earth/0000755000176200001440000000000013561510173011357 5ustar liggesusersearth/NAMESPACE0000644000176200001440000000343413443045532012603 0ustar liggesusersuseDynLib("earth") import(stats) importFrom(plotmo, plotmo.singles, plotmo.pairs, plotmo.y) importFrom(TeachingDemos, spread.labs) importFrom(Formula, Formula, model.part) export(contr.earth.response) export(earth) export(earth_plotmodsel) export(evimp) export(expand.bpairs) export(mars.to.earth) export(plot.earth.models) export(plotd) S3method(plotmo.singles, earth) S3method(plotmo.pairs, earth) S3method(plotmo.y, earth) S3method(plotmo.pairs, bagEarth) S3method(plotmo.y, bagEarth) S3method(anova, earth) S3method(case.names, earth) S3method(coef, earth) S3method(coef, varmod) S3method(deviance, earth) S3method(earth, default) S3method(earth, formula) S3method(effects, earth) S3method(extractAIC, earth) S3method(expand.bpairs, default) S3method(expand.bpairs, formula) S3method(family, earth) S3method(fitted, earth) S3method(fitted.values, earth) S3method(format, earth) S3method(format, lm) S3method(hatvalues, earth) S3method(model.matrix, earth) S3method(plot, earth) S3method(plot, earth.models) S3method(plot, evimp) S3method(plot, varmod) S3method(predict, earth) S3method(predict, varmod) S3method(print, earth) S3method(print, evimp) S3method(print, summary.earth) S3method(print, summary.varmod) S3method(print, varmod) S3method(resid, earth) S3method(residuals, earth) S3method(summary, earth) S3method(summary, varmod) S3method(update, earth) S3method(variable.names, earth) S3method(weights, earth) importFrom("grDevices", "as.graphicsAnnot", col2rgb, "heat.colors", "xy.coords") importFrom("graphics", "abline", "axis", "legend", "lines", "mtext", "par", "plot", "points", "polygon", "rect", "segments", "strheight", "strwidth", "text", "xinch", "yinch") importFrom("utils", "assignInMyNamespace", "flush.console", "head", "memory.size", "str") earth/data/0000755000176200001440000000000012506743405012274 5ustar liggesusersearth/data/etitanic.rda0000644000176200001440000001335612506743404014573 0ustar liggesusers M%GVoWۖ#K `4{n?̀f=`d{nc`5bz ~l#!$$ەol6GO=q?6g|q?l:Ϋ|,yu^W9_Wyu^WTL`cZej|96K7556rd;XOٜq5>LaMu3s ϗ9?9g)ol`ԳoKخi/xS~>ޖ6=ŭ594ɵ3ܽ%5汗4kms.;$ki)StӡCsp8O^tFM-iR۵s64dɇcnhҽe<㴵.g7eo)?cm38ZQ~mў~ss_]|הo|M_%;l%k?%;s8k.?rm)K>͵=$K8SmƸcSvb6祹ZR̦%>qMi.Fͽ5XOqqJg,qq -P\N&WQkpσshZV|5:/WbCwɗؗkrXCe._ɹ56.ڹ9$sƿ9sq=$tin!y6?Np?_8ާw?7^=qZߵۻo/o7O/rsñ||u,:-_ؾcwͱ ,6/;TƱ5{i3^vcve=^kwokS|4.;vmT~<Q{kj=^\^ߜ}]+߳+< _:r8>S/]O~6-SӸ4N5סѿ/?OP]{kW'o?W?OP<^<<-ߊ1>ow;wCoG:/~O+G}{^z~!?0;{nпGC;ڟu]9>[z)ngoOs{,Ng~KzuTW\{y+]?;}\o_~+}<ʍ{O*;S]:~ڿ9={/]O~_W^7=cgQ~pl/W﷿:-{_4>ӿ*oGq}}t¿L}r/zKdG;V)SX*nZo?;\g㈣xy[tّ~\ϫYf{Oy9?h]i=ZW8lI/Xg{l?]Qw)GN˛O8Sq5>*^^5q{|~xx^]G? ٕw-]i<}l1^jc#fjhl1;|GXsvmXT\펣㙳sǵ5~.ھvSxs_ϔTcؚ;4糝xV?ks"{ce`{燬yPmO̜S}סP2\:2&~S~/aO<-8ߗctH{ݟ!}m1b8)cNcm̍c?=aoM99Dc֬;^h=Z~:~_8ڜo}!1Ջ~Қa/>,KKksts|={2u.[9~k\v5Y? k1lq^CfN_]句'֌5}|}Nӧƶ scj~cmOvO~,ǒnw]~ZM{͘ΣGOK{}{ǩ~j<qy6 yu"ڱ][io'۝^/cYڽwcͽ ]oׅ⳻ӟ ֣MC(烿_Q䃏™ ܣo׶U*IJQTFm{-Zkj^ȡ#:rȡ#JuF6bmn#vۈFȩ#:^x㥎厗#玜;rȹ#i6rQ:rȥ#\:rȥ#\:rxՎW;J(Ԏz Zkuku֑[G:c0tC1tC1tC1tl\޸AuK5PTL-`[m5`jՀn7 8Dp##&"&"FLDLDL$L$L$L$L$L$F0111fp3n[p```nm5Bm>`bĀX0M4 4@M4 p3ܨTUL@y 7@y 7@ް 8@xqxqX o`l!: 7@yC<7dp!o o  o o1 xqǡ <8<8y & oF!o56#<8#<8#<8"!oE8#<2 xqGxqdiP:4Gawݑ9B#D=B#D=B#D=`G8Y#?B#?#p>GGD %,GGe<%(AdEBB($D!! QHBB$  %H(AB JXXЇ>$! }HCBЇ>$! }HCBЇ>$! }HCBЇ>$! }HCBЇ>$! }HCBЇ ! HHEB*RЇ>$!! QHBB JP$=AB($D!! %H(AB O?A 3?C 3?C 3?'(AF 2JQd %(AF 2JQd蟡g8!zg!z!zg!zg!zg!zg!zg!zg!zg!z=Ag8d蟡=AF 2JQ 3{d %(AF 2JdD!# QȈBF JPP%((AA JPP%((AA JPP%((AA JPD Q( PЇž (HEA* RQT (HEA* RQT (HEA* RQT (HEA* RQT (HEA* RQT}(CA PЇ>%((AA JPP%((AE BA*Pч>T}(AE *JPQT%(AE *JPQT%(AE *JPQT%(AE *JPQT%(AE *JPQT%(AE *JPQT%(AW8_|W8_|vW]awe#P!z0B+쮬FB +пB +p +Bm, 6`l n]oPAkPAkPAkPA|k|kj0j0AKhC 58PC 5ӊIԠS8e[iP/h06 C 24Xh,X6l`R7@ g`X4 ,u$X3@Hi 0 2Y=Y=^ $@*PL\Gw w w` THTԁzN>SjWLՃS7}{o0}{'i N2i?d N68S N18]vdf_bcЌfl5cf `5q `l ƖͥůpvSL=z1jԍ][NgW7L>o0yXo4}M]݌7 fW7cI'Ypgk3L×ek85ٚ0il`|kykykykykykyk6< &ɽ`r/ܰ}7շnl| &߂1~3ߌa0yȏHMN$?$Ս]!؍n4vM>j0yV!&'`r2 &?`t;&o`t;|"jlUch>?խ-3..]mӬ (ã`x]`͏Fh T4z={棻_}g~/#8earth/data/ozone1.rda0000644000176200001440000001451212506743404014201 0ustar liggesusers [^Wuǿ\ZPUt߽Pzo_h>2F%N_SwڷT\w[k :ޖMݾ+V_ɿT}1.6Q7evwmzs;˫Z>}~}< Qpb<߸wp&vZGUaG?QG.LZ?xYXf~`m3 (x`֎GwOT}}Ҏ><.|.vx;u?>[ku=bz`Ǜ8euz1a>޵| mn~Mkw<>.Q;G=zs18WkcFtMtsFg>a?##џڷUX~{ѯ@"MS#EDfeO}-c+;Q?5*ǚ1NYcQa;+7붾WEџ+뿽￰n뇽m7{}E//:U(u|0_1c&ogvXϬOX*|ԃC&oYn(񵢿^4Oalz;?|>o/kyÞѭ7u/b8s֎3|e^ =_5z|}X=}\=NczP~وc7XeRG N~dgW7U/;O8Εsgk+ο~.Wk82O]k|5k'y^oϋ5d76+_zOoG\˗8Wco-8zƫf_Mf\-]{SGwjs}ڽk-gm=X-^H\5w-XO\ڸQZO~,^:~%> +GW6s?bv^H_Mhw{LWݏ6xuJ\GD?!G>+;U1MNG}\<Z탾=s+vYF;ώW]*ޭߪU*2oR MU=Kc EoʾߎƗzB_ﶶ_O[v.z۰?k} ? qؠ/`ه܏37ȸ0ݩ$ۭ{;zY;풾Oz?ʢs9y1&?pďJ_Ge~}H/ y};?A.~do}yP.yk}\9}|8Xgܠ?1;EvPq~};ڍ:ۣߠO#IG1=#OE7c^>|~ͦO\A֡%\s< 1fX+>Rpw}qc}/Ε3jg=Egz?}۷磃ahC[ts~✍qACommc{7w qnz#$zs(q؉||v}{C3Gs>sn{(O_NApo {D|^0N>>8`? *s :S?7?7{hg9ǽ>>}=[Z?E}^o{"=~ìcǽb7^-qM|<yt}O'دc2| }SKT~ȭАK9󨗿+^n_wϊ';n" oR:zWϴ/_>@xjvnBs/~oَ>X}`=ݽ~G?~i\3 sEv|g'zn۷?r]Gw3ů}}TkWE>sb9c}Zϼ/]x`ٷ۷?_}# 9}__w,Ok|Ẋ\Dǧdҽx:=-EjӲٟ^~/o+y/|8'?3ѳIu-}_/m/QݏuqeŅ4NΫ,y鳬2q#nUٳ/=:?Y#AGO>{D{ qjm[^ ãsZ?/o+j]"}^~Xv[6nh<\=*ܧt77'|g~F+5n<}+xg+󱺯j?u[ZcW_67َV|zxu+^Z_e(~_/K֩6KןK'>tƸ=йU%LKk^=򟭄K=C{Q[K[P{GA{Kc{-rE7y|'ޛK>-xÎz*/؎ǑזW>ߥwknD r_ۛ+rɎv껎qïϨ̸xp/(~wJ>M+V5sїq?\5b8M򻟸 7Ңܛ|&a>1x>_'bPE$~^3_3 N]mCļ?ley{v1Oim Q-*_~Z߀~O^"?'ESb\Xǚ]GPniQ_;/E}=O/gW[iwk=7gc?-3~8c=?O߹`B1qN"?p}?Ժh~|.qJUO@EOQ@r9hد8O%.;/;zdOwKtY{~Y. R9:"=O;"coZw;J}?5[v#~k U磈SȝYwDuR=ѽjS=~0 S\iwP~L/<e])߱Y}O}w`o?y+!W9.ץeK_ kr;qd|A_ %UR|Pڙw|Kr}}즼='ѯ1т,}i_~ҋDαan7/ywy{TGgvΪ9~Gpgqeo7k_CPHGfN<~G|xog}o ӏqq>=y欞mܟ~8>eع|O})}jr3Jf(~r鏟jz ~8~v?sջ?M=Vx(e \|Oee?0^x_0cˎSWj8α<5?\gWf.~ǪrO({2sȻ_kq}m}oO|?owYm_s?_Q)כz~*yy]U}q'u=jߣ;={Cӹϓg[w{7{T3FU?o7soOj'G{uQw^s&<>OOގ<2Ͻ~GOxǽs&E<bܷÐ/$qH8ȷ߇%%oE'?,~Q"$~NGOCuωN_"#~}"o({=?y/a|1_#L#/IBx[=u.ʮE}ߢw݋_"y{/ I$%/ |}?$%/ IK=/K/K/K/K/˾eWZފ[[W"=W"E+_* U_W*|]W*U ? '?|K뷾[VչsKҶtg+s䃦;N^tl^6C%/a &yaFh|lq,q"'q*m4Fm4Fm4Fm4Fm4F$ZIh%JD+V$ZI&њDkI&њDkI&њDKDKDKDKDKDODODODODODHDHDHDHDHDLDLDLDLDLDJDJDJDJDJDNDNDNDNDN%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%%cIXR2%Mƒ&cIXd,i24K%Mƒ&cIXd,i24K%Mƒ&cIXd,i24K%Mƒ&cIXd,i24oŒs\9/S]{ 7 W _Z ~Kvearth/man/0000755000176200001440000000000013443754222012136 5ustar liggesusersearth/man/summary.earth.Rd0000644000176200001440000000742313427162410015224 0ustar liggesusers\name{summary.earth} \alias{summary.earth} \alias{print.summary.earth} \title{Summary method for earth objects} \description{ Summary method for \code{\link{earth}} objects. } \usage{ \method{summary}{earth}(object = stop("no 'object' argument"), details = FALSE, style = c("h", "pmax", "max", "C", "bf"), decomp = "anova", digits = getOption("digits"), fixed.point=TRUE, newdata = NULL, \dots) \method{print}{summary.earth}(x = stop("no 'x' argument"), details = x$details, decomp = x$decomp, digits = x$digits, fixed.point = x$fixed.point, newdata = x$newdata, \dots) } \arguments{ \item{object}{ An \code{\link{earth}} object. This is the only required argument for \code{summary.earth}. } \item{x}{ A \code{\link{summary.earth}} object. This is the only required argument for \code{print.summary.earth}. } \item{details}{ Default is \code{FALSE}. Use \code{TRUE} to print more information about \code{\link{earth}}--\code{\link{glm}} models. But note that the displayed Standard Errors and statistics for the GLM coefficients are meaningless (because of the amount of preprocessing done by earth to select the regression terms). } \item{style}{ Formatting style. One of\cr \code{"h"} (default) more compact\cr \code{"pmax"} for those who prefer it and for compatibility with old versions of earth\cr \code{"max"} is the same as \code{"pmax"} but prints \code{max} rather than \code{pmax}\cr \code{"C"} C style expression with zero based indexing\cr \code{"bf"} basis function format. } \item{decomp}{ Specify how terms are ordered. Default is \code{"anova"}. Use \code{"none"} to order the terms as created by the forward.pass. See \code{\link{format.earth}} for a full description. } \item{digits}{ The number of significant digits.\cr For \code{summary.earth}, the default is \code{getOption("digits")}.\cr For \code{print.summary.earth}, the default is the \code{$digits} component of \code{object}. } \item{fixed.point}{ Method of printing numbers in matrices. Default is \code{TRUE} which prints like this (making it easier to compare coefficients):\preformatted{ (Intercept) 15.029 h(temp-58) 0.313 h(234-ibt) -0.046 ... } whereas \code{fixed.point=FALSE} prints like this (which is more usual in R):\preformatted{ (Intercept) 1.5e+01 h(temp-58) 3.1e-01 h(234-ibt) -4.6e-02 ... } Matrices with two or fewer rows are never printed with a fixed point. } \item{newdata}{ Default \code{NULL}.\cr Else print R-Squared for the new data (and the returned object will have \code{newrsq} and \code{newdata} fields). Additionally, if a variance model is present print the interval coverage table for the new data.\cr } \item{\dots}{ Extra arguments are passed to \code{\link{format.earth}}. } } \value{ The value is the same as that returned by \code{\link{earth}} but with the following extra components.\cr \item{strings}{ String(s) created by \code{\link{format.earth}}. For multiple response models, a vector of strings. } \item{newrsq}{Only if \code{newdata} was passed to \code{summary.earth}.} \item{newdata}{Only if \code{newdata} was passed to \code{summary.earth}.} \item{digits}{} \item{details}{} \item{decomp}{} \item{fixed.point}{The corresponding arguments, passed on to \code{print.summary.earth}.} } \note{ The printed \code{Estimated importance} uses \code{\link{evimp}} with the \code{nsubsets} criterion. The most important predictor is printed first, and so on. } \seealso{ \code{\link{earth}}, \code{\link{evimp}}, \code{\link{format.earth}} } \examples{ earth.mod <- earth(Volume~ ., data = trees) summary(earth.mod, digits = 2) } \keyword{models} earth/man/varmod.Rd0000644000176200001440000001060612510266234013713 0ustar liggesusers\name{varmod} \alias{varmod} \alias{summary.varmod} \title{Variance models for estimating prediction intervals} \description{ A \emph{variance model} estimates the variance of predicted values. It can be used to estimate prediction intervals. See the \code{interval} argument of \code{\link{predict.earth}}. A variance model is built by \code{earth} if \code{earth}'s \code{varmod.method} argument is specified. Results are stored in the \code{$varmod} field of the \code{earth} model. See the vignette \dQuote{\href{../doc/earth-varmod.pdf}{Variance models in earth}} for details. You probably won't need to directly call \code{print.varmod} or \code{summary.varmod}. They get called internally by \code{\link{summary.earth}}. } \usage{ \method{summary}{varmod}( object = stop("no 'object' argument"), level = .95, style = "standard", digits = 2, newdata = NULL, \dots) } \arguments{ \item{object}{ A \code{varmod} object. This is the only required argument. } \item{level}{ Same as \code{predict.earth}'s \code{level} argument. } \item{style}{ Determines how the coefficients of the \code{varmod} are printed by \code{summary.varmod}:\cr \code{"standard"} (default)\cr \code{"unit"} for easy comparison normalize the coefficients by dividing by the first coefficient. } \item{digits}{ Number of digits to print. Default is \code{2}. } \item{newdata}{ Default \code{NULL}.\cr Else print the interval coverage table for the new data. } \item{\dots}{ Dots are passed on. } } \note{ A \code{"varmod"} object has the following fields: \itemize{ \item{\code{call}} The call used internally in the parent model to build the \code{varmod} object. \item{\code{parent}} The parent \code{earth} model. \item{\code{method}} Copy of the \code{varmod.method} argument to the parent model. \item{\code{package}} NULL, unless \code{method="gam"}, in which case either \code{"gam"} or \code{"mgcv"}. \item{\code{exponent}} Copy of the \code{varmod.exponent} argument to the parent model. \item{\code{lambda}} Currently always 1, meaning use absolute residuals. \item{\code{rmethod}} Currently always "hc2", meaning correct the residuals with \code{1/(1-h_ii)}. \item{\code{converged}} Did the residual submodel IRLS converge? \item{\code{iters}} Number of residual model IRLS iterations (1 to 50). \item{\code{residmod}} The residual submodel. So for example, if \code{varmod.method="lm"}, this will be an \code{lm} object. \item{\code{min.sd}} The predicted residual standard deviation is clamped so it will always be at least this value. This prevents prediction of negative or absurdly small variances. See \code{earth}'s \code{varmod.clamp} argument. Clamping takes place in \code{predict.varmod}, which is called by \code{predict.earth} when estimating prediction intervals. \item{\code{model.var}} An n x 1 matrix. The \code{model.var} for an observation is the estimated model variance for that observation over all datasets, and is estimated with repeated cross validation. It is the variance of the mean out-of-fold prediction for that observation over \code{ncross} repetitions. \item{\code{abs.resids}} An n x 1 matrix. The absolute residuals used to build the residual model. \item{\code{parent.x}} { An n x p matrix. Parent earth model \code{x}. } \item{\code{parent.y}} { An n x 1 matrix. Parent earth model \code{y}. } \item{\code{iter.rsq}} { Weighted R-Squared of residual submodel \code{residmod}, after IRLS iteration. } \item{\code{iter.stderr}} { Standard errors of the coefficients of the residual submodel \code{residmod}, after IRLS iteration. } } } \examples{ data(ozone1) set.seed(1) # optional, for cross validation reproducibility # note: should really use ncross=30 below but for a quick demo we don't earth.mod <- earth(O3~temp, data=ozone1, nfold=10, ncross=3, varmod.method="lm") print(summary(earth.mod)) # note additional info on the variance model old.mfrow <- par(mfrow=c(2,2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0)) plotmo(earth.mod, do.par=FALSE, response.col=1, level=.90, main="earth model: O3~temp") plot(earth.mod, which=3, level=.90) # residual plot: note 90% pred and darker conf intervals par(par=old.mfrow) } \seealso{ \code{\link{plot.varmod}}, \code{\link{predict.varmod}} } earth/man/predict.earth.Rd0000644000176200001440000001203113425430365015155 0ustar liggesusers\name{predict.earth} \alias{predict.earth} \title{Predict with an earth model} \description{ Predict with an \code{\link{earth}} model. } \usage{ \method{predict}{earth}(object = stop("no 'object' argument"), newdata = NULL, type = c("link", "response", "earth", "class", "terms"), interval = "none", level = .95, thresh = .5, trace = FALSE, \dots) } \arguments{ \item{object}{ An \code{\link{earth}} object. This is the only required argument. } \item{newdata}{ Make predictions using \code{newdata}, which can be a data frame, a matrix, or a vector with length equal to a multiple of the number of columns of the original input matrix \code{x}.\cr Default is NULL, meaning return values predicted from the training set.\cr NAs are allowed in \code{newdata} (and the predicted value will be NA unless the NAs are in variables that are unused in the earth model). } \item{type}{ Type of prediction. One of \code{"link"} (default), \code{"response"}, \code{"earth"}, \code{"class"}, or \code{"terms"}. See the \bold{Note} below. } \item{interval}{ Return prediction or confidence levels. Default is \code{"none"}. Use \code{interval="pint"} to get prediction intervals on new data. \cr Requires that the earth model was built with \code{varmod.method}. \cr This argument gets passed on as the \code{type} argument to \code{\link{predict.varmod}}. See its help page for details. } \item{level}{ Confidence level for the \code{interval} argument. Default is \code{0.95}, meaning construct 95\% confidence bands (estimate the 2.5\% and 97.5\% levels). } \item{thresh}{ Threshold, a value between 0 and 1 when predicting a probability. Only applies when \code{type="class"}. Default is 0.5. See the \bold{Note} below. } \item{trace}{ Default \code{FALSE}. Set to \code{TRUE} to see which data, subset, etc. \code{predict.earth} is using. } \item{\dots}{ Unused, but provided for generic/method consistency. } } \value{ The predicted values (a matrix for multiple response models). If \code{type="terms"}, a matrix with each column showing the contribution of a predictor. If \code{interval="pint"} or \code{"cint"}, a matrix with three columns:\cr \code{fit}: the predicted values\cr \code{lwr}: the lower confidence or prediction limit\cr \code{upr}: the upper confidence or prediction limit If \code{interval="se"}, the standard errors. } \note{ \bold{Predicting with standard earth models} Use the default \code{type="link"}, or possibly \code{type="class"}. Actually, the \code{"link"}, \code{"response"}, and \code{"earth"} choices all return the same value unless the \code{glm} argument was used in the original call to \code{\link{earth}}. \bold{Predicting with earth-GLM models} This section applies to earth models with a GLM component, i.e., when the \code{glm} argument was used in the original call to \code{\link{earth}}. The \code{"link"} and \code{"response"} options: see \code{\link{predict.glm}} for a description of these. In brief: for logistic models use \code{type="response"} to get probabilities, and \code{type="link"} to get log-odds. Use option \code{"earth"} to get the linear fit (this gives the prediction you would get if your original call to earth had no \code{glm} argument). \bold{Predicting with "class"} Use option \code{"class"} to get the predicted class. With option \code{"class"}, this function first makes predictions with \code{type="response"} and then assigns the predicted values to classes as follows: (i) When the response is a \emph{logical}, predict \code{TRUE} if the predicted probability is greater than \code{thresh} (default \code{0.5}). (ii) When the response is a \emph{numeric}, predict \code{TRUE} if the predicted value is greater than \code{thresh}. Actually, this is identical to the above case, although \code{thresh} here may legitimately be a value outside the 0...1 range. (iii) When the response is a \emph{two level factor}, predict the second level if its probability is more than \code{thresh}. In other words, with the default \code{thresh=0.5} predict the most probable level. (iv) When the response is a \emph{three or more level factor}, predict the most probable level (and \code{thresh} is ignored). \bold{Predicting with "terms"} The \code{"terms"} option returns a \code{"link"} response suitable for \code{\link{termplot}}. Only the additive terms and the first response (for multi-response models) are returned. Also, \code{"terms"} always returns the earth terms, and ignores the GLM component of the model, if any. } \seealso{ \code{\link{earth}}, \code{\link{predict}} } \examples{ data(trees) earth.mod <- earth(Volume ~ ., data = trees) predict(earth.mod) # same as earth.mod$fitted.values predict(earth.mod, data.frame(Girth=10, Height=80)) # yields 17.6 predict(earth.mod, c(10,80)) # equivalent } \keyword{models} earth/man/plotd.Rd0000644000176200001440000003310713402562667013560 0ustar liggesusers\name{plotd} \alias{plotd} \title{Plot the distribution of predictions for each class} \description{ Plot the distribution of the predicted values for each class. Can be used for \code{\link[earth]{earth}} models, but also for models built by \code{\link{lm}}, \code{\link{glm}}, \code{\link[MASS]{lda}}, etc. } \usage{ plotd(object, hist = FALSE, type = NULL, nresponse = NULL, dichot = FALSE, trace = FALSE, xlim = NULL, ylim = NULL, jitter = FALSE, main=NULL, xlab = "Predicted Value", ylab = if(hist) "Count" else "Density", lty = 1, col = c("gray70", 1, "lightblue", "brown", "pink", 2, 3, 4), fill = if(hist) col[1] else 0, breaks = "Sturges", labels = FALSE, kernel = "gaussian", adjust = 1, zero.line = FALSE, legend = TRUE, legend.names = NULL, legend.pos = NULL, cex.legend = .8, legend.bg = "white", legend.extra = FALSE, vline.col = 0, vline.thresh = .5, vline.lty = 1, vline.lwd = 1, err.thresh = vline.thresh, err.col = 0, err.border = 0, err.lwd = 1, xaxt = "s", yaxt = "s", xaxis.cex = 1, sd.thresh = 0.01, ...) } \arguments{ To start off, look at the arguments \code{object}, \code{hist}, \code{type}.\cr For predict methods with multiple column responses, see the \code{nresponse} argument.\cr For factor responses with more than two levels, see the \code{dichot} argument. \item{object}{ Model object. Typically a model which predicts a class or a class discriminant. } \item{hist}{ \code{FALSE} (default) to call \code{\link{density}} internally.\cr \code{TRUE} to call \code{\link{hist}} internally. } \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{plotd} tries to automatically select a suitable value for the model in question. (This is \code{"response"} for all objects except \code{rpart} models, where \code{"vector"} is used. The choices will often be inappropriate.) Typically you would set \code{hist=TRUE} when \code{type="class"}. } \item{nresponse}{ Which column to use when \code{predict} returns multiple columns. This can be a column index or column name (which may be abbreviated, partial matching is used). The default is \code{NULL}, meaning use all columns of the predicted response. } \item{dichot}{ Dichotimise the predicted response. This argument is ignored except for models where the observed response is a factor with more than two levels and the predicted response is a numeric vector. The default \code{FALSE} separates the response into a group for each factor. With \code{dichot=TRUE} the response is separated into just two groups: the first level of the factor versus the remaining levels. } \item{trace}{ Default \code{FALSE}. Use \code{TRUE} or \code{1} to trace \code{plotd} --- useful to see how \code{plotd} partitions the predicted response into classes. Use \code{2} for more details. } \item{xlim}{ Limits of the x axis. The default \code{NULL} means determine these limits automatically, else specify \code{c(xmin,xmax)}. } \item{ylim}{ Limits of the y axis. The default \code{NULL} means determine these limits automatically, else specify \code{c(ymin,ymax)}. } \item{jitter}{ Jitter the histograms or densities horizontally to minimize overplotting. Default \code{FALSE}. Specify \code{TRUE} to automatically calculate the jitter, else specify a numeric jitter value. } \item{main}{ Main title. Values:\cr \code{"string"} string\cr \code{""} no title\cr \code{NULL} (default) generate a title from the call. } \item{xlab}{ x axis label. Default is \code{"Predicted Value"}. } \item{ylab}{ y axis label. Default is \code{if(hist) "Count" else "Density"}. } \item{lty}{ Per class line types for the plotted lines. Default is 1 (which gets recycled for all lines). } \item{col}{ Per class line colors. The first few colors of the default are intended to be easily distinguishable on both color displays and monochrome printers. } \item{fill}{ Fill color for the plot for the first class. For \code{hist=FALSE}, the default is 0, i.e., no fill. For \code{hist=TRUE}, the default is the first element in the \code{col} argument. } \item{breaks}{ Passed to \code{\link{hist}}. Only used if \code{hist=TRUE}. Default is \code{"Sturges"}. When \code{type="class"}, setting \code{breaks} to a low number can be used to widen the histogram bars } \item{labels}{ \code{TRUE} to draw counts on the \code{\link{hist}} plot. Only used if \code{hist=TRUE}. Default is \code{FALSE}. } \item{kernel}{ Passed to \code{\link{density}}. Only used if \code{hist=FALSE}. Default is \code{"gaussian"}. } \item{adjust}{ Passed to \code{\link{density}}. Only used if \code{hist=FALSE}. Default is \code{1}. } \item{zero.line}{ Passed to \code{\link{plot.density}}. Only used if \code{hist=FALSE}. Default is \code{FALSE}. } \item{legend}{ \code{TRUE} (default) to draw a legend, else \code{FALSE}. } \item{legend.names}{ Class names in legend. The default \code{NULL} means determine these automatically. } \item{legend.pos}{ Position of the legend. The default \code{NULL} means position the legend automatically, else specify \code{c(x,y)}. } \item{cex.legend}{ \code{cex} for \code{\link[graphics]{legend}}. Default is \code{.8}. } \item{legend.bg}{ \code{bg} color for \code{\link[graphics]{legend}}. Default is \code{"white"}. } \item{legend.extra}{ Show (in the legend) the number of occurrences of each class. Default is \code{FALSE}. } \item{vline.thresh}{ Horizontal position of optional vertical line. Default is \code{0.5}. The vertical line is intended to indicate class separation. If you use this, don't forget to set \code{vline.col}. } \item{vline.col}{ Color of vertical line. Default is 0, meaning no vertical line. } \item{vline.lty}{ Line type of vertical line. Default is \code{1}. } \item{vline.lwd}{ Line width of vertical line. Default is \code{1}. } \item{err.thresh}{ x axis value specifying the error shading threshold. See \code{err.col}. Default is \code{vline.thresh}. } \item{err.col}{ Specify up to three colors to shade the "error areas" of the density plot. The default is \code{0}, meaning no error shading. This argument is ignored unless \code{hist=FALSE}. If there are more than two classes, \code{err.col} uses only the first two. This argument is best explained by running an example:\preformatted{ data(etitanic) earth.mod <- earth(survived ~ ., data=etitanic) plotd(earth.mod, vline.col=1, err.col=c(2,3,4)) } The three areas are (i) the error area to the left of the threshold, (ii) the error area to the right of the threshold, and, (iii) the reducible error area. If less than three values are specified, \code{plotd} re-uses values in a sensible manner. Use values of \code{0} to skip areas. Disjoint regions are not handled well by the current implementation. } \item{err.border}{ Borders around the error shading. Default is \code{0}, meaning no borders, else specify up to three colors. } \item{err.lwd}{ Line widths of borders of the error shading. Default is \code{1}, else specify up to three line widths. } \item{xaxt}{ Default is \code{"s"}. Use \code{xaxt="n"} for no x axis. } \item{yaxt}{ Default is \code{"s"}. Use \code{yaxt="n"} for no y axis. } \item{xaxis.cex}{ Only used if \code{hist=TRUE} and \code{type="class"}. Specify size of class labels drawn on the x axis. Default is 1. } \item{sd.thresh}{ Minimum acceptable standard deviation for a density. Default is \code{0.01}. Densities with a standard deviation less than \code{sd.thresh} will not be plotted (a warning will be issued and the legend will say \code{"not plotted"}). } \item{\dots}{ Extra arguments passed to the predict method for the object. } } \note{ This function calls \code{\link{predict}} with the data originally used to build the model, and with the \code{type} specified above. It then separates the predicted values into classes, where the class for each predicted value is determined by the class of the observed response. Finally, it calls \code{\link{density}} (or \code{\link{hist}} if \code{hist=TRUE}) for each class-specific set of values, and plots the results. This function estimates distributions with the \code{\link{density}} and \code{\link{hist}} functions, and also calls \code{\link{plot.density}} and \code{\link{plot.histogram}}. For an overview see Venables and Ripley MASS section 5.6. \bold{Partitioning the response into classes} Considerable effort is made to partition the predicted response into classes in a sensible way. This is not always possible for multiple column responses and the \code{nresponse} argument should be used where necessary. The partitioning details depend on the types and numbers of columns in the observed and predicted responses. These in turn depend on the model object and the \code{type} argument. Use the \code{trace} argument to see how \code{plotd} partitions the response for your model. \bold{Degenerate densities} A message such as\cr \code{Warning: standard deviation of "male" density is 0, density is degenerate?}\cr means that the density for that class will not be plotted (the legend will say \code{"not plotted"}). Set \code{sd.thresh=0} to get rid of this check, but be aware that histograms (and sometimes x axis labels) for degenerate densities will be misleading. \bold{Using plotd for various models} This function is included in the \code{\link[earth]{earth}} package but can also be used with other models. Example with \code{\link{glm}}: \preformatted{ library(earth); data(etitanic) glm.model <- glm(sex ~ ., data=etitanic, family=binomial) plotd(glm.model) } Example with \code{\link{lm}}:\preformatted{ library(earth); data(etitanic) lm.model <- lm(as.numeric(sex) ~ ., data=etitanic) plotd(lm.model) } % Example with \code{\link[rpart]{rpart}}:\preformatted{ % library(rpart); library(earth); data(etitanic) % rpart.model <- rpart(sex ~ ., data = etitanic, method="class") % plotd(rpart.model, type="prob", nresponse=1) % plotd(rpart.model, type="prob", nresponse=2) % plotd(rpart.model, type="class", hist=TRUE, labels=TRUE) % } \bold{Using plotd with lda or qda} The \code{plotd} function has special handling for \code{\link[MASS]{lda}} (and \code{\link[MASS]{qda}}) objects. For such objects, the \code{type} argument can take one of the following values: \code{"response"} (default) linear discriminant\cr \code{"ld"} same as \code{"response"}\cr \code{"class"} predicted classes\cr \code{"posterior"} posterior probabilities Example:\preformatted{ library(MASS); library(earth); data(etitanic) lda.model <- lda(sex ~ ., data=etitanic) plotd(lda.model) # linear discriminant by default plotd(lda.model, type="class", hist=TRUE, labels=TRUE) } This handling of \code{type} is handled internally by \code{plotd} and \code{type} is not passed to \code{predict.lda} (\code{type} is used merely to select fields in the list returned by \code{predict.lda}). The type names can be abbreviated down to a single character. For objects created with \code{lda.matrix} (as opposed to \code{lda.formula}), \code{plotd} blindly assumes that the \code{grouping} argument was the second argument. \code{plotd} does not yet support objects created with \code{lda.data.frame}. For \code{lda} responses with more than two factor levels, use the \code{nresponse} argument to select a column in the predicted response. Thus with the default \code{type=NULL}, (which gets automatically converted by \code{plotd} to \code{type="response"}), use \code{nresponse=1} to select just the first linear discriminant. The default \code{nresponse=NULL} selects all columns, which is typically not what you want for \code{lda} models. Example:\preformatted{ library(MASS); library(earth); set.seed(1) # optional, for reproducibility example(lda) # creates a model called "z" plot(z, dimen=1) # invokes plot.lda from the MASS package plotd(z, nresponse=1, hist=1) # equivalent using plotd # nresponse=1 selects first linear discr. } The \code{dichot=TRUE} argument is also useful for \code{lda} responses with more than two factor levels.\cr \bold{TODO} Handle degenerate densities in a more useful way.\cr Add \code{freq} argument for \code{\link{hist}}. } \seealso{ \code{\link{density}}, \code{\link{plot.density}}\cr \code{\link{hist}}, \code{\link{plot.histogram}}\cr \code{\link[earth]{earth}}, \code{\link[earth]{plot.earth}} } \examples{ if (require(earth)) { old.par <- par(no.readonly=TRUE); par(mfrow=c(2,2), mar=c(4, 3, 1.7, 0.5), mgp=c(1.6, 0.6, 0), par(cex = 0.8)) data(etitanic) mod <- earth(survived ~ ., data=etitanic, degree=2, glm=list(family=binomial)) plotd(mod) plotd(mod, hist=TRUE, legend.pos=c(.25,220)) plotd(mod, hist=TRUE, type="class", labels=TRUE, xlab="", xaxis.cex=.8) par(old.par) } } \keyword{models} earth/man/ozone1.Rd0000644000176200001440000000365112755624314013650 0ustar liggesusers\name{ozone1} \alias{ozone1} \title{Ozone readings in Los Angeles with incomplete cases removed} \description{ Ozone readings in Los Angeles, with incomplete cases removed.} \format{ A data frame with 330 observations on 10 variables. \tabular{ll}{ \code{O3} \tab daily maximum of the hourly average ozone concentrations in Upland, CA\cr \code{vh} \tab 500 millibar pressure height, measured at the Vandenberg air force base\cr \code{wind} \tab wind speed in mph at LAX airport\cr \code{humidity} \tab humidity in percent at LAX\cr \code{temp} \tab Sandburg Air Force Base temperature in degrees Fahrenheit\cr \code{ibh} \tab temperature inversion base height in feet\cr \code{dpg} \tab pressure gradient from LAX to Daggert in mm Hg\cr \code{ibt} \tab inversion base temperature at LAX in degrees Fahrenheit\cr \code{vis} \tab visibility at LAX in miles\cr \code{doy} \tab day of the year\cr } } \source{ This dataset was copied from \code{library(faraway)} and the name changed to \code{ozone1} to prevent a name clash. The data were originally made available by Leo Breiman who was a consultant on a project where the data were generated. Example analyses using these data may be found in Faraway and in Hastie and Tibshirani. \preformatted{ > ozone1 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 ... 330 1 5550 4 85 39 5000 8 44 100 390 } } \references{ Faraway (2005) \emph{Extending the Linear Model with R} \url{http://www.maths.bath.ac.uk/~jjf23} Hastie and Tibshirani (1990) \emph{Generalized Additive Models} \url{http://web.stanford.edu/~hastie/pub.htm} } \seealso{ \code{\link{earth}} \code{\link[datasets]{airquality}} a different set of ozone data } \keyword{datasets} earth/man/plot.earth.models.Rd0000644000176200001440000000666012531326141015767 0ustar liggesusers\name{plot.earth.models} \alias{plot.earth.models} \title{Compare earth models by plotting them.} \description{ Compare \code{\link{earth}} models by plotting them. } \usage{ \method{plot}{earth.models}(x = stop("no 'x' argument"), which = c(1:2), caption = "", jitter = 0, col.grsq = discrete.plot.cols(length(objects)), lty.grsq = 1, col.rsq = 0, lty.rsq = 5, col.vline = col.grsq, lty.vline = "12", col.npreds = 0, lty.npreds = 2, legend.text = NULL, do.par = NULL, trace = 0, \dots) } \arguments{ \item{x}{ A list of one or more \code{\link{earth}} objects, or a single \code{\link{earth}} object. This is the only required argument. (This argument is called 'x' for consistency with the generic \code{\link{plot}}.) } \item{which}{ Which plots to plot: 1 model, 2 cumulative distribution of residuals. Default is \code{1:2}, meaning both. } \item{caption}{ Overall caption. Values:\cr \code{"string"} string\cr \code{""} (default) no caption\cr \code{NULL} generate a caption from the \code{$call} component of the \code{earth} objects. } \item{jitter}{ Jitter applied to GRSq and RSq values to minimize over-plotting. Default is \code{0}, meaning no jitter. A typical useful value is 0.01. \cr \cr \emph{For the col arguments below, 0 means do not plot the corresponding graph element. You can use vectors of colors.} } \item{col.grsq}{ Vector of colors for the GRSq plot. The default is \code{discrete.plot.cols(length(x))} which is vector of distinguishable colors, the first three of which are also distinguishable on a monochrome printer. You can examine the colors using\cr \code{earth:::discrete.plot.cols()}. } \item{lty.grsq}{ Line type for the GRSq plot. Default is \code{1}. } \item{col.rsq}{ Vector of colors for the RSq plot. Default is \code{0}, meaning no RSq plot. } \item{lty.rsq}{ Line type for the RSq plot. Default is \code{5}. } \item{col.vline}{ A vertical line is drawn for each object to show which model size was chosen for that object. The color of the line is \code{col.vline}. Default is \code{col.grsq}. } \item{lty.vline}{ Line type of vertical lines (a vertical line is drawn to show the selected model for each object). Can be a vector. Default is \code{3}. } \item{col.npreds}{ Vector of colors for the "number of predictors" plot within the model selection plot. Default is \code{0}, meaning no "number of predictors" plot. The special value \code{NULL} means borrow \code{col.grsq} (or \code{col.rsq} if \code{col.grsq} is \code{NULL}). } \item{lty.npreds}{ Line type of the "number of predictors" plot (in the Model Selection plot). Default is \code{2}. } \item{legend.text,do.par,trace}{Please see \code{\link[plotmo]{plotres}} } \item{\dots}{Please see \code{\link[plotmo]{plotres}} } } \note{ This function ignores GLM and cross-validation components of the earth model, if any. } \seealso{ \code{\link{earth}}, \code{\link{plot.earth}}, \code{\link{plot.earth.models}}, \code{\link[earth]{plotd}}, \code{\link[plotmo]{plotmo}} } \examples{ data(ozone1) a1 <- earth(O3 ~ ., data = ozone1, degree = 2) a2 <- earth(O3 ~ .-wind, data = ozone1, degree = 2) a3 <- earth(O3 ~ .-humidity, data = ozone1, degree = 2) plot.earth.models(list(a1,a2,a3), ylim=c(.65,.85)) } \keyword{models} earth/man/plot.varmod.Rd0000644000176200001440000000440713000465665014676 0ustar liggesusers\name{plot.varmod} \alias{plot.varmod} \title{Plot a varmod object (created by calling earth with the varmod argument)} \description{ Plot a variance model (a \code{varmod} object). Typically you call this function for a variance model embedded in an \code{earth} model. } \usage{ \method{plot}{varmod}(x = stop("no 'x' argument"), which = 1:4, do.par = NULL, info=FALSE, cex = NULL, caption = NULL, line.col = 2, min.sd.col = line.col, trace = 0, \dots) } \arguments{ \item{x}{ A \code{varmod} object. Typically this is embedded in a parent \code{earth} object, and so you invoke this function with \code{plot(earth.mod$varmod)}. The \code{varmod.method} argument must have been specified when building the \code{earth} model. } \item{which}{ Which plots to plot. Default is 1:4 meaning all. The term \emph{parent} below refers to the \code{earth} model in which the \code{varmod} is embedded.\cr 1) fitted vs parent fitted\cr 2) fitted vs parent first predictor\cr 3) residuals vs fitted\cr 4) model selection graph (only when \code{varmod.method="earth"} or \code{"x.earth"}).\cr } \item{do.par}{Please see \code{\link[plotmo]{plotres}} } \item{info}{ Plot some additional information, including lowess fits in the first two plots. } \item{cex}{ Character expansion. } \item{caption}{ Default is NULL, meaning automatically generate an overall caption. } \item{line.col}{ Color of lines in the plots. Default is \code{red}. } \item{min.sd.col}{ Color of the \code{min.sd} dotted horizontal line. Default is \code{line.col}. Use \code{0} to not plot this line. } \item{trace,\dots}{Similar to \code{\link[plotmo]{plotres}} } } \note{ The horizontal red dotted line in the first two plots shows the value of \code{min.sd}. See \code{\link{earth}}'s \code{varmod.clamp} argument. } \examples{ data(ozone1) set.seed(1) # optional, for cross validation reproducibility # note: should really use ncross=30 below but for a quick demo we don't earth.mod <- earth(O3~temp, data=ozone1, nfold=10, ncross=3, varmod.method="lm") plot(earth.mod$varmod) # plot the embedded variance model (this calls plot.varmod) } \seealso{ \code{\link{varmod}} } earth/man/earth.Rd0000644000176200001440000007134313445511057013537 0ustar liggesusers\name{earth} \alias{earth} \alias{earth.default} \alias{earth.formula} \alias{earth.fit} \concept{regression} \concept{mars} \concept{Friedman} \title{Multivariate Adaptive Regression Splines} \description{ Build a regression model using the techniques in Friedman's papers "Multivariate Adaptive Regression Splines" and "Fast MARS". See the package vignette \dQuote{\href{../doc/earth-notes.pdf}{Notes on the earth package}}. } \usage{ \method{earth}{formula}(formula = stop("no 'formula' argument"), data = NULL, weights = NULL, wp = NULL, subset = NULL, na.action = na.fail, pmethod = c("backward", "none", "exhaustive", "forward", "seqrep", "cv"), keepxy = FALSE, trace = 0, glm = NULL, degree = 1, nprune = NULL, nfold=0, ncross=1, stratify=TRUE, varmod.method = "none", varmod.exponent = 1, varmod.conv = 1, varmod.clamp = .1, varmod.minspan = -3, Scale.y = NULL, \dots) \method{earth}{default}(x = stop("no 'x' argument"), y = stop("no 'y' argument"), weights = NULL, wp = NULL, subset = NULL, na.action = na.fail, pmethod = c("backward", "none", "exhaustive", "forward", "seqrep", "cv"), keepxy = FALSE, trace = 0, glm = NULL, degree = 1, nprune = NULL, nfold=0, ncross=1, stratify=TRUE, varmod.method = "none", varmod.exponent = 1, varmod.conv = 1, varmod.clamp = .1, varmod.minspan = -3, Scale.y = NULL, \dots) \method{earth}{fit}(x = stop("no 'x' argument"), y = stop("no 'y' argument"), weights = NULL, wp = NULL, subset = NULL, na.action = na.fail, offset = NULL, pmethod = c("backward", "none", "exhaustive", "forward", "seqrep", "cv"), keepxy = FALSE, trace = 0, glm = NULL, degree = 1, penalty = if(degree > 1) 3 else 2, nk = min(200, max(20, 2 * ncol(x))) + 1, thresh = 0.001, minspan = 0, endspan = 0, newvar.penalty = 0, fast.k = 20, fast.beta = 1, linpreds = FALSE, allowed = NULL, nprune = NULL, Object = NULL, Scale.y = NULL, Adjust.endspan = 2, Auto.linpreds = TRUE, Force.weights = FALSE, Use.beta.cache = TRUE, Force.xtx.prune = FALSE, Get.leverages = NROW(x) < 1e5, Exhaustive.tol = 1e-10, \dots) } \arguments{ To start off, look at the arguments \code{formula}, \code{data}, \code{x}, \code{y}, \code{nk}, \code{degree}, and \code{trace}. \cr If the response is binary or a factor, consider using the \code{glm} argument.\cr For cross validation, use the \code{nfold} argument.\cr For prediction intervals, use the \code{varmod.method} argument.\cr \cr Most users will find that the above arguments are all they need, plus in some cases \code{keepxy} and \code{nprune}. Unless you are a knowledgeable user, it's best not subvert the standard algorithm by toying with tuning parameters such as \code{thresh}, \code{penalty}, and \code{endspan}. \cr \item{formula}{ Model formula. } \item{data}{ Data frame for \code{formula}. } \item{x}{ Matrix or dataframe containing the independent variables. } \item{y}{ Vector containing the response variable, or, in the case of multiple responses, a matrix or dataframe whose columns are the values for each response. } \item{subset}{ Index vector specifying which cases to use, i.e., which rows in \code{x} to use. Default is NULL, meaning all. } \item{weights}{ Case weights. Default is NULL, meaning no case weights. If specified, \code{weights} must have length equal to \code{nrow(x)} before applying \code{subset}. Zero weights are converted to a very small nonzero value. In the current implementation, building models with weights can be slow. % Following the precedent set by \code{lm}, \code{earth} first searches for the % weights in \code{data}, then in the environment in which \code{earth} is called. } \item{wp}{ Response weights. Default is NULL, meaning no response weights. If specified, \code{wp} must have an element for each column of \code{y} (after \code{\link[=factor]{factors}} in \code{y}, if any, have been expanded). Zero weights are converted to a very small nonzero value. % Earth uses \code{wp} as follows: % It normalizes \code{wp} as follows \code{wp <- sqrt(wp / mean(wp))} % It multiplies each column of \code{y} by the corresponding % element of the normalized \code{wp}. % It runs its internal MARS machine with the modified \code{y}. % Finally, after running the machine it divides each column of % \code{fitted.values}, \code{residuals}, and \code{coefficients} by the % corresponding element of the normalized \code{wp}. } \item{na.action}{ NA action. Default is \code{na.fail}, and only \code{na.fail} is supported. } \item{offset}{ Offset term passed from the formula in \code{earth.formula}. } \item{keepxy}{ Default is \code{FALSE}. Set to \code{TRUE} to retain the following in the returned value: \code{x} and \code{y} (or \code{data}), \code{subset}, and \code{weights}. The function \code{\link{update.earth}} and friends will use these if present instead of searching for them in the environment at the time \code{update.earth} is invoked.\cr % The \code{subset} if specified will have been applied to the saved \code{x}, \code{y}, and \code{data}).\cr When the \code{nfold} argument is used with \code{keepxy=TRUE}, \code{earth} keeps more data and calls \code{predict.earth} multiple times to generate \code{cv.oof.rsq.tab} and \code{cv.infold.rsq.tab} (see the \code{cv.} arguments in \code{\link{earth.object}}). It therefore makes cross-validation significantly slower. } \item{trace}{ Trace \code{earth}'s execution. Values:\cr \code{0} (default) no tracing\cr \code{.3} variance model (the \code{varmod.method} arg)\cr \code{.5} cross validation (the \code{nfold} arg)\cr \code{1} overview\cr \code{2} forward pass\cr \code{3} pruning\cr \code{4} model mats summary, pruning details\cr \code{5} full model mats, internal details of operation\cr } \item{glm}{ NULL (default) or a list of arguments to pass on to \code{\link{glm}}. See the documentation of \code{\link{glm}} for a description of these arguments See \dQuote{\emph{Generalized linear models}} in the vignette. Example:\cr \code{earth(survived~., data=etitanic, degree=2, glm=list(family=binomial))} \cr\cr \bold{The following arguments are for the forward pass.} } \item{degree}{ Maximum degree of interaction (Friedman's \eqn{mi}). Default is \code{1}, meaning build an additive model (i.e., no interaction terms). } \item{penalty}{ Generalized Cross Validation (GCV) penalty per knot. Default is \code{if(degree>1) 3 else 2}. Simulation studies suggest values in the range of about \code{2} to \code{4}. The FAQ section in the vignette has some information on GCVs.\cr Special values (for use by knowledgeable users): The value \code{0} penalizes only terms, not knots. The value \code{-1} means no penalty, so GCV = RSS/n. } \item{nk}{ Maximum number of model terms before pruning, i.e., the maximum number of terms created by the forward pass. Includes the intercept.\cr The actual number of terms created by the forward pass will often be less than \code{nk} because of other stopping conditions. See \dQuote{\emph{Termination conditions for the forward pass}} in the vignette.\cr The default is semi-automatically calculated from the number of predictors but may need adjusting. } \item{thresh}{ Forward stepping threshold. Default is \code{0.001}. This is one of the arguments used to decide when forward stepping should terminate: the forward pass terminates if adding a term changes RSq by less than \code{thresh}. See \dQuote{\emph{Termination conditions for the forward pass}} in the vignette. } \item{minspan}{ Minimum number of observations between knots. (This increases resistance to runs of correlated noise in the input data.)\cr The default \code{minspan=0} is treated specially and means calculate the \code{minspan} internally, as per Friedman's MARS paper section 3.8 with \eqn{alpha} = 0.05. Set \code{trace>=2} to see the calculated value.\cr Use \code{minspan=1} and \code{endspan=1} to consider all x values.\cr Negative values of \code{minspan} specify the maximum number of knots per predictor. These will be equally spaced. For example, \code{minspan=-3} allows three evenly spaced knots for each predictor. As always, knots that fall in the end zones specified by \code{endspan} will be ignored. } \item{endspan}{ Minimum number of observations before the first and after the final knot.\cr The default \code{endspan=0} is treated specially and means calculate the \code{endspan} internally, as per the MARS paper equation 45 with \eqn{alpha} = 0.05. Set \code{trace>=2} to see the calculated value. \cr Be wary of reducing \code{endspan}, especially if you plan to make predictions beyond or near the limits of the training data. Overfitting near the edges of training data is much more likely with a small \code{endspan}. The model's \code{RSq} and \code{GRSq} won't indicate when this overfitting is occurring. (A \code{\link[plotmo]{plotmo}} plot can help: look for sharp hinges at the edges of the data). See also the \code{Adjust.endspan} argument. } \item{newvar.penalty}{ Penalty for adding a new variable in the forward pass (Friedman's \eqn{gamma}, equation 74 in the MARS paper). Default is \code{0}, meaning no penalty for adding a new variable. Useful non-zero values typically range from about \code{0.01} to \code{0.2} and sometimes higher --- you will need to experiment.\cr A word of explanation. With the default \code{newvar.penalty=0}, if two variables have nearly the same effect (e.g. they are collinear), at any step in the forward pass \code{earth} will arbitrarily select one or the other (depending on noise in the sample). Both variables can appear in the final model, complicating model interpretation. On the other hand with a non-zero \code{newvar.penalty}, the forward pass will be reluctant to add a new variable --- it will rather try to use a variable already in the model, if that does not affect RSq too much. The resulting final model may be easier to interpret, if you are lucky. There will often be a small performance hit (a worse GCV). } \item{fast.k}{ Maximum number of parent terms considered at each step of the forward pass. (This speeds up the forward pass. See the Fast MARS paper section 3.0.)\cr Default is \code{20}. A value of \code{0} is treated specially (as being equivalent to infinity), meaning no Fast MARS. Typical values, apart from \code{0}, are \code{20}, \code{10}, or \code{5}.\cr In general, with a lower \code{fast.k} (say \code{5}), \code{earth} is faster; with a higher \code{fast.k}, or with \code{fast.k} disabled (set to \code{0}), \code{earth} builds a better model. However, because of random variation this general rule often doesn't apply. } \item{fast.beta}{ Fast MARS ageing coefficient, as described in the Fast MARS paper section 3.1. Default is \code{1}. A value of \code{0} sometimes gives better results. } \item{linpreds}{ Index vector specifying which predictors should enter linearly, as in \code{\link{lm}}. The default is \code{FALSE}, meaning predictors enter in the standard MARS fashion, i.e., in hinge functions. \cr \cr The linpreds argument does not specify that a predictor \emph{must} enter the model; only that if it enters, it enters linearly. See \dQuote{\emph{The linpreds argument}} in the \href{../doc/earth-notes.pdf}{vignette}. \cr See also the \code{Auto.linpreds} argument below (which describes how \code{earth} will \emph{automatically} treat a predictor as linear under certain conditions). \cr \cr Details: A predictor's index in \code{linpreds} is the column number in the input matrix \code{x} (after factors have been expanded). \cr \code{linpreds=TRUE} makes all predictors enter linearly (the \code{TRUE} gets recycled). \cr \code{linpreds} may be a character vector e.g. \code{linpreds=c("wind", "vis")}. Note: \code{\link{grep}} is used for matching. Thus \code{"wind"} will match all variables that have \code{"wind"} in their names. Use \code{"^wind$"} to match only the variable named \code{"wind"}. } \item{allowed}{ Function specifying which predictors can interact and how. Default is NULL, meaning all standard MARS terms are allowed.\cr During the forward pass, \code{earth} calls the \code{allowed} function before considering a term for inclusion; the term can go into the model only if the \code{allowed} function returns \code{TRUE}. See \dQuote{\emph{The allowed argument}} in the vignette. \cr\cr \bold{The following arguments are for the pruning pass.} } \item{pmethod}{ Pruning method. One of: \code{backward none exhaustive forward seqrep cv}.\cr Default is \code{"backward"}.\cr Specify \code{pmethod="cv"} to use cross-validation to select the number of terms. This selects the number of terms that gives the maximum mean out-of-fold RSq on the fold models. Requires the \code{nfold} argument.\cr Use \code{"none"} to retain all the terms created by the forward pass.\cr If \code{y} has multiple columns, then only \code{"backward"} or \code{"none"} is allowed.\cr Pruning can take a while if \code{"exhaustive"} is chosen and the model is big (more than about 30 terms). The current version of the \code{\link[leaps]{leaps}} package used during pruning does not allow user interrupts (i.e., you have to kill your R session to interrupt; in Windows use the Task Manager or from the command line use \code{taskkill}). } \item{nprune}{ Maximum number of terms (including intercept) in the pruned model. Default is NULL, meaning all terms created by the forward pass (but typically not all terms will remain after pruning). Use this to enforce an upper bound on the model size (that is less than \code{nk}), or to reduce exhaustive search time with \code{pmethod="exhaustive"}. \cr\cr \bold{The following arguments are for cross validation.} } \item{nfold}{ Number of cross-validation folds. Default is \code{0}, no cross validation. If greater than \code{1}, \code{earth} first builds a standard model as usual with all the data. It then builds \code{nfold} cross-validated models, measuring R-Squared on the out-of-fold (left out) data each time. The final cross validation R-Squared (\code{CVRSq}) is the mean of these out-of-fold R-Squareds.\cr The above process of building \code{nfold} models is repeated \code{ncross} times (by default, once). Use \code{trace=.5} to trace cross-validation.\cr Further statistics are calculated if \code{keepxy=TRUE} or if a binomial or poisson model (specified with the \code{glm} argument). See \dQuote{\emph{Cross validation}} in the vignette. } \item{ncross}{ Only applies if \code{nfold>1}. Number of cross-validations. Each cross-validation has \code{nfold} folds. Default \code{1}. } \item{stratify}{ Only applies if \code{nfold>1}. Default is \code{TRUE}. Stratify the cross-validation samples so that an approximately equal number of cases with a non-zero response occur in each cross validation subset. So if the response \code{y} is logical, the \code{TRUE}s will be spread evenly across folds. And if the response is a multilevel factor, there will be an approximately equal number of each factor level in each fold (because a multilevel factor response gets expanded to columns of zeros and ones, see \dQuote{\emph{Factors}} in the vignette). We say \dQuote{approximately equal} because the number of occurrences of a factor level may not be exactly divisible by the number of folds. \cr\cr \bold{The following arguments are for variance models.} } \item{varmod.method}{ Construct a variance model. For details, see \code{\link{varmod}} and the vignette \dQuote{\href{../doc/earth-varmod.pdf}{Variance models in earth}}. Use \code{trace=.3} to trace construction of the variance model. \cr This argument requires \code{nfold} and \code{ncross}. (We suggest at least \code{ncross=30} here to properly calculate the variance of the errors --- although you can use a smaller value, say \code{3}, for debugging.)\cr The \code{varmod.method} argument should be one of\cr \bold{\code{"none"}} Default. Don't build a variance model. \cr \bold{\code{"const"}} Assume homoscedastic errors. \cr \bold{\code{"lm"}} Use \code{\link{lm}} to estimate standard deviation as a function of the predicted response. \cr \bold{\code{"rlm"}} Use \code{\link{rlm}}. \cr \bold{\code{"earth"}} Use \code{\link{earth}}. \cr \bold{\code{"gam"}} Use \code{gam}. This will use either \code{\link[gam]{gam}} or the \code{mgcv} package, whichever is loaded. \cr \bold{\code{"power"}} Estimate standard deviation as \code{intercept + coef * predicted.response^exponent}, where \code{intercept}, \code{coef}, and \code{exponent} will be estimated by \code{\link{nls}}. This is equivalent to \code{varmod.method="lm"} except that \code{exponent} is automatically estimated instead of being held at the value set by the \code{varmod.exponent} argument. \cr \bold{\code{"power0"}} Same as \code{"power"} but no intercept (offset) term. \cr \bold{\code{"x.lm"}}, \bold{\code{"x.rlm"}}, \bold{\code{"x.earth"}}, \bold{\code{"x.gam"}} Like the similarly named options above, but estimate standard deviation by regressing on the predictors \code{x} (instead of the predicted response). A current implementation restriction is that \code{"x.gam"} allows only models with one predictor (\code{x} must have only one column). } \item{varmod.exponent}{ Power transform applied to the rhs before regressing the absolute residuals with the specified \code{varmod.method}. Default is \code{1}.\cr For example, with \code{varmod.method="lm"}, if you expect the standard deviance to increase linearly with the mean response, use \code{varmod.exponent=1}. If you expect the standard deviance to increase with the square root of the mean response, use \code{varmod.exponent=.5} (where negative response values will be treated as \code{0}, and you will get an error message if more than 20\% of them are negative). } %\item{varmod.lambda}{ % The variance model regresses on \code{squared.resids^(varmod.lambda/2)}. % The default \code{varmod.lambda} is \code{1}, % that is, regress on the absolute value of the residuals. % } \item{varmod.conv}{ Convergence criterion for the Iteratively Reweighted Least Squares used when creating the variance model.\cr Iterations stop when the mean value of the coefficients of the residual model change by less than \code{varmod.conv} percent. Default is \code{1} percent.\cr Negative values force the specified number of iterations, e.g. \code{varmod.conv=-2} means iterate twice.\cr Positive values are ignored for \code{varmod="const"} and also currently ignored for \code{varmod="earth"} (these are iterated just once, the same as using \code{varmod.conv=-1}). } \item{varmod.clamp}{ The estimated standard deviation of the main model errors is forced to be at least a small positive value, which we call \code{min.sd}. This prevents negative or absurdly small estimated standard deviations. Clamping takes place in \code{predict.varmod}, which is called by \code{predict.earth} when estimating prediction intervals. The value of \code{min.sd} is determined when building the variance model as \code{min.sd = varmod.clamp * mean(sd(training.residuals))}. The default \code{varmod.clamp} is \code{0.1}. } \item{varmod.minspan}{ Only applies when \code{varmod.method="earth"} or \code{"x.earth"}. This is the \code{minspan} used in the internal call to \code{earth} when creating the variance model (not the main \code{earth} model).\cr Default is \code{-3}, i.e., three evenly spaced knots per predictor. Residuals tend to be very noisy, and allowing only this small number of knots helps prevent overfitting. \cr\cr \bold{The following arguments are for internal or advanced use.} } \item{Object}{ Earth object to be updated, for use by \code{\link{update.earth}}. } \item{Scale.y}{ \code{\link[=scale]{Scale}} the response internally in the forward pass. Scaling here means subtract the mean and divide by the standard deviation. \cr For single-response models, the default is \code{Scale.y = TRUE}. Scaling is invisible to the user, up to numerical differences, but does provide better numeric stability. \cr For multiple-response models, the default is \code{FALSE}. If \code{Scale.y} is set \code{TRUE}, each column of the response is independently scaled. This can prevent one response from ``overwhelming'' the others, and earth typically generates a different set of hinge functions. } \item{Adjust.endspan}{ In interaction terms, \code{endspan} gets multiplied by this value. This reduces the possibility of an overfitted interaction term supported by just a few cases on the boundary of the predictor space (as sometimes seen in our simulation studies).\cr The default is \code{2}. Use \code{Adjust.endspan=1} for compatibility with old versions of \code{earth}. } \item{Auto.linpreds}{ Default is \code{TRUE}, which works as follows (see \href{../doc/Auto-linpreds-example.pdf}{example}):\cr At any step in the forward pass, if earth discovers that the best knot for the best predictor is at the predictor minimum (in the training data), then earth adds the predictor to the model as a linear \dQuote{basis function} (with no hinge). Compare the following basis functions (printed in bold) for an example such predictor \code{x}:\cr \code{Auto.linpreds=TRUE} (default): \bold{\code{x}}\cr \code{Auto.linpreds=FALSE}: \bold{\code{max(x-99, 0)}} where \code{99} is the minimum \code{x} in the training data.\cr Using \code{Auto.linpreds=FALSE} always forces a knot, even when the knot is at the minimum value of the variable. This ensures that the basis functions are always expressed as hinge functions (and will always be non-negative).\cr Note that \code{Auto.linpreds} affects only how the model behaves \emph{outside} the training data. Thus \code{predict.earth} will make the same predictions from the training data, regardless of whether the earth model was built with \code{Auto.linpreds} set \code{TRUE} or \code{FALSE} (up to possible differences in the size of the model caused by different GCVs because of the different forms of the terms). } \item{Force.weights}{ Default is \code{FALSE}. For testing the \code{weights} argument. Force use of the code for handling weights in the \code{earth} code, even if \code{weights=NULL} or all the weights are the same. This will not necessarily generate an identical model, primarily because the non-weighted code requires some tests for numerical stability that can sometimes affect knot selection. } \item{Use.beta.cache}{ Default is \code{TRUE}. Using the \dQuote{beta cache} takes a little more memory but is faster (by 20\% and often much more for large models). The beta cache uses \code{nk * nk * ncol(x) * sizeof(double)} bytes. (The beta cache is an innovation in this implementation of MARS and does not appear in Friedman's papers. It is not related to the \code{fast.beta} argument. Certain regression coefficients in the forward pass can be saved and re-used, thus saving recalculation time.) } \item{Force.xtx.prune}{ Default is \code{FALSE}. This argument pertains to subset evaluation in the pruning pass. By default, if \code{y} has a single column then \code{earth} calls the \code{\link[leaps]{leaps}} routines; if \code{y} has multiple columns then \code{earth} calls \code{EvalSubsetsUsingXtx}. The \code{leaps} routines are numerically more stable but do not support multiple responses (\code{leaps} is based on the QR decomposition and \code{EvalSubsetsUsingXtx} is based on the inverse of X'X). Setting \code{Force.xtx.prune=TRUE} forces use of \code{EvalSubsetsUsingXtx}, even if \code{y} has a single column. } \item{Get.leverages}{ Default is \code{TRUE} unless the model has more than 100 thousand cases. The leverages are the diagonal hat values for the linear regression of \code{y} on \code{bx}. (The leverages are needed only for certain model checks, for example when \code{plotres} is called with \code{versus=4}). \cr Details: This argument was introduced to reduce peak memory usage. When \code{n >> p}, memory use peaks when \code{earth} is calculating the leverages. % If memory thrashing occurs, model-building will be slow. % The hard drive light will flicker continuously as the operating % system pages memory. } \item{Exhaustive.tol}{ Default \code{1e-10}. Applies only when \code{pmethod="exhaustive"}. If the reciprocal of the condition number of \code{bx} is less than \code{Exhaustive.tol}, \code{earth} forces \code{pmethod="backward"}. See \dQuote{\emph{XHAUST returned error code -999}} in the vignette. } \item{\dots}{ Dots are passed on to \code{earth.fit}. } } \value{ An S3 model of class \code{"earth"}. See \code{\link{earth.object}} for a complete description. } \author{ Stephen Milborrow, derived from \code{mda::\link[mda]{mars}} by Trevor Hastie and Robert Tibshirani. The approach used for GLMs was motivated by work done by Jane Elith and John Leathwick (a representative paper is given below). The \code{\link{evimp}} function uses ideas from Max Kuhn's \code{caret} package \url{https://CRAN.R-project.org/package=caret}. Parts of Thomas Lumley's \code{\link[leaps]{leaps}} package have been incorporated into \code{earth}, so \code{earth} can directly access Alan Miller's Fortran functions without going through hidden functions in the \code{leaps} package. } \references{ The Wikipedia article is recommended for an elementary introduction. The primary references are the Friedman papers, but readers may find the MARS section in Hastie, Tibshirani, and Friedman a more accessible introduction. Faraway takes a hands-on approach, using the \code{\link[=ozone1]{ozone}} data to compare \code{mda::mars} with other techniques. (If you use Faraway's examples with \code{earth} instead of \code{mars}, use \code{$bx} instead of \code{$x}, and check out the book's errata.) Friedman and Silverman is recommended background reading for the MARS paper. Earth's pruning pass uses code from the \code{\link[leaps]{leaps}} package which is based on techniques in Miller. Faraway (2005) \emph{Extending the Linear Model with R} \url{http://www.maths.bath.ac.uk/~jjf23} Friedman (1991) \emph{Multivariate Adaptive Regression Splines (with discussion)} Annals of Statistics 19/1, 1--141 % \code{https://statistics.stanford.edu/research/multivariate-adaptive-regression-splines}\cr \url{http://projecteuclid.org/euclid.aos/1176347963}\cr \doi{10.1214/aos/1176347963} Friedman (1993) \emph{Fast MARS} Stanford University Department of Statistics, Technical Report 110 % use \code and not \url below else get libcurl error 35 from cran check % note also that there is no DOI for this paper as far as I can tell \code{https://statistics.stanford.edu/research/fast-mars} Friedman and Silverman (1989) \emph{Flexible Parsimonious Smoothing and Additive Modeling} Technometrics, Vol. 31, No. 1. \url{https://www.tandfonline.com/doi/abs/10.1080/00401706.1989.10488470} % \url{https://www.jstor.org/stable/1270359} % CRAN check fails with "Message: Forbidden" Hastie, Tibshirani, and Friedman (2009) \emph{The Elements of Statistical Learning (2nd ed.)} \url{http://web.stanford.edu/~hastie/pub.htm} Leathwick, J.R., Rowe, D., Richardson, J., Elith, J., & Hastie, T. (2005) \emph{Using multivariate adaptive regression splines to predict the distributions of New Zealand's freshwater diadromous fish} Freshwater Biology, 50, 2034-2052 \url{http://web.stanford.edu/~hastie/pub.htm}, \url{http://www.botany.unimelb.edu.au/envisci/about/staff/elith.html} Miller, Alan (1990, 2nd ed. 2002) \emph{Subset Selection in Regression} \url{http://wp.csiro.au/alanmiller/index.html} Wikipedia article on MARS \url{http://en.wikipedia.org/wiki/Multivariate_adaptive_regression_splines} } \seealso{ Start with \code{\link{summary.earth}}, \code{\link{plot.earth}}, \code{\link{evimp}}, and \code{\link[plotmo]{plotmo}}. Please see the main package vignette \dQuote{\href{../doc/earth-notes.pdf}{Notes on the earth package}}. The vignette can also be downloaded from \url{http://www.milbo.org/doc/earth-notes.pdf}. The vignette \dQuote{\href{../doc/earth-varmod.pdf}{Variance models in earth}} is also included with the package. It describes how to generate prediction intervals for \code{earth} models. } \examples{ earth.mod <- earth(Volume ~ ., data = trees) plotmo(earth.mod) summary(earth.mod, digits = 2, style = "pmax") } \keyword{smooth} \keyword{models} \keyword{regression} earth/man/earth.object.Rd0000644000176200001440000003741413436620215015002 0ustar liggesusers\name{earth.object} \alias{earth.object} \title{An earth object} \description{ The object returned by the \code{\link{earth}} function. This is an \code{S3} model of \code{\link{class}} \code{"earth"}. It is a list with the components listed below. \emph{Term} refers to a term created during the forward pass (each line of the output from \code{\link{format.earth}} is a term). Term number 1 is always the intercept. } \value{ \item{\code{rss}}{ Residual sum-of-squares (RSS) of the model (summed over all responses, if \code{y} has multiple columns). } \item{\code{rsq}}{ \code{1-rss/tss}. R-Squared of the model (calculated over all responses, and calculated using the \code{weights} argument if it was supplied). A measure of how well the model fits the training data. Note that \code{tss} is the total sum-of-squares, \code{sum((y - mean(y))^2)}. } \item{\code{gcv}}{ Generalized Cross Validation (GCV) of the model (summed over all responses). The GCV is calculated using the \code{penalty} argument. For details of the GCV calculation, see equation 30 in Friedman's MARS paper and \code{earth:::get.gcv}. } \item{\code{grsq}}{ \code{1-gcv/gcv.null}. An estimate of the predictive power of the model (calculated over all responses, and calculated using the \code{weights} argument if it was supplied). \code{gcv.null} is the GCV of an intercept-only model. See \dQuote{\emph{Can \code{GRSq} be negative?}} in the vignette. } \item{\code{bx}}{ Matrix of basis functions applied to \code{x}. Each column corresponds to a selected term. Each row corresponds to a row in in the input matrix \code{x}, after taking \code{subset}. See \code{\link{model.matrix.earth}} for an example of \code{bx} handling. Example \code{bx}:\preformatted{ (Intercept) h(Girth-12.9) h(12.9-Girth) h(Girth-12.9)*h(... [1,] 1 0.0 4.6 0 [2,] 1 0.0 4.3 0 [3,] 1 0.0 4.1 0 ...} % \cr } \item{\code{dirs}}{ Matrix with one row per MARS term, and with with ij-th element equal to\cr \code{0} if predictor j is not in term i\cr \code{-1} if an expression of the form \code{h(const - xj)} is in term i\cr \code{1} if an expression of the form \code{h(xj - const)} is in term i\cr \code{2} if predictor j should enter term i linearly (either because specified by the \code{linpreds} argument or because earth discovered that a knot was unnecessary).\cr This matrix includes all terms generated by the forward pass, including those not in \code{selected.terms}. Note that here the terms may not all be in pairs, because although the forward pass add terms as hinged pairs (so both sides of the hinge are available as building blocks for further terms), it also deletes linearly dependent terms before handing control to the pruning pass. Example \code{dirs}:\preformatted{ Girth Height (Intercept) 0 0 #intercept h(12.9-Girth) -1 0 #2nd term uses Girth h(Girth-12.9) 1 0 #3rd term uses Girth h(Girth-12.9)*h(Height-76) 1 1 #4th term uses Girth and Height ... } % \cr } \item{\code{cuts}}{ Matrix with ij-th element equal to the cut point for predictor j in term i. This matrix includes all terms generated by the forward pass, including those not in \code{selected.terms}. Note for programmers: the precedent is to use \code{dirs} for term names etc. and to only use \code{cuts} where cut information needed. Example \code{cuts}:\preformatted{ Girth Height (Intercept) 0 0 #intercept, no cuts h(12.9-Girth) 12.9 0 #2nd term has cut at 12.9 h(Girth-12.9) 12.9 0 #3rd term has cut at 12.9 h(Girth-12.9)*h(Height-76) 12.9 76 #4th term has two cuts ...} % \cr } \item{\code{prune.terms}}{ A matrix specifying which terms appear in which pruning pass subsets. The row index of \code{prune.terms} is the model size. (The model size is the number of terms in the model. The intercept is counted as a term.) Each row is a vector of term numbers for the best model of that size. An element is 0 if the term is not in the model, thus \code{prune.terms} is a lower triangular matrix, with dimensions \code{nprune x nprune}. The model selected by the pruning pass is at row number \code{length(selected.terms)}. Example \code{prune.terms}:\preformatted{[1,] 1 0 0 0 0 0 0 #intercept-only model [2,] 1 2 0 0 0 0 0 #best 2 term model uses terms 1,2 [3,] 1 2 4 0 0 0 0 #best 3 term model uses terms 1,2,4 [4,] 1 2 6 9 0 0 0 #and so on ...} % \cr } \item{\code{selected.terms}}{ Vector of term numbers in the selected model. Can be used as a row index vector into \code{cuts} and \code{dirs}. The first element \code{selected.terms[1]} is always 1, the intercept. } \item{\code{fitted.values}}{ Fitted values. A matrix with dimensions \code{nrow(y) x ncol(y)} after factors in \code{y} have been expanded. } \item{\code{residuals}}{ Residuals. A matrix with dimensions \code{nrow(y) x ncol(y)} after factors in \code{y} have been expanded. } \item{\code{coefficients}}{ Regression coefficients. A matrix with dimensions \code{length(selected.terms) x ncol(y)} after factors in \code{y} have been expanded. Each column holds the least squares coefficients from regressing that column of \code{y} on \code{bx}. The first row holds the intercept coefficient(s). } \item{\code{rss.per.response}}{ A vector of the RSS for each response. Length is the number of responses, i.e., \code{ncol(y)} after factors in \code{y} have been expanded. The \code{rss} component above is equal to \code{sum(rss.per.response)}. } \item{\code{rsq.per.response}}{ A vector of the R-Squared for each response (where R-Squared is calculated using the \code{weights} argument if it was supplied). Length is the number of responses. } \item{\code{gcv.per.response}}{ A vector of the GCV for each response. Length is the number of responses. The \code{gcv} component above is equal to \code{sum(gcv.per.response)}. } \item{\code{grsq.per.response}}{ A vector of the GRSq for each response (calculated using the \code{weights} argument if it was supplied). Length is the number of responses. } \item{\code{rss.per.subset}}{ A vector of the RSS for each model subset generated by the pruning pass. Length is \code{nprune}. For multiple responses, the RSS is summed over all responses for each subset. The \code{rss} above is\cr \code{rss.per.subset[length(selected.terms)]}. The RSS of an intercept only-model is \code{rss.per.subset[1]}. } \item{\code{gcv.per.subset}}{ A vector of the GCV for each model in \code{prune.terms}. Length is \code{nprune}. For multiple responses, the GCV is summed over all responses for each subset. The \code{gcv} above is \code{gcv.per.subset[length(selected.terms)]}. The GCV of an intercept-only model is \code{gcv.per.subset[1]}. } \item{\code{leverages}}{ Diagonal of the hat matrix (from the linear regression of the response on \code{bx}). } \item{\code{penalty,nk,thresh}}{ Copies of the corresponding arguments to \code{earth}. } \item{\code{pmethod,nprune}}{ Copies of the corresponding arguments to \code{earth}. } \item{\code{weights,wp}}{ Copies of the corresponding arguments to \code{earth}. } \item{\code{termcond}}{ Reason the forward pass terminated (an integer). } \item{\code{call}}{ The call used to invoke \code{earth}. } \item{\code{terms}}{ Model frame terms. This component exists only if the model was built using \code{earth.formula}. } \item{\code{namesx}}{ Column names of \code{x}, generated internally by \code{earth} when necessary so each column of \code{x} has a name. Used, for example, by \code{\link{predict.earth}} to name columns if necessary. } \item{\code{namesx.org}}{ Original column names of \code{x}. } \item{\code{levels}}{ Levels of \code{y} if \code{y} is a \code{\link{factor}},\cr \code{c(FALSE,TRUE)} if \code{y} is \code{\link{logical}},\cr Else \code{NULL}. \cr\cr \bold{The following fields appear only if \code{earth}'s argument \code{keepxy} is \code{TRUE}.} } % \item{\code{x}}{} % \item{\code{y}}{} % \item{\code{data}}{} % \item{\code{subset}}{}{ \item{\code{x},\code{y},\code{data},\code{subset}}{ Copies of the corresponding arguments to \code{earth}. Only exist if \code{keepxy=TRUE}. \cr\cr \bold{The following fields appear only if \code{earth}'s \code{glm} argument is used.} } \item{\code{glm.list}}{ List of GLM models. Each element is the value returned by \code{earth}'s internal call to \code{\link{glm}} for each response.\cr Thus if there is a single response (or a single binomial pair, see \dQuote{\emph{Binomial pairs}} in the vignette) this will be a one element list and you access the GLM model with \code{earth.mod$glm.list[[1]]}. } \item{\code{glm.coefficients}}{ GLM regression coefficients. Analogous to the \code{coefficients} field described above but for the GLM model(s). A matrix with dimensions \code{length(selected.terms) x ncol(y)} after factors in \code{y} have been expanded. Each column holds the coefficients from the GLM regression of that column of \code{y} on \code{bx}. This duplicates, for convenience, information buried in \code{glm.list}. } \item{\code{glm.stats}}{ GLM summary statistics such as \code{devratio}, \code{AIC}, and \code{iters}. } \item{\code{glm.bpairs}}{ Is \code{NULL} unless there are paired binomial columns. Else a logical vector \code{c(TRUE, FALSE)}. See \dQuote{\emph{Binomial pairs}} in the vignette. Retained for backwards compatibility with old versions of earth. \cr\cr \bold{The following fields appear only if the \code{nfold} argument is greater than 1.} } \item{\code{cv.list}}{ List of \code{earth} models, one model for each fold (\code{ncross * nfold} models).\cr The fold models have two extra fields, \code{icross} (an integer from \code{1} to \code{ncross}) and \code{ifold} (an integer from \code{1} to \code{nfold}).\cr To save memory, lengthy fields in the fold models are removed unless you use \code{keepxy=TRUE}. The \dQuote{lengthy fields} are \code{$bx}, \code{$fitted.values}, and \code{$residuals}. } \item{\code{cv.nterms}}{ Vector of length \code{ncross * nfold + 1}. Number of MARS terms in the model generated at each cross-validation fold, with the final element being the mean of these. } \item{\code{cv.nvars}}{ Vector of length \code{ncross * nfold + 1}. Number of predictors in the model generated at each cross-validation fold, with the final element being the mean of these. } \item{\code{cv.groups}}{ Specifies which cases went into which folds. Matrix with two columns and number of rows equal to the the number of cases \code{nrow(x)} Elements of the first column specify the cross-validation number, \code{1:ncross}. Elements of the second column specify the fold number, \code{1:nfold}. } \item{\code{cv.rsq.tab}}{ Matrix with \code{ncross * nfold + 1} rows and \code{nresponse+1} columns, where \code{nresponse} is the number of responses, i.e., \code{ncol(y)} after factors in \code{y} have been expanded. The first \code{nresponse} elements of a row are the \code{cv.rsq}'s on the out-of-fold data for each response of the model generated at that row's fold. (A \code{cv.rsq} is calculated from predictions on the out-of-fold data using the best model built from the in-fold data; where \dQuote{best} means the model was selected using the in-fold GCV. The R-Squareds are calculated using the \code{weights} argument if it was supplied. The final column holds the row mean (a weighted mean if \code{wp} if specified)). The final row holds the column means. The values in this final row is the mean \code{cv.rsq} printed by \code{\link{summary.earth}}. \cr\cr Example for a single response model (where the \code{mean} column is redundant but included for uniformity with multiple response models): \preformatted{ y mean fold1 0.909 0.909 fold2 0.869 0.869 fold3 0.952 0.952 fold4 0.157 0.157 fold5 0.961 0.961 mean 0.769 0.769 } Example for a multiple response model: \preformatted{ y1 y2 y3 mean fold1 0.915 0.951 0.944 0.937 fold2 0.962 0.970 0.970 0.968 fold3 0.914 0.940 0.942 0.932 fold4 0.907 0.929 0.925 0.920 fold5 0.947 0.987 0.979 0.971 mean 0.929 0.955 0.952 0.946 } } \item{\code{cv.class.rate.tab}}{ Like \code{cv.rsq.tab} but is the classification rate at each fold i.e. the fraction of classes correctly predicted. Models with discrete response only. Calculated with \code{thresh=.5} for binary responses. For responses with more than two levels, the final row is the overall classification rate. The other rows are the classification rates for each level (the level versus not-the-level), which are usually higher than the overall classification rate (predicting the level versus not-the-level is easier than correctly predicting one of many levels). The \code{weights} argument is ignored for all cross-validation stats except R-Squareds. } \item{\code{cv.maxerr.tab}}{ Like \code{cv.rsq.tab} but is the \code{MaxErr} at each fold. This is the signed max absolute value at each fold. Results are aggregated for the final column and final row using the signed max absolute value. The \emph{signed max absolute value} is defined as the maximum of the absolute difference between the predicted and observed response values, multiplied by \code{-1} if the sign of that difference is negative. } \item{\code{cv.auc.tab}}{ Like \code{cv.rsq.tab} but is the \code{AUC} at each fold. Binomial models only. } \item{\code{cv.cor.tab}}{ Like \code{cv.rsq.tab} but is the \code{cor} at each fold. Poisson models only. } \item{\code{cv.deviance.tab}}{ Like \code{cv.rsq.tab} but is the \code{MeanDev} at each fold. Binomial models only. } \item{\code{cv.calib.int.tab}}{ Like \code{cv.rsq.tab} but is the \code{CalibInt} at each fold. Binomial models only. } \item{\code{cv.calib.slope.tab}}{ Like \code{cv.rsq.tab} but is the \code{CalibSlope} at each fold. Binomial models only. } \item{\code{cv.oof.rsq.tab}}{ Generated only if \code{keepxy=TRUE} or \code{pmethod="cv"}.\cr A matrix with \code{ncross * nfold + 1} rows and \code{max.nterms} columns, Each element holds an out-of-fold RSq (\code{oof.rsq}), calculated from predictions from the out-of-fold observations using the model built with the in-fold data. The final row is the mean over all folds. The R-Squareds are calculated using the \code{weights} argument if it was supplied. } \item{\code{cv.infold.rsq.tab}}{ Generated only if \code{keepxy=TRUE}. Like \code{cv.oof.rsq.tab} but from predictions made on the in-fold observations. } \item{\code{cv.oof.fit.tab}}{ Generated only if the \code{varmod.method} argument is used. Predicted values on the out-of-fold data. Dataframe with \code{nrow(data)} rows and \code{ncross} columns. \cr\cr \bold{The following field appears only if the \code{varmod.method} is specified.} } \item{\code{varmod}}{ An object of class \code{"varmod"}. See the \code{\link[=predict.varmod]{varmod}} help page for a description. Only appears if the \code{varmod.method} argument is used. } } \seealso{ \code{\link{earth}} } earth/man/residuals.earth.Rd0000644000176200001440000000467513410112407015521 0ustar liggesusers\name{residuals.earth} \alias{residuals.earth} \title{Residuals for an earth model} \description{ Residuals of an \code{\link{earth}} model. } \usage{ \method{residuals}{earth}(object = stop("no 'object' argument"), type = NULL, warn = TRUE, \dots) } \arguments{ \item{object}{ An \code{\link{earth}} object. This is the only required argument. } \item{type}{ One of:\cr \cr \bold{\code{"earth"}} (default) Residuals from the \code{\link{lm}} fit on \code{bx}.\cr \bold{\code{"response"}} Residuals as above, but for earth-glm models return the \code{\link{glm}} response residuals.\cr \bold{\code{"standardize"}} Residuals divided by \code{se * sqrt(1 - h_ii)}. See the \code{standardize} argument of \code{\link{plot.earth}}.\cr \bold{\code{"delever"}} Residuals divided by \code{sqrt(1 - h_ii)}. See the \code{delever} argument of \code{\link{plot.earth}}.\cr \cr The following options are for earth-glm models. They return the GLM residuals (from the \code{\link{glm}} fit on \code{bx}). See \code{\link{residuals.glm}} for details: \cr \cr \bold{\code{"deviance"}}\cr \bold{\code{"pearson"}}\cr \bold{\code{"working"}}\cr \bold{\code{"partial"}}\cr \cr The following options for earth-glm models are redundant. They are provided for compatibility with older versions of earth or other functions: \cr \cr \bold{\code{"glm.response"}} same as \code{"response"}\cr \bold{\code{"glm.deviance"}} same as \code{"deviance"}\cr \bold{\code{"glm.pearson"}} same as \code{"pearson"}\cr \bold{\code{"glm.working"}} same as \code{"working"}\cr \bold{\code{"glm.partial"}} same as \code{"partial"} } \item{warn}{ This function gives warnings when the results are not what you may expect. Use \code{warn=FALSE} to turn of just these warnings. } \item{\dots}{ Unused, but provided for generic/method consistency. } } \value{ The residual values (will be a matrix for multiple response models). } \seealso{ \code{\link{earth}}\cr \code{\link{residuals}}\cr \code{\link{resid}} identical to \code{\link{residuals}} } \examples{ data(etitanic) earth.mod <- earth(pclass ~ ., data=etitanic, glm=list(family=binomial)) head(resid(earth.mod, warn=FALSE)) # earth residuals, a column for each response head(resid(earth.mod, type="response")) # GLM response resids, a column for each response } \keyword{models} earth/man/plot.earth.Rd0000644000176200001440000001566613435103666014524 0ustar liggesusers\name{plot.earth} \alias{plot.earth} \alias{earth_plotmodsel} \title{Plot an earth object} \description{ Plot an \code{\link{earth}} object. By default the plot shows model selection, cumulative distribution of the residuals, residuals versus fitted values, and the residual QQ plot. This function calls \code{\link[plotmo]{plotres}} internally. The first arguments are identical to \code{plotres}. } \usage{ \method{plot}{earth}(x = stop("no 'x' argument"), # the following are identical to plotres arguments 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, # the following are earth specific col.cv = "lightblue", col.grsq = 1, col.rsq = 2, col.infold.rsq = 0, col.mean.infold.rsq = 0, col.mean.oof.rsq = "palevioletred", col.npreds = if(is.null(object$cv.oof.rsq.tab)) 1 else 0, col.oof.labs = 0, col.oof.rsq = "mistyrose2", col.oof.vline = col.mean.oof.rsq, col.pch.cv.rsq = 0, col.pch.max.oof.rsq = 0, col.vline = col.grsq, col.vseg = 0, lty.grsq = 1, lty.npreds = 2, lty.rsq = 5, lty.vline = "12", legend.pos = NULL, \dots) earth_plotmodsel( # for internal use by plotres x, col.rsq = 2, col.grsq = 1, col.infold.rsq = 0, col.mean.infold.rsq = 0, col.mean.oof.rsq = "palevioletred", col.npreds = NULL, col.oof.labs = 0, col.oof.rsq = "mistyrose2", col.oof.vline = col.mean.oof.rsq, col.pch.cv.rsq = 0, col.pch.max.oof.rsq = 0, col.vline = col.grsq, col.vseg = 0, lty.grsq = 1, lty.npreds = 2, lty.rsq = 5, lty.vline = "12", legend.pos=NULL, add = FALSE, jitter = 0, max.nterms = length(object$rss.per.subset), max.npreds=max(1,get.nused.preds.per.subset(object$dirs,object$prune.terms)), ...) } \arguments{ \item{x}{ An \code{\link{earth}} object. This is the only required argument. (It is called "x" for consistency with the generic \code{\link{plot}}.) \cr \cr } \item{which,info,versus}{These arguments are identical to \code{\link[plotmo]{plotres}}. Please see the help page for \code{\link[plotmo]{plotres}}. } \item{standardize,delever,level}{.} \item{id.n,labels.id,smooth.col}{.} \item{grid.col,jitter}{.} \item{do.par,caption,trace}{.} \item{npoints,center}{.} \item{type,nresponse}{.\cr \cr } \item{col.cv}{Default \code{"lightblue"}. Color of cross validation line in the residuals plot. This is the residual of the mean out-fold-predicted value. \cr \cr \bold{The following arguments are for the model selection plot.} \cr \cr } \item{col.grsq}{Default \code{1}. Color of GRSq line in the Model Selection plot. Use \code{0} for no GRSq line. } \item{col.rsq}{Default \code{2}. Color of the RSq line in the Model Selection plot. Use \code{0} for no RSq line. } \item{col.infold.rsq}{ Color of in-fold RSq lines for each fold in the Model Selection plot. Applies only if \code{nfold} and \code{keepxy} were used in the original call to \code{earth}. Default is \code{0}, lines not plotted. } \item{col.mean.infold.rsq}{ Color of mean in-fold RSq for each number of terms in the Model Selection plot. Default is \code{0}, line not plotted. Applies only if \code{nfold} and \code{keepxy} were used in the original call to \code{earth}. } \item{col.mean.oof.rsq}{Default \code{"palevioletred"}. Color of mean out-of-fold RSq for each number of terms in the Model Selection plot. Applies only if \code{nfold} and \code{keepxy} were used in the original call to \code{earth}. Use \code{0} to not plot this line. } \item{col.npreds}{Color of the "number of predictors" plot in the Model Selection plot. The default displays the number of predictors unless the \code{oof.rsq}'s are displayed. Use \code{0} for no "number of predictors" plot. } \item{col.oof.labs}{ Color of fold number labels on the \code{oof.rsq} lines. Default is \code{0}, no labels. } \item{col.oof.rsq}{ Color of out-of-fold RSq lines for each fold in the Model Selection plot. Applies only if \code{nfold} and \code{keepxy} were used in the original call to \code{earth}. Default is \code{"mistyrose2"}, a pale pink. Use \code{0} to not plot these lines. May be a vector of colors, which will be recycled if necessary. } \item{col.oof.vline}{ Color of vertical line at the maximum \code{oof.rsq} in the Model Selection plot. Default is \code{col.mean.oof.rsq}. } \item{col.pch.cv.rsq}{ Color of point plotted on the \code{oof.rsq} line to indicate the \code{cv.rsq}. for that fold (i.e., it is plotted at the number of terms selected by the in-fold GCV). Default is \code{0}, point not plotted. } \item{col.pch.max.oof.rsq}{ Color of point plotted on the \code{oof.rsq} line to indicate the maximum \code{oof.rsq} for that fold. Default is \code{0}, point not plotted. } \item{col.vline}{ Color of the vertical line at selected model in the Model Selection plot. Default is \code{col.grsq}. This will be at the maximum GRSq unless \code{pmethod="none"}. Use \code{0} for no vertical line. } \item{col.vseg}{ Default is \code{0}. Color of triangular marker at top of vertical line for best GRSq. } \item{lty.grsq}{ Line type of GRSq line in the Model Selection plot. Default is \code{1} } \item{lty.npreds}{ Line type of the "number of predictors" plot in the Model Selection plot. Default is \code{2}. } \item{lty.rsq}{ Line type of RSq line in the Model Selection plot. Default is \code{5}. } \item{lty.vline}{ Line type of vertical line at selected model in the Model Selection plot. Default is \code{"12"}. } \item{legend.pos}{ Position of the legend in the Model Selection plot. Default is \code{NULL} meaning automatic. Use \code{legend.pos=NA} or \code{0} for no legend. Can be something like \code{legend.pos="topleft"} or \code{legend.pos=c(6, .75)}. } \item{add, max.nterms, max.npreds}{ \code{earth_plotmodsel} arguments for internal use by \code{plotres}. \cr \cr \cr } \item{\dots}{Please see \code{\link[plotmo]{plotres}} for the details on the dots arguments. The \code{ylim} argument is treated specially in the model selection plot: \code{ymin} equal to \code{-1} means use the smallest GRSq or RSq value, excluding the intercept, and \code{ymax} equal \code{-1} means use the largest GRSq or RSq value. } } \note{ For details on interpreting the graphs, please see the \code{earth} package vignettes \dQuote{\href{../doc/earth-notes.pdf}{Notes on the earth package}} and \dQuote{\href{../doc/earth-varmod.pdf}{Variance models in earth}}. Note that cross-validation data will not be displayed unless both \code{nfold} and \code{keepxy} were used in the original call to \code{earth}. To remove the \code{Number of used predictors} from the Model Selection graph (to reduce clutter), use \code{col.npreds=0}. \code{earth_plotmodsel} is provided for use by \code{\link[plotmo]{plotres}}. } \seealso{ \code{\link{earth}}, \code{\link{plot.earth.models}}, \code{\link{plotd}}, \code{\link[plotmo]{plotmo}} } \examples{ data(ozone1) earth.mod <- earth(O3 ~ ., data = ozone1, degree = 2) plot(earth.mod) } \keyword{models} earth/man/plot.evimp.Rd0000644000176200001440000000411213000465674014517 0ustar liggesusers\name{plot.evimp} \alias{plot.evimp} \title{Plot an evimp object (created by the evimp function)} \description{ Plot an \code{\link{evimp}} object. } \usage{ \method{plot}{evimp}(x = stop("no 'x' argument"), cex.var = 1, type.nsubsets = "l", col.nsubsets = "black", lty.nsubsets = 1, type.gcv = "l", col.gcv = 2, lty.gcv = 1, type.rss = "l", col.rss = "gray60", lty.rss = 1, cex.legend = 1, x.legend = nrow(x), y.legend = x[1,"nsubsets"], rh.col = 1, do.par = TRUE, \dots) } \arguments{ \item{x}{ An \code{\link{evimp}} object. } \item{cex.var}{ cex for variable names. Default is 1. Make smaller (say 0.8) if you have lots of variables. } \item{type.nsubsets}{ Plot type for nsubsets graph. Default is "l". Use "n" for none, "b" looks good too. } \item{col.nsubsets}{ Color of nsubsets line. Default is "black". } \item{lty.nsubsets}{ Line type of nsubsets line. Default is 1. } \item{type.gcv,col.gcv,lty.gcv}{ As above but for the gcv plot } \item{type.rss,col.rss,lty.rss}{ As above but for the rss plot } \item{cex.legend}{ cex for legend strings. Default is 1. Make smaller (say 0.8) if you want a smaller legend. } \item{x.legend}{ x position of legend. Use 0 for no legend. } \item{y.legend}{ y position of legend. } \item{rh.col}{ Color of right hand axis label. Use \code{rh.col=0} for no label, a workaround for when the label is mispositioned. } \item{do.par}{ Call \code{par()} for global settings as appropriate. Default is \code{TRUE}, which sets\cr \code{oma=c(bottom.margin,0,0,3), cex=cex.var}.\cr Set to \code{FALSE} if you want to append figures to an existing plot. } \item{\dots}{ Extra arguments passed to plotting functions. } } \seealso{ \code{\link{earth}}, \code{\link{evimp}}, \code{\link{plot.earth.models}}, \code{\link[plotmo]{plotmo}} } \examples{ data(ozone1) earth.mod <- earth(O3 ~ ., data=ozone1, degree=2) ev <- evimp(earth.mod) plot(ev) print(ev) } \keyword{models} earth/man/etitanic.Rd0000644000176200001440000000463712506743404014236 0ustar liggesusers\name{etitanic} \alias{etitanic} \title{Titanic data with incomplete cases removed} \description{ Titanic data with incomplete cases, passenger names, and other details removed. } \format{ A data frame with 1046 observations on 6 variables. \tabular{ll}{ \code{pclass} \tab passenger class, unordered factor: 1st 2nd 3rd\cr \code{survived} \tab integer: 0 or 1\cr \code{sex} \tab unordered factor: male female\cr \code{age} \tab age in years, min 0.167 max 80.0\cr \code{sibsp} \tab number of siblings or spouses aboard, integer: 0...8\cr \code{parch} \tab number of parents or children aboard, integer: 0...6\cr } } \source{ This dataset is included in the earth package because it is a convenient vehicle for illustrating earth's GLM and factor handling. The dataset was compiled by Frank Harrell and Robert Dawson: \url{http://biostat.mc.vanderbilt.edu/twiki/pub/Main/DataSets/titanic.html}\cr See also:\cr \url{http://biostat.mc.vanderbilt.edu/twiki/pub/Main/DataSets/titanic3info.txt}. For this version of the Titanic data, passenger details and incomplete cases were deleted and the name changed to \code{etitanic} to minimize confusion with other versions ("e" because it is part of the earth package). Note that \code{survived} is an integer (it should arguably be a logical). In this data the crew are conspicuous by their absence. Contents of \code{etitanic}: \preformatted{ pclass survived sex age sibsp parch 1 1st 1 female 29.000 0 0 2 1st 1 male 0.917 1 2 3 1st 0 female 2.000 1 2 4 1st 0 male 30.000 1 2 5 1st 0 female 25.000 1 2 ... 1309 3rd 0 male 29.000 0 0 } How \code{etitanic} was built: \preformatted{ load("titanic3") # from Harrell's web site # discard name, ticket, fare, cabin, embarked, body, home.dest etitanic <- titanic3[,c(1,2,4,5,6,7)] etitanic <- etitanic[!is.na(etitanic$age),] save(etitanic, file="etitanic.rda") } } \references{ Further details and analyses of the Titanic data may be found in: F. Harrell (2001) \emph{ Regression Modeling Strategies with Applications to Linear Models, Logistic Regression, and Survival Analysis } \url{http://biostat.mc.vanderbilt.edu/twiki/bin/view/Main/RmS} } \seealso{ \code{\link{earth}} } \keyword{datasets} earth/man/expand.bpairs.Rd0000644000176200001440000000720313447756600015173 0ustar liggesusers\name{expand.bpairs} \alias{expand.bpairs} \alias{expand.bpairs.default} \alias{expand.bpairs.formula} \title{Expand binomial-pair data from short to long form} \description{ Expand binomial-pair data from ``short'' to ``long'' form. The short form specifies the response with two columns giving the numbers of successes and failures. Example short form:\preformatted{ survived died dose sex 3 0 10 male 2 1 10 female 1 2 20 male 1 2 20 female } The long form specifies the response as single column of \code{TRUE}s and \code{FALSE}s. For example, the long form of the above data (spaces and comments added):\preformatted{ survived dose sex TRUE 10 male # row 1 of short data: 0 died, 3 survived TRUE 10 male TRUE 10 male FALSE 10 female # row 2 of short data: 1 died, 2 survived TRUE 10 female TRUE 10 female FALSE 20 male # row 3 of short data: 2 died, 1 survived FALSE 20 male TRUE 20 male FALSE 20 female # row 4 of short data: 2 died, 1 survived FALSE 20 female TRUE 20 female } In this example the total number of survived and died for each row in the short data is the same, but in general that need not be true. } \usage{ \method{expand.bpairs}{formula}(formula = stop("no 'formula' argument"), data = NULL, sort = FALSE, \dots) \method{expand.bpairs}{default}(data = stop("no 'data' argument"), y = NULL, sort = FALSE, \dots) } \arguments{ \item{formula}{ Model formula such as \code{survived + died ~ dose + temp}. } \item{data}{ Matrix or dataframe containing the data. } \item{y}{ Model response. One of: \cr o Two column matrix or dataframe of binomial pairs e.g. \code{cbind(survived, died=20-survived)} \cr o Two-element numeric vector specifying the response columns in \code{data} e.g. \code{c(1,2)} \cr o Two-element character vector specifying the response column names in \code{data} e.g. \code{c("survived", "died")}. The full names must be used (partial matching isn't supported). } \item{sort}{ Default \code{FALSE}. Use \code{TRUE} to sort the rows of the long data so it is returned in canonical form, independent of the row order of the short data. The long data is sorted on predictor values; predictors on the left take precedence in the sort order. } \item{\dots}{ Unused, but provided for generic/method consistency. } } \value{ A dataframe of the data in the long form, with expanded binomial pairs. The first column of the data will be the response column (a column of \code{TRUE}s and \code{FALSE}s). Additionally, the returned value has two attached attributes: \code{bpairs.index} A vector of row indices into the returned data. Can be used to reconstruct the short data from the long data (although this package does not yet provide a function to do so). \code{ynames} Column names of the original response (a two-element character vector). } \examples{ survived <- c(3,2,1,1) # short data for demo (too short to build a real model) died <- c(0,1,2,2) dose <- c(10,10,20,20) sex <- factor(c("male", "female", "male", "female")) short.data <- data.frame(survived, died, dose, sex) expand.bpairs(survived + died ~ ., short.data) # returns long form of the data # expand.bpairs(data=short.data, y=cbind(survived, died)) # equivalent # expand.bpairs(short.data, c(1,2)) # equivalent # expand.bpairs(short.data, c("survived", "died")) # equivalent # For example models, see the earth vignette # section "Short versus long binomial data". } earth/man/format.earth.Rd0000644000176200001440000001047113437040777015030 0ustar liggesusers\name{format.earth} \alias{format.earth} \title{Format earth objects} \description{ Return a string representing an \code{\link{earth}} expression (\code{\link{summary.earth}} calls this function internally to display the terms of the \code{earth} model). } \usage{ \method{format}{earth}(x = stop("no 'x' argument"), style = "h", decomp = "anova", digits = getOption("digits"), use.names = TRUE, colon.char = ":", \dots) } \arguments{ \item{x}{ An \code{\link{earth}} object. This is the only required argument. } \item{style}{ Formatting style. One of\cr \code{"h"} (default) more compact\cr \code{"pmax"} for those who prefer it\cr \code{"max"} is the same as \code{"pmax"} but prints \code{max} rather than \code{pmax}\cr \code{"C"} C style expression with zero based indexing\cr \code{"bf"} basis function format } \item{decomp}{One of\cr \code{"anova"} (default) order the terms using the "anova decomposition", i.e., in increasing order of interaction\cr \code{"none"} order the terms as created during the earth forward pass.\cr } \item{digits}{ Number of significant digits. The default is \code{getOption(digits)}. } \item{use.names}{One of\cr \code{TRUE} (default), use variable names if available.\cr \code{FALSE} use names of the form \code{x[,1]}. } \item{colon.char}{ Change colons in the returned string to colon.char. Default is ":" (no change). Specifying \code{colon.char="*"} can be useful in some contexts to change names of the form \code{x1:x2} to \code{x1*x2}. } \item{\dots}{ Unused, but provided for generic/method consistency. } } \value{ A character representation of the \code{earth} model. If there are multiple responses, \code{format.earth} will return multiple strings. If there are embedded GLM model(s), the strings for the GLM model(s) come after the strings for the standard \code{earth} model(s). } \note{ The FAQ section in the package vignette gives precise details of the \code{"anova"} ordering. Using \code{format.earth}, perhaps after hand editing the returned string, you can create an alternative to \code{predict.earth}. For example: \preformatted{as.func <- function(object, digits = 8, use.names = FALSE, ...) eval(parse(text=paste( "function(x){\n", "if(is.vector(x))\n", " x <- matrix(x, nrow = 1, ncol = length(x))\n", "with(as.data.frame(x),\n", format(object, digits = digits, use.names = use.names, style = "pmax", ...), ")\n", "}\n", sep = ""))) earth.mod <- earth(Volume ~ ., data = trees) my.func <- as.func(earth.mod, use.names = FALSE) my.func(c(10,80)) # returns 16.84 predict(earth.mod, c(10,80)) # returns 16.84 } Note that with \code{pmax} the R expression generated by \code{format.earth} can handle multiple cases. Thus the expression is consistent with the way \code{predict} functions usually work in R --- we can give \code{predict} multiple cases (i.e., multiple rows in the input matrix) and it will return a vector of predicted values. \preformatted{ % trick to force a paragraph break TODO why is this needed? } The earth package also provides a function \code{format.lm}. It has arguments as follows\cr \code{format.lm(x, digits=getOption("digits"), use.names=TRUE, colon.char=":")}\cr (Strictly speaking, \code{format.lm} doesn't belong in the earth package.) Example: \preformatted{ lm.mod <- lm(Volume ~ Height*Girth, data = trees) cat(format(lm.mod, colon.char="*")) # yields: # 69.4 # - 1.30 * Height # - 5.86 * Girth # + 0.135 * Height*Girth } } \seealso{ \code{\link{summary.earth}}, \code{\link{pmax}}, } \examples{ earth.mod <- earth(Volume ~ ., data = trees) cat(format(earth.mod)) # yields: # 37.9 # - 3.92 * h(16-Girth) # + 7.4 * h(Girth-16) # + 0.484 * h(Height-75) cat(format(earth.mod, style="pmax")) # yields: # 37.9 # - 3.92 * pmax(0, 16 - Girth) # + 7.4 * pmax(0, Girth - 16) # + 0.484 * pmax(0, Height - 75) cat(format(earth.mod, style="C")) # yields (note zero based indexing): # 37.927 # - 3.9187 * max(0, 16 - x[0]) # + 7.4011 * max(0, x[0] - 16) # + 0.48411 * max(0, x[1] - 75) cat(format(earth.mod, style="bf")) # yields: # 37.9 # - 3.92 * bf1 # + 7.4 * bf2 # + 0.484 * bf3 # # bf1 h(16-Girth) # bf2 h(Girth-16) # bf3 h(Height-75) } \keyword{models} earth/man/evimp.Rd0000644000176200001440000000556412520127604013550 0ustar liggesusers\name{evimp} \alias{evimp} \title{Estimate variable importances in an earth object} \description{ Estimate variable importances in an \code{\link{earth}} object } \usage{ evimp(object, trim=TRUE, sqrt.=TRUE) } \arguments{ \item{object}{ An \code{\link{earth}} object. } \item{trim}{ If \code{TRUE} (default), delete rows in the returned matrix for variables that don't appear in any subsets. } \item{sqrt.}{ Default is \code{TRUE}, meaning take the \code{\link{sqrt}} of the GCV and RSS importances before normalizing to 0 to 100. Taking the square root gives a better indication of relative importances because the raw importances are calculated using a sum of squares. Use \code{FALSE} to not take the square root. } } \value{ This function returns a matrix showing the relative importances of the variables in the model. There is a row for each variable. The row name is the variable name, but with \code{-unused} appended if the variable does not appear in the final model. The columns of the matrix are (not all of these are printed by \code{print.evimp}): \itemize{ \item \code{col}: Column index of the variable in the \code{x} argument to \code{earth}. \item \code{used}: 1 if the variable is used in the final model, else 0. Equivalently, 0 if the row name has an \code{-unused} suffix. \item \code{nsubsets}: Variable importance using the "number of subsets" criterion. Is the number of subsets that include the variable (see "Three Criteria" in the chapter on \code{evimp} in the \code{earth} vignette \dQuote{\href{../doc/earth-notes.pdf}{Notes on the earth package}}). \item \code{gcv}: Variable importance using the GCV criterion (see "Three Criteria"). \item \code{gcv.match}: 1, except is 0 where the rank using the \code{gcv} criterion differs from that using the \code{nsubsets} criterion. In other words, there is a 0 for values that increase as you go down the \code{gcv} column. \item \code{rss}: Variable importance using the RSS criterion (see "Three Criteria"). \item \code{rss.match}: Like \code{gcv.match} but for the \code{rss}. } The rows are sorted on the \code{nsubsets} criterion. This means that values in the \code{nsubsets} column decrease as you go down the column (more accurately, they are non-increasing). The values in the \code{gcv} and \code{rss} columns are also non-increasing, except where the \code{gcv} or \code{rss} rank differs from the \code{nsubsets} ranking. } \note{ There is a chapter on \code{evimp} in the \code{earth} package vignette \dQuote{\href{../doc/earth-notes.pdf}{Notes on the earth package}}. \bold{Acknowledgment} Thanks to Max Kuhn for the original \code{evimp} code and for helpful discussions. } \seealso{ \code{\link{earth}}, \code{\link{plot.evimp}} } \examples{ data(ozone1) earth.mod <- earth(O3 ~ ., data=ozone1, degree=2) ev <- evimp(earth.mod, trim=FALSE) plot(ev) print(ev) } \keyword{models} earth/man/update.earth.Rd0000644000176200001440000000643212525341724015015 0ustar liggesusers\name{update.earth} \alias{update.earth} \title{Update an earth model} \description{ Update an \code{\link{earth}} model. } \usage{ \method{update}{earth}(object = stop("no 'object' argument"), formula. = NULL, ponly = FALSE, \dots, evaluate = TRUE) } \arguments{ \item{object}{ The earth object} \item{formula.}{ The \code{formula.} argument is treated like earth's \code{formula} argument.\cr } \item{ponly}{ Force pruning only, no forward pass. Default is \code{FALSE}, meaning \code{update.earth} decides automatically if a forward pass is needed. See note below. } \item{\dots}{ Arguments passed on to \code{\link{earth}}. } \item{evaluate}{ If \code{TRUE} (default) evaluate the new call, else return the call. Mostly for compatibility with the generic \code{\link{update}}. } } \details{ If only the following arguments are used, a forward pass is unnecessary, and \code{update.earth} will perform only the pruning pass. This is usually much faster for large models. \preformatted{ object glm trace nprune pmethod Eval.model.subsets Print.pruning.pass Force.xtx.prune Use.beta.cache Endspan.penalty Get.leverages } This automatic determination to do a forward pass can be overridden with the \code{ponly} argument. If \code{ponly=TRUE} the forward pass will be skipped and only the pruning pass will be executed. This is useful for doing a pruning pass with new data. (Use earth's \code{data} argument to specify the new data.) Typically in this scenario you would also specify \code{penalty=-1}. This is because with sufficient new data, independent of the original training data, the RSS not the GCV should be used for evaluating model subsets (The GCV approximates what the RSS would be on new data --- but here we actually have new data, so why bother approximating. This "use new data for pruning" approach is useful in situations where you don't trust the GCV approximation for your data.) By making \code{penalty=-1}, earth will calculate the RSS, not the GCV. See also the description of \code{penalty} on the \code{\link{earth}} help page. \cr \cr Another (somewhat esoteric) use of \code{ponly=TRUE} is to do subset selection with a different \code{penalty} from that used to build the original model. \cr \cr With \code{trace=1}, \code{update.earth} will tell you if earth's forward pass was skipped. \cr \cr If you used \code{keepxy=TRUE} in your original call to \code{earth}, then \code{update.earth} will use the saved values of \code{x}, \code{y}, etc., unless you specify otherwise by arguments to \code{update.earth}. It can be helpful to set \code{trace=1} to see which \code{x} and \code{y} is used by \code{update.earth}. } \value{ The value is the same as that returned by \code{\link{earth}}. If \code{object} is the only parameter then no changes are made --- the returned value will be the same as the original \code{object}. } \seealso{ \code{\link{earth}} } \examples{ data(ozone1) (earth.mod <- earth(O3 ~ ., data = ozone1, degree = 2)) update(earth.mod, formula = O3 ~ . - temp) # requires forward pass and pruning update(earth.mod, nprune = 8) # requires only pruning update(earth.mod, penalty=1, ponly=TRUE) # pruning pass only with a new penalty } \keyword{models} earth/man/mars.to.earth.Rd0000644000176200001440000000513213312347111015101 0ustar liggesusers\name{mars.to.earth} \alias{mars.to.earth} \title{Convert a mars object from the mda package to an earth object} \description{ Convert a \code{\link[mda]{mars}} object from the \code{mda} package to an \code{\link{earth}} object } \usage{ mars.to.earth(object, trace=TRUE) } \arguments{ \item{object}{ A \code{mars} object, created using \code{\link[mda]{mars}} in the \code{mda} package. } \item{trace}{ If \code{TRUE} (default) print a summary of the conversion. } } \value{ The value is the same format as that returned by \code{\link{earth}} but with skeletal versions of \code{rss.per.subset}, \code{gcv.per.subset}, and \code{prune.terms}.\cr You can fully initialize these components by calling \code{\link{update.earth}} after \code{mars.to.earth}, but if you do this \code{selected.terms} may change. However with \code{pmethod="backward"} a change is unlikely --- \code{selected.terms} would change only if GCVs are so close that numerical errors have an effect. } \note{ \bold{Differences between mars and earth objects} Perhaps the most notable difference between \code{mars} and \code{earth} objects is that \code{mars} returns the MARS basis matrix in a field called "\code{x}" whereas \code{earth} returns "\code{bx}" with only the selected terms. Also, \code{earth} returns "\code{dirs}" rather than "\code{factors}", and in \code{earth} this matrix can have entries of value 2 for linear predictors. For details of other differences between \code{mars} and \code{earth} objects, see the comments in the source code of \code{mars.to.earth}. \bold{Weights} The \code{w} argument is silently ignored by \code{mars}. % The equivalent \code{earth} argument \code{weights} is also not yet supported, % and you will get a warning. \code{mars} normalizes \code{wp} to (euclidean) length 1; \code{earth} normalizes \code{wp} to length equal to the number of responses, i.e., the number of columns in \code{y}. This change was made so an all ones \code{wp} (or in fact any all constant \code{wp}) is equivalent to using no \code{wp}. If the original call to \code{mars} used the \code{wp} argument, \code{mars.to.earth} will run \code{\link{update.earth}} to force consistency. This could modify the model, so a warning is issued. } \seealso{ \code{\link{earth}}, \code{\link[mda]{mars}} } \examples{ if(require(mda)) { mars.mod <- mars(trees[,-3], trees[,3]) earth.mod <- mars.to.earth(mars.mod) # the standard earth functions can now be used # note the reconstructed call in the summary summary(earth.mod, digits = 2) } } \keyword{models} earth/man/model.matrix.earth.Rd0000644000176200001440000000520413052052203016115 0ustar liggesusers\name{model.matrix.earth} \alias{model.matrix.earth} \title{Get the earth basis matrix} \description{ Get the basis matrix of an \code{\link{earth}} model. } \usage{ \method{model.matrix}{earth}(object = stop("no 'object' argument"), x = NULL, subset = NULL, which.terms = NULL, trace = 0, \dots, Env = parent.frame(), Callers.name = "model.matrix.earth") } \arguments{ \item{object}{ An \code{\link{earth}} model. This is the only required argument. } \item{x}{ Default is NULL, meaning use the original data used to build the \code{earth} model (after taking the original \code{subset}, if any). Else \code{x} can be a data frame, a matrix, or a vector with length equal to a multiple of the number of columns of the original input matrix \code{x}. (There is some leniency here. For example, column names aren't necessary if \code{x} has the same number of predictors originally used to build the \code{earth} model.) } \item{subset}{ Which rows to use in \code{x}. Default is NULL, meaning use all of \code{x}. } \item{which.terms}{ Which terms to use. Default is NULL, meaning all terms in the earth model (i.e. the terms in \code{object$selected.terms}). } \item{trace}{ Default 0. Set to non-zero to see which data \code{model.matrix.earth} is using. } \item{\dots}{ Unused, but provided for generic/method consistency. } \item{Env}{ For internal use. } \item{Callers.name}{ For internal use (used by earth in trace messages). } } \value{ A basis matrix \code{bx} of the same form returned by \code{\link{earth}}. The format of \code{bx} is described in \code{\link{earth.object}}. If \code{x}, \code{subset}, and \code{which.terms} are all NULL (the default), this function returns the model's \code{bx}. In this case, it is perhaps easier to simply use \code{object$bx}.\cr The matrix \code{bx} can be used as the input matrix to \code{\link{lm}} or \code{\link{glm}}, as shown below in the example. In fact, that is what earth does internally after the pruning pass --- it calls \code{\link{lm.fit}}, and additionally \code{\link{glm}} if earth's \code{glm} argument is used. } \seealso{ \code{\link{earth}} } \examples{ data(trees) earth.mod <- earth(Volume ~ ., data = trees) summary(earth.mod, decomp = "none") # "none" to print terms in same order as lm.mod below bx <- model.matrix(earth.mod) # equivalent to bx <- earth.mod$bx lm.mod <- lm(trees$Volume ~ bx[,-1]) # -1 to drop intercept summary(lm.mod) # yields same coeffs as above summary # displayed t values are not meaningful } \keyword{models} earth/man/contr.earth.response.Rd0000644000176200001440000000135412542763517016522 0ustar liggesusers\name{contr.earth.response} \alias{contr.earth.response} \title{Please ignore} \description{ Contrasts function for factors in the \code{\link{earth}} response. For internal use by earth. } \usage{ contr.earth.response(x, base, contrasts) } \arguments{ \item{x}{ a factor } \item{base}{ unused } \item{contrasts}{ unused } } \value{ Returns a diagonal matrix. An example for a 3 level factor with levels \code{A}, \code{B}, and \code{C}: \preformatted{ A B C A 1 0 0 B 0 1 0 C 0 0 1 } } \note{ Earth uses this function internally. You shouldn't need it. It is made publicly available only because it seems that is necessary for \code{model.matrix}. } \seealso{ \code{\link{contrasts}} } \keyword{models} earth/man/predict.varmod.Rd0000644000176200001440000000372412506743406015355 0ustar liggesusers\name{predict.varmod} \alias{predict.varmod} \title{Predict with a varmod model} \description{ You probably won't need to call this function directly. It is called by \code{\link{predict.earth}} when that function's \code{interval} argument is used. } \usage{ \method{predict}{varmod}( object = stop("no 'object' argument"), newdata = NULL, type = c("pint", "cint", "se", "abs.residual"), level = .95, trace = FALSE, \dots) } \arguments{ \item{object}{ A \code{varmod} object. } \item{newdata}{ Make predictions using \code{newdata}. Default is NULL, meaning return values predicted from the training set. } \item{type}{ Type of prediction. This is the \code{interval} argument of \code{\link{predict.earth}}. One of \cr\cr \code{"pint"} Prediction intervals. \cr\cr \code{"cint"} Confidence intervals. Cannot be used with \code{newdata}. \cr\cr \code{"se"} Standard error of the parent model residuals. \cr\cr \code{"abs.residual"} The absolute residuals of the parent model on which the residual model regresses. \cr\cr } \item{level}{ Confidence level for the \code{interval} argument. Default is \code{.95}, meaning construct 95\% confidence bands (estimate the 2.5\% and 97.5\% levels). } \item{trace}{ Currently unused. } \item{\dots}{ Unused, but provided for generic/method consistency. } } \note{ \code{predict.varmod} is called by \code{predict.earth} when its \code{interval} argument is used. } \examples{ data(ozone1) set.seed(1) # optional, for cross validation reproducibility # note: should really use ncross=30 below but for a quick demo we don't earth.mod <- earth(O3~temp, data=ozone1, nfold=10, ncross=3, varmod.method="lm") # call predict.earth, which calls predict.varmod predict(earth.mod, newdata=ozone1[200:203,], interval="pint", level=.95) } \seealso{ \code{\link{predict.earth}} \code{\link{varmod}} } earth/DESCRIPTION0000644000176200001440000000166713561510172013076 0ustar liggesusersPackage: earth Version: 5.1.2 Title: Multivariate Adaptive Regression Splines Author: Stephen Milborrow. Derived from mda:mars by Trevor Hastie and Rob Tibshirani. Uses Alan Miller's Fortran utilities with Thomas Lumley's leaps wrapper. Maintainer: Stephen Milborrow Depends: R (>= 3.4.0), Formula (>= 1.2-3), plotmo (>= 3.5.4), TeachingDemos (>= 2.10) Suggests: gam (>= 1.16), mgcv (>= 1.8-26), mda (>= 0.4-10), MASS (>= 7.3-51) Description: Build regression models using the techniques in Friedman's papers "Fast MARS" and "Multivariate Adaptive Regression Splines" . (The term "MARS" is trademarked and thus not used in the name of the package.) License: GPL-3 LazyData: yes URL: http://www.milbo.users.sonic.net/earth Packaged: 2019-11-08 22:13:36 UTC; milbo Repository: CRAN Date/Publication: 2019-11-09 10:10:02 UTC RoxygenNote: 5.1.2 NeedsCompilation: yes earth/build/0000755000176200001440000000000013561364217012464 5ustar liggesusersearth/build/partial.rdb0000644000176200001440000011053113561364217014612 0ustar liggesusers |YzAM@}$35 93= ]=]YKlޕ]GNDZĎَ_v,'N+>"%CЍwt:އ3LWfuwYɬݵS`w7 [37NsjfXUX6K*P޲zߚ hFV|eRn /_<{R.d3+E/b9_;;~_Z k] gO?0%o-/*Eo+Dt'ӑ陪_ȏ_<:~176u1RtKRNW?|aI7+RR}V?n64gkY.u~qMhlK! P)]h%&VZ%PWnw&zSE)cFIg{n)zp=m ^{_3P/|lP)V bt6\3ݬL7k#A5˚UekbIbkek Z\*^AIݔw[MrA)畣&PrS7|,ULwѭzX m^*I[*)cJ6=^>K+ĪՐ(W&V^aT-P;|,Ux /ߍz4lf`}cÎ,z|&̜rM 3isNQd)s>s.Y7v*˳_PZqŹN!14˜\n&cJȉm7n5@%B}Tʐr (>1t?~מW~҃G9Qy?GBf2y!TTK4s}w9 y)W p"K/_W皲iʧ\M<1,*!{S]D+N-Noi҂4&[Q/e<|A6&Ư;~9ej0S tFPxy5\Ci`YK%jؔAX#9:`)kIlH(+hovcͲ1ڛ壳e.-PԎӔ tvE R>'''NGl_ӑ /siɐg(1&;zv\c'ҟN8"o wXFZ6Ko} Cθs.p7yN-|[\ K4_yDvt4d1uCt1ذ\-Cl:bneQ?f{[(^^E%A9H(eS9W~ӝh'NDo5O7ٺ?FA6Uz3qޢ|%K<*9/[i/COr6潄8&zM*I~_.-R~|܅7zˋosL? nΘwiȹ_OQPzcӭfnPѾ$ޡ|-$ޥ|}jXY21^?U4`JrF%ǰTN K<@z)kǍD8V2u UmU͂ShjW32-S ̷d^|#cnܛ*wwfjA}*$5rLJln}\c-SmJFYtfYF: *H:56%*HMՑt:n n:JU&& G`#?" Ib&^٨>6:`=Rwi,Kyzݔ TVfUVVKjl1zL--VǶIL_* SY=y1qᬘTBCg/%'83梠2WqgaS#Kn~PTu*0$NQjSA =Z< 類!dU3I.[)w oK!CĞ,iJ?( Ŏ] czGr8Hy ulj(3͎ yEz".W(1*_M!Cp!lKr/E^%vPۍ:~h۲4UwM%ڝ$2t)Z2;rxllbN<|ZC>){ `PߝB;A΢_(8~)$VL0%l)y^^y!u*=2|BUl EbHh~f:QmA8onѡW,TK}a"#te8FY+,ZZ)W:_ ^lreų*u)X,x9ϝ)xrlxqU "4.xV[ަ|%nQln%7sAŏ̒KXXD[qްw\mFl2K5@f[P5A|Hk(wo]zA2 ɦZ)(b()뭗.tH=ZFTa 'S1{}˼E#SJ2jwh롾;v4R}جhqymШʐYY=cXeDC=f5iO+6)E04zyBKe^+$4ZQD`mZPOG YG bh #v=<˴ba6e4!580쥡x7*OYe:ڨ@}W [Ө4kFk:#[t9|LdF ʶ%"/%A~)s<3/T62mʷ[oT` 4 }i)q'h_ CCJۮ$= ƗUN˅C嵋i{gl G)6 /Œ\+-d`ss7R@Kj݇ Ɵ7c>GGw NL 4va08 ҵògZ۶ܪn>C,-W< hxB>;Ccʏk57sR=p !PksE D@UtɄ]Er_vh۴%3A KIلDRf~}ȑ./(p|8~MM7#qijB^lLVdnފxFμ94;GUF7))Ń7:5E|Ha{jkwߩ@)cHcp/%y[.ĠR++Y`*C%sY{jZ@6B>b?~jR_mD=r%^%tJָ,EDm1W~6/*QTщ

ㄅ`Qr|`6wRz<=<d(Yy*W'TmfqEg֯[s&&/3OW/2evP2|:Qk׳ZӧkXX5RJP* 7+q]bYpBg+Kڊ]+?L!VxʜttƋ?ԕxˊ2r 4:/7-&ؒB>_q§Nx+}u~UjtL "F Px Lw'oG)%_jf35I u mrS.ĽͦD]:OlLIOR~;r+„|W'Pʹ/!So#^lAuǃiզ .P6?׬մ ^hck ԴRhi;>q4$/yon)GX 8DyȘd42mʷ_iǹ/.&b ^Nk˟ ֬X 7!ƤD~@S ԟJ!C"{wV5)NQ%1qOK5`IP~RRǐƄ,Upq.<> T ˜Yf'(O0V 8f2dN檱\ h>b1qG`Z _ [pON?w=%W"-y1FyVX;﴿<~2|L{ȸ<q\Uⲭt&GN_|^8C!^'\!k3;Vja\f(`dehm"n|-'8* Y?#sExl> 蘿!Kq.NZxVYp$V.B)cmdo@Z?w h[IbF.wPޡCOhZZїB>vXLL:vEohIϖ=7M?x ơqqmmIP*,9Ez9Rl $eюz\"28MX-,:(/+=ﵾ3XՙYt33(oSlCOKƎ1!<Sv0gV{!iW=vm"#y.oS֚5AP7LCq%A$nKM[ /VRآVgd{͸}- мչ`ZT#vZ+:Y}ZjY6T[pOԸ򴲠3 zv )ӎyI|EPT _$]{mε{2O|Mu{*eX\0ͯG_JĀr`:4bd_֩@12@f+q]Oa>j (V/Y84esx `,qvUK E^? X`e=]+\tk7^V,h04 ;t5.U4vۭz^A[xB!ʇg$P8C4SOcN5-rdBg%fjܵƉS:|@=}:ce ȰAk .[;)lu"X ~:EA$'$e;Ro N3mۑa❌͵L w(G34s^ɫ UaY7lf+GȝQ5 :F'GGy_[DJOӕ4?JGQ]Us(7cciuͪdfg@c J}3ͦiomܲE/7ixYu׍kkfӃsx4CI;ĻﶿIPcI$ 3Ӷ& zr:H(uvexVDz$^w~: .Qju3(NIYVʍOO_/[` 4c>;Rȧ>uĝ[s^'X* Q+)l@!'2ꏦO[ҺOU['ߢo|˪lC[ɋ 5xh #: ԟH!ʷn(OMHMmǷ&\ԗƾMfKM 0e$[FnGRȧCnto\Tuk$&7qƏ[uS\+[nei(q'S՞6)^"^l~HEمj tȅCNk\Hy%;tBߡ|Ǫ 8B!GCt TOTz6&(C&OP{a4!]7;C])iA|s"ߘQ##QX Ǭ@ck XF̡ѣkPq\"sq=/ Jy-ZeEfa BoS$R~Nߡl%>Ș1&ڒQ W]f SVhc}/,'S R3Y;MRζd8q򈱩x *~91橚58_R~i̵f֊tmZ-V|Kđc /֠{8JyԢy|}1Ze ʿW F Ǎ/Iϕ(R$ |.Qgko\\2^65Oĝw Rǐq*?.{_Dʂ忞'F'ȏܒUd{؋eiVK{K˶oR h3UjlҡlGP+|}դH;wZM4]väQ[3ҫkFRӢ)cXc#y"iLĢxP|-UҴ#GLUz&./Sl_yh%^lqS66MXſ}q6؟B>aB.٦;CZt3Uwܒ~ٓs~֋`~P C_ߞh])lMSJn!ZR$;23n59cXeb$5%"OE5".NZkw5D;( ^v@n :zθj n(ۤy]"mz9iG<$>)OLr?| =9H[̻EAJ[%'g~'*D{>(KGܹ(ޔ CDcn!i,3K,<^Wʀ(_2((;|}rn^#5HǮjoӨ5RPGϸZx6^1{Ü.Pċ"Od~%5JSbEҭH5)ONH4b 'FCq?nÙp?))!^loBm-@}W [Е}f^7#M>bIJR8Oَ\M3##+42e^Aэ< vT>r^l&|D+ <{rq1#ՁDV#Ni D(8oOI!C.rsQ5*"RLYw(38W9 ;16M rv"<@|'ll&9SDAO'r[-~AmʷjrǴ`/^#jdK_^x 24^.mIt'([[# 7QJO;j vPxy[\=P0| i[?>ô?RؚyOCa-)=OO{ 1qV3WYpes3EYo'ӼǍy?9+a=;_H`jI$'ggR9cevPm4dIJߣ^}SL,O6d6gblI&FUo೟xߠnѡW!L~"m2[0UNS6== 6EDFmO?EGR[jjJ&Z A]/q?eզ0&򦶋D ^1:KN);eܑ gZBQo~ƼCט|g7?CֺRڟl\3^)_3CnWcauSy?^⡖&T6ߢѴAw()7mPn 1O9W,lFz@S?CS3c[MPwxOO)﬌\c,T ߡlnbu3ZKV=?՚,m 8Nyܘ.F 8̣7T(kNjX~?G3 PGo\MїMi+,Iت|UM O?l)9L,KFn̢"qWohyǔk`O(?k @{)cHtG/6BVwj>3mт]D'󽷣^'{;Zl@/҄mт-0:Ku*Lmea'.^K4")Z3{[YtfUͶm8Byĸ괷@cxux:~mebho+ؚ[Yn(,azSq!wi?qstC$"CyOǻs9LXa!--*p5sUM6ioP7Nwd٧Q&pElXڕ?.G^/r' 환`ijeIBqL}ѺfOψWNy9r*׿K~3w\={v\؞CIbD,lEIy7M|'33x6SIh]o5i;RG[A>⹌uP UԯRG=UB5Cu7_*.?+p/WUmUYyyM[xn~)i@d>Bqm+!Rnd!hǵ[*^X1uG}6l(GTN\_kwWxEųDq)r#&7bznV~D;XlKl~Mm~A}W h6톁neU/'4U`д@cG {W_PWm{Np}F$Ϡi7.}4>{͗9aS-&+b 4NK7[Q֋X ħ5M3cg)cHtCXP QՁ$'56]ă׎z<0"J&yzޟ_ebKD}i iim`UE.0KYo6-i8QՏȓslhipkP6E|ޑWʍ!ǍH* Pv: q6|Z Pw8@y6F Zhb rx e8.Yx5{1Uwju׉w)5 CX֨)[s+j.ȓiGM|Jd@u{꟥O{&DP9eC1!-9UP^=eg|̚׬u@4eEo5ׁ/]w0Dlo+V5)NH^%k;|NIYжqp"xu2A|VL\x -<$lNi2M-Z`*<+"|fu{eǸ6N%8AH#~|R~hթg)ӎyeTmhA`yCA4TP(op .[;)lyw+ganΊW^> AcvrxʳUb91HAQ\A>&Uw9 Y?{H{aĝ^㿢U?_A~CkrS7id˵[XSM]D{+(g1}. >`4Z5Sis&] e5)_ʪmtآS/!%czۥ 6-uҊL:{;yRJ%~ j!xu!֎/E#K#Ի|dV]2КOZR;M-n(G/HTE|Y~îuL&~* &=ث .ǥ܆uWn/ёuTS#U+RgB1-,r>e 9~;"/3[- ʎMsNN vΥ<),-,eڔ_4rTT˻V?0TTN =,cSNĻW]R[Wj҄{| 0E kn8A@ gqN|!ƻΠ!2]"^{#FFjP=I4Jިfu(-|ʿW F#QpkRIoSN\Z f,мAl6ޗ͎܈/̖͸6N'8n%^~ \ 8%xx^z!^M\i^|w Y)gh[hѠh}I;m:^E gmmOYUk:uRnC.|n7LvaUgB %d,tEUųwlV^^b =!l%̴+2b]EF,>:GOK`пؿn$ijP;F<'eMRo}T5Lρ-g n "-e ^g_94X}R'n;=vu;n姝,-,et;C b3-U9biz;r8{b7 b{Zl .jĽWS{CėRZuotU>RA<4yH˕k;g<nyUzણvP]GK̅IڟlKZ/woi+ېEK-m9'^ lmm]XC))k*mg[sKY/gz#>e%˙Щx\A/K؞&o&&o?Kh|Vn)\T)#eMNurn%?ĭ[|n/񢔁04-137пϯ?T'OўNޞ4Ikz< "Nm!flŧa'9WnoIY/1Ui? u lYHhjVCO5%1I|(eSOqOsp:/ʡ dslWT9N<%v'Pwh NQMbH^O^/bq0U)0;C|(e 6Gf(M]RR3C)쓲{W[,n[өijR˲x$%)/I9s=5@,eD +RDvʎ BWl,OR+ʫa9~̽a#e15󁚽Rּ,zOJhU[dziU:ZOe^^6Vzۤ T''H4-{ &aɛ`ŚpO*"Ee{?Fޡ1~+?yQ lOJ*q.㮶fhoJSRpEB:&! >^[y9jZu H۳>Q/ \N܆sRpSMN@%'^ȱa|Jf$ޕge└-!vfNչ-\p/ivMX KB5)F%~gNTOH-Z_TIY7'9 w,#r;p-,xQRR^d3+Ryyζ)"NfuyPwx7crOIɵ1E:'^zq42=8F=v.4mb7M8$e#6 ծqZ 7 4nRtR6`oKYooEg q 4TM(e`/PS1?BLl 9UJUfloJ3A!DmߪcX{&kxGi3gh/ZÃ:j \@u ,]h7fZVg'v~F К Լ96A).,U$AV:k(qsR {oj ╝܂'.̡n;-\^zPӞ!ޕىCTǐauPjm~9ģU)cvOH&@}=ÓKk|Nfl,(; ԟcX~3"g+4e=RnG:Ntl!SU\ 7|[L }pEbR[)pK_Zp qb2H$V}!$p&i>ul-9A5fbޙ~[,t095,yL6؊D.ȫϚ{o(欟ݯ 񨔁kM<&eMk "x'HYbWJl|rCuLCry[#p[)w#ju 4K*5d3Ey3ҪxUwlZѳ-S,Z1IVZcOhɱ-xcڧSVN8nٲ_.$ !QInk.☔-i0I)c3Ɖwla[vi`@ʚh;(yL2;pPW`~9&W"XF d!p55S1nmي8Ի8ǭ7 \k__WlP ^2՞ uċRpy)7q薔G%└-,v k("t0˝ saT3-\yij@CN-|Z WA8X R_H@,#'h^Qr,kQHJyxP;L_>K&eWN5i񺔁Ƌx)ق └-4We20婀$Tv +yBR-Gʩ/.њZ2ej,yRPik)Pq C.x^2_1b wkZ>K`Q 7|q |&6\--Mߣ_g\{K&\-D95$١('c6дGC*e:7iiQƎ: -h}UkHh@s^9L"tEn^ǖT۴?>⧮ <`fxT٭> gTX)"ف7B7[|[+""{at.jSKvhvxc|nJS@1q)[L.gу6u1 710rf~s^ U gIa׃qV@IF2>N`/\K5n/ё9PyNI-o%BW8=j<-ޥ8 ?nx.aY0tK0b][n@0ײfOޟ~8r xEʚ}ҟLԒ'kDGRWOl!hZ^϶ObI1iI@2M7Y\ңRT?UAS1qL mؖDM;, S囵=9bVzjnu#R0s_bN՚h8%e q4ZK^- _=VLrÿ>)[ X 8Bg`f˥xwGAl7qX2]i{DvzΦ漉%Uy$(p? 8Px@Vqc?QĪ@~/HY/YҋR_+uLCd+G~9#s jAL#0 =4s6r-=fI:F0#ސ2^u77@)񎔁Ld0ll(3㗂 S0rg@qcK=QOhXɔC?a+U Ln'܎nPwxWNmm˪`2ElaF)-hod1;V,}h<@<+e &$)ɠ5Bf⠔5/NNj|oHjd. CPUǖE5j =D(ͦE;h)xLGXXrr.14m hG,R\R;+=B^b5s?USRKW͵-¬ǖ( P|4+ Ü5GVev5Ԍ &oKB&xH|18b QdJSj-6:&OH)vIY/ژ=ZLG4PUi6Q%nZgٽv)E ViaƮ:&au, k>9}iEl7PkZ>.,5ҟ7-xZe~HS}LE2PO<$e`C30pC (<\b+wn@8U%9847ҟđ"\oyq}ќz!~k^r`z/"LМ^q ׉wE[k=P}%`/5 \Dn1)eoҌ6*>q)[^*DG:=pe{e;`tT_G烸_qpWw7h4%}5 >鈓/Wyutٖ?f00] f.bq?g ^ԦZz#xFyG(3M7 \S9QʝH=udjQ6#cX{&(dfi.GcQfV69xOFsOiƾ:&a'#Qnu?+L4-Ѩ-M7!OZ] c45 nLj'Ҥ^G֎xZwD9=P5\9C"e84kg# 7"*g~!c_ea-̆$o-s4+Z ޖ2К͋/5TK#eA諲,NJY/np lP]ƹ,`7K59u4[>->)oSknq-\MJT~~\'ih6L<*HM0y i7i&+\H2giL .LjRnG(  P bQ+R6Q-}j!^"z /I9s}Vvss^O`"๡r)H]&&'2Y^YQFu9 RWoquLCSb3-˕U K˻Jv^TBgxxq |PW}4 ӪeS-RnG@< e aZ Jh5 q\ʚןi8^ ^ᏲA:&6QFn)܎ 9Vm ,8f*ӟ&aYǹ2;>h%NHY %ﮣaLbG}BOH;fَOH i=v>!M"̘Iz̙ øqb漼5( #^r2 E,>gLw0U:LMbJhF9L=h+46@a7q W+DWӜ;k:E4:}֤fB1)aF)biqXj";-:j#GR\KzjZZKRxy?dIr@/[eh&آ&CEm>pۑJz}R:i濡AY|PC< em U}:M<+e4Pw8 v,nBA⠔-,nG'@9y)cϨKt `Ic˦"jGZF6N'h@{IIYݧN,(%תPw8$esx8,e JG]`[ ul٘rUS~_F6)1 S12mAOHY _J'21r:B<_W h'ݓͬE,qPz#OS|~)ZUq5#7c _{+zr +l'r;XD쓲ENͽv!gq{ q{&Ӹy/n☔ RdƇزt9X*#g:~8~\qj1`xIʚ9,%"ʑsެsM佉+EYEl5,ueK9 _&^kk6."4X˯dJoQ&Qo͎TMi"47dq`47WX-п'e͞.S#G܎n7-8s"N;7> ۜ9☔FP5s8.e͈jݒm<2hRI|Thvi-b/HY/ϧΗW}JPvC 4mNywi8CҰf^F&ڷ,B' ĎRnDžP8"e ns7b\:U5J)e~h3EL.}=4A|W@ Jս񩔁Ln(; $E~Zwsbg=ĨG}mگ;ئA}w[Ԧm՘lр}sL9:Zp-B6\3}[>eMV'.odںC 72m!m;D6 i.DmB/o間U|VMIY7i̘&2 ?@<(e` Z hMRmƖGh?R('~Dz@R<_ˤC_ .z ]ǝ ~ȯOp̓ O:q ֛L/OֺH8LzSK] \$^^)5,-*[<߬c860nƞōiTk,EߦҀsi,:$&OM#Ru)Vșw|f$c]گ w̾#HcXuמa9KlP)*mqHp>tf/=?Qhykkϸ3a쁑Wݤ鲗g2\#ϐkͨYZ?p&^^95Pwx]ʚy'ӟG@ M)[获 oVwx׍x1yZmP[jƞ:&fmdho{laJuQ|H~=7eLSO(@ Ig~t>g .`$?^.hx[@CfS2¾g+n95Z?^Rm!`?U_ߦhzSLo׊qr9 =-'2wͧ?Ub\v,Y;,Y f%ۥ%<4Fd"Kq1b=F|!,>ouLCO=F?J1m-=TjdI$͗Ko1y i?|^$E`+w1y4^Y /sAiA=pW ѹ v̴@cO Vӟ=WE*qZA,3<-F>%g[y [Ꞌ#l.6F|Fhr".̊#7DGwGcYJ2ɪ O1y iܦi!L,#V@Y??S} ͊m'\Cstf F܎-?%^%zye/u4z*iogf4N4`/ͤטv%!v"xձ]ۉPho;IDVHY/gNGǥysީcb$k\L9oEFZ*Zo$ҳ0\QHT6Xsibx\]x/la{خt8"eކQ⸔-dR~P1< B?X%JA%zLYGt,Crl;ք| uxQA %)wbhiw;n! xm`?i&dWw&cCv- ߚh-\:e {<3 lՓb58Q~ d&ZU ho4s& xHU ۮB)/)OS5O΢ -p;9m֬o,l|4>hZS(vKhX?QxT2ܾ-S+ނX6PŃKw&VSZ>~kB3,6u|\psGyy?#;Yha O@feߡ u8$v$a)[H !J}|Rg^=vJf+ 8m&d'Ml꺉l!fdogوH00UC#ޢ2&|*PENnImt? 2{܎TN<$e +=Kq&,k+CT <IhȷW#(M KSfJ)9Nz>a~ H0AUKZ\ 6IBE>-+lM)*2/hSlL (&ԂZm+Px\635v!Y809Gr;ƭPw8,\p YH&d5GKgV㠾-ZK(,%E,#{2æEh))r4(iZgeٻ⠳f$MVښu/0K;Zhշ`8.e}u>qRvT]) @-%&7h\@c[fH;Ӗ9&m#91eHԏX(0~&^2RmZ^))cfu׈l;j_11iRշI YGlenj2qF7l&YKYIA2LM Uk oQ? ?Ioڏ[* G-v$Ȇ=Rpll^HsmDz]q+"8Ty{l5]Ky$>`,9"]%[ UwS4A-z,yPm;A6~H4 ϓ^'쿢rfnF)݊B}Ox6Oϰ6~Ngϒ{d5dkCnD50cL5└s\u܉a.߯07Yc?C&wձE |E,5M 4v1y k}L)@j9!Ck\h^@;9eIko"\].K#e`GP7@J%NIj[ߤ4:آ֮y-x%Er>#;6)E$ˊfeL-QV~6#=?+S{l.֛-]ٓM2=C46DJl!z8d zlaq_{e/"y}}\Gl9=#׌}Eh) |CtJG hִ4B]M*9J<)vtU<Ŋ2\I&$a<8^i=)[V-zƳayush1DIT]ny/7iw۴/q?A%e,&άr/6T2ZoE!tIUG >_|pgP"aݝؖd0}/TV[ ̒sV3M7Y ☔-dNQn~cHc ϳb;X1;U[bWiuK̻L> _=6 h?kUxHئ RMwDĥb9ne[v!^2Аָ'Ev}- h pM/v4 uۈܑ& PI)_%ϴM)-RnFA0 )Qfؾۦ%+:gВYh-wJq"5)PO`nk1FFM+/s~∔-=a JnlN6;r#ycxmwJ'uZ;RഋxTzʩPxLʚ OO9쬗Blq>XLxljwyʼF}PB?)"%RO Vk^ pi( 9Xv0;3oP=iP7 lu{ u{R0,CNe{[R0q3 `A&.P":'{hw2̷ť6a\ƩnlݲW Ck(P} x/q%5mdk͵z,p qpyPG.O:ΔWp|śC+\!x~Ǎm6^+pA1}jucx_ĽUei/ ߐT]$K°Zcျcs۵puD{ X+wകxBzII]ϣ2P}{cEBwS]g=ÙcYhcǏvg|τYJa36ì/:rĤ@rKh,;dFߑ2А[X]TSw炒׈dCqF|{eR1T84#Cv:H0yZm'Hh6_V)VJm]3cTM#eh@F+efpKB^򼼘9}dy/:.WAc7,jl$o=BU^Ik}7)-e Ds{y4d"e)}*ڄuj8qQǤ܎-:;EϘ%?]"yzܮSI9<4zyq{[9RTz\_̈~)jN}N·9CWx3o@_8K*@ƒsSVmr@f+qnrΦOzѲ280T7i<Ӄn9)[R.cKRz9uxYS9+RɇkHxr6nUnjX@X rp61hH\zY"%s O!X6y@{w*wPcHc򴃙<;+V#Yf?ڋg&A)jP 㩊+[2ū^Lr+^rB:&!}p)S3=ifwR2_0S.%_GM&KC|-C}W[y^l9"hhdi `M f1YWdeqooFU-ಃ[8 u=RpW} IB7Y.|7lpGX>aGEA~߫9{A␔ii) y ?$+^/We,e,ZZB1)4Q:"܎9(xUg>gRJǐ6?t *7;cW6Z^|Тb!d3@vb5/ [-C:usxJ.zy∔A*9ML?#^j}{\ =5&>ލTt-@SC4-u?Ϭ~vά4=x U+%/x t7uZ"8&e^Q)mz5^hZ6/HBZ$Â?WH}|.KYo]mŮ$CP??ڊ*$AHY/N`Z:cXI^DRH h0˙dgHk~9)$uPwx^w?D:U:%1jMŔ.kS1y,W6~v,|½CY =t0T1,3Yr_`P]0 H CКk E[<cSR֛5PwxZ.VoH 񬔁<6:,a47@6Zel}n0U/׬]n1)]X|VF<.edlz3mѸS/*~Y P;Ak}640$CwѰ9nJuLR+c3_ *`q(ZNJ<'X{~^vu໡w_We8,e{Ez, LoJj5ҕPEe)4Y"v\U'l0euLCgfyQm7|O䅞fJgy|)KbMDK Gr%ps󎸣["ڹD-bPy䃒~o^81@̗G/ת,&!KǘypWxu`Yq`-u[Bq#Z,xKs)`o-j# 4bMhI6␔AW~E)g.;#DiuM;ywvķ 4$qR.%=޷i=t'n{joKxn~u{-̧6 9V r/Y!hm,@X% {ŵ\y\p$- UƉ 4q& X-x|TJd* A5ryTy?R_S}4 e1tDHނ / _j-|6JBjI8܊xr|0sB|#U X|8UKڧhvۚk-O<#eL AxLAq)n"* 0v}ALumj`|tҠHsEZ'f>Yz$x,׉9۴īRK:>5)k.B_cP9<Ef49>2-|us둯mmRZffжxNʝhx|4&ZjŔkƔW*ӊD~⻑Lݲ\W0`P=l&-#&>0XeuL܂e|aBgؐ36<y|~&oxvL Rl(J㗐_^jD~< u^A<=_w3ru'yoUW_kP{fK~-;ŨawU)>D?FITIW9ٜS%0^9~OئWa ?g\OFWXlt/nu4Y(_jqѵゎZmJjCZZņWWmxٴat~/x+f.(d&k:0LK fZj}Ayz}g}РuxBVoh uRp@:&!H 'WN%W#ђs+Hlqzy!vq3ʹW*366*9ZmK>yvG1OGR-JA`Pf;r:s^~,_${r8)b5"HBeSwwA{#q>/%?bDRed-x2̫kB/q^71OޢjC:&!E/AA!\rYgL9 ڙ@_ݤA(Zܷgw&9WGGFG/]Eի6{&:xMćR[&k>Rh cJbqڦFAE, C]2zҵO2ǬxȱwbfD~j+ pUi7"hiqiayvl_S^)/aHq_fX"ν 峃Lj_2ս;ԝ'~YʝԱcq`h<p{3˧d_1Rd磢bY)[7Bz∔-dQcFMT>rчw!g:X[{ܼ[ɇA ɜRn+LU+ިBbMOE[{ճHUbn1=fQYaVp{)zJY[VR'F\A![r.9.^WR!'e7+;Mz8M1Dl_?Ѷ~K9-Ǥl!ǧTYՖ l (VG҂氄T#LfgGIi<(T&|&eѠ<&<@3 ZrxyHfEZn9[q"͎ 52cϫ39ϽB=_aķl5NNJBew/2煊15Vrt|R[^Ujy(JF]wWZa~܃mmISO0!S:dd vb6WU~jmaٵWE[w=ijRnG\Nl]C:1H<'$\.U\!ޑ2V1F2VqxWz YxORi~m hgLΕ[V&H@z^)[Ud(}Rnnd nKRdbdRߩXѸ!^2дRpkRDi-͟O?+xn9'/D)~v݂?WH91*‹_hxD11(F-gqn2C OIYo)!CO@Kd Y0MJYl,񎔭^⤔-z^߫%D:]ڒr+SD{AX%n&*3Kw-U*dYlF.@:1_ P lq2 YU&#Q)wbW8:miKWI hoѣYYVA^Ø8#{i) Ix\etȋ3-m)3POxG5fY'iJZA:&!~(;+Tw%F9to}5,/IQ#'?Eęy%w'gr8* H-/>2Ar;֣ -[/e)R;PWt~@'_ٻ)?wpij߈qKǰXdc#qniP-zם쐼n‰*6mJQlreF]؏pO,.@Ώ¸LJ0Z*x_.oY(YGzĚOJhkb}PcuS\ӱ~}FnAwHh|--|;Y);_)PcRd[oRwVg+[oR6Wt͊fYbahmU co^+u&qv&zT< ~T/9nXO7 ] &~ZL]_~r^y}iÊ/m;@/ nޖ _s_H8ݖ}լ?WxYY¯"?*ѽMPU2K}iW.VNsWPg/n~5)Ј~{Umy"HYL6רWj˾u_)Wӟbh¥RPpW%o7鹥_]A)0m,+p۫xOn͵UыWv7U<}{GoPolu 3Æ>JJJ,Oñͬ nMٲ j\:W[O3E}YƬ;ԫ{^Q%X&n`ĂW|KlF­UtVUʶx S5?w%T+ae9 U+_[ՌNvUp {p>X,kX)ZTXj]?m|t9JK5w(Zm&j;`eԤ \7l6Zm_w&(BLhOJ<J-b~/nkX anFjM^EL_=i#&TOGE_<:~176ϚSxr!V]=}6eGU/jVglzXCG{ޤ̫ MG ԋlt>|1,5|'K;)_*+#ۨφ 4ÛmWj @2xbXKr"ވDq(1V^9Ĉ+Fu&FouoVBearth/tests/0000755000176200001440000000000013447755125012534 5ustar liggesusersearth/tests/README.txt0000644000176200001440000000020113273367227014222 0ustar liggesusersThis does a basic test to check that earth ported without problems. For much more comprehensive tests, see earth/inst/slowtests. earth/tests/test.earth.R0000644000176200001440000000153213447755125014741 0ustar liggesusers# test.earth.R # Check for porting problems by building a few simple models. # For much more comprehensive tests see earth\inst\slowtests. library(earth) options(digits=3) # prevent floating point implementation issues across machines data(trees) earth.mod <- earth(Volume~., data=trees) print(summary(earth.mod)) allowed.func <- function(degree, pred, parents, namesx) { namesx[pred] != "Height" # disallow "Height" } set.seed(2019) earth.mod2 <- earth(Volume~., data=trees, allowed=allowed.func, trace=1) print(summary(earth.mod2)) # multiple response model using class "Formula" and a factor predictor data(iris) earth.mod3 <- earth(Sepal.Length + Sepal.Width ~ Species, data=iris) print(summary(earth.mod3)) plot(earth.mod3, nresponse="Sepal.Length", which=c(1,3), do.par=2, legend.pos="topleft") plotmo(earth.mod3, nresponse=1, pt.col=2, do.par=0) earth/tests/test.earth.Rout.save0000644000176200001440000000547713447755102016435 0ustar liggesusers > # test.earth.R > # Check for porting problems by building a few simple models. > # For much more comprehensive tests see earth\inst\slowtests. > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > options(digits=3) # prevent floating point implementation issues across machines > data(trees) > earth.mod <- earth(Volume~., data=trees) > print(summary(earth.mod)) Call: earth(formula=Volume~., data=trees) coefficients (Intercept) 29.060 h(14.2-Girth) -3.420 h(Girth-14.2) 6.230 h(Height-75) 0.581 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.3 RSS 209 GRSq 0.96 RSq 0.974 > allowed.func <- function(degree, pred, parents, namesx) + { + namesx[pred] != "Height" # disallow "Height" + } > set.seed(2019) > earth.mod2 <- earth(Volume~., data=trees, allowed=allowed.func, trace=1) x[31,2] with colnames Girth Height y[31,1] with colname Volume, and values 10.3, 10.3, 10.2, 16.4, 18.8,... Forward pass term 1, 2, 4 RSq changed by less than 0.001 at 3 terms (DeltaRSq 9.7e-05) After forward pass GRSq 0.940 RSq 0.962 Prune backward penalty 2 nprune null: selected 3 of 3 terms, and 1 of 2 preds After pruning pass GRSq 0.949 RSq 0.961 > print(summary(earth.mod2)) Call: earth(formula=Volume~., data=trees, trace=1, allowed=allowed.func) coefficients (Intercept) 30.66 h(14.2-Girth) -3.57 h(Girth-14.2) 6.76 Selected 3 of 3 terms, and 1 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: Girth, Height-unused Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.3 RSS 313 GRSq 0.949 RSq 0.961 > # multiple response model using class "Formula" and a factor predictor > data(iris) > earth.mod3 <- earth(Sepal.Length + Sepal.Width ~ Species, data=iris) > print(summary(earth.mod3)) Call: earth(formula=Sepal.Length+Sepal.Width~Species, data=iris) Sepal.Length Sepal.Width (Intercept) 5.01 3.428 Speciesversicolor 0.93 -0.658 Speciesvirginica 1.58 -0.454 Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: Speciesvirginica, Speciesversicolor Number of terms at each degree of interaction: 1 2 (additive model) GCV RSS GRSq RSq Sepal.Length 0.278 39.0 0.597 0.619 Sepal.Width 0.121 17.0 0.367 0.401 All 0.399 55.9 0.547 0.571 > plot(earth.mod3, nresponse="Sepal.Length", which=c(1,3), do.par=2, legend.pos="topleft") > plotmo(earth.mod3, nresponse=1, pt.col=2, do.par=0) > earth/src/0000755000176200001440000000000013561364220012146 5ustar liggesusersearth/src/earth.h0000644000176200001440000001711213560116566013433 0ustar liggesusers// earth.h: externs for earth.c // // This program is free software; you can redistribute it and/or modify // it under the terms of the GNU General Public License as published by // the Free Software Foundation; either version 2 of the License, or // (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // A copy of the GNU General Public License is available at // http://www.r-project.org/Licenses #if !defined(EARTH_H) #define EARTH_H void FreeEarth(void); #if USING_R SEXP ForwardPassR( // for use by R SEXP SEXP_FullSet, // out: nMaxTerms x 1, bool vec of lin indep cols of bx SEXP SEXP_bx, // out: MARS basis matrix, nCases x nMaxTerms SEXP SEXP_Dirs, // out: nMaxTerms x nPreds, elements are -1,0,1,2 SEXP SEXP_Cuts, // out: nMaxTerms x nPreds, cut for iTerm,iPred SEXP SEXP_iTermCond, // out: reason we terminated the forward pass SEXP SEXP_x, // in: nCases x nPreds, unweighted x SEXP SEXP_y, // in: nCases x nResp, unweighted but scaled y SEXP SEXP_yw, // in: nCases x nResp, weighted and scaled y SEXP SEXP_WeightsArg, // in: nCases x 1, never R_NilValue SEXP SEXP_nCases, // in: number of rows in x and elements in y SEXP SEXP_nResp, // in: number of cols in y SEXP SEXP_nPreds, // in: number of cols in x SEXP SEXP_nMaxDegree, // in: SEXP SEXP_Penalty, // in: SEXP SEXP_nMaxTerms, // in: SEXP SEXP_Thresh, // in: forward step threshold SEXP SEXP_nMinSpan, // in: SEXP SEXP_nEndSpan, // in: SEXP SEXP_nFastK, // in: Fast MARS K SEXP SEXP_FastBeta, // in: Fast MARS ageing coef SEXP SEXP_NewVarPenalty, // in: penalty for adding a new variable (default is 0) SEXP SEXP_LinPreds, // in: nPreds x 1, 1 if predictor must enter linearly SEXP SEXP_Allowed, // in: constraints function, can be R NULL SEXP SEXP_nAllowedArgs, // in: number of arguments to Allowed function, 3...5 SEXP SEXP_Env, // in: environment for Allowed function SEXP SEXP_AdjustEndSpan, // in: SEXP SEXP_nAutoLinPreds, // in: assume predictor linear if knot is min predictor value SEXP SEXP_nUseBetaCache, // in: 1 to use the beta cache, for speed SEXP SEXP_Trace, // in: 0 none 1 overview 2 forward 3 pruning 4 more pruning SEXP SEXP_sPredNames); // in: predictor names in trace printfs void EvalSubsetsUsingXtxR( // for use by R double PruneTerms[], // out: specifies which cols in bx are in best set double RssVec[], // out: nTerms x 1 const int* pnCases, // in const int* pnResp, // in: number of cols in y const int* pnMaxTerms, // in const double bx[], // in: MARS basis matrix, all cols must be indep const double y[], // in: nCases * nResp (possibly weighted) const double* pTrace); // in void RegressR( // for testing earth routine Regress from R double Betas[], // out: (nUsedCols+1) * nResp, +1 is for intercept double Residuals[], // out: nCases * nResp double Rss[], // out: RSS, summed over all nResp double Diags[], // out: diags of inv(transpose(x) * x) int* pnRank, // out: nbr of indep cols in x int iPivots[], // out: nCols const double x[], // in: nCases x nCols const double y[], // in: nCases x nResp const int* pnCases, // in: number of rows in x and in y const int* pnResp, // in: number of cols in y int* pnCols, // in: number of columns in x, some may not be used const bool UsedCols[]); // in: specifies used columns in x #endif // USING_R #if STANDALONE void Earth( double* pBestGcv, // out: GCV of the best model i.e. BestSet columns of bx int* pnTerms, // out: max term nbr in final model, after removing lin dep terms int* piTermCond, // out: reason we terminated the foward pass bool BestSet[], // out: nMaxTerms x 1, indices of best set of cols of bx double bx[], // out: nCases x nMaxTerms int Dirs[], // out: nMaxTerms x nPreds, -1,0,1,2 for iTerm, iPred double Cuts[], // out: nMaxTerms x nPreds, cut for iTerm, iPred double Residuals[], // out: nCases x nResp double Betas[], // out: nMaxTerms x nResp const double x[], // in: nCases x nPreds const double y[], // in: nCases x nResp const double WeightsArg[], // in: nCases x 1, can be NULL, not yet supported const size_t nCases, // in: number of rows in x and elements in y const int nResp, // in: number of cols in y const int nPreds, // in: number of cols in x const int nMaxDegree, // in: Friedman's mi const int nMaxTerms, // in: includes the intercept term const double Penalty, // in: GCV penalty per knot const double Thresh, // in: forward step threshold const int nMinSpan, // in: set to non zero to override internal calculation const int nEndSpan, // in: set to non zero to override internal calculation const bool Prune, // in: do backward pass const int nFastK, // in: Fast MARS K const double FastBeta, // in: Fast MARS ageing coef const double NewVarPenalty, // in: penalty for adding a new variable const int LinPreds[], // in: nPreds x 1, 1 if predictor must enter linearly const double AdjustEndSpan, // in: for adjusting endspan for interaction terms const bool AutoLinPreds, // in: assume predictor linear if knot is max predictor value const bool UseBetaCache, // in: 1 to use the beta cache, for speed const double Trace, // in: 0 none 1 overview 2 forward 3 pruning 4 more pruning const char* sPredNames[]); // in: predictor names in trace printfs, can be NULL void FormatEarth( const bool UsedCols[], // in: nMaxTerms x 1, indices of best set of cols of bx const int Dirs[], // in: nMaxTerms x nPreds, -1,0,1,2 for iTerm, iPred const double Cuts[], // in: nMaxTerms x nPreds, cut for iTerm, iPred const double Betas[], // in: nMaxTerms x nResp const int nPreds, const int nResp, // in: number of cols in y const int nTerms, const int nMaxTerms, const int nDigits, // number of significant digits to print const double MinBeta); // terms with fabs(betas) less than this are not printed, 0 for all void PredictEarth( double y[], // out: vector nResp const double x[], // in: vector nPreds x 1 of input values const bool UsedCols[], // in: nMaxTerms x 1, indices of best set of cols of bx const int Dirs[], // in: nMaxTerms x nPreds, -1,0,1,2 for iTerm, iPred const double Cuts[], // in: nMaxTerms x nPreds, cut for iTerm, iPred const double Betas[], // in: nMaxTerms x nResp const int nPreds, // in: number of cols in x const int nResp, // in: number of cols in y const int nTerms, const int nMaxTerms); #endif // STANDALONE #endif // EARTH_H earth/src/allowed.c0000644000176200001440000001364413560116566013760 0ustar liggesusers// allowed.c: routines for the "allowed" parameter of the R function earth(). #include "R.h" #include "Rinternals.h" #ifndef _MSC_VER // microsoft #ifndef bool typedef int bool; #define false 0 #define true 1 #endif #endif #define Dirs_(iTerm,iPred) Dirs[(iTerm) + (iPred)*(nMaxTerms)] static SEXP AllowedFuncGlobal; static SEXP AllowedEnvGlobal; static int nArgsGlobal; static bool FirstGlobal; // Initialize the R function AllowedFuncGlobal from the Allowed function // argument which was passed into ForwardPassR. // For efficiency, we initialize once here rather than in IsAllowed. // // The caller of ForwardPassR has already checked that Allowed is // a function and has 3...5 args: degree, pred, parents, namesx, first. // // The "allowed" function has the following prototype, where // namesx and first are optional. // // allowed <- function(degree, pred, parents, namesx, first) // { // ... // TRUE # return TRUE if allowed // } // // where "degree" is the MARS term degree, with pred in the term. // "pred" is column index in the input matrix x // "parents" is an integer vector of parent predictors // (it's a copy of Dirs[iParent,] // "namesx" is optional and is the colnames of the x arg // to earth, after factor expansion // "first" is optional and is 1 the first time "allowed" // is invoked for the current model // // This code is based on the "Writing R Extensions" manual // Section 5.11 "Evaluating R expressions from C" void InitAllowedFunc( SEXP Allowed, // can be NULL int nAllowedArgs, SEXP Env, const char** sPredNames, int nPreds) { if(Allowed == R_NilValue) AllowedFuncGlobal = NULL; else { if(nAllowedArgs < 3 || nAllowedArgs > 5) error("Bad nAllowedArgs %d", nAllowedArgs); AllowedEnvGlobal = Env; nArgsGlobal = nAllowedArgs; // We use R_PreserveObject/R_ReleaseObject here instead of // PROTECT/UNPROTECT purely to avoid a false warning from CRAN rchk. // In the normal course of operation, FreeAllowedFunc() calls // R_ReleaseObject to undo the call below to R_PreserveObject. // But if there is a call to error in the earth C code (or // R_CheckUserInterrupt doesn't return), an on.exit in // the R code will call FreeEarth to callFreeAllowedFunc. AllowedFuncGlobal = allocList(1 + nAllowedArgs); R_PreserveObject(AllowedFuncGlobal); SEXP s = AllowedFuncGlobal; // 1st element is the function SETCAR(s, Allowed); SET_TYPEOF(s, LANGSXP); s = CDR(s); // 2nd element is "degree" SETCAR(s, allocVector(INTSXP, 1)); s = CDR(s); // 3rd element is "pred" SETCAR(s, allocVector(INTSXP, 1)); s = CDR(s); // 4th element is "parents" SETCAR(s, allocVector(INTSXP, nPreds)); if(nAllowedArgs >= 4) { SEXP namesx; s = CDR(s); // 5th element is "namesx" SETCAR(s, namesx = allocVector(STRSXP, nPreds)); if(sPredNames == NULL) error("Bad sPredNames"); PROTECT(namesx); for(int i = 0; i < nPreds; i++) SET_STRING_ELT(namesx, i, mkChar(sPredNames[i])); UNPROTECT(1); } if(nAllowedArgs >= 5) { s = CDR(s); // 6th element is "first" SETCAR(s, allocVector(LGLSXP, 1)); } } FirstGlobal = true; } void FreeAllowedFunc(void) { if(AllowedFuncGlobal != NULL) { // following matches R_PreserveObject in InitAllowedFunc R_ReleaseObject(AllowedFuncGlobal); AllowedFuncGlobal = NULL; } } static bool EvalAllowedFunc(void) { if(AllowedFuncGlobal == NULL) error("EvalAllowedFunc: AllowedFuncGlobal == NULL"); SEXP s = eval(AllowedFuncGlobal, AllowedEnvGlobal); bool allowed; switch(TYPEOF(s)) { // be fairly permissive with return type case LGLSXP: allowed = (bool)(LOGICAL(s)[0] != 0); break; case INTSXP: allowed = INTEGER(s)[0] != 0; break; case REALSXP: allowed = (bool)(REAL(s)[0] != 0.); break; default: error("the \"allowed\" function returned a %s instead of a logical", Rf_type2char(TYPEOF(s))); allowed = FALSE; // -Wall break; } if(LENGTH(s) != 1) error("the \"allowed\" function did not return a logical of length 1"); return allowed; } // Return TRUE if the current iPred can be used in a term with iParent // i.e. TRUE means no constraint. // // This calls the R function Allowed which was passed in as a parameter to // ForwardPassR. The fields of Allowed have been preallocated into // AllowedFuncGlobal and so all we do here is fill in the values and call eval. bool IsAllowed( const int iPred, // in: candidate predictor const int iParent, // in: candidate parent term const int Dirs[], // in: const int nPreds, // in: const int nMaxTerms) // in: { if(AllowedFuncGlobal == NULL) return TRUE; // AllowedFuncGlobal has been protected by R_PreserveObject SEXP s = AllowedFuncGlobal; // 1st element is the function s = CDR(s); // 2nd element is "degree" INTEGER(CADR(s))[0] = iPred+1; // 3rd element is "pred" int* p = INTEGER(CADDR(s)); // 4th element is "parents" int i, nDegree = 1; for(i = 0; i < nPreds; i++) { p[i] = Dirs_(iParent, i); if(p[i]) nDegree++; } INTEGER(CAR(s))[0] = nDegree; // optional 5th element already initialized to predictor names if(nArgsGlobal >= 5) // optional 6th element is "first" *(LOGICAL(CAD4R(s))) = FirstGlobal; FirstGlobal = false; return EvalAllowedFunc(); } earth/src/leaps.f0000644000176200001440000020752613561156334013442 0ustar liggesusersC Copied from Thomas Lumley's leaps 2.9 package for earth 3.2-6 to avoid C use of external routines in earth causing complaints from CRAN check. C Code which writes to the console has been commented out. C Original Fortran code from Alan Miller. C C PROGRAM START C C This is the starting program for the SUBSETS package of programs. C It forms the upper-triangular Banachiewicz factorization of the C input data. C Free-format input is assumed, i.e. with data fields separated by C spaces, CR's, tabs or commas. N.B. Some Fortran compilers will C not accept tabs and/or commas as delimiters. C Warning: Some Fortran compilers will not allow free format input C of character data. This program inputs the names of variables C in free format. C C Latest revision - 16 August 1992 C C Stephen Milborrow 5 Sep 2016: tweaked code to eliminate warnings: C Warning: Obsolescent feature: DO termination statement which is C not END DO or CONTINUE with label C c___c IMPLICIT NONE c___ integer npmax, dimu c___ parameter (npmax=50, dimu=npmax*(npmax+1)/2) c___ DOUBLE PRECISION U(dimu), EL(0:npmax), RHS(0:npmax), X(0:npmax), c___ + WT, ONE, Y, RESSQ c___ CHARACTER ANS, FNAME*20, VNAME(0:npmax)*8, YNAME*8, TEXT*79 c___ INTEGER LIN, YPOS, IPOS, I, K, ICONST, NCOLS, NOBS, NRBAR, IER, c___ + LINE1, LOUT c___ LOGICAL OK, LSEL c___ DATA WT/1.D0/, ONE/1.D0/, LSEL/.FALSE./ c___ c___C c___C Set unit numbers for I/O in the data statement below. c___C c___ DATA LIN/5/, LOUT/6/ c___C c___C Ask for details of the data file. c___C c___ 10 WRITE(LOUT, 900) c___ 900 FORMAT(' Name of data file = ? ') c___ READ(LIN, *) FNAME c___C c___C Add extension .dat if none has been entered, c___C detected by the lack of a '.' c___C c___ IF (INDEX(FNAME, '.') .EQ. 0) THEN c___ IPOS = INDEX(FNAME, ' ') c___ FNAME = FNAME(1:IPOS-1) // '.dat' c___ END IF c___C c___C Check that file exists. c___C c___ INQUIRE(FILE=FNAME, EXIST=OK) c___ IF (.NOT. OK) THEN c___ WRITE(*, 910) FNAME c___ 910 FORMAT(' *** File not found - ', a, ' **') c___ GO TO 10 c___ END IF c___C c___C Display first part of file. c___C c___ OPEN(10, FILE=FNAME, STATUS='OLD') c___ WRITE(*, *)'Start of your data file follows' c___ DO 20 I = 1, 12 c___ READ(10, '(A)') TEXT c___ WRITE(*, '(1X, A)') TEXT c___ 20 CONTINUE c___ REWIND 10 c___C c___ WRITE(LOUT, 920) c___ 920 FORMAT(' How many X-variables ? ') c___ READ(LIN, *) K c___ WRITE(LOUT, 930) c___ 930 FORMAT('+Do you want a constant in the model ? ') c___ READ(LIN, *) ANS c___ ICONST = 0 c___ IF(ANS.EQ.'Y' .OR. ANS .EQ. 'y') ICONST = 1 c___ NCOLS = K + ICONST c___ NRBAR = NCOLS * (NCOLS - 1) / 2 c___C c___C Get position of dependant variable. c___C c___ WRITE(*, *)'Is dependant variable at end ? (Y/N): ' c___ READ(*, *) ANS c___ IF (ANS .EQ. 'Y' .OR. ANS .EQ. 'y') THEN c___ YPOS = K+1 c___ ELSE c___ WRITE(*, *)'Enter no. of position of dependant variable: ' c___ READ(*, *) YPOS c___ IF (YPOS .LT. 1) YPOS = 1 c___ IF (YPOS .GT. K) YPOS = K + 1 c___ END IF c___C c___C Enter variable names, read them from file, or set defaults. c___C c___ VNAME(0) = 'Constant' c___ WRITE(*, *)'Are variable names in data file ? (Y/N): ' c___ READ(*, *) ANS c___ IF (ANS .EQ. 'Y' .OR. ANS .EQ. 'y') THEN c___ WRITE(*, *)'Which line do names start on ? ' c___ READ(*, *) LINE1 c___ IF (LINE1 .GT. 1) THEN c___ DO 30 I = 1, LINE1-1 c___ 30 READ(10, *) c___ END IF c___ IF (YPOS .GT. K) THEN c___ READ(10, *) (VNAME(I),I=1,K), YNAME c___ ELSE IF (YPOS .EQ. 1) THEN c___ READ(10, *) YNAME, (VNAME(I),I=1,K) c___ ELSE c___ READ(10, *) (VNAME(I),I=1,YPOS-1), YNAME, c___ + (VNAME(I),I=YPOS,K) c___ END IF c___ REWIND 10 c___ ELSE c___ WRITE(*, *)'Do you want to name variables ? (Y/N): ' c___ READ(*, '(a)') ANS c___ IF (ANS .EQ. 'Y' .OR. ANS .EQ. 'y') THEN c___ WRITE(*, *)'Variable names may contain up to 8 characters' c___ WRITE(*, *)'Name for dependant (Y) variable = ? ' c___ READ(*, '(a)') YNAME c___ DO 40 I = 1, K c___ WRITE(*, *)'Name for variable', I, ' = ? ' c___ READ(*, '(a)') VNAME(I) c___ 40 CONTINUE c___ ELSE c___ DO 50 I = 1, K c___ WRITE(VNAME(I), 940) I c___ 940 FORMAT('XVAR(', I2, ')') c___ 50 CONTINUE c___ YNAME = 'Dept.var' c___ END IF c___ END IF c___C c___ WRITE(*, *)'Which line does the data start on ? ' c___ READ(*, *) LINE1 c___ IF (LINE1 .GT. 1) THEN c___ DO 60 I = 1, LINE1-1 c___ 60 READ(10, *) c___ END IF c___C c___C Read in data and form the upper-triangular factorization. c___C c___ IF (ICONST .EQ. 1) THEN c___ CALL CLEAR(NCOLS, NRBAR, EL, U, RHS, RESSQ, IER) c___ ELSE c___ CALL CLEAR(NCOLS, NRBAR, EL(1), U, RHS(1), RESSQ, IER) c___ END IF c___ NOBS = 1 c___ X(0) = ONE c___C c___C Case is skipped if spurious characters are found (e.g. for c___C missing values). c___C c___ 70 CONTINUE c___ IF (YPOS .GT. K) THEN c___ READ(10, *, ERR=70, END=80) (X(I),I=1,K), Y c___ ELSE IF (YPOS .EQ. 1) THEN c___ READ(10, *, ERR=70, END=80) Y, (X(I),I=1,K) c___ ELSE c___ READ(10, *, ERR=70, END=80) (X(I),I=1,YPOS-1), Y, c___ + (X(I),I=YPOS,K) c___ END IF c___ IF (ICONST .EQ. 1) THEN c___ CALL INCLUD(NCOLS, NRBAR, WT, X, Y, EL, U, RHS, RESSQ, IER) c___ ELSE c___ CALL INCLUD(NCOLS, NRBAR, WT, X(1), Y, EL(1), U, RHS(1), RESSQ, c___ + IER) c___ END IF c___ NOBS = NOBS + 1 c___ GO TO 70 c___C c___C Change extension to .red for output file. c___C c___ 80 IPOS = INDEX(FNAME, '.') c___ FNAME(IPOS+1:IPOS+3) = 'red' c___ NOBS = NOBS - 1 c___C c___C Write U, EL, RHS & the residual sum of squares (RESSQ) to disk. c___C c___ OPEN(9, FILE=FNAME, STATUS='NEW', ACCESS='SEQUENTIAL', c___ + FORM='UNFORMATTED') c___ WRITE(9) K, ICONST, NCOLS, NOBS, NRBAR, LSEL c___ IF (ICONST .EQ. 0) THEN c___ WRITE(9) YNAME, (VNAME(I),I=1,K) c___ WRITE(9) (U(I),I=1,NRBAR), (EL(I),I=1,K), (RHS(I),I=1,K), RESSQ c___ ELSE c___ WRITE(9) YNAME, (VNAME(I),I=0,K) c___ WRITE(9) (U(I),I=1,NRBAR), (EL(I),I=0,K), (RHS(I),I=0,K), RESSQ c___ END IF c___ ENDFILE 9 c___C c___ END SUBROUTINE CLEAR(NP, NRBAR, D, RBAR, THETAB, SSERR, IER) C C ALGORITHM AS274 APPL. STATIST. (1992) VOL.41, NO. 2 C C Sets arrays to zero prior to calling INCLUD C INTEGER NP, NRBAR, IER DOUBLE PRECISION D(NP), RBAR(*), THETAB(NP), SSERR C C Local variables C INTEGER I DOUBLE PRECISION ZERO C DATA ZERO/0.D0/ C C Some checks. C IER = 0 IF (NP .LT. 1) IER = 1 IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2 IF (IER .NE. 0) RETURN C DO 10 I = 1, NP D(I) = ZERO THETAB(I) = ZERO 10 CONTINUE DO 20 I = 1, NRBAR RBAR(I) = ZERO 20 END DO SSERR = ZERO RETURN END c___ SUBROUTINE INCLUD(NP, NRBAR, WEIGHT, XROW, YELEM, D, c___ + RBAR, THETAB, SSERR, IER) c___C c___C ALGORITHM AS274 APPL. STATIST. (1992) VOL.41, NO. 2 c___C Modified from algorithm AS 75.1 c___C c___C Calling this routine updates d, rbar, thetab and sserr by the c___C inclusion of xrow, yelem with the specified weight. The number c___C of columns (variables) may exceed the number of rows (cases). c___C c___C**** WARNING: The elements of XROW are overwritten **** c___C c___ INTEGER NP, NRBAR, IER c___ DOUBLE PRECISION WEIGHT, XROW(NP), YELEM, D(NP), RBAR(*), c___ + THETAB(NP), SSERR c___C c___C Local variables c___C c___ INTEGER I, K, NEXTR c___ DOUBLE PRECISION ZERO, W, Y, XI, DI, WXI, DPI, CBAR, SBAR, XK c___C c___ DATA ZERO/0.D0/ c___C c___C Some checks. c___C c___ IER = 0 c___ IF (NP .LT. 1) IER = 1 c___ IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2 c___ IF (IER .NE. 0) RETURN c___C c___ W = WEIGHT c___ Y = YELEM c___ NEXTR = 1 c___ DO 30 I = 1, NP c___C c___C Skip unnecessary transformations. Test on exact zeros must be c___C used or stability can be destroyed. c___C c___ IF (W .EQ. ZERO) RETURN c___ XI = XROW(I) c___ IF (XI .EQ. ZERO) THEN c___ NEXTR = NEXTR + NP - I c___ GO TO 30 c___ END IF c___ DI = D(I) c___ WXI = W * XI c___ DPI = DI + WXI*XI c___ CBAR = DI / DPI c___ SBAR = WXI / DPI c___ W = CBAR * W c___ D(I) = DPI c___ IF (I .EQ. NP) GO TO 20 c___ DO 10 K = I+1, NP c___ XK = XROW(K) c___ XROW(K) = XK - XI * RBAR(NEXTR) c___ RBAR(NEXTR) = CBAR * RBAR(NEXTR) + SBAR * XK c___ NEXTR = NEXTR + 1 c___ 10 CONTINUE c___ 20 XK = Y c___ Y = XK - XI * THETAB(I) c___ THETAB(I) = CBAR * THETAB(I) + SBAR * XK c___ 30 CONTINUE c___C c___C Y * SQRT(W) is now equal to Brown & Durbin's recursive residual. c___C c___ SSERR = SSERR + W * Y * Y c___C c___ RETURN c___ END SUBROUTINE ADD1(NP, NRBAR, D, RBAR, THETAB, FIRST, LAST, TOL, SS, + SXX, SXY, SMAX, JMAX, IER) C C Calculate the reduction in residual sum of squares when one C variable, selected from those in positions FIRST .. LAST, is C added, given that the variables in positions 1 .. FIRST-1 (if C any) are already included. C INTEGER NP, NRBAR, FIRST, LAST, JMAX, IER DOUBLE PRECISION D(NP), RBAR(NRBAR), THETAB(NP), TOL(NP), SS(NP), + SXX(NP), SXY(NP), SMAX C C Local variables C INTEGER J, INC, POS, ROW, COL DOUBLE PRECISION ZERO, DIAG, DY, SSQX DATA ZERO/0.D0/ C C Check call arguments C JMAX = 0 SMAX = ZERO IER = 0 IF (FIRST .GT. NP) IER = 1 IF (LAST .LT. FIRST) IER = IER + 2 IF (FIRST .LT. 1) IER = IER + 4 IF (LAST .GT. NP) IER = IER + 8 IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 16 IF (IER .NE. 0) RETURN C C Accumulate sums of squares & products from row FIRST C DO 10 J = FIRST, LAST SXX(J) = ZERO SXY(J) = ZERO 10 CONTINUE INC = NP - LAST POS = (FIRST-1) * (NP+NP-FIRST)/2 + 1 DO 30 ROW = FIRST, LAST DIAG = D(ROW) DY = DIAG * THETAB(ROW) SXX(ROW) = SXX(ROW) + DIAG SXY(ROW) = SXY(ROW) + DY DO 20 COL = ROW+1, LAST SXX(COL) = SXX(COL) + DIAG * RBAR(POS)**2 SXY(COL) = SXY(COL) + DY * RBAR(POS) POS = POS + 1 20 CONTINUE POS = POS + INC 30 CONTINUE C C Incremental sum of squares for a variable = SXY * SXY / SXX. C Calculate whenever sqrt(SXX) > TOL for that variable. C DO 40 J = FIRST, LAST SSQX = SXX(J) IF (SQRT(SSQX) .GT. TOL(J)) THEN SS(J) = SXY(J)**2 / SXX(J) IF (SS(J) .GT. SMAX) THEN SMAX = SS(J) JMAX = J END IF ELSE SS(J) = ZERO END IF 40 CONTINUE C RETURN END SUBROUTINE BAKWRD(NP, NRBAR, D, RBAR, THETAB, FIRST, LAST, * VORDER, TOL, RSS, BOUND, NVMAX, RESS, IR, NBEST, LOPT, IL, * WK, IWK, IER) C C Backward elimination from variables in positions FIRST .. LAST. C If FIRST > 1, variables in positions prior to this are forced in. C If LAST < NP, variables in positions after this are forced out. C On exit, the array VORDER contains the numbers of the variables C in the order in which they were deleted. C INTEGER NP, NRBAR, FIRST, LAST, VORDER(NP), NVMAX, IR, NBEST, * IL, LOPT(IL, *), IWK, IER DOUBLE PRECISION D(NP), RBAR(NRBAR), THETAB(NP), TOL(NP), RSS(NP), * BOUND(NVMAX), RESS(IR, *), WK(IWK) C C Local variables C INTEGER NEED, POS, J1, JMIN, I DOUBLE PRECISION SMIN C C Check call arguments C IER = 0 IF (FIRST .GE. NP) IER = 1 IF (LAST .LE. 1) IER = IER + 2 IF (FIRST .LT. 1) IER = IER + 4 IF (LAST .GT. NP) IER = IER + 8 IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 16 IF (IWK .LT. 2*LAST) IER = IER + 32 IF (NBEST .GT. 0) THEN NEED = NVMAX*(NVMAX+1)/2 IF (IR .LT. NVMAX) IER = IER + 64 IF (IL .LT. NEED) IER = IER + 128 END IF IF (IER .NE. 0) RETURN C C For POS = LAST, ..., FIRST+1 call DROP1 to find best variable to C find which variable to drop next. C J1 = LAST + 1 DO 20 POS = LAST, FIRST+1, -1 CALL DROP1(NP, NRBAR, D, RBAR, THETAB, FIRST, POS, TOL, WK, * WK(J1), SMIN, JMIN, IER) IF (JMIN .GT. 0 .AND. JMIN .LT. POS) THEN CALL VMOVE(NP, NRBAR, VORDER, D, RBAR, THETAB, RSS, JMIN, POS, * TOL, IER) IF (NBEST .GT. 0) THEN DO 10 I = JMIN, POS-1 CALL REPORT(I, RSS(I), BOUND, NVMAX, RESS, IR, NBEST, LOPT, * IL, VORDER) 10 END DO END IF END IF 20 CONTINUE C RETURN END SUBROUTINE DROP1(NP, NRBAR, D, RBAR, THETAB, FIRST, LAST, TOL, * SS, WK, SMIN, JMIN, IER) C C Calculate the increase in the residual sum of squares when C variable J is dropped from the model, for J = FIRST, ..., LAST. C INTEGER NP, NRBAR, FIRST, LAST, JMIN, IER DOUBLE PRECISION D(NP), RBAR(NRBAR), THETAB(NP), TOL(NP), * SS(LAST), WK(LAST), SMIN C C Local variables C INTEGER J, POS1, INC, POS, ROW, COL, I DOUBLE PRECISION LARGE, ZERO, D1, RHS, D2, X DATA LARGE/1.D+35/, ZERO/0.D0/ C C Check call arguments C JMIN = 0 SMIN = LARGE IER = 0 IF (FIRST .GT. NP) IER = 1 IF (LAST .LT. FIRST) IER = IER + 2 IF (FIRST .LT. 1) IER = IER + 4 IF (LAST .GT. NP) IER = IER + 8 IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 16 IF (IER .NE. 0) RETURN C C POS1 = position of first element of row FIRST in RBAR. C POS1 = (FIRST - 1) * (NP + NP - FIRST)/2 + 1 INC = NP - LAST C C Start of outer cycle for the variable to be dropped. C DO 60 J = FIRST, LAST D1 = D(J) IF (SQRT(D1) .LT. TOL(J)) THEN SS(J) = ZERO SMIN = ZERO JMIN = J GO TO 50 END IF RHS = THETAB(J) IF (J .EQ. LAST) GO TO 40 C C Copy row J of RBAR into WK. C POS = POS1 DO 10 I = J+1, LAST WK(I) = RBAR(POS) POS = POS + 1 10 CONTINUE POS = POS + INC C C Lower the variable past each row. C DO 30 ROW = J+1, LAST X = WK(ROW) D2 = D(ROW) IF (ABS(X) * SQRT(D1) .LT. TOL(ROW) .OR. D2 .EQ. ZERO) THEN POS = POS + NP - ROW GO TO 30 END IF D1 = D1 * D2 / (D2 + D1 * X**2) DO 20 COL = ROW+1, LAST WK(COL) = WK(COL) - X * RBAR(POS) POS = POS + 1 20 CONTINUE RHS = RHS - X * THETAB(ROW) POS = POS + INC 30 CONTINUE 40 SS(J) = RHS * D1 * RHS IF (SS(J) .LT. SMIN) THEN JMIN = J SMIN = SS(J) END IF C C Update position of first element in row of RBAR. C 50 IF (J .LT. LAST) POS1 = POS1 + NP - J C 60 CONTINUE C RETURN END SUBROUTINE EXADD1(IVAR, RSS, BOUND, NVMAX, RESS, IR, NBEST, 1 LOPT, IL, VORDER, SMAX, JMAX, SS, WK, LAST) C C Update the NBEST subsets of IVAR variables found from a call C to subroutine ADD1. C INTEGER IVAR, NVMAX, IR, NBEST, IL, LOPT(IL, NBEST), LAST, * VORDER(LAST), JMAX DOUBLE PRECISION RSS(LAST), BOUND(NVMAX), RESS(IR, NBEST), SMAX, * SS(LAST), WK(LAST) C C Local variables C DOUBLE PRECISION ZERO, SSBASE, SM, TEMP INTEGER I, J, LTEMP, JM DATA ZERO/0.D0/ C IF (JMAX .EQ. 0) RETURN IF (IVAR .LE. 0) RETURN IF (IVAR .GT. NVMAX) RETURN LTEMP = VORDER(IVAR) JM = JMAX SM = SMAX IF (IVAR .GT. 1) SSBASE= RSS(IVAR-1) IF (IVAR .EQ. 1) SSBASE= RSS(IVAR) + SS(1) DO 10 J = IVAR, LAST WK(J) = SS(J) 10 END DO C DO 30 I = 1, NBEST TEMP = SSBASE - SM IF (TEMP .GE. BOUND(IVAR)) GO TO 40 VORDER(IVAR) = VORDER(JM) IF (JM .EQ. IVAR) VORDER(IVAR) = LTEMP CALL REPORT(IVAR, TEMP, BOUND, NVMAX, RESS, IR, NBEST, LOPT, IL, * VORDER) IF (I .GE. NBEST) GO TO 40 WK(JM) = ZERO SM = ZERO JM = 0 DO 20 J = IVAR, LAST IF (WK(J) .LE. SM) GO TO 20 JM = J SM = WK(J) 20 CONTINUE IF (JM .EQ. 0) GO TO 40 30 CONTINUE C C Restore VORDER(IVAR) C 40 VORDER(IVAR) = LTEMP C RETURN END SUBROUTINE FORWRD(NP, NRBAR, D, RBAR, THETAB, FIRST, LAST, * VORDER, TOL, RSS, BOUND, NVMAX, RESS, IR, NBEST, LOPT, IL, * WK, IWK, IER) C C Forward selection from variables in positions FIRST .. LAST. C If FIRST > 1, variables in positions prior to this are forced in. C If LAST < NP, variables in positions after this are forced out. C On exit, the array VORDER contains the numbers of the variables C in the order in which they were added. C INTEGER NP, NRBAR, FIRST, LAST, VORDER(NP), NVMAX, IR, NBEST, * IL, LOPT(IL, *), IWK, IER DOUBLE PRECISION D(NP), RBAR(NRBAR), THETAB(NP), TOL(NP), RSS(NP), * BOUND(NVMAX), RESS(IR, *), WK(IWK) C C Local variables C INTEGER NEED, POS, J1, J2, JMAX DOUBLE PRECISION SMAX C C Check call arguments C IER = 0 IF (FIRST .GE. NP) IER = 1 IF (LAST .LE. 1) IER = IER + 2 IF (FIRST .LT. 1) IER = IER + 4 IF (LAST .GT. NP) IER = IER + 8 IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 16 IF (IWK .LT. 3*LAST) IER = IER + 32 IF (NBEST .GT. 0) THEN NEED = NVMAX*(NVMAX+1)/2 IF (IR .LT. NVMAX) IER = IER + 64 IF (IL .LT. NEED) IER = IER + 128 END IF IF (IER .NE. 0) RETURN C C For POS = FIRST .. LAST-1, call ADD1 to find best variable to put C into position POS. C J1 = LAST + 1 J2 = LAST + J1 DO 10 POS = FIRST, LAST-1 CALL ADD1(NP, NRBAR, D, RBAR, THETAB, POS, LAST, TOL, WK, * WK(J1), WK(J2), SMAX, JMAX, IER) IF (NBEST .GT. 0) CALL EXADD1(POS, RSS, BOUND, NVMAX, RESS, * IR, NBEST, LOPT, IL, VORDER, SMAX, JMAX, WK, WK(J1), LAST) C C Move the best variable to position POS. C IF (JMAX .GT. POS) CALL VMOVE(NP, NRBAR, VORDER, D, RBAR, * THETAB, RSS, JMAX, POS, TOL, IER) 10 CONTINUE C RETURN END SUBROUTINE INITR(NP, NVMAX, NBEST, BOUND, RESS, IR, LOPT, IL, * VORDER, RSS, IER) C C Initialize the recording of best subsets C INTEGER NP, NVMAX, NBEST, IR, IL, LOPT(IL,NBEST), VORDER(NP), IER DOUBLE PRECISION BOUND(NP), RESS(IR,NBEST), RSS(NP) C C Local variables C INTEGER BEST, POS, NVAR, I DOUBLE PRECISION LARGE DATA LARGE/1.D+35/ C C Check call arguments C IER = 0 IF (NBEST .LE. 0) IER = 1 IF (NVMAX .LE. 0) IER = IER + 2 IF (NVMAX .GT. NP) IER = IER + 4 IF (IR .LT. NVMAX) IER = IER + 8 IF (IL .LT. NVMAX*(NVMAX+1)/2) IER = IER + 16 IF (IER .NE. 0) RETURN C C Initialize arrays BOUND, RESS & LOPT C DO 30 BEST = 1, NBEST POS = 1 DO 20 NVAR = 1, NVMAX IF (BEST .EQ. 1) THEN RESS(NVAR,BEST) = RSS(NVAR) ELSE RESS(NVAR,BEST) = LARGE END IF IF (BEST .EQ. NBEST) BOUND(NVAR) = RESS(NVAR,NBEST) DO 10 I = 1, NVAR IF (BEST .EQ. 1) THEN LOPT(POS,BEST) = VORDER(I) ELSE LOPT(POS,BEST) = 0 END IF POS = POS + 1 10 CONTINUE 20 CONTINUE 30 CONTINUE C RETURN END SUBROUTINE REPORT(POS, SSQ, BOUND, NVMAX, RESS, IR, NBEST, LOPT, * IL, VORDER) C C Update record of the best NBEST subsets of POS variables, if C necessary, using SSQ. C INTEGER POS, NVMAX, IR, IL, NBEST, LOPT(IL,NBEST), VORDER(POS) DOUBLE PRECISION SSQ, BOUND(NVMAX), RESS(IR,NBEST) C C Local variables C INTEGER RANK, L0, JJ, J, LISTJ, L, I, K DOUBLE PRECISION UNDER1, OVER1 DATA UNDER1/0.9999D0/, OVER1/1.0001D0/ C C If residual sum of squares (SSQ) for the new subset > the C appropriate bound, return. C IF (POS .GT. NVMAX) RETURN IF (SSQ .GE. BOUND(POS)) RETURN C C Find rank of the new subset C DO 30 RANK = 1,NBEST IF (SSQ .LE. RESS(POS,RANK)) GO TO 40 30 CONTINUE 40 L0 = (POS*(POS-1))/2 C C Check that the subset is not a duplicate of one which has already C been recorded. C JJ = RANK IF (SSQ .GT. UNDER1*RESS(POS,RANK)) GO TO 50 IF (RANK .EQ. 1) GO TO 90 IF (SSQ .GT. OVER1*RESS(POS,RANK-1)) GO TO 90 JJ = RANK-1 50 DO 70 J = 1, POS LISTJ = VORDER(J) L = L0 DO 60 I = 1, POS L = L + 1 IF (LISTJ .EQ. LOPT(L,JJ)) GO TO 70 60 CONTINUE GO TO 80 70 CONTINUE RETURN 80 JJ = JJ - 1 IF (JJ .GT. 0 .AND. JJ .EQ. RANK-1) GO TO 50 C C Record new subset, and move down the other records. C 90 IF (RANK .EQ. NBEST) GO TO 110 J = NBEST - RANK DO 101 I = 1, J JJ = NBEST - I RESS(POS,JJ+1) = RESS(POS,JJ) L = L0 DO 100 K = 1, POS L = L + 1 LOPT(L,JJ+1) = LOPT(L,JJ) 100 END DO 101 END DO 110 RESS(POS,RANK) = SSQ L = L0 DO 120 K = 1, POS L = L + 1 LOPT(L,RANK) = VORDER(K) 120 CONTINUE BOUND(POS) = RESS(POS,NBEST) END SUBROUTINE SEQREP(NP, NRBAR, D, RBAR, THETAB, FIRST, LAST, * VORDER, TOL, RSS, BOUND, NVMAX, RESS, IR, NBEST, LOPT, IL, * WK, IWK, IER) C C Sequential replacement algorithm applied to the variables in C positions FIRST, ..., LAST. C If FIRST > 1, variables in positions prior to this are forced in. C If LAST < NP, variables in positions after this are forced out. C INTEGER NP, NRBAR, FIRST, LAST, VORDER(NP), NVMAX, IR, NBEST, * IL, LOPT(IL, *), IWK, IER DOUBLE PRECISION D(NP), RBAR(NRBAR), THETAB(NP), TOL(NP), RSS(NP), * BOUND(NVMAX), RESS(IR, *), WK(IWK) C C Local variables C INTEGER NEED, J1, J2, NV, SIZE, START, BEST, FROM, I, JMAX, COUNT DOUBLE PRECISION ZERO, SSRED, SMAX DATA ZERO/0.D0/ C C Check call arguments C IER = 0 IF (FIRST .GE. NP) IER = 1 IF (LAST .LE. 1) IER = IER + 2 IF (FIRST .LT. 1) IER = IER + 4 IF (LAST .GT. NP) IER = IER + 8 IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 16 IF (IWK .LT. 3*LAST) IER = IER + 32 IF (NBEST .GT. 0) THEN NEED = NVMAX*(NVMAX+1)/2 IF (IR .LT. NVMAX) IER = IER + 64 IF (IL .LT. NEED) IER = IER + 128 END IF IF (IER .NE. 0 .OR. NBEST .LE. 0) RETURN C J1 = 1 + LAST J2 = J1 + LAST NV = MIN(NVMAX, LAST-1) C C Outer loop; SIZE = current size of subset being considered. C DO 30 SIZE = FIRST, NV COUNT = 0 START = FIRST 10 SSRED = ZERO BEST = 0 FROM = 0 C C Find the best variable from those in positions SIZE+1, ..., LAST C to replace the one in position SIZE. Then rotate variables in C positions START, ..., SIZE. C DO 20 I = START, SIZE CALL ADD1(NP, NRBAR, D, RBAR, THETAB, SIZE, LAST, TOL, WK, * WK(J1), WK(J2), SMAX, JMAX, IER) IF (JMAX .GT. SIZE) THEN CALL EXADD1(SIZE, RSS, BOUND, NVMAX, RESS, IR, NBEST, * LOPT, IL, VORDER, SMAX, JMAX, WK, WK(J1), LAST) IF (SMAX .GT. SSRED) THEN SSRED = SMAX BEST = JMAX IF (I .LT. SIZE) THEN FROM = SIZE + START - I - 1 ELSE FROM = SIZE END IF END IF END IF IF (I .LT. SIZE) CALL VMOVE(NP, NRBAR, VORDER, D, RBAR, * THETAB, RSS, SIZE, START, TOL, IER) 20 CONTINUE C C If any replacement reduces the RSS, make the best one. C Move variable from position FROM to SIZE. C Move variable from position BEST to FIRST. C IF (BEST .GT. SIZE) THEN IF (FROM .LT. SIZE) CALL VMOVE(NP, NRBAR, VORDER, D, RBAR, * THETAB, RSS, FROM, SIZE, TOL, IER) CALL VMOVE(NP, NRBAR, VORDER, D, RBAR, THETAB, RSS, BEST, * FIRST, TOL, IER) COUNT = 0 START = FIRST + 1 ELSE COUNT = COUNT + 1 END IF C C Repeat until COUNT = SIZE - START + 1 C IF (COUNT .LE. SIZE - START) GO TO 10 30 CONTINUE C RETURN END SUBROUTINE XHAUST(NP, NRBAR, D, RBAR, THETAB, FIRST, LAST, * VORDER, TOL, RSS, BOUND, NVMAX, RESS, IR, NBEST, LOPT, IL, * WK, DIMWK, IWK, DIMIWK, IER) C C Exhaustive search algorithm, using leaps and bounds, applied to C the variables in positions FIRST, ..., LAST. C If FIRST > 1, variables in positions prior to this are forced in. C If LAST < NP, variables in positions after this are forced out. C INTEGER NP, NRBAR, FIRST, LAST, VORDER(NP), NVMAX, IR, NBEST, * IL, LOPT(IL, *), DIMWK, DIMIWK, IWK(DIMIWK), IER DOUBLE PRECISION D(NP), RBAR(NRBAR), THETAB(NP), TOL(NP), RSS(NP), * BOUND(NVMAX), RESS(IR, *), WK(DIMWK) C C Local variables C INTEGER NEED, J1, J2, ROW, I, JMAX, IPT, NEWPOS DOUBLE PRECISION SMAX, TEMP C C Check call arguments C IER = 0 IF (FIRST .GE. NP) IER = 1 IF (LAST .LE. 1) IER = IER + 2 IF (FIRST .LT. 1) IER = IER + 4 IF (LAST .GT. NP) IER = IER + 8 IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 16 IF (DIMWK .LT. 3*LAST .OR. DIMIWK .LT. NVMAX) IER = IER + 32 IF (NBEST .GT. 0) THEN NEED = NVMAX*(NVMAX+1)/2 IF (IR .LT. NVMAX) IER = IER + 64 IF (IL .LT. NEED) IER = IER + 128 END IF IF (IER .NE. 0 .OR. NBEST .LE. 0) RETURN C J1 = 1 + LAST J2 = J1 + LAST C C Record subsets contained in the initial ordering, including check C for variables which are linearly related to earlier variables. C This should be redundant if the user has first called SING and C INITR. C DO 10 ROW = FIRST, NVMAX IF (D(ROW) .LE. TOL(ROW)) THEN IER = -999 RETURN END IF CALL REPORT(ROW, RSS(ROW), BOUND, NVMAX, RESS, IR, NBEST, LOPT, * IL, VORDER) 10 CONTINUE C C IWK(I) contains the upper limit for the I-th simulated DO-loop for C I = FIRST, ..., NVMAX-1. C IPT points to the current DO loop. C DO 20 I = FIRST, NVMAX IWK(I) = LAST 20 END DO C C Innermost loop. C Find best possible variable for position NVMAX from those in C positions NVMAX, .., IWK(NVMAX). C 30 CALL ADD1(NP, NRBAR, D, RBAR, THETAB, NVMAX, IWK(NVMAX), TOL, WK, * WK(J1), WK(J2), SMAX, JMAX, IER) CALL EXADD1(NVMAX, RSS, BOUND, NVMAX, RESS, IR, NBEST, LOPT, IL, * VORDER, SMAX, JMAX, WK, WK(J1), IWK(NVMAX)) C C Move to next lower numbered loop which has not been exhausted. C IPT = NVMAX - 1 40 IF (IPT .GE. IWK(IPT)) THEN IPT = IPT - 1 IF (IPT .GE. FIRST) GO TO 40 RETURN END IF C C Lower variable from position IPT to position IWK(IPT). C Record any good new subsets found by the move. C NEWPOS = IWK(IPT) CALL VMOVE(NP, NRBAR, VORDER, D, RBAR, THETAB, RSS, IPT, NEWPOS, * TOL, IER) DO 50 I = IPT, MIN(NVMAX, NEWPOS-1) CALL REPORT(I, RSS(I), BOUND, NVMAX, RESS, IR, NBEST, LOPT, IL, * VORDER) 50 END DO C C Reset all ends of loops for I >= IPT. C DO 60 I = IPT, NVMAX IWK(I) = NEWPOS - 1 60 END DO C C If residual sum of squares for all variables above position NEWPOS C is greater than BOUND(I), no better subsets of size I can be found C inside the current loop. C TEMP = RSS(NEWPOS-1) DO 70 I = IPT, NVMAX IF (TEMP .GT. BOUND(I)) GO TO 80 70 CONTINUE IF (IWK(NVMAX) .GT. NVMAX) GO TO 30 IPT = NVMAX - 1 GO TO 40 80 IPT = I - 1 IF (IPT .LT. FIRST) RETURN GO TO 40 C END C C___ SUBROUTINE EFROYM(NP, NRBAR, D, RBAR, THETAB, FIRST, LAST, C___ * FIN, FOUT, SIZE, NOBS, VORDER, TOL, RSS, BOUND, NVMAX, RESS, C___ * IR, NBEST, LOPT, IL, WK, IWK, IER) C___C C___C Efroymson's stepwise regression from variables in positions FIRST, C___C ..., LAST. If FIRST > 1, variables in positions prior to this are C___C forced in. If LAST < NP, variables in positions after this are C___C forced out. C___C C___c IMPLICIT NONE C___ INTEGER NP, NRBAR, FIRST, LAST, SIZE, NOBS, VORDER(NP), NVMAX, IR, C___ * NBEST, IL, LOPT(IL, *), IWK, IER C___ DOUBLE PRECISION D(NP), RBAR(NRBAR), THETAB(NP), FIN, FOUT, C___ * TOL(NP), RSS(NP), BOUND(NVMAX), RESS(IR, *), WK(IWK) C___C C___C Local variables C___C C___ INTEGER NEED, J1, J2, JMAX, JMIN, I C___ DOUBLE PRECISION ONE, EPS, ZERO, SMAX, BASE, VAR, F, SMIN C___ DATA ONE/1.D0/, EPS/1.D-16/, ZERO/0.D0/ C___C C___C Check call arguments C___C C___ IER = 0 C___ IF (FIRST .GE. NP) IER = 1 C___ IF (LAST .LE. 1) IER = IER + 2 C___ IF (FIRST .LT. 1) IER = IER + 4 C___ IF (LAST .GT. NP) IER = IER + 8 C___ IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 16 C___ IF (IWK .LT. 3*LAST) IER = IER + 32 C___ IF (NBEST .GT. 0) THEN C___ NEED = NVMAX*(NVMAX+1)/2 C___ IF (IR .LT. NVMAX) IER = IER + 64 C___ IF (IL .LT. NEED) IER = IER + 128 C___ END IF C___ IF (FIN .LT. FOUT .OR. FIN .LE. ZERO) IER = IER + 256 C___ IF (NOBS .LE. NP) IER = IER + 512 C___ IF (IER .NE. 0) RETURN C___C C___C EPS approximates the smallest quantity such that the calculated C___C value of (1 + EPS) is > 1. It is used to test for a perfect fit C___C (RSS = 0). C___C C___ 10 IF (ONE + EPS .LE. ONE) THEN C___ EPS = EPS + EPS C___ GO TO 10 C___ END IF C___C C___C SIZE = number of variables in the current subset C___C C___ SIZE = FIRST - 1 C___ J1 = LAST + 1 C___ J2 = LAST + J1 C___C C___C Find the best variable to add next C___C C___ 20 CALL ADD1(NP, NRBAR, D, RBAR, THETAB, SIZE+1, LAST, TOL, WK, C___ * WK(J1), WK(J2), SMAX, JMAX, IER) C___ IF (NBEST .GT. 0) CALL EXADD1(SIZE+1, RSS, BOUND, NVMAX, RESS, C___ * IR, NBEST, LOPT, IL, VORDER, SMAX, JMAX, WK, WK(J1), LAST) C___ write(*, *) 'Best variable to add: ', VORDER(JMAX) C___C C___C Calculate 'F-to-enter' value C___C C___ IF (SIZE .GT. 0) THEN C___ BASE = RSS(SIZE) C___ ELSE C___ BASE = RSS(1) + WK(1) C___ END IF C___ VAR = (BASE - SMAX) / (NOBS - SIZE - 1) C___ IF (VAR .LT. EPS*BASE) THEN C___ IER = -1 C___ F = ZERO C___ ELSE C___ F = SMAX / VAR C___ END IF C___ write(*, 900) F C___ 900 format(' F-to-enter = ', f10.2) C___C C___C Exit if F < FIN or IER < 0 (perfect fit) C___C C___ IF (F .LT. FIN .OR. IER .LT. 0) RETURN C___C C___C Add the variable to the subset (in position FIRST). C___C C___ SIZE = SIZE + 1 C___ IF (JMAX .GT. FIRST) CALL VMOVE(NP, NRBAR, VORDER, D, RBAR, C___ * THETAB, RSS, JMAX, FIRST, TOL, IER) C___C C___C See whether a variable entered earlier can be deleted now. C___C C___ 30 IF (SIZE .LE. FIRST) GO TO 20 C___ CALL DROP1(NP, NRBAR, D, RBAR, THETAB, FIRST+1, SIZE, TOL, WK, C___ * WK(J1), SMIN, JMIN, IER) C___ VAR = RSS(SIZE) / (NOBS - SIZE) C___ F = SMIN / VAR C___ write(*, 910) VORDER(JMIN), F C___ 910 format(' F-to-drop variable: ', i4, ' = ', f10.2) C___ IF (F .LT. FOUT) THEN C___ CALL VMOVE(NP, NRBAR, VORDER, D, RBAR, THETAB, RSS, JMIN, SIZE, C___ * TOL, IER) C___ IF (NBEST .GT. 0) THEN C___ DO 40 I = JMIN, SIZE-1 C___ 40 CALL REPORT(I, RSS(I), BOUND, NVMAX, RESS, IR, NBEST, LOPT, C___ * IL, VORDER) C___ END IF C___ SIZE = SIZE - 1 C___ GO TO 30 C___ END IF C___C C___ GO TO 20 C___ END SUBROUTINE REGCF(NP, NRBAR, D, RBAR, THETAB, TOL, BETA, + NREQ, IER) C C ALGORITHM AS274 APPL. STATIST. (1992) VOL 41, NO. x C C Modified version of AS75.4 to calculate regression coefficients C for the first NREQ variables, given an orthogonal reduction from C AS75.1. C INTEGER NP, NRBAR, NREQ, IER DOUBLE PRECISION D(NP), RBAR(*), THETAB(NP), TOL(NP), + BETA(NP) C C Local variables C INTEGER I, J, NEXTR DOUBLE PRECISION ZERO C DATA ZERO/0.D0/ C C Some checks. C IER = 0 IF (NP .LT. 1) IER = 1 IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2 IF (NREQ .LT. 1 .OR. NREQ .GT. NP) IER = IER + 4 IF (IER .NE. 0) RETURN C DO 20 I = NREQ, 1, -1 IF (SQRT(D(I)) .LT. TOL(I)) THEN BETA(I) = ZERO D(I) = ZERO GO TO 20 END IF BETA(I) = THETAB(I) NEXTR = (I-1) * (NP+NP-I)/2 + 1 DO 10 J = I+1, NREQ BETA(I) = BETA(I) - RBAR(NEXTR) * BETA(J) NEXTR = NEXTR + 1 10 CONTINUE 20 CONTINUE C RETURN END C SUBROUTINE SING(NP, NRBAR, D, RBAR, THETAB, SSERR, TOL, + LINDEP, WORK, IER) C C ALGORITHM AS274 APPL. STATIST. (1992) VOL.41, NO. 2 C C Checks for singularities, reports, and adjusts orthogonal C reductions produced by AS75.1. C INTEGER NP, NRBAR, IER DOUBLE PRECISION D(NP), RBAR(NRBAR), THETAB(NP), SSERR, + TOL(NP), WORK(NP) C Stephen Milborrow Nov 2019: changed LINDEP to INTEGER (from LOGICAL) to pacify R CRAN check INTEGER LINDEP(NP) C C Local variables C DOUBLE PRECISION ZERO, TEMP INTEGER COL, POS, ROW, NC2, POS2 C DATA ZERO/0.D0/ C C Check input parameters C IER = 0 IF (NP .LT. 1) IER = 1 IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2 IF (IER .NE. 0) RETURN C DO 10 COL = 1, NP WORK(COL) = SQRT(D(COL)) 10 END DO C DO 40 COL = 1, NP C C Set elements within RBAR to zero if they are less than TOL(COL) in C absolute value after being scaled by the square root of their row C multiplier. C TEMP = TOL(COL) POS = COL - 1 DO 30 ROW = 1, COL-1 IF (ABS(RBAR(POS)) * WORK(ROW) .LT. TEMP) RBAR(POS) = ZERO POS = POS + NP - ROW - 1 30 CONTINUE C C If diagonal element is near zero, set it to zero, set appropriate C element of LINDEP, and use INCLUD to augment the projections in C the lower rows of the orthogonalization. C LINDEP(COL) = 0 IF (WORK(COL) .LE. TEMP) THEN LINDEP(COL) = 1 IER = IER - 1 IF (COL .LT. NP) THEN NC2 = NP - COL POS2 = POS + NP - COL + 1 CALL INCLUD(NC2, NC2*(NC2-1)/2, D(COL), RBAR(POS+1), + THETAB(COL), D(COL+1), RBAR(POS2), THETAB(COL+1), + SSERR, IER) ELSE SSERR = SSERR + D(COL) * THETAB(COL)**2 END IF D(COL) = ZERO WORK(COL) = ZERO THETAB(COL) = ZERO END IF 40 CONTINUE RETURN END C SUBROUTINE SSLEAPS(NP, D, THETAB, SSERR, RSS, IER) C C ALGORITHM AS274 APPL. STATIST. (1992) VOL. 41, NO. 2 C C Calculates partial residual sums of squares from an orthogonal C reduction from AS75.1. C INTEGER NP, IER DOUBLE PRECISION D(NP), THETAB(NP), SSERR, RSS(NP) C C Local variables C INTEGER I DOUBLE PRECISION SUM C C Some checks. C IER = 0 IF (NP .LT. 1) IER = 1 IF (IER .NE. 0) RETURN C SUM = SSERR RSS(NP) = SSERR DO 10 I = NP, 2, -1 SUM = SUM + D(I) * THETAB(I)**2 RSS(I-1) = SUM 10 CONTINUE RETURN END C SUBROUTINE TOLSET(NP, NRBAR, D, RBAR, TOL, WORK, IER) C C ALGORITHM AS274 APPL. STATIST. (1992) VOL.41, NO. 2 C C Sets up array TOL for testing for zeros in an orthogonal C reduction formed using AS75.1. C INTEGER NP, NRBAR, IER DOUBLE PRECISION D(NP), RBAR(*), TOL(NP), WORK(NP) C C Local variables. C INTEGER COL, ROW, POS DOUBLE PRECISION EPS, SUM, ZERO C C EPS is a machine-dependent constant. For compilers which use C the IEEE format for floating-point numbers, recommended values C are 1.E-06 for single precision and 1.D-12 for double precision. C c changed EPS from 10^-12 to 5x10^-10 to try to fix a bug DATA EPS/5.D-10/, ZERO/0.D0/ C C Some checks. C IER = 0 IF (NP .LT. 1) IER = 1 IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2 IF (IER .NE. 0) RETURN C C Set TOL(I) = sum of absolute values in column I of RBAR after C scaling each element by the square root of its row multiplier. C DO 10 ROW = 1, NP WORK(ROW) = SQRT(D(ROW)) 10 END DO DO 30 COL = 1, NP POS = COL - 1 IF (COL .LE. NP) THEN SUM = WORK(COL) ELSE SUM = ZERO END IF DO 20 ROW = 1, MIN(COL-1, NP) SUM = SUM + ABS(RBAR(POS)) * WORK(ROW) POS = POS + NP - ROW - 1 20 CONTINUE TOL(COL) = EPS * SUM 30 CONTINUE C RETURN END C SUBROUTINE PCORR(NP, NRBAR, D, RBAR, THETAB, SSERR, IN, + WORK, CORMAT, DIMC, YCORR, IER) C C ALGORITHM AS274 APPL. STATIST. (1992) VOL. 41, NO. 2 C C Calculate partial correlations after the first IN variables C have been forced into the regression. C C Auxiliary routine called: COR C INTEGER NP, NRBAR, IN, DIMC, IER DOUBLE PRECISION D(NP), RBAR(*), THETAB(NP), SSERR, + WORK(NP), CORMAT(*), YCORR(NP) C C Local variables. C INTEGER START, IN1, I DOUBLE PRECISION ZERO C DATA ZERO/0.D0/ C C Some checks. C IER = 0 IF (NP .LT. 1) IER = 1 IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2 IF (IN .LT. 0 .OR. IN .GT. NP-1) IER = IER + 4 IF (DIMC .LT. (NP-IN)*(NP-IN-1)/2) IER = IER + 8 IF (IER .NE. 0) RETURN C START = IN * (NP+NP-IN-1)/2 + 1 IN1 = IN + 1 CALL COR(NP-IN, D(IN1), RBAR(START), THETAB(IN1), + SSERR, WORK, CORMAT, YCORR) C C Check for zeros. C DO 10 I = 1, NP-IN IF (WORK(I) .LE. ZERO) IER = -I 10 CONTINUE C RETURN END C SUBROUTINE COR(NP, D, RBAR, THETAB, SSERR, WORK, CORMAT, + YCORR) C C ALGORITHM AS274 APPL. STATIST. (1992) VOL. 41, NO. 2 C C Calculate correlations from an orthogonal reduction. This C routine will usually be called from PCORR, which will have C removed the appropriate number of rows at the start. C INTEGER NP DOUBLE PRECISION D(NP), RBAR(*), THETAB(NP), SSERR, + WORK(NP), CORMAT(*), YCORR(NP) C C Local variables. C INTEGER ROW, POS, COL1, POS1, COL2, POS2, DIFF DOUBLE PRECISION SUMY, SUM, ZERO C DATA ZERO/0.D0/ C C Process by columns, including the projections of the dependent C variable (THETAB). C SUMY = SSERR DO 10 ROW = 1, NP SUMY = SUMY + D(ROW) * THETAB(ROW)**2 10 END DO SUMY = SQRT(SUMY) POS = NP*(NP-1)/2 DO 70 COL1 = NP, 1, -1 C C Calculate the length of column COL1. C SUM = D(COL1) POS1 = COL1 - 1 DO 20 ROW = 1, MIN(COL1-1, NP) SUM = SUM + D(ROW) * RBAR(POS1)**2 POS1 = POS1 + NP - ROW - 1 20 CONTINUE WORK(COL1) = SQRT(SUM) C C If SUM = 0, set all correlations with this variable to zero. C IF (SUM .EQ. ZERO) THEN YCORR(COL1) = ZERO DO 30 COL2 = NP, COL1+1, -1 CORMAT(POS) = ZERO POS = POS - 1 30 CONTINUE GO TO 70 END IF C C Form cross-products, then divide by product of column lengths. C SUM = D(COL1) * THETAB(COL1) POS1 = COL1 - 1 DO 40 ROW = 1, MIN(COL1-1, NP) SUM = SUM + D(ROW) * RBAR(POS1) * THETAB(ROW) POS1 = POS1 + NP - ROW - 1 40 CONTINUE YCORR(COL1) = SUM / (SUMY * WORK(COL1)) C DO 60 COL2 = NP, COL1+1, -1 IF (WORK(COL2) .GT. ZERO) THEN POS1 = COL1 - 1 POS2 = COL2 - 1 DIFF = COL2 - COL1 SUM = ZERO DO 50 ROW = 1, MIN(COL1-1, NP) SUM = SUM + D(ROW) * RBAR(POS1) * RBAR(POS2) POS1 = POS1 + NP - ROW - 1 POS2 = POS1 + DIFF 50 CONTINUE SUM = SUM + D(COL1) * RBAR(POS2) CORMAT(POS) = SUM / (WORK(COL1) * WORK(COL2)) ELSE CORMAT(POS) = ZERO END IF POS = POS - 1 60 CONTINUE 70 CONTINUE C RETURN END C SUBROUTINE VMOVE(NP, NRBAR, VORDER, D, RBAR, THETAB, + RSS, FROM, TO, TOL, IER) C C ALGORITHM AS274 APPL. STATIST. (1992) VOL.41, NO. 2 C C Move variable from position FROM to position TO in an C orthogonal reduction produced by AS75.1. C INTEGER NP, NRBAR, VORDER(NP), FROM, TO, IER DOUBLE PRECISION D(NP), RBAR(*), THETAB(NP), RSS(NP), + TOL(NP) C C Local variables C DOUBLE PRECISION ZERO, D1, D2, X, ONE, D1NEW, D2NEW, CBAR, SBAR, Y INTEGER M, FIRST, LAST, INC, M1, M2, MP1, COL, POS, ROW C DATA ZERO/0.D0/, ONE/1.D0/ C C Check input parameters C IER = 0 IF (NP .LT. 1) IER = 1 IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2 IF (FROM .LT. 1 .OR. FROM .GT. NP) IER = IER + 4 IF (TO .LT. 1 .OR. TO .GT. NP) IER = IER + 8 IF (IER .NE. 0) RETURN C IF (FROM .EQ. TO) RETURN C IF (FROM .LT. TO) THEN FIRST = FROM LAST = TO - 1 INC = 1 ELSE FIRST = FROM - 1 LAST = TO INC = -1 END IF DO 70 M = FIRST, LAST, INC C C Find addresses of first elements of RBAR in rows M and (M+1). C M1 = (M-1)*(NP+NP-M)/2 + 1 M2 = M1 + NP - M MP1 = M + 1 IF (M .LE. NP) THEN D1 = D(M) IF (MP1 .LE. NP) THEN D2 = D(MP1) ELSE D2 = ZERO END IF ELSE D1 = ZERO D2 = ZERO END IF C C Special cases. C IF (D1 .EQ. ZERO .AND. D2 .EQ. ZERO) GO TO 40 X = RBAR(M1) IF (ABS(X) * SQRT(D1) .LT. TOL(MP1)) THEN X = ZERO END IF IF (D1 .EQ. ZERO .OR. X .EQ. ZERO) THEN D(M) = D2 D(MP1) = D1 RBAR(M1) = ZERO DO 10 COL = M+2, NP M1 = M1 + 1 X = RBAR(M1) RBAR(M1) = RBAR(M2) RBAR(M2) = X M2 = M2 + 1 10 CONTINUE X = THETAB(M) THETAB(M) = THETAB(MP1) THETAB(MP1) = X GO TO 40 ELSE IF (D2 .EQ. ZERO) THEN D(M) = D1 * X**2 RBAR(M1) = ONE / X DO 20 COL = M+2, NP M1 = M1 + 1 RBAR(M1) = RBAR(M1) / X 20 CONTINUE THETAB(M) = THETAB(M) / X GO TO 40 END IF C C Planar rotation in regular case. C D1NEW = D2 + D1*X**2 CBAR = D2 / D1NEW SBAR = X * D1 / D1NEW D2NEW = D1 * CBAR D(M) = D1NEW D(MP1) = D2NEW RBAR(M1) = SBAR DO 30 COL = M+2, NP M1 = M1 + 1 Y = RBAR(M1) RBAR(M1) = CBAR*RBAR(M2) + SBAR*Y RBAR(M2) = Y - X*RBAR(M2) M2 = M2 + 1 30 CONTINUE Y = THETAB(M) THETAB(M) = CBAR*THETAB(MP1) + SBAR*Y THETAB(MP1) = Y - X*THETAB(MP1) C C Swap columns M and (M+1) down to row (M-1). C 40 IF (M .EQ. 1) GO TO 60 POS = M DO 50 ROW = 1, M-1 X = RBAR(POS) RBAR(POS) = RBAR(POS-1) RBAR(POS-1) = X POS = POS + NP - ROW - 1 50 CONTINUE C C Adjust variable order (VORDER), the tolerances (TOL) and C the vector of residual sums of squares (RSS). C 60 M1 = VORDER(M) VORDER(M) = VORDER(MP1) VORDER(MP1) = M1 X = TOL(M) TOL(M) = TOL(MP1) TOL(MP1) = X RSS(M) = RSS(MP1) + D(MP1) * THETAB(MP1)**2 70 CONTINUE C RETURN END C SUBROUTINE REORDR(NP, NRBAR, VORDER, D, RBAR, THETAB, + RSS, TOL, LIST, N, POS1, IER) C C ALGORITHM AS274 APPL. STATIST. (1992) VOL.41, NO. 2 C C Re-order the variables in an orthogonal reduction produced by C AS75.1 so that the N variables in LIST start at position POS1, C though will not necessarily be in the same order as in LIST. C Any variables in VORDER before position POS1 are not moved. C C Auxiliary routine called: VMOVE C INTEGER NP, NRBAR, VORDER(NP), N, LIST(N), POS1, IER DOUBLE PRECISION D(NP), RBAR(NRBAR), THETAB(NP), RSS(NP), + TOL(NP) C C Local variables. C INTEGER NEXT, I, L, J C C Check N. C IER = 0 IF (NP .LT. 1) IER = 1 IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2 IF (N .LT. 1 .OR. N .GT. NP+1-POS1) IER = IER + 4 IF (IER .NE. 0) RETURN C C Work through VORDER finding variables which are in LIST. C NEXT = POS1 I = POS1 10 L = VORDER(I) DO 20 J = 1, N IF (L .EQ. LIST(J)) GO TO 40 20 CONTINUE 30 I = I + 1 IF (I .LE. NP) GO TO 10 C C If this point is reached, one or more variables in LIST has not C been found. C IER = NEXT - N - 1 RETURN C C Variable L is in LIST; move it up to position NEXT if it is not C already there. C 40 IF (I .GT. NEXT) CALL VMOVE(NP, NRBAR, VORDER, D, RBAR, + THETAB, RSS, I, NEXT, TOL, IER) NEXT = NEXT + 1 IF (NEXT .LT. N+POS1) GO TO 30 C RETURN END SUBROUTINE INCLUD(NP, NRBAR, WEIGHT, XROW, YELEM, D, + RBAR, THETAB, SSERR, IER) C C ALGORITHM AS274 APPL. STATIST. (1992) VOL.41, NO. 2 C Modified from algorithm AS 75.1 C C Calling this routine updates d, rbar, thetab and sserr by the C inclusion of xrow, yelem with the specified weight. The number C of columns (variables) may exceed the number of rows (cases). C C**** WARNING: The elements of XROW are overwritten **** C INTEGER NP, NRBAR, IER DOUBLE PRECISION WEIGHT, XROW(NP), YELEM, D(NP), RBAR(*), + THETAB(NP), SSERR C C Local variables C INTEGER I, K, NEXTR DOUBLE PRECISION ZERO, W, Y, XI, DI, WXI, DPI, CBAR, SBAR, XK C DATA ZERO/0.D0/ C C Some checks. C IER = 0 IF (NP .LT. 1) IER = 1 IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2 IF (IER .NE. 0) RETURN C W = WEIGHT Y = YELEM NEXTR = 1 DO 30 I = 1, NP C C Skip unnecessary transformations. Test on exact zeros must be C used or stability can be destroyed. C IF (W .EQ. ZERO) RETURN XI = XROW(I) IF (XI .EQ. ZERO) THEN NEXTR = NEXTR + NP - I GO TO 30 END IF DI = D(I) WXI = W * XI DPI = DI + WXI*XI CBAR = DI / DPI SBAR = WXI / DPI W = CBAR * W D(I) = DPI IF (I .EQ. NP) GO TO 20 DO 10 K = I+1, NP XK = XROW(K) XROW(K) = XK - XI * RBAR(NEXTR) RBAR(NEXTR) = CBAR * RBAR(NEXTR) + SBAR * XK NEXTR = NEXTR + 1 10 CONTINUE 20 XK = Y Y = XK - XI * THETAB(I) THETAB(I) = CBAR * THETAB(I) + SBAR * XK 30 CONTINUE C C Y * SQRT(W) is now equal to Brown & Durbin's recursive residual. C SSERR = SSERR + W * Y * Y C RETURN END c___C PROGRAM SUBSET c___C c___C Interactive program to perform regressions on subsets of c___C variables. Max. no. of variables, excl. constant = 50. c___C c___C Subroutines called:- c___C ADD1, BAKWRD, EFROYM, XHAUST, FORWRD, EXADD1, INITR, REGCF, c___C REORDR, LSORT, PCORR, REPORT, SEQREP, SHELL, SS, TOLSET. c___C c___C Latest revision - 10 November 1993 c___C c___C IMPLICIT NONE c___ INTEGER MAXCOL, MAXSUB, MAXBST, MAXL, MAXR c___ PARAMETER (MAXCOL=50, MAXSUB=25, MAXBST=20, MAXL=1000, c___ + MAXR=MAXSUB*MAXBST) c___ INTEGER UDIM, IIW, IW c___ PARAMETER (UDIM=MAXCOL*(MAXCOL+1)/2, IIW=3*MAXCOL, IW=UDIM+IIW) c___ CHARACTER FNAME*30, ANS, OPTION(22), VNAME(0:MAXCOL)*8, YNAME*8 c___ LOGICAL LSEL, OK c___ INTEGER LIN, LOUT, LPR, LOPT(MAXL), IWK(IIW), K, IRTN, LINE, c___ + ICONST, NCOLS, I1, IPOS, I, NOBS, VORDER(0:MAXCOL), IL, c___ + NRBAR, NVMAX, NVMX, NBEST, IOPT, IER, NDF, J, NV, NB, c___ + IPRINT, IR, L, IPROC, FIRST, LAST, SIZE, M, ILNB c___ DOUBLE PRECISION U(UDIM), EL(0:MAXCOL), RHS(0:MAXCOL), RESSQ, c___ + SSQ(0:MAXCOL), TOL(0:MAXCOL), BOUND(MAXSUB), RESS(MAXR), c___ + WK(IW), TEMP, FIN, FOUT c___ REAL VAR c___ DATA OPTION/'C', 'c', 'F', 'f', 'B', 'b', 'R', 'r', 'E', 'e', c___ + 'P', 'p', 'I', 'i', 'O', 'o', 'L', 'l', 'X', 'x', 'Q', 'q'/ c___C c___C Set unit numbers for I/O in LIN & LOUT below. c___C c___ DATA LIN/5/, LOUT/6/ c___C c___C Ask for name of the data set. c___C c___ 10 WRITE(LOUT,9000) c___ 9000 FORMAT(' Enter name of .RED file for data (e.g. B:myfile): ') c___ READ(LIN,8000) FNAME c___ 8000 FORMAT(A) c___C c___C Add the .RED extension if necessary. c___C c___ IF (INDEX(FNAME, '.RED') .EQ. 0) THEN c___ IPOS = INDEX(FNAME, ' ') c___ IF (IPOS .EQ. 0 .OR. IPOS .GT. 11) THEN c___ WRITE(LOUT, 9010) FNAME c___ 9010 FORMAT(' ** Illegal filename entered - ', A, ' **') c___ GO TO 10 c___ END IF c___ FNAME(IPOS: IPOS+3) = '.RED' c___ END IF c___C c___C Check that file exists. c___C c___ INQUIRE(FILE=FNAME, EXIST=OK) c___ IF (.NOT. OK) THEN c___ WRITE(LOUT, 9020) FNAME c___ 9020 FORMAT(' ** File not found - ', A, ' **') c___ GO TO 10 c___ END IF c___ OPEN(9, FILE=FNAME, STATUS='OLD', ACCESS='SEQUENTIAL', c___ + FORM='UNFORMATTED') c___C c___C Read contents of file. c___C c___ READ(9) K, ICONST, NCOLS, NOBS, NRBAR, LSEL c___ IF (ICONST .EQ. 0) THEN c___ READ(9) YNAME, (VNAME(I),I=1,K) c___ READ(9) (U(I),I=1,NRBAR), (EL(I),I=1,K), (RHS(I),I=1,K), RESSQ c___ ELSE c___ READ(9) YNAME, (VNAME(I),I=0,K) c___ READ(9) (U(I),I=1,NRBAR), (EL(I),I=0,K), (RHS(I),I=0,K), RESSQ c___ END IF c___ I1 = 1 + ICONST c___ WRITE(LOUT, 9030) K, NOBS, YNAME c___ 9030 FORMAT(' No. of predictors = ', I3, 5X, 'No. of cases = ', I5/ c___ + ' Dependant variable is ', A) c___ WRITE(LOUT, 9930) (I, VNAME(I),I=1,K) c___C c___C Initially, all variables except the constant (if there is one) c___C are considered candidates for either inclusion or exclusion c___C c___ FIRST = I1 c___ LAST = NCOLS c___C c___C Set up array VORDER. c___C c___ DO 30 I = 0, K c___ VORDER(I) = I c___ 30 CONTINUE c___C c___C Ask for values of NVMAX & NBEST. c___C c___ 50 WRITE(LOUT, 9040) c___ 9040 FORMAT(' Enter max. size of subsets (excl. constant): ') c___ READ(LIN, 8010) NVMAX c___ 8010 FORMAT(I3) c___ NVMX = NVMAX + ICONST c___ IF(NVMX .LE. MAXBST) GO TO 70 c___ 60 WRITE(LOUT, 9050) c___ 9050 FORMAT(' *** Too many, sorry, try again') c___ GO TO 50 c___ 70 IL = NVMX*(NVMX + 1)/2 c___ L = MIN(MAXL/IL, MAXR/NVMX, MAXBST) c___ WRITE(LOUT, 9060) L, NVMAX c___ 9060 FORMAT('+How many subsets of each size to be recorded ?'/ c___ + ' Max. = ', I4, ' with NVMAX =', I3, ' : ') c___ READ(LIN, 8010) NBEST c___ IF(NBEST .GT. L) GO TO 60 c___C c___C Call TOLSET, SS & INITR to initialize arrays. c___C c___ IF (ICONST .EQ. 1) THEN c___ CALL TOLSET(NCOLS, NRBAR, EL, U, TOL, WK, IER) c___ CALL SS(NCOLS, EL, RHS, RESSQ, SSQ, IER) c___ CALL INITR(NCOLS, NVMX, NBEST, BOUND, RESS, NVMX, LOPT, IL, c___ + VORDER, SSQ, IER) c___ ELSE c___ CALL TOLSET(NCOLS, NRBAR, EL(1), U, TOL(1), WK, IER) c___ CALL SS(NCOLS, EL(1), RHS(1), RESSQ, SSQ(1), IER) c___ CALL INITR(NCOLS, NVMX, NBEST, BOUND, RESS, NVMX, LOPT, IL, c___ + VORDER(1), SSQ(1), IER) c___ END IF c___ WRITE(LOUT, 9065) NCOLS, RESSQ c___ 9065 FORMAT(' Initially NCOLS = ', I4,' RESSQ = ', G13.5) c___ IF (NOBS .GT. NCOLS) THEN c___ NDF = NOBS - NCOLS c___ VAR = RESSQ / NDF c___ WRITE(*, 9068) VAR, NDF c___ 9068 FORMAT(' Resid. variance estimate = ', g11.4, ' with ', i4, c___ + ' deg. of freedom'/) c___ END IF c___ IPROC = 0 c___C c___C Display menu & ask for choice. c___C c___ 100 WRITE(LOUT, 9070) c___ 9070 FORMAT(' Options:-'/ c___ 1 ' C Corrlns. & partial corrlns. F Forward selection'/ c___ 2 ' B Backward elimination R Sequential replacement'/ c___ 3 ' E Efroymson stepwise P Print summary of subsets'/ c___ 4 ' I Specify IN variables O Specify OUT variables'/ c___ 5 ' L Least-squares regn.coeffs. X Exhaustive search'/ c___ 6 ' Q Quit ENTER YOUR OPTION : ') c___ READ(LIN, *) ANS c___C c___C Compare ANS with currently available options. c___C c___ DO 110 IOPT = 1,22 c___ IF(ANS .EQ. OPTION(IOPT)) GO TO 120 c___ 110 CONTINUE c___ WRITE(LOUT, 9080) ANS c___ 9080 FORMAT(' Option ', A, ' not available') c___ GO TO 100 c___ 120 L = (IOPT + 1)/2 c___C c___C C F B R E P I O L X Q c___ GO TO (200, 300, 400, 500, 550, 700, 800, 900, 250, 600, 850), L c___C c___C----------------------------------------------------------------------- c___C c___C Option 1. Correlations. c___C c___ 200 WRITE(LOUT, 9200) c___ 9200 FORMAT('+Do you want partial correlations ? (Y or N) ') c___ NV = 0 c___ READ(LIN, *) ANS c___ IF(ANS .EQ. 'N' .OR. ANS .EQ. 'n') GO TO 210 c___ IF(ANS .NE. 'Y' .AND. ANS .NE. 'y') GO TO 200 c___ ASSIGN 210 TO IRTN c___ WRITE(LOUT, 9210) c___ 9210 FORMAT(' Partial corrlns. on how many variables (excl.const.) ? ') c___ READ(LIN, 8010) NV c___ IF(NV .GT. 0) GO TO 1000 c___ 210 WRITE(LOUT, 9220) c___ 9220 FORMAT('+Correlations amongst all variables (A) or with Y only', c___ + 1X,'(Y) ? ') c___ IOPT = 0 c___ READ(LIN, *) ANS c___ IF(ANS .EQ. 'A' .OR. ANS .EQ. 'a') IOPT = 1 c___ NB = NV + ICONST c___ CALL PCORR(NCOLS, NRBAR, EL, U, RHS, RESSQ, NB, WK(UDIM+NCOLS+1), c___ + WK, IW, WK(UDIM+1), IER) c___C c___C Display the (partial) correlations. c___C Correlations amongst the X-variables start at WK(1); correlations c___C with Y start at WK(UDIM+1). c___C c___ CALL PRINTC(NCOLS, NB, WK, UDIM, WK(UDIM+1), VORDER, VNAME(1), c___ + YNAME, IOPT, LOUT, IER) c___ GO TO 100 c___C c___C----------------------------------------------------------------------- c___C c___C Option 9. Least - squares regression coefficients. c___C c___ 250 WRITE(LOUT, 9850) c___ READ(LIN, 8010) NV c___ ASSIGN 260 TO IRTN c___ GO TO 1000 c___ 260 IF (ICONST .EQ. 1) THEN c___ CALL REGCF(NCOLS, NRBAR, EL, U, RHS, TOL, WK, NV, IER) c___ ELSE c___ CALL REGCF(NCOLS, NRBAR, EL(1), U, RHS(1), TOL(1), WK, NV, IER) c___ END IF c___ IER = -IER c___ IF(IER .NE. 0) WRITE(LOUT, 9250) IER c___ 9250 FORMAT(' Variables linearly dependant, rank deficiency =',I4) c___ WRITE(LOUT, 9260)(VORDER(I-ICONST),WK(I),I=1,NV) c___ 9260 FORMAT(' Least-squares regn.coeffs.', c___ + 7(/1X, I5, G13.5, 2X, I5, G13.5, 2X, I5, G13.5, 2X, I5, G13.5)) c___ WRITE(LOUT, 9270) SSQ(NV-ICONST) c___ 9270 FORMAT(' Resid. sum of sq. =',G13.5/) c___ GO TO 100 c___C c___C----------------------------------------------------------------------- c___C c___C Option 2. Forward selection. c___C c___ 300 IF (ICONST .EQ. 1) THEN c___ CALL FORWRD(NCOLS, NRBAR, EL, U, RHS, FIRST, LAST, VORDER, TOL, c___ + SSQ, BOUND, NVMX, RESS, NVMX, NBEST, LOPT, IL, WK, IW, IER) c___ ELSE c___ CALL FORWRD(NCOLS, NRBAR, EL(1), U, RHS(1), FIRST, LAST, c___ + VORDER(1), TOL(1), SSQ(1), BOUND, NVMX, RESS, NVMX, NBEST, c___ + LOPT, IL, WK, IW, IER) c___ END IF c___ NV = NVMX c___ IF (IPROC .EQ. 2*(IPROC/2)) IPROC = IPROC + 1 c___ GO TO 1100 c___C c___C----------------------------------------------------------------------- c___C c___C Option 3. Backward elimination. c___C c___ 400 IF (ICONST .EQ. 1) THEN c___ CALL BAKWRD(NCOLS, NRBAR, EL, U, RHS, FIRST, LAST, VORDER, TOL, c___ + SSQ, BOUND, NVMX, RESS, NVMX, NBEST, LOPT, IL, WK, IW, IER) c___ ELSE c___ CALL BAKWRD(NCOLS, NRBAR, EL(1), U, RHS(1), FIRST, LAST, c___ + VORDER(1), TOL(1), SSQ(1), BOUND, NVMX, RESS, NVMX, NBEST, c___ + LOPT, IL, WK, IW, IER) c___ END IF c___ NV = LAST c___ I = IPROC/2 c___ IF (I .EQ. 2*(I/2)) IPROC = IPROC + 2 c___ GO TO 1100 c___C c___C----------------------------------------------------------------------- c___C c___C Option 4. Sequential replacement. c___C c___ 500 IF (ICONST .EQ. 1) THEN c___ CALL SEQREP(NCOLS, NRBAR, EL, U, RHS, FIRST, LAST, VORDER, TOL, c___ + SSQ, BOUND, NVMX, RESS, NVMX, NBEST, LOPT, IL, WK, IW, IER) c___ ELSE c___ CALL SEQREP(NCOLS, NRBAR, EL(1), U, RHS(1), FIRST, LAST, c___ + VORDER(1), TOL(1), SSQ(1), BOUND, NVMX, RESS, NVMX, NBEST, c___ + LOPT, IL, WK, IW, IER) c___ END IF c___ I = IPROC/8 c___ IF (I .EQ. 2*(I/2)) IPROC = IPROC + 8 c___ NV = NVMX c___ GO TO 1100 c___C c___C----------------------------------------------------------------------- c___C c___C Option 5. Efroymson (stepwise) c___C c___ 550 WRITE(LOUT, 9550) c___ 9550 FORMAT(' Enter F-to-enter value : ') c___ READ(LIN, 8550) FIN c___ 8550 FORMAT(F10.0) c___ WRITE(LOUT, 9560) c___ 9560 FORMAT(' Enter F-to-remove value : ') c___ READ(LIN, 8550) FOUT c___ IF (ICONST .EQ. 1) THEN c___ CALL EFROYM(NCOLS, NRBAR, EL, U, RHS, FIRST, LAST, FIN, FOUT, c___ + SIZE, NOBS, VORDER, TOL, SSQ, BOUND, NVMX, RESS, NVMX, NBEST, c___ + LOPT, IL, WK, IW, IER) c___ ELSE c___ CALL EFROYM(NCOLS, NRBAR, EL(1), U, RHS(1), FIRST, LAST, FIN, c___ + FOUT, SIZE, NOBS, VORDER(1), TOL(1), SSQ(1), BOUND, NVMX, RESS, c___ + NVMX, NBEST, LOPT, IL, WK, IW, IER) c___ END IF c___ IF (IER .NE. 0) THEN c___ WRITE(LOUT, 9570) IER c___ 9570 FORMAT(' Error code',I4,' returned by EFROYM') c___ GO TO 100 c___ ELSE c___ NV = SIZE c___ I = IPROC/4 c___ IPROC = IPROC + 4 c___ GO TO 1100 c___ END IF c___C c___C----------------------------------------------------------------------- c___C c___C Option 10. Exhaustive search. c___C c___ 600 IF (ICONST .EQ. 1) THEN c___ CALL XHAUST(NCOLS, NRBAR, EL, U, RHS, FIRST, LAST, VORDER, TOL, c___ + SSQ, BOUND, NVMX, RESS, NVMX, NBEST, LOPT, IL, WK, IW, IWK, c___ + IIW, IER) c___ ELSE c___ CALL XHAUST(NCOLS, NRBAR, EL(1), U, RHS(1), FIRST, LAST, c___ + VORDER(1), TOL(1), + SSQ(1), BOUND, NVMX, RESS, NVMX, c___ + NBEST, LOPT, IL, WK, IW, IWK, IIW, IER) c___ END IF c___ IF (IPROC .LT. 16) IPROC = IPROC + 16 c___ GO TO 100 c___C c___C----------------------------------------------------------------------- c___C c___C Option 6. Print summary of best subsets found so far. c___C c___ 700 CALL LSORT(LOPT, IL, NBEST, NVMX) c___ L = FIRST*(FIRST-1)/2 + 1 c___ LINE = 1 c___ M = FIRST - ICONST c___ DO 730 NV = FIRST, NVMX c___ WRITE(LOUT,9700) M c___ 9700 FORMAT(20X,'Best subsets found of',I3,' variables') c___ LINE = LINE + 1 c___ DO 720 NB = 1,NBEST c___ J = (NB-1)*NVMX + NV c___ TEMP = RESS(J) c___ IF(TEMP .GT. 1.E+35) GO TO 720 c___ IPOS = L c___ DO 710 I = 1,NV c___ J = (NB-1)*IL + IPOS c___ IWK(I) = LOPT(J) c___ IPOS = IPOS + 1 c___ 710 CONTINUE c___ WRITE(LOUT,9710) TEMP,(IWK(I),I=FIRST,NV) c___ LINE = LINE + 1 + (NV-1)/10 c___ 9710 FORMAT(' RSS =',G14.6,3X,'Variables:',10I4,4(/10X,10I4)) c___ 720 CONTINUE c___ IF (LINE .GE. 25 - NB) THEN c___ PAUSE c___ LINE = 1 c___ END IF c___ L = L + NV c___ M = M + 1 c___ 730 CONTINUE c___ GO TO 100 c___C c___C---------------------------------------------------------------------- c___C c___C Option 7. Force variables into models. c___C c___ 800 WRITE(LOUT, 9800) c___ 9800 FORMAT('+How many variables, excl. constant ? ') c___ READ(LIN, 8010) NV c___ ASSIGN 810 TO IRTN c___ GO TO 1000 c___ 810 GO TO 1100 c___C c___C---------------------------------------------------------------------- c___C c___C Option 11. Exit. c___C c___ 850 IF (IPROC .EQ. 0) STOP c___ WRITE(LOUT, 9860) c___ 9860 FORMAT(' Do you want to save the best subsets found ? (Y/N) ') c___ READ(LIN, *) ANS c___ IF (ANS .EQ. 'Y' .OR. ANS .EQ. 'y') THEN c___ REWIND(9) c___ CALL LSORT(LOPT, IL, NBEST, NVMX) c___ READ(9) K, ICONST, NCOLS, NOBS, NRBAR, LSEL c___ IF (ICONST .EQ. 0) THEN c___ READ(9) YNAME, (VNAME(I),I=1,K) c___ READ(9) (U(I),I=1,NRBAR), (EL(I),I=1,K), (RHS(I),I=1,K), RESSQ c___ ELSE c___ READ(9) YNAME, (VNAME(I),I=0,K) c___ READ(9) (U(I),I=1,NRBAR), (EL(I),I=0,K), (RHS(I),I=0,K), RESSQ c___ END IF c___ LSEL = .TRUE. c___ REWIND(9) c___ ILNB = IL*NBEST c___ IR = NVMX*NBEST c___ WRITE(9) K, ICONST, NCOLS, NOBS, NRBAR, LSEL c___ IF (ICONST .EQ. 0) THEN c___ WRITE(9) YNAME, (VNAME(I),I=1,K) c___ WRITE(9) (U(I),I=1,NRBAR), (EL(I),I=1,K), (RHS(I),I=1,K), c___ + RESSQ c___ ELSE c___ WRITE(9) YNAME, (VNAME(I),I=0,K) c___ WRITE(9) (U(I),I=1,NRBAR), (EL(I),I=0,K), (RHS(I),I=0,K), c___ + RESSQ c___ END IF c___ WRITE(9) NVMAX, NBEST, IL, ILNB, IR, IPROC c___ WRITE(9) (LOPT(L),L=1,ILNB) c___ WRITE(9) (RESS(I),I=1,IR) c___ END IF c___ STOP c___C c___C---------------------------------------------------------------------- c___C c___C Simulated subroutine to force variables into starting positions. c___C NV = no. of variables to be forced in. c___C c___ 1000 WRITE(LOUT, 9930) (I, VNAME(I),I = 1,K) c___ 9930 FORMAT('+Variables & their numbers:', 10(/1X, 5(I3, 1X, A8, 3X))) c___ IF(NV .LE. 0) GO TO 100 c___ WRITE(LOUT, 9920) c___ 9920 FORMAT(' List variable nos. : ') c___ READ(LIN, *) (IWK(I),I = 1,NV) c___C c___C Find variables in VORDER which are in the input list and move up c___C to the next available position. c___C c___ IF (ICONST .EQ. 1) THEN c___ CALL REORDR(NCOLS, NRBAR, VORDER, EL, U, RHS, SSQ, TOL, IWK, NV, c___ + 2, IER) c___ ELSE c___ CALL REORDR(NCOLS, NRBAR, VORDER(1), EL(1), U, RHS(1), SSQ(1), c___ + TOL(1), IWK, NV, 1, IER) c___ END IF c___ NV = NV + ICONST c___ FIRST = NV + 1 c___ GO TO IRTN,(210, 260, 810) c___C c___C---------------------------------------------------------------------- c___C c___C Option 8. Force variables out of models. c___C c___ 900 WRITE(LOUT, 9850) c___ 9850 FORMAT('+How many variables ? ') c___ READ(LIN, 8010) NV c___ WRITE(LOUT, 9920) c___ DO 910 I = 1, NV c___ 910 READ(LIN, *) IWK(I) c___ LAST = NCOLS c___ J = LAST c___ 920 L = VORDER(J) c___ DO 930 M = 1, NV c___ IF(L .EQ. IWK(M)) GO TO 940 c___ 930 CONTINUE c___ GO TO 960 c___ 940 IF(J .EQ. LAST) GO TO 950 c___ CALL VMOVE(NCOLS, NRBAR, VORDER, EL, U, RHS, SSQ, J, LAST, TOL, c___ + IER) c___ 950 LAST = LAST - 1 c___ IF(J .LT. FIRST) FIRST = FIRST - 1 c___ 960 J = J - 1 c___ IF(J .GT. 0) GO TO 920 c___ GO TO 100 c___C c___C---------------------------------------------------------------------- c___C c___C Print current order of the first NV variables and their RSS's. c___C c___ 1100 WRITE(LOUT, 9900) c___ 9900 FORMAT(' Order Variable Resid.sumsq.') c___ DO 1110 I = 1-ICONST, NV-ICONST c___ J = VORDER(I) c___ WRITE(LOUT, 9910) I, VNAME(J), SSQ(I) c___ 9910 FORMAT(I5, 3X, A8, 1X, G14.6) c___ 1110 CONTINUE c___ GO TO 100 c___ END c___C c___C c___C c___C SUBROUTINE LSORT(LOPT, IL, NBEST, NVMX) C C Sort the variable numbers in LOPT into increasing order. C C Latest revision - 12 February 1986 C DIMENSION LOPT(IL, NBEST) INTEGER COL, SIZE, TEMP, START C IF (NVMX .LT. 2) RETURN DO 20 COL = 1, NBEST TEMP = LOPT(2, COL) IF (TEMP .GT. LOPT(3,COL)) THEN LOPT(2,COL) = LOPT(3,COL) LOPT(3,COL) = TEMP END IF IF (IL .LE. 3) GO TO 20 START = 4 DO 10 SIZE = 3, NVMX CALL SHELL(LOPT(START,COL), SIZE) START = START + SIZE 10 CONTINUE 20 CONTINUE RETURN END C C C C SUBROUTINE SHELL(L, N) C C Perform a SHELL-sort on integer array L, sorting into C increasing order. C C Latest revision - 12 February 1986 C DIMENSION L(N) INTEGER START, END, TEMP C INCR = N 10 INCR = INCR/3 IF (INCR .EQ. 2*(INCR/2)) INCR = INCR + 1 DO 50 START = 1, INCR END = N C C TEMP contains the element being compared; IT holds its current C location. It is compared with the elements in locations C IT+INCR, IT+2.INCR, ... until a larger element is found. All C smaller elements move INCR locations towards the start. After C each time through the sequence, the END is decreased by INCR C until END <= INCR. C 20 I1 = START TEMP = L(I1) IT = I1 C C I2 = location of element NEW to be compared with TEMP. C Test I2 <= END. C 30 I2 = I1 + INCR IF (I2 .GT. END) THEN IF (I1 .GT. IT) L(I1) = TEMP END = END - INCR GO TO 40 END IF NEW = L(I2) C C If TEMP > NEW, move NEW to lower-numbered position. C IF (TEMP .GT. NEW) THEN L(I1) = NEW I1 = I2 GO TO 30 END IF C C TEMP <= NEW so do not swap. C Use NEW as the next TEMP. C IF (I1 .GT. IT) L(I1) = TEMP I1 = I2 TEMP = NEW IT = I1 GO TO 30 C C Repeat until END <= INCR. C 40 IF (END .GT. INCR) GO TO 20 50 CONTINUE C C Repeat until INCR = 1. C IF (INCR .GT. 1) GO TO 10 RETURN END C C C c___ SUBROUTINE PRINTC(NP, IN, CORMAT, DIMC, YCORR, VORDER, VNAME, c___ + YNAME, IOPT, LOUT, IER) c___C c___C Print (partial) correlations calculated using PCORR. c___C If IOPT = 0, print correlations with the Y-variable only. c___C c___C IMPLICIT NONE c___ INTEGER NP, IN, DIMC, VORDER(NP), IOPT, LOUT, IER c___ DOUBLE PRECISION CORMAT(DIMC), YCORR(NP) c___ CHARACTER VNAME(NP)*8, YNAME*8 c___C c___C Local variables. c___C c___ INTEGER NROWS, J1, J2, J, I1, I2, I, ROW, UPOS, TPOS, LAST c___ CHARACTER TEXT*74, EMPTY*65, CHAR1*9 c___ c___ DATA EMPTY/' '/, CHAR1/' 1.0'/ c___C c___C Check validity of arguments c___C c___ IER = 0 c___ IF (IN .GE. NP) IER = 1 c___ IF (NP .LE. 1) IER = IER + 2 c___ NROWS = NP - IN c___ IF (DIMC .LE. NROWS*(NROWS-1)/2) IER = IER + 4 c___ IF (IER .NE. 0) RETURN c___C c___C If IOPT.NE.0 output heading c___C c___ IF(IOPT .EQ. 0) GO TO 30 c___ WRITE(LOUT, 900) c___ 900 FORMAT(/5X, 'Correlation matrix') c___ J1 = IN + 1 c___ 10 J2 = MIN(J1+6, NP) c___ I1 = J1 - IN c___ I2 = J2 - IN c___ WRITE(LOUT, 910)(VNAME(VORDER(J)), J=J1,J2) c___ 910 FORMAT(11X, 7(A8, 1X)) c___C c___C Print correlations for rows 1 to I2, columns I1 to I2. c___C c___ DO 20 ROW = 1, I2 c___ TEXT = ' ' // VNAME(VORDER(ROW+IN)) // EMPTY c___ IF (I1 .GT. ROW) THEN c___ UPOS = (ROW-1) * (NROWS+NROWS-ROW) /2 + (I1-ROW) c___ LAST = UPOS + I2 - I1 c___ WRITE(TEXT(12:74), '(7(F8.5,1X))')(CORMAT(I),I=UPOS,LAST) c___ ELSE c___ UPOS = (ROW-1) * (NROWS+NROWS-ROW) /2 + 1 c___ TPOS = 12 + 9*(ROW-I1) c___ TEXT(TPOS:TPOS+8) = CHAR1 c___ LAST = UPOS + I2 - ROW - 1 c___ IF (ROW .LT. I2) WRITE(TEXT(TPOS+9:74), '(6(F8.5, 1X))') c___ + (CORMAT(I),I=UPOS, LAST) c___ END IF c___ WRITE(LOUT, '(A)') TEXT c___ 20 CONTINUE c___C c___C Move onto the next block of columns. c___C c___ J1 = J2 + 1 c___ IF (J1 .LE. NP) GO TO 10 c___C c___C Correlations with the Y-variable. c___C c___ 30 WRITE(LOUT, 920) YNAME c___ 920 FORMAT(/5X, 'Correlations with the dependent variable: ', A) c___ J1 = IN + 1 c___ 40 J2 = MIN(J1+7, NP) c___ I1 = J1 - IN c___ I2 = J2 - IN c___ WRITE(LOUT, 930)(VNAME(VORDER(J)), J=J1,J2) c___ 930 FORMAT(/1X, 8(A8, 1X)) c___ WRITE(LOUT, 940)(YCORR(I),I=I1,I2) c___ 940 FORMAT(1X, 8(F8.5, 1X)) c___ J1 = J2 + 1 c___ IF (J1 .LE. NP) GO TO 40 c___C c___C Put extra blank line into output c___C c___ WRITE(LOUT, *) c___C c___ RETURN c___ END c include 'subs.for' earth/src/Makevars0000644000176200001440000000003712506743406013647 0ustar liggesusersPKG_LIBS=$(BLAS_LIBS) $(FLIBS) earth/src/rentries.c0000644000176200001440000002362213560403361014151 0ustar liggesusers// rentries.c: Register native routines for R. // The core of this routine is the function R_init_earth. #define USING_R 1 #include "R.h" #include "Rinternals.h" // for REALSXP etc. #include "R_ext/Rdynload.h" #ifndef _MSC_VER // microsoft #ifndef bool typedef int bool; #endif #endif #include "earth.h" static R_NativePrimitiveArgType FreeEarth_t[] = {INTSXP}; static R_NativePrimitiveArgType EvalSubsetsUsingXtxR_t[] = { REALSXP, // 01 double PruneTerms[] REALSXP, // 02 double RssVec[] INTSXP, // 03 const int* pnCases INTSXP, // 04 const int* pnResp INTSXP, // 05 const int* pnMaxTerms REALSXP, // 06 const double bx[] REALSXP, // 07 const double y[] REALSXP // 08 const double* pTrace }; static R_NativePrimitiveArgType RegressR_t[] = { REALSXP, // 01 double Betas[] REALSXP, // 02 double Residuals[] REALSXP, // 03 double Rss[] REALSXP, // 04 double Diags[] INTSXP, // 05 int* pnRank INTSXP, // 06 int iPivots[] REALSXP, // 07 const double x[] REALSXP, // 08 const double y[] INTSXP, // 09 const int* pnCases INTSXP, // 10 const int* pnResp INTSXP, // 11 int* pnCols LGLSXP // 12 const bool UsedCols[] }; static R_CMethodDef cEntries[] = { {"FreeEarth", (DL_FUNC)&FreeEarth, 0, FreeEarth_t}, {"EvalSubsetsUsingXtxR", (DL_FUNC)&EvalSubsetsUsingXtxR, 8, EvalSubsetsUsingXtxR_t}, {"RegressR", (DL_FUNC)&RegressR, 12, RegressR_t}, {NULL, NULL, 0, NULL} }; static R_CallMethodDef callEntries[] = { {"ForwardPassR", (DL_FUNC)&ForwardPassR, 31}, {NULL, NULL, 0} }; extern void F77_SUB(bakwrd)( int *NP, int *NRBAR, double *D, double *RBAR, double *THETAB, int *FIRST, int *LAST, int *VORDER, double *TOL, double *RSS, double *BOUND, int *NVMAX, double *RESS, int *IR, int *NBEST, int *LOPT, int *IL, double *WK, int *IWK, int *IER); extern void F77_SUB(forwrd)( int *NP, int *NRBAR, double *D, double *RBAR, double *THETAB, int *FIRST, int *LAST, int *VORDER, double *TOL, double *RSS, double *BOUND, int *NVMAX, double *RESS, int *IR, int *NBEST, int *LOPT, int *IL, double *WK, int *IWK, int *IER); extern void F77_SUB(seqrep)( int *NP, int *NRBAR, double *D, double *RBAR, double *THETAB, int *FIRST, int *LAST, int *VORDER, double *TOL, double *RSS, double *BOUND, int *NVMAX, double *RESS, int *IR, int *NBEST, int *LOPT, int *IL, double *WK, int *IWK, int *IER); void F77_SUB(xhaust)( int *NP, int *NRBAR, double *D, double *RBAR, double *THETAB, int *FIRST, int *LAST, int *VORDER, double *TOL, double *RSS, double *BOUND, int *NVMAX, double *RESS, int *IR, int *NBEST, int *LOPT, int *IL, double *WK, int *DIMWK, int *IWK, int *DIMIWK, int *IER); extern void F77_SUB(initr)( int *NP, int *NVMAX, int *NBEST, double *BOUND, double *RESS, int *IR, int *LOPT, int *IL, int *VORDER, double *RSS, int *IER); extern void F77_SUB(sing)( int *NP, int *NRBAR, double *D, double *RBAR, double *THETAB, double *SSERR, double *TOL, // nov 2019: changed LINDEP to int (from bool) to pacify R CRAN check int *LINDEP, double *WORK, int *IER); extern void F77_SUB(ssleaps)( int *NP, double *D, double *THETAB, double *SSERR, double *RSS, int *IER); extern void F77_SUB(tolset)( int *NP, int *NRBAR, double *D, double *RBAR, double *TOL, double *WORK, int *IER); void F77_SUB(makeqr)( int *NP, int *NN, double *WEIGHTS, double *TXMAT, double *YVEC, double *D, double *RBAR, double *THETAB, double *SSERR, int *IER); static R_NativePrimitiveArgType bakwrd_t[] = { INTSXP, // 01 INTEGER NP INTSXP, // 02 INTEGER NRBAR REALSXP, // 03 DOUBLE D REALSXP, // 04 DOUBLE RBAR REALSXP, // 05 DOUBLE THETAB INTSXP, // 06 INTEGER FIRST INTSXP, // 07 INTEGER LAST INTSXP, // 08 INTEGER VORDER REALSXP, // 09 DOUBLE TOL REALSXP, // 10 DOUBLE RSS REALSXP, // 11 DOUBLE BOUND INTSXP, // 12 INTEGER NVMAX REALSXP, // 13 DOUBLE RESS INTSXP, // 14 INTEGER IR INTSXP, // 15 INTEGER NBEST INTSXP, // 16 INTEGER LOPT INTSXP, // 17 INTEGER IL REALSXP, // 18 DOUBLE WK INTSXP, // 19 INTEGER IWK INTSXP, // 20 INTEGER IER }; static R_NativePrimitiveArgType forwrd_t[] = { INTSXP, // 01 INTEGER NP INTSXP, // 02 INTEGER NRBAR REALSXP, // 03 DOUBLE D REALSXP, // 04 DOUBLE RBAR REALSXP, // 05 DOUBLE THETAB INTSXP, // 06 INTEGER FIRST INTSXP, // 07 INTEGER LAST INTSXP, // 08 INTEGER VORDER REALSXP, // 09 DOUBLE TOL REALSXP, // 10 DOUBLE RSS REALSXP, // 11 DOUBLE BOUND INTSXP, // 12 INTEGER NVMAX REALSXP, // 13 DOUBLE RESS INTSXP, // 14 INTEGER IR INTSXP, // 15 INTEGER NBEST INTSXP, // 16 INTEGER LOPT INTSXP, // 17 INTEGER IL REALSXP, // 18 DOUBLE WK INTSXP, // 19 INTEGER IWK INTSXP, // 20 INTEGER IER }; static R_NativePrimitiveArgType seqrep_t[] = { INTSXP, // 01 INTEGER NP INTSXP, // 02 INTEGER NRBAR REALSXP, // 03 DOUBLE D REALSXP, // 04 DOUBLE RBAR REALSXP, // 05 DOUBLE THETAB INTSXP, // 06 INTEGER FIRST INTSXP, // 07 INTEGER LAST INTSXP, // 08 INTEGER VORDER REALSXP, // 09 DOUBLE TOL REALSXP, // 10 DOUBLE RSS REALSXP, // 11 DOUBLE BOUND INTSXP, // 12 INTEGER NVMAX REALSXP, // 13 DOUBLE RESS INTSXP, // 14 INTEGER IR INTSXP, // 15 INTEGER NBEST INTSXP, // 16 INTEGER LOPT INTSXP, // 17 INTEGER IL REALSXP, // 18 DOUBLE WK INTSXP, // 19 INTEGER IWK INTSXP, // 20 INTEGER IER }; static R_NativePrimitiveArgType xhaust_t[] = { INTSXP, // 01 INTEGER NP INTSXP, // 02 INTEGER NRBAR REALSXP, // 03 DOUBLE D REALSXP, // 04 DOUBLE RBAR REALSXP, // 05 DOUBLE THETAB INTSXP, // 06 INTEGER FIRST INTSXP, // 07 INTEGER LAST INTSXP, // 08 INTEGER VORDER REALSXP, // 09 DOUBLE TOL REALSXP, // 10 DOUBLE RSS REALSXP, // 11 DOUBLE BOUND INTSXP, // 12 INTEGER NVMAX REALSXP, // 13 DOUBLE RESS INTSXP, // 14 INTEGER IR INTSXP, // 15 INTEGER NBEST INTSXP, // 16 INTEGER LOPT INTSXP, // 17 INTEGER IL REALSXP, // 18 DOUBLE WK INTSXP, // 19 INTEGER DIMWK INTSXP, // 20 INTEGER IWK INTSXP, // 21 INTEGER DIMIWK INTSXP, // 22 INTEGER IER }; static R_NativePrimitiveArgType initr_t[] = { INTSXP, // 01 INTEGER NP INTSXP, // 02 INTEGER NVMAX INTSXP, // 03 INTEGER NBEST REALSXP, // 09 DOUBLE BOUND REALSXP, // 10 DOUBLE RESS INTSXP, // 04 INTEGER IR INTSXP, // 06 INTEGER LOPT INTSXP, // 05 INTEGER IL INTSXP, // 07 INTEGER VORDER REALSXP, // 11 DOUBLE RSS INTSXP, // 08 INTEGER IER }; static R_NativePrimitiveArgType sing_t[] = { INTSXP, // 01 DOUBLE NP INTSXP, // 02 DOUBLE NRBAR REALSXP, // 04 DOUBLE D REALSXP, // 05 DOUBLE RBAR REALSXP, // 06 DOUBLE THETAB REALSXP, // 07 DOUBLE SSERR REALSXP, // 08 DOUBLE TOL // nov 2019: changed LINDEP to INTSXP (from LGLSXP) to pacify R CRAN check INTSXP, // 10 INTEGER LINDEP REALSXP, // 09 DOUBLE WORK INTSXP, // 03 INTEGER IER }; static R_NativePrimitiveArgType ssleaps_t[] = { INTSXP, // 01 INTEGER NP REALSXP, // 03 DOUBLE D REALSXP, // 04 DOUBLE THETAB REALSXP, // 05 DOUBLE SSERR REALSXP, // 06 DOUBLE RSS INTSXP, // 02 INTEGER IER }; static R_NativePrimitiveArgType tolset_t[] = { INTSXP, // 01 INTEGER NP INTSXP, // 02 INTEGER NRBAR REALSXP, // 04 DOUBLE D REALSXP, // 05 DOUBLE RBAR REALSXP, // 06 DOUBLE TOL REALSXP, // 07 DOUBLE WORK INTSXP, // 03 INTEGER IER }; static R_NativePrimitiveArgType makeqr_t[] = { INTSXP, // 01 INTEGER NP INTSXP, // 02 INTEGER NN REALSXP, // 04 DOUBLE WEIGHTS REALSXP, // 05 DOUBLE TXMAT REALSXP, // 06 DOUBLE YVEC REALSXP, // 07 DOUBLE D REALSXP, // 08 DOUBLE RBAR REALSXP, // 09 DOUBLE THETAB REALSXP, // 10 DOUBLE SSERR INTSXP, // 03 INTEGER IER }; static R_FortranMethodDef fortranEntries[] = { { "bakwrd", (DL_FUNC)&F77_SUB(bakwrd), 20, bakwrd_t}, { "forwrd", (DL_FUNC)&F77_SUB(forwrd), 20, forwrd_t}, { "seqrep", (DL_FUNC)&F77_SUB(seqrep), 20, seqrep_t}, { "xhaust", (DL_FUNC)&F77_SUB(xhaust), 22, xhaust_t}, { "initr", (DL_FUNC)&F77_SUB(initr), 11, initr_t}, { "sing", (DL_FUNC)&F77_SUB(sing), 10, sing_t}, { "ssleaps", (DL_FUNC)&F77_SUB(ssleaps), 6, ssleaps_t}, { "tolset", (DL_FUNC)&F77_SUB(tolset), 7, tolset_t}, { "makeqr", (DL_FUNC)&F77_SUB(makeqr), 10, makeqr_t}, {NULL, NULL, 0, NULL} }; void R_init_earth(DllInfo *dll) // called by R after R loads the earth package { R_registerRoutines(dll, cEntries, callEntries, fortranEntries, NULL); R_useDynamicSymbols(dll, FALSE); } earth/src/earth.c0000644000176200001440000045550013560116566013435 0ustar liggesusers// earth.c // // This code is derived from code in the Rational Fortran file dmarss.r which is // part of the R and S mda package by Hastie and Tibshirani. // Comments containing "TODO" mark known issues // // See the R earth documentation for descriptions of the principal data structures. // See also www.milbo.users.sonic.net. This code uses a subset of C99. // // Stephen Milborrow Feb 2007 Petaluma // // References: // // HastieTibs: Trevor Hastie and Robert Tibshirani // S library mda version 0.3.2 dmarss.r Ratfor code // Modifications for R by Kurt Hornik, Friedrich Leisch, Brian Ripley // // FriedmanMars: Multivariate Adaptive Regression Splines (with discussion) // Annals of Statistics 19/1, 1--141, 1991 // // FriedmanFastMars: Friedman "Fast MARS" // Dep. of Stats. Stanford, Tech Report 110, May 1993 // // Miller: Alan Miller (2nd ed. 2002) Subset Selection in Regression // //----------------------------------------------------------------------------- // This program is free software; you can redistribute it and/or modify // it under the terms of the GNU General Public License as published by // the Free Software Foundation; either version 2 of the License, or // (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // A copy of the GNU General Public License is available at // http://www.r-project.org/Licenses // //----------------------------------------------------------------------------- #if !STANDALONE #define USING_R 1 #endif // STANDALONE #include #include #include #include #include #include #if _MSC_VER // microsoft #include // microsoft malloc debugging library #define _C_ "C" // disable warning: 'vsprintf': This function or variable may be unsafe #pragma warning(disable: 4996) #else #define _C_ #ifndef bool typedef int bool; #define false 0 #define true 1 #endif #endif #if USING_R // R with gcc #include "R.h" #include "Rinternals.h" // needed for Allowed function handling #include "allowed.h" #include "R_ext/Rdynload.h" #define printf Rprintf #define FINITE(x) R_FINITE(x) #else #define warning printf void error(const char* args, ...); #if _MSC_VER // microsoft #define ISNAN(x) _isnan(x) #define FINITE(x) _finite(x) #else #define ISNAN(x) isnan(x) #define FINITE(x) finite(x) #endif #endif #include "earth.h" #ifdef MATLAB #include "mex.h" // for printf #endif // linpack functions (dqrdc2 is a modified form of dqrdc used by R) extern _C_ int dqrdc2_(double* x, int* ldx, int* n, int* p, double* tol, int* rank, double* qraux, int* pivot, double* work); extern _C_ int dtrsl_(double* t, int* ldt, int* n, double* b, int* job, int* info); extern _C_ int dqrsl_(double* x, int* ldx, int* n, int* k, double* qraux, double* y, double* qy, double* qty, double* b, double* rsd, double* xb, int* job, int* info); extern _C_ int daxpy_(const int* n, const double* alpha, const double* dx, const int* incx, double* dy, const int* incy); extern _C_ double ddot_(const int* n, const double* dx, const int* incx, const double* dy, const int* incy); #define ASSERT(x) \ if(!(x)) error("internal assertion failed in file %s line %d: %s\n", \ __FILE__, __LINE__, #x) #define sq(x) ((x) * (x)) #ifndef max #define max(a,b) (((a) > (b)) ? (a) : (b)) #endif #ifndef min #define min(a,b) (((a) < (b)) ? (a) : (b)) #endif #define INLINE inline #define USE_BLAS 1 // 1 is faster (tested on Windows XP Pentium with R BLAS) // also, need USE_BLAS to use bxOrthCenteredT #define FAST_MARS 1 // 1 to use techniques in FriedmanFastMars (see refs) #define WEIGHTS 1 // 1 if case weights are supported #if STANDALONE #define IOFFSET 0 #else #define IOFFSET 1 // printfs only: 1 to convert 0-based indices to 1-based in printfs // use 1 for R style indices in messages to the user // use 0 for C style indices in messages to the user #endif static const char* VERSION = "version 5.1.0"; // change if you modify this file! static const double MIN_GRSQ = -10.0; static const double QR_TOL = 1e-8; // same as R lm static const double MIN_BX_SOS = .01; static const double ALMOST_ZERO = 1e-10; static const int ONE = 1; // parameter for BLAS routines #ifdef __INTEL_COMPILER static const double POS_INF = __builtin_inff(); #elif _MSC_VER // microsoft compiler static const double POS_INF = _HUGE; #else // assume gcc static const double POS_INF = (1.0 / 0.0); #endif static const int MAX_DEGREE = 100; // Poor man's array indexing -- not pretty, but pretty useful. // // Note that we use column major ordering. C programs usually use row major // ordering but we don't here because the functions in this file are called // by R and call Fortran routines which use column major ordering. // // Note that nCases is size_t (not int), allowing array indices bigger than 2GB. // We don't expect nCases itself to be that big, but it can be used in // expressions that evaluate to more than 2GB. #define Dirs_(iTerm,iPred) Dirs[(iTerm) + (iPred)*(nMaxTerms)] #define Cuts_(iTerm,iPred) Cuts[(iTerm) + (iPred)*(nMaxTerms)] #define bx_(i,iTerm) bx [(i) + (iTerm)*(nCases)] #define bxUsed_(i,iTerm) bxUsed [(i) + (iTerm)*(nCases)] #define bxOrth_(i,iTerm) bxOrth [(i) + (iTerm)*(nCases)] #define bxOrthCenteredT_(iTerm,i) bxOrthCenteredT[(iTerm) + (i)*(nMaxTerms)] #define x_(i,iPred) x [(i) + (iPred)*(nCases)] #define xOrder_(i,iPred) xOrder [(i) + (iPred)*(nCases)] #define y_(i,iResp) y [(i) + (iResp)*(nCases)] #define Residuals_(i,iResp) Residuals [(i) + (iResp)*(nCases)] #define ycboSum_(iTerm,iResp) ycboSum [(iTerm) + (iResp)*(nMaxTerms)] #define Betas_(iTerm,iResp) Betas [(iTerm) + (iResp)*(nUsedCols)] static char* sFormatMemSize(const size_t MemSize, const bool Align); #if FAST_MARS static void FreeQ(void); #endif //----------------------------------------------------------------------------- // Global copies of some input parameters. These stay constant for the entire MARS fit. static double TraceGlobal; // copy of Trace parameter static int nMinSpanGlobal; // copy of nMinSpan parameter static int nEndSpanGlobal; // copy of nEndSpan parameter static double AdjustEndSpanGlobal; // copy of AdjustEndSpan parameter //----------------------------------------------------------------------------- // These are malloced blocks. They unfortunately have to be declared // globally so we can free them if there is a call to error (or if a // call to R_CheckUserInterrupt doesn't return). // Some of these are thus shadowed (same name for global and local vars). static double* ybxSum; // local to FindPredGivenParent #if WEIGHTS static bool* UsedCols; // local to FindWeightedPredGivenParent #endif static bool* WorkingSet; // local to FindTerm and EvalSubsets static double* xbx; // local to FindTerm static double* CovSx; // local to FindTerm static double* CovCol; // local to FindTerm static double* ycboSum; // local to FindTerm (used to be called CovSy) static double* bxOrth; // local to ForwardPass static double* yMean; // local to ForwardPass // Transposed and mean centered copy of bxOrth, for fast update in FindKnot. // It's faster because there is better data locality as iTerm increases, so // better L1 cache use. This is used only if USE_BLAS is true. static double* bxOrthCenteredT; // local to ForwardPass static double* bxOrthMean; // local to ForwardPass static int* nDegree; // local to Earth or ForwardPassR static int* nUses; // local to Earth or ForwardPassR static int* xOrder; // local to ForwardPass (init in GetArrayOrder) #if USING_R static int* iDirs; // local to ForwardPassR static bool* BoolFullSet; // local to ForwardPassR const char** sPredNames; // local to ForwardPassR static bool* BoolPruneTerms; // local to void EvalSubsetsUsingXtxR #endif static double* Betas; // local to EvalSubsetsUsingXtx static double* Diags; // local to EvalSubsetsUsingXtx static double* BetaCacheGlobal; // [iOrthCol,iParent,iPred] // dim nPreds x nMaxTerms x nMaxTerms //----------------------------------------------------------------------------- // DON'T USE free, malloc, and calloc in this file. // Use free1, malloc1, and calloc1 instead. // // The function malloc and its friends are redefined so: // (a) out-of-memory conditions are immediately detected (in any operating system) // (b) FreeEarth doesn't re-free any freed blocks // (c) Under Microsoft C using crtdbg.h we can easily track alloc errors. // // In normal operation of the code in this file, each alloc is eventually // followed by a free. But if there is an premature return from the code (via // a call to error or via ^C), then we must call FreeEarth to ensure full freeing. // The R code does this using on.exit(.C("FreeEarth")). // free1 is a macro so we can zero p (so FreeEarth can check if it's released) #define free1(p) \ { \ if(p) \ free(p); \ p = NULL; \ } static void* malloc1(size_t size, const char* args, ...) { void* p = malloc(size); if(!p || TraceGlobal == 1.5) { if(args == NULL) printf("malloc %s\n", sFormatMemSize(size, true)); else { char s[1000]; va_list va; va_start(va, args); vsprintf(s, args, va); va_end(va); printf("malloc %s: %s\n", sFormatMemSize(size, true), s); } } if(!p) error("Out of memory (could not allocate %s)", sFormatMemSize(size, false)); return p; } static void* calloc1(size_t num, size_t size, const char* args, ...) { void* p = calloc(num, size); if(!p || TraceGlobal == 1.5) { if(args == NULL) printf("calloc %s\n", sFormatMemSize(size, true)); else { char s[1000]; va_list va; va_start(va, args); vsprintf(s, args, va); va_end(va); printf("calloc %s: %s\n", sFormatMemSize(size, true), s); } } if(!p) error("Out of memory (could not allocate %s)", sFormatMemSize(size, false)); return p; } #if _MSC_VER && _DEBUG // microsoft C and debugging enabled? // After calling this, on program termination we will get a report if there are // writes outside the borders of allocated blocks or if there are non-freed blocks. // For example, use earth/inst/slowtests/test.earthc.bat or test.earthmain.vc.bat, // and temporarily comment out a call to free() in this file to see the report. static void InitMallocTracking(void) { _CrtSetReportMode(_CRT_WARN, _CRTDBG_MODE_WNDW); _CrtSetReportMode(_CRT_WARN, _CRTDBG_MODE_FILE); _CrtSetReportFile(_CRT_WARN, _CRTDBG_FILE_STDOUT); int Flag = _CrtSetDbgFlag(_CRTDBG_REPORT_FLAG); Flag |= (_CRTDBG_ALLOC_MEM_DF| // following commented out because it makes earth run very slowly // _CRTDBG_CHECK_ALWAYS_DF| // call _CrtCheckMemory at every alloc and free _CRTDBG_LEAK_CHECK_DF| _CRTDBG_DELAY_FREE_MEM_DF); _CrtSetDbgFlag(Flag); } #endif void FreeEarth(void) // frees memory if premature exit from the C code { if(TraceGlobal == 1.5) { // the following is only an approximate check that mem already free const bool isfree = #if USING_R nUses == NULL && // initialized at the start of ForwardPassR #endif xOrder == NULL && // initialized in ForwardPass Betas == NULL; // initialized in EvalSubsetsUsingXtx printf("FreeEarth%s\n", isfree? " (already free)": ""); } free1(ybxSum); #if WEIGHTS free1(UsedCols); #endif free1(WorkingSet); free1(xbx); free1(CovSx); free1(CovCol); free1(ycboSum); free1(bxOrth); free1(yMean); free1(bxOrthCenteredT); free1(bxOrthMean); free1(nDegree); free1(nUses); free1(xOrder); #if USING_R free1(iDirs); free1(BoolFullSet); free1(sPredNames); free1(BoolPruneTerms); FreeAllowedFunc(); #endif free1(Betas); free1(Diags); free1(BetaCacheGlobal); #if FAST_MARS FreeQ(); #endif } //----------------------------------------------------------------------------- static char* sFormatMemSize(const size_t MemSize, const bool Align) { static char s[100]; double Size = (double)MemSize; if(Size >= 1e9) sprintf(s, Align? "%6.3f GB": "%.3g GB", Size / ((size_t)1 << 30)); else if(Size >= 1e6) sprintf(s, Align? "%6.0f MB": "%.3g MB", Size / ((size_t)1 << 20)); else if(Size >= 1e3) sprintf(s, Align? "%6.0f kB": "%.3g kB", Size / ((size_t)1 << 10)); else sprintf(s, Align? "%6.0f B": "%g Bytes", Size); return s; } //----------------------------------------------------------------------------- static void tprintf(const int trace, const char *args, ...) // printf with trace check { if(TraceGlobal >= trace) { char s[1000]; va_list va; va_start(va, args); vsprintf(s, args, va); va_end(va); printf("%s", s); } } //----------------------------------------------------------------------------- // Gets called periodically to service the R framework. // Will not return if the user interrupts. #if USING_R static INLINE void ServiceR(void) { R_FlushConsole(); R_CheckUserInterrupt(); // may never return } #endif //----------------------------------------------------------------------------- #if FAST_MARS typedef struct tQueue { int iParent; // parent term double RssDelta; int nTermsForRssDelta; // number of terms when RssDelta was calculated double AgedRank; } tQueue; static tQueue* Q; // indexed on iTerm (this Q is used for queue updates) static tQueue* SortedQ; // indexed on iParent rank (this Q is used to get next iParent) static int nQMax; // number of elements in Q static void InitQ(const int nMaxTerms) { nQMax = 0; Q = (tQueue*)malloc1(nMaxTerms * sizeof(tQueue), "Q\t\t\tnMaxTerms %d sizeof(tQueue) %d", nMaxTerms, sizeof(tQueue)); SortedQ = (tQueue*)malloc1(nMaxTerms * sizeof(tQueue), "SortedQ\t\tnMaxTerms %d sizeof(tQueue) %d", nMaxTerms, sizeof(tQueue)); for(int iTerm = 0; iTerm < nMaxTerms; iTerm++) { Q[iTerm].iParent = iTerm; Q[iTerm].nTermsForRssDelta = -99; // not strictly needed, nice for debugging Q[iTerm].RssDelta = -1; Q[iTerm].AgedRank = -1; } } static void FreeQ(void) { free1(Q); free1(SortedQ); } static void PrintSortedQ(int nFastK) // for debugging { printf("\n\nSortedQ QIndex Parent nTermsForRssDelta AgedRank RssDelta\n"); for(int i = 0; i < nQMax; i++) { printf(" %3d %3d %15d %5.1f %g\n", i+IOFFSET, SortedQ[i].iParent+IOFFSET, SortedQ[i].nTermsForRssDelta+IOFFSET, SortedQ[i].AgedRank, SortedQ[i].RssDelta); if(i == nFastK-1) printf("FastK %d ----------------------------------------------------\n", nFastK); } } // Sort so highest RssDeltas are at low indices. // Secondary sort key is iParent. Not strictly needed, but removes // possible differences in qsort implementations (which "sort" // identical keys unpredictably). static int CompareQ(const void* p1, const void* p2) // for qsort { double Diff = ((const tQueue*)p2)->RssDelta - ((const tQueue*)p1)->RssDelta; if(Diff < 0) return -1; else if(Diff > 0) return 1; // Diff is 0, so sort now on iParent int iDiff = ((const tQueue*)p1)->iParent - ((const tQueue*)p2)->iParent; if(iDiff < 0) return -1; else if(iDiff > 0) return 1; return 0; } // Sort so lowest AgedRanks are at low indices. // If AgedRanks are the same then sort on RssDelta and iParent. static int CompareAgedQ(const void* p1, const void* p2) // for qsort { double Diff = ((const tQueue*)p1)->AgedRank - ((const tQueue*)p2)->AgedRank; if(Diff < 0) return -1; else if(Diff > 0) return 1; // Diff is 0, so sort now on RssDelta Diff = ((const tQueue*)p2)->RssDelta - ((const tQueue*)p1)->RssDelta; if(Diff < 0) return -1; else if(Diff > 0) return 1; // Diff is still 0, so sort now on iParent int iDiff = ((const tQueue*)p1)->iParent - ((const tQueue*)p2)->iParent; if(iDiff < 0) return -1; else if(iDiff > 0) return 1; return 0; } static void AddTermToQ( const int iTerm, // in const int nTerms, // in const double RssDelta, // in const bool Sort, // in const int nMaxTerms, // in const double FastBeta) // in: ageing Coef, 0 is no ageing, FastMARS recommends 1 { ASSERT(iTerm < nMaxTerms); ASSERT(nQMax < nMaxTerms); Q[nQMax].nTermsForRssDelta = nTerms; Q[nQMax].RssDelta = max(Q[iTerm].RssDelta, RssDelta); nQMax++; if(Sort) { memcpy(SortedQ, Q, nQMax * sizeof(tQueue)); qsort(SortedQ, nQMax, sizeof(tQueue), CompareQ); // sort on RssDelta if(FastBeta > 0) { for(int iRank = 0; iRank < nQMax; iRank++) SortedQ[iRank].AgedRank = iRank + FastBeta * (nTerms - SortedQ[iRank].nTermsForRssDelta); qsort(SortedQ, nQMax, sizeof(tQueue), CompareAgedQ); // sort on aged rank } } } static void UpdateRssDeltaInQ(const int iParent, const int nTermsForRssDelta, const double RssDelta) { ASSERT(iParent == Q[iParent].iParent); ASSERT(iParent < nQMax); Q[iParent].nTermsForRssDelta = nTermsForRssDelta; Q[iParent].RssDelta = RssDelta; } static int GetNextParent( // returns -1 if no more parents const bool InitFlag, // use true to init, thereafter false const int nFastK) { static int iQ; // index into sorted queue int iParent = -1; if(InitFlag) { if(TraceGlobal == 6) printf("\n|Considering parents "); iQ = 0; } else { if(iQ < min(nQMax, nFastK)) { iParent = SortedQ[iQ].iParent; iQ++; } if(TraceGlobal == 6 && iParent >= 0) printf("%d [%g] ", iParent+IOFFSET, SortedQ[iQ].RssDelta); } return iParent; } #endif // FAST_MARS //----------------------------------------------------------------------------- // This helps reduce the effects of numerical err, mostly when testing. static INLINE double MaybeZero(double x) { return x < ALMOST_ZERO? 0. : x; } //----------------------------------------------------------------------------- // GetOrder() gets the sort indices of vector x, so // x[sorted[i]] <= x[sorted[i+1]]. Ties may be reordered. The returned // indices are 0 based (as in C not as in R). // // This function is similar to the R library function rsort_with_index(), // but is defined here to minimize R dependencies. // Informal tests show that this is faster than rsort_with_index(). static const double* pxGlobal; // needed because of the way qsort works static int Compare(const void* p1, const void* p2) // for qsort { const int i1 = *(const int*)p1; const int i2 = *(const int*)p2; const double Diff = pxGlobal[i1] - pxGlobal[i2]; if(Diff < 0) return -1; else if(Diff > 0) return 1; else return 0; } static void GetOrder( int sorted[], // out: vec with nx elements const double x[], // in: x is a vec with nx elems const int nx) // in: number of elems in x { for(int i = 0; i < nx; i++) sorted[i] = i; pxGlobal = x; qsort(sorted, nx, sizeof(int), Compare); } //----------------------------------------------------------------------------- // Get order indices for an x array of dimensions nRows x nCols. // // Returns an nRows x nCols integer array of indices, where each column // corresponds to a column of x. See GetOrder() for ordering details. // // Caller must free the returned array. static int* GetArrayOrder( const double x[], // in const size_t nRows, // in const int nCols) // in { int *xOrder = (int*)malloc1(nRows * nCols * sizeof(int), "xOrder\t\tnRows %d nCols %d sizeof(int) %d", nRows, nCols, sizeof(int)); // following can be quite slow if nRows is big (requires qsort for each colun) for(int iCol = 0; iCol < nCols; iCol++) { GetOrder(xOrder + iCol*nRows, x + iCol*nRows, (int)nRows); #if USING_R if(nRows > (int)1e4) ServiceR(); #endif } return xOrder; } //----------------------------------------------------------------------------- // return the number of TRUEs in the boolean vector UsedCols static int GetNbrUsedCols(const bool UsedCols[], const int nLen) { int nTrue = 0; for(int iCol = 0; iCol < nLen; iCol++) if(UsedCols[iCol]) nTrue++; return nTrue; } //----------------------------------------------------------------------------- // Copy used columns in x to *pxUsed and return the number of used columns // UsedCols[i] is true for each each used column index in x // Caller must free *pxUsed static int CopyUsedCols( double** pxUsed, // out: caller must free const double x[], // in: nCases x nCols const size_t nCases, // in const int nCols, // in const bool UsedCols[]) // in { const int nUsedCols = GetNbrUsedCols(UsedCols, nCols); double* xUsed = (double*)malloc1(nCases * nUsedCols * sizeof(double), "xUsed\t\t\tnCases %d nUsedCols %d sizeof(double) %d", (int)nCases, nUsedCols, sizeof(double)); int iUsed = 0; for(int iCol = 0; iCol < nCols; iCol++) if(UsedCols[iCol]) { memcpy(xUsed + iUsed * nCases, x + iCol * nCases, nCases * sizeof(double)); iUsed++; } *pxUsed = xUsed; return nUsedCols; } //----------------------------------------------------------------------------- // Print a summary of the model, for debug tracing #if STANDALONE static void PrintSummary( const int nMaxTerms, // in const int nTerms, // in: number of cols in bx, some may be unused const int nPreds, // in: number of predictors const int nResp, // in: number of cols in y const bool UsedCols[], // in: specifies used columns in bx const int Dirs[], // in const double Cuts[], // in const double Betas[], // in: if NULL will print zeros const int nDegree[]) // in: degree of each term, degree of intercept is 0 { printf(" nFacs Beta\n"); const int nUsedCols = GetNbrUsedCols(UsedCols, nTerms); int iUsed = -1; for(int iTerm = 0; iTerm < nTerms; iTerm++) { if(UsedCols[iTerm]) { iUsed++; printf("%2.2d %2d ", iTerm, nDegree[iTerm]); for(int iResp = 0; iResp < nResp; iResp++) printf("%9.3g ", (Betas? Betas_(iUsed, iResp): 0)); printf("| "); } else { printf("%2.2d -- ", iTerm); for(int iResp = 0; iResp < nResp; iResp++) printf("%9s ", "--"); printf("| "); } int iPred; for(iPred = 0; iPred < nPreds; iPred++) if(Dirs_(iTerm,iPred) == 0) printf(" . "); else printf("%2d ", Dirs_(iTerm,iPred)); printf("|"); for(iPred = 0; iPred < nPreds; iPred++) if(Dirs_(iTerm,iPred) == 0) printf(" . "); else if(Dirs_(iTerm,iPred) == 2) printf(" linear "); else printf("%8.3g ", Cuts_(iTerm,iPred)); printf("\n"); } printf("\n"); } #endif // STANDALONE //----------------------------------------------------------------------------- // Set Diags to the diagonal values of inverse(X'X), // where X is referenced via the matrix R, from a previous call to dqrdc2 // with (in practice) bx. The net result is that Diags is the diagonal // values of inverse(bx'bx). We assume that R is created from a full rank X. // // TODO This could be simplified static void CalcDiags( double Diags[], // out: nCols x 1 const double R[], // in: nCases x nCols, QR from prev call to dqrdc2 const size_t nCases, // in const int nCols) // in { #define R_(i,j) R [(i) + (j) * nCases] #define R1_(i,j) R1[(i) + (const size_t)(j) * nCols] #define B_(i,j) B [(i) + (const size_t)(j) * nCols] double* R1 = (double*)malloc1(nCols * nCols * sizeof(double), // nCols rows of R "R1\t\t\tnCols %d nCols %d sizeof(double) %d", nCols, nCols, sizeof(double)); double* B = (double*)calloc1(nCols * nCols, sizeof(double), // rhs of R1 * x = B "B\t\t\tnCols %d nCols %d sizeof(double) %d", nCols, nCols, sizeof(double)); int i, j; for(i = 0; i < nCols; i++) { // copy nCols rows of R into R1 for(j = 0; j < nCols; j++) R1_(i,j) = R_(i,j); B_(i,i) = 1; // set diag of B to 1 } int job = 1; // 1 means solve R1 * x = B where R1 is upper triangular int info = 0; for(i = 0; i < nCols; i++) { dtrsl_( // LINPACK function R1, // in: t, matrix of the system, untouched (int*)&nCols, // in: ldt (typecast discards const) (int*)&nCols, // in: n &B_(0,i), // io: b, on return has solution x &job, // in: &info); // io: ASSERT(info == 0); } // B is now inverse(R1). Calculate B x B. for(i = 0; i < nCols; i++) for(j = 0; j < nCols; j++) { double Sum = 0; for(int k = max(i,j); k < nCols; k++) Sum += B_(i,k) * B_(j,k); B_(i,j) = B_(j,i) = Sum; } for(i = 0; i < nCols; i++) Diags[i] = B_(i,i); free1(B); free1(R1); } //----------------------------------------------------------------------------- // Regress y on the used columns of x, in the standard way (using QR). // UsedCols[i] is true for each each used col i in x; unused cols are ignored. // // The returned Betas argument is computed from, and is indexed on, // the compacted x vector, not on the original x. // // The returned iPivots should only be used if *pnRank != nUsedCols. // The entries of iPivots refer to columns in the full x (and are 0 based). // Entries in iPivots at *pnRank and above specify linearly dependent columns in x. // // To maximize compatibility we call the same routines as the R function lm. static void Regress( double Betas[], // out: nUsedCols * nResp, can be NULL double Residuals[], // out: nCases * nResp, can be NULL double* pRss, // out: RSS, summed over all nResp, can be NULL double Diags[], // out: diags of inv(transpose(x) * x), can be NULL int* pnRank, // out: nbr of indep cols in x, can be NULL int iPivots[], // out: nCols, can be NULL const double x[], // in: nCases x nCols, must include intercept const double y[], // in: nCases x nResp const size_t nCases, // in: number of rows in x and in y const int nResp, // in: number of cols in y const int nCols, // in: number of columns in x, some may not be used const bool UsedCols[]) // in: specifies used columns in x { double* xUsed; int nUsedCols = CopyUsedCols(&xUsed, x, nCases, nCols, UsedCols); bool MustFreeResiduals = false; if(Residuals == NULL) { Residuals = (double*)malloc1(nCases * nResp * sizeof(double), "Residuals\t\tnCases %d nResp %d sizeof(double) %d", (int)nCases, nResp, sizeof(double)); MustFreeResiduals = true; } bool MustFreePivots = false; if(iPivots == NULL) { iPivots = (int*)malloc1(nUsedCols * sizeof(int), "iPivots\t\tnUsedCols %d sizeof(int) %d", nUsedCols, sizeof(int)); MustFreePivots = true; } int iCol; for(iCol = 0; iCol < nUsedCols; iCol++) iPivots[iCol] = iCol+1; double* qraux = (double*)malloc1(nUsedCols * sizeof(double), "qraux\t\t\tnUsedCols %d sizeof(double) %d", nUsedCols, sizeof(double)); // work size must be nUsedCols*2 for dqrdc2, and nCases*nUsedCols for // dqrsl where it is used for qy, qty, and rsd double* work = (double*)malloc1( max((size_t)nUsedCols * 2, nCases * nUsedCols) * sizeof(double), "work\t\t\tnCases %d nUsedCols %d sizeof(double) %d", (int)nCases, nUsedCols, sizeof(double)); int nCases1 = (int)nCases; // type convert from size_t int nRank; dqrdc2_( // R function, QR decomp based on LINPACK dqrdc xUsed, // io: x, on return upper tri of x is R of QR &nCases1, // in: ldx &nCases1, // in: n &nUsedCols, // in: p (double*)&QR_TOL, // in: tol &nRank, // out: k, num of indep cols of x qraux, // out: qraux iPivots, // out: jpvt work); // work double Rss = 0; const bool NeedResiduals = !MustFreeResiduals || pRss; int job = (Betas? 100: 0) + (NeedResiduals? 10: 0); if(job) { // job will be zero if all we need are the iPivots from dqrdc2 for(int iResp = 0; iResp < nResp; iResp++) { int info; dqrsl_( // LINPACK function xUsed, // in: x, generated by dqrdc2 &nCases1, // in: ldx &nCases1, // in: n &nRank, // in: k qraux, // in: qraux (double*)(y + iResp * nCases), // in: y NULL, // out: qy, unused here work, // out: qty, required if rsd in job Betas? // out: b, only needed if user asked for them (double*)(&Betas_(0,iResp)): work, NeedResiduals? // out: rsd (double*)(&Residuals_(0,iResp)): NULL, NULL, // out: xb = yHat, unused here &job, // in: job &info); // in: info ASSERT(info == 0); // compute Residuals and Rss (sum over all responses) if(NeedResiduals) for(int i = 0; i < (const int)nCases; i++) Rss += sq(Residuals_(i, iResp)); } if(pRss) *pRss = Rss; } if(nRank != nUsedCols && !MustFreePivots ) { // only bother if caller wants iPivots back // adjust iPivots for missing cols in UsedCols and for 1 offset int* PivotOffset = (int*)malloc1(nCols * sizeof(int), "PivotOffset\t\t\tnCols %d sizeof(int) %d", nCols, sizeof(int)); int nOffset = 0, iOld = 0; for(iCol = 0; iCol < nCols; iCol++) { if(!UsedCols[iCol]) nOffset++; else { PivotOffset[iOld] = nOffset; if(++iOld > nUsedCols) break; } } for(iCol = 0; iCol < nUsedCols; iCol++) iPivots[iCol] = iPivots[iCol] - 1 + PivotOffset[iPivots[iCol] - 1]; free1(PivotOffset); } if(pnRank) *pnRank = nRank; if(Diags) CalcDiags(Diags, xUsed, nCases, nUsedCols); if(MustFreePivots) free1(iPivots); if(MustFreeResiduals) free1(Residuals); free1(xUsed); free1(qraux); free1(work); } //----------------------------------------------------------------------------- // This routine is for testing Regress from R, to compare results to R's lm(). #if USING_R void RegressR( // for testing earth routine Regress from R double Betas[], // out: (nUsedCols+1) * nResp, +1 is for intercept double Residuals[], // out: nCases * nResp double Rss[], // out: RSS, summed over all nResp double Diags[], // out: diags of inv(transpose(x) * x) int* pnRank, // out: nbr of indep cols in x int iPivots[], // out: nCols const double x[], // in: nCases x nCols const double y[], // in: nCases x nResp const int* pnCases, // in: number of rows in x and in y const int* pnResp, // in: number of cols in y int* pnCols, // in: number of columns in x, some may not be used const bool UsedCols[]) // in: specifies used columns in x { const size_t nCases1 = *pnCases; // type convert Regress(Betas, Residuals, Rss, Diags, pnRank, iPivots, x, y, nCases1, *pnResp, *pnCols, UsedCols); } #endif //----------------------------------------------------------------------------- // Regress y on bx to get Residuals and Betas. If bx isn't of full rank, // remove dependent cols, update UsedCols, and regress again on the bx with // removed cols. static void RegressAndFix( double Betas[], // out: nMaxTerms x nResp, can be NULL double Residuals[], // out: nCases x nResp, can be NULL double Diags[], // out: if !NULL set to diags of inv(transpose(bx) * bx) bool UsedCols[], // io: will remove cols if necessary, nMaxTerms x 1 const double bx[], // in: nCases x nMaxTerms const double y[], // in: nCases x nResp const size_t nCases, // in const int nResp, // in: number of cols in y const int nTerms) // in: number of cols in bx, some may not be used { int nRank; int* iPivots = (int*)malloc1(nTerms * sizeof(int), "iPivots\t\tnTerms %d sizeof(int) %d", nTerms, sizeof(int)); Regress(Betas, Residuals, NULL, Diags, &nRank, iPivots, bx, y, nCases, nResp, nTerms, UsedCols); int nUsedCols = GetNbrUsedCols(UsedCols, nTerms); const int nDeficient = nUsedCols - nRank; if(nDeficient) { // rank deficient? // Remove linearly dependent columns. // The lin dep columns are at index nRank and higher in iPivots. for(int iCol = nRank; iCol < nUsedCols; iCol++) UsedCols[iPivots[iCol]] = false; Regress(Betas, Residuals, NULL, Diags, &nRank, NULL, bx, y, nCases, nResp, nTerms, UsedCols); nUsedCols = nUsedCols - nDeficient; if(nRank != nUsedCols) warning("Could not fix rank deficient bx: nUsedCols %d nRank %d", nUsedCols, nRank); else { tprintf(1, "Fixed rank deficient bx by removing %d term%s, %d term%s remain%s\n", nDeficient, ((nDeficient==1)? "": "s"), nUsedCols, ((nUsedCols==1)? "": "s"), ((nUsedCols==1)? "s": "")); tprintf(4, "\n"); } } free1(iPivots); } //----------------------------------------------------------------------------- static INLINE double Mean(const double x[], size_t n) { double mean = 0; for(size_t i = 0; i < n; i++) mean += x[i] / n; return mean; } //----------------------------------------------------------------------------- // get mean centered sum of squares static INLINE double SumOfSquares(const double x[], const double mean, size_t n) { double ss = 0; for(size_t i = 0; i < n; i++) ss += sq(x[i] - mean); return ss; } //----------------------------------------------------------------------------- static INLINE double GetGcv(const int nTerms, // nbr basis terms including intercept const size_t nCases, double Rss, const double Penalty) { double Cost; if(Penalty == -1) // special case: terms and knots are free Cost = 0; else { const double nKnots = ((double)nTerms-1) / 2; Cost = (nTerms + Penalty * nKnots) / nCases; } // test against Cost ensures that GCVs are non-decreasing as nbr of terms increases return Cost >= 1? POS_INF : Rss / (nCases * sq(1 - Cost)); } //----------------------------------------------------------------------------- // Check if model term type is already in model, to avoid a linear dependence. // TODO The code in this routine doesn't seem to make sense. static bool GetNewFormFlag(const int iPred, const int iTerm, const int Dirs[], const bool UsedCols[], const int nTerms, const int nPreds, const int nMaxTerms) { bool IsNewForm = true; for(int i = 1; i < nTerms; i++) // start at 1 to skip intercept if(UsedCols[i]) { IsNewForm = false; if(Dirs_(i,iPred) == 0) // unused in term i return true; // TODO if the following code is commented out, test suite passes (!) for(int j = 0; j < nPreds; j++) if(j != iPred && (Dirs_(i,j) != 0) != (Dirs_(iTerm,j) != 0)) return true; } return IsNewForm; } //----------------------------------------------------------------------------- static double GetCut( const int i, const int iPred, const size_t nCases, const double x[], const int xOrder[]) { if(i < 0 || i >= (const int)nCases) error("GetCut i %d: i < 0 || i >= nCases", i); const int ix = xOrder_(i,iPred); if(ix < 0 || ix >= (const int)nCases) error("GetCut ix %d: ix < 0 || ix >= nCases", ix); return x_(ix,iPred); } //----------------------------------------------------------------------------- // The BetaCache is used when searching for a new term pair, via FindTerm. // Most of the calculation for the orthogonal regression betas is repeated // with the same data, and thus we can save time by caching betas. // (The "Betas" are the regression coefficients.) // // iParent is the term that forms the base for the new term // iPred is the predictor for the new term // iOrthCol is the column index in the bxOrth matrix static void InitBetaCache(const bool UseBetaCache, const int nMaxTerms, const int nPreds) { int nCache = nMaxTerms * nMaxTerms * nPreds; if(!UseBetaCache) { BetaCacheGlobal = NULL; // 3e9 below is somewhat arbitrary but seems about right (in 2011) } else if(nCache * sizeof(double) > 3e9) { printf( "\nNote: earth's beta cache would require %s, so forcing Use.beta.cache=FALSE.\n" " Invoke earth with Use.beta.cache=FALSE to make this message go away.\n\n", sFormatMemSize(nCache * sizeof(double), false)); BetaCacheGlobal = NULL; } else { tprintf(5, "BetaCache %s\n", // print cache size sFormatMemSize(nCache * sizeof(double), false)); BetaCacheGlobal = (double*)malloc1(nCache * sizeof(double), "BetaCacheGlobal\tnMaxTerms %d nMaxTerms %d nPreds %d sizeof(double) %d", nMaxTerms, nMaxTerms, nPreds, sizeof(double)); for(int i = 0; i < nCache; i++) // mark all entries as uninitialized BetaCacheGlobal[i] = POS_INF; } } //----------------------------------------------------------------------------- // Init a new bxOrthCol to the residuals from regressing y on the used columns // of the orthogonal matrix bxOrth. The length (i.e. sum of squares divided // by nCases) of each column of bxOrth must be 1 with mean 0 (except the // first column which is the intercept). // // In practice this function is called with the params shown in {braces} // and is called only by InitBxOrthCol. // // This function must be fast. // // In calculation of Beta, we used to have // xty += pbxOrth[i] * y[i]; // and now we have // xty += pbxOrth[i] * bxOrthCol[i]; // i.e. we use the "modified" instead of the "classic" Gram Schmidt. // This is less susceptible to numerical error, although it is rare // to see the effect in practice in earth models (but you can see it in the // final model in the test suite function test.zigzag in test.weights.R). static INLINE void OrthogResiduals( double bxOrthCol[], // out: nCases x 1 { bxOrth[,nTerms] } const double y[], // in: nCases x nResp { bx[,nTerms], xbx } const double bxOrth[], // in: nTerms x nPreds { bxOrth } const size_t nCases, // in const int nTerms, // in: nTerms in model, i.e. number of used cols in bxOrth const bool UsedTerms[], // in: UsedTerms[i] is true if col is used, unused cols ignored // Following parameters are only for the beta cache const int iParent, // in: if >= 0, use BetaCacheGlobal {FindTerm iTerm, addTermP -1} const int iPred, // in: predictor index i.e. col index in input matrix x const int nMaxTerms) // in: { double* pCache; if(iParent >= 0 && BetaCacheGlobal) pCache = BetaCacheGlobal + iParent*nMaxTerms + iPred*sq(nMaxTerms); else pCache = NULL; memcpy(bxOrthCol, y, nCases * sizeof(double)); for(int iTerm = 0; iTerm < nTerms; iTerm++) if(UsedTerms[iTerm]) { const double* pbxOrth = &bxOrth_(0, iTerm); double Beta; if(pCache && pCache[iTerm] != POS_INF) Beta = pCache[iTerm]; else { double xty = 0; for(int i = 0; i < (const int)nCases; i++) xty += pbxOrth[i] * bxOrthCol[i]; // see header comment Beta = xty; // no need to divide by xtx, it is 1 ASSERT(FINITE(Beta)); if(pCache) pCache[iTerm] = Beta; } if(USE_BLAS) { const double NegBeta = -Beta; const int nCases1 = (int)nCases; // type convert from size_t daxpy_(&nCases1, &NegBeta, pbxOrth, &ONE, bxOrthCol, &ONE); } else for(int i = 0; i < (const int)nCases; i++) bxOrthCol[i] -= Beta * pbxOrth[i]; } } //----------------------------------------------------------------------------- // Init the rightmost column of bxOrth i.e. the column indexed by nTerms. // The new col is the normalized residuals from regressing y on the // lower (i.e. already existing) cols of bxOrth. // Also updates bxOrthCenteredT and bxOrthMean. // // In practice this function is called only with the params shown in {braces} static INLINE void InitBxOrthCol( double bxOrth[], // io: col nTerms is changed, other cols not touched double bxOrthCenteredT[], // io: kept in sync with bxOrth double bxOrthMean[], // io: element at nTerms is updated bool* pGoodCol, // io: true if col sum-of-squares is greater than MIN_BX_SOS const double* y, // in: { AddCandLinTerm xbx, AddTermPair bx[,nTerms] } const int nTerms, // in: column goes in at index nTerms, 0 is the intercept const bool WorkingSet[], // in const size_t nCases, // in const int nMaxTerms, // in const int iCacheTerm, // in: if >= 0, use BetaCacheGlobal {FindTerm iTerm, AddTermP -1} // if < 0 then recalc Betas from scratch const int iPred) // in: predictor index i.e. col index in input matrix x { *pGoodCol = true; int i; if(nTerms == 0) { // column 0, the intercept double len = 1 / sqrt((double)nCases); for(i = 0; i < (const int)nCases; i++) bxOrth_(i,0) = len; bxOrthMean[0] = len; } else if(nTerms == 1) { // column 1, the first basis function, y = xbx = x[,1] double yMean = Mean(y, nCases); for(i = 0; i < (const int)nCases; i++) bxOrth_(i,1) = y[i] - yMean; } else OrthogResiduals(&bxOrth_(0,nTerms), // resids go in rightmost col of bxOrth at nTerms y, bxOrth, nCases, nTerms, WorkingSet, iCacheTerm, iPred, nMaxTerms); if(nTerms > 0) { // normalize the column to length 1 and init bxOrthMean[nTerms] double bxOrthSS = SumOfSquares(&bxOrth_(0,nTerms), 0, nCases); if(bxOrthSS <= MIN_BX_SOS) *pGoodCol = false; // iCacheTerm will be negative unless called by AddCandidateLinearTerm if(bxOrthSS > (iCacheTerm < 0? 0: MIN_BX_SOS)) { bxOrthMean[nTerms] = Mean(&bxOrth_(0,nTerms), nCases); const double len = sqrt(bxOrthSS); for(i = 0; i < (const int)nCases; i++) bxOrth_(i,nTerms) /= len; } else { bxOrthMean[nTerms] = 0; memset(&bxOrth_(0,nTerms), 0, nCases * sizeof(double)); } } for(i = 0; i < (const int)nCases; i++) // keep bxOrthCenteredT in sync bxOrthCenteredT_(nTerms,i) = bxOrth_(i,nTerms) - bxOrthMean[nTerms]; } //----------------------------------------------------------------------------- // Add a new term pair to the arrays. // Each term in the new term pair is a copy of an existing parent term but extended // by multiplying it by a new hinge function at the selected knot. // If the upper term in the term pair is invalid then we still add the upper // term but mark it as false in FullSet. static void AddTermPair( int Dirs[], // io double Cuts[], // io double bx[], // io: MARS basis matrix double bxOrth[], // io double bxOrthCenteredT[], // io double bxOrthMean[], // io bool FullSet[], // io bool* pIsNewForm, // io int nDegree[], // io: degree of each term, degree of intercept is 0 int nUses[], // io: nbr of times each predictor is used in the model const int nTerms, // in: new term pair goes in at index nTerms and nTerms1 const int iBestParent, // in: parent term const int iBestCase, // in const int iBestPred, // in const int nPreds, // in const size_t nCases, // in const int nMaxTerms, // in const bool LinPredIsBest, // in: true if pred should enter linearly (no knot) const int LinPreds[], // in: user specified preds which must enter linearly const double x[], // in const int xOrder[], // in const bool Weighted) // in { const int nTerms1 = nTerms+1; // copy the parent term to the new term pair int iPred; for(iPred = 0; iPred < nPreds; iPred++) { Dirs_(nTerms, iPred) = Dirs_(nTerms1,iPred) = Dirs_(iBestParent,iPred); Cuts_(nTerms, iPred) = Cuts_(nTerms1,iPred) = Cuts_(iBestParent,iPred); } // incorporate the new hinge function nDegree[nTerms] = nDegree[nTerms1] = nDegree[iBestParent] + 1; int DirEntry = 1; if(LinPreds[iBestPred] || LinPredIsBest) { // changed in earth 4.0.0 ASSERT(LinPredIsBest); DirEntry = 2; } Dirs_(nTerms, iBestPred) = DirEntry; Dirs_(nTerms1,iBestPred) = -1; // will be ignored if adding only one hinge const double BestCut = GetCut(iBestCase, iBestPred, nCases, x, xOrder); Cuts_(nTerms, iBestPred) = Cuts_(nTerms1,iBestPred) = BestCut; // Fill in new columns of bx, at nTerms and nTerms+1 (left and right hinges). #if WEIGHTS // in FindWeightedPredGivenParent, we used the two columns // in bx as a scratch buffer, so zero them again ASSERT(nTerms+1 < nMaxTerms); memset(&bx_(0,nTerms), 0, nCases * sizeof(double)); memset(&bx_(0,nTerms+1), 0, nCases * sizeof(double)); #endif int i; if(DirEntry == 2) { // linpred? for(i = 0; i < (const int)nCases; i++) // add single term bx_(i,nTerms) = bx_(i,iBestParent) * x_(i,iBestPred); } else for(i = 0; i < (const int)nCases; i++) { // add term pair const int iOrdered = xOrder_(i, iBestPred); const double xi = x_(iOrdered, iBestPred); if(i > iBestCase) bx_(iOrdered, nTerms) = bx_(iOrdered, iBestParent) * (xi - BestCut); else bx_(iOrdered, nTerms1) = bx_(iOrdered, iBestParent) * (BestCut - xi); } nUses[iBestPred]++; // init the col in bxOrth at nTerms and init bxOrthMean[nTerms] FullSet[nTerms] = true; bool GoodCol; InitBxOrthCol(bxOrth, bxOrthCenteredT, bxOrthMean, &GoodCol, &bx_(0,nTerms), nTerms, FullSet, nCases, nMaxTerms, -1, nPreds); // -1 means don't use BetaCacheGlobal, calc Betas afresh #if 0 // TODO commented out because this sometimes happens if(!GoodCol) printf("GoodCol is false in AddTermPair\n"); #endif // init the col in bxOrth at nTerms1 and init bxOrthMean[nTerms1] if(!LinPredIsBest && *pIsNewForm) FullSet[nTerms1] = true; if(FullSet[nTerms1]) { InitBxOrthCol(bxOrth, bxOrthCenteredT, bxOrthMean, &GoodCol, &bx_(0,nTerms1), nTerms1, FullSet, nCases, nMaxTerms, -1, iPred); if(Weighted && !GoodCol) { // !GoodCol usuall happens only when weights are used. For the // nonweighted situation we would have already cleared IsNewForm in // FindPredGivenParent (inside AddCandidateLinearTerm), although // we sometimes get a non GoodCol here without weights. tprintf(6, "clear IsNewForm\n"); *pIsNewForm = false; FullSet[nTerms1] = false; } } if(!FullSet[nTerms1]) { // If the term is not valid, then we don't wan't to use it as the // base for a new term later (in FindTerm). Enforce this by setting // nDegree to a value greater than any posssible nMaxDegree. nDegree[nTerms1] = MAX_DEGREE + 1; memset(&bxOrth_(0,nTerms1), 0, nCases * sizeof(double)); bxOrthMean[nTerms1] = 0; for(i = 0; i < (const int)nCases; i++) // keep bxOrthCenteredT in sync bxOrthCenteredT_(nTerms1,i) = 0; } } //----------------------------------------------------------------------------- static int GetNbrUsed( // Nm in Friedman's notation const size_t nCases, // in const int iParent, // in const double bx[]) // in: MARS basis matrix { int nUsed = 0; if(bx == NULL) nUsed = (const int)nCases; else for(int i = 0; i < (const int)nCases; i++) if(bx_(i,iParent) > 0) nUsed++; return nUsed; } //----------------------------------------------------------------------------- static int GetEndSpan( const int nPreds, const int nDegree, // in: degree of current term (for adjusting endspan) const size_t nCases) { int nEndSpan = 1; if(nEndSpanGlobal > 0) // user specified endspan? nEndSpan = nEndSpanGlobal; else if(nEndSpanGlobal == 0) { // auto? // eqn 45 FriedmanMars (see refs) static const double log_2 = 0.69315; // log(2) static const double temp1 = 7.32193; // 3 + log(20)/log(2); nEndSpan = (int)(temp1 + log((double)nPreds) / log_2); } else // negative endspan illegal error("endspan %d < 0", nEndSpanGlobal); if(nDegree >= 2) // .5 below makes (int) cast act as round nEndSpan += (int)(AdjustEndSpanGlobal * nEndSpan + .5); if(nEndSpan > (const int)nCases / 2 - 1) // always at least one knot, so above adjustment nEndSpan = (const int)nCases / 2 - 1; // doesn't completely inhibit degree2 terms nEndSpan = max(1, nEndSpan); return nEndSpan; } //----------------------------------------------------------------------------- static void GetSpanParams( int* pnMinSpan, // out: number cases between knots int* pnEndSpan, // out: number of cases from start until first knot int* pnStartSpan, // out: number of cases from end until first knot const size_t nCases, // in const int nPreds, // in const int nDegree, // in: degree of current term (for adjusting endspan) const int iParent, // in const double bx[]) // in: MARS basis matrix, can be NULL { const int nEndSpan = GetEndSpan(nPreds, nDegree, nCases); int nStartSpan = 0, nMinSpan = 0; if(nMinSpanGlobal < 0) { // treat negative minspan as number of knots // get nMinSpan nMinSpan = (int)(ceil(nCases / (1.-nMinSpanGlobal))); // convert ncases to minspan // get nStartSpan nStartSpan = nMinSpan; while(nStartSpan < nEndSpan) nStartSpan += nMinSpan; nStartSpan--; nStartSpan = max(1, nStartSpan); } else { // get nMinSpan if(nMinSpanGlobal > 0) // user specified minspan? nMinSpan = nMinSpanGlobal; else if(nMinSpanGlobal == 0) { // auto? // eqn 43 in FriedmanMars paper (see refs) const int nUsed = GetNbrUsed(nCases, iParent, bx); // Nm in Friedmans notation static const double temp1 = 2.9702; // -log(-log(0.95) static const double temp2 = 1.7329; // 2.5 * log(2) nMinSpan = (int)((temp1 + log((double)(nPreds * nUsed))) / temp2); } nMinSpan = max(1, nMinSpan); // get nStartSpan const int nAvail = max(0, (const int)nCases - 2 * nEndSpan); nStartSpan = nAvail / 2; // if space for only one knot, put it in center if(nAvail > nMinSpan) { // space for more than one knot? const int nDiv = nAvail / nMinSpan; if(nAvail == nDiv * nMinSpan) nStartSpan = nMinSpan / 2; else nStartSpan = (nAvail - nDiv * nMinSpan) / 2; } // TODO consider moving the following line of code into the "}" above nStartSpan = max(1, nEndSpan + nStartSpan); } *pnStartSpan = nStartSpan; *pnMinSpan = nMinSpan; *pnEndSpan = nEndSpan; } //----------------------------------------------------------------------------- // The caller has selected a candidate predictor iPred and a candidate iParent. // This function now selects a knot. If it finds a knot it will // update *piBestCase and pRssDeltaForParPredPair. // // The general idea: scan backwards through all (ordered) values (i.e. potential // knots) for the given predictor iPred, calculating RssDelta. // If RssDelta > *pRssDeltaForParPredPair (and all else is ok), then // select the knot (by updating *piBestCase and *pRssDeltaForParPredPair). // // We want to add a term pair at index iNewCol and iNewCol+1. // There are currently nTerms in the model. // // This function must be fast. static INLINE void FindKnot( int* piBestCase, // out: possibly updated, row index in x double* pRssDeltaForParPredPair, // io: updated if knot is better double CovCol[], // scratch buffer, overwritten, nTerms x 1 double ycboSum[], // scratch buffer, overwritten, nMaxTerms x nResp double CovSx[], // scratch buffer, overwritten, nTerms x 1 double* ybxSum, // scratch buffer, overwritten, nResp x 1 const int iNewCol, // in: tentative knot goes into bx[iNewCol] const int iParent, // in: parent term const int iPred, // in: predictor index const size_t nCases, // in const int nResp, // in: number of cols in y const int nMaxTerms, // in const double RssDeltaLin, // in: change in RSS if predictor iPred enters linearly const double MaxLegalRssDelta, // in: FindKnot rejects any changes in Rss greater than this const double bx[], // in: MARS basis matrix const double bxOrth[], // in const double bxOrthCenteredT[], // in const double bxOrthMean[], // in const double x[], // in: nCases x nPreds const double y[], // in: nCases x nResp const int xOrder[], // in const double yMean[], // in: vector nResp x 1 const int nStartSpan, // in: number of cases from end until first knot const int nMinSpan, // in: number cases between knots const int nEndSpan, // in: number of cases ignored on each end const double NewVarAdjust, // in: 1 if not a new var, 1/(1+NewVarPenalty) if new var const double RssBeforeNewTerm) // in: used only when trace >= 8 { tprintf(8, "--FindKnotBegin-- iPred %d iNewCol %d RssBeforeAddingHinge %g " "nMinSpan %d nEndSpan %d nStartSpan %d\n", iPred+IOFFSET, iNewCol+IOFFSET, RssBeforeNewTerm, nMinSpan, nEndSpan, nStartSpan); ASSERT(MaxLegalRssDelta > 0); // Tol was .01 prior to earth 4.4.0 but that caused zigzag runout in test.weights.R. // The comparison against iNewCol provides some measure of back compatibility and // helps prevent overfitting in small models. The 15 is fairly arb but was chosen // to keep small models from having nearby knots, for the zizgag function in // test.weights.R, and for the spkmap neural data. // TODO This isn't a clean solution. const double Tol = iNewCol < 15? .01 : 1e-5; int iResp; for(iResp = 0; iResp < nResp; iResp++) ycboSum_(iNewCol, iResp) = 0; memset(CovCol, 0, (iNewCol+1) * sizeof(double)); memset(CovSx, 0, (iNewCol+1) * sizeof(double)); memset(ybxSum, 0, nResp * sizeof(double)); double bxSum = 0, bxSqSum = 0, bxSqxSum = 0, bxxSum = 0, st = 0; int iSpan = nStartSpan; for(int i = (const int)nCases-2; i >= nEndSpan; i--) { // -2 allows for ix1 // may Mars have mercy on the poor soul who enters here const int ix0 = xOrder_(i, iPred); // get the x's in descending order const double x0 = x_(ix0,iPred); // the knot (printed as Cut in trace prints) const int ix1 = xOrder_(i+1, iPred); const double x1 = x_(ix1, iPred); // case next to the cut const double bx1 = bx_(ix1, iParent); const double bxSq = sq(bx1); const double xDelta = x1 - x0; // will always be non negative if(USE_BLAS) { daxpy_(&iNewCol, &bx1, &bxOrthCenteredT_(0,ix1), &ONE, CovSx, &ONE); daxpy_(&iNewCol, &xDelta, CovSx, &ONE, CovCol, &ONE); } else for(int it = 0; it < iNewCol; it++) { CovSx[it] += (bxOrth_(ix1,it) - bxOrthMean[it]) * bx1; CovCol[it] += xDelta * CovSx[it]; } bxSum += bx1; bxSqSum += bxSq; bxxSum += bx1 * x1; bxSqxSum += bxSq * x1; const double su = st; st = bxxSum - bxSum * x0; CovCol[iNewCol] += xDelta * (2 * bxSqxSum - bxSqSum * (x0 + x1)) + (sq(su) - sq(st)) / nCases; if(nResp == 1) { // treat nResp==1 as a special case, for speed ybxSum[0] += (y_(ix1, 0) - yMean[0]) * bx1; ycboSum_(iNewCol, 0) += xDelta * ybxSum[0]; } else for(iResp = 0; iResp < nResp; iResp++) { ybxSum[iResp] += (y_(ix1, iResp) - yMean[iResp]) * bx1; ycboSum_(iNewCol, iResp) += xDelta * ybxSum[iResp]; } if(bx1 > 0 && CovCol[iNewCol] > 0 && --iSpan == 0) { iSpan = nMinSpan; double RssDelta = 0; bool Best = false, TolGood = true; // calculate RssDelta and see if this knot beats the previous best RssDelta = 0; double temp1, temp2; for(iResp = 0; iResp < nResp; iResp++) { if(USE_BLAS) { temp1 = ycboSum_(iNewCol,iResp) - ddot_(&iNewCol, &ycboSum_(0,iResp), &ONE, CovCol, &ONE); temp2 = CovCol[iNewCol] - ddot_(&iNewCol, CovCol, &ONE, CovCol, &ONE); } else { temp1 = ycboSum_(iNewCol,iResp); temp2 = CovCol[iNewCol]; for(int it = 0; it < iNewCol; it++) { temp1 -= ycboSum_(it,iResp) * CovCol[it]; temp2 -= sq(CovCol[it]); } } // TODO HastieTibs code has a comment saying the following has to be fixed if(temp2 / CovCol[iNewCol] > Tol) RssDelta += sq(temp1) / temp2; else TolGood = false; } RssDelta = NewVarAdjust * (RssDeltaLin + RssDelta); if(RssDelta > *pRssDeltaForParPredPair && RssDelta < MaxLegalRssDelta) { *piBestCase = i; *pRssDeltaForParPredPair = RssDelta; Best = true; } if(TraceGlobal >= 8) { const double RssWithKnot = RssBeforeNewTerm - RssDelta; printf("--FindKnot--Case %4d RssWithKnot %12.5g RssDelta %12.5g " "Cut % 12.5g ", i+IOFFSET, MaybeZero(RssWithKnot), MaybeZero(RssDelta), x0); // separate trace to make it easier to check compat // with FindWeightedKnot when trace==8 tprintf(9, "bx1G %d CovColG %d TolG %d MaxG %d ", bx1 > 0, CovCol[iNewCol] > 0, TolGood, RssDelta < MaxLegalRssDelta); printf("%s\n", Best? " best": ""); } } else if(TraceGlobal >= 9) printf("--FindKnot--Case %4d iSpan %d bx1 % 8.4f\n", i+IOFFSET, iSpan, bx1); } // for tprintf(8, "--FindKnotEnd--\n"); } //----------------------------------------------------------------------------- // Add a candidate term at bx[,nTerms], with the parent term multiplied by // the predictor iPred entering linearly. Do this by setting the knot at // the lowest value xMin of x, since max(0,x-xMin)==x-xMin for all x. The // change in RSS caused by adding this term forms the base RSS delta which // we will try to beat in the search in FindKnot. // // This also initializes CovCol, bxOrth[,nTerms], and ycboSum[nTerms,] static INLINE void AddCandidateLinearTerm( double* pRssDeltaLin, // out: change to RSS caused by adding new term bool* pIsNewForm, // out: true on entry, may be cleared by InitBxOrthCol double xbx[], // out: nCases x 1 double CovCol[], // out: nMaxTerms x 1 double ycboSum[], // io: nMaxTerms x nResp double bxOrth[], // io double bxOrthCenteredT[], // io double bxOrthMean[], // io const int iPred, // in const int iParent, // in const double x[], // in: nCases x nPreds const double y[], // in: nCases x nResp, scaled y const size_t nCases, // in const int nResp, // in: number of cols in y const int nTerms, // in const int nMaxTerms, // in const double bx[], // in: MARS basis matrix const bool FullSet[]) // in { // set xbx to x[,iPred] * bx[,iParent] // note: when iParent==1, bx_[,iParent] is all ones, therefore xbx is x int i; for(i = 0; i < (const int)nCases; i++) xbx[i] = x_(i,iPred) * bx_(i,iParent); // Init bxOrth[,nTerms] and bxOrthMean[nTerms] for the candidate term. // Clears both those columns, bxOrthMean, and *pIsNewForm if // column sum-of-squares is less than MIN_BX_SOS. InitBxOrthCol(bxOrth, bxOrthCenteredT, bxOrthMean, pIsNewForm, xbx, nTerms, FullSet, nCases, nMaxTerms, iParent, iPred); // init CovCol and ycboSum[nTerms], for use by FindKnot later memset(CovCol, 0, (nTerms-1) * sizeof(double)); CovCol[nTerms] = 1; int iResp; for(iResp = 0; iResp < nResp; iResp++) { ycboSum_(nTerms, iResp) = 0; for(i = 0; i < (const int)nCases; i++) ycboSum_(nTerms, iResp) += (y_(i, iResp) - yMean[iResp]) * bxOrth_(i,nTerms); } // calculate change to RSS caused by adding candidate new term *pRssDeltaLin = 0; for(iResp = 0; iResp < nResp; iResp++) { double yboSum = 0; for(i = 0; i < (const int)nCases; i++) yboSum += y_(i,iResp) * bxOrth_(i,nTerms); *pRssDeltaLin += sq(yboSum); } } //----------------------------------------------------------------------------- // The caller has selected a candidate parent term iParent. // This function now selects a predictor, and a knot for that predictor. // // TODO These functions have a ridiculous number of parameters, I know. // // TODO A note on the comparison against ALMOST_ZERO below: // It's not a clean solution but seems to work ok. // It was added after we saw different results on different // machines for certain datasets e.g. (tested on earth 1.4.0) // ldose <- rep(0:5, 2) - 2 // ldose1 <- c(0.1, 1.2, 2.3, 3.4, 4.5, 5.6, 0.3, 1.4, 2.5, 3.6, 4.7, 5.8) // sex3 <- factor(rep(c("male", "female", "andro"), times=c(6,4,2))) // fac3 <- factor(c("lev2", "lev2", "lev1", "lev1", "lev3", "lev3", // "lev2", "lev2", "lev1", "lev1", "lev3", "lev3")) // numdead <- c(1,4,9,13,18,20,0,2,6,10,12,16) // numdead2 <- c(2,3,10,13,19,20,0,3,7,11,13,17) // pair <- cbind(numdead, numdead2) // df <- data.frame(sex3, ldose, ldose1, fac3) // am <- earth(df, pair, trace=6, pmethod="none", degree=2) static INLINE void FindPredGivenParent( int* piBestCase, // out: untouched unless an improving term is found int* piBestPred, // out: ditto int* piBestParent, // out: existing term on which we are basing the new term double* pBestRssDeltaForTerm, // io: untouched unless an improving term is found double* pBestRssDeltaForParent, // io: used only by FAST_MARS bool* pIsNewForm, // out bool* pLinPredIsBest, // out: true if pred should enter linearly (no knot) double bxOrth[], // io double bxOrthCenteredT[], // io double bxOrthMean[], // io double xbx[], // io: nCases x 1 double CovSx[], // io: nMaxTerms x 1 double CovCol[], // io: nMaxTerms x 1 double ycboSum[], // io: nMaxTerms x nResp const double bx[], // in: MARS basis matrix const double yMean[], // in: vector nResp x 1 const double RssBeforeNewTerm, // in const double MaxLegalRssDelta, // in: FindKnot rejects any changes in Rss greater than this const int iParent, // in const double x[], // in: nCases x nPreds, unweighted x const double y[], // in: nCases x nResp, unweighted but scaled y const size_t nCases, // in const int nResp, // in: number of cols in y const int nPreds, // in const int nTerms, // in const int nMaxTerms, // in const bool FullSet[], // in const int xOrder[], // in: order of each column of x array const int nUses[], // in: nbr of times each pred is used in the model const int Dirs[], // in const double NewVarPenalty, // in: penalty for adding a new variable (default is 0) const int LinPreds[], // in: nPreds x 1, 1 if predictor must enter linearly const int nMinSpan, // in const int nEndSpan, // in const int nStartSpan) // in { ybxSum = (double*)malloc1(nResp * sizeof(double), // working var for FindKnot "ybxSum\t\tnResp %d sizeof(double) %d", nResp, sizeof(double)); bool UpdatedBestRssDelta = false; for(int iPred = 0; iPred < nPreds; iPred++) { tprintf(9, "\n"); if(Dirs_(iParent,iPred) != 0) { // predictor is in parent term? tprintf(7, "|Parent %-2d Pred %-2d %44.44s skip (pred is in parent)\n", iParent+IOFFSET, iPred+IOFFSET, " "); #if USING_R } else if(!IsAllowed(iPred, iParent, Dirs, nPreds, nMaxTerms)) { tprintf(7, "|Parent %-2d Pred %-2d %44.44s skip (not allowed by \"allowed\" func)\n", iParent+IOFFSET, iPred+IOFFSET, " "); #endif } else { // we apply the penalty if the variable is entering for the first time const double NewVarAdjust = 1 / (1 + (nUses[iPred] == 0? NewVarPenalty: 0)); double RssDeltaLin = 0; // change in RSS for iPred entering linearly double UnadjustedRssDeltaLin = 0; double RssBeforeKnot = RssBeforeNewTerm; bool IsNewForm = GetNewFormFlag(iPred, iParent, Dirs, FullSet, nTerms, nPreds, nMaxTerms); if(IsNewForm) { // Create a candidate term at bx[,nTerms], // with iParent and iPred entering linearly // This may clear IsNewForm. AddCandidateLinearTerm(&UnadjustedRssDeltaLin, &IsNewForm, xbx, CovCol, ycboSum, bxOrth, bxOrthCenteredT, bxOrthMean, iPred, iParent, x, y, nCases, nResp, nTerms, nMaxTerms, bx, FullSet); RssDeltaLin = NewVarAdjust * UnadjustedRssDeltaLin; tprintf(8, "\n|Parent %-2d Pred %-2d Case -1 Cut % 12.4g< Rss %-12.5g", iParent+IOFFSET, iPred+IOFFSET, GetCut(0, iPred, nCases, x, xOrder), MaybeZero(RssBeforeNewTerm - RssDeltaLin)); tprintf(9, " RssDeltaLin %-12.5g ", RssDeltaLin); if(fabs(RssDeltaLin - *pBestRssDeltaForTerm) < ALMOST_ZERO) { RssDeltaLin = *pBestRssDeltaForTerm; // see header note tprintf(7, "RssDelta %g is ALMOST_ZERO\n", RssDeltaLin - *pBestRssDeltaForTerm); } if(RssDeltaLin > *pBestRssDeltaForParent) *pBestRssDeltaForParent = RssDeltaLin; RssBeforeKnot -= RssDeltaLin; if(RssDeltaLin > *pBestRssDeltaForTerm) { // The new term (with predictor entering linearly) beats other // candidate terms so far. tprintf(9, "best for term (lin pred) "); UpdatedBestRssDelta = true; *pBestRssDeltaForTerm = RssDeltaLin; *pLinPredIsBest = true; *piBestCase = 0; // knot is at the lowest value of x *piBestPred = iPred; *piBestParent = iParent; } tprintf(8, "\n"); } else tprintf(8, "|Parent %-2d Pred %-2d no new form\n", iParent+IOFFSET, iPred+IOFFSET); double RssDeltaForParPredPair = RssDeltaLin; if(!LinPreds[iPred]) { int iBestCase = -1; FindKnot(&iBestCase, &RssDeltaForParPredPair, CovCol, ycboSum, CovSx, ybxSum, (IsNewForm? nTerms + 1: nTerms), iParent, iPred, nCases, nResp, nMaxTerms, UnadjustedRssDeltaLin, MaxLegalRssDelta, bx, bxOrth, bxOrthCenteredT, bxOrthMean, x, y, xOrder, yMean, nStartSpan, nMinSpan, nEndSpan, NewVarAdjust, RssBeforeNewTerm); // RssBeforeNewTerm is for tracing if(RssDeltaForParPredPair > *pBestRssDeltaForParent) *pBestRssDeltaForParent = RssDeltaForParPredPair; if(RssDeltaForParPredPair > *pBestRssDeltaForTerm) { UpdatedBestRssDelta = true; *pBestRssDeltaForTerm = RssDeltaForParPredPair; *pLinPredIsBest = false; *piBestCase = iBestCase; *piBestPred = iPred; *piBestParent = iParent; *pIsNewForm = IsNewForm; tprintf(7, "|Parent %-2d Pred %-2d Case %4d Cut % 12.4g Rss %-12.5g RssDelta %-12.5g%s\n", iParent+IOFFSET, iPred+IOFFSET, iBestCase+IOFFSET, GetCut(iBestCase, iPred, nCases, x, xOrder), MaybeZero(RssBeforeNewTerm - *pBestRssDeltaForTerm), MaybeZero(*pBestRssDeltaForTerm), RssDeltaForParPredPair > *pBestRssDeltaForTerm? " best for term": ""); } else tprintf(7, "|Parent %-2d Pred %-2d Case %4d Cut % 12.4g< Rss %-12.5g RssDelta %-12.5g\n", iParent+IOFFSET, iPred+IOFFSET, -1, GetCut(0, iPred, nCases, x, xOrder), MaybeZero(RssBeforeNewTerm - RssDeltaLin), 0.); } } // else } // for iPred free1(ybxSum); if(UpdatedBestRssDelta && NewVarPenalty != 0. && nUses[*piBestPred] == 0) { // we applied NewVarPenalty earlier, now un-apply it *pBestRssDeltaForTerm *= 1 + NewVarPenalty; } } //----------------------------------------------------------------------------- #if WEIGHTS // TODO This could be made faster by caching previous results? static INLINE void InitHinge( // return TRUE if column is not all zeros double bxCol[], // out: this column will be initialized const int iHinge, // in: hinge index (row in x) const double bxParentCol[], // in: column in bx for iParent const double xCol[], // in: column of x for iPred const int xOrderCol[], // in: column in xOrder for iPred const size_t nCases) // in { const double Cut = xCol[xOrderCol[iHinge]]; for(int i = (const int)nCases-1; i > iHinge; i--) { const int ix = xOrderCol[i]; bxCol[ix] = bxParentCol[ix] * (xCol[ix] - Cut); } } #endif //----------------------------------------------------------------------------- #if WEIGHTS static double GetRegressionRss( double x[], // io: nCases x nCols, gets overwritten const double y[], // in: nCases x nResp const size_t nCases, // in: number of rows in x and in y const int nResp, // in: number of cols in y int nCols, // in: number of columns in x double Residuals[], // in: nCases, working storage int iPivots[], // in: nCols, working storage double qraux[], // in: nCols, working storage double work[]) // in: max(nCols * 2, nCases), working storage { for(int iCol = 0; iCol < nCols; iCol++) iPivots[iCol] = iCol+1; int nCases1 = (const int)nCases; // type convert from size_t int nRank; dqrdc2_( // R function, QR decomp based on LINPACK dqrdc x, // io: x, on return upper tri of x is R of QR &nCases1, // in: ldx &nCases1, // in: n &nCols, // in: p (double*)&QR_TOL, // in: tol &nRank, // out: k, num of indep cols of x qraux, // out: qraux iPivots, // out: jpvt work); // work double Rss = 0; int job = 10; // specify 10 because all we need are the residuals int info; for(int iResp = 0; iResp < nResp; iResp++) { dqrsl_( // LINPACK function x, // in: x, generated by dqrdc2 &nCases1, // in: ldx &nCases1, // in: n &nRank, // in: k qraux, // in: qraux (double*)(y + iResp * nCases), // in: y NULL, // out: qy, unreferenced here work, // out: qty, unused here but needed for dqrsl NULL, // out: b, unreferenced here (double*)Residuals, // out: rsd NULL, // out: xb, unreferenced here &job, // in: job &info); // in: info ASSERT(info == 0); for(int i = 0; i < (const int)nCases; i++) Rss += sq(Residuals[i]); } return Rss; } #endif // WEIGHTS //----------------------------------------------------------------------------- #if WEIGHTS static INLINE void FindWeightedKnot( int* piBestCase, // out: updated, row index in x double* pRssBestKnot, // io: updated, on entry is LinRss if did lin pred const bool UsedCols[], // in int iNewCol, // in: tentative knot goes into bx[iNewCol] const int iParent, // in: parent term const int iPred, // in: predictor index const size_t nCases, // in const int nResp, // in: number of cols in yw double bx[], // in: MARS basis matrix, columns nTerm and nTerm+1 filled in const double x[], // in: nCases x nPreds, unweighted x matrix const double yw[], // in: nCases x nResp, weighted and scaled y matrix const int xOrder[], // in: order of each column of _unweighted_ x array const int nStartSpan, // in: number of cases from end until first knot const int nMinSpan, // in: number cases between knots const int nEndSpan, // in: number of cases ignored on each end const double RssBeforeNewTerm) // in: used only for tracing { tprintf(8, "--FindKnotBegin-- iPred %d iNewCol %d RssBeforeAddingHinge %g " "nMinSpan %d nEndSpan %d nStartSpan %d\n", iPred+IOFFSET, iNewCol+IOFFSET, RssBeforeNewTerm, nMinSpan, nEndSpan, nStartSpan); // we malloc everything for GetRegressionRss once here instead of in the loop double* bxUsed; const int nUsedCols = CopyUsedCols(&bxUsed, bx, nCases, iNewCol+1, UsedCols); double* bxTemp = (double*)malloc1(nCases * nUsedCols * sizeof(double), "bxTemp\t\tnCases %d nUsedCols %d sizeof(double) %d", (const int)nCases, nUsedCols, sizeof(double)); double* Residuals = (double*)malloc1(nCases * sizeof(double), "Residuals\t\tnCases %d sizeof(double) %d", (const int)nCases, sizeof(double)); int* iPivots = (int*)malloc1(nUsedCols * sizeof(int), "iPivots\t\tnUsedCols %d sizeof(int) %d", nUsedCols, sizeof(int)); double* qraux = (double*)malloc1(nUsedCols * sizeof(double), "qraux\t\t\tnUsedCols %d sizeof(double) %d", nUsedCols, sizeof(double)); // in GetRegressionRss, work must be p*2 for dqrdc2, and // nCases in dqrsl where it is used as temporary storage for qty double* work = (double*)malloc1( max(nUsedCols * 2, (const int)nCases) * sizeof(double), "work\t\t\tnCases %d sizeof(double) %d", (const int)nCases, sizeof(double)); // zero the current column of bxUsed, we will fill it in with the hinge functions memset(&bxUsed_(0,iNewCol), 0, nCases * sizeof(double)); // for-loop indices and trace prints are compatible with FindKnot (when trace<=8) int iSpan = nStartSpan; for(int i = (const int)nCases-2; i >= nEndSpan; i--) { // TODO This should be bx0 (not bx1)? But for compat with FindKnot we use bx1. // In test.mods.R, using bx1 or bx0 here give almost identical results. const int ix1 = xOrder_(i+1, iPred); const double bx1 = bx_(ix1,iParent); if(bx1 > 0 && --iSpan == 0) { iSpan = nMinSpan; bool Best = false; InitHinge(&bxUsed_(0, iNewCol), // init this column of bxUsed i, &bx_(0, iParent), &x_(0, iPred), &xOrder_(0, iPred), nCases); // bxTemp is needed because GetRegressionRss destroys its first arg memcpy(bxTemp, bxUsed, nCases * nUsedCols * sizeof(double)); const double KnotRss = GetRegressionRss(bxTemp, yw, nCases, nResp, nUsedCols, Residuals, iPivots, qraux, work); // using ALMOST_ZERO here gives results closer to FindKnot if(KnotRss < *pRssBestKnot - ALMOST_ZERO) { *piBestCase = i; *pRssBestKnot = KnotRss; Best = true; } if(TraceGlobal >= 8) { const double RssDelta = RssBeforeNewTerm - KnotRss; printf( "--FindKnot--Case %4d RssWithKnot %12.5g RssDelta %12.5g Cut % 12.5g%s\n", i+IOFFSET, MaybeZero(KnotRss), MaybeZero(RssDelta), GetCut(i, iPred, nCases, x, xOrder), Best? " best": ""); } } else if(TraceGlobal >= 9) printf("--FindKnot--Case %4d iSpan %d bx1 % 8.4f\n", i+IOFFSET, iSpan, bx1); } free1(work); free1(qraux); free1(iPivots); free1(Residuals); free1(bxTemp); free1(bxUsed); tprintf(8, "--FindKnotEnd--\n"); } #endif // WEIGHTS //----------------------------------------------------------------------------- #if WEIGHTS static INLINE void FindWeightedPredGivenParent( int* piBestCase, // out: untouched unless an improving term is found int* piBestPred, // out: ditto int* piBestParent, // out: existing term on which we are basing the new term double* pBestRssDeltaForTerm, // io: untouched unless an improving term is found double* pBestRssDeltaForParent, // io: used only by FAST_MARS bool* pIsNewForm, // out bool* pLinPredIsBest, // out: true if pred should enter linearly (no knot) double bx[], // in: MARS basis matrix const double RssBeforeNewTerm, // in const int iParent, // in const double x[], // in: nCases x nPreds, unweighted x const double yw[], // in: nCases x nResp, weighted and scaled y const size_t nCases, // in const int nResp, // in: number of cols in y const int nPreds, // in const int nTerms, // in const int nMaxTerms, // in const bool FullSet[], // in const int xOrder[], // in: order of each column of _unweighted_ x array const int nUses[], // in: nbr of times each pred is used in the model const int Dirs[], // in const double NewVarPenalty, // in: penalty for adding a new variable (default is 0) const int LinPreds[], // in: nPreds x 1, 1 if predictor must enter linearly const int nMinSpan, // in const int nEndSpan, // in const int nStartSpan) // in { if(NewVarPenalty != 0) // NewVarPenalty is not yet fully tested when weights are used error("newvar.penalty is not yet implemented with weights"); bool UpdatedBestRssDelta = false; UsedCols = (bool*)calloc1(nMaxTerms, sizeof(bool), "UsedCols\t\tnMaxTerms %d sizeof(bool) %d", nMaxTerms, sizeof(bool)); for(int iTerm = 0; iTerm < nTerms; iTerm++) UsedCols[iTerm] = true; for(int iPred = 0; iPred < nPreds; iPred++) { tprintf(8, "\n"); if(Dirs_(iParent,iPred) != 0) { // predictor is in parent term? tprintf(7, "|Parent %-2d Pred %-2d %44.44s skip (pred is in parent)\n", iParent+IOFFSET, iPred+IOFFSET, " "); #if USING_R } else if(!IsAllowed(iPred, iParent, Dirs, nPreds, nMaxTerms)) { tprintf(7, "|Parent %-2d Pred %-2d %44.44s skip (not allowed by \"allowed\" func)\n", iParent+IOFFSET, iPred+IOFFSET, " "); #endif } else { #if USING_R ServiceR(); #endif // const double NewVarAdjust = 1 + (nUses[iPred] == 0? NewVarPenalty: 0); bool IsNewForm = GetNewFormFlag(iPred, iParent, Dirs, FullSet, nTerms, nPreds, nMaxTerms); ASSERT(nTerms+1 < nMaxTerms); UsedCols[nTerms] = UsedCols[nTerms+1] = false; double RssBeforeKnot = RssBeforeNewTerm; const int iNewCol = IsNewForm? nTerms+1: nTerms; if(IsNewForm) { // Add the new predictor as a linear term in bx[,nTerms]. // This updates RssBeforeKnot, which we will // try to beat in FindWeightedKnot. // Note that unlike FindPredGivenParent we never clear IsNewForm // here (that will be done later if necessary in AddTermPair). for(int i = 0; i < (const int)nCases; i++) bx_(i, nTerms) = bx_(i, iParent) * x_(i, iPred); UsedCols[nTerms] = true; Regress(NULL, NULL, &RssBeforeKnot, NULL, NULL, NULL, bx, yw, nCases, nResp, nMaxTerms, UsedCols); tprintf(8, "|Parent %-2d Pred %-2d Case -1 Cut % 12.4g< Rss %-12.5g\n", iParent+IOFFSET, iPred+IOFFSET, GetCut(0, iPred, nCases, x, xOrder), MaybeZero(RssBeforeKnot)); } else { tprintf(8, "\n|Parent %-2d Pred %-2d no new form\n", iParent+IOFFSET, iPred+IOFFSET); #if 0 // removed this slowish check for earth 5.1.0 (gives about 4% speed increase) Regress(NULL, NULL, &RssBeforeKnot, NULL, NULL, NULL, bx, yw, nCases, nResp, nMaxTerms, UsedCols); if(fabs(RssBeforeKnot - RssBeforeNewTerm) > RssBeforeKnot * 1e-6) error( "fabs(RssBeforeKnot %g - RssBeforeNewTerm %g) %g > %g", RssBeforeKnot, RssBeforeNewTerm, fabs(RssBeforeKnot - RssBeforeNewTerm), RssBeforeKnot * 1e-6); #endif } double RssBestKnot = RssBeforeKnot; int iBestCase = 0; if(!LinPreds[iPred]) { #if 0 // removed this slowish check for earth 5.1.0 double RssTemp; Regress(NULL, NULL, &RssTemp, NULL, NULL, NULL, bx, yw, nCases, nResp, nMaxTerms, UsedCols); if(fabs(RssTemp - RssBeforeKnot) > RssBeforeKnot * 1e-6) error("fabs(RssTemp - RssBeforeKnot) > %g", RssTemp, RssBeforeKnot, fabs(RssTemp - RssBeforeKnot), RssBeforeKnot * 1e-6); #endif ASSERT(iNewCol > 0 && iNewCol < nMaxTerms); UsedCols[iNewCol] = true; FindWeightedKnot(&iBestCase, &RssBestKnot, UsedCols, iNewCol, iParent, iPred, nCases, nResp, bx, x, yw, xOrder, nStartSpan, nMinSpan, nEndSpan, RssBeforeNewTerm); } // TODO must use NewVarAdjust here? const bool LinPredIsBest = RssBeforeKnot <= RssBestKnot; const double Rss = (LinPredIsBest? RssBeforeKnot: RssBestKnot); double RssDeltaForTerm = RssBeforeNewTerm - Rss; if(RssDeltaForTerm > *pBestRssDeltaForParent) *pBestRssDeltaForParent = RssDeltaForTerm; if(RssDeltaForTerm > *pBestRssDeltaForTerm) { UpdatedBestRssDelta = true; *pBestRssDeltaForTerm = RssDeltaForTerm; *pLinPredIsBest = LinPredIsBest; *piBestCase = iBestCase; *piBestPred = iPred; *piBestParent = iParent; *pIsNewForm = IsNewForm; tprintf(7, "|Parent %-2d Pred %-2d Case %4d Cut % 12.4g Rss %-12.5g RssDelta %-12.5g%s\n", iParent+IOFFSET, iPred+IOFFSET, iBestCase+IOFFSET, GetCut(iBestCase, iPred, nCases, x, xOrder), MaybeZero(Rss), MaybeZero(*pBestRssDeltaForTerm), RssDeltaForTerm > *pBestRssDeltaForTerm? " best for term": ""); } else tprintf(7, "|Parent %-2d Pred %-2d Case %4d Cut % 12.4g Rss %-12.5g RssDelta %-12.5g\n", iParent+IOFFSET, iPred+IOFFSET, -1, GetCut(0, iPred, nCases, x, xOrder), MaybeZero(Rss), MaybeZero(RssBeforeKnot)); } } // for iPred if(UpdatedBestRssDelta && nUses[*piBestPred] == 0) { // de-adjust for NewVarPenalty (only makes a difference if NewVarPenalty != 0) const double NewVarAdjust = 1 + NewVarPenalty; *pBestRssDeltaForTerm *= NewVarAdjust; } free1(UsedCols); } #endif // WEIGHTS //----------------------------------------------------------------------------- // Find a new term to add to the model, if possible, and return the // selected case (i.e. knot), predictor, and parent term indices. // // The new term is a copy of an existing parent term but extended // by multiplying the parent by a new hinge function at the selected knot. // // Actually, this usually finds a term _pair_, with left and right hinges. // // There are currently nTerms in the model. We want to add a term at index nTerms. static void FindTerm( int* piBestCase, // out: return -1 if no new term available, else row index int* piBestPred, // out: int* piBestParent, // out double* pBestRssDeltaForTerm, // out: adding new term reduces RSS this much // will be set to 0 if no possible new term bool* pIsNewForm, // out bool* pLinPredIsBest, // out: true if pred should enter linearly (no knot) double bxOrth[], // io: column nTerms overwritten double bxOrthCenteredT[], // io: kept in sync with bxOrth double bxOrthMean[], // io: element nTerms overwritten #if WEIGHTS double bx[], // io: cols at nTerms and nTerms+1 used as scratch, will be set to 0 #else const double bx[], // in: MARS basis matrix #endif const double x[], // in: nCases x nPreds, unweighted x const double y[], // in: nCases x nResp, unweighted but scaled y const double yw[], // in: nCases x nResp, weighted and scaled y, can be NULL const size_t nCases, // in: const int nResp, // in: number of cols in y const int nPreds, // in: const int nMaxDegree, // in: const int nTerms, // in: const int nMaxTerms, // in: const double yMean[], // in: vector nResp x 1 const double RssBeforeNewTerm, // in const double MaxLegalRssDelta, // in: FindKnot rejects any changes in Rss greater than this const bool FullSet[], // in: const int xOrder[], // in: const int nDegree[], // in: degree of each term, degree of intercept is 0 const int nUses[], // in: nbr of times each predictor is used in the model const int Dirs[], // in: const int nFastK, // in: Fast MARS K const double NewVarPenalty, // in: penalty for adding a new variable (default is 0) const int LinPreds[]) // in: nPreds x 1, 1 if predictor must enter linearly { #if !FAST_MARS // prevent compiler warning: unused parameter int Dummy = nFastK; ASSERT(Dummy != -999); #endif #if !WEIGHTS // prevent compiler warning: unused parameter double Dummy1 = RssBeforeNewTerm; ASSERT(Dummy1 != -999); #endif tprintf(7, "\n----------------------------------------------------------" "-------------------"); tprintf(7, "\n|FindTerm: Searching for new term %-3d " "RssDelta 0 MaxLegalRssDelta %g\n", nTerms+IOFFSET, MaxLegalRssDelta); *piBestCase = -1; *pBestRssDeltaForTerm = 0; *pLinPredIsBest = false; *pIsNewForm = false; int i; xbx = (double*)malloc1(nCases * sizeof(double), "xbx\t\t\tnCases %d sizeof(double) %d", (const int)nCases, sizeof(double)); CovSx = (double*)malloc1(nMaxTerms * sizeof(double), "CovSx\t\t\tnMaxTerms %d sizeof(double) %d", nMaxTerms, sizeof(double)); CovCol = (double*)calloc1(nMaxTerms, sizeof(double), "CovCol\t\tnMaxTerms %d sizeof(double) %d", nMaxTerms, sizeof(double)); ycboSum = (double*)calloc1(nMaxTerms * nResp, sizeof(double), "ycboSum\t\tnMaxTerms %d nResp %d sizeof(double) %d", nMaxTerms, nResp, sizeof(double)); for(int iResp = 0; iResp < nResp; iResp++) for(int iTerm = 0; iTerm < nTerms; iTerm++) for(i = 0; i < (const int)nCases; i++) ycboSum_(iTerm,iResp) += (y_(i,iResp) - yMean[iResp]) * bxOrth_(i,iTerm); #if USING_R const int nServiceR = (int)1e6 / nCases; #endif int iParent; #if FAST_MARS GetNextParent(true, nFastK); // init queue iterator while((iParent = GetNextParent(false, nFastK)) > -1) { #else for(iParent = 0; iParent < nTerms; iParent++) { #endif #if USING_R static int iServiceR = 0; if(++iServiceR > nServiceR) { ServiceR(); iServiceR = 0; } #endif // Assume a bad RssDelta for iParent. This pushes parent terms that // can't be used to the bottom of the FastMARS queue. (A parent can't // be used if its degree is too big or all predictors are in the parent.) double BestRssDeltaForParent = -1; // used only by FAST_MARS if(nDegree[iParent] >= nMaxDegree) tprintf(7, "|Parent %-2d %52.52s skip (degree of term would be %d)\n", iParent+IOFFSET, " ", nDegree[iParent]+1); else { int nMinSpan, nEndSpan, nStartSpan; GetSpanParams(&nMinSpan, &nEndSpan, &nStartSpan, nCases, nPreds, nDegree[iParent]+1, iParent, bx); #if WEIGHTS if(yw) FindWeightedPredGivenParent( piBestCase, piBestPred, piBestParent, pBestRssDeltaForTerm, &BestRssDeltaForParent, pIsNewForm, pLinPredIsBest, bx, RssBeforeNewTerm, iParent, x, yw, nCases, nResp, nPreds, nTerms, nMaxTerms, FullSet, xOrder, nUses, Dirs, NewVarPenalty, LinPreds, nMinSpan, nEndSpan, nStartSpan); else #endif FindPredGivenParent( piBestCase, piBestPred, piBestParent, pBestRssDeltaForTerm, &BestRssDeltaForParent, pIsNewForm, pLinPredIsBest, bxOrth, bxOrthCenteredT, bxOrthMean, xbx, CovSx, CovCol, ycboSum, bx, yMean, RssBeforeNewTerm, MaxLegalRssDelta, iParent, x, y, nCases, nResp, nPreds, nTerms, nMaxTerms, FullSet, xOrder, nUses, Dirs, NewVarPenalty, LinPreds, nMinSpan, nEndSpan, nStartSpan); #if FAST_MARS UpdateRssDeltaInQ(iParent, nTerms, BestRssDeltaForParent); #endif } } // iParent tprintf(7, "\n"); // free in opposite order to alloc to help operating system memory manager free1(ycboSum); free1(CovCol); free1(CovSx); free1(xbx); } //----------------------------------------------------------------------------- static void PrintForwardProlog( const size_t nCases, // in const int nPreds, // in const int nMaxTerms, // in const char* sPredNames[], // in: predictor names, can be NULL const bool HasWeights) // in { if(TraceGlobal == 1) printf("Forward pass term %d", IOFFSET); else if(TraceGlobal == 1.5) printf("Forward pass term %d\n", IOFFSET); else if(TraceGlobal >= 2) { int nMinSpan, nEndSpan, nStartSpan; GetSpanParams(&nMinSpan, &nEndSpan, &nStartSpan, nCases, nPreds, 1 /*nDegree*/, 0 /*iParent*/, NULL /*bx*/); char sx[100]; strcpy(sx, sFormatMemSize(nCases * nPreds * sizeof(double), false)); char sbx[100]; strcpy(sbx, sFormatMemSize(nCases * nMaxTerms * sizeof(double), false)); printf("Forward pass: minspan %d endspan %d x[%d,%d] %s bx[%d,%d] %s%s\n\n", nMinSpan, nEndSpan, (int)nCases, nPreds, sx, (int)nCases, nMaxTerms, sbx, HasWeights? " weighted": ""); printf(" GRSq RSq DeltaRSq Pred "); if(sPredNames) printf(" PredName "); printf(" Cut Terms Par Deg\n"); // following matches printfs in PrintForwardStep if(sPredNames) // in: predictor names, can be NULL printf("%-4d%9.4f %6.4f %12.12s\n", IOFFSET, 0., 0., "(Intercept)"); else printf("%-4d%9.4f %6.4f %d\n", IOFFSET, 0., 0., IOFFSET); } } //----------------------------------------------------------------------------- static void PrintForwardStep( const int nTerms, const int nUsedTerms, const int iBestCase, const int iBestPred, const int iBestParent, const int nDegree, const double RSq, const double RSqDelta, const double Gcv, const double GcvNull, const size_t nCases, const int xOrder[], const double x[], const bool IsTermPair, const char* sPredNames[]) // in: predictor names, can be NULL { if(TraceGlobal == 6) printf("\n\n"); if(TraceGlobal == 1) { printf(", "); if(nTerms % 30 == 29) printf("\n "); printf("%d", nTerms+IOFFSET); } else if(TraceGlobal == 1.5) printf("Forward pass term %d\n", nTerms+IOFFSET); else if(TraceGlobal >= 2) { tprintf(7, " GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg\n"); printf("%-4d%9.4f %6.4f %12.4g ", nTerms+IOFFSET, 1 - Gcv / GcvNull, RSq, RSqDelta); if(iBestPred < 0) // *piBestCase not updated in FindKnot (no DeltaRSq) printf(" - "); else { printf("%4d", iBestPred+IOFFSET); if(sPredNames) { if(sPredNames[iBestPred] && sPredNames[iBestPred][0]) printf(" %12.12s ", sPredNames[iBestPred]); else printf(" %12.12s ", " "); } if(iBestCase == -1) printf(" none "); else printf("% 11.5g%c ", GetCut(iBestCase, iBestPred, nCases, x, xOrder), (iBestCase==0? '<': ' ')); // print '<' if knot is at min if(IsTermPair) // two new used terms? printf("%-3d %-3d ", nUsedTerms-2+IOFFSET, nUsedTerms-1+IOFFSET); else printf("%-3d ", nUsedTerms-1+IOFFSET); if(iBestParent != 0) // print parent if it isn't the intercept tprintf(2, "%3d ", iBestParent+IOFFSET); else tprintf(2, " ", iBestParent+IOFFSET); printf("%3d ", nDegree); } } #if !USING_R // no flush needed when using R_printf if(TraceGlobal != 0) fflush(stdout); #endif } //----------------------------------------------------------------------------- static int ForwardEpilog( // returns reason we stopped adding terms const int nTerms, const int nMaxTerms, const double Thresh, const double RSq, const double RSqDelta, const double Gcv, const double GcvNull, const int iBestCase, const bool FullSet[]) { tprintf(7, "\n-----------------------------------------------------------------------------\n"); const double GRSq = 1 - Gcv / GcvNull; int iTermCond = 0; char sUsed[100] = ""; const int nUsed = GetNbrUsedCols(FullSet, nMaxTerms); if(nUsed != nTerms) sprintf(sUsed, ", %d term%s used", nUsed, nUsed == 1? "": "s"); char sTerms[200]; // May 2018: changed 100 to 200 for specious CRAN warning: '%s' directive writing up to 99 bytes into a region of size between 84 and 94 [-Wformat-overflow=] sprintf(sTerms, "%d term%s%s", nTerms, nTerms == 1? "": "s", sUsed); // NOTE 1: this code must match the loop termination conditions in ForwardPass // NOTE 2: if you update this, also update print.termcond in the R code // treat very low nMaxTerms as a special case // because RSDelta etc. not yet completely initialized if(nMaxTerms < 3) { iTermCond = 1; tprintf(1, "\nReached maximum number of terms %d\n", nMaxTerms); } else if(Thresh != 0 && GRSq < MIN_GRSQ) { if(GRSq < -1000) { iTermCond = 2; tprintf(1, "\nGRSq -Inf at %s\n", sTerms); } else { iTermCond = 3; if(TraceGlobal >= 1) printf("\nReached minimum GRSq %g at %s (GRSq %.2g)\n", MIN_GRSQ, sTerms, GRSq); } } else if(Thresh != 0 && RSqDelta < Thresh) { iTermCond = 4; if(TraceGlobal >= 1) printf("\nRSq changed by less than %g at %s (DeltaRSq %.2g)\n", Thresh, sTerms, RSqDelta); } else if(RSq >= 1-Thresh) { iTermCond = 5; if(TraceGlobal >= 1) printf("\nReached maximum RSq %.4f at %s (RSq %.4f)\n", 1-Thresh, sTerms, RSq); } else if(iBestCase < 0) { // TODO seems fishy, happens with linpreds so should give appropriate msg? iTermCond = 6; tprintf(1, "\nNo new term increases RSq (perhaps reached numerical limits) at %s\n", sTerms); } else { iTermCond = 7; #if USING_R tprintf(1, "\nReached nk %d\n", nMaxTerms); #else tprintf(1, "\nReached maximum number of terms %d\n", nMaxTerms); #endif } if(TraceGlobal >= 1) printf("After forward pass GRSq %.3f RSq %.3f\n", GRSq, RSq); tprintf(2, "Forward pass complete: %s\n", sTerms); tprintf(3, "\n"); return iTermCond; } //----------------------------------------------------------------------------- static void CheckVec( // check for NAs, NaNs, and infinite values in vector x const double x[], const size_t nCases, const int nCols, const char sVecName[]) { int iCol, i; for(iCol = 0; iCol < nCols; iCol++) for(i = 0; i < (const int)nCases; i++) { #if USING_R if(ISNA(x[i + iCol * nCases])) { if(nCols > 1) error("%s[%d,%d] is NA", sVecName, i+IOFFSET, iCol+IOFFSET); else error("%s[%d] is NA", sVecName, i+IOFFSET); } #endif if(ISNAN(x[i + iCol * nCases])) { if(nCols > 1) error("%s[%d,%d] is NaN", sVecName, i+IOFFSET, iCol+IOFFSET); else error("%s[%d] is NaN", sVecName, i+IOFFSET); } if(!FINITE(x[i + iCol * nCases])) { if(nCols > 1) error("%s[%d,%d] is not finite", sVecName, i+IOFFSET, iCol+IOFFSET); else error("%s[%d] is not finite", sVecName, i+IOFFSET); } } } //----------------------------------------------------------------------------- static double CheckRssNull( double RssNull, const double y[], const int iResp, const int nResp, const size_t nCases) { if(RssNull < 1e-8 * nCases) { // 1e-8 is arbitrary if(nResp) tprintf(1, "Variance of y[,%d] is zero (values are all equal to %g)\n", iResp+IOFFSET, y_(0,iResp)); else tprintf(1, "Variance of y is zero (values are all equal to %g)\n", y_(0,iResp)); RssNull = 1e-8 * nCases; // prevent later divide by zero } return RssNull; } //----------------------------------------------------------------------------- static double GetRssNull( const double y[], // in: nCases x nResp, unweighted but scaled y const double WeightsArg[], // in: nCases x 1, can be NULL const size_t nCases, // in: number of rows in x and elements in y const int nResp) // in: number of cols in y { double RssNull = 0; if(WeightsArg) for(int iResp = 0; iResp < nResp; iResp++) { double SumY = 0, SumWeights = 0; int i; for(i = 0; i < (const int)nCases; i++) { SumY += WeightsArg[i] * y_(i,iResp); SumWeights += WeightsArg[i]; } const double WeightedMean = SumY / SumWeights; for(i = 0; i < (const int)nCases; i++) { RssNull += WeightsArg[i] * sq(y_(i,iResp) - WeightedMean); } RssNull = CheckRssNull(RssNull, y, iResp, nResp, nCases); } else // no weights for(int iResp = 0; iResp < nResp; iResp++) { const double yMean = Mean(&y_(0,iResp), nCases); RssNull += SumOfSquares(&y_(0,iResp), yMean, nCases); RssNull = CheckRssNull(RssNull, y, iResp, nResp, nCases); } return RssNull; } //----------------------------------------------------------------------------- // The limits below are somewhat arbitrary and generous. They are intended to // catch gross errors on the part of the caller, and to prevent crashes because // of 0 sizes etc. We use error rather than ASSERT because these are user // settable params and we want to be informative from the user's perspective. // The errors are reported using the variable names in the R code. static void CheckForwardPassArgs( const double x[], const double y[], const double yw[], const double WeightsArg[], const size_t nCases, const int nResp, const int nPreds, const int nMaxDegree, const int nMaxTerms, const double Penalty, const double Thresh, const double FastBeta, const double NewVarPenalty, const int LinPreds[], const double AdjustEndSpan, const bool AutoLinPreds, const bool UseBetaCache) { const int nCases1 = (const int)nCases; // type convert from size_t if(nCases1 < 2) error("the x matrix must have at least two rows"); if(nCases1 > 1e9) // arbitrary error("too many rows %d in the input matrix, max allowed is 1e9", nCases1); if(nResp < 1) error("the number of responses %d is less than 1", nResp); if(nResp > 1000) error("the number of responses %d is greater than 1000", nResp); if(nPreds < 1) error("the number of predictors %d is less than 1", nPreds); if(nPreds > 1e5) error("the number of predictors %d is greater than 1e5", nPreds); if(nMaxDegree <= 0) error("degree %d is not greater than 0", nMaxDegree); if(nMaxDegree > MAX_DEGREE) error("degree %d is greater than %d", nMaxDegree, MAX_DEGREE); if(nMaxTerms < 1) // prevent internal misbehavior error("nk %d is less than 1", nMaxTerms); if(nMaxTerms > 1000) error("nk %d is greater than 1000", nMaxTerms); if(Penalty < 0 && Penalty != -1) error("penalty %g is less than 0 and the only legal value less than 0 is -1 " "(meaning terms and knots are free)", Penalty); if(Penalty > 1000) error("penalty %g is greater than 1000", Penalty); if(Thresh < 0) error("thresh %g is less than 0", Thresh); if(Thresh >= 1) error("thresh %g >= 1", Thresh); if(nMinSpanGlobal > nCases1) error("minspan %d is greater than the number of cases %d", nMinSpanGlobal, nCases1); if(nEndSpanGlobal > nCases1) error("endspan %d is greater than the number of cases %d", nEndSpanGlobal, nCases1); else if(nEndSpanGlobal < 0) error("endspan %d is less than 0", nEndSpanGlobal); if(FastBeta < 0) error("fast.beta %g is less than 0", FastBeta); if(FastBeta > 1000) error("fast.beta %g is greater than 1000", FastBeta); if(TraceGlobal < 0) warning("trace %g is less than 0", TraceGlobal); if(TraceGlobal > 10) warning("trace %g is greater than 10", TraceGlobal); if(NewVarPenalty < 0) warning("newvar.penalty %g is less than 0", NewVarPenalty); if(NewVarPenalty > 100) warning("newvar.penalty %g is greater than 100", NewVarPenalty); if(AdjustEndSpan < 0 || AdjustEndSpan > 10) error("Adjust.endspan is %g but should be between 0 and 10", AdjustEndSpan); if(AutoLinPreds != 0 && AutoLinPreds != 1) error("Auto.linpreds is neither TRUE nor FALSE"); if(UseBetaCache != 0 && UseBetaCache != 1) warning("Use.Beta.Cache is neither TRUE nor FALSE"); CheckVec(x, nCases, nPreds, "x"); CheckVec(y, nCases, nResp, "y"); #if WEIGHTS if(yw) { ASSERT(WeightsArg); CheckVec(yw, nCases, nResp, "yw"); for(int i = 0; i < (const int)nCases; i++) { CheckVec(WeightsArg, nCases, 1, "weights"); if(WeightsArg[i] < ALMOST_ZERO) error("weights[%d] is not greater than zero", i+IOFFSET); } } #else ASSERT(!yw); ASSERT(!WeightsArg || abs(WeightsArg[0] - WeightsArg[1]) < 1e-8); #endif for(int iPred = 0; iPred < nPreds; iPred++) if(LinPreds[iPred] != 0 && LinPreds[iPred] != 1) error("linpreds[%d] is not 0 or 1", iPred+IOFFSET); } //----------------------------------------------------------------------------- // Forward pass // // After initializing the intercept term, the main for loop adds terms in pairs. // In the for loop, nTerms is the index of the potential new term; nTerms+1 // the index of its partner. // The upper term in the term pair may not be useable. If so we still // increment nTerms by 2 but don't set the flag in FullSet. static void ForwardPass( int* pnTerms, // out: highest used term number in full model int* piTermCond, // out: reason we terminated the forward pass bool FullSet[], // out: 1 * nMaxTerms, indices of lin indep cols of bx double bx[], // out: MARS basis matrix, nCases * nMaxTerms int Dirs[], // out: nMaxTerms * nPreds, -1,0,1,2 for iTerm, iPred double Cuts[], // out: nMaxTerms * nPreds, cut for iTerm, iPred int nDegree[], // out: degree of each term, degree of intercept is 0 int nUses[], // out: nbr of times each predictor is used in the model const double x[], // in: nCases x nPreds, unweighted x const double y[], // in: nCases x nResp, unweighted but scaled y const double yw[], // in: nCases x nResp, weighted and scaled y, can be NULL const double WeightsArg[], // in: nCases x 1, can be NULL const size_t nCases, // in: number of rows in x and elements in y const int nResp, // in: number of cols in y const int nPreds, // in: const int nMaxDegree, // in: const int nMaxTerms, // in: const double Penalty, // in: GCV penalty per knot const double Thresh, // in: forward step threshold int nFastK, // in: Fast MARS K const double FastBeta, // in: Fast MARS ageing coef const double NewVarPenalty, // in: penalty for adding a new variable (default is 0) const int LinPreds[], // in: nPreds x 1, 1 if predictor must enter linearly const double AdjustEndSpan, // in: const bool AutoLinPreds, // in: assume predictor linear if knot is min predictor value const bool UseBetaCache, // in: true to use the beta cache, for speed const char* sPredNames[]) // in: predictor names, can be NULL { tprintf(5, "earth.c %s\n", VERSION); CheckForwardPassArgs(x, y, yw, WeightsArg, nCases, nResp, nPreds, nMaxDegree, nMaxTerms, Penalty, Thresh, FastBeta, NewVarPenalty, LinPreds, AdjustEndSpan, AutoLinPreds, UseBetaCache); if(nFastK <= 0) nFastK = 10000+1; // bigger than any nMaxTerms if(nFastK < 3) // avoid possible queue boundary conditions nFastK = 3; xOrder = GetArrayOrder(x, nCases, nPreds); InitBetaCache(UseBetaCache, nMaxTerms, nPreds); bxOrth = (double*)malloc1(nCases * nMaxTerms * sizeof(double), "bxOrth\t\tnCases %d nMaxTerms %d sizeof(double) %d", (const int)nCases, nMaxTerms, sizeof(double)); bxOrthCenteredT = (double*)malloc1(nMaxTerms * nCases * sizeof(double), "bxOrthCenteredT\tnMaxTerms %d nCases %d sizeof(double) %d", nMaxTerms, (const int)nCases, sizeof(double)); bxOrthMean = (double*)malloc1(nMaxTerms * nResp * sizeof(double), "bxOrthMean\t\tnMaxTerms %d nResp %d sizeof(double) %d", nMaxTerms, nResp, sizeof(double)); yMean = (double*)malloc1(nResp * sizeof(double), "yMean\t\t\tnResp %d sizeof(double) %d", nResp, sizeof(double)); memset(FullSet, 0, nMaxTerms * sizeof(bool)); memset(Dirs, 0, nMaxTerms * nPreds * sizeof(int)); memset(Cuts, 0, nMaxTerms * nPreds * sizeof(double)); memset(nDegree, 0, nMaxTerms * sizeof(int)); memset(nUses, 0, nPreds * sizeof(int)); memset(bx, 0, nCases * nMaxTerms * sizeof(double)); // Intercept columns of bx and bxOrth. // Note that we use the weights here, and since every term is a multiple // of this intercept term or a term derived from it, we don't need to use // the weighted x when forming bx. if(WeightsArg) for(int i = 0; i < (const int)nCases; i++) bx_(i,0) = sqrt(WeightsArg[i]); else for(int i = 0; i < (const int)nCases; i++) bx_(i,0) = 1; bool GoodCol; InitBxOrthCol(bxOrth, bxOrthCenteredT, bxOrthMean, &GoodCol, &bx_(0,0), 0 /*nTerms*/, FullSet, nCases, nMaxTerms, -1, -1); if(!GoodCol) // should never happen tprintf(1, "GoodCol is false in ForwardPass\n"); GoodCol = true; FullSet[0] = true; // intercept for(int iResp = 0; iResp < nResp; iResp++) yMean[iResp] = Mean(&y_(0,iResp), nCases); const double RssNull = GetRssNull(y, WeightsArg, nCases, nResp); double Rss = RssNull, RssDelta = RssNull, RSq = 0, RSqDelta = 0; int nUsedTerms = 1; // number of used basis terms including intercept, for GCV calc double Gcv = 0, GcvNull = GetGcv(nUsedTerms, nCases, RssNull, Penalty); PrintForwardProlog(nCases, nPreds, nMaxTerms, sPredNames, yw != NULL); #if FAST_MARS InitQ(nMaxTerms); AddTermToQ(0, 1, RssNull, true, nMaxTerms, FastBeta); // intercept term into Q #endif int nTerms = 1, iBestCase = -1; if(nMaxTerms >= 3) while(1) { // start after intercept, add terms in pairs int iBestPred = -1, iBestParent = -1; bool IsNewForm, LinPredIsBest; #if USING_R ServiceR(); #endif if(Rss <= 0) error("assertion failed: Rss <= 0 (y is all const?)"); ASSERT(RssDelta > 0); // Changed factor from 2 to 10 in version 4.2.0 (2 was too conservative). // Note that only the code without weights uses this. const double MaxLegalRssDelta = min(1.01 * Rss, 10 * RssDelta); FindTerm(&iBestCase, &iBestPred, &iBestParent, &RssDelta, &IsNewForm, &LinPredIsBest, bxOrth, bxOrthCenteredT, bxOrthMean, bx, x, y, yw, nCases, nResp, nPreds, nMaxDegree, nTerms, nMaxTerms, yMean, Rss, MaxLegalRssDelta, FullSet, xOrder, nDegree, nUses, Dirs, nFastK, NewVarPenalty, LinPreds); // following code added for Auto.linpreds (earth version 4.6.0, Dec 2017) if((LinPredIsBest && iBestCase != 0) || // paranoia, should never happen (!LinPredIsBest && iBestCase == 0)) printf("\nLinPredIsBest %d yet iBestCase%-5d\n", LinPredIsBest, iBestCase); if(!AutoLinPreds && !LinPreds[iBestPred]) LinPredIsBest = false; if(iBestCase >= 0) AddTermPair(Dirs, Cuts, bx, bxOrth, bxOrthCenteredT, bxOrthMean, FullSet, &IsNewForm, nDegree, nUses, nTerms, iBestParent, iBestCase, iBestPred, nPreds, nCases, nMaxTerms, LinPredIsBest, LinPreds, x, xOrder, yw != NULL); const bool IsTermPair = iBestCase > 0 && IsNewForm; nUsedTerms++; if(IsTermPair) nUsedTerms++; // add paired term Rss -= RssDelta; Rss = MaybeZero(Rss); // RSS can go slightly neg due to numerical error Gcv = GetGcv(nUsedTerms, nCases, Rss, Penalty); const double OldRSq = RSq; RSq = 1 - Rss / RssNull; RSqDelta = MaybeZero(RSq - OldRSq); PrintForwardStep(nTerms, nUsedTerms, iBestCase, iBestPred, iBestParent, iBestParent < 0? 0: nDegree[iBestParent]+1, RSq, RSqDelta, Gcv, GcvNull, nCases, xOrder, x, IsTermPair, sPredNames); // note the possible breaks in the code below if(iBestCase < 0) { // *piBestCase was not updated in FindKnot FullSet[nTerms] = FullSet[nTerms+1] = false; tprintf(2, "reject (no DeltaRsq)\n"); break; } if(Thresh != 0 && RSqDelta < Thresh) { FullSet[nTerms] = FullSet[nTerms+1] = false; tprintf(2, "reject (small DeltaRSq)\n"); break; } const double GRSq = 1 - Gcv / GcvNull; if(Thresh != 0 && GRSq < MIN_GRSQ) { FullSet[nTerms] = FullSet[nTerms+1] = false; tprintf(2, "reject (negative GRSq)\n"); break; } #if FAST_MARS if(!LinPredIsBest && IsNewForm) { // good upper term? AddTermToQ(nTerms, nTerms, POS_INF, false, nMaxTerms, FastBeta); AddTermToQ(nTerms+1, nTerms, POS_INF, true, nMaxTerms, FastBeta); } else AddTermToQ(nTerms, nTerms, POS_INF, true, nMaxTerms, FastBeta); if(TraceGlobal == 6) PrintSortedQ(nFastK); #endif nTerms += 2; if(RSq >= 1 - Thresh) { tprintf(2, "final (max RSq)\n"); break; } if(nTerms >= nMaxTerms - 1) { // -1 allows for upper term in pair tprintf(2, "final (reached nk %d)\n", nMaxTerms); break; } tprintf(2, "\n"); } // while(1) *piTermCond = ForwardEpilog(nTerms, nMaxTerms, Thresh, RSq, RSqDelta, Gcv, GcvNull, iBestCase, FullSet); *pnTerms = nTerms; #if FAST_MARS FreeQ(); #endif free1(yMean); free1(bxOrthMean); free1(bxOrthCenteredT); free1(bxOrth); free1(BetaCacheGlobal); free1(xOrder); } //----------------------------------------------------------------------------- // This is an interface from R to the C routine ForwardPass #if USING_R SEXP ForwardPassR( // for use by R SEXP SEXP_FullSet, // out: nMaxTerms x 1, bool vec of lin indep cols of bx SEXP SEXP_bx, // out: MARS basis matrix, nCases x nMaxTerms SEXP SEXP_Dirs, // out: nMaxTerms x nPreds, elements are -1,0,1,2 SEXP SEXP_Cuts, // out: nMaxTerms x nPreds, cut for iTerm,iPred SEXP SEXP_iTermCond, // out: reason we terminated the forward pass SEXP SEXP_x, // in: nCases x nPreds, unweighted x SEXP SEXP_y, // in: nCases x nResp, unweighted but scaled y SEXP SEXP_yw, // in: nCases x nResp, weighted and scaled y SEXP SEXP_WeightsArg, // in: nCases x 1, never R_NilValue SEXP SEXP_nCases, // in: number of rows in x and elements in y SEXP SEXP_nResp, // in: number of cols in y SEXP SEXP_nPreds, // in: number of cols in x SEXP SEXP_nMaxDegree, // in: SEXP SEXP_Penalty, // in: SEXP SEXP_nMaxTerms, // in: SEXP SEXP_Thresh, // in: forward step threshold SEXP SEXP_nMinSpan, // in: SEXP SEXP_nEndSpan, // in: SEXP SEXP_nFastK, // in: Fast MARS K SEXP SEXP_FastBeta, // in: Fast MARS ageing coef SEXP SEXP_NewVarPenalty, // in: penalty for adding a new variable (default is 0) SEXP SEXP_LinPreds, // in: nPreds x 1, 1 if predictor must enter linearly SEXP SEXP_Allowed, // in: constraints function, can be R NULL SEXP SEXP_nAllowedArgs, // in: number of arguments to Allowed function, 3...5 SEXP SEXP_Env, // in: environment for Allowed function SEXP SEXP_AdjustEndSpan, // in: SEXP SEXP_nAutoLinPreds, // in: assume predictor linear if knot is min predictor value SEXP SEXP_nUseBetaCache, // in: 1 to use the beta cache, for speed SEXP SEXP_Trace, // in: 0 none 1 overview 2 forward 3 pruning 4 more pruning SEXP SEXP_sPredNames) // in: predictor names in trace printfs { const size_t nCases = (size_t)(INTEGER(SEXP_nCases)[0]); const int nResp = INTEGER(SEXP_nResp)[0]; const int nPreds = INTEGER(SEXP_nPreds)[0]; const int nMaxTerms = INTEGER(SEXP_nMaxTerms)[0]; nMinSpanGlobal = INTEGER(SEXP_nMinSpan)[0]; nEndSpanGlobal = INTEGER(SEXP_nEndSpan)[0]; AdjustEndSpanGlobal = REAL(SEXP_AdjustEndSpan)[0]; TraceGlobal = REAL(SEXP_Trace)[0]; // nUses is the number of time each predictor is used in the model nUses = (int*)malloc1(nPreds * sizeof(int), "nUses\t\t\tnPreds %d sizeof(int) %d", nPreds, sizeof(int)); // nDegree is degree of each term, degree of intercept is considered to be 0 nDegree = (int*)malloc1(nMaxTerms * sizeof(int), "nDegree\t\tnMaxTerms %d sizeof(int) %d", nMaxTerms, sizeof(int)); iDirs = (int*)calloc1(nMaxTerms * nPreds, sizeof(int), "iDirs\t\t\tnMaxTerms %d nPreds %d sizeof(int) %d", nMaxTerms, nPreds, sizeof(int)); // convert FullSet int to bool (may be redundant, depending on compiler) BoolFullSet = (bool*)malloc1(nMaxTerms * sizeof(bool), "BoolFullSet\t\tnMaxTerms %d sizeof(bool) %d", nMaxTerms, sizeof(bool)); int iTerm; for(iTerm = 0; iTerm < nMaxTerms; iTerm++) BoolFullSet[iTerm] = INTEGER(SEXP_FullSet)[iTerm] != 0; // copy predictor names from SEXP_sPredNames to sPredNames ASSERT(LENGTH(SEXP_sPredNames) == nPreds); sPredNames = (const char**)malloc1( LENGTH(SEXP_sPredNames) * sizeof(char*), "sPredNames\t\tLENGTH(SEXP_sPredNames) %d sizeof(char*) %d", nPreds, sizeof(char*)); for(int i = 0; i < nPreds; i++) sPredNames[i] = (char*)CHAR(STRING_ELT(SEXP_sPredNames, i)); #if !WEIGHTS ASSERT(SEXP_yw == R_NilValue); #endif ASSERT(SEXP_WeightsArg != R_NilValue); InitAllowedFunc(SEXP_Allowed, INTEGER(SEXP_nAllowedArgs)[0], SEXP_Env, sPredNames, nPreds); // calls R_PreserveObject int nTerms; ForwardPass(&nTerms, INTEGER(SEXP_iTermCond), BoolFullSet, REAL(SEXP_bx), iDirs, REAL(SEXP_Cuts), nDegree, nUses, REAL(SEXP_x), REAL(SEXP_y), (SEXP_yw == R_NilValue)? NULL: REAL(SEXP_yw), REAL(SEXP_WeightsArg), nCases, nResp, nPreds, INTEGER(SEXP_nMaxDegree)[0], nMaxTerms, REAL(SEXP_Penalty)[0], REAL(SEXP_Thresh)[0], INTEGER(SEXP_nFastK)[0], REAL(SEXP_FastBeta)[0], REAL(SEXP_NewVarPenalty)[0], INTEGER(SEXP_LinPreds), REAL(SEXP_AdjustEndSpan)[0], INTEGER(SEXP_nAutoLinPreds)[0], INTEGER(SEXP_nUseBetaCache)[0] != 0, sPredNames); FreeAllowedFunc(); // calls R_ReleaseObject // remove linearly independent columns if necessary -- this updates BoolFullSet RegressAndFix(NULL, NULL, NULL, BoolFullSet, REAL(SEXP_bx), (SEXP_yw == R_NilValue)? REAL(SEXP_y): REAL(SEXP_yw), nCases, nResp, nMaxTerms); double* p = REAL(SEXP_Dirs); for(iTerm = 0; iTerm < nMaxTerms; iTerm++) // convert int to double for(int iPred = 0; iPred < nPreds; iPred++) p[iTerm + iPred * nMaxTerms] = iDirs[iTerm + iPred * nMaxTerms]; for(iTerm = 0; iTerm < nMaxTerms; iTerm++) // convert bool to int INTEGER(SEXP_FullSet)[iTerm] = BoolFullSet[iTerm]; free1(sPredNames); free1(BoolFullSet); free1(iDirs); free1(nDegree); free1(nUses); return R_NilValue; } #endif // USING_R //----------------------------------------------------------------------------- // Step backwards through the terms, at each step deleting the term that // causes the least RSS increase. The subset of terms and RSS of each subset are // saved in PruneTerms and RssVec (which are indexed on subset size). // // The crux of the method used here is that the change in RSS (for nResp=1) // caused by removing predictor iPred is DeltaRss = sq(Betas[iPred]) / Diags[iPred] // where Diags is the diagonal elements of the inverse of X'X. // See for example Miller (see refs in file header) section 3.4 p44. // // For multiple responses we sum the above DeltaRss over all responses. // // This method is fast and simple but accuracy can be poor if inv(X'X) is // ill conditioned. The Alan Miller code in the R package "leaps" uses a more // stable method, but does not support multiple responses. // // The "Xtx" in the name refers to the X'X matrix. static void EvalSubsetsUsingXtx( bool PruneTerms[], // out: nMaxTerms x nMaxTerms double RssVec[], // out: nMaxTerms x 1, RSS of each subset const size_t nCases, // in const int nResp, // in: number of cols in y const int nMaxTerms, // in: number of MARS terms in full model const double bx[], // in: nCases x nMaxTerms, all cols must be indep const double y[]) // in: nCases * nResp { Betas = (double*)malloc1(nMaxTerms * nResp * sizeof(double), "Betas\t\t\tnMaxTerms %d nResp %d sizeof(double) %d", nMaxTerms, nResp, sizeof(double)); Diags = (double*)malloc1(nMaxTerms * sizeof(double), "Diags\t\t\tnMaxTerms %d sizeof(double) %d", nMaxTerms, sizeof(double)); WorkingSet = (bool*)malloc1(nMaxTerms * sizeof(bool), "WorkingSet\t\tnMaxTerms %d sizeof(bool) %d", nMaxTerms, sizeof(bool)); for(int iTerm = 0; iTerm < nMaxTerms; iTerm++) WorkingSet[iTerm] = true; const double RssNull = GetRssNull(y, NULL, nCases, nResp); bool PrintHeader = true; for(int nUsedCols = nMaxTerms; nUsedCols > 0; nUsedCols--) { bool PrintNewline = true; int nRank; double Rss; Regress(Betas, NULL, &Rss, Diags, &nRank, NULL, bx, y, nCases, nResp, nMaxTerms, WorkingSet); if(nRank != nUsedCols) error("nRank %d != nUsedCols %d " "(probably because of lin dep terms in bx)\n", nRank, nUsedCols); RssVec[nUsedCols-1] = Rss; memcpy(PruneTerms + (nUsedCols-1) * nMaxTerms, WorkingSet, nMaxTerms * sizeof(bool)); if(nUsedCols == 1) break; // set iDelete to the best term for deletion int iDelete = -1; // term to be deleted int iTerm1 = 0; // index taking into account false vals in WorkingSet double MinDeltaRss = POS_INF; for(int iTerm = 0; iTerm < nMaxTerms; iTerm++) { if(WorkingSet[iTerm]) { double DeltaRss = 0; for(int iResp = 0; iResp < nResp; iResp++) DeltaRss += sq(Betas_(iTerm1, iResp)) / Diags[iTerm1]; bool NewMin = false; if(iTerm > 0 && DeltaRss < MinDeltaRss) { // new minimum? MinDeltaRss = DeltaRss; iDelete = iTerm; NewMin = true; } if(iTerm != 0) { if(PrintHeader) tprintf(4, " nTerms iTerm DeltaRss RSq"); PrintHeader = false; if(PrintNewline) tprintf(4, "\n"); PrintNewline = false; tprintf(4, " %6d %5d %11.5g %7.4f%s\n", nUsedCols, iTerm+IOFFSET, DeltaRss, 1 - (Rss + DeltaRss) / RssNull, NewMin? " min" : ""); } iTerm1++; } } ASSERT(iDelete > 0); WorkingSet[iDelete] = false; } tprintf(4, "\n"); free1(WorkingSet); free1(Diags); free1(Betas); } //----------------------------------------------------------------------------- // This is invoked from R if y has multiple columns i.e. a multiple response model. // It is needed because the alternative (Alan Miller's Fortran code) supports // only one response. #if USING_R void EvalSubsetsUsingXtxR( // for use by R double PruneTerms[], // out: specifies which cols in bx are in best set double RssVec[], // out: nTerms x 1 const int* pnCases, // in const int* pnResp, // in: number of cols in y const int* pnMaxTerms, // in const double bx[], // in: MARS basis matrix, all cols must be indep const double y[], // in: nCases * nResp (possibly weighted) const double* pTrace) // in { TraceGlobal = *pTrace; const int nMaxTerms = *pnMaxTerms; BoolPruneTerms = (bool*)malloc1(nMaxTerms * nMaxTerms * sizeof(bool), "BoolPruneTerms\tMaxTerms %d nMaxTerms %d sizeof(bool) %d", nMaxTerms, nMaxTerms, sizeof(bool)); size_t nCases = *pnCases; // type convert EvalSubsetsUsingXtx(BoolPruneTerms, RssVec, nCases, *pnResp, nMaxTerms, bx, y); // convert BoolPruneTerms to upper triangular matrix PruneTerms for(int iModel = 0; iModel < nMaxTerms; iModel++) { int iPrune = 0; for(int iTerm = 0; iTerm < nMaxTerms; iTerm++) if(BoolPruneTerms[iTerm + iModel * nMaxTerms]) PruneTerms[iModel + iPrune++ * nMaxTerms] = iTerm + 1; } free1(BoolPruneTerms); } #endif // USING_R //----------------------------------------------------------------------------- #if STANDALONE && WEIGHTS static void UnweightBx( double bx[], // in: nCases x nMaxTerms const double WeightsArg[], // in const size_t nCases, // in: number of rows in bx const int nMaxTerms) // in: number of cols in bx { if(WeightsArg) { for(int iTerm = 0; iTerm < nMaxTerms; iTerm++) for(int i = 0; i < (const int)nCases; i++) bx_(i, iTerm) /= sqrt(WeightsArg[i]); } } #endif // STANDALONE //----------------------------------------------------------------------------- #if STANDALONE static void BackwardPass( double* pBestGcv, // out: GCV of the best model i.e. BestSet columns of bx bool BestSet[], // out: nMaxTerms x 1, indices of best set of cols of bx double Residuals[], // out: nCases x nResp double Betas[], // out: nMaxTerms x nResp double bx[], // in: nCases x nMaxTerms, will be unweighted if weights const double y[], // in: nCases x nResp const double* WeightsArg, // in; NULL or nCases const size_t nCases, // in: number of rows in bx and elements in y const int nResp, // in: number of cols in y const int nMaxTerms, // in: number of cols in bx const double Penalty) // in: GCV penalty per knot { double* RssVec = (double*)malloc1(nMaxTerms * sizeof(double), "RssVec\t\tnMaxTerms %d sizeof(double) %d", nMaxTerms, sizeof(double)); bool* PruneTerms = (bool*)malloc1(nMaxTerms * nMaxTerms * sizeof(bool), "PruneTerms\t\tnMaxTerms %d nMaxTerms %d sizeof(bool) %d", nMaxTerms, nMaxTerms, sizeof(bool)); tprintf(4, "EvalSubsetsUsingXtx:\n"); EvalSubsetsUsingXtx(PruneTerms, RssVec, nCases, nResp, nMaxTerms, bx, y); // now we have the RSS for each model, so find the iModel which has the best GCV tprintf(3, "Backward pass:\nSubsetSize GRSq RSq\n"); int iBestModel = -1; double GcvNull = GetGcv(1, nCases, RssVec[0], Penalty); double BestGcv = POS_INF; for(int iModel = 0; iModel < nMaxTerms; iModel++) { const double Gcv = GetGcv(iModel+1, nCases, RssVec[iModel], Penalty); if(Gcv < BestGcv) { iBestModel = iModel; BestGcv = Gcv; } double GRSq = 1 - BestGcv/GcvNull; // Prevent negative almost-zero issued by some compilers (earth version 4.4.5) // This prints as -0.0000 below and messes up the test scripts. if(GRSq > -1e-12 && GRSq < 0) // -1e-12 is fairly arb GRSq = 0; tprintf(3, "%10d %12.4f %12.4f\n", iModel+IOFFSET, GRSq, 1 - RssVec[iModel]/RssVec[0]); } tprintf(3, "\nBackward pass complete: selected %d terms of %d, " "GRSq %.3f RSq %.3f\n\n", iBestModel+IOFFSET, nMaxTerms, 1 - BestGcv/GcvNull, 1 - RssVec[iBestModel]/RssVec[0]); // set BestSet to the model which has the best GCV ASSERT(iBestModel >= 0); memcpy(BestSet, PruneTerms + iBestModel * nMaxTerms, nMaxTerms * sizeof(bool)); free1(PruneTerms); free1(RssVec); *pBestGcv = BestGcv; #if WEIGHTS UnweightBx(bx, WeightsArg, nCases, nMaxTerms); // TODO should use weighted regression in RegressAndFix below #endif // get final model Betas, Residuals, Rss RegressAndFix(Betas, Residuals, NULL, BestSet, bx, y, nCases, nResp, nMaxTerms); } #endif // STANDALONE //----------------------------------------------------------------------------- #if STANDALONE static int DiscardUnusedTerms( double bx[], // io: nCases x nMaxTerms int Dirs[], // io: nMaxTerms x nPreds double Cuts[], // io: nMaxTerms x nPreds bool WhichSet[], // io: tells us which terms to discard int nDegree[], // io: degree of each term, degree of intercept is 0 const int nMaxTerms, const int nPreds, const size_t nCases) { int nUsed = 0, iTerm; for(iTerm = 0; iTerm < nMaxTerms; iTerm++) if(WhichSet[iTerm]) { memcpy(bx + nUsed * nCases, bx + iTerm * nCases, nCases * sizeof(double)); for(int iPred = 0; iPred < nPreds; iPred++) { Dirs_(nUsed, iPred) = Dirs_(iTerm, iPred); Cuts_(nUsed, iPred) = Cuts_(iTerm, iPred); } nDegree[nUsed] = nDegree[iTerm]; nUsed++; } memset(WhichSet, 0, nMaxTerms * sizeof(bool)); for(iTerm = 0; iTerm < nUsed; iTerm++) WhichSet[iTerm] = true; return nUsed; } #endif // STANDALONE //----------------------------------------------------------------------------- #if STANDALONE void Earth( double* pBestGcv, // out: GCV of the best model i.e. BestSet columns of bx int* pnTerms, // out: max term nbr in final model, after removing lin dep terms int* piTermCond, // out: reason we terminated the foward pass bool BestSet[], // out: nMaxTerms x 1, indices of best set of cols of bx double bx[], // out: nCases x nMaxTerms int Dirs[], // out: nMaxTerms x nPreds, -1,0,1,2 for iTerm, iPred double Cuts[], // out: nMaxTerms x nPreds, cut for iTerm, iPred double Residuals[], // out: nCases x nResp double Betas[], // out: nMaxTerms x nResp const double x[], // in: nCases x nPreds const double y[], // in: nCases x nResp const double WeightsArg[], // in: nCases x 1, can be NULL, not yet supported const size_t nCases, // in: number of rows in x and elements in y const int nResp, // in: number of cols in y const int nPreds, // in: number of cols in x const int nMaxDegree, // in: Friedman's mi const int nMaxTerms, // in: includes the intercept term const double Penalty, // in: GCV penalty per knot const double Thresh, // in: forward step threshold const int nMinSpan, // in: set to non zero to override internal calculation const int nEndSpan, // in: set to non zero to override internal calculation const bool Prune, // in: do backward pass const int nFastK, // in: Fast MARS K const double FastBeta, // in: Fast MARS ageing coef const double NewVarPenalty, // in: penalty for adding a new variable const int LinPreds[], // in: nPreds x 1, 1 if predictor must enter linearly const double AdjustEndSpan, // in: const bool AutoLinPreds, // in: assume predictor linear if knot is min predictor value const bool UseBetaCache, // in: 1 to use the beta cache, for speed const double Trace, // in: 0 none 1 overview 2 forward 3 pruning 4 more pruning const char* sPredNames[]) // in: predictor names in trace printfs, can be NULL { #if _MSC_VER && _DEBUG InitMallocTracking(); #endif TraceGlobal = Trace; nMinSpanGlobal = nMinSpan; nEndSpanGlobal = nEndSpan; AdjustEndSpanGlobal = AdjustEndSpan; // nUses is the number of time each predictor is used in the model nUses = (int*)malloc1(nPreds * sizeof(int), "nUses\t\t\tnPreds %d sizeof(int) %d", nPreds, sizeof(int)); // nDegree is degree of each term, degree of intercept is considered to be 0 nDegree = (int*)malloc1(nMaxTerms * sizeof(int), "nDegree\t\tnMaxTerms %d sizeof(int) %d", nMaxTerms, sizeof(int)); double* yw = NULL; #if WEIGHTS if(WeightsArg) { error("weights are not yet supported in STANDALONE earth"); // TODO yw = (double*)malloc1(nCases * nResp * sizeof(double), "yw\t\t\tnCases %d nResp %d sizeof(double) %d", (const int)nCases, nResp, sizeof(double)); for(int iResp = 0; iResp < nResp; iResp++) for(int i = 0; i < (const int)nCases; i++) { const int j = iResp * (const int)nCases + i; yw[j] = sqrt(WeightsArg[i]) * y[j]; } } #else ASSERT(WeightsArg == NULL); // weights are not currently supported #endif int nTerms = 0, iTermCond = 0; ForwardPass(&nTerms, &iTermCond, BestSet, bx, Dirs, Cuts, nDegree, nUses, x, y, yw, WeightsArg, nCases, nResp, nPreds, nMaxDegree, nMaxTerms, Penalty, Thresh, nFastK, FastBeta, NewVarPenalty, LinPreds, AdjustEndSpan, AutoLinPreds, UseBetaCache, sPredNames); // ensure bx is full rank by updating BestSet, and get Residuals and Betas RegressAndFix(Betas, Residuals, NULL, BestSet, bx, yw? yw: y, nCases, nResp, nMaxTerms); if(TraceGlobal >= 6) PrintSummary(nMaxTerms, nTerms, nPreds, nResp, BestSet, Dirs, Cuts, Betas, nDegree); int nMaxTerms1 = DiscardUnusedTerms(bx, Dirs, Cuts, BestSet, nDegree, nMaxTerms, nPreds, nCases); if(Prune) BackwardPass(pBestGcv, BestSet, Residuals, Betas, bx, yw? yw: y, WeightsArg, nCases, nResp, nMaxTerms1, Penalty); else if(WeightsArg) { // TODO should use weighted regression in RegressAndFix // UnweightBx(bx, WeightsArg, nCases, nMaxTerms); RegressAndFix(Betas, Residuals, NULL, BestSet, bx, y, nCases, nResp, nMaxTerms); } if(TraceGlobal >= 6) PrintSummary(nMaxTerms, nMaxTerms1, nPreds, nResp, BestSet, Dirs, Cuts, Betas, nDegree); *pnTerms = nMaxTerms1; *piTermCond = iTermCond; if(yw) free1(yw); free1(nDegree); free1(nUses); } #endif // STANDALONE //----------------------------------------------------------------------------- // Return the max number of knots in any term. // Lin dep factors are considered as having one knot (at the min value of the predictor) #if STANDALONE static int GetMaxKnotsPerTerm( const bool UsedCols[], // in const int Dirs[], // in const int nPreds, // in const int nTerms, // in const int nMaxTerms) // in { int nKnotsMax = 0; for(int iTerm = 1; iTerm < nTerms; iTerm++) if(UsedCols[iTerm]) { int nKnots = 0; // number of knots in this term for(int iPred = 0; iPred < nPreds; iPred++) if(Dirs_(iTerm, iPred) != 0) nKnots++; if(nKnots > nKnotsMax) nKnotsMax = nKnots; } return nKnotsMax; } #endif // STANDALONE //----------------------------------------------------------------------------- // print a string representing the earth expression, one term per line // TODO spacing is not quite right and is overly complicated #if STANDALONE static void FormatOneResponse( const bool UsedCols[],// in: nMaxTerms x 1, indices of best set of cols of bx const int Dirs[], // in: nMaxTerms x nPreds, -1,0,1,2 for iTerm, iPred const double Cuts[], // in: nMaxTerms x nPreds, cut for iTerm, iPred const double Betas[], // in: nMaxTerms x nResp const int nPreds, const int iResp, const int nTerms, const int nMaxTerms, const int nDigits, // number of significant digits to print const double MinBeta) // terms with fabs(beta) less than this are not printed, 0 for all { int iBestTerm = 0; int nKnotsMax = GetMaxKnotsPerTerm(UsedCols, Dirs, nPreds, nTerms, nMaxTerms); int nKnots = 0; char s[1000]; ASSERT(nDigits >= 0); char sFormat[50]; sprintf(sFormat, "%%-%d.%dg", nDigits+6, nDigits); char sFormat1[50]; sprintf(sFormat1, "%%%d.%dg", nDigits+6, nDigits); int nPredWidth; if(nPreds > 100) nPredWidth = 3; else if(nPreds > 10) nPredWidth = 2; else nPredWidth = 1; char sPredFormat[20]; sprintf(sPredFormat, "%%%dd", nPredWidth); char sPad[500]; sprintf(sPad, "%*s", 28+nDigits+nPredWidth, " "); // comment pad const int nUsedCols = nTerms; // nUsedCols is needed for the Betas_ macro printf(sFormat, Betas_(0, iResp)); // intercept while(nKnots++ < nKnotsMax) printf("%s", sPad); printf(" // 0\n"); for(int iTerm = 1; iTerm < nTerms; iTerm++) if(UsedCols[iTerm]) { iBestTerm++; if(fabs(Betas_(iBestTerm, iResp)) >= MinBeta) { printf("%+-9.3g", Betas_(iBestTerm, iResp)); nKnots = 0; for(int iPred = 0; iPred < nPreds; iPred++) { switch(Dirs_(iTerm, iPred)) { case 0: break; case -1: sprintf(s, " * max(0, %s - %*sx[%s])", sFormat, nDigits+2, " ", sPredFormat); printf(s, Cuts_(iTerm, iPred), iPred); nKnots++; break; case 1: sprintf(s, " * max(0, x[%s]%*s- %s)", sPredFormat, nDigits+2, " ", sFormat1); printf(s, iPred, Cuts_(iTerm, iPred)); nKnots++; break; case 2: sprintf(s, " * x[%s]%*s ", sPredFormat, nDigits+2, " "); printf(s, iPred); nKnots++; break; default: ASSERT(false); break; } } while(nKnots++ < nKnotsMax) printf("%s", sPad); printf(" // %d\n", iBestTerm); } } } void FormatEarth( const bool UsedCols[],// in: nMaxTerms x 1, indices of best set of cols of bx const int Dirs[], // in: nMaxTerms x nPreds, -1,0,1,2 for iTerm, iPred const double Cuts[], // in: nMaxTerms x nPreds, cut for iTerm, iPred const double Betas[], // in: nMaxTerms x nResp const int nPreds, const int nResp, // in: number of cols in y const int nTerms, const int nMaxTerms, const int nDigits, // number of significant digits to print const double MinBeta) // terms with fabs(betas) less than this are not printed, 0 for all { for(int iResp = 0; iResp < nResp; iResp++) { if(nResp > 1) printf("Response %d:\n", iResp+IOFFSET); FormatOneResponse(UsedCols, Dirs, Cuts, Betas, nPreds, iResp, nTerms, nMaxTerms, nDigits, MinBeta); } } #endif // STANDALONE //----------------------------------------------------------------------------- // return the value predicted by an earth model, given a vector of inputs x #if STANDALONE static double PredictOneResponse( const double x[], // in: vector nPreds x 1 of input values const bool UsedCols[], // in: nMaxTerms x 1, indices of best set of cols of bx const int Dirs[], // in: nMaxTerms x nPreds, -1,0,1,2 for iTerm, iPred const double Cuts[], // in: nMaxTerms x nPreds, cut for iTerm, iPred const double Betas[], // in: nMaxTerms x 1 const int nPreds, // in: number of cols in x const int nTerms, const int nMaxTerms) { double yHat = Betas[0]; int iTerm1 = 0; for(int iTerm = 1; iTerm < nTerms; iTerm++) if(UsedCols[iTerm]) { iTerm1++; double Term = Betas[iTerm1]; for(int iPred = 0; iPred < nPreds; iPred++) { switch(Dirs_(iTerm, iPred)) { case 0: break; case -1: Term *= max(0, Cuts_(iTerm, iPred) - x[iPred]); break; case 1: Term *= max(0, x[iPred] - Cuts_(iTerm, iPred)); break; case 2: Term *= x[iPred]; break; default: ASSERT("bad direction" == NULL); break; } } yHat += Term; } return yHat; } void PredictEarth( double y[], // out: vector nResp const double x[], // in: vector nPreds x 1 of input values const bool UsedCols[], // in: nMaxTerms x 1, indices of best set of cols of bx const int Dirs[], // in: nMaxTerms x nPreds, -1,0,1,2 for iTerm, iPred const double Cuts[], // in: nMaxTerms x nPreds, cut for iTerm, iPred const double Betas[], // in: nMaxTerms x nResp const int nPreds, // in: number of cols in x const int nResp, // in: number of cols in y const int nTerms, const int nMaxTerms) { for(int iResp = 0; iResp < nResp; iResp++) y[iResp] = PredictOneResponse(x, UsedCols, Dirs, Cuts, Betas + iResp * nTerms, nPreds, nTerms, nMaxTerms); } #endif // STANDALONE //----------------------------------------------------------------------------- // Example main routine // See earth/inst/slowtests/test.earthc.c for more complex examples #if STANDALONE && MAIN void error(const char *args, ...) // params like printf { char s[1000]; va_list va; va_start(va, args); vsprintf(s, args, va); va_end(va); printf("\nError: %s\n", s); // The following frees memory malloced by Earth(). // It is redundant here because exit() will release any unreleased memory. FreeEarth(); exit(-1); } // extern here prevents clang -Wmissing-prototypes warning extern void xerbla_(char *srname, int* info); void xerbla_(char *srname, int* info) // needed by BLAS and LAPACK routines { char buf[7]; strncpy(buf, srname, 6); buf[6] = 0; error("BLAS/LAPACK routine %6s gave error code %d", buf, -(*info)); } int main(void) { const int nMaxTerms = 21; // called "nk" in the R code const size_t nCases = 100; // note that nCases is size_t, not int // this allows e.g. mallocs below to be bigger than 2GB const int nResp = 1; // number of responses i.e. number of y columns const int nPreds = 1; // number of predictors i.e. number of x columns const int nMaxDegree = 1; // called "degree" in the R code const double Penalty = (nMaxDegree > 1)? 3: 2; const double Thresh = .001; const int nMinSpan = 0; // 0 means auto const int nEndSpan = 0; // 0 means auto const bool Prune = true; const int nFastK = 20; const double FastBeta = 1; const double NewVarPenalty = 0; int* LinPreds = (int*)calloc1(nPreds, sizeof(int), NULL); // "linpreds" in R code const double AdjustEndSpan = 2.0; const bool AutoLinPreds = true; const bool UseBetaCache = true; const double Trace = 3; const char** sPredNames = NULL; double BestGcv; int nTerms; int iTermCond; bool* BestSet = (bool*) malloc1(nMaxTerms * sizeof(bool), NULL); double* bx = (double*)malloc1(nCases * nMaxTerms * sizeof(double), NULL); int* Dirs = (int*) malloc1(nMaxTerms * nPreds * sizeof(int), NULL); double* Cuts = (double*)malloc1(nMaxTerms * nPreds * sizeof(double), NULL); double* Residuals = (double*)malloc1(nCases * nResp * sizeof(double), NULL); double* Betas = (double*)malloc1(nMaxTerms * nResp * sizeof(double), NULL); double* x = (double*)malloc1(nCases * nPreds * sizeof(double), NULL); double* y = (double*)malloc1(nCases * nResp * sizeof(double), NULL); ASSERT(nResp == 1); // code below only works for nResp == 1 for(int i = 0; i < (const int)nCases; i++) { const double xi = i / (double)nCases; x[i] = xi; y[i] = sin(4 * xi); // target function, change this to whatever you want } Earth(&BestGcv, &nTerms, &iTermCond, BestSet, bx, Dirs, Cuts, Residuals, Betas, x, y, NULL /*WeightsArg*/, nCases, nResp, nPreds, nMaxDegree, nMaxTerms, Penalty, Thresh, nMinSpan, nEndSpan, Prune, nFastK, FastBeta, NewVarPenalty, LinPreds, AdjustEndSpan, AutoLinPreds, UseBetaCache, Trace, sPredNames); printf("Expression:\n"); FormatEarth(BestSet, Dirs, Cuts, Betas, nPreds, nResp, nTerms, nMaxTerms, 3, 0); double x1 = 0.1234, y1; PredictEarth(&y1, &x1, BestSet, Dirs, Cuts, Betas, nPreds, nResp, nTerms, nMaxTerms); printf("\nf(%g) = %g\n", x1, y1); free1(y); free1(x); free1(Betas); free1(Residuals); free1(Cuts); free1(Dirs); free1(bx); free1(BestSet); free1(LinPreds); return 0; } #endif // STANDALONE && MAIN earth/src/leapshdr.f0000644000176200001440000000135213560116566014127 0ustar liggesusersC Copied from Thomas Lumley's leaps 2.9 package for earth 3.2-6 to avoid C use of external routines in earth causing complaints from CRAN check. C Original Fortran code by Alan Miller. C SUBROUTINE MAKEQR(NP,NN,WEIGHTS,TXMAT,YVEC,D,RBAR,THETAB, $ SSERR,IER) C Calls INCLUD to construct Banachiewicz factorisation C C INTEGER NP, NN, IER DOUBLE PRECISION WEIGHTS(NN), TXMAT(*), YVEC(NN), D(NP), RBAR(*), + THETAB(NP), SSERR C local variables INTEGER I, NRBAR IER=0 NRBAR=(NP*(NP-1))/2 DO 10 I=0, NN-1 CALL INCLUD(NP,NRBAR,WEIGHTS(I+1),TXMAT(I*NP+1),YVEC(I+1),D, $ RBAR,THETAB, SSERR,IER) IF (IER .NE. 0) RETURN 10 CONTINUE RETURN END earth/src/allowed.h0000644000176200001440000000067213560116566013762 0ustar liggesusers// allowed.h: externs for allowed.c void InitAllowedFunc( SEXP Allowed, // can be NULL int nAllowedArgs, SEXP Env, const char* sPredNames[], int nPreds); void FreeAllowedFunc(void); bool IsAllowed( const int iPred, // in: candidate predictor const int iParent, // in: candidate parent term const int Dirs[], // in: const int nPreds, // in: const int nMaxTerms); // in: earth/NEWS0000644000176200001440000010063113561151106012054 0ustar liggesusersChanges to the earth package ---------------------------- 5.1.2 Nov 4, 2019 Changed the type of the "lindeps" argument of the Fortran subroutine "SING" from LOGICAL to INTEGER, to satisfy a CRAN check. Improved handling of linear dependencies in bx (before the backward pass), although it is unlikely that such dependencies would exist in any earth model. Improved error reporting in leaps routines, although it is unlikely that such errors could occur in earth. Updated test scripts for the new random number generator that came with R version 3.6.0. 5.1.1 Apr 11, 2019 Earth now runs with R versions 3.4.0 or higher (whereas before the R version had to be 3.5.0 or higher). This restriction was lifted after running the tests in earth/inst/slowtests on R version 3.4.0. Minor updates to libraries shared with plotmo and rpart.plot. 5.1.0 Apr 3, 2019 Fixed a formatting bug in the trace output for cross validation. Thanks to Dirk Eddelbuettel. Fixed small memory leaks that sometimes occurred in the C code if error() was invoked or the user hit ^C. Changed the way memory is protected in allowed.c to pacify CRAN rchk. Thanks to Tomas Kalibera. Changed the name of the fallback memory release function to FreeEarth (it was FreeR) and made it suitable for use in environments other than R. If nfold > 1 and keepxy = 2, we now use keepxy=TRUE on the fold models. This allows plot.earth and plotmo on the fold models e.g. plot(mod$cv.list[[3]]). Also updated plotmo to remind user of this. Tweaked the trace message that is issued when glm doesn't converge. Documentation and test code updates. 5.0.0 March 20, 2019 Two-column binomial pair responses are now handled in a way that is more consistent with glm() i.e. regression on the fraction_true, weighted by the response rowsums. We now support cross-validation of binomial pair models. The function expand.bpairs was added. We no longer supports multiple-response binomial-pair models, and the bpairs argument is thus no longer necessary (i.e. we support a maximum of one binomial-pair response; the fact that the response is a binomial pair is automatically detected when family=binomial). We now save some additional GLM stats with earth-glm models. Some error message have been improved. For earth-glm models coef.earth() now returns the earth-glm coefficients (for these models, use coef.earth(mod, type="earth") to get the internal earth model coefficients). We now support "+" on the left side of formulas to specify multiple responses. Scale.y now works as documented for multiple response models. Fixed a bug where predict.earth issued an incorrect error message under certain conditions when a factor was passed as a string in the newdata. (This was the same as the old predict.lm "xlevels" bug.) Thanks to Meleksen Akin for help here. Fixed a bug where sometimes logical variables weren't displayed by plotmo if there were also factors in the model (you had to use all1=TRUE in plotmo). The model plot now avoids displaying ".5" in the Number Of Terms axis. Changes to some prints (mostly whitespace), for clarity. Updates to the documentation and shared libraries. 4.7.0 Jan 2, 2019 Earth no longer ignores the offset term in formulas. Thanks to Dag Johan Steinskog for help on this. The names of factor arguments are now handled slightly differently in the x argument for earth.default. This prevents a problem where plotmo mistakenly mistook certain models for an intercept-only model. (The models in question are those built with earth.default with a factor as the only column in the x matrix.) The type arguments for residuals.earth and fitted.earth were tweaked. For earth-glm models, plot.earth now plots the "response" residuals. For the behaviour of previous versions with earth-glm models, pass type="earth" to plot.earth to plot the earth (linear) residuals. Added some extra information to summary(glm.model). It now prints the AIC and the deviance ratio (defined analogously to RSquared as 1 - deviance / null.deviance). The print.earth function now includes summary of the weights and offsets, if any. For multiple-response models with weights, the weights are now accounted for when calculating the per-response GRSq (and not just for the overall GRSq). With plotmo(earth.model, all1=TRUE) now really plots all variables, (including variables that aren't used in the model). Added "LazyData: yes" to the DESCRIPTION file. Touch ups to documentation, code, and test scripts. Minor changes to prevent warnings when options(warnPartialMatchArgs=TRUE). 4.6.3 May 7, 2018 Earth's "allowed" argument was ignored when used with R version 3.5.0 (because of the byte compiler in that new version of R). Fixed that by internally in earth invoking .Call("ForwardPassR") instead of .C("ForwardPassR"). 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 earth is a little smaller (now 1342 kByte). Made some internal changes to earth.c to quieten minor clang warnings. 4.6.2 Mar 20, 2018 Minor documentation updates for the Auto.linpreds argument. 4.6.1 Mar 1, 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). Earth variance models now work with both the old and new versions of gam. 4.6.0 Dec 14, 2017 Added the Auto.linpreds argument. See the earth help page for details. Thanks to Ceyda Yazici for help on this. Further extensions to argument handling with pmethod="cv" (necessary when formula is a local variable in function calling earth.formula). 4.5.1 Jul 26, 2017 With pmethod="cv", you can now use arguments like "thresh" when earth is called in a function for which "thresh" is a local variable. Thanks to Matthew Watkins for help on this. 4.5.0 Apr 20, 2017 Removed trailing NULL entries in R_CMethodDef and R_FortranMethodDef to match changes to Rdynload.c in R core source code above version 3.3.3. 4.4.9 Feb 19, 2017 Fixed missing terminal entry in rentries.c:fortranEntries. Minor tweaks to C and Fortran files for clang and vcc warnings. 4.4.8 Feb 18, 2017 Minor updates to model.matrix.earth: Fixed a problem which can occur when the new x is a vector. We return NA if variables are missing in newdata. Extended the tests for model.matrix.earth in the slowtests directory. We now call R_init_earth (to quieten CRAN check complaints). To do that, added the file rentries.c and made changes to ForwardPassR. Minor documentation updates. Added DOI references to Friedman's papers in the help pages as requested by Uwe Ligges. 4.4.7 Oct 18, 2016 Updates to the documentation and to the libraries shared with plotmo and rpart.plot. 4.4.6 Sep 5, 2016 Added ... to argument list for all plotmo.* functions for compatibility with plotmo version 3.2.0 and higher. Tweaked leaps.f to eliminate gfortran warnings about the deprecated way that DO loops were terminated. 4.4.5 Aug 19, 2016 Fixed issue in earth.c with the latest gcc which calculates a negative almost-zero GRSq (something like -1e-17). This messed up the test scripts because it printed as -0.0000. Merged the library source file lib.R with the plotmo and rpart.plot packages's lib.R. Updated cross-validation section in vignette. 4.4.4 Jan 08, 2016 Fixed error message when predicting with a weighted model with a factor variable. Thanks to Damien Georges. Added a few type casts needed for clang and for matrices bigger than 2GB. Thanks to Todd Rudick. Removed a leftover debug call to cat("gc\n"). Thanks to Dirk Eddelbuettel. Updated some stale web links in the documentation. 4.4.3 Sep 26, 2015 Minor changes to satisfy CRAN checks. The print_summary function now has special handling for lists. The stopifnot.identifier function now allows ":" in identifier names. 4.4.2 Jun 24, 2015 In model.matrix.earth we no longer unnecessarily issue the message: variable 'foo' was fitted with type "nmatrix.1" but type "numeric" was supplied 4.4.1 Jun 17, 2015 Fixed an issue with earth's interaction with caret in certain situations. Thanks to Alexios Ghalanos for help on this. Documentation updates. 4.4.0 May 29, 2015 Changes to earth.c. The following changes mean that earth will produce slightly different models from previous releases: o For minspan counting in interaction terms, we now only count cases that are supported by the parent term (i.e., cases that are in the zero part of the parent hinge are not counted). This makes earth more robust against overfitting on the edges of the training predictor space. In previous versions, earth could create a hinge at the edge of the predictor space, then crank up the hinge coefficient to a huge value because of one or two outlying cases. This is now less likely. Thanks to Louise Corron at Universite Aix-Marseille for help characterizing this. o Modified the code for weighted models, mostly for consistency with non-weighted models. o Changed a numerical tolerance in FindKnot for better support of "sawtooth" responses (responses which sharply zigzag up and down as the predictor increases). The numerical tolerance was changed because we were seeing a breakdown caused by the the strategy of "start at one end of the predictor range and search downwards for knots". The asymmetrical nature of this search tends to honor potential knots at the high end of the predictor range at the expense of knots at the low end before numerical tolerances kick in. Thanks to Greg Jensen at Columbia for help on this. o Other minor updates, particularly to trace prints. Values that are almost zero are now printed as zero, for more consistency in trace prints across different architectures. The weights argument has now been comprehensively tested and the warning "support of weights is provisional" is no longer issued. Earth now supports pmethod = "cv", which uses cross-validation to select the optimum number of model terms. Thanks to the sabermetrician Jonathan Judge for help on this. Earth now supports bigger models with less memory thrashing. It calls gc() internally where necessary. Leverages are calculated only for non-big models (since memory use peaks when calculating leverages). The model selection plot has had various enhancements. Various other minor code and documentation updates. 4.3.0 Apr 30, 2015 We now support data matrices bigger than 2GB. The plot.earth function now invokes plotres in the plotmo package. Reparameterized the argument list of plot.earth, but maintained back-compatibility by using the "dots" routines. Numerous minor code clean-ups. 4.2.0 Jan 12, 2015 plot.earth: o Changed the default color scheme to black and red (was black and lightblue) for consistency with plot.lm and similar functions, and for readability. A result of this change is that col.line is now once again called col.rsq. o The type="pearson" arg is now type="student", since the stddev estimated by the varmod now includes a leverage correction. o The versus arg now takes numeric values, and can be used to plot the residuals versus the response or the leverages. o Added "abs" to displayed spearman correlation text to minimize confusion. o The error handling for the versus argument is improved. minspan and endspan: o The positioning of knots is now more symmetrical (in that we now have an equal number of skipped cases at each end of the predictor range). o We always allow at least one knot, even if endspan and minspan are such that no knots would normally be allowed (endspan and minspan overlap). o Added the Adjust.endspan argument to reduce the possibility of an overfitted interaction term supported by just a few cases on the boundary of the predictor space. variance models: o Variance model residuals now use the predicted value instead of the mean out-of-fold values. This is simpler, and gives better results in simulation. A consequence is that the legal values for predict.varmod's type argument have changed. o The convergence criteria for residual model IRLS was modified and non-convergence is better reported. The intercept-only RSS with weights is now calculated correctly in earth.c. Weights are now better tested. The Get.crit argument was removed from earth.fit. No longer needed. RSq's and GRSq's that are within 1e-5 of zero are now set to zero to facilitate testing across machines in the presence of numerical error, especially when case weights are used. Increased MaxAllowedRssDelta in earth.c because it was a bit too conservative. Updated the vignettes and help pages, and some error messages. 4.1.0 Dec 17, 2014 Added clang to the slowtests suite, and cleaned up minor warnings issued by clang. Forward pass termination messages are now similar in R and C code. The internal variable "reason" is now named "termcond". Documentation improvements. 4.0.0 Dec 12, 2014 Earth now supports prediction intervals. See earth's new var.method argument, and the new vignette. The predict.earth function now has "interval" and "level" arguments. The residual plot of plot.earth now shows prediction intervals if available. The new version of plotmo will also show earth prediction intervals. Case weights are now supported but are not yet comprehensively tested. The current implementation of case weights is slow. The print.earth and print.summary.earth function now print the reason the forward pass terminated. The ordering of terms in summary.earth was changed slightly: within term pairs, the term for "predictor less than hinge" is now placed before the term for "predictor greater than hinge" (so for example, h(16-Girth) is before h(Girth-16)}. This was done to make model interpretation slightly easier. Predictors that are discovered to best enter linearly (no knot) are now printed without a knot by summary.earth, to make model interpretation a little easier. Also, their entry in the dirs matrix is now 2, the same as predictors that are forced to enter linearly by earth's linpred arg. The minspan argument can now take negative values, to specify the max number of knots per predictor (as opposed to the spacing between the knots). Earth now has an endspan argument. The default endspan=0 gives the previous behaviour. The linpreds argument now accepts variables specified by name. Earth now accepts nk=1 to force an intercept-only model (in previous versions, nk had to be at least 3). DUP is now always TRUE in internal calls to C function, to satisfy CRAN checks. Sadly, this means that the earth forward pass uses more memory (because all the argument data is duplicated when handing over to C). The comprehensive (but slow) earth tests are now in inst/slowtests. As always, the tests in earth/tests just do a basic test of portability problems. "cv.rsq" is now consistently "CVRSq". In the earth C code, QR_TOL is now 1e-7 (was .01) to match lm's use of tol=1e-7 for dqrdc2. The GLM types for residuals.earth are now prefixed by "glm.", and type="pearson" now returns the pearsonized residuals. Various other minor tweaks, improvements to error messages, etc. Changes to plot.earth: plot.earth has some new arguments, including info, delever, pearson, level, and versus. The which argument now has extra values 5:8, to plot residuals vs log fitted values etc. The residuals plot now has a symmetrical y axis to make asymmetry in the point cloud more obvious (see the center argument). Graphics arguments to plot.earth are moved down so the more important arguments are earlier. plot.earth now has an xlim argument, and the ylim argument can now be used on any plot (not just the Model Selection plot), providing it is the only plot (length(which == 1). Some args are deprecated or changed (you will get an informative message if you use them). The changes were made for consistency with similar arguments elsewhere. --Old-- --New-- col.rsq col.line col.residuals col.points nresiduals npoints col.legend use legend.pos=NA for no legend If 1 is in the "which" arg to plot.earth, then ylim is used for the Model Selection plot, else it is used for the Residuals vs Fitted plot. 3.2-7 Jan 28, 2014 Tweaks to standalone version of earth for clean compiles with certain 64 GCC builds. plot.evimp now works with intercept-only models. Other minor tweaks to plot.evimp. Clerical changes to satisfy recent CRAN checks. 3.2-6 Apr 15, 2013 Added format.earth style="C". Included the leaps package files into the earth package, to prevent warnings from CRAN check about earth's use of internal leaps code. Removed "Depends: leaps" from earth's DESCRIPTION file. Lin deps discovered by leaps are now slightly better handled. Small changes to earth.c and earth.h for stand-alone builds. Added sections to the FAQ on using earth for binary and categorical responses. Added a section to the vignette on building a model based on cross validation results. Removed trace=4 from test.earth.R so a non-problem is no longer reported due to minor numerical differences across architectures. Reduced the number of digits printed in some of earth's trace messages. This makes trace results more consistent across different architectures (the ls digits are often in the numerical noise floor). We now print a max of 20 columns of a matrix when tracing. The legend.text arg of plot.earth.models now works correctly. 3.2-3 Apr 27, 2012 Incorporated Glen Luckjiff's patch to fix predict.earth(type="terms") failure when bx had just two columns. We no longer call fflush when in an R environment. The tests/test.earth.R code now uses the tree rather than the ozone1 data, in an effort to get test consistency across different architectures. Added .Rinstignore to drop inst/docs/figs files (prevents note in CRAN build). 3.2-2 Mar 14, 2012 We no longer pass R_NilValue from the R code to the C code. Incorporated Olaf Mersmann's patch for POS_INF with the INTEL_COMPILER. Code touchups for Microsoft Visual Studio 2010. 3.2-1 Jul 19, 2011 Documentation touchups. 3.2-0 Jun 19, 2011 The PDF file is now a standard vignette (but with no executable code). The "Importances" printed by print.earth are now a maximum of option("width") wide. We no longer warn "effective number of GCV parameters >= number of cases" but instead set such GCVs to Inf, so GCVs are now always non-decreasing with the number of terms. Documented as FAQ 12.11. The earth C routines now print memory allocations if trace=1.5. The pnTrace arg to ForwardPassR is now a double and called pTrace (allowing trace=1.5). The default nk is now clipped at 200. This limits the amount of memory needed in the forward pass for large x matrices. Numerical limits will probably kick in before 200 are reached anyway. We now force Use.beta.cache=FALSE with a message if the beta cache would be more than 3 GB. summary.earth now warns if illegal arguments are passed. Documentation touched up. 3.1-1 Jun 15, 2011 Documentation emendations. We now issue a warning if user uses a CV arg to plot.earth but no CV data to plot. The CV summary print no longer prints the response name for single response models. 3.1-0 Jun 14, 2011 print.evimp now formats the results a little differently (more clearly). "Reached min GRSq" and similar trace messages now also print the number of terms. The min auto-calculated ylim in model selection plots is now clamped at -1. Added the col.residuals, col.pch.max.oof.rsq, and col.pch.cv.rsq args to plot.earth. Cross validation with wp no longer gives an error message. Revised the documentation. 3.0-0 Jun 10, 2011 Created the vignette earth-notes.pdf which collects and extends documentation that was previously in the help files. Revamped cross validation. New argument "ncross" to earth. Extended plot.earth, mostly for cross validation. The default for evimp's "sqrt." argument is now TRUE. plot.earth now uses lowess rather than loess (loess tends to issue ugly warnings). Removed earth's Print.pruning.pass argument. Earth now uses less memory if passed an x matrix of doubles. Earth's memory report (with trace>=4) was not accurate in all cases and has been removed. Tweaked the Author: entry in DESCRIPTION for better results from citation(). Other minor touchups. 2.6-2 Apr 25, 2011 Moved plotmo.methods.earth.R to here so the plotmo package is independent of earth. Modified test scripts to conform to R 2.13.0's way of printing numbers. 2.6-1 Apr 13, 2011 Fixed an issue of dependency on the plotmo package. 2.6-0 Apr 12, 2011 Moved plotmo to the plotmo package, and added "depends plotmo" to earth's DESCRIPTION Added the Exhaustive.tol arg as a work-around for leaps.exhaustive error code -999 (Thanks to David Marra for help tracking this down.) The "Exhaustive pruning" pacifier is now printed based on the number of subsets Warnings from leaps routines are now treated as errors (because ret val is bad with warning) Replaced n=2 and similar in calls to eval with an explicit environment The decision to use eval.subsets.xtx is now more automatic and less obtrusive The response y is now named in certain situations where it used to be unnamed Removed annoying warning "specified nprune 20 is greater than the number of model terms" Some code tidying 2.5-1 Mar 25 2011 Modified handling of illegal arguments 2.5-0 Mar 24 2011 Changes to plotmo: The arguments were reordered (moved the most important arguments first). The ycolumn arg is now called nresponse and handled more consistently. The degree2="all" setting is now replaced by all2=TRUE, likewise for degree1. The default for the type argument is now object dependent. The cex parameter is now supported, and text is a little larger for most plots. The degree2 graph titles now have a space for readability. There is some minor backwards incompatibility in the minor arguments. The plotmo graphs are now ordered on the variable order, for all model classes. Plotmo now handles a wider range of object classes. Factor predictors are now plotted in degree2 plots. Miscellaneous other touchups. 2.4-8 Mar 05 2011 plotmo now handles vector colors better plotmo is now better at plotting lda and qda models Added the jitter.response argument to plotmo Moved plotmo method functions into a new file, plotmo.methods.R. 2.4-7 Feb 02 2011 Intercept-only models are now better supported, esp. for earth-glm models. Martin Renner and Keith Woolner provided the impetus for this change. Legend arguments are now handled better in plot.earth.models. A vector legend.text is now handled correctly and you can use values like "topleft" in legend.pos (thanks to Gavin Simpson at ECRC). The elements of cv.list in earth's returned value are now named, and plot.earth.models(model$cv.list) thus has better legends. Cumulative distrib plots in plot.earth.models now use the jitter arg, and plot.earth's (pointless) jitter argument has been removed. A few code and doc touchups were also made. 2.4-6 Jan 26 2011 Made the following changes to plotmo: We now print the fixed grid values unless trace < 0. The degree1 and degree2 arguments now have an "all" option. We now have better support for rpart objects The cex arg is now also used for response values (with cex.response!=0). Added cex.lab argument. For factor predictors we now print the factor levels vertically along the x axis. Fixed crossed type.gcv and type.rss args in plot.evimp. Fixed residuals.earth to handle vector responses correctly. (Thanks to Gavin Simpson at UCL for providing fixes for the above bugs.) plot.evimp now doesn't use on.exit(par(no.readonly=TRUE)), so we now allow subsequent plots on the same page with mfrow != c(1,1). Did the usual document touchups. Minor cleanups for R check (partial arg matches). 2.4-5 Oct 30 2010 Plotmo now better handles the "data" argument for earth.formula models. (Thanks to Keith Woolner for spotting that this was previously incorrect.) 2.4-4 Oct 6 2010 NAs are now allowed in the data passed to predict.earth. The predicted value will be NA unless the NAs are in variables that are unused in the earth model. 2.4-3 Sep 29 2010 For certain data we were seeing duplicated term names for cuts that are very close to each other. To avoid this you can now use options(digits) to increase the number of significant digits used when forming term names. (Thanks to Keith Woolner for spotting this.) 2.4-2 Aug 28 2010 We now give the correct error message for attempted cross validation of paired binomial responses (which is not yet supported). Labels on the largest residuals in plot.earth graphs are now slightly better positioned (using plotrix::thigmophobe.labels). plotd now handles qda objects in the same manner as lda objects Other doc touchups. 2.4-0 Nov 8 2009 This version of earth will build models SLIGHTLY DIFFERENT FROM PRIOR VERSIONS, because I fixed a bug in the calculation of minspan and endspan. Use minspan=-1 for backwards compatibility. (Thanks to Gints Jekabsons for spotting this.) 2.3-5 Oct 7 2009 Fixed bug where glm.control args were ignored under certain circumstances (Thanks to Jrme Gulat for letting me know about this.) 2.3-4 Sep 21 2009 . Fixed bug where predict.earth of a earth-glm model under R 2.9.0 and higher incorrectly gave the message: Object of type 'closure' is not subsettable (Thanks to Thomas Brockmeier for help tracking this down.) . plotd now correctly ignores the vline if vline.col=0 . Doc touchups 2.3-2 Mar 23 2009 Extended plotd Doc touchups 2.3-1 Feb 26 2009 Doc touchups Added leaps::: prefix needed for new version of the leaps package Added style="max" to summary.earth Added labels param to plotd Reordered some of earth's arguments 2.3-0 Feb 18 2009 Added the plotd function Removed some restrictions on type="class" in predict.earth Added sqrt. argument to evimp Added more grid lines to cumul density plot in plot.earth Added a help page section on interpreting the graphs in plot.earth Miscellaneous other touchups to code and docs 2.2-3 Feb 2 2009 Added levels to the return value Added type=class and thresh arguments to predict.earth Thanks to Max Kuhn for suggesting these improvements 2.2-2 Jan 30 2009 Doc touchups Cross validation MaxErr is now signed 2.2-1 Jan 22 2009 Added cross validation i.e. the nfold and stratify parameters. We now scale y before the forward pass, for better numeric stability in the forward pass with very big or very small y's. For the old behaviour, set earth's new argument scale.y=FALSE. Added get.pairs.bagEarth so plotmo prints degree2 plots for caret:bagEarth models. Changes internal to earth.c: High values of trace argument are treated differently ServiceR (to allow interrupts) is called more consistently for large datasets Delta RSS handling is simplified Changed some var names for consistency The last two were a byproduct of experimental changes to earth that were not included in this release. Changed documentation to American English. 2.1-2 Nov 18 2008 Touched up evimp help page. 2.1-0 Nov 15 2008 plotmo now has better support for factors and for glm models na.action (always na.fail) is now handled as documented in earth.formula Added style="bf" to format.earth and summary.earth Fixed a few minor bugs and touched up documentation for evimp 2.0-6 Oct 30 2008 You can now pass only the needed subset of columns to predict.earth Added plot.evimp Removed spurious warning "Need as many rows as columns" 2.0-5 Jul 14 2008 Touched up documentation for format.lm. 2.0-4 June 22 2008 Touched up code and documentation for a zero thresh value. 2.0-3 June 22 2008 Zero values are now allowed for earth's "thresh" parameter (previously if you used thresh=0, thresh was clamped internally to 1e-10). Also, if thresh=0, the MAX_GRSQ forward pass condition is ignored. The idea is to get as close to a big nk as possible Changed "valid.names" argument of format.earth and format.lm to "colon.char" which achieves the same end more simply. 2.0-2 June 15 2008 Added column names to results of mars.to.earth, allows use of evimp. Added valid.names argument to format.earth and format.lm. 2.0-1 June 10 2008 Added "namesx" and "first" arguments to the "allowed" function. evimp() for a scalar x now returns a matrix (I added a missing drop=FALSE). 2.0-0 June 07 2008 Added support for glms and factors (but plotmo does not yet support factors). Added variable importance function "evimp". Added response weights argument "wp" to earth. Output of summary.earth has changed to better deal with multiple response models, see the "style" argument. Added namesx and namesx.org to earth's return value. 1.3-2 Mar 29 2008 Fixed two bad multiple response bugs: a) for multiple reponse models, earth calculated the wrong null RSS and therefore the wrong RSq and GRSq for the sub-models. (The total RSq and GRSq were correct.) b) the wrong betas were used when pruning multiple response models. Also fixed a bug where summary.earth printed the wrong number of cases for multiple response models. 1.3-1 Mar 22 2008 "update.earth" now has a "ponly" argument, to force pruning only. Because of this change, the "ppenalty" argument to earth is no longer needed and has been removed. Revisited text of warnings after I was bamboozled by one of my own warnings. Tweaked legend positioning in plot.earth.models. 1.3-0 Mar 18 2008 Default minspan is now 0 (was 1) for compatibility with mda:mars and Friedman's MARS paper (I've flip flopped on this one). This means that models built with the default args will be little different to before. Earth's peak memory is now about 40% less. Big models are now more responsive to ^C. For multiple response models, we now print response names in most places instead of just "Response N". Removed get.nterms.per.degree and get.nused.preds.per.subset from NAMESPACE and from help pages, to simplify user interface. Fixed some niggling document issues and extended the FAQ. 1.2-2 Jan 2008 print.summary.earth now prints the call even for x,y interface to earth plotmo now accepts x matrices without column names Tweaked FindKnot and OrthogResiduals for speed Removed a few shadowed variables in earth.c after running gcc -Wshadow Clarified some paras in earth.Rd, reduced page width for better html display 1.2-1 Fixed a newvar.penalty bug introduced in previous release. Added src/tests/test.earthmain.gcc.bat More man page tweaks 1.2-0 Added linpreds, allowed, and Use.beta.cache arguments Anova decomp is now more consistent Added a few GPL headers Reinstated the beta cache More man page tweaks 1.1-5 Fixed bug reported by Joe Ritzer: long predictor names got munged in plotmo Changed "class" to "response" throughout when used for the predicted responses in the input y. Man page tweaks based on user feedback. 1.1-4 Changed as.matrix to data.matrix in earth.default -- grep for FIXED Extended earth.Rd slightly 1.1-2 Added my web page to DESCRIPTION and to some man pages 1.1-1 Changed \r\n to \n to pacify CMD CHECK 1.1-0 Default minspan is now 1 (was 0) Fixed potential crash in PrintForwardStep if nTrace>1 Added a missing drop=FALSE to backward() Minor code, comment, and man page fixups 1.0-8 Fixed bug where plotmo failed under these circumstances: form <- Volume ~ .; a <- earth(form, data = trees); plotmo(a) 1.0-7 Minor change to summary.earth formatting. Man page fixes. 1.0-6 May 11 2007 Initial release earth/R/0000755000176200001440000000000013561352060011557 5ustar liggesusersearth/R/varmod.R0000644000176200001440000015476113443543657013225 0ustar liggesusers# earth.varmod.R: build variance models for estimating prediction intervals # # TODO Extend the coverage table (print_inconf_tab) to show percentages in # lower and upper intervals, so the user can check for asymmetry of the # residuals. # # TODO Add QQ plot for prediction intervals, a "PIQ" plot # # TODO Consider making the code automatically detect non-monotonicity and # issuing a warning. Probably only possible for univariate models. # # TODO Could maybe prevent "Error in numericDeriv" by internally passing # an explicit derivative in the call to nls. VARMOD.METHODS <- c("const", "power", "power0", "lm", "rlm", "earth", "gam", "x.lm", "x.rlm", "x.earth", "x.gam") TRACE.VARMOD <- .3 TRACE.VARMOD.DETAILS <- .31 # will also cause plotting # varmod returns a "varmod" object. # y is the observed response (it is a n x 1 matrix) varmod <- function(parent, method, exponent, conv, clamp, minspan, trace, x, y, model.var, ...) { UseMethod("varmod") } varmod.earth <- function(parent, method, exponent, conv, clamp, minspan, trace, x, y, model.var, ...) { check.classname(parent, substitute(parent), "earth") varmod.internal(parent, method, exponent, conv, clamp, minspan, trace, x, y, model.var, ...) } varmod.default <- function(parent, method, exponent, conv, clamp, minspan, trace, x, y, model.var, ...) { warning0("varmod.default: varmods are not supported for \"", class(parent)[1], "\" objects\nContinuing anyway") varmod.internal(parent, method, exponent, conv, clamp, minspan, trace, x, y, model.var, ...) } varmod.internal <- function(parent, method, exponent=1, conv=1, clamp=.1, minspan=-5, trace=0, parent.x=NULL, parent.y=NULL, model.var, ...) { # The following constant "lambda" was an argument to earth but I removed # it and hardcoded it here for simplicity in the earth interface. # We use lambda to transform the squared residuals as follows: # transformed.resids = squared.resids ^ (lambda / 2) # So with lambda=1, we transform to absolute residuals, and if # lambda=2, then there is no transform. We call the transformed # residuals the abs.resids in the code (which is actually the correct # nomenclature only when lambda is 1). See also get.resids.name. lambda <- 1 # likewise, rmethod is hardcoded here instead of being an arg to earth rmethod <- "hc12" # TODO doesn't match documentation "Variance models in earth" trace <- as.numeric(check.numeric.scalar(trace, logical.ok=TRUE)) check.lambda.arg(lambda) check.exponent.arg(exponent, method) check.conv.arg(conv) check.clamp.arg(clamp) stopifnot(!is.null(parent.x)) stopifnot(is.matrix(parent.x)) stopifnot(!is.null(parent.y)) stopifnot(is.matrix(parent.y)) if(NCOL(parent.y) != 1) stop0("variance models are not supported for multiple response models") if(trace >= TRACE.VARMOD) { printf( "\nvarmod method=\"%s\" rmethod=\"%s\" lambda=%g exponent=%g conv=%g clamp=%g minspan=%g:\n", method, rmethod, lambda, exponent, conv, clamp, minspan) if(trace == TRACE.VARMOD.DETAILS) { oldpar <- par(no.readonly=TRUE) on.exit(par(oldpar)) par(mfrow=c(2, 3), mar=c(3, 3, 3, 1), mgp=c(1.5, .5, 0)) } } n <- nrow(parent.x) df <- length(parent$selected.terms) leverages <- parent$leverages stopifnot(!is.null(leverages)) leverages[leverages > .9] <- .9 # prevent any residual from being too influential correction <- switch(match.choices(rmethod, c("hc0", "hc1", "hc2", "hc3", "hc12"), "varmod.rmethod"), hc0 = 1, hc1 = n / (n - df), hc2 = 1 / (1 - leverages), hc3 = 1 / (1 - leverages)^2, hc12 = n / ((n - df) * (1 - leverages))) squared.resids <- correction * (parent.y - predict(parent))^2 + model.var abs.resids <- squared.resids ^ (lambda / 2) # by default lambda=1, so this takes sqrt temp <- iterate.residmod(parent, abs.resids, method, exponent, lambda, conv, clamp, minspan, trace, parent.x, parent.y, ...) residmod <- temp$residmod converged <- temp$converged iters <- temp$iters if(trace >= TRACE.VARMOD) printf("\n") varmod <- NULL varmod$call <- make.call.generic(match.call(), "varmod") varmod$parent <- parent varmod$method <- method varmod$package <- which.package(method) varmod$exponent <- exponent varmod$lambda <- lambda varmod$rmethod <- rmethod varmod$converged <- temp$converged varmod$iters <- temp$iters varmod$residmod <- residmod varmod$min.sd <- get.min.sd(residmod, lambda, clamp) varmod$model.var <- model.var varmod$abs.resids <- abs.resids # transformed residuals (actually only abs when lambda is 1) varmod$parent.x <- parent.x varmod$parent.y <- parent.y class(varmod) <- "varmod" varmod$iter.rsq <- get.iter.rsq(varmod, abs.resids) varmod$iter.stderr <- get.iter.stderr(varmod, trace) attr(varmod, ".Environment") <- get.model.env(residmod, "varmod", trace) varmod } get.iter.rsq <- function(object, abs.resids) # return NULL if can't get rsq { check.classname(object, substitute(object), "varmod") if(object$method == "const") return(NULL) fitted <- fitted(object$residmod) weights <- weights(object$residmod) if(is.null(fitted) || is.null(weights)) return(NULL) get.weighted.rsq(abs.resids, fitted, weights) } get.iter.stderr <- function(object, trace) # return if NULL if can't get stderr { check.classname(object, substitute(object), "varmod") residmod <- object$residmod if(class(residmod)[1] %in% c("lm", "rlm", "nls")) { coef <- summary(residmod)$coefficients stopifnot(!is.null(coef[,"Std. Error"])) coef[,"Std. Error"] } else if(class(residmod)[1] == "Gam") { # package gam version 1.15 or higher coef <- coefficients(summary.glm(residmod)) stopifnot(!is.null(coef[,"Std. Error"])) coef[,"Std. Error"] } else if(class(residmod)[1] == "gam" && object$package == "gam") { # package gam version less than 1.15 coef <- coefficients(summary.glm(residmod)) stopifnot(!is.null(coef[,"Std. Error"])) coef[,"Std. Error"] } else if(class(residmod)[1] == "gam" && object$package == "mgcv") { # only the stderr for the intercept is available len.coef <- length(coefficients(residmod)) std.err <- repl(NA, len.coef) std.err[1] <- summary(residmod)$p.table[1, "Std. Error"] # se of intercept std.err } else if(class(residmod)[1] == "earth") { trace2(trace, "--get.iter.stderr\n") y <- plotmo::plotmo_y(residmod, nresponse=1, trace)$y bx <- model.matrix(residmod) coef <- summary(lm(y~bx))$coefficients coef[,"Std. Error"] } else NULL } # iteratively reweighted least squares issued.singularities.warning.global <- FALSE iterate.residmod <- function(parent, abs.resids, method, exponent, lambda, conv, clamp, minspan, trace, parent.x, parent.y, ...) { varmod <- NULL max.iter <- 50 weights <- rep(1, nrow(parent.y)) residmod <- NULL # following is needed because we want to issue singular warning at most once assignInMyNamespace("issued.singularities.warning.global", FALSE) # we always build the trace tab but only print it # if tracing is enabled or convergence failed trace.tab <- NULL for(iter in 1:max.iter) { residmod <- get.residmod(method, exponent, minspan, parent.x, parent.y, abs.resids, weights, trace, iter, parent, residmod, ...) coef.change <- get.coef.change(method, iter, residmod) # fill in enough of varmod for predict.varmod in get.residmod.weights varmod$parent <- parent varmod$method <- method varmod$exponent <- exponent varmod$lambda <- lambda varmod$residmod <- residmod varmod$min.sd <- get.min.sd(residmod, lambda, clamp) class(varmod) <- "varmod" weights <- get.residmod.weights(varmod, iter, trace) trace.tab <- update.trace.tab(trace.tab, trace, iter, max.iter, residmod, varmod, coef, coef.change, parent.y, weights, exponent) if(residmod.converged(coef.change, conv, iter, max.iter, method)) break } converged <- residmod.converged(coef.change, conv, iter, max.iter, method) if(trace >= TRACE.VARMOD) { # || anyNA(coef(residmod)) || (conv >= 0 && !converged)) if(trace == TRACE.VARMOD.DETAILS && inherits(residmod, "nls")) printf("\n") print(trace.tab[1:iter,], row.names=FALSE, digits=2) } if(!converged) warnf("varmod did not converge after %d iters (%s), final coefchange %.1f%%", iter, get.non.convergence.reason(trace.tab), mean(abs(coef.change))) list(residmod=residmod, converged=converged, iters=iter) } blank.plot <- function(main=NULL) { plot(0, 0, col=0, bty="n", xlab="", ylab="", xaxt="n", yaxt="n", main=main) } trace.ncoef.global <- 0 update.trace.tab <- function(trace.tab, trace, iter, max.iter, residmod, varmod, coef, coef.change, parent.y, weights, exponent) { if(trace == TRACE.VARMOD.DETAILS) { if(inherits(residmod, "nls")) printf("\n") plotmo::plotmo(varmod, type="abs.residual", do.par=FALSE, degree1=1, degree2=0, trace=-1, pt.col=1, degree1.col=2, degree1.lwd=3, main="residmod first predictor") } coef <- coef(residmod) if(iter == 1) { # following needed because nbr of earth coefs can change assignInMyNamespace("trace.ncoef.global", length(coef)) trace.tab <- as.data.frame(matrix(NA, nrow=max.iter, ncol=3+trace.ncoef.global)) colnames(trace.tab) <- c(" iter", "weight.ratio", "coefchange%", fix.coef.names(names(coef), colnames(parent.y), exponent)) } trace.tab[iter,] <- c(iter, max(weights) / min(weights), mean(abs(coef.change)), c(coef, repl(NA, trace.ncoef.global))[1:trace.ncoef.global]) trace.tab } # For debugging non-convergence. In simulation about .4% of runs # did not converge, mostly "oscillating", nearly all with sample # sizes of less than 100. get.non.convergence.reason <- function(trace.tab) { nrow <- nrow(trace.tab) if(nrow < 7) return <- "short tab" # should never return this coefchange <- trace.tab[,"coefchange%"] c6 <- coefchange[nrow-6] c5 <- coefchange[nrow-5] c4 <- coefchange[nrow-4] c3 <- coefchange[nrow-3] c2 <- coefchange[nrow-2] c1 <- coefchange[nrow-1] c0 <- coefchange[nrow-0] # Example for oscillating: # iter weight.ratio coefchange% (Intercept) y # 27 57 big c3 3.7 0.00972 0.089 # 28 63 small c2 3.4 0.00921 0.091 # 29 57 big c1 3.5 0.00971 0.089 # 30 62 small c0 3.3 0.00922 0.091 if(c0 < c1 && c1 > c2 && c2 < c3 && c3 > c0) return("oscillating-lo") # oscillating, last iter lower than prev else if(c0 > c1 && c1 < c2 && c2 > c3 && c3 < c0) return("oscillating-hi") # oscillating, last iter higher than prev if(c2 > c1 && c1 > c0) { # only last two converged reason <- "converging2" if(c3 > c2) { # only last three converged reason <- "converging3" if(c4 > c3) { # only last four converged reason <- "converging4" if(c5 > c4) { # only last five converged reason <- "converging5" if(c6 > c5) # last six converged reason <- "converging6" } } } return(reason) } if(c2 < c1 && c1 < c0) { # last two diverged reason <- "diverging2" if(c3 < c2) { # last three diverged reason <- "diverging3" if(c4 < c3) { # last four diverged reason <- "diverging4" if(c5 < c4) { # last five diverged reason <- "diverging5" if(c6 < c5) # last six diverged reason <- "diverging6" } } } return(reason) } "non-monotonic" # can find no other pattern } get.residmod <- function(method, exponent, minspan, parent.x, parent.y, abs.resids, weights, trace, iter, parent, prev.residmod, ...) { switch(method, const = residmod.const(parent.x, parent.y, abs.resids, weights, trace), power = residmod.power(exponent, parent.x, parent.y, abs.resids, weights, trace, parent, prev.residmod, iter, ...), power0 = residmod.power0(exponent, parent.x, parent.y, abs.resids, weights, trace, parent, prev.residmod, iter, ...), lm = residmod.lm(exponent, parent.x, parent.y, abs.resids, weights, trace, parent, ...), rlm = residmod.rlm(exponent, parent.x, parent.y, abs.resids, weights, trace, parent, ...), earth = residmod.earth(exponent, minspan, parent.x, parent.y, abs.resids, weights, trace, parent, ...), gam = residmod.gam(exponent, parent.x, parent.y, abs.resids, weights, trace, parent, iter, ...), x.lm = residmod.x.lm(exponent, parent.x, parent.y, abs.resids, weights, trace, ...), x.rlm = residmod.x.rlm(exponent, parent.x, parent.y, abs.resids, weights, trace, ...), x.earth = residmod.x.earth(exponent, minspan, parent.x, parent.y, abs.resids, weights, trace, ...), x.gam = residmod.x.gam(exponent, parent.x, parent.y, abs.resids, weights, trace, iter, ...), stop0("illegal varmod.method \"", method, "\"")) } prev.coef.global <- NULL get.coef.change <- function(method, iter, residmod) # returns percents for each coef { coef <- coef(residmod) # lm sometimes returns 2nd coef as NA if resids are all the same # TODO this should be an error? --- but that halts simulation tests if(anyNA(coef)) { if(!issued.singularities.warning.global) { warning0("singularities in residual model (coefs ", paste.collapse(coef), ")") assignInMyNamespace("issued.singularities.warning.global", TRUE) } coef[is.na(coef)] <- 0 } if(iter == 1) assignInMyNamespace("prev.coef.global", coef) if(method %in% c("earth", "x.earth")) # see comments in residmod.converged if(length(prev.coef.global) != length(coef)) return(9999) coef.change <- abs(coef - prev.coef.global) prev <- abs(prev.coef.global) assignInMyNamespace("prev.coef.global", coef) # Divide by absolute value of previous coefficients. # But ensure no divide by near zero, by downweighting extremely small # coefs, thus preventing them from completely dominating the mean # change if the rest are large. # The 1e-8 prevents noise floor coefficients from preventing convergence. min <- max(.01 * max(prev), 1e-8) prev[prev < min] <- min 100 * coef.change / prev # a percentage for each coef } residmod.converged <- function(coef.change, conv, iter, max.iter, method) { if(conv < 0) iter >= abs(conv) else { method == "const" || # TODO Since the earth basis funcs can change, looking at changes # in the coefs can't be used to determine convergence. # So for now, always do 1 iter for earth residual models. (method %in% c("earth", "x.earth")) || # TODO following will sometimes create an intercept only model so unused # (method %in% c("earth", "x.earth") && iter >= 2) || iter > 1 && mean(abs(coef.change)) < conv } } draw.residmod.weights <- function(w, main, min=NA, max=NA, median=NA) # for debugging { plot(w, type="l", main=main, ylim=c(0, max(w, if(is.na(max)) 0 else max))) if(!is.na(min)) { abline(h=min, col=2) abline(h=max, col=2) abline(h=median, col=2) } else legend("topright", sprint("max/min %.0f", max(w) / min(w))) lines(w) # replot over other annotations } # clamp to prevent extreme weights after squaring and inverse in get.residmod.weights clamp.se <- function(se, iter, trace) { median <- median(se) max.ratio <- 5 # 5 seems ok with (limited) simulation studies min <- median / max.ratio max <- max.ratio * median if(trace == TRACE.VARMOD.DETAILS) draw.residmod.weights(se, main=sprint("iter %d: se", iter), min, max, median) se[se < min] <- min se[se > max] <- max se } # The variance for a regression on absolute residuals is proportional to # the square of the regression model predicted value (Carrol and Ruppert # book Section 3.3.3 and Table 3.3). get.residmod.weights <- function(object, iter=0, trace=0) { check.classname(object, substitute(object), "varmod") # square to convert se to variance, inverse to convert variance to weight weights <- 1 / clamp.se(predict.varmod(object, type="se"), iter, trace)^2 # normalization is not strictly necessary, may help numerics weights <- weights / mean(weights) if(trace == TRACE.VARMOD.DETAILS) draw.residmod.weights(weights, "weights") weights } # We calculate lamba.factor.global only when necessary because the # calculation can be slow. Hence we need the following global variables. lamba.global <- lamba.factor.global <- -999 update.lambda.factor <- function(lambda, trace) { approx.equal <- function(x, y) { # allow for limited precision in doubles, also allows .33 for 1/3 abs(x - y) < 1e-2 } #--- update.lambda.factor starts here --- if(lambda != lamba.global) { assignInMyNamespace("lamba.global", lambda) # some values have been precalculated if(approx.equal(lambda, 2)) assignInMyNamespace("lamba.factor.global", 1) # sqrt(pi / 2) = 1.2533, ratio mean dev to stddev, Geary 1935 else if(approx.equal(lambda, 1)) assignInMyNamespace("lamba.factor.global", sqrt(pi / 2)) # (residuals^2)^(1/3) is approx normal by the Wilson-Hilferty # transform, although the left tail will still be short else if(approx.equal(lambda, 2/3)) assignInMyNamespace("lamba.factor.global", 1.2464) else { rnorm(1) # seems to be necessary to make .Random.seed available old.seed <- .Random.seed set.seed(1) # for reproducibility # 1e6 below could be bigger but then slow assignInMyNamespace("lamba.factor.global", 1 / mean(rnorm(1e6)^2 ^ (lambda/2))) set.seed(old.seed) } if(trace >= TRACE.VARMOD) printf("lambda %g lamba.factor %g\n", lambda, lamba.factor.global) } } # scale a prediction by the residmod back to a standard deviation to.sd <- function(abs.resids, lambda, trace=0) { update.lambda.factor(lambda, trace) # pmax is necessary to prevent e.g. sqrt of neg prediction from residmod (lamba.factor.global * pmax(abs.resids, 0)) ^ (1 / lambda) } get.min.sd <- function(residmod, lambda, clamp=.1) { predict <- predict(residmod) predict <- predict[predict > 0] stopifnot(length(predict) > 0) stopifnot(clamp >= 0, clamp <= 1) clamp * mean(to.sd(predict, lambda, 0)) } check.lambda.arg <- function(lambda) { check.numeric.scalar(lambda) if(lambda < .25 || lambda > 2) stop0("lambda=", lambda, " but it should be between 0.25 and 2") } # TRUE if estimation of variance depends only on the fitted response (not on x) method.uses.fitted.response <- function(method) { method %in% c("power", "power0", "lm", "rlm", "earth", "gam") } check.exponent.arg <- function(exponent, method) { check.numeric.scalar(exponent) # TODO following restriction could be lifted but currently only partially implemented if(exponent != 1 && !method.uses.fitted.response(method)) stop0("varmod.exponent argument is not allowed with method=\"", method, "\"\n", "(varmod.exponent is only allowed for varmod.methods that depend only ", "on the fitted response)") if(exponent < .1 || exponent > 5) stop0("varmod.exponent=", exponent, " but it should be between .1 and 5") } check.conv.arg <- function(conv) { err <- function(conv) stop0("varmod.conv=", conv, " but it should be a negative integer ", "or a percent between 0 and 100") check.numeric.scalar(conv) if(conv < 0) { if(floor(conv) != conv) # conv is negative, check that it is an integer err(conv) } else if(conv == 0 || conv > 100) err(conv) } check.clamp.arg <- function(clamp) { check.numeric.scalar(clamp) if(clamp < 0 || clamp > 1) stop0("varmod.clamp=", clamp, " but it should be between 0 and 1") } residmod.const <- function(parent.x, parent.y, abs.resids, weights, trace) { # Predictions can be handled in a simple consistent way in # residmod.predict if instead of calculating the variance directly # here, we achieve the same result by building an intercept-only model # which always predicts mean(abs.resids). # # The conversion to a dataframe is necessary if the user later calls # plot(parent$varmod$residmod) or plotmo(parent$varmod$residmod). # Note that plotmo will call predict.varmod via predict.earth. data <- data.frame(abs.resids, parent.x) colnames(data) <- c("abs.resids", colnames(parent.x)) lm(abs.resids~1, data=data, weights=weights, y=TRUE) } apply.exponent <- function(yhat, exponent, yname=colnames(yhat)) { stopifnot(!is.null(yname)) check.vec(yhat, "yhat") # exponents of neg numbers are allowed only for integer exponents if(floor(exponent) != exponent) { check.that.most.are.positive( yhat, yname, sprint("exponent=%g", exponent), "nonpositive") yhat[yhat < 0] <- 0 # don't want to take say sqrt of a neg number } yhat ^ exponent } nls.wrapper <- function(form, data, start, weights, abs.resids, trace) { # We use algorithm="port" below because the default algorithm more often causes # "Error in numericDeriv: Missing value or an infinity produced" # Also, on test data we sometimes need more iterations than the default 50 mod <- nls(formula=form, data=data, start=start, weights=weights, trace=(trace == TRACE.VARMOD.DETAILS), algorithm="port", control=list(maxiter=100)) # make model data available for plotmo and plotres mod$x <- data[,-1,drop=FALSE] mod$y <- abs.resids # nls doesn't save the terms, so call$formula can confuse plotmo and plotres mod$call <- NULL mod } estimate.power.start.values <- function(prev.residmod, abs.resids, data, weights, trace, iter) { if(is.null(prev.residmod)) { # first iteration in iterate.residmod? # use a linear model to estimate the start values lm <- lm(abs.resids~., data=data, weights=weights) coefs <- coef(lm) if(trace == TRACE.VARMOD.DETAILS) { plotmo::plotmo(lm, pt.col=2, do.par=FALSE, trace=-1, main=sprint("iter 1: lm for start vals\nvarmod.method=\"power\"")) plot(lm, which=1) blank.plot() } start <- list(coefs[1], coefs[2], exponent=1) if(trace >= TRACE.VARMOD) printf( "\n start: (Intercept)=%.2g coef=%.2g exponent=%.2g\n\n", start[[1]], start[[2]], start[[3]]) } else { # not first iteration # use previous model values as starting values coefs <- coef(prev.residmod) stopifnot(length(coefs) == 3) start <- list(coefs[1], coefs[2], coefs[3]) } names(start) <- c("(Intercept)", "coef", "exponent") if(trace == TRACE.VARMOD.DETAILS) cat(sprint("iter %d RSS: ", iter), names(start), "\n") start } residmod.power <- function(exponent, parent.x, parent.y, abs.resids, weights, trace, parent, prev.residmod, iter, ...) { if(exponent != 1) # TODO allow this? stop0("the exponent argument is not allowed with varmod.method=\"power\"") parent.fit <- predict(parent) check.that.most.are.positive( parent.fit, "predict(parent)", "varmod.method=\"power\"", "nonpositive") parent.fit[parent.fit < 0] <- 0 # force negative values to zero form <- abs.resids~`(Intercept)` + coef * RHS^exponent data <- data.frame(abs.resids, apply.exponent(parent.fit, exponent)) colnames(data) <- c("abs.resids", "RHS") start <- estimate.power.start.values(prev.residmod, abs.resids, data, weights, trace, iter) nls.wrapper(form, data, start, weights, abs.resids, trace) } estimate.power0.start.values <- function(prev.residmod, abs.resids, data, weights, trace, iter) { if(is.null(prev.residmod)) { # first iteration in iterate.residmod? # use a linear model to estimate the start values lm <- lm(abs.resids~.-1, data=data, weights=weights) coefs <- coef(lm) if(trace == TRACE.VARMOD.DETAILS) { plotmo::plotmo(lm, pt.col=2, do.par=FALSE, trace=-1, main=sprint("iter 1: lm for start vals\nvarmod.method=\"power0\"")) plot(lm, which=1) blank.plot() } start <- list(coefs[1], exponent=1) if(trace >= TRACE.VARMOD) printf( "\n start: coef=%.2g exponent=%.2g\n\n", start[[1]], start[[2]]) } else { # not first iteration # use previous model values as starting values coefs <- coef(prev.residmod) stopifnot(length(coefs) == 2) start <- list(coefs[1], coefs[2]) } names(start) <- c("coef", "exponent") if(trace == TRACE.VARMOD.DETAILS) cat(sprint("iter %d RSS: ", iter), names(start), "\n") start } residmod.power0 <- function(exponent, parent.x, parent.y, abs.resids, weights, trace, parent, prev.residmod, iter, ...) { if(exponent != 1) # TODO allow this? stop0("the exponent argument is not allowed with varmod.method=\"power0\"") parent.fit <- predict(parent) check.that.most.are.positive( parent.fit, "predict(parent)", "varmod.method=\"power0\"", "nonpositive") parent.fit[parent.fit < 0] <- 0 # force negative values to zero data <- data.frame(abs.resids, apply.exponent(parent.fit, exponent)) colnames(data) <- c("abs.resids", "RHS") start <- estimate.power0.start.values(prev.residmod, abs.resids, data, weights, trace, iter) nls.wrapper(abs.resids~coef * RHS^exponent, data, start, weights, abs.resids, trace) } residmod.lm <- function(exponent, parent.x, parent.y, abs.resids, weights, trace, parent, ...) { # we use RHS instead of colnames(parent.y) because we have applied exponent data <- data.frame(abs.resids, apply.exponent(predict(parent), exponent)) colnames(data) <- c("abs.resids", "RHS") lm(abs.resids~., data=data, weights=weights, y=TRUE) } residmod.rlm <- function(exponent, parent.x, parent.y, abs.resids, weights, trace, parent, ...) { # we use RHS instead of colnames(parent.y) because we have applied exponent data <- data.frame(abs.resids, apply.exponent(predict(parent), exponent)) colnames(data) <- c("abs.resids", "RHS") mod <- MASS::rlm(abs.resids~., data=data, weights=weights, method="MM") # make model data available for plotmo and plotres mod$data <- data mod } residmod.earth <- function(exponent, minspan, parent.x, parent.y, abs.resids, weights, trace, parent, ...) { data <- data.frame(abs.resids, apply.exponent(predict(parent), exponent)) colnames(data) <- c("abs.resids", "RHS") earth(abs.resids~., data=data, weights=weights, keepxy=TRUE, trace=trace, minspan=minspan, ...) } please.load.gam.package <- function() { stop0("please load either the gam or mgcv package before using varmod.method=\"gam\"") } # Do we use the gam function in the gam or the mgcv package? # Note that library(gam) has to be used before calling gam::gam, else the # wrong "s" function is invoked. This is because requireNamespace(gam) # doesn't work there, even if we use gam::s when invoking gam. # But CRAN check disallows library(gam) in the code (as from Jan 2015). # So we have to ask the user to manually load the package if it is not loaded. which.gam.package.is.loaded <- function() { 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("varmod.method=\"gam\" is not allowed when both the ", "'gam' and 'mgcv' packages are loaded") } if(gam.package.loaded) return("gam") if(mgcv.package.loaded) return("mgcv") please.load.gam.package() } which.package <- function(method) { if(method %in% c("gam", "x.gam")) { if("package:gam" %in% search()) return("gam") if("package:mgcv" %in% search()) return("mgcv") } NULL } residmod.gam.aux <- function(form, data, weights, trace, iter) { package.name <- which.gam.package.is.loaded() if(package.name == "gam") { if(trace >= TRACE.VARMOD && iter==1) printf("using the gam function from the 'gam' package\n") residmod <- gam::gam(formula=form, data=data, weights=weights) # We don't use x=TRUE else the x has colnames like s(x) which # confuses things later. But we do save the data for plotmo. residmod$data <- data } else if(package.name == "mgcv") { if(trace >= TRACE.VARMOD && iter==1) printf("using the gam function from the 'mgcv' package\n") residmod <- mgcv::gam(formula=form, data=data, weights=weights) residmod$data <- data # for later access by plotmo etc. } else please.load.gam.package() residmod } residmod.gam <- function(exponent, parent.x, parent.y, abs.resids, weights, trace, parent, iter, ...) { form <- abs.resids ~ s(RHS) RHS <- apply.exponent(predict(parent), exponent) data <- data.frame(abs.resids, RHS) colnames(data) <- c("abs.resids", "RHS") residmod.gam.aux(form, data, weights, trace, iter) } residmod.x.lm <- function(exponent, parent.x, parent.y, abs.resids, weights, trace, ...) { if(exponent != 1) stop0("the exponent argument is not allowed with varmod.method=\"x.lm\"") data <- data.frame(abs.resids, parent.x) colnames(data) <- c("abs.resids", colnames(parent.x)) lm(abs.resids~., data=data, weights=weights, y=TRUE) } residmod.x.rlm <- function(exponent, parent.x, parent.y, abs.resids, weights, trace, ...) { if(exponent != 1) stop0("the exponent argument is not allowed with varmod.method=\"x.rlm\"") data <- data.frame(abs.resids, parent.x) colnames(data) <- c("abs.resids", colnames(parent.x)) mod <- MASS::rlm(abs.resids~., data=data, weights=weights, method="MM", y.ret=TRUE) # make model data available for plotmo and plotres mod$y <- abs.resids mod } residmod.x.earth <- function(exponent, minspan, parent.x, parent.y, abs.resids, weights, trace, ...) { if(exponent != 1) stop0("the exponent argument is not allowed with varmod.method=\"x.earth\"") data <- data.frame(abs.resids, parent.x) colnames(data) <- c("abs.resids", colnames(parent.x)) earth(abs.resids~., data=data, weights=weights, keepxy=TRUE, trace=trace, minspan=minspan, ...) } residmod.x.gam <- function(exponent, parent.x, parent.y, abs.resids, weights, trace, iter, ...) { if(exponent != 1) stop0("the exponent argument is not allowed with varmod.method=\"x.gam\"") if(ncol(parent.x) != 1) stop0("varmod.method=\"x.gam\" is not allowed when x has more than one column") form <- abs.resids ~ s(RHS) RHS <- parent.x[,1] data <- data.frame(abs.resids=abs.resids, RHS=RHS) colnames(data) <- c("abs.resids", "RHS") residmod.gam.aux(form, data, weights, trace, iter) } get.quant <- function(level) # e.g for level=.95 return 1.96 { check.level.arg(level, zero.ok=FALSE) stopifnot(level > 0, level < 1) level <- 1 - (1 - level) / 2 # .95 becomes .975 qnorm(level) # .975 becomes 1.96 } predict.se <- function(object, newdata) { to.sd(predict.abs.residual(object, newdata), object$lambda) } predict.abs.residual <- function(object, newdata) { # unfortunately needed to get model formulas to work for some varmod methods hack.colnames <- function(newdata, method) { if(!is.null(newdata) && method %in% c("power", "power0", "lm", "rlm", "earth", "gam", "x.gam")) { if(NCOL(newdata) != 1) { stop0("predict.varmod: NCOL(newdata) must be 1 ", "when method=\"", method, "\" (implementation restriction)") } newdata <- as.data.frame(newdata) colnames(newdata) <- "RHS" } newdata } if(is.null(newdata)) abs.resid <- predict(object$residmod) else if(method.uses.fitted.response(object$method)) { parent.fit <- predict(object$parent, newdata=newdata) parent.fit <- apply.exponent(parent.fit, object$exponent) parent.fit <- data.frame(parent.fit) parent.fit <- hack.colnames(parent.fit, object$method) if(object$method %in% c("power", "power0")) parent.fit[parent.fit < 0] <- 0 # force negative values to zero abs.resid <- predict(object$residmod, newdata=parent.fit) stopifnot(length(abs.resid) == NROW(parent.fit)) } else { newdata <- hack.colnames(newdata, object$method) abs.resid <- predict(object$residmod, newdata=newdata) stopifnot(length(abs.resid) == NROW(newdata)) } abs.resid <- as.vector(abs.resid) # clamp at object$min.sd min.abs.resid <- (object$min.sd ^ object$lambda) / lamba.factor.global pmax(abs.resid, min.abs.resid) } get.parent.fit <- function(object, newdata) { parent.fit <- predict(object$parent, newdata=newdata) check.vec(parent.fit, "parent.fit") stopifnot(!is.null(dim(parent.fit))) # check parent.fit is a matrix or dataframe parent.fit[,1] } predict.pint <- function(object, newdata, level) # newdata allowed { se <- predict.se(object, newdata) parent.fit <- get.parent.fit(object, newdata) stopifnot(length(parent.fit) == length(se)) quant <- get.quant(level) data.frame(fit = parent.fit, lwr = parent.fit - quant * se, upr = parent.fit + quant * se) } predict.cint <- function(object, newdata, level) { if(!is.null(newdata)) stop0("predict.varmod: newdata is not allowed with interval=\"cint\"") parent.fit <- get.parent.fit(object, newdata) se <- sqrt(object$model.var) stopifnot(length(se) == length(parent.fit)) quant <- get.quant(level) data.frame(fit = parent.fit, lwr = parent.fit - quant * se, upr = parent.fit + quant * se) } predict.varmod <- function( object = stop("no 'object' argument"), newdata = NULL, type = c("pint", "cint", "se", "abs.residual"), level = .95, trace = FALSE, # unused but needed for plotmo ...) { check.level95 <- function(level) { check.level.arg(level, zero.ok=TRUE) if(level != .95) stop0("predict.varmod: the level argument is not allowed with type=\"", type, "\"") } check.classname(object, substitute(object), "varmod") warn.if.dots(...) switch(match.arg1(type, "type"), pint = predict.pint(object, newdata, level), cint = predict.cint(object, newdata, level), se = { check.level95(level) predict.se(object, newdata) }, abs.residual = { check.level95(level) predict.abs.residual(object, newdata) }) } # Example: if digits=3, then "%.*f" becomes "%.3f" # Needed because R printf doesn't support * in printf formats # and we need it to make the digits arg work in printfs dot.star.to.digits <- function(s, digits) { check.integer.scalar(digits, min=1) stopifnot(floor(digits) == digits) stopifnot(digits > 0, digits < 20) gsub(".*", sprint(".%d", digits), s, fixed=TRUE) } # Example: # fix.coef.names(coef.names=h(y-123), resp.name="y", exponent=.5) # returns # h(sqrt(y)-123) # the func knows that the special case of exponent=.5 is sqrt fix.coef.names <- function(coef.names, resp.name, exponent) { if(length(coef.names) == 1) return(coef.names) # do nothing if intercept only model stopifnot(length(resp.name) == 1) stopifnot(exponent > 0) new.resp.name <- if(exponent > .33 && exponent < .34) sprint("cbrt(%s)", resp.name) else if(exponent == .5) sprint("sqrt(%s)", resp.name) else if(exponent == 1) resp.name else if(exponent == 2) sprint("sq(%s)", resp.name) else sprint("%s^%.3g", resp.name, exponent) coef.names <- gsub("RHS", resp.name, coef.names, fixed=TRUE) if(exponent == 1) coef.names else { # TODO revisit, will fail if resp.name is substring of a token in # coef.names or if resp.name="h" and coef.names="h(h-12)" gsub(resp.name, new.resp.name, coef.names, fixed=TRUE) } } # restore original exponent, it doesn't get scaled like the other coefficients restore.exponent <- function(coef, org.coef, method) { if(method == "power") coef[3] <- org.coef[3] # exponent is in coef[3] else if(method == "power0") coef[2] <- org.coef[2] # exponent is in coef[2] coef } coef.varmod <- function(object, as.sd=TRUE, ...) { warn.if.dots(...) coef <- coef(object$residmod) if(is.null(coef)) stop0("coef.varmod: cannot get coefficients for \"", class(object$residmod)[1], "\" residmod") as.sd <- check.boolean(as.sd) if(as.sd) { org.coef <- coef negs <- coef < 0 coef <- to.sd(abs(coef), object$lambda) coef[negs] <- -coef[negs] coef <- restore.exponent(coef, org.coef, object$method) } names(coef) <- fix.coef.names(names(coef), colnames(object$parent.y), object$exponent) coef } VARMOD.COEF.TAB.STYLES <- c("standard", "unit") get.varmod.coef.tab <- function( object, style = VARMOD.COEF.TAB.STYLES) { style <- match.arg1(style, "style") coef <- coef.varmod(object, as.sd=TRUE) # if style="unit", normalize coef if possible unit <- 1 if(style == "unit") { # choose which coef will be the unit if(length(coef) == 1) # method == "const"? unit <- abs(coef[1]) else unit <- abs(coef[2]) if(unit < 1e-3) { warning0("coef=", unit, " is very small, forcing style=\"standard\"\n") style <- "standard" unit <- 1 } } org.coef <- coef coef <- coef / unit coef <- restore.exponent(coef, org.coef, object$method) # get stderr NAs <- repl(NA, length(coef)) stderr <- NAs if(!is.null(object$iter.stderr)) { org.stderr <- object$iter.stderr stderr <- to.sd(org.stderr, object$lambda) / unit stderr <- restore.exponent(stderr, org.stderr, object$method) } abs.coef <- abs(coef) stderr.percent <- 100 * stderr / abs.coef coef.names <- names(coef) coef.names <- gsub("`", "", coef.names) # remove backquotes added by lm etc. if(style == "unit") { coef.tab <- data.frame(c(coef, unit), c(stderr, NA), c(stderr.percent, NA)) rownames(coef.tab) <- c(coef.names, "unit") } else { coef.tab <- data.frame(coef, stderr, stderr.percent) rownames(coef.tab) <- coef.names } if(object$method %in% c("earth", "x.earth")) { order <- reorder.earth(object$residmod, decomp="anova") coef.tab <- coef.tab[order,] } colnames(coef.tab) <- c("coefficients", "iter.stderr", "iter.stderr.percent") coef.tab } get.interval.tab <- function(object, level) { level <- check.level.arg(level, zero.ok=FALSE) predict <- predict.varmod(object, type="pint", level=level) interval <- predict$upr - predict$lwr interval <- interval[order(interval)] tab <- data.frame( " ", mean(interval), " ", interval[1], " ", interval[length(interval)], " ", interval[length(interval)] / interval[1]) colnames(tab) <- c( " ", "mean", " ", "smallest", " ", "largest", " ", "ratio") rownames(tab) <- sprint("%g%% prediction interval", 100*level) tab } percent.inconf <- function(object, level, parent.y, newdata) { predict <- predict.varmod(object, newdata, type="pint", level=level) inconf <- parent.y >= predict$lwr & parent.y <= predict$upr 100 * sum(inconf) / length(inconf) } print_inconf_tab <- function(object, parent.y, newdata) { if(NCOL(parent.y) != 1) { warning0("multiple response model: the table is for the first response") parent.y <- parent.y[,1] } stopifnot(is.numeric(parent.y) || is.logical(parent.y)) inconf68 <- percent.inconf(object, .68, parent.y, newdata) inconf80 <- percent.inconf(object, .80, parent.y, newdata) inconf90 <- percent.inconf(object, .90, parent.y, newdata) inconf95 <- percent.inconf(object, .95, parent.y, newdata) # .5 below adjusts for rounding in printf %.0f lt <- function(x, level) if(x < level-.5) "<" else " " tab <- data.frame( " ", sprint("%.0f%s ", inconf68, lt(inconf68, 68)), " ", sprint("%.0f%s ", inconf80, lt(inconf80, 80)), " ", sprint("%.0f%s ", inconf90, lt(inconf90, 90)), " ", sprint("%.0f%s ", inconf95, lt(inconf95, 95))) colnames(tab) <- c( " ", "68% ", " ", "80% ", " ", "90% ", " ", "95% ") if(is.null(newdata)) rowname <- "response values in prediction interval" else rowname <- "newdata in prediction interval" rownames(tab) <- rowname print(tab) # return value is the table but not in string form tab <- data.frame(inconf68, inconf80, inconf90, inconf95) colnames(tab) <- c("68%", "80%", "90%", "95%") rownames(tab) <- rowname tab } print.varmod <- function( x = stop("no 'x' argument"), # x is a varmod object level = .95, # use 0 to not print the interval tabs style = "standard", # one of VARMOD.COEF.TAB.STYLES digits = 2, newdata = NULL, ...) { check.classname(x, substitute(x), "varmod") object <- x # minimize confusion with x, the regression input matrix remove(x) # not necessary but prevents mistakes later warn.if.dots(...) if(!is.null(newdata)) { # if newdata, print just the inconf table object$inconf.tab <- print_inconf_tab(object, plotmo::plotmo_response(object$parent, newdata, trace=0, ...), newdata) return(invisible(object)) } printf("method \"%s\"", object$method) if(!is.null(object$package)) printf(" (%s package)", object$package) space <- if(object$exponent != 1 || object$lambda != 1) "" else " " if(object$exponent != 1) printf("%s exponent %.3f", space, object$exponent) if(object$lambda != 1) printf("%s lambda %g", space, object$lambda) printf("%s min.sd %.3g", space, object$min.sd) if(!is.null(object$iter.rsq)) { printf("%s iter.rsq %.3f", space, object$iter.rsq) # TODO prints too many digits # printf(dot.star.to.digits(", iter.rsq %.*f", digits+1), object$iter.rsq) } # coef tab printf("\n\nstddev of predictions%s:\n", if(style == "unit") " (scaled by unit)" else "") tab <- object$coef.tab if(is.null(tab)) { # needed if did not come here via summary.varmod tab <- get.varmod.coef.tab(object, style) object$coef.tab <- tab # for return value of this function } tab$coefficients <- zapsmall(tab$coefficients, digits+1) # sprint below so print "NA" not "" tab$iter.stderr <- sprint("%g", zapsmall(tab$iter.stderr, digits)) # convert iter.stderr.percent to character and print "big" if appropriate tab$iter.stderr.percent.as.char <- sprint("%.0f", tab$iter.stderr.percent) tab$iter.stderr.percent.as.char[tab$iter.stderr.percent >= 1e3] <- "big" tab$iter.stderr.percent <- NULL colnames(tab) <- c("coefficients", "iter.stderr", "iter.stderr%") print(tab, digits=digits) # interval and inconf tabs level <- check.level.arg(level, zero.ok=TRUE) if(is.specified(level)) { stopifnot(level == object$level) printf("\n") tab <- object$interval.tab if(is.null(tab)) { tab <- get.interval.tab(object, level) object$interval.tab <- tab # for return value of this function } print(tab, digits=digits) printf("\n") object$inconf.tab <- print_inconf_tab(object, object$parent.y, newdata=NULL) } invisible(object) } print.summary.varmod <- function( x = stop("no 'x' argument"), # x is a summary.varmod object level = x$level, style = x$style, digits = x$digits, newdata = x$newdata, ...) { check.classname(x, substitute(x), "varmod") warn.if.dots(...) if(is.null(level)) level <- .95 if(is.null(style)) style <- "standard" if(is.null(digits)) digits <- 2 if(!is.null(newdata)) # if newdata, print just the inconf table print.varmod(x, level, style, digits, newdata) else { printcall("Parent model: ", x$parent$call) printf("\n") print.varmod(x, level, style, digits) printf("\nRegression submodel (%s):\n", get.resids.name(x)) if(!(class(x$residmod)[1] %in% c("lm", "x.lm"))) printf("\n") print(x$residmod, digits=digits) } invisible(x) } summary.varmod <- function( object = stop("no 'object' argument"), level = .95, style = "standard", # one of VARMOD.COEF.TAB.STYLES digits = 2, newdata = NULL, ...) { check.classname(object, substitute(object), "varmod") warn.if.dots(...) object$level <- level # pass level on to print.summary.varmod object$style <- style # ditto object$digits <- digits # ditto object$newdata <- newdata # ditto object$coef.tab <- get.varmod.coef.tab(object, style) object$interval.tab <- get.interval.tab(object, level) # TODO add inconf table here too class(object) <- c("summary.varmod", "varmod") object } get.resids.name <- function(object) { if(object$lambda == 1) sprint("Abs Residuals") else if(object$lambda == 2) sprint("Squared Residuals") else sprint("(Squared Residuals) ^ %.2g", object$lambda / 2) } get.varmod.ylab <- function(object, as.sd) { sprint("ParentMod %s", if(as.sd) "StdDev" else get.resids.name(object)) } min.sd.line <- function(object, min.sd.col, lwd) # draw horizontal line at min.sd { if(is.specified(min.sd.col)) { # TODO need to apply lambda exponent here? abline(h=object$min.sd / lamba.factor.global, col=min.sd.col, lty=2, lwd=lwd) } } sd.axis <- function(object) # draw righthand axis in standard deviation scale { # for righthand axis sd <- lamba.factor.global * object$abs.resids ^ (1 / object$lambda) pretty.sd <- pretty(range(sd)) axis(side=4, at=pretty.sd / lamba.factor.global, labels=pretty.sd, srt=90) # the line setting depends on the axis margin lines mtext(get.varmod.ylab(object, as.sd=TRUE), side=4, cex=par("cex"), line=if(par("mgp")[1] < 1.8) 1.4 else 1.8) } plot.varmod <- function( x = stop("no 'x' argument"), which = 1:4, do.par = NULL, info = FALSE, cex = NULL, caption = NULL, line.col = 2, min.sd.col = line.col, trace = 0, ...) # unused, for compat with the generic { check.classname(x, substitute(x), "varmod") object <- x # minimize confusion with x, the regression input matrix remove(x) # needed else plotmo.x gets this x instead of the x matrix warn.if.dots(...) trace <- as.numeric(check.integer.scalar(trace, logical.ok=TRUE)) info <- check.boolean(info) check.index(which, "which", 1:4) do.par <- check.do.par(do.par, length(which)) # 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 stopifnot.string(caption, allow.empty=TRUE, null.ok=TRUE) if(length(which) > 1 && do.par && is.null(caption)) # auto caption? caption <- sprint("Variance Model method=\"%s\"\nParentMod: %s", object$method, strip.deparse(object$parent$call)) main <- dota("main", ...) if(do.par) { oldpar <- par(no.readonly=TRUE) do.par(nfigs=length(which), caption=caption, main1=main, xlab1=NULL, ylab1=NULL, trace=trace, nlines.in.main=2, def.right.mar=3, 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) } if(is.null(cex)) cex <- pt.cex(length(object$parent.y)) if(is.specified(main)) main <- repl(main, 4) # recycle for up to 4 plots ylim <- fix.lim(c(min(object$abs.resids, 0), max(object$abs.resids))) parent.fitted <- predict(object$parent)[,1] order <- order(parent.fitted) smooth.col <- if(info) 2 else 0 lwd <- 1 for(iwhich in seq_along(which)) { if(which[iwhich] == 1) { #--- fitted vs parent fitted --- plot(parent.fitted[order], object$abs.resids[order], main=if(!is.specified(main)) sprint("%s vs Fitted", get.resids.name(object)) else main[iwhich], ylim=ylim, pch=20, cex=cex, xlab="Fitted", ylab=get.varmod.ylab(object, as.sd=FALSE)) min.sd.line(object, min.sd.col, lwd) # horizontal line at min.sd sd.axis(object) # right hand axis in stddev scale # fitted values of residual model fitted <- predict.varmod(object, type="abs.residual") lines(parent.fitted[order], fitted[order], col=line.col, lwd=lwd) if(info) { # lowess smooth smooth <- lowess(parent.fitted[order], object$abs.resids[order], f=.5) lines(smooth$x, smooth$y, col=smooth.col, lwd=1) } } else if(which[iwhich] == 2) { #--- fitted vs parent first pred --- plotmo::plotmo(object, type="abs.residual", ylim=ylim, degree1=1, degree2=0, do.par=FALSE, trace=if(trace==0) -1 else trace, pt.col=1, pt.cex=cex, degree1.col=line.col, degree1.lwd=lwd, smooth.col=smooth.col, ylab=get.varmod.ylab(object, as.sd=FALSE), main=if(!is.specified(main)) sprint("%s vs First Predictor", get.resids.name(object)) else main[iwhich]) min.sd.line(object, min.sd.col, lwd) # horizontal line at min.sd sd.axis(object) # right hand axis in stddev scale } else if(which[iwhich] == 3) { #--- residual plot --- plotmo::plotres(object$residmod, which=3, do.par=FALSE, center=FALSE, xlab=get.varmod.ylab(object, as.sd=FALSE), ylab="VarMod Residuals", info=info) } else if(which[iwhich] == 4) { #--- model selection graph --- if(class(object$residmod)[1] == "earth") plot.earth(object$residmod, which=1, do.par=FALSE, main=if(!is.specified(main)) "VarMod Model Selection" else main[iwhich]) } else stopf("plot.varmod: illegal value %g in 'which' argument", which[iwhich]) } draw.caption(caption, ...) invisible() } earth/R/earth.cv.R0000644000176200001440000005504513447014622013427 0ustar liggesusers# earth.cv.R: Functions for cross validation of earth models. # Note that earth.cv returns null unless nfold > 1. earth.cv <- function(object, x, y, subset, weights, na.action, pmethod, keepxy, trace, glm.arg, degree, nprune, nfold, ncross, stratify, get.oof.fit.tab, get.oof.rsq.per.subset, Scale.y, env, ...) { get.fold.rsq.per.subset <- function(foldmod, oof.y, max.nterms, trace, must.print.dots) { wp.expanded <- wp.expanded / sum(wp.expanded) oof.rsq.per.subset <- infold.rsq.per.subset <- repl(0, max.nterms) # nrow(foldmod$dirs) is the number of terms in this fold's model before pruning for(nterms in 1:min(max.nterms, nrow(foldmod$dirs))) { trace.get.fold1(trace, must.print.dots, nterms) # penalty=-1 to enforce strict nprune TODO consider changing to pmethod=none # TODO with keepxy=TRUE, 70% of cv time is spent in update.earth pruned.foldmod <- update(foldmod, nprune=min(nprune, nterms), penalty=-1, ponly=TRUE, # glm=NULL for speed, ok because we don't need the glm submodel, # except if is.bpairs must convert bpairs to yfrac in pruned.foldmod glm=if(is.bpairs) glm.arg else NULL, trace=max(0, trace-1)) fit <- predict(pruned.foldmod, newdata=x, type="earth") oof.fit <- fit[oof.subset, , drop=FALSE] infold.fit <- fit[infold.subset, , drop=FALSE] for(iresp in seq_len(NCOL(fit))) { # for each response oof.rsq.per.subset[nterms] <- oof.rsq.per.subset[nterms] + wp.expanded[iresp] * get.weighted.rsq(oof.y[,iresp], oof.fit[,iresp], oof.weights) infold.rsq.per.subset[nterms] <- infold.rsq.per.subset[nterms] + wp.expanded[iresp] * get.weighted.rsq(infold.y[,iresp], infold.fit[,iresp], infold.weights) } if(nrow(foldmod$dirs) < max.nterms) for(nterms in (nrow(foldmod$dirs)+1): max.nterms) oof.rsq.per.subset[nterms] <- infold.rsq.per.subset[nterms] <- NA } trace.get.fold2(trace, must.print.dots, nterms) list(oof.rsq.per.subset = oof.rsq.per.subset, infold.rsq.per.subset = infold.rsq.per.subset) } #--- earth.cv starts here --- # We called check.cv.args(nfold, ncross, varmod.method, pmethod) # earlier so it's safe to use those args here # Likewise, subset arg was already checked in earth.fit. stratify <- check.boolean(stratify) stopifnot(nfold > 1, ncross >= 1) trace1(trace, "\n") if(nfold > nrow(x)) nfold <- nrow(x) is.bpairs <- !is.null(object$glm.bpairs) # response is glm binomial pairs nresp <- if(is.bpairs) 1 else ncol(y) # number of responses max.nterms <- nrow(object$dirs) wp <- wp.expanded <- object$wp if(is.null(wp)) wp.expanded <- repl(1, nresp) # all ones vector cv.list <- list() # returned list of cross validated models ncases <- nrow(x) # ndigits aligns trace prints without too much white space ndigits <- ceiling(log10(ncases)) # print pacifier dots if get.fold.rss.per.subset will be slow must.print.dots <- trace >= .5 && trace <= 1 && (get.oof.rsq.per.subset || get.oof.fit.tab) && nrow(x) * max.nterms > 50e3 trace.cv.header(object, nresp, trace, must.print.dots) groups <- matrix(NA, nrow=ncross*ncases, ncol=2) colnames(groups) <- c("cross", "fold") for(icross in seq_len(ncross)) { start <- ((icross-1) * ncases) + 1 groups[start:(start+ncases-1), 1] <- icross groups[start:(start+ncases-1), 2] <- get.groups(y, nfold, stratify) } is.binomial <- is.poisson <- FALSE if(!is.null(glm.arg)) { # TODO revisit the following to save memory? family <- get.glm.family(glm.arg$family, env=env) is.binomial <- is.binomial(family) is.poisson <- is.poisson(family) } must.get.class.rate <- !is.null(object$levels) # the final summary row of the tables is "mean", "all" or "max", depending on the statistic. if(ncross > 1) fold.names <- paste0(rep(paste0("fold", seq_len(ncross), "."), each=nfold), rep(seq_len(nfold), times=ncross)) else fold.names <- sprint("fold%d", seq_len(nfold)) fold.names.plus.mean <- c(fold.names, "mean") fold.names.plus.all <- c(fold.names, "all") fold.names.plus.max <- c(fold.names, "max") resp.names <- if(is.bpairs) colnames(y)[1] else colnames(y) resp.names.plus.mean <- c(resp.names, "mean") # response names plus "mean" resp.names.plus.max <- c(resp.names, "max") ncross.fold <- ncross * nfold nvars.selected.by.gcv <- double(ncross.fold+1) # nbr of used predictors in each CV mod nterms.selected.by.gcv <- double(ncross.fold+1) # nbr of selected terms in each CV mod names(nvars.selected.by.gcv) <- fold.names.plus.mean names(nterms.selected.by.gcv) <- fold.names.plus.mean rsq.tab <- matrix(0, nrow=ncross.fold+1, ncol=1+nresp) # table of cv results, +1 for means colnames(rsq.tab) <- resp.names.plus.mean rownames(rsq.tab) <- fold.names.plus.mean maxerr.tab <- matrix(0, nrow=ncross.fold+1, ncol=1+nresp) # table of cv results, +1 for max colnames(maxerr.tab) <- resp.names.plus.max rownames(maxerr.tab) <- fold.names.plus.max deviance.tab <- calib.int.tab <- calib.slope.tab <- test.tab <- class.rate.tab <- NULL if(is.binomial || is.poisson) { deviance.tab <- matrix(0, nrow=ncross.fold+1, ncol=1+nresp) # mean deviance calib.int.tab <- matrix(0, nrow=ncross.fold+1, ncol=1+nresp) calib.slope.tab <- matrix(0, nrow=ncross.fold+1, ncol=1+nresp) test.tab <- matrix(0, nrow=ncross.fold+1, ncol=1+nresp) # binomial auc, poisson cor colnames(deviance.tab) <- colnames(calib.int.tab) <- colnames(calib.slope.tab) <- colnames(test.tab) <- resp.names.plus.mean rownames(deviance.tab) <- rownames(calib.int.tab) <- rownames(calib.slope.tab) <- rownames(test.tab) <- fold.names.plus.mean } if(must.get.class.rate) { class.rate.tab <- matrix(0, nrow=ncross.fold+1, ncol=1+nresp) colnames(class.rate.tab) <- resp.names.plus.mean rownames(maxerr.tab) <- fold.names.plus.all } oof.rsq.tab <- infold.rsq.tab <- oof.fit.tab <- NULL if(get.oof.rsq.per.subset) { oof.rsq.tab <- infold.rsq.tab <- matrix(0, nrow=ncross.fold+1, ncol=max.nterms) colnames(oof.rsq.tab) <- colnames(infold.rsq.tab) <- paste0("nterms", 1:max.nterms) rownames(oof.rsq.tab) <- rownames(infold.rsq.tab) <- fold.names.plus.all } if(get.oof.fit.tab) { oof.fit.tab <- matrix(0, nrow=nrow(x), ncol=ncross) # preds on oof data colnames(oof.fit.tab) <- paste0("icross", seq_len(ncross)) } for(icross in seq_len(ncross)) { this.group <- get.this.group(icross, ifold, ncases, groups) for(ifold in seq_len(nfold)) { icross.fold <- ((icross-1) * nfold) + ifold oof.subset <- seq_len(ncases)[which(this.group == ifold)] infold.subset <- seq_len(ncases)[-oof.subset] trace.fold.header(trace, ncross, icross, ifold) infold.x <- x[infold.subset,,drop=FALSE] infold.y <- y[infold.subset,,drop=FALSE] infold.weights <- weights[infold.subset] foldmod <- earth.default(x=infold.x, y=infold.y, weights=infold.weights, wp=wp, Scale.y=Scale.y, subset=subset, trace=trace, glm=glm.arg, degree=degree, pmethod=if(pmethod == "cv") "backward" else pmethod, nfold=0, ncross=0, varmod.method="none", keepxy=(keepxy == 2), ...) foldmod$icross <- icross foldmod$ifold <- ifold oof.x <- x[oof.subset,,drop=FALSE] oof.y <- if(is.bpairs) object$glm.yfrac else y oof.y <- oof.y[oof.subset,,drop=FALSE] oof.weights <- weights[oof.subset] oof.fit <- predict(foldmod, newdata=oof.x, type="earth") # fill in subset of entries in this icross column of oof.fit.tab # note that we use only the first response when there are multiple responses if(!is.null(oof.fit.tab)) oof.fit.tab[oof.subset, icross] <- oof.fit[,1] oof.fit.resp <- NULL if(is.binomial || is.poisson) oof.fit.resp <- predict(foldmod, newdata=oof.x, type="response") else if(must.get.class.rate) # not glm but has binary response? oof.fit.resp <- oof.fit # fill in this fold's row in summary tabs for(iresp in seq_len(nresp)) { rsq.tab[icross.fold, iresp] <- get.weighted.rsq(oof.y[,iresp], oof.fit[,iresp], oof.weights) if(is.binomial) { deviance.tab[icross.fold, iresp] <- get.binomial.deviance(oof.fit.resp[,iresp], oof.y[,iresp]) calib <- get.binomial.calib(oof.fit.resp[,iresp], if(is.bpairs) y[oof.subset,] else oof.y[,iresp]) calib.int.tab[icross.fold, iresp] <- calib[1] calib.slope.tab[icross.fold, iresp] <- calib[2] maxerr.tab[icross.fold, iresp] <- get.maxerr(oof.y[,iresp] - oof.fit.resp[,iresp]) test.tab[icross.fold, iresp] <- get.auc(oof.fit.resp[,iresp], oof.y[,iresp]) } else if(is.poisson) { deviance.tab[icross.fold, iresp] <- get.poisson.deviance(oof.fit.resp[,iresp], oof.y[,iresp]) calib <- get.poisson.calib(oof.fit.resp[,iresp], oof.y[,iresp]) calib.int.tab[icross.fold, iresp] <- calib[1] calib.slope.tab[icross.fold, iresp] <- calib[2] maxerr.tab[icross.fold, iresp] <- get.maxerr(oof.y[,iresp] - oof.fit.resp[,iresp]) test.tab[icross.fold, iresp] <- cor(oof.fit.resp[,iresp], oof.y[,iresp]) } else maxerr.tab[icross.fold, iresp] <- get.maxerr(oof.y[,iresp] - oof.fit[,iresp]) } # end for iresp nvars.selected.by.gcv[icross.fold] <- get.nused.preds.per.subset(foldmod$dirs, foldmod$selected.terms) nterms.selected.by.gcv[icross.fold] <- length(foldmod$selected.terms) if(must.get.class.rate) class.rate.tab[icross.fold, ] <- get.class.rate(oof.fit.resp, oof.y, object$levels) if(get.oof.rsq.per.subset) { temp <- get.fold.rsq.per.subset(foldmod, oof.y, max.nterms, trace, must.print.dots) oof.rsq.tab[icross.fold,] <- temp$oof.rsq.per.subset infold.rsq.tab[icross.fold,] <- temp$infold.rsq.per.subset } # init last column of summary tables ilast.col <- nresp+1 # index of final (summary) column in tables rsq.tab[icross.fold, ilast.col] <- weighted.mean(rsq.tab[icross.fold, -ilast.col], wp.expanded) maxerr.tab[icross.fold, ilast.col] <- get.maxerr(maxerr.tab[icross.fold, -ilast.col]) if(is.binomial || is.poisson) { deviance.tab[icross.fold, ilast.col] <- weighted.mean(deviance.tab [icross.fold, -ilast.col], wp.expanded) calib.int.tab[icross.fold, ilast.col] <- weighted.mean(calib.int.tab [icross.fold, -ilast.col], wp.expanded) calib.slope.tab[icross.fold, ilast.col] <- weighted.mean(calib.slope.tab[icross.fold, -ilast.col], wp.expanded) test.tab[icross.fold, ilast.col] <- weighted.mean(test.tab [icross.fold, -ilast.col], wp.expanded) } if(!keepxy) # reduce memory by getting rid of big fields foldmod$bx <- foldmod$residuals <- foldmod$prune.terms <- NULL trace.fold(icross, ifold, trace, y, infold.subset, oof.subset, ncross, ndigits, rsq.tab[icross.fold,], must.print.dots) cv.list[[icross.fold]] <- foldmod } # end for ifold } # end for icross # init last row of summary tables ilast <- ncross.fold+1 # index of last row in tables nvars.selected.by.gcv [ilast] <- mean(nvars.selected.by.gcv[-ilast]) nterms.selected.by.gcv[ilast] <- mean(nterms.selected.by.gcv[-ilast]) rsq.tab [ilast,] <- colMeans(rsq.tab [-ilast,]) maxerr.tab[ilast,] <- get.maxerr(maxerr.tab[-ilast,]) if(is.binomial || is.poisson) { deviance.tab [ilast,] <- colMeans(deviance.tab [-ilast,]) calib.int.tab [ilast,] <- colMeans(calib.int.tab [-ilast,]) calib.slope.tab[ilast,] <- colMeans(calib.slope.tab[-ilast,]) test.tab [ilast,] <- colMeans(test.tab [-ilast,]) } if(must.get.class.rate) class.rate.tab[ilast,] <- colMeans(class.rate.tab [-ilast,]) oof.rsq.per.subset <- NULL if(get.oof.rsq.per.subset) { # there will be NAs in oof.rsq.tab if max terms in a fold is # less than max terms in full model oof.rsq.tab[ilast,] <- col.means.with.special.na.handling(oof.rsq.tab[-ilast,]) infold.rsq.tab[ilast,] <- col.means.with.special.na.handling(infold.rsq.tab[-ilast,]) } trace1(trace, "\n") trace.fold(icross, -1, trace, y, TRUE, TRUE, ncross, ndigits, rsq.tab[ilast,], must.print.dots) if(trace >= .5) cat("\n") names(cv.list) <- fold.names rv <- list( cv.list = cv.list, # list of earth models built during cross validation nterms.selected.by.gcv = nterms.selected.by.gcv, nvars.selected.by.gcv = nvars.selected.by.gcv, groups = groups, # groups used for cross validation rsq.tab = rsq.tab, maxerr.tab = maxerr.tab, class.rate.tab = class.rate.tab, auc.tab = if(is.binomial) test.tab else NULL, cor.tab = if(is.poisson) test.tab else NULL, deviance.tab = deviance.tab, calib.int.tab = calib.int.tab, calib.slope.tab = calib.slope.tab, oof.fit.tab = oof.fit.tab, infold.rsq.tab = infold.rsq.tab, oof.rsq.tab = oof.rsq.tab) rv } # Return the mean of each column in tab. # NAs are ignored, except that the column mean is NA # for columns in which over half the entries are NA. col.means.with.special.na.handling <- function(tab) { means <- colMeans(tab, na.rm=TRUE) nna <- colSums(is.na(tab)) # number of NAs in each column means[nna > nrow(tab) / 2] <- NA means # a vector of column means, some entries may be NA } check.cv.args <- function(nfold, ncross, pmethod, varmod.method) { check.integer.scalar(nfold, min=0) # if(nfold > 10000) # 10000 is arbitrary # stop0("nfold ", nfold, " is too big") check.integer.scalar(ncross, min=0) if(ncross > 1000) # 1000 is arbitrary stop0("ncross ", ncross, " is too big (max allowed is 1000)") if(ncross > 1 && nfold < 2) stop0("ncross=", ncross, " yet nfold=", nfold) if(ncross < 1 && nfold > 1) stop0("ncross=", ncross, " yet nfold=", nfold) if(varmod.method != "none") { if(nfold <= 1) stop0("varmod.method=\"", varmod.method, "\" requires nfold greater than 1") if(ncross < 3) stop0("ncross=", ncross, " but should be larger when varmod.method is used\n", " (suggest at least 30, for debugging 3 is ok)") } } get.groups <- function(y, nfold, stratify) { groups <- sample(repl(seq_len(nfold), nrow(y))) if(stratify) { # Get (roughly) equal number of folds for each non-zero entry in each y column # If y was originally a factor before expansion to multiple columns, this is # equivalent to having the same numbers of each factor level in each fold. for(iresp in seq_len(ncol(y))) { yset <- y[,iresp] != 0 groups[yset] <- sample(repl(seq_len(nfold), sum(yset))) } } if(any(table(groups) == 0)) stop0("Not enough data to do ", nfold, " fold cross validation (an out-of-fold set is empty)") groups } get.this.group <- function(icross, ifold, ncases, groups) { start <- ((icross-1) * ncases) + 1 groups[start:(start+ncases-1), 2] } trace.cv.header <- function(object, nresp, trace, must.print.dots) { if(trace == .5) { if(must.print.dots || nresp > 1) cat("\n") printf("Full model GRSq %5.3f RSq %5.3f, starting cross validation\n", object$grsq , object$rsq) if(must.print.dots || nresp > 1) cat("\n") } } trace.fold.header <- function(trace, ncross, icross, ifold) { if(trace >= .5 && trace < 1) { if(ncross > 1) printf("CV fold %2d.%-2d ", icross, ifold) else printf("CV fold %-2d ", ifold) } else if(trace >= 1) { # newline etc. to distinguish this from other trace prints if(ncross > 1) printf("\nCV fold %d.%d -----------------------------%s", icross, ifold, "---------------------------------------\n") else printf("\nCV fold %d -----------------------------%s", ifold, "---------------------------------------\n") } } # print results for the current fold (ifold=-1 means "all") trace.fold <- function(icross, ifold, trace, y, infold.subset, oof.subset, ncross, ndigits, rsq.row, must.print.dots) { if(trace < .5) return() if(ifold < 0) { icross <- if(ncross > 1) " " else "" printf("%s%s", "CV all ", icross) } else if(trace >= 1) { if(ncross > 1) icross <- sprint("%2d.", icross) else icross <- "" printf("CV fold %s%-2d ", icross, ifold) } printf("CVRSq % -6.3f ", rsq.row[length(rsq.row)]) nresp <- length(rsq.row) - 1 # -1 for "all" if(nresp > 1) { cat("Per response CVRSq ") for(iresp in seq_len(nresp)) printf("% -6.3f ", rsq.row[iresp]) } if(nresp > 1) { if(ncross > 1) cat("\n ") else cat("\n ") } if(ifold < 0) printf(" %.*s ", ndigits, " ") else printf("n.oof %*.0f %2.0f%% ", ndigits, length(infold.subset), 100 * (length(y[, 1]) - length(infold.subset)) / length(y[, 1])) cat("n.infold.nz ") if(nresp == 1) printf("%*.0f %2.0f%%", ndigits, sum(y[infold.subset, 1] != 0), 100 * sum(y[infold.subset, 1] != 0) / length(y[infold.subset, 1])) else for(iresp in seq_len(nresp)) printf("%*.0f", ndigits, sum(y[infold.subset, iresp] != 0)) if(ifold >= 0) { cat(" n.oof.nz ") if(nresp == 1) printf("%*.0f %2.0f%%", ndigits, sum(y[oof.subset, 1] != 0), 100 * sum(y[oof.subset, 1] != 0) / length(y[oof.subset, 1])) else for(iresp in seq_len(nresp)) printf("%*.0f", ndigits, sum(y[oof.subset, iresp] != 0)) if(nresp > 1) cat("\n") } if(must.print.dots && trace == .5 && ifold > 0) cat("\n") cat("\n") } trace.get.fold1 <- function(trace, must.print.dots, nterms) { if(trace >= 2) cat0("\nget.fold.rss.per.subset nterms=", nterms, "\n") else if(must.print.dots) { cat0(".") if(nterms %% 40 == 0) { cat0("\n") if(trace == .5) cat(" ") } flush.console() } } trace.get.fold2 <- function(trace, must.print.dots, nterms) { if(must.print.dots && nterms %% 40) { # nterms %% 40 avoids double newline cat0("\n") if(trace == .5) cat(" ") } } print_cv <- function(x) # called from print.earth for cross validated models { cv.field <- function(field) round(x[[field]][ilast,], 3) cv.sd <- function(field) round(apply(x[[field]][-ilast,], 2, sd), 3) #--- print_cv starts here --- stopifnot(!is.null(x$cv.list), x$pmethod != "cv") ilast <- nrow(x$cv.rsq.tab) # index of "all" row in summary tables cat("\nNote: the cross-validation sd's below are standard deviations across folds\n\n") printf("Cross validation: nterms %.2f sd %.2f nvars %.2f sd %.2f\n\n", x$cv.nterms.selected.by.gcv[ilast], sd(x$cv.nterms.selected.by.gcv[-ilast]), x$cv.nvars.selected.by.gcv[ilast], sd(x$cv.nvars.selected.by.gcv[-ilast])) # if printing little then use wide spacing wide.spacing <- is.null(x$cv.deviance.tab) # create a data.frame and print that tab <- if(wide.spacing) data.frame(" CVRSq"=cv.field("cv.rsq.tab"), check.names = FALSE) else data.frame("CVRSq" =cv.field("cv.rsq.tab")) tab$sd.1=cv.sd("cv.rsq.tab") if(!is.null(x$cv.class.rate.tab)) { if(wide.spacing) tab$" ClassRate" <- cv.field("cv.class.rate.tab") else tab$"ClassRate" <- cv.field("cv.class.rate.tab") tab$sd.2 <- cv.sd("cv.class.rate.tab") } if(wide.spacing) tab$" MaxErr" <- x$cv.maxerr.tab[ilast,] else tab$"MaxErr" <- x$cv.maxerr.tab[ilast,] tab$sd <- apply(x$cv.maxerr.tab[-ilast,], 2, sd) if(!is.null(x$cv.auc.tab)) { tab$AUC <- cv.field("cv.auc.tab") tab$sd.3 <- cv.sd("cv.auc.tab") } if(!is.null(x$cv.cor.tab)) { tab$cor.tab <- cv.field("cv.cor.tab") tab$sd.4 <- cv.sd("cv.cor.tab") } if(!is.null(x$cv.deviance.tab)) { tab$MeanDev <- x$cv.deviance.tab[ilast,] tab$sd.5 <- apply(x$cv.deviance.tab[-ilast,], 2, sd) tab$CalibInt <- cv.field("cv.calib.int.tab") tab$sd.6 <- cv.sd("cv.calib.int.tab") tab$CalibSlope <- cv.field("cv.calib.slope.tab") tab$sd.7 <- cv.sd("cv.calib.slope.tab") } # change "sd.N" to plain "sd" names <- names(tab) names[grep("sd", names)] <- "sd" names(tab) <- names rownames(tab) <- c(colnames(x$fitted.values), "All") digits <- min(getOption("digits"), 3) if(NCOL(x$coefficients) == 1) # single response model? print(tab[1,,drop=FALSE], digits=digits, row.names=FALSE) # skip "All" row else # multiple response model print(tab, digits=digits) } earth/R/evimp.R0000644000176200001440000002314613441031665013032 0ustar liggesusers# evimp.R: estimate variable importances in an earth object # Return a vector of column numbers for predictors that are used # in the final model get.used.preds <- function(object) # object is an earth object { which(apply(object$dirs[object$selected.terms,,drop=FALSE],2,any1)) } # Print predictors in order of decreasing estimated importance. # A one line summary. Called by print.summary.earth. print_one_line_evimp <- function(object, prefix.space) { if(is.null(object$prune.terms)) { if(is.null(object$ifold)) { # not a fold model? # must have been created by mars.to.earth if(prefix.space) printf(" ") cat("Importance: object has no prune.terms, call update() on the model to fix that\n") } return() } if(prefix.space) printf(" ") evimp <- row.names(evimp(object, trim=FALSE)) if(length(evimp) == 0) cat0("Importance: no predictors") else if(length(evimp) == 1) cat0("Importance: ", evimp[1]) else { width <- max(getOption("width")-5, 20) # -5 for ", ..." s <- paste0("Importance: ", evimp[1]) for(ipred in 2:length(evimp)) { temp <- paste0(s, ", ", evimp[ipred]) if(nchar(temp) >= width) { s <- paste0(s, ", ...") break } s <- temp } cat(s) } cat("\n") } evimp <- function(object, trim=TRUE, sqrt.=TRUE) # see help page for description { trim <- check.boolean(trim) sqrt. <- check.boolean(sqrt.) # convert col numbers in predtab to col numbers in importances as.icriti <- function(icrit) c(3,4,6)[icrit] check.classname(object, substitute(object), "earth") stopifnot(!is.null(object$prune.terms)) nsubsets <- length(object$selected.terms) dirs <- object$dirs pred.names <- gen.colnames(dirs, "x", "x", trace=0) # tagged.pred.names is a copy of pred.names but with unused # predictors renamed by adding a "-unused" suffix. # By unused, we mean unused in the final model. used.preds <- to.logical(get.used.preds(object), len=length(pred.names)) tagged.pred.names <- pred.names tagged.pred.names[!used.preds] <- paste0(tagged.pred.names[!used.preds], "-unused") # deltas[isubset, icrit] is the change in criterion value # for isubset using criterion icrit stopifnot(nsubsets >= 1) deltas <- matrix(nrow=nsubsets-1, ncol=3) colnames(deltas) <- c("nsubsets", "gcv", "rss") deltas[,"nsubsets"] <- rep(1, times=nsubsets-1) deltas[,"gcv"] <- -diff(object$gcv.per.subset[seq_len(nsubsets)]) deltas[,"rss"] <- -diff(object$rss.per.subset[seq_len(nsubsets)]) # preds.in.each.term[iterm] is the indices of predictors in term iterm preds.in.each.term <- apply(object$dirs, 1, function(row) which(row != 0)) # importances is the matrix we return importances <- matrix(0, nrow=length(pred.names), ncol=7) colnames(importances) <- c("col", "used", "nsubsets", "gcv", "gcv.match", "rss", "rss.match") rownames(importances) <- tagged.pred.names importances[, "col"] <- seq_len(nrow(importances)) importances[used.preds, "used"] <- 1 if(nsubsets > 1) for(isubset in 2:nsubsets) { terms.in.this.subset <- object$prune.terms[isubset,-1] # -1 drops intercept preds.in.this.subset <- unique(unlist(preds.in.each.term[terms.in.this.subset])) for(icrit in 1:3) { icriti <- as.icriti(icrit) importances[preds.in.this.subset, icriti] <- importances[preds.in.this.subset, icriti] + deltas[isubset-1, icrit] } } # sort rows in "importances" by the nsubsets criteria # and with the "gcv" criterion as a secondary sort key order.nsubsets <- order(importances[,"nsubsets"], importances[,"gcv"], decreasing=TRUE) importances <- importances[order.nsubsets, , drop=FALSE] if(nrow(importances) > 1) for(icrit in 2:3) { # tag importances where gcv or rss ordering disagrees with nsubsets ordering icriti <- as.icriti(icrit) importances[, icriti+1] <- 1 for(i in 2:nrow(importances)) if(importances[i,icriti] > importances[i-1,icriti]) importances[i, icriti+1] <- 0 # normalize importances max <- max(abs(importances[,icriti])) if(max != 0) { if(sqrt.) { temp <- sqrt(abs(importances[,icriti]) / max) signs <- ifelse(importances[,icriti] < 0, -1, 1) importances[,icriti] <- 100 * signs * temp } else importances[,icriti] <- 100 * importances[,icriti] / max } } if(trim) { # keep only rows for predictors that are used in at least one subset in.at.least.one.subset <- importances[,"nsubsets"] != 0 importances <- importances[in.at.least.one.subset, , drop=FALSE] } class(importances) <- "evimp" # allows use of plot.evimp attr(importances, "sqrt") <- sqrt. importances } print.evimp <- function(x = stop("no 'x' argument"), ...) # x is an "evimp" object { stopifnot(NCOL(x) == 7) if(NROW(x) == 0) { printf(" nsubsets gcv rss\n") return() } # truncate rownames if necessary so each entry requires only one line on the screen rownames <- rownames(x) max.rowname <- max(nchar(rownames)) width <- max(30, getOption("width")) if(max.rowname > width-25) { # width of stuff to right of rowname is slighty less than 25 rownames <- substr(rownames, 1, width-25) max.rowname <- max(nchar(rownames)) } printf("%*s nsubsets gcv rss\n", max.rowname, " ") for(i in seq_len(nrow(x))) printf("%-*s %8d %5.1f%s %5.1f%s\n", max.rowname, rownames[i], x[i, 3], x[i, 4], if(x[i, 7]) " " else ">", x[i, 6], if(x[i, 7]) "" else ">") } # TODO this would be better if rotated clockwise 90 degrees so could easily read var names plot.evimp <- function( x = stop("no 'x' argument"), cex.var = 1, type.nsubsets = "l", col.nsubsets = "black", lty.nsubsets = 1, type.gcv = "l", col.gcv = 2, lty.gcv = 1, type.rss = "l", col.rss = "gray60", lty.rss = 1, cex.legend = 1, x.legend = nrow(x), y.legend = x[1,"nsubsets"], rh.col = 1, do.par = TRUE, ...) { check.classname(x, substitute(x), "evimp") # make sure that all evimp columns are present (extra columns are ok) if(any(pmatch(c("col", "used", "nsubsets", "gcv"), colnames(x), nomatch=0) == 0)) stop0("x is not an evimp matrix") if(nrow(x) == 0) { # intercept-only model max.subsets <- 0 varlabs <- "intercept" } else { max.subsets <- x[1, "nsubsets"] varlabs <- paste(rownames(x), sprint("%3d", x[,"col"])) } sqrt. <- if(attr(x, "sqrt", exact=TRUE)) TRUE else FALSE par <- par("mar", "cex") on.exit(par(par)) cex.var <- par$cex * cex.var # cex.var is relative to current cex do.par <- check.boolean(do.par) if(do.par) { # TODO what is the best way of doing the bottom.margin calculation? # The .5 is a hack to convert nchars to line heights, as required by mar mar <- par$mar mar[1] <- cex.var * .5 * max(nchar(varlabs) + 6) # bottom margin mar[4] <- mar[4] + 3 # right margin par(mar=mar) # big bottom and right margins } main <- dota("main", DEF="Variable importance", ...) if(max.subsets == 0) { plot(1, ylim=c(0, 1), type=type.nsubsets, # intercept-only model, dummy plot xlab="", xaxt="n", ylab="nsubsets", main=main, lty=lty.nsubsets, col=col.nsubsets) } else { plot(x[, "nsubsets"], ylim=c(0, max.subsets), type=type.nsubsets, xlab="", xaxt="n", ylab="nsubsets", main=main, lty=lty.nsubsets, col=col.nsubsets) lines(max.subsets * x[,"rss"] / 100, type=type.rss, lty=lty.rss, col=col.rss) # plot gcv second so it goes on top of rss (gcv arguably more important than rss) lines(max.subsets * x[,"gcv"] / 100, type=type.gcv, lty=lty.gcv, col=col.gcv) } zero.or.one.var <- nrow(x) <= 1 if(is.specified(x.legend)) { if(sqrt.) legend <- c("nsubsets", "sqrt gcv", "sqrt rss") else legend <- c("nsubsets", "gcv", "rss") legend(x=if(zero.or.one.var) "topright" else x.legend, y = y.legend, xjust=1, legend=legend, col=c(col.nsubsets, col.gcv, col.rss), lty=c(lty.nsubsets, lty.gcv, lty.rss), bg="white", cex=cex.legend) } # right hand axis: normalized rss/gcv values, always 0...100 # TODO how to get the x position in the call to text correct for all window sizes? axis(side=4, at=c(0,.2*max.subsets,.4*max.subsets,.6*max.subsets,.8*max.subsets,max.subsets), labels=c(0,20,40,60,80,100)) if(sqrt.) label <- "normalized sqrt gcv or rss" else label <- "normalized gcv or rss" if(!zero.or.one.var) text(x=nrow(x) + 1.8, y=max.subsets/2, label, col=rh.col, xpd=NA, # no clip to plot region srt=90) # rotate text # bottom axis: variable names # axis() ignores the cex parameter (a bug?), so set cex globally, on.exit will restore it par(cex=cex.var) if(max.subsets == 0) axis(side=1, at=1, labels="intercept-only model") else axis(side=1, at=seq(1, nrow(x), by=1), labels=varlabs, las=3) invisible() } earth/R/earth.cv.lib.R0000644000176200001440000000472313435361202014165 0ustar liggesusers# earth.cv.lib.R: library functions for cross validation of earth models # The following functions were lifted from the Elith Leathwick code. # In that code, the AUC calculation was adapted from Ferrier, Pearce and Watson. # See Pearce and Ferrier (2000) Evaluating the predictive performance # of habitat models developed using logistic regression. get.binomial.deviance <- function(yhat, y) # yhat is predicted, y is observed { deviance.contribs <- y * log(yhat) + (1 - y) * log(1 - yhat) mean(-2 * sum(deviance.contribs)) / length(y) # TODO length(y) ok, should use dof? } get.poisson.deviance <- function(yhat, y) { deviance.contribs <- ifelse(y == 0, 0, y * log(y/yhat)) - (y - yhat) 2 * sum(deviance.contribs) / length(y) } get.auc <- function(yhat, y) # area under ROC curve { y <- y > .5 # necessary when is.bpairs (y is converted to glm.yfrac) nx <- length(y[y == 0]) ny <- length(y[y == 1]) xy <- c(yhat[y == 0], yhat[y == 1]) wilc <- nx * ny + (nx * (nx + 1)) / 2 - sum(rank(xy)[seq_len(nx)]) wilc / (nx * ny) } get.binomial.calib <- function(yhat, y) # returns c(intercept, slope) { yhat <- yhat + 1e-005 # prevents log(0) yhat[yhat >= 1] <- .99999 glm(y ~ log(yhat / (1 - yhat)), family = binomial)$coefficients } get.poisson.calib <- function(yhat, y) # returns c(intercept, slope) { glm(y ~ log(yhat), family = poisson)$coefficients } get.maxerr <- function(errs) # get signed max absolute err; if matrix then of each col { if(NCOL(errs) == 1) errs[which.max(abs(errs))] else apply(errs, 2, function(col) col[which.max(abs(col))]) } # get fraction correctly classified (one row of class.rate.tab) get.class.rate <- function(yhat, y, ylevels) { stopifnot(ncol(yhat) == ncol(y)) n <- nrow(y) if(ncol(y) == 1) # single response model? per.class.correct <- overall.correct <- sum((yhat > .5) == (y > .5)) else { # multiple response model # y and yhat are indicator columns, convert back to levels y <- ylevels[apply(y, 1, which.max)] yhat <- ylevels[apply(yhat, 1, which.max)] per.class.correct <- repl(0, length(ylevels)) for(i in seq_along(ylevels)) { level <- ylevels[i] per.class.correct[i] <- sum(y == level & yhat == level) + sum(y != level & yhat != level) } overall.correct <- sum(y == yhat) } c(per.class.correct, overall.correct) / n } earth/R/stop.if.dots.R0000644000176200001440000000301413437040777014245 0ustar liggesusers# stop.if.dots.R: # stop.if.dots issues an an error message if any args in dots. # We use it to test if any dots arg of the calling function was used, for # functions that must have a dots arg (to match the generic method) but don't # actually use the dots. This helps the user catch mistyped or illegal args. stop.if.dots <- function(...) { dots <- match.call(expand.dots=FALSE)$... if(length(dots)) dots.used.err(STOPFUNC=base::stop, MSG=": unrecognized", ...) } warn.if.dots <- function(...) { dots <- match.call(expand.dots=FALSE)$... if(length(dots)) dots.used.err(STOPFUNC=base::warning, MSG=" ignored", ...) } dots.used.err <- function(..., STOPFUNC, MSG) # utility for stop.if.dots and friends { callers.name <- callers.name(n=2) dots <- match.call(expand.dots=FALSE)$... for(idot in seq_along(dots)) # STOPFUNC is either stop() or warning() STOPFUNC(callers.name, MSG, describe.dot(dots, idot), call.=FALSE) } describe.dot <- function(dots, idot) # utility for dots.used.err { nchar <- nchar(names(dots)[idot]) if(length(nchar) && nchar > 0) return(sprint(" argument '%s'", names(dots[idot]))) # the argument that was passed in dots is unnamed call <- call.as.char(n=5) # n=5 to describe call to caller of stop.if.dots sprint(" unnamed argument\n The call was %s", paste0(strwrap(call, width=max(40, max(25, getOption("width")-20)), exdent=25), collapse="\n")) } earth/R/do.par.R0000644000176200001440000002103513405323607013070 0ustar liggesusers# do.par.R: functions setting par() and for setting the overall caption # main1 is not called main else would clash with main passed in dots (which # we ignore but cause an error message). Likewise for xlab1 and ylab1. do.par <- function(..., nfigs, caption, main1, xlab1, ylab1, trace, nlines.in.main=if(is.specified(main1)) nlines(main1) else 1, def.cex.main=1, def.font.main=2, # use 1 for compat with plot.lm def.right.mar=.8) { nrows <- ceiling(sqrt(nfigs)) # Note that the plain old cex argument is used in plotmo only in par() # (but we also query it later using par("cex")). # We use plain old cex relative to the cex calculated by nrows (so passing # cex=1 to plotmo causes no changes, and cex=.8 always makes things smaller). # TODO cex.axis etc. should be treated in the same way # TODO consider moving this into the dotargs functions, also extend for cex.axis, cex.main plain.old.cex <- dota("cex", DEF=1, ...) check.numeric.scalar(plain.old.cex) cex <- if(nrows == 1) 1 else if(nrows == 2) .83 else if(nrows >= 3) .66 cex <- plain.old.cex * cex # set oma to make space for caption if necessary stopifnot.string(caption, allow.empty=TRUE, null.ok=TRUE) def.oma <- dota("oma", ...) if(!is.specified(def.oma)) { def.oma <- par("oma") def.oma[3] <- max(def.oma[3], # .333 to limit cex adjustmment 2 + (plain.old.cex^.333 * nlines(caption))) } cex.lab <- dota("cex.lab", # make the labels small if multiple figures DEF=if(def.cex.main < 1) .8 * def.cex.main else 1, ...) mgp <- # compact title and axis annotations if(cex.lab < .6) c(1, 0.2, 0) else if(cex.lab < .8) c(1, 0.25, 0) else c(1.5, 0.4, 0) # margins are small to pack plots in, but make bigger if xlab # or ylab specified (note that xlab or ylab equal to NULL means # that we will later auto generate them) mar <- c( if(is.null(xlab1) || (is.specified(xlab1) && nzchar(xlab1))) 4 else 3, # bottom if(is.null(ylab1) || (is.specified(ylab1) && nzchar(ylab1))) 3 else 2, # left 1.2 * nlines.in.main, # top def.right.mar) # right if(nrows >= 5) # small margins if lots of figures mar <- cex * mar trace2(trace, "\n") call.dots(graphics::par, DROP="*", # drop everything KEEP="PREFIX,PAR.ARGS", # except args matching PREFIX and PAR.ARGS TRACE=if(trace >= 2) trace-1 else 0, SCALAR=TRUE, def.mfrow = c(nrows, nrows), def.mgp = mgp, # compact title and axis annotations def.tcl = -.3, # shorten tick length def.font.main = def.font.main, def.mar = mar, def.oma = def.oma, def.cex.main = def.cex.main, # ignored by most plot funcs so do it here def.cex.lab = cex.lab, def.cex.axis = cex.lab, force.cex = cex, # last, overrides any cex set by any arg above ...) # any remaining graphic dot args are also processed } # call do.par on any graphics args in dots, and return a list of their # old values so the caller can use on.exit to restore them do.par.dots <- function(..., trace=0) { dots <- match.call(expand.dots=FALSE)$... if(length(dots) == 0) return(NULL) oldpar <- args <- list() env <- parent.frame() for(dotname in PAR.ARGS) if(is.dot(dotname, ...)) { arg <- list(par(dotname)) names(arg) <- dotname oldpar <- append(oldpar, arg) dot.org <- dota(dotname, ...) dot <- try(eval(dot.org, envir=env, enclos=env), silent=TRUE) if(is.try.err(dot)) dot <- dot.org # TODO consider moving this into the dotargs functions, also extend for cex.axis, cex.main # special handling for cex args: we want cex to be relative # to the current setting, so e.g cex=1 causes no change if(substr(dotname, 1, 3) == "cex") { olddot <- par(dotname) dot <- dot[[1]] * olddot } else if(!(dotname %in% PAR.VEC) && length(dot) != 1) dot <- dot[[1]] # similar to handling of argument "scalar" in eval.dotlist arg <- list(dot) names(arg) <- dotname args <- append(args, arg) } if(length(args)) { if(trace >= 2) printf.wrap("\npar(%s)\n", list.as.char(args)) do.call(par, args) } oldpar # a list of old values of args that were changed, empty if none } check.do.par <- function(do.par, nfigs) # auto do.par if null, check is 0,1, or 2 { if(is.null(do.par)) do.par <- nfigs > 1 if(is.logical(do.par)) do.par <- as.numeric(do.par) stopifnot(length(do.par) == 1) if(!is.numeric(do.par) || (do.par != 0 && do.par != 1 &&do.par != 2)) stop0("do.par must be 0, 1, or 2") do.par } auto.caption <- function(caption, resp.name, type, model.call, object.name, my.call) { sresponse <- stype <- smodel <- scaption <- smy.call <- "" if(!is.null(caption)) scaption <- sprint("%s ", caption) # the test against "y" is because "y" may just be a fabricated # name created because the actual name was not available if(!is.null(resp.name) && resp.name != "y") sresponse <- paste0(resp.name, " ") if(type != "response") stype <- paste0("type=", type, " ") if(!is.null(model.call)) { smodel <- strip.deparse(model.call) smodel <- sub("\\(formula=", "(", smodel) # delete formula= } else smodel <- paste0("model: ", object.name) s <- paste0(scaption, sresponse, stype, smodel) smy.call <- process.my.call.for.caption(my.call) if(nzchar(smy.call)) s <- paste0(s, if(nzchar(s)) "\n" else "", smy.call) s } # Call this only after a plot is on the screen to avoid # an error message "plot.new has not been called yet" draw.caption <- function(caption, ...) { if(!is.null(caption) && any(nzchar(caption))) { # allow use of dot args for caption specs cex <- dota("caption.cex cex.caption", DEF=1, NEW=1, ...) font <- dota("caption.font font.caption", DEF=1, NEW=1, ...) col <- dota("caption.col col.caption", DEF=1, NEW=1, ...) line <- dota("caption.line", DEF=1, ...) # trim so caption fits # strwidth doesn't have units of device coords so work with usr coords # TODO the algorithm below is not quite correct caption <- strsplit(caption, "\n")[[1]] usr <- par("usr") # xmin, xmax, ymin, ymax n <- par("mfrow")[2] # number of figures horizontally across page avail <- .7 * n * (usr[2] - usr[1]) strwidth <- max(strwidth(caption)) if(strwidth > avail) { which <- strwidth(caption) > avail max <- max(nchar(caption)) max.nchar <- max * avail / strwidth if(max.nchar < max) { # TODO should always be FALSE but actually isn't caption <- substr(caption, 1, max.nchar) caption[which] <- paste0(caption[which], "...") } } caption <- paste(caption, collapse="\n") mtext(text=caption, line=line, outer=TRUE, cex=cex * par("cex")^.333, col=col, font=font) } caption } get.caption <- function(nfigs, do.par, caption, resp.name, type, model.call, object.name, my.call) { stopifnot.string(caption, null.ok=TRUE, allow.empty=TRUE) if(nfigs > 1 && do.par && (is.null(caption) || !is.null(my.call))) auto.caption(caption, resp.name, type, model.call, object.name, my.call) else paste0(if(is.null(caption)) "" else caption, if(!is.null(caption) && !is.null(my.call)) "\n" else "", if(!is.null(my.call)) "" else process.my.call.for.caption(my.call)) } process.my.call.for.caption <- function(my.call) { s <- "" if(!is.null(my.call)) { s <- sub("\\(object=", "(", my.call) # delete object= s <- sub(", trace=[-._$[:alnum:]]+", "", s) # delete trace=xxx s <- sub(", SHOWCALL=[-._$[:alnum:]]+", "", s) # delete SHOWCALL=xxx } s # a string, may be "" } earth/R/as.char.R0000644000176200001440000002164713442227574013244 0ustar liggesusers# as.char.R: brief description of an object as a string e.g. "c(1,2)" # this file also includes print_summary for matrices and data.frames as.char <- function(object, maxlen=20) { check.integer.scalar(maxlen, min=1) if(is.null(object)) "NULL" else if(is.name(object)) paste.trunc(object, maxlen=maxlen) # e.g. "..3" for unforced dot args else if(is.environment(object)) environment.as.char(object) else if(is.call(object)) { # e.g. x is a call object in foo(x=1:3) s <- strip.space.collapse(format(object)) if(nchar(s) > maxlen) s <- paste0(substr(s, 1, maxlen), "...)") s } else if(NCOL(object) == 1 && is.character(object)) paste.c(paste0("\"", object, "\"")) else if(NCOL(object) == 1 && is.logical(object)) paste.c(object) else if(NCOL(object) == 1 && is.numeric(object)) { # digits=4 is arb but seems about right, and zapsmall means more can # be displayed in limited space if just one val is say 3.553e-15 paste.c(signif(zapsmall(object, digits=4), digits=4)) } else if(length(dim(object)) == 2) sprint("%s[%g,%g]", class(object)[1], NROW(object), NCOL(object)) else if(class(object)[1] == "list") # not is.list() because e.g. lm objects are lists paste0("list(", paste.trunc(list.as.char(object), maxlen=maxlen+12), ")") else if(class(object)[1] == "Date") paste0("Date:", paste.trunc(object, maxlen=maxlen+12)) else paste0(class(object)[1], ".object") } # compact description of a list # maxlen is max length of each list element (not of the entire list) list.as.char <- function(object, maxlen=20) { stopifnot(is.list(object) || is.pairlist(object)) s <- "" names <- names(object) for(i in seq_along(object)) { if(i != 1) s <- sprint("%s, ", s) name.ok <- length(names) >= i && !is.na(names[i]) && nzchar(names[i]) if(name.ok && names[i] == "...") s <- sprint("%s...", s) # print dots as ... not as ...=pairlist.object else { if(name.ok) s <- sprint("%s%s=", s, names(object)[i]) s <- sprint("%s%s", s, as.char(object[[i]], maxlen=maxlen)) } } s # one element character vector e.g "x=1, 2" } environment.as.char <- function(env, maxlen=60) # compact description { if(is.null(env)) # illegal, but we still want to format it return("env(NULL)") stopifnot(is.environment(env)) # format(env) returns "" stripped.env <- gsub("", "", format(env)[1]) # if it's a standard environment return the environment's name if(grepl("^namespace:|^R_[[:alnum:]]+Env", stripped.env)) stripped.env # something like "namespace:stats" or "R_GlobalEnv" else # return the names of the objects in the environment sprint("env(%s)", paste.trunc(paste0(ls(env, all.names=TRUE), collapse=", "), maxlen=maxlen)) } # The main purpose of this routine is to summarize matrices and data.frames, # but it will also (semi)gracefully handle any object that is passed to it. # # Note that this only does anything if trace >= 2. # # If x is a matrix or dataframe or similar, print first few rows and last row. # If trace >= 4, then print all rows and cols, up to 1000 rows and 100 cols. # # the details argument: # 0=don't print data, print the colnames truncated to one line of output # 1=don't print data, print all colnames # -1=like print data but don't prefix the output with spaces # 2=print the data print_summary <- function(x, xname=trunc.deparse(substitute(x)), trace=2, msg="", prefix="", details=2) { check.numeric.scalar(trace) if(trace < 2) return() if(is.null(x)) { printf("%s: NULL\n", xname) return() } if(length(x) == 0) { printf("%s: length zero\n", xname) return() } # try(data.frame(), silent=TRUE) is not actually silent # for language objects, so handle them specially if(is.language(x)) { x$na.action <- NULL # don't want to print the na.action if there is one s <- try(format(x)) max <- if(trace <= 2) 8 else 1000 if(length(s) > max) { s <- s[1:max] s[max] <- paste(s[max], "\n...") } s <- gsub("[ \t\n]", "", s) # remove white space s <- gsub(",", ", ", s) # replace comma with comma space s <- paste(s, collapse="\n ", sep="") printf("%s%s%s:\n%s\n", prefix, xname, msg, s) return() } if(is.list(x) && !is.data.frame(x)) { # data.frames are lists, hence must check both if(details < 2 && trace < 4) { printf("%s: list with elements %s\n", xname, quotify.trunc(paste(names(x)))) return() } printf("%s ", xname) str(x) return() } df <- try(my.data.frame(x, trace, stringsAsFactors=FALSE), silent=TRUE) if(is.try.err(df)) { # be robust for whatever gets passed to this function printf("print_summary: cannot convert class \"%s\" to a data.frame (%s)\n", class(x)[1], cleantry(df)) printf("%s%s%s:\n", prefix, xname, msg) if(length(dim(x)) == 2) { # it's a matrix or other 2D object? if(trace >= 4) { try(print_with_strings_quoted(x)) try(print(summary(x))) } else { try(print_with_strings_quoted(head(x))) printf("...\n") } } else try(print_with_strings_quoted(x)) return() } if(details < 2 && trace < 4) { # don't print the data, just the dimensions and colnames if(details != -1) printf(" ") printf("%s%s[%d,%d]%s ", prefix, xname, nrow(df), ncol(df), msg) print_colnames(x, full=details == 2, newline="") if(NCOL(x) == 1 || NROW(x) == 1) # if a vector, print first few values cat0(", and values ", # if double, print 4 significant digits paste.trunc(if(is.double(x)) sprint("%.4g", x) else x, collapse=", ", maxlen=32)) cat0("\n") return() } colnames <- safe.colnames(x) printf("%s%s[%d,%d]%s%s:\n", prefix, xname, nrow(df), ncol(df), msg, if(is.null(colnames)) " with no column names" else "") df.short <- df maxrows <- if(trace >= 4) 1000 else 5 if(maxrows < nrow(df)) { df.short <- df[c(1:(maxrows-1), nrow(df)), , drop=FALSE] if(is.null(rownames(df.short))) rownames(df.short) <- c(1:(maxrows-1), nrow(df)) rownames(df.short)[maxrows-2+1] <- "..." } maxcols <- if(trace >= 4) 100 else 10 if(maxcols < ncol(df)) { df.short[,maxcols] <- "..." df.short <- df.short[, 1:maxcols, drop=FALSE] if(!is.null(colnames)) colnames(df.short)[maxcols] <- "..." } try(print_with_strings_quoted(df.short)) is.fac <- sapply(df, is.factor) if(is.null(colnames)) colnames(df) <- sprint("[,%d]", seq_len(NCOL(x))) if(any(is.fac)) { names <- paste0(colnames(df), ifelse(sapply(df, is.ordered), "(ordered)", "")) if(sum(is.fac) == 1) # only one fac, so enough space to print levels too printf(" %s is a factor with levels: %s\n", paste.trunc(names[is.fac]), paste.trunc(levels(df[,is.fac]))) else printf(" factors: %s\n", paste.trunc(names[is.fac])) } if(trace >= 4) try(print(summary(df))) } print_colnames <- function(x, full=FALSE, newline="\n") { colnames <- safe.colnames(x) if(is.null(colnames)) printf("with no column names%s", newline) else { colnames[which(colnames == "")] <- "\"\"" if(full) # full colnames (up to 1000 characters) printf("with colname%s %s%s", if(length(colnames(x)) > 1) "s" else "", paste.trunc(colnames, maxlen=max(25, getOption("width")-20)), newline) else # short version of colnames printf.wrap("with colname%s %s%s", if(length(colnames(x)) > 1) "s" else "", paste.trunc(colnames), newline) } } # Like print but puts quotes around strings. # Useful for disambiguating strings from factors. # # "..." is not quoted because it is used as a # "something was deleted" indicator in print_summary print_with_strings_quoted <- function(x) { if(length(dim(x)) == 2) for(i in seq_len(NCOL(x))) if(is.character(x[,i]) && x[,i] != "...") x[,i] <- paste0("\"", x[,i], "\"") print(x) } earth/R/bpairs.R0000644000176200001440000003104613444561525013176 0ustar liggesusers# bpairs.R: code to support "binomial pairs" in glm binomial models is.bpairs <- function(y, family, trace, is.earth) # true if response y is a binomial pair { msg <- NULL is.bpairs <- FALSE is.nonneg <- TRUE is.binomial <- is.binomial(family) if(is.binomial) check.no.na.in.mat(y) # prevent confusing errors later from comparisons if(is.binomial && NROW(y) > 1 && NCOL(y) == 2) { y1 <- y[, 1, drop=TRUE] y2 <- y[, 2, drop=TRUE] if(!(is.numeric(y1) || is.logical(y1)) || !(is.numeric(y2) || is.logical(y2))) { return(FALSE) # note return } rowsums <- rowSums(y) is.int <- all((round(y1) == y1) & (round(y2) == y2)) is.nonneg <- all((y1 >= 0) & (y2 >= 0)) is.rowsums.greater.than.1 <- any(rowsums > 1) is.bpairs <- is.int && is.nonneg && is.rowsums.greater.than.1 # TODO this and following stop sometimes cause duplicate messages, even with trace=0 msg <- bpairs.msg(is.bpairs, y, rowsums, is.earth, is.nonneg, is.int, is.rowsums.greater.than.1, trace) } if(is.binomial && !is.bpairs && (is.numeric(y) || is.logical(y)) && (!all(y >= 0 & y <= 1) || !is.nonneg)) { cat0("\nprint(head(y)):\n") print(head(y)) cat0("\n") # This preempts the following error from within glm() later: # Error in eval(family$initialize) : y values must be 0 <= y <= 1 stop0("Binomial response (see above): all values should be between 0 and 1, or a binomial pair", if(is.null(msg)) "" else paste0("\n ", msg)) } is.bpairs } # is.binomial is true and y has two columns when this is called bpairs.msg <- function(is.bpairs, y, rowsums, is.earth, is.nonneg, is.int, is.rowsums.greater.than.1, trace) { msg <- NULL if(!is.bpairs) { earth.msg <- if(!is.earth) "" else sprint("\nEarth will build two GLM models with responses \"%s\" and \"%s\"", colname(y, 1), colname(y, 2)) if(!is.int) { # glm will give a warning later (Warning: non-integer #successes in a binomial glm) cat0("\nprint(head(y)):\n") print(head(y)) cat0("\n") msg <- "Response has two columns but is not a binomial pair because not all values are integers" printf("%s%s\n\n", msg, earth.msg) } else if(!is.nonneg) { # will see error message below msg <- "Response has two columns but is not a binomial pair because some values are negative" trace1(trace, "%s\n", msg) } else if(!is.rowsums.greater.than.1) { # no warning from glm later msg <- "Response has two columns but is not a binomial pair because no rows sum to greater than 1" trace1(trace, "%s%s\n\n", msg, earth.msg) } } else if(any(rowsums == 0)) trace1(trace, "Note: Both entries in row %d %sof the %s and %s response are zero\n", which(rowsums==0)[1], if(length(which(rowsums==0)) == 1) "" else "(and others) ", colname(y, 1), colname(y, 2)) msg } # When expanding the binomial pair, the first column of the # short y is considered to be "true", the second "false". # # Example short data: # dose temp survived died # 1 5 20 1 3 # 2 2 20 2 3 # 3 2 30 0 1 # note 0 survived (to test) # 4 9 20 2 0 # note 0 died # 5 5 20 2 1 # note that predictors same as row 1 (dose=5 temp=20) # 6 9 30 0 0 # both rows 0 # # Equivalent long data: # dose temp survived # 1 5 20 1 # 2 5 20 0 # 3 5 20 0 # 4 5 20 0 # # 5 2 20 1 # 6 2 20 1 # 7 2 20 0 # 8 2 20 0 # 9 2 20 0 # # 10 2 30 0 # # 11 9 20 1 # 12 9 20 1 # # 13 5 20 1 # 14 5 20 1 # 15 5 20 0 # # 16 9 30 0 # both rows zero in short data, so treat as a "false" expand.bpairs <- function(...) { UseMethod("expand.bpairs") } expand.bpairs.formula <- function(formula=stop("no 'formula' argument"), data=NULL, sort=FALSE, ...) { stop.if.dots(...) call <- match.call(expand.dots=FALSE) imatch <- match(c("formula", "data"), names(call), 0) mf <- call[c(1, imatch)] # we use the Formula package to allow multiple responses # TODO this is not exactly consistent with earth, which uses # Formula only for formulas with + (else earth uses formula) Formula <- Formula::Formula(formula) mf[[1]] <- as.name("model.frame") mf$formula <- Formula mf$na.action <- na.pass # NAs are allowed, they get propogated as is mf <- eval.parent(mf) terms <- terms(Formula, data=data) varnames <- attr(terms, "term.labels") if(length(attr(Formula, "rhs")) > 1) stop0("invalid formula: too many terms on the right hand side") x <- model.part(Formula, data=mf, rhs=1) if(NCOL(x) == 0) stopf("expand.bpairs: the right side of the formula does not have any variables") x <- as.data.frame(x) if(length(attr(Formula, "lhs")) > 1) stop0("invalid formula: too many terms on the left hand side") y <- model.part(Formula, data=mf, lhs=1) # following handles when lhs of formula is a matrix e.g. cbind(success, fail) ~ . if(NCOL(y[[1]]) > 1) y <- y[[1]] respname <- colnames(y)[1] if(is.null(respname) || length(respname) != 1 || nchar(respname) == 0) stop0("expand.bpairs: cannot get response from formula") # paranoia if(NCOL(y) != 2) stopf("expand.bpairs: '%s' does not have two columns", respname) y <- as.data.frame(y) # trace=1 below to give extra info if we invoke stop() if(!is.bpairs(y, family="binomial", trace=1, is.earth=FALSE)) stopf("expand.bpairs: the left side of the formula is not a two-column matrix of binomial pairs") expand.bpairs.aux(x, y, sort) } expand.bpairs.default <- function(data = stop("no 'data' argument"), y = NULL, sort=FALSE, ...) { help.msg <- paste0( "The y argument should be one of:\n", "\n", " o Two column matrix or dataframe of binomial pairs.\n", "\n", " o Two-element numeric vector specifying the response columns in 'data'.\n", "\n", " o Two-element character vector specifying the response column names in 'data'.\n", " The full names must be used (partial matching isn't supported).") stop.if.dots(...) if(is.null(y)) stop0("expand.bpairs: no y argument\n\n", help.msg) stopifnot(is.vector(data) || is.matrix(data) || is.data.frame(data)) data.name <- trunc.deparse(substitute(data)) # for possible error message if(length(y) == 2 && is.numeric(y) && round(y[1]) == y[1] && round(y[2]) == y[2]) { # y is a two element numeric vector specifying two columns in data ycolumns <- y check.index(ycolumns, "ycolumns", data, is.col.index=1, allow.negatives=FALSE) y <- data[, ycolumns, drop=FALSE] yarg.name <- sprint("%s[,c(%g,%g)]", data.name, ycolumns[1], ycolumns[2]) check.index(-ycolumns, "ycolumns", data, is.col.index=1, allow.negatives=TRUE) data <- data[, -ycolumns, drop=FALSE] if(ncol(data) < 1) stop0("expand.bpairs: x is empty after removing response columns") } else if(length(y) == 2 && is.character(y)) { # y is a two element character vector specifying two columns in data ycolumns <- y check.index(ycolumns, "ycolumns", data, is.col.index=2, allow.negatives=FALSE) y <- data[, ycolumns, drop=FALSE] colnames <- colnames(data) i1 <- match(ycolumns[1], colnames) i2 <- match(ycolumns[2], colnames) # following check is probably unnecessary after above call to check.index if(length(i1) != 1 || length(i2) != 1 || anyNA(i1) || anyNA(i2)) stopf("expand.bpairs: cannot find '%s' or '%s' in colnames(data)", ycolumns[1], ycolumns[2]) yarg.name <- sprint("%s[,c(\"%s\",\"%s\")]", data.name, ycolumns[1], ycolumns[2]) ycolumns <- c(i1,i2) check.index(-ycolumns, "ycolumns", data, is.col.index=1, allow.negatives=TRUE) data <- data[, -ycolumns, drop=FALSE] if(ncol(data) < 1) stop0("expand.bpairs: x is empty after removing response columns") } else { # y is the response yarg.name <- trunc.deparse(substitute(y)) # basic error checking to preempt confusing messages from is.bpairs() below if(NCOL(y) != 2 || NROW(y) < 2) stop0("expand.bpairs: bad y argument '", unquote(yarg.name), "'\n\n", help.msg) } data <- as.data.frame(data) y <- as.data.frame(y) # trace=1 below to give extra info if we invoke stop() if(!is.bpairs(y, family="binomial", trace=1, is.earth=FALSE)) stopf("expand.bpairs: %s is not a two-column matrix of binomial pairs", yarg.name) expand.bpairs.aux(data, y, sort) } expand.bpairs.aux <- function(x, y, sort) # returns a data.frame with attributes { sort <- check.boolean(sort) stopifnot(ncol(x) >= 1) if(nrow(x) != nrow(y)) stopf("expand.bpairs: x has %d row%s, but the response y has %d row%s", nrow(x), if(nrow(x)==1) "" else "s", nrow(y), if(nrow(y)==1) "" else "s") # Remove columns in x that match colnames in y. # This allows expand.bpairs(formula=y~.,data=x) # when colnames(y) is c("survived", "died") and # "survived" and "died" are also columns in x. x <- possibly.delete.column(x, y, 1) x <- possibly.delete.column(x, y, 2) stopifnot(ncol(x) >= 1) colname.y1 <- colnames(y)[1] if(is.null(colname.y1) || nchar(colname.y1) == 0) colname.y1 <- "true" rowsums <- rowSums(y) # For simplicity, if both values in a y row are zero, we treat # this as a "false". Properly we should ignore the entry, but that gets # very complicated, because we would need to work with a subset of the data. rowsums[rowsums == 0] <- 1 # include row even if both values in row are 0 n <- sum(rowsums) # length of long data ylong <- logical(length=n) # long form of y xlong <- x[FALSE, , drop=FALSE] # data.frame with all variables, but zero rows rownames <- character(length=n) # rownames in long data bpairs.index <- repl(0L, nrow(y)) # for recompacting bpairs later i <- 1 # index into long data for(ishort in 1:nrow(y)) { bpairs.index[ishort] <- as.integer(i) ntrue <- y[ishort, 1, drop=TRUE] # drop is needed if y is a data.frame nfalse <- y[ishort, 2, drop=TRUE] if(ntrue + nfalse == 0) # both values zero? nfalse <- 1 # treat as false if(nfalse > 0) { i2 <- i + nfalse - 1 ylong[i:i2] <- FALSE xlong[i:i2,] <- x[ishort,] rownames[i:i2] <- sprint("row%d.%d", ishort, 1:(i2-i+1)) i <- i + nfalse } if(ntrue > 0) { i2 <- i + ntrue - 1 ylong[i:i2] <- TRUE xlong[i:i2,] <- x[ishort,] rownames[i:i2] <- sprint("row%d.%d", ishort, (nfalse+1):(nfalse+i2-i+1)) i <- i + ntrue } } ylong <- as.matrix(ylong) colnames(ylong) <- colname.y1 df <- data.frame(ylong, xlong) rownames(df) <- rownames if(sort) { stopifnot(ncol(df) >= 2) icol <- c(2:ncol(df), 1) # want y column to be last in sort order # this sorts on variable values (variables on left take precedence) # see example on help page for "order" df <- df[ do.call(order, df[,icol]), ] } else { attr(df, "bpairs.index") <- bpairs.index } attr(df, "ynames") <- colnames(y) df } possibly.delete.column <- function(x, y, icol) { stopifnot(is.data.frame(x) && is.data.frame(y)) stopifnot(icol >= 1 && icol <= 2 && ncol(y) == 2) colname.y <- colnames(y)[icol] if(!is.null(colname.y) && nchar(colname.y) > 0) { imatch <- match(colname.y, colnames(x), 0) if(length(imatch) > 1) # paranoia stopf("multiple columns match '%s'", colname.y) if(imatch) { # warnf("dropping column '%s' from x because it matches a column name in y", colnames(x)[imatch]) x[[imatch]] <- NULL # delete the column in x } } x } earth/R/mars.to.earth.R0000644000176200001440000002111413443106103014360 0ustar liggesusers# mars.to.earth.R: convert an mda:mars object to an earth object # # Stephen Milborrow Mar 2007 Forden, Wales # # The differences between mda:mars and earth objects are: # # 1. mars returns the MARS basis matrix in $x; # earth returns it in $bx. # There is no $x component of earth. # # 2. after the forward pass, earth discards lin dep terms in # bx, dirs and cuts # # 3. mars returns $all.terms; earth doesn't # Unneeded because of 2 above. # # 4. mars returns $lenb; earth doesn't. # Unneeded because of 2: lenb == nrow(cuts) == nrow(dirs) # # 4. mars$factor == earth$dirs (i.e. factor renamed to dirs). # In general, model$factor (sometimes called factors) is not # treated uniformly in the R code, so there seems to be no # compelling need to names dirs factor. # Note that this is not the same as model$terms$factors, # which is treated uniformly (but means something different). # Also earth$dirs can have a value of 2, for lin dep terms. # # 5. the formal arguments to mars and earth differ, thus $call differs # # 6. earth objects can be created through the formula interface and # if so will have a $terms field (doesn't apply to the conversion below) # # 7. earth objects have some extra components # # 8. mars normalizes the wp arg to len 1; earth normalizes the wp len # equal to the number of cols in y (so an all 1s wp argument is # equivalent to no wp argument). mars.to.earth <- function(object=stop("no 'object' argument"), trace=TRUE) { check.classname(object, substitute(object), "mars") trace <- as.numeric(check.numeric.scalar(trace, logical.ok=TRUE)) oldcall <- object$call newcall <- object$call newcall[[1]] <- as.name("earth") if(!is.null(object$call$prune) && !eval.parent(object$call$prune)) newcall$pmethod <- "none" # prune=FALSE was specified in the original call newcall$prune <- NULL if(!is.null(object$call$trace.mars) && eval.parent(object$call$trace.mars)) newcall$trace <- 4 # trace.mars=TRUE was specified in original call newcall$trace.mars <- NULL y <- eval.parent(object$call$y) # convert vector y to ncases x 1 matrix so can access uniformly below if(is.null(dim(y))) dim(y) <- c(length(y), 1) nresp <- ncol(y) # number of responses ncases <- nrow(y) # number of cases weights.used <- FALSE if(!is.null(object$call$wp)) { newcall$wp <- object$call$wp object$call$wp <- NULL # prevent partial match to "w" below weights.used <- TRUE } if(!is.null(object$call[["w"]]) && !is.null(eval.parent(object$call[["w"]]))) { warning0("the 'w' argument was used in the original call to mda::mars\n", "although mda::mars actually ignores the 'w' argument") newcall$weights <- object$call$w weights.used <- TRUE } newcall$w <- NULL newcall$forward.step <- NULL newcall$prev.fit <- NULL if(!is.null(dim(residuals))) dim(residuals) <- c(ncol(y), nrow(y)) # convert vector to ncases x 1 matrix nselected <- length(object$selected.terms) residuals <- object$residuals penalty <- object$penalty # Renumber selected.terms. Needed because earth drops terms from cuts and # dirs that are not in all.terms (whereas mars does not). selected <- repl(NA, nrow(object$factor)) selected[object$all.terms] <- FALSE selected[object$selected.terms] <- TRUE selected <- selected[!is.na(selected)] selected.terms <- (1:length(selected))[selected] # Fill in the [1] and [nselected] elements of rss.per.subset and gcv.per.subset. # This is enough for print.earth() and summary.earth() etc. to work. # You can fill in all the elements by calling update.earth() later. # We don't call update.earth() now because minor differences between pruning # pass implementations could conceivably change selected.terms. ntermsVec <- repl(NA, length(object$all.terms)) ntermsVec[1] <- 1 # intercept ntermsVec[nselected] <- nselected # nterms of selected model rss.per.subset <- repl(NA, length(object$all.terms)) rss.per.subset[1] <- sum(colSums((y - colMeans(y)) ^ 2)) # null RSS rss.per.subset[nselected] <- sos(residuals) # RSS of selected model rss <- rss.per.subset[nselected] # RSS of selected model gcv.per.subset <- get.gcv(rss.per.subset, ntermsVec, penalty, ncases) gcv <- gcv.per.subset[nselected] # GCV of selected model rss.per.response <- vector(mode="numeric", length=nresp) rsq.per.response <- vector(mode="numeric", length=nresp) gcv.per.response <- vector(mode="numeric", length=nresp) grsq.per.response <- vector(mode="numeric", length=nresp) for(iresp in seq_len(nresp)) { rss.per.response[iresp] <- sos(residuals[,iresp]) tss <- sos(y[,iresp] - mean(y[,iresp])) rsq.per.response[iresp] <- get.rsq(rss.per.response[iresp], tss) gcv.null <- get.gcv(tss, 1, penalty, ncases) gcv.per.response[iresp] <- get.gcv(rss.per.response[iresp], nselected, penalty, ncases) grsq.per.response[iresp] <- get.rsq(gcv.per.response[iresp], gcv.null) } pred.names <- gen.colnames(object$factor, "x", "x", trace=0) term.names <- get.earth.term.name(seq_len(nrow(object$factor)), object$factor, object$cuts, pred.names, NULL, warn.if.dup=FALSE) duplicated <- duplicated(term.names) if(any(duplicated)) { ndup <- sum(duplicated) term.names[duplicated] <- sprint("%s.%d", term.names[duplicated], seq_len(ndup)) if(trace > 0) printf("Renamed %d duplicated term name%s to %s\n\n", ndup, if(ndup == 1) "" else "s", quote.with.c(term.names[duplicated])) } dimnames(object$factor) <- list(term.names, pred.names) dimnames(object$cuts) <- list(term.names, pred.names) colnames(object$x) <- term.names[selected.terms] rownames(object$coefficients) <- term.names[selected.terms] resp.names <- gen.colnames(object$fitted.values, "y", "y", trace=0) colnames(object$fitted.values) <- resp.names colnames(object$residuals) <- resp.names colnames(object$coefficients) <- resp.names dirs <- object$factor[object$all.terms, , drop=FALSE] leverages = try(hatvalues.qr(lm.fit(object$x, y, singular.ok=FALSE)$qr, maxmem=0, trace=0), silent=trace == 0) if(is.try.err(leverages)) leverages <- NULL rval <- structure(list( bx = object$x, dirs = dirs, cuts = object$cuts[object$all.terms, , drop=FALSE], selected.terms = selected.terms, prune.terms = NULL, # init later if you want by calling update.earth() rss = rss, rsq = get.rsq(rss, rss.per.subset[1]), gcv = gcv, grsq = get.rsq(gcv, gcv.per.subset[1]), rss.per.response = rss.per.response, rsq.per.response = rsq.per.response, gcv.per.response = gcv.per.response, grsq.per.response = grsq.per.response, rss.per.subset = rss.per.subset, gcv.per.subset = gcv.per.subset, fitted.values = object$fitted.values, residuals = residuals, coefficients = object$coefficients, leverages = leverages, pmethod = "backward", penalty = object$penalty, namesx = colnames(dirs), namesx.org = colnames(dirs), call = newcall), class = "earth") if(weights.used) { # wp or w args used in original call? # mars and earth normalize wp differently, see header comments # TODO there is probably a better way of handling this warning0("w or wp were used in the original call to mars.\n", " Running update.earth to conform mars ", "use of weights to earth.\n") rval <- update(object=rval) } else if(!isTRUE(all.equal(object$gcv, rval$gcv))) warning0("the original mars GCV is ", object$gcv, "\n ", "but the GCV recalculated for earth is ", rval$gcv, "\n") if(trace > 0) { printcall("Converted ", oldcall) cat("\n") printcall("to ", newcall) cat("\n") } rval } earth/R/expand.arg.R0000644000176200001440000001314013412600075013725 0ustar liggesusers# expand.arg.R: # contr.earth.response returns an nlevels by nlevels diag matrix e.g. # # A B C # A 1 0 0 # B 0 1 0 # C 0 0 1 # # The base and contrasts arguments are ignored contr.earth.response <- function(x, base, contrasts) { contr <- array(0, c(length(x), length(x)), list(x, x)) diag(contr) <- 1 contr } # Return x but with factors expanded into dummy variables. # and with all values converted to double. # Always returns a matrix (never a vector) and always with column names. # Factors in earth's y argument are expanded to indicator columns exactly # like factors in the x argument, except contr.earth.response is always used. expand.arg <- function(x, # "x" is x or y arg to earth env, # evironment for evaluation trace, # passed to gen.colnames is.y.arg=FALSE, # is.y.arg is TRUE if y arg to earth xname=NULL, # used for colnames when x has no name is.earth.default=FALSE) # TRUE if called for x arg of earth.default { if(is.null(xname)) xname <- sub(".*\\$", "", trunc.deparse(substitute(x))) # temp$y becomes y if(is.null(ncol(x))) # make sure x is a matrix, not a vector dim(x) <- c(nrow=length(x), ncol=1) if(is.y.arg) { # We must do this here else the call to model.matrix later generates # two columns for each logical or two-level factor column. x <- convert.two.level.to.numeric(x) } if(is.double(x)) { # Already double so no need to convert. Note that is.double returns # TRUE for a matrix of doubles but always FALSE for data.frames. colnames(x) <- gen.colnames(x, xname, if(is.y.arg) "y" else "x", trace, xname) return(x) } if(is.y.arg) { # We always use contr.earth.response for the y argument (left side of formula). old.contrasts <- getOption("contrasts") on.exit(options(contrasts=old.contrasts)) options(contrasts=c("contr.earth.response", "contr.earth.response")) } ncol.x <- NCOL(x) is.data.frame <- is.data.frame(x) if(is.data.frame) mf <- call("model.frame", formula = ~., data=x, na.action=na.pass) else mf <- call("model.frame", formula = ~x, na.action=na.pass) mf <- eval(mf, env) # this is slow mf.has.colnames <- !is.null(colnames(mf)) x <- model.matrix(object=attr(mf, "terms"), data=mf) intercept <- match("(Intercept)", colnames(x), nomatch=0) if(intercept) x <- x[, -intercept, drop=FALSE] # discard intercept # If !is.data.frame, model.matrix prepends "x" to the column names, # so remove the "x", but only if x had column names to begin with. # Dec 2018: included !is.earth.default to prevent plotmo mistaking the following # model as an intercept-only model: earth(x=Insurance$Age, y=Insurance$Claims) # where Insurance$Age is a factor which gets expanded to x.L, x.Q, x.C colnames.x <- colnames(x) if(!is.earth.default && !is.data.frame && mf.has.colnames) colnames(x) <- substr(colnames(x), 2, 61) # strip 1st char of each colname # ensure all columns are named colnames(x) <- gen.colnames(x, xname, if(is.y.arg) "y" else "x", trace, xname) x # all columns are now double with column names } # Here "two.level" means logical or two-level factor. # These get converted to a numeric column of 0s and 1s. # This code doesn't touch y if no changes are needed. convert.two.level.to.numeric <- function(y) { stopifnot(!is.null(dim(y))) if(is.data.frame(y)) { # Dataframe, so handle each column independently. # Get here if y is a dataframe in call to earth.default. for(icol in seq_len(ncol(y))) { ycol <- y[,icol] if(is.logical(ycol)) y[,icol] <- as.numeric(ycol) else if(is.factor(ycol) && nlevels(ycol) <= 2) # two-level factor? y[,icol] <- as.numeric(ycol) - 1 } } else { # Not dataframe, must be a matrix. All columns are of the same class. # Can't use above code because for example y[,icol] <- as.numeric(ycol) # generates NAs if y is a matrix of factors. convert.logical <- convert.factor <- FALSE colnames <- colnames(y) for(icol in seq_len(ncol(y))) { ycol <- y[,icol] if(is.character(ycol)) # model.matrix in expand.arg would later convert the column to two columns # if nbr unique strings is two, which is incorrect, so block that here # TODO it would be better to process this rather than issue an error message stop0("y is a character variable: \"", ycol[1], "\", \"", if(length(y) >= 2) ycol[2] else "", "\", \"", if(length(y) >= 3) ycol[3] else "", "\", ...") else if(is.logical(ycol)) convert.logical <- TRUE else if(is.factor(ycol) && nlevels(ycol) <= 2) { # two-level factor? convert.factor <- TRUE if(!is.null(colnames) || ncol(y) == 1) colnames[icol] <- levels(ycol)[2] } } nrow <- nrow(y) ncol <- ncol(y) if(convert.logical) { y <- as.numeric(y) # convert to 0s and 1s dim(y) <- c(nrow, ncol) colnames(y) <- colnames } else if(convert.factor) { y <- as.numeric(y) - 1 # minus 1 to convert to 0s and 1s dim(y) <- c(nrow, ncol) colnames(y) <- colnames } } y } earth/R/earthlib.R0000644000176200001440000000055113412663077013505 0ustar liggesusers# earthlib.R: general purpose routines for the earth package # Modify call to refer to the generic e.g. "foo.default" becomes "foo". # This means that functions like update() call foo() and not foo.default(). # An advantage is that we don't have to export foo.default(). make.call.generic <- function(call, fname) { call[[1]] <- as.name(fname) call } earth/R/printcall.R0000644000176200001440000001323713323512123013672 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(...)") } earth/R/predict.earth.R0000644000176200001440000001536213443036072014446 0ustar liggesusers# predict.earth.R predict.earth <- function( object = stop("no 'object' argument"), newdata = NULL, type = c("link", "response", "earth", "class", "terms"), interval = "none", level = .95, # only used if interval != none thresh = .5, # only used if type="class" trace = FALSE, ...) # unused, for compatibility with generic predict { check.classname(object, substitute(object), "earth") warn.if.dots(...) trace <- as.numeric(check.numeric.scalar(trace, logical.ok=TRUE)) type <- match.arg1(type, "type") env <- parent.frame() # the environment from which predict.earth was called if(type == "terms") fit <- predict_earth_terms(object, newdata, env, trace) else fit <- predict_earth_aux(object, newdata, env, type, thresh, trace) interval <- match.choices(interval, c("none", "pint", "cint", "se", "abs.residual"), "interval") if(interval == "none") { if(!missing(level)) stop0("predict.earth: level=", as.char(level), " was specified but interval=\"none\"") return(fit) # note return } # the interval argument was used if(is.null(object$varmod)) stop0("no prediction intervals because ", "the earth model was not built with varmod.method") if(type == "class" || type == "terms") stop0("predict.earth: the interval argument is not allowed ", "with type=\"", type, "\"") if(!is.null(object$glm.list) && type != "earth") stop0("predict.earth: with earth-glm models, use type=\"earth\" ", "when using the interval argument") if(NCOL(fit) != 1) stop0("predict.earth: the interval argument is not supported ", "for multiple response models") predict.varmod(object$varmod, newdata=newdata, type=interval, level=level) } predict_earth_aux <- function(object, newdata, env, type, thresh, trace) { type.is.class <- type=="class" if(type.is.class) { type <- "response" # we want predicted probabilities ylevels <- object$levels if(is.null(ylevels)) ylevels <- c(FALSE, TRUE) } if(is.null(newdata)) # no newdata? fit <- predict_earth_without_newdata(object, type, trace) else # user supplied newdata fit <- predict_earth_with_newdata(object, newdata, env, type, trace) if(type.is.class) fit <- convert.predicted.response.to.class(fit, ylevels, colnames(object$coefficients)[1], thresh) fit } predict_earth_without_newdata <- function(object, type, trace) { if(is.null(object$glm.list) || type=="earth") { print_returning_earth(object, trace, "fitted.values") fit <- object$fitted.values } else { # glm predictions trace1(trace, "predict.earth: returning glm fitted.values\n") fit <- matrix(0, nrow=nrow(object$fitted.values), ncol=ncol(object$fitted.values)) colnames(fit) <- colnames(object$fitted.values) for(i in seq_along(object$glm.list)) fit[,i] = predict.glm(object$glm.list[[i]], type=type) } fit } predict_earth_with_newdata <- function(object, newdata, env, type, trace) { bx <- model.matrix.earth(object, newdata, trace=trace, Env=env, Callers.name="model.matrix.earth from predict.earth") if(trace >= 1) { print_summary(bx, "predict.earth with newdata: bx", trace=2) trace2(trace, "\n") } offset <- get.predict.offset(object, newdata, trace) if(is.null(object$glm.list) || type=="earth") { print_returning_earth(object, trace, "predictions") fit <- bx %*% object$coefficients if(!is.null(offset)) { stopifnot(NROW(fit) == NROW(offset)) fit <- fit + offset } } else { # glm predictions if(trace >= 1) cat("predict.earth: returning glm", type, "predictions\n") fit <- matrix(0, nrow=nrow(bx), ncol=ncol(object$fitted.values)) colnames(fit) <- colnames(object$fitted.values) bx <- eval(bx[,-1, drop=FALSE], envir=env) # -1 to drop intercept bx.data.frame <- as.data.frame(bx) if(!is.null(offset)) { stopifnot(NROW(bx.data.frame) == NROW(offset)) bx.data.frame$offset <- offset } for(i in seq_along(object$glm.list)) { fit[,i] = predict.glm(object$glm.list[[i]], newdata=bx.data.frame, type=type) check.nrows(nrow(bx), nrow(fit), nrow(object$fitted.values), "predict.earth") } } fit } print_returning_earth <- function(object, trace, msg) { if(trace >= 1) { if(is.null(object$glm.list)) cat("predict.earth: returning earth", msg, "\n") else cat("predict.earth: returning earth (not glm)", msg, "\n") } } convert.predicted.response.to.class <- function(resp, ylevels, resp.name, thresh=.5) { which1 <- function(row, thresh) # row is a scalar or a vector { if(length(row) > 1) which. <- which.max(row) else which. <- if(row > thresh) 2 else 1 which. } if(is.null(ylevels)) # should never happen stop0("predict.earth: cannot use type=\"class\" with this model") check.numeric.scalar(thresh) resp <- ylevels[apply(resp, 1, which1, thresh)] if(is.character(ylevels)) resp <- factor(resp, levels = ylevels) fit <- as.matrix(resp, ncol=1) colnames(fit) <- resp.name fit } # type="terms" was passed to predict.earth, return just enough for termplot to work predict_earth_terms <- function(object, newdata, env, trace) { if(!is.null(object$glm.list)) warning0("predict.earth: returning the earth (not glm) terms") bx <- model.matrix.earth(object, x=newdata, trace=trace, Env=env, Callers.name="predict.earth") dirs <- object$dirs[object$selected.terms, , drop=FALSE] # retain only additive terms additive.terms <- get.degrees.per.term(dirs) == 1 bx <- bx[, additive.terms, drop=FALSE] dirs <- dirs[additive.terms, , drop=FALSE] coefs <- object$coefficients[additive.terms, 1, drop=FALSE] additive.preds <- colSums(abs(dirs)) != 0 dirs <- dirs[, additive.preds, drop=FALSE] var.names <- variable.names(object, use.names=TRUE)[additive.preds] termMat <- matrix(0, nrow=nrow(bx), ncol=ncol(dirs)) colnames(termMat) <- var.names if(ncol(bx) >= 1) for(ipred in seq_len(ncol(dirs))) for(iterm in seq_len(ncol(bx))) if(dirs[iterm, ipred]) termMat[, ipred] = termMat[, ipred] + coefs[iterm] * bx[, iterm] termMat } earth/R/earth.glm.R0000644000176200001440000004232413445505262013575 0ustar liggesusers# earth.glm.R: Generalized Linear Model support for earth try.something.like <- "Try something like earth(y~x, glm=list(family=binomial))" check.glm.model <- function(g, resp.name) # g is a model created by calling glm() { # TODO following check is pointless? df is only defined for summary.glm? df <- if("df" %in% names(g)) g[["df"]] else NULL # avoid partial matching if(!is.null(df) && (nsingular <- df[3] - df[1])) stop0("earth glm response \"", resp.name, "\": ", nsingular, " coefficients not defined because of singularities") glm.coef <- coef(g) if(length(glm.coef) == 0) stop0("earth glm response \"", resp.name, "\": no glm coefficients") check.vec(glm.coef, "glm coef") } # Check for a common user error: specifying a family argument # to earth that is not wrapped in glm=list(family=...)) # Jan 2019: also check that epsilon and maxit are properly enclosed in glm list check.no.family.arg.to.earth <- function(..., is.null.glm.arg) { dots <- match.call(expand.dots=FALSE)$... if(!is.null(dots$fa)) # partial match stop0("illegal 'family' argument to earth\n", try.something.like) if(!is.null.glm.arg) { if(!is.null(dots$eps)) stop0("illegal 'epsilon' argument to earth\n", "Try something like earth(y~x, glm=list(family=binomial, control=list(epsilon=1e-9)))") if(!is.null(dots$maxi)) stop0("illegal 'maxit' argument to earth\n", "Try something like earth(y~x, glm=list(family=binomial, control=list(maxit=99)))") } } # Note that on entry process.glm.arg has already checked the glm argument # Most args are direct copies of args to earth.fit. earth.glm <- function(bx, y, weights, na.action, offset, glm.arg, trace, is.bpairs, env) { hack.intercept.only.glm.model <- function(g) { # Skullduggery for intercept-only glm models. # Get the model into a form usable by later functions like predict(). # We need to remove all references to EarthIntercept else predict() # will try to find it and complain because it cannot. g$coefficients <- g$coefficients[1] g$R <- g$R[1,1] g$qr$qr <- g$qr$qr[,1,drop=FALSE] g$model <- g$model[,1,drop=FALSE] g$x <- g$x[,1,drop=FALSE] g$data <- NULL # yarg ~ EarthIntercept becomes yarg ~ yarg # TODO this approach used because glm() won't allow just yarg~ g$terms[[3]] <- g$terms[[2]] # list(yarg, EarthIntercept) becomes list(yarg) attr(g$terms, "variables") <- call("list", quote(yarg)) # EarthIntercept # yarg 0 becomes an empty matrix attr(g$terms, "factors") <- matrix(nrow=0, ncol=0) # "EarthIntercept" becomes an empty character vector attr(g$terms, "term.labels") <- character(0) # list(yarg, EarthIntercept) becomes list(yarg) attr(g$terms, "predvars") <- call("list", quote(yarg)) g } #--- earth.glm starts here --- if(trace >= 4) cat("\n") ncases <- nrow(bx) intercept.only <- ncol(bx) == 1 if(intercept.only) { # glm() requires something on the rhs of the formula. # But this is an intercept-only model, so actually nothing on the rhs. # To work around that, give glm() the earth intercept, which will have # no effect on the glm model but will cause an extra coefficient etc. in # the value returned by glm. We remove that extra data later (in # hack.intercept.only.glm.model). # Actually the fake intercept does have a small effect on the # model: dof is off by one (which also affects vals derived from dof). trace1(trace, "earth.glm: intercept-only earth model\n") bx.data.frame <- as.data.frame(bx) # bx has a single column, the earth intercept colnames(bx.data.frame) <- "EarthIntercept" # for sanity checking } else { # default operation: drop intercept with -1 bx.data.frame <- as.data.frame(eval.parent(bx[, -1, drop=FALSE])) } # Convert args to form expected by glm(). # We need to convert glm() args whose default is not NULL. control <- glm.arg$control if(is.null(control)) control <- glm.control() # FIXED (earth 2.3-5): get control params if(!is.null(glm.arg$epsilon)) control$epsilon <- glm.arg$epsilon if(!is.null(glm.arg$maxit)) control$maxit <- glm.arg$maxit if(!is.null(glm.arg$trace)) control$trace <- glm.arg$trace family <- get.glm.family(glm.arg$family, env=env) stopifnot(is.null(glm.arg$weights)) glm.list <- list() # returned list of glm models non.converged <- NULL for(iycol in seq_len(ncol(y))) { # for each y column yarg <- if(is.bpairs) y[,1:2] # two columns else y[, iycol, drop=FALSE] # single column stopifnot(!is.null(colnames(yarg))) if(trace >= 4) { print_summary(yarg, "glm y", trace=2) printf("\n") print_summary(weights, "glm weights", trace=2) printf("\n") } # FIXED (earth 2.3-4): removed offset etc. arguments because of # difficulties evaluating them later in the correct environment # (process.glm.arg has already checked if such args were supplied by the user). # TODO consider setting x=FALSE, y=FALSE if keepxy=-1 g <- glm(yarg ~ ., family=family, data=bx.data.frame, weights=weights, na.action=na.action, offset=offset, control=control, model=TRUE, trace=(trace>=2), method="glm.fit", x=TRUE, y=TRUE, contrasts=NULL) if(intercept.only) g <- hack.intercept.only.glm.model(g) # if !converged remember this response for warning later if(!g$converged) non.converged <- c(non.converged, colnames(yarg)[1]) if(trace >= 1) { printf("GLM %s devratio %.2f dof %d/%d iters %d\n", colnames(yarg)[1], get.devratio(g$null.deviance, g$deviance), g$df.residual, g$df.null, g$iter) } check.glm.model(g, colnames(yarg)[1]) glm.list[[iycol]] <- g if(is.bpairs) { stopifnot(NCOL(y) == 2) # paranoia break # note break } } if(!is.null(non.converged)) warning0("the glm algorithm did not converge for response", if(length(non.converged) == 1) " " else "s ", quotify(non.converged)) glm.list } # process family here instead of in glm() so can give relevant error message get.glm.family <- function(family, env) { if(is.null(family)) family <- gaussian if(is.character(family)) family <- get(family, mode="function", envir=env) if(is.function(family)) family <- family() if(!inherits(family, "family") || is.null(family$family)) stop0("earth: illegal 'family' in 'glm' argument\n", try.something.like) family } # This returns earth's glm argument but with abbreviated names # expanded to their full name. It also checks that the glm argument is # valid. Called before calling glm(). We want to make sure that the # user hasn't specified, say, subset as a glm argument. The subset # should only be specified as an earth argument so the subset is the # same for earth and glm. # FIXED (earth 2.3-4): disallow offset etc. arguments because of # difficulties evaluating them later in the correct environment. process.glm.arg <- function(glm.arg) # glm.arg is earth's glm argument { # return glm.arg but with abbreviated names expanded to their full name. match.glm.arg <- function(glm.arg) { allowed.glm.args <- c("formula", "family", "data", "weights", "subset", "na.action", "control", "model", "method", "x", "y", "contrasts", "epsilon", "maxit", "trace", "bpairs") for(i in seq_along(glm.arg)) { name <- names(glm.arg)[[i]] j <- pmatch(name, "bpairs", nomatch=0) if(j != 0) warning0("earth: the '", name, "' argument is no longer supported\n", " (binomial pairs are determined automatically)\n", " See comments for 'bpairs' in the earth NEWS file (earth version 5.0.0)") j <- pmatch(name, allowed.glm.args, nomatch=0) if(j == 0) stop0("earth: '", name, "' is not supported in glm argument to earth") if(allowed.glm.args[j] != "bpairs") names(glm.arg)[[i]] <- allowed.glm.args[j] } # expand family argument if it is a string if(is.character(glm.arg$family)) { family.strings <- c("binomial", "gaussian", "Gamma", "inverse.gaussian", "poisson", "quasi", "quasibinomial", "quasipoisson") i <- pmatch(glm.arg$family, family.strings, nomatch=0) if(i == 0) stop0("earth: illegal family '", glm.arg$family, "' in glm argument\n", try.something.like) glm.arg$family <- family.strings[i] } glm.arg } #--- process.glm.arg starts here --- if(is.null(glm.arg)) return(NULL) if(!is.list(glm.arg)) stop0("earth: 'glm' argument must be a list\n", try.something.like) if(length(glm.arg) == 0) stop0("earth: 'glm' argument list is empty\n", try.something.like) argnames <- names(glm.arg) if(length(argnames) == 0) stop0("earth: no argument names in 'glm' argument list\n", try.something.like) glm.arg <- match.glm.arg(glm.arg) # expand argument names to their full name if(is.null(glm.arg$family)) stop0("earth: 'glm' argument must have a 'family' parameter\n", try.something.like) always.true.args <- c("x", "y", "model") imatch <- pmatch(always.true.args, argnames, nomatch=0) if(any(imatch)) stop0("earth: illegal '", argnames[imatch[1]], "' in 'glm' argument\n", "These are always effectively TRUE") earths.args <- c("subset", "weights") # illegal because these get passed on to glm internally imatch <- pmatch(earths.args, argnames, nomatch=0) if(any(imatch)) { imatch <- imatch[imatch != 0] stop0("earth: illegal '", argnames[imatch[1]], "' in 'glm' argument\n", " Use earth's '", argnames[imatch[1]], "' argument instead ", "(which will be passed on to glm internally)") } earths.args <- c("formula") # this is plain illegal imatch <- pmatch(earths.args, argnames, nomatch=0) if(any(imatch)) { imatch <- imatch[imatch != 0] stop0("earth: illegal '", argnames[imatch[1]], "' in 'glm' argument\n", " Use earth's '", argnames[imatch[1]], "' argument instead") } glm.arg } # get.glm.coefs returns a ncoeffs * nresponses matrix get.glm.coefs <- function(glm.list, nresp, selected.terms, term.names, resp.names) { coefs <- matrix(nrow=length(selected.terms), ncol=nresp) col.names <- character(length=nresp) for(iresp in seq_len(nresp)) { coefs[,iresp] <- glm.list[[iresp]]$coefficients col.names[iresp] <- resp.names[iresp] } colnames(coefs) <- col.names rownames(coefs) <- term.names[selected.terms] coefs } is.binomial <- function(family) # return true if family is binomial or quasibinomial { ( (is.character(family) && # e.g. "binomial" (substr(family, 1, 1) == "b" || substr(family, 1, 6) == "quasib")) # "quasib" excludes "quasip" (quasipoisson) || (class(family)[1] == "function" && # e.g. binomial (identical(body(family), body(binomial)) || identical(body(family), body(quasibinomial)))) || (class(family)[1] == "family" && # e.g. binomial() (family$family == "binomial" || family$family == "quasibinomial")) ) } is.poisson <- function(family) # return true if family is poisson or quasipoisson { ( (is.character(family) && # e.g. "poisson" (substr(family, 1, 1) == "p" || substr(family, 1, 6) == "quasip")) # "quasip" excludes "quasib" (quasibinomial) || (class(family)[1] == "function" && # e.g. poisson (identical(body(family), body(poisson)) || identical(body(family), body(quasipoisson)))) || (class(family)[1] == "family" && # e.g. poisson() (family$family == "poisson" || family$family == "quasipoisson")) ) } # called from print.summary.earth print_earth_glm <- function(object, digits, fixed.point, prefix.space) { glm.list <- object$glm.list nresp <- length(glm.list) # print the maxit if any glm model did not converge maxit.msg <- "" for(iresp in seq_len(nresp)) { g <- glm.list[[iresp]] if(!g$converged) { maxit.msg <- sprint(", maxit=%g", g$control$maxit) break # note break } } cat0(if(prefix.space) " " else "", "GLM (family ", glm.list[[1]]$family$family, ", link ", glm.list[[1]]$family$link, maxit.msg, "):\n") stopifnot(!is.null(object$glm.stats)) print(tweak.glm.stats.for.printing(object$glm.stats, digits, fixed.point, prefix.space), digits=max(3, digits-1)) cat0("\n") } get.glm.stats <- function(glm.list, response.names) { # not sure if all glm models have an aic field, so play safe with aic field aic <- glm.list[[1]]$aic[1] has.aic <- !is.null(aic) && !anyNA(aic) nresp <- length(glm.list) stats <- matrix(nrow=nresp, ncol=7+has.aic) colnames <- c("nulldev", "df", "dev", "df", "devratio") if(has.aic) colnames <- c(colnames, "AIC") colnames(stats) <- c(colnames, "iters", "converged") if(nresp == 1) rownames(stats) <- "" else rownames(stats) <- response.names for(iresp in seq_len(nresp)) { g <- glm.list[[iresp]] devratio <- get.devratio(g$null.deviance, g$deviance) if(has.aic) stats[iresp,] <- c(g$null.deviance, g$df.null, g$deviance, g$df.residual, devratio, g$aic, g$iter, g$converged) else stats[iresp,] <- c(g$null.deviance, g$df.null, g$deviance, g$df.residual, devratio, g$iter, g$converged) } stats } get.devratio <- function(null.deviance, deviance) { devratio <- (null.deviance - deviance) / null.deviance # TODO not sure what best boundary cases handling is if(null.deviance < 0 || is.nan(devratio)) # division by zero return(NA) if(devratio < 1e-4) devratio <- 0 # prevent e.g. -0.0 and unsightly things like "3.45e-6" devratio } tweak.glm.stats.for.printing <- function(stats, digits, fixed.point, prefix.space) { has.aic <- "AIC" %in% colnames(stats) stats[,"nulldev"] <- signif(stats[,"nulldev"], digits) stats[,"dev"] <- signif(stats[,"dev"], digits) stats[,"devratio"] <- signif(stats[,"devratio"], max(2, digits-4)) if(has.aic) # signif() matches code in stats::print.glm stats[,"AIC"] <- signif(stats[,"AIC"], max(3, digits-3)) # space out columns for readability colnames(stats) <- if(has.aic) c(paste0(if(prefix.space) " " else "", "nulldev"), "df", " dev", "df", " devratio", " AIC", "iters", "converged") else c(paste0(if(prefix.space) " " else "", "nulldev"), "df", " dev", "df", " devratio", " iters", "converged") stats } # Called from print.summary.earth # g is a glm object # Most of the following was lifted from print.summary.glm # but tweaked to include response names (necessary for multiple # response glm earth models). print_glm_details <- function(g, nresp, digits, fixed.point, resp.name) { if(nresp > 1) prefix <- paste("GLM", resp.name) else prefix <- paste("GLM") sumg <- summary(g) cat0(prefix, " deviance residuals:\n") if(sumg$df.residual > 5) { sumg$deviance.resid <- quantile(sumg$deviance.resid,na.rm=TRUE) names(sumg$deviance.resid) <- c("Min", "1Q", "Median", "3Q", "Max") } print.default(sumg$deviance.resid, digits=digits, na.print="", print.gap=2) df <- if("df" %in% names(sumg)) sumg[["df"]] else NULL cat0("\n", prefix) cat0(" coefficients (family ", g$family$family, ", link ", g$family$link, ")\n") if(!is.null(df) && (nsingular <- df[3] - df[1])) cat0(nsingular, # should never happen for earth glm " coefficients not defined because of singularities\n") aliased <- is.na(coef(g)) stopifnot(length(aliased) > 0, all(!aliased)) # already checked in check.glm.model coefs <- sumg$coefficients rownames(coefs) <- spaceout(rownames(coefs)) # TODO can't use fixed.point here, would like to printCoefmat(coefs, digits=digits, signif.stars=FALSE, na.print="NA") if(sumg$dispersion != 1) # only show dispersion if it is not 1 cat0("\n", prefix, " dispersion parameter for ", sumg$family$family, " family taken to be ", sumg$dispersion, "\n") cat("\n") NULL } earth/R/offset.R0000644000176200001440000001105313437342062013173 0ustar liggesusers# offset.R: misc functions for handling an offset term in the earth formula # If an offset variable is specified in the formula, the variable must be in the data # (it can't be passed as a global variable, independently of the data). # Without this check, the earth model will build ok, but predict.earth later fails, # because stat::model.frame fails (with a confusing message) if offset is not in the data. # (Models built with lm have this problem, but with earth we instead help the user here.) check.offset.var.is.in.data <- function(terms, data) { if(is.null(data)) stopf("if an offset is specified in the formula, the 'data' argument must be used") offset.index <- attr(terms,"offset") stopifnot(!is.null(offset.index)) if(length(offset.index) > 1) stop0("only one offset is allowed") varnames <- rownames(attr(terms, "factors")) stopifnot(!is.null(varnames)) stopifnot(offset.index >= 1) stopifnot(offset.index <= length(varnames)) offset.term <- varnames[offset.index] stopifnot(grepl("^offset\\(", offset.term)) # convert "offset(foo)" to "foo" offset.varname <- substring(offset.term, 8, nchar(offset.term)-1) offset.varname <- naken(offset.varname) # convert e.g. "log(Holders)" to "Holders" if(!(offset.varname %in% colnames(data))) stopf("the offset variable '%s' in '%s' must be in the data", offset.varname, offset.term) } # This converts an offset of say "log(Holders)" to "Holders". # It was copied from the plotmo code. # It's overkill for nudifying offset specs, but works for that purpose. # TODO Could use base::all.vars here instead? naken <- function(s) # e.g. "s(x3,x4,df=4)" becomes "x3+x4" { s <- paste.collapse(strip.space(s)) # We don't want to mess with anything in [square brackets]. # So we replace the bracketed expression with "#BRACKETS#", # and then replace that back again at the end. # Needed for e.g. lm(trees[,3]~trees[,1:2]) brackets <- replace.brackets("\\[.*\\]", "#BRACKETS#", s) s <- brackets$s s <- gsub("[-*/:]", "+", s) # replace - / * : with + # next two gsubs allow us to retain "x=x1" but drop "df=99" from "bs(x=x1, df=99)" s <- gsub("\\(._$[[:alnum:]]+=", "(", s) # replace "(ident=" with "(" s <- gsub("[._$[:alnum:]]+=[^,)]+", "", s) # delete "ident=any" # replace ",ident" with ")+f(ident", thus "s(x0,x1)" becomes "s(x0)f(x1)" s <- gsub(",([._$[:alpha:]])", ")+f(\\1", s) if(grepl("[._$[:alnum:]]*[(]", s)) { s <- gsub("[._$[:alnum:]]*[(]", "", s) # replace ident( s <- gsub("[,)][^+-]*", "", s) # remove remaining ",arg1,arg2)" } # s is now something like x1+x2, split it on "+" for further processing s <- strsplit(s, "+", fixed=TRUE)[[1]] s <- unique(s) # remove duplicates # remove numbers e.g. sin(x1*x2/12) is nakened to x1+x1+12, we don't want the 12 is.num <- sapply(s, function(x) grepl("^([0-9]|\\.[0-9])", x)) # but keep the intercept if there is one which1 <- which(s == "1") is.num[which1] <- FALSE s <- paste0(s[!is.num], collapse="+") sub("#BRACKETS#", brackets$brackets, s) # change #BRACKETS# back to what it was } replace.brackets <- function(pattern, place.holder, s) # utility for naken { brackets <- "" i <- regexpr(pattern, s) if(i > 0) { last <- i + attr(i,"match.length") - 1 stopifnot(last > i) brackets <- substr(s, i, last) # remember the bracketed expression s <- paste0(substr(s, 1, i-1), place.holder, substring(s, last+1)) # replace [.*] with #BRACKETS# } return(list(s=s, brackets=brackets)) } # get offset specified in model formula, if any get.predict.offset <- function(object, newdata, trace) { terms <- object$terms if(is.null(terms)) return(NULL) ioffset <- attr(terms, "offset") if(is.null(ioffset)) return(NULL) # following should have already been caught by stop.if.dots in earth.fit stopifnot(is.null(object$call$offset)) # following should have already been caught in earth.formula stopifnot(length(ioffset) == 1) # only one offset is allowed offset <- eval(attr(terms, "variables")[[ioffset+1]], envir=newdata) if(trace >= 1) cat0("predict.earth: offset: ", as.char(offset), "\n") offset } earth/R/earth.methods.R0000644000176200001440000000710513443320300014441 0ustar liggesusers# earth.methods.R: miscellaneous earth methods anova.earth <- function(object, warn=TRUE, ...) { if(warn) warning0("anova.earth: returning NULL") NULL } case.names.earth <- function(object, ...) { if(is.null(row.names(object$residuals))) paste(seq_len(nrow(object$residuals))) else row.names(object$residuals) } coef.earth <- function(object, type = c("response", "earth", "glm"), decomp="none", ...) { warn.if.dots(...) type <- match.arg1(type, "type") coef <- object$glm.coefficients if(is.null(coef)) { # not a glm model? if(type == "glm") stop0("coef.earth: type == \"glm\" is not allowed because this is not an earth-glm model") coef <- object$coefficients } else if(type == "earth") coef <- object$coefficients if(NCOL(coef) > 1) { warning0("coef.earth: multiple response model: returning coefficients for just the first response") coef <- coef[,1,drop=FALSE] } new.order <- reorder.earth(object, decomp=decomp) names <- spaceout(rownames(coef)) coef <- coef[new.order,] names(coef) <- names coef } deviance.earth <- function(object, warn=TRUE, ...) { if(warn && !is.null(object$glm.list)) warning0("deviance.earth: returning earth (not GLM) deviance") object$rss } effects.earth <- function(object, warn=TRUE, ...) { if(warn) warning0("effects.earth: returning NULL") NULL } # Fake the AIC by returning the GCV. This is enough for step() to work. extractAIC.earth <- function(fit, scale = 0, k = 2, warn=TRUE, ...) { if(warn) warning0("extractAIC.earth: returning GCV instead of AIC") if(scale != 0) warning0("extractAIC.earth: ignored scale parameter ", scale) if(k != 2) warning0("extractAIC.earth: ignored k parameter ", k) warn.if.dots(...) nterms <- length(fit$selected.terms) c(effective.nbr.of.params(nterms, get.nknots(nterms), fit$penalty), fit$gcv) } family.earth <- function(object, ...) { stopifnot(!is.null(object$glm.list)) family(object$glm.list[[1]]) } hatvalues.earth <- function(model, ...) { stop.if.dots(...) if(is.null(model$leverages)) stop0("this earth model does not have leverages") model$leverages } fitted.earth <- function(object, type="response", ...) { predict.earth(object, newdata=NULL, type=type, ...) } fitted.values.earth <- function(object, type="response", ...) { predict.earth(object, newdata=NULL, type=type, ...) } # use.names can have the following values: # TRUE: return name if possible, else return x[,i] or x[i-1]. # FALSE: return x[,i] # -1: return x[i] with 0 based indexing (treat x as a C array) variable.names.earth <- function(object, ..., use.names=TRUE) { warn.if.dots(...) ipred <- seq_len(ncol(object$dirs)) if(length(use.names) != 1) stop0("illegal value for use.names") if(use.names == TRUE) { varname <- colnames(object$dirs)[ipred] if(!is.null(varname) && !anyNA(varname)) varname else paste0("x[,", ipred, "]") } else if(use.names == FALSE) paste0("x[,", ipred, "]") else if(use.names == -1) paste0("x[", ipred-1, "]") else stop0("illegal value for use.names \"", use.names, "\"") } weights.earth <- function(object, ...) { warn.if.dots(...) if(is.null(object$weights)) # weights arg to earth was NULL? repl(1, length(object$fitted.values[,1])) else object$weights } earth/R/dotlib.R0000644000176200001440000000664213314322613013164 0ustar liggesusers# dotlib.R: miscellaneous functions for the dots routines # Arguments for par() which take a vector value (i.e. length of value is not one). PAR.VEC <- c("fig", "fin", "lab", "mai", "mar", "mfcol", "mfg", "mfrow", "mgp", "oma", "omd", "omi", "pin", "plt", "usr", "xaxp", "yaxp") # Add the elements of the extra list to the original list. Elements of the # original list that have the same names as extra elements get overwritten. # # Like utils::modifyList(keep.null=TRUE) except: # (i) input args can be NULL (NULL is treated as an empty list) # (ii) unnamed elements in extra are added to original (modifyList drops them) merge.list <- function(original, extra) { if(is.null(original)) original <- list() if(is.null(extra)) return(original) stopifnot(is.list(original)) stopifnot(is.list(extra)) # pairlist would probably be ok too for(i in seq_along(extra)) { e <- extra[[i]] name <- names(extra)[i] if(is.null(name) || !nzchar(name)) # extra element is unnamed? original <- c(original, if(is.null(e)) list(NULL) else e) else if(is.null(e)) original[name] <- list(NULL) # avoid "assign deletes elem if rhs is null" else original[[name]] <- e } original } # Evaluate each element of the list dots in the environment specified by n. # (This function can actually be used any list, but the evaluating # environment and enclosure are set up for dot arg lists.) # # TODO "scalar" is ugly, it is for par() alone and prevents # e.g. errmsg graphical parameter "lty" has the wrong length eval.dotlist <- function(dots, n=1, scalar=FALSE) { stopifnot(is.list(dots) || is.pairlist(dots)) env <- parent.frame(n) dotnames <- names(dots) for(i in seq_along(dots)) { e <- try(eval(dots[[i]], envir=env, enclos=env), silent=TRUE) if(!is.try.err(e)) { if(is.null(e)) dots[i] <- list(NULL) # avoid "assign deletes elem if rhs is null" else if(!scalar || (dotnames[i] %in% PAR.VEC) || length(e) == 1) dots[[i]] <- e else dots[[i]] <- e[[1]] # select first element of e only # TODO it would be better to drop the element entirely } } dots } # Is the string s a valid R lexigraphic identifier? # If allow.specials=TRUE we allow special chars used in DROP and KEEP strings. # The name argument is used only in error messages. stopifnot.identifier <- function(s, name=short.deparse(substitute(s)), allow.empty=FALSE, allow.specials=FALSE) { if(!is.character(s)) stop0(name, " is not a character variable (class(", name, ") is \"", class(s)[1], "\")") if(length(s) != 1) stop0(name, " has more than one element\n ", name, " = c(", paste.trunc("\"", s, "\"", sep=""), ")") if(!allow.empty && !nzchar(s)) stop0(name, " is an empty string") # TODO the following allows integers (no alphabetic characters), it shouldn't start <- if(allow.specials) # include , * $ regexpr("[^._:[:alnum:],*$]", s) else regexpr("[^._:[:alnum:]]", s) if(start > 0) stop0("illegal character \"", substr(s, start, start), "\" in ", name, " = \"", s, "\"") } earth/R/lib.R0000644000176200001440000012276213452531271012464 0ustar liggesusers# lib.R: miscellaneous functions for plotmo and related packages # functions in this file are in alphabetical order any1 <- function(x) { any(x != 0) # like any but no warning if x not logical } cat0 <- function(...) # cat with no added spaces { cat(..., sep="") } check <- function(object, object.name, check.name, check.func, na.ok=FALSE) { any <- check.func(object) if(na.ok) any <- any[!is.na(any)] else { which.na <- which(is.na(any)) if(length(which.na)) { stopf("NA in %s\n %s[%d] is %g", object.name, object.name, which.na[1], object[which.na[1]]) } } if(any(any)) { which <- which(check.func(object)) stopifnot(length(which) > 0) stopf("%s in %s\n %s[%d] is %g", check.name, object.name, object.name, which[1], object[which[1]]) } } # TODO commented out the following because it is too slow for big data # (the as.character is very slow) # # # The args argument is assumed to be a list of arguments for do.call. # # An argument in args will be an unforced promise if it couldn't be # # evaluated earlier e.g. if call.plot was invoked with arg=nonesuch. # # If an argument is such an unforced promise, issue an error message now # # to prevent very confusing error messages later. To do this, we have to # # determine if the arg is a promise, which we do with the if statement # # below. # # This makes me nervous, because the R language manual says "There is # # generally no way in R code to check whether an object is a promise or not". # # check.do.call.args <- function(func, args, fname) # { # stopifnot(is.list(args)) # for(i in seq_along(args)) { # if(length(args[i]) == 1 && !is.na(args[i]) && # substr(as.character(args[i]), 1, 2) == "..") { # printf("\n") # s <- paste0(strwrap(list.as.char(args), # width=getOption("width"), exdent=7), collapse="\n") # stop0("cannot evaluate ", quotify(names(args)[i], "'"), # " in\n ", fname, "(", s, ")") # } # } # } # mostly for checking user arguments (so error wording is for that) # but also occasionally used for other sanity checking check.boolean <- function(b) # b==0 or b==1 is also ok { if(length(b) != 1) stop0("the ", short.deparse(substitute(b), "given"), " argument is not FALSE, TRUE, 0, or 1") if(!(is.logical(b) || is.numeric(b)) || is.na(b) || !(b == 0 || b == 1)) stop0(short.deparse(substitute(b), "the argument"), "=", as.char(b), " but it should be FALSE, TRUE, 0, or 1") b != 0 # convert to logical } is.boolean <- function(b) # b==NA or b==0 or b==1 { length(b) == 1 && (is.logical(b) || is.numeric(b)) && (is.na(b) || b == 0 || b == 1) } check.classname <- function(object, substituted.object, allowed.classnames) { expected.classname <- quotify(allowed.classnames) if(length(allowed.classnames) > 1) expected.classname <- sprint("one of\n%s", expected.classname) if(is.null(object)) stopf("object is NULL but expected an object of class of %s", expected.classname) if(!inherits(object, allowed.classnames)) { stopf("the class of %s is \"%s\" but expected the class to be %s", quotify(paste.trunc(substituted.object, maxlen=30)), class(object)[1], expected.classname) } } # adjust name so e.g. error message is "argument is NULL" not "NULL is NULL" tweak.name <- function(name, quote=TRUE) { quoted.name <- quotify(name, quote="'") if(name %in% c("NULL", "NA") || (substr(name[1], 1, 1) %in% c("+", "-")) || grepl("[0-9]", substr(name[1], 1, 1))) { quoted.name <- name <- "argument" } if(quote) quoted.name else name } check.integer.scalar <- function(object, min=NA, max=NA, null.ok=FALSE, na.ok=FALSE, logical.ok=TRUE, char.ok=FALSE, object.name=short.deparse(substitute(object))) { stop.msg <- function(s) { s.null <- if(null.ok) ", or NULL" else "" s.na <- if(na.ok) ", or NA" else "" s.logical <- if(logical.ok) ", or TRUE or FALSE" else "" s.char <- if(char.ok) ", or a string" else "" stop0(s, " but it should be an integer", s.null, s.na, s.logical, s.char) } if(is.character(object)) { if(!char.ok || length(object) != 1) stop.msg(paste0(tweak.name(object.name), " is a string")) } else { check.numeric.scalar(object, min, max, null.ok, na.ok, logical.ok, char.ok.msg=char.ok, object.name=object.name) if(!is.null(object) && !is.na(object) && object != floor(object)) stop.msg(paste0(tweak.name(object.name, quote=FALSE), "=", object[1])) } object } check.level.arg <- function(level, zero.ok) { if(anyNA(level) || is.null(level)) # treat NA and NULL as 0 level <- 0 check.numeric.scalar(level) if(!((zero.ok && level == 0) || level >= .5 || level < 1)) { stop0("level=", level, " but it should be ", if(zero.ok) "zero or " else "", "between 0.5 and 1") } level } check.no.na.in.mat <- function(object) { if(anyNA(object)) { # quick initial check # detailed check for detailed error message for(icol in seq_along(ncol(object))) { check.name <- if(!is.null(colnames(object))) colnames(object)[icol] else sprint("%s[,%d]", short.deparse(substitute(object), "matrix"), icol) check(object, check.name, "NA", is.na, na.ok=FALSE) } } } # x can be a data.frame or matrix check.df.numeric.or.logical <- function(x, xname=trunc.deparse(substitute(x))) { stopifnot(!is.null(x), length(dim(x)) == 2) for(icol in seq_len(NCOL(x))) { if(!is.numeric(x[,icol]) && !is.logical(x[,icol])) stopf("the class of %s is \"%s\" (expected numeric or logical)", colname(x, icol, xname), class(x[,icol])) is.na <- is.na(x[,icol]) if(any(is.na)) stopf("%s[%g] is NA", colname(x, icol, xname), which(is.na)[1]) is.infinite <- !is.finite(x[,icol]) if(any(is.infinite)) stopf("%s[%g] is Inf", colname(x, icol, xname), which(is.infinite)[1]) } } check.numeric.scalar <- function(object, min=NA, max=NA, null.ok=FALSE, na.ok=FALSE, logical.ok=FALSE, char.ok.msg=FALSE, # only affects error msg object.name=short.deparse(substitute(object))) { s.logical <- if(logical.ok) ", or TRUE or FALSE" else "" if(na.ok) logical.ok <- TRUE # needed because NA is a logical any.na <- !is.null(object) && # following needed because anyNA gives error on some objects (is.numeric(object) || is.logical(object) || is.list(object) || is.character(object)) && anyNA(object) if(is.null(object)) { if(!null.ok) stop0(tweak.name(object.name), " is NULL") } else if(any.na && !na.ok) stop0(tweak.name(object.name), " is NA") else if(!is.numeric(object) && !(is.logical(object) && logical.ok)) { s.na <- if(na.ok) ", or NA" else "" s.null <- if(null.ok) ", or NULL" else "" s.char <- if(char.ok.msg) ", or a string" else "" stopf("%s must be numeric%s%s%s%s (whereas its current class is %s)", tweak.name(object.name), s.null, s.na, s.char, s.logical, quotify(class(object)[1])) } else if(length(object) != 1) stopf("the length of %s must be 1 (whereas its current length is %d)", tweak.name(object.name), length(object)) if(!is.null(object) && !any.na) { if(!is.na(min) && !is.na(max) && (object < min || object > max)) { stop0(tweak.name(object.name, quote=FALSE), "=", object, " but it should be between ", min, " and ", max) } if(!is.na(min) && object < min) { stop0(tweak.name(object.name, quote=FALSE), "=", object, " but it should be at least ", min) } if(!is.na(max) && object > max) { stop0(tweak.name(object.name, quote=FALSE), "=", object, " but it should not be greater than ", max) } } object } # We allow 20% of x to be nonpositive, useful if the response is essentially # positive, but the predicted response has a few nonpositive values at the extremes. # Needed for example if we will later take log(x) or sqrt(x). check.that.most.are.positive <- function(x, xname, user.arg, non.positive.msg, frac.allowed=.2) { check.numeric.scalar(frac.allowed) stopifnot(frac.allowed >= 0, frac.allowed <= 1) nonpos <- x <= 0 if(sum(nonpos, na.rm=TRUE) > frac.allowed * length(x)) { # more than frac.allowed nonpos? ifirst <- which(nonpos)[1] stop0(sprint( "%s is not allowed because too many %ss are %s\n", user.arg, unquote(xname), non.positive.msg), sprint( " %.2g%% are %s (%g%% is allowed)\n", 100 * sum(nonpos) / length(x), non.positive.msg, 100 * frac.allowed), sprint(" e.g. %s[%d] is %g", unquote(xname), ifirst, x[ifirst])) } } check.vec <- function(object, object.name, expected.len=NA, logical.ok=TRUE, na.ok=FALSE) { if(!(NROW(object) == 1 || NCOL(object) == 1)) stop0(tweak.name(object.name), " is not a vector\n ", "It has dimensions ", NROW(object), " by ", NCOL(object)) if(!((logical.ok && is.logical(object)) || is.numeric(object))) stop0(tweak.name(object.name), " is not numeric") if(!is.na(expected.len) && length(object) != expected.len) stop0(tweak.name(object.name), " has the wrong length ", length(object), ", expected ", expected.len) if(na.ok) object[is.na(object)] <- 1 # prevent check is.finite from complaining else check(object, object.name, "NA", is.na) check(object, object.name, "non-finite value", function(object) {!is.finite(object)}) } cleantry <- function(err) # clean up a try.err (remove "Error: " etc.) { stopifnot(is.try.err(err)) attributes(err) <- NULL err <- gsub("^[^:]*: *", "", err) # remove "Error: " (actually everything up to the first colon) err <- gsub("\n", " ", err, fixed=TRUE) # remove newlines err <- gsub(" +", " ", err) # multiple spaces to single spaces gsub(" $", "", err) # remove trailing space } # returns the column name, if that is not possible then something like x[,1] colname <- function(object, i, object.name=trunc.deparse(substitute(object))) { check.numeric.scalar(i) check.index(i, object.name, object, is.col.index=TRUE, allow.negatives=FALSE) colnames <- safe.colnames(object) if(!is.null(colnames)) colnames[i] else if(NCOL(object) > 1) sprint("%s[,%g]", object.name, i) else sprint(object.name) } # if trace>0 or the func fails, then print the call to func do.call.trace <- function(func, args, fname=short.deparse(deparse(func), "FUNC"), trace=0) { stopifnot(is.logical(trace) || is.numeric(trace), length(trace) == 1) # TODO commented out the following because it is too slow for big data # check.do.call.args(func, args, fname) trace <- as.numeric(trace) if(trace > 0) printf.wrap("%s(%s)\n", fname, list.as.char(args)) try <- try(do.call(what=func, args=args), silent=TRUE) if(is.try.err(try)) { if(trace == 0) # didn't print call above? then print it now printf.wrap("\n%s(%s)\n\n", fname, list.as.char(args)) else if(trace >= 2) # TODO is this best? printf("\n") # Re-call func so user can do a traceback within the function. Note that # if do.call.trace was called with try, this will be caught by that try. # TODO is there a better way to achieve this, perhaps using tryCatch # this could be confusing if func has side effects (unlikely) do.call(what=func, args=args) # should never get here stop0("second do.call(", fname, ", ...) did not give the expected error: ", try[1]) } invisible(try) # TODO is invisible necessary? } # identical to base::eval() but has trace and expr.name arguments eval.trace <- function( expr, envir = parent.frame(), enclos = if(is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv(), trace = 0, expr.name = NULL) { stopifnot(is.environment(envir)) stopifnot(is.environment(enclos)) if(trace >= 2) printf("eval(%s, %s)\n", if(is.null(expr.name)) trunc.deparse(substitute(expr)) else expr.name, environment.as.char(envir)) eval(expr, envir, enclos) } exp10 <- function(x) # e.g. exp10(-3) = 1e-3 { exp(x * log(10)) } # This function is used for checking both xlim and ylim. # This checks that lim is is a 2 element numeric vector. # Also, if xlim[1] == xlim[2], then plot() issues a confusing message. # We don't want that, so use this function to make sure xlim[2] # is different to xlim[1]. fix.lim <- function(lim) { if(!is.null(lim) && !isDate(lim)) { stopifnot(is.numeric(lim), length(lim) == 2) # constants below are arbitrary small <- max(1e-6, .001 * abs(lim[1]), .001 * abs(lim[2])) if(abs(lim[2] - lim[1]) < small) # illegal lim? lim <- c(lim[1] - small, lim[2] + small) } lim } # Ensure all columns of x have column names. Won't overwrite existing # column names (TODO except possibly if make.unique kicks in). gen.colnames <- function(x, prefix="x", alt.prefix=prefix, trace=0, xname=NULL) { if(NCOL(x) == 0) return(NULL) # If prefix is long and has characters like ( or [ then use the # alternate prefix. This is sometimes necessary when prefix is # generated using deparse and the arg is something like # "cbind(trees$Volume,trees$Volume+100)" if(any(nchar(prefix) > 30) && grepany("[([,]", prefix)) { trace2(trace, "using alt.prefix \"%s\" instead of prefix \"%s\"\n", alt.prefix, prefix) prefix <- alt.prefix } stopifnot(length(prefix) <= NCOL(x)) prefix <- substr(prefix, 1, 60) new.colnames <- if(NCOL(x) == length(prefix)) prefix else if(grepany("\\[", prefix)) new.colnames <- paste0(prefix, "[", seq_len(NCOL(x)), "]") else new.colnames <- paste0(prefix, seq_len(NCOL(x))) colnames <- org.colnames <- colnames(x) if(is.null(colnames)) colnames <- new.colnames else { missing <- !nzchar(colnames) if(any(missing)) colnames[missing] <- new.colnames[missing] } colnames <- make.unique(strip.space(colnames)) if(trace >= 2 && !identical(org.colnames, colnames)) trace2(trace, "%s colname%s %s now %s\n", if(is.null(xname)) trunc.deparse(substitute(x)) else xname, if(length(colnames) > 1) "s were" else " was", if(is.null(org.colnames)) "NULL" else paste.trunc(quotify(org.colnames)), paste.trunc(quotify(colnames))) colnames } get.mean.rsq <- function(rss, tss, wp) { if(is.null(wp)) wp <- repl(1, length(rss)) stopifnot(length(rss) == length(tss), length(wp) == length(tss)) total.rsq <- 0 for(iresp in seq_along(rss)) total.rsq <- total.rsq + wp[iresp] * get.rsq(rss[iresp], tss[iresp]) sum(total.rsq) / sum(wp) } # Get the environment for evaluating the model data: # 1. Return the environment in which the model function # was originally called. # 2. Else if the model already has an attribute .Environment, use that. # 3. Else return the environment in which the caller of this function # was called (e.g. return the environment of plotmo's caller). get.model.env <- function(object, object.name="object", trace=0) { # check args, because this func is called very early in plotmo (and friends) stopifnot.string(object.name) check.numeric.scalar(trace, logical.ok=TRUE) if(is.null(object)) stopf("%s is NULL", object.name) if(!is.list(object)) stopf("%s is not an S3 model", object.name) if(class(object)[1] == "list") stopf("%s is a plain list, not an S3 model", object.name) if(trace >= 2) { callers.name <- callers.name() my.call <- call.as.char(n=2) printf.wrap("%s trace %g: %s\n", callers.name, trace, my.call) call <- getCall(object) if(is.null(call)) printf("object class is \"%s\" with no call\n", class(object)[1]) else printf.wrap("object call is %s\n", strip.deparse(call), maxlen=80) printf("--get.model.env for %s object\n", class(object)[1]) } # following will fail for non-formula models because they have no terms field terms <- try(terms(object), silent=trace < 3) if(!is.try.err(terms) && !is.null(terms)) { model.env <- attr(terms, ".Environment") if(is.null(model.env)) { if(inherits(object, "glmnet.formula") || # glmnetUtils package inherits(object, "cv.glmnet.formula")) if(inherits(object, "glmnet.formula")) stop0( "for this plot, glmnet.formula must be called with use.model.frame=TRUE") if(inherits(object, "cv.glmnet.formula")) stop0( "for this plot, cv.glmnet.formula must be called with use.model.frame=TRUE") stop0("attr(terms, \".Environment\") is NULL") } if(!is.environment(model.env)) stop0("attr(terms, \".Environment\") is not an environment") else { trace2(trace, "using the environment saved with the %s model: %s\n", class(object)[1], environment.as.char(model.env)) return(model.env) } } model.env <- attr(object, ".Environment") if(is.environment(model.env)) { trace2(trace, "using attr(object,\".Environment\") saved with %s model: %s\n", class(object)[1], environment.as.char(model.env)) return(model.env) } if(!is.null(model.env)) stop0("attr(object, \".Environment\") is not an environment") model.env <- parent.frame(n=2) # caller of the function that called model.env trace2(trace, "assuming the environment of the %s model is that of %s's caller: %s\n", class(object)[1], callers.name, environment.as.char(model.env)) return(model.env) } get.rsq <- function(rss, tss) { rsq <- 1 - rss / tss # following makes testing easier across machines in presence of numerical error rsq[rsq > -1e-5 & rsq < 1e-5] <- 0 rsq } get.weighted.rsq <- function(y, yhat, w=NULL) # NAs will be dropped before calc { stopifnot(length(y) > 0, length(y) == length(yhat)) if(is.null(w)) { is.na <- is.na(y) | is.na(yhat) y <- y[!is.na] yhat <- yhat[!is.na] if(length(y) == 0) stop0("length(y) == 0 after deleting NAs in y or yhat") rss <- sos(y - yhat) tss <- sos(y - mean(y)) } else { stopifnot(length(w) == length(yhat)) is.na <- is.na(y) | is.na(yhat) | is.na(w) y <- y[!is.na] yhat <- yhat[!is.na] w <- w[!is.na] if(length(y) == 0) stop0("length(y) == 0 after deleting NAs in y or yhat or w") rss <- sos(y - yhat, w) tss <- sos(y - weighted.mean(y, w), w) } get.rsq(rss, tss) } # TRUE if pattern is in any of the strings in x grepany <- function(pattern, x, ignore.case=FALSE, ...) { any(grepl(pattern, x, ignore.case=ignore.case, ...)) } # scalar form of ifelse, with short name :-) # only evaluates the "no" argument if necessary ife <- function(ife.test, ife.yes, ife.no) { ife.test <- check.boolean(ife.test) stopifnot(!missing(ife.yes)) stopifnot(!missing(ife.no)) if(ife.test) ife.yes else ife.no } # returns an index, choices is a vector of strings imatch.choices <- function(arg, choices, argname=short.deparse(substitute(arg), "function"), err.msg.has.index=FALSE, # TRUE if integer "arg" is legal elsewhere err.msg="", # error message, "" for automatic err.msg.ext="") # extension to error message { err.msg.ext <- paste0( if(err.msg.has.index) " an integer index or" else "", if(nchar(err.msg.ext)) paste0(" ", err.msg.ext, " or") else "") if(nchar(err.msg) == 0) err.msg <- sprint("Choose%s one of: %s", err.msg.ext, quotify(choices)) if(!is.character(arg) || length(arg) != 1 || !nzchar(arg)) stopf("illegal %s argument\n%s", quotify(argname, "'"), err.msg) if(argname %in% c("NULL", "NA")) argname <- "argument" imatch <- pmatch(arg, choices) if(anyNA(imatch)) { imatch <- NULL for(i in seq_along(choices)) if(pmatch(arg, choices[i], nomatch=0)) imatch <- c(i, imatch) if(length(imatch) == 0) { if(length(choices) == 1) stopf("%s=\"%s\" is not allowed\n Only%s %s is allowed", argname, paste(arg), err.msg.ext, quotify(choices)) else stopf("%s=\"%s\" is not allowed\n%s", argname, paste(arg), err.msg) } if(length(imatch) > 1) stopf("%s=\"%s\" is ambiguous\n%s", argname, paste(arg), err.msg) } imatch } isDate <- function(x) { inherits(x, "Date") } # TRUE if all values in object are integers, ignoring NAs # assumes object is numeric or logical (check this before call this function) is.integral <- function(object) { object <- object[!is.na(object)] length(object) > 0 && is.null(dim(object)) && # prevent error in floor for e.g. survival objects all(floor(object) == object) } # is.specified's main purpose is to see if a plot component should be # drawn, i.e., to see if the component "has a color" is.specified <- function(object) { try <- try(!is.null(object) && !anyNA(object) && !is.zero(object) && # following needed for e.g. col=c("red", 0) because 0 is converted to string !identical(object, "0") && !identical(object, "0L") && !identical(object, "NA"), silent=FALSE) if(is.try.err(try)) { # this occurs if object is say a closure and anyNA fails # anyNA was introduced in R 3.1.0 printf("\n") # separate from any message printed by try() above stop0(deparse(substitute(object)), ": illegal value") } try } is.try.err <- function(object) { class(object)[1] == "try-error" } is.zero <- function(object) # needed because identical(object, 0) fails if object is 0L { identical(object, 0) || identical(object, 0L) } # Lighten color by amount 0 ... 1 where 1 is white. # If amount is negative, then darken the color, -1 is black. lighten <- function(col, lighten.amount, alpha=1) { # stopifnot.scalar(lighten.amount) # stopifnot(lighten.amount >= -1 && lighten.amount <= 1) rgb <- col2rgb(col) / 255 # empirically, sqrt makes visual effect of lighten.amount more linear lighten.amount2 <- sqrt(abs(lighten.amount)) rgb <- if(lighten.amount > 0) rgb + lighten.amount2 * (c(1,1,1) - rgb) # move each r,g,b towards 1 else # darken rgb - lighten.amount2 * rgb # move each r,g,b towards 0 rgb[rgb < 0] <- 0 # clamp rgb[rgb > 1] <- 1 if(alpha == 1) rgb(rgb[1,], rgb[2,], rgb[3,]) else rgb(rgb[1,], rgb[2,], rgb[3,], alpha) } # returns the expanded arg (error msg if arg is not an allowed choice in calling func) match.arg1 <- function(arg, argname=deparse(substitute(arg))) { formal.args <- formals(sys.function(sys.parent())) formal.argnames <- eval(formal.args[[argname]]) formal.argnames[imatch.choices(arg[1], formal.argnames, argname)] } # returns a string, choices is a vector of strings # error msg if arg is not an allowed choice match.choices <- function(arg, choices, argname=deparse(substitute(arg)), err.msg="", # error message ("" for automatic) err.msg.ext="") # extension to error message { choices[imatch.choices(arg, choices, argname, err.msg=err.msg, err.msg.ext=err.msg.ext)] } # This uses the object's .Environment attribute, which was # pre-assigned to the object via get.model.env # If this gives an error saying that class(model.env) is "NULL" # then that pre-assignment wasn't done. model.env <- function(object) { model.env <- attr(object, ".Environment") if(!is.environment(model.env)) stopf("class(model.env) is \"%s\"", class(model.env)[1]) model.env } # Like as.data.frame() but retains the original colnames, if any, and can # handle matrices from the Matrix etc. packages, if as.matrix() works for # them. Also it has a stringsAsFactors argument which works even if x is # already a data.frame. my.data.frame <- function(x, trace, stringsAsFactors=TRUE) { if(is.data.frame(x)) { if(stringsAsFactors) { # Convert any character columns to factors. Note as.data.frame # won't do this for us when x is already a data.frame. # We don't have a levels argument to pass to factor() # but I believe that this will not be a problem in the # context in which we use my.data.frame (plotmo_x). for(i in seq_len(length(x))) if(is.character(x[[i]])) x[[i]] <- factor(x[[i]]) } return(x) } df <- try(as.data.frame(x, stringsAsFactors=stringsAsFactors), silent=TRUE) if(is.try.err(df)) { # come here for sparse matrices from the Matrix package df <- try(as.matrix(x)) if(is.try.err(df)) stopf("Cannot convert %s object to a data.frame or matrix", quotify(class(x)[1])) df <- as.data.frame(df, stringsAsFactors=stringsAsFactors) trace2(trace, "converted %s object to data.frame\n", class(x)[1]) } colnames(df) <- safe.colnames(x) # restore original column names df } # default min.nrow=3 to use fixed point only if more than intercept and one other term my.fixed.point <- function(x, digits, min.nrow=3) { if(is.null(dim(x))) x <- as.matrix(x) if(NROW(x) >= min.nrow) x <- apply(x, 2, zapsmall, digits+1) x } # If s is a string vector s, return the number of lines in # the element that has the most lines # Examples: nlines(c(" ", " \n ") is 2 # nlines(c(" ", " \n") is 2 # nlines(" ") is 1 # nlines("") is 0 (special case) nlines <- function(s) { if(!nzchar(s[1])) # special case, caption="" is not printed 0 else if(anyNA(s)) 0 else length(strsplit(s, "\n")[[1]]) } paste.c <- function(object, maxlen=16) # return "x1" or "c(x1, x2)" { if(length(object) == 1) paste.trunc(object) else paste0("c(", paste.trunc(object, collapse=",", maxlen=maxlen), ")") } paste.collapse <- function(...) { paste(..., collapse=" ") } # collapse, and truncate if strings in ... are too long paste.trunc <- function(..., sep=" ", collapse=" ", maxlen=60) { s <- paste(..., sep=sep, collapse=collapse) if(nchar(s) > maxlen) { stopifnot(maxlen > 3) s <- paste0(substr(s, 1, maxlen-3), if(substr(s, maxlen-3, maxlen-3) == ".") ".." # avoid 4 dots else "...") } s } pastef <- function(s, fmt, ...) # paste the printf style args to s { paste0(s, sprint(fmt, ...)) } print_first_few_elements_of_vector <- function(x, trace, name=NULL) { try(cat(" min", min(x), "max", max(x)), silent=TRUE) spaces <- " " if(!is.null(name)) spaces <- sprint("%*s", nchar(name), " ") # nchar spaces cat0("\n", spaces, " value") len <- if(trace >= 4) length(x) else min(if(is.logical(x)) 20 else 10, length(x)) if(is.logical(x)) for(i in 1:len) cat0(if(x[i]) " T" else " F") else for(i in 1:len) cat0(" ", x[i]) if(length(x) > len) cat(" ...") cat("\n") if(trace >= 4) { cat("\n") print(summary(x)) } } # A safe version of sprintf. # Like sprintf except that %s on NULL prints "NULL" rather than # preventing the entire string from being printed # # e.g. sprintf("abc %s def", NULL) returns an empty string -- a silent failure! # but sprint("abc %s def", NULL) returns "abc NULL def" # # e.g. sprintf("abc %d def", NULL) returns an empty string! # but sprint("abc %d def", NULL) causes an error msg (not a silent failure) sprint <- function(fmt, ...) { dots <- list(...) dots <- lapply(dots, function(e) if(is.null(e)) "NULL" else e) do.call(sprintf, c(fmt, dots)) } printf <- function(fmt, ...) # like c printf { cat(sprint(fmt, ...), sep="") } # like printf but wrap at terminal width # exdent=NULL for automatic determination of xdent (line up to func opening paren) # TODO maxlen seems to be ignored, strwrap truncates before that? printf.wrap <- function(fmt, ..., exdent=NULL, maxlen=2000) { s <- paste.trunc(paste.collapse(sprint(fmt, ...)), maxlen=maxlen) if(is.null(exdent)) { # align to opening paren of func call e.g. "graphics::par(xxx)" or "foo$method(" # TODO this doesn't account for leading newlines if any exdent <- 4 igrep <- gregexpr("[ ._$:[:alnum:]]+\\(", s)[[1]] if(igrep[1] == 1) { len <- attr(igrep, "match.length")[1] exdent <- min(25, len) } } # strwrap doesn't preserve newlines in the input string, so do it manually :( for(i in seq_len(nchar(s))) # print leading newlines if(substr(s, i, i) == "\n") cat0("\n") else break cat(paste0(strwrap(s, width=getOption("width"), exdent=exdent), collapse="\n")) if(nchar(s) > i) for(j in nchar(s):i) # print trailing newlines if(substr(s, j, j) == "\n") cat0("\n") else break } pt.cex <- function(ncases, npoints=ncases) { n <- if(npoints > 0) min(npoints, ncases) else ncases if (n >= 20000) .2 else if(n >= 5000) .3 else if(n >= 3000) .4 else if(n >= 1000) .6 else if(n >= 300) .8 else if(n >= 30) 1 else 1.2 } # like short.deparse but quotify the deparsed obj (unless the alternative is used) quote.deparse <- function(object, alternative="object") { s <- strip.deparse(object) if(nchar(s) > 60) alternative else quotify(s, quote="'") } quote.with.c <- function(names) # return "x" or c("x1", "x2") { if(length(names) == 1) sprint("\"%s\"", names) else sprint("c(%s)", paste0("\"", paste(names, collapse="\", \""), "\"")) } quotify <- function(s, quote="\"") # add quotes and collapse to a single string { # called quotify because quote is taken if(is.null(s)) "NULL" else if(length(s) == 0) paste0(quote, quote) else if(substr(s[1], 1, 1) == "'" || substr(s[1], 1, 1) == "\"") paste.collapse(s) # already has quotes else paste0(quote, paste(s, collapse=paste0(quote, " ", quote)), quote) } # like quotify, but use the alternative name if s is too long quotify.short <- function(s, alternative="object", quote="\"") { stopifnot(is.character(s)) s <- paste0(s, collapse="") if(nchar(s) > 60) # 60 is arb but seems ok for plot titles etc alternative else quotify(s, quote) } quotify.trunc <- function(s, quote="\"", maxlen=60) { stopifnot(is.character(s)) s <- quotify(s, quote) if(nchar(s) > maxlen) { stopifnot(maxlen > 3) paste0(substr(s, 1, maxlen-3), "...") } else s } range1 <- function(object, ...) { stopifnot(length(dim(object)) <= 2) if(!is.null(dim(object))) object <- object[,1] if(is.factor(object)) c(1, nlevels(object)) else range(object, finite=TRUE, ...) } recycle <- function(object, ref.object) { repl(object, length.out=length(ref.object)) } repl <- function(object, length.out) { # following "if" added for R-2.15.3 otherwise # get warning: 'x' is NULL so the result will be NULL if(is.null(object)) return(NULL) check.numeric.scalar(length.out) stopifnot(floor(length.out) == length.out) stopifnot(length.out > 0) rep(object, length.out=length.out) } # the standard colnames() can crash for certain objects # TODO figure out when and why safe.colnames <- function(object) { colnames <- try(colnames(object), silent=TRUE) if(is.try.err(colnames)) NULL else colnames } # if deparse(object) is too long, return the alternative short.deparse <- function(object, alternative="object") { s <- strip.deparse(object) if(nchar(s) > 60) alternative else s } # Remove duplicates in x, then sort (smallest first). # Also works for Dates. sort.unique <- function(x) { sort(unique(x), na.last=NA) # na.last=NA drops NAs } sos <- function(x, weights=NULL) # sum of squares { if(is.null(weights)) sum(as.vector(x^2)) else { stopifnot(length(weights) == length(x)) sum(weights * as.vector(x^2)) } } stop0 <- function(...) { stop(..., call.=FALSE) } stopf <- function(fmt, ...) # args like printf { stop(sprint(fmt, ...), call.=FALSE) } # stop if s is not a one element character vector stopifnot.string <- function(s, name=short.deparse(substitute(s)), null.ok=FALSE, allow.empty=FALSE) { if(name %in% c("NULL", "NA")) name <- "argument" if(is.null(s)) { if(null.ok) return() else stop0(quotify(name, "'"), " is NULL (it should be a string)") } if(!is.character(s)) stop0(quotify(name, "'"), " is not a character variable (class(", name, ") is \"", class(s), "\")") if(length(s) == 0) stop0(quotify(name, "'"), " is empty (it has no elements)") if(length(s) != 1) stop0(quotify(name, "'"), " has more than one element\n ", name, " = c(", paste.trunc("\"", s, "\"", sep=""), ")") if(!allow.empty && !nzchar(s)) stop0(quotify(name, "'"), " is an empty string") } strip.deparse <- function(object) # deparse, collapse, remove most white space { s <- strip.space.collapse(deparse(object)) gsub(",", ", ", s) # put back space after commas } strip.space <- function(s) { gsub("[ \t\n]", "", s) } strip.space.collapse <- function(s) # returns a single string { gsub("[ \t\n]", "", paste(s, collapse="")) # paste converts vec to single } # like text, but with a white background # TODO sign of adj is backwards? text.on.white <- function(x, y, label, cex=1, adj=.5, font=1, xmar=.3, srt=0, white="white", ...) { stopifnot(length(label) == 1) if(length(adj) == 1) adj <- c(adj, .5) width <- strwidth(label, cex=cex, font=font) char.width <- strwidth("X", cex=cex, font=font) height <- strheight(label, cex=cex, font=font) char.height <- strheight("X", cex=cex, font=font) if(srt == 0) { if(is.specified(label)) rect(x - adj[1] * width - xmar * char.width, y - adj[2] * height - .3 * char.height, # .3 for extra space at bottom x + (1-adj[1]) * width + xmar * char.width, y + (1-adj[2]) * height + .1 * char.height, col=white, border=NA) text(x=x, y=y, labels=label, cex=cex, adj=adj, font=font, ...) } else if(srt == 90 || srt == -90) { # width and height are in usr coords, adjust these for flip of coords usr <- par("usr") # xmin, xmax, ymin, ymax xrange <- abs(usr[2] - usr[1]) yrange <- abs(usr[4] - usr[3]) height <- xrange / yrange * height width <- yrange / xrange * width char.height <- xrange / yrange * char.height char.width <- yrange / xrange * char.width if(is.specified(label)) rect(x + (1-adj[1]) * height, # left y + (1-adj[2]) * width + xmar * char.width, # bottom x - adj[1] * height, # right y - adj[2] * width - xmar * char.width, # top col=white, border=NA) text(x=x, y=y, labels=label, cex=cex, adj=adj, font=font, srt=srt, ...) } else stop0("srt=", srt, " is not allowed (only 0, 90, and -90 are supported)") } to.logical <- function(object, len) # object can be a boolean or numeric vector { xlogical <- repl(FALSE, len) xlogical[object] <- TRUE xlogical } trace0 <- function(trace, fmt, ...) { stopifnot(!(is.numeric(trace) && is.logical(trace))) if(trace >= 0) cat(sprint(fmt, ...), sep="") } trace1 <- function(trace, fmt, ...) { stopifnot(!(is.numeric(trace) && is.logical(trace))) if(trace >= 1) cat(sprint(fmt, ...), sep="") } trace2 <- function(trace, fmt, ...) { stopifnot(is.numeric(trace)) if(trace >= 2) cat(sprint(fmt, ...), sep="") } # Truncate deparse(object) if it is too long. # Necessary because deparse(substitute(x)) might return something very # long, like c(1000, 1001, 1002, 1003, 1004, 1005, 1006, 1008, 1009, etc.) # Return a one element character vector. trunc.deparse <- function(object, maxlen=60) { s <- strip.deparse(object) if(nchar(s) > maxlen) { stopifnot(maxlen > 3) paste0(substr(s, 1, maxlen-3), "...") } else s } # Return the number of lines in s (where lines are separated by \n). try.eval <- function( expr, envir = parent.frame(), trace = 0, expr.name = NULL, silent = trace < 2) { if(trace && is.null(expr.name)) expr.name <- trunc.deparse(substitute(expr)) try(eval.trace(expr, envir, trace=trace, expr.name=expr.name), silent=silent) } unquote <- function(s) # remove leading and trailing quotes, if any { if(is.character(s)) { s <- gsub("^\"|^'", "", s) # leading quotes s <- gsub("\"$|'$", "", s) # trailing quotes } s } # warn.if.not.all.finite helps preempt confusing message from code later. # Return TRUE if warning issued. warn.if.not.all.finite <- function(object, text="unknown") { is.factors <- sapply(object, is.factor) if(any(is.factors)) { if(NCOL(object) == 1 || all(is.factors)) # TODO suspect return(FALSE) object <- object[, !is.factors] # remove factor columns before is.finite check } if(any(sapply(object, is.na))) { warning0("NA in ", text) return(TRUE) } if(!all(sapply(object, is.finite))) { warning0("non finite value in ", text) return(TRUE) } FALSE } warnf <- function(fmt, ...) # args like printf { warning(sprint(fmt, ...), call.=FALSE) } warning0 <- function(...) { warning(..., call.=FALSE) } # Binomial pairs response: fraction true for each row. # # This function is used by both earth and plotmo. # If you change it here, change it there too. # # The first column of y is considered to be "true", the second "false". # # Example y: # survived died # 1 1 # 0 0 # both values zero # 3 4 # # becomes: # survived # .5 # 1 / (1 + 1) # 0 # special case (both survived and died equal to 0) # .43 # 3 / (3 + 4) bpairs.yfrac <- function(y, trace) { stopifnot(NCOL(y) == 2) both.zero <- (y[,1] == 0) & (y[,2] == 0) y[both.zero, 2] <- 1 # so zero rows will be translated to 0 in next line yfrac <- y[, 1, drop=FALSE] / (y[,1] + y[,2]) # fraction true trace.bpairs.yfrac(yfrac, trace) yfrac } trace.bpairs.yfrac <- function(yfrac, trace) { # based on code in print.earth.fit.args if(trace >= 4) cat("\n") if(trace >= 1 && trace < 7) { # don't print matrices when doing very detailed earth.c tracing tracex <- if(trace >= 5) 4 else 2 # adjust trace for print_summary details <- if(trace >= 4) 2 else if(trace >= 1) -1 else 0 print_summary(yfrac, "yfrac", tracex, details=details) if(details > 1) printf("\n") } } earth/R/residuals.earth.R0000644000176200001440000000571213412612166015005 0ustar liggesusers# residuals.earth.R: residuals.earth <- function(object=stop("no 'object' argument"), type=NULL, warn=TRUE, ...) { warn.if.dots(...) warn <- check.boolean(warn) if(warn && is.null(type) && !is.null(object$glm.list)) warning0("residuals.earth: returning earth (not glm) residuals") if(is.null(type)) type <- "earth" types <- c("earth", "deviance", "response", "standardize", "delever", "pearson", "working", "partial", "glm.response", "glm.pearson", "glm.working", "glm.partial") if(is.null(object$residuals)) # I think this can only happen for cv models stop0("earth object has no residuals field.\n", " Use keepxy=TRUE in the call to earth.") resids <- switch(match.choices(type, types, "type"), earth = object$residuals, deviance = if(is.null(object$glm.list)) object$residuals else glm.resids(object$glm.list, "deviance"), response = if(is.null(object$glm.list)) object$residuals else glm.resids(object$glm.list, "response"), standardize = plotmo::plotmo_standardizescale(object) * object$residuals, delever = object$residuals / sqrt(1 - hatvalues(object)), pearson = glm.resids(object$glm.list, "pearson"), working = glm.resids(object$glm.list, "working"), partial = glm.resids(object$glm.list, "partial"), glm.response = glm.resids(object$glm.list, "response"), glm.pearson = glm.resids(object$glm.list, "pearson"), glm.working = glm.resids(object$glm.list, "working"), glm.partial = glm.resids(object$glm.list, "partial")) if(!is.matrix(resids)) resids <- matrix(resids, ncol = 1) if(type != "partial" && type != "glm.partial") colnames(resids) <- colnames(object$residuals) rownames(resids) <- case.names(object) resids } glm.resids <- function(glm.list, type) { if(is.null(glm.list)) stop0("residuals.earth: type \"", type, "\" can be used ", "only on earth-glm models") colnames <- "" for(imodel in seq_along(glm.list)) { rval1 <- residuals(glm.list[[imodel]], type) # invokes residuals.glm if(imodel == 1) rval <- rval1 if(NROW(rval1) != NROW(rval)) # should never happen stop0("residuals.earth: glm.list[[", imodel, "]] does ", "not conform to glm.list[[", 1, "]] ", "(residuals have a different length)") if(imodel > 1) { colnames <- c(colnames) rval <- cbind(rval, rval1) } } rval } resid.earth <- function(object=stop("no 'object' argument"), type=NULL, warn=TRUE, ...) { residuals.earth(object, type, warn, ...) } earth/R/model.matrix.earth.R0000644000176200001440000004520613444255405015423 0ustar liggesusers# model.matrix.earth.R: functions for manipulating earth model matrices # # The main functions are: # # expand.arg(x, env, is.y.arg) expand factors in x and convert to double mat with col names # Called by earth.formula, earth.default, get.earth.x # # model.matrix(terms, data) standard R function to expand factors # Called by expand.arg earth.formula, get.earth.x, predict.earth(type="terms") # # model.matrix.earth(object, x, ...) x arg must not be expanded, returns bx # Called by predict.earth # # get.earth.x(object, data) returns x expanded for factors and all double # Called by model.matrix.earth # # get.bx(x, which.terms, dirs, cuts) x arg must be already expanded # Called by model.matrix.earth, pruning.pass # #----------------------------------------------------------------------------- # Called from earth.fit just before doing the pruning pass # Also called by model.matrix.earth (which returns bx) # The x arg must be already expanded get.bx <- function(x, which.terms, dirs, cuts) { stopifnot(all(dirs[1,] == 0)) # intercept term dirs must all be 0 check.which.terms(dirs, which.terms) stopifnot(NCOL(x) > 0) colnames <- rownames(dirs[which.terms,,drop=FALSE]) bx <- matrix(0, nrow=nrow(x), ncol=length(which.terms), dimnames=list(NULL, colnames)) ibx <- 1 for(iterm in which.terms) { temp1 <- 1 for(ipred in seq_len(ncol(x))) { dir <- dirs[iterm, ipred] if(dir == 2) # predictor enters linearly? temp1 <- temp1 * x[, ipred] else if(dir == -1 || dir == 1) { temp2 <- dir * (x[, ipred] - cuts[iterm, ipred]) temp1 <- temp1 * temp2 * (temp2 > 0) } else if(dir != 0) stop0("illegal direction ", dir, " in 'dirs'") } bx[, ibx] <- temp1 ibx <- ibx + 1 } bx } # returns x expanded for factors # data can be a dataframe, matrix, or vector get.earth.x <- function(object, data=NULL, env, trace=0, Callers.name) { trace <- get.update.arg(trace, "trace", object, env, trace1=NULL, Callers.name, print.trace=FALSE) if(is.null(trace)) trace <- 0 this.call <- match.call() if(is.null(object$terms)) # model was created with earth.default, no formula? x <- get.earth.x.default(object, data, env, trace, Callers.name) else # model was created with earth.formula x <- get.earth.x.formula(object, data, env, trace, Callers.name) if(NROW(x) == 0) stop0("empty model matrix") # Fix: April 2010, allow earth to play nicely with fda with factors in x if(ncol(x) > ncol(object$dirs)) # too many columns? x <- x[, colnames(x) %in% colnames(object$dirs), drop=FALSE] # select only the columns in dirs check.expanded.ncols(x, object, Callers.name) x } # object was created with earth.default, no formula get.earth.x.default <- function(object, data, env, trace, Callers.name) { x <- get.update.arg(data, "x", object, env, trace, Callers.name) x <- possibly.convert.vector.to.matrix(x, object$namesx, Callers.name) # following allows data to be a list e.g. newdata=etitanic[1,,drop=TRUE] x <- possibly.convert.list.to.data.frame(x) x <- fix.x.columns(x, object$namesx, trace, Callers.name) if(trace >= 1) { print_summary(x, sprint("%s: x", Callers.name), trace=2) trace2(trace, "\n") } expand.arg(x, env, trace, is.y.arg=FALSE) } # object was created with earth.formula get.earth.x.formula <- function(object, data, env, trace, Callers.name) { terms.without.response <- delete.Response(object$terms) data <- get.update.arg(data, "data", object, env, trace, Callers.name) data <- possibly.convert.vector.to.matrix(data, object$namesx, Callers.name) # following allows data to be a list e.g. newdata=etitanic[1,,drop=TRUE] data <- possibly.convert.list.to.data.frame(data) data <- fix.x.columns(data, object$namesx, trace, Callers.name) data <- as.data.frame(data) expected.nrows <- nrow(data) if(trace >= 1) { print_summary(data, sprint("%s: x", Callers.name), trace=2) trace2(trace, "\n") } if(!is.null(attr(terms.without.response, "offset"))) check.offset.var.is.in.data(terms.without.response, data) # March 2019: added xlev to match what lm does (and also linmod.R in the plotmo tests) # necessary for: mod <- earth(Sepal.Length~Species, data=iris); # predict(mod, newdata=data.frame(Species="setosa")) # used to fail mf <- model.frame(terms.without.response, data=data, na.action=na.pass, xlev=object$xlevels) if(trace >= 1) { print_summary(mf, sprint("%s: after call to model.frame: mf", Callers.name), trace=2) trace2(trace, "\n") } classes <- attr(terms.without.response, "dataClasses") if(!is.null(classes)) { # Use "try" for leniency, to allow numeric to be used for factors etc. # There is special treatment for the following message because it seems to be benign: # variable 'foo' was fitted with type "nmatrix.1" but type "numeric" was supplied try <- try(.checkMFClasses(classes, mf), silent=TRUE) if(is.try.err(try) && !grepl("\"nmatrix.1\" .* \"numeric\"", try[1])) { cat(try) cat("Continuing anyway, first few rows of modelframe are\n") print(head(mf)) } } x <- model.matrix(terms.without.response, mf) check.nrows(expected.nrows, nrow(x), nrow(object$fitted.values), Callers.name) intercept <- match("(Intercept)", colnames(x), nomatch=0) if(intercept) x <- x[, -intercept, drop=FALSE] # silently discard intercept x } # Like stats::delete.response but can handle multiple-response # Formula objects with a "Response" attr. # Can also handle conventional formula objects with a "response" attr. delete.Response <- function (termobj, issue.warning=TRUE) { a <- attributes(termobj) y <- a$response # response index if(is.null(y) || y[1] == 0) y <- a$Response # multiple resp termobj built with Formula if(is.null(y) || y[1] == 0) { if(issue.warning) { formula <- termobj attributes(formula) <- NULL warning0("formula has no response: ", quotify(paste(formula, collapse=" "))) } return(termobj) } # following copied from stats::delete.response, R version 3.5.3 (March 2019) a$response <- 0 a$variables <- a$variables[-(1+y)] a$predvars <- a$predvars[-(1+y)] if(length(a$factors)) a$factors <- a$factors[-y, , drop = FALSE] if(length(a$offset)) a$offset <- ifelse(a$offset > y, a$offset-1, a$offset) if(length(a$specials)) { for(i in seq_along(a$specials)) { b <- a$specials[[i]] a$specials[[i]] <- ifelse(b > y, b-1, b) } } if(length(y) == 1) # conventional formula object? termobj[[2]] <- NULL # termobj is list(~, response, rhs) else { # multiple response Formula object check.ymax <- function(len) { if(len < ymax) { attributes(termobj) <- NULL # for paste in error message stop0("Cannot delete response from ", quotify(paste(termobj, collapse=" ")), "\n because ", deparse(substitute(len)), " is ", len, ", expected length at least ", ymax) } } termobj <- strip_multiple_response_from_Formula(termobj) ymax <- max(y) # for error checking if(length(a$factors)) { check.ymax(NCOL(a$factors)) a$factors <- a$factors[, -y, drop = FALSE] } check.ymax(length(a$term.labels)) a$term.labels <- a$term.labels[-y] # TODO do we need the following? # check.ymax(length(a$order)) # a$term.order <- a$order[-y] a$Response <- 0 } attributes(termobj) <- a termobj } # Returns modified formula (the modified termobj) without attributes. # TODO Is there are simpler way of doing this? strip_multiple_response_from_Formula <- function(termobj) # termobj created by Formula { check.class <- function(element, classes) { if(!class(element)[1] %in% classes) stop0("Cannot delete response from ", quotify(paste(Formula, collapse=" ")), "\n because class(", deparse(substitute(element)), ") is ", quotify(class(element)), " which is not in ", quotify(classes)) } check.index <- function(element, i) { if(length(element) < i) { stop0("Cannot delete response from ", quotify(paste(Formula, collapse=" ")), "\n because length(", deparse(substitute(element)), ") is ", length(element), ", expected length at least ", i) } } Formula <- termobj # termobj is list(~, list( +, response, rhs)) # index: [1] [2] [2][1] [2][2] [2][3] attributes(Formula) <- NULL # converts class c("terms","formula") to "call" check.class(Formula, "call") check.index(Formula, 2) check.class(Formula[[2]], c("name", "call")) check.index(Formula[[2]], 3) check.class(Formula[[2]][[3]], c("name", "call")) Formula[[2]] <- Formula[[2]][[3]] # extract rhs into 2nd elem of Formula Formula } # Called only by model.matrix.earth check.expanded.ncols <- function(x, object, Callers.name) { if(NCOL(x) != NCOL(object$dirs)) stop0(Callers.name, ": the number ", NCOL(x), " of columns of x\n", "(after factor expansion) does not match the number ", NCOL(object$dirs), " of columns of the earth object", "\n expanded x: ", paste.collapse(colnames(x)), "\n object$dirs: ", paste.collapse(colnames(object$dirs)), "\nPossible remedy: check factors in the input data") } # Called by predict.earth and can also be called by users directly. # Return object$bx if all x, subset, which.terms equal NULL. model.matrix.earth <- function( # returns bx object = stop("no 'object' argument"), x = NULL, # x arg (not yet expanded) subset = NULL, which.terms = NULL, trace = 0, ..., # unused, for generic method comparibility Env = parent.frame(), Callers.name = "model.matrix.earth") # caller's name for trace messages { warn.if.dots(...) check.classname(object, substitute(object), "earth") trace <- as.numeric(check.numeric.scalar(trace, logical.ok=TRUE)) if(is.null(x) && is.null(subset) && is.null(which.terms)) { if(trace >= 1) cat0(Callers.name, ": returning object$bx\n") return(object$bx) } x <- get.earth.x(object, data=x, Env, trace, paste("get.earth.x from", Callers.name)) if(is.null(which.terms)) which.terms <- object$selected.terms if(!is.null(subset)) { # duplicates are allowed in subsets so user can specify a bootstrap sample check.index("subset", subset, x, allow.dups=TRUE, allow.zeros=TRUE) x <- x[subset, , drop=FALSE] } get.bx(x, which.terms, object$dirs, object$cuts) } # Called by update.earth and get.earth.x # # Which x should we use? The precedence is [1] the x parameter, if any, # in this call to update [2] the $x in the earth object (which exists # if keepxy=TRUE was used the original call to earth) [3] the x found # in the original call to earth. # Same applies for y, subset, weights, and wp. # The "arg" argument is from the current call to update or predict get.update.arg <- function(arg, argname, object, env, trace1, Callers.name="update.earth", print.trace=TRUE, reeval=TRUE) # TODO hack to re-evaluate { if(!print.trace) # print.trace arg prevents recursion issues with trace trace1 = FALSE if(is.null(arg)) { temp <- try(eval(object[[argname, exact=TRUE]], envir=env), silent=TRUE) if(!is.null(temp) && !is.try.err(temp)) { if(reeval) arg <- object[[argname, exact=TRUE]] else arg <- temp if(trace1 >= 1) cat0(Callers.name, ": using ", NROW(temp), " by ", NCOL(temp), " ", argname, " saved by keepxy in original call to earth\n") } else { temp <- try(eval(object$call[[argname, exact=TRUE]], envir=env), silent=TRUE) if(!is.null(temp) && !is.try.err(temp)) { if(reeval) arg <- object$call[[argname, exact=TRUE]] else arg <- temp if(trace1 >= 1) cat0(Callers.name, ": using ", NROW(temp), " by ", NCOL(temp), " ", argname, " argument from original call to earth\n") } } } arg } # If model.frame can't interpret the data passed to it it silently # returns the fitted values. This routine makes that not silent. # Note: model.frame is a standard R library function (it's in stats/R/models.R). check.nrows <- function(expected.nrows, actual.nrows, fitted.nrows, Callers.name) { if(actual.nrows != expected.nrows) { if(actual.nrows == fitted.nrows) stop0("model.frame.default could not interpret the data passed to ", Callers.name, "\n (actual.nrows=", actual.nrows, " expected.nrows=", expected.nrows, " fitted.nrows=", fitted.nrows, ")") else # can probably never get here warning0(Callers.name, " returned a number ", actual.nrows, " of rows that was different from the number ", expected.nrows, " of rows in the data") } } # If x is already a matrix or data.frame this does nothing. # Else if x is a vector, return a matrix with length(colnames) columns. possibly.convert.vector.to.matrix <- function(x, colnames, Callers.name) { if(is.null(ncol(x)) && !is.list(x)) { nrows <- length(x) / length(colnames) if(floor(nrows) == nrows) dim(x) <- c(nrow=nrows, ncol=length(colnames)) else stop0(Callers.name, ":\n", " could not convert vector x to matrix because ", "length(x) ", length(x), "\n", " is not a multiple of the number ", length(colnames), " of predictors ", "\n Expected predictors: ", paste.collapse(colnames)) } x } possibly.convert.list.to.data.frame <- function(x) { if(is.list(x) && !is.data.frame(x)) x <- as.data.frame(x) x } # Given an x matrix or data.frame, return an x with column names equal to # expected.colnames and with the columns in their correct order # So the user can hand us an x without column names, # or with named columns but in the wrong order, or an x containing # only a needed subset of all the columns, etc. # This code is a mess and doesn't handle all cases, just the common ones. fix.x.columns <- function(x, namesx, trace, Callers.name) { colnames <- colnames(x) ncolnames <- length(colnames) nexpected <- length(namesx) if(is.null(colnames)) { if(trace >= 1) cat0(Callers.name, ": x has no column names, ", "adding column names: ", paste.collapse(namesx), "\n") colnames <- namesx } else if(ncolnames < nexpected) { # CHANGED Oct 2008: allow user to specify less than the expected # nbr of columns -- which is ok if he specifies all predictors # actually used by the model. imatch <- pmatch(colnames, namesx, nomatch=0) if(any(imatch == 0)) { # can't repair the error because there are colnames in x that aren't # in expected.names (tends to happen with expanded factor names) stop0(Callers.name, ": x has ", ncolnames, " columns but expected ", length(namesx), "\n column names: ", paste.collapse(colnames), "\n expected column names: ", paste.collapse(namesx)) } # Create a new x, putting the existing cols into their correct positions. # Cols that aren't in the original x will end up as all NAs in the # the recreated x; that doesn't matter for predict.earth if they are # for predictors that are unused in the earth model. if(trace >= 1) cat0(Callers.name, ": x has missing columns, ", "creating a new x with all cols\n") imatch <- pmatch(namesx, colnames, nomatch=0) x.original <- x x <- matrix(data=NA_real_, nrow=nrow(x), ncol=nexpected) for(i in seq_len(nexpected)) if(imatch[i]) x[,i] <- x.original[,imatch[i]] colnames <- namesx } else if(ncolnames > nexpected) { NULL # TODO not sure what to do here (do nothing so old regression tests pass) } else { imatch <- pmatch(colnames, namesx, nomatch=0) if(all(imatch == 0)) { if(trace >= 1) cat0(Callers.name, ": unexpected x column names, renaming columns\n", " Old names: ", paste.collapse(colnames), "\n", " New names: ", paste.collapse(namesx), "\n") colnames <- namesx } else { # replace indices for non-found predictor names with their value # i.e. assume columns with unknown names are in their right position for(i in seq_along(imatch)) if(imatch[i] == 0) imatch[i] = i # if any columns are in the wrong order then fix their order # (imatch will be 1,2,3,... if columns are in the right order) if(!all(imatch == seq_along(imatch))) { s <- paste0(Callers.name, ": x columns are in the wrong order%s\n", " Old columns: ", paste.collapse(colnames), "\n", " New columns: ", paste.collapse(namesx), "\n") if(length(imatch) == ncol(x)) { trace1(trace, s, ", correcting the column order") x <- x[, imatch, drop=FALSE] colnames <- colnames[imatch] } else warnf(s, "") } } } colnames(x) <- colnames x } earth/R/format.earth.R0000644000176200001440000003226513375600641014310 0ustar liggesusers# format.earth.R # Return a vector s of strings, length of vector is nresponses. # But if there are embedded GLM model(s) then length of s is 2 * nresponses # and strings for the GLM model(s) start at s[nresponses]. # # For each model string, there is one term per line. Each term (except # the intercept) is made up of a coefficent which multiplies one or more # hockey stick funcs. # # For the default style="h" the result looks like this: # # 23 # + 5.7 * h(Girth-12.9) # - 2.9 * h(12.9-Girth) # + 0.72 * h(Height-76) # # For style="pmax" the result looks like this: # # 23.208244 # + 5.7459616 * pmax(0, Girth - 12.9) # - 2.8664516 * pmax(0, 12.9 - Girth) # + 0.71833643 * pmax(0, Height - 76) # # Style="max" is the same as "pmax" but prints "max" rather than "pmax". # # Style="C" looks like this: # 23.208244 # + 5.7459616 * max(0 x[0] - 12.9) # - 2.8664516 * max(0 12.9 - x[0]) # + 0.71833643 * max(0, x[1] - 76) # # For style="bf" the result looks like this: # # bf1: h(Girth-12.9) # bf2: h(12.9-Girth) # bf3: h(Height-76) # # 23 # + 5.7 * bf1 # - 2.9 * bf2 # + 0.72 * bf3 # # decomp argument: see reorder.earth() # # The first arg is actually an object but called x for consistency with generic # # TODO would be nice to add an option to print in term importance order format.earth <- function( x = stop("no 'x' argument"), # "earth" object style = "h", # see get.term.strings decomp = "anova", # see reorder.earth for legal decomp values digits = getOption("digits"), use.names = TRUE, colon.char = ":", # convert colons in expression to this char ...) # unused, for consistency with generic { check.classname(x, substitute(x), "earth") warn.if.dots(...) use.names <- check.boolean(use.names) nresp <- NCOL(x$coefficients) s <- vector(mode = "character", length=nresp) if(style[1] == "C") { if(digits < 5) digits <- 5 use.names <- -1 # tell variable.names.earth to use zero based indexing colon.char = "*" } for(iresp in seq_len(nresp)) s[iresp] <- format.one.response(iresp, x, digits, use.names, decomp, style=style, colon.char=colon.char, coefs=NULL) if(!is.null(x$glm.list)) # embedded GLM model(s)? for(iresp in seq_len(nresp)) s[nresp + iresp] <- format.one.response(iresp, x, digits, use.names, decomp, style=style, colon.char=colon.char, coefs=x$glm.list[[iresp]]$coefficients) s } format.one.response <- function( # called by format.earth iresp, # response index i.e. column in y matrix object, # "earth" object digits, use.names, decomp, # see reorder.earth for legal decomp values style, # see get.term.strings colon.char=":", # convert colons in output to this char coefs=NULL) # if not NULL use these instead of object$coefficients { new.order <- reorder.earth(object, decomp=decomp) if(is.null(coefs)) coefs <- object$coefficients[, iresp] coefs <- coefs[new.order] which.terms <- object$selected.terms[new.order] dirs <- object$dirs check.which.terms(dirs, which.terms) term.names <- get.term.strings(object, digits, use.names, style, new.order) # convert colons to colon.char term.names <- make.unique(gsub(":", colon.char, term.names), sep="_") coef.width <- get.coef.width(coefs[-1], digits) s <- if(style[1] == "C") "" else " " # result goes into this string s <- pastef(s, "%.*g\n", digits=digits, coefs[1]) iterm <- 2 while(iterm <= length(which.terms)) { coef <- coefs[iterm] if(coef < 0) s <- pastef(s, " - %s ", format(-coef, justify="left",width=coef.width,digits=digits,format="%g")) else s <- pastef(s, " + %s ", format(coef, justify="left", width=coef.width,digits=digits,format="%g")) s <- pastef(s, "* %s", term.names[iterm]) s <- pastef(s, "\n") iterm <- iterm + 1 } if(pmatch(style, "bf", nomatch=0)) # append table of basis functions? s <- paste0(s, "\n", get.table.of.basis.functions(object, new.order)) s } get.coef.width <- function(coefs, digits) # get print width for earth coefs { if(length(coefs) > 0) max(nchar(format(abs(coefs), digits=digits))) else 10 # arbitrary width if no coefs } # style argument: # "h" gives "h(survived-0) * h(16-age)" # "pmax" gives "pmax(0, survived - 0) * pmax(0, 16 - age)" # "max" gives "max(0, survived - 0) * max(0, 16 - age)" # "C" gives "max(0, x[0]) * max(0, 16 - x[1])" # "bf" gives basis functions e.g. "bf1" or "bf1 * bf3" get.term.strings <- function(object, digits, use.names, style = c("h", "pmax", "max", "C", "bf"), neworder) { switch(match.arg1(style, "style"), "h" = get.term.strings.h(object, digits, use.names, neworder), "pmax" = get.term.strings.pmax(object, digits, use.names, neworder, "pmax"), "max" = get.term.strings.pmax(object, digits, use.names, neworder, "max"), "C" = get.term.strings.pmax(object, digits, use.names, neworder, "max"), "bf" = get.term.strings.bf(object, digits, use.names, neworder)) } get.term.strings.h <- function(object, digits, use.names, new.order) { # digits is unused if(!use.names) warning("use.names=FALSE ignored because style=\"h\"") s <- colnames(object$bx)[new.order] } # TODO need to add factor simplification to this routine # TODO need to add get.ndigits functionality (in get.earth.term.name) to this routine get.term.strings.pmax <- function(object, digits, use.names, new.order, fname) { # get.width returns the width for printing elements of the earth expression. # This is used to keep things lined up without too much white space. # This returns the widest of all possible printed elements. get.width <- function(which.terms, dirs, var.names, cuts, digits) { if(length(which.terms) == 1) return(10) # return arbitrary width for intercept only model used.dirs <- dirs[which.terms, , drop=FALSE] # used.preds is a logical index vector which selects used x predictors used.preds <- apply(used.dirs, 2, any1) # as.list is needed so format treats each cut independently max(nchar(var.names[used.preds]), nchar(format(as.list(cuts[which.terms, used.preds]), digits=digits))) } which.terms <- object$selected.terms[new.order] cuts <- object$cuts var.names <- variable.names.earth(object, use.names=use.names) which.terms <- object$selected.terms[new.order] dirs <- object$dirs width <- get.width(which.terms, dirs, var.names, cuts, digits) nterms <- length(which.terms) s <- character(nterms) s[1] = "(Intercept)" iterm <- 2 fname <- if(fname=="h") "h(" else paste0(fname, "(0, ") while(iterm <= nterms) { isel.term <- which.terms[iterm] dir <- dirs[isel.term, , drop=FALSE] cut <- cuts[isel.term, , drop=FALSE] npreds <- ncol(cuts) prefix <- "" for(ipred in seq_len(npreds)) { if(dir[ipred]) { if(dir[ipred] == 2) # linear predictor? s[iterm] <- pastef(s[iterm], "%s%-*s %*s ", prefix, width=width, var.names[ipred], width=width, "") else if(dir[ipred] == -1) s[iterm] <- pastef(s[iterm], "%s%s%s - %*s) ", prefix, fname, format(cut[ipred], width=width, digits=digits), width, var.names[ipred]) else if(dir[ipred] == 1) s[iterm] <- pastef(s[iterm], "%s%s%*s - %s) ", prefix, fname, width=width, var.names[ipred], format(cut[ipred], width=width, digits=digits)) else stop0("illegal direction ", dir[ipred], " in 'dirs'") prefix <- "* " } } iterm <- iterm + 1 } s } # return a data.frame, each row has 2 elements: the original and new basis function names get.bfs <- function(names) { # Example: start of with names: # "(Intercept)", "h(temp-58)", "h(humidity-55)*h(temp-58)", ... # make a single long string s0 <- paste(names, collapse="") # "(Intercept)h(temp-58)h(humidity-55)*h(temp-58)..." # replace * with nothing s1 <- gsub("*", "", s0, fixed=TRUE) # "(Intercept)h(temp-58)h(humidity-55)h(temp-58)..." # replace ) with )@ so @ are split points s2 <- gsub(")", ")@", s1, fixed=TRUE) # "(Intercept)@h(temp-58)@h(humidity-55)@h(temp-58)..." # separate strings at split points s3 <- strsplit(s2, split="@")[[1]] # "(Intercept)", "h(temp-58)", "h(humidity-55)" "h(temp-58)", ... # remove duplicate strings, result is a vector of all basis function names original <- unique(s3) # "(Intercept)", "h(temp-58)", "h(humidity-55)" "h(temp-58)", ... # -1 below so first term is bf1 (i.e. intercept is bf0, which is unused) new <- paste0("bf", seq_along(original)-1) # "bf1", "bf2", "bf3", ... data.frame(original, new) } get.term.strings.bf <- function(object, digits, use.names, new.order) { # digits is unused if(!use.names) warning("use.names=FALSE ignored because style=\"h\"") names <- colnames(object$bx)[new.order] # "(Intercept)", "h(temp-58)", "h(humidity-55)*h(temp-58)", ... bfs <- get.bfs(names) # replace original names with names in new.bfs if(nrow(bfs) > 1) for(i in 2:nrow(bfs)) # start at 2 to skip intercept names <- gsub(bfs[i,1], bfs[i,2], names, fixed=TRUE) gsub("*", " * ", names, fixed=TRUE) # put space around * } # Return a string like this: # bf1 h(temp-58) # bf2 h(234-ibt) # bf3 h(200-vis) # bf4 h(doy-92) get.table.of.basis.functions <- function(object, new.order) { names <- colnames(object$bx)[new.order] bfs <- get.bfs(names) s <- "" if(nrow(bfs) > 1) for(i in 2:nrow(bfs)) # start at 2 to skip intercept s <- paste0(s, sprint("%6s %s\n", bfs[i,2], bfs[i,1])) s } # Return a string representing the linear model. # Example: a <- lm(Volume ~ ., data = trees); cat(format(a)) # which yields: # # -58 # + 4.71 * Girth # + 0.339 * Height # # The first arg is actually an object but called x for consistency with generic # # TODO this function doesn't really belong in the earth package format.lm <- function( x = stop("no 'x' argument"), # "lm" object, also works for "glm" objects digits = getOption("digits"), use.names = TRUE, colon.char = ":", # convert colons in expression to this char ...) # unused, for consistency with generic { format1 <- function(coef) { format(coef, justify="left", width=coef.width, digits=digits, format="%g") } check.classname(x, substitute(x), "lm") use.names <- check.boolean(use.names) dataClasses <- attr(x$terms, "dataClasses") # TODO extend this function to handle factors if(any((dataClasses == "factor") | (dataClasses == "ordered"))) stop0("a predictor has class \"factor\" and format.lm cannot handle that") coefs <- coef(x) stopifnot(length(coefs) > 0) if(!is.vector(coefs) || NCOL(coefs) > 1) stop0("format.lm can only handle single response models") pred.names <- names(coefs) if(is.null(pred.names) || !use.names) { pred.names <- paste("x[,", 0:length(coefs), "]", sep="") pred.names[1] <- "(Intercept)" } pred.names <- make.unique(gsub(":", colon.char, pred.names), sep="_") # if any coef is NA then issue warning and change the coef to 0 if(anyNA(coefs)) { which <- which(is.na(coefs)) warnf("coefficient for %s%s is NA, printing it as 0", pred.names[which[1]], if(length(which) > 1) " and others" else "") coefs[which] <- 0 } intercept <- 0 intercept.index <- match("(Intercept)", names(coefs), nomatch=0) if(intercept.index) { stopifnot(intercept.index == 1) intercept <- coefs[1] pred.names <- pred.names[-1] # drop intercept coefs <- coefs[-1] } s <- sprint(" %.*g\n", digits=digits, intercept) coef.width <- get.coef.width(coefs, digits) for(ipred in seq_along(coefs)) { coef <- coefs[ipred] if(coef < 0) s <- pastef(s, " - %s ", format1(-coef)) else s <- pastef(s, " + %s ", format1(coef)) s <- pastef(s, "* %s", pred.names[ipred]) s <- pastef(s, "\n") } s } earth/R/earth.regress.R0000644000176200001440000000661113447262015014465 0ustar liggesusers# earth.regress.R: earth.regress is used only for testing Regress in earth.c # (it is called using earth:::earth.regress in test.earth.full.R) earth.regress <- function( x = stop("no 'x' argument"), # NAs are not allowed in x or y y = stop("no 'y' argument"), weights = NULL, # case weights used.cols = NULL) { # following copied from header of earth.fit # expand factors, convert to double matrix with col names env <- parent.frame() x <- expand.arg(x, env, trace=0) y <- expand.arg(y, env, trace=0, is.y.arg=TRUE, xname=trunc.deparse(substitute(y))) if(nrow(x) == 0) stop0("no 'x' values") if(ncol(x) == 0) # this happens for example for earth(Volume~Volume,data=trees) stop0("no 'x'") if(nrow(x) != nrow(y)) stop0("nrow(x) ", nrow(x), " != nrow(y) ", nrow(y)) if(!all(is.double(x))) stop0("non double entries in 'x' argument") if(!all(is.double(y))) stop0("non double entries in 'y' argument") if(!is.null(weights) && length(weights) != nrow(x)) stop0("length(weights) ", length(weights), " != nrow(x) ", nrow(y)) # add intercept to x colnames. <- colnames(x) x <- cbind(repl(1, nrow(x)), x) colnames(x) <- c("(Intercept)", colnames.) nresp <- ncol(y) ncols <- ncol(x) ncases <- nrow(x) if(is.null(weights)) weights <- repl(1, ncases) else weights <- check.weights(weights, "weights", ncases, tweak.zero.weights=TRUE) if(is.null(used.cols)) { used.cols <- repl(TRUE, ncols) coefficients <- matrix(1.0, nrow=ncol(x), ncol=nresp) } else { if(!is.logical(used.cols)) stop0("used.cols is not logical") if(length(used.cols) != ncol(x)-1) # -1 for intercept added above stop0("length(used.cols) != ncol(x)") check.index(used.cols, "used.cols", x, is.col.index=TRUE) used.cols <- c(TRUE, used.cols) # add intercept coefficients <- matrix(1.0, nrow=ncol(x) - sum(!used.cols), ncol=nresp) } rownames(coefficients) <- colnames(x)[used.cols] colnames(coefficients) <- colnames(y) on.exit(.C("FreeEarth", PACKAGE="earth")) # if error or user interrupt, free mem rval <- .C("RegressR", coefficients = coefficients, # double Betas[] out: nUsedCols * nResp residuals = matrix(1.0, nrow=ncases, ncol=nresp), # double Residuals[] out: nCases * nResp rss = double(1), # double* pRss out: RSS, summed over all nResp diags = double(ncols), # double Diags[] out: rank = integer(1), # int* pnRank out: nbr of indep cols in x pivots = integer(ncols),# int iPivots[] out: nCols as.double(x), # const double x[] in: nCases x nCols as.double(y), # const double y[] in: nCases x nResp as.integer(ncases), # const int* pnCases in: number of rows in x and in y as.integer(nresp), # const int* pnResp in: number of cols in y as.integer(ncols), # int* pnCols in: number of columns in x as.logical(used.cols), # const bool UsedCols[]) in: specifies used columns in x PACKAGE="earth") rval$fitted.values <- y - rval$residuals rval$call <- match.call() rval } earth/R/check.index.R0000644000176200001440000001720313443765152014101 0ustar liggesusers# check.index.R # Check that an index vector specified by the user is ok to index an object. # We want to preclude confusing R messages or behaviour later. # An example is when max(index) > length(object) which quietly # returns NA and can cause confusing downstream behaviour. # This returns a vector suitable for indexing into object (will # be identical to index unless index is a character vector). # # If index is a character vector, then matching (regex if is.col.index != 2) # is used against the names in the object, and an integer vector is returned. check.index <- function(index, index.name, object, colnames = NULL, is.col.index = 0, # 0=row index, 1=col index, 2=exact non-regex col name if char allow.empty = FALSE, # if index is char will warn if necessary regardless of allow.empty allow.zeros = FALSE, allow.negatives = TRUE, allow.dups = FALSE, treat.NA.as.one = FALSE, is.degree.spec = FALSE) # special handling for degree1 and degree2 specs { index.name <- quotify.short(index.name, "index", quote="'") # check that the given index and object can be evaluated try <- try(eval(index)) if(is.try.err(try)) stop0("illegal ", index.name) try <- try(eval(object)) if(is.try.err(try)) stop0("illegal ", quotify.short(object, quote="'")) is.col.index <- check.integer.scalar(is.col.index, min=0, max=2) allow.empty <- check.boolean(allow.empty) allow.zeros <- check.boolean(allow.zeros) allow.negatives <- check.boolean(allow.negatives) allow.dups <- check.boolean(allow.dups) treat.NA.as.one <- check.boolean(treat.NA.as.one) if(is.null(index)) { if(!allow.empty) stop0(index.name, " is NULL and cannot be used as an index") return(NULL) } if(treat.NA.as.one && (length(index) == 1 && is.na(index)[1])) index <- 1 if(anyNA(index)) stop0("NA in ", index.name) if(NROW(index) != 1 && NCOL(index) != 1) stop0(index.name, " must be a vector not a matrix (", index.name, " has dimensions ", NROW(index), " x ", NCOL(index), ")") len <- get.len(object, is.col.index) if(is.character(index)) # currently only works for column names of object check.character.index(index, index.name, object, colnames, len, is.col.index, allow.empty, is.degree.spec) else if(is.logical(index)) check.logical.index(index, index.name, len, allow.empty) else if(is.numeric(index)) check.numeric.index(index, index.name, len, allow.empty, allow.negatives, allow.dups, allow.zeros, treat.NA.as.one) else stop0(index.name, " must be an index vector (numeric, logical, or character)") } get.len <- function(object, is.col.index) { if(is.col.index) len <- NCOL(object) # index is for columns of object else if(is.null(dim(object))) len <- length(object) else len <- NROW(object) # index is for rows of object # NROW also works for lists stopifnot(length(len) == 1) stopifnot(len > 0) len } matchmult <- function(x, tab) # like match but return multiple matches if present { matches <- integer(0) for(i in seq_along(x)) { xi <- x[i] for(itab in 1:length(tab)) if(xi == tab[itab]) matches <- c(matches, itab) } matches } # This does regex matching of index and returns an integer vector check.character.index <- function(index, index.name, object, names, len, is.col.index, # 0=row index, 1=col index, 2=exact non-regex col name if char allow.empty, is.degree.spec) { stopifnot(is.character(index)) is.col.index <- check.integer.scalar(is.col.index, min=0, max=2) # certain regular expressions match everything, even if names not avail if(is.col.index != 2 && length(index) == 1 && index %in% c("", ".", ".*")) return(1:len) if(is.col.index && is.null(names)) names <- colnames(object) if(length(names) == 0 || !is.character(names)) stop0(index.name, " specifies names but the names are unavailable") matches <- integer(0) warning.names <- integer(0) # these regexs don't match any column names for(i in seq_along(index)) { name <- index[i] igrep <- if(is.col.index == 2) { # exact match, not a regular exp? if(nchar(name) == 0) warning0(unquote(index.name), "[", i, "] is an empty string \"\"") which(name == names) } else grep(name, names) if(length(igrep)) matches <- c(matches, igrep) else warning.names <- c(warning.names, name) } if(is.degree.spec) { if(is.null(dim(object))) # vector, degree1 matches <- matchmult(matches, object) else if(length(dim(object)) == 2) # 2D matrix, degree2 matches <- c(matchmult(matches, object[,1]), matchmult(matches, object[,2])) else stop0("that kind of object is not yet supported for ", index.name) } new.index <- unique(matches[!is.na(matches)]) for(name in warning.names) warning0("\"", name, "\" in ", unquote(index.name), " does not match any names\n", " Available names are ", paste.trunc(quotify(names))) new.index } check.logical.index <- function(index, index.name, len, allow.empty) { stopifnot(is.logical(index)) if(!allow.empty) { if(length(index) == 0) stop0("length(", unquote(index.name), ") == 0") if(length(index[index == TRUE]) == 0) stop0(index.name, " is all FALSE") } # note that a single FALSE or TRUE is ok regardless of length(object) if(length(index) > len && length(index) != 1) { stop0("logical index ", index.name, " is too long.\n", " Its length is ", length(index), " and the max allowed length is ", len) } index } check.numeric.index <- function(index, index.name, len, allow.empty, allow.negatives, allow.dups, allow.zeros, treat.NA.as.one) { stopifnot(is.numeric(index)) if(!allow.empty) { if(length(index) == 0) stop0(index.name, " is empty, (its length is 0)") else if(all(index == 0)) if(length(index) == 1) stop0(index.name, " is 0") else stop0(index.name, " is all zeros") } if(!is.integral(index)) stop0(index.name, " is not an integer") if(any(index < 0) && any(index > 0)) stop0("mixed negative and positive values in ", index.name) if(!allow.zeros && any(index == 0) && length(index) != 1) warning0("zero in ", index.name) if(!allow.negatives && any(index < 0)) stop0("negative value in ", index.name) if(!allow.dups && any(duplicated(index))) warning0("duplicates in ", index.name) if(any(abs(index) > len)) { if(length(index) == 1) prefix <- paste0(unquote(index.name), "=", index, " but ") else prefix <- paste0(index.name, " is out of range, ") if(len != 1) stop0(prefix, "allowed values are 1 to ", len) else if(treat.NA.as.one) stop0(prefix, "the only allowed value is 1 (or NA)") else stop0(prefix, "the only allowed value is 1") } index } earth/R/print.earth.R0000644000176200001440000003656413443003076014155 0ustar liggesusers# print.earth.R: functions for summarizing and printing earth objects # print.earth's first arg is actually a model object but called x for consistency with generic print.earth <- function(x, digits=getOption("digits"), fixed.point=TRUE, ...) { form <- function(x, pad) { sprint("%-*s", digits+pad, format(if(abs(x) < 1e-20) 0 else x, digits=digits)) } #--- print.earth starts here check.classname(x, substitute(x), "earth") warn.if.dots(...) remind.user.bpairs.expansion <- !is.null(x$glm.bpairs) && !is.null(x$ncases.after.expanding.bpairs) # ncases.after.expanding.bpairs is null if Expand.bpairs was FALSE if(!is.null(x$glm.list)) { if(remind.user.bpairs.expansion) printf("The following stats are for the binomial pairs without expansion (%g cases):\n", NROW(x$residuals)) print_earth_glm(x, digits, fixed.point, prefix.space=remind.user.bpairs.expansion) } nresp <- NCOL(x$coefficients) is.cv <- !is.null(x$cv.list) nselected <- length(x$selected.terms) if(is.null(x$glm.list)) { # glm.list is a list of glm models, null if none if(remind.user.bpairs.expansion) printf(" ") cat("Selected ") } else { if(remind.user.bpairs.expansion) printf("The following stats are for the binomial pairs after expansion (%g cases):\n ", x$ncases.after.expanding.bpairs) cat("Earth selected ") # remind user that these are for the earth not glm model } cat(length(x$selected.terms), "of", nrow(x$dirs), "terms, and", get.nused.preds.per.subset(x$dirs, x$selected.terms), "of", ncol(x$dirs), "predictors") if(x$pmethod != "backward") printf(" (pmethod=\"%s\")", x$pmethod) cat("\n") print_termcond(x, remind.user.bpairs.expansion) print_one_line_evimp(x, remind.user.bpairs.expansion) # "try" below is paranoia so don't completely blow out if problem in print_offset try(print_offset(x, digits, remind.user.bpairs.expansion)) try(print_weights(x, digits, remind.user.bpairs.expansion)) nterms.per.degree <- get.nterms.per.degree(x, x$selected.terms) cat0(if(remind.user.bpairs.expansion) " " else "") cat("Number of terms at each degree of interaction:", nterms.per.degree) cat0(switch(length(nterms.per.degree), " (intercept only model)", " (additive model)"), "\n") if(nresp > 1) print_earth_multiple_response(x, digits, fixed.point) else print_earth_single_response(x, digits, fixed.point, remind.user.bpairs.expansion) if(x$pmethod == "cv") { # The digits +1 below is an attempt to be compatible with the above prints. # The number of digits won't always match exactly, it's not critical. print_would_have(x, if(nresp > 1) digits+1 else digits) } invisible(x) } print_earth_single_response <- function(x, digits, fixed.point, prefix.space) { is.cv <- !is.null(x$cv.list) spacer <- if(is.cv) " " else " " nselected <- length(x$selected.terms) if(prefix.space) printf(" ") if(!is.null(x$glm.list)) cat0("Earth ") # remind user if(x$pmethod == "cv") { ilast <- nrow(x$cv.oof.rsq.tab) cat0("GRSq ", format(x$grsq, digits=digits), spacer, "RSq ", format(x$rsq, digits=digits), spacer, "mean.oof.RSq ", format(x$cv.oof.rsq.tab[ilast,nselected], digits=digits), " (sd ", format(sd(x$cv.oof.rsq.tab[-ilast,nselected], na.rm=TRUE), digits=3), ")\n") } else { ilast <- nrow(x$cv.rsq.tab) cat0("GCV ", format(x$gcv, digits=digits), spacer, "RSS ", format(x$rss, digits=digits), spacer, "GRSq ", format(x$grsq, digits=digits), spacer, "RSq ", format(x$rsq, digits=digits)) if(is.cv) cat0(spacer, "CVRSq ", format(x$cv.rsq.tab[ilast,ncol(x$cv.rsq.tab)], digits=digits)) cat("\n") } } print_earth_multiple_response <- function(x, digits, fixed.point) { nresp <- NCOL(x$coefficients) stopifnot(nresp > 1) is.cv <- !is.null(x$cv.list) nselected <- length(x$selected.terms) # create a data.frame and print that mat <- matrix(nrow=nresp+1, ncol=4 + is.cv + (x$pmethod == "cv")) rownames(mat) <- c(colnames(x$fitted.values), "All") colnames <- c("GCV", "RSS", "GRSq", "RSq") if(is.cv) colnames <- c(colnames, if(x$pmethod=="cv") c(" mean.oof.RSq", "sd(mean.oof.RSq)") else "CVRSq") colnames(mat) <- colnames for(iresp in seq_len(nresp)) { mat[iresp,1:4] <- c(x$gcv.per.response[iresp], x$rss.per.response[iresp], x$grsq.per.response[iresp], x$rsq.per.response[iresp]) if(is.cv) { if(x$pmethod == "cv") { ilast <- nrow(x$cv.oof.rsq.tab) mat[iresp,5] <- NA mat[iresp,6] <- NA } else { ilast <- nrow(x$cv.rsq.tab) mat[iresp,5] <- x$cv.rsq.tab[ilast,iresp] } } } # final row for "All" mat[nresp+1,1:4] <- c(x$gcv, x$rss, x$grsq, x$rsq) if(is.cv) { if(x$pmethod == "cv") { mat[nresp+1,5] <- signif(x$cv.oof.rsq.tab[ilast,nselected], digits=digits) mat[nresp+1,6] <- signif(sd(x$cv.oof.rsq.tab[-ilast,nselected], na.rm=TRUE), digits=digits) } else mat[nresp+1,5] <- x$cv.rsq.tab[ilast,ncol(x$cv.rsq.tab)] } cat("\n") if(!is.null(x$glm.list)) cat("Earth\n") # remind user if(fixed.point) mat <- my.fixed.point(mat, digits) df <- as.data.frame(mat) # the following converts the matrix from numeric to character df[is.na(df)] <- "" # print NAs as blanks (in mean.oof.RSq column) print(df, digits=digits) } # print reason we terminated the forward pass print_termcond <- function(object, prefix.space) { if(prefix.space) printf(" ") printf("Termination condition: ") if(is.null(object$termcond)) { printf("Unknown\n") # model was created by mars.to.earth return() } termcond <- object$termcond check.numeric.scalar(termcond) nk <- object$nk check.numeric.scalar(nk) nterms.before.pruning <- nrow(object$dirs) check.numeric.scalar(nterms.before.pruning) thresh <- object$thresh check.numeric.scalar(thresh) terms.string = if(nterms.before.pruning == 1) "term" else "terms" if(termcond == 1) printf("Reached nk %d\n", nk) else if(termcond == 2) printf("GRSq -Inf at %d %s\n", nterms.before.pruning, terms.string) else if(termcond == 3) printf("GRSq -10 at %d %s\n", nterms.before.pruning, terms.string) else if(termcond == 4) printf("RSq changed by less than %g at %d %s\n", thresh, nterms.before.pruning, terms.string) else if(termcond == 5) printf("Reached maximum RSq %.4f at %d %s\n", 1-thresh, nterms.before.pruning, terms.string) else if(termcond == 6) printf("No new term increases RSq at %d %s\n", nterms.before.pruning, terms.string) else if(termcond == 7) printf("Reached nk %d\n", nk) else printf("Unknown (termcond %d)\n", termcond) # should never happen } # The first arg is actually an object but called x for consistency with generic print.summary.earth <- function( x = stop("no 'x' argument"), # "summary.earth" object details = x$details, decomp = x$decomp, digits = x$digits, fixed.point = x$fixed.point, newdata = x$newdata, ...) { nresp <- NCOL(x$coefficients) warn.if.dots(...) if(!is.null(newdata)) { # print short summary on newdata printf("RSq %.3f on newdata (%d cases)\n", x$newrsq, NROW(newdata)) if(!is.null(x$varmod)) { printf("\n") print.varmod(x$varmod, newdata=newdata, digits=digits) } return(invisible(x)) } printcall("Call: ", x$call) cat("\n") new.order <- reorder.earth(x, decomp=decomp) if(is.null(x$glm.stats) || details) print_earth_coefficients(x, digits, fixed.point, new.order) if(!is.null(x$glm.stats)) print_summary_earth_glm(x, details, digits, fixed.point, new.order) # if(details) # cat0("Number of cases: ", nrow(x$residuals), "\n") print.earth(x, digits) if(!is.null(x$cv.list) && x$pmethod != "cv") print_cv(x) if(!is.null(x$varmod)) { printf("\nvarmod: ") x$varmod <- print.varmod(x$varmod, digits=digits) } invisible(x) } print_offset <- function(object, digits, prefix.space) { # currently only earth.formula objects can have an offset terms <- object$terms if(is.null(terms)) return() offset.index <- attr(terms, "offset") if(is.null(offset.index) || is.null(object$offset)) return() varnames <- rownames(attr(terms, "factors")) if(is.null(varnames) || offset.index < 1 || offset.index > length(varnames)) return() offset.term <- varnames[offset.index] # convert "offset(foo)" to "foo" offset.term.name <- substring(offset.term, 8, nchar(offset.term)-1) if(prefix.space) printf(" ") print_values("Offset", offset.term.name, object$offset, digits) } print_weights <- function(object, digits, prefix.space) { if(is.null(object$weights)) return() if(prefix.space) printf(" ") print_values("Weights", NULL, object$weights, digits) } print_values <- function(name, term.name, values, digits) { s <- if(is.null(term.name)) paste0(name, ": ") else paste0(name, ": ", strip.space.collapse(term.name), " with values ") cat0(s) n <- min(30, length(values)) # save time by formatting a max of only 30 values stopifnot(n > 0) svalues <- character(n) maxlen <- max(25, getOption("width") - nchar(s) - 5) # -5 for ", ..." s <- if(!is.null(term.name) && substring(term.name, 1, 4) == "log(") { # common case # format each value individually (not aggregrated like format on a vector) # this is nice for example if just one weight is very small for(i in seq_along(svalues)) svalues[i] <- strip.space(format(exp(values[i]), digits=digits)) paste.trunc("log(", svalues, ")", sep="", collapse=", ", maxlen=maxlen) } else { for(i in seq_along(svalues)) svalues[i] <- strip.space(format(values[i], digits=digits)) paste.trunc(svalues, sep="", collapse=", ", maxlen=maxlen) } cat0(s, "\n") } print_would_have <- function(x, digits) { form <- function(x) format(x, digits=digits) nselected <- length(x$backward.selected.terms) ilast <- nrow(x$cv.oof.rsq.tab) cat0("\npmethod=\"backward\" would have selected", if(nselected == length(x$selected.terms)) " the same model" else "", ":\n ", nselected, " terms ", get.nused.preds.per.subset(x$dirs, x$backward.selected.terms), " preds, GRSq ", form(get.rsq(x$gcv.per.subset[nselected], x$gcv.per.subset[1])), " RSq ", form(get.rsq(x$rss.per.subset[nselected], x$rss.per.subset[1])), " mean.oof.RSq ", form(x$cv.oof.rsq.tab[ilast, nselected]), "\n") if(anyNA(x$cv.oof.rsq.tab[ilast, nselected])) printf( " (mean.oof.RSq is NA because most fold models have less than %g terms)\n", nselected) } print_earth_coefficients <- function(x, digits, fixed.point, new.order) { nresp <- NCOL(x$coefficients) if(!is.null(x$strings)) { # old style expression formatting? resp.names <- colnames(x$fitted.values) for(iresp in seq_len(nresp)) { cat0(resp.names[iresp], " =\n") cat(x$strings[iresp]) cat("\n") } } else { rownames(x$coefficients) <- spaceout(rownames(x$coefficients)) coef <- x$coefficients[new.order, , drop=FALSE] if(fixed.point) coef <- my.fixed.point(coef, digits) if(!is.null(x$glm.list)) # embedded GLM model(s)? cat("Earth coefficients\n") # remind user what these are else if(nresp == 1) colnames(coef) = "coefficients" print(coef, digits=digits) cat("\n") } } print_summary_earth_glm <- function(x, details, digits, fixed.point, new.order) { nresp <- NCOL(x$coefficients) resp.names <- colnames(x$fitted.values) if(!is.null(x$strings)) { # old style expression formatting? for(iresp in seq_len(nresp)) { g <- x$glm.list[[iresp]] cat("GLM ") # remind user that these are GLM (not earth) coefficients cat0(resp.names[iresp], " =\n") cat(x$strings[nresp+iresp]) # glm strings index is offset by nresp cat("\n") } } else { cat("GLM coefficients\n") # remind user that these are GLM (not earth) coefficients rownames(x$glm.coefficients) <- spaceout(rownames(x$glm.coefficients)) coef <- x$glm.coefficients[new.order, , drop=FALSE] if(fixed.point) coef <- my.fixed.point(coef, digits) print(coef, digits=digits) cat("\n") } if(details) for(iresp in seq_len(nresp)) print_glm_details(x$glm.list[[iresp]], nresp, digits, my.fixed.point, resp.names[iresp]) } # TODO Add an inverse.func arg to summary.earth, similar to plotmo. summary.earth <- function( # returns a superset, not a summary in the strict sense object = stop("no 'object' argument"), details = FALSE, style = c("h", "pmax", "max", "C", "bf"), decomp = "anova", digits = getOption("digits"), fixed.point = TRUE, newdata = NULL, ...) # unused { check.classname(object, substitute(object), "earth") details <- check.boolean(details) fixed.point <- check.boolean(fixed.point) rval <- object rval$strings <- switch(match.arg1(style, "style"), "h" = { stop.if.dots(...) }, "pmax" = format.earth(x=object, style=style, decomp=decomp, digits=digits, ...), "max" = format.earth(x=object, style=style, decomp=decomp, digits=digits, ...), "C" = format.earth(x=object, style=style, decomp=decomp, digits=digits, ...), "bf" = format.earth(x=object, style=style, decomp=decomp, digits=digits, ...)) rval$details <- details # pass details arg on to print.summary.earth rval$decomp <- decomp rval$digits <- digits rval$fixed.point <- fixed.point if(!is.null(newdata)) { rval$newdata <- newdata rval$newrsq <- plotmo::plotmo_rsq(object, newdata, ...) } is.glm <- !is.null(object$glm.list) # TRUE if embedded GLM model(s) class(rval) <- c("summary.earth", "earth") rval } # put some spaces into term names for readability # convert h(x1-5860)*h(x2--15) # to h(x1-5860) * h(x2- -15) spaceout <- function(rownames.) { rownames. <- gsub("\\*", " * ", rownames.) # spaces around * rownames. <- gsub("--", "- -", rownames.) # spaces between -- gsub("`", "", rownames.) # remove backquotes } earth/R/plotd.R0000644000176200001440000007525013437330133013034 0ustar liggesusers# plotd.R: plot densities of class conditional predicted values # # TODO: allow newdata so can plot not only with the training data # TODO: allow freq arg for histograms plotd <- function(object, # object is a model object hist = FALSE, # FALSE to use density(), TRUE to use hist() type = NULL, # NULL gets changed to a value which is passed on to predict nresponse = NULL, # which response, for multiple response models, NULL for all dichot = FALSE, trace = FALSE, xlim = NULL, # NULL means auto ylim = NULL, # NULL means auto jitter = FALSE, main = NULL, # graph caption # "string" string # "" no caption # NULL generate a caption from x$call xlab = "Predicted Value", ylab = if(hist) "Count" else "Density", lty = 1, # linetypes for the plotted lines col = c("gray70", 1, "lightblue", "brown", "pink", 2, 3, 4), # cols for plotted lines fill = if(hist) col[1] else 0, # fill color for first hist/density plot breaks = "Sturges", # following passed on to hist, only used if hist=TRUE labels = FALSE, kernel = "gaussian", # following passed on to density, only used if hist=FALSE adjust = 1, zero.line = FALSE, legend = TRUE, # TRUE to draw a legend legend.names = NULL, # NULL means auto, else specify a vector of strings, legend.pos = NULL, # NULL means auto, else specify c(x,y) in user coords cex.legend = .8, # cex for legend legend.bg = "white", # bg for legend legend.extra = FALSE, # print number in each class in legend vline.col = 0, # color of vertical line, use NULL or 0 for no line vline.thresh = .5, # horizontal position of vertical line vline.lty = 1, # lty of vertical line vline.lwd = 1, # lwd of vertical line err.thresh=vline.thresh, # thresh for "error areas" err.col=0, # col shading of "error areas" err.border=0, err.lwd=1, xaxt = "s", yaxt = "s", xaxis.cex = 1, sd.thresh = 0.01, ...) # passed to predict { init.global.data() on.exit(init.global.data()) # release memory on exit object.name <- short.deparse(substitute(object)) trace <- as.numeric(check.integer.scalar(trace, logical.ok=TRUE)) # Associate the model environment with the object. # (This is instead of passing it as an argument to plotmo's data access # functions. It saves a few hundred references to model.env in the code.) attr(object, ".Environment") <- get.model.env(object, object.name, trace) temp <- plotmo::plotmo_prolog(object, object.name, trace, ...) object <- temp$object my.call <- temp$my.call hist <- check.boolean(hist) # dicho <- check.boolean(dichot) # can't use because we use missing(dichot) below trace <- as.numeric(check.integer.scalar(trace, logical.ok=TRUE)) jitter <- check.boolean(jitter) labels <- check.boolean(labels) zero.line <- check.boolean(zero.line) legend <- check.boolean(legend) legend.extra <- check.boolean(legend.extra) type <- plotmo::plotmo_type(object, trace, "plotmo", type, ...) yhat.per.class <- get.yhat.per.class(object, object.name, type, nresponse, dichot, trace, ...) nclasses <- length(yhat.per.class) # get densities densities <- NULL for(iclass in seq_len(nclasses)) if(!hist) densities[[iclass]] <- density(yhat.per.class[[iclass]], kernel=kernel, adjust=adjust) else { densities[[iclass]] <- hist(yhat.per.class[[iclass]], breaks=breaks, plot=FALSE) # need x and y components so hist can be treated uniformly with density densities[[iclass]]$x <- densities[[iclass]]$breaks densities[[iclass]]$y <- densities[[iclass]]$counts } # get x limits of plot if(is.null(xlim)) { min1 <- Inf max1 <- -Inf for(iclass in seq_len(nclasses)) { min1 <- min(min1, densities[[iclass]]$x) max1 <- max(max1, densities[[iclass]]$x) } xlim <- c(min1, max1) } if(length(xlim) != 2) stop0("length(xlim) != 2") xspan <- xlim[2] - xlim[1] # sanity check the ranges of each class, issue warnings if need be degenerate <- logical(nclasses) for(iclass in seq_len(nclasses)) { range <- range(yhat.per.class[[iclass]]) if(sd(yhat.per.class[[iclass]]) < sd.thresh) { warning0("standard deviation of '", names(yhat.per.class)[iclass], "' density is ", sd(yhat.per.class[[iclass]]), ", density is degenerate?") degenerate[iclass] <- TRUE } } # add jitter and get ymax for plot ymax <- 1e-6 if(is.logical(jitter) && jitter) jitter <- xspan / 100 for(iclass in seq_len(nclasses)) { if(jitter) { if(hist) densities[[iclass]]$breaks <- densities[[iclass]]$breaks + iclass * jitter else densities[[iclass]]$x <- densities[[iclass]]$x + iclass * jitter } ymax <- max(ymax, densities[[iclass]]$y) } if((is.logical(labels) && labels) || is.character(labels)) ymax <- 1.1 * ymax # hack to make space for labels if(!is.null(ylim)) { if(length(ylim) != 2) stop0("length(ylim) != 2") ymax <- ylim[2] if(ymax <= 0) stop0("ylim[2] <= 0") if(ylim[1] != 0) warning0("ignoring ylim[1], treating it as 0") } # expand lty and other arguments if necessary if(length(lty) < nclasses) lty <- repl(lty, nclasses) if(length(col) < nclasses) col <- repl(col, nclasses) if(is.null(main)) { # auto generate main? main <- paste0(object.name, " ", paste.collapse(type), if(missing(nresponse)) "" else paste0(" nresp=", paste(nresponse, collapse=",")), if(missing(dichot)) "" else paste0(" dichot=", dichot)) main <- paste.trunc(main) } if(!is.null(my.call)) { main <- paste0(main, "\n", paste.trunc(my.call)) old.cex.main <- par("cex.main") on.exit(par(cex.main=old.cex.main), add=TRUE) par(cex.main=1) } # we draw our own x axis for type="class" # xlims are wrong for histograms if a density is degenerate hence the test # TODO weird behaviour in hist? hist gives a 0 lower x val if density degenerate draw.own.axis <- hist && xaxt != "n" && !anyNA(pmatch(type, "class")) && !any(degenerate) if(draw.own.axis) xaxt <- "n" # plot the first graph ifirst <- 1 # index of first non-degenerate class, 1 if all degenerate for(iclass in seq_len(nclasses)) if(!degenerate[iclass]) { ifirst <- iclass break } if(hist) { # plot.histogram plot(densities[[ifirst]], xlim=xlim, ylim=c(0, ymax), main=main, xlab=xlab, ylab=ylab, lty=lty[ifirst], border=col[ifirst], xaxt=xaxt, yaxt=yaxt, col=if(ifirst==1) fill else 0) # fill color draw.labels(densities[[ifirst]], labels, cex.legend) } else { # plot.density plot(densities[[ifirst]], xlim=xlim, ylim=c(0, ymax), col=col[ifirst], main=main, xlab=xlab, ylab=ylab, lty=lty[ifirst], zero.line=zero.line, xaxt=xaxt, yaxt=yaxt) if(ifirst == 1 && is.specified(fill)) polygon(densities[[1]], col=fill, border=col[1]) } if(draw.own.axis) { at <- xlim[1]:xlim[2] # hack to adjust leftmost label TODO not quite right, but ok at[1] <- at[1] + strwidth(names(yhat.per.class)[1], "user") mtext(names(yhat.per.class), side=1, at=at, font=2, adj=1, cex=xaxis.cex) } # optional error region shading if(!hist && any1(err.col)) draw.err.col(densities, err.thresh, err.col, err.border, err.lwd) # overlay the graphs for(iclass in seq_len(nclasses)) if(!degenerate[iclass]) { if(!hist) # lines.density lines(densities[[iclass]], col=col[iclass], lty=lty[iclass]) else { # lines.histogram lines(densities[[iclass]], col=NULL, border=col[iclass], lty=lty[iclass]) draw.labels(densities[[iclass]], labels, cex.legend) } } # optional vertical line at vline.thresh if(!is.null(vline.col) && is.specified(vline.col)) abline(v=vline.thresh, col=vline.col, lty=vline.lty, lwd=vline.lwd) # Redo optional error region shading if it has borders, because the # borders go on top of the other plotted lines. if(any1(err.border)) draw.err.col(densities, err.thresh, err.col, err.border, err.lwd) # optional legend if(legend) draw.legend(densities, degenerate, yhat.per.class, ymax, hist, xlim, col, fill, lty, legend.names, legend.pos, cex.legend, legend.bg, legend.extra) invisible(yhat.per.class) } # add histogram labels --- lifted from plot.histogram and # tweaked to (i) use cex and (ii) not draw zero counts draw.labels <- function(x, labels, cex) { if((is.logical <- is.logical(labels) && labels) || is.character(labels)) { stopifnot(!is.null(x$counts)) # plotd hist supports only counts, not densities if(is.logical) { labels <- format(x$counts) labels[x$counts == 0] <- "" } text(x$mids, x$counts, labels=labels, adj=c(.5, -.5), cex=cex) } } is.numlog <- function(x) is.numeric(x) || is.logical(x) is.lda.or.qda <- function(object) # allows hacks for lda and qda specific code inherits(object, "lda") || inherits(object, "qda") # return the predictions for each class, in a list with each class named # nomeclature: y is the observed response, yhat is the predicted response get.yhat.per.class <- function(object, object.name, type, nresponse, dichot, trace, ...) { temp <- get.plotd.data(object, type, nresponse, trace, ...) y <- temp$y yhat <- temp$yhat colnames.yhat <- temp$colnames.yhat nresponse <- temp$nresponse yhat1 <- if(length(dim(yhat)) > 1) yhat[,1] else yhat # TODO could probably delete yhat.per.class <- list() # will put per-class predicted vals in here ylevs <- levels(y) # null if y is not a factor nlevs <- 0 if(NCOL(yhat) == 1) { #---single column yhat-------------------------------------------------- trace2(trace, "single column yhat\n") if(is.factor(y) && (is.numlog(yhat1) || is.factor(yhat1))) { nlevs <- nlevels(y) if(!is.numlog(yhat1) && !is.factor(yhat1)) cannot.plot.this.response(y, yhat, colnames.yhat, type, nlevs) stopifnot(length(ylevs) > 1) if(!anyNA(pmatch(type, "class"))) dichot <- FALSE # no dichot for type="class" if(length(ylevs) == 2 || dichot) { ylev1 <- ylevs[1] if(length(ylevs) == 2) { other.level.name <- paste(ylevs[2]) observed.string <- "two-level factor" } else { other.level.name <- paste("not", ylev1) observed.string <- "multi-level factor, but dichot" } trace.response.type(trace, type, observed=observed.string, predicted="numeric or logical vector", "CLASS1 predicted[observed == ", ylev1, "], CLASS2 predicted[observed == ", other.level.name, "]") yhat.per.class[[1]] <- yhat1[y == ylev1] check.min(yhat.per.class[[1]], ylev1) yhat.per.class[[2]] <- yhat1[y != ylev1] check.min(yhat.per.class[[2]], other.level.name) names(yhat.per.class) <- get.prefixed.names(c(ylev1, other.level.name), yhat, colnames.yhat, nresponse) } else { trace.response.type(trace, type, observed="multi-level factor", predicted="numeric or logical vector", "predicted[observed == level] for ", length(ylevs), " levels") for(iclass in seq_along(ylevs)) { lev <- ylevs[iclass] yhat.per.class[[iclass]] <- yhat1[y == lev] check.min(yhat.per.class[[iclass]], lev) } names(yhat.per.class) <- get.prefixed.names(ylevs, yhat, colnames.yhat, nresponse) } } else if(NCOL(y) == 2 && is.numlog(y[,1]) && is.numlog(y[,2])) { trace.response.type(trace, type, observed="numeric or logical vector", predicted="two-column numeric", "CLASS1 observed[,1] <= observed[,2], ", "CLASS2 observed[,1] > observed[,2]") # split into two classes based on relative sizes of columns of y yhat.per.class[[1]] <- yhat1[y[,1] <= y[,2]] check.min(yhat.per.class[[1]], "observed[,1] <= observed[,2]") yhat.per.class[[2]] <- yhat1[y[,1] > y[,2]] check.min(yhat.per.class[[2]], "observed[,1] > observed[,2]") names(yhat.per.class) <- get.binary.class.names(yhat, colnames.yhat, object$fitted.values, c("FALSE", "TRUE")) } else if(NCOL(y) == 1 && is.numlog(y)) { th <- get.thresh(y, "response") trace.response.type(trace, type, observed="numeric or logical vector", predicted="numeric or logical vector", "CLASS1 ", th$text.le, ", CLASS2 ", th$text.gt) yhat.per.class[[1]] <- yhat1[y <= th$thresh] check.min(yhat.per.class[[1]], th$text.le) yhat.per.class[[2]] <- yhat1[y > th$thresh] check.min(yhat.per.class[[2]], th$text.gt) names(yhat.per.class) <- NULL if(th$thresh == 0) names(yhat.per.class) <- get.binary.class.names(yhat, colnames.yhat, object$fitted.values, c(th$text.le, th$text.gt)) else names(yhat.per.class) <- c(th$text.le, th$text.gt) } else cannot.plot.this.response(y, yhat, colnames.yhat, type, nlevs) } else { #---multiple column yhat------------------------------------------------ trace2(trace, "multiple column yhat\n") if(!is.numeric(yhat[,1])) cannot.plot.this.response(y, yhat, colnames.yhat, type, nlevs) if(NCOL(y) == 1 && is.null(ylevs)) ylevs <- as.numeric(names(table(y))) # use numeric levels like a factor nlevs <- length(ylevs) if(NCOL(y) == 1 && nlevs == NCOL(yhat)) { if(is.factor(y)) trace.response.type(trace, type, observed="factor", predicted= "multicolumn numeric, ncol(predicted) == nlevels(observed)", "observed==level for each level in observed response") else trace.response.type(trace, type, observed="factor", predicted= "multicolumn numeric, ncol(predicted) == nbr.of.unique.vals.in.observed", "observed==val for each unique val in observed response") for(iclass in seq_len(ncol(yhat))) { lev <- ylevs[iclass] yhat.per.class[[iclass]] <- yhat[y == lev, iclass] check.min(yhat.per.class[[iclass]], lev) if(length(yhat.per.class[[iclass]]) == length(yhat[,iclass])) stop0("no occurrences of ", lev, " in the observed response") } if(!is.null(colnames.yhat)) names(yhat.per.class) <- colnames.yhat else names(yhat.per.class) <- ylevs # } else if(NCOL(y) == 1) { # nlevs != NCOL(yhat)) # trace.response.type(trace, type, # observed="factor", # predicted="multicolumn numeric; ncol(predicted) != nlevels(observed)", # "each column of predicted response is a group") # for(iclass in seq_len(ncol(yhat))) # yhat.per.class[[iclass]] <- yhat[, iclass] # if(!is.null(colnames.yhat)) # names(yhat.per.class) <- colnames.yhat # else # names(yhat.per.class) <- paste0(type, "[,", seq_len(ncol(yhat)), "]") } else if(is.numeric(y) && NCOL(y) == NCOL(yhat)) { th <- get.thresh(y, "response") trace.response.type(trace, type, observed="multicolumn numeric", predicted= "multicolumn numeric with same number of columns as observed response", th$text.gt, "for each column of observed response") for(iclass in seq_len(ncol(yhat))) { yhat.per.class[[iclass]] <- yhat[y[,iclass] > th$thresh, iclass] check.min(yhat.per.class[[iclass]], th$text.gt) if(length(yhat.per.class[[iclass]]) == length(yhat[,iclass])) stop0("no occurrences of ", th$text.le, " in the observed response") } names(yhat.per.class) <- get.class.names(y, yhat, colnames.yhat, object$fitted.values) } else cannot.plot.this.response(y, yhat, colnames.yhat, type, nlevs, "Remedy: use the \"nresponse\" argument to select ", "just one column of the predicted response\n") } nchar <- max(nchar(names(yhat.per.class))) for(iclass in seq_along(yhat.per.class)) { # density needs numeric yhat.per.class[[iclass]] <- as.numeric(yhat.per.class[[iclass]]) if(trace >= 1) { trace2(trace, "\n") print_summary(yhat.per.class[[iclass]], sprint("predicted.response.per.class[%-*s]", nchar, names(yhat.per.class)[iclass]), trace=max(2, trace), details=if(trace>=2) 2 else 0) } } if(trace >= 1) cat("\n") yhat.per.class } get.plotd.data <- function(object, type, nresponse, trace, ...) { # TODO this routine is bit messy # if it were unified with plotmo_meta we would support more models # assignInMyNamespace("trace.call.global", trace) y <- get.observed.response(object) if(trace >= 2) { print_summary(y, "observed response", trace=2) trace2(trace, "\n") } yhat <- plotmo::plotmo_predict(object, newdata=NULL, nresponse=NULL, type, expected.levs=NULL, trace, ...)$yhat # assignInMyNamespace("trace.call.global", 0) if(is.character(yhat[,1])) { if(trace >= 1) printf("convert character yhat to factor\n") expected.levs <- plotmo::plotmo_resplevs(object, NULL, y, trace) yhat[,1] <- factor(yhat[,1], levels=expected.levs) } colnames.yhat <- colnames(yhat) if(!is.null(nresponse)) { nresponse <- plotmo::plotmo_nresponse(yhat, object, nresponse, trace, sprint("predict.%s", class(object)[1]), type) if(NCOL(yhat) > 1) { yhat <- yhat[, nresponse] if(is.data.frame(yhat)) # TODO needed for fda type="hier", why? yhat <- as.matrix(yhat) print_summary(yhat, paste("predict after selecting nresponse", nresponse), trace) trace2(trace, "\n") } } list(y = y, yhat = yhat, colnames.yhat = colnames.yhat, nresponse = nresponse) } # get the original observed response (it's needed to determine correct classes) get.observed.response <- function(object) { offset <- NULL if(!is.null(object$call$formula)) { # get y from formula and data used in original call data <- get.update.arg(NULL, "data", object, parent.frame(), FALSE) call <- object$call m <- match(c("formula", "data", "na.action", "offset", "subset"), names(call), 0) mf <- call[c(1, m)] mf[[1]] <- as.name("model.frame") mf <- eval(mf, model.env(object)) y <- model.response(mf, "any") # "any" means factors are allowed offset <- model.offset(mf) if(NCOL(y) == 1 && is.numlog(y)) { # turn into a matrix so we have the column name names(y) <- NULL # we don't need row names y <- as.matrix(y) colnames(y) <- colnames(mf)[attr(object$terms,"response")] } } else if(is.lda.or.qda(object)) { # hack for lda and qda, get grouping arg y <- eval(object$call[[3]], model.env(object)) # sanity check if(NCOL(y) != 1 || length(y) < 3 || (!is.numeric(y) && !is.factor(y))) stop0("cannot get \"grouping\" argument from object$call") } else y <- get.update.arg(NULL, "y", object, parent.frame(), trace1=FALSE, reeval=FALSE) if(!is.null(offset)) stop0("'offset' in formula is not yet supported by plotd") if(is.lda.or.qda(object)) y <- as.factor(y) # to make plotd handle response appropriately y } check.min <- function(x, ...) { len <- length(x) if(len == 0) warning0("no occurrences of ", paste0(...), " in the observed response") else if(len < 3) # 3 is arbitrary warning0("only ", len, " occurrences of ", paste0(...), " in the observed response") } get.binary.class.names <- function(yhat, colnames.yhat, fitted.values, last.resort) { if(!is.null(colnames.yhat)) c(paste("not", colnames.yhat[1]), colnames.yhat[1]) else if(!is.null(colnames(fitted.values))) c(paste("not", colnames(fitted.values)), colnames(fitted.values)) else last.resort } get.class.names <- function(y, yhat, colnames.yhat, fitted.values) { ynames <- paste0("response", seq_len(ncol(yhat))) if(length(colnames.yhat) == ncol(yhat)) class.names <- colnames.yhat else if(length(colnames(y)) == ncol(y)) class.names <- colnames(y) else if(length(fitted.values(y)) == fitted.values(y)) class.names <- colnames(y) else class.names <- ynames # fill in missing names, if necessary which. <- which(class.names == "") if(length(which.)) class.names[which.] <- ynames[which.] class.names } # return names1 but with yhat column names prefixed if necessary get.prefixed.names <- function(names1, yhat, colnames.yhat, nresponse) { stopifnot(NCOL(yhat) == 1) if(!is.null(colnames.yhat) && !is.null(nresponse)) names1 <- paste(colnames.yhat[nresponse], names1, sep=": ") names1 } # determine the threshold to split classes, a bit of a hack get.thresh <- function(y, yname) { thresh <- 0 ymin <- min(y) if(ymin == 1) thresh <- 1 if(!is.null(colnames(y))) yname <- colnames(y)[1] if(ymin == thresh) { text.le <- sprint("%s == %g", yname, thresh) text.gt <- sprint("%s != %g", yname, thresh) } else { text.le <- sprint("%s <= %g", yname, thresh) text.gt <- sprint("%s > %g", yname, thresh) } list(thresh=thresh, text.le=text.le, text.gt=text.gt) } cannot.plot.this.response <- function(y, yhat, colnames.yhat, type, nlevs, ...) { stop0("cannot plot this kind of response (with predict type=\"", type, "\")\n", ..., "Additional information:\n class(observed)=", class(y[1]), if(nlevs > 0) paste0(" nlevels(observed)=", nlevs) else "", " ncol(observed)=", NCOL(y), if(!is.null(colnames(y))) sprint(" colnames(observed) %s", paste.trunc(colnames(y))) else "", "\n class(predicted)=", class(yhat[,1])[1], " ncol(predicted)=", NCOL(yhat), if(!is.null(colnames.yhat)) sprint(" colnames(response) %s", paste.trunc(colnames.yhat)) else "") } trace.response.type <- function(trace, type, observed, predicted, ...) { if(trace >= 1) { trace2(trace, "\n") cat0("observed response: ", observed, "\n", "predicted response: ", predicted, " (predict type is \"", type, "\")\n", "grouping criterion: ", ..., "\n") } } draw.legend <- function(densities, degenerate, yhat.per.class, ymax, hist, xlim, col, fill, lty, legend.names, legend.pos, cex.legend, legend.bg, legend.extra) { get.legend.pos <- function() { # take a stab at positioning the legend correctly -- # on left or right, away from the highest peak pos <- c(0,ymax) pos[1] <- xlim[1] # place on left side of graph max.left <- 0 max.right <- 0 xmid <- xlim[1] + (xlim[2] - xlim[1])/2 for(iclass in seq_len(nclasses)) { if(!degenerate[iclass]) { den <- densities[[iclass]] if(hist) den$x <- den$x[-1] x.left <- (den$x >= xlim[1]) & (den$x <= xmid) if(sum(x.left)) max.left <- max(max.left, den$y[x.left]) x.right <- (den$x > xmid) & (den$x <= xlim[2]) if(sum(x.right)) max.right <- max(max.right, den$y[x.right]) } } if(max.right < max.left) pos[1] <- xlim[1] + (xlim[2] - xlim[1]) / 2.1 # slightly to left of center pos } #--- draw.legend starts here --- nclasses <- length(yhat.per.class) if(is.null(legend.pos)) legend.pos <- get.legend.pos() else if(length(legend.pos) == 1) legend.pos <- c(legend.pos, 0) if(length(legend.pos) != 2) stop0("length(legend.pos) != 2") if(is.null(legend.names)) legend.names <- names(yhat.per.class) if(length(legend.names) < nclasses) { warning0("length ", length(legend.names), " of legend.names ", "is less than the number ", nclasses, " of classes") legend.names <- repl(legend.names, nclasses) } else for(iclass in seq_len(nclasses)) if(degenerate[iclass]) legend.names[iclass] <- paste(legend.names[iclass], "(not plotted)") lwd <- repl(1, nclasses) # if the first histogram is filled in, then make its legend lwd bigger if(fill[1]==col[1] && fill[1] != "white" && fill[1] != 0) lwd[1] <- 4 if(legend.extra) legend.names <- paste0(legend.names, " (", sapply(yhat.per.class, length), " cases)") legend(x=legend.pos[1], y=legend.pos[2], legend=legend.names, cex=cex.legend, bg=legend.bg, lty=lty, lwd=lwd, col=col) } # shade the "error areas" of the density plots draw.err.col <- function(densities, thresh, col, border, lwd) { den1 <- densities[[1]] den2 <- densities[[2]] # is reducible error area to the left or to the right? # set iden=1 if to the left, iden=2 if to the right iden <- den1$y[den1$x >= thresh][1] > den2$y[den2$x >= thresh][1] if(anyNA(iden)) { # no overlap between classes? warning0("no overlap between (first two) classes, ignoring 'err.col' argument") return(NULL) } iden <- if(iden) 2 else 1 if(length(col) < 2) col[2] <- col[1] if(length(col) < 3) col[3] <- col[iden] if(length(border) < 2) border[2] <- border[1] if(length(border) < 3) border[3] <- border[iden] if(length(lwd) < 2) lwd[2] <- lwd[1] if(length(lwd) < 3) lwd[3] <- lwd[iden] if(is.specified(col[1]) || is.specified(border[1])) { # left side of threshold matches <- den2$x < thresh if(sum(matches)) { x <- c(den2$x[matches]) y <- c(den2$y[matches]) len <- length(x) x[len] <- thresh # close possible tiny gap x[len+1] <- thresh y[len+1] <- 0 polygon(x, y, col=col[1], border=border[1], lwd=lwd[1]) } } if(is.specified(col[2]) || is.specified(border[2])) { # right side of threshold matches <- den1$x > thresh if(sum(matches)) { x <- den1$x[matches] y <- den1$y[matches] x[1] <- thresh # close possible tiny gap len <- length(x) x[len+1] <- thresh y[len+1] <- 0 polygon(x, y, col=col[2], border=border[2], lwd=lwd[2]) } } if(is.specified(col[3]) || is.specified(border[3])) { if(iden == 1) { # reducible error, left side of threshold # get indices i1 of den1 and i2 of den2 where den1 crosses den2 i2 <- length(den2$x) for(i1 in length(den1$x):1) { while(i2 > 1 && den2$x[i2] > den1$x[i1]) i2 <- i2 - 1 if(den1$x[i1] <= thresh && den1$y[i1] >= den2$y[i2]) break } i1 <- den1$x <= thresh & (1:length(den1$x)) >= i1 i2 <- den2$x <= thresh & (1:length(den2$x)) >= i2 if(sum(i1) && sum(i2)) { # reverse i1 so polygon ends where it starts i1 <- rev(((1:length(den1$x))[i1])) # close tiny x gap to left of threshhold line den1$x[i1][1] <- thresh den2$x[i2][sum(i2)] <- thresh polygon(x = c(den1$x[i1], den2$x[i2]), y = c(den1$y[i1], den2$y[i2]), col=col[3], border=border[3], lwd=lwd[3]) } } else { # reducible error, right side of threshold # get indices i1 of den1 and i2 of den2 where den1 crosses den2 i2 <- 1 for(i1 in seq_along(den1$x)) { while(i2 < length(den2$x) && den2$x[i2] < den1$x[i1]) i2 <- i2 + 1 if(den1$x[i1] >= thresh && den2$y[i2] >= den1$y[i1]) break } i1 <- den1$x >= thresh & (1:length(den1$x)) < i1 i2 <- den2$x >= thresh & (1:length(den2$x)) < i2 if(sum(i1) && sum(i2)) { # reverse i2 so polygon ends where it starts i2 <- rev(((1:length(den2$x))[i2])) polygon(x = c(den1$x[i1], den2$x[i2]), y = c(den1$y[i1], den2$y[i2]), col=col[3], border=border[3], lwd=lwd[3]) } } } } earth/R/plot.earth.R0000644000176200001440000012235213441025555013772 0ustar liggesusers# plot.earth.R: plotting routines for the earth package plot.earth <- function(x = stop("no 'x' 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 and residuals nresponse = NA, # following are passed to plotres via plotres's dots col.cv = "lightblue", # following are passed to earth_plotmodsel via plotres's dots col.grsq = 1, col.rsq = 2, col.infold.rsq = 0, col.mean.infold.rsq = 0, col.mean.oof.rsq = "palevioletred", col.npreds = if(is.null(object$cv.oof.rsq.tab)) 1 else 0, col.oof.labs = 0, col.oof.rsq = "mistyrose2", col.oof.vline = col.mean.oof.rsq, col.pch.cv.rsq = 0, col.pch.max.oof.rsq = 0, col.vline = col.grsq, col.vseg = 0, lty.grsq = 1, lty.npreds = 2, lty.rsq = 5, lty.vline = "12", legend.pos = NULL, ...) { object.name <- quote.deparse(substitute(x)) object <- x remove(x) # prevent confusion with the x matrix check.classname(object, substitute(object), "earth") npoints <- dota("nresiduals", DEF=npoints, ...) # back compat col.rsq <- dota("col.line", DEF=col.rsq, ...) plotmo::plotres(object=object, which=which, info=info, versus=versus, standardize=standardize, delever=delever, level=level, id.n=id.n, labels.id=labels.id, smooth.col=smooth.col, grid.col=grid.col, jitter=jitter, do.par=do.par, caption=caption, trace=trace, npoints=npoints, center=center, type=type, # dec 2018 (was previously passed in dots) nresponse=nresponse, object.name=object.name, # following are passed to plotres via plotres's dots col.cv=col.cv, # following are passed to earth_plotmodsel w1.col.grsq = col.grsq, w1.col.rsq = col.rsq, w1.col.infold.rsq = col.infold.rsq, w1.col.mean.infold.rsq = col.mean.infold.rsq, w1.col.mean.oof.rsq = col.mean.oof.rsq, w1.col.npreds = col.npreds, w1.col.oof.labs = col.oof.labs, w1.col.oof.rsq = col.oof.rsq, w1.col.oof.vline = col.oof.vline, w1.col.pch.cv.rsq = col.pch.cv.rsq, w1.col.pch.max.oof.rsq = col.pch.max.oof.rsq, w1.col.vline = col.vline, w1.col.vseg = col.vseg, w1.lty.grsq = lty.grsq, w1.lty.npreds = lty.npreds, w1.lty.rsq = lty.rsq, w1.lty.vline = lty.vline, w1.legend.pos = legend.pos, ...) } # TODO add nresponse to plot.earth.models plot.earth.models <- function( x = stop("no 'x' argument"), which = c(1:2), caption = "", jitter = 0, col.grsq = discrete.plot.cols(length(objects)), lty.grsq = 1, col.rsq = 0, lty.rsq = 5, col.vline = col.grsq, lty.vline = "12", col.npreds = 0, lty.npreds = 2, legend.text = NULL, do.par = NULL, trace = 0, ...) { objects <- x remove(x) # prevent confusion with the x matrix if(!is.list(objects)) # note that is.list returns TRUE for a single object stop0("'x' is not an \"earth\" object or a list of \"earth\" objects") trace <- as.numeric(check.integer.scalar(trace, logical.ok=TRUE)) # check for a common error, using plot.earth.models(mod1, mod2) instead # of plot.earth.models(list(mod1, mod2)) instead if(inherits(which, "earth")) stop0("use plot.earth.models(list(model1, model2)), ", "not plot.earth.models(model1, model2)") if(typeof(objects[[1]]) != "list") # if user specified just one object, convert to list objects <- list(objects) check.index(which, "which", 1:2) show <- to.logical(which, 4) if(length(which) == 0) { warning0("plot.earth.models: nothing to plot (the 'which' argument is empty)") return(invisible()) } if(is.null(col.rsq)) col.rsq <- if(is.null(col.grsq)) col.rsq else col.grsq if(is.null(col.npreds)) col.npreds <- if(is.null(col.grsq)) col.rsq else col.grsq cum.col1 <- dota("cum.col col.cum pt.col col", ...) if(!is.specified(cum.col1)) cum.col1 <- if(!is.specified(col.grsq)) col.rsq else col.grsq if(show[1] && col.grsq[1] == 0 && col.rsq[1] == 0) stop0("both col.grsq[1] and col.rsq[1] are zero") if(show[2] && !is.specified(cum.col1)) stop0("cum.col is NULL, and unable to use col.grsq or col.rsq instead") nmodels <- length(objects) col.grsq <- repl(col.grsq, nmodels) lty.grsq <- repl(lty.grsq, nmodels) col.rsq <- repl(col.rsq, nmodels) lty.rsq <- repl(lty.rsq, nmodels) col.npreds <- repl(col.npreds, nmodels) lty.npreds <- repl(lty.npreds, nmodels) cum.col1 <- repl(cum.col1, nmodels) col.vline <- repl(col.vline, nmodels) lty.vline <- repl(lty.vline, nmodels) do.par <- check.do.par(do.par, length(which)) # 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 if(is.null(caption)) caption <- "" main <- dota("main", DEF="Model Comparison", ...) if(do.par) { oldpar <- par(no.readonly=TRUE) do.par(nfigs=length(which), caption=caption, main1=main, xlab1=NULL, ylab1=NULL, trace=trace, 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) } max.npreds <- 1 max.nterms <- 1 ylim <- dota("ylim", DEF=c(0,1), ...) for(imodel in seq_along(objects)) { object <- objects[[imodel]] check.classname(object, objects[[imodel]], "earth") ylim <- range(ylim, get.model.selection.ylim(object, ylim, col.grsq[imodel], col.rsq[imodel])) max.npreds <- max(max.npreds, get.nused.preds.per.subset(object$dirs, object$prune.terms)) max.nterms <- max(max.nterms, length(object$rss.per.subset)) } legend.col <- dota("legend.col col.legend", EX=c(0,1), DEF=1, NEW=1, ...) if(show[1]) { if(is.null(object$residuals)) # probably a model from object$cv.list stop0("earth object has no $residuals field.\n", " Use keepxy=TRUE in the call to earth.") for(imodel in seq_along(objects)) earth_plotmodsel( x = objects[[imodel]], col.rsq = col.rsq[imodel], col.grsq = col.grsq[imodel], col.infold.rsq = 0, col.mean.infold.rsq = 0, col.mean.oof.rsq = 0, col.npreds = col.npreds[imodel], col.oof.labs = 0, col.oof.rsq = 0, col.oof.vline = 0, col.pch.cv.rsq = 0, col.pch.max.oof.rsq = 0, col.vline = col.vline[imodel], col.vseg = col.grsq[imodel], lty.grsq = lty.grsq[imodel], lty.npreds = lty.npreds[imodel], lty.rsq = lty.rsq, lty.vline = lty.vline[imodel], legend.pos = NA, # we plot our own legend add = (imodel > 1), max.nterms = max.nterms, max.npreds = max.npreds, jitter = if(imodel>1) jitter else 0, # dots args main = if(imodel > 1) "" else main, ylim = ylim) if(is.specified(legend.col) && length(objects) > 1 && !show[2]) draw.earth.models.legend(objects, min.width=.4, legend.text, legend.col, col.rsq, lty.rsq, col.grsq, lty.grsq, ...) } if(show[2]) { multiple.responses <- FALSE xlim <- c(0,0) for(object in objects) { if(is.null(object$residuals)) # probably a model from object$cv.list stop0("earth object has no $residuals field.\n", " Use keepxy=TRUE in the call to earth.") if(NCOL(object$residuals) > 1) { multiple.responses <- TRUE xlim <- range(xlim, abs(object$residuals[,1]), na.rm=TRUE) } else xlim <- range(xlim, abs(object$residuals), na.rm=TRUE) } for(imodel in seq_along(objects)) { object <- objects[[imodel]] attr(object, ".Environment") <- get.model.env(object) rinfo <- plotmo::plotmo_rinfo(object, type="earth", residtype="earth", nresponse=NULL, trace=trace, leverage.msg="ignored") plotmo::plotmo_cum( rinfo = rinfo, info = FALSE, nfigs = 1, add = (imodel > 1), cum.col1 = if(length(cum.col1) > 1) cum.col1[imodel] else if(is.specified(col.grsq[imodel])) col.grsq[imodel] else col.rsq[imodel], grid.col = 0, jitter = if(imodel == 1) 0 else jitter, cum.grid = "none", # dots args xlim = xlim, main = if(imodel > 1) "" else if(multiple.responses) "Cumul Distrib (response 1)" else "Cumulative Distribution") } if(is.specified(legend.col) && length(objects) > 1) draw.earth.models.legend(objects, min.width=.5, legend.text, legend.col, col.rsq, lty.rsq, col.grsq, lty.grsq, ...) } draw.caption(caption, ...) invisible() } # Return a vector of n clearly distinguishable colors. # The first three are also distinguishable on (my) monochrome printer. discrete.plot.cols <- function(ncolors=5) { cols <- c(1, "brown", "gray60", "lightblue", "pink", "green") if(ncolors > length(cols)) # won't really be distinguishable cols <- c(cols, heat.colors(ncolors - length(cols))) cols[seq_len(ncolors)] } draw.earth.models.legend <- function( objects, min.width, legend.text, legend.col, col.rsq, lty.rsq, col.grsq, lty.grsq, ...) { lty <- NULL col <- NULL if(is.null(legend.text)) { if(is.null(names(objects))) { args <- get.arg.strings(objects, maxchars=20) legend.text <- character(length=length(objects)) for(imodel in seq_along(objects)) legend.text[imodel] <- paste(imodel, args[[imodel]]) } else legend.text <- names(objects) } else legend.text <- repl(legend.text, length(objects)) if(col.rsq[1] != 0) { # RSq plotted? col <- c(col, col.rsq) lty <- c(lty, repl(lty.rsq, length(col))) if(col.grsq[1] != 0) legend1 <- paste("RSq", legend.text) } if(col.grsq[1] != 0) { # GRSq plotted? col <- c(col, col.grsq) lty <- c(lty, repl(lty.grsq, length(col))) if(col.rsq[1] != 0) legend.text <- c(legend1, paste("GRSq", legend.text)) } legend.pos <- dota("legend.pos", DEF=NULL, ...) if(is.null(legend.pos)) { # auto? legend.x <- "bottomright" 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.cex <- get.earth.legend.cex(legend.text, min.width=min.width, ...) elegend(x=legend.x, y=legend.y, bg="white", legend=legend.text, col=col, lty=lty, cex=legend.cex, # y offset allows vertical lines to be visible below legend inset=c(.02, .04)) } # called by plotres for which=1, and called by plot.earth.models earth_plotmodsel <- function( x, col.rsq = 2, col.grsq = 1, col.infold.rsq = 0, col.mean.infold.rsq = 0, col.mean.oof.rsq = "palevioletred", col.npreds = NULL, col.oof.labs = 0, col.oof.rsq = "mistyrose2", col.oof.vline = col.mean.oof.rsq, col.pch.cv.rsq = 0, col.pch.max.oof.rsq = 0, col.vline = col.grsq, col.vseg = 0, lty.grsq = 1, lty.npreds = 2, lty.rsq = 5, lty.vline = "12", legend.pos = NULL, add = FALSE, jitter = 0, max.nterms = length(object$rss.per.subset), max.npreds = max(1, get.nused.preds.per.subset(object$dirs, object$prune.terms)), ...) { possibly.issue.cv.warning <- function() { if((!identical(col.mean.oof.rsq, "palevioletred") && !is.zero(col.mean.oof.rsq)) || (!identical(col.oof.rsq, "mistyrose2") && !is.zero(col.oof.rsq)) || !is.zero(col.oof.labs) || !is.zero(col.pch.max.oof.rsq) || !is.zero(col.pch.cv.rsq) || !is.zero(col.mean.infold.rsq) || !is.zero(col.infold.rsq)) { # user specifed a cross-validation argument, check that data is available if(is.null(object$cv.list)) warning0("no cross-validation data because nfold not used in original call to earth") else if(is.null(object$cv.oof.rsq.tab)) warning0("cannot plot cross-validation data because ", "the earth model was not built with keepxy=TRUE") } } scale1 <- function(x, Min, Max) { return((x-Min)/(Max-Min)) } left.axis <- function() { pretty <- pretty(c(ylim[1], ylim[2])) axis(side=2, at=scale1(pretty, ylim[1], ylim[2]), labels=pretty, srt=90) text <- "" if(is.specified(col.grsq)) text <- "GRSq" if(is.specified(col.rsq) || is.specified(col.oof.rsq) || is.specified(col.mean.oof.rsq) || is.specified(col.infold.rsq) || is.specified(col.mean.infold.rsq)) text <- paste0(text, " RSq") # TODO mtext needs cex=par("cex"), not sure why # the line setting depends on the axis margin lines (want # compact axes if do.par set, but not compact if not set) mtext(text, side=2, cex=par("cex"), line=if(par("mgp")[1] < 1.8) 1.6 else 2) } right.axis <- function() { if(max.npreds <= 5) # try to get rid of fractions in the label pretty <- pretty(c(0, max.npreds), n=max.npreds) else pretty <- pretty(c(0, max.npreds)) axis(side=4, at=scale1(pretty, 0, max.npreds), labels=pretty, srt=90) mtext("Number of used predictors", side=4, cex=par("cex"), line=if(par("mgp")[1] < 1.8) 1.4 else 1.8) } draw.selection.grid <- function() # plot the grid { if(!is.specified(grid.col)) return() col <- grid.col[1] abline(v=0:par("usr")[2], col=col) # vertical grid if((ylim[2] - ylim[1]) > .5) # coarse horizontal grid? for(v in seq(-1, 1, by=.05)) abline(h=scale1(v, ylim[1], ylim[2]), col=col, lwd=1) else { # fine horizontal grid for(v in seq(-1, 1, by=.01)) abline(h=scale1(v, ylim[1], ylim[2]), col=col, lwd=.6) for(v in seq(-1, 1, by=.05)) abline(h=scale1(v, ylim[1], ylim[2]), col=col, lwd=1.2) } } draw.infold.rsqs <- function() # plot rsq's measured on the in-fold data { if(!is.specified(col.infold.rsq)) return() # recycle col.infold.rsq so can use different colors for different folds col.infold.rsq <- repl(col.infold.rsq, length(object$cv.list)) for(ifold in seq_along(object$cv.list)) { infold.rsq <- object$cv.infold.rsq.tab[ifold,] if(jitter > 0) infold.rsq <- jitter(infold.rsq, amount=jitter) scaled.rsq <- scale1(infold.rsq, ylim[1], ylim[2]) lines(scaled.rsq, col=col.infold.rsq[ifold], lty=1) } } draw.oof.rsqs <- function() # plot rsq's measured on the out-of-fold data { if(!is.specified(col.oof.rsq)) return() # recycle col.oof.rsq so user can specify different colors for different folds col.oof.rsq <- repl(col.oof.rsq, length(object$cv.list)) for(ifold in seq_along(object$cv.list)) { oof.rsq <- object$cv.oof.rsq.tab[ifold,] if(jitter > 0) oof.rsq <- jitter(oof.rsq, amount=jitter) scaled.rsq <- scale1(oof.rsq, ylim[1], ylim[2]) lines(scaled.rsq, col=col.oof.rsq[ifold], lty=1) } if(is.specified(col.oof.labs)) { col.oof.labs <- repl(col.oof.labs, length(object$cv.list)) x <- y <- labs <- NULL usr <- par("usr") # xmin, xmax, ymin, ymax for(ifold in seq_along(object$cv.list)) { oof.rsq <- object$cv.oof.rsq.tab[ifold,] oof.rsq <- oof.rsq[!is.na(oof.rsq)] # truncate NAs scaled.rsq <- scale1(oof.rsq, ylim[1], ylim[2]) y <- c(y, scaled.rsq[min(usr[2], length(oof.rsq))]) x <- c(x, min(usr[2]-.1, length(oof.rsq)+.2)) labs <- c(labs, substr(names(object$cv.list)[ifold], 5, 15)) } cex <- .6 text(x=x, y=TeachingDemos::spread.labs(y, mindiff=1.2 * strheight("X")), labels=labs, cex=cex, col=col.oof.labs[ifold], xpd=NA) } if(is.specified(col.pch.max.oof.rsq) || is.specified(col.pch.cv.rsq)) { for(ifold in seq_along(object$cv.list)) { oof.rsq <- object$cv.oof.rsq.tab[ifold,] scaled.rsq <- scale1(oof.rsq, ylim[1], ylim[2]) # show the max oof.rsq for this fold nterms <- which.max(oof.rsq) points(nterms, scale1(oof.rsq, ylim[1], ylim[2])[nterms], pch=1, col=col.pch.max.oof.rsq) # show the position of the cv.rsq's nterms <- length(object$cv.list[[ifold]]$selected.terms) points(nterms, scale1(oof.rsq, ylim[1], ylim[2])[nterms], pch=20, col=col.pch.cv.rsq, cex=.7) } } } draw.unused.preds <- function() # plot nbr of used predictors { # nothing actually plotted if col.npreds=0 nused.preds <- get.nused.preds.per.subset(object$dirs, object$prune.terms) nused.preds.vec <- scale1(nused.preds, 0, max.npreds) if(jitter > 0) # 2*jitter seems to work better relative to jitter on GRSq nused.preds.vec <- jitter(nused.preds.vec, amount=2*jitter) else { # nudge max value to prevent overplot of maximum RSq(s) max <- max(nused.preds.vec) nused.preds.vec[nused.preds.vec == max] <- max + max / 150 } lines(nused.preds.vec, type="l", col=col.npreds, lty=lty.npreds) } draw.vline.at.max.mean.oof.rsq <- function() { if(!is.specified(col.mean.oof.rsq) || !is.specified(col.oof.vline)) return() x <- xnudge <- which.max(mean.oof.rsq.per.subset) # possibly nudge right to prevent overplot of grsq.line if(x == which.min(object$gcv.per.subset)) xnudge <- xnudge + nterms.on.horiz.axis / 150 # possibly nudge to prevent overplot of grid if(is.specified(grid.col)) xnudge <- xnudge + nterms.on.horiz.axis / 150 abline(v=xnudge, col=col.oof.vline, lty="12", lwd=1.2) } show.max.mean.oof.rsq <- function() { if(!is.specified(col.mean.oof.rsq) || !is.specified(col.oof.vline)) return() x <- which.max(mean.oof.rsq.per.subset) if(which.min(object$gcv.per.subset) == x) return() # don't overplot (see show.max.grsq) usr <- par("usr") text.on.white(x, usr[3] + strheight("X"), x, cex=.8, col=col.oof.vline, xmar=.05) } draw.mean.infold.rsq <- function() { if(!is.specified(col.mean.infold.rsq)) return() lines(scale1(mean.infold.rsq.per.subset, ylim[1], ylim[2]), col=col.mean.infold.rsq, lwd=lwd) } draw.mean.oof.rsq <- function() { if(!is.specified(col.mean.oof.rsq)) return() lines(scale1(mean.oof.rsq.per.subset, ylim[1], ylim[2]), col=col.mean.oof.rsq, lwd=lwd) } draw.rsq <- function() { if(jitter > 0) rsq.vec <- jitter(rsq.vec, amount=jitter) lines(scale1(rsq.vec, ylim[1], ylim[2]), col=col.rsq, lty=lty.rsq) } draw.grsq <- function() { if(jitter > 0) grsq.vec <- jitter(grsq.vec, amount=jitter) y <- scale1(grsq.vec, ylim[1], ylim[2]) lines(y, col=col.grsq, lwd=lwd) # if pmethod=="cv", draw a circle at the selected model if(object$pmethod=="cv" && !is.null(mean.oof.rsq.per.subset)) { x <- length(object$selected.terms) points(x, y[x], col=col.grsq, lwd=lwd, pch=1) } } draw.vline.at.max.grsq <- function() { if(!is.specified(col.vline)) return() x <- xnudge <- which.min(object$gcv.per.subset) # possibly nudge to prevent overplot of grid if(is.specified(grid.col)) xnudge <- xnudge + nterms.on.horiz.axis / 150 abline(v=xnudge, col=col.vline, lty=lty.vline, lwd=1.2) # possibly plot a colored marker at the top of the above line # (this is used by plot.earth.models when plotting multiple models) if(is.specified(col.vseg)) points(x=xnudge, y=1.02, col=col.vseg, pch=6) } show.max.grsq <- function() { if(!is.specified(col.vline) || is.specified(col.vseg)) return() x <- which.min(object$gcv.per.subset) usr <- par("usr") text.on.white(x, usr[3] + strheight("X"), x, cex=.8, col=col.vline, xmar=.05) } draw.vline.at.max.nterms <- function() { if(object$pmethod != "none" || !is.specified(col.vline)) return() # nrow(object$prune.terms) is nk x <- xnudge <- nrow(object$prune.terms) # possibly nudge to prevent overplot of grid if(is.specified(grid.col)) xnudge <- xnudge + nterms.on.horiz.axis / 150 # possibly nudge to prevent overplot of max.grsq line if(which.min(object$gcv.per.subset) == x) xnudge <- xnudge + nterms.on.horiz.axis / 150 abline(v=xnudge, col=col.vline, lty=2, lwd=1.2) } show.max.nterms <- function() { if(object$pmethod != "none" || !is.specified(col.vline)) return() x <- nrow(object$prune.terms) if(which.min(object$gcv.per.subset) == x || (!is.null(mean.oof.rsq.per.subset) && which.max(mean.oof.rsq.per.subset) == x)) { # don't overplot (see show.max.grsq and show.max.mean.oof.rsq) return() } usr <- par("usr") text.on.white(x, usr[3] + strheight("X"), x, cex=.8, col=col.vline, , xmar=.05) } draw.legend <- function(...) { # return TRUE if "over" lines obscure "under" lines is.obscured <- function(under, over) { len <- min(length(under), length(over)) under <- under[1:len] over <- over[1:len] i <- under >= ylim[1] & under <= ylim[2] i[is.na(under) | is.na(over)] <- FALSE # ignore NAs nobscured <- sum(abs(under[i] - over[i]) < (ylim[2] - ylim[1]) / 100) nobscured > .8 * sum(i) } update.legend <- function(text, col=1, lty=1, lwd=1, vert=FALSE, pch=NA) { if(is.null(legend.text)) { # first time? if(text == "") # spacer between entries? return() # ignore space when first entry legend.text <<- text # note <<- not <- legend.col <<- col legend.lty <<- lty.as.char(lty) legend.lwd <<- lwd legend.vert <<- vert legend.pch <<- pch } else { legend.text <<- c(legend.text, text) legend.col <<- c(legend.col, col) legend.lty <<- c(legend.lty, lty.as.char(lty)) legend.lwd <<- c(legend.lwd, lwd) legend.vert <<- c(legend.vert, vert) legend.pch <<- c(legend.pch, pch) } } #--- draw.legend starts here # The is.obscured code assumes that plot order is rsq, mean.oof.rsq, grsq. # Obscuring of or by infold.rsq is not yet handled. if(!is.null(legend.pos) && !is.specified(legend.pos)) return() legend.text <- legend.col <- legend.lty <- legend.lwd <- NULL legend.vert <- legend.pch <- NULL full.model <- if(show.cv.data) " (full model)" else "" if(is.specified(col.vline) && object$pmethod == "none") { update.legend("selected model (pmethod=none)", col.vline, lty=2, lwd=1.2, vert=TRUE) update.legend("", 0) # dummy entry to leave a vertical space } if(is.specified(col.grsq)) update.legend(paste0("GRSq", full.model), lwd=lwd) if(is.specified(col.vline)) update.legend( if(object$pmethod != "none" && object$pmethod != "cv") "selected model" else "max GRSq", col.vline, lty.vline, lwd=1.2, vert=TRUE) if(is.specified(col.rsq)) { RSq.string <- if(show.cv.data) "RSq (full model)" else "RSq" if(is.specified(col.grsq) && is.obscured(rsq.vec, grsq.vec)) text <- paste0(RSq.string, " (obscured)") else if(is.specified(col.mean.oof.rsq) && is.obscured(rsq.vec, mean.oof.rsq.per.subset)) text <- paste0(RSq.string, " (obscured)") else text <- RSq.string update.legend(text, col.rsq, lty.rsq) } added.space <- FALSE # We draw the infold legend above the oof legend because the infold # curves are usually above the oof curves. if(is.specified(col.mean.infold.rsq)) { text <- "mean in-fold RSq" update.legend("", 0) # dummy entry to leave a vertical space added.space <- TRUE update.legend(text, col.mean.infold.rsq, lwd=lwd) } if(is.specified(col.infold.rsq)) { if(!added.space) update.legend("", 0) # dummy entry to leave a vertical space update.legend("in-fold RSq", col.infold.rsq[1]) } if(is.specified(col.mean.oof.rsq)) { if(is.specified(col.grsq) && is.obscured(mean.oof.rsq.per.subset, grsq.vec)) text <- "mean out-of-fold RSq (obscured)" else text <- "mean out-of-fold RSq" update.legend("", 0) # dummy entry to leave a vertical space added.space <- TRUE update.legend(text, col.mean.oof.rsq, lwd=lwd) if(is.specified(col.oof.vline)) update.legend("max mean out-of-fold RSq", col.oof.vline, lty="12", lwd=1.2, vert=TRUE) } if(is.specified(col.oof.rsq)) { if(!added.space) update.legend("", 0) # dummy entry to leave a vertical space update.legend("out-of-fold RSq", col.oof.rsq[1]) } if(is.specified(col.npreds)) { if(added.space) update.legend("", 0) # dummy entry to leave a vertical space update.legend(paste0("nbr preds", full.model), col.npreds, lty.npreds) } if(is.specified(col.oof.vline) && object$pmethod == "cv") update.legend("selected model", col=col.grsq, lty=NA, lwd=lwd, pch=1) legend.cex <- get.earth.legend.cex(legend.text, ...) legend.inset <- 0 if(is.null(legend.pos)) { # auto? if(max.nterms == 2) { legend.x <- "topleft" legend.inset <- c(.02, .02) } else { legend.x <- "bottomright" # legend y offset allows vertical lines and text to be visible below legend legend.inset <- c(.02, max(.05, 2 * strheight("X"))) } legend.y <- NULL } else { # user specified legend position legend.x <- legend.pos[1] legend.y <- NULL if(length(legend.pos) == 1) # presumably something like "topright" legend.inset <- c(.02, .02) else legend.y <- scale1(legend.pos[2], ylim[1], ylim[2]) } usr <- par("usr") # xmin, xmax, ymin, ymax if(max.nterms == 1) text.on.white(usr[1] + 2 * strwidth("X"), usr[4] - 2 * strheight("X"), "intercept-only model", adj=0) else if(!is.null(object$nprune)) text.on.white(usr[1] + .5 * strwidth("X"), usr[4] - .6 * strheight("X"), paste0("nprune ", object$nprune), adj=0, cex=.8 * par("cex")) elegend(x=legend.x, y=legend.y, bg="white", legend=legend.text, col=legend.col, lty=legend.lty, lwd=legend.lwd, vert=legend.vert, pch=legend.pch, cex=legend.cex, xpd=NA, inset=legend.inset) } #--- earth_plotmodsel starts here --- object <- x remove(x) # prevent confusion with the x matrix main <- dota("main", ...) if(!is.specified(main)) main <- if(NCOL(object$residuals) > 1) "Model Selection (all responses)" else "Model Selection" stopifnot.string(main, allow.empty=TRUE) if(is.null(object$prune.terms)) { # no prune data? if(!add) plot(c(0,1), col=0, xlab="", ylab="", main=main) legend(x=1, y=1, bty="n", legend=c("No model selection data", "", "Run update.earth() to generate", "model selection data")) return(NULL) } check.numeric.scalar(jitter) stopifnot(jitter >= 0) if(jitter > .1) stop0("'jitter' ", jitter , " is too big, try something like jitter=0.01") if(!is.specified(lty.grsq)) col.grsq <- 0 if(!is.specified(lty.rsq)) col.rsq <- 0 if(!is.specified(lty.npreds)) col.npreds <- 0 if(!is.specified(lty.vline)) col.vline <- 0 grid.col <- dota("grid.col col.sel.grid", ...) ylim <- get.model.selection.ylim(object, ylim=dota("ylim", DEF=NULL, ...), col.grsq=1, col.rsq, col.mean.oof.rsq, col.oof.rsq, col.mean.infold.rsq, col.infold.rsq) possibly.issue.cv.warning() if(is.null(object$cv.oof.rsq.tab)) # if no cv data available, force no display of cv data col.mean.oof.rsq <- col.oof.rsq <- col.mean.infold.rsq <- col.infold.rsq <- 0 show.cv.data <- is.specified(col.mean.oof.rsq) || is.specified(col.oof.rsq) || is.specified(col.mean.infold.rsq) || is.specified(col.infold.rsq) show.non.cv.data <- is.specified(col.grsq) || is.specified(col.rsq) || is.specified(col.npreds) if(is.null(col.npreds)) # by default, show npreds if not show cv data col.npreds <- if(show.cv.data) 0 else 1 rsq.vec <- get.rsq(object$rss.per.subset, object$rss.per.subset[1]) grsq.vec <- get.rsq(object$gcv.per.subset, object$gcv.per.subset[1]) mean.oof.rsq.per.subset <- NULL if(is.specified(col.mean.oof.rsq)) mean.oof.rsq.per.subset <- object$cv.oof.rsq.tab[nrow(object$cv.oof.rsq.tab),] if(is.specified(col.mean.infold.rsq)) mean.infold.rsq.per.subset <- object$cv.infold.rsq.tab[nrow(object$cv.infold.rsq.tab),] lwd <- if(show.cv.data) 2 else 1 # want fat non-cv lines if plotting cv data nterms.on.horiz.axis <- max.nterms if(show.cv.data && !show.non.cv.data) nterms.on.horiz.axis <- min(nterms.on.horiz.axis, get.max.terms.of.fold.models(object)) if(!add) { old.mar <- par("mar") if(is.specified(col.npreds) && old.mar[4] < 3.5) { # ensure right margin big enough for right axis on.exit(par(mar=old.mar)) par(mar=c(old.mar[1:3], 3.5)) } xlim <- get.model.selection.xlim(object, dota("xlim", ...), mean.oof.rsq.per.subset, col.mean.oof.rsq, col.oof.vline) # set up so vertical scale is 0..1, horizontal is 0..nterms.on.horiz.axis plot(0:nterms.on.horiz.axis, (0:nterms.on.horiz.axis)/nterms.on.horiz.axis, type="n", main=main, xlab="Number of terms", xaxt="n", ylab="", yaxt="n", xlim=xlim) # bottom axis (use xaxp to limit the number of ticks to avoid ".5" ticks) if(xlim[2] < 5) axis(1, xaxp=c(xlim[1], xlim[2], xlim[2])) else axis(1) left.axis() if(is.specified(col.npreds)) right.axis() draw.selection.grid() } # note: if you change the plot order here, modify is.obscured code in draw.legend draw.infold.rsqs() draw.oof.rsqs() draw.unused.preds() draw.vline.at.max.grsq() draw.vline.at.max.mean.oof.rsq() draw.vline.at.max.nterms() draw.rsq() draw.mean.infold.rsq() draw.mean.oof.rsq() draw.grsq() show.max.grsq() show.max.mean.oof.rsq() show.max.nterms() draw.legend(...) } # Note: there is no string line type corresponding to 1, so this # converts 1 to "1" which is an illegal lty, so must be specially # handled in functions which use the lty string. lty.as.char <- function(lty) { char <- lty if(anyNA(lty)) char <- "NA" else if(is.numeric(lty)) { char <- NULL tab <- c("1", "44", "13", "1343", "73", "2262") # from par man page stopifnot(length(lty) > 0) for(i in seq_along(lty)) { stopifnot(lty[i] >= 1, lty[i] <= length(tab)) char <- c(char, tab[lty[i]]) } } char } get.earth.legend.cex <- function(legend.text, min.width=.4, min.cex=.4, ...) { cex <- dota("legend.cex cex.legend", EX=c(0,1), NEW=1, ...) if(anyNA(cex)) { longest.text <- legend.text[which.max(strwidth(legend.text))] longest.text <- paste0("AAAAAA ", longest.text) # incorporate line on left of legend # reduce cex until legend fits, but not more than min.cex cex <- .8 while((width <- max(strwidth(longest.text, units="figure", cex=cex))) > min.width && cex > min.cex) cex <- cex - .1 } cex } get.model.selection.xlim <- function(object, xlim, mean.oof.rsq.per.subset, col.mean.oof.rsq, col.oof.vline) { if(!is.specified(xlim)) { # not specified by the user? nk <- nrow(object$dirs) xmax <- 2 * which.min(object$gcv.per.subset) # nbr terms selected by GCV if(object$pmethod == "none") xmax <- max(xmax, nk) # if cross-validation vert line is plotted, include that too # following "if" matches that in draw.vline.at.max.mean.oof.rsq if(!is.null(mean.oof.rsq.per.subset) && is.specified(col.mean.oof.rsq) && is.specified(col.oof.vline)) xmax <- max(xmax, which.max(mean.oof.rsq.per.subset)) xlim <- c(0, min(xmax + 3, nk)) } xlim } # check ylim specified by user, and convert special values in ylim to actual vals get.model.selection.ylim <- function(object, ylim, col.grsq, col.rsq, col.mean.oof.rsq=0, col.oof.rsq=0, col.mean.infold.rsq=0, col.infold.rsq=0) { get.fold.min.max <- function() { min <- Inf max <- -Inf if(!is.null(object$cv.oof.rsq.tab) && (is.specified(col.mean.oof.rsq) || is.specified(col.oof.rsq))) { # will be plotting oof.rsq, so must adjust axis limits for that min <- min(object$cv.oof.rsq.tab[,-1], na.rm=TRUE) # -1 to ignore intercept-only model max <- max(object$cv.oof.rsq.tab[,-1], na.rm=TRUE) # prevent outrageous axis scales caused by wayward cross-validation results max <- min(max, 2 * max(rsq)) # 2 is arb min <- max(min, -3) # -3 is arb } if(!is.null(object$cv.infold.rsq.tab) && (is.specified(col.mean.infold.rsq) || is.specified(col.infold.rsq))) { min <- min(min, object$cv.infold.rsq.tab[,-1], na.rm=TRUE) max <- max(max, object$cv.infold.rsq.tab[,-1], na.rm=TRUE) max <- min(max, 2 * max(rsq)) min <- max(min, -3) } list(min=min, max=max) } #--- get.model.selection.ylim starts here --- if(is.null(ylim)) ylim <- c(-1, -1) if(length(ylim) != 2) stop0("length(ylim) != 2") if(ylim[2] <= ylim[1] && ylim[2] != -1) stop0("ylim[2] <= ylim[1]") if(ylim[1] < -1 || ylim[1] > 1 || ylim[2] < -1 || ylim[2] > 1) stop0(paste0( "illegal ylim=c(", ylim[1], ",", ylim[2], ") in the earth model selection plot\n", "Allowed settings are from -1 to 1, with special values:\n", " ylim[1] = -1 means use min(RSq, GRSq)\n", " ylim[2] = -1 means use max(RSq, GRSq)\n")) if(ylim[1] == -1 || ylim[2] == -1) { grsq <- NULL if(is.specified(col.grsq)) grsq <- get.rsq(object$gcv.per.subset, object$gcv.per.subset[1]) rsq <- get.rsq(object$rss.per.subset, object$rss.per.subset[1]) temp <- get.fold.min.max() if(!is.specified(col.rsq)) rsq <- NULL if(ylim[1] == -1) { ylim[1] <- min(grsq[-1], rsq[-1], temp$min, na.rm=TRUE) # small model, treat specially so user sees context if(length(object$rss.per.subset) <= 3) ylim[1] <- min(0, ylim[1]) ylim[1] <- max(-1, ylim[1]) # clamp minimum ylim at -1 } if(ylim[2] == -1) ylim[2] <- max(grsq, rsq, temp$max, na.rm=TRUE) } # following code gives a decent y axis even with an intercept-only model if(abs(ylim[1] - ylim[2]) < 1e-6) ylim[2] <- ylim[1] + 1 ylim } get.max.terms.of.fold.models <- function(object) { tab <- object$cv.oof.rsq.tab stopifnot(!is.null(tab)) stopifnot(nrow(tab) > 1) max.terms <- 0 for(i in 1:(nrow(tab)-1)) # -1 to skip last (summary) row max.terms <- max(max.terms, sum(!is.na(tab[i,]))) max.terms } # Given a list of objects, return a vector of strings. Each string shows where # the $call argument of the object differs from the call of the first object. # (Thus the first object is used as a reference). get.arg.strings <- function( objects, # list of objects with $call arguments maxchars=16) { # the gsub discards white space and the final ")" get.call <- function(iobj) gsub("[ \t\n)]", "", paste.collapse(format(objects[[iobj]]$call))) stopifnot(length(objects) > 0) call <- get.call(1) if(length(objects) == 1) return(substr(call, 1, maxchars)) call2 <- get.call(2) i <- first.non.matching.arg(call, call2) if(i == 0) rval <- c("", "") else rval <- c(substr(call, i, i+maxchars), substr(call2, i, i+maxchars)) if(length(objects) > 2) for(iobj in 3:(length(objects))) { call2 <- get.call(iobj) i <- first.non.matching.arg(call, call2) rval <- c(rval, if(i==0) "" else substr(call2, i, i+maxchars)) } rval } # Return the position of the first non matching arg between two function call strings. # # More precisely, find the first non matching characters in s1 and s2. # When it is found, step back until a comma or "(" is found. # Return the index of the character after the comma or "(". # # Example: s1 = lm(formula=O3~.,data=ozone # s2 = lm(formula=O3~.-wind,data=ozone # # return index of "formula=O3~.-wind,data=ozone" # because formula is the first argument with a differing argument first.non.matching.arg <- function(s1, s2) { len <- min(nchar(s1), nchar(s2)) if(len == 0) return(0) for(i in 1:len) if(substr(s1, i, i) != substr(s2, i, i)) break if(i == len || i == 1) # no difference or all different? return(1) while(i >= 1 && substr(s2, i, i) != "," && substr(s2, i, i) != "(") i <- i - 1 # move backwards to character following comma or "(" return(i+1) } earth/R/earth.leaps.R0000644000176200001440000003174413561344531014125 0ustar liggesusers# earth.leaps.R: # # Copied from Thomas Lumley's leaps 2.9 package for earth 3.2-6 to avoid # use of leaps::: in the earth code, to prevent complaints from CRAN check. # leaps.setup is modified to handle linear dependencies in x properly. I think # this fix is needed only if leaps.setup is called with intercept=FALSE. # # The fix is needed because if there are linear dependencies in the matrix # x passed to the original leaps.setup, it gives an incorrect error # message: "missing value where TRUE/FALSE needed". # # In the earth context, this happened if you call earth.update with new # data and the bx generated from that data has linear dependencies (which # is actually ok). # # I also touched up the warning messages to be more informative, # and changed most warning messages to stop messages. leaps.setup<-function(x,y,wt=rep(1,length(y)),force.in=NULL, force.out=NULL,intercept=TRUE, nvmax=8,nbest=1,warn.dep=TRUE){ make.names<-function(np){ if (np<27) letters[1:np] else as.character(1:np) } np<-NCOL(x) nn<-NROW(x) if (length(y)!=nn) stop("y and x different lengths") if (length(wt)!=nn) stop("wt and x different lengths") if (is.null(colnames(x))) colnames(x)<-make.names(np) index<-rep(0,np) names(index)<-colnames(x) index[force.in]<--1 if (any(index[force.out]==-1)) stop("Can't force the same variable in and out") index[force.out]<-1 force.in<-(index==-1) ## make force.in, force.out logical vectors force.out<-(index==1) ii<-order(index) xx<-x[,ii] force.in<-force.in[ii] force.out<-force.out[ii] ones<-rep(1,np) names(ones)<-colnames(x) first<-1+sum(ones[force.in]) last<-np-sum(ones[force.out]) nvmax<-min(nvmax,np) if (intercept){ np<-np+1 xnames<-c("(Intercept)",colnames(xx)) xx<-cbind(1,xx) colnames(xx)<-xnames first<-first+1 last<-last+1 nvmax<-nvmax+1 index<-c(-1,index) } vorder<-1:np il<-nvmax*(nvmax+1)/2 nrbar<-np*(np-1)/2 qrleaps<-.Fortran("makeqr",np=as.integer(np),nn=as.integer(nn), wt=as.double(wt),tx=t(xx),y=as.double(y),d=numeric(np), rbar=numeric(nrbar), thetab=numeric(np),sserr=numeric(1),ier=as.integer(0), PACKAGE="earth") if (qrleaps$ier!=0) stopf("Fortran routine MAKEQR returned error code 0x%4.4X", qrleaps$ier) qrleaps$tx<-NULL qrleaps$wt<-NULL tolset<-.Fortran("tolset",as.integer(np), as.integer(nrbar),qrleaps$d,qrleaps$rbar, tol=numeric(np),numeric(np),ier=as.integer(0), PACKAGE="earth") if (tolset$ier!=0) stopf("Fortran routine TOLSET returned error code 0x%4.4X", tolset$ier) ss<-.Fortran("ssleaps",as.integer(np),qrleaps$d, qrleaps$thetab,qrleaps$sserr,rss=numeric(np), ier=as.integer(0), PACKAGE="earth") if (ss$ier!=0) stopf("Fortran routine SSLEAPS returned error code 0x%4.4X", ss$ier) sing<-.Fortran("sing",np=as.integer(qrleaps$np),nrbar=as.integer(nrbar), d=qrleaps$d,rbar=qrleaps$rbar,thetab=qrleaps$thetab, sserr=qrleaps$sserr,tol=tolset$tol,lindep=integer(qrleaps$np), work=numeric(qrleaps$np),ier=as.integer(0), PACKAGE="earth") if (sing$ier>0) stopf("Fortran routine SING returned error code 0x%4.4X", sing$ier) sing$lindep <- as.logical(sing$lindep) # from integer (0 or 1) to logical sing$work<-NULL if(any(sing$lindep)) { # linear dependencies in x? (should never happen with earth bx) if (intercept) { new.force.out <- sing$lindep | c(FALSE,force.out) reordered.col.nbrs <- order(new.force.out[-1]) # put lin dep cols at end try.again <- any((c(new.force.out,1) - c(0,new.force.out)) < 0) # huh? lindep.in.force.in <- any(sing$lindep[-1] & force.in) colnames.with.intercept <- c("(Intercept)", colnames(x)) } else { new.force.out <- sing$lindep | force.out reordered.col.nbrs <- order(new.force.out) try.again <- any((c(new.force.out,1) - c(0,new.force.out)) < 0) lindep.in.force.in <- any(sing$lindep & force.in) colnames.with.intercept <- colnames(x) } if (warn.dep) { nsingular <- sum(sing$lindep) warning0("In leaps.setup, ", if(try.again) "discarding " else "", if(nsingular > 1) paste0(nsingular, " linearly dependent variables: ") else "linearly dependent variable: ", paste(colnames.with.intercept[sing$lindep], collapse=", ")) } if (lindep.in.force.in) stop("Linear dependency in force.in variable(s)") if (try.again) { # recursive call rval<-leaps.setup(x[,ii[reordered.col.nbrs],drop=FALSE], y, wt, force.in[reordered.col.nbrs], force.out[reordered.col.nbrs], intercept, nvmax, nbest, warn.dep=FALSE) rval$reorder<-ii[reordered.col.nbrs] return(rval) } lastsafe<-max((1:np)[!new.force.out]) if (lastsafe 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") } } earth/R/elegend.R0000644000176200001440000002700113440633426013311 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))) } earth/R/plotmo.methods.earth.R0000644000176200001440000001270513443036072015766 0ustar liggesusers# plotmo.rpart.R: plotmo methods for earth objects plotmo.singles.earth <- function(object, x, nresponse, trace, all1, ...) { if(all1) # user wants all used predictors, not just those in degree1 terms? return(seq_len(NCOL(x))) singles <- NULL max.degree <- 1 selected <- object$selected.terms[ reorder.earth(object, degree=max.degree, min.degree=1)] if(trace >= 0 && !is.null(attr(object$terms, "offset"))) cat0("note: the offset in the formula is not plotted\n", " (use all1=TRUE to plot the offset, or use trace=-1 to silence this message)\n\n") if(length(selected) > 0) { prednames <- object$namesx.org degree1.dirs <- object$dirs[selected, , drop=FALSE] # column numbers of dirs that have predictors in degree1 terms icol <- which(degree1.dirs != 0, arr.ind=TRUE)[,2] if(!any(sapply(x, is.factor))) # no factors in x? singles <- icol else { # factors in x colnames <- colnames(object$dirs)[icol] for(ipred in seq_along(prednames)) { if(ipred > ncol(x)) stopf( "get.singles.earth: ipred=%d but x has only %d columns\n prednames=%s\n colnames(x)=%s", ipred, ncol(x), paste.c(prednames, maxlen=100), paste.c(colnames(x), maxlen=100)) if(is.logical(x[,ipred])) { # e.g. logical "survived" is renamed to "survivedTRUE" by model.matrix() # (model.matrix is invoked when earth.formula is invoked) if(paste0(prednames[ipred], "TRUE") %in% colnames) singles <- c(singles, ipred) } else if(is.factor(x[,ipred])) { # This knows how to handle factor names expanded by model.matrix() # because it e.g. looks for "^pclass" in "pclass3rd". # TODO this can give extra predictors if variable names alias # e.g. "x" and "x1" are both variable names if(grepany(paste0("^", prednames[ipred]), colnames)) singles <- c(singles, ipred) } else if(prednames[ipred] %in% colnames) singles <- c(singles, ipred) } } if(any(singles > length(prednames))) stop0("plotmo.singles.earth returned an index ", "greater than the number of predictors\n", " singles=", paste(singles, collapse=","), " prednames=", paste(prednames, collapse=",")) } singles } plotmo.pairs.earth <- function(object, x, ...) { pairs <- matrix(0, nrow=0, ncol=2) # no pairs selected <- object$selected.terms[ # selected is all degree 2 terms reorder.earth(object, degree=2, min.degree=2)] pairs <- vector(mode="numeric") for(i in selected) # append indices of the two preds in term i pairs <- c(pairs, which(object$dirs[i,] != 0)) pairs <- unique(matrix(pairs, ncol=2, byrow=TRUE)) if(nrow(pairs) > 0 && any(sapply(x, is.factor))) { # any columns in x are factors? # pairs works off expanded factor names, so replace each name # with index of original variable name # TODO this can give wrong results if variable names alias # e.g. if "x" and "x1" are both variable names this takes the LAST # of the matching names so correct with "x" "x1" but not "x1" "x" dir.colnames <- colnames(object$dirs) prednames <- object$namesx.org prednames.hat <- paste0("^", prednames) for(i in seq_len(nrow(pairs))) for(j in 1:2) { ipred1 <- 0 for(ipred in seq_along(prednames.hat)) if(grepany(prednames.hat[ipred], dir.colnames[pairs[i, j]])) ipred1 <- ipred if(ipred1 == 0) stop0("internal error: illegal ipred1 in plotmo.pairs.earth") pairs[i, j] <- ipred1 } } pairs } plotmo.y.earth <- function(object, trace, naked, expected.len, ...) { temp <- plotmo::plotmo.y.default(object, trace, naked, expected.len) # plotmo.y.default returns list(field=y, do.subset=do.subset) # do the same processing on y as earth does, e.g. if y is a two # level factor, convert it to an indicator column of 0s and 1s colnames <- colnames(temp$field) temp$field <- expand.arg(temp$field, model.env(object), trace, is.y.arg=TRUE, xname=if(!is.null(colnames)) colnames else "y") temp } plotmo.pairs.bagEarth <- function(object, x, ...) # caret package { pairs <- matrix(0, nrow=0, ncol=2) for(i in seq_along(object$fit)) pairs <- rbind(pairs, plotmo.pairs.earth(object$fit[[i]], x)) pairs[order(pairs[,1], pairs[,2]),] } plotmo.y.bagEarth <- function(object, trace, naked, expected.len, ...) { plotmo.y.earth(object, trace, naked, expected.len) } # back compatibility get.plotmo.pairs.bagEarth <- function(object, env, x, trace, ...) { plotmo.pairs.bagEarth(object, x, ...) } get.plotmo.y.bagEarth <- function(object, env, y.column, expected.len, trace, ...) { plotmo.y.bagEarth(object, trace) } earth/R/earth.R0000644000176200001440000026030213561352060013010 0ustar liggesusers# earth.R: an implementation of Friedman's Multivariate Adaptive # Regression Splines, commonly known as MARS. # # This code is derived from code in mda.R by Hastie and Tibshirani. # Functions are in mostly in alphabetical order. # Stephen Milborrow Mar 2007 Petaluma # #----------------------------------------------------------------------------- # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # A copy of the GNU General Public License is available at # http://www.r-project.org/Licenses # #----------------------------------------------------------------------------- # Notes for earth() that didn't make it into the man pages. # # --- subset argument (for selecting cases) # # All subset handling is done in earth.fit not in earth.formula or # update.earth. This is because we want to allow the user to specify # a subset even when he or she isn't using the formula based approach # i.e. using earth.default() and not earth.formula(). # #----------------------------------------------------------------------------- # This is a list of those formal arguments of earth.fit that can be changed without # requiring a new forward pass. # NOTE: if you change the pruning formal arguments in earth.fit(), update this too! prune.only.args <- c("glm", "trace", "nprune", "pmethod", "Use.beta.cache", "Force.xtx.prune", "Get.leverages", "Exhaustive.tol") # returns the number of arguments to the user's "allowed" function check.allowed.arg <- function(allowed) # check earth's "allowed" argument { len <- 0 if(!is.null(allowed)) { allowed.func.needs <- paste0( " The 'allowed' function needs the following arguments ", "(but namesx and first are optional):\n ", paste.collapse(c("degree", "pred", "parents", "namesx", "first"))) if(!identical(typeof(allowed), "closure")) stop0("your 'allowed' argument is not a function") names. <- names(formals(allowed)) len <- length(names.) if(len < 3 || len > 5) stop0("your 'allowed' function does not have the correct number of arguments\n", allowed.func.needs) if(names.[1] != "degree" || names.[2] != "pred" || names.[3] != "parents" || (len >= 4 && names.[4] != "namesx") || (len >= 5 && names.[5] != "first")) { stop0(allowed.func.needs, "\n You have:\n ", paste.collapse(names.)) } } len } # This reports when more than one term changes in a single pruning pass step. # To see run the call to earth below, and in the pruning pass note that at # step 8 several terms are added and deleted (but really only one term # should be added per step if pmethod="backward" or "forward"). # earth(O3 ~ ., data = ozone1, degree=2, trace=5) check.one.term.per.step <- function(prune.terms, trace) { for(i in 2:nrow(prune.terms)) { which1 <- which2 <- repl(FALSE, ncol(prune.terms)) which1[prune.terms[i-1,]] <- TRUE which2[prune.terms[i,]] <- TRUE xor <- xor(which1, which2) # true for every term that changed if(sum(xor) > 1) { # more than one term changed? printf("%g terms changed between steps %g and %g of the pruning pass\n", sum(xor), i-1, i) break } } } tweak.zero.weights <- function(w, wname) { meanw <- mean(w) if(meanw == 0) stop0("mean of '", wname, "' is zero") else if(meanw < 1e-8) stop0("mean of '", wname, "' is (almost) zero") # TODO fix zero weights (but should maybe do what lm.wfit does and delete cols) almost.zero <- meanw / 1e8 # note that 1e8 becomes 1e4 after sqrt later w[w < almost.zero] <- almost.zero w } check.weights <- function(w, wname, expected.len, tweak.zero.weights) # invoked for both wp and weights { check.vec(w, wname, expected.len) check(w, wname, "negative value", function(x) { x < 0 }) if(tweak.zero.weights) w <- tweak.zero.weights(w, wname) w } check.which.terms <- function(dirs, which.terms) # ensure which.terms is valid { if(is.null(which.terms)) stop0("'which.terms' is NULL") if(length(which.terms) == 0) stop0("length(which.terms) == 0") if(which.terms[1] != 1) stop0("first element of 'which.terms' must be 1, the intercept term") if(NCOL(which.terms) > 1) { for(i in seq_len(NCOL(which.terms))) check.index(which.terms[,i], "which.terms", dirs, allow.zeros=TRUE, allow.dups=TRUE) } else check.index(which.terms, "which.terms", dirs, allow.zeros=TRUE, allow.dups=TRUE) } convert.linpreds.to.logical <- function(linpreds, npreds, x) { linpreds <- check.index(linpreds, "linpreds", x, is.col.index=TRUE, allow.empty=TRUE) to.logical(linpreds, npreds) } earth <- function(...) { UseMethod("earth") } earth.default <- function( x = stop("no 'x' argument"), y = stop("no 'y' argument"), weights = NULL, # case weights wp = NULL, # response column weights subset = NULL, # which rows in x to use na.action = na.fail, # only legal value is na.fail pmethod = c("backward", "none", "exhaustive", "forward", "seqrep", "cv"), keepxy = FALSE, # true to retain x, y, etc in returned value trace = 0, glm = NULL, degree = 1, # max degree of interaction (1=additive model) (Friedman's mi) nprune = NULL, # max nbr of terms (including intercept) in pruned subset nfold = 0, # number of folds per cross-validation ncross = 1, # number of cross-validations, ignored unless nfold>0 stratify = TRUE, # stratify levels in cross-validation folds varmod.method = "none", # estimate cross-validation pred intervals varmod.exponent = 1, # power transform applied to fitted response varmod.conv = 1, # max mean percent coef change for IRLS iterations varmod.clamp = .1, # min.sd predicted by varmod is varmod.clamp * mean(sd) varmod.minspan = -3, # minspan for varmod call to earth Scale.y = NULL, # TRUE to scale y in the forward pass ...) # passed on to earth.fit { trace <- as.numeric(check.numeric.scalar(trace, logical.ok=TRUE)) env <- parent.frame() # the environment from which earth was called call <- make.call.generic(match.call(), "earth") if(trace >= 4) printcall("Call: ", call) if(!is.null(call$data)) stop0("'data' argument not allowed in earth.default") if(is.character(na.action)) { if(is.na(pmatch(na.action, "na.fail"))) stop0("illegal 'na.action', only na.action=na.fail is allowed") } else if(!identical(na.action, na.fail)) stop0("illegal 'na.action', only na.action=na.fail is allowed") keepxy <- check.numeric.scalar(keepxy, min=0, max=2, logical.ok=TRUE) pmethod <- match.arg1(pmethod, "pmethod") if(pmethod == "cv") keepxy <- min(1, keepxy) if(keepxy) { xkeep <- x ykeep <- y # TODO this should be done in one place instead of here and also in earth.fit # TODO does lm process the weights before or after subset (I'm assuming before) if(!is.null(subset)) { # duplicates are allowed in subset so user can specify a bootstrap sample subset <- check.index(subset, "subset", xkeep, allow.dups=TRUE, allow.zeros=TRUE) xkeep <- if(is.null(dim(xkeep))) xkeep[subset] else xkeep[subset, , drop=FALSE] ykeep <- if(is.null(dim(ykeep))) ykeep[subset] else ykeep[subset, , drop=FALSE] } } xname <- trunc.deparse(substitute(x)) namesx <- gen.colnames(x, "x", "x", trace=0) namesx.org <- namesx # the "if" saves memory when x is already in canonical form if(!is.matrix(x) || !is.double(x[,1]) || !good.colnames(x)) { # expand factors, convert to double matrix with column names x <- expand.arg(x, env, trace=0, is.y.arg=FALSE, xname=xname, is.earth.default=TRUE) rownames(x) <- possibly.delete.rownames(x) } ylevels <- get.ylevels(y) y <- expand.arg(y, env, trace=0, is.y.arg=TRUE, xname=trunc.deparse(substitute(y))) rownames(y) <- possibly.delete.rownames(y) # we need the diag of the hat matrix if varmod.method != "none" varmod.method <- match.choices(varmod.method, c("none", VARMOD.METHODS), "varmod.method") check.cv.args(nfold, ncross, pmethod, varmod.method) pmethod1 <- pmethod update.earth.called.me <- !is.null(dota("Object", DEF=NULL, ...)) if(pmethod == "cv" && !update.earth.called.me) { trace1(trace, "=== pmethod=\"cv\": Preliminary model with pmethod=\"backward\" ===\n") if(nfold <= 1 || ncross < 1) stop0("the nfold argument must be specified when pmethod=\"cv\"") pmethod1 <- "backward" } rv <- earth.fit(x=x, y=y, weights=weights, wp=wp, subset=subset, na.action=na.action, offset=NULL, pmethod=pmethod1, keepxy=keepxy, trace=trace, glm=glm, degree=degree, nprune=nprune, Scale.y=Scale.y, ...) rv$call <- call rv$namesx.org <- namesx.org # name chosen not to alias with rv$x rv$namesx <- namesx # ditto rv$levels <- ylevels rv$wp <- wp if(keepxy) { rv[["x"]] <- xkeep # following ruse is needed else vector y's lose their name # Jun 2015: but we don't use it for factors because as.matrix # converts factors to character variables (!) if(is.null(dim(ykeep)) && !is.factor(ykeep)) { ykeep <- as.matrix(ykeep) colnames(ykeep) <- colnames(y)[1] } rv[["y"]] <- ykeep rv$subset <- subset # TODO consider doing the following # rv$.Environment <- parent.frame() } if(nfold > 1 && ncross >= 1) { glm.arg <- process.glm.arg(glm) cv <- earth.cv(object=rv, x=if(is.null(subset)) x else x[subset,,drop=FALSE], y=if(is.null(subset)) y else y[subset,,drop=FALSE], subset=subset, weights=weights, na.action=na.action, pmethod=pmethod, keepxy=keepxy, trace=if(trace >= 4.1) trace else if(trace) .5 else 0, glm.arg=glm.arg, degree=degree, nprune=nprune, nfold=nfold, ncross=ncross, stratify=stratify, get.oof.fit.tab = varmod.method != "none", get.oof.rsq.per.subset = keepxy || pmethod == "cv", Scale.y=rv$Scale.y, env=env, ...) rv$cv.list <- cv$cv.list rv$cv.nterms.selected.by.gcv <- cv$nterms.selected.by.gcv rv$cv.nvars.selected.by.gcv <- cv$nvars.selected.by.gcv rv$cv.groups <- cv$groups # groups used for cross validation rv$cv.rsq.tab <- cv$rsq.tab rv$cv.maxerr.tab <- cv$maxerr.tab if(!is.null(cv$class.rate.tab)) rv$cv.class.rate.tab <- cv$class.rate.tab if(!is.null(cv$auc.tab)) rv$cv.auc.tab <- cv$auc.tab if(!is.null(cv$cor.tab)) rv$cv.cor.tab <- cv$cor.tab if(!is.null(cv$deviance.tab)) rv$cv.deviance.tab <- cv$deviance.tab if(!is.null(cv$calib.int.tab)) rv$cv.calib.int.tab <- cv$calib.int.tab if(!is.null(cv$calib.slope.tab)) rv$cv.calib.slope.tab <- cv$calib.slope.tab if(!is.null(cv$oof.rsq.tab)) rv$cv.oof.rsq.tab <- cv$oof.rsq.tab if(!is.null(cv$infold.rsq.tab)) rv$cv.infold.rsq.tab <- cv$infold.rsq.tab if(!is.null(cv$oof.fit.tab)) rv$cv.oof.fit.tab <- cv$oof.fit.tab if(pmethod == "cv") { rv.backward <- rv tab <- rv$cv.oof.rsq.tab stopifnot(nrow(tab) > 1, ncol(tab) > 1) mean.oof.rsq.per.subset <- tab[nrow(tab),] nterms.selected.by.cv <- which.max(mean.oof.rsq.per.subset) trace1(trace, "=== pmethod=\"cv\": Calling update.earth internally for nterms.selected.by.cv=%g ===\n", nterms.selected.by.cv) trace2(trace, "\n") # July 2017 TODO following necessary for eval.parent(call) in update.earth penalty <- dota("penalty", DEF=if(degree > 1) 3 else 2, ...) nk <- dota("nk", DEF=min(200, max(20, 2 * ncol(x))) + 1, ...) thresh <- dota("thresh", DEF=0.001, ...) minspan <- dota("minspan", DEF=0, ...) endspan <- dota("endspan", DEF=0, ...) newvar.penalty <- dota("newvar.penalty", DEF=0, ...) fast.k <- dota("fast.k", DEF=20, ...) fast.beta <- dota("fast.beta", DEF=1, ...) linpreds <- dota("linpreds", DEF=FALSE, ...) allowed <- dota("allowed", DEF=NULL, ...) Object <- dota("Object ", DEF=NULL, ...) Adjust.endspan <- dota("Adjust.endspan", DEF=2, ...) Auto.linpreds <- dota("Auto.linpreds", DEF=TRUE, ...) Force.weights <- dota("Force.weights", DEF=FALSE, ...) Use.beta.cache <- dota("Use.beta.cache", DEF=TRUE, ...) Force.xtx.prune <- dota("Force.xtx.prune", DEF=FALSE, ...) Get.leverages <- dota("Get.leverages", DEF=NROW(x) < 1e5, ...) Exhaustive.tol <- dota("Exhaustive.tol", DEF=1e-10, ...) rv <- update.earth(rv, ponly=TRUE, trace=trace, pmethod="cv", nprune=nterms.selected.by.cv, nfold=0, ncross=1, glm=glm, varmod.method="none", # July 2017 TODO following necessary for eval.parent(call) in update.earth penalty=penalty, nk=nk, thresh=thresh, minspan=minspan, endspan=endspan, newvar.penalty=newvar.penalty, fast.k=fast.k, fast.beta=fast.beta, linpreds=linpreds, allowed=allowed, Object=Object, Adjust.endspan=Adjust.endspan, Auto.linpreds=Auto.linpreds, Force.weights=Force.weights, Use.beta.cache=Use.beta.cache, Force.xtx.prune=Force.xtx.prune, Get.leverages=Get.leverages, Exhaustive.tol=Exhaustive.tol) rv$call <- call rv$pmethod <- "cv" rv$nprune <- nprune rv$dirs <- rv.backward$dirs rv$cuts <- rv.backward$cuts rv$prune.terms <- rv.backward$prune.terms rv$rss.per.subset <- rv.backward$rss.per.subset rv$gcv.per.subset <- rv.backward$gcv.per.subset rv$cv.list <- rv.backward$cv.list rv$cv <- rv.backward$cv # the number of terms that would have been selected by pmethod="backward" rv$backward.selected.terms <- rv.backward$selected.terms rv$cv.oof.fit.tab = rv.backward$cv.oof.fit.tab rv$cv.infold.rsq.tab = rv.backward$cv.infold.rsq.tab rv$cv.oof.rsq.tab = rv.backward$cv.oof.rsq.tab # The following were calculated using the best model selected at each # fold using the fold's GCVs. To minimize confusion, we delete them. rv$cv.rsq.tab <- NULL rv$cv.maxerr.tab <- NULL rv$cv.class.rate.tab <- NULL rv$cv.auc.tab <- NULL rv$cv.cor.tab <- NULL rv$cv.deviance.tab <- NULL rv$cv.calib.int.tab <- NULL rv$cv.calib.slope.tab <- NULL } } # TODO only do varmod for final model if pmethod="cv", similarly for glm if(varmod.method != "none") { oof.fit.tab <- rv$cv.oof.fit.tab stopifnot(!is.null(oof.fit.tab)) model.var <- apply(oof.fit.tab, 1, var) # var of each row of oof.fit.tab model.var <- matrix(model.var, ncol=1) rv$varmod <- varmod(rv, varmod.method, varmod.exponent, varmod.conv, varmod.clamp, varmod.minspan, trace, x, y, model.var, degree=degree) } rv$Scale.y <- NULL rv } earth.formula <- function( formula = stop("no 'formula' argument"), # intercept will be ignored data = NULL, weights = NULL, wp = NULL, subset = NULL, na.action = na.fail, pmethod = c("backward", "none", "exhaustive", "forward", "seqrep", "cv"), keepxy = FALSE, trace = 0, glm = NULL, degree = 1, # max degree of interaction (1=additive model) (Friedman's mi) nprune = NULL, # max nbr of terms (including intercept) in pruned subset nfold = 0, ncross = 1, stratify = TRUE, varmod.method = "none", varmod.exponent = 1, varmod.conv = 1, varmod.clamp = .1, varmod.minspan = -3, Scale.y = NULL, ...) { trace <- as.numeric(check.numeric.scalar(trace, logical.ok=TRUE)) env <- parent.frame() # the environment from which earth was called call <- make.call.generic(match.call(), "earth") if(trace >= 4) printcall("Call: ", call) if(!is.null(call[["x"]])) stop0("'x' argument not allowed in earth.formula") if(!is.null(call[["y"]])) stop0("'y' argument not allowed in earth.formula") call2 <- match.call(expand.dots=FALSE) # subset is handled in earth.fit so it isn't included here # we handle weights here in the same way as source code of lm (so # weights are first searched for in the data passed to the formula) m <- match(c("formula", "data", "weights", "na.action", "offset"), names(call2), 0) ret <- get.mfdata(mf=call2[c(1, m)], formula, data, env, trace) x <- ret$x y <- ret$y weights <- ret$weights offset <- ret$offset terms <- ret$terms namesx <- ret$namesx xlevels <- ret$xlevels ylevels <- ret$ylevels keepxy <- check.numeric.scalar(keepxy, min=0, max=2, logical.ok=TRUE) pmethod <- match.arg1(pmethod, "pmethod") # we need the diag of the hat matrix if varmod.method != "none" varmod.method <- match.choices(varmod.method, c("none", VARMOD.METHODS), "varmod.method") check.cv.args(nfold, ncross, pmethod, varmod.method) pmethod1 <- pmethod update.earth.called.me <- !is.null(dota("Object", DEF=NULL, ...)) if(pmethod == "cv" && !update.earth.called.me) { trace1(trace, "=== pmethod=\"cv\": Preliminary model with pmethod=\"backward\" ===\n") if(nfold <= 1 || ncross < 1) stop0("the nfold argument must be specified when pmethod=\"cv\"") pmethod1 <- "backward" } rv <- earth.fit(x=x, y=y, weights=weights, wp=wp, subset=subset, na.action=na.action, offset=offset, pmethod=pmethod1, keepxy=keepxy, trace=trace, glm=glm, degree=degree, nprune=nprune, Scale.y=Scale.y, ...) rv$call <- call rv$namesx.org <- namesx # rv$namesx name chosen not to alias with rv$x rv$namesx <- make.unique(rv$namesx.org) # ditto rv$terms <- terms # March 2019: added xlevels to match what lm does (and so does linmod.R in the plotmo tests) rv$xlevels <- xlevels rv$levels <- ylevels rv$wp <- wp if(keepxy) { if(!is.null(data)) rv$data <- data else if(trace >= 0) warning0("No 'data' argument to earth so 'keepxy' is limited\n") rv[["y"]] <- y if(!is.null(subset)) { # duplicates are allowed in subset so user can specify a bootstrap sample subset <- check.index(subset, "subset", data, allow.dups=TRUE, allow.zeros=TRUE) rv$data <- data[subset, , drop=FALSE] rv[["y"]] <- rv[["y"]][subset, , drop=FALSE] } rv$subset <- subset } # TODO make the following code a subroutine, it's identical to code in earth.default if(nfold > 1 && ncross >= 1) { glm.arg <- process.glm.arg(glm) cv <- earth.cv(object=rv, x=if(is.null(subset)) x else x[subset,,drop=FALSE], y=if(is.null(subset)) y else y[subset,,drop=FALSE], subset=subset, weights=weights, na.action=na.action, pmethod=pmethod, keepxy=keepxy, trace=if(trace >= 4.1) trace else if(trace) .5 else 0, glm.arg=glm.arg, degree=degree, nprune=nprune, nfold=nfold, ncross=ncross, stratify=stratify, get.oof.fit.tab = varmod.method != "none", get.oof.rsq.per.subset = keepxy || pmethod == "cv", Scale.y=rv$Scale.y, env=env, ...) rv$cv.list <- cv$cv.list rv$cv.nterms.selected.by.gcv <- cv$nterms.selected.by.gcv rv$cv.nvars.selected.by.gcv <- cv$nvars.selected.by.gcv rv$cv.groups <- cv$groups # groups used for cross validation rv$cv.rsq.tab <- cv$rsq.tab rv$cv.maxerr.tab <- cv$maxerr.tab if(!is.null(cv$class.rate.tab)) rv$cv.class.rate.tab <- cv$class.rate.tab if(!is.null(cv$auc.tab)) rv$cv.auc.tab <- cv$auc.tab if(!is.null(cv$cor.tab)) rv$cv.cor.tab <- cv$cor.tab if(!is.null(cv$deviance.tab)) rv$cv.deviance.tab <- cv$deviance.tab if(!is.null(cv$calib.int.tab)) rv$cv.calib.int.tab <- cv$calib.int.tab if(!is.null(cv$calib.slope.tab)) rv$cv.calib.slope.tab <- cv$calib.slope.tab if(!is.null(cv$oof.rsq.tab)) rv$cv.oof.rsq.tab <- cv$oof.rsq.tab if(!is.null(cv$infold.rsq.tab)) rv$cv.infold.rsq.tab <- cv$infold.rsq.tab if(!is.null(cv$oof.fit.tab)) rv$cv.oof.fit.tab <- cv$oof.fit.tab if(pmethod == "cv") { rv.backward <- rv tab <- rv$cv.oof.rsq.tab stopifnot(nrow(tab) > 1, ncol(tab) > 1) mean.oof.rsq.per.subset <- tab[nrow(tab),] nterms.selected.by.cv <- which.max(mean.oof.rsq.per.subset) trace1(trace, "=== pmethod=\"cv\": Calling update.earth internally for nterms.selected.by.cv=%g ===\n", nterms.selected.by.cv) trace2(trace, "\n") # July 2017 TODO following necessary for eval.parent(call) in update.earth penalty <- dota("penalty", DEF=if(degree > 1) 3 else 2, ...) nk <- dota("nk", DEF=min(200, max(20, 2 * ncol(x))) + 1, ...) thresh <- dota("thresh", DEF=0.001, ...) minspan <- dota("minspan", DEF=0, ...) endspan <- dota("endspan", DEF=0, ...) newvar.penalty <- dota("newvar.penalty", DEF=0, ...) fast.k <- dota("fast.k", DEF=20, ...) fast.beta <- dota("fast.beta", DEF=1, ...) linpreds <- dota("linpreds", DEF=FALSE, ...) allowed <- dota("allowed", DEF=NULL, ...) Object <- dota("Object ", DEF=NULL, ...) Adjust.endspan <- dota("Adjust.endspan", DEF=2, ...) Auto.linpreds <- dota("Auto.linpreds", DEF=TRUE, ...) Force.weights <- dota("Force.weights", DEF=FALSE, ...) Use.beta.cache <- dota("Use.beta.cache", DEF=TRUE, ...) Force.xtx.prune <- dota("Force.xtx.prune", DEF=FALSE, ...) Get.leverages <- dota("Get.leverages", DEF=NROW(x) < 1e5, ...) Exhaustive.tol <- dota("Exhaustive.tol", DEF=1e-10, ...) # July 2017 TODO necessary when form is a local var in function calling earth.formula rv$call$formula <- formula rv$call$data <- data rv <- update.earth(rv, ponly=TRUE, trace=trace, pmethod="cv", nprune=nterms.selected.by.cv, nfold=0, ncross=1, glm=glm, varmod.method="none", # July 2017 TODO following necessary for eval.parent(call) in update.earth penalty=penalty, nk=nk, thresh=thresh, minspan=minspan, endspan=endspan, newvar.penalty=newvar.penalty, fast.k=fast.k, fast.beta=fast.beta, linpreds=linpreds, allowed=allowed, Object=Object, Adjust.endspan=Adjust.endspan, Auto.linpreds=Auto.linpreds, Force.weights=Force.weights, Use.beta.cache=Use.beta.cache, Force.xtx.prune=Force.xtx.prune, Get.leverages=Get.leverages, Exhaustive.tol=Exhaustive.tol) rv$call <- call rv$pmethod <- "cv" rv$nprune <- nprune rv$dirs <- rv.backward$dirs rv$cuts <- rv.backward$cuts rv$prune.terms <- rv.backward$prune.terms rv$rss.per.subset <- rv.backward$rss.per.subset rv$gcv.per.subset <- rv.backward$gcv.per.subset rv$cv.list <- rv.backward$cv.list rv$cv <- rv.backward$cv # the number of terms that would have been selected by pmethod="backward" rv$backward.selected.terms <- rv.backward$selected.terms rv$cv.oof.fit.tab = rv.backward$cv.oof.fit.tab rv$cv.infold.rsq.tab = rv.backward$cv.infold.rsq.tab rv$cv.oof.rsq.tab = rv.backward$cv.oof.rsq.tab # The following were calculated using the best model selected at each # fold using the fold's GCVs. To minimize confusion, we delete them. rv$cv.rsq.tab <- NULL rv$cv.maxerr.tab <- NULL rv$cv.class.rate.tab <- NULL rv$cv.auc.tab <- NULL rv$cv.cor.tab <- NULL rv$cv.deviance.tab <- NULL rv$cv.calib.int.tab <- NULL rv$cv.calib.slope.tab <- NULL } } # TODO only do varmod for final model if pmethod="cv", similarly for glm if(varmod.method != "none") { oof.fit.tab <- rv$cv.oof.fit.tab stopifnot(!is.null(oof.fit.tab)) model.var <- apply(oof.fit.tab, 1, var) # var of each row of oof.fit.tab model.var <- matrix(model.var, ncol=1) rv$varmod <- varmod(rv, varmod.method, varmod.exponent, varmod.conv, varmod.clamp, varmod.minspan, trace, x, y, model.var, degree=degree) } rv$Scale.y <- NULL rv } # This is called from earth.default or earth.formula, not directly # because the x and y args must be expanded for factors first. earth.fit <- function( x = stop("no 'x' argument"), # x and y already processed by model.matrix y = stop("no 'y' argument"), # NAs are not allowed in x or y, an error msg if so weights = NULL, # case weights (row weights) wp = NULL, # response weights (column weights) subset = NULL, # which rows in x to use na.action = na.fail, # only legal value is na.fail offset = NULL, # offset term in formula pmethod = c("backward", "none", "exhaustive", "forward", "seqrep", "cv"), keepxy = FALSE, trace = 0, # 0 none 1 overview 2 forward 3 pruning # 4 model mats, memory use, more pruning, etc. 5 ... glm = NULL, # glm parameter from earth.formula or earth.default degree = 1, # max degree of interaction (1=additive model) (Friedman's mi) penalty = if(degree > 1) 3 else 2, # GCV penalty per knot: # 0 penalizes only terms (not knots) # special case -1 means no penalty (so GRSq==RSq) # Following affect forward pass only, not pruning pass nk = min(200, max(20, 2 * ncol(x))) + 1, # max number of model terms including intercept thresh = 0.001, # used as one of the conditions to stop adding terms in forw pass # stop if RSqDelta> p, memory use peaks here qr <- lm.fit$qr remove(lm.fit) # free memory leverages <- hatvalues.qr.wrapper(qr, maxmem, trace) possible.gc(maxmem, trace, "after hatvalues.qr.wrapper") } if(!is.null(wp)) { tt <- outer(repl(1, nrow(y)), wp) fitted.values <- fitted.values / tt # divide each column by its wp residuals <- residuals / tt y <- y / tt coefficients <- coefficients / outer(repl(1, nselected), wp) } # build glm model(s) if glm argument is not NULL glm.list <- NULL # glm.list is a list of glm models, NULL if none glm.coefs <- NULL # glm.coefs is a nselected x nresponses matrix if(!is.null(glm.arg)) { y.glm <- y.org if(!is.null(subset)) y.glm <- y.glm[subset, , drop=FALSE] glm.list <- earth.glm(bx, y.glm, weights.before.bpairs, na.action, offset, glm.arg, trace, is.bpairs, env) glm.coefs <- get.glm.coefs(glm.list=glm.list, nresp=if(is.bpairs) 1 else ncol(coefficients), selected.terms, term.names, resp.names) } # following is for consistency when running test suite on different machines rss.per.subset[rss.per.subset < 1e-10] <- 0 gcv.per.subset[gcv.per.subset < 1e-10] <- 0 # prepare returned summary statistics rss.per.response <- vector(mode="numeric", length=nresp) rsq.per.response <- vector(mode="numeric", length=nresp) gcv.per.response <- vector(mode="numeric", length=nresp) grsq.per.response <- vector(mode="numeric", length=nresp) tss.per.response <- vector(mode="numeric", length=nresp) offset.fitted.values <- if(is.null(offset)) fitted.values else fitted.values - offset if(nresp == 1 && !use.weights) { # special case to save memory rss.per.response[1] <- sos(residuals) rsq.per.response[1] <- get.weighted.rsq(y, offset.fitted.values, weights) gcv.per.response[1] <- get.gcv(rss.per.response[1], nselected, penalty, nrow(bx)) tss.per.response[1] <- sos(y - mean(y)) } else for(iresp in seq_len(nresp)) { # multiple response or weighted model y1 <- y[,iresp] offset.fitted.values1 <- offset.fitted.values[,iresp] rss.per.response[iresp] <- sos(y1 - offset.fitted.values1, weights) rsq.per.response[iresp] <- get.weighted.rsq(y1, offset.fitted.values1, weights) gcv.per.response[iresp] <- get.gcv(rss.per.response[iresp], nselected, penalty, nrow(bx)) tss.per.response[iresp] <- sos(y1 - weighted.mean(y1, weights), weights) } for(iresp in seq_len(nresp)) { gcv.null <- get.gcv(tss.per.response[iresp], 1, penalty, nrow(bx)) grsq.per.response[iresp] <- if(!use.weights) get.rsq(gcv.per.response[iresp], gcv.null) else if(nresp == 1) get.rsq(gcv.per.subset[nselected], gcv.per.subset[1]) else # TODO grsq is wrong when weights and multiple responses get.rsq(gcv.per.response[iresp], gcv.null) } rss <- rss.per.subset[nselected] rsq <- get.rsq(rss, rss.per.subset[1]) gcv <- gcv.per.subset[nselected] grsq <- get.rsq(gcv, gcv.per.subset[1]) rv <- structure(list( # term 1 is the intercept in all returned data rss = rss, # RSS, across all responses if y has multiple cols rsq = rsq, # R-Squared, across all responses gcv = gcv, # GCV, across all responses grsq = grsq, # GRSq across all responses bx = bx, # selected terms only dirs = dirs, # all terms including unselected: nterms x npreds cuts = cuts, # all terms including unselected: nterms x npreds selected.terms = selected.terms,# row indices into dirs and cuts prune.terms = prune.terms, # nprune x nprune, each row is vec of term indices fitted.values = fitted.values, # ncases (after subset) x nresp residuals = residuals, # ncases (after subset) x nresp coefficients = coefficients, # selected terms only: nselected x nresp rss.per.response = rss.per.response, # nresp x 1, RSS for each response rsq.per.response = rsq.per.response, # nresp x 1, RSq for each response gcv.per.response = gcv.per.response, # nresp x 1, GCV for each response grsq.per.response = grsq.per.response, # nresp x 1, GRSq for each response rss.per.subset = rss.per.subset,# nprune x 1, RSS of each model, across all resp gcv.per.subset = gcv.per.subset,# nprune x 1, GCV of each model, across all resp leverages = leverages, pmethod = pmethod, nprune = nprune, penalty = penalty, # copy of penalty argument nk = nk, # copy of nk argument thresh = thresh, # copy of thresh argument termcond = termcond, # reason we terminated the forward pass weights = if(use.weights) weights.before.bpairs else NULL, Scale.y = Scale.y), # return Scale.y so can pass to earth.cv class = "earth") if(!is.null(offset)) rv$offset <- offset if(!is.null(glm.list)) { rv$glm.list <- glm.list # list of glm models, NULL if none rv$glm.coefficients <- glm.coefs # matrix of glm coefs, nselected x nresp rv$glm.stats <- get.glm.stats(glm.list, colnames(rv$fitted.values)) rv$glm.bpairs <- if(is.bpairs) c(TRUE, FALSE) else NULL # backwards compat rv$glm.yfrac <- yfrac # fraction true } rv } effective.nbr.of.params <- function(ntermsVec, nknotsVec, penalty) # for GCV calculation { if(penalty < 0) # special case: term and knots are free so GCV == RSS/ncases repl(0, length(ntermsVec)) else ntermsVec + (penalty * nknotsVec) } # This returns the RSS and selected terms for each subset of size 1:nprune eval.model.subsets <- function( bx, # weighted basis matrix y, # weighted model response pmethod, nprune, # max nbr of terms (including intercept) in prune subset, in range 1..nterms Force.xtx.prune, # TRUE to always call EvalSubsetsUsingXtx rather than leaps trace) { stopifnot(nprune >= 1, nprune <= nrow(bx)) if(ncol(y) > 1) { # leaps cannot handle multiple responses if(pmethod != "none" && pmethod != "backward") stop0("pmethod=\"", pmethod, "\" is not allowed with multiple response models\n", " (y has ", ncol(y), " columns, use trace=4 to see y)") trace2(trace, "Using EvalSubsetsUsingXtx (rather than leaps) because this is a multiple response model\n") eval.subsets.xtx(bx, y, pmethod, nprune, Force.xtx.prune, trace) } else if(ncol(bx) <= 2) { # leaps code gives an error for small number of cols if(pmethod != "none" && pmethod != "backward") pmethod <- "backward" trace2(trace, "Using EvalSubsetsUsingXtx (rather than leaps) because ncol(bx) <= 2\n") eval.subsets.xtx(bx, y, pmethod, nprune, Force.xtx.prune, trace) } else if(Force.xtx.prune) { # user explicitly asked for xtx subset evaluation trace2(trace, "Using EvalSubsetsUsingXtx (rather than leaps) because Force.xtx.prune=TRUE\n") eval.subsets.xtx(bx, y, pmethod, nprune, Force.xtx.prune, trace) } else eval.model.subsets.with.leaps(bx, y, pmethod, nprune) } # convert lopt format to prune.terms format convert.lopt <- function(lopt, nprune) { # Assignment fills matrix column wise. We want row wise, so # take upper triangle and then transpose. prune.terms <- matrix(0, nrow=nprune, ncol=nprune) prune.terms[upper.tri(prune.terms, diag=TRUE)] <- lopt t(prune.terms) } eval.model.subsets.with.leaps <- function( bx, y, pmethod, nprune) { rprune <- leaps.setup(x=bx, y=y, force.in=1, # make sure intercept is in model force.out=NULL, intercept=FALSE, # we have an intercept so leaps.setup must not add one nvmax=nprune, nbest=1, warn.dep=TRUE) rprune <- switch(pmethod, backward = leaps.backward(rprune), none = leaps.backward(rprune), # for stats, won't actually prune exhaustive = leaps.exhaustive(rprune), forward = leaps.forward(rprune), seqrep = leaps.seqrep(rprune)) list(rss.per.subset = as.vector(rprune$ress), # convert nx1 mat to vec # each row of prune.terms is a vec of term indices prune.terms = convert.lopt(rprune$lopt, nprune)) } # This calls the earth.c routine EvalSubsetsUsingXtxR. # Unlike the leaps code, it can handle multiple responses (i.e. multiple y columns) eval.subsets.xtx <- function( bx, y, pmethod, nprune, Force.xtx.prune, trace) { bad.pmethod <- function() { stop0("pmethod=\"", pmethod, "\" is not allowed with 'eval.subsets.xtx'") } backward <- function(bx, y) { ncases <- nrow(bx) nterms <- ncol(bx) nresp <- ncol(y) stopifnot(is.double(bx)) stopifnot(is.double(y)) on.exit(.C("FreeEarth", PACKAGE="earth")) # if error or user interrupt, free mem # TODO replace .C call with alternative interface that doesn't require DUP=TRUE rv <- .C("EvalSubsetsUsingXtxR", prune.terms = matrix(0, nrow=nterms, ncol=nterms), # double PruneTerms[] rss.per.subset = vector(mode="numeric", length=nterms), as.integer(ncases), # const int* pnCases as.integer(nresp), # const int* pnResp as.integer(nterms), # const int* pnMaxTerms bx, # const double bx[] y, # const double y[] as.double(max(trace, 0)), # in: const double* pTrace PACKAGE="earth") # above returns all subsets, so trim back to nprune below list(rss.per.subset = rv$rss.per.subset[seq_len(nprune)], prune.terms = rv$prune.terms[seq_len(nprune), seq_len(nprune), drop=FALSE]) } #--- eval.subsets.xtx starts here --- rprune <- switch(pmethod, backward = backward(bx, y), none = backward(bx, y), # for stats, won't actually prune exhaustive = bad.pmethod(), forward = bad.pmethod(), seqrep = bad.pmethod()) } forward.pass <- function(x, y, yw, weights, # must be double, but yw can be NULL trace, degree, penalty, nk, thresh, minspan, endspan, newvar.penalty, fast.k, fast.beta, linpreds, allowed, Scale.y, Adjust.endspan, Auto.linpreds, Use.beta.cache, n.allowed.args, env, maxmem) { if(nrow(x) < 2) stop0("the x matrix must have at least two rows") stopifnot(nrow(x) == nrow(y)) if(!is.null(yw)) { stopifnot(nrow(y) == nrow(yw)) stopifnot(ncol(y) == ncol(yw)) } npreds <- ncol(x) fullset <- repl(0, nk) # element will be set TRUE if corresponding term used linpreds <- convert.linpreds.to.logical(linpreds, npreds, x) if(trace >= 2) print_linpreds(linpreds, x) if(Scale.y) { y <- get.scaled.y(y, "y") if(!is.null(yw)) yw <- scale(yw, center=FALSE, scale=attr(y, "scaled:scale")) } print_scaled_y(trace, Scale.y, y) # prints only if trace >= 5 # we are careful to initialize the "out" variables for ForwardPassR here # in a way that does not require them to be duplicated in ForwardPassR fullset <- as.integer(fullset) bx <- matrix(0, nrow=nrow(x), ncol=nk) dirs <- matrix(0, nrow=nk, ncol=npreds) cuts <- matrix(0, nrow=nk, ncol=npreds) termcond <- integer(length=1) # reason we terminated the forward pass stopifnot(!is.null(colnames(x))) # ensure we have predictor names stopifnot(is.double(x)) # no typecast in .Call below stopifnot(is.double(y)) stopifnot(is.null(weights) || is.double(weights)) on.exit(.C("FreeEarth", PACKAGE="earth")) # if error or user interrupt, free mem .Call("ForwardPassR", fullset, # out: int FullSet[] bx, # out: double bx[] dirs, # out: double Dirs[] cuts, # out: double Cuts[] termcond, # out: int* x, # in: double x[] y, # in: double y[] yw, # in: double yw[] or NULL weights, # in: double WeightsArg[] (never NULL) as.integer(nrow(x)), # in: int* nCases as.integer(ncol(y)), # in: int* nResp as.integer(npreds), # in: int* nPreds as.integer(degree), # in: int* nMaxDegree as.double(penalty), # in: double* Penalty as.integer(nk), # in: int* nMaxTerms as.double(thresh), # in: double* Thresh as.integer(minspan), # in: int* nMinSpan as.integer(endspan), # in: int* nEndSpan as.integer(fast.k), # in: int* nFastK as.double(fast.beta), # in: double* FastBeta as.double(newvar.penalty), # in: double* NewVarPenalty as.integer(linpreds), # in: int LinPreds[] allowed, # in: SEXP Allowed as.integer(n.allowed.args), # in: int* nAllowedArgs env, # in: SEXP Env as.double(Adjust.endspan), # in: double AdjustEndSpan as.integer(Auto.linpreds), # in: int* nAutoLinPred as.integer(Use.beta.cache), # in: int* nUseBetaCache as.double(max(trace, 0)), # in: double* Trace colnames(x), # in: char* sPredNames[] NAOK = TRUE, # we check for NAs etc. internally in C ForwardPass PACKAGE="earth") fullset <- as.logical(fullset) list(termcond = termcond, bx = bx[, fullset, drop=FALSE], dirs = dirs[fullset, , drop=FALSE], cuts = cuts[fullset, , drop=FALSE]) } # Return a vec which specifies the degree of each term in dirs. # Each row of dirs specifies one term so we work row-wise in dirs. get.degrees.per.term <- function(dirs) { if(nrow(dirs) == 1) # intercept only model? return(0) degrees <- double(nrow(dirs)) for(i in seq_along(degrees)) degrees[i] <- sum(dirs[i,] != 0) degrees } # Used when building the model to name the columns of bx and rows of dirs etc. # Also called by mars.to.earth. # Return string like "h(55-x1)*h(x2-58)". # h represents the hockey stick func. # If ntermsVec is a vector, this returns a vector of strings. # x can be NULL (currently only when called from mars.to.earth), it is used # only for simplifying terms with factor predictors. get.earth.term.name <- function(ntermsVec, dirs, cuts, pred.names, x, warn.if.dup=TRUE) { get.term.name1 <- function(nterm, dirs, cuts, pred.names, xrange, form1, form2) { get.name <- function(ipred) # return "name" if possible, else "x[,i]" { pred.name <- pred.names[ipred] if(is.null(pred.name) || anyNA(pred.name)) paste0("x[,", ipred, "]") else pred.name } if(nterm == 1) return("(Intercept)") s <- "" first.fac <- TRUE stopifnot(ncol(dirs) > 0) for(ipred in seq_len(ncol(dirs))) if(dirs[nterm,ipred]) { if(!first.fac) s <- paste0(s, "*") first.fac <- FALSE if(dirs[nterm,ipred] == 2) # linear predictor? s <- pastef(s, "%s", get.name(ipred)) else if(dirs[nterm,ipred] == -1) s <- pastef(s, form1, cuts[nterm,ipred], get.name(ipred)) else if(dirs[nterm,ipred] == 1) { if(cuts[nterm,ipred] == 0 && !is.null(xrange) && xrange[1, ipred] == 0 && xrange[2, ipred] < 100 && x[,ipred] == floor(x[,ipred])) # all integer? # simplify to no hinge function, it's a factor s <- pastef(s, "%s", get.name(ipred)) else s <- pastef(s, form2, get.name(ipred), cuts[nterm,ipred]) } else if(dirs[nterm,ipred] != 0) stop0("illegal direction ", dirs[nterm,ipred], " in dirs") } s } #--- get.earth.term.name starts here --- stopifnot(ncol(dirs) == ncol(x)) xrange <- NULL # 1st row is min, 2nd row is max, a column for each pred if(!is.null(x)) xrange <- apply(x, 2, range) # for simplifying "h(ldose-0)" to "ldose" # get format strings for sprint later ndigits <- getOption("digits") if(ndigits <= 7) { # for back compat with previous versions of earth form1 <- "h(%g-%s)" # let %g figure out the nbr of digits form2 <- "h(%s-%g)" } else { form1 <- sprint("h(%%.%dg-%%s)", ndigits) # e.g. "h(%.9g-%s)" form2 <- sprint("h(%%s-%%.%dg)", ndigits) # e.g. "h(%s-%.9g)" } term.names <- sapply(seq_along(ntermsVec), get.term.name1, dirs, cuts, pred.names, xrange, form1, form2) # check for duplicated term names duplicated <- duplicated(term.names) if(warn.if.dup && any(duplicated)) warning0("duplicate term name \"", term.names[which(duplicated)[1]], "\"\n", "This is usually caused by cuts that are very close to each other\n", "Remedy: use options(digits=NDIGITS), ", "typically NDIGITS has to be at least 7 ", "(currently NDIGITS=", ndigits, ")") term.names } # get.gcv returns GCVs as defined in Friedman's MARS paper, with an # extension for penalty < 0 get.gcv <- function( rss.per.subset, ntermsVec, # number of MARS regression terms including intercept penalty, # penalty per knot, argument from earth.fit() ncases) # number of cases { stopifnot(length(rss.per.subset) == length(ntermsVec)) nknotsVec <- get.nknots(ntermsVec) nparams <- effective.nbr.of.params(ntermsVec, nknotsVec, penalty) ifelse(nparams >= ncases, Inf, # ensure that GCVs are non-decreasing as number of terms increases rss.per.subset / (ncases * (1 - nparams/ncases)^2)) } # Return the estimated number of knots # # TODO This is not quite correct? It assumes that each term pair adds one # knot. Thus each term adds "half a knot". But if we have deleted a term # in a pair then the remaining term should add a knot, not half a knot. get.nknots <- function(nterms) { (nterms - 1 ) / 2 } get.mfdata <- function(mf, formula, data, env, trace) # called by earth.formula { mf[[1]] <- as.name("model.frame") if(!is.null(mf$na.action)) stop0("'na.action' argument is not allowed (it is set internally to na.fail)") mf$na.action <- na.fail if(must.use.Formula(formula)) { # use class "Formula" (allows multiple responses separated by +) trace1(trace, "Using class \"Formula\" because lhs of formula has terms separated by \"+\"\n") Formula <- Formula::Formula(formula) if(length(attr(Formula, "lhs")) > 1) # e.g. y1 | y2 ~ . stop0("multiple parts on left side of formula (because \"|\" was used)") if(length(attr(Formula, "rhs")) > 1) # e.g. y ~ x1 | x2 stop0("multiple parts on right side of formula (because \"|\" was used)") mf$formula <- Formula mf <- eval(mf, envir=env) terms <- terms(mf) x <- model.matrix(Formula, data=mf, rhs=1) # TODO work around for model.matrix.Formula which incorrectly includes # `(weights)` in x (Formula package version 1.2-3 March 2019). # Happens only if dot is used on rhs of formula? # e.g. d<-data.frame(x=1:9,y=1:9,z=1:9);earth(y+z~.,data=d,weights=1:9,trace=2) if(any(colnames(x) == "`(weights)`")) { trace2(trace, "Deleting spurious `(weights)` column from model.matrix\n") x <- x[, colnames(x) != "`(weights)`", drop=FALSE] } y <- model.part(Formula, data=mf, lhs=1) attr(terms, "Formula") <- Formula attr(terms, "Response") <- 1:NCOL(y) # TODO is 1:NCOL(y) reliable here? iresp.col <- attr(terms, "Response") } else { # use class "formula" (lhs does not have two terms separated by + or |) # we use formula not Formula here for backwards compatibility # could still be a multiple response e.g. cbind(survived, died)~. mf <- eval(mf, envir=env) terms <- terms(mf) # expand factors in x, convert to double matrix, add colnames x <- model.matrix(terms, data=mf) y <- model.response(mf, "any") # "any" means factors are allowed iresp.col <- attr(terms, "response") } namesx <- get.namesx(mf, iresp.col) yname <- NULL if(!is.factor(y)) # TODO is this correct for multiple column responses? yname <- names(attr(terms, "dataClasses"))[[iresp.col[1]]] rownames(x) <- possibly.delete.rownames(x) intercept <- match("(Intercept)", colnames(x), nomatch=0) if(intercept) x <- x[, -intercept, drop=FALSE] # silently discard intercept else warning0("ignored -1 in formula (earth objects always have an intercept)") # strip white space for better reading earth formula for e.g. earth(y~I(X-3)) # because model.matrix inserts spaces around the minus if(!is.null(colnames(x))) colnames(x) <- strip.space(colnames(x)) ylevels <- get.ylevels(y) # TODO this always returns NULL if Formula was used # expand factors in y, convert to double matrix, add colnames # note that if e.g. "survived" is a logical, it gets renamed to "survivedTRUE" # and if e.g. "pclass" is a factor, it gets renamed to "pclass2nd" and "pclass3rd" y <- expand.arg(y, env, trace=0, is.y.arg=TRUE, xname=yname) rownames(y) <- possibly.delete.rownames(y) # as.vector to avoid problems with Nx1 weights (same as lm source code) weights <- as.vector(model.weights(mf)) offset <- as.vector(model.offset(mf)) if(!is.null(offset)) { check.offset.var.is.in.data(terms, data) check.vec(offset, "formula offset", expected.len=NROW(y), logical.ok=FALSE) } list(x=x, y=y, weights=weights, offset=offset, terms=terms, namesx=namesx, xlevels=.getXlevelsMulti(terms, mf), ylevels=ylevels) } # Like stats::.getXlevels but also works for Terms for multiple-response # model terms made with Formula and with a "Response" attribute. # If we use .getXlevels and not .getXlevels2, model.frame.default issues # Warning: variable 'pclass' is not a factor # for e.g. a<-earth(pclass+age~sibsp, data=etitanic); plotmo(a, nresponse=1) # This function is based on .getXlevels R version 3.5.3 (March 2019). .getXlevelsMulti <- function(Terms, m) { deparse2 <- function(x) { # copy of stats:::deparse2 paste(deparse(x, width.cutoff = 500L, backtick = !is.symbol(x) && is.language(x)), collapse = " ") } xvars <- vapply(attr(Terms, "variables"), deparse2, "")[-1L] yvars <- attr(Terms, "response") if(is.null(yvars) || yvars[1] == 0) yvars <- attr(Terms, "Response") if(any(yvars) > 0) xvars <- xvars[-yvars] if(length(xvars)) { xlev <- lapply(m[xvars], function(x) if(is.factor(x)) levels(x) else if (is.character(x)) levels(as.factor(x)) else NULL) xlev[!vapply(xlev, is.null, NA)] } else NULL } # get x column names from model frame get.namesx <- function(mf, iresp.col) { namesx <- character(0) for(i in seq_len(ncol(mf))) if(!(i %in% iresp.col)) { if(!is.null(colnames(mf[[i]]))) namesx <- c(namesx, colnames(mf[[i]])) else if(colnames(mf)[i] != "(weights)") namesx <- c(namesx, colnames(mf)[i]) } namesx } #--- earth.formula starts here get.nterms.per.degree <- function(object, which.terms = object$selected.terms) { check.classname(object, substitute(object), "earth") check.which.terms(object$dirs, which.terms) degrees.per.term <- get.degrees.per.term(object$dirs[which.terms, , drop=FALSE]) max.degree <- max(degrees.per.term) nterms.per.degree <- repl(0, max.degree+1) # +1 for intercept for(i in 0:max.degree) nterms.per.degree[i+1] <- sum(degrees.per.term == i) names(nterms.per.degree) <- 0:max.degree # for backward compat with old version nterms.per.degree } get.nused.preds.per.subset <- function(dirs, which.terms) { # object was converted from mars? if so, ugly hack to allow plot routines to work if(is.null(which.terms)) which.terms <- matrix(seq_len(ncol(dirs)), ncol(dirs), ncol(dirs)) # allow which.terms to be a vector or matrix if(NROW(which.terms) == 1 || NCOL(which.terms) == 1) which.terms <- matrix(which.terms, nrow=1, ncol=NROW(which.terms) * NCOL(which.terms == 1)) nmodels <- NROW(which.terms) stopifnot(nmodels > 0) nused <- vector(mode="numeric", nmodels) for(i in seq_len(nmodels)) { check.which.terms(dirs, which.terms) nused[i] <- sum(0 != colSums(abs( dirs[which.terms[i,,drop=FALSE], , drop=FALSE]))) } nused } get.Scale.y <- function(Scale.y, y, use.weights, wp, Force.weights) { if(is.null(Scale.y)) # auto Scale.y Scale.y <- NCOL(y) == 1 && is.null(wp) else { # user specified Scale.y Scale.y <- check.boolean(Scale.y) if(Scale.y && !is.null(wp)) stop0("Scale.y=TRUE is not allowed with wp (implementation restriction)") } Scale.y } get.scaled.y <- function(y, yname) { y.scaled <- scale(y) # check that scaling was ok i <- which(attr(y.scaled, "scaled:scale") == 0) if(length(i)) { if(ncol(y) > 1) warning0("Cannot scale column ", i[1], " of ", yname, " (values are all equal to ", y[1,i], ")\n", " Use Scale.y=FALSE to silence this warning") else warning0("Cannot scale ", yname, " (values are all equal to ", y[1,1], ")\n", " Use Scale.y=FALSE to silence this warning") y.scaled <- y # fall back } y.scaled } get.weights <- function(weights, y, is.bpairs, is.subset.arg, is.glm.arg, Force.weights, trace) { n <- nrow(y) weights.specified <- !is.null(weights) if(is.null(weights)) weights <- repl(1, n) else weights <- check.weights(weights, "weights", n, tweak.zero.weights=FALSE) weights.before.bpairs <- if(weights.specified || Force.weights) weights else NULL if(is.bpairs) { # note: all zero rows will have weight zero, which will later # be changed to almost-zero in tweak.zero.weights below weights <- weights * rowSums(y) } # use weights only if necessary, because earth is much faster without weights use.weights <- check.boolean(Force.weights) || any(abs(weights - weights[1]) > 1e-8) if(!use.weights) weights <- repl(1, n) if(!is.double(weights)) # paranoia: weights must be double for calls to C functions weights <- as.double(weights) trace.weights(trace, weights, weights.before.bpairs, is.bpairs, is.glm.arg, weights.specified, use.weights) list(weights = tweak.zero.weights(weights, "weights"), weights.before.bpairs = weights.before.bpairs, use.weights = use.weights) } trace.weights <- function(trace, weights, weights.before.bpairs, is.bpairs, is.glm.arg, weights.specified, use.weights) { if(trace < 1) return(NULL) if(is.bpairs) { if(use.weights) { printf("weights used by earth internally: %s\n", paste.trunc(sprint("%.4g", weights), collapse=", ", maxlen=50)) trace2(trace, "weights passed to glm (which will adjust by rowsums): %s\n", if(is.null(weights.before.bpairs)) "NULL" else paste.trunc(sprint("%.4g", weights.before.bpairs), collapse=", ", maxlen=30)) } else printf("earth and glm: unweighted%s\n", if(weights.specified) " (because all weights equal)" else "") } else if(is.glm.arg) { if(use.weights) printf("earth and glm weights[%d]: %s\n", NROW(weights), paste.trunc(sprint("%.4g", weights), collapse=", ", maxlen=40)) else if(weights.specified) printf("earth and glm: unweighted (because all weights equal)\n") } else { if(use.weights) printf("weights[%d]: %s\n", NROW(weights), paste.trunc(sprint("%.4g", weights), collapse=", ", maxlen=60)) else if(weights.specified) printf("weights: no weights (because all weights equal)\n") } } get.ylevels <- function(y) { if(!is.null(levels(y))) return(levels(y)) # following needed for predict.earth(type="class") if(is.logical(y)) return(c(FALSE, TRUE)) if(is.numeric(y)) { range <- range(y, na.rm=TRUE) # forward pass will check NAs later if(range[2] - range[1] == 1) return(c(range[1], range[2])) } NULL } good.colname <- function(name) { # The nchar check prevents super long names (60 is arb) # that are actually contents of vectors e.g. c(1,2,3,etc.) # The grep ensures that there are no more than three commas, # also to prevent using the contents of vectors. !is.null(name) && nchar(name) <= 60 && !grepany(",.*,.*,", name) } good.colnames <- function(x) { colnames <- colnames(x) if(is.null(colnames)) return(FALSE) for(i in seq_along(colnames)) if(!good.colname(colnames[i])) return(FALSE) return(TRUE) } # hatvalues() doesn't work on lm.fit objects, so get leverages ourselves # TODO this hasn't been tested for multiple response models hatvalues.qr <- function(qr, maxmem, trace) { possible.gc(maxmem, trace, "hatvalues.qr1") y <- diag(1, nrow=nrow(qr$qr), ncol=qr$rank) possible.gc(maxmem, trace, "hatvalues.qr2") qr.qy <- qr.qy(qr, y)^2 # calculate (Q %*% y)^2 remove(y) # free memory for rowSums possible.gc(maxmem, trace, "hatvalues.qr3") leverages <- rowSums(qr.qy) leverages[leverages < 1e-8] <- 0 # allow for numerical error leverages[leverages > 1 - 1e-8] <- 1 # allow for numerical error leverages } # this wrapper is because when n >> p we run out of memory in qr.qy hatvalues.qr.wrapper <- function(qr, maxmem, trace) { # treat memory allocation warning in qr.qy as an error, not a warning old.warn <- getOption("warn") on.exit(options(warn=old.warn)) options(warn=2) # treat warnings as errors if(trace == 1.5) printf("Getting leverages\n") leverages <- try(hatvalues.qr(qr, maxmem, trace), silent=TRUE) if(is.try.err(leverages)) { options(warn=1) warning0("Not enough memory to get leverages (but otherwise the model is fine)") leverages <- NULL } leverages } init.global.data <- function() { assignInMyNamespace("lamba.global", -999) assignInMyNamespace("lamba.factor.global", -999) assignInMyNamespace("prev.coef.global", NULL) assignInMyNamespace("trace.ncoef.global", 0) assignInMyNamespace("issued.singularities.warning.global", FALSE) } # the following calculation of max mem needed by earth is just an approximation maxmem <- function(x, nk, trace) { sint <- 4 # sizeof int sdouble <- 8 # sizeof double n <- nrow(x) p <- ncol(x) x <- n * p * sdouble y <- n * sdouble bx <- n * nk * sdouble # matrices used in the C code xorder <- n * p * sint bxorth <- bx bxorthcenteredt <- bx xbx <- n * sdouble # TODO what about xUsed and work (used "After forward pass GRSq ...") maxmem <- x + y + bx + xorder + bxorth + bxorthcenteredt + xbx maxmem <- maxmem / 1024^3 # Bytes to GBytes if(trace >= 5 || trace == 1.5 || trace == 1.6) printf("maxmem %.1f GB\n", maxmem) maxmem # estimated maximum memory used by earth, in GBytes } # If lhs of formula has two terms separated by + or |, use # class "Formula" (to support multiple responses) # e.g. y+y2~. # e.g. y|y2~. (issue an error message if this is used, to help user) # # Otherwise, use class "formula" (for backwards compatability) # e.g. y~. standard case # e.g. y/y2~. because + isn't used # e.g. cbind(y+y2)~. because + is internal to cbind # e.g. (y+y2)~. because + is in parentheses # e.g. I(y+y2)~. because + is in parentheses # # TODO this function depends on the implementation of all.names (it depends # on the order in which all.names returns the names in the formula) must.use.Formula <- function(formula) { all.names <- all.names(formula) length(all.names) > 3 && all.names[1] == "~" && (all.names[2] == "+" || all.names[2] == "|") } possible.gc <- function(maxmem, trace, msg) { if(maxmem > 1) { # more than 1 GByte of memory required by earth? if(trace == 1.5 || trace == 1.6) old.memsize <- memory.size() gc() if(trace == 1.5 || trace == 1.6) { printf("memsize %.1f to %.1f max %.1f GB %s\n", old.memsize / 1024, memory.size() / 1024, memory.size(max=TRUE) / 1024, msg) } } } # Remove useless(?) "1" "2" "3" ... rownames for x (added by # model.matrix) so earth.formula x is same as earth.default x, # and to save memory (although not as important now that R # hashes strings internally). possibly.delete.rownames <- function(x) { # decide by looking at first few names n <- length(rownames(x)) if((n >= 1 && (is.null(rownames(x)[1]) || rownames(x)[1] == "1")) && (n >= 2 && (is.null(rownames(x)[2]) || rownames(x)[2] == "2")) && (n >= 3 && (is.null(rownames(x)[3]) || rownames(x)[3] == "3"))) NULL else rownames(x) } # print a reminder if exhaustive pruning will be slow possibly.print.exhaustive.pruning.reminder <- function(nprune, trace, bx, bx.cond) { nsubsets <- 0 # approx, assumes brute force exhaustive search for(subset.size in seq_len(nprune)) nsubsets <- nsubsets + choose(ncol(bx), subset.size) if(trace >= 1 || nsubsets > 1e9) { cat0("Exhaustive pruning: number of subsets ", format(nsubsets, digits=2), " bx sing val ratio ", format(bx.cond, digits=2), "\n") } } # If pmethod is exhaustive and bx is ill conditioned, change pmethod to # backward. This prevents leaps.exhaustive returning error code -999. # # Note that bx should never be ill-conditioned (RegressAndFix should # take care of that). However it seems that dqrdc2 (called by # RegressAndFix) does not detect certain types of ill conditioning (with # any tol). This is probably because we are near the numerical noise floor # and the column norms in dqrdc are not monotically decreasing. # This change was made in Apr 2011. # # TODO This would be better handled by simply removing collinear cols in bx? preprocess.exhaustive <- function(pmethod, nprune, Exhaustive.tol, trace, bx) { pmethod <- "exhaustive" check.numeric.scalar(Exhaustive.tol) if(Exhaustive.tol < 0 || Exhaustive.tol > .1) stop0("illegal Exhaustive.tol ", Exhaustive.tol, ", try something like Exhaustive.tol=1e-8") sing.vals <- svd(bx)$d # expensive bx.cond <- sing.vals[length(sing.vals)] / sing.vals[1] if(is.na(bx.cond) || bx.cond < Exhaustive.tol) { trace1(trace, "\n") warning0("forced pmethod=\"backward\" ", "(bx is ill conditioned, sing val ratio ", format(bx.cond, digits=2), ")") trace1(trace, "\n") pmethod <- "backward" } if(pmethod == "exhaustive") possibly.print.exhaustive.pruning.reminder(nprune, trace, bx, bx.cond) pmethod } print_earth_fit_args <- function(trace, x, y) { 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(x, "x", tracex, details=details) if(details > 1) printf("\n") print_summary(y, "y", tracex, details=details) if(details > 1) printf("\n") } } print_scaled_y <- function(trace, Scale.y, y) { if(trace >= 5 && trace < 7) { # don't print matrices when doing very detailed earth.c tracing if(!Scale.y) printf("\nScale.y = FALSE\n\n") else { printf("\nScale.y = TRUE: yscale %s ycenter %s\n\n", paste.trunc(format(attr(y, "scaled:scale"), digits=5)), paste.trunc(format(attr(y, "scaled:center"), digits=5))) 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(y, "yscaled", tracex, details=details) if(details > 1) printf("\n") } } } print_linpreds <- function(linpreds, x) { if(any(linpreds != 0)) { cat("Linear predictors ") colnames. <- colnames(x) index <- (1:length(linpreds))[linpreds] if(!is.null(colnames.)) cat(paste(index, "=", colnames.[linpreds], sep="", collapse=" ")) else cat(paste.collapse((1:length(linpreds))[linpreds])) cat("\n") } } print_pruning_pass <- function(trace, pmethod, penalty, nprune, selected.terms, prune.terms, rss.per.subset, gcv.per.subset, dirs) { nselected <- length(selected.terms) prev.grsq <- 0 if(trace >= 3 && trace <= 7) { cat("Subset size GRSq RSq DeltaGRSq nPreds") if(trace >= 4) cat(" Terms (col nbr in bx)") cat("\n") for(iterm in seq_along(rss.per.subset)) { grsq <- get.rsq(gcv.per.subset[iterm], gcv.per.subset[1]) delta.grsq <- grsq - prev.grsq prev.grsq <- grsq selected <- prune.terms[iterm,] selected <- selected[selected != 0] cat0(if(iterm==nselected) "chosen " else " ", format(iterm, width=4), sprint("%12.4f ", grsq), sprint("%7.4f", get.rsq(rss.per.subset[iterm], rss.per.subset[1])), sprint("%11.4f ", delta.grsq), sprint("%6d", get.nused.preds.per.subset(dirs, selected)), " ") if(trace >= 4) cat(selected) cat("\n") } cat("\n") } if(trace >= 5 && (pmethod == "backward" || pmethod == "forward")) check.one.term.per.step(prune.terms) if(trace >= 1) { cat0("Prune ", pmethod, " penalty ", penalty) if(pmethod != "cv") cat0(" nprune ", if(is.null(nprune)) "null" else nprune) cat0(": selected ", nselected, " of ") selected <- prune.terms[nselected,] selected <- selected[selected != 0] cat(nrow(dirs), "terms, and", get.nused.preds.per.subset(dirs, selected), "of", ncol(dirs), "preds\n") cat0("After pruning pass GRSq ", format(get.rsq(gcv.per.subset[nselected], gcv.per.subset[1]), digits=3), " RSq ", format(get.rsq(rss.per.subset[nselected], rss.per.subset[1]), digits=3), "\n") } } # This is called pruning.pass (not backward.pass) because pmethod may not be "backward". # # Note that pmethod="none" is equivalent to "backward" except that by # default it retains all the terms created by the forward pass. If nprune # is specified, then it selects the terms that backward would have # selected if backward selected nprune terms. # # If pmethod=="cv" we first do a normal pmethod="backward" pass with nprune=nterms, # then select the subset using the nprune passed to this routine, rather than # with the GCV. The nprune passed to this routine will be machine generated # as the nprune that gives the max mean oof rsq. pruning.pass <- function(x, y, bx, # x, y, and bx are weighted if weights arg was used pmethod, penalty, nprune, trace, dirs, Force.xtx.prune, Exhaustive.tol) { stopifnot(nrow(bx) == nrow(y)) nterms <- nrow(dirs) check.integer.scalar(nprune, null.ok=TRUE, min=1) nprune.org <- nprune if(is.null(nprune) || pmethod=="cv") nprune <- nterms else trace1(trace, "nprune=%g\n", nprune) nprune <- min(nprune, nterms) if(pmethod == "exhaustive") pmethod <- preprocess.exhaustive(pmethod, nprune, Exhaustive.tol, trace, bx) flush.console() # make sure previous messages get seen, pruning make take a while rv <- eval.model.subsets(bx, y, pmethod=if(pmethod=="cv") "backward" else pmethod, nprune, Force.xtx.prune, trace) rss.per.subset <- rv$rss.per.subset # RSS for each subset (across all responses) prune.terms <- rv$prune.terms # each row is a vec of term indices stopifnot(length(rss.per.subset) <= nprune) nprune <- length(rss.per.subset) prune.terms <- prune.terms[seq_len(nprune), seq_len(nprune), drop=FALSE] stopifnot(all(prune.terms[,1] == 1)) # check intercept column gcv.per.subset <- get.gcv(rss.per.subset, seq_len(nprune), penalty, nrow(bx)) if(!all(is.finite(rss.per.subset))) warning0("earth: non finite RSS in model subsets ", "(see the rss.per.subset returned by earth)") check.vec(rss.per.subset, "rss.per.subset") selected.terms <- seq_len(nprune) # all terms if(pmethod == "cv") { # choose the subset at the nprune passed to this routine check.integer.scalar(nprune.org, min=1, max=nterms) selected.terms <- prune.terms[nprune.org,] selected.terms <- selected.terms[selected.terms != 0] } else if(pmethod != "none") { # choose the subset which has the lowest GCV in the vector of GCVS selected.terms <- prune.terms[which.min(gcv.per.subset),] selected.terms <- selected.terms[selected.terms != 0] } print_pruning_pass(trace, pmethod, penalty, nprune.org, selected.terms, prune.terms, rss.per.subset, gcv.per.subset, dirs) list(bx = bx, rss.per.subset = rss.per.subset, # vector of RSSs for each model (index on subset size) gcv.per.subset = gcv.per.subset, # vector of GCVs for each model (index on subset size) prune.terms = prune.terms, # triang mat: each row is a vector of term indices selected.terms = selected.terms) # vec of model terms in best model } # Return an index vector suitable for indexing into object$coefficients # and ordered using the specified "decomp": # # "none" Order the terms as created during the earth forward pass # # "anova" Order the terms using the "anova decomposition" # i.e. in increasing order of interaction # # The first arg is actually an object but called x for consistency with generic reorder.earth <- function( x = stop("no 'x' argument"), which.terms = x$selected.terms, decomp = c("anova", "none"), degree = 99, # max degree, 0 returns just the intercept min.degree = 0, ...) # unused { warn.if.dots(...) if(degree < 0) stop0("degree ", degree, " < 0") if(min.degree < 0) stop0("min.degree ", min.degree, " < 0") if(degree < min.degree) stop0("degree ", degree, " < min.degree ", min.degree) check.which.terms(x$dirs, which.terms) dirs <- x$dirs[which.terms, , drop=FALSE] new.order <- switch(match.arg1(decomp, "decomp"), anova = reorder.terms.anova( dirs, x$cuts[which.terms,,drop=FALSE]), none = 1:length(which.terms)) degrees <- get.degrees.per.term(dirs[new.order, , drop=FALSE]) new.order[degrees >= min.degree & degrees <= degree] } # return a vector of term numbers, ordered as per the "anova" decomposition reorder.terms.anova <- function(dirs, cuts) { nterms <- nrow(dirs) key.degrees <- get.degrees.per.term(dirs) # sort first on degree first.fac.order <- double(nterms) # order of first factor key.x <- double(nterms) # order of preds in factors if(nterms > 1) for(i in 2:nterms) { # start at 2 to skip intercept used <- which(dirs[i,] != 0) first.fac.order[i] <- used[1] key.x[i] <- 1e6 * used[1] # 1st factor if(!is.na(used[2])) { # 2nd factor if any key.x[i] <- key.x[i] + 1e3 * used[2] if(!is.na(used[3])) # 3rd factor if any key.x[i] <- key.x[i] + used[3] } } key.linpreds <- double(nterms) # put lin pred factors first key.cuts <- double(nterms) # cut values key.pair <- double(nterms) # put h(5-x1) before h(x1-5) if(nterms > 1) for(i in 2:nterms) { key.linpreds[i] <- -sum(dirs[i, ] == 2) key.cuts[i] <- cuts[i, first.fac.order[i]] ifirst.non.zero <- which(dirs[i, ] != 0)[1] stopifnot(length(ifirst.non.zero) == 1) key.pair[i] <- dirs[i, ifirst.non.zero] == 1 } order(key.degrees, key.linpreds, key.x, key.cuts, key.pair) } # update.earth is based on update.default but: # # a) If a forward pass is needed (i.e. regenerate the earth model # from scratch) then it removes any "Object" argument from the call. # # Conversely, if the forward pass is unneeded (i.e. we just need to # re-prune the earth model) then it adds an "Object" argument to the call. # # The global character vector prune.only.args says which # args are needed only for the pruning pass. # # This default decision to do a forward pass or not can be overridden # with the ponly argument. # # b) This function also handle appropriately objects that were or were # not created using a formula i.e. were created by earth.formula() or # by earth.default(). # # c) This function retrieves x and y from object$x and object$y if need be # and also data, weights, wp, and subset. update.earth <- function( object = stop("no 'object' argument"), formula. = NULL, # formula. is optional ponly = FALSE, # force prune only, no forward pass ..., # dots passed on to earth() evaluate = TRUE) # for compatibility with generic update { check.classname(object, substitute(object), "earth") call <- object$call stopifnot(!is.null(call)) do.forward.pass <- FALSE if(!is.null(formula.)) { if(is.null(call$formula)) stop0("'formula.' argument is not allowed on ", "objects created without a formula") call$formula <- update.formula(formula(object), formula.) do.forward.pass <- TRUE } env <- parent.frame() # TODO should use model.env(object) here? # figure out what trace should be this.call <- match.call() trace <- get.update.arg(this.call$trace, "trace", object, env, trace1=NULL, "update.earth", print.trace=FALSE) trace <- eval.parent(trace) if(is.name(trace)) # TODO needed when called from earth.cv with glm=NULL, why? trace <- eval.parent(trace) if(is.null(trace)) trace <- 0 if(is.name(call$glm)) # TODO needed when called from earth.cv with glm=NULL, why? call$glm <- eval.parent(call$glm) dots <- match.call(expand.dots=FALSE)$... if(length(dots) > 0) { if(anyNA(pmatch(names(dots), prune.only.args))) do.forward.pass <- TRUE else if(!is.null(dots$nfold) || !is.null(call$nfold)) { trace1(trace, "update.earth: forcing forward pass because nfold argument used\n") do.forward.pass <- TRUE } existing <- !is.na(match(names(dots), names(call))) for(i in names(dots)[existing]) # replace existing args call[[i]] <- dots[[i]] if(any(!existing)) { # append new args call <- c(as.list(call), dots[!existing]) call <- as.call(call) } } if(is.null(call$formula)) { call[["x"]] <- get.update.arg(this.call[["x"]], "x", object, env, trace) call[["y"]] <- get.update.arg(this.call[["y"]], "y", object, env, trace) } else call$data <- get.update.arg(this.call$data, "data", object, env, trace) call$subset <- get.update.arg(this.call$subset, "subset", object, env, trace) call$weights <- get.update.arg(this.call$weights, "weights", object, env, trace) call$wp <- get.update.arg(this.call$wp, "wp", object, env, trace) if(check.boolean(ponly)) do.forward.pass <- FALSE call$Object <- if(do.forward.pass) NULL else substitute(object) if(evaluate) eval.parent(call) else call } earth/R/call.dots.R0000644000176200001440000006705013437042521013575 0ustar liggesusers# call.dots.R: functions to handle prefixed dot arguments # # This file provides support for "prefixed" dot arguments. For example in # plotmo(), the user can specify predict.foo=3 as a dots argument. From # the prefix, plotmo recognizes that the argument is for predict, and # passes the argument to predict as foo=3. #----------------------------------------------------------------------------- # call.dots calls function FUNC with special processing of the dot arguments. # # It drops all args in dots matching DROP except those matching # PREFIX and FORMALS, then passes the remaining dot args to function FUNC. # By default FORMALS is the formal arguments of FUNC. # # If argname is prefixed with "force." then ignore any such arg in dots. # Any argname prefixed with "def." can be overridden by a user arg in dots. call.dots <- function( FUNC = NULL, # the function to call ..., PREFIX = NULL, # default NULL means no prefix DROP = "*", # default drops everything except args matching PREFIX KEEP = "PREFIX", TRACE = 0, # for debugging FNAME = if(is.character(FUNC)) FUNC else trunc.deparse(substitute(FUNC)), FORMALS = NULL, # formal args of FUNC (NULL means get automatically, but # can't always do that because because CRAN doesn't allow :::) SCALAR = FALSE, # see argument "scalar" in eval.dotlist CALLARGS = NULL, CALLER = NULL) { stopifnot(is.logical(TRACE) || is.numeric(TRACE), length(TRACE) == 1) TRACE <- as.numeric(TRACE) if(TRACE >= 2) { if(is.null(CALLER)) CALLER <- callers.name() printf("%s invoked call.dots\n", CALLER) } if(is.null(CALLARGS)) CALLARGS <- callargs(call.dots) args <- deprefix(FUNC=FUNC, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME=FNAME, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS) do.call.trace(FUNC, args, FNAME, trace=TRACE) } # A version of call.dots specialized for calling plotting functions. # This drops all args in dots except those matching PREFIX and PLOT.ARGS. call.plot <- function( FUNC = NULL, # same as call.dots ..., PREFIX = NULL, # if not specified, match only PLOT.ARGS TRACE = 0, # same as call.dots FORMALS = NULL, # same as call.dots SCALAR = FALSE) # same as call.dots { fname <- trunc.deparse(substitute(FUNC)) callargs <- callargs(call.plot) caller <- callers.name() # function that invoked call.plot call.dots(FUNC=FUNC, PREFIX=PREFIX, ..., DROP="*", # drop everything KEEP="PREFIX,PLOT.ARGS", # except args matching PREFIX and PLOT.ARGS TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=callargs, CALLER=caller) } deprefix <- function( FUNC = NULL, ..., PREFIX = NULL, DROP = NULL, KEEP = NULL, TRACE = 0, FNAME = if(is.character(FUNC)) FUNC else trunc.deparse(substitute(FUNC)), FORMALS = NULL, SCALAR = FALSE, CALLARGS = NULL) { stopifnot(is.logical(TRACE) || is.numeric(TRACE), length(TRACE) == 1) TRACE <- as.numeric(TRACE) if(!is.null(FUNC)) match.fun(FUNC) # check that FUNC is available and is a function FNAME <- init.fname(FNAME, FUNC, TRACE) higher.caller <- higher.caller.to.deprefix(..., FNAME=FNAME) PREFIX <- init.prefix(PREFIX, FUNC, FNAME) if(is.null(CALLARGS)) CALLARGS <- callargs(deprefix) DROP <- expand.drop(DROP, PREFIX, FUNC, FORMALS) KEEP <- expand.drop(KEEP, PREFIX, FUNC, FORMALS, namedrop="KEEP", callargs=CALLARGS, include.standard.prefixes=TRUE) dots <- match.call(expand.dots=FALSE)$... trace.prolog(TRACE, PREFIX, DROP, KEEP, dots, higher.caller) stopif.unnamed.dot(dots, higher.caller, ...) org.dots <- dots if(!is.null(DROP)) dots[grep(DROP, names(dots))] <- NULL stopifnot(!is.null(KEEP)) for(name in names(org.dots)) if(grepl(KEEP, name)) dots[[name]] <- org.dots[[name]] trace.after.dropkeep(TRACE, dots) args <- deprefix.aux(FUNC, dots, PREFIX, FNAME, FORMALS, TRACE) # workhorse eval.dotlist(args, n=2, scalar=SCALAR) # n=2 for caller of deprefix e.g. call.dots } deprefix.aux <- function(func, dots, prefix, fname, formals, trace) # workhorse { force <- "^force\\." # "force." as a regex def <- "^def\\." # "def." as a regex # change prefix to a regex, "plot." becomes "^plot\." prefix <- paste0("^", gsub(".", "\\.", prefix, fixed=TRUE)) groups <- list() # list with three elements: force, prefix, def args for(pref in c(force, prefix, def)) { # put args matching pref into group, with the prefix pre removed which <- grep(pref, names(dots)) # select only args matching pref group <- dots[which] # put them into the group group <- expand.dotnames(group, pref, func, fname, formals) names(group) <- sub(pref, "", names(group)) # remove prefix groups[[pref]] <- group dots[which] <- NULL # remove args in this group from dots } # dots is now just those arguments which did not have a special prefix dots <- expand.dotnames(dots, prefix="", func, fname) # "" matches anything args <- groups[[def]] # "def." args lowest precedence args <- merge.list(args, dots) # next come remaining dots args <- merge.list(args, groups[[prefix]]) args <- merge.list(args, groups[[force]]) # "force." args overrule all others args <- drop.args.prefixed.with.drop(args) order.args(args, trace) } # Argument names for plot functions. We exclude "overall" par() args like # mfrow that shouldn't be included when calling functions like plot(), # lines(), or text(). # # If specified in a DROP or KEEP string, the actual argument must exactly # match the PLOT.ARGS argument to be dropped or kept --- abreviated actual # args won't be matched (otherwise we would match too much, e.g. an actual # arg "s" would match "srt"). PLOT.ARGS <- c("add", "adj", "bty", "cex", "cex.axis", "cex.lab", "cex.main", "cex.sub", "col", "col.axis", "col.lab", "col.main", "col.sub", "crt", "family", "font", "font", "font.axis", "font.lab", "font.main", "font.sub", "lend", "ljoin", "lmitre", "lty", "lwd", "main", "pch", "srt", "xaxp", "xaxs", "xaxt", "xlab", "xlim", "xlog", "xpd", "yaxp", "yaxs", "yaxt", "ylab", "ylim", "ylog") # Arguments for par(). This list includes all par arguments except # readonly arguments (e.g. cin) and unimplemented arguments (e.g. err). # The actual argname must be an exact match to be recognized (no abbreviations). # Following omitted because they change too much: col, lwd PAR.ARGS <- c("adj", "ann", "ask", "bg", "bty", "cex", "cex.axis", "cex.lab", "cex.main", "cex.sub", "col.axis", "col.lab", "col.main", "col.sub", "crt", "err", "family", "fg", "fig", "fin", "font", "font.axis", "font.lab", "font.main", "font.sub", "lab", "las", "lend", "lheight", "ljoin", "lmitre", "lty", "mai", "mar", "mex", "mfcol", "mfg", "mfrow", "mgp", "mkh", "new", "oma", "omd", "omi", "pch", "pin", "plt", "ps", "pty", "srt", "tck", "tcl", "usr", "xaxp", "xaxs", "xaxt", "xlog", "xpd", "yaxp", "yaxs", "yaxt", "ylbias", "ylog") # Arguments for par() which take a vector value (i.e. length of value is not one). PAR.VEC <- c("fig", "fin", "lab", "mai", "mar", "mfcol", "mfg", "mfrow", "mgp", "oma", "omd", "omi", "pin", "plt", "usr", "xaxp", "yaxp") # Arguments that are used for subplots in plotmo and similar programs. # # Useful for dropping all args that could conceivably be plotting # arguments and will never(?) be a predict() or residuals() argument. # # When "PLOTMO.ARGS" is used in a DROP string, any actual arg _prefixed_ # with any of these is dropped (as opposed to PLOT.ARGS and PAR.ARGS we drop # actual argnames that _exactly_ match argnames in PLOT.ARGS and PAR.ARGS). # # "nresiduals", is for back compat with old versions of plot.earth PLOTMO.ARGS <- c( "caption.", "cex.", "col.", "contour.", "cum.", "degree1.", "degree2.", "density.", "filled.contour.", "font.", "func.", "grid.", "heatmap.", "image.", "jitter.", "legend.", "label.", "level.", "line.", "lines.", "lty.", "lty.", "lwd.", "main.", "mtext.", "nresiduals", "par.", "pch.", "persp.", "plot.", "plotmath.", "qq.", "qqline.", "pt.", "response.", "rug.", "smooth.", "text.", "title.", "vfont.") # from now on in this module function defs are in alphabetic order add.formals.to.drop <- function(drop, func, formals, namedrop) { stopifnot(grepl("FORMALS", drop)) if(is.null(func)) stop0("\"FORMALS\" specified in ", namedrop, ", but FUNC is NULL") formals <- merge.formals(func, formals, must.exist=TRUE) formals <- paste0(formals, collapse=",") # vector to string drop <- sub("FORMALS[,]", "", drop) # remove "FORMALS," from drop paste.drop(">FORMALS", formals, drop) # add the formal args } # Return the names of the actual args passed to the caller of this function, # ignoring args matching formals of the caller and ignoring dots. # # For example, for call.dots(foo, PREFIX="anything", x=1, y=1, ...), this # function returns c("x", "y"), because x and y are in the argument list # in the call to call.dots but don't match any of the formals of call.dots # (as PREFIX does). The "..." is ignored. # TODO if these were forced we wouldn't need the force.argument callargs <- function(func) { # names of arguments passed to the func that invoked callargs # args passed in dots will not appear in names names <- names(sys.call(-1)) names <- names[names != ""] # drop unnamed args # drop formal arguments (typically PREFIX, KEEP, etc.) names[!(names %in% names(formals(func)))] } # return string "a,b,c,d,e" if given c("a", "b,c", "d e") # i.e. white space converted to comma, c() collapsed to single string canonical.drop <- function(drop, namedrop) { drop <- gsub(" +|,+", ",", drop) # convert space or multi commas to comma drop <- gsub("^,+|,+$", "", drop) # drop leading and trailing commas drop <- unlist(strsplit(drop, split=",")) # convert to a vector drop <- paste0(drop, collapse=",") # collapse stopifnot.identifier(drop, namedrop, allow.specials=TRUE) drop } # TODO add this check elsewhere in earth and plotmo too check.regex <- function(s) # check for some common regex errors { if(grepl("||", s, fixed=TRUE)) stop0("\"||\" in following regex matches everything:\n", "\"", s, "\"") if(grepl("^\\|", s)) stop0("\"|\" at the start of the following regex matches everything:\n", "\"", s, "\"") if(grepl("\\|$", s)) stop0("\"|\" at the end of the following regex matches everything:\n", "\"", s, "\"") } # convert drop to a regex, "x,y*,prefix." becomes "^x|^y.*|^prefix\." convert.drop.to.regex <- function(drop) { drop <- gsub(",", "|", drop) # change comma to | drop <- gsub(".", "\\.", drop, fixed=TRUE) # escape period, "plot." becomes "plot\." drop <- gsub("*", ".*", drop, fixed=TRUE) # change * to .* # clean up, for example we now may have "||" in drop which must be changed to "|" for(iter in 1:2) { # two iterations seems sufficient in practice drop <- gsub(" +", "", drop) # delete spaces drop <- sub("^\\|", "", drop) # delete | at at start drop <- sub("^\\|", "", drop) # delete | at at end drop <- gsub("^^", "^", drop, fixed=TRUE) # change ^^ to single ^ drop <- gsub("||", "|", drop, fixed=TRUE) # change || to | } # prepend ^ to match prefixes only, "x|y" becomes "^x|^y" drop <- unlist(strsplit(drop, split="|", fixed=TRUE)) drop <- ifelse(substr(drop, 1, 1) == ">", drop, paste0("^", drop)) drop <- paste0(drop, collapse="|") check.regex(drop) # sanity check for some common regex errors drop } # TODO add to test suite (although this is tested implicitly in the plotmo tests) # what happens if the argname is abbreviated and no formals to match against? drop.args.prefixed.with.drop <- function(args) { for(name in names(args)) if(grepl("^drop\\.", name)) { check.integer.scalar(args[[name]], logical.ok=FALSE, object.name=name) if(args[[name]] != 1) stop0(name, "=1 is not TRUE") args[[name]] <- NULL # drop the drop.xxx argument itself name <- sub("drop.", "", name, fixed=TRUE) # delete "drop." from name # TODO allow dropping if just the prefix of name matches name <- paste0("^", name, "$") # turn it into a regex for exact matching args[grep(name, names(args))] <- NULL # drop args that exactly match name } args } # Only dot names that have the given prefix are considered. Expand the # suffix of each of those dot names to its full formal name using the # standard R argument matching rules. # # Example: with prefix = "persp." and func = persp.default, # "persp.sh" in dots gets expanded to "persp.shade", because # "shade" is the full name of an argument of persp.default. # # Among other things, This makes it possible for deprefix to properly # process two actual argument names that are different but both match # the same formal argument name. # # It also helps prevent downstream name aliasing issues, because here we # can pre-emptively check for argname matching problems, and issue clearer # error messages than the standard R arg matching error messages. expand.dotnames <- function( dots, prefix, # a regex, not a plain string func = NULL, # if NULL then we just check for duplicate args and go home fname, # used only in error messages formals = NULL) # manual additions to the formal arg list of func { stopifnot(is.list(dots)) dot.names <- names(dots) matches <- grep(prefix, dot.names) # indices of arg which match prefix if(length(matches) == 0) return(list()) if(is.null(func)) { duplicated <- which(duplicated(dot.names)) if(length(duplicated)) stop0("argument '", dot.names[duplicated[1]], "' for ", fname, "() is duplicated") return(dots[matches]) } # match against the formal arguments of func stopifnot(!is.null(dot.names)) unexpanded.names <- dot.names formals <- merge.formals(func, formals) for(idot in matches) { # for all arguments which match prefix dot.name <- dot.names[idot] stopifnot(nzchar(dot.name)) raw.prefix <- "" raw.dotname <- dot.name if(nzchar(prefix)) { # strip off the prefix substring in dot.name (we will put it back later) start <- regexpr(prefix, dot.name) stopifnot(start == 1) # prefix matches only prefixes stop <- start + attr(start, "match.length") stopifnot(stop > start) raw.prefix <- substr(dot.name, start=start, stop=stop-1) # as string not regex raw.dotname <- substring(dot.name, first=stop) # dotname with prefix removed } match <- charmatch(raw.dotname, formals) if(anyNA(match)) { # No match, not necessarily a problem assuming FUNC has a dots formal arg. # We will allow FUNC to check for itself later (if someone calls it). NULL } else if(match == 0) { # multiple matches matches <- grep(paste0("^", raw.dotname), formals) stopifnot(length(matches) >= 2) stop0("'", raw.dotname, "' matches both the '", formals[matches[1]], "' and '", formals[matches[2]], "' arguments of ", fname, "()") } else # single match, this is the ideal situation dot.names[idot] <- paste0(raw.prefix, formals[match]) # prepend prefix } stopifnot.expanded.dotnames.unique(dot.names, unexpanded.names, fname, formals, prefix) names(dots) <- dot.names dots } # returned the expanded the drop argument as a regex expand.drop <- function(drop, prefix, func, formals=NULL, # manual additions to the formal arg list of func namedrop="DROP", callargs=NULL, include.standard.prefixes=FALSE) { if(is.null(drop)) { if(include.standard.prefixes) return(paste0("^force.|^def.|^", prefix)) else return(NULL) } drop <- canonical.drop(drop, namedrop) if(drop == "*") return(".*") # regex to match everything # TODO following is helpful in the trace print only if # you put special identifiers AFTER the other identifiers drop <- paste.drop(">EXPLICIT", drop, "") if(length(callargs) > 0) drop <- paste.drop(">CALLARGS,", paste0(callargs, "$", collapse=","), drop) if(include.standard.prefixes) { drop <- sub("PREFIX", "", drop) # delete "PREFIX" from drop, if present drop <- paste.drop(">PREFIX,", prefix, drop) drop <- paste.drop(">STANDARDPREFIXES,", "force.,def.,drop.", drop) } else drop <- paste.drop(">PREFIX,", sub("PREFIX", prefix, drop), "") if(grepl("FORMALS", drop)) drop <- add.formals.to.drop(drop, func, formals, namedrop) temp <- paste.drop(">PLOT_ARGS,", paste0(PLOT.ARGS, "$", collapse=","), "") drop <- sub("PLOT.ARGS", temp, drop) temp <- paste.drop(">PAR_ARGS,", paste0(PAR.ARGS, "$", collapse=","), "") drop <- sub("PAR.ARGS", temp, drop) temp <- paste.drop(">PLOTMO_ARGS,", paste0(PLOTMO.ARGS, collapse=","), "") drop <- sub("PLOTMO.ARGS", temp, drop) convert.drop.to.regex(drop) # convert drop to a regex } higher.call.args <- function(..., CALLX, FNAME) { stopifnot(is.list(CALLX)) CALLX[1] <- NULL # remove fname from CALLX if(CALLX[length(CALLX)] == "...") # remove dots from CALLX CALLX[length(CALLX)] <- NULL args <- eval.dotlist(as.list(CALLX)) # add dots to args, if they are not already in args dots <- as.list(match.call(expand.dots=FALSE)$...) arg.names <- names(args) dot.names <- names(dots) for(i in seq_along(dots)) { if(!(dot.names[i] %in% arg.names)) { list <- list(eval(dots[[i]])) names(list) <- dot.names[i] args <- append(args, list) } } args[[1]] <- as.name(FNAME) list.as.char(args) } # used only for tracing and error messages # TODO simplify this and friends when match.call is working (R 3.2.0) higher.caller.to.deprefix <- function(..., FNAME=FNAME) { # search the stack looking for org caller of prefix e.g. call.plot sys.calls <- sys.calls() ncalls <- length(sys.calls) stopifnot(ncalls > 2) higher.fname <- "FUNC" try.was.used <- FALSE for(i in max(ncalls-10, 1) : ncalls) { fname <- paste(sys.calls[[i]][1]) # TODO is [1] in the correct position? if(grepl("^call\\.|^deprefix", fname)) break if(grepl("^doTry|^try", fname)) try.was.used <- TRUE else higher.fname <- fname } call <- as.list(sys.calls[[i]]) fname <- paste(call[[1]]) if(try.was.used) higher.fname <- paste0(higher.fname, " via try ") # use try here for paranoia args <- try(higher.call.args(..., CALLX=call, FNAME=FNAME), silent=TRUE) if(is.try.err(args)) args <- sprint("%s, ...", FNAME) sprint("%s called %s(%s)", higher.fname, fname, args) } init.fname <- function(FNAME, FUNC, TRACE) { # check deparse(substitute(FUNC)) issued a good function name # e.g. FNAME will be "NULL" if FUNC is NULL if(is.null(FNAME) || length(FNAME) != 1 || FNAME == "NULL") FNAME <- "FUNC" stopifnot.string(FNAME) FNAME <- sub(".*:+", "", FNAME) # graphics::lines becomes lines stopifnot.identifier(FNAME, "FNAME") FNAME } init.prefix <- function(PREFIX, FUNC, FNAME) { if(is.null(PREFIX)) { # automatic prefix, so check that we can generate it safely if(is.null(FUNC)) stop0("PREFIX must be specified when FUNC is NULL") PREFIX <- sub("\\..*$", "", FNAME) # lines.default becomes lines # Was deprefix invoked using FUNC=FUNC or in a try block? # This won't catch all cases of FUNC=unusable.name but it helps # The stopifnot.identifier() below also helps. if(PREFIX %in% c("FUNC", "doTryCatch")) stop0("PREFIX must be specified in this context ", "(because FNAME is \", fname, \")") PREFIX <- paste0(PREFIX, ".") # add a period stopifnot.identifier(PREFIX, "the automatically generated PREFIX") } stopifnot.identifier(PREFIX, "PREFIX", allow.empty=TRUE) if(PREFIX == "") PREFIX <- ">NOPREFIX" # no argname can match this PREFIX } # return a char vector: formal() of func plus names in manform # manform is manually specified formals merge.formals <- function(func, manform, must.exist=FALSE) { formals <- names(formals(func)) if(!is.null(manform)) formals <- c(formals, strsplit(canonical.drop(manform, "manform"), ",")[[1]]) if(must.exist) { if(length(formals) == 0) stop0("\"FORMALS\" specified but formals(FUNC) ", "returned no formal arguments") if(length(formals[formals != "..."]) == 0) stop0("\"FORMALS\" specified but formals(FUNC) returned only \"...\"") } formals <- formals[formals != "..."] # drop arg named "..." in formals, if any sapply(formals, stopifnot.identifier) # check that all names are valid unique(formals) } # Put the "anon" args first in the argument list. # Then put args named "object", "x", etc. at the front of the list # (after the anon args if any). This is necessary because all the # manipulation we have done has sadly done some reordering of the args # (meaning that the order of the args supplied to call.dots is only # partially retained). The names object, x, etc. are usually what we want # at the start for the predict and plot functions used with call.dots. order.args <- function(args, trace) { trace2(trace, "return dotnames ") if(length(args)) { # order anonymous args on their names, then delete their names which <- which(grepl("^anon", names(args))) anon <- args[which] # select args with "anon." prefix args[which] <- NULL # remove them from the arg list anon <- anon[order(names(anon))] # order them on their names trace2(trace, "%s", paste0(names(anon), collapse=" ")) names(anon) <- NULL # delete their names args1 <- anon # anon args go first in the arg list # Put arguments named "object", "x", etc. first (after anon args if any). # We want mfrow and mfcol early so subsequent args like cex have the last say. for(argname in c("object", "x", "y", "type", "main", "xlab", "ylab", "mfrow", "mfcol")) { args1[[argname]] <- args[[argname]] args[[argname]] <- NULL # remove from args } args <- append(args1, args) # append remaining args to the list if(trace >= 2) cat0(paste.collapse(names(args)), "\n") } trace2(trace, "\n") args } # paste.drop("prefix", "", drop) returns "prefix,DROP" # paste.drop("prefix", "x", drop) returns "prefix,x,DROP," # paste.drop("prefix", "x,y", drop) returns "prefix,x,y,DROP," # paste.drop("prefix", c("x","y"), drop) returns "prefix,x,y,DROP," paste.drop <- function(prefix, s, drop) { s <- paste(s, collapse=",") if(nzchar(s)) paste0(prefix, ",", s, ",", drop) else paste0(prefix, ",", drop) } stopif.unnamed.dot <- function(dots, higher.caller, ...) # called from deprefix() { which <- which(names(dots) == "") if(length(which)) { call <- sprint("\n %s\n", paste0(strwrap(higher.caller, width=getOption("width"), exdent=10), collapse="\n")) dot <- dots[[ which[1] ]] env <- parent.frame(2) arg <- try(eval(dot, envir=env, enclos=env), silent=TRUE) if(is.try.err(arg)) # fallback to weaker error message "(argument ..1 is unnamed)" stop0("Unnamed arguments are not allowed here", " (argument ", as.char(dot), " is unnamed)", call) else stop0("Unnamed arguments are not allowed here", "\n The argument's value is ", as.char(arg), call) } } stopifnot.expanded.dotnames.unique <- function(expanded.names, unexpanded.names, fname, formals, prefix) { duplicated <- which(duplicated(expanded.names)) if(length(duplicated) == 0) return() # no duplicates if(is.null(formals)) stop0("argument '", unexpanded.names[duplicated[1]], "' for ", fname, "() is duplicated") else { # a little processing is needed because we want to report the # error using the unexpanded.names, not the expanded names # get the index of the duplicated argument's twin duplicated <- duplicated[1] for(twin in 1:duplicated) if(expanded.names[twin] == expanded.names[duplicated]) break stopifnot(twin < duplicated) # get the formal argument matched by the duplicated arguments match <- charmatch(sub(prefix, "", expanded.names[duplicated]), formals) if(anyNA(match)) # Dot args are duplicated, but don't match any formal arg. Probably # because e.g. force.xlab is specified but force.xlab is also passed # in dots to call.dots (an error in the way call.dots is invoked). stop0("argument '", unexpanded.names[duplicated[1]], "' for ", fname, "() is duplicated") else if(unexpanded.names[twin] == unexpanded.names[duplicated]) # dot args are identical and they both match the formal stop0("argument '", unexpanded.names[duplicated[1]], "' for ", fname, "() is duplicated") else # dot args are not identical but both match the formal stop0("'", unexpanded.names[twin], "' and '", unexpanded.names[duplicated], "' both match the '", formals[match[1]], "' argument of ", fname, "()") } } trace.after.dropkeep <- function(trace, dots) { if(trace >= 2) printf("after DROP and KEEP %s\n", paste.collapse(names(dots))) } trace.prolog <- function(trace, prefix, drop, keep, dots, higher.caller) { if(trace >= 2) { printf.wrap("TRACE %s", higher.caller) printf("\nPREFIX %s\n", prefix) printf("DROP %s\n", if(is.null(drop)) "NULL" else gsub("\\|>", "\n >", drop)) printf("KEEP %s\n", if(is.null(keep)) "NULL" else gsub("\\|>", "\n >", keep)) names <- names(dots) names[which(names=="")] <- "UNNAMED" printf("input dotnames %s\n", paste.collapse(names)) } } earth/MD50000644000176200001440000002024613561510173011673 0ustar liggesusersa3ac08f10e32b1183e066beeb4aa2e3a *DESCRIPTION 5aa79ec1972007b8f7d88e50a785acfe *NAMESPACE f71f3ab51cf4ba1731749f6a46119555 *NEWS 1b32f707cff45fa442f5bcac644aa921 *R/as.char.R be26dc1e4635bf4953204d621592d672 *R/bpairs.R a8a382411b4193cd470e8b26448ad179 *R/call.dots.R 603fad4b5796d460ea897428e7510be4 *R/check.index.R 46e84213d0eb9d5fe9ff59d183266ffd *R/do.par.R 3c28173aa59055555bf5ed7079e0f51b *R/dot.R 4c6d18adedd8fc8f8b00d7e83aa5f53b *R/dotlib.R 1a70ff75a8d4605dafdc25cb9cb1958b *R/earth.R 9486548730f2557b0568e2fadab0d01b *R/earth.cv.R 4507b4d9b5414af51b28a64cffd7912f *R/earth.cv.lib.R 837fc0e07841a901771d50394f545371 *R/earth.glm.R 9bda58af45165858fb71c8e183167a2b *R/earth.leaps.R 4613864f6a19b1851859bfe46a2506a2 *R/earth.methods.R 85b621913cef50f279c2245341402e1c *R/earth.regress.R aa67b6f1757775f2b4e184c3fe06841b *R/earthlib.R 861fba8a34b68a1dd39a3e0f62ab7f14 *R/elegend.R b468ecca4c3738aa2d01b99fbd885b1a *R/evimp.R b3db51152b3f4509a9d8e95c24533110 *R/expand.arg.R 56be31b525f9c5cc1d97eec124804624 *R/format.earth.R 0e0ab780975f24288aa94236ebddef6f *R/lib.R 7f26f04d6f862be62ca51806f962b4d4 *R/mars.to.earth.R a3dc652297d085a62cc8317949037b37 *R/model.matrix.earth.R f0c3d0d81a64557287bb56ad7c0695a6 *R/offset.R 6bdd7d7574d8f58e944af1d22109e2e9 *R/plot.earth.R e878048289005127b67672fcc5352709 *R/plotd.R 8470ea5a094e2d9a0107cb8f96fae67b *R/plotmo.methods.earth.R 1cfc1b501ff98e1209e64390d6355a42 *R/predict.earth.R d7238c97f8b3ec876550beabc15e36ec *R/print.earth.R a7cfa01bdb6be6069eeed7f427df35ee *R/printcall.R c28a335203f548644cb5db09d39d6d61 *R/residuals.earth.R a556d185d5c55facadd00539ab77433c *R/stop.if.dots.R c585abfe33f2b18ad00d5eb0386d99ab *R/varmod.R 01c2996d49ab79c559856d1c0b69fe7c *build/partial.rdb ea521b18189dc9e26e3e8953602656de *data/etitanic.rda 15f5470c6245efd1c6d5e0ed0be996b4 *data/ozone1.rda 80c701f6d86dff4e6d5dab3cab33ae9a *inst/doc/Auto-linpreds-example.pdf 5aee68d64d91e9e057ccd75c076a7468 *inst/doc/earth-notes.pdf 1fb255264b95b9e96a1aab7b96e4987d *inst/doc/earth-varmod.pdf 8ace3b54aa5b3cf62b0f7df1938de8cd *inst/doc/index.html d4aa9fde2958026574fe7ae4d6c7d0b2 *inst/slowtests/README.txt 85c1427c3d7bb2a49d3d9a71f3502581 *inst/slowtests/check.earth.matches.glm.R ad43c84900ba29624c8036c9189e6c04 *inst/slowtests/check.models.equal.R 6bd2ba002669178ea189438b42553291 *inst/slowtests/earth.times.R ae1273233c861e046c04fcf64e9a31fd *inst/slowtests/earth.times.bat 0a8897a3198356dbad32d25b5172f6f1 *inst/slowtests/earth.times.txt 6f853aed92ff695b160d0c7d06dca8c7 *inst/slowtests/make.bat 80387dc1ec999cd4376789be312aed7e *inst/slowtests/test.allowedfunc.R 7daf67097d0383357b95a74dc742ac5f *inst/slowtests/test.allowedfunc.Rout.save bbe18db489bf608b730c90e833936de4 *inst/slowtests/test.allowedfunc.bat 0dac2b45b8553cd7ac2b63ae4040d37e *inst/slowtests/test.big.R 10510e5c3b2d381c2cd317559536c94e *inst/slowtests/test.big.Rout.save 78a30d542d95dbe64050dac58a569a38 *inst/slowtests/test.big.bat 49d33d97a310d48a8c8ab9f5f19e3c79 *inst/slowtests/test.bpairs.R dd1f8ad9f5740ee47003c29afe43aaa4 *inst/slowtests/test.bpairs.Rout.save 382f9445453ce7b9e9db6861e80fcaf8 *inst/slowtests/test.bpairs.bat 84202cf97e9b102e2ed63e269e9ca077 *inst/slowtests/test.cv.R d954e14df1670aaa4d55d6bfb8899d50 *inst/slowtests/test.cv.Rout.save 70ad4d831eb1f26098e12a9adae0c5db *inst/slowtests/test.cv.bat 083b08a1f712f7cc69476ad7196153d2 *inst/slowtests/test.earthc.bat 022071286162c83c2a2dc446dd61c170 *inst/slowtests/test.earthc.c dbaa8a4e093226da7d89f7cb486bf615 *inst/slowtests/test.earthc.mak 921b3d7c359271775d19e782ccfc98a6 *inst/slowtests/test.earthc.out.save 49cfae6fb4c343890baa9d2aed37ad2b *inst/slowtests/test.earthmain.clang.bat fd4e2e426536001a6c04a2757b5646e5 *inst/slowtests/test.earthmain.gcc.bat 01a3b65549e67abf309a2efb892be2ab *inst/slowtests/test.earthmain.gcc64.bat a47317f1e7814f82617c91adf6fd0518 *inst/slowtests/test.earthmain.out.save e1efa51d0584c6eedbbdd75c35bdff84 *inst/slowtests/test.earthmain.vc.bat 7306baea0c61d656121cd743183c8172 *inst/slowtests/test.epilog.R 8bf305a95269c23381aaf87ce8fba278 *inst/slowtests/test.expand.bpairs.R b3d056aacfcc0ef3fd5ca61517cd21df *inst/slowtests/test.expand.bpairs.Rout.save f8b2baf923d565ba17a544ee120bcb87 *inst/slowtests/test.expand.bpairs.bat 0ff34c1be58292d60065612a9762b012 *inst/slowtests/test.full.R 5736ccff6156688c87eb776af99d81ef *inst/slowtests/test.full.Rout.save 2278166a45732e38d5c85f2d13b0b821 *inst/slowtests/test.full.bat be2650065462122a9454a9df7200b8cc *inst/slowtests/test.glm.R 528b3eff3155124070f51b0bab1514bf *inst/slowtests/test.glm.Rout.save 430b684f2fcda1c5ebe6223021ad3e78 *inst/slowtests/test.glm.bat 9b3d8f1bbc3581912075a8f36ffea7f4 *inst/slowtests/test.incorrect.R 096f0d3b74788489dfdf00e5f9db502a *inst/slowtests/test.incorrect.Rout.save b01a55eb3624ebb5b8ac7b0bb1f5a12d *inst/slowtests/test.incorrect.bat d41f0b4b6b022f70b8d0f4f8e858cdaa *inst/slowtests/test.mem.R c355e07929a54c2d693707f52cc62d13 *inst/slowtests/test.mem.Rout.save 4d4cfabd3a04a9cf19d44145e20d1656 *inst/slowtests/test.mem.bat 04ca3a6494493c51742eb0386ae2b94a *inst/slowtests/test.mods.R c47cd3a2fe28a6ebf9957a08fb0e9460 *inst/slowtests/test.mods.Rout.save 8d44b66ce7fabf7be9858bd61fabba42 *inst/slowtests/test.mods.bat f3b824f06536f993e1c6c5e7b9bfb761 *inst/slowtests/test.multresp.R 7ee5e86edd014b9518bef6a2a40b15c0 *inst/slowtests/test.multresp.Rout.save e67a5fc87ce8d79f229d1e680d0ffb44 *inst/slowtests/test.multresp.bat d4611a3fc5185ae66a9593a68ea89a9d *inst/slowtests/test.offset.R b4992c5e6fd5320ced26b687fddda89f *inst/slowtests/test.offset.Rout.save 8e83444edfbde29694fab05366a2fd18 *inst/slowtests/test.offset.bat 48af6e1b160867b5f17d993f9b0e5afc *inst/slowtests/test.plotd.R d128d09011e59747ea8a6feb51807bfd *inst/slowtests/test.plotd.Rout.save 3bbdccbb9e9436d6888412ffa8f68728 *inst/slowtests/test.plotd.bat a322c4dde845a129c0c4338c274e09ee *inst/slowtests/test.pmethod.cv.R 5f73b01a0bf65009d5f0c4fbc1cf022d *inst/slowtests/test.pmethod.cv.Rout.save d8fb1ae8a4defe9a35300059665f2be8 *inst/slowtests/test.pmethod.cv.bat 8e351f3b5c1e757e0dcac1f70284beae *inst/slowtests/test.prolog.R 5413525c57b49037119933fe641d8012 *inst/slowtests/test.varmod.R 62237ee2ae9da3e4ddf88150c3f9475a *inst/slowtests/test.varmod.Rout.save 4e0f39852d1dae6a3bf06a527ffd2971 *inst/slowtests/test.varmod.bat 1e0f343adca8e020d7752b9adc5cfe46 *inst/slowtests/test.varmod.mgcv.R 7dee5782a60ad63764b81f940445360b *inst/slowtests/test.varmod.mgcv.Rout.save ae61ecaa83025056145542f21284ef28 *inst/slowtests/test.varmod.mgcv.bat 279bf3392a2e416317b416e1fd226559 *inst/slowtests/test.weights.R 47b9771293aa7c35291ac6f8493f0d13 *inst/slowtests/test.weights.Rout.save 96cefbe5a3dd789e37ebe8e59644fe8e *inst/slowtests/test.weights.bat 5e8f2c2936cb04affe73d49102b2a151 *man/contr.earth.response.Rd 3e4443bad637d4591473680027b32d16 *man/earth.Rd 33fa895af040abc9a299ed6216459ac5 *man/earth.object.Rd 694715ee325a1f520bc15ace58baaebf *man/etitanic.Rd af099acb1ba78cbbb9ab6550e76f737e *man/evimp.Rd b97f7456181831a838ec529f68651902 *man/expand.bpairs.Rd 7aaa774fd399c524ef39d5befe3e2f77 *man/format.earth.Rd 0a22b304563012fe0eca2b7216956f29 *man/mars.to.earth.Rd 443c720a0aa7616746cb3734a4dc4210 *man/model.matrix.earth.Rd e09844078933def30ba76e56ce99f49b *man/ozone1.Rd 94493653c6109b03804eea785b3b4d2f *man/plot.earth.Rd f856f9ec0fc3d79c80ce02f72618ed04 *man/plot.earth.models.Rd ee59058dbe1c343004fa8f112699e5ea *man/plot.evimp.Rd c9717666d3f944c0b4a1c82fe82dca6d *man/plot.varmod.Rd 7b75810f7a208f7e01da50d1e9702da4 *man/plotd.Rd 34aedd9fc370e912f4c00b600fe0257f *man/predict.earth.Rd 2c0fa176c132c3d02aae8958ddfb6cbf *man/predict.varmod.Rd a5ddd00f50bbe4cdeafdbb5f701c9473 *man/residuals.earth.Rd 3f802ad21d2f7a97cdeabc4bce4d0d55 *man/summary.earth.Rd a8e59cb01becf2ab800c9a05b0ddf2dd *man/update.earth.Rd 00b9be9438906e7c17a611c425c4f1b5 *man/varmod.Rd 8290d2e9740414e315237f0d5d4024bb *src/Makevars a39264c5bc555fbe8ca35a61510b67a4 *src/allowed.c c13959b9ec3e4b2ec8ff2c8755b0f092 *src/allowed.h 4631440d2b543c8b8489aa7615d3759c *src/earth.c aed6035b13ca23745ba1903fa2d1e72a *src/earth.h 0b53801b52ab3c2f26da925b64c5e4cf *src/leaps.f f7b979854bdd049cda5b1e7c1e8ce5c4 *src/leapshdr.f 28308575ea69ad5ceeac8c6eeb337d3c *src/rentries.c 102bf0619953cf80628f770fe5da24ea *tests/README.txt 697b85ac96006ad37f389167033a8db7 *tests/test.earth.R 62f45b5a3eb56106518015409028b4c0 *tests/test.earth.Rout.save earth/inst/0000755000176200001440000000000012506743405012340 5ustar liggesusersearth/inst/slowtests/0000755000176200001440000000000013561364142014406 5ustar liggesusersearth/inst/slowtests/test.prolog.R0000644000176200001440000000310413446221226017004 0ustar liggesusers# test.prolog.R # A safe version of sprintf. # Like sprintf except that %s on NULL prints "NULL" rather than # preventing the entire string from being printed # # e.g. sprintf("abc %s def", NULL) returns an empty string -- a silent failure! # but sprint("abc %s def", NULL) returns "abc NULL def" # # e.g. sprintf("abc %d def", NULL) returns an empty string! # but sprint("abc %d def", NULL) causes an error msg (not a silent failure) sprint <- function(fmt, ...) { dots <- list(...) dots <- lapply(dots, function(e) if(is.null(e)) "NULL" else e) do.call(sprintf, c(fmt, dots)) } printf <- function(fmt, ...) cat(sprint(fmt, ...), sep="") cat0 <- function(...) cat(..., sep="") strip.space <- function(s) gsub("[ \t\n]", "", s) # test that we got an error as expected from a try() call expect.err <- function(object, expected.msg="") { if(class(object)[1] == "try-error") { msg <- attr(object, "condition")$message[1] if(length(grep(expected.msg, msg, fixed=TRUE))) cat0("Got error as expected from ", deparse(substitute(object)), "\n") else stop(sprint("Expected: %s\n Got: %s", expected.msg, substr(msg[1], 1, 1000))) } else stop("Did not get expected error: ", expected.msg) } empty.plot <- function() { plot(0, 0, col=0, bty="n", xaxt="n", yaxt="n", xlab="", ylab="", main="") } options(warn=1) # print warnings as they occur if(!interactive()) postscript(paper="letter") old.par <- par(no.readonly=TRUE) set.seed(2019) earth/inst/slowtests/test.expand.bpairs.R0000644000176200001440000003411113444022766020250 0ustar liggesusers# test.expand.bpairs.R: source("test.prolog.R") library(earth) # 5 cases (11 obs) sex <- factor(c("m","f","f","f","f")) pclass <- factor(c("1st", "2nd", "3rd", "3rd", "3rd")) x.short <- data.frame(dose=1L:5L, numericx=c(1.1,1.2,1.3,1.4,1.5), logicalx=c(TRUE,FALSE,TRUE,FALSE,TRUE), sex=sex, pclass=pclass) y.short <- data.frame(success=c(1,2,3,0,1), fail =c(1,1,1,0,0)) short <- data.frame(x.short, y.short) x.short.unsorted <- x.short[nrow(x.short):1, ] y.short.unsorted <- y.short[nrow(y.short):1, ] short.unsorted <- data.frame(x.short.unsorted, y.short.unsorted) long <- data.frame( success =c( F, T, F, T, T, F, T, T, T, F, T), dose =c( 1L, 1L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 4L, 5L), numericx=c( 1.1, 1.1, 1.2, 1.2, 1.2, 1.3, 1.3, 1.3, 1.3, 1.4, 1.5), logicalx=c( T, T, F, F, F, T, T, T, T, F, T), sex =c( "m", "m", "f", "f", "f", "f", "f", "f", "f", "f", "f"), pclass =c("1st","1st","2nd","2nd","2nd","3rd","3rd","3rd","3rd","3rd","3rd")) bpairs.index <- c(1L, 3L, 6L, 10L, 11L) ynames <- c("success", "fail") check.expanded.bpairs <- function(long.expanded, long.ref, bpairs.index.ref, ynames.ref) { stopifnot(rownames(long.expanded)[1] == "row1.1") # basic sanity check # delete attributes so can check identical stripped.long.expanded <- long.expanded rownames(stripped.long.expanded) <- 1:nrow(long.expanded) attr(stripped.long.expanded, "bpairs.index") <- NULL attr(stripped.long.expanded, "ynames") <- NULL if(!identical(stripped.long.expanded, long.ref)) { printf("\nstripped.long.expanded:\n") print(stripped.long.expanded) printf("\nlong.ref:\n") print(long.ref) printf("\n") printf("class(long.expanded) '%s'\n", class(long.expanded)) for(j in 1:ncol(long.expanded)) printf("class(long.expanded[,%d] %s colname '%s'\n", j, class(long.expanded[,j]), colnames(long.expanded)[j]) printf("\n") printf("class(long.ref) '%s'\n", class(long.ref)) for(j in 1:ncol(long.ref)) printf("class(long.ref[,%d] %s colname '%s'\n", j, class(long.ref[,j]), colnames(long.ref)[j]) printf("\n") printf("attributes(stripped.long.expanded):\n") print(attributes(stripped.long.expanded)) printf("\n") printf("attributes(long.ref):\n") print(attributes(long.ref)) printf("\n") stop("!identical(stripped.long.expanded, long.ref), see above prints") } stopifnot(identical(attr(long.expanded, "bpairs.index"), bpairs.index.ref)) stopifnot(identical(attr(long.expanded, "ynames"), ynames.ref)) } cat("expand.bpairs(x.short, y.short)\n") long.default <- expand.bpairs(x.short, y.short) check.expanded.bpairs(long.default, long, bpairs.index, ynames) long.default.sort <- expand.bpairs(x.short.unsorted, y.short.unsorted, sort=TRUE) attr(long.default.sort, "row.names") <- NULL attr(long.default.sort, "ynames") <- NULL long1 <- long rownames(long1) <- NULL attr(long1, "row.names") <- NULL attr(long1, "bpairs.index") <- NULL stopifnot(all.equal(long.default.sort, long1)) # single predictor "dose" cat("expand.bpairs(expand.bpairs(short$dose, y.short)\n") long.default.dose <- expand.bpairs(short$dose, y.short) colnames(long.default.dose)[2] <- "dose" # needed for check because above produces column name "x" check.expanded.bpairs(long.default.dose, long[,c("success", "dose")], bpairs.index, ynames) # use a two element numeric vector to specify the y columns cat("expand.bpairs(short.data.frame, c(6,7))\n") short.data.frame <- data.frame(x.short, y.short) long.colindex <- expand.bpairs(short.data.frame, c(6,7)) check.expanded.bpairs(long.colindex, long, bpairs.index, ynames) # use a two element numeric vector to specify the y columns, single predictor "dose" cat("expand.bpairs(short.data.frame.dose, c(2,3))\n") short.data.frame.dose <- data.frame(dose=x.short$dose, y.short) long.default.dose <- expand.bpairs(short.data.frame.dose, c(2,3)) check.expanded.bpairs(long.default.dose, long[,c("success", "dose")], bpairs.index, ynames) # use a two element character vector to specify the y columns cat("expand.bpairs(short.data.frame, c(\"success\",\"fail\"))\n") short.data.frame <- data.frame(x.short, y.short) long.charindex <- expand.bpairs(short.data.frame, c("success", "fail")) check.expanded.bpairs(long.charindex, long, bpairs.index, ynames) # use a two element character vector to specify the y columns, single predictor "dose" cat("expand.bpairs(short.data.frame.dose, c(2,3))\n") short.data.frame.dose <- data.frame(dose=x.short$dose, y.short) long.default.charindex.dose <- expand.bpairs(short.data.frame.dose, c(2,3)) check.expanded.bpairs(long.default.charindex.dose, long[,c("success", "dose")], bpairs.index, ynames) expect.err(try(expand.bpairs()), "expand.bpairs: no y argument") expect.err(try(expand.bpairs(short.data.frame.dose)), "expand.bpairs: no y argument") expect.err(try(expand.bpairs(short.data.frame.dose, c(2,3), nonesuch=99)), "expand.bpairs.default: unrecognized argument 'nonesuch'") expect.err(try(expand.bpairs(short.data.frame, c(5,6))), "short.data.frame[,c(5,6)] is not a two-column matrix of binomial pairs") expect.err(try(expand.bpairs(short.data.frame, 1)), "expand.bpairs: bad y argument '1'") expect.err(try(expand.bpairs(short.data.frame, c(1,2,3))), "bad y argument 'c(1, 2, 3)'") expect.err(try(expand.bpairs(short.data.frame, c(1,2))), "expand.bpairs: short.data.frame[,c(1,2)] is not a two-column matrix of binomial pairs") expect.err(try(expand.bpairs(short.data.frame, c(99,100))), "'ycolumns' is out of range, allowed values are 1 to 7") expect.err(try(expand.bpairs(short.data.frame, c("success99", "fail"))), "undefined columns selected") expect.err(try(expand.bpairs(short.data.frame, c("nonesuch", "fail"))), "undefined columns selected") expect.err(try(expand.bpairs(short.data.frame, "nonesuch")), "bad y argument 'nonesuch'") expect.err(try(expand.bpairs(short.data.frame, nonesuch)), "object 'nonesuch' not found") options(warn=2) expect.err(try(expand.bpairs(short.data.frame, c("nonesuch", "fail"))), "\"nonesuch\" in ycolumns does not match any names") expect.err(try(expand.bpairs(short.data.frame, c("fail", "nonesuch99"))), "\"nonesuch99\" in ycolumns does not match any names") expect.err(try(expand.bpairs(short.data.frame, c("", "fail"))), "ycolumns[1] is an empty string \"\"") expect.err(try(expand.bpairs(short.data.frame, c("success", ""))), "ycolumns[2] is an empty string \"\"") options(warn=1) try(expand.bpairs(short.data.frame, c("success", ""))) # check error messages that are issued after the warning # formula cat("expand.bpairs(success.fail~., data=x.short)\n") success.fail <- cbind(success=short$success, fail=short$fail) long.formula.matrix <- expand.bpairs(success.fail~., data=x.short) check.expanded.bpairs(long.formula.matrix, long, bpairs.index, ynames) cat("expand.bpairs(success+fail~., data=x.short)\n") xy.short <- data.frame(y.short, x.short) long.formula <- expand.bpairs(success+fail~., data=xy.short) check.expanded.bpairs(long.formula, long, bpairs.index, ynames) long.formula.sort <- expand.bpairs(x.short, y.short, sort=TRUE) long.formula.sort <- expand.bpairs(x.short.unsorted, y.short.unsorted, sort=TRUE) attr(long.formula.sort, "row.names") <- NULL attr(long.formula.sort, "ynames") <- NULL long1 <- long rownames(long1) <- NULL attr(long1, "row.names") <- NULL attr(long1, "bpairs.index") <- NULL stopifnot(all.equal(long.formula.sort, long1)) expand.bpairs(success+fail+fail~., data=xy.short) # ok, duplicated name gets dropped expect.err(try(expand.bpairs(success~., data=xy.short)), "expand.bpairs: 'success' does not have two columns") expect.err(try(expand.bpairs(success+success~., data=xy.short)), "expand.bpairs: 'success + success' does not have two columns") cat("expand.bpairs(success.fail~., data=x.short)\n") success.fail <- cbind(success=short$success, fail=short$fail) long.formula.matrix <- expand.bpairs(success.fail~., data=x.short) check.expanded.bpairs(long.formula.matrix, long, bpairs.index, ynames) # TODO it's a pity the following doesn't work (issue is in model.frame.default) cat("expand.bpairs(data.frame(success.fail)~., data=x.short)\n") expect.err(try(expand.bpairs(data.frame(success.fail)~., data=x.short)), "invalid type (list) for variable 'data.frame(success.fail)'") # formula, single predictor "dose" cat("expand.bpairs(expand.bpairs(success+fail~dose, data=xy.short)\n") long.formula.dose <- expand.bpairs(success+fail~dose, data=xy.short) check.expanded.bpairs(long.formula.dose, long[,c("success", "dose")], bpairs.index, ynames) trues <- xy.short$success falses <- xy.short$fail cat("expand.bpairs(expand.bpairs(trues+falses~dose, data=x.short)\n") long.formula.dose <- expand.bpairs(trues+falses~~dose, data=xy.short) stopifnot(identical(colnames(long.formula.dose), c("trues", "dose"))) colnames(long.formula.dose) <- c("success", "dose") attr(long.formula.dose, "ynames") <- c("success", "fail") check.expanded.bpairs(long.formula.dose, long[,c("success", "dose")], bpairs.index, ynames) cat("expand.bpairs(expand.bpairs(trues+falses~., data=x.short)\n") long.formula <- expand.bpairs(trues+falses~., data=xy.short) stopifnot(identical(colnames(long.formula), c("trues", "success", "fail", "dose", "numericx", "logicalx", "sex", "pclass"))) cat("expand.bpairs(expand.bpairs(success.fail~dose, data=x.short)\n") long.formula.dose <- expand.bpairs(success.fail~dose, data=x.short) check.expanded.bpairs(long.formula.dose, long[,c("success", "dose")], bpairs.index, ynames) cat("expand.bpairs(expand.bpairs(success.fail~dose, data=xy.short)\n") long.formula.dose <- expand.bpairs(success.fail~dose, data=xy.short) check.expanded.bpairs(long.formula.dose, long[,c("success", "dose")], bpairs.index, ynames) x.short.na <- x.short x.short.na$dose[3] <- NA long.na <- long long.na$dose[6:9] <- NA # formula with NAs in data cat("expand.bpairs(success.fail~., data=x.short.na)\n") long.formula.na <- expand.bpairs(success.fail~., data=x.short.na) check.expanded.bpairs(long.formula.na, long.na, bpairs.index, ynames) # formula with NAs in data, single predictor "dose" cat("expand.bpairs(success.fail~dose., data=x.short.na)\n") long.formula.dose.na <- expand.bpairs(success.fail~dose, data=x.short.na) check.expanded.bpairs(long.formula.dose.na, long.na[,c("success", "dose")], bpairs.index, ynames) expect.err(try(expand.bpairs(nonesuch~., data=x.short)), "object 'nonesuch' not found") expect.err(try(expand.bpairs(dose~., data=x.short)), "'dose' does not have two columns") expect.err(try(expand.bpairs(dose~success.fail, data=x.short)), "'dose' does not have two columns") # # # check Warning: dropping column 'success' from x because it matches a column name in y # # TODO Removed because we (intentionally) no longer give a warning long.formula <- expand.bpairs(success.fail~., data=xy.short) check.expanded.bpairs(long.formula, long, bpairs.index, ynames) # options(warn=2) # # expect.err(try(expand.bpairs(success.fail~., data=xy.short)), "(converted from warning) dropping column 'success' from x because it matches a column name in y") # # options(warn=1) long.formula.dose <- expand.bpairs(success.fail~dose, data=xy.short) check.expanded.bpairs(long.formula.dose, long[,c("success", "dose")], bpairs.index, ynames) old.success.fail <- success.fail success.fail <- 99 expect.err(try(expand.bpairs(success.fail~., data=xy.short)), "variable lengths differ (found for 'success')") success.fail <- old.success.fail # example with short data as a matrix (not a data.frame) short <- matrix(c( 5, 2, 2, 9, 5, 9, 20,20,30,20,20,30), ncol=2) colnames(short) <- c("dose", "temp") success.fail <- matrix(c(1,2,0,2,2,0, 3,3,1,0,1,0), ncol=2) long <- matrix(c( 0, 5, 20, 0, 5, 20, 0, 5, 20, 1, 5, 20, 0, 2, 20, 0, 2, 20, 0, 2, 20, 1, 2, 20, 1, 2, 20, 0, 2, 30, 1, 9, 20, 1, 9, 20, 0, 5, 20, 1, 5, 20, 1, 5, 20, 0, 9, 30), # both rows zero in short data, so treat as a "false", ncol=3, byrow=TRUE) colnames(long) <- c("V1", "dose", "temp") long <- as.data.frame(long) bpairs.index <- c(1L, 5L, 10L, 11L, 13L, 16L) ynames <- c("V1", "V2") long.default <- expand.bpairs(short, success.fail) long.default$V1 <- as.numeric(long.default$V1) # convert TRUE/FALSE to 0/1 check.expanded.bpairs(long.default, long, bpairs.index, ynames) # man page for expand.bpairs example(expand.bpairs) # man page for expand.bpairs, do it manually and check survived <- c(3,2,1,1) died <- c(0,1,2,2) dose <- c(10,10,20,20) sex <- factor(c("male", "female", "male", "female")) short.data <- data.frame(survived, died, dose, sex) long.data <- expand.bpairs(survived + died ~ ., short.data) # returns long form of the data print(long.data) stopifnot(identical(expand.bpairs(data=short.data, y=cbind(survived, died)), long.data)) # equivalent stopifnot(identical(expand.bpairs(short.data, c(1,2)), long.data)) # equivalent stopifnot(identical(expand.bpairs(short.data, c("survived", "died")), long.data)) # equivalent pairs(short.data, main="short.data") pairs(long.data, main="long.data") # test without column names short.unsorted.nocolnames <- short.unsorted colnames(short.unsorted.nocolnames) <- NULL temp <- expand.bpairs(short.unsorted, 6:7) temp.nocolnames <- expand.bpairs(short.unsorted.nocolnames, 6:7) stopifnot(all.equal(colnames(temp.nocolnames), c("true", "X1", "X2", "X3", "X4", "X5"))) colnames(temp.nocolnames) <- colnames(temp) attr(temp, "ynames") <- NULL stopifnot(identical(temp.nocolnames, temp)) source("test.epilog.R") earth/inst/slowtests/test.bpairs.Rout.save0000644000176200001440000024636013560112513020457 0ustar liggesusers> # test.bpairs.R: > > source("test.prolog.R") > source("check.models.equal.R") > source("check.earth.matches.glm.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > data(ozone1) > data(trees) > data(etitanic) > > cat("\n===short and long data===\n") ===short and long data=== > x.short <- data.frame(x1=c(5,2,2,9,5), x2=c(20,20,30,20,20)) > y.short <- data.frame(true=c(1,2,0,2,2), false=c(3,3,1,0,1)) > short <- data.frame(x.short, y.short) > cat("short:\n") short: > print(short) x1 x2 true false 1 5 20 1 3 2 2 20 2 3 3 2 30 0 1 4 9 20 2 0 5 5 20 2 1 > x.long <- data.frame(x1=c( 5, 5, 5, 5, 2, 2, 2, 2, 2, 2, 9, 9, 5, 5, 5), + x2=c(20,20,20,20, 20,20,20,20,20, 30, 20,20, 20, 20, 20)) > y.long <- data.frame(true=c(1,0,0,0, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 0)) > long <- data.frame(x.long, y.long) > cat("long:\n") long: > print(long) x1 x2 true 1 5 20 1 2 5 20 0 3 5 20 0 4 5 20 0 5 2 20 1 6 2 20 1 7 2 20 0 8 2 20 0 9 2 20 0 10 2 30 0 11 9 20 1 12 9 20 1 13 5 20 1 14 5 20 1 15 5 20 0 > true.false <- cbind(true=short$true, false=short$false) > weights.long <- c(4, 4, 4, 4, 5, 5, 5, 5, 5, 1, 2, 2, 3, 3, 3) > > elong <- earth(true~x1+x2, data=long, glm=list(family="binomial"), + linpreds=TRUE, thresh=0, penalty=-1, trace=1) x[15,2] with colnames x1 x2 y[15,1] with colname true, and values 1, 0, 0, 0, 1, 1, 0, 0, 0, 0,... 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.173 RSq 0.173 Prune backward penalty -1 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.173 RSq 0.173 GLM true devratio 0.15 dof 12/14 iters 16 > glong <- glm(true~x1+x2, data=long, family="binomial") > check.earth.matches.glm(elong, glong) check elong vs glong > par(mfrow=c(2,2)) > plotres(elong, do.par=0, which=c(1,3), main="elong", legend.pos="topleft") > empty.plot() > plotres(glong, do.par=0, which=3, main="glong") > par(mfrow=c(2,2)) > plotmo(elong, do.par=0) plotmo grid: x1 x2 5 20 > plotmo(glong, do.par=0) plotmo grid: x1 x2 5 20 > par(old.par) > > eshort <- earth(true.false~x1+x2, data=short, glm=list(family="binomial"), + linpreds=TRUE, thresh=0, penalty=-1, trace=2) x[5,2] with colnames x1 x2 y[5,2] with colnames true false weights used by earth internally: 4, 5, 1, 2, 3 weights passed to glm (which will adjust by rowsums): NULL Response columns true and false are a binomial pair (15 obs in total) yfrac[5,1] with colname true, and values 0.25, 0.4, 0, 1, 0.6667 Linear predictors 1=x1 2=x2 Forward pass: minspan 3 endspan 1 x[5,2] 80 Bytes bx[5,21] 840 Bytes weighted GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.5017 0.5017 0.5017 1 x1 2< 2 1 4 0.5775 0.5775 0.07583 2 x2 20< 3 1 6 0.5775 0.5775 0 - reject (no DeltaRsq) No new term increases RSq (perhaps reached numerical limits) at 5 terms, 3 terms used After forward pass GRSq 0.578 RSq 0.578 Forward pass complete: 5 terms, 3 terms used Prune backward penalty -1 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.578 RSq 0.578 GLM true devratio 0.54 dof 2/4 iters 18 > gshort <- glm(true.false~x1+x2, data=short, family="binomial") > OLD.EARTH <- FALSE # earth prior to version 5.0.0 > MAX.ARG <- if(OLD.EARTH) 1e-6 else 1e-8 > check.earth.matches.glm(eshort, gshort, max=MAX.ARG) check eshort vs gshort > par(mfrow=c(2,2)) > plotres(eshort, do.par=0, which=c(1,3), main="eshort", legend.pos="topleft") > empty.plot() > plotres(gshort, do.par=0, which=3, main="gshort") > par(mfrow=c(2,2)) > plotmo(eshort, do.par=0) plotmo grid: x1 x2 5 20 > plotmo(gshort, do.par=0) plotmo grid: x1 x2 5 20 > par(old.par) > > par(mfrow=c(2,2)) > plot(elong, main="elong: Model Selection", which=c(1, 3), do.par=0, legend.pos="topleft") > plot(eshort, main="eshort: Model Selection", which=c(1, 3), do.par=0, legend.pos="topleft") > par(old.par) > > cat("\n===long data with weights ===\n") ===long data with weights === > elong.weights <- earth(true~x1+x2, data=long, glm=list(family="binomial"), + weights=weights.long, trace=1, + linpreds=TRUE, thresh=0, penalty=-1) x[15,2] with colnames x1 x2 y[15,1] with colname true, and values 1, 0, 0, 0, 1, 1, 0, 0, 0, 0,... earth and glm weights[15]: 4, 4, 4, 4, 5, 5, 5, 5, 5, 1, 2, 2, 3... 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.064 RSq 0.064 Prune backward penalty -1 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.0635 RSq 0.0635 GLM true devratio 0.05 dof 12/14 iters 14 > print(summary(elong.weights)) Call: earth(formula=true~x1+x2, data=long, weights=weights.long, trace=1, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1) GLM coefficients true (Intercept) 28.6833914 x1 0.2283708 x2 -1.4902067 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 75.3529 14 71.4597 12 0.0517 77.46 14 1 Earth selected 3 of 3 terms, and 2 of 2 predictors Termination condition: No new term increases RSq at 3 terms Importance: x1, x2 Weights: 4, 4, 4, 4, 5, 5, 5, 5, 5, 1, 2, 2, 3, 3, 3 Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.8445361 RSS 12.66804 GRSq 0.06351846 RSq 0.06351846 > glong.weights <- glm(true~x1+x2, data=long, family="binomial", + weights=weights.long) > # models match here but in general models with long and short data won't match > check.earth.matches.glm(elong.weights, glong.weights) check elong.weights vs glong.weights > # compare "earth" part of earth-glm model to lm > lm.long.weights <- lm(true~x1+x2, data=long, weights=weights.long) > stopifnot(identical(sort(names(coef(elong.weights))), sort(names(coef(lm.long.weights))))) > stopifnot(identical(sort(coef(elong.weights, type="earth")), sort(coef(lm.long.weights)))) > > cat("\n===short data with weights ===\n") ===short data with weights === > # add an extra row to prevent singularities in glm with a zero weight > short6 <- rbind(short, list(x1=9, x2=10, true=1, false=1)) > true.false6 <- rbind(true.false, c(1,1)) > weights.short6 <- sqrt(1:6) > cat("weights.short6:\n") weights.short6: > print(weights.short6) [1] 1.000000 1.414214 1.732051 2.000000 2.236068 2.449490 > eshort.weights6 <- earth(true.false6~x1+x2, data=short6, glm=list(family="binomial"), + weights=weights.short6, + trace=1, + linpreds=TRUE, thresh=0, penalty=-1) x[6,2] with colnames x1 x2 y[6,2] with colnames true false weights used by earth internally: 4, 7.071, 1.732, 4, 6.708, 4.899 Response columns true and false are a binomial pair (17 obs in total) yfrac[6,1] with colname true, and values 0.25, 0.4, 0, 1, 0.6667, 0.5 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.417 RSq 0.417 Prune backward penalty -1 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.417 RSq 0.417 GLM true devratio 0.34 dof 3/5 iters 4 > print(summary(eshort.weights6)) Call: earth(formula=true.false6~x1+x2, data=short6, weights=weights.short6, trace=1, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1) GLM coefficients true (Intercept) -3.01560815 x1 0.32839481 x2 0.07196558 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 9.99556 5 6.62365 3 0.337 24.38 4 1 Earth selected 3 of 3 terms, and 2 of 2 predictors Termination condition: No new term increases RSq at 3 terms Importance: x1, x2 Weights: 1, 1.414214, 1.732051, 2, 2.236068, 2.44949 Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.1876099 RSS 1.12566 GRSq 0.4166392 RSq 0.4166392 > gshort.weights6 <- glm(true.false6~x1+x2, data=short6, family="binomial", + weights=weights.short6) > print(summary(gshort.weights6)) Call: glm(formula = true.false6 ~ x1 + x2, family = "binomial", data = short6, weights = weights.short6) Deviance Residuals: 1 2 3 4 5 6 -1.0873 0.6551 -1.4395 1.3403 0.7875 -0.7235 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) -3.01561 3.03667 -0.993 0.321 x1 0.32839 0.20696 1.587 0.113 x2 0.07197 0.11426 0.630 0.529 (Dispersion parameter for binomial family taken to be 1) Null deviance: 9.9956 on 5 degrees of freedom Residual deviance: 6.6237 on 3 degrees of freedom AIC: 24.377 Number of Fisher Scoring iterations: 4 > check.earth.matches.glm(eshort.weights6, gshort.weights6, max=1e-6, max.residuals=1e-10) check eshort.weights6 vs gshort.weights6 > > # unweighted (because all weights equal) > cat("weights.short6.reciprocal.of.rowsums:\n") weights.short6.reciprocal.of.rowsums: > eshort.weights6.reciprocal.of.rowsums <- earth(true.false6~x1+x2, data=short6, glm=list(family="binomial"), + weights=1/rowSums(true.false6), + trace=1, + linpreds=TRUE, thresh=0, penalty=-1) x[6,2] with colnames x1 x2 y[6,2] with colnames true false earth and glm: unweighted (because all weights equal) Response columns true and false are a binomial pair (17 obs in total) yfrac[6,1] with colname true, and values 0.25, 0.4, 0, 1, 0.6667, 0.5 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.512 RSq 0.512 Prune backward penalty -1 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.512 RSq 0.512 GLM true devratio 0.41 dof 3/5 iters 4 > print(summary(eshort.weights6.reciprocal.of.rowsums)) Call: earth(formula=true.false6~x1+x2, data=short6, weights=1/rowSums(true.false6), trace=1, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1) GLM coefficients true (Intercept) -2.75047847 x1 0.39024757 x2 0.02659503 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 3.16533 5 1.87393 3 0.408 9.964 4 1 Earth selected 3 of 3 terms, and 2 of 2 predictors Termination condition: No new term increases RSq at 3 terms Importance: x1, x2 Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.04836798 RSS 0.2902079 GRSq 0.5119899 RSq 0.5119899 > gshort.weights6.reciprocal.of.rowsums <- glm(true.false6~x1+x2, data=short6, family="binomial", + weights=1/rowSums(true.false6)) > print(summary(gshort.weights6.reciprocal.of.rowsums)) Call: glm(formula = true.false6 ~ x1 + x2, family = "binomial", data = short6, weights = 1/rowSums(true.false6)) Deviance Residuals: 1 2 3 4 5 6 -0.3818 0.4800 -0.7346 0.6962 0.4692 -0.5032 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) -2.7505 6.9971 -0.393 0.694 x1 0.3902 0.4964 0.786 0.432 x2 0.0266 0.2387 0.111 0.911 (Dispersion parameter for binomial family taken to be 1) Null deviance: 3.1653 on 5 degrees of freedom Residual deviance: 1.8739 on 3 degrees of freedom AIC: 9.9642 Number of Fisher Scoring iterations: 4 > check.earth.matches.glm(eshort.weights6.reciprocal.of.rowsums, gshort.weights6.reciprocal.of.rowsums, max=1e-6, max.residuals=1e-10) check eshort.weights6.reciprocal.of.rowsums vs gshort.weights6.reciprocal.of.rowsums > > weights.short6zero <- sqrt(1:6) > weights.short6zero[3] <- 0 > cat("weights.short6zero:\n") weights.short6zero: > print(weights.short6zero) [1] 1.000000 1.414214 0.000000 2.000000 2.236068 2.449490 > eshort.weights6zero <- earth(true.false6~x1+x2, data=short6, glm=list(family="binomial"), + weights=weights.short6zero, + trace=1, + linpreds=TRUE, thresh=0, penalty=-1) x[6,2] with colnames x1 x2 y[6,2] with colnames true false weights used by earth internally: 4, 7.071, 0, 4, 6.708, 4.899 Response columns true and false are a binomial pair (17 obs in total) yfrac[6,1] with colname true, and values 0.25, 0.4, 0, 1, 0.6667, 0.5 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.616 RSq 0.616 Prune backward penalty -1 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.616 RSq 0.616 GLM true devratio 0.54 dof 2/4 iters 4 > print(summary(eshort.weights6zero)) Call: earth(formula=true.false6~x1+x2, data=short6, weights=weights.short6zero, trace=1, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1) GLM coefficients true (Intercept) -5.7222363 x1 0.4061112 x2 0.2067235 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 7.33721 4 3.4012 2 0.536 21.15 4 1 Earth selected 3 of 3 terms, and 2 of 2 predictors Termination condition: No new term increases RSq at 3 terms Importance: x1, x2 Weights: 1, 1.414214, 0, 2, 2.236068, 2.44949 Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.09169144 RSS 0.5501486 GRSq 0.6159334 RSq 0.6159334 > gshort.weights6zero <- glm(true.false6~x1+x2, data=short6, family="binomial", + weights=weights.short6zero) > print(summary(gshort.weights6zero)) Call: glm(formula = true.false6 ~ x1 + x2, family = "binomial", data = short6, weights = weights.short6zero) Deviance Residuals: 1 2 3 4 5 6 -1.4583 0.4750 0.0000 0.9763 0.3096 0.0000 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) -5.7222 3.7137 -1.541 0.1234 x1 0.4061 0.2349 1.729 0.0838 . x2 0.2067 0.1497 1.381 0.1673 --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 7.3372 on 4 degrees of freedom Residual deviance: 3.4012 on 2 degrees of freedom AIC: 21.155 Number of Fisher Scoring iterations: 4 > # max.residuals has to be big because of the way earth handles zero weights > check.earth.matches.glm(eshort.weights6zero, gshort.weights6zero) check eshort.weights6zero vs gshort.weights6zero > > cat("\n===short and long data with hinges===\n") ===short and long data with hinges=== > # test without linpreds=TRUE (to avoid int-only model, need thresh=0, penalty=-1) > elong.hinge <- earth(true~x1+x2, data=long, glm=list(family="binomial"), + thresh=0, penalty=-1) > print(summary(elong.hinge)) Call: earth(formula=true~x1+x2, data=long, glm=list(family="binomial"), thresh=0, penalty=-1) GLM coefficients true (Intercept) 36.033525 x2 -1.816060 h(5-x1) -0.039261 h(x1-5) 4.713438 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 20.7277 14 16.2908 11 0.214 24.29 17 1 Earth selected 4 of 4 terms, and 2 of 2 predictors Termination condition: No new term increases RSq at 4 terms Importance: x1, x2 Number of terms at each degree of interaction: 1 3 (additive model) Earth GCV 0.1942857 RSS 2.914286 GRSq 0.2193878 RSq 0.2193878 > eshort.hinge <- earth(true.false~x1+x2, data=short, glm=list(family="binomial"), + thresh=0, penalty=-1) > print(summary(eshort.hinge)) Call: earth(formula=true.false~x1+x2, data=short, glm=list(family="binomial"), thresh=0, penalty=-1) GLM coefficients true (Intercept) 40.033524 x2 -2.016060 h(5-x1) -0.039261 h(x1-5) 5.297520 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 5.67982 4 1.24295 1 0.781 14.72 19 1 Earth selected 4 of 4 terms, and 2 of 2 predictors Termination condition: No new term increases RSq at 4 terms Importance: x1, x2 Number of terms at each degree of interaction: 1 3 (additive model) Earth GCV 0.05952381 RSS 0.297619 GRSq 0.7334755 RSq 0.7334755 > eshort.hinge2 <- earth(true+false~x1+x2, data=short, glm=list(family="binomial"), + thresh=0, penalty=-1) > check.models.equal(eshort.hinge, eshort.hinge2, "eshort.hinge, eshort.hinge2, ", newdata=short[2:3,]) eshort.hinge, eshort.hinge2, : models not identical Formulas differ: true.false ~ x1 + x2 and: ~true + false + (x1 + x2) eshort.hinge, eshort.hinge2, : glm submodel formula strings are identical: yarg ~ `h(x1-5)` + `h(5-x1)` + x2 eshort.hinge, eshort.hinge2, : but the actual glm submodel formulas differ (classes are "formula" and "formula") eshort.hinge, eshort.hinge2, : glm submodels not identical (but coefs, residuals, fitted.values are the same) eshort.hinge, eshort.hinge2, : Models are equivalent, within numerical tolerances > if(OLD.EARTH) { + stopifnot(identical(eshort.hinge$dirs[order(rownames(eshort.hinge$dirs)),], + elong.hinge$dirs [order(rownames(elong.hinge$dirs)),])) + } else + stopifnot(identical(eshort.hinge$dirs, elong.hinge$dirs)) > > par(mfrow=c(2,2)) > plotres(elong.hinge, do.par=0, which=c(1,3), main="elong.hinge", legend.pos="topleft") > plotres(eshort.hinge, do.par=0, which=c(1,3), main="eshort.hinge", legend.pos="topleft") > > par(mfrow=c(2,2)) > plotmo(elong.hinge, do.par=0, ndiscrete=0) plotmo grid: x1 x2 5 20 > plotmo(eshort.hinge, do.par=0, ndiscrete=0) plotmo grid: x1 x2 5 20 > > par(old.par) > > # test with a y with a binomial pair row with both entries equal to 0 > x.short.with.zeros <- data.frame(x1=c(5,2,2,9,5,9), x2=c(20,20,30,20,20,30)) > y.short.with.zeros <- data.frame(true=c(1,2,0,2,2,0), false=c(3,3,1,0,1,0)) > short.with.zeros <- data.frame(x.short.with.zeros, y.short.with.zeros) > true.false.with.zeros <- cbind(true=short.with.zeros$true, false=short.with.zeros$false) > eshort.with.zeros <- earth(true.false.with.zeros~x1+x2, data=short.with.zeros, glm=list(family="binomial"), + linpreds=TRUE, thresh=0, penalty=-1) > gshort.with.zeros <- glm(true.false.with.zeros~x1+x2, data=short.with.zeros, family="binomial") > check.earth.matches.glm(eshort.with.zeros, gshort.with.zeros) check eshort.with.zeros vs gshort.with.zeros > par(mfrow=c(2,2)) > plotres(eshort.with.zeros, do.par=0, which=c(1,3), main="eshort.with.zeros", legend.pos="topleft") > empty.plot() > plotres(gshort.with.zeros, do.par=0, which=3, main="gshort.with.zeros") > par(mfrow=c(2,2)) > plotmo(eshort.with.zeros, do.par=0, ndiscrete=0) plotmo grid: x1 x2 5 20 > plotmo(gshort.with.zeros, do.par=0, ndiscrete=0) plotmo grid: x1 x2 5 20 > par(old.par) > eshort.with.zeros.plus <- earth(true+false~x1+x2, data=short.with.zeros, glm=list(family="binomial"), + linpreds=TRUE, thresh=0, penalty=-1, trace=1) Using class "Formula" because lhs of formula has terms separated by "+" x[6,2] with colnames x1 x2 y[6,2] with colnames true false Note: Both entries in row 6 of the true and false response are zero weights used by earth internally: 4, 5, 1, 2, 3, 0 Response columns true and false are a binomial pair (15 obs in total) yfrac[6,1] with colname true, and values 0.25, 0.4, 0, 1, 0.6667, 0 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.578 RSq 0.578 Prune backward penalty -1 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.578 RSq 0.578 GLM true devratio 0.54 dof 2/4 iters 18 > check.models.equal(eshort.with.zeros, eshort.with.zeros.plus, "eshort.with.zeros, eshort.with.zeros.plus", newdata=short.with.zeros[2:3,]) eshort.with.zeros, eshort.with.zeros.plus: models not identical Formulas differ: true.false.with.zeros ~ x1 + x2 and: ~true + false + (x1 + x2) eshort.with.zeros, eshort.with.zeros.plus: glm submodel formula strings are identical: yarg ~ x1 + x2 eshort.with.zeros, eshort.with.zeros.plus: but the actual glm submodel formulas differ (classes are "formula" and "formula") eshort.with.zeros, eshort.with.zeros.plus: glm submodels not identical (but coefs, residuals, fitted.values are the same) eshort.with.zeros, eshort.with.zeros.plus: Models are equivalent, within numerical tolerances > > eshort.with.zeros.plus.quasibinomial <- earth(true+false~x1+x2, data=short.with.zeros, glm=list(family="quasibinomial"), + linpreds=TRUE, thresh=0, penalty=-1, trace=1) Using class "Formula" because lhs of formula has terms separated by "+" x[6,2] with colnames x1 x2 y[6,2] with colnames true false Note: Both entries in row 6 of the true and false response are zero weights used by earth internally: 4, 5, 1, 2, 3, 0 Response columns true and false are a binomial pair (15 obs in total) yfrac[6,1] with colname true, and values 0.25, 0.4, 0, 1, 0.6667, 0 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.578 RSq 0.578 Prune backward penalty -1 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.578 RSq 0.578 GLM true devratio 0.54 dof 2/4 iters 18 > check.models.equal(eshort.with.zeros.plus, eshort.with.zeros.plus.quasibinomial, "eshort.with.zeros.plus eshort.with.zeros.plus.quasibinomial", newdata=short.with.zeros[1:3,]) eshort.with.zeros.plus eshort.with.zeros.plus.quasibinomial: models not identical eshort.with.zeros.plus eshort.with.zeros.plus.quasibinomial: glm submodel formula strings are identical: yarg ~ x1 + x2 eshort.with.zeros.plus eshort.with.zeros.plus.quasibinomial: but the actual glm submodel formulas differ (classes are "formula" and "formula") eshort.with.zeros.plus eshort.with.zeros.plus.quasibinomial: glm submodels not identical (but coefs, residuals, fitted.values are the same) eshort.with.zeros.plus eshort.with.zeros.plus.quasibinomial: Models are equivalent, within numerical tolerances > # print(summary(eshort.with.zeros.plus)) > # print(summary(eshort.with.zeros.plus.quasibinomial)) > # print(summary(eshort.with.zeros.plus$glm.list[[1]])) > # print(summary(eshort.with.zeros.plus.quasibinomial$glm.list[[1]])) > > cat("\n===compare with model where yfrac is generated manually===\n") ===compare with model where yfrac is generated manually=== > bpairs.frac <- function(y) + { + stopifnot(NCOL(y) == 2) # binomial pairs y has two columns + stopifnot(is.numeric(y[,1]) ||is.logical(y[,1])) + stopifnot(is.numeric(y[,2]) ||is.logical(y[,2])) + stopifnot(all(y >= 0)) # all y values non-negative + stopifnot(round(y) == y) # all y values integers + weights <- y[,1] + y[,2] + if(length(weights > 1) == 0) + warning("no rows of y sum to greater than 1 (earth will not consider y to be a binomial pair") + y[weights == 0, 2] <- 1 # so all-zero rows will be treated as fraction=0 + # we return y as a one column mat (not a vector) so we can give it a colname + frac <- matrix(y[, 1] / (y[,1] + y[,2]), ncol=1) # fraction true + colnames(frac) <- colnames(y)[1] + nchar <- nchar(colnames(frac)) + if(length(nchar) == 0 || nchar == 0) + colnames(frac) <- "frac" + list(frac=frac, weights=weights) + } > ret <- bpairs.frac(cbind(short.with.zeros$true, short.with.zeros$false)) > print(ret) $frac frac [1,] 0.2500000 [2,] 0.4000000 [3,] 0.0000000 [4,] 1.0000000 [5,] 0.6666667 [6,] 0.0000000 $weights [1] 4 5 1 2 3 0 > stopifnot(identical(colnames(ret$frac), "frac")) # column name added automatically > ret <- bpairs.frac(short.with.zeros[,c("true", "false")]) > print(ret) $frac true [1,] 0.2500000 [2,] 0.4000000 [3,] 0.0000000 [4,] 1.0000000 [5,] 0.6666667 [6,] 0.0000000 $weights [1] 4 5 1 2 3 0 > stopifnot(identical(colnames(ret$frac), "true")) > frac <- ret$frac > weights <- ret$weights > options(warn=2) > # expect warning: non-integer #successes in a binomial glm > expect.err(try(earth(frac~x1+x2, data=short.with.zeros, glm=list(family="binomial"), + linpreds=TRUE, thresh=0, penalty=-1)), "non-integer #successes in a binomial glm") Error in eval(family$initialize) : (converted from warning) non-integer #successes in a binomial glm! Got error as expected from try(earth(frac ~ x1 + x2, data = short.with.zeros, glm = list(family = "binomial"), linpreds = TRUE, thresh = 0, penalty = -1)) > # warning goes away if we use quasibinomial > eshort.with.zeros.frac.quasibinomial <- earth(frac~x1+x2, data=short.with.zeros, weights=weights, glm=list(family="quasibinomial"), + linpreds=TRUE, thresh=0, penalty=-1, trace=1) x[6,2] with colnames x1 x2 y[6,1] with colname frac, and values 0.25, 0.4, 0, 1, 0.6667, 0 earth and glm weights[6]: 4, 5, 1, 2, 3, 0 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.578 RSq 0.578 Prune backward penalty -1 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.578 RSq 0.578 GLM frac devratio 0.54 dof 2/4 iters 18 > options(warn=1) > check.models.equal(eshort.with.zeros.frac.quasibinomial, eshort.with.zeros.plus, "eshort.frac, eshort.with.zeros.plus", newdata=short.with.zeros[2:3,], allow.different.names=TRUE) eshort.frac, eshort.with.zeros.plus: models not identical mod1 coefficients [1] "frac" mod2 coefficients [1] "true" Warning: coefficients has different column names but is otherwise identical, see above messages mod1 residuals [1] "frac" mod2 residuals [1] "true" Warning: residuals has different column names but is otherwise identical, see above messages mod1 predict with no newdata, default type [1] "frac" mod2 predict with no newdata, default type [1] "true" Warning: predict with no newdata, default type has different column names but is otherwise identical, see above messages mod1 predict with no newdata, type="link" [1] "frac" mod2 predict with no newdata, type="link" [1] "true" Warning: predict with no newdata, type="link" has different column names but is otherwise identical, see above messages mod1 predict with no newdata, type="response" [1] "frac" mod2 predict with no newdata, type="response" [1] "true" Warning: predict with no newdata, type="response" has different column names but is otherwise identical, see above messages mod1 predict with no newdata, type="earth" [1] "frac" mod2 predict with no newdata, type="earth" [1] "true" Warning: predict with no newdata, type="earth" has different column names but is otherwise identical, see above messages mod1 predict with newdata, default type [1] "frac" mod2 predict with newdata, default type [1] "true" Warning: predict with newdata, default type has different column names but is otherwise identical, see above messages mod1 predict with newdata, , type="link" [1] "frac" mod2 predict with newdata, , type="link" [1] "true" Warning: predict with newdata, , type="link" has different column names but is otherwise identical, see above messages mod1 predict with newdata, , type="response" [1] "frac" mod2 predict with newdata, , type="response" [1] "true" Warning: predict with newdata, , type="response" has different column names but is otherwise identical, see above messages mod1 predict with newdata, , type="earth" [1] "frac" mod2 predict with newdata, , type="earth" [1] "true" Warning: predict with newdata, , type="earth" has different column names but is otherwise identical, see above messages Formulas differ: frac ~ x1 + x2 and: ~true + false + (x1 + x2) eshort.frac, eshort.with.zeros.plus: glm submodel formula strings are identical: yarg ~ x1 + x2 eshort.frac, eshort.with.zeros.plus: but the actual glm submodel formulas differ (classes are "formula" and "formula") eshort.frac, eshort.with.zeros.plus: glm submodels not identical (but coefs, residuals, fitted.values are the same) eshort.frac, eshort.with.zeros.plus: Models are equivalent, within numerical tolerances > eshort.with.zeros.frac.binomial <- earth(frac~x1+x2, data=short.with.zeros, weights=weights, glm=list(family="binomial"), + linpreds=TRUE, thresh=0, penalty=-1) > # # compare stats like deviance etc (all identical here except no AIC for quasibinomial, > # # and standard deviations of glm submodels differ) > # cat("eshort.with.zeros.frac.binomial:\n") > # print(summary(eshort.with.zeros.frac.binomial)) > # cat("eshort.with.zeros.frac.quasibinomial:\n") > # print(summary(eshort.with.zeros.frac.quasibinomial)) > # cat("---------------------------------------------------\n") > # print(summary(eshort.with.zeros.frac.binomial$glm.list[[1]])) > # print(summary(eshort.with.zeros.frac.quasibinomial$glm.list[[1]])) > > # lizard data used in McCullagh and Nelder GLM book (2nd ed) > # this has an entry with both responses equal to zero (similar to the above data): > # site.shade diameter.wide height.tall time grahami opalinus > # 11 FALSE TRUE TRUE Mid 0 0 > > cat("\n===lizards===\n") ===lizards=== > > shade <- factor(x=c( + "sun", "sun", "sun", "sun", "sun", "sun", "sun", "sun", "sun", "sun", "sun", "sun", + "shade", "shade", "shade", "shade", "shade", "shade", "shade", "shade", "shade", "shade", "shade", "shade"), + levels=c("sun", "shade")) > diameter.wide <- as.logical(c( + 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, + 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1)) > height.tall <- as.logical(c( + 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1, + 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1)) > time <- factor(x=c( + "Early", "Mid", "Late", + "Early", "Mid", "Late", + "Early", "Mid", "Late", + "Early", "Mid", "Late", + "Early", "Mid", "Late", + "Early", "Mid", "Late", + "Early", "Mid", "Late", + "Early", "Mid", "Late"), + levels=c("Early", "Mid", "Late"), ordered=FALSE) > grahami <- c( + 20, 8, 4, 13, 8, 12, 8, 4, 5, 6, 0, 1, + 34, 69, 18, 31, 55, 13, 17, 60, 8, 12, 21, 4) > opalinus <- c( + 2, 1, 4, 0, 0, 0, 3, 1, 3, 0, 0, 1, 11, + 20, 10, 5, 4, 3, 15, 32, 8, 1, 5, 4) > lizards <- data.frame( + shade=shade, + wide=diameter.wide, + tall=height.tall, + time=time, + grahami=grahami, + opalinus=opalinus) > > grahami.opalinus <- cbind(grahami=lizards$grahami, opalinus=lizards$opalinus) > eliz <- earth(grahami.opalinus~shade+wide+tall+time, + data=lizards, glm=list(family="binomial"), + linpreds=TRUE, thresh=0, penalty=-1, trace=1) x[24,5] with colnames shadeshade wideTRUE tallTRUE timeMid timeLate y[24,2] with colnames grahami opalinus Note: Both entries in row 11 of the grahami and opalinus response are zero weights used by earth internally: 22, 9, 8, 13, 8, 12, 11, 5, 8, 6, 0, 2, 45, 89,... Response columns grahami and opalinus are a binomial pair (564 obs in total) yfrac[24,1] with colname grahami, and values 0.9091, 0.8889, 0.5, 1, 1, 1,... Forward pass term 1, 2, 4, 6, 8, 10, 12 No new term increases RSq (perhaps reached numerical limits) at 11 terms, 6 terms used After forward pass GRSq 0.850 RSq 0.850 Prune backward penalty -1 nprune null: selected 6 of 6 terms, and 5 of 5 preds After pruning pass GRSq 0.85 RSq 0.85 GLM grahami devratio 0.80 dof 17/22 iters 4 > eliz.Formula <- earth(grahami+opalinus~shade+wide+tall+time, + data=lizards, glm=list(family="binomial"), + linpreds=TRUE, thresh=0, penalty=-1, trace=1) Using class "Formula" because lhs of formula has terms separated by "+" x[24,5] with colnames shadeshade wideTRUE tallTRUE timeMid timeLate y[24,2] with colnames grahami opalinus Note: Both entries in row 11 of the grahami and opalinus response are zero weights used by earth internally: 22, 9, 8, 13, 8, 12, 11, 5, 8, 6, 0, 2, 45, 89,... Response columns grahami and opalinus are a binomial pair (564 obs in total) yfrac[24,1] with colname grahami, and values 0.9091, 0.8889, 0.5, 1, 1, 1,... Forward pass term 1, 2, 4, 6, 8, 10, 12 No new term increases RSq (perhaps reached numerical limits) at 11 terms, 6 terms used After forward pass GRSq 0.850 RSq 0.850 Prune backward penalty -1 nprune null: selected 6 of 6 terms, and 5 of 5 preds After pruning pass GRSq 0.85 RSq 0.85 GLM grahami devratio 0.80 dof 17/22 iters 4 > gliz <- glm(grahami.opalinus~shade+wide+tall+time, + data=lizards, family="binomial") > check.earth.matches.glm(eliz, gliz, newdata=lizards[c(2:5),]) check eliz vs gliz > check.earth.matches.glm(eliz.Formula, gliz, newdata=lizards[c(2:5),]) check eliz.Formula vs gliz > print(evimp(eliz)) nsubsets gcv rss tallTRUE 5 100.0 100.0 wideTRUE 4 72.6 72.6 timeLate 3 53.3 53.3 shadeshade 2 35.4 35.4 timeMid 1 11.8 11.8 > par(mfrow=c(3,2)) > plotres(eliz, do.par=0, which=c(1,3), main="eliz", legend.pos="topleft") > plotres(eliz.Formula, do.par=0, which=c(1,3), main="eliz.Formula", legend.pos="topleft") > empty.plot() > plotres(gliz, do.par=0, which=3, main="gliz") > par(old.par) > plotmo(eliz, ndiscrete=0, SHOWCALL=TRUE) plotmo grid: shade wide tall time sun FALSE FALSE Early > plotmo(eliz.Formula, ndiscrete=0, SHOWCALL=TRUE) plotmo grid: shade wide tall time sun FALSE FALSE Early > plotmo(gliz, ndiscrete=0, SHOWCALL=TRUE) plotmo grid: shade wide tall time sun FALSE FALSE Early > > cat("\n===incorrect bpairs (error handling for bad data)===\n") ===incorrect bpairs (error handling for bad data)=== > test.incorrect.bpairs <- function(msg, expect.err, trace, y.short) + { + printf("\ntest.incorrect.bpairs: %s\n", msg) + x.short <- data.frame(x1=as.double(1:5)) + short <- data.frame(x.short, y.short) + true.false <- cbind(true=short$true, false=short$false) + if(expect.err) + expect.err(try(earth(true.false~x1, data=short, glm=list(family="binomial"), trace=trace)), "Binomial response (see above): all values should be between 0 and 1, or a binomial pair") + else + earth(true.false~x1, data=short, glm=list(family="binomial"), trace=trace) + } > test.incorrect.bpairs("non integral, greater than 1", expect.err=TRUE, trace=1, + data.frame(true=as.double(c(0,1,0,1,0)), false=as.double(c(1,0,1,0,1.1)))) test.incorrect.bpairs: non integral, greater than 1 x[5,1] with colname x1, and values 1, 2, 3, 4, 5 y[5,2] with colnames true false print(head(y)): true false [1,] 0 1.0 [2,] 1 0.0 [3,] 0 1.0 [4,] 1 0.0 [5,] 0 1.1 Response has two columns but is not a binomial pair because not all values are integers Earth will build two GLM models with responses "true" and "false" print(head(y)): true false [1,] 0 1.0 [2,] 1 0.0 [3,] 0 1.0 [4,] 1 0.0 [5,] 0 1.1 Error : Binomial response (see above): all values should be between 0 and 1, or a binomial pair Response has two columns but is not a binomial pair because not all values are integers Got error as expected from try(earth(true.false ~ x1, data = short, glm = list(family = "binomial"), trace = trace)) > test.incorrect.bpairs("non integral but in range 0...1", expect.err=FALSE, trace=1, + data.frame(true=as.double(c(0,1,0,1,0)), false=as.double(c(1,0,1,0,.1)))) test.incorrect.bpairs: non integral but in range 0...1 x[5,1] with colname x1, and values 1, 2, 3, 4, 5 y[5,2] with colnames true false print(head(y)): true false [1,] 0 1.0 [2,] 1 0.0 [3,] 0 1.0 [4,] 1 0.0 [5,] 0 0.1 Response has two columns but is not a binomial pair because not all values are integers Earth will build two GLM models with responses "true" and "false" Forward pass term 1, 2 GRSq -Inf at 1 term After forward pass GRSq -in RSq 0.363 Prune backward penalty 2 nprune null: selected 1 of 1 terms, and 0 of 1 preds After pruning pass GRSq 0 RSq 0 earth.glm: intercept-only earth model GLM true devratio 0.00 dof 4/4 iters 4 Warning in eval(family$initialize) : non-integer #successes in a binomial glm! GLM false devratio 0.00 dof 4/4 iters 4 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged true 6.73012 4 6.73012 4 0 8.730 4 1 false 6.15275 4 6.15275 4 0 8.738 4 1 Earth selected 1 of 1 terms, and 0 of 1 predictors Termination condition: GRSq -Inf at 1 term Importance: x1-unused Number of terms at each degree of interaction: 1 (intercept only model) Earth GCV RSS GRSq RSq true 0.3750 1.200 0 0 false 0.3525 1.128 0 0 All 0.7275 2.328 0 0 > test.incorrect.bpairs("non integral but in range 0...1", expect.err=FALSE, trace=0, + data.frame(true=as.double(c(0,1,0,1,0)), false=as.double(c(1,0,1,0,.1)))) test.incorrect.bpairs: non integral but in range 0...1 print(head(y)): true false [1,] 0 1.0 [2,] 1 0.0 [3,] 0 1.0 [4,] 1 0.0 [5,] 0 0.1 Response has two columns but is not a binomial pair because not all values are integers Earth will build two GLM models with responses "true" and "false" Warning in eval(family$initialize) : non-integer #successes in a binomial glm! GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged true 6.73012 4 6.73012 4 0 8.730 4 1 false 6.15275 4 6.15275 4 0 8.738 4 1 Earth selected 1 of 1 terms, and 0 of 1 predictors Termination condition: GRSq -Inf at 1 term Importance: x1-unused Number of terms at each degree of interaction: 1 (intercept only model) Earth GCV RSS GRSq RSq true 0.3750 1.200 0 0 false 0.3525 1.128 0 0 All 0.7275 2.328 0 0 > test.incorrect.bpairs("negative value", expect.err=TRUE, trace=1, + data.frame(true=as.double(c(0,1,0,1,0)), false=as.double(c(1,0,1,0,-2)))) test.incorrect.bpairs: negative value x[5,1] with colname x1, and values 1, 2, 3, 4, 5 y[5,2] with colnames true false Response has two columns but is not a binomial pair because some values are negative print(head(y)): true false [1,] 0 1 [2,] 1 0 [3,] 0 1 [4,] 1 0 [5,] 0 -2 Error : Binomial response (see above): all values should be between 0 and 1, or a binomial pair Response has two columns but is not a binomial pair because some values are negative Got error as expected from try(earth(true.false ~ x1, data = short, glm = list(family = "binomial"), trace = trace)) > test.incorrect.bpairs("no rows sum to greater than 1", expect.err=FALSE, trace=1, + data.frame(true=as.double(c(0,1,0,1,0)), false=as.double(c(1,0,1,0,0)))) test.incorrect.bpairs: no rows sum to greater than 1 x[5,1] with colname x1, and values 1, 2, 3, 4, 5 y[5,2] with colnames true false Response has two columns but is not a binomial pair because no rows sum to greater than 1 Earth will build two GLM models with responses "true" and "false" Forward pass term 1, 2 GRSq -Inf at 1 term After forward pass GRSq -in RSq 0.375 Prune backward penalty 2 nprune null: selected 1 of 1 terms, and 0 of 1 preds After pruning pass GRSq 0 RSq 0 earth.glm: intercept-only earth model GLM true devratio 0.00 dof 4/4 iters 4 GLM false devratio 0.00 dof 4/4 iters 4 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged true 6.73012 4 6.73012 4 0 8.73 4 1 false 6.73012 4 6.73012 4 0 8.73 4 1 Earth selected 1 of 1 terms, and 0 of 1 predictors Termination condition: GRSq -Inf at 1 term Importance: x1-unused Number of terms at each degree of interaction: 1 (intercept only model) Earth GCV RSS GRSq RSq true 0.375 1.2 0 0 false 0.375 1.2 0 0 All 0.750 2.4 0 0 > printf("\n") > > #-------------------------------------------------------- > > ldose <- rep(0:5, 2) - 2 # Venables and Ripley 4th edition page 191 > sex <- factor(rep(c("male", "female"), times=c(6,6))) > numdead <- c(1,4,9,13,18,20,0,2,6,10,12,16) > numalive = 20 - numdead > pair <- cbind(numalive, numdead) > # following uses formula not Formula > pairmod <- earth(pair ~ sex + ldose, trace=1, pmethod="none", + glm=list(family=binomial)) x[12,2] with colnames sexmale ldose y[12,2] with colnames numalive numdead earth and glm: unweighted Response columns numalive and numdead are a binomial pair (240 obs in total) yfrac[12,1] with colname numalive, and values 0.95, 0.8, 0.55, 0.35, 0.1, 0... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 3 terms used (DeltaRSq 0) After forward pass GRSq 0.907 RSq 0.981 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.952 RSq 0.981 GLM numalive devratio 0.95 dof 9/11 iters 4 > stopifnot(attr(terms(pairmod), "response") == 1) > stopifnot(is.null(attr(terms(pairmod), "Response"))) > glm.weights <- 1 * c(.8,1,1,.5,1,1,1,1,1,1,1,1) # will change model slightly > pairmod.weights <- earth(pair ~ sex + ldose, weights=glm.weights, + trace=0, pmethod="none", + glm=list(family=binomial)) > # build a model using a global variables > # following uses Formula not formula because of "+" > pairmod2 <- earth(numalive + numdead ~ sex + ldose, trace=1, pmethod="none", + glm=list(family=binomial)) Using class "Formula" because lhs of formula has terms separated by "+" x[12,2] with colnames sexmale ldose y[12,2] with colnames numalive numdead earth and glm: unweighted Response columns numalive and numdead are a binomial pair (240 obs in total) yfrac[12,1] with colname numalive, and values 0.95, 0.8, 0.55, 0.35, 0.1, 0... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 3 terms used (DeltaRSq 0) After forward pass GRSq 0.907 RSq 0.981 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.952 RSq 0.981 GLM numalive devratio 0.95 dof 9/11 iters 4 > stopifnot(attr(terms(pairmod2), "response") == 0) > stopifnot(attr(terms(pairmod2), "Response") == c(1,2)) > check.models.equal(pairmod2, pairmod, "pairmod2, pairmod", newdata=data.frame(sex="male", ldose=3)) pairmod2, pairmod: models not identical Formulas differ: ~numalive + numdead + (sex + ldose) and: pair ~ sex + ldose pairmod2, pairmod: glm submodel formula strings are identical: yarg ~ ldose + sexmale pairmod2, pairmod: but the actual glm submodel formulas differ (classes are "formula" and "formula") pairmod2, pairmod: glm submodels not identical (but coefs, residuals, fitted.values are the same) pairmod2, pairmod: Models are equivalent, within numerical tolerances > plot(pairmod2, info=TRUE, SHOWCALL=TRUE) > pairmod2.weights <- earth(numalive + numdead ~ sex + ldose, weights=glm.weights, + trace=0, pmethod="none", + glm=list(family=binomial)) > plot(pairmod2.weights, info=TRUE, SHOWCALL=TRUE) > check.models.equal(pairmod2.weights, pairmod.weights, "pairmod2.weights, pairmod.weights", newdata=data.frame(sex="male", ldose=3)) pairmod2.weights, pairmod.weights: models not identical Formulas differ: ~numalive + numdead + (sex + ldose) and: pair ~ sex + ldose pairmod2.weights, pairmod.weights: glm submodel formula strings are identical: yarg ~ `h(ldose-0)` + `h(0-ldose)` + sexmale pairmod2.weights, pairmod.weights: but the actual glm submodel formulas differ (classes are "formula" and "formula") pairmod2.weights, pairmod.weights: glm submodels not identical (but coefs, residuals, fitted.values are the same) pairmod2.weights, pairmod.weights: Models are equivalent, within numerical tolerances > plotmo(pairmod, SHOWCALL=TRUE) plotmo grid: sex ldose female 0.5 > plotmo(pairmod2, SHOWCALL=TRUE) plotmo grid: sex ldose female 0.5 > > # build a model using a combo of global and data.frame data > df.except.numdead <- data.frame(ldose=ldose, numalive=numalive, sex=sex) > # change global data to invalid values so we can see if we use it by mistake > ldose <- rep(90:95, 2) - 2 # Venables and Ripley 4th edition page 191 > sex <- factor(rep(c("a", "be"), times=c(6,6))) > numalive = NA > # following uses Formula not formula because of "+" > pairmod3 <- earth(numalive + numdead ~ sex + ldose, data=df.except.numdead, trace=0, pmethod="none", + glm=list(family=binomial)) > check.models.equal(pairmod3, pairmod2, "pairmod3, pairmod2", newdata=df.except.numdead[3:4,]) pairmod3, pairmod2: models not identical pairmod3, pairmod2: glm submodel formula strings are identical: yarg ~ ldose + sexmale pairmod3, pairmod2: but the actual glm submodel formulas differ (classes are "formula" and "formula") pairmod3, pairmod2: glm submodels not identical (but coefs, residuals, fitted.values are the same) pairmod3, pairmod2: Models are equivalent, within numerical tolerances > plot(pairmod3, info=TRUE) > plotmo(pairmod3, SHOWCALL=TRUE) plotmo grid: sex ldose female 0.5 > > # build a model using only data from a data.frame > df <- data.frame(df.except.numdead, numdead=numdead) > numdead <- 991:992 # invalidate the global data > # following uses Formula not formula because of "+" > pairmod_Formula <- earth(numalive + numdead ~ sex + ldose, data=df, trace=0, pmethod="none", + glm=list(family=binomial)) > plot(pairmod_Formula, info=TRUE) > check.models.equal(pairmod_Formula, pairmod2, "pairmod_Formula, pairmod2", newdata=df[5:6,]) pairmod_Formula, pairmod2: models not identical pairmod_Formula, pairmod2: glm submodel formula strings are identical: yarg ~ ldose + sexmale pairmod_Formula, pairmod2: but the actual glm submodel formulas differ (classes are "formula" and "formula") pairmod_Formula, pairmod2: glm submodels not identical (but coefs, residuals, fitted.values are the same) pairmod_Formula, pairmod2: Models are equivalent, within numerical tolerances > > expect.err(try(earth(20-numdead+numdead ~ sex + ldose, data=df, glm=list(family=binomial))), "invalid model formula in ExtractVars") Error in terms.formula(paste_formula(NULL, attr(Formula, "lhs"), rsep = "+")) : invalid model formula in ExtractVars Got error as expected from try(earth(20 - numdead + numdead ~ sex + ldose, data = df, glm = list(family = binomial))) > > # following uses formula not Formula > pairmod_formula <- earth(pair ~ sex + ldose, data=df, trace=0, pmethod="none", + glm=list(family=binomial)) > stopifnot(attr(terms(pairmod_formula), "response") == 1) > stopifnot(is.null(attr(terms(pairmod_formula), "Response"))) > check.models.equal(pairmod_formula, pairmod_Formula, "pairmod_Formula, pairmod2", newdata=df[1:3,]) pairmod_Formula, pairmod2: models not identical Formulas differ: pair ~ sex + ldose and: ~numalive + numdead + (sex + ldose) pairmod_Formula, pairmod2: glm submodel formula strings are identical: yarg ~ ldose + sexmale pairmod_Formula, pairmod2: but the actual glm submodel formulas differ (classes are "formula" and "formula") pairmod_Formula, pairmod2: glm submodels not identical (but coefs, residuals, fitted.values are the same) pairmod_Formula, pairmod2: Models are equivalent, within numerical tolerances > > # subset > # build a model using only data from a data.frame > # following uses Formula not formula because of "+" > subset.middle <- seq(from=2, to=nrow(df)-2) > pairmod_Formula_subset <- earth(numalive + numdead ~ sex + ldose, data=df, subset=subset.middle, trace=0, pmethod="none", + glm=list(family=binomial)) > plot(pairmod_Formula_subset, info=TRUE) > > # following uses formula not Formula > pairmod_formula_subset <- earth(pair ~ sex + ldose, data=df, subset=subset.middle, trace=0, pmethod="none", + glm=list(family=binomial)) > stopifnot(attr(terms(pairmod_formula_subset), "response") == 1) > stopifnot(is.null(attr(terms(pairmod_formula_subset), "Response"))) > check.models.equal(pairmod_formula_subset, pairmod_Formula_subset, "pairmod_Formula_subset, pairmod2", newdata=df[1:3,]) pairmod_Formula_subset, pairmod2: models not identical Formulas differ: pair ~ sex + ldose and: ~numalive + numdead + (sex + ldose) pairmod_Formula_subset, pairmod2: glm submodel formula strings are identical: yarg ~ `h(ldose-0)` + `h(0-ldose)` + sexmale pairmod_Formula_subset, pairmod2: but the actual glm submodel formulas differ (classes are "formula" and "formula") pairmod_Formula_subset, pairmod2: glm submodels not identical (but coefs, residuals, fitted.values are the same) pairmod_Formula_subset, pairmod2: Models are equivalent, within numerical tolerances > plot(pairmod_formula_subset, info=TRUE) > plotmo(pairmod_Formula_subset, SHOWCALL=TRUE) plotmo grid: sex ldose male 0 > plotmo(pairmod_formula_subset, SHOWCALL=TRUE) plotmo grid: sex ldose male 0 > > # have to use I() if a minus in a formula that has a plus > pairmod5 <- earth(I(20-numdead) + numdead ~ sex + ldose, data=df, trace=1, pmethod="none", + glm=list(family=binomial)) Using class "Formula" because lhs of formula has terms separated by "+" x[12,2] with colnames sexmale ldose y[12,2] with colnames `I(20-numdead)` numdead earth and glm: unweighted Response columns `I(20-numdead)` and numdead are a binomial pair (240 obs in total) yfrac[12,1] with colname `I(20-numdead)`, and values 0.95, 0.8, 0.55, 0.35, 0.1, 0... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 3 terms used (DeltaRSq 0) After forward pass GRSq 0.907 RSq 0.981 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.952 RSq 0.981 GLM `I(20-numdead)` devratio 0.95 dof 9/11 iters 4 > check.models.equal(pairmod5, pairmod2, "pairmod5, pairmod2", newdata=df[5:6,], allow.different.names=TRUE) pairmod5, pairmod2: models not identical mod1 coefficients [1] "`I(20-numdead)`" mod2 coefficients [1] "numalive" Warning: coefficients has different column names but is otherwise identical, see above messages mod1 residuals [1] "`I(20-numdead)`" mod2 residuals [1] "numalive" Warning: residuals has different column names but is otherwise identical, see above messages mod1 predict with no newdata, default type [1] "`I(20-numdead)`" mod2 predict with no newdata, default type [1] "numalive" Warning: predict with no newdata, default type has different column names but is otherwise identical, see above messages mod1 predict with no newdata, type="link" [1] "`I(20-numdead)`" mod2 predict with no newdata, type="link" [1] "numalive" Warning: predict with no newdata, type="link" has different column names but is otherwise identical, see above messages mod1 predict with no newdata, type="response" [1] "`I(20-numdead)`" mod2 predict with no newdata, type="response" [1] "numalive" Warning: predict with no newdata, type="response" has different column names but is otherwise identical, see above messages mod1 predict with no newdata, type="earth" [1] "`I(20-numdead)`" mod2 predict with no newdata, type="earth" [1] "numalive" Warning: predict with no newdata, type="earth" has different column names but is otherwise identical, see above messages mod1 predict with newdata, default type [1] "`I(20-numdead)`" mod2 predict with newdata, default type [1] "numalive" Warning: predict with newdata, default type has different column names but is otherwise identical, see above messages mod1 predict with newdata, , type="link" [1] "`I(20-numdead)`" mod2 predict with newdata, , type="link" [1] "numalive" Warning: predict with newdata, , type="link" has different column names but is otherwise identical, see above messages mod1 predict with newdata, , type="response" [1] "`I(20-numdead)`" mod2 predict with newdata, , type="response" [1] "numalive" Warning: predict with newdata, , type="response" has different column names but is otherwise identical, see above messages mod1 predict with newdata, , type="earth" [1] "`I(20-numdead)`" mod2 predict with newdata, , type="earth" [1] "numalive" Warning: predict with newdata, , type="earth" has different column names but is otherwise identical, see above messages Formulas differ: ~I(20 - numdead) + numdead + (sex + ldose) and: ~numalive + numdead + (sex + ldose) pairmod5, pairmod2: glm submodel formula strings are identical: yarg ~ ldose + sexmale pairmod5, pairmod2: but the actual glm submodel formulas differ (classes are "formula" and "formula") pairmod5, pairmod2: glm submodels not identical (but coefs, residuals, fitted.values are the same) pairmod5, pairmod2: Models are equivalent, within numerical tolerances > plot(pairmod5, info=TRUE) > > pairmod6a <- earth(numalive + numdead ~ sex + ldose - sex, data=df, trace=1, pmethod="none") Using class "Formula" because lhs of formula has terms separated by "+" x[12,1] with colname ldose, and values -2, -1, 0, 1, 2, 3, -2, -1, 0... y[12,2] with colnames numalive numdead Forward pass term 1, 2, 4 RSq changed by less than 0.001 at 3 terms, 2 terms used (DeltaRSq 0) After forward pass GRSq 0.805 RSq 0.921 Prune none penalty 2 nprune null: selected 2 of 2 terms, and 1 of 1 preds After pruning pass GRSq 0.882 RSq 0.921 > pairmod6b <- earth(numalive + numdead ~ ldose, data=df, trace=1, pmethod="none") Using class "Formula" because lhs of formula has terms separated by "+" x[12,1] with colname ldose, and values -2, -1, 0, 1, 2, 3, -2, -1, 0... y[12,2] with colnames numalive numdead Forward pass term 1, 2, 4 RSq changed by less than 0.001 at 3 terms, 2 terms used (DeltaRSq 0) After forward pass GRSq 0.805 RSq 0.921 Prune none penalty 2 nprune null: selected 2 of 2 terms, and 1 of 1 preds After pruning pass GRSq 0.882 RSq 0.921 > print(summary(pairmod6a)) Call: earth(formula=numalive+numdead~sex+ldose-sex, data=df, pmethod="none", trace=1) numalive numdead (Intercept) 12.571429 7.428571 ldose -3.642857 3.642857 Selected 2 of 2 terms, and 1 of 1 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 2 terms Importance: ldose Number of terms at each degree of interaction: 1 1 (additive model) GCV RSS GRSq RSq numalive 5.89418 39.78571 0.8821359 0.9210992 numdead 5.89418 39.78571 0.8821359 0.9210992 All 11.78836 79.57143 0.8821359 0.9210992 > plot(pairmod6a, nresponse=1) > plotmo(pairmod6a, nresponse=1) plotmo grid: sex ldose female 0.5 > check.models.equal(pairmod6a, pairmod6b, "pairmod6a, pairmod6b", newdata=df[5:6,]) pairmod6a, pairmod6b: models not identical Formulas differ: ~numalive + numdead + (sex + ldose - sex) and: ~numalive + numdead + ldose pairmod6a, pairmod6b: Models are equivalent, within numerical tolerances > > pairmod7 <- earth(numalive + numdead ~ sex * ldose, data=df, trace=1, pmethod="none") Using class "Formula" because lhs of formula has terms separated by "+" x[12,3] with colnames sexmale ldose sexmale:ldose y[12,2] with colnames numalive numdead Forward pass term 1, 2, 4, 6, 8 RSq changed by less than 0.001 at 7 terms, 5 terms used (DeltaRSq 0) After forward pass GRSq -0.057 RSq 0.991 Prune none penalty 2 nprune null: selected 5 of 5 terms, and 3 of 3 preds After pruning pass GRSq 0.883 RSq 0.991 > print(summary(pairmod7)) Call: earth(formula=numalive+numdead~sex*ldose, data=df, pmethod="none", trace=1) numalive numdead (Intercept) 13.9619048 6.0380952 sexmale -2.9794486 2.9794486 ldose -3.2571429 3.2571429 h(0-sexmale:ldose) 0.9533835 -0.9533835 h(sexmale:ldose-0) -0.6639098 0.6639098 Selected 5 of 5 terms, and 3 of 3 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 5 terms Importance: ldose, sexmale, sexmale:ldose Number of terms at each degree of interaction: 1 4 (additive model) GCV RSS GRSq RSq numalive 5.872348 4.404261 0.8825725 0.9912657 numdead 5.872348 4.404261 0.8825725 0.9912657 All 11.744695 8.808521 0.8825725 0.9912657 > plot(pairmod7, nresponse=1) > plotmo(pairmod7, nresponse=1) plotmo grid: sex ldose female 0.5 > > pairmod8 <- earth(numalive + numdead ~ ., data=df, trace=1, pmethod="none", + glm=list(family=binomial)) Using class "Formula" because lhs of formula has terms separated by "+" x[12,2] with colnames ldose sexmale y[12,2] with colnames numalive numdead earth and glm: unweighted Response columns numalive and numdead are a binomial pair (240 obs in total) yfrac[12,1] with colname numalive, and values 0.95, 0.8, 0.55, 0.35, 0.1, 0... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 3 terms used (DeltaRSq 0) After forward pass GRSq 0.907 RSq 0.981 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.952 RSq 0.981 GLM numalive devratio 0.95 dof 9/11 iters 4 > print(summary(pairmod8)) Call: earth(formula=numalive+numdead~., data=df, pmethod="none", trace=1, glm=list(family=binomial)) GLM coefficients numalive (Intercept) 1.344727 ldose -1.064214 sexmale -1.100743 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 124.876 11 6.75706 9 0.946 42.87 4 1 Earth selected 3 of 3 terms, and 2 of 2 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 3 terms Importance: ldose, sexmale Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.005940233 RSS 0.02425595 GRSq 0.952486 RSq 0.9807588 > plot(pairmod8, nresponse=1) > plotmo(pairmod8, nresponse=1) plotmo grid: ldose sex 0.5 female > # following fails because predictors are in a different order in dirs, ok > try(check.models.equal(pairmod8, pairmod2, "pairmod8, pairmod2", newdata=df[5:6,])) pairmod8, pairmod2: models not identical m1 dirs ldose sexmale (Intercept) 0 0 ldose 2 0 sexmale 0 2 m2 dirs sexmale ldose (Intercept) 0 0 ldose 0 2 sexmale 2 0 difference mod1-mod2 dirs ldose sexmale (Intercept) 0 0 ldose 2 -2 sexmale -2 2 Error : dirs don't match, see above messages (max=0) > stopifnot(all.equal(sort(coef(pairmod8)), sort(coef(pairmod2)))) # ok > set.seed(2019) > pairmod.cv <- earth(numalive + numdead ~ ., data=df, nfold=2, trace=1, pmethod="none", + keepxy=TRUE, + glm=list(family=binomial)) Using class "Formula" because lhs of formula has terms separated by "+" x[12,2] with colnames ldose sexmale y[12,2] with colnames numalive numdead earth and glm: unweighted Response columns numalive and numdead are a binomial pair (240 obs in total) yfrac[12,1] with colname numalive, and values 0.95, 0.8, 0.55, 0.35, 0.1, 0... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 3 terms used (DeltaRSq 0) After forward pass GRSq 0.907 RSq 0.981 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.952 RSq 0.981 GLM numalive devratio 0.95 dof 9/11 iters 4 Full model GRSq 0.952 RSq 0.981, starting cross validation CV fold 1 CVRSq 0.778 n.oof 6 50% n.infold.nz 5 83% n.oof.nz 6 100% CV fold 2 CVRSq 0.707 n.oof 6 50% n.infold.nz 6 100% n.oof.nz 5 83% CV all CVRSq 0.743 n.infold.nz 11 92% > check.models.equal(pairmod.cv, pairmod8, "pairmod.cv, pairmod9", newdata=df[3:5,]) pairmod.cv, pairmod9: models not identical pairmod.cv, pairmod9: glm submodel formula strings are identical: yarg ~ ldose + sexmale pairmod.cv, pairmod9: but the actual glm submodel formulas differ (classes are "formula" and "formula") pairmod.cv, pairmod9: glm submodels not identical (but coefs, residuals, fitted.values are the same) pairmod.cv, pairmod9: Models are equivalent, within numerical tolerances > > # TODO following fails, it shouldn't (the minus sign on the rhs messes things up), cf pairmod6a > try(earth(numalive + numdead ~ . - ldose, data=df)) Error in model.matrix.default(mt, data = data, ...) : model frame and formula mismatch in model.matrix() > > newdata.dataframe <- df[1,,drop=FALSE] # data.frame > print(newdata.dataframe) ldose numalive sex numdead 1 -2 19 male 1 > predict.pairmod <- predict(pairmod, newdata.dataframe) > predict.pairmod2 <- predict(pairmod2, newdata.dataframe) > predict.pairmod_Formula <- predict(pairmod_Formula, newdata.dataframe) > predict.pairmod5 <- predict(pairmod5, newdata.dataframe) > check.same(predict.pairmod, 2.372412, max=1e-4) > check.same(predict.pairmod2, predict.pairmod, "predict pairmod2,pairmod with newdata.dataframe") > check.same(predict.pairmod_Formula, predict.pairmod, "predict pairmod_Formula,pairmod2 with newdata.dataframe") > check.same(predict.pairmod5, predict.pairmod, "predict pairmod5,pairmod2 with newdata.dataframe", allow.different.names=TRUE) mod1 predict pairmod5,pairmod2 with newdata.dataframe [1] "`I(20-numdead)`" mod2 predict pairmod5,pairmod2 with newdata.dataframe [1] "numalive" Warning: predict pairmod5,pairmod2 with newdata.dataframe has different column names but is otherwise identical, see above messages > > newdata.vector <- df[1,,drop=TRUE] # list > print(newdata.vector) $ldose [1] -2 $numalive [1] 19 $sex [1] male Levels: female male $numdead [1] 1 > predict.pairmodv <- predict(pairmod, newdata.vector) > predict.pairmod2v <- predict(pairmod2, newdata.vector) > predict.pairmod_Formulav <- predict(pairmod_Formula, newdata.vector) > predict.pairmod5v <- predict(pairmod5, newdata.vector) > check.same(predict.pairmodv, 2.372412, max=1e-4) > check.same(predict.pairmod2v, predict.pairmodv, "predict pairmod2,pairmod with newdata.vector") > check.same(predict.pairmod_Formulav, predict.pairmodv, "predict pairmod_Formula,pairmod2 with newdata.vector") > check.same(predict.pairmod5v, predict.pairmodv, "predict pairmod5,pairmod2 with newdata.vector", allow.different.names=TRUE) mod1 predict pairmod5,pairmod2 with newdata.vector [1] "`I(20-numdead)`" mod2 predict pairmod5,pairmod2 with newdata.vector [1] "numalive" Warning: predict pairmod5,pairmod2 with newdata.vector has different column names but is otherwise identical, see above messages > > plotmo(pairmod_Formula, SHOWCALL=TRUE) plotmo grid: sex ldose female 0.5 > plotmo(pairmod5, SHOWCALL=TRUE) plotmo grid: sex ldose female 0.5 > expect.err(try(plotmo(pairmod2)), "cannot get the original model predictors") # because we deleted ldose, numalive, etc. Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'numdead') (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got error as expected from try(plotmo(pairmod2)) > expect.err(try(plotmo(pairmod2.weights)), "cannot get the original model predictors") # because we deleted ldose, numalive, etc. Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'numdead') (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got error as expected from try(plotmo(pairmod2.weights)) > > expect.err(try(earth(numalive + 20 - numdead ~ sex + ldose, data=df, glm=list(family=binomial))), "Binomial response (see above): all values should be between 0 and 1, or a binomial pair") print(head(y)): numalive+20-numdead [1,] 38 [2,] 32 [3,] 22 [4,] 14 [5,] 4 [6,] 0 Error : Binomial response (see above): all values should be between 0 and 1, or a binomial pair Got error as expected from try(earth(numalive + 20 - numdead ~ sex + ldose, data = df, glm = list(family = binomial))) > > cat("\n===vignette short/long data example===\n") ===vignette short/long data example=== > ldose <- rep(0:5, 2) - 2 # Venables and Ripley 4th edition page 191 > sex <- factor(rep(c("male", "female"), times=c(6,6))) > numdead <- c(1,4,9,13,18,20,0,2,6,10,12,16) > numalive <- 20 - numdead > > glm.short <- glm(cbind(numalive,numdead) ~ ldose + sex, family=binomial) > > earth.short <- earth(cbind(numalive,numdead) ~ ldose + sex, + glm=list(family=binomial)) > > earth.short.lin <- earth(cbind(numalive,numdead) ~ ldose + sex, + glm=list(family=binomial), + # coerce earth to build a linear (no hinge) model with all vars + # (generated model matches the glm.short model above) + linpreds=TRUE, thresh=0, penalty=-1) > > data.short <- data.frame(numalive, numdead, ldose, sex) > > data.long <- expand.bpairs(data.short, c("numalive", "numdead")) > # data.long$num.alive will be a fraction 0...1 > print(data.long) numalive ldose sex row1.1 FALSE -2 male row1.2 TRUE -2 male row1.3 TRUE -2 male row1.4 TRUE -2 male row1.5 TRUE -2 male row1.6 TRUE -2 male row1.7 TRUE -2 male row1.8 TRUE -2 male row1.9 TRUE -2 male row1.10 TRUE -2 male row1.11 TRUE -2 male row1.12 TRUE -2 male row1.13 TRUE -2 male row1.14 TRUE -2 male row1.15 TRUE -2 male row1.16 TRUE -2 male row1.17 TRUE -2 male row1.18 TRUE -2 male row1.19 TRUE -2 male row1.20 TRUE -2 male row2.1 FALSE -1 male row2.2 FALSE -1 male row2.3 FALSE -1 male row2.4 FALSE -1 male row2.5 TRUE -1 male row2.6 TRUE -1 male row2.7 TRUE -1 male row2.8 TRUE -1 male row2.9 TRUE -1 male row2.10 TRUE -1 male row2.11 TRUE -1 male row2.12 TRUE -1 male row2.13 TRUE -1 male row2.14 TRUE -1 male row2.15 TRUE -1 male row2.16 TRUE -1 male row2.17 TRUE -1 male row2.18 TRUE -1 male row2.19 TRUE -1 male row2.20 TRUE -1 male row3.1 FALSE 0 male row3.2 FALSE 0 male row3.3 FALSE 0 male row3.4 FALSE 0 male row3.5 FALSE 0 male row3.6 FALSE 0 male row3.7 FALSE 0 male row3.8 FALSE 0 male row3.9 FALSE 0 male row3.10 TRUE 0 male row3.11 TRUE 0 male row3.12 TRUE 0 male row3.13 TRUE 0 male row3.14 TRUE 0 male row3.15 TRUE 0 male row3.16 TRUE 0 male row3.17 TRUE 0 male row3.18 TRUE 0 male row3.19 TRUE 0 male row3.20 TRUE 0 male row4.1 FALSE 1 male row4.2 FALSE 1 male row4.3 FALSE 1 male row4.4 FALSE 1 male row4.5 FALSE 1 male row4.6 FALSE 1 male row4.7 FALSE 1 male row4.8 FALSE 1 male row4.9 FALSE 1 male row4.10 FALSE 1 male row4.11 FALSE 1 male row4.12 FALSE 1 male row4.13 FALSE 1 male row4.14 TRUE 1 male row4.15 TRUE 1 male row4.16 TRUE 1 male row4.17 TRUE 1 male row4.18 TRUE 1 male row4.19 TRUE 1 male row4.20 TRUE 1 male row5.1 FALSE 2 male row5.2 FALSE 2 male row5.3 FALSE 2 male row5.4 FALSE 2 male row5.5 FALSE 2 male row5.6 FALSE 2 male row5.7 FALSE 2 male row5.8 FALSE 2 male row5.9 FALSE 2 male row5.10 FALSE 2 male row5.11 FALSE 2 male row5.12 FALSE 2 male row5.13 FALSE 2 male row5.14 FALSE 2 male row5.15 FALSE 2 male row5.16 FALSE 2 male row5.17 FALSE 2 male row5.18 FALSE 2 male row5.19 TRUE 2 male row5.20 TRUE 2 male row6.1 FALSE 3 male row6.2 FALSE 3 male row6.3 FALSE 3 male row6.4 FALSE 3 male row6.5 FALSE 3 male row6.6 FALSE 3 male row6.7 FALSE 3 male row6.8 FALSE 3 male row6.9 FALSE 3 male row6.10 FALSE 3 male row6.11 FALSE 3 male row6.12 FALSE 3 male row6.13 FALSE 3 male row6.14 FALSE 3 male row6.15 FALSE 3 male row6.16 FALSE 3 male row6.17 FALSE 3 male row6.18 FALSE 3 male row6.19 FALSE 3 male row6.20 FALSE 3 male row7.1 TRUE -2 female row7.2 TRUE -2 female row7.3 TRUE -2 female row7.4 TRUE -2 female row7.5 TRUE -2 female row7.6 TRUE -2 female row7.7 TRUE -2 female row7.8 TRUE -2 female row7.9 TRUE -2 female row7.10 TRUE -2 female row7.11 TRUE -2 female row7.12 TRUE -2 female row7.13 TRUE -2 female row7.14 TRUE -2 female row7.15 TRUE -2 female row7.16 TRUE -2 female row7.17 TRUE -2 female row7.18 TRUE -2 female row7.19 TRUE -2 female row7.20 TRUE -2 female row8.1 FALSE -1 female row8.2 FALSE -1 female row8.3 TRUE -1 female row8.4 TRUE -1 female row8.5 TRUE -1 female row8.6 TRUE -1 female row8.7 TRUE -1 female row8.8 TRUE -1 female row8.9 TRUE -1 female row8.10 TRUE -1 female row8.11 TRUE -1 female row8.12 TRUE -1 female row8.13 TRUE -1 female row8.14 TRUE -1 female row8.15 TRUE -1 female row8.16 TRUE -1 female row8.17 TRUE -1 female row8.18 TRUE -1 female row8.19 TRUE -1 female row8.20 TRUE -1 female row9.1 FALSE 0 female row9.2 FALSE 0 female row9.3 FALSE 0 female row9.4 FALSE 0 female row9.5 FALSE 0 female row9.6 FALSE 0 female row9.7 TRUE 0 female row9.8 TRUE 0 female row9.9 TRUE 0 female row9.10 TRUE 0 female row9.11 TRUE 0 female row9.12 TRUE 0 female row9.13 TRUE 0 female row9.14 TRUE 0 female row9.15 TRUE 0 female row9.16 TRUE 0 female row9.17 TRUE 0 female row9.18 TRUE 0 female row9.19 TRUE 0 female row9.20 TRUE 0 female row10.1 FALSE 1 female row10.2 FALSE 1 female row10.3 FALSE 1 female row10.4 FALSE 1 female row10.5 FALSE 1 female row10.6 FALSE 1 female row10.7 FALSE 1 female row10.8 FALSE 1 female row10.9 FALSE 1 female row10.10 FALSE 1 female row10.11 TRUE 1 female row10.12 TRUE 1 female row10.13 TRUE 1 female row10.14 TRUE 1 female row10.15 TRUE 1 female row10.16 TRUE 1 female row10.17 TRUE 1 female row10.18 TRUE 1 female row10.19 TRUE 1 female row10.20 TRUE 1 female row11.1 FALSE 2 female row11.2 FALSE 2 female row11.3 FALSE 2 female row11.4 FALSE 2 female row11.5 FALSE 2 female row11.6 FALSE 2 female row11.7 FALSE 2 female row11.8 FALSE 2 female row11.9 FALSE 2 female row11.10 FALSE 2 female row11.11 FALSE 2 female row11.12 FALSE 2 female row11.13 TRUE 2 female row11.14 TRUE 2 female row11.15 TRUE 2 female row11.16 TRUE 2 female row11.17 TRUE 2 female row11.18 TRUE 2 female row11.19 TRUE 2 female row11.20 TRUE 2 female row12.1 FALSE 3 female row12.2 FALSE 3 female row12.3 FALSE 3 female row12.4 FALSE 3 female row12.5 FALSE 3 female row12.6 FALSE 3 female row12.7 FALSE 3 female row12.8 FALSE 3 female row12.9 FALSE 3 female row12.10 FALSE 3 female row12.11 FALSE 3 female row12.12 FALSE 3 female row12.13 FALSE 3 female row12.14 FALSE 3 female row12.15 FALSE 3 female row12.16 FALSE 3 female row12.17 TRUE 3 female row12.18 TRUE 3 female row12.19 TRUE 3 female row12.20 TRUE 3 female > > glm.long <- glm(numalive ~ ldose + sex, data=data.long, family=binomial) > > earth.long <- earth(numalive ~ ldose + sex, data=data.long, + glm=list(family=binomial)) > > earth.long.lin <- earth(numalive ~ ldose + sex, data=data.long, + glm=list(family=binomial), + linpreds=TRUE, thresh=0, penalty=-1) > print(summary(glm.short)) Call: glm(formula = cbind(numalive, numdead) ~ ldose + sex, family = binomial) Deviance Residuals: Min 1Q Median 3Q Max -1.42944 -0.48471 0.02225 0.65343 1.10540 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) 1.3447 0.2797 4.809 1.52e-06 *** ldose -1.0642 0.1311 -8.119 4.70e-16 *** sexmale -1.1007 0.3558 -3.093 0.00198 ** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 124.8756 on 11 degrees of freedom Residual deviance: 6.7571 on 9 degrees of freedom AIC: 42.867 Number of Fisher Scoring iterations: 4 > print(summary(earth.short)) Call: earth(formula=cbind(numalive,numdead)~ldose+sex, glm=list(family=binomial)) GLM coefficients numalive (Intercept) 1.344727 ldose -1.064214 sexmale -1.100743 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 124.876 11 6.75706 9 0.946 42.87 4 1 Earth selected 3 of 3 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: ldose, sexmale Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.005940233 RSS 0.02425595 GRSq 0.952486 RSq 0.9807588 > print(summary(earth.short.lin)) Call: earth(formula=cbind(numalive,numdead)~ldose+sex, glm=list(family=binomial), linpreds=TRUE, thresh=0, penalty=-1) GLM coefficients numalive (Intercept) 1.344727 ldose -1.064214 sexmale -1.100743 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 124.876 11 6.75706 9 0.946 42.87 4 1 Earth selected 3 of 3 terms, and 2 of 2 predictors Termination condition: No new term increases RSq at 3 terms Importance: ldose, sexmale Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.002021329 RSS 0.02425595 GRSq 0.9807588 RSq 0.9807588 > print(summary(glm.long)) Call: glm(formula = numalive ~ ldose + sex, family = binomial, data = data.long) Deviance Residuals: Min 1Q Median 3Q Max -2.2338 -0.5410 0.2472 0.6806 2.0129 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) 1.3447 0.2797 4.809 1.52e-06 *** ldose -1.0642 0.1311 -8.119 4.70e-16 *** sexmale -1.1007 0.3558 -3.093 0.00198 ** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 331.36 on 239 degrees of freedom Residual deviance: 213.24 on 237 degrees of freedom AIC: 219.24 Number of Fisher Scoring iterations: 5 > print(summary(earth.long)) Call: earth(formula=numalive~ldose+sex, data=data.long, glm=list(family=binomial)) GLM coefficients numalive (Intercept) -1.107855 sexmale -1.087416 h(2-ldose) 1.196265 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 331.359 239 215.878 237 0.349 221.9 5 1 Earth selected 3 of 5 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Importance: ldose, sexmale Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.1541512 RSS 35.47083 GRSq 0.3850639 RSq 0.4054752 > print(summary(earth.long.lin)) Call: earth(formula=numalive~ldose+sex, data=data.long, glm=list(family=binomial), linpreds=TRUE, thresh=0, penalty=-1) GLM coefficients numalive (Intercept) 1.344727 ldose -1.064214 sexmale -1.100743 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 331.359 239 213.241 237 0.356 219.2 5 1 Earth selected 3 of 3 terms, and 2 of 2 predictors Termination condition: No new term increases RSq at 3 terms Importance: ldose, sexmale Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.145563 RSS 34.93512 GRSq 0.4144543 RSq 0.4144543 > > print(coef(glm.short)) (Intercept) ldose sexmale 1.344727 -1.064214 -1.100743 > stopifnot(max(coef(earth.short.lin) - coef(glm.short)) < 1e-12) # same > stopifnot(max(coef(glm.long) - coef(glm.short)) < 1e-12) # same > stopifnot(max(coef(earth.long.lin) - coef(glm.short)) < 1e-12) # same > coef(earth.short) # different (Intercept) ldose sexmale 1.344727 -1.064214 -1.100743 > coef(earth.long) # different (Intercept) h(2-ldose) sexmale -1.107855 1.196265 -1.087416 > > cat("\n===cross validated binomial pair model===\n") ===cross validated binomial pair model=== > # use a big enough data set for cross validation without negative GRSqs > n2 <- 20 > set.seed(2019) > good <- pmax(round(c((1:n2),(n2:1)) + rnorm(2*n2)), 0) > bad <- pmax(n2 - good, 0) > data <- data.frame(good, bad, x=1:(2 * n2)) > set.seed(2020) > earth.cv <- earth(good+bad~., data=data, glm=list(family=binomial), trace=1, nfold=2, keepxy=TRUE) Using class "Formula" because lhs of formula has terms separated by "+" x[40,1] with colname x, and values 1, 2, 3, 4, 5, 6, 7, 8, 9, 10... y[40,2] with colnames good bad earth and glm: unweighted Response columns good and bad are a binomial pair (800 obs in total) yfrac[40,1] with colname good, and values 0.1, 0.05, 0.05, 0.25, 0.2, 0... Forward pass term 1, 2, 4, 6, 8, 10, 12 RSq changed by less than 0.001 at 11 terms, 7 terms used (DeltaRSq 0.00011) After forward pass GRSq 0.923 RSq 0.968 Prune backward penalty 2 nprune null: selected 4 of 7 terms, and 1 of 1 preds After pruning pass GRSq 0.949 RSq 0.963 GLM good devratio 0.93 dof 36/39 iters 4 Full model GRSq 0.949 RSq 0.963, starting cross validation CV fold 1 CVRSq 0.923 n.oof 21 48% n.infold.nz 21 100% n.oof.nz 19 100% CV fold 2 CVRSq 0.928 n.oof 19 52% n.infold.nz 19 100% n.oof.nz 21 100% CV all CVRSq 0.926 n.infold.nz 40 100% > cat("cross validated model:\n") cross validated model: > print(summary(earth.cv)) Call: earth(formula=good+bad~., data=data, keepxy=TRUE, trace=1, glm=list(family=binomial), nfold=2) GLM coefficients good (Intercept) 2.6553682 h(20-x) -0.2657911 h(x-23) -0.5420035 h(x-26) 0.3168845 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 324.951 39 23.0641 36 0.929 145 4 1 Earth selected 4 of 7 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 7 terms Importance: x Number of terms at each degree of interaction: 1 3 (additive model) Earth GCV 0.004633736 RSS 0.1261535 GRSq 0.9488392 RSq 0.9633701 CVRSq 0.9256185 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.50 sd 0.71 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd AUC sd MeanDev sd CalibInt sd CalibSlope 0.926 0.004 -0.208 0.289 0.994 0.008 1.04 0.132 -0.052 0.401 1.08 sd 0.243 > cat("first fold model:\n") first fold model: > print(summary(earth.cv$cv.list[[1]])) Call: earth(x=infold.x, y=infold.y, weights=infold.weights, wp=wp, subset=subset, pmethod=if(pmethod=="cv")"backward"elsepmethod, keepxy=(keepxy==2), trace=trace, glm=glm.arg, degree=degree, nfold=0, ncross=0, varmod.method="none", Scale.y=Scale.y) GLM coefficients good (Intercept) 3.0769321 h(21-x) -0.2770319 h(x-21) -0.2732809 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 206.311 20 10.5272 18 0.949 72.58 4 1 Earth selected 3 of 3 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: x Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.004101511 RSS 0.04999937 GRSq 0.9637956 RSq 0.9768292 > par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > set.seed(2019) > plotmo(earth.cv, type="earth", pt.col=2, do.par=0) > empty.plot() > # TODO following doesn't work (can't plotmo the fold models) > # plotmo(earth.cv$cv.list[[1]], type="earth", pt.col=2, do.par=0) > plot.earth.models(list(earth.cv, earth.cv$cv.list[[1]], earth.cv$cv.list[[2]]), which=1:2, do.par=0) > > source("test.epilog.R") earth/inst/slowtests/test.mods.Rout.save0000644000176200001440000011222113451164531020133 0ustar liggesusers> # test.mods.R: test earth's ability to build various models > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > options(digits=4) > > SHORTTEST <- TRUE # use TRUE for production testing against test.mods.Rout.save > TRACE <- 0 > PRINT.DATA <- FALSE > FORCE.WEIGHTS <- FALSE > # GLOBAL.SEEDS <- 1:10 > GLOBAL.SEEDS <- 1 > COLLINEAR.TESTS <- TRUE > SUMMARY <- FALSE > PLOT <- FALSE > TIME <- FALSE > COMPARE_TO_WEIGHTED_MODEL <- FALSE > RANDOMFOREST <- FALSE > MARS <- FALSE > RPROF <- FALSE > if(SHORTTEST) { + GLOBAL.SEEDS <- 1 + COLLINEAR.TESTS <- FALSE + SUMMARY <- FALSE + PLOT <- FALSE + TIME <- FALSE + COMPARE_TO_WEIGHTED_MODEL <- FALSE + RANDOMFOREST <- FALSE + MARS <- FALSE + RPROF <- FALSE + } > itest <- 0 > > test.rsqs.global <- nterms.global <- delta.rsqs.global <- nknots.global <- NULL > other.rsqs.global <- NULL > mars.rsqs.global <- mars.nterms.global <- NULL > > printf <- function(format, ...) cat(sprint(format, ...)) # like c printf > > sq <- function(x) x * x > > sos <- function(x) sum(as.vector(x^2)) # sum of squares > > test.mod <- function(func, x, xtest, collinear.x2, npreds, nk=NULL, degree=2, ...) + { + itest <<- itest + 1 + # sanity checks + stopifnot(collinear.x2 == 0 || collinear.x2 == 1) + stopifnot(npreds >= 1, npreds <= 9) + stopifnot(nk >= 1, nk <= 201) + stopifnot(degree >= 1, degree <= 5) + set.seed(1994 + global.seed + itest) + x <- x[, 1:npreds, drop=FALSE] + y <- func(x) + nk <- if(is.null(nk)) min(200, max(20, 2 * ncol(x))) + 1 else nk + if(length(GLOBAL.SEEDS) > 1) + printf("global.seed %g ", global.seed) + printf("TEST %-2g%s n %-3g p %-1g %-16.16s nk %-3g deg %-1g ", + itest, if(collinear.x2) " colx2" else "", + nrow(x), ncol(x), deparse(substitute(func)), nk, degree) + gc() + if(TIME) { + # system.time adds quite a lot of time overhead (because of its calls to gc) + earth.time <- system.time(mod <- earth(x, y, nk=nk, degree=degree, + trace=TRACE, Force.weights=FORCE.WEIGHTS, ...)) + time.string <- sprint(" [time %5.3f]", earth.time[3]) + } else { + mod <- earth(x, y, nk=nk, degree=degree, + trace=TRACE, Force.weights=FORCE.WEIGHTS, ...) + time.string <- "" + } + ytest <- func(xtest) + fitted <- predict(mod, xtest) + stopifnot(length(fitted) == nrow(xtest)) + test.rsq <- 1 - sos(ytest - fitted) / sos(ytest - mean(ytest)) + if(TRACE > 0) + printf("TEST %-2g n %-3g p %-1g %-16.16s nk %-2g degree %-2g ", + itest, nrow(x), ncol(x), deparse(substitute(func)), nk, degree) + if(mod$grsq < .3) { # all bets are off with a very low GRsq + test.rsq <- max(-.1, test.rsq) + delta.rsq <- test.rsq - max(0, mod$grsq) + } else + delta.rsq <- test.rsq - mod$grsq + + extra.msg <- "" + if(COMPARE_TO_WEIGHTED_MODEL && !FORCE.WEIGHTS) { + # build a weighted model and print a message if significantly different + modw <- earth(x, y, nk=nk, degree=degree, + trace=TRACE, Force.weights=TRUE, ...) + fittedw <- predict(modw, xtest) + test.rsqw <- 1 - sos(ytest - fittedw) / sos(ytest - mean(ytest)) + deltaw <- test.rsq - test.rsqw + extra.msg <- sprint("%s grsqw % 4.2f test.rsqw % 4.2f deltaw % 4.2f%s", + extra.msg, modw$grsq, test.rsqw, deltaw, + if(abs(deltaw) > .5) "!" else "") + } + if(RANDOMFOREST) { # build a randomForest model + require(randomForest) + rf <- randomForest(x, y, ntree=1000) + fitted.rf <- predict(rf, xtest) + rsq.rf <- 1 - sos(ytest - fitted.rf) / sos(ytest - mean(ytest)) + other.rsqs.global <<- c(other.rsqs.global, rsq.rf) + delta <- test.rsq - rsq.rf + extra.msg <- sprint("%s rsq.rf % 4.2f delta % 4.2f%s", + extra.msg, rsq.rf, delta, + if(abs(delta) > .5) "!" else "") + } + if(MARS) { # build an mda::mars model + require(mda) + mars <- mars(x, y, nk=nk, degree=degree) + mars <- mars.to.earth(mars, trace=FALSE) + fitted.mars <- predict(mars, xtest) + rsq.mars <- 1 - sos(ytest - fitted.mars) / sos(ytest - mean(ytest)) + mars.rsqs.global <<- c(mars.rsqs.global, rsq.mars) + mars.nterms.global <<- c(mars.nterms.global, length(mars$selected.terms)) + delta <- test.rsq - rsq.mars + extra.msg <- sprint("%s rsq.mars % 4.2f delta % 4.2f%s", + extra.msg, rsq.mars, delta, + if(abs(delta) > .5) "!" else "") + } + printf("nterms %-2g%s grsq % 4.2f test.rsq % 4.2f grsq-test.rsq % 5.2f%s%s%s\n", + length(mod$selected.terms), time.string, mod$grsq, test.rsq, delta.rsq, + if(delta.rsq < -.3) " baddelta" else "", + if(test.rsq < -1) " badtestrsq" else "", + extra.msg) + test.rsqs.global <<- c(test.rsqs.global, test.rsq) + nterms.global <<- c(nterms.global, length(mod$selected.terms)) + delta.rsqs.global <<- c(delta.rsqs.global, delta.rsq) + nknots.global <<- c(nknots.global, length(unique(as.vector(mod$cuts)))) + if(SUMMARY) { + print(summary(mod)) + printf("\n") + } + if(PRINT.DATA) { + print(cbind(y, x)) + printf("\n") + } + if(PLOT || + # following is to always produce a plot so diffps ok in test.mods.bat + (!interactive() && itest == 1 && nrow(x) == 100)) { + caption <- sprint("TEST %g%s n %d p %d %-.20s nk %g deg %g grsq %.2f test.rsq %.2f", + itest, if(collinear.x2) " col.x2" else "", nrow(x), ncol(x), + deparse(substitute(func)), nk, degree, mod$grsq, test.rsq) + # plotmo(mod, trace=-1, pt.col="red", pt.cex=.8, caption=caption, + # cex.caption=if(npreds<=2) .7 else .9) + plotmo(mod, trace=-1, pt.col="red", pt.cex=.8, caption=caption, + cex.caption=if(npreds<=2) .7 else .9, type2="im") + } + mod + } > ran <- function(n) runif(n, -1, 1) > # ran <- function(n) 2 * rnorm(n) > > testn <- function(n, collinear.x2=FALSE) + { + itest <<- 0 + max.ncol <- 10 + set.seed(2015 + global.seed + n) + x <- matrix(ran(max.ncol * n), ncol=max.ncol) + x <- x[order(x[,1]), , drop=FALSE] # sort first column for convenience + if(collinear.x2) + x[,2] <- x[,1] + .3 * rnorm(nrow(x)) + colnames(x) <- paste("x", 1:ncol(x), sep="") + + xtest <- matrix(ran(max.ncol * 1e4), ncol=max.ncol) + if(collinear.x2) + xtest[,2] <- xtest[,1] + .3 * rnorm(nrow(xtest)) + xtest <- xtest[order(xtest[,1]), , drop=FALSE] + colnames(xtest) <- c(paste("x", 1:max.ncol, sep="")) + + univariate <- function(x) + { + x[,1] + .3 * rnorm(nrow(x)) + } + test.mod(univariate, x, xtest, collinear.x2, npreds=1, degree=1) + test.mod(univariate, x, xtest, collinear.x2, npreds=2, degree=2) # extra predictor + + bi <- function(x) + { + x[,1] + x[,2] + .3 * rnorm(nrow(x)) + } + test.mod(bi, x, xtest, collinear.x2, npreds=2, degree=1) + test.mod(bi, x, xtest, collinear.x2, npreds=2, degree=2) + test.mod(bi, x, xtest, collinear.x2, npreds=3, degree=2) # extra predictor + + bi.interact <- function(x) + { + x[,1] + x[,2] + (x[,1] * x[,2]) + .3 * rnorm(nrow(x)) + } + test.mod(bi.interact, x, xtest, collinear.x2, npreds=2, degree=1) + test.mod(bi.interact, x, xtest, collinear.x2, npreds=2, degree=2) + test.mod(bi.interact, x, xtest, collinear.x2, npreds=3, degree=2) # extra predictor + + bi.interact2 <- function(x) + { + x[,1] - x[,2] + (x[,1] * x[,2]) + .3 * rnorm(nrow(x)) + } + test.mod(bi.interact2, x, xtest, collinear.x2, npreds=2, degree=1) + test.mod(bi.interact2, x, xtest, collinear.x2, npreds=2, degree=2) + test.mod(bi.interact2, x, xtest, collinear.x2, npreds=3, degree=2) # extra predictor + + bi.interact3 <- function(x) + { + x[,1] + x[,2] - .5 * (x[,1] * x[,2]) + .3 * rnorm(nrow(x)) + } + test.mod(bi.interact3, x, xtest, collinear.x2, npreds=2, degree=1) + test.mod(bi.interact3, x, xtest, collinear.x2, npreds=2, degree=2) + test.mod(bi.interact3, x, xtest, collinear.x2, npreds=3, degree=2) # extra predictor + printf("\n") + + tri <- function(x) + { + x[,1] + x[,2] - x[,3] + .1 * rnorm(nrow(x)) + } + test.mod(tri, x, xtest, collinear.x2, npreds=3, degree=1) + test.mod(tri, x, xtest, collinear.x2, npreds=3, degree=2) + test.mod(tri, x, xtest, collinear.x2, npreds=4, degree=2) # extra predictor + + tri.interact <- function(x) + { + x[,1] - x[,2] + sin(x[,3]) + (x[,1] * x[,2]) + .2 * rnorm(nrow(x)) + } + test.mod(tri.interact, x, xtest, collinear.x2, npreds=3, degree=1) + test.mod(tri.interact, x, xtest, collinear.x2, npreds=3, degree=2) + test.mod(tri.interact, x, xtest, collinear.x2, npreds=3, degree=3) + + # TODO this and next function often cause a negative test.rsq (even though grsq is high) + tri.interact2 <- function(x) + { + x[,1] + x[,2] + sin(x[,3]) - (x[,1] * x[,2]) + .2 * rnorm(nrow(x)) + } + test.mod(tri.interact2, x, xtest, collinear.x2, npreds=3, degree=1) + test.mod(tri.interact2, x, xtest, collinear.x2, npreds=3, degree=2) + test.mod(tri.interact2, x, xtest, collinear.x2, npreds=3, degree=3) + + tri.interact3 <- function(x) + { + x[,1] - x[,2] + sq(x[,3]) + (x[,1] * x[,2]) + .2 * rnorm(nrow(x)) + } + test.mod(tri.interact3, x, xtest, collinear.x2, npreds=3, degree=1) + test.mod(tri.interact3, x, xtest, collinear.x2, npreds=3, degree=2) + test.mod(tri.interact3, x, xtest, collinear.x2, npreds=3, degree=3) + + tri.two.interacts <- function(x) + { + x[,1] + x[,2] - sq(x[,3]) + (x[,1] * x[,2]) + sq(x[,1] * sq(x[,3])) + .1 * rnorm(nrow(x)) + } + test.mod(tri.two.interacts, x, xtest, collinear.x2, npreds=3, degree=1) + test.mod(tri.two.interacts, x, xtest, collinear.x2, npreds=3, degree=2) + printf("\n") + + sin.3.x1 <- function(x) + { + # curve looks like this /\ + # \/ + sin(3 * x[,1]) + } + test.mod(sin.3.x1, x, xtest, collinear.x2, npreds=1, nk=51, degree=1) + test.mod(sin.3.x1, x, xtest, collinear.x2, npreds=2, nk=51, degree=1) # x2 is noise + test.mod(sin.3.x1, x, xtest, collinear.x2, npreds=2, nk=51, degree=2) + printf("\n") + + sin.5.x1 <- function(x) + { + # curve looks like this \ /\ + # \/ \ + sin(5 * x[,1]) + } + test.mod(sin.5.x1, x, xtest, collinear.x2, npreds=1, nk=51, degree=1) + test.mod(sin.5.x1, x, xtest, collinear.x2, npreds=2, nk=51, degree=1) # x2 is noise + test.mod(sin.5.x1, x, xtest, collinear.x2, npreds=2, nk=51, degree=2) + printf("\n") + + if(n > 30) { + sin.5.x1.noise <- function(x) + { + sin(5 * x[,1]) + .5 * rnorm(nrow(x)) + } + test.mod(sin.5.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1) + test.mod(sin.5.x1.noise, x, xtest, collinear.x2, npreds=2, degree=1) + test.mod(sin.5.x1.noise, x, xtest, collinear.x2, npreds=2, degree=2) + test.mod(sin.5.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1, nk=51) + test.mod(sin.5.x1.noise, x, xtest, collinear.x2, npreds=2, degree=1, nk=51) + test.mod(sin.5.x1.noise, x, xtest, collinear.x2, npreds=2, degree=2, nk=51) + printf("\n") + } + if(n > 100) { # need many points because the function is so curvy + sin.10.x1 <- function(x) + { + # curve looks like this \ /\ /\ /\ + # (three humps) \/ \/ \/ \ + sin(10 * x[,1]) + } + test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=1, degree=1) + test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=2, degree=1) + test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=2, degree=2) + test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=1, degree=1, nk=51) + test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=2, degree=1, nk=51) + test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=1, degree=2, nk=51) + # even with thresh=0 here we still don't cover all curves, ditto for models below + test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=1, degree=1, nk=51, thresh=1e-5) + test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=2, degree=1, nk=51, thresh=1e-5) + test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=2, degree=2, nk=51, thresh=1e-5) + printf("\n") + } + if(n > 100) { + sin.10.x1.noise <- function(x) + { + sin(10 * x[,1]) + .5 * rnorm(nrow(x)) + } + test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1) + test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=2, degree=1) + test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=2, degree=2) + test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1, nk=51) + test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=2, degree=1, nk=51) + test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=1, degree=2, nk=51) + test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1, nk=51, thresh=1e-5) + test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=2, degree=1, nk=51, thresh=1e-5) + test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=2, degree=2, nk=51, thresh=1e-5) + printf("\n") + } + # commented out because need too many cases because the function is so curvy + # if(n > 100) { # need many points because the function is so curvy + # sin.20.x1 <- function(x) + # { + # sin(20 * x[,1]) + # } + # test.mod(sin.20.x1, x, xtest, collinear.x2, npreds=1, degree=1) + # test.mod(sin.20.x1, x, xtest, collinear.x2, npreds=1, degree=2) + # test.mod(sin.20.x1, x, xtest, collinear.x2, npreds=1, degree=1, nk=51) + # test.mod(sin.20.x1, x, xtest, collinear.x2, npreds=1, degree=2, nk=51) + # test.mod(sin.20.x1, x, xtest, collinear.x2, npreds=1, degree=1, nk=51, thresh=1e-5) + # test.mod(sin.20.x1, x, xtest, collinear.x2, npreds=1, degree=2, nk=51, thresh=1e-5) + # printf("\n") + # } + # if(n > 100) { # need many points because the function is so curvy + # sin.20.x1.noise <- function(x) # six humps + # { + # sin(20 * x[,1]) + .5 * rnorm(nrow(x)) + # } + # test.mod(sin.20.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1) + # test.mod(sin.20.x1.noise, x, xtest, collinear.x2, npreds=1, degree=2) + # test.mod(sin.20.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1, nk=51) + # test.mod(sin.20.x1.noise, x, xtest, collinear.x2, npreds=1, degree=2, nk=51) + # test.mod(sin.20.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1, nk=51, thresh=1e-5) + # test.mod(sin.20.x1.noise, x, xtest, collinear.x2, npreds=1, degree=2, nk=51, thresh=1e-5) + # printf("\n") + # } + sin.3.x1.plus.x2 <- function(x) + { + sin(3 * x[,1]) + x[,2] + } + test.mod(sin.3.x1.plus.x2, x, xtest, collinear.x2, npreds=2, degree=1) + test.mod(sin.3.x1.plus.x2, x, xtest, collinear.x2, npreds=2, degree=2) + printf("\n") + + # TODO this function tends to have the most rsq discrepancies with randomForest models + sin.2.x1.times.x2 <- function(x) + { + sin(2 * x[,1]) * x[,2] + } + test.mod(sin.2.x1.times.x2, x, xtest, collinear.x2, npreds=2, degree=1) + test.mod(sin.2.x1.times.x2, x, xtest, collinear.x2, npreds=2, degree=2) + printf("\n") + + # TODO this and the next function seem to most often cause a big + # discrepancy between grsq and test.rsq + cos.2.x1.times.x2 <- function(x) # cos(2 * x1) looks like /\ + { + cos(2 * x[,1]) * x[,2] + } + test.mod(cos.2.x1.times.x2, x, xtest, collinear.x2, npreds=2, degree=1) + test.mod(cos.2.x1.times.x2, x, xtest, collinear.x2, npreds=2, degree=2) + printf("\n") + + cos.2.x1.times.x2.noise <- function(x) + { + cos(2 * x[,1]) * x[,2] + .3 * rnorm(nrow(x)) + } + test.mod(cos.2.x1.times.x2.noise, x, xtest, collinear.x2, npreds=2, degree=1) + test.mod(cos.2.x1.times.x2.noise, x, xtest, collinear.x2, npreds=2, degree=2) + printf("\n") + + eqn56 <- function(x) # Friedman MARS paper equation 56 (note that this is additive) + { + 0.1 * exp(4 * x[,1]) + + 4 / (1 + exp(-20 * (x[,2] - 0.5))) + + 3 * x[,3] + + 2 * x[,4] + + x[,5] + } + test.mod(eqn56, x, xtest, collinear.x2, npreds=5, degree=1) + test.mod(eqn56, x, xtest, collinear.x2, npreds=5, degree=2) + test.mod(eqn56, x, xtest, collinear.x2, npreds=5, degree=3) + test.mod(eqn56, x, xtest, collinear.x2, npreds=5, nk=99, degree=1) + test.mod(eqn56, x, xtest, collinear.x2, npreds=5, nk=99, degree=2) + test.mod(eqn56, x, xtest, collinear.x2, npreds=5, nk=99, degree=3) + printf("\n") + + eqn56.extra.preds <- function(x) + { + eqn56(x) + } + test.mod(eqn56.extra.preds, x, xtest, collinear.x2, npreds=9, degree=1) + test.mod(eqn56.extra.preds, x, xtest, collinear.x2, npreds=9, degree=2) + if(n > 30) + test.mod(eqn56.extra.preds, x, xtest, collinear.x2, npreds=9, degree=3) + test.mod(eqn56.extra.preds, x, xtest, collinear.x2, npreds=9, degree=1, nk=99) + test.mod(eqn56.extra.preds, x, xtest, collinear.x2, npreds=9, degree=2, nk=99) + if(n > 30) + test.mod(eqn56.extra.preds, x, xtest, collinear.x2, npreds=9, degree=3, nk=99) + printf("\n") + + eqn56.noise <- function(x) + { + eqn56(x) + rnorm(nrow(x)) + } + test.mod(eqn56.noise, x, xtest, collinear.x2, npreds=5, degree=1) + test.mod(eqn56.noise, x, xtest, collinear.x2, npreds=5, degree=2) + test.mod(eqn56.noise, x, xtest, collinear.x2, npreds=5, degree=3) + test.mod(eqn56.noise, x, xtest, collinear.x2, npreds=5, nk=99, degree=1) + # commented out the following because they are slow + # test.mod(eqn56.noise, x, xtest, collinear.x2, npreds=5, nk=99, degree=2) + # test.mod(eqn56.noise, x, xtest, collinear.x2, npreds=5, nk=99, degree=3) + printf("\n") + + if(n > 30) { + eqn56.noise.extra.preds <- function(x) + { + eqn56(x) + rnorm(nrow(x)) + } + test.mod(eqn56.noise.extra.preds, x, xtest, collinear.x2, npreds=9, degree=1) + test.mod(eqn56.noise.extra.preds, x, xtest, collinear.x2, npreds=9, degree=2) + test.mod(eqn56.noise.extra.preds, x, xtest, collinear.x2, npreds=9, degree=3) + test.mod(eqn56.noise.extra.preds, x, xtest, collinear.x2, npreds=9, degree=1, nk=99) + # commented out the following because they are slow + # test.mod(eqn56.noise.extra.preds, x, xtest, collinear.x2, npreds=9, degree=2, nk=99) + # test.mod(eqn56.noise.extra.preds, x, xtest, collinear.x2, npreds=9, degree=3, nk=99) + printf("\n") + } + # force linpreds in 1 and 2 degree terms + test.mod(eqn56, x, xtest, collinear.x2, npreds=5, linpreds=c("^x1$","x3","5")) + test.mod(eqn56, x, xtest, collinear.x2, npreds=5, linpreds=c(3,5)) + + # check symmetry by using negative of eqn56 (may not be completely symmetric) + neg.eqn56 <- function(x) + { + -eqn56(x) + } + test.mod(neg.eqn56, x, xtest, collinear.x2, npreds=5, linpreds=c(3,5)) + printf("\n") + + five.preds <- function(x) # x1 and x2, and x3 and x4 interact + { + y <- 0 + for (i in 1:5) + y <- y + sin(2 * x[,i]) + y + x[,1] * cos(4 * x[,2]) + (x[,3]-2) * x[,4] + } + test.mod(five.preds, x, xtest, collinear.x2, npreds=5, degree=1) + test.mod(five.preds, x, xtest, collinear.x2, npreds=5, degree=2) + test.mod(five.preds, x, xtest, collinear.x2, npreds=5, degree=3) + test.mod(five.preds, x, xtest, collinear.x2, npreds=5, degree=1, nk=51) + # commented out the following because they are slow + # test.mod(five.preds, x, xtest, collinear.x2, npreds=5, degree=2, nk=51) + # test.mod(five.preds, x, xtest, collinear.x2, npreds=5, degree=3, nk=51) + printf("\n") + + if(n > 30) { + five.preds.noise <- function(x) + { + five.preds(x) + .3 * rnorm(nrow(x)) + } + test.mod(five.preds.noise, x, xtest, collinear.x2, npreds=5, degree=1) + test.mod(five.preds.noise, x, xtest, collinear.x2, npreds=5, degree=2) + test.mod(five.preds.noise, x, xtest, collinear.x2, npreds=5, degree=3) + test.mod(five.preds.noise, x, xtest, collinear.x2, npreds=5, degree=1, nk=51) + # commented out the following because they are slow + # test.mod(five.preds.noise, x, xtest, collinear.x2, npreds=5, degree=2, nk=51) + # test.mod(five.preds.noise, x, xtest, collinear.x2, npreds=5, degree=3, nk=51) + printf("\n") + } + pure.noise <- function(x) + { + rnorm(nrow(x)) + } + test.mod(pure.noise, x, xtest, collinear.x2, npreds=1, degree=1) + test.mod(pure.noise, x, xtest, collinear.x2, npreds=2, degree=1) + test.mod(pure.noise, x, xtest, collinear.x2, npreds=2, degree=2) + if(n < 100) { + cat("Skipping further tests because n < 100\n\n") + return(invisible()) + } + test.mod(pure.noise, x, xtest, collinear.x2, npreds=1, degree=1, nk=51) + test.mod(pure.noise, x, xtest, collinear.x2, npreds=2, degree=2, nk=51) + test.mod(pure.noise, x, xtest, collinear.x2, npreds=2, degree=2, nk=51) + test.mod(pure.noise, x, xtest, collinear.x2, npreds=5, degree=1) + test.mod(pure.noise, x, xtest, collinear.x2, npreds=5, degree=2) + test.mod(pure.noise, x, xtest, collinear.x2, npreds=5, degree=1, nk=51) + # commented out the following because it is slow + # test.mod(pure.noise, x, xtest, collinear.x2, npreds=5, degree=2, nk=51) + printf("\n") + + if(n > 100) { # need many points (Fast MARS paper uses 400 and 800 for robot.arm) + robot.arm <- function(x) # Friedman Fast MARS paper + { + l1 <- x[,1] + l2 <- x[,2] + theta1 <- x[,3] + theta2 <- x[,4] + phi <- x[,5] + + x1 <- l1 * cos(theta1) - l2 * cos(theta1 + theta2) * cos(phi) + y <- l1 * sin(theta1) - l2 * sin(theta1 + theta2) * cos(phi) + z <- l2 * sin(theta2) * sin(phi) + + sqrt(x1^2 + y^2 + z^2) + } + x[,1] <- (x[,1] + 1) / 2 # l1 0..1 + x[,2] <- (x[,2] + 1) / 2 # l2 0..1 + x[,3] <- pi * (x[,3] + 1) # theta1 + x[,4] <- pi * (x[,4] + 1) # theta2 + x[,5] <- pi * x[,5] / 2 # phi + colnames(x) <- c("l1", "l2", "theta1", "theta2", "phi", paste("x", 6:ncol(x), sep="")) + + xtest[,1] <- (xtest[,1] + 1) / 2 # l1 0..1 + xtest[,2] <- (xtest[,2] + 1) / 2 # l2 0..1 + xtest[,3] <- pi * (xtest[,3] + 1) # theta1 + xtest[,4] <- pi * (xtest[,4] + 1) # theta2 + xtest[,5] <- pi * xtest[,5] / 2 # phi + colnames(xtest) <- c("l1", "l2", "theta1", "theta2", "phi", paste("x", 6:ncol(x), sep="")) + + test.mod(robot.arm, x, xtest, collinear.x2, npreds=5, nk=51, degree=3) + test.mod(robot.arm, x, xtest, collinear.x2, npreds=5, nk=99, degree=2) + test.mod(robot.arm, x, xtest, collinear.x2, npreds=5, nk=99, degree=3) + test.mod(robot.arm, x, xtest, collinear.x2, npreds=5, nk=99, degree=5) + printf("\n") + } + if(n > 30) { # need many points (Meinshausen paper uses 1000) + sin.sin <- function(x) # from Meinshausen "Node Harvest" paper + { + sin(pi * (x[,1] + 1)) * sin(pi * (x[,2] + 1)) + } + # thresh=.0001 else get intercept only model + test.mod(sin.sin, x, xtest, collinear.x2, npreds=2, degree=2, nk=99, thresh=.0001) + test.mod(sin.sin, x, xtest, collinear.x2, npreds=4, degree=2, nk=99, thresh=.0001) # extra noise predictors + printf("\n") + } + if(n > 100) { # need many points (Meinshausen paper uses 1000) + sin.sin.noise <- function(x) + { + # we use less noise than the paper because we only have a max of 300 points + sin(pi * x[,1]) * sin(pi * x[,2]) + rnorm(nrow(x), sd=.25) + } + test.mod(sin.sin.noise, x, xtest, collinear.x2, npreds=2, degree=2, nk=99, thresh=.0001) + test.mod(sin.sin.noise, x, xtest, collinear.x2, npreds=4, degree=2, nk=99, thresh=.0001) # extra noise predictors + printf("\n") + } + invisible() + } > my.summary <- function(x) + { + q <- stats::quantile(x, probs = c(0, .01, .05, .1, .5, .9, 1)) + q <- c(q[1:4], mean(x), q[5:7]) + q <- as.numeric(sprint("%.3f", q)) + names(q) <- c("min", "1%", "5%", "10%", "mean", "median", "95%", "max") + q + } > start.time <- proc.time() > global.seed <- GLOBAL.SEEDS[1] > cat("begin GLOBAL.SEEDS ", GLOBAL.SEEDS, " FORCE.WEIGHTS ", FORCE.WEIGHTS, "\n", sep="") begin GLOBAL.SEEDS 1 FORCE.WEIGHTS FALSE > if(RPROF) + Rprof("Rprof.out") > if(SHORTTEST) { + testn(100) + } else for(global.seed in GLOBAL.SEEDS) { + testn(30) + testn(100) + testn(300) + if(COLLINEAR.TESTS) + testn(100, collinear.x2=TRUE) # collinear.x2 preds expose the need for Adjust.endspan + } TEST 1 n 100 p 1 univariate nk 21 deg 1 nterms 3 grsq 0.79 test.rsq 0.78 grsq-test.rsq -0.01 TEST 2 n 100 p 2 univariate nk 21 deg 2 nterms 3 grsq 0.80 test.rsq 0.75 grsq-test.rsq -0.05 TEST 3 n 100 p 2 bi nk 21 deg 1 nterms 5 grsq 0.83 test.rsq 0.87 grsq-test.rsq 0.04 TEST 4 n 100 p 2 bi nk 21 deg 2 nterms 4 grsq 0.87 test.rsq 0.88 grsq-test.rsq 0.01 TEST 5 n 100 p 3 bi nk 21 deg 2 nterms 5 grsq 0.86 test.rsq 0.87 grsq-test.rsq 0.01 TEST 6 n 100 p 2 bi.interact nk 21 deg 1 nterms 4 grsq 0.78 test.rsq 0.73 grsq-test.rsq -0.05 TEST 7 n 100 p 2 bi.interact nk 21 deg 2 nterms 6 grsq 0.89 test.rsq 0.89 grsq-test.rsq -0.01 TEST 8 n 100 p 3 bi.interact nk 21 deg 2 nterms 6 grsq 0.91 test.rsq 0.89 grsq-test.rsq -0.03 TEST 9 n 100 p 2 bi.interact2 nk 21 deg 1 nterms 4 grsq 0.81 test.rsq 0.68 grsq-test.rsq -0.12 TEST 10 n 100 p 2 bi.interact2 nk 21 deg 2 nterms 6 grsq 0.90 test.rsq 0.86 grsq-test.rsq -0.04 TEST 11 n 100 p 3 bi.interact2 nk 21 deg 2 nterms 5 grsq 0.89 test.rsq 0.81 grsq-test.rsq -0.08 TEST 12 n 100 p 2 bi.interact3 nk 21 deg 1 nterms 4 grsq 0.79 test.rsq 0.84 grsq-test.rsq 0.05 TEST 13 n 100 p 2 bi.interact3 nk 21 deg 2 nterms 4 grsq 0.85 test.rsq 0.87 grsq-test.rsq 0.02 TEST 14 n 100 p 3 bi.interact3 nk 21 deg 2 nterms 8 grsq 0.84 test.rsq 0.85 grsq-test.rsq 0.01 TEST 15 n 100 p 3 tri nk 21 deg 1 nterms 7 grsq 0.99 test.rsq 0.99 grsq-test.rsq 0.00 TEST 16 n 100 p 3 tri nk 21 deg 2 nterms 7 grsq 0.98 test.rsq 0.99 grsq-test.rsq 0.01 TEST 17 n 100 p 4 tri nk 21 deg 2 nterms 7 grsq 0.98 test.rsq 0.99 grsq-test.rsq 0.01 TEST 18 n 100 p 3 tri.interact nk 21 deg 1 nterms 7 grsq 0.87 test.rsq 0.80 grsq-test.rsq -0.07 TEST 19 n 100 p 3 tri.interact nk 21 deg 2 nterms 8 grsq 0.94 test.rsq 0.96 grsq-test.rsq 0.01 TEST 20 n 100 p 3 tri.interact nk 21 deg 3 nterms 8 grsq 0.95 test.rsq 0.96 grsq-test.rsq 0.01 TEST 21 n 100 p 3 tri.interact2 nk 21 deg 1 nterms 5 grsq 0.86 test.rsq 0.79 grsq-test.rsq -0.07 TEST 22 n 100 p 3 tri.interact2 nk 21 deg 2 nterms 7 grsq 0.94 test.rsq 0.96 grsq-test.rsq 0.02 TEST 23 n 100 p 3 tri.interact2 nk 21 deg 3 nterms 9 grsq 0.95 test.rsq 0.93 grsq-test.rsq -0.02 TEST 24 n 100 p 3 tri.interact3 nk 21 deg 1 nterms 7 grsq 0.88 test.rsq 0.79 grsq-test.rsq -0.09 TEST 25 n 100 p 3 tri.interact3 nk 21 deg 2 nterms 10 grsq 0.93 test.rsq 0.91 grsq-test.rsq -0.02 TEST 26 n 100 p 3 tri.interact3 nk 21 deg 3 nterms 11 grsq 0.94 test.rsq 0.93 grsq-test.rsq -0.01 TEST 27 n 100 p 3 tri.two.interact nk 21 deg 1 nterms 7 grsq 0.88 test.rsq 0.78 grsq-test.rsq -0.10 TEST 28 n 100 p 3 tri.two.interact nk 21 deg 2 nterms 14 grsq 0.98 test.rsq 0.98 grsq-test.rsq -0.00 TEST 29 n 100 p 1 sin.3.x1 nk 51 deg 1 nterms 7 grsq 1.00 test.rsq 1.00 grsq-test.rsq 0.00 TEST 30 n 100 p 2 sin.3.x1 nk 51 deg 1 nterms 7 grsq 1.00 test.rsq 1.00 grsq-test.rsq 0.00 TEST 31 n 100 p 2 sin.3.x1 nk 51 deg 2 nterms 7 grsq 1.00 test.rsq 1.00 grsq-test.rsq 0.00 TEST 32 n 100 p 1 sin.5.x1 nk 51 deg 1 nterms 7 grsq 0.97 test.rsq 0.98 grsq-test.rsq 0.01 TEST 33 n 100 p 2 sin.5.x1 nk 51 deg 1 nterms 5 grsq 0.94 test.rsq 0.95 grsq-test.rsq 0.01 TEST 34 n 100 p 2 sin.5.x1 nk 51 deg 2 nterms 10 grsq 1.00 test.rsq 1.00 grsq-test.rsq -0.00 TEST 35 n 100 p 1 sin.5.x1.noise nk 21 deg 1 nterms 5 grsq 0.54 test.rsq 0.64 grsq-test.rsq 0.10 TEST 36 n 100 p 2 sin.5.x1.noise nk 21 deg 1 nterms 8 grsq 0.54 test.rsq 0.49 grsq-test.rsq -0.05 TEST 37 n 100 p 2 sin.5.x1.noise nk 21 deg 2 nterms 4 grsq 0.64 test.rsq 0.59 grsq-test.rsq -0.06 TEST 38 n 100 p 1 sin.5.x1.noise nk 51 deg 1 nterms 5 grsq 0.66 test.rsq 0.59 grsq-test.rsq -0.07 TEST 39 n 100 p 2 sin.5.x1.noise nk 51 deg 1 nterms 6 grsq 0.69 test.rsq 0.61 grsq-test.rsq -0.08 TEST 40 n 100 p 2 sin.5.x1.noise nk 51 deg 2 nterms 8 grsq 0.61 test.rsq 0.58 grsq-test.rsq -0.02 TEST 41 n 100 p 2 sin.3.x1.plus.x2 nk 21 deg 1 nterms 7 grsq 1.00 test.rsq 1.00 grsq-test.rsq -0.00 TEST 42 n 100 p 2 sin.3.x1.plus.x2 nk 21 deg 2 nterms 7 grsq 1.00 test.rsq 1.00 grsq-test.rsq -0.00 TEST 43 n 100 p 2 sin.2.x1.times.x nk 21 deg 1 nterms 6 grsq 0.08 test.rsq -0.10 grsq-test.rsq -0.18 TEST 44 n 100 p 2 sin.2.x1.times.x nk 21 deg 2 nterms 11 grsq 0.98 test.rsq 0.98 grsq-test.rsq -0.01 TEST 45 n 100 p 2 cos.2.x1.times.x nk 21 deg 1 nterms 5 grsq 0.60 test.rsq 0.28 grsq-test.rsq -0.32 baddelta TEST 46 n 100 p 2 cos.2.x1.times.x nk 21 deg 2 nterms 11 grsq 1.00 test.rsq 0.97 grsq-test.rsq -0.03 TEST 47 n 100 p 2 cos.2.x1.times.x nk 21 deg 1 nterms 2 grsq 0.29 test.rsq 0.31 grsq-test.rsq 0.03 TEST 48 n 100 p 2 cos.2.x1.times.x nk 21 deg 2 nterms 7 grsq 0.61 test.rsq 0.50 grsq-test.rsq -0.11 TEST 49 n 100 p 5 eqn56 nk 21 deg 1 nterms 12 grsq 1.00 test.rsq 1.00 grsq-test.rsq -0.00 TEST 50 n 100 p 5 eqn56 nk 21 deg 2 nterms 12 grsq 1.00 test.rsq 1.00 grsq-test.rsq 0.00 TEST 51 n 100 p 5 eqn56 nk 21 deg 3 nterms 12 grsq 1.00 test.rsq 1.00 grsq-test.rsq 0.00 TEST 52 n 100 p 5 eqn56 nk 99 deg 1 nterms 12 grsq 1.00 test.rsq 1.00 grsq-test.rsq -0.00 TEST 53 n 100 p 5 eqn56 nk 99 deg 2 nterms 12 grsq 1.00 test.rsq 1.00 grsq-test.rsq 0.00 TEST 54 n 100 p 5 eqn56 nk 99 deg 3 nterms 12 grsq 1.00 test.rsq 1.00 grsq-test.rsq 0.00 TEST 55 n 100 p 9 eqn56.extra.pred nk 21 deg 1 nterms 12 grsq 1.00 test.rsq 1.00 grsq-test.rsq -0.00 TEST 56 n 100 p 9 eqn56.extra.pred nk 21 deg 2 nterms 12 grsq 1.00 test.rsq 1.00 grsq-test.rsq -0.00 TEST 57 n 100 p 9 eqn56.extra.pred nk 21 deg 3 nterms 12 grsq 1.00 test.rsq 1.00 grsq-test.rsq -0.00 TEST 58 n 100 p 9 eqn56.extra.pred nk 99 deg 1 nterms 12 grsq 1.00 test.rsq 1.00 grsq-test.rsq -0.00 TEST 59 n 100 p 9 eqn56.extra.pred nk 99 deg 2 nterms 12 grsq 1.00 test.rsq 1.00 grsq-test.rsq -0.00 TEST 60 n 100 p 9 eqn56.extra.pred nk 99 deg 3 nterms 12 grsq 1.00 test.rsq 1.00 grsq-test.rsq -0.00 TEST 61 n 100 p 5 eqn56.noise nk 21 deg 1 nterms 13 grsq 0.93 test.rsq 0.83 grsq-test.rsq -0.09 TEST 62 n 100 p 5 eqn56.noise nk 21 deg 2 nterms 10 grsq 0.92 test.rsq 0.80 grsq-test.rsq -0.12 TEST 63 n 100 p 5 eqn56.noise nk 21 deg 3 nterms 12 grsq 0.90 test.rsq 0.81 grsq-test.rsq -0.08 TEST 64 n 100 p 5 eqn56.noise nk 99 deg 1 nterms 8 grsq 0.89 test.rsq 0.85 grsq-test.rsq -0.04 TEST 65 n 100 p 9 eqn56.noise.extr nk 21 deg 1 nterms 12 grsq 0.88 test.rsq 0.85 grsq-test.rsq -0.03 TEST 66 n 100 p 9 eqn56.noise.extr nk 21 deg 2 nterms 12 grsq 0.90 test.rsq 0.80 grsq-test.rsq -0.10 TEST 67 n 100 p 9 eqn56.noise.extr nk 21 deg 3 nterms 13 grsq 0.85 test.rsq 0.81 grsq-test.rsq -0.03 TEST 68 n 100 p 9 eqn56.noise.extr nk 99 deg 1 nterms 9 grsq 0.89 test.rsq 0.80 grsq-test.rsq -0.09 TEST 69 n 100 p 5 eqn56 nk 21 deg 2 nterms 7 grsq 0.96 test.rsq 0.92 grsq-test.rsq -0.05 TEST 70 n 100 p 5 eqn56 nk 21 deg 2 nterms 10 grsq 1.00 test.rsq 1.00 grsq-test.rsq 0.00 TEST 71 n 100 p 5 neg.eqn56 nk 21 deg 2 nterms 10 grsq 1.00 test.rsq 1.00 grsq-test.rsq 0.00 TEST 72 n 100 p 5 five.preds nk 21 deg 1 nterms 12 grsq 0.88 test.rsq 0.83 grsq-test.rsq -0.05 TEST 73 n 100 p 5 five.preds nk 21 deg 2 nterms 16 grsq 0.93 test.rsq 0.86 grsq-test.rsq -0.07 TEST 74 n 100 p 5 five.preds nk 21 deg 3 nterms 16 grsq 0.93 test.rsq 0.86 grsq-test.rsq -0.07 TEST 75 n 100 p 5 five.preds nk 51 deg 1 nterms 14 grsq 0.89 test.rsq 0.83 grsq-test.rsq -0.05 TEST 76 n 100 p 5 five.preds.noise nk 21 deg 1 nterms 12 grsq 0.82 test.rsq 0.79 grsq-test.rsq -0.02 TEST 77 n 100 p 5 five.preds.noise nk 21 deg 2 nterms 13 grsq 0.89 test.rsq 0.86 grsq-test.rsq -0.03 TEST 78 n 100 p 5 five.preds.noise nk 21 deg 3 nterms 11 grsq 0.87 test.rsq 0.80 grsq-test.rsq -0.07 TEST 79 n 100 p 5 five.preds.noise nk 51 deg 1 nterms 12 grsq 0.87 test.rsq 0.79 grsq-test.rsq -0.08 TEST 80 n 100 p 1 pure.noise nk 21 deg 1 nterms 1 grsq 0.00 test.rsq -0.00 grsq-test.rsq -0.00 TEST 81 n 100 p 2 pure.noise nk 21 deg 1 nterms 1 grsq 0.00 test.rsq -0.02 grsq-test.rsq -0.02 TEST 82 n 100 p 2 pure.noise nk 21 deg 2 nterms 1 grsq 0.00 test.rsq -0.03 grsq-test.rsq -0.03 TEST 83 n 100 p 1 pure.noise nk 51 deg 1 nterms 1 grsq 0.00 test.rsq -0.00 grsq-test.rsq -0.00 TEST 84 n 100 p 2 pure.noise nk 51 deg 2 nterms 1 grsq 0.00 test.rsq -0.00 grsq-test.rsq -0.00 TEST 85 n 100 p 2 pure.noise nk 51 deg 2 nterms 1 grsq 0.00 test.rsq -0.00 grsq-test.rsq -0.00 TEST 86 n 100 p 5 pure.noise nk 21 deg 1 nterms 1 grsq 0.00 test.rsq -0.02 grsq-test.rsq -0.02 TEST 87 n 100 p 5 pure.noise nk 21 deg 2 nterms 2 grsq 0.00 test.rsq -0.09 grsq-test.rsq -0.09 TEST 88 n 100 p 5 pure.noise nk 51 deg 1 nterms 2 grsq 0.01 test.rsq -0.06 grsq-test.rsq -0.07 TEST 89 n 100 p 2 sin.sin nk 99 deg 2 nterms 17 grsq 0.90 test.rsq 0.53 grsq-test.rsq -0.37 baddelta TEST 90 n 100 p 4 sin.sin nk 99 deg 2 nterms 15 grsq 0.80 test.rsq 0.71 grsq-test.rsq -0.09 > if(RPROF) { + Rprof(NULL) + print(summaryRprof()) + } > cat("end GLOBAL.SEEDS ", GLOBAL.SEEDS, " FORCE.WEIGHTS ", FORCE.WEIGHTS, + " COLLINEAR.TESTS ", COLLINEAR.TESTS, "\n", sep="") end GLOBAL.SEEDS 1 FORCE.WEIGHTS FALSE COLLINEAR.TESTS FALSE > printf("test.rsq (bigger is better):\n") test.rsq (bigger is better): > print(my.summary(test.rsqs.global)) min 1% 5% 10% mean median 95% max -0.100 -0.090 -0.019 -0.001 0.753 0.853 0.997 0.998 > printf("grsq-test.rsq (closest to zero is best, but positive is better than negative):\n") grsq-test.rsq (closest to zero is best, but positive is better than negative): > print(my.summary(delta.rsqs.global)) min 1% 5% 10% mean median 95% max -0.372 -0.326 -0.116 -0.094 -0.035 -0.013 0.010 0.095 > # printf("%.3f ", my.summary(delta.rsqs.global)); printf("\n") > printf("nterms (smaller is better):\n") nterms (smaller is better): > print(my.summary(nterms.global)) min 1% 5% 10% mean median 95% max 1.000 1.000 1.000 2.000 8.056 7.000 12.100 17.000 > printf("nknots (smaller is better):\n") nknots (smaller is better): > print(my.summary(nknots.global)) min 1% 5% 10% mean median 95% max 4.00 4.00 5.45 6.00 10.96 11.00 22.00 38.00 > if(!is.null(other.rsqs.global)) { + printf("rf.rsq:\n") + print(my.summary(other.rsqs.global)) + } > if(!is.null(mars.rsqs.global)) { + printf("mars.rsq:\n") + print(my.summary(mars.rsqs.global)) + printf("mars.nterms:\n") + print(my.summary(mars.nterms.global)) + } > if(TIME) + printf("[testn time %.3f]\n", (proc.time() - start.time)[3]) > source("test.epilog.R") earth/inst/slowtests/test.allowedfunc.bat0000755000176200001440000000162613514230362020361 0ustar liggesusers@rem test.allowedfunc.bat @rem Stephen Milborrow Dec 2014 Shrewsbury @echo test.allowedfunc.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.allowedfunc.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.allowedfunc.Rout: @echo. @tail test.allowedfunc.Rout @echo test.allowedfunc.R @exit /B 1 :good1 mks.diff test.allowedfunc.Rout test.allowedfunc.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.allowedfunc.save.ps @exit /B 1 :good2 @rem test.allowedfunc.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.allowedfunc.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.allowedfunc.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.mem.R0000644000176200001440000001425213561352212016264 0ustar liggesusers# test.mem.R: test earth C code memory usage under both normal and error conditions source("test.prolog.R") library(earth) # the data we will build the models on ncases <- 10 x <- matrix(1:ncases, ncol=1) colnames(x) <- "x" max <- max(x) y <- sin(3 * x / max(x)) colnames(y) <- "y" nmodels <- 5 nlm <- double(length=nmodels) # mem used for each lm model nstandardearth <- double(length=nmodels) # mem used for each earth model ngoodallowed <- double(length=nmodels) nbadallowed <- double(length=nmodels) nbadendspan <- double(length=nmodels) max.mem.change <- function(mem.start, gc.start) { mem <- memory.size() # MBytes (on non windows platforms, will always be Inf) gc <- gc(full=TRUE) # returns cells left after garbage collection # max(abs(mem - mem.start), # abs(gc[1,1] - gc.start[1,1]), # Ncells # abs(gc[2,1] - gc.start[2,1])) # Vcells mem <- abs(mem - mem.start) ncells <- abs(gc[1,1] - gc.start[1,1]) vcells <- abs(gc[2,1] - gc.start[2,1]) printf("mem %g ncells %g vcells %g\n", mem, ncells, vcells) max(mem, ncells, vcells) } plotmem <- function(nlm, nstandardearth, ngoodallowed, nbadallowed, nbadendspan) { min <- min(nlm, nstandardearth, ngoodallowed, nbadallowed, nbadendspan) max <- max(nlm, nstandardearth, ngoodallowed, nbadallowed, nbadendspan) min <- min - 1 max <- max + 3 yjitter <- (max - min) / 130 # minimize overplotting # in the graphs, lines should be horizontal (at least after the first iter) # if a line increases after the first iter, it means that memory is not being released plot( 1:nmodels, nlm, type="l", main="memory used by each model", xlab="nmodels", ylab="memory change", ylim=c(min, max)) lines(1:nmodels, nstandardearth + 1 * yjitter, col=2) lines(1:nmodels, ngoodallowed + 2 * yjitter, col=3) lines(1:nmodels, nbadallowed + 3 * yjitter, col=1, lty=2) lines(1:nmodels, nbadendspan + 4 * yjitter, col=2, lty=2) legend(x="topright", bg="white", legend=c("lm", "standardearth", "goodallowed", "badallowed", "badendspan"), lty=c(1,1,1,2,2), col=c(1,2,3,1,2)) } good.allowedfunc <- function(degree, pred, parents, namesx, first) { pred != 999 } bad.allowedfunc <- function(degree, pred, parents, namesx, first) { # this stop is silent because call earth using try(..., silent=TRUE) stop("early exit from bad.allowedfunc") } cat("initial redundant run of lm\n") # else initial nlm very large # (probably because some function is allocating a static buffer) print(summary(lm(y~x))) for(i in 0:nmodels) { try(lm(y~x), silent=FALSE) gc <- gc(full=TRUE) if(i <= 0) { mem.start <- memory.size() gc.start <- gc(full=TRUE) } else nlm[i] <- max.mem.change(mem.start, gc.start) } cat("actual run of lm\n") # We use 0:nmodels, because we build the first model at iter 0, # but don't save results from iter 0 (i.e. we the ignore first model). # This is because the first model sometimes leaves some memory allocated (why?). print(summary(lm(y~x))) for(i in 0:nmodels) { try(lm(y~x), silent=FALSE) gc <- gc(full=TRUE) if(i <= 0) { mem.start <- memory.size() gc.start <- gc(full=TRUE) } else nlm[i] <- max.mem.change(mem.start, gc.start) } # standard earth model cat("earth(y~x)\n") print(summary(earth(y~x))) for(i in 0:nmodels) { try(earth(y~x), silent=FALSE) gc <- gc(full=TRUE) if(i <= 0) { mem.start <- memory.size() gc.start <- gc(full=TRUE) } else nstandardearth[i] <- max.mem.change(mem.start, gc.start) } # earth model with an allowed func cat("earth(y~x, allowed = good.allowedfunc)\n") print(summary(earth(y~x, allowed = good.allowedfunc))) for(i in 0:nmodels) { try(earth(y~x, allowed = good.allowedfunc), silent=FALSE) gc <- gc(full=TRUE) if(i <= 0) { mem.start <- memory.size() gc.start <- gc(full=TRUE) } else ngoodallowed[i] <- max.mem.change(mem.start, gc.start) } # try earth model with an allowed func which causes an error cat("earth(y~x, allowed = bad.allowedfunc)\n") expect.err(try(earth(y~x, allowed = bad.allowedfunc), silent=FALSE), "early exit from bad.allowedfunc") for(i in 0:nmodels) { try(earth(y~x, allowed = bad.allowedfunc), silent=TRUE) gc <- gc(full=TRUE) if(i <= 0) { mem.start <- memory.size() gc.start <- gc(full=TRUE) } else nbadallowed[i] <- max.mem.change(mem.start, gc.start) } # try earth model with an arg that causes error in ForwardPass in earth.c cat("earth(y~x, Adjust.endspan = -999\n") expect.err(try(earth(y~x, Adjust.endspan = -999), silent=FALSE), "Adjust.endspan is -999 but should be between 0 and 10") for(i in 0:nmodels) { try(earth(y~x, Adjust.endspan = -999), silent=TRUE) gc <- gc(full=TRUE) if(i <= 0) { mem.start <- memory.size() gc.start <- gc(full=TRUE) } else nbadendspan[i] <- max.mem.change(mem.start, gc.start) } cat("nlm "); print(nlm) cat("nstandardearth"); print(nstandardearth) cat("ngoodallowed "); print(ngoodallowed) cat("nbadallowed "); print(nbadallowed) cat("nbadendspan "); print(nbadendspan) # printf("\n Min 1stQ Median Mean 3rdQ Max\n") # printf("lm %s\n", paste0(sprintf("% 10.3f", summary(nlm)), collapse=" ")) # printf("standardearth %s\n", paste0(sprintf("% 10.3f", summary(nstandardearth)), collapse=" ")) # printf("goodallowed %s\n", paste0(sprintf("% 10.3f", summary(ngoodallowed)), collapse=" ")) # printf("badallowed %s\n", paste0(sprintf("% 10.3f", summary(nbadallowed)), collapse=" ")) # printf("badendspan %s\n", paste0(sprintf("% 10.3f", summary(nbadendspan)), collapse=" ")) # plot the data we are modeling plot(1:nrow(x), y, type="b", pch=20, xlab="x", main="the data we are modeling") # plot memory used for each model plotmem(nlm, nstandardearth, ngoodallowed, nbadallowed, nbadendspan) source("test.epilog.R") earth/inst/slowtests/test.earthmain.gcc.bat0000755000176200001440000000377613514230362020571 0ustar liggesusers@rem test.earthmain.gcc.bat: test 32 bit standalone earth.c with main() @rem @rem Stephen Milborrow Jan 2008 Durban @echo test.earthmain.gcc.bat @cp "d:/bin/R320dll/i386/R.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Rblas.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Riconv.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Rgraphapp.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Rzlib.dll" . @if %errorlevel% neq 0 goto error @rem you may have to create Rdll.lib and Rblas.lib beforehand @cp "../../.#/Rdll.lib" . @if %errorlevel% neq 0 goto error @cp "../../.#/Rblas.lib" . @if %errorlevel% neq 0 goto error @rem modify the path to include gcc, if needed @rem only do it if needed @set | egrep -i "PATH=[^;]*Rtools.mingw_32" >NUL && goto :donesetpath @echo Modifying path for 32 bit Rtools and R @set PATH=C:\Rtools\mingw_32\bin;^ C:\Rtools\bin;^ C:\Program Files\R\R-3.6.1\bin\i386;^ C:\Program Files\gs\gs9.19\bin;^ %PATH% :donesetpath @gcc -DSTANDALONE -DMAIN -Wall -pedantic -Wextra -O3 -std=gnu99^ -I"/a/r/ra/include" -I../../inst/slowtests ../../src/earth.c^ Rdll.lib Rblas.lib -o earthmain-gcc.exe @if %errorlevel% neq 0 goto error @earthmain-gcc.exe > test.earthmain-gcc.out @rem no errorlevel test, diff will do check for discrepancies @rem @if %errorlevel% neq 0 goto error @rem we use -w on mks.diff so it treats \r\n the same as \n mks.diff -w test.earthmain-gcc.out test.earthmain.out.save @if %errorlevel% neq 0 goto error @rm -f R.dll Rblas.dll Riconv.dll Riconv.dll Rgraphapp.dll Rzlib.dll Rdll.lib Rblas.lib earthmain-gcc.* test.earthmain-gcc.* *.o @exit /B 0 :error @exit /B %errorlevel% earth/inst/slowtests/test.glm.Rout.save0000644000176200001440000130346513470055222017762 0ustar liggesusers> # test.glm.R: tests glm and factors added for earth release 2.0 > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > data(ozone1) > data(trees) > data(etitanic) > source("check.models.equal.R") > > printh <- function(x, expect.warning=FALSE, max.print=0) # like print but with a header + { + cat("===", deparse(substitute(x))) + if(expect.warning) + cat(" expect warning -->") + else if (NROW(x) > 1) + cat("\n") + if (max.print > 0) + print(head(x, n=max.print)) + else + print(x) + } > > model.count <- 0 > > show.earth.models <- function(a, nresponse=NA, legend.pos=NULL, ...) + { + model.name <- deparse(substitute(a)) + cat("\nPrint", model.name, "\n\n") + print(a) + cat("\nSummary", model.name, "\n\n") + print(summary(a)) + model.count <<- model.count + 1 + if (model.count %% 2 == 0) { # an attempt at trying different parameters without combin explosion. + cat("\nSummary", model.name, "decomp=\"none\", digits=5, fixed.point=FALSE, details=TRUE\n\n") + print(summary(a, decomp="none", digits=5, fixed.point=FALSE, details=TRUE)) + } else { + cat("\nSummary", model.name, "digits=3, details=TRUE\n\n") + print(summary(a, decomp="none", digits=3, details=TRUE)) + } + cat("\nevimp", model.name, "\n\n") + print(evimp(a)) + cat("\nevimp", model.name, "trim=FALSE\n\n") + ev <- evimp(a, trim=FALSE) + print(ev) + plot(a, nresponse=nresponse, legend.pos=legend.pos, + caption=if(is.na(nresponse)) model.name + else paste("Response ", nresponse, ": ", model.name, sep="")) + plot(ev) + if (!is.null(a$glm.list)) { + control <- a$glm.list[[1]]$control + family <- a$glm.list[[1]]$family + cat("\nglm params: epsilon", control$epsilon, + "maxit", control$maxit, "trace", control$trace, + "family", family$family, "link", family$link, "\n") + } + cat("\nplotmo", model.name, "\n") + if(is.na(nresponse)) + plotmo(a, clip=FALSE) + else + plotmo(a, nresponse=nresponse, clip=FALSE) + cat("-------------------------------------------------------------------------------\n\n") + } > > # print contents of earth.model, for sanity checking that all fields are present as usual > # but strip big fields to reduce amount of printing > > print.stripped.earth.model <- function(a, model.name) + { + a$bx <- NULL + a$fitted.values <- NULL + a$residuals <- NULL + cat("print.stripped.earth.model(", model.name, ")\n", sep="") + print.default(a) + cat("-------------------------------------------------------------------------------\n\n") + } > > # binomial models > > ldose <- rep(0:5, 2) - 2 > # ldose1 <- c(0.1, 1.2, 2.3, 3.4, 4.5, 5.6, 0.3, 1.4, 2.5, 3.6, 4.7, 5.8) > ldose1 <- c(0.1, 1.2, 0.1, 1.2, 1.0, 0.1, 0.3, 1.4, 0.1, 1.2, 0.1, 0.9) > sex <- factor(rep(c("male", "female"), times=c(6,6))) > numdead <- c(1,4,9,13,18,20,0,2,6,10,12,16) > numalive=20 - numdead > SF <- cbind(numdead, numalive) > numdead2 <- c(2,3,10,13,19,20,0,3,7,11,13,17) > SF2 <- cbind(numdead2, numalive2=20 - numdead2) > > PMETHOD <- "none" # avoid intercept only models > NK <- 6 # avoid infinite GCV models (since pmethod="none") > > # single response glm model but with a binomial pair of y columns > cat("a1: single response glm model but with a binomial pair of y columns, with ldose1 data degree=2\n\n") a1: single response glm model but with a binomial pair of y columns, with ldose1 data degree=2 > a1 <- earth(SF ~ sex + ldose + ldose1, glm=list(family="binomial"), trace=4, pmethod=PMETHOD, nk=NK, degree=2) Call: earth(formula=SF~sex+ldose+ldose1, pmethod=PMETHOD, trace=4, glm=list(family="binomial"), degree=2, nk=NK) x[12,3]: sexmale ldose ldose1 1 1 -2 0.1 2 1 -1 1.2 3 1 0 0.1 ... 1 1 1.2 12 0 3 0.9 y[12,2]: numdead numalive 1 1 19 2 4 16 3 9 11 ... 13 7 12 16 4 earth and glm: unweighted Response columns numdead and numalive are a binomial pair (240 obs in total) yfrac[12,1]: numdead 1 0.05 2 0.20 3 0.45 ... 0.65 12 0.80 Forward pass: minspan 3 endspan 5 x[12,3] 288 Bytes bx[12,6] 576 Bytes GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.8679 0.9211 0.9211 2 ldose -2< 2 1 4 0.9353 0.9808 0.05966 1 sexmale 0< 3 1 final (reached nk 6) Reached nk 6 After forward pass GRSq 0.935 RSq 0.981 Forward pass complete: 5 terms, 3 terms used Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 2 0.8679 0.9211 0.8679 1 1 2 chosen 3 0.9353 0.9808 0.0675 2 1 2 3 Prune none penalty 3 nprune null: selected 3 of 3 terms, and 2 of 3 preds After pruning pass GRSq 0.935 RSq 0.981 glm y[12,2]: numdead numalive 1 1 19 2 4 16 3 9 11 ... 13 7 12 16 4 glm weights: NULL GLM numdead devratio 0.95 dof 9/11 iters 4 > show.earth.models(a1, legend.pos="topleft") Print a1 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 124.876 11 6.75706 9 0.946 42.87 4 1 Earth selected 3 of 3 terms, and 2 of 3 predictors (pmethod="none") Termination condition: Reached nk 6 Importance: ldose, sexmale, ldose1-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.008085317 RSS 0.02425595 GRSq 0.9353281 RSq 0.9807588 Summary a1 Call: earth(formula=SF~sex+ldose+ldose1, pmethod=PMETHOD, trace=4, glm=list(family="binomial"), degree=2, nk=NK) GLM coefficients numdead (Intercept) -1.344727 sexmale 1.100743 ldose 1.064214 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 124.876 11 6.75706 9 0.946 42.87 4 1 Earth selected 3 of 3 terms, and 2 of 3 predictors (pmethod="none") Termination condition: Reached nk 6 Importance: ldose, sexmale, ldose1-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.008085317 RSS 0.02425595 GRSq 0.9353281 RSq 0.9807588 Summary a1 digits=3, details=TRUE Call: earth(formula=SF~sex+ldose+ldose1, pmethod=PMETHOD, trace=4, glm=list(family="binomial"), degree=2, nk=NK) Earth coefficients numdead (Intercept) 0.292 ldose 0.182 sexmale 0.158 GLM coefficients numdead (Intercept) -1.34 ldose 1.06 sexmale 1.10 GLM deviance residuals: Min 1Q Median 3Q Max -1.1054 -0.6534 -0.0222 0.4847 1.4294 GLM coefficients (family binomial, link logit) Estimate Std. Error z value Pr(>|z|) (Intercept) -1.345 0.280 -4.81 1.5e-06 ldose 1.064 0.131 8.12 4.7e-16 sexmale 1.101 0.356 3.09 0.002 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 125 11 6.76 9 0.95 42.9 4 1 Earth selected 3 of 3 terms, and 2 of 3 predictors (pmethod="none") Termination condition: Reached nk 6 Importance: ldose, sexmale, ldose1-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.00809 RSS 0.0243 GRSq 0.935 RSq 0.981 evimp a1 nsubsets gcv rss ldose 2 100.0 100.0 sexmale 1 26.9 24.7 evimp a1 trim=FALSE nsubsets gcv rss ldose 2 100.0 100.0 sexmale 1 26.9 24.7 ldose1-unused 0 0.0 0.0 glm params: epsilon 1e-08 maxit 25 trace FALSE family binomial link logit plotmo a1 plotmo grid: sex ldose ldose1 female 0.5 0.6 ------------------------------------------------------------------------------- > printh(evimp(a1, trim=FALSE, sqrt=FALSE)) === evimp(a1, trim = FALSE, sqrt = FALSE) nsubsets gcv rss ldose 2 100.0 100.0 sexmale 1 7.2 6.1 ldose1-unused 0 0.0 0.0 > printh(evimp(a1, trim=FALSE, sqrt=TRUE)) # this tests sqrt param with negative evimps === evimp(a1, trim = FALSE, sqrt = TRUE) nsubsets gcv rss ldose 2 100.0 100.0 sexmale 1 26.9 24.7 ldose1-unused 0 0.0 0.0 > a1update <- update(a1, trace=0) > check.models.equal(a1, a1update, msg="a1update a1", newdata=data.frame(sex="female", ldose=10, ldose1=11)) a1update a1: models not identical a1update a1: glm submodel formula strings are identical: yarg ~ ldose + sexmale a1update a1: but the actual glm submodel formulas differ (classes are "formula" and "formula") a1update a1: glm submodels not identical (but coefs, residuals, fitted.values are the same) a1update a1: Models are equivalent, within numerical tolerances > > # test some different but equivalent glm specs > a1a <- earth(SF ~ sex + ldose + ldose1, glm=list(family="binomial"), trace=1, pmethod=PMETHOD, nk=NK, degree=2) x[12,3] with colnames sexmale ldose ldose1 y[12,2] with colnames numdead numalive earth and glm: unweighted Response columns numdead and numalive are a binomial pair (240 obs in total) yfrac[12,1] with colname numdead, and values 0.05, 0.2, 0.45, 0.65, 0.9, 1... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.935 RSq 0.981 Prune none penalty 3 nprune null: selected 3 of 3 terms, and 2 of 3 preds After pruning pass GRSq 0.935 RSq 0.981 GLM numdead devratio 0.95 dof 9/11 iters 4 > check.models.equal(a1a, a1, msg="a1 a1a", newdata=data.frame(sex="female", ldose=10, ldose1=11)) a1 a1a: models not identical a1 a1a: glm submodel formula strings are identical: yarg ~ ldose + sexmale a1 a1a: but the actual glm submodel formulas differ (classes are "formula" and "formula") a1 a1a: glm submodels not identical (but coefs, residuals, fitted.values are the same) a1 a1a: Models are equivalent, within numerical tolerances > a1b <- earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial), trace=1, pmethod=PMETHOD, nk=NK, degree=2) x[12,3] with colnames sexmale ldose ldose1 y[12,2] with colnames numdead numalive earth and glm: unweighted Response columns numdead and numalive are a binomial pair (240 obs in total) yfrac[12,1] with colname numdead, and values 0.05, 0.2, 0.45, 0.65, 0.9, 1... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.935 RSq 0.981 Prune none penalty 3 nprune null: selected 3 of 3 terms, and 2 of 3 preds After pruning pass GRSq 0.935 RSq 0.981 GLM numdead devratio 0.95 dof 9/11 iters 4 > check.models.equal(a1, a1b, msg="a1 a1b", newdata=data.frame(sex="female", ldose=10, ldose1=11)) a1 a1b: models not identical a1 a1b: glm submodel formula strings are identical: yarg ~ ldose + sexmale a1 a1b: but the actual glm submodel formulas differ (classes are "formula" and "formula") a1 a1b: glm submodels not identical (but coefs, residuals, fitted.values are the same) a1 a1b: Models are equivalent, within numerical tolerances > a1c <- earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial()), trace=1, pmethod=PMETHOD, nk=NK, degree=2) x[12,3] with colnames sexmale ldose ldose1 y[12,2] with colnames numdead numalive earth and glm: unweighted Response columns numdead and numalive are a binomial pair (240 obs in total) yfrac[12,1] with colname numdead, and values 0.05, 0.2, 0.45, 0.65, 0.9, 1... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.935 RSq 0.981 Prune none penalty 3 nprune null: selected 3 of 3 terms, and 2 of 3 preds After pruning pass GRSq 0.935 RSq 0.981 GLM numdead devratio 0.95 dof 9/11 iters 4 > check.models.equal(a1, a1c, msg="a1 a1c", newdata=data.frame(sex="female", ldose=10, ldose1=11)) a1 a1c: models not identical a1 a1c: glm submodel formula strings are identical: yarg ~ ldose + sexmale a1 a1c: but the actual glm submodel formulas differ (classes are "formula" and "formula") a1 a1c: glm submodels not identical (but coefs, residuals, fitted.values are the same) a1 a1c: Models are equivalent, within numerical tolerances > a1d <- earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit")), trace=1, pmethod=PMETHOD, nk=NK, degree=2) x[12,3] with colnames sexmale ldose ldose1 y[12,2] with colnames numdead numalive earth and glm: unweighted Response columns numdead and numalive are a binomial pair (240 obs in total) yfrac[12,1] with colname numdead, and values 0.05, 0.2, 0.45, 0.65, 0.9, 1... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.935 RSq 0.981 Prune none penalty 3 nprune null: selected 3 of 3 terms, and 2 of 3 preds After pruning pass GRSq 0.935 RSq 0.981 GLM numdead devratio 0.95 dof 9/11 iters 4 > check.models.equal(a1, a1d, msg="a1 a1d", newdata=data.frame(sex="female", ldose=10, ldose1=11)) a1 a1d: models not identical a1 a1d: glm submodel formula strings are identical: yarg ~ ldose + sexmale a1 a1d: but the actual glm submodel formulas differ (classes are "formula" and "formula") a1 a1d: glm submodels not identical (but coefs, residuals, fitted.values are the same) a1 a1d: Models are equivalent, within numerical tolerances > expect.err(try(earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit"),offset=NULL), trace=1, pmethod=PMETHOD, nk=NK, degree=2)), "earth: 'offset' is not supported in glm argument to earth") x[12,3] with colnames sexmale ldose ldose1 y[12,2] with colnames numdead numalive Error : earth: 'offset' is not supported in glm argument to earth Got error as expected from try(earth(SF ~ sex + ldose + ldose1, glm = list(family = binomial(link = "logit"), offset = NULL), trace = 1, pmethod = PMETHOD, nk = NK, degree = 2)) > a1g <- earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit"),control=glm.control()), trace=1, pmethod=PMETHOD, nk=NK, degree=2) x[12,3] with colnames sexmale ldose ldose1 y[12,2] with colnames numdead numalive earth and glm: unweighted Response columns numdead and numalive are a binomial pair (240 obs in total) yfrac[12,1] with colname numdead, and values 0.05, 0.2, 0.45, 0.65, 0.9, 1... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.935 RSq 0.981 Prune none penalty 3 nprune null: selected 3 of 3 terms, and 2 of 3 preds After pruning pass GRSq 0.935 RSq 0.981 GLM numdead devratio 0.95 dof 9/11 iters 4 > check.models.equal(a1, a1g, msg="a1 a1g", newdata=data.frame(sex="female", ldose=10, ldose1=11)) a1 a1g: models not identical a1 a1g: glm submodel formula strings are identical: yarg ~ ldose + sexmale a1 a1g: but the actual glm submodel formulas differ (classes are "formula" and "formula") a1 a1g: glm submodels not identical (but coefs, residuals, fitted.values are the same) a1 a1g: Models are equivalent, within numerical tolerances > # following should cause a "did not converge warning" because maxit=2 > a1h <- earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit"),control=glm.control(epsilon=1e-8, maxit=2, trace=TRUE)), trace=1, pmethod=PMETHOD, nk=NK, degree=2) x[12,3] with colnames sexmale ldose ldose1 y[12,2] with colnames numdead numalive earth and glm: unweighted Response columns numdead and numalive are a binomial pair (240 obs in total) yfrac[12,1] with colname numdead, and values 0.05, 0.2, 0.45, 0.65, 0.9, 1... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.935 RSq 0.981 Prune none penalty 3 nprune null: selected 3 of 3 terms, and 2 of 3 preds After pruning pass GRSq 0.935 RSq 0.981 Deviance = 6.811649 Iterations - 1 Deviance = 6.757094 Iterations - 2 Warning: glm.fit: algorithm did not converge GLM numdead devratio 0.95 dof 9/11 iters 2 Warning: the glm algorithm did not converge for response "numdead" > show.earth.models(a1h, legend.pos="topleft") # show non convergence (and maxit) Print a1h GLM (family binomial, link logit, maxit=2): nulldev df dev df devratio AIC iters converged 124.876 11 6.75709 9 0.946 42.87 2 0 Earth selected 3 of 3 terms, and 2 of 3 predictors (pmethod="none") Termination condition: Reached nk 6 Importance: ldose, sexmale, ldose1-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.008085317 RSS 0.02425595 GRSq 0.9353281 RSq 0.9807588 Summary a1h Call: earth(formula=SF~sex+ldose+ldose1, pmethod=PMETHOD, trace=1, glm=list(family=binomial(link="logit"),control=glm.con...), degree=2, nk=NK) GLM coefficients numdead (Intercept) -1.343835 sexmale 1.099751 ldose 1.063528 GLM (family binomial, link logit, maxit=2): nulldev df dev df devratio AIC iters converged 124.876 11 6.75709 9 0.946 42.87 2 0 Earth selected 3 of 3 terms, and 2 of 3 predictors (pmethod="none") Termination condition: Reached nk 6 Importance: ldose, sexmale, ldose1-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.008085317 RSS 0.02425595 GRSq 0.9353281 RSq 0.9807588 Summary a1h decomp="none", digits=5, fixed.point=FALSE, details=TRUE Call: earth(formula=SF~sex+ldose+ldose1, pmethod=PMETHOD, trace=1, glm=list(family=binomial(link="logit"),control=glm.con...), degree=2, nk=NK) Earth coefficients numdead (Intercept) 0.29226 ldose 0.18214 sexmale 0.15833 GLM coefficients numdead (Intercept) -1.3438 ldose 1.0635 sexmale 1.0998 GLM deviance residuals: Min 1Q Median 3Q Max -1.106632 -0.654066 -0.022671 0.486200 1.430948 GLM coefficients (family binomial, link logit) Estimate Std. Error z value Pr(>|z|) (Intercept) -1.34383 0.27542 -4.8793 1.065e-06 ldose 1.06353 0.12814 8.3000 < 2.2e-16 sexmale 1.09975 0.35113 3.1320 0.001736 GLM (family binomial, link logit, maxit=2): nulldev df dev df devratio AIC iters converged 124.9 11 6.757 9 0.95 42.9 2 0 Earth selected 3 of 3 terms, and 2 of 3 predictors (pmethod="none") Termination condition: Reached nk 6 Importance: ldose, sexmale, ldose1-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.0080853 RSS 0.024256 GRSq 0.93533 RSq 0.98076 evimp a1h nsubsets gcv rss ldose 2 100.0 100.0 sexmale 1 26.9 24.7 evimp a1h trim=FALSE nsubsets gcv rss ldose 2 100.0 100.0 sexmale 1 26.9 24.7 ldose1-unused 0 0.0 0.0 glm params: epsilon 1e-08 maxit 2 trace TRUE family binomial link logit plotmo a1h plotmo grid: sex ldose ldose1 female 0.5 0.6 ------------------------------------------------------------------------------- > check.models.equal(a1, a1g, msg="a1 a1h", newdata=data.frame(sex="female", ldose=10, ldose1=11)) # models should still be equal within numeric tolerance a1 a1h: models not identical a1 a1h: glm submodel formula strings are identical: yarg ~ ldose + sexmale a1 a1h: but the actual glm submodel formulas differ (classes are "formula" and "formula") a1 a1h: glm submodels not identical (but coefs, residuals, fitted.values are the same) a1 a1h: Models are equivalent, within numerical tolerances > stopifnot(a1h$glm.list[[1]]$control$maxit == 2) > # equivalent way of specifying maxit > a1h2 <- earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit"),control=glm.control(epsilon=1e-8),maxit=2), pmethod=PMETHOD, nk=NK, degree=2) Warning: glm.fit: algorithm did not converge Warning: the glm algorithm did not converge for response "numdead" > check.models.equal(a1h, a1h2, msg="a1h a1h2", newdata=data.frame(sex="female", ldose=10, ldose1=11)) a1h a1h2: models not identical a1h a1h2: glm submodel formula strings are identical: yarg ~ ldose + sexmale a1h a1h2: but the actual glm submodel formulas differ (classes are "formula" and "formula") a1h a1h2: glm submodels not identical (but coefs, residuals, fitted.values are the same) a1h a1h2: Models are equivalent, within numerical tolerances > stopifnot(a1h2$glm.list[[1]]$control$maxit == 2) > expect.err(try(earth(SF ~ sex + ldose + ldose1, family=binomial)), "illegal 'family' argument to earth\nTry something like earth(y~x, glm=list(family=binomial))") Error : illegal 'family' argument to earth Try something like earth(y~x, glm=list(family=binomial)) Got error as expected from try(earth(SF ~ sex + ldose + ldose1, family = binomial)) > expect.err(try(earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit")), maxi=123)), "illegal 'maxit' argument to earth\nTry something like earth(y~x, glm=list(family=binomial, control=list(maxit=99)))") Error : illegal 'maxit' argument to earth Try something like earth(y~x, glm=list(family=binomial, control=list(maxit=99))) Got error as expected from try(earth(SF ~ sex + ldose + ldose1, glm = list(family = binomial(link = "logit")), maxi = 123)) > expect.err(try(earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit")), eps=123)), "illegal 'epsilon' argument to earth\nTry something like earth(y~x, glm=list(family=binomial, control=list(epsilon=1e-9)))") Error : illegal 'epsilon' argument to earth Try something like earth(y~x, glm=list(family=binomial, control=list(epsilon=1e-9))) Got error as expected from try(earth(SF ~ sex + ldose + ldose1, glm = list(family = binomial(link = "logit")), eps = 123)) > expect.err(try(earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit"), weights=1:nrow(SF)))), "earth: illegal 'weights' in 'glm' argument") Error : earth: illegal 'weights' in 'glm' argument Use earth's 'weights' argument instead (which will be passed on to glm internally) Got error as expected from try(earth(SF ~ sex + ldose + ldose1, glm = list(family = binomial(link = "logit"), weights = 1:nrow(SF)))) > expect.err(try(earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit"), subset=1:nrow(SF)))), "earth: illegal 'subset' in 'glm' argument") Error : earth: illegal 'subset' in 'glm' argument Use earth's 'subset' argument instead (which will be passed on to glm internally) Got error as expected from try(earth(SF ~ sex + ldose + ldose1, glm = list(family = binomial(link = "logit"), subset = 1:nrow(SF)))) > expect.err(try(earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit"), formula=SF~sex))), "earth: illegal 'formula' in 'glm' argument") Error : earth: illegal 'formula' in 'glm' argument Use earth's 'formula' argument instead Got error as expected from try(earth(SF ~ sex + ldose + ldose1, glm = list(family = binomial(link = "logit"), formula = SF ~ sex))) > > plotres(a1h, caption="a1h: default type", legend.pos="topleft") > plotres(a1h, type="response", caption="a1h: type=\"response\" (same as default type)", legend.pos="topleft") > plotres(a1h, type="earth", caption="a1h: type=\"earth\"", legend.pos="topleft") > > # check update, also check params are carried forward properly with update > a1h.update1 <- update(a1h, glm=list(family=binomial(link="probit"), maxit=8)) x[12,3] with colnames sexmale ldose ldose1 y[12,2] with colnames numdead numalive earth and glm: unweighted Response columns numdead and numalive are a binomial pair (240 obs in total) yfrac[12,1] with colname numdead, and values 0.05, 0.2, 0.45, 0.65, 0.9, 1... Skipped forward pass Prune none penalty 3 nprune null: selected 3 of 3 terms, and 2 of 3 preds After pruning pass GRSq 0.935 RSq 0.981 GLM numdead devratio 0.96 dof 9/11 iters 4 > stopifnot(a1h.update1$glm.list[[1]]$control$maxit == 8) > show.earth.models(a1h.update1, legend.pos="topleft") Print a1h.update1 GLM (family binomial, link probit): nulldev df dev df devratio AIC iters converged 124.876 11 5.56596 9 0.955 41.68 4 1 Earth selected 3 of 3 terms, and 2 of 3 predictors (pmethod="none") Termination condition: Reached nk 6 Importance: ldose, sexmale, ldose1-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.008085317 RSS 0.02425595 GRSq 0.9353281 RSq 0.9807588 Summary a1h.update1 Call: earth(formula=SF~sex+ldose+ldose1, pmethod=PMETHOD, trace=1, glm=list(family=binomial(link="probit"),maxit=8), degree=2, nk=NK, Object=a1h) GLM coefficients numdead (Intercept) -0.7954325 sexmale 0.6536447 ldose 0.6324486 GLM (family binomial, link probit): nulldev df dev df devratio AIC iters converged 124.876 11 5.56596 9 0.955 41.68 4 1 Earth selected 3 of 3 terms, and 2 of 3 predictors (pmethod="none") Termination condition: Reached nk 6 Importance: ldose, sexmale, ldose1-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.008085317 RSS 0.02425595 GRSq 0.9353281 RSq 0.9807588 Summary a1h.update1 digits=3, details=TRUE Call: earth(formula=SF~sex+ldose+ldose1, pmethod=PMETHOD, trace=1, glm=list(family=binomial(link="probit"),maxit=8), degree=2, nk=NK, Object=a1h) Earth coefficients numdead (Intercept) 0.292 ldose 0.182 sexmale 0.158 GLM coefficients numdead (Intercept) -0.795 ldose 0.632 sexmale 0.654 GLM deviance residuals: Min 1Q Median 3Q Max -0.8917 -0.5833 -0.0773 0.4622 1.2710 GLM coefficients (family binomial, link probit) Estimate Std. Error z value Pr(>|z|) (Intercept) -0.7954 0.1562 -5.09 3.5e-07 ldose 0.6324 0.0697 9.07 < 2e-16 sexmale 0.6536 0.2024 3.23 0.0012 GLM (family binomial, link probit): nulldev df dev df devratio AIC iters converged 125 11 5.57 9 0.96 41.7 4 1 Earth selected 3 of 3 terms, and 2 of 3 predictors (pmethod="none") Termination condition: Reached nk 6 Importance: ldose, sexmale, ldose1-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.00809 RSS 0.0243 GRSq 0.935 RSq 0.981 evimp a1h.update1 nsubsets gcv rss ldose 2 100.0 100.0 sexmale 1 26.9 24.7 evimp a1h.update1 trim=FALSE nsubsets gcv rss ldose 2 100.0 100.0 sexmale 1 26.9 24.7 ldose1-unused 0 0.0 0.0 glm params: epsilon 1e-08 maxit 8 trace FALSE family binomial link probit plotmo a1h.update1 plotmo grid: sex ldose ldose1 female 0.5 0.6 ------------------------------------------------------------------------------- > a1h.update2 <- update(a1h, glm=list(family=gaussian, maxit=9), degree=1) x[12,3] with colnames sexmale ldose ldose1 y[12,2] with colnames numdead numalive Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.952 RSq 0.981 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 3 preds After pruning pass GRSq 0.952 RSq 0.981 GLM numdead devratio 0.98 dof 9/11 iters 2 GLM numalive devratio 0.98 dof 9/11 iters 2 > stopifnot(a1h.update2$glm.list[[1]]$control$maxit == 9) > show.earth.models(a1h.update2, nresponse="numdea", legend.pos="topleft") Print a1h.update2 GLM (family gaussian, link identity): nulldev df dev df devratio AIC iters converged numdead 504.25 11 9.70238 9 0.981 39.5 2 1 numalive 504.25 11 9.70238 9 0.981 39.5 2 1 Earth selected 3 of 3 terms, and 2 of 3 predictors (pmethod="none") Termination condition: Reached nk 6 Importance: ldose, sexmale, ldose1-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV RSS GRSq RSq numdead 2.376093 9.702381 0.952486 0.9807588 numalive 2.376093 9.702381 0.952486 0.9807588 All 4.752187 19.404762 0.952486 0.9807588 Summary a1h.update2 Call: earth(formula=SF~sex+ldose+ldose1, pmethod=PMETHOD, trace=1, glm=list(family=gaussian,maxit=9), degree=1, nk=NK) GLM coefficients numdead numalive (Intercept) 5.845238 14.154762 sexmale 3.166667 -3.166667 ldose 3.642857 -3.642857 GLM (family gaussian, link identity): nulldev df dev df devratio AIC iters converged numdead 504.25 11 9.70238 9 0.981 39.5 2 1 numalive 504.25 11 9.70238 9 0.981 39.5 2 1 Earth selected 3 of 3 terms, and 2 of 3 predictors (pmethod="none") Termination condition: Reached nk 6 Importance: ldose, sexmale, ldose1-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV RSS GRSq RSq numdead 2.376093 9.702381 0.952486 0.9807588 numalive 2.376093 9.702381 0.952486 0.9807588 All 4.752187 19.404762 0.952486 0.9807588 Summary a1h.update2 decomp="none", digits=5, fixed.point=FALSE, details=TRUE Call: earth(formula=SF~sex+ldose+ldose1, pmethod=PMETHOD, trace=1, glm=list(family=gaussian,maxit=9), degree=1, nk=NK) Earth coefficients numdead numalive (Intercept) 5.8452 14.1548 ldose 3.6429 -3.6429 sexmale 3.1667 -3.1667 GLM coefficients numdead numalive (Intercept) 5.8452 14.1548 ldose 3.6429 -3.6429 sexmale 3.1667 -3.1667 GLM numdead deviance residuals: Min 1Q Median 3Q Max -1.36905 -0.73810 0.02381 0.38690 1.70238 GLM numdead coefficients (family gaussian, link identity) Estimate Std. Error t value Pr(>|t|) (Intercept) 5.84524 0.43287 13.5035 2.800e-07 ldose 3.64286 0.17550 20.7567 6.542e-09 sexmale 3.16667 0.59946 5.2826 0.0005054 GLM numdead dispersion parameter for gaussian family taken to be 1.078042 GLM numalive deviance residuals: Min 1Q Median 3Q Max -1.70238 -0.38690 -0.02381 0.73810 1.36905 GLM numalive coefficients (family gaussian, link identity) Estimate Std. Error t value Pr(>|t|) (Intercept) 14.15476 0.43287 32.7000 1.151e-10 ldose -3.64286 0.17550 -20.7567 6.542e-09 sexmale -3.16667 0.59946 -5.2826 0.0005054 GLM numalive dispersion parameter for gaussian family taken to be 1.078042 GLM (family gaussian, link identity): nulldev df dev df devratio AIC iters converged numdead 504.2 11 9.702 9 0.98 39.5 2 1 numalive 504.2 11 9.702 9 0.98 39.5 2 1 Earth selected 3 of 3 terms, and 2 of 3 predictors (pmethod="none") Termination condition: Reached nk 6 Importance: ldose, sexmale, ldose1-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV RSS GRSq RSq numdead 2.3761 9.7024 0.95249 0.98076 numalive 2.3761 9.7024 0.95249 0.98076 All 4.7522 19.4048 0.95249 0.98076 evimp a1h.update2 nsubsets gcv rss ldose 2 100.0 100.0 sexmale 1 27.2 24.7 evimp a1h.update2 trim=FALSE nsubsets gcv rss ldose 2 100.0 100.0 sexmale 1 27.2 24.7 ldose1-unused 0 0.0 0.0 glm params: epsilon 1e-08 maxit 9 trace FALSE family gaussian link identity plotmo a1h.update2 plotmo grid: sex ldose ldose1 female 0.5 0.6 ------------------------------------------------------------------------------- > > # basic check with an I in formula > a1i <- earth(SF ~ sex + ldose + I(ldose1-3), glm=list(family="binomial"), trace=1, pmethod=PMETHOD, nk=NK, degree=2) x[12,3] with colnames sexmale ldose I(ldose1-3) y[12,2] with colnames numdead numalive earth and glm: unweighted Response columns numdead and numalive are a binomial pair (240 obs in total) yfrac[12,1] with colname numdead, and values 0.05, 0.2, 0.45, 0.65, 0.9, 1... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.935 RSq 0.981 Prune none penalty 3 nprune null: selected 3 of 3 terms, and 2 of 3 preds After pruning pass GRSq 0.935 RSq 0.981 GLM numdead devratio 0.95 dof 9/11 iters 4 > print(summary(a1i)) Call: earth(formula=SF~sex+ldose+I(ldose1-3), pmethod=PMETHOD, trace=1, glm=list(family="binomial"), degree=2, nk=NK) GLM coefficients numdead (Intercept) -1.344727 sexmale 1.100743 ldose 1.064214 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 124.876 11 6.75706 9 0.946 42.87 4 1 Earth selected 3 of 3 terms, and 2 of 3 predictors (pmethod="none") Termination condition: Reached nk 6 Importance: ldose, sexmale, I(ldose1-3)-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.008085317 RSS 0.02425595 GRSq 0.9353281 RSq 0.9807588 > > cat("a2: single response glm model but with a binomial pair of y columns, degree=1\n\n") a2: single response glm model but with a binomial pair of y columns, degree=1 > a2 <- earth(SF ~ sex*ldose, glm=list(fa="b"), trace=3, pmethod=PMETHOD) x[12,3] with colnames sexmale ldose sexmale:ldose y[12,2] with colnames numdead numalive earth and glm: unweighted Response columns numdead and numalive are a binomial pair (240 obs in total) yfrac[12,1] with colname numdead, and values 0.05, 0.2, 0.45, 0.65, 0.9, 1... Forward pass: minspan 3 endspan 5 x[12,3] 288 Bytes bx[12,21] 1.97 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.8821 0.9211 0.9211 2 ldose -2< 2 1 4 0.9525 0.9808 0.05966 1 sexmale 0< 3 1 6 0.8826 0.9913 0.01051 3 sexmale:ldos 0 4 5 1 8 -0.0568 0.9913 0 - reject (no DeltaRsq) RSq changed by less than 0.001 at 7 terms, 5 terms used (DeltaRSq 0) After forward pass GRSq -0.057 RSq 0.991 Forward pass complete: 7 terms, 5 terms used Subset size GRSq RSq DeltaGRSq nPreds 1 0.0000 0.0000 0.0000 0 2 0.8821 0.9211 0.8821 1 3 0.9525 0.9808 0.0704 2 4 0.9402 0.9876 -0.0123 3 chosen 5 0.8826 0.9913 -0.0576 3 Prune none penalty 2 nprune null: selected 5 of 5 terms, and 3 of 3 preds After pruning pass GRSq 0.883 RSq 0.991 GLM numdead devratio 0.96 dof 7/11 iters 4 > show.earth.models(a2, legend.pos="topleft") Print a2 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 124.876 11 4.96002 7 0.96 45.07 4 1 Earth selected 5 of 5 terms, and 3 of 3 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 5 terms Importance: ldose, sexmale, sexmale:ldose Number of terms at each degree of interaction: 1 4 (additive model) Earth GCV 0.01468087 RSS 0.01101065 GRSq 0.8825725 RSq 0.9912657 Summary a2 Call: earth(formula=SF~sex*ldose, pmethod=PMETHOD, trace=3, glm=list(fa="b")) GLM coefficients numdead (Intercept) -1.1814689 sexmale 0.8263579 ldose 0.9060364 h(0-sexmale:ldose) -0.2777279 h(sexmale:ldose-0) 0.4011671 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 124.876 11 4.96002 7 0.96 45.07 4 1 Earth selected 5 of 5 terms, and 3 of 3 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 5 terms Importance: ldose, sexmale, sexmale:ldose Number of terms at each degree of interaction: 1 4 (additive model) Earth GCV 0.01468087 RSS 0.01101065 GRSq 0.8825725 RSq 0.9912657 Summary a2 digits=3, details=TRUE Call: earth(formula=SF~sex*ldose, pmethod=PMETHOD, trace=3, glm=list(fa="b")) Earth coefficients numdead (Intercept) 0.3019 ldose 0.1629 sexmale 0.1490 h(sexmale:ldose-0) 0.0332 h(0-sexmale:ldose) -0.0477 GLM coefficients numdead (Intercept) -1.181 ldose 0.906 sexmale 0.826 h(sexmale:ldose-0) 0.401 h(0-sexmale:ldose) -0.278 GLM deviance residuals: Min 1Q Median 3Q Max -1.398 -0.321 -0.116 0.411 1.056 GLM coefficients (family binomial, link logit) Estimate Std. Error z value Pr(>|z|) (Intercept) -1.181 0.285 -4.14 3.5e-05 ldose 0.906 0.167 5.42 5.9e-08 sexmale 0.826 0.489 1.69 0.091 h(sexmale:ldose-0) 0.401 0.380 1.06 0.291 h(0-sexmale:ldose) -0.278 0.486 -0.57 0.568 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 125 11 4.96 7 0.96 45.1 4 1 Earth selected 5 of 5 terms, and 3 of 3 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 5 terms Importance: ldose, sexmale, sexmale:ldose Number of terms at each degree of interaction: 1 4 (additive model) Earth GCV 0.0147 RSS 0.011 GRSq 0.883 RSq 0.991 evimp a2 nsubsets gcv rss ldose 4 100.0 100.0 sexmale 3 2.2 26.6 sexmale:ldose 2 -28.1 10.3 evimp a2 trim=FALSE nsubsets gcv rss ldose 4 100.0 100.0 sexmale 3 2.2 26.6 sexmale:ldose 2 -28.1 10.3 glm params: epsilon 1e-08 maxit 25 trace FALSE family binomial link logit plotmo a2 plotmo grid: sex ldose female 0.5 ------------------------------------------------------------------------------- > # repeat with bpairs arg > a2a <- earth(SF ~ sex*ldose, glm=list(family="binomial", bpairs=c(TRUE,FALSE)), trace=3, pmethod=PMETHOD) x[12,3] with colnames sexmale ldose sexmale:ldose y[12,2] with colnames numdead numalive Warning: earth: the 'bpairs' argument is no longer supported (binomial pairs are determined automatically) See comments for 'bpairs' in the earth NEWS file (earth version 5.0.0) earth and glm: unweighted Response columns numdead and numalive are a binomial pair (240 obs in total) yfrac[12,1] with colname numdead, and values 0.05, 0.2, 0.45, 0.65, 0.9, 1... Forward pass: minspan 3 endspan 5 x[12,3] 288 Bytes bx[12,21] 1.97 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.8821 0.9211 0.9211 2 ldose -2< 2 1 4 0.9525 0.9808 0.05966 1 sexmale 0< 3 1 6 0.8826 0.9913 0.01051 3 sexmale:ldos 0 4 5 1 8 -0.0568 0.9913 0 - reject (no DeltaRsq) RSq changed by less than 0.001 at 7 terms, 5 terms used (DeltaRSq 0) After forward pass GRSq -0.057 RSq 0.991 Forward pass complete: 7 terms, 5 terms used Subset size GRSq RSq DeltaGRSq nPreds 1 0.0000 0.0000 0.0000 0 2 0.8821 0.9211 0.8821 1 3 0.9525 0.9808 0.0704 2 4 0.9402 0.9876 -0.0123 3 chosen 5 0.8826 0.9913 -0.0576 3 Prune none penalty 2 nprune null: selected 5 of 5 terms, and 3 of 3 preds After pruning pass GRSq 0.883 RSq 0.991 GLM numdead devratio 0.96 dof 7/11 iters 4 > stopifnot(identical(a2$glm.list[[1]]$coefficients, a2a$glm.list[[1]]$coefficients)) > stopifnot(isTRUE(all.equal(coef(a2), coefficients(a2)))) > stopifnot(isTRUE(all.equal(coef(a2, type="glm"), coefficients(a2, type="glm")))) > stopifnot(isTRUE(all.equal(coef(a2, type="earth"), coefficients(a2, type="earth")))) > stopifnot(identical(names(coef(a2)), rownames(a2$coefficients))) > stopifnot(identical(names(coef(a2)), rownames(a2$glm.coefficients))) > stopifnot(identical(names(coef(a2, type="glm")), rownames(a2$glm.coefficients))) > stopifnot(max(abs(coef(a2) - a2$glm.coefficients)) == 0) > stopifnot(max(abs(coef(a2, type="earth") - a2$coefficients)) == 0) > stopifnot(max(abs(coef(a2) - a2$glm.list[[1]]$coefficients)) == 0) > a2b <- earth(numdead+numalive~sex*ldose, glm=list(family="binomial"), pmethod=PMETHOD) > predict.a2 <- predict(a2,newdata=data.frame(sex=sex[1],ldose=3)) > predict.a2a <- predict(a2a,newdata=data.frame(sex=sex[1],ldose=3)) > predict.a2b <- predict(a2b,newdata=data.frame(sex=sex[1],ldose=3)) > stopifnot(identical(predict.a2a, predict.a2)) > stopifnot(identical(predict.a2b, predict.a2)) > > a2c <- earth(SF ~ sex, glm=list(family="binomial"), trace=0, pmethod=PMETHOD) > a2update <- update(a2, SF ~ sex, trace=0) > check.models.equal(a2c, a2update, msg="a2c a2update", newdata=data.frame(sex="female", ldose=10, ldose1=11)) a2c a2update: models not identical a2c a2update: glm submodel formula strings are identical: yarg ~ sexmale a2c a2update: but the actual glm submodel formulas differ (classes are "formula" and "formula") a2c a2update: glm submodels not identical (but coefs, residuals, fitted.values are the same) a2c a2update: Models are equivalent, within numerical tolerances > > # build a standard GLM model for comparison > cat("a3: direct GLM a3:\n\n") a3: direct GLM a3: > a3 <- glm(SF ~ sex * ldose, family="binomial") > print(summary(a3)) Call: glm(formula = SF ~ sex * ldose, family = "binomial") Deviance Residuals: Min 1Q Median 3Q Max -1.39849 -0.32094 -0.07592 0.38220 1.10375 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) -1.1815 0.2853 -4.141 3.46e-05 *** sexmale 0.8808 0.3884 2.268 0.0234 * ldose 0.9060 0.1671 5.422 5.89e-08 *** sexmale:ldose 0.3529 0.2700 1.307 0.1912 --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 124.8756 on 11 degrees of freedom Residual deviance: 4.9937 on 8 degrees of freedom AIC: 43.104 Number of Fisher Scoring iterations: 4 > plotmo(a3, caption="a3 <- glm(SF ~ sex * ldose, family=\"binomial\")") plotmo grid: sex ldose female 0.5 > cat("-------------------------------------------------------------------------------\n\n") ------------------------------------------------------------------------------- > > # double response glm model with two binomial paired cols > SF.both <- cbind(SF, SF2) > cat("a4: double response glm model with two binomial paired cols\n\n") a4: double response glm model with two binomial paired cols > expect.err(try(earth(SF.both ~ sex*ldose, linpreds=TRUE, glm=list(family="binomial"), trace=1)), "Binomial response (see above): all values should be between 0 and 1, or a binomial pair") x[12,3] with colnames sexmale ldose sexmale:ldose y[12,4] with colnames numdead numalive numdead2 numalive2 print(head(y)): numdead numalive numdead2 numalive2 [1,] 1 19 2 18 [2,] 4 16 3 17 [3,] 9 11 10 10 [4,] 13 7 13 7 [5,] 18 2 19 1 [6,] 20 0 20 0 Error : Binomial response (see above): all values should be between 0 and 1, or a binomial pair Got error as expected from try(earth(SF.both ~ sex * ldose, linpreds = TRUE, glm = list(family = "binomial"), trace = 1)) > > # titanic data, multiple responses (i.e. 3 level factor) > cat("a5: titanic data, multiple responses (i.e. 3 level factor)\n\n") a5: titanic data, multiple responses (i.e. 3 level factor) > a5 <- earth(pclass ~ ., data=etitanic, degree=2, glm=list(family="binomial"), trace=0) > show.earth.models(a5, nresponse=1) Print a5 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 1223.31 1045 894.814 1037 0.2690 912.8 5 1 2nd 1175.31 1045 1126.944 1037 0.0411 1145.0 5 1 3rd 1448.21 1045 1118.941 1037 0.2270 1137.0 5 1 Earth selected 9 of 17 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 4 4 Earth GCV RSS GRSq RSq 1st 0.1478715 148.5253 0.253819943 0.28210854 2nd 0.1869804 187.8072 0.003405389 0.04118751 3rd 0.1895587 190.3968 0.241872961 0.27061448 All 0.5244105 526.7293 0.175229617 0.20649767 Summary a5 Call: earth(formula=pclass~., data=etitanic, trace=0, glm=list(family="binomial"), degree=2) GLM coefficients 1st 2nd 3rd (Intercept) -2.66307135 -1.93136147 1.37992944 survived 2.84788552 1.06418271 -2.84378575 sexmale 1.42483431 0.96598862 -1.45239590 h(sibsp-1) -0.52879762 -0.64928949 0.79974678 h(2-parch) 1.25518755 0.06534587 -1.29855706 survived * sexmale -1.25498201 -1.95099222 2.28554497 survived * h(16-age) -0.17824991 0.09390085 0.02011681 h(55-age) * h(2-parch) -0.04946408 0.00043737 0.04146455 h(1-sibsp) * h(1-parch) -1.02162885 -0.21902436 1.12490799 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 1223.31 1045 894.814 1037 0.2690 912.8 5 1 2nd 1175.31 1045 1126.944 1037 0.0411 1145.0 5 1 3rd 1448.21 1045 1118.941 1037 0.2270 1137.0 5 1 Earth selected 9 of 17 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 4 4 Earth GCV RSS GRSq RSq 1st 0.1478715 148.5253 0.253819943 0.28210854 2nd 0.1869804 187.8072 0.003405389 0.04118751 3rd 0.1895587 190.3968 0.241872961 0.27061448 All 0.5244105 526.7293 0.175229617 0.20649767 Summary a5 decomp="none", digits=5, fixed.point=FALSE, details=TRUE Call: earth(formula=pclass~., data=etitanic, trace=0, glm=list(family="binomial"), degree=2) Earth coefficients 1st 2nd 3rd (Intercept) 0.1396780 1.3822e-01 0.7221057 survived 0.3518559 1.6023e-01 -0.5120905 h(sibsp-1) -0.0479585 -6.7564e-02 0.1155224 h(2-parch) 0.2173334 9.4235e-03 -0.2267568 survived * h(16-age) -0.0232585 1.8686e-02 0.0045728 survived * sexmale -0.0959323 -3.0327e-01 0.3992025 sexmale 0.1093674 1.3653e-01 -0.2458963 h(55-age) * h(2-parch) -0.0078473 3.5599e-05 0.0078117 h(1-sibsp) * h(1-parch) -0.1623930 -3.2878e-02 0.1952714 GLM coefficients 1st 2nd 3rd (Intercept) -2.663071 -1.93136147 1.379929 survived 2.847886 1.06418271 -2.843786 h(sibsp-1) -0.528798 -0.64928949 0.799747 h(2-parch) 1.255188 0.06534587 -1.298557 survived * h(16-age) -0.178250 0.09390085 0.020117 survived * sexmale -1.254982 -1.95099222 2.285545 sexmale 1.424834 0.96598862 -1.452396 h(55-age) * h(2-parch) -0.049464 0.00043737 0.041465 h(1-sibsp) * h(1-parch) -1.021629 -0.21902436 1.124908 GLM 1st deviance residuals: Min 1Q Median 3Q Max -2.02122 -0.68435 -0.35766 0.56892 2.66017 GLM 1st coefficients (family binomial, link logit) Estimate Std. Error z value Pr(>|z|) (Intercept) -2.6630714 0.5298325 -5.0263 5.002e-07 survived 2.8478855 0.5104917 5.5787 2.423e-08 h(sibsp-1) -0.5287976 0.2365149 -2.2358 0.0253656 h(2-parch) 1.2551876 0.1875848 6.6913 2.212e-11 survived * h(16-age) -0.1782499 0.0515714 -3.4564 0.0005475 survived * sexmale -1.2549820 0.5640362 -2.2250 0.0260811 sexmale 1.4248343 0.5092679 2.7978 0.0051451 h(55-age) * h(2-parch) -0.0494641 0.0044068 -11.2244 < 2.2e-16 h(1-sibsp) * h(1-parch) -1.0216289 0.2129941 -4.7965 1.615e-06 GLM 2nd deviance residuals: Min 1Q Median 3Q Max -1.45407 -0.80675 -0.77534 -0.10402 2.07089 GLM 2nd coefficients (family binomial, link logit) Estimate Std. Error z value Pr(>|z|) (Intercept) -1.93136147 0.37697795 -5.1233 3.003e-07 survived 1.06418271 0.34979070 3.0423 0.0023475 h(sibsp-1) -0.64928949 0.22307746 -2.9106 0.0036073 h(2-parch) 0.06534587 0.17330956 0.3770 0.7061386 survived * h(16-age) 0.09390085 0.02842944 3.3029 0.0009568 survived * sexmale -1.95099222 0.43722003 -4.4623 8.110e-06 sexmale 0.96598862 0.34300568 2.8162 0.0048588 h(55-age) * h(2-parch) 0.00043737 0.00357988 0.1222 0.9027599 h(1-sibsp) * h(1-parch) -0.21902436 0.19299092 -1.1349 0.2564195 GLM 3rd deviance residuals: Min 1Q Median 3Q Max -2.32939 -0.83909 -0.32160 0.89944 2.61933 GLM 3rd coefficients (family binomial, link logit) Estimate Std. Error z value Pr(>|z|) (Intercept) 1.3799294 0.3534087 3.9046 9.437e-05 survived -2.8437858 0.3383356 -8.4052 < 2.2e-16 h(sibsp-1) 0.7997468 0.1912028 4.1827 2.880e-05 h(2-parch) -1.2985571 0.1912192 -6.7909 1.114e-11 survived * h(16-age) 0.0201168 0.0284533 0.7070 0.4796 survived * sexmale 2.2855450 0.3990264 5.7278 1.017e-08 sexmale -1.4523959 0.3219393 -4.5114 6.440e-06 h(55-age) * h(2-parch) 0.0414645 0.0040611 10.2101 < 2.2e-16 h(1-sibsp) * h(1-parch) 1.1249080 0.2035671 5.5260 3.276e-08 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 1223 1045 894.8 1037 0.270 913 5 1 2nd 1175 1045 1126.9 1037 0.041 1140 5 1 3rd 1448 1045 1118.9 1037 0.230 1140 5 1 Earth selected 9 of 17 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 4 4 Earth GCV RSS GRSq RSq 1st 0.14787 148.53 0.2538199 0.282108 2nd 0.18698 187.81 0.0034054 0.041188 3rd 0.18956 190.40 0.2418730 0.270614 All 0.52441 526.73 0.1752296 0.206498 evimp a5 nsubsets gcv rss age 8 100.0 100.0 parch 8 100.0 100.0 survived 7 79.7 81.7 sibsp 5 40.3 48.0 sexmale 4 34.4 41.7 evimp a5 trim=FALSE nsubsets gcv rss age 8 100.0 100.0 parch 8 100.0 100.0 survived 7 79.7 81.7 sibsp 5 40.3 48.0 sexmale 4 34.4 41.7 glm params: epsilon 1e-08 maxit 25 trace FALSE family binomial link logit plotmo a5 plotmo grid: survived sex age sibsp parch 0 male 28 0 0 ------------------------------------------------------------------------------- > printh(a5$levels) === a5$levels [1] "1st" "2nd" "3rd" > print.stripped.earth.model(a5, "a5") print.stripped.earth.model(a5) $rss [1] 526.7293 $rsq [1] 0.2064977 $gcv [1] 0.5244105 $grsq [1] 0.1752296 $dirs survived sexmale age sibsp parch (Intercept) 0 0 0 0 0 h(age-26) 0 0 1 0 0 h(26-age) 0 0 -1 0 0 survived 2 0 0 0 0 h(sibsp-1) 0 0 0 1 0 h(1-sibsp) 0 0 0 -1 0 h(parch-2) 0 0 0 0 1 h(2-parch) 0 0 0 0 -1 survived*h(age-16) 2 0 1 0 0 survived*h(16-age) 2 0 -1 0 0 survived*sexmale 2 2 0 0 0 sexmale 0 2 0 0 0 h(age-55)*h(2-parch) 0 0 1 0 -1 h(55-age)*h(2-parch) 0 0 -1 0 -1 h(1-sibsp)*h(parch-1) 0 0 0 -1 1 h(1-sibsp)*h(1-parch) 0 0 0 -1 -1 h(age-54) 0 0 1 0 0 $cuts survived sexmale age sibsp parch (Intercept) 0 0 0 0 0 h(age-26) 0 0 26 0 0 h(26-age) 0 0 26 0 0 survived 0 0 0 0 0 h(sibsp-1) 0 0 0 1 0 h(1-sibsp) 0 0 0 1 0 h(parch-2) 0 0 0 0 2 h(2-parch) 0 0 0 0 2 survived*h(age-16) 0 0 16 0 0 survived*h(16-age) 0 0 16 0 0 survived*sexmale 0 0 0 0 0 sexmale 0 0 0 0 0 h(age-55)*h(2-parch) 0 0 55 0 2 h(55-age)*h(2-parch) 0 0 55 0 2 h(1-sibsp)*h(parch-1) 0 0 0 1 1 h(1-sibsp)*h(1-parch) 0 0 0 1 1 h(age-54) 0 0 54 0 0 $selected.terms [1] 1 4 5 8 10 11 12 14 16 $prune.terms [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [1,] 1 0 0 0 0 0 0 0 0 0 0 0 0 [2,] 1 14 0 0 0 0 0 0 0 0 0 0 0 [3,] 1 4 14 0 0 0 0 0 0 0 0 0 0 [4,] 1 4 8 14 0 0 0 0 0 0 0 0 0 [5,] 1 4 8 14 16 0 0 0 0 0 0 0 0 [6,] 1 4 8 11 14 16 0 0 0 0 0 0 0 [7,] 1 4 8 11 12 14 16 0 0 0 0 0 0 [8,] 1 4 5 8 11 12 14 16 0 0 0 0 0 [9,] 1 4 5 8 10 11 12 14 16 0 0 0 0 [10,] 1 4 5 8 10 11 12 14 16 17 0 0 0 [11,] 1 4 5 8 10 11 12 13 14 16 17 0 0 [12,] 1 4 5 7 8 10 11 12 13 14 16 17 0 [13,] 1 3 4 5 7 8 10 11 12 13 14 16 17 [14,] 1 3 4 5 7 8 9 10 11 12 13 14 16 [15,] 1 3 4 5 6 7 8 9 10 11 12 13 14 [16,] 1 3 4 5 6 7 8 9 10 11 12 13 14 [17,] 1 2 3 4 5 6 7 8 9 10 11 12 13 [,14] [,15] [,16] [,17] [1,] 0 0 0 0 [2,] 0 0 0 0 [3,] 0 0 0 0 [4,] 0 0 0 0 [5,] 0 0 0 0 [6,] 0 0 0 0 [7,] 0 0 0 0 [8,] 0 0 0 0 [9,] 0 0 0 0 [10,] 0 0 0 0 [11,] 0 0 0 0 [12,] 0 0 0 0 [13,] 0 0 0 0 [14,] 17 0 0 0 [15,] 16 17 0 0 [16,] 15 16 17 0 [17,] 14 15 16 17 $coefficients 1st 2nd 3rd (Intercept) 0.139677983 0.1382163301 0.722105687 survived 0.351855854 0.1602346217 -0.512090476 h(sibsp-1) -0.047958497 -0.0675639271 0.115522424 h(2-parch) 0.217333399 0.0094234505 -0.226756850 survived*h(16-age) -0.023258457 0.0186856516 0.004572806 survived*sexmale -0.095932289 -0.3032702269 0.399202516 sexmale 0.109367428 0.1365288369 -0.245896265 h(55-age)*h(2-parch) -0.007847314 0.0000355992 0.007811715 h(1-sibsp)*h(1-parch) -0.162393009 -0.0328783910 0.195271400 $rss.per.response [1] 148.5253 187.8072 190.3968 $rsq.per.response [1] 0.28210854 0.04118751 0.27061448 $gcv.per.response [1] 0.1478715 0.1869804 0.1895587 $grsq.per.response [1] 0.253819943 0.003405389 0.241872961 $rss.per.subset [1] 663.8031 618.3144 587.1155 558.2529 550.5473 546.0083 539.0533 532.1400 [9] 526.7293 526.1097 522.0963 519.3960 516.5436 515.0676 514.2161 513.5054 [17] 513.3259 $gcv.per.subset [1] 0.6358261 0.5950986 0.5677911 0.5424834 0.5375831 0.5357360 0.5314825 [8] 0.5272225 0.5244105 0.5263582 0.5249065 0.5247609 0.5244530 0.5255400 [15] 0.5272719 0.5291595 0.5316095 $leverages [1] 0.005158606 0.033494707 0.017266066 0.011963928 0.017266066 0.011263458 [7] 0.011670960 0.002889399 0.014370755 0.007592325 0.008274991 0.008886300 [13] 0.005594526 0.005363932 0.013850834 0.005386378 0.005441478 0.005121957 [19] 0.002541748 0.010859171 0.005243409 0.009110406 0.006218027 0.005158606 [25] 0.002710161 0.012630619 0.008624204 0.005253987 0.008931298 0.004090736 [31] 0.009430977 0.005127648 0.010444850 0.003405728 0.006912318 0.005232760 [37] 0.003214876 0.004944421 0.006662146 0.015229279 0.010444850 0.006024081 [43] 0.004090736 0.009776645 0.009588407 0.010855244 0.005865304 0.002362774 [49] 0.002439326 0.004257037 0.014508881 0.009550159 0.017792581 0.010894224 [55] 0.005266467 0.006450345 0.011670960 0.008015404 0.008894797 0.012364077 [61] 0.006922784 0.005335481 0.005127648 0.010435712 0.006644234 0.007314315 [67] 0.005900089 0.004641118 0.004921387 0.005128157 0.010894224 0.015229279 [73] 0.006077876 0.010894224 0.005865304 0.006723071 0.007205379 0.012259881 [79] 0.009011481 0.005147225 0.006370641 0.010894224 0.012055896 0.009167137 [85] 0.011559223 0.024055130 0.005771168 0.009166204 0.005000615 0.009176221 [91] 0.009176221 0.014380004 0.002889399 0.005176960 0.005554695 0.011258343 [97] 0.012825352 0.008964545 0.002352479 0.014998031 0.014998031 0.014998031 [103] 0.013529385 0.011963928 0.010894224 0.005127648 0.017721685 0.012930589 [109] 0.010894224 0.011731068 0.005304747 0.006522512 0.006979596 0.004641118 [115] 0.005253987 0.005232760 0.005134791 0.002837924 0.014380004 0.007592325 [121] 0.013017873 0.006498998 0.005141092 0.005865304 0.011230581 0.005134791 [127] 0.004356556 0.012630619 0.007445216 0.014091580 0.009476386 0.007774559 [133] 0.006979596 0.003042767 0.009011481 0.005594526 0.006077876 0.005596952 [139] 0.003405728 0.007592325 0.005665956 0.005087510 0.010132943 0.007164476 [145] 0.006979596 0.008894792 0.012238148 0.006979596 0.005554695 0.016839282 [151] 0.011576857 0.004356556 0.005607255 0.002349345 0.007592325 0.006998599 [157] 0.012754617 0.008388177 0.005692415 0.008100426 0.005127648 0.008894792 [163] 0.003405728 0.010444850 0.005665956 0.005516873 0.002386532 0.006080983 [169] 0.002352479 0.010444850 0.005177299 0.002352479 0.007266584 0.008091037 [175] 0.008886300 0.005594526 0.004356556 0.007157827 0.008964545 0.006547723 [181] 0.007592325 0.009555430 0.006922784 0.007111376 0.012104828 0.007592325 [187] 0.004641118 0.005128157 0.006940939 0.007763244 0.011963928 0.010894224 [193] 0.007592325 0.005692415 0.005232760 0.006077876 0.002410586 0.004221303 [199] 0.002984428 0.006469953 0.007950371 0.008356226 0.009167137 0.005127648 [205] 0.012629506 0.004641118 0.005865304 0.002754773 0.003149675 0.005044914 [211] 0.002337169 0.010435712 0.005147225 0.004356556 0.002541748 0.005147225 [217] 0.011026399 0.011258343 0.002362774 0.013933400 0.010020765 0.010020765 [223] 0.011963928 0.010894224 0.005594526 0.006979596 0.005127648 0.008843781 [229] 0.005848877 0.008894792 0.009166204 0.007318124 0.013850834 0.008931298 [235] 0.007592325 0.007592325 0.007046220 0.008886300 0.012792003 0.007763244 [241] 0.019643889 0.011059261 0.004945241 0.011026399 0.008797985 0.007592325 [247] 0.016103256 0.007956525 0.010489334 0.010444850 0.011026399 0.021013236 [253] 0.007592325 0.007775286 0.010894224 0.005814165 0.004921387 0.014091580 [259] 0.005592625 0.017792581 0.004921387 0.008803201 0.003042767 0.007592325 [265] 0.004641118 0.005253987 0.011026399 0.011670960 0.007592325 0.005985287 [271] 0.005558420 0.010444850 0.010894224 0.006077876 0.005134791 0.005661786 [277] 0.011963928 0.005441478 0.006080983 0.005735633 0.011358608 0.005115432 [283] 0.007592325 0.005335481 0.006410926 0.007108739 0.002352479 0.003998081 [289] 0.002710161 0.006362237 0.007036115 0.007592325 0.003998081 0.002984428 [295] 0.005335481 0.002439326 0.005966785 0.012025706 0.008624204 0.002439326 [301] 0.033505449 0.023497806 0.006963553 0.010894224 0.008843781 0.006498998 [307] 0.002984428 0.002601141 0.003405728 0.002510862 0.005594526 0.010053817 [313] 0.006077876 0.004945241 0.008380851 0.006893482 0.005335481 0.002710161 [319] 0.003405728 0.006218027 0.033794505 0.011073682 0.005232760 0.005253987 [325] 0.003757866 0.016794103 0.010616876 0.006345057 0.006522512 0.014695434 [331] 0.005079416 0.010894224 0.006469953 0.007108739 0.002386532 0.002439326 [337] 0.009364483 0.013599923 0.005148940 0.004899238 0.005900089 0.012229617 [343] 0.003333663 0.013085174 0.003998081 0.010894224 0.005208306 0.002340601 [349] 0.004257037 0.006469953 0.007594859 0.002710161 0.003998081 0.005502815 [355] 0.004872402 0.007157827 0.016579641 0.005239689 0.004872402 0.007202156 [361] 0.006978130 0.002984428 0.003333663 0.003998081 0.006851464 0.007034064 [367] 0.003998081 0.002541748 0.013173866 0.002463348 0.006613420 0.006362237 [373] 0.005191235 0.004534736 0.002601141 0.004641118 0.007616884 0.007616884 [379] 0.002837924 0.002837924 0.002403690 0.002352479 0.006345057 0.002352479 [385] 0.032582313 0.010894224 0.003843658 0.015413122 0.005222587 0.013850834 [391] 0.002352479 0.015453503 0.005276052 0.005134791 0.010894224 0.010894224 [397] 0.011963928 0.010894224 0.010444850 0.008528887 0.008039888 0.009021505 [403] 0.012163845 0.006245578 0.005096049 0.002541748 0.010894224 0.005607255 [409] 0.007552456 0.007034064 0.003333663 0.009776645 0.011026399 0.021013236 [415] 0.002362774 0.006991980 0.007164476 0.006065037 0.004641118 0.008528887 [421] 0.008838557 0.002340601 0.005737937 0.006362237 0.007594859 0.012484856 [427] 0.002463348 0.006912318 0.007592325 0.002337169 0.011957304 0.005168804 [433] 0.033646698 0.026235307 0.011963928 0.010894224 0.006991980 0.005191235 [439] 0.002541748 0.002837924 0.007592325 0.009166204 0.007768811 0.019163075 [445] 0.033197605 0.005148940 0.005125845 0.002352479 0.003042767 0.002340601 [451] 0.002352479 0.004356556 0.005175567 0.004973780 0.010327659 0.002889399 [457] 0.004944421 0.007592325 0.002510862 0.007157827 0.002889399 0.004534736 [463] 0.007592325 0.006345354 0.009798160 0.027736707 0.024481800 0.011963928 [469] 0.002601141 0.005696542 0.002439326 0.010097540 0.005158606 0.002889399 [475] 0.009693527 0.002984428 0.008869857 0.002439326 0.005441478 0.003757866 [481] 0.003214876 0.005293246 0.006498998 0.005276052 0.005121957 0.002403690 [487] 0.008827158 0.002510862 0.028417425 0.010862136 0.010894224 0.002541748 [493] 0.006362237 0.018644724 0.005208306 0.002984428 0.031945235 0.024481800 [499] 0.010020765 0.008444309 0.003757866 0.006080983 0.002601141 0.002710161 [505] 0.002510862 0.005079416 0.010894224 0.006280619 0.005127648 0.007592325 [511] 0.005127648 0.002463348 0.005848877 0.002710161 0.003214876 0.002710161 [517] 0.003875631 0.005146359 0.008444309 0.002984428 0.005208306 0.005276748 [523] 0.006469953 0.014734225 0.003042767 0.005115432 0.006410926 0.007217699 [529] 0.005115432 0.009630894 0.005848877 0.005132249 0.006644234 0.007034064 [535] 0.027736707 0.021264885 0.010894224 0.033984602 0.020170908 0.011963928 [541] 0.010894224 0.007592325 0.008803201 0.005363932 0.012308595 0.003405728 [547] 0.011963928 0.005938866 0.004872828 0.007266584 0.009228074 0.010097540 [553] 0.006736118 0.002352479 0.002601141 0.015822134 0.031945235 0.005502815 [559] 0.009110406 0.002601141 0.003536394 0.002837924 0.002710161 0.002463348 [565] 0.003998081 0.002340601 0.008624204 0.023088199 0.028683036 0.028683036 [571] 0.025826021 0.028683036 0.028683036 0.028683036 0.011963928 0.009011481 [577] 0.002601141 0.017266066 0.003536394 0.002601141 0.006893482 0.015836517 [583] 0.002837924 0.002463348 0.023088199 0.023088199 0.045566605 0.023088199 [589] 0.039375881 0.011963928 0.009519634 0.010894224 0.006912318 0.003333663 [595] 0.002984428 0.013253497 0.002352479 0.002984428 0.008555300 0.003536394 [601] 0.006349098 0.018745469 0.036159802 0.036159802 0.020292844 0.010894224 [607] 0.006736118 0.003042767 0.002601141 0.010097540 0.012163845 0.012668599 [613] 0.012184767 0.003149675 0.003757866 0.002601141 0.003149675 0.003536394 [619] 0.008797985 0.003333663 0.003998081 0.002601141 0.007051171 0.012754646 [625] 0.005181020 0.011999189 0.003333663 0.005900089 0.012736086 0.006469953 [631] 0.007407921 0.003149675 0.002463348 0.012973707 0.009886162 0.003757866 [637] 0.013062285 0.012601100 0.012229617 0.003998081 0.002754773 0.004257037 [643] 0.004257037 0.012601100 0.003333663 0.003333663 0.002439326 0.002837924 [649] 0.007266584 0.012990238 0.002439326 0.002837924 0.003333663 0.008797985 [655] 0.002386532 0.006759487 0.008356226 0.003536394 0.010576520 0.002837924 [661] 0.002541748 0.002837924 0.002337169 0.002337169 0.005900089 0.012229617 [667] 0.007592325 0.003615322 0.002463348 0.002510862 0.003757866 0.002352479 [673] 0.011781432 0.024481800 0.010894224 0.007592325 0.003757866 0.005582043 [679] 0.005317100 0.004257037 0.003064709 0.010435712 0.012484856 0.003757866 [685] 0.005127648 0.008869857 0.011963928 0.005117464 0.011952523 0.002510862 [691] 0.002710161 0.008528887 0.003149675 0.009021505 0.009940717 0.012121784 [697] 0.007036115 0.008827158 0.004534736 0.033197605 0.037132184 0.011963928 [703] 0.010894224 0.002710161 0.003149675 0.002541748 0.006498998 0.004257037 [709] 0.003405728 0.003615322 0.002340601 0.010327659 0.005127648 0.012308595 [715] 0.005737937 0.002362774 0.007592325 0.009364483 0.007217699 0.007950371 [721] 0.003998081 0.004534736 0.004090736 0.011963928 0.005853406 0.006029012 [727] 0.004641118 0.026204360 0.003126479 0.003126479 0.003998081 0.002601141 [733] 0.015220999 0.015220999 0.009821294 0.011963928 0.017266066 0.002710161 [739] 0.003149675 0.007266584 0.015552639 0.005123271 0.003214876 0.004899238 [745] 0.002754773 0.038497738 0.038497738 0.038497738 0.044190141 0.044190141 [751] 0.038497738 0.011963928 0.017266066 0.005966785 0.002340601 0.003536394 [757] 0.008343378 0.008134451 0.003757866 0.012308595 0.013253497 0.006547723 [763] 0.007594859 0.003536394 0.002908833 0.008923527 0.006759487 0.003333663 [769] 0.008388177 0.002710161 0.006204359 0.009011481 0.013062285 0.005363932 [775] 0.012387354 0.005900089 0.002439326 0.012180975 0.028417425 0.005232760 [781] 0.003615322 0.002439326 0.005276748 0.003405728 0.002352479 0.014734225 [787] 0.014847985 0.008869857 0.009886162 0.003536394 0.004944421 0.008640158 [793] 0.002403690 0.009110406 0.003149675 0.002362774 0.002337169 0.002386532 [799] 0.021552086 0.032481486 0.005266467 0.002362774 0.003757866 0.010894224 [805] 0.002984428 0.008797985 0.002510862 0.015460369 0.015300409 0.008797985 [811] 0.004257037 0.003333663 0.002352479 0.009886162 0.002362774 0.003149675 [817] 0.021264885 0.010881080 0.003875631 0.002431176 0.003843658 0.016687392 [823] 0.008294185 0.023034733 0.018030683 0.005037673 0.013598416 0.005772631 [829] 0.017266066 0.009228074 0.012990238 0.005900089 0.009110406 0.002386532 [835] 0.002386532 0.003149675 0.009693527 0.002340601 0.002431176 0.002541748 [841] 0.002889399 0.002837924 0.012248577 0.014984041 0.006450345 0.014704151 [847] 0.013624959 0.002439326 0.006410926 0.014781734 0.003432686 0.009011481 [853] 0.005966785 0.005737937 0.008797985 0.009364483 0.003149675 0.002386532 [859] 0.012253491 0.002463348 0.002362774 0.007373145 0.012679208 0.007046220 [865] 0.015639072 0.007592325 0.009886162 0.002837924 0.003333663 0.002439326 [871] 0.002710161 0.016668242 0.005000615 0.002403690 0.005594526 0.003998081 [877] 0.003149675 0.007373145 0.033646698 0.011429649 0.005428273 0.002362774 [883] 0.014800364 0.009798160 0.012195925 0.002439326 0.006736118 0.005363932 [889] 0.003333663 0.003214876 0.009286256 0.003333663 0.002410586 0.005900089 [895] 0.007592325 0.002984428 0.005900089 0.011781432 0.002439326 0.005239689 [901] 0.012282051 0.002439326 0.008797985 0.003536394 0.012387354 0.012736086 [907] 0.003536394 0.004534736 0.005115432 0.012245706 0.011773651 0.018198928 [913] 0.017813362 0.017266066 0.023447722 0.022817686 0.023331002 0.022188904 [919] 0.022295835 0.017266066 0.003333663 0.003757866 0.002340601 0.007822697 [925] 0.013359360 0.017266066 0.003333663 0.002710161 0.003149675 0.012630619 [931] 0.002837924 0.012180975 0.003757866 0.006893482 0.013062285 0.008797985 [937] 0.004257037 0.002837924 0.002754773 0.003333663 0.022565922 0.023111619 [943] 0.022817686 0.023331002 0.022729079 0.017266066 0.012484856 0.002463348 [949] 0.009166204 0.017719872 0.013476545 0.005772631 0.017266066 0.005607255 [955] 0.004534736 0.002710161 0.002819743 0.119830700 0.002837924 0.006080983 [961] 0.002889399 0.032481486 0.010894224 0.021264885 0.009228074 0.003536394 [967] 0.002771700 0.008869857 0.003149675 0.003042767 0.003333663 0.006736118 [973] 0.013529385 0.013529385 0.019026655 0.019026655 0.011963928 0.017266066 [979] 0.003757866 0.002352479 0.002340601 0.002362774 0.005737937 0.003333663 [985] 0.007592325 0.003757866 0.012484856 0.008803201 0.002510862 0.013476545 [991] 0.011957161 0.011130469 0.010197281 0.002710161 0.007592325 0.010710424 [997] 0.002837924 0.009228074 0.002403690 0.033555247 0.005665956 0.002340601 [1003] 0.002342481 0.003843658 0.009228074 0.014714111 0.009074434 0.010894224 [1009] 0.002541748 0.006736118 0.010444850 0.006381420 0.011963928 0.017266066 [1015] 0.005119907 0.011966485 0.002362774 0.002439326 0.002439326 0.004641118 [1021] 0.017260659 0.015550914 0.010217375 0.014731610 0.009693527 0.003536394 [1027] 0.013939585 0.003149675 0.003149675 0.002349345 0.005554695 0.005966785 [1033] 0.008356226 0.007616884 0.008894797 0.002410586 0.003333663 0.002510862 [1039] 0.002541748 0.006644234 0.009470932 0.004221303 0.016675168 0.002553659 [1045] 0.002510862 0.002386532 $pmethod [1] "backward" $nprune NULL $penalty [1] 3 $nk [1] 21 $thresh [1] 0.001 $termcond [1] 7 $weights NULL $glm.list $glm.list[[1]] Call: glm(formula = yarg ~ ., family = family, data = bx.data.frame, weights = weights, na.action = na.action, offset = offset, control = control, model = TRUE, method = "glm.fit", x = TRUE, y = TRUE, contrasts = NULL, trace = (trace >= 2)) Coefficients: (Intercept) survived `h(sibsp-1)` -2.66307 2.84789 -0.52880 `h(2-parch)` `survived*h(16-age)` `survived*sexmale` 1.25519 -0.17825 -1.25498 sexmale `h(55-age)*h(2-parch)` `h(1-sibsp)*h(1-parch)` 1.42483 -0.04946 -1.02163 Degrees of Freedom: 1045 Total (i.e. Null); 1037 Residual Null Deviance: 1223 Residual Deviance: 894.8 AIC: 912.8 $glm.list[[2]] Call: glm(formula = yarg ~ ., family = family, data = bx.data.frame, weights = weights, na.action = na.action, offset = offset, control = control, model = TRUE, method = "glm.fit", x = TRUE, y = TRUE, contrasts = NULL, trace = (trace >= 2)) Coefficients: (Intercept) survived `h(sibsp-1)` -1.9313615 1.0641827 -0.6492895 `h(2-parch)` `survived*h(16-age)` `survived*sexmale` 0.0653459 0.0939009 -1.9509922 sexmale `h(55-age)*h(2-parch)` `h(1-sibsp)*h(1-parch)` 0.9659886 0.0004374 -0.2190244 Degrees of Freedom: 1045 Total (i.e. Null); 1037 Residual Null Deviance: 1175 Residual Deviance: 1127 AIC: 1145 $glm.list[[3]] Call: glm(formula = yarg ~ ., family = family, data = bx.data.frame, weights = weights, na.action = na.action, offset = offset, control = control, model = TRUE, method = "glm.fit", x = TRUE, y = TRUE, contrasts = NULL, trace = (trace >= 2)) Coefficients: (Intercept) survived `h(sibsp-1)` 1.37993 -2.84379 0.79975 `h(2-parch)` `survived*h(16-age)` `survived*sexmale` -1.29856 0.02012 2.28554 sexmale `h(55-age)*h(2-parch)` `h(1-sibsp)*h(1-parch)` -1.45240 0.04146 1.12491 Degrees of Freedom: 1045 Total (i.e. Null); 1037 Residual Null Deviance: 1448 Residual Deviance: 1119 AIC: 1137 $glm.coefficients 1st 2nd 3rd (Intercept) -2.66307135 -1.931361472 1.37992944 survived 2.84788552 1.064182711 -2.84378575 h(sibsp-1) -0.52879762 -0.649289486 0.79974678 h(2-parch) 1.25518755 0.065345867 -1.29855706 survived*h(16-age) -0.17824991 0.093900852 0.02011681 survived*sexmale -1.25498201 -1.950992216 2.28554497 sexmale 1.42483431 0.965988623 -1.45239590 h(55-age)*h(2-parch) -0.04946408 0.000437374 0.04146455 h(1-sibsp)*h(1-parch) -1.02162885 -0.219024356 1.12490799 $glm.stats nulldev df dev df devratio AIC iters converged 1st 1223.308 1045 894.8141 1037 0.2685294 912.8141 5 1 2nd 1175.305 1045 1126.9441 1037 0.0411477 1144.9441 5 1 3rd 1448.212 1045 1118.9411 1037 0.2273640 1136.9411 5 1 $call earth(formula = pclass ~ ., data = etitanic, trace = 0, glm = list(family = "binomial"), degree = 2) $namesx.org [1] "survived" "sex" "age" "sibsp" "parch" $namesx [1] "survived" "sex" "age" "sibsp" "parch" $terms pclass ~ survived + sex + age + sibsp + parch attr(,"variables") list(pclass, survived, sex, age, sibsp, parch) attr(,"factors") survived sex age sibsp parch pclass 0 0 0 0 0 survived 1 0 0 0 0 sex 0 1 0 0 0 age 0 0 1 0 0 sibsp 0 0 0 1 0 parch 0 0 0 0 1 attr(,"term.labels") [1] "survived" "sex" "age" "sibsp" "parch" attr(,"order") [1] 1 1 1 1 1 attr(,"intercept") [1] 1 attr(,"response") [1] 1 attr(,".Environment") attr(,"predvars") list(pclass, survived, sex, age, sibsp, parch) attr(,"dataClasses") pclass survived sex age sibsp parch "factor" "numeric" "factor" "numeric" "numeric" "numeric" $xlevels $xlevels$sex [1] "female" "male" $levels [1] "1st" "2nd" "3rd" attr(,"class") [1] "earth" ------------------------------------------------------------------------------- > # variance models are not supported for multiple response models > expect.err(try(earth(pclass ~ ., data=etitanic, ncross=3, nfold=3, varmod.method="lm")), "variance models are not supported for multiple response models") Error : variance models are not supported for multiple response models Got error as expected from try(earth(pclass ~ ., data = etitanic, ncross = 3, nfold = 3, varmod.method = "lm")) > > a5d <- earth(pclass ~ .-age, data=etitanic, degree=2, glm=list(family="binomial"), trace=0) > a5update <- update(a5, form=pclass ~ .-age) > check.models.equal(a5update, a5d, msg="a5update a5d", newdata=etitanic[5,]) a5update a5d: models not identical Formulas differ: pclass ~ survived + sex + sibsp + parch and: pclass ~ (survived + sex + age + sibsp + parch) - age a5update a5d: glm submodel formula strings are identical: yarg ~ survived + `h(sibsp-1)` + `survived*sexmale` + sexmale + `h(1-sibsp)*h(1-parch)` + `survived*h(1-parch)` a5update a5d: but the actual glm submodel formulas differ (classes are "formula" and "formula") a5update a5d: glm submodels not identical (but coefs, residuals, fitted.values are the same) a5update a5d: Models are equivalent, within numerical tolerances > > a5d <- earth(pclass ~ .-age, data=etitanic, degree=2, glm=list(family="binomial"), trace=0, keepxy=1) > a5update <- update(a5, form=pclass ~ .-age) > check.models.equal(a5update, a5d, msg="a5update a5d with keepxy", newdata=etitanic[5,]) a5update a5d with keepxy: models not identical Formulas differ: pclass ~ survived + sex + sibsp + parch and: pclass ~ (survived + sex + age + sibsp + parch) - age a5update a5d with keepxy: glm submodel formula strings are identical: yarg ~ survived + `h(sibsp-1)` + `survived*sexmale` + sexmale + `h(1-sibsp)*h(1-parch)` + `survived*h(1-parch)` a5update a5d with keepxy: but the actual glm submodel formulas differ (classes are "formula" and "formula") a5update a5d with keepxy: glm submodels not identical (but coefs, residuals, fitted.values are the same) a5update a5d with keepxy: Models are equivalent, within numerical tolerances > > # titanic data, one logical response > cat("a6: titanic data, one logical response\n\n") a6: titanic data, one logical response > pclass1 = (etitanic[,1] == "1st") > a6 <- earth(pclass1 ~ ., data=etitanic[,-1], degree=2, glm=list(family="binomial"), trace=1) x[1046,5] with colnames survived sexmale age sibsp parch y[1046,1] with colname pclass1, and values 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,... Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.253 RSq 0.309 Prune backward penalty 3 nprune null: selected 8 of 17 terms, and 4 of 5 preds After pruning pass GRSq 0.27 RSq 0.294 GLM pclass1 devratio 0.26 dof 1038/1045 iters 5 > show.earth.models(a6) Print a6 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1223.31 1045 902.306 1038 0.262 918.3 5 1 Earth selected 8 of 17 terms, and 4 of 5 predictors Termination condition: Reached nk 21 Importance: age, survived, parch, sibsp, sexmale-unused Number of terms at each degree of interaction: 1 3 4 Earth GCV 0.1446768 RSS 146.0263 GRSq 0.2699404 RSq 0.2941874 Summary a6 Call: earth(formula=pclass1~., data=etitanic[,-1], trace=1, glm=list(family="binomial"), degree=2) GLM coefficients pclass1 (Intercept) -2.25778086 survived 1.88576461 h(age-44) 0.20634617 h(2-parch) 1.24353020 survived * h(52-age) -0.01132281 h(48-age) * h(2-parch) -0.04760841 h(age-48) * h(2-parch) -0.11771604 h(1-sibsp) * h(1-parch) -0.87090239 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1223.31 1045 902.306 1038 0.262 918.3 5 1 Earth selected 8 of 17 terms, and 4 of 5 predictors Termination condition: Reached nk 21 Importance: age, survived, parch, sibsp, sexmale-unused Number of terms at each degree of interaction: 1 3 4 Earth GCV 0.1446768 RSS 146.0263 GRSq 0.2699404 RSq 0.2941874 Summary a6 digits=3, details=TRUE Call: earth(formula=pclass1~., data=etitanic[,-1], trace=1, glm=list(family="binomial"), degree=2) Earth coefficients pclass1 (Intercept) 0.1112 survived 0.3690 survived * h(52-age) -0.0053 h(2-parch) 0.1793 h(age-48) * h(2-parch) -0.0203 h(48-age) * h(2-parch) -0.0063 h(age-44) 0.0381 h(1-sibsp) * h(1-parch) -0.1313 GLM coefficients pclass1 (Intercept) -2.2578 survived 1.8858 survived * h(52-age) -0.0113 h(2-parch) 1.2435 h(age-48) * h(2-parch) -0.1177 h(48-age) * h(2-parch) -0.0476 h(age-44) 0.2063 h(1-sibsp) * h(1-parch) -0.8709 GLM deviance residuals: Min 1Q Median 3Q Max -2.304 -0.644 -0.407 0.382 2.691 GLM coefficients (family binomial, link logit) Estimate Std. Error z value Pr(>|z|) (Intercept) -2.25778 0.27314 -8.27 < 2e-16 survived 1.88576 0.28847 6.54 6.3e-11 survived * h(52-age) -0.01132 0.01132 -1.00 0.31722 h(2-parch) 1.24353 0.19891 6.25 4.1e-10 h(age-48) * h(2-parch) -0.11772 0.03372 -3.49 0.00048 h(48-age) * h(2-parch) -0.04761 0.00663 -7.18 6.9e-13 h(age-44) 0.20635 0.05265 3.92 8.9e-05 h(1-sibsp) * h(1-parch) -0.87090 0.21192 -4.11 4.0e-05 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1220 1045 902 1038 0.26 918 5 1 Earth selected 8 of 17 terms, and 4 of 5 predictors Termination condition: Reached nk 21 Importance: age, survived, parch, sibsp, sexmale-unused Number of terms at each degree of interaction: 1 3 4 Earth GCV 0.145 RSS 146 GRSq 0.27 RSq 0.294 evimp a6 nsubsets gcv rss age 7 100.0 100.0 survived 6 64.6 67.2 parch 4 45.6 48.7 sibsp 2 22.7 26.4 evimp a6 trim=FALSE nsubsets gcv rss age 7 100.0 100.0 survived 6 64.6 67.2 parch 4 45.6 48.7 sibsp 2 22.7 26.4 sexmale-unused 0 0.0 0.0 glm params: epsilon 1e-08 maxit 25 trace FALSE family binomial link logit plotmo a6 plotmo grid: survived sex age sibsp parch 0 male 28 0 0 ------------------------------------------------------------------------------- > printh(a6$levels) # expect levels to be NULL === a6$levels [1] FALSE TRUE > print.stripped.earth.model(a6, "a6") print.stripped.earth.model(a6) $rss [1] 146.0263 $rsq [1] 0.2941874 $gcv [1] 0.1446768 $grsq [1] 0.2699404 $dirs survived sexmale age sibsp parch (Intercept) 0 0 0 0 0 h(age-26) 0 0 1 0 0 h(26-age) 0 0 -1 0 0 survived 2 0 0 0 0 survived*h(age-52) 2 0 1 0 0 survived*h(52-age) 2 0 -1 0 0 h(parch-2) 0 0 0 0 1 h(2-parch) 0 0 0 0 -1 h(sibsp-1) 0 0 0 1 0 h(1-sibsp) 0 0 0 -1 0 h(age-48)*h(2-parch) 0 0 1 0 -1 h(48-age)*h(2-parch) 0 0 -1 0 -1 h(age-44) 0 0 1 0 0 h(1-sibsp)*h(parch-1) 0 0 0 -1 1 h(1-sibsp)*h(1-parch) 0 0 0 -1 -1 survived*h(age-16) 2 0 1 0 0 sexmale*h(age-26) 0 2 1 0 0 $cuts survived sexmale age sibsp parch (Intercept) 0 0 0 0 0 h(age-26) 0 0 26 0 0 h(26-age) 0 0 26 0 0 survived 0 0 0 0 0 survived*h(age-52) 0 0 52 0 0 survived*h(52-age) 0 0 52 0 0 h(parch-2) 0 0 0 0 2 h(2-parch) 0 0 0 0 2 h(sibsp-1) 0 0 0 1 0 h(1-sibsp) 0 0 0 1 0 h(age-48)*h(2-parch) 0 0 48 0 2 h(48-age)*h(2-parch) 0 0 48 0 2 h(age-44) 0 0 44 0 0 h(1-sibsp)*h(parch-1) 0 0 0 1 1 h(1-sibsp)*h(1-parch) 0 0 0 1 1 survived*h(age-16) 0 0 16 0 0 sexmale*h(age-26) 0 0 26 0 0 $selected.terms [1] 1 4 6 8 11 12 13 15 $prune.terms [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [1,] 1 0 0 0 0 0 0 0 0 0 0 0 0 [2,] 1 2 0 0 0 0 0 0 0 0 0 0 0 [3,] 1 4 12 0 0 0 0 0 0 0 0 0 0 [4,] 1 2 3 4 0 0 0 0 0 0 0 0 0 [5,] 1 2 3 4 5 0 0 0 0 0 0 0 0 [6,] 1 4 8 11 12 13 0 0 0 0 0 0 0 [7,] 1 4 8 11 12 13 15 0 0 0 0 0 0 [8,] 1 4 6 8 11 12 13 15 0 0 0 0 0 [9,] 1 4 6 8 11 12 13 15 16 0 0 0 0 [10,] 1 4 6 8 10 11 12 13 15 16 0 0 0 [11,] 1 4 6 8 10 11 12 13 14 15 16 0 0 [12,] 1 4 6 8 10 11 12 13 14 15 16 17 0 [13,] 1 4 6 8 9 10 11 12 13 14 15 16 17 [14,] 1 4 5 6 8 9 10 11 12 13 14 15 16 [15,] 1 3 4 5 6 8 9 10 11 12 13 14 15 [16,] 1 2 3 4 5 6 8 9 10 11 12 13 14 [17,] 1 2 3 4 5 6 7 8 9 10 11 12 13 [,14] [,15] [,16] [,17] [1,] 0 0 0 0 [2,] 0 0 0 0 [3,] 0 0 0 0 [4,] 0 0 0 0 [5,] 0 0 0 0 [6,] 0 0 0 0 [7,] 0 0 0 0 [8,] 0 0 0 0 [9,] 0 0 0 0 [10,] 0 0 0 0 [11,] 0 0 0 0 [12,] 0 0 0 0 [13,] 0 0 0 0 [14,] 17 0 0 0 [15,] 16 17 0 0 [16,] 15 16 17 0 [17,] 14 15 16 17 $coefficients pclass1 (Intercept) 0.111229445 survived 0.368959879 survived*h(52-age) -0.005272714 h(2-parch) 0.179260948 h(age-48)*h(2-parch) -0.020341897 h(48-age)*h(2-parch) -0.006316595 h(age-44) 0.038123994 h(1-sibsp)*h(1-parch) -0.131302863 $rss.per.response [1] 146.0263 $rsq.per.response [1] 0.2941874 $gcv.per.response [1] 0.1446768 $grsq.per.response [1] 0.2699404 $rss.per.subset [1] 206.8910 173.4973 167.2214 154.2267 154.1736 150.2618 147.5346 146.0263 [9] 145.3576 145.0403 144.4600 144.0982 143.8546 143.6294 143.3491 143.0633 [17] 142.9648 $gcv.per.subset [1] 0.1981713 0.1669830 0.1617175 0.1498702 0.1505432 0.1474349 0.1454625 [8] 0.1446768 0.1447177 0.1451088 0.1452376 0.1455866 0.1460573 0.1465497 [15] 0.1469887 0.1474246 0.1480569 $leverages [1] 0.003717914 0.017486700 0.009079130 0.009079130 0.009079130 0.011482760 [7] 0.027832614 0.004190842 0.012199910 0.049504115 0.013149033 0.008652007 [13] 0.004181112 0.003866615 0.113251604 0.003888758 0.011730700 0.003956867 [19] 0.003200293 0.005382715 0.008585463 0.003866615 0.007553097 0.003717914 [25] 0.002531799 0.006412039 0.008202794 0.004583473 0.003724408 0.006896782 [31] 0.006489270 0.003754492 0.015131693 0.005527777 0.008520378 0.003595773 [37] 0.005043645 0.011958601 0.008789215 0.018409717 0.018768659 0.006999647 [43] 0.006896782 0.007553097 0.010661926 0.005051158 0.022533846 0.002556130 [49] 0.002252269 0.004970653 0.010927470 0.009699422 0.010831477 0.010831477 [55] 0.010685351 0.007061468 0.087645749 0.011586773 0.011603271 0.006159702 [61] 0.006436433 0.004878488 0.003754492 0.008520378 0.006063996 0.006264334 [67] 0.004667899 0.009570331 0.006136868 0.004210022 0.128951415 0.013213240 [73] 0.059135967 0.010831477 0.036825827 0.008086729 0.007851540 0.010302463 [79] 0.003773975 0.004122663 0.006122444 0.008211789 0.006171899 0.009144293 [85] 0.015238332 0.015083175 0.016361837 0.013147818 0.003432751 0.013070304 [91] 0.013070304 0.012336549 0.004190842 0.003502475 0.005597734 0.012574499 [97] 0.003200293 0.004878488 0.002258351 0.008002121 0.008355407 0.008005961 [103] 0.009079130 0.133333091 0.084456314 0.003754492 0.011928492 0.010343462 [109] 0.008046665 0.026626644 0.009891924 0.007364734 0.006873258 0.009570331 [115] 0.004583473 0.003595773 0.007916162 0.002701951 0.012336549 0.049504115 [121] 0.010661926 0.005721125 0.004302087 0.022533846 0.003502475 0.007916162 [127] 0.007883058 0.006412039 0.006412039 0.013070304 0.012336549 0.010725509 [133] 0.006873258 0.004598000 0.003773975 0.004181112 0.015205067 0.014282627 [139] 0.005527777 0.008593024 0.004792842 0.008553321 0.011846133 0.009458375 [145] 0.006873258 0.004583473 0.007851540 0.006873258 0.005597734 0.009676251 [151] 0.010763630 0.007883058 0.009676251 0.002482445 0.011112903 0.008962673 [157] 0.009758932 0.010553651 0.006021966 0.010763630 0.003754492 0.004583473 [163] 0.005527777 0.011657378 0.004792842 0.012917519 0.002236066 0.004975902 [169] 0.002258351 0.015131693 0.005098567 0.002258351 0.007162004 0.007794488 [175] 0.008652007 0.004181112 0.007883058 0.008281367 0.004878488 0.006020877 [181] 0.026237917 0.010565243 0.006436433 0.007482373 0.006104241 0.008593024 [187] 0.009570331 0.004210022 0.006171899 0.006836667 0.065505659 0.008389965 [193] 0.023284747 0.006021966 0.003595773 0.040297360 0.002239357 0.007302295 [199] 0.002910589 0.006016246 0.007113590 0.008183993 0.009144293 0.003754492 [205] 0.010560426 0.009570331 0.019112243 0.003822172 0.003157715 0.008009337 [211] 0.002319124 0.008520378 0.004122663 0.007883058 0.003200293 0.004122663 [217] 0.012109284 0.012574499 0.002556130 0.010071907 0.008578128 0.008124234 [223] 0.096146027 0.017529616 0.004181112 0.006873258 0.003754492 0.004331532 [229] 0.006489270 0.004583473 0.013147818 0.008263779 0.012551332 0.003724408 [235] 0.009168832 0.009168832 0.006424276 0.008652007 0.006602817 0.006836667 [241] 0.013711508 0.007916162 0.006559465 0.013542930 0.003956867 0.018170860 [247] 0.012574499 0.010343462 0.012089471 0.023462230 0.036560237 0.024183499 [253] 0.016010144 0.011482760 0.008578128 0.010949459 0.006136868 0.013070304 [259] 0.008204042 0.008803154 0.006136868 0.003834143 0.004598000 0.016010144 [265] 0.009570331 0.004583473 0.026881456 0.020369214 0.014113579 0.013618732 [271] 0.004045543 0.011657378 0.009007450 0.018881134 0.007916162 0.008951382 [277] 0.009079130 0.011730700 0.004975902 0.009866521 0.003719417 0.003834143 [283] 0.018170860 0.004878488 0.006050101 0.006098142 0.002258351 0.004531091 [289] 0.002531799 0.006570397 0.007156279 0.010008792 0.004531091 0.002910589 [295] 0.004878488 0.002252269 0.008931303 0.006282630 0.008202794 0.002252269 [301] 0.012565128 0.010464429 0.006197823 0.010831477 0.004331532 0.005721125 [307] 0.002910589 0.002400135 0.005527777 0.002306958 0.004181112 0.009363802 [313] 0.025653727 0.006559465 0.007796653 0.006265696 0.004878488 0.002531799 [319] 0.005527777 0.007553097 0.017556581 0.003404662 0.003595773 0.004583473 [325] 0.004130016 0.010565243 0.011788689 0.008450506 0.007364734 0.006016246 [331] 0.003406920 0.015102299 0.006016246 0.006098142 0.002236066 0.002252269 [337] 0.004181112 0.012487300 0.003859688 0.003848575 0.004667899 0.002258351 [343] 0.003443328 0.008088352 0.004531091 0.017529616 0.003724408 0.002418383 [349] 0.004970653 0.006016246 0.006602817 0.002531799 0.004531091 0.004272432 [355] 0.004479085 0.008281367 0.012487300 0.004766567 0.004479085 0.006159702 [361] 0.006104241 0.002910589 0.003443328 0.004531091 0.008505457 0.006079655 [367] 0.004531091 0.003200293 0.003822172 0.002947085 0.007706488 0.006570397 [373] 0.004331532 0.005448703 0.002400135 0.009570331 0.007130942 0.007130942 [379] 0.002701951 0.002701951 0.002732364 0.002258351 0.008450506 0.002258351 [385] 0.012815373 0.008002121 0.006611502 0.009215697 0.003814416 0.023462230 [391] 0.002258351 0.013080972 0.004906741 0.007916162 0.008002121 0.008002121 [397] 0.012864724 0.017529616 0.011657378 0.006424276 0.006233274 0.007130942 [403] 0.004288925 0.003873409 0.003931398 0.003200293 0.039535981 0.009676251 [409] 0.010565243 0.006079655 0.003443328 0.007553097 0.024183499 0.017674534 [415] 0.002556130 0.006638639 0.009458375 0.003439524 0.009570331 0.006424276 [421] 0.006856899 0.002418383 0.004402969 0.006570397 0.006602817 0.003157715 [427] 0.002947085 0.008520378 0.010008792 0.002319124 0.003832343 0.003834976 [433] 0.017417159 0.015824305 0.009079130 0.008046665 0.006638639 0.004331532 [439] 0.003200293 0.002701951 0.016010144 0.013147818 0.009758932 0.010008792 [445] 0.017417159 0.003859688 0.003439524 0.002258351 0.004598000 0.002418383 [451] 0.002258351 0.007883058 0.005801057 0.007012409 0.005721125 0.004190842 [457] 0.011958601 0.044966037 0.002306958 0.008281367 0.004190842 0.005448703 [463] 0.018170860 0.006303122 0.010879586 0.011834548 0.011134315 0.009079130 [469] 0.002400135 0.004198176 0.002252269 0.005326977 0.003717914 0.004190842 [475] 0.004667899 0.002910589 0.003717914 0.002252269 0.011730700 0.004130016 [481] 0.005043645 0.003719417 0.005721125 0.004906741 0.003956867 0.002732364 [487] 0.003754492 0.002306958 0.011834548 0.008088352 0.009626467 0.003200293 [493] 0.006570397 0.006104241 0.003724408 0.002910589 0.012689867 0.011134315 [499] 0.008002121 0.010370197 0.004130016 0.004975902 0.002400135 0.002531799 [505] 0.002306958 0.003406920 0.008578128 0.005326977 0.003754492 0.012481166 [511] 0.003754492 0.002947085 0.006489270 0.002531799 0.005043645 0.002531799 [517] 0.004325743 0.006520264 0.010370197 0.002910589 0.003724408 0.003773975 [523] 0.006016246 0.006063996 0.004598000 0.003834143 0.006050101 0.006621344 [529] 0.003834143 0.009686194 0.006489270 0.004034381 0.006063996 0.006079655 [535] 0.011834548 0.010464429 0.008535890 0.017486700 0.014378909 0.009079130 [541] 0.009626467 0.029455238 0.003834143 0.003866615 0.002701951 0.005527777 [547] 0.009079130 0.004499289 0.004749948 0.007162004 0.004002327 0.005326977 [553] 0.006158345 0.002258351 0.002400135 0.008505457 0.012689867 0.004272432 [559] 0.003866615 0.002400135 0.003767429 0.002701951 0.002531799 0.002947085 [565] 0.004531091 0.002418383 0.008202794 0.009079130 0.009079130 0.009079130 [571] 0.008803154 0.009079130 0.009079130 0.009079130 0.009079130 0.003773975 [577] 0.002400135 0.009079130 0.003767429 0.002400135 0.006265696 0.008183993 [583] 0.002701951 0.002947085 0.009079130 0.009079130 0.015824305 0.009079130 [589] 0.014378909 0.009079130 0.004402969 0.011819139 0.008520378 0.003443328 [595] 0.002910589 0.004970653 0.002258351 0.002910589 0.008990537 0.003767429 [601] 0.006233274 0.006436433 0.012752515 0.012752515 0.009824890 0.008002121 [607] 0.006158345 0.004598000 0.002400135 0.005326977 0.004288925 0.004641655 [613] 0.002306958 0.003157715 0.004130016 0.002400135 0.003157715 0.003767429 [619] 0.003956867 0.003443328 0.004531091 0.002400135 0.006128417 0.005538649 [625] 0.004515084 0.003894023 0.003443328 0.004667899 0.003767429 0.006016246 [631] 0.006856899 0.003157715 0.002947085 0.004325743 0.004975902 0.004130016 [637] 0.004531091 0.003443328 0.002258351 0.004531091 0.003822172 0.004970653 [643] 0.004970653 0.003443328 0.003443328 0.003443328 0.002252269 0.002701951 [649] 0.007162004 0.003491989 0.002252269 0.002701951 0.003443328 0.003956867 [655] 0.002236066 0.006145602 0.008183993 0.003767429 0.006158345 0.002701951 [661] 0.003200293 0.002701951 0.002319124 0.002319124 0.004667899 0.002258351 [667] 0.047202057 0.006050396 0.002947085 0.002306958 0.004130016 0.002258351 [673] 0.007570199 0.011134315 0.010831477 0.012481166 0.004130016 0.004517463 [679] 0.005056538 0.004970653 0.003029341 0.008520378 0.003157715 0.004130016 [685] 0.003754492 0.003717914 0.009079130 0.003991557 0.003814416 0.002306958 [691] 0.002531799 0.006424276 0.003157715 0.007130942 0.008611984 0.007313942 [697] 0.007156279 0.003754492 0.005448703 0.017417159 0.018124340 0.009079130 [703] 0.009626467 0.002531799 0.003157715 0.003200293 0.005721125 0.004970653 [709] 0.005527777 0.006050396 0.002418383 0.005721125 0.003754492 0.002701951 [715] 0.004402969 0.002556130 0.026237917 0.004181112 0.006621344 0.007113590 [721] 0.004531091 0.005448703 0.006896782 0.009079130 0.004389296 0.004618904 [727] 0.009570331 0.015761821 0.004816011 0.004816011 0.004531091 0.002400135 [733] 0.009079130 0.009079130 0.009079130 0.009079130 0.010652784 0.002531799 [739] 0.003157715 0.007162004 0.011930492 0.003937979 0.005043645 0.003848575 [745] 0.003822172 0.009079130 0.009079130 0.009079130 0.009079130 0.009079130 [751] 0.009079130 0.009079130 0.009079130 0.008931303 0.002418383 0.003767429 [757] 0.007364734 0.006020877 0.004130016 0.002701951 0.004970653 0.006020877 [763] 0.006602817 0.003767429 0.002801459 0.008962673 0.006145602 0.003443328 [769] 0.010553651 0.002531799 0.008416259 0.003773975 0.004531091 0.003866615 [775] 0.002910589 0.004667899 0.002252269 0.002252269 0.011834548 0.003595773 [781] 0.006050396 0.002252269 0.003773975 0.005527777 0.002258351 0.006063996 [787] 0.006265696 0.003717914 0.004975902 0.003767429 0.011958601 0.008611984 [793] 0.002732364 0.003866615 0.003157715 0.002556130 0.002319124 0.002236066 [799] 0.010464429 0.012565128 0.010685351 0.002556130 0.004130016 0.008211789 [805] 0.002910589 0.003956867 0.002306958 0.007443472 0.007130942 0.003956867 [811] 0.004970653 0.003443328 0.002258351 0.004975902 0.002556130 0.003157715 [817] 0.010464429 0.006136868 0.004325743 0.002834913 0.006611502 0.006856899 [823] 0.006145602 0.015083175 0.003579970 0.003404662 0.007303799 0.004288925 [829] 0.009079130 0.004002327 0.003491989 0.004667899 0.003866615 0.002236066 [835] 0.002236066 0.003157715 0.004667899 0.002418383 0.002834913 0.003200293 [841] 0.004190842 0.002701951 0.002531799 0.006896782 0.007061468 0.006050101 [847] 0.007796653 0.002252269 0.006050101 0.006145602 0.003600568 0.003773975 [853] 0.008931303 0.004402969 0.003956867 0.004181112 0.003157715 0.002236066 [859] 0.002283927 0.002947085 0.002556130 0.007728443 0.002947085 0.006424276 [865] 0.007794488 0.008847909 0.004975902 0.002701951 0.003443328 0.002252269 [871] 0.002531799 0.009215697 0.003432751 0.002732364 0.004181112 0.004531091 [877] 0.003157715 0.007728443 0.017417159 0.003873409 0.004057747 0.002556130 [883] 0.012251812 0.010879586 0.002236066 0.002252269 0.006158345 0.003866615 [889] 0.003443328 0.005043645 0.006021966 0.003443328 0.002239357 0.004667899 [895] 0.016010144 0.002910589 0.004667899 0.007570199 0.002252269 0.004766567 [901] 0.002319124 0.002252269 0.003956867 0.003767429 0.002910589 0.003767429 [907] 0.003767429 0.005448703 0.003834143 0.007049479 0.006128417 0.006804780 [913] 0.005725617 0.009079130 0.007303799 0.005922206 0.007049479 0.004499289 [919] 0.004748140 0.009079130 0.003443328 0.004130016 0.002418383 0.007368882 [925] 0.006804780 0.009079130 0.003443328 0.002531799 0.003157715 0.006412039 [931] 0.002701951 0.002252269 0.004130016 0.006265696 0.004531091 0.003956867 [937] 0.004970653 0.002701951 0.003822172 0.003443328 0.005361304 0.006569704 [943] 0.005922206 0.007049479 0.005725617 0.009079130 0.003157715 0.002947085 [949] 0.013147818 0.013149033 0.007049479 0.004288925 0.009079130 0.009676251 [955] 0.005448703 0.002531799 0.004001696 0.009079130 0.002701951 0.004975902 [961] 0.004190842 0.012565128 0.008002121 0.010464429 0.004002327 0.003767429 [967] 0.002612064 0.003717914 0.003157715 0.004598000 0.003443328 0.006158345 [973] 0.009079130 0.009079130 0.009079130 0.009079130 0.009079130 0.008381427 [979] 0.004130016 0.002258351 0.002418383 0.002556130 0.004402969 0.003443328 [985] 0.015028843 0.004130016 0.003157715 0.003834143 0.002306958 0.007049479 [991] 0.003819885 0.007162004 0.008789215 0.002531799 0.064703256 0.008337954 [997] 0.002701951 0.004002327 0.002732364 0.013005288 0.004792842 0.002418383 [1003] 0.002283927 0.006611502 0.004002327 0.008636851 0.007570199 0.008535890 [1009] 0.003200293 0.006158345 0.026205242 0.005113327 0.009079130 0.009079130 [1015] 0.004127579 0.003834976 0.002556130 0.002252269 0.002252269 0.009570331 [1021] 0.008183993 0.006122444 0.009078463 0.006122444 0.004667899 0.003767429 [1027] 0.006520264 0.003157715 0.003157715 0.002482445 0.005597734 0.008931303 [1033] 0.008183993 0.007130942 0.011603271 0.002239357 0.003443328 0.002306958 [1039] 0.003200293 0.006063996 0.010258083 0.007302295 0.009850345 0.002348736 [1045] 0.002306958 0.002236066 $pmethod [1] "backward" $nprune NULL $penalty [1] 3 $nk [1] 21 $thresh [1] 0.001 $termcond [1] 7 $weights NULL $glm.list $glm.list[[1]] Call: glm(formula = yarg ~ ., family = family, data = bx.data.frame, weights = weights, na.action = na.action, offset = offset, control = control, model = TRUE, method = "glm.fit", x = TRUE, y = TRUE, contrasts = NULL, trace = (trace >= 2)) Coefficients: (Intercept) survived `survived*h(52-age)` -2.25778 1.88576 -0.01132 `h(2-parch)` `h(age-48)*h(2-parch)` `h(48-age)*h(2-parch)` 1.24353 -0.11772 -0.04761 `h(age-44)` `h(1-sibsp)*h(1-parch)` 0.20635 -0.87090 Degrees of Freedom: 1045 Total (i.e. Null); 1038 Residual Null Deviance: 1223 Residual Deviance: 902.3 AIC: 918.3 $glm.coefficients pclass1 (Intercept) -2.25778086 survived 1.88576461 survived*h(52-age) -0.01132281 h(2-parch) 1.24353020 h(age-48)*h(2-parch) -0.11771604 h(48-age)*h(2-parch) -0.04760841 h(age-44) 0.20634617 h(1-sibsp)*h(1-parch) -0.87090239 $glm.stats nulldev df dev df devratio AIC iters converged 1223.308 1045 902.3064 1038 0.2624048 918.3064 5 1 $call earth(formula = pclass1 ~ ., data = etitanic[, -1], trace = 1, glm = list(family = "binomial"), degree = 2) $namesx.org [1] "survived" "sex" "age" "sibsp" "parch" $namesx [1] "survived" "sex" "age" "sibsp" "parch" $terms pclass1 ~ survived + sex + age + sibsp + parch attr(,"variables") list(pclass1, survived, sex, age, sibsp, parch) attr(,"factors") survived sex age sibsp parch pclass1 0 0 0 0 0 survived 1 0 0 0 0 sex 0 1 0 0 0 age 0 0 1 0 0 sibsp 0 0 0 1 0 parch 0 0 0 0 1 attr(,"term.labels") [1] "survived" "sex" "age" "sibsp" "parch" attr(,"order") [1] 1 1 1 1 1 attr(,"intercept") [1] 1 attr(,"response") [1] 1 attr(,".Environment") attr(,"predvars") list(pclass1, survived, sex, age, sibsp, parch) attr(,"dataClasses") pclass1 survived sex age sibsp parch "logical" "numeric" "factor" "numeric" "numeric" "numeric" $xlevels $xlevels$sex [1] "female" "male" $levels [1] FALSE TRUE attr(,"class") [1] "earth" ------------------------------------------------------------------------------- > > # titanic data, one response which is a two level factor > cat("a7: titanic data, one response which is a two level factor\n\n") a7: titanic data, one response which is a two level factor > a7 <- earth(sex ~ ., data=etitanic, degree=2, glm=list(family="binomial"), trace=1) x[1046,6] with colnames pclass2nd pclass3rd survived age sibsp parch y[1046,1] with colname male, and values 0, 1, 0, 1, 0, 1, 0, 1, 0, 1,... Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.340 RSq 0.384 Prune backward penalty 3 nprune null: selected 10 of 15 terms, and 6 of 6 preds After pruning pass GRSq 0.352 RSq 0.38 GLM male devratio 0.32 dof 1036/1045 iters 5 > show.earth.models(a7, nresponse=1) Print a7 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1379.57 1045 941.167 1036 0.318 961.2 5 1 Earth selected 10 of 15 terms, and 6 of 6 predictors Termination condition: Reached nk 21 Importance: survived, parch, age, pclass3rd, sibsp, pclass2nd Number of terms at each degree of interaction: 1 1 8 Earth GCV 0.1513968 RSS 151.3254 GRSq 0.3524225 RSq 0.3800084 Summary a7 Call: earth(formula=sex~., data=etitanic, trace=1, glm=list(family="binomial"), degree=2) GLM coefficients male (Intercept) 1.6414456 pclass3rd -2.9192836 pclass2nd * survived -0.9900858 pclass3rd * survived 1.2824017 pclass3rd * h(4-parch) 0.5357947 survived * h(age-15) 0.9421209 survived * h(age-11.5) -0.9446345 h(25-age) * h(4-parch) -0.0267240 h(2-sibsp) * h(4-parch) 0.1645457 h(sibsp-2) * h(4-parch) 0.3810006 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1379.57 1045 941.167 1036 0.318 961.2 5 1 Earth selected 10 of 15 terms, and 6 of 6 predictors Termination condition: Reached nk 21 Importance: survived, parch, age, pclass3rd, sibsp, pclass2nd Number of terms at each degree of interaction: 1 1 8 Earth GCV 0.1513968 RSS 151.3254 GRSq 0.3524225 RSq 0.3800084 Summary a7 decomp="none", digits=5, fixed.point=FALSE, details=TRUE Call: earth(formula=sex~., data=etitanic, trace=1, glm=list(family="binomial"), degree=2) Earth coefficients male (Intercept) 0.7868343 survived * h(age-15) 0.1722326 pclass3rd * survived 0.2100380 h(25-age) * h(4-parch) -0.0045394 h(sibsp-2) * h(4-parch) 0.0651053 h(2-sibsp) * h(4-parch) 0.0243171 pclass3rd -0.5470414 pclass3rd * h(4-parch) 0.1182762 pclass2nd * survived -0.1638962 survived * h(age-11.5) -0.1724967 GLM coefficients male (Intercept) 1.641446 survived * h(age-15) 0.942121 pclass3rd * survived 1.282402 h(25-age) * h(4-parch) -0.026724 h(sibsp-2) * h(4-parch) 0.381001 h(2-sibsp) * h(4-parch) 0.164546 pclass3rd -2.919284 pclass3rd * h(4-parch) 0.535795 pclass2nd * survived -0.990086 survived * h(age-11.5) -0.944635 GLM deviance residuals: Min 1Q Median 3Q Max -2.45293 -0.71226 0.37332 0.56500 2.14246 GLM coefficients (family binomial, link logit) Estimate Std. Error z value Pr(>|z|) (Intercept) 1.6414456 0.3063579 5.3579 8.418e-08 survived * h(age-15) 0.9421209 0.0996551 9.4538 < 2.2e-16 pclass3rd * survived 1.2824017 0.3265418 3.9272 8.593e-05 h(25-age) * h(4-parch) -0.0267240 0.0054184 -4.9321 8.136e-07 h(sibsp-2) * h(4-parch) 0.3810006 0.0944226 4.0351 5.459e-05 h(2-sibsp) * h(4-parch) 0.1645457 0.0382249 4.3047 1.672e-05 pclass3rd -2.9192836 0.6046060 -4.8284 1.376e-06 pclass3rd * h(4-parch) 0.5357947 0.1546537 3.4645 0.0005313 pclass2nd * survived -0.9900858 0.2985006 -3.3169 0.0009103 survived * h(age-11.5) -0.9446345 0.0928577 -10.1729 < 2.2e-16 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1380 1045 941.2 1036 0.32 961 5 1 Earth selected 10 of 15 terms, and 6 of 6 predictors Termination condition: Reached nk 21 Importance: survived, parch, age, pclass3rd, sibsp, pclass2nd Number of terms at each degree of interaction: 1 1 8 Earth GCV 0.1514 RSS 151.33 GRSq 0.35242 RSq 0.38001 evimp a7 nsubsets gcv rss survived 9 100.0 100.0 parch 8 43.4 48.8 age 6 36.5 41.2 pclass3rd 5 36.6 40.2 sibsp 3 24.4 27.9 pclass2nd 1 12.1 14.5 evimp a7 trim=FALSE nsubsets gcv rss survived 9 100.0 100.0 parch 8 43.4 48.8 age 6 36.5 41.2 pclass3rd 5 36.6 40.2 sibsp 3 24.4 27.9 pclass2nd 1 12.1 14.5 glm params: epsilon 1e-08 maxit 25 trace FALSE family binomial link logit plotmo a7 plotmo grid: pclass survived age sibsp parch 3rd 0 28 0 0 ------------------------------------------------------------------------------- > printh(a7$levels) === a7$levels [1] "female" "male" > print.stripped.earth.model(a7, "a7") print.stripped.earth.model(a7) $rss [1] 151.3254 $rsq [1] 0.3800084 $gcv [1] 0.1513968 $grsq [1] 0.3524225 $dirs pclass2nd pclass3rd survived age sibsp parch (Intercept) 0 0 0 0 0 0 survived 0 0 2 0 0 0 h(parch-4) 0 0 0 0 0 1 h(4-parch) 0 0 0 0 0 -1 survived*h(age-15) 0 0 2 1 0 0 survived*h(15-age) 0 0 2 -1 0 0 pclass3rd*survived 0 2 2 0 0 0 h(age-25)*h(4-parch) 0 0 0 1 0 -1 h(25-age)*h(4-parch) 0 0 0 -1 0 -1 h(sibsp-2)*h(4-parch) 0 0 0 0 1 -1 h(2-sibsp)*h(4-parch) 0 0 0 0 -1 -1 pclass3rd 0 2 0 0 0 0 pclass3rd*h(4-parch) 0 2 0 0 0 -1 pclass2nd*survived 2 0 2 0 0 0 survived*h(age-11.5) 0 0 2 1 0 0 $cuts pclass2nd pclass3rd survived age sibsp parch (Intercept) 0 0 0 0.0 0 0 survived 0 0 0 0.0 0 0 h(parch-4) 0 0 0 0.0 0 4 h(4-parch) 0 0 0 0.0 0 4 survived*h(age-15) 0 0 0 15.0 0 0 survived*h(15-age) 0 0 0 15.0 0 0 pclass3rd*survived 0 0 0 0.0 0 0 h(age-25)*h(4-parch) 0 0 0 25.0 0 4 h(25-age)*h(4-parch) 0 0 0 25.0 0 4 h(sibsp-2)*h(4-parch) 0 0 0 0.0 2 4 h(2-sibsp)*h(4-parch) 0 0 0 0.0 2 4 pclass3rd 0 0 0 0.0 0 0 pclass3rd*h(4-parch) 0 0 0 0.0 0 4 pclass2nd*survived 0 0 0 0.0 0 0 survived*h(age-11.5) 0 0 0 11.5 0 0 $selected.terms [1] 1 5 7 9 10 11 12 13 14 15 $prune.terms [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [1,] 1 0 0 0 0 0 0 0 0 0 0 0 0 [2,] 1 2 0 0 0 0 0 0 0 0 0 0 0 [3,] 1 2 3 0 0 0 0 0 0 0 0 0 0 [4,] 1 2 3 4 0 0 0 0 0 0 0 0 0 [5,] 1 2 3 4 5 0 0 0 0 0 0 0 0 [6,] 1 5 9 12 13 15 0 0 0 0 0 0 0 [7,] 1 5 7 9 12 13 15 0 0 0 0 0 0 [8,] 1 5 7 9 10 12 13 15 0 0 0 0 0 [9,] 1 5 7 9 10 11 12 13 15 0 0 0 0 [10,] 1 5 7 9 10 11 12 13 14 15 0 0 0 [11,] 1 3 5 7 9 10 11 12 13 14 15 0 0 [12,] 1 2 3 5 7 9 10 11 12 13 14 15 0 [13,] 1 2 3 5 6 7 9 10 11 12 13 14 15 [14,] 1 2 3 4 5 6 7 9 10 11 12 13 14 [15,] 1 2 3 4 5 6 7 8 9 10 11 12 13 [,14] [,15] [1,] 0 0 [2,] 0 0 [3,] 0 0 [4,] 0 0 [5,] 0 0 [6,] 0 0 [7,] 0 0 [8,] 0 0 [9,] 0 0 [10,] 0 0 [11,] 0 0 [12,] 0 0 [13,] 0 0 [14,] 15 0 [15,] 14 15 $coefficients male (Intercept) 0.786834343 survived*h(age-15) 0.172232564 pclass3rd*survived 0.210037978 h(25-age)*h(4-parch) -0.004539399 h(sibsp-2)*h(4-parch) 0.065105306 h(2-sibsp)*h(4-parch) 0.024317117 pclass3rd -0.547041393 pclass3rd*h(4-parch) 0.118276153 pclass2nd*survived -0.163896221 survived*h(age-11.5) -0.172496699 $rss.per.response [1] 151.3254 $rsq.per.response [1] 0.3800084 $gcv.per.response [1] 0.1513968 $grsq.per.response [1] 0.3524225 $rss.per.subset [1] 244.0765 173.4300 172.3216 167.0752 166.3467 162.1420 158.5482 156.2928 [9] 153.2833 151.3254 150.8940 150.5522 150.4688 150.3932 150.3774 $gcv.per.subset [1] 0.2337895 0.1669182 0.1666498 0.1623556 0.1624296 0.1590915 0.1563215 [8] 0.1548485 0.1526086 0.1513968 0.1517062 0.1521072 0.1527728 0.1534511 [15] 0.1541954 $leverages [1] 0.006833739 0.012041802 0.011374780 0.007810055 0.007810055 0.009159163 [7] 0.019828087 0.004608382 0.016778909 0.004608382 0.005031322 0.015743860 [13] 0.008925468 0.007810807 0.046315070 0.003732806 0.008895001 0.006223281 [19] 0.004608382 0.006489974 0.008623226 0.007810807 0.006836171 0.006833739 [25] 0.004608382 0.008233466 0.014142568 0.005979435 0.007118693 0.004608382 [31] 0.006387716 0.006589518 0.016289582 0.004608382 0.007814361 0.009427613 [37] 0.004608382 0.004608382 0.007447563 0.021294672 0.018204481 0.006591576 [43] 0.004608382 0.006836171 0.012215191 0.004904418 0.014759976 0.004608382 [49] 0.004608382 0.007396820 0.007569355 0.012301154 0.007888534 0.007888534 [55] 0.004608382 0.005031322 0.037298175 0.005031322 0.007776859 0.007377265 [61] 0.005786292 0.005979622 0.006589518 0.007814361 0.005031322 0.007784999 [67] 0.010868851 0.004608382 0.006590748 0.006206750 0.020927533 0.018121225 [73] 0.006206750 0.005540722 0.021598336 0.005031322 0.005580681 0.010870576 [79] 0.007444383 0.006101265 0.005031322 0.009910970 0.006153678 0.017521279 [85] 0.011858436 0.008555015 0.012540209 0.005031322 0.008430179 0.008224551 [91] 0.008224551 0.008712978 0.004608382 0.008628148 0.006102200 0.011766133 [97] 0.004608382 0.005979622 0.004608382 0.016832516 0.015225008 0.017200442 [103] 0.012976847 0.012300297 0.022189870 0.006589518 0.015070945 0.006393434 [109] 0.009937182 0.017486270 0.009060591 0.005031322 0.005581844 0.004608382 [115] 0.005979435 0.009427613 0.006553265 0.004421263 0.008712978 0.004608382 [121] 0.012215191 0.015104874 0.003964098 0.014759976 0.008628148 0.006553265 [127] 0.004608382 0.008233466 0.008233466 0.008224551 0.008712978 0.005031322 [133] 0.005581844 0.004608382 0.007444383 0.008925468 0.006206750 0.011217398 [139] 0.004608382 0.004608382 0.016609618 0.006207121 0.009812036 0.005031322 [145] 0.005581844 0.005979435 0.005580681 0.005581844 0.006102200 0.004608382 [151] 0.009688899 0.004608382 0.004608382 0.004608382 0.004608382 0.005031322 [157] 0.006149414 0.007003677 0.006224591 0.009688899 0.006589518 0.005979435 [163] 0.004608382 0.013722744 0.016609618 0.009485552 0.004608382 0.012104732 [169] 0.004608382 0.016289582 0.018204154 0.004608382 0.020926033 0.004978690 [175] 0.015743860 0.008925468 0.004608382 0.004608382 0.005979622 0.005031322 [181] 0.004608382 0.012300297 0.005786292 0.005540334 0.006398473 0.004608382 [187] 0.004608382 0.003964098 0.006153678 0.009498662 0.005031322 0.012272410 [193] 0.004608382 0.006224591 0.009427613 0.003964098 0.004608382 0.004608382 [199] 0.004387194 0.005031322 0.010395449 0.005505592 0.017521279 0.006589518 [205] 0.011522516 0.004608382 0.013049325 0.004608382 0.004506174 0.005901713 [211] 0.004608382 0.007814361 0.006101265 0.004608382 0.004608382 0.006101265 [217] 0.005031322 0.011766133 0.004608382 0.012354337 0.019626885 0.017263642 [223] 0.009841237 0.012016303 0.008925468 0.005581844 0.006589518 0.006019983 [229] 0.006387716 0.005979435 0.005031322 0.005661762 0.014537622 0.007118693 [235] 0.004608382 0.004608382 0.004639926 0.015743860 0.008778001 0.009498662 [241] 0.007492439 0.007870699 0.006702237 0.005031322 0.006223281 0.004608382 [247] 0.011766133 0.006393434 0.010422667 0.020282317 0.005031322 0.005031322 [253] 0.004608382 0.009159163 0.013191155 0.006206750 0.006590748 0.008224551 [259] 0.006206750 0.014180068 0.006590748 0.006386033 0.004608382 0.004608382 [265] 0.004608382 0.005979435 0.005031322 0.016774158 0.004608382 0.003964098 [271] 0.003555474 0.013722744 0.006153678 0.006206750 0.007870699 0.006206750 [277] 0.005031322 0.010057526 0.012104732 0.003964098 0.010340660 0.006386033 [283] 0.004608382 0.005979622 0.005031322 0.010550133 0.004608382 0.006512591 [289] 0.004608382 0.005031322 0.010415841 0.004608382 0.006512591 0.004387194 [295] 0.011541110 0.004608382 0.004608382 0.010157111 0.012744442 0.004608382 [301] 0.026097909 0.023087686 0.017312016 0.012420470 0.011247657 0.014393116 [307] 0.004387194 0.004608382 0.004608382 0.004608382 0.011911437 0.014875285 [313] 0.006206750 0.012073391 0.012058822 0.005031322 0.011541110 0.004608382 [319] 0.004608382 0.013399098 0.015728056 0.011882701 0.012191312 0.011374016 [325] 0.005781412 0.005031322 0.005031322 0.004608382 0.005031322 0.005031322 [331] 0.012174589 0.013380957 0.005031322 0.010550133 0.004608382 0.004608382 [337] 0.011911437 0.013812476 0.006206750 0.011034277 0.012375729 0.004608382 [343] 0.004778204 0.016653951 0.006512591 0.015102551 0.011344928 0.004608382 [349] 0.007396820 0.005031322 0.011077602 0.004608382 0.006512591 0.012968921 [355] 0.009870578 0.004608382 0.013812476 0.006206750 0.011014037 0.010750225 [361] 0.010272153 0.004387194 0.004778204 0.006512591 0.005031322 0.010390776 [367] 0.006512591 0.004608382 0.004608382 0.004608382 0.005031322 0.005031322 [373] 0.011247657 0.008434098 0.004608382 0.004608382 0.004384035 0.004384035 [379] 0.004421263 0.004421263 0.004608382 0.004608382 0.004608382 0.004608382 [385] 0.023697435 0.011317124 0.004608382 0.018571098 0.003964098 0.030183378 [391] 0.004608382 0.013961789 0.006206750 0.014076387 0.013518539 0.013518539 [397] 0.007810055 0.016859324 0.022455457 0.011704623 0.012300297 0.010835902 [403] 0.005591267 0.017623940 0.011464180 0.004608382 0.022736656 0.004608382 [409] 0.005031322 0.010390776 0.004778204 0.013399098 0.005031322 0.005031322 [415] 0.004608382 0.016618672 0.005031322 0.017255849 0.004608382 0.011704623 [421] 0.010972426 0.004608382 0.012055520 0.005031322 0.011077602 0.004506174 [427] 0.004608382 0.014878008 0.004608382 0.004608382 0.006206750 0.006206750 [433] 0.016871062 0.016253689 0.007810055 0.013757236 0.016618672 0.011247657 [439] 0.004608382 0.004421263 0.004608382 0.005031322 0.012025974 0.004608382 [445] 0.015661175 0.006206750 0.012066582 0.004608382 0.004608382 0.004608382 [451] 0.004608382 0.004608382 0.011360649 0.011465935 0.014393116 0.004608382 [457] 0.004608382 0.004608382 0.004608382 0.004608382 0.004608382 0.008434098 [463] 0.004608382 0.005031322 0.014031952 0.022072474 0.020954161 0.005031322 [469] 0.004608382 0.005420921 0.004608382 0.013544527 0.011226880 0.004608382 [475] 0.012375729 0.004387194 0.011226880 0.004608382 0.016449997 0.005781412 [481] 0.004608382 0.011337448 0.014393116 0.003964098 0.011117142 0.004608382 [487] 0.011149566 0.004608382 0.022072474 0.016653951 0.010160691 0.004608382 [493] 0.005031322 0.033519092 0.011344928 0.004387194 0.023486024 0.020954161 [499] 0.017616641 0.018157551 0.005781412 0.012872065 0.004608382 0.004608382 [505] 0.004608382 0.010752292 0.013057719 0.013544527 0.011149566 0.004608382 [511] 0.011149566 0.004608382 0.012616830 0.004608382 0.004608382 0.004608382 [517] 0.006127871 0.010967804 0.018157551 0.004387194 0.011344928 0.011503711 [523] 0.005031322 0.005031322 0.004608382 0.011112987 0.005031322 0.004401579 [529] 0.011112987 0.018085278 0.012616830 0.011134495 0.005031322 0.010390776 [535] 0.022072474 0.019921938 0.010390776 0.016900095 0.015789365 0.007810055 [541] 0.012227284 0.004608382 0.011112987 0.011703228 0.004421263 0.003709070 [547] 0.012946738 0.006126070 0.012189365 0.013093342 0.009833896 0.009883436 [553] 0.011136137 0.003709070 0.003709070 0.006226728 0.023307982 0.011368319 [559] 0.009723625 0.003709070 0.003969043 0.003454965 0.003709070 0.003709070 [565] 0.005144381 0.003709070 0.012137490 0.018658577 0.018302336 0.019167867 [571] 0.030096659 0.022551408 0.018054944 0.018081328 0.047845941 0.009654088 [577] 0.003709070 0.047845941 0.003969043 0.003709070 0.006226728 0.006232099 [583] 0.003454965 0.003709070 0.018461325 0.018054944 0.029791958 0.018260762 [589] 0.030045166 0.047845941 0.009325333 0.051969049 0.015368043 0.003610949 [595] 0.003353910 0.005961624 0.003709070 0.003353910 0.012652204 0.003969043 [601] 0.006226728 0.038806395 0.024995469 0.024995469 0.021328713 0.031825357 [607] 0.011136137 0.003709070 0.003709070 0.009883436 0.005163892 0.005138529 [613] 0.003709070 0.003405905 0.004480187 0.003709070 0.003405905 0.003969043 [619] 0.009917425 0.003610949 0.005144381 0.003709070 0.014052742 0.010770791 [625] 0.006352800 0.006352800 0.003610949 0.009335241 0.003969043 0.006226728 [631] 0.005310732 0.003405905 0.003709070 0.004793153 0.009521276 0.004480187 [637] 0.005144381 0.003610949 0.003709070 0.005144381 0.003709070 0.005961624 [643] 0.005961624 0.003610949 0.003610949 0.003610949 0.003709070 0.003454965 [649] 0.013093342 0.003709070 0.003709070 0.003454965 0.003610949 0.009917425 [655] 0.003709070 0.006226728 0.006232099 0.003969043 0.011136137 0.003454965 [661] 0.003709070 0.003454965 0.003709070 0.003709070 0.009335241 0.003709070 [667] 0.003709070 0.003709070 0.003709070 0.003709070 0.004480187 0.003709070 [673] 0.015633954 0.019885789 0.018378193 0.003709070 0.004480187 0.011912196 [679] 0.005138529 0.005961624 0.003360776 0.015368043 0.003405905 0.004480187 [685] 0.009689886 0.009637219 0.018898425 0.006352800 0.006352800 0.003709070 [691] 0.003709070 0.014927762 0.003405905 0.013858083 0.014574541 0.013243646 [697] 0.013100487 0.009689886 0.006931917 0.020861992 0.021119127 0.013331359 [703] 0.018083391 0.003709070 0.003405905 0.003709070 0.010421723 0.005961624 [709] 0.003709070 0.003709070 0.003709070 0.010421723 0.009689886 0.003454965 [715] 0.009325333 0.003709070 0.003709070 0.009491551 0.005463014 0.011539911 [721] 0.005144381 0.006931917 0.003709070 0.012971160 0.005806901 0.006531330 [727] 0.003709070 0.028066251 0.003709070 0.003709070 0.005144381 0.003709070 [733] 0.014374173 0.014960685 0.014004258 0.026243500 0.027162406 0.003709070 [739] 0.003405905 0.013093342 0.019910563 0.006352800 0.003709070 0.011659872 [745] 0.003709070 0.036081112 0.036492552 0.036360876 0.036201863 0.037729879 [751] 0.037067490 0.047845941 0.047845941 0.003709070 0.003709070 0.003969043 [757] 0.015590420 0.015590420 0.004480187 0.003454965 0.005961624 0.006226728 [763] 0.012022157 0.003969043 0.003385306 0.015590420 0.006226728 0.003610949 [769] 0.017235431 0.003709070 0.014079127 0.009654088 0.005144381 0.009723625 [775] 0.003353910 0.009335241 0.003709070 0.003709070 0.021886792 0.011423061 [781] 0.003709070 0.003709070 0.009654088 0.003709070 0.003709070 0.006226728 [787] 0.006226728 0.009637219 0.009521276 0.003969043 0.003709070 0.006845065 [793] 0.003709070 0.009723625 0.003405905 0.003709070 0.003709070 0.003709070 [799] 0.018961924 0.021991791 0.003709070 0.003709070 0.004480187 0.017744860 [805] 0.003353910 0.009917425 0.003709070 0.005465316 0.005311499 0.009917425 [811] 0.005961624 0.003610949 0.003709070 0.009521276 0.003709070 0.003405905 [817] 0.019723160 0.012458150 0.004793153 0.003709070 0.003709070 0.014061593 [823] 0.015590420 0.020576854 0.023192495 0.011914533 0.021244470 0.005573821 [829] 0.012971160 0.009833896 0.003709070 0.009335241 0.009723625 0.003709070 [835] 0.003709070 0.003405905 0.009335241 0.003709070 0.003709070 0.003709070 [841] 0.003709070 0.003454965 0.003709070 0.003709070 0.006226728 0.006226728 [847] 0.011762171 0.003709070 0.006226728 0.006226728 0.003770865 0.009654088 [853] 0.003709070 0.009325333 0.009917425 0.009491551 0.003405905 0.003709070 [859] 0.003709070 0.003709070 0.003709070 0.014336135 0.003709070 0.005768346 [865] 0.005772183 0.003709070 0.009521276 0.003454965 0.003610949 0.003709070 [871] 0.003709070 0.017903889 0.010497888 0.003709070 0.009491551 0.005144381 [877] 0.003405905 0.014336135 0.021435778 0.011547897 0.011780687 0.003709070 [883] 0.016040246 0.013090910 0.003709070 0.003709070 0.011136137 0.009723625 [889] 0.003610949 0.003709070 0.011996947 0.003610949 0.003709070 0.009335241 [895] 0.003709070 0.003353910 0.009335241 0.015820661 0.003709070 0.005138529 [901] 0.003709070 0.003709070 0.009917425 0.003969043 0.003353910 0.003969043 [907] 0.003969043 0.006931917 0.009783288 0.018923656 0.014942288 0.017799178 [913] 0.013468147 0.047845941 0.041435110 0.037173375 0.040509595 0.036591877 [919] 0.036118466 0.047845941 0.003610949 0.004480187 0.003709070 0.021660554 [925] 0.018109508 0.012971160 0.003610949 0.003709070 0.003405905 0.012527469 [931] 0.003454965 0.003709070 0.004480187 0.006226728 0.005144381 0.009917425 [937] 0.005961624 0.003454965 0.003709070 0.003610949 0.036204728 0.038916835 [943] 0.037173375 0.040509595 0.036764402 0.047845941 0.003405905 0.003709070 [949] 0.006226728 0.006226728 0.019633944 0.005573821 0.012971160 0.003709070 [955] 0.006931917 0.003709070 0.003709070 0.159303782 0.003454965 0.009521276 [961] 0.003709070 0.021991791 0.017934870 0.018961924 0.009833896 0.003969043 [967] 0.003562886 0.009637219 0.003405905 0.003709070 0.003610949 0.011136137 [973] 0.012251885 0.010882173 0.011014802 0.013014555 0.047845941 0.047845941 [979] 0.004480187 0.003709070 0.003709070 0.003709070 0.009325333 0.003610949 [985] 0.003709070 0.004480187 0.003405905 0.009783288 0.003709070 0.021062507 [991] 0.006352800 0.013093342 0.014704357 0.003709070 0.003709070 0.012232907 [997] 0.003454965 0.009833896 0.003709070 0.023843847 0.013160547 0.003709070 [1003] 0.003709070 0.003709070 0.009833896 0.016706870 0.015633954 0.017600459 [1009] 0.003709070 0.011136137 0.034279995 0.008627703 0.012971160 0.013801537 [1015] 0.006352800 0.006352800 0.003709070 0.003709070 0.003709070 0.003709070 [1021] 0.014165852 0.028557684 0.015136280 0.006226728 0.009335241 0.003969043 [1027] 0.009331652 0.003405905 0.003405905 0.003709070 0.011577669 0.003709070 [1033] 0.006232099 0.005311499 0.018602388 0.003709070 0.003610949 0.003709070 [1039] 0.003709070 0.006226728 0.015400030 0.003709070 0.009047073 0.003709070 [1045] 0.003709070 0.003709070 $pmethod [1] "backward" $nprune NULL $penalty [1] 3 $nk [1] 21 $thresh [1] 0.001 $termcond [1] 7 $weights NULL $glm.list $glm.list[[1]] Call: glm(formula = yarg ~ ., family = family, data = bx.data.frame, weights = weights, na.action = na.action, offset = offset, control = control, model = TRUE, method = "glm.fit", x = TRUE, y = TRUE, contrasts = NULL, trace = (trace >= 2)) Coefficients: (Intercept) `survived*h(age-15)` `pclass3rd*survived` 1.64145 0.94212 1.28240 `h(25-age)*h(4-parch)` `h(sibsp-2)*h(4-parch)` `h(2-sibsp)*h(4-parch)` -0.02672 0.38100 0.16455 pclass3rd `pclass3rd*h(4-parch)` `pclass2nd*survived` -2.91928 0.53579 -0.99009 `survived*h(age-11.5)` -0.94463 Degrees of Freedom: 1045 Total (i.e. Null); 1036 Residual Null Deviance: 1380 Residual Deviance: 941.2 AIC: 961.2 $glm.coefficients male (Intercept) 1.6414456 survived*h(age-15) 0.9421209 pclass3rd*survived 1.2824017 h(25-age)*h(4-parch) -0.0267240 h(sibsp-2)*h(4-parch) 0.3810006 h(2-sibsp)*h(4-parch) 0.1645457 pclass3rd -2.9192836 pclass3rd*h(4-parch) 0.5357947 pclass2nd*survived -0.9900858 survived*h(age-11.5) -0.9446345 $glm.stats nulldev df dev df devratio AIC iters converged 1379.574 1045 941.1673 1036 0.3177844 961.1673 5 1 $call earth(formula = sex ~ ., data = etitanic, trace = 1, glm = list(family = "binomial"), degree = 2) $namesx.org [1] "pclass" "survived" "age" "sibsp" "parch" $namesx [1] "pclass" "survived" "age" "sibsp" "parch" $terms sex ~ pclass + survived + age + sibsp + parch attr(,"variables") list(sex, pclass, survived, age, sibsp, parch) attr(,"factors") pclass survived age sibsp parch sex 0 0 0 0 0 pclass 1 0 0 0 0 survived 0 1 0 0 0 age 0 0 1 0 0 sibsp 0 0 0 1 0 parch 0 0 0 0 1 attr(,"term.labels") [1] "pclass" "survived" "age" "sibsp" "parch" attr(,"order") [1] 1 1 1 1 1 attr(,"intercept") [1] 1 attr(,"response") [1] 1 attr(,".Environment") attr(,"predvars") list(sex, pclass, survived, age, sibsp, parch) attr(,"dataClasses") sex pclass survived age sibsp parch "factor" "factor" "numeric" "numeric" "numeric" "numeric" $xlevels $xlevels$pclass [1] "1st" "2nd" "3rd" $levels [1] "female" "male" attr(,"class") [1] "earth" ------------------------------------------------------------------------------- > > a7d <- earth(sex ~ .-pclass, data=etitanic, degree=2, glm=list(family="binomial"), trace=0) > a7dupdate <- update(a7, form=sex ~ .-pclass) update.earth: using 1046 by 6 data argument from original call to earth x[1046,4] with colnames survived age sibsp parch y[1046,1] with colname male, and values 0, 1, 0, 1, 0, 1, 0, 1, 0, 1,... Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.310 RSq 0.368 Prune backward penalty 3 nprune null: selected 8 of 19 terms, and 4 of 4 preds After pruning pass GRSq 0.335 RSq 0.357 GLM male devratio 0.30 dof 1038/1045 iters 4 > check.models.equal(a7dupdate, a7d, msg="a7update a7d", newdata=etitanic[5,]) a7update a7d: models not identical Formulas differ: sex ~ survived + age + sibsp + parch and: sex ~ (pclass + survived + age + sibsp + parch) - pclass a7update a7d: glm submodel formula strings are identical: yarg ~ `survived*h(age-15)` + `h(25-age)*h(4-parch)` + `h(sibsp-2)*h(4-parch)` + `h(2-sibsp)*h(4-parch)` + `h(sibsp-2)` + `h(2-sibsp)` + `survived*h(age-11.5)` a7update a7d: but the actual glm submodel formulas differ (classes are "formula" and "formula") a7update a7d: glm submodels not identical (but coefs, residuals, fitted.values are the same) a7update a7d: Models are equivalent, within numerical tolerances > printh(a7d$levels) === a7d$levels [1] "female" "male" > > a7d <- earth(sex ~ .-pclass, data=etitanic, degree=2, glm=list(family="binomial"), trace=0, keepxy=1) > a7dupdate <- update(a7, form=sex ~ .-pclass) update.earth: using 1046 by 6 data argument from original call to earth x[1046,4] with colnames survived age sibsp parch y[1046,1] with colname male, and values 0, 1, 0, 1, 0, 1, 0, 1, 0, 1,... Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.310 RSq 0.368 Prune backward penalty 3 nprune null: selected 8 of 19 terms, and 4 of 4 preds After pruning pass GRSq 0.335 RSq 0.357 GLM male devratio 0.30 dof 1038/1045 iters 4 > check.models.equal(a7dupdate, a7d, msg="a7update a7d with keepxy", newdata=etitanic[5,]) a7update a7d with keepxy: models not identical Formulas differ: sex ~ survived + age + sibsp + parch and: sex ~ (pclass + survived + age + sibsp + parch) - pclass a7update a7d with keepxy: glm submodel formula strings are identical: yarg ~ `survived*h(age-15)` + `h(25-age)*h(4-parch)` + `h(sibsp-2)*h(4-parch)` + `h(2-sibsp)*h(4-parch)` + `h(sibsp-2)` + `h(2-sibsp)` + `survived*h(age-11.5)` a7update a7d with keepxy: but the actual glm submodel formulas differ (classes are "formula" and "formula") a7update a7d with keepxy: glm submodels not identical (but coefs, residuals, fitted.values are the same) a7update a7d with keepxy: Models are equivalent, within numerical tolerances > > subset. <- rep(TRUE, nrow(etitanic)) > subset.[1:10] <- FALSE > a7e <- earth(sex ~ ., subset=subset., data=etitanic, degree=2, glm=list(family="binomial"), trace=0) > a7eupdate <- update(a7, subset=subset.) update.earth: using 1046 by 6 data argument from original call to earth x[1046,6] with colnames pclass2nd pclass3rd survived age sibsp parch y[1046,1] with colname male, and values 0, 1, 0, 1, 0, 1, 0, 1, 0, 1,... 1036 cases after taking subset Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.345 RSq 0.389 Prune backward penalty 3 nprune null: selected 11 of 15 terms, and 6 of 6 preds After pruning pass GRSq 0.358 RSq 0.389 GLM male devratio 0.33 dof 1025/1035 iters 5 > check.models.equal(a7eupdate, a7e, msg="a7update a7e", newdata=etitanic[5,]) a7update a7e: models not identical a7update a7e: glm submodel formula strings are identical: yarg ~ survived + `survived*h(age-15)` + `pclass3rd*survived` + pclass3rd + `h(sibsp-1)*h(4-parch)` + `h(1-sibsp)*h(4-parch)` + `pclass3rd*h(2-parch)` + `survived*h(age-26)` + `pclass2nd*survived` + `survived*h(age-12)` a7update a7e: but the actual glm submodel formulas differ (classes are "formula" and "formula") a7update a7e: glm submodels not identical (but coefs, residuals, fitted.values are the same) a7update a7e: Models are equivalent, within numerical tolerances > > subset. <- 1:nrow(etitanic) # another way of specifying a subset > subset.[1:10] <- 0 > a7eeupdate <- update(a7, subset=subset.) update.earth: using 1046 by 6 data argument from original call to earth x[1046,6] with colnames pclass2nd pclass3rd survived age sibsp parch y[1046,1] with colname male, and values 0, 1, 0, 1, 0, 1, 0, 1, 0, 1,... 1036 cases after taking subset Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.345 RSq 0.389 Prune backward penalty 3 nprune null: selected 11 of 15 terms, and 6 of 6 preds After pruning pass GRSq 0.358 RSq 0.389 GLM male devratio 0.33 dof 1025/1035 iters 5 > check.models.equal(a7eeupdate, a7e, msg="a7update a7e with alternative subset", newdata=etitanic[5,]) a7update a7e with alternative subset: models not identical a7update a7e with alternative subset: glm submodel formula strings are identical: yarg ~ survived + `survived*h(age-15)` + `pclass3rd*survived` + pclass3rd + `h(sibsp-1)*h(4-parch)` + `h(1-sibsp)*h(4-parch)` + `pclass3rd*h(2-parch)` + `survived*h(age-26)` + `pclass2nd*survived` + `survived*h(age-12)` a7update a7e with alternative subset: but the actual glm submodel formulas differ (classes are "formula" and "formula") a7update a7e with alternative subset: glm submodels not identical (but coefs, residuals, fitted.values are the same) a7update a7e with alternative subset: Models are equivalent, within numerical tolerances > > a7f <- earth(sex ~ ., data=etitanic, degree=2, glm=list(family=binomial(link="probit")), trace=0) > a7fupdate <- update(a7, glm=list(family=binomial(link="probit"))) update.earth: using 1046 by 6 data argument from original call to earth x[1046,6] with colnames pclass2nd pclass3rd survived age sibsp parch y[1046,1] with colname male, and values 0, 1, 0, 1, 0, 1, 0, 1, 0, 1,... Skipped forward pass Prune backward penalty 3 nprune null: selected 10 of 15 terms, and 6 of 6 preds After pruning pass GRSq 0.352 RSq 0.38 GLM male devratio 0.32 dof 1036/1045 iters 5 > check.models.equal(a7fupdate, a7f, msg="a7update a7f with link=probit", newdata=etitanic[5,]) a7update a7f with link=probit: models not identical a7update a7f with link=probit: glm submodel formula strings are identical: yarg ~ `survived*h(age-15)` + `pclass3rd*survived` + `h(25-age)*h(4-parch)` + `h(sibsp-2)*h(4-parch)` + `h(2-sibsp)*h(4-parch)` + pclass3rd + `pclass3rd*h(4-parch)` + `pclass2nd*survived` + `survived*h(age-11.5)` a7update a7f with link=probit: but the actual glm submodel formulas differ (classes are "formula" and "formula") a7update a7f with link=probit: glm submodels not identical (but coefs, residuals, fitted.values are the same) a7update a7f with link=probit: Models are equivalent, within numerical tolerances > > a7 <- earth(sex ~ ., data=etitanic, degree=2, glm=list(family="binomial"), keepxy=1) > a7g <- earth(sex ~ ., data=etitanic, degree=2, glm=list(family=binomial(link="probit")), trace=0) > a7gupdate <- update(a7, glm=list(family=binomial(link="probit")), trace=1) update.earth: using 1046 by 6 data saved by keepxy in original call to earth x[1046,6] with colnames pclass2nd pclass3rd survived age sibsp parch y[1046,1] with colname male, and values 0, 1, 0, 1, 0, 1, 0, 1, 0, 1,... Skipped forward pass Prune backward penalty 3 nprune null: selected 10 of 15 terms, and 6 of 6 preds After pruning pass GRSq 0.352 RSq 0.38 GLM male devratio 0.32 dof 1036/1045 iters 5 > check.models.equal(a7gupdate, a7g, msg="a7update a7g with link=probit and keepxy", newdata=etitanic[5,]) a7update a7g with link=probit and keepxy: models not identical a7update a7g with link=probit and keepxy: glm submodel formula strings are identical: yarg ~ `survived*h(age-15)` + `pclass3rd*survived` + `h(25-age)*h(4-parch)` + `h(sibsp-2)*h(4-parch)` + `h(2-sibsp)*h(4-parch)` + pclass3rd + `pclass3rd*h(4-parch)` + `pclass2nd*survived` + `survived*h(age-11.5)` a7update a7g with link=probit and keepxy: but the actual glm submodel formulas differ (classes are "formula" and "formula") a7update a7g with link=probit and keepxy: glm submodels not identical (but coefs, residuals, fitted.values are the same) a7update a7g with link=probit and keepxy: Models are equivalent, within numerical tolerances > > a8 <- earth(sex ~ ., data=etitanic, degree=2, glm=list(family="binomial"), keepxy=1) > a8g <- earth(sex ~ ., data=etitanic[100:900,], degree=2, glm=list(family=binomial), trace=0) > a8gupdate <- update(a8, data=etitanic[100:900,], trace=1) x[801,6] with colnames pclass2nd pclass3rd survived age sibsp parch y[801,1] with colname male, and values 0, 0, 0, 1, 1, 0, 0, 1, 1, 0,... Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.345 RSq 0.409 Prune backward penalty 3 nprune null: selected 9 of 17 terms, and 6 of 6 preds After pruning pass GRSq 0.369 RSq 0.4 GLM male devratio 0.34 dof 792/800 iters 5 > check.models.equal(a8gupdate, a8g, msg="a8update a8g with new data", newdata=etitanic[5,]) a8update a8g with new data: models not identical a8update a8g with new data: glm submodel formula strings are identical: yarg ~ survived + `h(3-parch)` + `pclass3rd*survived` + pclass3rd + `pclass3rd*h(13-age)` + pclass2nd + `h(15-age)` + `pclass3rd*h(2-sibsp)` a8update a8g with new data: but the actual glm submodel formulas differ (classes are "formula" and "formula") a8update a8g with new data: glm submodels not identical (but coefs, residuals, fitted.values are the same) a8update a8g with new data: Models are equivalent, within numerical tolerances > > # poisson models > > counts <- c(18,17,15,20,10,20,25,13,12) > counts2 <- c(181,171,151,201,101,201,251,131,121) > outcome <- gl(3,1,9) > treatment <- gl(3,3) > d.AD <- data.frame(treatment, outcome, counts, counts2) > > # one response poisson model > cat("a8p: one response poisson model\n\n") a8p: one response poisson model > a8p <- earth(counts ~ outcome + treatment, glm=list(family=poisson()), trace=3, pmethod=PMETHOD) x[9,4] with colnames outcome2 outcome3 treatment2 treatment3 y[9,1] with colname counts, and values 18, 17, 15, 20, 10, 20, 25, 1... Forward pass: minspan 3 endspan 3 x[9,4] 288 Bytes bx[9,21] 1.48 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 -0.2727 0.2841 0.2841 1 outcome2 0< 2 1 4 -0.8939 0.5265 0.2424 2 outcome3 0< 3 1 6 -6.5758 0.5265 0 - reject (no DeltaRsq) RSq changed by less than 0.001 at 5 terms, 3 terms used (DeltaRSq 0) After forward pass GRSq -6.576 RSq 0.527 Forward pass complete: 5 terms, 3 terms used Subset size GRSq RSq DeltaGRSq nPreds 1 0.0000 0.0000 0.0000 0 2 -0.2727 0.2841 -0.2727 1 chosen 3 -0.8939 0.5265 -0.6212 2 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 4 preds After pruning pass GRSq -0.894 RSq 0.527 GLM counts devratio 0.52 dof 6/8 iters 4 > show.earth.models(a8p, legend.pos="topleft") Print a8p GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged 10.5815 8 5.12914 6 0.515 52.76 4 1 Earth selected 3 of 3 terms, and 2 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 3 terms Importance: outcome2, outcome3, treatment2-unused, treatment3-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 46.875 RSS 83.33333 GRSq -0.8939394 RSq 0.5265152 Summary a8p Call: earth(formula=counts~outcome+treatment, pmethod=PMETHOD, trace=3, glm=list(family=poisson())) GLM coefficients counts (Intercept) 3.0445224 outcome2 -0.4542553 outcome3 -0.2929871 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged 10.5815 8 5.12914 6 0.515 52.76 4 1 Earth selected 3 of 3 terms, and 2 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 3 terms Importance: outcome2, outcome3, treatment2-unused, treatment3-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 46.875 RSS 83.33333 GRSq -0.8939394 RSq 0.5265152 Summary a8p digits=3, details=TRUE Call: earth(formula=counts~outcome+treatment, pmethod=PMETHOD, trace=3, glm=list(family=poisson())) Earth coefficients counts (Intercept) 21.00 outcome2 -7.67 outcome3 -5.33 GLM coefficients counts (Intercept) 3.045 outcome2 -0.454 outcome3 -0.293 GLM deviance residuals: Min 1Q Median 3Q Max -0.967 -0.671 -0.170 0.847 1.049 GLM coefficients (family poisson, link log) Estimate Std. Error z value Pr(>|z|) (Intercept) 3.045 0.126 24.17 <2e-16 outcome2 -0.454 0.202 -2.25 0.025 outcome3 -0.293 0.193 -1.52 0.128 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged 10.6 8 5.13 6 0.52 52.8 4 1 Earth selected 3 of 3 terms, and 2 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 3 terms Importance: outcome2, outcome3, treatment2-unused, treatment3-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 46.9 RSS 83.3 GRSq -0.894 RSq 0.527 evimp a8p nsubsets gcv rss outcome2 2 -100.0 100.0 outcome3 1 -83.4 67.9 evimp a8p trim=FALSE nsubsets gcv rss outcome2 2 -100.0 100.0 outcome3 1 -83.4 67.9 treatment2-unused 0 0.0 0.0 treatment3-unused 0 0.0 0.0 glm params: epsilon 1e-08 maxit 25 trace FALSE family poisson link log plotmo a8p plotmo grid: outcome treatment 1 1 ------------------------------------------------------------------------------- > # build a standard GLM model for comparison > cat("a9: one response poisson model, standard GLM model for comparison\n\n") a9: one response poisson model, standard GLM model for comparison > a9 <- glm(counts ~ outcome + treatment, family="poisson") > cat("Direct GLM a9 summary:\n\n") Direct GLM a9 summary: > print(summary(a9)) Call: glm(formula = counts ~ outcome + treatment, family = "poisson") Deviance Residuals: 1 2 3 4 5 6 7 8 -0.67125 0.96272 -0.16965 -0.21999 -0.95552 1.04939 0.84715 -0.09167 9 -0.96656 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) 3.045e+00 1.709e-01 17.815 <2e-16 *** outcome2 -4.543e-01 2.022e-01 -2.247 0.0246 * outcome3 -2.930e-01 1.927e-01 -1.520 0.1285 treatment2 1.338e-15 2.000e-01 0.000 1.0000 treatment3 1.421e-15 2.000e-01 0.000 1.0000 --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 (Dispersion parameter for poisson family taken to be 1) Null deviance: 10.5814 on 8 degrees of freedom Residual deviance: 5.1291 on 4 degrees of freedom AIC: 56.761 Number of Fisher Scoring iterations: 4 > plotmo(a9, grid.levels=list(outcome="2"), caption="a9 <- glm(counts ~ outcome + treatment, family=\"poisson\")") plotmo grid: outcome treatment 2 1 > > # two response poisson model > cat("a10: two response poisson model\n\n") a10: two response poisson model > a10 <- earth(cbind(counts, counts2) ~ outcome + treatment, glm=list(fam="po"), trace=1, pmethod=PMETHOD) x[9,4] with colnames outcome2 outcome3 treatment2 treatment3 y[9,2] with colnames counts counts2 Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 3 terms used (DeltaRSq 0) After forward pass GRSq -6.576 RSq 0.527 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 4 preds After pruning pass GRSq -0.894 RSq 0.527 GLM counts devratio 0.52 dof 6/8 iters 4 GLM counts2 devratio 0.52 dof 6/8 iters 4 > show.earth.models(a10, nresponse="counts") Print a10 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged counts 10.5815 8 5.12914 6 0.515 52.76 4 1 counts2 105.1660 8 50.96448 6 0.515 119.30 4 1 Earth selected 3 of 3 terms, and 2 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 3 terms Importance: outcome2, outcome3, treatment2-unused, treatment3-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV RSS GRSq RSq counts 46.875 83.3333 -0.8939394 0.5265152 counts2 4687.500 8333.3333 -0.8939394 0.5265152 All 4734.375 8416.6667 -0.8939394 0.5265152 Summary a10 Call: earth(formula=cbind(counts,counts2)~outcome+treatment, pmethod=PMETHOD, trace=1, glm=list(fam="po")) GLM coefficients counts counts2 (Intercept) 3.0445224 5.3518581 outcome2 -0.4542553 -0.4515339 outcome3 -0.2929871 -0.2913750 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged counts 10.5815 8 5.12914 6 0.515 52.76 4 1 counts2 105.1660 8 50.96448 6 0.515 119.30 4 1 Earth selected 3 of 3 terms, and 2 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 3 terms Importance: outcome2, outcome3, treatment2-unused, treatment3-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV RSS GRSq RSq counts 46.875 83.3333 -0.8939394 0.5265152 counts2 4687.500 8333.3333 -0.8939394 0.5265152 All 4734.375 8416.6667 -0.8939394 0.5265152 Summary a10 decomp="none", digits=5, fixed.point=FALSE, details=TRUE Call: earth(formula=cbind(counts,counts2)~outcome+treatment, pmethod=PMETHOD, trace=1, glm=list(fam="po")) Earth coefficients counts counts2 (Intercept) 21.0000 211.000 outcome2 -7.6667 -76.667 outcome3 -5.3333 -53.333 GLM coefficients counts counts2 (Intercept) 3.04452 5.35186 outcome2 -0.45426 -0.45153 outcome3 -0.29299 -0.29138 GLM counts deviance residuals: Min 1Q Median 3Q Max -0.96656 -0.67125 -0.16965 0.84715 1.04939 GLM counts coefficients (family poisson, link log) Estimate Std. Error z value Pr(>|z|) (Intercept) 3.04452 0.12599 24.1651 < 2e-16 outcome2 -0.45426 0.20217 -2.2469 0.02465 outcome3 -0.29299 0.19274 -1.5201 0.12849 GLM counts2 deviance residuals: Min 1Q Median 3Q Max -3.04594 -2.11738 -0.53474 2.67294 3.30873 GLM counts2 coefficients (family poisson, link log) Estimate Std. Error z value Pr(>|z|) (Intercept) 5.351858 0.039746 134.6500 < 2.2e-16 outcome2 -0.451534 0.063727 -7.0854 1.386e-12 outcome3 -0.291375 0.060778 -4.7941 1.634e-06 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged counts 10.58 8 5.129 6 0.52 52.8 4 1 counts2 105.17 8 50.964 6 0.52 119.0 4 1 Earth selected 3 of 3 terms, and 2 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 3 terms Importance: outcome2, outcome3, treatment2-unused, treatment3-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV RSS GRSq RSq counts 46.87 83.33 -0.89394 0.52651 counts2 4687.50 8333.33 -0.89394 0.52651 All 4734.38 8416.67 -0.89394 0.52651 evimp a10 nsubsets gcv rss outcome2 2 -100.0 100.0 outcome3 1 -83.4 67.9 evimp a10 trim=FALSE nsubsets gcv rss outcome2 2 -100.0 100.0 outcome3 1 -83.4 67.9 treatment2-unused 0 0.0 0.0 treatment3-unused 0 0.0 0.0 glm params: epsilon 1e-08 maxit 25 trace FALSE family poisson link log plotmo a10 plotmo grid: outcome treatment 1 1 ------------------------------------------------------------------------------- > > # compare family=gaussian to standard earth model > cat("a11: compare family=gaussian to standard earth model\n\n") a11: compare family=gaussian to standard earth model > a11 <- earth(etitanic$sex ~ ., data=etitanic, degree=2, glm=list(family="gaussian"), trace=4) Call: earth(formula=etitanic$sex~., data=etitanic, trace=4, glm=list(family="gaussian"), degree=2) x[1046,6]: pclass2nd pclass3rd survived age sibsp parch 1 0 0 1 29.0000 0 0 2 0 0 1 0.9167 1 2 3 0 0 0 2.0000 1 2 ... 0 0 0 30.0000 1 2 1046 0 1 0 29.0000 0 0 y[1046,1]: male 1 0 2 1 3 0 ... 1 1046 1 Forward pass: minspan 6 endspan 9 x[1046,6] 49 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.2860 0.2894 0.2894 3 survived 0< 2 1 4 0.3055 0.3155 0.02604 6 parch 4 3 4 1 6 0.3162 0.3325 0.017 4 age 15 5 6 2 2 8 0.3227 0.3420 0.009563 2 pclass3rd 0< 7 2 2 10 0.3270 0.3525 0.01049 4 age 25 8 9 5 2 12 0.3288 0.3605 0.007986 5 sibsp 2 10 11 5 2 14 0.3336 0.3682 0.007705 2 pclass3rd 0< 12 1 16 0.3389 0.3763 0.008053 2 pclass3rd 0< 13 5 2 18 0.3404 0.3808 0.004528 1 pclass2nd 0< 14 2 2 20 0.3405 0.3839 0.003089 4 age 11.5 15 2 2 final (reached nk 21) Reached nk 21 After forward pass GRSq 0.340 RSq 0.384 Forward pass complete: 21 terms, 15 terms used Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 2 0.2860 0.2894 0.2860 1 1 2 3 0.2872 0.2940 0.0011 2 1 2 3 4 0.3055 0.3155 0.0184 2 1 2 3 4 5 0.3052 0.3185 -0.0003 3 1 2 3 4 5 6 0.3195 0.3357 0.0143 4 1 5 9 12 13 15 7 0.3314 0.3504 0.0118 4 1 5 7 9 12 13 15 8 0.3377 0.3597 0.0063 5 1 5 7 9 10 12 13 15 9 0.3472 0.3720 0.0096 5 1 5 7 9 10 11 12 13 15 chosen 10 0.3524 0.3800 0.0052 6 1 5 7 9 10 11 12 13 14 15 11 0.3511 0.3818 -0.0013 6 1 3 5 7 9 10 11 12 13 14 15 12 0.3494 0.3832 -0.0017 6 1 2 3 5 7 9 10 11 12 13 14 15 13 0.3465 0.3835 -0.0028 6 1 2 3 5 6 7 9 10 11 12 13 14 15 14 0.3436 0.3838 -0.0029 6 1 2 3 4 5 6 7 9 10 11 12 13 14 15 15 0.3405 0.3839 -0.0032 6 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Prune backward penalty 3 nprune null: selected 10 of 15 terms, and 6 of 6 preds After pruning pass GRSq 0.352 RSq 0.38 glm y[1046,1]: male 1 0 2 1 3 0 ... 1 1046 1 glm weights: NULL GLM male devratio 0.38 dof 1036/1045 iters 2 > cat("\nsummary(a11, details=TRUE)\n\n", sep="") summary(a11, details=TRUE) > print(summary(a11, details=TRUE)) Call: earth(formula=etitanic$sex~., data=etitanic, trace=4, glm=list(family="gaussian"), degree=2) Earth coefficients male (Intercept) 0.78683434 pclass3rd -0.54704139 pclass2nd * survived -0.16389622 pclass3rd * survived 0.21003798 pclass3rd * h(4-parch) 0.11827615 survived * h(age-15) 0.17223256 survived * h(age-11.5) -0.17249670 h(25-age) * h(4-parch) -0.00453940 h(2-sibsp) * h(4-parch) 0.02431712 h(sibsp-2) * h(4-parch) 0.06510531 GLM coefficients male (Intercept) 0.78683434 pclass3rd -0.54704139 pclass2nd * survived -0.16389622 pclass3rd * survived 0.21003798 pclass3rd * h(4-parch) 0.11827615 survived * h(age-15) 0.17223256 survived * h(age-11.5) -0.17249670 h(25-age) * h(4-parch) -0.00453940 h(2-sibsp) * h(4-parch) 0.02431712 h(sibsp-2) * h(4-parch) 0.06510531 GLM deviance residuals: Min 1Q Median 3Q Max -0.98137128 -0.24911370 0.06726295 0.18302689 0.91075446 GLM coefficients (family gaussian, link identity) Estimate Std. Error t value Pr(>|t|) (Intercept) 0.7868343433 0.0423871064 18.56306 < 2.22e-16 survived * h(age-15) 0.1722325636 0.0149860217 11.49288 < 2.22e-16 pclass3rd * survived 0.2100379776 0.0508526436 4.13033 3.9143e-05 h(25-age) * h(4-parch) -0.0045393995 0.0008358286 -5.43102 6.9815e-08 h(sibsp-2) * h(4-parch) 0.0651053056 0.0141628706 4.59690 4.8168e-06 h(2-sibsp) * h(4-parch) 0.0243171175 0.0055901123 4.35002 1.4958e-05 pclass3rd -0.5470413932 0.0946425398 -5.78008 9.8730e-09 pclass3rd * h(4-parch) 0.1182761529 0.0244084967 4.84570 1.4543e-06 pclass2nd * survived -0.1638962213 0.0447652568 -3.66124 0.00026368 survived * h(age-11.5) -0.1724966990 0.0137251005 -12.56797 < 2.22e-16 GLM dispersion parameter for gaussian family taken to be 0.1460669 GLM (family gaussian, link identity): nulldev df dev df devratio AIC iters converged 244.077 1045 151.325 1036 0.38 968.2 2 1 Earth selected 10 of 15 terms, and 6 of 6 predictors Termination condition: Reached nk 21 Importance: survived, parch, age, pclass3rd, sibsp, pclass2nd Number of terms at each degree of interaction: 1 1 8 Earth GCV 0.1513968 RSS 151.3254 GRSq 0.3524225 RSq 0.3800084 > stopifnot(identical(a11$coefficients, a11$glm.coefficients)) > cat("-------------------------------------------------------------------------------\n\n") ------------------------------------------------------------------------------- > > cat("a12: compare family=gaussian to standard earth model with two responses\n\n") a12: compare family=gaussian to standard earth model with two responses > a12 <- earth(cbind(etitanic$sex, (as.integer(etitanic$age)^2)) ~ ., data=etitanic, degree=2, glm=list(family="gaussian"), trace=4) Call: earth(formula=cbind(etitanic$sex,(as.integer(etitanic$age)^2))~., data=etitanic, trace=4, glm=list(family="gaussian"), degree=2) x[1046,5]: pclass2nd pclass3rd survived sibsp parch 1 0 0 1 0 0 2 0 0 1 1 2 3 0 0 0 1 2 ... 0 0 0 1 2 1046 0 1 0 0 0 y[1046,2]: y1 y2 1 1 841 2 2 0 3 1 4 ... 2 900 1046 2 841 Forward pass: minspan 6 endspan 9 x[1046,5] 40.9 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.1060 0.1103 0.1103 2 pclass3rd 0< 2 1 4 0.1653 0.1733 0.06303 1 pclass2nd 0< 3 1 6 0.2059 0.2210 0.04767 5 parch 2 4 5 1 8 0.2210 0.2396 0.01859 3 survived 0< 6 1 10 0.2223 0.2481 0.008525 5 parch 2 7 8 2 2 12 0.2234 0.2565 0.00837 4 sibsp 1 9 10 1 14 0.2219 0.2587 0.002244 5 parch 1 11 2 2 16 0.2231 0.2635 0.004765 5 parch 1 12 1 18 0.2226 0.2702 0.006718 5 parch 1 13 14 4 2 20 0.2232 0.2743 0.00415 1 pclass2nd 0< 15 6 2 final (reached nk 21) Reached nk 21 After forward pass GRSq 0.223 RSq 0.274 Forward pass complete: 21 terms, 15 terms used Using EvalSubsetsUsingXtx (rather than leaps) because this is a multiple response model nTerms iTerm DeltaRss RSq 15 2 2.8941e+007 0.2461 min 15 3 3.4484e+007 0.2406 15 4 3.0548e+007 0.2445 15 5 1.9834e+006 0.2724 min 15 6 2.0705e+007 0.2541 15 7 2.4297e+007 0.2506 15 8 6.3042e+006 0.2682 15 9 6.3458e+006 0.2681 15 10 8231.6 0.2743 min 15 11 1.5243e+007 0.2594 15 12 1.4677e+007 0.2600 15 13 1.0817e+007 0.2638 15 14 4.9902e+006 0.2695 15 15 4.2448e+006 0.2702 14 2 2.9403e+007 0.2456 min 14 3 3.491e+007 0.2402 14 4 3.0578e+007 0.2444 14 5 1.9758e+006 0.2724 min 14 6 2.074e+007 0.2541 14 7 2.4514e+007 0.2504 14 8 6.4997e+006 0.2680 14 9 6.995e+006 0.2675 14 11 1.5597e+007 0.2591 14 12 1.467e+007 0.2600 14 13 1.0901e+007 0.2637 14 14 5.1186e+006 0.2693 14 15 4.2486e+006 0.2702 13 2 4.1871e+007 0.2315 min 13 3 4.0788e+007 0.2325 min 13 4 3.2141e+007 0.2410 min 13 6 2.0184e+007 0.2527 min 13 7 2.3466e+007 0.2495 13 8 5.1563e+006 0.2674 min 13 9 7.0251e+006 0.2655 13 11 1.5565e+007 0.2572 13 12 2.1626e+007 0.2513 13 13 8.9657e+006 0.2636 13 14 3.173e+006 0.2693 min 13 15 3.5082e+006 0.2690 12 2 4.1546e+007 0.2287 min 12 3 7.7449e+007 0.1936 12 4 3.1892e+007 0.2381 min 12 6 2.3605e+007 0.2462 min 12 7 2.3299e+007 0.2465 min 12 8 4.9192e+006 0.2645 min 12 9 7.5636e+006 0.2619 12 11 1.5356e+007 0.2543 12 12 2.139e+007 0.2484 12 13 6.1065e+006 0.2633 12 15 2.5439e+006 0.2668 min 11 2 4.0833e+007 0.2269 min 11 3 7.5335e+007 0.1932 11 4 3.2208e+007 0.2353 min 11 6 2.3752e+007 0.2436 min 11 7 2.0994e+007 0.2463 min 11 8 4.7818e+006 0.2621 min 11 9 8.2607e+006 0.2587 11 11 1.3425e+007 0.2537 11 12 1.8871e+007 0.2484 11 13 3.5784e+006 0.2633 min 10 2 3.947e+007 0.2247 min 10 3 7.2626e+007 0.1923 10 4 2.897e+007 0.2350 min 10 6 2.2396e+007 0.2414 min 10 7 1.8734e+007 0.2450 min 10 8 4.7438e+006 0.2587 min 10 9 8.8185e+006 0.2547 10 11 1.0366e+007 0.2532 10 12 1.638e+007 0.2473 9 2 1.8992e+008 0.0730 min 9 3 7.3379e+007 0.1870 min 9 4 2.8502e+007 0.2308 min 9 6 2.5381e+007 0.2339 min 9 7 1.4043e+007 0.2450 min 9 9 1.3625e+007 0.2454 min 9 11 5.6644e+006 0.2531 min 9 12 1.5764e+007 0.2433 8 2 1.8436e+008 0.0729 min 8 3 7.3891e+007 0.1809 min 8 4 2.2897e+007 0.2308 min 8 6 2.6814e+007 0.2269 8 7 8.7055e+006 0.2446 min 8 9 9.3843e+006 0.2440 8 12 1.0108e+007 0.2433 7 2 1.9348e+008 0.0555 min 7 3 7.5359e+007 0.1710 min 7 4 1.7932e+007 0.2271 min 7 6 2.644e+007 0.2188 7 9 9.7584e+006 0.2351 min 7 12 8.2948e+006 0.2365 min 6 2 1.9155e+008 0.0493 min 6 3 7.663e+007 0.1616 min 6 4 1.17e+007 0.2251 min 6 6 3.1425e+007 0.2058 6 9 2.1466e+007 0.2155 5 2 1.8693e+008 0.0424 min 5 3 7.7548e+007 0.1493 min 5 6 3.258e+007 0.1932 min 5 9 2.2907e+007 0.2027 min 4 2 2.0575e+008 0.0016 min 4 3 7.681e+007 0.1276 min 4 6 3.0059e+007 0.1733 min 3 2 1.7662e+008 0.0007 min 3 3 6.448e+007 0.1103 min 2 2 1.1281e+008 0.0000 min Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 2 0.1060 0.1103 0.1060 1 1 2 3 0.1653 0.1733 0.0593 2 1 2 3 4 0.1911 0.2027 0.0258 3 1 2 3 6 5 0.2100 0.2251 0.0189 4 1 2 3 6 9 6 0.2179 0.2365 0.0079 5 1 2 3 4 6 9 7 0.2225 0.2446 0.0045 5 1 2 3 4 6 9 12 8 0.2275 0.2531 0.0050 5 1 2 3 4 6 7 9 12 9 0.2295 0.2587 0.0020 5 1 2 3 4 6 7 9 11 12 chosen 10 0.2305 0.2633 0.0011 5 1 2 3 4 6 7 8 9 11 12 11 0.2304 0.2668 -0.0001 5 1 2 3 4 6 7 8 9 11 12 13 12 0.2293 0.2693 -0.0012 5 1 2 3 4 6 7 8 9 11 12 13 15 13 0.2288 0.2724 -0.0005 5 1 2 3 4 6 7 8 9 11 12 13 14 15 14 0.2270 0.2743 -0.0018 5 1 2 3 4 5 6 7 8 9 11 12 13 14 15 15 0.2232 0.2743 -0.0038 5 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Prune backward penalty 3 nprune null: selected 10 of 15 terms, and 5 of 5 preds After pruning pass GRSq 0.231 RSq 0.263 glm y[1046,1]: y1 1 1 2 2 3 1 ... 2 1046 2 glm weights: NULL GLM y1 devratio 0.32 dof 1036/1045 iters 2 glm y[1046,1]: y2 1 841 2 0 3 4 ... 900 1046 841 glm weights: NULL GLM y2 devratio 0.26 dof 1036/1045 iters 2 > cat("\nsummary(a12, details=TRUE)\n\n", sep="") summary(a12, details=TRUE) > print(summary(a12, details=TRUE)) Call: earth(formula=cbind(etitanic$sex,(as.integer(etitanic$age)^2))~., data=etitanic, trace=4, glm=list(family="gaussian"), degree=2) Earth coefficients y1 y2 (Intercept) 1.87825514 1994.3477 pclass2nd -0.03052777 -739.9866 pclass3rd -0.24945083 -1666.0231 survived -0.52605843 -320.9401 h(sibsp-1) 0.01497329 -177.7240 h(parch-1) -0.09968178 -594.6399 h(parch-2) 0.04012795 1973.9441 pclass3rd * h(parch-2) -0.02275679 -2152.3800 pclass3rd * h(2-parch) 0.13019337 299.5782 pclass3rd * h(parch-1) 0.03601703 1047.1577 GLM coefficients y1 y2 (Intercept) 1.87825514 1994.3477 pclass2nd -0.03052777 -739.9866 pclass3rd -0.24945083 -1666.0231 survived -0.52605843 -320.9401 h(sibsp-1) 0.01497329 -177.7240 h(parch-1) -0.09968178 -594.6399 h(parch-2) 0.04012795 1973.9441 pclass3rd * h(parch-2) -0.02275679 -2152.3800 pclass3rd * h(2-parch) 0.13019337 299.5782 pclass3rd * h(parch-1) 0.03601703 1047.1577 GLM y1 deviance residuals: Min 1Q Median 3Q Max -0.9041644 -0.3216689 0.1108089 0.1522726 0.9609189 GLM y1 coefficients (family gaussian, link identity) Estimate Std. Error t value Pr(>|t|) (Intercept) 1.87825514 0.02962998 63.39037 < 2e-16 pclass3rd -0.24945083 0.10625049 -2.34776 0.019074 pclass2nd -0.03052777 0.03479059 -0.87747 0.380434 h(parch-2) 0.04012795 0.14694175 0.27309 0.784840 survived -0.52605843 0.02717222 -19.36016 < 2e-16 pclass3rd * h(parch-2) -0.02275679 0.19924557 -0.11421 0.909090 pclass3rd * h(2-parch) 0.13019337 0.05510971 2.36244 0.018339 h(sibsp-1) 0.01497329 0.02397899 0.62443 0.532480 pclass3rd * h(parch-1) 0.03601703 0.13031139 0.27639 0.782302 h(parch-1) -0.09968178 0.05886754 -1.69332 0.090695 GLM y1 dispersion parameter for gaussian family taken to be 0.1605338 GLM y2 deviance residuals: Min 1Q Median 3Q Max -1705.3478 -514.7814 -198.4811 297.5189 4726.5924 GLM y2 coefficients (family gaussian, link identity) Estimate Std. Error t value Pr(>|t|) (Intercept) 1994.34775 63.07215 31.62010 < 2.22e-16 pclass3rd -1666.02307 226.17115 -7.36621 3.5776e-13 pclass2nd -739.98661 74.05734 -9.99208 < 2.22e-16 h(parch-2) 1973.94408 312.78900 6.31078 4.1081e-10 survived -320.94014 57.84041 -5.54872 3.6538e-08 pclass3rd * h(parch-2) -2152.38000 424.12604 -5.07486 4.5943e-07 pclass3rd * h(2-parch) 299.57821 117.30982 2.55374 0.01079967 h(sibsp-1) -177.72401 51.04312 -3.48184 0.00051875 pclass3rd * h(parch-1) 1047.15774 277.38862 3.77506 0.00016906 h(parch-1) -594.63992 125.30896 -4.74539 2.3728e-06 GLM y2 dispersion parameter for gaussian family taken to be 727409.6 GLM (family gaussian, link identity): nulldev df dev df devratio AIC iters converged y1 2.44077e+02 1045 1.66313e+02 1036 0.319 1067 2 1 y2 1.02296e+09 1045 7.53596e+08 1036 0.263 17100 2 1 Earth selected 10 of 15 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: pclass3rd, pclass2nd, survived, sibsp, parch Number of terms at each degree of interaction: 1 6 3 Earth GCV RSS GRSq RSq y1 0.17 166 0.2882848 0.3186029 y2 753952.19 753596300 0.2305416 0.2633195 All 753952.36 753596466 0.2305416 0.2633195 > stopifnot(identical(a12$coefficients, a12$glm.coefficients)) > > # test to see how standard model.matrix does column numbering with formula > > my.x1 <- as.numeric(ToothGrowth[,2]) # supp was VC or OJ > my.x2 <- as.numeric(ToothGrowth[,3]) # dose > my.input.mat <- cbind(my.x1, my.x2) > my.response <- ToothGrowth[,1] > a13 <- earth(my.response~my.input.mat, trace=1) x[60,2] with colnames my.input.matmy.x1 my.input.matmy.x2 y[60,1] with colname my.response, and values 4.2, 11.5, 7.3, 5.8, 6.4, 10,... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 4 terms used (DeltaRSq 0) After forward pass GRSq 0.682 RSq 0.762 Prune backward penalty 2 nprune null: selected 4 of 4 terms, and 2 of 2 preds After pruning pass GRSq 0.705 RSq 0.762 > print(summary(a13, details=TRUE)) Call: earth(formula=my.response~my.input.mat, trace=1) coefficients (Intercept) 25.285 my.input.matmy.x1 -3.700 h(1-my.input.matmy.x2) -18.260 h(my.input.matmy.x2-1) 6.365 Selected 4 of 4 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: my.input.matmy.x2, my.input.matmy.x1 Number of terms at each degree of interaction: 1 3 (additive model) GCV 17.52421 RSS 820.425 GRSq 0.7054941 RSq 0.7623478 > > stop.if.not.identical <- function(msg, a, b) + { + if(!identical(a, b)) { + cat(msg, "not identical\n") + cat(deparse(substitute(a)), ":\n", sep="") + print(a) + cat(deparse(substitute(b)), ":\n", sep="") + print(b) + stop("test failed") + } + cat(msg, "identical\n") + } > > # some matrix interface tests > > # double response glm model with two binomial paired cols > SF.both <- cbind(SF, SF2) > df <- data.frame(sex, ldose) > expect.err(try(earth(SF.both ~ ., data=df, glm=list(family="binomial"), trace=1)), "Binomial response (see above): all values should be between 0 and 1, or a binomial pair") x[12,2] with colnames sexmale ldose y[12,4] with colnames numdead numalive numdead2 numalive2 print(head(y)): numdead numalive numdead2 numalive2 [1,] 1 19 2 18 [2,] 4 16 3 17 [3,] 9 11 10 10 [4,] 13 7 13 7 [5,] 18 2 19 1 [6,] 20 0 20 0 Error : Binomial response (see above): all values should be between 0 and 1, or a binomial pair Got error as expected from try(earth(SF.both ~ ., data = df, glm = list(family = "binomial"), trace = 1)) > > # --- predict with factors ------------------------------------------------------ > > # there is a lot of redundancy in this routine, it doesn't really matter > > test.predict.with.factors <- function(trace) + { + cat("\n--- predict with single level factors and a single response, trace=", trace, + " ---\n\n", sep="") + + cat("first do a quick test of predict.earth help page example\n") + a <- earth(Volume ~ ., data = trees) + if (trace) print(head(predict(a, trace=trace))) + if (trace) print(predict(a, c(10,80), trace=trace)) + + # test set A: prepare the data + + ldose <- rep(0:5, 2) - 2 + # ldose1 <- c(0.1, 1.2, 2.3, 3.4, 4.5, 5.6, 0.3, 1.4, 2.5, 3.6, 4.7, 5.8) + ldose1 <- c(0.1, 1.2, 0.1, 1.2, 1.0, 0.1, 0.3, 1.4, 0.1, 1.2, 0.1, 0.9) + sex <- factor(rep(c("male", "female"), times=c(6,6))) + numdead <- c(1,4,9,13,18,20,0,2,6,10,12,16) + + sexmale <- (sex == "male") + am <- earth(cbind(sexmale, ldose, ldose1), numdead, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) + af <- earth(numdead ~ sex + ldose + ldose1, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) + check.models.equal(am, af, "predict with single level factors and a single response") + + cat("A-20m head(predict(am, trace=", trace, ")\n", sep="") + pm <- predict(am, trace=trace) + if (trace) print(head(pm)) + + cat("A-20f head(predict(af, trace=", trace, ")\n", sep="") + pf <- predict(af, trace=trace) + if (trace) print(head(pf)) + stop.if.not.identical("A-20", pm, pf) + + cat("A-21m predict(am, newdata=c(sex[1], -2, 0.1), trace=", trace, "))\n", sep="") + pm <- predict(am, newdata=c(sex[1]=="male", -2, 0.1), trace=trace) + pm.ref <- pm + if (trace) print(pm) + + cat("A-21f predict(af, newdata=c(sex[1], -2, 0.1), trace=", trace, "))\n", sep="") + pf <- predict(af, newdata=c(sex[1]=="male", -2, 0.1), trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-21", pm.ref, pf) + + cat("A-22m predict(am, newdata=c(1, -2, 0.1), trace=", trace, ")) use numeric instead of factor sex\n", sep="") + pm <- predict(am, newdata=c(1, -2, 0.1), trace=trace) + if (trace) print(pm) + stop.if.not.identical("A-22", pm.ref, pm) + + cat("A-22f predict(af, newdata=c(1, -2, 0.1), trace=", trace, ")) use numeric instead of factor sex\n", sep="") + pf <- predict(af, newdata=c(1, -2, 0.1), trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-22", pm, pf) + + cat("A-23m predict(am, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=", trace, ")) multiple rows as a vec\n", sep="") + pm <- predict(am, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=trace) + if (trace) print(pm) + + cat("A-23f predict(af, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=", trace, ")) multiple rows as a vec\n", sep="") + pf <- predict(af, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-23", pm, pf) + + cat("A-24m predict(am, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=", trace, ")) more multiple rows as a vec\n", sep="") + pm <- predict(am, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=trace) + if (trace) print(pm) + pm2.ref <- pm + + cat("A-24f predict(af, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=", trace, ")) more multiple rows as a vec\n", sep="") + pf <- predict(af, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-24", pm, pf) + + cat("A-25m predict(am, xpredict matrix trace=", trace, "\n", sep="") + new.data <- matrix(c(sex[1], sex[1], -2, -1, 0.1, 0.1), nrow=2) + pm <- predict(am, newdata=new.data, trace=trace) + if (trace) print(pm) + stop.if.not.identical("A-25", pm2.ref, pm) + + cat("A-25f predict(af, xpredict matrix trace=", trace, "\n", sep="") + pf <- predict(af, newdata=new.data, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-25", pm, pf) + + cat("A-26m predict(am, new.data with col names) trace=", trace, "\n", sep="") + new.data <- matrix(c(sex[1], sex[1], -2, -1, 0.1, 0.1), nrow=2) + colnames(new.data) <- c("sex", "ldose", "ldose1") + pm <- predict(am, newdata=new.data, trace=trace) + if (trace) print(pm) + stop.if.not.identical("A-26m", pm2.ref, pm) + + cat("A-26f predict(af, new.data with col names) trace=", trace, "\n", sep="") + pf <- predict(af, newdata=new.data, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-26f", pm, pf) + + cat("A-27m predict(am, new.data with out of order col names) trace=", trace, "\n", sep="") + new.data <- matrix(c(sex[1], sex[1], 0.1, 0.1, -2, -1), nrow=2) + colnames(new.data) <- c("sex", "ldose1", "ldose") + pm <- predict(am, newdata=new.data, trace=trace) + if (trace) print(pm) + stop.if.not.identical("A-27", pm2.ref, pm) + + cat("A-27f predict(af, new.data with out of order col names) trace=", trace, "\n", sep="") + pf <- predict(af, newdata=new.data, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-27", pm, pf) + + cat("A-28m predict(am, xdata.frame without col names) trace=", trace, "\n", sep="") + if (trace) print(pm) + stop.if.not.identical("A-28", pm2.ref, pm) + + cat("A-28f predict(af, xdata.frame without col names) trace=", trace, "\n", sep="") + xdata.frame <- data.frame(c(sex[1], sex[1]), c(-2, -1), c(0.1, 0.1)) + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-28", pm, pf) + + cat("A-29m predict(am, xdata.frame with col names) trace=", trace, "\n", sep="") + xdata.frame.29 <- data.frame(sex[1], -2, 0.1) + colnames(xdata.frame.29) <- c("sex", "ldose", "ldose1") + pm <- predict(am, xdata.frame.29, trace=trace) + if (trace) print(pm) + stop.if.not.identical("A-29", pm.ref, pm) + + cat("A-29f predict(af, xdata.frame with col names) trace=", trace, "\n", sep="") + pf <- predict(af, xdata.frame.29, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-29", pm, pf) + + cat("A2-29m predict(am, xdata.frame with col names) trace=", trace, "\n", sep="") + xdata.frame.29.2 <- data.frame(c(sex[1], sex[1]), c(-2, -1), c(0.1, 0.1)) + colnames(xdata.frame.29.2) <- c("sex", "ldose", "ldose1") + pm <- predict(am, xdata.frame.29.2, trace=trace) + if (trace) print(pm) + stop.if.not.identical("A2-29", pm2.ref, pm) + + cat("A2-29f predict(af, xdata.frame with col names) trace=", trace, "\n", sep="") + pf <- predict(af, xdata.frame.29.2, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A2-29", pm, pf) + + cat("A-31m predict(am, xdata.frame, trace=", trace, ") data frame with factors and wrong col names\n", sep="") + xdata.frame <- data.frame(sex[1], -2, 0.1) + pm <- predict(am, xdata.frame, trace=trace) + stop.if.not.identical("A-31", pm.ref, pm) + if (trace) print(pm) + + cat("A-31f predict(af, xdata.frame, trace=", trace, ") data frame with factors and wrong col names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-31", pm, pf) + + cat("A-31bm predict(am, xdata.frame, trace=", trace, ") data frame col names\n", sep="") + xdata.frame <- data.frame(sex=sex[1], ldose=-2, ldose1=0.1) + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("A-31", pm.ref, pm) + + cat("A-31bf predict(af, xdata.frame, trace=", trace, ") data frame col names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-31b", pm, pf) + + cat("A-32m predict(am, xdata.frame, trace=", trace, ") # data frame with names\n", sep="") + xdata.frame <- data.frame(sex[1], -2, 0.1) + colnames(xdata.frame) <- c("sex", "ldose", "ldose1") + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("A-32", pm, pf) + stop.if.not.identical("A-32", pm.ref, pm) + + cat("A-32f predict(af, xdata.frame, trace=", trace, ") # data frame with names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-32", pm, pf) + + cat("A-42am predict(am, newdata=c(1, -2, 0.1), trace=", trace, ")) use numeric instead of factor sex\n", sep="") + pm <- predict(am, newdata=c(1, -2, 0.1), trace=trace) + if (trace) print(pm) + stop.if.not.identical("A-42a", pm.ref, pm) + + cat("A-42af predict(af, newdata=c(1, -2, 0.1), trace=", trace, ")) use numeric instead of factor sex\n", sep="") + pf <- predict(af, newdata=c(1, -2, 0.1), trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-42a", pm, pf) + + cat("A-43am predict(af, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=", trace, ")) multiple rows as a vec\n", sep="") + pm <- predict(af, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=trace) + if (trace) print(pm) + + cat("A-43af predict(am, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=", trace, ")) multiple rows as a vec\n", sep="") + pf <- predict(am, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-43a", pm, pf) + + cat("A-44am predict(af, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=", trace, ")) more multiple rows as a vec\n", sep="") + pm <- predict(af, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=trace) + if (trace) print(pm) + stop.if.not.identical("A-44a", pm2.ref, pm) + + cat("A-44fm predict(am, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=", trace, ")) more multiple rows as a vec\n", sep="") + pf <- predict(am, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-44f", pm, pf) + + cat("A-53m predict(am, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") + xdata.frame <- data.frame(sex[1], -2) + expect.err(try(predict(am, xdata.frame, trace=trace)), "expected 3") + + cat("A-53f predict(af, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") + xdata.frame <- data.frame(sex[1], -2) + expect.err(try(predict(af, xdata.frame, trace=trace)), "expected 3") + + cat("A-54m predict(am, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") + xdata.frame <- data.frame(-2, sex[1], 0.1) + colnames(xdata.frame) <- c("ldose", "sex", "ldose1") + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("A-54", pm.ref, pm) + + cat("A-54f predict(af, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-54", pm, pf) + + cat("A-55m predict(am, xdata.frame, trace=", trace, ") data frame without col names\n", sep="") + xdata.frame <- data.frame(sex[c(1,7)], c(-2,-1), c(0.1, 0.1)) + pm <- predict(am, xdata.frame, trace=trace) + pm3.ref <- pm + if (trace) print(pm) + + cat("A-55f predict(af, xdata.frame, trace=", trace, ") data frame without col names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-55", pm, pf) + + cat("A-56m predict(am, xdata.frame, trace=", trace, ") # data frame with col names\n", sep="") + xdata.frame <- data.frame(sex[c(1,7)], c(-2,-1), c(0.1, 0.1)) + colnames(xdata.frame) <- c("sex", "ldose", "ldose1") + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("A-56", pm3.ref, pm) + + cat("A-56f predict(af, xdata.frame, trace=", trace, ") # data frame with col names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-56", pm, pf) + + cat("A-57m predict(am, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") + xdata.frame <- data.frame(sex[c(1,7)], c(-2,-1)) + expect.err(try(predict(am, xdata.frame, trace=trace)), "expected 3") + + cat("A-57f predict(af, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") + expect.err(try(predict(af, xdata.frame, trace=trace)), "expected 3") + stop.if.not.identical("A-57", pm, pf) + + cat("A-58m predict(am, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") + xdata.frame <- data.frame(c(-2,-1), sex[c(1,7)], c(0.1, 0.1)) + colnames(xdata.frame) <- c("ldose", "sex", "ldose1") + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("A-58", pm3.ref, pm) + + cat("A-58f predict(af, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-58", pm, pf) + + cat("A-59m predict(am, xdata.frame, trace=", trace, ") numeric where factor expected, expect forge on message\n", sep="") + xdata.frame.39 <- data.frame(c(sex[1], sex[7]), c(-2,-1), c(0.1, 0.1)) + colnames(xdata.frame.39) <- c("sex", "ldose", "ldose1") + pm <- predict(am, xdata.frame.39, trace=trace) + if (trace) print(pm) + # stop.if.not.identical("A-59", pm3.ref, pm) # TODO fails but "forge on" message is correctly issued + + cat("A-59f predict(af, xdata.frame, trace=", trace, ") numeric where factor expected, expect forge on message\n", sep="") + pf <- predict(af, xdata.frame.39, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-59", pm, pf) + + cat("A-50m data frame without column names, trace=", trace, "\n", sep="") + xdata.frame <- data.frame(sex[1], -2, 0.1) + colnames(xdata.frame) <- NULL + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("A-34", pm.ref, pm) + + cat("A-60f data frame without column names, trace=", trace, "\n", sep="") + xdata.frame <- data.frame(sex[1], -2, 0.1) + colnames(xdata.frame) <- NULL + pf <- predict(am, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-60", pm, pf) + + cat("A-61f data frame without extra columns, trace=", trace, "\n", sep="") + xdata.frame <- data.frame(sex=sex[1], extra1=99, ldose=-2, extra2=99, ldose1=0.1, extra3=sex[7]) + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-61", pm, pf) + + #----------------------------------- + + my.x1 <- as.numeric(ToothGrowth[,2]) # supp was VC or OJ + my.x2 <- as.numeric(ToothGrowth[,3]) # dose + my.input.mat <- cbind(my.x1, my.x2) + my.response <- ToothGrowth[,1] + + cat("A-68 input matrix to formula interface trace=", trace, ", expect error \"could not interpret\"\n", sep="") + a41 <- earth(my.response~my.input.mat, trace=trace) + expect.err(try(predict(a41, c(2.1, 0.6), trace=trace)), "could not interpret the data") + + cat("A-69 above test but with properly named dataframe trace=", trace, "\n", sep="") + df <- data.frame(growth=my.response, supp=my.x1, dose=my.x2) + a42 <- earth(formula=growth~., data=df, trace=0) + p <- predict(a42, c(2.1, 0.6), trace=0) # now gives the correct result + if (trace) print(head(p)) + + cat("Tests with not all predictors used in the model so can pass fewer columns\n") + # No factor tests done, they probably won't work in this setup. + + # first for earth.default + dummy <- rep(0, 12) + am <- earth(cbind(ldose, dummy, ldose1), numdead, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) + # prepare reference prediction, using all columns + newdata <- matrix(c(-2, 0, 0.1), ncol=3, nrow=1) + colnames(newdata) <- c("ldose", "dummy", "ldose1") + pm.ref <- predict(am, newdata=newdata, trace=trace) + if (trace) print(pm.ref) + + cat("A-72m predict(am, newdata=newdata[two columns], trace=trace)\n") + newdata <- matrix(c(-2, 0.1), ncol=2, nrow=1) + colnames(newdata) <- c("ldose", "ldose1") + pm <- predict(am, newdata=newdata, trace=trace) + if (trace) print(pm) + stop.if.not.identical("A-72m", pm, pm.ref) + + # prepare reference prediction, using all columns + newdata <- data.frame(cbind(ldose, dummy, ldose1)) + print(newdata) + pm.ref <- predict(am, newdata=newdata, trace=trace) + if (trace) print(pm.ref) + + cat("A-73m predict(am, newdata=newdata[two columns], trace=trace)\n") + newdata <- newdata[, c(1,3)] + pm <- predict(am, newdata=newdata, trace=trace) + if (trace) print(pm) + stop.if.not.identical("A-73m", pm, pm.ref) + + # now for earth.formula + dummy <- rep(0, 12) + af <- earth(numdead ~ ldose + dummy + ldose1, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) + # prepare reference prediction, using all columns + newdata <- matrix(c(-2, 0, 0.1), ncol=3, nrow=1) + colnames(newdata) <- c("ldose", "dummy", "ldose1") + newdata <- as.data.frame(newdata) + pf.ref <- predict(af, newdata=newdata, trace=trace) + if (trace) print(pf.ref) + + cat("A-72f predict(af, newdata=newdata[two columns], trace=trace)\n") + newdata <- matrix(c(-2, 0.1), ncol=2, nrow=1) + colnames(newdata) <- c("ldose", "ldose1") + newdata <- as.data.frame(newdata) + pf <- predict(af, newdata=newdata, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-72f", pf, pf.ref) + + # prepare reference prediction, using all columns + newdata <- data.frame(cbind(ldose, dummy, ldose1)) + print(newdata) + pf.ref <- predict(af, newdata=newdata, trace=trace) + if (trace) print(pf.ref) + + cat("A-73f predict(af, newdata=newdata[two columns], trace=trace)\n") + newdata <- newdata[, c(1,3)] + pf <- predict(af, newdata=newdata, trace=trace) + if (trace) print(pf) + stop.if.not.identical("A-73f", pf, pf.ref) + + cat("\n--- B predict with multiple level factors and a multiple real response, trace=", trace, + " ---\n\n", sep="") + + # note that we can no now longer get away with using numerics for + # factors because factors have more than two levels + + # test set B: prepare the data + + ldose <- rep(0:5, 2) - 2 + ldose1 <- c(0.1, 1.2, 2.3, 3.4, 4.5, 5.6, 0.3, 1.4, 2.5, 3.6, 4.7, 5.8) + sex3 <- factor(rep(c("male", "female", "andro"), times=c(6,4,2))) + fac3 <- factor(c("lev2", "lev2", "lev1", "lev1", "lev3", "lev3", + "lev2", "lev2", "lev1", "lev1", "lev3", "lev3")) + numdead <- c(1,4,9,13,18,20,0,2,6,10,12,16) + numdead2 <- c(2,3,10,13,19,20,0,3,7,11,13,17) + numdeadboth <- cbind(numdead, numdead2) + isex <- as.double(sex3) # sex3 as an index + df <- data.frame(sex3, ldose, ldose1, fac3) + am <- earth(df, numdeadboth, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) + af <- earth(numdeadboth ~ ., data=df, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) + check.models.equal(am, af, "B predict with multiple level factors and a multiple real response") + cat("20m head(predict(am, trace=", trace, ")\n", sep="") + pm <- predict(am, trace=trace) + if (trace) print(head(pm)) + + cat("B-21f head(predict(af, trace=", trace, ")\n", sep="") + pf <- predict(af, trace=trace) + if (trace) print(head(pf)) + stop.if.not.identical("B-20", pm, pf) + + cat("B-31m predict(am, xdata.frame, trace=", trace, ") data frame with factors and wrong col names\n", sep="") + xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) + pm <- predict(am, xdata.frame, trace=trace) + pm.ref <- pm + stop.if.not.identical("B-31", pm.ref, pm) + if (trace) print(pm) + + cat("B-31f predict(af, xdata.frame, trace=", trace, ") data frame with factors and wrong col names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("B-31", pm, pf) + + cat("B-31bm predict(am, xdata.frame, trace=", trace, ") data frame col names\n", sep="") + xdata.frame <- data.frame(sex3=sex3[1], ldose=-2, ldose1=0.1, fac3=fac3[1]) + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("B-31", pm.ref, pm) + + cat("B-31bf predict(af, xdata.frame, trace=", trace, ") data frame col names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("B-31b", pm, pf) + + cat("B-32m predict(am, xdata.frame, trace=", trace, ") # data frame with names\n", sep="") + xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) + colnames(xdata.frame) <- c("sex3", "ldose", "ldose1", "fac3") + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("B-32", pm, pf) + stop.if.not.identical("B-32", pm.ref, pm) + + cat("B-32f predict(af, xdata.frame, trace=", trace, ") # data frame with names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("B-32", pm, pf) + + cat("B-53m predict(am, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") + xdata.frame <- data.frame(sex3[1], -2) + expect.err(try(predict(am, xdata.frame, trace=trace)), "get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4") + + cat("B-53f predict(af, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") + expect.err(try(predict(af, xdata.frame, trace=trace)), "get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4") + + cat("B-54m predict(am, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") + xdata.frame <- data.frame(-2, sex3[1], 0.1, fac3[1]) + colnames(xdata.frame) <- c("ldose", "sex3", "ldose1", "fac3") + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("B-54", pm.ref, pm) + + cat("B-54f predict(af, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("B-54", pm, pf) + + cat("B-55m predict(am, xdata.frame, trace=", trace, ") data frame without col names\n", sep="") + xdata.frame <- data.frame(sex3[c(1,7)], c(-2,-1), c(0.1, 0.1), fac3[c(1,9)]) + pm <- predict(am, xdata.frame, trace=trace) + pm3.ref <- pm + if (trace) print(pm) + cat("B-55m again, but with same x data for both reponses\n") + xdata.frame <- data.frame(sex3[c(1,1)], c(-2,-2), c(0.1, 0.1), fac3[c(1,1)]) + pm <- predict(am, xdata.frame, trace=trace) + print(pm) + + cat("B-55f predict(af, xdata.frame, trace=", trace, ") data frame without col names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("B-55", pm, pf) + + cat("B2-55bm predict(am, xdata.frame, trace=", trace, ") data frame col names\n", sep="") + xdata.frame <- data.frame(sex3=sex3[c(1,7)], ldose=c(-2,-1), ldose1=c(0.1,0.1), fac3=fac3[c(1,9)]) + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("B2-55", pm3.ref, pm) + + cat("B2-55bf predict(af, xdata.frame, trace=", trace, ") data frame col names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("B2-55b", pm, pf) + + cat("B-56m predict(am, xdata.frame, trace=", trace, ") # data frame with col names\n", sep="") + xdata.frame <- data.frame(sex3[c(1,7)], c(-2,-1), c(0.1, 0.1), fac3[c(1,9)]) + colnames(xdata.frame) <- c("sex3", "ldose", "ldose1", "fac3") + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("B-56", pm3.ref, pm) + + cat("B-56f predict(af, xdata.frame, trace=", trace, ") # data frame with col names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("B-56", pm, pf) + + cat("B-57m predict(am, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") + xdata.frame <- data.frame(sex3[c(1,7)], c(-2,-1)) + expect.err(try(predict(am, xdata.frame, trace=trace)), "get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4") + + cat("B-57f predict(af, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") + expect.err(try(predict(af, xdata.frame, trace=trace)), "get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4") + stop.if.not.identical("B-57", pm, pf) + + cat("B-58m predict(am, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") + xdata.frame <- data.frame(c(-2,-1), sex3[c(1,7)], c(0.1, 0.1), fac3[c(1,9)]) + colnames(xdata.frame) <- c("ldose", "sex3", "ldose1", "fac3") + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("B-58", pm3.ref, pm) + + cat("B-58f predict(af, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("B-58", pm, pf) + + cat("B-50m data frame without column names, trace=", trace, "\n", sep="") + xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) + colnames(xdata.frame) <- NULL + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("B-34", pm.ref, pm) + + cat("B-60f data frame without column names, trace=", trace, "\n", sep="") + xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) + colnames(xdata.frame) <- NULL + pf <- predict(am, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("B-60", pm, pf) + + cat("B-60f data frame without extra columns, trace=", trace, "\n", sep="") + xdata.frame <- data.frame(sex3=sex3[1], extra1=99, ldose=-2, extra2=99, + ldose1=0.1, fac3=fac3[1], extra3=sex3[7]) + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("B-60f", pm, pf) + + cat("\n--- C predict with multiple level factors and a 3 level factor response, trace=", trace, + " ---\n\n", sep="") + + # test set C: prepare the data + + ldose <- rep(0:5, 2) - 2 + ldose1 <- c(0.1, 1.2, 2.3, 3.4, 4.5, 5.6, 0.3, 1.4, 2.5, 3.6, 4.7, 5.8) + sex3 <- factor(rep(c("male", "female", "andro"), times=c(6,4,2))) + fac3 <- factor(c("lev2", "lev2", "lev1", "lev1", "lev3", "lev3", + "lev2", "lev2", "lev1", "lev1", "lev3", "lev3")) + facdead <- factor(c("dead2", "dead2", "dead3", "dead1", "dead3", "dead3", + "dead1", "dead2", "dead1", "dead1", "dead3", "dead3")) + + isex <- as.double(sex3) # sex3 as an index + df <- data.frame(sex3=sex3, ldose=ldose, ldose1=ldose1, fac3=fac3) + am <- earth(df, facdead, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) + df.with.response <- data.frame(sex3=sex3, ldose=ldose, ldose1=ldose1, facdead=facdead, fac3=fac3) + af <- earth(facdead ~ ., data=df.with.response, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) + check.models.equal(am, af, "C predict with multiple level factors and a multiple real response") + cat("20m head(predict(am, trace=", trace, ")\n", sep="") + pm <- predict(am, trace=trace) + if (trace) print(head(pm)) + + cat("C-21f head(predict(af, trace=", trace, ")\n", sep="") + pf <- predict(af, trace=trace) + if (trace) print(head(pf)) + stop.if.not.identical("C-20", pm, pf) + + cat("C-31m predict(am, xdata.frame, trace=", trace, ") data frame with factors and wrong col names\n", sep="") + xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) + pm <- predict(am, xdata.frame, trace=trace) + pm.ref <- pm + stop.if.not.identical("C-31", pm.ref, pm) + if (trace) print(pm) + + cat("C-31f predict(af, xdata.frame, trace=", trace, ") data frame with factors and wrong col names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("C-31", pm, pf) + + cat("C-31bm predict(am, xdata.frame, trace=", trace, ") data frame col names\n", sep="") + xdata.frame <- data.frame(sex3=sex3[1], ldose=-2, ldose1=0.1, fac3=fac3[1]) + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("C-31", pm.ref, pm) + + cat("C-31bf predict(af, xdata.frame, trace=", trace, ") data frame col names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("C-31b", pm, pf) + + cat("C-32m predict(am, xdata.frame, trace=", trace, ") # data frame with names\n", sep="") + xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) + colnames(xdata.frame) <- c("sex3", "ldose", "ldose1", "fac3") + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("C-32", pm, pf) + stop.if.not.identical("C-32", pm.ref, pm) + + cat("C-32f predict(af, xdata.frame, trace=", trace, ") # data frame with names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("C-32", pm, pf) + + cat("C-53m predict(am, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") + xdata.frame <- data.frame(sex3[1], -2) + expect.err(try(predict(am, xdata.frame, trace=trace)), "get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4") + + cat("C-53f predict(af, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") + expect.err(try(predict(af, xdata.frame, trace=trace)), "get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4") + + cat("C-54m predict(am, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") + xdata.frame <- data.frame(-2, sex3[1], 0.1, fac3[1]) + colnames(xdata.frame) <- c("ldose", "sex3", "ldose1", "fac3") + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("C-54", pm.ref, pm) + + cat("C-54f predict(af, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("C-54", pm, pf) + + cat("C-55m predict(am, xdata.frame, trace=", trace, ") data frame without col names\n", sep="") + xdata.frame <- data.frame(sex3[c(1,7)], c(-2,-1), c(0.1, 0.1), fac3[c(1,9)]) + pm <- predict(am, xdata.frame, trace=trace) + pm3.ref <- pm + if (trace) print(pm) + + cat("C-55f predict(af, xdata.frame, trace=", trace, ") data frame without col names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("C-55", pm, pf) + + cat("C2-55bm predict(am, xdata.frame, trace=", trace, ") data frame col names\n", sep="") + xdata.frame <- data.frame(sex3=sex3[c(1,7)], ldose=c(-2,-1), ldose1=c(0.1,0.1), fac3=fac3[c(1,9)]) + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("C2-55", pm3.ref, pm) + + cat("C2-55bf predict(af, xdata.frame, trace=", trace, ") data frame col names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("C2-55b", pm, pf) + + cat("C-56m predict(am, xdata.frame, trace=", trace, ") # data frame with col names\n", sep="") + xdata.frame <- data.frame(sex3[c(1,7)], c(-2,-1), c(0.1, 0.1), fac3[c(1,9)]) + colnames(xdata.frame) <- c("sex3", "ldose", "ldose1", "fac3") + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("C-56", pm3.ref, pm) + + cat("C-56f predict(af, xdata.frame, trace=", trace, ") # data frame with col names\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("C-56", pm, pf) + + cat("C-57m predict(am, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") + xdata.frame <- data.frame(sex3[c(1,7)], c(-2,-1)) + expect.err(try(predict(am, xdata.frame, trace=trace)), "get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4") + + cat("C-57f predict(af, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") + expect.err(try(predict(af, xdata.frame, trace=trace)), "has 2 columns") + stop.if.not.identical("C-57", pm, pf) + + cat("C-58m predict(am, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") + xdata.frame <- data.frame(c(-2,-1), sex3[c(1,7)], c(0.1, 0.1), fac3[c(1,9)]) + colnames(xdata.frame) <- c("ldose", "sex3", "ldose1", "fac3") + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("C-58", pm3.ref, pm) + + cat("C-58f predict(af, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("C-58", pm, pf) + + cat("C-50m data frame without column names, trace=", trace, "\n", sep="") + xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) + colnames(xdata.frame) <- NULL + pm <- predict(am, xdata.frame, trace=trace) + if (trace) print(pm) + stop.if.not.identical("C-34", pm.ref, pm) + + cat("C-60f data frame without column names, trace=", trace, "\n", sep="") + xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) + colnames(xdata.frame) <- NULL + pf <- predict(am, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("C-60", pm, pf) + + cat("C-61f data frame without extra columns, trace=", trace, "\n", sep="") + xdata.frame <- data.frame(sex3=sex3[1], extra1=99, ldose=-2, extra2=99, + ldose1=0.1, fac3=fac3[1], extra3=sex3[7]) + pf <- predict(af, xdata.frame, trace=trace) + if (trace) print(pf) + stop.if.not.identical("C-61", pm, pf) + } > test.predict.with.factors(trace=1) --- predict with single level factors and a single response, trace=1 --- first do a quick test of predict.earth help page example predict.earth: returning earth fitted.values Volume [1,] 8.883097 [2,] 9.909039 [3,] 10.593000 [4,] 16.406671 [5,] 20.578818 [6,] 22.083528 get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[1,2]: Girth Height 1 10 80 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,2]: Girth Height 1 10 80 predict.earth with newdata: bx[1,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 predict.earth: returning earth predictions Volume [1,] 17.60359 x[12,3] with colnames sexmale ldose ldose1 y[12,1] with colname numdead, and values 1, 4, 9, 13, 18, 20, 0, 2, 6,... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.935 RSq 0.981 Prune none penalty 3 nprune null: selected 3 of 3 terms, and 2 of 3 preds After pruning pass GRSq 0.935 RSq 0.981 x[12,3] with colnames sexmale ldose ldose1 y[12,1] with colname numdead, and values 1, 4, 9, 13, 18, 20, 0, 2, 6,... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.935 RSq 0.981 Prune none penalty 3 nprune null: selected 3 of 3 terms, and 2 of 3 preds After pruning pass GRSq 0.935 RSq 0.981 predict with single level factors and a single response: models not identical Formulas differ: Error in formula.default(mod1) : invalid formula and: numdead ~ sex + ldose + ldose1 predict with single level factors and a single response: Models are equivalent, within numerical tolerances A-20m head(predict(am, trace=1) predict.earth: returning earth fitted.values numdead [1,] 1.726190 [2,] 5.369048 [3,] 9.011905 [4,] 12.654762 [5,] 16.297619 [6,] 19.940476 A-20f head(predict(af, trace=1) predict.earth: returning earth fitted.values numdead [1,] 1.726190 [2,] 5.369048 [3,] 9.011905 [4,] 12.654762 [5,] 16.297619 [6,] 19.940476 A-20 identical A-21m predict(am, newdata=c(sex[1], -2, 0.1), trace=1)) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sexmale ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sexmale ldose ldose1 1 1 -2 0.1 predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-21f predict(af, newdata=c(sex[1], -2, 0.1), trace=1)) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sex ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sex ldose ldose1 1 1 -2 0.1 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,3]: sex ldose ldose1 1 1 -2 0.1 Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 1 -2 0.1 predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-21 identical A-22m predict(am, newdata=c(1, -2, 0.1), trace=1)) use numeric instead of factor sex get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sexmale ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sexmale ldose ldose1 1 1 -2 0.1 predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-22 identical A-22f predict(af, newdata=c(1, -2, 0.1), trace=1)) use numeric instead of factor sex get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sex ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sex ldose ldose1 1 1 -2 0.1 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,3]: sex ldose ldose1 1 1 -2 0.1 Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 1 -2 0.1 predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-22 identical A-23m predict(am, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=1)) multiple rows as a vec get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sexmale ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sexmale ldose ldose1 1 2 -2 0.1 2 2 -2 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -2 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 4.892857 A-23f predict(af, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=1)) multiple rows as a vec get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sex ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -2 0.1 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -2 0.1 Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -2 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -2 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 4.892857 A-23 identical A-24m predict(am, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=1)) more multiple rows as a vec get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sexmale ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sexmale ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -1 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 8.535714 A-24f predict(af, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=1)) more multiple rows as a vec get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sex ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -1 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 8.535714 A-24 identical A-25m predict(am, xpredict matrix trace=1 get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sexmale ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sexmale ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -1 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 8.535714 A-25 identical A-25f predict(af, xpredict matrix trace=1 get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sex ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -1 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 8.535714 A-25 identical A-26m predict(am, new.data with col names) trace=1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -1 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 8.535714 A-26m identical A-26f predict(af, new.data with col names) trace=1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -1 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 8.535714 A-26f identical A-27m predict(am, new.data with out of order col names) trace=1 get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: sex ldose1 ldose New columns: sexmale ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -1 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 8.535714 A-27 identical A-27f predict(af, new.data with out of order col names) trace=1 get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: sex ldose1 ldose New columns: sex ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -1 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 8.535714 A-27 identical A-28m predict(am, xdata.frame without col names) trace=1 numdead [1,] 4.892857 [2,] 8.535714 A-28 identical A-28f predict(af, xdata.frame without col names) trace=1 get.earth.x from model.matrix.earth from predict.earth: unexpected x column names, renaming columns Old names: c.sex.1...sex.1.. c..2...1. c.0.1..0.1. New names: sex ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -1 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 8.535714 A-28 identical A-29m predict(am, xdata.frame with col names) trace=1 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sex ldose ldose1 1 male -2 0.1 sex is a factor with levels: female male predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-29 identical A-29f predict(af, xdata.frame with col names) trace=1 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sex ldose ldose1 1 male -2 0.1 sex is a factor with levels: female male get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,3]: sex ldose ldose1 1 male -2 0.1 sex is a factor with levels: female male predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-29 identical A2-29m predict(am, xdata.frame with col names) trace=1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -1 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 8.535714 A2-29 identical A2-29f predict(af, xdata.frame with col names) trace=1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -1 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 8.535714 A2-29 identical A-31m predict(am, xdata.frame, trace=1) data frame with factors and wrong col names get.earth.x from model.matrix.earth from predict.earth: unexpected x column names, renaming columns Old names: sex.1. X.2 X0.1 New names: sexmale ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sexmale ldose ldose1 1 male -2 0.1 sexmale is a factor with levels: female male predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions A-31 identical numdead [1,] 1.72619 A-31f predict(af, xdata.frame, trace=1) data frame with factors and wrong col names get.earth.x from model.matrix.earth from predict.earth: unexpected x column names, renaming columns Old names: sex.1. X.2 X0.1 New names: sex ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sex ldose ldose1 1 male -2 0.1 sex is a factor with levels: female male get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,3]: sex ldose ldose1 1 male -2 0.1 sex is a factor with levels: female male predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-31 identical A-31bm predict(am, xdata.frame, trace=1) data frame col names get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sex ldose ldose1 1 male -2 0.1 sex is a factor with levels: female male predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-31 identical A-31bf predict(af, xdata.frame, trace=1) data frame col names get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sex ldose ldose1 1 male -2 0.1 sex is a factor with levels: female male get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,3]: sex ldose ldose1 1 male -2 0.1 sex is a factor with levels: female male predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-31b identical A-32m predict(am, xdata.frame, trace=1) # data frame with names get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sex ldose ldose1 1 male -2 0.1 sex is a factor with levels: female male predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-32 identical A-32 identical A-32f predict(af, xdata.frame, trace=1) # data frame with names get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sex ldose ldose1 1 male -2 0.1 sex is a factor with levels: female male get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,3]: sex ldose ldose1 1 male -2 0.1 sex is a factor with levels: female male predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-32 identical A-42am predict(am, newdata=c(1, -2, 0.1), trace=1)) use numeric instead of factor sex get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sexmale ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sexmale ldose ldose1 1 1 -2 0.1 predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-42a identical A-42af predict(af, newdata=c(1, -2, 0.1), trace=1)) use numeric instead of factor sex get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sex ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sex ldose ldose1 1 1 -2 0.1 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,3]: sex ldose ldose1 1 1 -2 0.1 Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 1 -2 0.1 predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-42a identical A-43am predict(af, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=1)) multiple rows as a vec get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sex ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -2 0.1 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -2 0.1 Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -2 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -2 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 4.892857 A-43af predict(am, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=1)) multiple rows as a vec get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sexmale ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sexmale ldose ldose1 1 2 -2 0.1 2 2 -2 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -2 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 4.892857 A-43a identical A-44am predict(af, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=1)) more multiple rows as a vec get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sex ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,3]: sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -1 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 8.535714 A-44a identical A-44fm predict(am, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=1)) more multiple rows as a vec get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sexmale ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sexmale ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -1 2 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 8.535714 A-44f identical A-53m predict(am, xdata.frame, trace=1) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 3 column names: sex.1. X.2 expected column names: sexmale ldose ldose1 Got error as expected from try(predict(am, xdata.frame, trace = trace)) A-53f predict(af, xdata.frame, trace=1) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 3 column names: sex.1. X.2 expected column names: sex ldose ldose1 Got error as expected from try(predict(af, xdata.frame, trace = trace)) A-54m predict(am, xdata.frame, trace=1) # data frame with cols in different order get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: ldose sex ldose1 New columns: sexmale ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sex ldose ldose1 1 male -2 0.1 sex is a factor with levels: female male predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-54 identical A-54f predict(af, xdata.frame, trace=1) # data frame with cols in different order get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: ldose sex ldose1 New columns: sex ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sex ldose ldose1 1 male -2 0.1 sex is a factor with levels: female male get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,3]: sex ldose ldose1 1 male -2 0.1 sex is a factor with levels: female male predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-54 identical A-55m predict(am, xdata.frame, trace=1) data frame without col names get.earth.x from model.matrix.earth from predict.earth: unexpected x column names, renaming columns Old names: sex.c.1..7.. c..2...1. c.0.1..0.1. New names: sexmale ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sexmale ldose ldose1 1 male -2 0.1 2 female -1 0.1 sexmale is a factor with levels: female male predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 1 2 1 -1 0 predict.earth: returning earth predictions numdead [1,] 1.726190 [2,] 2.202381 A-55f predict(af, xdata.frame, trace=1) data frame without col names get.earth.x from model.matrix.earth from predict.earth: unexpected x column names, renaming columns Old names: sex.c.1..7.. c..2...1. c.0.1..0.1. New names: sex ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 male -2 0.1 2 female -1 0.1 sex is a factor with levels: female male get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,3]: sex ldose ldose1 1 male -2 0.1 2 female -1 0.1 sex is a factor with levels: female male predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 1 2 1 -1 0 predict.earth: returning earth predictions numdead [1,] 1.726190 [2,] 2.202381 A-55 identical A-56m predict(am, xdata.frame, trace=1) # data frame with col names get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 male -2 0.1 2 female -1 0.1 sex is a factor with levels: female male predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 1 2 1 -1 0 predict.earth: returning earth predictions numdead [1,] 1.726190 [2,] 2.202381 A-56 identical A-56f predict(af, xdata.frame, trace=1) # data frame with col names get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 male -2 0.1 2 female -1 0.1 sex is a factor with levels: female male get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,3]: sex ldose ldose1 1 male -2 0.1 2 female -1 0.1 sex is a factor with levels: female male predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 1 2 1 -1 0 predict.earth: returning earth predictions numdead [1,] 1.726190 [2,] 2.202381 A-56 identical A-57m predict(am, xdata.frame, trace=1) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 3 column names: sex.c.1..7.. c..2...1. expected column names: sexmale ldose ldose1 Got error as expected from try(predict(am, xdata.frame, trace = trace)) A-57f predict(af, xdata.frame, trace=1) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 3 column names: sex.c.1..7.. c..2...1. expected column names: sex ldose ldose1 Got error as expected from try(predict(af, xdata.frame, trace = trace)) A-57 identical A-58m predict(am, xdata.frame, trace=1) # data frame with cols in different order get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: ldose sex ldose1 New columns: sexmale ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 male -2 0.1 2 female -1 0.1 sex is a factor with levels: female male predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 1 2 1 -1 0 predict.earth: returning earth predictions numdead [1,] 1.726190 [2,] 2.202381 A-58 identical A-58f predict(af, xdata.frame, trace=1) # data frame with cols in different order get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: ldose sex ldose1 New columns: sex ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 male -2 0.1 2 female -1 0.1 sex is a factor with levels: female male get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,3]: sex ldose ldose1 1 male -2 0.1 2 female -1 0.1 sex is a factor with levels: female male predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 1 2 1 -1 0 predict.earth: returning earth predictions numdead [1,] 1.726190 [2,] 2.202381 A-58 identical A-59m predict(am, xdata.frame, trace=1) numeric where factor expected, expect forge on message get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 2 -2 0.1 2 1 -1 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -1 1 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 5.369048 A-59f predict(af, xdata.frame, trace=1) numeric where factor expected, expect forge on message get.earth.x from model.matrix.earth from predict.earth: x[2,3]: sex ldose ldose1 1 2 -2 0.1 2 1 -1 0.1 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,3]: sex ldose ldose1 1 2 -2 0.1 2 1 -1 0.1 Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 1 -1 0.1 predict.earth with newdata: bx[2,3]: (Intercept) ldose sexmale 1 1 -2 2 2 1 -1 1 predict.earth: returning earth predictions numdead [1,] 4.892857 [2,] 5.369048 A-59 identical A-50m data frame without column names, trace=1 get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sexmale ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sexmale ldose ldose1 1 male -2 0.1 sexmale is a factor with levels: female male predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-34 identical A-60f data frame without column names, trace=1 get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sexmale ldose ldose1 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: sexmale ldose ldose1 1 male -2 0.1 sexmale is a factor with levels: female male predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-60 identical A-61f data frame without extra columns, trace=1 get.earth.x from model.matrix.earth from predict.earth: x[1,6]: sex extra1 ldose extra2 ldose1 extra3 1 male 99 -2 99 0.1 female factors: sex extra3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,3]: sex ldose ldose1 1 male -2 0.1 sex is a factor with levels: female male predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 -2 1 predict.earth: returning earth predictions numdead [1,] 1.72619 A-61 identical A-68 input matrix to formula interface trace=1, expect error "could not interpret" x[60,2] with colnames my.input.matmy.x1 my.input.matmy.x2 y[60,1] with colname my.response, and values 4.2, 11.5, 7.3, 5.8, 6.4, 10,... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 4 terms used (DeltaRSq 0) After forward pass GRSq 0.682 RSq 0.762 Prune backward penalty 2 nprune null: selected 4 of 4 terms, and 2 of 2 preds After pruning pass GRSq 0.705 RSq 0.762 get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: my.x1 my.x2 get.earth.x from model.matrix.earth from predict.earth: x[1,2]: my.x1 my.x2 1 2.1 0.6 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[60,1]: my.input.mat.my.x1 my.input.mat.my.x2 1 2.0 0.5 2 2.0 0.5 3 2.0 0.5 ... 2.0 0.5 60 1.0 2.0 Error : model.frame.default could not interpret the data passed to get.earth.x from model.matrix.earth from predict.earth (actual.nrows=60 expected.nrows=1 fitted.nrows=60) Got error as expected from try(predict(a41, c(2.1, 0.6), trace = trace)) A-69 above test but with properly named dataframe trace=1 growth [1,] 10.211 Tests with not all predictors used in the model so can pass fewer columns x[12,3] with colnames ldose dummy ldose1 y[12,1] with colname numdead, and values 1, 4, 9, 13, 18, 20, 0, 2, 6,... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.745 RSq 0.924 Prune none penalty 3 nprune null: selected 3 of 3 terms, and 2 of 3 preds After pruning pass GRSq 0.745 RSq 0.924 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: ldose dummy ldose1 1 -2 0 0.1 predict.earth with newdata: bx[1,3]: (Intercept) ldose ldose*ldose1 1 1 -2 -0.2 predict.earth: returning earth predictions numdead [1,] 0.4686592 A-72m predict(am, newdata=newdata[two columns], trace=trace) get.earth.x from model.matrix.earth from predict.earth: x has missing columns, creating a new x with all cols get.earth.x from model.matrix.earth from predict.earth: x[1,3]: ldose dummy ldose1 1 -2 NA 0.1 predict.earth with newdata: bx[1,3]: (Intercept) ldose ldose*ldose1 1 1 -2 -0.2 predict.earth: returning earth predictions numdead [1,] 0.4686592 A-72m identical ldose dummy ldose1 1 -2 0 0.1 2 -1 0 1.2 3 0 0 0.1 4 1 0 1.2 5 2 0 1.0 6 3 0 0.1 7 -2 0 0.3 8 -1 0 1.4 9 0 0 0.1 10 1 0 1.2 11 2 0 0.1 12 3 0 0.9 get.earth.x from model.matrix.earth from predict.earth: x[12,3]: ldose dummy ldose1 1 -2 0 0.1 2 -1 0 1.2 3 0 0 0.1 ... 1 0 1.2 12 3 0 0.9 predict.earth with newdata: bx[12,3]: (Intercept) ldose ldose*ldose1 1 1 -2 -0.2 2 1 -1 -1.2 3 1 0 0.0 ... 1 1 1.2 12 1 3 2.7 predict.earth: returning earth predictions numdead [1,] 0.4686592 [2,] 3.4356368 [3,] 7.3864088 [4,] 11.3371809 [5,] 15.1090812 [6,] 17.7630332 [7,] 0.2897875 [8,] 3.3462009 [9,] 7.3864088 [10,] 11.3371809 [11,] 14.3041584 [12,] 18.8362636 A-73m predict(am, newdata=newdata[two columns], trace=trace) get.earth.x from model.matrix.earth from predict.earth: x has missing columns, creating a new x with all cols get.earth.x from model.matrix.earth from predict.earth: x[12,3]: ldose dummy ldose1 1 -2 NA 0.1 2 -1 NA 1.2 3 0 NA 0.1 ... 1 NA 1.2 12 3 NA 0.9 predict.earth with newdata: bx[12,3]: (Intercept) ldose ldose*ldose1 1 1 -2 -0.2 2 1 -1 -1.2 3 1 0 0.0 ... 1 1 1.2 12 1 3 2.7 predict.earth: returning earth predictions numdead [1,] 0.4686592 [2,] 3.4356368 [3,] 7.3864088 [4,] 11.3371809 [5,] 15.1090812 [6,] 17.7630332 [7,] 0.2897875 [8,] 3.3462009 [9,] 7.3864088 [10,] 11.3371809 [11,] 14.3041584 [12,] 18.8362636 A-73m identical x[12,3] with colnames ldose dummy ldose1 y[12,1] with colname numdead, and values 1, 4, 9, 13, 18, 20, 0, 2, 6,... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.745 RSq 0.924 Prune none penalty 3 nprune null: selected 3 of 3 terms, and 2 of 3 preds After pruning pass GRSq 0.745 RSq 0.924 get.earth.x from model.matrix.earth from predict.earth: x[1,3]: ldose dummy ldose1 1 -2 0 0.1 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,3]: ldose dummy ldose1 1 -2 0 0.1 predict.earth with newdata: bx[1,3]: (Intercept) ldose ldose*ldose1 1 1 -2 -0.2 predict.earth: returning earth predictions numdead [1,] 0.4686592 A-72f predict(af, newdata=newdata[two columns], trace=trace) get.earth.x from model.matrix.earth from predict.earth: x has missing columns, creating a new x with all cols get.earth.x from model.matrix.earth from predict.earth: x[1,3]: ldose dummy ldose1 1 -2 NA 0.1 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,3]: ldose dummy ldose1 1 -2 NA 0.1 predict.earth with newdata: bx[1,3]: (Intercept) ldose ldose*ldose1 1 1 -2 -0.2 predict.earth: returning earth predictions numdead [1,] 0.4686592 A-72f identical ldose dummy ldose1 1 -2 0 0.1 2 -1 0 1.2 3 0 0 0.1 4 1 0 1.2 5 2 0 1.0 6 3 0 0.1 7 -2 0 0.3 8 -1 0 1.4 9 0 0 0.1 10 1 0 1.2 11 2 0 0.1 12 3 0 0.9 get.earth.x from model.matrix.earth from predict.earth: x[12,3]: ldose dummy ldose1 1 -2 0 0.1 2 -1 0 1.2 3 0 0 0.1 ... 1 0 1.2 12 3 0 0.9 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[12,3]: ldose dummy ldose1 1 -2 0 0.1 2 -1 0 1.2 3 0 0 0.1 ... 1 0 1.2 12 3 0 0.9 predict.earth with newdata: bx[12,3]: (Intercept) ldose ldose*ldose1 1 1 -2 -0.2 2 1 -1 -1.2 3 1 0 0.0 ... 1 1 1.2 12 1 3 2.7 predict.earth: returning earth predictions numdead [1,] 0.4686592 [2,] 3.4356368 [3,] 7.3864088 [4,] 11.3371809 [5,] 15.1090812 [6,] 17.7630332 [7,] 0.2897875 [8,] 3.3462009 [9,] 7.3864088 [10,] 11.3371809 [11,] 14.3041584 [12,] 18.8362636 A-73f predict(af, newdata=newdata[two columns], trace=trace) get.earth.x from model.matrix.earth from predict.earth: x has missing columns, creating a new x with all cols get.earth.x from model.matrix.earth from predict.earth: x[12,3]: ldose dummy ldose1 1 -2 NA 0.1 2 -1 NA 1.2 3 0 NA 0.1 ... 1 NA 1.2 12 3 NA 0.9 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[12,3]: ldose dummy ldose1 1 -2 NA 0.1 2 -1 NA 1.2 3 0 NA 0.1 ... 1 NA 1.2 12 3 NA 0.9 predict.earth with newdata: bx[12,3]: (Intercept) ldose ldose*ldose1 1 1 -2 -0.2 2 1 -1 -1.2 3 1 0 0.0 ... 1 1 1.2 12 1 3 2.7 predict.earth: returning earth predictions numdead [1,] 0.4686592 [2,] 3.4356368 [3,] 7.3864088 [4,] 11.3371809 [5,] 15.1090812 [6,] 17.7630332 [7,] 0.2897875 [8,] 3.3462009 [9,] 7.3864088 [10,] 11.3371809 [11,] 14.3041584 [12,] 18.8362636 A-73f identical --- B predict with multiple level factors and a multiple real response, trace=1 --- x[12,6] with colnames sex3female sex3male ldose ldose1 fac3lev2 fac3lev3 y[12,2] with colnames numdead numdead2 Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.763 RSq 0.976 Prune none penalty 3 nprune null: selected 4 of 4 terms, and 2 of 6 preds After pruning pass GRSq 0.763 RSq 0.976 x[12,6] with colnames sex3female sex3male ldose ldose1 fac3lev2 fac3lev3 y[12,2] with colnames numdead numdead2 Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.763 RSq 0.976 Prune none penalty 3 nprune null: selected 4 of 4 terms, and 2 of 6 preds After pruning pass GRSq 0.763 RSq 0.976 B predict with multiple level factors and a multiple real response: models not identical Formulas differ: Error in formula.default(mod1) : invalid formula and: numdeadboth ~ sex3 + ldose + ldose1 + fac3 B predict with multiple level factors and a multiple real response: Models are equivalent, within numerical tolerances 20m head(predict(am, trace=1) predict.earth: returning earth fitted.values numdead numdead2 [1,] 1.577732 1.587702 [2,] 5.369367 5.595869 [3,] 9.161001 9.604036 [4,] 12.751499 13.214895 [5,] 16.297300 16.737465 [6,] 19.843100 20.260034 B-21f head(predict(af, trace=1) predict.earth: returning earth fitted.values numdead numdead2 [1,] 1.577732 1.587702 [2,] 5.369367 5.595869 [3,] 9.161001 9.604036 [4,] 12.751499 13.214895 [5,] 16.297300 16.737465 [6,] 19.843100 20.260034 B-20 identical B-31m predict(am, xdata.frame, trace=1) data frame with factors and wrong col names get.earth.x from model.matrix.earth from predict.earth: unexpected x column names, renaming columns Old names: sex3.1. X.2 X0.1 fac3.1. New names: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 predict.earth: returning earth predictions B-31 identical numdead numdead2 [1,] 1.577732 1.587702 B-31f predict(af, xdata.frame, trace=1) data frame with factors and wrong col names get.earth.x from model.matrix.earth from predict.earth: unexpected x column names, renaming columns Old names: sex3.1. X.2 X0.1 fac3.1. New names: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 B-31 identical B-31bm predict(am, xdata.frame, trace=1) data frame col names get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 B-31 identical B-31bf predict(af, xdata.frame, trace=1) data frame col names get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 B-31b identical B-32m predict(am, xdata.frame, trace=1) # data frame with names get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 B-32 identical B-32 identical B-32f predict(af, xdata.frame, trace=1) # data frame with names get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 B-32 identical B-53m predict(am, xdata.frame, trace=1) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.1. X.2 expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(am, xdata.frame, trace = trace)) B-53f predict(af, xdata.frame, trace=1) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.1. X.2 expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(af, xdata.frame, trace = trace)) B-54m predict(am, xdata.frame, trace=1) # data frame with cols in different order get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: ldose sex3 ldose1 fac3 New columns: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 B-54 identical B-54f predict(af, xdata.frame, trace=1) # data frame with cols in different order get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: ldose sex3 ldose1 fac3 New columns: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 B-54 identical B-55m predict(am, xdata.frame, trace=1) data frame without col names get.earth.x from model.matrix.earth from predict.earth: unexpected x column names, renaming columns Old names: sex3.c.1..7.. c..2...1. c.0.1..0.1. fac3.c.1..9.. New names: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 2 1 -1 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 [2,] 22.663117 20.019737 B-55m again, but with same x data for both reponses get.earth.x from model.matrix.earth from predict.earth: unexpected x column names, renaming columns Old names: sex3.c.1..1.. c..2...2. c.0.1..0.1. fac3.c.1..1.. New names: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 2 1 -2 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 [2,] 1.577732 1.587702 B-55f predict(af, xdata.frame, trace=1) data frame without col names get.earth.x from model.matrix.earth from predict.earth: unexpected x column names, renaming columns Old names: sex3.c.1..1.. c..2...2. c.0.1..0.1. fac3.c.1..1.. New names: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 male -2 0.1 lev2 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 2 1 -2 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 [2,] 1.577732 1.587702 B-55 identical B2-55bm predict(am, xdata.frame, trace=1) data frame col names get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 2 1 -1 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 [2,] 22.663117 20.019737 B2-55 identical B2-55bf predict(af, xdata.frame, trace=1) data frame col names get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 2 1 -1 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 [2,] 22.663117 20.019737 B2-55b identical B-56m predict(am, xdata.frame, trace=1) # data frame with col names get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 2 1 -1 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 [2,] 22.663117 20.019737 B-56 identical B-56f predict(af, xdata.frame, trace=1) # data frame with col names get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 2 1 -1 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 [2,] 22.663117 20.019737 B-56 identical B-57m predict(am, xdata.frame, trace=1) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.c.1..7.. c..2...1. expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(am, xdata.frame, trace = trace)) B-57f predict(af, xdata.frame, trace=1) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.c.1..7.. c..2...1. expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(af, xdata.frame, trace = trace)) B-57 identical B-58m predict(am, xdata.frame, trace=1) # data frame with cols in different order get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: ldose sex3 ldose1 fac3 New columns: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 2 1 -1 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 [2,] 22.663117 20.019737 B-58 identical B-58f predict(af, xdata.frame, trace=1) # data frame with cols in different order get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: ldose sex3 ldose1 fac3 New columns: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 2 1 -1 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 [2,] 22.663117 20.019737 B-58 identical B-50m data frame without column names, trace=1 get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 B-34 identical B-60f data frame without column names, trace=1 get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 B-60 identical B-60f data frame without extra columns, trace=1 get.earth.x from model.matrix.earth from predict.earth: x[1,7]: sex3 extra1 ldose extra2 ldose1 fac3 extra3 1 male 99 -2 99 0.1 lev2 female factors: sex3 fac3 extra3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) ldose h(ldose1-2.5) h(2.5-ldose1) 1 1 -2 0 2.4 predict.earth: returning earth predictions numdead numdead2 [1,] 1.577732 1.587702 B-60f identical --- C predict with multiple level factors and a 3 level factor response, trace=1 --- x[12,6] with colnames sex3female sex3male ldose ldose1 fac3lev2 fac3lev3 y[12,3] with colnames dead1 dead2 dead3 Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq -2.977 RSq 0.597 Prune none penalty 3 nprune null: selected 4 of 4 terms, and 2 of 6 preds After pruning pass GRSq -2.98 RSq 0.597 x[12,6] with colnames sex3female sex3male ldose ldose1 fac3lev2 fac3lev3 y[12,3] with colnames dead1 dead2 dead3 Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq -2.977 RSq 0.597 Prune none penalty 3 nprune null: selected 4 of 4 terms, and 2 of 6 preds After pruning pass GRSq -2.98 RSq 0.597 C predict with multiple level factors and a multiple real response: models not identical Formulas differ: Error in formula.default(mod1) : invalid formula and: facdead ~ sex3 + ldose + ldose1 + fac3 C predict with multiple level factors and a multiple real response: Models are equivalent, within numerical tolerances 20m head(predict(am, trace=1) predict.earth: returning earth fitted.values dead1 dead2 dead3 [1,] 0.48796881 0.55646922 -0.04443804 [2,] -0.17857394 1.04640569 0.13216825 [3,] 0.61065675 0.20356630 0.18577695 [4,] 0.63869210 -0.05928628 0.42059419 [5,] 0.30641076 -0.01824193 0.71183118 [6,] -0.02587059 0.02280242 1.00306817 C-21f head(predict(af, trace=1) predict.earth: returning earth fitted.values dead1 dead2 dead3 [1,] 0.48796881 0.55646922 -0.04443804 [2,] -0.17857394 1.04640569 0.13216825 [3,] 0.61065675 0.20356630 0.18577695 [4,] 0.63869210 -0.05928628 0.42059419 [5,] 0.30641076 -0.01824193 0.71183118 [6,] -0.02587059 0.02280242 1.00306817 C-20 identical C-31m predict(am, xdata.frame, trace=1) data frame with factors and wrong col names get.earth.x from model.matrix.earth from predict.earth: unexpected x column names, renaming columns Old names: sex3.1. X.2 X0.1 fac3.1. New names: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 predict.earth: returning earth predictions C-31 identical dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 C-31f predict(af, xdata.frame, trace=1) data frame with factors and wrong col names get.earth.x from model.matrix.earth from predict.earth: unexpected x column names, renaming columns Old names: sex3.1. X.2 X0.1 fac3.1. New names: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 C-31 identical C-31bm predict(am, xdata.frame, trace=1) data frame col names get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 C-31 identical C-31bf predict(af, xdata.frame, trace=1) data frame col names get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 C-31b identical C-32m predict(am, xdata.frame, trace=1) # data frame with names get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 C-32 identical C-32 identical C-32f predict(af, xdata.frame, trace=1) # data frame with names get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 C-32 identical C-53m predict(am, xdata.frame, trace=1) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.1. X.2 expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(am, xdata.frame, trace = trace)) C-53f predict(af, xdata.frame, trace=1) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.1. X.2 expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(af, xdata.frame, trace = trace)) C-54m predict(am, xdata.frame, trace=1) # data frame with cols in different order get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: ldose sex3 ldose1 fac3 New columns: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 C-54 identical C-54f predict(af, xdata.frame, trace=1) # data frame with cols in different order get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: ldose sex3 ldose1 fac3 New columns: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 C-54 identical C-55m predict(am, xdata.frame, trace=1) data frame without col names get.earth.x from model.matrix.earth from predict.earth: unexpected x column names, renaming columns Old names: sex3.c.1..7.. c..2...1. c.0.1..0.1. fac3.c.1..9.. New names: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 2 1 0 2.4 -2.4 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 [2,] -1.1001477 2.0104065 0.08974114 C-55f predict(af, xdata.frame, trace=1) data frame without col names get.earth.x from model.matrix.earth from predict.earth: unexpected x column names, renaming columns Old names: sex3.c.1..7.. c..2...1. c.0.1..0.1. fac3.c.1..9.. New names: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 2 1 0 2.4 -2.4 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 [2,] -1.1001477 2.0104065 0.08974114 C-55 identical C2-55bm predict(am, xdata.frame, trace=1) data frame col names get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 2 1 0 2.4 -2.4 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 [2,] -1.1001477 2.0104065 0.08974114 C2-55 identical C2-55bf predict(af, xdata.frame, trace=1) data frame col names get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 2 1 0 2.4 -2.4 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 [2,] -1.1001477 2.0104065 0.08974114 C2-55b identical C-56m predict(am, xdata.frame, trace=1) # data frame with col names get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 2 1 0 2.4 -2.4 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 [2,] -1.1001477 2.0104065 0.08974114 C-56 identical C-56f predict(af, xdata.frame, trace=1) # data frame with col names get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 2 1 0 2.4 -2.4 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 [2,] -1.1001477 2.0104065 0.08974114 C-56 identical C-57m predict(am, xdata.frame, trace=1) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.c.1..7.. c..2...1. expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(am, xdata.frame, trace = trace)) C-57f predict(af, xdata.frame, trace=1) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.c.1..7.. c..2...1. expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(af, xdata.frame, trace = trace)) C-57 identical C-58m predict(am, xdata.frame, trace=1) # data frame with cols in different order get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: ldose sex3 ldose1 fac3 New columns: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 2 1 0 2.4 -2.4 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 [2,] -1.1001477 2.0104065 0.08974114 C-58 identical C-58f predict(af, xdata.frame, trace=1) # data frame with cols in different order get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: ldose sex3 ldose1 fac3 New columns: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 2 female -1 0.1 lev1 factors: sex3 fac3 predict.earth with newdata: bx[2,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 2 1 0 2.4 -2.4 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 [2,] -1.1001477 2.0104065 0.08974114 C-58 identical C-50m data frame without column names, trace=1 get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 C-34 identical C-60f data frame without column names, trace=1 get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: sex3 ldose ldose1 fac3 get.earth.x from model.matrix.earth from predict.earth: x[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 C-60 identical C-61f data frame without extra columns, trace=1 get.earth.x from model.matrix.earth from predict.earth: x[1,7]: sex3 extra1 ldose extra2 ldose1 fac3 extra3 1 male 99 -2 99 0.1 lev2 female factors: sex3 fac3 extra3 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,4]: sex3 ldose ldose1 fac3 1 male -2 0.1 lev2 factors: sex3 fac3 predict.earth with newdata: bx[1,4]: (Intercept) h(ldose1-2.5) h(2.5-ldose1) ldose*h(2.5-ldose1) 1 1 0 2.4 -4.8 predict.earth: returning earth predictions dead1 dead2 dead3 [1,] 0.4879688 0.5564692 -0.04443804 C-61 identical > test.predict.with.factors(trace=0) --- predict with single level factors and a single response, trace=0 --- first do a quick test of predict.earth help page example predict with single level factors and a single response: models not identical Formulas differ: Error in formula.default(mod1) : invalid formula and: numdead ~ sex + ldose + ldose1 predict with single level factors and a single response: Models are equivalent, within numerical tolerances A-20m head(predict(am, trace=0) A-20f head(predict(af, trace=0) A-20 identical A-21m predict(am, newdata=c(sex[1], -2, 0.1), trace=0)) A-21f predict(af, newdata=c(sex[1], -2, 0.1), trace=0)) Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 1 -2 0.1 A-21 identical A-22m predict(am, newdata=c(1, -2, 0.1), trace=0)) use numeric instead of factor sex A-22 identical A-22f predict(af, newdata=c(1, -2, 0.1), trace=0)) use numeric instead of factor sex Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 1 -2 0.1 A-22 identical A-23m predict(am, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=0)) multiple rows as a vec A-23f predict(af, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=0)) multiple rows as a vec Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -2 0.1 A-23 identical A-24m predict(am, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=0)) more multiple rows as a vec A-24f predict(af, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=0)) more multiple rows as a vec Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 A-24 identical A-25m predict(am, xpredict matrix trace=0 A-25 identical A-25f predict(af, xpredict matrix trace=0 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 A-25 identical A-26m predict(am, new.data with col names) trace=0 A-26m identical A-26f predict(af, new.data with col names) trace=0 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 A-26f identical A-27m predict(am, new.data with out of order col names) trace=0 A-27 identical A-27f predict(af, new.data with out of order col names) trace=0 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 A-27 identical A-28m predict(am, xdata.frame without col names) trace=0 A-28 identical A-28f predict(af, xdata.frame without col names) trace=0 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 A-28 identical A-29m predict(am, xdata.frame with col names) trace=0 A-29 identical A-29f predict(af, xdata.frame with col names) trace=0 A-29 identical A2-29m predict(am, xdata.frame with col names) trace=0 A2-29 identical A2-29f predict(af, xdata.frame with col names) trace=0 Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 A2-29 identical A-31m predict(am, xdata.frame, trace=0) data frame with factors and wrong col names A-31 identical A-31f predict(af, xdata.frame, trace=0) data frame with factors and wrong col names A-31 identical A-31bm predict(am, xdata.frame, trace=0) data frame col names A-31 identical A-31bf predict(af, xdata.frame, trace=0) data frame col names A-31b identical A-32m predict(am, xdata.frame, trace=0) # data frame with names A-32 identical A-32 identical A-32f predict(af, xdata.frame, trace=0) # data frame with names A-32 identical A-42am predict(am, newdata=c(1, -2, 0.1), trace=0)) use numeric instead of factor sex A-42a identical A-42af predict(af, newdata=c(1, -2, 0.1), trace=0)) use numeric instead of factor sex Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 1 -2 0.1 A-42a identical A-43am predict(af, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=0)) multiple rows as a vec Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -2 0.1 A-43af predict(am, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=0)) multiple rows as a vec A-43a identical A-44am predict(af, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=0)) more multiple rows as a vec Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 2 -1 0.1 A-44a identical A-44fm predict(am, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=0)) more multiple rows as a vec A-44f identical A-53m predict(am, xdata.frame, trace=0) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 3 column names: sex.1. X.2 expected column names: sexmale ldose ldose1 Got error as expected from try(predict(am, xdata.frame, trace = trace)) A-53f predict(af, xdata.frame, trace=0) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 3 column names: sex.1. X.2 expected column names: sex ldose ldose1 Got error as expected from try(predict(af, xdata.frame, trace = trace)) A-54m predict(am, xdata.frame, trace=0) # data frame with cols in different order A-54 identical A-54f predict(af, xdata.frame, trace=0) # data frame with cols in different order A-54 identical A-55m predict(am, xdata.frame, trace=0) data frame without col names A-55f predict(af, xdata.frame, trace=0) data frame without col names A-55 identical A-56m predict(am, xdata.frame, trace=0) # data frame with col names A-56 identical A-56f predict(af, xdata.frame, trace=0) # data frame with col names A-56 identical A-57m predict(am, xdata.frame, trace=0) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 3 column names: sex.c.1..7.. c..2...1. expected column names: sexmale ldose ldose1 Got error as expected from try(predict(am, xdata.frame, trace = trace)) A-57f predict(af, xdata.frame, trace=0) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 3 column names: sex.c.1..7.. c..2...1. expected column names: sex ldose ldose1 Got error as expected from try(predict(af, xdata.frame, trace = trace)) A-57 identical A-58m predict(am, xdata.frame, trace=0) # data frame with cols in different order A-58 identical A-58f predict(af, xdata.frame, trace=0) # data frame with cols in different order A-58 identical A-59m predict(am, xdata.frame, trace=0) numeric where factor expected, expect forge on message A-59f predict(af, xdata.frame, trace=0) numeric where factor expected, expect forge on message Warning in model.frame.default(terms.without.response, data = data, na.action = na.pass, : variable 'sex' is not a factor Error : variable 'sex' was fitted with type "factor" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are sex ldose ldose1 1 2 -2 0.1 2 1 -1 0.1 A-59 identical A-50m data frame without column names, trace=0 A-34 identical A-60f data frame without column names, trace=0 A-60 identical A-61f data frame without extra columns, trace=0 A-61 identical A-68 input matrix to formula interface trace=0, expect error "could not interpret" Error : model.frame.default could not interpret the data passed to get.earth.x from model.matrix.earth from predict.earth (actual.nrows=60 expected.nrows=1 fitted.nrows=60) Got error as expected from try(predict(a41, c(2.1, 0.6), trace = trace)) A-69 above test but with properly named dataframe trace=0 Tests with not all predictors used in the model so can pass fewer columns A-72m predict(am, newdata=newdata[two columns], trace=trace) A-72m identical ldose dummy ldose1 1 -2 0 0.1 2 -1 0 1.2 3 0 0 0.1 4 1 0 1.2 5 2 0 1.0 6 3 0 0.1 7 -2 0 0.3 8 -1 0 1.4 9 0 0 0.1 10 1 0 1.2 11 2 0 0.1 12 3 0 0.9 A-73m predict(am, newdata=newdata[two columns], trace=trace) A-73m identical A-72f predict(af, newdata=newdata[two columns], trace=trace) A-72f identical ldose dummy ldose1 1 -2 0 0.1 2 -1 0 1.2 3 0 0 0.1 4 1 0 1.2 5 2 0 1.0 6 3 0 0.1 7 -2 0 0.3 8 -1 0 1.4 9 0 0 0.1 10 1 0 1.2 11 2 0 0.1 12 3 0 0.9 A-73f predict(af, newdata=newdata[two columns], trace=trace) A-73f identical --- B predict with multiple level factors and a multiple real response, trace=0 --- B predict with multiple level factors and a multiple real response: models not identical Formulas differ: Error in formula.default(mod1) : invalid formula and: numdeadboth ~ sex3 + ldose + ldose1 + fac3 B predict with multiple level factors and a multiple real response: Models are equivalent, within numerical tolerances 20m head(predict(am, trace=0) B-21f head(predict(af, trace=0) B-20 identical B-31m predict(am, xdata.frame, trace=0) data frame with factors and wrong col names B-31 identical B-31f predict(af, xdata.frame, trace=0) data frame with factors and wrong col names B-31 identical B-31bm predict(am, xdata.frame, trace=0) data frame col names B-31 identical B-31bf predict(af, xdata.frame, trace=0) data frame col names B-31b identical B-32m predict(am, xdata.frame, trace=0) # data frame with names B-32 identical B-32 identical B-32f predict(af, xdata.frame, trace=0) # data frame with names B-32 identical B-53m predict(am, xdata.frame, trace=0) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.1. X.2 expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(am, xdata.frame, trace = trace)) B-53f predict(af, xdata.frame, trace=0) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.1. X.2 expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(af, xdata.frame, trace = trace)) B-54m predict(am, xdata.frame, trace=0) # data frame with cols in different order B-54 identical B-54f predict(af, xdata.frame, trace=0) # data frame with cols in different order B-54 identical B-55m predict(am, xdata.frame, trace=0) data frame without col names B-55m again, but with same x data for both reponses numdead numdead2 [1,] 1.577732 1.587702 [2,] 1.577732 1.587702 B-55f predict(af, xdata.frame, trace=0) data frame without col names B-55 identical B2-55bm predict(am, xdata.frame, trace=0) data frame col names B2-55 identical B2-55bf predict(af, xdata.frame, trace=0) data frame col names B2-55b identical B-56m predict(am, xdata.frame, trace=0) # data frame with col names B-56 identical B-56f predict(af, xdata.frame, trace=0) # data frame with col names B-56 identical B-57m predict(am, xdata.frame, trace=0) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.c.1..7.. c..2...1. expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(am, xdata.frame, trace = trace)) B-57f predict(af, xdata.frame, trace=0) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.c.1..7.. c..2...1. expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(af, xdata.frame, trace = trace)) B-57 identical B-58m predict(am, xdata.frame, trace=0) # data frame with cols in different order B-58 identical B-58f predict(af, xdata.frame, trace=0) # data frame with cols in different order B-58 identical B-50m data frame without column names, trace=0 B-34 identical B-60f data frame without column names, trace=0 B-60 identical B-60f data frame without extra columns, trace=0 B-60f identical --- C predict with multiple level factors and a 3 level factor response, trace=0 --- C predict with multiple level factors and a multiple real response: models not identical Formulas differ: Error in formula.default(mod1) : invalid formula and: facdead ~ sex3 + ldose + ldose1 + fac3 C predict with multiple level factors and a multiple real response: Models are equivalent, within numerical tolerances 20m head(predict(am, trace=0) C-21f head(predict(af, trace=0) C-20 identical C-31m predict(am, xdata.frame, trace=0) data frame with factors and wrong col names C-31 identical C-31f predict(af, xdata.frame, trace=0) data frame with factors and wrong col names C-31 identical C-31bm predict(am, xdata.frame, trace=0) data frame col names C-31 identical C-31bf predict(af, xdata.frame, trace=0) data frame col names C-31b identical C-32m predict(am, xdata.frame, trace=0) # data frame with names C-32 identical C-32 identical C-32f predict(af, xdata.frame, trace=0) # data frame with names C-32 identical C-53m predict(am, xdata.frame, trace=0) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.1. X.2 expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(am, xdata.frame, trace = trace)) C-53f predict(af, xdata.frame, trace=0) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.1. X.2 expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(af, xdata.frame, trace = trace)) C-54m predict(am, xdata.frame, trace=0) # data frame with cols in different order C-54 identical C-54f predict(af, xdata.frame, trace=0) # data frame with cols in different order C-54 identical C-55m predict(am, xdata.frame, trace=0) data frame without col names C-55f predict(af, xdata.frame, trace=0) data frame without col names C-55 identical C2-55bm predict(am, xdata.frame, trace=0) data frame col names C2-55 identical C2-55bf predict(af, xdata.frame, trace=0) data frame col names C2-55b identical C-56m predict(am, xdata.frame, trace=0) # data frame with col names C-56 identical C-56f predict(af, xdata.frame, trace=0) # data frame with col names C-56 identical C-57m predict(am, xdata.frame, trace=0) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.c.1..7.. c..2...1. expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(am, xdata.frame, trace = trace)) C-57f predict(af, xdata.frame, trace=0) data frame with not enough columns, expect error message Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4 column names: sex3.c.1..7.. c..2...1. expected column names: sex3 ldose ldose1 fac3 Got error as expected from try(predict(af, xdata.frame, trace = trace)) C-57 identical C-58m predict(am, xdata.frame, trace=0) # data frame with cols in different order C-58 identical C-58f predict(af, xdata.frame, trace=0) # data frame with cols in different order C-58 identical C-50m data frame without column names, trace=0 C-34 identical C-60f data frame without column names, trace=0 C-60 identical C-61f data frame without extra columns, trace=0 C-61 identical > > cat("---test glm.predict---\n") ---test glm.predict--- > > ldose <- rep(0:5, 2) - 2 > sex <- factor(rep(c("male", "female"), times=c(6,6))) > numdead <- c(1,4,9,13,18,20,0,2,6,10,12,16) > SF <- cbind(numdead, numalive=20 - numdead) > > cat("c1a: single response glm model with a binomial pair of y columns, fitted values, keepxy=0\n") c1a: single response glm model with a binomial pair of y columns, fitted values, keepxy=0 > c1a <- earth(SF ~ sex + ldose, glm=list(family="binomial"), linpreds=TRUE, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=0) x[12,2] with colnames sexmale ldose y[12,2] with colnames numdead numalive earth and glm: unweighted Response columns numdead and numalive are a binomial pair (240 obs in total) yfrac[12,1] with colname numdead, and values 0.05, 0.2, 0.45, 0.65, 0.9, 1... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.952 RSq 0.981 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.952 RSq 0.981 GLM numdead devratio 0.95 dof 9/11 iters 4 > c1ag <- glm(SF ~ sex + ldose, family="binomial") # use this as a reference > > c1a.predict <- predict(c1a, trace=1) predict.earth: returning glm fitted.values > c1ag.predict <- predict(c1ag, trace=1) > check.almost.equal(c1a.predict, c1ag.predict, max=1e-10, msg="c1a fitted values, type=default link, keepxy=0", verbose=TRUE) c1a fitted values, type=default link, keepxy=0 OK > c1a.predict <- predict(c1a, type="link", trace=1) predict.earth: returning glm fitted.values > c1ag.predict <- predict(c1ag, type="li", trace=1) > check.almost.equal(c1a.predict, c1ag.predict, max=1e-10, msg="c1a fitted values, type=link, keepxy=0", verbose=TRUE) c1a fitted values, type=link, keepxy=0 OK > c1a.predict <- predict(c1a, type="response", trace=1) predict.earth: returning glm fitted.values > c1ag.predict <- predict(c1ag, type="resp", trace=1) > check.almost.equal(c1a.predict, c1ag.predict, max=1e-10, msg="c1a fitted values, type=response, keepxy=0", verbose=TRUE) c1a fitted values, type=response, keepxy=0 OK > c1a.predict <- predict(c1a, type="e", trace=1) predict.earth: returning earth (not glm) fitted.values > dead.frac <- numdead / (numdead + (20 - numdead)) > c1ae <- earth(dead.frac ~ sex + ldose, trace=1, linpreds=TRUE, pmethod=PMETHOD, nk=NK, degree=1, keepxy=0) x[12,2] with colnames sexmale ldose y[12,1] with colname dead.frac, and values 0.05, 0.2, 0.45, 0.65, 0.9, 1... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.952 RSq 0.981 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.952 RSq 0.981 > c1ae.predict <- predict(c1ae, trace=1) predict.earth: returning earth fitted.values > check.almost.equal(c1a.predict, c1ae.predict, max=1e-10, msg="c1a fitted values, type=earth, keepxy=0", verbose=TRUE) c1a fitted values, type=earth, keepxy=0 OK > > cat("c1b: single response glm model with a binomial pair of y columns\n") c1b: single response glm model with a binomial pair of y columns > c1b <- earth(SF ~ sex + ldose, glm=list(family="binomial"), linpreds=TRUE, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) x[12,2] with colnames sexmale ldose y[12,2] with colnames numdead numalive earth and glm: unweighted Response columns numdead and numalive are a binomial pair (240 obs in total) yfrac[12,1] with colname numdead, and values 0.05, 0.2, 0.45, 0.65, 0.9, 1... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.952 RSq 0.981 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.952 RSq 0.981 GLM numdead devratio 0.95 dof 9/11 iters 4 Warning: No 'data' argument to earth so 'keepxy' is limited > c1be <- earth(numdead ~ sex + ldose, linpreds=TRUE, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) x[12,2] with colnames sexmale ldose y[12,1] with colname numdead, and values 1, 4, 9, 13, 18, 20, 0, 2, 6,... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.952 RSq 0.981 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.952 RSq 0.981 Warning: No 'data' argument to earth so 'keepxy' is limited > c1bg <- glm(SF ~ sex + ldose, family="binomial") # use this as a reference > > newdata <- data.frame(sex=sex[1], ldose=2) > c1b.predict <- predict(c1b, newdata, trace=1) get.earth.x from model.matrix.earth from predict.earth: x[1,2]: sex ldose 1 male 2 sex is a factor with levels: female male get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,2]: sex ldose 1 male 2 sex is a factor with levels: female male predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 2 1 predict.earth: returning glm link predictions > stopifnot(dim(c1b.predict) == c(1,1)) > check.almost.equal(c1b.predict, predict(c1bg, newdata), max=1e-10, msg="c1b", verbose=TRUE) c1b OK > > c1b.link.predict <- predict(c1b, newdata, type="link", trace=1) # should be same as above because default is link get.earth.x from model.matrix.earth from predict.earth: x[1,2]: sex ldose 1 male 2 sex is a factor with levels: female male get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,2]: sex ldose 1 male 2 sex is a factor with levels: female male predict.earth with newdata: bx[1,3]: (Intercept) ldose sexmale 1 1 2 1 predict.earth: returning glm link predictions > check.almost.equal(c1b.link.predict, c1b.predict, max=1e-10, msg="c1b link", verbose=TRUE) c1b link OK > > c1b.predict <- predict(c1b, newdata, type="r") > stopifnot(dim(c1b.predict) == c(1,1)) > check.almost.equal(c1b.predict, predict(c1bg, newdata, type="response"), max=1e-10, msg="c1b type=response", verbose=TRUE) c1b type=response OK > > c1b.predict <- predict(c1b, newdata, type="earth") > stopifnot(dim(c1b.predict) == c(1,1)) > print(c1b.predict) numdead [1,] 0.814881 > > newdata <- data.frame(sex=sex[c(1,3,7,9)], ldose=ldose[c(1,3,7,9)]) > c1b.predict <- predict(c1b, newdata, trace=1) get.earth.x from model.matrix.earth from predict.earth: x[4,2]: sex ldose 1 male -2 2 male 0 3 female -2 4 female 0 sex is a factor with levels: female male get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[4,2]: sex ldose 1 male -2 2 male 0 3 female -2 4 female 0 sex is a factor with levels: female male predict.earth with newdata: bx[4,3]: (Intercept) ldose sexmale 1 1 -2 1 2 1 0 1 3 1 -2 0 4 1 0 0 predict.earth: returning glm link predictions > stopifnot(dim(c1b.predict) == c(4,1)) > check.almost.equal(c1b.predict, predict(c1bg, newdata), max=1e-10, msg="c1b multiple rows", verbose=TRUE) c1b multiple rows OK > > c1b.predict <- predict(c1b, newdata, type="response", trace=1) get.earth.x from model.matrix.earth from predict.earth: x[4,2]: sex ldose 1 male -2 2 male 0 3 female -2 4 female 0 sex is a factor with levels: female male get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[4,2]: sex ldose 1 male -2 2 male 0 3 female -2 4 female 0 sex is a factor with levels: female male predict.earth with newdata: bx[4,3]: (Intercept) ldose sexmale 1 1 -2 1 2 1 0 1 3 1 -2 0 4 1 0 0 predict.earth: returning glm response predictions > stopifnot(dim(c1b.predict) == c(4,1)) > check.almost.equal(c1b.predict, predict(c1bg, newdata, type="response"), max=1e-10, msg="c1b multiple rows type=response", verbose=TRUE) c1b multiple rows type=response OK > > c1b.predict <- predict(c1b, newdata, type="terms", trace=0) Warning: predict.earth: returning the earth (not glm) terms > print(c1b.predict) sexmale ldose [1,] 0.1583333 -0.3642857 [2,] 0.1583333 0.0000000 [3,] 0.0000000 -0.3642857 [4,] 0.0000000 0.0000000 > c1be.predict <- predict(c1be, newdata, type="terms") > print(c1be.predict) sexmale ldose [1,] 3.166667 -7.285714 [2,] 3.166667 0.000000 [3,] 0.000000 -7.285714 [4,] 0.000000 0.000000 > c1bg.predict <- predict(c1bg, newdata, type="terms") > print(c1bg.predict) sex ldose 1 0.5503717 -2.660535 2 0.5503717 -0.532107 3 -0.5503717 -2.660535 4 -0.5503717 -0.532107 attr(,"constant") [1] -0.2622487 > > # commented out because multiple binomial pairs are no longer supported > # cat("c2: double response glm model with two y binomial pairs\n") > # SF2 <- cbind(numdead, numalive=20 - numdead, numdead2=numdead, numalive2=20 - numdead) > # c2 <- earth(SF2 ~ sex + ldose, glm=list(family="binomial"), linpreds=TRUE, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) > # c2e <- earth(data.frame(sex, ldose), data.frame(numdead,numdead), linpreds=TRUE, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) > # c2g <- glm(SF ~ sex + ldose, family="binomial") # use this as a reference > > # newdata <- data.frame(sex=sex[1], ldose=2) > # c2.predict <- predict(c2, newdata, trace=1) > # stopifnot(dim(c2.predict) == c(1,2)) > # check.almost.equal(c2.predict[,1], predict(c2g, newdata), max=1e-10, msg="c2", verbose=TRUE) > # > # c2.link.predict <- predict(c2, newdata, type="link", trace=1) # should be same as above because default is link > # check.almost.equal(c2.link.predict, c2.predict, max=1e-10, msg="c2 link", verbose=TRUE) > # > # c2.predict <- predict(c2, newdata, type="response") > # stopifnot(dim(c2.predict) == c(1,2)) > # check.almost.equal(c2.predict[,1], predict(c2g, newdata, type="response"), max=1e-10, msg="c2 multiple rows type=response", verbose=TRUE) > # > # newdata <- data.frame(sex=sex[c(1,3,7,9)], ldose=ldose[c(1,3,7,9)]) > # c2.predict <- predict(c2, newdata) > # stopifnot(dim(c2.predict) == c(4,2)) > # check.almost.equal(c2.predict[,1], predict(c2g, newdata), max=1e-10, msg="c2 column1", verbose=TRUE) > # check.almost.equal(c2.predict[,2], predict(c2g, newdata), max=1e-10, msg="c2 column2", verbose=TRUE) > # > # c2.predict <- predict(c2, newdata, type="response") > # stopifnot(dim(c2.predict) == c(4,2)) > # check.almost.equal(c2.predict[,1], predict(c2g, newdata, type="response"), max=1e-10, msg="c2 column1 multiple rows type=response", verbose=TRUE) > # check.almost.equal(c2.predict[,2], predict(c2g, newdata, type="response"), max=1e-10, msg="c2 column2 multiple rows type=response", verbose=TRUE) > # > # c2.predict <- predict(c2, newdata, type="earth", trace=1) > # stopifnot(dim(c2.predict) == c(4,2)) > # check.almost.equal(c2.predict[,1], predict(c2e, newdata, trace=1), max=1e-10, msg="c2 column1 multiple rows type=earth", verbose=TRUE) > # check.almost.equal(c2.predict[,2], predict(c2e, newdata, trace=1), max=1e-10, msg="c2 column2 multiple rows type=earth", verbose=TRUE) > > cat("c3a: single response glm model with a boolean response, fitted values, keepxy=0\n") c3a: single response glm model with a boolean response, fitted values, keepxy=0 > > mybool <- rep(c(FALSE, TRUE), times=c(6,6)) > data1 <- data.frame(mybool, sex, ldose) > c3a <- earth(mybool ~ sex + ldose, data=data1, glm=list(family="binomial"), linpreds=TRUE, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=0) x[12,2] with colnames sexmale ldose y[12,1] with colname mybool, and values 0, 0, 0, 0, 0, 0, 1, 1, 1, 1,... Forward pass term 1, 2 Reached maximum RSq 0.9990 at 3 terms, 2 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Prune none penalty 2 nprune null: selected 2 of 2 terms, and 1 of 2 preds After pruning pass GRSq 1 RSq 1 GLM mybool devratio 1.00 dof 10/11 iters 23 > c3ag <- glm(mybool ~ sex + ldose, family="binomial") # use this as a reference > c3ae <- earth(mybool ~ sex + ldose, data=data1, linpreds=TRUE, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) > > c3a.predict <- predict(c3a, trace=1) predict.earth: returning glm fitted.values > c3ag.predict <- predict(c3ag, trace=1) > # TODO why does max have to be big here? > check.almost.equal(c3a.predict, c3ag.predict, max=1e-7, msg="c3a fitted values, type=default link, keepxy=0", verbose=TRUE) c3a fitted values, type=default link, keepxy=0 OK > c3a.predict <- predict(c3a, type="link", trace=1) predict.earth: returning glm fitted.values > c3ag.predict <- predict(c3ag, type="link", trace=1) > check.almost.equal(c3a.predict, c3ag.predict, max=1e-7, msg="c3a fitted values, type=link, keepxy=0", verbose=TRUE) c3a fitted values, type=link, keepxy=0 OK > c3a.predict <- predict(c3a, type="response", trace=1) predict.earth: returning glm fitted.values > c3ag.predict <- predict(c3ag, type="response", trace=1) > check.almost.equal(c3a.predict, c3ag.predict, max=1e-10, msg="c3a fitted values, type=response, keepxy=0", verbose=TRUE) c3a fitted values, type=response, keepxy=0 OK > c3a.predict <- predict(c3a, type="earth", trace=1) predict.earth: returning earth (not glm) fitted.values > c3ae.predict <- predict(c3ae, trace=1) predict.earth: returning earth fitted.values > check.almost.equal(c3a.predict, c3ae.predict, max=1e-10, msg="c3a fitted values, type=earth, keepxy=0", verbose=TRUE) c3a fitted values, type=earth, keepxy=0 OK > > c3a.response.predict <- predict(c3a, type="response") > c3a.class.predict <- predict(c3a,type="class") > stopifnot(c3a.class.predict == (c3a.response.predict > .5)) > > cat("c3b: single response glm model with a boolean response, fitted values, keepxy=1\n") c3b: single response glm model with a boolean response, fitted values, keepxy=1 > > c3b <- earth(mybool ~ sex + ldose, glm=list(family="binomial"), linpreds=TRUE, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) x[12,2] with colnames sexmale ldose y[12,1] with colname mybool, and values 0, 0, 0, 0, 0, 0, 1, 1, 1, 1,... Forward pass term 1, 2 Reached maximum RSq 0.9990 at 3 terms, 2 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Prune none penalty 2 nprune null: selected 2 of 2 terms, and 1 of 2 preds After pruning pass GRSq 1 RSq 1 GLM mybool devratio 1.00 dof 10/11 iters 23 Warning: No 'data' argument to earth so 'keepxy' is limited > c3bg <- glm(mybool ~ sex + ldose, family="binomial") # use this as a reference > c3be <- earth(mybool ~ sex + ldose, linpreds=TRUE, pmethod=PMETHOD, nk=NK, degree=1, keepxy=0) > > c3b.predict <- predict(c3b, trace=1) # fitted values predict.earth: returning glm fitted.values > c3bg.predict <- predict(c3bg, trace=1) > check.almost.equal(c3b.predict, c3bg.predict, max=1e-7, msg="c3b fitted values, type=default link, keepxy=0", verbose=TRUE) c3b fitted values, type=default link, keepxy=0 OK > c3b.predict <- predict(c3b, type="link", trace=1) predict.earth: returning glm fitted.values > c3bg.predict <- predict(c3bg, type="link", trace=1) > check.almost.equal(c3b.predict, c3bg.predict, max=1e-7, msg="c3b fitted values, type=link, keepxy=0", verbose=TRUE) c3b fitted values, type=link, keepxy=0 OK > c3b.predict <- predict(c3b, type="response", trace=1) predict.earth: returning glm fitted.values > c3bg.predict <- predict(c3bg, type="response", trace=1) > check.almost.equal(c3b.predict, c3bg.predict, max=1e-10, msg="c3b fitted values, type=response, keepxy=0", verbose=TRUE) c3b fitted values, type=response, keepxy=0 OK > c3b.predict <- predict(c3b, type="earth", trace=1) predict.earth: returning earth (not glm) fitted.values > c3be.predict <- predict(c3be, trace=1) predict.earth: returning earth fitted.values > check.almost.equal(c3b.predict, c3be.predict, max=1e-10, msg="c3b fitted values, type=earth, keepxy=0", verbose=TRUE) c3b fitted values, type=earth, keepxy=0 OK > > c3b.response.predict <- predict(c3b, type="response") > c3b.class.predict <- predict(c3b,type="cla") > stopifnot(c3b.class.predict == (c3b.response.predict > .5)) > > cat("c3c: single response glm model with a boolean response\n") c3c: single response glm model with a boolean response > > c3c <- earth(mybool ~ sex + ldose, data=data1, linpreds=TRUE, glm=list(family="binomial"), trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=0) x[12,2] with colnames sexmale ldose y[12,1] with colname mybool, and values 0, 0, 0, 0, 0, 0, 1, 1, 1, 1,... Forward pass term 1, 2 Reached maximum RSq 0.9990 at 3 terms, 2 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Prune none penalty 2 nprune null: selected 2 of 2 terms, and 1 of 2 preds After pruning pass GRSq 1 RSq 1 GLM mybool devratio 1.00 dof 10/11 iters 23 > c3cg <- glm(mybool ~ sex + ldose, data=data1, family="binomial") # use this as a reference > c3ce <- earth(mybool ~ sex + ldose, data=data1, linpreds=TRUE, pmethod=PMETHOD, nk=NK, degree=1, keepxy=0) > > newdata <- data.frame(sex=sex[1], ldose=2) > c3c.predict <- predict(c3c, newdata) > stopifnot(dim(c3c.predict) == c(1,1)) > check.almost.equal(c3c.predict, predict(c3cg, newdata), max=1e-10, msg="c3c", verbose=TRUE) c3c OK > > c3c.predict <- predict(c3c, newdata, type="response") > stopifnot(dim(c3c.predict) == c(1,1)) > check.almost.equal(c3c.predict, predict(c3cg, newdata, type="response"), max=1e-10, msg="c3c type=response", verbose=TRUE) c3c type=response OK > > newdata <- data.frame(sex=sex[c(1,3,7,9)], ldose=ldose[c(1,3,7,9)]) > c3c.predict <- predict(c3c, newdata) > stopifnot(dim(c3c.predict) == c(4,1)) > # TODO why does the max have to be bigger on this? > check.almost.equal(c3c.predict, predict(c3cg, newdata), max=1e-7, msg="c3c multiple rows", verbose=TRUE) c3c multiple rows OK > > c3c.predict <- predict(c3c, newdata, type="response") > stopifnot(dim(c3c.predict) == c(4,1)) > check.almost.equal(c3c.predict, predict(c3cg, newdata, type="response"), max=1e-10, msg="c3c multiple rows type=response", verbose=TRUE) c3c multiple rows type=response OK > > c3c.response.predict <- predict(c3c, type="response") > c3c.class.predict <- predict(c3c,type="cl") > stopifnot(c3c.class.predict == (c3c.response.predict > .5)) > > cat("c3d: single response glm model with a two level factor response\n") c3d: single response glm model with a two level factor response > cat("Expect \"did not converge warnings\", it doesn't matter for our purposes here\n") Expect "did not converge warnings", it doesn't matter for our purposes here > myfac <- gl(2, 3, length=12, labels = c("Control", "Treat")) > c3d <- earth(myfac ~ ldose + sex, data=data1, glm=list(family="binomial"), trace=0, pmethod=PMETHOD, nk=NK, degree=1) Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred > c3d.class.predict <- predict(c3d,type="cl") # we also test here that the type can be abbreviated > stopifnot(c3d.class.predict == myfac) > > cat("c4: multiple response glm model with a factor response\n") c4: multiple response glm model with a factor response > fac3 <- factor(rep(c("A", "B", "C"), times=c(4,3,5))) > cat("Expect \"did not converge warnings\", it doesn't matter for our purposes here\n") Expect "did not converge warnings", it doesn't matter for our purposes here > c4 <- earth(fac3 ~ sex + ldose, linpreds=TRUE, glm=list(family="binomial"), trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) x[12,2] with colnames sexmale ldose y[12,3] with colnames A B C Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq -0.145 RSq 0.536 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq -0.145 RSq 0.536 Warning: glm.fit: algorithm did not converge Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred GLM A devratio 1.00 dof 9/11 iters 25 GLM B devratio 0.06 dof 9/11 iters 4 Warning: glm.fit: algorithm did not converge Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred GLM C devratio 1.00 dof 9/11 iters 25 Warning: the glm algorithm did not converge for responses "A" "C" Warning: No 'data' argument to earth so 'keepxy' is limited > c4g <- glm(fac3 ~ sex + ldose, family="binomial") # use this as a reference Warning: glm.fit: algorithm did not converge Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred > c4.notrace <- earth(fac3 ~ sex + ldose, linpreds=TRUE, glm=list(family="binomial"), trace=0, pmethod=PMETHOD) Warning: glm.fit: algorithm did not converge Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred Warning: glm.fit: algorithm did not converge Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred Warning: the glm algorithm did not converge for responses "A" "C" > > newdata <- data.frame(sex=sex[1], ldose=2) > c4.predict <- predict(c4, newdata) > stopifnot(dim(c4.predict) == c(1,3)) > # minus needed on predict because of different handling of factors > check.almost.equal(c4.predict[1,1], -predict(c4g, newdata), max=1e-8, msg="c4", verbose=TRUE) c4 OK > > newdata <- data.frame(sex=sex[c(1,3,7,9)], ldose=ldose[c(1,3,7,9)]) > c4.predict <- predict(c4, newdata) > stopifnot(dim(c4.predict) == c(4,3)) > check.almost.equal(c4.predict[,1], -predict(c4g, newdata), max=1e-8, msg="c4 multiple rows", verbose=TRUE) c4 multiple rows OK > > c4.predict <- predict(c4, newdata, type="response") > stopifnot(dim(c4.predict) == c(4,3)) > check.almost.equal(1-c4.predict[,1], predict(c4g, newdata, type="response"), max=1e-10, msg="c4 multiple rows type=response", verbose=TRUE) c4 multiple rows type=response OK > > cat("c5: multiple response glm model with two multi level factor responses\n") c5: multiple response glm model with two multi level factor responses > > fac3 <- factor(rep(c("A", "B", "C"), times=c(4,3,5))) > fac4 <- factor(rep(c("P", "Q", "R", "S"), times=c(3,3,3,3))) > big.dataframe <- data.frame(fac3, fac4) > c5 <- earth(data.frame(sex, ldose), big.dataframe, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) x[12,2] with colnames sexmale ldose y[12,7] with colnames fac3A fac3B fac3C fac4P fac4Q fac4R fac4S Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq -0.074 RSq 0.565 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq -0.0737 RSq 0.565 > stopifnot(colnames(c5$coef) == c("fac3A", "fac3B", "fac3C", + "fac4P", "fac4Q", "fac4R", "fac4S")) > stopifnot(is.null(c5$glm.bpairs)) > > cat("c6: multiple response earth model with mixed responses\n") c6: multiple response earth model with mixed responses > > big.dataframe2 <- data.frame(SF, fac3, fac4, SF+1, sex, fac4, SF+3) > c6 <- earth(data.frame(sex, ldose), big.dataframe2, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) x[12,2] with colnames sexmale ldose y[12,18] with colnames numdead numalive fac3A fac3B fac3C fac4P fac4Q fac4R fac4... Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.944 RSq 0.977 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.944 RSq 0.977 > stopifnot(colnames(c6$coef) == c("numdead", "numalive", "fac3A", "fac3B", "fac3C", + "fac4P", "fac4Q", "fac4R", "fac4S", "numdead.1", "numalive.1", + "sex", "fac4.1P", "fac4.1Q", "fac4.1R", "fac4.1S", + "numdead.2", "numalive.2")) > stopifnot(is.null(c6$glm.bpairs)) > > # residuals > > a <- earth(pclass ~ ., data=etitanic) > printh(residuals(a), max.print=3) === residuals(a) 1st 2nd 3rd 1 0.6459266 -0.2575797 -0.3883469 2 0.7904775 -0.3372244 -0.4532531 3 1.0316575 -0.3335720 -0.6980855 > a <- earth(pclass ~ ., data=etitanic, glm=list(family="b")) > printh(residuals(a), expect.warning=TRUE, max.print=3) === residuals(a) expect warning -->Warning: residuals.earth: returning earth (not glm) residuals 1st 2nd 3rd 1 0.6459266 -0.2575797 -0.3883469 2 0.7904775 -0.3372244 -0.4532531 3 1.0316575 -0.3335720 -0.6980855 > printh(residuals(a, warn=FALSE), max.print=3) === residuals(a, warn = FALSE) 1st 2nd 3rd 1 0.6459266 -0.2575797 -0.3883469 2 0.7904775 -0.3372244 -0.4532531 3 1.0316575 -0.3335720 -0.6980855 > printh(resid(a, type="earth"), max.print=3) === resid(a, type = "earth") 1st 2nd 3rd 1 0.6459266 -0.2575797 -0.3883469 2 0.7904775 -0.3372244 -0.4532531 3 1.0316575 -0.3335720 -0.6980855 > printh(resid(a, type="deviance"), max.print=3) === resid(a, type = "deviance") 1st 2nd 3rd 1 1.463565 -0.7712447 -0.9440797 2 2.002755 -0.9266706 -1.0226283 3 2.611499 -0.9184549 -1.5622542 > printh(resid(a, type="glm.pearson"), max.print=3) === resid(a, type = "glm.pearson") 1st 2nd 3rd 1 1.385038 -0.5885288 -0.7493292 2 2.535727 -0.7323065 -0.8287859 3 5.409631 -0.7243429 -1.5454025 > printh(resid(a, type="glm.working"), max.print=3) === resid(a, type = "glm.working") 1st 2nd 3rd 1 2.918329 -1.346366 -1.561494 2 7.429912 -1.536273 -1.686886 3 30.264104 -1.524673 -3.388269 > printh(resid(a, type="glm.response"), max.print=3) === resid(a, type = "glm.response") 1st 2nd 3rd 1 0.6573382 -0.2572600 -0.3595878 2 0.8654089 -0.3490739 -0.4071918 3 0.9669576 -0.3441215 -0.7048640 > printh(resid(a, type="glm.partial"), max.print=3) === resid(a, type = "glm.partial") `h(age-26)` `h(26-age)` survived `h(sibsp-1)` `h(1-sibsp)` `h(parch-2)` 1 2.551986 3.229034 3.868894 2.971321 2.716353 2.967871 2 6.823847 5.636241 8.380477 7.482904 7.813164 7.479454 3 29.658038 28.561316 29.608383 30.317096 30.647355 30.313645 `h(2-parch)` `h(age-26)` `h(26-age)` survived `h(sibsp-1)` `h(1-sibsp)` 1 2.814339 -1.286898 -1.291444 -1.323918 -1.226331 -1.459130 2 7.875285 -1.437891 -1.853336 -1.513824 -1.416238 -1.322303 3 30.709476 -1.426291 -1.825670 -1.540158 -1.404638 -1.310703 `h(parch-2)` `h(2-parch)` `h(age-26)` `h(26-age)` survived `h(sibsp-1)` 1 -1.308344 -1.430315 -1.238589 -1.8139051 -2.342634 -1.688705 2 -1.498251 -1.176736 -1.152683 -0.2297406 -2.468026 -1.814097 3 -1.486651 -1.165135 -2.854066 -2.0049559 -2.849421 -3.515480 `h(1-sibsp)` `h(parch-2)` `h(2-parch)` 1 -1.266139 -1.631657 -1.398041 2 -2.247324 -1.757049 -2.386927 3 -3.948707 -3.458432 -4.088310 > expect.err(try(printh(resid(a, type="nonesuch"), max.print=3)), "Choose one of") === resid(a, type = "nonesuch")Error : type="nonesuch" is not allowed Choose one of: "earth" "deviance" "response" "standardize" "delever" "pearson" "working" "partial" "glm.response" "glm.pearson" "glm.working" "glm.partial" Got error as expected from try(printh(resid(a, type = "nonesuch"), max.print = 3)) > expect.err(try(printh(resid(a, type="g"), max.print=3)), "ambiguous") # type="g" is ambiguous === resid(a, type = "g")Error : type="g" is ambiguous Choose one of: "earth" "deviance" "response" "standardize" "delever" "pearson" "working" "partial" "glm.response" "glm.pearson" "glm.working" "glm.partial" Got error as expected from try(printh(resid(a, type = "g"), max.print = 3)) > expect.err(try(printh(resid(a, type="standardize"), max.print=3)), "model was not built with varmod.method") # model was not built with varmod.method === resid(a, type = "standardize")Error : "standardize" is not allowed because the model was not built with varmod.method Got error as expected from try(printh(resid(a, type = "standardize"), max.print = 3)) > > # tests based on Gavin Simpson's bug report > # fit a MARS model allowing one-way interactions > mod.Gamma <- earth(O3 ~ . - doy, data = ozone1, degree = 2, glm = list(family = Gamma)) > for(type in c("earth", "deviance", "glm.pearson", "glm.working", "glm.response", "glm.partial")) + { + cat("residuals.earth Gamma type=", type, ":\n", sep="") + print(head(resid(mod.Gamma, type = type), n=2)) + print(tail(resid(mod.Gamma, type = type), n=2)) + } residuals.earth Gamma type=earth: O3 1 -0.7243326 2 -2.2761517 O3 329 -2.4265537 330 -0.7557191 residuals.earth Gamma type=deviance: O3 1 -0.3273382 2 -0.1389893 O3 329 -0.352996 330 -1.141034 residuals.earth Gamma type=glm.pearson: O3 1 -0.2926391 2 -0.1326260 O3 329 -0.3127411 330 -0.7548319 residuals.earth Gamma type=glm.working: O3 1 0.06900048 2 0.02300727 O3 329 0.04298682 330 0.18506071 residuals.earth Gamma type=glm.response: O3 1 -1.2411163 2 -0.7645259 O3 329 -2.275278 330 -3.078834 residuals.earth Gamma type=glm.partial: `h(58-temp)` `h(ibh-1105)` `h(53-humidity)*h(temp-58)` `h(temp-58)*h(dpg-54)` 1 0.13967791 0.068767224 0.06840770 0.06817591 2 0.06801493 0.008540681 0.02241449 0.02218270 `h(temp-58)*h(54-dpg)` `h(2-dpg)` `h(dpg-2)*h(ibt-115)` 1 0.07442982 0.09497502 0.07427533 2 0.02843660 0.04755558 0.02828212 `h(humidity-46)*h(ibh-1105)` `h(vis-17)` `h(17-vis)` `h(wind-5)*h(1105-ibh)` 1 0.06311208 0.08356335 0.06849208 0.06844222 2 0.01711887 0.02011078 0.02249886 0.02244901 `h(ibh-1105)*h(vis-40)` 1 0.07052912 2 0.02101241 `h(58-temp)` `h(ibh-1105)` `h(53-humidity)*h(temp-58)` 329 0.06232471 0.05181521 0.04239404 330 0.26087209 0.20550522 0.18446793 `h(temp-58)*h(dpg-54)` `h(temp-58)*h(54-dpg)` `h(2-dpg)` 329 0.04216225 0.04841615 0.03045335 330 0.18423614 0.19049004 0.17252724 `h(dpg-2)*h(ibt-115)` `h(humidity-46)*h(ibh-1105)` `h(vis-17)` `h(17-vis)` 329 0.04826167 0.04751573 0.03310658 0.04247842 330 0.19033556 0.21976336 0.18216422 0.18455231 `h(wind-5)*h(1105-ibh)` `h(ibh-1105)*h(vis-40)` 329 0.04242856 0.04099196 330 0.18450245 0.18553509 > mod.binomial <- earth(survived ~ ., data = etitanic, degree = 2, glm = list(family = binomial)) > for(type in c("earth", "deviance", "glm.pearson", "glm.working", "glm.response", "glm.partial")) + { + cat("residuals.earth binomial type=", type, ":\n", sep="") + print(head(residuals(mod.binomial, type = type), n=2)) + print(tail(residuals(mod.binomial, type = type), n=2)) + } residuals.earth binomial type=earth: survived 1 0.03829050 2 -0.07121224 survived 1045 -0.1782103 1046 -0.1782103 residuals.earth binomial type=deviance: survived 1 0.3251518 2 0.2593733 survived 1045 -0.6051248 1046 -0.6051248 residuals.earth binomial type=glm.pearson: survived 1 0.2329892 2 0.1849578 survived 1045 -0.4482411 1046 -0.4482411 residuals.earth binomial type=glm.working: survived 1 1.054284 2 1.034209 survived 1045 -1.20092 1046 -1.20092 residuals.earth binomial type=glm.response: survived 1 0.05148896 2 0.03307782 survived 1045 -0.1673051 1046 -0.1673051 residuals.earth binomial type=glm.partial: sexmale pclass3rd `sexmale*h(16-age)` `pclass2nd*sexmale` 1 3.0582428 3.463517 0.922184 1.321358 2 -0.1474563 3.443443 4.549463 1.301283 `pclass3rd*h(4-sibsp)` `pclass3rd*sexmale` `h(age-32)` 1 0.029899131 0.6463292 1.233359 2 0.009824537 0.6262546 1.213285 sexmale pclass3rd `sexmale*h(16-age)` `pclass2nd*sexmale` 1045 -2.382586 -3.821743 -1.33302 -0.9338465 1046 -2.382586 -3.821743 -1.33302 -0.9338465 `pclass3rd*h(4-sibsp)` `pclass3rd*sexmale` `h(age-32)` 1045 0.2493061 -0.3861795 -1.021845 1046 0.2493061 -0.3861795 -1.021845 > # intercept only model > > cat("a.intercept.only: intercept only logistic model\n\n") a.intercept.only: intercept only logistic model > # This seed chosen so call to earth below has one predictor model in 1st > # cv fold and intercept-only in 2nd cv fold, that way we test both. > set.seed(3) > df <- data.frame(aaa = round(runif(18)), bbb = runif(18), ccc = rnorm(18)) > a.intercept.only <- earth(aaa ~ bbb + ccc, data = df, glm=list(family=binomial), trace=1, nfold=2) x[18,2] with colnames bbb ccc y[18,1] with colname aaa, and values 0, 1, 0, 0, 1, 1, 0, 0, 1, 1,... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0) After forward pass GRSq -3.791 RSq 0.188 Prune backward penalty 2 nprune null: selected 1 of 5 terms, and 0 of 2 preds After pruning pass GRSq 0 RSq 0 earth.glm: intercept-only earth model GLM aaa devratio 0.00 dof 17/17 iters 4 Full model GRSq 0.000 RSq 0.000, starting cross validation CV fold 1 CVRSq -1.032 n.oof 9 50% n.infold.nz 6 67% n.oof.nz 6 67% CV fold 2 CVRSq 0.000 n.oof 9 50% n.infold.nz 6 67% n.oof.nz 6 67% CV all CVRSq -0.516 n.infold.nz 12 67% > show.earth.models(a.intercept.only) Print a.intercept.only GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 22.9145 17 22.9145 17 0 24.91 4 1 Earth selected 1 of 5 terms, and 0 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Importance: bbb-unused, ccc-unused Number of terms at each degree of interaction: 1 (intercept only model) Earth GCV 0.2491349 RSS 4 GRSq 0 RSq 0 CVRSq -0.515968 Summary a.intercept.only Call: earth(formula=aaa~bbb+ccc, data=df, trace=1, glm=list(family=binomial), nfold=2) GLM coefficients aaa (Intercept) 0.6931472 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 22.9145 17 22.9145 17 0 24.91 4 1 Earth selected 1 of 5 terms, and 0 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Importance: bbb-unused, ccc-unused Number of terms at each degree of interaction: 1 (intercept only model) Earth GCV 0.2491349 RSS 4 GRSq 0 RSq 0 CVRSq -0.515968 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 1.50 sd 0.71 nvars 0.50 sd 0.71 CVRSq sd ClassRate sd MaxErr sd AUC sd MeanDev sd CalibInt -0.516 0.73 0.611 0.079 0.995 1.18 0.583 0.118 1.97 0.993 0.808 sd CalibSlope sd 0.162 NA NA Summary a.intercept.only digits=3, details=TRUE Call: earth(formula=aaa~bbb+ccc, data=df, trace=1, glm=list(family=binomial), nfold=2) Earth coefficients aaa (Intercept) 0.667 GLM coefficients aaa (Intercept) 0.693 GLM deviance residuals: Min 1Q Median 3Q Max -1.482 -1.482 0.901 0.901 0.901 GLM coefficients (family binomial, link logit) Estimate Std. Error z value Pr(>|z|) (Intercept) 0.693 0.500 1.39 0.17 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 22.9 17 22.9 17 0 24.9 4 1 Earth selected 1 of 5 terms, and 0 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Importance: bbb-unused, ccc-unused Number of terms at each degree of interaction: 1 (intercept only model) Earth GCV 0.249 RSS 4 GRSq 0 RSq 0 CVRSq -0.516 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 1.50 sd 0.71 nvars 0.50 sd 0.71 CVRSq sd ClassRate sd MaxErr sd AUC sd MeanDev sd CalibInt -0.516 0.73 0.611 0.079 0.995 1.18 0.583 0.118 1.97 0.993 0.808 sd CalibSlope sd 0.162 NA NA evimp a.intercept.only nsubsets gcv rss evimp a.intercept.only trim=FALSE nsubsets gcv rss bbb-unused 0 0.0 0.0 ccc-unused 0 0.0 0.0 glm params: epsilon 1e-08 maxit 25 trace FALSE family binomial link logit plotmo a.intercept.only plotmo grid: bbb ccc 0.3547735 0.06386657 ------------------------------------------------------------------------------- > cat("\nsummary(a.intercept.only, details=TRUE)\n\n", sep="") summary(a.intercept.only, details=TRUE) > print(summary(a.intercept.only, details=TRUE)) Call: earth(formula=aaa~bbb+ccc, data=df, trace=1, glm=list(family=binomial), nfold=2) Earth coefficients aaa (Intercept) 0.6666667 GLM coefficients aaa (Intercept) 0.6931472 GLM deviance residuals: Min 1Q Median 3Q Max -1.4823038 -1.4823038 0.9005166 0.9005166 0.9005166 GLM coefficients (family binomial, link logit) Estimate Std. Error z value Pr(>|z|) (Intercept) 0.6931472 0.4999999 1.38629 0.16566 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 22.9145 17 22.9145 17 0 24.91 4 1 Earth selected 1 of 5 terms, and 0 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Importance: bbb-unused, ccc-unused Number of terms at each degree of interaction: 1 (intercept only model) Earth GCV 0.2491349 RSS 4 GRSq 0 RSq 0 CVRSq -0.515968 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 1.50 sd 0.71 nvars 0.50 sd 0.71 CVRSq sd ClassRate sd MaxErr sd AUC sd MeanDev sd CalibInt -0.516 0.73 0.611 0.079 0.995 1.18 0.583 0.118 1.97 0.993 0.808 sd CalibSlope sd 0.162 NA NA > printh(predict(a.intercept.only)) === predict(a.intercept.only) aaa [1,] 0.6931472 [2,] 0.6931472 [3,] 0.6931472 [4,] 0.6931472 [5,] 0.6931472 [6,] 0.6931472 [7,] 0.6931472 [8,] 0.6931472 [9,] 0.6931472 [10,] 0.6931472 [11,] 0.6931472 [12,] 0.6931472 [13,] 0.6931472 [14,] 0.6931472 [15,] 0.6931472 [16,] 0.6931472 [17,] 0.6931472 [18,] 0.6931472 > printh(predict(a.intercept.only, type="link")) === predict(a.intercept.only, type = "link") aaa [1,] 0.6931472 [2,] 0.6931472 [3,] 0.6931472 [4,] 0.6931472 [5,] 0.6931472 [6,] 0.6931472 [7,] 0.6931472 [8,] 0.6931472 [9,] 0.6931472 [10,] 0.6931472 [11,] 0.6931472 [12,] 0.6931472 [13,] 0.6931472 [14,] 0.6931472 [15,] 0.6931472 [16,] 0.6931472 [17,] 0.6931472 [18,] 0.6931472 > printh(predict(a.intercept.only, type="response")) === predict(a.intercept.only, type = "response") aaa [1,] 0.6666667 [2,] 0.6666667 [3,] 0.6666667 [4,] 0.6666667 [5,] 0.6666667 [6,] 0.6666667 [7,] 0.6666667 [8,] 0.6666667 [9,] 0.6666667 [10,] 0.6666667 [11,] 0.6666667 [12,] 0.6666667 [13,] 0.6666667 [14,] 0.6666667 [15,] 0.6666667 [16,] 0.6666667 [17,] 0.6666667 [18,] 0.6666667 > printh(predict(a.intercept.only, type="earth")) === predict(a.intercept.only, type = "earth") aaa [1,] 0.6666667 [2,] 0.6666667 [3,] 0.6666667 [4,] 0.6666667 [5,] 0.6666667 [6,] 0.6666667 [7,] 0.6666667 [8,] 0.6666667 [9,] 0.6666667 [10,] 0.6666667 [11,] 0.6666667 [12,] 0.6666667 [13,] 0.6666667 [14,] 0.6666667 [15,] 0.6666667 [16,] 0.6666667 [17,] 0.6666667 [18,] 0.6666667 > g <- a.intercept.only$glm.list[[1]] > printh(predict(g, type="link")) === predict(g, type = "link") 1 2 3 4 5 6 7 8 0.6931472 0.6931472 0.6931472 0.6931472 0.6931472 0.6931472 0.6931472 0.6931472 9 10 11 12 13 14 15 16 0.6931472 0.6931472 0.6931472 0.6931472 0.6931472 0.6931472 0.6931472 0.6931472 17 18 0.6931472 0.6931472 > printh(predict(g, type="response")) === predict(g, type = "response") 1 2 3 4 5 6 7 8 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 9 10 11 12 13 14 15 16 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 17 18 0.6666667 0.6666667 > > new.df <- df[3:5, ] > printh(predict(a.intercept.only, type="response")) === predict(a.intercept.only, type = "response") aaa [1,] 0.6666667 [2,] 0.6666667 [3,] 0.6666667 [4,] 0.6666667 [5,] 0.6666667 [6,] 0.6666667 [7,] 0.6666667 [8,] 0.6666667 [9,] 0.6666667 [10,] 0.6666667 [11,] 0.6666667 [12,] 0.6666667 [13,] 0.6666667 [14,] 0.6666667 [15,] 0.6666667 [16,] 0.6666667 [17,] 0.6666667 [18,] 0.6666667 > printh(predict(a.intercept.only, newdata=new.df, trace=1, type="link")) === predict(a.intercept.only, newdata = new.df, trace = 1, type = "link")get.earth.x from model.matrix.earth from predict.earth: x[3,3]: aaa bbb ccc 3 0 0.22820188 -0.5784837 4 0 0.01532989 -0.9423007 5 1 0.12898156 -0.2037282 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[3,2]: bbb ccc 3 0.22820188 -0.5784837 4 0.01532989 -0.9423007 5 0.12898156 -0.2037282 predict.earth with newdata: bx[3,1]: (Intercept) 1 1 2 1 3 1 predict.earth: returning glm link predictions aaa [1,] 0.6931472 [2,] 0.6931472 [3,] 0.6931472 > printh(predict(a.intercept.only, newdata=new.df, trace=1, type="response")) === predict(a.intercept.only, newdata = new.df, trace = 1, type = "response")get.earth.x from model.matrix.earth from predict.earth: x[3,3]: aaa bbb ccc 3 0 0.22820188 -0.5784837 4 0 0.01532989 -0.9423007 5 1 0.12898156 -0.2037282 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[3,2]: bbb ccc 3 0.22820188 -0.5784837 4 0.01532989 -0.9423007 5 0.12898156 -0.2037282 predict.earth with newdata: bx[3,1]: (Intercept) 1 1 2 1 3 1 predict.earth: returning glm response predictions aaa [1,] 0.6666667 [2,] 0.6666667 [3,] 0.6666667 > printh(predict(a.intercept.only, newdata=new.df, type="earth")) === predict(a.intercept.only, newdata = new.df, type = "earth") aaa [1,] 0.6666667 [2,] 0.6666667 [3,] 0.6666667 > printh(predict(a.intercept.only, newdata=new.df, type="class")) === predict(a.intercept.only, newdata = new.df, type = "class") aaa [1,] 1 [2,] 1 [3,] 1 > # cat("Expect Warning: predict.earth: returning the earth (not glm) terms\n") > printh(predict(a.intercept.only, newdata=new.df, type="terms")) === predict(a.intercept.only, newdata = new.df, type = "terms")Warning: predict.earth: returning the earth (not glm) terms [1,] [2,] [3,] > > set.seed(1235) > a <- earth(survived ~ ., data=etitanic, glm=list(family=binomial), nfold=2) > plot.earth.models(list(a.intercept.only, a), main="plot.earth.models\nlist(a.intercept.only, a)") > plot.earth.models(list(a, a.intercept.only), main="plot.earth.models\nlist(a, a.intercept.only)", legend.pos="topleft", jitter=.01) > # nothing will plot for the next call > plot.earth.models(list(a.intercept.only, a.intercept.only), main="plot.earth.models\nlist(a.intercept.only, a.intercept.only)") > > # test position of legend and "intercep-only model" message when only one term in model > a.intercept.pruned <- update(a.intercept.only, nprune=1, nfold=1) update.earth: using 18 by 3 data argument from original call to earth x[18,2] with colnames bbb ccc y[18,1] with colname aaa, and values 0, 1, 0, 0, 1, 1, 0, 0, 1, 1,... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0) After forward pass GRSq -3.791 RSq 0.188 nprune=1 Prune backward penalty 2 nprune 1: selected 1 of 5 terms, and 0 of 2 preds After pruning pass GRSq 0 RSq 0 earth.glm: intercept-only earth model GLM aaa devratio 0.00 dof 17/17 iters 4 > show.earth.models(a.intercept.pruned) Print a.intercept.pruned GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 22.9145 17 22.9145 17 0 24.91 4 1 Earth selected 1 of 5 terms, and 0 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Importance: bbb-unused, ccc-unused Number of terms at each degree of interaction: 1 (intercept only model) Earth GCV 0.2491349 RSS 4 GRSq 0 RSq 0 Summary a.intercept.pruned Call: earth(formula=aaa~bbb+ccc, data=df, trace=1, glm=list(family=binomial), nprune=1, nfold=1) GLM coefficients aaa (Intercept) 0.6931472 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 22.9145 17 22.9145 17 0 24.91 4 1 Earth selected 1 of 5 terms, and 0 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Importance: bbb-unused, ccc-unused Number of terms at each degree of interaction: 1 (intercept only model) Earth GCV 0.2491349 RSS 4 GRSq 0 RSq 0 Summary a.intercept.pruned decomp="none", digits=5, fixed.point=FALSE, details=TRUE Call: earth(formula=aaa~bbb+ccc, data=df, trace=1, glm=list(family=binomial), nprune=1, nfold=1) Earth coefficients aaa (Intercept) 0.66667 GLM coefficients aaa (Intercept) 0.69315 GLM deviance residuals: Min 1Q Median 3Q Max -1.48230 -1.48230 0.90052 0.90052 0.90052 GLM coefficients (family binomial, link logit) Estimate Std. Error z value Pr(>|z|) (Intercept) 0.69315 0.50000 1.3863 0.1657 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 22.91 17 22.91 17 0 24.9 4 1 Earth selected 1 of 5 terms, and 0 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Importance: bbb-unused, ccc-unused Number of terms at each degree of interaction: 1 (intercept only model) Earth GCV 0.24913 RSS 4 GRSq 0 RSq 0 evimp a.intercept.pruned nsubsets gcv rss evimp a.intercept.pruned trim=FALSE nsubsets gcv rss bbb-unused 0 0.0 0.0 ccc-unused 0 0.0 0.0 glm params: epsilon 1e-08 maxit 25 trace FALSE family binomial link logit plotmo a.intercept.pruned plotmo grid: bbb ccc 0.3547735 0.06386657 ------------------------------------------------------------------------------- > > # misc tests > > cat("---misc 1---\n") ---misc 1--- > sex1 <- factor(rep(c("male", "female"), times=c(6,6))) > sex2 <- factor(rep(c("male", "female"), times=c(6,6))) > earth(numdead, cbind(sex1, sex2, sex1), trace=1) # one duplicate name x[12,1] with colname numdead, and values 1, 4, 9, 13, 18, 20, 0, 2, 6,... y[12,3] with colnames sex1 sex2 sex1.1 Forward pass term 1, 2, 4 RSq changed by less than 0.001 at 3 terms (DeltaRSq 0) After forward pass GRSq -3.446 RSq 0.081 Prune backward penalty 2 nprune null: selected 1 of 3 terms, and 0 of 1 preds After pruning pass GRSq 0 RSq 0 Selected 1 of 3 terms, and 0 of 1 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: numdead-unused Number of terms at each degree of interaction: 1 (intercept only model) GCV RSS GRSq RSq sex1 0.2975207 3 0 0 sex2 0.2975207 3 0 0 sex1.1 0.2975207 3 0 0 All 0.8925620 9 0 0 > sex1 <- factor(rep(c("male", "female"), times=c(6,6))) > sex2 <- factor(rep(c("male", "female"), times=c(6,6))) > earth(numdead, cbind(sex1, sex2, sex1, sex1), trace=1) # two duplicate names x[12,1] with colname numdead, and values 1, 4, 9, 13, 18, 20, 0, 2, 6,... y[12,4] with colnames sex1 sex2 sex1.1 sex1.2 Forward pass term 1, 2, 4 RSq changed by less than 0.001 at 3 terms (DeltaRSq 0) After forward pass GRSq -3.446 RSq 0.081 Prune backward penalty 2 nprune null: selected 1 of 3 terms, and 0 of 1 preds After pruning pass GRSq 0 RSq 0 Selected 1 of 3 terms, and 0 of 1 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: numdead-unused Number of terms at each degree of interaction: 1 (intercept only model) GCV RSS GRSq RSq sex1 0.2975207 3 0 0 sex2 0.2975207 3 0 0 sex1.1 0.2975207 3 0 0 sex1.2 0.2975207 3 0 0 All 1.1900826 12 0 0 > > # test column expansion when y is a data frame in earth.default > > cat("---misc 2---\n") ---misc 2--- > ldose <- rep(0:5, 2) - 2 > ldose1 <- c(0.1, 1.2, 2.3, 3.4, 4.5, 5.6, 0.3, 1.4, 2.5, 3.6, 4.7, 5.8) > sex <- factor(rep(c("male", "female"), times=c(6,6))) > sex2 <- sex > sex3 <- factor(rep(c("male", "female", "andro"), times=c(6,4,2))) > fac3 <- factor(c("lev2", "lev2", "lev1", "lev1", "lev3", "lev3", + "lev2", "lev2", "lev1", "lev1", "lev3", "lev3")) > facdead <- factor(c("dead2", "dead2", "dead3", "dead1", "dead3", "dead3", + "dead1", "dead2", "dead1", "dead1", "dead3", "dead3")) > > isex <- as.double(sex3) # sex3 as an index > df1 <- data.frame(sex2, d_=facdead, sex, sex, isex) > af <- earth(data.frame(sex3,ldose,fac3,isex), df1, trace=1, pmethod=PMETHOD, nk=NK, degree=2) x[12,6] with colnames sex3female sex3male ldose fac3lev2 fac3lev3 isex y[12,7] with colnames sex2 d_dead1 d_dead2 d_dead3 sex sex.1 isex Forward pass term 1, 2, 4 Reached nk 6 After forward pass GRSq 0.297 RSq 0.791 Prune none penalty 3 nprune null: selected 3 of 3 terms, and 2 of 6 preds After pruning pass GRSq 0.297 RSq 0.791 > > cat("---misc 3---\n") ---misc 3--- > > # strings in input matrices, get converted to factors and a warning issued > # TODO would like to improve the error message (says 'x' even when 'y') > # TODO Apr 2013 warning no longer issued (R changed), is that ok? > > ldose <- rep(0:5, 2) - 2 > ldose1 <- c(0.1, 1.2, 2.3, 3.4, 4.5, 5.6, 0.3, 1.4, 2.5, 3.6, 4.7, 5.8) > sex2 <- rep(c("male", "female"), times=c(6,6)) > # y cannot be a character variable > expect.err(try(earth(sex2, sex2, trace=1)), "y is a character variable: ") Error : y is a character variable: "male", "male", "male", ... Got error as expected from try(earth(sex2, sex2, trace = 1)) > expect.err(try(earth(sex2~ldose1, trace=1)), "y is a character variable: ") Error : y is a character variable: "male", "male", "male", ... Got error as expected from try(earth(sex2 ~ ldose1, trace = 1)) > # but note that this is ok > earth(sex2, data.frame(sex2=sex2), trace=1) x[12,1] with colname xmale, and values 1, 1, 1, 1, 1, 1, 0, 0, 0, 0,... y[12,1] with colname sex2, and values 1, 1, 1, 1, 1, 1, 0, 0, 0, 0,... Forward pass term 1, 2 Reached maximum RSq 0.9990 at 3 terms, 2 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Prune backward penalty 2 nprune null: selected 2 of 2 terms, and 1 of 1 preds After pruning pass GRSq 1 RSq 1 Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: Reached maximum RSq 0.9990 at 2 terms Importance: xmale Number of terms at each degree of interaction: 1 1 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > > # test update.earth with bpairs argument (for now always do forward pass if bpairs) > > cat("---misc 4---\n") ---misc 4--- > volumei <- as.integer(trees$Volume) > x1 <- trees$Height > a <- earth(x1, cbind(volumei, 100-volumei), glm=list(family=binomial)) > update(a, trace=1, glm=list(family=binomial)) update.earth: using 31 by 1 x argument from original call to earth update.earth: using 31 by 2 y argument from original call to earth x[31,1] with colname x1, and values 70, 65, 63, 72, 81, 83, 66, 7... y[31,2] with colnames volumei cbind(volumei,100-volumei)2 earth and glm: unweighted Response columns volumei and cbind(volumei,100-volumei)2 are a binomial pair (3100 obs in total) yfrac[31,1] with colname volumei, and values 0.1, 0.1, 0.1, 0.16, 0.18, 0... Skipped forward pass Prune backward penalty 2 nprune null: selected 2 of 5 terms, and 1 of 1 preds After pruning pass GRSq 0.239 RSq 0.338 GLM volumei devratio 0.33 dof 29/30 iters 4 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 382.433 30 255.079 29 0.333 405.1 4 1 Earth selected 2 of 5 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Importance: x1 Number of terms at each degree of interaction: 1 1 (additive model) Earth GCV 0.02132819 RSS 0.5393967 GRSq 0.2394863 RSq 0.337508 > a <- earth(x1, cbind(volumei, 100-volumei), glm=list(family=binomial)) > update(a, trace=1, glm=list(family=binomial)) update.earth: using 31 by 1 x argument from original call to earth update.earth: using 31 by 2 y argument from original call to earth x[31,1] with colname x1, and values 70, 65, 63, 72, 81, 83, 66, 7... y[31,2] with colnames volumei cbind(volumei,100-volumei)2 earth and glm: unweighted Response columns volumei and cbind(volumei,100-volumei)2 are a binomial pair (3100 obs in total) yfrac[31,1] with colname volumei, and values 0.1, 0.1, 0.1, 0.16, 0.18, 0... Skipped forward pass Prune backward penalty 2 nprune null: selected 2 of 5 terms, and 1 of 1 preds After pruning pass GRSq 0.239 RSq 0.338 GLM volumei devratio 0.33 dof 29/30 iters 4 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 382.433 30 255.079 29 0.333 405.1 4 1 Earth selected 2 of 5 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Importance: x1 Number of terms at each degree of interaction: 1 1 (additive model) Earth GCV 0.02132819 RSS 0.5393967 GRSq 0.2394863 RSq 0.337508 > > source("test.epilog.R") earth/inst/slowtests/check.models.equal.R0000644000176200001440000002471113444563366020214 0ustar liggesusers# check.models.equal.R almost.equal <- function(x, y, max=1e-8, msg="") { stopifnot(max >= 0 && max < .1) almost.equal <- length(x) == length(y) && max(abs(x - y)) < max if(!almost.equal) { xname <- deparse(substitute(x)) yname <- deparse(substitute(y)) printf("\n---%s-------------------------------------------------------\n", msg) printf("not almost.equal(%s, %s, max=%g)\n\n", xname, yname, max) printf("%s:\n", xname) print(x) printf("\n%s:\n", yname) print(y) printf("----------------------------------------------------------\n\n") } almost.equal } check.almost.equal <- function(x, y, max=1e-8, msg="", verbose=FALSE) { if(any(y == 0)) diff <- x - y else diff <- (x - y) / y if(any(abs(diff) > max)) { cat(msg, "\n1st matrix:\n", sep="") print(x) cat("2nd matrix:\n") print(y) cat("diff:\n") print(diff) stop("check.almost.equal failed for ", msg, call.=FALSE) } if(verbose) cat(msg, "OK\n") } check.same <- function(mod1, mod2, msg="", allow.different.names=FALSE, max=0) { if(!identical(mod1, mod2)) { stop.with.msg = TRUE if(!is.null(dim(mod1)) && !is.null(dim(mod2))) { # check if it is the column names mod1a <- mod1 mod2a <- mod2 colnames(mod1a) <- NULL colnames(mod2a) <- NULL if(identical(mod1a, mod2a)) { cat("mod1", msg, "\n") print(colnames(mod1)) cat("mod2", msg, "\n") print(colnames(mod2)) cat("\n") if(allow.different.names) { warning(msg, " has different column names but is otherwise identical, see above messages\n", call.=FALSE) stop.with.msg = FALSE } else stop(msg, " has different column names but is otherwise identical, see above messages", call.=FALSE) } # check if it is the row names mod1a <- mod1 mod2a <- mod2 rownames(mod1a) <- NULL rownames(mod2a) <- NULL if(identical(mod1a, mod2a)) { cat("\nm1", msg, "\n"); print(head(mod1)); cat("\nm2", msg, "\n"); print(head(mod2)); cat("\n") if(allow.different.names) { warning(msg, " has different row names but is otherwise identical, see above messages\n", call.=FALSE) stop.with.msg = FALSE } else stop(msg, " has different row names but is otherwise identical, see above messages", call.=FALSE) } } if(max != 0) { same <- almost.equal(mod1, mod2, max=max, msg=msg) stop.with.msg = FALSE } if(stop.with.msg) { cat("\nm1", msg, "\n"); print(mod1); cat("\nm2", msg, "\n"); print(mod2); cat("\ndifference mod1-mod2", msg, "\n"); try(print(mod1-mod2)); cat("\n") stop(msg, " don't match, see above messages (max=", max, ")", call.=FALSE) } } } check.models.equal <- function(mod1, mod2, msg="", check.subsets=TRUE, allow.different.names=FALSE, newdata=NULL) { mod1$call <- NULL mod2$call <- NULL mod1$trace <- NULL mod2$trace <- NULL msg.colon <- if(nchar(msg) != 0) paste0(msg, ": ") else "" if(identical(mod1, mod2)) cat(msg.colon, "models identical\n", sep="") else { cat(msg.colon, "models not identical\n\n", sep=""); # cat("mod1\n"); print(summary(mod1)); cat("mod2\n"); print(summary(mod2)); cat("\n") # TODO why do we need a nonzero max here and below? check.same(mod1$bx, mod2$bx, "bx", allow.different.names=allow.different.names, max=1e-14) check.same(mod1$coefficients, mod2$coefficients, "coefficients", allow.different.names=allow.different.names, max=1e-14) check.same(mod1$dirs, mod2$dirs, "dirs", allow.different.names=allow.different.names) check.same(mod1$cuts, mod2$cuts, "cuts", allow.different.names=allow.different.names) check.same(mod1$residuals, mod2$residuals, "residuals", max=1e-14, allow.different.names=allow.different.names) check.same(mod1$selected.terms, mod2$selected.terms, "selected.terms", allow.different.names=allow.different.names) if(check.subsets) { # leaps and xtx pruning can give different prune.terms, so skip test check.same(mod1$prune.terms, mod2$prune.terms, "prune.terms") check.same(mod1$rss.per.response, mod2$rss.per.response, "rss.per.response", max=1e-14) check.same(mod1$rsq.per.response, mod2$rsq.per.response, "rsq.per.response") check.same(mod1$gcv.per.response, mod2$gcv.per.response, "gcv.per.response") check.same(mod1$grsq.per.response, mod2$grsq.per.response, "grsq.per.response") check.same(mod1$rss.per.subset, mod2$rss.per.subset, "rss.per.subset", max=1e-14) check.same(mod1$gcv.per.subset, mod2$gcv.per.subset, "gcv.per.subset", max=1e-14) } check.same(predict(mod1), predict(mod2), "predict with no newdata, default type", allow.different.names=allow.different.names) check.same(predict(mod1, type="link"), predict(mod2, type="link"), "predict with no newdata, type=\"link\"", allow.different.names=allow.different.names) check.same(predict(mod1, type="response"), predict(mod2, type="response"), "predict with no newdata, type=\"response\"", allow.different.names=allow.different.names) check.same(predict(mod1, type="earth"), predict(mod2, type="earth"), "predict with no newdata, type=\"earth\"", allow.different.names=allow.different.names) if(!is.null(newdata)) { check.same(predict(mod1, newdata), predict(mod2, newdata), "predict with newdata, default type", allow.different.names=allow.different.names) check.same(predict(mod1, newdata, type="link"), predict(mod2, newdata, type="link"), "predict with newdata, , type=\"link\"", allow.different.names=allow.different.names) check.same(predict(mod1, newdata, type="response"), predict(mod2, newdata, type="response"), "predict with newdata, , type=\"response\"", allow.different.names=allow.different.names) check.same(predict(mod1, newdata, type="earth"), predict(mod2, newdata, type="earth"), "predict with newdata, , type=\"earth\"", allow.different.names=allow.different.names) } if(!almost.equal(mod1$rss, mod2$rss, msg=msg)) stop(msg.colon, "different rss") if(!almost.equal(mod1$rsq, mod2$rsq, msg=msg)) stop(msg.colon, "different rsq") if(mod1$rsq != mod2$rsq) cat("mod1$rsq ", mod1$rsq, " != mod2$rsq ", mod2$rsq, " (although almost equal)\n", sep="") if(!almost.equal(mod1$gcv, mod2$gcv, msg=msg)) stop(msg.colon, "different gcv") if(!almost.equal(mod1$grsq, mod2$grsq, msg=msg)) stop(msg.colon, "different grsq") form1 <- try(formula(mod1), silent=TRUE) form2 <- try(formula(mod2), silent=TRUE) if(!identical(form1, form2)) cat("Formulas differ: ", gsub("\n", "", format(form1)), "\nand: ", gsub("\n", "", format(form2)), "\n\n", sep="") else if(!identical(terms(mod1), terms(mod2))) cat("terms(mod1) != terms(mod2)\n", sep="") glm1 <- mod1$glm.list[[1]] glm2 <- mod2$glm.list[[1]] if(is.null(glm1) && !is.null(glm2)) cat(msg.colon, "mod2 has a GLM submodel but mod1 does not\n") else if(!is.null(glm1) && is.null(glm2)) cat(msg.colon, "mod1 has a GLM submodel but mod2 does not\n") else if(!is.null(glm1) && !is.null(glm2)) { if(identical(glm1, glm2)) cat(msg.colon, "glm submodels identical\n", sep="") else { if(!almost.equal(glm1$coefficients, glm2$coefficients, msg=msg)) stop(msg.colon, "different coefficients") if(!almost.equal(residuals(glm1), residuals(glm2), msg=msg)) stop(msg.colon, "different residuals") # I have the seen the following with a quasibinomial model with a zero weight else if(!almost.equal(glm1$residuals, glm2$residuals, msg=msg)) warning("residuals(glm1) == residuals(glm2) but glm1$residuals != glm2$residuals\n\n") if(!almost.equal(glm1$fitted.values, glm2$fitted.values, msg=msg)) stop(msg.colon, "different fitted.values") # cat("summary(glm.glm1, details=TRUE):\n") # print(summary(glm1, details=TRUE)) # cat("summary(glm.glm2, details=TRUE):\n") # print(summary(glm2, details=TRUE)) form1 <- try(formula(glm1), silent=TRUE) form2 <- try(formula(glm2), silent=TRUE) form1s <- paste0(gsub("\n", "", format(form1)), collapse="") form2s <- paste0(gsub("\n", "", format(form2)), collapse="") if(identical(form1s, form2s)) printf("%sglm submodel formula strings are identical: %s\n", msg.colon, form1s) if(!identical(form1, form2)) { if(identical(form1s, form2s)) cat(msg.colon, "but the actual glm submodel formulas differ ", "(classes are \"", class(form1)[1], "\" and \"", class(form2)[1], "\")\n", sep="") else cat(msg.colon, "glm submodel formulas differ: ", form1s, "\nand: ", form2s, "(classes are \"", class(form1)[1], "\" and \"", class(form2)[1], ")\"\n", sep="") } else if(!identical(terms(glm1), terms(glm2))) cat(msg.colon, "terms(glm1) != terms(glm2)\n", sep="") cat(msg.colon, "glm submodels not identical (but coefs, residuals, fitted.values are the same)\n", sep="") } } cat(msg.colon, "Models are equivalent, within numerical tolerances\n", sep="") } cat("\n") } earth/inst/slowtests/earth.times.R0000644000176200001440000001275713447040033016761 0ustar liggesusers# earth.times.R library(earth) library(mda) # for Hastie Tibs version of mars set.seed(2018) # for reproducibility printf <- function(format, ...) cat(sprintf(format, ...)) # like c printf # generate robot arm data from Friedman's Fast MARS paper robotarm <- function(n=1000, p=20) { robotarm1 <- function(x) { x. <- with(x, l1 * cos(theta1) - l2 * cos(theta1 + theta2) * cos(phi)) y <- with(x, l1 * sin(theta1) - l2 * sin(theta1 + theta2) * cos(phi)) z <- with(x, l2 * sin(theta2) * sin(phi)) sqrt(x.^2 + y^2 + z^2) } l1 <- runif(n, 0, 1) l2 <- runif(n, 0, 1) theta1 <- runif(n, 0, 2 * pi) theta2 <- runif(n, 0, 2 * pi) phi <- runif(n, -pi/2, pi/2) x <- cbind(l1, l2, theta1, theta2, phi) for (i in 1:(p-5)) # p-5 dummy variables, so p vars in total x <- cbind(x, runif(n, 0, 1)) x <- data.frame(x) y <- robotarm1(x) list(x=x, y=y) } spacer <- function() { cat(" |", " |\n", sep="") } test <- function(x, y, nk, degree, niter) { earth.time <- system.time(for (i in 1:niter) earth <- earth(x, y, nk=nk, degree=degree, minspan=0)) gcv.null <- earth$gcv.per.subset[1] grsq <- 1 - earth$gcv/gcv.null mars.time <- system.time(for (i in 1:niter) mars <- mars(x, y, degree=degree, nk=nk)) mars.grsq <- 1 - mars$gcv/gcv.null no.fastmars.time <- system.time(for (i in 1:niter) no.fastmars <- earth(x, y, nk=nk, degree=degree, minspan=0, fast.k=0)) no.betacache.time <- system.time(for (i in 1:niter) no.betacache <- earth(x, y, nk=nk, degree=degree, minspan=0, Use.beta.cache=FALSE)) minspan1.time <- system.time(for (i in 1:niter) minspan1 <- earth(x, y, nk=nk, degree=degree, minspan=1)) # dummy func to estimate time taken by an "allowed" function allowed.func <- function(degree, pred, parents) { if (degree > 0 && (parents[1] == 999 || pred == 999)) return(FALSE) # never get here TRUE } allowed.time <- system.time(for (i in 1:niter) allowed <- earth(x, y, nk=nk, degree=degree, minspan=0, allowed=allowed.func)) niter.weights <- 3 # weights code is very slow weights.time <- system.time(for (i in 1: niter.weights) weights <- earth(x, y, nk=nk, degree=degree, Force.weights=TRUE)) # Force.weights=TRUE with minspan=1 is extremely slow # if(nrow(x) < 1000) # weights.minspan1.time <- system.time(for (i in 1: niter.weights) # weights.minspan1 <- earth(x, y, nk=nk, degree=degree, Force.weights=TRUE, minspan=1)) # else { # too slow, skip # weights.minspan1.time <- NA # weights.minspan1 <- list(grsq=NA) # } format <- paste( # nk degree nterms time mars no-fast no-betacache minspan1 allowed weights "%2d %3d %4.0d %6.3f | %4.1f %5.1f %5.1f %5.1f %5.1f %7.0f ", # grsq mars no-fast minspan1 weights "| %4.2f %4.2f %4.2f %4.2f %4.2f\n", sep="") printf(format, nk, degree, length(earth$selected.terms), earth.time[1] / niter, mars.time[1] / earth.time[1], no.fastmars.time[1] / earth.time[1], no.betacache.time[1] / earth.time[1], minspan1.time[1] / earth.time[1], allowed.time[1] / earth.time[1], (weights.time[1] / earth.time[1]) * (niter / niter.weights), grsq, mars.grsq, no.fastmars$grsq, minspan1$grsq, weights$grsq) } print.header <- function () { printf("nk degree earth earth ") printf("| execution time ratio: ") printf("| grsq: \n") printf(" nterms time ") printf("| mars no-fastmars no-betacache minspan=1 allowed weights ") printf("| earth mars no-fastmars minspan=1 weights\n") spacer() } # data(trees) # x <- trees[, -3] # y <- trees[, 3] # niter <- 500 # repeat calls to earth niter times to average out time variation # printf("==== trees %d x %d ============\n\n", nrow(x), ncol(x)) # print.header() # test(x, y, nk=21, degree=1, niter=niter) # cat("\n") data(ozone1) x <- ozone1[,-1] y <- ozone1[,1] niter <- 50 printf("\n==== ozone %d x %d ============\n\n", nrow(x), ncol(x)) print.header() test(x, y, nk=5, degree=1, niter=niter) test(x, y, nk=5, degree=2, niter=niter) test(x, y, nk=5, degree=3, niter=niter) spacer() test(x, y, nk=21, degree=1, niter=niter) test(x, y, nk=21, degree=2, niter=niter) test(x, y, nk=21, degree=3, niter=niter) spacer() test(x, y, nk=51, degree=1, niter=niter) test(x, y, nk=51, degree=2, niter=niter) test(x, y, nk=51, degree=3, niter=niter) cat("\n") robotarm <- robotarm(n=1000, p=20) x <- robotarm$x y <- robotarm$y niter <- 10 # robot arm is slow (especially with Force.weights) so only do 10 iters printf("\n==== robot arm %d x %d ========\n\n", nrow(x), ncol(x)) print.header() test(x, y, nk=5, degree=1, niter=niter) test(x, y, nk=5, degree=2, niter=niter) test(x, y, nk=5, degree=3, niter=niter) spacer() test(x, y, nk=21, degree=1, niter=niter) test(x, y, nk=21, degree=2, niter=niter) test(x, y, nk=21, degree=3, niter=niter) spacer() test(x, y, nk=51, degree=1, niter=niter) test(x, y, nk=51, degree=2, niter=niter) test(x, y, nk=51, degree=3, niter=niter) cat("\n") earth/inst/slowtests/earth.times.bat0000755000176200001440000000021313514230362017312 0ustar liggesusers"C:\PROGRA~1\R\R-3.6.1\bin\x64\Rterm.exe" --vanilla --slave # test.weights.R > > source("test.prolog.R") > source("check.models.equal.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > check.equal <- function(x, y, msg="") + { + diff <- x - y + if (any(abs(diff) > 1e-8)) { + cat(msg, "\n1st matrix:\n", sep="") + print(x) + cat("\n2nd matrix:\n") + print(y) + cat("\ndiff:\n") + print(diff) + stop("check.equal failed for ", msg, call.=FALSE) + } + } > check.earth.lm.models.equal <- function(lm.mod, earth.mod) + { + lm.mod.name <- deparse(substitute(lm.mod)) + earth.mod.name <- deparse(substitute(earth.mod)) + msg <- sprint("%s vs %s", lm.mod.name, earth.mod.name) + check.equal(lm.mod$coefficients, earth.mod$coefficients, msg=sprint("%s coefficients", msg)) + check.equal(lm.mod$rss, earth.mod$rss, msg=sprint("%s rss", msg)) + check.equal(lm.mod$residuals, earth.mod$residuals, msg=sprint("%s residuals", msg)) + check.equal(summary(lm.mod)$r.squared, earth.mod$rsq, msg=sprint("%s rsq", msg)) + check.equal(summary(lm.mod)$r.squared, earth.mod$rsq.per.reponse[1], msg=sprint("%s rsq.per.response", msg)) + } > # artifical data > xxx <- 1:9 > yyy <- 1:9 > yyy[5] <- 9 > data <- data.frame(x=xxx, y=yyy) > colnames(data) <- c("x", "y") > > # Check against a linear model with weights, using linpreds. > # This also checks the backward pass's handling of weights. > > lm1 <- lm(y~., data=data) > a1 <- earth(y~., data=data, linpreds=TRUE) > check.earth.lm.models.equal(lm1, a1) > > weights <- c(1, 1, 1, 1, 1, 1, 1, 1, 1) > lm2 <- lm(y~., data=data, weights=weights) > a2 <- earth(y~., data=data, linpreds=TRUE, weights=weights) > check.earth.lm.models.equal(lm2, a2) > > # check that we can get the weights from the data as per lm > lm2.a <- lm(y~xxx, data=data, weights=x) # weights from model frame > a2.a <- earth(y~xxx, data=data, linpreds=TRUE, weights=x) # weights from model frame > a2.b <- earth(y~xxx, data=data, linpreds=TRUE, weights=xxx) # weights from global env > check.earth.lm.models.equal(lm2.a, a2.a) > check.earth.lm.models.equal(a2.b, a2.a) > > weights <- c(1, 2, 3, 1, 2, 3, 1, 2, 3) > lm3 <- lm(y~., data=data, weights=weights) > a3 <- earth(y~., data=data, linpreds=TRUE, weights=weights, trace=-1) > check.earth.lm.models.equal(lm3, a3) > > expect.err(try(earth(y~., data=data, wp=3, Scale.y=TRUE)), "Scale.y=TRUE is not allowed with wp") Error : Scale.y=TRUE is not allowed with wp (implementation restriction) Got error as expected from try(earth(y ~ ., data = data, wp = 3, Scale.y = TRUE)) > allthrees <- rep(3.0, length.out=nrow(data)) > options(warn=2) > expect.err(try(earth(allthrees~x, data=data)), "Cannot scale y (values are all equal to 3)") Error : (converted from warning) Cannot scale y (values are all equal to 3) Use Scale.y=FALSE to silence this warning Got error as expected from try(earth(allthrees ~ x, data = data)) > options(warn=1) > allthrees.mod <- earth(allthrees~x, data=data) Warning: Cannot scale y (values are all equal to 3) Use Scale.y=FALSE to silence this warning > print(summary(allthrees.mod)) Call: earth(formula=allthrees~x, data=data) coefficients (Intercept) 3 Selected 1 of 1 terms, and 0 of 1 predictors Termination condition: RSq changed by less than 0.001 at 1 term Importance: x-unused Number of terms at each degree of interaction: 1 (intercept only model) GCV 0 RSS 0 GRSq NaN RSq NaN > # Scale.y=FALSE allows us to use a response that is constant (silences the error message) > allthrees.mod.noscale <- earth(allthrees~x, data=data, Scale.y=FALSE) # intercept only > print(summary(allthrees.mod.noscale)) Call: earth(formula=allthrees~x, data=data, Scale.y=FALSE) coefficients (Intercept) 3 Selected 1 of 1 terms, and 0 of 1 predictors Termination condition: RSq changed by less than 0.001 at 1 term Importance: x-unused Number of terms at each degree of interaction: 1 (intercept only model) GCV 0 RSS 0 GRSq NaN RSq NaN > stopifnot(identical(allthrees.mod$coefficients, allthrees.mod.noscale$coefficients)) > > subset <- c(TRUE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE) > lm3.weights <- lm(y~., data=data, weights=weights, subset=subset) > a3.weights <- earth(y~., data=data, linpreds=TRUE, weights=weights, trace=-1, subset=subset) > check.earth.lm.models.equal(lm3.weights, a3.weights) > > lm4 <- lm(y~., data=data, weights=.1 * weights) > a4 <- earth(y~., data=data, linpreds=TRUE, weights=.1 * weights, + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) > cat("a4:\n") a4: > print(a4) Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 1e-08 at 2 terms Importance: x Weights: 0.1, 0.2, 0.3, 0.1, 0.2, 0.3, 0.1, 0.2, 0.3 Number of terms at each degree of interaction: 1 1 (additive model) GCV 0.3153798 RSS 2.838418 GRSq 0.7988523 RSq 0.7988523 > check.earth.lm.models.equal(lm4, a4) > > # We want to see the effect only on the forward pass, so disable the > # backward pass with penalty=-1. This also prevents "termination of the > # forward pass with a negative GRSq" with this artifical data. > # > # We can't use thresh=0, because then very small weights will still cause a usable > # reduction in RSq (remember that weights of zero are changed to very small weights > # in the current implementation). So instead we use thresh=1e-8. > # This is a problem only with this very artifical data. With real data, we > # want to use the standard thresh=.001, even with weights. > > cat("=== a5.noweights ===\n") === a5.noweights === > par(mfrow = c(2, 2)) > par(mar = c(3, 3, 3, 1)) > par(mgp = c(1.5, 0.5, 0)) > a5.noweights <- earth(y~., data=data, + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=3) x[9,1] with colname x, and values 1, 2, 3, 4, 5, 6, 7, 8, 9 y[9,1] with colname y, and values 1, 2, 3, 4, 9, 6, 7, 8, 9 Forward pass: minspan 1 endspan 1 x[9,1] 72 Bytes bx[9,21] 1.48 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.8768 0.8768 0.8768 1 x 5 2 3 1 4 0.9138 0.9138 0.03695 1 x 4 4 1 6 1.0000 1.0000 0.08623 1 x 6 5 1 final (max RSq) Reached maximum RSq 1.0000 at 7 terms, 5 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 7 terms, 5 terms used Subset size GRSq RSq DeltaGRSq nPreds 1 0.0000 0.0000 0.0000 0 2 0.6259 0.6259 0.6259 1 3 0.8768 0.8768 0.2509 1 4 0.9326 0.9326 0.0558 1 chosen 5 1.0000 1.0000 0.0674 1 Prune backward penalty -1 nprune null: selected 5 of 5 terms, and 1 of 1 preds After pruning pass GRSq 1 RSq 1 > plotmo(a5.noweights, col.response=2, do.par=F, main="a5.noweights", grid.col="gray", jitter=0) > # TODO why does this model differ from the above model? > a5.noweights.force <- earth(y~., data=data, Force.weights=T, + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=3) x[9,1] with colname x, and values 1, 2, 3, 4, 5, 6, 7, 8, 9 y[9,1] with colname y, and values 1, 2, 3, 4, 9, 6, 7, 8, 9 weights[9]: 1, 1, 1, 1, 1, 1, 1, 1, 1 Forward pass: minspan 1 endspan 1 x[9,1] 72 Bytes bx[9,21] 1.48 kB weighted GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.8768 0.8768 0.8768 1 x 5 2 3 1 4 0.9138 0.9138 0.03695 1 x 6 4 1 6 1.0000 1.0000 0.08623 1 x 4 5 1 final (max RSq) Reached maximum RSq 1.0000 at 7 terms, 5 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 7 terms, 5 terms used Subset size GRSq RSq DeltaGRSq nPreds 1 0.0000 0.0000 0.0000 0 2 0.6259 0.6259 0.6259 1 3 0.8768 0.8768 0.2509 1 4 0.9326 0.9326 0.0558 1 chosen 5 1.0000 1.0000 0.0674 1 Prune backward penalty -1 nprune null: selected 5 of 5 terms, and 1 of 1 preds After pruning pass GRSq 1 RSq 1 > cat("a5.noweights.force:\n") a5.noweights.force: > print(a5.noweights.force) Selected 5 of 5 terms, and 1 of 1 predictors Termination condition: Reached maximum RSq 1.0000 at 5 terms Importance: x Weights: 1, 1, 1, 1, 1, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 4 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > plotmo(a5.noweights.force, col.response=2, do.par=F, main="a5.noweights.force", grid.col="gray", jitter=0) > > cat("=== a6.azeroweight ===\n") === a6.azeroweight === > a6.azeroweight <- earth(y~., data=data, weights=c(1, 1, 1, 1, 0, 1, 1, 1, 1), + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=3) x[9,1] with colname x, and values 1, 2, 3, 4, 5, 6, 7, 8, 9 y[9,1] with colname y, and values 1, 2, 3, 4, 9, 6, 7, 8, 9 weights[9]: 1, 1, 1, 1, 0, 1, 1, 1, 1 Forward pass: minspan 1 endspan 1 x[9,1] 72 Bytes bx[9,21] 1.48 kB weighted GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 1.0000 1.0000 1 1 x 1< 2 1 final (max RSq) Reached maximum RSq 1.0000 at 3 terms, 2 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 3 terms, 2 terms used Using EvalSubsetsUsingXtx (rather than leaps) because ncol(bx) <= 2 Subset size GRSq RSq DeltaGRSq nPreds 1 0.0000 0.0000 0.0000 0 chosen 2 1.0000 1.0000 1.0000 1 Prune backward penalty -1 nprune null: selected 2 of 2 terms, and 1 of 1 preds After pruning pass GRSq 1 RSq 1 > cat("a6.azeroweight:\n") a6.azeroweight: > print(a6.azeroweight) Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: Reached maximum RSq 1.0000 at 2 terms Importance: x Weights: 1, 1, 1, 1, 0, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 1 (additive model) GCV 1.580247e-08 RSS 1.422222e-07 GRSq 1 RSq 1 > plotmo(a6.azeroweight, col.response=2, do.par=F, main="a6.azeroweight", grid.col="gray", jitter=0) > > cat("=== a7.asmallweight ===\n") # different set of weights (pick up notch in data, but with different forward pass RSq's) === a7.asmallweight === > a7.asmallweight <- earth(y~., data=data, weights=c(1, 1, 1, 1, .5, 1, 1, 1, 1), + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=3) x[9,1] with colname x, and values 1, 2, 3, 4, 5, 6, 7, 8, 9 y[9,1] with colname y, and values 1, 2, 3, 4, 9, 6, 7, 8, 9 weights[9]: 1, 1, 1, 1, 0.5, 1, 1, 1, 1 Forward pass: minspan 1 endspan 1 x[9,1] 72 Bytes bx[9,21] 1.48 kB weighted GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.9138 0.9138 0.9138 1 x 5 2 3 1 4 0.9323 0.9323 0.01846 1 x 6 4 1 6 1.0000 1.0000 0.0677 1 x 4 5 1 final (max RSq) Reached maximum RSq 1.0000 at 7 terms, 5 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 7 terms, 5 terms used Subset size GRSq RSq DeltaGRSq nPreds 1 0.0000 0.0000 0.0000 0 2 0.8500 0.8500 0.8500 1 3 0.9243 0.9243 0.0743 1 4 0.9323 0.9323 0.0080 1 chosen 5 1.0000 1.0000 0.0677 1 Prune backward penalty -1 nprune null: selected 5 of 5 terms, and 1 of 1 preds After pruning pass GRSq 1 RSq 1 > plotmo(a7.asmallweight, col.response=2, do.par=F, main="a7.asmallweight", grid.col="gray", jitter=0) > > cat("=== a7.xy.asmallweight ===\n") # x,y interface === a7.xy.asmallweight === > a7.xy.asmallweight <- earth(xxx, yyy, weights=c(1, 1, 1, 1, .5, 1, 1, 1, 1), + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=3) x[9,1] with colname x, and values 1, 2, 3, 4, 5, 6, 7, 8, 9 y[9,1] with colname yyy, and values 1, 2, 3, 4, 9, 6, 7, 8, 9 weights[9]: 1, 1, 1, 1, 0.5, 1, 1, 1, 1 Forward pass: minspan 1 endspan 1 x[9,1] 72 Bytes bx[9,21] 1.48 kB weighted GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.9138 0.9138 0.9138 1 x 5 2 3 1 4 0.9323 0.9323 0.01846 1 x 6 4 1 6 1.0000 1.0000 0.0677 1 x 4 5 1 final (max RSq) Reached maximum RSq 1.0000 at 7 terms, 5 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 7 terms, 5 terms used Subset size GRSq RSq DeltaGRSq nPreds 1 0.0000 0.0000 0.0000 0 2 0.8500 0.8500 0.8500 1 3 0.9243 0.9243 0.0743 1 4 0.9323 0.9323 0.0080 1 chosen 5 1.0000 1.0000 0.0677 1 Prune backward penalty -1 nprune null: selected 5 of 5 terms, and 1 of 1 preds After pruning pass GRSq 1 RSq 1 > check.earth.lm.models.equal(a7.xy.asmallweight, a7.xy.asmallweight) > > cat("=== a8 ===\n") === a8 === > par(mfrow = c(3, 2)) # new page > par(mar = c(3, 3, 3, 1)) > par(mgp = c(1.5, 0.5, 0)) > data$y <- c(0, 0, 0, 1, 0, 1, 1, 1, 1) != 0 > > # glm models first without weights > a8 <- earth(y~., data=data, + linpreds=TRUE, glm=list(family=binomial), + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) > plotmo(a8, + col.response=2, do.par=F, main="a8 glm no weights\ntype=\"response\"", + grid.col="gray", ylim=c(-.2, 1.2), jitter=0) > plotmo(a8, type="earth", + col.response=2, do.par=F, main="a8 glm no weights\ntype=\"earth\"", + grid.col="gray", ylim=c(-.2, 1.2), jitter=0) > glm.a8 <- glm(y~., data=data, family=binomial) > stopifnot(coefficients(a8$glm.list[[1]]) == coefficients(glm.a8)) > > cat("=== a8.weights ===\n") === a8.weights === > # now glm models with weights > glm.weights <- c(.8,1,1,.5,1,1,1,1,1) > # The following calls to earth and glm both give "Warning: non-integer #successes in a binomial glm" > # See https://stackoverflow.com/questions/12953045/warning-non-integer-successes-in-a-binomial-glm-survey-packages > a8.weights <- earth(y~., data=data, + linpreds=TRUE, glm=list(family=binomial), + weights=glm.weights, + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) Warning in eval(family$initialize) : non-integer #successes in a binomial glm! > cat("a8.weights:\n") a8.weights: > print(a8.weights) GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 11.4471 8 3.72175 7 0.675 6.107 7 1 Earth selected 2 of 2 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 1e-08 at 2 terms Importance: x Weights: 0.8, 1, 1, 0.5, 1, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 1 (additive model) Earth GCV 0.07569683 RSS 0.6812715 GRSq 0.6693244 RSq 0.6693244 > plotmo(a8.weights, type="response", + col.response=2, do.par=F, main="a8.weights glm\ntype=\"response\"", + grid.col="gray", ylim=c(-.2, 1.2), jitter=0) > plotmo(a8.weights, type="earth", + col.response=2, do.par=F, main="a8.weights glm\ntype=\"earth\"", + grid.col="gray", ylim=c(-.2, 1.2), jitter=0) > glm.a8.weights <- glm(y~., data=data, weights=glm.weights, family=binomial) Warning in eval(family$initialize) : non-integer #successes in a binomial glm! > stopifnot(coefficients(a8.weights$glm.list[[1]]) == coefficients(glm.a8.weights)) > stopifnot(a8.weights$glm.list[[1]]$aic == glm.a8.weights$aic) > source("check.earth.matches.glm.R") > check.earth.matches.glm(a8.weights, glm.a8.weights, newdata=data[2:6,]) check a8.weights vs glm.a8.weights > > options(warn=2) # treat warnings as errors > # same as a8.weights but use family=quasibinomial > # (test no Warning: non-integer #successes in a binomial glm) > a8.weights.quasibinomial <- earth(y~., data=data, + linpreds=TRUE, glm=list(family=quasibinomial), + weights=glm.weights, + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) > options(warn=1) > cat("a8.weights.quasibinomial:\n") a8.weights.quasibinomial: > print(a8.weights.quasibinomial) GLM (family quasibinomial, link logit): nulldev df dev df devratio iters converged 11.4471 8 3.72175 7 0.675 7 1 Earth selected 2 of 2 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 1e-08 at 2 terms Importance: x Weights: 0.8, 1, 1, 0.5, 1, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 1 (additive model) Earth GCV 0.07569683 RSS 0.6812715 GRSq 0.6693244 RSq 0.6693244 > check.models.equal(a8.weights, a8.weights.quasibinomial, "a8.weights, a8.weights.quasibinomial", newdata=data[2,]) a8.weights, a8.weights.quasibinomial: models not identical a8.weights, a8.weights.quasibinomial: glm submodel formula strings are identical: yarg ~ x a8.weights, a8.weights.quasibinomial: but the actual glm submodel formulas differ (classes are "formula" and "formula") a8.weights, a8.weights.quasibinomial: glm submodels not identical (but coefs, residuals, fitted.values are the same) a8.weights, a8.weights.quasibinomial: Models are equivalent, within numerical tolerances > > # glm model with weights and subset > # To suppress "Warning: non-integer #successes in a binomial glm" we use quasibinomial rather than binomial > # See https://stackoverflow.com/questions/12953045/warning-non-integer-successes-in-a-binomial-glm-survey-packages > a8.subset <- c(TRUE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE) > a8.weights.subset <- earth(y~., data=data, + linpreds=TRUE, glm=list(family=quasibinomial), + weights=glm.weights, subset=a8.subset, + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=1) x[9,1] with colname x, and values 1, 2, 3, 4, 5, 6, 7, 8, 9 y[9,1] with colname y, and values 0, 0, 0, 1, 0, 1, 1, 1, 1 earth and glm weights[9]: 0.8, 1, 1, 0.5, 1, 1, 1, 1, 1 7 cases after taking subset Forward pass term 1, 2, 4 RSq changed by less than 1e-08 at 3 terms, 2 terms used (DeltaRSq 0) After forward pass GRSq 0.584 RSq 0.584 Prune backward penalty -1 nprune null: selected 2 of 2 terms, and 1 of 1 preds After pruning pass GRSq 0.584 RSq 0.584 GLM y devratio 0.57 dof 5/6 iters 6 > glm.a8.weights.subset <- glm(y~., data=data, weights=glm.weights, subset=a8.subset, family=quasibinomial) > stopifnot(coefficients(a8.weights.subset$glm.list[[1]]) == coefficients(glm.a8.weights.subset)) > stopifnot(a8.weights.subset$glm.list[[1]]$deviance == glm.a8.weights.subset$deviance) > # AIC is NA because we use quasibinomial rather than binomial > stopifnot(is.na(a8.weights.subset$glm.list[[1]]$aic)) > stopifnot(is.na(glm.a8.weights.subset$aic)) > cat("summary(a8.weights.subset:\n") summary(a8.weights.subset: > print(summary(a8.weights.subset)) Call: earth(formula=y~., data=data, weights=glm.weights, subset=a8.subset, trace=1, glm=list(family=quasibinomial), linpreds=TRUE, minspan=1, endspan=1, penalty=-1, thresh=1e-08) GLM coefficients y (Intercept) -7.267917 x 1.488788 GLM (family quasibinomial, link logit): nulldev df dev df devratio iters converged 8.65572 6 3.69334 5 0.573 6 1 Earth selected 2 of 2 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 1e-08 at 2 terms Importance: x Weights: 0.8, 1, 0.5, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 1 (additive model) Earth GCV 0.09233891 RSS 0.6463724 GRSq 0.5844749 RSq 0.5844749 > cat("summary(glm,a8.weights.subset:\n") summary(glm,a8.weights.subset: > print(summary(glm.a8.weights.subset)) Call: glm(formula = y ~ ., family = quasibinomial, data = data, weights = glm.weights, subset = a8.subset) Deviance Residuals: 1 3 4 5 6 7 8 -0.07028 -0.34335 1.24541 -1.25302 0.58873 0.28918 0.13848 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -7.2679 5.0395 -1.442 0.209 x 1.4888 0.9709 1.533 0.186 (Dispersion parameter for quasibinomial family taken to be 0.6710906) Null deviance: 8.6557 on 6 degrees of freedom Residual deviance: 3.6933 on 5 degrees of freedom AIC: NA Number of Fisher Scoring iterations: 6 > > cat("=== a8.weights including a zero weight ===\n") === a8.weights including a zero weight === > # now glm models with weights including a zero weight > glm.weights <- c(.8,1,1,0,1,1,1,1,1) > a8.azeroweight <- earth(y~., data=data, + linpreds=TRUE, glm=list(family=binomial), + weights=glm.weights, + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred > plotmo(a8.azeroweight, type="response", + col.response=2, do.par=F, main="a8.azeroweight glm\ntype=\"response\"", + grid.col="gray", ylim=c(-.2, 1.2), jitter=0) > plotmo(a8.azeroweight, type="earth", + col.response=2, do.par=F, main="a8.azeroweight glm\ntype=\"earth\"", + grid.col="gray", ylim=c(-.2, 1.2), jitter=0) > glm.a8.azeroweight <- glm(y~., data=data, weights=glm.weights, family=binomial) Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred > # # TODO this fails because a weight is 0 in glm.weights > # print(coefficients(a8.azeroweight$glm.list[[1]])) > # print(coefficients(glm.a8.azeroweight)) > # stopifnot(coefficients(a8.azeroweight$glm.list[[1]]) == coefficients(glm.a8.azeroweight)) > > cat("=== plot.earth with weights ===\n") === plot.earth with weights === > # we also test id.n=TRUE and id.n=-1 here > old.par <- par(mfrow=c(2,2), mar=c(4, 3.2, 3, 3), mgp=c(1.6, 0.6, 0), oma=c(0,0,3,0), par(cex=1)) > plot(a3, id.n=TRUE, SHOWCALL=TRUE, caption="compare a3 to to lm3", do.par=FALSE, + which=c(3,4), caption.cex=1.5) > plot(lm3, id.n=9, which=c(1,2), sub.caption="") > par(old.par) > > cat("=== plot.earth with earth-glm model and weights ===\n") === plot.earth with earth-glm model and weights === > plot(a8, id.n=TRUE, caption="a8") > plot(a8.weights, id.n=TRUE, caption="a8.weights") > plotres(glm.a8.weights, id.n=TRUE, caption="plotres: glm.a8.weights") > plot(a8.weights, id.n=TRUE, delever=TRUE, caption="a8.weights delever=TRUE") > > set.seed(2019) > plotmo(a8.weights, pt.col=2, caption="plotmo: a8.weights") > set.seed(2019) > plotmo(glm.a8.weights, pt.col=2, caption="plotmo: glm.a8.weights") > > cat("=== plot.earth with earth-glm model and weights including a zero weight ===\n") === plot.earth with earth-glm model and weights including a zero weight === > set.seed(2019) > plotmo(a8.azeroweight, pt.col=2, caption="plotmo: a8.azeroweight") > set.seed(2019) > plotmo(glm.a8.azeroweight, pt.col=2, caption="plotmo: glm.a8.azeroweight") > > cat("=== plot.earth with earth-glm model, weights ===\n") === plot.earth with earth-glm model, weights === > > # multivariate models > > noise <- .01 * c(1,2,3,2,1,3,5,2,0) > data <- data.frame(x1=c(1,2,3,4,5,6,7,8,9), x2=c(1,2,3,3,3,6,7,8,9), y=(1:9)+noise) > data[5,] <- c(5, 5, 6) > colnames(data) <- c("x1", "x2", "y") > > weights <- c(3, 2, 1, 1, 2, 3, 1, 2, 3) > lm20 <- lm(y~., data=data, weights=weights) > a20 <- earth(y~., data=data, linpreds=TRUE, weights=weights, + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) > check.earth.lm.models.equal(lm20, a20) > > a21.noweights <- earth(y~., data=data, # no weights for comparison + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) > plotmo(a21.noweights, col.resp=2, trace=-1, caption="a21.noweights", jitter=0) > > weights <- c(1, 1, 1, 1, .5, 1, 1, 1, 1) > a10 <- earth(y~., data=data, weights=weights, + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) > plotmo(a10, col.resp=2, caption="a10", jitter=0) plotmo grid: x1 x2 5 5 > > test.zigzag <- function() + { + par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0), oma=c(0,0,0,0)) + TRACE <- 0 + THRESH <- 0 + PMETHOD <- "none" + + # # models are identical + # x <- 1:21 + # y <- c(1:3, 2) + # y <- rep(y, length.out=length(x)) + # data <- data.frame(x=x, y=y) + # a <- earth(y~x, data=data, minspan=1, endspan=1, trace=TRACE, pmethod=PMETHOD, thresh=THRESH, Scale.y=FALSE, nk=201) + # plot(x, y, type="p", pch=20) + # lines(x, predict(a), col=3, pch=20) + # aw <- earth(y~x, data=data, minspan=1, endspan=1, trace=TRACE, pmethod=PMETHOD, thresh=THRESH, Scale.y=FALSE, nk=201, Force.weights=T) + # plot(x, y, type="p", pch=20) + # lines(x, predict(aw), col=3, pch=20) + + # models are not identical + x <- 1:81 + y <- c(1:3, 2) + y <- rep(y, length.out=length(x)) + data <- data.frame(x=x, y=y) + a <- earth(y~x, data=data, minspan=1, endspan=1, trace=TRACE, pmethod=PMETHOD, thresh=THRESH, Scale.y=FALSE, nk=201) + plot(x, y, type="p", pch=20, main="without weights") + lines(x, predict(a), col=3, pch=20) + aw <- earth(y~x, data=data, minspan=1, endspan=1, trace=TRACE, pmethod=PMETHOD, thresh=THRESH, Scale.y=FALSE, nk=201, Force.weights=T) + plot(x, y, type="p", pch=20, main="with weights") + lines(x, predict(aw), col=3, pch=20) + } > # zigzag > test.zigzag() > > # commented out because too slow and next test essentially covers this > # # trees > # a.trees <- earth(Volume~., data=trees, trace=2) > # aw.trees <- earth(Volume~., data=trees, trace=2, Force.weights=TRUE) > # plotmo(a.trees, do.par=2, caption="trees: top and bottom should be similar") > # plotmo(aw.trees, do.par=FALSE) > > # bivariate.with.interaction > set.seed(2015) > n <- 18 > x <- matrix(runif(2 * n, -1, 1), ncol=2) > x <- x[order(x[,1]), , drop=FALSE] # sort first column for convenience > colnames(x) <- paste("x", 1:ncol(x), sep="") > bivariate.with.interaction <- function(x) + { + x[,1] + x[,2] + x[,1] * x[,2] + .05 * rnorm(nrow(x)) + } > set.seed(1) > y <- bivariate.with.interaction(x) > a.biv <- earth(x, y, degree=2, trace=2) x[18,2] with colnames x1 x2 y[18,1] with colname y, and values -0.9802, -0.8914, -0.8429, -0... Forward pass: minspan 3 endspan 8 x[18,2] 288 Bytes bx[18,21] 2.95 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.4416 0.7218 0.7218 1 x1 -0.29363 2 3 1 4 0.8409 0.9503 0.2286 2 x2 -0.74556< 4 2 2 6 0.7940 0.9856 0.03526 2 x2 0.14781 5 6 1 8 0.8140 0.9974 0.01186 2 x2 -0.74556< 7 3 2 10 -inf 0.9979 0.0004551 1 x1 -0.93714< 8 7 2 reject (small DeltaRSq) GRSq -Inf at 9 terms, 7 terms used After forward pass GRSq -in RSq 0.998 Forward pass complete: 9 terms, 7 terms used Prune backward penalty 3 nprune null: selected 5 of 7 terms, and 2 of 2 preds After pruning pass GRSq 0.914 RSq 0.985 > aw.biv <- earth(x, y, degree=2, trace=2, Force.weights=TRUE) x[18,2] with colnames x1 x2 y[18,1] with colname y, and values -0.9802, -0.8914, -0.8429, -0... weights[18]: 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Forward pass: minspan 3 endspan 8 x[18,2] 288 Bytes bx[18,21] 2.95 kB weighted GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.4416 0.7218 0.7218 1 x1 -0.29363 2 3 1 4 0.8409 0.9503 0.2286 2 x2 -0.74556< 4 2 2 6 0.7940 0.9856 0.03526 2 x2 0.14781 5 6 1 8 0.8140 0.9974 0.01186 2 x2 -0.74556< 7 3 2 10 -inf 0.9979 0.0004551 1 x1 -0.93714< 8 6 2 reject (small DeltaRSq) GRSq -Inf at 9 terms, 7 terms used After forward pass GRSq -in RSq 0.998 Forward pass complete: 9 terms, 7 terms used Prune backward penalty 3 nprune null: selected 5 of 7 terms, and 2 of 2 preds After pruning pass GRSq 0.914 RSq 0.985 > cat("aw.biv:\n") aw.biv: > print(aw.biv) Selected 5 of 7 terms, and 2 of 2 predictors Termination condition: GRSq -Inf at 7 terms Importance: x1, x2 Weights: 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 3 1 GCV 0.0670688 RSS 0.1825762 GRSq 0.9142114 RSq 0.9854545 > > par(mfrow=c(2,3), mar=c(4, 3.2, 3, 3), mgp=c(1.6, 0.6, 0), par(cex = 0.8), oma=c(0,0,3,0)) > plotmo(a.biv, do.par=FALSE, caption="bivariate: top and bottom should be similar") plotmo grid: x1 x2 -0.255094 0.2391128 > plotmo(aw.biv, do.par=FALSE) plotmo grid: x1 x2 -0.255094 0.2391128 > > # Comparison to glm and rpart > # > # The response y is split into two curves, we will weight the second lower > # curve and see how that affects the earth curve. > # > # With weight=1 the earth curve should be half way between the top and > # bottom curve. With say weight=10, the bottom curve is given much more > # weight than the top curve, so the model should be closer to the bottom > # curve. > # > # We also compare the earth curve to to other models that support weights. > # Each vertical line of plots should be approximately the same. > > library(gam) Loading required package: splines Loading required package: foreach Loaded gam 1.16.1 > library(rpart) > n <- 100 > x1 <- c((-n:n) / n, (-n:n) / n) > x2 <- c((n:-n) / n, (-n:n) / n) > y <- x1 * x1 > y[(2 * n + 2) : (3 * n + 2)] <- -.25 * y[(2 * n + 2): (3 * n + 2)] > y[(3 * n + 3) : (4 * n + 2)] <- .25 * y[(3 * n + 3) : (4 * n + 2)] > data <- data.frame(x1=x1, x2=x2, y=y) > > par(mfcol = c(3, 5), mar = c(1.5, 4, 3, 2), mgp = c(1.5, 0.5, 0), oma=c(0,0,4,0)) > > cat("comparison to glm and rpart: unweighted\n") comparison to glm and rpart: unweighted > a200 <- earth(y~x1, data=data) > plotmo(a200, do.par=FALSE, pt.col=2, main="unweighted\nearth", cex=.7, pt.cex=.2, grid.col=TRUE) > mtext("comparison to glm and rpart", outer=TRUE, line=2) > gam200 <- gam(y~s(x1, 5), data=data) Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored > plotmo(gam200, do.par=FALSE, pt.col=2, main="gam", cex=.7, pt.cex=.2, grid.col=TRUE) > rpart <- rpart(y~x1, data=data, method="anova", control=rpart.control(cp=.001)) > plotmo(rpart, do.par=FALSE, pt.col=2, main="rpart", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) > > cat("comparison to glm and rpart: weight=.1\n") comparison to glm and rpart: weight=.1 > weight <- .1 > w <- c(rep_len(1, 2 * n + 1), rep_len(weight, 2 * n + 1)) > aw201 <- earth(y~x1, data=data, weights=w) > plotmo(aw201, do.par=FALSE, pt.col=2, main=sprint("weight %g\nearth", weight), cex=.7, pt.cex=.2, grid.col=TRUE) > gamw201 <- gam(y~s(x1, 5), data=data, weights=w) Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored > plotmo(gamw201, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE) > rpart <- rpart(y~x1, data=data, method="anova", control=rpart.control(cp=.001), weights=w) > plotmo(rpart, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) > > cat("comparison to glm and rpart: weight=1\n") comparison to glm and rpart: weight=1 > weight <- 1 > w <- c(rep_len(1, 2 * n + 1), rep_len(weight, 2 * n + 1)) > aw202 <- earth(y~x1, data=data, weights=w) > plotmo(aw202, do.par=FALSE, pt.col=2, main=sprint("weight %g\nearth", weight), cex=.7, pt.cex=.2, grid.col=TRUE) > gamw202 <- gam(y~s(x1, 5), data=data, weights=w) Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored > plotmo(gamw202, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE) > rpart <- rpart(y~x1, data=data, method="anova", control=rpart.control(cp=.001), weights=w) > plotmo(rpart, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) > > cat("comparison to glm and rpart: weight=2\n") comparison to glm and rpart: weight=2 > weight <- 2 > w <- c(rep_len(1, 2 * n + 1), rep_len(weight, 2 * n + 1)) > aw203 <- earth(y~x1, data=data, weights=w) > plotmo(aw203, do.par=FALSE, pt.col=2, main=sprint("weight %g\nearth", weight), cex=.7, pt.cex=.2, grid.col=TRUE) > gamw203 <- gam(y~s(x1, 5), data=data, weights=w) Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored > plotmo(gamw203, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE) > rpart <- rpart(y~x1, data=data, method="anova", control=rpart.control(cp=.001), weights=w) > plotmo(rpart, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) > > cat("comparison to glm and rpart: weight=10\n") comparison to glm and rpart: weight=10 > weight <- 10 > w <- c(rep_len(1, 2 * n + 1), rep_len(weight, 2 * n + 1)) > aw204 <- earth(y~x1, data=data, weights=w) > plotmo(aw204, do.par=FALSE, pt.col=2, main=sprint("weight %g\nearth", weight), cex=.7, pt.cex=.2, grid.col=TRUE) > gamw204 <- gam(y~s(x1, 5), data=data, weights=w) Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored > plotmo(gamw204, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE) > rpart <- rpart(y~x1, data=data, method="anova", control=rpart.control(cp=.001), weights=w) > plotmo(rpart, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) > > # # TODO the following are meant to do degree2 weight tests, > # # but they are unconvincing either way, so commented out > # > # par(mfcol = c(3, 3), mar = c(1.5, 4, 3, 2), mgp = c(1.5, 0.5, 0), oma=c(0,0,6,0)) > # > # y <- x2 * x2 * y > # data <- data.frame(x1=x1, x2=x2, y=y) > # > # cat("degree2 comparison to glm and rpart: unweighted\n") > # a200 <- earth(y~x1+x2, data=data, degree=2) > # plotmo(a200, do.par=FALSE, pt.col=2, cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1, persp.ticktype="d") > # mtext("comparison to glm and rpart, degree2, unweighted\nleft side earth, right side gam200", outer=TRUE, line=2) > # gam200 <- gam(y~s(x1, 7)+s(x2, 7)+s(x1, 7)*s(x2, 7), data=data) > # plotmo(gam200, do.par=FALSE, pt.col=2, cex=.7, pt.cex=.2, grid.col=TRUE, all2=T, trace=-1, persp.ticktype="d") > # rpart <- rpart(y~x1+x2, data=data, method="anova", control=rpart.control(cp=.001, minbucket=3)) > # plotmo(rpart, do.par=FALSE, pt.col=2, main="rpart", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) > # # plotres(rpart) > # > # cat("degree2 comparison to glm and rpart: weight=2\n") > # weight <- 2 > # w <- c(rep_len(1, 2 * n + 1), rep_len(weight, 2 * n + 1)) > # aw201 <- earth(y~x1+x2, data=data, weights=w, degree=2) > # plotmo(aw201, do.par=FALSE, pt.col=2, cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1, persp.ticktype="d") > # mtext("comparison to glm and rpart, degree2, weight 2\nleft side earth, right side gam200", outer=TRUE, line=2) > # gamw201 <- gam(y~s(x1, 7)+s(x2, 7)+s(x1, 7)*s(x2, 7), data=data, weights=w) > # plotmo(gamw201, do.par=FALSE, pt.col=2, cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1, all2=TRUE, persp.ticktype="d") > # rpart <- rpart(y~x1, data=data, method="anova", control=rpart.control(cp=.001), weights=w) > # plotmo(rpart, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) > # > # cat("degree2 comparison to glm and rpart: weight=10\n") > # weight <- 10 > # w <- c(rep_len(1, 2 * n + 1), rep_len(weight, 2 * n + 1)) > # aw201 <- earth(y~x1+x2, data=data, weights=w, degree=2) > # plotmo(aw201, do.par=FALSE, pt.col=2, cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1, persp.ticktype="d") > # mtext("comparison to glm and rpart, degree2, weight 10\nleft side earth, right side gam200", outer=TRUE, line=2) > # gamw201 <- gam(y~s(x1, 7)+s(x2, 7)+s(x1, 7)*s(x2, 7), data=data, weights=w) > # plotmo(gamw201, do.par=FALSE, pt.col=2, main="gam200", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1, all2=TRUE, persp.ticktype="d") > # rpart <- rpart(y~x1, data=data, method="anova", control=rpart.control(cp=.001), weights=w) > # plotmo(rpart, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) > > # test bug fix for bug reported by damien georges (required adding check for "(weights)" to get.namesx) > set.seed(2016) > n <- 100 > x1 <- factor(sample(c("A", "B", "C"), n, replace = TRUE)) # factorial variable > x2 <- runif(n) # continuous variable > x3 <- rnorm(n) # continuous variable > y <- factor(ifelse((as.numeric(x1) + x2 + x3) / mean(as.numeric(x1) + x2 + x3) > .8, "yes", "no")) > dat <- data.frame(y=y, x1=x1, x2=x2, x3=x3) > > a <- earth(formula=y ~ x1 + x2 + x3, data=dat, glm=list(family=binomial)) Warning: glm.fit: algorithm did not converge Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred Warning: the glm algorithm did not converge for response "yes" > print(summary(a)) Call: earth(formula=y~x1+x2+x3, data=dat, glm=list(family=binomial)) GLM coefficients yes (Intercept) -354.94518 x1B 225.24760 x1C 400.87267 h(0.162484-x2) 1756.01294 h(x2-0.162484) 482.27536 h(x3- -0.662305) -27.27155 h(0.0157099-x3) -107.40748 h(x3-0.0157099) 245.22300 GLM (family binomial, link logit, maxit=25): nulldev df dev df devratio AIC iters converged 132.813 99 3.92659e-08 92 1 16 25 0 Earth selected 8 of 13 terms, and 4 of 4 predictors Termination condition: Reached nk 21 Importance: x3, x1C, x1B, x2 Number of terms at each degree of interaction: 1 7 (additive model) Earth GCV 0.0989258 RSS 7.147389 GRSq 0.588467 RSq 0.6966304 > yhat <- predict(a, dat[, c('x1', 'x2', 'x3')], type='response') > > w <- rep(1, n) # vector of equal weights > aw <- earth(formula=y ~ x1 + x2 + x3, data=dat, glm=list(family=binomial), weight=w) Warning: glm.fit: algorithm did not converge Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred Warning: the glm algorithm did not converge for response "yes" > print(summary(aw)) Call: earth(formula=y~x1+x2+x3, data=dat, weights=w, glm=list(family=binomial)) GLM coefficients yes (Intercept) -354.94518 x1B 225.24760 x1C 400.87267 h(0.162484-x2) 1756.01294 h(x2-0.162484) 482.27536 h(x3- -0.662305) -27.27155 h(0.0157099-x3) -107.40748 h(x3-0.0157099) 245.22300 GLM (family binomial, link logit, maxit=25): nulldev df dev df devratio AIC iters converged 132.813 99 3.92659e-08 92 1 16 25 0 Earth selected 8 of 13 terms, and 4 of 4 predictors Termination condition: Reached nk 21 Importance: x3, x1C, x1B, x2 Number of terms at each degree of interaction: 1 7 (additive model) Earth GCV 0.0989258 RSS 7.147389 GRSq 0.588467 RSq 0.6966304 > yhatw <- predict(aw, dat[, c('x1', 'x2', 'x3')], type='response') > stopifnot(identical(yhat, yhat)) > check.models.equal(a, aw) models not identical Formulas differ: y ~ x1 + x2 + x3 and: y ~ x1 + x2 + x3 glm submodel formula strings are identical: yarg ~ `h(x3-0.0157099)` + `h(0.0157099-x3)` + x1C + x1B + `h(x2-0.162484)` + `h(0.162484-x2)` + `h(x3--0.662305)` but the actual glm submodel formulas differ (classes are "formula" and "formula") glm submodels not identical (but coefs, residuals, fitted.values are the same) Models are equivalent, within numerical tolerances > > w <- rep(1, n) # vector of equal weights > aw.force <- earth(formula=y ~ x1 + x2 + x3, data=dat, glm=list(family=binomial), weight=w, Force.weights=TRUE) Warning: glm.fit: algorithm did not converge Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred Warning: the glm algorithm did not converge for response "yes" > print(summary(aw.force)) Call: earth(formula=y~x1+x2+x3, data=dat, weights=w, glm=list(family=binomial), Force.weights=TRUE) GLM coefficients yes (Intercept) -354.94518 x1B 225.24760 x1C 400.87267 h(0.162484-x2) 1756.01294 h(x2-0.162484) 482.27536 h(x3- -0.662305) -27.27155 h(0.0157099-x3) -107.40748 h(x3-0.0157099) 245.22300 GLM (family binomial, link logit, maxit=25): nulldev df dev df devratio AIC iters converged 132.813 99 3.92659e-08 92 1 16 25 0 Earth selected 8 of 13 terms, and 4 of 4 predictors Termination condition: Reached nk 21 Importance: x3, x1C, x1B, x2 Weights: 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, ... Number of terms at each degree of interaction: 1 7 (additive model) Earth GCV 0.0989258 RSS 7.147389 GRSq 0.588467 RSq 0.6966304 > yhatw <- predict(aw.force, dat[, c('x1', 'x2', 'x3')], type='response') > stopifnot(identical(yhat, yhat)) > check.earth.lm.models.equal(a, aw.force) > > cat("---check Scale.y-------------------------------------------\n") ---check Scale.y------------------------------------------- > > xxx <- 1:9 > yyy <- 1:9 > yyy[3] <- 9 > datxy <- data.frame(x=xxx, y=yyy) > colnames(datxy) <- c("xxx", "yyy") > options(warn=2) > > mod1 <- earth(yyy~., datxy, Scale.y=FALSE) > mod2 <- earth(yyy~., datxy, Scale.y=TRUE) > check.models.equal(mod1, mod2, "mod1, mod2", newdata=dataxy[3,]) mod1, mod2: models identical > > mod3 <- earth(yyy~., datxy, weights=weights, Scale.y=FALSE) > mod4 <- earth(yyy~., datxy, weights=weights, Scale.y=TRUE) > check.models.equal(mod3, mod4, "mod3, mod4", newdata=dataxy[3,]) mod3, mod4: models identical > > data(ozone1) > > mod5 <- earth(O3~., ozone1, Scale.y=FALSE) > mod6 <- earth(O3~., ozone1, Scale.y=TRUE) > check.models.equal(mod5, mod6, "mod5, mod6", newdata=ozone1[3,]) mod5, mod6: models identical > > mod7 <- earth(O3~., ozone1, weights=sqrt(ozone1$O3), Scale.y=FALSE) > mod8 <- earth(O3~., ozone1, weights=sqrt(ozone1$O3), Scale.y=TRUE) > check.models.equal(mod7, mod8, "mod7, mod8", newdata=ozone1[3,]) mod7, mod8: models identical > > data(etitanic) > > # nk=5 for speed > mod9 <- earth(survived~., etitanic, nk=5, weights=sqrt(etitanic$age), Scale.y=FALSE) > mod10 <- earth(survived~., etitanic, nk=5, weights=sqrt(etitanic$age), Scale.y=TRUE) > check.models.equal(mod9, mod10, "mod9, mod10", newdata=etitanic[2,]) mod9, mod10: models identical > > # use nk=7 to minimize differences between code for weighted and unweighted models in earth.c > mod.O3vh <- earth(O3+vh~wind+doy, ozone1, nk=7, Scale.y=FALSE, trace=1) Using class "Formula" because lhs of formula has terms separated by "+" x[330,2] with colnames wind doy y[330,2] with colnames O3 vh Forward pass term 1, 2, 4, 6 Reached nk 7 After forward pass GRSq 0.452 RSq 0.485 Prune backward penalty 2 nprune null: selected 6 of 6 terms, and 2 of 2 preds After pruning pass GRSq 0.452 RSq 0.485 > w1 <- rep(1, length.out=nrow(ozone1)) > mod.O3vh.w1 <- earth(O3+vh~wind+doy, ozone1, nk=7, weights=w1, Force.weights=TRUE, Scale.y=FALSE, trace=1) Using class "Formula" because lhs of formula has terms separated by "+" x[330,2] with colnames wind doy y[330,2] with colnames O3 vh weights[330]: 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, ... Forward pass term 1, 2, 4, 6 Reached nk 7 After forward pass GRSq 0.452 RSq 0.485 Prune backward penalty 2 nprune null: selected 6 of 6 terms, and 2 of 2 preds After pruning pass GRSq 0.452 RSq 0.485 > check.models.equal(mod.O3vh, mod.O3vh.w1, "mod.O3vh, mod.O3vh.w1", newdata=ozone1[2,]) mod.O3vh, mod.O3vh.w1: models not identical Formulas differ: ~O3 + vh + (wind + doy) and: ~O3 + vh + (wind + doy) mod.O3vh, mod.O3vh.w1: Models are equivalent, within numerical tolerances > > w3 <- rep(3, length.out=nrow(ozone1)) > mod.O3vh.w3 <- earth(O3+vh~wind+doy, ozone1, nk=7, weights=w3, Force.weights=TRUE, Scale.y=FALSE) > check.equal(mod.O3vh$grsq, mod.O3vh.w3$grsq) > check.equal(mod.O3vh$rsq, mod.O3vh.w3$rsq) > check.equal(mod.O3vh$coefficients, mod.O3vh.w3$coefficients) > # check.models.equal(mod.O3vh, mod.O3vh.w3, "(mod.O3vh, mod.O3vh.w3") # not exactly equal but close > > mod.O3vh.Scaley <- earth(O3+vh~wind+doy, ozone1, nk=7, Scale.y=TRUE, trace=0) > w1 <- rep(1, length.out=nrow(ozone1)) > mod.O3vh.w1.Scaley <- earth(O3+vh~wind+doy, ozone1, nk=7, weights=w1, Force.weights=TRUE, Scale.y=TRUE) > check.models.equal(mod.O3vh.Scaley, mod.O3vh.w1.Scaley, "mod.O3vh.Scaley, mod.O3vh.w1.Scaley", newdata=ozone1[2,]) mod.O3vh.Scaley, mod.O3vh.w1.Scaley: models not identical Formulas differ: ~O3 + vh + (wind + doy) and: ~O3 + vh + (wind + doy) mod.O3vh.Scaley, mod.O3vh.w1.Scaley: Models are equivalent, within numerical tolerances > > # multiple response models, Scale.y will be visible (i.e. models with different Scale.y will be different) > mod.O3vh <- earth(O3+vh~wind+doy, ozone1, degree=2, Scale.y=FALSE) > print(mod.O3vh) Selected 9 of 15 terms, and 2 of 2 predictors Termination condition: Reached nk 21 Importance: doy, wind Number of terms at each degree of interaction: 1 7 1 GCV RSS GRSq RSq O3 41.1772 11914.06 0.3603606 0.4357645 vh 5619.6553 1625970.63 0.4986120 0.5577182 All 5660.8325 1637884.69 0.4978225 0.5570217 > mod.O3vh.Scaley <- earth(O3+vh~wind+doy, ozone1, degree=2, Scale.y=TRUE) > print(mod.O3vh.Scaley) Selected 8 of 16 terms, and 2 of 2 predictors Termination condition: Reached nk 21 Importance: doy, wind Number of terms at each degree of interaction: 1 7 (additive model) GCV RSS GRSq RSq O3 37.4304 11005.91 0.4185634 0.4787732 vh 6042.6701 1776769.31 0.4608704 0.5166993 All 6080.1004 1787775.23 0.4606288 0.5164827 > rsq.diff <- abs(mod.O3vh$rsq.per.response[1] - mod.O3vh$rsq.per.response[2]) > rsq.diff.Scaley <- abs(mod.O3vh.Scaley$rsq.per.response[1] - mod.O3vh.Scaley$rsq.per.response[2]) > # Scale.y=TRUE for multiple response models should make the rsq for the two responses closer > # i.e. with Scale.y=TRUE, vh should not overwhelm O3 because vh has much bigger values > stopifnot(rsq.diff.Scaley < rsq.diff) > > wO3 <- sqrt(ozone1$O3) > mod.O3vh.wO3 <- earth(O3+vh~wind+doy, ozone1, degree=2, weights=wO3, Scale.y=FALSE) > print(mod.O3vh.wO3) Selected 12 of 14 terms, and 2 of 2 predictors Termination condition: Reached nk 21 Importance: doy, wind Weights: 1.732051, 2.236068, 2.236068, 2.44949, 2, 2, 2.44949, 2.645751,... Number of terms at each degree of interaction: 1 10 1 GCV RSS GRSq RSq O3 139.039 38299.9 0.4024813 0.4981957 vh 14584.328 4017418.8 0.5287752 0.6042591 All 14723.367 4055718.7 0.5278328 0.6034676 > mod.O3vh.wO3.Scaley <- earth(O3+vh~wind+doy, ozone1, degree=2, weights=wO3, Scale.y=TRUE) > print(mod.O3vh.wO3.Scaley) Selected 11 of 13 terms, and 2 of 2 predictors Termination condition: Reached nk 21 Importance: doy, wind Weights: 1.732051, 2.236068, 2.236068, 2.44949, 2, 2, 2.44949, 2.645751,... Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq O3 125.7911 35227.6 0.4594138 0.5384483 vh 14406.2124 4034437.9 0.5345302 0.6025826 All 14532.0035 4069665.6 0.5339697 0.6021040 > rsq.diff.wO3 <- abs(mod.O3vh.wO3$rsq.per.response[1] - mod.O3vh.wO3$rsq.per.response[2]) > rsq.diff.wO3.Scaley <- abs(mod.O3vh.wO3.Scaley$rsq.per.response[1] - mod.O3vh.wO3.Scaley$rsq.per.response[2]) > # Scale.y=TRUE for multiple response models should make the rsq for the two responses closer > stopifnot(rsq.diff.wO3.Scaley < rsq.diff.wO3) > > # nk=5 for speed > mod11 <- earth(pclass~., etitanic, nk=5, weights=sqrt(etitanic$age), Scale.y=FALSE) > print(mod11) Selected 3 of 4 terms, and 2 of 5 predictors Termination condition: Reached nk 5 Importance: age, survived, sexmale-unused, sibsp-unused, parch-unused Weights: 5.385165, 0.9574445, 1.414214, 5.477226, 5, 6.928203, 7.937254,... Number of terms at each degree of interaction: 1 2 (additive model) GCV RSS GRSq RSq 1st 0.8509308 881.5847 0.254112886 0.259812098 2nd 0.9918505 1027.5809 -0.007243869 0.000452331 3rd 1.0288556 1065.9190 0.207088152 0.213146673 All 2.8716370 2975.0846 0.161103938 0.167513818 > mod12 <- earth(pclass~., etitanic, nk=5, weights=sqrt(etitanic$age), Scale.y=TRUE) > print(mod12) Selected 4 of 4 terms, and 2 of 5 predictors Termination condition: Reached nk 5 Importance: age, survived, sexmale-unused, sibsp-unused, parch-unused Weights: 5.385165, 0.9574445, 1.414214, 5.477226, 5, 6.928203, 7.937254,... Number of terms at each degree of interaction: 1 3 (additive model) GCV RSS GRSq RSq 1st 0.8516553 878.9482 0.253477791 0.262025685 2nd 0.9899034 1021.6267 -0.005266484 0.006244106 3rd 1.0388367 1072.1282 0.199396002 0.208563148 All 2.8803954 2972.7030 0.158545320 0.168180218 > > source("test.epilog.R") earth/inst/slowtests/test.varmod.mgcv.R0000644000176200001440000000423713403043445017733 0ustar liggesusers# test.varmmod.mgcv.R # mgcv has to be tested separately because of clashes between library(gam) and library(mgcv) # Stephen Milborrow Apr 2015 Berea source("test.prolog.R") library(earth) options(warn=2) printh <- function(caption) cat("===", caption, "\n", sep="") CAPTION <- NULL multifigure <- function(caption, nrow=3, ncol=3) { CAPTION <<- caption printh(caption) par(mfrow=c(nrow, ncol)) par(cex = 0.8) par(mar = c(3, 3, 5, 0.5)) # small margins but space for right hand axis par(mgp = c(1.6, 0.6, 0)) # flatten axis elements oma <- par("oma") # make space for caption oma[3] <- 2 par(oma=oma) } do.caption <- function() # must be called _after_ first plot on new page mtext(CAPTION, outer=TRUE, font=2, line=1, cex=1) old.par <- par(no.readonly=TRUE) library(mgcv) for(varmod.method in c("gam", "x.gam")) { multifigure(sprint("varmod.method=\"%s\"", varmod.method), 2, 3) par(mar = c(3, 3, 2, 3)) # space for right margin axis set.seed(6) earth.mod <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method=varmod.method, trace=if(varmod.method %in% c("const", "lm", "power")) .3 else 0) printh(sprint("varmod.method %s: summary(earth.mod)", varmod.method)) printh("summary(earth.mod)") print(summary(earth.mod)) # summary(mgcv) prints environment as hex address which messes up the diffs printh("skipping summary(mgcv::gam) etc.\n") printh(sprint("varmod.method %s: predict(earth.mod, interval=\"pint\")", varmod.method)) pints <- predict(earth.mod, interval="pint") print(pints) plotmo(earth.mod$varmod, do.par=FALSE, col.response=2, clip=FALSE, main="plotmo residual model", xlab="x", ylab="varmod residuals") plotmo(earth.mod, level=.90, do.par=FALSE, col.response=1, clip=FALSE, main="main model plotmo Girth") do.caption() plot(earth.mod, which=3, do.par=FALSE, level=.95) # plot.varmod plot(earth.mod$varmod, do.par=FALSE, which=1:3, info=(varmod.method=="earth")) } par(old.par) source("test.epilog.R") earth/inst/slowtests/check.earth.matches.glm.R0000644000176200001440000001226313442314354021113 0ustar liggesusers# check.earth.matches.glm.R: check that earth-glm model matches glm model in all essential details check.earth.matches.glm <- function(earth, glm, newdata=long[c(3,1,9),], check.coef.names=TRUE, check.casenames=FALSE, max=1e-15, max.residuals=1e-12) { check.names <- function(earth.names, glm.names) { if(check.casenames && # glm always adds rownames even if "1", "2", "3": this seems # wasteful and not particulary helpful, so earth doesn't do # this, hence the first !isTRUE(all.equal) below !isTRUE(all.equal(glm.names, paste(1:length(glm.names)))) && !isTRUE(all.equal(earth.names, glm.names))) { print(earth.names) print(glm.names) stop(deparse(substitute(earth.names)), " != ", deparse(substitute(glm.names))) } } cat0("check ", deparse(substitute(earth)), " vs ", deparse(substitute(glm)), "\n") # sort is needed because earth may reorder predictors based in importance earth.glm <- earth$glm.list[[1]] stopifnot(!is.null(earth.glm)) stopifnot(almost.equal(sort(coef(earth.glm)), sort(coef(glm)), max=max)) if(check.coef.names) stopifnot(identical(sort(names(coef(earth.glm))), sort(names(coef(glm))))) stopifnot(length(earth.glm$coefficients) == length(glm$coefficients)) stopifnot(almost.equal(sort(earth.glm$coefficients), sort(glm$coefficients), max=max)) stopifnot(length(earth.glm$residuals) == length(glm$residuals)) stopifnot(almost.equal(earth.glm$residuals, glm$residuals, max=max.residuals)) stopifnot(length(earth.glm$fitted.values) == length(glm$fitted.values)) stopifnot(almost.equal(earth.glm$fitted.values, glm$fitted.values, max=max)) stopifnot(almost.equal(fitted(earth.glm), fitted(glm), max=max)) if(!is.null(names(fitted(earth.glm))) && !is.null(names(fitted(glm)))) check.names(names(fitted(earth.glm)), names(fitted(glm))) stopifnot(almost.equal(residuals(earth.glm), residuals(glm), max=max.residuals)) if(!is.null(names(residuals(earth.glm))) && !is.null(names(residuals(glm)))) check.names(names(residuals(earth.glm)), names(residuals(glm))) stopifnot(almost.equal(residuals(earth, type="response"), residuals(glm, type="response"), max=max.residuals)) stopifnot(almost.equal(residuals(earth, type="glm.response"), residuals(glm, type="response"), max=max.residuals)) stopifnot(almost.equal(residuals(earth, type="deviance"), residuals(glm, type="deviance"), max=max.residuals)) stopifnot(almost.equal(residuals(earth, type="glm.pearson"), residuals(glm, type="pearson"), max=max.residuals)) stopifnot(almost.equal(residuals(earth, type="glm.working"), residuals(glm, type="working"), max=max.residuals)) # commented out because partial residuals don't match (because factors are expanded differently?) # stopifnot(almost.equal(residuals(earth, type="glm.partial"), residuals(glm, type="partial"), max=max.residuals)) # predict without newdata predict.earth <- predict(earth) predict.glm <- predict(glm) stopifnot(almost.equal(predict.earth[,1], predict.glm, max=max)) if(!is.null(names(predict.earth)) && !is.null(names(predict.glm))) check.names(names(predict.earth), names(predict.glm)) # predict type=default predict.earth <- predict(earth, newdata=newdata) predict.glm <- predict(glm, newdata=newdata) stopifnot(almost.equal(predict.earth[,1], predict.glm, max=max)) if(!is.null(names(predict.earth)) && !is.null(names(predict.glm))) check.names(names(predict.earth), names(predict.glm)) # predict type="response" predict.earth.response <- predict(earth, newdata=newdata, type="response") predict.glm.response <- predict(glm, newdata=newdata, type="response") if(!is.null(names(predict.earth)) && !is.null(names(predict.glm))) check.names(names(predict.earth), names(predict.glm)) stopifnot(almost.equal(predict.earth.response[,1], predict.glm.response, max=max)) if(!is.null(names(predict.earth.response)) && !is.null(names(predict.glm.response))) check.names(names(predict.earth.response), names(predict.glm.response)) # predict type="link" predict.earth.link <- predict(earth, newdata=newdata, type="link") predict.glm.link <- predict(glm, newdata=newdata, type="link") stopifnot(almost.equal(predict.earth.link[,1], predict.glm.link, max=max)) if(!is.null(names(predict.earth)) && !is.null(names(predict.lm))) check.names(names(predict.earth), names(predict.glm)) # check internal consistency of earth model if(is.null(earth$bpairs)) { # doesn't work for bpair models stopifnot(earth$gcv == earth$gcv[1]) stopifnot(almost.equal(earth$rsq.per.response[1], earth$rsq, max=1e-15)) stopifnot(almost.equal(earth$grsq.per.response[1], earth$grsq, max=1e-15)) if(is.null(earth$weights)) stopifnot(almost.equal(earth$rss.per.response, earth$rss, max=1e-10)) } } earth/inst/slowtests/README.txt0000644000176200001440000000112113306002727016072 0ustar liggesusersearth/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.earth.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. earth/inst/slowtests/test.earthc.c0000644000176200001440000004642613447225133017011 0ustar liggesusers// test.c: main() for testing earth c routines // Comments containing "TODO" mark known issues #include #include #include #include #include #include #include #include #include "../../src/earth.h" #define PRINT_TIME 0 #define sq(x) ((x) * (x)) #if _MSC_VER // microsoft // disable warning: 'vsprintf': This function or variable may be unsafe #pragma warning(disable: 4996) #endif //----------------------------------------------------------------------------- void error(const char *args, ...) { char s[1000]; va_list p; va_start(p, args); vsprintf(s, args, p); va_end(p); printf("\nError: %s\n", s); // printf("Forcing a crash for the JIT debugger\n"); // fflush(stdout); // _sleep(1000); // wait for fflush to finish // static volatile int* p999 = 0; // *p999 = 999; exit(-1); } //----------------------------------------------------------------------------- static double getGcv(const int nTerms, // nbr basis terms including intercept const int nCases, double Rss, const double penalty) { double cost; if (penalty < 0) // special case: terms and knots are free cost = 0; else cost = nTerms + (penalty * (double)(nTerms-1) / 2); // nKnots = (nTerms-1)/2 return Rss / (nCases * sq(1 - cost/nCases)); } //----------------------------------------------------------------------------- static double RandUniform(void) // uniform rand number from -1 to +1 { return (double)((rand() % 20000) - 10000) / 10000; } //----------------------------------------------------------------------------- static double RandGauss(void) // standard normal random number { double r = 0; for (int i = 0; i < 12; i++) // by central limit theorem sum of uniforms is gaussian r += RandUniform(); return r / 2; } //----------------------------------------------------------------------------- static double funcNoise(const double x[], const int iResponse) { return RandGauss(); } static double func0(const double x[], const int iResponse) { return x[0]; } static double func1clean(const double x[], const int iResponse) { return x[0] + x[1]; } static double func1(const double x[], const int iResponse) { return x[0] + x[1] + .1 * RandGauss(); } static double func2(const double x[], const int iResponse) { return x[0] + x[1] + x[0]*x[1]; } static double func3(const double x[], const int iResponse) { return cos(x[0]) + x[1]; } static double func4(const double x[], const int iResponse) { return sin(2 * x[0]) + 2*x[1] + 0.5*x[0]*x[1]; } static double func5(const double x[], const int iResponse) { return x[0] + x[1] + x[3] + x[4] + x[5] + x[1]*x[2] + (x[3]+1)*(x[4]+1)*x[5]; } static double func4lin(const double x[], const int iResponse) { return x[0] + x[1] + x[3] + x[4]; } static double func6(const double x[], const int iResponse) { // 5 preds, 2nd order return x[0] +x[1]+ x[2] +x[3] +x[4] +x[5] + x[0]*x[1] + x[2]*x[3] + x[4]*x[5] + .1 * RandGauss(); } static double func6clean(const double x[], const int iResponse) { // 5 preds, 2nd order return x[0] +x[1]+ x[2] +x[3] +x[4] +x[5] + x[0]*x[1] + x[2]*x[3] + x[4]*x[5]; } static double func7(const double x[], const int iResponse) { // 10 preds, 2nd order return x[0] +x[1]+ x[2] +x[3] +x[4] +x[5] +x[6] +x[7] +x[8] +x[9] + x[0]*x[1] + x[2]*x[3] + x[4]*x[5] + x[6]*x[7] + x[8]*x[9]; } static double func8(const double x[], const int iResponse) { // 20 preds, 2nd order return x[0] +x[1]+ x[2] +x[3] +x[4] +x[5] +x[6] +x[7] +x[8] +x[9] + x[10]+x[11]+x[12]+x[13]+x[14]+x[15]+x[16]+x[17]+x[18]+x[19] + x[0]*x[1] + x[2]*x[3] + x[4]*x[5] + x[6]*x[7] + x[8]*x[9] + + .1 * RandGauss(); } static double func9(const double x[], const int iResponse) { return x[1]; } static double func56(const double x[], const int iResponse) { // Friedman MARS paper eqn 56 return 0.1 * exp(4*x[0]) + 4 / (1 + exp(-20*(x[1]-0.5)) + 3*x[2] + 2*x[3] + x[4] + RandGauss()); } // functions for testing multiple responses static double func0_1clean(const double x[], const int iResponse) { if (iResponse == 0) return func0(x, iResponse); else if (iResponse == 1) return func1clean(x, iResponse); else error("bad iResponse"); return 0; } static double func0_1(const double x[], const int iResponse) { if (iResponse == 0) return func0(x, iResponse); else if (iResponse == 1) return func1(x, iResponse); else error("bad iResponse"); return 0; } static double func2_2(const double x[], const int iResponse) { if (iResponse == 0) return func2(x, iResponse); else if (iResponse == 1) return func2(x, iResponse); else error("bad iResponse"); return 0; } static double func0_4(const double x[], const int iResponse) { if (iResponse == 0) return func0(x, iResponse); else if (iResponse == 1) return func4(x, iResponse); else error("bad iResponse"); return 0; } static double func0_2_4(const double x[], const int iResponse) { if (iResponse == 0) return func0(x, iResponse); else if (iResponse == 1) return func2(x, iResponse); else if (iResponse == 2) return func4(x, iResponse); else error("bad iResponse"); return 0; } static double func2_4_0(const double x[], const int iResponse) { if (iResponse == 0) return func2(x, iResponse); else if (iResponse == 1) return func4(x, iResponse); else if (iResponse == 2) return func0(x, iResponse); else error("bad iResponse"); return 0; } static double func4_2_0(const double x[], const int iResponse) { if (iResponse == 0) return func4(x, iResponse); else if (iResponse == 1) return func2(x, iResponse); else if (iResponse == 2) return func0(x, iResponse); else error("bad iResponse"); return 0; } static double func4_6(const double x[], const int iResponse) { if (iResponse == 0) return func4(x, iResponse); else if (iResponse == 1) return func6(x, iResponse); else error("bad iResponse"); return 0; } // functions for testing NewVarPenalty static double func1collinear(const double x[], const int iResponse) { return x[0] + x[1] + .001 * RandGauss(); } static double func2collinear(const double x[], const int iResponse) { return cos(x[0]) + cos(x[1]) + .1 * RandGauss(); } int cmp(const void *x, const void *y) // for qsort { double x0 = *(double*)x; double y0 = *(double*)y; if (x0 < y0) return -1; if (x0 > y0) return 1; return 0; } //----------------------------------------------------------------------------- static void TestEarth(char sTestName[], double (__cdecl *func)(const double xrow[], const int iResponse), const int nCases, const int nResponses, const int nPreds, const int nMaxDegree, const int nMaxTerms, const double Trace, const bool Format, const double ForwardStepThresh, const int nFastK, const double FastBeta, const double NewVarPenalty, const int seed, const double Collinear = 0) // used for testing NewVarPenalty { #define y_(i,iResponse) y[(i) + (iResponse)*(nCases)] int *LinPreds = (int *)calloc(nPreds, sizeof(int)); double *x = (double *)malloc(nCases * nPreds * sizeof(double)); double *y = (double *)malloc(nCases * nResponses * sizeof(double)); double *bx = (double *)malloc(nCases * nMaxTerms * sizeof(double)); bool *BestSet = (bool *) malloc(nMaxTerms * sizeof(bool)); int *Dirs = (int *) malloc(nMaxTerms * nPreds * sizeof(int)); double *Cuts = (double *)malloc(nMaxTerms * nPreds * sizeof(double)); double *Residuals = (double *)malloc(nCases * nResponses * sizeof(double)); double *Betas = (double *)malloc(nMaxTerms * nResponses * sizeof(double)); static int nTest; nTest++; printf("=============================================================================\n"); printf("TEST %d: %s n=%d p=%d\n", nTest, sTestName, nCases, nPreds); // init x srand(seed); int i; for (i = 0; i < nCases; i++) for (int iPred = 0; iPred < nPreds; iPred++) { double xtemp; xtemp = (double)((rand() % 20000) - 10000) / 10000; // rand number from -1 to +1 x[i + iPred * nCases] = xtemp; } // sort the first column of x, makes debugging easier qsort(x, nCases, sizeof(double), cmp); if (Collinear > 0) { // copy column 0 to 1 with added noise for (i = 0; i < nCases; i++) x[i + 1 * nCases] = x[i] + Collinear * RandGauss(); } // init y double *xrow = (double *)malloc(nPreds * sizeof(double)); for (i = 0; i < nCases; i++) { for (int iPred = 0; iPred < nPreds; iPred++) xrow[iPred] = x[i + iPred * nCases]; for (int iResponse = 0; iResponse < nResponses; iResponse++) y_(i, iResponse) = func(xrow, iResponse); } free(xrow); double BestGcv; int nTerms, iReason; const double Penalty = ((nMaxDegree>1)? 3:2); clock_t Time = clock(); if(Trace >= 4) { if(nResponses != 1) error("cannot use Trace>=4 with nResponses!=1"); printf(" y"); for(int iPred = 0; iPred < nPreds; iPred++) printf(" x%d", iPred); printf("\n"); for(int i = 0; i < nCases; i++) { printf("%4d % 7.5f", i, y[i]); for(int iPred = 0; iPred < nPreds; iPred++) { printf(" % 7.5f", x[i + iPred * nCases]); } printf("\n"); } printf("\n"); } Earth(&BestGcv, &nTerms, &iReason, BestSet, bx, Dirs, Cuts, Residuals, Betas, x, y, NULL, // weights are NULL nCases, nResponses, nPreds, nMaxDegree, nMaxTerms, Penalty, ForwardStepThresh, 0, 0, // MinSpan, EndSpan true, // Prune nFastK, FastBeta, NewVarPenalty, LinPreds, 2 /*AdjustEndSpan*/, true /*AutoLinPred*/, true /*UseBetaCache*/, Trace, NULL); // calc nUsedTerms int nUsedTerms = 0; for (int iTerm = 0; iTerm < nTerms; iTerm++) if (BestSet[iTerm]) nUsedTerms++; // calc RSquared, GRSquared for (int iResponse = 0; iResponse < nResponses; iResponse++) { double Rss = 0, Tss = 0, meanY = 0; for (i = 0; i < nCases; i++) meanY += y_(i, iResponse); meanY /= nCases; xrow = (double *)malloc(nPreds * sizeof(double)); double *yHat = (double *)malloc(nResponses * sizeof(double)); for (i = 0; i < nCases; i++) { for (int iPred = 0; iPred < nPreds; iPred++) xrow[iPred] = x[i + iPred * nCases]; PredictEarth(yHat, xrow, BestSet, Dirs, Cuts, Betas, nPreds, nResponses, nTerms, nMaxTerms); double Residual = y_(i,iResponse) - yHat[iResponse]; Rss += sq(Residual); Tss += sq(y_(i,iResponse) - meanY); } free(yHat); free(xrow); const double RSq = 1 - Rss/Tss; const double GcvNull = getGcv(1, nCases, Tss, Penalty); const double GRSq = 1 - getGcv(nUsedTerms, nCases, Rss, Penalty) / GcvNull; #if PRINT_TIME double TimeDelta = (double)(clock() - Time) / CLOCKS_PER_SEC; #else double TimeDelta = 99.99; #endif // show results if (nResponses > 1) { printf("RESULT %d Response %d: GRSq %.5g RSq %.5g nTerms %d of %d of %d", nTest, iResponse+1, GRSq, RSq, nUsedTerms, nTerms, nMaxTerms); if (iResponse == 0) printf(" FUNCTION %s n=%d p=%d [%.2f secs]", sTestName, nCases, nPreds, TimeDelta); printf("\n"); } else printf("RESULT %d: GRSq %g RSq %g nTerms %d of %d of %d " "FUNCTION %s n=%d p=%d [%.2f secs]\n", nTest, GRSq, RSq, nUsedTerms, nTerms, nMaxTerms, sTestName, nCases, nPreds, TimeDelta); } if (Format && Trace != 0) { printf("\nTEST %d: FUNCTION %s n=%d p=%d\n", nTest, sTestName, nCases, nPreds); FormatEarth(BestSet, Dirs, Cuts, Betas, nPreds, nResponses, nTerms, nMaxTerms, 3, 1e-6); printf("\n"); } free(LinPreds); free(x); free(y); free(BestSet); free(Dirs); free(Cuts); free(Residuals); free(Betas); free(bx); } //----------------------------------------------------------------------------- int main(void) { clock_t Time = clock(); // func nCases nResp nPreds nMaxDegree nMaxTerms Trace Form Thresh K B N s TestEarth("noise", funcNoise, 1000, 1, 1, 2, 51, 3,true,0.001,20,1,0,99); TestEarth("x0", func0, 10, 1, 1, 2, 51, 7,true,0.001,20,1,0,99); // intercept only models TestEarth("x0", func0, 10, 1, 1, 2, 1, 3,true,0.001,20,1,0,99); TestEarth("x0", func0, 10, 1, 1, 2, 2, 3,true,0.001,20,1,0,99); TestEarth("x0", func0, 1000, 1, 1, 2, 51, 3,true,0.001,20,1,0,99); TestEarth("x0 + noise", func0, 1000, 1, 1+1, 2, 51, 3,true,0.001,20,1,0,99); TestEarth("x0 + x1", func1, 1000, 1, 2, 2, 11, 7,true,0.001,20,1,0,99); TestEarth("x0 + x1 + noise", func1, 1000, 1, 2+8, 2, 51, 0,true,0.001,20,1,0,99); TestEarth("x0 + x1 + x0*x1", func2, 30, 1, 2, 2, 51, 4,true,0.001,20,1,0,99); TestEarth("x0 + x1 + x0*x1", func2, 1000, 1, 2, 2, 51, 3,true,0.001,20,1,0,99); TestEarth("x0 + x1 + x0*x1", func2, 1000, 1, 2, 2, 51, 1.5,true,0.001,20,1,0,99); TestEarth("cos(x0) + x1", func3, 1000, 1, 2, 2, 51, 3,true,0.001,20,1,0,99); TestEarth("sin(2*x0)+2*x1*.5*x0*x1", func4, 1000, 1, 2, 2, 51, 3,true,0.001,20,1,0,99); TestEarth("sin(2*x0)+2*x1*.5*x0*x1", func4, 1000, 1, 3, 2, 51, 3,true,0.001,20,1,0,99); TestEarth("3rd order, mi=2 ni=11", func5, 1000, 1, 6, 2, 11, 1,true,0.001,20,1,0,99); TestEarth("3rd order, mi=2 ni=51", func5, 1000, 1, 6, 2, 51, 2,true,0.001,20,1,0,99); TestEarth("3rd order, mi=3", func5, 1000, 1, 6, 3, 51, 3,true,0.001,20,1,0,99); TestEarth("5 preds + noise", func6, 200, 1, 5+10, 2, 101, 3,true,0.001,20,1,0,99); TestEarth("5 preds clean", func6clean, 200, 1, 5+10, 2, 101, 3,true,0.001,20,1,0,99); TestEarth("10 preds + noise", func7, 200, 1, 10+40, 2, 101, 3,true,0.001,20,1,0,99); TestEarth("20 preds + noise,", func8, 100, 1, 20+10, 2, 101, 3,true,0.001,20,1,0,99); TestEarth("20 preds + noise,", func8, 400, 1, 20+10, 2, 101, 3,true,0.001,20,1,0,99); TestEarth("3rd order, mi=3 + noise", func5, 1000, 1, 10, 2, 51, 3,true,0.001,20,1,0,99); TestEarth("eqn56 mi=1", func56, 300, 1, 6, 1, 101, 3,true,0.001,20,1,0,99); TestEarth("eqn56 mi=2", func56, 300, 1, 6, 2, 51, 3,true,0.001,20,1,0,99); TestEarth("eqn56 mi=10", func56, 300, 1, 6, 10, 51, 3,true,0.001,20,1,0,99); // Following two tests are slow so are commented out (take more than half a second each) // TestEarth("eqn56 mi=10", func56, 1000, 1, 6, 10, 101, 3,true,0.001,20,1,0,99); // TestEarth("eqn56 mi=10", func56, 5000, 1, 6, 10, 101, 3,true,0.001,20,1,0,99); TestEarth("x0 + x1 + x0*x1", func2, 30, 1, 2, 2, 51, 3,true,0.001,99,1,0,99); TestEarth("x0 + x1 + x0*x1", func2, 30, 1, 2, 2, 51, 3,true,0.001, 4,0,0,99); TestEarth("x0 + x1 + x0*x1", func2, 30, 1, 2, 2, 51, 3,true,0.001, 4,1,0,99); // test multiple responses func nCases nResp nPreds nMaxDegree nMaxTerms Trace Form Thresh K B N s TestEarth("x0|x0+x1 degree=1", func0_1clean, 30, 2, 2, 1, 51, 3, true,0.001,20,1,0,99); TestEarth("x0|x+x1+noise", func0_1, 100, 2, 2, 1, 51, 3, true,0.001,20,1,0,99); TestEarth("x0+x1+x0*x1|x0+x1+x0*x1 degree=1", func2_2, 100, 2, 2, 1, 51, 3, true,0.001,20,1,0,99); TestEarth("x0+x1+x0*x1|x0+x1+x0*x1 degree=2", func2_2, 100, 2, 2, 2, 51, 3, true,0.001,20,1,0,99); TestEarth("x0|sin(2*x0) + 2*x1 + 0.5*x0*x1 + 8 noise preds", func0_4, 200, 2, 10, 2, 101, 3, true,0.001,20,1,0,99); TestEarth("x0|x0+x1+x0*x1|sin(2*x0) + 2*x1 + 0.5*x0*x1 + 8 noise preds", func0_2_4, 200, 3, 3+8, 2, 101, 3, true,0.001,20,1,0,99); TestEarth("|x0+x1+x0*x1|sin(2*x0) + 2*x1 + 0.5*x0*x1|x0 + 8 noise preds", func2_4_0, 200, 3, 3+8, 2, 101, 3, true,0.001,20,1,0,99); TestEarth("sin(2*x0) + 2*x1 + 0.5*x0*x1|x0+x1+x0*x1|x0 + 8 noise preds", func4_2_0, 200, 3, 3+8, 2, 101, 3, true,0.001,20,1,0,99); //TODO following gives lousy GRSq for Response 2, investigate TestEarth("sin(2*x0) + 2*x1 + 0.5*x0*x1|2nd order 6 preds + noise", func4_6, 1000, 2, 6, 2, 101, 3, true,0.001,20,1,0,99); // test NewVarPenalty func nCases nResp nPreds nMaxDegree nMaxTerms Trace Form Thresh K B NP s Colin // basis functions (after pruning) include both predictors TestEarth("cos(x1) + cos(x2), x1 and x2 xcollinear, NewVarPenalty=0", func2collinear, 100, 1, 2, 1, 51, 3, true, 0.001,20,1, 0, 99,.07); // basis functions (after pruning) include only one predictor TestEarth("cos(x1) + cos(x2), x1 and x2 xcollinear, NewVarPenalty=0", func2collinear, 100, 1, 2, 1, 51, 3, true, 0.001,20,1,0.1, 99,.07); #if PRINT_TIME printf("[Total time %.2f secs]\n", (double)(clock() - Time) / CLOCKS_PER_SEC); #endif return 0; } earth/inst/slowtests/test.plotd.Rout.save0000644000176200001440000005225713470056722020332 0ustar liggesusers> # test.plotd.R > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > data(etitanic) > > printh <- function(caption) + cat("===", caption, "\n", sep="") > > multifigure <- function(caption) + { + printh(caption) + par(mfrow=c(2, 2)) + par(cex = 0.7) + par(mar = c(4, 3, 1.7, 0.5)) # small margins and text to pack figs in + par(mgp = c(1.6, 0.6, 0)) # flatten axis elements + oma <- par("oma") # make space for caption + oma[3] <- 2.4 + par(oma=oma) + } > do.caption <- function(caption) + mtext(caption, outer=TRUE, font=2, line=1, cex=1) > old.par <- par(no.readonly=TRUE) > > # test plotd basic functionality on a numeric response > > multifigure("a1") # start a new page ===a1 > a1 <- earth(survived ~ ., data=etitanic, degree=2, glm=list(family=binomial)) > > plotd(a1) > do.caption("a1") > > plotd(a1, main="earth-glm, numeric, kernel=epan adjust=.3", trace=TRUE, + kernel="epan", adjust=.3, legend.names=c("mylegend", "mylegend2"), + legend.pos=c(.3,4), cex.legend=1, legend.extra=TRUE, + col=c(1, "green"), fill="red") observed response: numeric or logical vector predicted response: numeric or logical vector (predict type is "response") grouping criterion: CLASS1 survived == 0, CLASS2 survived != 0 predicted.response.per.class[not survived][619,1] with no column names, and values 0.9485, 0.4324, 0.9485, 0.369... predicted.response.per.class[survived ][427,1] with no column names, and values 0.9485, 0.9669, 0.2946, 0.851... > > plotd(a1, main="earth-glm, numeric, type=earth, params", + type="earth", xlab="my xlab", ylab="my ylab", + legend.pos="topleft", xlim=c(-.5, 1.5), zero.line=TRUE, vline.col="green", + col=c("pink", "red"), fill="pink") > > plotd(a1, main="earth-glm, numeric, type=link, params", type="link", legend=FALSE, + col=c("red", "blue"), lty=c(1,2), + vline.thresh=1, vline.col="gray", vline.lty=2) > > # test with earth.default (as opposed to earth.formula) > multifigure("a2") # start a new page ===a2 > a2 <- earth(etitanic[,-2], etitanic$survived, degree=2, glm=list(family=binomial)) > plotd(a2, main="earth.default-glm, numeric response") > do.caption("a2") > > printh("a3") ===a3 > a3 <- earth(etitanic[,-1], etitanic$pclass, degree=2, glm=list(family=binomial)) > plotd(a3, main="earth.default-glm, 3 lev fac") > > # test plotd with histograms > > plotd(a3, main="earth-glm, 3 lev fac, hist", hist=TRUE) > > plotd(a3, main="earth-glm, 3 lev fac, hist, params", + hist=TRUE, col=c("green", "red", "black"), fill="pink", lty=c(1,3), + xlab="my xlab", ylab="my ylab", xlim=c(-.2, 1.2), + vline.thresh=.65, vline.col="brown", vline.lty=2, breaks=5) > > # xlim and ylim tests > > multifigure("xlim and ylim tests") # start a new page ===xlim and ylim tests > plotd(a1, xlim=c(.25,.75), fill="gray") > printh("xlim and ylim tests") ===xlim and ylim tests > plotd(a1, xlim=c(.25,1), ylim=c(0,2)) > plotd(a1, xlim=c(.25,.75), hist=TRUE) > plotd(a1, xlim=c(.25,1), ylim=c(0,100), hist=TRUE) > > # test plotd with a logical response > > multifigure("a5") ===a5 > bool.survived <- as.logical(etitanic$survived) > a5 <- earth(bool.survived ~ . - survived, data=etitanic, degree=2, glm=list(family=binomial)) > plotd(a5, main="earth-glm, logical") > do.caption("a5") > plotd(a5, main="earth-glm, logical, hist", hist=TRUE) > > # test plotd with a two level factor > > multifigure("a6") ===a6 > a6 <- earth(sex ~ ., data=etitanic, glm=list(family=binomial)) > plotd(a6, main="earth-glm, 2 lev fac", fill="gray70") > do.caption("a6") > plotd(a6, main="earth-glm, 2 lev fac, type=class", type="class", fill="gray70") > plotd(a6, main="earth-glm, 2 lev fac, hist ", hist=TRUE) > plotd(a6, main="earth-glm, 2 lev fac, hist, type=class", type="class", hist=TRUE, labels=TRUE) > > # test plotd with a 3 level factor > > multifigure("a7") ===a7 > a7 <- earth(pclass ~ ., data=etitanic, glm=list(family=binomial)) > > plotd(a7, main="earth-glm, 3 lev fac", + col=c("pink", "red", "brown"), fill="pink") > do.caption("a7") > > plotd(a7, main="earth-glm, 3 lev fac, params", + xlab="my xlab", ylab="my ylab", xlim=c(-.2, 1.2), + col=c("pink", "black", "green"), lty=c(1,3,1), + vline.thresh=.2, vline.col="blue", vline.lty=3, + adjust=.3) > > plotd(a7, main="earth-glm, 3 lev fac, hist", hist=TRUE) > > plotd(a7, main="earth-glm, 3 lev fac, hist, params", + hist=TRUE, col=c("pink", "red", "black"), fill=c("pink"), lty=c(1,2,3), + xlab="my xlab", ylab="my ylab", xlim=c(-.2, 1.2), + vline.thresh=.65, vline.col="gray", vline.lty=1, + breaks=5) > > multifigure("a7 part 2") ===a7 part 2 > plotd(a7, type="class", main="earth-glm, 3 lev fac, type=class", fill="gray70") > do.caption("a7 part 2") > plotd(a7, type="class", main="earth-glm, 3 lev fac, hist, type=class", hist=TRUE, labels=TRUE) > > # test nresponse > > multifigure("a7 with nresponse") ===a7 with nresponse > plotd(a7, main="earth.default-glm, 3 lev fac") > do.caption("a7 with nresponse") > plotd(a7, main="earth.default-glm, 3 lev fac, nresp=1", nresp=1) > plotd(a7, main="earth.default-glm, 3 lev fac, nresp=2", nresp=2) > #plotd(a7, main="earth.default-glm, 3 lev fac, nresp=c(1,2)", nresp=c(1,2)) > > # test plotd with earth not glm > > multifigure("a8") ===a8 > a8 <- earth(survived ~ ., data=etitanic, degree=2) > plotd(a8, main="earth, numeric, no glm arg") > do.caption("a8") > plotd(a8, main="earth, hist, num, no glm arg, type=class", hist=TRUE, type="class") > > printh("a9") ===a9 > a9 <- earth(survived - .5 ~ .-survived, data=etitanic, degree=2) > plotd(a9, main="earth, survived-.5, type=class, thresh=0", hist=TRUE, type="class",thresh=0,vline.col="brown",xaxis.cex=.8, fill="pink",breaks=4,labels=TRUE) > plotd(a9, main="earth, survived-.5, type=class, thresh=0.3", hist=TRUE, type="class",thresh=0.3,vline.col="brown", xaxis.cex=.7,breaks=3,labels=TRUE) > > multifigure("a10") ===a10 > bool.survived <- as.logical(etitanic$survived) > a10 <- earth(bool.survived ~ . - survived, data=etitanic, degree=2) > plotd(a10, main="earth, logical, no glm arg") > do.caption("a10") > > printh("a11") ===a11 > a11 <- earth(sex ~ ., data=etitanic, degree=2) > plotd(a11, main="earth, 2 lev fac, no glm arg") > > printh("a12") ===a12 > a12 <- earth(pclass ~ ., data=etitanic, degree=2) > plotd(a12, main="earth, 3 lev fac, no glm arg") > > # test that we can change the order of the levels and still get the same results > multifigure("compare pclass with different factor levels") ===compare pclass with different factor levels > printh("fit.pclass") ===fit.pclass > fit.pclass <- earth(pclass ~ ., data=etitanic, degree=2) > plotd(fit.pclass, type="class", hist=1, main="fit.pclass", fill=0, + col=c(2, 1, "lightblue")) > do.caption("left and right graphs should match, up to level order") > printh("fit.pclass.reorder") ===fit.pclass.reorder > tit <- etitanic > pclass <- as.character(tit$pclass) > pclass[pclass == "1st"] <- "first" > pclass[pclass == "2nd"] <- "class2" > pclass[pclass == "3rd"] <- "classthird" > tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) > fit.pclass.reorder <- earth(pclass ~ ., data=tit, degree=2) > plotd(fit.pclass.reorder, type="class", hist=1, main="fit.pclass.reorder", + col=c(1, "lightblue", 2), fill=0, legend.pos="topright") > > # examples from the man page > > printh("example(plotd)") ===example(plotd) > example(plotd) plotd> if (require(earth)) { plotd+ old.par <- par(no.readonly=TRUE); plotd+ par(mfrow=c(2,2), mar=c(4, 3, 1.7, 0.5), mgp=c(1.6, 0.6, 0), par(cex = 0.8)) plotd+ data(etitanic) plotd+ mod <- earth(survived ~ ., data=etitanic, degree=2, glm=list(family=binomial)) plotd+ plotd+ plotd(mod) plotd+ plotd+ plotd(mod, hist=TRUE, legend.pos=c(.25,220)) plotd+ plotd+ plotd(mod, hist=TRUE, type="class", labels=TRUE, xlab="", xaxis.cex=.8) plotd+ plotd+ par(old.par) plotd+ } > do.caption("example(plotd)") > > multifigure("glm.model example from man page") ===glm.model example from man page > library(earth); data(etitanic) > glm.model <- glm(sex ~ ., data=etitanic, family=binomial) > plotd(glm.model) > do.caption("glm.model example from man page") > > printh("lm.model example from man page") ===lm.model example from man page > library(earth); data(etitanic) > lm.model <- lm(as.numeric(sex) ~ ., data=etitanic) > plotd(lm.model, trace=2) plotd trace 2: plotd(object=lm.model, trace=2) object call is lm(formula=as.numeric(sex)~., data=etitanic) --get.model.env for lm object using the environment saved with the lm model: R_GlobalEnv --plotmo_prolog for lm object lm.model observed response[1046,1]: as.numeric(sex) 1 1 2 2 3 1 ... 2 1046 2 calling predict.lm with NULL newdata stats::predict(lm.object, NULL, type="response") predict returned[1046,1] with no column names: 1 1.392914 2 1.212219 3 1.733813 ... 1.723106 1309 1.882905 predict after processing with nresponse=NULL is [1046,1] with no column names: 1 1.392914 2 1.212219 3 1.733813 ... 1.723106 1309 1.882905 single column yhat observed response: numeric or logical vector predicted response: numeric or logical vector (predict type is "response") grouping criterion: CLASS1 as.numeric(sex) == 1, CLASS2 as.numeric(sex) != 1 predicted.response.per.class[as.numeric(sex) == 1][388,1] with no column names: 1 1.392914 2 1.733813 3 1.725018 ... 1.353087 388 1.861625 predicted.response.per.class[as.numeric(sex) != 1][658,1] with no column names: 1 1.212219 2 1.723106 3 1.385648 ... 1.911098 658 1.882905 > plot(1,1) # empty.plot > plot(1,1) > > # test with rpart (also test nresponse with a character value) > printh("rpart") ===rpart > library(rpart); library(earth); data(etitanic) > rpart.model <- rpart(sex ~ ., data = etitanic, method="class") > plotd(rpart.model, type="prob", nresponse="female") > plotd(rpart.model, type="prob", nresponse="ma") > plotd(rpart.model, type="class", hist=TRUE, labels=TRUE) > plotd(rpart.model, hist=TRUE, labels=TRUE) # default type is "vector" > > printh("lda.model examples from man pages") ===lda.model examples from man pages > library(MASS); library(earth); data(etitanic) > lda.model <- lda(sex ~ ., data=etitanic) > plotd(lda.model, type="response") > plotd(lda.model, hist=TRUE, labels=TRUE) > > library(MASS); library(earth); set.seed(420) > example(lda) lda> Iris <- data.frame(rbind(iris3[,,1], iris3[,,2], iris3[,,3]), lda+ Sp = rep(c("s","c","v"), rep(50,3))) lda> train <- sample(1:150, 75) lda> table(Iris$Sp[train]) c s v 30 22 23 lda> ## your answer may differ lda> ## c s v lda> ## 22 23 30 lda> z <- lda(Sp ~ ., Iris, prior = c(1,1,1)/3, subset = train) lda> predict(z, Iris[-train, ])$class [1] s s s s s s s s s s s s s s s s s s s s s s s s s s s s c c c c c c c c c c [39] c c c c c c c c c c v v v v v v v v v v v v v v v v v v c c v v v v v v v Levels: c s v lda> ## [1] s s s s s s s s s s s s s s s s s s s s s s s s s s s c c c lda> ## [31] c c c c c c c v c c c c v c c c c c c c c c c c c v v v v v lda> ## [61] v v v v v v v v v v v v v v v lda> (z1 <- update(z, . ~ . - Petal.W.)) Call: lda(Sp ~ Sepal.L. + Sepal.W. + Petal.L., data = Iris, prior = c(1, 1, 1)/3, subset = train) Prior probabilities of groups: c s v 0.3333333 0.3333333 0.3333333 Group means: Sepal.L. Sepal.W. Petal.L. c 5.910000 2.746667 4.250000 s 5.036364 3.490909 1.459091 v 6.565217 2.939130 5.573913 Coefficients of linear discriminants: LD1 LD2 Sepal.L. 0.8709036 -0.3591731 Sepal.W. 1.1535614 2.7990902 Petal.L. -2.8007048 0.5780621 Proportion of trace: LD1 LD2 0.9903 0.0097 > plotd(z, type="response", nresponse=1) # nresponse=1 selects first linear discriminant > do.caption("lda.model example from example(lda)") > > a.qda <- qda(survived ~ ., data=etitanic) > plotd(a.qda) > plotd(a.qda, type="post") > > # test plotd with lm models > > multifigure("lm1") ===lm1 > lm1 <- lm(survived ~ ., data=etitanic) > plotd(lm1) > do.caption("lm1") > plotd(lm1, main="lm1, survived") > plotd(lm1, hist=TRUE, main="lm1, survived, hist=TRUE, labels=1", labels=1) > > printh("lm2") ===lm2 > bool.survived <- as.logical(etitanic$survived) > lm2 <- lm(bool.survived ~ . - survived, data=etitanic) > plotd(lm2, main="lm, logical") > > # following commented out because lm doesn't like factor responses(?) > # printh("lm3") > # lm3 <- lm(sex ~ ., data=etitanic) > # plotd(lm3, main="lm, 2 lev fac") > # > # printh("lm4") > # lm4 <- lm(pclass ~ ., data=etitanic) > # plotd(lm4, main="lm, 3 lev fac") > > multifigure("lm5") ===lm5 > lm5 <- lm(age - mean(age)~ ., data=etitanic) > plotd(lm5, main="lm5, age - mean(age)") > do.caption("lm5") > > printh("lm6") ===lm6 > lm6 <- lm(unclass(pclass)-1 ~ ., data=etitanic) > plotd(lm6, main="lm6, unclass(pclass)-1") > plotd(lm6, main="lm6, unclass(pclass)-1, fac=TRUE", hist=TRUE) > > printh("lm7") ===lm7 > lm7 <- lm(cbind(survived, sin(age)) ~ ., data=etitanic) # nonsense model > plotd(lm7, xlim=c(-.5,1.5), hist=TRUE, main="lm7, NCOL(y)==2") > > multifigure("lm5") ===lm5 > lm8 <- lm(cbind(survived, sin(age), cos(age)) ~ ., data=etitanic) # nonsense model > plotd(lm8, hist=TRUE, main="lm8, NCOL(y)==3") > do.caption("lm8") > > # test plotd with glm models > > multifigure("glm1") ===glm1 > glm1 <- glm(survived ~ ., data=etitanic, family=binomial) > plotd(glm1, main="glm1, survived") > do.caption("glm1") > > printh("glm2") ===glm2 > glm2 <- glm(pclass ~ ., data=etitanic, family=binomial) > plotd(glm2, main="glm2, pclass") > > printh("glm3") ===glm3 > glm3 <- glm(sex ~ ., data=etitanic, family=binomial) > plotd(glm3, main="glm3, sex") > > multifigure("glm, 3 level factor with dichot") ===glm, 3 level factor with dichot > glm4 <- glm(pclass ~ ., data=etitanic, family=binomial) > plotd(glm4, dichot = TRUE, type="link") > do.caption("glm, 3 level factor with dichot") > plotd(glm4, dichot = FALSE, type="link") > plotd(glm4, dichot = TRUE) # default type="response" > plotd(glm4, dichot = FALSE, type=NULL) # default type="response" > > # lda with formula interface > > library(MASS) > multifigure("lda1") ===lda1 > lda1 <- lda(sex ~ ., data=etitanic) > plotd(lda1, main="lda1, 2 lev fac", trace=1) observed response: two-level factor predicted response: numeric or logical vector (predict type is "class") grouping criterion: CLASS1 predicted[observed == female], CLASS2 predicted[observed == male] predicted.response.per.class[female][388,1] with no column names, and values 1, 2, 2, 1, 1, 1, 1, 1, 1, 1,... predicted.response.per.class[male ][658,1] with no column names, and values 1, 2, 1, 2, 2, 2, 1, 2, 2, 1,... > do.caption("lda1") > plotd(lda1, main="lda1, 2 lev fac, hist=TRUE", type="response", hist=TRUE) > plotd(lda1, main="lda1, 2 lev fac, hist=TRUE, type=post", hist=TRUE, type="post") > plotd(lda1, main="lda1, 2 lev fac, hist=TRUE, type=class", hist=TRUE, type="class", labels=TRUE) > > multifigure("lda2") ===lda2 > lda2 <- lda(pclass ~ ., data=etitanic) > plotd(lda2, type="response", main="lda2, 3 lev fac, nresponse=1", jitter=TRUE, nresponse=1) > do.caption("lda2") > plotd(lda2, type="response", main="lda2, 3 lev fac, nresponse=1", jitter=TRUE, nresponse=1) > plotd(lda2, type="response", main="lda2, 3 lev fac, nresponse=2", jitter=TRUE, nresponse=2) > # plotd(lda2, main="lda2, 3 lev fac, nresponse=NULL", jitter=TRUE, nresponse=NULL) > > multifigure("lda2 part 2") ===lda2 part 2 > # plotd(lda2, type="response", main="lda2, 3 lev fac, hist=TRUE", hist=TRUE) > plotd(lda2, main="lda2, 3 lev fac, hist=TRUE, type=p, nresponse=1", hist=TRUE, type="p", nresponse=1) > do.caption("lda2 part 2") > plotd(lda2, main="lda2, 3 lev fac, type=p", type="p") > plotd(lda2, main="lda2, 3 lev fac, hist=TRUE, type=class, nresponse=1", hist=TRUE, type="class", nresponse=1) > > multifigure("lda2 with dichot") ===lda2 with dichot > plotd(lda2, main="lda2, 3 lev fac, type=p, nresponse=1", hist=TRUE, type="p", nresponse=1) > do.caption("lda2 with dichot") > plotd(lda2, main="lda2, 3 lev fac, dichot=1, type=p, nresponse=1", hist=TRUE, type="p", nresponse=1, dichot=TRUE) > plotd(lda2, main="lda2, 3 lev fac, type=p, nresponse=1", type="p", nresponse=1) > plotd(lda2, main="lda2, 3 lev fac, dichot=1, type=p, nresponse=1", type="p", nresponse=1, dichot=TRUE) > > multifigure("lda3") ===lda3 > lda3 <- lda(survived ~ ., data=etitanic) > plotd(lda3, type="response", main="lda3, logical") > do.caption("lda3") > plotd(lda3, type="response", main="lda3, logical, hist=TRUE", hist=TRUE) > plotd(lda3, main="lda3, logical, hist=TRUE, type=posterior", hist=TRUE, type="posterior") > plotd(lda3, main="lda3, logical, hist=TRUE, type=class", hist=TRUE, type="class", labels=TRUE) > > # lda with default interface > > # predict.lda (called by plotd) can't deal with factors in x argument > etitanic1 <- etitanic > etitanic1[,1] <- as.numeric(etitanic1[,1]) # pclass > etitanic1[,3] <- as.numeric(etitanic1[,3]) # sex > > multifigure("ldad1") ===ldad1 > ldad1 <- lda(etitanic1[,-3], etitanic$sex) > plotd(ldad1, type="response", main="ldad1, 2 lev fac") > do.caption("ldad1") > plotd(ldad1, type="response", main="ldad1, 2 lev fac, hist=TRUE", hist=TRUE) > plotd(ldad1, main="ldad1, 2 lev fac, hist=TRUE, type=post", hist=TRUE, type="post") > plotd(ldad1, main="ldad1, 2 lev fac, hist=TRUE, type=class", hist=TRUE, type="class") > > multifigure("ldad2") ===ldad2 > ldad2 <- lda(etitanic1[,-1], etitanic$pclass) > # plotd(ldad2, type="response", main="ldad2, 3 lev fac", jitter=TRUE) > plotd(ldad2, type="response", main="ldad2, 3 lev fac, nresponse=1", jitter=TRUE, nresponse=1) > do.caption("ldad2") > plotd(ldad2, type="response", main="ldad2, 3 lev fac, nresponse=2", jitter=TRUE, nresponse=2) > multifigure("ldad2 part 2") ===ldad2 part 2 > plotd(ldad2, type="response", main="ldad2, 3 lev fac, hist=TRUE, nresponse=1", hist=TRUE, nresponse=1) > do.caption("ldad2 part 2") > plotd(ldad2, main="ldad2, 3 lev fac, hist=TRUE, type=p, nresponse=1", hist=TRUE, type="p", nresponse=1) > plotd(ldad2, main="ldad2, 3 lev fac, type=p, nresponse=1", type="po", nresponse=1) > plotd(ldad2, main="ldad2, 3 lev fac, hist=TRUE, type=class, nresponse=1", hist=TRUE, type="cla", nresponse=1) > > multifigure("ldad3") ===ldad3 > ldad3 <- lda(etitanic1[,-2], etitanic$survived) > plotd(ldad3, type="response", main="ldad3, logical") > do.caption("ldad3") > plotd(ldad3, type="response", main="ldad3, logical, hist=TRUE", hist=TRUE) > plotd(ldad3, main="ldad3, logical, hist=TRUE, type=post", hist=TRUE, type="post") > plotd(ldad3, main="ldad3, logical, hist=TRUE, type=cl", hist=TRUE, type="cl") > > # err shading > > multifigure("err shading") ===err shading > a.shade <- earth(survived ~ ., data=etitanic, degree=2, glm=list(family=binomial)) > plotd(a.shade, vline.col="gray", err.col=c("slategray1","slategray3"), fill=0) > do.caption("err shading") > plotd(a.shade, vline.col="gray", err.col=c(0, 0,"pink"), fill=0, vline.thresh = .6, err.border=c(0,0,2)) > # try various err.shade options > plotd(a.shade, vline.thresh = .7, vline.col=1, vline.lty=2, vline.lwd=3, fill=0, col=c(2,1), + err.col=c("slategray1","slategray3","pink"), + err.border=c(3,4,5), err.lwd=c(1,2,3)) > # reverse direction of reducible error area > a1.shade <- earth(!survived ~ ., data=etitanic, degree=2, glm=list(family=binomial)) > plotd(a1.shade, vline.col="gray", err.col=c("slategray1","slategray3","pink"), err.border=c("slategray1","slategray3","red")) > > # clip xlim into the shaded area and make sure area is still shaded correctly > multifigure("err shading with xlim") ===err shading with xlim > a.shade <- earth(survived ~ ., data=etitanic, degree=2, glm=list(family=binomial)) > plotd(a.shade, vline.thresh = .7, vline.col=1, vline.lty=2, vline.lwd=3, fill=0, col=c(2,1), + err.col=c("slategray1","slategray3","pink"), + err.border=c(3,4,5), err.lwd=c(1,2,3), xlim=c(.3,1)) > plotd(a.shade, vline.thresh = .7, vline.col=1, vline.lty=2, vline.lwd=3, fill=0, col=c(2,1), + err.col=c("slategray1","slategray3","pink"), + err.border=c(3,4,5), err.lwd=c(1,2,3), xlim=c(.5,1)) > plotd(a.shade, vline.thresh = .7, vline.col=1, vline.lty=2, vline.lwd=3, fill=0, col=c(2,1), + err.col=c("slategray1","slategray3","pink"), + err.border=c(3,4,5), err.lwd=c(1,2,3), xlim=c(.3,.6)) > # reverse direction of reducible error area > a1.shade <- earth(!survived ~ ., data=etitanic, degree=2, glm=list(family=binomial)) > plotd(a1.shade, vline.col="gray", err.col=c("slategray1","slategray3","pink"), + err.border=c("slategray1","slategray3","red"), xlim=c(.52, .9)) > > par(old.par) > > source("test.epilog.R") earth/inst/slowtests/test.pmethod.cv.bat0000755000176200001440000000256513514230362020130 0ustar liggesusers@Rem test.pmethod.cv.R: example pmethod.cv model built by earth @rem Stephen Milborrow May 2015 Berea @echo test.pmethod.cv.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.pmethod.cv.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.pmethod.cv.Rout: @echo. @tail test.pmethod.cv.Rout @echo test.pmethod.cv.R @exit /B 1 :good1 @echo diff test.pmethod.cv.Rout test.pmethod.cv.Rout.save @rem egreps to deal with times @C:\Rtools\bin\echo -n "new " @egrep "^\[total time" test.pmethod.cv.Rout @C:\Rtools\bin\echo -n "old " @egrep "^\[total time" test.pmethod.cv.Rout.save @egrep -v "^\[total time" test.pmethod.cv.Rout >test.pmethod.cv.Rout1 @egrep -v "^\[total time" test.pmethod.cv.Rout.save >test.pmethod.cv.Rout.save1 @rem -w to treat \n same as \r\n @mks.diff -w test.pmethod.cv.Rout1 test.pmethod.cv.Rout.save1 @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.pmethod.cv.save.ps @exit /B 1 :good2 @rem test.pmethod.cv.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.pmethod.cv.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.pmethod.cv.Rout test.pmethod.cv.Rout1 test.pmethod.cv.Rout.save1 @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.glm.bat0000755000176200001440000000141213514230362016626 0ustar liggesusers@rem test.glm.bat @echo test.glm.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.glm.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.glm.Rout: @echo. @tail test.glm.Rout @echo test.glm.R @exit /B 1 :good1 mks.diff test.glm.Rout test.glm.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.glm.save.ps @exit /B 1 :good2 @rem test.glm.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.glm.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.glm.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.full.R0000644000176200001440000022301113446220721016444 0ustar liggesusers# test.full.R: test earth print(R.version.string) source("test.prolog.R") source("check.models.equal.R") library(earth) library(mda) data(ozone1) data(trees) data(etitanic) PRINT.TIME <- FALSE # FALSE for no time results (for diff against reference) PLOT <- TRUE # TRUE to do plots too, FALSE for speed options.old <- options() options(warn=1) # print warnings as they occur # options(digits=5) # removed because want to check against default printh <- function(x, expect.warning=FALSE, max.print=0) # like print but with a header { cat("===", deparse(substitute(x)), " ", sep="") if(expect.warning) cat(" expect warning -->") else if (NROW(x) > 1) cat("\n") if (max.print > 0) print(head(x, n=max.print)) else print(x) } print(citation("earth")) #--- test examples from man pages ------------------------------------------------------------ cat("--- earth.Rd -----------------------------\n") example(earth) set.seed(2015) train.subset <- sample(1:nrow(trees), .8 * nrow(trees)) test.subset <- (1:nrow(trees))[-train.subset] earth.model <- earth(Volume ~ ., data = trees[train.subset,]) # print R-Squared on the test data print(summary(earth.model, newdata=trees[test.subset,])) # manually calculate R-Squared on the test data (same as above call to summary) yhat <- predict(earth.model, newdata = trees[test.subset,]) y <- trees$Volume[test.subset] printh(1 - sum((y - yhat)^2) / sum((y - mean(y))^2)) # print R-Squared newrsq <- 1 - sum((y - yhat)^2) / sum((y - mean(y))^2) stopifnot(abs(summary(earth.model, newdata=trees[test.subset,])$newrsq - newrsq) < 1e-10) cars <- earth(mpg ~ ., data = mtcars, pmethod = "none", trace = 4) stopifnot(max(coef(cars) - cars$coefficients) == 0) stopifnot(max(coef(cars, type="response") - cars$coefficients) == 0) stopifnot(max(coef(cars, type="earth") - cars$coefficients) == 0) expect.err(try(coef(cars, type="nonesuch")), "type=\"nonesuch\" is not allowed") expect.err(try(coef(cars, type="glm")), "type == \"glm\" is not allowed because this is not an earth-glm model") expect.err(try(coefficients(cars, type="glm")), "type == \"glm\" is not allowed because this is not an earth-glm model") stopifnot(isTRUE(all.equal(coef(cars), coefficients(cars)))) stopifnot(isTRUE(all.equal(coef(cars, type="earth"), coefficients(cars, type="earth")))) stopifnot(identical(names(coef(cars)), rownames(cars$coefficients))) get.used.pred.names <- function(obj) # obj is an earth object { any1 <- function(x) any(x != 0) # like any but no warning if x is double names(which(apply(obj$dirs[obj$selected.terms,,drop=FALSE],2,any1))) } printh(get.used.pred.names(cars)) a1 <- earth(survived ~ ., data=etitanic, # c.f. Harrell "Reg. Mod. Strat." ch. 12 degree=2, trace=1, glm=list(family=binomial)) printh(a1) a1a <- earth(etitanic[,-2], etitanic[,2], # equivalent but using earth.default degree=2, trace=1, glm=list(family=binomial)) printh(a1a) a2 <- earth(pclass ~ ., data=etitanic, glm=list(family=binomial), trace=1) printh(a2) ldose <- rep(0:5, 2) - 2 # Venables and Ripley 4th edition page 191 sex <- factor(rep(c("male", "female"), times=c(6,6))) numdead <- c(1,4,9,13,18,20,0,2,6,10,12,16) pair <- cbind(numdead, numalive=20 - numdead) a3 <- earth(pair ~ sex + ldose, glm=list(family=binomial(link=probit), maxit=100), trace=1) printh(a3) numalive <- 20 - numdead pairmod2 <- earth(numalive + numdead ~ sex + ldose, glm=list(family=binomial()), trace=1) printh(pairmod2) # multiple responses with short (compacted) binomial data no longer supported numdead2.verylongname <- c(2,8,11,12,20,23,0,4,6,16,12,14) # bogus data doublepair <- cbind(numdead, numalive=20-numdead, numdead2.verylongname=numdead2.verylongname, numalive2.verylongname=30-numdead2.verylongname) expect.err(try(earth(doublepair ~ sex + ldose, trace=1, pmethod="none", glm=list(family="binomial"))), "Binomial response (see above): all values should be between 0 and 1, or a binomial pair") counts <- c(18,17,15,20,10,20,25,13,12) # Dobson 1990 p. 93 outcome <- gl(3,1,9) treatment <- gl(3,3) a5 <- earth(counts ~ outcome + treatment, trace=1, pmethod="none", glm=list(family=poisson)) printh(a5) a6 <- earth(numdead ~ sex + ldose, glm=list(family=gaussian(link=identity)), trace=1) printh(a6$coefficients == a6$glm.coefficients) # all TRUE printh(a6) remove(ldose) remove(sex) remove(numdead) remove(pair) remove(numdead2.verylongname) remove(doublepair) remove(counts) remove(outcome) remove(treatment) printh(earth(cbind(Volume,lvol=log(Volume)) ~ ., data=trees)) attach(trees) printh(earth(data.frame(Girth,Height), data.frame(Volume,lvol=log(Volume)))) detach(trees) lm.fit <- lm(O3 ~ log(temp) + humidity*temp, data=ozone1) printh(lm.fit) plotmo(lm.fit, level=.95, trace=-1) lm.fit2 <- lm(O3 ~ temp+ibh+doy, data=ozone1) printh(lm.fit2) plotmo(lm.fit2, all2=TRUE, clip=FALSE, trace=-1) cat("--- print.default of earth object---------\n") print.default(cars, digits=3) cat("--- done print.default of earth object----\n") if (PLOT) plot(cars) library(mda) (a <- fda(Species~., data=iris, method=earth, keepxy=TRUE)) if (PLOT) plot(a) printh(summary(a$fit)) expect.err(try(printh(summary(a$fit, none.such1="xxx"))), "unrecognized argument") # summary.earth unrecognized argument "none.such1" printh(summary(a$fit, style="bf", none.such2="xxx")) # Warning: format.earth ignored unrecognized argument "none.such2" if (PLOT) { plot(a$fit, col.residuals=iris$Species, nresponse=1) plotmo(a$fit, nresponse=1, ylim=c(-1.5,1.5), clip=FALSE, trace=-1) plotmo(a$fit, nresponse=2, ylim=c(-1.5,1.5), clip=FALSE, trace=-1) } a <- update(a, nk=3) # not on man page printh(a) printh(summary(a$fit)) head(etitanic) # pclass and sex are unordered factors earth(pclass ~ ., data=etitanic, trace=2) cat("--- format.earth.Rd ----------------------\n") as.func <- function( # convert expression string to func object, digits = 8, use.names = TRUE, ...) eval(parse(text=paste( "function(x)\n", "{\n", "if(is.vector(x))\n", " x <- matrix(x, nrow = 1, ncol = length(x))\n", "with(as.data.frame(x),\n", format(object, digits = digits, use.names = use.names, style = "p", ...), ")\n", "}\n", sep = ""))) a <- earth(Volume ~ ., data = trees) my.func <- as.func(a, use.names = FALSE) printh(my.func(c(10,80))) # yields 17.76888 printh(predict(a, c(10,80))) # yields 17.76888, but is slower example(format.earth) a <- earth(Volume ~ ., data = trees) cat(format(a)) # basic tests of format.earth cat(format(a, digits=4)) # cat(format(a, use.names=FALSE)) cat(format(a, style="pmax")) cat(format(a, style="max")) cat(format(a, style="bf")) cat(format(a, use.names=FALSE, style="p")) cat(format(a, use.names=FALSE, style="m")) a <- earth(Volume ~ Girth*Height, data = trees, pmethod="none") cat(format(a)) cat(format(a, colon.char="*")) a <- lm(Volume ~ ., data = trees) cat(format(a)) # basic tests of format.lm cat(format(a, digits=4)) cat(format(a, use.names=FALSE)) cat(format(a, style="p")) cat(format(a, use.names=FALSE, style="p")) a <- lm(Volume ~ Girth*Height, data = trees) cat(format(a)) cat(format(a, colon.char="*")) cat("--- mars.to.earth.Rd ----------------------\n") example(mars.to.earth) library(mda) a <- mars(trees[,-3], trees[,3]) a <- mars.to.earth(a) print(summary(a, digits = 2)) printh(summary(a, digits=2)) printh(summary(a, digits=2, style="bf")) cat("--- plot.earth.models.Rd ----------------------\n") if (PLOT) example(plot.earth.models) cat("--- plot.earth.Rd ----------------------\n") if (PLOT) { data(etitanic) a <- earth(survived ~ ., data=etitanic, glm=list(family=binomial)) par(mfrow=c(2,2)) plot(a$glm.list[[1]], caption="a$glm.list[[1]]") example(plot.earth) } cat("--- predict.earth.Rd ----------------------\n") example(predict.earth) cat("--- residuals.earth.Rd --------------------\n") example(residuals.earth) cat("--- update.earth.Rd ----------------------\n") example(update.earth) cat("--- evimp.Rd -----------------------------\n") par(mfrow=c(2,2)) cat('before calling evimp par("mar", "cex"):\n') print(par("mar", "cex")) example(evimp) cat("--- plot.evimp.Rd ------------------------\n") example(plot.evimp) rownames(ev)[4] <- "a_long_variable_name" plot(ev, main="plot.evimp with various options", cex.var = .8, type.nsubsets = "p", col.nsubsets = "red", lty.nsubsets = 2, # ignored because type.nsubsets="p" type.gcv = "l", col.gcv = "green", lty.gcv = 3, type.rss = "b", col.rss = "blue", lty.rss = 4, cex.legend = .8, x.legend = "topright", rh.col = "pink") a <- earth(Volume ~ Girth, data = trees) plot(evimp(a), main="plot.evimp with single var in model") cat('after calling evimp par("mar", "cex"):\n') print(par("mar", "cex")) par(mfrow=c(1,1)) cat("--- test predict.earth -------------------\n") a <- earth(Volume ~ ., data = trees) cat("1a predict(a, c(10,80))\n") printh(predict(a, c(10,80), trace=1)) cat("1b predict(a, c(10,10,80,80))\n") printh(predict(a, c(10,10,80,80), trace=1)) cat("1c predict(a, c(10,11,80,81))\n") printh(predict(a, c(10,11,80,81), trace=1)) cat("2 predict(a)\n") printh(head(predict(a, trace=1))) cat("3a predict(a, matrix(c(10,12), nrow=1, ncol=2))\n") printh(predict(a, matrix(c(10,12), nrow=1, ncol=2), trace=1)) cat("3b predict(a, matrix(c(10,12), nrow=2, ncol=2, byrow=TRUE)\n") printh(predict(a, matrix(c(10,12), nrow=2, ncol=2, byrow=TRUE), trace=1)) cat("3c predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2))\n") printh(predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2), trace=1)) xpredict <- matrix(c(10,12,80,90), nrow=2, ncol=2) colnames(xpredict) <- c("Girth", "Height") cat("4 predict(a, xpredict with colnames)\n") printh(predict(a, xpredict, trace=1)) cat("5 predict(a, as.data.frame(xpredict with colnames))\n") printh(predict(a, as.data.frame(xpredict), trace=1)) # reverse dataframe columns (and their names), predict should deal with it correctly xpredict <- as.data.frame(cbind(xpredict[,2], xpredict[,1])) colnames(xpredict) <- c("Height", "Girth") cat("6a predict(a, xpredict with reversed columns and colnames)\n") printh(predict(a, xpredict, trace=1)) xpredict2 <- cbind(xpredict[,1], xpredict[,2]) # nameless matrix cat("6b predict(a, xpredict2)\n") printh(predict(a, xpredict2, trace=1)) # repeat but with x,y (not formula) call to earth x1 <- cbind(trees$Girth, trees$Height) colnames(x1) <- c("Girth", "Height") a <- earth(x1, trees$Volume) xpredict <- matrix(c(10,12,80,90), nrow=2, ncol=2) cat("7a predict(a)\n") printh(head(predict(a, trace=1))) cat("7n predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2)\n") printh(predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2), trace=1)) colnames(xpredict) <- c("Girth", "Height") cat("8 predict(a, xpredict with colnames)\n") printh(predict(a, xpredict, trace=1)) cat("9 predict(a, as.data.frame(xpredict with colnames))\n") printh(predict(a, as.data.frame(xpredict), trace=1)) cat("--Expect warning from predict.earth: the variable names in 'data' do not match those in 'object'\n") xpredict2 <- cbind(xpredict[,1], xpredict[,2]) colnames(xpredict2) <- c("none.such", "joe") cat("10a predict(a, xpredict2)\n") printh(predict(a, xpredict2, trace=1), expect.warning=TRUE) cat("--Expect warning from predict.earth: the variable names in 'data' do not match those in 'object'\n") xpredict2 <- cbind(xpredict[,1], xpredict[,2]) colnames(xpredict2) <- c("Height", "Girth") # reversed cat("10b predict(a, xpredict2)\n") printh(predict(a, xpredict2, trace=1), expect.warning=TRUE) cat("--- test predict.earth with multiple response models-------------------\n") a <- earth(cbind(Volume, Volume + 100) ~ ., data = trees) cat("1a predict(a, c(10,80))\n") printh(predict(a, c(10,80), trace=1)) predict.a1a <- predict(a, c(10,80)) check.almost.equal(predict.a1a[1,1], 17.6035895926138, msg="predict.a1a[1,1]") check.almost.equal(predict.a1a[1,2], 117.603589592614, msg="predict.a1a[1,2]") cat("1b predict(a, c(10,10,80,80))\n") printh(predict(a, c(10,10,80,80), trace=1)) cat("1c predict(a, c(10,11,80,81))\n") printh(predict(a, c(10,11,80,81), trace=1)) cat("1d predict(a, data.frame=c(Girth=10,Height=80))\n") printh(predict(a, newdata=data.frame(Girth=10,Height=80))) predict.a1d <- predict(a, newdata=data.frame(Girth=10,Height=80)) check.almost.equal(predict.a1d[1,1], 17.6035895926138, msg="predict.a1d[1,1]") check.almost.equal(predict.a1d[1,2], 117.603589592614, msg="predict.a1d[1,2]") expect.err(try(predict(a, newdata=10)), "get.earth.x from model.matrix.earth from predict.earth:\n could not convert vector x to matrix because length(x) 1\n is not a multiple of the number 2 of predictors") cat("2 predict(a)\n") printh(head(predict(a, trace=1))) cat("3a predict(a, matrix(c(10,12), nrow=1, ncol=2))\n") printh(predict(a, matrix(c(10,12), nrow=1, ncol=2), trace=1)) cat("3b predict(a, matrix(c(10,12), nrow=2, ncol=2, byrow=TRUE)\n") printh(predict(a, matrix(c(10,12), nrow=2, ncol=2, byrow=TRUE), trace=1)) cat("3c predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2))\n") printh(predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2), trace=1)) xpredict <- matrix(c(10,12,80,90), nrow=2, ncol=2) colnames(xpredict) <- c("Girth", "Height") cat("4 predict(a, xpredict with colnames)\n") printh(predict(a, xpredict, trace=1)) cat("5 predict(a, as.data.frame(xpredict with colnames))\n") printh(predict(a, as.data.frame(xpredict), trace=1)) # reverse dataframe columns (and their names), predict should deal with it correctly xpredict <- as.data.frame(cbind(xpredict[,2], xpredict[,1])) colnames(xpredict) <- c("Height", "Girth") cat("6 predict(a, xpredict with reversed columns and colnames)\n") printh(predict(a, xpredict, trace=1)) expect.err(try(predict(a, interval="pin")), "no prediction intervals because the earth model was not built with varmod.method") expect.err(try(earth(cbind(Volume, Volume + 100) ~ ., data = trees, nfold=3, ncross=3, varmod.method="lm")), "variance models are not supported for multiple response models") # repeat but with x,y (not formula) call to earth x1 <- cbind(trees$Girth, trees$Height) colnames(x1) <- c("Girth", "Height") a <- earth(x1, cbind(trees$Volume, trees$Volume+100)) xpredict <- matrix(c(10,12,80,90), nrow=2, ncol=2) cat("7a predict(a)\n") printh(head(predict(a, trace=1))) cat("7b predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2)\n") printh(predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2), trace=1)) colnames(xpredict) <- c("Girth", "Height") cat("8 predict(a, xpredict with colnames)\n") printh(predict(a, xpredict, trace=1)) cat("9 predict(a, as.data.frame(xpredict with colnames))\n") printh(predict(a, as.data.frame(xpredict), trace=1)) cat("--Expect warning from predict.earth: the variable names in 'data' do not match those in 'object'\n") xpredict <- as.data.frame(cbind(xpredict[,2], xpredict[,1])) colnames(xpredict) <- c("Height", "Girth") cat("10 predict(a, xpredict)\n") printh(predict(a, xpredict, trace=1), expect.warning=TRUE) cat("--- earth.predict with NAs, with formula interface ---\n") predict.with.message <- function(message, earth.model, newdata) { cat("predict.earth ", message, ":\n", sep="") print(predict(earth.model, newdata=newdata, trace=1)) cat("\n") } iris.earth <- earth(Petal.Width ~ Sepal.Length + Sepal.Width + Petal.Length, data=iris) x <- iris[1,] predict.with.message("formula interface and vector", iris.earth, newdata=x) x$Sepal.Width <- as.numeric(NA) predict.with.message("formula interface and vector with NA", iris.earth, newdata=x) x <- iris[1,] x$Petal.Width <- as.numeric(NA) # Petal.Width is unused in the earth model predict.with.message("formula interface and vector with NA in unused variable", iris.earth, newdata=x) x <- iris[1:3,] predict.with.message("formula interface and matrix", iris.earth, newdata=x) x[2,]$Sepal.Width <- as.numeric(NA) predict.with.message("formula interface and matrix with NA", iris.earth, newdata=x) x <- iris[1:3,] x[2,]$Petal.Width <- as.numeric(NA) # Petal.Width is unused in the earth model predict.with.message("formula interface and matrix with NA in unused variable", iris.earth, newdata=x) cat("--- earth.predict with NAs, with matrix interface ---\n") iris.earth <- earth(iris[,1:3], iris[,4]) x <- iris[1,] predict.with.message("default interface and vector", iris.earth, newdata=x) x$Sepal.Width <- as.numeric(NA) predict.with.message("default interface and vector with NA", iris.earth, newdata=x) x <- iris[1,] x$Petal.Width <- as.numeric(NA) # Petal.Width is unused in the earth model predict.with.message("default interface and vector with NA in unused variable", iris.earth, newdata=x) x <- iris[1:3,] predict.with.message("default interface and matrix", iris.earth, newdata=x) x[2,]$Sepal.Width <- as.numeric(NA) predict.with.message("default interface and matrix with NA", iris.earth, newdata=x) x <- iris[1:3,] x[2,]$Petal.Width <- as.numeric(NA) # Petal.Width is unused in the earth model predict.with.message("default interface and matrix with NA in unused variable", iris.earth, newdata=x) cat("--- test reorder.earth ----------------------\n") a <- earth(O3 ~ ., data = ozone1, degree = 2) earth:::reorder.earth(a, decomp = "none") earth:::reorder.earth(a) # defaults to decomp = "anova" a$selected.terms[earth:::reorder.earth(a)] cat("--- tests with ozone data ----------------------\n") ozone.test <- function(itest, sModel, x, y, degree=2, nk=51, plotit=PLOT, trace=0, smooth.col="red") { fite <- earth(x, y, degree=degree, nk=nk, trace=trace) fitm <- mars(x, y, degree=degree, nk=nk) cat("itest", sprint("%-3d", itest), sprint("%-32s", sModel), "degree", sprint("%-2d", degree), "nk", sprint("%-3g", nk), "nTerms", sprint("%-2d", sum(fite$selected.terms != 0)), "of", sprint("%-3d", nrow(fite$dirs)), "GRSq", sprint("%4.2g", fite$grsq), "GRSq ratio", fite$grsq/mars.to.earth(fitm)$grsq, "\n") caption <- paste("itest ", itest, ": ", sModel, " degree=", degree, " nk=", nk, sep="") printh(summary(fite)) printh(summary(fite, style="bf")) if(plotit) { fitme <- mars.to.earth(fitm) plotmo(fite, caption=paste("EARTH", caption), trace=-1) plotmo(fitme, caption=paste("MARS", caption), trace=-1) plot(fite, npoints=500, smooth.col=smooth.col, caption=paste("EARTH", caption), info=TRUE) plot(fitme, caption=paste("MARS", caption), info=TRUE) fitme <- update(fitme) # generate model selection data plot.earth.models(list(fite, fitme), caption=paste(itest, ": Compare earth to mars ", sModel, sep="")) } fite } data(ozone1) attach(ozone1) x.global <- cbind(wind, humidity, temp, vis) y <- doy itest <- 1; ozone.test(itest, "doy ~ wind+humidity+temp+vis", x.global, y, degree=1, nk=21) x.global <- cbind(wind, humidity, temp, vis) y <- doy itest <- itest+1; a91 <- ozone.test(itest, "doy ~ wind+humidity+temp+vis", x.global, y, degree=2, nk=21) # this is a basic test of RegressAndFix (because this generates lin dep bx cols) cat("--Expect warning from mda::mars: NAs introduced by coercion\n") # why do we get a warning? x.global <- cbind(wind, exp(humidity)) y <- doy # smooth.col is 0 else get loess errors # trace==2 so we print the "Fixed rank deficient bx by removing 2 terms, 7 terms remain" message # TODO why are we getting the rank deficient message? itest <- itest+1; ozone.test(itest, "doy ~ wind+exp(humidity)", x.global, y, degree=1, nk=21, smooth.col=0, trace=2) x.global <- cbind(vh,wind,humidity,temp,ibh,dpg,ibt,vis,doy) y <- O3 itest <- itest+1; ozone.test(itest, "O3~.", x.global, y, degree=2, nk=21) x.global <- cbind(vh,wind,humidity,temp,ibh,dpg,ibt,vis,doy) y <- O3 itest <- itest+1; ozone.test(itest, "O3~., nk=51", x.global, y, degree=2, nk=51) detach(ozone1) cat("--- fast mars -----------------------------------\n") printh(earth(O3 ~ ., data=ozone1, degree=2, nk = 31, fast.k = 0, fast.beta = 1)) printh(earth(O3 ~ ., data=ozone1, degree=2, nk = 31, fast.k = 0, fast.beta = 0)) printh(earth(O3 ~ ., data=ozone1, degree=2, nk = 31, fast.k = 5, fast.beta = 1)) printh(earth(O3 ~ ., data=ozone1, degree=2, nk = 31, fast.k = 5, fast.beta = 0)) cat("--- plot.earth and plot.earth.models ------------\n") a <- earth(O3 ~ ., data=ozone1) # formula interface if (PLOT) plot(a, caption="plot.earth test 1", col.rsq=3, smooth.col=4, qqline.col="pink", col.vline=1, col.npreds=0, nresiduals=100, cum.grid="grid", grid.col="lightblue", col.sel.grid="lightgreen") set.seed(1) if (PLOT) { plot(a, caption="plot.earth test 2", which=c(3,4,1), ylim=c(.2,.9), id.n=20, legend.pos=c(10,.6), pch=20, lty.vline=1, cex.legend=1, grid.col="lightblue") plot(a, caption="plot.earth test 3", which=2, main="test main") } a1 <- earth(ozone1[,c(2:4,10)], ozone1[,1]) # x,y interface if (PLOT) { plot(a, caption="plot.earth test 4", id.n=1) set.seed(1) plot.earth.models(a, which=1, ylim=c(.4,.8), jitter=.01) plot.earth.models(a1) plot.earth.models(list(a, a1), col.cum=c(3,4), col.grsq=c(1,2), col.rsq=c(3,4), col.npreds=1, col.vline=1, lty.vline=3, legend.pos=c(5,.4), legend.text=c("a", "b", "c"), cex.legend=1.3) } cat("--- plot.earth args -----------------------------\n") test.plot.earth.args <- function() { caption <- "test earth args" printh(caption) argtest <- earth(ozone1[,c(2:4,10)], ozone1[,1]) old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) par(mfrow=c(2,3)) par(cex = 0.8) par(mar = c(3, 3, 3, 0.5)) # small margins and text to pack figs in par(mgp = c(1.6, 0.6, 0)) # flatten axis elements oma <- par("oma") # make space for caption oma[3] <- 2.4 par(oma=oma) par(cex.main=1) plot(argtest, do.par=FALSE, which=1, main="default") mtext(caption, outer=TRUE, font=2) plot(argtest, do.par=FALSE, which=1, col.rsq=3, col.grsq=2, col.npreds="blue", grid.col="lightblue", main=sprint("%s\n%s", "col.rsq=3, col.grsq=2, ", "col.npreds=\"lightblue\", col.sel.grid=\"gray\"")) plot(argtest, do.par=FALSE, which=1, col.vline="pink", legend.pos="topleft", lty.grsq=2, lty.npreds=1, lty.vline=1, main=sprint("%s\n%s", "col.vline=\"pink\", legend.pos=\"topleft\", ", "lty.grsq=2, lty.npreds=1, lty.vline=1")) plot(argtest, do.par=FALSE, which=1, legend.pos=NA, col.npreds=0, main="legend.pos=NA, col.npreds=0") plot(argtest, do.par=FALSE, which=1, legend.pos=0, main="legend.pos=0") } test.plot.earth.args() cat("--- test minspan --------------------------------\n") a.minspan2 <- earth(O3 ~ ., data=ozone1, minspan=2) printh(summary(a.minspan2)) a.minspan0 <- earth(O3 ~ ., data=ozone1, minspan=0) printh(summary(a.minspan0)) a.minspan.minus1 <- earth(O3 ~ ., data=ozone1, minspan=-1) printh(summary(a.minspan.minus1)) a.minspan.minus3 <- earth(O3 ~ ., data=ozone1, minspan=-3) printh(summary(a.minspan.minus3)) a.endspan80 <- earth(O3 ~ ., data=ozone1, endspan=80) printh(summary(a.endspan80)) cat("--- test multiple responses ---------------------\n") # this uses the global matrix data.global (data.global[,1:2] is the response) test.two.responses <- function(itest, func1, func2, degree=2, nk=51, plotit=PLOT, test.rsq=TRUE, trace=0, minspan=0, test.mars.to.earth=FALSE, pmethod="backward") { if(typeof(func1) == "character") funcnames <- paste("multiple responses", func1, func2) else funcnames <- paste("multiple responses", deparse(substitute(func1)), deparse(substitute(func2))) cat("itest", sprint("%-3d", itest), funcnames, " degree", sprint("%-2d", degree), "nk", sprint("%-3g", nk), "\n\n") gc() fite <- earth(x=data.global[,c(-1,-2), drop=FALSE], y=data.global[,1:2], degree=degree, trace=trace, nk=nk, pmethod=pmethod, minspan=minspan) printh(fite) caption <- paste("itest ", itest, ": ", funcnames, " degree=", degree, " nk=", nk, sep="") if(plotit) { if(typeof(func1) == "character") { plotmo(fite, caption=caption, nresponse=1, trace=-1) plotmo(fite, nresponse=2, trace=-1) } else { plotmo(fite, func=func1, caption=caption, nresponse=1) plotmo(fite, func=func2, nresponse=2) } plot(fite, caption=caption, nresponse=1) plot(fite, nresponse=2) } cat("\n") if(test.mars.to.earth) { cat("Testing mars.to.earth with a multiple response model\n") fitm <- mars(data.global[,c(-1,-2), drop=FALSE], data.global[,1:2], degree=degree, trace=(trace!=0), nk=nk) fitme <- mars.to.earth(fitm) printh(fitme) printh(summary(fitme)) if(plotit) { plotmo(fitm, func=func1, caption=caption, nresponse=1, clip=FALSE) plotmo(fitm, func=func2, nresponse=2, clip=FALSE) } # TODO following code causes error "nk" not found, looking in wrong environment? # cat("Expect warnings because of weights in the mars model\n") # fitm <- mars(data.global[,c(-1,-2), drop=FALSE], data.global[,1:2], # degree=degree, trace=(trace!=0), nk=nk, wp=c(1,2)) # fitme <- mars.to.earth(fitm) # printh(fitme) # printh(summary(fitme)) } fite } N <- 100 set.seed(1) x1 <- runif(N, -1, 1) x2 <- runif(N, -1, 1) x3 <- runif(N, -1, 1) x4 <- runif(N, -1, 1) x5 <- runif(N, -1, 1) func1 <- function(x) { sin(3 * x[,1]) + x[,2] } func7 <- function(x) # just one predictor { sin(5 * x[,1]) } x.global <- cbind( x1, x2) data.global <- cbind(func1(x.global), func7(x.global), x1, x2) colnames(data.global) = c("func1", "func7", "x1", "x2") # expect pmethod="ex" cannot be used with multiple response models expect.err(try(test.two.responses(itest, func1, func7, nk=51, degree=1, pmethod="ex")), "not allowed with multiple response models") # expect pmethod="seq" cannot be used with multiple response models expect.err(try(test.two.responses(itest, func1, func7, nk=51, degree=1, pmethod="seq")), "not allowed with multiple response models") itest <- itest+1; a <- test.two.responses(itest, func1, func7, nk=51, degree=1) printh(summary(a)) printh(summary(a, style="bf")) if (PLOT) { plotmo(a, nresponse=1, trace=-1) # test generation of caption based on response name plotmo(a, nresponse=2, trace=-1) plot(a, nresponse=1) plot(a, nresponse=2) } x.global <- cbind( x1, x2) data.global <- cbind(func1(x.global), func7(x.global), x1, x2) colnames(data.global) = c("func1", "a.very.long.in.fact.extremely.long.response.name", "x1.a.very.long.in.fact.extremely.long.predictor.name", "x2") itest <- itest+1; a <- test.two.responses(itest, func1, func7, nk=51, degree=3) printh(summary(a)) print(evimp(a)) print.default(evimp(a)) eqn56 <- function(x) # Friedman MARS paper equation 56 { 0.1 * exp(4*x[,1]) + 4 / (1 + exp(-20*(x[,2]-0.5))) + 3 * x[,3] + 2 * x[,4] + x[,5] } neg.eqn56 <- function(x) { -eqn56(x) } eqn56noise <- function(x) { set.seed(ncol(x)) eqn56(x) + rnorm(nrow(x),0,1) } neg.eqn56noise <- function(x) { -eqn56noise(x) } robot.arm <- function(x) # Friedman Fast MARS paper { l1 <- x[,1] l2 <- x[,2] theta1 <- x[,3] theta2 <- x[,4] phi <- x[,5] x1 <- l1 * cos(theta1) - l2 * cos(theta1 + theta2) * cos(phi) y <- l1 * sin(theta1) - l2 * sin(theta1 + theta2) * cos(phi) z <- l2 * sin(theta2) * sin(phi) sqrt(x1^2 + y^2 + z^2) } x.global <- cbind( x1, x2, x3, x4, x5) data.global <- cbind(eqn56=eqn56(x.global), neg.eqn56noise(x.global), x1, x2, x3, x4, x5) colnames(data.global) = c("", "neg.eqn56noise", "x1", "x2", "x3", "x4", "x5") itest <- itest+1; a <- test.two.responses(itest, eqn56, neg.eqn56noise, nk=51, degree=1) print(evimp(a)) print.default(evimp(a)) x.global <- cbind( x1, x2, x3, x4, x5) data.global <- cbind(eqn56=eqn56(x.global), neg.eqn56noise(x.global), x1, x2, x3, x4, x5) colnames(data.global) = NULL itest <- itest+1; a70 <- test.two.responses(itest, eqn56, neg.eqn56noise, nk=51, degree=2) printh(summary(a70)) printh(summary(a70, style="bf")) N1 <- 100 set.seed(1) x1. <- runif(N1, -1, 1) x2. <- runif(N1, -1, 1) x3. <- runif(N1, -1, 1) x4. <- runif(N1, -1, 1) x5. <- runif(N1, -1, 1) x.global <- cbind( (x1.+1)/2, (x2.+2)/2, pi*(x3.+1), pi*(x4.+1), pi*x5./2 ) data.global <- cbind(robot.arm(x.global), eqn56(x.global), (x1.+1)/2, (x2.+2)/2, pi*(x3.+1), pi*(x4.+1), pi*x5./2 ) colnames(x.global) <- c( "l1", "l2", "theta1", "theta2", "phi") colnames(data.global) <- c("arm", "eqn56", "l1", "l2", "theta1", "theta2", "phi") itest <- itest+1; test.two.responses(itest, robot.arm, eqn56, nk=51, degree=1) itest <- itest+1; test.two.responses(itest, robot.arm, eqn56, nk=51, degree=2, test.mars.to.earth=TRUE) itest <- itest+1; test.two.responses(itest, robot.arm, eqn56, nk=201, degree=1) itest <- itest+1; test.two.responses(itest, robot.arm, eqn56, nk=201, degree=2) itest <- itest+1; test.two.responses(itest, robot.arm, eqn56, nk=201, degree=10) attach(ozone1) x.global <- cbind( wind, humidity, temp, ibh, dpg, ibt, vis) data.global <- cbind(O3, doy, vh, wind, humidity, temp, ibh, dpg, ibt, vis) itest <- itest+1; test.two.responses(itest, "O3", "doy", nk=51, degree=2) detach(ozone1) cat("--- formula based multiple response -------------\n") a2 <- earth(cbind(O3,doy) ~ ., data=ozone1, degree=2) if (PLOT) { plotmo(a2, nresponse=1, trace=-1) # TODO1 delete plotmo(a2, nresponse=1, trace=-1) # test generation of caption based on response name plotmo(a2, nresponse=2, trace=-1) plot(a2, nresponse=1) # TODO delete plot(a2, nresponse=1) plot(a2, nresponse=2) } cat("--- test plot.earth.models with multiple responses ---\n") set.seed(1) a <- earth(O3 ~ ., data=ozone1, degree=2) a2 <- earth(cbind(O3,doy) ~ ., data=ozone1, degree=2) b2 <- earth(cbind(O3,doy) ~ ., data=ozone1, degree=1) if (PLOT) { plot.earth.models(list(a, a2), caption="plot.earth.models with multiple responses, list(a,a2)") plot.earth.models(list(a2, a), caption="plot.earth.models with multiple responses, list(a2,a)", col.rsq=c(2,3), col.npreds=c(2,3)) plot.earth.models(list(a2, b2), caption="plot.earth.models with multiple responses, list(a2,b2)", col.rsq=c(2,3), col.npreds=c(4,5), jitter=.01, legend.pos="topleft") } cat("--- subset --------------------------------------\n") set.seed(9) train.subset <- sample(1:nrow(ozone1), .8 * nrow(ozone1)) test.subset <- (1:nrow(ozone1))[-train.subset] # all the following models should be identical a <- earth(ozone1[,-1], ozone1[,1], subset=train.subset, nprune=7, degree=2) printh(a) if (PLOT) plotmo(a, caption="test subset: earth(ozone1[,-1], ozone1[,1], subset=train.subset)", trace=-1) a <- earth(ozone1[train.subset,-1], ozone1[train.subset,1], nprune=7, degree=2) printh(a) if (PLOT) plotmo(a, caption="test subset: earth(ozone1[train.subset,-1], ozone1[train.subset,1]", trace=-1) a <- earth(O3 ~ ., data=ozone1, subset=train.subset, nprune=7, degree=2) printh(a) if (PLOT) plotmo(a, caption="test subset: earth(O3 ~ ., data=ozone1, subset=train.subset", trace=-1) y <- ozone1[test.subset, 1] yhat <- predict(a, newdata = ozone1[test.subset, -1]) printh(1 - sum((y - yhat)^2)/sum((y - mean(y))^2)) # print RSquared cat("--- update -------------------------\n") a <- earth(O3 ~ ., data=ozone1, degree=2) printh(update(a, penalty = -1, ponly=TRUE)) printh(update(a, penalty = 10, ponly=TRUE)) a <- earth(O3 ~ ., data=ozone1, nk=31, pmethod="n", degree=2) a.none <- printh(update(a, nprune=10, pmethod="n")) printh(update(a.none, pmethod="b")) printh(update(a.none, nprune=4, pmethod="e")) a.updated <- update(a.none, nprune=10, pmethod="b") printh(a.updated) a.backwards <- update(a, nprune=10, pmethod="b") printh(a.backwards) printh(all.equal(a.updated$bx, a.backwards$bx)) a <- earth(O3 ~ ., data=ozone1, nk=31, nprune=10, pmethod="b", degree=2) printh(a) printh(all.equal(a$bx, a.backwards$bx)) cat("--- Auto.linpreds -----------------------------\n") set.seed(2017) x1 <- runif(10) x2 <- runif(10) y <- x1 + x2 data=data.frame(x1=x1, x2=x2, y=y) OLD.PAR <- par(no.readonly=TRUE) par(mfrow = c(6, 4), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) expect.err(try(earth(y~., data=data, Auto.linpr=99)), "Auto.linpreds=99 but it should be FALSE, TRUE, 0, or 1") a <- earth(y~., data=data, trace=2) # default Auto.linpreds=TRUE print(summary(a, style="pmax")) plotmo(a, extend=.3, ylim=c(.2, 1.7), do.par=FALSE, pt.col=2, jitter=0, main=c("default Auto.linpreds=T", "")) empty.plot() empty.plot() a1 <- earth(y~., data=data, trace=2, Auto.linpreds=FALSE) print(summary(a1, style="pmax")) plotmo(a1, extend=.3, ylim=c(.2, 1.7), do.par=FALSE, pt.col=2, jitter=0, main=c("Auto.linpreds=F", "")) empty.plot() empty.plot() stopifnot(isTRUE(all.equal(predict(a), predict(a1)))) a2 <- earth(y~., data=data, trace=2, linpreds=TRUE, Auto.linpreds=FALSE) print(summary(a2, style="pmax")) plotmo(a2, extend=.3, ylim=c(.2, 1.7), do.par=FALSE, pt.col=2, jitter=0, main=c("linpreds=T, Auto.linpreds=F", "")) empty.plot() empty.plot() stopifnot(isTRUE(all.equal(predict(a), predict(a2)))) a3 <- earth(y~., data=data, linpreds="x1", Auto.linpreds=FALSE) print(summary(a3, style="pmax")) plotmo(a3, extend=.3, ylim=c(.2, 1.7), do.par=FALSE, pt.col=2, jitter=0, main=c("linpreds=x1, Auto.linpreds=F", "")) empty.plot() empty.plot() stopifnot(isTRUE(all.equal(predict(a), predict(a3)))) a4 <- earth(y~., data=data, linpreds="x2", Auto.linpreds=FALSE) print(summary(a4, style="pmax")) plotmo(a4, extend=.3, ylim=c(.2, 1.7), do.par=FALSE, pt.col=2, jitter=0, main=c("linpreds=x2, Auto.linpreds=F", "")) empty.plot() empty.plot() stopifnot(isTRUE(all.equal(predict(a), predict(a4)))) # x,y interface a5 <- earth(data[,1:2], data[,3], Auto.linpreds=FALSE) print(summary(a5, style="pmax")) plotmo(a5, extend=.3, ylim=c(.2, 1.7), do.par=FALSE, pt.col=2, jitter=0, main=c("x,y interface", "")) empty.plot() empty.plot() stopifnot(isTRUE(all.equal(as.vector(predict(a1)), as.vector(predict(a5))))) par(OLD.PAR) # more complicated example (with Auto.linpreds=TRUE, vh enters linearly in a degree2 term) data(ozone1) oz <- ozone1[1:50,] mod.none1 <- earth(O3~., data=oz, degree=2, nk=15, pmethod="none") # default Auto.linpreds=TRUE print(summary(mod.none1)) mod.none2 <- earth(O3~., data=oz, degree=2, nk=15, pmethod="none", Auto.linpreds=FALSE) print(summary(mod.none2)) stopifnot(all.equal(predict(mod.none1), predict(mod.none2))) # example figure in inst/doc OLD.PAR <- par(no.readonly=TRUE) par(mfrow=c(2,2), mar=c(4, 3.2, 3, 3), mgp=c(1.6, 0.6, 0), par(cex = 0.7)) set.seed(2017) offset <- 98 data.autolin <- data.frame(x=offset+(1:10), y=offset+(1:10)) autolinFALSE <- earth(y~x, data=data.autolin, Auto.linpreds=FALSE) print(summary(autolinFALSE, style="max")) set.seed(2017) # for same jitter on this and previous graph plotmo(autolinFALSE, extend=.3, do.par=FALSE, pt.col="red", lwd=2, main="Auto.linpreds = FALSE", xaxt="n", yaxt="n", jitter=1, cex.main=1, xlim=offset+c(-2,13), ylim=offset+c(-3,13)) legend(x="topleft", legend=c("data", "earth model"), lty=c(0, 1), lwd=c(0, 2), pch=c(20, NA), col=c("red", 1)) text(x=offset+3.8, y=offset-1.2, cex=.9, "The knot happens to be at the") text(x=offset+4, y=offset-2.4, cex=.9, "minimum value of the predictor") autolinTRUE <- earth(y~x, data=data.autolin) # default Auto.linpreds=TRUE print(summary(autolinTRUE, style="max")) set.seed(2017) # for same jitter on this and next graph plotmo(autolinTRUE, extend=.3, do.par=FALSE, pt.col="red", lwd=2, main="Auto.linpreds = TRUE (default)", xaxt="n", yaxt="n", jitter=1, cex.main=1, xlim=offset+c(-2,13), ylim=offset+c(-3,13)) legend(x="topleft", legend=c("data", "earth model"), lty=c(0, 1), lwd=c(0, 2), pch=c(20, NA), col=c("red", 1)) text(x=offset+4, y=offset-2.4, cex=.9, "Same data as previous graph") stopifnot(isTRUE(all.equal(predict(autolinTRUE), predict(autolinFALSE)))) par(OLD.PAR) # test Auto.linpreds with data sent in by a user ndata <- matrix(data=c( -0.0781, -0.6109, -0.216, -1.5172, 0.8184, -1.1242, -0.0781, -0.5885, -0.216, -1.3501, 0.8184, -0.8703, -0.0781, -0.5885, -0.216, -1.3501, 0.8184, -0.9549, -0.0781, -0.5885, -0.216, -1.3501, 1.4136, -0.8703, -2.5759, -0.5885, 1.1665, -1.3501, 2.0089, -0.9549, -2.5759, -0.5885, 1.1665, -1.3501, 2.0089, -0.8703, -0.0781, -0.4937, -0.216, -0.9949, -0.372, -1.0396, -0.0781, -0.4463, -0.216, -0.8278, -0.372, -0.447, -0.0781, -0.4463, -0.216, -0.8278, -0.372, -0.701, -0.0781, -0.4463, -0.216, -0.8278, -0.372, -0.6163, -0.0781, -0.4463, -0.216, -0.8278, 0.8184, -0.447, -0.0781, -0.4463, -0.216, -0.8278, 0.8184, -0.6163, -0.0781, -0.4463, 1.1665, -0.8278, 0.8184, -0.447, -0.0781, -0.4379, 1.1665, 0.2585, -0.372, -0.1085, -0.0781, -0.2147, 1.1665, 0.0496, -0.372, -0.1085, -0.0781, -0.2147, -0.216, 0.2585, -0.372, -0.0238, -0.0781, -0.1589, -0.216, 0.2585, -0.372, -0.1931, -0.0781, -0.1589, -0.216, 0.2585, -0.372, -0.1085, -0.0781, -0.1589, 1.1665, 0.2585, -0.372, -0.1931, -0.0781, -0.1589, -0.216, 0.2585, 0.8184, -0.1085, -0.0781, -0.1589, -0.216, 0.2585, 0.8184, 0.0608, -0.0781, -0.1589, -0.216, 1.0942, 0.8184, -0.0238, -0.0781, 0.0643, 1.1665, 1.0942, -0.372, 0.2301, -0.0781, 0.0643, -0.216, 1.0942, -1.5624, 0.3148, -0.0781, 0.0643, -0.216, 1.0942, -0.9672, 0.1455, -0.0781, 0.0643, 1.1665, 1.4284, 0.2232, 0.4841, -0.0781, 0.1563, -0.216, 1.0942, -0.372, 0.5687, 2.4197, 0.3432, -0.216, 1.0942, -1.5624, 1.0766, -0.0781, 0.3432, -0.216, 1.0942, -1.5624, 1.1613, -0.0781, 0.3432, 1.1665, 1.0942, 0.2232, 0.738, 2.4197, 2.7145, -2.9811, 1.0942, -1.5624, 2.5156, 2.4197, 4.3884, -2.9811, 1.0942, -1.5624, 3.5314), ncol=6) colnames(ndata) <- c("x1", "x2", "x3", "x4", "x5", "y") ndata <- as.data.frame(ndata) cat("Auto.linpreds=TRUE pmethod=\"none\":\n") auto.linpreds.true.pmethod.none <- earth(y~., data=ndata, degree=2, nk=21, trace=2, pmethod="none") print(summary(auto.linpreds.true.pmethod.none, decomp="none")) cat("\nAuto.linpreds=FALSE pmethod=\"none\":\n") auto.linpreds.false.pmethod.none <- earth(y~., data=ndata, degree=2, nk=21, trace=2, Auto.linpreds=FALSE, pmethod="none") print(summary(auto.linpreds.false.pmethod.none, decomp="none")) stopifnot(isTRUE(all.equal(predict(auto.linpreds.true.pmethod.none), predict(auto.linpreds.false.pmethod.none)))) cat("\nAuto.linpreds=TRUE:\n") auto.linpreds.true <- earth(y~., data=ndata, degree=2, nk=21, trace=2) print(summary(auto.linpreds.true, decomp="none")) cat("\nAuto.linpreds=FALSE:\n") auto.linpreds.false <- earth(y~., data=ndata, degree=2, nk=21, trace=2, Auto.linpreds=FALSE) print(summary(auto.linpreds.false, decomp="none")) # following fails because of different pruning because of different term count # stopifnot(isTRUE(all.equal(predict(auto.linpreds.true), predict(auto.linpreds.false)))) cat("--- Force.xtx.prune -----------------------------\n") expect.err(try(earth(Volume ~ ., data = trees, Force.xtx.prune=TRUE, pmethod="ex")), "not allowed with") # pmethod="ex" cannot be used with Force.xtx.prune m1 <- earth(Volume ~ ., data = trees) m2 <- earth(Volume ~ ., data = trees, Force.xtx.prune=TRUE) check.models.equal(m1, m2, "Force.xtx.prune test 1", check.subsets=FALSE, newdata=data.frame(Height=10, Girth=12)) m1 <- earth(O3 ~ wind+temp, data = ozone1, nk=51) m2 <- earth(O3 ~ wind+temp, data = ozone1, nk=51, Force.xtx.prune=TRUE) check.models.equal(m1, m2, "Force.xtx.prune test 2", check.subsets=FALSE, newdata=ozone1[5:7,]) # TODO The following exposes a bug in leaps(?). It is described in # check.one.term.per.step in the earth R code. The test is commented out # because this bug causes a discrepancy with Force.xtx.prune (although # usually the bug does not cause any problems). # # m1 <- earth(O3 ~ ., data = ozone1, nk=51, degree=2, trace=5) # m2 <- earth(O3 ~ ., data = ozone1, nk=51, degree=2, Force.xtx.prune=TRUE) # check.models.equal(m1, m2, "Force.xtx.prune test 3", check.subsets=FALSE) cat("--- extractAIC.earth ----------------------------\n") a <-earth(O3 ~ ., data=ozone1, degree=2) cat("Ignore 10 warnings: extractAIC.earth: using GCV instead of AIC\n") printh(drop1(a), expect.warning=TRUE) printh(drop1(a, warn=FALSE)) # repeat but with warnings suppressed cat("--- fda and mda with earth -----------------------------------\n") am <- fda(Species ~ ., data=iris, method=mars, degree=1, keepxy=TRUE) printh(am) a <- fda(Species ~ ., data=iris, method=earth, degree=1, keepxy=TRUE) printh(a) printh(confusion(a)) if (PLOT) { par(mar=c(3, 3, 2, .5)) # small margins and text to pack figs in par(mgp=c(1.6, 0.6, 0)) # flatten axis elements par(oma=c(0,0,4,0)) # make space for caption layout(rbind(c(1,1,0,0), c(2,3,4,5), c(6,7,8,9)), heights=c(2,1,1)) plot(a) plotmo(a$fit, nresponse=1, ylim=c(-1.5,1.5), clip=FALSE, do.par=FALSE, trace=-1) plotmo(a$fit, nresponse=2, ylim=c(-1.5,1.5), clip=FALSE, do.par=FALSE, trace=-1) mtext("fda test", outer=TRUE, font=2, line=1.5, cex=1) } data(glass) set.seed(123) samp <- sample(c(1:214), size=100, replace=FALSE) glass.train <- glass[samp,] glass.test <- glass[-samp,] am <- mda(Type ~ ., data=glass.train, method=mars, keepxy=TRUE, degree=2) a <- mda(Type ~ ., data=glass.train, method=earth, keepxy=TRUE, degree=2, keep.fitted=TRUE) printh(am) printh(a) cat("mda with mars ", attr(confusion(am), "error"), "\n") cat("mda with earth ", attr(confusion(a), "error"), "\n") if (PLOT) { plot(a$fit, caption="mda on glass data", nresponse=1) plotmo(a$fit, nresponse=9, clip=FALSE, ylim=NA, caption="mda on glass data", trace=-1) } cat("\n---- update and keepxy, formula interface --------------------------\n") new.trees <- trees + c(1,2,3,4) new.trees <- new.trees[, -c(20:23)] a.formula <- earth(Volume ~ ., subset=rep(TRUE, nrow(trees)), data = trees) cat("\nupdate(a, trace=1)\n") a.formula.1update <- update(a.formula, trace=1) a.formula.1 <- earth(Volume ~ ., subset=rep(TRUE, nrow(trees)), data = trees) newdata.global <- trees[seq(from=nrow(trees), to=1, by=-5),] check.models.equal(a.formula.1update, a.formula.1, msg="a1update a1", newdata=newdata.global) cat("\nupdate(a.formula, data=new.trees, trace=1)\n") a.formula.2update <- update(a.formula, data=new.trees, trace=1) a.formula.2 <- earth(Volume ~ ., subset=rep(TRUE, nrow(trees)), data = new.trees) check.models.equal(a.formula.2update, a.formula.2, msg="a2update a2", newdata=newdata.global) cat("\nupdate(a.formula, wp=2, trace=1)\n") a.formula.3update <- update(a.formula, wp=2, trace=1) a.formula.3 <- earth(Volume ~ ., subset=rep(TRUE, nrow(trees)), data = trees, wp=2) check.models.equal(a.formula.3update, a.formula.3, msg="a3update a3", newdata=newdata.global) cat("\nupdate(a.formula, subset=subset.new, trace=1)\n") subset.new <- rep(TRUE, nrow(trees)) subset.new[1:4] = FALSE a.formula.4update <- update(a.formula, subset=subset.new, trace=1) a.formula.4 <- earth(Volume ~ ., data = trees, subset=subset.new) check.models.equal(a.formula.4update, a.formula.4, msg="a4update a4", newdata=newdata.global) # now use keepxy=TRUE a.formula <- earth(Volume ~ ., wp=1, data = trees, keepxy=TRUE) cat("\nupdate(a.formula, trace=1)\n") a.formula.5update <- update(a.formula, trace=1) a.formula.5 <- earth(Volume ~ ., wp=1, data = trees, keepxy=TRUE) check.models.equal(a.formula.5update, a.formula.5, msg="a5update a5", newdata=newdata.global) cat("\nupdate(a.formula, data=new.trees, trace=1)\n") a.formula.6update <- update(a.formula, data=new.trees, trace=1) a.formula.6 <- earth(Volume ~ ., wp=1, data = new.trees, keepxy=TRUE) check.models.equal(a.formula.6update, a.formula.6, msg="a6update a6", newdata=newdata.global) cat("\nupdate(a.formula, wp=2, trace=1)\n") a.formula.7update <- update(a.formula, wp=2, trace=1) a.formula.7 <- earth(Volume ~ ., wp=2, data = trees, keepxy=TRUE) check.models.equal(a.formula.7update, a.formula.7, msg="a7update a7", newdata=newdata.global) cat("\n----- update and keepxy, matrix interface--------------------------\n") Volume <- trees$Volume x <- cbind(trees$Height, trees$Volume) colnames(x) <- c("Height", "Volume") new.x <- cbind(new.trees$Height, new.trees$Volume) colnames(new.x) <- c("Height", "Volume") a <- earth(x, Volume, subset=rep(TRUE, nrow(trees))) cat("\nupdate(a, trace=1)\n") a1update <- update(a, trace=1) a1 <- earth(x, Volume, subset=rep(TRUE, nrow(trees))) check.models.equal(a1update, a1, msg="a1update a1", newdata=newdata.global) cat("\nupdate(a, x=new.x, trace=1)\n") a2update <- update(a, x=new.x, trace=1) a2 <- earth(new.x, Volume, subset=rep(TRUE, nrow(trees))) check.models.equal(a2update, a2, msg="a2update a2", newdata=newdata.global) cat("\nupdate(a, wp=2, trace=0)\n") a3update <- update(a, wp=2, trace=0) a3 <- earth(x, Volume, subset=rep(TRUE, nrow(trees)), wp=2) check.models.equal(a3update, a3, msg="a3update a3", newdata=newdata.global) cat("\nupdate(a, subset=subset.new, trace=4)\n") subset.new <- rep(TRUE, nrow(trees)) subset.new[1:4] = FALSE a4update <- update(a, subset=subset.new, trace=4) a4 <- earth(x, Volume, subset=subset.new) check.models.equal(a4update, a4, msg="a4update a4", newdata=newdata.global) # now use keepxy=TRUE a <- earth(x, Volume, wp=1, keepxy=TRUE) cat("\nupdate(a, trace=4)\n") a5update <- update(a, trace=4) a5 <- earth(x, Volume, wp=1, keepxy=TRUE) check.models.equal(a5update, a5, msg="a5update a5", newdata=newdata.global) cat("\nupdate(a, x=new.x, trace=4)\n") a6update <- update(a, x=new.x, trace=4) a6 <- earth(new.x, Volume, wp=1, keepxy=TRUE) check.models.equal(a6update, a6, msg="a6update a6", newdata=newdata.global) cat("\nupdate(a, wp=2)\n") a7update <- update(a, wp=2) a7 <- earth(x, Volume, wp=2, keepxy=TRUE) check.models.equal(a7update, a7, msg="a7update a7", newdata=newdata.global) cat("--- beta cache -------------------------\n") a1 <- earth(O3 ~ ., data = ozone1, degree = 3) a2 <- earth(O3 ~ ., data = ozone1, degree = 3, Use.beta.cache=FALSE) a1$call <- NULL a2$call <- NULL stopifnot(identical(a1, a2)) cat("--- test \"call\" printing in earth.default and summary.earth ---\n") # we want to make sure that long x or y aren't printed but short ones are x = c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0) y = c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0) a <- earth(x = x, y=y, trace=5) a.longx <- earth(x = c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0), y=y, trace=4) a.longy <- earth(x = x, y = c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0), trace=4) a.longxy <- earth(x = c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0), y = c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, 0,1,2,3,4,5,6,7,8,9,0), trace=4) printh(summary(a)) printh(summary(a.longx)) printh(summary(a.longy)) printh(summary(a.longxy)) printh(summary(a.longxy, style="bf")) cat("--- factors with x,y interface -------------------------\n") # this also tests for integer variables in the input matrix data(etitanic) attach(etitanic) a1 <- earth(pclass, sex, degree=2, trace=2) # x=unordered y=unordered printh(summary(a1)) printh(summary(a1, style="bf")) if (PLOT) plot(a1) a2 <- earth(sex, pclass, degree=2, trace=2) # x=unordered y=unordered printh(summary(a2)) if (PLOT) plot(a2, nresponse=1) a3 <- earth(pclass, age, degree=2, trace=2) # x=unordered y=numeric printh(summary(a3)) if (PLOT) plot(a3, nresponse=1) a4 <- earth(age, pclass, degree=2, trace=2) # x=numeric y=unordered printh(summary(a4)) if (PLOT) plot(a4, nresponse=1) a5 <- earth(etitanic[,c(2:4)], pclass, degree=2, trace=2) # x=mixed y=unordered printh(summary(a5)) if (PLOT) plot(a5, nresponse=1) a6 <- earth(etitanic[,c(1,3,4,5,6)], survived, degree=2, trace=2) # x=mixed y=unordered printh(summary(a6)) if (PLOT) plot(a6) a7 <- earth(etitanic[,c(2,3,5,6)], etitanic[,c(1,4)], degree=2, trace=2) # x=mixed y=mixed printh(summary(a7)) if (PLOT) plot(a7, nresponse=1) cat("--- factors with formula interface -------------------------\n") # these correspond to the models above (except a7 which is a multiple response model) a1f <- earth(sex ~ pclass, degree=2, trace=2) # x=unordered y=unordered printh(summary(a1f)) printh(summary(a1f, style="bf")) if (PLOT) plot(a1f) a2f <- earth(pclass ~ sex, degree=2, trace=2) # x=unordered y=unordered printh(summary(a2f)) if (PLOT) plot(a2f, nresponse=1) a3f <- earth(age ~ pclass, degree=2, trace=2) # x=unordered y=numeric printh(summary(a3f)) if (PLOT) plot(a3f) a4f <- earth(pclass ~ age, degree=2, trace=2) # x=numeric y=unordered printh(summary(a4f)) if (PLOT) plot(a4f, nresponse=1) a5f <- earth(pclass ~ survived + sex + age, data=etitanic, degree=2, trace=2) # x=mixed y=unordered printh(summary(a5f)) if (PLOT) plot(a5f, nresponse=1) a6f <- earth(survived ~ ., data=etitanic, degree=2, trace=2) # x=mixed y=unordered printh(summary(a6f)) if (PLOT) plot(a6f) detach(etitanic) # basic test with ordered factors ff <- factor(substring("statistics", 1:10, 1:10), levels=letters, ordered=TRUE) ff <- c(ff, ff, ff) vowels = (ff == 1 | ff == 9) * 3 printh(head(ff)) printh(head(vowels)) a8 <- earth(ff, vowels, degree=1, trace=2) # x=ordered y=numeric printh(summary(a8)) if (PLOT) plot(a8, nresponse=1) plotmo(a8, caption="a8", pt.col=3) a9 <- earth(vowels, ff, degree=1, trace=2) # x=numeric y=ordered if (PLOT) plot(a9, nresponse=1) printh(summary(a9)) cat("--- wp argument---------------------------------\n") set.seed(79) NWP <- 100 x1 <- runif(NWP) x2 <- runif(NWP) y1 <- (x1 > .5) + .3 * runif(1) y2 <- sin(3 * x2) + .3 * runif(1) myw <- 10 m <- mars(cbind(x1,x2), cbind(y1, y2)) me1 <- mars.to.earth(m) printh(me1) e1 <- earth(cbind(x1,x2), cbind(y1, y2)) printh(e1) e2 <- earth(cbind(x1,x2), cbind(y1, y2), wp=c(1,1)) printh(e2) e1$call <- NULL e2$call <- NULL e1$wp <- NULL e2$wp <- NULL stopifnot(identical(e1, e2)) e3 <- earth(cbind(x1,x2), cbind(y1, y2), wp=c(.001,1)) printh(e3) wp <- c(1, 2) e3 <- earth(cbind(x1,x2), cbind(y1, y2), wp=wp) printh(e3) m3 <- mars(cbind(x1,x2), cbind(y1, y2), wp=wp) cat("response weights: wp", wp, "earth gcv", e3$gcv, "mars gcv", m3$gcv, "mars gcv*length(wp)", m3$gcv * length(wp), "\n") e4 <- earth(cbind(O3, O3) ~ ., data=ozone1, wp=c(1, .01)) printh(e4) # both sub models should be the same printh(summary(e4)) # wp with formula interface e5 <- earth(cbind(O3, wind) ~ ., data=ozone1, wp=c(1, 1)) printh(e5) printh(summary(e5)) e5 <- earth(cbind(O3, wind) ~ ., data=ozone1, wp=c(.3, 1)) printh(e5) printh(summary(e5)) # wp with factors e6 <- earth(pclass ~ ., data=etitanic, degree=2, wp=c(.001,.001,1)) printh(e6) printh(summary(e6)) e7 <- earth(pclass ~ ., data=etitanic, degree=2, wp=c(1,.001,.001)) printh(e7) printh(summary(e7)) if (PLOT) plot(e7, pt.col=as.numeric(etitanic$pclass)+1, nresponse=1) cat("--- earth.regress ---------------------------------\n") msg = "earth.regress with trees data, single response, no weights" cat("Test:", msg, "\n") data(trees) y <- trees$Volume x <- cbind(trees$Girth, trees$Height) colnames(x) <- c("girth", "height") a.lm <- lm(y ~ x) a.lm.rss <- sum((a.lm$fitted.values - y)^2) if (is.null(dim(a.lm$coefficients))) dim(a.lm$coefficients) <- c(length(a.lm$coefficients), 1) a <- earth:::earth.regress(x, y) rownames(a.lm$coefficients) <- rownames(a$coefficients) check.almost.equal(a.lm$coefficients, a$coefficients, msg=paste("coefficients [", msg, "]", sep="")) check.almost.equal(a.lm.rss, a$rss, msg=paste("rss [", msg, "]")) check.almost.equal(a.lm$residuals, a$residuals, msg=paste("residuals [", msg, "]")) msg = "earth.regress with ozone1 data, multiple responses, no weights" cat("Test:", msg, "\n") data(ozone1) y <- cbind(ozone1$O3, ozone1$O3 ^ 2) colnames(y) <- c("O3", "O32") x <- cbind(ozone1$wind, ozone1$humidity, ozone1$temp) colnames(x) <- c("wind", "humidity", "temp") a.lm <- lm(y ~ x) a.lm.rss <- sum((a.lm$fitted.values - y)^2) a <- earth:::earth.regress(x, y) rownames(a.lm$coefficients) <- rownames(a$coefficients) check.almost.equal(a.lm$coefficients, a$coefficients, msg=paste("coefficients [", msg, "]")) check.almost.equal(a.lm.rss, a$rss, msg=paste("rss [", msg, "]", sep="")) check.almost.equal(a.lm$residuals, a$residuals, msg=paste("residuals [", msg, "]", sep="")) # msg = "earth.regress with ozone1 data, multiple responses with case weights" # cat("Test:", msg, "\n") # # # options(digits=10) # weights. <- rep(.5, nrow(x)) # weights.[1] <- 1 # weights.[2] <- 2 # weights.[3] <- 3 # weights.[4] <- 4 # weights.[5] <- 5 # a.lm <- lm(y ~ x, weights=weights.) # # a.lm.rss <- sum((a.lm$fitted.values - y)^2) # line below is equivalent # a.lm.rss <- sum(a.lm$residuals^2) # a <- earth:::earth.regress(x, y, weights=weights.) # rownames(a.lm$coefficients) <- rownames(a$coefficients) # check.almost.equal(a.lm$coefficients, a$coefficients, msg=paste("coefficients [", msg, "]", sep="")) # check.almost.equal(a.lm.rss, a$rss, msg=paste("rss [", msg, "]", sep="")) # check.almost.equal(a.lm$residuals, a$residuals, msg=paste("residuals [", msg, "]", sep="")) # msg = "earth.regress case weights with zero weights 1" # cat("Test:", msg, "\n") # # weights. <- rep(1, nrow(x)) # weights.[2] <- 0 # weights.[4] <- 0 # a.lm <- lm(y ~ x, weights=weights.) # # a.lm.rss <- sum((a.lm$fitted.values - y)^2) # line below is equivalent # a.lm.rss <- sum(a.lm$residuals^2) # a <- earth:::earth.regress(x, y, weights=weights.) # rownames(a.lm$coefficients) <- rownames(a$coefficients) # # options(digits=10) # check.almost.equal(a.lm$coefficients, a$coefficients, msg=paste("coefficients [", msg, "]", sep="")) # check.almost.equal(a.lm.rss, a$rss, msg=paste("rss [", msg, "]", sep="")) # check.almost.equal(a.lm$residuals, a$residuals, max=1e-6, msg=paste("residuals [", msg, "]", sep="")) # # msg = "earth.regress case weights with zero weights 2" # cat("Test:", msg, "\n") # weights. <- rep(1, nrow(x)) # weights.[5] <- 0 # weights.[6] <- 0 # weights.[7] <- 0 # weights.[21] <- 0 # weights.[22] <- 0 # weights.[23] <- 0 # weights.[24] <- 0 # weights.[25] <- 0 # weights.[26] <- 0 # weights.[27] <- 0 # a.lm <- lm(y ~ x, weights=weights.) # # a.lm.rss <- sum((a.lm$fitted.values - y)^2) # line below is equivalent # a.lm.rss <- sum(a.lm$residuals^2) # a <- earth:::earth.regress(x, y, weights=weights.) # rownames(a.lm$coefficients) <- rownames(a$coefficients) # check.almost.equal(a.lm$coefficients, a$coefficients, msg=paste("coefficients [", msg, "]", sep="")) # check.almost.equal(a.lm.rss, a$rss, msg=paste("rss [", msg, "]", sep="")) # check.almost.equal(a.lm$residuals, a$residuals, max=1e-6, msg=paste("residuals [", msg, "]", sep="")) # # msg = "earth.regress case weights with zero weights and missing columns 1" # cat("Test:", msg, "\n") # x <- cbind(ozone1$wind, ozone1$humidity, ozone1$temp, ozone1$wind^2, ozone1$humidity^2, ozone1$temp^2) # weights. <- rep(1, nrow(x)) # weights.[5] <- 0 # weights.[6] <- 0 # weights.[7] <- 0 # weights.[21] <- 0 # weights.[22] <- 0 # weights.[23] <- 0 # weights.[24] <- 0 # weights.[25] <- 0 # weights.[26] <- 0 # weights.[27] <- 0 # colnames(x) <- c("wind", "humidity", "temp", "wind2", "humidity2", "temp2") # used.cols = as.logical(c(1,0,1,0,1,1)) # x.missing <- x[,used.cols] # a.lm <- lm(y ~ x.missing, weights=weights.) # a.lm.rss <- sum((a.lm$fitted.values - y)^2) # line below is equivalent # a.lm.rss <- sum(a.lm$residuals^2) # a <- earth:::earth.regress(x, y, weights=weights., used.cols=used.cols) # rownames(a.lm$coefficients) <- rownames(a$coefficients) # check.almost.equal(a.lm$coefficients, a$coefficients, msg=paste("coefficients [", msg, "]", sep="")) # check.almost.equal(a.lm.rss, a$rss, msg=paste("rss [", msg, "]", sep="")) # check.almost.equal(a.lm$residuals, a$residuals, max=1e-6, msg=paste("residuals [", msg, "]", sep="")) # # msg = "earth.regress case weights with zero weights and missing columns 2" # cat("Test:", msg, "\n") # x <- cbind(ozone1$wind, ozone1$humidity, ozone1$temp, ozone1$wind^2, ozone1$humidity^2, ozone1$temp^2) # weights. <- rep(1, nrow(x)) # weights.[5] <- .1 # weights.[6] <- .2 # weights.[7] <- 1.9 # weights.[21] <- .59 # colnames(x) <- c("wind", "humidity", "temp", "wind2", "humidity2", "temp2") # used.cols = as.logical(c(0,1,0,0,1,0)) # x.missing <- x[,used.cols] # a.lm <- lm(y ~ x.missing, weights=weights.) # a.lm.rss <- sum((a.lm$fitted.values - y)^2) # line below is equivalent # a.lm.rss <- sum(a.lm$residuals^2) # a <- earth:::earth.regress(x, y, weights=weights., used.cols=used.cols) # rownames(a.lm$coefficients) <- rownames(a$coefficients) # check.almost.equal(a.lm$coefficients, a$coefficients, msg=paste("coefficients [", msg, "]", sep="")) # check.almost.equal(a.lm.rss, a$rss, msg=paste("rss [", msg, "]", sep="")) # check.almost.equal(a.lm$residuals, a$residuals, max=1e-6, msg=paste("residuals [", msg, "]", sep="")) cat("---standard method functions ------------------------\n") short.etitanic <- etitanic[seq(from=1, to=1000, by=20),] a1 <- earth(pclass ~ ., data=short.etitanic, glm=list(family=binomial), trace=0) printh(variable.names(a1)) printh(case.names(a1)) printh(case.names(a1, use.names=FALSE)) named.short.etitanic <- short.etitanic rownames(named.short.etitanic) <- paste("xx", 1:nrow(named.short.etitanic)) a2 <- earth(pclass ~ ., data=named.short.etitanic, glm=list(family=binomial), trace=0) printh(variable.names(a2)) printh(case.names(a2)) printh(case.names(a2, use.names=FALSE)) printh(deviance(a1), expect.warning=TRUE) printh(deviance(a1, warn=FALSE)) printh(effects(a1), expect.warning=TRUE) printh(effects(a1, warn=FALSE)) printh(family(a1)) printh(anova(a1), expect.warning=TRUE) printh(anova(a1, warn=FALSE)) printh(family(a1)) # TODO removed because causes different results on different machines # cat("--- thresh=0 -----------------------------------------\n") # # a.no.thresh <- earth(O3 ~ ., data = ozone1, thresh=0, nk=1000, degree=2, trace=4) # printh(a.no.thresh) # printh(summary(a.no.thresh)) # plotmo(a.no.thresh, degree1=1, degree2=c(4,9,16), clip=0, , caption="test with thresh=0", trace=-1) # test the way plotmo gets the data with earth with a formula interface # use strange data name se to make sure eval gets correct environment (don't pick up se in plotmo) se <- ozone1 a <- earth(O3 ~ ., data=se, degree=2, keepxy=0) printh(summary(a)) plotmo(a, trace=2, caption="getdata earth test1") a <- earth(O3 ~ ., data=se, degree=2, keepxy=1) printh(summary(a)) plotmo(a, trace=1, caption="getdata earth test2") a <- earth(O3 ~ ., data=se, degree=2, keepxy=1) se <- NULL printh(summary(a)) plotmo(a, trace=2, caption="getdata earth test3") se <- ozone1 a <- earth(O3 ~ ., data=se, degree=2, keepxy=0) se <- NULL printh(summary(a)) expect.err(try(plotmo(a, trace=0, caption="getdata earth test4")), "cannot get the original model predictors") # test the way plotmo gets the data with earth with the default interface se <- ozone1 a <- earth(se[,2:10], se[,1], degree=2, keepxy=0) printh(summary(a)) plotmo(a, trace=0, caption="getdata earth test5") a <- earth(se[,2:10], se[,1], degree=2, keepxy=1) printh(summary(a)) plotmo(a, trace=0, caption="getdata earth test6") a <- earth(se[,2:10], se[,1], degree=2, keepxy=1) se <- NULL printh(summary(a)) plotmo(a, trace=0, caption="getdata earth test7") se <- ozone1 a <- earth(se[,2:10], se[,1], degree=2, keepxy=0) se <- NULL expect.err(try(plotmo(a, trace=0, caption="getdata earth test8")), "cannot get the original model predictors") se <- ozone1 a <- earth(se[,2:10], se[,1], degree=2, keepxy=0) # TODO error message could be improved here se$vh <- NULL # vh is unused (but plotmo still needs it --- why?) expect.err(try(plotmo(a, trace=0, caption="getdata earth test9")), "cannot get the original model predictors") # plotmo.x.default cannot get the x matrix se <- ozone1 a <- earth(se[,2:10], se[,1], degree=2, keepxy=TRUE) se$vh <- NULL # vh is unused (but plotmo still needs it --- why?) printh(summary(a)) plotmo(a, trace=0, caption="getdata earth test9") # test the way plotmo gets the data with lm se <- ozone1 a <- lm(O3 ~ ., data=se) printh(summary(a)) plotmo(a, trace=0, caption="getdata lm test1") a <- lm(O3 ~ ., data=se, x=1) printh(summary(a)) plotmo(a, trace=0, caption="getdata lm test2") a <- lm(O3 ~ ., data=se, y=1) printh(summary(a)) plotmo(a, trace=0, caption="getdata lm test3") a <- lm(O3 ~ ., data=se, x=1, y=1) printh(summary(a)) plotmo(a, trace=0, caption="getdata lm test3") a <- lm(O3 ~ ., data=se, x=0, y=1, model=F) se <- 99 expect.err(try(plotmo(a, trace=0, caption="getdata lm test4")), "cannot get the original model predictors") se <- ozone1 a <- lm(O3 ~ ., data=se, x=1, y=1) se <- 77 printh(summary(a)) plotmo(a, trace=0, caption="getdata lm test5") se <- ozone1 a <- lm(O3 ~ ., data=se, model=F) se$wind <- NULL expect.err(try(plotmo(a, trace=0, caption="getdata lm test6")), "cannot get the original model predictors") cat("test fixed.point warning in print.summary.earth\n") options(digits=3) et <- etitanic et$age <- 1000 * et$age a <- earth(survived~., data=et) print(summary(a)) print(summary(a, fixed.point=FALSE)) options(digits=7) # back to default cat("--- summary earth with new data ----------------------\n") a.trees <- earth(Volume~., data=trees) cat("summary(a.trees, newdata=trees)\n") print(summary(a.trees, newdata=trees)) cat("summary(a.trees, newdata=trees[1:5,])\n") a.trees.summary <- print(summary(a.trees, newdata=trees[1:5,])) a.xy.trees <- earth(trees[,1:2], trees[,3]) cat("summary(a.xy.trees, newdata=trees[1:5,])\n") a.xy.trees.summary <- print(summary(a.xy.trees, newdata=trees[1:5,])) stopifnot(a.xy.trees.summary$newrsq == a.trees.summary$newrsq) a.xy1.trees <- earth(trees[,1:2], trees$Volume) cat("summary(a.xy1.trees, newdata=trees[1:5,])\n") a.xy1.trees.summary <- print(summary(a.xy1.trees, newdata=trees[1:5,])) stopifnot(a.xy1.trees.summary$newrsq == a.trees.summary$newrsq) cat("--- ../../tests/test.earth.R -------------------------\n") options(options.old) source("../../tests/test.earth.R") cat("--- check that spurious warn gone: non-integer #successes in a binomial glm ---\n") library(segmented) # for down data data(down) fit.e <- earth(cases/births~age, data=down, weights=down$births, glm=list(family="binomial")) print(summary(fit.e)) # test nk=1, 2, and 3 cat("nk=1\n") par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) a.nk1 <- earth(Volume~., data=trees, nk=1) plot(a.nk1, which=1, main="nk=1") print(a.nk1) cat("nk=2\n") a.nk2 <- earth(Volume~., data=trees, nk=2) print(summary(a.nk2)) plot(a.nk2, which=1, main="nk=2") cat("nk=3\n") a.nk3 <- earth(Volume~., data=trees, nk=3) plot(a.nk3, which=1, main="nk=3") cat("\ntest model.matrix.earth\n") check.model.matrix <- function(msg, xnew, bx1, bx2) { cat("check.model.matrix", msg, ":\n") print(xnew) if(!identical(bx1, bx2)) { cat("\nnot identical\n") cat(deparse(substitute(bx1)), ":\n", sep="") print(bx1) cat(deparse(substitute(bx2)), ":\n", sep="") print(bx2) stop("check.model.matrix ", msg, " failed") } } data(trees) earth.trees.formula <- earth(Volume ~ ., data=trees, subset=1:20) bx <- model.matrix(earth.trees.formula) check.model.matrix("earth.trees.formula formula 1", NULL, bx, earth.trees.formula$bx) # nprune so only Girth is used, not Height earth.girth.formula <- earth(Volume ~ ., data=trees, nprune=3) # model.matrix where xnew is a data.frame xnew <- trees[,1:2] bx <- model.matrix(earth.girth.formula, xnew) lm.mod <- lm(trees$Volume ~ bx[,-1]) # -1 to drop intercept stopifnot(coef(earth.girth.formula) == coef(lm.mod)) colnames(xnew) <- NULL bx <- model.matrix(earth.girth.formula, xnew) lm.mod2 <- lm(trees$Volume ~ bx[,-1]) stopifnot(coef(earth.girth.formula) == coef(lm.mod2)) xnew <- data.frame(Girth=c(8.3, 8.6), Height=c(70, 65)) bx <- model.matrix(earth.girth.formula, xnew) check.model.matrix("earth.girth.formula formula 2", xnew, bx, earth.girth.formula$bx[1:2,]) # test what happens when variables are missing predict.girth.height <- predict(earth.girth.formula, xnew) predict.girth <- predict(earth.girth.formula, newdata=data.frame(Girth=c(8.3, 8.6))) stopifnot(all.equal(predict.girth.height, predict.girth)) predict.height <- predict(earth.girth.formula, newdata=data.frame(Height=c(70, 65))) stopifnot(all(is.na(predict.height))) xnew <- trees[1:2,] bx <- model.matrix(earth.girth.formula, xnew) check.model.matrix("earth.girth.formula formula 3", xnew, bx, earth.girth.formula$bx[1:2,]) xnew <- trees[1:2,1:2] # exclude Volume column colnames(xnew) <- NULL bx <- model.matrix(earth.girth.formula, xnew) check.model.matrix("earth.girth.formula formula 4", xnew, bx, earth.girth.formula$bx[1:2,]) xnew <- trees[1:2,3:1] # change order of columns bx <- model.matrix(earth.girth.formula, xnew) check.model.matrix("earth.girth.formula formula 5", xnew, bx, earth.girth.formula$bx[1:2,]) xnew <- trees[1:2,1,drop=FALSE] # include only Girth bx <- model.matrix(earth.girth.formula, xnew) check.model.matrix("earth.girth.formula formula 6", xnew, bx, earth.girth.formula$bx[1:2,]) xnew <- trees[1,2:1] bx <- model.matrix(earth.girth.formula, xnew) check.model.matrix("earth.girth.formula formula 7", xnew, bx, earth.girth.formula$bx[1,,drop=FALSE]) xnew <- trees[1,1:2] names(xnew) <- NULL bx <- model.matrix(earth.girth.formula, xnew) check.model.matrix("earth.girth.formula formula 8", xnew, bx, earth.girth.formula$bx[1,,drop=FALSE]) # model.matrix where xnew is a matrix (same as above code but with as.matrix) xnew <- as.matrix(trees[,1:2]) bx <- model.matrix(earth.girth.formula, xnew) lm.mod <- lm(trees$Volume ~ bx[,-1]) # -1 to drop intercept stopifnot(coef(earth.girth.formula) == coef(lm.mod)) colnames(xnew) <- NULL bx <- model.matrix(earth.girth.formula, xnew) lm.mod2 <- lm(trees$Volume ~ bx[,-1]) stopifnot(coef(earth.girth.formula) == coef(lm.mod2)) xnew <- as.matrix(data.frame(Girth=c(8.3, 8.6), Height=c(70, 65))) bx <- model.matrix(earth.girth.formula, xnew) check.model.matrix("earth.girth.formula formula 9", xnew, bx, earth.girth.formula$bx[1:2,]) xnew <- as.matrix(trees[1:2,]) bx <- model.matrix(earth.girth.formula, xnew) check.model.matrix("earth.girth.formula formula 10", xnew, bx, earth.girth.formula$bx[1:2,]) xnew <- as.matrix(trees[1:2,1:2]) # exclude Volume column colnames(xnew) <- NULL bx <- model.matrix(earth.girth.formula, xnew) check.model.matrix("earth.girth.formula formula 11", xnew, bx, earth.girth.formula$bx[1:2,]) xnew <- as.matrix(trees[1:2,3:1]) # change order of columns bx <- model.matrix(earth.girth.formula, xnew) check.model.matrix("earth.girth.formula formula 12", xnew, bx, earth.girth.formula$bx[1:2,]) xnew <- as.matrix(trees[1:2,1,drop=FALSE]) # include only Girth bx <- model.matrix(earth.girth.formula, xnew) check.model.matrix("earth.girth.formula formula 13", xnew, bx, earth.girth.formula$bx[1:2,]) xnew <- as.matrix(trees[1,2:1]) bx <- model.matrix(earth.girth.formula, xnew, trace=2) check.model.matrix("earth.girth.formula formula 14", xnew, bx, earth.girth.formula$bx[1,,drop=FALSE]) xnew <- as.matrix(trees[3,1:2]) names(xnew) <- NULL bx <- model.matrix(earth.girth.formula, xnew) check.model.matrix("earth.girth.formula formula 15", xnew, bx, earth.girth.formula$bx[3,,drop=FALSE]) #--- model.matrix with an x,y model data(trees) earth.trees.xy.subset <- earth(trees[,1:2], trees[,3], subset=1:20) bx <- model.matrix(earth.trees.xy.subset) check.model.matrix("earth.trees.xy.subset x,y 1", NULL, bx, earth.trees.xy.subset$bx) # nprune so only Girth is used, not Height earth.girth.xy <- earth(trees[,1:2], trees[,3], nprune=3) # model.matrix where xnew is a data.frame xnew <- trees[,1:2] bx <- model.matrix(earth.girth.xy, xnew) lm.mod <- lm(trees$Volume ~ bx[,-1]) # -1 to drop intercept stopifnot(coef(earth.girth.xy) == coef(lm.mod)) colnames(xnew) <- NULL bx <- model.matrix(earth.girth.xy, xnew) lm.mod2 <- lm(trees$Volume ~ bx[,-1]) stopifnot(coef(earth.girth.xy) == coef(lm.mod2)) xnew <- data.frame(Girth=c(8.3, 8.6), Height=c(70, 65)) bx <- model.matrix(earth.girth.xy, xnew) check.model.matrix("earth.girth.xy x,y 2", xnew, bx, earth.girth.xy$bx[1:2,]) # test what happens when variables are missing predict.girth.height <- predict(earth.girth.xy, xnew) predict.girth <- predict(earth.girth.xy, newdata=data.frame(Girth=c(8.3, 8.6))) stopifnot(all.equal(predict.girth.height, predict.girth)) predict.height <- predict(earth.girth.xy, newdata=data.frame(Height=c(70, 65))) stopifnot(all(is.na(predict.height))) xnew <- trees[1:2,] bx <- model.matrix(earth.girth.xy, xnew) check.model.matrix("earth.girth.xy x,y 3", xnew, bx, earth.girth.xy$bx[1:2,]) xnew <- trees[1:2,1:2] # exclude Volume column colnames(xnew) <- NULL bx <- model.matrix(earth.girth.xy, xnew) check.model.matrix("earth.girth.xy x,y 4", xnew, bx, earth.girth.xy$bx[1:2,]) # # TODO fails # xnew <- trees[1:2,3:1] # change order of columns # bx <- model.matrix(earth.girth.xy, xnew) # check.model.matrix("earth.girth.xy x,y 5", xnew, bx, earth.girth.xy$bx[1:2,]) xnew <- trees[1:2,1,drop=FALSE] # include only Girth bx <- model.matrix(earth.girth.xy, xnew) check.model.matrix("earth.girth.xy x,y 6", xnew, bx, earth.girth.xy$bx[1:2,]) xnew <- trees[1,2:1] bx <- model.matrix(earth.girth.xy, xnew) check.model.matrix("earth.girth.xy x,y 7", xnew, bx, earth.girth.xy$bx[1,,drop=FALSE]) xnew <- trees[1,1:2] names(xnew) <- NULL bx <- model.matrix(earth.girth.xy, xnew) check.model.matrix("earth.girth.xy x,y 8", xnew, bx, earth.girth.xy$bx[1,,drop=FALSE]) # model.matrix where xnew is a matrix (same as above code but with as.matrix) xnew <- as.matrix(trees[,1:2]) bx <- model.matrix(earth.girth.xy, xnew) lm.mod <- lm(trees$Volume ~ bx[,-1]) # -1 to drop intercept stopifnot(coef(earth.girth.xy) == coef(lm.mod)) colnames(xnew) <- NULL bx <- model.matrix(earth.girth.xy, xnew) lm.mod2 <- lm(trees$Volume ~ bx[,-1]) stopifnot(coef(earth.girth.xy) == coef(lm.mod2)) xnew <- as.matrix(data.frame(Girth=c(8.3, 8.6), Height=c(70, 65))) bx <- model.matrix(earth.girth.xy, xnew) check.model.matrix("earth.girth.xy x,y 9", xnew, bx, earth.girth.xy$bx[1:2,]) xnew <- as.matrix(trees[1:2,]) bx <- model.matrix(earth.girth.xy, xnew) check.model.matrix("earth.girth.xy x,y 10", xnew, bx, earth.girth.xy$bx[1:2,]) xnew <- as.matrix(trees[1:2,1:2]) # exclude Volume column colnames(xnew) <- NULL bx <- model.matrix(earth.girth.xy, xnew) check.model.matrix("earth.girth.xy x,y 11", xnew, bx, earth.girth.xy$bx[1:2,]) # # TODO fails # xnew <- as.matrix(trees[1:2,3:1]) # change order of columns # bx <- model.matrix(earth.girth.xy, xnew) # check.model.matrix("earth.girth.xy x,y 12", xnew, bx, earth.girth.xy$bx[1:2,]) xnew <- as.matrix(trees[1:2,1,drop=FALSE]) # include only Girth bx <- model.matrix(earth.girth.xy, xnew) check.model.matrix("earth.girth.xy x,y 13", xnew, bx, earth.girth.xy$bx[1:2,]) xnew <- as.matrix(trees[1,2:1]) bx <- model.matrix(earth.girth.xy, xnew, trace=2) check.model.matrix("earth.girth.xy x,y 14", xnew, bx, earth.girth.xy$bx[1,,drop=FALSE]) xnew <- as.matrix(trees[3,1:2]) names(xnew) <- NULL bx <- model.matrix(earth.girth.xy, xnew) check.model.matrix("earth.girth.xy x,y 15", xnew, bx, earth.girth.xy$bx[3,,drop=FALSE]) cat("--- compare backward, none, exhaustive, forward, seqrep ---------------------\n") data(ozone1) oz <- ozone1[1:50,] cat("--mod.none\n") mod.none <- earth(O3~., data=oz, degree=2, trace=4, pmethod="none") print(summary(mod.none)) cat("--mod.backward\n") mod.backward <- earth(O3~., data=oz, degree=2, trace=4, pmethod="backward") print(summary(mod.backward)) cat("--mod.forward\n") mod.forward <- earth(O3~., data=oz, degree=2, trace=4, pmethod="forward") print(summary(mod.forward)) cat("--mod.exhaustive\n") mod.exhaustive <- earth(O3~., data=oz, degree=2, trace=4, pmethod="exhaustive") print(summary(mod.exhaustive)) cat("--mod.seqrep\n") mod.seqrep <- earth(O3~., data=oz, degree=2, trace=4, pmethod="seqrep") print(summary(mod.seqrep)) tab <- data.frame(pmethod=c("none", "backward", "forward", "exhaustive", "seqrep"), grsq=c(mod.none$grsq, mod.backward$grsq, mod.forward$grsq, mod.exhaustive$grsq, mod.seqrep$grsq), nterms=c(length(mod.none$selected.terms), length(mod.backward$selected.terms), length(mod.forward$selected.terms), length(mod.exhaustive$selected.terms), length(mod.seqrep$selected.terms))) cat("\n") print(tab) # check fix for bug reported by Meleksen Akin (Feb 2019, fixed in earth 5.0.0) # to fix this I added xlevels to earth objects lm.Species <- lm(Sepal.Length~Species, data=iris) predict.lm <- predict(lm.Species, newdata=data.frame(Species="setosa")) # ok earth.Species <- earth(Sepal.Length~Species, data=iris) predict.earth <- predict(earth.Species, newdata=data.frame(Species="setosa")) # used to fail stopifnot(identical(as.vector(predict.lm), as.vector(predict.earth))) source("test.epilog.R") earth/inst/slowtests/test.offset.Rout.save0000644000176200001440000011232113451167442020464 0ustar liggesusers> # test.offset.R > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > > almost.equal <- function(x, y, max=1e-8) + { + stopifnot(max >= 0 && max <= .01) + length(x) == length(y) && max(abs(x - y)) < max + } > # check that earth model matches lm model in all essential details > check.earth.matches.lm <- function(earth, lm, newdata=data[c(3,1,9),], + check.coef.names=TRUE, + check.casenames=TRUE, + max=1e-8, + max.residuals=1e-8) + { + check.names <- function(earth.names, lm.names) + { + if(check.casenames && + # lm always adds rownames even if "1", "2", "3": this seems + # wasteful and not particulary helpful, so earth doesn't do + # this, hence the first !isTRUE(all.equal) below + !isTRUE(all.equal(lm.names, paste(1:length(lm.names)))) && + !isTRUE(all.equal(earth.names, lm.names))) { + print(earth.names) + print(lm.names) + stop(deparse(substitute(earth.names)), " != ", + deparse(substitute(lm.names))) + } + } + cat0("check ", deparse(substitute(earth)), " vs ", + deparse(substitute(lm)), "\n") + + # sort is needed because earth may reorder predictors based in importance + stopifnot(almost.equal(sort(coef(earth)), sort(coef(lm)), max=max)) + if(check.coef.names) + stopifnot(identical(sort(names(coef(earth))), sort(names(coef(lm))))) + + stopifnot(length(earth$coefficients) == length(lm$coefficients)) + stopifnot(almost.equal(sort(earth$coefficients), sort(lm$coefficients), max=max)) + + stopifnot(length(earth$residuals) == length(lm$residuals)) + stopifnot(almost.equal(earth$residuals, lm$residuals, max=max.residuals)) + + stopifnot(length(earth$fitted.values) == length(lm$fitted.values)) + stopifnot(almost.equal(earth$fitted.values, lm$fitted.values, max=max)) + + stopifnot(almost.equal(fitted(earth), fitted(lm), max=max)) + if(!is.null(names(fitted(earth))) && !is.null(names(fitted(lm)))) + check.names(names(fitted(earth)), names(fitted(lm))) + stopifnot(almost.equal(residuals(earth), residuals(lm), max=max.residuals)) + if(!is.null(names(residuals(earth))) && !is.null(names(residuals(lm)))) + check.names(names(residuals(earth)), names(residuals(lm))) + + predict.earth <- predict(earth) + predict.lm <- predict(lm) + stopifnot(almost.equal(predict.earth, predict.lm, max=max)) + if(!is.null(names(predict.earth)) && !is.null(names(predict.lm))) + check.names(names(predict.earth), names(predict.lm)) + + predict.earth <- predict(earth, newdata=newdata) + predict.lm <- predict(lm, newdata=newdata) + stopifnot(almost.equal(predict.earth, predict.lm, max=max)) + if(!is.null(names(predict.earth)) && !is.null(names(predict.lm))) + check.names(names(predict.earth), names(predict.lm)) + # we calculate earth rsq manually to match the rsq technique of lm + # this is necessary to get the same rsq when an offset is used + if(is.null(earth$offset)) { + earth.rsq <- earth$rsq + rss <- if (is.null(earth$weights)) + sum(earth$residuals^2) + else + sum(earth$weights * earth$residuals^2) + } else { + if (is.null(earth$weights)) { + mss <- sum((earth$fitted.values - mean(earth$fitted.values))^2) + rss <- sum(earth$residuals^2) + } else { + stopifnot(almost.equal(lm$weights, earth$weights, max=max)) + m <- sum(earth$weights * earth$fitted.values /sum(earth$weights)) + mss <- sum(earth$weights * (earth$fitted.values - m)^2) + rss <- sum(earth$weights * earth$residuals^2) + } + earth.rsq <- mss / (mss + rss) + } + stopifnot(almost.equal(earth.rsq, summary(lm)$r.squared, max=max)) + + # check internal consistency of earth model + stopifnot(earth$gcv == earth$gcv[1]) + stopifnot(almost.equal(earth$rsq.per.response[1], earth$rsq, max=1e-15)) + stopifnot(almost.equal(earth$grsq.per.response[1], earth$grsq, max=1e-15)) + if(is.null(earth$weights)) + stopifnot(almost.equal(earth$rss.per.response, earth$rss, max=1e-10)) + } > # check that earth-glm model matches glm model in all essential details > check.earth.matches.glm <- function(earth, glm, newdata=data[c(3,1,9),], + check.coef.names=TRUE, + check.casenames=FALSE, + max=1e-8, + max.residuals=1e-8) + { + check.names <- function(earth.names, glm.names) + { + if(check.casenames && + # glm always adds rownames even if "1", "2", "3": this seems + # wasteful and not particulary helpful, so earth doesn't do + # this, hence the first !isTRUE(all.equal) below + !isTRUE(all.equal(glm.names, paste(1:length(glm.names)))) && + !isTRUE(all.equal(earth.names, glm.names))) { + print(earth.names) + print(glm.names) + stop(deparse(substitute(earth.names)), " != ", + deparse(substitute(glm.names))) + } + } + cat0("check ", deparse(substitute(earth)), " vs ", + deparse(substitute(glm)), "\n") + + # sort is needed because earth may reorder predictors based in importance + earth.glm <- earth$glm.list[[1]] + stopifnot(!is.null(earth.glm)) + stopifnot(almost.equal(sort(coef(earth.glm)), sort(coef(glm)), max=max)) + if(check.coef.names) + stopifnot(identical(sort(names(coef(earth.glm))), sort(names(coef(glm))))) + + stopifnot(length(earth.glm$coefficients) == length(glm$coefficients)) + stopifnot(almost.equal(sort(earth.glm$coefficients), sort(glm$coefficients), max=max)) + + stopifnot(length(earth.glm$residuals) == length(glm$residuals)) + stopifnot(almost.equal(earth.glm$residuals, glm$residuals, max=max)) + + stopifnot(length(earth.glm$fitted.values) == length(glm$fitted.values)) + stopifnot(almost.equal(earth.glm$fitted.values, glm$fitted.values, max=max)) + + stopifnot(almost.equal(fitted(earth.glm), fitted(glm), max=max)) + if(!is.null(names(fitted(earth.glm))) && !is.null(names(fitted(glm)))) + check.names(names(fitted(earth.glm)), names(fitted(glm))) + + stopifnot(almost.equal(residuals(earth.glm), residuals(glm), max=max.residuals)) + if(!is.null(names(residuals(earth.glm))) && !is.null(names(residuals(glm)))) + check.names(names(residuals(earth.glm)), names(residuals(glm))) + + stopifnot(almost.equal(residuals(earth, type="response"), residuals(glm, type="response"), max=max.residuals)) + stopifnot(almost.equal(residuals(earth, type="glm.response"), residuals(glm, type="response"), max=max.residuals)) + stopifnot(almost.equal(residuals(earth, type="deviance"), residuals(glm, type="deviance"), max=max.residuals)) + stopifnot(almost.equal(residuals(earth, type="glm.pearson"), residuals(glm, type="pearson"), max=max.residuals)) + stopifnot(almost.equal(residuals(earth, type="glm.working"), residuals(glm, type="working"), max=max.residuals)) + # commented out because partial residuals don't match (because factors are expanded differently?) + # stopifnot(almost.equal(residuals(earth, type="glm.partial"), residuals(glm, type="partial"), max=max.residuals)) + + # predict without newdata + predict.glm <- predict(glm) + predict.earth <- predict(earth) + stopifnot(almost.equal(predict.earth, predict.glm, max=max)) + if(!is.null(names(predict.earth)) && !is.null(names(predict.glm))) + check.names(names(predict.earth), names(predict.glm)) + + # predict type=default + predict.glm <- predict(glm, newdata=newdata) + predict.earth <- predict(earth, newdata=newdata) + stopifnot(almost.equal(predict.earth, predict.glm, max=max)) + if(!is.null(names(predict.earth)) && !is.null(names(predict.glm))) + check.names(names(predict.earth), names(predict.glm)) + + # predict type="response" + predict.glm.response <- predict(glm, newdata=newdata, type="response") + predict.earth.response <- predict(earth, newdata=newdata, type="response") + if(!is.null(names(predict.earth)) && !is.null(names(predict.glm))) + check.names(names(predict.earth), names(predict.glm)) + stopifnot(almost.equal(predict.earth.response, predict.glm.response, max=max)) + if(!is.null(names(predict.earth.response)) && !is.null(names(predict.glm.response))) + check.names(names(predict.earth.response), names(predict.glm.response)) + + # predict type="link" + predict.earth.link <- predict(earth, newdata=newdata, type="link") + predict.glm.link <- predict(glm, newdata=newdata, type="link") + stopifnot(almost.equal(predict.earth.link, predict.glm.link, max=max)) + if(!is.null(names(predict.earth)) && !is.null(names(predict.lm))) + check.names(names(predict.earth), names(predict.glm)) + + # check internal consistency of earth model + stopifnot(earth$gcv == earth$gcv[1]) + stopifnot(almost.equal(earth$rsq.per.response[1], earth$rsq, max=1e-15)) + stopifnot(almost.equal(earth$grsq.per.response[1], earth$grsq, max=1e-15)) + if(is.null(earth$weights)) + stopifnot(almost.equal(earth$rss.per.response, earth$rss, max=1e-10)) + } > devratio <- function(mod) + { + if(is.null(mod$deviance)) + mod <- mod$glm.list[[1]] + stopifnot(!is.null(mod)) + stopifnot(!is.null(mod$deviance)) + stopifnot(!is.null(mod$null.deviance)) + sprint("devratio %.2f", 1 - mod$deviance / mod$null.deviance) + } > print.devratio <- function(s, mod) + { + printf("%-22s %s\n", s, devratio(mod)) + } > #------------------------------------------------------------------------------ > # linear model > > n <- 100 > set.seed(2019) > x1 <- ((1:n) + runif(n, min=0, max=10)) / n > set.seed(2019) > x2 <- ((1:n) + runif(n, min=0, max=10)) / n > y <- 3 * x1 + rnorm(n) > > myoffset <- (1:n) / n > data <- data.frame(y=y, x1=x1, myoffset=myoffset) > > lm.weights <- lm(y ~ x1, data=data, weights=sin(myoffset)) > earth.weights <- earth(y ~ x1, data=data, weights=sin(myoffset), + linpreds=TRUE, thresh=0, penalty=-1) > check.earth.matches.lm(earth.weights, lm.weights) check earth.weights vs lm.weights > > myoffset <- (1:n) / n > data <- data.frame(y=y, x1=x1, myoffset=myoffset) > lm4 <- lm(y ~ x1 + offset(myoffset), data=data) > earth4 <- earth(y ~ x1 + offset(myoffset), data=data, + linpreds=TRUE, thresh=0, penalty=-1) > check.earth.matches.lm(earth4, lm4) check earth4 vs lm4 > cat("==print(earth4)==\n") ==print(earth4)== > print(earth4) Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: No new term increases RSq at 2 terms Importance: x1 Offset: myoffset with values 0.01, 0.02, 0.03, 0.04, 0.05, 0.06, 0.07, 0... Number of terms at each degree of interaction: 1 1 (additive model) GCV 0.8799077 RSS 87.99077 GRSq 0.312992 RSq 0.312992 > cat("==summary(earth4)==\n") ==summary(earth4)== > print(summary(earth4)) Call: earth(formula=y~x1+offset(myoffset), data=data, linpreds=TRUE, thresh=0, penalty=-1) coefficients (Intercept) -0.1235607 x1 2.1524642 Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: No new term increases RSq at 2 terms Importance: x1 Offset: myoffset with values 0.01, 0.02, 0.03, 0.04, 0.05, 0.06, 0.07, 0... Number of terms at each degree of interaction: 1 1 (additive model) GCV 0.8799077 RSS 87.99077 GRSq 0.312992 RSq 0.312992 > cat("==summary(earth4, details=TRUE)==\n") ==summary(earth4, details=TRUE)== > print(summary(earth4, details=TRUE)) Call: earth(formula=y~x1+offset(myoffset), data=data, linpreds=TRUE, thresh=0, penalty=-1) coefficients (Intercept) -0.1235607 x1 2.1524642 Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: No new term increases RSq at 2 terms Importance: x1 Offset: myoffset with values 0.01, 0.02, 0.03, 0.04, 0.05, 0.06, 0.07, 0... Number of terms at each degree of interaction: 1 1 (additive model) GCV 0.8799077 RSS 87.99077 GRSq 0.312992 RSq 0.312992 > > par(mfrow=c(4, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) > set.seed(2019) > plotmo(lm4, trace=0, pt.col=2, do.par=FALSE) plotmo grid: x1 myoffset 0.5369945 0.505 > mtext( + "row1: lm4\nrow2: earth4\nrow3: lm4 grid.levels=list(myoffset=-3)\nrow4: earth4 grid.levels=list(myoffset=-3)", + outer=TRUE, cex=.8) > set.seed(2019) > plotmo(earth4, trace=0, pt.col=2, do.par=FALSE) 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: x1 myoffset 0.5369945 0.505 > empty.plot() > set.seed(2019) > plotmo(lm4, trace=0, pt.col=2, do.par=FALSE, grid.levels=list(myoffset=-3)) plotmo grid: x1 myoffset 0.5369945 -3 > set.seed(2019) > plotmo(earth4, trace=0, pt.col=2, do.par=FALSE, grid.levels=list(myoffset=-3)) 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: x1 myoffset 0.5369945 -3 > par(old.par) > > plotres(lm4) > plotres(earth4) > > # linear model with weights and offset > > lm4.weights <- lm(y ~ x1 + offset(exp(myoffset)), data=data, weights=sin(myoffset)) > earth4.weights <- earth(y ~ x1 + offset(exp(myoffset)), data=data, weights=sin(myoffset), + linpreds=TRUE, thresh=0, penalty=-1) > check.earth.matches.lm(earth4.weights, lm4.weights) check earth4.weights vs lm4.weights > print(earth4.weights) Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: No new term increases RSq at 2 terms Importance: x1 Offset: exp(myoffset) with values 1.01005, 1.020201, 1.030455, 1.040811,... Weights: 0.009999833, 0.01999867, 0.0299955, 0.03998933, 0.04997917, 0.0... Number of terms at each degree of interaction: 1 1 (additive model) GCV 0.4651571 RSS 46.51571 GRSq 0.1327794 RSq 0.1327794 > print(summary(earth4.weights)) Call: earth(formula=y~x1+offset(exp(myoffset)), data=data, weights=sin(myoffset), linpreds=TRUE, thresh=0, penalty=-1) coefficients (Intercept) -1.065071 x1 1.594748 Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: No new term increases RSq at 2 terms Importance: x1 Offset: exp(myoffset) with values 1.01005, 1.020201, 1.030455, 1.040811,... Weights: 0.009999833, 0.01999867, 0.0299955, 0.03998933, 0.04997917, 0.0... Number of terms at each degree of interaction: 1 1 (additive model) GCV 0.4651571 RSS 46.51571 GRSq 0.1327794 RSq 0.1327794 > > #------------------------------------------------------------------------------ > # error handling > > data <- data.frame(y=y, x1=x1) > expect.err(try(earth(y ~ x1 + offset(myoffset), data=data)), "the offset variable 'myoffset' in 'offset(myoffset)' must be in the data") Error : the offset variable 'myoffset' in 'offset(myoffset)' must be in the data Got error as expected from try(earth(y ~ x1 + offset(myoffset), data = data)) > expect.err(try(earth(y ~ x1 + offset(myoffset))), "if an offset is specified in the formula, the 'data' argument must be used") Error : if an offset is specified in the formula, the 'data' argument must be used Got error as expected from try(earth(y ~ x1 + offset(myoffset))) > > data <- data.frame(y=y, x1=x1, offset0=rep(0, length.out=n), offset1=rep(1, length.out=n)) > expect.err(try(earth(y ~ x1 + offset(offset0) + offset(offset1), data=data)), "only one offset is allowed") Error : only one offset is allowed Got error as expected from try(earth(y ~ x1 + offset(offset0) + offset(offset1), data = data)) > > #------------------------------------------------------------------------------ > # poisson model with and without linear predictors > > library(MASS) > data(Insurance) > Ins <- Insurance > Ins$Claims[Ins$Claims > 100] <- 100 > Ins$day <- (1:nrow(Insurance)) / nrow(Insurance) # non linear term (like a seasonal effect) > Ins$Claims <- round(Ins$Claims * (1 + sin(2 * pi * Ins$day))) > pois <- glm(Claims ~ Group + Age + day + offset(log(Holders)), + data = Ins, family = poisson) > earth.pois.linpreds <- earth(Claims ~ offset(log(Holders)) + Group + Age + day, + data = Ins, glm=list(family = poisson), + linpreds=TRUE, thresh=0, penalty=-1) > > stopifnot(isTRUE(all.equal(coef(earth.pois.linpreds), coefficients(earth.pois.linpreds)))) > stopifnot(isTRUE(all.equal(coef(earth.pois.linpreds, type="glm"), coefficients(earth.pois.linpreds, type="glm")))) > stopifnot(isTRUE(all.equal(coef(earth.pois.linpreds, type="earth"), coefficients(earth.pois.linpreds, type="earth")))) > stopifnot(identical(names(coef(earth.pois.linpreds)), rownames(earth.pois.linpreds$coefficients))) > stopifnot(identical(names(coef(earth.pois.linpreds)), rownames(earth.pois.linpreds$glm.coefficients))) > stopifnot(identical(names(coef(earth.pois.linpreds, type="glm")), rownames(earth.pois.linpreds$glm.coefficients))) > stopifnot(max(abs(coef(earth.pois.linpreds) - earth.pois.linpreds$glm.coefficients)) == 0) > stopifnot(max(abs(coef(earth.pois.linpreds, type="response") - earth.pois.linpreds$glm.coefficients)) == 0) > stopifnot(max(abs(coef(earth.pois.linpreds, type="earth") - earth.pois.linpreds$coefficients)) == 0) > stopifnot(max(abs(coef(earth.pois.linpreds) - earth.pois.linpreds$glm.list[[1]]$coefficients)) == 0) > stopifnot(max(abs(coef(earth.pois.linpreds, type="glm") - earth.pois.linpreds$coefficients)) > 99) > > check.earth.matches.glm(earth.pois.linpreds, pois, newdata=Ins[4:6,]) check earth.pois.linpreds vs pois > earth.pois <- earth(Claims ~ Group + Age + day + offset(log(Holders)), + data = Ins, glm=list(family = poisson)) > cat("==print(earth.pois)==\n") ==print(earth.pois)== > print(earth.pois) GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged 1935.72 63 462.414 58 0.761 753.7 5 1 Earth selected 6 of 14 terms, and 3 of 7 predictors Termination condition: Reached nk 21 Importance: day, Age.L, Group.L, Group.Q-unused, Group.C-unused, ... Offset: log(Holders) with values log(197), log(264), log(246), log(1680)... Number of terms at each degree of interaction: 1 5 (additive model) Earth GCV 1037.405 RSS 45532.35 GRSq 0.6401826 RSq 0.7453446 > cat("==summary(earth.pois)==\n") ==summary(earth.pois)== > print(summary(earth.pois)) Call: earth(formula=Claims~Group+Age+day+offset(log(Holders)), data=Ins, glm=list(family=poisson)) GLM coefficients Claims (Intercept) -1.6274033 h(-0.223607-Group.L) 0.6591962 h(Group.L- -0.223607) 1.2356444 h(Age.L-0.223607) -2.1045753 h(day-0.421875) -10.3890623 h(day-0.578125) 12.8123676 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged 1935.72 63 462.414 58 0.761 753.7 5 1 Earth selected 6 of 14 terms, and 3 of 7 predictors Termination condition: Reached nk 21 Importance: day, Age.L, Group.L, Group.Q-unused, Group.C-unused, ... Offset: log(Holders) with values log(197), log(264), log(246), log(1680)... Number of terms at each degree of interaction: 1 5 (additive model) Earth GCV 1037.405 RSS 45532.35 GRSq 0.6401826 RSq 0.7453446 > cat("==summary(earth.pois, details=TRUE)==\n") ==summary(earth.pois, details=TRUE)== > print(summary(earth.pois, details=TRUE)) Call: earth(formula=Claims~Group+Age+day+offset(log(Holders)), data=Ins, glm=list(family=poisson)) Earth coefficients Claims (Intercept) 86.23803 h(-0.223607-Group.L) -71.10802 h(Group.L- -0.223607) -38.47796 h(Age.L-0.223607) 122.63443 h(day-0.421875) -545.81580 h(day-0.578125) 583.55576 GLM coefficients Claims (Intercept) -1.6274033 h(-0.223607-Group.L) 0.6591962 h(Group.L- -0.223607) 1.2356444 h(Age.L-0.223607) -2.1045753 h(day-0.421875) -10.3890623 h(day-0.578125) 12.8123676 GLM deviance residuals: Min 1Q Median 3Q Max -6.7202654 -1.8420108 -0.2845822 1.2156207 6.5715831 GLM coefficients (family poisson, link log) Estimate Std. Error z value Pr(>|z|) (Intercept) -1.62740331 0.03503726 -46.44779 < 2.22e-16 h(Age.L-0.223607) -2.10457528 0.08442153 -24.92937 < 2.22e-16 h(Group.L- -0.223607) 1.23564436 0.06612011 18.68788 < 2.22e-16 h(-0.223607-Group.L) 0.65919622 0.11236250 5.86669 4.4457e-09 h(day-0.421875) -10.38906233 0.65640911 -15.82711 < 2.22e-16 h(day-0.578125) 12.81236762 1.02262981 12.52884 < 2.22e-16 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged 1935.72 63 462.414 58 0.761 753.7 5 1 Earth selected 6 of 14 terms, and 3 of 7 predictors Termination condition: Reached nk 21 Importance: day, Age.L, Group.L, Group.Q-unused, Group.C-unused, ... Offset: log(Holders) with values log(197), log(264), log(246), log(1680)... Number of terms at each degree of interaction: 1 5 (additive model) Earth GCV 1037.405 RSS 45532.35 GRSq 0.6401826 RSq 0.7453446 > earth.pois.no.penalty <- earth(Claims ~ Group + Age + day + offset(log(Holders)), + data = Ins, glm=list(family = poisson), + thresh=0, penalty=-1) > print.devratio("pois", pois) pois devratio 0.62 > print.devratio("earth.pois.linpreds", earth.pois.linpreds$glm.list[[1]]) earth.pois.linpreds devratio 0.62 > print.devratio("earth.pois", earth.pois$glm.list[[1]]) earth.pois devratio 0.76 > print.devratio("earth.pois.no.penalty", earth.pois.no.penalty$glm.list[[1]]) earth.pois.no.penalty devratio 0.90 > > par(mfrow=c(3, 4), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) > set.seed(2019) > plotmo(pois, trace=0, pt.col=2, do.par=FALSE, ylim=c(0,50)) plotmo grid: Group Age day Holders <1l <25 0.5078125 136 > mtext(sprint( + "row1: pois (%s)\nrow2: earth.pois.linpreds (%s)\nrow3: earth.pois.linpreds(all1=TRUE)", + devratio(pois), devratio(earth.pois.linpreds)), + outer=TRUE, cex=.8) > set.seed(2019) > plotmo(earth.pois.linpreds, trace=0, pt.col=2, do.par=FALSE, ylim=c(0,50)) 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: Holders Group Age day 136 <1l <25 0.5078125 > empty.plot() > set.seed(2019) > plotmo(earth.pois.linpreds, all1=T, trace=-1, pt.col=2, do.par=FALSE, ylim=c(0,50)) > par(old.par) > > plotres(pois, type="response", caption='pois, type="response"') > plotres(earth.pois.linpreds, type="response", caption='earth.pois.linpreds, type="response"') > > par(mfrow=c(3, 4), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) > set.seed(2019) > plotmo(pois, trace=0, pt.col=2, do.par=FALSE, ylim=c(0,50), grid.levels=list(Holders=20)) plotmo grid: Group Age day Holders <1l <25 0.5078125 20 > mtext( + "----- grid.levels=list(Holders=20)) -----\nrow1: pois\nrow2: earth.pois.linpreds\nrow3: earth.pois.linpreds(all1=TRUE)", + outer=TRUE, cex=.8) > set.seed(2019) > plotmo(earth.pois.linpreds, trace=0, pt.col=2, do.par=FALSE, ylim=c(0,50), grid.levels=list(Holders=20)) 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: Holders Group Age day 20 <1l <25 0.5078125 > empty.plot() > set.seed(2019) > plotmo(earth.pois.linpreds, all1=T, trace=-1, pt.col=2, do.par=FALSE, ylim=c(0,50), grid.levels=list(Holders=20)) > par(old.par) > > plotmo(earth.pois.linpreds, pmethod="partdep", do.par=2, + caption=sprint("earth.pois.linpreds, pmethod=\"partdep\", %s", devratio(earth.pois.linpreds))) note: the offset in the formula is not plotted (use all1=TRUE to plot the offset, or use trace=-1 to silence this message) calculating partdep for Group calculating partdep for Age calculating partdep for day > plotmo(earth.pois.linpreds, pmethod="partdep", do.par=0, + grid.levels=list(Age=">35"), degree1="day", main="day with Age=\">35\"") note: the offset in the formula is not plotted (use all1=TRUE to plot the offset, or use trace=-1 to silence this message) calculating partdep for day > plotmo(earth.pois, pmethod="partdep", + caption=sprint("earth.pois, pmethod=\"partdep\", %s", devratio(earth.pois))) note: the offset in the formula is not plotted (use all1=TRUE to plot the offset, or use trace=-1 to silence this message) calculating partdep for Group calculating partdep for Age calculating partdep for day > plotmo(earth.pois.no.penalty, pmethod="partdep", + caption=sprint("earth.pois.no.penalty, pmethod=\"partdep\", %s", devratio(earth.pois.no.penalty))) note: the offset in the formula is not plotted (use all1=TRUE to plot the offset, or use trace=-1 to silence this message) calculating partdep for Group calculating partdep for Age calculating partdep for day > > #------------------------------------------------------------------------------ > # poisson model with weights > > Ins <- Insurance > Ins$Claims[Ins$Claims > 100] <- 100 > Ins$day <- (1:nrow(Insurance)) / nrow(Insurance) # non linear term (like a seasonal effect) > Ins$Claims <- round(Ins$Claims * (1 + sin(2 * pi * Ins$day))) > weights <- 1:nrow(Ins) > > pois.weights <- glm(Claims ~ Group + Age + day, + data = Ins, family = poisson, weights=weights) > > earth.pois.linpreds.weights <- earth(Claims ~ Group + Age + day, + data = Ins, glm=list(family = poisson), + weights=weights, + linpreds=TRUE, thresh=0, penalty=-1) > check.earth.matches.glm(earth.pois.linpreds.weights, pois.weights, newdata=Ins[1:3,]) check earth.pois.linpreds.weights vs pois.weights > > #------------------------------------------------------------------------------ > # poisson model with weights, some of which are zero > > Ins <- Insurance > Ins$Claims[Ins$Claims > 100] <- 100 > Ins$day <- (1:nrow(Insurance)) / nrow(Insurance) # non linear term (like a seasonal effect) > Ins$Claims <- round(Ins$Claims * (1 + sin(2 * pi * Ins$day))) > weights <- 1:nrow(Ins) > weights[4] <- 0 > weights[8] <- 0 > > pois.weights.some.zero <- glm(Claims ~ Group + Age + day, + data = Ins, family = poisson, weights=weights) > > earth.pois.linpreds.weights.some.zero <- earth(Claims ~ Group + Age + day, + data = Ins, glm=list(family = poisson), + weights=weights, + linpreds=TRUE, thresh=0, penalty=-1) > check.earth.matches.glm(earth.pois.linpreds.weights.some.zero, pois.weights.some.zero, newdata=Ins[1:3,], + max=1e-5, max.residuals=1e-2) # TODO why does max.residuals have to be so big here? check earth.pois.linpreds.weights.some.zero vs pois.weights.some.zero > > plotres(pois.weights.some.zero, caption="pois.weights.some.zero") > plotres(earth.pois.linpreds.weights.some.zero, caption="earth.pois.linpreds.weights.some.zero") > plotmo(pois.weights.some.zero, caption="pois.weights.some.zero") plotmo grid: Group Age day <1l <25 0.5078125 > plotmo(earth.pois.linpreds.weights.some.zero, caption="earth.pois.linpreds.weights.some.zero") plotmo grid: Group Age day <1l <25 0.5078125 > > #------------------------------------------------------------------------------ > # multiple response models > > data(trees) > tr <- trees > set.seed(2019) > tr$Vol2 <- tr$Volume + 10 * rnorm(nrow(tr)) > > earth10 <- earth(Volume ~ Girth + offset(log(Height)), data=tr, + linpreds=TRUE, thresh=0, penalty=-1) > lm10 <- lm(Volume ~ Girth + offset(log(Height)), data=tr) > check.earth.matches.lm(earth10, lm10, newdata=tr[c(3:5),]) check earth10 vs lm10 > cat("earth10:\n") earth10: > print(summary(earth10)) Call: earth(formula=Volume~Girth+offset(log(Height)), data=tr, linpreds=TRUE, thresh=0, penalty=-1) coefficients (Intercept) -41.083623 Girth 5.051736 Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: No new term increases RSq at 2 terms Importance: Girth Offset: log(Height) with values log(70), log(65), log(63), log(72), log(... Number of terms at each degree of interaction: 1 1 (additive model) GCV 16.66619 RSS 516.6518 GRSq 0.9358693 RSq 0.9358693 > > earth20 <- earth(Vol2 ~ Girth + offset(log(Height)), data=tr, + linpreds=TRUE, thresh=0, penalty=-1) > cat("earth20:\n") earth20: > print(summary(earth20)) Call: earth(formula=Vol2~Girth+offset(log(Height)), data=tr, linpreds=TRUE, thresh=0, penalty=-1) coefficients (Intercept) -41.875132 Girth 4.991977 Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: No new term increases RSq at 2 terms Importance: Girth Offset: log(Height) with values log(70), log(65), log(63), log(72), log(... Number of terms at each degree of interaction: 1 1 (additive model) GCV 141.1826 RSS 4376.662 GRSq 0.6271664 RSq 0.6271664 > > earth30 <- earth(cbind(Volume, Vol2) ~ Girth + offset(log(Height)), data=tr, + linpreds=TRUE, thresh=0, penalty=-1) > cat("earth30:\n") earth30: > print(summary(earth30)) Call: earth(formula=cbind(Volume,Vol2)~Girth+offset(log(Height)), data=tr, linpreds=TRUE, thresh=0, penalty=-1) Volume Vol2 (Intercept) -41.083623 -41.875132 Girth 5.051736 4.991977 Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: No new term increases RSq at 2 terms Importance: Girth Offset: log(Height) with values log(70), log(65), log(63), log(72), log(... Number of terms at each degree of interaction: 1 1 (additive model) GCV RSS GRSq RSq Volume 16.66619 516.6518 0.9358692 0.9358692 Vol2 141.18264 4376.6618 0.6271664 0.6271664 All 157.84883 4893.3136 0.7528023 0.7528023 > > plotmo(lm10, all1=TRUE, pt.col=2) plotmo grid: Girth Height 12.9 76 > plotmo(earth10, all1=TRUE, pt.col=2) plotmo grid: Girth Height 12.9 76 > plotmo(earth20, all1=TRUE, pt.col=2) plotmo grid: Girth Height 12.9 76 > plotmo(earth30, nresponse=1, all1=TRUE, pt.col=2) plotmo grid: Girth Height 12.9 76 > plotmo(earth30, nresponse=2, all1=TRUE, pt.col=2) plotmo grid: Girth Height 12.9 76 > > plotres(lm10) > plotres(earth10) > plotres(earth20) > plotres(earth30, nresponse=2) > plotres(earth30, nresponse=1) > > # multiple response pois model with weights (basic test) > > Ins <- Insurance > Ins$Claims[Ins$Claims > 100] <- 100 > Ins$day <- (1:nrow(Insurance)) / nrow(Insurance) # non linear term (like a seasonal effect) > Ins$Claims <- round(Ins$Claims * (1 + sin(2 * pi * Ins$day))) > Ins$Claims2 <- Insurance$Claims2 <- round(Insurance$Claims^1.5) > weights <- 1:nrow(Ins) > weights[4] <- 0 > weights[8] <- 0 > > earth.pois.multiple.response <- + earth(x=Insurance$Age, y=cbind(Insurance$Claims, Insurance$Claims2), + trace=1, # Insurance$Age expands to x.L x.Q x.C + glm=list(family = poisson), weights=weights) x[64,3] with colnames x.L x.Q x.C y[64,2] with colnames y1 y2 earth and glm weights[64]: 1, 2, 3, 0, 5, 6, 7, 0, 9, 10, 11, 12... Forward pass term 1, 2, 4 RSq changed by less than 0.001 at 3 terms (DeltaRSq 5.7e-05) After forward pass GRSq 0.175 RSq 0.325 Prune backward penalty 2 nprune null: selected 2 of 3 terms, and 1 of 3 preds After pruning pass GRSq 0.278 RSq 0.323 GLM y1 devratio 0.58 dof 60/61 iters 5 GLM y2 devratio 0.57 dof 60/61 iters 6 > cat("earth.pois.multiple.response:\n") earth.pois.multiple.response: > print(earth.pois.multiple.response) GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged y1 94934.7 61 39830 60 0.580 49300 5 1 y2 1613415.0 61 698038 60 0.567 710400 6 1 Earth selected 2 of 3 terms, and 1 of 3 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: x.L, x.Q-unused, x.C-unused Weights: 1, 2, 3, 0, 5, 6, 7, 0, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, ... Number of terms at each degree of interaction: 1 1 (additive model) Earth GCV RSS GRSq RSq y1 45124.4 2623560 0.4258811 0.4617544 y2 12454506.9 724112813 0.2772184 0.3223809 All 12499631.2 726736372 0.2778934 0.3230137 > cat("summary(earth.pois.multiple.response:\n") summary(earth.pois.multiple.response: > print(summary(earth.pois.multiple.response)) Call: earth(x=Insurance$Age, y=cbind(Insurance$Claims,Insurance$Claims2), weights=weights, trace=1, glm=list(family=poisson)) GLM coefficients y1 y2 (Intercept) 2.693536 4.327129 h(x.L-0.223607) 4.045294 5.791490 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged y1 94934.7 61 39830 60 0.580 49300 5 1 y2 1613415.0 61 698038 60 0.567 710400 6 1 Earth selected 2 of 3 terms, and 1 of 3 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: x.L, x.Q-unused, x.C-unused Weights: 1, 2, 3, 0, 5, 6, 7, 0, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, ... Number of terms at each degree of interaction: 1 1 (additive model) Earth GCV RSS GRSq RSq y1 45124.4 2623560 0.4258811 0.4617544 y2 12454506.9 724112813 0.2772184 0.3223809 All 12499631.2 726736372 0.2778934 0.3230137 > plotmo(earth.pois.multiple.response, nresponse=1, pt.col=2) > > # test update.earth with weights and offset > > data(trees) > tr <- trees > set.seed(2019) > tr$Vol2 <- tr$Volume + 10 * rnorm(nrow(tr)) > my.weights <- 1:nrow(tr) > my.weights[3] <- 0 > > earth30 <- earth(Volume ~ Girth + offset(log(Height)), data=tr, + linpreds=TRUE, thresh=0, penalty=-1) > lm30 <- lm(Volume ~ Girth + offset(log(Height)), data=tr) > check.earth.matches.lm(earth30, lm30, newdata=tr[c(3:5),]) check earth30 vs lm30 > > lm31 <- lm(Volume ~ Girth, data=tr) > earth31 <- earth(Volume ~ Girth, data=tr, + linpreds=TRUE, thresh=0, penalty=-1) > earth31.offset <- update(earth31, formula.=Volume ~ Girth + offset(log(Height))) > check.earth.matches.lm(earth31.offset, lm30, newdata=tr[c(3:5),]) check earth31.offset vs lm30 > earth.nooffset <- update(earth31.offset, formula.=Volume ~ Girth) > check.earth.matches.lm(earth.nooffset, lm31, newdata=tr[c(3:5),]) check earth.nooffset vs lm31 > > lm31.weights <- lm(Volume ~ Girth, data=tr, weights=my.weights) > earth31.weights <- update(earth31, weights=my.weights) > # lower max is needed below because of zeros in my.weights > check.earth.matches.lm(earth31.weights, lm31.weights, newdata=tr[c(3:5),], max=1e-6, max.residuals=1e-6) check earth31.weights vs lm31.weights > > lm31.weights.offset <- lm(Volume ~ Girth + offset(log(Height)), data=tr, weights=my.weights) > earth31.weights.offset <- update(earth31.weights, formula=Volume ~ Girth + offset(log(Height))) > check.earth.matches.lm(earth31.weights.offset, lm31.weights.offset, newdata=tr[c(3:5),], max=1e-6, max.residuals=1e-6) check earth31.weights.offset vs lm31.weights.offset > cat("earth31.weights.offset:\n") earth31.weights.offset: > print(summary(earth31.weights.offset)) Call: earth(formula=Volume~Girth+offset(log(Height)), data=tr, weights=c(1,2,0,4,5,6,7...), linpreds=TRUE, thresh=0, penalty=-1) coefficients (Intercept) -49.507279 Girth 5.594527 Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: No new term increases RSq at 2 terms Importance: Girth Offset: log(Height) with values log(70), log(65), log(63), log(72), log(... Weights: 1, 2, 0, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, ... Number of terms at each degree of interaction: 1 1 (additive model) GCV 292.7582 RSS 9075.505 GRSq 0.9339319 RSq 0.9339319 > > source("test.epilog.R") earth/inst/slowtests/earth.times.txt0000644000176200001440000001764313403264661017405 0ustar liggesusersTiming Test Results On Earth Version 4.6.2 May 2018 ---------------------------------------------------- Tested on Dell M6800 2.90 GHz i7 laptop running Win7, computer quiet, internet disconnected. ==== ozone 330 x 9 ============ nk degree earth earth | execution time ratio: | grsq: nterms time | mars no-fastmars no-betacache minspan=1 allowed weights | earth mars no-fastmars minspan=1 weights | | 5 1 5 0.004 | 0.3 1.0 1.0 1.0 1.0 4 | 0.69 0.69 0.69 0.70 0.70 5 2 4 0.005 | 0.2 0.9 0.9 0.8 0.9 4 | 0.69 0.69 0.69 0.69 0.69 5 3 4 0.004 | 0.3 0.9 1.0 1.0 1.0 5 | 0.69 0.69 0.69 0.69 0.69 | | 21 1 12 0.006 | 0.6 1.0 1.1 1.1 1.0 52 | 0.77 0.77 0.77 0.78 0.77 21 2 12 0.013 | 1.4 1.0 1.1 1.1 1.0 88 | 0.79 0.78 0.79 0.79 0.78 21 3 15 0.015 | 1.4 1.0 1.1 1.2 1.1 96 | 0.79 0.78 0.79 0.79 0.78 | | 51 1 16 0.009 | 1.3 1.0 1.2 1.4 1.0 305 | 0.78 0.77 0.78 0.80 0.78 51 2 25 0.023 | 5.4 1.7 1.1 0.9 1.0 146 | 0.81 0.80 0.82 0.80 0.79 51 3 27 0.046 | 3.9 1.5 1.3 1.2 1.0 319 | 0.82 0.82 0.82 0.80 0.80 ==== robot arm 1000 x 20 ======== nk degree earth earth | execution time ratio: | grsq: nterms time | mars no-fastmars no-betacache minspan=1 allowed weights | earth mars no-fastmars minspan=1 weights | | 5 1 4 0.010 | 0.2 1.0 1.0 0.6 0.6 26 | 0.58 0.58 0.58 0.58 0.58 5 2 4 0.010 | 0.2 1.0 0.8 1.0 1.0 40 | 0.58 0.58 0.58 0.58 0.58 5 3 4 0.008 | 0.7 1.2 1.2 1.2 1.2 50 | 0.58 0.58 0.58 0.58 0.58 | | 21 1 17 0.014 | 1.1 1.1 1.4 1.6 1.4 425 | 0.81 0.81 0.81 0.81 0.81 21 2 19 0.060 | 1.5 1.0 1.1 1.2 1.0 384 | 0.89 0.89 0.89 0.89 0.89 21 3 19 0.084 | 1.5 1.0 1.2 1.3 1.1 383 | 0.90 0.90 0.90 0.90 0.90 | | 51 1 22 0.022 | 3.5 1.3 1.3 1.7 1.3 707 | 0.81 0.81 0.81 0.81 0.81 51 2 31 0.116 | 5.1 1.8 1.2 1.2 1.1 609 | 0.95 0.95 0.95 0.95 0.95 51 3 43 0.328 | 3.3 1.6 1.3 1.3 1.0 816 | 0.97 0.96 0.97 0.97 0.97 Timing Test Results On Earth Version 0.1 ---------------------------------------- NOTE Jan 2008: more recent tests can be found at www.milbo.users.sonic.net. Tested on a 1.5GHz Dell laptop with the robot arm from Friedman's Fast MARS paper. These tests were done before I added the multiple response code. I re-defined BETA_CACHE to FALSE when I added the multiple response code, so the current code is not as fast as the times below. N ncol(x) fast.k degree time gcv grsq nterms npreds 3000 5 -1 10 4.9 0.0025 0.98 54 4 original 3000 5 20 10 3.6 0.0024 0.98 59 4 original 3000 30 -1 10 41 0.0025 0.98 54 4 original 3000 30 20 10 27 0.0024 0.98 59 4 original 3000 5 -1 10 5 0.0025 0.98 54 4 no -O3 (i.e. -O2) 3000 5 20 10 3.7 0.0024 0.98 59 4 no -O3 (i.e. -O2) 3000 30 -1 10 41 0.0025 0.98 54 4 no -O3 (i.e. -O2) 3000 30 20 10 27 0.0024 0.98 59 4 no -O3 (i.e. -O2) 3000 5 -1 10 4.9 0.0025 0.98 54 4 no INLINE 3000 5 20 10 3.7 0.0024 0.98 59 4 no INLINE 3000 30 -1 10 41 0.0025 0.98 54 4 no INLINE 3000 30 20 10 27 0.0024 0.98 59 4 no INLINE 3000 5 -1 10 6.7 0.0025 0.98 54 4 no BLAS 3000 5 20 10 4.8 0.0024 0.98 59 4 no BLAS 3000 30 -1 10 62 0.0025 0.98 54 4 no BLAS 3000 30 20 10 39 0.0024 0.98 59 4 no BLAS 3000 5 -1 10 5.7 0.0025 0.98 54 4 no BETA_CACHE 3000 5 20 10 4.2 0.0024 0.98 59 4 no BETA_CACHE 3000 30 -1 10 49 0.0025 0.98 54 4 no BETA_CACHE 3000 30 20 10 32 0.0024 0.98 59 4 no BETA_CACHE 3000 5 -1 10 7.6 0.0025 0.98 54 4 no INLINE, no USE_BLAS, no BETA_CACHE 3000 5 20 10 5.4 0.0024 0.98 59 4 no INLINE, no USE_BLAS, no BETA_CACHE 3000 30 -1 10 70 0.0025 0.98 54 4 no INLINE, no USE_BLAS, no BETA_CACHE 3000 30 20 10 44 0.0024 0.98 59 4 no INLINE, no USE_BLAS, no BETA_CACHE Notes ----- 1. INLINE appears to make no difference for this model -- is gcc actually doing the inlining? Using the Microsoft compiler, INLINE makes a difference(not shown here) 2. -O3 appears to make no difference for this model 3. fast.k gives less improvement than expected from the Fast MARS paper 4. To see a malloc fail (in RegressAndFix) on a 512 MB machine: test(s, 100000, -1, 1, 5) This probably means that the peak memory use occurs in RegressAndFix, which could be fixed quite easily but I haven't done so yet. Here is the code used to produce the above table. robotArm <- function(x) { x. <- with(x, l1 * cos(theta1) - l2 * cos(theta1 + theta2) * cos(phi)) y <- with(x, l1 * sin(theta1) - l2 * sin(theta1 + theta2) * cos(phi)) z <- with(x, l2 * sin(theta2) * sin(phi)) sqrt(x.^2 + y^2 + z^2) } test <- function(s, N, fast.k, degree, ndummy) { set.seed(1) # for reproducibility gc() l1 <- runif(N, 0, 1) l2 <- runif(N, 0, 1) theta1 <- runif(N, 0, 2 * pi) theta2 <- runif(N, 0, 2 * pi) phi <- runif(N, -pi/2, pi/2) x <- cbind(l1, l2, theta1, theta2, phi) if (ndummy > 0) for (i in 1:ndummy) x <- cbind(x, runif(N, 0, 1)) x <- data.frame(x) e.time <- system.time(e <- earth(x, robotArm(x), degree=degree, nk=201, fast.k=fast.k)) options(digits=2) cat(N, "\t", ncol(x), "\t", fast.k, "\t", degree, "\t", e.time[1], "\t", e$gcv, "\t", e$grsq, "\t", length(e$selected.terms), "\t", earth:::get.nused.preds.per.subset(e$dirs, e$selected.terms), "\t", s, "\n") } s <- "original" cat("N ncol(x) fast.k degree time gcv grsq nterms npreds\n") test(s, 3000, -1, 10, 0) test(s, 3000, 20, 10, 0) test(s, 3000, -1, 10, 25) test(s, 3000, 20, 10, 25) Forden Wales Mar 2007 earth/inst/slowtests/test.varmod.R0000644000176200001440000003763613470057551017020 0ustar liggesusers# test.varmod.R source("test.prolog.R") library(earth) options(warn=2) printh <- function(caption) cat("===", caption, "\n", sep="") CAPTION <- NULL multifigure <- function(caption, nrow=3, ncol=3) { CAPTION <<- caption printh(caption) par(mfrow=c(nrow, ncol)) par(cex = 0.8) par(mar = c(3, 3, 5, 0.5)) # small margins but space for right hand axis par(mgp = c(1.6, 0.6, 0)) # flatten axis elements oma <- par("oma") # make space for caption oma[3] <- 2 par(oma=oma) } do.caption <- function() # must be called _after_ first plot on new page mtext(CAPTION, outer=TRUE, font=2, line=1, cex=1) old.par <- par(no.readonly=TRUE) multifigure("test predict.earth with pints", 2, 2) set.seed(2) earth.trees <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="earth") old.environment <- attr(earth.trees$varmod, ".Environment") stopifnot(is.environment(old.environment)) # following necessary else print.default prints a different default environment hex address each time attr(earth.trees$varmod, ".Environment") <- NULL printh("print.default(earth.trees$varmod)") print.default(earth.trees$varmod) attr(earth.trees$varmod, ".Environment") <- old.environment printh("summary(earth.trees)") print(summary(earth.trees)) # level arg not allowed with interval="se" expect.err(try(predict(earth.trees, interval="se", level=.8))) printh("predict(earth.trees, interval=\"se\")") stderrs <- predict(earth.trees, interval="se") print(stderrs) # level arg not allowed with interval="abs.residual" expect.err(try(predict(earth.trees, interval="abs.res", level=.8))) printh("predict(earth.trees, interval=\"abs.residual\")") stderrs <- predict(earth.trees, interval="abs.residual") print(stderrs) expect.err(try(predict(earth.trees, newdata=trees, interval="cint"))) printh("predict(earth.trees, interval=\"cint\")") cints <- predict(earth.trees, interval="cint") print(cints) printh("predict(earth.trees, interval=\"pin\", level=.80)") news <- predict(earth.trees, interval="pin", level=.80) print(news) expect.err(try(predict(earth.trees, interval="none", level=.80)), "predict.earth: level=0.8 was specified but interval=\"none\"") expect.err(try(predict(earth.trees, interval="pin", type="class")), "predict.earth: the interval argument is not allowed with type=\"class\"") expect.err(try(predict(earth.trees, interval="pin", type="cl")), "predict.earth: the interval argument is not allowed with type=\"class\"") expect.err(try(predict(earth.trees, interval="pin", type="ter")), "predict.earth: the interval argument is not allowed with type=\"terms\"") printh("print.default(earth.trees$varmod$residmod)") # have to modify earth.trees because terms field stores the environment # as a hex address which messes up the diffs earth.trees$varmod$residmod$terms <- NULL print.default(earth.trees$varmod$residmod) # prevent mistakes later where we try to use a modified earth.trees remove(earth.trees) multifigure("test example for varmod help page", 2, 2) data(ozone1) set.seed(1) # optional, for cross validation reproducibility a <- earth(O3~temp, data=ozone1, nfold=10, ncross=3, varmod.method="earth") print(summary(a)) # note additional info on the variance model old.mfrow <- par(mfrow=c(2,2)) # the variance model assumes residuals are symmetric, which is not # quite true in this example, so the lower band is a bit too big plotmo(a, do.par=FALSE, col.response=1, level=.95, main="earth model: O3~temp") plot(a, which=1) # model selection plot, same as ever plot(a, which=3, level=.95) # residual plot: note 95% pred and darker conf intervals plot(a, which=3, level=.95, standardize=TRUE) # standardize resids are approx homoscedastic par(par=old.mfrow) plot(a$varmod) # plot the embedded variance model (this calls plot.varmod) multifigure("test example for plot.varmod help page", 2, 2) # multivariate example (for univariate, see the example on the varmod help page) data(ozone1) set.seed(1) # optional, for cross validation reproducibility mod.temp.vh.doy <- earth(O3~temp+vh+vis+doy, data=ozone1, nfold=5, ncross=3, varmod.method="x.earth") print(summary(mod.temp.vh.doy)) # note additional info on the variance model plot(mod.temp.vh.doy, level=.95) # note 95% pred and darker conf intervals in resids plot plot(mod.temp.vh.doy$varmod) # plot the variance model (this calls plot.varmod) plot(mod.temp.vh.doy, versus="", level=.9, caption="plot.earth versus=\"\"") plot(mod.temp.vh.doy, versus="v", level=.9, caption="plot.earth versus=\"v\" and versus=\"temp\"", do.par=2) plot(mod.temp.vh.doy, versus="temp", level=.9, caption="", main="temp on same page") # plot.earth will silently not plots it cannot plot below, so 1:9 becomes c(3,5,6) plot(mod.temp.vh.doy, which=1:9, versus="v", info=T, caption='which=c(3,5) versus="v" info=T') # versus="b:" plot(mod.temp.vh.doy, versus="b:", level=.9, caption="plot.earth versus=\"b:\"") # versus="b:" and versus=1:4 with info plot(mod.temp.vh.doy, versus="b:", level=.8, info=TRUE, caption="plot.earth versus=\"b:\" with info") multifigure("versus=1:4", 3, 3) plot(mod.temp.vh.doy, versus=1, caption="", do.par=FALSE, which=3) do.caption() plot(mod.temp.vh.doy, versus=2, caption="", do.par=FALSE) plot(mod.temp.vh.doy, versus=3, caption="", do.par=FALSE) plot(mod.temp.vh.doy, versus=1, info=TRUE, caption="", do.par=FALSE, which=3) plot(mod.temp.vh.doy, versus=2, info=TRUE, caption="", do.par=FALSE) plot(mod.temp.vh.doy, versus=3, info=TRUE, caption="", do.par=FALSE) plot(mod.temp.vh.doy, versus=1, info=TRUE, caption="", do.par=FALSE, level=.8, which=3) plot(mod.temp.vh.doy, versus=2, info=TRUE, caption="", do.par=FALSE, level=.8) plot(mod.temp.vh.doy, versus=3, info=TRUE, caption="", do.par=FALSE, level=.8) expect.err(try(plot(mod.temp.vh.doy, versus=9))) expect.err(try(plot(mod.temp.vh.doy, versus=1.2))) expect.err(try(plot(mod.temp.vh.doy, versus=2:3))) # versus="b:doy" plot(mod.temp.vh.doy, versus="b:doy", level=.9, caption="plot.earth versus=\"b:doy\"") # test warnings from plotres about which options(warn=1) # print warnings as they occur plot(mod.temp.vh.doy, which=1, versus="b:doy") options(warn=2) multifigure("test example in (very old) earth vignette", 2, 2) data(ozone1) x <- ozone1$temp y <- ozone1$O3 set.seed(1) # optional, for cross validation reproducibility earth.mod <- earth(y~x, nfold=10, ncross=3, varmod.method="earth", trace=.1) predict <- predict(earth.mod, interval="pint") order <- order(x) x <- x[order] y <- y[order] predict <- predict[order,] inconf <- y >= predict$lwr & y <= predict$upr plot(x, y, pch=20, col=ifelse(inconf, 1, 2), main=sprint( "Prediction intervals\n%.0f%% of the points are in the estimated band", 100 * sum(inconf) / length(y))) do.caption() lines(x, predict$fit) lines(x, predict$lwr, lty=2) lines(x, predict$upr, lty=2) # Plot the Residuals vs Fitted graph plot(earth.mod, which=3, level=.95) # Plot the embedded residual model plot(earth.mod$varmod, do.par=F, which=1:2) cat('head(residuals(earth.mod))\n') print(head(residuals(earth.mod))) cat('head(residuals(earth.mod, type="standardize"))\n') print(head(residuals(earth.mod, type="standardize"))) multifigure("plot.earth varmod options", 2, 2) plot(earth.mod, which=3, level=.95, level.shade=0, main="plot.earth varmod options") do.caption() plot(earth.mod, which=3, level.shade="orange", level.shade2="darkgray", level=.99) plot(earth.mod, which=3, level=.95, level.shade=0, level.shade2="mistyrose4") multifigure("plot.earth delever and standardize", 2, 2) set.seed(4) earth.mod1 <- earth(O3~temp, data=ozone1, nfold=5, ncross=3, varmod.method="lm", keepxy=T, trace=.1) plot(earth.mod1, which=3, ylim=c(-16,20), info=TRUE, level=.95) do.caption() plot(earth.mod1, which=3, ylim=c(-16,20), delever=TRUE, level=.95) plot(earth.mod1, which=3, standardize=TRUE, info=TRUE, level=.95) # the standardize and delever arguments cannot both be set expect.err(try(plot(earth.mod1, which=3, standardize=TRUE, delever=TRUE, level=.95))) multifigure("plot.earth which=5 and which=6", 2, 3) plot(earth.mod1, which=5, info=T, main="which=5, info=T") plot(earth.mod1, which=5, standardize=T, info=T, main="which=5, standardize=T, info=T") plot(earth.mod1, which=5, standardize=T, main="which=5, standardize=T") do.caption() plot(earth.mod1, which=6, info=T, main="which=6, info=T") plot(earth.mod1, which=6, standardize=T, info=T, main="which=6, standardize=T, info=T") plot(earth.mod1, which=6, standardize=T, main="which=6, standardize=T") multifigure("plot.earth which=7", 2, 3) plot(earth.mod1, which=7, info=T, main="which=7, info=T") plot(earth.mod1, which=7, standardize=T, info=T, main="which=7, standardize=T, info=T") plot(earth.mod1, which=7, standardize=T, main="which=7, standardize=T") do.caption() multifigure("plot.earth which=8 and which=9", 2, 3) plot(earth.mod1, which=8, info=T, main="which=8, info=T") plot(earth.mod1, which=8, standardize=T, info=T, main="which=8, standardize=T, info=T") plot(earth.mod1, which=8, standardize=T, main="which=8, standardize=T") do.caption() plot(earth.mod1, which=9, info=T, main="which=9, info=T") plot(earth.mod1, which=9, standardize=T, info=T, main="which=9, standardize=T, info=T") plot(earth.mod1, which=9, standardize=T, main="which=9, standardize=T") multifigure("plot.earth versus=4, which=3 and which=5", 2, 3) plot(earth.mod1, versus=4, which=3, main="versus=4, which=3") plot(earth.mod1, versus=4, which=3, standardize=T, info=T, main="versus=4, which=3, standardize=T, info=T") plot(earth.mod1, versus=4, which=3, standardize=T, main="versus=4, which=3, standardize=T") do.caption() plot(earth.mod1, versus=4, which=5, main="versus=4, which=5") plot(earth.mod1, versus=4, which=5, standardize=T, info=T, main="versus=4, which=5, standardize=T, info=T") plot(earth.mod1, versus=4, which=5, standardize=T, main="versus=4, which=5, standardize=T") cat("summary(earth.mod1, newdata=ozone1)\n") print(summary(earth.mod1, newdata=ozone1)) cat("summary(earth.mod1, newdata=ozone1[1:100,]:)\n") print(summary(earth.mod1, newdata=ozone1[1:100,])) # earth.default O3 <- ozone1$O3 temp <- ozone1$temp set.seed(4) earth.default <- earth(temp, O3, nfold=5, ncross=3, varmod.method="lm") cat("summary(earth.default)\n") print(summary(earth.default)) cat("summary(earth.default, newdata=ozone1[1:100,]:)\n") print(summary(earth.default, newdata=ozone1[1:100,])) plot(earth.default, level=.80, caption="earth.default") plotmo(earth.default, level=.80, col.response=3, caption="earth.default\nlevel = .80") # TODO the following give err msg as expected, but do not give a try error # expect.err(try(summary(earth.mod1, newdata=c(1,2,3)))) # expect.err(try(summary(earth.mod1, newdata=ozone1[1:100,1:3]))) multifigure("plot(earth.mod1)", 2, 2) set.seed(5) earth.mod2 <- earth(y~x, nfold=10, ncross=5, varmod.method="earth") plot(earth.mod2, caption="plot(earth.mod2)", level=.95) do.caption() multifigure("plot(earth.mod2) with standardize=TRUE", 2, 2) plot(earth.mod2, standardize=TRUE, level=.95, caption="plot(earth.mod2, standardize=TRUE, level=.95)") do.caption() multifigure("plot.varmod by calling plot(earth.mod2$varmod)", 2, 2) plot(earth.mod2$varmod) multifigure("embedded earth model by calling plot(earth.mod2$varmod$residmod)", 2, 2) plot(earth.mod2$varmod$residmod, caption="embedded earth model") do.caption() # test varmod.* args like varmod.conv # cat("test varmod.exponent=.5\n") # set.seed(1) # (earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="lm", trace=.3, varmod.exponent=.5)) # cat("test varmod.lambda=2/3\n") # set.seed(1) # (earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="lm", trace=.3, varmod.lambda=2/3)) cat("test varmod.conv=50%\n") set.seed(1) (earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="lm", trace=.3, varmod.conv=50)) cat("test varmod.conv=-5\n") set.seed(1) (earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="lm", trace=.3, varmod.conv=-5)) cat("test varmod.clamp\n") set.seed(1) a.noclamp <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="lm") plot(a.noclamp$varmod, which=1:2, caption="a.noclamp and a.clamp", do.par=FALSE) set.seed(1) a.clamp <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="lm", varmod.clamp=.6) plot(a.clamp$varmod, which=1:2, caption="", do.par=FALSE) cat("test varmod.minspan=-5\n") set.seed(1) a.varmod.minspan.minus5 <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="earth", trace=.3, varmod.minspan=-5) print(coef(a.varmod.minspan.minus5$varmod)) cat("test varmod.minspan=1\n") set.seed(1) a.varmod.minspan1 <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="earth", trace=.3, varmod.minspan=1) print(coef(a.varmod.minspan1$varmod)) # gam and y.gam are repeated below and on the repeat we will use the mgcv not gam package use.mgcv.package <- FALSE for(varmod.method in c(earth:::VARMOD.METHODS, "gam", "x.gam")) { multifigure(sprint("varmod.method=\"%s\"", varmod.method), 2, 3) par(mar = c(3, 3, 2, 3)) # space for right margin axis if(varmod.method %in% c("gam", "x.gam")) { if(use.mgcv.package) { # TODO with R 3.2.1 unload(gam) no longer works cat("skipping mgcv tests\n") next # NOTE next cat("library(mgcv)\n") library(mgcv) } else library(gam) } set.seed(2019) # may 2019: following added because gam version 1.16 R version 3.6.0 gives Warning: non-list contrasts argument ignored if(varmod.method %in% c("gam", "x.gam")) options(warn=1) earth.mod <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method=varmod.method, trace=if(varmod.method %in% c("const", "lm", "power")) .3 else 0) options(warn=2) printh(sprint("varmod.method %s: summary(earth.mod)", varmod.method)) printh("summary(earth.mod)") print(summary(earth.mod)) if(use.mgcv.package && (varmod.method == "x.gam" || varmod.method == "gam")) { # summary(mgcv) prints environment as hex address which messes up the diffs printh("skipping summary(mgcv::gam) etc.\n") } else { printh("earth.mod$varmod") print(earth.mod$varmod, style="unit") printh("summary(earth.mod$varmod)") print(summary(earth.mod$varmod)) printh("summary(earth.mod$varmod$residmod)") print(summary(earth.mod$varmod$residmod)) } printh(sprint("varmod.method %s: predict(earth.mod, interval=\"pint\")", varmod.method)) pints <- predict(earth.mod, interval="pint") print(pints) plotmo(earth.mod$varmod, do.par=FALSE, col.response=2, clip=FALSE, main="plotmo residual model", xlab="x", ylab="varmod residuals") plotmo(earth.mod, level=.90, do.par=FALSE, col.response=1, clip=FALSE, main="main model plotmo Girth") do.caption() plot(earth.mod, which=3, do.par=FALSE, level=.95) # plot.varmod plot(earth.mod$varmod, do.par=FALSE, which=1:3, info=(varmod.method=="earth")) # on second use of gam and y.gam we want to use the mgcv package if(varmod.method == "x.gam" && !use.mgcv.package) { use.mgcv.package <- TRUE cat("detach(\"package:gam\", unload=TRUE)\n") detach("package:gam", unload=TRUE) } } # test varmod.exponent set.seed(6) earth.exponent <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="lm", varmod.exponent=.5) printh("summary(earth.exponent)") print(summary(earth.exponent)) par(old.par) source("test.epilog.R") earth/inst/slowtests/test.cv.bat0000755000176200001440000000145113514230362016462 0ustar liggesusers@rem test.cv.bat: tests earth cross validation @rem Stephen Milborrow Nov 2008 Gardens @echo test.cv.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.cv.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.cv.Rout: @tail test.cv.Rout @echo test.cv.R @echo. @exit /B 1 :good1 mks.diff test.cv.Rout test.cv.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.cv.save.ps @exit /B 1 @rem test.cv.save.ps is too big to be included in the release @rem so it is stored elsewhere :good2 diffps Rplots.ps ..\..\.#\test-reference\test.cv.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.cv.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.big.bat0000755000176200001440000000244613514230362016620 0ustar liggesusers@rem test.big.bat: This tests earth on a biggish model @rem This is the test mentioned in the earth man page "Big Models" section @rem Stephen Milborrow Mar 2008 Durban @echo test.big.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.big.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.big.Rout: @echo. @tail test.big.Rout @echo test.big.R @exit /B 1 :good1 @echo diff test.big.Rout test.big.Rout.save @rem egreps to deal with times @C:\Rtools\bin\echo -n "new " @egrep "^\[total time" test.big.Rout @C:\Rtools\bin\echo -n "old " @egrep "^\[total time" test.big.Rout.save @egrep -v "^\[total time" test.big.Rout >test.big.Rout1 @egrep -v "^\[total time" test.big.Rout.save >test.big.Rout.save1 @mks.diff test.big.Rout1 test.big.Rout.save1 @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.big.save.ps @exit /B 1 :good2 @rem test.big.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.big.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.big.Rout test.big.Rout1 test.big.Rout.save1 @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/make.bat0000755000176200001440000000360113561156441016017 0ustar liggesusers@rem earth/inst/slowtests/make.bat time /T @call test.earthmain.gcc.bat @if %errorlevel% NEQ 0 goto error @call test.earthmain.clang.bat @if %errorlevel% NEQ 0 goto error @call test.earthmain.vc.bat @if %errorlevel% NEQ 0 goto error @call test.earthc.bat @if %errorlevel% NEQ 0 goto error @call test.mods.bat @if %errorlevel% NEQ 0 goto error @call test.incorrect.bat @if %errorlevel% NEQ 0 goto error @call test.big.bat @if %errorlevel% NEQ 0 goto error @call test.weights.bat @if %errorlevel% NEQ 0 goto error @call test.glm.bat @if %errorlevel% NEQ 0 goto error @call test.expand.bpairs.bat @if %errorlevel% NEQ 0 goto error @call test.bpairs.bat @if %errorlevel% NEQ 0 goto error @call test.full.bat @if %errorlevel% NEQ 0 goto error @call test.allowedfunc.bat @if %errorlevel% NEQ 0 goto error @call test.cv.bat @if %errorlevel% NEQ 0 goto error @call test.pmethod.cv.bat @if %errorlevel% NEQ 0 goto error @call test.varmod.bat @if %errorlevel% NEQ 0 goto error @call test.varmod.mgcv.bat @if %errorlevel% NEQ 0 goto error @call test.plotd.bat @if %errorlevel% NEQ 0 goto error @call test.offset.bat @if %errorlevel% NEQ 0 goto error @call test.multresp.bat @if %errorlevel% NEQ 0 goto error @call test.mem.bat @if %errorlevel% NEQ 0 goto error @goto done :error @echo ==== ERROR ==== @exit /B %errorlevel% :done @rm -f ../../src/earth_res.rc ../Makedeps @rm -f test.*.pdf *.dll *.lib *.pdb time /T @exit /B 0 earth/inst/slowtests/test.allowedfunc.Rout.save0000644000176200001440000003655313451166410021507 0ustar liggesusers> # test.allowedfunc.R > > source("test.prolog.R") > source("check.models.equal.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > data(trees) > > printh <- function(x, expect.warning=FALSE, max.print=0) # like print but with a header + { + cat("===", deparse(substitute(x)), " ", sep="") + if(expect.warning) + cat(" expect warning -->") + else if (NROW(x) > 1) + cat("\n") + if (max.print > 0) + print(head(x, n=max.print)) + else + print(x) + } > > example.nopred2 <- function(degree, pred, parents) + { + pred != 2 # disallow predictor 2, which is "Height" + } > a.nopred2 <- earth(Volume ~ ., data = trees, allowed = example.nopred2) > printh(summary(a.nopred2)) ===summary(a.nopred2) Call: earth(formula=Volume~., data=trees, allowed=example.nopred2) coefficients (Intercept) 30.656747 h(14.2-Girth) -3.569047 h(Girth-14.2) 6.757306 Selected 3 of 3 terms, and 1 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: Girth, Height-unused Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.3391 RSS 312.6848 GRSq 0.948644 RSq 0.9614259 > > example.noHeight <- function(degree, pred, parents, namesx) + { + namesx[pred] != "Height" # disallow "Height" + } > a.noHeight <- earth(Volume ~ ., data = trees, allowed = example.noHeight) > newdata.global <- trees[seq(from=nrow(trees), to=1, by=-5),] > check.models.equal(a.nopred2, a.noHeight, msg="\"allowed\" function a.nopred2 a.noHeight", newdata=newdata.global) "allowed" function a.nopred2 a.noHeight: models identical > > # we explicitly set minspan and endspan here because they are calculated differently if number of predictors is different > aGirthOnly <- earth(Volume ~ Girth, data = trees, trace=4, minspan=1, endspan=1) Call: earth(formula=Volume~Girth, data=trees, trace=4, minspan=1, endspan=1) x[31,1]: Girth 1 8.3 2 8.6 3 8.8 ... 10.5 31 20.6 y[31,1]: Volume 1 10.3 2 10.3 3 10.2 ... 16.4 31 77.0 Forward pass: minspan 1 endspan 1 x[31,1] 248 Bytes bx[31,21] 5.09 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.9503 0.9627 0.9627 1 Girth 16 2 3 1 4 0.9446 0.9645 0.00186 1 Girth 13.7 4 1 6 0.9349 0.9650 0.00042 1 Girth 17.3 5 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 5 terms, 4 terms used (DeltaRSq 0.00042) After forward pass GRSq 0.935 RSq 0.965 Forward pass complete: 5 terms, 4 terms used Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 2 0.7615 0.7922 0.7615 1 1 3 chosen 3 0.9503 0.9627 0.1888 1 1 2 3 4 0.9446 0.9645 -0.0057 1 1 2 3 4 Prune backward penalty 2 nprune null: selected 3 of 4 terms, and 1 of 1 preds After pruning pass GRSq 0.95 RSq 0.963 > printh(summary(aGirthOnly)) ===summary(aGirthOnly) Call: earth(formula=Volume~Girth, data=trees, trace=4, minspan=1, endspan=1) coefficients (Intercept) 39.289008 h(16-Girth) -3.993966 h(Girth-16) 8.260584 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 13.86977 RSS 302.4505 GRSq 0.9503249 RSq 0.9626885 > a1c <- earth(Volume ~ ., data = trees, allowed = example.noHeight, trace=4, minspan=1, endspan=1) Call: earth(formula=Volume~., data=trees, trace=4, allowed=example.noHeight, minspan=1, endspan=1) x[31,2]: Girth Height 1 8.3 70 2 8.6 65 3 8.8 63 ... 10.5 72 31 20.6 87 y[31,1]: Volume 1 10.3 2 10.3 3 10.2 ... 16.4 31 77.0 Forward pass: minspan 1 endspan 1 x[31,2] 496 Bytes bx[31,21] 5.09 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.9503 0.9627 0.9627 1 Girth 16 2 3 1 4 0.9446 0.9645 0.00186 1 Girth 13.7 4 1 6 0.9349 0.9650 0.00042 1 Girth 17.3 5 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 5 terms, 4 terms used (DeltaRSq 0.00042) After forward pass GRSq 0.935 RSq 0.965 Forward pass complete: 5 terms, 4 terms used Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 2 0.7615 0.7922 0.7615 1 1 3 chosen 3 0.9503 0.9627 0.1888 1 1 2 3 4 0.9446 0.9645 -0.0057 1 1 2 3 4 Prune backward penalty 2 nprune null: selected 3 of 4 terms, and 1 of 2 preds After pruning pass GRSq 0.95 RSq 0.963 > # can't use check.models.equal because e.g. dirs for a1c has two columns but aGirthOnly has only one column > stopifnot(identical(predict(aGirthOnly), predict(a1c))) > > iheight <- 0 > example.noHeight.first <- function(degree, pred, parents, namesx, first) + { + if (first) { + iheight <<- which(namesx == "Height") # note use of <<- not <- + if (length(iheight) != 1) + stop("could not find Height in ", paste(namesx, collapse=" ")) + } + pred != iheight + } > a.noHeight.first <- earth(Volume ~ ., data = trees, allowed = example.noHeight.first) > check.models.equal(a.nopred2, a.noHeight, msg="\"allowed\" function a.nopred2 a.noHeight.first", newdata=newdata.global) "allowed" function a.nopred2 a.noHeight.first: models identical > > example.noHumidityInDegree2 <- function(degree, pred, parents) + { + # disallow humidity in terms of degree > 1 + # 3 is the "humidity" column in the input matrix + if (degree > 1 && (pred == 3 || parents[3])) + return(FALSE) + TRUE + } > a.noHumidityInDegree2 <- earth(O3 ~ ., data = ozone1, degree = 2, allowed = example.noHumidityInDegree2) > printh(summary(a.noHumidityInDegree2)) ===summary(a.noHumidityInDegree2) Call: earth(formula=O3~., data=ozone1, degree=2, allowed=example.noHumidityInDegree2) coefficients (Intercept) 14.8457466 h(5860-vh) -0.0157499 h(vh-5860) 0.2637241 h(temp-58) 0.5296758 h(ibh-1105) -0.0004860 h(10-dpg) -0.0560986 h(dpg-10) -0.0761112 h(150-vis) 0.0504424 h(96-doy) -0.1184470 h(doy-158) -0.0302548 h(vh-5860) * h(dpg- -15) -0.0038034 h(vh-5860) * h(-15-dpg) -0.0093059 h(temp-58) * h(dpg-52) -0.0160364 h(temp-58) * h(52-dpg) -0.0047659 h(72-temp) * h(150-vis) -0.0012431 h(temp-72) * h(150-vis) -0.0042689 Selected 16 of 20 terms, and 6 of 9 predictors Termination condition: Reached nk 21 Importance: temp, doy, dpg, vis, vh, ibh, wind-unused, humidity-unused, ... Number of terms at each degree of interaction: 1 9 6 GCV 15.17392 RSS 3907.158 GRSq 0.764291 RSq 0.8149617 > example.Degree2OnlyHumidityAndTemp <- function(degree, pred, parents) + { + # allow only humidity and temp in terms of degree > 1 + # 3 and 4 are the "humidity" and "temp" columns + allowed.set = c(3,4) + if (degree > 1 && (all(allowed.set != pred) || any(parents[-allowed.set]))) + return(FALSE) + TRUE + } > a.Degree2OnlyHumidityAndTemp <- earth(O3 ~ ., data = ozone1, degree = 2, allowed = example.Degree2OnlyHumidityAndTemp) > printh(summary(a.Degree2OnlyHumidityAndTemp)) ===summary(a.Degree2OnlyHumidityAndTemp) Call: earth(formula=O3~., data=ozone1, degree=2, allowed=example.Degree2OnlyHumidityAndTemp) coefficients (Intercept) 13.4717045 h(5850-vh) -0.0142141 h(wind-6) -0.5690100 h(temp-58) 0.2832302 h(1105-ibh) -0.0029012 h(10-dpg) -0.0691576 h(dpg-10) -0.0903813 h(ibt-115) 0.0446509 h(200-vis) 0.0181357 h(96-doy) -0.1237491 h(doy-150) -0.0313603 h(55-humidity) * h(temp-58) -0.0173091 Selected 12 of 20 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, dpg, vis, doy, humidity, ibh, vh, ibt, wind Number of terms at each degree of interaction: 1 10 1 GCV 13.8999 RSS 3828.887 GRSq 0.7840813 RSq 0.8186686 > > ihumidity.global <- NA > itemp.global <- NA > example.Degree2OnlyHumidityAndTemp.First <- function(degree, pred, parents, namesx, first) + { + if (first) { + ihumidity.global <<- which(namesx == "humidity") # note use of <<- not <- + if (length(ihumidity.global) != 1) + stop("could not find humidity in ", paste(namesx, collapse=" ")) + itemp.global <<- which(namesx == "temp") # note use of <<- not <- + if (length(itemp.global) != 1) + stop("could not find temp in ", paste(namesx, collapse=" ")) + } + # allow only humidity and temp in terms of degree > 1 + allowed.set = c(ihumidity.global, itemp.global) + if (degree > 1 && + (all(allowed.set != pred) || any(parents[-allowed.set]))) + return(FALSE) + TRUE + } > a.Degree2OnlyHumidityAndTemp.First <- earth(O3 ~ ., data = ozone1, degree = 2, allowed = example.Degree2OnlyHumidityAndTemp) > check.models.equal(a.Degree2OnlyHumidityAndTemp, a.Degree2OnlyHumidityAndTemp.First, msg="\"allowed\" function a.Degree2OnlyHumidityAndTemp a.Degree2OnlyHumidityAndTemp.First", newdata=newdata.global) "allowed" function a.Degree2OnlyHumidityAndTemp a.Degree2OnlyHumidityAndTemp.First: models identical > > #--- no predictor in PREDICTORS is allowed to interact with any predictor in PARENTS > #--- but all other interactions are allowed > > PREDICTORS <- c("age") > PARENTS <- c("survived", "parch") > > example4 <- function(degree, pred, parents, namesx) + { + if (degree > 1) { + predictor <- namesx[pred] + parents <- namesx[parents != 0] + if((any(predictor %in% PREDICTORS) && any(parents %in% PARENTS)) || + (any(predictor %in% PARENTS) && any(parents %in% PREDICTORS))) { + return(FALSE) + } + } + TRUE + } > a4.allowed <- earth(sex~., data=etitanic, degree=2, allowed=example4) > printh(summary(a4.allowed)) ===summary(a4.allowed) Call: earth(formula=sex~., data=etitanic, degree=2, allowed=example4) coefficients (Intercept) 0.74841883 pclass3rd -0.44966704 survived -0.62673470 h(15-age) 0.03878154 pclass2nd * survived -0.16200218 pclass3rd * survived 0.31810348 pclass3rd * h(20-age) -0.02792432 pclass3rd * h(4-parch) 0.08607338 h(3-sibsp) * h(4-parch) 0.01835222 h(sibsp-3) * h(4-parch) 0.08911862 Selected 10 of 16 terms, and 6 of 6 predictors Termination condition: Reached nk 21 Importance: survived, parch, sibsp, pclass3rd, age, pclass2nd Number of terms at each degree of interaction: 1 3 6 GCV 0.1525303 RSS 152.4583 GRSq 0.3475741 RSq 0.3753665 > plotmo(a4.allowed, caption="a4.allowed") plotmo grid: pclass survived age sibsp parch 3rd 0 28 0 0 > > #--- predictors in PREDICTORS are allowed to interact with predictors in PARENTS > #--- but no other interactions are allowed > > PREDICTORS <- c("age") > PARENTS <- c("survived", "parch") > > example5 <- function(degree, pred, parents, namesx) + { + if (degree <= 1) + return(TRUE) + predictor <- namesx[pred] + parents <- namesx[parents != 0] + if((any(predictor %in% PREDICTORS) && any(parents %in% PARENTS)) || + (any(predictor %in% PARENTS) && any(parents %in% PREDICTORS))) { + return(TRUE) + } + FALSE + } > a5.allowed <- earth(sex~., data=etitanic, degree=2, allowed=example5) > printh(summary(a5.allowed)) ===summary(a5.allowed) Call: earth(formula=sex~., data=etitanic, degree=2, allowed=example5) coefficients (Intercept) 0.34721404 h(2-sibsp) 0.06347988 h(sibsp-2) 0.10099095 h(4-parch) 0.11453239 survived * h(age-15) 0.15093805 survived * h(age-11.5) -0.15199742 h(25-age) * h(4-parch) -0.00419678 Selected 7 of 17 terms, and 4 of 6 predictors Termination condition: Reached nk 21 Importance: survived, parch, age, sibsp, pclass2nd-unused, ... Number of terms at each degree of interaction: 1 3 3 GCV 0.1561245 RSS 158.3485 GRSq 0.3322006 RSq 0.3512343 > plotmo(a5.allowed, caption="a5.allowed") plotmo grid: pclass survived age sibsp parch 3rd 0 28 0 0 > > # "allowed" function checks, these check error handling by forcing an error > > expect.err(try(earth(Volume ~ ., data = trees, allowed = 99)), "argument is not a function") Error : your 'allowed' argument is not a function Got error as expected from try(earth(Volume ~ ., data = trees, allowed = 99)) > > example7 <- function(degree, pred) pred!=2 > expect.err(try(earth(Volume ~ ., data = trees, allowed = example7)), "function does not have the correct number of arguments") Error : your 'allowed' function does not have the correct number of arguments The 'allowed' function needs the following arguments (but namesx and first are optional): degree pred parents namesx first Got error as expected from try(earth(Volume ~ ., data = trees, allowed = example7)) > > expect.err(try(earth(Volume ~ ., data = trees, allowed = earth)), "your 'allowed' function does not have the correct number of arguments") Error : your 'allowed' function does not have the correct number of arguments The 'allowed' function needs the following arguments (but namesx and first are optional): degree pred parents namesx first Got error as expected from try(earth(Volume ~ ., data = trees, allowed = earth)) > > example8 <- function(degree, pred, parents99) pred!=2 > expect.err(try(earth(Volume ~ ., data = trees, allowed = example8)), "function needs the following arguments") Error : The 'allowed' function needs the following arguments (but namesx and first are optional): degree pred parents namesx first You have: degree pred parents99 Got error as expected from try(earth(Volume ~ ., data = trees, allowed = example8)) > > example9 <- function(degree, pred, parents, namesx99) pred!=2 > expect.err(try(earth(Volume ~ ., data = trees, allowed = example9)), "function needs the following arguments") Error : The 'allowed' function needs the following arguments (but namesx and first are optional): degree pred parents namesx first You have: degree pred parents namesx99 Got error as expected from try(earth(Volume ~ ., data = trees, allowed = example9)) > > source("test.epilog.R") earth/inst/slowtests/test.expand.bpairs.Rout.save0000644000176200001440000006271213451165124021737 0ustar liggesusers> # test.expand.bpairs.R: > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > # 5 cases (11 obs) > sex <- factor(c("m","f","f","f","f")) > pclass <- factor(c("1st", "2nd", "3rd", "3rd", "3rd")) > x.short <- data.frame(dose=1L:5L, + numericx=c(1.1,1.2,1.3,1.4,1.5), + logicalx=c(TRUE,FALSE,TRUE,FALSE,TRUE), + sex=sex, + pclass=pclass) > y.short <- data.frame(success=c(1,2,3,0,1), + fail =c(1,1,1,0,0)) > short <- data.frame(x.short, y.short) > x.short.unsorted <- x.short[nrow(x.short):1, ] > y.short.unsorted <- y.short[nrow(y.short):1, ] > short.unsorted <- data.frame(x.short.unsorted, y.short.unsorted) > long <- data.frame( + success =c( F, T, F, T, T, F, T, T, T, F, T), + dose =c( 1L, 1L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 4L, 5L), + numericx=c( 1.1, 1.1, 1.2, 1.2, 1.2, 1.3, 1.3, 1.3, 1.3, 1.4, 1.5), + logicalx=c( T, T, F, F, F, T, T, T, T, F, T), + sex =c( "m", "m", "f", "f", "f", "f", "f", "f", "f", "f", "f"), + pclass =c("1st","1st","2nd","2nd","2nd","3rd","3rd","3rd","3rd","3rd","3rd")) > bpairs.index <- c(1L, 3L, 6L, 10L, 11L) > ynames <- c("success", "fail") > > check.expanded.bpairs <- function(long.expanded, long.ref, bpairs.index.ref, ynames.ref) + { + stopifnot(rownames(long.expanded)[1] == "row1.1") # basic sanity check + # delete attributes so can check identical + stripped.long.expanded <- long.expanded + rownames(stripped.long.expanded) <- 1:nrow(long.expanded) + attr(stripped.long.expanded, "bpairs.index") <- NULL + attr(stripped.long.expanded, "ynames") <- NULL + if(!identical(stripped.long.expanded, long.ref)) { + printf("\nstripped.long.expanded:\n") + print(stripped.long.expanded) + printf("\nlong.ref:\n") + print(long.ref) + printf("\n") + + printf("class(long.expanded) '%s'\n", class(long.expanded)) + for(j in 1:ncol(long.expanded)) + printf("class(long.expanded[,%d] %s colname '%s'\n", + j, class(long.expanded[,j]), colnames(long.expanded)[j]) + printf("\n") + printf("class(long.ref) '%s'\n", class(long.ref)) + for(j in 1:ncol(long.ref)) + printf("class(long.ref[,%d] %s colname '%s'\n", + j, class(long.ref[,j]), colnames(long.ref)[j]) + printf("\n") + printf("attributes(stripped.long.expanded):\n") + print(attributes(stripped.long.expanded)) + printf("\n") + printf("attributes(long.ref):\n") + print(attributes(long.ref)) + printf("\n") + + stop("!identical(stripped.long.expanded, long.ref), see above prints") + } + stopifnot(identical(attr(long.expanded, "bpairs.index"), bpairs.index.ref)) + stopifnot(identical(attr(long.expanded, "ynames"), ynames.ref)) + } > cat("expand.bpairs(x.short, y.short)\n") expand.bpairs(x.short, y.short) > long.default <- expand.bpairs(x.short, y.short) Note: Both entries in row 4 of the success and fail response are zero > check.expanded.bpairs(long.default, long, bpairs.index, ynames) > > long.default.sort <- expand.bpairs(x.short.unsorted, y.short.unsorted, sort=TRUE) Note: Both entries in row 2 of the success and fail response are zero > attr(long.default.sort, "row.names") <- NULL > attr(long.default.sort, "ynames") <- NULL > long1 <- long > rownames(long1) <- NULL > attr(long1, "row.names") <- NULL > attr(long1, "bpairs.index") <- NULL > stopifnot(all.equal(long.default.sort, long1)) > > # single predictor "dose" > cat("expand.bpairs(expand.bpairs(short$dose, y.short)\n") expand.bpairs(expand.bpairs(short$dose, y.short) > long.default.dose <- expand.bpairs(short$dose, y.short) Note: Both entries in row 4 of the success and fail response are zero > colnames(long.default.dose)[2] <- "dose" # needed for check because above produces column name "x" > check.expanded.bpairs(long.default.dose, long[,c("success", "dose")], bpairs.index, ynames) > > # use a two element numeric vector to specify the y columns > cat("expand.bpairs(short.data.frame, c(6,7))\n") expand.bpairs(short.data.frame, c(6,7)) > short.data.frame <- data.frame(x.short, y.short) > long.colindex <- expand.bpairs(short.data.frame, c(6,7)) Note: Both entries in row 4 of the success and fail response are zero > check.expanded.bpairs(long.colindex, long, bpairs.index, ynames) > > # use a two element numeric vector to specify the y columns, single predictor "dose" > cat("expand.bpairs(short.data.frame.dose, c(2,3))\n") expand.bpairs(short.data.frame.dose, c(2,3)) > short.data.frame.dose <- data.frame(dose=x.short$dose, y.short) > long.default.dose <- expand.bpairs(short.data.frame.dose, c(2,3)) Note: Both entries in row 4 of the success and fail response are zero > check.expanded.bpairs(long.default.dose, long[,c("success", "dose")], bpairs.index, ynames) > > # use a two element character vector to specify the y columns > cat("expand.bpairs(short.data.frame, c(\"success\",\"fail\"))\n") expand.bpairs(short.data.frame, c("success","fail")) > short.data.frame <- data.frame(x.short, y.short) > long.charindex <- expand.bpairs(short.data.frame, c("success", "fail")) Note: Both entries in row 4 of the success and fail response are zero > check.expanded.bpairs(long.charindex, long, bpairs.index, ynames) > > # use a two element character vector to specify the y columns, single predictor "dose" > cat("expand.bpairs(short.data.frame.dose, c(2,3))\n") expand.bpairs(short.data.frame.dose, c(2,3)) > short.data.frame.dose <- data.frame(dose=x.short$dose, y.short) > long.default.charindex.dose <- expand.bpairs(short.data.frame.dose, c(2,3)) Note: Both entries in row 4 of the success and fail response are zero > check.expanded.bpairs(long.default.charindex.dose, long[,c("success", "dose")], bpairs.index, ynames) > > expect.err(try(expand.bpairs()), "expand.bpairs: no y argument") Error : expand.bpairs: no y argument The y argument should be one of: o Two column matrix or dataframe of binomial pairs. o Two-element numeric vector specifying the response columns in 'data'. o Two-element character vector specifying the response column names in 'data'. The full names must be used (partial matching isn't supported). Got error as expected from try(expand.bpairs()) > expect.err(try(expand.bpairs(short.data.frame.dose)), "expand.bpairs: no y argument") Error : expand.bpairs: no y argument The y argument should be one of: o Two column matrix or dataframe of binomial pairs. o Two-element numeric vector specifying the response columns in 'data'. o Two-element character vector specifying the response column names in 'data'. The full names must be used (partial matching isn't supported). Got error as expected from try(expand.bpairs(short.data.frame.dose)) > expect.err(try(expand.bpairs(short.data.frame.dose, c(2,3), nonesuch=99)), "expand.bpairs.default: unrecognized argument 'nonesuch'") Error : expand.bpairs.default: unrecognized argument 'nonesuch' Got error as expected from try(expand.bpairs(short.data.frame.dose, c(2, 3), nonesuch = 99)) > expect.err(try(expand.bpairs(short.data.frame, c(5,6))), "short.data.frame[,c(5,6)] is not a two-column matrix of binomial pairs") Error : expand.bpairs: short.data.frame[,c(5,6)] is not a two-column matrix of binomial pairs Got error as expected from try(expand.bpairs(short.data.frame, c(5, 6))) > expect.err(try(expand.bpairs(short.data.frame, 1)), "expand.bpairs: bad y argument '1'") Error : expand.bpairs: bad y argument '1' The y argument should be one of: o Two column matrix or dataframe of binomial pairs. o Two-element numeric vector specifying the response columns in 'data'. o Two-element character vector specifying the response column names in 'data'. The full names must be used (partial matching isn't supported). Got error as expected from try(expand.bpairs(short.data.frame, 1)) > expect.err(try(expand.bpairs(short.data.frame, c(1,2,3))), "bad y argument 'c(1, 2, 3)'") Error : expand.bpairs: bad y argument 'c(1, 2, 3)' The y argument should be one of: o Two column matrix or dataframe of binomial pairs. o Two-element numeric vector specifying the response columns in 'data'. o Two-element character vector specifying the response column names in 'data'. The full names must be used (partial matching isn't supported). Got error as expected from try(expand.bpairs(short.data.frame, c(1, 2, 3))) > expect.err(try(expand.bpairs(short.data.frame, c(1,2))), "expand.bpairs: short.data.frame[,c(1,2)] is not a two-column matrix of binomial pairs") print(head(y)): dose numericx 1 1 1.1 2 2 1.2 3 3 1.3 4 4 1.4 5 5 1.5 Response has two columns but is not a binomial pair because not all values are integers Error : expand.bpairs: short.data.frame[,c(1,2)] is not a two-column matrix of binomial pairs Got error as expected from try(expand.bpairs(short.data.frame, c(1, 2))) > expect.err(try(expand.bpairs(short.data.frame, c(99,100))), "'ycolumns' is out of range, allowed values are 1 to 7") Error : 'ycolumns' is out of range, allowed values are 1 to 7 Got error as expected from try(expand.bpairs(short.data.frame, c(99, 100))) > expect.err(try(expand.bpairs(short.data.frame, c("success99", "fail"))), "undefined columns selected") Warning: "success99" in ycolumns does not match any names Available names are "dose" "numericx" "logicalx" "sex" "pclass" "success" "fail" Error in `[.data.frame`(data, , ycolumns, drop = FALSE) : undefined columns selected Got error as expected from try(expand.bpairs(short.data.frame, c("success99", "fail"))) > expect.err(try(expand.bpairs(short.data.frame, c("nonesuch", "fail"))), "undefined columns selected") Warning: "nonesuch" in ycolumns does not match any names Available names are "dose" "numericx" "logicalx" "sex" "pclass" "success" "fail" Error in `[.data.frame`(data, , ycolumns, drop = FALSE) : undefined columns selected Got error as expected from try(expand.bpairs(short.data.frame, c("nonesuch", "fail"))) > expect.err(try(expand.bpairs(short.data.frame, "nonesuch")), "bad y argument 'nonesuch'") Error : expand.bpairs: bad y argument 'nonesuch' The y argument should be one of: o Two column matrix or dataframe of binomial pairs. o Two-element numeric vector specifying the response columns in 'data'. o Two-element character vector specifying the response column names in 'data'. The full names must be used (partial matching isn't supported). Got error as expected from try(expand.bpairs(short.data.frame, "nonesuch")) > expect.err(try(expand.bpairs(short.data.frame, nonesuch)), "object 'nonesuch' not found") Error in expand.bpairs.default(short.data.frame, nonesuch) : object 'nonesuch' not found Got error as expected from try(expand.bpairs(short.data.frame, nonesuch)) > options(warn=2) > expect.err(try(expand.bpairs(short.data.frame, c("nonesuch", "fail"))), "\"nonesuch\" in ycolumns does not match any names") Error : (converted from warning) "nonesuch" in ycolumns does not match any names Available names are "dose" "numericx" "logicalx" "sex" "pclass" "success" "fail" Got error as expected from try(expand.bpairs(short.data.frame, c("nonesuch", "fail"))) > expect.err(try(expand.bpairs(short.data.frame, c("fail", "nonesuch99"))), "\"nonesuch99\" in ycolumns does not match any names") Error : (converted from warning) "nonesuch99" in ycolumns does not match any names Available names are "dose" "numericx" "logicalx" "sex" "pclass" "success" "fail" Got error as expected from try(expand.bpairs(short.data.frame, c("fail", "nonesuch99"))) > expect.err(try(expand.bpairs(short.data.frame, c("", "fail"))), "ycolumns[1] is an empty string \"\"") Error : (converted from warning) ycolumns[1] is an empty string "" Got error as expected from try(expand.bpairs(short.data.frame, c("", "fail"))) > expect.err(try(expand.bpairs(short.data.frame, c("success", ""))), "ycolumns[2] is an empty string \"\"") Error : (converted from warning) ycolumns[2] is an empty string "" Got error as expected from try(expand.bpairs(short.data.frame, c("success", ""))) > options(warn=1) > try(expand.bpairs(short.data.frame, c("success", ""))) # check error messages that are issued after the warning Warning: ycolumns[2] is an empty string "" Warning: "" in ycolumns does not match any names Available names are "dose" "numericx" "logicalx" "sex" "pclass" "success" "fail" Error in `[.data.frame`(data, , ycolumns, drop = FALSE) : undefined columns selected > > # formula > cat("expand.bpairs(success.fail~., data=x.short)\n") expand.bpairs(success.fail~., data=x.short) > success.fail <- cbind(success=short$success, fail=short$fail) > long.formula.matrix <- expand.bpairs(success.fail~., data=x.short) Note: Both entries in row 4 of the success and fail response are zero > check.expanded.bpairs(long.formula.matrix, long, bpairs.index, ynames) > > cat("expand.bpairs(success+fail~., data=x.short)\n") expand.bpairs(success+fail~., data=x.short) > xy.short <- data.frame(y.short, x.short) > long.formula <- expand.bpairs(success+fail~., data=xy.short) Note: Both entries in row 4 of the success and fail response are zero > check.expanded.bpairs(long.formula, long, bpairs.index, ynames) > > long.formula.sort <- expand.bpairs(x.short, y.short, sort=TRUE) Note: Both entries in row 4 of the success and fail response are zero > long.formula.sort <- expand.bpairs(x.short.unsorted, y.short.unsorted, sort=TRUE) Note: Both entries in row 2 of the success and fail response are zero > attr(long.formula.sort, "row.names") <- NULL > attr(long.formula.sort, "ynames") <- NULL > long1 <- long > rownames(long1) <- NULL > attr(long1, "row.names") <- NULL > attr(long1, "bpairs.index") <- NULL > stopifnot(all.equal(long.formula.sort, long1)) > > expand.bpairs(success+fail+fail~., data=xy.short) # ok, duplicated name gets dropped Note: Both entries in row 4 of the success and fail response are zero success dose numericx logicalx sex pclass row1.1 FALSE 1 1.1 TRUE m 1st row1.2 TRUE 1 1.1 TRUE m 1st row2.1 FALSE 2 1.2 FALSE f 2nd row2.2 TRUE 2 1.2 FALSE f 2nd row2.3 TRUE 2 1.2 FALSE f 2nd row3.1 FALSE 3 1.3 TRUE f 3rd row3.2 TRUE 3 1.3 TRUE f 3rd row3.3 TRUE 3 1.3 TRUE f 3rd row3.4 TRUE 3 1.3 TRUE f 3rd row4.1 FALSE 4 1.4 FALSE f 3rd row5.1 TRUE 5 1.5 TRUE f 3rd > expect.err(try(expand.bpairs(success~., data=xy.short)), "expand.bpairs: 'success' does not have two columns") Error : expand.bpairs: 'success' does not have two columns Got error as expected from try(expand.bpairs(success ~ ., data = xy.short)) > expect.err(try(expand.bpairs(success+success~., data=xy.short)), "expand.bpairs: 'success + success' does not have two columns") Error : expand.bpairs: 'success + success' does not have two columns Got error as expected from try(expand.bpairs(success + success ~ ., data = xy.short)) > > cat("expand.bpairs(success.fail~., data=x.short)\n") expand.bpairs(success.fail~., data=x.short) > success.fail <- cbind(success=short$success, fail=short$fail) > long.formula.matrix <- expand.bpairs(success.fail~., data=x.short) Note: Both entries in row 4 of the success and fail response are zero > check.expanded.bpairs(long.formula.matrix, long, bpairs.index, ynames) > > # TODO it's a pity the following doesn't work (issue is in model.frame.default) > cat("expand.bpairs(data.frame(success.fail)~., data=x.short)\n") expand.bpairs(data.frame(success.fail)~., data=x.short) > expect.err(try(expand.bpairs(data.frame(success.fail)~., data=x.short)), "invalid type (list) for variable 'data.frame(success.fail)'") Error in model.frame.default(terms(formula, lhs = lhs, rhs = rhs, data = data, : invalid type (list) for variable 'data.frame(success.fail)' Got error as expected from try(expand.bpairs(data.frame(success.fail) ~ ., data = x.short)) > > # formula, single predictor "dose" > cat("expand.bpairs(expand.bpairs(success+fail~dose, data=xy.short)\n") expand.bpairs(expand.bpairs(success+fail~dose, data=xy.short) > long.formula.dose <- expand.bpairs(success+fail~dose, data=xy.short) Note: Both entries in row 4 of the success and fail response are zero > check.expanded.bpairs(long.formula.dose, long[,c("success", "dose")], bpairs.index, ynames) > > trues <- xy.short$success > falses <- xy.short$fail > cat("expand.bpairs(expand.bpairs(trues+falses~dose, data=x.short)\n") expand.bpairs(expand.bpairs(trues+falses~dose, data=x.short) > long.formula.dose <- expand.bpairs(trues+falses~~dose, data=xy.short) Note: Both entries in row 4 of the trues and falses response are zero > stopifnot(identical(colnames(long.formula.dose), c("trues", "dose"))) > colnames(long.formula.dose) <- c("success", "dose") > attr(long.formula.dose, "ynames") <- c("success", "fail") > check.expanded.bpairs(long.formula.dose, long[,c("success", "dose")], bpairs.index, ynames) > > cat("expand.bpairs(expand.bpairs(trues+falses~., data=x.short)\n") expand.bpairs(expand.bpairs(trues+falses~., data=x.short) > long.formula <- expand.bpairs(trues+falses~., data=xy.short) Note: Both entries in row 4 of the trues and falses response are zero > stopifnot(identical(colnames(long.formula), c("trues", "success", "fail", "dose", "numericx", "logicalx", "sex", "pclass"))) > > cat("expand.bpairs(expand.bpairs(success.fail~dose, data=x.short)\n") expand.bpairs(expand.bpairs(success.fail~dose, data=x.short) > long.formula.dose <- expand.bpairs(success.fail~dose, data=x.short) Note: Both entries in row 4 of the success and fail response are zero > check.expanded.bpairs(long.formula.dose, long[,c("success", "dose")], bpairs.index, ynames) > > cat("expand.bpairs(expand.bpairs(success.fail~dose, data=xy.short)\n") expand.bpairs(expand.bpairs(success.fail~dose, data=xy.short) > long.formula.dose <- expand.bpairs(success.fail~dose, data=xy.short) Note: Both entries in row 4 of the success and fail response are zero > check.expanded.bpairs(long.formula.dose, long[,c("success", "dose")], bpairs.index, ynames) > > x.short.na <- x.short > x.short.na$dose[3] <- NA > long.na <- long > long.na$dose[6:9] <- NA > # formula with NAs in data > cat("expand.bpairs(success.fail~., data=x.short.na)\n") expand.bpairs(success.fail~., data=x.short.na) > long.formula.na <- expand.bpairs(success.fail~., data=x.short.na) Note: Both entries in row 4 of the success and fail response are zero > check.expanded.bpairs(long.formula.na, long.na, bpairs.index, ynames) > > # formula with NAs in data, single predictor "dose" > cat("expand.bpairs(success.fail~dose., data=x.short.na)\n") expand.bpairs(success.fail~dose., data=x.short.na) > long.formula.dose.na <- expand.bpairs(success.fail~dose, data=x.short.na) Note: Both entries in row 4 of the success and fail response are zero > check.expanded.bpairs(long.formula.dose.na, long.na[,c("success", "dose")], bpairs.index, ynames) > > expect.err(try(expand.bpairs(nonesuch~., data=x.short)), "object 'nonesuch' not found") Error in eval(predvars, data, env) : object 'nonesuch' not found Got error as expected from try(expand.bpairs(nonesuch ~ ., data = x.short)) > expect.err(try(expand.bpairs(dose~., data=x.short)), "'dose' does not have two columns") Error : expand.bpairs: 'dose' does not have two columns Got error as expected from try(expand.bpairs(dose ~ ., data = x.short)) > expect.err(try(expand.bpairs(dose~success.fail, data=x.short)), "'dose' does not have two columns") Error : expand.bpairs: 'dose' does not have two columns Got error as expected from try(expand.bpairs(dose ~ success.fail, data = x.short)) > > # # # check Warning: dropping column 'success' from x because it matches a column name in y > # # TODO Removed because we (intentionally) no longer give a warning > long.formula <- expand.bpairs(success.fail~., data=xy.short) Note: Both entries in row 4 of the success and fail response are zero > check.expanded.bpairs(long.formula, long, bpairs.index, ynames) > # options(warn=2) > # # expect.err(try(expand.bpairs(success.fail~., data=xy.short)), "(converted from warning) dropping column 'success' from x because it matches a column name in y") > # # options(warn=1) > long.formula.dose <- expand.bpairs(success.fail~dose, data=xy.short) Note: Both entries in row 4 of the success and fail response are zero > check.expanded.bpairs(long.formula.dose, long[,c("success", "dose")], bpairs.index, ynames) > > old.success.fail <- success.fail > success.fail <- 99 > expect.err(try(expand.bpairs(success.fail~., data=xy.short)), "variable lengths differ (found for 'success')") Error in model.frame.default(terms(formula, lhs = lhs, rhs = rhs, data = data, : variable lengths differ (found for 'success') Got error as expected from try(expand.bpairs(success.fail ~ ., data = xy.short)) > success.fail <- old.success.fail > > # example with short data as a matrix (not a data.frame) > short <- matrix(c( 5, 2, 2, 9, 5, 9, + 20,20,30,20,20,30), ncol=2) > colnames(short) <- c("dose", "temp") > success.fail <- matrix(c(1,2,0,2,2,0, + 3,3,1,0,1,0), ncol=2) > long <- matrix(c( + 0, 5, 20, + 0, 5, 20, + 0, 5, 20, + 1, 5, 20, + + 0, 2, 20, + 0, 2, 20, + 0, 2, 20, + 1, 2, 20, + 1, 2, 20, + + 0, 2, 30, + + 1, 9, 20, + 1, 9, 20, + + 0, 5, 20, + 1, 5, 20, + 1, 5, 20, + + 0, 9, 30), # both rows zero in short data, so treat as a "false", + ncol=3, byrow=TRUE) > colnames(long) <- c("V1", "dose", "temp") > long <- as.data.frame(long) > bpairs.index <- c(1L, 5L, 10L, 11L, 13L, 16L) > ynames <- c("V1", "V2") > > long.default <- expand.bpairs(short, success.fail) Note: Both entries in row 6 of the V1 and V2 response are zero > long.default$V1 <- as.numeric(long.default$V1) # convert TRUE/FALSE to 0/1 > check.expanded.bpairs(long.default, long, bpairs.index, ynames) > # man page for expand.bpairs > example(expand.bpairs) expnd.> survived <- c(3,2,1,1) # short data for demo (too short to build a real model) expnd.> died <- c(0,1,2,2) expnd.> dose <- c(10,10,20,20) expnd.> sex <- factor(c("male", "female", "male", "female")) expnd.> short.data <- data.frame(survived, died, dose, sex) expnd.> expand.bpairs(survived + died ~ ., short.data) # returns long form of the data survived dose sex row1.1 TRUE 10 male row1.2 TRUE 10 male row1.3 TRUE 10 male row2.1 FALSE 10 female row2.2 TRUE 10 female row2.3 TRUE 10 female row3.1 FALSE 20 male row3.2 FALSE 20 male row3.3 TRUE 20 male row4.1 FALSE 20 female row4.2 FALSE 20 female row4.3 TRUE 20 female expnd.> # expand.bpairs(data=short.data, y=cbind(survived, died)) # equivalent expnd.> # expand.bpairs(short.data, c(1,2)) # equivalent expnd.> # expand.bpairs(short.data, c("survived", "died")) # equivalent expnd.> expnd.> # For example models, see the earth vignette expnd.> # section "Short versus long binomial data". expnd.> expnd.> expnd.> > # man page for expand.bpairs, do it manually and check > survived <- c(3,2,1,1) > died <- c(0,1,2,2) > dose <- c(10,10,20,20) > sex <- factor(c("male", "female", "male", "female")) > short.data <- data.frame(survived, died, dose, sex) > long.data <- expand.bpairs(survived + died ~ ., short.data) # returns long form of the data > print(long.data) survived dose sex row1.1 TRUE 10 male row1.2 TRUE 10 male row1.3 TRUE 10 male row2.1 FALSE 10 female row2.2 TRUE 10 female row2.3 TRUE 10 female row3.1 FALSE 20 male row3.2 FALSE 20 male row3.3 TRUE 20 male row4.1 FALSE 20 female row4.2 FALSE 20 female row4.3 TRUE 20 female > stopifnot(identical(expand.bpairs(data=short.data, y=cbind(survived, died)), long.data)) # equivalent > stopifnot(identical(expand.bpairs(short.data, c(1,2)), long.data)) # equivalent > stopifnot(identical(expand.bpairs(short.data, c("survived", "died")), long.data)) # equivalent > pairs(short.data, main="short.data") > pairs(long.data, main="long.data") > > # test without column names > short.unsorted.nocolnames <- short.unsorted > colnames(short.unsorted.nocolnames) <- NULL > temp <- expand.bpairs(short.unsorted, 6:7) Note: Both entries in row 2 of the success and fail response are zero > temp.nocolnames <- expand.bpairs(short.unsorted.nocolnames, 6:7) Note: Both entries in row 2 of the y[,1] and y[,2] response are zero > stopifnot(all.equal(colnames(temp.nocolnames), c("true", "X1", "X2", "X3", "X4", "X5"))) > colnames(temp.nocolnames) <- colnames(temp) > attr(temp, "ynames") <- NULL > stopifnot(identical(temp.nocolnames, temp)) > > source("test.epilog.R") earth/inst/slowtests/test.pmethod.cv.R0000644000176200001440000001043713403043445017556 0ustar liggesusers# test.pmethod.cv.R: example pmethod.cv model built by earth # Stephen Milborrow May 2015 Berea source("test.prolog.R") library(earth) data(etitanic) options(digits=4) printf <- function(format, ...) cat(sprint(format, ...)) # like c printf cat("\npmethod=cv with formula interface\n\n") par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0), oma=c(0,0,2,0)) # following is so we can directly compare pmethod=back to pmethod=cv set.seed(2) a100.form <- earth(survived ~ ., data=etitanic, degree=2, trace=0, pmethod="back", nfold=2, ncross=2, keepxy=TRUE) cat("print(a100.form)\n") print(a100.form) plot(a100.form, which=1, legend.cex=.5, main="a100.form: pmethod=\"back\"", cex.main=.8, caption="formula interface") set.seed(2) cat("\n") a101.form <- earth(survived ~ ., data=etitanic, degree=2, trace=1, pmethod="cv", nfold=2, ncross=3) cat("\nprint(a101.form)\n") print(a101.form) cat("\nprint(summary(a101.form))\n") print(summary(a101.form)) plot(a101.form, which=1, legend.cex=.5, main="a101.form: pmethod=\"cv\"", cex.main=.8) # multiple response model set.seed(2015) a102.form <- earth(pclass ~ ., data=etitanic, degree=2, pmethod="cv", nfold=3) cat("\nprint(a102.form)\n") print(a102.form) cat("\nprint(summary(a102.form))\n") print(summary(a102.form)) plot(a102.form, which=1, nresponse=1, main="a102.form: pmethod=\"cv\" multiple response", cex.main=.8) # multiple response model # following is useful because the model selected by cv is same as that selected by gcv set.seed(1) # don't change a103.form <- earth(pclass ~ ., data=etitanic, degree=2, pmethod="cv", nfold=3, nprune=10) cat("\nprint(a103.form)\n") print(a103.form) plot(a103.form, which=1, nresponse=1, main="a103.form: pmethod=\"cv\" multiple response\nmax(GRSq) == which.max(mean.oof.rsq)", cex.main=.8) # test cv with nprune less than what would be normally selected set.seed(1) a104.form <- earth(pclass ~ ., data=etitanic, degree=2, pmethod="cv", nfold=3, nprune=8) cat("\nprint(a104.form)\n") print(a104.form) plot(a104.form, which=1, nresponse=1, grid=T, main="a104.form: pmethod=\"cv\" nprune=10", cex.main=.8) cat("\n\npmethod=cv with x,y interface\n\n") par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0), oma=c(0,0,3,0)) etitanic.except.survived <- etitanic[,c(1,3,4,5,6)] survived <- etitanic$survived # # following is so we can directly compare pmethod=back to pmethod=cv # # commented out because already done above with model a100.formula # set.seed(2) # a100.xy <- earth(etitanic.except.survived, survived, degree=2, trace=0, pmethod="back", nfold=2, ncross=2, keepxy=TRUE) # cat("\nprint(a100.xy)\n") # print(a100.xy) # plot(a100.xy, which=1, legend.cex=.5, main="a100.xy: pmethod=\"back\"", cex.main=.8) set.seed(2) a101.xy <- earth(etitanic.except.survived, survived, degree=2, trace=1, pmethod="cv", nfold=2, ncross=2) cat("\nprint(a101.xy)\n") print(a101.xy) cat("\nprint(summary(a101.xy)\n") print(summary(a101.xy)) plot(a101.xy, which=1, legend.cex=.5, main="a101.xy: pmethod=\"cv\"", cex.main=.8, caption="x,y interface") # a101.form # a102.xy # multiple response model x.except.pclass <- etitanic[,c(2,3,4,5,6)] pclass <- etitanic$pclass set.seed(2015) a102.xy <- earth(x.except.pclass, pclass, degree=2, pmethod="cv", nfold=3) cat("\nprint(a102.xy)\n") print(a102.xy) plot(a102.xy, which=1, nresponse=1, main="a102.xy: pmethod=\"cv\" multiple response", cex.main=.8) # multiple response model # following is useful because the model selected by cv is same as that selected by gcv set.seed(1) # don't change a103.xy <- earth(x.except.pclass, pclass, degree=2, pmethod="cv", nfold=3, nprune=10) cat("\nprint(a103.xy)\n") print(a103.xy) cat("\nprint(summary(a103.xy)\n") print(summary(a103.xy)) plot(a103.xy, which=1, nresponse=1, main="a103.xy: pmethod=\"cv\" multiple response\nmax(GRSq) == which.max(mean.oof.rsq)", cex.main=.8) # test cv with nprune less than what would be normally selected set.seed(1) a104.xy <- earth(x.except.pclass, pclass, degree=2, pmethod="cv", nfold=3, nprune=8) cat("\nprint(a104.xy)\n") print(a104.xy) plot(a104.xy, which=1, nresponse=1, grid=T, main="a104.xy: pmethod=\"cv\" nprune=10", cex.main=.8) source("test.epilog.R") earth/inst/slowtests/test.mem.Rout.save0000644000176200001440000002376013561363660017766 0ustar liggesusers> # test.mem.R: test earth C code memory usage under both normal and error conditions > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > > # the data we will build the models on > ncases <- 10 > x <- matrix(1:ncases, ncol=1) > colnames(x) <- "x" > max <- max(x) > y <- sin(3 * x / max(x)) > colnames(y) <- "y" > > nmodels <- 5 > nlm <- double(length=nmodels) # mem used for each lm model > nstandardearth <- double(length=nmodels) # mem used for each earth model > ngoodallowed <- double(length=nmodels) > nbadallowed <- double(length=nmodels) > nbadendspan <- double(length=nmodels) > > max.mem.change <- function(mem.start, gc.start) + { + mem <- memory.size() # MBytes (on non windows platforms, will always be Inf) + gc <- gc(full=TRUE) # returns cells left after garbage collection + # max(abs(mem - mem.start), + # abs(gc[1,1] - gc.start[1,1]), # Ncells + # abs(gc[2,1] - gc.start[2,1])) # Vcells + mem <- abs(mem - mem.start) + ncells <- abs(gc[1,1] - gc.start[1,1]) + vcells <- abs(gc[2,1] - gc.start[2,1]) + printf("mem %g ncells %g vcells %g\n", mem, ncells, vcells) + max(mem, ncells, vcells) + } > plotmem <- function(nlm, nstandardearth, ngoodallowed, nbadallowed, nbadendspan) + { + min <- min(nlm, nstandardearth, ngoodallowed, nbadallowed, nbadendspan) + max <- max(nlm, nstandardearth, ngoodallowed, nbadallowed, nbadendspan) + min <- min - 1 + max <- max + 3 + yjitter <- (max - min) / 130 # minimize overplotting + + # in the graphs, lines should be horizontal (at least after the first iter) + # if a line increases after the first iter, it means that memory is not being released + plot( 1:nmodels, nlm, type="l", main="memory used by each model", + xlab="nmodels", ylab="memory change", ylim=c(min, max)) + lines(1:nmodels, nstandardearth + 1 * yjitter, col=2) + lines(1:nmodels, ngoodallowed + 2 * yjitter, col=3) + lines(1:nmodels, nbadallowed + 3 * yjitter, col=1, lty=2) + lines(1:nmodels, nbadendspan + 4 * yjitter, col=2, lty=2) + + legend(x="topright", bg="white", + legend=c("lm", "standardearth", "goodallowed", "badallowed", "badendspan"), + lty=c(1,1,1,2,2), + col=c(1,2,3,1,2)) + } > good.allowedfunc <- function(degree, pred, parents, namesx, first) + { + pred != 999 + } > bad.allowedfunc <- function(degree, pred, parents, namesx, first) + { + # this stop is silent because call earth using try(..., silent=TRUE) + stop("early exit from bad.allowedfunc") + } > cat("initial redundant run of lm\n") # else initial nlm very large initial redundant run of lm > # (probably because some function is allocating a static buffer) > print(summary(lm(y~x))) Call: lm(formula = y ~ x) Residuals: Min 1Q Median 3Q Max -0.45497 -0.17062 0.06399 0.23525 0.32264 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 0.76940 0.21312 3.61 0.00688 ** x -0.01891 0.03435 -0.55 0.59701 --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.312 on 8 degrees of freedom Multiple R-squared: 0.0365, Adjusted R-squared: -0.08394 F-statistic: 0.303 on 1 and 8 DF, p-value: 0.597 > for(i in 0:nmodels) { + try(lm(y~x), silent=FALSE) + gc <- gc(full=TRUE) + if(i <= 0) { + mem.start <- memory.size() + gc.start <- gc(full=TRUE) + } else + nlm[i] <- max.mem.change(mem.start, gc.start) + } mem 5.39 ncells 20 vcells 30 mem 5.21 ncells 1585 vcells 3675 mem 5.37 ncells 1785 vcells 4255 mem 5.37 ncells 1785 vcells 4255 mem 5.37 ncells 1785 vcells 4255 > cat("actual run of lm\n") actual run of lm > # We use 0:nmodels, because we build the first model at iter 0, > # but don't save results from iter 0 (i.e. we the ignore first model). > # This is because the first model sometimes leaves some memory allocated (why?). > print(summary(lm(y~x))) Call: lm(formula = y ~ x) Residuals: Min 1Q Median 3Q Max -0.45497 -0.17062 0.06399 0.23525 0.32264 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 0.76940 0.21312 3.61 0.00688 ** x -0.01891 0.03435 -0.55 0.59701 --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.312 on 8 degrees of freedom Multiple R-squared: 0.0365, Adjusted R-squared: -0.08394 F-statistic: 0.303 on 1 and 8 DF, p-value: 0.597 > for(i in 0:nmodels) { + try(lm(y~x), silent=FALSE) + gc <- gc(full=TRUE) + if(i <= 0) { + mem.start <- memory.size() + gc.start <- gc(full=TRUE) + } else + nlm[i] <- max.mem.change(mem.start, gc.start) + } mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 > # standard earth model > cat("earth(y~x)\n") earth(y~x) > print(summary(earth(y~x))) Call: earth(formula=y~x) coefficients (Intercept) 1.1315971 h(5-x) -0.1980423 h(x-5) -0.1787669 Selected 3 of 3 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: x Number of terms at each degree of interaction: 1 2 (additive model) GCV 0.01888444 RSS 0.0472111 GRSq 0.8107224 RSq 0.941581 > for(i in 0:nmodels) { + try(earth(y~x), silent=FALSE) + gc <- gc(full=TRUE) + if(i <= 0) { + mem.start <- memory.size() + gc.start <- gc(full=TRUE) + } else + nstandardearth[i] <- max.mem.change(mem.start, gc.start) + } mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 > # earth model with an allowed func > cat("earth(y~x, allowed = good.allowedfunc)\n") earth(y~x, allowed = good.allowedfunc) > print(summary(earth(y~x, allowed = good.allowedfunc))) Call: earth(formula=y~x, allowed=good.allowedfunc) coefficients (Intercept) 1.1315971 h(5-x) -0.1980423 h(x-5) -0.1787669 Selected 3 of 3 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: x Number of terms at each degree of interaction: 1 2 (additive model) GCV 0.01888444 RSS 0.0472111 GRSq 0.8107224 RSq 0.941581 > for(i in 0:nmodels) { + try(earth(y~x, allowed = good.allowedfunc), silent=FALSE) + gc <- gc(full=TRUE) + if(i <= 0) { + mem.start <- memory.size() + gc.start <- gc(full=TRUE) + } else + ngoodallowed[i] <- max.mem.change(mem.start, gc.start) + } mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 > # try earth model with an allowed func which causes an error > cat("earth(y~x, allowed = bad.allowedfunc)\n") earth(y~x, allowed = bad.allowedfunc) > expect.err(try(earth(y~x, allowed = bad.allowedfunc), silent=FALSE), "early exit from bad.allowedfunc") Error in (function (degree, pred, parents, namesx, first) : early exit from bad.allowedfunc Got error as expected from try(earth(y ~ x, allowed = bad.allowedfunc), silent = FALSE) > for(i in 0:nmodels) { + try(earth(y~x, allowed = bad.allowedfunc), silent=TRUE) + gc <- gc(full=TRUE) + if(i <= 0) { + mem.start <- memory.size() + gc.start <- gc(full=TRUE) + } else + nbadallowed[i] <- max.mem.change(mem.start, gc.start) + } mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 > # try earth model with an arg that causes error in ForwardPass in earth.c > cat("earth(y~x, Adjust.endspan = -999\n") earth(y~x, Adjust.endspan = -999 > expect.err(try(earth(y~x, Adjust.endspan = -999), silent=FALSE), "Adjust.endspan is -999 but should be between 0 and 10") Error in forward.pass(x, y, yw, weights, trace, degree, penalty, nk, thresh, : Adjust.endspan is -999 but should be between 0 and 10 Got error as expected from try(earth(y ~ x, Adjust.endspan = -999), silent = FALSE) > for(i in 0:nmodels) { + try(earth(y~x, Adjust.endspan = -999), silent=TRUE) + gc <- gc(full=TRUE) + if(i <= 0) { + mem.start <- memory.size() + gc.start <- gc(full=TRUE) + } else + nbadendspan[i] <- max.mem.change(mem.start, gc.start) + } mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 mem 0 ncells 9 vcells 1 > cat("nlm "); print(nlm) nlm [1] 9 9 9 9 9 > cat("nstandardearth"); print(nstandardearth) nstandardearth[1] 9 9 9 9 9 > cat("ngoodallowed "); print(ngoodallowed) ngoodallowed [1] 9 9 9 9 9 > cat("nbadallowed "); print(nbadallowed) nbadallowed [1] 9 9 9 9 9 > cat("nbadendspan "); print(nbadendspan) nbadendspan [1] 9 9 9 9 9 > > # printf("\n Min 1stQ Median Mean 3rdQ Max\n") > # printf("lm %s\n", paste0(sprintf("% 10.3f", summary(nlm)), collapse=" ")) > # printf("standardearth %s\n", paste0(sprintf("% 10.3f", summary(nstandardearth)), collapse=" ")) > # printf("goodallowed %s\n", paste0(sprintf("% 10.3f", summary(ngoodallowed)), collapse=" ")) > # printf("badallowed %s\n", paste0(sprintf("% 10.3f", summary(nbadallowed)), collapse=" ")) > # printf("badendspan %s\n", paste0(sprintf("% 10.3f", summary(nbadendspan)), collapse=" ")) > > # plot the data we are modeling > plot(1:nrow(x), y, type="b", pch=20, xlab="x", main="the data we are modeling") > > # plot memory used for each model > plotmem(nlm, nstandardearth, ngoodallowed, nbadallowed, nbadendspan) > > source("test.epilog.R") earth/inst/slowtests/test.big.Rout.save0000644000176200001440000002345013451164674017747 0ustar liggesusers> # test.big: test earth with a biggish model > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > options(digits=3) > > p <- 100 > n <- 20000 # big enough to cross ten-thousand-cases barrier in plotres and plotmo > > # p <- 100; n <- 10e6 # earth 4.4.0: Error in forward.pass: Out of memory (could not allocate 15 GB) > # ok with nk=21, 42 minutes to build model > # earth 4.6.3: Stopped after two hours, much memory paging > > # p <- 100; n <- 9e6 # windows 64 bit system, 2.9 GHz i7, 32 gig ram, SSD drive: > # earth 4.4.0: Out of memory (could not allocate 15 GB) > # earth 4.6.3: ok (earth now uses .Call instead of .C to invoke ForwardPassR) > # 55 mins to build model > > # p <- 100; n <- 8e6 # 51 minutes to build model, additional 1.5 minutes for plotmo and plotres > > # p <- 2; n <- 60e6 # ok > > # p <- 2; n <- 80e6 # ok (but not enough memory to get leverages) > # # 18 minutes to build model, additional 8 minutes for plotmo and plotres > # > # p <- 2; n <- 100e6 # earth 4.6.3: thrashes, interupted after a few hours > # # earth 4.4.0 Error in leaps.setup: Reached total allocation of 32673Mb > # # ok with nk=11, not so much thrashing, 10 minutes > > cat("creating x\n") creating x > ran <- function() runif(n, min=-1, max=1) > x <- matrix(ran(), ncol=1) > if(p >= 2) + x <- cbind(x, ran()) > if(p >= 3) + x <- cbind(x, ran()) > if(p >= 4) { + # xran saves time generating x, ok because func uses only columns x1, x2, and x3 + xran <- ran() + x <- cbind(x, matrix(xran, nrow=n, ncol=p-3)) + } > colnames(x) <- paste("x", 1:ncol(x), sep="") > func <- function(x) # additive, no interactions + { + y <- sin(4 * x[,1]) + if(p > 1) + y <- y + x[,2] + if(p > 2) + y <- y + 2 * x[,3]^2 - 1 + y + } > cat("creating y\n") creating y > y <- func(x) > cat("testing memory handling when an error (Adjust.endspan = -999)\n") testing memory handling when an error (Adjust.endspan = -999) > dummy.allowed <- function(degree, pred, parents) TRUE > expect.err(try(earth(x, y, trace=1.5, allowed=dummy.allowed, Adjust.endspan = -999)), "Adjust.endspan is -999 but should be between 0 and 10") x[20000,100] with colnames x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x1... y[20000,1] with colname y, and values 0.7958, 0.4044, -2.497, -1.05... maxmem 0.1 GB malloc 400 B: nUses nPreds 100 sizeof(int) 4 malloc 804 B: nDegree nMaxTerms 201 sizeof(int) 4 calloc 4 B: iDirs nMaxTerms 201 nPreds 100 sizeof(int) 4 malloc 804 B: BoolFullSet nMaxTerms 201 sizeof(bool) 4 malloc 800 B: sPredNames LENGTH(SEXP_sPredNames) 100 sizeof(char*) 8 FreeEarth Error in forward.pass(x, y, yw, weights, trace, degree, penalty, nk, thresh, : Adjust.endspan is -999 but should be between 0 and 10 Got error as expected from try(earth(x, y, trace = 1.5, allowed = dummy.allowed, Adjust.endspan = -999)) > cat("calling earth\n") calling earth > start.time <- proc.time() > a <- earth(x, y, degree=1, trace=1.5) x[20000,100] with colnames x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x1... y[20000,1] with colname y, and values 0.7958, 0.4044, -2.497, -1.05... maxmem 0.1 GB malloc 400 B: nUses nPreds 100 sizeof(int) 4 malloc 804 B: nDegree nMaxTerms 201 sizeof(int) 4 calloc 4 B: iDirs nMaxTerms 201 nPreds 100 sizeof(int) 4 malloc 804 B: BoolFullSet nMaxTerms 201 sizeof(bool) 4 malloc 800 B: sPredNames LENGTH(SEXP_sPredNames) 100 sizeof(char*) 8 malloc 8 MB: xOrder nRows 20000 nCols 100 sizeof(int) 4 malloc 31 MB: BetaCacheGlobal nMaxTerms 201 nMaxTerms 201 nPreds 100 sizeof(double) 8 malloc 31 MB: bxOrth nCases 20000 nMaxTerms 201 sizeof(double) 8 malloc 31 MB: bxOrthCenteredT nMaxTerms 201 nCases 20000 sizeof(double) 8 malloc 2 kB: bxOrthMean nMaxTerms 201 nResp 1 sizeof(double) 8 malloc 8 B: yMean nResp 1 sizeof(double) 8 Forward pass term 1 malloc 6 kB: Q nMaxTerms 201 sizeof(tQueue) 32 malloc 6 kB: SortedQ nMaxTerms 201 sizeof(tQueue) 32 malloc 156 kB: xbx nCases 20000 sizeof(double) 8 malloc 2 kB: CovSx nMaxTerms 201 sizeof(double) 8 calloc 8 B: CovCol nMaxTerms 201 sizeof(double) 8 calloc 8 B: ycboSum nMaxTerms 201 nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 Forward pass term 2 malloc 156 kB: xbx nCases 20000 sizeof(double) 8 malloc 2 kB: CovSx nMaxTerms 201 sizeof(double) 8 calloc 8 B: CovCol nMaxTerms 201 sizeof(double) 8 calloc 8 B: ycboSum nMaxTerms 201 nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 Forward pass term 4 malloc 156 kB: xbx nCases 20000 sizeof(double) 8 malloc 2 kB: CovSx nMaxTerms 201 sizeof(double) 8 calloc 8 B: CovCol nMaxTerms 201 sizeof(double) 8 calloc 8 B: ycboSum nMaxTerms 201 nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 Forward pass term 6 malloc 156 kB: xbx nCases 20000 sizeof(double) 8 malloc 2 kB: CovSx nMaxTerms 201 sizeof(double) 8 calloc 8 B: CovCol nMaxTerms 201 sizeof(double) 8 calloc 8 B: ycboSum nMaxTerms 201 nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 Forward pass term 8 malloc 156 kB: xbx nCases 20000 sizeof(double) 8 malloc 2 kB: CovSx nMaxTerms 201 sizeof(double) 8 calloc 8 B: CovCol nMaxTerms 201 sizeof(double) 8 calloc 8 B: ycboSum nMaxTerms 201 nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 Forward pass term 10 malloc 156 kB: xbx nCases 20000 sizeof(double) 8 malloc 2 kB: CovSx nMaxTerms 201 sizeof(double) 8 calloc 8 B: CovCol nMaxTerms 201 sizeof(double) 8 calloc 8 B: ycboSum nMaxTerms 201 nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 Forward pass term 12 malloc 156 kB: xbx nCases 20000 sizeof(double) 8 malloc 2 kB: CovSx nMaxTerms 201 sizeof(double) 8 calloc 8 B: CovCol nMaxTerms 201 sizeof(double) 8 calloc 8 B: ycboSum nMaxTerms 201 nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 Forward pass term 14 malloc 156 kB: xbx nCases 20000 sizeof(double) 8 malloc 2 kB: CovSx nMaxTerms 201 sizeof(double) 8 calloc 8 B: CovCol nMaxTerms 201 sizeof(double) 8 calloc 8 B: ycboSum nMaxTerms 201 nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 Forward pass term 16 malloc 156 kB: xbx nCases 20000 sizeof(double) 8 malloc 2 kB: CovSx nMaxTerms 201 sizeof(double) 8 calloc 8 B: CovCol nMaxTerms 201 sizeof(double) 8 calloc 8 B: ycboSum nMaxTerms 201 nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 Forward pass term 18 malloc 156 kB: xbx nCases 20000 sizeof(double) 8 malloc 2 kB: CovSx nMaxTerms 201 sizeof(double) 8 calloc 8 B: CovCol nMaxTerms 201 sizeof(double) 8 calloc 8 B: ycboSum nMaxTerms 201 nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 Forward pass term 20 RSq changed by less than 0.001 at 19 terms, 13 terms used (DeltaRSq 0.00078) After forward pass GRSq 0.998 RSq 0.998 malloc 804 B: iPivots nTerms 201 sizeof(int) 4 malloc 2 MB: xUsed nCases 20000 nUsedCols 13 sizeof(double) 8 malloc 156 kB: Residuals nCases 20000 nResp 1 sizeof(double) 8 malloc 104 B: qraux nUsedCols 13 sizeof(double) 8 malloc 2 MB: work nCases 20000 nUsedCols 13 sizeof(double) 8 FreeEarth (already free) Prune backward penalty 2 nprune null: selected 12 of 13 terms, and 3 of 100 preds After pruning pass GRSq 0.997 RSq 0.997 Getting leverages > if(interactive()) + printf("n %g p %g: earth time %.3f seconds (%.3f minutes)\n", + n, p, + (proc.time() - start.time)[3], + (proc.time() - start.time)[3] / 60) > cat("print(summary(a1)):\n") print(summary(a1)): > print(summary(a)) Call: earth(x=x, y=y, trace=1.5, degree=1) coefficients (Intercept) -2.096 h(-0.609965-x1) 3.841 h(x1- -0.609965) -1.557 h(x1- -0.366104) 3.545 h(x1- -0.21304) 1.537 h(x1-0.276572) -3.138 h(x1-0.477924) -3.827 h(0.998539-x2) -1.000 h(x3- -0.57676) 2.162 h(0.0224676-x3) 3.296 h(x3-0.0224676) -0.974 h(x3-0.530607) 1.866 Selected 12 of 13 terms, and 3 of 100 predictors Termination condition: RSq changed by less than 0.001 at 13 terms Importance: x2, x3, x1, x4-unused, x5-unused, x6-unused, x7-unused, ... Number of terms at each degree of interaction: 1 11 (additive model) GCV 0.00294 RSS 58.6 GRSq 0.997 RSq 0.997 > invisible(gc()) > cat("calling plotmo\n") calling plotmo > plotmo(a, trace=-1) > invisible(gc()) > cat("calling plotres\n") calling plotres > set.seed(2015) # TODO this is necessary, why? > plot(a, trace=1) stats::residuals(object=earth.object, type="response") stats::fitted(object=earth.object) got model response from getCall(object)$y using 10000 of 20000 residuals, forcing id.n=0 because of that (implementation restriction) training rsq 1.00 > if(interactive()) { + printf("n %g p %g: total time %.3f seconds (%.3f minutes)\n", + n, p, + (proc.time() - start.time)[3], + (proc.time() - start.time)[3] / 60) + x <- y <- 0 # free memory by reducing size of large matrices + gc() # release memory back to operating system + } > source("test.epilog.R") earth/inst/slowtests/test.incorrect.R0000644000176200001440000000305013447036435017501 0ustar liggesusers# test.incorrect.R: example incorrect model built by earth # Stephen Milborrow May 2015 Berea source("test.prolog.R") library(earth) options(digits=4) printf <- function(format, ...) cat(sprint(format, ...)) # like c printf sos <- function(x) sum(as.vector(x^2)) # sum of squares func <- function(x) # bivariate with interaction { x[,1] + x[,2] + (x[,1] * x[,2]) + .3 * rnorm(nrow(x)) } n <- 30 set.seed(n) n <- 11 seed <- 17 set.seed(100 + seed) x1 <- sort(runif(n, -(n-1), n+1)) x2 <- runif(n, -(n-1), n+1) x <- data.frame(x1=x1, x2=x2) set.seed(101 + seed) x1test <- runif(10000, -n, n) x2test <- runif(10000, -n, n) xtest <- data.frame(x1=x1test, x2=x2test) colnames(x) <- colnames(xtest) <- c("x1", "x2") set.seed(103 + seed) ytest <- func(xtest) par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) correct.mod <- earth(xtest, ytest, degree=2, trace=0, minspan=-1, Force.weights=TRUE) plotmo(correct.mod, degree1=0, do.par=FALSE, main="correct model\nx1 + x2 + x1*x2") plotmo(correct.mod, degree1=0, do.par=FALSE, main="correct model", type2="im") set.seed(102 + seed) y <- func(x) incorrect.mod <- earth(x, y, degree=2, trace=2, minspan=-1) print(incorrect.mod) test.rsq <- 1 - sos(ytest - predict(incorrect.mod, newdata=xtest)) / sos(ytest - mean(ytest)) plotmo(incorrect.mod, degree1=0, do.par=FALSE, main="incorrect model") plotmo(incorrect.mod, degree1=0, do.par=FALSE, main="incorrect model", pt.col=2, type2="im") points(xtest[,1], xtest[,2], col=3, pch=20, cex=.05) source("test.epilog.R") earth/inst/slowtests/test.varmod.mgcv.bat0000755000176200001440000000176213514230362020302 0ustar liggesusers@rem test.varmod.mgcv.bat @rem mgcv has to be tested separately because of clashes between library(gam) and library(mgcv) @rem Stephen Milborrow Apr 2015 Berea @echo test.varmod.mgcv.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.varmod.mgcv.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.varmod.mgcv.Rout: @echo. @tail test.varmod.mgcv.Rout @echo test.varmod.mgcv.R @exit /B 1 :good1 mks.diff test.varmod.mgcv.Rout test.varmod.mgcv.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.varmod.mgcv.save.ps @exit /B 1 :good2 @rem test.varmod.mgcv.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.varmod.mgcv.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.varmod.mgcv.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.pmethod.cv.Rout.save0000644000176200001440000004214713470061076021252 0ustar liggesusers> # test.pmethod.cv.R: example pmethod.cv model built by earth > # Stephen Milborrow May 2015 Berea > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > data(etitanic) > options(digits=4) > > printf <- function(format, ...) cat(sprint(format, ...)) # like c printf > > cat("\npmethod=cv with formula interface\n\n") pmethod=cv with formula interface > > par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0), oma=c(0,0,2,0)) > > # following is so we can directly compare pmethod=back to pmethod=cv > set.seed(2) > a100.form <- earth(survived ~ ., data=etitanic, degree=2, trace=0, pmethod="back", nfold=2, ncross=2, keepxy=TRUE) > cat("print(a100.form)\n") print(a100.form) > print(a100.form) 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 0.1405 RSS 141.8 GRSq 0.4197 RSq 0.439 CVRSq 0.395 > plot(a100.form, which=1, legend.cex=.5, main="a100.form: pmethod=\"back\"", cex.main=.8, caption="formula interface") > > set.seed(2) > cat("\n") > a101.form <- earth(survived ~ ., data=etitanic, degree=2, trace=1, pmethod="cv", nfold=2, ncross=3) === pmethod="cv": Preliminary model with pmethod="backward" === x[1046,6] with colnames pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname survived, and values 1, 1, 0, 0, 0, 1, 1, 0, 1, 0,... Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.406 RSq 0.450 Prune backward penalty 3 nprune null: selected 8 of 17 terms, and 5 of 6 preds After pruning pass GRSq 0.42 RSq 0.439 Full model GRSq 0.420 RSq 0.439, starting cross validation CV fold 1.1 CVRSq 0.449 n.oof 526 50% n.infold.nz 213 40% n.oof.nz 214 41% CV fold 1.2 CVRSq 0.333 n.oof 520 50% n.infold.nz 214 41% n.oof.nz 213 40% CV fold 2.1 CVRSq 0.463 n.oof 521 50% n.infold.nz 213 41% n.oof.nz 214 41% CV fold 2.2 CVRSq 0.336 n.oof 525 50% n.infold.nz 214 41% n.oof.nz 213 41% CV fold 3.1 CVRSq 0.452 n.oof 517 51% n.infold.nz 213 41% n.oof.nz 214 40% CV fold 3.2 CVRSq 0.371 n.oof 529 49% n.infold.nz 214 40% n.oof.nz 213 41% CV all CVRSq 0.400 n.infold.nz 427 41% === pmethod="cv": Calling update.earth internally for nterms.selected.by.cv=7 === update.earth: using 1046 by 6 data argument from original call to earth x[1046,6] with colnames pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname survived, and values 1, 1, 0, 0, 0, 1, 1, 0, 1, 0,... Skipped forward pass Prune cv penalty 3: selected 7 of 17 terms, and 5 of 6 preds After pruning pass GRSq 0.417 RSq 0.434 > cat("\nprint(a101.form)\n") print(a101.form) > print(a101.form) Selected 7 of 17 terms, and 5 of 6 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, pclass2nd, age, sibsp, parch-unused Number of terms at each degree of interaction: 1 2 4 GRSq 0.4171 RSq 0.4338 mean.oof.RSq 0.4054 (sd 0.0655) pmethod="backward" would have selected: 8 terms 5 preds, GRSq 0.4197 RSq 0.439 mean.oof.RSq 0.4019 > cat("\nprint(summary(a101.form))\n") print(summary(a101.form)) > print(summary(a101.form)) Call: earth(formula=survived~., data=etitanic, pmethod="cv", trace=1, degree=2, nfold=2, ncross=3) coefficients (Intercept) 0.90262 pclass3rd -0.74136 sexmale -0.38773 pclass2nd * sexmale -0.32761 pclass3rd * h(4-sibsp) 0.10938 sexmale * h(age-16) -0.00514 sexmale * h(16-age) 0.04200 Selected 7 of 17 terms, and 5 of 6 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, pclass2nd, age, sibsp, parch-unused Number of terms at each degree of interaction: 1 2 4 GRSq 0.4171 RSq 0.4338 mean.oof.RSq 0.4054 (sd 0.0655) pmethod="backward" would have selected: 8 terms 5 preds, GRSq 0.4197 RSq 0.439 mean.oof.RSq 0.4019 > plot(a101.form, which=1, legend.cex=.5, main="a101.form: pmethod=\"cv\"", cex.main=.8) > > # multiple response model > set.seed(2015) > a102.form <- earth(pclass ~ ., data=etitanic, degree=2, + pmethod="cv", nfold=3) > cat("\nprint(a102.form)\n") print(a102.form) > print(a102.form) Selected 13 of 17 terms, and 5 of 5 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 7 5 GCV RSS GRSq RSq mean.oof.RSq sd(mean.oof.RSq) 1st 0.1470 144.7 0.258427 0.30039 2nd 0.1876 184.8 0.000087 0.05668 3rd 0.1899 187.0 0.240541 0.28352 All 0.5244 516.5 0.175163 0.22184 0.1769 0.005629 pmethod="backward" would have selected: 9 terms 5 preds, GRSq 0.17523 RSq 0.2065 mean.oof.RSq 0.16585 > cat("\nprint(summary(a102.form))\n") print(summary(a102.form)) > print(summary(a102.form)) Call: earth(formula=pclass~., data=etitanic, pmethod="cv", degree=2, nfold=3) 1st 2nd 3rd (Intercept) 0.10670 0.267079 0.62622 survived 0.34507 0.128138 -0.47320 sexmale 0.09874 0.117929 -0.21667 h(26-age) 0.00612 -0.013322 0.00720 h(age-54) 0.08439 -0.035881 -0.04851 h(sibsp-1) -0.06288 -0.040683 0.10356 h(2-parch) 0.24046 -0.060362 -0.18010 h(parch-2) -0.06175 -0.090291 0.15204 survived * sexmale -0.08186 -0.285173 0.36704 survived * h(16-age) -0.03092 0.034844 -0.00393 h(55-age) * h(2-parch) -0.00833 0.001282 0.00705 h(age-55) * h(2-parch) -0.04785 0.018682 0.02917 h(1-sibsp) * h(1-parch) -0.15714 -0.031838 0.18897 Selected 13 of 17 terms, and 5 of 5 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 7 5 GCV RSS GRSq RSq mean.oof.RSq sd(mean.oof.RSq) 1st 0.1470 144.7 0.258427 0.30039 2nd 0.1876 184.8 0.000087 0.05668 3rd 0.1899 187.0 0.240541 0.28352 All 0.5244 516.5 0.175163 0.22184 0.1769 0.005629 pmethod="backward" would have selected: 9 terms 5 preds, GRSq 0.17523 RSq 0.2065 mean.oof.RSq 0.16585 > plot(a102.form, which=1, nresponse=1, main="a102.form: pmethod=\"cv\" multiple response", cex.main=.8) > > # multiple response model > # following is useful because the model selected by cv is same as that selected by gcv > set.seed(1) # don't change > a103.form <- earth(pclass ~ ., data=etitanic, degree=2, + pmethod="cv", nfold=3, nprune=10) > cat("\nprint(a103.form)\n") print(a103.form) > print(a103.form) Selected 10 of 17 terms, and 5 of 5 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 5 4 GCV RSS GRSq RSq mean.oof.RSq sd(mean.oof.RSq) 1st 0.1483 148.3 0.251441 0.28333 2nd 0.1875 187.4 0.000435 0.04301 3rd 0.1905 190.4 0.238198 0.27065 All 0.5264 526.1 0.172166 0.20743 0.161 0.04713 pmethod="backward" would have selected: 9 terms 5 preds, GRSq 0.17523 RSq 0.2065 mean.oof.RSq 0.15678 > plot(a103.form, which=1, nresponse=1, + main="a103.form: pmethod=\"cv\" multiple response\nmax(GRSq) == which.max(mean.oof.rsq)", cex.main=.8) > > # test cv with nprune less than what would be normally selected > set.seed(1) > a104.form <- earth(pclass ~ ., data=etitanic, degree=2, + pmethod="cv", nfold=3, nprune=8) > cat("\nprint(a104.form)\n") print(a104.form) > print(a104.form) Selected 8 of 17 terms, and 5 of 5 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 4 3 GCV RSS GRSq RSq mean.oof.RSq sd(mean.oof.RSq) 1st 0.1503 151.7 0.241384 0.2666 2nd 0.1881 189.9 -0.002701 0.0306 3rd 0.1888 190.5 0.245066 0.2701 All 0.5272 532.1 0.170807 0.1983 0.1543 0.03648 pmethod="backward" would have selected the same model: 8 terms 5 preds, GRSq 0.17081 RSq 0.19835 mean.oof.RSq 0.15428 > plot(a104.form, which=1, nresponse=1, grid=T, main="a104.form: pmethod=\"cv\" nprune=10", cex.main=.8) > > cat("\n\npmethod=cv with x,y interface\n\n") pmethod=cv with x,y interface > par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0), oma=c(0,0,3,0)) > > etitanic.except.survived <- etitanic[,c(1,3,4,5,6)] > survived <- etitanic$survived > > # # following is so we can directly compare pmethod=back to pmethod=cv > # # commented out because already done above with model a100.formula > # set.seed(2) > # a100.xy <- earth(etitanic.except.survived, survived, degree=2, trace=0, pmethod="back", nfold=2, ncross=2, keepxy=TRUE) > # cat("\nprint(a100.xy)\n") > # print(a100.xy) > # plot(a100.xy, which=1, legend.cex=.5, main="a100.xy: pmethod=\"back\"", cex.main=.8) > > set.seed(2) > a101.xy <- earth(etitanic.except.survived, survived, degree=2, trace=1, pmethod="cv", nfold=2, ncross=2) === pmethod="cv": Preliminary model with pmethod="backward" === x[1046,6] with colnames pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname survived, and values 1, 1, 0, 0, 0, 1, 1, 0, 1, 0,... Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.406 RSq 0.450 Prune backward penalty 3 nprune null: selected 8 of 17 terms, and 5 of 6 preds After pruning pass GRSq 0.42 RSq 0.439 Full model GRSq 0.420 RSq 0.439, starting cross validation CV fold 1.1 CVRSq 0.449 n.oof 526 50% n.infold.nz 213 40% n.oof.nz 214 41% CV fold 1.2 CVRSq 0.333 n.oof 520 50% n.infold.nz 214 41% n.oof.nz 213 40% CV fold 2.1 CVRSq 0.463 n.oof 521 50% n.infold.nz 213 41% n.oof.nz 214 41% CV fold 2.2 CVRSq 0.336 n.oof 525 50% n.infold.nz 214 41% n.oof.nz 213 41% CV all CVRSq 0.395 n.infold.nz 427 41% === pmethod="cv": Calling update.earth internally for nterms.selected.by.cv=7 === update.earth: using 1046 by 5 x argument from original call to earth update.earth: using 1046 by 1 y argument from original call to earth x[1046,6] with colnames pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname survived, and values 1, 1, 0, 0, 0, 1, 1, 0, 1, 0,... Skipped forward pass Prune cv penalty 3: selected 7 of 17 terms, and 5 of 6 preds After pruning pass GRSq 0.417 RSq 0.434 > cat("\nprint(a101.xy)\n") print(a101.xy) > print(a101.xy) Selected 7 of 17 terms, and 5 of 6 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, pclass2nd, age, sibsp, parch-unused Number of terms at each degree of interaction: 1 2 4 GRSq 0.4171 RSq 0.4338 mean.oof.RSq 0.3994 (sd 0.0791) pmethod="backward" would have selected: 8 terms 5 preds, GRSq 0.4197 RSq 0.439 mean.oof.RSq 0.3924 > cat("\nprint(summary(a101.xy)\n") print(summary(a101.xy) > print(summary(a101.xy)) Call: earth(x=etitanic.except.survived, y=survived, pmethod="cv", trace=1, degree=2, nfold=2, ncross=2) coefficients (Intercept) 0.90262 pclass3rd -0.74136 sexmale -0.38773 pclass2nd * sexmale -0.32761 pclass3rd * h(4-sibsp) 0.10938 sexmale * h(age-16) -0.00514 sexmale * h(16-age) 0.04200 Selected 7 of 17 terms, and 5 of 6 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, pclass2nd, age, sibsp, parch-unused Number of terms at each degree of interaction: 1 2 4 GRSq 0.4171 RSq 0.4338 mean.oof.RSq 0.3994 (sd 0.0791) pmethod="backward" would have selected: 8 terms 5 preds, GRSq 0.4197 RSq 0.439 mean.oof.RSq 0.3924 > plot(a101.xy, which=1, legend.cex=.5, main="a101.xy: pmethod=\"cv\"", cex.main=.8, caption="x,y interface") > > # a101.form > # a102.xy > > # multiple response model > x.except.pclass <- etitanic[,c(2,3,4,5,6)] > pclass <- etitanic$pclass > set.seed(2015) > a102.xy <- earth(x.except.pclass, pclass, degree=2, + pmethod="cv", nfold=3) > cat("\nprint(a102.xy)\n") print(a102.xy) > print(a102.xy) Selected 13 of 17 terms, and 5 of 5 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 7 5 GCV RSS GRSq RSq mean.oof.RSq sd(mean.oof.RSq) 1st 0.1470 144.7 0.258427 0.30039 2nd 0.1876 184.8 0.000087 0.05668 3rd 0.1899 187.0 0.240541 0.28352 All 0.5244 516.5 0.175163 0.22184 0.1769 0.005629 pmethod="backward" would have selected: 9 terms 5 preds, GRSq 0.17523 RSq 0.2065 mean.oof.RSq 0.16585 > plot(a102.xy, which=1, nresponse=1, main="a102.xy: pmethod=\"cv\" multiple response", cex.main=.8) > > # multiple response model > # following is useful because the model selected by cv is same as that selected by gcv > set.seed(1) # don't change > a103.xy <- earth(x.except.pclass, pclass, degree=2, + pmethod="cv", nfold=3, nprune=10) > cat("\nprint(a103.xy)\n") print(a103.xy) > print(a103.xy) Selected 10 of 17 terms, and 5 of 5 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 5 4 GCV RSS GRSq RSq mean.oof.RSq sd(mean.oof.RSq) 1st 0.1483 148.3 0.251441 0.28333 2nd 0.1875 187.4 0.000435 0.04301 3rd 0.1905 190.4 0.238198 0.27065 All 0.5264 526.1 0.172166 0.20743 0.161 0.04713 pmethod="backward" would have selected: 9 terms 5 preds, GRSq 0.17523 RSq 0.2065 mean.oof.RSq 0.15678 > cat("\nprint(summary(a103.xy)\n") print(summary(a103.xy) > print(summary(a103.xy)) Call: earth(x=x.except.pclass, y=pclass, pmethod="cv", degree=2, nprune=10, nfold=3) 1st 2nd 3rd (Intercept) 0.13619 0.142374 0.72144 survived 0.35281 0.159102 -0.51191 sexmale 0.10869 0.137341 -0.24603 h(age-54) 0.00761 -0.009057 0.00145 h(sibsp-1) -0.04745 -0.068171 0.11562 h(2-parch) 0.20897 0.019375 -0.22835 survived * sexmale -0.09467 -0.304775 0.39944 survived * h(16-age) -0.02359 0.019077 0.00451 h(55-age) * h(2-parch) -0.00750 -0.000377 0.00788 h(1-sibsp) * h(1-parch) -0.16253 -0.032710 0.19524 Selected 10 of 17 terms, and 5 of 5 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 5 4 GCV RSS GRSq RSq mean.oof.RSq sd(mean.oof.RSq) 1st 0.1483 148.3 0.251441 0.28333 2nd 0.1875 187.4 0.000435 0.04301 3rd 0.1905 190.4 0.238198 0.27065 All 0.5264 526.1 0.172166 0.20743 0.161 0.04713 pmethod="backward" would have selected: 9 terms 5 preds, GRSq 0.17523 RSq 0.2065 mean.oof.RSq 0.15678 > plot(a103.xy, which=1, nresponse=1, + main="a103.xy: pmethod=\"cv\" multiple response\nmax(GRSq) == which.max(mean.oof.rsq)", cex.main=.8) > > # test cv with nprune less than what would be normally selected > set.seed(1) > a104.xy <- earth(x.except.pclass, pclass, degree=2, + pmethod="cv", nfold=3, nprune=8) > cat("\nprint(a104.xy)\n") print(a104.xy) > print(a104.xy) Selected 8 of 17 terms, and 5 of 5 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 4 3 GCV RSS GRSq RSq mean.oof.RSq sd(mean.oof.RSq) 1st 0.1503 151.7 0.241384 0.2666 2nd 0.1881 189.9 -0.002701 0.0306 3rd 0.1888 190.5 0.245066 0.2701 All 0.5272 532.1 0.170807 0.1983 0.1543 0.03648 pmethod="backward" would have selected the same model: 8 terms 5 preds, GRSq 0.17081 RSq 0.19835 mean.oof.RSq 0.15428 > plot(a104.xy, which=1, nresponse=1, grid=T, main="a104.xy: pmethod=\"cv\" nprune=10", cex.main=.8) > > source("test.epilog.R") earth/inst/slowtests/test.glm.R0000644000176200001440000021236713444547240016303 0ustar liggesusers# test.glm.R: tests glm and factors added for earth release 2.0 source("test.prolog.R") library(earth) data(ozone1) data(trees) data(etitanic) source("check.models.equal.R") printh <- function(x, expect.warning=FALSE, max.print=0) # like print but with a header { cat("===", deparse(substitute(x))) if(expect.warning) cat(" expect warning -->") else if (NROW(x) > 1) cat("\n") if (max.print > 0) print(head(x, n=max.print)) else print(x) } model.count <- 0 show.earth.models <- function(a, nresponse=NA, legend.pos=NULL, ...) { model.name <- deparse(substitute(a)) cat("\nPrint", model.name, "\n\n") print(a) cat("\nSummary", model.name, "\n\n") print(summary(a)) model.count <<- model.count + 1 if (model.count %% 2 == 0) { # an attempt at trying different parameters without combin explosion. cat("\nSummary", model.name, "decomp=\"none\", digits=5, fixed.point=FALSE, details=TRUE\n\n") print(summary(a, decomp="none", digits=5, fixed.point=FALSE, details=TRUE)) } else { cat("\nSummary", model.name, "digits=3, details=TRUE\n\n") print(summary(a, decomp="none", digits=3, details=TRUE)) } cat("\nevimp", model.name, "\n\n") print(evimp(a)) cat("\nevimp", model.name, "trim=FALSE\n\n") ev <- evimp(a, trim=FALSE) print(ev) plot(a, nresponse=nresponse, legend.pos=legend.pos, caption=if(is.na(nresponse)) model.name else paste("Response ", nresponse, ": ", model.name, sep="")) plot(ev) if (!is.null(a$glm.list)) { control <- a$glm.list[[1]]$control family <- a$glm.list[[1]]$family cat("\nglm params: epsilon", control$epsilon, "maxit", control$maxit, "trace", control$trace, "family", family$family, "link", family$link, "\n") } cat("\nplotmo", model.name, "\n") if(is.na(nresponse)) plotmo(a, clip=FALSE) else plotmo(a, nresponse=nresponse, clip=FALSE) cat("-------------------------------------------------------------------------------\n\n") } # print contents of earth.model, for sanity checking that all fields are present as usual # but strip big fields to reduce amount of printing print.stripped.earth.model <- function(a, model.name) { a$bx <- NULL a$fitted.values <- NULL a$residuals <- NULL cat("print.stripped.earth.model(", model.name, ")\n", sep="") print.default(a) cat("-------------------------------------------------------------------------------\n\n") } # binomial models ldose <- rep(0:5, 2) - 2 # ldose1 <- c(0.1, 1.2, 2.3, 3.4, 4.5, 5.6, 0.3, 1.4, 2.5, 3.6, 4.7, 5.8) ldose1 <- c(0.1, 1.2, 0.1, 1.2, 1.0, 0.1, 0.3, 1.4, 0.1, 1.2, 0.1, 0.9) sex <- factor(rep(c("male", "female"), times=c(6,6))) numdead <- c(1,4,9,13,18,20,0,2,6,10,12,16) numalive=20 - numdead SF <- cbind(numdead, numalive) numdead2 <- c(2,3,10,13,19,20,0,3,7,11,13,17) SF2 <- cbind(numdead2, numalive2=20 - numdead2) PMETHOD <- "none" # avoid intercept only models NK <- 6 # avoid infinite GCV models (since pmethod="none") # single response glm model but with a binomial pair of y columns cat("a1: single response glm model but with a binomial pair of y columns, with ldose1 data degree=2\n\n") a1 <- earth(SF ~ sex + ldose + ldose1, glm=list(family="binomial"), trace=4, pmethod=PMETHOD, nk=NK, degree=2) show.earth.models(a1, legend.pos="topleft") printh(evimp(a1, trim=FALSE, sqrt=FALSE)) printh(evimp(a1, trim=FALSE, sqrt=TRUE)) # this tests sqrt param with negative evimps a1update <- update(a1, trace=0) check.models.equal(a1, a1update, msg="a1update a1", newdata=data.frame(sex="female", ldose=10, ldose1=11)) # test some different but equivalent glm specs a1a <- earth(SF ~ sex + ldose + ldose1, glm=list(family="binomial"), trace=1, pmethod=PMETHOD, nk=NK, degree=2) check.models.equal(a1a, a1, msg="a1 a1a", newdata=data.frame(sex="female", ldose=10, ldose1=11)) a1b <- earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial), trace=1, pmethod=PMETHOD, nk=NK, degree=2) check.models.equal(a1, a1b, msg="a1 a1b", newdata=data.frame(sex="female", ldose=10, ldose1=11)) a1c <- earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial()), trace=1, pmethod=PMETHOD, nk=NK, degree=2) check.models.equal(a1, a1c, msg="a1 a1c", newdata=data.frame(sex="female", ldose=10, ldose1=11)) a1d <- earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit")), trace=1, pmethod=PMETHOD, nk=NK, degree=2) check.models.equal(a1, a1d, msg="a1 a1d", newdata=data.frame(sex="female", ldose=10, ldose1=11)) expect.err(try(earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit"),offset=NULL), trace=1, pmethod=PMETHOD, nk=NK, degree=2)), "earth: 'offset' is not supported in glm argument to earth") a1g <- earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit"),control=glm.control()), trace=1, pmethod=PMETHOD, nk=NK, degree=2) check.models.equal(a1, a1g, msg="a1 a1g", newdata=data.frame(sex="female", ldose=10, ldose1=11)) # following should cause a "did not converge warning" because maxit=2 a1h <- earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit"),control=glm.control(epsilon=1e-8, maxit=2, trace=TRUE)), trace=1, pmethod=PMETHOD, nk=NK, degree=2) show.earth.models(a1h, legend.pos="topleft") # show non convergence (and maxit) check.models.equal(a1, a1g, msg="a1 a1h", newdata=data.frame(sex="female", ldose=10, ldose1=11)) # models should still be equal within numeric tolerance stopifnot(a1h$glm.list[[1]]$control$maxit == 2) # equivalent way of specifying maxit a1h2 <- earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit"),control=glm.control(epsilon=1e-8),maxit=2), pmethod=PMETHOD, nk=NK, degree=2) check.models.equal(a1h, a1h2, msg="a1h a1h2", newdata=data.frame(sex="female", ldose=10, ldose1=11)) stopifnot(a1h2$glm.list[[1]]$control$maxit == 2) expect.err(try(earth(SF ~ sex + ldose + ldose1, family=binomial)), "illegal 'family' argument to earth\nTry something like earth(y~x, glm=list(family=binomial))") expect.err(try(earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit")), maxi=123)), "illegal 'maxit' argument to earth\nTry something like earth(y~x, glm=list(family=binomial, control=list(maxit=99)))") expect.err(try(earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit")), eps=123)), "illegal 'epsilon' argument to earth\nTry something like earth(y~x, glm=list(family=binomial, control=list(epsilon=1e-9)))") expect.err(try(earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit"), weights=1:nrow(SF)))), "earth: illegal 'weights' in 'glm' argument") expect.err(try(earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit"), subset=1:nrow(SF)))), "earth: illegal 'subset' in 'glm' argument") expect.err(try(earth(SF ~ sex + ldose + ldose1, glm=list(family=binomial(link="logit"), formula=SF~sex))), "earth: illegal 'formula' in 'glm' argument") plotres(a1h, caption="a1h: default type", legend.pos="topleft") plotres(a1h, type="response", caption="a1h: type=\"response\" (same as default type)", legend.pos="topleft") plotres(a1h, type="earth", caption="a1h: type=\"earth\"", legend.pos="topleft") # check update, also check params are carried forward properly with update a1h.update1 <- update(a1h, glm=list(family=binomial(link="probit"), maxit=8)) stopifnot(a1h.update1$glm.list[[1]]$control$maxit == 8) show.earth.models(a1h.update1, legend.pos="topleft") a1h.update2 <- update(a1h, glm=list(family=gaussian, maxit=9), degree=1) stopifnot(a1h.update2$glm.list[[1]]$control$maxit == 9) show.earth.models(a1h.update2, nresponse="numdea", legend.pos="topleft") # basic check with an I in formula a1i <- earth(SF ~ sex + ldose + I(ldose1-3), glm=list(family="binomial"), trace=1, pmethod=PMETHOD, nk=NK, degree=2) print(summary(a1i)) cat("a2: single response glm model but with a binomial pair of y columns, degree=1\n\n") a2 <- earth(SF ~ sex*ldose, glm=list(fa="b"), trace=3, pmethod=PMETHOD) show.earth.models(a2, legend.pos="topleft") # repeat with bpairs arg a2a <- earth(SF ~ sex*ldose, glm=list(family="binomial", bpairs=c(TRUE,FALSE)), trace=3, pmethod=PMETHOD) stopifnot(identical(a2$glm.list[[1]]$coefficients, a2a$glm.list[[1]]$coefficients)) stopifnot(isTRUE(all.equal(coef(a2), coefficients(a2)))) stopifnot(isTRUE(all.equal(coef(a2, type="glm"), coefficients(a2, type="glm")))) stopifnot(isTRUE(all.equal(coef(a2, type="earth"), coefficients(a2, type="earth")))) stopifnot(identical(names(coef(a2)), rownames(a2$coefficients))) stopifnot(identical(names(coef(a2)), rownames(a2$glm.coefficients))) stopifnot(identical(names(coef(a2, type="glm")), rownames(a2$glm.coefficients))) stopifnot(max(abs(coef(a2) - a2$glm.coefficients)) == 0) stopifnot(max(abs(coef(a2, type="earth") - a2$coefficients)) == 0) stopifnot(max(abs(coef(a2) - a2$glm.list[[1]]$coefficients)) == 0) a2b <- earth(numdead+numalive~sex*ldose, glm=list(family="binomial"), pmethod=PMETHOD) predict.a2 <- predict(a2,newdata=data.frame(sex=sex[1],ldose=3)) predict.a2a <- predict(a2a,newdata=data.frame(sex=sex[1],ldose=3)) predict.a2b <- predict(a2b,newdata=data.frame(sex=sex[1],ldose=3)) stopifnot(identical(predict.a2a, predict.a2)) stopifnot(identical(predict.a2b, predict.a2)) a2c <- earth(SF ~ sex, glm=list(family="binomial"), trace=0, pmethod=PMETHOD) a2update <- update(a2, SF ~ sex, trace=0) check.models.equal(a2c, a2update, msg="a2c a2update", newdata=data.frame(sex="female", ldose=10, ldose1=11)) # build a standard GLM model for comparison cat("a3: direct GLM a3:\n\n") a3 <- glm(SF ~ sex * ldose, family="binomial") print(summary(a3)) plotmo(a3, caption="a3 <- glm(SF ~ sex * ldose, family=\"binomial\")") cat("-------------------------------------------------------------------------------\n\n") # double response glm model with two binomial paired cols SF.both <- cbind(SF, SF2) cat("a4: double response glm model with two binomial paired cols\n\n") expect.err(try(earth(SF.both ~ sex*ldose, linpreds=TRUE, glm=list(family="binomial"), trace=1)), "Binomial response (see above): all values should be between 0 and 1, or a binomial pair") # titanic data, multiple responses (i.e. 3 level factor) cat("a5: titanic data, multiple responses (i.e. 3 level factor)\n\n") a5 <- earth(pclass ~ ., data=etitanic, degree=2, glm=list(family="binomial"), trace=0) show.earth.models(a5, nresponse=1) printh(a5$levels) print.stripped.earth.model(a5, "a5") # variance models are not supported for multiple response models expect.err(try(earth(pclass ~ ., data=etitanic, ncross=3, nfold=3, varmod.method="lm")), "variance models are not supported for multiple response models") a5d <- earth(pclass ~ .-age, data=etitanic, degree=2, glm=list(family="binomial"), trace=0) a5update <- update(a5, form=pclass ~ .-age) check.models.equal(a5update, a5d, msg="a5update a5d", newdata=etitanic[5,]) a5d <- earth(pclass ~ .-age, data=etitanic, degree=2, glm=list(family="binomial"), trace=0, keepxy=1) a5update <- update(a5, form=pclass ~ .-age) check.models.equal(a5update, a5d, msg="a5update a5d with keepxy", newdata=etitanic[5,]) # titanic data, one logical response cat("a6: titanic data, one logical response\n\n") pclass1 = (etitanic[,1] == "1st") a6 <- earth(pclass1 ~ ., data=etitanic[,-1], degree=2, glm=list(family="binomial"), trace=1) show.earth.models(a6) printh(a6$levels) # expect levels to be NULL print.stripped.earth.model(a6, "a6") # titanic data, one response which is a two level factor cat("a7: titanic data, one response which is a two level factor\n\n") a7 <- earth(sex ~ ., data=etitanic, degree=2, glm=list(family="binomial"), trace=1) show.earth.models(a7, nresponse=1) printh(a7$levels) print.stripped.earth.model(a7, "a7") a7d <- earth(sex ~ .-pclass, data=etitanic, degree=2, glm=list(family="binomial"), trace=0) a7dupdate <- update(a7, form=sex ~ .-pclass) check.models.equal(a7dupdate, a7d, msg="a7update a7d", newdata=etitanic[5,]) printh(a7d$levels) a7d <- earth(sex ~ .-pclass, data=etitanic, degree=2, glm=list(family="binomial"), trace=0, keepxy=1) a7dupdate <- update(a7, form=sex ~ .-pclass) check.models.equal(a7dupdate, a7d, msg="a7update a7d with keepxy", newdata=etitanic[5,]) subset. <- rep(TRUE, nrow(etitanic)) subset.[1:10] <- FALSE a7e <- earth(sex ~ ., subset=subset., data=etitanic, degree=2, glm=list(family="binomial"), trace=0) a7eupdate <- update(a7, subset=subset.) check.models.equal(a7eupdate, a7e, msg="a7update a7e", newdata=etitanic[5,]) subset. <- 1:nrow(etitanic) # another way of specifying a subset subset.[1:10] <- 0 a7eeupdate <- update(a7, subset=subset.) check.models.equal(a7eeupdate, a7e, msg="a7update a7e with alternative subset", newdata=etitanic[5,]) a7f <- earth(sex ~ ., data=etitanic, degree=2, glm=list(family=binomial(link="probit")), trace=0) a7fupdate <- update(a7, glm=list(family=binomial(link="probit"))) check.models.equal(a7fupdate, a7f, msg="a7update a7f with link=probit", newdata=etitanic[5,]) a7 <- earth(sex ~ ., data=etitanic, degree=2, glm=list(family="binomial"), keepxy=1) a7g <- earth(sex ~ ., data=etitanic, degree=2, glm=list(family=binomial(link="probit")), trace=0) a7gupdate <- update(a7, glm=list(family=binomial(link="probit")), trace=1) check.models.equal(a7gupdate, a7g, msg="a7update a7g with link=probit and keepxy", newdata=etitanic[5,]) a8 <- earth(sex ~ ., data=etitanic, degree=2, glm=list(family="binomial"), keepxy=1) a8g <- earth(sex ~ ., data=etitanic[100:900,], degree=2, glm=list(family=binomial), trace=0) a8gupdate <- update(a8, data=etitanic[100:900,], trace=1) check.models.equal(a8gupdate, a8g, msg="a8update a8g with new data", newdata=etitanic[5,]) # poisson models counts <- c(18,17,15,20,10,20,25,13,12) counts2 <- c(181,171,151,201,101,201,251,131,121) outcome <- gl(3,1,9) treatment <- gl(3,3) d.AD <- data.frame(treatment, outcome, counts, counts2) # one response poisson model cat("a8p: one response poisson model\n\n") a8p <- earth(counts ~ outcome + treatment, glm=list(family=poisson()), trace=3, pmethod=PMETHOD) show.earth.models(a8p, legend.pos="topleft") # build a standard GLM model for comparison cat("a9: one response poisson model, standard GLM model for comparison\n\n") a9 <- glm(counts ~ outcome + treatment, family="poisson") cat("Direct GLM a9 summary:\n\n") print(summary(a9)) plotmo(a9, grid.levels=list(outcome="2"), caption="a9 <- glm(counts ~ outcome + treatment, family=\"poisson\")") # two response poisson model cat("a10: two response poisson model\n\n") a10 <- earth(cbind(counts, counts2) ~ outcome + treatment, glm=list(fam="po"), trace=1, pmethod=PMETHOD) show.earth.models(a10, nresponse="counts") # compare family=gaussian to standard earth model cat("a11: compare family=gaussian to standard earth model\n\n") a11 <- earth(etitanic$sex ~ ., data=etitanic, degree=2, glm=list(family="gaussian"), trace=4) cat("\nsummary(a11, details=TRUE)\n\n", sep="") print(summary(a11, details=TRUE)) stopifnot(identical(a11$coefficients, a11$glm.coefficients)) cat("-------------------------------------------------------------------------------\n\n") cat("a12: compare family=gaussian to standard earth model with two responses\n\n") a12 <- earth(cbind(etitanic$sex, (as.integer(etitanic$age)^2)) ~ ., data=etitanic, degree=2, glm=list(family="gaussian"), trace=4) cat("\nsummary(a12, details=TRUE)\n\n", sep="") print(summary(a12, details=TRUE)) stopifnot(identical(a12$coefficients, a12$glm.coefficients)) # test to see how standard model.matrix does column numbering with formula my.x1 <- as.numeric(ToothGrowth[,2]) # supp was VC or OJ my.x2 <- as.numeric(ToothGrowth[,3]) # dose my.input.mat <- cbind(my.x1, my.x2) my.response <- ToothGrowth[,1] a13 <- earth(my.response~my.input.mat, trace=1) print(summary(a13, details=TRUE)) stop.if.not.identical <- function(msg, a, b) { if(!identical(a, b)) { cat(msg, "not identical\n") cat(deparse(substitute(a)), ":\n", sep="") print(a) cat(deparse(substitute(b)), ":\n", sep="") print(b) stop("test failed") } cat(msg, "identical\n") } # some matrix interface tests # double response glm model with two binomial paired cols SF.both <- cbind(SF, SF2) df <- data.frame(sex, ldose) expect.err(try(earth(SF.both ~ ., data=df, glm=list(family="binomial"), trace=1)), "Binomial response (see above): all values should be between 0 and 1, or a binomial pair") # --- predict with factors ------------------------------------------------------ # there is a lot of redundancy in this routine, it doesn't really matter test.predict.with.factors <- function(trace) { cat("\n--- predict with single level factors and a single response, trace=", trace, " ---\n\n", sep="") cat("first do a quick test of predict.earth help page example\n") a <- earth(Volume ~ ., data = trees) if (trace) print(head(predict(a, trace=trace))) if (trace) print(predict(a, c(10,80), trace=trace)) # test set A: prepare the data ldose <- rep(0:5, 2) - 2 # ldose1 <- c(0.1, 1.2, 2.3, 3.4, 4.5, 5.6, 0.3, 1.4, 2.5, 3.6, 4.7, 5.8) ldose1 <- c(0.1, 1.2, 0.1, 1.2, 1.0, 0.1, 0.3, 1.4, 0.1, 1.2, 0.1, 0.9) sex <- factor(rep(c("male", "female"), times=c(6,6))) numdead <- c(1,4,9,13,18,20,0,2,6,10,12,16) sexmale <- (sex == "male") am <- earth(cbind(sexmale, ldose, ldose1), numdead, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) af <- earth(numdead ~ sex + ldose + ldose1, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) check.models.equal(am, af, "predict with single level factors and a single response") cat("A-20m head(predict(am, trace=", trace, ")\n", sep="") pm <- predict(am, trace=trace) if (trace) print(head(pm)) cat("A-20f head(predict(af, trace=", trace, ")\n", sep="") pf <- predict(af, trace=trace) if (trace) print(head(pf)) stop.if.not.identical("A-20", pm, pf) cat("A-21m predict(am, newdata=c(sex[1], -2, 0.1), trace=", trace, "))\n", sep="") pm <- predict(am, newdata=c(sex[1]=="male", -2, 0.1), trace=trace) pm.ref <- pm if (trace) print(pm) cat("A-21f predict(af, newdata=c(sex[1], -2, 0.1), trace=", trace, "))\n", sep="") pf <- predict(af, newdata=c(sex[1]=="male", -2, 0.1), trace=trace) if (trace) print(pf) stop.if.not.identical("A-21", pm.ref, pf) cat("A-22m predict(am, newdata=c(1, -2, 0.1), trace=", trace, ")) use numeric instead of factor sex\n", sep="") pm <- predict(am, newdata=c(1, -2, 0.1), trace=trace) if (trace) print(pm) stop.if.not.identical("A-22", pm.ref, pm) cat("A-22f predict(af, newdata=c(1, -2, 0.1), trace=", trace, ")) use numeric instead of factor sex\n", sep="") pf <- predict(af, newdata=c(1, -2, 0.1), trace=trace) if (trace) print(pf) stop.if.not.identical("A-22", pm, pf) cat("A-23m predict(am, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=", trace, ")) multiple rows as a vec\n", sep="") pm <- predict(am, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=trace) if (trace) print(pm) cat("A-23f predict(af, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=", trace, ")) multiple rows as a vec\n", sep="") pf <- predict(af, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=trace) if (trace) print(pf) stop.if.not.identical("A-23", pm, pf) cat("A-24m predict(am, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=", trace, ")) more multiple rows as a vec\n", sep="") pm <- predict(am, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=trace) if (trace) print(pm) pm2.ref <- pm cat("A-24f predict(af, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=", trace, ")) more multiple rows as a vec\n", sep="") pf <- predict(af, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=trace) if (trace) print(pf) stop.if.not.identical("A-24", pm, pf) cat("A-25m predict(am, xpredict matrix trace=", trace, "\n", sep="") new.data <- matrix(c(sex[1], sex[1], -2, -1, 0.1, 0.1), nrow=2) pm <- predict(am, newdata=new.data, trace=trace) if (trace) print(pm) stop.if.not.identical("A-25", pm2.ref, pm) cat("A-25f predict(af, xpredict matrix trace=", trace, "\n", sep="") pf <- predict(af, newdata=new.data, trace=trace) if (trace) print(pf) stop.if.not.identical("A-25", pm, pf) cat("A-26m predict(am, new.data with col names) trace=", trace, "\n", sep="") new.data <- matrix(c(sex[1], sex[1], -2, -1, 0.1, 0.1), nrow=2) colnames(new.data) <- c("sex", "ldose", "ldose1") pm <- predict(am, newdata=new.data, trace=trace) if (trace) print(pm) stop.if.not.identical("A-26m", pm2.ref, pm) cat("A-26f predict(af, new.data with col names) trace=", trace, "\n", sep="") pf <- predict(af, newdata=new.data, trace=trace) if (trace) print(pf) stop.if.not.identical("A-26f", pm, pf) cat("A-27m predict(am, new.data with out of order col names) trace=", trace, "\n", sep="") new.data <- matrix(c(sex[1], sex[1], 0.1, 0.1, -2, -1), nrow=2) colnames(new.data) <- c("sex", "ldose1", "ldose") pm <- predict(am, newdata=new.data, trace=trace) if (trace) print(pm) stop.if.not.identical("A-27", pm2.ref, pm) cat("A-27f predict(af, new.data with out of order col names) trace=", trace, "\n", sep="") pf <- predict(af, newdata=new.data, trace=trace) if (trace) print(pf) stop.if.not.identical("A-27", pm, pf) cat("A-28m predict(am, xdata.frame without col names) trace=", trace, "\n", sep="") if (trace) print(pm) stop.if.not.identical("A-28", pm2.ref, pm) cat("A-28f predict(af, xdata.frame without col names) trace=", trace, "\n", sep="") xdata.frame <- data.frame(c(sex[1], sex[1]), c(-2, -1), c(0.1, 0.1)) pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("A-28", pm, pf) cat("A-29m predict(am, xdata.frame with col names) trace=", trace, "\n", sep="") xdata.frame.29 <- data.frame(sex[1], -2, 0.1) colnames(xdata.frame.29) <- c("sex", "ldose", "ldose1") pm <- predict(am, xdata.frame.29, trace=trace) if (trace) print(pm) stop.if.not.identical("A-29", pm.ref, pm) cat("A-29f predict(af, xdata.frame with col names) trace=", trace, "\n", sep="") pf <- predict(af, xdata.frame.29, trace=trace) if (trace) print(pf) stop.if.not.identical("A-29", pm, pf) cat("A2-29m predict(am, xdata.frame with col names) trace=", trace, "\n", sep="") xdata.frame.29.2 <- data.frame(c(sex[1], sex[1]), c(-2, -1), c(0.1, 0.1)) colnames(xdata.frame.29.2) <- c("sex", "ldose", "ldose1") pm <- predict(am, xdata.frame.29.2, trace=trace) if (trace) print(pm) stop.if.not.identical("A2-29", pm2.ref, pm) cat("A2-29f predict(af, xdata.frame with col names) trace=", trace, "\n", sep="") pf <- predict(af, xdata.frame.29.2, trace=trace) if (trace) print(pf) stop.if.not.identical("A2-29", pm, pf) cat("A-31m predict(am, xdata.frame, trace=", trace, ") data frame with factors and wrong col names\n", sep="") xdata.frame <- data.frame(sex[1], -2, 0.1) pm <- predict(am, xdata.frame, trace=trace) stop.if.not.identical("A-31", pm.ref, pm) if (trace) print(pm) cat("A-31f predict(af, xdata.frame, trace=", trace, ") data frame with factors and wrong col names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("A-31", pm, pf) cat("A-31bm predict(am, xdata.frame, trace=", trace, ") data frame col names\n", sep="") xdata.frame <- data.frame(sex=sex[1], ldose=-2, ldose1=0.1) pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("A-31", pm.ref, pm) cat("A-31bf predict(af, xdata.frame, trace=", trace, ") data frame col names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("A-31b", pm, pf) cat("A-32m predict(am, xdata.frame, trace=", trace, ") # data frame with names\n", sep="") xdata.frame <- data.frame(sex[1], -2, 0.1) colnames(xdata.frame) <- c("sex", "ldose", "ldose1") pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("A-32", pm, pf) stop.if.not.identical("A-32", pm.ref, pm) cat("A-32f predict(af, xdata.frame, trace=", trace, ") # data frame with names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("A-32", pm, pf) cat("A-42am predict(am, newdata=c(1, -2, 0.1), trace=", trace, ")) use numeric instead of factor sex\n", sep="") pm <- predict(am, newdata=c(1, -2, 0.1), trace=trace) if (trace) print(pm) stop.if.not.identical("A-42a", pm.ref, pm) cat("A-42af predict(af, newdata=c(1, -2, 0.1), trace=", trace, ")) use numeric instead of factor sex\n", sep="") pf <- predict(af, newdata=c(1, -2, 0.1), trace=trace) if (trace) print(pf) stop.if.not.identical("A-42a", pm, pf) cat("A-43am predict(af, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=", trace, ")) multiple rows as a vec\n", sep="") pm <- predict(af, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=trace) if (trace) print(pm) cat("A-43af predict(am, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=", trace, ")) multiple rows as a vec\n", sep="") pf <- predict(am, newdata=c(sex[1], sex[1], -2, -2, 0.1, 0.1), trace=trace) if (trace) print(pf) stop.if.not.identical("A-43a", pm, pf) cat("A-44am predict(af, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=", trace, ")) more multiple rows as a vec\n", sep="") pm <- predict(af, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=trace) if (trace) print(pm) stop.if.not.identical("A-44a", pm2.ref, pm) cat("A-44fm predict(am, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=", trace, ")) more multiple rows as a vec\n", sep="") pf <- predict(am, newdata=c(sex[1], sex[1], -2, -1, 0.1, 0.1), trace=trace) if (trace) print(pf) stop.if.not.identical("A-44f", pm, pf) cat("A-53m predict(am, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") xdata.frame <- data.frame(sex[1], -2) expect.err(try(predict(am, xdata.frame, trace=trace)), "expected 3") cat("A-53f predict(af, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") xdata.frame <- data.frame(sex[1], -2) expect.err(try(predict(af, xdata.frame, trace=trace)), "expected 3") cat("A-54m predict(am, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") xdata.frame <- data.frame(-2, sex[1], 0.1) colnames(xdata.frame) <- c("ldose", "sex", "ldose1") pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("A-54", pm.ref, pm) cat("A-54f predict(af, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("A-54", pm, pf) cat("A-55m predict(am, xdata.frame, trace=", trace, ") data frame without col names\n", sep="") xdata.frame <- data.frame(sex[c(1,7)], c(-2,-1), c(0.1, 0.1)) pm <- predict(am, xdata.frame, trace=trace) pm3.ref <- pm if (trace) print(pm) cat("A-55f predict(af, xdata.frame, trace=", trace, ") data frame without col names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("A-55", pm, pf) cat("A-56m predict(am, xdata.frame, trace=", trace, ") # data frame with col names\n", sep="") xdata.frame <- data.frame(sex[c(1,7)], c(-2,-1), c(0.1, 0.1)) colnames(xdata.frame) <- c("sex", "ldose", "ldose1") pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("A-56", pm3.ref, pm) cat("A-56f predict(af, xdata.frame, trace=", trace, ") # data frame with col names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("A-56", pm, pf) cat("A-57m predict(am, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") xdata.frame <- data.frame(sex[c(1,7)], c(-2,-1)) expect.err(try(predict(am, xdata.frame, trace=trace)), "expected 3") cat("A-57f predict(af, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") expect.err(try(predict(af, xdata.frame, trace=trace)), "expected 3") stop.if.not.identical("A-57", pm, pf) cat("A-58m predict(am, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") xdata.frame <- data.frame(c(-2,-1), sex[c(1,7)], c(0.1, 0.1)) colnames(xdata.frame) <- c("ldose", "sex", "ldose1") pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("A-58", pm3.ref, pm) cat("A-58f predict(af, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("A-58", pm, pf) cat("A-59m predict(am, xdata.frame, trace=", trace, ") numeric where factor expected, expect forge on message\n", sep="") xdata.frame.39 <- data.frame(c(sex[1], sex[7]), c(-2,-1), c(0.1, 0.1)) colnames(xdata.frame.39) <- c("sex", "ldose", "ldose1") pm <- predict(am, xdata.frame.39, trace=trace) if (trace) print(pm) # stop.if.not.identical("A-59", pm3.ref, pm) # TODO fails but "forge on" message is correctly issued cat("A-59f predict(af, xdata.frame, trace=", trace, ") numeric where factor expected, expect forge on message\n", sep="") pf <- predict(af, xdata.frame.39, trace=trace) if (trace) print(pf) stop.if.not.identical("A-59", pm, pf) cat("A-50m data frame without column names, trace=", trace, "\n", sep="") xdata.frame <- data.frame(sex[1], -2, 0.1) colnames(xdata.frame) <- NULL pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("A-34", pm.ref, pm) cat("A-60f data frame without column names, trace=", trace, "\n", sep="") xdata.frame <- data.frame(sex[1], -2, 0.1) colnames(xdata.frame) <- NULL pf <- predict(am, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("A-60", pm, pf) cat("A-61f data frame without extra columns, trace=", trace, "\n", sep="") xdata.frame <- data.frame(sex=sex[1], extra1=99, ldose=-2, extra2=99, ldose1=0.1, extra3=sex[7]) pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("A-61", pm, pf) #----------------------------------- my.x1 <- as.numeric(ToothGrowth[,2]) # supp was VC or OJ my.x2 <- as.numeric(ToothGrowth[,3]) # dose my.input.mat <- cbind(my.x1, my.x2) my.response <- ToothGrowth[,1] cat("A-68 input matrix to formula interface trace=", trace, ", expect error \"could not interpret\"\n", sep="") a41 <- earth(my.response~my.input.mat, trace=trace) expect.err(try(predict(a41, c(2.1, 0.6), trace=trace)), "could not interpret the data") cat("A-69 above test but with properly named dataframe trace=", trace, "\n", sep="") df <- data.frame(growth=my.response, supp=my.x1, dose=my.x2) a42 <- earth(formula=growth~., data=df, trace=0) p <- predict(a42, c(2.1, 0.6), trace=0) # now gives the correct result if (trace) print(head(p)) cat("Tests with not all predictors used in the model so can pass fewer columns\n") # No factor tests done, they probably won't work in this setup. # first for earth.default dummy <- rep(0, 12) am <- earth(cbind(ldose, dummy, ldose1), numdead, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) # prepare reference prediction, using all columns newdata <- matrix(c(-2, 0, 0.1), ncol=3, nrow=1) colnames(newdata) <- c("ldose", "dummy", "ldose1") pm.ref <- predict(am, newdata=newdata, trace=trace) if (trace) print(pm.ref) cat("A-72m predict(am, newdata=newdata[two columns], trace=trace)\n") newdata <- matrix(c(-2, 0.1), ncol=2, nrow=1) colnames(newdata) <- c("ldose", "ldose1") pm <- predict(am, newdata=newdata, trace=trace) if (trace) print(pm) stop.if.not.identical("A-72m", pm, pm.ref) # prepare reference prediction, using all columns newdata <- data.frame(cbind(ldose, dummy, ldose1)) print(newdata) pm.ref <- predict(am, newdata=newdata, trace=trace) if (trace) print(pm.ref) cat("A-73m predict(am, newdata=newdata[two columns], trace=trace)\n") newdata <- newdata[, c(1,3)] pm <- predict(am, newdata=newdata, trace=trace) if (trace) print(pm) stop.if.not.identical("A-73m", pm, pm.ref) # now for earth.formula dummy <- rep(0, 12) af <- earth(numdead ~ ldose + dummy + ldose1, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) # prepare reference prediction, using all columns newdata <- matrix(c(-2, 0, 0.1), ncol=3, nrow=1) colnames(newdata) <- c("ldose", "dummy", "ldose1") newdata <- as.data.frame(newdata) pf.ref <- predict(af, newdata=newdata, trace=trace) if (trace) print(pf.ref) cat("A-72f predict(af, newdata=newdata[two columns], trace=trace)\n") newdata <- matrix(c(-2, 0.1), ncol=2, nrow=1) colnames(newdata) <- c("ldose", "ldose1") newdata <- as.data.frame(newdata) pf <- predict(af, newdata=newdata, trace=trace) if (trace) print(pf) stop.if.not.identical("A-72f", pf, pf.ref) # prepare reference prediction, using all columns newdata <- data.frame(cbind(ldose, dummy, ldose1)) print(newdata) pf.ref <- predict(af, newdata=newdata, trace=trace) if (trace) print(pf.ref) cat("A-73f predict(af, newdata=newdata[two columns], trace=trace)\n") newdata <- newdata[, c(1,3)] pf <- predict(af, newdata=newdata, trace=trace) if (trace) print(pf) stop.if.not.identical("A-73f", pf, pf.ref) cat("\n--- B predict with multiple level factors and a multiple real response, trace=", trace, " ---\n\n", sep="") # note that we can no now longer get away with using numerics for # factors because factors have more than two levels # test set B: prepare the data ldose <- rep(0:5, 2) - 2 ldose1 <- c(0.1, 1.2, 2.3, 3.4, 4.5, 5.6, 0.3, 1.4, 2.5, 3.6, 4.7, 5.8) sex3 <- factor(rep(c("male", "female", "andro"), times=c(6,4,2))) fac3 <- factor(c("lev2", "lev2", "lev1", "lev1", "lev3", "lev3", "lev2", "lev2", "lev1", "lev1", "lev3", "lev3")) numdead <- c(1,4,9,13,18,20,0,2,6,10,12,16) numdead2 <- c(2,3,10,13,19,20,0,3,7,11,13,17) numdeadboth <- cbind(numdead, numdead2) isex <- as.double(sex3) # sex3 as an index df <- data.frame(sex3, ldose, ldose1, fac3) am <- earth(df, numdeadboth, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) af <- earth(numdeadboth ~ ., data=df, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) check.models.equal(am, af, "B predict with multiple level factors and a multiple real response") cat("20m head(predict(am, trace=", trace, ")\n", sep="") pm <- predict(am, trace=trace) if (trace) print(head(pm)) cat("B-21f head(predict(af, trace=", trace, ")\n", sep="") pf <- predict(af, trace=trace) if (trace) print(head(pf)) stop.if.not.identical("B-20", pm, pf) cat("B-31m predict(am, xdata.frame, trace=", trace, ") data frame with factors and wrong col names\n", sep="") xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) pm <- predict(am, xdata.frame, trace=trace) pm.ref <- pm stop.if.not.identical("B-31", pm.ref, pm) if (trace) print(pm) cat("B-31f predict(af, xdata.frame, trace=", trace, ") data frame with factors and wrong col names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("B-31", pm, pf) cat("B-31bm predict(am, xdata.frame, trace=", trace, ") data frame col names\n", sep="") xdata.frame <- data.frame(sex3=sex3[1], ldose=-2, ldose1=0.1, fac3=fac3[1]) pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("B-31", pm.ref, pm) cat("B-31bf predict(af, xdata.frame, trace=", trace, ") data frame col names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("B-31b", pm, pf) cat("B-32m predict(am, xdata.frame, trace=", trace, ") # data frame with names\n", sep="") xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) colnames(xdata.frame) <- c("sex3", "ldose", "ldose1", "fac3") pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("B-32", pm, pf) stop.if.not.identical("B-32", pm.ref, pm) cat("B-32f predict(af, xdata.frame, trace=", trace, ") # data frame with names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("B-32", pm, pf) cat("B-53m predict(am, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") xdata.frame <- data.frame(sex3[1], -2) expect.err(try(predict(am, xdata.frame, trace=trace)), "get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4") cat("B-53f predict(af, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") expect.err(try(predict(af, xdata.frame, trace=trace)), "get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4") cat("B-54m predict(am, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") xdata.frame <- data.frame(-2, sex3[1], 0.1, fac3[1]) colnames(xdata.frame) <- c("ldose", "sex3", "ldose1", "fac3") pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("B-54", pm.ref, pm) cat("B-54f predict(af, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("B-54", pm, pf) cat("B-55m predict(am, xdata.frame, trace=", trace, ") data frame without col names\n", sep="") xdata.frame <- data.frame(sex3[c(1,7)], c(-2,-1), c(0.1, 0.1), fac3[c(1,9)]) pm <- predict(am, xdata.frame, trace=trace) pm3.ref <- pm if (trace) print(pm) cat("B-55m again, but with same x data for both reponses\n") xdata.frame <- data.frame(sex3[c(1,1)], c(-2,-2), c(0.1, 0.1), fac3[c(1,1)]) pm <- predict(am, xdata.frame, trace=trace) print(pm) cat("B-55f predict(af, xdata.frame, trace=", trace, ") data frame without col names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("B-55", pm, pf) cat("B2-55bm predict(am, xdata.frame, trace=", trace, ") data frame col names\n", sep="") xdata.frame <- data.frame(sex3=sex3[c(1,7)], ldose=c(-2,-1), ldose1=c(0.1,0.1), fac3=fac3[c(1,9)]) pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("B2-55", pm3.ref, pm) cat("B2-55bf predict(af, xdata.frame, trace=", trace, ") data frame col names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("B2-55b", pm, pf) cat("B-56m predict(am, xdata.frame, trace=", trace, ") # data frame with col names\n", sep="") xdata.frame <- data.frame(sex3[c(1,7)], c(-2,-1), c(0.1, 0.1), fac3[c(1,9)]) colnames(xdata.frame) <- c("sex3", "ldose", "ldose1", "fac3") pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("B-56", pm3.ref, pm) cat("B-56f predict(af, xdata.frame, trace=", trace, ") # data frame with col names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("B-56", pm, pf) cat("B-57m predict(am, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") xdata.frame <- data.frame(sex3[c(1,7)], c(-2,-1)) expect.err(try(predict(am, xdata.frame, trace=trace)), "get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4") cat("B-57f predict(af, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") expect.err(try(predict(af, xdata.frame, trace=trace)), "get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4") stop.if.not.identical("B-57", pm, pf) cat("B-58m predict(am, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") xdata.frame <- data.frame(c(-2,-1), sex3[c(1,7)], c(0.1, 0.1), fac3[c(1,9)]) colnames(xdata.frame) <- c("ldose", "sex3", "ldose1", "fac3") pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("B-58", pm3.ref, pm) cat("B-58f predict(af, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("B-58", pm, pf) cat("B-50m data frame without column names, trace=", trace, "\n", sep="") xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) colnames(xdata.frame) <- NULL pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("B-34", pm.ref, pm) cat("B-60f data frame without column names, trace=", trace, "\n", sep="") xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) colnames(xdata.frame) <- NULL pf <- predict(am, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("B-60", pm, pf) cat("B-60f data frame without extra columns, trace=", trace, "\n", sep="") xdata.frame <- data.frame(sex3=sex3[1], extra1=99, ldose=-2, extra2=99, ldose1=0.1, fac3=fac3[1], extra3=sex3[7]) pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("B-60f", pm, pf) cat("\n--- C predict with multiple level factors and a 3 level factor response, trace=", trace, " ---\n\n", sep="") # test set C: prepare the data ldose <- rep(0:5, 2) - 2 ldose1 <- c(0.1, 1.2, 2.3, 3.4, 4.5, 5.6, 0.3, 1.4, 2.5, 3.6, 4.7, 5.8) sex3 <- factor(rep(c("male", "female", "andro"), times=c(6,4,2))) fac3 <- factor(c("lev2", "lev2", "lev1", "lev1", "lev3", "lev3", "lev2", "lev2", "lev1", "lev1", "lev3", "lev3")) facdead <- factor(c("dead2", "dead2", "dead3", "dead1", "dead3", "dead3", "dead1", "dead2", "dead1", "dead1", "dead3", "dead3")) isex <- as.double(sex3) # sex3 as an index df <- data.frame(sex3=sex3, ldose=ldose, ldose1=ldose1, fac3=fac3) am <- earth(df, facdead, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) df.with.response <- data.frame(sex3=sex3, ldose=ldose, ldose1=ldose1, facdead=facdead, fac3=fac3) af <- earth(facdead ~ ., data=df.with.response, trace=trace, pmethod=PMETHOD, nk=NK, degree=2) check.models.equal(am, af, "C predict with multiple level factors and a multiple real response") cat("20m head(predict(am, trace=", trace, ")\n", sep="") pm <- predict(am, trace=trace) if (trace) print(head(pm)) cat("C-21f head(predict(af, trace=", trace, ")\n", sep="") pf <- predict(af, trace=trace) if (trace) print(head(pf)) stop.if.not.identical("C-20", pm, pf) cat("C-31m predict(am, xdata.frame, trace=", trace, ") data frame with factors and wrong col names\n", sep="") xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) pm <- predict(am, xdata.frame, trace=trace) pm.ref <- pm stop.if.not.identical("C-31", pm.ref, pm) if (trace) print(pm) cat("C-31f predict(af, xdata.frame, trace=", trace, ") data frame with factors and wrong col names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("C-31", pm, pf) cat("C-31bm predict(am, xdata.frame, trace=", trace, ") data frame col names\n", sep="") xdata.frame <- data.frame(sex3=sex3[1], ldose=-2, ldose1=0.1, fac3=fac3[1]) pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("C-31", pm.ref, pm) cat("C-31bf predict(af, xdata.frame, trace=", trace, ") data frame col names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("C-31b", pm, pf) cat("C-32m predict(am, xdata.frame, trace=", trace, ") # data frame with names\n", sep="") xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) colnames(xdata.frame) <- c("sex3", "ldose", "ldose1", "fac3") pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("C-32", pm, pf) stop.if.not.identical("C-32", pm.ref, pm) cat("C-32f predict(af, xdata.frame, trace=", trace, ") # data frame with names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("C-32", pm, pf) cat("C-53m predict(am, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") xdata.frame <- data.frame(sex3[1], -2) expect.err(try(predict(am, xdata.frame, trace=trace)), "get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4") cat("C-53f predict(af, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") expect.err(try(predict(af, xdata.frame, trace=trace)), "get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4") cat("C-54m predict(am, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") xdata.frame <- data.frame(-2, sex3[1], 0.1, fac3[1]) colnames(xdata.frame) <- c("ldose", "sex3", "ldose1", "fac3") pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("C-54", pm.ref, pm) cat("C-54f predict(af, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("C-54", pm, pf) cat("C-55m predict(am, xdata.frame, trace=", trace, ") data frame without col names\n", sep="") xdata.frame <- data.frame(sex3[c(1,7)], c(-2,-1), c(0.1, 0.1), fac3[c(1,9)]) pm <- predict(am, xdata.frame, trace=trace) pm3.ref <- pm if (trace) print(pm) cat("C-55f predict(af, xdata.frame, trace=", trace, ") data frame without col names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("C-55", pm, pf) cat("C2-55bm predict(am, xdata.frame, trace=", trace, ") data frame col names\n", sep="") xdata.frame <- data.frame(sex3=sex3[c(1,7)], ldose=c(-2,-1), ldose1=c(0.1,0.1), fac3=fac3[c(1,9)]) pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("C2-55", pm3.ref, pm) cat("C2-55bf predict(af, xdata.frame, trace=", trace, ") data frame col names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("C2-55b", pm, pf) cat("C-56m predict(am, xdata.frame, trace=", trace, ") # data frame with col names\n", sep="") xdata.frame <- data.frame(sex3[c(1,7)], c(-2,-1), c(0.1, 0.1), fac3[c(1,9)]) colnames(xdata.frame) <- c("sex3", "ldose", "ldose1", "fac3") pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("C-56", pm3.ref, pm) cat("C-56f predict(af, xdata.frame, trace=", trace, ") # data frame with col names\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("C-56", pm, pf) cat("C-57m predict(am, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") xdata.frame <- data.frame(sex3[c(1,7)], c(-2,-1)) expect.err(try(predict(am, xdata.frame, trace=trace)), "get.earth.x from model.matrix.earth from predict.earth: x has 2 columns but expected 4") cat("C-57f predict(af, xdata.frame, trace=", trace, ") data frame with not enough columns, expect error message\n", sep="") expect.err(try(predict(af, xdata.frame, trace=trace)), "has 2 columns") stop.if.not.identical("C-57", pm, pf) cat("C-58m predict(am, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") xdata.frame <- data.frame(c(-2,-1), sex3[c(1,7)], c(0.1, 0.1), fac3[c(1,9)]) colnames(xdata.frame) <- c("ldose", "sex3", "ldose1", "fac3") pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("C-58", pm3.ref, pm) cat("C-58f predict(af, xdata.frame, trace=", trace, ") # data frame with cols in different order\n", sep="") pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("C-58", pm, pf) cat("C-50m data frame without column names, trace=", trace, "\n", sep="") xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) colnames(xdata.frame) <- NULL pm <- predict(am, xdata.frame, trace=trace) if (trace) print(pm) stop.if.not.identical("C-34", pm.ref, pm) cat("C-60f data frame without column names, trace=", trace, "\n", sep="") xdata.frame <- data.frame(sex3[1], -2, 0.1, fac3[1]) colnames(xdata.frame) <- NULL pf <- predict(am, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("C-60", pm, pf) cat("C-61f data frame without extra columns, trace=", trace, "\n", sep="") xdata.frame <- data.frame(sex3=sex3[1], extra1=99, ldose=-2, extra2=99, ldose1=0.1, fac3=fac3[1], extra3=sex3[7]) pf <- predict(af, xdata.frame, trace=trace) if (trace) print(pf) stop.if.not.identical("C-61", pm, pf) } test.predict.with.factors(trace=1) test.predict.with.factors(trace=0) cat("---test glm.predict---\n") ldose <- rep(0:5, 2) - 2 sex <- factor(rep(c("male", "female"), times=c(6,6))) numdead <- c(1,4,9,13,18,20,0,2,6,10,12,16) SF <- cbind(numdead, numalive=20 - numdead) cat("c1a: single response glm model with a binomial pair of y columns, fitted values, keepxy=0\n") c1a <- earth(SF ~ sex + ldose, glm=list(family="binomial"), linpreds=TRUE, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=0) c1ag <- glm(SF ~ sex + ldose, family="binomial") # use this as a reference c1a.predict <- predict(c1a, trace=1) c1ag.predict <- predict(c1ag, trace=1) check.almost.equal(c1a.predict, c1ag.predict, max=1e-10, msg="c1a fitted values, type=default link, keepxy=0", verbose=TRUE) c1a.predict <- predict(c1a, type="link", trace=1) c1ag.predict <- predict(c1ag, type="li", trace=1) check.almost.equal(c1a.predict, c1ag.predict, max=1e-10, msg="c1a fitted values, type=link, keepxy=0", verbose=TRUE) c1a.predict <- predict(c1a, type="response", trace=1) c1ag.predict <- predict(c1ag, type="resp", trace=1) check.almost.equal(c1a.predict, c1ag.predict, max=1e-10, msg="c1a fitted values, type=response, keepxy=0", verbose=TRUE) c1a.predict <- predict(c1a, type="e", trace=1) dead.frac <- numdead / (numdead + (20 - numdead)) c1ae <- earth(dead.frac ~ sex + ldose, trace=1, linpreds=TRUE, pmethod=PMETHOD, nk=NK, degree=1, keepxy=0) c1ae.predict <- predict(c1ae, trace=1) check.almost.equal(c1a.predict, c1ae.predict, max=1e-10, msg="c1a fitted values, type=earth, keepxy=0", verbose=TRUE) cat("c1b: single response glm model with a binomial pair of y columns\n") c1b <- earth(SF ~ sex + ldose, glm=list(family="binomial"), linpreds=TRUE, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) c1be <- earth(numdead ~ sex + ldose, linpreds=TRUE, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) c1bg <- glm(SF ~ sex + ldose, family="binomial") # use this as a reference newdata <- data.frame(sex=sex[1], ldose=2) c1b.predict <- predict(c1b, newdata, trace=1) stopifnot(dim(c1b.predict) == c(1,1)) check.almost.equal(c1b.predict, predict(c1bg, newdata), max=1e-10, msg="c1b", verbose=TRUE) c1b.link.predict <- predict(c1b, newdata, type="link", trace=1) # should be same as above because default is link check.almost.equal(c1b.link.predict, c1b.predict, max=1e-10, msg="c1b link", verbose=TRUE) c1b.predict <- predict(c1b, newdata, type="r") stopifnot(dim(c1b.predict) == c(1,1)) check.almost.equal(c1b.predict, predict(c1bg, newdata, type="response"), max=1e-10, msg="c1b type=response", verbose=TRUE) c1b.predict <- predict(c1b, newdata, type="earth") stopifnot(dim(c1b.predict) == c(1,1)) print(c1b.predict) newdata <- data.frame(sex=sex[c(1,3,7,9)], ldose=ldose[c(1,3,7,9)]) c1b.predict <- predict(c1b, newdata, trace=1) stopifnot(dim(c1b.predict) == c(4,1)) check.almost.equal(c1b.predict, predict(c1bg, newdata), max=1e-10, msg="c1b multiple rows", verbose=TRUE) c1b.predict <- predict(c1b, newdata, type="response", trace=1) stopifnot(dim(c1b.predict) == c(4,1)) check.almost.equal(c1b.predict, predict(c1bg, newdata, type="response"), max=1e-10, msg="c1b multiple rows type=response", verbose=TRUE) c1b.predict <- predict(c1b, newdata, type="terms", trace=0) print(c1b.predict) c1be.predict <- predict(c1be, newdata, type="terms") print(c1be.predict) c1bg.predict <- predict(c1bg, newdata, type="terms") print(c1bg.predict) # commented out because multiple binomial pairs are no longer supported # cat("c2: double response glm model with two y binomial pairs\n") # SF2 <- cbind(numdead, numalive=20 - numdead, numdead2=numdead, numalive2=20 - numdead) # c2 <- earth(SF2 ~ sex + ldose, glm=list(family="binomial"), linpreds=TRUE, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) # c2e <- earth(data.frame(sex, ldose), data.frame(numdead,numdead), linpreds=TRUE, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) # c2g <- glm(SF ~ sex + ldose, family="binomial") # use this as a reference # newdata <- data.frame(sex=sex[1], ldose=2) # c2.predict <- predict(c2, newdata, trace=1) # stopifnot(dim(c2.predict) == c(1,2)) # check.almost.equal(c2.predict[,1], predict(c2g, newdata), max=1e-10, msg="c2", verbose=TRUE) # # c2.link.predict <- predict(c2, newdata, type="link", trace=1) # should be same as above because default is link # check.almost.equal(c2.link.predict, c2.predict, max=1e-10, msg="c2 link", verbose=TRUE) # # c2.predict <- predict(c2, newdata, type="response") # stopifnot(dim(c2.predict) == c(1,2)) # check.almost.equal(c2.predict[,1], predict(c2g, newdata, type="response"), max=1e-10, msg="c2 multiple rows type=response", verbose=TRUE) # # newdata <- data.frame(sex=sex[c(1,3,7,9)], ldose=ldose[c(1,3,7,9)]) # c2.predict <- predict(c2, newdata) # stopifnot(dim(c2.predict) == c(4,2)) # check.almost.equal(c2.predict[,1], predict(c2g, newdata), max=1e-10, msg="c2 column1", verbose=TRUE) # check.almost.equal(c2.predict[,2], predict(c2g, newdata), max=1e-10, msg="c2 column2", verbose=TRUE) # # c2.predict <- predict(c2, newdata, type="response") # stopifnot(dim(c2.predict) == c(4,2)) # check.almost.equal(c2.predict[,1], predict(c2g, newdata, type="response"), max=1e-10, msg="c2 column1 multiple rows type=response", verbose=TRUE) # check.almost.equal(c2.predict[,2], predict(c2g, newdata, type="response"), max=1e-10, msg="c2 column2 multiple rows type=response", verbose=TRUE) # # c2.predict <- predict(c2, newdata, type="earth", trace=1) # stopifnot(dim(c2.predict) == c(4,2)) # check.almost.equal(c2.predict[,1], predict(c2e, newdata, trace=1), max=1e-10, msg="c2 column1 multiple rows type=earth", verbose=TRUE) # check.almost.equal(c2.predict[,2], predict(c2e, newdata, trace=1), max=1e-10, msg="c2 column2 multiple rows type=earth", verbose=TRUE) cat("c3a: single response glm model with a boolean response, fitted values, keepxy=0\n") mybool <- rep(c(FALSE, TRUE), times=c(6,6)) data1 <- data.frame(mybool, sex, ldose) c3a <- earth(mybool ~ sex + ldose, data=data1, glm=list(family="binomial"), linpreds=TRUE, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=0) c3ag <- glm(mybool ~ sex + ldose, family="binomial") # use this as a reference c3ae <- earth(mybool ~ sex + ldose, data=data1, linpreds=TRUE, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) c3a.predict <- predict(c3a, trace=1) c3ag.predict <- predict(c3ag, trace=1) # TODO why does max have to be big here? check.almost.equal(c3a.predict, c3ag.predict, max=1e-7, msg="c3a fitted values, type=default link, keepxy=0", verbose=TRUE) c3a.predict <- predict(c3a, type="link", trace=1) c3ag.predict <- predict(c3ag, type="link", trace=1) check.almost.equal(c3a.predict, c3ag.predict, max=1e-7, msg="c3a fitted values, type=link, keepxy=0", verbose=TRUE) c3a.predict <- predict(c3a, type="response", trace=1) c3ag.predict <- predict(c3ag, type="response", trace=1) check.almost.equal(c3a.predict, c3ag.predict, max=1e-10, msg="c3a fitted values, type=response, keepxy=0", verbose=TRUE) c3a.predict <- predict(c3a, type="earth", trace=1) c3ae.predict <- predict(c3ae, trace=1) check.almost.equal(c3a.predict, c3ae.predict, max=1e-10, msg="c3a fitted values, type=earth, keepxy=0", verbose=TRUE) c3a.response.predict <- predict(c3a, type="response") c3a.class.predict <- predict(c3a,type="class") stopifnot(c3a.class.predict == (c3a.response.predict > .5)) cat("c3b: single response glm model with a boolean response, fitted values, keepxy=1\n") c3b <- earth(mybool ~ sex + ldose, glm=list(family="binomial"), linpreds=TRUE, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) c3bg <- glm(mybool ~ sex + ldose, family="binomial") # use this as a reference c3be <- earth(mybool ~ sex + ldose, linpreds=TRUE, pmethod=PMETHOD, nk=NK, degree=1, keepxy=0) c3b.predict <- predict(c3b, trace=1) # fitted values c3bg.predict <- predict(c3bg, trace=1) check.almost.equal(c3b.predict, c3bg.predict, max=1e-7, msg="c3b fitted values, type=default link, keepxy=0", verbose=TRUE) c3b.predict <- predict(c3b, type="link", trace=1) c3bg.predict <- predict(c3bg, type="link", trace=1) check.almost.equal(c3b.predict, c3bg.predict, max=1e-7, msg="c3b fitted values, type=link, keepxy=0", verbose=TRUE) c3b.predict <- predict(c3b, type="response", trace=1) c3bg.predict <- predict(c3bg, type="response", trace=1) check.almost.equal(c3b.predict, c3bg.predict, max=1e-10, msg="c3b fitted values, type=response, keepxy=0", verbose=TRUE) c3b.predict <- predict(c3b, type="earth", trace=1) c3be.predict <- predict(c3be, trace=1) check.almost.equal(c3b.predict, c3be.predict, max=1e-10, msg="c3b fitted values, type=earth, keepxy=0", verbose=TRUE) c3b.response.predict <- predict(c3b, type="response") c3b.class.predict <- predict(c3b,type="cla") stopifnot(c3b.class.predict == (c3b.response.predict > .5)) cat("c3c: single response glm model with a boolean response\n") c3c <- earth(mybool ~ sex + ldose, data=data1, linpreds=TRUE, glm=list(family="binomial"), trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=0) c3cg <- glm(mybool ~ sex + ldose, data=data1, family="binomial") # use this as a reference c3ce <- earth(mybool ~ sex + ldose, data=data1, linpreds=TRUE, pmethod=PMETHOD, nk=NK, degree=1, keepxy=0) newdata <- data.frame(sex=sex[1], ldose=2) c3c.predict <- predict(c3c, newdata) stopifnot(dim(c3c.predict) == c(1,1)) check.almost.equal(c3c.predict, predict(c3cg, newdata), max=1e-10, msg="c3c", verbose=TRUE) c3c.predict <- predict(c3c, newdata, type="response") stopifnot(dim(c3c.predict) == c(1,1)) check.almost.equal(c3c.predict, predict(c3cg, newdata, type="response"), max=1e-10, msg="c3c type=response", verbose=TRUE) newdata <- data.frame(sex=sex[c(1,3,7,9)], ldose=ldose[c(1,3,7,9)]) c3c.predict <- predict(c3c, newdata) stopifnot(dim(c3c.predict) == c(4,1)) # TODO why does the max have to be bigger on this? check.almost.equal(c3c.predict, predict(c3cg, newdata), max=1e-7, msg="c3c multiple rows", verbose=TRUE) c3c.predict <- predict(c3c, newdata, type="response") stopifnot(dim(c3c.predict) == c(4,1)) check.almost.equal(c3c.predict, predict(c3cg, newdata, type="response"), max=1e-10, msg="c3c multiple rows type=response", verbose=TRUE) c3c.response.predict <- predict(c3c, type="response") c3c.class.predict <- predict(c3c,type="cl") stopifnot(c3c.class.predict == (c3c.response.predict > .5)) cat("c3d: single response glm model with a two level factor response\n") cat("Expect \"did not converge warnings\", it doesn't matter for our purposes here\n") myfac <- gl(2, 3, length=12, labels = c("Control", "Treat")) c3d <- earth(myfac ~ ldose + sex, data=data1, glm=list(family="binomial"), trace=0, pmethod=PMETHOD, nk=NK, degree=1) c3d.class.predict <- predict(c3d,type="cl") # we also test here that the type can be abbreviated stopifnot(c3d.class.predict == myfac) cat("c4: multiple response glm model with a factor response\n") fac3 <- factor(rep(c("A", "B", "C"), times=c(4,3,5))) cat("Expect \"did not converge warnings\", it doesn't matter for our purposes here\n") c4 <- earth(fac3 ~ sex + ldose, linpreds=TRUE, glm=list(family="binomial"), trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) c4g <- glm(fac3 ~ sex + ldose, family="binomial") # use this as a reference c4.notrace <- earth(fac3 ~ sex + ldose, linpreds=TRUE, glm=list(family="binomial"), trace=0, pmethod=PMETHOD) newdata <- data.frame(sex=sex[1], ldose=2) c4.predict <- predict(c4, newdata) stopifnot(dim(c4.predict) == c(1,3)) # minus needed on predict because of different handling of factors check.almost.equal(c4.predict[1,1], -predict(c4g, newdata), max=1e-8, msg="c4", verbose=TRUE) newdata <- data.frame(sex=sex[c(1,3,7,9)], ldose=ldose[c(1,3,7,9)]) c4.predict <- predict(c4, newdata) stopifnot(dim(c4.predict) == c(4,3)) check.almost.equal(c4.predict[,1], -predict(c4g, newdata), max=1e-8, msg="c4 multiple rows", verbose=TRUE) c4.predict <- predict(c4, newdata, type="response") stopifnot(dim(c4.predict) == c(4,3)) check.almost.equal(1-c4.predict[,1], predict(c4g, newdata, type="response"), max=1e-10, msg="c4 multiple rows type=response", verbose=TRUE) cat("c5: multiple response glm model with two multi level factor responses\n") fac3 <- factor(rep(c("A", "B", "C"), times=c(4,3,5))) fac4 <- factor(rep(c("P", "Q", "R", "S"), times=c(3,3,3,3))) big.dataframe <- data.frame(fac3, fac4) c5 <- earth(data.frame(sex, ldose), big.dataframe, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) stopifnot(colnames(c5$coef) == c("fac3A", "fac3B", "fac3C", "fac4P", "fac4Q", "fac4R", "fac4S")) stopifnot(is.null(c5$glm.bpairs)) cat("c6: multiple response earth model with mixed responses\n") big.dataframe2 <- data.frame(SF, fac3, fac4, SF+1, sex, fac4, SF+3) c6 <- earth(data.frame(sex, ldose), big.dataframe2, trace=1, pmethod=PMETHOD, nk=NK, degree=1, keepxy=1) stopifnot(colnames(c6$coef) == c("numdead", "numalive", "fac3A", "fac3B", "fac3C", "fac4P", "fac4Q", "fac4R", "fac4S", "numdead.1", "numalive.1", "sex", "fac4.1P", "fac4.1Q", "fac4.1R", "fac4.1S", "numdead.2", "numalive.2")) stopifnot(is.null(c6$glm.bpairs)) # residuals a <- earth(pclass ~ ., data=etitanic) printh(residuals(a), max.print=3) a <- earth(pclass ~ ., data=etitanic, glm=list(family="b")) printh(residuals(a), expect.warning=TRUE, max.print=3) printh(residuals(a, warn=FALSE), max.print=3) printh(resid(a, type="earth"), max.print=3) printh(resid(a, type="deviance"), max.print=3) printh(resid(a, type="glm.pearson"), max.print=3) printh(resid(a, type="glm.working"), max.print=3) printh(resid(a, type="glm.response"), max.print=3) printh(resid(a, type="glm.partial"), max.print=3) expect.err(try(printh(resid(a, type="nonesuch"), max.print=3)), "Choose one of") expect.err(try(printh(resid(a, type="g"), max.print=3)), "ambiguous") # type="g" is ambiguous expect.err(try(printh(resid(a, type="standardize"), max.print=3)), "model was not built with varmod.method") # model was not built with varmod.method # tests based on Gavin Simpson's bug report # fit a MARS model allowing one-way interactions mod.Gamma <- earth(O3 ~ . - doy, data = ozone1, degree = 2, glm = list(family = Gamma)) for(type in c("earth", "deviance", "glm.pearson", "glm.working", "glm.response", "glm.partial")) { cat("residuals.earth Gamma type=", type, ":\n", sep="") print(head(resid(mod.Gamma, type = type), n=2)) print(tail(resid(mod.Gamma, type = type), n=2)) } mod.binomial <- earth(survived ~ ., data = etitanic, degree = 2, glm = list(family = binomial)) for(type in c("earth", "deviance", "glm.pearson", "glm.working", "glm.response", "glm.partial")) { cat("residuals.earth binomial type=", type, ":\n", sep="") print(head(residuals(mod.binomial, type = type), n=2)) print(tail(residuals(mod.binomial, type = type), n=2)) } # intercept only model cat("a.intercept.only: intercept only logistic model\n\n") # This seed chosen so call to earth below has one predictor model in 1st # cv fold and intercept-only in 2nd cv fold, that way we test both. set.seed(3) df <- data.frame(aaa = round(runif(18)), bbb = runif(18), ccc = rnorm(18)) a.intercept.only <- earth(aaa ~ bbb + ccc, data = df, glm=list(family=binomial), trace=1, nfold=2) show.earth.models(a.intercept.only) cat("\nsummary(a.intercept.only, details=TRUE)\n\n", sep="") print(summary(a.intercept.only, details=TRUE)) printh(predict(a.intercept.only)) printh(predict(a.intercept.only, type="link")) printh(predict(a.intercept.only, type="response")) printh(predict(a.intercept.only, type="earth")) g <- a.intercept.only$glm.list[[1]] printh(predict(g, type="link")) printh(predict(g, type="response")) new.df <- df[3:5, ] printh(predict(a.intercept.only, type="response")) printh(predict(a.intercept.only, newdata=new.df, trace=1, type="link")) printh(predict(a.intercept.only, newdata=new.df, trace=1, type="response")) printh(predict(a.intercept.only, newdata=new.df, type="earth")) printh(predict(a.intercept.only, newdata=new.df, type="class")) # cat("Expect Warning: predict.earth: returning the earth (not glm) terms\n") printh(predict(a.intercept.only, newdata=new.df, type="terms")) set.seed(1235) a <- earth(survived ~ ., data=etitanic, glm=list(family=binomial), nfold=2) plot.earth.models(list(a.intercept.only, a), main="plot.earth.models\nlist(a.intercept.only, a)") plot.earth.models(list(a, a.intercept.only), main="plot.earth.models\nlist(a, a.intercept.only)", legend.pos="topleft", jitter=.01) # nothing will plot for the next call plot.earth.models(list(a.intercept.only, a.intercept.only), main="plot.earth.models\nlist(a.intercept.only, a.intercept.only)") # test position of legend and "intercep-only model" message when only one term in model a.intercept.pruned <- update(a.intercept.only, nprune=1, nfold=1) show.earth.models(a.intercept.pruned) # misc tests cat("---misc 1---\n") sex1 <- factor(rep(c("male", "female"), times=c(6,6))) sex2 <- factor(rep(c("male", "female"), times=c(6,6))) earth(numdead, cbind(sex1, sex2, sex1), trace=1) # one duplicate name sex1 <- factor(rep(c("male", "female"), times=c(6,6))) sex2 <- factor(rep(c("male", "female"), times=c(6,6))) earth(numdead, cbind(sex1, sex2, sex1, sex1), trace=1) # two duplicate names # test column expansion when y is a data frame in earth.default cat("---misc 2---\n") ldose <- rep(0:5, 2) - 2 ldose1 <- c(0.1, 1.2, 2.3, 3.4, 4.5, 5.6, 0.3, 1.4, 2.5, 3.6, 4.7, 5.8) sex <- factor(rep(c("male", "female"), times=c(6,6))) sex2 <- sex sex3 <- factor(rep(c("male", "female", "andro"), times=c(6,4,2))) fac3 <- factor(c("lev2", "lev2", "lev1", "lev1", "lev3", "lev3", "lev2", "lev2", "lev1", "lev1", "lev3", "lev3")) facdead <- factor(c("dead2", "dead2", "dead3", "dead1", "dead3", "dead3", "dead1", "dead2", "dead1", "dead1", "dead3", "dead3")) isex <- as.double(sex3) # sex3 as an index df1 <- data.frame(sex2, d_=facdead, sex, sex, isex) af <- earth(data.frame(sex3,ldose,fac3,isex), df1, trace=1, pmethod=PMETHOD, nk=NK, degree=2) cat("---misc 3---\n") # strings in input matrices, get converted to factors and a warning issued # TODO would like to improve the error message (says 'x' even when 'y') # TODO Apr 2013 warning no longer issued (R changed), is that ok? ldose <- rep(0:5, 2) - 2 ldose1 <- c(0.1, 1.2, 2.3, 3.4, 4.5, 5.6, 0.3, 1.4, 2.5, 3.6, 4.7, 5.8) sex2 <- rep(c("male", "female"), times=c(6,6)) # y cannot be a character variable expect.err(try(earth(sex2, sex2, trace=1)), "y is a character variable: ") expect.err(try(earth(sex2~ldose1, trace=1)), "y is a character variable: ") # but note that this is ok earth(sex2, data.frame(sex2=sex2), trace=1) # test update.earth with bpairs argument (for now always do forward pass if bpairs) cat("---misc 4---\n") volumei <- as.integer(trees$Volume) x1 <- trees$Height a <- earth(x1, cbind(volumei, 100-volumei), glm=list(family=binomial)) update(a, trace=1, glm=list(family=binomial)) a <- earth(x1, cbind(volumei, 100-volumei), glm=list(family=binomial)) update(a, trace=1, glm=list(family=binomial)) source("test.epilog.R") earth/inst/slowtests/test.weights.bat0000755000176200001440000000154613514230362017531 0ustar liggesusers@rem test.weights.bat @rem Stephen Milborrow Dec 2014 Shrewsbury @echo test.weights.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.weights.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.weights.Rout: @echo. @tail test.weights.Rout @echo test.weights.R @exit /B 1 :good1 mks.diff test.weights.Rout test.weights.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.weights.save.ps @exit /B 1 :good2 @rem test.weights.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.weights.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.weights.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.earthmain.gcc64.bat0000755000176200001440000000433013514230362020726 0ustar liggesusers@rem test.earthmain.gcc64.bat: test 64 bit standalone earth.c with main() @rem @rem TODO I haven't yet been able to get this to work: @rem Crashes in daxpy_ call in FindKnot, ok with USE_BLAS = 0. cp "C:/Program Files/R/R-3.6.1/bin/x64/R.dll" . @if %errorlevel% neq 0 goto error cp "C:/Program Files/R/R-3.6.1/bin/x64/Rblas.dll" . @if %errorlevel% neq 0 goto error cp "C:/Program Files/R/R-3.6.1/bin/x64/Riconv.dll" . @if %errorlevel% neq 0 goto error cp "C:/Program Files/R/R-3.6.1/bin/x64/Rgraphapp.dll" . @if %errorlevel% neq 0 goto error @rem cp "C:/Program Files/R/R-3.6.1/bin/x64/Rzlib.dll" . @rem @if %errorlevel% neq 0 goto error @rem you may have to create Rdll_x64.lib and Rblas_x64.lib beforehand @cp "../../.#/Rdll_x64.lib" Rdll.lib @if %errorlevel% neq 0 goto error @cp "../../.#/Rblas_x64.lib" Rblas.lib @if %errorlevel% neq 0 goto error @rem modify the path to include gcc, if needed @rem only do it if needed @set | egrep -i "PATH=[^;]*Rtools.mingw_64" >NUL && goto :donesetpath @echo Modifying path for 64 bit Rtools and R @set PATH=C:\Rtools\mingw_64\bin;^ C:\Rtools\bin;^ C:\Program Files\R\R-3.2.2\bin\x64;^ C:\Program Files\gs\gs9.19\bin;^ %PATH% :donesetpath gcc -DSTANDALONE -DMAIN -Wall -pedantic -Wextra -O3 -std=gnu99^ -m64^ -I"/a/r/ra/include" -I../../inst/slowtests ../../src/earth.c^ Rdll.lib Rblas.lib -o earthmain-gcc64.exe @if %errorlevel% neq 0 goto error @rem earthmain-gcc64.exe > test.earthmain-gcc64.out @rem @if %errorlevel% neq 0 goto error earthmain-gcc64.exe @rem no errorlevel test, diff will do check for discrepancies @rem @if %errorlevel% neq 0 goto error mks.diff test.earthmain-gcc64.out test.earthmain.out64.save @if %errorlevel% neq 0 goto error @rm -f R.dll Rblas.dll Riconv.dll Riconv.dll Rgraphapp.dll Rzlib.dll Rdll.lib Rblas.lib earthmain-gcc.* test.earthmain-gcc64.* *.o @exit /B 0 :error @exit /B %errorlevel% earth/inst/slowtests/test.incorrect.Rout.save0000644000176200001440000000543713451164531021173 0ustar liggesusers> # test.incorrect.R: example incorrect model built by earth > # Stephen Milborrow May 2015 Berea > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > options(digits=4) > > printf <- function(format, ...) cat(sprint(format, ...)) # like c printf > > sos <- function(x) sum(as.vector(x^2)) # sum of squares > > func <- function(x) # bivariate with interaction + { + x[,1] + x[,2] + (x[,1] * x[,2]) + .3 * rnorm(nrow(x)) + } > > n <- 30 > set.seed(n) > n <- 11 > seed <- 17 > set.seed(100 + seed) > x1 <- sort(runif(n, -(n-1), n+1)) > x2 <- runif(n, -(n-1), n+1) > x <- data.frame(x1=x1, x2=x2) > set.seed(101 + seed) > > x1test <- runif(10000, -n, n) > x2test <- runif(10000, -n, n) > xtest <- data.frame(x1=x1test, x2=x2test) > colnames(x) <- colnames(xtest) <- c("x1", "x2") > set.seed(103 + seed) > ytest <- func(xtest) > > par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > correct.mod <- earth(xtest, ytest, degree=2, trace=0, minspan=-1, Force.weights=TRUE) > plotmo(correct.mod, degree1=0, do.par=FALSE, main="correct model\nx1 + x2 + x1*x2") > plotmo(correct.mod, degree1=0, do.par=FALSE, main="correct model", type2="im") > > set.seed(102 + seed) > y <- func(x) > incorrect.mod <- earth(x, y, degree=2, trace=2, minspan=-1) x[11,2] with colnames x1 x2 y[11,1] with colname y, and values 18.58, -22.71, -56.16, -3.128... Forward pass: minspan 6 endspan 4 x[11,2] 176 Bytes bx[11,21] 1.8 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 -2.2926 0.1769 0.1769 2 x2 4.9696 2 3 1 4 -4.9885 0.6257 0.4489 1 x1 -9.9743< 4 2 2 6 -inf 0.8630 0.2373 1 x1 -9.9743< 5 3 2 reject (negative GRSq) GRSq -Inf at 5 terms, 4 terms used After forward pass GRSq -in RSq 0.863 Forward pass complete: 5 terms, 4 terms used Prune backward penalty 3 nprune null: selected 2 of 4 terms, and 2 of 2 preds After pruning pass GRSq 0.0737 RSq 0.479 > print(incorrect.mod) Selected 2 of 4 terms, and 2 of 2 predictors Termination condition: GRSq -Inf at 4 terms Importance: x1, x2 Number of terms at each degree of interaction: 1 0 1 GCV 1278 RSS 6534 GRSq 0.07365 RSq 0.4789 > test.rsq <- 1 - sos(ytest - predict(incorrect.mod, newdata=xtest)) / sos(ytest - mean(ytest)) > plotmo(incorrect.mod, degree1=0, do.par=FALSE, main="incorrect model") > plotmo(incorrect.mod, degree1=0, do.par=FALSE, main="incorrect model", pt.col=2, type2="im") > points(xtest[,1], xtest[,2], col=3, pch=20, cex=.05) > > source("test.epilog.R") earth/inst/slowtests/test.mem.bat0000755000176200001440000000141213514230362016625 0ustar liggesusers@rem test.mem.bat @echo test.mem.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.mem.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.mem.Rout: @echo. @tail test.mem.Rout @echo test.mem.R @exit /B 1 :good1 mks.diff test.mem.Rout test.mem.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.mem.save.ps @exit /B 1 :good2 @rem test.mem.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.mem.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.mem.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.varmod.Rout.save0000644000176200001440000031367513514234432020477 0ustar liggesusers> # test.varmod.R > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > options(warn=2) > printh <- function(caption) + cat("===", caption, "\n", sep="") > > CAPTION <- NULL > > multifigure <- function(caption, nrow=3, ncol=3) + { + CAPTION <<- caption + printh(caption) + par(mfrow=c(nrow, ncol)) + par(cex = 0.8) + par(mar = c(3, 3, 5, 0.5)) # small margins but space for right hand axis + par(mgp = c(1.6, 0.6, 0)) # flatten axis elements + oma <- par("oma") # make space for caption + oma[3] <- 2 + par(oma=oma) + } > do.caption <- function() # must be called _after_ first plot on new page + mtext(CAPTION, outer=TRUE, font=2, line=1, cex=1) > old.par <- par(no.readonly=TRUE) > > multifigure("test predict.earth with pints", 2, 2) ===test predict.earth with pints > > set.seed(2) > earth.trees <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="earth") > > old.environment <- attr(earth.trees$varmod, ".Environment") > stopifnot(is.environment(old.environment)) > # following necessary else print.default prints a different default environment hex address each time > attr(earth.trees$varmod, ".Environment") <- NULL > printh("print.default(earth.trees$varmod)") ===print.default(earth.trees$varmod) > print.default(earth.trees$varmod) $call varmod(parent = parent, method = method, exponent = exponent, conv = conv, clamp = clamp, minspan = minspan, trace = trace, parent.x = x, parent.y = y, model.var = model.var, degree = ..1) $parent Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9391778 $method [1] "earth" $exponent [1] 1 $lambda [1] 1 $rmethod [1] "hc12" $converged [1] TRUE $iters [1] 1 $residmod Selected 2 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: RHS Number of terms at each degree of interaction: 1 1 (additive model) GCV 3.469431 RSS 87.74303 GRSq 0.201497 RSq 0.3044152 $min.sd [1] 0.3768615 $model.var [,1] [1,] 0.781975654 [2,] 0.380089019 [3,] 0.582758485 [4,] 0.504914123 [5,] 0.178568741 [6,] 0.028039319 [7,] 0.090059658 [8,] 0.422836830 [9,] 0.082078906 [10,] 0.088552129 [11,] 0.345306201 [12,] 0.630158271 [13,] 0.336500919 [14,] 0.133563294 [15,] 0.837790056 [16,] 2.204958223 [17,] 0.201022761 [18,] 1.807147402 [19,] 0.268167169 [20,] 1.809333273 [21,] 0.640120276 [22,] 0.370925125 [23,] 0.925079265 [24,] 0.319450065 [25,] 0.530235103 [26,] 1.307173363 [27,] 0.037534136 [28,] 1.257092327 [29,] 0.776503513 [30,] 0.007620971 [31,] 6.082359146 $abs.resids Volume [1,] 0.9972120 [2,] 0.9723250 [3,] 1.8202611 [4,] 1.3499478 [5,] 0.8303927 [6,] 1.3274450 [7,] 3.8646145 [8,] 1.2316707 [9,] 3.3429505 [10,] 0.3015926 [11,] 4.3500327 [12,] 0.9355264 [13,] 1.0922872 [14,] 0.4657214 [15,] 3.8742754 [16,] 4.0735748 [17,] 8.8560415 [18,] 1.3975099 [19,] 3.0799671 [20,] 4.5302574 [21,] 4.9795594 [22,] 0.6962448 [23,] 3.3650804 [24,] 5.3763683 [25,] 2.9142428 [26,] 4.1766153 [27,] 2.9175095 [28,] 3.1228458 [29,] 5.5561498 [30,] 6.0503894 [31,] 5.3658904 $parent.x Girth [1,] 8.3 [2,] 8.6 [3,] 8.8 [4,] 10.5 [5,] 10.7 [6,] 10.8 [7,] 11.0 [8,] 11.0 [9,] 11.1 [10,] 11.2 [11,] 11.3 [12,] 11.4 [13,] 11.4 [14,] 11.7 [15,] 12.0 [16,] 12.9 [17,] 12.9 [18,] 13.3 [19,] 13.7 [20,] 13.8 [21,] 14.0 [22,] 14.2 [23,] 14.5 [24,] 16.0 [25,] 16.3 [26,] 17.3 [27,] 17.5 [28,] 17.9 [29,] 18.0 [30,] 18.0 [31,] 20.6 $parent.y Volume [1,] 10.3 [2,] 10.3 [3,] 10.2 [4,] 16.4 [5,] 18.8 [6,] 19.7 [7,] 15.6 [8,] 18.2 [9,] 22.6 [10,] 19.9 [11,] 24.2 [12,] 21.0 [13,] 21.4 [14,] 21.3 [15,] 19.1 [16,] 22.2 [17,] 33.8 [18,] 27.4 [19,] 25.7 [20,] 24.9 [21,] 34.5 [22,] 31.7 [23,] 36.3 [24,] 38.3 [25,] 42.6 [26,] 55.4 [27,] 55.7 [28,] 58.3 [29,] 51.5 [30,] 51.0 [31,] 77.0 $iter.rsq [1] 0.3044152 $iter.stderr (Intercept) bxh(25.6817-RHS) 0.39973858 0.06692328 attr(,"class") [1] "varmod" > attr(earth.trees$varmod, ".Environment") <- old.environment > > printh("summary(earth.trees)") ===summary(earth.trees) > print(summary(earth.trees)) Call: earth(formula=Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="earth") coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9391778 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.939 0.033 9.74 7.81 varmod: method "earth" min.sd 0.377 iter.rsq 0.304 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 4.8820836 0.500998 10 h(25.6817-Volume) -0.2988094 0.0838759 28 mean smallest largest ratio 95% prediction interval 14.79879 1.47727 19.13742 12.95458 68% 80% 90% 95% response values in prediction interval 68 90 94 97 > > # level arg not allowed with interval="se" > expect.err(try(predict(earth.trees, interval="se", level=.8))) Error : predict.varmod: the level argument is not allowed with type="se" Got error as expected from try(predict(earth.trees, interval = "se", level = 0.8)) > > printh("predict(earth.trees, interval=\"se\")") ===predict(earth.trees, interval="se") > stderrs <- predict(earth.trees, interval="se") > print(stderrs) [1] 0.3768615 0.4777686 0.6826204 2.4238612 2.6287131 2.7311390 2.9359909 [8] 2.9359909 3.0384168 3.1408428 3.2432687 3.3456946 3.3456946 3.6529724 [15] 3.9602502 4.8820836 4.8820836 4.8820836 4.8820836 4.8820836 4.8820836 [22] 4.8820836 4.8820836 4.8820836 4.8820836 4.8820836 4.8820836 4.8820836 [29] 4.8820836 4.8820836 4.8820836 > > # level arg not allowed with interval="abs.residual" > expect.err(try(predict(earth.trees, interval="abs.res", level=.8))) Error : predict.varmod: the level argument is not allowed with type="abs.residual" Got error as expected from try(predict(earth.trees, interval = "abs.res", level = 0.8)) > > printh("predict(earth.trees, interval=\"abs.residual\")") ===predict(earth.trees, interval="abs.residual") > stderrs <- predict(earth.trees, interval="abs.residual") > print(stderrs) [1] 0.3006919 0.3812042 0.5446523 1.9339615 2.0974096 2.1791337 2.3425818 [8] 2.3425818 2.4243059 2.5060299 2.5877540 2.6694781 2.6694781 2.9146503 [15] 3.1598225 3.8953391 3.8953391 3.8953391 3.8953391 3.8953391 3.8953391 [22] 3.8953391 3.8953391 3.8953391 3.8953391 3.8953391 3.8953391 3.8953391 [29] 3.8953391 3.8953391 3.8953391 > > expect.err(try(predict(earth.trees, newdata=trees, interval="cint"))) Error : predict.varmod: newdata is not allowed with interval="cint" Got error as expected from try(predict(earth.trees, newdata = trees, interval = "cint")) > > printh("predict(earth.trees, interval=\"cint\")") ===predict(earth.trees, interval="cint") > cints <- predict(earth.trees, interval="cint") > print(cints) fit lwr upr 1 9.913855 8.180670 11.64704 2 10.942195 9.733851 12.15054 3 11.627755 10.131546 13.12396 4 17.455018 16.062320 18.84772 5 18.140578 17.312349 18.96881 6 18.483359 18.155164 18.81155 7 19.168919 18.580735 19.75710 8 19.168919 17.894435 20.44340 9 19.511699 18.950181 20.07322 10 19.854479 19.271239 20.43772 11 20.197259 19.045531 21.34899 12 20.540040 18.984171 22.09591 13 20.540040 19.403090 21.67699 14 21.568380 20.852086 22.28467 15 22.596721 20.802748 24.39069 16 25.681742 22.771372 28.59211 17 25.681742 24.802981 26.56050 18 27.052863 24.418080 29.68765 19 28.423983 27.409019 29.43895 20 28.766764 26.130387 31.40314 21 30.080913 28.512795 31.64903 22 31.395063 30.201373 32.58875 23 33.366287 31.481173 35.25140 24 43.222408 42.114638 44.33018 25 45.193632 43.766440 46.62082 26 51.764379 49.523520 54.00524 27 53.078529 52.698811 53.45825 28 55.706828 53.509314 57.90434 29 56.363903 54.636793 58.09101 30 56.363903 56.192801 56.53500 31 73.447846 68.614097 78.28160 > > printh("predict(earth.trees, interval=\"pin\", level=.80)") ===predict(earth.trees, interval="pin", level=.80) > news <- predict(earth.trees, interval="pin", level=.80) > print(news) fit lwr upr 1 9.913855 9.430887 10.39682 2 10.942195 10.329910 11.55448 3 11.627755 10.752942 12.50257 4 17.455018 14.348715 20.56132 5 18.140578 14.771747 21.50941 6 18.483359 14.983263 21.98345 7 19.168919 15.406295 22.93154 8 19.168919 15.406295 22.93154 9 19.511699 15.617811 23.40559 10 19.854479 15.829327 23.87963 11 20.197259 16.040843 24.35368 12 20.540040 16.252359 24.82772 13 20.540040 16.252359 24.82772 14 21.568380 16.886908 26.24985 15 22.596721 17.521456 27.67199 16 25.681742 19.425100 31.93838 17 25.681742 19.425100 31.93838 18 27.052863 20.796221 33.30950 19 28.423983 22.167342 34.68063 20 28.766764 22.510122 35.02341 21 30.080913 23.824271 36.33755 22 31.395063 25.138421 37.65170 23 33.366287 27.109645 39.62293 24 43.222408 36.965766 49.47905 25 45.193632 38.936990 51.45027 26 51.764379 45.507738 58.02102 27 53.078529 46.821887 59.33517 28 55.706828 49.450186 61.96347 29 56.363903 50.107261 62.62054 30 56.363903 50.107261 62.62054 31 73.447846 67.191204 79.70449 > expect.err(try(predict(earth.trees, interval="none", level=.80)), "predict.earth: level=0.8 was specified but interval=\"none\"") Error : predict.earth: level=0.8 was specified but interval="none" Got error as expected from try(predict(earth.trees, interval = "none", level = 0.8)) > expect.err(try(predict(earth.trees, interval="pin", type="class")), "predict.earth: the interval argument is not allowed with type=\"class\"") Error : predict.earth: the interval argument is not allowed with type="class" Got error as expected from try(predict(earth.trees, interval = "pin", type = "class")) > expect.err(try(predict(earth.trees, interval="pin", type="cl")), "predict.earth: the interval argument is not allowed with type=\"class\"") Error : predict.earth: the interval argument is not allowed with type="class" Got error as expected from try(predict(earth.trees, interval = "pin", type = "cl")) > expect.err(try(predict(earth.trees, interval="pin", type="ter")), "predict.earth: the interval argument is not allowed with type=\"terms\"") Error : predict.earth: the interval argument is not allowed with type="terms" Got error as expected from try(predict(earth.trees, interval = "pin", type = "ter")) > > printh("print.default(earth.trees$varmod$residmod)") ===print.default(earth.trees$varmod$residmod) > # have to modify earth.trees because terms field stores the environment > # as a hex address which messes up the diffs > earth.trees$varmod$residmod$terms <- NULL > print.default(earth.trees$varmod$residmod) $rss [1] 87.74303 $rsq [1] 0.3044152 $gcv [1] 3.469431 $grsq [1] 0.201497 $bx (Intercept) h(25.6817-RHS) [1,] 1 15.767888 [2,] 1 14.739547 [3,] 1 14.053987 [4,] 1 8.226724 [5,] 1 7.541164 [6,] 1 7.198383 [7,] 1 6.512823 [8,] 1 6.512823 [9,] 1 6.170043 [10,] 1 5.827263 [11,] 1 5.484483 [12,] 1 5.141702 [13,] 1 5.141702 [14,] 1 4.113362 [15,] 1 3.085021 [16,] 1 0.000000 [17,] 1 0.000000 [18,] 1 0.000000 [19,] 1 0.000000 [20,] 1 0.000000 [21,] 1 0.000000 [22,] 1 0.000000 [23,] 1 0.000000 [24,] 1 0.000000 [25,] 1 0.000000 [26,] 1 0.000000 [27,] 1 0.000000 [28,] 1 0.000000 [29,] 1 0.000000 [30,] 1 0.000000 [31,] 1 0.000000 $dirs RHS (Intercept) 0 h(RHS-25.6817) 1 h(25.6817-RHS) -1 h(RHS-43.2224) 1 $cuts RHS (Intercept) 0.00000 h(RHS-25.6817) 25.68174 h(25.6817-RHS) 25.68174 h(RHS-43.2224) 43.22241 $selected.terms [1] 1 3 $prune.terms [,1] [,2] [,3] [,4] [1,] 1 0 0 0 [2,] 1 3 0 0 [3,] 1 3 4 0 [4,] 1 2 3 4 $fitted.values abs.resids [1,] 0.1360320 [2,] 0.3812042 [3,] 0.5446523 [4,] 1.9339615 [5,] 2.0974096 [6,] 2.1791337 [7,] 2.3425818 [8,] 2.3425818 [9,] 2.4243059 [10,] 2.5060299 [11,] 2.5877540 [12,] 2.6694781 [13,] 2.6694781 [14,] 2.9146503 [15,] 3.1598225 [16,] 3.8953391 [17,] 3.8953391 [18,] 3.8953391 [19,] 3.8953391 [20,] 3.8953391 [21,] 3.8953391 [22,] 3.8953391 [23,] 3.8953391 [24,] 3.8953391 [25,] 3.8953391 [26,] 3.8953391 [27,] 3.8953391 [28,] 3.8953391 [29,] 3.8953391 [30,] 3.8953391 [31,] 3.8953391 $residuals abs.resids [1,] 0.8611800 [2,] 0.5911208 [3,] 1.2756088 [4,] -0.5840137 [5,] -1.2670169 [6,] -0.8516886 [7,] 1.5220327 [8,] -1.1109111 [9,] 0.9186446 [10,] -2.2044373 [11,] 1.7622786 [12,] -1.7339517 [13,] -1.5771909 [14,] -2.4489289 [15,] 0.7144529 [16,] 0.1782357 [17,] 4.9607024 [18,] -2.4978292 [19,] -0.8153720 [20,] 0.6349183 [21,] 1.0842203 [22,] -3.1990944 [23,] -0.5302587 [24,] 1.4810292 [25,] -0.9810963 [26,] 0.2812761 [27,] -0.9778296 [28,] -0.7724933 [29,] 1.6608107 [30,] 2.1550503 [31,] 1.4705513 $coefficients abs.resids (Intercept) 3.8953391 h(25.6817-RHS) -0.2384154 $rss.per.response [1] 87.74303 $rsq.per.response [1] 0.3044152 $gcv.per.response [1] 3.469431 $grsq.per.response [1] 0.201497 $rss.per.subset [1] 126.14282 87.74303 82.82243 82.80450 $gcv.per.subset [1] 4.344919 3.469431 3.798070 4.456492 $leverages [1] 0.24689453 0.21180022 0.19014329 0.06223841 0.05380006 0.05010267 [7] 0.04375147 0.04375147 0.04109766 0.03879170 0.03683360 0.03522336 [13] 0.03522336 0.03247977 0.03286691 0.05281259 0.05281259 0.05281259 [19] 0.05281259 0.05281259 0.05281259 0.05281259 0.05281259 0.05281259 [25] 0.05281259 0.05281259 0.05281259 0.05281259 0.05281259 0.05281259 [31] 0.05281259 $pmethod [1] "backward" $nprune NULL $penalty [1] 2 $nk [1] 21 $thresh [1] 0.001 $termcond [1] 4 $weights NULL $call earth(formula = abs.resids ~ ., data = data, weights = weights, keepxy = TRUE, trace = trace, degree = ..1, minspan = minspan) $namesx.org [1] "RHS" $namesx [1] "RHS" $xlevels named list() $data abs.resids RHS 1 0.9972120 9.913855 2 0.9723250 10.942195 3 1.8202611 11.627755 4 1.3499478 17.455018 5 0.8303927 18.140578 6 1.3274450 18.483359 7 3.8646145 19.168919 8 1.2316707 19.168919 9 3.3429505 19.511699 10 0.3015926 19.854479 11 4.3500327 20.197259 12 0.9355264 20.540040 13 1.0922872 20.540040 14 0.4657214 21.568380 15 3.8742754 22.596721 16 4.0735748 25.681742 17 8.8560415 25.681742 18 1.3975099 27.052863 19 3.0799671 28.423983 20 4.5302574 28.766764 21 4.9795594 30.080913 22 0.6962448 31.395063 23 3.3650804 33.366287 24 5.3763683 43.222408 25 2.9142428 45.193632 26 4.1766153 51.764379 27 2.9175095 53.078529 28 3.1228458 55.706828 29 5.5561498 56.363903 30 6.0503894 56.363903 31 5.3658904 73.447846 $y abs.resids [1,] 0.9972120 [2,] 0.9723250 [3,] 1.8202611 [4,] 1.3499478 [5,] 0.8303927 [6,] 1.3274450 [7,] 3.8646145 [8,] 1.2316707 [9,] 3.3429505 [10,] 0.3015926 [11,] 4.3500327 [12,] 0.9355264 [13,] 1.0922872 [14,] 0.4657214 [15,] 3.8742754 [16,] 4.0735748 [17,] 8.8560415 [18,] 1.3975099 [19,] 3.0799671 [20,] 4.5302574 [21,] 4.9795594 [22,] 0.6962448 [23,] 3.3650804 [24,] 5.3763683 [25,] 2.9142428 [26,] 4.1766153 [27,] 2.9175095 [28,] 3.1228458 [29,] 5.5561498 [30,] 6.0503894 [31,] 5.3658904 attr(,"class") [1] "earth" > # prevent mistakes later where we try to use a modified earth.trees > remove(earth.trees) > > multifigure("test example for varmod help page", 2, 2) ===test example for varmod help page > > data(ozone1) > set.seed(1) # optional, for cross validation reproducibility > > a <- earth(O3~temp, data=ozone1, nfold=10, ncross=3, varmod.method="earth") > > print(summary(a)) # note additional info on the variance model Call: earth(formula=O3~temp, data=ozone1, nfold=10, ncross=3, varmod.method="earth") coefficients (Intercept) 7.5768304 h(58-temp) -0.1572930 h(temp-58) 0.6090229 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: temp Number of terms at each degree of interaction: 1 2 (additive model) GCV 22.43818 RSS 7181.917 GRSq 0.6514492 RSq 0.6598731 CVRSq 0.6232032 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.67 sd 1.47 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.623 0.106 17.5 11.8 varmod: method "earth" min.sd 0.464 iter.rsq 0.169 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 6.6003879 0.304075 5 h(16.1032-O3) -0.3474529 0.0425299 12 mean smallest largest ratio 95% prediction interval 18.2071 7.190636 25.87305 3.598158 68% 80% 90% 95% response values in prediction interval 71 82 95 97 > > old.mfrow <- par(mfrow=c(2,2)) > > # the variance model assumes residuals are symmetric, which is not > # quite true in this example, so the lower band is a bit too big > plotmo(a, do.par=FALSE, col.response=1, level=.95, main="earth model: O3~temp") > > plot(a, which=1) # model selection plot, same as ever > plot(a, which=3, level=.95) # residual plot: note 95% pred and darker conf intervals > plot(a, which=3, level=.95, standardize=TRUE) # standardize resids are approx homoscedastic > > par(par=old.mfrow) > > plot(a$varmod) # plot the embedded variance model (this calls plot.varmod) > > multifigure("test example for plot.varmod help page", 2, 2) ===test example for plot.varmod help page > > # multivariate example (for univariate, see the example on the varmod help page) > > data(ozone1) > set.seed(1) # optional, for cross validation reproducibility > > mod.temp.vh.doy <- earth(O3~temp+vh+vis+doy, data=ozone1, nfold=5, ncross=3, varmod.method="x.earth") > > print(summary(mod.temp.vh.doy)) # note additional info on the variance model Call: earth(formula=O3~temp+vh+vis+doy, data=ozone1, nfold=5, ncross=3, varmod.method="x.earth") coefficients (Intercept) 9.8874670 h(temp-58) 0.4016529 h(vh-5530) 0.0210146 h(vis-17) -0.0324305 h(vis-200) 0.0474193 h(106-doy) -0.0972229 h(doy-151) -0.0285859 Selected 7 of 15 terms, and 4 of 4 predictors Termination condition: Reached nk 21 Importance: temp, vis, doy, vh Number of terms at each degree of interaction: 1 6 (additive model) GCV 17.87166 RSS 5442.137 GRSq 0.7223847 RSq 0.742267 CVRSq 0.699885 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 8.07 sd 1.28 nvars 4.00 sd 0.00 CVRSq sd MaxErr sd 0.7 0.071 15.2 13.2 varmod: method "x.earth" min.sd 0.414 iter.rsq 0.252 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 8.3952546 1.32479 16 h(vh-5690) 0.0137305 0.0026369 19 h(vis-70) -0.0221452 0.0057626 26 h(vis-150) 0.0221952 0.008622 39 h(doy-119) -0.0219062 0.0059075 27 h(302-doy) -0.0216992 0.0061695 28 mean smallest largest ratio 95% prediction interval 16.22979 3.466058 31.21429 9.005701 68% 80% 90% 95% response values in prediction interval 73 82 93 96 > > plot(mod.temp.vh.doy, level=.95) # note 95% pred and darker conf intervals in resids plot > > plot(mod.temp.vh.doy$varmod) # plot the variance model (this calls plot.varmod) > > plot(mod.temp.vh.doy, versus="", level=.9, caption="plot.earth versus=\"\"") > plot(mod.temp.vh.doy, versus="v", level=.9, caption="plot.earth versus=\"v\" and versus=\"temp\"", do.par=2) > plot(mod.temp.vh.doy, versus="temp", level=.9, caption="", main="temp on same page") > > # plot.earth will silently not plots it cannot plot below, so 1:9 becomes c(3,5,6) > plot(mod.temp.vh.doy, which=1:9, versus="v", info=T, caption='which=c(3,5) versus="v" info=T') > > # versus="b:" > > plot(mod.temp.vh.doy, versus="b:", level=.9, + caption="plot.earth versus=\"b:\"") > > # versus="b:" and versus=1:4 with info > plot(mod.temp.vh.doy, versus="b:", level=.8, info=TRUE, + caption="plot.earth versus=\"b:\" with info") > > multifigure("versus=1:4", 3, 3) ===versus=1:4 > > plot(mod.temp.vh.doy, versus=1, caption="", do.par=FALSE, which=3) > do.caption() > plot(mod.temp.vh.doy, versus=2, caption="", do.par=FALSE) > plot(mod.temp.vh.doy, versus=3, caption="", do.par=FALSE) > > plot(mod.temp.vh.doy, versus=1, info=TRUE, caption="", do.par=FALSE, which=3) > plot(mod.temp.vh.doy, versus=2, info=TRUE, caption="", do.par=FALSE) > plot(mod.temp.vh.doy, versus=3, info=TRUE, caption="", do.par=FALSE) > > plot(mod.temp.vh.doy, versus=1, info=TRUE, caption="", do.par=FALSE, level=.8, which=3) > plot(mod.temp.vh.doy, versus=2, info=TRUE, caption="", do.par=FALSE, level=.8) > plot(mod.temp.vh.doy, versus=3, info=TRUE, caption="", do.par=FALSE, level=.8) > > expect.err(try(plot(mod.temp.vh.doy, versus=9))) Error : versus must be an integer or a string: 1 fitted (default) 2 observation numbers 3 response 4 leverages "" predictors "b:" basis functions Got error as expected from try(plot(mod.temp.vh.doy, versus = 9)) > expect.err(try(plot(mod.temp.vh.doy, versus=1.2))) Error : versus must be an integer or a string: 1 fitted (default) 2 observation numbers 3 response 4 leverages "" predictors "b:" basis functions Got error as expected from try(plot(mod.temp.vh.doy, versus = 1.2)) > expect.err(try(plot(mod.temp.vh.doy, versus=2:3))) Error : illegal 'versus' argument (length of 'versus' must be 1 when 'versus' is numeric) Got error as expected from try(plot(mod.temp.vh.doy, versus = 2:3)) > > # versus="b:doy" > > plot(mod.temp.vh.doy, versus="b:doy", level=.9, caption="plot.earth versus=\"b:doy\"") > > # test warnings from plotres about which > options(warn=1) # print warnings as they occur > plot(mod.temp.vh.doy, which=1, versus="b:doy") Warning: which=1 is now empty because plots were removed because versus=b:doy Warning: plotres: nothing to plot > options(warn=2) > > multifigure("test example in (very old) earth vignette", 2, 2) ===test example in (very old) earth vignette > > data(ozone1) > x <- ozone1$temp > y <- ozone1$O3 > > set.seed(1) # optional, for cross validation reproducibility > earth.mod <- earth(y~x, nfold=10, ncross=3, varmod.method="earth", trace=.1) Full model GRSq 0.651 RSq 0.660, starting cross validation CV fold 1.1 CVRSq 0.704 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 1.2 CVRSq 0.514 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 1.3 CVRSq 0.774 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 1.4 CVRSq 0.726 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 1.5 CVRSq 0.543 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 1.6 CVRSq 0.695 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 1.7 CVRSq 0.641 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 1.8 CVRSq 0.674 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 1.9 CVRSq 0.482 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 1.10 CVRSq 0.564 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 2.1 CVRSq 0.693 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 2.2 CVRSq 0.568 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 2.3 CVRSq 0.505 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 2.4 CVRSq 0.676 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 2.5 CVRSq 0.377 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 2.6 CVRSq 0.794 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 2.7 CVRSq 0.843 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 2.8 CVRSq 0.534 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 2.9 CVRSq 0.609 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 2.10 CVRSq 0.481 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 3.1 CVRSq 0.647 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 3.2 CVRSq 0.631 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 3.3 CVRSq 0.641 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 3.4 CVRSq 0.565 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 3.5 CVRSq 0.515 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 3.6 CVRSq 0.704 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 3.7 CVRSq 0.611 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 3.8 CVRSq 0.560 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 3.9 CVRSq 0.717 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV fold 3.10 CVRSq 0.709 n.oof 297 10% n.infold.nz 297 100% n.oof.nz 33 100% CV all CVRSq 0.623 n.infold.nz 330 100% > predict <- predict(earth.mod, interval="pint") > > order <- order(x) > x <- x[order] > y <- y[order] > predict <- predict[order,] > > inconf <- y >= predict$lwr & y <= predict$upr > > plot(x, y, pch=20, col=ifelse(inconf, 1, 2), main=sprint( + "Prediction intervals\n%.0f%% of the points are in the estimated band", + 100 * sum(inconf) / length(y))) > do.caption() > > lines(x, predict$fit) > lines(x, predict$lwr, lty=2) > lines(x, predict$upr, lty=2) > > # Plot the Residuals vs Fitted graph > plot(earth.mod, which=3, level=.95) > > # Plot the embedded residual model > plot(earth.mod$varmod, do.par=F, which=1:2) > > cat('head(residuals(earth.mod))\n') head(residuals(earth.mod)) > print(head(residuals(earth.mod))) y 1 -1.7455563 2 -0.5320213 3 -1.9476584 4 2.0409087 5 -1.5320213 6 -3.1049514 > cat('head(residuals(earth.mod, type="standardize"))\n') head(residuals(earth.mod, type="standardize")) > print(head(residuals(earth.mod, type="standardize"))) y 1 -0.6627370 2 -0.1824742 3 -0.5713109 4 0.8688808 5 -0.5254570 6 -0.8967349 > > multifigure("plot.earth varmod options", 2, 2) ===plot.earth varmod options > > plot(earth.mod, which=3, level=.95, level.shade=0, main="plot.earth varmod options") > do.caption() > plot(earth.mod, which=3, level.shade="orange", level.shade2="darkgray", level=.99) > plot(earth.mod, which=3, level=.95, level.shade=0, level.shade2="mistyrose4") > > multifigure("plot.earth delever and standardize", 2, 2) ===plot.earth delever and standardize > > set.seed(4) > earth.mod1 <- earth(O3~temp, data=ozone1, nfold=5, ncross=3, varmod.method="lm", keepxy=T, trace=.1) Full model GRSq 0.651 RSq 0.660, starting cross validation CV fold 1.1 CVRSq 0.648 n.oof 264 20% n.infold.nz 264 100% n.oof.nz 66 100% CV fold 1.2 CVRSq 0.739 n.oof 264 20% n.infold.nz 264 100% n.oof.nz 66 100% CV fold 1.3 CVRSq 0.549 n.oof 264 20% n.infold.nz 264 100% n.oof.nz 66 100% CV fold 1.4 CVRSq 0.436 n.oof 264 20% n.infold.nz 264 100% n.oof.nz 66 100% CV fold 1.5 CVRSq 0.665 n.oof 264 20% n.infold.nz 264 100% n.oof.nz 66 100% CV fold 2.1 CVRSq 0.666 n.oof 264 20% n.infold.nz 264 100% n.oof.nz 66 100% CV fold 2.2 CVRSq 0.673 n.oof 264 20% n.infold.nz 264 100% n.oof.nz 66 100% CV fold 2.3 CVRSq 0.652 n.oof 264 20% n.infold.nz 264 100% n.oof.nz 66 100% CV fold 2.4 CVRSq 0.645 n.oof 264 20% n.infold.nz 264 100% n.oof.nz 66 100% CV fold 2.5 CVRSq 0.496 n.oof 264 20% n.infold.nz 264 100% n.oof.nz 66 100% CV fold 3.1 CVRSq 0.671 n.oof 264 20% n.infold.nz 264 100% n.oof.nz 66 100% CV fold 3.2 CVRSq 0.588 n.oof 264 20% n.infold.nz 264 100% n.oof.nz 66 100% CV fold 3.3 CVRSq 0.632 n.oof 264 20% n.infold.nz 264 100% n.oof.nz 66 100% CV fold 3.4 CVRSq 0.616 n.oof 264 20% n.infold.nz 264 100% n.oof.nz 66 100% CV fold 3.5 CVRSq 0.610 n.oof 264 20% n.infold.nz 264 100% n.oof.nz 66 100% CV all CVRSq 0.619 n.infold.nz 330 100% > plot(earth.mod1, which=3, ylim=c(-16,20), info=TRUE, level=.95) > do.caption() > plot(earth.mod1, which=3, ylim=c(-16,20), delever=TRUE, level=.95) > plot(earth.mod1, which=3, standardize=TRUE, info=TRUE, level=.95) > # the standardize and delever arguments cannot both be set > expect.err(try(plot(earth.mod1, which=3, standardize=TRUE, delever=TRUE, level=.95))) Error : the standardize and delever arguments cannot both be set Got error as expected from try(plot(earth.mod1, which = 3, standardize = TRUE, delever = TRUE, level = 0.95)) > > multifigure("plot.earth which=5 and which=6", 2, 3) ===plot.earth which=5 and which=6 > plot(earth.mod1, which=5, info=T, main="which=5, info=T") > plot(earth.mod1, which=5, standardize=T, info=T, main="which=5, standardize=T, info=T") > plot(earth.mod1, which=5, standardize=T, main="which=5, standardize=T") > do.caption() > plot(earth.mod1, which=6, info=T, main="which=6, info=T") > plot(earth.mod1, which=6, standardize=T, info=T, main="which=6, standardize=T, info=T") > plot(earth.mod1, which=6, standardize=T, main="which=6, standardize=T") > > multifigure("plot.earth which=7", 2, 3) ===plot.earth which=7 > plot(earth.mod1, which=7, info=T, main="which=7, info=T") > plot(earth.mod1, which=7, standardize=T, info=T, main="which=7, standardize=T, info=T") > plot(earth.mod1, which=7, standardize=T, main="which=7, standardize=T") > do.caption() > > multifigure("plot.earth which=8 and which=9", 2, 3) ===plot.earth which=8 and which=9 > plot(earth.mod1, which=8, info=T, main="which=8, info=T") > plot(earth.mod1, which=8, standardize=T, info=T, main="which=8, standardize=T, info=T") > plot(earth.mod1, which=8, standardize=T, main="which=8, standardize=T") > do.caption() > plot(earth.mod1, which=9, info=T, main="which=9, info=T") > plot(earth.mod1, which=9, standardize=T, info=T, main="which=9, standardize=T, info=T") > plot(earth.mod1, which=9, standardize=T, main="which=9, standardize=T") > > multifigure("plot.earth versus=4, which=3 and which=5", 2, 3) ===plot.earth versus=4, which=3 and which=5 > plot(earth.mod1, versus=4, which=3, main="versus=4, which=3") > plot(earth.mod1, versus=4, which=3, standardize=T, info=T, main="versus=4, which=3, standardize=T, info=T") > plot(earth.mod1, versus=4, which=3, standardize=T, main="versus=4, which=3, standardize=T") > do.caption() > plot(earth.mod1, versus=4, which=5, main="versus=4, which=5") > plot(earth.mod1, versus=4, which=5, standardize=T, info=T, main="versus=4, which=5, standardize=T, info=T") > plot(earth.mod1, versus=4, which=5, standardize=T, main="versus=4, which=5, standardize=T") > > cat("summary(earth.mod1, newdata=ozone1)\n") summary(earth.mod1, newdata=ozone1) > print(summary(earth.mod1, newdata=ozone1)) RSq 0.660 on newdata (330 cases) 68% 80% 90% 95% newdata in prediction interval 72 83 93 97 > > cat("summary(earth.mod1, newdata=ozone1[1:100,]:)\n") summary(earth.mod1, newdata=ozone1[1:100,]:) > print(summary(earth.mod1, newdata=ozone1[1:100,])) RSq 0.199 on newdata (100 cases) 68% 80% 90% 95% newdata in prediction interval 79 85 92 95 > > # earth.default > O3 <- ozone1$O3 > temp <- ozone1$temp > set.seed(4) > earth.default <- earth(temp, O3, nfold=5, ncross=3, varmod.method="lm") > cat("summary(earth.default)\n") summary(earth.default) > print(summary(earth.default)) Call: earth(x=temp, y=O3, nfold=5, ncross=3, varmod.method="lm") coefficients (Intercept) 7.5768304 h(58-temp) -0.1572930 h(temp-58) 0.6090229 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: temp Number of terms at each degree of interaction: 1 2 (additive model) GCV 22.43818 RSS 7181.917 GRSq 0.6514492 RSq 0.6598731 CVRSq 0.6191483 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.87 sd 1.25 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.619 0.076 19.6 11.4 varmod: method "lm" min.sd 0.481 iter.rsq 0.149 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 1.6911524 0.333325 20 O3 0.2644448 0.0348975 13 mean smallest largest ratio 95% prediction interval 18.836 9.102701 36.57943 4.018524 68% 80% 90% 95% response values in prediction interval 72 83 93 97 > cat("summary(earth.default, newdata=ozone1[1:100,]:)\n") summary(earth.default, newdata=ozone1[1:100,]:) > print(summary(earth.default, newdata=ozone1[1:100,])) RSq 0.199 on newdata (100 cases) 68% 80% 90% 95% newdata in prediction interval 79 85 92 95 > plot(earth.default, level=.80, caption="earth.default") > plotmo(earth.default, level=.80, col.response=3, caption="earth.default\nlevel = .80") > > # TODO the following give err msg as expected, but do not give a try error > # expect.err(try(summary(earth.mod1, newdata=c(1,2,3)))) > # expect.err(try(summary(earth.mod1, newdata=ozone1[1:100,1:3]))) > > multifigure("plot(earth.mod1)", 2, 2) ===plot(earth.mod1) > set.seed(5) > earth.mod2 <- earth(y~x, nfold=10, ncross=5, varmod.method="earth") > plot(earth.mod2, caption="plot(earth.mod2)", level=.95) > do.caption() > > multifigure("plot(earth.mod2) with standardize=TRUE", 2, 2) ===plot(earth.mod2) with standardize=TRUE > plot(earth.mod2, standardize=TRUE, level=.95, + caption="plot(earth.mod2, standardize=TRUE, level=.95)") > do.caption() > > multifigure("plot.varmod by calling plot(earth.mod2$varmod)", 2, 2) ===plot.varmod by calling plot(earth.mod2$varmod) > plot(earth.mod2$varmod) > > multifigure("embedded earth model by calling plot(earth.mod2$varmod$residmod)", 2, 2) ===embedded earth model by calling plot(earth.mod2$varmod$residmod) > plot(earth.mod2$varmod$residmod, caption="embedded earth model") > do.caption() > > # test varmod.* args like varmod.conv > > # cat("test varmod.exponent=.5\n") > # set.seed(1) > # (earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="lm", trace=.3, varmod.exponent=.5)) > > # cat("test varmod.lambda=2/3\n") > # set.seed(1) > # (earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="lm", trace=.3, varmod.lambda=2/3)) > > cat("test varmod.conv=50%\n") test varmod.conv=50% > set.seed(1) > (earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="lm", trace=.3, varmod.conv=50)) Full model GRSq 0.949 RSq 0.962, starting cross validation CV fold 1.1 CVRSq 0.927 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 1.2 CVRSq 0.953 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 1.3 CVRSq 0.927 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 2.1 CVRSq 0.263 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 2.2 CVRSq 0.940 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 2.3 CVRSq 0.966 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3.1 CVRSq 0.965 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 3.2 CVRSq 0.968 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3.3 CVRSq 0.921 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV all CVRSq 0.870 n.infold.nz 31 100% varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=50 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) Volume 1 2.3 0 2.9 0.026 2 1.8 20 3.1 0.017 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.8701366 > > cat("test varmod.conv=-5\n") test varmod.conv=-5 > set.seed(1) > (earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="lm", trace=.3, varmod.conv=-5)) Full model GRSq 0.949 RSq 0.962, starting cross validation CV fold 1.1 CVRSq 0.927 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 1.2 CVRSq 0.953 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 1.3 CVRSq 0.927 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 2.1 CVRSq 0.263 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 2.2 CVRSq 0.940 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 2.3 CVRSq 0.966 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3.1 CVRSq 0.965 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 3.2 CVRSq 0.968 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3.3 CVRSq 0.921 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV all CVRSq 0.870 n.infold.nz 31 100% varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=-5 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) Volume 1 2.3 0.0 2.9 0.026 2 1.8 19.9 3.1 0.017 3 2.0 7.1 3.1 0.021 4 1.9 2.7 3.1 0.019 5 1.9 1.0 3.1 0.020 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.8701366 > > cat("test varmod.clamp\n") test varmod.clamp > set.seed(1) > a.noclamp <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="lm") > plot(a.noclamp$varmod, which=1:2, caption="a.noclamp and a.clamp", do.par=FALSE) > set.seed(1) > a.clamp <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="lm", varmod.clamp=.6) > plot(a.clamp$varmod, which=1:2, caption="", do.par=FALSE) > > cat("test varmod.minspan=-5\n") test varmod.minspan=-5 > set.seed(1) > a.varmod.minspan.minus5 <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="earth", trace=.3, varmod.minspan=-5) Full model GRSq 0.949 RSq 0.962, starting cross validation CV fold 1.1 CVRSq 0.927 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 1.2 CVRSq 0.953 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 1.3 CVRSq 0.927 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 2.1 CVRSq 0.263 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 2.2 CVRSq 0.940 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 2.3 CVRSq 0.966 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3.1 CVRSq 0.965 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 3.2 CVRSq 0.968 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3.3 CVRSq 0.921 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV all CVRSq 0.870 n.infold.nz 31 100% varmod method="earth" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-5: iter weight.ratio coefchange% (Intercept) h(Volume-19.1689) 1 6.9 0 2.5 0.06 h(19.1689-Volume) 0.45 > print(coef(a.varmod.minspan.minus5$varmod)) (Intercept) h(Volume-19.1689) h(19.1689-Volume) 3.19140324 0.07540525 0.55793565 > cat("test varmod.minspan=1\n") test varmod.minspan=1 > set.seed(1) > a.varmod.minspan1 <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="earth", trace=.3, varmod.minspan=1) Full model GRSq 0.949 RSq 0.962, starting cross validation CV fold 1.1 CVRSq 0.927 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 1.2 CVRSq 0.953 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 1.3 CVRSq 0.927 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 2.1 CVRSq 0.263 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 2.2 CVRSq 0.940 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 2.3 CVRSq 0.966 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3.1 CVRSq 0.965 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 3.2 CVRSq 0.968 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3.3 CVRSq 0.921 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV all CVRSq 0.870 n.infold.nz 31 100% varmod method="earth" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=1: iter weight.ratio coefchange% (Intercept) h(Volume-19.1689) 1 6.9 0 2.5 0.06 h(19.1689-Volume) 0.45 > print(coef(a.varmod.minspan1$varmod)) (Intercept) h(Volume-19.1689) h(19.1689-Volume) 3.19140324 0.07540525 0.55793565 > > # gam and y.gam are repeated below and on the repeat we will use the mgcv not gam package > use.mgcv.package <- FALSE > > for(varmod.method in c(earth:::VARMOD.METHODS, "gam", "x.gam")) { + + multifigure(sprint("varmod.method=\"%s\"", varmod.method), 2, 3) + par(mar = c(3, 3, 2, 3)) # space for right margin axis + + if(varmod.method %in% c("gam", "x.gam")) { + if(use.mgcv.package) { + # TODO with R 3.2.1 unload(gam) no longer works + cat("skipping mgcv tests\n") + next # NOTE next + cat("library(mgcv)\n") + library(mgcv) + } else + library(gam) + } + set.seed(2019) + # may 2019: following added because gam version 1.16 R version 3.6.0 gives Warning: non-list contrasts argument ignored + if(varmod.method %in% c("gam", "x.gam")) + options(warn=1) + earth.mod <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, + varmod.method=varmod.method, + trace=if(varmod.method %in% c("const", "lm", "power")) .3 else 0) + options(warn=2) + printh(sprint("varmod.method %s: summary(earth.mod)", varmod.method)) + printh("summary(earth.mod)") + print(summary(earth.mod)) + + if(use.mgcv.package && (varmod.method == "x.gam" || varmod.method == "gam")) { + # summary(mgcv) prints environment as hex address which messes up the diffs + printh("skipping summary(mgcv::gam) etc.\n") + } else { + printh("earth.mod$varmod") + print(earth.mod$varmod, style="unit") + + printh("summary(earth.mod$varmod)") + print(summary(earth.mod$varmod)) + + printh("summary(earth.mod$varmod$residmod)") + print(summary(earth.mod$varmod$residmod)) + } + printh(sprint("varmod.method %s: predict(earth.mod, interval=\"pint\")", varmod.method)) + pints <- predict(earth.mod, interval="pint") + print(pints) + + plotmo(earth.mod$varmod, do.par=FALSE, col.response=2, clip=FALSE, + main="plotmo residual model", + xlab="x", ylab="varmod residuals") + + plotmo(earth.mod, level=.90, do.par=FALSE, col.response=1, clip=FALSE, + main="main model plotmo Girth") + do.caption() + + plot(earth.mod, which=3, do.par=FALSE, level=.95) + + # plot.varmod + plot(earth.mod$varmod, do.par=FALSE, which=1:3, info=(varmod.method=="earth")) + + # on second use of gam and y.gam we want to use the mgcv package + if(varmod.method == "x.gam" && !use.mgcv.package) { + use.mgcv.package <- TRUE + cat("detach(\"package:gam\", unload=TRUE)\n") + detach("package:gam", unload=TRUE) + } + } ===varmod.method="const" Full model GRSq 0.949 RSq 0.962, starting cross validation CV fold 1.1 CVRSq 0.913 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 1.2 CVRSq 0.949 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 1.3 CVRSq 0.928 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 2.1 CVRSq 0.952 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 2.2 CVRSq 0.917 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 2.3 CVRSq 0.947 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3.1 CVRSq 0.924 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 3.2 CVRSq 0.974 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3.3 CVRSq 0.957 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV all CVRSq 0.940 n.infold.nz 31 100% varmod method="const" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) 1 1 0 3 ===varmod.method const: summary(earth.mod) ===summary(earth.mod) Call: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9401008 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.94 0.02 10.4 7.04 varmod: method "const" min.sd 0.38 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 3.80095 0.464479 12 mean smallest largest ratio 95% prediction interval 14.89945 14.89945 14.89945 1 68% 80% 90% 95% response values in prediction interval 77 90 97 97 ===earth.mod$varmod method "const" min.sd 0.38 stddev of predictions (scaled by unit): coefficients iter.stderr iter.stderr% (Intercept) 1.0 0.122 12 unit 3.8 NA NA mean smallest largest ratio 95% prediction interval 15 15 15 1 68% 80% 90% 95% response values in prediction interval 77 90 97 97 ===summary(earth.mod$varmod) Parent model: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) method "const" min.sd 0.38 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 3.8 0.46 12 mean smallest largest ratio 95% prediction interval 15 15 15 1 68% 80% 90% 95% response values in prediction interval 77 90 97 97 Regression submodel (Abs Residuals): Call: lm(formula = abs.resids ~ 1, data = data, weights = weights, y = TRUE) Coefficients: (Intercept) 3 ===summary(earth.mod$varmod$residmod) Call: lm(formula = abs.resids ~ 1, data = data, weights = weights, y = TRUE) Residuals: Min 1Q Median 3Q Max -2.8891 -1.8867 0.0443 1.1643 5.9181 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 3.0327 0.3706 8.183 3.91e-09 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 2.063 on 30 degrees of freedom ===varmod.method const: predict(earth.mod, interval="pint") fit lwr upr 1 9.913855 2.464130 17.36358 2 10.942195 3.492471 18.39192 3 11.627755 4.178031 19.07748 4 17.455018 10.005294 24.90474 5 18.140578 10.690854 25.59030 6 18.483359 11.033634 25.93308 7 19.168919 11.719195 26.61864 8 19.168919 11.719195 26.61864 9 19.511699 12.061975 26.96142 10 19.854479 12.404755 27.30420 11 20.197259 12.747535 27.64698 12 20.540040 13.090315 27.98976 13 20.540040 13.090315 27.98976 14 21.568380 14.118656 29.01810 15 22.596721 15.146996 30.04644 16 25.681742 18.232018 33.13147 17 25.681742 18.232018 33.13147 18 27.052863 19.603138 34.50259 19 28.423983 20.974259 35.87371 20 28.766764 21.317039 36.21649 21 30.080913 22.631189 37.53064 22 31.395063 23.945338 38.84479 23 33.366287 25.916562 40.81601 24 43.222408 35.772684 50.67213 25 45.193632 37.743908 52.64336 26 51.764379 44.314655 59.21410 27 53.078529 45.628805 60.52825 28 55.706828 48.257104 63.15655 29 56.363903 48.914178 63.81363 30 56.363903 48.914178 63.81363 31 73.447846 65.998122 80.89757 ===varmod.method="power" Full model GRSq 0.949 RSq 0.962, starting cross validation CV fold 1.1 CVRSq 0.913 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 1.2 CVRSq 0.949 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 1.3 CVRSq 0.928 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 2.1 CVRSq 0.952 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 2.2 CVRSq 0.917 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 2.3 CVRSq 0.947 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3.1 CVRSq 0.924 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 3.2 CVRSq 0.974 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3.3 CVRSq 0.957 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV all CVRSq 0.940 n.infold.nz 31 100% varmod method="power" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: start: (Intercept)=1.1 coef=0.064 exponent=1 iter weight.ratio coefchange% (Intercept) coef exponent 1 19 0.00 -4.28 2.89 0.28 2 14 141.52 0.69 0.12 0.87 3 16 69.67 0.13 0.25 0.72 4 15 69.81 0.35 0.19 0.78 5 15 10.17 0.28 0.21 0.76 6 15 3.91 0.30 0.20 0.77 7 15 1.21 0.30 0.21 0.77 8 15 0.41 0.30 0.20 0.77 ===varmod.method power: summary(earth.mod) ===summary(earth.mod) Call: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9401008 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.94 0.02 10.4 7.04 varmod: method "power" min.sd 0.381 iter.rsq 0.195 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 0.3731008 4.80736 big coef 0.2564913 1.41385 551 exponent 0.7682577 1.19522 156 mean smallest largest ratio 95% prediction interval 14.92662 7.320154 28.74623 3.926998 68% 80% 90% 95% response values in prediction interval 74 94 97 97 ===earth.mod$varmod method "power" min.sd 0.381 iter.rsq 0.195 stddev of predictions (scaled by unit): coefficients iter.stderr iter.stderr% (Intercept) 1.46 18.7 big coef 1.00 5.5 551 exponent 0.77 1.2 156 unit 0.26 NA NA mean smallest largest ratio 95% prediction interval 15 7.3 29 3.9 68% 80% 90% 95% response values in prediction interval 74 94 97 97 ===summary(earth.mod$varmod) Parent model: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) method "power" min.sd 0.381 iter.rsq 0.195 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 0.37 4.8 big coef 0.26 1.4 551 exponent 0.77 1.2 156 mean smallest largest ratio 95% prediction interval 15 7.3 29 3.9 68% 80% 90% 95% response values in prediction interval 74 94 97 97 Regression submodel (Abs Residuals): Nonlinear regression model model: abs.resids ~ `(Intercept)` + coef * RHS^exponent data: data (Intercept) coef exponent 0.30 0.20 0.77 weighted residual sum-of-squares: 84 Number of iterations to convergence: 4 Achieved convergence tolerance: 2.4e-09 ===summary(earth.mod$varmod$residmod) Formula: abs.resids ~ `(Intercept)` + coef * RHS^exponent Parameters: Estimate Std. Error t value Pr(>|t|) (Intercept) 0.2977 3.8357 0.078 0.939 coef 0.2047 1.1281 0.181 0.857 exponent 0.7683 1.1952 0.643 0.526 Residual standard error: 1.733 on 28 degrees of freedom Number of iterations to convergence: 4 Achieved convergence tolerance: 2.419e-09 ===varmod.method power: predict(earth.mod, interval="pint") fit lwr upr 1 9.913855 6.253778 13.57393 2 10.942195 7.051415 14.83298 3 11.627755 7.585973 15.66954 4 17.455018 12.200662 22.70937 5 18.140578 12.750354 23.53080 6 18.483359 13.025648 23.94107 7 19.168919 13.577097 24.76074 8 19.168919 13.577097 24.76074 9 19.511699 13.853240 25.17016 10 19.854479 14.129654 25.57930 11 20.197259 14.406333 25.98819 12 20.540040 14.683271 26.39681 13 20.540040 14.683271 26.39681 14 21.568380 15.515590 27.62117 15 22.596721 16.350064 28.84338 16 25.681742 18.865270 32.49821 17 25.681742 18.865270 32.49821 18 27.052863 19.988308 34.11742 19 28.423983 21.114244 35.73372 20 28.766764 21.396161 36.13737 21 30.080913 22.478505 37.68332 22 31.395063 23.563186 39.22694 23 33.366287 25.194326 41.53825 24 43.222408 33.413637 53.03118 25 45.193632 35.068458 55.31881 26 51.764379 40.606626 62.92213 27 53.078529 41.718011 64.43905 28 55.706828 43.944227 67.46943 29 56.363903 44.501474 68.22633 30 56.363903 44.501474 68.22633 31 73.447846 59.074730 87.82096 ===varmod.method="power0" ===varmod.method power0: summary(earth.mod) ===summary(earth.mod) Call: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9401008 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.94 0.02 10.4 7.04 varmod: method "power0" min.sd 0.38 iter.rsq 0.197 stddev of predictions: coefficients iter.stderr iter.stderr% coef 0.3806260 0.298741 78 exponent 0.6838047 0.236589 35 mean smallest largest ratio 95% prediction interval 14.91131 7.161631 28.16708 3.933054 68% 80% 90% 95% response values in prediction interval 77 94 97 97 ===earth.mod$varmod method "power0" min.sd 0.38 iter.rsq 0.197 stddev of predictions (scaled by unit): coefficients iter.stderr iter.stderr% coef 0.56 0.44 78 exponent 0.68 0.24 35 unit 0.68 NA NA mean smallest largest ratio 95% prediction interval 15 7.2 28 3.9 68% 80% 90% 95% response values in prediction interval 77 94 97 97 ===summary(earth.mod$varmod) Parent model: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) method "power0" min.sd 0.38 iter.rsq 0.197 stddev of predictions: coefficients iter.stderr iter.stderr% coef 0.38 0.299 78 exponent 0.68 0.237 35 mean smallest largest ratio 95% prediction interval 15 7.2 28 3.9 68% 80% 90% 95% response values in prediction interval 77 94 97 97 Regression submodel (Abs Residuals): Nonlinear regression model model: abs.resids ~ coef * RHS^exponent data: data coef exponent 0.30 0.68 weighted residual sum-of-squares: 83 Number of iterations to convergence: 2 Achieved convergence tolerance: 4.7e-12 ===summary(earth.mod$varmod$residmod) Formula: abs.resids ~ coef * RHS^exponent Parameters: Estimate Std. Error t value Pr(>|t|) coef 0.3037 0.2384 1.274 0.21274 exponent 0.6838 0.2366 2.890 0.00722 ** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 1.693 on 29 degrees of freedom Number of iterations to convergence: 2 Achieved convergence tolerance: 4.65e-12 ===varmod.method power0: predict(earth.mod, interval="pint") fit lwr upr 1 9.913855 6.333039 13.49467 2 10.942195 7.111381 14.77301 3 11.627755 7.634403 15.62111 4 17.455018 12.182992 22.72704 5 18.140578 12.727826 23.55333 6 18.483359 13.000875 23.96584 7 19.168919 13.548187 24.78965 8 19.168919 13.548187 24.78965 9 19.511699 13.822431 25.20097 10 19.854479 14.097054 25.61190 11 20.197259 14.372048 26.02247 12 20.540040 14.647405 26.43267 13 20.540040 14.647405 26.43267 14 21.568380 15.475575 27.66119 15 22.596721 16.306741 28.88670 16 25.681742 18.816523 32.54696 17 25.681742 18.816523 32.54696 18 27.052863 19.939078 34.16665 19 28.423983 21.065587 35.78238 20 28.766764 21.347802 36.18573 21 30.080913 22.431838 37.72999 22 31.395063 23.519032 39.27109 23 33.366287 25.155370 41.57720 24 43.222408 33.421821 53.02299 25 45.193632 35.089566 55.29770 26 51.764379 40.677507 62.85125 27 53.078529 41.799954 64.35710 28 55.706828 44.049286 67.36437 29 56.363903 44.612510 68.11530 30 56.363903 44.612510 68.11530 31 73.447846 59.364306 87.53139 ===varmod.method="lm" Full model GRSq 0.949 RSq 0.962, starting cross validation CV fold 1.1 CVRSq 0.913 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 1.2 CVRSq 0.949 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 1.3 CVRSq 0.928 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 2.1 CVRSq 0.952 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 2.2 CVRSq 0.917 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 2.3 CVRSq 0.947 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3.1 CVRSq 0.924 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 3.2 CVRSq 0.974 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3.3 CVRSq 0.957 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV all CVRSq 0.940 n.infold.nz 31 100% varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) Volume 1 11 0.000 1.09 0.064 2 16 18.134 0.85 0.073 3 16 1.170 0.83 0.074 4 16 0.045 0.83 0.074 ===varmod.method lm: summary(earth.mod) ===summary(earth.mod) Call: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9401008 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.94 0.02 10.4 7.04 varmod: method "lm" min.sd 0.383 iter.rsq 0.186 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 1.04223409 0.871036 84 Volume 0.09231383 0.0358384 39 mean smallest largest ratio 95% prediction interval 15.00326 7.672945 30.66358 3.996325 68% 80% 90% 95% response values in prediction interval 74 94 97 97 ===earth.mod$varmod method "lm" min.sd 0.383 iter.rsq 0.186 stddev of predictions (scaled by unit): coefficients iter.stderr iter.stderr% (Intercept) 11.29 9.4 84 Volume 1.00 0.4 39 unit 0.09 NA NA mean smallest largest ratio 95% prediction interval 15 7.7 31 4 68% 80% 90% 95% response values in prediction interval 74 94 97 97 ===summary(earth.mod$varmod) Parent model: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) method "lm" min.sd 0.383 iter.rsq 0.186 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 1.042 0.87 84 Volume 0.092 0.04 39 mean smallest largest ratio 95% prediction interval 15 7.7 31 4 68% 80% 90% 95% response values in prediction interval 74 94 97 97 Regression submodel (Abs Residuals): Call: lm(formula = abs.resids ~ ., data = data, weights = weights, y = TRUE) Coefficients: (Intercept) RHS 0.832 0.074 ===summary(earth.mod$varmod$residmod) Call: lm(formula = abs.resids ~ ., data = data, weights = weights, y = TRUE) Weighted Residuals: Min 1Q Median 3Q Max -2.4007 -1.1849 -0.3129 1.0673 5.8571 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 0.83158 0.69499 1.197 0.2412 RHS 0.07366 0.02859 2.576 0.0154 * --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 1.729 on 29 degrees of freedom Multiple R-squared: 0.1862, Adjusted R-squared: 0.1581 F-statistic: 6.635 on 1 and 29 DF, p-value: 0.01536 ===varmod.method lm: predict(earth.mod, interval="pint") fit lwr upr 1 9.913855 6.077382 13.75033 2 10.942195 6.919663 14.96473 3 11.627755 7.481184 15.77433 4 17.455018 12.254109 22.65593 5 18.140578 12.815630 23.46553 6 18.483359 13.096390 23.87033 7 19.168919 13.657911 24.67993 8 19.168919 13.657911 24.67993 9 19.511699 13.938671 25.08473 10 19.854479 14.219432 25.48953 11 20.197259 14.500192 25.89433 12 20.540040 14.780952 26.29913 13 20.540040 14.780952 26.29913 14 21.568380 15.623233 27.51353 15 22.596721 16.465514 28.72793 16 25.681742 18.992357 32.37113 17 25.681742 18.992357 32.37113 18 27.052863 20.115399 33.99033 19 28.423983 21.238440 35.60953 20 28.766764 21.519200 36.01433 21 30.080913 22.595579 37.56625 22 31.395063 23.671957 39.11817 23 33.366287 25.286524 41.44605 24 43.222408 33.359359 53.08546 25 45.193632 34.973926 55.41334 26 51.764379 40.355817 63.17294 27 53.078529 41.432195 64.72486 28 55.706828 43.584951 67.82870 29 56.363903 44.123140 68.60467 30 56.363903 44.123140 68.60467 31 73.447846 58.116055 88.77964 ===varmod.method="rlm" ===varmod.method rlm: summary(earth.mod) ===summary(earth.mod) Call: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9401008 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.94 0.02 10.4 7.04 varmod: method "rlm" min.sd 0.359 iter.rsq 0.179 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 0.9844540 0.785585 80 Volume 0.0862091 0.0323205 37 mean smallest largest ratio 95% prediction interval 14.05477 7.209212 28.67947 3.97817 68% 80% 90% 95% response values in prediction interval 71 90 97 97 ===earth.mod$varmod method "rlm" min.sd 0.359 iter.rsq 0.179 stddev of predictions (scaled by unit): coefficients iter.stderr iter.stderr% (Intercept) 11.42 9.1 80 Volume 1.00 0.4 37 unit 0.09 NA NA mean smallest largest ratio 95% prediction interval 14 7.2 29 4 68% 80% 90% 95% response values in prediction interval 71 90 97 97 ===summary(earth.mod$varmod) Parent model: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) method "rlm" min.sd 0.359 iter.rsq 0.179 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 0.984 0.79 80 Volume 0.086 0.03 37 mean smallest largest ratio 95% prediction interval 14 7.2 29 4 68% 80% 90% 95% response values in prediction interval 71 90 97 97 Regression submodel (Abs Residuals): Call: rlm(formula = abs.resids ~ ., data = data, weights = weights, method = "MM") Converged in 6 iterations Coefficients: (Intercept) RHS 0.785 0.069 Degrees of freedom: 31 total; 29 residual Scale estimate: 1.67 ===summary(earth.mod$varmod$residmod) Call: rlm(formula = abs.resids ~ ., data = data, weights = weights, method = "MM") Residuals: Min 1Q Median 3Q Max -2.2413 -1.0249 -0.1484 1.2252 6.0184 Coefficients: Value Std. Error t value (Intercept) 0.7855 0.6268 1.2531 RHS 0.0688 0.0258 2.6673 Residual standard error: 1.671 on 29 degrees of freedom ===varmod.method rlm: predict(earth.mod, interval="pint") fit lwr upr 1 9.913855 6.309248 13.51846 2 10.942195 7.163834 14.72056 3 11.627755 7.733557 15.52195 4 17.455018 12.576206 22.33383 5 18.140578 13.145930 23.13523 6 18.483359 13.430792 23.53593 7 19.168919 14.000515 24.33732 8 19.168919 14.000515 24.33732 9 19.511699 14.285377 24.73802 10 19.854479 14.570238 25.13872 11 20.197259 14.855100 25.53942 12 20.540040 15.139962 25.94012 13 20.540040 15.139962 25.94012 14 21.568380 15.994547 27.14221 15 22.596721 16.849132 28.34431 16 25.681742 19.412888 31.95060 17 25.681742 19.412888 31.95060 18 27.052863 20.552335 33.55339 19 28.423983 21.691782 35.15619 20 28.766764 21.976643 35.55688 21 30.080913 23.068745 37.09308 22 31.395063 24.160847 38.62928 23 33.366287 25.799000 40.93357 24 43.222408 33.989765 52.45505 25 45.193632 35.627918 54.75935 26 51.764379 41.088427 62.44033 27 53.078529 42.180529 63.97653 28 55.706828 44.364733 67.04892 29 56.363903 44.910784 67.81702 30 56.363903 44.910784 67.81702 31 73.447846 59.108109 87.78758 ===varmod.method="earth" ===varmod.method earth: summary(earth.mod) ===summary(earth.mod) Call: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9401008 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.94 0.02 10.4 7.04 varmod: method "earth" min.sd 0.38 iter.rsq 0.241 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 4.7975074 0.526686 11 h(25.6817-Volume) -0.2674352 0.0881764 33 mean smallest largest ratio 95% prediction interval 14.89945 2.275985 18.80588 8.262746 68% 80% 90% 95% response values in prediction interval 77 94 97 100 ===earth.mod$varmod method "earth" min.sd 0.38 iter.rsq 0.241 stddev of predictions (scaled by unit): coefficients iter.stderr iter.stderr% (Intercept) 18 1.97 11 h(25.6817-Volume) -1 0.33 33 mean smallest largest ratio 95% prediction interval 15 2.3 19 8.3 68% 80% 90% 95% response values in prediction interval 77 94 97 100 ===summary(earth.mod$varmod) Parent model: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) method "earth" min.sd 0.38 iter.rsq 0.241 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 4.80 0.53 11 h(25.6817-Volume) -0.27 0.09 33 mean smallest largest ratio 95% prediction interval 15 2.3 19 8.3 68% 80% 90% 95% response values in prediction interval 77 94 97 100 Regression submodel (Abs Residuals): Selected 2 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: RHS Number of terms at each degree of interaction: 1 1 (additive model) GCV 3.8 RSS 97 GRSq 0.13 RSq 0.24 ===summary(earth.mod$varmod$residmod) Call: earth(formula=abs.resids~., data=data, weights=weights, keepxy=TRUE, trace=trace, degree=..1, minspan=minspan) coefficients (Intercept) 3.8278571 h(25.6817-RHS) -0.2133824 Selected 2 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: RHS Number of terms at each degree of interaction: 1 1 (additive model) GCV 3.834325 RSS 96.97131 GRSq 0.1284858 RSq 0.2408143 ===varmod.method earth: predict(earth.mod, interval="pint") fit lwr upr 1 9.913855 8.775862 11.05185 2 10.942195 9.265184 12.61921 3 11.627755 9.591399 13.66411 4 17.455018 12.364224 22.54581 5 18.140578 12.690439 23.59072 6 18.483359 12.853546 24.11317 7 19.168919 13.179761 25.15808 8 19.168919 13.179761 25.15808 9 19.511699 13.342868 25.68053 10 19.854479 13.505975 26.20298 11 20.197259 13.669083 26.72544 12 20.540040 13.832190 27.24789 13 20.540040 13.832190 27.24789 14 21.568380 14.321512 28.81525 15 22.596721 14.810834 30.38261 16 25.681742 16.278800 35.08468 17 25.681742 16.278800 35.08468 18 27.052863 17.649921 36.45580 19 28.423983 19.021042 37.82693 20 28.766764 19.363822 38.16971 21 30.080913 20.677971 39.48385 22 31.395063 21.992121 40.79800 23 33.366287 23.963345 42.76923 24 43.222408 33.819466 52.62535 25 45.193632 35.790690 54.59657 26 51.764379 42.361438 61.16732 27 53.078529 43.675587 62.48147 28 55.706828 46.303886 65.10977 29 56.363903 46.960961 65.76684 30 56.363903 46.960961 65.76684 31 73.447846 64.044904 82.85079 ===varmod.method="gam" Loading required package: splines Loading required package: foreach Loaded gam 1.16.1 Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored ===varmod.method gam: summary(earth.mod) ===summary(earth.mod) Call: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9401008 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.94 0.02 10.4 7.04 varmod: method "gam" (gam package) min.sd 0.373 iter.rsq 0.271 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 0.90395875 0.816758 90 s(Volume) 0.09087774 0.0340212 37 mean smallest largest ratio 95% prediction interval 14.63944 7.984429 26.45596 3.313444 68% 80% 90% 95% response values in prediction interval 84 90 97 97 ===earth.mod$varmod method "gam" (gam package) min.sd 0.373 iter.rsq 0.271 stddev of predictions (scaled by unit): coefficients iter.stderr iter.stderr% (Intercept) 9.95 9 90 s(Volume) 1.00 0.4 37 unit 0.09 NA NA mean smallest largest ratio 95% prediction interval 15 8 26 3.3 68% 80% 90% 95% response values in prediction interval 84 90 97 97 ===summary(earth.mod$varmod) Parent model: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) method "gam" (gam package) min.sd 0.373 iter.rsq 0.271 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 0.904 0.82 90 s(Volume) 0.091 0.03 37 mean smallest largest ratio 95% prediction interval 15 8 26 3.3 68% 80% 90% 95% response values in prediction interval 84 90 97 97 Regression submodel (Abs Residuals): Call: gam::gam(formula = form, data = data, weights = weights) Degrees of Freedom: 30 total; 26 Residual Residual Deviance: 69.35 ===summary(earth.mod$varmod$residmod) Call: gam::gam(formula = form, data = data, weights = weights) Deviance Residuals: Min 1Q Median 3Q Max -2.2464 -0.9264 -0.1597 0.7912 4.5141 (Dispersion Parameter for gaussian family taken to be 2.6674) Null Deviance: 95.1631 on 30 degrees of freedom Residual Deviance: 69.3525 on 25.9999 degrees of freedom AIC: 133.2783 Number of Local Scoring Iterations: 2 Anova for Parametric Effects Df Sum Sq Mean Sq F value Pr(>F) s(RHS) 1 19.033 19.0329 7.1354 0.01287 * Residuals 26 69.353 2.6674 --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Anova for Nonparametric Effects Npar Df Npar F Pr(F) (Intercept) s(RHS) 3 0.84695 0.4808 ===varmod.method gam: predict(earth.mod, interval="pint") fit lwr upr 1 9.913855 5.764567 14.06314 2 10.942195 6.891083 14.99331 3 11.627755 7.635541 15.61997 4 17.455018 13.288559 21.62148 5 18.140578 13.807943 22.47321 6 18.483359 14.052497 22.91422 7 19.168919 14.514981 23.82286 8 19.168919 14.514981 23.82286 9 19.511699 14.735062 24.28834 10 19.854479 14.948275 24.76068 11 20.197259 15.154184 25.24033 12 20.540040 15.352863 25.72722 13 20.540040 15.352863 25.72722 14 21.568380 15.904134 27.23263 15 22.596721 16.407111 28.78633 16 25.681742 18.006579 33.35691 17 25.681742 18.006579 33.35691 18 27.052863 18.906909 35.19882 19 28.423983 19.922792 36.92518 20 28.766764 20.191769 37.34176 21 30.080913 21.270124 38.89170 22 31.395063 22.402661 40.38746 23 33.366287 24.139303 42.59327 24 43.222408 33.212278 53.23254 25 45.193632 35.096740 55.29052 26 51.764379 41.207623 62.32114 27 53.078529 42.375943 63.78111 28 55.706828 44.658253 66.75540 29 56.363903 45.223339 67.50447 30 56.363903 45.223339 67.50447 31 73.447846 60.219868 86.67582 ===varmod.method="x.lm" ===varmod.method x.lm: summary(earth.mod) ===summary(earth.mod) Call: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9401008 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.94 0.02 10.4 7.04 varmod: method "x.lm" min.sd 0.378 iter.rsq 0.217 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) -1.6318976 1.67757 103 Girth 0.4084884 0.144115 35 mean smallest largest ratio 95% prediction interval 14.81699 6.893412 26.58873 3.857121 68% 80% 90% 95% response values in prediction interval 77 94 97 97 ===earth.mod$varmod method "x.lm" min.sd 0.378 iter.rsq 0.217 stddev of predictions (scaled by unit): coefficients iter.stderr iter.stderr% (Intercept) -3.99 4.1 103 Girth 1.00 0.4 35 unit 0.41 NA NA mean smallest largest ratio 95% prediction interval 15 6.9 27 3.9 68% 80% 90% 95% response values in prediction interval 77 94 97 97 ===summary(earth.mod$varmod) Parent model: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) method "x.lm" min.sd 0.378 iter.rsq 0.217 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) -1.63 1.68 103 Girth 0.41 0.14 35 mean smallest largest ratio 95% prediction interval 15 6.9 27 3.9 68% 80% 90% 95% response values in prediction interval 77 94 97 97 Regression submodel (Abs Residuals): Call: lm(formula = abs.resids ~ ., data = data, weights = weights, y = TRUE) Coefficients: (Intercept) Girth -1.30 0.33 ===summary(earth.mod$varmod$residmod) Call: lm(formula = abs.resids ~ ., data = data, weights = weights, y = TRUE) Weighted Residuals: Min 1Q Median 3Q Max -2.3859 -1.2223 -0.0691 0.9672 5.2921 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -1.3021 1.3385 -0.973 0.33871 Girth 0.3259 0.1150 2.834 0.00827 ** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 1.642 on 29 degrees of freedom Multiple R-squared: 0.2169, Adjusted R-squared: 0.1899 F-statistic: 8.034 on 1 and 29 DF, p-value: 0.008275 ===varmod.method x.lm: predict(earth.mod, interval="pint") fit lwr upr 1 9.913855 6.467148 13.36056 2 10.942195 7.255302 14.62909 3 11.627755 7.780738 15.47477 4 17.455018 12.246943 22.66309 5 18.140578 12.772378 23.50878 6 18.483359 13.035096 23.93162 7 19.168919 13.560532 24.77731 8 19.168919 13.560532 24.77731 9 19.511699 13.823250 25.20015 10 19.854479 14.085968 25.62299 11 20.197259 14.348686 26.04583 12 20.540040 14.611404 26.46868 13 20.540040 14.611404 26.46868 14 21.568380 15.399557 27.73720 15 22.596721 16.187711 29.00573 16 25.681742 18.552172 32.81131 17 25.681742 18.552172 32.81131 18 27.052863 19.603044 34.50268 19 28.423983 20.653916 36.19405 20 28.766764 20.916634 36.61689 21 30.080913 22.070659 38.09117 22 31.395063 23.224684 39.56544 23 33.366287 24.955721 41.77685 24 43.222408 33.610908 52.83391 25 45.193632 35.341946 55.04532 26 51.764379 41.112071 62.41669 27 53.078529 42.266096 63.89096 28 55.706828 44.574146 66.83951 29 56.363903 45.151158 67.57665 30 56.363903 45.151158 67.57665 31 73.447846 60.153483 86.74221 ===varmod.method="x.rlm" ===varmod.method x.rlm: summary(earth.mod) ===summary(earth.mod) Call: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9401008 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.94 0.02 10.4 7.04 varmod: method "x.rlm" min.sd 0.36 iter.rsq 0.214 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) -1.4695340 1.57954 107 Girth 0.3827563 0.135229 35 mean smallest largest ratio 95% prediction interval 14.11711 6.692661 25.1473 3.757444 68% 80% 90% 95% response values in prediction interval 71 90 97 97 ===earth.mod$varmod method "x.rlm" min.sd 0.36 iter.rsq 0.214 stddev of predictions (scaled by unit): coefficients iter.stderr iter.stderr% (Intercept) -3.84 4.1 107 Girth 1.00 0.4 35 unit 0.38 NA NA mean smallest largest ratio 95% prediction interval 14 6.7 25 3.8 68% 80% 90% 95% response values in prediction interval 71 90 97 97 ===summary(earth.mod$varmod) Parent model: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) method "x.rlm" min.sd 0.36 iter.rsq 0.214 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) -1.47 1.58 107 Girth 0.38 0.14 35 mean smallest largest ratio 95% prediction interval 14 6.7 25 3.8 68% 80% 90% 95% response values in prediction interval 71 90 97 97 Regression submodel (Abs Residuals): Call: rlm(formula = abs.resids ~ ., data = data, weights = weights, method = "MM", y.ret = TRUE) Converged in 6 iterations Coefficients: (Intercept) Girth -1.17 0.31 Degrees of freedom: 31 total; 29 residual Scale estimate: 1.67 ===summary(earth.mod$varmod$residmod) Call: rlm(formula = abs.resids ~ ., data = data, weights = weights, method = "MM", y.ret = TRUE) Residuals: Min 1Q Median 3Q Max -2.28196 -1.11477 0.05309 1.10372 5.44602 Coefficients: Value Std. Error t value (Intercept) -1.1725 1.2603 -0.9304 Girth 0.3054 0.1079 2.8304 Residual standard error: 1.667 on 29 degrees of freedom ===varmod.method x.rlm: predict(earth.mod, interval="pint") fit lwr upr 1 9.913855 6.567524 13.26019 2 10.942195 7.370808 14.51358 3 11.627755 7.906330 15.34918 4 17.455018 12.458273 22.45176 5 18.140578 12.993795 23.28736 6 18.483359 13.261557 23.70516 7 19.168919 13.797079 24.54076 8 19.168919 13.797079 24.54076 9 19.511699 14.064841 24.95856 10 19.854479 14.332602 25.37636 11 20.197259 14.600363 25.79416 12 20.540040 14.868125 26.21195 13 20.540040 14.868125 26.21195 14 21.568380 15.671409 27.46535 15 22.596721 16.474692 28.71875 16 25.681742 18.884544 32.47894 17 25.681742 18.884544 32.47894 18 27.052863 19.955590 34.15014 19 28.423983 21.026635 35.82133 20 28.766764 21.294396 36.23913 21 30.080913 22.458508 37.70332 22 31.395063 23.622620 39.16751 23 33.366287 25.368787 41.36379 24 43.222408 34.099626 52.34519 25 45.193632 35.845793 54.54147 26 51.764379 41.666352 61.86241 27 53.078529 42.830464 63.32659 28 55.706828 45.158688 66.25497 29 56.363903 45.740744 66.98706 30 56.363903 45.740744 66.98706 31 73.447846 60.874197 86.02149 ===varmod.method="x.earth" ===varmod.method x.earth: summary(earth.mod) ===summary(earth.mod) Call: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9401008 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.94 0.02 10.4 7.04 varmod: method "x.earth" min.sd 0.38 iter.rsq 0.272 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 2.5942766 0.544528 21 h(Girth-11) 0.4795752 0.145551 30 mean smallest largest ratio 95% prediction interval 14.89945 10.16938 28.21642 2.774646 68% 80% 90% 95% response values in prediction interval 81 90 97 97 ===earth.mod$varmod method "x.earth" min.sd 0.38 iter.rsq 0.272 stddev of predictions (scaled by unit): coefficients iter.stderr iter.stderr% (Intercept) 5.4 1.14 21 h(Girth-11) 1.0 0.3 30 mean smallest largest ratio 95% prediction interval 15 10 28 2.8 68% 80% 90% 95% response values in prediction interval 81 90 97 97 ===summary(earth.mod$varmod) Parent model: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) method "x.earth" min.sd 0.38 iter.rsq 0.272 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 2.59 0.54 21 h(Girth-11) 0.48 0.15 30 mean smallest largest ratio 95% prediction interval 15 10 28 2.8 68% 80% 90% 95% response values in prediction interval 81 90 97 97 Regression submodel (Abs Residuals): Selected 2 of 5 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Importance: Girth Number of terms at each degree of interaction: 1 1 (additive model) GCV 3.7 RSS 93 GRSq 0.16 RSq 0.27 ===summary(earth.mod$varmod$residmod) Call: earth(formula=abs.resids~., data=data, weights=weights, keepxy=TRUE, trace=trace, degree=..1, minspan=minspan) coefficients (Intercept) 2.0699332 h(Girth-11) 0.3826456 Selected 2 of 5 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Importance: Girth Number of terms at each degree of interaction: 1 1 (additive model) GCV 3.674869 RSS 92.93863 GRSq 0.1647288 RSq 0.272386 ===varmod.method x.earth: predict(earth.mod, interval="pint") fit lwr upr 1 9.913855 4.829166 14.99854 2 10.942195 5.857506 16.02688 3 11.627755 6.543067 16.71244 4 17.455018 12.370330 22.53971 5 18.140578 13.055890 23.22527 6 18.483359 13.398670 23.56805 7 19.168919 14.084230 24.25361 8 19.168919 14.084230 24.25361 9 19.511699 14.333016 24.69038 10 19.854479 14.581801 25.12716 11 20.197259 14.830586 25.56393 12 20.540040 15.079371 26.00071 13 20.540040 15.079371 26.00071 14 21.568380 15.825726 27.31103 15 22.596721 16.572082 28.62136 16 25.681742 18.811148 32.55234 17 25.681742 18.811148 32.55234 18 27.052863 19.806289 34.29944 19 28.423983 20.801430 36.04654 20 28.766764 21.050215 36.48331 21 30.080913 22.176374 37.98545 22 31.395063 23.302534 39.48759 23 33.366287 24.991773 41.74080 24 43.222408 33.437969 53.00685 25 45.193632 35.127208 55.26006 26 51.764379 40.758005 62.77075 27 53.078529 41.884165 64.27289 28 55.706828 44.136484 67.27717 29 56.363903 44.699563 68.02824 30 56.363903 44.699563 68.02824 31 73.447846 59.339636 87.55606 ===varmod.method="x.gam" Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored ===varmod.method x.gam: summary(earth.mod) ===summary(earth.mod) Call: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9401008 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.94 0.02 10.4 7.04 varmod: method "x.gam" (gam package) min.sd 0.374 iter.rsq 0.289 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) -2.1239640 1.8135 85 s(Volume) 0.4316199 0.156258 36 mean smallest largest ratio 95% prediction interval 14.67221 7.622878 26.26615 3.445701 68% 80% 90% 95% response values in prediction interval 84 87 97 100 ===earth.mod$varmod method "x.gam" (gam package) min.sd 0.374 iter.rsq 0.289 stddev of predictions (scaled by unit): coefficients iter.stderr iter.stderr% (Intercept) -4.92 4.2 85 s(Volume) 1.00 0.4 36 unit 0.43 NA NA mean smallest largest ratio 95% prediction interval 15 7.6 26 3.4 68% 80% 90% 95% response values in prediction interval 84 87 97 100 ===summary(earth.mod$varmod) Parent model: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) method "x.gam" (gam package) min.sd 0.374 iter.rsq 0.289 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) -2.12 1.81 85 s(Volume) 0.43 0.16 36 mean smallest largest ratio 95% prediction interval 15 7.6 26 3.4 68% 80% 90% 95% response values in prediction interval 84 87 97 100 Regression submodel (Abs Residuals): Call: gam::gam(formula = form, data = data, weights = weights) Degrees of Freedom: 30 total; 26 Residual Residual Deviance: 65.15 ===summary(earth.mod$varmod$residmod) Call: gam::gam(formula = form, data = data, weights = weights) Deviance Residuals: Min 1Q Median 3Q Max -2.2060 -0.8878 -0.1530 0.7521 4.0281 (Dispersion Parameter for gaussian family taken to be 2.5059) Null Deviance: 91.5706 on 30 degrees of freedom Residual Deviance: 65.1524 on 26 degrees of freedom AIC: 132.156 Number of Local Scoring Iterations: 2 Anova for Parametric Effects Df Sum Sq Mean Sq F value Pr(>F) s(RHS) 1 19.120 19.1196 7.6299 0.0104 * Residuals 26 65.152 2.5059 --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Anova for Nonparametric Effects Npar Df Npar F Pr(F) (Intercept) s(RHS) 3 0.97087 0.4214 ===varmod.method x.gam: predict(earth.mod, interval="pint") fit lwr upr 1 9.913855 5.505536 14.32217 2 10.942195 6.770308 15.11408 3 11.627755 7.601547 15.65396 4 17.455018 13.643579 21.26646 5 18.140578 14.126734 22.15442 6 18.483359 14.345510 22.62121 7 19.168919 14.748924 23.58891 8 19.168919 14.748924 23.58891 9 19.511699 14.939781 24.08362 10 19.854479 15.124403 24.58456 11 20.197259 15.300626 25.09389 12 20.540040 15.467505 25.61257 13 20.540040 15.467505 25.61257 14 21.568380 15.896738 27.24002 15 22.596721 16.243213 28.95023 16 25.681742 17.508646 33.85484 17 25.681742 17.508646 33.85484 18 27.052863 18.435857 35.66987 19 28.423983 19.537481 37.31049 20 28.766764 19.830369 37.70316 21 30.080913 21.059261 39.10256 22 31.395063 22.299109 40.49102 23 33.366287 24.156085 42.57649 24 43.222408 33.353500 53.09132 25 45.193632 35.187814 55.19945 26 51.764379 41.190650 62.33811 27 53.078529 42.363566 63.79349 28 55.706828 44.683386 66.73027 29 56.363903 45.260369 67.46744 30 56.363903 45.260369 67.46744 31 73.447846 60.314769 86.58092 detach("package:gam", unload=TRUE) ===varmod.method="gam" skipping mgcv tests ===varmod.method="x.gam" skipping mgcv tests > # test varmod.exponent > set.seed(6) > earth.exponent <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, + varmod.method="lm", varmod.exponent=.5) > printh("summary(earth.exponent)") ===summary(earth.exponent) > print(summary(earth.exponent)) Call: earth(formula=Volume~Girth, data=trees, nfold=3, ncross=3, varmod.method="lm", varmod.exponent=0.5) coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9266989 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.927 0.043 9.81 7.21 varmod: method "lm" exponent 0.500 min.sd 0.374 iter.rsq 0.339 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) -2.801211 1.36234 49 sqrt(Volume) 1.229319 0.318489 26 mean smallest largest ratio 95% prediction interval 14.6542 4.192195 30.31777 7.231956 68% 80% 90% 95% response values in prediction interval 71 90 97 97 > > par(old.par) > > source("test.epilog.R") earth/inst/slowtests/test.full.Rout.save0000644000176200001440000123304113560110450020130 0ustar liggesusers> # test.full.R: test earth > > print(R.version.string) [1] "R version 3.6.1 (2019-07-05)" > > source("test.prolog.R") > source("check.models.equal.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > library(mda) Loading required package: class Loaded mda 0.4-10 > data(ozone1) > data(trees) > data(etitanic) > > PRINT.TIME <- FALSE # FALSE for no time results (for diff against reference) > PLOT <- TRUE # TRUE to do plots too, FALSE for speed > options.old <- options() > options(warn=1) # print warnings as they occur > # options(digits=5) # removed because want to check against default > > printh <- function(x, expect.warning=FALSE, max.print=0) # like print but with a header + { + cat("===", deparse(substitute(x)), " ", sep="") + if(expect.warning) + cat(" expect warning -->") + else if (NROW(x) > 1) + cat("\n") + if (max.print > 0) + print(head(x, n=max.print)) + else + print(x) + } > > print(citation("earth")) To cite package 'earth' in publications use: Stephen Milborrow. Derived from mda:mars by Trevor Hastie and Rob Tibshirani. Uses Alan Miller's Fortran utilities with Thomas Lumley's leaps wrapper. (2011). earth: Multivariate Adaptive Regression Splines. R package version 5.1.2. https://CRAN.R-project.org/package=earth A BibTeX entry for LaTeX users is @Manual{, title = {earth: Multivariate Adaptive Regression Splines}, author = {Stephen Milborrow. Derived from mda:mars by Trevor Hastie and Rob Tibshirani. Uses Alan Miller's Fortran utilities with Thomas Lumley's leaps wrapper.}, year = {2011}, note = {R package version 5.1.2}, url = {https://CRAN.R-project.org/package=earth}, } ATTENTION: This citation information has been auto-generated from the package DESCRIPTION file and may need manual editing, see 'help("citation")'. > > #--- test examples from man pages ------------------------------------------------------------ > > cat("--- earth.Rd -----------------------------\n") --- earth.Rd ----------------------------- > example(earth) earth> earth.mod <- earth(Volume ~ ., data = trees) earth> plotmo(earth.mod) plotmo grid: Girth Height 12.9 76 earth> summary(earth.mod, digits = 2, style = "pmax") Call: earth(formula=Volume~., data=trees) Volume = 29 - 3.4 * pmax(0, 14 - Girth) + 6.2 * pmax(0, Girth - 14) + 0.58 * pmax(0, Height - 75) 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 RSS 209 GRSq 0.96 RSq 0.97 > > set.seed(2015) > > train.subset <- sample(1:nrow(trees), .8 * nrow(trees)) > test.subset <- (1:nrow(trees))[-train.subset] > > earth.model <- earth(Volume ~ ., data = trees[train.subset,]) > > # print R-Squared on the test data > print(summary(earth.model, newdata=trees[test.subset,])) RSq 0.959 on newdata (7 cases) > > # manually calculate R-Squared on the test data (same as above call to summary) > yhat <- predict(earth.model, newdata = trees[test.subset,]) > y <- trees$Volume[test.subset] > printh(1 - sum((y - yhat)^2) / sum((y - mean(y))^2)) # print R-Squared ===1 - sum((y - yhat)^2)/sum((y - mean(y))^2) [1] 0.9592516 > > newrsq <- 1 - sum((y - yhat)^2) / sum((y - mean(y))^2) > stopifnot(abs(summary(earth.model, newdata=trees[test.subset,])$newrsq - newrsq) < 1e-10) > > cars <- earth(mpg ~ ., data = mtcars, pmethod = "none", trace = 4) Call: earth(formula=mpg~., data=mtcars, pmethod="none", trace=4) x[32,10]: cyl disp hp drat wt qsec vs am gear carb Mazda RX4 6 160 110 3.90 2.620 16.46 0 1 4 4 Mazda RX4 Wag 6 160 110 3.90 2.875 17.02 0 1 4 4 Datsun 710 4 108 93 3.85 2.320 18.61 1 1 4 1 ... 6 258 110 3.08 3.215 19.44 1 0 3 1 Volvo 142E 4 121 109 4.11 2.780 18.60 1 1 4 2 y[32,1]: mpg 1 21.0 2 21.0 3 22.8 ... 21.4 32 21.4 Forward pass: minspan 5 endspan 10 x[32,10] 2.5 kB bx[32,21] 5.25 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.8157 0.8602 0.8602 2 disp 145 2 3 1 4 0.7815 0.8797 0.01956 3 hp 123 4 5 1 6 0.7601 0.9099 0.03016 6 qsec 18.52 6 7 1 8 0.6839 0.9260 0.01611 4 drat 3.15 8 9 1 10 0.5031 0.9374 0.01144 9 gear 4 10 11 1 12 0.3575 0.9458 0.008417 2 disp 275.8 12 1 14 0.0073 0.9494 0.003535 6 qsec 17.02 13 1 16 -0.5893 0.9587 0.009271 7 vs 0< 14 1 18 -35.8726 0.9616 0.002977 10 carb 2 15 16 1 reject (negative GRSq) Reached minimum GRSq -10 at 17 terms, 14 terms used (GRSq -36) After forward pass GRSq -35.873 RSq 0.962 Forward pass complete: 17 terms, 14 terms used Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 2 0.6706 0.7118 0.6706 1 1 3 3 0.8157 0.8602 0.1450 1 1 2 3 4 0.7988 0.8691 -0.0169 2 1 2 3 4 5 0.7815 0.8797 -0.0173 2 1 2 3 4 5 6 0.7601 0.8899 -0.0214 4 1 3 4 6 13 14 7 0.7934 0.9224 0.0332 4 1 3 4 5 6 13 14 8 0.7852 0.9354 -0.0082 5 1 3 4 5 6 9 13 14 9 0.7579 0.9433 -0.0272 5 1 3 4 5 6 9 12 13 14 10 0.6997 0.9472 -0.0582 6 1 3 4 5 6 9 10 12 13 14 11 0.6132 0.9513 -0.0865 6 1 2 3 4 5 6 9 10 12 13 14 12 0.4534 0.9539 -0.1598 6 1 2 3 4 5 6 9 10 11 12 13 14 13 0.1741 0.9579 -0.2793 6 1 2 3 4 5 6 8 9 10 11 12 13 14 chosen 14 -0.5893 0.9587 -0.7634 6 1 2 3 4 5 6 7 8 9 10 11 12 13 14 Prune none penalty 2 nprune null: selected 14 of 14 terms, and 6 of 10 preds After pruning pass GRSq -0.589 RSq 0.959 > > stopifnot(max(coef(cars) - cars$coefficients) == 0) > stopifnot(max(coef(cars, type="response") - cars$coefficients) == 0) > stopifnot(max(coef(cars, type="earth") - cars$coefficients) == 0) > expect.err(try(coef(cars, type="nonesuch")), "type=\"nonesuch\" is not allowed") Error : type="nonesuch" is not allowed Choose one of: "response" "earth" "glm" Got error as expected from try(coef(cars, type = "nonesuch")) > expect.err(try(coef(cars, type="glm")), "type == \"glm\" is not allowed because this is not an earth-glm model") Error : coef.earth: type == "glm" is not allowed because this is not an earth-glm model Got error as expected from try(coef(cars, type = "glm")) > expect.err(try(coefficients(cars, type="glm")), "type == \"glm\" is not allowed because this is not an earth-glm model") Error : coef.earth: type == "glm" is not allowed because this is not an earth-glm model Got error as expected from try(coefficients(cars, type = "glm")) > stopifnot(isTRUE(all.equal(coef(cars), coefficients(cars)))) > stopifnot(isTRUE(all.equal(coef(cars, type="earth"), coefficients(cars, type="earth")))) > stopifnot(identical(names(coef(cars)), rownames(cars$coefficients))) > > get.used.pred.names <- function(obj) # obj is an earth object + { + any1 <- function(x) any(x != 0) # like any but no warning if x is double + names(which(apply(obj$dirs[obj$selected.terms,,drop=FALSE],2,any1))) + } > printh(get.used.pred.names(cars)) ===get.used.pred.names(cars) [1] "disp" "hp" "drat" "qsec" "vs" "gear" > > a1 <- earth(survived ~ ., data=etitanic, # c.f. Harrell "Reg. Mod. Strat." ch. 12 + degree=2, trace=1, + glm=list(family=binomial)) x[1046,6] with colnames pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname survived, and values 1, 1, 0, 0, 0, 1, 1, 0, 1, 0,... Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.406 RSq 0.450 Prune backward penalty 3 nprune null: selected 8 of 17 terms, and 5 of 6 preds After pruning pass GRSq 0.42 RSq 0.439 GLM survived devratio 0.37 dof 1038/1045 iters 5 > printh(a1) ===a1 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 Termination condition: Reached nk 21 Importance: sexmale, 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 > > a1a <- earth(etitanic[,-2], etitanic[,2], # equivalent but using earth.default + degree=2, trace=1, + glm=list(family=binomial)) x[1046,6] with colnames pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname etitanic[,2], and values 1, 1, 0, 0, 0, 1, 1, 0, 1, 0,... Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.406 RSq 0.450 Prune backward penalty 3 nprune null: selected 8 of 17 terms, and 5 of 6 preds After pruning pass GRSq 0.42 RSq 0.439 GLM etitanic[,2] devratio 0.37 dof 1038/1045 iters 5 > printh(a1a) ===a1a 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 Termination condition: Reached nk 21 Importance: sexmale, 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 > > a2 <- earth(pclass ~ ., data=etitanic, glm=list(family=binomial), trace=1) x[1046,5] with colnames survived sexmale age sibsp parch y[1046,3] with colnames 1st 2nd 3rd Forward pass term 1, 2, 4, 6, 8, 10, 12, 14 RSq changed by less than 0.001 at 13 terms, 10 terms used (DeltaRSq 0.00065) After forward pass GRSq 0.163 RSq 0.195 Prune backward penalty 2 nprune null: selected 8 of 10 terms, and 4 of 5 preds After pruning pass GRSq 0.167 RSq 0.189 GLM 1st devratio 0.25 dof 1038/1045 iters 5 GLM 2nd devratio 0.02 dof 1038/1045 iters 5 GLM 3rd devratio 0.21 dof 1038/1045 iters 5 > printh(a2) ===a2 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 1223.31 1045 920.802 1038 0.2470 936.8 5 1 2nd 1175.31 1045 1147.518 1038 0.0236 1164.0 5 1 3rd 1448.21 1045 1142.756 1038 0.2110 1159.0 5 1 Earth selected 8 of 10 terms, and 4 of 5 predictors Termination condition: RSq changed by less than 0.001 at 10 terms Importance: age, survived, sibsp, parch, sexmale-unused Number of terms at each degree of interaction: 1 7 (additive model) Earth GCV RSS GRSq RSq 1st 0.1483414 150.7467 0.251448718 0.27137124 2nd 0.1885520 191.6094 -0.004971341 0.02177575 3rd 0.1927692 195.8949 0.229032722 0.24955184 All 0.5296626 538.2511 0.166969402 0.18914032 > > ldose <- rep(0:5, 2) - 2 # Venables and Ripley 4th edition page 191 > sex <- factor(rep(c("male", "female"), times=c(6,6))) > numdead <- c(1,4,9,13,18,20,0,2,6,10,12,16) > pair <- cbind(numdead, numalive=20 - numdead) > > a3 <- earth(pair ~ sex + ldose, + glm=list(family=binomial(link=probit), maxit=100), trace=1) x[12,2] with colnames sexmale ldose y[12,2] with colnames numdead numalive earth and glm: unweighted Response columns numdead and numalive are a binomial pair (240 obs in total) yfrac[12,1] with colname numdead, and values 0.05, 0.2, 0.45, 0.65, 0.9, 1... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 3 terms used (DeltaRSq 0) After forward pass GRSq 0.907 RSq 0.981 Prune backward penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.952 RSq 0.981 GLM numdead devratio 0.96 dof 9/11 iters 4 > printh(a3) ===a3 GLM (family binomial, link probit): nulldev df dev df devratio AIC iters converged 124.876 11 5.56596 9 0.955 41.68 4 1 Earth selected 3 of 3 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: ldose, sexmale Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.005940233 RSS 0.02425595 GRSq 0.952486 RSq 0.9807588 > > numalive <- 20 - numdead > pairmod2 <- earth(numalive + numdead ~ sex + ldose, + glm=list(family=binomial()), trace=1) Using class "Formula" because lhs of formula has terms separated by "+" x[12,2] with colnames sexmale ldose y[12,2] with colnames numalive numdead earth and glm: unweighted Response columns numalive and numdead are a binomial pair (240 obs in total) yfrac[12,1] with colname numalive, and values 0.95, 0.8, 0.55, 0.35, 0.1, 0... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 3 terms used (DeltaRSq 0) After forward pass GRSq 0.907 RSq 0.981 Prune backward penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.952 RSq 0.981 GLM numalive devratio 0.95 dof 9/11 iters 4 > printh(pairmod2) ===pairmod2 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 124.876 11 6.75706 9 0.946 42.87 4 1 Earth selected 3 of 3 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: ldose, sexmale Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.005940233 RSS 0.02425595 GRSq 0.952486 RSq 0.9807588 > > # multiple responses with short (compacted) binomial data no longer supported > numdead2.verylongname <- c(2,8,11,12,20,23,0,4,6,16,12,14) # bogus data > doublepair <- cbind(numdead, numalive=20-numdead, + numdead2.verylongname=numdead2.verylongname, + numalive2.verylongname=30-numdead2.verylongname) > expect.err(try(earth(doublepair ~ sex + ldose, trace=1, pmethod="none", glm=list(family="binomial"))), + "Binomial response (see above): all values should be between 0 and 1, or a binomial pair") x[12,2] with colnames sexmale ldose y[12,4] with colnames numdead numalive numdead2.verylongname numalive2.verylong... print(head(y)): numdead numalive numdead2.verylongname numalive2.verylongname [1,] 1 19 2 28 [2,] 4 16 8 22 [3,] 9 11 11 19 [4,] 13 7 12 18 [5,] 18 2 20 10 [6,] 20 0 23 7 Error : Binomial response (see above): all values should be between 0 and 1, or a binomial pair Got error as expected from try(earth(doublepair ~ sex + ldose, trace = 1, pmethod = "none", glm = list(family = "binomial"))) > > counts <- c(18,17,15,20,10,20,25,13,12) # Dobson 1990 p. 93 > outcome <- gl(3,1,9) > treatment <- gl(3,3) > > a5 <- earth(counts ~ outcome + treatment, trace=1, pmethod="none", + glm=list(family=poisson)) x[9,4] with colnames outcome2 outcome3 treatment2 treatment3 y[9,1] with colname counts, and values 18, 17, 15, 20, 10, 20, 25, 1... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 3 terms used (DeltaRSq 0) After forward pass GRSq -6.576 RSq 0.527 Prune none penalty 2 nprune null: selected 3 of 3 terms, and 2 of 4 preds After pruning pass GRSq -0.894 RSq 0.527 GLM counts devratio 0.52 dof 6/8 iters 4 > printh(a5) ===a5 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged 10.5815 8 5.12914 6 0.515 52.76 4 1 Earth selected 3 of 3 terms, and 2 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 3 terms Importance: outcome2, outcome3, treatment2-unused, treatment3-unused Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 46.875 RSS 83.33333 GRSq -0.8939394 RSq 0.5265152 > > a6 <- earth(numdead ~ sex + ldose, + glm=list(family=gaussian(link=identity)), trace=1) x[12,2] with colnames sexmale ldose y[12,1] with colname numdead, and values 1, 4, 9, 13, 18, 20, 0, 2, 6,... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 3 terms used (DeltaRSq 0) After forward pass GRSq 0.907 RSq 0.981 Prune backward penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.952 RSq 0.981 GLM numdead devratio 0.98 dof 9/11 iters 2 > printh(a6$coefficients == a6$glm.coefficients) # all TRUE ===a6$coefficients == a6$glm.coefficients numdead (Intercept) TRUE ldose TRUE sexmale TRUE > printh(a6) ===a6 GLM (family gaussian, link identity): nulldev df dev df devratio AIC iters converged 504.25 11 9.70238 9 0.981 39.5 2 1 Earth selected 3 of 3 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: ldose, sexmale Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 2.376093 RSS 9.702381 GRSq 0.952486 RSq 0.9807588 > > remove(ldose) > remove(sex) > remove(numdead) > remove(pair) > remove(numdead2.verylongname) > remove(doublepair) > remove(counts) > remove(outcome) > remove(treatment) > > printh(earth(cbind(Volume,lvol=log(Volume)) ~ ., data=trees)) ===earth(cbind(Volume, lvol = log(Volume)) ~ ., data = trees) 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 RSS GRSq RSq Volume 11.2543915 209.113855 0.9596919 0.9742028 lvol 0.0158825 0.295106 0.9445035 0.9644822 All 11.2702739 209.408961 0.9596764 0.9741929 > attach(trees) > printh(earth(data.frame(Girth,Height), data.frame(Volume,lvol=log(Volume)))) ===earth(data.frame(Girth, Height), data.frame(Volume, lvol = log(Volume))) 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 RSS GRSq RSq Volume 11.2543915 209.113855 0.9596919 0.9742028 lvol 0.0158825 0.295106 0.9445035 0.9644822 All 11.2702739 209.408961 0.9596764 0.9741929 > detach(trees) > > lm.fit <- lm(O3 ~ log(temp) + humidity*temp, data=ozone1) > printh(lm.fit) ===lm.fit Call: lm(formula = O3 ~ log(temp) + humidity * temp, data = ozone1) Coefficients: (Intercept) log(temp) humidity temp humidity:temp 94.85623 -31.27411 -0.20050 0.63299 0.00475 > plotmo(lm.fit, level=.95, trace=-1) > lm.fit2 <- lm(O3 ~ temp+ibh+doy, data=ozone1) > printh(lm.fit2) ===lm.fit2 Call: lm(formula = O3 ~ temp + ibh + doy, data = ozone1) Coefficients: (Intercept) temp ibh doy -7.6740829 0.3785184 -0.0009858 -0.0066324 > plotmo(lm.fit2, all2=TRUE, clip=FALSE, trace=-1) > > cat("--- print.default of earth object---------\n") --- print.default of earth object--------- > print.default(cars, digits=3) $rss [1] 46.6 $rsq [1] 0.959 $gcv [1] 59.6 $grsq [1] -0.589 $bx (Intercept) h(disp-145) h(145-disp) h(hp-123) h(123-hp) h(qsec-18.52) [1,] 1 15.0 0.0 0 13 0.00 [2,] 1 15.0 0.0 0 13 0.00 [3,] 1 0.0 37.0 0 30 0.09 [4,] 1 113.0 0.0 0 13 0.92 [5,] 1 215.0 0.0 52 0 0.00 [6,] 1 80.0 0.0 0 18 1.70 [7,] 1 215.0 0.0 122 0 0.00 [8,] 1 1.7 0.0 0 61 1.48 [9,] 1 0.0 4.2 0 28 4.38 [10,] 1 22.6 0.0 0 0 0.00 [11,] 1 22.6 0.0 0 0 0.38 [12,] 1 130.8 0.0 57 0 0.00 [13,] 1 130.8 0.0 57 0 0.00 [14,] 1 130.8 0.0 57 0 0.00 [15,] 1 327.0 0.0 82 0 0.00 [16,] 1 315.0 0.0 92 0 0.00 [17,] 1 295.0 0.0 107 0 0.00 [18,] 1 0.0 66.3 0 57 0.95 [19,] 1 0.0 69.3 0 71 0.00 [20,] 1 0.0 73.9 0 58 1.38 [21,] 1 0.0 24.9 0 26 1.49 [22,] 1 173.0 0.0 27 0 0.00 [23,] 1 159.0 0.0 27 0 0.00 [24,] 1 205.0 0.0 122 0 0.00 [25,] 1 255.0 0.0 52 0 0.00 [26,] 1 0.0 66.0 0 57 0.38 [27,] 1 0.0 24.7 0 32 0.00 [28,] 1 0.0 49.9 0 10 0.00 [29,] 1 206.0 0.0 141 0 0.00 [30,] 1 0.0 0.0 52 0 0.00 [31,] 1 156.0 0.0 212 0 0.00 [32,] 1 0.0 24.0 0 14 0.08 h(18.52-qsec) h(drat-3.15) h(3.15-drat) h(gear-4) h(4-gear) h(disp-275.8) [1,] 2.06 0.75 0.00 0 0 0.0 [2,] 1.50 0.75 0.00 0 0 0.0 [3,] 0.00 0.70 0.00 0 0 0.0 [4,] 0.00 0.00 0.07 0 1 0.0 [5,] 1.50 0.00 0.00 0 1 84.2 [6,] 0.00 0.00 0.39 0 1 0.0 [7,] 2.68 0.06 0.00 0 1 84.2 [8,] 0.00 0.54 0.00 0 0 0.0 [9,] 0.00 0.77 0.00 0 0 0.0 [10,] 0.22 0.77 0.00 0 0 0.0 [11,] 0.00 0.77 0.00 0 0 0.0 [12,] 1.12 0.00 0.08 0 1 0.0 [13,] 0.92 0.00 0.08 0 1 0.0 [14,] 0.52 0.00 0.08 0 1 0.0 [15,] 0.54 0.00 0.22 0 1 196.2 [16,] 0.70 0.00 0.15 0 1 184.2 [17,] 1.10 0.08 0.00 0 1 164.2 [18,] 0.00 0.93 0.00 0 0 0.0 [19,] 0.00 1.78 0.00 0 0 0.0 [20,] 0.00 1.07 0.00 0 0 0.0 [21,] 0.00 0.55 0.00 0 1 0.0 [22,] 1.65 0.00 0.39 0 1 42.2 [23,] 1.22 0.00 0.00 0 1 28.2 [24,] 3.11 0.58 0.00 0 1 74.2 [25,] 1.47 0.00 0.07 0 1 124.2 [26,] 0.00 0.93 0.00 0 0 0.0 [27,] 1.82 1.28 0.00 1 0 0.0 [28,] 1.62 0.62 0.00 1 0 0.0 [29,] 4.02 1.07 0.00 1 0 75.2 [30,] 3.02 0.47 0.00 1 0 0.0 [31,] 3.92 0.39 0.00 1 0 25.2 [32,] 0.00 0.96 0.00 0 0 0.0 h(qsec-17.02) vs [1,] 0.00 0 [2,] 0.00 0 [3,] 1.59 1 [4,] 2.42 1 [5,] 0.00 0 [6,] 3.20 1 [7,] 0.00 0 [8,] 2.98 1 [9,] 5.88 1 [10,] 1.28 1 [11,] 1.88 1 [12,] 0.38 0 [13,] 0.58 0 [14,] 0.98 0 [15,] 0.96 0 [16,] 0.80 0 [17,] 0.40 0 [18,] 2.45 1 [19,] 1.50 1 [20,] 2.88 1 [21,] 2.99 1 [22,] 0.00 0 [23,] 0.28 0 [24,] 0.00 0 [25,] 0.03 0 [26,] 1.88 1 [27,] 0.00 0 [28,] 0.00 1 [29,] 0.00 0 [30,] 0.00 0 [31,] 0.00 0 [32,] 1.58 1 $dirs cyl disp hp drat wt qsec vs am gear carb (Intercept) 0 0 0 0 0 0 0 0 0 0 h(disp-145) 0 1 0 0 0 0 0 0 0 0 h(145-disp) 0 -1 0 0 0 0 0 0 0 0 h(hp-123) 0 0 1 0 0 0 0 0 0 0 h(123-hp) 0 0 -1 0 0 0 0 0 0 0 h(qsec-18.52) 0 0 0 0 0 1 0 0 0 0 h(18.52-qsec) 0 0 0 0 0 -1 0 0 0 0 h(drat-3.15) 0 0 0 1 0 0 0 0 0 0 h(3.15-drat) 0 0 0 -1 0 0 0 0 0 0 h(gear-4) 0 0 0 0 0 0 0 0 1 0 h(4-gear) 0 0 0 0 0 0 0 0 -1 0 h(disp-275.8) 0 1 0 0 0 0 0 0 0 0 h(qsec-17.02) 0 0 0 0 0 1 0 0 0 0 vs 0 0 0 0 0 0 2 0 0 0 $cuts cyl disp hp drat wt qsec vs am gear carb (Intercept) 0 0 0 0.00 0 0.0 0 0 0 0 h(disp-145) 0 145 0 0.00 0 0.0 0 0 0 0 h(145-disp) 0 145 0 0.00 0 0.0 0 0 0 0 h(hp-123) 0 0 123 0.00 0 0.0 0 0 0 0 h(123-hp) 0 0 123 0.00 0 0.0 0 0 0 0 h(qsec-18.52) 0 0 0 0.00 0 18.5 0 0 0 0 h(18.52-qsec) 0 0 0 0.00 0 18.5 0 0 0 0 h(drat-3.15) 0 0 0 3.15 0 0.0 0 0 0 0 h(3.15-drat) 0 0 0 3.15 0 0.0 0 0 0 0 h(gear-4) 0 0 0 0.00 0 0.0 0 0 4 0 h(4-gear) 0 0 0 0.00 0 0.0 0 0 4 0 h(disp-275.8) 0 276 0 0.00 0 0.0 0 0 0 0 h(qsec-17.02) 0 0 0 0.00 0 17.0 0 0 0 0 vs 0 0 0 0.00 0 0.0 0 0 0 0 $selected.terms [1] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 $prune.terms [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [1,] 1 0 0 0 0 0 0 0 0 0 0 0 0 [2,] 1 3 0 0 0 0 0 0 0 0 0 0 0 [3,] 1 2 3 0 0 0 0 0 0 0 0 0 0 [4,] 1 2 3 4 0 0 0 0 0 0 0 0 0 [5,] 1 2 3 4 5 0 0 0 0 0 0 0 0 [6,] 1 3 4 6 13 14 0 0 0 0 0 0 0 [7,] 1 3 4 5 6 13 14 0 0 0 0 0 0 [8,] 1 3 4 5 6 9 13 14 0 0 0 0 0 [9,] 1 3 4 5 6 9 12 13 14 0 0 0 0 [10,] 1 3 4 5 6 9 10 12 13 14 0 0 0 [11,] 1 2 3 4 5 6 9 10 12 13 14 0 0 [12,] 1 2 3 4 5 6 9 10 11 12 13 14 0 [13,] 1 2 3 4 5 6 8 9 10 11 12 13 14 [14,] 1 2 3 4 5 6 7 8 9 10 11 12 13 [,14] [1,] 0 [2,] 0 [3,] 0 [4,] 0 [5,] 0 [6,] 0 [7,] 0 [8,] 0 [9,] 0 [10,] 0 [11,] 0 [12,] 0 [13,] 0 [14,] 14 $fitted.values mpg [1,] 20.4 [2,] 20.8 [3,] 24.4 [4,] 20.0 [5,] 18.1 [6,] 17.7 [7,] 14.7 [8,] 24.7 [9,] 23.8 [10,] 18.5 [11,] 18.0 [12,] 16.8 [13,] 16.1 [14,] 14.8 [15,] 10.7 [16,] 11.6 [17,] 13.8 [18,] 30.6 [19,] 30.4 [20,] 31.7 [21,] 21.8 [22,] 16.1 [23,] 18.6 [24,] 13.8 [25,] 17.0 [26,] 30.1 [27,] 26.2 [28,] 31.1 [29,] 16.0 [30,] 18.7 [31,] 14.9 [32,] 21.0 $residuals mpg [1,] 0.5985 [2,] 0.2222 [3,] -1.5897 [4,] 1.4241 [5,] 0.6074 [6,] 0.3738 [7,] -0.3637 [8,] -0.2722 [9,] -1.0463 [10,] 0.7205 [11,] -0.2200 [12,] -0.4350 [13,] 1.1530 [14,] 0.4290 [15,] -0.2985 [16,] -1.1876 [17,] 0.9460 [18,] 1.8033 [19,] 0.0178 [20,] 2.2245 [21,] -0.3183 [22,] -0.6363 [23,] -3.4341 [24,] -0.4700 [25,] 2.2104 [26,] -2.8176 [27,] -0.1547 [28,] -0.6588 [29,] -0.2107 [30,] 0.9699 [31,] 0.0543 [32,] 0.3589 $coefficients mpg (Intercept) 21.2246 h(disp-145) 0.0215 h(145-disp) 0.1101 h(hp-123) -0.0365 h(123-hp) 0.0972 h(qsec-18.52) 4.8944 h(18.52-qsec) -0.6719 h(drat-3.15) -1.3666 h(3.15-drat) -8.2362 h(gear-4) 2.0743 h(4-gear) -2.1513 h(disp-275.8) -0.0321 h(qsec-17.02) -4.1119 vs 3.2318 $rss.per.response [1] 46.6 $rsq.per.response [1] 0.959 $gcv.per.response [1] 59.6 $grsq.per.response [1] -0.589 $rss.per.subset [1] 1126.0 324.6 157.5 147.3 135.4 123.9 87.4 72.8 63.8 59.5 [11] 54.8 51.9 47.4 46.6 $gcv.per.subset [1] 37.50 12.35 6.91 7.54 8.19 8.99 7.75 8.06 9.08 11.26 14.50 20.50 [13] 30.97 59.59 $leverages [1] 0.385 0.343 0.196 0.494 0.209 0.549 0.297 0.792 0.877 0.340 0.322 0.232 [13] 0.241 0.371 0.456 0.323 0.337 0.261 0.572 0.347 0.615 0.550 0.280 0.469 [25] 0.217 0.259 0.640 0.775 0.672 0.615 0.724 0.238 $pmethod [1] "none" $nprune NULL $penalty [1] 2 $nk [1] 21 $thresh [1] 0.001 $termcond [1] 3 $weights NULL $call earth(formula = mpg ~ ., data = mtcars, pmethod = "none", trace = 4) $namesx.org [1] "cyl" "disp" "hp" "drat" "wt" "qsec" "vs" "am" "gear" "carb" $namesx [1] "cyl" "disp" "hp" "drat" "wt" "qsec" "vs" "am" "gear" "carb" $terms mpg ~ cyl + disp + hp + drat + wt + qsec + vs + am + gear + carb attr(,"variables") list(mpg, cyl, disp, hp, drat, wt, qsec, vs, am, gear, carb) attr(,"factors") cyl disp hp drat wt qsec vs am gear carb mpg 0 0 0 0 0 0 0 0 0 0 cyl 1 0 0 0 0 0 0 0 0 0 disp 0 1 0 0 0 0 0 0 0 0 hp 0 0 1 0 0 0 0 0 0 0 drat 0 0 0 1 0 0 0 0 0 0 wt 0 0 0 0 1 0 0 0 0 0 qsec 0 0 0 0 0 1 0 0 0 0 vs 0 0 0 0 0 0 1 0 0 0 am 0 0 0 0 0 0 0 1 0 0 gear 0 0 0 0 0 0 0 0 1 0 carb 0 0 0 0 0 0 0 0 0 1 attr(,"term.labels") [1] "cyl" "disp" "hp" "drat" "wt" "qsec" "vs" "am" "gear" "carb" attr(,"order") [1] 1 1 1 1 1 1 1 1 1 1 attr(,"intercept") [1] 1 attr(,"response") [1] 1 attr(,".Environment") attr(,"predvars") list(mpg, cyl, disp, hp, drat, wt, qsec, vs, am, gear, carb) attr(,"dataClasses") mpg cyl disp hp drat wt qsec vs "numeric" "numeric" "numeric" "numeric" "numeric" "numeric" "numeric" "numeric" am gear carb "numeric" "numeric" "numeric" $xlevels named list() attr(,"class") [1] "earth" > cat("--- done print.default of earth object----\n") --- done print.default of earth object---- > if (PLOT) + plot(cars) > library(mda) > (a <- fda(Species~., data=iris, method=earth, keepxy=TRUE)) Call: fda(formula = Species ~ ., data = iris, method = earth, keepxy = TRUE) Dimension: 2 Percent Between-Group Variance Explained: v1 v2 97.97 100.00 Training Misclassification Error: 0.04 ( N = 150 ) > if (PLOT) + plot(a) > printh(summary(a$fit)) ===summary(a$fit) Call: earth(x=x, y=Theta, weights=weights, keepxy=TRUE) Theta1 Theta2 (Intercept) 1.2060322 -0.7346235 h(Sepal.Length-5.4) -0.1373750 -0.2294201 h(3.3-Sepal.Width) 0.1830045 0.3597030 h(Petal.Length-1.9) -1.7002724 -0.1836390 h(Petal.Length-3.5) 2.0219035 0.4940619 h(Petal.Length-4.5) 0.5710668 1.2862155 h(Petal.Length-5.3) -0.7975568 -1.4507177 h(Petal.Width-1.5) 2.0119980 3.5355314 h(Petal.Width-1.8) -1.9863032 -3.4901478 Selected 9 of 15 terms, and 4 of 4 predictors Termination condition: Reached nk 21 Importance: Petal.Length, Petal.Width, Sepal.Width, Sepal.Length Number of terms at each degree of interaction: 1 8 (additive model) GCV RSS GRSq RSq Theta1 0.0473001 5.577943 0.9533285 0.9628137 Theta2 0.1234732 14.560786 0.8781676 0.9029281 All 0.1707733 20.138729 0.9157480 0.9328709 > expect.err(try(printh(summary(a$fit, none.such1="xxx"))), "unrecognized argument") # summary.earth unrecognized argument "none.such1" ===summary(a$fit, none.such1 = "xxx") Error : summary.earth: unrecognized argument 'none.such1' Got error as expected from try(printh(summary(a$fit, none.such1 = "xxx"))) > printh(summary(a$fit, style="bf", none.such2="xxx")) # Warning: format.earth ignored unrecognized argument "none.such2" ===summary(a$fit, style = "bf", none.such2 = "xxx") Warning: format.earth ignored argument 'none.such2' Call: earth(x=x, y=Theta, weights=weights, keepxy=TRUE) Theta1 = 1.206032 - 0.137375 * bf1 + 0.1830045 * bf2 - 1.700272 * bf3 + 2.021903 * bf4 + 0.5710668 * bf5 - 0.7975568 * bf6 + 2.011998 * bf7 - 1.986303 * bf8 bf1 h(Sepal.Length-5.4) bf2 h(3.3-Sepal.Width) bf3 h(Petal.Length-1.9) bf4 h(Petal.Length-3.5) bf5 h(Petal.Length-4.5) bf6 h(Petal.Length-5.3) bf7 h(Petal.Width-1.5) bf8 h(Petal.Width-1.8) Theta2 = -0.7346235 - 0.2294201 * bf1 + 0.359703 * bf2 - 0.183639 * bf3 + 0.4940619 * bf4 + 1.286216 * bf5 - 1.450718 * bf6 + 3.535531 * bf7 - 3.490148 * bf8 bf1 h(Sepal.Length-5.4) bf2 h(3.3-Sepal.Width) bf3 h(Petal.Length-1.9) bf4 h(Petal.Length-3.5) bf5 h(Petal.Length-4.5) bf6 h(Petal.Length-5.3) bf7 h(Petal.Width-1.5) bf8 h(Petal.Width-1.8) Selected 9 of 15 terms, and 4 of 4 predictors Termination condition: Reached nk 21 Importance: Petal.Length, Petal.Width, Sepal.Width, Sepal.Length Number of terms at each degree of interaction: 1 8 (additive model) GCV RSS GRSq RSq Theta1 0.0473001 5.577943 0.9533285 0.9628137 Theta2 0.1234732 14.560786 0.8781676 0.9029281 All 0.1707733 20.138729 0.9157480 0.9328709 > if (PLOT) { + plot(a$fit, col.residuals=iris$Species, nresponse=1) + plotmo(a$fit, nresponse=1, ylim=c(-1.5,1.5), clip=FALSE, trace=-1) + plotmo(a$fit, nresponse=2, ylim=c(-1.5,1.5), clip=FALSE, trace=-1) + } > a <- update(a, nk=3) # not on man page > printh(a) ===a Call: fda(formula = Species ~ ., data = iris, method = earth, keepxy = TRUE, nk = 3) Dimension: 2 Percent Between-Group Variance Explained: v1 v2 94.38 100.00 Training Misclassification Error: 0.04 ( N = 150 ) > printh(summary(a$fit)) ===summary(a$fit) Call: earth(x=x, y=Theta, weights=weights, keepxy=TRUE, nk=3) Theta1 Theta2 (Intercept) -1.300791 -0.74367728 h(1.2-Petal.Width) 2.601323 0.03896856 h(Petal.Width-1.2) 1.351182 2.22366217 Selected 3 of 3 terms, and 1 of 4 predictors Termination condition: Reached nk 3 Importance: Petal.Width, Sepal.Length-unused, Sepal.Width-unused, ... Number of terms at each degree of interaction: 1 2 (additive model) GCV RSS GRSq RSq Theta1 0.1190355 16.68481 0.8825464 0.8887680 Theta2 0.2430154 34.06267 0.7602140 0.7729156 All 0.3620509 50.74747 0.8213802 0.8308418 > head(etitanic) # pclass and sex are unordered factors pclass survived sex age sibsp parch 1 1st 1 female 29.0000 0 0 2 1st 1 male 0.9167 1 2 3 1st 0 female 2.0000 1 2 4 1st 0 male 30.0000 1 2 5 1st 0 female 25.0000 1 2 6 1st 1 male 48.0000 0 0 > earth(pclass ~ ., data=etitanic, trace=2) x[1046,5] with colnames survived sexmale age sibsp parch y[1046,3] with colnames 1st 2nd 3rd Forward pass: minspan 6 endspan 9 x[1046,5] 40.9 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0910 0.0980 0.09797 3 age 26 2 3 1 4 0.1525 0.1622 0.0642 1 survived 0< 4 1 6 0.1598 0.1758 0.01368 4 sibsp 1 5 6 1 8 0.1670 0.1891 0.0133 5 parch 2 7 8 1 10 0.1664 0.1918 0.002617 3 age 21 9 1 12 0.1656 0.1941 0.002331 3 age 57 10 1 14 0.1630 0.1947 0.0006471 3 age 55.5 11 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 13 terms, 10 terms used (DeltaRSq 0.00065) After forward pass GRSq 0.163 RSq 0.195 Forward pass complete: 13 terms, 10 terms used Using EvalSubsetsUsingXtx (rather than leaps) because this is a multiple response model Prune backward penalty 2 nprune null: selected 8 of 10 terms, and 4 of 5 preds After pruning pass GRSq 0.167 RSq 0.189 Selected 8 of 10 terms, and 4 of 5 predictors Termination condition: RSq changed by less than 0.001 at 10 terms Importance: age, survived, sibsp, parch, sexmale-unused Number of terms at each degree of interaction: 1 7 (additive model) GCV RSS GRSq RSq 1st 0.1483414 150.7467 0.251448718 0.27137124 2nd 0.1885520 191.6094 -0.004971341 0.02177575 3rd 0.1927692 195.8949 0.229032722 0.24955184 All 0.5296626 538.2511 0.166969402 0.18914032 > > cat("--- format.earth.Rd ----------------------\n") --- format.earth.Rd ---------------------- > as.func <- function( # convert expression string to func + object, digits = 8, use.names = TRUE, ...) + eval(parse(text=paste( + "function(x)\n", + "{\n", + "if(is.vector(x))\n", + " x <- matrix(x, nrow = 1, ncol = length(x))\n", + "with(as.data.frame(x),\n", + format(object, digits = digits, use.names = use.names, style = "p", ...), + ")\n", + "}\n", sep = ""))) > a <- earth(Volume ~ ., data = trees) > my.func <- as.func(a, use.names = FALSE) > printh(my.func(c(10,80))) # yields 17.76888 ===my.func(c(10, 80)) [1] 17.60359 > printh(predict(a, c(10,80))) # yields 17.76888, but is slower ===predict(a, c(10, 80)) Volume [1,] 17.60359 > example(format.earth) frmt.r> earth.mod <- earth(Volume ~ ., data = trees) frmt.r> cat(format(earth.mod)) 29.05995 - 3.419806 * h(14.2-Girth) + 6.229514 * h(Girth-14.2) + 0.5813644 * h(Height-75) frmt.r> # yields: frmt.r> # 37.9 frmt.r> # - 3.92 * h(16-Girth) frmt.r> # + 7.4 * h(Girth-16) frmt.r> # + 0.484 * h(Height-75) frmt.r> frmt.r> cat(format(earth.mod, style="pmax")) 29.05995 - 3.419806 * pmax(0, 14.2 - Girth) + 6.229514 * pmax(0, Girth - 14.2) + 0.5813644 * pmax(0, Height - 75) frmt.r> # yields: frmt.r> # 37.9 frmt.r> # - 3.92 * pmax(0, 16 - Girth) frmt.r> # + 7.4 * pmax(0, Girth - 16) frmt.r> # + 0.484 * pmax(0, Height - 75) frmt.r> frmt.r> cat(format(earth.mod, style="C")) 29.05995 - 3.419806 * max(0, 14.2 - x[0]) + 6.229514 * max(0, x[0] - 14.2) + 0.5813644 * max(0, x[1] - 75) frmt.r> # yields (note zero based indexing): frmt.r> # 37.927 frmt.r> # - 3.9187 * max(0, 16 - x[0]) frmt.r> # + 7.4011 * max(0, x[0] - 16) frmt.r> # + 0.48411 * max(0, x[1] - 75) frmt.r> frmt.r> cat(format(earth.mod, style="bf")) 29.05995 - 3.419806 * bf1 + 6.229514 * bf2 + 0.5813644 * bf3 bf1 h(14.2-Girth) bf2 h(Girth-14.2) bf3 h(Height-75) frmt.r> # yields: frmt.r> # 37.9 frmt.r> # - 3.92 * bf1 frmt.r> # + 7.4 * bf2 frmt.r> # + 0.484 * bf3 frmt.r> # frmt.r> # bf1 h(16-Girth) frmt.r> # bf2 h(Girth-16) frmt.r> # bf3 h(Height-75) frmt.r> frmt.r> frmt.r> > a <- earth(Volume ~ ., data = trees) > cat(format(a)) # basic tests of format.earth 29.05995 - 3.419806 * h(14.2-Girth) + 6.229514 * h(Girth-14.2) + 0.5813644 * h(Height-75) > cat(format(a, digits=4)) 29.06 - 3.42 * h(14.2-Girth) + 6.23 * h(Girth-14.2) + 0.5814 * h(Height-75) > # cat(format(a, use.names=FALSE)) > cat(format(a, style="pmax")) 29.05995 - 3.419806 * pmax(0, 14.2 - Girth) + 6.229514 * pmax(0, Girth - 14.2) + 0.5813644 * pmax(0, Height - 75) > cat(format(a, style="max")) 29.05995 - 3.419806 * max(0, 14.2 - Girth) + 6.229514 * max(0, Girth - 14.2) + 0.5813644 * max(0, Height - 75) > cat(format(a, style="bf")) 29.05995 - 3.419806 * bf1 + 6.229514 * bf2 + 0.5813644 * bf3 bf1 h(14.2-Girth) bf2 h(Girth-14.2) bf3 h(Height-75) > cat(format(a, use.names=FALSE, style="p")) 29.05995 - 3.419806 * pmax(0, 14.2 - x[,1]) + 6.229514 * pmax(0, x[,1] - 14.2) + 0.5813644 * pmax(0, x[,2] - 75) > cat(format(a, use.names=FALSE, style="m")) 29.05995 - 3.419806 * max(0, 14.2 - x[,1]) + 6.229514 * max(0, x[,1] - 14.2) + 0.5813644 * max(0, x[,2] - 75) > a <- earth(Volume ~ Girth*Height, data = trees, pmethod="none") > cat(format(a)) 25.24205 - 0.8905681 * h(13.3-Girth) + 2.590203 * h(Girth-13.3) - 0.02669905 * h(972.7-Girth:Height) + 0.03883467 * h(Girth:Height-972.7) > cat(format(a, colon.char="*")) 25.24205 - 0.8905681 * h(13.3-Girth) + 2.590203 * h(Girth-13.3) - 0.02669905 * h(972.7-Girth*Height) + 0.03883467 * h(Girth*Height-972.7) > a <- lm(Volume ~ ., data = trees) > cat(format(a)) # basic tests of format.lm -57.98766 + 4.708161 * Girth + 0.3392512 * Height > cat(format(a, digits=4)) -57.99 + 4.708 * Girth + 0.3393 * Height > cat(format(a, use.names=FALSE)) -57.98766 + 4.708161 * x[,1] + 0.3392512 * x[,2] > cat(format(a, style="p")) -57.98766 + 4.708161 * Girth + 0.3392512 * Height > cat(format(a, use.names=FALSE, style="p")) -57.98766 + 4.708161 * x[,1] + 0.3392512 * x[,2] > a <- lm(Volume ~ Girth*Height, data = trees) > cat(format(a)) 69.39632 - 5.855848 * Girth - 1.297083 * Height + 0.1346544 * Girth:Height > cat(format(a, colon.char="*")) 69.39632 - 5.855848 * Girth - 1.297083 * Height + 0.1346544 * Girth*Height > cat("--- mars.to.earth.Rd ----------------------\n") --- mars.to.earth.Rd ---------------------- > example(mars.to.earth) mrs.t.> if(require(mda)) { mrs.t.+ mars.mod <- mars(trees[,-3], trees[,3]) mrs.t.+ earth.mod <- mars.to.earth(mars.mod) mrs.t.+ # the standard earth functions can now be used mrs.t.+ # note the reconstructed call in the summary mrs.t.+ summary(earth.mod, digits = 2) mrs.t.+ } Converted mars(x=trees[,-3], y=trees[,3]) to earth(x=trees[,-3], y=trees[,3]) Call: earth(x=trees[,-3], y=trees[,3]) coefficients (Intercept) 26.3 h(13.8-Girth) -3.2 h(Girth-13.8) 6.1 h(11.4-Girth) 0.5 Selected 4 of 8 terms, and 2 of 2 predictors Termination condition: Unknown Importance: object has no prune.terms, call update() on the model to fix that Number of terms at each degree of interaction: 1 3 (additive model) GCV 10 RSS 190 GRSq 0.96 RSq 0.98 > library(mda) > a <- mars(trees[,-3], trees[,3]) > a <- mars.to.earth(a) Converted mars(x=trees[,-3], y=trees[,3]) to earth(x=trees[,-3], y=trees[,3]) > print(summary(a, digits = 2)) Call: earth(x=trees[,-3], y=trees[,3]) coefficients (Intercept) 26.3 h(13.8-Girth) -3.2 h(Girth-13.8) 6.1 h(11.4-Girth) 0.5 Selected 4 of 8 terms, and 2 of 2 predictors Termination condition: Unknown Importance: object has no prune.terms, call update() on the model to fix that Number of terms at each degree of interaction: 1 3 (additive model) GCV 10 RSS 190 GRSq 0.96 RSq 0.98 > printh(summary(a, digits=2)) ===summary(a, digits = 2) Call: earth(x=trees[,-3], y=trees[,3]) coefficients (Intercept) 26.3 h(13.8-Girth) -3.2 h(Girth-13.8) 6.1 h(11.4-Girth) 0.5 Selected 4 of 8 terms, and 2 of 2 predictors Termination condition: Unknown Importance: object has no prune.terms, call update() on the model to fix that Number of terms at each degree of interaction: 1 3 (additive model) GCV 10 RSS 190 GRSq 0.96 RSq 0.98 > printh(summary(a, digits=2, style="bf")) ===summary(a, digits = 2, style = "bf") Call: earth(x=trees[,-3], y=trees[,3]) y = 26 - 3.2 * bf1 + 6.1 * bf2 + 0.5 * bf3 bf1 h(13.8-Girth) bf2 h(Girth-13.8) bf3 h(11.4-Girth) Selected 4 of 8 terms, and 2 of 2 predictors Termination condition: Unknown Importance: object has no prune.terms, call update() on the model to fix that Number of terms at each degree of interaction: 1 3 (additive model) GCV 10 RSS 190 GRSq 0.96 RSq 0.98 > cat("--- plot.earth.models.Rd ----------------------\n") --- plot.earth.models.Rd ---------------------- > if (PLOT) + example(plot.earth.models) plt.r.> data(ozone1) plt.r.> a1 <- earth(O3 ~ ., data = ozone1, degree = 2) plt.r.> a2 <- earth(O3 ~ .-wind, data = ozone1, degree = 2) plt.r.> a3 <- earth(O3 ~ .-humidity, data = ozone1, degree = 2) plt.r.> plot.earth.models(list(a1,a2,a3), ylim=c(.65,.85)) > cat("--- plot.earth.Rd ----------------------\n") --- plot.earth.Rd ---------------------- > if (PLOT) { + data(etitanic) + a <- earth(survived ~ ., data=etitanic, glm=list(family=binomial)) + par(mfrow=c(2,2)) + plot(a$glm.list[[1]], caption="a$glm.list[[1]]") + example(plot.earth) + } plt.rt> data(ozone1) plt.rt> earth.mod <- earth(O3 ~ ., data = ozone1, degree = 2) plt.rt> plot(earth.mod) > cat("--- predict.earth.Rd ----------------------\n") --- predict.earth.Rd ---------------------- > example(predict.earth) prdct.> data(trees) prdct.> earth.mod <- earth(Volume ~ ., data = trees) prdct.> predict(earth.mod) # same as earth.mod$fitted.values Volume [1,] 8.883097 [2,] 9.909039 [3,] 10.593000 [4,] 16.406671 [5,] 20.578818 [6,] 22.083528 [7,] 18.116574 [8,] 18.116574 [9,] 21.365376 [10,] 18.800535 [11,] 21.467973 [12,] 20.065861 [13,] 20.065861 [14,] 20.510438 [15,] 21.536380 [16,] 24.614206 [17,] 30.427849 [18,] 32.377136 [19,] 27.350050 [20,] 27.692031 [21,] 30.120085 [22,] 31.966775 [23,] 30.928808 [24,] 40.273079 [25,] 43.304662 [26,] 51.859634 [27,] 53.686902 [28,] 55.015978 [29,] 55.638930 [30,] 55.638930 [31,] 75.905218 prdct.> predict(earth.mod, data.frame(Girth=10, Height=80)) # yields 17.6 Volume [1,] 17.60359 prdct.> predict(earth.mod, c(10,80)) # equivalent Volume [1,] 17.60359 > cat("--- residuals.earth.Rd --------------------\n") --- residuals.earth.Rd -------------------- > example(residuals.earth) rsdls.> data(etitanic) rsdls.> earth.mod <- earth(pclass ~ ., data=etitanic, glm=list(family=binomial)) rsdls.> head(resid(earth.mod, warn=FALSE)) # earth residuals, a column for each response 1st 2nd 3rd 1 0.6459266 -0.2575797 -0.3883469 2 0.7904775 -0.3372244 -0.4532531 3 1.0316575 -0.3335720 -0.6980855 4 0.7171249 -0.3904317 -0.3266933 5 0.7873520 -0.3970218 -0.3903302 6 0.3628026 -0.2131729 -0.1496297 rsdls.> head(resid(earth.mod, type="response")) # GLM response resids, a column for each response 1st 2nd 3rd 1 0.6573382 -0.2572600 -0.3595878 2 0.8654089 -0.3490739 -0.4071918 3 0.9669576 -0.3441215 -0.7048640 4 0.7394748 -0.4155799 -0.2598236 5 0.8095001 -0.4246067 -0.3324777 6 0.2959240 -0.2130374 -0.1283785 > cat("--- update.earth.Rd ----------------------\n") --- update.earth.Rd ---------------------- > example(update.earth) updt.r> data(ozone1) updt.r> (earth.mod <- earth(O3 ~ ., data = ozone1, degree = 2)) Selected 12 of 21 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, ibh, dpg, vis, wind, vh Number of terms at each degree of interaction: 1 5 6 GCV 13.40805 RSS 3693.401 GRSq 0.7917216 RSq 0.825085 updt.r> update(earth.mod, formula = O3 ~ . - temp) # requires forward pass and pruning Selected 15 of 21 terms, and 8 of 8 predictors Termination condition: Reached nk 21 Importance: ibt, humidity, doy, vh, dpg, vis, ibh, wind Number of terms at each degree of interaction: 1 9 5 GCV 13.01626 RSS 3409.313 GRSq 0.7978077 RSq 0.8385391 updt.r> update(earth.mod, nprune = 8) # requires only pruning Selected 8 of 21 terms, and 6 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibh-unused, ibt, doy, dpg, vis, vh-unused, ... Number of terms at each degree of interaction: 1 5 2 GCV 14.70227 RSS 4323.013 GRSq 0.7716175 RSq 0.7952674 updt.r> update(earth.mod, penalty=1, ponly=TRUE) # pruning pass only with a new penalty Selected 12 of 21 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, ibh, dpg, vis, wind, vh Number of terms at each degree of interaction: 1 5 6 GCV 12.48074 RSS 3693.401 GRSq 0.8061264 RSq 0.825085 > > cat("--- evimp.Rd -----------------------------\n") --- evimp.Rd ----------------------------- > > par(mfrow=c(2,2)) > cat('before calling evimp par("mar", "cex"):\n') before calling evimp par("mar", "cex"): > print(par("mar", "cex")) $mar [1] 5.1 4.1 4.1 2.1 $cex [1] 0.83 > > example(evimp) evimp> data(ozone1) evimp> earth.mod <- earth(O3 ~ ., data=ozone1, degree=2) evimp> ev <- evimp(earth.mod, trim=FALSE) evimp> plot(ev) evimp> print(ev) nsubsets gcv rss temp 11 100.0 100.0 humidity 9 35.7 38.9 ibt 7 31.6 34.0 doy 7 31.6 34.0 ibh 6 33.4> 36.0> dpg 6 27.5 29.8 vis 5 21.4 24.1 wind 2 10.3 12.6 vh 1 5.3 7.7 > > cat("--- plot.evimp.Rd ------------------------\n") --- plot.evimp.Rd ------------------------ > > example(plot.evimp) plt.vm> data(ozone1) plt.vm> earth.mod <- earth(O3 ~ ., data=ozone1, degree=2) plt.vm> ev <- evimp(earth.mod) plt.vm> plot(ev) plt.vm> print(ev) nsubsets gcv rss temp 11 100.0 100.0 humidity 9 35.7 38.9 ibt 7 31.6 34.0 doy 7 31.6 34.0 ibh 6 33.4> 36.0> dpg 6 27.5 29.8 vis 5 21.4 24.1 wind 2 10.3 12.6 vh 1 5.3 7.7 > > rownames(ev)[4] <- "a_long_variable_name" > > plot(ev, main="plot.evimp with various options", + cex.var = .8, + type.nsubsets = "p", + col.nsubsets = "red", + lty.nsubsets = 2, # ignored because type.nsubsets="p" + type.gcv = "l", + col.gcv = "green", + lty.gcv = 3, + type.rss = "b", + col.rss = "blue", + lty.rss = 4, + cex.legend = .8, + x.legend = "topright", + rh.col = "pink") > > a <- earth(Volume ~ Girth, data = trees) > plot(evimp(a), main="plot.evimp with single var in model") > > cat('after calling evimp par("mar", "cex"):\n') after calling evimp par("mar", "cex"): > print(par("mar", "cex")) $mar [1] 5.1 4.1 4.1 2.1 $cex [1] 0.83 > par(mfrow=c(1,1)) > > cat("--- test predict.earth -------------------\n") --- test predict.earth ------------------- > > a <- earth(Volume ~ ., data = trees) > cat("1a predict(a, c(10,80))\n") 1a predict(a, c(10,80)) > printh(predict(a, c(10,80), trace=1)) ===predict(a, c(10, 80), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[1,2]: Girth Height 1 10 80 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,2]: Girth Height 1 10 80 predict.earth with newdata: bx[1,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 predict.earth: returning earth predictions Volume [1,] 17.60359 > cat("1b predict(a, c(10,10,80,80))\n") 1b predict(a, c(10,10,80,80)) > printh(predict(a, c(10,10,80,80), trace=1)) ===predict(a, c(10, 10, 80, 80), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 10 80 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,2]: Girth Height 1 10 80 2 10 80 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 4.2 5 predict.earth: returning earth predictions Volume [1,] 17.60359 [2,] 17.60359 > cat("1c predict(a, c(10,11,80,81))\n") 1c predict(a, c(10,11,80,81)) > printh(predict(a, c(10,11,80,81), trace=1)) ===predict(a, c(10, 11, 80, 81), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 11 81 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,2]: Girth Height 1 10 80 2 11 81 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 3.2 6 predict.earth: returning earth predictions Volume [1,] 17.60359 [2,] 21.60476 > cat("2 predict(a)\n") 2 predict(a) > printh(head(predict(a, trace=1))) ===head(predict(a, trace = 1)) predict.earth: returning earth fitted.values Volume [1,] 8.883097 [2,] 9.909039 [3,] 10.593000 [4,] 16.406671 [5,] 20.578818 [6,] 22.083528 > cat("3a predict(a, matrix(c(10,12), nrow=1, ncol=2))\n") 3a predict(a, matrix(c(10,12), nrow=1, ncol=2)) > printh(predict(a, matrix(c(10,12), nrow=1, ncol=2), trace=1)) ===predict(a, matrix(c(10, 12), nrow = 1, ncol = 2), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[1,2]: Girth Height 1 10 12 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,2]: Girth Height 1 10 12 predict.earth with newdata: bx[1,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 0 predict.earth: returning earth predictions Volume [1,] 14.69677 > cat("3b predict(a, matrix(c(10,12), nrow=2, ncol=2, byrow=TRUE)\n") 3b predict(a, matrix(c(10,12), nrow=2, ncol=2, byrow=TRUE) > printh(predict(a, matrix(c(10,12), nrow=2, ncol=2, byrow=TRUE), trace=1)) ===predict(a, matrix(c(10, 12), nrow = 2, ncol = 2, byrow = TRUE), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 12 2 10 12 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,2]: Girth Height 1 10 12 2 10 12 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 0 2 1 0 4.2 0 predict.earth: returning earth predictions Volume [1,] 14.69677 [2,] 14.69677 > cat("3c predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2))\n") 3c predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2)) > printh(predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2), trace=1)) ===predict(a, matrix(c(10, 12, 80, 90), nrow = 2, ncol = 2), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions Volume [1,] 17.60359 [2,] 30.25685 > xpredict <- matrix(c(10,12,80,90), nrow=2, ncol=2) > colnames(xpredict) <- c("Girth", "Height") > cat("4 predict(a, xpredict with colnames)\n") 4 predict(a, xpredict with colnames) > printh(predict(a, xpredict, trace=1)) ===predict(a, xpredict, trace = 1) get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions Volume [1,] 17.60359 [2,] 30.25685 > cat("5 predict(a, as.data.frame(xpredict with colnames))\n") 5 predict(a, as.data.frame(xpredict with colnames)) > printh(predict(a, as.data.frame(xpredict), trace=1)) ===predict(a, as.data.frame(xpredict), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions Volume [1,] 17.60359 [2,] 30.25685 > # reverse dataframe columns (and their names), predict should deal with it correctly > xpredict <- as.data.frame(cbind(xpredict[,2], xpredict[,1])) > colnames(xpredict) <- c("Height", "Girth") > cat("6a predict(a, xpredict with reversed columns and colnames)\n") 6a predict(a, xpredict with reversed columns and colnames) > printh(predict(a, xpredict, trace=1)) ===predict(a, xpredict, trace = 1) get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: Height Girth New columns: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions Volume [1,] 17.60359 [2,] 30.25685 > xpredict2 <- cbind(xpredict[,1], xpredict[,2]) # nameless matrix > cat("6b predict(a, xpredict2)\n") 6b predict(a, xpredict2) > printh(predict(a, xpredict2, trace=1)) ===predict(a, xpredict2, trace = 1) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 80 10 2 90 12 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,2]: Girth Height 1 80 10 2 90 12 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 65.8 0 0 2 1 75.8 0 0 predict.earth: returning earth predictions Volume [1,] 438.9620 [2,] 501.2571 > > # repeat but with x,y (not formula) call to earth > > x1 <- cbind(trees$Girth, trees$Height) > colnames(x1) <- c("Girth", "Height") > a <- earth(x1, trees$Volume) > xpredict <- matrix(c(10,12,80,90), nrow=2, ncol=2) > cat("7a predict(a)\n") 7a predict(a) > printh(head(predict(a, trace=1))) ===head(predict(a, trace = 1)) predict.earth: returning earth fitted.values trees$Volume [1,] 8.883097 [2,] 9.909039 [3,] 10.593000 [4,] 16.406671 [5,] 20.578818 [6,] 22.083528 > cat("7n predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2)\n") 7n predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2) > printh(predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2), trace=1)) ===predict(a, matrix(c(10, 12, 80, 90), nrow = 2, ncol = 2), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions trees$Volume [1,] 17.60359 [2,] 30.25685 > colnames(xpredict) <- c("Girth", "Height") > cat("8 predict(a, xpredict with colnames)\n") 8 predict(a, xpredict with colnames) > printh(predict(a, xpredict, trace=1)) ===predict(a, xpredict, trace = 1) get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions trees$Volume [1,] 17.60359 [2,] 30.25685 > cat("9 predict(a, as.data.frame(xpredict with colnames))\n") 9 predict(a, as.data.frame(xpredict with colnames)) > printh(predict(a, as.data.frame(xpredict), trace=1)) ===predict(a, as.data.frame(xpredict), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions trees$Volume [1,] 17.60359 [2,] 30.25685 > cat("--Expect warning from predict.earth: the variable names in 'data' do not match those in 'object'\n") --Expect warning from predict.earth: the variable names in 'data' do not match those in 'object' > xpredict2 <- cbind(xpredict[,1], xpredict[,2]) > colnames(xpredict2) <- c("none.such", "joe") > cat("10a predict(a, xpredict2)\n") 10a predict(a, xpredict2) > printh(predict(a, xpredict2, trace=1), expect.warning=TRUE) ===predict(a, xpredict2, trace = 1) expect warning -->get.earth.x from model.matrix.earth from predict.earth: unexpected x column names, renaming columns Old names: none.such joe New names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions trees$Volume [1,] 17.60359 [2,] 30.25685 > cat("--Expect warning from predict.earth: the variable names in 'data' do not match those in 'object'\n") --Expect warning from predict.earth: the variable names in 'data' do not match those in 'object' > xpredict2 <- cbind(xpredict[,1], xpredict[,2]) > colnames(xpredict2) <- c("Height", "Girth") # reversed > cat("10b predict(a, xpredict2)\n") 10b predict(a, xpredict2) > printh(predict(a, xpredict2, trace=1), expect.warning=TRUE) ===predict(a, xpredict2, trace = 1) expect warning -->get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: Height Girth New columns: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 80 10 2 90 12 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 65.8 0 0 2 1 75.8 0 0 predict.earth: returning earth predictions trees$Volume [1,] 438.9620 [2,] 501.2571 > > cat("--- test predict.earth with multiple response models-------------------\n") --- test predict.earth with multiple response models------------------- > > a <- earth(cbind(Volume, Volume + 100) ~ ., data = trees) > cat("1a predict(a, c(10,80))\n") 1a predict(a, c(10,80)) > printh(predict(a, c(10,80), trace=1)) ===predict(a, c(10, 80), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[1,2]: Girth Height 1 10 80 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,2]: Girth Height 1 10 80 predict.earth with newdata: bx[1,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 predict.earth: returning earth predictions Volume cbind(Volume,Volume+100)2 [1,] 17.60359 117.6036 > predict.a1a <- predict(a, c(10,80)) > check.almost.equal(predict.a1a[1,1], 17.6035895926138, msg="predict.a1a[1,1]") > check.almost.equal(predict.a1a[1,2], 117.603589592614, msg="predict.a1a[1,2]") > cat("1b predict(a, c(10,10,80,80))\n") 1b predict(a, c(10,10,80,80)) > printh(predict(a, c(10,10,80,80), trace=1)) ===predict(a, c(10, 10, 80, 80), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 10 80 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,2]: Girth Height 1 10 80 2 10 80 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 4.2 5 predict.earth: returning earth predictions Volume cbind(Volume,Volume+100)2 [1,] 17.60359 117.6036 [2,] 17.60359 117.6036 > cat("1c predict(a, c(10,11,80,81))\n") 1c predict(a, c(10,11,80,81)) > printh(predict(a, c(10,11,80,81), trace=1)) ===predict(a, c(10, 11, 80, 81), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 11 81 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,2]: Girth Height 1 10 80 2 11 81 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 3.2 6 predict.earth: returning earth predictions Volume cbind(Volume,Volume+100)2 [1,] 17.60359 117.6036 [2,] 21.60476 121.6048 > cat("1d predict(a, data.frame=c(Girth=10,Height=80))\n") 1d predict(a, data.frame=c(Girth=10,Height=80)) > printh(predict(a, newdata=data.frame(Girth=10,Height=80))) ===predict(a, newdata = data.frame(Girth = 10, Height = 80)) Volume cbind(Volume,Volume+100)2 [1,] 17.60359 117.6036 > predict.a1d <- predict(a, newdata=data.frame(Girth=10,Height=80)) > check.almost.equal(predict.a1d[1,1], 17.6035895926138, msg="predict.a1d[1,1]") > check.almost.equal(predict.a1d[1,2], 117.603589592614, msg="predict.a1d[1,2]") > expect.err(try(predict(a, newdata=10)), "get.earth.x from model.matrix.earth from predict.earth:\n could not convert vector x to matrix because length(x) 1\n is not a multiple of the number 2 of predictors") Error : get.earth.x from model.matrix.earth from predict.earth: could not convert vector x to matrix because length(x) 1 is not a multiple of the number 2 of predictors Expected predictors: Girth Height Got error as expected from try(predict(a, newdata = 10)) > cat("2 predict(a)\n") 2 predict(a) > printh(head(predict(a, trace=1))) ===head(predict(a, trace = 1)) predict.earth: returning earth fitted.values Volume cbind(Volume,Volume+100)2 [1,] 8.883097 108.8831 [2,] 9.909039 109.9090 [3,] 10.593000 110.5930 [4,] 16.406671 116.4067 [5,] 20.578818 120.5788 [6,] 22.083528 122.0835 > cat("3a predict(a, matrix(c(10,12), nrow=1, ncol=2))\n") 3a predict(a, matrix(c(10,12), nrow=1, ncol=2)) > printh(predict(a, matrix(c(10,12), nrow=1, ncol=2), trace=1)) ===predict(a, matrix(c(10, 12), nrow = 1, ncol = 2), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[1,2]: Girth Height 1 10 12 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,2]: Girth Height 1 10 12 predict.earth with newdata: bx[1,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 0 predict.earth: returning earth predictions Volume cbind(Volume,Volume+100)2 [1,] 14.69677 114.6968 > cat("3b predict(a, matrix(c(10,12), nrow=2, ncol=2, byrow=TRUE)\n") 3b predict(a, matrix(c(10,12), nrow=2, ncol=2, byrow=TRUE) > printh(predict(a, matrix(c(10,12), nrow=2, ncol=2, byrow=TRUE), trace=1)) ===predict(a, matrix(c(10, 12), nrow = 2, ncol = 2, byrow = TRUE), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 12 2 10 12 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,2]: Girth Height 1 10 12 2 10 12 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 0 2 1 0 4.2 0 predict.earth: returning earth predictions Volume cbind(Volume,Volume+100)2 [1,] 14.69677 114.6968 [2,] 14.69677 114.6968 > cat("3c predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2))\n") 3c predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2)) > printh(predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2), trace=1)) ===predict(a, matrix(c(10, 12, 80, 90), nrow = 2, ncol = 2), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions Volume cbind(Volume,Volume+100)2 [1,] 17.60359 117.6036 [2,] 30.25685 130.2568 > xpredict <- matrix(c(10,12,80,90), nrow=2, ncol=2) > colnames(xpredict) <- c("Girth", "Height") > cat("4 predict(a, xpredict with colnames)\n") 4 predict(a, xpredict with colnames) > printh(predict(a, xpredict, trace=1)) ===predict(a, xpredict, trace = 1) get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions Volume cbind(Volume,Volume+100)2 [1,] 17.60359 117.6036 [2,] 30.25685 130.2568 > cat("5 predict(a, as.data.frame(xpredict with colnames))\n") 5 predict(a, as.data.frame(xpredict with colnames)) > printh(predict(a, as.data.frame(xpredict), trace=1)) ===predict(a, as.data.frame(xpredict), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions Volume cbind(Volume,Volume+100)2 [1,] 17.60359 117.6036 [2,] 30.25685 130.2568 > # reverse dataframe columns (and their names), predict should deal with it correctly > xpredict <- as.data.frame(cbind(xpredict[,2], xpredict[,1])) > colnames(xpredict) <- c("Height", "Girth") > cat("6 predict(a, xpredict with reversed columns and colnames)\n") 6 predict(a, xpredict with reversed columns and colnames) > printh(predict(a, xpredict, trace=1)) ===predict(a, xpredict, trace = 1) get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: Height Girth New columns: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions Volume cbind(Volume,Volume+100)2 [1,] 17.60359 117.6036 [2,] 30.25685 130.2568 > expect.err(try(predict(a, interval="pin")), "no prediction intervals because the earth model was not built with varmod.method") Error : no prediction intervals because the earth model was not built with varmod.method Got error as expected from try(predict(a, interval = "pin")) > expect.err(try(earth(cbind(Volume, Volume + 100) ~ ., data = trees, nfold=3, ncross=3, varmod.method="lm")), "variance models are not supported for multiple response models") Error : variance models are not supported for multiple response models Got error as expected from try(earth(cbind(Volume, Volume + 100) ~ ., data = trees, nfold = 3, ncross = 3, varmod.method = "lm")) > > # repeat but with x,y (not formula) call to earth > > x1 <- cbind(trees$Girth, trees$Height) > colnames(x1) <- c("Girth", "Height") > a <- earth(x1, cbind(trees$Volume, trees$Volume+100)) > xpredict <- matrix(c(10,12,80,90), nrow=2, ncol=2) > cat("7a predict(a)\n") 7a predict(a) > printh(head(predict(a, trace=1))) ===head(predict(a, trace = 1)) predict.earth: returning earth fitted.values y1 y2 [1,] 8.883097 108.8831 [2,] 9.909039 109.9090 [3,] 10.593000 110.5930 [4,] 16.406671 116.4067 [5,] 20.578818 120.5788 [6,] 22.083528 122.0835 > cat("7b predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2)\n") 7b predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2) > printh(predict(a, matrix(c(10,12,80,90), nrow=2, ncol=2), trace=1)) ===predict(a, matrix(c(10, 12, 80, 90), nrow = 2, ncol = 2), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x has no column names, adding column names: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions y1 y2 [1,] 17.60359 117.6036 [2,] 30.25685 130.2568 > colnames(xpredict) <- c("Girth", "Height") > cat("8 predict(a, xpredict with colnames)\n") 8 predict(a, xpredict with colnames) > printh(predict(a, xpredict, trace=1)) ===predict(a, xpredict, trace = 1) get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions y1 y2 [1,] 17.60359 117.6036 [2,] 30.25685 130.2568 > cat("9 predict(a, as.data.frame(xpredict with colnames))\n") 9 predict(a, as.data.frame(xpredict with colnames)) > printh(predict(a, as.data.frame(xpredict), trace=1)) ===predict(a, as.data.frame(xpredict), trace = 1) get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions y1 y2 [1,] 17.60359 117.6036 [2,] 30.25685 130.2568 > cat("--Expect warning from predict.earth: the variable names in 'data' do not match those in 'object'\n") --Expect warning from predict.earth: the variable names in 'data' do not match those in 'object' > xpredict <- as.data.frame(cbind(xpredict[,2], xpredict[,1])) > colnames(xpredict) <- c("Height", "Girth") > cat("10 predict(a, xpredict)\n") 10 predict(a, xpredict) > printh(predict(a, xpredict, trace=1), expect.warning=TRUE) ===predict(a, xpredict, trace = 1) expect warning -->get.earth.x from model.matrix.earth from predict.earth: x columns are in the wrong order, correcting the column order Old columns: Height Girth New columns: Girth Height get.earth.x from model.matrix.earth from predict.earth: x[2,2]: Girth Height 1 10 80 2 12 90 predict.earth with newdata: bx[2,4]: (Intercept) h(Girth-14.2) h(14.2-Girth) h(Height-75) 1 1 0 4.2 5 2 1 0 2.2 15 predict.earth: returning earth predictions y1 y2 [1,] 17.60359 117.6036 [2,] 30.25685 130.2568 > > cat("--- earth.predict with NAs, with formula interface ---\n") --- earth.predict with NAs, with formula interface --- > > predict.with.message <- function(message, earth.model, newdata) { + cat("predict.earth ", message, ":\n", sep="") + print(predict(earth.model, newdata=newdata, trace=1)) + cat("\n") + } > > iris.earth <- earth(Petal.Width ~ Sepal.Length + Sepal.Width + Petal.Length, data=iris) > x <- iris[1,] > predict.with.message("formula interface and vector", iris.earth, newdata=x) predict.earth formula interface and vector: get.earth.x from model.matrix.earth from predict.earth: x[1,5]: Sepal.Length Sepal.Width Petal.Length Petal.Width Species 1 5.1 3.5 1.4 0.2 setosa Species is a factor with levels: setosa versicolor virginica get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,3]: Sepal.Length Sepal.Width Petal.Length 1 5.1 3.5 1.4 predict.earth with newdata: bx[1,9]: (Intercept) h(6-Petal.Length) h(3.5-Sepal.Width) h(Sepal.Length-6.9) 1 1 4.6 0 0 h(6.9-Sepal.Length) h(Sepal.Length-7.2) h(Petal.Length-5.3) 1 1.8 0 0 h(Petal.Length-4.7) h(Petal.Length-5.5) 1 0 0 predict.earth: returning earth predictions Petal.Width [1,] 0.2562505 > x$Sepal.Width <- as.numeric(NA) > predict.with.message("formula interface and vector with NA", iris.earth, newdata=x) predict.earth formula interface and vector with NA: get.earth.x from model.matrix.earth from predict.earth: x[1,5]: Sepal.Length Sepal.Width Petal.Length Petal.Width Species 1 5.1 NA 1.4 0.2 setosa Species is a factor with levels: setosa versicolor virginica get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,3]: Sepal.Length Sepal.Width Petal.Length 1 5.1 NA 1.4 predict.earth with newdata: bx[1,9]: (Intercept) h(6-Petal.Length) h(3.5-Sepal.Width) h(Sepal.Length-6.9) 1 1 4.6 NA 0 h(6.9-Sepal.Length) h(Sepal.Length-7.2) h(Petal.Length-5.3) 1 1.8 0 0 h(Petal.Length-4.7) h(Petal.Length-5.5) 1 0 0 predict.earth: returning earth predictions Petal.Width [1,] NA > x <- iris[1,] > x$Petal.Width <- as.numeric(NA) # Petal.Width is unused in the earth model > predict.with.message("formula interface and vector with NA in unused variable", iris.earth, newdata=x) predict.earth formula interface and vector with NA in unused variable: get.earth.x from model.matrix.earth from predict.earth: x[1,5]: Sepal.Length Sepal.Width Petal.Length Petal.Width Species 1 5.1 3.5 1.4 NA setosa Species is a factor with levels: setosa versicolor virginica get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[1,3]: Sepal.Length Sepal.Width Petal.Length 1 5.1 3.5 1.4 predict.earth with newdata: bx[1,9]: (Intercept) h(6-Petal.Length) h(3.5-Sepal.Width) h(Sepal.Length-6.9) 1 1 4.6 0 0 h(6.9-Sepal.Length) h(Sepal.Length-7.2) h(Petal.Length-5.3) 1 1.8 0 0 h(Petal.Length-4.7) h(Petal.Length-5.5) 1 0 0 predict.earth: returning earth predictions Petal.Width [1,] 0.2562505 > > x <- iris[1:3,] > predict.with.message("formula interface and matrix", iris.earth, newdata=x) predict.earth formula interface and matrix: get.earth.x from model.matrix.earth from predict.earth: x[3,5]: Sepal.Length Sepal.Width Petal.Length Petal.Width Species 1 5.1 3.5 1.4 0.2 setosa 2 4.9 3.0 1.4 0.2 setosa 3 4.7 3.2 1.3 0.2 setosa Species is a factor with levels: setosa versicolor virginica get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[3,3]: Sepal.Length Sepal.Width Petal.Length 1 5.1 3.5 1.4 2 4.9 3.0 1.4 3 4.7 3.2 1.3 predict.earth with newdata: bx[3,9]: (Intercept) h(6-Petal.Length) h(3.5-Sepal.Width) h(Sepal.Length-6.9) 1 1 4.6 0.0 0 2 1 4.6 0.5 0 3 1 4.7 0.3 0 h(6.9-Sepal.Length) h(Sepal.Length-7.2) h(Petal.Length-5.3) 1 1.8 0 0 2 2.0 0 0 3 2.2 0 0 h(Petal.Length-4.7) h(Petal.Length-5.5) 1 0 0 2 0 0 3 0 0 predict.earth: returning earth predictions Petal.Width [1,] 0.2562505 [2,] 0.1733787 [3,] 0.1880121 > x[2,]$Sepal.Width <- as.numeric(NA) > predict.with.message("formula interface and matrix with NA", iris.earth, newdata=x) predict.earth formula interface and matrix with NA: get.earth.x from model.matrix.earth from predict.earth: x[3,5]: Sepal.Length Sepal.Width Petal.Length Petal.Width Species 1 5.1 3.5 1.4 0.2 setosa 2 4.9 NA 1.4 0.2 setosa 3 4.7 3.2 1.3 0.2 setosa Species is a factor with levels: setosa versicolor virginica get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[3,3]: Sepal.Length Sepal.Width Petal.Length 1 5.1 3.5 1.4 2 4.9 NA 1.4 3 4.7 3.2 1.3 predict.earth with newdata: bx[3,9]: (Intercept) h(6-Petal.Length) h(3.5-Sepal.Width) h(Sepal.Length-6.9) 1 1 4.6 0.0 0 2 1 4.6 NA 0 3 1 4.7 0.3 0 h(6.9-Sepal.Length) h(Sepal.Length-7.2) h(Petal.Length-5.3) 1 1.8 0 0 2 2.0 0 0 3 2.2 0 0 h(Petal.Length-4.7) h(Petal.Length-5.5) 1 0 0 2 0 0 3 0 0 predict.earth: returning earth predictions Petal.Width [1,] 0.2562505 [2,] NA [3,] 0.1880121 > x <- iris[1:3,] > x[2,]$Petal.Width <- as.numeric(NA) # Petal.Width is unused in the earth model > predict.with.message("formula interface and matrix with NA in unused variable", iris.earth, newdata=x) predict.earth formula interface and matrix with NA in unused variable: get.earth.x from model.matrix.earth from predict.earth: x[3,5]: Sepal.Length Sepal.Width Petal.Length Petal.Width Species 1 5.1 3.5 1.4 0.2 setosa 2 4.9 3.0 1.4 NA setosa 3 4.7 3.2 1.3 0.2 setosa Species is a factor with levels: setosa versicolor virginica get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[3,3]: Sepal.Length Sepal.Width Petal.Length 1 5.1 3.5 1.4 2 4.9 3.0 1.4 3 4.7 3.2 1.3 predict.earth with newdata: bx[3,9]: (Intercept) h(6-Petal.Length) h(3.5-Sepal.Width) h(Sepal.Length-6.9) 1 1 4.6 0.0 0 2 1 4.6 0.5 0 3 1 4.7 0.3 0 h(6.9-Sepal.Length) h(Sepal.Length-7.2) h(Petal.Length-5.3) 1 1.8 0 0 2 2.0 0 0 3 2.2 0 0 h(Petal.Length-4.7) h(Petal.Length-5.5) 1 0 0 2 0 0 3 0 0 predict.earth: returning earth predictions Petal.Width [1,] 0.2562505 [2,] 0.1733787 [3,] 0.1880121 > > cat("--- earth.predict with NAs, with matrix interface ---\n") --- earth.predict with NAs, with matrix interface --- > > iris.earth <- earth(iris[,1:3], iris[,4]) > x <- iris[1,] > predict.with.message("default interface and vector", iris.earth, newdata=x) predict.earth default interface and vector: get.earth.x from model.matrix.earth from predict.earth: x[1,5]: Sepal.Length Sepal.Width Petal.Length Petal.Width Species 1 5.1 3.5 1.4 0.2 setosa Species is a factor with levels: setosa versicolor virginica predict.earth with newdata: bx[1,9]: (Intercept) h(6-Petal.Length) h(3.5-Sepal.Width) h(Sepal.Length-6.9) 1 1 4.6 0 0 h(6.9-Sepal.Length) h(Sepal.Length-7.2) h(Petal.Length-5.3) 1 1.8 0 0 h(Petal.Length-4.7) h(Petal.Length-5.5) 1 0 0 predict.earth: returning earth predictions iris[,4] [1,] 0.2562505 > x$Sepal.Width <- as.numeric(NA) > predict.with.message("default interface and vector with NA", iris.earth, newdata=x) predict.earth default interface and vector with NA: get.earth.x from model.matrix.earth from predict.earth: x[1,5]: Sepal.Length Sepal.Width Petal.Length Petal.Width Species 1 5.1 NA 1.4 0.2 setosa Species is a factor with levels: setosa versicolor virginica predict.earth with newdata: bx[1,9]: (Intercept) h(6-Petal.Length) h(3.5-Sepal.Width) h(Sepal.Length-6.9) 1 1 4.6 NA 0 h(6.9-Sepal.Length) h(Sepal.Length-7.2) h(Petal.Length-5.3) 1 1.8 0 0 h(Petal.Length-4.7) h(Petal.Length-5.5) 1 0 0 predict.earth: returning earth predictions iris[,4] [1,] NA > x <- iris[1,] > x$Petal.Width <- as.numeric(NA) # Petal.Width is unused in the earth model > predict.with.message("default interface and vector with NA in unused variable", iris.earth, newdata=x) predict.earth default interface and vector with NA in unused variable: get.earth.x from model.matrix.earth from predict.earth: x[1,5]: Sepal.Length Sepal.Width Petal.Length Petal.Width Species 1 5.1 3.5 1.4 NA setosa Species is a factor with levels: setosa versicolor virginica predict.earth with newdata: bx[1,9]: (Intercept) h(6-Petal.Length) h(3.5-Sepal.Width) h(Sepal.Length-6.9) 1 1 4.6 0 0 h(6.9-Sepal.Length) h(Sepal.Length-7.2) h(Petal.Length-5.3) 1 1.8 0 0 h(Petal.Length-4.7) h(Petal.Length-5.5) 1 0 0 predict.earth: returning earth predictions iris[,4] [1,] 0.2562505 > > x <- iris[1:3,] > predict.with.message("default interface and matrix", iris.earth, newdata=x) predict.earth default interface and matrix: get.earth.x from model.matrix.earth from predict.earth: x[3,5]: Sepal.Length Sepal.Width Petal.Length Petal.Width Species 1 5.1 3.5 1.4 0.2 setosa 2 4.9 3.0 1.4 0.2 setosa 3 4.7 3.2 1.3 0.2 setosa Species is a factor with levels: setosa versicolor virginica predict.earth with newdata: bx[3,9]: (Intercept) h(6-Petal.Length) h(3.5-Sepal.Width) h(Sepal.Length-6.9) 1 1 4.6 0.0 0 2 1 4.6 0.5 0 3 1 4.7 0.3 0 h(6.9-Sepal.Length) h(Sepal.Length-7.2) h(Petal.Length-5.3) 1 1.8 0 0 2 2.0 0 0 3 2.2 0 0 h(Petal.Length-4.7) h(Petal.Length-5.5) 1 0 0 2 0 0 3 0 0 predict.earth: returning earth predictions iris[,4] [1,] 0.2562505 [2,] 0.1733787 [3,] 0.1880121 > x[2,]$Sepal.Width <- as.numeric(NA) > predict.with.message("default interface and matrix with NA", iris.earth, newdata=x) predict.earth default interface and matrix with NA: get.earth.x from model.matrix.earth from predict.earth: x[3,5]: Sepal.Length Sepal.Width Petal.Length Petal.Width Species 1 5.1 3.5 1.4 0.2 setosa 2 4.9 NA 1.4 0.2 setosa 3 4.7 3.2 1.3 0.2 setosa Species is a factor with levels: setosa versicolor virginica predict.earth with newdata: bx[3,9]: (Intercept) h(6-Petal.Length) h(3.5-Sepal.Width) h(Sepal.Length-6.9) 1 1 4.6 0.0 0 2 1 4.6 NA 0 3 1 4.7 0.3 0 h(6.9-Sepal.Length) h(Sepal.Length-7.2) h(Petal.Length-5.3) 1 1.8 0 0 2 2.0 0 0 3 2.2 0 0 h(Petal.Length-4.7) h(Petal.Length-5.5) 1 0 0 2 0 0 3 0 0 predict.earth: returning earth predictions iris[,4] [1,] 0.2562505 [2,] NA [3,] 0.1880121 > x <- iris[1:3,] > x[2,]$Petal.Width <- as.numeric(NA) # Petal.Width is unused in the earth model > predict.with.message("default interface and matrix with NA in unused variable", iris.earth, newdata=x) predict.earth default interface and matrix with NA in unused variable: get.earth.x from model.matrix.earth from predict.earth: x[3,5]: Sepal.Length Sepal.Width Petal.Length Petal.Width Species 1 5.1 3.5 1.4 0.2 setosa 2 4.9 3.0 1.4 NA setosa 3 4.7 3.2 1.3 0.2 setosa Species is a factor with levels: setosa versicolor virginica predict.earth with newdata: bx[3,9]: (Intercept) h(6-Petal.Length) h(3.5-Sepal.Width) h(Sepal.Length-6.9) 1 1 4.6 0.0 0 2 1 4.6 0.5 0 3 1 4.7 0.3 0 h(6.9-Sepal.Length) h(Sepal.Length-7.2) h(Petal.Length-5.3) 1 1.8 0 0 2 2.0 0 0 3 2.2 0 0 h(Petal.Length-4.7) h(Petal.Length-5.5) 1 0 0 2 0 0 3 0 0 predict.earth: returning earth predictions iris[,4] [1,] 0.2562505 [2,] 0.1733787 [3,] 0.1880121 > > cat("--- test reorder.earth ----------------------\n") --- test reorder.earth ---------------------- > a <- earth(O3 ~ ., data = ozone1, degree = 2) > earth:::reorder.earth(a, decomp = "none") [1] 1 2 3 4 5 6 7 8 9 10 11 12 > earth:::reorder.earth(a) # defaults to decomp = "anova" [1] 1 2 10 8 5 4 12 9 3 6 7 11 > a$selected.terms[earth:::reorder.earth(a)] [1] 1 2 17 13 9 8 21 14 7 10 11 19 > > cat("--- tests with ozone data ----------------------\n") --- tests with ozone data ---------------------- > > ozone.test <- function(itest, sModel, x, y, degree=2, nk=51, + plotit=PLOT, trace=0, smooth.col="red") + { + fite <- earth(x, y, degree=degree, nk=nk, trace=trace) + fitm <- mars(x, y, degree=degree, nk=nk) + + cat("itest", + sprint("%-3d", itest), + sprint("%-32s", sModel), + "degree", sprint("%-2d", degree), "nk", sprint("%-3g", nk), + "nTerms", sprint("%-2d", sum(fite$selected.terms != 0)), + "of", sprint("%-3d", nrow(fite$dirs)), + "GRSq", sprint("%4.2g", fite$grsq), + "GRSq ratio", fite$grsq/mars.to.earth(fitm)$grsq, + "\n") + caption <- paste("itest ", itest, ": ", sModel, " degree=", degree, " nk=", nk, sep="") + printh(summary(fite)) + printh(summary(fite, style="bf")) + if(plotit) { + fitme <- mars.to.earth(fitm) + plotmo(fite, caption=paste("EARTH", caption), trace=-1) + plotmo(fitme, caption=paste("MARS", caption), trace=-1) + plot(fite, npoints=500, smooth.col=smooth.col, caption=paste("EARTH", caption), info=TRUE) + plot(fitme, caption=paste("MARS", caption), info=TRUE) + fitme <- update(fitme) # generate model selection data + plot.earth.models(list(fite, fitme), caption=paste(itest, ": Compare earth to mars ", sModel, sep="")) + } + fite + } > data(ozone1) > attach(ozone1) > > x.global <- cbind(wind, humidity, temp, vis) > y <- doy > itest <- 1; ozone.test(itest, "doy ~ wind+humidity+temp+vis", x.global, y, degree=1, nk=21) Converted mars(x=x, y=y, degree=degree, nk=nk) to earth(x=x, y=y, degree=degree, nk=nk) itest 1 doy ~ wind+humidity+temp+vis degree 1 nk 21 nTerms 7 of 15 GRSq 0.2 GRSq ratio 1.209183 ===summary(fite) Call: earth(x=x, y=y, trace=trace, degree=degree, nk=nk) coefficients (Intercept) 68.211814 h(3-wind) 58.202580 h(28-humidity) 8.904095 h(humidity-28) 1.514544 h(temp-45) 45.704313 h(temp-48) -118.146795 h(temp-49) 73.558997 Selected 7 of 15 terms, and 3 of 4 predictors Termination condition: Reached nk 21 Importance: wind, temp, humidity, vis-unused Number of terms at each degree of interaction: 1 6 (additive model) GCV 8737.327 RSS 2660622 GRSq 0.2004306 RSq 0.2576942 ===summary(fite, style = "bf") Call: earth(x=x, y=y, trace=trace, degree=degree, nk=nk) y = 68.21181 + 58.20258 * bf1 + 8.904095 * bf2 + 1.514544 * bf3 + 45.70431 * bf4 - 118.1468 * bf5 + 73.559 * bf6 bf1 h(3-wind) bf2 h(28-humidity) bf3 h(humidity-28) bf4 h(temp-45) bf5 h(temp-48) bf6 h(temp-49) Selected 7 of 15 terms, and 3 of 4 predictors Termination condition: Reached nk 21 Importance: wind, temp, humidity, vis-unused Number of terms at each degree of interaction: 1 6 (additive model) GCV 8737.327 RSS 2660622 GRSq 0.2004306 RSq 0.2576942 Converted mars(x=x, y=y, degree=degree, nk=nk) to earth(x=x, y=y, degree=degree, nk=nk) Selected 7 of 15 terms, and 3 of 4 predictors Termination condition: Reached nk 21 Importance: wind, temp, humidity, vis-unused Number of terms at each degree of interaction: 1 6 (additive model) GCV 8737.327 RSS 2660622 GRSq 0.2004306 RSq 0.2576942 > > x.global <- cbind(wind, humidity, temp, vis) > y <- doy > itest <- itest+1; a91 <- ozone.test(itest, "doy ~ wind+humidity+temp+vis", x.global, y, degree=2, nk=21) Converted mars(x=x, y=y, degree=degree, nk=nk) to earth(x=x, y=y, degree=degree, nk=nk) itest 2 doy ~ wind+humidity+temp+vis degree 2 nk 21 nTerms 10 of 20 GRSq 0.17 GRSq ratio 0.9365432 ===summary(fite) Call: earth(x=x, y=y, trace=trace, degree=degree, nk=nk) coefficients (Intercept) 130.291709 h(3-wind) 56.324090 h(28-humidity) 15.639545 h(humidity-28) 2.108507 h(49-temp) -8.918573 h(wind-3) * h(44-temp) 1.473267 h(23-humidity) * h(temp-49) -4.977131 h(28-humidity) * h(temp-53) 1.856655 h(humidity-28) * h(vis-200) -0.022851 h(temp-49) * h(vis-120) 0.024712 Selected 10 of 20 terms, and 4 of 4 predictors Termination condition: Reached nk 21 Importance: wind, temp, humidity, vis Number of terms at each degree of interaction: 1 4 5 GCV 9046.094 RSS 2575183 GRSq 0.1721748 RSq 0.2815314 ===summary(fite, style = "bf") Call: earth(x=x, y=y, trace=trace, degree=degree, nk=nk) y = 130.2917 + 56.32409 * bf1 + 15.63955 * bf2 + 2.108507 * bf3 - 8.918573 * bf4 + 1.473267 * bf5 * bf6 - 4.977131 * bf7 * bf8 + 1.856655 * bf2 * bf9 - 0.02285106 * bf3 * bf10 + 0.02471206 * bf8 * bf11 bf1 h(3-wind) bf2 h(28-humidity) bf3 h(humidity-28) bf4 h(49-temp) bf5 h(wind-3) bf6 h(44-temp) bf7 h(23-humidity) bf8 h(temp-49) bf9 h(temp-53) bf10 h(vis-200) bf11 h(vis-120) Selected 10 of 20 terms, and 4 of 4 predictors Termination condition: Reached nk 21 Importance: wind, temp, humidity, vis Number of terms at each degree of interaction: 1 4 5 GCV 9046.094 RSS 2575183 GRSq 0.1721748 RSq 0.2815314 Converted mars(x=x, y=y, degree=degree, nk=nk) to earth(x=x, y=y, degree=degree, nk=nk) > > # this is a basic test of RegressAndFix (because this generates lin dep bx cols) > > cat("--Expect warning from mda::mars: NAs introduced by coercion\n") # why do we get a warning? --Expect warning from mda::mars: NAs introduced by coercion > x.global <- cbind(wind, exp(humidity)) > y <- doy > # smooth.col is 0 else get loess errors > # trace==2 so we print the "Fixed rank deficient bx by removing 2 terms, 7 terms remain" message > # TODO why are we getting the rank deficient message? > itest <- itest+1; ozone.test(itest, "doy ~ wind+exp(humidity)", x.global, y, degree=1, nk=21, smooth.col=0, trace=2) x[330,2] with colnames wind "" y[330,1] with colname y, and values 33, 34, 35, 36, 37, 38, 39, 4... Forward pass: minspan 5 endspan 8 x[330,2] 5.16 kB bx[330,21] 54.1 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0887 0.1107 0.1107 1 wind 3 2 3 1 4 0.0906 0.1235 0.01274 1 wind 9 4 1 6 0.0821 0.1262 0.002668 1 wind 4 5 1 8 0.0730 0.1285 0.002307 1 wind 6 6 1 10 0.0633 0.1304 0.001925 2 1.7848e+08< 7 1 12 0.0534 0.1323 0.001868 2 1.7848e+08< 8 1 14 0.0432 0.1340 0.001792 2 1.7848e+08< 9 1 16 0.0309 0.1340 0 - reject (no DeltaRsq) RSq changed by less than 0.001 at 15 terms, 9 terms used (DeltaRSq 0) After forward pass GRSq 0.031 RSq 0.134 Forward pass complete: 15 terms, 9 terms used Fixed rank deficient bx by removing 2 terms, 7 terms remain Prune backward penalty 2 nprune null: selected 3 of 7 terms, and 1 of 2 preds After pruning pass GRSq 0.101 RSq 0.123 Warning in storage.mode(tagx) <- "integer" : NAs introduced by coercion to integer range Converted mars(x=x, y=y, degree=degree, nk=nk) to earth(x=x, y=y, degree=degree, nk=nk) itest 3 doy ~ wind+exp(humidity) degree 1 nk 21 nTerms 3 of 7 GRSq 0.1 GRSq ratio 1.318534 ===summary(fite) Call: earth(x=x, y=y, trace=trace, degree=degree, nk=nk) coefficients (Intercept) 202.17924 h(3-wind) 50.04004 h(wind-9) -61.15513 Selected 3 of 7 terms, and 1 of 2 predictors Termination condition: RSq changed by less than 0.001 at 7 terms Importance: wind, x2-unused Number of terms at each degree of interaction: 1 2 (additive model) GCV 9821.564 RSS 3143644 GRSq 0.1012101 RSq 0.1229323 ===summary(fite, style = "bf") Call: earth(x=x, y=y, trace=trace, degree=degree, nk=nk) y = 202.1792 + 50.04004 * bf1 - 61.15513 * bf2 bf1 h(3-wind) bf2 h(wind-9) Selected 3 of 7 terms, and 1 of 2 predictors Termination condition: RSq changed by less than 0.001 at 7 terms Importance: wind, x2-unused Number of terms at each degree of interaction: 1 2 (additive model) GCV 9821.564 RSS 3143644 GRSq 0.1012101 RSq 0.1229323 Converted mars(x=x, y=y, degree=degree, nk=nk) to earth(x=x, y=y, degree=degree, nk=nk) Selected 3 of 7 terms, and 1 of 2 predictors Termination condition: RSq changed by less than 0.001 at 7 terms Importance: wind, x2-unused Number of terms at each degree of interaction: 1 2 (additive model) GCV 9821.564 RSS 3143644 GRSq 0.1012101 RSq 0.1229323 > > x.global <- cbind(vh,wind,humidity,temp,ibh,dpg,ibt,vis,doy) > y <- O3 > itest <- itest+1; ozone.test(itest, "O3~.", x.global, y, degree=2, nk=21) Converted mars(x=x, y=y, degree=degree, nk=nk) to earth(x=x, y=y, degree=degree, nk=nk) itest 4 O3~. degree 2 nk 21 nTerms 12 of 21 GRSq 0.79 GRSq ratio 1.014924 ===summary(fite) Call: earth(x=x, y=y, trace=trace, degree=degree, nk=nk) coefficients (Intercept) 13.2169900 h(temp-58) 0.3726072 h(194-ibt) -0.0455100 h(200-vis) 0.0222462 h(96-doy) -0.1223029 h(doy-96) -0.0240235 h(5730-vh) * h(temp-58) -0.0104496 h(wind-7) * h(200-vis) -0.0180898 h(55-humidity) * h(temp-58) -0.0222754 h(temp-58) * h(dpg-52) -0.0168249 h(temp-58) * h(52-dpg) 0.0041232 h(1105-ibh) * h(21-dpg) -0.0001022 Selected 12 of 21 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, ibh, dpg, vis, wind, vh Number of terms at each degree of interaction: 1 5 6 GCV 13.40805 RSS 3693.401 GRSq 0.7917216 RSq 0.825085 ===summary(fite, style = "bf") Call: earth(x=x, y=y, trace=trace, degree=degree, nk=nk) y = 13.21699 + 0.3726072 * bf1 - 0.04550995 * bf2 + 0.02224623 * bf3 - 0.1223029 * bf4 - 0.02402354 * bf5 - 0.01044957 * bf6 * bf1 - 0.01808982 * bf7 * bf3 - 0.02227539 * bf8 * bf1 - 0.01682493 * bf1 * bf9 + 0.004123235 * bf1 * bf10 - 0.000102163 * bf11 * bf12 bf1 h(temp-58) bf2 h(194-ibt) bf3 h(200-vis) bf4 h(96-doy) bf5 h(doy-96) bf6 h(5730-vh) bf7 h(wind-7) bf8 h(55-humidity) bf9 h(dpg-52) bf10 h(52-dpg) bf11 h(1105-ibh) bf12 h(21-dpg) Selected 12 of 21 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, ibh, dpg, vis, wind, vh Number of terms at each degree of interaction: 1 5 6 GCV 13.40805 RSS 3693.401 GRSq 0.7917216 RSq 0.825085 Converted mars(x=x, y=y, degree=degree, nk=nk) to earth(x=x, y=y, degree=degree, nk=nk) Selected 12 of 21 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, ibh, dpg, vis, wind, vh Number of terms at each degree of interaction: 1 5 6 GCV 13.40805 RSS 3693.401 GRSq 0.7917216 RSq 0.825085 > > x.global <- cbind(vh,wind,humidity,temp,ibh,dpg,ibt,vis,doy) > y <- O3 > itest <- itest+1; ozone.test(itest, "O3~., nk=51", x.global, y, degree=2, nk=51) Converted mars(x=x, y=y, degree=degree, nk=nk) to earth(x=x, y=y, degree=degree, nk=nk) itest 5 O3~., nk=51 degree 2 nk 51 nTerms 25 of 46 GRSq 0.81 GRSq ratio 1.006346 ===summary(fite) Call: earth(x=x, y=y, trace=trace, degree=degree, nk=nk) coefficients (Intercept) 68.254338 h(temp-58) 0.361808 h(10-dpg) -0.037457 h(dpg-10) -0.043446 h(ibt-281) 0.276811 h(vis-17) -0.293855 h(200-vis) -0.247686 h(vis-200) 0.321231 h(96-doy) -0.111486 h(doy-96) -0.023111 h(5730-vh) * h(temp-58) -0.009559 h(vh-5850) * h(doy-96) 0.000494 h(wind-7) * h(200-vis) -0.012406 h(55-humidity) * h(temp-58) -0.018386 h(humidity-55) * h(temp-58) 0.005696 h(temp-71) * h(1105-ibh) 0.000423 h(temp-58) * h(dpg-52) -0.013575 h(temp-72) * h(doy-96) -0.003615 h(1105-ibh) * h(21-dpg) -0.000100 h(ibt-194) * h(vis-80) 0.014133 h(ibt-194) * h(vis-70) -0.008274 h(ibt-194) * h(vis-100) -0.006492 h(230-ibt) * h(vis-17) -0.000179 h(260-ibt) * h(200-vis) -0.000331 h(ibt-260) * h(200-vis) -0.001086 Selected 25 of 46 terms, and 9 of 9 predictors Termination condition: Reached nk 51 Importance: temp, ibt, vis, doy, ibh, dpg, humidity, wind, vh Number of terms at each degree of interaction: 1 9 15 GCV 12.35626 RSS 2709.428 GRSq 0.80806 RSq 0.8716848 ===summary(fite, style = "bf") Call: earth(x=x, y=y, trace=trace, degree=degree, nk=nk) y = 68.25434 + 0.3618078 * bf1 - 0.03745668 * bf2 - 0.04344561 * bf3 + 0.2768106 * bf4 - 0.2938554 * bf5 - 0.2476858 * bf6 + 0.3212311 * bf7 - 0.1114864 * bf8 - 0.02311108 * bf9 - 0.009559369 * bf10 * bf1 + 0.0004937219 * bf11 * bf9 - 0.01240617 * bf12 * bf6 - 0.01838558 * bf13 * bf1 + 0.005696166 * bf14 * bf1 + 0.0004227812 * bf15 * bf16 - 0.01357508 * bf1 * bf17 - 0.003615445 * bf18 * bf9 - 0.0001000355 * bf16 * bf19 + 0.01413322 * bf20 * bf21 - 0.008274048 * bf20 * bf22 - 0.006492333 * bf20 * bf23 - 0.0001792429 * bf24 * bf5 - 0.0003309519 * bf25 * bf6 - 0.001086437 * bf26 * bf6 bf1 h(temp-58) bf2 h(10-dpg) bf3 h(dpg-10) bf4 h(ibt-281) bf5 h(vis-17) bf6 h(200-vis) bf7 h(vis-200) bf8 h(96-doy) bf9 h(doy-96) bf10 h(5730-vh) bf11 h(vh-5850) bf12 h(wind-7) bf13 h(55-humidity) bf14 h(humidity-55) bf15 h(temp-71) bf16 h(1105-ibh) bf17 h(dpg-52) bf18 h(temp-72) bf19 h(21-dpg) bf20 h(ibt-194) bf21 h(vis-80) bf22 h(vis-70) bf23 h(vis-100) bf24 h(230-ibt) bf25 h(260-ibt) bf26 h(ibt-260) Selected 25 of 46 terms, and 9 of 9 predictors Termination condition: Reached nk 51 Importance: temp, ibt, vis, doy, ibh, dpg, humidity, wind, vh Number of terms at each degree of interaction: 1 9 15 GCV 12.35626 RSS 2709.428 GRSq 0.80806 RSq 0.8716848 Converted mars(x=x, y=y, degree=degree, nk=nk) to earth(x=x, y=y, degree=degree, nk=nk) Selected 25 of 46 terms, and 9 of 9 predictors Termination condition: Reached nk 51 Importance: temp, ibt, vis, doy, ibh, dpg, humidity, wind, vh Number of terms at each degree of interaction: 1 9 15 GCV 12.35626 RSS 2709.428 GRSq 0.80806 RSq 0.8716848 > > detach(ozone1) > > cat("--- fast mars -----------------------------------\n") --- fast mars ----------------------------------- > > printh(earth(O3 ~ ., data=ozone1, degree=2, nk = 31, fast.k = 0, fast.beta = 1)) ===earth(O3 ~ ., data = ozone1, degree = 2, nk = 31, fast.k = 0, fast.beta = 1) Selected 15 of 31 terms, and 9 of 9 predictors Termination condition: Reached nk 31 Importance: temp, ibt, humidity, doy, dpg, vis, wind, ibh, vh Number of terms at each degree of interaction: 1 5 9 GCV 13.22659 RSS 3464.405 GRSq 0.7945405 RSq 0.83593 > printh(earth(O3 ~ ., data=ozone1, degree=2, nk = 31, fast.k = 0, fast.beta = 0)) ===earth(O3 ~ ., data = ozone1, degree = 2, nk = 31, fast.k = 0, fast.beta = 0) Selected 15 of 31 terms, and 9 of 9 predictors Termination condition: Reached nk 31 Importance: temp, ibt, humidity, doy, dpg, vis, wind, ibh, vh Number of terms at each degree of interaction: 1 5 9 GCV 13.22659 RSS 3464.405 GRSq 0.7945405 RSq 0.83593 > printh(earth(O3 ~ ., data=ozone1, degree=2, nk = 31, fast.k = 5, fast.beta = 1)) ===earth(O3 ~ ., data = ozone1, degree = 2, nk = 31, fast.k = 5, fast.beta = 1) Selected 11 of 17 terms, and 7 of 9 predictors Termination condition: RSq changed by less than 0.001 at 17 terms Importance: humidity, ibt, doy, temp, dpg, ibh, wind, vh-unused, ... Number of terms at each degree of interaction: 1 8 2 GCV 14.15189 RSS 3963.216 GRSq 0.780167 RSq 0.8123069 > printh(earth(O3 ~ ., data=ozone1, degree=2, nk = 31, fast.k = 5, fast.beta = 0)) ===earth(O3 ~ ., data = ozone1, degree = 2, nk = 31, fast.k = 5, fast.beta = 0) Selected 11 of 17 terms, and 6 of 9 predictors Termination condition: RSq changed by less than 0.001 at 17 terms Importance: humidity, ibt, doy, ibh, vis, dpg, temp-unused, vh-unused, ... Number of terms at each degree of interaction: 1 6 4 GCV 13.89191 RSS 3890.408 GRSq 0.7842055 RSq 0.815755 > > cat("--- plot.earth and plot.earth.models ------------\n") --- plot.earth and plot.earth.models ------------ > > a <- earth(O3 ~ ., data=ozone1) # formula interface > > if (PLOT) + plot(a, caption="plot.earth test 1", col.rsq=3, smooth.col=4, qqline.col="pink", + col.vline=1, col.npreds=0, nresiduals=100, cum.grid="grid", + grid.col="lightblue", col.sel.grid="lightgreen") > > set.seed(1) > if (PLOT) { + plot(a, caption="plot.earth test 2", which=c(3,4,1), ylim=c(.2,.9), + id.n=20, legend.pos=c(10,.6), pch=20, lty.vline=1, cex.legend=1, + grid.col="lightblue") + + plot(a, caption="plot.earth test 3", which=2, main="test main") + } > > a1 <- earth(ozone1[,c(2:4,10)], ozone1[,1]) # x,y interface > > if (PLOT) { + plot(a, caption="plot.earth test 4", id.n=1) + set.seed(1) + plot.earth.models(a, which=1, ylim=c(.4,.8), jitter=.01) + + plot.earth.models(a1) + + plot.earth.models(list(a, a1), col.cum=c(3,4), col.grsq=c(1,2), col.rsq=c(3,4), + col.npreds=1, col.vline=1, lty.vline=3, + legend.pos=c(5,.4), legend.text=c("a", "b", "c"), cex.legend=1.3) + } > > cat("--- plot.earth args -----------------------------\n") --- plot.earth args ----------------------------- > > test.plot.earth.args <- function() + { + caption <- "test earth args" + printh(caption) + + argtest <- earth(ozone1[,c(2:4,10)], ozone1[,1]) + + old.par <- par(no.readonly=TRUE) + on.exit(par(old.par)) + par(mfrow=c(2,3)) + par(cex = 0.8) + par(mar = c(3, 3, 3, 0.5)) # small margins and text to pack figs in + par(mgp = c(1.6, 0.6, 0)) # flatten axis elements + oma <- par("oma") # make space for caption + oma[3] <- 2.4 + par(oma=oma) + par(cex.main=1) + + plot(argtest, do.par=FALSE, which=1, + main="default") + + mtext(caption, outer=TRUE, font=2) + + plot(argtest, do.par=FALSE, which=1, + col.rsq=3, col.grsq=2, + col.npreds="blue", grid.col="lightblue", + main=sprint("%s\n%s", + "col.rsq=3, col.grsq=2, ", + "col.npreds=\"lightblue\", col.sel.grid=\"gray\"")) + + plot(argtest, do.par=FALSE, which=1, + col.vline="pink", legend.pos="topleft", + lty.grsq=2, lty.npreds=1, lty.vline=1, + main=sprint("%s\n%s", + "col.vline=\"pink\", legend.pos=\"topleft\", ", + "lty.grsq=2, lty.npreds=1, lty.vline=1")) + + plot(argtest, do.par=FALSE, which=1, + legend.pos=NA, col.npreds=0, + main="legend.pos=NA, col.npreds=0") + + plot(argtest, do.par=FALSE, which=1, + legend.pos=0, + main="legend.pos=0") + } > test.plot.earth.args() ===caption [1] "test earth args" > > cat("--- test minspan --------------------------------\n") --- test minspan -------------------------------- > > a.minspan2 <- earth(O3 ~ ., data=ozone1, minspan=2) > printh(summary(a.minspan2)) ===summary(a.minspan2) Call: earth(formula=O3~., data=ozone1, minspan=2) coefficients (Intercept) 37.206815 h(5740-vh) -0.020094 h(54-humidity) -0.130146 h(temp-58) 0.322610 h(1046-ibh) -0.003655 h(dpg-12) -0.092232 h(ibt-120) 0.038616 h(vis-17) -0.372533 h(80-vis) -0.319300 h(vis-80) 0.365130 h(89-doy) -0.144947 h(doy-159) -0.032265 Selected 12 of 19 terms, and 8 of 9 predictors Termination condition: Reached nk 21 Importance: temp, vh, humidity, dpg, doy, ibh, vis, ibt, wind-unused Number of terms at each degree of interaction: 1 11 (additive model) GCV 14.47406 RSS 4133.834 GRSq 0.7751625 RSq 0.8042266 > > a.minspan0 <- earth(O3 ~ ., data=ozone1, minspan=0) > printh(summary(a.minspan0)) ===summary(a.minspan0) Call: earth(formula=O3~., data=ozone1, minspan=0) coefficients (Intercept) 14.1595171 h(5860-vh) -0.0137728 h(wind-3) -0.3377222 h(54-humidity) -0.1349547 h(temp-58) 0.2791320 h(1105-ibh) -0.0033837 h(dpg-10) -0.0991581 h(ibt-120) 0.0326330 h(150-vis) 0.0231881 h(96-doy) -0.1105145 h(doy-96) 0.0406468 h(doy-158) -0.0836732 Selected 12 of 20 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, dpg, doy, vh, ibh, vis, ibt, wind Number of terms at each degree of interaction: 1 11 (additive model) GCV 14.61004 RSS 4172.671 GRSq 0.7730502 RSq 0.8023874 > > a.minspan.minus1 <- earth(O3 ~ ., data=ozone1, minspan=-1) > printh(summary(a.minspan.minus1)) ===summary(a.minspan.minus1) Call: earth(formula=O3~., data=ozone1, minspan=-1) coefficients (Intercept) 14.8317540 ibh 0.0035879 h(5760-vh) -0.0131360 h(64-humidity) -0.0630395 h(temp-62) 0.3670405 h(ibh-823) -0.0043888 h(dpg-24) -0.1188100 h(120-vis) 0.0359176 h(206-doy) -0.0486385 h(doy-206) -0.0585411 Selected 10 of 19 terms, and 7 of 9 predictors Termination condition: Reached nk 21 Importance: temp, ibh, humidity, dpg, vis, doy, vh, wind-unused, ... Number of terms at each degree of interaction: 1 9 (additive model) GCV 16.16163 RSS 4736.877 GRSq 0.748948 RSq 0.7756673 > > a.minspan.minus3 <- earth(O3 ~ ., data=ozone1, minspan=-3) > printh(summary(a.minspan.minus3)) ===summary(a.minspan.minus3) Call: earth(formula=O3~., data=ozone1, minspan=-3) coefficients (Intercept) 13.5336798 h(5690-vh) -0.0169026 h(vh-5690) 0.0155040 h(wind-3) -0.2790195 h(64-humidity) -0.0997117 h(temp-62) 0.5474683 h(temp-72) -0.3244650 h(dpg-24) -0.1084691 h(ibt-107) 0.0171885 h(150-vis) 0.0232805 h(119-doy) -0.1064486 h(doy-119) -0.0334354 Selected 12 of 20 terms, and 8 of 9 predictors Termination condition: Reached nk 21 Importance: temp, dpg, vis, doy, vh, humidity, ibh-unused, wind, ibt Number of terms at each degree of interaction: 1 11 (additive model) GCV 14.82868 RSS 4235.117 GRSq 0.7696538 RSq 0.79943 > > a.endspan80 <- earth(O3 ~ ., data=ozone1, endspan=80) > printh(summary(a.endspan80)) ===summary(a.endspan80) Call: earth(formula=O3~., data=ozone1, endspan=80) coefficients (Intercept) 14.7832332 h(5770-vh) -0.0160418 h(wind-3) -0.3028539 h(55-humidity) -0.1303358 h(temp-58) 0.3179697 h(1046-ibh) -0.0041830 h(dpg-10) -0.0933000 h(ibt-121) 0.0371643 h(150-vis) 0.0223985 h(118-doy) -0.0989561 h(doy-147) -0.0367509 Selected 11 of 20 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, doy, humidity, dpg, ibh, vh, vis, ibt, wind Number of terms at each degree of interaction: 1 10 (additive model) GCV 14.31885 RSS 4142.964 GRSq 0.7775735 RSq 0.8037943 > > cat("--- test multiple responses ---------------------\n") --- test multiple responses --------------------- > > # this uses the global matrix data.global (data.global[,1:2] is the response) > > test.two.responses <- function(itest, func1, func2, + degree=2, nk=51, plotit=PLOT, test.rsq=TRUE, trace=0, minspan=0, + test.mars.to.earth=FALSE, pmethod="backward") + { + if(typeof(func1) == "character") + funcnames <- paste("multiple responses", func1, func2) + else + funcnames <- paste("multiple responses", deparse(substitute(func1)), deparse(substitute(func2))) + cat("itest", sprint("%-3d", itest), funcnames, + " degree", sprint("%-2d", degree), "nk", sprint("%-3g", nk), "\n\n") + gc() + fite <- earth(x=data.global[,c(-1,-2), drop=FALSE], y=data.global[,1:2], + degree=degree, trace=trace, nk=nk, pmethod=pmethod, minspan=minspan) + printh(fite) + caption <- paste("itest ", itest, ": ", funcnames, " degree=", degree, " nk=", nk, sep="") + if(plotit) { + if(typeof(func1) == "character") { + plotmo(fite, caption=caption, nresponse=1, trace=-1) + plotmo(fite, nresponse=2, trace=-1) + } else { + plotmo(fite, func=func1, caption=caption, nresponse=1) + plotmo(fite, func=func2, nresponse=2) + } + plot(fite, caption=caption, nresponse=1) + plot(fite, nresponse=2) + } + cat("\n") + if(test.mars.to.earth) { + cat("Testing mars.to.earth with a multiple response model\n") + fitm <- mars(data.global[,c(-1,-2), drop=FALSE], data.global[,1:2], + degree=degree, trace=(trace!=0), nk=nk) + fitme <- mars.to.earth(fitm) + printh(fitme) + printh(summary(fitme)) + if(plotit) { + plotmo(fitm, func=func1, caption=caption, nresponse=1, clip=FALSE) + plotmo(fitm, func=func2, nresponse=2, clip=FALSE) + } + # TODO following code causes error "nk" not found, looking in wrong environment? + # cat("Expect warnings because of weights in the mars model\n") + # fitm <- mars(data.global[,c(-1,-2), drop=FALSE], data.global[,1:2], + # degree=degree, trace=(trace!=0), nk=nk, wp=c(1,2)) + # fitme <- mars.to.earth(fitm) + # printh(fitme) + # printh(summary(fitme)) + } + fite + } > > N <- 100 > set.seed(1) > x1 <- runif(N, -1, 1) > x2 <- runif(N, -1, 1) > x3 <- runif(N, -1, 1) > x4 <- runif(N, -1, 1) > x5 <- runif(N, -1, 1) > > func1 <- function(x) + { + sin(3 * x[,1]) + x[,2] + } > func7 <- function(x) # just one predictor + { + sin(5 * x[,1]) + } > x.global <- cbind( x1, x2) > data.global <- cbind(func1(x.global), func7(x.global), x1, x2) > colnames(data.global) = c("func1", "func7", "x1", "x2") > # expect pmethod="ex" cannot be used with multiple response models > expect.err(try(test.two.responses(itest, func1, func7, nk=51, degree=1, pmethod="ex")), "not allowed with multiple response models") itest 5 multiple responses func1 func7 degree 1 nk 51 Error : pmethod="exhaustive" is not allowed with multiple response models (y has 2 columns, use trace=4 to see y) Got error as expected from try(test.two.responses(itest, func1, func7, nk = 51, degree = 1, pmethod = "ex")) > # expect pmethod="seq" cannot be used with multiple response models > expect.err(try(test.two.responses(itest, func1, func7, nk=51, degree=1, pmethod="seq")), "not allowed with multiple response models") itest 5 multiple responses func1 func7 degree 1 nk 51 Error : pmethod="seqrep" is not allowed with multiple response models (y has 2 columns, use trace=4 to see y) Got error as expected from try(test.two.responses(itest, func1, func7, nk = 51, degree = 1, pmethod = "seq")) > itest <- itest+1; a <- test.two.responses(itest, func1, func7, nk=51, degree=1) itest 6 multiple responses func1 func7 degree 1 nk 51 ===fite Selected 9 of 9 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: x1, x2 Number of terms at each degree of interaction: 1 8 (additive model) GCV RSS GRSq RSq func1 0.002626520 0.1809409 0.9969000 0.9978211 func7 0.007889046 0.5434764 0.9846251 0.9891931 All 0.010515566 0.7244173 0.9922701 0.9945668 plotmo grid: x1 x2 -0.02437858 0.03719751 plotmo grid: x1 x2 -0.02437858 0.03719751 > printh(summary(a)) ===summary(a) Call: earth(x=data.global[,c(-1,-2),drop=FALSE], y=data.global[,1:2], pmethod=pmethod, trace=trace, degree=degree, nk=nk, minspan=minspan) func1 func7 (Intercept) -1.4159357 -0.6824246 h(-0.468983-x1) 1.4219106 3.9942993 h(x1- -0.468983) 1.8463556 -1.4788784 h(x1- -0.235224) 0.9882662 5.9409061 h(x1-0.209867) -0.8510911 -4.4376027 h(x1-0.425029) -2.5321006 -4.8071373 h(x1-0.739382) -2.1198279 2.4557576 h(-0.329025-x2) -1.0346040 -0.0308457 h(x2- -0.329025) 0.9870580 -0.0232994 Selected 9 of 9 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: x1, x2 Number of terms at each degree of interaction: 1 8 (additive model) GCV RSS GRSq RSq func1 0.002626520 0.1809409 0.9969000 0.9978211 func7 0.007889046 0.5434764 0.9846251 0.9891931 All 0.010515566 0.7244173 0.9922701 0.9945668 > printh(summary(a, style="bf")) ===summary(a, style = "bf") Call: earth(x=data.global[,c(-1,-2),drop=FALSE], y=data.global[,1:2], pmethod=pmethod, trace=trace, degree=degree, nk=nk, minspan=minspan) func1 = -1.415936 + 1.421911 * bf1 + 1.846356 * bf2 + 0.9882662 * bf3 - 0.8510911 * bf4 - 2.532101 * bf5 - 2.119828 * bf6 - 1.034604 * bf7 + 0.987058 * bf8 bf1 h(-0.468983-x1) bf2 h(x1--0.468983) bf3 h(x1--0.235224) bf4 h(x1-0.209867) bf5 h(x1-0.425029) bf6 h(x1-0.739382) bf7 h(-0.329025-x2) bf8 h(x2--0.329025) func7 = -0.6824246 + 3.994299 * bf1 - 1.478878 * bf2 + 5.940906 * bf3 - 4.437603 * bf4 - 4.807137 * bf5 + 2.455758 * bf6 - 0.03084575 * bf7 - 0.02329942 * bf8 bf1 h(-0.468983-x1) bf2 h(x1--0.468983) bf3 h(x1--0.235224) bf4 h(x1-0.209867) bf5 h(x1-0.425029) bf6 h(x1-0.739382) bf7 h(-0.329025-x2) bf8 h(x2--0.329025) Selected 9 of 9 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: x1, x2 Number of terms at each degree of interaction: 1 8 (additive model) GCV RSS GRSq RSq func1 0.002626520 0.1809409 0.9969000 0.9978211 func7 0.007889046 0.5434764 0.9846251 0.9891931 All 0.010515566 0.7244173 0.9922701 0.9945668 > if (PLOT) { + plotmo(a, nresponse=1, trace=-1) # test generation of caption based on response name + plotmo(a, nresponse=2, trace=-1) + plot(a, nresponse=1) + plot(a, nresponse=2) + } > x.global <- cbind( x1, x2) > data.global <- cbind(func1(x.global), func7(x.global), x1, x2) > colnames(data.global) = c("func1", + "a.very.long.in.fact.extremely.long.response.name", + "x1.a.very.long.in.fact.extremely.long.predictor.name", + "x2") > itest <- itest+1; a <- test.two.responses(itest, func1, func7, nk=51, degree=3) itest 7 multiple responses func1 func7 degree 3 nk 51 ===fite Selected 9 of 9 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: x1.a.very.long.in.fact.extremely.long.predictor.name, x2 Number of terms at each degree of interaction: 1 8 (additive model) GCV RSS func1 0.002899230 0.1809409 a.very.long.in.fact.extremely.long.response.name 0.008708162 0.5434764 All 0.011607392 0.7244173 GRSq RSq func1 0.9965782 0.9978211 a.very.long.in.fact.extremely.long.response.name 0.9830287 0.9891931 All 0.9914675 0.9945668 plotmo grid: x1.a.very.long.in.fact.extremely.long.predictor.name -0.02437858 x2 0.03719751 plotmo grid: x1.a.very.long.in.fact.extremely.long.predictor.name -0.02437858 x2 0.03719751 > printh(summary(a)) ===summary(a) Call: earth(x=data.global[,c(-1,-2),drop=FALSE], y=data.global[,1:2], pmethod=pmethod, trace=trace, degree=degree, nk=nk, minspan=minspan) func1 (Intercept) -1.4159357 h(-0.468983-x1.a.very.long.in.fact.extremely.long.predictor.name) 1.4219106 h(x1.a.very.long.in.fact.extremely.long.predictor.name- -0.468983) 1.8463556 h(x1.a.very.long.in.fact.extremely.long.predictor.name- -0.235224) 0.9882662 h(x1.a.very.long.in.fact.extremely.long.predictor.name-0.209867) -0.8510911 h(x1.a.very.long.in.fact.extremely.long.predictor.name-0.425029) -2.5321006 h(x1.a.very.long.in.fact.extremely.long.predictor.name-0.739382) -2.1198279 h(-0.329025-x2) -1.0346040 h(x2- -0.329025) 0.9870580 a.very.long.in.fact.extremely.long.response.name (Intercept) -0.6824246 h(-0.468983-x1.a.very.long.in.fact.extremely.long.predictor.name) 3.9942993 h(x1.a.very.long.in.fact.extremely.long.predictor.name- -0.468983) -1.4788784 h(x1.a.very.long.in.fact.extremely.long.predictor.name- -0.235224) 5.9409061 h(x1.a.very.long.in.fact.extremely.long.predictor.name-0.209867) -4.4376027 h(x1.a.very.long.in.fact.extremely.long.predictor.name-0.425029) -4.8071373 h(x1.a.very.long.in.fact.extremely.long.predictor.name-0.739382) 2.4557576 h(-0.329025-x2) -0.0308457 h(x2- -0.329025) -0.0232994 Selected 9 of 9 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: x1.a.very.long.in.fact.extremely.long.predictor.name, x2 Number of terms at each degree of interaction: 1 8 (additive model) GCV RSS func1 0.002899230 0.1809409 a.very.long.in.fact.extremely.long.response.name 0.008708162 0.5434764 All 0.011607392 0.7244173 GRSq RSq func1 0.9965782 0.9978211 a.very.long.in.fact.extremely.long.response.name 0.9830287 0.9891931 All 0.9914675 0.9945668 > print(evimp(a)) nsubsets gcv rss x1.a.very.long.in.fact.extremely.long.predictor.name 8 100.0 100.0 x2 6 65.6 62.4 > print.default(evimp(a)) col used nsubsets x1.a.very.long.in.fact.extremely.long.predictor.name 1 1 8 x2 2 1 6 gcv gcv.match x1.a.very.long.in.fact.extremely.long.predictor.name 100.00000 1 x2 65.60412 1 rss rss.match x1.a.very.long.in.fact.extremely.long.predictor.name 100.00000 1 x2 62.37599 1 attr(,"class") [1] "evimp" attr(,"sqrt") [1] TRUE > > eqn56 <- function(x) # Friedman MARS paper equation 56 + { + 0.1 * exp(4*x[,1]) + + 4 / (1 + exp(-20*(x[,2]-0.5))) + + 3 * x[,3] + + 2 * x[,4] + + x[,5] + } > neg.eqn56 <- function(x) + { + -eqn56(x) + } > > eqn56noise <- function(x) + { + set.seed(ncol(x)) + eqn56(x) + rnorm(nrow(x),0,1) + } > > neg.eqn56noise <- function(x) + { + -eqn56noise(x) + } > > robot.arm <- function(x) # Friedman Fast MARS paper + { + l1 <- x[,1] + l2 <- x[,2] + theta1 <- x[,3] + theta2 <- x[,4] + phi <- x[,5] + + x1 <- l1 * cos(theta1) - l2 * cos(theta1 + theta2) * cos(phi) + y <- l1 * sin(theta1) - l2 * sin(theta1 + theta2) * cos(phi) + z <- l2 * sin(theta2) * sin(phi) + + sqrt(x1^2 + y^2 + z^2) + } > x.global <- cbind( x1, x2, x3, x4, x5) > data.global <- cbind(eqn56=eqn56(x.global), neg.eqn56noise(x.global), x1, x2, x3, x4, x5) > colnames(data.global) = c("", "neg.eqn56noise", "x1", "x2", "x3", "x4", "x5") > itest <- itest+1; a <- test.two.responses(itest, eqn56, neg.eqn56noise, nk=51, degree=1) itest 8 multiple responses eqn56 neg.eqn56noise degree 1 nk 51 ===fite Selected 12 of 22 terms, and 5 of 5 predictors Termination condition: RSq changed by less than 0.001 at 22 terms Importance: x3, x2, x4, x1, x5 Number of terms at each degree of interaction: 1 11 (additive model) GCV RSS GRSq RSq data.global[,1:2][1] 0.1186568 7.035159 0.9859153 0.9914796 neg.eqn56noise 1.0576805 62.709877 0.8846994 0.9302502 All 1.1763373 69.745036 0.9331542 0.9595624 plotmo grid: x1 x2 x3 x4 x5 -0.02437858 0.03719751 -0.2437968 -0.07448578 -0.04164241 plotmo grid: x1 x2 x3 x4 x5 -0.02437858 0.03719751 -0.2437968 -0.07448578 -0.04164241 > print(evimp(a)) nsubsets gcv rss x3 11 100.0 100.0 x2 10 82.5 81.2 x4 9 59.0 57.8 x1 8 48.0 46.6 x5 6 33.7 32.2 > print.default(evimp(a)) col used nsubsets gcv gcv.match rss rss.match x3 3 1 11 100.00000 1 100.00000 1 x2 2 1 10 82.46294 1 81.21481 1 x4 4 1 9 58.98392 1 57.75405 1 x1 1 1 8 47.99407 1 46.58408 1 x5 5 1 6 33.69458 1 32.15406 1 attr(,"class") [1] "evimp" attr(,"sqrt") [1] TRUE > > x.global <- cbind( x1, x2, x3, x4, x5) > data.global <- cbind(eqn56=eqn56(x.global), neg.eqn56noise(x.global), x1, x2, x3, x4, x5) > colnames(data.global) = NULL > itest <- itest+1; a70 <- test.two.responses(itest, eqn56, neg.eqn56noise, nk=51, degree=2) itest 9 multiple responses eqn56 neg.eqn56noise degree 2 nk 51 ===fite Selected 11 of 36 terms, and 5 of 5 predictors Termination condition: RSq changed by less than 0.001 at 36 terms Importance: x3, x2, x4, x1, x5 Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq data.global[,1:2][1] 0.1491246 8.166063 0.9822988 0.9901100 data.global[,1:2][2] 1.2644713 69.242451 0.8621565 0.9229843 All 1.4135959 77.408514 0.9196719 0.9551192 plotmo grid: x1 x2 x3 x4 x5 -0.02437858 0.03719751 -0.2437968 -0.07448578 -0.04164241 plotmo grid: x1 x2 x3 x4 x5 -0.02437858 0.03719751 -0.2437968 -0.07448578 -0.04164241 > printh(summary(a70)) ===summary(a70) Call: earth(x=data.global[,c(-1,-2),drop=FALSE], y=data.global[,1:2], pmethod=pmethod, trace=trace, degree=degree, nk=nk, minspan=minspan) data.global[,1:2][1] data.global[,1:2][2] (Intercept) 0.2818910 -0.199523 h(0.565866-x1) -0.5573832 0.701461 h(x1-0.565866) 8.6735609 -6.756016 h(x2-0.266987) 5.6617262 -3.485078 h(x2-0.458619) 24.7167189 -41.977152 h(x2-0.516206) -26.6087010 42.046569 h(x3-0.109801) 2.5861859 -2.829496 h(0.26284-x3) -2.9626317 2.501109 h(-0.303396-x4) -3.1086768 3.484234 h(x4-0.124354) 2.6383691 -2.972662 h(x5- -0.859935) 0.9423879 -0.854188 Selected 11 of 36 terms, and 5 of 5 predictors Termination condition: RSq changed by less than 0.001 at 36 terms Importance: x3, x2, x4, x1, x5 Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq data.global[,1:2][1] 0.1491246 8.166063 0.9822988 0.9901100 data.global[,1:2][2] 1.2644713 69.242451 0.8621565 0.9229843 All 1.4135959 77.408514 0.9196719 0.9551192 > printh(summary(a70, style="bf")) ===summary(a70, style = "bf") Call: earth(x=data.global[,c(-1,-2),drop=FALSE], y=data.global[,1:2], pmethod=pmethod, trace=trace, degree=degree, nk=nk, minspan=minspan) data.global[,1:2][1] = 0.281891 - 0.5573832 * bf1 + 8.673561 * bf2 + 5.661726 * bf3 + 24.71672 * bf4 - 26.6087 * bf5 + 2.586186 * bf6 - 2.962632 * bf7 - 3.108677 * bf8 + 2.638369 * bf9 + 0.9423879 * bf10 bf1 h(0.565866-x1) bf2 h(x1-0.565866) bf3 h(x2-0.266987) bf4 h(x2-0.458619) bf5 h(x2-0.516206) bf6 h(x3-0.109801) bf7 h(0.26284-x3) bf8 h(-0.303396-x4) bf9 h(x4-0.124354) bf10 h(x5--0.859935) data.global[,1:2][2] = -0.1995226 + 0.7014611 * bf1 - 6.756016 * bf2 - 3.485078 * bf3 - 41.97715 * bf4 + 42.04657 * bf5 - 2.829496 * bf6 + 2.501109 * bf7 + 3.484234 * bf8 - 2.972662 * bf9 - 0.8541879 * bf10 bf1 h(0.565866-x1) bf2 h(x1-0.565866) bf3 h(x2-0.266987) bf4 h(x2-0.458619) bf5 h(x2-0.516206) bf6 h(x3-0.109801) bf7 h(0.26284-x3) bf8 h(-0.303396-x4) bf9 h(x4-0.124354) bf10 h(x5--0.859935) Selected 11 of 36 terms, and 5 of 5 predictors Termination condition: RSq changed by less than 0.001 at 36 terms Importance: x3, x2, x4, x1, x5 Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq data.global[,1:2][1] 0.1491246 8.166063 0.9822988 0.9901100 data.global[,1:2][2] 1.2644713 69.242451 0.8621565 0.9229843 All 1.4135959 77.408514 0.9196719 0.9551192 > > N1 <- 100 > set.seed(1) > x1. <- runif(N1, -1, 1) > x2. <- runif(N1, -1, 1) > x3. <- runif(N1, -1, 1) > x4. <- runif(N1, -1, 1) > x5. <- runif(N1, -1, 1) > > x.global <- cbind( (x1.+1)/2, (x2.+2)/2, pi*(x3.+1), pi*(x4.+1), pi*x5./2 ) > data.global <- cbind(robot.arm(x.global), eqn56(x.global), (x1.+1)/2, (x2.+2)/2, pi*(x3.+1), pi*(x4.+1), pi*x5./2 ) > colnames(x.global) <- c( "l1", "l2", "theta1", "theta2", "phi") > colnames(data.global) <- c("arm", "eqn56", "l1", "l2", "theta1", "theta2", "phi") > itest <- itest+1; test.two.responses(itest, robot.arm, eqn56, nk=51, degree=1) itest 10 multiple responses robot.arm eqn56 degree 1 nk 51 ===fite Selected 11 of 11 terms, and 5 of 5 predictors Termination condition: RSq changed by less than 0.001 at 11 terms Importance: theta1, theta2, l1, phi, l2 Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq arm 0.06212730 3.877365 0.6674660 0.7882518 eqn56 0.04559835 2.845793 0.9990475 0.9993935 All 0.10772566 6.723158 0.9977586 0.9985727 plotmo grid: l1 l2 theta1 theta2 phi 0.4878107 1.018599 2.375682 2.907589 -0.06541174 plotmo grid: l1 l2 theta1 theta2 phi 0.4878107 1.018599 2.375682 2.907589 -0.06541174 Selected 11 of 11 terms, and 5 of 5 predictors Termination condition: RSq changed by less than 0.001 at 11 terms Importance: theta1, theta2, l1, phi, l2 Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq arm 0.06212730 3.877365 0.6674660 0.7882518 eqn56 0.04559835 2.845793 0.9990475 0.9993935 All 0.10772566 6.723158 0.9977586 0.9985727 > itest <- itest+1; test.two.responses(itest, robot.arm, eqn56, nk=51, degree=2, test.mars.to.earth=TRUE) itest 11 multiple responses robot.arm eqn56 degree 2 nk 51 ===fite Selected 11 of 11 terms, and 5 of 5 predictors Termination condition: RSq changed by less than 0.001 at 11 terms Importance: theta1, theta2, l1, phi, l2 Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq arm 0.07080652 3.877365 0.6210109 0.7882518 eqn56 0.05196847 2.845793 0.9989145 0.9993935 All 0.12277499 6.723158 0.9974454 0.9985727 plotmo grid: l1 l2 theta1 theta2 phi 0.4878107 1.018599 2.375682 2.907589 -0.06541174 plotmo grid: l1 l2 theta1 theta2 phi 0.4878107 1.018599 2.375682 2.907589 -0.06541174 Testing mars.to.earth with a multiple response model Converted mars(x=data.global[,c(-1,-2),drop=FALSE], y=data.global[,1:2], degree=degree, nk=nk, trace.mars=(trace!=0)) to earth(x=data.global[,c(-1,-2),drop=FALSE], y=data.global[,1:2], degree=degree, nk=nk) ===fitme Selected 14 of 14 terms, and 5 of 5 predictors Termination condition: Unknown Importance: object has no prune.terms, call update() on the model to fix that Number of terms at each degree of interaction: 1 11 2 GCV RSS GRSq RSq arm 0.06354264 2.810014 0.6598905 0.8465412 eqn56 0.02822229 1.248060 0.9994105 0.9997340 All 0.09176492 4.058074 0.9997770 0.9998994 ===summary(fitme) Call: earth(x=data.global[,c(-1,-2),drop=FALSE], y=data.global[,1:2], degree=degree, nk=nk) arm eqn56 (Intercept) 1.21455366 17.9497354 h(l1-0.48208) 0.74838045 3.1350878 h(0.712515-l1) -0.29309259 -1.2345462 h(l1-0.712515) 0.45693753 8.6324286 h(0.689194-l2) -0.56638468 -6.5226645 h(l2-0.689194) 0.80658229 0.0048442 h(2.05469-theta1) 0.04949653 -2.9820177 h(theta1-2.05469) 0.01153761 3.0259557 h(3.53226-theta2) -0.14968401 -1.9869680 h(theta2-3.53226) -0.26441106 2.0236977 h(-0.0748075-phi) -0.14373035 -0.9622197 h(phi- -0.0748075) -0.22638721 0.9964946 h(0.48208-l1) -0.18021728 -0.0612455 h(l1-0.48208) * h(theta2-1.51306) -2.04353916 -0.4060211 Selected 14 of 14 terms, and 5 of 5 predictors Termination condition: Unknown Importance: object has no prune.terms, call update() on the model to fix that Number of terms at each degree of interaction: 1 11 2 GCV RSS GRSq RSq arm 0.06354264 2.810014 0.6598905 0.8465412 eqn56 0.02822229 1.248060 0.9994105 0.9997340 All 0.09176492 4.058074 0.9997770 0.9998994 plotmo grid: l1 l2 theta1 theta2 phi 0.4878107 1.018599 2.375682 2.907589 -0.06541174 plotmo grid: l1 l2 theta1 theta2 phi 0.4878107 1.018599 2.375682 2.907589 -0.06541174 Selected 11 of 11 terms, and 5 of 5 predictors Termination condition: RSq changed by less than 0.001 at 11 terms Importance: theta1, theta2, l1, phi, l2 Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq arm 0.07080652 3.877365 0.6210109 0.7882518 eqn56 0.05196847 2.845793 0.9989145 0.9993935 All 0.12277499 6.723158 0.9974454 0.9985727 > itest <- itest+1; test.two.responses(itest, robot.arm, eqn56, nk=201, degree=1) itest 12 multiple responses robot.arm eqn56 degree 1 nk 201 ===fite Selected 11 of 11 terms, and 5 of 5 predictors Termination condition: RSq changed by less than 0.001 at 11 terms Importance: theta1, theta2, l1, phi, l2 Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq arm 0.06212730 3.877365 0.6674660 0.7882518 eqn56 0.04559835 2.845793 0.9990475 0.9993935 All 0.10772566 6.723158 0.9977586 0.9985727 plotmo grid: l1 l2 theta1 theta2 phi 0.4878107 1.018599 2.375682 2.907589 -0.06541174 plotmo grid: l1 l2 theta1 theta2 phi 0.4878107 1.018599 2.375682 2.907589 -0.06541174 Selected 11 of 11 terms, and 5 of 5 predictors Termination condition: RSq changed by less than 0.001 at 11 terms Importance: theta1, theta2, l1, phi, l2 Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq arm 0.06212730 3.877365 0.6674660 0.7882518 eqn56 0.04559835 2.845793 0.9990475 0.9993935 All 0.10772566 6.723158 0.9977586 0.9985727 > itest <- itest+1; test.two.responses(itest, robot.arm, eqn56, nk=201, degree=2) itest 13 multiple responses robot.arm eqn56 degree 2 nk 201 ===fite Selected 11 of 11 terms, and 5 of 5 predictors Termination condition: RSq changed by less than 0.001 at 11 terms Importance: theta1, theta2, l1, phi, l2 Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq arm 0.07080652 3.877365 0.6210109 0.7882518 eqn56 0.05196847 2.845793 0.9989145 0.9993935 All 0.12277499 6.723158 0.9974454 0.9985727 plotmo grid: l1 l2 theta1 theta2 phi 0.4878107 1.018599 2.375682 2.907589 -0.06541174 plotmo grid: l1 l2 theta1 theta2 phi 0.4878107 1.018599 2.375682 2.907589 -0.06541174 Selected 11 of 11 terms, and 5 of 5 predictors Termination condition: RSq changed by less than 0.001 at 11 terms Importance: theta1, theta2, l1, phi, l2 Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq arm 0.07080652 3.877365 0.6210109 0.7882518 eqn56 0.05196847 2.845793 0.9989145 0.9993935 All 0.12277499 6.723158 0.9974454 0.9985727 > itest <- itest+1; test.two.responses(itest, robot.arm, eqn56, nk=201, degree=10) itest 14 multiple responses robot.arm eqn56 degree 10 nk 201 ===fite Selected 11 of 11 terms, and 5 of 5 predictors Termination condition: RSq changed by less than 0.001 at 11 terms Importance: theta1, theta2, l1, phi, l2 Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq arm 0.07080652 3.877365 0.6210109 0.7882518 eqn56 0.05196847 2.845793 0.9989145 0.9993935 All 0.12277499 6.723158 0.9974454 0.9985727 plotmo grid: l1 l2 theta1 theta2 phi 0.4878107 1.018599 2.375682 2.907589 -0.06541174 plotmo grid: l1 l2 theta1 theta2 phi 0.4878107 1.018599 2.375682 2.907589 -0.06541174 Selected 11 of 11 terms, and 5 of 5 predictors Termination condition: RSq changed by less than 0.001 at 11 terms Importance: theta1, theta2, l1, phi, l2 Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq arm 0.07080652 3.877365 0.6210109 0.7882518 eqn56 0.05196847 2.845793 0.9989145 0.9993935 All 0.12277499 6.723158 0.9974454 0.9985727 > > attach(ozone1) > x.global <- cbind( wind, humidity, temp, ibh, dpg, ibt, vis) > data.global <- cbind(O3, doy, vh, wind, humidity, temp, ibh, dpg, ibt, vis) > itest <- itest+1; test.two.responses(itest, "O3", "doy", nk=51, degree=2) itest 15 multiple responses O3 doy degree 2 nk 51 ===fite Selected 13 of 47 terms, and 8 of 8 predictors Termination condition: Reached nk 51 Importance: wind, vh, ibh, temp, dpg, vis, humidity, ibt Number of terms at each degree of interaction: 1 5 7 GCV RSS GRSq RSq O3 22.9046 6205.13 0.6442040 0.7061325 doy 6853.8813 1856799.52 0.3727883 0.4819583 All 6876.7859 1863004.66 0.3743779 0.4832712 Selected 13 of 47 terms, and 8 of 8 predictors Termination condition: Reached nk 51 Importance: wind, vh, ibh, temp, dpg, vis, humidity, ibt Number of terms at each degree of interaction: 1 5 7 GCV RSS GRSq RSq O3 22.9046 6205.13 0.6442040 0.7061325 doy 6853.8813 1856799.52 0.3727883 0.4819583 All 6876.7859 1863004.66 0.3743779 0.4832712 > detach(ozone1) > > cat("--- formula based multiple response -------------\n") --- formula based multiple response ------------- > > a2 <- earth(cbind(O3,doy) ~ ., data=ozone1, degree=2) > if (PLOT) { + plotmo(a2, nresponse=1, trace=-1) # TODO1 delete + plotmo(a2, nresponse=1, trace=-1) # test generation of caption based on response name + plotmo(a2, nresponse=2, trace=-1) + plot(a2, nresponse=1) # TODO delete + plot(a2, nresponse=1) + plot(a2, nresponse=2) + } > > cat("--- test plot.earth.models with multiple responses ---\n") --- test plot.earth.models with multiple responses --- > > set.seed(1) > a <- earth(O3 ~ ., data=ozone1, degree=2) > a2 <- earth(cbind(O3,doy) ~ ., data=ozone1, degree=2) > b2 <- earth(cbind(O3,doy) ~ ., data=ozone1, degree=1) > if (PLOT) { + plot.earth.models(list(a, a2), caption="plot.earth.models with multiple responses, list(a,a2)") + plot.earth.models(list(a2, a), caption="plot.earth.models with multiple responses, list(a2,a)", + col.rsq=c(2,3), col.npreds=c(2,3)) + plot.earth.models(list(a2, b2), caption="plot.earth.models with multiple responses, list(a2,b2)", + col.rsq=c(2,3), col.npreds=c(4,5), jitter=.01, legend.pos="topleft") + } > > cat("--- subset --------------------------------------\n") --- subset -------------------------------------- > > set.seed(9) > train.subset <- sample(1:nrow(ozone1), .8 * nrow(ozone1)) > test.subset <- (1:nrow(ozone1))[-train.subset] > > # all the following models should be identical > a <- earth(ozone1[,-1], ozone1[,1], subset=train.subset, nprune=7, degree=2) > printh(a) ===a Selected 7 of 21 terms, and 5 of 9 predictors Termination condition: Reached nk 21 Importance: temp, ibh, humidity, doy, dpg, vh-unused, wind-unused, ... Number of terms at each degree of interaction: 1 4 2 GCV 17.531 RSS 4084.192 GRSq 0.7243851 RSq 0.7549275 > if (PLOT) + plotmo(a, caption="test subset: earth(ozone1[,-1], ozone1[,1], subset=train.subset)", trace=-1) > > a <- earth(ozone1[train.subset,-1], ozone1[train.subset,1], nprune=7, degree=2) > printh(a) ===a Selected 7 of 21 terms, and 5 of 9 predictors Termination condition: Reached nk 21 Importance: temp, ibh, humidity, doy, dpg, vh-unused, wind-unused, ... Number of terms at each degree of interaction: 1 4 2 GCV 17.531 RSS 4084.192 GRSq 0.7243851 RSq 0.7549275 > if (PLOT) + plotmo(a, caption="test subset: earth(ozone1[train.subset,-1], ozone1[train.subset,1]", trace=-1) > > a <- earth(O3 ~ ., data=ozone1, subset=train.subset, nprune=7, degree=2) > printh(a) ===a Selected 7 of 21 terms, and 5 of 9 predictors Termination condition: Reached nk 21 Importance: temp, ibh, humidity, doy, dpg, vh-unused, wind-unused, ... Number of terms at each degree of interaction: 1 4 2 GCV 17.531 RSS 4084.192 GRSq 0.7243851 RSq 0.7549275 > if (PLOT) + plotmo(a, caption="test subset: earth(O3 ~ ., data=ozone1, subset=train.subset", trace=-1) > > y <- ozone1[test.subset, 1] > yhat <- predict(a, newdata = ozone1[test.subset, -1]) > printh(1 - sum((y - yhat)^2)/sum((y - mean(y))^2)) # print RSquared ===1 - sum((y - yhat)^2)/sum((y - mean(y))^2) [1] 0.7922595 > > cat("--- update -------------------------\n") --- update ------------------------- > > a <- earth(O3 ~ ., data=ozone1, degree=2) > printh(update(a, penalty = -1, ponly=TRUE)) ===update(a, penalty = -1, ponly = TRUE) Selected 21 of 21 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, ibh, dpg, vis, wind, vh Number of terms at each degree of interaction: 1 10 10 GCV 10.85657 RSS 3582.667 GRSq 0.8303292 RSq 0.8303292 > printh(update(a, penalty = 10, ponly=TRUE)) ===update(a, penalty = 10, ponly = TRUE) Selected 11 of 21 terms, and 8 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, ibh, dpg, vis, wind, vh-unused Number of terms at each degree of interaction: 1 5 5 GCV 17.30867 RSS 3795.372 GRSq 0.7311301 RSq 0.8202558 > a <- earth(O3 ~ ., data=ozone1, nk=31, pmethod="n", degree=2) > a.none <- printh(update(a, nprune=10, pmethod="n")) ===update(a, nprune = 10, pmethod = "n") Selected 10 of 31 terms, and 5 of 9 predictors (pmethod="none") Termination condition: Reached nk 31 Importance: temp, ibt-unused, humidity, doy, dpg, vis-unused, wind-unused, ... Number of terms at each degree of interaction: 1 6 3 GCV 14.03861 RSS 3996.421 GRSq 0.7819266 RSq 0.8107343 > printh(update(a.none, pmethod="b")) ===update(a.none, pmethod = "b") Selected 10 of 31 terms, and 8 of 9 predictors Termination condition: Reached nk 31 Importance: temp, ibt, humidity, doy, dpg, vis, wind, ibh, vh-unused Number of terms at each degree of interaction: 1 5 4 GCV 14.03861 RSS 3996.421 GRSq 0.7819266 RSq 0.8107343 > printh(update(a.none, nprune=4, pmethod="e")) ===update(a.none, nprune = 4, pmethod = "e") Selected 4 of 31 terms, and 3 of 9 predictors (pmethod="exhaustive") Termination condition: Reached nk 31 Importance: temp, ibh, humidity, vh-unused, wind-unused, dpg-unused, ... Number of terms at each degree of interaction: 1 2 1 GCV 18.56782 RSS 5815.792 GRSq 0.7115708 RSq 0.7245711 > a.updated <- update(a.none, nprune=10, pmethod="b") > printh(a.updated) ===a.updated Selected 10 of 31 terms, and 8 of 9 predictors Termination condition: Reached nk 31 Importance: temp, ibt, humidity, doy, dpg, vis, wind, ibh, vh-unused Number of terms at each degree of interaction: 1 5 4 GCV 14.03861 RSS 3996.421 GRSq 0.7819266 RSq 0.8107343 > a.backwards <- update(a, nprune=10, pmethod="b") > printh(a.backwards) ===a.backwards Selected 10 of 31 terms, and 8 of 9 predictors Termination condition: Reached nk 31 Importance: temp, ibt, humidity, doy, dpg, vis, wind, ibh, vh-unused Number of terms at each degree of interaction: 1 5 4 GCV 14.03861 RSS 3996.421 GRSq 0.7819266 RSq 0.8107343 > printh(all.equal(a.updated$bx, a.backwards$bx)) ===all.equal(a.updated$bx, a.backwards$bx) [1] TRUE > a <- earth(O3 ~ ., data=ozone1, nk=31, nprune=10, pmethod="b", degree=2) > printh(a) ===a Selected 10 of 31 terms, and 8 of 9 predictors Termination condition: Reached nk 31 Importance: temp, ibt, humidity, doy, dpg, vis, wind, ibh, vh-unused Number of terms at each degree of interaction: 1 5 4 GCV 14.03861 RSS 3996.421 GRSq 0.7819266 RSq 0.8107343 > printh(all.equal(a$bx, a.backwards$bx)) ===all.equal(a$bx, a.backwards$bx) [1] TRUE > > cat("--- Auto.linpreds -----------------------------\n") --- Auto.linpreds ----------------------------- > > set.seed(2017) > x1 <- runif(10) > x2 <- runif(10) > y <- x1 + x2 > data=data.frame(x1=x1, x2=x2, y=y) > OLD.PAR <- par(no.readonly=TRUE) > par(mfrow = c(6, 4), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > > expect.err(try(earth(y~., data=data, Auto.linpr=99)), "Auto.linpreds=99 but it should be FALSE, TRUE, 0, or 1") Error : Auto.linpreds=99 but it should be FALSE, TRUE, 0, or 1 Got error as expected from try(earth(y ~ ., data = data, Auto.linpr = 99)) > > a <- earth(y~., data=data, trace=2) # default Auto.linpreds=TRUE x[10,2] with colnames x1 x2 y[10,1] with colname y, and values 1.599, 0.5392, 0.4943, 0.7207... Forward pass: minspan 3 endspan 4 x[10,2] 160 Bytes bx[10,21] 1.64 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 -0.3656 0.5785 0.5785 2 x2 0.43208 2 3 1 4 1.0000 1.0000 0.4215 1 x1 0.039322< 4 1 final (max RSq) Reached maximum RSq 0.9990 at 5 terms, 4 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 5 terms, 4 terms used Prune backward penalty 2 nprune null: selected 4 of 4 terms, and 2 of 2 preds After pruning pass GRSq 1 RSq 1 > print(summary(a, style="pmax")) Call: earth(formula=y~., data=data, trace=2) y = 0.4320778 + 1 * x1 - 1 * pmax(0, 0.4320778 - x2) + 1 * pmax(0, x2 - 0.4320778) Selected 4 of 4 terms, and 2 of 2 predictors Termination condition: Reached maximum RSq 0.9990 at 4 terms Importance: x2, x1 Number of terms at each degree of interaction: 1 3 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > plotmo(a, extend=.3, ylim=c(.2, 1.7), + do.par=FALSE, pt.col=2, jitter=0, + main=c("default Auto.linpreds=T", "")) plotmo grid: x1 x2 0.470681 0.4657348 > empty.plot() > empty.plot() > > a1 <- earth(y~., data=data, trace=2, Auto.linpreds=FALSE) x[10,2] with colnames x1 x2 y[10,1] with colname y, and values 1.599, 0.5392, 0.4943, 0.7207... Forward pass: minspan 3 endspan 4 x[10,2] 160 Bytes bx[10,21] 1.64 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 -0.3656 0.5785 0.5785 2 x2 0.43208 2 3 1 4 1.0000 1.0000 0.4215 1 x1 0.039322< 4 1 final (max RSq) Reached maximum RSq 0.9990 at 5 terms, 4 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 5 terms, 4 terms used Prune backward penalty 2 nprune null: selected 4 of 4 terms, and 2 of 2 preds After pruning pass GRSq 1 RSq 1 > print(summary(a1, style="pmax")) Call: earth(formula=y~., data=data, trace=2, Auto.linpreds=FALSE) y = 0.4714001 + 1 * pmax(0, x1 - 0.03932234) - 1 * pmax(0, 0.4320778 - x2) + 1 * pmax(0, x2 - 0.4320778) Selected 4 of 4 terms, and 2 of 2 predictors Termination condition: Reached maximum RSq 0.9990 at 4 terms Importance: x2, x1 Number of terms at each degree of interaction: 1 3 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > plotmo(a1, extend=.3, ylim=c(.2, 1.7), + do.par=FALSE, pt.col=2, jitter=0, + main=c("Auto.linpreds=F", "")) plotmo grid: x1 x2 0.470681 0.4657348 > empty.plot() > empty.plot() > stopifnot(isTRUE(all.equal(predict(a), predict(a1)))) > > a2 <- earth(y~., data=data, trace=2, linpreds=TRUE, Auto.linpreds=FALSE) x[10,2] with colnames x1 x2 y[10,1] with colname y, and values 1.599, 0.5392, 0.4943, 0.7207... Linear predictors 1=x1 2=x2 Forward pass: minspan 3 endspan 4 x[10,2] 160 Bytes bx[10,21] 1.64 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.3033 0.5785 0.5785 2 x2 0.0020208< 2 1 4 1.0000 1.0000 0.4215 1 x1 0.039322< 3 1 final (max RSq) Reached maximum RSq 0.9990 at 5 terms, 3 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 5 terms, 3 terms used Prune backward penalty 2 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 1 RSq 1 > print(summary(a2, style="pmax")) Call: earth(formula=y~., data=data, trace=2, linpreds=TRUE, Auto.linpreds=FALSE) y = -0 + 1 * x1 + 1 * x2 Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: Reached maximum RSq 0.9990 at 3 terms Importance: x2, x1 Number of terms at each degree of interaction: 1 2 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > plotmo(a2, extend=.3, ylim=c(.2, 1.7), + do.par=FALSE, pt.col=2, jitter=0, + main=c("linpreds=T, Auto.linpreds=F", "")) plotmo grid: x1 x2 0.470681 0.4657348 > empty.plot() > empty.plot() > stopifnot(isTRUE(all.equal(predict(a), predict(a2)))) > > a3 <- earth(y~., data=data, linpreds="x1", Auto.linpreds=FALSE) > print(summary(a3, style="pmax")) Call: earth(formula=y~., data=data, linpreds="x1", Auto.linpreds=FALSE) y = 0.4320778 + 1 * x1 - 1 * pmax(0, 0.4320778 - x2) + 1 * pmax(0, x2 - 0.4320778) Selected 4 of 4 terms, and 2 of 2 predictors Termination condition: Reached maximum RSq 0.9990 at 4 terms Importance: x2, x1 Number of terms at each degree of interaction: 1 3 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > plotmo(a3, extend=.3, ylim=c(.2, 1.7), + do.par=FALSE, pt.col=2, jitter=0, + main=c("linpreds=x1, Auto.linpreds=F", "")) plotmo grid: x1 x2 0.470681 0.4657348 > empty.plot() > empty.plot() > stopifnot(isTRUE(all.equal(predict(a), predict(a3)))) > > a4 <- earth(y~., data=data, linpreds="x2", Auto.linpreds=FALSE) > print(summary(a4, style="pmax")) Call: earth(formula=y~., data=data, linpreds="x2", Auto.linpreds=FALSE) y = 0.03932234 + 1 * x2 + 1 * pmax(0, x1 - 0.03932234) Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: Reached maximum RSq 0.9990 at 3 terms Importance: x2, x1 Number of terms at each degree of interaction: 1 2 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > plotmo(a4, extend=.3, ylim=c(.2, 1.7), + do.par=FALSE, pt.col=2, jitter=0, + main=c("linpreds=x2, Auto.linpreds=F", "")) plotmo grid: x1 x2 0.470681 0.4657348 > empty.plot() > empty.plot() > stopifnot(isTRUE(all.equal(predict(a), predict(a4)))) > > # x,y interface > a5 <- earth(data[,1:2], data[,3], Auto.linpreds=FALSE) > print(summary(a5, style="pmax")) Call: earth(x=data[,1:2], y=data[,3], Auto.linpreds=FALSE) data[,3] = 0.4714001 + 1 * pmax(0, x1 - 0.03932234) - 1 * pmax(0, 0.4320778 - x2) + 1 * pmax(0, x2 - 0.4320778) Selected 4 of 4 terms, and 2 of 2 predictors Termination condition: Reached maximum RSq 0.9990 at 4 terms Importance: x2, x1 Number of terms at each degree of interaction: 1 3 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > plotmo(a5, extend=.3, ylim=c(.2, 1.7), + do.par=FALSE, pt.col=2, jitter=0, + main=c("x,y interface", "")) plotmo grid: x1 x2 0.470681 0.4657348 > empty.plot() > empty.plot() > stopifnot(isTRUE(all.equal(as.vector(predict(a1)), as.vector(predict(a5))))) > par(OLD.PAR) > > # more complicated example (with Auto.linpreds=TRUE, vh enters linearly in a degree2 term) > data(ozone1) > oz <- ozone1[1:50,] > mod.none1 <- earth(O3~., data=oz, degree=2, nk=15, pmethod="none") # default Auto.linpreds=TRUE > print(summary(mod.none1)) Call: earth(formula=O3~., data=oz, pmethod="none", degree=2, nk=15) coefficients (Intercept) 4.2036778 h(5720-vh) 0.0331735 h(vh-5720) 0.0145381 h(4-wind) 1.1184678 h(wind-4) 0.1767766 h(28-humidity) -0.1729997 h(humidity-28) -7.3870298 h(174-ibt) -0.0109694 h(ibt-174) -0.0151749 h(45-doy) -0.0433483 h(doy-45) 0.1827167 h(doy-61) -0.2544981 vh * h(humidity-28) 0.0012973 Selected 13 of 13 terms, and 5 of 9 predictors (pmethod="none") Termination condition: Reached nk 15 Importance: humidity, vh, doy, wind, ibt, temp-unused, ibh-unused, ... Number of terms at each degree of interaction: 1 11 1 GCV 7.21889 RSS 52.12038 GRSq -0.05294658 RSq 0.8416852 > mod.none2 <- earth(O3~., data=oz, degree=2, nk=15, pmethod="none", Auto.linpreds=FALSE) > print(summary(mod.none2)) Call: earth(formula=O3~., data=oz, pmethod="none", degree=2, nk=15, Auto.linpreds=FALSE) coefficients (Intercept) 4.2036778 h(5720-vh) 0.0331735 h(vh-5720) 0.0145381 h(4-wind) 1.1184678 h(wind-4) 0.1767766 h(28-humidity) -0.1729997 h(humidity-28) -0.4464325 h(174-ibt) -0.0109694 h(ibt-174) -0.0151749 h(45-doy) -0.0433483 h(doy-45) 0.1827167 h(doy-61) -0.2544981 h(vh-5350) * h(humidity-28) 0.0012973 Selected 13 of 13 terms, and 5 of 9 predictors (pmethod="none") Termination condition: Reached nk 15 Importance: humidity, vh, doy, wind, ibt, temp-unused, ibh-unused, ... Number of terms at each degree of interaction: 1 11 1 GCV 7.21889 RSS 52.12038 GRSq -0.05294658 RSq 0.8416852 > stopifnot(all.equal(predict(mod.none1), predict(mod.none2))) > > # example figure in inst/doc > OLD.PAR <- par(no.readonly=TRUE) > par(mfrow=c(2,2), mar=c(4, 3.2, 3, 3), mgp=c(1.6, 0.6, 0), par(cex = 0.7)) > set.seed(2017) > offset <- 98 > data.autolin <- data.frame(x=offset+(1:10), y=offset+(1:10)) > autolinFALSE <- earth(y~x, data=data.autolin, Auto.linpreds=FALSE) > print(summary(autolinFALSE, style="max")) Call: earth(formula=y~x, data=data.autolin, Auto.linpreds=FALSE) y = 99 + 1 * max(0, x - 99) Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: Reached maximum RSq 0.9990 at 2 terms Importance: x Number of terms at each degree of interaction: 1 1 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > set.seed(2017) # for same jitter on this and previous graph > plotmo(autolinFALSE, extend=.3, do.par=FALSE, pt.col="red", lwd=2, + main="Auto.linpreds = FALSE", + xaxt="n", yaxt="n", jitter=1, cex.main=1, + xlim=offset+c(-2,13), ylim=offset+c(-3,13)) > legend(x="topleft", legend=c("data", "earth model"), + lty=c(0, 1), lwd=c(0, 2), pch=c(20, NA), col=c("red", 1)) > text(x=offset+3.8, y=offset-1.2, cex=.9, "The knot happens to be at the") > text(x=offset+4, y=offset-2.4, cex=.9, "minimum value of the predictor") > > autolinTRUE <- earth(y~x, data=data.autolin) # default Auto.linpreds=TRUE > print(summary(autolinTRUE, style="max")) Call: earth(formula=y~x, data=data.autolin) y = -0 + 1 * x Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: Reached maximum RSq 0.9990 at 2 terms Importance: x Number of terms at each degree of interaction: 1 1 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > set.seed(2017) # for same jitter on this and next graph > plotmo(autolinTRUE, extend=.3, do.par=FALSE, pt.col="red", lwd=2, + main="Auto.linpreds = TRUE (default)", + xaxt="n", yaxt="n", jitter=1, cex.main=1, + xlim=offset+c(-2,13), ylim=offset+c(-3,13)) > legend(x="topleft", legend=c("data", "earth model"), + lty=c(0, 1), lwd=c(0, 2), pch=c(20, NA), col=c("red", 1)) > text(x=offset+4, y=offset-2.4, cex=.9, "Same data as previous graph") > stopifnot(isTRUE(all.equal(predict(autolinTRUE), predict(autolinFALSE)))) > par(OLD.PAR) > > # test Auto.linpreds with data sent in by a user > ndata <- matrix(data=c( + -0.0781, -0.6109, -0.216, -1.5172, 0.8184, -1.1242, + -0.0781, -0.5885, -0.216, -1.3501, 0.8184, -0.8703, + -0.0781, -0.5885, -0.216, -1.3501, 0.8184, -0.9549, + -0.0781, -0.5885, -0.216, -1.3501, 1.4136, -0.8703, + -2.5759, -0.5885, 1.1665, -1.3501, 2.0089, -0.9549, + -2.5759, -0.5885, 1.1665, -1.3501, 2.0089, -0.8703, + -0.0781, -0.4937, -0.216, -0.9949, -0.372, -1.0396, + -0.0781, -0.4463, -0.216, -0.8278, -0.372, -0.447, + -0.0781, -0.4463, -0.216, -0.8278, -0.372, -0.701, + -0.0781, -0.4463, -0.216, -0.8278, -0.372, -0.6163, + -0.0781, -0.4463, -0.216, -0.8278, 0.8184, -0.447, + -0.0781, -0.4463, -0.216, -0.8278, 0.8184, -0.6163, + -0.0781, -0.4463, 1.1665, -0.8278, 0.8184, -0.447, + -0.0781, -0.4379, 1.1665, 0.2585, -0.372, -0.1085, + -0.0781, -0.2147, 1.1665, 0.0496, -0.372, -0.1085, + -0.0781, -0.2147, -0.216, 0.2585, -0.372, -0.0238, + -0.0781, -0.1589, -0.216, 0.2585, -0.372, -0.1931, + -0.0781, -0.1589, -0.216, 0.2585, -0.372, -0.1085, + -0.0781, -0.1589, 1.1665, 0.2585, -0.372, -0.1931, + -0.0781, -0.1589, -0.216, 0.2585, 0.8184, -0.1085, + -0.0781, -0.1589, -0.216, 0.2585, 0.8184, 0.0608, + -0.0781, -0.1589, -0.216, 1.0942, 0.8184, -0.0238, + -0.0781, 0.0643, 1.1665, 1.0942, -0.372, 0.2301, + -0.0781, 0.0643, -0.216, 1.0942, -1.5624, 0.3148, + -0.0781, 0.0643, -0.216, 1.0942, -0.9672, 0.1455, + -0.0781, 0.0643, 1.1665, 1.4284, 0.2232, 0.4841, + -0.0781, 0.1563, -0.216, 1.0942, -0.372, 0.5687, + 2.4197, 0.3432, -0.216, 1.0942, -1.5624, 1.0766, + -0.0781, 0.3432, -0.216, 1.0942, -1.5624, 1.1613, + -0.0781, 0.3432, 1.1665, 1.0942, 0.2232, 0.738, + 2.4197, 2.7145, -2.9811, 1.0942, -1.5624, 2.5156, + 2.4197, 4.3884, -2.9811, 1.0942, -1.5624, 3.5314), + ncol=6) > colnames(ndata) <- c("x1", "x2", "x3", "x4", "x5", "y") > ndata <- as.data.frame(ndata) > > cat("Auto.linpreds=TRUE pmethod=\"none\":\n") Auto.linpreds=TRUE pmethod="none": > auto.linpreds.true.pmethod.none <- earth(y~., data=ndata, degree=2, nk=21, trace=2, pmethod="none") x[32,5] with colnames x1 x2 x3 x4 x5 y[32,1] with colname y, and values -0.372, 0.5687, 2.42, 0.3432,... Forward pass: minspan 4 endspan 9 x[32,5] 1.25 kB bx[32,21] 5.25 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0583 0.3376 0.3376 1 x1 -0.9549 2 3 1 4 -0.2012 0.4488 0.1112 3 x3 -0.0781 4 5 1 6 -0.1801 0.5797 0.131 4 x4 -0.372< 6 2 2 8 -0.2458 0.6681 0.08841 3 x3 -0.8278< 7 2 2 10 -0.4175 0.7312 0.06304 3 x3 -0.8278< 8 3 2 12 -0.8452 0.7677 0.03649 1 x1 -0.216 9 1 14 -1.7625 0.7923 0.02464 1 x1 -2.5759< 10 4 2 16 -13.8221 0.8111 0.01875 2 x2 -0.216 11 12 1 reject (negative GRSq) Reached minimum GRSq -10 at 15 terms, 10 terms used (GRSq -14) After forward pass GRSq -13.822 RSq 0.811 Forward pass complete: 15 terms, 10 terms used Prune none penalty 3 nprune null: selected 10 of 10 terms, and 3 of 5 preds After pruning pass GRSq -1.76 RSq 0.792 > print(summary(auto.linpreds.true.pmethod.none, decomp="none")) Call: earth(formula=y~., data=ndata, pmethod="none", trace=2, degree=2, nk=21) coefficients (Intercept) 2.4332961 h(x1- -0.9549) -0.9865989 h(-0.9549-x1) 6.9070794 h(x3- -0.0781) -8.9336500 h(-0.0781-x3) 0.0165408 h(x1- -0.9549) * x4 -1.2581107 h(x1- -0.9549) * x3 6.4769097 h(-0.9549-x1) * x3 25.0101165 h(x1- -0.216) 1.8627919 x1 * h(x3- -0.0781) -5.5959046 Selected 10 of 10 terms, and 3 of 5 predictors (pmethod="none") Termination condition: GRSq -10 at 10 terms Importance: x1, x4, x3, x2-unused, x5-unused Number of terms at each degree of interaction: 1 5 4 GCV 8.371258 RSS 18.90073 GRSq -1.762519 RSq 0.792308 > cat("\nAuto.linpreds=FALSE pmethod=\"none\":\n") Auto.linpreds=FALSE pmethod="none": > auto.linpreds.false.pmethod.none <- earth(y~., data=ndata, degree=2, nk=21, trace=2, Auto.linpreds=FALSE, pmethod="none") x[32,5] with colnames x1 x2 x3 x4 x5 y[32,1] with colname y, and values -0.372, 0.5687, 2.42, 0.3432,... Forward pass: minspan 4 endspan 9 x[32,5] 1.25 kB bx[32,21] 5.25 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0583 0.3376 0.3376 1 x1 -0.9549 2 3 1 4 -0.2012 0.4488 0.1112 3 x3 -0.0781 4 5 1 6 -0.1801 0.5797 0.131 4 x4 -0.372< 6 2 2 8 -0.2458 0.6681 0.08841 3 x3 -0.8278< 7 2 2 10 -0.4175 0.7312 0.06304 3 x3 -0.8278< 8 3 2 12 -0.8452 0.7677 0.03649 1 x1 -0.216 9 1 14 -1.7625 0.7923 0.02464 1 x1 -2.5759< 10 5 2 16 -13.8221 0.8111 0.01875 2 x2 -0.216 11 12 1 reject (negative GRSq) Reached minimum GRSq -10 at 15 terms, 12 terms used (GRSq -14) After forward pass GRSq -13.822 RSq 0.811 Forward pass complete: 15 terms, 12 terms used Fixed rank deficient bx by removing 2 terms, 10 terms remain Prune none penalty 3 nprune null: selected 10 of 10 terms, and 3 of 5 preds After pruning pass GRSq -1.76 RSq 0.792 > print(summary(auto.linpreds.false.pmethod.none, decomp="none")) Call: earth(formula=y~., data=ndata, pmethod="none", trace=2, degree=2, nk=21, Auto.linpreds=FALSE) coefficients (Intercept) 2.433296 h(x1- -0.9549) -1.684918 h(-0.9549-x1) -17.991545 h(x3- -0.0781) -3.590121 h(-0.0781-x3) 9.087502 h(x1- -0.9549) * h(x4- -0.372) -1.258111 h(x1- -0.9549) * h(x3- -0.8278) 0.881005 h(-0.9549-x1) * h(x3- -0.8278) 30.606021 h(x1- -0.216) 1.862792 h(x1- -2.5759) * h(-0.0781-x3) -5.595905 Selected 10 of 10 terms, and 3 of 5 predictors (pmethod="none") Termination condition: GRSq -10 at 10 terms Importance: x1, x4, x3, x2-unused, x5-unused Number of terms at each degree of interaction: 1 5 4 GCV 8.371258 RSS 18.90073 GRSq -1.762519 RSq 0.792308 > stopifnot(isTRUE(all.equal(predict(auto.linpreds.true.pmethod.none), predict(auto.linpreds.false.pmethod.none)))) > > cat("\nAuto.linpreds=TRUE:\n") Auto.linpreds=TRUE: > auto.linpreds.true <- earth(y~., data=ndata, degree=2, nk=21, trace=2) x[32,5] with colnames x1 x2 x3 x4 x5 y[32,1] with colname y, and values -0.372, 0.5687, 2.42, 0.3432,... Forward pass: minspan 4 endspan 9 x[32,5] 1.25 kB bx[32,21] 5.25 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0583 0.3376 0.3376 1 x1 -0.9549 2 3 1 4 -0.2012 0.4488 0.1112 3 x3 -0.0781 4 5 1 6 -0.1801 0.5797 0.131 4 x4 -0.372< 6 2 2 8 -0.2458 0.6681 0.08841 3 x3 -0.8278< 7 2 2 10 -0.4175 0.7312 0.06304 3 x3 -0.8278< 8 3 2 12 -0.8452 0.7677 0.03649 1 x1 -0.216 9 1 14 -1.7625 0.7923 0.02464 1 x1 -2.5759< 10 4 2 16 -13.8221 0.8111 0.01875 2 x2 -0.216 11 12 1 reject (negative GRSq) Reached minimum GRSq -10 at 15 terms, 10 terms used (GRSq -14) After forward pass GRSq -13.822 RSq 0.811 Forward pass complete: 15 terms, 10 terms used Prune backward penalty 3 nprune null: selected 4 of 10 terms, and 3 of 5 preds After pruning pass GRSq 0.209 RSq 0.546 > print(summary(auto.linpreds.true, decomp="none")) Call: earth(formula=y~., data=ndata, trace=2, degree=2, nk=21) coefficients (Intercept) 1.371239 h(x3- -0.0781) -1.882810 h(x1- -0.9549) * x4 -1.413220 h(-0.9549-x1) * x3 4.319452 Selected 4 of 10 terms, and 3 of 5 predictors Termination condition: GRSq -10 at 10 terms Importance: x1, x4, x3, x2-unused, x5-unused Number of terms at each degree of interaction: 1 1 2 GCV 2.396481 RSS 41.35802 GRSq 0.20916 RSq 0.5455344 > cat("\nAuto.linpreds=FALSE:\n") Auto.linpreds=FALSE: > auto.linpreds.false <- earth(y~., data=ndata, degree=2, nk=21, trace=2, Auto.linpreds=FALSE) x[32,5] with colnames x1 x2 x3 x4 x5 y[32,1] with colname y, and values -0.372, 0.5687, 2.42, 0.3432,... Forward pass: minspan 4 endspan 9 x[32,5] 1.25 kB bx[32,21] 5.25 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0583 0.3376 0.3376 1 x1 -0.9549 2 3 1 4 -0.2012 0.4488 0.1112 3 x3 -0.0781 4 5 1 6 -0.1801 0.5797 0.131 4 x4 -0.372< 6 2 2 8 -0.2458 0.6681 0.08841 3 x3 -0.8278< 7 2 2 10 -0.4175 0.7312 0.06304 3 x3 -0.8278< 8 3 2 12 -0.8452 0.7677 0.03649 1 x1 -0.216 9 1 14 -1.7625 0.7923 0.02464 1 x1 -2.5759< 10 5 2 16 -13.8221 0.8111 0.01875 2 x2 -0.216 11 12 1 reject (negative GRSq) Reached minimum GRSq -10 at 15 terms, 12 terms used (GRSq -14) After forward pass GRSq -13.822 RSq 0.811 Forward pass complete: 15 terms, 12 terms used Fixed rank deficient bx by removing 2 terms, 10 terms remain Prune backward penalty 3 nprune null: selected 5 of 10 terms, and 3 of 5 preds After pruning pass GRSq 0.223 RSq 0.643 > print(summary(auto.linpreds.false, decomp="none")) Call: earth(formula=y~., data=ndata, trace=2, degree=2, nk=21, Auto.linpreds=FALSE) coefficients (Intercept) 1.635321 h(-0.9549-x1) -12.155291 h(x3- -0.0781) -1.555091 h(x1- -0.9549) * h(x4- -0.372) -1.220702 h(-0.9549-x1) * h(x3- -0.8278) 22.975120 Selected 5 of 10 terms, and 3 of 5 predictors Termination condition: GRSq -10 at 10 terms Importance: x1, x4, x3, x2-unused, x5-unused Number of terms at each degree of interaction: 1 2 2 GCV 2.354961 RSS 32.4543 GRSq 0.2228618 RSq 0.6433736 > # following fails because of different pruning because of different term count > # stopifnot(isTRUE(all.equal(predict(auto.linpreds.true), predict(auto.linpreds.false)))) > > cat("--- Force.xtx.prune -----------------------------\n") --- Force.xtx.prune ----------------------------- > > expect.err(try(earth(Volume ~ ., data = trees, Force.xtx.prune=TRUE, pmethod="ex")), "not allowed with") # pmethod="ex" cannot be used with Force.xtx.prune Error : pmethod="exhaustive" is not allowed with 'eval.subsets.xtx' Got error as expected from try(earth(Volume ~ ., data = trees, Force.xtx.prune = TRUE, pmethod = "ex")) > > m1 <- earth(Volume ~ ., data = trees) > m2 <- earth(Volume ~ ., data = trees, Force.xtx.prune=TRUE) > check.models.equal(m1, m2, "Force.xtx.prune test 1", check.subsets=FALSE, newdata=data.frame(Height=10, Girth=12)) Force.xtx.prune test 1: models not identical mod1$rsq 0.9742029 != mod2$rsq 0.9742029 (although almost equal) Force.xtx.prune test 1: Models are equivalent, within numerical tolerances > > m1 <- earth(O3 ~ wind+temp, data = ozone1, nk=51) > m2 <- earth(O3 ~ wind+temp, data = ozone1, nk=51, Force.xtx.prune=TRUE) > check.models.equal(m1, m2, "Force.xtx.prune test 2", check.subsets=FALSE, newdata=ozone1[5:7,]) Force.xtx.prune test 2: models not identical mod1$rsq 0.6647086 != mod2$rsq 0.6647086 (although almost equal) Force.xtx.prune test 2: Models are equivalent, within numerical tolerances > > # TODO The following exposes a bug in leaps(?). It is described in > # check.one.term.per.step in the earth R code. The test is commented out > # because this bug causes a discrepancy with Force.xtx.prune (although > # usually the bug does not cause any problems). > # > # m1 <- earth(O3 ~ ., data = ozone1, nk=51, degree=2, trace=5) > # m2 <- earth(O3 ~ ., data = ozone1, nk=51, degree=2, Force.xtx.prune=TRUE) > # check.models.equal(m1, m2, "Force.xtx.prune test 3", check.subsets=FALSE) > > cat("--- extractAIC.earth ----------------------------\n") --- extractAIC.earth ---------------------------- > > a <-earth(O3 ~ ., data=ozone1, degree=2) > cat("Ignore 10 warnings: extractAIC.earth: using GCV instead of AIC\n") Ignore 10 warnings: extractAIC.earth: using GCV instead of AIC > printh(drop1(a), expect.warning=TRUE) ===drop1(a) expect warning -->Warning: extractAIC.earth: returning GCV instead of AIC Warning: extractAIC.earth: returning GCV instead of AIC Warning: extractAIC.earth: returning GCV instead of AIC Warning: extractAIC.earth: returning GCV instead of AIC Warning: extractAIC.earth: returning GCV instead of AIC Warning: extractAIC.earth: returning GCV instead of AIC Warning: extractAIC.earth: returning GCV instead of AIC Warning: extractAIC.earth: returning GCV instead of AIC Warning: extractAIC.earth: returning GCV instead of AIC Warning: extractAIC.earth: returning GCV instead of AIC Single term deletions Model: O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis + doy Df AIC 13.408 vh 0.0 13.486 wind 2.5 13.887 humidity -10.0 15.191 temp -7.5 13.016 ibh 0.0 12.836 dpg 0.0 14.800 ibt -7.5 13.736 vis -7.5 14.785 doy -2.5 15.353 > printh(drop1(a, warn=FALSE)) # repeat but with warnings suppressed ===drop1(a, warn = FALSE) Single term deletions Model: O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis + doy Df AIC 13.408 vh 0.0 13.486 wind 2.5 13.887 humidity -10.0 15.191 temp -7.5 13.016 ibh 0.0 12.836 dpg 0.0 14.800 ibt -7.5 13.736 vis -7.5 14.785 doy -2.5 15.353 > > cat("--- fda and mda with earth -----------------------------------\n") --- fda and mda with earth ----------------------------------- > > am <- fda(Species ~ ., data=iris, method=mars, degree=1, keepxy=TRUE) > printh(am) ===am Call: fda(formula = Species ~ ., data = iris, method = mars, degree = 1, keepxy = TRUE) Dimension: 2 Percent Between-Group Variance Explained: v1 v2 92.73 100.00 Training Misclassification Error: 0.02667 ( N = 150 ) > a <- fda(Species ~ ., data=iris, method=earth, degree=1, keepxy=TRUE) > printh(a) ===a Call: fda(formula = Species ~ ., data = iris, method = earth, degree = 1, keepxy = TRUE) Dimension: 2 Percent Between-Group Variance Explained: v1 v2 97.97 100.00 Training Misclassification Error: 0.04 ( N = 150 ) > printh(confusion(a)) ===confusion(a) true predicted setosa versicolor virginica setosa 50 0 0 versicolor 0 47 3 virginica 0 3 47 > if (PLOT) { + par(mar=c(3, 3, 2, .5)) # small margins and text to pack figs in + par(mgp=c(1.6, 0.6, 0)) # flatten axis elements + par(oma=c(0,0,4,0)) # make space for caption + layout(rbind(c(1,1,0,0), c(2,3,4,5), c(6,7,8,9)), heights=c(2,1,1)) + plot(a) + plotmo(a$fit, nresponse=1, ylim=c(-1.5,1.5), clip=FALSE, do.par=FALSE, trace=-1) + plotmo(a$fit, nresponse=2, ylim=c(-1.5,1.5), clip=FALSE, do.par=FALSE, trace=-1) + mtext("fda test", outer=TRUE, font=2, line=1.5, cex=1) + } > > data(glass) > set.seed(123) > samp <- sample(c(1:214), size=100, replace=FALSE) > glass.train <- glass[samp,] > glass.test <- glass[-samp,] > am <- mda(Type ~ ., data=glass.train, method=mars, keepxy=TRUE, degree=2) > a <- mda(Type ~ ., data=glass.train, method=earth, keepxy=TRUE, degree=2, keep.fitted=TRUE) > printh(am) ===am Call: mda(formula = Type ~ ., data = glass.train, method = mars, keepxy = TRUE, degree = 2) Dimension: 14 Percent Between-Group Variance Explained: v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 50.58 74.19 86.94 92.11 95.37 97.20 98.32 99.16 99.64 99.88 100.00 v12 v13 v14 100.00 100.00 100.00 Training Misclassification Error: 0.2 ( N = 100 ) Deviance: 83.903 > printh(a) ===a Call: mda(formula = Type ~ ., data = glass.train, method = earth, keep.fitted = TRUE, keepxy = TRUE, degree = 2) Dimension: 12 Percent Between-Group Variance Explained: v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 46.60 74.43 85.71 92.48 95.56 98.06 99.20 100.00 100.00 100.00 100.00 v12 100.00 Training Misclassification Error: 0.22 ( N = 100 ) Deviance: 121.699 > cat("mda with mars ", attr(confusion(am), "error"), "\n") mda with mars 0.2 > cat("mda with earth ", attr(confusion(a), "error"), "\n") mda with earth 0.22 > if (PLOT) { + plot(a$fit, caption="mda on glass data", nresponse=1) + plotmo(a$fit, nresponse=9, clip=FALSE, ylim=NA, caption="mda on glass data", trace=-1) + } > > cat("\n---- update and keepxy, formula interface --------------------------\n") ---- update and keepxy, formula interface -------------------------- > > new.trees <- trees + c(1,2,3,4) > new.trees <- new.trees[, -c(20:23)] > a.formula <- earth(Volume ~ ., subset=rep(TRUE, nrow(trees)), data = trees) > cat("\nupdate(a, trace=1)\n") update(a, trace=1) > a.formula.1update <- update(a.formula, trace=1) update.earth: using 31 by 3 data argument from original call to earth update.earth: using 31 by 1 subset argument from original call to earth x[31,2] with colnames Girth Height y[31,1] with colname Volume, and values 10.3, 10.3, 10.2, 16.4, 18.8,... 31 cases after taking subset Skipped forward pass Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 > a.formula.1 <- earth(Volume ~ ., subset=rep(TRUE, nrow(trees)), data = trees) > newdata.global <- trees[seq(from=nrow(trees), to=1, by=-5),] > check.models.equal(a.formula.1update, a.formula.1, msg="a1update a1", newdata=newdata.global) a1update a1: models identical > > cat("\nupdate(a.formula, data=new.trees, trace=1)\n") update(a.formula, data=new.trees, trace=1) > a.formula.2update <- update(a.formula, data=new.trees, trace=1) update.earth: using 31 by 1 subset argument from original call to earth x[31,2] with colnames Girth Height y[31,1] with colname Volume, and values 13.3, 14.3, 11.2, 18.4, 21.8,... 31 cases after taking subset Forward pass term 1, 2, 4, 6, 8, 10, 12 RSq changed by less than 0.001 at 11 terms, 8 terms used (DeltaRSq 0.00016) After forward pass GRSq 0.735 RSq 0.942 Prune backward penalty 2 nprune null: selected 5 of 8 terms, and 2 of 2 preds After pruning pass GRSq 0.886 RSq 0.938 > a.formula.2 <- earth(Volume ~ ., subset=rep(TRUE, nrow(trees)), data = new.trees) > check.models.equal(a.formula.2update, a.formula.2, msg="a2update a2", newdata=newdata.global) a2update a2: models identical > > cat("\nupdate(a.formula, wp=2, trace=1)\n") update(a.formula, wp=2, trace=1) > a.formula.3update <- update(a.formula, wp=2, trace=1) update.earth: using 31 by 3 data argument from original call to earth update.earth: using 31 by 1 subset argument from original call to earth x[31,2] with colnames Girth Height y[31,1] with colname Volume, and values 10.3, 10.3, 10.2, 16.4, 18.8,... 31 cases after taking subset Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00087) After forward pass GRSq 0.947 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 > a.formula.3 <- earth(Volume ~ ., subset=rep(TRUE, nrow(trees)), data = trees, wp=2) > check.models.equal(a.formula.3update, a.formula.3, msg="a3update a3", newdata=newdata.global) a3update a3: models identical > > cat("\nupdate(a.formula, subset=subset.new, trace=1)\n") update(a.formula, subset=subset.new, trace=1) > subset.new <- rep(TRUE, nrow(trees)) > subset.new[1:4] = FALSE > a.formula.4update <- update(a.formula, subset=subset.new, trace=1) update.earth: using 31 by 3 data argument from original call to earth x[31,2] with colnames Girth Height y[31,1] with colname Volume, and values 10.3, 10.3, 10.2, 16.4, 18.8,... 27 cases after taking subset Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00037) After forward pass GRSq 0.925 RSq 0.972 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.947 RSq 0.969 > a.formula.4 <- earth(Volume ~ ., data = trees, subset=subset.new) > check.models.equal(a.formula.4update, a.formula.4, msg="a4update a4", newdata=newdata.global) a4update a4: models identical > > # now use keepxy=TRUE > > a.formula <- earth(Volume ~ ., wp=1, data = trees, keepxy=TRUE) > > cat("\nupdate(a.formula, trace=1)\n") update(a.formula, trace=1) > a.formula.5update <- update(a.formula, trace=1) update.earth: using 31 by 3 data saved by keepxy in original call to earth update.earth: using 1 by 1 wp saved by keepxy in original call to earth x[31,2] with colnames Girth Height y[31,1] with colname Volume, and values 10.3, 10.3, 10.2, 16.4, 18.8,... Skipped forward pass Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 > a.formula.5 <- earth(Volume ~ ., wp=1, data = trees, keepxy=TRUE) > check.models.equal(a.formula.5update, a.formula.5, msg="a5update a5", newdata=newdata.global) a5update a5: models identical > > cat("\nupdate(a.formula, data=new.trees, trace=1)\n") update(a.formula, data=new.trees, trace=1) > a.formula.6update <- update(a.formula, data=new.trees, trace=1) update.earth: using 1 by 1 wp saved by keepxy in original call to earth x[31,2] with colnames Girth Height y[31,1] with colname Volume, and values 13.3, 14.3, 11.2, 18.4, 21.8,... Forward pass term 1, 2, 4, 6, 8, 10, 12 RSq changed by less than 0.001 at 11 terms, 8 terms used (DeltaRSq 0.00016) After forward pass GRSq 0.735 RSq 0.942 Prune backward penalty 2 nprune null: selected 5 of 8 terms, and 2 of 2 preds After pruning pass GRSq 0.886 RSq 0.938 > a.formula.6 <- earth(Volume ~ ., wp=1, data = new.trees, keepxy=TRUE) > check.models.equal(a.formula.6update, a.formula.6, msg="a6update a6", newdata=newdata.global) a6update a6: models identical > > cat("\nupdate(a.formula, wp=2, trace=1)\n") update(a.formula, wp=2, trace=1) > a.formula.7update <- update(a.formula, wp=2, trace=1) update.earth: using 31 by 3 data saved by keepxy in original call to earth x[31,2] with colnames Girth Height y[31,1] with colname Volume, and values 10.3, 10.3, 10.2, 16.4, 18.8,... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00087) After forward pass GRSq 0.947 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 > a.formula.7 <- earth(Volume ~ ., wp=2, data = trees, keepxy=TRUE) > check.models.equal(a.formula.7update, a.formula.7, msg="a7update a7", newdata=newdata.global) a7update a7: models identical > > cat("\n----- update and keepxy, matrix interface--------------------------\n") ----- update and keepxy, matrix interface-------------------------- > > Volume <- trees$Volume > x <- cbind(trees$Height, trees$Volume) > colnames(x) <- c("Height", "Volume") > > new.x <- cbind(new.trees$Height, new.trees$Volume) > colnames(new.x) <- c("Height", "Volume") > > a <- earth(x, Volume, subset=rep(TRUE, nrow(trees))) > cat("\nupdate(a, trace=1)\n") update(a, trace=1) > a1update <- update(a, trace=1) update.earth: using 31 by 2 x argument from original call to earth update.earth: using 31 by 1 y argument from original call to earth update.earth: using 31 by 1 subset argument from original call to earth x[31,2] with colnames Height Volume y[31,1] with colname Volume, and values 10.3, 10.3, 10.2, 16.4, 18.8,... 31 cases after taking subset Skipped forward pass Prune backward penalty 2 nprune null: selected 2 of 2 terms, and 1 of 2 preds After pruning pass GRSq 1 RSq 1 > a1 <- earth(x, Volume, subset=rep(TRUE, nrow(trees))) > check.models.equal(a1update, a1, msg="a1update a1", newdata=newdata.global) a1update a1: models identical > > cat("\nupdate(a, x=new.x, trace=1)\n") update(a, x=new.x, trace=1) > a2update <- update(a, x=new.x, trace=1) update.earth: using 31 by 1 y argument from original call to earth update.earth: using 31 by 1 subset argument from original call to earth x[31,2] with colnames Height Volume y[31,1] with colname Volume, and values 10.3, 10.3, 10.2, 16.4, 18.8,... 31 cases after taking subset Forward pass term 1, 2, 4 RSq changed by less than 0.001 at 3 terms (DeltaRSq 0.00028) After forward pass GRSq 0.992 RSq 0.996 Prune backward penalty 2 nprune null: selected 3 of 3 terms, and 1 of 2 preds After pruning pass GRSq 0.994 RSq 0.995 > a2 <- earth(new.x, Volume, subset=rep(TRUE, nrow(trees))) > check.models.equal(a2update, a2, msg="a2update a2", newdata=newdata.global) a2update a2: models identical > > cat("\nupdate(a, wp=2, trace=0)\n") update(a, wp=2, trace=0) > a3update <- update(a, wp=2, trace=0) > a3 <- earth(x, Volume, subset=rep(TRUE, nrow(trees)), wp=2) > check.models.equal(a3update, a3, msg="a3update a3", newdata=newdata.global) a3update a3: models identical > > cat("\nupdate(a, subset=subset.new, trace=4)\n") update(a, subset=subset.new, trace=4) > subset.new <- rep(TRUE, nrow(trees)) > subset.new[1:4] = FALSE > a4update <- update(a, subset=subset.new, trace=4) update.earth: using 31 by 2 x argument from original call to earth update.earth: using 31 by 1 y argument from original call to earth Call: earth(x=x, y=Volume, subset=subset.new, trace=4) x[31,2]: Height Volume 1 70 10.3 2 65 10.3 3 63 10.2 ... 72 16.4 31 87 77.0 y[31,1]: Volume 1 10.3 2 10.3 3 10.2 ... 16.4 31 77.0 27 cases after taking subset Forward pass: minspan 4 endspan 8 x[27,2] 432 Bytes bx[27,21] 4.43 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 1.0000 1.0000 1 2 Volume 15.6< 2 1 final (max RSq) Reached maximum RSq 0.9990 at 3 terms, 2 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 3 terms, 2 terms used Using EvalSubsetsUsingXtx (rather than leaps) because ncol(bx) <= 2 nTerms iTerm DeltaRss RSq 2 2 6527.9 -0.0000 min Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 chosen 2 1.0000 1.0000 1.0000 1 1 2 Prune backward penalty 2 nprune null: selected 2 of 2 terms, and 1 of 2 preds After pruning pass GRSq 1 RSq 1 > a4 <- earth(x, Volume, subset=subset.new) > check.models.equal(a4update, a4, msg="a4update a4", newdata=newdata.global) a4update a4: models identical > > # now use keepxy=TRUE > > a <- earth(x, Volume, wp=1, keepxy=TRUE) > > cat("\nupdate(a, trace=4)\n") update(a, trace=4) > a5update <- update(a, trace=4) update.earth: using 31 by 2 x saved by keepxy in original call to earth update.earth: using 31 by 1 y saved by keepxy in original call to earth update.earth: using 1 by 1 wp saved by keepxy in original call to earth Call: earth(x=matrix[31,2], y=c(10.3,10.3,10...), wp=1, keepxy=TRUE, trace=4, Object=a) x[31,2]: Height Volume 1 70 10.3 2 65 10.3 3 63 10.2 ... 72 16.4 31 87 77.0 y[31,1]: Volume 1 10.3 2 10.3 3 10.2 ... 16.4 31 77.0 Skipped forward pass Using EvalSubsetsUsingXtx (rather than leaps) because ncol(bx) <= 2 nTerms iTerm DeltaRss RSq 2 2 8106.1 -0.0000 min Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 chosen 2 1.0000 1.0000 1.0000 1 1 2 Prune backward penalty 2 nprune null: selected 2 of 2 terms, and 1 of 2 preds After pruning pass GRSq 1 RSq 1 > a5 <- earth(x, Volume, wp=1, keepxy=TRUE) > check.models.equal(a5update, a5, msg="a5update a5", newdata=newdata.global) a5update a5: models identical > > cat("\nupdate(a, x=new.x, trace=4)\n") update(a, x=new.x, trace=4) > a6update <- update(a, x=new.x, trace=4) update.earth: using 31 by 1 y saved by keepxy in original call to earth update.earth: using 1 by 1 wp saved by keepxy in original call to earth Call: earth(x=new.x, y=c(10.3,10.3,10...), wp=1, keepxy=TRUE, trace=4) x[31,2]: Height Volume 1 74 13.3 2 66 14.3 3 65 11.2 ... 75 18.4 31 89 78.0 y[31,1]: Volume 1 10.3 2 10.3 3 10.2 ... 16.4 31 77.0 Forward pass: minspan 4 endspan 8 x[31,2] 496 Bytes bx[31,21] 5.09 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.9938 0.9954 0.9954 2 Volume 37.3 2 3 1 4 0.9919 0.9956 0.0002782 1 Height 75 4 5 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 3 terms (DeltaRSq 0.00028) After forward pass GRSq 0.992 RSq 0.996 Forward pass complete: 3 terms Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 2 0.7964 0.8226 0.7964 1 1 2 chosen 3 0.9938 0.9954 0.1974 1 1 2 3 Prune backward penalty 2 nprune null: selected 3 of 3 terms, and 1 of 2 preds After pruning pass GRSq 0.994 RSq 0.995 > a6 <- earth(new.x, Volume, wp=1, keepxy=TRUE) > check.models.equal(a6update, a6, msg="a6update a6", newdata=newdata.global) a6update a6: models identical > > cat("\nupdate(a, wp=2)\n") update(a, wp=2) > a7update <- update(a, wp=2) > a7 <- earth(x, Volume, wp=2, keepxy=TRUE) > check.models.equal(a7update, a7, msg="a7update a7", newdata=newdata.global) a7update a7: models identical > > cat("--- beta cache -------------------------\n") --- beta cache ------------------------- > > a1 <- earth(O3 ~ ., data = ozone1, degree = 3) > a2 <- earth(O3 ~ ., data = ozone1, degree = 3, Use.beta.cache=FALSE) > a1$call <- NULL > a2$call <- NULL > stopifnot(identical(a1, a2)) > > cat("--- test \"call\" printing in earth.default and summary.earth ---\n") --- test "call" printing in earth.default and summary.earth --- > # we want to make sure that long x or y aren't printed but short ones are > > x = c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0) > > y = c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0) > > a <- earth(x = x, y=y, trace=5) Call: earth(x=x, y=y, trace=5) x[101,1]: x 1 0 2 1 3 2 4 3 5 4 6 5 7 6 8 7 9 8 10 9 11 0 12 1 13 2 14 3 15 4 16 5 17 6 18 7 19 8 20 9 21 0 22 1 23 2 24 3 25 4 26 5 27 6 28 7 29 8 30 9 31 0 32 1 33 2 34 3 35 4 36 5 37 6 38 7 39 8 40 9 41 0 42 1 43 2 44 3 45 4 46 5 47 6 48 7 49 8 50 9 51 0 52 1 53 2 54 3 55 4 56 5 57 6 58 7 59 8 60 9 61 0 62 1 63 2 64 3 65 4 66 5 67 6 68 7 69 8 70 9 71 0 72 1 73 2 74 3 75 4 76 5 77 6 78 7 79 8 80 9 81 0 82 1 83 2 84 3 85 4 86 5 87 6 88 7 89 8 90 9 91 0 92 1 93 2 94 3 95 4 96 5 97 6 98 7 99 8 100 9 101 0 x Min. :0.000 1st Qu.:2.000 Median :4.000 Mean :4.455 3rd Qu.:7.000 Max. :9.000 y[101,1]: y 1 0 2 1 3 2 4 3 5 4 6 5 7 6 8 7 9 8 10 9 11 0 12 1 13 2 14 3 15 4 16 5 17 6 18 7 19 8 20 9 21 0 22 1 23 2 24 3 25 4 26 5 27 6 28 7 29 8 30 9 31 0 32 1 33 2 34 3 35 4 36 5 37 6 38 7 39 8 40 9 41 0 42 1 43 2 44 3 45 4 46 5 47 6 48 7 49 8 50 9 51 0 52 1 53 2 54 3 55 4 56 5 57 6 58 7 59 8 60 9 61 0 62 1 63 2 64 3 65 4 66 5 67 6 68 7 69 8 70 9 71 0 72 1 73 2 74 3 75 4 76 5 77 6 78 7 79 8 80 9 81 0 82 1 83 2 84 3 85 4 86 5 87 6 88 7 89 8 90 9 91 0 92 1 93 2 94 3 95 4 96 5 97 6 98 7 99 8 100 9 101 0 y Min. :0.000 1st Qu.:2.000 Median :4.000 Mean :4.455 3rd Qu.:7.000 Max. :9.000 maxmem 0.0 GB Scale.y = TRUE: yscale 2.907 ycenter 4.4554 yscaled[101,1]: y 1 -1.5326750 2 -1.1886746 3 -0.8446742 4 -0.5006738 5 -0.1566734 6 0.1873269 7 0.5313273 8 0.8753277 9 1.2193281 10 1.5633285 11 -1.5326750 12 -1.1886746 13 -0.8446742 14 -0.5006738 15 -0.1566734 16 0.1873269 17 0.5313273 18 0.8753277 19 1.2193281 20 1.5633285 21 -1.5326750 22 -1.1886746 23 -0.8446742 24 -0.5006738 25 -0.1566734 26 0.1873269 27 0.5313273 28 0.8753277 29 1.2193281 30 1.5633285 31 -1.5326750 32 -1.1886746 33 -0.8446742 34 -0.5006738 35 -0.1566734 36 0.1873269 37 0.5313273 38 0.8753277 39 1.2193281 40 1.5633285 41 -1.5326750 42 -1.1886746 43 -0.8446742 44 -0.5006738 45 -0.1566734 46 0.1873269 47 0.5313273 48 0.8753277 49 1.2193281 50 1.5633285 51 -1.5326750 52 -1.1886746 53 -0.8446742 54 -0.5006738 55 -0.1566734 56 0.1873269 57 0.5313273 58 0.8753277 59 1.2193281 60 1.5633285 61 -1.5326750 62 -1.1886746 63 -0.8446742 64 -0.5006738 65 -0.1566734 66 0.1873269 67 0.5313273 68 0.8753277 69 1.2193281 70 1.5633285 71 -1.5326750 72 -1.1886746 73 -0.8446742 74 -0.5006738 75 -0.1566734 76 0.1873269 77 0.5313273 78 0.8753277 79 1.2193281 80 1.5633285 81 -1.5326750 82 -1.1886746 83 -0.8446742 84 -0.5006738 85 -0.1566734 86 0.1873269 87 0.5313273 88 0.8753277 89 1.2193281 90 1.5633285 91 -1.5326750 92 -1.1886746 93 -0.8446742 94 -0.5006738 95 -0.1566734 96 0.1873269 97 0.5313273 98 0.8753277 99 1.2193281 100 1.5633285 101 -1.5326750 y Min. :-1.5327 1st Qu.:-0.8447 Median :-0.1567 Mean : 0.0000 3rd Qu.: 0.8753 Max. : 1.5633 earth.c version 5.1.0 BetaCache 3.45 kB Forward pass: minspan 4 endspan 7 x[101,1] 808 Bytes bx[101,21] 16.6 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 1.0000 1.0000 1 1 x 0< 2 1 final (max RSq) Reached maximum RSq 0.9990 at 3 terms, 2 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 3 terms, 2 terms used Using EvalSubsetsUsingXtx (rather than leaps) because ncol(bx) <= 2 nTerms iTerm DeltaRss RSq 2 2 845.05 -0.0000 min Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 chosen 2 1.0000 1.0000 1.0000 1 1 2 Prune backward penalty 2 nprune null: selected 2 of 2 terms, and 1 of 1 preds After pruning pass GRSq 1 RSq 1 > > a.longx <- earth(x = c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0), + y=y, + trace=4) Call: earth(x=c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,...), y=y, trace=4) x[101,1]: x 1 0 2 1 3 2 ... 3 101 0 y[101,1]: y 1 0 2 1 3 2 ... 3 101 0 Forward pass: minspan 4 endspan 7 x[101,1] 808 Bytes bx[101,21] 16.6 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 1.0000 1.0000 1 1 x 0< 2 1 final (max RSq) Reached maximum RSq 0.9990 at 3 terms, 2 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 3 terms, 2 terms used Using EvalSubsetsUsingXtx (rather than leaps) because ncol(bx) <= 2 nTerms iTerm DeltaRss RSq 2 2 845.05 -0.0000 min Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 chosen 2 1.0000 1.0000 1.0000 1 1 2 Prune backward penalty 2 nprune null: selected 2 of 2 terms, and 1 of 1 preds After pruning pass GRSq 1 RSq 1 > > a.longy <- earth(x = x, + y = c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0), + trace=4) Call: earth(x=x, y=c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,...), trace=4) x[101,1]: x 1 0 2 1 3 2 ... 3 101 0 y[101,1]: y 1 0 2 1 3 2 ... 3 101 0 Forward pass: minspan 4 endspan 7 x[101,1] 808 Bytes bx[101,21] 16.6 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 1.0000 1.0000 1 1 x 0< 2 1 final (max RSq) Reached maximum RSq 0.9990 at 3 terms, 2 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 3 terms, 2 terms used Using EvalSubsetsUsingXtx (rather than leaps) because ncol(bx) <= 2 nTerms iTerm DeltaRss RSq 2 2 845.05 -0.0000 min Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 chosen 2 1.0000 1.0000 1.0000 1 1 2 Prune backward penalty 2 nprune null: selected 2 of 2 terms, and 1 of 1 preds After pruning pass GRSq 1 RSq 1 > > a.longxy <- earth(x = c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0), + y = c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9, + 0,1,2,3,4,5,6,7,8,9,0), + trace=4) Call: earth(x=c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,...), y=c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,...), trace=4) x[101,1]: x 1 0 2 1 3 2 ... 3 101 0 y[101,1]: y 1 0 2 1 3 2 ... 3 101 0 Forward pass: minspan 4 endspan 7 x[101,1] 808 Bytes bx[101,21] 16.6 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 1.0000 1.0000 1 1 x 0< 2 1 final (max RSq) Reached maximum RSq 0.9990 at 3 terms, 2 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 3 terms, 2 terms used Using EvalSubsetsUsingXtx (rather than leaps) because ncol(bx) <= 2 nTerms iTerm DeltaRss RSq 2 2 845.05 -0.0000 min Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 chosen 2 1.0000 1.0000 1.0000 1 1 2 Prune backward penalty 2 nprune null: selected 2 of 2 terms, and 1 of 1 preds After pruning pass GRSq 1 RSq 1 > printh(summary(a)) ===summary(a) Call: earth(x=x, y=y, trace=5) coefficients (Intercept) -7.070164e-16 x 1.000000e+00 Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: Reached maximum RSq 0.9990 at 2 terms Importance: x Number of terms at each degree of interaction: 1 1 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > printh(summary(a.longx)) ===summary(a.longx) Call: earth(x=c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,...), y=y, trace=4) coefficients (Intercept) -7.070164e-16 x 1.000000e+00 Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: Reached maximum RSq 0.9990 at 2 terms Importance: x Number of terms at each degree of interaction: 1 1 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > printh(summary(a.longy)) ===summary(a.longy) Call: earth(x=x, y=c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,...), trace=4) coefficients (Intercept) -7.070164e-16 x 1.000000e+00 Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: Reached maximum RSq 0.9990 at 2 terms Importance: x Number of terms at each degree of interaction: 1 1 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > printh(summary(a.longxy)) ===summary(a.longxy) Call: earth(x=c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,...), y=c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,...), trace=4) coefficients (Intercept) -7.070164e-16 x 1.000000e+00 Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: Reached maximum RSq 0.9990 at 2 terms Importance: x Number of terms at each degree of interaction: 1 1 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > printh(summary(a.longxy, style="bf")) ===summary(a.longxy, style = "bf") Call: earth(x=c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,...), y=c(0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,...), trace=4) y = -7.070164e-16 + 1 * bf1 bf1 x Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: Reached maximum RSq 0.9990 at 2 terms Importance: x Number of terms at each degree of interaction: 1 1 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > > cat("--- factors with x,y interface -------------------------\n") --- factors with x,y interface ------------------------- > # this also tests for integer variables in the input matrix > data(etitanic) > attach(etitanic) > a1 <- earth(pclass, sex, degree=2, trace=2) # x=unordered y=unordered x[1046,2] with colnames x2nd x3rd y[1046,1] with colname male, and values 0, 1, 0, 1, 0, 1, 0, 1, 0, 1,... Forward pass: minspan 6 endspan 8 x[1046,2] 16.3 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0133 0.0180 0.01797 2 x3rd 0< 2 1 4 0.0116 0.0210 0.003025 1 x2nd 0< 3 1 6 0.0068 0.0210 0 - reject (no DeltaRsq) RSq changed by less than 0.001 at 5 terms, 3 terms used (DeltaRSq 0) After forward pass GRSq 0.007 RSq 0.021 Forward pass complete: 5 terms, 3 terms used Prune backward penalty 3 nprune null: selected 2 of 3 terms, and 1 of 2 preds After pruning pass GRSq 0.0133 RSq 0.018 > printh(summary(a1)) ===summary(a1) Call: earth(x=pclass, y=sex, trace=2, degree=2) coefficients (Intercept) 0.5669725 x3rd 0.1296343 Selected 2 of 3 terms, and 1 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: x3rd, x2nd-unused Number of terms at each degree of interaction: 1 1 (additive model) GCV 0.2306901 RSS 239.6897 GRSq 0.01325722 RSq 0.01797283 > printh(summary(a1, style="bf")) ===summary(a1, style = "bf") Call: earth(x=pclass, y=sex, trace=2, degree=2) male = 0.5669725 + 0.1296343 * bf1 bf1 x3rd Selected 2 of 3 terms, and 1 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: x3rd, x2nd-unused Number of terms at each degree of interaction: 1 1 (additive model) GCV 0.2306901 RSS 239.6897 GRSq 0.01325722 RSq 0.01797283 > if (PLOT) + plot(a1) > a2 <- earth(sex, pclass, degree=2, trace=2) # x=unordered y=unordered x[1046,1] with colname xmale, and values 0, 1, 0, 1, 0, 1, 0, 1, 0, 1,... y[1046,3] with colnames 1st 2nd 3rd Forward pass: minspan 5 endspan 7 x[1046,1] 8.17 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0073 0.0120 0.01202 1 xmale 0< 2 1 4 0.0025 0.0120 0 - reject (no DeltaRsq) RSq changed by less than 0.001 at 3 terms, 2 terms used (DeltaRSq 0) After forward pass GRSq 0.003 RSq 0.012 Forward pass complete: 3 terms, 2 terms used Using EvalSubsetsUsingXtx (rather than leaps) because this is a multiple response model Prune backward penalty 3 nprune null: selected 2 of 2 terms, and 1 of 1 preds After pruning pass GRSq 0.00728 RSq 0.012 > printh(summary(a2)) ===summary(a2) Call: earth(x=sex, y=pclass, trace=2, degree=2) 1st 2nd 3rd (Intercept) 0.3427835 0.26546392 0.3917526 xmale -0.1133002 -0.02534234 0.1386426 Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 2 terms Importance: xmale Number of terms at each degree of interaction: 1 1 (additive model) GCV RSS GRSq RSq 1st 0.1961073 203.7578 0.010414990 0.0151441824 2nd 0.1883694 195.7180 -0.003997793 0.0008002778 3rd 0.2467207 256.3457 0.013257223 0.0179728324 All 0.6311974 655.8215 0.007279765 0.0120239411 > if (PLOT) + plot(a2, nresponse=1) > a3 <- earth(pclass, age, degree=2, trace=2) # x=unordered y=numeric x[1046,2] with colnames x2nd x3rd y[1046,1] with colname age, and values 29, 0.9167, 2, 30, 25, 48, 63... Forward pass: minspan 6 endspan 8 x[1046,2] 16.3 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.1094 0.1136 0.1136 2 x3rd 0< 2 1 4 0.1640 0.1720 0.05838 1 x2nd 0< 3 1 6 0.1600 0.1720 0 - reject (no DeltaRsq) RSq changed by less than 0.001 at 5 terms, 3 terms used (DeltaRSq 0) After forward pass GRSq 0.160 RSq 0.172 Forward pass complete: 5 terms, 3 terms used Prune backward penalty 3 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.164 RSq 0.172 > printh(summary(a3)) ===summary(a3) Call: earth(x=pclass, y=age, trace=2, degree=2) coefficients (Intercept) 39.159918 x2nd -9.653213 x3rd -14.343551 Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: x3rd, x2nd Number of terms at each degree of interaction: 1 2 (additive model) GCV 173.8417 RSS 179758.3 GRSq 0.1640128 RSq 0.1719935 > if (PLOT) + plot(a3, nresponse=1) > a4 <- earth(age, pclass, degree=2, trace=2) # x=numeric y=unordered x[1046,1] with colname age, and values 29, 0.9167, 2, 30, 25, 48, 63... y[1046,3] with colnames 1st 2nd 3rd Forward pass: minspan 5 endspan 7 x[1046,1] 8.17 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0893 0.0980 0.09797 1 age 26 2 3 1 4 0.0891 0.1021 0.004178 1 age 55 4 1 6 0.0881 0.1055 0.003357 1 age 16 5 1 8 0.0849 0.1067 0.00116 1 age 44 6 1 10 0.0813 0.1075 0.0008104 1 age 48 7 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 9 terms, 6 terms used (DeltaRSq 0.00081) After forward pass GRSq 0.081 RSq 0.107 Forward pass complete: 9 terms, 6 terms used Using EvalSubsetsUsingXtx (rather than leaps) because this is a multiple response model Prune backward penalty 3 nprune null: selected 2 of 6 terms, and 1 of 1 preds After pruning pass GRSq 0.093 RSq 0.0974 > printh(summary(a4)) ===summary(a4) Call: earth(x=age, y=pclass, trace=2, degree=2) 1st 2nd 3rd (Intercept) 0.06439450 0.2563335580 0.67927195 h(age-16) 0.01388561 -0.0004566659 -0.01342895 Selected 2 of 6 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 6 terms Importance: age Number of terms at each degree of interaction: 1 1 (additive model) GCV RSS GRSq RSq 1st 0.1670033 173.5184 0.157277818 0.16130516 2nd 0.1884855 195.8387 -0.004616749 0.00018428 3rd 0.2211945 229.8237 0.115347486 0.11957521 All 0.5766834 599.1808 0.093017132 0.09735157 > if (PLOT) + plot(a4, nresponse=1) > a5 <- earth(etitanic[,c(2:4)], pclass, degree=2, trace=2) # x=mixed y=unordered x[1046,3] with colnames survived sexmale age y[1046,3] with colnames 1st 2nd 3rd Forward pass: minspan 6 endspan 8 x[1046,3] 24.5 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0893 0.0980 0.09797 3 age 26 2 3 1 4 0.1500 0.1622 0.0642 1 survived 0< 4 1 6 0.1557 0.1758 0.01364 3 age 16 5 6 4 2 8 0.1603 0.1842 0.008445 2 sexmale 0< 7 4 2 10 0.1631 0.1909 0.006652 2 sexmale 0< 8 1 12 0.1616 0.1934 0.00253 3 age 57 9 1 14 0.1599 0.1956 0.002212 2 sexmale 0< 10 2 2 16 0.1541 0.1980 0.002352 3 age 5 11 12 10 2 18 0.1529 0.2008 0.002846 3 age 2 13 1 20 0.1495 0.2016 0.0007302 3 age 12 14 4 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 19 terms, 13 terms used (DeltaRSq 0.00073) After forward pass GRSq 0.149 RSq 0.202 Forward pass complete: 19 terms, 13 terms used Using EvalSubsetsUsingXtx (rather than leaps) because this is a multiple response model Prune backward penalty 3 nprune null: selected 7 of 13 terms, and 3 of 3 preds After pruning pass GRSq 0.165 RSq 0.189 > printh(summary(a5)) ===summary(a5) Call: earth(x=etitanic[,c(2:4)], y=pclass, trace=2, degree=2) 1st 2nd 3rd (Intercept) -0.02151789 0.210092649 0.81142524 survived 0.36119246 0.144874864 -0.50606732 sexmale 0.07967096 0.115755401 -0.19542636 h(26-age) -0.00070712 -0.013836973 0.01454409 h(age-26) 0.01592910 -0.003659393 -0.01226971 survived * sexmale -0.07745396 -0.293062401 0.37051636 survived * h(16-age) -0.02037404 0.038860933 -0.01848689 Selected 7 of 13 terms, and 3 of 3 predictors Termination condition: RSq changed by less than 0.001 at 13 terms Importance: age, survived, sexmale Number of terms at each degree of interaction: 1 4 2 GCV RSS GRSq RSq 1st 0.1502539 152.3942 0.24179781 0.26340816 2nd 0.1834402 186.0532 0.02227456 0.05014178 3rd 0.1970609 199.8680 0.21186826 0.23433166 All 0.5307550 538.3155 0.16525132 0.18904341 > if (PLOT) + plot(a5, nresponse=1) > a6 <- earth(etitanic[,c(1,3,4,5,6)], survived, degree=2, trace=2) # x=mixed y=unordered x[1046,6] with colnames pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname survived, and values 1, 1, 0, 0, 0, 1, 1, 0, 1, 0,... Forward pass: minspan 6 endspan 9 x[1046,6] 49 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.2860 0.2894 0.2894 3 sexmale 0< 2 1 4 0.3297 0.3361 0.04669 2 pclass3rd 0< 3 1 6 0.3588 0.3710 0.03488 4 age 16 4 5 2 2 8 0.3962 0.4106 0.03954 1 pclass2nd 0< 6 2 2 10 0.4143 0.4338 0.0232 5 sibsp 4 7 8 4 2 12 0.4133 0.4383 0.004574 6 parch 1 9 10 1 14 0.4150 0.4427 0.00437 2 pclass3rd 0< 11 2 2 16 0.4116 0.4449 0.002169 5 sibsp 1 12 13 2 2 18 0.4087 0.4477 0.002807 4 age 17 14 15 13 2 20 0.4056 0.4502 0.002549 4 age 32 16 17 1 final (reached nk 21) Reached nk 21 After forward pass GRSq 0.406 RSq 0.450 Forward pass complete: 21 terms, 17 terms used Prune backward penalty 3 nprune null: selected 8 of 17 terms, and 5 of 6 preds After pruning pass GRSq 0.42 RSq 0.439 > printh(summary(a6)) ===summary(a6) Call: earth(x=etitanic[,c(1,3,4,5,6)], y=survived, trace=2, degree=2) coefficients (Intercept) 0.96170950 pclass3rd -0.81545352 sexmale -0.57003496 h(age-32) -0.00471938 pclass2nd * sexmale -0.26568920 pclass3rd * sexmale 0.19310203 pclass3rd * h(4-sibsp) 0.10222181 sexmale * h(16-age) 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 0.1404529 RSS 141.7629 GRSq 0.4197106 RSq 0.4389834 > if (PLOT) + plot(a6) > a7 <- earth(etitanic[,c(2,3,5,6)], etitanic[,c(1,4)], degree=2, trace=2) # x=mixed y=mixed x[1046,4] with colnames survived sexmale sibsp parch y[1046,4] with colnames pclass1st pclass2nd pclass3rd age Forward pass: minspan 6 endspan 9 x[1046,4] 32.7 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0813 0.0901 0.09011 4 parch 2 2 3 1 4 0.1049 0.1219 0.03183 3 sibsp 1 4 5 1 6 0.1068 0.1323 0.01034 4 parch 1 6 7 4 2 8 0.1089 0.1385 0.006171 4 parch 4 8 1 10 0.1093 0.1431 0.00463 3 sibsp 2 9 1 12 0.1043 0.1466 0.003515 4 parch 1 10 11 5 2 14 0.1024 0.1491 0.002463 2 sexmale 0< 12 3 2 16 0.0998 0.1507 0.001651 1 survived 0< 13 4 2 18 0.0974 0.1526 0.001929 1 survived 0< 14 10 2 20 0.0944 0.1540 0.001385 4 parch 1 15 1 final (reached nk 21) Reached nk 21 After forward pass GRSq 0.094 RSq 0.154 Forward pass complete: 21 terms, 15 terms used Using EvalSubsetsUsingXtx (rather than leaps) because this is a multiple response model Prune backward penalty 3 nprune null: selected 7 of 15 terms, and 2 of 4 preds After pruning pass GRSq 0.113 RSq 0.138 > printh(summary(a7)) ===summary(a7) Call: earth(x=etitanic[,c(2,3,5,6)], y=etitanic[,c(1,4)], trace=2, degree=2) pclass1st pclass2nd pclass3rd age (Intercept) 0.36758408 0.35266924 0.27974668 22.291896 h(sibsp-1) -0.12882542 -0.08036041 0.20918583 -7.715668 h(2-parch) -0.04851620 -0.05326897 0.10178517 4.853565 h(parch-2) -0.03888370 -0.12184854 0.16073223 13.049389 h(parch-4) -0.16812822 0.04401127 0.12411695 -18.899871 h(sibsp-1) * h(parch-1) 0.05211343 -0.02136815 -0.03074529 4.418743 h(sibsp-1) * h(1-parch) 0.06525217 0.09912874 -0.16438091 7.403960 Selected 7 of 15 terms, and 2 of 4 predictors Termination condition: Reached nk 21 Importance: sibsp, parch, survived-unused, sexmale-unused Number of terms at each degree of interaction: 1 4 2 GCV RSS GRSq RSq pclass1st 0.200320 203.173 -0.01084030 0.01797077 pclass2nd 0.189624 192.326 -0.01068680 0.01811990 pclass3rd 0.243908 247.383 0.02450493 0.05230858 age 184.482965 187110.877 0.11283993 0.13812585 All 185.116817 187753.758 0.11250542 0.13780087 > if (PLOT) + plot(a7, nresponse=1) > > cat("--- factors with formula interface -------------------------\n") --- factors with formula interface ------------------------- > # these correspond to the models above (except a7 which is a multiple response model) > a1f <- earth(sex ~ pclass, degree=2, trace=2) # x=unordered y=unordered x[1046,2] with colnames pclass2nd pclass3rd y[1046,1] with colname male, and values 0, 1, 0, 1, 0, 1, 0, 1, 0, 1,... Forward pass: minspan 6 endspan 8 x[1046,2] 16.3 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0133 0.0180 0.01797 2 pclass3rd 0< 2 1 4 0.0116 0.0210 0.003025 1 pclass2nd 0< 3 1 6 0.0068 0.0210 0 - reject (no DeltaRsq) RSq changed by less than 0.001 at 5 terms, 3 terms used (DeltaRSq 0) After forward pass GRSq 0.007 RSq 0.021 Forward pass complete: 5 terms, 3 terms used Prune backward penalty 3 nprune null: selected 2 of 3 terms, and 1 of 2 preds After pruning pass GRSq 0.0133 RSq 0.018 > printh(summary(a1f)) ===summary(a1f) Call: earth(formula=sex~pclass, trace=2, degree=2) coefficients (Intercept) 0.5669725 pclass3rd 0.1296343 Selected 2 of 3 terms, and 1 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: pclass3rd, pclass2nd-unused Number of terms at each degree of interaction: 1 1 (additive model) GCV 0.2306901 RSS 239.6897 GRSq 0.01325722 RSq 0.01797283 > printh(summary(a1f, style="bf")) ===summary(a1f, style = "bf") Call: earth(formula=sex~pclass, trace=2, degree=2) male = 0.5669725 + 0.1296343 * bf1 bf1 pclass3rd Selected 2 of 3 terms, and 1 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: pclass3rd, pclass2nd-unused Number of terms at each degree of interaction: 1 1 (additive model) GCV 0.2306901 RSS 239.6897 GRSq 0.01325722 RSq 0.01797283 > if (PLOT) + plot(a1f) > a2f <- earth(pclass ~ sex, degree=2, trace=2) # x=unordered y=unordered x[1046,1] with colname sexmale, and values 0, 1, 0, 1, 0, 1, 0, 1, 0, 1,... y[1046,3] with colnames 1st 2nd 3rd Forward pass: minspan 5 endspan 7 x[1046,1] 8.17 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0073 0.0120 0.01202 1 sexmale 0< 2 1 4 0.0025 0.0120 0 - reject (no DeltaRsq) RSq changed by less than 0.001 at 3 terms, 2 terms used (DeltaRSq 0) After forward pass GRSq 0.003 RSq 0.012 Forward pass complete: 3 terms, 2 terms used Using EvalSubsetsUsingXtx (rather than leaps) because this is a multiple response model Prune backward penalty 3 nprune null: selected 2 of 2 terms, and 1 of 1 preds After pruning pass GRSq 0.00728 RSq 0.012 > printh(summary(a2f)) ===summary(a2f) Call: earth(formula=pclass~sex, trace=2, degree=2) 1st 2nd 3rd (Intercept) 0.3427835 0.26546392 0.3917526 sexmale -0.1133002 -0.02534234 0.1386426 Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 2 terms Importance: sexmale Number of terms at each degree of interaction: 1 1 (additive model) GCV RSS GRSq RSq 1st 0.1961073 203.7578 0.010414990 0.0151441824 2nd 0.1883694 195.7180 -0.003997793 0.0008002778 3rd 0.2467207 256.3457 0.013257223 0.0179728324 All 0.6311974 655.8215 0.007279765 0.0120239411 > if (PLOT) + plot(a2f, nresponse=1) > a3f <- earth(age ~ pclass, degree=2, trace=2) # x=unordered y=numeric x[1046,2] with colnames pclass2nd pclass3rd y[1046,1] with colname age, and values 29, 0.9167, 2, 30, 25, 48, 63... Forward pass: minspan 6 endspan 8 x[1046,2] 16.3 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.1094 0.1136 0.1136 2 pclass3rd 0< 2 1 4 0.1640 0.1720 0.05838 1 pclass2nd 0< 3 1 6 0.1600 0.1720 0 - reject (no DeltaRsq) RSq changed by less than 0.001 at 5 terms, 3 terms used (DeltaRSq 0) After forward pass GRSq 0.160 RSq 0.172 Forward pass complete: 5 terms, 3 terms used Prune backward penalty 3 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.164 RSq 0.172 > printh(summary(a3f)) ===summary(a3f) Call: earth(formula=age~pclass, trace=2, degree=2) coefficients (Intercept) 39.159918 pclass2nd -9.653213 pclass3rd -14.343551 Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: pclass3rd, pclass2nd Number of terms at each degree of interaction: 1 2 (additive model) GCV 173.8417 RSS 179758.3 GRSq 0.1640128 RSq 0.1719935 > if (PLOT) + plot(a3f) > a4f <- earth(pclass ~ age, degree=2, trace=2) # x=numeric y=unordered x[1046,1] with colname age, and values 29, 0.9167, 2, 30, 25, 48, 63... y[1046,3] with colnames 1st 2nd 3rd Forward pass: minspan 5 endspan 7 x[1046,1] 8.17 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0893 0.0980 0.09797 1 age 26 2 3 1 4 0.0891 0.1021 0.004178 1 age 55 4 1 6 0.0881 0.1055 0.003357 1 age 16 5 1 8 0.0849 0.1067 0.00116 1 age 44 6 1 10 0.0813 0.1075 0.0008104 1 age 48 7 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 9 terms, 6 terms used (DeltaRSq 0.00081) After forward pass GRSq 0.081 RSq 0.107 Forward pass complete: 9 terms, 6 terms used Using EvalSubsetsUsingXtx (rather than leaps) because this is a multiple response model Prune backward penalty 3 nprune null: selected 2 of 6 terms, and 1 of 1 preds After pruning pass GRSq 0.093 RSq 0.0974 > printh(summary(a4f)) ===summary(a4f) Call: earth(formula=pclass~age, trace=2, degree=2) 1st 2nd 3rd (Intercept) 0.06439450 0.2563335580 0.67927195 h(age-16) 0.01388561 -0.0004566659 -0.01342895 Selected 2 of 6 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 6 terms Importance: age Number of terms at each degree of interaction: 1 1 (additive model) GCV RSS GRSq RSq 1st 0.1670033 173.5184 0.157277818 0.16130516 2nd 0.1884855 195.8387 -0.004616749 0.00018428 3rd 0.2211945 229.8237 0.115347486 0.11957521 All 0.5766834 599.1808 0.093017132 0.09735157 > if (PLOT) + plot(a4f, nresponse=1) > a5f <- earth(pclass ~ survived + sex + age, data=etitanic, degree=2, trace=2) # x=mixed y=unordered x[1046,3] with colnames survived sexmale age y[1046,3] with colnames 1st 2nd 3rd Forward pass: minspan 6 endspan 8 x[1046,3] 24.5 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0893 0.0980 0.09797 3 age 26 2 3 1 4 0.1500 0.1622 0.0642 1 survived 0< 4 1 6 0.1557 0.1758 0.01364 3 age 16 5 6 4 2 8 0.1603 0.1842 0.008445 2 sexmale 0< 7 4 2 10 0.1631 0.1909 0.006652 2 sexmale 0< 8 1 12 0.1616 0.1934 0.00253 3 age 57 9 1 14 0.1599 0.1956 0.002212 2 sexmale 0< 10 2 2 16 0.1541 0.1980 0.002352 3 age 5 11 12 10 2 18 0.1529 0.2008 0.002846 3 age 2 13 1 20 0.1495 0.2016 0.0007302 3 age 12 14 4 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 19 terms, 13 terms used (DeltaRSq 0.00073) After forward pass GRSq 0.149 RSq 0.202 Forward pass complete: 19 terms, 13 terms used Using EvalSubsetsUsingXtx (rather than leaps) because this is a multiple response model Prune backward penalty 3 nprune null: selected 7 of 13 terms, and 3 of 3 preds After pruning pass GRSq 0.165 RSq 0.189 > printh(summary(a5f)) ===summary(a5f) Call: earth(formula=pclass~survived+sex+age, data=etitanic, trace=2, degree=2) 1st 2nd 3rd (Intercept) -0.02151789 0.210092649 0.81142524 survived 0.36119246 0.144874864 -0.50606732 sexmale 0.07967096 0.115755401 -0.19542636 h(26-age) -0.00070712 -0.013836973 0.01454409 h(age-26) 0.01592910 -0.003659393 -0.01226971 survived * sexmale -0.07745396 -0.293062401 0.37051636 survived * h(16-age) -0.02037404 0.038860933 -0.01848689 Selected 7 of 13 terms, and 3 of 3 predictors Termination condition: RSq changed by less than 0.001 at 13 terms Importance: age, survived, sexmale Number of terms at each degree of interaction: 1 4 2 GCV RSS GRSq RSq 1st 0.1502539 152.3942 0.24179781 0.26340816 2nd 0.1834402 186.0532 0.02227456 0.05014178 3rd 0.1970609 199.8680 0.21186826 0.23433166 All 0.5307550 538.3155 0.16525132 0.18904341 > if (PLOT) + plot(a5f, nresponse=1) > a6f <- earth(survived ~ ., data=etitanic, degree=2, trace=2) # x=mixed y=unordered x[1046,6] with colnames pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname survived, and values 1, 1, 0, 0, 0, 1, 1, 0, 1, 0,... Forward pass: minspan 6 endspan 9 x[1046,6] 49 kB bx[1046,21] 172 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.2860 0.2894 0.2894 3 sexmale 0< 2 1 4 0.3297 0.3361 0.04669 2 pclass3rd 0< 3 1 6 0.3588 0.3710 0.03488 4 age 16 4 5 2 2 8 0.3962 0.4106 0.03954 1 pclass2nd 0< 6 2 2 10 0.4143 0.4338 0.0232 5 sibsp 4 7 8 4 2 12 0.4133 0.4383 0.004574 6 parch 1 9 10 1 14 0.4150 0.4427 0.00437 2 pclass3rd 0< 11 2 2 16 0.4116 0.4449 0.002169 5 sibsp 1 12 13 2 2 18 0.4087 0.4477 0.002807 4 age 17 14 15 13 2 20 0.4056 0.4502 0.002549 4 age 32 16 17 1 final (reached nk 21) Reached nk 21 After forward pass GRSq 0.406 RSq 0.450 Forward pass complete: 21 terms, 17 terms used Prune backward penalty 3 nprune null: selected 8 of 17 terms, and 5 of 6 preds After pruning pass GRSq 0.42 RSq 0.439 > printh(summary(a6f)) ===summary(a6f) Call: earth(formula=survived~., data=etitanic, trace=2, degree=2) coefficients (Intercept) 0.96170950 pclass3rd -0.81545352 sexmale -0.57003496 h(age-32) -0.00471938 pclass2nd * sexmale -0.26568920 pclass3rd * sexmale 0.19310203 pclass3rd * h(4-sibsp) 0.10222181 sexmale * h(16-age) 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 0.1404529 RSS 141.7629 GRSq 0.4197106 RSq 0.4389834 > if (PLOT) + plot(a6f) > detach(etitanic) > > # basic test with ordered factors > ff <- factor(substring("statistics", 1:10, 1:10), levels=letters, ordered=TRUE) > ff <- c(ff, ff, ff) > vowels = (ff == 1 | ff == 9) * 3 > printh(head(ff)) ===head(ff) [1] 19 20 1 20 9 19 > printh(head(vowels)) ===head(vowels) [1] 0 0 3 0 3 0 > a8 <- earth(ff, vowels, degree=1, trace=2) # x=ordered y=numeric x[30,1] with colname x, and values 19, 20, 1, 20, 9, 19, 20, 9, ... y[30,1] with colname vowels, and values 0, 0, 3, 0, 3, 0, 0, 3, 0, 0,... Forward pass: minspan 3 endspan 7 x[30,1] 240 Bytes bx[30,21] 4.92 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.5906 0.6958 0.6958 1 x 9 2 3 1 4 0.5250 0.7012 0.005454 1 x 19 4 1 6 0.4302 0.7012 0 - reject (no DeltaRsq) RSq changed by less than 0.001 at 5 terms, 4 terms used (DeltaRSq 0) After forward pass GRSq 0.430 RSq 0.701 Forward pass complete: 5 terms, 4 terms used Prune backward penalty 2 nprune null: selected 3 of 4 terms, and 1 of 1 preds After pruning pass GRSq 0.591 RSq 0.696 > printh(summary(a8)) ===summary(a8) Call: earth(x=ff, y=vowels, trace=2, degree=1) coefficients (Intercept) 2.7464305 h(9-x) -0.1445003 h(x-9) -0.2609730 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: x Number of terms at each degree of interaction: 1 2 (additive model) GCV 0.828019 RSS 17.2504 GRSq 0.5906149 RSq 0.6957602 > if (PLOT) + plot(a8, nresponse=1) > plotmo(a8, caption="a8", pt.col=3) > a9 <- earth(vowels, ff, degree=1, trace=2) # x=numeric y=ordered x[30,1] with colname vowels, and values 0, 0, 3, 0, 3, 0, 0, 3, 0, 0,... y[30,1] with colname ff, and values 19, 20, 1, 20, 9, 19, 20, 9, ... Forward pass: minspan 3 endspan 7 x[30,1] 240 Bytes bx[30,21] 4.92 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.3877 0.4693 0.4693 1 vowels 0< 2 1 4 0.2858 0.4693 0 - reject (no DeltaRsq) RSq changed by less than 0.001 at 3 terms, 2 terms used (DeltaRSq 0) After forward pass GRSq 0.286 RSq 0.469 Forward pass complete: 3 terms, 2 terms used Using EvalSubsetsUsingXtx (rather than leaps) because ncol(bx) <= 2 Prune backward penalty 2 nprune null: selected 2 of 2 terms, and 1 of 1 preds After pruning pass GRSq 0.388 RSq 0.469 > if (PLOT) + plot(a9, nresponse=1) > printh(summary(a9)) ===summary(a9) Call: earth(x=vowels, y=ff, trace=2, degree=1) coefficients (Intercept) 17.142857 vowels -3.603175 Selected 2 of 2 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 2 terms Importance: vowels Number of terms at each degree of interaction: 1 1 (additive model) GCV 34.2622 RSS 832.5714 GRSq 0.38772 RSq 0.4692603 > > cat("--- wp argument---------------------------------\n") --- wp argument--------------------------------- > set.seed(79) > NWP <- 100 > x1 <- runif(NWP) > x2 <- runif(NWP) > y1 <- (x1 > .5) + .3 * runif(1) > y2 <- sin(3 * x2) + .3 * runif(1) > myw <- 10 > m <- mars(cbind(x1,x2), cbind(y1, y2)) > me1 <- mars.to.earth(m) Converted mars(x=cbind(x1,x2), y=cbind(y1,y2)) to earth(x=cbind(x1,x2), y=cbind(y1,y2)) > printh(me1) ===me1 Selected 7 of 13 terms, and 2 of 2 predictors Termination condition: Unknown Importance: object has no prune.terms, call update() on the model to fix that Number of terms at each degree of interaction: 1 6 (additive model) GCV RSS GRSq RSq y1 0.0212617234 1.60929985 0.9166455 0.9356280 y2 0.0006116807 0.04629811 0.9940111 0.9953750 All 0.0218734041 1.65559796 0.9390624 0.9529398 > e1 <- earth(cbind(x1,x2), cbind(y1, y2)) > printh(e1) ===e1 Selected 7 of 9 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: x1, x2 Number of terms at each degree of interaction: 1 6 (additive model) GCV RSS GRSq RSq y1 0.0252890017 1.91412454 0.9008570 0.9234350 y2 0.0007586223 0.05742013 0.9925725 0.9942639 All 0.0260476241 1.97154466 0.9270808 0.9436868 > e2 <- earth(cbind(x1,x2), cbind(y1, y2), wp=c(1,1)) > printh(e2) ===e2 Selected 7 of 9 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: x1, x2 Number of terms at each degree of interaction: 1 6 (additive model) GCV RSS GRSq RSq y1 0.0252890017 1.91412454 0.9008570 0.9234350 y2 0.0007586223 0.05742013 0.9925725 0.9942639 All 0.0260476241 1.97154466 0.9270808 0.9436868 > e1$call <- NULL > e2$call <- NULL > e1$wp <- NULL > e2$wp <- NULL > stopifnot(identical(e1, e2)) > e3 <- earth(cbind(x1,x2), cbind(y1, y2), wp=c(.001,1)) > printh(e3) ===e3 Selected 6 of 7 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 7 terms Importance: x2, x1 Number of terms at each degree of interaction: 1 5 (additive model) GCV RSS GRSq RSq y1 0.058039265 4.5972902 0.7724629 0.8161084 y2 0.000297713 0.0235818 0.9970851 0.9976443 All 0.000710793 0.0563019 0.9965256 0.9971920 > wp <- c(1, 2) > e3 <- earth(cbind(x1,x2), cbind(y1, y2), wp=wp) > printh(e3) ===e3 Selected 7 of 9 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: x1, x2 Number of terms at each degree of interaction: 1 6 (additive model) GCV RSS GRSq RSq y1 0.0252890017 1.91412454 0.9008570 0.9234350 y2 0.0007586223 0.05742013 0.9925725 0.9942639 All 0.0178708309 1.35264319 0.9416429 0.9549327 > m3 <- mars(cbind(x1,x2), cbind(y1, y2), wp=wp) > cat("response weights: wp", wp, "earth gcv", e3$gcv, + "mars gcv", m3$gcv, "mars gcv*length(wp)", + m3$gcv * length(wp), "\n") response weights: wp 1 2 earth gcv 0.01787083 mars gcv 0.007495028 mars gcv*length(wp) 0.01499006 > > e4 <- earth(cbind(O3, O3) ~ ., data=ozone1, wp=c(1, .01)) > printh(e4) # both sub models should be the same ===e4 Selected 12 of 20 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, dpg, doy, vh, vis, ibt, ibh, wind Number of terms at each degree of interaction: 1 11 (additive model) GCV RSS GRSq RSq O3 14.61004 4172.671 0.7730502 0.8023874 O3.1 14.61004 4172.671 0.7730502 0.8023874 All 29.22008 8345.342 0.7730502 0.8023874 > printh(summary(e4)) ===summary(e4) Call: earth(formula=cbind(O3,O3)~., data=ozone1, wp=c(1,0.01)) O3 O3.1 (Intercept) 14.1595171 14.1595171 h(5860-vh) -0.0137728 -0.0137728 h(wind-3) -0.3377222 -0.3377222 h(54-humidity) -0.1349547 -0.1349547 h(temp-58) 0.2791320 0.2791320 h(1105-ibh) -0.0033837 -0.0033837 h(dpg-10) -0.0991581 -0.0991581 h(ibt-120) 0.0326330 0.0326330 h(150-vis) 0.0231881 0.0231881 h(96-doy) -0.1105145 -0.1105145 h(doy-96) 0.0406468 0.0406468 h(doy-158) -0.0836732 -0.0836732 Selected 12 of 20 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, dpg, doy, vh, vis, ibt, ibh, wind Number of terms at each degree of interaction: 1 11 (additive model) GCV RSS GRSq RSq O3 14.61004 4172.671 0.7730502 0.8023874 O3.1 14.61004 4172.671 0.7730502 0.8023874 All 29.22008 8345.342 0.7730502 0.8023874 > > # wp with formula interface > e5 <- earth(cbind(O3, wind) ~ ., data=ozone1, wp=c(1, 1)) > printh(e5) ===e5 Selected 12 of 19 terms, and 8 of 8 predictors Termination condition: Reached nk 21 Importance: temp, humidity, dpg, doy, vh, vis, ibh, ibt Number of terms at each degree of interaction: 1 11 (additive model) GCV RSS GRSq RSq O3 14.902776 4256.2781 0.7685029 0.7984278 wind 3.488862 996.4297 0.2238615 0.3241907 All 18.391639 5252.7078 0.7329545 0.7674747 > printh(summary(e5)) ===summary(e5) Call: earth(formula=cbind(O3,wind)~., data=ozone1, wp=c(1,1)) O3 wind (Intercept) 10.5988809 5.6114349 h(5610-vh) -0.0201264 0.0125912 h(vh-5610) 0.0181809 -0.0060755 h(54-humidity) -0.1506629 0.0119373 h(temp-56) 0.2646075 0.0550381 h(1105-ibh) -0.0034196 -0.0008298 h(dpg-13) -0.0954378 0.0046173 h(ibt-120) 0.0336582 -0.0045594 h(150-vis) 0.0217267 -0.0006158 h(96-doy) -0.1307894 -0.0090201 h(doy-158) -0.0418477 0.0043672 h(doy-312) 0.0359320 -0.0570514 Selected 12 of 19 terms, and 8 of 8 predictors Termination condition: Reached nk 21 Importance: temp, humidity, dpg, doy, vh, vis, ibh, ibt Number of terms at each degree of interaction: 1 11 (additive model) GCV RSS GRSq RSq O3 14.902776 4256.2781 0.7685029 0.7984278 wind 3.488862 996.4297 0.2238615 0.3241907 All 18.391639 5252.7078 0.7329545 0.7674747 > e5 <- earth(cbind(O3, wind) ~ ., data=ozone1, wp=c(.3, 1)) > printh(e5) ===e5 Selected 11 of 19 terms, and 7 of 8 predictors Termination condition: Reached nk 21 Importance: temp, ibh, doy, humidity, dpg, vh, vis, ibt-unused Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq O3 15.271877 4418.7094 0.7627693 0.7907353 wind 3.410203 986.6958 0.2413602 0.3307925 All 12.295025 3557.3978 0.6643222 0.7038936 > printh(summary(e5)) ===summary(e5) Call: earth(formula=cbind(O3,wind)~., data=ozone1, wp=c(0.3,1)) O3 wind (Intercept) 7.4506335 4.6371421 h(5610-vh) -0.0141304 0.0118244 h(vh-5610) 0.0175637 -0.0038642 h(humidity-23) 0.0838361 0.0071938 h(temp-55) 0.3675094 0.0292957 h(ibh-1105) -0.0004039 0.0002864 h(dpg-13) -0.0862256 0.0011425 h(150-vis) 0.0197846 -0.0005190 h(96-doy) -0.1367936 -0.0089124 h(doy-150) -0.0391186 0.0036656 h(doy-294) 0.0273699 -0.0421686 Selected 11 of 19 terms, and 7 of 8 predictors Termination condition: Reached nk 21 Importance: temp, ibh, doy, humidity, dpg, vh, vis, ibt-unused Number of terms at each degree of interaction: 1 10 (additive model) GCV RSS GRSq RSq O3 15.271877 4418.7094 0.7627693 0.7907353 wind 3.410203 986.6958 0.2413602 0.3307925 All 12.295025 3557.3978 0.6643222 0.7038936 > # wp with factors > e6 <- earth(pclass ~ ., data=etitanic, degree=2, wp=c(.001,.001,1)) > printh(e6) ===e6 Selected 9 of 18 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, survived, sexmale, sibsp, parch Number of terms at each degree of interaction: 1 5 3 GCV RSS GRSq RSq 1st 0.1498185 150.4809 0.2439951 0.27265613 2nd 0.1876176 188.4472 0.0000000 0.03791987 3rd 0.1888766 189.7117 0.2446010 0.27323905 All 0.5665090 569.0139 0.2444172 0.27306228 > printh(summary(e6)) ===summary(e6) Call: earth(formula=pclass~., data=etitanic, wp=c(0.001,0.001,1), degree=2) 1st 2nd 3rd (Intercept) -0.013576232 0.282485118 0.73109111 survived 0.312918412 0.174952174 -0.48787059 sexmale 0.073351259 0.149478916 -0.22283017 h(age-9) 0.011822473 -0.003165402 -0.00865707 h(1-sibsp) -0.090396669 -0.045506746 0.13590342 h(parch-2) -0.120345986 -0.075313793 0.19565978 survived * sexmale -0.077447025 -0.291809662 0.36925669 h(21-age) * h(sibsp-1) -0.001063853 -0.008028212 0.00909206 h(57-age) * h(2-parch) -0.001527820 -0.001150068 0.00267789 Selected 9 of 18 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, survived, sexmale, sibsp, parch Number of terms at each degree of interaction: 1 5 3 GCV RSS GRSq RSq 1st 0.1498185 150.4809 0.2439951 0.27265613 2nd 0.1876176 188.4472 0.0000000 0.03791987 3rd 0.1888766 189.7117 0.2446010 0.27323905 All 0.5665090 569.0139 0.2444172 0.27306228 > e7 <- earth(pclass ~ ., data=etitanic, degree=2, wp=c(1,.001,.001)) > printh(e7) ===e7 Selected 8 of 17 terms, and 4 of 5 predictors Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale-unused Number of terms at each degree of interaction: 1 3 4 GCV RSS GRSq RSq 1st 0.1446768 146.0263 0.26994041 0.29418743 2nd 0.1903255 192.1007 -0.01442347 0.01926795 3rd 0.1977757 199.6204 0.20900943 0.23528011 All 0.4343262 438.3772 0.26959508 0.29385356 > printh(summary(e7)) ===summary(e7) Call: earth(formula=pclass~., data=etitanic, wp=c(1,0.001,0.001), degree=2) 1st 2nd 3rd (Intercept) 0.11122944 0.208223042 0.68054751 survived 0.36895988 -0.129640255 -0.23931962 h(age-44) 0.03812399 -0.007721391 -0.03040260 h(2-parch) 0.17926095 0.072120537 -0.25138149 survived * h(52-age) -0.00527271 0.006970050 -0.00169734 h(48-age) * h(2-parch) -0.00631659 -0.002155682 0.00847228 h(age-48) * h(2-parch) -0.02034190 0.002942071 0.01739983 h(1-sibsp) * h(1-parch) -0.13130286 -0.036388271 0.16769113 Selected 8 of 17 terms, and 4 of 5 predictors Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale-unused Number of terms at each degree of interaction: 1 3 4 GCV RSS GRSq RSq 1st 0.1446768 146.0263 0.26994041 0.29418743 2nd 0.1903255 192.1007 -0.01442347 0.01926795 3rd 0.1977757 199.6204 0.20900943 0.23528011 All 0.4343262 438.3772 0.26959508 0.29385356 > if (PLOT) + plot(e7, pt.col=as.numeric(etitanic$pclass)+1, nresponse=1) > > cat("--- earth.regress ---------------------------------\n") --- earth.regress --------------------------------- > > msg = "earth.regress with trees data, single response, no weights" > cat("Test:", msg, "\n") Test: earth.regress with trees data, single response, no weights > > data(trees) > y <- trees$Volume > x <- cbind(trees$Girth, trees$Height) > colnames(x) <- c("girth", "height") > > a.lm <- lm(y ~ x) > a.lm.rss <- sum((a.lm$fitted.values - y)^2) > if (is.null(dim(a.lm$coefficients))) + dim(a.lm$coefficients) <- c(length(a.lm$coefficients), 1) > a <- earth:::earth.regress(x, y) > rownames(a.lm$coefficients) <- rownames(a$coefficients) > check.almost.equal(a.lm$coefficients, a$coefficients, msg=paste("coefficients [", msg, "]", sep="")) > check.almost.equal(a.lm.rss, a$rss, msg=paste("rss [", msg, "]")) > check.almost.equal(a.lm$residuals, a$residuals, msg=paste("residuals [", msg, "]")) > > msg = "earth.regress with ozone1 data, multiple responses, no weights" > cat("Test:", msg, "\n") Test: earth.regress with ozone1 data, multiple responses, no weights > > data(ozone1) > y <- cbind(ozone1$O3, ozone1$O3 ^ 2) > colnames(y) <- c("O3", "O32") > x <- cbind(ozone1$wind, ozone1$humidity, ozone1$temp) > colnames(x) <- c("wind", "humidity", "temp") > > a.lm <- lm(y ~ x) > a.lm.rss <- sum((a.lm$fitted.values - y)^2) > a <- earth:::earth.regress(x, y) > rownames(a.lm$coefficients) <- rownames(a$coefficients) > check.almost.equal(a.lm$coefficients, a$coefficients, msg=paste("coefficients [", msg, "]")) > check.almost.equal(a.lm.rss, a$rss, msg=paste("rss [", msg, "]", sep="")) > check.almost.equal(a.lm$residuals, a$residuals, msg=paste("residuals [", msg, "]", sep="")) > > # msg = "earth.regress with ozone1 data, multiple responses with case weights" > # cat("Test:", msg, "\n") > # > # # options(digits=10) > # weights. <- rep(.5, nrow(x)) > # weights.[1] <- 1 > # weights.[2] <- 2 > # weights.[3] <- 3 > # weights.[4] <- 4 > # weights.[5] <- 5 > # a.lm <- lm(y ~ x, weights=weights.) > # # a.lm.rss <- sum((a.lm$fitted.values - y)^2) # line below is equivalent > # a.lm.rss <- sum(a.lm$residuals^2) > # a <- earth:::earth.regress(x, y, weights=weights.) > # rownames(a.lm$coefficients) <- rownames(a$coefficients) > # check.almost.equal(a.lm$coefficients, a$coefficients, msg=paste("coefficients [", msg, "]", sep="")) > # check.almost.equal(a.lm.rss, a$rss, msg=paste("rss [", msg, "]", sep="")) > # check.almost.equal(a.lm$residuals, a$residuals, msg=paste("residuals [", msg, "]", sep="")) > > # msg = "earth.regress case weights with zero weights 1" > # cat("Test:", msg, "\n") > # > # weights. <- rep(1, nrow(x)) > # weights.[2] <- 0 > # weights.[4] <- 0 > # a.lm <- lm(y ~ x, weights=weights.) > # # a.lm.rss <- sum((a.lm$fitted.values - y)^2) # line below is equivalent > # a.lm.rss <- sum(a.lm$residuals^2) > # a <- earth:::earth.regress(x, y, weights=weights.) > # rownames(a.lm$coefficients) <- rownames(a$coefficients) > # # options(digits=10) > # check.almost.equal(a.lm$coefficients, a$coefficients, msg=paste("coefficients [", msg, "]", sep="")) > # check.almost.equal(a.lm.rss, a$rss, msg=paste("rss [", msg, "]", sep="")) > # check.almost.equal(a.lm$residuals, a$residuals, max=1e-6, msg=paste("residuals [", msg, "]", sep="")) > # > # msg = "earth.regress case weights with zero weights 2" > # cat("Test:", msg, "\n") > # weights. <- rep(1, nrow(x)) > # weights.[5] <- 0 > # weights.[6] <- 0 > # weights.[7] <- 0 > # weights.[21] <- 0 > # weights.[22] <- 0 > # weights.[23] <- 0 > # weights.[24] <- 0 > # weights.[25] <- 0 > # weights.[26] <- 0 > # weights.[27] <- 0 > # a.lm <- lm(y ~ x, weights=weights.) > # # a.lm.rss <- sum((a.lm$fitted.values - y)^2) # line below is equivalent > # a.lm.rss <- sum(a.lm$residuals^2) > # a <- earth:::earth.regress(x, y, weights=weights.) > # rownames(a.lm$coefficients) <- rownames(a$coefficients) > # check.almost.equal(a.lm$coefficients, a$coefficients, msg=paste("coefficients [", msg, "]", sep="")) > # check.almost.equal(a.lm.rss, a$rss, msg=paste("rss [", msg, "]", sep="")) > # check.almost.equal(a.lm$residuals, a$residuals, max=1e-6, msg=paste("residuals [", msg, "]", sep="")) > # > # msg = "earth.regress case weights with zero weights and missing columns 1" > # cat("Test:", msg, "\n") > # x <- cbind(ozone1$wind, ozone1$humidity, ozone1$temp, ozone1$wind^2, ozone1$humidity^2, ozone1$temp^2) > # weights. <- rep(1, nrow(x)) > # weights.[5] <- 0 > # weights.[6] <- 0 > # weights.[7] <- 0 > # weights.[21] <- 0 > # weights.[22] <- 0 > # weights.[23] <- 0 > # weights.[24] <- 0 > # weights.[25] <- 0 > # weights.[26] <- 0 > # weights.[27] <- 0 > # colnames(x) <- c("wind", "humidity", "temp", "wind2", "humidity2", "temp2") > # used.cols = as.logical(c(1,0,1,0,1,1)) > # x.missing <- x[,used.cols] > # a.lm <- lm(y ~ x.missing, weights=weights.) > # a.lm.rss <- sum((a.lm$fitted.values - y)^2) # line below is equivalent > # a.lm.rss <- sum(a.lm$residuals^2) > # a <- earth:::earth.regress(x, y, weights=weights., used.cols=used.cols) > # rownames(a.lm$coefficients) <- rownames(a$coefficients) > # check.almost.equal(a.lm$coefficients, a$coefficients, msg=paste("coefficients [", msg, "]", sep="")) > # check.almost.equal(a.lm.rss, a$rss, msg=paste("rss [", msg, "]", sep="")) > # check.almost.equal(a.lm$residuals, a$residuals, max=1e-6, msg=paste("residuals [", msg, "]", sep="")) > # > # msg = "earth.regress case weights with zero weights and missing columns 2" > # cat("Test:", msg, "\n") > # x <- cbind(ozone1$wind, ozone1$humidity, ozone1$temp, ozone1$wind^2, ozone1$humidity^2, ozone1$temp^2) > # weights. <- rep(1, nrow(x)) > # weights.[5] <- .1 > # weights.[6] <- .2 > # weights.[7] <- 1.9 > # weights.[21] <- .59 > # colnames(x) <- c("wind", "humidity", "temp", "wind2", "humidity2", "temp2") > # used.cols = as.logical(c(0,1,0,0,1,0)) > # x.missing <- x[,used.cols] > # a.lm <- lm(y ~ x.missing, weights=weights.) > # a.lm.rss <- sum((a.lm$fitted.values - y)^2) # line below is equivalent > # a.lm.rss <- sum(a.lm$residuals^2) > # a <- earth:::earth.regress(x, y, weights=weights., used.cols=used.cols) > # rownames(a.lm$coefficients) <- rownames(a$coefficients) > # check.almost.equal(a.lm$coefficients, a$coefficients, msg=paste("coefficients [", msg, "]", sep="")) > # check.almost.equal(a.lm.rss, a$rss, msg=paste("rss [", msg, "]", sep="")) > # check.almost.equal(a.lm$residuals, a$residuals, max=1e-6, msg=paste("residuals [", msg, "]", sep="")) > > cat("---standard method functions ------------------------\n") ---standard method functions ------------------------ > > short.etitanic <- etitanic[seq(from=1, to=1000, by=20),] > a1 <- earth(pclass ~ ., data=short.etitanic, glm=list(family=binomial), trace=0) > printh(variable.names(a1)) ===variable.names(a1) [1] "survived" "sexmale" "age" "sibsp" "parch" > printh(case.names(a1)) ===case.names(a1) [1] "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12" "13" "14" "15" [16] "16" "17" "18" "19" "20" "21" "22" "23" "24" "25" "26" "27" "28" "29" "30" [31] "31" "32" "33" "34" "35" "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" [46] "46" "47" "48" "49" "50" > printh(case.names(a1, use.names=FALSE)) ===case.names(a1, use.names = FALSE) [1] "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12" "13" "14" "15" [16] "16" "17" "18" "19" "20" "21" "22" "23" "24" "25" "26" "27" "28" "29" "30" [31] "31" "32" "33" "34" "35" "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" [46] "46" "47" "48" "49" "50" > > named.short.etitanic <- short.etitanic > rownames(named.short.etitanic) <- paste("xx", 1:nrow(named.short.etitanic)) > a2 <- earth(pclass ~ ., data=named.short.etitanic, glm=list(family=binomial), trace=0) > printh(variable.names(a2)) ===variable.names(a2) [1] "survived" "sexmale" "age" "sibsp" "parch" > printh(case.names(a2)) ===case.names(a2) [1] "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12" "13" "14" "15" [16] "16" "17" "18" "19" "20" "21" "22" "23" "24" "25" "26" "27" "28" "29" "30" [31] "31" "32" "33" "34" "35" "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" [46] "46" "47" "48" "49" "50" > printh(case.names(a2, use.names=FALSE)) ===case.names(a2, use.names = FALSE) [1] "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12" "13" "14" "15" [16] "16" "17" "18" "19" "20" "21" "22" "23" "24" "25" "26" "27" "28" "29" "30" [31] "31" "32" "33" "34" "35" "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" [46] "46" "47" "48" "49" "50" > > printh(deviance(a1), expect.warning=TRUE) ===deviance(a1) expect warning -->Warning: deviance.earth: returning earth (not GLM) deviance [1] 25.48701 > printh(deviance(a1, warn=FALSE)) ===deviance(a1, warn = FALSE) [1] 25.48701 > printh(effects(a1), expect.warning=TRUE) ===effects(a1) expect warning -->Warning: effects.earth: returning NULL NULL > printh(effects(a1, warn=FALSE)) ===effects(a1, warn = FALSE) NULL > printh(family(a1)) ===family(a1) Family: binomial Link function: logit > printh(anova(a1), expect.warning=TRUE) ===anova(a1) expect warning -->Warning: anova.earth: returning NULL NULL > printh(anova(a1, warn=FALSE)) ===anova(a1, warn = FALSE) NULL > printh(family(a1)) ===family(a1) Family: binomial Link function: logit > > # TODO removed because causes different results on different machines > # cat("--- thresh=0 -----------------------------------------\n") > # > # a.no.thresh <- earth(O3 ~ ., data = ozone1, thresh=0, nk=1000, degree=2, trace=4) > # printh(a.no.thresh) > # printh(summary(a.no.thresh)) > # plotmo(a.no.thresh, degree1=1, degree2=c(4,9,16), clip=0, , caption="test with thresh=0", trace=-1) > > # test the way plotmo gets the data with earth with a formula interface > # use strange data name se to make sure eval gets correct environment (don't pick up se in plotmo) > se <- ozone1 > a <- earth(O3 ~ ., data=se, degree=2, keepxy=0) > printh(summary(a)) ===summary(a) Call: earth(formula=O3~., data=se, keepxy=0, degree=2) coefficients (Intercept) 13.2169900 h(temp-58) 0.3726072 h(194-ibt) -0.0455100 h(200-vis) 0.0222462 h(96-doy) -0.1223029 h(doy-96) -0.0240235 h(5730-vh) * h(temp-58) -0.0104496 h(wind-7) * h(200-vis) -0.0180898 h(55-humidity) * h(temp-58) -0.0222754 h(temp-58) * h(dpg-52) -0.0168249 h(temp-58) * h(52-dpg) 0.0041232 h(1105-ibh) * h(21-dpg) -0.0001022 Selected 12 of 21 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, ibh, dpg, vis, wind, vh Number of terms at each degree of interaction: 1 5 6 GCV 13.40805 RSS 3693.401 GRSq 0.7917216 RSq 0.825085 > plotmo(a, trace=2, caption="getdata earth test1") plotmo trace 2: plotmo(object=a, caption="getdata earth test1", trace=2) object call is earth(formula=O3~., data=se, keepxy=0, degree=2) --get.model.env for earth object using the environment saved with the earth model: R_GlobalEnv --plotmo_prolog for earth object 'a' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=O3~., data=se, keepxy=0, degree=2) get.x.from.model.frame: formula(object) is O3~vh+wind+humidity+temp+ibh+dpg+ibt+vis+doy naked formula is the same formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(O3~vh+wind+humidity+temp+ibh+dpg+ibt+..., data=call$data, na.action="na.fail") x=model.frame[,-1] is usable and has column names vh wind humidity temp ibh dpg ibt vis doy plotmo_x returned[330,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5710 4 28 40 2693 -25 87 250 33 2 5700 3 37 45 590 -24 128 100 34 3 5760 3 51 54 1450 25 139 60 35 ... 5720 4 69 35 1568 15 121 60 36 330 5550 4 85 39 5000 8 44 100 390 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[330,1]: O3 1 0.6423433 2 2.4875500 3 6.3679385 ... 5.6710623 330 1.5521976 predict after processing with nresponse=NULL is [330,1]: O3 1 0.6423433 2 2.4875500 3 6.3679385 ... 5.6710623 330 1.5521976 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[330,1]: O3 1 0.6423433 2 2.4875500 3 6.3679385 ... 5.6710623 330 1.5521976 fitted(object) after processing with nresponse=NULL is [330,1]: O3 1 0.6423433 2 2.4875500 3 6.3679385 ... 5.6710623 330 1.5521976 ----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=se, keepxy=0, degree=2) get.y.from.model.frame: formula(object) is O3~vh+wind+humidity+temp+ibh+dpg+ibt+vis+doy naked formula is the same formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(O3~vh+wind+humidity+temp+ibh+dpg+ibt+..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name O3 plotmo_y returned[330,1]: O3 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=NULL is [330,1]: O3 1 3 2 5 3 5 ... 6 330 1 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=O3~., data=se, keepxy=0, degree=2) get.y.from.model.frame: formula(object) is O3~vh+wind+humidity+temp+ibh+dpg+ibt+vis+doy formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(O3~vh+wind+humidity+temp+ibh+dpg+ibt+..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name O3 got model response from model.frame(O3~vh+wind+humidity+temp+ibh+dpg+ibt+..., data=call$data, na.action="na.fail") plotmo_y returned[330,1]: O3 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=1 is [330,1]: O3 1 3 2 5 3 5 ... 6 330 1 got response name "O3" from yhat resp.levs is NULL ----Metadata: done number of x values: vh 53 wind 11 humidity 65 temp 63 ibh 196 dpg 128 ibt 193... ----plotmo_singles for earth object singles: 4 temp, 7 ibt, 8 vis, 9 doy ----plotmo_pairs for earth object pairs: [,1] [,2] [1,] "1 vh" "4 temp" [2,] "2 wind" "8 vis" [3,] "3 humidity" "4 temp" [4,] "4 temp" "6 dpg" [5,] "5 ibh" "6 dpg" 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,4,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 11.16010 2 11.16010 3 11.16010 ... 11.16010 50 28.24212 predict after processing with nresponse=1 is [50,1]: O3 1 11.16010 2 11.16010 3 11.16010 ... 11.16010 50 28.24212 Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "plotmo") variable ibt degree1 plot3 (pmethod "plotmo") variable vis degree1 plot4 (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 11.16010 2 11.16010 3 11.16010 ... 11.16010 400 28.24212 predict after processing with nresponse=1 is [400,1]: O3 1 11.16010 2 11.16010 3 11.16010 ... 11.16010 400 28.24212 Reducing trace level for subsequent degree2 plots degree2 plot2 (pmethod "plotmo") variables wind:vis degree2 plot3 (pmethod "plotmo") variables humidity:temp degree2 plot4 (pmethod "plotmo") variables temp:dpg degree2 plot5 (pmethod "plotmo") variables ibh:dpg --done get.ylim.by.dummy.plots ylim c(-15.89, 38.55) 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(11.16,11.16,1...), type="n", main="1 temp", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(25,93), ylim=c(-15.89,38.55)) --plot.degree2(draw.plot=TRUE) persp(vh:temp) theta -35 persp(wind:vis) theta 145 persp(humidity:temp) theta -35 persp(temp:dpg) theta 235 persp(ibh:dpg) theta 235 > a <- earth(O3 ~ ., data=se, degree=2, keepxy=1) > printh(summary(a)) ===summary(a) Call: earth(formula=O3~., data=se, keepxy=1, degree=2) coefficients (Intercept) 13.2169900 h(temp-58) 0.3726072 h(194-ibt) -0.0455100 h(200-vis) 0.0222462 h(96-doy) -0.1223029 h(doy-96) -0.0240235 h(5730-vh) * h(temp-58) -0.0104496 h(wind-7) * h(200-vis) -0.0180898 h(55-humidity) * h(temp-58) -0.0222754 h(temp-58) * h(dpg-52) -0.0168249 h(temp-58) * h(52-dpg) 0.0041232 h(1105-ibh) * h(21-dpg) -0.0001022 Selected 12 of 21 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, ibh, dpg, vis, wind, vh Number of terms at each degree of interaction: 1 5 6 GCV 13.40805 RSS 3693.401 GRSq 0.7917216 RSq 0.825085 > plotmo(a, trace=1, caption="getdata earth test2") 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 > a <- earth(O3 ~ ., data=se, degree=2, keepxy=1) > se <- NULL > printh(summary(a)) ===summary(a) Call: earth(formula=O3~., data=se, keepxy=1, degree=2) coefficients (Intercept) 13.2169900 h(temp-58) 0.3726072 h(194-ibt) -0.0455100 h(200-vis) 0.0222462 h(96-doy) -0.1223029 h(doy-96) -0.0240235 h(5730-vh) * h(temp-58) -0.0104496 h(wind-7) * h(200-vis) -0.0180898 h(55-humidity) * h(temp-58) -0.0222754 h(temp-58) * h(dpg-52) -0.0168249 h(temp-58) * h(52-dpg) 0.0041232 h(1105-ibh) * h(21-dpg) -0.0001022 Selected 12 of 21 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, ibh, dpg, vis, wind, vh Number of terms at each degree of interaction: 1 5 6 GCV 13.40805 RSS 3693.401 GRSq 0.7917216 RSq 0.825085 > plotmo(a, trace=2, caption="getdata earth test3") plotmo trace 2: plotmo(object=a, caption="getdata earth test3", trace=2) object call is earth(formula=O3~., data=se, keepxy=1, degree=2) --get.model.env for earth object using the environment saved with the earth model: R_GlobalEnv --plotmo_prolog for earth object 'a' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=O3~., data=se, keepxy=1, degree=2) get.x.from.model.frame: formula(object) is O3~vh+wind+humidity+temp+ibh+dpg+ibt+vis+doy naked formula is the same formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(O3~vh+wind+humidity+temp+ibh+dpg+ibt+..., data=object$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 0.6423433 2 2.4875500 3 6.3679385 ... 5.6710623 330 1.5521976 predict after processing with nresponse=NULL is [330,1]: O3 1 0.6423433 2 2.4875500 3 6.3679385 ... 5.6710623 330 1.5521976 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[330,1]: O3 1 0.6423433 2 2.4875500 3 6.3679385 ... 5.6710623 330 1.5521976 fitted(object) after processing with nresponse=NULL is [330,1]: O3 1 0.6423433 2 2.4875500 3 6.3679385 ... 5.6710623 330 1.5521976 ----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 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 usable and has column name O3 got model response from object$y 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, 7 ibt, 8 vis, 9 doy ----plotmo_pairs for earth object pairs: [,1] [,2] [1,] "1 vh" "4 temp" [2,] "2 wind" "8 vis" [3,] "3 humidity" "4 temp" [4,] "4 temp" "6 dpg" [5,] "5 ibh" "6 dpg" 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,4,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 11.16010 2 11.16010 3 11.16010 ... 11.16010 50 28.24212 predict after processing with nresponse=1 is [50,1]: O3 1 11.16010 2 11.16010 3 11.16010 ... 11.16010 50 28.24212 Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "plotmo") variable ibt degree1 plot3 (pmethod "plotmo") variable vis degree1 plot4 (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 11.16010 2 11.16010 3 11.16010 ... 11.16010 400 28.24212 predict after processing with nresponse=1 is [400,1]: O3 1 11.16010 2 11.16010 3 11.16010 ... 11.16010 400 28.24212 Reducing trace level for subsequent degree2 plots degree2 plot2 (pmethod "plotmo") variables wind:vis degree2 plot3 (pmethod "plotmo") variables humidity:temp degree2 plot4 (pmethod "plotmo") variables temp:dpg degree2 plot5 (pmethod "plotmo") variables ibh:dpg --done get.ylim.by.dummy.plots ylim c(-15.89, 38.55) 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(11.16,11.16,1...), type="n", main="1 temp", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(25,93), ylim=c(-15.89,38.55)) --plot.degree2(draw.plot=TRUE) persp(vh:temp) theta -35 persp(wind:vis) theta 145 persp(humidity:temp) theta -35 persp(temp:dpg) theta 235 persp(ibh:dpg) theta 235 > se <- ozone1 > a <- earth(O3 ~ ., data=se, degree=2, keepxy=0) > se <- NULL > printh(summary(a)) ===summary(a) Call: earth(formula=O3~., data=se, keepxy=0, degree=2) coefficients (Intercept) 13.2169900 h(temp-58) 0.3726072 h(194-ibt) -0.0455100 h(200-vis) 0.0222462 h(96-doy) -0.1223029 h(doy-96) -0.0240235 h(5730-vh) * h(temp-58) -0.0104496 h(wind-7) * h(200-vis) -0.0180898 h(55-humidity) * h(temp-58) -0.0222754 h(temp-58) * h(dpg-52) -0.0168249 h(temp-58) * h(52-dpg) 0.0041232 h(1105-ibh) * h(21-dpg) -0.0001022 Selected 12 of 21 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, ibh, dpg, vis, wind, vh Number of terms at each degree of interaction: 1 5 6 GCV 13.40805 RSS 3693.401 GRSq 0.7917216 RSq 0.825085 > expect.err(try(plotmo(a, trace=0, caption="getdata earth test4")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'O3' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got error as expected from try(plotmo(a, trace = 0, caption = "getdata earth test4")) > > # test the way plotmo gets the data with earth with the default interface > se <- ozone1 > a <- earth(se[,2:10], se[,1], degree=2, keepxy=0) > printh(summary(a)) ===summary(a) Call: earth(x=se[,2:10], y=se[,1], keepxy=0, degree=2) coefficients (Intercept) 13.2169900 h(temp-58) 0.3726072 h(194-ibt) -0.0455100 h(200-vis) 0.0222462 h(96-doy) -0.1223029 h(doy-96) -0.0240235 h(5730-vh) * h(temp-58) -0.0104496 h(wind-7) * h(200-vis) -0.0180898 h(55-humidity) * h(temp-58) -0.0222754 h(temp-58) * h(dpg-52) -0.0168249 h(temp-58) * h(52-dpg) 0.0041232 h(1105-ibh) * h(21-dpg) -0.0001022 Selected 12 of 21 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, ibh, dpg, vis, wind, vh Number of terms at each degree of interaction: 1 5 6 GCV 13.40805 RSS 3693.401 GRSq 0.7917216 RSq 0.825085 > plotmo(a, trace=0, caption="getdata earth test5") 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(se[,2:10], se[,1], degree=2, keepxy=1) > printh(summary(a)) ===summary(a) Call: earth(x=se[,2:10], y=se[,1], keepxy=1, degree=2) coefficients (Intercept) 13.2169900 h(temp-58) 0.3726072 h(194-ibt) -0.0455100 h(200-vis) 0.0222462 h(96-doy) -0.1223029 h(doy-96) -0.0240235 h(5730-vh) * h(temp-58) -0.0104496 h(wind-7) * h(200-vis) -0.0180898 h(55-humidity) * h(temp-58) -0.0222754 h(temp-58) * h(dpg-52) -0.0168249 h(temp-58) * h(52-dpg) 0.0041232 h(1105-ibh) * h(21-dpg) -0.0001022 Selected 12 of 21 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, ibh, dpg, vis, wind, vh Number of terms at each degree of interaction: 1 5 6 GCV 13.40805 RSS 3693.401 GRSq 0.7917216 RSq 0.825085 > plotmo(a, trace=0, caption="getdata earth test6") 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(se[,2:10], se[,1], degree=2, keepxy=1) > se <- NULL > printh(summary(a)) ===summary(a) Call: earth(x=se[,2:10], y=se[,1], keepxy=1, degree=2) coefficients (Intercept) 13.2169900 h(temp-58) 0.3726072 h(194-ibt) -0.0455100 h(200-vis) 0.0222462 h(96-doy) -0.1223029 h(doy-96) -0.0240235 h(5730-vh) * h(temp-58) -0.0104496 h(wind-7) * h(200-vis) -0.0180898 h(55-humidity) * h(temp-58) -0.0222754 h(temp-58) * h(dpg-52) -0.0168249 h(temp-58) * h(52-dpg) 0.0041232 h(1105-ibh) * h(21-dpg) -0.0001022 Selected 12 of 21 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, ibh, dpg, vis, wind, vh Number of terms at each degree of interaction: 1 5 6 GCV 13.40805 RSS 3693.401 GRSq 0.7917216 RSq 0.825085 > plotmo(a, trace=0, caption="getdata earth test7") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > se <- ozone1 > a <- earth(se[,2:10], se[,1], degree=2, keepxy=0) > se <- NULL > expect.err(try(plotmo(a, trace=0, caption="getdata earth test8")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: no formula in getCall(object) (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got error as expected from try(plotmo(a, trace = 0, caption = "getdata earth test8")) > se <- ozone1 > a <- earth(se[,2:10], se[,1], degree=2, keepxy=0) > # TODO error message could be improved here > se$vh <- NULL # vh is unused (but plotmo still needs it --- why?) > expect.err(try(plotmo(a, trace=0, caption="getdata earth test9")), "cannot get the original model predictors") # plotmo.x.default cannot get the x matrix 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: undefined columns selected Error : cannot get the original model predictors Got error as expected from try(plotmo(a, trace = 0, caption = "getdata earth test9")) > se <- ozone1 > a <- earth(se[,2:10], se[,1], degree=2, keepxy=TRUE) > se$vh <- NULL # vh is unused (but plotmo still needs it --- why?) > printh(summary(a)) ===summary(a) Call: earth(x=se[,2:10], y=se[,1], keepxy=TRUE, degree=2) coefficients (Intercept) 13.2169900 h(temp-58) 0.3726072 h(194-ibt) -0.0455100 h(200-vis) 0.0222462 h(96-doy) -0.1223029 h(doy-96) -0.0240235 h(5730-vh) * h(temp-58) -0.0104496 h(wind-7) * h(200-vis) -0.0180898 h(55-humidity) * h(temp-58) -0.0222754 h(temp-58) * h(dpg-52) -0.0168249 h(temp-58) * h(52-dpg) 0.0041232 h(1105-ibh) * h(21-dpg) -0.0001022 Selected 12 of 21 terms, and 9 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, ibh, dpg, vis, wind, vh Number of terms at each degree of interaction: 1 5 6 GCV 13.40805 RSS 3693.401 GRSq 0.7917216 RSq 0.825085 > plotmo(a, trace=0, caption="getdata earth test9") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > # test the way plotmo gets the data with lm > se <- ozone1 > a <- lm(O3 ~ ., data=se) > printh(summary(a)) ===summary(a) Call: lm(formula = O3 ~ ., data = se) Residuals: Min 1Q Median 3Q Max -12.1011 -2.9289 -0.2715 2.7080 13.3687 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 20.3135755 29.5193067 0.688 0.49186 vh -0.0054271 0.0053985 -1.005 0.31551 wind -0.0545832 0.1348425 -0.405 0.68590 humidity 0.0809741 0.0188394 4.298 2.29e-05 *** temp 0.2755492 0.0497912 5.534 6.52e-08 *** ibh -0.0002338 0.0002956 -0.791 0.42944 dpg -0.0033629 0.0112805 -0.298 0.76581 ibt 0.0296411 0.0136088 2.178 0.03013 * vis -0.0079910 0.0037503 -2.131 0.03387 * doy -0.0091194 0.0027745 -3.287 0.00113 ** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 4.441 on 320 degrees of freedom Multiple R-squared: 0.7012, Adjusted R-squared: 0.6927 F-statistic: 83.42 on 9 and 320 DF, p-value: < 2.2e-16 > plotmo(a, trace=0, caption="getdata lm test1") 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(O3 ~ ., data=se, x=1) > printh(summary(a)) ===summary(a) Call: lm(formula = O3 ~ ., data = se, x = 1) Residuals: Min 1Q Median 3Q Max -12.1011 -2.9289 -0.2715 2.7080 13.3687 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 20.3135755 29.5193067 0.688 0.49186 vh -0.0054271 0.0053985 -1.005 0.31551 wind -0.0545832 0.1348425 -0.405 0.68590 humidity 0.0809741 0.0188394 4.298 2.29e-05 *** temp 0.2755492 0.0497912 5.534 6.52e-08 *** ibh -0.0002338 0.0002956 -0.791 0.42944 dpg -0.0033629 0.0112805 -0.298 0.76581 ibt 0.0296411 0.0136088 2.178 0.03013 * vis -0.0079910 0.0037503 -2.131 0.03387 * doy -0.0091194 0.0027745 -3.287 0.00113 ** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 4.441 on 320 degrees of freedom Multiple R-squared: 0.7012, Adjusted R-squared: 0.6927 F-statistic: 83.42 on 9 and 320 DF, p-value: < 2.2e-16 > plotmo(a, trace=0, caption="getdata lm test2") 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(O3 ~ ., data=se, y=1) > printh(summary(a)) ===summary(a) Call: lm(formula = O3 ~ ., data = se, y = 1) Residuals: Min 1Q Median 3Q Max -12.1011 -2.9289 -0.2715 2.7080 13.3687 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 20.3135755 29.5193067 0.688 0.49186 vh -0.0054271 0.0053985 -1.005 0.31551 wind -0.0545832 0.1348425 -0.405 0.68590 humidity 0.0809741 0.0188394 4.298 2.29e-05 *** temp 0.2755492 0.0497912 5.534 6.52e-08 *** ibh -0.0002338 0.0002956 -0.791 0.42944 dpg -0.0033629 0.0112805 -0.298 0.76581 ibt 0.0296411 0.0136088 2.178 0.03013 * vis -0.0079910 0.0037503 -2.131 0.03387 * doy -0.0091194 0.0027745 -3.287 0.00113 ** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 4.441 on 320 degrees of freedom Multiple R-squared: 0.7012, Adjusted R-squared: 0.6927 F-statistic: 83.42 on 9 and 320 DF, p-value: < 2.2e-16 > plotmo(a, trace=0, caption="getdata lm test3") 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(O3 ~ ., data=se, x=1, y=1) > printh(summary(a)) ===summary(a) Call: lm(formula = O3 ~ ., data = se, x = 1, y = 1) Residuals: Min 1Q Median 3Q Max -12.1011 -2.9289 -0.2715 2.7080 13.3687 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 20.3135755 29.5193067 0.688 0.49186 vh -0.0054271 0.0053985 -1.005 0.31551 wind -0.0545832 0.1348425 -0.405 0.68590 humidity 0.0809741 0.0188394 4.298 2.29e-05 *** temp 0.2755492 0.0497912 5.534 6.52e-08 *** ibh -0.0002338 0.0002956 -0.791 0.42944 dpg -0.0033629 0.0112805 -0.298 0.76581 ibt 0.0296411 0.0136088 2.178 0.03013 * vis -0.0079910 0.0037503 -2.131 0.03387 * doy -0.0091194 0.0027745 -3.287 0.00113 ** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 4.441 on 320 degrees of freedom Multiple R-squared: 0.7012, Adjusted R-squared: 0.6927 F-statistic: 83.42 on 9 and 320 DF, p-value: < 2.2e-16 > plotmo(a, trace=0, caption="getdata lm test3") 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(O3 ~ ., data=se, x=0, y=1, model=F) > se <- 99 > expect.err(try(plotmo(a, trace=0, caption="getdata lm test4")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'O3' not found (3) getCall(object)$x: less than three rows Error : cannot get the original model predictors Got error as expected from try(plotmo(a, trace = 0, caption = "getdata lm test4")) > se <- ozone1 > a <- lm(O3 ~ ., data=se, x=1, y=1) > se <- 77 > printh(summary(a)) ===summary(a) Call: lm(formula = O3 ~ ., data = se, x = 1, y = 1) Residuals: Min 1Q Median 3Q Max -12.1011 -2.9289 -0.2715 2.7080 13.3687 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 20.3135755 29.5193067 0.688 0.49186 vh -0.0054271 0.0053985 -1.005 0.31551 wind -0.0545832 0.1348425 -0.405 0.68590 humidity 0.0809741 0.0188394 4.298 2.29e-05 *** temp 0.2755492 0.0497912 5.534 6.52e-08 *** ibh -0.0002338 0.0002956 -0.791 0.42944 dpg -0.0033629 0.0112805 -0.298 0.76581 ibt 0.0296411 0.0136088 2.178 0.03013 * vis -0.0079910 0.0037503 -2.131 0.03387 * doy -0.0091194 0.0027745 -3.287 0.00113 ** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 4.441 on 320 degrees of freedom Multiple R-squared: 0.7012, Adjusted R-squared: 0.6927 F-statistic: 83.42 on 9 and 320 DF, p-value: < 2.2e-16 > plotmo(a, trace=0, caption="getdata lm test5") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > se <- ozone1 > a <- lm(O3 ~ ., data=se, model=F) > se$wind <- NULL > expect.err(try(plotmo(a, trace=0, caption="getdata lm test6")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'wind' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got error as expected from try(plotmo(a, trace = 0, caption = "getdata lm test6")) > > cat("test fixed.point warning in print.summary.earth\n") test fixed.point warning in print.summary.earth > options(digits=3) > et <- etitanic > et$age <- 1000 * et$age > a <- earth(survived~., data=et) > print(summary(a)) Call: earth(formula=survived~., data=et) coefficients (Intercept) 1.0258 pclass2nd -0.2165 pclass3rd -0.3552 sexmale -0.4903 h(11000-age) 0.0000 h(age-11000) 0.0000 h(sibsp-1) -0.0926 Selected 7 of 10 terms, and 5 of 6 predictors Termination condition: RSq changed by less than 0.001 at 10 terms Importance: sexmale, pclass3rd, age, pclass2nd, sibsp, parch-unused Number of terms at each degree of interaction: 1 6 (additive model) GCV 0.152 RSS 155 GRSq 0.372 RSq 0.386 > print(summary(a, fixed.point=FALSE)) Call: earth(formula=survived~., data=et) coefficients (Intercept) 1.03e+00 pclass2nd -2.17e-01 pclass3rd -3.55e-01 sexmale -4.90e-01 h(11000-age) 2.92e-05 h(age-11000) -4.45e-06 h(sibsp-1) -9.26e-02 Selected 7 of 10 terms, and 5 of 6 predictors Termination condition: RSq changed by less than 0.001 at 10 terms Importance: sexmale, pclass3rd, age, pclass2nd, sibsp, parch-unused Number of terms at each degree of interaction: 1 6 (additive model) GCV 0.152 RSS 155 GRSq 0.372 RSq 0.386 > options(digits=7) # back to default > > cat("--- summary earth with new data ----------------------\n") --- summary earth with new data ---------------------- > a.trees <- earth(Volume~., data=trees) > cat("summary(a.trees, newdata=trees)\n") summary(a.trees, newdata=trees) > print(summary(a.trees, newdata=trees)) RSq 0.974 on newdata (31 cases) > cat("summary(a.trees, newdata=trees[1:5,])\n") summary(a.trees, newdata=trees[1:5,]) > a.trees.summary <- print(summary(a.trees, newdata=trees[1:5,])) RSq 0.919 on newdata (5 cases) > > a.xy.trees <- earth(trees[,1:2], trees[,3]) > cat("summary(a.xy.trees, newdata=trees[1:5,])\n") summary(a.xy.trees, newdata=trees[1:5,]) > a.xy.trees.summary <- print(summary(a.xy.trees, newdata=trees[1:5,])) Assuming response trees[,3] implies that the response column is 3 RSq 0.919 on newdata (5 cases) > stopifnot(a.xy.trees.summary$newrsq == a.trees.summary$newrsq) > > a.xy1.trees <- earth(trees[,1:2], trees$Volume) > cat("summary(a.xy1.trees, newdata=trees[1:5,])\n") summary(a.xy1.trees, newdata=trees[1:5,]) > a.xy1.trees.summary <- print(summary(a.xy1.trees, newdata=trees[1:5,])) RSq 0.919 on newdata (5 cases) > stopifnot(a.xy1.trees.summary$newrsq == a.trees.summary$newrsq) > > cat("--- ../../tests/test.earth.R -------------------------\n") --- ../../tests/test.earth.R ------------------------- > > options(options.old) > source("../../tests/test.earth.R") Call: earth(formula=Volume~., data=trees) coefficients (Intercept) 29.060 h(14.2-Girth) -3.420 h(Girth-14.2) 6.230 h(Height-75) 0.581 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.3 RSS 209 GRSq 0.96 RSq 0.974 x[31,2] with colnames Girth Height y[31,1] with colname Volume, and values 10.3, 10.3, 10.2, 16.4, 18.8,... Forward pass term 1, 2, 4 RSq changed by less than 0.001 at 3 terms (DeltaRSq 9.7e-05) After forward pass GRSq 0.940 RSq 0.962 Prune backward penalty 2 nprune null: selected 3 of 3 terms, and 1 of 2 preds After pruning pass GRSq 0.949 RSq 0.961 Call: earth(formula=Volume~., data=trees, trace=1, allowed=allowed.func) coefficients (Intercept) 30.66 h(14.2-Girth) -3.57 h(Girth-14.2) 6.76 Selected 3 of 3 terms, and 1 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: Girth, Height-unused Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.3 RSS 313 GRSq 0.949 RSq 0.961 Call: earth(formula=Sepal.Length+Sepal.Width~Species, data=iris) Sepal.Length Sepal.Width (Intercept) 5.01 3.428 Speciesversicolor 0.93 -0.658 Speciesvirginica 1.58 -0.454 Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: Speciesvirginica, Speciesversicolor Number of terms at each degree of interaction: 1 2 (additive model) GCV RSS GRSq RSq Sepal.Length 0.278 39.0 0.597 0.619 Sepal.Width 0.121 17.0 0.367 0.401 All 0.399 55.9 0.547 0.571 > > cat("--- check that spurious warn gone: non-integer #successes in a binomial glm ---\n") --- check that spurious warn gone: non-integer #successes in a binomial glm --- > > library(segmented) # for down data > data(down) > fit.e <- earth(cases/births~age, data=down, weights=down$births, glm=list(family="binomial")) > print(summary(fit.e)) Call: earth(formula=cases/births~age, data=down, weights=down$births, glm=list(family="binomial")) GLM coefficients cases/births (Intercept) -6.943 h(age-36.5) 0.709 h(age-39.5) -0.484 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 625 29 69.6 27 0.89 214 4 1 Earth selected 3 of 5 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Importance: age Weights: 13555, 13675, 18752, 22005, 23896, 24667, 24807, 23986, 22860, ... Number of terms at each degree of interaction: 1 2 (additive model) Earth GCV 0.0124 RSS 0.259 GRSq 0.867 RSq 0.901 > > # test nk=1, 2, and 3 > cat("nk=1\n") nk=1 > par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > a.nk1 <- earth(Volume~., data=trees, nk=1) > plot(a.nk1, which=1, main="nk=1") > print(a.nk1) Selected 1 of 1 terms, and 0 of 2 predictors Termination condition: Reached nk 1 Importance: Girth-unused, Height-unused Number of terms at each degree of interaction: 1 (intercept only model) GCV 279 RSS 8106 GRSq 0 RSq 0 > cat("nk=2\n") nk=2 > a.nk2 <- earth(Volume~., data=trees, nk=2) > print(summary(a.nk2)) Call: earth(formula=Volume~., data=trees, nk=2) coefficients (Intercept) 30.2 Selected 1 of 1 terms, and 0 of 2 predictors Termination condition: Reached nk 2 Importance: Girth-unused, Height-unused Number of terms at each degree of interaction: 1 (intercept only model) GCV 279 RSS 8106 GRSq 0 RSq 0 > plot(a.nk2, which=1, main="nk=2") > cat("nk=3\n") nk=3 > a.nk3 <- earth(Volume~., data=trees, nk=3) > plot(a.nk3, which=1, main="nk=3") > > cat("\ntest model.matrix.earth\n") test model.matrix.earth > > check.model.matrix <- function(msg, xnew, bx1, bx2) + { + cat("check.model.matrix", msg, ":\n") + print(xnew) + if(!identical(bx1, bx2)) { + cat("\nnot identical\n") + cat(deparse(substitute(bx1)), ":\n", sep="") + print(bx1) + cat(deparse(substitute(bx2)), ":\n", sep="") + print(bx2) + stop("check.model.matrix ", msg, " failed") + } + } > > data(trees) > earth.trees.formula <- earth(Volume ~ ., data=trees, subset=1:20) > bx <- model.matrix(earth.trees.formula) > check.model.matrix("earth.trees.formula formula 1", NULL, bx, earth.trees.formula$bx) check.model.matrix earth.trees.formula formula 1 : NULL > > # nprune so only Girth is used, not Height > earth.girth.formula <- earth(Volume ~ ., data=trees, nprune=3) > > # model.matrix where xnew is a data.frame > > xnew <- trees[,1:2] > bx <- model.matrix(earth.girth.formula, xnew) > lm.mod <- lm(trees$Volume ~ bx[,-1]) # -1 to drop intercept > stopifnot(coef(earth.girth.formula) == coef(lm.mod)) > > colnames(xnew) <- NULL > bx <- model.matrix(earth.girth.formula, xnew) > lm.mod2 <- lm(trees$Volume ~ bx[,-1]) > stopifnot(coef(earth.girth.formula) == coef(lm.mod2)) > > xnew <- data.frame(Girth=c(8.3, 8.6), Height=c(70, 65)) > bx <- model.matrix(earth.girth.formula, xnew) > check.model.matrix("earth.girth.formula formula 2", xnew, bx, earth.girth.formula$bx[1:2,]) check.model.matrix earth.girth.formula formula 2 : Girth Height 1 8.3 70 2 8.6 65 > > # test what happens when variables are missing > predict.girth.height <- predict(earth.girth.formula, xnew) > predict.girth <- predict(earth.girth.formula, newdata=data.frame(Girth=c(8.3, 8.6))) > stopifnot(all.equal(predict.girth.height, predict.girth)) > predict.height <- predict(earth.girth.formula, newdata=data.frame(Height=c(70, 65))) > stopifnot(all(is.na(predict.height))) > > xnew <- trees[1:2,] > bx <- model.matrix(earth.girth.formula, xnew) > check.model.matrix("earth.girth.formula formula 3", xnew, bx, earth.girth.formula$bx[1:2,]) check.model.matrix earth.girth.formula formula 3 : Girth Height Volume 1 8.3 70 10.3 2 8.6 65 10.3 > > xnew <- trees[1:2,1:2] # exclude Volume column > colnames(xnew) <- NULL > bx <- model.matrix(earth.girth.formula, xnew) > check.model.matrix("earth.girth.formula formula 4", xnew, bx, earth.girth.formula$bx[1:2,]) check.model.matrix earth.girth.formula formula 4 : 1 8.3 70 2 8.6 65 > > xnew <- trees[1:2,3:1] # change order of columns > bx <- model.matrix(earth.girth.formula, xnew) > check.model.matrix("earth.girth.formula formula 5", xnew, bx, earth.girth.formula$bx[1:2,]) check.model.matrix earth.girth.formula formula 5 : Volume Height Girth 1 10.3 70 8.3 2 10.3 65 8.6 > > xnew <- trees[1:2,1,drop=FALSE] # include only Girth > bx <- model.matrix(earth.girth.formula, xnew) > check.model.matrix("earth.girth.formula formula 6", xnew, bx, earth.girth.formula$bx[1:2,]) check.model.matrix earth.girth.formula formula 6 : Girth 1 8.3 2 8.6 > > xnew <- trees[1,2:1] > bx <- model.matrix(earth.girth.formula, xnew) > check.model.matrix("earth.girth.formula formula 7", xnew, bx, earth.girth.formula$bx[1,,drop=FALSE]) check.model.matrix earth.girth.formula formula 7 : Height Girth 1 70 8.3 > > xnew <- trees[1,1:2] > names(xnew) <- NULL > bx <- model.matrix(earth.girth.formula, xnew) > check.model.matrix("earth.girth.formula formula 8", xnew, bx, earth.girth.formula$bx[1,,drop=FALSE]) check.model.matrix earth.girth.formula formula 8 : 1 8.3 70 > > # model.matrix where xnew is a matrix (same as above code but with as.matrix) > > xnew <- as.matrix(trees[,1:2]) > bx <- model.matrix(earth.girth.formula, xnew) > lm.mod <- lm(trees$Volume ~ bx[,-1]) # -1 to drop intercept > stopifnot(coef(earth.girth.formula) == coef(lm.mod)) > > colnames(xnew) <- NULL > bx <- model.matrix(earth.girth.formula, xnew) > lm.mod2 <- lm(trees$Volume ~ bx[,-1]) > stopifnot(coef(earth.girth.formula) == coef(lm.mod2)) > > xnew <- as.matrix(data.frame(Girth=c(8.3, 8.6), Height=c(70, 65))) > bx <- model.matrix(earth.girth.formula, xnew) > check.model.matrix("earth.girth.formula formula 9", xnew, bx, earth.girth.formula$bx[1:2,]) check.model.matrix earth.girth.formula formula 9 : Girth Height [1,] 8.3 70 [2,] 8.6 65 > > xnew <- as.matrix(trees[1:2,]) > bx <- model.matrix(earth.girth.formula, xnew) > check.model.matrix("earth.girth.formula formula 10", xnew, bx, earth.girth.formula$bx[1:2,]) check.model.matrix earth.girth.formula formula 10 : Girth Height Volume 1 8.3 70 10.3 2 8.6 65 10.3 > > xnew <- as.matrix(trees[1:2,1:2]) # exclude Volume column > colnames(xnew) <- NULL > bx <- model.matrix(earth.girth.formula, xnew) > check.model.matrix("earth.girth.formula formula 11", xnew, bx, earth.girth.formula$bx[1:2,]) check.model.matrix earth.girth.formula formula 11 : [,1] [,2] 1 8.3 70 2 8.6 65 > > xnew <- as.matrix(trees[1:2,3:1]) # change order of columns > bx <- model.matrix(earth.girth.formula, xnew) > check.model.matrix("earth.girth.formula formula 12", xnew, bx, earth.girth.formula$bx[1:2,]) check.model.matrix earth.girth.formula formula 12 : Volume Height Girth 1 10.3 70 8.3 2 10.3 65 8.6 > > xnew <- as.matrix(trees[1:2,1,drop=FALSE]) # include only Girth > bx <- model.matrix(earth.girth.formula, xnew) > check.model.matrix("earth.girth.formula formula 13", xnew, bx, earth.girth.formula$bx[1:2,]) check.model.matrix earth.girth.formula formula 13 : Girth 1 8.3 2 8.6 > > xnew <- as.matrix(trees[1,2:1]) > bx <- model.matrix(earth.girth.formula, xnew, trace=2) get.earth.x from model.matrix.earth: x columns are in the wrong order, correcting the column order Old columns: Height Girth New columns: Girth Height get.earth.x from model.matrix.earth: x[1,2]: Girth Height 1 8.3 70 get.earth.x from model.matrix.earth: after call to model.frame: mf[1,2]: Girth Height 1 8.3 70 > check.model.matrix("earth.girth.formula formula 14", xnew, bx, earth.girth.formula$bx[1,,drop=FALSE]) check.model.matrix earth.girth.formula formula 14 : Height Girth 1 70 8.3 > > xnew <- as.matrix(trees[3,1:2]) > names(xnew) <- NULL > bx <- model.matrix(earth.girth.formula, xnew) > check.model.matrix("earth.girth.formula formula 15", xnew, bx, earth.girth.formula$bx[3,,drop=FALSE]) check.model.matrix earth.girth.formula formula 15 : Girth Height 3 8.8 63 > > #--- model.matrix with an x,y model > > data(trees) > earth.trees.xy.subset <- earth(trees[,1:2], trees[,3], subset=1:20) > bx <- model.matrix(earth.trees.xy.subset) > check.model.matrix("earth.trees.xy.subset x,y 1", NULL, bx, earth.trees.xy.subset$bx) check.model.matrix earth.trees.xy.subset x,y 1 : NULL > > # nprune so only Girth is used, not Height > earth.girth.xy <- earth(trees[,1:2], trees[,3], nprune=3) > > # model.matrix where xnew is a data.frame > > xnew <- trees[,1:2] > bx <- model.matrix(earth.girth.xy, xnew) > lm.mod <- lm(trees$Volume ~ bx[,-1]) # -1 to drop intercept > stopifnot(coef(earth.girth.xy) == coef(lm.mod)) > > colnames(xnew) <- NULL > bx <- model.matrix(earth.girth.xy, xnew) > lm.mod2 <- lm(trees$Volume ~ bx[,-1]) > stopifnot(coef(earth.girth.xy) == coef(lm.mod2)) > > xnew <- data.frame(Girth=c(8.3, 8.6), Height=c(70, 65)) > bx <- model.matrix(earth.girth.xy, xnew) > check.model.matrix("earth.girth.xy x,y 2", xnew, bx, earth.girth.xy$bx[1:2,]) check.model.matrix earth.girth.xy x,y 2 : Girth Height 1 8.3 70 2 8.6 65 > > # test what happens when variables are missing > predict.girth.height <- predict(earth.girth.xy, xnew) > predict.girth <- predict(earth.girth.xy, newdata=data.frame(Girth=c(8.3, 8.6))) > stopifnot(all.equal(predict.girth.height, predict.girth)) > predict.height <- predict(earth.girth.xy, newdata=data.frame(Height=c(70, 65))) > stopifnot(all(is.na(predict.height))) > > xnew <- trees[1:2,] > bx <- model.matrix(earth.girth.xy, xnew) > check.model.matrix("earth.girth.xy x,y 3", xnew, bx, earth.girth.xy$bx[1:2,]) check.model.matrix earth.girth.xy x,y 3 : Girth Height Volume 1 8.3 70 10.3 2 8.6 65 10.3 > > xnew <- trees[1:2,1:2] # exclude Volume column > colnames(xnew) <- NULL > bx <- model.matrix(earth.girth.xy, xnew) > check.model.matrix("earth.girth.xy x,y 4", xnew, bx, earth.girth.xy$bx[1:2,]) check.model.matrix earth.girth.xy x,y 4 : 1 8.3 70 2 8.6 65 > > # # TODO fails > # xnew <- trees[1:2,3:1] # change order of columns > # bx <- model.matrix(earth.girth.xy, xnew) > # check.model.matrix("earth.girth.xy x,y 5", xnew, bx, earth.girth.xy$bx[1:2,]) > > xnew <- trees[1:2,1,drop=FALSE] # include only Girth > bx <- model.matrix(earth.girth.xy, xnew) > check.model.matrix("earth.girth.xy x,y 6", xnew, bx, earth.girth.xy$bx[1:2,]) check.model.matrix earth.girth.xy x,y 6 : Girth 1 8.3 2 8.6 > > xnew <- trees[1,2:1] > bx <- model.matrix(earth.girth.xy, xnew) > check.model.matrix("earth.girth.xy x,y 7", xnew, bx, earth.girth.xy$bx[1,,drop=FALSE]) check.model.matrix earth.girth.xy x,y 7 : Height Girth 1 70 8.3 > > xnew <- trees[1,1:2] > names(xnew) <- NULL > bx <- model.matrix(earth.girth.xy, xnew) > check.model.matrix("earth.girth.xy x,y 8", xnew, bx, earth.girth.xy$bx[1,,drop=FALSE]) check.model.matrix earth.girth.xy x,y 8 : 1 8.3 70 > > # model.matrix where xnew is a matrix (same as above code but with as.matrix) > > xnew <- as.matrix(trees[,1:2]) > bx <- model.matrix(earth.girth.xy, xnew) > lm.mod <- lm(trees$Volume ~ bx[,-1]) # -1 to drop intercept > stopifnot(coef(earth.girth.xy) == coef(lm.mod)) > > colnames(xnew) <- NULL > bx <- model.matrix(earth.girth.xy, xnew) > lm.mod2 <- lm(trees$Volume ~ bx[,-1]) > stopifnot(coef(earth.girth.xy) == coef(lm.mod2)) > > xnew <- as.matrix(data.frame(Girth=c(8.3, 8.6), Height=c(70, 65))) > bx <- model.matrix(earth.girth.xy, xnew) > check.model.matrix("earth.girth.xy x,y 9", xnew, bx, earth.girth.xy$bx[1:2,]) check.model.matrix earth.girth.xy x,y 9 : Girth Height [1,] 8.3 70 [2,] 8.6 65 > > xnew <- as.matrix(trees[1:2,]) > bx <- model.matrix(earth.girth.xy, xnew) > check.model.matrix("earth.girth.xy x,y 10", xnew, bx, earth.girth.xy$bx[1:2,]) check.model.matrix earth.girth.xy x,y 10 : Girth Height Volume 1 8.3 70 10.3 2 8.6 65 10.3 > > xnew <- as.matrix(trees[1:2,1:2]) # exclude Volume column > colnames(xnew) <- NULL > bx <- model.matrix(earth.girth.xy, xnew) > check.model.matrix("earth.girth.xy x,y 11", xnew, bx, earth.girth.xy$bx[1:2,]) check.model.matrix earth.girth.xy x,y 11 : [,1] [,2] 1 8.3 70 2 8.6 65 > > # # TODO fails > # xnew <- as.matrix(trees[1:2,3:1]) # change order of columns > # bx <- model.matrix(earth.girth.xy, xnew) > # check.model.matrix("earth.girth.xy x,y 12", xnew, bx, earth.girth.xy$bx[1:2,]) > > xnew <- as.matrix(trees[1:2,1,drop=FALSE]) # include only Girth > bx <- model.matrix(earth.girth.xy, xnew) > check.model.matrix("earth.girth.xy x,y 13", xnew, bx, earth.girth.xy$bx[1:2,]) check.model.matrix earth.girth.xy x,y 13 : Girth 1 8.3 2 8.6 > > xnew <- as.matrix(trees[1,2:1]) > bx <- model.matrix(earth.girth.xy, xnew, trace=2) get.earth.x from model.matrix.earth: x columns are in the wrong order, correcting the column order Old columns: Height Girth New columns: Girth Height get.earth.x from model.matrix.earth: x[1,2]: Girth Height 1 8.3 70 > check.model.matrix("earth.girth.xy x,y 14", xnew, bx, earth.girth.xy$bx[1,,drop=FALSE]) check.model.matrix earth.girth.xy x,y 14 : Height Girth 1 70 8.3 > > xnew <- as.matrix(trees[3,1:2]) > names(xnew) <- NULL > bx <- model.matrix(earth.girth.xy, xnew) > check.model.matrix("earth.girth.xy x,y 15", xnew, bx, earth.girth.xy$bx[3,,drop=FALSE]) check.model.matrix earth.girth.xy x,y 15 : Girth Height 3 8.8 63 > > cat("--- compare backward, none, exhaustive, forward, seqrep ---------------------\n") --- compare backward, none, exhaustive, forward, seqrep --------------------- > data(ozone1) > oz <- ozone1[1:50,] > cat("--mod.none\n") --mod.none > mod.none <- earth(O3~., data=oz, degree=2, trace=4, pmethod="none") Call: earth(formula=O3~., data=oz, pmethod="none", trace=4, degree=2) x[50,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 50 5640 5 68 50 5000 24 56 300 84 y[50,1]: O3 1 3 2 5 3 5 ... 6 50 6 Forward pass: minspan 5 endspan 10 x[50,9] 3.52 kB bx[50,21] 8.2 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0507 0.2345 0.2345 7 ibt 174 2 3 1 4 0.1107 0.4367 0.2021 9 doy 45 4 5 1 6 0.1332 0.5826 0.146 3 humidity 28 6 7 1 8 0.0724 0.6751 0.09244 1 vh 5720 8 9 1 10 0.1641 0.7555 0.08043 1 vh 5350< 10 6 2 12 0.1705 0.8010 0.04548 9 doy 61 11 1 14 -0.0529 0.8417 0.04069 2 wind 4 12 13 1 16 -0.1680 0.8676 0.02587 4 temp 30< 14 5 2 18 -1.0243 0.8885 0.02094 6 dpg -2 15 16 1 20 -4.1102 0.9101 0.02157 4 temp 51 17 18 1 final (reached nk 21) Reached nk 21 After forward pass GRSq -4.110 RSq 0.910 Forward pass complete: 21 terms, 18 terms used Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 2 -0.0643 0.0415 -0.0643 1 1 2 3 0.3274 0.4577 0.3917 2 1 6 10 4 0.2845 0.4867 -0.0429 3 1 4 6 10 5 0.4261 0.6365 0.1417 3 1 4 6 10 11 6 0.4967 0.7207 0.0706 3 1 4 6 9 10 11 7 0.5304 0.7739 0.0337 4 1 4 6 9 10 11 13 8 0.5260 0.8041 -0.0044 5 1 4 6 9 10 11 13 15 9 0.4962 0.8235 -0.0298 5 1 4 6 9 10 11 13 15 16 10 0.4844 0.8492 -0.0119 5 1 4 6 8 9 10 11 13 15 16 11 0.4031 0.8568 -0.0813 6 1 4 6 8 9 10 11 13 14 15 16 12 0.2946 0.8642 -0.1085 6 1 4 5 6 8 9 10 11 13 14 15 16 13 0.1833 0.8772 -0.1113 6 1 4 5 6 8 9 10 11 13 14 15 16 18 14 0.0300 0.8900 -0.1533 6 1 4 5 6 8 9 10 11 13 14 15 16 17 18 15 -0.2295 0.8996 -0.2595 6 1 4 5 6 7 8 9 10 11 13 14 15 16 17 18 16 -0.7245 0.9050 -0.4950 6 1 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 17 -1.7229 0.9081 -0.9984 7 1 2 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 chosen 18 -4.1102 0.9101 -2.3873 7 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 Prune none penalty 3 nprune null: selected 18 of 18 terms, and 7 of 9 preds After pruning pass GRSq -4.11 RSq 0.91 > print(summary(mod.none)) Call: earth(formula=O3~., data=oz, pmethod="none", trace=4, degree=2) coefficients (Intercept) 5.325 h(5720-vh) 0.041 h(vh-5720) 0.024 h(4-wind) 1.482 h(wind-4) 0.155 h(28-humidity) -0.139 h(humidity-28) -7.705 h(51-temp) -0.132 h(temp-51) -0.104 h(-2-dpg) -0.033 h(dpg- -2) -0.023 h(174-ibt) -0.006 h(ibt-174) -0.013 h(45-doy) 1.279 h(doy-45) 0.173 h(doy-61) -0.268 vh * h(humidity-28) 0.001 temp * h(45-doy) -0.030 Selected 18 of 18 terms, and 7 of 9 predictors (pmethod="none") Termination condition: Reached nk 21 Importance: vh, humidity, doy, wind, dpg, temp, ibt, ibh-unused, ... Number of terms at each degree of interaction: 1 15 2 GCV 35 RSS 29.6 GRSq -4.11 RSq 0.91 > cat("--mod.backward\n") --mod.backward > mod.backward <- earth(O3~., data=oz, degree=2, trace=4, pmethod="backward") Call: earth(formula=O3~., data=oz, pmethod="backward", trace=4, degree=2) x[50,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 50 5640 5 68 50 5000 24 56 300 84 y[50,1]: O3 1 3 2 5 3 5 ... 6 50 6 Forward pass: minspan 5 endspan 10 x[50,9] 3.52 kB bx[50,21] 8.2 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0507 0.2345 0.2345 7 ibt 174 2 3 1 4 0.1107 0.4367 0.2021 9 doy 45 4 5 1 6 0.1332 0.5826 0.146 3 humidity 28 6 7 1 8 0.0724 0.6751 0.09244 1 vh 5720 8 9 1 10 0.1641 0.7555 0.08043 1 vh 5350< 10 6 2 12 0.1705 0.8010 0.04548 9 doy 61 11 1 14 -0.0529 0.8417 0.04069 2 wind 4 12 13 1 16 -0.1680 0.8676 0.02587 4 temp 30< 14 5 2 18 -1.0243 0.8885 0.02094 6 dpg -2 15 16 1 20 -4.1102 0.9101 0.02157 4 temp 51 17 18 1 final (reached nk 21) Reached nk 21 After forward pass GRSq -4.110 RSq 0.910 Forward pass complete: 21 terms, 18 terms used Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 2 -0.0643 0.0415 -0.0643 1 1 2 3 0.3274 0.4577 0.3917 2 1 6 10 4 0.2845 0.4867 -0.0429 3 1 4 6 10 5 0.4261 0.6365 0.1417 3 1 4 6 10 11 6 0.4967 0.7207 0.0706 3 1 4 6 9 10 11 chosen 7 0.5304 0.7739 0.0337 4 1 4 6 9 10 11 13 8 0.5260 0.8041 -0.0044 5 1 4 6 9 10 11 13 15 9 0.4962 0.8235 -0.0298 5 1 4 6 9 10 11 13 15 16 10 0.4844 0.8492 -0.0119 5 1 4 6 8 9 10 11 13 15 16 11 0.4031 0.8568 -0.0813 6 1 4 6 8 9 10 11 13 14 15 16 12 0.2946 0.8642 -0.1085 6 1 4 5 6 8 9 10 11 13 14 15 16 13 0.1833 0.8772 -0.1113 6 1 4 5 6 8 9 10 11 13 14 15 16 18 14 0.0300 0.8900 -0.1533 6 1 4 5 6 8 9 10 11 13 14 15 16 17 18 15 -0.2295 0.8996 -0.2595 6 1 4 5 6 7 8 9 10 11 13 14 15 16 17 18 16 -0.7245 0.9050 -0.4950 6 1 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 17 -1.7229 0.9081 -0.9984 7 1 2 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 18 -4.1102 0.9101 -2.3873 7 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 Prune backward penalty 3 nprune null: selected 7 of 18 terms, and 4 of 9 preds After pruning pass GRSq 0.53 RSq 0.774 > print(summary(mod.backward)) Call: earth(formula=O3~., data=oz, pmethod="backward", trace=4, degree=2) coefficients (Intercept) 3.446 h(5720-vh) 0.041 h(4-wind) 1.108 h(humidity-28) -8.941 h(doy-45) 0.204 h(doy-61) -0.334 vh * h(humidity-28) 0.002 Selected 7 of 18 terms, and 4 of 9 predictors Termination condition: Reached nk 21 Importance: vh, humidity, doy, wind, ibt-unused, temp-unused, ibh-unused, ... Number of terms at each degree of interaction: 1 5 1 GCV 3.22 RSS 74.4 GRSq 0.53 RSq 0.774 > cat("--mod.forward\n") --mod.forward > mod.forward <- earth(O3~., data=oz, degree=2, trace=4, pmethod="forward") Call: earth(formula=O3~., data=oz, pmethod="forward", trace=4, degree=2) x[50,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 50 5640 5 68 50 5000 24 56 300 84 y[50,1]: O3 1 3 2 5 3 5 ... 6 50 6 Forward pass: minspan 5 endspan 10 x[50,9] 3.52 kB bx[50,21] 8.2 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0507 0.2345 0.2345 7 ibt 174 2 3 1 4 0.1107 0.4367 0.2021 9 doy 45 4 5 1 6 0.1332 0.5826 0.146 3 humidity 28 6 7 1 8 0.0724 0.6751 0.09244 1 vh 5720 8 9 1 10 0.1641 0.7555 0.08043 1 vh 5350< 10 6 2 12 0.1705 0.8010 0.04548 9 doy 61 11 1 14 -0.0529 0.8417 0.04069 2 wind 4 12 13 1 16 -0.1680 0.8676 0.02587 4 temp 30< 14 5 2 18 -1.0243 0.8885 0.02094 6 dpg -2 15 16 1 20 -4.1102 0.9101 0.02157 4 temp 51 17 18 1 final (reached nk 21) Reached nk 21 After forward pass GRSq -4.110 RSq 0.910 Forward pass complete: 21 terms, 18 terms used Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 2 0.1478 0.2325 0.1478 1 1 3 3 0.2867 0.4248 0.1389 2 1 3 4 chosen 4 0.4118 0.5781 0.1251 3 1 3 4 7 5 0.3946 0.6165 -0.0172 4 1 3 4 7 13 6 0.3715 0.6513 -0.0231 5 1 3 4 7 13 16 7 0.3424 0.6834 -0.0292 6 1 3 4 7 13 16 9 8 0.2960 0.7091 -0.0463 7 1 3 4 7 13 16 9 14 9 0.2253 0.7287 -0.0707 7 1 3 4 7 13 16 9 14 5 10 0.1641 0.7555 -0.0612 4 1 2 3 4 5 6 7 8 9 10 11 0.1705 0.8010 0.0064 4 1 2 3 4 5 6 7 8 9 10 11 12 -0.0334 0.8010 -0.2039 5 1 2 3 4 5 6 7 8 9 10 11 12 13 0.0121 0.8515 0.0455 7 1 3 4 7 13 16 9 14 5 8 15 10 6 14 -0.0753 0.8781 -0.0874 7 1 3 4 7 13 16 9 14 5 8 15 10 6 11 15 -0.3788 0.8874 -0.3035 7 1 3 4 7 13 16 9 14 5 8 15 10 6 11 17 16 -0.8136 0.9001 -0.4348 7 1 3 4 7 13 16 9 14 5 8 15 10 6 11 17 18 17 -1.7890 0.9059 -0.9754 7 1 3 4 7 13 16 9 14 5 8 15 10 6 11 17 18 12 18 -4.1102 0.9101 -2.3212 7 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 Prune forward penalty 3 nprune null: selected 4 of 18 terms, and 3 of 9 preds After pruning pass GRSq 0.412 RSq 0.578 > print(summary(mod.forward)) Call: earth(formula=O3~., data=oz, pmethod="forward", trace=4, degree=2) coefficients (Intercept) 7.496 h(28-humidity) -0.266 h(174-ibt) -0.046 h(doy-45) 0.110 Selected 4 of 18 terms, and 3 of 9 predictors (pmethod="forward") Termination condition: Reached nk 21 Importance: ibt, doy, humidity, vh-unused, wind-unused, temp-unused, ... Number of terms at each degree of interaction: 1 3 (additive model) GCV 4.03 RSS 139 GRSq 0.412 RSq 0.578 > cat("--mod.exhaustive\n") --mod.exhaustive > mod.exhaustive <- earth(O3~., data=oz, degree=2, trace=4, pmethod="exhaustive") Call: earth(formula=O3~., data=oz, pmethod="exhaustive", trace=4, degree=2) x[50,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 50 5640 5 68 50 5000 24 56 300 84 y[50,1]: O3 1 3 2 5 3 5 ... 6 50 6 Forward pass: minspan 5 endspan 10 x[50,9] 3.52 kB bx[50,21] 8.2 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0507 0.2345 0.2345 7 ibt 174 2 3 1 4 0.1107 0.4367 0.2021 9 doy 45 4 5 1 6 0.1332 0.5826 0.146 3 humidity 28 6 7 1 8 0.0724 0.6751 0.09244 1 vh 5720 8 9 1 10 0.1641 0.7555 0.08043 1 vh 5350< 10 6 2 12 0.1705 0.8010 0.04548 9 doy 61 11 1 14 -0.0529 0.8417 0.04069 2 wind 4 12 13 1 16 -0.1680 0.8676 0.02587 4 temp 30< 14 5 2 18 -1.0243 0.8885 0.02094 6 dpg -2 15 16 1 20 -4.1102 0.9101 0.02157 4 temp 51 17 18 1 final (reached nk 21) Reached nk 21 After forward pass GRSq -4.110 RSq 0.910 Forward pass complete: 21 terms, 18 terms used Exhaustive pruning: number of subsets 262143 bx sing val ratio 6.6e-07 Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 2 0.1478 0.2325 0.1478 1 1 3 3 0.3274 0.4577 0.1796 2 1 6 10 4 0.4118 0.5781 0.0844 3 1 4 7 3 5 0.4261 0.6365 0.0143 3 1 6 11 4 10 6 0.4967 0.7207 0.0706 3 1 6 9 4 11 10 chosen 7 0.5304 0.7739 0.0337 4 1 6 9 4 11 10 13 8 0.5260 0.8041 -0.0044 5 1 6 15 11 10 13 9 4 9 0.4962 0.8235 -0.0298 5 1 6 15 11 10 13 9 16 4 10 0.4844 0.8492 -0.0119 5 1 6 8 13 15 10 11 4 16 9 11 0.4031 0.8568 -0.0813 6 1 14 16 15 6 13 4 10 9 8 11 12 0.3006 0.8654 -0.1025 6 1 14 16 15 6 13 4 10 9 8 11 17 13 0.1833 0.8772 -0.1174 6 1 14 16 15 6 13 4 10 9 18 11 5 8 14 0.0300 0.8900 -0.1533 6 1 14 16 15 6 13 4 10 9 18 17 8 11 5 15 -0.2295 0.8996 -0.2595 6 1 14 16 15 6 13 4 10 9 18 17 8 7 5 11 16 -0.7245 0.9050 -0.4950 6 1 14 16 15 6 13 4 10 9 18 17 8 7 5 12 11 17 -1.7229 0.9081 -0.9984 7 1 2 11 6 8 12 18 9 14 7 13 10 15 17 5 16 4 18 -4.1102 0.9101 -2.3873 7 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 Prune exhaustive penalty 3 nprune null: selected 7 of 18 terms, and 4 of 9 preds After pruning pass GRSq 0.53 RSq 0.774 > print(summary(mod.exhaustive)) Call: earth(formula=O3~., data=oz, pmethod="exhaustive", trace=4, degree=2) coefficients (Intercept) 3.446 h(5720-vh) 0.041 h(4-wind) 1.108 h(humidity-28) -8.941 h(doy-45) 0.204 h(doy-61) -0.334 vh * h(humidity-28) 0.002 Selected 7 of 18 terms, and 4 of 9 predictors (pmethod="exhaustive") Termination condition: Reached nk 21 Importance: humidity, vh, doy, ibt-unused, wind, temp-unused, ibh-unused, ... Number of terms at each degree of interaction: 1 5 1 GCV 3.22 RSS 74.4 GRSq 0.53 RSq 0.774 > cat("--mod.seqrep\n") --mod.seqrep > mod.seqrep <- earth(O3~., data=oz, degree=2, trace=4, pmethod="seqrep") Call: earth(formula=O3~., data=oz, pmethod="seqrep", trace=4, degree=2) x[50,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 50 5640 5 68 50 5000 24 56 300 84 y[50,1]: O3 1 3 2 5 3 5 ... 6 50 6 Forward pass: minspan 5 endspan 10 x[50,9] 3.52 kB bx[50,21] 8.2 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.0507 0.2345 0.2345 7 ibt 174 2 3 1 4 0.1107 0.4367 0.2021 9 doy 45 4 5 1 6 0.1332 0.5826 0.146 3 humidity 28 6 7 1 8 0.0724 0.6751 0.09244 1 vh 5720 8 9 1 10 0.1641 0.7555 0.08043 1 vh 5350< 10 6 2 12 0.1705 0.8010 0.04548 9 doy 61 11 1 14 -0.0529 0.8417 0.04069 2 wind 4 12 13 1 16 -0.1680 0.8676 0.02587 4 temp 30< 14 5 2 18 -1.0243 0.8885 0.02094 6 dpg -2 15 16 1 20 -4.1102 0.9101 0.02157 4 temp 51 17 18 1 final (reached nk 21) Reached nk 21 After forward pass GRSq -4.110 RSq 0.910 Forward pass complete: 21 terms, 18 terms used Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 2 0.1478 0.2325 0.1478 1 1 3 3 0.2867 0.4248 0.1389 2 1 3 4 4 0.4118 0.5781 0.1251 3 1 4 3 7 chosen 5 0.4131 0.6282 0.0013 4 1 13 3 4 16 6 0.3744 0.6528 -0.0388 5 1 16 13 4 3 9 7 0.1332 0.5826 -0.2412 3 1 2 3 4 5 6 7 8 0.2960 0.7091 0.1629 7 1 9 13 4 3 16 7 14 9 0.2253 0.7287 -0.0707 7 1 14 7 4 3 9 13 16 5 10 0.1641 0.7555 -0.0612 4 1 2 3 4 5 6 7 8 9 10 11 0.1705 0.8010 0.0064 4 1 2 3 4 5 6 7 8 9 10 11 12 0.1955 0.8451 0.0251 6 1 6 9 13 16 14 5 8 15 7 10 18 13 0.1833 0.8772 -0.0123 6 1 4 10 18 6 15 9 13 16 14 5 8 11 14 0.0300 0.8900 -0.1533 6 1 16 5 9 13 8 10 18 6 4 11 14 15 17 15 -0.5442 0.8739 -0.5742 7 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 -1.0243 0.8885 -0.4801 7 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 -1.7229 0.9081 -0.6986 7 1 17 5 9 13 8 10 18 6 4 11 14 15 16 7 12 2 18 -4.1102 0.9101 -2.3873 7 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 Prune seqrep penalty 3 nprune null: selected 5 of 18 terms, and 4 of 9 preds After pruning pass GRSq 0.413 RSq 0.628 > print(summary(mod.seqrep)) Call: earth(formula=O3~., data=oz, pmethod="seqrep", trace=4, degree=2) coefficients (Intercept) 7.296 h(4-wind) 1.263 h(-2-dpg) -0.052 h(174-ibt) -0.043 h(doy-45) 0.097 Selected 5 of 18 terms, and 4 of 9 predictors (pmethod="seqrep") Termination condition: Reached nk 21 Importance: ibt, doy, humidity-unused, wind, dpg, vh-unused, temp-unused, ... Number of terms at each degree of interaction: 1 4 (additive model) GCV 4.02 RSS 122 GRSq 0.413 RSq 0.628 > tab <- data.frame(pmethod=c("none", "backward", "forward", "exhaustive", "seqrep"), + grsq=c(mod.none$grsq, + mod.backward$grsq, + mod.forward$grsq, + mod.exhaustive$grsq, + mod.seqrep$grsq), + nterms=c(length(mod.none$selected.terms), + length(mod.backward$selected.terms), + length(mod.forward$selected.terms), + length(mod.exhaustive$selected.terms), + length(mod.seqrep$selected.terms))) > cat("\n") > print(tab) pmethod grsq nterms 1 none -4.110 18 2 backward 0.530 7 3 forward 0.412 4 4 exhaustive 0.530 7 5 seqrep 0.413 5 > > # check fix for bug reported by Meleksen Akin (Feb 2019, fixed in earth 5.0.0) > # to fix this I added xlevels to earth objects > lm.Species <- lm(Sepal.Length~Species, data=iris) > predict.lm <- predict(lm.Species, newdata=data.frame(Species="setosa")) # ok > earth.Species <- earth(Sepal.Length~Species, data=iris) > predict.earth <- predict(earth.Species, newdata=data.frame(Species="setosa")) # used to fail > stopifnot(identical(as.vector(predict.lm), as.vector(predict.earth))) > > source("test.epilog.R") earth/inst/slowtests/test.earthc.out.save0000644000176200001440000047062313451164122020326 0ustar liggesusersMicrosoft (R) C/C++ Optimizing Compiler Version 19.00.23026 for x86 Copyright (C) Microsoft Corporation. All rights reserved. ============================================================================= TEST 1: noise n=1000 p=1 Forward pass: minspan 5 endspan 7 x[1000,1] 7.81 kB bx[1000,51] 398 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 -0.0062 0.0038 0.003837 0 0.0286 1 2 1 3 -0.0064 0.0087 0.004838 0 0.3242 3 1 5 -0.0088 0.0113 0.002621 0 0.9833 4 1 7 -0.0114 0.0137 0.002439 0 -0.1493 5 1 9 -0.0154 0.0149 0.001125 0 -0.469 6 1 11 -0.0199 0.0155 0.0006418 0 0.9668 7 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 11 terms, 7 terms used (DeltaRSq 0.00064) After forward pass GRSq -0.020 RSq 0.016 Forward pass complete: 11 terms, 7 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.0000 0.0002 2 0.0000 0.0027 3 0.0000 0.0102 4 0.0000 0.0130 5 0.0000 0.0137 6 0.0000 0.0149 Backward pass complete: selected 0 terms of 7, GRSq 0.000 RSq 0.000 RESULT 1: GRSq 1.11022e-16 RSq 1.11022e-16 nTerms 1 of 7 of 51 FUNCTION noise n=1000 p=1 [99.99 secs] TEST 1: FUNCTION noise n=1000 p=1 -0.898 // 0 ============================================================================= TEST 2: x0 n=10 p=1 y x0 0 -0.96810 -0.96810 1 -0.96390 -0.96390 2 -0.84140 -0.84140 3 -0.67650 -0.67650 4 -0.53710 -0.53710 5 -0.45910 -0.45910 6 -0.33030 -0.33030 7 -0.26730 -0.26730 8 0.17770 0.17770 9 0.41900 0.41900 earth.c version 5.1.0 BetaCache 20.3 kB Forward pass: minspan 3 endspan 4 x[10,1] 80 Bytes bx[10,51] 3.98 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 ----------------------------------------------------------------------------- |FindTerm: Searching for new term 1 RssDelta 0 MaxLegalRssDelta 1.96069 |Parent 0 Pred 0 Case -1 Cut -0.9681< Rss 0 RssDelta 0 GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 1.0000 1.0000 1 0 -0.9681< 1 1 final (max RSq) ----------------------------------------------------------------------------- Reached maximum RSq 0.9990 at 3 terms, 2 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 3 terms, 2 terms used nFacs Beta 00 0 -7.02e-17 | . | . 01 1 1 | 2 | linear 02 -- -- | -1 | -0.968 EvalSubsetsUsingXtx: nTerms iTerm DeltaRss RSq 2 1 1.9413 0.0000 min Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 1.0000 1.0000 Backward pass complete: selected 1 terms of 2, GRSq 1.000 RSq 1.000 nFacs Beta 00 0 -7.02e-17 | . | . 01 1 1 | 2 | linear RESULT 2: GRSq 1 RSq 1 nTerms 2 of 2 of 51 FUNCTION x0 n=10 p=1 [99.99 secs] TEST 2: FUNCTION x0 n=10 p=1 -7.02e-17 // 0 +1 * x[0] // 1 ============================================================================= TEST 3: x0 n=10 p=1 Forward pass: minspan 3 endspan 4 x[10,1] 80 Bytes bx[10,1] 80 Bytes GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 Reached maximum number of terms 1 After forward pass GRSq 1.000 RSq 0.000 Forward pass complete: 1 term Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 Backward pass complete: selected 0 terms of 1, GRSq 0.000 RSq 0.000 RESULT 3: GRSq -2.22045e-16 RSq -2.22045e-16 nTerms 1 of 1 of 1 FUNCTION x0 n=10 p=1 [99.99 secs] TEST 3: FUNCTION x0 n=10 p=1 -0.445 // 0 ============================================================================= TEST 4: x0 n=10 p=1 Forward pass: minspan 3 endspan 4 x[10,1] 80 Bytes bx[10,2] 160 Bytes GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 Reached maximum number of terms 2 After forward pass GRSq 1.000 RSq 0.000 Forward pass complete: 1 term Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 Backward pass complete: selected 0 terms of 1, GRSq 0.000 RSq 0.000 RESULT 4: GRSq -2.22045e-16 RSq -2.22045e-16 nTerms 1 of 1 of 2 FUNCTION x0 n=10 p=1 [99.99 secs] TEST 4: FUNCTION x0 n=10 p=1 -0.445 // 0 ============================================================================= TEST 5: x0 n=1000 p=1 Forward pass: minspan 5 endspan 7 x[1000,1] 7.81 kB bx[1000,51] 398 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 1.0000 1.0000 1 0 -0.9987< 1 1 final (max RSq) Reached maximum RSq 0.9990 at 3 terms, 2 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 3 terms, 2 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 1.0000 1.0000 Backward pass complete: selected 1 terms of 2, GRSq 1.000 RSq 1.000 RESULT 5: GRSq 1 RSq 1 nTerms 2 of 2 of 51 FUNCTION x0 n=1000 p=1 [99.99 secs] TEST 5: FUNCTION x0 n=1000 p=1 -2.81e-17 // 0 +1 * x[0] // 1 ============================================================================= TEST 6: x0 + noise n=1000 p=2 Forward pass: minspan 6 endspan 8 x[1000,2] 15.6 kB bx[1000,51] 398 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 1.0000 1.0000 1 0 -0.9994< 1 1 final (max RSq) Reached maximum RSq 0.9990 at 3 terms, 2 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 3 terms, 2 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 1.0000 1.0000 Backward pass complete: selected 1 terms of 2, GRSq 1.000 RSq 1.000 RESULT 6: GRSq 1 RSq 1 nTerms 2 of 2 of 51 FUNCTION x0 + noise n=1000 p=2 [99.99 secs] TEST 6: FUNCTION x0 + noise n=1000 p=2 5.62e-17 // 0 +1 * x[0] // 1 ============================================================================= TEST 7: x0 + x1 n=1000 p=2 y x0 x1 0 -1.82316 -0.99940 -0.67650 1 -1.58849 -0.99870 -0.45910 2 -1.28108 -0.99360 -0.26730 3 -1.41754 -0.99190 -0.53710 4 -0.89739 -0.99040 0.17770 5 -0.68039 -0.98950 0.24610 6 -0.82187 -0.98630 0.27350 7 -1.39147 -0.98150 -0.15440 8 -0.63339 -0.97810 0.53740 9 -0.30040 -0.97490 0.70940 10 -1.52488 -0.97400 -0.55920 11 -0.73773 -0.97350 0.22230 12 -0.68829 -0.97210 0.47980 13 -1.17311 -0.97020 -0.22990 14 -0.17224 -0.97010 0.87830 15 -1.01941 -0.96950 -0.12570 16 -1.26706 -0.96810 -0.11260 17 -1.89049 -0.96800 -0.88080 18 -1.75001 -0.96650 -0.64310 19 -1.02825 -0.96390 -0.01930 20 -0.88901 -0.96370 0.20470 21 -1.52283 -0.96230 -0.50560 22 -0.35964 -0.96230 0.73550 23 -1.23622 -0.96210 -0.17330 24 -1.67568 -0.96020 -0.67230 25 -0.13365 -0.96000 0.90110 26 -0.14658 -0.95920 0.88640 27 -1.93472 -0.95640 -0.96300 28 -1.01516 -0.95320 0.18000 29 -1.56527 -0.95230 -0.58770 30 -0.95579 -0.94720 -0.07770 31 -1.21449 -0.94520 -0.12000 32 -1.19142 -0.94220 -0.30130 33 -1.77923 -0.94180 -0.68430 34 -0.92002 -0.94150 0.10970 35 -0.73030 -0.94080 0.32050 36 -0.94119 -0.94070 0.22880 37 -1.63461 -0.93950 -0.71330 38 -1.83176 -0.93950 -0.70010 39 -1.15938 -0.93890 -0.13410 40 -1.61089 -0.93760 -0.67110 41 -0.81916 -0.93480 0.24750 42 -1.01721 -0.93390 -0.16930 43 -1.38887 -0.93300 -0.56120 44 -0.07779 -0.93240 0.87780 45 -1.95747 -0.93040 -0.91790 46 -0.07976 -0.92980 0.94580 47 -0.96742 -0.92960 0.04180 48 -1.37702 -0.92880 -0.47070 49 -0.04134 -0.92840 0.97610 50 -0.73209 -0.92810 0.34730 51 -1.02995 -0.92800 0.00290 52 -1.76163 -0.92630 -0.80830 53 -1.14275 -0.92510 -0.26420 54 -0.12879 -0.92050 0.71000 55 -1.66640 -0.92020 -0.47750 56 -1.16032 -0.91600 -0.08210 57 -0.18484 -0.91340 0.77800 58 -0.81251 -0.91020 0.22320 59 -1.76974 -0.90890 -0.87870 60 -0.35816 -0.90830 0.48120 61 -0.82279 -0.90780 0.09870 62 -1.03629 -0.90730 -0.07580 63 -0.79077 -0.90550 0.11410 64 -1.61924 -0.90390 -0.63920 65 -1.05781 -0.90270 -0.13260 66 -1.35831 -0.90050 -0.38740 67 -1.65093 -0.89760 -0.72150 68 -1.51698 -0.89730 -0.58590 69 0.05973 -0.89240 0.98330 70 -1.44520 -0.89230 -0.38060 71 -1.29265 -0.89140 -0.53090 72 -1.25250 -0.88960 -0.14940 73 -0.97318 -0.88930 -0.00250 74 -1.73819 -0.88770 -0.79920 75 -0.09736 -0.88410 0.72210 76 -1.17182 -0.88330 -0.27630 77 -1.89637 -0.88310 -0.95780 78 -1.63735 -0.88050 -0.70330 79 -1.13330 -0.87910 -0.14230 80 -0.19036 -0.87780 0.72370 81 -0.98447 -0.87070 -0.04470 82 -0.89904 -0.87030 -0.08700 83 -0.95246 -0.86860 0.06470 84 -0.89400 -0.86790 0.04250 85 -0.75519 -0.86650 0.26210 86 -0.77132 -0.86640 0.25280 87 -0.53721 -0.86600 0.38510 88 -0.09666 -0.86530 0.70870 89 -1.96842 -0.86170 -0.94430 90 -0.70635 -0.86030 0.19460 91 -1.88115 -0.86020 -0.94520 92 -0.62412 -0.85820 0.16450 93 -1.79799 -0.85780 -0.92520 94 -1.77934 -0.85620 -0.75670 95 -0.06839 -0.85420 0.87020 96 -0.96237 -0.85210 -0.02600 97 -2.00395 -0.85190 -0.98010 98 0.03029 -0.84940 0.99650 99 -0.98509 -0.84650 -0.09830 100 -0.77130 -0.84640 0.32560 101 -1.26517 -0.84570 -0.27360 102 -0.76021 -0.84400 0.19180 103 -1.35563 -0.84370 -0.49050 104 -0.81829 -0.84320 0.17620 105 -1.44331 -0.84140 -0.53000 106 -1.01678 -0.83670 -0.00730 107 -0.06026 -0.83300 0.76980 108 -1.26747 -0.82820 -0.53460 109 -1.91673 -0.82590 -0.82660 110 -0.98569 -0.82530 -0.14580 111 -0.77042 -0.82100 0.03240 112 -0.87817 -0.81680 0.12360 113 -0.70969 -0.81590 0.14660 114 -0.49911 -0.81450 0.35180 115 -1.63989 -0.81240 -0.72670 116 -1.21210 -0.81130 -0.38530 117 -1.27028 -0.81090 -0.27090 118 -1.08178 -0.81060 -0.13380 119 -1.58551 -0.80900 -0.63510 120 -0.23872 -0.80850 0.76260 121 -1.46107 -0.80750 -0.48980 122 -1.38409 -0.80350 -0.49210 123 -1.02874 -0.80020 -0.19930 124 -1.52253 -0.79750 -0.77950 125 -0.32879 -0.79670 0.51320 126 -0.16579 -0.78950 0.79130 127 -1.37170 -0.78940 -0.49170 128 -1.90107 -0.78890 -0.98980 129 -0.71395 -0.78730 0.23560 130 -0.87799 -0.78540 -0.06820 131 -0.03018 -0.78220 0.83970 132 -0.10757 -0.78200 0.64010 133 -0.65294 -0.78100 0.26790 134 -1.26026 -0.77970 -0.38430 135 -1.12051 -0.77690 -0.24320 136 -1.20871 -0.77660 -0.36650 137 -1.69542 -0.77440 -0.73980 138 -1.84754 -0.77330 -0.99030 139 -0.35157 -0.77140 0.64120 140 -1.00387 -0.77070 0.01970 141 -0.88607 -0.77020 -0.08570 142 -1.41795 -0.76850 -0.37360 143 -0.90450 -0.76780 0.02200 144 -1.50205 -0.76770 -0.70300 145 -1.06370 -0.76770 -0.16840 146 -1.37784 -0.76720 -0.56990 147 -1.77178 -0.76620 -0.90240 148 -0.92122 -0.76540 -0.31880 149 0.04901 -0.76400 0.98500 150 -1.28724 -0.76290 -0.47860 151 -1.11786 -0.76240 -0.22600 152 -0.80239 -0.76120 0.05710 153 -0.53198 -0.76060 0.27910 154 -1.81742 -0.76050 -0.93780 155 -0.91687 -0.75990 -0.20890 156 -1.03472 -0.75670 -0.16850 157 -0.97738 -0.75550 -0.15870 158 -1.10654 -0.75300 -0.32760 159 -1.11774 -0.75290 -0.24990 160 -1.20386 -0.75170 -0.42010 161 -1.28478 -0.74950 -0.49180 162 -1.04808 -0.74920 -0.27260 163 -1.84141 -0.74880 -0.89620 164 -1.11391 -0.74670 -0.32710 165 -1.29876 -0.74630 -0.27860 166 -1.53045 -0.74580 -0.59530 167 -1.88375 -0.74480 -0.93470 168 -1.35191 -0.74390 -0.42690 169 -1.80067 -0.74230 -0.95210 170 -1.36735 -0.73830 -0.58350 171 -1.75382 -0.73760 -0.96630 172 -1.52330 -0.73360 -0.71900 173 -1.34691 -0.73330 -0.48880 174 -0.93532 -0.73070 -0.01720 175 -0.25722 -0.72900 0.53670 176 -1.34022 -0.72870 -0.54990 177 -0.28694 -0.72730 0.37650 178 -1.35044 -0.72710 -0.55470 179 -0.82080 -0.72580 -0.07850 180 -0.15105 -0.72480 0.37620 181 -1.48287 -0.72390 -0.76070 182 -0.57370 -0.72370 0.27440 183 -1.64234 -0.71920 -0.71420 184 -1.15886 -0.71540 -0.34540 185 -0.51789 -0.71370 0.41530 186 -0.46956 -0.71150 0.11830 187 -0.78567 -0.70940 -0.01090 188 -0.91809 -0.70870 -0.18160 189 -0.89956 -0.70600 -0.04490 190 -0.77648 -0.70480 0.07520 191 -1.10716 -0.70380 -0.32130 192 -1.54133 -0.70290 -0.84510 193 -0.50574 -0.70150 0.29990 194 -1.18773 -0.69590 -0.50010 195 -0.80791 -0.69470 -0.10290 196 -1.07311 -0.69280 -0.34570 197 -1.45169 -0.69080 -0.60750 198 0.11813 -0.68850 0.88020 199 -0.14241 -0.68260 0.65090 200 -1.22598 -0.68190 -0.67700 201 -1.50561 -0.68160 -0.57150 202 -0.20983 -0.68050 0.56990 203 -1.91689 -0.68010 -0.99330 204 -1.57486 -0.67730 -0.83390 205 -0.54165 -0.67360 0.40250 206 -0.77726 -0.67090 -0.06860 207 -1.10394 -0.67090 -0.24410 208 -1.10860 -0.66950 -0.40250 209 -1.24816 -0.66700 -0.49050 210 -0.53610 -0.66380 0.16400 211 -0.88138 -0.66370 -0.06300 212 -0.53986 -0.66320 0.19590 213 -0.62645 -0.66160 0.06330 214 0.25041 -0.66010 0.98930 215 -0.88766 -0.65740 -0.06420 216 -1.14976 -0.65720 -0.46730 217 -0.76804 -0.65660 0.05630 218 -1.78077 -0.65610 -0.97820 219 -0.53809 -0.65230 0.27310 220 -1.27917 -0.65100 -0.46700 221 -0.48394 -0.64990 0.28160 222 -1.07600 -0.64810 -0.17280 223 -0.15342 -0.64580 0.46210 224 -1.41074 -0.64540 -0.60060 225 -0.20430 -0.64490 0.43490 226 -1.38711 -0.64240 -0.71850 227 -0.65731 -0.63630 0.23080 228 -1.41451 -0.63350 -0.65410 229 -1.03537 -0.63170 -0.32830 230 -1.22104 -0.63120 -0.44400 231 -0.04679 -0.63050 0.64510 232 -0.62462 -0.62910 0.23340 233 -0.74157 -0.62850 -0.08770 234 -1.07159 -0.62830 -0.36520 235 -1.51329 -0.62730 -0.74230 236 -1.31921 -0.62660 -0.60010 237 -1.50256 -0.62650 -0.61170 238 -1.24323 -0.62550 -0.60460 239 -0.53276 -0.62540 0.22040 240 -0.98963 -0.62430 -0.33130 241 -0.75409 -0.62270 -0.12630 242 -1.68295 -0.62200 -0.83950 243 -0.51186 -0.62080 0.25130 244 -1.54177 -0.61900 -0.72530 245 -1.37685 -0.61860 -0.61040 246 -0.61661 -0.61790 -0.00130 247 -1.23702 -0.61730 -0.60270 248 -0.72677 -0.61680 0.03070 249 -0.24779 -0.61270 0.25490 250 -1.70529 -0.61250 -0.96640 251 -1.35184 -0.60760 -0.56330 252 -0.75777 -0.60730 0.07310 253 -0.98372 -0.60350 -0.28300 254 -1.59542 -0.60320 -0.88310 255 -1.32528 -0.60220 -0.53970 256 -0.91550 -0.60220 -0.21470 257 -0.60543 -0.60180 0.09880 258 -0.70837 -0.60100 0.01930 259 -0.60644 -0.60070 0.03130 260 -0.36538 -0.59790 0.25500 261 -0.67988 -0.59630 0.03400 262 -0.74094 -0.59590 0.03040 263 -1.09976 -0.59540 -0.45960 264 -1.17030 -0.59450 -0.36750 265 -1.24291 -0.59370 -0.73590 266 -1.45828 -0.59340 -0.58580 267 0.16939 -0.59300 0.84600 268 0.27487 -0.59050 0.79190 269 0.21402 -0.58970 0.90690 270 -1.17122 -0.58820 -0.61720 271 -1.51743 -0.58800 -0.99800 272 -0.32970 -0.58730 0.50850 273 -1.40234 -0.58700 -0.80280 274 -1.03796 -0.58370 -0.35240 275 -0.27742 -0.58100 0.33320 276 -1.26013 -0.57970 -0.61480 277 -0.62288 -0.57960 0.06640 278 -0.90335 -0.57870 -0.00280 279 0.32003 -0.57820 0.98240 280 -0.74177 -0.57740 -0.15080 281 -0.66283 -0.57710 -0.12800 282 -1.54568 -0.57690 -0.94720 283 -0.50400 -0.57630 0.08160 284 -1.55441 -0.57370 -0.93260 285 -0.45962 -0.56660 0.24200 286 -0.29092 -0.56340 0.32530 287 -0.27808 -0.56160 0.39500 288 -1.37452 -0.56110 -0.57690 289 -0.06376 -0.55540 0.56180 290 -0.31740 -0.55130 0.46860 291 -1.50482 -0.54950 -0.96690 292 -0.40841 -0.54610 0.41980 293 0.24703 -0.54600 0.87000 294 -1.37722 -0.54510 -0.73660 295 -0.46453 -0.54500 0.19140 296 -0.32154 -0.54490 0.31700 297 -0.33895 -0.54370 0.27120 298 -0.30713 -0.54090 0.34990 299 -0.06720 -0.53990 0.46910 300 -0.23033 -0.53900 0.34370 301 -1.36281 -0.53890 -0.79530 302 -0.06234 -0.53730 0.54010 303 -1.52187 -0.53720 -0.80470 304 0.01332 -0.53620 0.76980 305 -0.59049 -0.53120 0.12300 306 -1.55247 -0.53090 -0.80020 307 -1.26174 -0.52760 -0.71000 308 0.08089 -0.52630 0.66200 309 -0.46363 -0.52630 0.02640 310 -1.10442 -0.52560 -0.51280 311 -0.38008 -0.52500 0.36480 312 -1.28947 -0.52300 -0.67240 313 -0.51982 -0.52280 -0.03980 314 -1.67969 -0.52260 -0.93660 315 -0.12349 -0.52170 0.44760 316 -0.33085 -0.51670 0.33680 317 -0.40566 -0.51480 0.19900 318 -0.25068 -0.51480 0.36420 319 -0.38227 -0.51450 0.07250 320 -1.63665 -0.51410 -0.93860 321 -1.49352 -0.51330 -0.71350 322 -1.60062 -0.51230 -0.97720 323 -0.76211 -0.51150 -0.28390 324 0.10790 -0.51110 0.79410 325 -0.48695 -0.50880 0.20850 326 -0.93457 -0.50690 -0.31620 327 -0.83217 -0.50630 -0.18600 328 -1.25908 -0.50550 -0.55470 329 -0.28598 -0.50080 0.25190 330 0.03860 -0.49710 0.52190 331 -1.38761 -0.49470 -0.81390 332 -1.13506 -0.49410 -0.58140 333 -0.53483 -0.49410 -0.00310 334 -0.69727 -0.49210 -0.12480 335 -0.09211 -0.48600 0.42580 336 -0.74912 -0.48580 0.02050 337 -0.11140 -0.47940 0.37930 338 -0.91413 -0.47820 -0.41660 339 -1.38244 -0.47540 -0.68640 340 -0.97045 -0.47330 -0.39900 341 0.16951 -0.47290 0.84090 342 -1.31814 -0.47110 -0.83710 343 0.44884 -0.46950 0.85640 344 -1.50070 -0.46910 -0.83330 345 0.20292 -0.46900 0.65730 346 -0.64736 -0.46640 -0.03540 347 -0.88267 -0.46620 -0.30980 348 -1.11746 -0.46440 -0.49010 349 -0.95086 -0.46100 -0.43120 350 -1.31971 -0.46060 -0.93890 351 -0.40297 -0.45910 0.21440 352 -1.54290 -0.45650 -0.91240 353 -0.44683 -0.45450 0.09680 354 -0.21899 -0.45300 0.26770 355 -1.65782 -0.45270 -0.90850 356 -0.06474 -0.45090 0.69300 357 -0.03440 -0.44970 0.43970 358 -0.87001 -0.44780 -0.30190 359 -0.64892 -0.44730 -0.18380 360 -0.71781 -0.44720 -0.18580 361 0.25703 -0.44540 0.88620 362 -1.36912 -0.44150 -0.90520 363 0.38565 -0.44070 0.97170 364 0.00148 -0.43810 0.46440 365 0.32465 -0.43800 0.80680 366 0.16752 -0.43710 0.75770 367 -0.68306 -0.43710 -0.04250 368 0.40369 -0.43510 0.91340 369 -1.13389 -0.43360 -0.66760 370 -0.02809 -0.43360 0.37280 371 -0.38409 -0.43280 0.06480 372 -1.43668 -0.43160 -0.94020 373 -0.84535 -0.42830 -0.28070 374 -0.32359 -0.42810 0.08050 375 -0.36062 -0.42810 0.13080 376 -0.27282 -0.42790 0.25910 377 -1.48340 -0.42400 -0.98400 378 -1.34563 -0.41960 -0.81310 379 -1.31677 -0.41770 -0.67410 380 -0.00922 -0.41660 0.40770 381 -0.49938 -0.41470 -0.02930 382 -1.23569 -0.41130 -0.84190 383 0.45151 -0.40920 0.90390 384 -0.81542 -0.40860 -0.30320 385 -0.65767 -0.40790 -0.09850 386 -0.29861 -0.40630 0.04320 387 -0.62326 -0.40400 -0.19110 388 -1.55157 -0.40280 -0.92980 389 -0.12641 -0.39970 0.31580 390 -0.72829 -0.39970 -0.26500 391 -1.13584 -0.39960 -0.58600 392 -0.36266 -0.39820 0.02860 393 -0.46558 -0.38900 0.04610 394 -1.05665 -0.38820 -0.57440 395 -0.97190 -0.38750 -0.39200 396 -0.33637 -0.38530 0.12130 397 0.34129 -0.38180 0.79590 398 -0.83381 -0.38140 -0.52750 399 -1.04421 -0.37940 -0.58400 400 -1.22415 -0.37870 -0.98350 401 -1.27407 -0.37770 -0.73600 402 0.36023 -0.37760 0.78080 403 -1.33050 -0.37750 -0.81790 404 -1.19029 -0.37550 -0.63510 405 -0.97096 -0.36810 -0.49020 406 -0.01160 -0.36730 0.38070 407 -0.34423 -0.36640 0.22330 408 -0.97813 -0.36450 -0.52460 409 -1.25441 -0.35960 -0.82600 410 -0.11929 -0.35730 0.18300 411 -0.41554 -0.35600 -0.04360 412 -0.46088 -0.35580 -0.06430 413 -1.01039 -0.35500 -0.61460 414 -0.50028 -0.35390 -0.07100 415 -0.02305 -0.35310 0.58590 416 0.25083 -0.35170 0.55310 417 -0.00438 -0.35130 0.52470 418 -1.00574 -0.35040 -0.34180 419 -0.25213 -0.35020 0.15640 420 -1.07121 -0.34820 -0.75920 421 -0.31779 -0.34530 0.22710 422 -0.96893 -0.34450 -0.52230 423 0.20556 -0.34370 0.73870 424 -0.89142 -0.34310 -0.39160 425 -0.40908 -0.34280 -0.03470 426 -1.00938 -0.34120 -0.59780 427 -0.67298 -0.34020 -0.20720 428 -0.82162 -0.33830 -0.43950 429 0.29885 -0.33630 0.76420 430 -0.41157 -0.33380 -0.05730 431 -1.10780 -0.33370 -0.65780 432 -0.91261 -0.33370 -0.46380 433 -0.05265 -0.33330 0.26350 434 -0.75303 -0.33210 -0.34140 435 -0.71943 -0.33080 -0.39700 436 -0.29825 -0.33030 0.09700 437 0.37240 -0.32910 0.86830 438 -0.08320 -0.32560 0.39630 439 0.34448 -0.32520 0.80740 440 0.59097 -0.32470 0.98510 441 0.35903 -0.32170 0.90720 442 -0.81712 -0.31930 -0.33990 443 -0.63123 -0.31880 -0.17820 444 -0.93660 -0.31650 -0.63880 445 -0.21759 -0.31640 0.15530 446 -0.19301 -0.31540 0.11600 447 -1.13932 -0.30880 -0.65650 448 -1.21892 -0.30770 -0.87170 449 -0.32973 -0.30740 0.15180 450 -0.93788 -0.30690 -0.49390 451 0.42969 -0.29740 0.78350 452 -0.35750 -0.29670 0.15830 453 -0.23334 -0.29630 0.20240 454 0.35703 -0.29450 0.80140 455 -1.50069 -0.29370 -0.99380 456 -0.09856 -0.29140 0.26560 457 0.22285 -0.29120 0.68530 458 -1.30530 -0.28920 -0.89540 459 0.27101 -0.28080 0.58520 460 0.41924 -0.27940 0.69860 461 -0.57817 -0.27780 -0.12670 462 0.10847 -0.27750 0.62270 463 -0.87512 -0.27670 -0.63840 464 0.49262 -0.27630 0.76380 465 -0.33052 -0.27560 0.05910 466 -0.23588 -0.27260 0.21910 467 0.01707 -0.27070 0.24270 468 -0.78849 -0.26760 -0.24790 469 0.37147 -0.26500 0.64290 470 -0.75955 -0.26410 -0.45500 471 -1.01171 -0.26220 -0.80490 472 -0.24274 -0.25970 0.21230 473 -0.81912 -0.25920 -0.37000 474 0.25693 -0.25870 0.51740 475 -1.05916 -0.25790 -0.64600 476 0.68996 -0.25760 0.86640 477 -0.02843 -0.25410 0.26130 478 -0.65216 -0.25390 -0.45340 479 -0.23708 -0.25370 0.17510 480 0.19533 -0.25330 0.53300 481 -0.07269 -0.25270 0.05340 482 -0.29146 -0.25260 0.17270 483 -1.15300 -0.25250 -0.74500 484 -0.50897 -0.25240 -0.13860 485 -0.25585 -0.25000 0.07860 486 -0.43751 -0.24910 -0.05700 487 -1.30360 -0.24760 -0.92910 488 -0.74028 -0.24740 -0.31010 489 -0.72635 -0.24260 -0.28350 490 0.71763 -0.24250 0.97440 491 -0.44570 -0.23940 -0.04040 492 -0.19177 -0.23780 -0.01620 493 -0.12134 -0.23700 0.20010 494 -0.94925 -0.23350 -0.56430 495 -1.17759 -0.23280 -0.70820 496 -1.11470 -0.23230 -0.64800 497 0.42383 -0.23220 0.57070 498 -0.31409 -0.22990 0.03660 499 -0.09782 -0.22890 0.20840 500 -1.26240 -0.22670 -0.98180 501 -0.42900 -0.22660 0.04310 502 -0.49382 -0.21810 -0.39410 503 -0.05227 -0.21720 0.33680 504 -0.13073 -0.21390 0.21920 505 -0.39989 -0.21300 -0.15840 506 0.35515 -0.21030 0.73900 507 -0.78873 -0.20980 -0.48370 508 0.73240 -0.19580 0.99550 509 -0.29766 -0.19580 0.04560 510 -1.14151 -0.19480 -0.86750 511 -0.87557 -0.19440 -0.66650 512 -0.86018 -0.19400 -0.48410 513 0.66199 -0.18950 0.96870 514 -0.86079 -0.18870 -0.50200 515 0.03470 -0.18860 0.22050 516 -0.40253 -0.18520 -0.14300 517 -1.20608 -0.18020 -0.83890 518 0.47507 -0.17800 0.77760 519 -0.38969 -0.17750 -0.02080 520 -0.67572 -0.17660 -0.40690 521 -1.25675 -0.17560 -0.89950 522 -0.37250 -0.17550 -0.18510 523 -0.66618 -0.17220 -0.30160 524 -0.77662 -0.17170 -0.49760 525 -0.07560 -0.16970 0.35240 526 0.30695 -0.16180 0.66650 527 -0.76442 -0.15850 -0.51830 528 -0.16886 -0.15840 0.14560 529 -0.79400 -0.15780 -0.47360 530 0.59366 -0.15590 0.87750 531 0.66873 -0.15510 0.96890 532 -1.02355 -0.15050 -0.88540 533 -0.83984 -0.14980 -0.63680 534 -0.16324 -0.14930 -0.00340 535 -0.00537 -0.14820 0.26780 536 -0.03911 -0.14720 0.26040 537 -0.08906 -0.14700 0.23320 538 -0.16947 -0.14640 -0.05290 539 -0.17414 -0.14610 0.18690 540 0.31329 -0.14470 0.65400 541 -0.29076 -0.14460 0.04280 542 -1.05475 -0.14350 -0.74530 543 -1.28779 -0.14220 -0.90600 544 0.26652 -0.14050 0.46430 545 -0.12869 -0.13870 0.16790 546 0.49840 -0.13790 0.79060 547 0.44033 -0.13630 0.69130 548 0.53347 -0.13290 0.90690 549 -0.35241 -0.13200 -0.15950 550 -0.02009 -0.13140 0.26520 551 -0.14758 -0.13130 0.03200 552 -0.65872 -0.12840 -0.50460 553 -0.65808 -0.12780 -0.37550 554 -0.77944 -0.12400 -0.65560 555 0.21064 -0.12350 0.49930 556 0.03762 -0.12130 0.25600 557 -0.53640 -0.11980 -0.31590 558 -0.54593 -0.11350 -0.31520 559 -1.02748 -0.11260 -0.80480 560 -0.41819 -0.11200 -0.20250 561 -1.20281 -0.10830 -0.98440 562 -1.18508 -0.10690 -0.96050 563 -0.49425 -0.10680 -0.36850 564 -0.22699 -0.10580 0.17550 565 -0.25372 -0.10400 -0.18690 566 -1.22141 -0.10250 -0.95010 567 -0.81823 -0.10210 -0.61530 568 -0.81424 -0.09900 -0.60180 569 -0.91764 -0.09450 -0.69590 570 -0.87382 -0.08790 -0.59730 571 -0.16471 -0.08750 0.15960 572 0.20569 -0.08690 0.38600 573 -0.17935 -0.08320 0.04170 574 -0.11728 -0.08090 0.10180 575 -0.62437 -0.08080 -0.46030 576 0.61872 -0.07130 0.85010 577 -0.93507 -0.06700 -0.88640 578 -0.40691 -0.06690 -0.27890 579 -0.26505 -0.06690 -0.12950 580 -1.02750 -0.06610 -0.75860 581 0.79946 -0.06610 0.86880 582 0.14797 -0.06360 0.28110 583 -0.44437 -0.06340 -0.27800 584 -0.14752 -0.06030 0.00150 585 -0.10526 -0.05900 0.05340 586 -0.96363 -0.05870 -0.91070 587 0.40637 -0.05750 0.69820 588 -0.98654 -0.05600 -0.94570 589 -0.06479 -0.05510 0.07970 590 -0.56346 -0.05510 -0.50150 591 -0.37240 -0.05130 -0.11170 592 -0.04772 -0.05130 -0.12440 593 0.40416 -0.04930 0.59690 594 -0.09140 -0.04640 0.28890 595 0.65583 -0.04530 0.94170 596 -0.07680 -0.04510 -0.02610 597 0.12422 -0.04510 0.24050 598 0.91034 -0.04300 0.90670 599 0.15776 -0.04150 0.27650 600 -0.55046 -0.03580 -0.38980 601 -0.41357 -0.03300 -0.25460 602 0.01264 -0.03260 0.00500 603 0.61518 -0.03080 0.75910 604 -0.97935 -0.03050 -0.90310 605 0.26565 -0.02820 0.57650 606 -0.65413 -0.02640 -0.49870 607 -0.27337 -0.02240 -0.16140 608 -0.36654 -0.01810 -0.21640 609 -1.09902 -0.01730 -0.92390 610 -1.19617 -0.01710 -0.95540 611 -0.68913 -0.01700 -0.50750 612 0.21778 -0.01680 0.17570 613 -0.74053 -0.01670 -0.64060 614 -1.10429 -0.01470 -0.93810 615 0.36257 -0.01450 0.45720 616 -0.91436 -0.01280 -0.81490 617 0.02813 -0.01150 -0.10250 618 -0.52721 -0.00950 -0.50870 619 -0.36825 -0.00650 -0.28410 620 -0.71295 -0.00620 -0.54770 621 -1.04689 -0.00500 -0.93750 622 0.62338 -0.00320 0.75400 623 0.37909 -0.00130 0.27140 624 0.33187 -0.00040 0.30950 625 -1.10262 0.00160 -0.91700 626 0.03889 0.00160 0.20010 627 -0.71583 0.00180 -0.54690 628 0.49117 0.00300 0.64420 629 0.39078 0.00460 0.57840 630 0.72269 0.00560 0.62290 631 -0.66619 0.00880 -0.66000 632 -0.81127 0.00890 -0.76430 633 0.57669 0.01030 0.77950 634 -0.85701 0.01390 -0.81580 635 0.71381 0.02030 0.77900 636 0.52336 0.02100 0.60770 637 -0.17003 0.02210 -0.01020 638 -0.55207 0.02250 -0.35830 639 0.10752 0.02300 0.07390 640 -0.80171 0.02460 -0.70930 641 0.83688 0.02560 0.79460 642 0.31508 0.03100 0.43150 643 -0.13811 0.03260 0.03730 644 -0.71832 0.03680 -0.61340 645 0.75328 0.04150 0.61810 646 -0.90858 0.04350 -0.79380 647 -0.68709 0.04450 -0.54640 648 -0.49322 0.04470 -0.34910 649 -0.20030 0.04630 -0.24790 650 -0.08674 0.04730 -0.09290 651 -0.03020 0.04790 -0.11150 652 1.05374 0.04900 0.98300 653 -0.39180 0.05170 -0.37540 654 -0.10434 0.05230 -0.26380 655 -0.91571 0.05310 -0.75310 656 -0.64486 0.05330 -0.60960 657 -0.00484 0.05430 0.03240 658 0.75726 0.05800 0.70910 659 -0.96737 0.05930 -0.81180 660 0.66112 0.06000 0.68220 661 0.37132 0.06030 0.39780 662 -0.43665 0.06190 -0.38390 663 -0.13335 0.06300 -0.11300 664 -0.37698 0.06400 -0.30140 665 -0.84964 0.06600 -0.90240 666 0.41741 0.06810 0.39330 667 0.25000 0.07540 0.09780 668 0.44666 0.07720 0.54710 669 1.04944 0.07960 0.98550 670 0.34215 0.08010 0.35040 671 -0.81049 0.08040 -0.75590 672 -0.88469 0.08420 -0.79530 673 -0.39227 0.08720 -0.46050 674 -0.09841 0.08940 -0.08620 675 0.01257 0.09040 -0.03740 676 -0.50633 0.09290 -0.53380 677 -0.35353 0.09370 -0.24160 678 1.16676 0.09440 0.95080 679 -0.59915 0.09490 -0.43430 680 -0.42436 0.09530 -0.52750 681 -0.63370 0.09690 -0.70300 682 0.25936 0.10300 0.22470 683 -0.07904 0.10350 -0.08660 684 0.49283 0.10360 0.64790 685 0.97473 0.10820 0.73550 686 -0.20985 0.11180 -0.18540 687 -0.52845 0.11330 -0.64430 688 0.32254 0.11780 0.32470 689 0.24418 0.12290 0.25770 690 0.03187 0.12370 -0.05600 691 0.74667 0.12460 0.70050 692 0.13834 0.12970 0.22250 693 1.05065 0.13000 0.90860 694 0.18719 0.13420 0.21910 695 0.89043 0.13780 0.86810 696 0.02089 0.13830 -0.10830 697 -0.69255 0.14030 -0.80100 698 0.45874 0.14040 0.33940 699 -0.17574 0.14120 -0.32140 700 -0.57466 0.14280 -0.54090 701 -0.66240 0.14410 -0.81720 702 -0.82203 0.14440 -0.90720 703 0.28129 0.14930 0.15540 704 0.37035 0.14980 0.27460 705 -0.32257 0.15110 -0.50350 706 -0.77691 0.15280 -0.83800 707 -0.24894 0.15310 -0.25170 708 0.16467 0.15500 0.09120 709 -0.35285 0.15680 -0.46770 710 0.31174 0.15840 0.17070 711 -0.65587 0.15870 -0.71380 712 -0.53316 0.15890 -0.74530 713 -0.88178 0.15980 -0.87240 714 -0.66924 0.16260 -0.75270 715 -0.35950 0.16610 -0.42680 716 -0.03269 0.17120 -0.18970 717 0.13847 0.17660 0.11050 718 0.03290 0.18180 -0.00280 719 0.36334 0.19240 0.22330 720 -0.53511 0.19340 -0.59630 721 0.92214 0.19400 0.76390 722 -0.79007 0.19410 -0.88260 723 0.74565 0.19610 0.73560 724 -0.82381 0.19820 -0.96220 725 -0.15526 0.20040 -0.31830 726 -0.55495 0.20620 -0.70400 727 -0.83259 0.20640 -0.95840 728 -0.10050 0.20720 -0.03780 729 -0.05609 0.20730 -0.22520 730 -0.00589 0.21100 -0.07820 731 -0.00428 0.21410 -0.04660 732 -0.38454 0.21600 -0.47380 733 0.10278 0.21640 -0.16070 734 1.07284 0.21700 0.97320 735 -0.53437 0.21740 -0.74710 736 0.86902 0.21780 0.88740 737 -0.75425 0.22010 -0.78730 738 0.94560 0.22060 0.93120 739 -0.76560 0.22110 -0.87120 740 -0.11776 0.22410 -0.14640 741 0.42649 0.22540 0.33030 742 -0.09244 0.22580 -0.17390 743 -0.31728 0.22690 -0.53050 744 -0.04668 0.22780 -0.20570 745 0.97248 0.22800 0.75420 746 0.18348 0.22850 -0.02990 747 -0.26893 0.22930 -0.43460 748 0.97977 0.23110 0.91810 749 0.11488 0.23160 -0.00420 750 0.42364 0.23360 0.20720 751 0.48908 0.23760 0.39050 752 -0.51217 0.23850 -0.71990 753 0.33952 0.24040 0.19410 754 -0.73472 0.24170 -0.91930 755 -0.65787 0.24220 -0.87610 756 0.31499 0.24520 -0.01430 757 0.96347 0.24530 0.65010 758 -0.82005 0.24910 -0.82060 759 0.84218 0.25550 0.63470 760 1.03300 0.25740 0.80300 761 -0.29037 0.25930 -0.67580 762 0.11419 0.26050 -0.15250 763 -0.49001 0.26050 -0.83780 764 -0.50669 0.26230 -0.70770 765 -0.48514 0.26770 -0.70250 766 1.23109 0.26830 0.90330 767 0.12532 0.26860 -0.10370 768 0.76050 0.27050 0.51540 769 -0.29234 0.27460 -0.57270 770 1.07367 0.27700 0.89180 771 0.28451 0.28690 0.03050 772 0.01805 0.28750 -0.29300 773 0.29745 0.28920 0.18110 774 -0.01030 0.29010 -0.20790 775 0.10782 0.29030 -0.11470 776 1.30353 0.29420 0.97300 777 0.32027 0.29490 0.21840 778 0.19754 0.29580 -0.08040 779 -0.30495 0.29650 -0.49710 780 -0.39456 0.30080 -0.66550 781 0.45012 0.30090 0.10680 782 -0.40993 0.30300 -0.54740 783 -0.45042 0.30400 -0.51700 784 0.23226 0.30540 0.07560 785 -0.27654 0.30900 -0.44680 786 -0.74006 0.31270 -0.95330 787 0.12052 0.31340 -0.11220 788 0.31224 0.32010 0.11590 789 0.74494 0.32420 0.66170 790 -0.60071 0.33030 -0.71290 791 0.57754 0.33100 0.40590 792 -0.01743 0.33160 -0.16200 793 -0.53187 0.33380 -0.73830 794 0.56770 0.33920 0.29270 795 0.01462 0.34020 -0.09330 796 0.61046 0.34610 0.38620 797 0.71402 0.35670 0.26130 798 0.21468 0.36150 -0.01270 799 -0.44339 0.36420 -0.74630 800 -0.23347 0.36740 -0.45450 801 0.42771 0.37390 0.13400 802 -0.53067 0.37670 -0.92420 803 0.41553 0.37750 0.01830 804 -0.08819 0.37960 -0.31010 805 -0.33335 0.38060 -0.52490 806 -0.68526 0.38950 -0.97130 807 -0.24596 0.39010 -0.61220 808 -0.20079 0.39320 -0.41250 809 0.09839 0.39450 -0.24610 810 -0.06924 0.40550 -0.46270 811 -0.17994 0.40840 -0.47040 812 0.24304 0.41900 0.06110 813 0.23192 0.42690 -0.03340 814 -0.40225 0.42750 -0.89690 815 0.30115 0.42970 0.04140 816 0.13880 0.43270 -0.11080 817 1.31101 0.43370 0.93060 818 0.33335 0.43710 -0.13360 819 0.58200 0.43940 0.30420 820 -0.63040 0.44080 -0.99090 821 -0.09696 0.45980 -0.35070 822 -0.24003 0.46060 -0.60170 823 -0.25233 0.46220 -0.69450 824 1.11900 0.46460 0.68320 825 -0.33947 0.46540 -0.63690 826 -0.36649 0.46670 -0.75870 827 1.19230 0.46700 0.98040 828 0.98281 0.46790 0.62870 829 0.05733 0.47760 -0.37330 830 -0.27885 0.47930 -0.86300 831 0.36618 0.47940 -0.03800 832 -0.14604 0.48090 -0.55010 833 0.61346 0.48120 0.07190 834 0.41374 0.48490 -0.12310 835 -0.43663 0.48520 -0.81190 836 1.06934 0.48580 0.75580 837 0.06495 0.48610 -0.31250 838 0.27855 0.48800 -0.03530 839 -0.27747 0.48900 -0.80680 840 -0.06597 0.48920 -0.48060 841 0.25739 0.48990 -0.04420 842 1.43241 0.50460 0.90320 843 0.27778 0.50610 -0.01850 844 -0.22328 0.51660 -0.81570 845 0.41961 0.51890 0.01370 846 -0.15097 0.52170 -0.55660 847 0.13776 0.53520 -0.30850 848 1.37022 0.53910 0.84270 849 -0.24353 0.54380 -0.66870 850 1.14248 0.54740 0.75280 851 0.88900 0.55730 0.39540 852 0.20909 0.55750 -0.28510 853 1.09973 0.56300 0.46090 854 0.06313 0.56710 -0.51600 855 -0.14335 0.57030 -0.63130 856 0.56367 0.57170 0.03940 857 -0.49987 0.57520 -0.95700 858 -0.42209 0.57750 -0.96100 859 1.37011 0.58030 0.98490 860 1.37246 0.58110 0.92550 861 0.47027 0.58490 0.09780 862 0.66615 0.58500 0.01020 863 -0.20760 0.59010 -0.81090 864 -0.17606 0.59880 -0.66110 865 -0.24886 0.60530 -0.76540 866 1.08675 0.60590 0.60380 867 0.15624 0.60610 -0.34170 868 -0.02172 0.60720 -0.50330 869 0.17648 0.60890 -0.23770 870 -0.51969 0.61140 -0.99340 871 -0.05039 0.61690 -0.56740 872 0.84948 0.61760 0.28870 873 0.13498 0.62060 -0.21910 874 -0.26572 0.62080 -0.81780 875 0.92384 0.62140 0.27940 876 -0.43793 0.62570 -0.84780 877 1.00392 0.62690 0.49430 878 0.28592 0.62730 -0.15690 879 1.56571 0.62760 0.97410 880 0.01301 0.62770 -0.41120 881 -0.02214 0.62810 -0.60160 882 -0.29434 0.62920 -0.71980 883 0.45776 0.63070 -0.00820 884 -0.40686 0.63580 -0.90910 885 -0.37121 0.63630 -0.97060 886 0.52958 0.63730 0.04680 887 0.98250 0.63750 0.26910 888 1.51985 0.64600 0.96910 889 1.32578 0.64680 0.80050 890 0.02201 0.64780 -0.50000 891 0.03987 0.65210 -0.56300 892 0.25882 0.65430 -0.17950 893 0.64852 0.65670 0.01680 894 0.66784 0.65850 0.24210 895 1.02524 0.65930 0.29510 896 -0.26319 0.66130 -0.76190 897 0.19509 0.66230 -0.36190 898 0.14419 0.66270 -0.34990 899 0.05199 0.66280 -0.47510 900 0.20324 0.66460 -0.41050 901 0.54425 0.66900 -0.10200 902 0.00984 0.67540 -0.69370 903 0.00316 0.67560 -0.67790 904 -0.41342 0.67710 -0.94610 905 0.36186 0.68290 -0.17560 906 -0.14315 0.68550 -0.82270 907 0.56833 0.69320 0.03610 908 0.35665 0.70110 -0.11850 909 -0.24826 0.70780 -0.87620 910 0.42083 0.70890 -0.13610 911 0.14602 0.71180 -0.48540 912 1.04084 0.71410 0.41870 913 0.76663 0.71480 0.13680 914 -0.01795 0.71690 -0.78500 915 0.52430 0.71920 -0.16090 916 1.60539 0.71960 0.91000 917 1.48031 0.72330 0.92590 918 1.18926 0.72520 0.50420 919 -0.03190 0.72770 -0.68120 920 0.02831 0.72860 -0.55030 921 0.51526 0.72970 0.05010 922 0.40604 0.74580 -0.30670 923 0.74684 0.74620 0.21510 924 0.93003 0.74780 0.21930 925 0.37186 0.75210 -0.08170 926 0.30577 0.75780 -0.34030 927 0.54757 0.75840 -0.27540 928 0.79953 0.76190 0.25790 929 0.11993 0.76630 -0.72400 930 0.50487 0.76900 -0.22900 931 -0.31047 0.77540 -0.92400 932 1.07334 0.77760 0.34920 933 -0.10914 0.78050 -0.96150 934 0.44008 0.78140 -0.17620 935 0.92246 0.78510 0.26950 936 1.56163 0.79050 0.61170 937 -0.22107 0.79390 -0.95680 938 0.71162 0.79480 -0.11610 939 0.23570 0.79880 -0.60430 940 -0.02123 0.79980 -0.73340 941 0.09435 0.80290 -0.57470 942 0.40075 0.80930 -0.40150 943 1.28761 0.81030 0.57720 944 1.22152 0.81190 0.53890 945 1.11906 0.81220 0.35910 946 1.51601 0.81790 0.85490 947 1.34066 0.81830 0.49080 948 0.08693 0.82120 -0.69360 949 0.15920 0.82480 -0.64000 950 0.13610 0.82510 -0.81100 951 0.14323 0.82590 -0.53200 952 -0.11890 0.82850 -0.90260 953 0.59305 0.82890 -0.15560 954 1.75205 0.82980 0.87960 955 0.36779 0.83240 -0.44070 956 0.27625 0.83690 -0.61090 957 0.43058 0.84190 -0.40890 958 -0.18921 0.84890 -0.99440 959 1.13095 0.84930 0.28420 960 0.72853 0.85040 -0.12960 961 0.48860 0.85940 -0.38920 962 0.86381 0.86100 -0.08620 963 0.26581 0.87090 -0.48530 964 0.88431 0.87210 0.00640 965 1.46517 0.87560 0.65900 966 0.44831 0.87710 -0.28890 967 0.27876 0.87820 -0.50900 968 0.36770 0.88140 -0.43310 969 -0.00598 0.88660 -0.69090 970 0.40485 0.90020 -0.44850 971 1.42701 0.90880 0.69410 972 0.09561 0.91370 -0.77560 973 1.35483 0.91530 0.56040 974 0.16348 0.92310 -0.66830 975 -0.05810 0.92450 -0.93580 976 1.21917 0.92510 0.24040 977 0.46096 0.92910 -0.37610 978 1.52783 0.93230 0.68940 979 0.99314 0.93350 -0.03070 980 1.66426 0.94020 0.77630 981 0.76355 0.94540 -0.09710 982 1.09740 0.95650 0.24210 983 0.35039 0.95760 -0.52470 984 0.48291 0.95950 -0.66380 985 -0.05247 0.96030 -0.95560 986 0.81651 0.96250 -0.04190 987 0.28702 0.96680 -0.65210 988 0.95829 0.96870 0.06600 989 0.36860 0.96890 -0.43060 990 1.13270 0.97070 0.10690 991 1.78077 0.98070 0.97220 992 1.46772 0.98900 0.46270 993 0.14413 0.98980 -0.81040 994 0.99918 0.99040 0.11040 995 0.85891 0.99390 -0.14780 996 0.26598 0.99420 -0.67740 997 0.10334 0.99690 -0.85000 998 1.57294 0.99760 0.65150 999 0.77250 0.99800 -0.15910 earth.c version 5.1.0 BetaCache 1.89 kB Forward pass: minspan 6 endspan 8 x[1000,2] 15.6 kB bx[1000,11] 85.9 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 ----------------------------------------------------------------------------- |FindTerm: Searching for new term 1 RssDelta 0 MaxLegalRssDelta 591.565 |Parent 0 Pred 0 Case 466 Cut -0.2726 Rss 303.3 RssDelta 282.4 |Parent 0 Pred 1 Case -1 Cut -0.998< Rss 308.61 RssDelta 0 GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.4769 0.4822 0.4822 0 -0.2726 1 2 1 ----------------------------------------------------------------------------- |FindTerm: Searching for new term 3 RssDelta 0 MaxLegalRssDelta 306.336 |Parent 1 Pred 0 skip (pred is in parent) |Parent 1 Pred 1 Case 849 Cut 0.5374 Rss 193.71 RssDelta 109.59 |Parent 2 Pred 0 skip (pred is in parent) |Parent 2 Pred 1 Case -1 Cut -0.998< Rss 203.78 RssDelta 0 |Parent 0 Pred 0 Case -1 Cut -0.9994< Rss 303.3 RssDelta 0 |Parent 0 Pred 1 Case 712 Cut 0.2144 Rss 8.0225 RssDelta 295.28 GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 3 0.9860 0.9863 0.5041 1 0.2144 3 4 1 ----------------------------------------------------------------------------- |FindTerm: Searching for new term 5 RssDelta 0 MaxLegalRssDelta 8.10272 |Parent 3 Pred 0 Case 681 Cut 0.0969 Rss 8.0117 RssDelta 0.010845 |Parent 3 Pred 1 skip (pred is in parent) |Parent 4 Pred 0 Case 255 Cut -0.6022 Rss 7.9859 RssDelta 0.036634 |Parent 4 Pred 1 skip (pred is in parent) |Parent 0 Pred 0 Case -1 Cut -0.9994< Rss 8.0225 RssDelta 0 |Parent 0 Pred 1 Case -1 Cut -0.998< Rss 8.0225 RssDelta 0 |Parent 1 Pred 0 skip (pred is in parent) |Parent 1 Pred 1 Case -1 Cut -0.998< Rss 8.0081 RssDelta 0 |Parent 2 Pred 0 skip (pred is in parent) |Parent 2 Pred 1 Case -1 Cut -0.998< Rss 8.0217 RssDelta 0 GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 5 0.9859 0.9864 6.255e-05 0 -0.6022 5 6 4 2 reject (small DeltaRSq) ----------------------------------------------------------------------------- RSq changed by less than 0.001 at 5 terms (DeltaRSq 6.3e-05) After forward pass GRSq 0.986 RSq 0.986 Forward pass complete: 5 terms nFacs Beta 00 0 -0.164 | . . | . . 01 1 1.03 | 1 . | -0.273 . 02 1 -0.957 | -1 . | -0.273 . 03 1 1.01 | . 1 | . 0.214 04 1 -0.996 | . -1 | . 0.214 EvalSubsetsUsingXtx: nTerms iTerm DeltaRss RSq 5 1 104.58 0.8077 min 5 2 33.217 0.9296 min 5 3 32.545 0.9307 min 5 4 117.12 0.7863 4 1 105.2 0.7511 min 4 2 35.519 0.8701 min 4 4 262.74 0.4822 3 1 272.41 0.4050 min 3 4 269.6 0.4098 min 2 1 240.02 -0.0000 min Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.4068 0.4098 2 0.8688 0.8701 3 0.9297 0.9307 4 0.9860 0.9863 Backward pass complete: selected 4 terms of 5, GRSq 0.986 RSq 0.986 nFacs Beta 00 0 -0.164 | . . | . . 01 1 1.03 | 1 . | -0.273 . 02 1 -0.957 | -1 . | -0.273 . 03 1 1.01 | . 1 | . 0.214 04 1 -0.996 | . -1 | . 0.214 RESULT 7: GRSq 0.986025 RSq 0.986303 nTerms 5 of 5 of 11 FUNCTION x0 + x1 n=1000 p=2 [99.99 secs] TEST 7: FUNCTION x0 + x1 n=1000 p=2 -0.164 // 0 +1.03 * max(0, x[0] - -0.273) // 1 -0.957 * max(0, -0.273 - x[0]) // 2 +1.01 * max(0, x[1] - 0.214) // 3 -0.996 * max(0, 0.214 - x[1]) // 4 ============================================================================= TEST 8: x0 + x1 + noise n=1000 p=10 RESULT 8: GRSq 0.985844 RSq 0.986126 nTerms 5 of 5 of 51 FUNCTION x0 + x1 + noise n=1000 p=10 [99.99 secs] ============================================================================= TEST 9: x0 + x1 + x0*x1 n=30 p=2 y x0 x1 0 -0.98968 -0.96810 -0.67650 1 -0.98047 -0.96390 -0.45910 2 -0.97084 -0.96020 -0.26730 3 -0.96320 -0.92050 -0.53710 4 -0.81322 -0.84140 0.17770 5 -0.73770 -0.78950 0.24610 6 -0.69945 -0.76400 0.27350 7 -0.77059 -0.72870 -0.15440 8 -0.58075 -0.72730 0.53740 9 -0.35778 -0.62430 0.70940 10 -0.82465 -0.60220 -0.55920 11 -0.48284 -0.57690 0.22230 12 -0.31530 -0.53730 0.47980 13 -0.49520 -0.34450 -0.22990 14 0.25790 -0.33030 0.87830 15 -0.38572 -0.29740 -0.12570 16 -0.35007 -0.26760 -0.11260 17 -0.91151 -0.25760 -0.88080 18 -0.69639 -0.14930 -0.64310 19 -0.07687 -0.05870 -0.01930 20 0.17073 -0.02820 0.20470 21 -0.49556 0.02030 -0.50560 22 0.82627 0.05230 0.73550 23 -0.05938 0.13780 -0.17330 24 -0.60466 0.20640 -0.67230 25 1.46478 0.29650 0.90110 26 1.67680 0.41900 0.88640 27 -0.94135 0.58500 -0.96300 28 0.88658 0.59880 0.18000 29 -0.19086 0.96250 -0.58770 Forward pass: minspan 4 endspan 8 x[30,2] 480 Bytes bx[30,51] 12 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.3267 0.5388 0.5388 1 0.2223 1 2 1 3 0.7103 0.8756 0.3368 0 -0.7273 3 4 1 5 0.9981 0.9994 0.1238 1 -0.963< 5 3 2 final (max RSq) Reached maximum RSq 0.9990 at 7 terms, 6 terms used (RSq 0.9994) After forward pass GRSq 0.998 RSq 0.999 Forward pass complete: 7 terms, 6 terms used EvalSubsetsUsingXtx: nTerms iTerm DeltaRss RSq 6 1 0.057346 0.9954 min 6 2 0.088124 0.9933 6 3 4.3325 0.7011 6 4 0.036857 0.9969 min 6 5 1.7974 0.8756 5 1 0.08082 0.9913 min 5 2 0.18814 0.9839 5 3 6.1468 0.5736 5 5 1.8651 0.8684 4 2 0.22076 0.9761 min 4 3 7.7439 0.4581 4 5 3.2211 0.7695 3 3 7.6345 0.4504 min 3 5 9.2268 0.3407 2 5 6.5407 0.0000 min Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.3418 0.4504 2 0.9651 0.9761 3 0.9842 0.9913 4 0.9927 0.9969 5 0.9981 0.9994 Backward pass complete: selected 5 terms of 6, GRSq 0.998 RSq 0.999 RESULT 9: GRSq 0.998138 RSq 0.999397 nTerms 6 of 6 of 51 FUNCTION x0 + x1 + x0*x1 n=30 p=2 [99.99 secs] TEST 9: FUNCTION x0 + x1 + x0*x1 n=30 p=2 -0.686 // 0 +0.283 * max(0, x[1] - 0.222) // 1 -0.23 * max(0, 0.222 - x[1]) // 2 +1 * max(0, x[0] - -0.727) // 3 -0.597 * max(0, -0.727 - x[0]) // 4 +1.02 * max(0, x[0] - -0.727) * x[1] // 5 ============================================================================= TEST 10: x0 + x1 + x0*x1 n=1000 p=2 Forward pass: minspan 6 endspan 8 x[1000,2] 15.6 kB bx[1000,51] 398 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.4044 0.4103 0.4103 1 0.9761 1 2 1 3 0.8290 0.8324 0.4221 0 -0.7271 3 4 1 5 1.0000 1.0000 0.1676 0 -0.545 5 6 2 2 final (max RSq) Reached maximum RSq 0.9990 at 7 terms (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 7 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.3870 0.3901 2 0.9557 0.9561 3 0.9881 0.9883 4 0.9914 0.9916 5 1.0000 1.0000 6 1.0000 1.0000 Backward pass complete: selected 6 terms of 7, GRSq 1.000 RSq 1.000 RESULT 10: GRSq 1 RSq 1 nTerms 7 of 7 of 51 FUNCTION x0 + x1 + x0*x1 n=1000 p=2 [99.99 secs] TEST 10: FUNCTION x0 + x1 + x0*x1 n=1000 p=2 -0.461 // 0 +0.565 * max(0, x[1] - 0.976) // 1 -0.455 * max(0, 0.976 - x[1]) // 2 +1.98 * max(0, x[0] - -0.727) // 3 -1.98 * max(0, -0.727 - x[0]) // 4 -1 * max(0, x[0] - -0.545) * max(0, 0.976 - x[1]) // 5 +1 * max(0, -0.545 - x[0]) * max(0, 0.976 - x[1]) // 6 ============================================================================= TEST 11: x0 + x1 + x0*x1 n=1000 p=2 malloc 8 B: nUses nPreds 2 sizeof(int) 4 malloc 204 B: nDegree nMaxTerms 51 sizeof(int) 4 malloc 8 kB: xOrder nRows 1000 nCols 2 sizeof(int) 4 malloc 41 kB: BetaCacheGlobal nMaxTerms 51 nMaxTerms 51 nPreds 2 sizeof(double) 8 malloc 398 kB: bxOrth nCases 1000 nMaxTerms 51 sizeof(double) 8 malloc 398 kB: bxOrthCenteredT nMaxTerms 51 nCases 1000 sizeof(double) 8 malloc 408 B: bxOrthMean nMaxTerms 51 nResp 1 sizeof(double) 8 malloc 8 B: yMean nResp 1 sizeof(double) 8 Forward pass term 0 malloc 2 kB: Q nMaxTerms 51 sizeof(tQueue) 32 malloc 2 kB: SortedQ nMaxTerms 51 sizeof(tQueue) 32 malloc 8 kB: xbx nCases 1000 sizeof(double) 8 malloc 408 B: CovSx nMaxTerms 51 sizeof(double) 8 calloc 8 B: CovCol nMaxTerms 51 sizeof(double) 8 calloc 8 B: ycboSum nMaxTerms 51 nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 Forward pass term 1 malloc 8 kB: xbx nCases 1000 sizeof(double) 8 malloc 408 B: CovSx nMaxTerms 51 sizeof(double) 8 calloc 8 B: CovCol nMaxTerms 51 sizeof(double) 8 calloc 8 B: ycboSum nMaxTerms 51 nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 Forward pass term 3 malloc 8 kB: xbx nCases 1000 sizeof(double) 8 malloc 408 B: CovSx nMaxTerms 51 sizeof(double) 8 calloc 8 B: CovCol nMaxTerms 51 sizeof(double) 8 calloc 8 B: ycboSum nMaxTerms 51 nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 malloc 8 B: ybxSum nResp 1 sizeof(double) 8 Forward pass term 5 Reached maximum RSq 0.9990 at 7 terms (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 malloc 204 B: iPivots nTerms 51 sizeof(int) 4 malloc 55 kB: xUsed nCases 1000 nUsedCols 7 sizeof(double) 8 malloc 56 B: qraux nUsedCols 7 sizeof(double) 8 malloc 55 kB: work nCases 1000 nUsedCols 7 sizeof(double) 8 malloc 56 B: RssVec nMaxTerms 7 sizeof(double) 8 malloc 49 B: PruneTerms nMaxTerms 7 nMaxTerms 7 sizeof(bool) 1 malloc 56 B: Betas nMaxTerms 7 nResp 1 sizeof(double) 8 malloc 56 B: Diags nMaxTerms 7 sizeof(double) 8 malloc 7 B: WorkingSet nMaxTerms 7 sizeof(bool) 1 malloc 55 kB: xUsed nCases 1000 nUsedCols 7 sizeof(double) 8 malloc 8 kB: Residuals nCases 1000 nResp 1 sizeof(double) 8 malloc 28 B: iPivots nUsedCols 7 sizeof(int) 4 malloc 56 B: qraux nUsedCols 7 sizeof(double) 8 malloc 55 kB: work nCases 1000 nUsedCols 7 sizeof(double) 8 malloc 392 B: R1 nCols 7 nCols 7 sizeof(double) 8 calloc 8 B: B nCols 7 nCols 7 sizeof(double) 8 malloc 47 kB: xUsed nCases 1000 nUsedCols 6 sizeof(double) 8 malloc 8 kB: Residuals nCases 1000 nResp 1 sizeof(double) 8 malloc 24 B: iPivots nUsedCols 6 sizeof(int) 4 malloc 48 B: qraux nUsedCols 6 sizeof(double) 8 malloc 47 kB: work nCases 1000 nUsedCols 6 sizeof(double) 8 malloc 288 B: R1 nCols 6 nCols 6 sizeof(double) 8 calloc 8 B: B nCols 6 nCols 6 sizeof(double) 8 malloc 39 kB: xUsed nCases 1000 nUsedCols 5 sizeof(double) 8 malloc 8 kB: Residuals nCases 1000 nResp 1 sizeof(double) 8 malloc 20 B: iPivots nUsedCols 5 sizeof(int) 4 malloc 40 B: qraux nUsedCols 5 sizeof(double) 8 malloc 39 kB: work nCases 1000 nUsedCols 5 sizeof(double) 8 malloc 200 B: R1 nCols 5 nCols 5 sizeof(double) 8 calloc 8 B: B nCols 5 nCols 5 sizeof(double) 8 malloc 31 kB: xUsed nCases 1000 nUsedCols 4 sizeof(double) 8 malloc 8 kB: Residuals nCases 1000 nResp 1 sizeof(double) 8 malloc 16 B: iPivots nUsedCols 4 sizeof(int) 4 malloc 32 B: qraux nUsedCols 4 sizeof(double) 8 malloc 31 kB: work nCases 1000 nUsedCols 4 sizeof(double) 8 malloc 128 B: R1 nCols 4 nCols 4 sizeof(double) 8 calloc 8 B: B nCols 4 nCols 4 sizeof(double) 8 malloc 23 kB: xUsed nCases 1000 nUsedCols 3 sizeof(double) 8 malloc 8 kB: Residuals nCases 1000 nResp 1 sizeof(double) 8 malloc 12 B: iPivots nUsedCols 3 sizeof(int) 4 malloc 24 B: qraux nUsedCols 3 sizeof(double) 8 malloc 23 kB: work nCases 1000 nUsedCols 3 sizeof(double) 8 malloc 72 B: R1 nCols 3 nCols 3 sizeof(double) 8 calloc 8 B: B nCols 3 nCols 3 sizeof(double) 8 malloc 16 kB: xUsed nCases 1000 nUsedCols 2 sizeof(double) 8 malloc 8 kB: Residuals nCases 1000 nResp 1 sizeof(double) 8 malloc 8 B: iPivots nUsedCols 2 sizeof(int) 4 malloc 16 B: qraux nUsedCols 2 sizeof(double) 8 malloc 16 kB: work nCases 1000 nUsedCols 2 sizeof(double) 8 malloc 32 B: R1 nCols 2 nCols 2 sizeof(double) 8 calloc 8 B: B nCols 2 nCols 2 sizeof(double) 8 malloc 8 kB: xUsed nCases 1000 nUsedCols 1 sizeof(double) 8 malloc 8 kB: Residuals nCases 1000 nResp 1 sizeof(double) 8 malloc 4 B: iPivots nUsedCols 1 sizeof(int) 4 malloc 8 B: qraux nUsedCols 1 sizeof(double) 8 malloc 8 kB: work nCases 1000 nUsedCols 1 sizeof(double) 8 malloc 8 B: R1 nCols 1 nCols 1 sizeof(double) 8 calloc 8 B: B nCols 1 nCols 1 sizeof(double) 8 malloc 28 B: iPivots nTerms 7 sizeof(int) 4 malloc 55 kB: xUsed nCases 1000 nUsedCols 7 sizeof(double) 8 malloc 56 B: qraux nUsedCols 7 sizeof(double) 8 malloc 55 kB: work nCases 1000 nUsedCols 7 sizeof(double) 8 RESULT 11: GRSq 1 RSq 1 nTerms 7 of 7 of 51 FUNCTION x0 + x1 + x0*x1 n=1000 p=2 [99.99 secs] TEST 11: FUNCTION x0 + x1 + x0*x1 n=1000 p=2 -0.461 // 0 +0.565 * max(0, x[1] - 0.976) // 1 -0.455 * max(0, 0.976 - x[1]) // 2 +1.98 * max(0, x[0] - -0.727) // 3 -1.98 * max(0, -0.727 - x[0]) // 4 -1 * max(0, x[0] - -0.545) * max(0, 0.976 - x[1]) // 5 +1 * max(0, -0.545 - x[0]) * max(0, 0.976 - x[1]) // 6 ============================================================================= TEST 12: cos(x0) + x1 n=1000 p=2 Forward pass: minspan 6 endspan 8 x[1000,2] 15.6 kB bx[1000,51] 398 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.9405 0.9411 0.9411 1 -0.6724 1 2 1 3 0.9968 0.9969 0.05576 0 -0.0587 3 4 1 5 0.9981 0.9981 0.001254 0 0.5166 5 1 7 0.9998 0.9998 0.001624 0 -0.5167 6 1 final (max RSq) Reached maximum RSq 0.9990 at 9 terms, 7 terms used (RSq 0.9998) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 9 terms, 7 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.9277 0.9281 2 0.9492 0.9497 3 0.9824 0.9827 4 0.9976 0.9977 5 0.9996 0.9996 6 0.9998 0.9998 Backward pass complete: selected 6 terms of 7, GRSq 1.000 RSq 1.000 RESULT 12: GRSq 0.999751 RSq 0.999759 nTerms 7 of 7 of 51 FUNCTION cos(x0) + x1 n=1000 p=2 [99.99 secs] TEST 12: FUNCTION cos(x0) + x1 n=1000 p=2 0.524 // 0 +0.999 * max(0, x[1] - -0.672) // 1 -1.01 * max(0, -0.672 - x[1]) // 2 +0.166 * max(0, x[0] - -0.0587) // 3 -0.682 * max(0, -0.0587 - x[0]) // 4 -0.504 * max(0, x[0] - 0.517) // 5 -0.382 * max(0, x[0] - -0.517) // 6 ============================================================================= TEST 13: sin(2*x0)+2*x1*.5*x0*x1 n=1000 p=2 Forward pass: minspan 6 endspan 8 x[1000,2] 15.6 kB bx[1000,51] 398 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.6783 0.6815 0.6815 1 0.3728 1 2 1 3 0.9774 0.9779 0.2964 0 -0.6291 3 4 1 5 0.9951 0.9952 0.01736 0 0.5849 5 6 2 2 7 0.9980 0.9981 0.002864 0 0.5717 7 1 9 0.9989 0.9989 0.0008665 0 -0.2914 8 9 1 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 9 terms, 8 terms used (DeltaRSq 0.00087) After forward pass GRSq 0.999 RSq 0.999 Forward pass complete: 9 terms, 8 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.6243 0.6262 2 0.9331 0.9337 3 0.9775 0.9779 4 0.9870 0.9873 5 0.9978 0.9979 6 0.9980 0.9981 7 0.9980 0.9981 Backward pass complete: selected 7 terms of 8, GRSq 0.998 RSq 0.998 RESULT 13: GRSq 0.998008 RSq 0.998077 nTerms 8 of 8 of 51 FUNCTION sin(2*x0)+2*x1*.5*x0*x1 n=1000 p=2 [99.99 secs] TEST 13: FUNCTION sin(2*x0)+2*x1*.5*x0*x1 n=1000 p=2 -0.463 // 0 +1.91 * max(0, x[1] - 0.373) // 1 -2.37 * max(0, 0.373 - x[1]) // 2 +1.96 * max(0, x[0] - -0.629) // 3 +0.0656 * max(0, -0.629 - x[0]) // 4 -0.567 * max(0, x[0] - 0.585) * max(0, 0.373 - x[1]) // 5 +0.596 * max(0, 0.585 - x[0]) * max(0, 0.373 - x[1]) // 6 -1.72 * max(0, x[0] - 0.572) // 7 ============================================================================= TEST 14: sin(2*x0)+2*x1*.5*x0*x1 n=1000 p=3 Forward pass: minspan 6 endspan 8 x[1000,3] 23.4 kB bx[1000,51] 398 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.6843 0.6875 0.6875 1 0.7948 1 2 1 3 0.9787 0.9791 0.2916 0 -0.6632 3 4 1 5 0.9966 0.9967 0.01765 0 0.6053 5 6 2 2 7 0.9985 0.9986 0.001833 0 0.5775 7 1 9 0.9995 0.9996 0.0009945 0 -0.4112 8 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 9 terms, 8 terms used (DeltaRSq 0.00099) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 9 terms, 8 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.6796 0.6812 2 0.9756 0.9758 3 0.9850 0.9852 4 0.9966 0.9966 5 0.9983 0.9983 6 0.9984 0.9985 7 0.9985 0.9986 Backward pass complete: selected 7 terms of 8, GRSq 0.999 RSq 0.999 RESULT 14: GRSq 0.998518 RSq 0.99857 nTerms 8 of 8 of 51 FUNCTION sin(2*x0)+2*x1*.5*x0*x1 n=1000 p=3 [99.99 secs] TEST 14: FUNCTION sin(2*x0)+2*x1*.5*x0*x1 n=1000 p=3 0.223 // 0 +1.95 * max(0, x[1] - 0.795) // 1 -2.31 * max(0, 0.795 - x[1]) // 2 +2.08 * max(0, x[0] - -0.663) // 3 +0.176 * max(0, -0.663 - x[0]) // 4 -0.52 * max(0, x[0] - 0.605) * max(0, 0.795 - x[1]) // 5 +0.51 * max(0, 0.605 - x[0]) * max(0, 0.795 - x[1]) // 6 -1.68 * max(0, x[0] - 0.578) // 7 ============================================================================= TEST 15: 3rd order, mi=2 ni=11 n=1000 p=6 Forward pass term 0, 1, 3, 5, 7, 9 Reached maximum number of terms 11 After forward pass GRSq 0.878 RSq 0.884 RESULT 15: GRSq 0.878378 RSq 0.883795 nTerms 10 of 11 of 11 FUNCTION 3rd order, mi=2 ni=11 n=1000 p=6 [99.99 secs] TEST 15: FUNCTION 3rd order, mi=2 ni=11 n=1000 p=6 2.95 // 0 +1.16 * max(0, x[5] - 0.742) // 1 -1.73 * max(0, 0.742 - x[5]) // 2 +0.598 * max(0, x[0] - 0.622) // 3 -1.03 * max(0, 0.622 - x[0]) // 4 +3.31 * max(0, x[4] - 0.874) // 5 -0.879 * max(0, 0.874 - x[4]) // 6 -0.898 * max(0, 0.971 - x[3]) // 7 +0.837 * max(0, x[1] - -0.703) // 8 -0.607 * max(0, -0.703 - x[1]) // 9 ============================================================================= TEST 16: 3rd order, mi=2 ni=51 n=1000 p=6 Forward pass: minspan 6 endspan 9 x[1000,6] 46.9 kB bx[1000,51] 398 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.4156 0.4215 0.4215 5 0.7417 1 2 1 3 0.5457 0.5547 0.1333 0 0.622 3 4 1 5 0.6550 0.6653 0.1106 4 0.8742 5 6 1 7 0.7728 0.7818 0.1165 3 0.9713 7 8 1 9 0.8778 0.8839 0.1021 1 -0.7025 9 10 1 11 0.9057 0.9113 0.02738 4 0.7805 11 12 2 2 13 0.9367 0.9410 0.02975 3 0.913 13 14 2 2 15 0.9562 0.9597 0.01866 2 -0.355 15 16 10 2 17 0.9641 0.9673 0.007589 2 -0.6405 17 18 9 2 19 0.9863 0.9876 0.02037 2 0.5516 19 20 1 21 0.9867 0.9882 0.0005182 4 0.8212 21 22 8 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 21 terms (DeltaRSq 0.00052) After forward pass GRSq 0.987 RSq 0.988 Forward pass complete: 21 terms RESULT 16: GRSq 0.986328 RSq 0.987532 nTerms 19 of 21 of 51 FUNCTION 3rd order, mi=2 ni=51 n=1000 p=6 [99.99 secs] TEST 16: FUNCTION 3rd order, mi=2 ni=51 n=1000 p=6 4 // 0 +1.72 * max(0, x[5] - 0.742) // 1 -3.39 * max(0, 0.742 - x[5]) // 2 +1.01 * max(0, x[0] - 0.622) // 3 -0.984 * max(0, 0.622 - x[0]) // 4 +3.71 * max(0, x[4] - 0.874) // 5 -1.65 * max(0, 0.874 - x[4]) // 6 -9.98 * max(0, x[3] - 0.971) // 7 -1.62 * max(0, 0.971 - x[3]) // 8 +0.36 * max(0, x[1] - -0.703) // 9 -0.644 * max(0, x[4] - 0.78) * max(0, 0.742 - x[5]) // 10 +0.888 * max(0, 0.78 - x[4]) * max(0, 0.742 - x[5]) // 11 +2.5 * max(0, x[3] - 0.913) * max(0, 0.742 - x[5]) // 12 +0.822 * max(0, 0.913 - x[3]) * max(0, 0.742 - x[5]) // 13 -1.99 * max(0, -0.703 - x[1]) * max(0, x[2] - -0.355) // 14 +0.968 * max(0, x[1] - -0.703) * max(0, x[2] - -0.64) // 15 -0.722 * max(0, x[1] - -0.703) * max(0, -0.64 - x[2]) // 16 -0.501 * max(0, x[2] - 0.552) // 17 +0.669 * max(0, 0.552 - x[2]) // 18 ============================================================================= TEST 17: 3rd order, mi=3 n=1000 p=6 Forward pass: minspan 6 endspan 9 x[1000,6] 46.9 kB bx[1000,51] 398 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.4156 0.4215 0.4215 5 0.7417 1 2 1 3 0.5457 0.5547 0.1333 0 0.622 3 4 1 5 0.6550 0.6653 0.1106 4 0.8742 5 6 1 7 0.7728 0.7818 0.1165 3 0.9713 7 8 1 9 0.8778 0.8839 0.1021 1 -0.7025 9 10 1 11 0.9057 0.9113 0.02738 4 0.7805 11 12 2 2 13 0.9367 0.9410 0.02975 3 0.913 13 14 2 2 15 0.9562 0.9597 0.01866 2 -0.355 15 16 10 2 17 0.9641 0.9673 0.007589 2 -0.6405 17 18 9 2 19 0.9863 0.9876 0.02037 2 0.5516 19 20 1 21 0.9921 0.9930 0.005325 4 0.7504 21 22 14 3 23 0.9996 0.9997 0.006699 4 0.7939 23 24 8 2 final (max RSq) Reached maximum RSq 0.9990 at 25 terms (RSq 0.9997) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 25 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.4185 0.4215 2 0.5501 0.5546 3 0.6566 0.6617 4 0.7727 0.7772 5 0.8372 0.8413 6 0.9144 0.9169 7 0.9395 0.9416 8 0.9685 0.9698 9 0.9764 0.9775 10 0.9815 0.9824 11 0.9884 0.9890 12 0.9916 0.9921 13 0.9938 0.9942 14 0.9959 0.9962 15 0.9977 0.9979 16 0.9991 0.9992 17 0.9993 0.9993 18 0.9993 0.9994 19 0.9994 0.9995 20 0.9995 0.9996 21 0.9996 0.9996 22 0.9996 0.9996 23 0.9996 0.9997 24 0.9996 0.9997 Backward pass complete: selected 23 terms of 25, GRSq 1.000 RSq 1.000 RESULT 17: GRSq 0.999619 RSq 0.999662 nTerms 24 of 25 of 51 FUNCTION 3rd order, mi=3 n=1000 p=6 [99.99 secs] TEST 17: FUNCTION 3rd order, mi=3 n=1000 p=6 4.95 // 0 +1.65 * max(0, x[5] - 0.742) // 1 -4.49 * max(0, 0.742 - x[5]) // 2 +1.03 * max(0, x[0] - 0.622) // 3 -0.996 * max(0, 0.622 - x[0]) // 4 +2.71 * max(0, x[4] - 0.874) // 5 -2.52 * max(0, 0.874 - x[4]) // 6 -2.38 * max(0, 0.971 - x[3]) // 7 +0.362 * max(0, x[1] - -0.703) // 8 -0.62 * max(0, -0.703 - x[1]) // 9 -2.07 * max(0, x[4] - 0.78) * max(0, 0.742 - x[5]) // 10 +1.97 * max(0, 0.78 - x[4]) * max(0, 0.742 - x[5]) // 11 -0.57 * max(0, x[3] - 0.913) * max(0, 0.742 - x[5]) // 12 +1.8 * max(0, 0.913 - x[3]) * max(0, 0.742 - x[5]) // 13 -1.02 * max(0, -0.703 - x[1]) * max(0, x[2] - -0.355) // 14 +1.11 * max(0, -0.703 - x[1]) * max(0, -0.355 - x[2]) // 15 +0.998 * max(0, x[1] - -0.703) * max(0, x[2] - -0.64) // 16 -0.981 * max(0, x[1] - -0.703) * max(0, -0.64 - x[2]) // 17 -0.714 * max(0, x[2] - 0.552) // 18 +0.698 * max(0, 0.552 - x[2]) // 19 +0.906 * max(0, 0.913 - x[3]) * max(0, x[4] - 0.75) * max(0, 0.742 - x[5]) // 20 -1.02 * max(0, 0.913 - x[3]) * max(0, 0.75 - x[4]) * max(0, 0.742 - x[5]) // 21 -0.538 * max(0, 0.971 - x[3]) * max(0, x[4] - 0.794) // 22 +0.761 * max(0, 0.971 - x[3]) * max(0, 0.794 - x[4]) // 23 ============================================================================= TEST 18: 5 preds + noise n=200 p=15 Forward pass: minspan 6 endspan 11 x[200,15] 23.4 kB bx[200,101] 158 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.1465 0.1888 0.1888 0 0.5901 1 2 1 3 0.2649 0.3369 0.1481 2 -0.7001 3 4 1 5 0.4088 0.4946 0.1577 4 0.7045 5 6 1 7 0.5581 0.6424 0.1478 3 0.2002 7 8 3 2 9 0.6932 0.7654 0.123 5 0.7698 9 10 1 11 0.8527 0.8937 0.1283 1 0.3017 11 12 1 13 0.9245 0.9487 0.05498 5 -0.4899 13 14 6 2 15 0.9833 0.9893 0.0406 1 0.0326 15 16 2 2 17 0.9898 0.9939 0.004571 3 0.7005 17 18 1 19 0.9913 0.9949 0.001055 1 -0.9994< 19 1 2 21 0.9915 0.9954 0.0004449 2 0.1811 20 21 18 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 21 terms, 20 terms used (DeltaRSq 0.00044) After forward pass GRSq 0.992 RSq 0.995 Forward pass complete: 21 terms, 20 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.0998 0.1222 2 0.2613 0.2980 3 0.4476 0.4885 4 0.5733 0.6151 5 0.7339 0.7663 6 0.8601 0.8804 7 0.9041 0.9202 8 0.9320 0.9449 9 0.9493 0.9601 10 0.9618 0.9708 11 0.9649 0.9739 12 0.9749 0.9819 13 0.9793 0.9855 14 0.9831 0.9886 15 0.9855 0.9904 16 0.9883 0.9926 17 0.9901 0.9939 18 0.9916 0.9949 19 0.9916 0.9949 Backward pass complete: selected 18 terms of 20, GRSq 0.992 RSq 0.995 RESULT 18: GRSq 0.991566 RSq 0.994949 nTerms 19 of 20 of 101 FUNCTION 5 preds + noise n=200 p=15 [99.99 secs] TEST 18: FUNCTION 5 preds + noise n=200 p=15 2.5 // 0 +1.22 * max(0, x[ 0] - 0.59) // 1 -0.995 * max(0, 0.59 - x[ 0]) // 2 +1.19 * max(0, x[ 2] - -0.7) // 3 -0.933 * max(0, -0.7 - x[ 2]) // 4 +0.974 * max(0, x[ 4] - 0.705) // 5 -0.492 * max(0, 0.705 - x[ 4]) // 6 +1.12 * max(0, x[ 2] - -0.7) * max(0, x[ 3] - 0.2) // 7 -1.01 * max(0, x[ 2] - -0.7) * max(0, 0.2 - x[ 3]) // 8 +2.04 * max(0, x[ 5] - 0.77) // 9 -1.79 * max(0, 0.77 - x[ 5]) // 10 +1.49 * max(0, x[ 1] - 0.302) // 11 -1.46 * max(0, 0.302 - x[ 1]) // 12 -1.09 * max(0, 0.705 - x[ 4]) * max(0, x[ 5] - -0.49) // 13 +1.07 * max(0, 0.705 - x[ 4]) * max(0, -0.49 - x[ 5]) // 14 -0.887 * max(0, 0.59 - x[ 0]) * max(0, x[ 1] - 0.0326) // 15 +0.894 * max(0, 0.59 - x[ 0]) * max(0, 0.0326 - x[ 1]) // 16 -0.287 * max(0, 0.701 - x[ 3]) // 17 +1.34 * max(0, x[ 0] - 0.59) * x[ 1] // 18 ============================================================================= TEST 19: 5 preds clean n=200 p=15 Forward pass: minspan 6 endspan 11 x[200,15] 23.4 kB bx[200,101] 158 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.1446 0.1870 0.187 0 -0.3736 1 2 1 3 0.3062 0.3742 0.1871 1 -0.389 3 4 1 2 5 0.4074 0.4933 0.1191 2 -0.7001 5 6 1 7 0.5465 0.6331 0.1397 3 0.2591 7 8 5 2 9 0.7084 0.7770 0.144 4 0.7521 9 10 1 11 0.8897 0.9204 0.1434 5 -0.6977 11 12 1 13 0.9614 0.9738 0.05337 4 0.0929 13 14 11 2 15 0.9854 0.9907 0.01688 1 -0.53 15 16 1 17 0.9917 0.9950 0.004355 0 -0.4204 17 18 15 2 19 0.9977 0.9987 0.003668 3 0.8122 19 20 1 21 0.9986 0.9992 0.0005327 4 -0.9916< 21 12 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 21 terms (DeltaRSq 0.00053) After forward pass GRSq 0.999 RSq 0.999 Forward pass complete: 21 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.3044 0.3217 2 0.4087 0.4381 3 0.5507 0.5839 4 0.6950 0.7249 5 0.8751 0.8903 6 0.9068 0.9203 7 0.9121 0.9269 8 0.9355 0.9478 9 0.9534 0.9633 10 0.9699 0.9770 11 0.9804 0.9854 12 0.9870 0.9906 13 0.9905 0.9933 14 0.9927 0.9951 15 0.9956 0.9971 16 0.9965 0.9977 17 0.9977 0.9986 18 0.9977 0.9986 19 0.9977 0.9987 20 0.9977 0.9987 Backward pass complete: selected 19 terms of 21, GRSq 0.998 RSq 0.999 RESULT 19: GRSq 0.997747 RSq 0.998694 nTerms 20 of 21 of 101 FUNCTION 5 preds clean n=200 p=15 [99.99 secs] TEST 19: FUNCTION 5 preds clean n=200 p=15 -1.79 // 0 +0.637 * max(0, x[ 0] - -0.374) // 1 -0.351 * max(0, -0.374 - x[ 0]) // 2 +0.984 * max(0, x[ 0] - -0.374) * max(0, x[ 1] - -0.389) // 3 -1.19 * max(0, x[ 0] - -0.374) * max(0, -0.389 - x[ 1]) // 4 +1.3 * max(0, x[ 2] - -0.7) // 5 -0.856 * max(0, -0.7 - x[ 2]) // 6 +1.02 * max(0, x[ 2] - -0.7) * max(0, x[ 3] - 0.259) // 7 -1.08 * max(0, x[ 2] - -0.7) * max(0, 0.259 - x[ 3]) // 8 +0.273 * max(0, x[ 4] - 0.752) // 9 -0.225 * max(0, 0.752 - x[ 4]) // 10 +1.11 * max(0, x[ 5] - -0.698) // 11 -1.04 * max(0, -0.698 - x[ 5]) // 12 +1.06 * max(0, x[ 4] - 0.0929) * max(0, x[ 5] - -0.698) // 13 -1.08 * max(0, 0.0929 - x[ 4]) * max(0, x[ 5] - -0.698) // 14 +0.625 * max(0, x[ 1] - -0.53) // 15 -0.466 * max(0, -0.53 - x[ 1]) // 16 -1.18 * max(0, -0.42 - x[ 0]) * max(0, x[ 1] - -0.53) // 17 +0.677 * max(0, x[ 3] - 0.812) // 18 -0.225 * max(0, 0.812 - x[ 3]) // 19 ============================================================================= TEST 20: 10 preds + noise n=200 p=50 Forward pass: minspan 7 endspan 12 x[200,50] 78.1 kB bx[200,101] 158 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.1676 0.2089 0.2089 8 0.6855 1 2 1 3 0.2643 0.3364 0.1274 6 0.7834 3 4 1 5 0.3371 0.4332 0.09688 1 -0.406 5 6 1 7 0.3992 0.5139 0.08068 7 0.6965 7 8 1 9 0.4667 0.5923 0.07834 0 0.7167 9 10 1 11 0.5369 0.6660 0.07377 9 0.7671 11 12 1 13 0.5997 0.7281 0.06209 5 -0.2754 13 14 8 2 15 0.6523 0.7780 0.0499 2 0.1682 15 16 1 17 0.7020 0.8216 0.04354 4 0.419 17 18 1 19 0.7381 0.8532 0.0316 3 -0.8599 19 20 1 21 0.7795 0.8845 0.03139 7 -0.6779 21 22 4 2 23 0.8236 0.9139 0.02937 9 -0.0166 23 24 2 2 25 0.8567 0.9350 0.0211 1 -0.6494 25 26 10 2 27 0.8892 0.9534 0.01841 5 0.7832 27 28 1 29 0.9386 0.9762 0.02274 4 -0.6858 29 30 28 2 31 0.9982 0.9994 0.02318 2 -0.2661 31 32 19 2 final (max RSq) Reached maximum RSq 0.9990 at 33 terms (RSq 0.9994) After forward pass GRSq 0.998 RSq 0.999 Forward pass complete: 33 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.1682 0.1890 2 0.2314 0.2695 3 0.3528 0.4007 4 0.4382 0.4933 5 0.5118 0.5712 6 0.5814 0.6421 7 0.6631 0.7198 8 0.7209 0.7742 9 0.8124 0.8524 10 0.8559 0.8898 11 0.8848 0.9145 12 0.9037 0.9305 13 0.9221 0.9455 14 0.9412 0.9601 15 0.9627 0.9754 16 0.9699 0.9808 17 0.9744 0.9842 18 0.9786 0.9872 19 0.9830 0.9901 20 0.9858 0.9920 21 0.9888 0.9939 22 0.9910 0.9953 23 0.9927 0.9963 24 0.9944 0.9973 25 0.9952 0.9978 26 0.9961 0.9982 27 0.9971 0.9987 28 0.9978 0.9991 29 0.9981 0.9992 30 0.9983 0.9993 31 0.9983 0.9993 32 0.9983 0.9994 Backward pass complete: selected 30 terms of 33, GRSq 0.998 RSq 0.999 RESULT 20: GRSq 0.998286 RSq 0.999334 nTerms 31 of 33 of 101 FUNCTION 10 preds + noise n=200 p=50 [99.99 secs] TEST 20: FUNCTION 10 preds + noise n=200 p=50 4.84 // 0 +0.878 * max(0, x[ 8] - 0.685) // 1 -0.989 * max(0, 0.685 - x[ 8]) // 2 +1.22 * max(0, x[ 6] - 0.783) // 3 -0.31 * max(0, 0.783 - x[ 6]) // 4 +1.74 * max(0, x[ 1] - -0.406) // 5 -1.76 * max(0, -0.406 - x[ 1]) // 6 +1.71 * max(0, x[ 7] - 0.697) // 7 -1.83 * max(0, 0.697 - x[ 7]) // 8 +0.759 * max(0, x[ 0] - 0.717) // 9 -0.349 * max(0, 0.717 - x[ 0]) // 10 +1.6 * max(0, x[ 9] - 0.767) // 11 -1.75 * max(0, 0.767 - x[ 9]) // 12 +0.126 * max(0, x[ 2] - 0.168) // 13 -0.121 * max(0, 0.168 - x[ 2]) // 14 +1.83 * max(0, x[ 4] - 0.419) // 15 -1.83 * max(0, 0.419 - x[ 4]) // 16 +0.746 * max(0, x[ 3] - -0.86) // 17 -0.915 * max(0, -0.86 - x[ 3]) // 18 -1.03 * max(0, 0.783 - x[ 6]) * max(0, x[ 7] - -0.678) // 19 +1.02 * max(0, 0.783 - x[ 6]) * max(0, -0.678 - x[ 7]) // 20 -1.05 * max(0, 0.685 - x[ 8]) * max(0, x[ 9] - -0.0166) // 21 +1.05 * max(0, 0.685 - x[ 8]) * max(0, -0.0166 - x[ 9]) // 22 -1.02 * max(0, 0.717 - x[ 0]) * max(0, x[ 1] - -0.649) // 23 +1.07 * max(0, 0.717 - x[ 0]) * max(0, -0.649 - x[ 1]) // 24 +1.05 * max(0, x[ 5] - 0.783) // 25 -0.293 * max(0, 0.783 - x[ 5]) // 26 -1.03 * max(0, x[ 4] - -0.686) * max(0, 0.783 - x[ 5]) // 27 +1.08 * max(0, -0.686 - x[ 4]) * max(0, 0.783 - x[ 5]) // 28 +0.976 * max(0, x[ 2] - -0.266) * max(0, x[ 3] - -0.86) // 29 -1.05 * max(0, -0.266 - x[ 2]) * max(0, x[ 3] - -0.86) // 30 ============================================================================= TEST 21: 20 preds + noise, n=100 p=30 Forward pass: minspan 6 endspan 12 x[100,30] 23.4 kB bx[100,101] 78.9 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.0252 0.1212 0.1212 4 0.4667 1 2 1 3 0.0589 0.2395 0.1182 2 -0.3814 3 4 1 5 0.1510 0.3888 0.1493 0 -0.3904 5 6 3 2 7 0.2038 0.4930 0.1042 11 0.0197 7 8 2 2 9 0.2110 0.5592 0.06617 12 -0.2775 9 10 3 2 11 0.1963 0.6096 0.05044 18 -0.4794 11 12 2 2 13 0.1989 0.6652 0.05558 17 -0.1569 13 14 2 2 15 0.1474 0.6972 0.032 24 -0.3247 15 16 1 17 0.0977 0.7315 0.03436 8 -0.355 17 18 15 2 19 0.0330 0.7631 0.03155 15 -0.1795 19 20 2 2 21 -0.0630 0.7900 0.02692 3 0.6338 21 22 1 23 -0.2202 0.8106 0.02062 14 -0.2963 23 24 22 2 25 -0.4168 0.8329 0.02225 18 -0.4509 25 26 22 2 27 -0.7296 0.8516 0.01869 8 -0.0775 27 28 2 2 29 -1.1609 0.8730 0.02142 9 -0.4271 29 30 2 2 31 -1.9423 0.8916 0.01862 14 -0.7237 31 32 1 33 -3.7010 0.9060 0.01436 19 -0.355 33 34 1 35 -9.0348 0.9171 0.01108 0 0.0949 35 36 1 37 -42.9295 0.9283 0.01122 9 0.1498 37 38 1 reject (negative GRSq) Reached minimum GRSq -10 at 37 terms (GRSq -43) After forward pass GRSq -42.929 RSq 0.928 Forward pass complete: 37 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.1723 0.2136 2 0.2692 0.3412 3 0.2777 0.3830 4 0.3041 0.4376 5 0.3213 0.4818 6 0.3521 0.5335 7 0.3848 0.5831 8 0.4196 0.6304 9 0.4541 0.6740 10 0.4939 0.7172 11 0.4939 0.7349 12 0.5091 0.7616 13 0.5145 0.7809 14 0.5236 0.8009 15 0.5257 0.8170 16 0.5257 0.8302 17 0.5257 0.8402 18 0.5257 0.8507 19 0.5257 0.8546 20 0.5257 0.8647 21 0.5257 0.8765 22 0.5257 0.8833 23 0.5257 0.8891 24 0.5257 0.8945 25 0.5257 0.8981 26 0.5257 0.9037 27 0.5257 0.9077 28 0.5257 0.9118 29 0.5257 0.9139 30 0.5257 0.9154 31 0.5257 0.9166 32 0.5257 0.9169 33 0.5257 0.9170 34 0.5257 0.9171 35 0.5257 0.9171 36 0.5257 0.9171 Backward pass complete: selected 15 terms of 37, GRSq 0.526 RSq 0.817 RESULT 21: GRSq 0.525724 RSq 0.816975 nTerms 16 of 37 of 101 FUNCTION 20 preds + noise, n=100 p=30 [99.99 secs] TEST 21: FUNCTION 20 preds + noise, n=100 p=30 -2.66 // 0 +5.01 * max(0, x[ 4] - 0.467) // 1 -1.14 * max(0, 0.467 - x[ 4]) // 2 +5.28 * max(0, x[ 0] - -0.39) * max(0, x[ 2] - -0.381) // 3 +5.76 * max(0, -0.39 - x[ 0]) * max(0, x[ 2] - -0.381) // 4 +3.76 * max(0, 0.467 - x[ 4]) * max(0, x[11] - 0.0197) // 5 +1.66 * max(0, 0.467 - x[ 4]) * max(0, 0.0197 - x[11]) // 6 -3.3 * max(0, x[ 2] - -0.381) * max(0, -0.278 - x[12]) // 7 +1.93 * max(0, 0.467 - x[ 4]) * max(0, x[18] - -0.479) // 8 -2.29 * max(0, 0.467 - x[ 4]) * max(0, -0.157 - x[17]) // 9 -1.13 * max(0, x[ 8] - -0.355) * max(0, x[24] - -0.325) // 10 -4.42 * max(0, -0.355 - x[ 8]) * max(0, x[24] - -0.325) // 11 -2.06 * max(0, 0.467 - x[ 4]) * max(0, -0.179 - x[15]) // 12 -3.23 * max(0, 0.634 - x[ 3]) * max(0, -0.296 - x[14]) // 13 +7.2 * max(0, -0.724 - x[14]) // 14 -2.08 * max(0, -0.355 - x[19]) // 15 ============================================================================= TEST 22: 20 preds + noise, n=400 p=30 Forward pass: minspan 7 endspan 12 x[400,30] 93.8 kB bx[400,101] 316 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.0462 0.0700 0.06999 4 0.864 1 2 1 3 0.0958 0.1406 0.07059 0 -0.0136 3 4 1 5 0.1366 0.2003 0.05975 16 -0.6032 5 6 1 7 0.1776 0.2579 0.05761 1 0.2717 7 8 3 2 9 0.2076 0.3038 0.04583 18 0.846 9 10 1 11 0.2427 0.3523 0.04855 12 -0.1363 11 12 1 13 0.2863 0.4060 0.0537 13 0.583 13 14 10 2 15 0.3407 0.4662 0.06022 3 0.3055 15 16 1 17 0.3830 0.5143 0.04804 14 -0.6152 17 18 5 2 19 0.4078 0.5469 0.0326 6 0.0576 19 20 2 2 21 0.4367 0.5813 0.03438 19 0.1852 21 22 16 2 23 0.4655 0.6141 0.03288 10 0.0087 23 24 16 2 25 0.4965 0.6472 0.03307 11 -0.0537 25 26 1 27 0.5349 0.6837 0.03653 5 -0.8826 27 28 1 29 0.5606 0.7103 0.02652 17 -0.928 29 30 1 31 0.5976 0.7428 0.03254 15 -0.7716 31 32 1 33 0.6265 0.7687 0.02587 2 0.6341 33 34 1 35 0.6555 0.7934 0.02469 7 0.8198 35 36 1 37 0.6915 0.8209 0.02753 8 0.8584 37 38 1 39 0.7306 0.8487 0.0278 9 -0.6906 39 40 1 41 0.7578 0.8685 0.0198 14 -0.0002 41 42 1 43 0.7792 0.8841 0.01565 3 0.65 43 44 34 2 45 0.8060 0.9017 0.01759 1 -0.701 45 46 2 2 47 0.8237 0.9138 0.01207 19 0.2889 47 48 36 2 49 0.8431 0.9260 0.01222 8 -0.1754 49 50 39 2 51 0.8654 0.9388 0.0128 10 0.234 51 52 1 53 0.8843 0.9493 0.01051 4 -0.5402 53 54 27 2 55 0.9003 0.9580 0.008639 6 -0.942 55 56 1 57 0.9347 0.9735 0.01557 7 -0.8474 57 58 55 2 59 0.9532 0.9818 0.008244 13 0.1542 59 60 1 61 0.9735 0.9901 0.00831 19 0.38 61 62 1 63 0.9830 0.9939 0.003797 1 0.6901 63 64 1 65 0.9942 0.9980 0.004122 0 0.0024 65 66 64 2 67 0.9941 0.9981 4.451e-05 17 -0.5026 67 68 64 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 67 terms (DeltaRSq 4.5e-05) After forward pass GRSq 0.994 RSq 0.998 Forward pass complete: 67 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.0906 0.1020 2 0.1446 0.1659 3 0.1947 0.2247 4 0.2381 0.2758 5 0.2969 0.3402 6 0.3430 0.3914 7 0.3892 0.4416 8 0.4341 0.4894 9 0.4708 0.5288 10 0.5123 0.5715 11 0.5512 0.6109 12 0.5881 0.6477 13 0.6296 0.6875 14 0.6781 0.7321 15 0.7252 0.7744 16 0.7732 0.8164 17 0.8166 0.8536 18 0.8377 0.8723 19 0.8562 0.8884 20 0.8718 0.9019 21 0.8885 0.9159 22 0.9044 0.9289 23 0.9121 0.9356 24 0.9278 0.9479 25 0.9437 0.9599 26 0.9513 0.9659 27 0.9591 0.9717 28 0.9658 0.9768 29 0.9714 0.9809 30 0.9757 0.9839 31 0.9793 0.9866 32 0.9830 0.9891 33 0.9863 0.9914 34 0.9885 0.9929 35 0.9904 0.9942 36 0.9921 0.9953 37 0.9929 0.9958 38 0.9936 0.9963 39 0.9941 0.9966 40 0.9946 0.9969 41 0.9949 0.9972 42 0.9952 0.9974 43 0.9955 0.9976 44 0.9956 0.9977 45 0.9957 0.9978 46 0.9957 0.9978 47 0.9958 0.9979 48 0.9958 0.9979 49 0.9958 0.9979 50 0.9958 0.9980 51 0.9958 0.9980 52 0.9958 0.9980 53 0.9958 0.9980 54 0.9958 0.9980 55 0.9958 0.9980 56 0.9958 0.9980 57 0.9958 0.9980 58 0.9958 0.9980 59 0.9958 0.9980 60 0.9958 0.9980 61 0.9958 0.9980 62 0.9958 0.9980 63 0.9958 0.9980 64 0.9958 0.9980 65 0.9958 0.9980 66 0.9958 0.9980 Backward pass complete: selected 48 terms of 67, GRSq 0.996 RSq 0.998 RESULT 22: GRSq 0.995764 RSq 0.997929 nTerms 49 of 67 of 101 FUNCTION 20 preds + noise, n=400 p=30 [99.99 secs] TEST 22: FUNCTION 20 preds + noise, n=400 p=30 -1.32 // 0 -0.115 * max(0, 0.864 - x[ 4]) // 1 +1.26 * max(0, x[ 0] - -0.0136) // 2 -1.73 * max(0, -0.0136 - x[ 0]) // 3 +0.978 * max(0, x[16] - -0.603) // 4 -1.04 * max(0, -0.603 - x[16]) // 5 +0.921 * max(0, x[ 0] - -0.0136) * max(0, x[ 1] - 0.272) // 6 -0.954 * max(0, x[ 0] - -0.0136) * max(0, 0.272 - x[ 1]) // 7 +1.08 * max(0, x[18] - 0.846) // 8 -0.996 * max(0, 0.846 - x[18]) // 9 +0.981 * max(0, x[12] - -0.136) // 10 -1.03 * max(0, -0.136 - x[12]) // 11 +1.57 * max(0, x[ 3] - 0.305) // 12 -1.63 * max(0, 0.305 - x[ 3]) // 13 -0.112 * max(0, 0.305 - x[ 3]) * max(0, 0.0087 - x[10]) // 14 +1.04 * max(0, x[11] - -0.0537) // 15 -0.978 * max(0, -0.0537 - x[11]) // 16 +0.464 * max(0, x[ 5] - -0.883) // 17 -1.45 * max(0, -0.883 - x[ 5]) // 18 +1.02 * max(0, x[17] - -0.928) // 19 +0.991 * max(0, x[15] - -0.772) // 20 -1.08 * max(0, -0.772 - x[15]) // 21 +0.584 * max(0, x[ 2] - 0.634) // 22 -1.69 * max(0, 0.634 - x[ 2]) // 23 -0.047 * max(0, 0.82 - x[ 7]) // 24 -0.257 * max(0, 0.858 - x[ 8]) // 25 +0.803 * max(0, x[ 9] - -0.691) // 26 -1.03 * max(0, -0.691 - x[ 9]) // 27 +0.966 * max(0, x[14] - -0.0002) // 28 -1.01 * max(0, -0.0002 - x[14]) // 29 -0.811 * max(0, 0.634 - x[ 2]) * max(0, x[ 3] - 0.65) // 30 +1.02 * max(0, 0.634 - x[ 2]) * max(0, 0.65 - x[ 3]) // 31 +1.08 * max(0, x[ 8] - -0.175) * max(0, x[ 9] - -0.691) // 32 -1.04 * max(0, -0.175 - x[ 8]) * max(0, x[ 9] - -0.691) // 33 +1 * max(0, x[10] - 0.234) // 34 -0.965 * max(0, 0.234 - x[10]) // 35 +1 * max(0, x[ 4] - -0.54) * max(0, x[ 5] - -0.883) // 36 -0.976 * max(0, -0.54 - x[ 4]) * max(0, x[ 5] - -0.883) // 37 +0.158 * max(0, x[ 6] - -0.942) // 38 -2.82 * max(0, -0.942 - x[ 6]) // 39 +1.01 * max(0, x[ 6] - -0.942) * max(0, x[ 7] - -0.847) // 40 -1.25 * max(0, x[ 6] - -0.942) * max(0, -0.847 - x[ 7]) // 41 +1.07 * max(0, x[13] - 0.154) // 42 -0.959 * max(0, 0.154 - x[13]) // 43 +0.978 * max(0, x[19] - 0.38) // 44 -0.995 * max(0, 0.38 - x[19]) // 45 +0.813 * max(0, x[ 1] - 0.69) // 46 -1 * max(0, 0.69 - x[ 1]) // 47 +1.01 * max(0, 0.0024 - x[ 0]) * max(0, 0.69 - x[ 1]) // 48 ============================================================================= TEST 23: 3rd order, mi=3 + noise n=1000 p=10 Forward pass: minspan 7 endspan 10 x[1000,10] 78.1 kB bx[1000,51] 398 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.4178 0.4236 0.4236 5 0.9454 1 2 1 3 0.5591 0.5678 0.1442 0 0.7441 3 4 1 5 0.6742 0.6839 0.116 1 -0.719 5 6 1 7 0.7723 0.7813 0.09741 4 0.4397 7 8 1 9 0.8730 0.8792 0.09794 3 -0.4429 9 10 1 11 0.9041 0.9098 0.03057 4 0.3897 11 12 2 2 13 0.9358 0.9402 0.03042 3 -0.0744 13 14 2 2 15 0.9516 0.9554 0.0152 2 -0.2981 15 16 6 2 17 0.9612 0.9646 0.009191 2 -0.914 17 18 5 2 19 0.9849 0.9864 0.02176 2 -0.8771 19 20 1 21 0.9870 0.9884 0.002016 4 0.7776 21 22 9 2 23 0.9872 0.9887 0.0002842 4 0.9407 23 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 23 terms (DeltaRSq 0.00028) After forward pass GRSq 0.987 RSq 0.989 Forward pass complete: 23 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.4193 0.4222 2 0.5583 0.5627 3 0.6473 0.6525 4 0.7434 0.7485 5 0.8356 0.8397 6 0.9101 0.9128 7 0.9361 0.9383 8 0.9444 0.9466 9 0.9657 0.9672 10 0.9768 0.9779 11 0.9798 0.9809 12 0.9822 0.9833 13 0.9844 0.9854 14 0.9861 0.9870 15 0.9866 0.9876 16 0.9868 0.9878 17 0.9869 0.9880 18 0.9870 0.9881 19 0.9871 0.9883 20 0.9871 0.9884 21 0.9871 0.9884 22 0.9871 0.9884 Backward pass complete: selected 20 terms of 23, GRSq 0.987 RSq 0.988 RESULT 23: GRSq 0.987131 RSq 0.988387 nTerms 21 of 23 of 51 FUNCTION 3rd order, mi=3 + noise n=1000 p=10 [99.99 secs] TEST 23: FUNCTION 3rd order, mi=3 + noise n=1000 p=10 2.54 // 0 -2.21 * max(0, 0.945 - x[5]) // 1 +0.977 * max(0, x[0] - 0.744) // 2 -1.01 * max(0, 0.744 - x[0]) // 3 +0.0723 * max(0, x[1] - -0.719) // 4 -0.81 * max(0, -0.719 - x[1]) // 5 +2.1 * max(0, x[4] - 0.44) // 6 -1.88 * max(0, 0.44 - x[4]) // 7 +1.56 * max(0, x[3] - -0.443) // 8 -1.79 * max(0, -0.443 - x[3]) // 9 -0.986 * max(0, x[4] - 0.39) * max(0, 0.945 - x[5]) // 10 +0.834 * max(0, 0.39 - x[4]) * max(0, 0.945 - x[5]) // 11 -0.811 * max(0, x[3] - -0.0744) * max(0, 0.945 - x[5]) // 12 +0.846 * max(0, -0.0744 - x[3]) * max(0, 0.945 - x[5]) // 13 -0.728 * max(0, -0.719 - x[1]) * max(0, x[2] - -0.298) // 14 +1.44 * max(0, -0.719 - x[1]) * max(0, -0.298 - x[2]) // 15 +1.02 * max(0, x[1] - -0.719) * max(0, x[2] - -0.914) // 16 +1.65 * max(0, x[1] - -0.719) * max(0, -0.914 - x[2]) // 17 -0.728 * max(0, x[2] - -0.877) // 18 -1.07 * max(0, x[3] - -0.443) * max(0, x[4] - 0.778) // 19 +0.241 * max(0, x[3] - -0.443) * max(0, 0.778 - x[4]) // 20 ============================================================================= TEST 24: eqn56 mi=1 n=300 p=6 Forward pass: minspan 6 endspan 9 x[300,6] 14.1 kB bx[300,101] 237 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 -0.0084 0.0184 0.01843 3 0.8014 1 2 1 3 -0.0176 0.0362 0.01774 4 0.8119 3 4 1 5 -0.0264 0.0543 0.01817 0 0.2869 5 6 1 7 -0.0098 0.0825 0.02818 0 -0.4381 7 1 9 -0.0219 0.0974 0.01493 5 0.5132 8 9 1 11 -0.0390 0.1083 0.01087 1 0.7808 10 11 1 13 -0.0427 0.1179 0.009637 3 0.7091 12 1 15 -0.0305 0.1409 0.02296 0 0.2605 13 1 17 0.0202 0.1951 0.05417 0 0.3316 14 1 19 0.0213 0.2079 0.01279 0 -0.2775 15 1 21 0.0206 0.2190 0.01115 0 -0.461 16 1 23 0.0139 0.2254 0.006412 0 -0.581 17 1 25 0.0307 0.2501 0.02465 0 -0.5954 18 1 27 0.0488 0.2752 0.02514 0 -0.5372 19 1 29 0.0291 0.2827 0.007478 2 -0.1135 20 21 1 31 0.0208 0.2878 0.005091 0 -0.3777 22 1 33 0.0118 0.2925 0.004659 0 -0.6273 23 1 35 0.0028 0.2973 0.004828 2 0.6829 24 1 37 -0.0032 0.3042 0.006952 2 0.5391 25 1 39 0.0032 0.3197 0.0155 2 0.7148 26 1 41 -0.0014 0.3277 0.00793 1 0.7577 27 1 43 -0.0083 0.3340 0.006334 1 0.8802 28 1 45 -0.0207 0.3369 0.002866 2 0.6089 29 1 47 -0.0297 0.3421 0.005207 2 0.6468 30 1 49 -0.0422 0.3452 0.003153 4 -0.6819 31 1 51 -0.0443 0.3549 0.009706 4 -0.8168 32 1 53 -0.0407 0.3680 0.0131 4 -0.8877 33 1 55 -0.0256 0.3879 0.01983 4 -0.7258 34 1 57 -0.0364 0.3921 0.004192 4 -0.8521 35 1 59 -0.0461 0.3970 0.004969 4 -0.7822 36 1 61 -0.0591 0.4003 0.003242 3 0.4643 37 1 63 -0.0705 0.4046 0.004301 3 0.3905 38 1 65 -0.0837 0.4079 0.003373 1 0.6822 39 1 67 -0.0703 0.4258 0.01786 1 0.6077 40 1 69 -0.0810 0.4306 0.004824 3 -0.0354 41 1 71 -0.0858 0.4386 0.007984 3 -0.0073 42 1 73 -0.0462 0.4691 0.03046 3 -0.063 43 1 75 -0.0600 0.4721 0.003068 5 -0.9389 44 1 77 -0.0731 0.4757 0.003552 5 -0.7453 45 1 79 -0.0880 0.4785 0.002826 3 0.5859 46 1 81 -0.1039 0.4811 0.002575 3 0.097 47 1 83 -0.1192 0.4841 0.003001 0 0.1941 48 1 85 -0.1355 0.4869 0.002771 5 0.5765 49 1 87 -0.1520 0.4897 0.002838 5 -0.8826 50 1 89 -0.1691 0.4925 0.002774 5 -0.6959 51 1 91 -0.1862 0.4955 0.003005 1 -0.5769 52 1 93 -0.2059 0.4976 0.002096 4 -0.5088 53 1 95 -0.2222 0.5013 0.003682 4 -0.3437 54 1 97 -0.2401 0.5045 0.003227 4 -0.6032 55 1 99 -0.2608 0.5068 0.002349 3 -0.0985 56 1 final (reached nk 101) Reached maximum number of terms 101 After forward pass GRSq -0.261 RSq 0.507 Forward pass complete: 101 terms, 57 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.0000 0.0016 2 0.0199 0.0459 3 0.0706 0.1075 4 0.0728 0.1218 5 0.0728 0.1237 6 0.1091 0.1792 7 0.1091 0.1814 8 0.1091 0.1891 9 0.1373 0.2380 10 0.1395 0.2507 11 0.1395 0.2571 12 0.1621 0.2913 13 0.1621 0.2925 14 0.1621 0.3068 15 0.1621 0.3108 16 0.1641 0.3335 17 0.1641 0.3349 18 0.1641 0.3501 19 0.1698 0.3674 20 0.1698 0.3746 21 0.1788 0.3933 22 0.1788 0.3966 23 0.1788 0.4018 24 0.1788 0.4124 25 0.1788 0.4223 26 0.1788 0.4300 27 0.1788 0.4326 28 0.1788 0.4359 29 0.1788 0.4380 30 0.1788 0.4454 31 0.1788 0.4522 32 0.1788 0.4575 33 0.1788 0.4583 34 0.1788 0.4631 35 0.1788 0.4678 36 0.1788 0.4722 37 0.1788 0.4767 38 0.1788 0.4814 39 0.1788 0.4848 40 0.1788 0.4877 41 0.1788 0.4911 42 0.1788 0.4943 43 0.1788 0.4948 44 0.1788 0.4977 45 0.1788 0.5002 46 0.1788 0.5025 47 0.1788 0.5044 48 0.1788 0.5053 49 0.1788 0.5058 50 0.1788 0.5062 51 0.1788 0.5063 52 0.1788 0.5064 53 0.1788 0.5066 54 0.1788 0.5067 55 0.1788 0.5068 56 0.1788 0.5068 Backward pass complete: selected 21 terms of 57, GRSq 0.179 RSq 0.393 RESULT 24: GRSq 0.178818 RSq 0.393315 nTerms 22 of 57 of 101 FUNCTION eqn56 mi=1 n=300 p=6 [99.99 secs] TEST 24: FUNCTION eqn56 mi=1 n=300 p=6 441 // 0 +338 * max(0, x[4] - 0.812) // 1 -252 * max(0, 0.812 - x[4]) // 2 +2.11e+03 * max(0, x[0] - 0.287) // 3 -1.7e+03 * max(0, x[1] - 0.781) // 4 -1.39e+03 * max(0, x[0] - 0.261) // 5 -705 * max(0, x[0] - 0.332) // 6 -4.68e+03 * max(0, x[0] - -0.581) // 7 +3.57e+03 * max(0, x[0] - -0.595) // 8 +1.11e+03 * max(0, x[0] - -0.537) // 9 +899 * max(0, x[2] - 0.683) // 10 -154 * max(0, x[2] - 0.539) // 11 -746 * max(0, x[2] - 0.715) // 12 +2.15e+03 * max(0, x[1] - 0.758) // 13 +957 * max(0, x[4] - -0.817) // 14 -866 * max(0, x[4] - -0.888) // 15 -344 * max(0, x[4] - -0.726) // 16 -909 * max(0, x[1] - 0.682) // 17 +335 * max(0, x[1] - 0.608) // 18 -2.91e+03 * max(0, x[3] - -0.0354) // 19 +1.53e+03 * max(0, x[3] - -0.0073) // 20 +1.39e+03 * max(0, x[3] - -0.063) // 21 ============================================================================= TEST 25: eqn56 mi=2 n=300 p=6 Forward pass: minspan 6 endspan 9 x[300,6] 14.1 kB bx[300,51] 120 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 -0.0152 0.0184 0.01843 3 0.8014 1 2 1 3 0.0140 0.0788 0.06037 1 0.6822 3 4 2 2 5 0.1171 0.2034 0.1246 1 0.6077 5 6 1 7 0.1595 0.2682 0.06475 0 -0.5873 7 8 5 2 9 0.1686 0.3018 0.03367 3 -0.4905 9 10 5 2 11 0.1670 0.3258 0.02392 2 -0.4196 11 12 5 2 13 0.1612 0.3461 0.02033 5 -0.5464 13 14 5 2 15 0.1953 0.3962 0.05007 4 -0.8145 15 16 5 2 17 0.3645 0.5324 0.1362 4 -0.7038 17 5 2 19 0.3867 0.5574 0.02504 4 -0.6022 18 5 2 21 0.4423 0.6054 0.04804 0 -0.809 19 5 2 23 0.4445 0.6225 0.01704 4 0.7192 20 21 1 25 0.4566 0.6455 0.02305 4 0.6273 22 23 6 2 27 0.4722 0.6628 0.01725 1 -0.9934< 24 23 2 29 0.4879 0.6796 0.01683 3 -0.998< 25 23 2 31 0.4821 0.6895 0.009933 0 0.5901 26 27 1 33 0.4837 0.6972 0.007644 4 0.6292 28 1 35 0.4868 0.7055 0.008299 1 0.8802 29 1 37 0.4865 0.7118 0.006329 3 0.7639 30 1 39 0.4843 0.7170 0.005168 1 0.6227 31 24 2 41 0.5499 0.7585 0.04154 1 0.5219 32 24 2 43 0.5555 0.7670 0.008447 2 -0.651 33 5 2 45 0.5925 0.7913 0.02432 1 0.7577 34 1 47 0.6152 0.8120 0.02072 0 -0.8494 35 36 33 2 49 0.6461 0.8312 0.01922 1 0.6822 37 1 final (reached nk 51) Reached maximum number of terms 51 After forward pass GRSq 0.646 RSq 0.831 Forward pass complete: 51 terms, 38 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.0228 0.0390 2 0.0354 0.0674 3 0.0444 0.0917 4 0.1080 0.1666 5 0.1505 0.2201 6 0.3523 0.4156 7 0.3659 0.4379 8 0.4190 0.4941 9 0.5153 0.5855 10 0.5458 0.6186 11 0.5790 0.6529 12 0.5926 0.6702 13 0.6193 0.6976 14 0.6328 0.7137 15 0.6520 0.7339 16 0.6809 0.7605 17 0.6881 0.7705 18 0.7111 0.7915 19 0.7142 0.7978 20 0.7185 0.8048 21 0.7185 0.8062 22 0.7185 0.8111 23 0.7185 0.8150 24 0.7185 0.8179 25 0.7185 0.8207 26 0.7185 0.8244 27 0.7185 0.8248 28 0.7185 0.8252 29 0.7185 0.8265 30 0.7185 0.8266 31 0.7185 0.8274 32 0.7185 0.8284 33 0.7185 0.8295 34 0.7185 0.8304 35 0.7185 0.8310 36 0.7185 0.8311 37 0.7185 0.8312 Backward pass complete: selected 20 terms of 38, GRSq 0.719 RSq 0.805 RESULT 25: GRSq 0.718514 RSq 0.804785 nTerms 21 of 38 of 51 FUNCTION eqn56 mi=2 n=300 p=6 [99.99 secs] TEST 25: FUNCTION eqn56 mi=2 n=300 p=6 0.368 // 0 -373 * max(0, x[1] - 0.682) * max(0, 0.801 - x[3]) // 1 -1.28e+04 * max(0, x[1] - 0.608) // 2 +2.16e+03 * max(0, x[0] - -0.587) * max(0, x[1] - 0.608) // 3 -1.99e+03 * max(0, -0.587 - x[0]) * max(0, x[1] - 0.608) // 4 +731 * max(0, x[1] - 0.608) * max(0, -0.49 - x[3]) // 5 -4.17e+03 * max(0, x[1] - 0.608) * max(0, x[2] - -0.42) // 6 +1.48e+03 * max(0, x[1] - 0.608) * max(0, -0.42 - x[2]) // 7 +128 * max(0, x[1] - 0.608) * max(0, x[5] - -0.546) // 8 +1.53e+04 * max(0, x[1] - 0.608) * max(0, x[4] - -0.815) // 9 -2.76e+03 * max(0, x[1] - 0.608) * max(0, -0.815 - x[4]) // 10 -8.66e+03 * max(0, x[1] - 0.608) * max(0, x[4] - -0.704) // 11 +1.51e+03 * max(0, x[1] - 0.608) * max(0, x[4] - -0.602) // 12 -2.41e+03 * max(0, x[0] - -0.809) * max(0, x[1] - 0.608) // 13 -1.55e+03 * max(0, x[1] - 0.88) // 14 +7.36e+03 * max(0, x[1] - 0.623) * max(0, 0.719 - x[4]) // 15 +1.06e+03 * max(0, x[1] - 0.522) * max(0, 0.719 - x[4]) // 16 +3.97e+03 * max(0, x[1] - 0.608) * max(0, x[2] - -0.651) // 17 +1.29e+03 * max(0, x[1] - 0.758) // 18 -3.26e+03 * max(0, -0.849 - x[0]) * max(0, x[4] - 0.629) // 19 -1.13e+03 * max(0, x[1] - 0.682) // 20 ============================================================================= TEST 26: eqn56 mi=10 n=300 p=6 Forward pass: minspan 6 endspan 9 x[300,6] 14.1 kB bx[300,51] 120 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 -0.0152 0.0184 0.01843 3 0.8014 1 2 1 3 0.0140 0.0788 0.06037 1 0.6822 3 4 2 2 5 0.1171 0.2034 0.1246 1 0.6077 5 6 1 7 0.2219 0.3104 0.1069 2 -0.9815< 7 3 3 9 0.3685 0.4600 0.1496 2 -0.651 8 9 5 2 11 0.4045 0.5090 0.04905 3 -0.6392 10 11 9 3 13 0.5140 0.6067 0.09765 5 -0.9938< 12 11 4 15 0.5310 0.6343 0.02768 4 -0.8168 13 14 9 3 17 0.6424 0.7264 0.0921 4 -0.7672 15 9 3 19 0.6517 0.7437 0.01724 4 0.7939 16 17 1 21 0.6609 0.7601 0.01643 4 0.6273 18 19 6 2 23 0.6864 0.7825 0.02242 1 -0.9934< 20 19 2 25 0.7266 0.8142 0.03168 3 -0.998< 21 19 2 27 0.7399 0.8303 0.01609 5 -0.7873 22 23 9 3 29 0.7564 0.8443 0.01405 0 -0.9936< 24 21 3 31 0.7539 0.8493 0.004929 1 0.6229 25 26 20 2 33 0.8041 0.8826 0.03329 1 0.5219 27 20 2 35 0.8334 0.9023 0.01971 1 0.6401 28 1 37 0.8603 0.9198 0.01756 1 0.5154 29 1 39 0.8862 0.9376 0.01774 4 -0.8168 30 31 27 4 41 0.8982 0.9454 0.007829 1 0.6573 32 20 2 43 0.8988 0.9482 0.002777 0 0.5901 33 34 1 45 0.9012 0.9506 0.002412 4 0.6292 35 1 47 0.9039 0.9530 0.002459 2 -0.651 36 35 2 49 0.9067 0.9566 0.003526 5 -0.6556 37 38 5 2 final (reached nk 51) Reached maximum number of terms 51 After forward pass GRSq 0.907 RSq 0.957 Forward pass complete: 51 terms, 39 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.1745 0.1882 2 0.2312 0.2567 3 0.3407 0.3733 4 0.6551 0.6778 5 0.6837 0.7096 6 0.7105 0.7388 7 0.7193 0.7512 8 0.7193 0.7512 9 0.7193 0.7517 10 0.7193 0.7604 11 0.7193 0.7610 12 0.7193 0.7617 13 0.7193 0.7625 14 0.7576 0.8110 15 0.7589 0.8156 16 0.7980 0.8484 17 0.8180 0.8661 18 0.8382 0.8832 19 0.8456 0.8908 20 0.8491 0.8954 21 0.8627 0.9067 22 0.8746 0.9165 23 0.8836 0.9240 24 0.8916 0.9308 25 0.9011 0.9381 26 0.9068 0.9429 27 0.9117 0.9471 28 0.9145 0.9498 29 0.9160 0.9518 30 0.9174 0.9537 31 0.9174 0.9544 32 0.9175 0.9557 33 0.9175 0.9564 34 0.9175 0.9565 35 0.9175 0.9566 36 0.9175 0.9566 37 0.9175 0.9566 38 0.9175 0.9566 Backward pass complete: selected 32 terms of 39, GRSq 0.918 RSq 0.956 RESULT 26: GRSq 0.917515 RSq 0.955749 nTerms 33 of 39 of 51 FUNCTION eqn56 mi=10 n=300 p=6 [99.99 secs] TEST 26: FUNCTION eqn56 mi=10 n=300 p=6 -2.91 // 0 -221 * max(0, x[1] - 0.682) * max(0, 0.801 - x[3]) // 1 +3.06e+03 * max(0, x[1] - 0.608) // 2 -1.69e+03 * max(0, 0.608 - x[1]) // 3 -417 * max(0, x[1] - 0.682) * x[2] * max(0, 0.801 - x[3]) // 4 -658 * max(0, x[1] - 0.608) * max(0, x[2] - -0.651) // 5 -377 * max(0, x[1] - 0.608) * max(0, -0.651 - x[2]) // 6 +326 * max(0, x[1] - 0.608) * max(0, x[2] - -0.651) * max(0, -0.639 - x[3]) // 7 +100 * max(0, x[1] - 0.608) * max(0, x[2] - -0.651) * max(0, x[3] - -0.639) * x[5] // 8 +9.01e+03 * max(0, x[1] - 0.608) * max(0, x[2] - -0.651) * max(0, x[4] - -0.817) // 9 +5.86e+03 * max(0, x[1] - 0.608) * max(0, x[2] - -0.651) * max(0, -0.817 - x[4]) // 10 -9.32e+03 * max(0, x[1] - 0.608) * max(0, x[2] - -0.651) * max(0, x[4] - -0.767) // 11 -6.16e+03 * max(0, x[4] - 0.794) // 12 -152 * max(0, 0.794 - x[4]) // 13 +1.01e+04 * max(0, 0.608 - x[1]) * max(0, x[4] - 0.627) // 14 -1.02e+04 * max(0, 0.608 - x[1]) * max(0, 0.627 - x[4]) // 15 +1.05e+04 * x[1] * max(0, x[4] - 0.794) // 16 +216 * x[3] * max(0, x[4] - 0.794) // 17 -177 * max(0, x[1] - 0.608) * max(0, x[2] - -0.651) * max(0, x[5] - -0.787) // 18 +1.37e+03 * max(0, x[1] - 0.608) * max(0, x[2] - -0.651) * max(0, -0.787 - x[5]) // 19 +53.2 * x[0] * max(0, 0.608 - x[1]) * max(0, x[4] - 0.627) // 20 -2.24e+03 * max(0, x[1] - 0.623) * max(0, 0.794 - x[4]) // 21 +1.02e+04 * max(0, 0.623 - x[1]) * max(0, 0.794 - x[4]) // 22 +1.56e+03 * max(0, x[1] - 0.522) * max(0, 0.794 - x[4]) // 23 -2.55e+03 * max(0, x[1] - 0.64) // 24 -566 * max(0, x[1] - 0.515) // 25 +310 * max(0, x[1] - 0.608) * max(0, x[2] - -0.651) * max(0, x[4] - -0.817) * max(0, x[5] - -0.787) // 26 +5.8e+03 * max(0, x[1] - 0.608) * max(0, x[2] - -0.651) * max(0, -0.817 - x[4]) * max(0, x[5] - -0.787) // 27 +677 * max(0, x[1] - 0.657) * max(0, 0.794 - x[4]) // 28 +12.2 * max(0, x[0] - 0.59) // 29 +65.9 * max(0, x[4] - 0.629) // 30 +758 * max(0, x[1] - 0.64) * max(0, x[2] - -0.651) // 31 -534 * max(0, x[1] - 0.608) * max(0, -0.656 - x[5]) // 32 ============================================================================= TEST 27: x0 + x1 + x0*x1 n=30 p=2 Forward pass: minspan 4 endspan 8 x[30,2] 480 Bytes bx[30,51] 12 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.3267 0.5388 0.5388 1 0.2223 1 2 1 3 0.7103 0.8756 0.3368 0 -0.7273 3 4 1 5 0.9981 0.9994 0.1238 1 -0.963< 5 3 2 final (max RSq) Reached maximum RSq 0.9990 at 7 terms, 6 terms used (RSq 0.9994) After forward pass GRSq 0.998 RSq 0.999 Forward pass complete: 7 terms, 6 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.3418 0.4504 2 0.9651 0.9761 3 0.9842 0.9913 4 0.9927 0.9969 5 0.9981 0.9994 Backward pass complete: selected 5 terms of 6, GRSq 0.998 RSq 0.999 RESULT 27: GRSq 0.998138 RSq 0.999397 nTerms 6 of 6 of 51 FUNCTION x0 + x1 + x0*x1 n=30 p=2 [99.99 secs] TEST 27: FUNCTION x0 + x1 + x0*x1 n=30 p=2 -0.686 // 0 +0.283 * max(0, x[1] - 0.222) // 1 -0.23 * max(0, 0.222 - x[1]) // 2 +1 * max(0, x[0] - -0.727) // 3 -0.597 * max(0, -0.727 - x[0]) // 4 +1.02 * max(0, x[0] - -0.727) * x[1] // 5 ============================================================================= TEST 28: x0 + x1 + x0*x1 n=30 p=2 Forward pass: minspan 4 endspan 8 x[30,2] 480 Bytes bx[30,51] 12 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.3267 0.5388 0.5388 1 0.2223 1 2 1 3 0.7103 0.8756 0.3368 0 -0.7273 3 4 1 5 0.9981 0.9994 0.1238 1 -0.963< 5 3 2 final (max RSq) Reached maximum RSq 0.9990 at 7 terms, 6 terms used (RSq 0.9994) After forward pass GRSq 0.998 RSq 0.999 Forward pass complete: 7 terms, 6 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.3418 0.4504 2 0.9651 0.9761 3 0.9842 0.9913 4 0.9927 0.9969 5 0.9981 0.9994 Backward pass complete: selected 5 terms of 6, GRSq 0.998 RSq 0.999 RESULT 28: GRSq 0.998138 RSq 0.999397 nTerms 6 of 6 of 51 FUNCTION x0 + x1 + x0*x1 n=30 p=2 [99.99 secs] TEST 28: FUNCTION x0 + x1 + x0*x1 n=30 p=2 -0.686 // 0 +0.283 * max(0, x[1] - 0.222) // 1 -0.23 * max(0, 0.222 - x[1]) // 2 +1 * max(0, x[0] - -0.727) // 3 -0.597 * max(0, -0.727 - x[0]) // 4 +1.02 * max(0, x[0] - -0.727) * x[1] // 5 ============================================================================= TEST 29: x0 + x1 + x0*x1 n=30 p=2 Forward pass: minspan 4 endspan 8 x[30,2] 480 Bytes bx[30,51] 12 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.3267 0.5388 0.5388 1 0.2223 1 2 1 3 0.7103 0.8756 0.3368 0 -0.7273 3 4 1 5 0.9981 0.9994 0.1238 1 -0.963< 5 3 2 final (max RSq) Reached maximum RSq 0.9990 at 7 terms, 6 terms used (RSq 0.9994) After forward pass GRSq 0.998 RSq 0.999 Forward pass complete: 7 terms, 6 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.3418 0.4504 2 0.9651 0.9761 3 0.9842 0.9913 4 0.9927 0.9969 5 0.9981 0.9994 Backward pass complete: selected 5 terms of 6, GRSq 0.998 RSq 0.999 RESULT 29: GRSq 0.998138 RSq 0.999397 nTerms 6 of 6 of 51 FUNCTION x0 + x1 + x0*x1 n=30 p=2 [99.99 secs] TEST 29: FUNCTION x0 + x1 + x0*x1 n=30 p=2 -0.686 // 0 +0.283 * max(0, x[1] - 0.222) // 1 -0.23 * max(0, 0.222 - x[1]) // 2 +1 * max(0, x[0] - -0.727) // 3 -0.597 * max(0, -0.727 - x[0]) // 4 +1.02 * max(0, x[0] - -0.727) * x[1] // 5 ============================================================================= TEST 30: x0|x0+x1 degree=1 n=30 p=2 Forward pass: minspan 4 endspan 8 x[30,2] 480 Bytes bx[30,51] 12 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.5789 0.6870 0.687 0 -0.7273 1 2 1 3 1.0000 1.0000 0.313 1 -0.963< 3 1 final (max RSq) Reached maximum RSq 0.9990 at 5 terms, 4 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 5 terms, 4 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.5386 0.6001 2 0.9867 0.9901 3 1.0000 1.0000 Backward pass complete: selected 3 terms of 4, GRSq 1.000 RSq 1.000 RESULT 30 Response 1: GRSq 1 RSq 1 nTerms 4 of 4 of 51 FUNCTION x0|x0+x1 degree=1 n=30 p=2 [99.99 secs] RESULT 30 Response 2: GRSq 1 RSq 1 nTerms 4 of 4 of 51 TEST 30: FUNCTION x0|x0+x1 degree=1 n=30 p=2 Response 0: -0.727 // 0 +1 * max(0, x[0] - -0.727) // 1 -1 * max(0, -0.727 - x[0]) // 2 Response 1: -0.727 // 0 +1 * max(0, x[0] - -0.727) // 1 -1 * max(0, -0.727 - x[0]) // 2 +1 * x[1] // 3 ============================================================================= TEST 31: x0|x+x1+noise n=100 p=2 Forward pass: minspan 4 endspan 8 x[100,2] 1.56 kB bx[100,51] 39.8 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.6317 0.6608 0.6608 0 0.2417 1 2 1 3 0.9891 0.9908 0.33 1 0.2735 3 4 1 5 0.9888 0.9910 0.000128 0 0.1378 5 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00013) After forward pass GRSq 0.989 RSq 0.991 Forward pass complete: 5 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.5796 0.5964 2 0.8814 0.8907 3 0.9473 0.9535 4 0.9891 0.9908 Backward pass complete: selected 4 terms of 5, GRSq 0.989 RSq 0.991 RESULT 31 Response 1: GRSq 1 RSq 1 nTerms 5 of 5 of 51 FUNCTION x0|x+x1+noise n=100 p=2 [99.99 secs] RESULT 31 Response 2: GRSq 0.98363 RSq 0.98616 nTerms 5 of 5 of 51 TEST 31: FUNCTION x0|x+x1+noise n=100 p=2 Response 0: 0.242 // 0 +1 * max(0, x[0] - 0.242) // 1 -1 * max(0, 0.242 - x[0]) // 2 Response 1: 0.404 // 0 +1.1 * max(0, x[0] - 0.242) // 1 -0.962 * max(0, 0.242 - x[0]) // 2 +1.02 * max(0, x[1] - 0.274) // 3 -0.986 * max(0, 0.274 - x[1]) // 4 ============================================================================= TEST 32: x0+x1+x0*x1|x0+x1+x0*x1 degree=1 n=100 p=2 Forward pass: minspan 4 endspan 8 x[100,2] 1.56 kB bx[100,51] 39.8 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.3856 0.4343 0.4343 0 0.1584 1 2 1 3 0.8191 0.8471 0.4129 1 -0.6765 3 4 1 5 0.8184 0.8532 0.006106 1 0.4798 5 1 7 0.8121 0.8549 0.00167 0 0.5061 6 1 9 0.8052 0.8564 0.001487 0 -0.0415 7 1 11 0.7967 0.8571 0.0007263 0 0.6089 8 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 11 terms, 8 terms used (DeltaRSq 0.00073) After forward pass GRSq 0.797 RSq 0.857 Forward pass complete: 11 terms, 8 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.3518 0.3777 2 0.7354 0.7564 3 0.7693 0.7964 4 0.8191 0.8471 5 0.8191 0.8532 6 0.8191 0.8549 7 0.8191 0.8564 Backward pass complete: selected 4 terms of 8, GRSq 0.819 RSq 0.847 RESULT 32 Response 1: GRSq 0.81906 RSq 0.84712 nTerms 5 of 8 of 51 FUNCTION x0+x1+x0*x1|x0+x1+x0*x1 degree=1 n=100 p=2 [99.99 secs] RESULT 32 Response 2: GRSq -1.0363 RSq -0.72047 nTerms 5 of 8 of 51 TEST 32: FUNCTION x0+x1+x0*x1|x0+x1+x0*x1 degree=1 n=100 p=2 Response 0: -0.326 // 0 +1.14 * max(0, x[0] - 0.158) // 1 -0.938 * max(0, 0.158 - x[0]) // 2 +0.72 * max(0, x[1] - -0.676) // 3 -2.76 * max(0, -0.676 - x[1]) // 4 Response 1: 0.72 // 0 -2.76 * max(0, x[0] - 0.158) // 1 -0.987 * max(0, 0.158 - x[0]) // 2 +0.515 * max(0, x[1] - -0.676) // 3 -3.14 * max(0, -0.676 - x[1]) // 4 ============================================================================= TEST 33: x0+x1+x0*x1|x0+x1+x0*x1 degree=2 n=100 p=2 Forward pass: minspan 4 endspan 8 x[100,2] 1.56 kB bx[100,51] 39.8 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.3725 0.4343 0.4343 0 0.1584 1 2 1 3 0.8108 0.8471 0.4129 1 -0.6765 3 4 1 5 0.9973 0.9981 0.1509 0 -0.0115 5 6 3 2 7 1.0000 1.0000 0.001948 0 -0.9936< 7 4 2 final (max RSq) Reached maximum RSq 0.9990 at 9 terms, 8 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 9 terms, 8 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.3428 0.3756 2 0.8797 0.8916 3 0.9838 0.9861 4 0.9906 0.9924 5 0.9972 0.9979 6 0.9980 0.9986 7 1.0000 1.0000 Backward pass complete: selected 7 terms of 8, GRSq 1.000 RSq 1.000 RESULT 33 Response 1: GRSq 1 RSq 1 nTerms 8 of 8 of 51 FUNCTION x0+x1+x0*x1|x0+x1+x0*x1 degree=2 n=100 p=2 [99.99 secs] RESULT 33 Response 2: GRSq 1 RSq 1 nTerms 8 of 8 of 51 TEST 33: FUNCTION x0+x1+x0*x1|x0+x1+x0*x1 degree=2 n=100 p=2 Response 0: -0.625 // 0 +0.324 * max(0, x[0] - 0.158) // 1 -0.323 * max(0, 0.158 - x[0]) // 2 +0.989 * max(0, x[1] - -0.676) // 3 -1 * max(0, -0.676 - x[1]) // 4 +1 * max(0, x[0] - -0.0115) * max(0, x[1] - -0.676) // 5 -1 * max(0, -0.0115 - x[0]) * max(0, x[1] - -0.676) // 6 -1 * x[0] * max(0, -0.676 - x[1]) // 7 Response 1: -0.625 // 0 +0.324 * max(0, x[0] - 0.158) // 1 -0.323 * max(0, 0.158 - x[0]) // 2 +0.989 * max(0, x[1] - -0.676) // 3 -1 * max(0, -0.676 - x[1]) // 4 +1 * max(0, x[0] - -0.0115) * max(0, x[1] - -0.676) // 5 -1 * max(0, -0.0115 - x[0]) * max(0, x[1] - -0.676) // 6 -1 * x[0] * max(0, -0.676 - x[1]) // 7 ============================================================================= TEST 34: x0|sin(2*x0) + 2*x1 + 0.5*x0*x1 + 8 noise preds n=200 p=10 Forward pass: minspan 6 endspan 10 x[200,10] 15.6 kB bx[200,101] 158 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.5579 0.5798 0.5798 1 0.4349 1 2 1 3 0.9818 0.9835 0.4037 0 -0.6959 3 4 1 5 0.9949 0.9956 0.01206 0 0.3567 5 6 2 2 7 0.9972 0.9977 0.002059 0 0.5189 7 1 9 0.9993 0.9994 0.00174 0 -0.3794 8 1 final (max RSq) Reached maximum RSq 0.9990 at 11 terms, 9 terms used (RSq 0.9994) After forward pass GRSq 0.999 RSq 0.999 Forward pass complete: 11 terms, 9 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.5072 0.5195 2 0.9476 0.9502 3 0.9798 0.9813 4 0.9852 0.9866 5 0.9941 0.9948 6 0.9968 0.9973 7 0.9983 0.9986 8 0.9993 0.9994 Backward pass complete: selected 8 terms of 9, GRSq 0.999 RSq 0.999 RESULT 34 Response 1: GRSq 1 RSq 1 nTerms 9 of 9 of 101 FUNCTION x0|sin(2*x0) + 2*x1 + 0.5*x0*x1 + 8 noise preds n=200 p=10 [99.99 secs] RESULT 34 Response 2: GRSq 0.99913 RSq 0.9993 nTerms 9 of 9 of 101 TEST 34: FUNCTION x0|sin(2*x0) + 2*x1 + 0.5*x0*x1 + 8 noise preds n=200 p=10 Response 0: -0.696 // 0 +1 * max(0, x[0] - -0.696) // 3 -1 * max(0, -0.696 - x[0]) // 4 Response 1: -0.324 // 0 +1.92 * max(0, x[1] - 0.435) // 1 -2.21 * max(0, 0.435 - x[1]) // 2 +1.25 * max(0, x[0] - -0.696) // 3 -0.0334 * max(0, -0.696 - x[0]) // 4 -0.609 * max(0, x[0] - 0.357) * max(0, 0.435 - x[1]) // 5 +0.563 * max(0, 0.357 - x[0]) * max(0, 0.435 - x[1]) // 6 -1.73 * max(0, x[0] - 0.519) // 7 +0.869 * max(0, x[0] - -0.379) // 8 ============================================================================= TEST 35: x0|x0+x1+x0*x1|sin(2*x0) + 2*x1 + 0.5*x0*x1 + 8 noise preds n=200 p=11 Forward pass: minspan 6 endspan 10 x[200,11] 17.2 kB bx[200,101] 158 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.4262 0.4547 0.4547 1 0.6822 1 2 1 3 0.9333 0.9399 0.4852 0 -0.6826 3 4 1 5 0.9968 0.9972 0.05738 0 0.4397 5 6 2 2 7 0.9982 0.9985 0.001282 0 0.5752 7 1 9 0.9993 0.9994 0.000894 0 -0.4534 8 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 9 terms, 8 terms used (DeltaRSq 0.00089) After forward pass GRSq 0.999 RSq 0.999 Forward pass complete: 9 terms, 8 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.4315 0.4457 2 0.9262 0.9298 3 0.9641 0.9667 4 0.9811 0.9829 5 0.9905 0.9917 6 0.9968 0.9972 7 0.9982 0.9985 Backward pass complete: selected 7 terms of 8, GRSq 0.998 RSq 0.999 RESULT 35 Response 1: GRSq 1 RSq 1 nTerms 8 of 8 of 101 FUNCTION x0|x0+x1+x0*x1|sin(2*x0) + 2*x1 + 0.5*x0*x1 + 8 noise preds n=200 p=11 [99.99 secs] RESULT 35 Response 2: GRSq 0.99828 RSq 0.99857 nTerms 8 of 8 of 101 RESULT 35 Response 3: GRSq 0.99778 RSq 0.99816 nTerms 8 of 8 of 101 TEST 35: FUNCTION x0|x0+x1+x0*x1|sin(2*x0) + 2*x1 + 0.5*x0*x1 + 8 noise preds n=200 p=11 Response 0: -0.683 // 0 +1 * max(0, x[ 0] - -0.683) // 3 -1 * max(0, -0.683 - x[ 0]) // 4 Response 1: -0.492 // 0 +0.698 * max(0, x[ 1] - 0.682) // 1 -1.49 * max(0, 0.682 - x[ 1]) // 2 +1.76 * max(0, x[ 0] - -0.683) // 3 -1.73 * max(0, -0.683 - x[ 0]) // 4 -0.937 * max(0, x[ 0] - 0.44) * max(0, 0.682 - x[ 1]) // 5 +1.07 * max(0, 0.44 - x[ 0]) * max(0, 0.682 - x[ 1]) // 6 -0.23 * max(0, x[ 0] - 0.575) // 7 Response 2: 0.0355 // 0 +1.87 * max(0, x[ 1] - 0.682) // 1 -2.23 * max(0, 0.682 - x[ 1]) // 2 +1.99 * max(0, x[ 0] - -0.683) // 3 +0.24 * max(0, -0.683 - x[ 0]) // 4 -0.504 * max(0, x[ 0] - 0.44) * max(0, 0.682 - x[ 1]) // 5 +0.511 * max(0, 0.44 - x[ 0]) * max(0, 0.682 - x[ 1]) // 6 -1.61 * max(0, x[ 0] - 0.575) // 7 ============================================================================= TEST 36: |x0+x1+x0*x1|sin(2*x0) + 2*x1 + 0.5*x0*x1|x0 + 8 noise preds n=200 p=11 Forward pass: minspan 6 endspan 10 x[200,11] 17.2 kB bx[200,101] 158 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.4262 0.4547 0.4547 1 0.6822 1 2 1 3 0.9333 0.9399 0.4852 0 -0.6826 3 4 1 5 0.9968 0.9972 0.05738 0 0.4397 5 6 2 2 7 0.9982 0.9985 0.001282 0 0.5752 7 1 9 0.9993 0.9994 0.000894 0 -0.4534 8 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 9 terms, 8 terms used (DeltaRSq 0.00089) After forward pass GRSq 0.999 RSq 0.999 Forward pass complete: 9 terms, 8 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.4315 0.4457 2 0.9262 0.9298 3 0.9641 0.9667 4 0.9811 0.9829 5 0.9905 0.9917 6 0.9968 0.9972 7 0.9982 0.9985 Backward pass complete: selected 7 terms of 8, GRSq 0.998 RSq 0.999 RESULT 36 Response 1: GRSq 0.99828 RSq 0.99857 nTerms 8 of 8 of 101 FUNCTION |x0+x1+x0*x1|sin(2*x0) + 2*x1 + 0.5*x0*x1|x0 + 8 noise preds n=200 p=11 [99.99 secs] RESULT 36 Response 2: GRSq 0.99778 RSq 0.99816 nTerms 8 of 8 of 101 RESULT 36 Response 3: GRSq 1 RSq 1 nTerms 8 of 8 of 101 TEST 36: FUNCTION |x0+x1+x0*x1|sin(2*x0) + 2*x1 + 0.5*x0*x1|x0 + 8 noise preds n=200 p=11 Response 0: -0.492 // 0 +0.698 * max(0, x[ 1] - 0.682) // 1 -1.49 * max(0, 0.682 - x[ 1]) // 2 +1.76 * max(0, x[ 0] - -0.683) // 3 -1.73 * max(0, -0.683 - x[ 0]) // 4 -0.937 * max(0, x[ 0] - 0.44) * max(0, 0.682 - x[ 1]) // 5 +1.07 * max(0, 0.44 - x[ 0]) * max(0, 0.682 - x[ 1]) // 6 -0.23 * max(0, x[ 0] - 0.575) // 7 Response 1: 0.0355 // 0 +1.87 * max(0, x[ 1] - 0.682) // 1 -2.23 * max(0, 0.682 - x[ 1]) // 2 +1.99 * max(0, x[ 0] - -0.683) // 3 +0.24 * max(0, -0.683 - x[ 0]) // 4 -0.504 * max(0, x[ 0] - 0.44) * max(0, 0.682 - x[ 1]) // 5 +0.511 * max(0, 0.44 - x[ 0]) * max(0, 0.682 - x[ 1]) // 6 -1.61 * max(0, x[ 0] - 0.575) // 7 Response 2: -0.683 // 0 +1 * max(0, x[ 0] - -0.683) // 3 -1 * max(0, -0.683 - x[ 0]) // 4 ============================================================================= TEST 37: sin(2*x0) + 2*x1 + 0.5*x0*x1|x0+x1+x0*x1|x0 + 8 noise preds n=200 p=11 Forward pass: minspan 6 endspan 10 x[200,11] 17.2 kB bx[200,101] 158 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.4262 0.4547 0.4547 1 0.6822 1 2 1 3 0.9333 0.9399 0.4852 0 -0.6826 3 4 1 5 0.9968 0.9972 0.05738 0 0.4397 5 6 2 2 7 0.9982 0.9985 0.001282 0 0.5752 7 1 9 0.9993 0.9994 0.000894 0 -0.4534 8 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 9 terms, 8 terms used (DeltaRSq 0.00089) After forward pass GRSq 0.999 RSq 0.999 Forward pass complete: 9 terms, 8 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.4315 0.4457 2 0.9262 0.9298 3 0.9641 0.9667 4 0.9811 0.9829 5 0.9905 0.9917 6 0.9968 0.9972 7 0.9982 0.9985 Backward pass complete: selected 7 terms of 8, GRSq 0.998 RSq 0.999 RESULT 37 Response 1: GRSq 0.99778 RSq 0.99816 nTerms 8 of 8 of 101 FUNCTION sin(2*x0) + 2*x1 + 0.5*x0*x1|x0+x1+x0*x1|x0 + 8 noise preds n=200 p=11 [99.99 secs] RESULT 37 Response 2: GRSq 0.99828 RSq 0.99857 nTerms 8 of 8 of 101 RESULT 37 Response 3: GRSq 1 RSq 1 nTerms 8 of 8 of 101 TEST 37: FUNCTION sin(2*x0) + 2*x1 + 0.5*x0*x1|x0+x1+x0*x1|x0 + 8 noise preds n=200 p=11 Response 0: 0.0355 // 0 +1.87 * max(0, x[ 1] - 0.682) // 1 -2.23 * max(0, 0.682 - x[ 1]) // 2 +1.99 * max(0, x[ 0] - -0.683) // 3 +0.24 * max(0, -0.683 - x[ 0]) // 4 -0.504 * max(0, x[ 0] - 0.44) * max(0, 0.682 - x[ 1]) // 5 +0.511 * max(0, 0.44 - x[ 0]) * max(0, 0.682 - x[ 1]) // 6 -1.61 * max(0, x[ 0] - 0.575) // 7 Response 1: -0.492 // 0 +0.698 * max(0, x[ 1] - 0.682) // 1 -1.49 * max(0, 0.682 - x[ 1]) // 2 +1.76 * max(0, x[ 0] - -0.683) // 3 -1.73 * max(0, -0.683 - x[ 0]) // 4 -0.937 * max(0, x[ 0] - 0.44) * max(0, 0.682 - x[ 1]) // 5 +1.07 * max(0, 0.44 - x[ 0]) * max(0, 0.682 - x[ 1]) // 6 -0.23 * max(0, x[ 0] - 0.575) // 7 Response 2: -0.683 // 0 +1 * max(0, x[ 0] - -0.683) // 3 -1 * max(0, -0.683 - x[ 0]) // 4 ============================================================================= TEST 38: sin(2*x0) + 2*x1 + 0.5*x0*x1|2nd order 6 preds + noise n=1000 p=6 Forward pass: minspan 6 endspan 9 x[1000,6] 46.9 kB bx[1000,101] 789 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.3712 0.3774 0.3774 1 0.9369 1 2 1 3 0.5740 0.5825 0.2051 0 -0.7048 3 4 1 5 0.6602 0.6704 0.08787 4 -0.2051 5 6 1 7 0.7446 0.7548 0.08438 5 0.386 7 8 5 2 9 0.8232 0.8320 0.07721 3 0.8418 9 10 1 11 0.9009 0.9067 0.07478 2 -0.7192 11 12 1 13 0.9380 0.9423 0.03556 0 0.5822 13 14 2 2 15 0.9727 0.9748 0.03253 2 0.7584 15 16 10 2 17 0.9900 0.9909 0.01602 5 0.8057 17 18 1 19 0.9950 0.9955 0.004603 5 0.5908 19 20 6 2 21 0.9957 0.9962 0.0007247 0 -0.3888 21 2 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 21 terms (DeltaRSq 0.00072) After forward pass GRSq 0.996 RSq 0.996 Forward pass complete: 21 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.3733 0.3765 2 0.5777 0.5819 3 0.6580 0.6631 4 0.7400 0.7452 5 0.8136 0.8182 6 0.8876 0.8910 7 0.9132 0.9162 8 0.9373 0.9398 9 0.9577 0.9596 10 0.9692 0.9707 11 0.9784 0.9795 12 0.9837 0.9847 13 0.9886 0.9894 14 0.9933 0.9938 15 0.9943 0.9948 16 0.9949 0.9953 17 0.9950 0.9954 18 0.9950 0.9954 19 0.9950 0.9954 20 0.9950 0.9955 Backward pass complete: selected 17 terms of 21, GRSq 0.995 RSq 0.995 RESULT 38 Response 1: GRSq 0.9963 RSq 0.99661 nTerms 18 of 21 of 101 FUNCTION sin(2*x0) + 2*x1 + 0.5*x0*x1|2nd order 6 preds + noise n=1000 p=6 [99.99 secs] RESULT 38 Response 2: GRSq -4.5942 RSq -4.1284 nTerms 18 of 21 of 101 TEST 38: FUNCTION sin(2*x0) + 2*x1 + 0.5*x0*x1|2nd order 6 preds + noise n=1000 p=6 Response 0: 0.452 // 0 -2.19 * max(0, 0.937 - x[1]) // 1 +1.95 * max(0, x[0] - -0.705) // 2 +0.46 * max(0, -0.705 - x[0]) // 3 +0.0111 * max(0, x[4] - -0.205) // 4 +0.00685 * max(0, -0.205 - x[4]) // 5 -0.0418 * max(0, x[4] - -0.205) * max(0, x[5] - 0.386) // 6 -0.0327 * max(0, x[4] - -0.205) * max(0, 0.386 - x[5]) // 7 +0.0286 * max(0, x[3] - 0.842) // 8 +0.00298 * max(0, 0.842 - x[3]) // 9 +0.00184 * max(0, x[2] - -0.719) // 10 -0.0488 * max(0, -0.719 - x[2]) // 11 -1.55 * max(0, x[0] - 0.582) * max(0, 0.937 - x[1]) // 12 +0.388 * max(0, 0.582 - x[0]) * max(0, 0.937 - x[1]) // 13 -0.0569 * max(0, x[2] - 0.758) * max(0, 0.842 - x[3]) // 14 -0.000517 * max(0, 0.758 - x[2]) * max(0, 0.842 - x[3]) // 15 +0.0135 * max(0, 0.806 - x[5]) // 16 -0.0169 * max(0, -0.205 - x[4]) * max(0, 0.591 - x[5]) // 17 Response 1: -1.91 // 0 +1.35 * max(0, 0.937 - x[1]) // 1 -1.73 * max(0, x[0] - -0.705) // 2 +1.09 * max(0, -0.705 - x[0]) // 3 -0.966 * max(0, x[4] - -0.205) // 4 +0.898 * max(0, -0.205 - x[4]) // 5 -1.77 * max(0, x[4] - -0.205) * max(0, x[5] - 0.386) // 6 +1.85 * max(0, x[4] - -0.205) * max(0, 0.386 - x[5]) // 7 -1.95 * max(0, x[3] - 0.842) // 8 -1.05 * max(0, 0.842 - x[3]) // 9 +1.01 * max(0, x[2] - -0.719) // 10 -1.01 * max(0, -0.719 - x[2]) // 11 +1.01 * max(0, x[0] - 0.582) * max(0, 0.937 - x[1]) // 12 -0.816 * max(0, 0.582 - x[0]) * max(0, 0.937 - x[1]) // 13 +1.12 * max(0, x[2] - 0.758) * max(0, 0.842 - x[3]) // 14 -1.01 * max(0, 0.758 - x[2]) * max(0, 0.842 - x[3]) // 15 +1.01 * max(0, 0.806 - x[5]) // 16 +0.475 * max(0, -0.205 - x[4]) * max(0, 0.591 - x[5]) // 17 ============================================================================= TEST 39: cos(x1) + cos(x2), x1 and x2 xcollinear, NewVarPenalty=0 n=100 p=2 Forward pass: minspan 4 endspan 8 x[100,2] 1.56 kB bx[100,51] 39.8 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.8908 0.8994 0.8994 0 -0.0415 1 2 1 3 0.8988 0.9145 0.01503 1 0.60639 3 4 1 5 0.9099 0.9272 0.01271 0 -0.4472 5 1 7 0.9123 0.9322 0.005049 0 0.2417 6 1 9 0.9083 0.9324 0.0001538 0 0.6089 7 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 9 terms, 7 terms used (DeltaRSq 0.00015) After forward pass GRSq 0.908 RSq 0.932 Forward pass complete: 9 terms, 7 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.5190 0.5383 2 0.8951 0.9034 3 0.9160 0.9258 4 0.9160 0.9280 5 0.9160 0.9311 6 0.9160 0.9322 Backward pass complete: selected 3 terms of 7, GRSq 0.916 RSq 0.926 RESULT 39: GRSq 0.915959 RSq 0.925837 nTerms 4 of 7 of 51 FUNCTION cos(x1) + cos(x2), x1 and x2 xcollinear, NewVarPenalty=0 n=100 p=2 [99.99 secs] TEST 39: FUNCTION cos(x1) + cos(x2), x1 and x2 xcollinear, NewVarPenalty=0 n=100 p=2 2.21 // 0 -1.27 * max(0, -0.0415 - x[0]) // 1 -0.867 * max(0, x[1] - 0.606) // 2 -0.559 * max(0, x[0] - -0.447) // 3 ============================================================================= TEST 40: cos(x1) + cos(x2), x1 and x2 xcollinear, NewVarPenalty=0 n=100 p=2 Forward pass: minspan 4 endspan 8 x[100,2] 1.56 kB bx[100,51] 39.8 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.8908 0.8994 0.8994 0 -0.0415 1 2 1 3 0.8988 0.9145 0.01503 1 0.60639 3 4 1 5 0.9099 0.9272 0.01271 0 -0.4472 5 1 7 0.9123 0.9322 0.005049 0 0.2417 6 1 9 0.9083 0.9324 0.0001538 0 0.6089 7 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 9 terms, 7 terms used (DeltaRSq 0.00015) After forward pass GRSq 0.908 RSq 0.932 Forward pass complete: 9 terms, 7 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.5190 0.5383 2 0.8951 0.9034 3 0.9160 0.9258 4 0.9160 0.9280 5 0.9160 0.9311 6 0.9160 0.9322 Backward pass complete: selected 3 terms of 7, GRSq 0.916 RSq 0.926 RESULT 40: GRSq 0.915959 RSq 0.925837 nTerms 4 of 7 of 51 FUNCTION cos(x1) + cos(x2), x1 and x2 xcollinear, NewVarPenalty=0 n=100 p=2 [99.99 secs] TEST 40: FUNCTION cos(x1) + cos(x2), x1 and x2 xcollinear, NewVarPenalty=0 n=100 p=2 2.21 // 0 -1.27 * max(0, -0.0415 - x[0]) // 1 -0.867 * max(0, x[1] - 0.606) // 2 -0.559 * max(0, x[0] - -0.447) // 3 earth/inst/slowtests/test.weights.R0000644000176200001440000006416513470054571017176 0ustar liggesusers# test.weights.R source("test.prolog.R") source("check.models.equal.R") library(earth) check.equal <- function(x, y, msg="") { diff <- x - y if (any(abs(diff) > 1e-8)) { cat(msg, "\n1st matrix:\n", sep="") print(x) cat("\n2nd matrix:\n") print(y) cat("\ndiff:\n") print(diff) stop("check.equal failed for ", msg, call.=FALSE) } } check.earth.lm.models.equal <- function(lm.mod, earth.mod) { lm.mod.name <- deparse(substitute(lm.mod)) earth.mod.name <- deparse(substitute(earth.mod)) msg <- sprint("%s vs %s", lm.mod.name, earth.mod.name) check.equal(lm.mod$coefficients, earth.mod$coefficients, msg=sprint("%s coefficients", msg)) check.equal(lm.mod$rss, earth.mod$rss, msg=sprint("%s rss", msg)) check.equal(lm.mod$residuals, earth.mod$residuals, msg=sprint("%s residuals", msg)) check.equal(summary(lm.mod)$r.squared, earth.mod$rsq, msg=sprint("%s rsq", msg)) check.equal(summary(lm.mod)$r.squared, earth.mod$rsq.per.reponse[1], msg=sprint("%s rsq.per.response", msg)) } # artifical data xxx <- 1:9 yyy <- 1:9 yyy[5] <- 9 data <- data.frame(x=xxx, y=yyy) colnames(data) <- c("x", "y") # Check against a linear model with weights, using linpreds. # This also checks the backward pass's handling of weights. lm1 <- lm(y~., data=data) a1 <- earth(y~., data=data, linpreds=TRUE) check.earth.lm.models.equal(lm1, a1) weights <- c(1, 1, 1, 1, 1, 1, 1, 1, 1) lm2 <- lm(y~., data=data, weights=weights) a2 <- earth(y~., data=data, linpreds=TRUE, weights=weights) check.earth.lm.models.equal(lm2, a2) # check that we can get the weights from the data as per lm lm2.a <- lm(y~xxx, data=data, weights=x) # weights from model frame a2.a <- earth(y~xxx, data=data, linpreds=TRUE, weights=x) # weights from model frame a2.b <- earth(y~xxx, data=data, linpreds=TRUE, weights=xxx) # weights from global env check.earth.lm.models.equal(lm2.a, a2.a) check.earth.lm.models.equal(a2.b, a2.a) weights <- c(1, 2, 3, 1, 2, 3, 1, 2, 3) lm3 <- lm(y~., data=data, weights=weights) a3 <- earth(y~., data=data, linpreds=TRUE, weights=weights, trace=-1) check.earth.lm.models.equal(lm3, a3) expect.err(try(earth(y~., data=data, wp=3, Scale.y=TRUE)), "Scale.y=TRUE is not allowed with wp") allthrees <- rep(3.0, length.out=nrow(data)) options(warn=2) expect.err(try(earth(allthrees~x, data=data)), "Cannot scale y (values are all equal to 3)") options(warn=1) allthrees.mod <- earth(allthrees~x, data=data) print(summary(allthrees.mod)) # Scale.y=FALSE allows us to use a response that is constant (silences the error message) allthrees.mod.noscale <- earth(allthrees~x, data=data, Scale.y=FALSE) # intercept only print(summary(allthrees.mod.noscale)) stopifnot(identical(allthrees.mod$coefficients, allthrees.mod.noscale$coefficients)) subset <- c(TRUE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE) lm3.weights <- lm(y~., data=data, weights=weights, subset=subset) a3.weights <- earth(y~., data=data, linpreds=TRUE, weights=weights, trace=-1, subset=subset) check.earth.lm.models.equal(lm3.weights, a3.weights) lm4 <- lm(y~., data=data, weights=.1 * weights) a4 <- earth(y~., data=data, linpreds=TRUE, weights=.1 * weights, minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) cat("a4:\n") print(a4) check.earth.lm.models.equal(lm4, a4) # We want to see the effect only on the forward pass, so disable the # backward pass with penalty=-1. This also prevents "termination of the # forward pass with a negative GRSq" with this artifical data. # # We can't use thresh=0, because then very small weights will still cause a usable # reduction in RSq (remember that weights of zero are changed to very small weights # in the current implementation). So instead we use thresh=1e-8. # This is a problem only with this very artifical data. With real data, we # want to use the standard thresh=.001, even with weights. cat("=== a5.noweights ===\n") par(mfrow = c(2, 2)) par(mar = c(3, 3, 3, 1)) par(mgp = c(1.5, 0.5, 0)) a5.noweights <- earth(y~., data=data, minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=3) plotmo(a5.noweights, col.response=2, do.par=F, main="a5.noweights", grid.col="gray", jitter=0) # TODO why does this model differ from the above model? a5.noweights.force <- earth(y~., data=data, Force.weights=T, minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=3) cat("a5.noweights.force:\n") print(a5.noweights.force) plotmo(a5.noweights.force, col.response=2, do.par=F, main="a5.noweights.force", grid.col="gray", jitter=0) cat("=== a6.azeroweight ===\n") a6.azeroweight <- earth(y~., data=data, weights=c(1, 1, 1, 1, 0, 1, 1, 1, 1), minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=3) cat("a6.azeroweight:\n") print(a6.azeroweight) plotmo(a6.azeroweight, col.response=2, do.par=F, main="a6.azeroweight", grid.col="gray", jitter=0) cat("=== a7.asmallweight ===\n") # different set of weights (pick up notch in data, but with different forward pass RSq's) a7.asmallweight <- earth(y~., data=data, weights=c(1, 1, 1, 1, .5, 1, 1, 1, 1), minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=3) plotmo(a7.asmallweight, col.response=2, do.par=F, main="a7.asmallweight", grid.col="gray", jitter=0) cat("=== a7.xy.asmallweight ===\n") # x,y interface a7.xy.asmallweight <- earth(xxx, yyy, weights=c(1, 1, 1, 1, .5, 1, 1, 1, 1), minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=3) check.earth.lm.models.equal(a7.xy.asmallweight, a7.xy.asmallweight) cat("=== a8 ===\n") par(mfrow = c(3, 2)) # new page par(mar = c(3, 3, 3, 1)) par(mgp = c(1.5, 0.5, 0)) data$y <- c(0, 0, 0, 1, 0, 1, 1, 1, 1) != 0 # glm models first without weights a8 <- earth(y~., data=data, linpreds=TRUE, glm=list(family=binomial), minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) plotmo(a8, col.response=2, do.par=F, main="a8 glm no weights\ntype=\"response\"", grid.col="gray", ylim=c(-.2, 1.2), jitter=0) plotmo(a8, type="earth", col.response=2, do.par=F, main="a8 glm no weights\ntype=\"earth\"", grid.col="gray", ylim=c(-.2, 1.2), jitter=0) glm.a8 <- glm(y~., data=data, family=binomial) stopifnot(coefficients(a8$glm.list[[1]]) == coefficients(glm.a8)) cat("=== a8.weights ===\n") # now glm models with weights glm.weights <- c(.8,1,1,.5,1,1,1,1,1) # The following calls to earth and glm both give "Warning: non-integer #successes in a binomial glm" # See https://stackoverflow.com/questions/12953045/warning-non-integer-successes-in-a-binomial-glm-survey-packages a8.weights <- earth(y~., data=data, linpreds=TRUE, glm=list(family=binomial), weights=glm.weights, minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) cat("a8.weights:\n") print(a8.weights) plotmo(a8.weights, type="response", col.response=2, do.par=F, main="a8.weights glm\ntype=\"response\"", grid.col="gray", ylim=c(-.2, 1.2), jitter=0) plotmo(a8.weights, type="earth", col.response=2, do.par=F, main="a8.weights glm\ntype=\"earth\"", grid.col="gray", ylim=c(-.2, 1.2), jitter=0) glm.a8.weights <- glm(y~., data=data, weights=glm.weights, family=binomial) stopifnot(coefficients(a8.weights$glm.list[[1]]) == coefficients(glm.a8.weights)) stopifnot(a8.weights$glm.list[[1]]$aic == glm.a8.weights$aic) source("check.earth.matches.glm.R") check.earth.matches.glm(a8.weights, glm.a8.weights, newdata=data[2:6,]) options(warn=2) # treat warnings as errors # same as a8.weights but use family=quasibinomial # (test no Warning: non-integer #successes in a binomial glm) a8.weights.quasibinomial <- earth(y~., data=data, linpreds=TRUE, glm=list(family=quasibinomial), weights=glm.weights, minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) options(warn=1) cat("a8.weights.quasibinomial:\n") print(a8.weights.quasibinomial) check.models.equal(a8.weights, a8.weights.quasibinomial, "a8.weights, a8.weights.quasibinomial", newdata=data[2,]) # glm model with weights and subset # To suppress "Warning: non-integer #successes in a binomial glm" we use quasibinomial rather than binomial # See https://stackoverflow.com/questions/12953045/warning-non-integer-successes-in-a-binomial-glm-survey-packages a8.subset <- c(TRUE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE) a8.weights.subset <- earth(y~., data=data, linpreds=TRUE, glm=list(family=quasibinomial), weights=glm.weights, subset=a8.subset, minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=1) glm.a8.weights.subset <- glm(y~., data=data, weights=glm.weights, subset=a8.subset, family=quasibinomial) stopifnot(coefficients(a8.weights.subset$glm.list[[1]]) == coefficients(glm.a8.weights.subset)) stopifnot(a8.weights.subset$glm.list[[1]]$deviance == glm.a8.weights.subset$deviance) # AIC is NA because we use quasibinomial rather than binomial stopifnot(is.na(a8.weights.subset$glm.list[[1]]$aic)) stopifnot(is.na(glm.a8.weights.subset$aic)) cat("summary(a8.weights.subset:\n") print(summary(a8.weights.subset)) cat("summary(glm,a8.weights.subset:\n") print(summary(glm.a8.weights.subset)) cat("=== a8.weights including a zero weight ===\n") # now glm models with weights including a zero weight glm.weights <- c(.8,1,1,0,1,1,1,1,1) a8.azeroweight <- earth(y~., data=data, linpreds=TRUE, glm=list(family=binomial), weights=glm.weights, minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) plotmo(a8.azeroweight, type="response", col.response=2, do.par=F, main="a8.azeroweight glm\ntype=\"response\"", grid.col="gray", ylim=c(-.2, 1.2), jitter=0) plotmo(a8.azeroweight, type="earth", col.response=2, do.par=F, main="a8.azeroweight glm\ntype=\"earth\"", grid.col="gray", ylim=c(-.2, 1.2), jitter=0) glm.a8.azeroweight <- glm(y~., data=data, weights=glm.weights, family=binomial) # # TODO this fails because a weight is 0 in glm.weights # print(coefficients(a8.azeroweight$glm.list[[1]])) # print(coefficients(glm.a8.azeroweight)) # stopifnot(coefficients(a8.azeroweight$glm.list[[1]]) == coefficients(glm.a8.azeroweight)) cat("=== plot.earth with weights ===\n") # we also test id.n=TRUE and id.n=-1 here old.par <- par(mfrow=c(2,2), mar=c(4, 3.2, 3, 3), mgp=c(1.6, 0.6, 0), oma=c(0,0,3,0), par(cex=1)) plot(a3, id.n=TRUE, SHOWCALL=TRUE, caption="compare a3 to to lm3", do.par=FALSE, which=c(3,4), caption.cex=1.5) plot(lm3, id.n=9, which=c(1,2), sub.caption="") par(old.par) cat("=== plot.earth with earth-glm model and weights ===\n") plot(a8, id.n=TRUE, caption="a8") plot(a8.weights, id.n=TRUE, caption="a8.weights") plotres(glm.a8.weights, id.n=TRUE, caption="plotres: glm.a8.weights") plot(a8.weights, id.n=TRUE, delever=TRUE, caption="a8.weights delever=TRUE") set.seed(2019) plotmo(a8.weights, pt.col=2, caption="plotmo: a8.weights") set.seed(2019) plotmo(glm.a8.weights, pt.col=2, caption="plotmo: glm.a8.weights") cat("=== plot.earth with earth-glm model and weights including a zero weight ===\n") set.seed(2019) plotmo(a8.azeroweight, pt.col=2, caption="plotmo: a8.azeroweight") set.seed(2019) plotmo(glm.a8.azeroweight, pt.col=2, caption="plotmo: glm.a8.azeroweight") cat("=== plot.earth with earth-glm model, weights ===\n") # multivariate models noise <- .01 * c(1,2,3,2,1,3,5,2,0) data <- data.frame(x1=c(1,2,3,4,5,6,7,8,9), x2=c(1,2,3,3,3,6,7,8,9), y=(1:9)+noise) data[5,] <- c(5, 5, 6) colnames(data) <- c("x1", "x2", "y") weights <- c(3, 2, 1, 1, 2, 3, 1, 2, 3) lm20 <- lm(y~., data=data, weights=weights) a20 <- earth(y~., data=data, linpreds=TRUE, weights=weights, minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) check.earth.lm.models.equal(lm20, a20) a21.noweights <- earth(y~., data=data, # no weights for comparison minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) plotmo(a21.noweights, col.resp=2, trace=-1, caption="a21.noweights", jitter=0) weights <- c(1, 1, 1, 1, .5, 1, 1, 1, 1) a10 <- earth(y~., data=data, weights=weights, minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) plotmo(a10, col.resp=2, caption="a10", jitter=0) test.zigzag <- function() { par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0), oma=c(0,0,0,0)) TRACE <- 0 THRESH <- 0 PMETHOD <- "none" # # models are identical # x <- 1:21 # y <- c(1:3, 2) # y <- rep(y, length.out=length(x)) # data <- data.frame(x=x, y=y) # a <- earth(y~x, data=data, minspan=1, endspan=1, trace=TRACE, pmethod=PMETHOD, thresh=THRESH, Scale.y=FALSE, nk=201) # plot(x, y, type="p", pch=20) # lines(x, predict(a), col=3, pch=20) # aw <- earth(y~x, data=data, minspan=1, endspan=1, trace=TRACE, pmethod=PMETHOD, thresh=THRESH, Scale.y=FALSE, nk=201, Force.weights=T) # plot(x, y, type="p", pch=20) # lines(x, predict(aw), col=3, pch=20) # models are not identical x <- 1:81 y <- c(1:3, 2) y <- rep(y, length.out=length(x)) data <- data.frame(x=x, y=y) a <- earth(y~x, data=data, minspan=1, endspan=1, trace=TRACE, pmethod=PMETHOD, thresh=THRESH, Scale.y=FALSE, nk=201) plot(x, y, type="p", pch=20, main="without weights") lines(x, predict(a), col=3, pch=20) aw <- earth(y~x, data=data, minspan=1, endspan=1, trace=TRACE, pmethod=PMETHOD, thresh=THRESH, Scale.y=FALSE, nk=201, Force.weights=T) plot(x, y, type="p", pch=20, main="with weights") lines(x, predict(aw), col=3, pch=20) } # zigzag test.zigzag() # commented out because too slow and next test essentially covers this # # trees # a.trees <- earth(Volume~., data=trees, trace=2) # aw.trees <- earth(Volume~., data=trees, trace=2, Force.weights=TRUE) # plotmo(a.trees, do.par=2, caption="trees: top and bottom should be similar") # plotmo(aw.trees, do.par=FALSE) # bivariate.with.interaction set.seed(2015) n <- 18 x <- matrix(runif(2 * n, -1, 1), ncol=2) x <- x[order(x[,1]), , drop=FALSE] # sort first column for convenience colnames(x) <- paste("x", 1:ncol(x), sep="") bivariate.with.interaction <- function(x) { x[,1] + x[,2] + x[,1] * x[,2] + .05 * rnorm(nrow(x)) } set.seed(1) y <- bivariate.with.interaction(x) a.biv <- earth(x, y, degree=2, trace=2) aw.biv <- earth(x, y, degree=2, trace=2, Force.weights=TRUE) cat("aw.biv:\n") print(aw.biv) par(mfrow=c(2,3), mar=c(4, 3.2, 3, 3), mgp=c(1.6, 0.6, 0), par(cex = 0.8), oma=c(0,0,3,0)) plotmo(a.biv, do.par=FALSE, caption="bivariate: top and bottom should be similar") plotmo(aw.biv, do.par=FALSE) # Comparison to glm and rpart # # The response y is split into two curves, we will weight the second lower # curve and see how that affects the earth curve. # # With weight=1 the earth curve should be half way between the top and # bottom curve. With say weight=10, the bottom curve is given much more # weight than the top curve, so the model should be closer to the bottom # curve. # # We also compare the earth curve to to other models that support weights. # Each vertical line of plots should be approximately the same. library(gam) library(rpart) n <- 100 x1 <- c((-n:n) / n, (-n:n) / n) x2 <- c((n:-n) / n, (-n:n) / n) y <- x1 * x1 y[(2 * n + 2) : (3 * n + 2)] <- -.25 * y[(2 * n + 2): (3 * n + 2)] y[(3 * n + 3) : (4 * n + 2)] <- .25 * y[(3 * n + 3) : (4 * n + 2)] data <- data.frame(x1=x1, x2=x2, y=y) par(mfcol = c(3, 5), mar = c(1.5, 4, 3, 2), mgp = c(1.5, 0.5, 0), oma=c(0,0,4,0)) cat("comparison to glm and rpart: unweighted\n") a200 <- earth(y~x1, data=data) plotmo(a200, do.par=FALSE, pt.col=2, main="unweighted\nearth", cex=.7, pt.cex=.2, grid.col=TRUE) mtext("comparison to glm and rpart", outer=TRUE, line=2) gam200 <- gam(y~s(x1, 5), data=data) plotmo(gam200, do.par=FALSE, pt.col=2, main="gam", cex=.7, pt.cex=.2, grid.col=TRUE) rpart <- rpart(y~x1, data=data, method="anova", control=rpart.control(cp=.001)) plotmo(rpart, do.par=FALSE, pt.col=2, main="rpart", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) cat("comparison to glm and rpart: weight=.1\n") weight <- .1 w <- c(rep_len(1, 2 * n + 1), rep_len(weight, 2 * n + 1)) aw201 <- earth(y~x1, data=data, weights=w) plotmo(aw201, do.par=FALSE, pt.col=2, main=sprint("weight %g\nearth", weight), cex=.7, pt.cex=.2, grid.col=TRUE) gamw201 <- gam(y~s(x1, 5), data=data, weights=w) plotmo(gamw201, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE) rpart <- rpart(y~x1, data=data, method="anova", control=rpart.control(cp=.001), weights=w) plotmo(rpart, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) cat("comparison to glm and rpart: weight=1\n") weight <- 1 w <- c(rep_len(1, 2 * n + 1), rep_len(weight, 2 * n + 1)) aw202 <- earth(y~x1, data=data, weights=w) plotmo(aw202, do.par=FALSE, pt.col=2, main=sprint("weight %g\nearth", weight), cex=.7, pt.cex=.2, grid.col=TRUE) gamw202 <- gam(y~s(x1, 5), data=data, weights=w) plotmo(gamw202, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE) rpart <- rpart(y~x1, data=data, method="anova", control=rpart.control(cp=.001), weights=w) plotmo(rpart, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) cat("comparison to glm and rpart: weight=2\n") weight <- 2 w <- c(rep_len(1, 2 * n + 1), rep_len(weight, 2 * n + 1)) aw203 <- earth(y~x1, data=data, weights=w) plotmo(aw203, do.par=FALSE, pt.col=2, main=sprint("weight %g\nearth", weight), cex=.7, pt.cex=.2, grid.col=TRUE) gamw203 <- gam(y~s(x1, 5), data=data, weights=w) plotmo(gamw203, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE) rpart <- rpart(y~x1, data=data, method="anova", control=rpart.control(cp=.001), weights=w) plotmo(rpart, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) cat("comparison to glm and rpart: weight=10\n") weight <- 10 w <- c(rep_len(1, 2 * n + 1), rep_len(weight, 2 * n + 1)) aw204 <- earth(y~x1, data=data, weights=w) plotmo(aw204, do.par=FALSE, pt.col=2, main=sprint("weight %g\nearth", weight), cex=.7, pt.cex=.2, grid.col=TRUE) gamw204 <- gam(y~s(x1, 5), data=data, weights=w) plotmo(gamw204, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE) rpart <- rpart(y~x1, data=data, method="anova", control=rpart.control(cp=.001), weights=w) plotmo(rpart, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) # # TODO the following are meant to do degree2 weight tests, # # but they are unconvincing either way, so commented out # # par(mfcol = c(3, 3), mar = c(1.5, 4, 3, 2), mgp = c(1.5, 0.5, 0), oma=c(0,0,6,0)) # # y <- x2 * x2 * y # data <- data.frame(x1=x1, x2=x2, y=y) # # cat("degree2 comparison to glm and rpart: unweighted\n") # a200 <- earth(y~x1+x2, data=data, degree=2) # plotmo(a200, do.par=FALSE, pt.col=2, cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1, persp.ticktype="d") # mtext("comparison to glm and rpart, degree2, unweighted\nleft side earth, right side gam200", outer=TRUE, line=2) # gam200 <- gam(y~s(x1, 7)+s(x2, 7)+s(x1, 7)*s(x2, 7), data=data) # plotmo(gam200, do.par=FALSE, pt.col=2, cex=.7, pt.cex=.2, grid.col=TRUE, all2=T, trace=-1, persp.ticktype="d") # rpart <- rpart(y~x1+x2, data=data, method="anova", control=rpart.control(cp=.001, minbucket=3)) # plotmo(rpart, do.par=FALSE, pt.col=2, main="rpart", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) # # plotres(rpart) # # cat("degree2 comparison to glm and rpart: weight=2\n") # weight <- 2 # w <- c(rep_len(1, 2 * n + 1), rep_len(weight, 2 * n + 1)) # aw201 <- earth(y~x1+x2, data=data, weights=w, degree=2) # plotmo(aw201, do.par=FALSE, pt.col=2, cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1, persp.ticktype="d") # mtext("comparison to glm and rpart, degree2, weight 2\nleft side earth, right side gam200", outer=TRUE, line=2) # gamw201 <- gam(y~s(x1, 7)+s(x2, 7)+s(x1, 7)*s(x2, 7), data=data, weights=w) # plotmo(gamw201, do.par=FALSE, pt.col=2, cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1, all2=TRUE, persp.ticktype="d") # rpart <- rpart(y~x1, data=data, method="anova", control=rpart.control(cp=.001), weights=w) # plotmo(rpart, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) # # cat("degree2 comparison to glm and rpart: weight=10\n") # weight <- 10 # w <- c(rep_len(1, 2 * n + 1), rep_len(weight, 2 * n + 1)) # aw201 <- earth(y~x1+x2, data=data, weights=w, degree=2) # plotmo(aw201, do.par=FALSE, pt.col=2, cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1, persp.ticktype="d") # mtext("comparison to glm and rpart, degree2, weight 10\nleft side earth, right side gam200", outer=TRUE, line=2) # gamw201 <- gam(y~s(x1, 7)+s(x2, 7)+s(x1, 7)*s(x2, 7), data=data, weights=w) # plotmo(gamw201, do.par=FALSE, pt.col=2, main="gam200", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1, all2=TRUE, persp.ticktype="d") # rpart <- rpart(y~x1, data=data, method="anova", control=rpart.control(cp=.001), weights=w) # plotmo(rpart, do.par=FALSE, pt.col=2, main="", cex=.7, pt.cex=.2, grid.col=TRUE, trace=-1) # test bug fix for bug reported by damien georges (required adding check for "(weights)" to get.namesx) set.seed(2016) n <- 100 x1 <- factor(sample(c("A", "B", "C"), n, replace = TRUE)) # factorial variable x2 <- runif(n) # continuous variable x3 <- rnorm(n) # continuous variable y <- factor(ifelse((as.numeric(x1) + x2 + x3) / mean(as.numeric(x1) + x2 + x3) > .8, "yes", "no")) dat <- data.frame(y=y, x1=x1, x2=x2, x3=x3) a <- earth(formula=y ~ x1 + x2 + x3, data=dat, glm=list(family=binomial)) print(summary(a)) yhat <- predict(a, dat[, c('x1', 'x2', 'x3')], type='response') w <- rep(1, n) # vector of equal weights aw <- earth(formula=y ~ x1 + x2 + x3, data=dat, glm=list(family=binomial), weight=w) print(summary(aw)) yhatw <- predict(aw, dat[, c('x1', 'x2', 'x3')], type='response') stopifnot(identical(yhat, yhat)) check.models.equal(a, aw) w <- rep(1, n) # vector of equal weights aw.force <- earth(formula=y ~ x1 + x2 + x3, data=dat, glm=list(family=binomial), weight=w, Force.weights=TRUE) print(summary(aw.force)) yhatw <- predict(aw.force, dat[, c('x1', 'x2', 'x3')], type='response') stopifnot(identical(yhat, yhat)) check.earth.lm.models.equal(a, aw.force) cat("---check Scale.y-------------------------------------------\n") xxx <- 1:9 yyy <- 1:9 yyy[3] <- 9 datxy <- data.frame(x=xxx, y=yyy) colnames(datxy) <- c("xxx", "yyy") options(warn=2) mod1 <- earth(yyy~., datxy, Scale.y=FALSE) mod2 <- earth(yyy~., datxy, Scale.y=TRUE) check.models.equal(mod1, mod2, "mod1, mod2", newdata=dataxy[3,]) mod3 <- earth(yyy~., datxy, weights=weights, Scale.y=FALSE) mod4 <- earth(yyy~., datxy, weights=weights, Scale.y=TRUE) check.models.equal(mod3, mod4, "mod3, mod4", newdata=dataxy[3,]) data(ozone1) mod5 <- earth(O3~., ozone1, Scale.y=FALSE) mod6 <- earth(O3~., ozone1, Scale.y=TRUE) check.models.equal(mod5, mod6, "mod5, mod6", newdata=ozone1[3,]) mod7 <- earth(O3~., ozone1, weights=sqrt(ozone1$O3), Scale.y=FALSE) mod8 <- earth(O3~., ozone1, weights=sqrt(ozone1$O3), Scale.y=TRUE) check.models.equal(mod7, mod8, "mod7, mod8", newdata=ozone1[3,]) data(etitanic) # nk=5 for speed mod9 <- earth(survived~., etitanic, nk=5, weights=sqrt(etitanic$age), Scale.y=FALSE) mod10 <- earth(survived~., etitanic, nk=5, weights=sqrt(etitanic$age), Scale.y=TRUE) check.models.equal(mod9, mod10, "mod9, mod10", newdata=etitanic[2,]) # use nk=7 to minimize differences between code for weighted and unweighted models in earth.c mod.O3vh <- earth(O3+vh~wind+doy, ozone1, nk=7, Scale.y=FALSE, trace=1) w1 <- rep(1, length.out=nrow(ozone1)) mod.O3vh.w1 <- earth(O3+vh~wind+doy, ozone1, nk=7, weights=w1, Force.weights=TRUE, Scale.y=FALSE, trace=1) check.models.equal(mod.O3vh, mod.O3vh.w1, "mod.O3vh, mod.O3vh.w1", newdata=ozone1[2,]) w3 <- rep(3, length.out=nrow(ozone1)) mod.O3vh.w3 <- earth(O3+vh~wind+doy, ozone1, nk=7, weights=w3, Force.weights=TRUE, Scale.y=FALSE) check.equal(mod.O3vh$grsq, mod.O3vh.w3$grsq) check.equal(mod.O3vh$rsq, mod.O3vh.w3$rsq) check.equal(mod.O3vh$coefficients, mod.O3vh.w3$coefficients) # check.models.equal(mod.O3vh, mod.O3vh.w3, "(mod.O3vh, mod.O3vh.w3") # not exactly equal but close mod.O3vh.Scaley <- earth(O3+vh~wind+doy, ozone1, nk=7, Scale.y=TRUE, trace=0) w1 <- rep(1, length.out=nrow(ozone1)) mod.O3vh.w1.Scaley <- earth(O3+vh~wind+doy, ozone1, nk=7, weights=w1, Force.weights=TRUE, Scale.y=TRUE) check.models.equal(mod.O3vh.Scaley, mod.O3vh.w1.Scaley, "mod.O3vh.Scaley, mod.O3vh.w1.Scaley", newdata=ozone1[2,]) # multiple response models, Scale.y will be visible (i.e. models with different Scale.y will be different) mod.O3vh <- earth(O3+vh~wind+doy, ozone1, degree=2, Scale.y=FALSE) print(mod.O3vh) mod.O3vh.Scaley <- earth(O3+vh~wind+doy, ozone1, degree=2, Scale.y=TRUE) print(mod.O3vh.Scaley) rsq.diff <- abs(mod.O3vh$rsq.per.response[1] - mod.O3vh$rsq.per.response[2]) rsq.diff.Scaley <- abs(mod.O3vh.Scaley$rsq.per.response[1] - mod.O3vh.Scaley$rsq.per.response[2]) # Scale.y=TRUE for multiple response models should make the rsq for the two responses closer # i.e. with Scale.y=TRUE, vh should not overwhelm O3 because vh has much bigger values stopifnot(rsq.diff.Scaley < rsq.diff) wO3 <- sqrt(ozone1$O3) mod.O3vh.wO3 <- earth(O3+vh~wind+doy, ozone1, degree=2, weights=wO3, Scale.y=FALSE) print(mod.O3vh.wO3) mod.O3vh.wO3.Scaley <- earth(O3+vh~wind+doy, ozone1, degree=2, weights=wO3, Scale.y=TRUE) print(mod.O3vh.wO3.Scaley) rsq.diff.wO3 <- abs(mod.O3vh.wO3$rsq.per.response[1] - mod.O3vh.wO3$rsq.per.response[2]) rsq.diff.wO3.Scaley <- abs(mod.O3vh.wO3.Scaley$rsq.per.response[1] - mod.O3vh.wO3.Scaley$rsq.per.response[2]) # Scale.y=TRUE for multiple response models should make the rsq for the two responses closer stopifnot(rsq.diff.wO3.Scaley < rsq.diff.wO3) # nk=5 for speed mod11 <- earth(pclass~., etitanic, nk=5, weights=sqrt(etitanic$age), Scale.y=FALSE) print(mod11) mod12 <- earth(pclass~., etitanic, nk=5, weights=sqrt(etitanic$age), Scale.y=TRUE) print(mod12) source("test.epilog.R") earth/inst/slowtests/test.offset.R0000644000176200001440000005455313446223366017015 0ustar liggesusers# test.offset.R source("test.prolog.R") library(earth) almost.equal <- function(x, y, max=1e-8) { stopifnot(max >= 0 && max <= .01) length(x) == length(y) && max(abs(x - y)) < max } # check that earth model matches lm model in all essential details check.earth.matches.lm <- function(earth, lm, newdata=data[c(3,1,9),], check.coef.names=TRUE, check.casenames=TRUE, max=1e-8, max.residuals=1e-8) { check.names <- function(earth.names, lm.names) { if(check.casenames && # lm always adds rownames even if "1", "2", "3": this seems # wasteful and not particulary helpful, so earth doesn't do # this, hence the first !isTRUE(all.equal) below !isTRUE(all.equal(lm.names, paste(1:length(lm.names)))) && !isTRUE(all.equal(earth.names, lm.names))) { print(earth.names) print(lm.names) stop(deparse(substitute(earth.names)), " != ", deparse(substitute(lm.names))) } } cat0("check ", deparse(substitute(earth)), " vs ", deparse(substitute(lm)), "\n") # sort is needed because earth may reorder predictors based in importance stopifnot(almost.equal(sort(coef(earth)), sort(coef(lm)), max=max)) if(check.coef.names) stopifnot(identical(sort(names(coef(earth))), sort(names(coef(lm))))) stopifnot(length(earth$coefficients) == length(lm$coefficients)) stopifnot(almost.equal(sort(earth$coefficients), sort(lm$coefficients), max=max)) stopifnot(length(earth$residuals) == length(lm$residuals)) stopifnot(almost.equal(earth$residuals, lm$residuals, max=max.residuals)) stopifnot(length(earth$fitted.values) == length(lm$fitted.values)) stopifnot(almost.equal(earth$fitted.values, lm$fitted.values, max=max)) stopifnot(almost.equal(fitted(earth), fitted(lm), max=max)) if(!is.null(names(fitted(earth))) && !is.null(names(fitted(lm)))) check.names(names(fitted(earth)), names(fitted(lm))) stopifnot(almost.equal(residuals(earth), residuals(lm), max=max.residuals)) if(!is.null(names(residuals(earth))) && !is.null(names(residuals(lm)))) check.names(names(residuals(earth)), names(residuals(lm))) predict.earth <- predict(earth) predict.lm <- predict(lm) stopifnot(almost.equal(predict.earth, predict.lm, max=max)) if(!is.null(names(predict.earth)) && !is.null(names(predict.lm))) check.names(names(predict.earth), names(predict.lm)) predict.earth <- predict(earth, newdata=newdata) predict.lm <- predict(lm, newdata=newdata) stopifnot(almost.equal(predict.earth, predict.lm, max=max)) if(!is.null(names(predict.earth)) && !is.null(names(predict.lm))) check.names(names(predict.earth), names(predict.lm)) # we calculate earth rsq manually to match the rsq technique of lm # this is necessary to get the same rsq when an offset is used if(is.null(earth$offset)) { earth.rsq <- earth$rsq rss <- if (is.null(earth$weights)) sum(earth$residuals^2) else sum(earth$weights * earth$residuals^2) } else { if (is.null(earth$weights)) { mss <- sum((earth$fitted.values - mean(earth$fitted.values))^2) rss <- sum(earth$residuals^2) } else { stopifnot(almost.equal(lm$weights, earth$weights, max=max)) m <- sum(earth$weights * earth$fitted.values /sum(earth$weights)) mss <- sum(earth$weights * (earth$fitted.values - m)^2) rss <- sum(earth$weights * earth$residuals^2) } earth.rsq <- mss / (mss + rss) } stopifnot(almost.equal(earth.rsq, summary(lm)$r.squared, max=max)) # check internal consistency of earth model stopifnot(earth$gcv == earth$gcv[1]) stopifnot(almost.equal(earth$rsq.per.response[1], earth$rsq, max=1e-15)) stopifnot(almost.equal(earth$grsq.per.response[1], earth$grsq, max=1e-15)) if(is.null(earth$weights)) stopifnot(almost.equal(earth$rss.per.response, earth$rss, max=1e-10)) } # check that earth-glm model matches glm model in all essential details check.earth.matches.glm <- function(earth, glm, newdata=data[c(3,1,9),], check.coef.names=TRUE, check.casenames=FALSE, max=1e-8, max.residuals=1e-8) { check.names <- function(earth.names, glm.names) { if(check.casenames && # glm always adds rownames even if "1", "2", "3": this seems # wasteful and not particulary helpful, so earth doesn't do # this, hence the first !isTRUE(all.equal) below !isTRUE(all.equal(glm.names, paste(1:length(glm.names)))) && !isTRUE(all.equal(earth.names, glm.names))) { print(earth.names) print(glm.names) stop(deparse(substitute(earth.names)), " != ", deparse(substitute(glm.names))) } } cat0("check ", deparse(substitute(earth)), " vs ", deparse(substitute(glm)), "\n") # sort is needed because earth may reorder predictors based in importance earth.glm <- earth$glm.list[[1]] stopifnot(!is.null(earth.glm)) stopifnot(almost.equal(sort(coef(earth.glm)), sort(coef(glm)), max=max)) if(check.coef.names) stopifnot(identical(sort(names(coef(earth.glm))), sort(names(coef(glm))))) stopifnot(length(earth.glm$coefficients) == length(glm$coefficients)) stopifnot(almost.equal(sort(earth.glm$coefficients), sort(glm$coefficients), max=max)) stopifnot(length(earth.glm$residuals) == length(glm$residuals)) stopifnot(almost.equal(earth.glm$residuals, glm$residuals, max=max)) stopifnot(length(earth.glm$fitted.values) == length(glm$fitted.values)) stopifnot(almost.equal(earth.glm$fitted.values, glm$fitted.values, max=max)) stopifnot(almost.equal(fitted(earth.glm), fitted(glm), max=max)) if(!is.null(names(fitted(earth.glm))) && !is.null(names(fitted(glm)))) check.names(names(fitted(earth.glm)), names(fitted(glm))) stopifnot(almost.equal(residuals(earth.glm), residuals(glm), max=max.residuals)) if(!is.null(names(residuals(earth.glm))) && !is.null(names(residuals(glm)))) check.names(names(residuals(earth.glm)), names(residuals(glm))) stopifnot(almost.equal(residuals(earth, type="response"), residuals(glm, type="response"), max=max.residuals)) stopifnot(almost.equal(residuals(earth, type="glm.response"), residuals(glm, type="response"), max=max.residuals)) stopifnot(almost.equal(residuals(earth, type="deviance"), residuals(glm, type="deviance"), max=max.residuals)) stopifnot(almost.equal(residuals(earth, type="glm.pearson"), residuals(glm, type="pearson"), max=max.residuals)) stopifnot(almost.equal(residuals(earth, type="glm.working"), residuals(glm, type="working"), max=max.residuals)) # commented out because partial residuals don't match (because factors are expanded differently?) # stopifnot(almost.equal(residuals(earth, type="glm.partial"), residuals(glm, type="partial"), max=max.residuals)) # predict without newdata predict.glm <- predict(glm) predict.earth <- predict(earth) stopifnot(almost.equal(predict.earth, predict.glm, max=max)) if(!is.null(names(predict.earth)) && !is.null(names(predict.glm))) check.names(names(predict.earth), names(predict.glm)) # predict type=default predict.glm <- predict(glm, newdata=newdata) predict.earth <- predict(earth, newdata=newdata) stopifnot(almost.equal(predict.earth, predict.glm, max=max)) if(!is.null(names(predict.earth)) && !is.null(names(predict.glm))) check.names(names(predict.earth), names(predict.glm)) # predict type="response" predict.glm.response <- predict(glm, newdata=newdata, type="response") predict.earth.response <- predict(earth, newdata=newdata, type="response") if(!is.null(names(predict.earth)) && !is.null(names(predict.glm))) check.names(names(predict.earth), names(predict.glm)) stopifnot(almost.equal(predict.earth.response, predict.glm.response, max=max)) if(!is.null(names(predict.earth.response)) && !is.null(names(predict.glm.response))) check.names(names(predict.earth.response), names(predict.glm.response)) # predict type="link" predict.earth.link <- predict(earth, newdata=newdata, type="link") predict.glm.link <- predict(glm, newdata=newdata, type="link") stopifnot(almost.equal(predict.earth.link, predict.glm.link, max=max)) if(!is.null(names(predict.earth)) && !is.null(names(predict.lm))) check.names(names(predict.earth), names(predict.glm)) # check internal consistency of earth model stopifnot(earth$gcv == earth$gcv[1]) stopifnot(almost.equal(earth$rsq.per.response[1], earth$rsq, max=1e-15)) stopifnot(almost.equal(earth$grsq.per.response[1], earth$grsq, max=1e-15)) if(is.null(earth$weights)) stopifnot(almost.equal(earth$rss.per.response, earth$rss, max=1e-10)) } devratio <- function(mod) { if(is.null(mod$deviance)) mod <- mod$glm.list[[1]] stopifnot(!is.null(mod)) stopifnot(!is.null(mod$deviance)) stopifnot(!is.null(mod$null.deviance)) sprint("devratio %.2f", 1 - mod$deviance / mod$null.deviance) } print.devratio <- function(s, mod) { printf("%-22s %s\n", s, devratio(mod)) } #------------------------------------------------------------------------------ # linear model n <- 100 set.seed(2019) x1 <- ((1:n) + runif(n, min=0, max=10)) / n set.seed(2019) x2 <- ((1:n) + runif(n, min=0, max=10)) / n y <- 3 * x1 + rnorm(n) myoffset <- (1:n) / n data <- data.frame(y=y, x1=x1, myoffset=myoffset) lm.weights <- lm(y ~ x1, data=data, weights=sin(myoffset)) earth.weights <- earth(y ~ x1, data=data, weights=sin(myoffset), linpreds=TRUE, thresh=0, penalty=-1) check.earth.matches.lm(earth.weights, lm.weights) myoffset <- (1:n) / n data <- data.frame(y=y, x1=x1, myoffset=myoffset) lm4 <- lm(y ~ x1 + offset(myoffset), data=data) earth4 <- earth(y ~ x1 + offset(myoffset), data=data, linpreds=TRUE, thresh=0, penalty=-1) check.earth.matches.lm(earth4, lm4) cat("==print(earth4)==\n") print(earth4) cat("==summary(earth4)==\n") print(summary(earth4)) cat("==summary(earth4, details=TRUE)==\n") print(summary(earth4, details=TRUE)) par(mfrow=c(4, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) set.seed(2019) plotmo(lm4, trace=0, pt.col=2, do.par=FALSE) mtext( "row1: lm4\nrow2: earth4\nrow3: lm4 grid.levels=list(myoffset=-3)\nrow4: earth4 grid.levels=list(myoffset=-3)", outer=TRUE, cex=.8) set.seed(2019) plotmo(earth4, trace=0, pt.col=2, do.par=FALSE) empty.plot() set.seed(2019) plotmo(lm4, trace=0, pt.col=2, do.par=FALSE, grid.levels=list(myoffset=-3)) set.seed(2019) plotmo(earth4, trace=0, pt.col=2, do.par=FALSE, grid.levels=list(myoffset=-3)) par(old.par) plotres(lm4) plotres(earth4) # linear model with weights and offset lm4.weights <- lm(y ~ x1 + offset(exp(myoffset)), data=data, weights=sin(myoffset)) earth4.weights <- earth(y ~ x1 + offset(exp(myoffset)), data=data, weights=sin(myoffset), linpreds=TRUE, thresh=0, penalty=-1) check.earth.matches.lm(earth4.weights, lm4.weights) print(earth4.weights) print(summary(earth4.weights)) #------------------------------------------------------------------------------ # error handling data <- data.frame(y=y, x1=x1) expect.err(try(earth(y ~ x1 + offset(myoffset), data=data)), "the offset variable 'myoffset' in 'offset(myoffset)' must be in the data") expect.err(try(earth(y ~ x1 + offset(myoffset))), "if an offset is specified in the formula, the 'data' argument must be used") data <- data.frame(y=y, x1=x1, offset0=rep(0, length.out=n), offset1=rep(1, length.out=n)) expect.err(try(earth(y ~ x1 + offset(offset0) + offset(offset1), data=data)), "only one offset is allowed") #------------------------------------------------------------------------------ # poisson model with and without linear predictors library(MASS) data(Insurance) Ins <- Insurance Ins$Claims[Ins$Claims > 100] <- 100 Ins$day <- (1:nrow(Insurance)) / nrow(Insurance) # non linear term (like a seasonal effect) Ins$Claims <- round(Ins$Claims * (1 + sin(2 * pi * Ins$day))) pois <- glm(Claims ~ Group + Age + day + offset(log(Holders)), data = Ins, family = poisson) earth.pois.linpreds <- earth(Claims ~ offset(log(Holders)) + Group + Age + day, data = Ins, glm=list(family = poisson), linpreds=TRUE, thresh=0, penalty=-1) stopifnot(isTRUE(all.equal(coef(earth.pois.linpreds), coefficients(earth.pois.linpreds)))) stopifnot(isTRUE(all.equal(coef(earth.pois.linpreds, type="glm"), coefficients(earth.pois.linpreds, type="glm")))) stopifnot(isTRUE(all.equal(coef(earth.pois.linpreds, type="earth"), coefficients(earth.pois.linpreds, type="earth")))) stopifnot(identical(names(coef(earth.pois.linpreds)), rownames(earth.pois.linpreds$coefficients))) stopifnot(identical(names(coef(earth.pois.linpreds)), rownames(earth.pois.linpreds$glm.coefficients))) stopifnot(identical(names(coef(earth.pois.linpreds, type="glm")), rownames(earth.pois.linpreds$glm.coefficients))) stopifnot(max(abs(coef(earth.pois.linpreds) - earth.pois.linpreds$glm.coefficients)) == 0) stopifnot(max(abs(coef(earth.pois.linpreds, type="response") - earth.pois.linpreds$glm.coefficients)) == 0) stopifnot(max(abs(coef(earth.pois.linpreds, type="earth") - earth.pois.linpreds$coefficients)) == 0) stopifnot(max(abs(coef(earth.pois.linpreds) - earth.pois.linpreds$glm.list[[1]]$coefficients)) == 0) stopifnot(max(abs(coef(earth.pois.linpreds, type="glm") - earth.pois.linpreds$coefficients)) > 99) check.earth.matches.glm(earth.pois.linpreds, pois, newdata=Ins[4:6,]) earth.pois <- earth(Claims ~ Group + Age + day + offset(log(Holders)), data = Ins, glm=list(family = poisson)) cat("==print(earth.pois)==\n") print(earth.pois) cat("==summary(earth.pois)==\n") print(summary(earth.pois)) cat("==summary(earth.pois, details=TRUE)==\n") print(summary(earth.pois, details=TRUE)) earth.pois.no.penalty <- earth(Claims ~ Group + Age + day + offset(log(Holders)), data = Ins, glm=list(family = poisson), thresh=0, penalty=-1) print.devratio("pois", pois) print.devratio("earth.pois.linpreds", earth.pois.linpreds$glm.list[[1]]) print.devratio("earth.pois", earth.pois$glm.list[[1]]) print.devratio("earth.pois.no.penalty", earth.pois.no.penalty$glm.list[[1]]) par(mfrow=c(3, 4), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) set.seed(2019) plotmo(pois, trace=0, pt.col=2, do.par=FALSE, ylim=c(0,50)) mtext(sprint( "row1: pois (%s)\nrow2: earth.pois.linpreds (%s)\nrow3: earth.pois.linpreds(all1=TRUE)", devratio(pois), devratio(earth.pois.linpreds)), outer=TRUE, cex=.8) set.seed(2019) plotmo(earth.pois.linpreds, trace=0, pt.col=2, do.par=FALSE, ylim=c(0,50)) empty.plot() set.seed(2019) plotmo(earth.pois.linpreds, all1=T, trace=-1, pt.col=2, do.par=FALSE, ylim=c(0,50)) par(old.par) plotres(pois, type="response", caption='pois, type="response"') plotres(earth.pois.linpreds, type="response", caption='earth.pois.linpreds, type="response"') par(mfrow=c(3, 4), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) set.seed(2019) plotmo(pois, trace=0, pt.col=2, do.par=FALSE, ylim=c(0,50), grid.levels=list(Holders=20)) mtext( "----- grid.levels=list(Holders=20)) -----\nrow1: pois\nrow2: earth.pois.linpreds\nrow3: earth.pois.linpreds(all1=TRUE)", outer=TRUE, cex=.8) set.seed(2019) plotmo(earth.pois.linpreds, trace=0, pt.col=2, do.par=FALSE, ylim=c(0,50), grid.levels=list(Holders=20)) empty.plot() set.seed(2019) plotmo(earth.pois.linpreds, all1=T, trace=-1, pt.col=2, do.par=FALSE, ylim=c(0,50), grid.levels=list(Holders=20)) par(old.par) plotmo(earth.pois.linpreds, pmethod="partdep", do.par=2, caption=sprint("earth.pois.linpreds, pmethod=\"partdep\", %s", devratio(earth.pois.linpreds))) plotmo(earth.pois.linpreds, pmethod="partdep", do.par=0, grid.levels=list(Age=">35"), degree1="day", main="day with Age=\">35\"") plotmo(earth.pois, pmethod="partdep", caption=sprint("earth.pois, pmethod=\"partdep\", %s", devratio(earth.pois))) plotmo(earth.pois.no.penalty, pmethod="partdep", caption=sprint("earth.pois.no.penalty, pmethod=\"partdep\", %s", devratio(earth.pois.no.penalty))) #------------------------------------------------------------------------------ # poisson model with weights Ins <- Insurance Ins$Claims[Ins$Claims > 100] <- 100 Ins$day <- (1:nrow(Insurance)) / nrow(Insurance) # non linear term (like a seasonal effect) Ins$Claims <- round(Ins$Claims * (1 + sin(2 * pi * Ins$day))) weights <- 1:nrow(Ins) pois.weights <- glm(Claims ~ Group + Age + day, data = Ins, family = poisson, weights=weights) earth.pois.linpreds.weights <- earth(Claims ~ Group + Age + day, data = Ins, glm=list(family = poisson), weights=weights, linpreds=TRUE, thresh=0, penalty=-1) check.earth.matches.glm(earth.pois.linpreds.weights, pois.weights, newdata=Ins[1:3,]) #------------------------------------------------------------------------------ # poisson model with weights, some of which are zero Ins <- Insurance Ins$Claims[Ins$Claims > 100] <- 100 Ins$day <- (1:nrow(Insurance)) / nrow(Insurance) # non linear term (like a seasonal effect) Ins$Claims <- round(Ins$Claims * (1 + sin(2 * pi * Ins$day))) weights <- 1:nrow(Ins) weights[4] <- 0 weights[8] <- 0 pois.weights.some.zero <- glm(Claims ~ Group + Age + day, data = Ins, family = poisson, weights=weights) earth.pois.linpreds.weights.some.zero <- earth(Claims ~ Group + Age + day, data = Ins, glm=list(family = poisson), weights=weights, linpreds=TRUE, thresh=0, penalty=-1) check.earth.matches.glm(earth.pois.linpreds.weights.some.zero, pois.weights.some.zero, newdata=Ins[1:3,], max=1e-5, max.residuals=1e-2) # TODO why does max.residuals have to be so big here? plotres(pois.weights.some.zero, caption="pois.weights.some.zero") plotres(earth.pois.linpreds.weights.some.zero, caption="earth.pois.linpreds.weights.some.zero") plotmo(pois.weights.some.zero, caption="pois.weights.some.zero") plotmo(earth.pois.linpreds.weights.some.zero, caption="earth.pois.linpreds.weights.some.zero") #------------------------------------------------------------------------------ # multiple response models data(trees) tr <- trees set.seed(2019) tr$Vol2 <- tr$Volume + 10 * rnorm(nrow(tr)) earth10 <- earth(Volume ~ Girth + offset(log(Height)), data=tr, linpreds=TRUE, thresh=0, penalty=-1) lm10 <- lm(Volume ~ Girth + offset(log(Height)), data=tr) check.earth.matches.lm(earth10, lm10, newdata=tr[c(3:5),]) cat("earth10:\n") print(summary(earth10)) earth20 <- earth(Vol2 ~ Girth + offset(log(Height)), data=tr, linpreds=TRUE, thresh=0, penalty=-1) cat("earth20:\n") print(summary(earth20)) earth30 <- earth(cbind(Volume, Vol2) ~ Girth + offset(log(Height)), data=tr, linpreds=TRUE, thresh=0, penalty=-1) cat("earth30:\n") print(summary(earth30)) plotmo(lm10, all1=TRUE, pt.col=2) plotmo(earth10, all1=TRUE, pt.col=2) plotmo(earth20, all1=TRUE, pt.col=2) plotmo(earth30, nresponse=1, all1=TRUE, pt.col=2) plotmo(earth30, nresponse=2, all1=TRUE, pt.col=2) plotres(lm10) plotres(earth10) plotres(earth20) plotres(earth30, nresponse=2) plotres(earth30, nresponse=1) # multiple response pois model with weights (basic test) Ins <- Insurance Ins$Claims[Ins$Claims > 100] <- 100 Ins$day <- (1:nrow(Insurance)) / nrow(Insurance) # non linear term (like a seasonal effect) Ins$Claims <- round(Ins$Claims * (1 + sin(2 * pi * Ins$day))) Ins$Claims2 <- Insurance$Claims2 <- round(Insurance$Claims^1.5) weights <- 1:nrow(Ins) weights[4] <- 0 weights[8] <- 0 earth.pois.multiple.response <- earth(x=Insurance$Age, y=cbind(Insurance$Claims, Insurance$Claims2), trace=1, # Insurance$Age expands to x.L x.Q x.C glm=list(family = poisson), weights=weights) cat("earth.pois.multiple.response:\n") print(earth.pois.multiple.response) cat("summary(earth.pois.multiple.response:\n") print(summary(earth.pois.multiple.response)) plotmo(earth.pois.multiple.response, nresponse=1, pt.col=2) # test update.earth with weights and offset data(trees) tr <- trees set.seed(2019) tr$Vol2 <- tr$Volume + 10 * rnorm(nrow(tr)) my.weights <- 1:nrow(tr) my.weights[3] <- 0 earth30 <- earth(Volume ~ Girth + offset(log(Height)), data=tr, linpreds=TRUE, thresh=0, penalty=-1) lm30 <- lm(Volume ~ Girth + offset(log(Height)), data=tr) check.earth.matches.lm(earth30, lm30, newdata=tr[c(3:5),]) lm31 <- lm(Volume ~ Girth, data=tr) earth31 <- earth(Volume ~ Girth, data=tr, linpreds=TRUE, thresh=0, penalty=-1) earth31.offset <- update(earth31, formula.=Volume ~ Girth + offset(log(Height))) check.earth.matches.lm(earth31.offset, lm30, newdata=tr[c(3:5),]) earth.nooffset <- update(earth31.offset, formula.=Volume ~ Girth) check.earth.matches.lm(earth.nooffset, lm31, newdata=tr[c(3:5),]) lm31.weights <- lm(Volume ~ Girth, data=tr, weights=my.weights) earth31.weights <- update(earth31, weights=my.weights) # lower max is needed below because of zeros in my.weights check.earth.matches.lm(earth31.weights, lm31.weights, newdata=tr[c(3:5),], max=1e-6, max.residuals=1e-6) lm31.weights.offset <- lm(Volume ~ Girth + offset(log(Height)), data=tr, weights=my.weights) earth31.weights.offset <- update(earth31.weights, formula=Volume ~ Girth + offset(log(Height))) check.earth.matches.lm(earth31.weights.offset, lm31.weights.offset, newdata=tr[c(3:5),], max=1e-6, max.residuals=1e-6) cat("earth31.weights.offset:\n") print(summary(earth31.weights.offset)) source("test.epilog.R") earth/inst/slowtests/test.bpairs.bat0000755000176200001440000000145613514230362017337 0ustar liggesusers@rem test.bpairs.bat @echo test.bpairs.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.bpairs.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.bpairs.Rout: @echo. @tail test.bpairs.Rout @echo test.bpairs.R @exit /B 1 :good1 mks.diff test.bpairs.Rout test.bpairs.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.bpairs.save.ps @exit /B 1 :good2 @rem test.bpairs.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.bpairs.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.bpairs.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.expand.bpairs.bat0000755000176200001440000000160213514230362020606 0ustar liggesusers@rem test.expand.bpairs.bat @echo test.expand.bpairs.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.expand.bpairs.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.expand.bpairs.Rout: @echo. @tail test.expand.bpairs.Rout @echo test.expand.bpairs.R @exit /B 1 :good1 mks.diff test.expand.bpairs.Rout test.expand.bpairs.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.expand.bpairs.save.ps @exit /B 1 :good2 @rem test.expand.bpairs.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.expand.bpairs.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.expand.bpairs.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.epilog.R0000644000176200001440000000034013446266516016773 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 } earth/inst/slowtests/test.multresp.Rout.save0000644000176200001440000021002213470056774021054 0ustar liggesusers> # test.multresp.R: test multiple response models using the Formula interface > # Stephen Milborrow Mar 2019 Petaluma > > source("test.prolog.R") > source("check.models.equal.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > show.earth.mod <- function(mod, modname, nresponses, caption, trace, ...) + { + set.seed(2019) + cat("\nsummary:", modname, "\n\n") + print(summary(mod)) + cat("\nevimp:", modname, "\n\n") + evimp <- evimp(mod) + print(evimp) + cat("\n") + nrow <- 1 + max(1, ceiling(nresponses * nrow(evimp(mod)) / 2)) + par(mfrow=c(nrow, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) + if(nresponses == 1) + plot(mod, which=c(1,3), do.par=0, caption=caption, trace=trace) + else { + plot(mod, nresponse=1, which=3, do.par=0, + caption=caption, trace=trace, + main="Response 1: Residuals vs Fitted") + plot(mod, nresponse=max(nresponses), which=3, do.par=0, + caption=caption, trace=trace, + main=sprint("Response %d: Residuals vs Fitted", max(nresponses))) + } + cat("\nplotmo:", modname, "\n\n") + if(nresponses == 1) + plotmo(mod, do.par=0, pt.col="red", trace=trace) + else for(iresponse in 1:nresponses) + plotmo(mod, nresponse=iresponse, do.par=0, pt.col=iresponse+1, trace=trace) + par(old.par) + cat("-------------------------------------------------------------------------------\n\n") + } > show.earth.formula <- function(formula, data=trees, subset=NULL, nresponses=1, + show=TRUE, caption=modname, trace=0, ...) + { + modname <- sprint("formula=%s (nresponses=%d)", + deparse(substitute(formula)), nresponses) + printf("%s\n", modname) + # use formula, not Formula + mod <- earth(formula=formula, data=data, subset=subset, trace=1, keepxy=TRUE) + global.mod <<- mod + n <- if(is.null(subset)) nrow(data) else nrow(data[subset,]) + if(!(all(dim(mod$fitted.values) == c(n, nresponses)))) { + cat("dim(mod$fitted.values)", dim(mod$fitted.values), "\n") + stop("show.earth.formula: wrong response dimensions (see above)") + } + if(show) + show.earth.mod(mod=mod, modname=modname, nresponses=nresponses, + caption=caption, trace=trace, ...) + mod + } > show.earth.Formula <- function(formula, data=trees, subset=NULL, nresponses=1, + show=TRUE, caption=modname, trace=0, ...) + { + modname <- sprint("Formula=%s (nresponses=%d)", + deparse(substitute(formula)), nresponses) + printf("%s\n", modname) + # use Formula, not formula + # use trace=1 so so can that we can see trace message: + # Using class "Formula" because lhs of formula has terms separated by "+" + mod <- earth(formula=formula, data=data, subset=subset, trace=1, keepxy=TRUE) + global.mod <<- mod + if(!(all(dim(mod$fitted.values) == c(31, nresponses)))) { + cat("dim(mod$fitted.values)", dim(mod$fitted.values), "\n") + stop("show.earth.Formula: wrong response dimensions (see above)") + } + show.earth.mod(mod=mod, modname=modname, nresponses=nresponses, + caption=caption, trace=trace, ...) + mod + } > options(warn=2) > VolNeg <- -sqrt(trees$Volume) > SinVol <- sin(pi * trees$Volume / max(trees$Volume)) > global.mod <- NULL > > # following use formula (not Formula) > show.earth.formula(Volume/VolNeg ~., show=FALSE) # show=FALSE to save time formula=Volume/VolNeg ~ . (nresponses=1) x[31,2] with colnames Girth Height y[31,1] with colname Volume/VolNeg, and values -3.209, -3.209, -3.194, -4.05... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00068) After forward pass GRSq 0.951 RSq 0.978 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.964 RSq 0.977 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 0.07569746 RSS 1.406508 GRSq 0.9636664 RSq 0.9767465 > show.earth.formula(Volume/99 ~., show=FALSE) formula=Volume/99 ~ . (nresponses=1) x[31,2] with colnames Girth Height y[31,1] with colname Volume/99, and values 0.104, 0.104, 0.103, 0.1657, ... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00087) After forward pass GRSq 0.947 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 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 0.00114829 RSS 0.02133597 GRSq 0.959692 RSq 0.9742029 > show.earth.formula(Volume*99 ~., show=FALSE) formula=Volume * 99 ~ . (nresponses=1) x[31,2] with colnames Girth Height y[31,1] with colname Volume*99, and values 1020, 1020, 1010, 1624, 1861,... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00087) After forward pass GRSq 0.947 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 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 110304.3 RSS 2049525 GRSq 0.959692 RSq 0.9742029 > show.earth.formula(Volume-99 ~., show=FALSE) formula=Volume - 99 ~ . (nresponses=1) x[31,2] with colnames Girth Height y[31,1] with colname Volume-99, and values -88.7, -88.7, -88.8, -82.6, -... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00087) After forward pass GRSq 0.947 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 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 > show.earth.formula(Volume ~., show=FALSE) formula=Volume ~ . (nresponses=1) x[31,2] with colnames Girth Height y[31,1] with colname Volume, and values 10.3, 10.3, 10.2, 16.4, 18.8,... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00087) After forward pass GRSq 0.947 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 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 > show.earth.formula(cbind(Volume+VolNeg)~., show=FALSE) formula=cbind(Volume + VolNeg) ~ . (nresponses=1) x[31,2] with colnames Girth Height y[31,1] with colname cbind(Volume+VolNeg), and values 7.091, 7.091, 7.006, 12.35, 1... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00097) After forward pass GRSq 0.946 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.959 RSq 0.974 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 9.492807 RSS 176.3825 GRSq 0.9593466 RSq 0.9739818 > show.earth.formula((Volume+VolNeg) ~., show=FALSE) formula=(Volume + VolNeg) ~ . (nresponses=1) x[31,2] with colnames Girth Height y[31,1] with colname (Volume+VolNeg), and values 7.091, 7.091, 7.006, 12.35, 1... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00097) After forward pass GRSq 0.946 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.959 RSq 0.974 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 9.492807 RSS 176.3825 GRSq 0.9593466 RSq 0.9739818 > show.earth.formula(I(Volume+VolNeg) ~., show=FALSE) formula=I(Volume + VolNeg) ~ . (nresponses=1) x[31,2] with colnames Girth Height y[31,1] with colname I(Volume+VolNeg), and values 7.091, 7.091, 7.006, 12.35, 1... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00097) After forward pass GRSq 0.946 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.959 RSq 0.974 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 9.492807 RSS 176.3825 GRSq 0.9593466 RSq 0.9739818 > show.earth.formula(VolNeg~Girth+Height, show=FALSE) formula=VolNeg ~ Girth + Height (nresponses=1) x[31,2] with colnames Girth Height y[31,1] with colname VolNeg, and values -3.209, -3.209, -3.194, -4.05... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00068) After forward pass GRSq 0.951 RSq 0.978 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.964 RSq 0.977 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 0.07569746 RSS 1.406508 GRSq 0.9636664 RSq 0.9767465 > > # use formula, but multiple response > show.earth.formula(cbind(VolNeg, SinVol)~., nresponses=2, show=FALSE) formula=cbind(VolNeg, SinVol) ~ . (nresponses=2) x[31,3] with colnames Girth Height Volume y[31,2] with colnames VolNeg SinVol Forward pass term 1, 2, 4, 6, 8 RSq changed by less than 0.001 at 7 terms (DeltaRSq 0.00028) After forward pass GRSq 0.995 RSq 0.999 Prune backward penalty 2 nprune null: selected 5 of 7 terms, and 3 of 3 preds After pruning pass GRSq 0.996 RSq 0.998 Selected 5 of 7 terms, and 3 of 3 predictors Termination condition: RSq changed by less than 0.001 at 7 terms Importance: Volume, Girth, Height Number of terms at each degree of interaction: 1 4 (additive model) GCV RSS GRSq RSq VolNeg 0.002631565 0.04108638 0.9987369 0.9993207 SinVol 0.006303928 0.09842262 0.8684471 0.9292538 All 0.008935494 0.13950899 0.9958075 0.9977454 > show.earth.formula(cbind(VolNeg, SinVol)~., nresponses=2, show=FALSE) formula=cbind(VolNeg, SinVol) ~ . (nresponses=2) x[31,3] with colnames Girth Height Volume y[31,2] with colnames VolNeg SinVol Forward pass term 1, 2, 4, 6, 8 RSq changed by less than 0.001 at 7 terms (DeltaRSq 0.00028) After forward pass GRSq 0.995 RSq 0.999 Prune backward penalty 2 nprune null: selected 5 of 7 terms, and 3 of 3 preds After pruning pass GRSq 0.996 RSq 0.998 Selected 5 of 7 terms, and 3 of 3 predictors Termination condition: RSq changed by less than 0.001 at 7 terms Importance: Volume, Girth, Height Number of terms at each degree of interaction: 1 4 (additive model) GCV RSS GRSq RSq VolNeg 0.002631565 0.04108638 0.9987369 0.9993207 SinVol 0.006303928 0.09842262 0.8684471 0.9292538 All 0.008935494 0.13950899 0.9958075 0.9977454 > show.earth.formula(cbind(VolNeg/33, SinVol)~., nresponses=2, show=FALSE) formula=cbind(VolNeg/33, SinVol) ~ . (nresponses=2) x[31,3] with colnames Girth Height Volume y[31,2] with colnames cbind(VolNeg/33,SinVol)1 SinVol Forward pass term 1, 2, 4, 6, 8, 10, 12 RSq changed by less than 0.001 at 11 terms, 9 terms used (DeltaRSq 0.00019) After forward pass GRSq 0.740 RSq 0.958 Prune backward penalty 2 nprune null: selected 5 of 9 terms, and 2 of 3 preds After pruning pass GRSq 0.894 RSq 0.943 Selected 5 of 9 terms, and 2 of 3 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: Volume, Height, Girth-unused Number of terms at each degree of interaction: 1 4 (additive model) GCV RSS GRSq RSq cbind(VolNeg/33,SinVol)1 0.0000084012 0.000131166 0.9956087 0.9976384 SinVol 0.0052819329 0.082466307 0.8897745 0.9407232 All 0.0052903340 0.082597474 0.8938376 0.9429082 > show.earth.formula(cbind(VolNeg+33, SinVol)~., nresponses=2, show=FALSE) formula=cbind(VolNeg + 33, SinVol) ~ . (nresponses=2) x[31,3] with colnames Girth Height Volume y[31,2] with colnames cbind(VolNeg+33,SinVol)1 SinVol Forward pass term 1, 2, 4, 6, 8 RSq changed by less than 0.001 at 7 terms (DeltaRSq 0.00028) After forward pass GRSq 0.995 RSq 0.999 Prune backward penalty 2 nprune null: selected 5 of 7 terms, and 3 of 3 preds After pruning pass GRSq 0.996 RSq 0.998 Selected 5 of 7 terms, and 3 of 3 predictors Termination condition: RSq changed by less than 0.001 at 7 terms Importance: Volume, Girth, Height Number of terms at each degree of interaction: 1 4 (additive model) GCV RSS GRSq RSq cbind(VolNeg+33,SinVol)1 0.002631565 0.04108638 0.9987369 0.9993207 SinVol 0.006303928 0.09842262 0.8684471 0.9292538 All 0.008935494 0.13950899 0.9958075 0.9977454 > show.earth.formula(cbind(VolNeg, SinVol)~Girth, nresponses=2, show=FALSE) formula=cbind(VolNeg, SinVol) ~ Girth (nresponses=2) x[31,1] with colname Girth, and values 8.3, 8.6, 8.8, 10.5, 10.7, 10... y[31,2] with colnames VolNeg SinVol Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 4 terms used (DeltaRSq 0) After forward pass GRSq 0.917 RSq 0.955 Prune backward penalty 2 nprune null: selected 3 of 4 terms, and 1 of 1 preds After pruning pass GRSq 0.938 RSq 0.954 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV RSS GRSq RSq VolNeg 0.11498191 2.5073475 0.9448104 0.9585465 SinVol 0.01648432 0.3594646 0.6559985 0.7416166 All 0.13146624 2.8668121 0.9383170 0.9536692 > randx <- c(0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0) > show.earth.formula(VolNeg~randx, nresponses=1) # intercept only model formula=VolNeg ~ randx (nresponses=1) x[31,1] with colname randx, and values 0, 1, 0, 1, 0, 1, 0, 1, 0, 1,... y[31,1] with colname VolNeg, and values -3.209, -3.209, -3.194, -4.05... Forward pass term 1, 2, 4 RSq changed by less than 0.001 at 3 terms, 2 terms used (DeltaRSq 0) After forward pass GRSq -0.328 RSq 0.003 Prune backward penalty 2 nprune null: selected 1 of 2 terms, and 0 of 1 preds After pruning pass GRSq 0 RSq 0 summary: formula=VolNeg ~ randx (nresponses=1) Call: earth(formula=formula, data=data, subset=subset, keepxy=TRUE, trace=1) coefficients (Intercept) -5.312232 Selected 1 of 2 terms, and 0 of 1 predictors Termination condition: RSq changed by less than 0.001 at 2 terms Importance: randx-unused Number of terms at each degree of interaction: 1 (intercept only model) GCV 2.083399 RSS 60.48579 GRSq 0 RSq 0 evimp: formula=VolNeg ~ randx (nresponses=1) nsubsets gcv rss plotmo: formula=VolNeg ~ randx (nresponses=1) ------------------------------------------------------------------------------- Selected 1 of 2 terms, and 0 of 1 predictors Termination condition: RSq changed by less than 0.001 at 2 terms Importance: randx-unused Number of terms at each degree of interaction: 1 (intercept only model) GCV 2.083399 RSS 60.48579 GRSq 0 RSq 0 > VolVolNeg <- show.earth.formula(cbind(Volume, VolNeg)~Girth+Height, nresponses=2, trace=0) formula=cbind(Volume, VolNeg) ~ Girth + Height (nresponses=2) x[31,2] with colnames Girth Height y[31,2] with colnames Volume VolNeg Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00087) After forward pass GRSq 0.947 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 summary: formula=cbind(Volume, VolNeg) ~ Girth + Height (nresponses=2) Call: earth(formula=formula, data=data, subset=subset, keepxy=TRUE, trace=1) Volume VolNeg (Intercept) 29.0599535 -5.4935391 h(14.2-Girth) -3.4198062 0.3964215 h(Girth-14.2) 6.2295143 -0.4313910 h(Height-75) 0.5813644 -0.0529614 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 RSS GRSq RSq Volume 11.2543915 209.113855 0.9596919 0.9742028 VolNeg 0.0885223 1.644801 0.9575107 0.9728068 All 11.3429138 210.758656 0.9596758 0.9741925 evimp: formula=cbind(Volume, VolNeg) ~ Girth + Height (nresponses=2) nsubsets gcv rss Girth 3 100.0 100.0 Height 1 10.7 11.5 plotmo: formula=cbind(Volume, VolNeg) ~ Girth + Height (nresponses=2) plotmo grid: Girth Height 12.9 76 plotmo grid: Girth Height 12.9 76 ------------------------------------------------------------------------------- > # Use a global variable for Volume > trees1 <- trees > Volume <- trees1$Volume # global Volume > trees1$Volume <- NULL # Volume no longer available in trees1 > cbind.Volume.VolNeg <- cbind(Volume, VolNeg) > VolGlobalVolNeg <- show.earth.formula(cbind(Volume, VolNeg)~Girth+Height, data=trees1, nresponses=2, trace=0, + caption="VolGlobalVolNeg: This page should be the same as the previous page") formula=cbind(Volume, VolNeg) ~ Girth + Height (nresponses=2) x[31,2] with colnames Girth Height y[31,2] with colnames Volume VolNeg Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00087) After forward pass GRSq 0.947 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 summary: formula=cbind(Volume, VolNeg) ~ Girth + Height (nresponses=2) Call: earth(formula=formula, data=data, subset=subset, keepxy=TRUE, trace=1) Volume VolNeg (Intercept) 29.0599535 -5.4935391 h(14.2-Girth) -3.4198062 0.3964215 h(Girth-14.2) 6.2295143 -0.4313910 h(Height-75) 0.5813644 -0.0529614 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 RSS GRSq RSq Volume 11.2543915 209.113855 0.9596919 0.9742028 VolNeg 0.0885223 1.644801 0.9575107 0.9728068 All 11.3429138 210.758656 0.9596758 0.9741925 evimp: formula=cbind(Volume, VolNeg) ~ Girth + Height (nresponses=2) nsubsets gcv rss Girth 3 100.0 100.0 Height 1 10.7 11.5 plotmo: formula=cbind(Volume, VolNeg) ~ Girth + Height (nresponses=2) plotmo grid: Girth Height 12.9 76 plotmo grid: Girth Height 12.9 76 ------------------------------------------------------------------------------- > check.models.equal(VolVolNeg, VolGlobalVolNeg, msg="VolVolNeg, VolGlobalVolNeg", newdata=trees[3,]) VolVolNeg, VolGlobalVolNeg: models not identical VolVolNeg, VolGlobalVolNeg: Models are equivalent, within numerical tolerances > > # following use Formula (not formula) > VolVolNega <- show.earth.Formula(Volume+VolNeg~Girth+Height, nresponses=2, + caption="VolVolNega: This page should be the same as the previous page") Formula=Volume + VolNeg ~ Girth + Height (nresponses=2) Using class "Formula" because lhs of formula has terms separated by "+" x[31,2] with colnames Girth Height y[31,2] with colnames Volume VolNeg Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00087) After forward pass GRSq 0.947 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 summary: Formula=Volume + VolNeg ~ Girth + Height (nresponses=2) Call: earth(formula=formula, data=data, subset=subset, keepxy=TRUE, trace=1) Volume VolNeg (Intercept) 29.0599535 -5.4935391 h(14.2-Girth) -3.4198062 0.3964215 h(Girth-14.2) 6.2295143 -0.4313910 h(Height-75) 0.5813644 -0.0529614 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 RSS GRSq RSq Volume 11.2543915 209.113855 0.9596919 0.9742028 VolNeg 0.0885223 1.644801 0.9575107 0.9728068 All 11.3429138 210.758656 0.9596758 0.9741925 evimp: Formula=Volume + VolNeg ~ Girth + Height (nresponses=2) nsubsets gcv rss Girth 3 100.0 100.0 Height 1 10.7 11.5 plotmo: Formula=Volume + VolNeg ~ Girth + Height (nresponses=2) plotmo grid: Girth Height 12.9 76 plotmo grid: Girth Height 12.9 76 ------------------------------------------------------------------------------- > check.models.equal(VolVolNega, VolVolNeg, msg="VolVolNega, VolVolNeg", newdata=trees[3,]) VolVolNega, VolVolNeg: models not identical Formulas differ: ~Volume + VolNeg + (Girth + Height) and: cbind(Volume, VolNeg) ~ Girth + Height VolVolNega, VolVolNeg: Models are equivalent, within numerical tolerances > Vol.VolNeg.dot <- show.earth.Formula(Volume+VolNeg~., nresponses=2, # use dot + caption="Vol.VolNeg.dot: This page should be the same as the previous page") Formula=Volume + VolNeg ~ . (nresponses=2) Using class "Formula" because lhs of formula has terms separated by "+" x[31,2] with colnames Girth Height y[31,2] with colnames Volume VolNeg Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00087) After forward pass GRSq 0.947 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 summary: Formula=Volume + VolNeg ~ . (nresponses=2) Call: earth(formula=formula, data=data, subset=subset, keepxy=TRUE, trace=1) Volume VolNeg (Intercept) 29.0599535 -5.4935391 h(14.2-Girth) -3.4198062 0.3964215 h(Girth-14.2) 6.2295143 -0.4313910 h(Height-75) 0.5813644 -0.0529614 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 RSS GRSq RSq Volume 11.2543915 209.113855 0.9596919 0.9742028 VolNeg 0.0885223 1.644801 0.9575107 0.9728068 All 11.3429138 210.758656 0.9596758 0.9741925 evimp: Formula=Volume + VolNeg ~ . (nresponses=2) nsubsets gcv rss Girth 3 100.0 100.0 Height 1 10.7 11.5 plotmo: Formula=Volume + VolNeg ~ . (nresponses=2) plotmo grid: Girth Height 12.9 76 plotmo grid: Girth Height 12.9 76 ------------------------------------------------------------------------------- > check.models.equal(Vol.VolNeg.dot, VolVolNega, msg="Vol.VolNeg.dot, VolVolNega", newdata=trees[3,]) Vol.VolNeg.dot, VolVolNega: models not identical Formulas differ: ~Volume + VolNeg + (Girth + Height) and: ~Volume + VolNeg + (Girth + Height) Vol.VolNeg.dot, VolVolNega: Models are equivalent, within numerical tolerances > > trees1 <- trees > trees1$VolNeg <- VolNeg > VolVolNegc <- show.earth.Formula(Volume+VolNeg~., data=trees1, nresponses=2, # all variables on lhs in data argument (none global) + caption="Vol.VolNeg.trees1: This page should be the same as the previous page") Formula=Volume + VolNeg ~ . (nresponses=2) Using class "Formula" because lhs of formula has terms separated by "+" x[31,2] with colnames Girth Height y[31,2] with colnames Volume VolNeg Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00087) After forward pass GRSq 0.947 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 summary: Formula=Volume + VolNeg ~ . (nresponses=2) Call: earth(formula=formula, data=data, subset=subset, keepxy=TRUE, trace=1) Volume VolNeg (Intercept) 29.0599535 -5.4935391 h(14.2-Girth) -3.4198062 0.3964215 h(Girth-14.2) 6.2295143 -0.4313910 h(Height-75) 0.5813644 -0.0529614 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 RSS GRSq RSq Volume 11.2543915 209.113855 0.9596919 0.9742028 VolNeg 0.0885223 1.644801 0.9575107 0.9728068 All 11.3429138 210.758656 0.9596758 0.9741925 evimp: Formula=Volume + VolNeg ~ . (nresponses=2) nsubsets gcv rss Girth 3 100.0 100.0 Height 1 10.7 11.5 plotmo: Formula=Volume + VolNeg ~ . (nresponses=2) plotmo grid: Girth Height 12.9 76 plotmo grid: Girth Height 12.9 76 ------------------------------------------------------------------------------- > check.models.equal(VolVolNegc, VolVolNega, msg="VolVolNegc, VolVolNega", newdata=trees1[2:3,]) VolVolNegc, VolVolNega: models not identical Formulas differ: ~Volume + VolNeg + (Girth + Height) and: ~Volume + VolNeg + (Girth + Height) VolVolNegc, VolVolNega: Models are equivalent, within numerical tolerances > > # check without using keepxy=TRUE (because show.earth.Formula uses keepxy=TRUE) > VolVolNega.nokeepxy <- earth(Volume+VolNeg~Girth+Height, data=trees, trace=1) Using class "Formula" because lhs of formula has terms separated by "+" x[31,2] with colnames Girth Height y[31,2] with colnames Volume VolNeg Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00087) After forward pass GRSq 0.947 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 > check.models.equal(VolVolNega.nokeepxy, VolVolNega, msg="VolVolNega.nokeepxy, VolVolNega", newdata=trees1[2:3,]) VolVolNega.nokeepxy, VolVolNega: models not identical VolVolNega.nokeepxy, VolVolNega: Models are equivalent, within numerical tolerances > caption <- "VolVolNega.nokeepxy This page should be the same as the previous page" > par(mfrow=c(3, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) > plot(VolVolNega.nokeepxy, nresponse=1, which=3, do.par=0, + caption=caption, trace=0, + main="Response 1: Residuals vs Fitted") > plot(VolVolNega.nokeepxy, nresponse=2, which=3, do.par=0, + caption=caption, trace=0, + main="Response 2: Residuals vs Fitted") > plotmo(VolVolNega.nokeepxy, nresponse=1, do.par=0, pt.col=2) plotmo grid: Girth Height 12.9 76 > plotmo(VolVolNega.nokeepxy, nresponse=2, do.par=0, pt.col=3) plotmo grid: Girth Height 12.9 76 > par(old.par) > options(warn=1) > plot(VolVolNega.nokeepxy) # Warning: Defaulting to nresponse=1, see above messages predict.earth[31,2]: Volume VolNeg 1 8.883097 -3.154652 2 9.909039 -3.273579 3 10.593000 -3.352863 ... 16.406671 -4.026780 31 75.905218 -8.889978 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="VolNeg" Warning: Defaulting to nresponse=1, see above messages > options(warn=2) > > # subset, single response > # TODO we don't use show.earth.formula here because there are plotmo problems > # with subset and keepxy when called inside a function > subset2 <- seq(from=1, to=nrow(trees1), by=2) > Vol.formula.subset.nokeepxy <- earth(Volume~Girth+Height, data=trees1, subset=subset2, trace=1) x[31,2] with colnames Girth Height y[31,1] with colname Volume, and values 10.3, 10.3, 10.2, 16.4, 18.8,... 16 cases after taking subset Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0) After forward pass GRSq 0.888 RSq 0.988 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.958 RSq 0.985 > plot(Vol.formula.subset.nokeepxy, caption="Vol.formula.subset.nokeepxy") > plotmo(Vol.formula.subset.nokeepxy, nresponse=1, trace=1, pt.col=2, caption="Vol.formula.subset.nokeepxy") stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from model.frame(Volume~Girth+Height, data=call$data, na.action="na.fail") plotmo grid: Girth Height 12.45 77.5 > > Vol.formula.subset.keepxy <- earth(Volume~Girth+Height, data=trees1, subset=subset2, trace=1) x[31,2] with colnames Girth Height y[31,1] with colname Volume, and values 10.3, 10.3, 10.2, 16.4, 18.8,... 16 cases after taking subset Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0) After forward pass GRSq 0.888 RSq 0.988 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.958 RSq 0.985 > plotmo(Vol.formula.subset.keepxy, nresponse=1, trace=1, pt.col=2, caption="Vol.formula.subset.keepxy") stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from model.frame(Volume~Girth+Height, data=call$data, na.action="na.fail") plotmo grid: Girth Height 12.45 77.5 > > # subset, multiple response > VolVolNega.formula.subset.nokeepxy <- earth(cbind.Volume.VolNeg~Girth+Height, data=trees1, subset=subset2, trace=1) x[31,2] with colnames Girth Height y[31,2] with colnames Volume VolNeg 16 cases after taking subset Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0) After forward pass GRSq 0.888 RSq 0.988 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.958 RSq 0.985 > VolVolNega.Formula.subset.nokeepxy <- earth(Volume+VolNeg ~Girth+Height, data=trees1, subset=subset2, trace=1) Using class "Formula" because lhs of formula has terms separated by "+" x[31,2] with colnames Girth Height y[31,2] with colnames Volume VolNeg 16 cases after taking subset Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0) After forward pass GRSq 0.888 RSq 0.988 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.958 RSq 0.985 > check.models.equal(VolVolNega.formula.subset.nokeepxy, VolVolNega.Formula.subset.nokeepxy, "VolVolNega.formula.subset.nokeepxy, VolVolNega.Formula.subset.nokeepxy", newdata=trees[3,]) VolVolNega.formula.subset.nokeepxy, VolVolNega.Formula.subset.nokeepxy: models not identical Formulas differ: cbind.Volume.VolNeg ~ Girth + Height and: ~Volume + VolNeg + (Girth + Height) VolVolNega.formula.subset.nokeepxy, VolVolNega.Formula.subset.nokeepxy: Models are equivalent, within numerical tolerances > > caption <- "VolVolNega.formula.subset.nokeepxy" > par(mfrow=c(3, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) > plot(VolVolNega.formula.subset.nokeepxy, nresponse=1, which=3, do.par=0, + caption=caption, trace=1, + main="Response 1: Residuals vs Fitted") stats::residuals(object=earth.object, type="response") stats::fitted(object=earth.object) got model response from model.frame(cbind.Volume.VolNeg~Girth+Height, data=call$data, na.action="na.fail") training rsq 0.98 > plot(VolVolNega.formula.subset.nokeepxy, nresponse=2, which=3, do.par=0, + caption=caption, trace=1, + main="Response 2: Residuals vs Fitted") stats::residuals(object=earth.object, type="response") stats::fitted(object=earth.object) got model response from model.frame(cbind.Volume.VolNeg~Girth+Height, data=call$data, na.action="na.fail") training rsq 0.98 > plotmo(VolVolNega.formula.subset.nokeepxy, nresponse=1, do.par=0, pt.col=2) plotmo grid: Girth Height 12.45 77.5 > plotmo(VolVolNega.formula.subset.nokeepxy, nresponse=2, do.par=0, pt.col=3) plotmo grid: Girth Height 12.45 77.5 > par(old.par) > > caption <- "VolVolNega.Formula.subset.nokeepxy" > par(mfrow=c(3, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) > plot(VolVolNega.Formula.subset.nokeepxy, nresponse=1, which=3, do.par=0, + caption=caption, trace=1, + main="Response 1: Residuals vs Fitted") stats::residuals(object=earth.object, type="response") stats::fitted(object=earth.object) object created with Formula (not formula): using attr(terms, "Formula") object created with Formula (not formula): using attr(terms, "Formula") got model response from model.frame(Volume+VolNeg~Girth+Height, data=call$data, na.action="na.fail") training rsq 0.98 > plot(VolVolNega.Formula.subset.nokeepxy, nresponse=2, which=3, do.par=0, + caption=caption, trace=1, + main="Response 2: Residuals vs Fitted") stats::residuals(object=earth.object, type="response") stats::fitted(object=earth.object) object created with Formula (not formula): using attr(terms, "Formula") object created with Formula (not formula): using attr(terms, "Formula") got model response from model.frame(Volume+VolNeg~Girth+Height, data=call$data, na.action="na.fail") training rsq 0.98 > plotmo(VolVolNega.Formula.subset.nokeepxy, nresponse=1, do.par=0, pt.col=2) plotmo grid: Girth Height 12.45 77.5 > plotmo(VolVolNega.Formula.subset.nokeepxy, nresponse=2, do.par=0, pt.col=3) plotmo grid: Girth Height 12.45 77.5 > par(old.par) > > # subset, multiple response, keepxy > subset2 <- seq(from=1, to=nrow(trees1), by=2) > VolVolNega.formula.subset.keepxy <- earth(cbind.Volume.VolNeg~Girth+Height, data=trees1, subset=subset2, trace=1, keepxy=TRUE) x[31,2] with colnames Girth Height y[31,2] with colnames Volume VolNeg 16 cases after taking subset Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0) After forward pass GRSq 0.888 RSq 0.988 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.958 RSq 0.985 > VolVolNega.Formula.subset.keepxy <- earth(Volume+VolNeg ~Girth+Height, data=trees1, subset=subset2, trace=1, keepxy=TRUE) Using class "Formula" because lhs of formula has terms separated by "+" x[31,2] with colnames Girth Height y[31,2] with colnames Volume VolNeg 16 cases after taking subset Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0) After forward pass GRSq 0.888 RSq 0.988 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.958 RSq 0.985 > check.models.equal(VolVolNega.formula.subset.nokeepxy, VolVolNega.formula.subset.keepxy, msg="VolVolNega.formula.subset.nokeepxy, VolVolNega.formula.subset.keepxy", newdata=trees1[2:3,]) VolVolNega.formula.subset.nokeepxy, VolVolNega.formula.subset.keepxy: models not identical VolVolNega.formula.subset.nokeepxy, VolVolNega.formula.subset.keepxy: Models are equivalent, within numerical tolerances > check.models.equal(VolVolNega.Formula.subset.nokeepxy, VolVolNega.Formula.subset.keepxy, msg="VolVolNega.Formula.subset.nokeepxy, VolVolNega.Formula.subset.keepxy", newdata=trees1[2:3,]) VolVolNega.Formula.subset.nokeepxy, VolVolNega.Formula.subset.keepxy: models not identical VolVolNega.Formula.subset.nokeepxy, VolVolNega.Formula.subset.keepxy: Models are equivalent, within numerical tolerances > check.models.equal(VolVolNega.formula.subset.keepxy, VolVolNega.Formula.subset.keepxy, msg="VolVolNega.formula.subset.keepxy, VolVolNega.Formula.subset.keepxy", newdata=trees1[2:3,]) VolVolNega.formula.subset.keepxy, VolVolNega.Formula.subset.keepxy: models not identical Formulas differ: cbind.Volume.VolNeg ~ Girth + Height and: ~Volume + VolNeg + (Girth + Height) VolVolNega.formula.subset.keepxy, VolVolNega.Formula.subset.keepxy: Models are equivalent, within numerical tolerances > > caption <- "VolVolNega.formula.subset.keepxy" > par(mfrow=c(3, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) > plot(VolVolNega.formula.subset.keepxy, nresponse=1, which=3, do.par=0, + caption=caption, trace=1, + main="Response 1: Residuals vs Fitted") stats::residuals(object=earth.object, type="response") stats::fitted(object=earth.object) got model response from object$y training rsq 0.98 > plot(VolVolNega.formula.subset.keepxy, nresponse=2, which=3, do.par=0, + caption=caption, trace=1, + main="Response 2: Residuals vs Fitted") stats::residuals(object=earth.object, type="response") stats::fitted(object=earth.object) got model response from object$y training rsq 0.98 > # TODO following fail: subset and keepxy > try(plotmo(VolVolNega.formula.subset.keepxy, nresponse=1, do.par=0, pt.col=2)) Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'Girth') (3) getCall(object)$x: NULL Error : cannot get the original model predictors > try(plotmo(VolVolNega.formula.subset.keepxy, nresponse=2, do.par=0, pt.col=3)) Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'Girth') (3) getCall(object)$x: NULL Error : cannot get the original model predictors > par(old.par) > > caption <- "VolVolNega.Formula.subset.keepxy" > par(mfrow=c(3, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) > plot(VolVolNega.Formula.subset.keepxy, nresponse=1, which=3, do.par=0, + caption=caption, trace=1, + main="Response 1: Residuals vs Fitted") stats::residuals(object=earth.object, type="response") stats::fitted(object=earth.object) got model response from object$y training rsq 0.98 > plot(VolVolNega.Formula.subset.keepxy, nresponse=2, which=3, do.par=0, + caption=caption, trace=1, + main="Response 2: Residuals vs Fitted") stats::residuals(object=earth.object, type="response") stats::fitted(object=earth.object) got model response from object$y training rsq 0.98 > # TODO following fail: subset and keepxy > try(plotmo(VolVolNega.Formula.subset.keepxy, nresponse=1, do.par=0, pt.col=2)) Error : 'subset' is out of range, allowed values are 1 to 16 > try(plotmo(VolVolNega.Formula.subset.keepxy, nresponse=2, do.par=0, pt.col=3)) Error : 'subset' is out of range, allowed values are 1 to 16 > par(old.par) > > # subset, multiple response, weights > weights2 <- sqrt(1:nrow(trees1)) > VolVolNega.formula.weights.subset.nokeepxy <- earth(cbind.Volume.VolNeg~Girth+Height, data=trees1, weights=weights2, subset=subset2, trace=1) x[31,2] with colnames Girth Height y[31,2] with colnames Volume VolNeg weights[31]: 1, 1.414, 1.732, 2, 2.236, 2.449, 2.646, 2.828, 3, 3.162,... 16 cases after taking subset Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0) After forward pass GRSq 0.887 RSq 0.987 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.958 RSq 0.985 > VolVolNega.Formula.weights.subset.nokeepxy <- earth(Volume+VolNeg ~Girth+Height, data=trees1, weights=weights2, subset=subset2, trace=1) Using class "Formula" because lhs of formula has terms separated by "+" x[31,2] with colnames Girth Height y[31,2] with colnames Volume VolNeg weights[31]: 1, 1.414, 1.732, 2, 2.236, 2.449, 2.646, 2.828, 3, 3.162,... 16 cases after taking subset Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0) After forward pass GRSq 0.887 RSq 0.987 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.958 RSq 0.985 > check.models.equal(VolVolNega.formula.weights.subset.nokeepxy, VolVolNega.Formula.weights.subset.nokeepxy, "VolVolNega.formula.weights.subset.nokeepxy, VolVolNega.Formula.weights.subset.nokeepxy") VolVolNega.formula.weights.subset.nokeepxy, VolVolNega.Formula.weights.subset.nokeepxy: models not identical Formulas differ: cbind.Volume.VolNeg ~ Girth + Height and: ~Volume + VolNeg + (Girth + Height) VolVolNega.formula.weights.subset.nokeepxy, VolVolNega.Formula.weights.subset.nokeepxy: Models are equivalent, within numerical tolerances > > caption <- "VolVolNega.formula.weights.subset.nokeepxy" > par(mfrow=c(3, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) > plot(VolVolNega.formula.weights.subset.nokeepxy, nresponse=1, which=3, do.par=0, + caption=caption, trace=1, + main="Response 1: Residuals vs Fitted") stats::residuals(object=earth.object, type="response") stats::fitted(object=earth.object) got model response from model.frame(cbind.Volume.VolNeg~Girth+Height, data=call$data, na.action="na.fail") training rsq 0.98 > plot(VolVolNega.formula.weights.subset.nokeepxy, nresponse=2, which=3, do.par=0, + caption=caption, trace=1, + main="Response 2: Residuals vs Fitted") stats::residuals(object=earth.object, type="response") stats::fitted(object=earth.object) got model response from model.frame(cbind.Volume.VolNeg~Girth+Height, data=call$data, na.action="na.fail") training rsq 0.98 > plotmo(VolVolNega.formula.weights.subset.nokeepxy, nresponse=1, do.par=0, pt.col=2) plotmo grid: Girth Height 12.45 77.5 > plotmo(VolVolNega.formula.weights.subset.nokeepxy, nresponse=2, do.par=0, pt.col=3) plotmo grid: Girth Height 12.45 77.5 > par(old.par) > > caption <- "VolVolNega.Formula.weights.subset.nokeepxy" > par(mfrow=c(3, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) > plot(VolVolNega.Formula.weights.subset.nokeepxy, nresponse=1, which=3, do.par=0, + caption=caption, trace=1, + main="Response 1: Residuals vs Fitted") stats::residuals(object=earth.object, type="response") stats::fitted(object=earth.object) object created with Formula (not formula): using attr(terms, "Formula") object created with Formula (not formula): using attr(terms, "Formula") got model response from model.frame(Volume+VolNeg~Girth+Height, data=call$data, na.action="na.fail") training rsq 0.98 > plot(VolVolNega.Formula.weights.subset.nokeepxy, nresponse=2, which=3, do.par=0, + caption=caption, trace=1, + main="Response 2: Residuals vs Fitted") stats::residuals(object=earth.object, type="response") stats::fitted(object=earth.object) object created with Formula (not formula): using attr(terms, "Formula") object created with Formula (not formula): using attr(terms, "Formula") got model response from model.frame(Volume+VolNeg~Girth+Height, data=call$data, na.action="na.fail") training rsq 0.98 > plotmo(VolVolNega.Formula.weights.subset.nokeepxy, nresponse=1, do.par=0, pt.col=2) plotmo grid: Girth Height 12.45 77.5 > plotmo(VolVolNega.Formula.weights.subset.nokeepxy, nresponse=2, do.par=0, pt.col=3) plotmo grid: Girth Height 12.45 77.5 > par(old.par) > > # examples in earth vignette > data(ozone1) > mul1 <- earth(cbind(O3,wind) ~ ., data=ozone1) # formula interface > mul2 <- earth(O3 + wind ~ ., data=ozone1) # use + on left of formula > check.models.equal(mul2, mul1, "mul2, mul1", newdata=ozone1[1:3,]) mul2, mul1: models not identical Formulas differ: ~O3 + wind + (vh + humidity + temp + ibh + dpg + ibt + vis + doy) and: cbind(O3, wind) ~ vh + humidity + temp + ibh + dpg + ibt + vis + doy mul2, mul1: Models are equivalent, within numerical tolerances > mul3 <- earth(ozone1[,-c(1,3)], ozone1[,c(1,3)]) # x,y interface > check.models.equal(mul3, mul1,"mul3, mul", newdata=ozone1[1:3,]) mul3, mul: models not identical Formulas differ: Error in formula.default(mod1) : invalid formula and: cbind(O3, wind) ~ vh + humidity + temp + ibh + dpg + ibt + vis + doy mul3, mul: Models are equivalent, within numerical tolerances > mul4 <- earth(cbind(log.O3=log(O3),wind) ~ ., data=ozone1) > print(summary(mul4)) Call: earth(formula=cbind(log.O3=log(O3),wind)~., data=ozone1) log.O3 wind (Intercept) 3.2898176 6.5858915 h(5700-vh) -0.0036819 0.0098936 h(vh-5810) 0.0053975 -0.0120374 h(32-humidity) -0.0233220 0.1003807 h(humidity-32) 0.0026948 0.0194174 h(temp-80) 0.0015404 0.1486489 h(2972-ibh) 0.0001920 -0.0003352 h(vis-250) -0.0000692 0.0143934 h(doy-150) -0.0082304 -0.0103293 h(285-doy) -0.0071836 -0.0120143 h(doy-318) 0.0003533 -0.0621512 h(doy-376) -0.0169292 0.2458606 Selected 12 of 17 terms, and 6 of 8 predictors Termination condition: Reached nk 21 Importance: doy, vh, ibh, temp, humidity, vis, dpg-unused, ibt-unused Number of terms at each degree of interaction: 1 11 (additive model) GCV RSS GRSq RSq log.O3 0.2031747 58.02731 0.6383106 0.6850651 wind 3.1435625 897.81098 0.3006775 0.3910769 All 3.3467372 955.83829 0.3381830 0.4237342 > x1 <- ozone1$O3 > x2 <- ozone1$win > x3 <- ozone1$O3 > y1 <- ozone1$temp > y2 <- ozone1$doy > mul5 <- earth(x=data.frame(x1, x2, log.x3=log(x3)), y=data.frame(y1, y2), trace=1) x[330,3] with colnames x1 x2 log.x3 y[330,2] with colnames y1 y2 Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.063 RSq 0.205 Prune backward penalty 2 nprune null: selected 5 of 14 terms, and 3 of 3 preds After pruning pass GRSq 0.125 RSq 0.167 > print(summary(mul5)) Call: earth(x=data.frame(x1,x2,log.x3=log(x3)), y=data.frame(y1,y2), trace=1) y1 y2 (Intercept) 73.810483 216.683033 h(14-x1) -2.625043 -5.874072 h(3-x2) -0.562188 51.060251 h(x2-8) -3.262345 -40.527822 h(1.79176-log.x3) 3.856324 93.506320 Selected 5 of 14 terms, and 3 of 3 predictors Termination condition: Reached nk 21 Importance: x2, x1, log.x3 Number of terms at each degree of interaction: 1 4 (additive model) GCV RSS GRSq RSq y1 91.8529 28680.65 0.5619596 0.5830035 y2 9649.8087 3013108.89 0.1169277 0.1593514 All 9741.6616 3041789.54 0.1253067 0.1673278 > log.x3 <- log(x3) > mul6 <- earth(y1 + y2 ~ x1 + x2 + log.x3, trace=1) Using class "Formula" because lhs of formula has terms separated by "+" x[330,3] with colnames x1 x2 log.x3 y[330,2] with colnames y1 y2 Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.063 RSq 0.205 Prune backward penalty 2 nprune null: selected 5 of 14 terms, and 3 of 3 preds After pruning pass GRSq 0.125 RSq 0.167 > stopifnot(all.equal(as.vector(mul5$coefficients), as.vector(mul6$coefficients))) > stopifnot(all.equal(as.vector(mul5$dirs), as.vector(mul6$dirs))) > mul7 <- earth(y1 + y2 ~ x1 + x2 + log(x3), trace=1) Using class "Formula" because lhs of formula has terms separated by "+" x[330,3] with colnames x1 x2 log(x3) y[330,2] with colnames y1 y2 Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.063 RSq 0.205 Prune backward penalty 2 nprune null: selected 5 of 14 terms, and 3 of 3 preds After pruning pass GRSq 0.125 RSq 0.167 > stopifnot(all.equal(as.vector(mul5$coefficients), as.vector(mul7$coefficients))) > stopifnot(all.equal(as.vector(mul5$dirs), as.vector(mul7$dirs))) > > log.O3.wind <- log(ozone1$O3 + ozone1$wind) > a10 <- earth(log.O3.wind + ibt ~ temp, data=ozone1, trace=1) Using class "Formula" because lhs of formula has terms separated by "+" x[330,1] with colname temp, and values 40, 45, 54, 35, 45, 55, 41, 4... y[330,2] with colnames log.O3.wind ibt Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 4 terms used (DeltaRSq 0.00024) After forward pass GRSq 0.738 RSq 0.750 Prune backward penalty 2 nprune null: selected 3 of 4 terms, and 1 of 1 preds After pruning pass GRSq 0.743 RSq 0.749 > a11 <- earth(log(O3 + wind) + ibt ~ temp, data=ozone1, trace=1) Using class "Formula" because lhs of formula has terms separated by "+" x[330,1] with colname temp, and values 40, 45, 54, 35, 45, 55, 41, 4... y[330,2] with colnames `log(O3+wind)` ibt Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 4 terms used (DeltaRSq 0.00024) After forward pass GRSq 0.738 RSq 0.750 Prune backward penalty 2 nprune null: selected 3 of 4 terms, and 1 of 1 preds After pruning pass GRSq 0.743 RSq 0.749 > stopifnot(all.equal(as.vector(a10$coefficients), as.vector(a11$coefficients))) > stopifnot(all.equal(as.vector(a10$dirs), as.vector(a11$dirs))) > > expect.err(try(show.earth.Formula(VolNeg+Volume~1, nresponses=2)), "'x' has no columns") Formula=VolNeg + Volume ~ 1 (nresponses=2) Using class "Formula" because lhs of formula has terms separated by "+" x: length zero y[31,2] with colnames VolNeg Volume Error : 'x' has no columns Got error as expected from try(show.earth.Formula(VolNeg + Volume ~ 1, nresponses = 2)) > # use lhs on rhs TODO earth itself should give an error message, not just plotmo > expect.err(try(show.earth.Formula(VolNeg+Volume~Volume, nresponses=2)), "x is empty") # err from plotmo Formula=VolNeg + Volume ~ Volume (nresponses=2) Using class "Formula" because lhs of formula has terms separated by "+" x[31,1] with colname Volume, and values 10.3, 10.3, 10.2, 16.4, 18.8,... y[31,2] with colnames VolNeg Volume Forward pass term 1, 2 Reached maximum RSq 0.9990 at 3 terms (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Prune backward penalty 2 nprune null: selected 3 of 3 terms, and 1 of 1 preds After pruning pass GRSq 1 RSq 1 summary: Formula=VolNeg + Volume ~ Volume (nresponses=2) Call: earth(formula=formula, data=data, subset=subset, keepxy=TRUE, trace=1) VolNeg Volume (Intercept) -5.7604480 31.7 h(31.7-Volume) 0.1144978 -1.0 h(Volume-31.7) -0.0689001 1.0 Selected 3 of 3 terms, and 1 of 1 predictors Termination condition: Reached maximum RSq 0.9990 at 3 terms Importance: Volume Number of terms at each degree of interaction: 1 2 (additive model) GCV RSS GRSq RSq VolNeg 0.005362325 0.1169333 0.9974262 0.9980668 Volume 0.000000000 0.0000000 1.0000000 1.0000000 All 0.005362325 0.1169333 0.9999809 0.9999857 evimp: Formula=VolNeg + Volume ~ Volume (nresponses=2) nsubsets gcv rss Volume 2 281.3> 8166.5> plotmo: Formula=VolNeg + Volume ~ Volume (nresponses=2) Error in plotmo(mod, nresponse = iresponse, do.par = 0, pt.col = iresponse + : x is empty Got error as expected from try(show.earth.Formula(VolNeg + Volume ~ Volume, nresponses = 2)) > # formula has better error handling than Formula (model.matrix.default gives warning) > expect.err(try(show.earth.formula(Volume~Volume)), "(converted from warning) the response appeared on the right-hand side and was dropped") formula=Volume ~ Volume (nresponses=1) Error in model.matrix.default(terms, data = mf) : (converted from warning) the response appeared on the right-hand side and was dropped Got error as expected from try(show.earth.formula(Volume ~ Volume)) > show.earth.Formula(VolNeg+Volume~Girth, nresponses=2, subset=) Formula=VolNeg + Volume ~ Girth (nresponses=2) Using class "Formula" because lhs of formula has terms separated by "+" x[31,1] with colname Girth, and values 8.3, 8.6, 8.8, 10.5, 10.7, 10... y[31,2] with colnames VolNeg Volume Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms, 4 terms used (DeltaRSq 8.6e-05) After forward pass GRSq 0.931 RSq 0.963 Prune backward penalty 2 nprune null: selected 3 of 4 terms, and 1 of 1 preds After pruning pass GRSq 0.949 RSq 0.962 summary: Formula=VolNeg + Volume ~ Girth (nresponses=2) Call: earth(formula=formula, data=data, subset=subset, keepxy=TRUE, trace=1) VolNeg Volume (Intercept) -5.4611150 28.766764 h(13.8-Girth) 0.4054536 -3.427802 h(Girth-13.8) -0.4767735 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV RSS GRSq RSq VolNeg 0.1143809 2.494241 0.9450989 0.9587632 Volume 14.2014480 309.683189 0.9491370 0.9617962 All 14.3158289 312.177431 0.9491070 0.9617737 evimp: Formula=VolNeg + Volume ~ Girth (nresponses=2) nsubsets gcv rss Girth 2 267.0> 7854.4> plotmo: Formula=VolNeg + Volume ~ Girth (nresponses=2) ------------------------------------------------------------------------------- Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV RSS GRSq RSq VolNeg 0.1143809 2.494241 0.9450989 0.9587632 Volume 14.2014480 309.683189 0.9491370 0.9617962 All 14.3158289 312.177431 0.9491070 0.9617737 > show.earth.Formula(Volume+VolNeg+SinVol~., nresponses=3) Formula=Volume + VolNeg + SinVol ~ . (nresponses=3) Using class "Formula" because lhs of formula has terms separated by "+" x[31,2] with colnames Girth Height y[31,3] with colnames Volume VolNeg SinVol Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00087) After forward pass GRSq 0.947 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 summary: Formula=Volume + VolNeg + SinVol ~ . (nresponses=3) Call: earth(formula=formula, data=data, subset=subset, keepxy=TRUE, trace=1) Volume VolNeg SinVol (Intercept) 29.0599535 -5.4935391 1.05004721 h(14.2-Girth) -3.4198062 0.3964215 -0.11150531 h(Girth-14.2) 6.2295143 -0.4313910 -0.10110737 h(Height-75) 0.5813644 -0.0529614 -0.00102027 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 RSS GRSq RSq Volume 11.2543915 209.113855 0.9596919 0.9742028 VolNeg 0.0885223 1.644801 0.9575107 0.9728068 SinVol 0.0219274 0.407425 0.5424106 0.7071428 All 11.3648412 211.166081 0.9596047 0.9741470 evimp: Formula=Volume + VolNeg + SinVol ~ . (nresponses=3) nsubsets gcv rss Girth 3 100.0 100.0 Height 1 10.7 11.5 plotmo: Formula=Volume + VolNeg + SinVol ~ . (nresponses=3) plotmo grid: Girth Height 12.9 76 plotmo grid: Girth Height 12.9 76 plotmo grid: Girth Height 12.9 76 ------------------------------------------------------------------------------- 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 RSS GRSq RSq Volume 11.2543915 209.113855 0.9596919 0.9742028 VolNeg 0.0885223 1.644801 0.9575107 0.9728068 SinVol 0.0219274 0.407425 0.5424106 0.7071428 All 11.3648412 211.166081 0.9596047 0.9741470 > show.earth.formula(VolNeg+SinVol~randx, nresponses=2) # intercept only model formula=VolNeg + SinVol ~ randx (nresponses=2) Using class "Formula" because lhs of formula has terms separated by "+" x[31,1] with colname randx, and values 0, 1, 0, 1, 0, 1, 0, 1, 0, 1,... y[31,2] with colnames VolNeg SinVol Forward pass term 1, 2, 4 RSq changed by less than 0.001 at 3 terms, 2 terms used (DeltaRSq 0) After forward pass GRSq -0.328 RSq 0.003 Prune backward penalty 2 nprune null: selected 1 of 2 terms, and 0 of 1 preds After pruning pass GRSq 0 RSq 0 summary: formula=VolNeg + SinVol ~ randx (nresponses=2) Call: earth(formula=formula, data=data, subset=subset, keepxy=TRUE, trace=1) VolNeg SinVol (Intercept) -5.312232 0.746683 Selected 1 of 2 terms, and 0 of 1 predictors Termination condition: RSq changed by less than 0.001 at 2 terms Importance: randx-unused Number of terms at each degree of interaction: 1 (intercept only model) GCV RSS GRSq RSq VolNeg 2.08339943 60.485790 0 0 SinVol 0.04791933 1.391206 0 0 All 2.13131876 61.876996 0 0 evimp: formula=VolNeg + SinVol ~ randx (nresponses=2) nsubsets gcv rss plotmo: formula=VolNeg + SinVol ~ randx (nresponses=2) ------------------------------------------------------------------------------- Selected 1 of 2 terms, and 0 of 1 predictors Termination condition: RSq changed by less than 0.001 at 2 terms Importance: randx-unused Number of terms at each degree of interaction: 1 (intercept only model) GCV RSS GRSq RSq VolNeg 2.08339943 60.485790 0 0 SinVol 0.04791933 1.391206 0 0 All 2.13131876 61.876996 0 0 > # TODO following should say "invalid formula: too many terms on the left hand side", but at least it gives an error message > expect.err(try(earth(Volume+VolNeg|99~Girth+Height, data=trees, trace=1)), "multiple parts on left side of formula (because \"|\" was used)") Using class "Formula" because lhs of formula has terms separated by "+" Error : multiple parts on left side of formula (because "|" was used) Got error as expected from try(earth(Volume + VolNeg | 99 ~ Girth + Height, data = trees, trace = 1)) > expect.err(try(earth(Volume+VolNeg~Girth+Height|Volume, data=trees, trace=1)), "multiple parts on right side of formula (because \"|\" was used)") Using class "Formula" because lhs of formula has terms separated by "+" Error : multiple parts on right side of formula (because "|" was used) Got error as expected from try(earth(Volume + VolNeg ~ Girth + Height | Volume, data = trees, trace = 1)) > a1 <- earth(Volume+VolNeg~Girth+(Height|Volume), data=trees, trace=1) # ok, because | is in () (and earth will use formula, not Formula) Using class "Formula" because lhs of formula has terms separated by "+" x[31,2] with colnames Girth Height|VolumeTRUE y[31,2] with colnames Volume VolNeg Forward pass term 1, 2, 4 RSq changed by less than 0.001 at 3 terms (DeltaRSq 0.00011) After forward pass GRSq 0.940 RSq 0.962 Prune backward penalty 2 nprune null: selected 3 of 3 terms, and 1 of 2 preds After pruning pass GRSq 0.949 RSq 0.961 > stopifnot(NCOL(a1$coefficients) == 2) > a2 <- earth(Volume+VolNeg~Girth+I(Height|Volume), data=trees, trace=1) # ok, because | is in I() Using class "Formula" because lhs of formula has terms separated by "+" x[31,2] with colnames Girth I(Height|Volume)TRUE y[31,2] with colnames Volume VolNeg Forward pass term 1, 2, 4 RSq changed by less than 0.001 at 3 terms (DeltaRSq 0.00011) After forward pass GRSq 0.940 RSq 0.962 Prune backward penalty 2 nprune null: selected 3 of 3 terms, and 1 of 2 preds After pruning pass GRSq 0.949 RSq 0.961 > stopifnot(NCOL(a2$coefficients) == 2) > a3 <- earth((Volume+VolNeg)~Girth+Height, data=trees, trace=1) # ok, earth will build a single response model x[31,2] with colnames Girth Height y[31,1] with colname (Volume+VolNeg), and values 7.091, 7.091, 7.006, 12.35, 1... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00097) After forward pass GRSq 0.946 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.959 RSq 0.974 > stopifnot(NCOL(a3$coefficients) == 1) > # TODO it's a pity the following don't work > expect.err(try(earth(Volume+VolNeg*999~., data=trees, trace=1)), "invalid model formula in ExtractVars") # use Formula Using class "Formula" because lhs of formula has terms separated by "+" Error in terms.formula(paste_formula(NULL, attr(Formula, "lhs"), rsep = "+")) : invalid model formula in ExtractVars Got error as expected from try(earth(Volume + VolNeg * 999 ~ ., data = trees, trace = 1)) > expect.err(try(earth(Volume+VolNeg/99+SinVol~., data=trees, trace=1)), "invalid model formula in ExtractVars") # use Formula Using class "Formula" because lhs of formula has terms separated by "+" Error in terms.formula(paste_formula(NULL, attr(Formula, "lhs"), rsep = "+")) : invalid model formula in ExtractVars Got error as expected from try(earth(Volume + VolNeg/99 + SinVol ~ ., data = trees, trace = 1)) > > library(earth) > data(ozone1) > > a10 <- earth(cbind(log.O3=log(O3),wind) ~ ., data=ozone1, trace=1) # ok x[330,8] with colnames vh humidity temp ibh dpg ibt vis doy y[330,2] with colnames log.O3 wind Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.308 RSq 0.436 Prune backward penalty 2 nprune null: selected 12 of 17 terms, and 6 of 8 preds After pruning pass GRSq 0.338 RSq 0.424 > a11 <- earth(log(O3) + wind ~ ., data=ozone1, trace=1) # wrong Using class "Formula" because lhs of formula has terms separated by "+" x[330,9] with colnames `log(O3)` vh humidity temp ibh dpg ibt vis doy y[330,2] with colnames `log(O3)` wind Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.338 RSq 0.468 Prune backward penalty 2 nprune null: selected 10 of 18 terms, and 5 of 9 preds After pruning pass GRSq 0.377 RSq 0.443 > # TODO the following fails, it puts log(O3) on both sides of the formula > try(stopifnot(all.equal(as.vector(a10$coefficients), as.vector(a11$coefficients)))) Error : as.vector(a10$coefficients) and as.vector(a11$coefficients) are not equal: Numeric: lengths (24, 20) differ > > a1 <- earth(cbind(log.O3=log(O3),wind) ~ humidity+temp, data=ozone1) > options(warn=2) > expect.err(try(coef(a1)), "coef.earth: multiple response model: returning coefficients for just the first response") Error : (converted from warning) coef.earth: multiple response model: returning coefficients for just the first response Got error as expected from try(coef(a1)) > a2 <- earth(cbind(log(O3),wind) ~ humidity+temp, data=ozone1) > stopifnot(all.equal(as.vector(a2$coefficients), as.vector(a1$coefficients))) > log.O3 <- log(ozone1$O3) > a3 <- earth(cbind(log.O3,wind) ~ humidity+temp, data=ozone1) > stopifnot(all.equal(as.vector(a3$coefficients), as.vector(a1$coefficients))) > a4 <- earth(log.O3+wind ~ humidity+temp, data=ozone1) > stopifnot(all.equal(as.vector(a4$coefficients), as.vector(a1$coefficients))) > a5 <- earth(log(O3)+wind ~ humidity+temp, data=ozone1) > stopifnot(all.equal(as.vector(a5$coefficients), as.vector(a1$coefficients))) > > # multiple responses, mixed factors and numeric > data(etitanic) > pclass.age <- earth(pclass+age~sibsp, data=etitanic) > plot(pclass.age, nresponse=4) > par(mfrow=c(2,2)) > options(warn=2) > cat("plotmo(pclass.age, nresponse=1):\n") plotmo(pclass.age, nresponse=1): > plotmo(pclass.age, nresponse=1, main="nresponse=1, pclass1st", do.par=FALSE) > cat("plotmo(pclass.age, nresponse=2):\n") plotmo(pclass.age, nresponse=2): > plotmo(pclass.age, nresponse=2, main="nresponse=2, pclass2nd", do.par=FALSE) > cat("plotmo(pclass.age, nresponse=3):\n") plotmo(pclass.age, nresponse=3): > plotmo(pclass.age, nresponse=3, main="nresponse=3, pclass3rd", do.par=FALSE) > cat("plotmo(pclass.age, nresponse=4):\n") plotmo(pclass.age, nresponse=4): > plotmo(pclass.age, nresponse=4, main="nresponse=4, age", do.par=FALSE) > cat("plotmo(pclass.age, nresponse=5):\n") plotmo(pclass.age, nresponse=5): > expect.err(try(plotmo(pclass.age, nresponse=5, main="nresponse=5", do.par=FALSE)), "nresponse is 5 but the number of columns is only 4") Error : nresponse is 5 but the number of columns is only 4 Got error as expected from try(plotmo(pclass.age, nresponse = 5, main = "nresponse=5", do.par = FALSE)) > > age.pclass <- earth(age+pclass~sibsp, data=etitanic) > par(mfrow=c(2,2)) > options(warn=2) > cat("plotmo(age.pclass, nresponse=1):\n") plotmo(age.pclass, nresponse=1): > plotmo(age.pclass, nresponse=1, main="nresponse=1, age", do.par=FALSE, trace=1) object created with Formula (not formula): using attr(terms, "Formula") stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) object created with Formula (not formula): using attr(terms, "Formula") object created with Formula (not formula): using attr(terms, "Formula") got model response from model.frame(age+pclass~sibsp, data=call$data, na.action="na.fail") > cat("plotmo(age.pclass, nresponse=2):\n") plotmo(age.pclass, nresponse=2): > plotmo(age.pclass, nresponse=2, main="nresponse=2, pclass1st", do.par=FALSE) > cat("plotmo(age.pclass, nresponse=3):\n") plotmo(age.pclass, nresponse=3): > plotmo(age.pclass, nresponse=3, main="nresponse=3, pclass2nd", do.par=FALSE) > cat("plotmo(age.pclass, nresponse=4):\n") plotmo(age.pclass, nresponse=4): > plotmo(age.pclass, nresponse=4, main="nresponse=4, pclass3rd", do.par=FALSE) > cat("plotmo(age.pclass, nresponse=5):\n") plotmo(age.pclass, nresponse=5): > expect.err(try(plotmo(age.pclass, nresponse=5, main="nresponse=5", do.par=FALSE)), "nresponse is 5 but the number of columns is only 4") Error : nresponse is 5 but the number of columns is only 4 Got error as expected from try(plotmo(age.pclass, nresponse = 5, main = "nresponse=5", do.par = FALSE)) > > pclass.sex <- earth(pclass+sex~sibsp, data=etitanic) > par(mfrow=c(2,2)) > options(warn=2) > cat("plotmo(pclass.sex, nresponse=1):\n") plotmo(pclass.sex, nresponse=1): > plotmo(pclass.sex, nresponse=1, main="nresponse=1, pclass1st", do.par=FALSE, trace=1) object created with Formula (not formula): using attr(terms, "Formula") stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) object created with Formula (not formula): using attr(terms, "Formula") object created with Formula (not formula): using attr(terms, "Formula") got model response from model.frame(pclass+sex~sibsp, data=call$data, na.action="na.fail") > cat("plotmo(pclass.sex, nresponse=2):\n") plotmo(pclass.sex, nresponse=2): > plotmo(pclass.sex, nresponse=2, main="nresponse=2, pclass2nd", do.par=FALSE) > cat("plotmo(pclass.sex, nresponse=3):\n") plotmo(pclass.sex, nresponse=3): > plotmo(pclass.sex, nresponse=3, main="nresponse=3, pclass3rd", do.par=FALSE) > cat("plotmo(pclass.sex, nresponse=4):\n") plotmo(pclass.sex, nresponse=4): > plotmo(pclass.sex, nresponse=4, main="nresponse=4, age", do.par=FALSE) > cat("plotmo(pclass.sex, nresponse=5):\n") plotmo(pclass.sex, nresponse=5): > expect.err(try(plotmo(pclass.sex, nresponse=5, main="nresponse=5", do.par=FALSE)), "nresponse is 5 but the number of columns is only 4") Error : nresponse is 5 but the number of columns is only 4 Got error as expected from try(plotmo(pclass.sex, nresponse = 5, main = "nresponse=5", do.par = FALSE)) > > source("test.epilog.R") earth/inst/slowtests/test.earthc.bat0000755000176200001440000000364713447225172017341 0ustar liggesusers@rem test.earthc.bat: @rem @rem This tests the earth C code. It does this: builds test.earthc.exe @rem (under Microsoft C), runs it, and compares results to test.earthc.out.save @rem You need to make Rdll.lib first -- see instructions in gnuwin32/README.packages @rem You will need to tweak this file and test.earthc.mak for your directories @rem @rem Stephen Milborrow Mar 2007 Forden, Wales @echo test.earthc.bat @set CYGWIN=nodosfilewarning @cp "d:/bin/R320dll/i386/R.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Rblas.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Riconv.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Rgraphapp.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Rzlib.dll" . @if %errorlevel% neq 0 goto error @rem you may have to create Rdll.lib and Rblas.lib beforehand @cp "../../.#/Rdll.lib" . @if %errorlevel% neq 0 goto error @cp "../../.#/Rblas.lib" . @if %errorlevel% neq 0 goto error @rem get iconv.dll from /a/r/ra/src/gnuwin32/unicode @cp "../../.#/Rdll.lib" . @if %errorlevel% neq 0 goto error @md Debug @md Release @rem @nmake -nologo CFG=Release -f test.earthc.mak @rem The Debug build gives slightly different output in lower decimal places (TODO why?) @rem The advantage of using Debug is that memory leaks are reported. @rem It is much slower though. @nmake -nologo CFG=Debug -f test.earthc.mak @if %errorlevel% equ 0 goto good @echo error: errorlevel %errorlevel% @exit /B %errorlevel% :good @rm -f R.dll Rblas.dll Rdll.lib Rblas.lib iconv.dll Riconv.dll Rgraphapp.dll Rzlib.dll @rm -f test.earthc.main.exe test.earthc.main.map test.earthc.main.ilk *.pdb @rm -rf Debug @rm -rf Release earth/inst/slowtests/test.earthc.mak0000644000176200001440000000553413514230362017325 0ustar liggesusers# test.earthc.mak: makefile for test.earthc.main.exe with Microsoft Visual C 6.0 # This builds the executable, runs it, then diffs the results against the reference. all: test.earthc.out R_DIR="%ProgramFiles%\r\R-3.6.1" INCL=-I$(R_DIR)\src\include -I. # Use PROF_FLAGS if you want to do profiling using profile, prep and plist # Note: Don't use -Zi and -debug flags below if you want to do profiling # PROF_FLAGS=-map -mapinfo:exports -mapinfo:fixups -mapinfo:lines -fixed:no PROF_FLAGS= !IF "$(CFG)" != "Release" && "$(CFG)" != "Debug" !MESSAGE Invalid configuration "$(CFG)" specified. Use "nmake CFG=Debug" or "nmake CFG=Release". Defaulting to CFG=Debug. CFG=Debug !ENDIF !IF "$(CFG)" == "Release" # Fast version (note: I tried -Ox but it appears no faster than -O2 for this code) # -02 is for fast code OUTDIR=Release CFLAGS=-nologo -DSTANDALONE $(RELEASE_BUILD_CFLAGS) -TP -O2 -W3 -MT $(INCL) -Fp$(OUTDIR)\vc60.PCH -Fo"$(OUTDIR)/" -c LFLAGS=-nologo $(RELEASE_BUILD_LFLAGS) $(PROF_FLAGS) # To build Rdll.libs see instructions in gnuwin32\README.packages LIBS=Rdll.lib Rblas.lib !ENDIF !IF "$(CFG)" == "Debug" # Debugging version # -Tp says treat the file as a C++ file (needed for C99 source files) # -Zi is for a debugging build # -W3 is warning level 3 # -MTd is for the multi threaded static debugging runtime library # -Gr is for fast function calling (can't use because conflicts with GSL lib) # No need to define _DEBUG, compiler does it for us if -MTd flag is used OUTDIR=Debug # TODO We use -MDd instead of -MTd here. It seems to work just as well. # Using -Mtd causes linker error: LIBCMTD.lib(sprintf.obj) : error LNK2005: _sprintf already defined in Rdll.lib(R.dll) # CFLAGS=-nologo -DSTANDALONE -TP -Zi -W3 -MTd $(INCL) -Fp$(OUTDIR)\vc60.PCH -Fo"$(OUTDIR)/" -c CFLAGS=-nologo -DSTANDALONE -TP -Zi -W3 -MDd $(INCL) -Fp$(OUTDIR)\vc60.PCH -Fo"$(OUTDIR)/" -c LFLAGS=-nologo -debug # To build Rdll.libs see instructions in gnuwin32\README.packages LIBS=Rdll.lib Rblas.lib !ENDIF OBJ=$(OUTDIR)\earth.obj $(OUTDIR)\test.earthc.obj .c{$(OUTDIR)}.obj:: cl $(CFLAGS) $< clean: rm -f test.earthc.main.exe $(OUTDIR)/*.obj $(OUTDIR)/*.out $(OUTDIR)/*.pch *.pdb *.dll *.map *.ilk test.earthc.main.exe: $(OBJ) link $(LFLAGS) -out:test.earthc.main.exe $(OBJ) $(LIBS) # we use diff -w below so \r\n is treated the same as \n test.earthc.out: test.earthc.main.exe test.earthc.out.save @rem following is so we can check the compiler version because it can affect the model -cl 1> NUL 2> $(OUTDIR)\test.earthc.out test.earthc.main.exe >> $(OUTDIR)\test.earthc.out !IF "$(CFG)" == "Debug" @rem @echo === Following diff may give some differences === !ENDIF diff -w $(OUTDIR)\test.earthc.out test.earthc.out.save $(OUTDIR)/earth.obj: ..\..\src\earth.c test.earthc.mak cl $(CFLAGS) ..\..\src\earth.c $(OUTDIR)/test.earthc.obj: test.earthc.c ..\..\src\earth.c test.earthc.mak earth/inst/slowtests/test.varmod.bat0000755000176200001440000000153213514230362017342 0ustar liggesusers@rem test.varmod.bat @rem Stephen Milborrow Dec 2014 Shrewsbury @echo test.varmod.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.varmod.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.varmod.Rout: @echo. @tail test.varmod.Rout @echo test.varmod.R @exit /B 1 :good1 mks.diff test.varmod.Rout test.varmod.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.varmod.save.ps @exit /B 1 :good2 @rem test.varmod.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.varmod.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.varmod.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.earthmain.vc.bat0000755000176200001440000000372113514230362020433 0ustar liggesusers@rem test.earthmain.bat: test the standalone earth.c with main() @rem @rem Stephen Milborrow Apr 2007 Petaluma @echo test.earthmain.vc.bat @set CYGWIN=nodosfilewarning @cp "d:/bin/R320dll/i386/R.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Rblas.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Riconv.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Rgraphapp.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Rzlib.dll" . @if %errorlevel% neq 0 goto error @rem you may have to create Rdll.lib and Rblas.lib beforehand @cp "../../.#/Rdll.lib" . @if %errorlevel% neq 0 goto error @cp "../../.#/Rblas.lib" . @if %errorlevel% neq 0 goto error @rem get iconv.dll from /a/r/ra/src/gnuwin32/unicode @cp "../../.#/Rdll.lib" . @if %errorlevel% neq 0 goto error @md Debug @rem Use -W4 (insteadof -W3) for lint like warnings cl -nologo -DSTANDALONE -DMAIN -TP -Zi -W3 -MDd -I"%ProgramFiles%\r\R-3.6.1"\src\include -I. -FpDebug\vc60.PCH -Fo"Debug/" -c ..\..\src\earth.c @if %errorlevel% neq 0 goto error link -nologo -debug -out:earthmain.exe Debug\earth.obj Rdll.lib Rblas.lib @if %errorlevel% neq 0 goto error earthmain.exe > Debug\test.earthmain.out @rem no errorlevel test, diff will do check for discrepancies @rem @if %errorlevel% neq 0 goto error mks.diff Debug\test.earthmain.out test.earthmain.out.save @if %errorlevel% neq 0 goto error @rm -f R.dll Rblas.dll Rdll.lib Rblas.lib iconv.dll Riconv.dll Rgraphapp.dll Rzlib.dll earthmain.exe *.map *.ilk *.pdb @rm -rf Debug @exit /B 0 :error @exit /B %errorlevel% earth/inst/slowtests/test.cv.R0000644000176200001440000003342313445510507016123 0ustar liggesusers# test.cv.R: test earth cross validation source("test.prolog.R") source("check.models.equal.R") library(earth) data(ozone1) data(trees) data(etitanic) options(width=200) printh <- function(x, expect.warning=FALSE, max.print=0) # like print but with a header { cat("===", deparse(substitute(x))) if(expect.warning) cat(" expect warning -->") else if (NROW(x) > 1) cat("\n") if (max.print > 0) print(head(x, n=max.print)) else print(x) } # print contents of earth.model, for sanity checking that all fields are present as usual # but strip big fields to reduce amount of printing print.stripped.earth.model <- function(earth.mod, model.name) { earth.mod$bx <- NULL earth.mod$fitted.values <- NULL earth.mod$residuals <- NULL earth.mod$rss <- NULL cat("print.stripped.earth.model(", model.name, ")\n", sep="") print.default(earth.mod) cat("-------------------------------------------------------------------------------\n\n") } cat("a0: trees\n\n") set.seed(23) a0 <- earth(Volume ~ ., data = trees, trace=0.5, nfold=3) printh(a0$cv.rsq.tab) printh(a0) printh(summary(a0)) print.stripped.earth.model(a0, "a0") cat("a0a: trees with matrix interface\n\n") set.seed(23) a0a <- earth(trees[,-3], trees[,3], trace=0, nfold=3) stopifnot(!identical(a0$cv.rsq.tab, a0a$cv.rsq.tab)) printh(a0a) printh(summary(a0a)) print.stripped.earth.model(a0a, "a0a") cat("a1: trees with trace enabled\n\n") set.seed(1) a1 <- earth(Volume ~ ., data = trees, trace=1, nfold=3) stopifnot(!identical(a0$cv.rsq.tab, a1$cv.rsq.tab)) printh(a1) printh(summary(a1)) # test correct operation of update cat("a2 <- update(a0) # should do cv\n") set.seed(2) a2 <- update(a0) cat("a3 <- update(a0) # should do cv\n") set.seed(3) a3 <- update(a0, formula=Volume~.-Height) printh(a3$cv.rsq.tab) printh(a3) printh(summary(a3)) cat("a4 <- update(a0, nfold=0, trace=.5) # should not do cv\n") set.seed(4) a4 <- update(a0, nfold=0, trace=.5) cat("a5 <- update(a4, trace=.5) # should not do cv\n") set.seed(5) a5 <- update(a4) cat("a5a <- update(a4, nfold=2, trace=.5) # should do cv\n") set.seed(2) a5a <- update(a4, nfold=2, trace=.5) cat("a6: titanic data, one logical response\n\n") survived. <- as.logical(etitanic$survived) set.seed(6) a6 <- earth(survived. ~ ., data=etitanic[,-2], degree=2, glm=list(family="binomial"), trace=0.5, ncross=2, nfold=3) printh(a6) printh(summary(a6)) plotmo(a6) printh(a6$cv.list[[2]]) printh(summary(a6$cv.list[[2]])) print.stripped.earth.model(a6, "a6") cat("a6a: stratify=FALSE\n\n") set.seed(6) a6a <- earth(survived. ~ ., data=etitanic[,-2], degree=2, glm=list(family="binomial"), trace=0.5, nfold=3, stratify=FALSE, keepxy=TRUE) printh(a6a) printh(summary(a6a)) plot(a6a, main="a6a (stratify=FALSE)", which=1, col.oof.labs=1) cat("a7: titanic data, multiple responses (i.e. 3 level factor)\n\n") set.seed(3) # keepxy is needed for summary and plotmo of resmodels a7 <- earth(pclass ~ ., data=etitanic, degree=2, glm=list(family="binomial"), trace=1, ncross=2, nfold=3, keepxy=TRUE) printh(a7) plot(a7, nresponse=1) print.stripped.earth.model(a7, "a7") printh(summary(a7)) plotmo(a7, nresponse=1) printh(a7$cv.list[[3]]) printh(summary(a7$cv.list[[3]])) plot(a7, main="a7 (multiple response model)", which=1, nresponse=1) cat("a7.wp: as above but with wp parameter\n\n") set.seed(3) a7.wp <- earth(pclass ~ ., data=etitanic, degree=2, glm=list(family="binomial"), trace=0.5, nfold=3, wp=c(1,3,1)) printh(a7.wp) printh(summary(a7.wp)) print.stripped.earth.model(a7.wp, "a7.wp") # poisson models counts <- c(18, 17, 15, 20, 10, 20, 25, 13, 12, 18+2,17+2,15+2,20+2,10+2,20+2,25+2,13+2,12+2, 18+3,17+3,15+3,20+3,10+3,20+3,25+3,13+3,12+3, 18+4,17+4,15+4,20+4,10+4,20+4,25+4,13+4,12+4) counts2 <- c(181,171,151,201,101,201,251,131,121, 189,179,159,209,109,209,259,139,121, 185,175,155,205,105,205,255,135,125, 183,173,153,203,103,203,253,133,123) outcome <- gl(3,1,4*9) treatment <- gl(3,4*3) d.AD <- data.frame(treatment, outcome, counts, counts2) # one response poisson model cat("a8p: one response poisson model\n\n") set.seed(1236) a8p <- earth(counts ~ outcome + treatment, glm=list(family=poisson()), trace=0.5, pmethod="none", nfold=3) printh(a8p) printh(summary(a8p)) print.stripped.earth.model(a8p, "a8p") # two response poisson model cat("a10: two response poisson model\n\n") set.seed(1237) a10 <- earth(cbind(counts, counts2) ~ outcome + treatment, glm=list(fam="po"), trace=0.5, pmethod="none", nfold=3) printh(a10) printh(summary(a10)) print.stripped.earth.model(a10, "a10") # binomial pair model with keepxy set.seed(2019) bpair.mod <- earth(cbind(counts, counts2) ~ outcome + treatment, glm=list(fam="quasib"), trace=1, pmethod="none", nfold=3, keepxy=TRUE) print(summary(bpair.mod)) plot(bpair.mod, which=1, main="bpair.mod") bpair.data <- data.frame(counts, counts2, outcome, treatment) set.seed(2019) bpair.mod.Formula <- earth(counts+counts2 ~ outcome + treatment, data=bpair.data, glm=list(fam="quasib"), trace=1, pmethod="none", nfold=3, keepxy=TRUE) print(summary(bpair.mod.Formula)) plot(bpair.mod.Formula, which=1, main="bpair.mod.Formula") check.models.equal(bpair.mod, bpair.mod.Formula, "bpair.mod, bpair.mod.Formula", newdata=bpair.data[1:3,]) set.seed(427) earth.mod.err <- earth(survived~., data=etitanic, degree=1, nfold=3, keepxy=FALSE) expect.err(try(plot(earth.mod.err$cv.list[[1]])), "cannot get the original model response") # test plot.earth with cross-validated models (example from help page) set.seed(427) earth.mod.help <- earth(survived~., data=etitanic, trace=1, degree=2, nfold=5, keepxy=TRUE) print.stripped.earth.model(earth.mod.help, "earth.mod.help") plot(earth.mod.help) # the full model # test various options old.par <- par(mfrow=c(2,2), mar=c(4, 3.2, 3, 3), mgp=c(1.6, 0.6, 0), par(cex = 0.8)) plot(earth.mod.help, which=1, main="plot.model.selection\ncol.oof.rsq=c(\"red\", \"green\")", col.oof.rsq=c("red", "green"), do.par=F) plot(earth.mod.help, which=1, col.oof.rsq=0, col.npreds="gray", lty.npreds=1, main="col.oof.rsq=0 col.npreds=gray", do.par=F) plot(earth.mod.help, which=1, main="col.infold.rsq=lightblue", col.grsq = 0, col.rsq = NA, col.vline = 0, col.oof.vline = 0, col.mean.infold.rsq="blue", col.infold.rsq="lightblue", col.mean.oof.rsq="red", col.oof.rsq="pink", col.pch.max.oof.rsq="purple", col.pch.cv.rsq=1, do.par=F, legend.pos=c(5,0.32)) # expect Warning: cannot plot cross-validation data because keepxy not set in original call to earth a0 <- earth(Volume ~ ., data = trees, nfold=2) plot(a0, col.oof.rsq="pink", which=1, do.par=F) par(old.par) # test plot.earth.models with cross-validated models set.seed(428) earth.mod <- earth(survived ~ ., data=etitanic, nfold=3, keepxy=TRUE) plot.earth.models(earth.mod$cv.list, main="plot.earth.models with cross validated models") # test keepxy=2 expect.err(try(plot(earth.mod.help$cv.list[[3]])), "cannot get the original model response (use keepxy=2 in the call to earth)") expect.err(try(plotmo(earth.mod.help$cv.list[[3]])), "cannot get the original model predictors (use keepxy=2 in the call to earth)") set.seed(2019) earth.mod.help.keepxy2 <- earth(survived~., data=etitanic, nfold=3, keepxy=2) plot(earth.mod.help.keepxy2$cv.list[[3]]) plotmo(earth.mod.help.keepxy2$cv.list[[3]]) # example in earth vignette library(bootstrap) # just for the "scor" data set.seed(2) # for fold reproducibility, not strictly necessary data(scor) data <- data.frame(y=scor[,3], # didactic canonical data frame x1=scor[,1], x2=scor[,2], x3=scor[,4], x4=scor[,5]) # Build an earth model with cross validation. Note that keepxy=TRUE # to retain the cross-validation data for further processing. mod <- earth(y~., data=data, nfold=5, keepxy=TRUE) plot(mod, which=1, col.rsq=0, caption="Cross Validated Models") print(mod$cv.oof.rsq.tab, digits=2) # out-of-fold R-Squareds # Use the cross-validation results to select the optimum number-of-terms. # This is the number of terms that gave the max mean RSq on the out-of-fold # data, as displayed by the vertical dotted red line in the graph. # (This is criterion (ii) in the next section. There are other approaches.) mean.oof.rsq.per.subset <- mod$cv.oof.rsq.tab[nrow(mod$cv.oof.rsq.tab),] nterms.selected.by.cv <- which.max(mean.oof.rsq.per.subset) cat("\nnterms selected by GCV (standard earth model):", length(mod$selected.terms), "\nnterms selected by CV: ", nterms.selected.by.cv, "\n") # Rebuild the earth model with the desired number of terms (and using # all the data). # The penalty=-1 tells earth to ignore the GCV (otherwise earth's usual # selection-by-min-GCV may return a smaller model than the given nprune). mod.cv <- earth(y~., data=data, nprune=nterms.selected.by.cv, penalty=-1) # Test cross validation when calling earth from within a function formula.global <- Volume ~ . data.global <- trees weights.global <- rep(1, length.out=nrow(trees)) weights.global[1] <- 2 lm.weights.local1 <- function() { weights.local <- rep(1, length.out=nrow(trees)) weights.local[1] <- 2 lm(formula=Volume ~ ., data=trees, weights=weights.local) } cat("\n--lm.weights.local1\n") print(summary(lm.weights.local1())) earth.weights.local2 <- function() { weights.local <- rep(1, length.out=nrow(trees)) weights.local[1] <- 2 earth(formula=Volume ~ ., data=trees, linpreds=TRUE, weights=weights.local) } cat("\n--earth.weights.local2\n") print(summary(earth.weights.local2())) lm.weights.local2 <- function(){ weights.local <- rep(1, length.out=nrow(trees)) weights.local[1] <- 2 lm(formula=formula.global, data=data.global, weights=weights.local) } cat("\n--lm.weights.local2\n") try(lm.weights.local2()) # fails: object 'weights.local' not found earth.weights.local2 <- function(){ weights.local <- rep(1, length.out=nrow(trees)) weights.local[1] <- 2 earth(formula=formula.global, data=data.global, linpreds=TRUE, weights=weights.local) } cat("\n--earth.weights.local2\n") try(earth.weights.local2()) # fails: object 'weights.local' not found, so does lm (see lm.weights.local2 above) #--- cross validation tests earth.cv.1 <- function() { set.seed(2017) earth(formula=Volume ~ ., data=trees, weights=weights.global, linpreds=TRUE, nfold=3) } cat("\n--earth.cv.1\n") print(earth.cv.1()) earth.cv.2 <- function() { weights.local <- rep(1, length.out=nrow(trees)) weights.local[1] <- 2 set.seed(2017) earth(formula=Volume ~ ., data=trees, weights=weights.local, linpreds=TRUE, nfold=3) } cat("\n--earth.cv.2\n") print(earth.cv.2()) earth.cv.3 <- function(){ set.seed(2017) earth(formula=formula.global, data=data.global, weights=weights.global, linpreds=TRUE, nfold=3) } cat("\n--earth.cv.3\n") print(earth.cv.3()) # earth.cv.4 <- function(){ # fails: object 'weights.local' not found, cf earth.weights.local2 above for simpler example # weights.local <- rep(1, length.out=nrow(trees)) # weights.local[1] <- 2 # set.seed(2017) # earth(formula=formula.global, data=data.global, weights=weights.local, linpreds=TRUE, # nfold=3) # } # cat("\n--earth.cv.4\n") # printt(earth.cv.4()) thresh.global <- .002 earth.cv.1 <- function() { set.seed(2017) earth(formula=Volume ~ ., data=trees, thresh=thresh.global, nfold=3) } cat("\n--earth.cv.1\n") print(earth.cv.1()) earth.cv.2 <- function() { thresh.local <- .002 set.seed(2017) earth(formula=Volume ~ ., data=trees, thresh=thresh.local, nfold=3) } cat("\n--earth.cv.2\n") print(earth.cv.2()) earth.cv.3 <- function(){ set.seed(2017) earth(formula=formula.global, data=data.global, thresh=thresh.global, nfold=3) } cat("\n--earth.cv.3\n") print(earth.cv.3()) earth.cv.4 <- function(){ thresh.local <- .002 set.seed(2017) earth(formula=formula.global, data=data.global, thresh=thresh.local, nfold=3) } cat("\n--earth.cv.4\n") print(earth.cv.4()) earth.cv.5 <- function(){ thresh <- .002 set.seed(2017) earth(formula=formula.global, data=data.global, thresh=thresh, nfold=3) } cat("\n--earth.cv.5\n") print(earth.cv.5()) thresh.global <- .002 earth.cv.1 <- function() { set.seed(2017) earth(formula=Volume ~ ., data=trees, thresh=thresh.global, pmethod="cv", nfold=3) } cat("\n--earth.cv.1\n") print(earth.cv.1()) earth.cv.2 <- function() { # fails thresh.local <- .002 set.seed(2017) a <- earth(formula=Volume ~ ., data=trees, thresh=thresh.local, pmethod="cv", ncross=3, nfold=3, keepxy=TRUE) # plot(a, which=1, ylim=c(.7, 1)) # print(a) a } cat("\n--earth.cv.2\n") print(earth.cv.2()) a <- earth.cv.2() earth.cv.3 <- function(){ set.seed(2017) earth(formula=formula.global, data=data.global, thresh=thresh.global, pmethod="cv", nfold=3) } cat("\n--earth.cv.3\n") print(earth.cv.3()) earth.cv.4 <- function(){ # fails thresh.local <- .002 set.seed(2017) earth(formula=formula.global, data=data.global, thresh=thresh.local, pmethod="cv", nfold=3) } cat("\n--earth.cv.4\n") print(earth.cv.4()) earth.cv.5 <- function(){ # fails thresh <- .002 set.seed(2017) earth(formula=formula.global, data=data.global, thresh=thresh, pmethod="cv", nfold=3) } cat("\n--earth.cv.5\n") a.cv.5 <- earth.cv.5() print(a.cv.5) cat("\n--summary(earth.cv.5)\n") print(summary(a.cv.5)) source("test.epilog.R") earth/inst/slowtests/test.mods.R0000644000176200001440000006355213403043445016457 0ustar liggesusers# test.mods.R: test earth's ability to build various models source("test.prolog.R") library(earth) options(digits=4) SHORTTEST <- TRUE # use TRUE for production testing against test.mods.Rout.save TRACE <- 0 PRINT.DATA <- FALSE FORCE.WEIGHTS <- FALSE # GLOBAL.SEEDS <- 1:10 GLOBAL.SEEDS <- 1 COLLINEAR.TESTS <- TRUE SUMMARY <- FALSE PLOT <- FALSE TIME <- FALSE COMPARE_TO_WEIGHTED_MODEL <- FALSE RANDOMFOREST <- FALSE MARS <- FALSE RPROF <- FALSE if(SHORTTEST) { GLOBAL.SEEDS <- 1 COLLINEAR.TESTS <- FALSE SUMMARY <- FALSE PLOT <- FALSE TIME <- FALSE COMPARE_TO_WEIGHTED_MODEL <- FALSE RANDOMFOREST <- FALSE MARS <- FALSE RPROF <- FALSE } itest <- 0 test.rsqs.global <- nterms.global <- delta.rsqs.global <- nknots.global <- NULL other.rsqs.global <- NULL mars.rsqs.global <- mars.nterms.global <- NULL printf <- function(format, ...) cat(sprint(format, ...)) # like c printf sq <- function(x) x * x sos <- function(x) sum(as.vector(x^2)) # sum of squares test.mod <- function(func, x, xtest, collinear.x2, npreds, nk=NULL, degree=2, ...) { itest <<- itest + 1 # sanity checks stopifnot(collinear.x2 == 0 || collinear.x2 == 1) stopifnot(npreds >= 1, npreds <= 9) stopifnot(nk >= 1, nk <= 201) stopifnot(degree >= 1, degree <= 5) set.seed(1994 + global.seed + itest) x <- x[, 1:npreds, drop=FALSE] y <- func(x) nk <- if(is.null(nk)) min(200, max(20, 2 * ncol(x))) + 1 else nk if(length(GLOBAL.SEEDS) > 1) printf("global.seed %g ", global.seed) printf("TEST %-2g%s n %-3g p %-1g %-16.16s nk %-3g deg %-1g ", itest, if(collinear.x2) " colx2" else "", nrow(x), ncol(x), deparse(substitute(func)), nk, degree) gc() if(TIME) { # system.time adds quite a lot of time overhead (because of its calls to gc) earth.time <- system.time(mod <- earth(x, y, nk=nk, degree=degree, trace=TRACE, Force.weights=FORCE.WEIGHTS, ...)) time.string <- sprint(" [time %5.3f]", earth.time[3]) } else { mod <- earth(x, y, nk=nk, degree=degree, trace=TRACE, Force.weights=FORCE.WEIGHTS, ...) time.string <- "" } ytest <- func(xtest) fitted <- predict(mod, xtest) stopifnot(length(fitted) == nrow(xtest)) test.rsq <- 1 - sos(ytest - fitted) / sos(ytest - mean(ytest)) if(TRACE > 0) printf("TEST %-2g n %-3g p %-1g %-16.16s nk %-2g degree %-2g ", itest, nrow(x), ncol(x), deparse(substitute(func)), nk, degree) if(mod$grsq < .3) { # all bets are off with a very low GRsq test.rsq <- max(-.1, test.rsq) delta.rsq <- test.rsq - max(0, mod$grsq) } else delta.rsq <- test.rsq - mod$grsq extra.msg <- "" if(COMPARE_TO_WEIGHTED_MODEL && !FORCE.WEIGHTS) { # build a weighted model and print a message if significantly different modw <- earth(x, y, nk=nk, degree=degree, trace=TRACE, Force.weights=TRUE, ...) fittedw <- predict(modw, xtest) test.rsqw <- 1 - sos(ytest - fittedw) / sos(ytest - mean(ytest)) deltaw <- test.rsq - test.rsqw extra.msg <- sprint("%s grsqw % 4.2f test.rsqw % 4.2f deltaw % 4.2f%s", extra.msg, modw$grsq, test.rsqw, deltaw, if(abs(deltaw) > .5) "!" else "") } if(RANDOMFOREST) { # build a randomForest model require(randomForest) rf <- randomForest(x, y, ntree=1000) fitted.rf <- predict(rf, xtest) rsq.rf <- 1 - sos(ytest - fitted.rf) / sos(ytest - mean(ytest)) other.rsqs.global <<- c(other.rsqs.global, rsq.rf) delta <- test.rsq - rsq.rf extra.msg <- sprint("%s rsq.rf % 4.2f delta % 4.2f%s", extra.msg, rsq.rf, delta, if(abs(delta) > .5) "!" else "") } if(MARS) { # build an mda::mars model require(mda) mars <- mars(x, y, nk=nk, degree=degree) mars <- mars.to.earth(mars, trace=FALSE) fitted.mars <- predict(mars, xtest) rsq.mars <- 1 - sos(ytest - fitted.mars) / sos(ytest - mean(ytest)) mars.rsqs.global <<- c(mars.rsqs.global, rsq.mars) mars.nterms.global <<- c(mars.nterms.global, length(mars$selected.terms)) delta <- test.rsq - rsq.mars extra.msg <- sprint("%s rsq.mars % 4.2f delta % 4.2f%s", extra.msg, rsq.mars, delta, if(abs(delta) > .5) "!" else "") } printf("nterms %-2g%s grsq % 4.2f test.rsq % 4.2f grsq-test.rsq % 5.2f%s%s%s\n", length(mod$selected.terms), time.string, mod$grsq, test.rsq, delta.rsq, if(delta.rsq < -.3) " baddelta" else "", if(test.rsq < -1) " badtestrsq" else "", extra.msg) test.rsqs.global <<- c(test.rsqs.global, test.rsq) nterms.global <<- c(nterms.global, length(mod$selected.terms)) delta.rsqs.global <<- c(delta.rsqs.global, delta.rsq) nknots.global <<- c(nknots.global, length(unique(as.vector(mod$cuts)))) if(SUMMARY) { print(summary(mod)) printf("\n") } if(PRINT.DATA) { print(cbind(y, x)) printf("\n") } if(PLOT || # following is to always produce a plot so diffps ok in test.mods.bat (!interactive() && itest == 1 && nrow(x) == 100)) { caption <- sprint("TEST %g%s n %d p %d %-.20s nk %g deg %g grsq %.2f test.rsq %.2f", itest, if(collinear.x2) " col.x2" else "", nrow(x), ncol(x), deparse(substitute(func)), nk, degree, mod$grsq, test.rsq) # plotmo(mod, trace=-1, pt.col="red", pt.cex=.8, caption=caption, # cex.caption=if(npreds<=2) .7 else .9) plotmo(mod, trace=-1, pt.col="red", pt.cex=.8, caption=caption, cex.caption=if(npreds<=2) .7 else .9, type2="im") } mod } ran <- function(n) runif(n, -1, 1) # ran <- function(n) 2 * rnorm(n) testn <- function(n, collinear.x2=FALSE) { itest <<- 0 max.ncol <- 10 set.seed(2015 + global.seed + n) x <- matrix(ran(max.ncol * n), ncol=max.ncol) x <- x[order(x[,1]), , drop=FALSE] # sort first column for convenience if(collinear.x2) x[,2] <- x[,1] + .3 * rnorm(nrow(x)) colnames(x) <- paste("x", 1:ncol(x), sep="") xtest <- matrix(ran(max.ncol * 1e4), ncol=max.ncol) if(collinear.x2) xtest[,2] <- xtest[,1] + .3 * rnorm(nrow(xtest)) xtest <- xtest[order(xtest[,1]), , drop=FALSE] colnames(xtest) <- c(paste("x", 1:max.ncol, sep="")) univariate <- function(x) { x[,1] + .3 * rnorm(nrow(x)) } test.mod(univariate, x, xtest, collinear.x2, npreds=1, degree=1) test.mod(univariate, x, xtest, collinear.x2, npreds=2, degree=2) # extra predictor bi <- function(x) { x[,1] + x[,2] + .3 * rnorm(nrow(x)) } test.mod(bi, x, xtest, collinear.x2, npreds=2, degree=1) test.mod(bi, x, xtest, collinear.x2, npreds=2, degree=2) test.mod(bi, x, xtest, collinear.x2, npreds=3, degree=2) # extra predictor bi.interact <- function(x) { x[,1] + x[,2] + (x[,1] * x[,2]) + .3 * rnorm(nrow(x)) } test.mod(bi.interact, x, xtest, collinear.x2, npreds=2, degree=1) test.mod(bi.interact, x, xtest, collinear.x2, npreds=2, degree=2) test.mod(bi.interact, x, xtest, collinear.x2, npreds=3, degree=2) # extra predictor bi.interact2 <- function(x) { x[,1] - x[,2] + (x[,1] * x[,2]) + .3 * rnorm(nrow(x)) } test.mod(bi.interact2, x, xtest, collinear.x2, npreds=2, degree=1) test.mod(bi.interact2, x, xtest, collinear.x2, npreds=2, degree=2) test.mod(bi.interact2, x, xtest, collinear.x2, npreds=3, degree=2) # extra predictor bi.interact3 <- function(x) { x[,1] + x[,2] - .5 * (x[,1] * x[,2]) + .3 * rnorm(nrow(x)) } test.mod(bi.interact3, x, xtest, collinear.x2, npreds=2, degree=1) test.mod(bi.interact3, x, xtest, collinear.x2, npreds=2, degree=2) test.mod(bi.interact3, x, xtest, collinear.x2, npreds=3, degree=2) # extra predictor printf("\n") tri <- function(x) { x[,1] + x[,2] - x[,3] + .1 * rnorm(nrow(x)) } test.mod(tri, x, xtest, collinear.x2, npreds=3, degree=1) test.mod(tri, x, xtest, collinear.x2, npreds=3, degree=2) test.mod(tri, x, xtest, collinear.x2, npreds=4, degree=2) # extra predictor tri.interact <- function(x) { x[,1] - x[,2] + sin(x[,3]) + (x[,1] * x[,2]) + .2 * rnorm(nrow(x)) } test.mod(tri.interact, x, xtest, collinear.x2, npreds=3, degree=1) test.mod(tri.interact, x, xtest, collinear.x2, npreds=3, degree=2) test.mod(tri.interact, x, xtest, collinear.x2, npreds=3, degree=3) # TODO this and next function often cause a negative test.rsq (even though grsq is high) tri.interact2 <- function(x) { x[,1] + x[,2] + sin(x[,3]) - (x[,1] * x[,2]) + .2 * rnorm(nrow(x)) } test.mod(tri.interact2, x, xtest, collinear.x2, npreds=3, degree=1) test.mod(tri.interact2, x, xtest, collinear.x2, npreds=3, degree=2) test.mod(tri.interact2, x, xtest, collinear.x2, npreds=3, degree=3) tri.interact3 <- function(x) { x[,1] - x[,2] + sq(x[,3]) + (x[,1] * x[,2]) + .2 * rnorm(nrow(x)) } test.mod(tri.interact3, x, xtest, collinear.x2, npreds=3, degree=1) test.mod(tri.interact3, x, xtest, collinear.x2, npreds=3, degree=2) test.mod(tri.interact3, x, xtest, collinear.x2, npreds=3, degree=3) tri.two.interacts <- function(x) { x[,1] + x[,2] - sq(x[,3]) + (x[,1] * x[,2]) + sq(x[,1] * sq(x[,3])) + .1 * rnorm(nrow(x)) } test.mod(tri.two.interacts, x, xtest, collinear.x2, npreds=3, degree=1) test.mod(tri.two.interacts, x, xtest, collinear.x2, npreds=3, degree=2) printf("\n") sin.3.x1 <- function(x) { # curve looks like this /\ # \/ sin(3 * x[,1]) } test.mod(sin.3.x1, x, xtest, collinear.x2, npreds=1, nk=51, degree=1) test.mod(sin.3.x1, x, xtest, collinear.x2, npreds=2, nk=51, degree=1) # x2 is noise test.mod(sin.3.x1, x, xtest, collinear.x2, npreds=2, nk=51, degree=2) printf("\n") sin.5.x1 <- function(x) { # curve looks like this \ /\ # \/ \ sin(5 * x[,1]) } test.mod(sin.5.x1, x, xtest, collinear.x2, npreds=1, nk=51, degree=1) test.mod(sin.5.x1, x, xtest, collinear.x2, npreds=2, nk=51, degree=1) # x2 is noise test.mod(sin.5.x1, x, xtest, collinear.x2, npreds=2, nk=51, degree=2) printf("\n") if(n > 30) { sin.5.x1.noise <- function(x) { sin(5 * x[,1]) + .5 * rnorm(nrow(x)) } test.mod(sin.5.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1) test.mod(sin.5.x1.noise, x, xtest, collinear.x2, npreds=2, degree=1) test.mod(sin.5.x1.noise, x, xtest, collinear.x2, npreds=2, degree=2) test.mod(sin.5.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1, nk=51) test.mod(sin.5.x1.noise, x, xtest, collinear.x2, npreds=2, degree=1, nk=51) test.mod(sin.5.x1.noise, x, xtest, collinear.x2, npreds=2, degree=2, nk=51) printf("\n") } if(n > 100) { # need many points because the function is so curvy sin.10.x1 <- function(x) { # curve looks like this \ /\ /\ /\ # (three humps) \/ \/ \/ \ sin(10 * x[,1]) } test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=1, degree=1) test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=2, degree=1) test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=2, degree=2) test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=1, degree=1, nk=51) test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=2, degree=1, nk=51) test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=1, degree=2, nk=51) # even with thresh=0 here we still don't cover all curves, ditto for models below test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=1, degree=1, nk=51, thresh=1e-5) test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=2, degree=1, nk=51, thresh=1e-5) test.mod(sin.10.x1, x, xtest, collinear.x2, npreds=2, degree=2, nk=51, thresh=1e-5) printf("\n") } if(n > 100) { sin.10.x1.noise <- function(x) { sin(10 * x[,1]) + .5 * rnorm(nrow(x)) } test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1) test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=2, degree=1) test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=2, degree=2) test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1, nk=51) test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=2, degree=1, nk=51) test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=1, degree=2, nk=51) test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1, nk=51, thresh=1e-5) test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=2, degree=1, nk=51, thresh=1e-5) test.mod(sin.10.x1.noise, x, xtest, collinear.x2, npreds=2, degree=2, nk=51, thresh=1e-5) printf("\n") } # commented out because need too many cases because the function is so curvy # if(n > 100) { # need many points because the function is so curvy # sin.20.x1 <- function(x) # { # sin(20 * x[,1]) # } # test.mod(sin.20.x1, x, xtest, collinear.x2, npreds=1, degree=1) # test.mod(sin.20.x1, x, xtest, collinear.x2, npreds=1, degree=2) # test.mod(sin.20.x1, x, xtest, collinear.x2, npreds=1, degree=1, nk=51) # test.mod(sin.20.x1, x, xtest, collinear.x2, npreds=1, degree=2, nk=51) # test.mod(sin.20.x1, x, xtest, collinear.x2, npreds=1, degree=1, nk=51, thresh=1e-5) # test.mod(sin.20.x1, x, xtest, collinear.x2, npreds=1, degree=2, nk=51, thresh=1e-5) # printf("\n") # } # if(n > 100) { # need many points because the function is so curvy # sin.20.x1.noise <- function(x) # six humps # { # sin(20 * x[,1]) + .5 * rnorm(nrow(x)) # } # test.mod(sin.20.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1) # test.mod(sin.20.x1.noise, x, xtest, collinear.x2, npreds=1, degree=2) # test.mod(sin.20.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1, nk=51) # test.mod(sin.20.x1.noise, x, xtest, collinear.x2, npreds=1, degree=2, nk=51) # test.mod(sin.20.x1.noise, x, xtest, collinear.x2, npreds=1, degree=1, nk=51, thresh=1e-5) # test.mod(sin.20.x1.noise, x, xtest, collinear.x2, npreds=1, degree=2, nk=51, thresh=1e-5) # printf("\n") # } sin.3.x1.plus.x2 <- function(x) { sin(3 * x[,1]) + x[,2] } test.mod(sin.3.x1.plus.x2, x, xtest, collinear.x2, npreds=2, degree=1) test.mod(sin.3.x1.plus.x2, x, xtest, collinear.x2, npreds=2, degree=2) printf("\n") # TODO this function tends to have the most rsq discrepancies with randomForest models sin.2.x1.times.x2 <- function(x) { sin(2 * x[,1]) * x[,2] } test.mod(sin.2.x1.times.x2, x, xtest, collinear.x2, npreds=2, degree=1) test.mod(sin.2.x1.times.x2, x, xtest, collinear.x2, npreds=2, degree=2) printf("\n") # TODO this and the next function seem to most often cause a big # discrepancy between grsq and test.rsq cos.2.x1.times.x2 <- function(x) # cos(2 * x1) looks like /\ { cos(2 * x[,1]) * x[,2] } test.mod(cos.2.x1.times.x2, x, xtest, collinear.x2, npreds=2, degree=1) test.mod(cos.2.x1.times.x2, x, xtest, collinear.x2, npreds=2, degree=2) printf("\n") cos.2.x1.times.x2.noise <- function(x) { cos(2 * x[,1]) * x[,2] + .3 * rnorm(nrow(x)) } test.mod(cos.2.x1.times.x2.noise, x, xtest, collinear.x2, npreds=2, degree=1) test.mod(cos.2.x1.times.x2.noise, x, xtest, collinear.x2, npreds=2, degree=2) printf("\n") eqn56 <- function(x) # Friedman MARS paper equation 56 (note that this is additive) { 0.1 * exp(4 * x[,1]) + 4 / (1 + exp(-20 * (x[,2] - 0.5))) + 3 * x[,3] + 2 * x[,4] + x[,5] } test.mod(eqn56, x, xtest, collinear.x2, npreds=5, degree=1) test.mod(eqn56, x, xtest, collinear.x2, npreds=5, degree=2) test.mod(eqn56, x, xtest, collinear.x2, npreds=5, degree=3) test.mod(eqn56, x, xtest, collinear.x2, npreds=5, nk=99, degree=1) test.mod(eqn56, x, xtest, collinear.x2, npreds=5, nk=99, degree=2) test.mod(eqn56, x, xtest, collinear.x2, npreds=5, nk=99, degree=3) printf("\n") eqn56.extra.preds <- function(x) { eqn56(x) } test.mod(eqn56.extra.preds, x, xtest, collinear.x2, npreds=9, degree=1) test.mod(eqn56.extra.preds, x, xtest, collinear.x2, npreds=9, degree=2) if(n > 30) test.mod(eqn56.extra.preds, x, xtest, collinear.x2, npreds=9, degree=3) test.mod(eqn56.extra.preds, x, xtest, collinear.x2, npreds=9, degree=1, nk=99) test.mod(eqn56.extra.preds, x, xtest, collinear.x2, npreds=9, degree=2, nk=99) if(n > 30) test.mod(eqn56.extra.preds, x, xtest, collinear.x2, npreds=9, degree=3, nk=99) printf("\n") eqn56.noise <- function(x) { eqn56(x) + rnorm(nrow(x)) } test.mod(eqn56.noise, x, xtest, collinear.x2, npreds=5, degree=1) test.mod(eqn56.noise, x, xtest, collinear.x2, npreds=5, degree=2) test.mod(eqn56.noise, x, xtest, collinear.x2, npreds=5, degree=3) test.mod(eqn56.noise, x, xtest, collinear.x2, npreds=5, nk=99, degree=1) # commented out the following because they are slow # test.mod(eqn56.noise, x, xtest, collinear.x2, npreds=5, nk=99, degree=2) # test.mod(eqn56.noise, x, xtest, collinear.x2, npreds=5, nk=99, degree=3) printf("\n") if(n > 30) { eqn56.noise.extra.preds <- function(x) { eqn56(x) + rnorm(nrow(x)) } test.mod(eqn56.noise.extra.preds, x, xtest, collinear.x2, npreds=9, degree=1) test.mod(eqn56.noise.extra.preds, x, xtest, collinear.x2, npreds=9, degree=2) test.mod(eqn56.noise.extra.preds, x, xtest, collinear.x2, npreds=9, degree=3) test.mod(eqn56.noise.extra.preds, x, xtest, collinear.x2, npreds=9, degree=1, nk=99) # commented out the following because they are slow # test.mod(eqn56.noise.extra.preds, x, xtest, collinear.x2, npreds=9, degree=2, nk=99) # test.mod(eqn56.noise.extra.preds, x, xtest, collinear.x2, npreds=9, degree=3, nk=99) printf("\n") } # force linpreds in 1 and 2 degree terms test.mod(eqn56, x, xtest, collinear.x2, npreds=5, linpreds=c("^x1$","x3","5")) test.mod(eqn56, x, xtest, collinear.x2, npreds=5, linpreds=c(3,5)) # check symmetry by using negative of eqn56 (may not be completely symmetric) neg.eqn56 <- function(x) { -eqn56(x) } test.mod(neg.eqn56, x, xtest, collinear.x2, npreds=5, linpreds=c(3,5)) printf("\n") five.preds <- function(x) # x1 and x2, and x3 and x4 interact { y <- 0 for (i in 1:5) y <- y + sin(2 * x[,i]) y + x[,1] * cos(4 * x[,2]) + (x[,3]-2) * x[,4] } test.mod(five.preds, x, xtest, collinear.x2, npreds=5, degree=1) test.mod(five.preds, x, xtest, collinear.x2, npreds=5, degree=2) test.mod(five.preds, x, xtest, collinear.x2, npreds=5, degree=3) test.mod(five.preds, x, xtest, collinear.x2, npreds=5, degree=1, nk=51) # commented out the following because they are slow # test.mod(five.preds, x, xtest, collinear.x2, npreds=5, degree=2, nk=51) # test.mod(five.preds, x, xtest, collinear.x2, npreds=5, degree=3, nk=51) printf("\n") if(n > 30) { five.preds.noise <- function(x) { five.preds(x) + .3 * rnorm(nrow(x)) } test.mod(five.preds.noise, x, xtest, collinear.x2, npreds=5, degree=1) test.mod(five.preds.noise, x, xtest, collinear.x2, npreds=5, degree=2) test.mod(five.preds.noise, x, xtest, collinear.x2, npreds=5, degree=3) test.mod(five.preds.noise, x, xtest, collinear.x2, npreds=5, degree=1, nk=51) # commented out the following because they are slow # test.mod(five.preds.noise, x, xtest, collinear.x2, npreds=5, degree=2, nk=51) # test.mod(five.preds.noise, x, xtest, collinear.x2, npreds=5, degree=3, nk=51) printf("\n") } pure.noise <- function(x) { rnorm(nrow(x)) } test.mod(pure.noise, x, xtest, collinear.x2, npreds=1, degree=1) test.mod(pure.noise, x, xtest, collinear.x2, npreds=2, degree=1) test.mod(pure.noise, x, xtest, collinear.x2, npreds=2, degree=2) if(n < 100) { cat("Skipping further tests because n < 100\n\n") return(invisible()) } test.mod(pure.noise, x, xtest, collinear.x2, npreds=1, degree=1, nk=51) test.mod(pure.noise, x, xtest, collinear.x2, npreds=2, degree=2, nk=51) test.mod(pure.noise, x, xtest, collinear.x2, npreds=2, degree=2, nk=51) test.mod(pure.noise, x, xtest, collinear.x2, npreds=5, degree=1) test.mod(pure.noise, x, xtest, collinear.x2, npreds=5, degree=2) test.mod(pure.noise, x, xtest, collinear.x2, npreds=5, degree=1, nk=51) # commented out the following because it is slow # test.mod(pure.noise, x, xtest, collinear.x2, npreds=5, degree=2, nk=51) printf("\n") if(n > 100) { # need many points (Fast MARS paper uses 400 and 800 for robot.arm) robot.arm <- function(x) # Friedman Fast MARS paper { l1 <- x[,1] l2 <- x[,2] theta1 <- x[,3] theta2 <- x[,4] phi <- x[,5] x1 <- l1 * cos(theta1) - l2 * cos(theta1 + theta2) * cos(phi) y <- l1 * sin(theta1) - l2 * sin(theta1 + theta2) * cos(phi) z <- l2 * sin(theta2) * sin(phi) sqrt(x1^2 + y^2 + z^2) } x[,1] <- (x[,1] + 1) / 2 # l1 0..1 x[,2] <- (x[,2] + 1) / 2 # l2 0..1 x[,3] <- pi * (x[,3] + 1) # theta1 x[,4] <- pi * (x[,4] + 1) # theta2 x[,5] <- pi * x[,5] / 2 # phi colnames(x) <- c("l1", "l2", "theta1", "theta2", "phi", paste("x", 6:ncol(x), sep="")) xtest[,1] <- (xtest[,1] + 1) / 2 # l1 0..1 xtest[,2] <- (xtest[,2] + 1) / 2 # l2 0..1 xtest[,3] <- pi * (xtest[,3] + 1) # theta1 xtest[,4] <- pi * (xtest[,4] + 1) # theta2 xtest[,5] <- pi * xtest[,5] / 2 # phi colnames(xtest) <- c("l1", "l2", "theta1", "theta2", "phi", paste("x", 6:ncol(x), sep="")) test.mod(robot.arm, x, xtest, collinear.x2, npreds=5, nk=51, degree=3) test.mod(robot.arm, x, xtest, collinear.x2, npreds=5, nk=99, degree=2) test.mod(robot.arm, x, xtest, collinear.x2, npreds=5, nk=99, degree=3) test.mod(robot.arm, x, xtest, collinear.x2, npreds=5, nk=99, degree=5) printf("\n") } if(n > 30) { # need many points (Meinshausen paper uses 1000) sin.sin <- function(x) # from Meinshausen "Node Harvest" paper { sin(pi * (x[,1] + 1)) * sin(pi * (x[,2] + 1)) } # thresh=.0001 else get intercept only model test.mod(sin.sin, x, xtest, collinear.x2, npreds=2, degree=2, nk=99, thresh=.0001) test.mod(sin.sin, x, xtest, collinear.x2, npreds=4, degree=2, nk=99, thresh=.0001) # extra noise predictors printf("\n") } if(n > 100) { # need many points (Meinshausen paper uses 1000) sin.sin.noise <- function(x) { # we use less noise than the paper because we only have a max of 300 points sin(pi * x[,1]) * sin(pi * x[,2]) + rnorm(nrow(x), sd=.25) } test.mod(sin.sin.noise, x, xtest, collinear.x2, npreds=2, degree=2, nk=99, thresh=.0001) test.mod(sin.sin.noise, x, xtest, collinear.x2, npreds=4, degree=2, nk=99, thresh=.0001) # extra noise predictors printf("\n") } invisible() } my.summary <- function(x) { q <- stats::quantile(x, probs = c(0, .01, .05, .1, .5, .9, 1)) q <- c(q[1:4], mean(x), q[5:7]) q <- as.numeric(sprint("%.3f", q)) names(q) <- c("min", "1%", "5%", "10%", "mean", "median", "95%", "max") q } start.time <- proc.time() global.seed <- GLOBAL.SEEDS[1] cat("begin GLOBAL.SEEDS ", GLOBAL.SEEDS, " FORCE.WEIGHTS ", FORCE.WEIGHTS, "\n", sep="") if(RPROF) Rprof("Rprof.out") if(SHORTTEST) { testn(100) } else for(global.seed in GLOBAL.SEEDS) { testn(30) testn(100) testn(300) if(COLLINEAR.TESTS) testn(100, collinear.x2=TRUE) # collinear.x2 preds expose the need for Adjust.endspan } if(RPROF) { Rprof(NULL) print(summaryRprof()) } cat("end GLOBAL.SEEDS ", GLOBAL.SEEDS, " FORCE.WEIGHTS ", FORCE.WEIGHTS, " COLLINEAR.TESTS ", COLLINEAR.TESTS, "\n", sep="") printf("test.rsq (bigger is better):\n") print(my.summary(test.rsqs.global)) printf("grsq-test.rsq (closest to zero is best, but positive is better than negative):\n") print(my.summary(delta.rsqs.global)) # printf("%.3f ", my.summary(delta.rsqs.global)); printf("\n") printf("nterms (smaller is better):\n") print(my.summary(nterms.global)) printf("nknots (smaller is better):\n") print(my.summary(nknots.global)) if(!is.null(other.rsqs.global)) { printf("rf.rsq:\n") print(my.summary(other.rsqs.global)) } if(!is.null(mars.rsqs.global)) { printf("mars.rsq:\n") print(my.summary(mars.rsqs.global)) printf("mars.nterms:\n") print(my.summary(mars.nterms.global)) } if(TIME) printf("[testn time %.3f]\n", (proc.time() - start.time)[3]) source("test.epilog.R") earth/inst/slowtests/test.incorrect.bat0000755000176200001440000000253613514230362020047 0ustar liggesusers@Rem test.incorrect.R: example incorrect model built by earth @rem Stephen Milborrow May 2015 Berea @echo test.incorrect.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.incorrect.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.incorrect.Rout: @echo. @tail test.incorrect.Rout @echo test.incorrect.R @exit /B 1 :good1 @echo diff test.incorrect.Rout test.incorrect.Rout.save @rem egreps to deal with times @C:\Rtools\bin\echo -n "new " @egrep "^\[total time" test.incorrect.Rout @C:\Rtools\bin\echo -n "old " @egrep "^\[total time" test.incorrect.Rout.save @egrep -v "^\[total time" test.incorrect.Rout >test.incorrect.Rout1 @egrep -v "^\[total time" test.incorrect.Rout.save >test.incorrect.Rout.save1 @rem -w to treat \n same as \r\n @mks.diff -w test.incorrect.Rout1 test.incorrect.Rout.save1 @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.incorrect.save.ps @exit /B 1 :good2 @rem test.incorrect.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.incorrect.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.incorrect.Rout test.incorrect.Rout1 test.incorrect.Rout.save1 @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.bpairs.R0000644000176200001440000006320013554117555016776 0ustar liggesusers# test.bpairs.R: source("test.prolog.R") source("check.models.equal.R") source("check.earth.matches.glm.R") library(earth) data(ozone1) data(trees) data(etitanic) cat("\n===short and long data===\n") x.short <- data.frame(x1=c(5,2,2,9,5), x2=c(20,20,30,20,20)) y.short <- data.frame(true=c(1,2,0,2,2), false=c(3,3,1,0,1)) short <- data.frame(x.short, y.short) cat("short:\n") print(short) x.long <- data.frame(x1=c( 5, 5, 5, 5, 2, 2, 2, 2, 2, 2, 9, 9, 5, 5, 5), x2=c(20,20,20,20, 20,20,20,20,20, 30, 20,20, 20, 20, 20)) y.long <- data.frame(true=c(1,0,0,0, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 0)) long <- data.frame(x.long, y.long) cat("long:\n") print(long) true.false <- cbind(true=short$true, false=short$false) weights.long <- c(4, 4, 4, 4, 5, 5, 5, 5, 5, 1, 2, 2, 3, 3, 3) elong <- earth(true~x1+x2, data=long, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1, trace=1) glong <- glm(true~x1+x2, data=long, family="binomial") check.earth.matches.glm(elong, glong) par(mfrow=c(2,2)) plotres(elong, do.par=0, which=c(1,3), main="elong", legend.pos="topleft") empty.plot() plotres(glong, do.par=0, which=3, main="glong") par(mfrow=c(2,2)) plotmo(elong, do.par=0) plotmo(glong, do.par=0) par(old.par) eshort <- earth(true.false~x1+x2, data=short, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1, trace=2) gshort <- glm(true.false~x1+x2, data=short, family="binomial") OLD.EARTH <- FALSE # earth prior to version 5.0.0 MAX.ARG <- if(OLD.EARTH) 1e-6 else 1e-8 check.earth.matches.glm(eshort, gshort, max=MAX.ARG) par(mfrow=c(2,2)) plotres(eshort, do.par=0, which=c(1,3), main="eshort", legend.pos="topleft") empty.plot() plotres(gshort, do.par=0, which=3, main="gshort") par(mfrow=c(2,2)) plotmo(eshort, do.par=0) plotmo(gshort, do.par=0) par(old.par) par(mfrow=c(2,2)) plot(elong, main="elong: Model Selection", which=c(1, 3), do.par=0, legend.pos="topleft") plot(eshort, main="eshort: Model Selection", which=c(1, 3), do.par=0, legend.pos="topleft") par(old.par) cat("\n===long data with weights ===\n") elong.weights <- earth(true~x1+x2, data=long, glm=list(family="binomial"), weights=weights.long, trace=1, linpreds=TRUE, thresh=0, penalty=-1) print(summary(elong.weights)) glong.weights <- glm(true~x1+x2, data=long, family="binomial", weights=weights.long) # models match here but in general models with long and short data won't match check.earth.matches.glm(elong.weights, glong.weights) # compare "earth" part of earth-glm model to lm lm.long.weights <- lm(true~x1+x2, data=long, weights=weights.long) stopifnot(identical(sort(names(coef(elong.weights))), sort(names(coef(lm.long.weights))))) stopifnot(identical(sort(coef(elong.weights, type="earth")), sort(coef(lm.long.weights)))) cat("\n===short data with weights ===\n") # add an extra row to prevent singularities in glm with a zero weight short6 <- rbind(short, list(x1=9, x2=10, true=1, false=1)) true.false6 <- rbind(true.false, c(1,1)) weights.short6 <- sqrt(1:6) cat("weights.short6:\n") print(weights.short6) eshort.weights6 <- earth(true.false6~x1+x2, data=short6, glm=list(family="binomial"), weights=weights.short6, trace=1, linpreds=TRUE, thresh=0, penalty=-1) print(summary(eshort.weights6)) gshort.weights6 <- glm(true.false6~x1+x2, data=short6, family="binomial", weights=weights.short6) print(summary(gshort.weights6)) check.earth.matches.glm(eshort.weights6, gshort.weights6, max=1e-6, max.residuals=1e-10) # unweighted (because all weights equal) cat("weights.short6.reciprocal.of.rowsums:\n") eshort.weights6.reciprocal.of.rowsums <- earth(true.false6~x1+x2, data=short6, glm=list(family="binomial"), weights=1/rowSums(true.false6), trace=1, linpreds=TRUE, thresh=0, penalty=-1) print(summary(eshort.weights6.reciprocal.of.rowsums)) gshort.weights6.reciprocal.of.rowsums <- glm(true.false6~x1+x2, data=short6, family="binomial", weights=1/rowSums(true.false6)) print(summary(gshort.weights6.reciprocal.of.rowsums)) check.earth.matches.glm(eshort.weights6.reciprocal.of.rowsums, gshort.weights6.reciprocal.of.rowsums, max=1e-6, max.residuals=1e-10) weights.short6zero <- sqrt(1:6) weights.short6zero[3] <- 0 cat("weights.short6zero:\n") print(weights.short6zero) eshort.weights6zero <- earth(true.false6~x1+x2, data=short6, glm=list(family="binomial"), weights=weights.short6zero, trace=1, linpreds=TRUE, thresh=0, penalty=-1) print(summary(eshort.weights6zero)) gshort.weights6zero <- glm(true.false6~x1+x2, data=short6, family="binomial", weights=weights.short6zero) print(summary(gshort.weights6zero)) # max.residuals has to be big because of the way earth handles zero weights check.earth.matches.glm(eshort.weights6zero, gshort.weights6zero) cat("\n===short and long data with hinges===\n") # test without linpreds=TRUE (to avoid int-only model, need thresh=0, penalty=-1) elong.hinge <- earth(true~x1+x2, data=long, glm=list(family="binomial"), thresh=0, penalty=-1) print(summary(elong.hinge)) eshort.hinge <- earth(true.false~x1+x2, data=short, glm=list(family="binomial"), thresh=0, penalty=-1) print(summary(eshort.hinge)) eshort.hinge2 <- earth(true+false~x1+x2, data=short, glm=list(family="binomial"), thresh=0, penalty=-1) check.models.equal(eshort.hinge, eshort.hinge2, "eshort.hinge, eshort.hinge2, ", newdata=short[2:3,]) if(OLD.EARTH) { stopifnot(identical(eshort.hinge$dirs[order(rownames(eshort.hinge$dirs)),], elong.hinge$dirs [order(rownames(elong.hinge$dirs)),])) } else stopifnot(identical(eshort.hinge$dirs, elong.hinge$dirs)) par(mfrow=c(2,2)) plotres(elong.hinge, do.par=0, which=c(1,3), main="elong.hinge", legend.pos="topleft") plotres(eshort.hinge, do.par=0, which=c(1,3), main="eshort.hinge", legend.pos="topleft") par(mfrow=c(2,2)) plotmo(elong.hinge, do.par=0, ndiscrete=0) plotmo(eshort.hinge, do.par=0, ndiscrete=0) par(old.par) # test with a y with a binomial pair row with both entries equal to 0 x.short.with.zeros <- data.frame(x1=c(5,2,2,9,5,9), x2=c(20,20,30,20,20,30)) y.short.with.zeros <- data.frame(true=c(1,2,0,2,2,0), false=c(3,3,1,0,1,0)) short.with.zeros <- data.frame(x.short.with.zeros, y.short.with.zeros) true.false.with.zeros <- cbind(true=short.with.zeros$true, false=short.with.zeros$false) eshort.with.zeros <- earth(true.false.with.zeros~x1+x2, data=short.with.zeros, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1) gshort.with.zeros <- glm(true.false.with.zeros~x1+x2, data=short.with.zeros, family="binomial") check.earth.matches.glm(eshort.with.zeros, gshort.with.zeros) par(mfrow=c(2,2)) plotres(eshort.with.zeros, do.par=0, which=c(1,3), main="eshort.with.zeros", legend.pos="topleft") empty.plot() plotres(gshort.with.zeros, do.par=0, which=3, main="gshort.with.zeros") par(mfrow=c(2,2)) plotmo(eshort.with.zeros, do.par=0, ndiscrete=0) plotmo(gshort.with.zeros, do.par=0, ndiscrete=0) par(old.par) eshort.with.zeros.plus <- earth(true+false~x1+x2, data=short.with.zeros, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1, trace=1) check.models.equal(eshort.with.zeros, eshort.with.zeros.plus, "eshort.with.zeros, eshort.with.zeros.plus", newdata=short.with.zeros[2:3,]) eshort.with.zeros.plus.quasibinomial <- earth(true+false~x1+x2, data=short.with.zeros, glm=list(family="quasibinomial"), linpreds=TRUE, thresh=0, penalty=-1, trace=1) check.models.equal(eshort.with.zeros.plus, eshort.with.zeros.plus.quasibinomial, "eshort.with.zeros.plus eshort.with.zeros.plus.quasibinomial", newdata=short.with.zeros[1:3,]) # print(summary(eshort.with.zeros.plus)) # print(summary(eshort.with.zeros.plus.quasibinomial)) # print(summary(eshort.with.zeros.plus$glm.list[[1]])) # print(summary(eshort.with.zeros.plus.quasibinomial$glm.list[[1]])) cat("\n===compare with model where yfrac is generated manually===\n") bpairs.frac <- function(y) { stopifnot(NCOL(y) == 2) # binomial pairs y has two columns stopifnot(is.numeric(y[,1]) ||is.logical(y[,1])) stopifnot(is.numeric(y[,2]) ||is.logical(y[,2])) stopifnot(all(y >= 0)) # all y values non-negative stopifnot(round(y) == y) # all y values integers weights <- y[,1] + y[,2] if(length(weights > 1) == 0) warning("no rows of y sum to greater than 1 (earth will not consider y to be a binomial pair") y[weights == 0, 2] <- 1 # so all-zero rows will be treated as fraction=0 # we return y as a one column mat (not a vector) so we can give it a colname frac <- matrix(y[, 1] / (y[,1] + y[,2]), ncol=1) # fraction true colnames(frac) <- colnames(y)[1] nchar <- nchar(colnames(frac)) if(length(nchar) == 0 || nchar == 0) colnames(frac) <- "frac" list(frac=frac, weights=weights) } ret <- bpairs.frac(cbind(short.with.zeros$true, short.with.zeros$false)) print(ret) stopifnot(identical(colnames(ret$frac), "frac")) # column name added automatically ret <- bpairs.frac(short.with.zeros[,c("true", "false")]) print(ret) stopifnot(identical(colnames(ret$frac), "true")) frac <- ret$frac weights <- ret$weights options(warn=2) # expect warning: non-integer #successes in a binomial glm expect.err(try(earth(frac~x1+x2, data=short.with.zeros, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1)), "non-integer #successes in a binomial glm") # warning goes away if we use quasibinomial eshort.with.zeros.frac.quasibinomial <- earth(frac~x1+x2, data=short.with.zeros, weights=weights, glm=list(family="quasibinomial"), linpreds=TRUE, thresh=0, penalty=-1, trace=1) options(warn=1) check.models.equal(eshort.with.zeros.frac.quasibinomial, eshort.with.zeros.plus, "eshort.frac, eshort.with.zeros.plus", newdata=short.with.zeros[2:3,], allow.different.names=TRUE) eshort.with.zeros.frac.binomial <- earth(frac~x1+x2, data=short.with.zeros, weights=weights, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1) # # compare stats like deviance etc (all identical here except no AIC for quasibinomial, # # and standard deviations of glm submodels differ) # cat("eshort.with.zeros.frac.binomial:\n") # print(summary(eshort.with.zeros.frac.binomial)) # cat("eshort.with.zeros.frac.quasibinomial:\n") # print(summary(eshort.with.zeros.frac.quasibinomial)) # cat("---------------------------------------------------\n") # print(summary(eshort.with.zeros.frac.binomial$glm.list[[1]])) # print(summary(eshort.with.zeros.frac.quasibinomial$glm.list[[1]])) # lizard data used in McCullagh and Nelder GLM book (2nd ed) # this has an entry with both responses equal to zero (similar to the above data): # site.shade diameter.wide height.tall time grahami opalinus # 11 FALSE TRUE TRUE Mid 0 0 cat("\n===lizards===\n") shade <- factor(x=c( "sun", "sun", "sun", "sun", "sun", "sun", "sun", "sun", "sun", "sun", "sun", "sun", "shade", "shade", "shade", "shade", "shade", "shade", "shade", "shade", "shade", "shade", "shade", "shade"), levels=c("sun", "shade")) diameter.wide <- as.logical(c( 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1)) height.tall <- as.logical(c( 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1)) time <- factor(x=c( "Early", "Mid", "Late", "Early", "Mid", "Late", "Early", "Mid", "Late", "Early", "Mid", "Late", "Early", "Mid", "Late", "Early", "Mid", "Late", "Early", "Mid", "Late", "Early", "Mid", "Late"), levels=c("Early", "Mid", "Late"), ordered=FALSE) grahami <- c( 20, 8, 4, 13, 8, 12, 8, 4, 5, 6, 0, 1, 34, 69, 18, 31, 55, 13, 17, 60, 8, 12, 21, 4) opalinus <- c( 2, 1, 4, 0, 0, 0, 3, 1, 3, 0, 0, 1, 11, 20, 10, 5, 4, 3, 15, 32, 8, 1, 5, 4) lizards <- data.frame( shade=shade, wide=diameter.wide, tall=height.tall, time=time, grahami=grahami, opalinus=opalinus) grahami.opalinus <- cbind(grahami=lizards$grahami, opalinus=lizards$opalinus) eliz <- earth(grahami.opalinus~shade+wide+tall+time, data=lizards, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1, trace=1) eliz.Formula <- earth(grahami+opalinus~shade+wide+tall+time, data=lizards, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1, trace=1) gliz <- glm(grahami.opalinus~shade+wide+tall+time, data=lizards, family="binomial") check.earth.matches.glm(eliz, gliz, newdata=lizards[c(2:5),]) check.earth.matches.glm(eliz.Formula, gliz, newdata=lizards[c(2:5),]) print(evimp(eliz)) par(mfrow=c(3,2)) plotres(eliz, do.par=0, which=c(1,3), main="eliz", legend.pos="topleft") plotres(eliz.Formula, do.par=0, which=c(1,3), main="eliz.Formula", legend.pos="topleft") empty.plot() plotres(gliz, do.par=0, which=3, main="gliz") par(old.par) plotmo(eliz, ndiscrete=0, SHOWCALL=TRUE) plotmo(eliz.Formula, ndiscrete=0, SHOWCALL=TRUE) plotmo(gliz, ndiscrete=0, SHOWCALL=TRUE) cat("\n===incorrect bpairs (error handling for bad data)===\n") test.incorrect.bpairs <- function(msg, expect.err, trace, y.short) { printf("\ntest.incorrect.bpairs: %s\n", msg) x.short <- data.frame(x1=as.double(1:5)) short <- data.frame(x.short, y.short) true.false <- cbind(true=short$true, false=short$false) if(expect.err) expect.err(try(earth(true.false~x1, data=short, glm=list(family="binomial"), trace=trace)), "Binomial response (see above): all values should be between 0 and 1, or a binomial pair") else earth(true.false~x1, data=short, glm=list(family="binomial"), trace=trace) } test.incorrect.bpairs("non integral, greater than 1", expect.err=TRUE, trace=1, data.frame(true=as.double(c(0,1,0,1,0)), false=as.double(c(1,0,1,0,1.1)))) test.incorrect.bpairs("non integral but in range 0...1", expect.err=FALSE, trace=1, data.frame(true=as.double(c(0,1,0,1,0)), false=as.double(c(1,0,1,0,.1)))) test.incorrect.bpairs("non integral but in range 0...1", expect.err=FALSE, trace=0, data.frame(true=as.double(c(0,1,0,1,0)), false=as.double(c(1,0,1,0,.1)))) test.incorrect.bpairs("negative value", expect.err=TRUE, trace=1, data.frame(true=as.double(c(0,1,0,1,0)), false=as.double(c(1,0,1,0,-2)))) test.incorrect.bpairs("no rows sum to greater than 1", expect.err=FALSE, trace=1, data.frame(true=as.double(c(0,1,0,1,0)), false=as.double(c(1,0,1,0,0)))) printf("\n") #-------------------------------------------------------- ldose <- rep(0:5, 2) - 2 # Venables and Ripley 4th edition page 191 sex <- factor(rep(c("male", "female"), times=c(6,6))) numdead <- c(1,4,9,13,18,20,0,2,6,10,12,16) numalive = 20 - numdead pair <- cbind(numalive, numdead) # following uses formula not Formula pairmod <- earth(pair ~ sex + ldose, trace=1, pmethod="none", glm=list(family=binomial)) stopifnot(attr(terms(pairmod), "response") == 1) stopifnot(is.null(attr(terms(pairmod), "Response"))) glm.weights <- 1 * c(.8,1,1,.5,1,1,1,1,1,1,1,1) # will change model slightly pairmod.weights <- earth(pair ~ sex + ldose, weights=glm.weights, trace=0, pmethod="none", glm=list(family=binomial)) # build a model using a global variables # following uses Formula not formula because of "+" pairmod2 <- earth(numalive + numdead ~ sex + ldose, trace=1, pmethod="none", glm=list(family=binomial)) stopifnot(attr(terms(pairmod2), "response") == 0) stopifnot(attr(terms(pairmod2), "Response") == c(1,2)) check.models.equal(pairmod2, pairmod, "pairmod2, pairmod", newdata=data.frame(sex="male", ldose=3)) plot(pairmod2, info=TRUE, SHOWCALL=TRUE) pairmod2.weights <- earth(numalive + numdead ~ sex + ldose, weights=glm.weights, trace=0, pmethod="none", glm=list(family=binomial)) plot(pairmod2.weights, info=TRUE, SHOWCALL=TRUE) check.models.equal(pairmod2.weights, pairmod.weights, "pairmod2.weights, pairmod.weights", newdata=data.frame(sex="male", ldose=3)) plotmo(pairmod, SHOWCALL=TRUE) plotmo(pairmod2, SHOWCALL=TRUE) # build a model using a combo of global and data.frame data df.except.numdead <- data.frame(ldose=ldose, numalive=numalive, sex=sex) # change global data to invalid values so we can see if we use it by mistake ldose <- rep(90:95, 2) - 2 # Venables and Ripley 4th edition page 191 sex <- factor(rep(c("a", "be"), times=c(6,6))) numalive = NA # following uses Formula not formula because of "+" pairmod3 <- earth(numalive + numdead ~ sex + ldose, data=df.except.numdead, trace=0, pmethod="none", glm=list(family=binomial)) check.models.equal(pairmod3, pairmod2, "pairmod3, pairmod2", newdata=df.except.numdead[3:4,]) plot(pairmod3, info=TRUE) plotmo(pairmod3, SHOWCALL=TRUE) # build a model using only data from a data.frame df <- data.frame(df.except.numdead, numdead=numdead) numdead <- 991:992 # invalidate the global data # following uses Formula not formula because of "+" pairmod_Formula <- earth(numalive + numdead ~ sex + ldose, data=df, trace=0, pmethod="none", glm=list(family=binomial)) plot(pairmod_Formula, info=TRUE) check.models.equal(pairmod_Formula, pairmod2, "pairmod_Formula, pairmod2", newdata=df[5:6,]) expect.err(try(earth(20-numdead+numdead ~ sex + ldose, data=df, glm=list(family=binomial))), "invalid model formula in ExtractVars") # following uses formula not Formula pairmod_formula <- earth(pair ~ sex + ldose, data=df, trace=0, pmethod="none", glm=list(family=binomial)) stopifnot(attr(terms(pairmod_formula), "response") == 1) stopifnot(is.null(attr(terms(pairmod_formula), "Response"))) check.models.equal(pairmod_formula, pairmod_Formula, "pairmod_Formula, pairmod2", newdata=df[1:3,]) # subset # build a model using only data from a data.frame # following uses Formula not formula because of "+" subset.middle <- seq(from=2, to=nrow(df)-2) pairmod_Formula_subset <- earth(numalive + numdead ~ sex + ldose, data=df, subset=subset.middle, trace=0, pmethod="none", glm=list(family=binomial)) plot(pairmod_Formula_subset, info=TRUE) # following uses formula not Formula pairmod_formula_subset <- earth(pair ~ sex + ldose, data=df, subset=subset.middle, trace=0, pmethod="none", glm=list(family=binomial)) stopifnot(attr(terms(pairmod_formula_subset), "response") == 1) stopifnot(is.null(attr(terms(pairmod_formula_subset), "Response"))) check.models.equal(pairmod_formula_subset, pairmod_Formula_subset, "pairmod_Formula_subset, pairmod2", newdata=df[1:3,]) plot(pairmod_formula_subset, info=TRUE) plotmo(pairmod_Formula_subset, SHOWCALL=TRUE) plotmo(pairmod_formula_subset, SHOWCALL=TRUE) # have to use I() if a minus in a formula that has a plus pairmod5 <- earth(I(20-numdead) + numdead ~ sex + ldose, data=df, trace=1, pmethod="none", glm=list(family=binomial)) check.models.equal(pairmod5, pairmod2, "pairmod5, pairmod2", newdata=df[5:6,], allow.different.names=TRUE) plot(pairmod5, info=TRUE) pairmod6a <- earth(numalive + numdead ~ sex + ldose - sex, data=df, trace=1, pmethod="none") pairmod6b <- earth(numalive + numdead ~ ldose, data=df, trace=1, pmethod="none") print(summary(pairmod6a)) plot(pairmod6a, nresponse=1) plotmo(pairmod6a, nresponse=1) check.models.equal(pairmod6a, pairmod6b, "pairmod6a, pairmod6b", newdata=df[5:6,]) pairmod7 <- earth(numalive + numdead ~ sex * ldose, data=df, trace=1, pmethod="none") print(summary(pairmod7)) plot(pairmod7, nresponse=1) plotmo(pairmod7, nresponse=1) pairmod8 <- earth(numalive + numdead ~ ., data=df, trace=1, pmethod="none", glm=list(family=binomial)) print(summary(pairmod8)) plot(pairmod8, nresponse=1) plotmo(pairmod8, nresponse=1) # following fails because predictors are in a different order in dirs, ok try(check.models.equal(pairmod8, pairmod2, "pairmod8, pairmod2", newdata=df[5:6,])) stopifnot(all.equal(sort(coef(pairmod8)), sort(coef(pairmod2)))) # ok set.seed(2019) pairmod.cv <- earth(numalive + numdead ~ ., data=df, nfold=2, trace=1, pmethod="none", keepxy=TRUE, glm=list(family=binomial)) check.models.equal(pairmod.cv, pairmod8, "pairmod.cv, pairmod9", newdata=df[3:5,]) # TODO following fails, it shouldn't (the minus sign on the rhs messes things up), cf pairmod6a try(earth(numalive + numdead ~ . - ldose, data=df)) newdata.dataframe <- df[1,,drop=FALSE] # data.frame print(newdata.dataframe) predict.pairmod <- predict(pairmod, newdata.dataframe) predict.pairmod2 <- predict(pairmod2, newdata.dataframe) predict.pairmod_Formula <- predict(pairmod_Formula, newdata.dataframe) predict.pairmod5 <- predict(pairmod5, newdata.dataframe) check.same(predict.pairmod, 2.372412, max=1e-4) check.same(predict.pairmod2, predict.pairmod, "predict pairmod2,pairmod with newdata.dataframe") check.same(predict.pairmod_Formula, predict.pairmod, "predict pairmod_Formula,pairmod2 with newdata.dataframe") check.same(predict.pairmod5, predict.pairmod, "predict pairmod5,pairmod2 with newdata.dataframe", allow.different.names=TRUE) newdata.vector <- df[1,,drop=TRUE] # list print(newdata.vector) predict.pairmodv <- predict(pairmod, newdata.vector) predict.pairmod2v <- predict(pairmod2, newdata.vector) predict.pairmod_Formulav <- predict(pairmod_Formula, newdata.vector) predict.pairmod5v <- predict(pairmod5, newdata.vector) check.same(predict.pairmodv, 2.372412, max=1e-4) check.same(predict.pairmod2v, predict.pairmodv, "predict pairmod2,pairmod with newdata.vector") check.same(predict.pairmod_Formulav, predict.pairmodv, "predict pairmod_Formula,pairmod2 with newdata.vector") check.same(predict.pairmod5v, predict.pairmodv, "predict pairmod5,pairmod2 with newdata.vector", allow.different.names=TRUE) plotmo(pairmod_Formula, SHOWCALL=TRUE) plotmo(pairmod5, SHOWCALL=TRUE) expect.err(try(plotmo(pairmod2)), "cannot get the original model predictors") # because we deleted ldose, numalive, etc. expect.err(try(plotmo(pairmod2.weights)), "cannot get the original model predictors") # because we deleted ldose, numalive, etc. expect.err(try(earth(numalive + 20 - numdead ~ sex + ldose, data=df, glm=list(family=binomial))), "Binomial response (see above): all values should be between 0 and 1, or a binomial pair") cat("\n===vignette short/long data example===\n") ldose <- rep(0:5, 2) - 2 # Venables and Ripley 4th edition page 191 sex <- factor(rep(c("male", "female"), times=c(6,6))) numdead <- c(1,4,9,13,18,20,0,2,6,10,12,16) numalive <- 20 - numdead glm.short <- glm(cbind(numalive,numdead) ~ ldose + sex, family=binomial) earth.short <- earth(cbind(numalive,numdead) ~ ldose + sex, glm=list(family=binomial)) earth.short.lin <- earth(cbind(numalive,numdead) ~ ldose + sex, glm=list(family=binomial), # coerce earth to build a linear (no hinge) model with all vars # (generated model matches the glm.short model above) linpreds=TRUE, thresh=0, penalty=-1) data.short <- data.frame(numalive, numdead, ldose, sex) data.long <- expand.bpairs(data.short, c("numalive", "numdead")) # data.long$num.alive will be a fraction 0...1 print(data.long) glm.long <- glm(numalive ~ ldose + sex, data=data.long, family=binomial) earth.long <- earth(numalive ~ ldose + sex, data=data.long, glm=list(family=binomial)) earth.long.lin <- earth(numalive ~ ldose + sex, data=data.long, glm=list(family=binomial), linpreds=TRUE, thresh=0, penalty=-1) print(summary(glm.short)) print(summary(earth.short)) print(summary(earth.short.lin)) print(summary(glm.long)) print(summary(earth.long)) print(summary(earth.long.lin)) print(coef(glm.short)) stopifnot(max(coef(earth.short.lin) - coef(glm.short)) < 1e-12) # same stopifnot(max(coef(glm.long) - coef(glm.short)) < 1e-12) # same stopifnot(max(coef(earth.long.lin) - coef(glm.short)) < 1e-12) # same coef(earth.short) # different coef(earth.long) # different cat("\n===cross validated binomial pair model===\n") # use a big enough data set for cross validation without negative GRSqs n2 <- 20 set.seed(2019) good <- pmax(round(c((1:n2),(n2:1)) + rnorm(2*n2)), 0) bad <- pmax(n2 - good, 0) data <- data.frame(good, bad, x=1:(2 * n2)) set.seed(2020) earth.cv <- earth(good+bad~., data=data, glm=list(family=binomial), trace=1, nfold=2, keepxy=TRUE) cat("cross validated model:\n") print(summary(earth.cv)) cat("first fold model:\n") print(summary(earth.cv$cv.list[[1]])) par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) set.seed(2019) plotmo(earth.cv, type="earth", pt.col=2, do.par=0) empty.plot() # TODO following doesn't work (can't plotmo the fold models) # plotmo(earth.cv$cv.list[[1]], type="earth", pt.col=2, do.par=0) plot.earth.models(list(earth.cv, earth.cv$cv.list[[1]], earth.cv$cv.list[[2]]), which=1:2, do.par=0) source("test.epilog.R") earth/inst/slowtests/test.cv.Rout.save0000644000176200001440000161316313470056616017622 0ustar liggesusers> # test.cv.R: test earth cross validation > > source("test.prolog.R") > source("check.models.equal.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > data(ozone1) > data(trees) > data(etitanic) > options(width=200) > > printh <- function(x, expect.warning=FALSE, max.print=0) # like print but with a header + { + cat("===", deparse(substitute(x))) + if(expect.warning) + cat(" expect warning -->") + else if (NROW(x) > 1) + cat("\n") + if (max.print > 0) + print(head(x, n=max.print)) + else + print(x) + } > > # print contents of earth.model, for sanity checking that all fields are present as usual > # but strip big fields to reduce amount of printing > > print.stripped.earth.model <- function(earth.mod, model.name) + { + earth.mod$bx <- NULL + earth.mod$fitted.values <- NULL + earth.mod$residuals <- NULL + earth.mod$rss <- NULL + cat("print.stripped.earth.model(", model.name, ")\n", sep="") + print.default(earth.mod) + cat("-------------------------------------------------------------------------------\n\n") + } > > cat("a0: trees\n\n") a0: trees > > set.seed(23) > a0 <- earth(Volume ~ ., data = trees, trace=0.5, nfold=3) Full model GRSq 0.960 RSq 0.974, starting cross validation CV fold 1 CVRSq 0.950 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 2 CVRSq 0.916 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3 CVRSq 0.950 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV all CVRSq 0.939 n.infold.nz 31 100% > printh(a0$cv.rsq.tab) === a0$cv.rsq.tab Volume mean fold1 0.9502943 0.9502943 fold2 0.9156043 0.9156043 fold3 0.9502586 0.9502586 mean 0.9387191 0.9387191 > printh(a0) === a0 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 CVRSq 0.9387191 > printh(summary(a0)) === summary(a0) Call: earth(formula=Volume~., data=trees, trace=0.5, nfold=3) 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 CVRSq 0.9387191 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.67 sd 0.58 nvars 1.67 sd 0.58 CVRSq sd MaxErr sd 0.939 0.02 -10.3 9.87 > print.stripped.earth.model(a0, "a0") print.stripped.earth.model(a0) $rsq [1] 0.9742029 $gcv [1] 11.25439 $grsq [1] 0.959692 $dirs Girth Height (Intercept) 0 0 h(Girth-14.2) 1 0 h(14.2-Girth) -1 0 h(Height-75) 0 1 h(75-Height) 0 -1 $cuts Girth Height (Intercept) 0.0 0 h(Girth-14.2) 14.2 0 h(14.2-Girth) 14.2 0 h(Height-75) 0.0 75 h(75-Height) 0.0 75 $selected.terms [1] 1 2 3 4 $prune.terms [,1] [,2] [,3] [,4] [,5] [1,] 1 0 0 0 0 [2,] 1 2 0 0 0 [3,] 1 2 3 0 0 [4,] 1 2 3 4 0 [5,] 1 2 3 4 5 $coefficients Volume (Intercept) 29.0599535 h(Girth-14.2) 6.2295143 h(14.2-Girth) -3.4198062 h(Height-75) 0.5813644 $rss.per.response [1] 209.1139 $rsq.per.response [1] 0.9742029 $gcv.per.response [1] 11.25439 $grsq.per.response [1] 0.959692 $rss.per.subset [1] 8106.0839 1224.3713 312.6848 209.1139 199.1495 $gcv.per.subset [1] 279.20956 48.41264 14.33910 11.25439 12.75544 $leverages [1] 0.21562477 0.18838971 0.17165171 0.07520293 0.11435309 0.17770878 0.06244141 0.06244141 0.07866123 0.05932299 0.05813251 0.04736783 0.04736783 0.05649241 0.05819896 0.07864063 0.24749025 [18] 0.30936220 0.11610541 0.12206534 0.11143282 0.14069416 0.13653142 0.12838010 0.08964560 0.09235130 0.10594882 0.12696836 0.13404314 0.13404314 0.45293971 $pmethod [1] "backward" $nprune NULL $penalty [1] 2 $nk [1] 21 $thresh [1] 0.001 $termcond [1] 4 $weights NULL $call earth(formula = Volume ~ ., data = trees, trace = 0.5, nfold = 3) $namesx.org [1] "Girth" "Height" $namesx [1] "Girth" "Height" $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() $cv.list $cv.list$fold1 Selected 4 of 5 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Number of terms at each degree of interaction: 1 3 (additive model) GCV 12.50762 RSS 105.6894 GRSq 0.9459775 RSq 0.9747097 $cv.list$fold2 Selected 3 of 5 terms, and 1 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Number of terms at each degree of interaction: 1 2 (additive model) GCV 10.90976 RSS 132.9952 GRSq 0.964869 RSq 0.9775162 $cv.list$fold3 Selected 4 of 5 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Number of terms at each degree of interaction: 1 3 (additive model) GCV 13.06567 RSS 121.9462 GRSq 0.958905 RSq 0.9798635 $cv.nterms.selected.by.gcv fold1 fold2 fold3 mean 4.000000 3.000000 4.000000 3.666667 $cv.nvars.selected.by.gcv fold1 fold2 fold3 mean 2.000000 1.000000 2.000000 1.666667 $cv.groups cross fold [1,] 1 2 [2,] 1 3 [3,] 1 1 [4,] 1 1 [5,] 1 1 [6,] 1 1 [7,] 1 2 [8,] 1 1 [9,] 1 2 [10,] 1 3 [11,] 1 2 [12,] 1 3 [13,] 1 1 [14,] 1 3 [15,] 1 2 [16,] 1 2 [17,] 1 2 [18,] 1 1 [19,] 1 1 [20,] 1 2 [21,] 1 3 [22,] 1 1 [23,] 1 3 [24,] 1 3 [25,] 1 3 [26,] 1 3 [27,] 1 1 [28,] 1 2 [29,] 1 2 [30,] 1 3 [31,] 1 1 $cv.rsq.tab Volume mean fold1 0.9502943 0.9502943 fold2 0.9156043 0.9156043 fold3 0.9502586 0.9502586 mean 0.9387191 0.9387191 $cv.maxerr.tab Volume max fold1 -10.296537 -10.296537 fold2 8.169792 8.169792 fold3 4.984991 4.984991 max -10.296537 -10.296537 attr(,"class") [1] "earth" ------------------------------------------------------------------------------- > > cat("a0a: trees with matrix interface\n\n") a0a: trees with matrix interface > > set.seed(23) > a0a <- earth(trees[,-3], trees[,3], trace=0, nfold=3) > stopifnot(!identical(a0$cv.rsq.tab, a0a$cv.rsq.tab)) > printh(a0a) === a0a 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 CVRSq 0.9387191 > printh(summary(a0a)) === summary(a0a) Call: earth(x=trees[,-3], y=trees[,3], trace=0, nfold=3) 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 CVRSq 0.9387191 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.67 sd 0.58 nvars 1.67 sd 0.58 CVRSq sd MaxErr sd 0.939 0.02 -10.3 9.87 > print.stripped.earth.model(a0a, "a0a") print.stripped.earth.model(a0a) $rsq [1] 0.9742029 $gcv [1] 11.25439 $grsq [1] 0.959692 $dirs Girth Height (Intercept) 0 0 h(Girth-14.2) 1 0 h(14.2-Girth) -1 0 h(Height-75) 0 1 h(75-Height) 0 -1 $cuts Girth Height (Intercept) 0.0 0 h(Girth-14.2) 14.2 0 h(14.2-Girth) 14.2 0 h(Height-75) 0.0 75 h(75-Height) 0.0 75 $selected.terms [1] 1 2 3 4 $prune.terms [,1] [,2] [,3] [,4] [,5] [1,] 1 0 0 0 0 [2,] 1 2 0 0 0 [3,] 1 2 3 0 0 [4,] 1 2 3 4 0 [5,] 1 2 3 4 5 $coefficients trees[,3] (Intercept) 29.0599535 h(Girth-14.2) 6.2295143 h(14.2-Girth) -3.4198062 h(Height-75) 0.5813644 $rss.per.response [1] 209.1139 $rsq.per.response [1] 0.9742029 $gcv.per.response [1] 11.25439 $grsq.per.response [1] 0.959692 $rss.per.subset [1] 8106.0839 1224.3713 312.6848 209.1139 199.1495 $gcv.per.subset [1] 279.20956 48.41264 14.33910 11.25439 12.75544 $leverages [1] 0.21562477 0.18838971 0.17165171 0.07520293 0.11435309 0.17770878 0.06244141 0.06244141 0.07866123 0.05932299 0.05813251 0.04736783 0.04736783 0.05649241 0.05819896 0.07864063 0.24749025 [18] 0.30936220 0.11610541 0.12206534 0.11143282 0.14069416 0.13653142 0.12838010 0.08964560 0.09235130 0.10594882 0.12696836 0.13404314 0.13404314 0.45293971 $pmethod [1] "backward" $nprune NULL $penalty [1] 2 $nk [1] 21 $thresh [1] 0.001 $termcond [1] 4 $weights NULL $call earth(x = trees[, -3], y = trees[, 3], trace = 0, nfold = 3) $namesx.org [1] "Girth" "Height" $namesx [1] "Girth" "Height" $cv.list $cv.list$fold1 Selected 4 of 5 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Number of terms at each degree of interaction: 1 3 (additive model) GCV 12.50762 RSS 105.6894 GRSq 0.9459775 RSq 0.9747097 $cv.list$fold2 Selected 3 of 5 terms, and 1 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Number of terms at each degree of interaction: 1 2 (additive model) GCV 10.90976 RSS 132.9952 GRSq 0.964869 RSq 0.9775162 $cv.list$fold3 Selected 4 of 5 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Number of terms at each degree of interaction: 1 3 (additive model) GCV 13.06567 RSS 121.9462 GRSq 0.958905 RSq 0.9798635 $cv.nterms.selected.by.gcv fold1 fold2 fold3 mean 4.000000 3.000000 4.000000 3.666667 $cv.nvars.selected.by.gcv fold1 fold2 fold3 mean 2.000000 1.000000 2.000000 1.666667 $cv.groups cross fold [1,] 1 2 [2,] 1 3 [3,] 1 1 [4,] 1 1 [5,] 1 1 [6,] 1 1 [7,] 1 2 [8,] 1 1 [9,] 1 2 [10,] 1 3 [11,] 1 2 [12,] 1 3 [13,] 1 1 [14,] 1 3 [15,] 1 2 [16,] 1 2 [17,] 1 2 [18,] 1 1 [19,] 1 1 [20,] 1 2 [21,] 1 3 [22,] 1 1 [23,] 1 3 [24,] 1 3 [25,] 1 3 [26,] 1 3 [27,] 1 1 [28,] 1 2 [29,] 1 2 [30,] 1 3 [31,] 1 1 $cv.rsq.tab trees[,3] mean fold1 0.9502943 0.9502943 fold2 0.9156043 0.9156043 fold3 0.9502586 0.9502586 mean 0.9387191 0.9387191 $cv.maxerr.tab trees[,3] max fold1 -10.296537 -10.296537 fold2 8.169792 8.169792 fold3 4.984991 4.984991 max -10.296537 -10.296537 attr(,"class") [1] "earth" ------------------------------------------------------------------------------- > > cat("a1: trees with trace enabled\n\n") a1: trees with trace enabled > > set.seed(1) > a1 <- earth(Volume ~ ., data = trees, trace=1, nfold=3) x[31,2] with colnames Girth Height y[31,1] with colname Volume, and values 10.3, 10.3, 10.2, 16.4, 18.8,... Forward pass term 1, 2, 4, 6 RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00087) After forward pass GRSq 0.947 RSq 0.976 Prune backward penalty 2 nprune null: selected 4 of 5 terms, and 2 of 2 preds After pruning pass GRSq 0.96 RSq 0.974 Full model GRSq 0.960 RSq 0.974, starting cross validation CV fold 1 CVRSq 0.946 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 2 CVRSq 0.961 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3 CVRSq 0.963 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV all CVRSq 0.956 n.infold.nz 31 100% > stopifnot(!identical(a0$cv.rsq.tab, a1$cv.rsq.tab)) > printh(a1) === a1 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 CVRSq 0.9564543 > printh(summary(a1)) === summary(a1) Call: earth(formula=Volume~., data=trees, trace=1, nfold=3) 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 CVRSq 0.9564543 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 4.00 sd 0.00 nvars 2.00 sd 0.00 CVRSq sd MaxErr sd 0.956 0.01 -7.76 6.51 > > # test correct operation of update > > cat("a2 <- update(a0) # should do cv\n") a2 <- update(a0) # should do cv > set.seed(2) > a2 <- update(a0) Full model GRSq 0.960 RSq 0.974, starting cross validation CV fold 1 CVRSq 0.873 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 2 CVRSq 0.959 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3 CVRSq 0.952 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV all CVRSq 0.928 n.infold.nz 31 100% > cat("a3 <- update(a0) # should do cv\n") a3 <- update(a0) # should do cv > set.seed(3) > a3 <- update(a0, formula=Volume~.-Height) Full model GRSq 0.949 RSq 0.962, starting cross validation CV fold 1 CVRSq 0.921 n.oof 20 35% n.infold.nz 20 100% n.oof.nz 11 100% CV fold 2 CVRSq 0.949 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV fold 3 CVRSq 0.916 n.oof 21 32% n.infold.nz 21 100% n.oof.nz 10 100% CV all CVRSq 0.929 n.infold.nz 31 100% > printh(a3$cv.rsq.tab) === a3$cv.rsq.tab Volume mean fold1 0.9209881 0.9209881 fold2 0.9492484 0.9492484 fold3 0.9157070 0.9157070 mean 0.9286478 0.9286478 > printh(a3) === a3 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9286478 > printh(summary(a3)) === summary(a3) Call: earth(formula=Volume~Girth, data=trees, trace=0.5, nfold=3) coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9286478 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.929 0.018 10.4 2.37 > cat("a4 <- update(a0, nfold=0, trace=.5) # should not do cv\n") a4 <- update(a0, nfold=0, trace=.5) # should not do cv > set.seed(4) > a4 <- update(a0, nfold=0, trace=.5) > cat("a5 <- update(a4, trace=.5) # should not do cv\n") a5 <- update(a4, trace=.5) # should not do cv > set.seed(5) > a5 <- update(a4) > cat("a5a <- update(a4, nfold=2, trace=.5) # should do cv\n") a5a <- update(a4, nfold=2, trace=.5) # should do cv > set.seed(2) > a5a <- update(a4, nfold=2, trace=.5) Full model GRSq 0.960 RSq 0.974, starting cross validation CV fold 1 CVRSq 0.910 n.oof 15 52% n.infold.nz 15 100% n.oof.nz 16 100% CV fold 2 CVRSq 0.911 n.oof 16 48% n.infold.nz 16 100% n.oof.nz 15 100% CV all CVRSq 0.911 n.infold.nz 31 100% > > cat("a6: titanic data, one logical response\n\n") a6: titanic data, one logical response > survived. <- as.logical(etitanic$survived) > set.seed(6) > a6 <- earth(survived. ~ ., data=etitanic[,-2], degree=2, glm=list(family="binomial"), trace=0.5, ncross=2, nfold=3) Full model GRSq 0.420 RSq 0.439, starting cross validation CV fold 1.1 CVRSq 0.414 n.oof 706 33% n.infold.nz 284 40% n.oof.nz 143 42% CV fold 1.2 CVRSq 0.350 n.oof 696 33% n.infold.nz 285 41% n.oof.nz 142 41% CV fold 1.3 CVRSq 0.400 n.oof 690 34% n.infold.nz 285 41% n.oof.nz 142 40% CV fold 2.1 CVRSq 0.406 n.oof 683 35% n.infold.nz 284 42% n.oof.nz 143 39% CV fold 2.2 CVRSq 0.417 n.oof 714 32% n.infold.nz 285 40% n.oof.nz 142 43% CV fold 2.3 CVRSq 0.425 n.oof 695 34% n.infold.nz 285 41% n.oof.nz 142 40% CV all CVRSq 0.402 n.infold.nz 427 41% > printh(a6) === a6 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 Termination condition: Reached nk 21 Importance: sexmale, 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 CVRSq 0.4018797 > printh(summary(a6)) === summary(a6) Call: earth(formula=survived.~., data=etitanic[,-2], trace=0.5, glm=list(family="binomial"), degree=2, nfold=3, ncross=2) GLM coefficients survived. (Intercept) 2.9135260 pclass3rd -5.0300560 sexmale -3.1856245 h(age-32) -0.0375715 pclass2nd * sexmale -1.7680945 pclass3rd * sexmale 1.2226954 pclass3rd * h(4-sibsp) 0.6186527 sexmale * 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 Termination condition: Reached nk 21 Importance: sexmale, 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 CVRSq 0.4018797 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 8.83 sd 0.75 nvars 5.33 sd 0.52 CVRSq sd ClassRate sd MaxErr sd AUC sd MeanDev sd CalibInt sd CalibSlope sd 0.402 0.027 0.796 0.007 0.996 1.07 0.849 0.014 0.906 0.0358 -0.033 0.142 0.895 0.076 > plotmo(a6) plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > printh(a6$cv.list[[2]]) === a6$cv.list[[2]] GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 941.924 695 571.823 687 0.393 589.8 5 1 Earth selected 9 of 16 terms, and 5 of 6 predictors Termination condition: Reached nk 21 Number of terms at each degree of interaction: 1 4 4 Earth GCV 0.139433 RSS 91.27752 GRSq 0.4250256 RSq 0.4576415 > printh(summary(a6$cv.list[[2]])) === summary(a6$cv.list[[2]]) Call: earth(x=infold.x, y=infold.y, weights=infold.weights, wp=wp, subset=subset, pmethod=if(pmethod=="cv")"backward"elsepmethod, keepxy=(keepxy==2), trace=trace, glm=glm.arg, degree=degree, nfold=0, ncross=0, varmod.method="none", Scale.y=Scale.y) GLM coefficients survived. (Intercept) 4.7078105 pclass2nd -1.8772666 pclass3rd -5.3284067 sexmale -4.2764317 h(age-3) -0.0296751 pclass3rd * sexmale 2.4648967 pclass3rd * h(14-age) -0.1804096 pclass3rd * h(2-sibsp) 0.7289378 sexmale * h(17-age) 0.2652321 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 941.924 695 571.823 687 0.393 589.8 5 1 Earth selected 9 of 16 terms, and 5 of 6 predictors Termination condition: Reached nk 21 Number of terms at each degree of interaction: 1 4 4 Earth GCV 0.139433 RSS 91.27752 GRSq 0.4250256 RSq 0.4576415 > print.stripped.earth.model(a6, "a6") print.stripped.earth.model(a6) $rsq [1] 0.4389834 $gcv [1] 0.1404529 $grsq [1] 0.4197106 $dirs pclass2nd pclass3rd sexmale age sibsp parch (Intercept) 0 0 0 0 0 0 sexmale 0 0 2 0 0 0 pclass3rd 0 2 0 0 0 0 sexmale*h(age-16) 0 0 2 1 0 0 sexmale*h(16-age) 0 0 2 -1 0 0 pclass2nd*sexmale 2 0 2 0 0 0 pclass3rd*h(sibsp-4) 0 2 0 0 1 0 pclass3rd*h(4-sibsp) 0 2 0 0 -1 0 h(parch-1) 0 0 0 0 0 1 h(1-parch) 0 0 0 0 0 -1 pclass3rd*sexmale 0 2 2 0 0 0 sexmale*h(sibsp-1) 0 0 2 0 1 0 sexmale*h(1-sibsp) 0 0 2 0 -1 0 h(age-17)*h(1-parch) 0 0 0 1 0 -1 h(17-age)*h(1-parch) 0 0 0 -1 0 -1 h(age-32) 0 0 0 1 0 0 h(32-age) 0 0 0 -1 0 0 $cuts pclass2nd pclass3rd sexmale age sibsp parch (Intercept) 0 0 0 0 0 0 sexmale 0 0 0 0 0 0 pclass3rd 0 0 0 0 0 0 sexmale*h(age-16) 0 0 0 16 0 0 sexmale*h(16-age) 0 0 0 16 0 0 pclass2nd*sexmale 0 0 0 0 0 0 pclass3rd*h(sibsp-4) 0 0 0 0 4 0 pclass3rd*h(4-sibsp) 0 0 0 0 4 0 h(parch-1) 0 0 0 0 0 1 h(1-parch) 0 0 0 0 0 1 pclass3rd*sexmale 0 0 0 0 0 0 sexmale*h(sibsp-1) 0 0 0 0 1 0 sexmale*h(1-sibsp) 0 0 0 0 1 0 h(age-17)*h(1-parch) 0 0 0 17 0 1 h(17-age)*h(1-parch) 0 0 0 17 0 1 h(age-32) 0 0 0 32 0 0 h(32-age) 0 0 0 32 0 0 $selected.terms [1] 1 2 3 5 6 8 11 16 $prune.terms [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [,14] [,15] [,16] [,17] [1,] 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [2,] 1 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [3,] 1 2 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [4,] 1 2 3 6 0 0 0 0 0 0 0 0 0 0 0 0 0 [5,] 1 2 3 5 6 0 0 0 0 0 0 0 0 0 0 0 0 [6,] 1 2 3 5 6 8 0 0 0 0 0 0 0 0 0 0 0 [7,] 1 2 3 4 5 6 8 0 0 0 0 0 0 0 0 0 0 [8,] 1 2 3 5 6 8 11 16 0 0 0 0 0 0 0 0 0 [9,] 1 2 3 5 6 8 10 11 16 0 0 0 0 0 0 0 0 [10,] 1 2 3 5 6 8 9 10 11 16 0 0 0 0 0 0 0 [11,] 1 2 3 5 6 8 9 10 11 15 16 0 0 0 0 0 0 [12,] 1 2 3 5 6 8 9 10 11 14 15 16 0 0 0 0 0 [13,] 1 2 3 4 5 6 8 9 10 11 14 15 16 0 0 0 0 [14,] 1 2 3 4 5 6 8 9 10 11 12 14 15 16 0 0 0 [15,] 1 2 3 4 5 6 8 9 10 11 12 13 14 15 16 0 0 [16,] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 0 [17,] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 $coefficients survived. (Intercept) 0.961709504 sexmale -0.570034960 pclass3rd -0.815453521 sexmale*h(16-age) 0.045052323 pclass2nd*sexmale -0.265689205 pclass3rd*h(4-sibsp) 0.102221809 pclass3rd*sexmale 0.193102034 h(age-32) -0.004719378 $rss.per.response [1] 141.7629 $rsq.per.response [1] 0.4389834 $gcv.per.response [1] 0.1404529 $grsq.per.response [1] 0.4197106 $rss.per.subset [1] 252.6893 179.5499 167.7515 159.6526 151.2288 145.4049 143.0839 141.7629 141.4108 140.6857 140.0308 139.7756 139.4650 139.2047 139.0511 138.9389 138.9223 $gcv.per.subset [1] 0.2420393 0.1728083 0.1622301 0.1551427 0.1476677 0.1426693 0.1410744 0.1404529 0.1407883 0.1407521 0.1407846 0.1412193 0.1416005 0.1420350 0.1425815 0.1431744 0.1438705 $leverages [1] 0.004844979 0.048080311 0.004844979 0.008718349 0.004844979 0.006944951 0.013758765 0.006963068 0.007618618 0.018340762 0.006822593 0.004844979 0.004844979 0.004844979 0.027277340 0.008718349 [17] 0.006382881 0.004844979 0.007528775 0.007309114 0.005426979 0.008718349 0.004455662 0.004844979 0.008718349 0.008718349 0.004844979 0.004401711 0.008718349 0.006671156 0.006836684 0.004844979 [33] 0.010300033 0.006677195 0.004945174 0.004844979 0.006741393 0.006944951 0.004750910 0.010929594 0.011590248 0.004354676 0.006671156 0.006677195 0.007618618 0.007528775 0.010300033 0.008374317 [49] 0.008718349 0.008718349 0.012291127 0.004844979 0.007528775 0.004316140 0.007098402 0.007528775 0.026389314 0.006731328 0.005426979 0.008718349 0.004666130 0.004316140 0.004844979 0.006671156 [65] 0.008718349 0.004844979 0.004844979 0.006822593 0.004245984 0.007309114 0.014543790 0.008597906 0.017503273 0.004316140 0.014543790 0.006963068 0.004238276 0.007498581 0.008718349 0.004666130 [81] 0.008718349 0.004844979 0.008718349 0.004844979 0.008023130 0.033080206 0.008092716 0.007282945 0.004844979 0.005714520 0.005714520 0.007098402 0.006963068 0.004844979 0.004238276 0.008092716 [97] 0.004316140 0.007528775 0.008718349 0.004844979 0.004844979 0.004844979 0.008718349 0.013131281 0.011590248 0.004844979 0.007282945 0.006644089 0.004844979 0.010838474 0.005714520 0.007309114 [113] 0.004401711 0.006822593 0.004401711 0.004844979 0.004945174 0.008718349 0.007098402 0.018340762 0.008023130 0.004844979 0.007120544 0.010300033 0.008718349 0.004945174 0.006731328 0.008718349 [129] 0.004844979 0.006944951 0.006033154 0.006671156 0.004401711 0.006836684 0.008718349 0.004844979 0.008672051 0.007175613 0.006677195 0.008672051 0.004844979 0.004750910 0.006763701 0.006677195 [145] 0.004401711 0.007779530 0.007120544 0.004401711 0.004238276 0.006382881 0.007098402 0.006731328 0.007282945 0.008542447 0.009878627 0.006741393 0.006677195 0.004945174 0.004245984 0.006033154 [161] 0.004844979 0.007779530 0.006677195 0.008597906 0.004844979 0.006763701 0.008718349 0.004844979 0.008718349 0.010300033 0.004844979 0.008718349 0.004844979 0.008718349 0.004844979 0.004844979 [177] 0.006731328 0.008332044 0.007528775 0.008718349 0.013782215 0.006642076 0.004666130 0.004261662 0.008718349 0.008672051 0.006822593 0.007309114 0.004844979 0.004844979 0.009878627 0.004844979 [193] 0.013131281 0.004245984 0.004844979 0.013782215 0.008718349 0.006697356 0.008718349 0.008718349 0.004844979 0.008718349 0.004844979 0.004844979 0.007745309 0.006822593 0.009134189 0.007120544 [209] 0.008718349 0.004587740 0.008718349 0.006671156 0.004666130 0.006731328 0.007528775 0.004666130 0.008672051 0.008092716 0.008374317 0.009734359 0.004844979 0.004844979 0.011365037 0.005714520 [225] 0.004844979 0.004401711 0.004844979 0.008061377 0.004284784 0.007779530 0.007282945 0.004245984 0.009043150 0.008718349 0.009043150 0.009043150 0.008718349 0.004844979 0.008718349 0.004844979 [241] 0.025261042 0.006671156 0.004284784 0.009445342 0.008718349 0.011922692 0.008332044 0.004587740 0.007175613 0.013004834 0.015177360 0.013758765 0.011365037 0.005714520 0.004844979 0.007745309 [257] 0.004245984 0.006944951 0.007098402 0.008718349 0.004245984 0.008718349 0.006836684 0.011365037 0.006822593 0.004401711 0.013131281 0.011590248 0.010838474 0.008332044 0.008718349 0.008597906 [273] 0.004844979 0.009445342 0.004945174 0.007282945 0.008718349 0.006382881 0.004844979 0.007498581 0.008718349 0.004844979 0.011922692 0.004316140 0.006891233 0.004844979 0.006891233 0.006891233 [289] 0.006891233 0.006638257 0.004316140 0.012668178 0.006891233 0.006891233 0.004316140 0.006891233 0.009509428 0.006891233 0.004844979 0.006891233 0.043204039 0.004844979 0.004844979 0.004316140 [305] 0.006638257 0.004844979 0.006891233 0.006891233 0.006870060 0.006891233 0.004844979 0.004844979 0.014667305 0.004284784 0.004844979 0.006891233 0.004316140 0.006891233 0.006870060 0.004455662 [321] 0.044082769 0.006891233 0.004844979 0.004401711 0.006891233 0.004750910 0.010948886 0.009958155 0.006491988 0.004844979 0.004844979 0.004945174 0.006891233 0.004844979 0.006891233 0.006891233 [337] 0.006891233 0.004844979 0.006891233 0.004844979 0.004844979 0.004844979 0.006891233 0.015733269 0.006891233 0.005714520 0.004844979 0.006891233 0.006891233 0.006891233 0.004844979 0.006891233 [353] 0.006891233 0.004844979 0.004518374 0.010948886 0.015733269 0.006870060 0.004518374 0.004844979 0.004844979 0.006891233 0.006891233 0.006891233 0.006625553 0.004844979 0.006891233 0.006509652 [369] 0.004238276 0.006558408 0.006505417 0.006638257 0.004518374 0.006891233 0.006891233 0.008025449 0.006891233 0.006891233 0.006891233 0.006891233 0.006638257 0.006891233 0.009958155 0.006891233 [385] 0.044971407 0.004844979 0.007238937 0.004844979 0.006891233 0.016155519 0.006891233 0.004844979 0.007038952 0.004945174 0.004844979 0.004844979 0.008705253 0.005714520 0.008597906 0.006891233 [401] 0.006891233 0.006891233 0.004844979 0.004844979 0.006891233 0.006509652 0.008092716 0.009091794 0.007238937 0.004844979 0.006891233 0.006870060 0.016946265 0.011590248 0.006749199 0.004844979 [417] 0.006870060 0.004844979 0.008025449 0.006891233 0.006891233 0.006891233 0.004844979 0.006638257 0.004844979 0.004844979 0.006558408 0.004945174 0.012668178 0.006891233 0.004844979 0.006891233 [433] 0.004844979 0.004844979 0.006891233 0.004844979 0.004844979 0.004518374 0.006509652 0.006891233 0.015395865 0.009091794 0.004455662 0.009701565 0.043204039 0.006891233 0.004844979 0.006891233 [449] 0.006625553 0.006891233 0.006891233 0.007732185 0.004844979 0.004354676 0.006891233 0.006549939 0.008349805 0.023352084 0.006891233 0.010948886 0.006549939 0.006891233 0.016155519 0.006816329 [465] 0.004844979 0.038151987 0.033475820 0.006496933 0.006891233 0.006891233 0.006891233 0.006891233 0.004844979 0.006549939 0.006891233 0.006891233 0.006891233 0.006891233 0.006382881 0.006891233 [481] 0.006732260 0.004844979 0.004844979 0.007038952 0.004844979 0.006638257 0.006891233 0.006891233 0.004844979 0.004844979 0.004666130 0.006509652 0.006638257 0.004844979 0.004844979 0.006891233 [497] 0.044082769 0.033475820 0.004844979 0.006382881 0.006891233 0.004844979 0.006891233 0.006891233 0.006891233 0.004844979 0.004844979 0.004844979 0.004844979 0.013969836 0.004844979 0.006558408 [513] 0.004284784 0.006891233 0.006732260 0.006891233 0.006891233 0.006846429 0.006382881 0.006891233 0.004844979 0.004844979 0.006891233 0.004844979 0.006625553 0.004844979 0.006891233 0.006891233 [529] 0.004844979 0.004844979 0.004284784 0.004751668 0.006891233 0.004844979 0.038151987 0.004844979 0.004844979 0.004844979 0.004844979 0.006509652 0.004666130 0.019505060 0.006891233 0.004844979 [545] 0.004844979 0.004135506 0.004452488 0.004046722 0.006769445 0.007704959 0.003404693 0.003404693 0.007704959 0.003404693 0.003404693 0.007383781 0.043382716 0.007704959 0.003404693 0.003404693 [561] 0.003404693 0.003404693 0.003404693 0.003297464 0.003404693 0.003404693 0.006773955 0.032986536 0.028775859 0.028775859 0.028775859 0.029121958 0.028775859 0.028775859 0.004261096 0.003404693 [577] 0.003404693 0.007198728 0.003404693 0.003404693 0.004046722 0.006773955 0.003404693 0.003297464 0.030734265 0.025484035 0.035614692 0.026247972 0.028775859 0.004416091 0.003404693 0.007044768 [593] 0.009652064 0.003404693 0.003404693 0.007704959 0.003404693 0.003404693 0.007704959 0.003404693 0.004046722 0.017285175 0.009975438 0.009975438 0.009975438 0.007704959 0.007704959 0.003740602 [609] 0.003404693 0.003404693 0.007704959 0.009652064 0.007704959 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.016055741 0.006773955 [625] 0.004416091 0.006773955 0.003404693 0.007704959 0.007704959 0.004046722 0.004046722 0.003404693 0.003297464 0.007704959 0.003404693 0.003404693 0.007704959 0.007704959 0.007704959 0.003404693 [641] 0.003470069 0.003404693 0.003404693 0.007704959 0.003404693 0.003404693 0.003404693 0.003404693 0.007704959 0.007831992 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.004046722 [657] 0.004046722 0.003404693 0.003404693 0.003404693 0.003323906 0.003404693 0.003404693 0.003404693 0.007704959 0.007704959 0.023276548 0.004379597 0.003297464 0.003404693 0.003404693 0.003404693 [673] 0.008506238 0.026988214 0.007744400 0.012513659 0.003404693 0.007704959 0.004654781 0.003404693 0.003404693 0.004961057 0.007704959 0.003404693 0.007704959 0.003404693 0.046172892 0.003952508 [689] 0.006773955 0.003404693 0.003404693 0.008821237 0.003404693 0.008821237 0.008821237 0.004009637 0.006830127 0.003404693 0.003404693 0.036155957 0.006773955 0.004046722 0.006741359 0.003404693 [705] 0.003404693 0.003323906 0.007704959 0.003404693 0.004135506 0.004379597 0.003404693 0.003404693 0.007704959 0.007704959 0.007704959 0.003337857 0.017616050 0.003404693 0.004046722 0.006773955 [721] 0.003404693 0.003404693 0.004961057 0.003589789 0.004046722 0.003556140 0.005666888 0.007704959 0.003827668 0.003827668 0.003404693 0.003404693 0.009975438 0.009975438 0.008821237 0.004046722 [737] 0.009983538 0.003404693 0.003404693 0.007704959 0.011111944 0.003984069 0.003922507 0.006773955 0.003470069 0.025484035 0.041998662 0.025114233 0.028775859 0.028775859 0.027378671 0.004416091 [753] 0.008125495 0.007451662 0.003404693 0.003404693 0.008839810 0.008821237 0.003404693 0.007704959 0.007704959 0.004046722 0.006773955 0.003404693 0.003404693 0.009414337 0.004046722 0.003404693 [769] 0.008775434 0.003404693 0.007030445 0.003404693 0.007704959 0.007704959 0.007704959 0.007704959 0.003404693 0.007704959 0.007704959 0.006773955 0.004379597 0.003404693 0.007704959 0.004135506 [785] 0.003404693 0.006773955 0.006773955 0.003404693 0.003404693 0.003404693 0.006066442 0.004046722 0.003302114 0.003404693 0.003404693 0.003337857 0.003404693 0.003404693 0.022968171 0.006773955 [801] 0.006497090 0.003337857 0.003404693 0.007704959 0.003404693 0.003404693 0.003404693 0.006773955 0.006773955 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003337857 0.003404693 [817] 0.007704959 0.003589789 0.003404693 0.003295902 0.004654781 0.009975438 0.008821237 0.007704959 0.017728237 0.006773955 0.006773955 0.004046722 0.007744400 0.003404693 0.007831992 0.007704959 [833] 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003295902 0.003323906 0.003589789 0.003404693 0.007704959 0.009652064 0.003982665 0.006773955 0.004046722 0.003404693 [849] 0.004046722 0.006773955 0.003404693 0.003404693 0.007451662 0.007704959 0.003404693 0.003404693 0.003404693 0.003404693 0.007704959 0.003297464 0.003337857 0.007704959 0.007687900 0.004046722 [865] 0.006773955 0.010054180 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.020053334 0.007704959 0.003302114 0.007704959 0.003404693 0.003404693 0.007704959 0.007704959 0.004046722 [881] 0.006773955 0.003337857 0.004339704 0.006773955 0.007704959 0.003404693 0.007704959 0.007704959 0.003404693 0.003922507 0.003589789 0.003404693 0.003404693 0.007704959 0.014090085 0.003404693 [897] 0.007704959 0.011111944 0.003404693 0.004135506 0.007704959 0.003404693 0.003404693 0.003404693 0.007704959 0.007704959 0.003404693 0.003404693 0.007704959 0.032074718 0.020458014 0.017309406 [913] 0.017309406 0.007704959 0.041998662 0.027357379 0.038618735 0.030767723 0.027378671 0.008493286 0.003404693 0.003404693 0.003404693 0.037407643 0.006773955 0.007704959 0.003404693 0.003404693 [929] 0.003404693 0.004046722 0.003404693 0.007704959 0.003404693 0.004046722 0.007704959 0.003404693 0.003404693 0.003404693 0.003470069 0.003404693 0.025111191 0.032986536 0.027357379 0.038618735 [945] 0.026232764 0.008100454 0.007704959 0.003297464 0.007676145 0.009549744 0.006773955 0.004046722 0.008493286 0.006958829 0.003404693 0.003404693 0.003526042 0.028084977 0.003404693 0.007704959 [961] 0.003589789 0.006773955 0.007704959 0.006773955 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003740602 0.003404693 0.007704959 0.025514595 0.014855477 0.017309406 0.017309406 [977] 0.004416091 0.008775434 0.003404693 0.003404693 0.003404693 0.003337857 0.007704959 0.003404693 0.013684319 0.003404693 0.007704959 0.003404693 0.003404693 0.007704959 0.006773955 0.003404693 [993] 0.004654781 0.003404693 0.027368393 0.003727337 0.003404693 0.003404693 0.003302114 0.045700960 0.006773955 0.003404693 0.003404693 0.004654781 0.003404693 0.013163355 0.006773955 0.007704959 [1009] 0.003323906 0.007704959 0.021022916 0.004799198 0.003827668 0.007704959 0.003982665 0.006773955 0.003337857 0.003404693 0.003404693 0.005666888 0.009975438 0.017728237 0.008821237 0.006773955 [1025] 0.003404693 0.003404693 0.007704959 0.003404693 0.003404693 0.003367389 0.007950676 0.007451662 0.004046722 0.004046722 0.009549744 0.003404693 0.003404693 0.003404693 0.003323906 0.004046722 [1041] 0.006773955 0.005125855 0.006773955 0.003404693 0.003404693 0.003404693 $pmethod [1] "backward" $nprune NULL $penalty [1] 3 $nk [1] 21 $thresh [1] 0.001 $termcond [1] 7 $weights NULL $glm.list $glm.list[[1]] Call: glm(formula = yarg ~ ., family = family, data = bx.data.frame, weights = weights, na.action = na.action, offset = offset, control = control, model = TRUE, method = "glm.fit", x = TRUE, y = TRUE, contrasts = NULL, trace = (trace >= 2)) Coefficients: (Intercept) sexmale pclass3rd `sexmale*h(16-age)` `pclass2nd*sexmale` `pclass3rd*h(4-sibsp)` `pclass3rd*sexmale` `h(age-32)` 2.91353 -3.18562 -5.03006 0.24181 -1.76809 0.61865 1.22270 -0.03757 Degrees of Freedom: 1045 Total (i.e. Null); 1038 Residual Null Deviance: 1415 Residual Deviance: 892.8 AIC: 908.8 $glm.coefficients survived. (Intercept) 2.91352601 sexmale -3.18562450 pclass3rd -5.03005596 sexmale*h(16-age) 0.24181403 pclass2nd*sexmale -1.76809448 pclass3rd*h(4-sibsp) 0.61865275 pclass3rd*sexmale 1.22269536 h(age-32) -0.03757149 $glm.stats nulldev df dev df devratio AIC iters converged 1414.62 1045 892.794 1038 0.3688809 908.794 5 1 $call earth(formula = survived. ~ ., data = etitanic[, -2], trace = 0.5, glm = list(family = "binomial"), degree = 2, nfold = 3, ncross = 2) $namesx.org [1] "pclass" "sex" "age" "sibsp" "parch" $namesx [1] "pclass" "sex" "age" "sibsp" "parch" $terms survived. ~ pclass + sex + age + sibsp + parch attr(,"variables") list(survived., pclass, sex, age, sibsp, parch) attr(,"factors") pclass sex age sibsp parch survived. 0 0 0 0 0 pclass 1 0 0 0 0 sex 0 1 0 0 0 age 0 0 1 0 0 sibsp 0 0 0 1 0 parch 0 0 0 0 1 attr(,"term.labels") [1] "pclass" "sex" "age" "sibsp" "parch" attr(,"order") [1] 1 1 1 1 1 attr(,"intercept") [1] 1 attr(,"response") [1] 1 attr(,".Environment") attr(,"predvars") list(survived., pclass, sex, age, sibsp, parch) attr(,"dataClasses") survived. pclass sex age sibsp parch "logical" "factor" "factor" "numeric" "numeric" "numeric" $xlevels $xlevels$pclass [1] "1st" "2nd" "3rd" $xlevels$sex [1] "female" "male" $levels [1] FALSE TRUE $cv.list $cv.list$fold1.1 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 951.575 705 593.153 697 0.377 611.2 5 1 Earth selected 9 of 16 terms, and 6 of 6 predictors Termination condition: Reached nk 21 Number of terms at each degree of interaction: 1 2 6 Earth GCV 0.141466 RSS 94.02177 GRSq 0.4133225 RSq 0.446137 $cv.list$fold1.2 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 941.924 695 571.823 687 0.393 589.8 5 1 Earth selected 9 of 16 terms, and 5 of 6 predictors Termination condition: Reached nk 21 Number of terms at each degree of interaction: 1 4 4 Earth GCV 0.139433 RSS 91.27752 GRSq 0.4250256 RSq 0.4576415 $cv.list$fold1.3 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 935.567 689 576.117 681 0.384 594.1 6 1 Earth selected 9 of 16 terms, and 5 of 6 predictors Termination condition: Reached nk 21 Number of terms at each degree of interaction: 1 3 5 Earth GCV 0.1425002 RSS 92.43118 GRSq 0.413924 RSq 0.4474549 $cv.list$fold2.1 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 927.383 682 570.118 675 0.385 586.1 5 1 Earth selected 8 of 16 terms, and 5 of 6 predictors Termination condition: Reached nk 21 Number of terms at each degree of interaction: 1 3 4 Earth GCV 0.1405264 RSS 90.85047 GRSq 0.4231865 RSq 0.4524085 $cv.list$fold2.2 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 960.572 713 604.611 706 0.371 620.6 5 1 Earth selected 8 of 16 terms, and 5 of 6 predictors Termination condition: Reached nk 21 Number of terms at each degree of interaction: 1 2 5 Earth GCV 0.1407293 RSS 95.34121 GRSq 0.4148577 RSq 0.4432289 $cv.list$fold2.3 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 940.87 694 595.92 685 0.367 615.9 5 1 Earth selected 10 of 15 terms, and 6 of 6 predictors Termination condition: Reached nk 21 Number of terms at each degree of interaction: 1 3 6 Earth GCV 0.1472498 RSS 95.53491 GRSq 0.3930609 RSq 0.4317778 $cv.nterms.selected.by.gcv fold1.1 fold1.2 fold1.3 fold2.1 fold2.2 fold2.3 mean 9.000000 9.000000 9.000000 8.000000 8.000000 10.000000 8.833333 $cv.nvars.selected.by.gcv fold1.1 fold1.2 fold1.3 fold2.1 fold2.2 fold2.3 mean 6.000000 5.000000 5.000000 5.000000 5.000000 6.000000 5.333333 $cv.groups cross fold [1,] 1 1 [2,] 1 2 [3,] 1 2 [4,] 1 1 [5,] 1 3 [6,] 1 3 [7,] 1 2 [8,] 1 1 [9,] 1 1 [10,] 1 2 [11,] 1 2 [12,] 1 1 [13,] 1 1 [14,] 1 3 [15,] 1 3 [16,] 1 1 [17,] 1 1 [18,] 1 2 [19,] 1 3 [20,] 1 1 [21,] 1 2 [22,] 1 2 [23,] 1 3 [24,] 1 1 [25,] 1 3 [26,] 1 3 [27,] 1 1 [28,] 1 3 [29,] 1 3 [30,] 1 2 [31,] 1 2 [32,] 1 3 [33,] 1 3 [34,] 1 3 [35,] 1 2 [36,] 1 1 [37,] 1 1 [38,] 1 3 [39,] 1 3 [40,] 1 1 [41,] 1 3 [42,] 1 3 [43,] 1 1 [44,] 1 2 [45,] 1 3 [46,] 1 2 [47,] 1 2 [48,] 1 1 [49,] 1 3 [50,] 1 2 [51,] 1 1 [52,] 1 2 [53,] 1 1 [54,] 1 1 [55,] 1 3 [56,] 1 3 [57,] 1 1 [58,] 1 3 [59,] 1 1 [60,] 1 3 [61,] 1 3 [62,] 1 2 [63,] 1 1 [64,] 1 2 [65,] 1 1 [66,] 1 3 [67,] 1 3 [68,] 1 3 [69,] 1 1 [70,] 1 2 [71,] 1 3 [72,] 1 2 [73,] 1 1 [74,] 1 2 [75,] 1 1 [76,] 1 3 [77,] 1 1 [78,] 1 3 [79,] 1 1 [80,] 1 3 [81,] 1 3 [82,] 1 3 [83,] 1 3 [84,] 1 2 [85,] 1 2 [86,] 1 2 [87,] 1 1 [88,] 1 2 [89,] 1 3 [90,] 1 2 [91,] 1 3 [92,] 1 1 [93,] 1 2 [94,] 1 3 [95,] 1 1 [96,] 1 1 [97,] 1 2 [98,] 1 1 [99,] 1 3 [100,] 1 1 [101,] 1 3 [102,] 1 1 [103,] 1 3 [104,] 1 2 [105,] 1 3 [106,] 1 3 [107,] 1 3 [108,] 1 2 [109,] 1 1 [110,] 1 3 [111,] 1 2 [112,] 1 1 [113,] 1 2 [114,] 1 2 [115,] 1 3 [116,] 1 1 [117,] 1 1 [118,] 1 3 [119,] 1 1 [120,] 1 2 [121,] 1 2 [122,] 1 2 [123,] 1 1 [124,] 1 3 [125,] 1 1 [126,] 1 1 [127,] 1 2 [128,] 1 1 [129,] 1 1 [130,] 1 1 [131,] 1 3 [132,] 1 2 [133,] 1 1 [134,] 1 1 [135,] 1 2 [136,] 1 3 [137,] 1 2 [138,] 1 1 [139,] 1 1 [140,] 1 2 [141,] 1 2 [142,] 1 3 [143,] 1 1 [144,] 1 2 [145,] 1 3 [146,] 1 3 [147,] 1 1 [148,] 1 3 [149,] 1 3 [150,] 1 3 [151,] 1 3 [152,] 1 3 [153,] 1 2 [154,] 1 1 [155,] 1 2 [156,] 1 1 [157,] 1 3 [158,] 1 2 [159,] 1 1 [160,] 1 2 [161,] 1 3 [162,] 1 2 [163,] 1 2 [164,] 1 2 [165,] 1 1 [166,] 1 1 [167,] 1 3 [168,] 1 1 [169,] 1 3 [170,] 1 3 [171,] 1 3 [172,] 1 2 [173,] 1 1 [174,] 1 2 [175,] 1 3 [176,] 1 2 [177,] 1 2 [178,] 1 3 [179,] 1 2 [180,] 1 1 [181,] 1 3 [182,] 1 3 [183,] 1 2 [184,] 1 3 [185,] 1 2 [186,] 1 2 [187,] 1 2 [188,] 1 2 [189,] 1 2 [190,] 1 2 [191,] 1 3 [192,] 1 3 [193,] 1 2 [194,] 1 2 [195,] 1 2 [196,] 1 1 [197,] 1 1 [198,] 1 2 [199,] 1 2 [200,] 1 2 [201,] 1 2 [202,] 1 3 [203,] 1 3 [204,] 1 1 [205,] 1 1 [206,] 1 1 [207,] 1 2 [208,] 1 3 [209,] 1 1 [210,] 1 2 [211,] 1 1 [212,] 1 1 [213,] 1 1 [214,] 1 3 [215,] 1 2 [216,] 1 2 [217,] 1 2 [218,] 1 3 [219,] 1 3 [220,] 1 2 [221,] 1 2 [222,] 1 3 [223,] 1 3 [224,] 1 2 [225,] 1 1 [226,] 1 2 [227,] 1 2 [228,] 1 2 [229,] 1 1 [230,] 1 2 [231,] 1 3 [232,] 1 3 [233,] 1 2 [234,] 1 1 [235,] 1 2 [236,] 1 3 [237,] 1 2 [238,] 1 1 [239,] 1 2 [240,] 1 1 [241,] 1 1 [242,] 1 2 [243,] 1 2 [244,] 1 2 [245,] 1 3 [246,] 1 1 [247,] 1 3 [248,] 1 3 [249,] 1 1 [250,] 1 1 [251,] 1 2 [252,] 1 2 [253,] 1 1 [254,] 1 3 [255,] 1 3 [256,] 1 3 [257,] 1 3 [258,] 1 2 [259,] 1 1 [260,] 1 3 [261,] 1 1 [262,] 1 1 [263,] 1 3 [264,] 1 3 [265,] 1 3 [266,] 1 1 [267,] 1 2 [268,] 1 1 [269,] 1 3 [270,] 1 1 [271,] 1 3 [272,] 1 3 [273,] 1 1 [274,] 1 2 [275,] 1 3 [276,] 1 2 [277,] 1 3 [278,] 1 3 [279,] 1 1 [280,] 1 3 [281,] 1 3 [282,] 1 1 [283,] 1 2 [284,] 1 2 [285,] 1 2 [286,] 1 2 [287,] 1 2 [288,] 1 2 [289,] 1 1 [290,] 1 3 [291,] 1 2 [292,] 1 3 [293,] 1 2 [294,] 1 2 [295,] 1 3 [296,] 1 2 [297,] 1 3 [298,] 1 1 [299,] 1 1 [300,] 1 1 [301,] 1 3 [302,] 1 3 [303,] 1 3 [304,] 1 1 [305,] 1 2 [306,] 1 1 [307,] 1 3 [308,] 1 1 [309,] 1 3 [310,] 1 3 [311,] 1 1 [312,] 1 3 [313,] 1 1 [314,] 1 2 [315,] 1 3 [316,] 1 2 [317,] 1 3 [318,] 1 2 [319,] 1 2 [320,] 1 3 [321,] 1 2 [322,] 1 1 [323,] 1 1 [324,] 1 1 [325,] 1 3 [326,] 1 1 [327,] 1 3 [328,] 1 2 [329,] 1 1 [330,] 1 2 [331,] 1 3 [332,] 1 3 [333,] 1 3 [334,] 1 3 [335,] 1 3 [336,] 1 3 [337,] 1 2 [338,] 1 2 [339,] 1 2 [340,] 1 3 [341,] 1 3 [342,] 1 2 [343,] 1 1 [344,] 1 1 [345,] 1 2 [346,] 1 2 [347,] 1 1 [348,] 1 2 [349,] 1 2 [350,] 1 1 [351,] 1 2 [352,] 1 2 [353,] 1 2 [354,] 1 3 [355,] 1 1 [356,] 1 3 [357,] 1 1 [358,] 1 2 [359,] 1 1 [360,] 1 3 [361,] 1 2 [362,] 1 1 [363,] 1 1 [364,] 1 3 [365,] 1 3 [366,] 1 1 [367,] 1 1 [368,] 1 1 [369,] 1 1 [370,] 1 2 [371,] 1 2 [372,] 1 2 [373,] 1 1 [374,] 1 2 [375,] 1 1 [376,] 1 2 [377,] 1 2 [378,] 1 3 [379,] 1 2 [380,] 1 1 [381,] 1 1 [382,] 1 2 [383,] 1 3 [384,] 1 2 [385,] 1 2 [386,] 1 1 [387,] 1 2 [388,] 1 2 [389,] 1 1 [390,] 1 2 [391,] 1 1 [392,] 1 1 [393,] 1 3 [394,] 1 3 [395,] 1 2 [396,] 1 1 [397,] 1 2 [398,] 1 3 [399,] 1 3 [400,] 1 2 [401,] 1 2 [402,] 1 3 [403,] 1 1 [404,] 1 1 [405,] 1 1 [406,] 1 3 [407,] 1 1 [408,] 1 1 [409,] 1 1 [410,] 1 2 [411,] 1 3 [412,] 1 3 [413,] 1 2 [414,] 1 1 [415,] 1 1 [416,] 1 2 [417,] 1 2 [418,] 1 3 [419,] 1 1 [420,] 1 2 [421,] 1 2 [422,] 1 1 [423,] 1 1 [424,] 1 1 [425,] 1 3 [426,] 1 1 [427,] 1 1 [428,] 1 2 [429,] 1 3 [430,] 1 1 [431,] 1 3 [432,] 1 1 [433,] 1 2 [434,] 1 1 [435,] 1 2 [436,] 1 2 [437,] 1 1 [438,] 1 3 [439,] 1 3 [440,] 1 3 [441,] 1 1 [442,] 1 3 [443,] 1 2 [444,] 1 1 [445,] 1 1 [446,] 1 3 [447,] 1 1 [448,] 1 2 [449,] 1 2 [450,] 1 1 [451,] 1 2 [452,] 1 3 [453,] 1 2 [454,] 1 1 [455,] 1 3 [456,] 1 2 [457,] 1 3 [458,] 1 3 [459,] 1 2 [460,] 1 3 [461,] 1 1 [462,] 1 3 [463,] 1 1 [464,] 1 1 [465,] 1 3 [466,] 1 2 [467,] 1 1 [468,] 1 3 [469,] 1 2 [470,] 1 1 [471,] 1 3 [472,] 1 2 [473,] 1 3 [474,] 1 3 [475,] 1 3 [476,] 1 1 [477,] 1 1 [478,] 1 1 [479,] 1 2 [480,] 1 1 [481,] 1 2 [482,] 1 2 [483,] 1 2 [484,] 1 2 [485,] 1 3 [486,] 1 3 [487,] 1 1 [488,] 1 3 [489,] 1 2 [490,] 1 3 [491,] 1 3 [492,] 1 2 [493,] 1 3 [494,] 1 2 [495,] 1 1 [496,] 1 2 [497,] 1 3 [498,] 1 3 [499,] 1 3 [500,] 1 1 [501,] 1 1 [502,] 1 2 [503,] 1 3 [504,] 1 3 [505,] 1 2 [506,] 1 1 [507,] 1 2 [508,] 1 1 [509,] 1 2 [510,] 1 1 [511,] 1 1 [512,] 1 3 [513,] 1 1 [514,] 1 3 [515,] 1 3 [516,] 1 2 [517,] 1 3 [518,] 1 1 [519,] 1 3 [520,] 1 3 [521,] 1 2 [522,] 1 3 [523,] 1 2 [524,] 1 1 [525,] 1 2 [526,] 1 1 [527,] 1 1 [528,] 1 2 [529,] 1 3 [530,] 1 1 [531,] 1 2 [532,] 1 1 [533,] 1 2 [534,] 1 2 [535,] 1 2 [536,] 1 3 [537,] 1 2 [538,] 1 3 [539,] 1 1 [540,] 1 3 [541,] 1 1 [542,] 1 2 [543,] 1 3 [544,] 1 1 [545,] 1 3 [546,] 1 3 [547,] 1 3 [548,] 1 3 [549,] 1 3 [550,] 1 2 [551,] 1 1 [552,] 1 3 [553,] 1 3 [554,] 1 1 [555,] 1 3 [556,] 1 2 [557,] 1 2 [558,] 1 1 [559,] 1 1 [560,] 1 2 [561,] 1 3 [562,] 1 2 [563,] 1 1 [564,] 1 1 [565,] 1 3 [566,] 1 2 [567,] 1 2 [568,] 1 2 [569,] 1 3 [570,] 1 1 [571,] 1 3 [572,] 1 3 [573,] 1 1 [574,] 1 2 [575,] 1 3 [576,] 1 1 [577,] 1 1 [578,] 1 1 [579,] 1 2 [580,] 1 3 [581,] 1 2 [582,] 1 3 [583,] 1 3 [584,] 1 1 [585,] 1 3 [586,] 1 1 [587,] 1 3 [588,] 1 2 [589,] 1 2 [590,] 1 2 [591,] 1 3 [592,] 1 1 [593,] 1 3 [594,] 1 1 [595,] 1 1 [596,] 1 2 [597,] 1 1 [598,] 1 3 [599,] 1 3 [600,] 1 1 [601,] 1 3 [602,] 1 3 [603,] 1 2 [604,] 1 2 [605,] 1 2 [606,] 1 3 [607,] 1 1 [608,] 1 1 [609,] 1 3 [610,] 1 3 [611,] 1 1 [612,] 1 2 [613,] 1 2 [614,] 1 3 [615,] 1 3 [616,] 1 3 [617,] 1 1 [618,] 1 1 [619,] 1 2 [620,] 1 2 [621,] 1 1 [622,] 1 3 [623,] 1 3 [624,] 1 2 [625,] 1 1 [626,] 1 2 [627,] 1 1 [628,] 1 3 [629,] 1 3 [630,] 1 1 [631,] 1 3 [632,] 1 3 [633,] 1 2 [634,] 1 3 [635,] 1 1 [636,] 1 3 [637,] 1 2 [638,] 1 1 [639,] 1 2 [640,] 1 1 [641,] 1 2 [642,] 1 3 [643,] 1 3 [644,] 1 1 [645,] 1 3 [646,] 1 1 [647,] 1 3 [648,] 1 3 [649,] 1 2 [650,] 1 3 [651,] 1 3 [652,] 1 3 [653,] 1 1 [654,] 1 1 [655,] 1 2 [656,] 1 3 [657,] 1 3 [658,] 1 1 [659,] 1 1 [660,] 1 2 [661,] 1 3 [662,] 1 3 [663,] 1 2 [664,] 1 1 [665,] 1 1 [666,] 1 2 [667,] 1 3 [668,] 1 2 [669,] 1 3 [670,] 1 2 [671,] 1 3 [672,] 1 1 [673,] 1 2 [674,] 1 2 [675,] 1 3 [676,] 1 1 [677,] 1 1 [678,] 1 3 [679,] 1 1 [680,] 1 1 [681,] 1 1 [682,] 1 2 [683,] 1 3 [684,] 1 3 [685,] 1 2 [686,] 1 2 [687,] 1 2 [688,] 1 2 [689,] 1 3 [690,] 1 1 [691,] 1 2 [692,] 1 3 [693,] 1 1 [694,] 1 3 [695,] 1 2 [696,] 1 3 [697,] 1 2 [698,] 1 1 [699,] 1 3 [700,] 1 3 [701,] 1 2 [702,] 1 3 [703,] 1 2 [704,] 1 1 [705,] 1 2 [706,] 1 1 [707,] 1 3 [708,] 1 1 [709,] 1 1 [710,] 1 2 [711,] 1 1 [712,] 1 3 [713,] 1 1 [714,] 1 1 [715,] 1 2 [716,] 1 2 [717,] 1 2 [718,] 1 2 [719,] 1 3 [720,] 1 2 [721,] 1 3 [722,] 1 1 [723,] 1 2 [724,] 1 2 [725,] 1 1 [726,] 1 2 [727,] 1 1 [728,] 1 3 [729,] 1 3 [730,] 1 2 [731,] 1 1 [732,] 1 1 [733,] 1 2 [734,] 1 1 [735,] 1 1 [736,] 1 1 [737,] 1 1 [738,] 1 2 [739,] 1 1 [740,] 1 2 [741,] 1 1 [742,] 1 3 [743,] 1 1 [744,] 1 1 [745,] 1 2 [746,] 1 1 [747,] 1 1 [748,] 1 2 [749,] 1 2 [750,] 1 2 [751,] 1 2 [752,] 1 2 [753,] 1 1 [754,] 1 2 [755,] 1 1 [756,] 1 3 [757,] 1 2 [758,] 1 2 [759,] 1 3 [760,] 1 3 [761,] 1 3 [762,] 1 3 [763,] 1 2 [764,] 1 3 [765,] 1 1 [766,] 1 3 [767,] 1 3 [768,] 1 1 [769,] 1 1 [770,] 1 2 [771,] 1 2 [772,] 1 2 [773,] 1 3 [774,] 1 3 [775,] 1 3 [776,] 1 1 [777,] 1 1 [778,] 1 1 [779,] 1 2 [780,] 1 1 [781,] 1 1 [782,] 1 1 [783,] 1 3 [784,] 1 3 [785,] 1 3 [786,] 1 3 [787,] 1 2 [788,] 1 2 [789,] 1 3 [790,] 1 1 [791,] 1 1 [792,] 1 1 [793,] 1 3 [794,] 1 1 [795,] 1 2 [796,] 1 1 [797,] 1 1 [798,] 1 3 [799,] 1 1 [800,] 1 2 [801,] 1 1 [802,] 1 3 [803,] 1 1 [804,] 1 2 [805,] 1 2 [806,] 1 1 [807,] 1 3 [808,] 1 2 [809,] 1 1 [810,] 1 2 [811,] 1 2 [812,] 1 1 [813,] 1 2 [814,] 1 3 [815,] 1 1 [816,] 1 1 [817,] 1 3 [818,] 1 2 [819,] 1 2 [820,] 1 1 [821,] 1 3 [822,] 1 1 [823,] 1 3 [824,] 1 2 [825,] 1 3 [826,] 1 2 [827,] 1 3 [828,] 1 1 [829,] 1 1 [830,] 1 3 [831,] 1 3 [832,] 1 2 [833,] 1 2 [834,] 1 3 [835,] 1 1 [836,] 1 3 [837,] 1 3 [838,] 1 2 [839,] 1 3 [840,] 1 1 [841,] 1 2 [842,] 1 3 [843,] 1 2 [844,] 1 1 [845,] 1 1 [846,] 1 2 [847,] 1 2 [848,] 1 1 [849,] 1 3 [850,] 1 2 [851,] 1 1 [852,] 1 1 [853,] 1 1 [854,] 1 1 [855,] 1 3 [856,] 1 3 [857,] 1 2 [858,] 1 3 [859,] 1 3 [860,] 1 3 [861,] 1 2 [862,] 1 3 [863,] 1 3 [864,] 1 2 [865,] 1 3 [866,] 1 2 [867,] 1 2 [868,] 1 2 [869,] 1 1 [870,] 1 2 [871,] 1 1 [872,] 1 3 [873,] 1 2 [874,] 1 2 [875,] 1 1 [876,] 1 3 [877,] 1 1 [878,] 1 3 [879,] 1 2 [880,] 1 2 [881,] 1 3 [882,] 1 3 [883,] 1 3 [884,] 1 3 [885,] 1 3 [886,] 1 3 [887,] 1 2 [888,] 1 2 [889,] 1 1 [890,] 1 1 [891,] 1 1 [892,] 1 3 [893,] 1 3 [894,] 1 3 [895,] 1 3 [896,] 1 1 [897,] 1 2 [898,] 1 2 [899,] 1 1 [900,] 1 2 [901,] 1 2 [902,] 1 1 [903,] 1 1 [904,] 1 2 [905,] 1 3 [906,] 1 1 [907,] 1 3 [908,] 1 2 [909,] 1 2 [910,] 1 1 [911,] 1 1 [912,] 1 1 [913,] 1 3 [914,] 1 1 [915,] 1 1 [916,] 1 2 [917,] 1 2 [918,] 1 2 [919,] 1 3 [920,] 1 3 [921,] 1 2 [922,] 1 1 [923,] 1 3 [924,] 1 1 [925,] 1 3 [926,] 1 2 [927,] 1 3 [928,] 1 1 [929,] 1 3 [930,] 1 1 [931,] 1 1 [932,] 1 1 [933,] 1 2 [934,] 1 2 [935,] 1 2 [936,] 1 1 [937,] 1 1 [938,] 1 2 [939,] 1 1 [940,] 1 3 [941,] 1 3 [942,] 1 3 [943,] 1 2 [944,] 1 3 [945,] 1 2 [946,] 1 2 [947,] 1 1 [948,] 1 1 [949,] 1 3 [950,] 1 1 [951,] 1 3 [952,] 1 3 [953,] 1 1 [954,] 1 2 [955,] 1 3 [956,] 1 3 [957,] 1 3 [958,] 1 1 [959,] 1 2 [960,] 1 1 [961,] 1 2 [962,] 1 2 [963,] 1 2 [964,] 1 3 [965,] 1 2 [966,] 1 1 [967,] 1 2 [968,] 1 1 [969,] 1 3 [970,] 1 1 [971,] 1 1 [972,] 1 3 [973,] 1 2 [974,] 1 3 [975,] 1 1 [976,] 1 2 [977,] 1 3 [978,] 1 2 [979,] 1 3 [980,] 1 3 [981,] 1 3 [982,] 1 2 [983,] 1 1 [984,] 1 2 [985,] 1 1 [986,] 1 3 [987,] 1 3 [988,] 1 1 [989,] 1 1 [990,] 1 3 [991,] 1 1 [992,] 1 1 [993,] 1 1 [994,] 1 2 [995,] 1 3 [996,] 1 3 [997,] 1 3 [998,] 1 3 [999,] 1 3 [1000,] 1 2 [1001,] 1 3 [1002,] 1 2 [1003,] 1 3 [1004,] 1 3 [1005,] 1 2 [1006,] 1 1 [1007,] 1 2 [1008,] 1 1 [1009,] 1 2 [1010,] 1 1 [1011,] 1 2 [1012,] 1 2 [1013,] 1 2 [1014,] 1 2 [1015,] 1 2 [1016,] 1 1 [1017,] 1 3 [1018,] 1 1 [1019,] 1 2 [1020,] 1 3 [1021,] 1 2 [1022,] 1 2 [1023,] 1 2 [1024,] 1 3 [1025,] 1 3 [1026,] 1 1 [1027,] 1 1 [1028,] 1 1 [1029,] 1 1 [1030,] 1 2 [1031,] 1 1 [1032,] 1 3 [1033,] 1 3 [1034,] 1 2 [1035,] 1 2 [1036,] 1 1 [1037,] 1 3 [1038,] 1 2 [1039,] 1 2 [1040,] 1 2 [1041,] 1 1 [1042,] 1 1 [1043,] 1 1 [1044,] 1 2 [1045,] 1 2 [1046,] 1 3 [1047,] 2 3 [1048,] 2 2 [1049,] 2 1 [1050,] 2 2 [1051,] 2 2 [1052,] 2 1 [1053,] 2 1 [1054,] 2 1 [1055,] 2 3 [1056,] 2 1 [1057,] 2 3 [1058,] 2 2 [1059,] 2 1 [1060,] 2 2 [1061,] 2 3 [1062,] 2 1 [1063,] 2 3 [1064,] 2 3 [1065,] 2 1 [1066,] 2 1 [1067,] 2 3 [1068,] 2 1 [1069,] 2 2 [1070,] 2 3 [1071,] 2 1 [1072,] 2 1 [1073,] 2 3 [1074,] 2 1 [1075,] 2 2 [1076,] 2 3 [1077,] 2 3 [1078,] 2 2 [1079,] 2 1 [1080,] 2 1 [1081,] 2 2 [1082,] 2 1 [1083,] 2 1 [1084,] 2 1 [1085,] 2 2 [1086,] 2 2 [1087,] 2 2 [1088,] 2 3 [1089,] 2 2 [1090,] 2 2 [1091,] 2 3 [1092,] 2 1 [1093,] 2 1 [1094,] 2 3 [1095,] 2 2 [1096,] 2 2 [1097,] 2 2 [1098,] 2 1 [1099,] 2 3 [1100,] 2 3 [1101,] 2 2 [1102,] 2 1 [1103,] 2 1 [1104,] 2 3 [1105,] 2 2 [1106,] 2 2 [1107,] 2 3 [1108,] 2 3 [1109,] 2 2 [1110,] 2 2 [1111,] 2 3 [1112,] 2 2 [1113,] 2 3 [1114,] 2 1 [1115,] 2 3 [1116,] 2 2 [1117,] 2 1 [1118,] 2 2 [1119,] 2 1 [1120,] 2 2 [1121,] 2 2 [1122,] 2 3 [1123,] 2 2 [1124,] 2 2 [1125,] 2 3 [1126,] 2 1 [1127,] 2 3 [1128,] 2 3 [1129,] 2 3 [1130,] 2 1 [1131,] 2 1 [1132,] 2 3 [1133,] 2 3 [1134,] 2 3 [1135,] 2 1 [1136,] 2 1 [1137,] 2 2 [1138,] 2 2 [1139,] 2 3 [1140,] 2 1 [1141,] 2 2 [1142,] 2 2 [1143,] 2 1 [1144,] 2 2 [1145,] 2 2 [1146,] 2 2 [1147,] 2 3 [1148,] 2 2 [1149,] 2 2 [1150,] 2 2 [1151,] 2 3 [1152,] 2 2 [1153,] 2 2 [1154,] 2 1 [1155,] 2 3 [1156,] 2 3 [1157,] 2 2 [1158,] 2 3 [1159,] 2 1 [1160,] 2 3 [1161,] 2 3 [1162,] 2 3 [1163,] 2 3 [1164,] 2 3 [1165,] 2 2 [1166,] 2 2 [1167,] 2 1 [1168,] 2 3 [1169,] 2 2 [1170,] 2 1 [1171,] 2 3 [1172,] 2 1 [1173,] 2 2 [1174,] 2 2 [1175,] 2 2 [1176,] 2 2 [1177,] 2 2 [1178,] 2 1 [1179,] 2 1 [1180,] 2 3 [1181,] 2 2 [1182,] 2 3 [1183,] 2 3 [1184,] 2 2 [1185,] 2 1 [1186,] 2 3 [1187,] 2 2 [1188,] 2 2 [1189,] 2 1 [1190,] 2 3 [1191,] 2 3 [1192,] 2 2 [1193,] 2 2 [1194,] 2 3 [1195,] 2 2 [1196,] 2 2 [1197,] 2 1 [1198,] 2 2 [1199,] 2 1 [1200,] 2 2 [1201,] 2 3 [1202,] 2 3 [1203,] 2 3 [1204,] 2 2 [1205,] 2 1 [1206,] 2 3 [1207,] 2 1 [1208,] 2 1 [1209,] 2 2 [1210,] 2 3 [1211,] 2 1 [1212,] 2 1 [1213,] 2 1 [1214,] 2 1 [1215,] 2 1 [1216,] 2 1 [1217,] 2 3 [1218,] 2 3 [1219,] 2 2 [1220,] 2 2 [1221,] 2 2 [1222,] 2 1 [1223,] 2 3 [1224,] 2 1 [1225,] 2 2 [1226,] 2 1 [1227,] 2 3 [1228,] 2 1 [1229,] 2 3 [1230,] 2 2 [1231,] 2 1 [1232,] 2 1 [1233,] 2 3 [1234,] 2 3 [1235,] 2 1 [1236,] 2 2 [1237,] 2 2 [1238,] 2 3 [1239,] 2 3 [1240,] 2 1 [1241,] 2 3 [1242,] 2 3 [1243,] 2 1 [1244,] 2 2 [1245,] 2 3 [1246,] 2 1 [1247,] 2 3 [1248,] 2 3 [1249,] 2 2 [1250,] 2 3 [1251,] 2 3 [1252,] 2 2 [1253,] 2 2 [1254,] 2 1 [1255,] 2 1 [1256,] 2 2 [1257,] 2 3 [1258,] 2 1 [1259,] 2 3 [1260,] 2 1 [1261,] 2 2 [1262,] 2 2 [1263,] 2 2 [1264,] 2 3 [1265,] 2 1 [1266,] 2 3 [1267,] 2 3 [1268,] 2 2 [1269,] 2 1 [1270,] 2 3 [1271,] 2 3 [1272,] 2 2 [1273,] 2 1 [1274,] 2 3 [1275,] 2 1 [1276,] 2 1 [1277,] 2 1 [1278,] 2 1 [1279,] 2 1 [1280,] 2 2 [1281,] 2 1 [1282,] 2 1 [1283,] 2 3 [1284,] 2 2 [1285,] 2 3 [1286,] 2 2 [1287,] 2 3 [1288,] 2 2 [1289,] 2 3 [1290,] 2 1 [1291,] 2 2 [1292,] 2 1 [1293,] 2 3 [1294,] 2 1 [1295,] 2 3 [1296,] 2 2 [1297,] 2 3 [1298,] 2 3 [1299,] 2 2 [1300,] 2 1 [1301,] 2 2 [1302,] 2 3 [1303,] 2 1 [1304,] 2 3 [1305,] 2 3 [1306,] 2 1 [1307,] 2 3 [1308,] 2 3 [1309,] 2 3 [1310,] 2 3 [1311,] 2 3 [1312,] 2 3 [1313,] 2 1 [1314,] 2 1 [1315,] 2 3 [1316,] 2 3 [1317,] 2 2 [1318,] 2 3 [1319,] 2 1 [1320,] 2 3 [1321,] 2 1 [1322,] 2 3 [1323,] 2 3 [1324,] 2 3 [1325,] 2 2 [1326,] 2 2 [1327,] 2 1 [1328,] 2 1 [1329,] 2 3 [1330,] 2 3 [1331,] 2 3 [1332,] 2 3 [1333,] 2 3 [1334,] 2 1 [1335,] 2 1 [1336,] 2 1 [1337,] 2 2 [1338,] 2 1 [1339,] 2 2 [1340,] 2 1 [1341,] 2 3 [1342,] 2 2 [1343,] 2 1 [1344,] 2 2 [1345,] 2 1 [1346,] 2 2 [1347,] 2 3 [1348,] 2 1 [1349,] 2 3 [1350,] 2 1 [1351,] 2 1 [1352,] 2 1 [1353,] 2 1 [1354,] 2 2 [1355,] 2 3 [1356,] 2 1 [1357,] 2 2 [1358,] 2 3 [1359,] 2 2 [1360,] 2 3 [1361,] 2 2 [1362,] 2 3 [1363,] 2 1 [1364,] 2 1 [1365,] 2 2 [1366,] 2 1 [1367,] 2 1 [1368,] 2 1 [1369,] 2 3 [1370,] 2 2 [1371,] 2 1 [1372,] 2 2 [1373,] 2 1 [1374,] 2 3 [1375,] 2 2 [1376,] 2 2 [1377,] 2 3 [1378,] 2 3 [1379,] 2 2 [1380,] 2 1 [1381,] 2 1 [1382,] 2 2 [1383,] 2 1 [1384,] 2 3 [1385,] 2 2 [1386,] 2 1 [1387,] 2 1 [1388,] 2 1 [1389,] 2 1 [1390,] 2 2 [1391,] 2 2 [1392,] 2 1 [1393,] 2 1 [1394,] 2 3 [1395,] 2 1 [1396,] 2 1 [1397,] 2 1 [1398,] 2 1 [1399,] 2 3 [1400,] 2 1 [1401,] 2 1 [1402,] 2 1 [1403,] 2 3 [1404,] 2 1 [1405,] 2 1 [1406,] 2 2 [1407,] 2 1 [1408,] 2 1 [1409,] 2 2 [1410,] 2 2 [1411,] 2 3 [1412,] 2 2 [1413,] 2 1 [1414,] 2 1 [1415,] 2 1 [1416,] 2 3 [1417,] 2 3 [1418,] 2 2 [1419,] 2 2 [1420,] 2 2 [1421,] 2 1 [1422,] 2 3 [1423,] 2 2 [1424,] 2 3 [1425,] 2 3 [1426,] 2 2 [1427,] 2 3 [1428,] 2 3 [1429,] 2 1 [1430,] 2 2 [1431,] 2 3 [1432,] 2 1 [1433,] 2 3 [1434,] 2 2 [1435,] 2 2 [1436,] 2 3 [1437,] 2 2 [1438,] 2 3 [1439,] 2 2 [1440,] 2 2 [1441,] 2 1 [1442,] 2 3 [1443,] 2 2 [1444,] 2 3 [1445,] 2 1 [1446,] 2 1 [1447,] 2 1 [1448,] 2 1 [1449,] 2 3 [1450,] 2 3 [1451,] 2 1 [1452,] 2 3 [1453,] 2 2 [1454,] 2 1 [1455,] 2 3 [1456,] 2 2 [1457,] 2 2 [1458,] 2 1 [1459,] 2 1 [1460,] 2 3 [1461,] 2 2 [1462,] 2 1 [1463,] 2 1 [1464,] 2 2 [1465,] 2 1 [1466,] 2 1 [1467,] 2 3 [1468,] 2 1 [1469,] 2 3 [1470,] 2 1 [1471,] 2 1 [1472,] 2 3 [1473,] 2 3 [1474,] 2 2 [1475,] 2 2 [1476,] 2 2 [1477,] 2 3 [1478,] 2 1 [1479,] 2 2 [1480,] 2 1 [1481,] 2 2 [1482,] 2 1 [1483,] 2 2 [1484,] 2 2 [1485,] 2 2 [1486,] 2 1 [1487,] 2 1 [1488,] 2 1 [1489,] 2 3 [1490,] 2 1 [1491,] 2 3 [1492,] 2 2 [1493,] 2 2 [1494,] 2 3 [1495,] 2 2 [1496,] 2 2 [1497,] 2 2 [1498,] 2 3 [1499,] 2 3 [1500,] 2 1 [1501,] 2 3 [1502,] 2 1 [1503,] 2 1 [1504,] 2 3 [1505,] 2 2 [1506,] 2 3 [1507,] 2 3 [1508,] 2 1 [1509,] 2 2 [1510,] 2 1 [1511,] 2 3 [1512,] 2 1 [1513,] 2 3 [1514,] 2 3 [1515,] 2 2 [1516,] 2 3 [1517,] 2 1 [1518,] 2 2 [1519,] 2 1 [1520,] 2 1 [1521,] 2 1 [1522,] 2 2 [1523,] 2 1 [1524,] 2 2 [1525,] 2 3 [1526,] 2 3 [1527,] 2 1 [1528,] 2 3 [1529,] 2 3 [1530,] 2 2 [1531,] 2 3 [1532,] 2 3 [1533,] 2 2 [1534,] 2 1 [1535,] 2 1 [1536,] 2 3 [1537,] 2 1 [1538,] 2 3 [1539,] 2 1 [1540,] 2 2 [1541,] 2 2 [1542,] 2 1 [1543,] 2 3 [1544,] 2 1 [1545,] 2 1 [1546,] 2 3 [1547,] 2 1 [1548,] 2 1 [1549,] 2 3 [1550,] 2 1 [1551,] 2 1 [1552,] 2 3 [1553,] 2 2 [1554,] 2 1 [1555,] 2 2 [1556,] 2 3 [1557,] 2 3 [1558,] 2 3 [1559,] 2 2 [1560,] 2 2 [1561,] 2 1 [1562,] 2 2 [1563,] 2 2 [1564,] 2 3 [1565,] 2 3 [1566,] 2 3 [1567,] 2 1 [1568,] 2 1 [1569,] 2 1 [1570,] 2 1 [1571,] 2 1 [1572,] 2 1 [1573,] 2 1 [1574,] 2 2 [1575,] 2 2 [1576,] 2 2 [1577,] 2 2 [1578,] 2 1 [1579,] 2 2 [1580,] 2 3 [1581,] 2 2 [1582,] 2 3 [1583,] 2 2 [1584,] 2 1 [1585,] 2 3 [1586,] 2 3 [1587,] 2 1 [1588,] 2 2 [1589,] 2 1 [1590,] 2 1 [1591,] 2 3 [1592,] 2 2 [1593,] 2 3 [1594,] 2 3 [1595,] 2 2 [1596,] 2 2 [1597,] 2 2 [1598,] 2 3 [1599,] 2 2 [1600,] 2 2 [1601,] 2 2 [1602,] 2 2 [1603,] 2 3 [1604,] 2 2 [1605,] 2 3 [1606,] 2 1 [1607,] 2 3 [1608,] 2 1 [1609,] 2 2 [1610,] 2 3 [1611,] 2 3 [1612,] 2 3 [1613,] 2 1 [1614,] 2 1 [1615,] 2 3 [1616,] 2 1 [1617,] 2 3 [1618,] 2 2 [1619,] 2 2 [1620,] 2 3 [1621,] 2 3 [1622,] 2 2 [1623,] 2 2 [1624,] 2 2 [1625,] 2 3 [1626,] 2 1 [1627,] 2 3 [1628,] 2 2 [1629,] 2 2 [1630,] 2 3 [1631,] 2 3 [1632,] 2 3 [1633,] 2 2 [1634,] 2 3 [1635,] 2 1 [1636,] 2 3 [1637,] 2 2 [1638,] 2 2 [1639,] 2 1 [1640,] 2 3 [1641,] 2 2 [1642,] 2 1 [1643,] 2 1 [1644,] 2 1 [1645,] 2 2 [1646,] 2 1 [1647,] 2 1 [1648,] 2 1 [1649,] 2 1 [1650,] 2 3 [1651,] 2 3 [1652,] 2 2 [1653,] 2 3 [1654,] 2 1 [1655,] 2 2 [1656,] 2 3 [1657,] 2 2 [1658,] 2 2 [1659,] 2 1 [1660,] 2 2 [1661,] 2 2 [1662,] 2 2 [1663,] 2 1 [1664,] 2 2 [1665,] 2 3 [1666,] 2 2 [1667,] 2 3 [1668,] 2 3 [1669,] 2 1 [1670,] 2 3 [1671,] 2 1 [1672,] 2 1 [1673,] 2 3 [1674,] 2 3 [1675,] 2 3 [1676,] 2 2 [1677,] 2 1 [1678,] 2 2 [1679,] 2 1 [1680,] 2 2 [1681,] 2 3 [1682,] 2 1 [1683,] 2 2 [1684,] 2 3 [1685,] 2 3 [1686,] 2 2 [1687,] 2 3 [1688,] 2 2 [1689,] 2 1 [1690,] 2 2 [1691,] 2 2 [1692,] 2 2 [1693,] 2 3 [1694,] 2 1 [1695,] 2 3 [1696,] 2 2 [1697,] 2 2 [1698,] 2 1 [1699,] 2 1 [1700,] 2 2 [1701,] 2 3 [1702,] 2 3 [1703,] 2 2 [1704,] 2 2 [1705,] 2 1 [1706,] 2 2 [1707,] 2 1 [1708,] 2 2 [1709,] 2 3 [1710,] 2 2 [1711,] 2 2 [1712,] 2 3 [1713,] 2 3 [1714,] 2 3 [1715,] 2 2 [1716,] 2 3 [1717,] 2 3 [1718,] 2 1 [1719,] 2 2 [1720,] 2 1 [1721,] 2 1 [1722,] 2 1 [1723,] 2 1 [1724,] 2 1 [1725,] 2 1 [1726,] 2 1 [1727,] 2 1 [1728,] 2 2 [1729,] 2 3 [1730,] 2 2 [1731,] 2 2 [1732,] 2 2 [1733,] 2 3 [1734,] 2 3 [1735,] 2 1 [1736,] 2 2 [1737,] 2 3 [1738,] 2 3 [1739,] 2 3 [1740,] 2 2 [1741,] 2 1 [1742,] 2 3 [1743,] 2 3 [1744,] 2 1 [1745,] 2 1 [1746,] 2 3 [1747,] 2 2 [1748,] 2 3 [1749,] 2 1 [1750,] 2 2 [1751,] 2 1 [1752,] 2 1 [1753,] 2 3 [1754,] 2 3 [1755,] 2 1 [1756,] 2 3 [1757,] 2 1 [1758,] 2 2 [1759,] 2 2 [1760,] 2 2 [1761,] 2 1 [1762,] 2 3 [1763,] 2 2 [1764,] 2 1 [1765,] 2 1 [1766,] 2 1 [1767,] 2 1 [1768,] 2 1 [1769,] 2 1 [1770,] 2 1 [1771,] 2 1 [1772,] 2 3 [1773,] 2 1 [1774,] 2 3 [1775,] 2 3 [1776,] 2 2 [1777,] 2 1 [1778,] 2 1 [1779,] 2 3 [1780,] 2 1 [1781,] 2 3 [1782,] 2 2 [1783,] 2 2 [1784,] 2 2 [1785,] 2 3 [1786,] 2 2 [1787,] 2 1 [1788,] 2 2 [1789,] 2 1 [1790,] 2 2 [1791,] 2 3 [1792,] 2 2 [1793,] 2 3 [1794,] 2 3 [1795,] 2 1 [1796,] 2 1 [1797,] 2 1 [1798,] 2 1 [1799,] 2 3 [1800,] 2 1 [1801,] 2 1 [1802,] 2 3 [1803,] 2 3 [1804,] 2 3 [1805,] 2 3 [1806,] 2 1 [1807,] 2 3 [1808,] 2 2 [1809,] 2 3 [1810,] 2 3 [1811,] 2 2 [1812,] 2 3 [1813,] 2 1 [1814,] 2 3 [1815,] 2 3 [1816,] 2 1 [1817,] 2 2 [1818,] 2 3 [1819,] 2 2 [1820,] 2 2 [1821,] 2 2 [1822,] 2 1 [1823,] 2 3 [1824,] 2 1 [1825,] 2 3 [1826,] 2 2 [1827,] 2 2 [1828,] 2 1 [1829,] 2 1 [1830,] 2 1 [1831,] 2 2 [1832,] 2 3 [1833,] 2 2 [1834,] 2 1 [1835,] 2 3 [1836,] 2 3 [1837,] 2 1 [1838,] 2 3 [1839,] 2 1 [1840,] 2 2 [1841,] 2 2 [1842,] 2 1 [1843,] 2 1 [1844,] 2 2 [1845,] 2 1 [1846,] 2 1 [1847,] 2 3 [1848,] 2 1 [1849,] 2 2 [1850,] 2 3 [1851,] 2 2 [1852,] 2 2 [1853,] 2 3 [1854,] 2 1 [1855,] 2 2 [1856,] 2 3 [1857,] 2 1 [1858,] 2 1 [1859,] 2 3 [1860,] 2 3 [1861,] 2 1 [1862,] 2 2 [1863,] 2 2 [1864,] 2 1 [1865,] 2 3 [1866,] 2 1 [1867,] 2 2 [1868,] 2 3 [1869,] 2 2 [1870,] 2 3 [1871,] 2 2 [1872,] 2 2 [1873,] 2 1 [1874,] 2 3 [1875,] 2 1 [1876,] 2 1 [1877,] 2 2 [1878,] 2 3 [1879,] 2 2 [1880,] 2 2 [1881,] 2 3 [1882,] 2 3 [1883,] 2 1 [1884,] 2 3 [1885,] 2 1 [1886,] 2 2 [1887,] 2 1 [1888,] 2 3 [1889,] 2 3 [1890,] 2 2 [1891,] 2 3 [1892,] 2 3 [1893,] 2 3 [1894,] 2 1 [1895,] 2 1 [1896,] 2 1 [1897,] 2 3 [1898,] 2 1 [1899,] 2 3 [1900,] 2 3 [1901,] 2 3 [1902,] 2 2 [1903,] 2 2 [1904,] 2 3 [1905,] 2 3 [1906,] 2 2 [1907,] 2 2 [1908,] 2 2 [1909,] 2 1 [1910,] 2 1 [1911,] 2 1 [1912,] 2 2 [1913,] 2 2 [1914,] 2 1 [1915,] 2 2 [1916,] 2 1 [1917,] 2 1 [1918,] 2 1 [1919,] 2 2 [1920,] 2 2 [1921,] 2 2 [1922,] 2 3 [1923,] 2 3 [1924,] 2 1 [1925,] 2 2 [1926,] 2 2 [1927,] 2 2 [1928,] 2 1 [1929,] 2 2 [1930,] 2 1 [1931,] 2 2 [1932,] 2 3 [1933,] 2 3 [1934,] 2 2 [1935,] 2 1 [1936,] 2 3 [1937,] 2 3 [1938,] 2 1 [1939,] 2 2 [1940,] 2 3 [1941,] 2 3 [1942,] 2 2 [1943,] 2 1 [1944,] 2 1 [1945,] 2 1 [1946,] 2 2 [1947,] 2 1 [1948,] 2 2 [1949,] 2 1 [1950,] 2 1 [1951,] 2 3 [1952,] 2 1 [1953,] 2 1 [1954,] 2 3 [1955,] 2 3 [1956,] 2 2 [1957,] 2 1 [1958,] 2 1 [1959,] 2 3 [1960,] 2 2 [1961,] 2 3 [1962,] 2 1 [1963,] 2 2 [1964,] 2 2 [1965,] 2 2 [1966,] 2 1 [1967,] 2 1 [1968,] 2 2 [1969,] 2 1 [1970,] 2 1 [1971,] 2 1 [1972,] 2 1 [1973,] 2 3 [1974,] 2 3 [1975,] 2 2 [1976,] 2 1 [1977,] 2 3 [1978,] 2 3 [1979,] 2 2 [1980,] 2 3 [1981,] 2 3 [1982,] 2 1 [1983,] 2 3 [1984,] 2 1 [1985,] 2 2 [1986,] 2 3 [1987,] 2 2 [1988,] 2 1 [1989,] 2 3 [1990,] 2 2 [1991,] 2 2 [1992,] 2 1 [1993,] 2 1 [1994,] 2 2 [1995,] 2 3 [1996,] 2 2 [1997,] 2 2 [1998,] 2 1 [1999,] 2 3 [2000,] 2 3 [2001,] 2 1 [2002,] 2 1 [2003,] 2 3 [2004,] 2 1 [2005,] 2 2 [2006,] 2 3 [2007,] 2 3 [2008,] 2 3 [2009,] 2 1 [2010,] 2 3 [2011,] 2 1 [2012,] 2 1 [2013,] 2 1 [2014,] 2 1 [2015,] 2 3 [2016,] 2 3 [2017,] 2 2 [2018,] 2 1 [2019,] 2 2 [2020,] 2 1 [2021,] 2 3 [2022,] 2 2 [2023,] 2 3 [2024,] 2 1 [2025,] 2 1 [2026,] 2 3 [2027,] 2 2 [2028,] 2 3 [2029,] 2 3 [2030,] 2 2 [2031,] 2 1 [2032,] 2 2 [2033,] 2 1 [2034,] 2 1 [2035,] 2 3 [2036,] 2 3 [2037,] 2 2 [2038,] 2 2 [2039,] 2 2 [2040,] 2 3 [2041,] 2 2 [2042,] 2 2 [2043,] 2 1 [2044,] 2 1 [2045,] 2 1 [2046,] 2 2 [2047,] 2 2 [2048,] 2 3 [2049,] 2 2 [2050,] 2 2 [2051,] 2 1 [2052,] 2 1 [2053,] 2 3 [2054,] 2 3 [2055,] 2 1 [2056,] 2 2 [2057,] 2 1 [2058,] 2 3 [2059,] 2 2 [2060,] 2 3 [2061,] 2 3 [2062,] 2 1 [2063,] 2 3 [2064,] 2 3 [2065,] 2 3 [2066,] 2 2 [2067,] 2 2 [2068,] 2 2 [2069,] 2 2 [2070,] 2 2 [2071,] 2 3 [2072,] 2 1 [2073,] 2 1 [2074,] 2 1 [2075,] 2 3 [2076,] 2 1 [2077,] 2 3 [2078,] 2 2 [2079,] 2 3 [2080,] 2 1 [2081,] 2 1 [2082,] 2 3 [2083,] 2 2 [2084,] 2 3 [2085,] 2 1 [2086,] 2 2 [2087,] 2 2 [2088,] 2 2 [2089,] 2 2 [2090,] 2 2 [2091,] 2 1 [2092,] 2 3 $cv.rsq.tab survived. mean fold1.1 0.4138487 0.4138487 fold1.2 0.3503314 0.3503314 fold1.3 0.4003172 0.4003172 fold2.1 0.4056132 0.4056132 fold2.2 0.4165287 0.4165287 fold2.3 0.4246392 0.4246392 mean 0.4018797 0.4018797 $cv.maxerr.tab survived. max fold1.1 -0.9389088 -0.9389088 fold1.2 -0.9910562 -0.9910562 fold1.3 0.9962986 0.9962986 fold2.1 -0.9611915 -0.9611915 fold2.2 0.9700198 0.9700198 fold2.3 0.9861027 0.9861027 all 0.9962986 0.9962986 $cv.class.rate.tab survived. mean [1,] 0.7911765 0.7911765 [2,] 0.7942857 0.7942857 [3,] 0.7921348 0.7921348 [4,] 0.8044077 0.8044077 [5,] 0.7891566 0.7891566 [6,] 0.8062678 0.8062678 [7,] 0.7962382 0.7962382 $cv.auc.tab survived. mean fold1.1 0.8511767 0.8511767 fold1.2 0.8277526 0.8277526 fold1.3 0.8412860 0.8412860 fold2.1 0.8470280 0.8470280 fold2.2 0.8623425 0.8623425 fold2.3 0.8649505 0.8649505 mean 0.8490894 0.8490894 $cv.deviance.tab survived. mean fold1.1 0.8892578 0.8892578 fold1.2 0.9639068 0.9639068 fold1.3 0.9358144 0.9358144 fold2.1 0.8891913 0.8891913 fold2.2 0.8811683 0.8811683 fold2.3 0.8747528 0.8747528 mean 0.9056819 0.9056819 $cv.calib.int.tab survived. mean fold1.1 -0.11358464 -0.11358464 fold1.2 0.08138036 0.08138036 fold1.3 -0.10576265 -0.10576265 fold2.1 -0.08873200 -0.08873200 fold2.2 0.20074167 0.20074167 fold2.3 -0.16986142 -0.16986142 mean -0.03263645 -0.03263645 $cv.calib.slope.tab survived. mean fold1.1 0.8726317 0.8726317 fold1.2 0.8354114 0.8354114 fold1.3 0.8257333 0.8257333 fold2.1 0.8732894 0.8732894 fold2.2 1.0282050 1.0282050 fold2.3 0.9340455 0.9340455 mean 0.8948861 0.8948861 attr(,"class") [1] "earth" ------------------------------------------------------------------------------- > > cat("a6a: stratify=FALSE\n\n") a6a: stratify=FALSE > set.seed(6) > a6a <- earth(survived. ~ ., data=etitanic[,-2], degree=2, glm=list(family="binomial"), trace=0.5, nfold=3, stratify=FALSE, keepxy=TRUE) Full model GRSq 0.420 RSq 0.439, starting cross validation CV fold 1 CVRSq 0.425 n.oof 697 33% n.infold.nz 275 39% n.oof.nz 152 44% CV fold 2 CVRSq 0.379 n.oof 697 33% n.infold.nz 286 41% n.oof.nz 141 40% CV fold 3 CVRSq 0.415 n.oof 698 33% n.infold.nz 293 42% n.oof.nz 134 39% CV all CVRSq 0.406 n.infold.nz 427 41% > printh(a6a) === a6a 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 Termination condition: Reached nk 21 Importance: sexmale, 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 CVRSq 0.4060928 > printh(summary(a6a)) === summary(a6a) Call: earth(formula=survived.~., data=etitanic[,-2], keepxy=TRUE, trace=0.5, glm=list(family="binomial"), degree=2, nfold=3, stratify=FALSE) GLM coefficients survived. (Intercept) 2.9135260 pclass3rd -5.0300560 sexmale -3.1856245 h(age-32) -0.0375715 pclass2nd * sexmale -1.7680945 pclass3rd * sexmale 1.2226954 pclass3rd * h(4-sibsp) 0.6186527 sexmale * 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 Termination condition: Reached nk 21 Importance: sexmale, 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 CVRSq 0.4060928 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 9.00 sd 1.00 nvars 5.33 sd 0.58 CVRSq sd ClassRate sd MaxErr sd AUC sd MeanDev sd CalibInt sd CalibSlope sd 0.406 0.024 0.797 0.002 0.995 0.0111 0.852 0.008 0.906 0.027 -0.016 0.049 0.898 0.062 > plot(a6a, main="a6a (stratify=FALSE)", which=1, col.oof.labs=1) > > cat("a7: titanic data, multiple responses (i.e. 3 level factor)\n\n") a7: titanic data, multiple responses (i.e. 3 level factor) > set.seed(3) > # keepxy is needed for summary and plotmo of resmodels > a7 <- earth(pclass ~ ., data=etitanic, degree=2, glm=list(family="binomial"), trace=1, ncross=2, nfold=3, keepxy=TRUE) x[1046,5] with colnames survived sexmale age sibsp parch y[1046,3] with colnames 1st 2nd 3rd Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.164 RSq 0.227 Prune backward penalty 3 nprune null: selected 9 of 17 terms, and 5 of 5 preds After pruning pass GRSq 0.175 RSq 0.206 GLM 1st devratio 0.27 dof 1037/1045 iters 5 GLM 2nd devratio 0.04 dof 1037/1045 iters 5 GLM 3rd devratio 0.23 dof 1037/1045 iters 5 Full model GRSq 0.175 RSq 0.206, starting cross validation CV fold 1.1 CVRSq 0.147 Per response CVRSq 0.244 -0.028 0.224 n.oof 697 33% n.infold.nz 189 174 334 n.oof.nz 95 87 167 CV fold 1.2 CVRSq 0.153 Per response CVRSq 0.253 -0.003 0.210 n.oof 697 33% n.infold.nz 189 174 334 n.oof.nz 95 87 167 CV fold 1.3 CVRSq 0.168 Per response CVRSq 0.230 0.037 0.237 n.oof 698 33% n.infold.nz 190 174 334 n.oof.nz 94 87 167 CV fold 2.1 CVRSq 0.186 Per response CVRSq 0.298 0.027 0.232 n.oof 697 33% n.infold.nz 189 174 334 n.oof.nz 95 87 167 CV fold 2.2 CVRSq 0.135 Per response CVRSq 0.188 -0.005 0.223 n.oof 697 33% n.infold.nz 189 174 334 n.oof.nz 95 87 167 CV fold 2.3 CVRSq 0.187 Per response CVRSq 0.277 0.038 0.245 n.oof 698 33% n.infold.nz 190 174 334 n.oof.nz 94 87 167 CV all CVRSq 0.163 Per response CVRSq 0.248 0.011 0.229 n.infold.nz 284 261 501 > printh(a7) === a7 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 1223.31 1045 894.814 1037 0.2690 912.8 5 1 2nd 1175.31 1045 1126.944 1037 0.0411 1145.0 5 1 3rd 1448.21 1045 1118.941 1037 0.2270 1137.0 5 1 Earth selected 9 of 17 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 4 4 Earth GCV RSS GRSq RSq CVRSq 1st 0.1478715 148.5253 0.253819943 0.28210854 0.24841689 2nd 0.1869804 187.8072 0.003405389 0.04118751 0.01107525 3rd 0.1895587 190.3968 0.241872961 0.27061448 0.22855380 All 0.5244105 526.7293 0.175229617 0.20649767 0.16268198 > plot(a7, nresponse=1) > print.stripped.earth.model(a7, "a7") print.stripped.earth.model(a7) $rsq [1] 0.2064977 $gcv [1] 0.5244105 $grsq [1] 0.1752296 $dirs survived sexmale age sibsp parch (Intercept) 0 0 0 0 0 h(age-26) 0 0 1 0 0 h(26-age) 0 0 -1 0 0 survived 2 0 0 0 0 h(sibsp-1) 0 0 0 1 0 h(1-sibsp) 0 0 0 -1 0 h(parch-2) 0 0 0 0 1 h(2-parch) 0 0 0 0 -1 survived*h(age-16) 2 0 1 0 0 survived*h(16-age) 2 0 -1 0 0 survived*sexmale 2 2 0 0 0 sexmale 0 2 0 0 0 h(age-55)*h(2-parch) 0 0 1 0 -1 h(55-age)*h(2-parch) 0 0 -1 0 -1 h(1-sibsp)*h(parch-1) 0 0 0 -1 1 h(1-sibsp)*h(1-parch) 0 0 0 -1 -1 h(age-54) 0 0 1 0 0 $cuts survived sexmale age sibsp parch (Intercept) 0 0 0 0 0 h(age-26) 0 0 26 0 0 h(26-age) 0 0 26 0 0 survived 0 0 0 0 0 h(sibsp-1) 0 0 0 1 0 h(1-sibsp) 0 0 0 1 0 h(parch-2) 0 0 0 0 2 h(2-parch) 0 0 0 0 2 survived*h(age-16) 0 0 16 0 0 survived*h(16-age) 0 0 16 0 0 survived*sexmale 0 0 0 0 0 sexmale 0 0 0 0 0 h(age-55)*h(2-parch) 0 0 55 0 2 h(55-age)*h(2-parch) 0 0 55 0 2 h(1-sibsp)*h(parch-1) 0 0 0 1 1 h(1-sibsp)*h(1-parch) 0 0 0 1 1 h(age-54) 0 0 54 0 0 $selected.terms [1] 1 4 5 8 10 11 12 14 16 $prune.terms [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [,14] [,15] [,16] [,17] [1,] 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [2,] 1 14 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [3,] 1 4 14 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [4,] 1 4 8 14 0 0 0 0 0 0 0 0 0 0 0 0 0 [5,] 1 4 8 14 16 0 0 0 0 0 0 0 0 0 0 0 0 [6,] 1 4 8 11 14 16 0 0 0 0 0 0 0 0 0 0 0 [7,] 1 4 8 11 12 14 16 0 0 0 0 0 0 0 0 0 0 [8,] 1 4 5 8 11 12 14 16 0 0 0 0 0 0 0 0 0 [9,] 1 4 5 8 10 11 12 14 16 0 0 0 0 0 0 0 0 [10,] 1 4 5 8 10 11 12 14 16 17 0 0 0 0 0 0 0 [11,] 1 4 5 8 10 11 12 13 14 16 17 0 0 0 0 0 0 [12,] 1 4 5 7 8 10 11 12 13 14 16 17 0 0 0 0 0 [13,] 1 3 4 5 7 8 10 11 12 13 14 16 17 0 0 0 0 [14,] 1 3 4 5 7 8 9 10 11 12 13 14 16 17 0 0 0 [15,] 1 3 4 5 6 7 8 9 10 11 12 13 14 16 17 0 0 [16,] 1 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 0 [17,] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 $coefficients 1st 2nd 3rd (Intercept) 0.139677983 0.1382163301 0.722105687 survived 0.351855854 0.1602346217 -0.512090476 h(sibsp-1) -0.047958497 -0.0675639271 0.115522424 h(2-parch) 0.217333399 0.0094234505 -0.226756850 survived*h(16-age) -0.023258457 0.0186856516 0.004572806 survived*sexmale -0.095932289 -0.3032702269 0.399202516 sexmale 0.109367428 0.1365288369 -0.245896265 h(55-age)*h(2-parch) -0.007847314 0.0000355992 0.007811715 h(1-sibsp)*h(1-parch) -0.162393009 -0.0328783910 0.195271400 $rss.per.response [1] 148.5253 187.8072 190.3968 $rsq.per.response [1] 0.28210854 0.04118751 0.27061448 $gcv.per.response [1] 0.1478715 0.1869804 0.1895587 $grsq.per.response [1] 0.253819943 0.003405389 0.241872961 $rss.per.subset [1] 663.8031 618.3144 587.1155 558.2529 550.5473 546.0083 539.0533 532.1400 526.7293 526.1097 522.0963 519.3960 516.5436 515.0676 514.2161 513.5054 513.3259 $gcv.per.subset [1] 0.6358261 0.5950986 0.5677911 0.5424834 0.5375831 0.5357360 0.5314825 0.5272225 0.5244105 0.5263582 0.5249065 0.5247609 0.5244530 0.5255400 0.5272719 0.5291595 0.5316095 $leverages [1] 0.005158606 0.033494707 0.017266066 0.011963928 0.017266066 0.011263458 0.011670960 0.002889399 0.014370755 0.007592325 0.008274991 0.008886300 0.005594526 0.005363932 0.013850834 0.005386378 [17] 0.005441478 0.005121957 0.002541748 0.010859171 0.005243409 0.009110406 0.006218027 0.005158606 0.002710161 0.012630619 0.008624204 0.005253987 0.008931298 0.004090736 0.009430977 0.005127648 [33] 0.010444850 0.003405728 0.006912318 0.005232760 0.003214876 0.004944421 0.006662146 0.015229279 0.010444850 0.006024081 0.004090736 0.009776645 0.009588407 0.010855244 0.005865304 0.002362774 [49] 0.002439326 0.004257037 0.014508881 0.009550159 0.017792581 0.010894224 0.005266467 0.006450345 0.011670960 0.008015404 0.008894797 0.012364077 0.006922784 0.005335481 0.005127648 0.010435712 [65] 0.006644234 0.007314315 0.005900089 0.004641118 0.004921387 0.005128157 0.010894224 0.015229279 0.006077876 0.010894224 0.005865304 0.006723071 0.007205379 0.012259881 0.009011481 0.005147225 [81] 0.006370641 0.010894224 0.012055896 0.009167137 0.011559223 0.024055130 0.005771168 0.009166204 0.005000615 0.009176221 0.009176221 0.014380004 0.002889399 0.005176960 0.005554695 0.011258343 [97] 0.012825352 0.008964545 0.002352479 0.014998031 0.014998031 0.014998031 0.013529385 0.011963928 0.010894224 0.005127648 0.017721685 0.012930589 0.010894224 0.011731068 0.005304747 0.006522512 [113] 0.006979596 0.004641118 0.005253987 0.005232760 0.005134791 0.002837924 0.014380004 0.007592325 0.013017873 0.006498998 0.005141092 0.005865304 0.011230581 0.005134791 0.004356556 0.012630619 [129] 0.007445216 0.014091580 0.009476386 0.007774559 0.006979596 0.003042767 0.009011481 0.005594526 0.006077876 0.005596952 0.003405728 0.007592325 0.005665956 0.005087510 0.010132943 0.007164476 [145] 0.006979596 0.008894792 0.012238148 0.006979596 0.005554695 0.016839282 0.011576857 0.004356556 0.005607255 0.002349345 0.007592325 0.006998599 0.012754617 0.008388177 0.005692415 0.008100426 [161] 0.005127648 0.008894792 0.003405728 0.010444850 0.005665956 0.005516873 0.002386532 0.006080983 0.002352479 0.010444850 0.005177299 0.002352479 0.007266584 0.008091037 0.008886300 0.005594526 [177] 0.004356556 0.007157827 0.008964545 0.006547723 0.007592325 0.009555430 0.006922784 0.007111376 0.012104828 0.007592325 0.004641118 0.005128157 0.006940939 0.007763244 0.011963928 0.010894224 [193] 0.007592325 0.005692415 0.005232760 0.006077876 0.002410586 0.004221303 0.002984428 0.006469953 0.007950371 0.008356226 0.009167137 0.005127648 0.012629506 0.004641118 0.005865304 0.002754773 [209] 0.003149675 0.005044914 0.002337169 0.010435712 0.005147225 0.004356556 0.002541748 0.005147225 0.011026399 0.011258343 0.002362774 0.013933400 0.010020765 0.010020765 0.011963928 0.010894224 [225] 0.005594526 0.006979596 0.005127648 0.008843781 0.005848877 0.008894792 0.009166204 0.007318124 0.013850834 0.008931298 0.007592325 0.007592325 0.007046220 0.008886300 0.012792003 0.007763244 [241] 0.019643889 0.011059261 0.004945241 0.011026399 0.008797985 0.007592325 0.016103256 0.007956525 0.010489334 0.010444850 0.011026399 0.021013236 0.007592325 0.007775286 0.010894224 0.005814165 [257] 0.004921387 0.014091580 0.005592625 0.017792581 0.004921387 0.008803201 0.003042767 0.007592325 0.004641118 0.005253987 0.011026399 0.011670960 0.007592325 0.005985287 0.005558420 0.010444850 [273] 0.010894224 0.006077876 0.005134791 0.005661786 0.011963928 0.005441478 0.006080983 0.005735633 0.011358608 0.005115432 0.007592325 0.005335481 0.006410926 0.007108739 0.002352479 0.003998081 [289] 0.002710161 0.006362237 0.007036115 0.007592325 0.003998081 0.002984428 0.005335481 0.002439326 0.005966785 0.012025706 0.008624204 0.002439326 0.033505449 0.023497806 0.006963553 0.010894224 [305] 0.008843781 0.006498998 0.002984428 0.002601141 0.003405728 0.002510862 0.005594526 0.010053817 0.006077876 0.004945241 0.008380851 0.006893482 0.005335481 0.002710161 0.003405728 0.006218027 [321] 0.033794505 0.011073682 0.005232760 0.005253987 0.003757866 0.016794103 0.010616876 0.006345057 0.006522512 0.014695434 0.005079416 0.010894224 0.006469953 0.007108739 0.002386532 0.002439326 [337] 0.009364483 0.013599923 0.005148940 0.004899238 0.005900089 0.012229617 0.003333663 0.013085174 0.003998081 0.010894224 0.005208306 0.002340601 0.004257037 0.006469953 0.007594859 0.002710161 [353] 0.003998081 0.005502815 0.004872402 0.007157827 0.016579641 0.005239689 0.004872402 0.007202156 0.006978130 0.002984428 0.003333663 0.003998081 0.006851464 0.007034064 0.003998081 0.002541748 [369] 0.013173866 0.002463348 0.006613420 0.006362237 0.005191235 0.004534736 0.002601141 0.004641118 0.007616884 0.007616884 0.002837924 0.002837924 0.002403690 0.002352479 0.006345057 0.002352479 [385] 0.032582313 0.010894224 0.003843658 0.015413122 0.005222587 0.013850834 0.002352479 0.015453503 0.005276052 0.005134791 0.010894224 0.010894224 0.011963928 0.010894224 0.010444850 0.008528887 [401] 0.008039888 0.009021505 0.012163845 0.006245578 0.005096049 0.002541748 0.010894224 0.005607255 0.007552456 0.007034064 0.003333663 0.009776645 0.011026399 0.021013236 0.002362774 0.006991980 [417] 0.007164476 0.006065037 0.004641118 0.008528887 0.008838557 0.002340601 0.005737937 0.006362237 0.007594859 0.012484856 0.002463348 0.006912318 0.007592325 0.002337169 0.011957304 0.005168804 [433] 0.033646698 0.026235307 0.011963928 0.010894224 0.006991980 0.005191235 0.002541748 0.002837924 0.007592325 0.009166204 0.007768811 0.019163075 0.033197605 0.005148940 0.005125845 0.002352479 [449] 0.003042767 0.002340601 0.002352479 0.004356556 0.005175567 0.004973780 0.010327659 0.002889399 0.004944421 0.007592325 0.002510862 0.007157827 0.002889399 0.004534736 0.007592325 0.006345354 [465] 0.009798160 0.027736707 0.024481800 0.011963928 0.002601141 0.005696542 0.002439326 0.010097540 0.005158606 0.002889399 0.009693527 0.002984428 0.008869857 0.002439326 0.005441478 0.003757866 [481] 0.003214876 0.005293246 0.006498998 0.005276052 0.005121957 0.002403690 0.008827158 0.002510862 0.028417425 0.010862136 0.010894224 0.002541748 0.006362237 0.018644724 0.005208306 0.002984428 [497] 0.031945235 0.024481800 0.010020765 0.008444309 0.003757866 0.006080983 0.002601141 0.002710161 0.002510862 0.005079416 0.010894224 0.006280619 0.005127648 0.007592325 0.005127648 0.002463348 [513] 0.005848877 0.002710161 0.003214876 0.002710161 0.003875631 0.005146359 0.008444309 0.002984428 0.005208306 0.005276748 0.006469953 0.014734225 0.003042767 0.005115432 0.006410926 0.007217699 [529] 0.005115432 0.009630894 0.005848877 0.005132249 0.006644234 0.007034064 0.027736707 0.021264885 0.010894224 0.033984602 0.020170908 0.011963928 0.010894224 0.007592325 0.008803201 0.005363932 [545] 0.012308595 0.003405728 0.011963928 0.005938866 0.004872828 0.007266584 0.009228074 0.010097540 0.006736118 0.002352479 0.002601141 0.015822134 0.031945235 0.005502815 0.009110406 0.002601141 [561] 0.003536394 0.002837924 0.002710161 0.002463348 0.003998081 0.002340601 0.008624204 0.023088199 0.028683036 0.028683036 0.025826021 0.028683036 0.028683036 0.028683036 0.011963928 0.009011481 [577] 0.002601141 0.017266066 0.003536394 0.002601141 0.006893482 0.015836517 0.002837924 0.002463348 0.023088199 0.023088199 0.045566605 0.023088199 0.039375881 0.011963928 0.009519634 0.010894224 [593] 0.006912318 0.003333663 0.002984428 0.013253497 0.002352479 0.002984428 0.008555300 0.003536394 0.006349098 0.018745469 0.036159802 0.036159802 0.020292844 0.010894224 0.006736118 0.003042767 [609] 0.002601141 0.010097540 0.012163845 0.012668599 0.012184767 0.003149675 0.003757866 0.002601141 0.003149675 0.003536394 0.008797985 0.003333663 0.003998081 0.002601141 0.007051171 0.012754646 [625] 0.005181020 0.011999189 0.003333663 0.005900089 0.012736086 0.006469953 0.007407921 0.003149675 0.002463348 0.012973707 0.009886162 0.003757866 0.013062285 0.012601100 0.012229617 0.003998081 [641] 0.002754773 0.004257037 0.004257037 0.012601100 0.003333663 0.003333663 0.002439326 0.002837924 0.007266584 0.012990238 0.002439326 0.002837924 0.003333663 0.008797985 0.002386532 0.006759487 [657] 0.008356226 0.003536394 0.010576520 0.002837924 0.002541748 0.002837924 0.002337169 0.002337169 0.005900089 0.012229617 0.007592325 0.003615322 0.002463348 0.002510862 0.003757866 0.002352479 [673] 0.011781432 0.024481800 0.010894224 0.007592325 0.003757866 0.005582043 0.005317100 0.004257037 0.003064709 0.010435712 0.012484856 0.003757866 0.005127648 0.008869857 0.011963928 0.005117464 [689] 0.011952523 0.002510862 0.002710161 0.008528887 0.003149675 0.009021505 0.009940717 0.012121784 0.007036115 0.008827158 0.004534736 0.033197605 0.037132184 0.011963928 0.010894224 0.002710161 [705] 0.003149675 0.002541748 0.006498998 0.004257037 0.003405728 0.003615322 0.002340601 0.010327659 0.005127648 0.012308595 0.005737937 0.002362774 0.007592325 0.009364483 0.007217699 0.007950371 [721] 0.003998081 0.004534736 0.004090736 0.011963928 0.005853406 0.006029012 0.004641118 0.026204360 0.003126479 0.003126479 0.003998081 0.002601141 0.015220999 0.015220999 0.009821294 0.011963928 [737] 0.017266066 0.002710161 0.003149675 0.007266584 0.015552639 0.005123271 0.003214876 0.004899238 0.002754773 0.038497738 0.038497738 0.038497738 0.044190141 0.044190141 0.038497738 0.011963928 [753] 0.017266066 0.005966785 0.002340601 0.003536394 0.008343378 0.008134451 0.003757866 0.012308595 0.013253497 0.006547723 0.007594859 0.003536394 0.002908833 0.008923527 0.006759487 0.003333663 [769] 0.008388177 0.002710161 0.006204359 0.009011481 0.013062285 0.005363932 0.012387354 0.005900089 0.002439326 0.012180975 0.028417425 0.005232760 0.003615322 0.002439326 0.005276748 0.003405728 [785] 0.002352479 0.014734225 0.014847985 0.008869857 0.009886162 0.003536394 0.004944421 0.008640158 0.002403690 0.009110406 0.003149675 0.002362774 0.002337169 0.002386532 0.021552086 0.032481486 [801] 0.005266467 0.002362774 0.003757866 0.010894224 0.002984428 0.008797985 0.002510862 0.015460369 0.015300409 0.008797985 0.004257037 0.003333663 0.002352479 0.009886162 0.002362774 0.003149675 [817] 0.021264885 0.010881080 0.003875631 0.002431176 0.003843658 0.016687392 0.008294185 0.023034733 0.018030683 0.005037673 0.013598416 0.005772631 0.017266066 0.009228074 0.012990238 0.005900089 [833] 0.009110406 0.002386532 0.002386532 0.003149675 0.009693527 0.002340601 0.002431176 0.002541748 0.002889399 0.002837924 0.012248577 0.014984041 0.006450345 0.014704151 0.013624959 0.002439326 [849] 0.006410926 0.014781734 0.003432686 0.009011481 0.005966785 0.005737937 0.008797985 0.009364483 0.003149675 0.002386532 0.012253491 0.002463348 0.002362774 0.007373145 0.012679208 0.007046220 [865] 0.015639072 0.007592325 0.009886162 0.002837924 0.003333663 0.002439326 0.002710161 0.016668242 0.005000615 0.002403690 0.005594526 0.003998081 0.003149675 0.007373145 0.033646698 0.011429649 [881] 0.005428273 0.002362774 0.014800364 0.009798160 0.012195925 0.002439326 0.006736118 0.005363932 0.003333663 0.003214876 0.009286256 0.003333663 0.002410586 0.005900089 0.007592325 0.002984428 [897] 0.005900089 0.011781432 0.002439326 0.005239689 0.012282051 0.002439326 0.008797985 0.003536394 0.012387354 0.012736086 0.003536394 0.004534736 0.005115432 0.012245706 0.011773651 0.018198928 [913] 0.017813362 0.017266066 0.023447722 0.022817686 0.023331002 0.022188904 0.022295835 0.017266066 0.003333663 0.003757866 0.002340601 0.007822697 0.013359360 0.017266066 0.003333663 0.002710161 [929] 0.003149675 0.012630619 0.002837924 0.012180975 0.003757866 0.006893482 0.013062285 0.008797985 0.004257037 0.002837924 0.002754773 0.003333663 0.022565922 0.023111619 0.022817686 0.023331002 [945] 0.022729079 0.017266066 0.012484856 0.002463348 0.009166204 0.017719872 0.013476545 0.005772631 0.017266066 0.005607255 0.004534736 0.002710161 0.002819743 0.119830700 0.002837924 0.006080983 [961] 0.002889399 0.032481486 0.010894224 0.021264885 0.009228074 0.003536394 0.002771700 0.008869857 0.003149675 0.003042767 0.003333663 0.006736118 0.013529385 0.013529385 0.019026655 0.019026655 [977] 0.011963928 0.017266066 0.003757866 0.002352479 0.002340601 0.002362774 0.005737937 0.003333663 0.007592325 0.003757866 0.012484856 0.008803201 0.002510862 0.013476545 0.011957161 0.011130469 [993] 0.010197281 0.002710161 0.007592325 0.010710424 0.002837924 0.009228074 0.002403690 0.033555247 0.005665956 0.002340601 0.002342481 0.003843658 0.009228074 0.014714111 0.009074434 0.010894224 [1009] 0.002541748 0.006736118 0.010444850 0.006381420 0.011963928 0.017266066 0.005119907 0.011966485 0.002362774 0.002439326 0.002439326 0.004641118 0.017260659 0.015550914 0.010217375 0.014731610 [1025] 0.009693527 0.003536394 0.013939585 0.003149675 0.003149675 0.002349345 0.005554695 0.005966785 0.008356226 0.007616884 0.008894797 0.002410586 0.003333663 0.002510862 0.002541748 0.006644234 [1041] 0.009470932 0.004221303 0.016675168 0.002553659 0.002510862 0.002386532 $pmethod [1] "backward" $nprune NULL $penalty [1] 3 $nk [1] 21 $thresh [1] 0.001 $termcond [1] 7 $weights NULL $glm.list $glm.list[[1]] Call: glm(formula = yarg ~ ., family = family, data = bx.data.frame, weights = weights, na.action = na.action, offset = offset, control = control, model = TRUE, method = "glm.fit", x = TRUE, y = TRUE, contrasts = NULL, trace = (trace >= 2)) Coefficients: (Intercept) survived `h(sibsp-1)` `h(2-parch)` `survived*h(16-age)` `survived*sexmale` sexmale `h(55-age)*h(2-parch)` -2.66307 2.84789 -0.52880 1.25519 -0.17825 -1.25498 1.42483 -0.04946 `h(1-sibsp)*h(1-parch)` -1.02163 Degrees of Freedom: 1045 Total (i.e. Null); 1037 Residual Null Deviance: 1223 Residual Deviance: 894.8 AIC: 912.8 $glm.list[[2]] Call: glm(formula = yarg ~ ., family = family, data = bx.data.frame, weights = weights, na.action = na.action, offset = offset, control = control, model = TRUE, method = "glm.fit", x = TRUE, y = TRUE, contrasts = NULL, trace = (trace >= 2)) Coefficients: (Intercept) survived `h(sibsp-1)` `h(2-parch)` `survived*h(16-age)` `survived*sexmale` sexmale `h(55-age)*h(2-parch)` -1.9313615 1.0641827 -0.6492895 0.0653459 0.0939009 -1.9509922 0.9659886 0.0004374 `h(1-sibsp)*h(1-parch)` -0.2190244 Degrees of Freedom: 1045 Total (i.e. Null); 1037 Residual Null Deviance: 1175 Residual Deviance: 1127 AIC: 1145 $glm.list[[3]] Call: glm(formula = yarg ~ ., family = family, data = bx.data.frame, weights = weights, na.action = na.action, offset = offset, control = control, model = TRUE, method = "glm.fit", x = TRUE, y = TRUE, contrasts = NULL, trace = (trace >= 2)) Coefficients: (Intercept) survived `h(sibsp-1)` `h(2-parch)` `survived*h(16-age)` `survived*sexmale` sexmale `h(55-age)*h(2-parch)` 1.37993 -2.84379 0.79975 -1.29856 0.02012 2.28554 -1.45240 0.04146 `h(1-sibsp)*h(1-parch)` 1.12491 Degrees of Freedom: 1045 Total (i.e. Null); 1037 Residual Null Deviance: 1448 Residual Deviance: 1119 AIC: 1137 $glm.coefficients 1st 2nd 3rd (Intercept) -2.66307135 -1.931361472 1.37992944 survived 2.84788552 1.064182711 -2.84378575 h(sibsp-1) -0.52879762 -0.649289486 0.79974678 h(2-parch) 1.25518755 0.065345867 -1.29855706 survived*h(16-age) -0.17824991 0.093900852 0.02011681 survived*sexmale -1.25498201 -1.950992216 2.28554497 sexmale 1.42483431 0.965988623 -1.45239590 h(55-age)*h(2-parch) -0.04946408 0.000437374 0.04146455 h(1-sibsp)*h(1-parch) -1.02162885 -0.219024356 1.12490799 $glm.stats nulldev df dev df devratio AIC iters converged 1st 1223.308 1045 894.8141 1037 0.2685294 912.8141 5 1 2nd 1175.305 1045 1126.9441 1037 0.0411477 1144.9441 5 1 3rd 1448.212 1045 1118.9411 1037 0.2273640 1136.9411 5 1 $call earth(formula = pclass ~ ., data = etitanic, keepxy = TRUE, trace = 1, glm = list(family = "binomial"), degree = 2, nfold = 3, ncross = 2) $namesx.org [1] "survived" "sex" "age" "sibsp" "parch" $namesx [1] "survived" "sex" "age" "sibsp" "parch" $terms pclass ~ survived + sex + age + sibsp + parch attr(,"variables") list(pclass, survived, sex, age, sibsp, parch) attr(,"factors") survived sex age sibsp parch pclass 0 0 0 0 0 survived 1 0 0 0 0 sex 0 1 0 0 0 age 0 0 1 0 0 sibsp 0 0 0 1 0 parch 0 0 0 0 1 attr(,"term.labels") [1] "survived" "sex" "age" "sibsp" "parch" attr(,"order") [1] 1 1 1 1 1 attr(,"intercept") [1] 1 attr(,"response") [1] 1 attr(,".Environment") attr(,"predvars") list(pclass, survived, sex, age, sibsp, parch) attr(,"dataClasses") pclass survived sex age sibsp parch "factor" "numeric" "factor" "numeric" "numeric" "numeric" $xlevels $xlevels$sex [1] "female" "male" $levels [1] "1st" "2nd" "3rd" $data pclass survived sex age sibsp parch 1 1st 1 female 29.0000 0 0 2 1st 1 male 0.9167 1 2 3 1st 0 female 2.0000 1 2 4 1st 0 male 30.0000 1 2 5 1st 0 female 25.0000 1 2 6 1st 1 male 48.0000 0 0 7 1st 1 female 63.0000 1 0 8 1st 0 male 39.0000 0 0 9 1st 1 female 53.0000 2 0 10 1st 0 male 71.0000 0 0 11 1st 0 male 47.0000 1 0 12 1st 1 female 18.0000 1 0 13 1st 1 female 24.0000 0 0 14 1st 1 female 26.0000 0 0 15 1st 1 male 80.0000 0 0 17 1st 0 male 24.0000 0 1 18 1st 1 female 50.0000 0 1 19 1st 1 female 32.0000 0 0 20 1st 0 male 36.0000 0 0 21 1st 1 male 37.0000 1 1 22 1st 1 female 47.0000 1 1 23 1st 1 male 26.0000 0 0 24 1st 1 female 42.0000 0 0 25 1st 1 female 29.0000 0 0 26 1st 0 male 25.0000 0 0 27 1st 1 male 25.0000 1 0 28 1st 1 female 19.0000 1 0 29 1st 1 female 35.0000 0 0 30 1st 1 male 28.0000 0 0 31 1st 0 male 45.0000 0 0 32 1st 1 male 40.0000 0 0 33 1st 1 female 30.0000 0 0 34 1st 1 female 58.0000 0 0 35 1st 0 male 42.0000 0 0 36 1st 1 female 45.0000 0 0 37 1st 1 female 22.0000 0 1 39 1st 0 male 41.0000 0 0 40 1st 0 male 48.0000 0 0 42 1st 1 female 44.0000 0 0 43 1st 1 female 59.0000 2 0 44 1st 1 female 60.0000 0 0 45 1st 1 female 41.0000 0 0 46 1st 0 male 45.0000 0 0 48 1st 1 male 42.0000 0 0 49 1st 1 female 53.0000 0 0 50 1st 1 male 36.0000 0 1 51 1st 1 female 58.0000 0 1 52 1st 0 male 33.0000 0 0 53 1st 0 male 28.0000 0 0 54 1st 0 male 17.0000 0 0 55 1st 1 male 11.0000 1 2 56 1st 1 female 14.0000 1 2 57 1st 1 male 36.0000 1 2 58 1st 1 female 36.0000 1 2 59 1st 0 male 49.0000 0 0 61 1st 0 male 36.0000 1 0 62 1st 1 female 76.0000 1 0 63 1st 0 male 46.0000 1 0 64 1st 1 female 47.0000 1 0 65 1st 1 male 27.0000 1 0 66 1st 1 female 33.0000 1 0 67 1st 1 female 36.0000 0 0 68 1st 1 female 30.0000 0 0 69 1st 1 male 45.0000 0 0 72 1st 0 male 27.0000 1 0 73 1st 1 female 26.0000 1 0 74 1st 1 female 22.0000 0 0 76 1st 0 male 47.0000 0 0 77 1st 1 female 39.0000 1 1 78 1st 0 male 37.0000 1 1 79 1st 1 female 64.0000 0 2 80 1st 1 female 55.0000 2 0 82 1st 0 male 70.0000 1 1 83 1st 1 female 36.0000 0 2 84 1st 1 female 64.0000 1 1 85 1st 0 male 39.0000 1 0 86 1st 1 female 38.0000 1 0 87 1st 1 male 51.0000 0 0 88 1st 1 male 27.0000 0 0 89 1st 1 female 33.0000 0 0 90 1st 0 male 31.0000 1 0 91 1st 1 female 27.0000 1 2 92 1st 1 male 31.0000 1 0 93 1st 1 female 17.0000 1 0 94 1st 1 male 53.0000 1 1 95 1st 1 male 4.0000 0 2 96 1st 1 female 54.0000 1 1 97 1st 0 male 50.0000 1 0 98 1st 1 female 27.0000 1 1 99 1st 1 female 48.0000 1 0 100 1st 1 female 48.0000 1 0 101 1st 1 male 49.0000 1 0 102 1st 0 male 39.0000 0 0 103 1st 1 female 23.0000 0 1 104 1st 1 female 38.0000 0 0 105 1st 1 female 54.0000 1 0 106 1st 0 female 36.0000 0 0 110 1st 1 male 36.0000 0 0 111 1st 0 male 30.0000 0 0 112 1st 1 female 24.0000 3 2 113 1st 1 female 28.0000 3 2 114 1st 1 female 23.0000 3 2 115 1st 0 male 19.0000 3 2 116 1st 0 male 64.0000 1 4 117 1st 1 female 60.0000 1 4 118 1st 1 female 30.0000 0 0 120 1st 1 male 50.0000 2 0 121 1st 1 male 43.0000 1 0 123 1st 1 female 22.0000 0 2 124 1st 1 male 60.0000 1 1 125 1st 1 female 48.0000 1 1 127 1st 0 male 37.0000 1 0 128 1st 1 female 35.0000 1 0 129 1st 0 male 47.0000 0 0 130 1st 1 female 35.0000 0 0 131 1st 1 female 22.0000 0 1 132 1st 1 female 45.0000 0 1 133 1st 0 male 24.0000 0 0 134 1st 1 male 49.0000 1 0 136 1st 0 male 71.0000 0 0 137 1st 1 male 53.0000 0 0 138 1st 1 female 19.0000 0 0 139 1st 0 male 38.0000 0 1 140 1st 1 female 58.0000 0 1 141 1st 1 male 23.0000 0 1 142 1st 1 female 45.0000 0 1 143 1st 0 male 46.0000 0 0 144 1st 1 male 25.0000 1 0 145 1st 1 female 25.0000 1 0 146 1st 1 male 48.0000 1 0 147 1st 1 female 49.0000 1 0 149 1st 0 male 45.0000 1 0 150 1st 1 female 35.0000 1 0 151 1st 0 male 40.0000 0 0 152 1st 1 male 27.0000 0 0 154 1st 1 female 24.0000 0 0 155 1st 0 male 55.0000 1 1 156 1st 1 female 52.0000 1 1 157 1st 0 male 42.0000 0 0 159 1st 0 male 55.0000 0 0 160 1st 1 female 16.0000 0 1 161 1st 1 female 44.0000 0 1 162 1st 1 female 51.0000 1 0 163 1st 0 male 42.0000 1 0 164 1st 1 female 35.0000 1 0 165 1st 1 male 35.0000 0 0 166 1st 1 male 38.0000 1 0 168 1st 1 female 35.0000 1 0 169 1st 1 female 38.0000 0 0 170 1st 0 female 50.0000 0 0 171 1st 1 male 49.0000 0 0 172 1st 0 male 46.0000 0 0 173 1st 0 male 50.0000 0 0 174 1st 0 male 32.5000 0 0 175 1st 0 male 58.0000 0 0 176 1st 0 male 41.0000 1 0 178 1st 1 male 42.0000 1 0 179 1st 1 female 45.0000 1 0 181 1st 1 female 39.0000 0 0 182 1st 1 female 49.0000 0 0 183 1st 1 female 30.0000 0 0 184 1st 1 male 35.0000 0 0 186 1st 0 male 42.0000 0 0 187 1st 1 female 55.0000 0 0 188 1st 1 female 16.0000 0 1 189 1st 1 female 51.0000 0 1 190 1st 0 male 29.0000 0 0 191 1st 1 female 21.0000 0 0 192 1st 0 male 30.0000 0 0 193 1st 1 female 58.0000 0 0 194 1st 1 female 15.0000 0 1 195 1st 0 male 30.0000 0 0 196 1st 1 female 16.0000 0 0 198 1st 0 male 19.0000 1 0 199 1st 1 female 18.0000 1 0 200 1st 1 female 24.0000 0 0 201 1st 0 male 46.0000 0 0 202 1st 0 male 54.0000 0 0 203 1st 1 male 36.0000 0 0 204 1st 0 male 28.0000 1 0 206 1st 0 male 65.0000 0 0 207 1st 0 male 44.0000 2 0 208 1st 1 female 33.0000 1 0 209 1st 1 female 37.0000 1 0 210 1st 1 male 30.0000 1 0 211 1st 0 male 55.0000 0 0 212 1st 0 male 47.0000 0 0 213 1st 0 male 37.0000 0 1 214 1st 1 female 31.0000 1 0 215 1st 1 female 23.0000 1 0 216 1st 0 male 58.0000 0 2 217 1st 1 female 19.0000 0 2 218 1st 0 male 64.0000 0 0 219 1st 1 female 39.0000 0 0 221 1st 1 female 22.0000 0 1 222 1st 0 male 65.0000 0 1 223 1st 0 male 28.5000 0 0 225 1st 0 male 45.5000 0 0 226 1st 0 male 23.0000 0 0 227 1st 0 male 29.0000 1 0 228 1st 1 female 22.0000 1 0 229 1st 0 male 18.0000 1 0 230 1st 1 female 17.0000 1 0 231 1st 1 female 30.0000 0 0 232 1st 1 male 52.0000 0 0 233 1st 0 male 47.0000 0 0 234 1st 1 female 56.0000 0 1 235 1st 0 male 38.0000 0 0 237 1st 0 male 22.0000 0 0 239 1st 1 female 43.0000 0 1 240 1st 0 male 31.0000 0 0 241 1st 1 male 45.0000 0 0 243 1st 1 female 33.0000 0 0 244 1st 0 male 46.0000 0 0 245 1st 0 male 36.0000 0 0 246 1st 1 female 33.0000 0 0 247 1st 0 male 55.0000 1 0 248 1st 1 female 54.0000 1 0 249 1st 0 male 33.0000 0 0 250 1st 1 male 13.0000 2 2 251 1st 1 female 18.0000 2 2 252 1st 1 female 21.0000 2 2 253 1st 0 male 61.0000 1 3 254 1st 1 female 48.0000 1 3 256 1st 1 female 24.0000 0 0 258 1st 1 female 35.0000 1 0 259 1st 1 female 30.0000 0 0 260 1st 1 male 34.0000 0 0 261 1st 1 female 40.0000 0 0 262 1st 1 male 35.0000 0 0 263 1st 0 male 50.0000 1 0 264 1st 1 female 39.0000 1 0 265 1st 1 male 56.0000 0 0 266 1st 1 male 28.0000 0 0 267 1st 0 male 56.0000 0 0 268 1st 0 male 56.0000 0 0 269 1st 0 male 24.0000 1 0 271 1st 1 female 18.0000 1 0 272 1st 1 male 24.0000 1 0 273 1st 1 female 23.0000 1 0 274 1st 1 male 6.0000 0 2 275 1st 1 male 45.0000 1 1 276 1st 1 female 40.0000 1 1 277 1st 0 male 57.0000 1 0 279 1st 1 male 32.0000 0 0 280 1st 0 male 62.0000 0 0 281 1st 1 male 54.0000 1 0 282 1st 1 female 43.0000 1 0 283 1st 1 female 52.0000 1 0 285 1st 1 female 62.0000 0 0 286 1st 0 male 67.0000 1 0 287 1st 0 female 63.0000 1 0 288 1st 0 male 61.0000 0 0 289 1st 1 female 48.0000 0 0 290 1st 1 female 18.0000 0 2 291 1st 0 male 52.0000 1 1 292 1st 1 female 39.0000 1 1 293 1st 1 male 48.0000 1 0 295 1st 0 male 49.0000 1 1 296 1st 1 male 17.0000 0 2 297 1st 1 female 39.0000 1 1 299 1st 1 male 31.0000 0 0 300 1st 0 male 40.0000 0 0 301 1st 0 male 61.0000 0 0 302 1st 0 male 47.0000 0 0 303 1st 1 female 35.0000 0 0 304 1st 0 male 64.0000 1 0 305 1st 1 female 60.0000 1 0 306 1st 0 male 60.0000 0 0 307 1st 0 male 54.0000 0 1 308 1st 0 male 21.0000 0 1 309 1st 1 female 55.0000 0 0 310 1st 1 female 31.0000 0 2 311 1st 0 male 57.0000 1 1 312 1st 1 female 45.0000 1 1 313 1st 0 male 50.0000 1 1 314 1st 0 male 27.0000 0 2 315 1st 1 female 50.0000 1 1 316 1st 1 female 21.0000 0 0 317 1st 0 male 51.0000 0 1 318 1st 1 male 21.0000 0 1 320 1st 1 female 31.0000 0 0 322 1st 0 male 62.0000 0 0 323 1st 1 female 36.0000 0 0 324 2nd 0 male 30.0000 1 0 325 2nd 1 female 28.0000 1 0 326 2nd 0 male 30.0000 0 0 327 2nd 0 male 18.0000 0 0 328 2nd 0 male 25.0000 0 0 329 2nd 0 male 34.0000 1 0 330 2nd 1 female 36.0000 1 0 331 2nd 0 male 57.0000 0 0 332 2nd 0 male 18.0000 0 0 333 2nd 0 male 23.0000 0 0 334 2nd 1 female 36.0000 0 0 335 2nd 0 male 28.0000 0 0 336 2nd 0 male 51.0000 0 0 337 2nd 1 male 32.0000 1 0 338 2nd 1 female 19.0000 1 0 339 2nd 0 male 28.0000 0 0 340 2nd 1 male 1.0000 2 1 341 2nd 1 female 4.0000 2 1 342 2nd 1 female 12.0000 2 1 343 2nd 1 female 36.0000 0 3 344 2nd 1 male 34.0000 0 0 345 2nd 1 female 19.0000 0 0 346 2nd 0 male 23.0000 0 0 347 2nd 0 male 26.0000 0 0 348 2nd 0 male 42.0000 0 0 349 2nd 0 male 27.0000 0 0 350 2nd 1 female 24.0000 0 0 351 2nd 1 female 15.0000 0 2 352 2nd 0 male 60.0000 1 1 353 2nd 1 female 40.0000 1 1 354 2nd 1 female 20.0000 1 0 355 2nd 0 male 25.0000 1 0 356 2nd 1 female 36.0000 0 0 357 2nd 0 male 25.0000 0 0 358 2nd 0 male 42.0000 0 0 359 2nd 1 female 42.0000 0 0 360 2nd 1 male 0.8333 0 2 361 2nd 1 male 26.0000 1 1 362 2nd 1 female 22.0000 1 1 363 2nd 1 female 35.0000 0 0 365 2nd 0 male 19.0000 0 0 366 2nd 0 female 44.0000 1 0 367 2nd 0 male 54.0000 1 0 368 2nd 0 male 52.0000 0 0 369 2nd 0 male 37.0000 1 0 370 2nd 0 female 29.0000 1 0 371 2nd 1 female 25.0000 1 1 372 2nd 1 female 45.0000 0 2 373 2nd 0 male 29.0000 1 0 374 2nd 1 female 28.0000 1 0 375 2nd 0 male 29.0000 0 0 376 2nd 0 male 28.0000 0 0 377 2nd 1 male 24.0000 0 0 378 2nd 1 female 8.0000 0 2 379 2nd 0 male 31.0000 1 1 380 2nd 1 female 31.0000 1 1 381 2nd 1 female 22.0000 0 0 382 2nd 0 female 30.0000 0 0 384 2nd 0 male 21.0000 0 0 386 2nd 1 male 8.0000 1 1 387 2nd 0 male 18.0000 0 0 388 2nd 1 female 48.0000 0 2 389 2nd 1 female 28.0000 0 0 390 2nd 0 male 32.0000 0 0 391 2nd 0 male 17.0000 0 0 392 2nd 0 male 29.0000 1 0 393 2nd 1 female 24.0000 1 0 394 2nd 0 male 25.0000 0 0 395 2nd 0 male 18.0000 0 0 396 2nd 1 female 18.0000 0 1 397 2nd 1 female 34.0000 0 1 398 2nd 0 male 54.0000 0 0 399 2nd 1 male 8.0000 0 2 400 2nd 0 male 42.0000 1 1 401 2nd 1 female 34.0000 1 1 402 2nd 1 female 27.0000 1 0 403 2nd 1 female 30.0000 1 0 404 2nd 0 male 23.0000 0 0 405 2nd 0 male 21.0000 0 0 406 2nd 0 male 18.0000 0 0 407 2nd 0 male 40.0000 1 0 408 2nd 1 female 29.0000 1 0 409 2nd 0 male 18.0000 0 0 410 2nd 0 male 36.0000 0 0 412 2nd 0 female 38.0000 0 0 413 2nd 0 male 35.0000 0 0 414 2nd 0 male 38.0000 1 0 415 2nd 0 male 34.0000 1 0 416 2nd 1 female 34.0000 0 0 417 2nd 0 male 16.0000 0 0 418 2nd 0 male 26.0000 0 0 419 2nd 0 male 47.0000 0 0 420 2nd 0 male 21.0000 1 0 421 2nd 0 male 21.0000 1 0 422 2nd 0 male 24.0000 0 0 423 2nd 0 male 24.0000 0 0 424 2nd 0 male 34.0000 0 0 425 2nd 0 male 30.0000 0 0 426 2nd 0 male 52.0000 0 0 427 2nd 0 male 30.0000 0 0 428 2nd 1 male 0.6667 1 1 429 2nd 1 female 24.0000 0 2 430 2nd 0 male 44.0000 0 0 431 2nd 1 female 6.0000 0 1 432 2nd 0 male 28.0000 0 1 433 2nd 1 male 62.0000 0 0 434 2nd 0 male 30.0000 0 0 435 2nd 1 female 7.0000 0 2 436 2nd 0 male 43.0000 1 1 437 2nd 1 female 45.0000 1 1 438 2nd 1 female 24.0000 1 2 439 2nd 1 female 24.0000 1 2 440 2nd 0 male 49.0000 1 2 441 2nd 1 female 48.0000 1 2 442 2nd 1 female 55.0000 0 0 443 2nd 0 male 24.0000 2 0 444 2nd 0 male 32.0000 2 0 445 2nd 0 male 21.0000 2 0 446 2nd 0 female 18.0000 1 1 447 2nd 1 female 20.0000 2 1 448 2nd 0 male 23.0000 2 1 449 2nd 0 male 36.0000 0 0 450 2nd 1 female 54.0000 1 3 451 2nd 0 male 50.0000 0 0 452 2nd 0 male 44.0000 1 0 453 2nd 1 female 29.0000 1 0 454 2nd 0 male 21.0000 0 0 455 2nd 1 male 42.0000 0 0 456 2nd 0 male 63.0000 1 0 457 2nd 0 female 60.0000 1 0 458 2nd 0 male 33.0000 0 0 459 2nd 1 female 17.0000 0 0 460 2nd 0 male 42.0000 1 0 461 2nd 1 female 24.0000 2 1 462 2nd 0 male 47.0000 0 0 463 2nd 0 male 24.0000 2 0 464 2nd 0 male 22.0000 2 0 465 2nd 0 male 32.0000 0 0 466 2nd 1 female 23.0000 0 0 467 2nd 0 male 34.0000 1 0 468 2nd 1 female 24.0000 1 0 469 2nd 0 female 22.0000 0 0 471 2nd 0 male 35.0000 0 0 472 2nd 1 female 45.0000 0 0 473 2nd 0 male 57.0000 0 0 475 2nd 0 male 31.0000 0 0 476 2nd 0 female 26.0000 1 1 477 2nd 0 male 30.0000 1 1 479 2nd 1 female 1.0000 1 2 480 2nd 1 female 3.0000 1 2 481 2nd 0 male 25.0000 1 2 482 2nd 1 female 22.0000 1 2 483 2nd 1 female 17.0000 0 0 485 2nd 1 female 34.0000 0 0 486 2nd 0 male 36.0000 0 0 487 2nd 0 male 24.0000 0 0 488 2nd 0 male 61.0000 0 0 489 2nd 0 male 50.0000 1 0 490 2nd 1 female 42.0000 1 0 491 2nd 0 female 57.0000 0 0 493 2nd 1 male 1.0000 0 2 494 2nd 0 male 31.0000 1 1 495 2nd 1 female 24.0000 1 1 497 2nd 0 male 30.0000 0 0 498 2nd 0 male 40.0000 0 0 499 2nd 0 male 32.0000 0 0 500 2nd 0 male 30.0000 0 0 501 2nd 0 male 46.0000 0 0 502 2nd 1 female 13.0000 0 1 503 2nd 1 female 41.0000 0 1 504 2nd 1 male 19.0000 0 0 505 2nd 0 male 39.0000 0 0 506 2nd 0 male 48.0000 0 0 507 2nd 0 male 70.0000 0 0 508 2nd 0 male 27.0000 0 0 509 2nd 0 male 54.0000 0 0 510 2nd 0 male 39.0000 0 0 511 2nd 0 male 16.0000 0 0 512 2nd 0 male 62.0000 0 0 513 2nd 0 male 32.5000 1 0 514 2nd 1 female 14.0000 1 0 515 2nd 1 male 2.0000 1 1 516 2nd 1 male 3.0000 1 1 517 2nd 0 male 36.5000 0 2 518 2nd 0 male 26.0000 0 0 519 2nd 0 male 19.0000 1 1 520 2nd 0 male 28.0000 0 0 521 2nd 1 male 20.0000 0 0 522 2nd 1 female 29.0000 0 0 523 2nd 0 male 39.0000 0 0 524 2nd 1 male 22.0000 0 0 526 2nd 0 male 23.0000 0 0 527 2nd 1 male 29.0000 0 0 528 2nd 0 male 28.0000 0 0 530 2nd 1 female 50.0000 0 1 531 2nd 0 male 19.0000 0 0 533 2nd 0 male 41.0000 0 0 534 2nd 1 female 21.0000 0 1 535 2nd 1 female 19.0000 0 0 536 2nd 0 male 43.0000 0 1 537 2nd 1 female 32.0000 0 0 538 2nd 0 male 34.0000 0 0 539 2nd 1 male 30.0000 0 0 540 2nd 0 male 27.0000 0 0 541 2nd 1 female 2.0000 1 1 542 2nd 1 female 8.0000 1 1 543 2nd 1 female 33.0000 0 2 544 2nd 0 male 36.0000 0 0 545 2nd 0 male 34.0000 1 0 546 2nd 1 female 30.0000 3 0 547 2nd 1 female 28.0000 0 0 548 2nd 0 male 23.0000 0 0 549 2nd 1 male 0.8333 1 1 550 2nd 1 male 3.0000 1 1 551 2nd 1 female 24.0000 2 3 552 2nd 1 female 50.0000 0 0 553 2nd 0 male 19.0000 0 0 554 2nd 1 female 21.0000 0 0 555 2nd 0 male 26.0000 0 0 556 2nd 0 male 25.0000 0 0 557 2nd 0 male 27.0000 0 0 558 2nd 1 female 25.0000 0 1 559 2nd 1 female 18.0000 0 2 560 2nd 1 female 20.0000 0 0 561 2nd 1 female 30.0000 0 0 562 2nd 0 male 59.0000 0 0 563 2nd 1 female 30.0000 0 0 564 2nd 0 male 35.0000 0 0 565 2nd 1 female 40.0000 0 0 566 2nd 0 male 25.0000 0 0 567 2nd 0 male 41.0000 0 0 568 2nd 0 male 25.0000 0 0 569 2nd 0 male 18.5000 0 0 570 2nd 0 male 14.0000 0 0 571 2nd 1 female 50.0000 0 0 572 2nd 0 male 23.0000 0 0 573 2nd 1 female 28.0000 0 0 574 2nd 1 female 27.0000 0 0 575 2nd 0 male 29.0000 1 0 576 2nd 0 female 27.0000 1 0 577 2nd 0 male 40.0000 0 0 578 2nd 1 female 31.0000 0 0 579 2nd 0 male 30.0000 1 0 580 2nd 0 male 23.0000 1 0 581 2nd 1 female 31.0000 0 0 583 2nd 1 female 12.0000 0 0 584 2nd 1 female 40.0000 0 0 585 2nd 1 female 32.5000 0 0 586 2nd 0 male 27.0000 1 0 587 2nd 1 female 29.0000 1 0 588 2nd 1 male 2.0000 1 1 589 2nd 1 female 4.0000 1 1 590 2nd 1 female 29.0000 0 2 591 2nd 1 female 0.9167 1 2 592 2nd 1 female 5.0000 1 2 593 2nd 0 male 36.0000 1 2 594 2nd 1 female 33.0000 1 2 595 2nd 0 male 66.0000 0 0 597 2nd 1 male 31.0000 0 0 599 2nd 1 female 26.0000 0 0 600 2nd 0 female 24.0000 0 0 601 3rd 0 male 42.0000 0 0 602 3rd 0 male 13.0000 0 2 603 3rd 0 male 16.0000 1 1 604 3rd 1 female 35.0000 1 1 605 3rd 1 female 16.0000 0 0 606 3rd 1 male 25.0000 0 0 607 3rd 1 male 20.0000 0 0 608 3rd 1 female 18.0000 0 0 609 3rd 0 male 30.0000 0 0 610 3rd 0 male 26.0000 0 0 611 3rd 0 female 40.0000 1 0 612 3rd 1 male 0.8333 0 1 613 3rd 1 female 18.0000 0 1 614 3rd 1 male 26.0000 0 0 615 3rd 0 male 26.0000 0 0 616 3rd 0 male 20.0000 0 0 617 3rd 0 male 24.0000 0 0 618 3rd 0 male 25.0000 0 0 619 3rd 0 male 35.0000 0 0 620 3rd 0 male 18.0000 0 0 621 3rd 0 male 32.0000 0 0 622 3rd 1 female 19.0000 1 0 623 3rd 0 male 4.0000 4 2 624 3rd 0 female 6.0000 4 2 625 3rd 0 female 2.0000 4 2 626 3rd 1 female 17.0000 4 2 627 3rd 0 female 38.0000 4 2 628 3rd 0 female 9.0000 4 2 629 3rd 0 female 11.0000 4 2 630 3rd 0 male 39.0000 1 5 631 3rd 1 male 27.0000 0 0 632 3rd 0 male 26.0000 0 0 633 3rd 0 female 39.0000 1 5 634 3rd 0 male 20.0000 0 0 635 3rd 0 male 26.0000 0 0 636 3rd 0 male 25.0000 1 0 637 3rd 0 female 18.0000 1 0 638 3rd 0 male 24.0000 0 0 639 3rd 0 male 35.0000 0 0 640 3rd 0 male 5.0000 4 2 641 3rd 0 male 9.0000 4 2 642 3rd 1 male 3.0000 4 2 643 3rd 0 male 13.0000 4 2 644 3rd 1 female 5.0000 4 2 645 3rd 0 male 40.0000 1 5 646 3rd 1 male 23.0000 0 0 647 3rd 1 female 38.0000 1 5 648 3rd 1 female 45.0000 0 0 649 3rd 0 male 21.0000 0 0 650 3rd 0 male 23.0000 0 0 651 3rd 0 female 17.0000 0 0 652 3rd 0 male 30.0000 0 0 653 3rd 0 male 23.0000 0 0 654 3rd 1 female 13.0000 0 0 655 3rd 0 male 20.0000 0 0 656 3rd 0 male 32.0000 1 0 657 3rd 1 female 33.0000 3 0 658 3rd 1 female 0.7500 2 1 659 3rd 1 female 0.7500 2 1 660 3rd 1 female 5.0000 2 1 661 3rd 1 female 24.0000 0 3 662 3rd 1 female 18.0000 0 0 663 3rd 0 male 40.0000 0 0 664 3rd 0 male 26.0000 0 0 665 3rd 1 male 20.0000 0 0 666 3rd 0 female 18.0000 0 1 667 3rd 0 female 45.0000 0 1 668 3rd 0 female 27.0000 0 0 669 3rd 0 male 22.0000 0 0 670 3rd 0 male 19.0000 0 0 671 3rd 0 male 26.0000 0 0 672 3rd 0 male 22.0000 0 0 674 3rd 0 male 20.0000 0 0 675 3rd 1 male 32.0000 0 0 676 3rd 0 male 21.0000 0 0 677 3rd 0 male 18.0000 0 0 678 3rd 0 male 26.0000 0 0 679 3rd 0 male 6.0000 1 1 680 3rd 0 female 9.0000 1 1 684 3rd 0 male 40.0000 1 1 685 3rd 0 female 32.0000 1 1 686 3rd 0 male 21.0000 0 0 687 3rd 1 female 22.0000 0 0 688 3rd 0 female 20.0000 0 0 689 3rd 0 male 29.0000 1 0 690 3rd 0 male 22.0000 1 0 691 3rd 0 male 22.0000 0 0 692 3rd 0 male 35.0000 0 0 693 3rd 0 female 18.5000 0 0 694 3rd 1 male 21.0000 0 0 695 3rd 0 male 19.0000 0 0 696 3rd 0 female 18.0000 0 0 697 3rd 0 female 21.0000 0 0 698 3rd 0 female 30.0000 0 0 699 3rd 0 male 18.0000 0 0 700 3rd 0 male 38.0000 0 0 701 3rd 0 male 17.0000 0 0 702 3rd 0 male 17.0000 0 0 703 3rd 0 female 21.0000 0 0 704 3rd 0 male 21.0000 0 0 705 3rd 0 male 21.0000 0 0 708 3rd 0 male 28.0000 0 0 709 3rd 0 male 24.0000 0 0 710 3rd 1 female 16.0000 0 0 711 3rd 0 female 37.0000 0 0 712 3rd 0 male 28.0000 0 0 713 3rd 0 male 24.0000 0 0 714 3rd 0 male 21.0000 0 0 715 3rd 1 male 32.0000 0 0 716 3rd 0 male 29.0000 0 0 717 3rd 0 male 26.0000 1 0 718 3rd 0 male 18.0000 1 0 719 3rd 0 male 20.0000 0 0 720 3rd 1 male 18.0000 0 0 721 3rd 0 male 24.0000 0 0 722 3rd 0 male 36.0000 0 0 723 3rd 0 male 24.0000 0 0 724 3rd 0 male 31.0000 0 0 725 3rd 0 male 31.0000 0 0 726 3rd 1 female 22.0000 0 0 727 3rd 0 female 30.0000 0 0 728 3rd 0 male 70.5000 0 0 729 3rd 0 male 43.0000 0 0 730 3rd 0 male 35.0000 0 0 731 3rd 0 male 27.0000 0 0 732 3rd 0 male 19.0000 0 0 733 3rd 0 male 30.0000 0 0 734 3rd 1 male 9.0000 1 1 735 3rd 1 male 3.0000 1 1 736 3rd 1 female 36.0000 0 2 737 3rd 0 male 59.0000 0 0 738 3rd 0 male 19.0000 0 0 739 3rd 1 female 17.0000 0 1 740 3rd 0 male 44.0000 0 1 741 3rd 0 male 17.0000 0 0 742 3rd 0 male 22.5000 0 0 743 3rd 1 male 45.0000 0 0 744 3rd 0 female 22.0000 0 0 745 3rd 0 male 19.0000 0 0 746 3rd 1 female 30.0000 0 0 747 3rd 1 male 29.0000 0 0 748 3rd 0 male 0.3333 0 2 749 3rd 0 male 34.0000 1 1 750 3rd 0 female 28.0000 1 1 751 3rd 0 male 27.0000 0 0 752 3rd 0 male 25.0000 0 0 753 3rd 0 male 24.0000 2 0 754 3rd 0 male 22.0000 0 0 755 3rd 0 male 21.0000 2 0 756 3rd 0 male 17.0000 2 0 759 3rd 1 male 36.5000 1 0 760 3rd 1 female 36.0000 1 0 761 3rd 1 male 30.0000 0 0 762 3rd 0 male 16.0000 0 0 763 3rd 1 male 1.0000 1 2 764 3rd 1 female 0.1667 1 2 765 3rd 0 male 26.0000 1 2 766 3rd 1 female 33.0000 1 2 767 3rd 0 male 25.0000 0 0 770 3rd 0 male 22.0000 0 0 771 3rd 0 male 36.0000 0 0 772 3rd 1 female 19.0000 0 0 773 3rd 0 male 17.0000 0 0 774 3rd 0 male 42.0000 0 0 775 3rd 0 male 43.0000 0 0 777 3rd 0 male 32.0000 0 0 778 3rd 1 male 19.0000 0 0 779 3rd 1 female 30.0000 0 0 780 3rd 0 female 24.0000 0 0 781 3rd 1 female 23.0000 0 0 782 3rd 0 male 33.0000 0 0 783 3rd 0 male 65.0000 0 0 784 3rd 1 male 24.0000 0 0 785 3rd 0 male 23.0000 1 0 786 3rd 1 female 22.0000 1 0 787 3rd 0 male 18.0000 0 0 788 3rd 0 male 16.0000 0 0 789 3rd 0 male 45.0000 0 0 791 3rd 0 male 39.0000 0 2 792 3rd 0 male 17.0000 1 1 793 3rd 0 male 15.0000 1 1 794 3rd 0 male 47.0000 0 0 795 3rd 1 female 5.0000 0 0 797 3rd 0 male 40.5000 0 0 798 3rd 0 male 40.5000 0 0 800 3rd 0 male 18.0000 0 0 804 3rd 0 male 26.0000 0 0 807 3rd 0 female 21.0000 2 2 808 3rd 0 female 9.0000 2 2 810 3rd 0 male 18.0000 2 2 811 3rd 0 male 16.0000 1 3 812 3rd 0 female 48.0000 1 3 815 3rd 0 male 25.0000 0 0 818 3rd 0 male 22.0000 0 0 819 3rd 1 female 16.0000 0 0 821 3rd 1 male 9.0000 0 2 822 3rd 0 male 33.0000 1 1 823 3rd 0 male 41.0000 0 0 824 3rd 1 female 31.0000 1 1 825 3rd 0 male 38.0000 0 0 826 3rd 0 male 9.0000 5 2 827 3rd 0 male 1.0000 5 2 828 3rd 0 male 11.0000 5 2 829 3rd 0 female 10.0000 5 2 830 3rd 0 female 16.0000 5 2 831 3rd 0 male 14.0000 5 2 832 3rd 0 male 40.0000 1 6 833 3rd 0 female 43.0000 1 6 834 3rd 0 male 51.0000 0 0 835 3rd 0 male 32.0000 0 0 837 3rd 0 male 20.0000 0 0 838 3rd 0 male 37.0000 2 0 839 3rd 0 male 28.0000 2 0 840 3rd 0 male 19.0000 0 0 841 3rd 0 female 24.0000 0 0 842 3rd 0 female 17.0000 0 0 845 3rd 0 male 28.0000 1 0 846 3rd 1 female 24.0000 1 0 847 3rd 0 male 20.0000 0 0 848 3rd 0 male 23.5000 0 0 849 3rd 0 male 41.0000 2 0 850 3rd 0 male 26.0000 1 0 851 3rd 0 male 21.0000 0 0 852 3rd 1 female 45.0000 1 0 854 3rd 0 male 25.0000 0 0 856 3rd 0 male 11.0000 0 0 858 3rd 1 male 27.0000 0 0 860 3rd 0 female 18.0000 0 0 861 3rd 1 female 26.0000 0 0 862 3rd 0 female 23.0000 0 0 863 3rd 1 female 22.0000 0 0 864 3rd 0 male 28.0000 0 0 865 3rd 0 female 28.0000 0 0 867 3rd 1 female 2.0000 0 1 868 3rd 1 female 22.0000 1 1 869 3rd 0 male 43.0000 0 0 870 3rd 0 male 28.0000 0 0 871 3rd 1 female 27.0000 0 0 874 3rd 0 male 42.0000 0 0 876 3rd 0 male 30.0000 0 0 878 3rd 0 female 27.0000 1 0 879 3rd 0 female 25.0000 1 0 881 3rd 1 male 29.0000 0 0 882 3rd 1 male 21.0000 0 0 884 3rd 0 male 20.0000 0 0 885 3rd 0 male 48.0000 0 0 886 3rd 0 male 17.0000 1 0 889 3rd 0 male 34.0000 0 0 890 3rd 1 male 26.0000 0 0 891 3rd 0 male 22.0000 0 0 892 3rd 0 male 33.0000 0 0 893 3rd 0 male 31.0000 0 0 894 3rd 0 male 29.0000 0 0 895 3rd 1 male 4.0000 1 1 896 3rd 1 female 1.0000 1 1 897 3rd 0 male 49.0000 0 0 898 3rd 0 male 33.0000 0 0 899 3rd 0 male 19.0000 0 0 900 3rd 1 female 27.0000 0 2 905 3rd 0 male 23.0000 0 0 906 3rd 1 male 32.0000 0 0 907 3rd 0 male 27.0000 0 0 908 3rd 0 female 20.0000 1 0 909 3rd 0 female 21.0000 1 0 910 3rd 1 male 32.0000 0 0 911 3rd 0 male 17.0000 0 0 912 3rd 0 male 21.0000 0 0 913 3rd 0 male 30.0000 0 0 914 3rd 1 male 21.0000 0 0 915 3rd 0 male 33.0000 0 0 916 3rd 0 male 22.0000 0 0 917 3rd 1 female 4.0000 0 1 918 3rd 1 male 39.0000 0 1 920 3rd 0 male 18.5000 0 0 925 3rd 0 male 34.5000 0 0 926 3rd 0 male 44.0000 0 0 933 3rd 0 female 22.0000 2 0 934 3rd 0 male 26.0000 2 0 935 3rd 1 female 4.0000 0 2 936 3rd 1 male 29.0000 3 1 937 3rd 1 female 26.0000 1 1 938 3rd 0 female 1.0000 1 1 939 3rd 0 male 18.0000 1 1 940 3rd 0 female 36.0000 0 2 942 3rd 1 male 25.0000 0 0 944 3rd 0 female 37.0000 0 0 948 3rd 1 female 22.0000 0 0 950 3rd 1 male 26.0000 0 0 951 3rd 0 male 29.0000 0 0 952 3rd 0 male 29.0000 0 0 953 3rd 0 male 22.0000 0 0 954 3rd 1 male 22.0000 0 0 960 3rd 0 male 32.0000 0 0 961 3rd 0 male 34.5000 0 0 964 3rd 0 male 36.0000 0 0 965 3rd 0 male 39.0000 0 0 966 3rd 0 male 24.0000 0 0 967 3rd 0 female 25.0000 0 0 968 3rd 0 female 45.0000 0 0 969 3rd 0 male 36.0000 1 0 970 3rd 0 female 30.0000 1 0 971 3rd 1 male 20.0000 1 0 973 3rd 0 male 28.0000 0 0 975 3rd 0 male 30.0000 1 0 976 3rd 0 female 26.0000 1 0 978 3rd 0 male 20.5000 0 0 979 3rd 1 male 27.0000 0 0 980 3rd 0 male 51.0000 0 0 981 3rd 1 female 23.0000 0 0 982 3rd 1 male 32.0000 0 0 986 3rd 1 male 24.0000 0 0 987 3rd 0 male 22.0000 0 0 991 3rd 0 male 29.0000 0 0 993 3rd 0 female 30.5000 0 0 996 3rd 0 male 35.0000 0 0 997 3rd 0 male 33.0000 0 0 1008 3rd 1 female 15.0000 0 0 1009 3rd 0 female 35.0000 0 0 1011 3rd 0 male 24.0000 1 0 1012 3rd 0 female 19.0000 1 0 1016 3rd 0 male 55.5000 0 0 1018 3rd 1 male 21.0000 0 0 1020 3rd 0 male 24.0000 0 0 1021 3rd 0 male 21.0000 0 0 1022 3rd 0 male 28.0000 0 0 1025 3rd 0 male 25.0000 0 0 1026 3rd 1 male 6.0000 0 1 1027 3rd 1 female 27.0000 0 1 1032 3rd 0 male 34.0000 0 0 1041 3rd 1 female 24.0000 0 0 1046 3rd 0 male 18.0000 0 0 1047 3rd 0 male 22.0000 0 0 1048 3rd 1 female 15.0000 0 0 1049 3rd 1 female 1.0000 0 2 1050 3rd 1 male 20.0000 1 1 1051 3rd 1 female 19.0000 1 1 1052 3rd 0 male 33.0000 0 0 1057 3rd 1 male 12.0000 1 0 1058 3rd 1 female 14.0000 1 0 1059 3rd 0 female 29.0000 0 0 1060 3rd 0 male 28.0000 0 0 1061 3rd 1 female 18.0000 0 0 1062 3rd 1 female 26.0000 0 0 1063 3rd 0 male 21.0000 0 0 1064 3rd 0 male 41.0000 0 0 1065 3rd 1 male 39.0000 0 0 1066 3rd 0 male 21.0000 0 0 1067 3rd 0 male 28.5000 0 0 1068 3rd 1 female 22.0000 0 0 1069 3rd 0 male 61.0000 0 0 1076 3rd 0 male 23.0000 0 0 1080 3rd 1 female 22.0000 0 0 1083 3rd 1 male 9.0000 0 1 1084 3rd 0 male 28.0000 0 0 1085 3rd 0 male 42.0000 0 1 1087 3rd 0 female 31.0000 0 0 1088 3rd 0 male 28.0000 0 0 1089 3rd 1 male 32.0000 0 0 1090 3rd 0 male 20.0000 0 0 1091 3rd 0 female 23.0000 0 0 1092 3rd 0 female 20.0000 0 0 1093 3rd 0 male 20.0000 0 0 1094 3rd 0 male 16.0000 0 0 1095 3rd 1 female 31.0000 0 0 1097 3rd 0 male 2.0000 3 1 1098 3rd 0 male 6.0000 3 1 1099 3rd 0 female 3.0000 3 1 1100 3rd 0 female 8.0000 3 1 1101 3rd 0 female 29.0000 0 4 1102 3rd 0 male 1.0000 4 1 1103 3rd 0 male 7.0000 4 1 1104 3rd 0 male 2.0000 4 1 1105 3rd 0 male 16.0000 4 1 1106 3rd 0 male 14.0000 4 1 1107 3rd 0 female 41.0000 0 5 1108 3rd 0 male 21.0000 0 0 1109 3rd 0 male 19.0000 0 0 1111 3rd 0 male 32.0000 0 0 1112 3rd 0 male 0.7500 1 1 1113 3rd 0 female 3.0000 1 1 1114 3rd 0 female 26.0000 0 2 1118 3rd 0 male 21.0000 0 0 1119 3rd 0 male 25.0000 0 0 1120 3rd 0 male 22.0000 0 0 1121 3rd 1 male 25.0000 1 0 1126 3rd 0 male 24.0000 0 0 1127 3rd 0 female 28.0000 0 0 1128 3rd 0 male 19.0000 0 0 1130 3rd 0 male 25.0000 1 0 1131 3rd 0 female 18.0000 0 0 1132 3rd 1 male 32.0000 0 0 1134 3rd 0 male 17.0000 0 0 1135 3rd 0 male 24.0000 0 0 1140 3rd 0 male 38.0000 0 0 1141 3rd 0 male 21.0000 0 0 1142 3rd 0 male 10.0000 4 1 1143 3rd 0 male 4.0000 4 1 1144 3rd 0 male 7.0000 4 1 1145 3rd 0 male 2.0000 4 1 1146 3rd 0 male 8.0000 4 1 1147 3rd 0 female 39.0000 0 5 1148 3rd 0 female 22.0000 0 0 1149 3rd 0 male 35.0000 0 0 1153 3rd 0 male 50.0000 1 0 1154 3rd 0 female 47.0000 1 0 1157 3rd 0 female 2.0000 1 1 1158 3rd 0 male 18.0000 1 1 1159 3rd 0 female 41.0000 0 2 1161 3rd 0 male 50.0000 0 0 1162 3rd 0 male 16.0000 0 0 1166 3rd 0 male 25.0000 0 0 1170 3rd 0 male 38.5000 0 0 1172 3rd 0 male 14.5000 8 2 1182 3rd 0 male 24.0000 0 0 1183 3rd 1 female 21.0000 0 0 1184 3rd 0 male 39.0000 0 0 1188 3rd 1 female 1.0000 1 1 1189 3rd 1 female 24.0000 0 2 1190 3rd 1 female 4.0000 1 1 1191 3rd 1 male 25.0000 0 0 1192 3rd 0 male 20.0000 0 0 1193 3rd 0 male 24.5000 0 0 1197 3rd 1 male 29.0000 0 0 1202 3rd 0 male 22.0000 0 0 1204 3rd 0 male 40.0000 0 0 1205 3rd 0 male 21.0000 0 0 1206 3rd 1 female 18.0000 0 0 1207 3rd 0 male 4.0000 3 2 1208 3rd 0 male 10.0000 3 2 1209 3rd 0 female 9.0000 3 2 1210 3rd 0 female 2.0000 3 2 1211 3rd 0 male 40.0000 1 4 1212 3rd 0 female 45.0000 1 4 1218 3rd 0 male 19.0000 0 0 1219 3rd 0 male 30.0000 0 0 1221 3rd 0 male 32.0000 0 0 1223 3rd 0 male 33.0000 0 0 1224 3rd 1 female 23.0000 0 0 1225 3rd 0 male 21.0000 0 0 1226 3rd 0 male 60.5000 0 0 1227 3rd 0 male 19.0000 0 0 1228 3rd 0 female 22.0000 0 0 1229 3rd 1 male 31.0000 0 0 1230 3rd 0 male 27.0000 0 0 1231 3rd 0 female 2.0000 0 1 1232 3rd 0 female 29.0000 1 1 1233 3rd 1 male 16.0000 0 0 1234 3rd 1 male 44.0000 0 0 1235 3rd 0 male 25.0000 0 0 1236 3rd 0 male 74.0000 0 0 1237 3rd 1 male 14.0000 0 0 1238 3rd 0 male 24.0000 0 0 1239 3rd 1 male 25.0000 0 0 1240 3rd 0 male 34.0000 0 0 1241 3rd 1 male 0.4167 0 1 1245 3rd 1 female 16.0000 1 1 1249 3rd 0 male 32.0000 0 0 1252 3rd 0 male 30.5000 0 0 1253 3rd 0 male 44.0000 0 0 1255 3rd 1 male 25.0000 0 0 1257 3rd 1 male 7.0000 1 1 1258 3rd 1 female 9.0000 1 1 1259 3rd 1 female 29.0000 0 2 1260 3rd 0 male 36.0000 0 0 1261 3rd 1 female 18.0000 0 0 1262 3rd 1 female 63.0000 0 0 1264 3rd 0 male 11.5000 1 1 1265 3rd 0 male 40.5000 0 2 1266 3rd 0 female 10.0000 0 2 1267 3rd 0 male 36.0000 1 1 1268 3rd 0 female 30.0000 1 1 1270 3rd 0 male 33.0000 0 0 1271 3rd 0 male 28.0000 0 0 1272 3rd 0 male 28.0000 0 0 1273 3rd 0 male 47.0000 0 0 1274 3rd 0 female 18.0000 2 0 1275 3rd 0 male 31.0000 3 0 1276 3rd 0 male 16.0000 2 0 1277 3rd 0 female 31.0000 1 0 1278 3rd 1 male 22.0000 0 0 1279 3rd 0 male 20.0000 0 0 1280 3rd 0 female 14.0000 0 0 1281 3rd 0 male 22.0000 0 0 1282 3rd 0 male 22.0000 0 0 1286 3rd 0 male 32.5000 0 0 1287 3rd 1 female 38.0000 0 0 1288 3rd 0 male 51.0000 0 0 1289 3rd 0 male 18.0000 1 0 1290 3rd 0 male 21.0000 1 0 1291 3rd 1 female 47.0000 1 0 1295 3rd 0 male 28.5000 0 0 1296 3rd 0 male 21.0000 0 0 1297 3rd 0 male 27.0000 0 0 1299 3rd 0 male 36.0000 0 0 1300 3rd 0 male 27.0000 1 0 1301 3rd 1 female 15.0000 1 0 1302 3rd 0 male 45.5000 0 0 1305 3rd 0 female 14.5000 1 0 1307 3rd 0 male 26.5000 0 0 1308 3rd 0 male 27.0000 0 0 1309 3rd 0 male 29.0000 0 0 $y 1st 2nd 3rd [1,] 1 0 0 [2,] 1 0 0 [3,] 1 0 0 [4,] 1 0 0 [5,] 1 0 0 [6,] 1 0 0 [7,] 1 0 0 [8,] 1 0 0 [9,] 1 0 0 [10,] 1 0 0 [11,] 1 0 0 [12,] 1 0 0 [13,] 1 0 0 [14,] 1 0 0 [15,] 1 0 0 [16,] 1 0 0 [17,] 1 0 0 [18,] 1 0 0 [19,] 1 0 0 [20,] 1 0 0 [21,] 1 0 0 [22,] 1 0 0 [23,] 1 0 0 [24,] 1 0 0 [25,] 1 0 0 [26,] 1 0 0 [27,] 1 0 0 [28,] 1 0 0 [29,] 1 0 0 [30,] 1 0 0 [31,] 1 0 0 [32,] 1 0 0 [33,] 1 0 0 [34,] 1 0 0 [35,] 1 0 0 [36,] 1 0 0 [37,] 1 0 0 [38,] 1 0 0 [39,] 1 0 0 [40,] 1 0 0 [41,] 1 0 0 [42,] 1 0 0 [43,] 1 0 0 [44,] 1 0 0 [45,] 1 0 0 [46,] 1 0 0 [47,] 1 0 0 [48,] 1 0 0 [49,] 1 0 0 [50,] 1 0 0 [51,] 1 0 0 [52,] 1 0 0 [53,] 1 0 0 [54,] 1 0 0 [55,] 1 0 0 [56,] 1 0 0 [57,] 1 0 0 [58,] 1 0 0 [59,] 1 0 0 [60,] 1 0 0 [61,] 1 0 0 [62,] 1 0 0 [63,] 1 0 0 [64,] 1 0 0 [65,] 1 0 0 [66,] 1 0 0 [67,] 1 0 0 [68,] 1 0 0 [69,] 1 0 0 [70,] 1 0 0 [71,] 1 0 0 [72,] 1 0 0 [73,] 1 0 0 [74,] 1 0 0 [75,] 1 0 0 [76,] 1 0 0 [77,] 1 0 0 [78,] 1 0 0 [79,] 1 0 0 [80,] 1 0 0 [81,] 1 0 0 [82,] 1 0 0 [83,] 1 0 0 [84,] 1 0 0 [85,] 1 0 0 [86,] 1 0 0 [87,] 1 0 0 [88,] 1 0 0 [89,] 1 0 0 [90,] 1 0 0 [91,] 1 0 0 [92,] 1 0 0 [93,] 1 0 0 [94,] 1 0 0 [95,] 1 0 0 [96,] 1 0 0 [97,] 1 0 0 [98,] 1 0 0 [99,] 1 0 0 [100,] 1 0 0 [101,] 1 0 0 [102,] 1 0 0 [103,] 1 0 0 [104,] 1 0 0 [105,] 1 0 0 [106,] 1 0 0 [107,] 1 0 0 [108,] 1 0 0 [109,] 1 0 0 [110,] 1 0 0 [111,] 1 0 0 [112,] 1 0 0 [113,] 1 0 0 [114,] 1 0 0 [115,] 1 0 0 [116,] 1 0 0 [117,] 1 0 0 [118,] 1 0 0 [119,] 1 0 0 [120,] 1 0 0 [121,] 1 0 0 [122,] 1 0 0 [123,] 1 0 0 [124,] 1 0 0 [125,] 1 0 0 [126,] 1 0 0 [127,] 1 0 0 [128,] 1 0 0 [129,] 1 0 0 [130,] 1 0 0 [131,] 1 0 0 [132,] 1 0 0 [133,] 1 0 0 [134,] 1 0 0 [135,] 1 0 0 [136,] 1 0 0 [137,] 1 0 0 [138,] 1 0 0 [139,] 1 0 0 [140,] 1 0 0 [141,] 1 0 0 [142,] 1 0 0 [143,] 1 0 0 [144,] 1 0 0 [145,] 1 0 0 [146,] 1 0 0 [147,] 1 0 0 [148,] 1 0 0 [149,] 1 0 0 [150,] 1 0 0 [151,] 1 0 0 [152,] 1 0 0 [153,] 1 0 0 [154,] 1 0 0 [155,] 1 0 0 [156,] 1 0 0 [157,] 1 0 0 [158,] 1 0 0 [159,] 1 0 0 [160,] 1 0 0 [161,] 1 0 0 [162,] 1 0 0 [163,] 1 0 0 [164,] 1 0 0 [165,] 1 0 0 [166,] 1 0 0 [167,] 1 0 0 [168,] 1 0 0 [169,] 1 0 0 [170,] 1 0 0 [171,] 1 0 0 [172,] 1 0 0 [173,] 1 0 0 [174,] 1 0 0 [175,] 1 0 0 [176,] 1 0 0 [177,] 1 0 0 [178,] 1 0 0 [179,] 1 0 0 [180,] 1 0 0 [181,] 1 0 0 [182,] 1 0 0 [183,] 1 0 0 [184,] 1 0 0 [185,] 1 0 0 [186,] 1 0 0 [187,] 1 0 0 [188,] 1 0 0 [189,] 1 0 0 [190,] 1 0 0 [191,] 1 0 0 [192,] 1 0 0 [193,] 1 0 0 [194,] 1 0 0 [195,] 1 0 0 [196,] 1 0 0 [197,] 1 0 0 [198,] 1 0 0 [199,] 1 0 0 [200,] 1 0 0 [201,] 1 0 0 [202,] 1 0 0 [203,] 1 0 0 [204,] 1 0 0 [205,] 1 0 0 [206,] 1 0 0 [207,] 1 0 0 [208,] 1 0 0 [209,] 1 0 0 [210,] 1 0 0 [211,] 1 0 0 [212,] 1 0 0 [213,] 1 0 0 [214,] 1 0 0 [215,] 1 0 0 [216,] 1 0 0 [217,] 1 0 0 [218,] 1 0 0 [219,] 1 0 0 [220,] 1 0 0 [221,] 1 0 0 [222,] 1 0 0 [223,] 1 0 0 [224,] 1 0 0 [225,] 1 0 0 [226,] 1 0 0 [227,] 1 0 0 [228,] 1 0 0 [229,] 1 0 0 [230,] 1 0 0 [231,] 1 0 0 [232,] 1 0 0 [233,] 1 0 0 [234,] 1 0 0 [235,] 1 0 0 [236,] 1 0 0 [237,] 1 0 0 [238,] 1 0 0 [239,] 1 0 0 [240,] 1 0 0 [241,] 1 0 0 [242,] 1 0 0 [243,] 1 0 0 [244,] 1 0 0 [245,] 1 0 0 [246,] 1 0 0 [247,] 1 0 0 [248,] 1 0 0 [249,] 1 0 0 [250,] 1 0 0 [251,] 1 0 0 [252,] 1 0 0 [253,] 1 0 0 [254,] 1 0 0 [255,] 1 0 0 [256,] 1 0 0 [257,] 1 0 0 [258,] 1 0 0 [259,] 1 0 0 [260,] 1 0 0 [261,] 1 0 0 [262,] 1 0 0 [263,] 1 0 0 [264,] 1 0 0 [265,] 1 0 0 [266,] 1 0 0 [267,] 1 0 0 [268,] 1 0 0 [269,] 1 0 0 [270,] 1 0 0 [271,] 1 0 0 [272,] 1 0 0 [273,] 1 0 0 [274,] 1 0 0 [275,] 1 0 0 [276,] 1 0 0 [277,] 1 0 0 [278,] 1 0 0 [279,] 1 0 0 [280,] 1 0 0 [281,] 1 0 0 [282,] 1 0 0 [283,] 1 0 0 [284,] 1 0 0 [285,] 0 1 0 [286,] 0 1 0 [287,] 0 1 0 [288,] 0 1 0 [289,] 0 1 0 [290,] 0 1 0 [291,] 0 1 0 [292,] 0 1 0 [293,] 0 1 0 [294,] 0 1 0 [295,] 0 1 0 [296,] 0 1 0 [297,] 0 1 0 [298,] 0 1 0 [299,] 0 1 0 [300,] 0 1 0 [301,] 0 1 0 [302,] 0 1 0 [303,] 0 1 0 [304,] 0 1 0 [305,] 0 1 0 [306,] 0 1 0 [307,] 0 1 0 [308,] 0 1 0 [309,] 0 1 0 [310,] 0 1 0 [311,] 0 1 0 [312,] 0 1 0 [313,] 0 1 0 [314,] 0 1 0 [315,] 0 1 0 [316,] 0 1 0 [317,] 0 1 0 [318,] 0 1 0 [319,] 0 1 0 [320,] 0 1 0 [321,] 0 1 0 [322,] 0 1 0 [323,] 0 1 0 [324,] 0 1 0 [325,] 0 1 0 [326,] 0 1 0 [327,] 0 1 0 [328,] 0 1 0 [329,] 0 1 0 [330,] 0 1 0 [331,] 0 1 0 [332,] 0 1 0 [333,] 0 1 0 [334,] 0 1 0 [335,] 0 1 0 [336,] 0 1 0 [337,] 0 1 0 [338,] 0 1 0 [339,] 0 1 0 [340,] 0 1 0 [341,] 0 1 0 [342,] 0 1 0 [343,] 0 1 0 [344,] 0 1 0 [345,] 0 1 0 [346,] 0 1 0 [347,] 0 1 0 [348,] 0 1 0 [349,] 0 1 0 [350,] 0 1 0 [351,] 0 1 0 [352,] 0 1 0 [353,] 0 1 0 [354,] 0 1 0 [355,] 0 1 0 [356,] 0 1 0 [357,] 0 1 0 [358,] 0 1 0 [359,] 0 1 0 [360,] 0 1 0 [361,] 0 1 0 [362,] 0 1 0 [363,] 0 1 0 [364,] 0 1 0 [365,] 0 1 0 [366,] 0 1 0 [367,] 0 1 0 [368,] 0 1 0 [369,] 0 1 0 [370,] 0 1 0 [371,] 0 1 0 [372,] 0 1 0 [373,] 0 1 0 [374,] 0 1 0 [375,] 0 1 0 [376,] 0 1 0 [377,] 0 1 0 [378,] 0 1 0 [379,] 0 1 0 [380,] 0 1 0 [381,] 0 1 0 [382,] 0 1 0 [383,] 0 1 0 [384,] 0 1 0 [385,] 0 1 0 [386,] 0 1 0 [387,] 0 1 0 [388,] 0 1 0 [389,] 0 1 0 [390,] 0 1 0 [391,] 0 1 0 [392,] 0 1 0 [393,] 0 1 0 [394,] 0 1 0 [395,] 0 1 0 [396,] 0 1 0 [397,] 0 1 0 [398,] 0 1 0 [399,] 0 1 0 [400,] 0 1 0 [401,] 0 1 0 [402,] 0 1 0 [403,] 0 1 0 [404,] 0 1 0 [405,] 0 1 0 [406,] 0 1 0 [407,] 0 1 0 [408,] 0 1 0 [409,] 0 1 0 [410,] 0 1 0 [411,] 0 1 0 [412,] 0 1 0 [413,] 0 1 0 [414,] 0 1 0 [415,] 0 1 0 [416,] 0 1 0 [417,] 0 1 0 [418,] 0 1 0 [419,] 0 1 0 [420,] 0 1 0 [421,] 0 1 0 [422,] 0 1 0 [423,] 0 1 0 [424,] 0 1 0 [425,] 0 1 0 [426,] 0 1 0 [427,] 0 1 0 [428,] 0 1 0 [429,] 0 1 0 [430,] 0 1 0 [431,] 0 1 0 [432,] 0 1 0 [433,] 0 1 0 [434,] 0 1 0 [435,] 0 1 0 [436,] 0 1 0 [437,] 0 1 0 [438,] 0 1 0 [439,] 0 1 0 [440,] 0 1 0 [441,] 0 1 0 [442,] 0 1 0 [443,] 0 1 0 [444,] 0 1 0 [445,] 0 1 0 [446,] 0 1 0 [447,] 0 1 0 [448,] 0 1 0 [449,] 0 1 0 [450,] 0 1 0 [451,] 0 1 0 [452,] 0 1 0 [453,] 0 1 0 [454,] 0 1 0 [455,] 0 1 0 [456,] 0 1 0 [457,] 0 1 0 [458,] 0 1 0 [459,] 0 1 0 [460,] 0 1 0 [461,] 0 1 0 [462,] 0 1 0 [463,] 0 1 0 [464,] 0 1 0 [465,] 0 1 0 [466,] 0 1 0 [467,] 0 1 0 [468,] 0 1 0 [469,] 0 1 0 [470,] 0 1 0 [471,] 0 1 0 [472,] 0 1 0 [473,] 0 1 0 [474,] 0 1 0 [475,] 0 1 0 [476,] 0 1 0 [477,] 0 1 0 [478,] 0 1 0 [479,] 0 1 0 [480,] 0 1 0 [481,] 0 1 0 [482,] 0 1 0 [483,] 0 1 0 [484,] 0 1 0 [485,] 0 1 0 [486,] 0 1 0 [487,] 0 1 0 [488,] 0 1 0 [489,] 0 1 0 [490,] 0 1 0 [491,] 0 1 0 [492,] 0 1 0 [493,] 0 1 0 [494,] 0 1 0 [495,] 0 1 0 [496,] 0 1 0 [497,] 0 1 0 [498,] 0 1 0 [499,] 0 1 0 [500,] 0 1 0 [501,] 0 1 0 [502,] 0 1 0 [503,] 0 1 0 [504,] 0 1 0 [505,] 0 1 0 [506,] 0 1 0 [507,] 0 1 0 [508,] 0 1 0 [509,] 0 1 0 [510,] 0 1 0 [511,] 0 1 0 [512,] 0 1 0 [513,] 0 1 0 [514,] 0 1 0 [515,] 0 1 0 [516,] 0 1 0 [517,] 0 1 0 [518,] 0 1 0 [519,] 0 1 0 [520,] 0 1 0 [521,] 0 1 0 [522,] 0 1 0 [523,] 0 1 0 [524,] 0 1 0 [525,] 0 1 0 [526,] 0 1 0 [527,] 0 1 0 [528,] 0 1 0 [529,] 0 1 0 [530,] 0 1 0 [531,] 0 1 0 [532,] 0 1 0 [533,] 0 1 0 [534,] 0 1 0 [535,] 0 1 0 [536,] 0 1 0 [537,] 0 1 0 [538,] 0 1 0 [539,] 0 1 0 [540,] 0 1 0 [541,] 0 1 0 [542,] 0 1 0 [543,] 0 1 0 [544,] 0 1 0 [545,] 0 1 0 [546,] 0 0 1 [547,] 0 0 1 [548,] 0 0 1 [549,] 0 0 1 [550,] 0 0 1 [551,] 0 0 1 [552,] 0 0 1 [553,] 0 0 1 [554,] 0 0 1 [555,] 0 0 1 [556,] 0 0 1 [557,] 0 0 1 [558,] 0 0 1 [559,] 0 0 1 [560,] 0 0 1 [561,] 0 0 1 [562,] 0 0 1 [563,] 0 0 1 [564,] 0 0 1 [565,] 0 0 1 [566,] 0 0 1 [567,] 0 0 1 [568,] 0 0 1 [569,] 0 0 1 [570,] 0 0 1 [571,] 0 0 1 [572,] 0 0 1 [573,] 0 0 1 [574,] 0 0 1 [575,] 0 0 1 [576,] 0 0 1 [577,] 0 0 1 [578,] 0 0 1 [579,] 0 0 1 [580,] 0 0 1 [581,] 0 0 1 [582,] 0 0 1 [583,] 0 0 1 [584,] 0 0 1 [585,] 0 0 1 [586,] 0 0 1 [587,] 0 0 1 [588,] 0 0 1 [589,] 0 0 1 [590,] 0 0 1 [591,] 0 0 1 [592,] 0 0 1 [593,] 0 0 1 [594,] 0 0 1 [595,] 0 0 1 [596,] 0 0 1 [597,] 0 0 1 [598,] 0 0 1 [599,] 0 0 1 [600,] 0 0 1 [601,] 0 0 1 [602,] 0 0 1 [603,] 0 0 1 [604,] 0 0 1 [605,] 0 0 1 [606,] 0 0 1 [607,] 0 0 1 [608,] 0 0 1 [609,] 0 0 1 [610,] 0 0 1 [611,] 0 0 1 [612,] 0 0 1 [613,] 0 0 1 [614,] 0 0 1 [615,] 0 0 1 [616,] 0 0 1 [617,] 0 0 1 [618,] 0 0 1 [619,] 0 0 1 [620,] 0 0 1 [621,] 0 0 1 [622,] 0 0 1 [623,] 0 0 1 [624,] 0 0 1 [625,] 0 0 1 [626,] 0 0 1 [627,] 0 0 1 [628,] 0 0 1 [629,] 0 0 1 [630,] 0 0 1 [631,] 0 0 1 [632,] 0 0 1 [633,] 0 0 1 [634,] 0 0 1 [635,] 0 0 1 [636,] 0 0 1 [637,] 0 0 1 [638,] 0 0 1 [639,] 0 0 1 [640,] 0 0 1 [641,] 0 0 1 [642,] 0 0 1 [643,] 0 0 1 [644,] 0 0 1 [645,] 0 0 1 [646,] 0 0 1 [647,] 0 0 1 [648,] 0 0 1 [649,] 0 0 1 [650,] 0 0 1 [651,] 0 0 1 [652,] 0 0 1 [653,] 0 0 1 [654,] 0 0 1 [655,] 0 0 1 [656,] 0 0 1 [657,] 0 0 1 [658,] 0 0 1 [659,] 0 0 1 [660,] 0 0 1 [661,] 0 0 1 [662,] 0 0 1 [663,] 0 0 1 [664,] 0 0 1 [665,] 0 0 1 [666,] 0 0 1 [667,] 0 0 1 [668,] 0 0 1 [669,] 0 0 1 [670,] 0 0 1 [671,] 0 0 1 [672,] 0 0 1 [673,] 0 0 1 [674,] 0 0 1 [675,] 0 0 1 [676,] 0 0 1 [677,] 0 0 1 [678,] 0 0 1 [679,] 0 0 1 [680,] 0 0 1 [681,] 0 0 1 [682,] 0 0 1 [683,] 0 0 1 [684,] 0 0 1 [685,] 0 0 1 [686,] 0 0 1 [687,] 0 0 1 [688,] 0 0 1 [689,] 0 0 1 [690,] 0 0 1 [691,] 0 0 1 [692,] 0 0 1 [693,] 0 0 1 [694,] 0 0 1 [695,] 0 0 1 [696,] 0 0 1 [697,] 0 0 1 [698,] 0 0 1 [699,] 0 0 1 [700,] 0 0 1 [701,] 0 0 1 [702,] 0 0 1 [703,] 0 0 1 [704,] 0 0 1 [705,] 0 0 1 [706,] 0 0 1 [707,] 0 0 1 [708,] 0 0 1 [709,] 0 0 1 [710,] 0 0 1 [711,] 0 0 1 [712,] 0 0 1 [713,] 0 0 1 [714,] 0 0 1 [715,] 0 0 1 [716,] 0 0 1 [717,] 0 0 1 [718,] 0 0 1 [719,] 0 0 1 [720,] 0 0 1 [721,] 0 0 1 [722,] 0 0 1 [723,] 0 0 1 [724,] 0 0 1 [725,] 0 0 1 [726,] 0 0 1 [727,] 0 0 1 [728,] 0 0 1 [729,] 0 0 1 [730,] 0 0 1 [731,] 0 0 1 [732,] 0 0 1 [733,] 0 0 1 [734,] 0 0 1 [735,] 0 0 1 [736,] 0 0 1 [737,] 0 0 1 [738,] 0 0 1 [739,] 0 0 1 [740,] 0 0 1 [741,] 0 0 1 [742,] 0 0 1 [743,] 0 0 1 [744,] 0 0 1 [745,] 0 0 1 [746,] 0 0 1 [747,] 0 0 1 [748,] 0 0 1 [749,] 0 0 1 [750,] 0 0 1 [751,] 0 0 1 [752,] 0 0 1 [753,] 0 0 1 [754,] 0 0 1 [755,] 0 0 1 [756,] 0 0 1 [757,] 0 0 1 [758,] 0 0 1 [759,] 0 0 1 [760,] 0 0 1 [761,] 0 0 1 [762,] 0 0 1 [763,] 0 0 1 [764,] 0 0 1 [765,] 0 0 1 [766,] 0 0 1 [767,] 0 0 1 [768,] 0 0 1 [769,] 0 0 1 [770,] 0 0 1 [771,] 0 0 1 [772,] 0 0 1 [773,] 0 0 1 [774,] 0 0 1 [775,] 0 0 1 [776,] 0 0 1 [777,] 0 0 1 [778,] 0 0 1 [779,] 0 0 1 [780,] 0 0 1 [781,] 0 0 1 [782,] 0 0 1 [783,] 0 0 1 [784,] 0 0 1 [785,] 0 0 1 [786,] 0 0 1 [787,] 0 0 1 [788,] 0 0 1 [789,] 0 0 1 [790,] 0 0 1 [791,] 0 0 1 [792,] 0 0 1 [793,] 0 0 1 [794,] 0 0 1 [795,] 0 0 1 [796,] 0 0 1 [797,] 0 0 1 [798,] 0 0 1 [799,] 0 0 1 [800,] 0 0 1 [801,] 0 0 1 [802,] 0 0 1 [803,] 0 0 1 [804,] 0 0 1 [805,] 0 0 1 [806,] 0 0 1 [807,] 0 0 1 [808,] 0 0 1 [809,] 0 0 1 [810,] 0 0 1 [811,] 0 0 1 [812,] 0 0 1 [813,] 0 0 1 [814,] 0 0 1 [815,] 0 0 1 [816,] 0 0 1 [817,] 0 0 1 [818,] 0 0 1 [819,] 0 0 1 [820,] 0 0 1 [821,] 0 0 1 [822,] 0 0 1 [823,] 0 0 1 [824,] 0 0 1 [825,] 0 0 1 [826,] 0 0 1 [827,] 0 0 1 [828,] 0 0 1 [829,] 0 0 1 [830,] 0 0 1 [831,] 0 0 1 [832,] 0 0 1 [833,] 0 0 1 [834,] 0 0 1 [835,] 0 0 1 [836,] 0 0 1 [837,] 0 0 1 [838,] 0 0 1 [839,] 0 0 1 [840,] 0 0 1 [841,] 0 0 1 [842,] 0 0 1 [843,] 0 0 1 [844,] 0 0 1 [845,] 0 0 1 [846,] 0 0 1 [847,] 0 0 1 [848,] 0 0 1 [849,] 0 0 1 [850,] 0 0 1 [851,] 0 0 1 [852,] 0 0 1 [853,] 0 0 1 [854,] 0 0 1 [855,] 0 0 1 [856,] 0 0 1 [857,] 0 0 1 [858,] 0 0 1 [859,] 0 0 1 [860,] 0 0 1 [861,] 0 0 1 [862,] 0 0 1 [863,] 0 0 1 [864,] 0 0 1 [865,] 0 0 1 [866,] 0 0 1 [867,] 0 0 1 [868,] 0 0 1 [869,] 0 0 1 [870,] 0 0 1 [871,] 0 0 1 [872,] 0 0 1 [873,] 0 0 1 [874,] 0 0 1 [875,] 0 0 1 [876,] 0 0 1 [877,] 0 0 1 [878,] 0 0 1 [879,] 0 0 1 [880,] 0 0 1 [881,] 0 0 1 [882,] 0 0 1 [883,] 0 0 1 [884,] 0 0 1 [885,] 0 0 1 [886,] 0 0 1 [887,] 0 0 1 [888,] 0 0 1 [889,] 0 0 1 [890,] 0 0 1 [891,] 0 0 1 [892,] 0 0 1 [893,] 0 0 1 [894,] 0 0 1 [895,] 0 0 1 [896,] 0 0 1 [897,] 0 0 1 [898,] 0 0 1 [899,] 0 0 1 [900,] 0 0 1 [901,] 0 0 1 [902,] 0 0 1 [903,] 0 0 1 [904,] 0 0 1 [905,] 0 0 1 [906,] 0 0 1 [907,] 0 0 1 [908,] 0 0 1 [909,] 0 0 1 [910,] 0 0 1 [911,] 0 0 1 [912,] 0 0 1 [913,] 0 0 1 [914,] 0 0 1 [915,] 0 0 1 [916,] 0 0 1 [917,] 0 0 1 [918,] 0 0 1 [919,] 0 0 1 [920,] 0 0 1 [921,] 0 0 1 [922,] 0 0 1 [923,] 0 0 1 [924,] 0 0 1 [925,] 0 0 1 [926,] 0 0 1 [927,] 0 0 1 [928,] 0 0 1 [929,] 0 0 1 [930,] 0 0 1 [931,] 0 0 1 [932,] 0 0 1 [933,] 0 0 1 [934,] 0 0 1 [935,] 0 0 1 [936,] 0 0 1 [937,] 0 0 1 [938,] 0 0 1 [939,] 0 0 1 [940,] 0 0 1 [941,] 0 0 1 [942,] 0 0 1 [943,] 0 0 1 [944,] 0 0 1 [945,] 0 0 1 [946,] 0 0 1 [947,] 0 0 1 [948,] 0 0 1 [949,] 0 0 1 [950,] 0 0 1 [951,] 0 0 1 [952,] 0 0 1 [953,] 0 0 1 [954,] 0 0 1 [955,] 0 0 1 [956,] 0 0 1 [957,] 0 0 1 [958,] 0 0 1 [959,] 0 0 1 [960,] 0 0 1 [961,] 0 0 1 [962,] 0 0 1 [963,] 0 0 1 [964,] 0 0 1 [965,] 0 0 1 [966,] 0 0 1 [967,] 0 0 1 [968,] 0 0 1 [969,] 0 0 1 [970,] 0 0 1 [971,] 0 0 1 [972,] 0 0 1 [973,] 0 0 1 [974,] 0 0 1 [975,] 0 0 1 [976,] 0 0 1 [977,] 0 0 1 [978,] 0 0 1 [979,] 0 0 1 [980,] 0 0 1 [981,] 0 0 1 [982,] 0 0 1 [983,] 0 0 1 [984,] 0 0 1 [985,] 0 0 1 [986,] 0 0 1 [987,] 0 0 1 [988,] 0 0 1 [989,] 0 0 1 [990,] 0 0 1 [991,] 0 0 1 [992,] 0 0 1 [993,] 0 0 1 [994,] 0 0 1 [995,] 0 0 1 [996,] 0 0 1 [997,] 0 0 1 [998,] 0 0 1 [999,] 0 0 1 [1000,] 0 0 1 [1001,] 0 0 1 [1002,] 0 0 1 [1003,] 0 0 1 [1004,] 0 0 1 [1005,] 0 0 1 [1006,] 0 0 1 [1007,] 0 0 1 [1008,] 0 0 1 [1009,] 0 0 1 [1010,] 0 0 1 [1011,] 0 0 1 [1012,] 0 0 1 [1013,] 0 0 1 [1014,] 0 0 1 [1015,] 0 0 1 [1016,] 0 0 1 [1017,] 0 0 1 [1018,] 0 0 1 [1019,] 0 0 1 [1020,] 0 0 1 [1021,] 0 0 1 [1022,] 0 0 1 [1023,] 0 0 1 [1024,] 0 0 1 [1025,] 0 0 1 [1026,] 0 0 1 [1027,] 0 0 1 [1028,] 0 0 1 [1029,] 0 0 1 [1030,] 0 0 1 [1031,] 0 0 1 [1032,] 0 0 1 [1033,] 0 0 1 [1034,] 0 0 1 [1035,] 0 0 1 [1036,] 0 0 1 [1037,] 0 0 1 [1038,] 0 0 1 [1039,] 0 0 1 [1040,] 0 0 1 [1041,] 0 0 1 [1042,] 0 0 1 [1043,] 0 0 1 [1044,] 0 0 1 [1045,] 0 0 1 [1046,] 0 0 1 $cv.list $cv.list$fold1.1 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 814.669 696 597.078 688 0.2670 615.1 5 1 2nd 783.345 696 734.139 688 0.0628 752.1 5 1 3rd 965.040 696 740.983 688 0.2320 759.0 4 1 Earth selected 9 of 18 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, survived, sibsp, parch, sexmale Number of terms at each degree of interaction: 1 4 4 Earth GCV RSS GRSq RSq 1st 0.1515520 99.36248 0.235363940 0.2786772 2nd 0.1865456 122.30541 0.006992362 0.0632418 3rd 0.1913997 125.48793 0.235272465 0.2785909 All 0.5294974 347.15582 0.167909094 0.2150433 $cv.list$fold1.2 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 814.669 696 626.198 691 0.2310 638.2 5 1 2nd 783.345 696 758.632 691 0.0315 770.6 5 1 3rd 965.040 696 762.502 691 0.2100 774.5 5 1 Earth selected 6 of 17 terms, and 4 of 5 predictors Termination condition: Reached nk 21 Importance: age, survived, sibsp, parch, sexmale-unused Number of terms at each degree of interaction: 1 4 1 Earth GCV RSS GRSq RSq 1st 0.1529711 102.5306 0.228204289 0.25567789 2nd 0.1888236 126.5612 -0.005133596 0.03064613 3rd 0.1942640 130.2077 0.223828340 0.25145771 All 0.5360587 359.2995 0.157598160 0.18758513 $cv.list$fold1.3 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 817.276 697 570.753 688 0.3020 590.8 6 1 2nd 783.919 697 744.014 688 0.0509 764.0 5 1 3rd 966.344 697 733.878 688 0.2410 753.9 5 1 Earth selected 10 of 18 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, parch, survived, sexmale, sibsp Number of terms at each degree of interaction: 1 5 4 Earth GCV RSS GRSq RSq 1st 0.1451921 94.63492 0.26921240 0.31563228 2nd 0.1901834 123.95985 -0.01334561 0.05102244 3rd 0.1912660 124.66547 0.23571486 0.28426251 All 0.5266414 343.26025 0.17274390 0.22529148 $cv.list$fold2.1 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 814.669 696 597.254 687 0.2670 617.3 6 1 2nd 783.345 696 736.794 687 0.0594 756.8 5 1 3rd 965.040 696 727.497 687 0.2460 747.5 5 1 Earth selected 10 of 18 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, survived, parch, sexmale, sibsp Number of terms at each degree of interaction: 1 5 4 Earth GCV RSS GRSq RSq 1st 0.1520939 98.98152 0.232630294 0.28144276 2nd 0.1889734 122.98247 -0.005931327 0.05805606 3rd 0.1900884 123.70807 0.240511837 0.28882295 All 0.5311557 345.67206 0.165303103 0.21839826 $cv.list$fold2.2 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 814.669 696 578.326 688 0.2900 596.3 6 1 2nd 783.345 696 724.472 688 0.0752 742.5 6 1 3rd 965.040 696 743.461 688 0.2300 761.5 5 1 Earth selected 9 of 17 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, survived, sexmale, sibsp, parch Number of terms at each degree of interaction: 1 5 3 Earth GCV RSS GRSq RSq 1st 0.1438013 94.28082 0.27446947 0.31556753 2nd 0.1844386 120.92397 0.01820836 0.07382247 3rd 0.1929243 126.48748 0.22918118 0.27284462 All 0.5211642 341.69227 0.18100457 0.22739700 $cv.list$fold2.3 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 817.276 697 616.648 688 0.245 636.6 5 1 2nd 783.919 697 740.015 688 0.056 760.0 5 1 3rd 966.344 697 742.566 688 0.232 762.6 5 1 Earth selected 10 of 18 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 4 5 Earth GCV RSS GRSq RSq 1st 0.1539970 100.3739 0.224895067 0.2741300 2nd 0.1890842 123.2434 -0.007488717 0.0565073 3rd 0.1943104 126.6498 0.223549460 0.2728699 All 0.5373916 350.2671 0.155857400 0.2094776 $cv.nterms.selected.by.gcv fold1.1 fold1.2 fold1.3 fold2.1 fold2.2 fold2.3 mean 9 6 10 10 9 10 9 $cv.nvars.selected.by.gcv fold1.1 fold1.2 fold1.3 fold2.1 fold2.2 fold2.3 mean 5.000000 4.000000 5.000000 5.000000 5.000000 5.000000 4.833333 $cv.groups cross fold [1,] 1 3 [2,] 1 2 [3,] 1 2 [4,] 1 3 [5,] 1 3 [6,] 1 1 [7,] 1 1 [8,] 1 1 [9,] 1 3 [10,] 1 1 [11,] 1 2 [12,] 1 1 [13,] 1 2 [14,] 1 3 [15,] 1 3 [16,] 1 2 [17,] 1 2 [18,] 1 2 [19,] 1 3 [20,] 1 3 [21,] 1 3 [22,] 1 3 [23,] 1 2 [24,] 1 3 [25,] 1 1 [26,] 1 2 [27,] 1 1 [28,] 1 1 [29,] 1 1 [30,] 1 2 [31,] 1 1 [32,] 1 2 [33,] 1 2 [34,] 1 1 [35,] 1 2 [36,] 1 2 [37,] 1 1 [38,] 1 2 [39,] 1 2 [40,] 1 1 [41,] 1 2 [42,] 1 1 [43,] 1 3 [44,] 1 2 [45,] 1 2 [46,] 1 1 [47,] 1 1 [48,] 1 3 [49,] 1 3 [50,] 1 1 [51,] 1 1 [52,] 1 2 [53,] 1 2 [54,] 1 3 [55,] 1 1 [56,] 1 2 [57,] 1 2 [58,] 1 1 [59,] 1 1 [60,] 1 2 [61,] 1 2 [62,] 1 3 [63,] 1 3 [64,] 1 2 [65,] 1 3 [66,] 1 3 [67,] 1 3 [68,] 1 1 [69,] 1 1 [70,] 1 1 [71,] 1 2 [72,] 1 3 [73,] 1 2 [74,] 1 3 [75,] 1 1 [76,] 1 1 [77,] 1 3 [78,] 1 2 [79,] 1 3 [80,] 1 3 [81,] 1 2 [82,] 1 3 [83,] 1 2 [84,] 1 1 [85,] 1 2 [86,] 1 3 [87,] 1 3 [88,] 1 1 [89,] 1 3 [90,] 1 2 [91,] 1 3 [92,] 1 3 [93,] 1 3 [94,] 1 2 [95,] 1 1 [96,] 1 2 [97,] 1 3 [98,] 1 1 [99,] 1 1 [100,] 1 2 [101,] 1 3 [102,] 1 2 [103,] 1 2 [104,] 1 1 [105,] 1 1 [106,] 1 3 [107,] 1 1 [108,] 1 3 [109,] 1 2 [110,] 1 3 [111,] 1 3 [112,] 1 2 [113,] 1 3 [114,] 1 1 [115,] 1 2 [116,] 1 1 [117,] 1 1 [118,] 1 3 [119,] 1 2 [120,] 1 2 [121,] 1 1 [122,] 1 1 [123,] 1 1 [124,] 1 1 [125,] 1 2 [126,] 1 3 [127,] 1 1 [128,] 1 3 [129,] 1 3 [130,] 1 1 [131,] 1 3 [132,] 1 2 [133,] 1 3 [134,] 1 2 [135,] 1 2 [136,] 1 3 [137,] 1 2 [138,] 1 1 [139,] 1 1 [140,] 1 3 [141,] 1 3 [142,] 1 1 [143,] 1 1 [144,] 1 2 [145,] 1 2 [146,] 1 3 [147,] 1 1 [148,] 1 2 [149,] 1 2 [150,] 1 3 [151,] 1 3 [152,] 1 1 [153,] 1 3 [154,] 1 3 [155,] 1 2 [156,] 1 2 [157,] 1 2 [158,] 1 3 [159,] 1 3 [160,] 1 1 [161,] 1 1 [162,] 1 2 [163,] 1 2 [164,] 1 1 [165,] 1 3 [166,] 1 3 [167,] 1 3 [168,] 1 3 [169,] 1 1 [170,] 1 2 [171,] 1 2 [172,] 1 1 [173,] 1 1 [174,] 1 2 [175,] 1 1 [176,] 1 2 [177,] 1 2 [178,] 1 3 [179,] 1 2 [180,] 1 1 [181,] 1 2 [182,] 1 3 [183,] 1 2 [184,] 1 3 [185,] 1 1 [186,] 1 2 [187,] 1 1 [188,] 1 2 [189,] 1 3 [190,] 1 3 [191,] 1 3 [192,] 1 1 [193,] 1 2 [194,] 1 3 [195,] 1 2 [196,] 1 2 [197,] 1 1 [198,] 1 1 [199,] 1 1 [200,] 1 2 [201,] 1 3 [202,] 1 2 [203,] 1 2 [204,] 1 2 [205,] 1 3 [206,] 1 3 [207,] 1 1 [208,] 1 1 [209,] 1 1 [210,] 1 1 [211,] 1 2 [212,] 1 3 [213,] 1 2 [214,] 1 1 [215,] 1 3 [216,] 1 1 [217,] 1 1 [218,] 1 1 [219,] 1 3 [220,] 1 1 [221,] 1 3 [222,] 1 2 [223,] 1 3 [224,] 1 2 [225,] 1 2 [226,] 1 2 [227,] 1 3 [228,] 1 3 [229,] 1 3 [230,] 1 2 [231,] 1 1 [232,] 1 2 [233,] 1 2 [234,] 1 2 [235,] 1 1 [236,] 1 1 [237,] 1 3 [238,] 1 2 [239,] 1 3 [240,] 1 3 [241,] 1 1 [242,] 1 1 [243,] 1 1 [244,] 1 1 [245,] 1 1 [246,] 1 3 [247,] 1 3 [248,] 1 3 [249,] 1 2 [250,] 1 1 [251,] 1 1 [252,] 1 1 [253,] 1 2 [254,] 1 3 [255,] 1 1 [256,] 1 3 [257,] 1 2 [258,] 1 2 [259,] 1 2 [260,] 1 1 [261,] 1 1 [262,] 1 1 [263,] 1 2 [264,] 1 1 [265,] 1 1 [266,] 1 3 [267,] 1 1 [268,] 1 3 [269,] 1 3 [270,] 1 3 [271,] 1 2 [272,] 1 1 [273,] 1 3 [274,] 1 1 [275,] 1 3 [276,] 1 1 [277,] 1 1 [278,] 1 1 [279,] 1 2 [280,] 1 3 [281,] 1 2 [282,] 1 3 [283,] 1 3 [284,] 1 2 [285,] 1 3 [286,] 1 2 [287,] 1 1 [288,] 1 1 [289,] 1 3 [290,] 1 2 [291,] 1 2 [292,] 1 2 [293,] 1 3 [294,] 1 2 [295,] 1 3 [296,] 1 3 [297,] 1 1 [298,] 1 3 [299,] 1 2 [300,] 1 3 [301,] 1 1 [302,] 1 3 [303,] 1 2 [304,] 1 1 [305,] 1 2 [306,] 1 2 [307,] 1 2 [308,] 1 3 [309,] 1 1 [310,] 1 3 [311,] 1 3 [312,] 1 2 [313,] 1 2 [314,] 1 2 [315,] 1 1 [316,] 1 2 [317,] 1 1 [318,] 1 1 [319,] 1 2 [320,] 1 3 [321,] 1 3 [322,] 1 3 [323,] 1 3 [324,] 1 1 [325,] 1 2 [326,] 1 3 [327,] 1 1 [328,] 1 3 [329,] 1 1 [330,] 1 3 [331,] 1 1 [332,] 1 2 [333,] 1 1 [334,] 1 3 [335,] 1 3 [336,] 1 3 [337,] 1 2 [338,] 1 3 [339,] 1 1 [340,] 1 2 [341,] 1 2 [342,] 1 2 [343,] 1 2 [344,] 1 2 [345,] 1 3 [346,] 1 1 [347,] 1 1 [348,] 1 3 [349,] 1 1 [350,] 1 3 [351,] 1 3 [352,] 1 2 [353,] 1 1 [354,] 1 2 [355,] 1 3 [356,] 1 2 [357,] 1 2 [358,] 1 1 [359,] 1 3 [360,] 1 1 [361,] 1 3 [362,] 1 2 [363,] 1 2 [364,] 1 3 [365,] 1 3 [366,] 1 2 [367,] 1 3 [368,] 1 3 [369,] 1 1 [370,] 1 2 [371,] 1 1 [372,] 1 2 [373,] 1 2 [374,] 1 2 [375,] 1 1 [376,] 1 2 [377,] 1 1 [378,] 1 1 [379,] 1 1 [380,] 1 2 [381,] 1 3 [382,] 1 1 [383,] 1 1 [384,] 1 2 [385,] 1 1 [386,] 1 3 [387,] 1 3 [388,] 1 3 [389,] 1 2 [390,] 1 3 [391,] 1 2 [392,] 1 2 [393,] 1 1 [394,] 1 1 [395,] 1 1 [396,] 1 2 [397,] 1 1 [398,] 1 3 [399,] 1 2 [400,] 1 3 [401,] 1 3 [402,] 1 2 [403,] 1 1 [404,] 1 1 [405,] 1 3 [406,] 1 2 [407,] 1 3 [408,] 1 3 [409,] 1 2 [410,] 1 2 [411,] 1 2 [412,] 1 2 [413,] 1 3 [414,] 1 2 [415,] 1 2 [416,] 1 1 [417,] 1 1 [418,] 1 3 [419,] 1 3 [420,] 1 2 [421,] 1 1 [422,] 1 2 [423,] 1 1 [424,] 1 1 [425,] 1 3 [426,] 1 3 [427,] 1 2 [428,] 1 3 [429,] 1 3 [430,] 1 2 [431,] 1 2 [432,] 1 3 [433,] 1 3 [434,] 1 3 [435,] 1 1 [436,] 1 1 [437,] 1 3 [438,] 1 1 [439,] 1 3 [440,] 1 2 [441,] 1 1 [442,] 1 3 [443,] 1 1 [444,] 1 1 [445,] 1 1 [446,] 1 3 [447,] 1 2 [448,] 1 1 [449,] 1 2 [450,] 1 3 [451,] 1 1 [452,] 1 1 [453,] 1 2 [454,] 1 3 [455,] 1 1 [456,] 1 3 [457,] 1 3 [458,] 1 2 [459,] 1 1 [460,] 1 3 [461,] 1 1 [462,] 1 1 [463,] 1 2 [464,] 1 3 [465,] 1 1 [466,] 1 1 [467,] 1 3 [468,] 1 2 [469,] 1 3 [470,] 1 2 [471,] 1 3 [472,] 1 1 [473,] 1 1 [474,] 1 2 [475,] 1 3 [476,] 1 2 [477,] 1 2 [478,] 1 1 [479,] 1 1 [480,] 1 1 [481,] 1 2 [482,] 1 1 [483,] 1 3 [484,] 1 1 [485,] 1 3 [486,] 1 3 [487,] 1 3 [488,] 1 2 [489,] 1 2 [490,] 1 1 [491,] 1 3 [492,] 1 2 [493,] 1 3 [494,] 1 2 [495,] 1 2 [496,] 1 2 [497,] 1 1 [498,] 1 2 [499,] 1 3 [500,] 1 1 [501,] 1 2 [502,] 1 1 [503,] 1 2 [504,] 1 1 [505,] 1 2 [506,] 1 3 [507,] 1 1 [508,] 1 1 [509,] 1 1 [510,] 1 1 [511,] 1 1 [512,] 1 2 [513,] 1 3 [514,] 1 1 [515,] 1 1 [516,] 1 3 [517,] 1 3 [518,] 1 1 [519,] 1 1 [520,] 1 2 [521,] 1 1 [522,] 1 2 [523,] 1 3 [524,] 1 1 [525,] 1 1 [526,] 1 3 [527,] 1 2 [528,] 1 2 [529,] 1 1 [530,] 1 1 [531,] 1 3 [532,] 1 2 [533,] 1 3 [534,] 1 1 [535,] 1 3 [536,] 1 2 [537,] 1 3 [538,] 1 2 [539,] 1 3 [540,] 1 1 [541,] 1 3 [542,] 1 1 [543,] 1 2 [544,] 1 2 [545,] 1 1 [546,] 1 2 [547,] 1 1 [548,] 1 3 [549,] 1 1 [550,] 1 2 [551,] 1 3 [552,] 1 2 [553,] 1 3 [554,] 1 1 [555,] 1 1 [556,] 1 1 [557,] 1 2 [558,] 1 2 [559,] 1 2 [560,] 1 2 [561,] 1 1 [562,] 1 1 [563,] 1 2 [564,] 1 3 [565,] 1 1 [566,] 1 1 [567,] 1 1 [568,] 1 2 [569,] 1 2 [570,] 1 1 [571,] 1 1 [572,] 1 1 [573,] 1 2 [574,] 1 1 [575,] 1 3 [576,] 1 1 [577,] 1 3 [578,] 1 3 [579,] 1 3 [580,] 1 2 [581,] 1 3 [582,] 1 2 [583,] 1 2 [584,] 1 3 [585,] 1 3 [586,] 1 3 [587,] 1 1 [588,] 1 1 [589,] 1 2 [590,] 1 3 [591,] 1 3 [592,] 1 3 [593,] 1 3 [594,] 1 2 [595,] 1 1 [596,] 1 2 [597,] 1 1 [598,] 1 3 [599,] 1 2 [600,] 1 3 [601,] 1 2 [602,] 1 3 [603,] 1 1 [604,] 1 3 [605,] 1 3 [606,] 1 1 [607,] 1 2 [608,] 1 3 [609,] 1 1 [610,] 1 3 [611,] 1 1 [612,] 1 2 [613,] 1 2 [614,] 1 1 [615,] 1 1 [616,] 1 3 [617,] 1 3 [618,] 1 3 [619,] 1 3 [620,] 1 3 [621,] 1 2 [622,] 1 1 [623,] 1 3 [624,] 1 1 [625,] 1 3 [626,] 1 3 [627,] 1 3 [628,] 1 3 [629,] 1 3 [630,] 1 1 [631,] 1 1 [632,] 1 1 [633,] 1 3 [634,] 1 2 [635,] 1 2 [636,] 1 1 [637,] 1 3 [638,] 1 2 [639,] 1 2 [640,] 1 1 [641,] 1 2 [642,] 1 1 [643,] 1 2 [644,] 1 1 [645,] 1 2 [646,] 1 3 [647,] 1 3 [648,] 1 1 [649,] 1 2 [650,] 1 2 [651,] 1 1 [652,] 1 1 [653,] 1 3 [654,] 1 2 [655,] 1 3 [656,] 1 1 [657,] 1 2 [658,] 1 3 [659,] 1 1 [660,] 1 2 [661,] 1 3 [662,] 1 2 [663,] 1 3 [664,] 1 2 [665,] 1 1 [666,] 1 1 [667,] 1 2 [668,] 1 2 [669,] 1 3 [670,] 1 3 [671,] 1 1 [672,] 1 1 [673,] 1 2 [674,] 1 1 [675,] 1 1 [676,] 1 1 [677,] 1 1 [678,] 1 2 [679,] 1 3 [680,] 1 1 [681,] 1 2 [682,] 1 1 [683,] 1 3 [684,] 1 2 [685,] 1 1 [686,] 1 3 [687,] 1 2 [688,] 1 3 [689,] 1 3 [690,] 1 3 [691,] 1 2 [692,] 1 3 [693,] 1 3 [694,] 1 2 [695,] 1 2 [696,] 1 1 [697,] 1 1 [698,] 1 2 [699,] 1 2 [700,] 1 2 [701,] 1 3 [702,] 1 2 [703,] 1 1 [704,] 1 2 [705,] 1 1 [706,] 1 1 [707,] 1 1 [708,] 1 1 [709,] 1 2 [710,] 1 1 [711,] 1 1 [712,] 1 1 [713,] 1 1 [714,] 1 3 [715,] 1 2 [716,] 1 1 [717,] 1 3 [718,] 1 1 [719,] 1 2 [720,] 1 3 [721,] 1 3 [722,] 1 1 [723,] 1 3 [724,] 1 3 [725,] 1 3 [726,] 1 3 [727,] 1 1 [728,] 1 2 [729,] 1 3 [730,] 1 2 [731,] 1 1 [732,] 1 3 [733,] 1 2 [734,] 1 3 [735,] 1 3 [736,] 1 2 [737,] 1 1 [738,] 1 1 [739,] 1 3 [740,] 1 2 [741,] 1 2 [742,] 1 1 [743,] 1 2 [744,] 1 2 [745,] 1 1 [746,] 1 1 [747,] 1 2 [748,] 1 1 [749,] 1 3 [750,] 1 2 [751,] 1 1 [752,] 1 3 [753,] 1 1 [754,] 1 3 [755,] 1 2 [756,] 1 1 [757,] 1 3 [758,] 1 3 [759,] 1 3 [760,] 1 1 [761,] 1 2 [762,] 1 3 [763,] 1 2 [764,] 1 1 [765,] 1 1 [766,] 1 3 [767,] 1 3 [768,] 1 2 [769,] 1 1 [770,] 1 1 [771,] 1 3 [772,] 1 2 [773,] 1 1 [774,] 1 3 [775,] 1 3 [776,] 1 3 [777,] 1 2 [778,] 1 1 [779,] 1 3 [780,] 1 3 [781,] 1 2 [782,] 1 1 [783,] 1 2 [784,] 1 3 [785,] 1 3 [786,] 1 1 [787,] 1 1 [788,] 1 3 [789,] 1 2 [790,] 1 3 [791,] 1 3 [792,] 1 1 [793,] 1 3 [794,] 1 1 [795,] 1 3 [796,] 1 3 [797,] 1 1 [798,] 1 3 [799,] 1 2 [800,] 1 3 [801,] 1 3 [802,] 1 1 [803,] 1 1 [804,] 1 1 [805,] 1 2 [806,] 1 2 [807,] 1 3 [808,] 1 2 [809,] 1 1 [810,] 1 3 [811,] 1 3 [812,] 1 3 [813,] 1 1 [814,] 1 1 [815,] 1 2 [816,] 1 1 [817,] 1 1 [818,] 1 3 [819,] 1 2 [820,] 1 1 [821,] 1 2 [822,] 1 2 [823,] 1 1 [824,] 1 1 [825,] 1 1 [826,] 1 2 [827,] 1 1 [828,] 1 2 [829,] 1 2 [830,] 1 3 [831,] 1 2 [832,] 1 3 [833,] 1 2 [834,] 1 1 [835,] 1 2 [836,] 1 2 [837,] 1 1 [838,] 1 1 [839,] 1 2 [840,] 1 2 [841,] 1 1 [842,] 1 2 [843,] 1 1 [844,] 1 2 [845,] 1 3 [846,] 1 2 [847,] 1 2 [848,] 1 1 [849,] 1 1 [850,] 1 2 [851,] 1 1 [852,] 1 3 [853,] 1 3 [854,] 1 3 [855,] 1 3 [856,] 1 3 [857,] 1 1 [858,] 1 1 [859,] 1 2 [860,] 1 3 [861,] 1 3 [862,] 1 1 [863,] 1 1 [864,] 1 2 [865,] 1 3 [866,] 1 2 [867,] 1 3 [868,] 1 2 [869,] 1 2 [870,] 1 2 [871,] 1 2 [872,] 1 1 [873,] 1 3 [874,] 1 3 [875,] 1 1 [876,] 1 3 [877,] 1 3 [878,] 1 2 [879,] 1 3 [880,] 1 1 [881,] 1 1 [882,] 1 1 [883,] 1 1 [884,] 1 2 [885,] 1 2 [886,] 1 2 [887,] 1 1 [888,] 1 2 [889,] 1 3 [890,] 1 1 [891,] 1 2 [892,] 1 3 [893,] 1 3 [894,] 1 2 [895,] 1 3 [896,] 1 1 [897,] 1 1 [898,] 1 1 [899,] 1 2 [900,] 1 1 [901,] 1 1 [902,] 1 3 [903,] 1 3 [904,] 1 2 [905,] 1 2 [906,] 1 2 [907,] 1 2 [908,] 1 2 [909,] 1 3 [910,] 1 2 [911,] 1 1 [912,] 1 3 [913,] 1 2 [914,] 1 3 [915,] 1 2 [916,] 1 3 [917,] 1 3 [918,] 1 2 [919,] 1 3 [920,] 1 2 [921,] 1 2 [922,] 1 1 [923,] 1 2 [924,] 1 2 [925,] 1 2 [926,] 1 1 [927,] 1 2 [928,] 1 2 [929,] 1 1 [930,] 1 2 [931,] 1 1 [932,] 1 3 [933,] 1 3 [934,] 1 2 [935,] 1 1 [936,] 1 3 [937,] 1 2 [938,] 1 2 [939,] 1 3 [940,] 1 3 [941,] 1 3 [942,] 1 1 [943,] 1 1 [944,] 1 1 [945,] 1 3 [946,] 1 1 [947,] 1 2 [948,] 1 1 [949,] 1 3 [950,] 1 1 [951,] 1 2 [952,] 1 1 [953,] 1 3 [954,] 1 2 [955,] 1 3 [956,] 1 3 [957,] 1 3 [958,] 1 3 [959,] 1 3 [960,] 1 1 [961,] 1 1 [962,] 1 2 [963,] 1 3 [964,] 1 3 [965,] 1 2 [966,] 1 2 [967,] 1 3 [968,] 1 2 [969,] 1 1 [970,] 1 1 [971,] 1 1 [972,] 1 3 [973,] 1 3 [974,] 1 2 [975,] 1 2 [976,] 1 2 [977,] 1 2 [978,] 1 1 [979,] 1 1 [980,] 1 2 [981,] 1 2 [982,] 1 3 [983,] 1 3 [984,] 1 1 [985,] 1 2 [986,] 1 1 [987,] 1 1 [988,] 1 1 [989,] 1 3 [990,] 1 3 [991,] 1 3 [992,] 1 3 [993,] 1 2 [994,] 1 1 [995,] 1 3 [996,] 1 3 [997,] 1 1 [998,] 1 2 [999,] 1 3 [1000,] 1 1 [1001,] 1 3 [1002,] 1 1 [1003,] 1 2 [1004,] 1 2 [1005,] 1 2 [1006,] 1 3 [1007,] 1 3 [1008,] 1 2 [1009,] 1 2 [1010,] 1 2 [1011,] 1 2 [1012,] 1 2 [1013,] 1 2 [1014,] 1 3 [1015,] 1 3 [1016,] 1 2 [1017,] 1 3 [1018,] 1 1 [1019,] 1 1 [1020,] 1 1 [1021,] 1 2 [1022,] 1 1 [1023,] 1 2 [1024,] 1 3 [1025,] 1 1 [1026,] 1 1 [1027,] 1 2 [1028,] 1 3 [1029,] 1 2 [1030,] 1 2 [1031,] 1 3 [1032,] 1 3 [1033,] 1 1 [1034,] 1 2 [1035,] 1 1 [1036,] 1 2 [1037,] 1 1 [1038,] 1 1 [1039,] 1 1 [1040,] 1 2 [1041,] 1 3 [1042,] 1 1 [1043,] 1 2 [1044,] 1 1 [1045,] 1 3 [1046,] 1 2 [1047,] 2 3 [1048,] 2 2 [1049,] 2 2 [1050,] 2 1 [1051,] 2 1 [1052,] 2 1 [1053,] 2 2 [1054,] 2 1 [1055,] 2 2 [1056,] 2 2 [1057,] 2 2 [1058,] 2 2 [1059,] 2 3 [1060,] 2 3 [1061,] 2 1 [1062,] 2 2 [1063,] 2 3 [1064,] 2 2 [1065,] 2 2 [1066,] 2 2 [1067,] 2 3 [1068,] 2 3 [1069,] 2 2 [1070,] 2 1 [1071,] 2 2 [1072,] 2 1 [1073,] 2 3 [1074,] 2 1 [1075,] 2 3 [1076,] 2 1 [1077,] 2 2 [1078,] 2 2 [1079,] 2 1 [1080,] 2 2 [1081,] 2 1 [1082,] 2 2 [1083,] 2 2 [1084,] 2 3 [1085,] 2 2 [1086,] 2 2 [1087,] 2 2 [1088,] 2 2 [1089,] 2 2 [1090,] 2 3 [1091,] 2 1 [1092,] 2 3 [1093,] 2 2 [1094,] 2 2 [1095,] 2 2 [1096,] 2 1 [1097,] 2 2 [1098,] 2 3 [1099,] 2 2 [1100,] 2 1 [1101,] 2 1 [1102,] 2 2 [1103,] 2 3 [1104,] 2 3 [1105,] 2 3 [1106,] 2 1 [1107,] 2 1 [1108,] 2 3 [1109,] 2 2 [1110,] 2 1 [1111,] 2 2 [1112,] 2 3 [1113,] 2 3 [1114,] 2 1 [1115,] 2 1 [1116,] 2 3 [1117,] 2 3 [1118,] 2 1 [1119,] 2 2 [1120,] 2 2 [1121,] 2 3 [1122,] 2 3 [1123,] 2 1 [1124,] 2 1 [1125,] 2 1 [1126,] 2 2 [1127,] 2 2 [1128,] 2 3 [1129,] 2 3 [1130,] 2 1 [1131,] 2 1 [1132,] 2 1 [1133,] 2 1 [1134,] 2 2 [1135,] 2 1 [1136,] 2 3 [1137,] 2 3 [1138,] 2 1 [1139,] 2 2 [1140,] 2 3 [1141,] 2 3 [1142,] 2 1 [1143,] 2 1 [1144,] 2 1 [1145,] 2 2 [1146,] 2 2 [1147,] 2 3 [1148,] 2 1 [1149,] 2 2 [1150,] 2 3 [1151,] 2 1 [1152,] 2 2 [1153,] 2 1 [1154,] 2 3 [1155,] 2 3 [1156,] 2 1 [1157,] 2 1 [1158,] 2 2 [1159,] 2 1 [1160,] 2 3 [1161,] 2 1 [1162,] 2 1 [1163,] 2 2 [1164,] 2 2 [1165,] 2 1 [1166,] 2 3 [1167,] 2 3 [1168,] 2 1 [1169,] 2 2 [1170,] 2 2 [1171,] 2 1 [1172,] 2 1 [1173,] 2 1 [1174,] 2 1 [1175,] 2 3 [1176,] 2 1 [1177,] 2 3 [1178,] 2 3 [1179,] 2 3 [1180,] 2 1 [1181,] 2 3 [1182,] 2 3 [1183,] 2 2 [1184,] 2 2 [1185,] 2 2 [1186,] 2 2 [1187,] 2 3 [1188,] 2 1 [1189,] 2 2 [1190,] 2 1 [1191,] 2 3 [1192,] 2 2 [1193,] 2 1 [1194,] 2 3 [1195,] 2 1 [1196,] 2 3 [1197,] 2 1 [1198,] 2 3 [1199,] 2 2 [1200,] 2 2 [1201,] 2 3 [1202,] 2 1 [1203,] 2 3 [1204,] 2 3 [1205,] 2 3 [1206,] 2 3 [1207,] 2 3 [1208,] 2 2 [1209,] 2 1 [1210,] 2 3 [1211,] 2 2 [1212,] 2 3 [1213,] 2 3 [1214,] 2 3 [1215,] 2 2 [1216,] 2 1 [1217,] 2 1 [1218,] 2 1 [1219,] 2 1 [1220,] 2 1 [1221,] 2 2 [1222,] 2 1 [1223,] 2 2 [1224,] 2 3 [1225,] 2 3 [1226,] 2 3 [1227,] 2 1 [1228,] 2 3 [1229,] 2 3 [1230,] 2 3 [1231,] 2 1 [1232,] 2 3 [1233,] 2 3 [1234,] 2 1 [1235,] 2 1 [1236,] 2 2 [1237,] 2 1 [1238,] 2 2 [1239,] 2 2 [1240,] 2 3 [1241,] 2 3 [1242,] 2 2 [1243,] 2 2 [1244,] 2 3 [1245,] 2 1 [1246,] 2 3 [1247,] 2 3 [1248,] 2 1 [1249,] 2 3 [1250,] 2 2 [1251,] 2 1 [1252,] 2 3 [1253,] 2 3 [1254,] 2 1 [1255,] 2 1 [1256,] 2 2 [1257,] 2 1 [1258,] 2 2 [1259,] 2 1 [1260,] 2 2 [1261,] 2 3 [1262,] 2 2 [1263,] 2 2 [1264,] 2 2 [1265,] 2 2 [1266,] 2 3 [1267,] 2 1 [1268,] 2 3 [1269,] 2 2 [1270,] 2 1 [1271,] 2 1 [1272,] 2 3 [1273,] 2 2 [1274,] 2 2 [1275,] 2 1 [1276,] 2 2 [1277,] 2 3 [1278,] 2 2 [1279,] 2 1 [1280,] 2 1 [1281,] 2 3 [1282,] 2 2 [1283,] 2 3 [1284,] 2 3 [1285,] 2 3 [1286,] 2 2 [1287,] 2 2 [1288,] 2 1 [1289,] 2 1 [1290,] 2 2 [1291,] 2 1 [1292,] 2 2 [1293,] 2 3 [1294,] 2 3 [1295,] 2 1 [1296,] 2 2 [1297,] 2 1 [1298,] 2 2 [1299,] 2 3 [1300,] 2 1 [1301,] 2 3 [1302,] 2 3 [1303,] 2 2 [1304,] 2 2 [1305,] 2 3 [1306,] 2 2 [1307,] 2 1 [1308,] 2 1 [1309,] 2 3 [1310,] 2 1 [1311,] 2 2 [1312,] 2 2 [1313,] 2 1 [1314,] 2 2 [1315,] 2 2 [1316,] 2 3 [1317,] 2 2 [1318,] 2 1 [1319,] 2 3 [1320,] 2 3 [1321,] 2 2 [1322,] 2 1 [1323,] 2 1 [1324,] 2 3 [1325,] 2 3 [1326,] 2 1 [1327,] 2 2 [1328,] 2 1 [1329,] 2 3 [1330,] 2 2 [1331,] 2 3 [1332,] 2 2 [1333,] 2 3 [1334,] 2 1 [1335,] 2 3 [1336,] 2 1 [1337,] 2 1 [1338,] 2 3 [1339,] 2 3 [1340,] 2 2 [1341,] 2 2 [1342,] 2 3 [1343,] 2 2 [1344,] 2 1 [1345,] 2 2 [1346,] 2 1 [1347,] 2 2 [1348,] 2 2 [1349,] 2 1 [1350,] 2 2 [1351,] 2 1 [1352,] 2 3 [1353,] 2 2 [1354,] 2 2 [1355,] 2 1 [1356,] 2 2 [1357,] 2 2 [1358,] 2 2 [1359,] 2 3 [1360,] 2 1 [1361,] 2 3 [1362,] 2 2 [1363,] 2 1 [1364,] 2 1 [1365,] 2 3 [1366,] 2 2 [1367,] 2 1 [1368,] 2 3 [1369,] 2 1 [1370,] 2 1 [1371,] 2 1 [1372,] 2 1 [1373,] 2 2 [1374,] 2 2 [1375,] 2 3 [1376,] 2 3 [1377,] 2 1 [1378,] 2 1 [1379,] 2 1 [1380,] 2 2 [1381,] 2 1 [1382,] 2 3 [1383,] 2 2 [1384,] 2 3 [1385,] 2 3 [1386,] 2 3 [1387,] 2 1 [1388,] 2 2 [1389,] 2 1 [1390,] 2 3 [1391,] 2 3 [1392,] 2 2 [1393,] 2 2 [1394,] 2 1 [1395,] 2 2 [1396,] 2 2 [1397,] 2 2 [1398,] 2 2 [1399,] 2 3 [1400,] 2 1 [1401,] 2 1 [1402,] 2 1 [1403,] 2 3 [1404,] 2 3 [1405,] 2 2 [1406,] 2 3 [1407,] 2 1 [1408,] 2 2 [1409,] 2 2 [1410,] 2 1 [1411,] 2 2 [1412,] 2 3 [1413,] 2 3 [1414,] 2 1 [1415,] 2 2 [1416,] 2 3 [1417,] 2 2 [1418,] 2 3 [1419,] 2 2 [1420,] 2 1 [1421,] 2 2 [1422,] 2 2 [1423,] 2 1 [1424,] 2 3 [1425,] 2 3 [1426,] 2 3 [1427,] 2 3 [1428,] 2 3 [1429,] 2 2 [1430,] 2 2 [1431,] 2 1 [1432,] 2 1 [1433,] 2 2 [1434,] 2 1 [1435,] 2 2 [1436,] 2 2 [1437,] 2 3 [1438,] 2 3 [1439,] 2 1 [1440,] 2 3 [1441,] 2 3 [1442,] 2 2 [1443,] 2 2 [1444,] 2 1 [1445,] 2 2 [1446,] 2 1 [1447,] 2 1 [1448,] 2 3 [1449,] 2 3 [1450,] 2 2 [1451,] 2 1 [1452,] 2 3 [1453,] 2 1 [1454,] 2 3 [1455,] 2 1 [1456,] 2 2 [1457,] 2 3 [1458,] 2 1 [1459,] 2 2 [1460,] 2 2 [1461,] 2 2 [1462,] 2 2 [1463,] 2 1 [1464,] 2 1 [1465,] 2 2 [1466,] 2 3 [1467,] 2 3 [1468,] 2 2 [1469,] 2 3 [1470,] 2 3 [1471,] 2 2 [1472,] 2 3 [1473,] 2 2 [1474,] 2 2 [1475,] 2 2 [1476,] 2 3 [1477,] 2 2 [1478,] 2 1 [1479,] 2 3 [1480,] 2 3 [1481,] 2 2 [1482,] 2 3 [1483,] 2 3 [1484,] 2 3 [1485,] 2 3 [1486,] 2 1 [1487,] 2 2 [1488,] 2 2 [1489,] 2 3 [1490,] 2 3 [1491,] 2 2 [1492,] 2 2 [1493,] 2 3 [1494,] 2 3 [1495,] 2 2 [1496,] 2 1 [1497,] 2 1 [1498,] 2 3 [1499,] 2 3 [1500,] 2 2 [1501,] 2 1 [1502,] 2 1 [1503,] 2 3 [1504,] 2 3 [1505,] 2 3 [1506,] 2 2 [1507,] 2 3 [1508,] 2 2 [1509,] 2 3 [1510,] 2 3 [1511,] 2 1 [1512,] 2 1 [1513,] 2 1 [1514,] 2 3 [1515,] 2 3 [1516,] 2 1 [1517,] 2 2 [1518,] 2 1 [1519,] 2 2 [1520,] 2 1 [1521,] 2 2 [1522,] 2 1 [1523,] 2 1 [1524,] 2 3 [1525,] 2 3 [1526,] 2 3 [1527,] 2 2 [1528,] 2 1 [1529,] 2 3 [1530,] 2 3 [1531,] 2 1 [1532,] 2 1 [1533,] 2 3 [1534,] 2 3 [1535,] 2 1 [1536,] 2 2 [1537,] 2 2 [1538,] 2 1 [1539,] 2 1 [1540,] 2 1 [1541,] 2 2 [1542,] 2 2 [1543,] 2 2 [1544,] 2 1 [1545,] 2 2 [1546,] 2 1 [1547,] 2 1 [1548,] 2 3 [1549,] 2 1 [1550,] 2 2 [1551,] 2 1 [1552,] 2 2 [1553,] 2 3 [1554,] 2 1 [1555,] 2 3 [1556,] 2 1 [1557,] 2 3 [1558,] 2 2 [1559,] 2 3 [1560,] 2 3 [1561,] 2 3 [1562,] 2 2 [1563,] 2 1 [1564,] 2 1 [1565,] 2 1 [1566,] 2 3 [1567,] 2 2 [1568,] 2 1 [1569,] 2 1 [1570,] 2 3 [1571,] 2 2 [1572,] 2 2 [1573,] 2 1 [1574,] 2 1 [1575,] 2 1 [1576,] 2 1 [1577,] 2 1 [1578,] 2 2 [1579,] 2 1 [1580,] 2 3 [1581,] 2 1 [1582,] 2 2 [1583,] 2 1 [1584,] 2 3 [1585,] 2 2 [1586,] 2 1 [1587,] 2 3 [1588,] 2 2 [1589,] 2 1 [1590,] 2 2 [1591,] 2 3 [1592,] 2 1 [1593,] 2 2 [1594,] 2 1 [1595,] 2 1 [1596,] 2 2 [1597,] 2 1 [1598,] 2 2 [1599,] 2 3 [1600,] 2 2 [1601,] 2 1 [1602,] 2 3 [1603,] 2 2 [1604,] 2 3 [1605,] 2 3 [1606,] 2 3 [1607,] 2 1 [1608,] 2 1 [1609,] 2 1 [1610,] 2 2 [1611,] 2 1 [1612,] 2 3 [1613,] 2 2 [1614,] 2 1 [1615,] 2 3 [1616,] 2 3 [1617,] 2 3 [1618,] 2 2 [1619,] 2 2 [1620,] 2 3 [1621,] 2 2 [1622,] 2 3 [1623,] 2 3 [1624,] 2 2 [1625,] 2 3 [1626,] 2 2 [1627,] 2 1 [1628,] 2 1 [1629,] 2 2 [1630,] 2 3 [1631,] 2 1 [1632,] 2 3 [1633,] 2 2 [1634,] 2 1 [1635,] 2 1 [1636,] 2 2 [1637,] 2 1 [1638,] 2 3 [1639,] 2 3 [1640,] 2 3 [1641,] 2 2 [1642,] 2 2 [1643,] 2 2 [1644,] 2 3 [1645,] 2 2 [1646,] 2 2 [1647,] 2 2 [1648,] 2 3 [1649,] 2 2 [1650,] 2 3 [1651,] 2 1 [1652,] 2 1 [1653,] 2 2 [1654,] 2 3 [1655,] 2 3 [1656,] 2 2 [1657,] 2 1 [1658,] 2 1 [1659,] 2 1 [1660,] 2 1 [1661,] 2 3 [1662,] 2 1 [1663,] 2 3 [1664,] 2 3 [1665,] 2 3 [1666,] 2 1 [1667,] 2 2 [1668,] 2 3 [1669,] 2 3 [1670,] 2 3 [1671,] 2 2 [1672,] 2 1 [1673,] 2 1 [1674,] 2 1 [1675,] 2 2 [1676,] 2 2 [1677,] 2 1 [1678,] 2 3 [1679,] 2 2 [1680,] 2 2 [1681,] 2 2 [1682,] 2 1 [1683,] 2 3 [1684,] 2 1 [1685,] 2 3 [1686,] 2 1 [1687,] 2 3 [1688,] 2 1 [1689,] 2 3 [1690,] 2 2 [1691,] 2 3 [1692,] 2 1 [1693,] 2 3 [1694,] 2 3 [1695,] 2 1 [1696,] 2 3 [1697,] 2 2 [1698,] 2 1 [1699,] 2 3 [1700,] 2 1 [1701,] 2 2 [1702,] 2 1 [1703,] 2 2 [1704,] 2 1 [1705,] 2 3 [1706,] 2 1 [1707,] 2 2 [1708,] 2 1 [1709,] 2 1 [1710,] 2 2 [1711,] 2 2 [1712,] 2 1 [1713,] 2 3 [1714,] 2 3 [1715,] 2 3 [1716,] 2 3 [1717,] 2 3 [1718,] 2 3 [1719,] 2 3 [1720,] 2 2 [1721,] 2 2 [1722,] 2 3 [1723,] 2 2 [1724,] 2 2 [1725,] 2 3 [1726,] 2 3 [1727,] 2 1 [1728,] 2 3 [1729,] 2 1 [1730,] 2 2 [1731,] 2 1 [1732,] 2 1 [1733,] 2 1 [1734,] 2 2 [1735,] 2 1 [1736,] 2 1 [1737,] 2 1 [1738,] 2 2 [1739,] 2 1 [1740,] 2 3 [1741,] 2 3 [1742,] 2 2 [1743,] 2 2 [1744,] 2 3 [1745,] 2 2 [1746,] 2 3 [1747,] 2 3 [1748,] 2 1 [1749,] 2 2 [1750,] 2 1 [1751,] 2 3 [1752,] 2 2 [1753,] 2 1 [1754,] 2 1 [1755,] 2 2 [1756,] 2 3 [1757,] 2 1 [1758,] 2 3 [1759,] 2 1 [1760,] 2 3 [1761,] 2 1 [1762,] 2 2 [1763,] 2 3 [1764,] 2 1 [1765,] 2 2 [1766,] 2 2 [1767,] 2 1 [1768,] 2 3 [1769,] 2 1 [1770,] 2 2 [1771,] 2 1 [1772,] 2 1 [1773,] 2 1 [1774,] 2 2 [1775,] 2 2 [1776,] 2 3 [1777,] 2 2 [1778,] 2 2 [1779,] 2 3 [1780,] 2 1 [1781,] 2 3 [1782,] 2 1 [1783,] 2 3 [1784,] 2 2 [1785,] 2 2 [1786,] 2 2 [1787,] 2 2 [1788,] 2 3 [1789,] 2 2 [1790,] 2 2 [1791,] 2 2 [1792,] 2 3 [1793,] 2 2 [1794,] 2 3 [1795,] 2 2 [1796,] 2 1 [1797,] 2 1 [1798,] 2 3 [1799,] 2 3 [1800,] 2 3 [1801,] 2 2 [1802,] 2 3 [1803,] 2 2 [1804,] 2 2 [1805,] 2 1 [1806,] 2 1 [1807,] 2 3 [1808,] 2 2 [1809,] 2 1 [1810,] 2 2 [1811,] 2 1 [1812,] 2 1 [1813,] 2 3 [1814,] 2 1 [1815,] 2 1 [1816,] 2 3 [1817,] 2 1 [1818,] 2 3 [1819,] 2 2 [1820,] 2 3 [1821,] 2 1 [1822,] 2 2 [1823,] 2 1 [1824,] 2 1 [1825,] 2 2 [1826,] 2 1 [1827,] 2 1 [1828,] 2 1 [1829,] 2 2 [1830,] 2 1 [1831,] 2 3 [1832,] 2 2 [1833,] 2 3 [1834,] 2 1 [1835,] 2 2 [1836,] 2 1 [1837,] 2 1 [1838,] 2 3 [1839,] 2 3 [1840,] 2 1 [1841,] 2 1 [1842,] 2 1 [1843,] 2 2 [1844,] 2 3 [1845,] 2 3 [1846,] 2 3 [1847,] 2 1 [1848,] 2 1 [1849,] 2 1 [1850,] 2 3 [1851,] 2 1 [1852,] 2 1 [1853,] 2 1 [1854,] 2 2 [1855,] 2 3 [1856,] 2 2 [1857,] 2 2 [1858,] 2 1 [1859,] 2 1 [1860,] 2 3 [1861,] 2 3 [1862,] 2 3 [1863,] 2 2 [1864,] 2 2 [1865,] 2 3 [1866,] 2 3 [1867,] 2 1 [1868,] 2 1 [1869,] 2 1 [1870,] 2 2 [1871,] 2 2 [1872,] 2 3 [1873,] 2 3 [1874,] 2 1 [1875,] 2 3 [1876,] 2 3 [1877,] 2 2 [1878,] 2 1 [1879,] 2 2 [1880,] 2 3 [1881,] 2 2 [1882,] 2 2 [1883,] 2 2 [1884,] 2 1 [1885,] 2 3 [1886,] 2 1 [1887,] 2 3 [1888,] 2 1 [1889,] 2 1 [1890,] 2 2 [1891,] 2 2 [1892,] 2 2 [1893,] 2 2 [1894,] 2 3 [1895,] 2 2 [1896,] 2 3 [1897,] 2 2 [1898,] 2 3 [1899,] 2 2 [1900,] 2 1 [1901,] 2 3 [1902,] 2 3 [1903,] 2 2 [1904,] 2 3 [1905,] 2 2 [1906,] 2 3 [1907,] 2 2 [1908,] 2 2 [1909,] 2 3 [1910,] 2 2 [1911,] 2 3 [1912,] 2 1 [1913,] 2 1 [1914,] 2 3 [1915,] 2 2 [1916,] 2 1 [1917,] 2 3 [1918,] 2 1 [1919,] 2 2 [1920,] 2 1 [1921,] 2 3 [1922,] 2 2 [1923,] 2 3 [1924,] 2 1 [1925,] 2 1 [1926,] 2 1 [1927,] 2 1 [1928,] 2 2 [1929,] 2 1 [1930,] 2 1 [1931,] 2 3 [1932,] 2 2 [1933,] 2 2 [1934,] 2 1 [1935,] 2 3 [1936,] 2 3 [1937,] 2 3 [1938,] 2 2 [1939,] 2 1 [1940,] 2 2 [1941,] 2 3 [1942,] 2 2 [1943,] 2 2 [1944,] 2 1 [1945,] 2 3 [1946,] 2 1 [1947,] 2 2 [1948,] 2 3 [1949,] 2 1 [1950,] 2 1 [1951,] 2 2 [1952,] 2 1 [1953,] 2 3 [1954,] 2 2 [1955,] 2 1 [1956,] 2 2 [1957,] 2 1 [1958,] 2 2 [1959,] 2 1 [1960,] 2 1 [1961,] 2 2 [1962,] 2 2 [1963,] 2 3 [1964,] 2 3 [1965,] 2 3 [1966,] 2 1 [1967,] 2 3 [1968,] 2 2 [1969,] 2 2 [1970,] 2 1 [1971,] 2 2 [1972,] 2 3 [1973,] 2 2 [1974,] 2 2 [1975,] 2 3 [1976,] 2 3 [1977,] 2 3 [1978,] 2 3 [1979,] 2 1 [1980,] 2 3 [1981,] 2 2 [1982,] 2 3 [1983,] 2 2 [1984,] 2 3 [1985,] 2 1 [1986,] 2 1 [1987,] 2 3 [1988,] 2 2 [1989,] 2 3 [1990,] 2 3 [1991,] 2 2 [1992,] 2 1 [1993,] 2 1 [1994,] 2 3 [1995,] 2 3 [1996,] 2 2 [1997,] 2 3 [1998,] 2 1 [1999,] 2 3 [2000,] 2 2 [2001,] 2 3 [2002,] 2 1 [2003,] 2 3 [2004,] 2 3 [2005,] 2 1 [2006,] 2 1 [2007,] 2 2 [2008,] 2 3 [2009,] 2 3 [2010,] 2 2 [2011,] 2 3 [2012,] 2 1 [2013,] 2 2 [2014,] 2 3 [2015,] 2 2 [2016,] 2 3 [2017,] 2 3 [2018,] 2 3 [2019,] 2 3 [2020,] 2 2 [2021,] 2 3 [2022,] 2 2 [2023,] 2 2 [2024,] 2 3 [2025,] 2 1 [2026,] 2 1 [2027,] 2 3 [2028,] 2 2 [2029,] 2 1 [2030,] 2 2 [2031,] 2 3 [2032,] 2 2 [2033,] 2 1 [2034,] 2 2 [2035,] 2 2 [2036,] 2 3 [2037,] 2 3 [2038,] 2 3 [2039,] 2 2 [2040,] 2 2 [2041,] 2 2 [2042,] 2 2 [2043,] 2 1 [2044,] 2 2 [2045,] 2 1 [2046,] 2 3 [2047,] 2 3 [2048,] 2 2 [2049,] 2 2 [2050,] 2 2 [2051,] 2 1 [2052,] 2 1 [2053,] 2 3 [2054,] 2 3 [2055,] 2 1 [2056,] 2 1 [2057,] 2 1 [2058,] 2 2 [2059,] 2 1 [2060,] 2 1 [2061,] 2 2 [2062,] 2 2 [2063,] 2 2 [2064,] 2 2 [2065,] 2 1 [2066,] 2 1 [2067,] 2 3 [2068,] 2 1 [2069,] 2 1 [2070,] 2 1 [2071,] 2 2 [2072,] 2 3 [2073,] 2 1 [2074,] 2 1 [2075,] 2 3 [2076,] 2 2 [2077,] 2 1 [2078,] 2 1 [2079,] 2 1 [2080,] 2 1 [2081,] 2 3 [2082,] 2 1 [2083,] 2 2 [2084,] 2 2 [2085,] 2 2 [2086,] 2 2 [2087,] 2 2 [2088,] 2 3 [2089,] 2 2 [2090,] 2 2 [2091,] 2 1 [2092,] 2 2 $cv.rsq.tab 1st 2nd 3rd mean fold1.1 0.2441411 -0.027509916 0.2242076 0.1469463 fold1.2 0.2534320 -0.002595645 0.2095488 0.1534617 fold1.3 0.2298410 0.036552600 0.2370491 0.1678142 fold2.1 0.2984635 0.026935659 0.2322357 0.1858783 fold2.2 0.1879841 -0.005368357 0.2230252 0.1352136 fold2.3 0.2766396 0.038437143 0.2452564 0.1867777 mean 0.2484169 0.011075247 0.2285538 0.1626820 $cv.maxerr.tab 1st 2nd 3rd max fold1.1 0.9861059 0.9630160 0.9539150 0.9861059 fold1.2 0.9728289 0.9010602 0.9684675 0.9728289 fold1.3 0.9805176 0.9279797 -0.9494686 0.9805176 fold2.1 0.9800442 0.9353560 0.9572124 0.9800442 fold2.2 0.9955341 0.9606033 -0.9908314 0.9955341 fold2.3 0.8985087 0.9309341 0.9625199 0.9625199 all 0.9955341 0.9630160 -0.9908314 0.9955341 $cv.class.rate.tab 1st 2nd 3rd mean [1,] 0.7621777 0.7335244 0.6962751 0.5959885 [2,] 0.7879656 0.7335244 0.6762178 0.5988539 [3,] 0.7442529 0.7298851 0.7155172 0.5948276 [4,] 0.7908309 0.7507163 0.7134670 0.6275072 [5,] 0.7449857 0.7020057 0.6991404 0.5730659 [6,] 0.7816092 0.7442529 0.7097701 0.6178161 [7,] 0.7686370 0.7323181 0.7017313 0.6013432 $cv.auc.tab 1st 2nd 3rd mean fold1.1 0.8156651 0.5397473 0.7868658 0.7140928 fold1.2 0.8141525 0.5138633 0.7651675 0.6977278 fold1.3 0.7934956 0.6373365 0.7822642 0.7376988 fold2.1 0.8325114 0.6106651 0.7877213 0.7436326 fold2.2 0.7790924 0.5744275 0.7798908 0.7111369 fold2.3 0.8255570 0.6235962 0.7933635 0.7475056 mean 0.8100790 0.5832727 0.7825455 0.7252991 $cv.deviance.tab 1st 2nd 3rd mean fold1.1 0.9088035 1.159727 1.131264 1.066598 fold1.2 0.9062630 1.121149 1.155246 1.060886 fold1.3 0.9359478 1.085656 1.121004 1.047536 fold2.1 0.8593893 1.101500 1.122192 1.027694 fold2.2 0.9869922 1.131566 1.130573 1.083044 fold2.3 0.8757037 1.081301 1.105563 1.020856 mean 0.9121833 1.113483 1.127640 1.051102 $cv.calib.int.tab 1st 2nd 3rd mean fold1.1 -0.077142384 -0.8222402 -0.0704352444 -0.32327261 fold1.2 0.055047839 -0.5466561 -0.0534965483 -0.18170161 fold1.3 -0.228856612 -0.3093184 0.1569883335 -0.12706224 fold2.1 -0.051707497 -0.3130541 -0.0710011545 -0.14525425 fold2.2 -0.214811640 -0.6221650 0.0411599519 -0.26527223 fold2.3 0.008864474 -0.2934482 -0.0022279021 -0.09560389 mean -0.084767637 -0.4844803 0.0001645727 -0.18969447 $cv.calib.slope.tab 1st 2nd 3rd mean fold1.1 0.8301696 0.2348317 0.8294982 0.6314998 fold1.2 0.9687494 0.5085021 0.8688421 0.7820312 fold1.3 0.8045537 0.7534334 0.9098568 0.8226146 fold2.1 0.9358269 0.6639685 0.8538646 0.8178867 fold2.2 0.7130290 0.4340352 0.8754701 0.6741781 fold2.3 1.0426759 0.7279681 0.8517028 0.8741156 mean 0.8825007 0.5537898 0.8648724 0.7670543 $cv.oof.rsq.tab nterms1 nterms2 nterms3 nterms4 nterms5 nterms6 nterms7 nterms8 nterms9 nterms10 nterms11 nterms12 nterms13 nterms14 nterms15 nterms16 nterms17 fold1.1 0.000000e+00 0.11596099 0.1590362 0.1598438 0.1508959 0.1470209 0.1349494 0.1380797 0.1469463 0.1493190 0.1511365 0.1583270 0.1568701 0.1554200 0.1598953 0.1633167 0.16479632 fold1.2 0.000000e+00 0.08260207 0.1423589 0.1463711 0.1496191 0.1534617 0.1624207 0.1711873 0.1625250 0.1716659 0.1766699 0.1798231 0.1819866 0.1858894 0.1754512 0.1759474 0.17956621 fold1.3 -7.394925e-06 0.04902664 0.1062241 0.1380487 0.1444341 0.1407807 0.1468760 0.1552429 0.1641363 0.1678142 0.1680551 0.1658091 0.1654798 0.1644041 0.1616314 0.1667670 0.16121360 fold2.1 0.000000e+00 0.10440480 0.1637471 0.1542226 0.1392713 0.1418149 0.1518690 0.1625576 0.1752427 0.1858783 0.1840361 0.1810567 0.1777510 0.1716854 0.1684616 0.1672333 0.09030691 fold2.2 0.000000e+00 0.08055039 0.1163897 0.1311168 0.1273805 0.1221960 0.1177016 0.1273801 0.1352136 0.1147362 0.1182514 0.1155206 0.1129037 0.1182062 0.1285892 0.1269659 0.12515184 fold2.3 -7.394925e-06 0.05265338 0.1218099 0.1372113 0.1487085 0.1596166 0.1725239 0.1805705 0.1911727 0.1867777 0.1932294 0.1897985 0.1856205 0.1760852 0.1679349 0.1690713 0.16745728 all -2.464975e-06 0.08086638 0.1349277 0.1444690 0.1433849 0.1441485 0.1477234 0.1558364 0.1625394 0.1626985 0.1652297 0.1650558 0.1634353 0.1619484 0.1603273 0.1615503 0.14808203 $cv.infold.rsq.tab nterms1 nterms2 nterms3 nterms4 nterms5 nterms6 nterms7 nterms8 nterms9 nterms10 nterms11 nterms12 nterms13 nterms14 nterms15 nterms16 nterms17 fold1.1 0 0.08017385 0.1500335 0.1642621 0.1738047 0.1854757 0.1957948 0.2006982 0.2068366 0.2123606 0.2169513 0.2202322 0.2212613 0.2221827 0.2230876 0.2238410 0.2241052 fold1.2 0 0.09881522 0.1549135 0.1608374 0.1703478 0.1792606 0.1847912 0.1914389 0.1943076 0.1993468 0.2029905 0.2076836 0.2111838 0.2129476 0.2143582 0.2151953 0.2160593 fold1.3 0 0.08631842 0.1252904 0.1564999 0.1645027 0.1779671 0.1920107 0.2023478 0.2101203 0.2169724 0.2206087 0.2223064 0.2261109 0.2291259 0.2320543 0.2346892 0.2370381 fold2.1 0 0.08046881 0.1363296 0.1575026 0.1717429 0.1804159 0.1867818 0.1949175 0.2030768 0.2094406 0.2135045 0.2165366 0.2192895 0.2207172 0.2226409 0.2250009 0.2270592 fold2.2 0 0.08512719 0.1513537 0.1658048 0.1837451 0.1927214 0.1995994 0.2143539 0.2207449 0.2244967 0.2284963 0.2318850 0.2346543 0.2376913 0.2390537 0.2398683 0.2399726 fold2.3 0 0.07969951 0.1327762 0.1550381 0.1606285 0.1702405 0.1805690 0.1859688 0.1949599 0.2011691 0.2044097 0.2079054 0.2096610 0.2119299 0.2145126 0.2150638 0.2172960 all 0 0.08510050 0.1417828 0.1599908 0.1707953 0.1810135 0.1899245 0.1982875 0.2050077 0.2106310 0.2144935 0.2177582 0.2203601 0.2224324 0.2242845 0.2256098 0.2269217 attr(,"class") [1] "earth" ------------------------------------------------------------------------------- > printh(summary(a7)) === summary(a7) Call: earth(formula=pclass~., data=etitanic, keepxy=TRUE, trace=1, glm=list(family="binomial"), degree=2, nfold=3, ncross=2) GLM coefficients 1st 2nd 3rd (Intercept) -2.66307135 -1.93136147 1.37992944 survived 2.84788552 1.06418271 -2.84378575 sexmale 1.42483431 0.96598862 -1.45239590 h(sibsp-1) -0.52879762 -0.64928949 0.79974678 h(2-parch) 1.25518755 0.06534587 -1.29855706 survived * sexmale -1.25498201 -1.95099222 2.28554497 survived * h(16-age) -0.17824991 0.09390085 0.02011681 h(55-age) * h(2-parch) -0.04946408 0.00043737 0.04146455 h(1-sibsp) * h(1-parch) -1.02162885 -0.21902436 1.12490799 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 1223.31 1045 894.814 1037 0.2690 912.8 5 1 2nd 1175.31 1045 1126.944 1037 0.0411 1145.0 5 1 3rd 1448.21 1045 1118.941 1037 0.2270 1137.0 5 1 Earth selected 9 of 17 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 4 4 Earth GCV RSS GRSq RSq CVRSq 1st 0.1478715 148.5253 0.253819943 0.28210854 0.24841689 2nd 0.1869804 187.8072 0.003405389 0.04118751 0.01107525 3rd 0.1895587 190.3968 0.241872961 0.27061448 0.22855380 All 0.5244105 526.7293 0.175229617 0.20649767 0.16268198 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 9.00 sd 1.55 nvars 4.83 sd 0.41 CVRSq sd ClassRate sd MaxErr sd AUC sd MeanDev sd CalibInt sd CalibSlope sd 1st 0.248 0.038 0.769 0.021 0.996 0.0353 0.810 0.020 0.912 0.0454 -0.085 0.116 0.883 0.121 2nd 0.011 0.027 0.732 0.017 0.963 0.0230 0.583 0.049 1.113 0.0299 -0.484 0.216 0.554 0.200 3rd 0.229 0.012 0.702 0.015 -0.991 0.9971 0.783 0.010 1.128 0.0164 0.000 0.089 0.865 0.027 All 0.163 0.021 0.601 0.019 0.996 0.0113 0.725 0.020 1.051 0.0238 -0.190 0.088 0.767 0.094 > plotmo(a7, nresponse=1) plotmo grid: survived sex age sibsp parch 0 male 28 0 0 > printh(a7$cv.list[[3]]) === a7$cv.list[[3]] GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 817.276 697 570.753 688 0.3020 590.8 6 1 2nd 783.919 697 744.014 688 0.0509 764.0 5 1 3rd 966.344 697 733.878 688 0.2410 753.9 5 1 Earth selected 10 of 18 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, parch, survived, sexmale, sibsp Number of terms at each degree of interaction: 1 5 4 Earth GCV RSS GRSq RSq 1st 0.1451921 94.63492 0.26921240 0.31563228 2nd 0.1901834 123.95985 -0.01334561 0.05102244 3rd 0.1912660 124.66547 0.23571486 0.28426251 All 0.5266414 343.26025 0.17274390 0.22529148 > printh(summary(a7$cv.list[[3]])) === summary(a7$cv.list[[3]]) Call: earth(x=infold.x, y=infold.y, weights=infold.weights, wp=wp, subset=subset, pmethod=if(pmethod=="cv")"backward"elsepmethod, keepxy=(keepxy==2), trace=trace, glm=glm.arg, degree=degree, nfold=0, ncross=0, varmod.method="none", Scale.y=Scale.y) GLM coefficients 1st 2nd 3rd (Intercept) -3.6572433 -1.70096406 1.75718954 survived 3.5781291 1.12923557 -3.09432269 sexmale 2.3609385 0.95729183 -1.81007854 h(age-26) 0.0312937 -0.03221103 -0.02946033 h(sibsp-1) -0.4057591 -0.70349731 0.73044840 h(2-parch) 0.8317124 0.30062718 -0.82349485 survived * sexmale -1.9369398 -2.24946126 2.65125784 survived * h(16-age) -0.1619917 0.11754183 0.00615730 h(48-age) * h(2-parch) -0.0440142 -0.01336573 0.03316346 h(1-sibsp) * h(1-parch) -1.1813433 -0.13382116 1.09860841 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 817.276 697 570.753 688 0.3020 590.8 6 1 2nd 783.919 697 744.014 688 0.0509 764.0 5 1 3rd 966.344 697 733.878 688 0.2410 753.9 5 1 Earth selected 10 of 18 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, parch, survived, sexmale, sibsp Number of terms at each degree of interaction: 1 5 4 Earth GCV RSS GRSq RSq 1st 0.1451921 94.63492 0.26921240 0.31563228 2nd 0.1901834 123.95985 -0.01334561 0.05102244 3rd 0.1912660 124.66547 0.23571486 0.28426251 All 0.5266414 343.26025 0.17274390 0.22529148 > plot(a7, main="a7 (multiple response model)", which=1, nresponse=1) > > cat("a7.wp: as above but with wp parameter\n\n") a7.wp: as above but with wp parameter > set.seed(3) > a7.wp <- earth(pclass ~ ., data=etitanic, degree=2, glm=list(family="binomial"), trace=0.5, nfold=3, wp=c(1,3,1)) Full model GRSq 0.116 RSq 0.158, starting cross validation CV fold 1 CVRSq 0.111 Per response CVRSq 0.253 0.020 0.242 n.oof 697 33% n.infold.nz 189 174 334 n.oof.nz 95 87 167 CV fold 2 CVRSq 0.094 Per response CVRSq 0.274 -0.009 0.225 n.oof 697 33% n.infold.nz 189 174 334 n.oof.nz 95 87 167 CV fold 3 CVRSq 0.114 Per response CVRSq 0.225 0.038 0.230 n.oof 698 33% n.infold.nz 190 174 334 n.oof.nz 94 87 167 CV all CVRSq 0.106 Per response CVRSq 0.251 0.016 0.232 n.infold.nz 284 261 501 > printh(a7.wp) === a7.wp GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 1223.31 1045 896.399 1035 0.2670 918.4 5 1 2nd 1175.31 1045 1104.929 1035 0.0599 1127.0 5 1 3rd 1448.21 1045 1104.910 1035 0.2370 1127.0 5 1 Earth selected 11 of 17 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, survived, sexmale, sibsp, parch Number of terms at each degree of interaction: 1 7 3 Earth GCV RSS GRSq RSq CVRSq 1st 0.1479826 147.1903 0.25325913 0.28856097 0.25052621 2nd 0.1853555 184.3632 0.01206601 0.05877016 0.01640531 3rd 0.1892947 188.2813 0.24292866 0.27871887 0.23220531 All 0.5360063 533.1367 0.11643262 0.15820288 0.10638949 > printh(summary(a7.wp)) === summary(a7.wp) Call: earth(formula=pclass~., data=etitanic, wp=c(1,3,1), trace=0.5, glm=list(family="binomial"), degree=2, nfold=3) GLM coefficients 1st 2nd 3rd (Intercept) -3.3291753 -0.21324912 1.20532422 survived 2.7457252 0.96232229 -2.77177950 sexmale 1.2967289 0.88217084 -1.35666727 h(age-2) 0.0499172 -0.03281616 -0.03729641 h(29-age) 0.0405659 -0.09795559 0.01758322 h(1-sibsp) -0.6590991 -0.32444864 0.95229902 h(sibsp-1) -0.6115266 -0.59416550 0.88280794 h(parch-2) -0.9893139 -0.68927555 1.37568290 survived * sexmale -1.1255509 -1.91592795 2.21593299 survived * h(16-age) -0.1880959 0.19060050 -0.03040525 h(47-age) * h(2-parch) -0.0288987 -0.00291049 0.01997497 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 1223.31 1045 896.399 1035 0.2670 918.4 5 1 2nd 1175.31 1045 1104.929 1035 0.0599 1127.0 5 1 3rd 1448.21 1045 1104.910 1035 0.2370 1127.0 5 1 Earth selected 11 of 17 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: age, survived, sexmale, sibsp, parch Number of terms at each degree of interaction: 1 7 3 Earth GCV RSS GRSq RSq CVRSq 1st 0.1479826 147.1903 0.25325913 0.28856097 0.25052621 2nd 0.1853555 184.3632 0.01206601 0.05877016 0.01640531 3rd 0.1892947 188.2813 0.24292866 0.27871887 0.23220531 All 0.5360063 533.1367 0.11643262 0.15820288 0.10638949 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 9.00 sd 1.00 nvars 5.00 sd 0.00 CVRSq sd ClassRate sd MaxErr sd AUC sd MeanDev sd CalibInt sd CalibSlope sd 1st 0.251 0.025 0.763 0.034 0.983 0.01172 0.810 0.014 0.914 0.02656 -0.077 0.161 0.892 0.098 2nd 0.016 0.024 0.735 0.006 0.931 0.00647 0.603 0.040 1.108 0.02462 -0.462 0.158 0.579 0.167 3rd 0.232 0.009 0.693 0.013 0.980 1.11319 0.782 0.011 1.130 0.00519 0.008 0.133 0.870 0.031 All 0.106 0.011 0.596 0.011 0.983 0.00454 0.680 0.022 1.074 0.00938 -0.291 0.083 0.700 0.080 > print.stripped.earth.model(a7.wp, "a7.wp") print.stripped.earth.model(a7.wp) $rsq [1] 0.1582029 $gcv [1] 0.5360063 $grsq [1] 0.1164326 $dirs survived sexmale age sibsp parch (Intercept) 0 0 0 0 0 h(age-29) 0 0 1 0 0 h(29-age) 0 0 -1 0 0 survived 2 0 0 0 0 survived*h(age-16) 2 0 1 0 0 survived*h(16-age) 2 0 -1 0 0 survived*sexmale 2 2 0 0 0 h(parch-2) 0 0 0 0 1 h(2-parch) 0 0 0 0 -1 h(sibsp-1) 0 0 0 1 0 h(1-sibsp) 0 0 0 -1 0 sexmale 0 2 0 0 0 h(age-47)*h(2-parch) 0 0 1 0 -1 h(47-age)*h(2-parch) 0 0 -1 0 -1 sexmale*h(age-6) 0 2 1 0 0 sexmale*h(6-age) 0 2 -1 0 0 h(age-2) 0 0 1 0 0 $cuts survived sexmale age sibsp parch (Intercept) 0 0 0 0 0 h(age-29) 0 0 29 0 0 h(29-age) 0 0 29 0 0 survived 0 0 0 0 0 survived*h(age-16) 0 0 16 0 0 survived*h(16-age) 0 0 16 0 0 survived*sexmale 0 0 0 0 0 h(parch-2) 0 0 0 0 2 h(2-parch) 0 0 0 0 2 h(sibsp-1) 0 0 0 1 0 h(1-sibsp) 0 0 0 1 0 sexmale 0 0 0 0 0 h(age-47)*h(2-parch) 0 0 47 0 2 h(47-age)*h(2-parch) 0 0 47 0 2 sexmale*h(age-6) 0 0 6 0 0 sexmale*h(6-age) 0 0 6 0 0 h(age-2) 0 0 2 0 0 $selected.terms [1] 1 3 4 6 7 8 10 11 12 14 17 $prune.terms [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [,14] [,15] [,16] [,17] [1,] 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [2,] 1 17 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [3,] 1 4 17 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [4,] 1 4 6 17 0 0 0 0 0 0 0 0 0 0 0 0 0 [5,] 1 3 4 6 17 0 0 0 0 0 0 0 0 0 0 0 0 [6,] 1 3 4 6 7 17 0 0 0 0 0 0 0 0 0 0 0 [7,] 1 3 4 6 7 12 17 0 0 0 0 0 0 0 0 0 0 [8,] 1 3 4 6 7 11 12 17 0 0 0 0 0 0 0 0 0 [9,] 1 3 4 6 7 8 11 12 17 0 0 0 0 0 0 0 0 [10,] 1 3 4 6 7 8 10 11 12 17 0 0 0 0 0 0 0 [11,] 1 3 4 6 7 8 10 11 12 14 17 0 0 0 0 0 0 [12,] 1 3 4 6 7 8 10 11 12 14 16 17 0 0 0 0 0 [13,] 1 2 3 4 6 7 8 10 11 12 14 16 17 0 0 0 0 [14,] 1 2 3 4 5 6 7 8 10 11 12 14 16 17 0 0 0 [15,] 1 2 3 4 5 6 7 8 10 11 12 13 14 16 17 0 0 [16,] 1 2 3 4 5 6 7 8 10 11 12 13 14 15 16 17 0 [17,] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 $coefficients 1st 2nd 3rd (Intercept) -0.113016046 0.4410080356 0.672008011 h(29-age) 0.011622146 -0.0148601744 0.003238028 survived 0.345324535 0.1352434703 -0.480568006 survived*h(16-age) -0.027367652 0.0315510492 -0.004183397 survived*sexmale -0.077747515 -0.2922811680 0.370028683 h(parch-2) -0.119815977 -0.0781102278 0.197926205 h(sibsp-1) -0.062328534 -0.0567608107 0.119089344 h(1-sibsp) -0.101051958 -0.0554014556 0.156453413 sexmale 0.097154715 0.1204541292 -0.217608845 h(47-age)*h(2-parch) -0.003545525 -0.0007925215 0.004338047 h(age-2) 0.011747870 -0.0056509080 -0.006096962 $rss.per.response [1] 147.1903 184.3632 188.2813 $rsq.per.response [1] 0.28856098 0.05877016 0.27871887 $gcv.per.response [1] 0.1479826 0.1853555 0.1892947 $grsq.per.response [1] 0.25325913 0.01206601 0.24292866 $rss.per.subset [1] 633.3315 596.1670 569.4424 565.3467 557.0527 550.2290 546.1448 542.4382 538.9851 536.7700 533.1367 531.9897 529.6179 527.8453 526.6263 526.1890 525.9617 $gcv.per.subset [1] 0.6066389 0.5737828 0.5506997 0.5493768 0.5439353 0.5398772 0.5384744 0.5374256 0.5366124 0.5370235 0.5360063 0.5374847 0.5377276 0.5385776 0.5399971 0.5422297 0.5446954 $leverages [1] 0.006002461 0.035827364 0.051251220 0.012281000 0.019501236 0.010962447 0.014953775 0.002968149 0.011387011 0.019294018 0.006770236 0.009780826 0.005274689 0.005250452 0.039828386 0.004551448 [17] 0.006894687 0.005296968 0.002901891 0.011878516 0.006923105 0.009168370 0.005114749 0.006002461 0.002835936 0.012099613 0.009080508 0.004891856 0.009499543 0.004001812 0.009142857 0.005733921 [33] 0.010553112 0.003334789 0.005710911 0.006190463 0.003179200 0.004700629 0.005478815 0.015386827 0.011923751 0.004982780 0.004001812 0.009453116 0.007924572 0.009885054 0.010553112 0.003136014 [49] 0.003487892 0.005722454 0.020967062 0.017334577 0.013898889 0.008174102 0.004833488 0.005797173 0.030074907 0.006514897 0.006923105 0.012210651 0.006716234 0.004823571 0.005733921 0.010168823 [65] 0.006540548 0.007121503 0.005719385 0.004613372 0.006293117 0.006517780 0.015212268 0.012537870 0.020291992 0.007515345 0.015843319 0.005662045 0.006039161 0.011684887 0.009281399 0.005128555 [81] 0.006689904 0.011831765 0.012183884 0.010586260 0.014099619 0.029272500 0.009000020 0.007165845 0.007349052 0.007082997 0.007082997 0.012866704 0.002968149 0.005985869 0.004787127 0.009000020 [97] 0.013389251 0.008922849 0.003670520 0.015960834 0.018934807 0.015497928 0.013573014 0.047464806 0.046277288 0.005733921 0.015111236 0.011637851 0.013529926 0.018012946 0.007082997 0.005718755 [113] 0.006345278 0.004613372 0.004891856 0.006190463 0.005878616 0.002828848 0.012866704 0.019294018 0.012394530 0.007174794 0.003951379 0.010553112 0.010614844 0.005878616 0.004290904 0.012099613 [129] 0.007086016 0.012672483 0.007288493 0.006292933 0.006345278 0.003056987 0.009281399 0.005274689 0.008737260 0.008178600 0.003334789 0.006588313 0.009469425 0.005723058 0.007836294 0.005827298 [145] 0.006345278 0.008951286 0.011281289 0.006345278 0.004787127 0.015644348 0.011157657 0.004290904 0.005011951 0.003204239 0.008081369 0.005738838 0.011499787 0.006493042 0.004818969 0.006642599 [161] 0.005733921 0.008951286 0.003334789 0.008839179 0.009469425 0.007192379 0.003915441 0.006099407 0.003670520 0.010553112 0.008493156 0.003670520 0.009576240 0.007784838 0.009780826 0.005274689 [177] 0.004290904 0.006181834 0.008922849 0.006858030 0.013161281 0.007254676 0.006716234 0.006107824 0.012446330 0.006588313 0.004613372 0.004020324 0.007220694 0.007330386 0.008081369 0.016221626 [193] 0.012298770 0.004818969 0.006190463 0.013161281 0.003688527 0.004142186 0.002926875 0.007280627 0.007610244 0.008413392 0.010586260 0.005733921 0.012016907 0.004613372 0.009364887 0.002912687 [209] 0.003130017 0.005596000 0.003458976 0.010168823 0.005128555 0.004290904 0.002901891 0.005128555 0.008737260 0.009000020 0.003136014 0.016542052 0.012005308 0.010603838 0.018973399 0.013933227 [225] 0.005274689 0.006345278 0.005733921 0.009013099 0.004884186 0.008951286 0.007165845 0.006003874 0.013801019 0.009499543 0.007040395 0.007040395 0.006218793 0.009780826 0.012201766 0.007330386 [241] 0.025158446 0.012166795 0.006272115 0.009685049 0.009236853 0.010710557 0.014521856 0.006196483 0.008178600 0.013476803 0.017160187 0.024056364 0.009984855 0.006436114 0.017343329 0.007657602 [257] 0.006293117 0.012672483 0.006988372 0.024321614 0.006293117 0.009398793 0.003056987 0.009984855 0.004613372 0.004891856 0.014438812 0.012558761 0.009304756 0.006181834 0.005095807 0.008839179 [273] 0.009903162 0.009685049 0.006594607 0.007165845 0.011002825 0.007539592 0.006099407 0.005236017 0.011237893 0.005498756 0.010710557 0.004823571 0.006968578 0.007507824 0.003670520 0.004993737 [289] 0.002835936 0.006054138 0.006209863 0.007538081 0.004993737 0.002926875 0.004823571 0.003487892 0.005236017 0.011954815 0.009080508 0.003487892 0.037557013 0.025433408 0.007441390 0.015445304 [305] 0.009013099 0.007174794 0.002926875 0.002948140 0.003334789 0.003165458 0.005274689 0.018719978 0.011448756 0.006272115 0.008485305 0.006220929 0.004823571 0.002835936 0.003334789 0.005114749 [321] 0.038211874 0.012652651 0.007254577 0.004891856 0.004370134 0.014976113 0.008331771 0.005505686 0.005718755 0.016364775 0.007018206 0.006090277 0.007280627 0.007507824 0.003915441 0.003487892 [337] 0.009257658 0.020171946 0.007734312 0.007487135 0.005719385 0.014242833 0.003438274 0.014413122 0.004993737 0.006436114 0.005646676 0.003280807 0.005722454 0.007280627 0.007155643 0.002835936 [353] 0.004993737 0.007985695 0.005734984 0.006181834 0.022455276 0.006287757 0.006825628 0.007262106 0.007522988 0.002926875 0.003438274 0.004993737 0.005683753 0.007858657 0.004993737 0.002901891 [369] 0.013371729 0.002946556 0.005673712 0.006054138 0.004993518 0.006556287 0.002948140 0.004613372 0.006843074 0.006843074 0.002828848 0.002828848 0.003024597 0.003670520 0.005505686 0.003670520 [385] 0.034695855 0.012296634 0.003746095 0.017166611 0.005193233 0.017845285 0.003670520 0.021790254 0.006327252 0.006594607 0.012656379 0.012656379 0.006988372 0.007082997 0.008839179 0.007932078 [401] 0.009018732 0.007826285 0.014729542 0.006742030 0.005853178 0.002901891 0.016077964 0.005011951 0.006104346 0.007858657 0.003438274 0.009453116 0.013622893 0.021581443 0.003136014 0.008670643 [417] 0.005827298 0.007289717 0.004613372 0.007932078 0.007756434 0.003280807 0.005444479 0.006054138 0.007155643 0.012650271 0.002946556 0.005710911 0.007538081 0.003458976 0.014788334 0.008036818 [433] 0.035350755 0.029029057 0.013543596 0.013767296 0.008670643 0.004993518 0.002901891 0.002828848 0.009984855 0.007165845 0.006098267 0.018872307 0.037688759 0.007734312 0.006999311 0.003670520 [449] 0.003056987 0.003280807 0.003670520 0.004290904 0.007704611 0.005427384 0.011320394 0.002968149 0.004700629 0.018157887 0.003165458 0.006181834 0.002968149 0.006556287 0.010710557 0.006334473 [465] 0.011555948 0.029171164 0.025741497 0.006450479 0.002948140 0.008435891 0.003487892 0.010697616 0.006002461 0.002968149 0.009767407 0.002926875 0.009822802 0.003487892 0.006894687 0.004370134 [481] 0.003179200 0.006492743 0.007174794 0.004034152 0.005296968 0.003024597 0.009594110 0.003165458 0.029633453 0.012063542 0.008811226 0.002901891 0.006054138 0.023960939 0.005646676 0.002926875 [497] 0.033958263 0.025741497 0.017519387 0.006894687 0.004370134 0.006099407 0.002948140 0.002835936 0.003165458 0.005869738 0.017343329 0.006584543 0.005733921 0.008670261 0.005733921 0.002946556 [513] 0.004884186 0.002835936 0.003179200 0.002835936 0.004668796 0.008539298 0.006894687 0.002926875 0.005646676 0.005396007 0.007280627 0.015320063 0.003056987 0.005498756 0.006968578 0.006321772 [529] 0.005498756 0.012020778 0.004884186 0.005208589 0.006540548 0.007858657 0.029171164 0.022224828 0.011177512 0.035631587 0.023728299 0.008831117 0.009472951 0.014069396 0.009398793 0.005250452 [545] 0.012653736 0.003334789 0.024706479 0.010361179 0.006662125 0.009576240 0.009160457 0.010697616 0.007870161 0.003670520 0.002948140 0.014612155 0.034569833 0.007985695 0.009168370 0.002948140 [561] 0.003851646 0.002828848 0.002835936 0.002946556 0.004993737 0.003280807 0.009080508 0.030220620 0.031552109 0.035565285 0.025650159 0.042474123 0.029720692 0.029060922 0.083075210 0.009281399 [577] 0.002948140 0.082879656 0.003851646 0.002948140 0.006220929 0.015822057 0.002828848 0.002946556 0.029006707 0.025273401 0.048748772 0.023335852 0.041497533 0.082910508 0.009459975 0.084269979 [593] 0.005710911 0.003438274 0.002926875 0.014481125 0.003670520 0.002926875 0.010741765 0.003851646 0.006444606 0.022442288 0.040320229 0.040320229 0.021826416 0.020075239 0.007870161 0.003056987 [609] 0.002948140 0.010697616 0.013771233 0.014512273 0.013447296 0.003130017 0.004370134 0.002948140 0.003130017 0.003851646 0.009236853 0.003438274 0.004993737 0.002948140 0.023128368 0.022136347 [625] 0.006294266 0.015643829 0.003438274 0.005719385 0.013067267 0.007280627 0.006529865 0.003130017 0.002946556 0.013655942 0.010179954 0.004370134 0.013904724 0.012806212 0.014242833 0.004993737 [641] 0.002912687 0.005722454 0.005722454 0.012806212 0.003438274 0.003438274 0.003487892 0.002828848 0.009576240 0.013363802 0.003487892 0.002828848 0.003438274 0.009236853 0.003915441 0.006328181 [657] 0.008413392 0.003851646 0.012048286 0.002828848 0.002901891 0.002828848 0.003458976 0.003458976 0.005719385 0.014242833 0.018720252 0.003523754 0.002946556 0.003165458 0.004370134 0.003670520 [673] 0.013311438 0.025741497 0.007515345 0.008670261 0.004370134 0.008678717 0.004136207 0.005722454 0.003015307 0.010168823 0.012650271 0.004370134 0.005733921 0.009822802 0.055179807 0.006997796 [689] 0.015779887 0.003165458 0.002835936 0.007932078 0.003130017 0.007826285 0.009156841 0.011337027 0.006209863 0.009594110 0.006556287 0.035584380 0.038292263 0.013243242 0.009472951 0.002835936 [705] 0.003130017 0.002901891 0.007174794 0.005722454 0.003334789 0.003523754 0.003280807 0.011320394 0.005733921 0.012653736 0.005444479 0.003136014 0.013161281 0.009257658 0.006321772 0.007610244 [721] 0.004993737 0.006556287 0.004001812 0.005557040 0.009621731 0.011198313 0.004613372 0.033440924 0.003113921 0.003113921 0.004993737 0.002948140 0.016478503 0.025250003 0.012146579 0.027225611 [737] 0.019397290 0.002835936 0.003130017 0.009576240 0.021632773 0.007214801 0.003179200 0.007487135 0.002912687 0.038877974 0.044218896 0.038646977 0.044339532 0.047267188 0.039142243 0.146280684 [753] 0.143638625 0.005236017 0.003280807 0.003851646 0.007699632 0.009544747 0.004370134 0.012653736 0.014481125 0.006858030 0.007155643 0.003851646 0.002864722 0.007245117 0.006328181 0.003438274 [769] 0.006493042 0.002835936 0.012302179 0.009281399 0.013904724 0.005250452 0.012599446 0.005719385 0.003487892 0.013922046 0.031109404 0.007254577 0.003523754 0.003487892 0.005396007 0.003334789 [785] 0.003670520 0.015320063 0.014695811 0.009822802 0.010179954 0.003851646 0.004700629 0.009147061 0.003024597 0.009168370 0.003130017 0.003136014 0.003458976 0.003915441 0.022699828 0.034175947 [801] 0.004833488 0.003136014 0.004370134 0.011288457 0.002926875 0.009236853 0.003165458 0.014974697 0.014708689 0.009236853 0.005722454 0.003438274 0.003670520 0.010179954 0.003136014 0.003130017 [817] 0.023362013 0.009796085 0.004668796 0.002981405 0.003746095 0.016693512 0.008528182 0.028761503 0.024892822 0.007134786 0.035560259 0.008979968 0.015892109 0.009160457 0.013363802 0.005719385 [833] 0.009168370 0.003915441 0.003915441 0.003130017 0.009767407 0.003280807 0.002981405 0.002901891 0.002968149 0.002828848 0.012813141 0.014361743 0.005797173 0.016038567 0.013661531 0.003487892 [849] 0.006968578 0.014955380 0.003631821 0.009281399 0.005236017 0.005444479 0.009236853 0.009257658 0.003130017 0.003915441 0.014125809 0.002946556 0.003136014 0.009519496 0.013448075 0.006218793 [865] 0.015345819 0.006808654 0.010179954 0.002828848 0.003438274 0.003487892 0.002835936 0.017515748 0.006144348 0.003024597 0.005274689 0.004993737 0.003130017 0.009519496 0.038518287 0.013766976 [881] 0.008370119 0.003136014 0.016725599 0.011555948 0.014501912 0.003487892 0.007870161 0.005250452 0.003438274 0.003179200 0.009037791 0.003438274 0.003688527 0.005719385 0.009984855 0.002926875 [897] 0.005719385 0.012538558 0.003487892 0.003960597 0.014017130 0.003487892 0.009236853 0.003851646 0.012599446 0.013067267 0.003851646 0.006556287 0.005498756 0.021182057 0.016237912 0.024244458 [913] 0.019844552 0.047325640 0.030148806 0.024451477 0.028576241 0.023181093 0.022779602 0.086741370 0.003438274 0.004370134 0.003280807 0.033876713 0.031470066 0.018978832 0.003438274 0.002835936 [929] 0.003130017 0.012099613 0.002828848 0.013922046 0.004370134 0.006220929 0.013904724 0.009236853 0.005722454 0.002828848 0.002912687 0.003438274 0.023148846 0.026633279 0.024451477 0.028576241 [945] 0.023919581 0.086822670 0.012650271 0.002946556 0.007165845 0.015599526 0.033367586 0.008979968 0.014777549 0.005011951 0.006556287 0.002835936 0.002936246 0.137228748 0.002828848 0.006099407 [961] 0.002968149 0.034175947 0.012296634 0.022224828 0.009160457 0.003851646 0.002819253 0.009822802 0.003130017 0.003056987 0.003438274 0.007870161 0.027213914 0.018727215 0.023389223 0.032601680 [977] 0.038647545 0.041465252 0.004370134 0.003670520 0.003280807 0.003136014 0.005444479 0.003438274 0.009639105 0.004370134 0.012650271 0.009398793 0.003165458 0.032859165 0.016422192 0.013819417 [993] 0.009896878 0.002835936 0.022976031 0.013162769 0.002828848 0.009160457 0.003024597 0.036510560 0.010364830 0.003280807 0.003560576 0.003746095 0.009160457 0.015902803 0.010493213 0.011177512 [1009] 0.002901891 0.007870161 0.014321734 0.014897555 0.005157787 0.033963876 0.006649285 0.016134237 0.003136014 0.003487892 0.003487892 0.004613372 0.016994340 0.020267705 0.009752267 0.015745735 [1025] 0.009767407 0.003851646 0.016841019 0.003130017 0.003130017 0.003204239 0.004787127 0.005236017 0.008413392 0.006843074 0.006923105 0.003688527 0.003438274 0.003165458 0.002901891 0.006540548 [1041] 0.011303752 0.004142186 0.018316670 0.003043660 0.003165458 0.003915441 $pmethod [1] "backward" $nprune NULL $penalty [1] 3 $nk [1] 21 $thresh [1] 0.001 $termcond [1] 7 $weights NULL $glm.list $glm.list[[1]] Call: glm(formula = yarg ~ ., family = family, data = bx.data.frame, weights = weights, na.action = na.action, offset = offset, control = control, model = TRUE, method = "glm.fit", x = TRUE, y = TRUE, contrasts = NULL, trace = (trace >= 2)) Coefficients: (Intercept) `h(29-age)` survived `survived*h(16-age)` `survived*sexmale` `h(parch-2)` `h(sibsp-1)` `h(1-sibsp)` -3.32918 0.04057 2.74573 -0.18810 -1.12555 -0.98931 -0.61153 -0.65910 sexmale `h(47-age)*h(2-parch)` `h(age-2)` 1.29673 -0.02890 0.04992 Degrees of Freedom: 1045 Total (i.e. Null); 1035 Residual Null Deviance: 1223 Residual Deviance: 896.4 AIC: 918.4 $glm.list[[2]] Call: glm(formula = yarg ~ ., family = family, data = bx.data.frame, weights = weights, na.action = na.action, offset = offset, control = control, model = TRUE, method = "glm.fit", x = TRUE, y = TRUE, contrasts = NULL, trace = (trace >= 2)) Coefficients: (Intercept) `h(29-age)` survived `survived*h(16-age)` `survived*sexmale` `h(parch-2)` `h(sibsp-1)` `h(1-sibsp)` -0.21325 -0.09796 0.96232 0.19060 -1.91593 -0.68928 -0.59417 -0.32445 sexmale `h(47-age)*h(2-parch)` `h(age-2)` 0.88217 -0.00291 -0.03282 Degrees of Freedom: 1045 Total (i.e. Null); 1035 Residual Null Deviance: 1175 Residual Deviance: 1105 AIC: 1127 $glm.list[[3]] Call: glm(formula = yarg ~ ., family = family, data = bx.data.frame, weights = weights, na.action = na.action, offset = offset, control = control, model = TRUE, method = "glm.fit", x = TRUE, y = TRUE, contrasts = NULL, trace = (trace >= 2)) Coefficients: (Intercept) `h(29-age)` survived `survived*h(16-age)` `survived*sexmale` `h(parch-2)` `h(sibsp-1)` `h(1-sibsp)` 1.20532 0.01758 -2.77178 -0.03041 2.21593 1.37568 0.88281 0.95230 sexmale `h(47-age)*h(2-parch)` `h(age-2)` -1.35667 0.01997 -0.03730 Degrees of Freedom: 1045 Total (i.e. Null); 1035 Residual Null Deviance: 1448 Residual Deviance: 1105 AIC: 1127 $glm.coefficients 1st 2nd 3rd (Intercept) -3.32917533 -0.213249115 1.20532422 h(29-age) 0.04056586 -0.097955585 0.01758322 survived 2.74572515 0.962322290 -2.77177950 survived*h(16-age) -0.18809586 0.190600501 -0.03040525 survived*sexmale -1.12555087 -1.915927955 2.21593299 h(parch-2) -0.98931388 -0.689275554 1.37568290 h(sibsp-1) -0.61152656 -0.594165499 0.88280794 h(1-sibsp) -0.65909908 -0.324448645 0.95229902 sexmale 1.29672890 0.882170836 -1.35666727 h(47-age)*h(2-parch) -0.02889869 -0.002910489 0.01997497 h(age-2) 0.04991720 -0.032816163 -0.03729641 $glm.stats nulldev df dev df devratio AIC iters converged 1st 1223.308 1045 896.399 1035 0.26723386 918.399 5 1 2nd 1175.305 1045 1104.929 1035 0.05987931 1126.929 5 1 3rd 1448.212 1045 1104.910 1035 0.23705247 1126.910 5 1 $call earth(formula = pclass ~ ., data = etitanic, wp = c(1, 3, 1), trace = 0.5, glm = list(family = "binomial"), degree = 2, nfold = 3) $namesx.org [1] "survived" "sex" "age" "sibsp" "parch" $namesx [1] "survived" "sex" "age" "sibsp" "parch" $terms pclass ~ survived + sex + age + sibsp + parch attr(,"variables") list(pclass, survived, sex, age, sibsp, parch) attr(,"factors") survived sex age sibsp parch pclass 0 0 0 0 0 survived 1 0 0 0 0 sex 0 1 0 0 0 age 0 0 1 0 0 sibsp 0 0 0 1 0 parch 0 0 0 0 1 attr(,"term.labels") [1] "survived" "sex" "age" "sibsp" "parch" attr(,"order") [1] 1 1 1 1 1 attr(,"intercept") [1] 1 attr(,"response") [1] 1 attr(,".Environment") attr(,"predvars") list(pclass, survived, sex, age, sibsp, parch) attr(,"dataClasses") pclass survived sex age sibsp parch "factor" "numeric" "factor" "numeric" "numeric" "numeric" $xlevels $xlevels$sex [1] "female" "male" $levels [1] "1st" "2nd" "3rd" $wp [1] 1 3 1 $cv.list $cv.list$fold1 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 814.669 696 604.667 687 0.258 624.7 6 1 2nd 783.345 696 730.043 687 0.068 750.0 5 1 3rd 965.040 696 737.981 687 0.235 758.0 6 1 Earth selected 10 of 17 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Number of terms at each degree of interaction: 1 6 3 Earth GCV RSS GRSq RSq 1st 0.1523284 99.13414 0.231447047 0.28033478 2nd 0.1869040 121.63570 0.005084503 0.06837118 3rd 0.1946994 126.70891 0.222088658 0.27157168 All 0.5446439 354.45010 0.103080543 0.16013368 $cv.list$fold2 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 814.669 696 620.925 689 0.2380 636.9 6 1 2nd 783.345 696 744.262 689 0.0499 760.3 5 1 3rd 965.040 696 743.207 689 0.2300 759.2 5 1 Earth selected 8 of 17 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Number of terms at each degree of interaction: 1 5 2 Earth GCV RSS GRSq RSq 1st 0.1544711 102.0268 0.220636204 0.25933563 2nd 0.1883822 124.4247 -0.002783902 0.04700948 3rd 0.1932034 127.6091 0.228066207 0.26639670 All 0.5476926 361.7461 0.098060018 0.14284599 $cv.list$fold3 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1st 817.276 697 580.542 689 0.2900 598.5 6 1 2nd 783.919 697 741.103 689 0.0546 759.1 5 1 3rd 966.344 697 736.450 689 0.2380 754.4 5 1 Earth selected 9 of 18 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Number of terms at each degree of interaction: 1 4 4 Earth GCV RSS GRSq RSq 1st 0.1458373 95.7614 0.265964937 0.30748595 2nd 0.1879762 123.4312 -0.001585256 0.05506986 3rd 0.1916078 125.8158 0.234348815 0.27765821 All 0.5408243 355.1224 0.109287820 0.15967135 $cv.nterms.selected.by.gcv fold1 fold2 fold3 mean 10 8 9 9 $cv.nvars.selected.by.gcv fold1 fold2 fold3 mean 5 5 5 5 $cv.groups cross fold [1,] 1 3 [2,] 1 2 [3,] 1 2 [4,] 1 3 [5,] 1 3 [6,] 1 1 [7,] 1 1 [8,] 1 1 [9,] 1 3 [10,] 1 1 [11,] 1 2 [12,] 1 1 [13,] 1 2 [14,] 1 3 [15,] 1 3 [16,] 1 2 [17,] 1 2 [18,] 1 2 [19,] 1 3 [20,] 1 3 [21,] 1 3 [22,] 1 3 [23,] 1 2 [24,] 1 3 [25,] 1 1 [26,] 1 2 [27,] 1 1 [28,] 1 1 [29,] 1 1 [30,] 1 2 [31,] 1 1 [32,] 1 2 [33,] 1 2 [34,] 1 1 [35,] 1 2 [36,] 1 2 [37,] 1 1 [38,] 1 2 [39,] 1 2 [40,] 1 1 [41,] 1 2 [42,] 1 1 [43,] 1 3 [44,] 1 2 [45,] 1 2 [46,] 1 1 [47,] 1 1 [48,] 1 3 [49,] 1 3 [50,] 1 1 [51,] 1 1 [52,] 1 2 [53,] 1 2 [54,] 1 3 [55,] 1 1 [56,] 1 2 [57,] 1 2 [58,] 1 1 [59,] 1 1 [60,] 1 2 [61,] 1 2 [62,] 1 3 [63,] 1 3 [64,] 1 2 [65,] 1 3 [66,] 1 3 [67,] 1 3 [68,] 1 1 [69,] 1 1 [70,] 1 1 [71,] 1 2 [72,] 1 3 [73,] 1 2 [74,] 1 3 [75,] 1 1 [76,] 1 1 [77,] 1 3 [78,] 1 2 [79,] 1 3 [80,] 1 3 [81,] 1 2 [82,] 1 3 [83,] 1 2 [84,] 1 1 [85,] 1 2 [86,] 1 3 [87,] 1 3 [88,] 1 1 [89,] 1 3 [90,] 1 2 [91,] 1 3 [92,] 1 3 [93,] 1 3 [94,] 1 2 [95,] 1 1 [96,] 1 2 [97,] 1 3 [98,] 1 1 [99,] 1 1 [100,] 1 2 [101,] 1 3 [102,] 1 2 [103,] 1 2 [104,] 1 1 [105,] 1 1 [106,] 1 3 [107,] 1 1 [108,] 1 3 [109,] 1 2 [110,] 1 3 [111,] 1 3 [112,] 1 2 [113,] 1 3 [114,] 1 1 [115,] 1 2 [116,] 1 1 [117,] 1 1 [118,] 1 3 [119,] 1 2 [120,] 1 2 [121,] 1 1 [122,] 1 1 [123,] 1 1 [124,] 1 1 [125,] 1 2 [126,] 1 3 [127,] 1 1 [128,] 1 3 [129,] 1 3 [130,] 1 1 [131,] 1 3 [132,] 1 2 [133,] 1 3 [134,] 1 2 [135,] 1 2 [136,] 1 3 [137,] 1 2 [138,] 1 1 [139,] 1 1 [140,] 1 3 [141,] 1 3 [142,] 1 1 [143,] 1 1 [144,] 1 2 [145,] 1 2 [146,] 1 3 [147,] 1 1 [148,] 1 2 [149,] 1 2 [150,] 1 3 [151,] 1 3 [152,] 1 1 [153,] 1 3 [154,] 1 3 [155,] 1 2 [156,] 1 2 [157,] 1 2 [158,] 1 3 [159,] 1 3 [160,] 1 1 [161,] 1 1 [162,] 1 2 [163,] 1 2 [164,] 1 1 [165,] 1 3 [166,] 1 3 [167,] 1 3 [168,] 1 3 [169,] 1 1 [170,] 1 2 [171,] 1 2 [172,] 1 1 [173,] 1 1 [174,] 1 2 [175,] 1 1 [176,] 1 2 [177,] 1 2 [178,] 1 3 [179,] 1 2 [180,] 1 1 [181,] 1 2 [182,] 1 3 [183,] 1 2 [184,] 1 3 [185,] 1 1 [186,] 1 2 [187,] 1 1 [188,] 1 2 [189,] 1 3 [190,] 1 3 [191,] 1 3 [192,] 1 1 [193,] 1 2 [194,] 1 3 [195,] 1 2 [196,] 1 2 [197,] 1 1 [198,] 1 1 [199,] 1 1 [200,] 1 2 [201,] 1 3 [202,] 1 2 [203,] 1 2 [204,] 1 2 [205,] 1 3 [206,] 1 3 [207,] 1 1 [208,] 1 1 [209,] 1 1 [210,] 1 1 [211,] 1 2 [212,] 1 3 [213,] 1 2 [214,] 1 1 [215,] 1 3 [216,] 1 1 [217,] 1 1 [218,] 1 1 [219,] 1 3 [220,] 1 1 [221,] 1 3 [222,] 1 2 [223,] 1 3 [224,] 1 2 [225,] 1 2 [226,] 1 2 [227,] 1 3 [228,] 1 3 [229,] 1 3 [230,] 1 2 [231,] 1 1 [232,] 1 2 [233,] 1 2 [234,] 1 2 [235,] 1 1 [236,] 1 1 [237,] 1 3 [238,] 1 2 [239,] 1 3 [240,] 1 3 [241,] 1 1 [242,] 1 1 [243,] 1 1 [244,] 1 1 [245,] 1 1 [246,] 1 3 [247,] 1 3 [248,] 1 3 [249,] 1 2 [250,] 1 1 [251,] 1 1 [252,] 1 1 [253,] 1 2 [254,] 1 3 [255,] 1 1 [256,] 1 3 [257,] 1 2 [258,] 1 2 [259,] 1 2 [260,] 1 1 [261,] 1 1 [262,] 1 1 [263,] 1 2 [264,] 1 1 [265,] 1 1 [266,] 1 3 [267,] 1 1 [268,] 1 3 [269,] 1 3 [270,] 1 3 [271,] 1 2 [272,] 1 1 [273,] 1 3 [274,] 1 1 [275,] 1 3 [276,] 1 1 [277,] 1 1 [278,] 1 1 [279,] 1 2 [280,] 1 3 [281,] 1 2 [282,] 1 3 [283,] 1 3 [284,] 1 2 [285,] 1 3 [286,] 1 2 [287,] 1 1 [288,] 1 1 [289,] 1 3 [290,] 1 2 [291,] 1 2 [292,] 1 2 [293,] 1 3 [294,] 1 2 [295,] 1 3 [296,] 1 3 [297,] 1 1 [298,] 1 3 [299,] 1 2 [300,] 1 3 [301,] 1 1 [302,] 1 3 [303,] 1 2 [304,] 1 1 [305,] 1 2 [306,] 1 2 [307,] 1 2 [308,] 1 3 [309,] 1 1 [310,] 1 3 [311,] 1 3 [312,] 1 2 [313,] 1 2 [314,] 1 2 [315,] 1 1 [316,] 1 2 [317,] 1 1 [318,] 1 1 [319,] 1 2 [320,] 1 3 [321,] 1 3 [322,] 1 3 [323,] 1 3 [324,] 1 1 [325,] 1 2 [326,] 1 3 [327,] 1 1 [328,] 1 3 [329,] 1 1 [330,] 1 3 [331,] 1 1 [332,] 1 2 [333,] 1 1 [334,] 1 3 [335,] 1 3 [336,] 1 3 [337,] 1 2 [338,] 1 3 [339,] 1 1 [340,] 1 2 [341,] 1 2 [342,] 1 2 [343,] 1 2 [344,] 1 2 [345,] 1 3 [346,] 1 1 [347,] 1 1 [348,] 1 3 [349,] 1 1 [350,] 1 3 [351,] 1 3 [352,] 1 2 [353,] 1 1 [354,] 1 2 [355,] 1 3 [356,] 1 2 [357,] 1 2 [358,] 1 1 [359,] 1 3 [360,] 1 1 [361,] 1 3 [362,] 1 2 [363,] 1 2 [364,] 1 3 [365,] 1 3 [366,] 1 2 [367,] 1 3 [368,] 1 3 [369,] 1 1 [370,] 1 2 [371,] 1 1 [372,] 1 2 [373,] 1 2 [374,] 1 2 [375,] 1 1 [376,] 1 2 [377,] 1 1 [378,] 1 1 [379,] 1 1 [380,] 1 2 [381,] 1 3 [382,] 1 1 [383,] 1 1 [384,] 1 2 [385,] 1 1 [386,] 1 3 [387,] 1 3 [388,] 1 3 [389,] 1 2 [390,] 1 3 [391,] 1 2 [392,] 1 2 [393,] 1 1 [394,] 1 1 [395,] 1 1 [396,] 1 2 [397,] 1 1 [398,] 1 3 [399,] 1 2 [400,] 1 3 [401,] 1 3 [402,] 1 2 [403,] 1 1 [404,] 1 1 [405,] 1 3 [406,] 1 2 [407,] 1 3 [408,] 1 3 [409,] 1 2 [410,] 1 2 [411,] 1 2 [412,] 1 2 [413,] 1 3 [414,] 1 2 [415,] 1 2 [416,] 1 1 [417,] 1 1 [418,] 1 3 [419,] 1 3 [420,] 1 2 [421,] 1 1 [422,] 1 2 [423,] 1 1 [424,] 1 1 [425,] 1 3 [426,] 1 3 [427,] 1 2 [428,] 1 3 [429,] 1 3 [430,] 1 2 [431,] 1 2 [432,] 1 3 [433,] 1 3 [434,] 1 3 [435,] 1 1 [436,] 1 1 [437,] 1 3 [438,] 1 1 [439,] 1 3 [440,] 1 2 [441,] 1 1 [442,] 1 3 [443,] 1 1 [444,] 1 1 [445,] 1 1 [446,] 1 3 [447,] 1 2 [448,] 1 1 [449,] 1 2 [450,] 1 3 [451,] 1 1 [452,] 1 1 [453,] 1 2 [454,] 1 3 [455,] 1 1 [456,] 1 3 [457,] 1 3 [458,] 1 2 [459,] 1 1 [460,] 1 3 [461,] 1 1 [462,] 1 1 [463,] 1 2 [464,] 1 3 [465,] 1 1 [466,] 1 1 [467,] 1 3 [468,] 1 2 [469,] 1 3 [470,] 1 2 [471,] 1 3 [472,] 1 1 [473,] 1 1 [474,] 1 2 [475,] 1 3 [476,] 1 2 [477,] 1 2 [478,] 1 1 [479,] 1 1 [480,] 1 1 [481,] 1 2 [482,] 1 1 [483,] 1 3 [484,] 1 1 [485,] 1 3 [486,] 1 3 [487,] 1 3 [488,] 1 2 [489,] 1 2 [490,] 1 1 [491,] 1 3 [492,] 1 2 [493,] 1 3 [494,] 1 2 [495,] 1 2 [496,] 1 2 [497,] 1 1 [498,] 1 2 [499,] 1 3 [500,] 1 1 [501,] 1 2 [502,] 1 1 [503,] 1 2 [504,] 1 1 [505,] 1 2 [506,] 1 3 [507,] 1 1 [508,] 1 1 [509,] 1 1 [510,] 1 1 [511,] 1 1 [512,] 1 2 [513,] 1 3 [514,] 1 1 [515,] 1 1 [516,] 1 3 [517,] 1 3 [518,] 1 1 [519,] 1 1 [520,] 1 2 [521,] 1 1 [522,] 1 2 [523,] 1 3 [524,] 1 1 [525,] 1 1 [526,] 1 3 [527,] 1 2 [528,] 1 2 [529,] 1 1 [530,] 1 1 [531,] 1 3 [532,] 1 2 [533,] 1 3 [534,] 1 1 [535,] 1 3 [536,] 1 2 [537,] 1 3 [538,] 1 2 [539,] 1 3 [540,] 1 1 [541,] 1 3 [542,] 1 1 [543,] 1 2 [544,] 1 2 [545,] 1 1 [546,] 1 2 [547,] 1 1 [548,] 1 3 [549,] 1 1 [550,] 1 2 [551,] 1 3 [552,] 1 2 [553,] 1 3 [554,] 1 1 [555,] 1 1 [556,] 1 1 [557,] 1 2 [558,] 1 2 [559,] 1 2 [560,] 1 2 [561,] 1 1 [562,] 1 1 [563,] 1 2 [564,] 1 3 [565,] 1 1 [566,] 1 1 [567,] 1 1 [568,] 1 2 [569,] 1 2 [570,] 1 1 [571,] 1 1 [572,] 1 1 [573,] 1 2 [574,] 1 1 [575,] 1 3 [576,] 1 1 [577,] 1 3 [578,] 1 3 [579,] 1 3 [580,] 1 2 [581,] 1 3 [582,] 1 2 [583,] 1 2 [584,] 1 3 [585,] 1 3 [586,] 1 3 [587,] 1 1 [588,] 1 1 [589,] 1 2 [590,] 1 3 [591,] 1 3 [592,] 1 3 [593,] 1 3 [594,] 1 2 [595,] 1 1 [596,] 1 2 [597,] 1 1 [598,] 1 3 [599,] 1 2 [600,] 1 3 [601,] 1 2 [602,] 1 3 [603,] 1 1 [604,] 1 3 [605,] 1 3 [606,] 1 1 [607,] 1 2 [608,] 1 3 [609,] 1 1 [610,] 1 3 [611,] 1 1 [612,] 1 2 [613,] 1 2 [614,] 1 1 [615,] 1 1 [616,] 1 3 [617,] 1 3 [618,] 1 3 [619,] 1 3 [620,] 1 3 [621,] 1 2 [622,] 1 1 [623,] 1 3 [624,] 1 1 [625,] 1 3 [626,] 1 3 [627,] 1 3 [628,] 1 3 [629,] 1 3 [630,] 1 1 [631,] 1 1 [632,] 1 1 [633,] 1 3 [634,] 1 2 [635,] 1 2 [636,] 1 1 [637,] 1 3 [638,] 1 2 [639,] 1 2 [640,] 1 1 [641,] 1 2 [642,] 1 1 [643,] 1 2 [644,] 1 1 [645,] 1 2 [646,] 1 3 [647,] 1 3 [648,] 1 1 [649,] 1 2 [650,] 1 2 [651,] 1 1 [652,] 1 1 [653,] 1 3 [654,] 1 2 [655,] 1 3 [656,] 1 1 [657,] 1 2 [658,] 1 3 [659,] 1 1 [660,] 1 2 [661,] 1 3 [662,] 1 2 [663,] 1 3 [664,] 1 2 [665,] 1 1 [666,] 1 1 [667,] 1 2 [668,] 1 2 [669,] 1 3 [670,] 1 3 [671,] 1 1 [672,] 1 1 [673,] 1 2 [674,] 1 1 [675,] 1 1 [676,] 1 1 [677,] 1 1 [678,] 1 2 [679,] 1 3 [680,] 1 1 [681,] 1 2 [682,] 1 1 [683,] 1 3 [684,] 1 2 [685,] 1 1 [686,] 1 3 [687,] 1 2 [688,] 1 3 [689,] 1 3 [690,] 1 3 [691,] 1 2 [692,] 1 3 [693,] 1 3 [694,] 1 2 [695,] 1 2 [696,] 1 1 [697,] 1 1 [698,] 1 2 [699,] 1 2 [700,] 1 2 [701,] 1 3 [702,] 1 2 [703,] 1 1 [704,] 1 2 [705,] 1 1 [706,] 1 1 [707,] 1 1 [708,] 1 1 [709,] 1 2 [710,] 1 1 [711,] 1 1 [712,] 1 1 [713,] 1 1 [714,] 1 3 [715,] 1 2 [716,] 1 1 [717,] 1 3 [718,] 1 1 [719,] 1 2 [720,] 1 3 [721,] 1 3 [722,] 1 1 [723,] 1 3 [724,] 1 3 [725,] 1 3 [726,] 1 3 [727,] 1 1 [728,] 1 2 [729,] 1 3 [730,] 1 2 [731,] 1 1 [732,] 1 3 [733,] 1 2 [734,] 1 3 [735,] 1 3 [736,] 1 2 [737,] 1 1 [738,] 1 1 [739,] 1 3 [740,] 1 2 [741,] 1 2 [742,] 1 1 [743,] 1 2 [744,] 1 2 [745,] 1 1 [746,] 1 1 [747,] 1 2 [748,] 1 1 [749,] 1 3 [750,] 1 2 [751,] 1 1 [752,] 1 3 [753,] 1 1 [754,] 1 3 [755,] 1 2 [756,] 1 1 [757,] 1 3 [758,] 1 3 [759,] 1 3 [760,] 1 1 [761,] 1 2 [762,] 1 3 [763,] 1 2 [764,] 1 1 [765,] 1 1 [766,] 1 3 [767,] 1 3 [768,] 1 2 [769,] 1 1 [770,] 1 1 [771,] 1 3 [772,] 1 2 [773,] 1 1 [774,] 1 3 [775,] 1 3 [776,] 1 3 [777,] 1 2 [778,] 1 1 [779,] 1 3 [780,] 1 3 [781,] 1 2 [782,] 1 1 [783,] 1 2 [784,] 1 3 [785,] 1 3 [786,] 1 1 [787,] 1 1 [788,] 1 3 [789,] 1 2 [790,] 1 3 [791,] 1 3 [792,] 1 1 [793,] 1 3 [794,] 1 1 [795,] 1 3 [796,] 1 3 [797,] 1 1 [798,] 1 3 [799,] 1 2 [800,] 1 3 [801,] 1 3 [802,] 1 1 [803,] 1 1 [804,] 1 1 [805,] 1 2 [806,] 1 2 [807,] 1 3 [808,] 1 2 [809,] 1 1 [810,] 1 3 [811,] 1 3 [812,] 1 3 [813,] 1 1 [814,] 1 1 [815,] 1 2 [816,] 1 1 [817,] 1 1 [818,] 1 3 [819,] 1 2 [820,] 1 1 [821,] 1 2 [822,] 1 2 [823,] 1 1 [824,] 1 1 [825,] 1 1 [826,] 1 2 [827,] 1 1 [828,] 1 2 [829,] 1 2 [830,] 1 3 [831,] 1 2 [832,] 1 3 [833,] 1 2 [834,] 1 1 [835,] 1 2 [836,] 1 2 [837,] 1 1 [838,] 1 1 [839,] 1 2 [840,] 1 2 [841,] 1 1 [842,] 1 2 [843,] 1 1 [844,] 1 2 [845,] 1 3 [846,] 1 2 [847,] 1 2 [848,] 1 1 [849,] 1 1 [850,] 1 2 [851,] 1 1 [852,] 1 3 [853,] 1 3 [854,] 1 3 [855,] 1 3 [856,] 1 3 [857,] 1 1 [858,] 1 1 [859,] 1 2 [860,] 1 3 [861,] 1 3 [862,] 1 1 [863,] 1 1 [864,] 1 2 [865,] 1 3 [866,] 1 2 [867,] 1 3 [868,] 1 2 [869,] 1 2 [870,] 1 2 [871,] 1 2 [872,] 1 1 [873,] 1 3 [874,] 1 3 [875,] 1 1 [876,] 1 3 [877,] 1 3 [878,] 1 2 [879,] 1 3 [880,] 1 1 [881,] 1 1 [882,] 1 1 [883,] 1 1 [884,] 1 2 [885,] 1 2 [886,] 1 2 [887,] 1 1 [888,] 1 2 [889,] 1 3 [890,] 1 1 [891,] 1 2 [892,] 1 3 [893,] 1 3 [894,] 1 2 [895,] 1 3 [896,] 1 1 [897,] 1 1 [898,] 1 1 [899,] 1 2 [900,] 1 1 [901,] 1 1 [902,] 1 3 [903,] 1 3 [904,] 1 2 [905,] 1 2 [906,] 1 2 [907,] 1 2 [908,] 1 2 [909,] 1 3 [910,] 1 2 [911,] 1 1 [912,] 1 3 [913,] 1 2 [914,] 1 3 [915,] 1 2 [916,] 1 3 [917,] 1 3 [918,] 1 2 [919,] 1 3 [920,] 1 2 [921,] 1 2 [922,] 1 1 [923,] 1 2 [924,] 1 2 [925,] 1 2 [926,] 1 1 [927,] 1 2 [928,] 1 2 [929,] 1 1 [930,] 1 2 [931,] 1 1 [932,] 1 3 [933,] 1 3 [934,] 1 2 [935,] 1 1 [936,] 1 3 [937,] 1 2 [938,] 1 2 [939,] 1 3 [940,] 1 3 [941,] 1 3 [942,] 1 1 [943,] 1 1 [944,] 1 1 [945,] 1 3 [946,] 1 1 [947,] 1 2 [948,] 1 1 [949,] 1 3 [950,] 1 1 [951,] 1 2 [952,] 1 1 [953,] 1 3 [954,] 1 2 [955,] 1 3 [956,] 1 3 [957,] 1 3 [958,] 1 3 [959,] 1 3 [960,] 1 1 [961,] 1 1 [962,] 1 2 [963,] 1 3 [964,] 1 3 [965,] 1 2 [966,] 1 2 [967,] 1 3 [968,] 1 2 [969,] 1 1 [970,] 1 1 [971,] 1 1 [972,] 1 3 [973,] 1 3 [974,] 1 2 [975,] 1 2 [976,] 1 2 [977,] 1 2 [978,] 1 1 [979,] 1 1 [980,] 1 2 [981,] 1 2 [982,] 1 3 [983,] 1 3 [984,] 1 1 [985,] 1 2 [986,] 1 1 [987,] 1 1 [988,] 1 1 [989,] 1 3 [990,] 1 3 [991,] 1 3 [992,] 1 3 [993,] 1 2 [994,] 1 1 [995,] 1 3 [996,] 1 3 [997,] 1 1 [998,] 1 2 [999,] 1 3 [1000,] 1 1 [1001,] 1 3 [1002,] 1 1 [1003,] 1 2 [1004,] 1 2 [1005,] 1 2 [1006,] 1 3 [1007,] 1 3 [1008,] 1 2 [1009,] 1 2 [1010,] 1 2 [1011,] 1 2 [1012,] 1 2 [1013,] 1 2 [1014,] 1 3 [1015,] 1 3 [1016,] 1 2 [1017,] 1 3 [1018,] 1 1 [1019,] 1 1 [1020,] 1 1 [1021,] 1 2 [1022,] 1 1 [1023,] 1 2 [1024,] 1 3 [1025,] 1 1 [1026,] 1 1 [1027,] 1 2 [1028,] 1 3 [1029,] 1 2 [1030,] 1 2 [1031,] 1 3 [1032,] 1 3 [1033,] 1 1 [1034,] 1 2 [1035,] 1 1 [1036,] 1 2 [1037,] 1 1 [1038,] 1 1 [1039,] 1 1 [1040,] 1 2 [1041,] 1 3 [1042,] 1 1 [1043,] 1 2 [1044,] 1 1 [1045,] 1 3 [1046,] 1 2 $cv.rsq.tab 1st 2nd 3rd mean fold1 0.2529497 0.020474012 0.2415051 0.11117536 fold2 0.2738003 -0.009115144 0.2247095 0.09423286 fold3 0.2248287 0.037857049 0.2304014 0.11376024 mean 0.2505262 0.016405306 0.2322053 0.10638949 $cv.maxerr.tab 1st 2nd 3rd max fold1 0.9598727 0.9274252 0.9799994 0.9799994 fold2 0.9684488 0.9182826 0.9741092 0.9741092 fold3 0.9830470 0.9307908 -0.9510353 0.9830470 all 0.9830470 0.9307908 0.9799994 0.9830470 $cv.class.rate.tab 1st 2nd 3rd mean [1,] 0.7478510 0.7421203 0.6962751 0.5931232 [2,] 0.8022923 0.7335244 0.6790831 0.6074499 [3,] 0.7385057 0.7298851 0.7040230 0.5862069 [4,] 0.7628830 0.7351766 0.6931271 0.5955933 $cv.auc.tab 1st 2nd 3rd mean fold1 0.8087029 0.6092173 0.7939889 0.6860688 fold2 0.8247617 0.5603668 0.7741824 0.6560089 fold3 0.7961342 0.6390320 0.7767559 0.6979972 mean 0.8098663 0.6028720 0.7816424 0.6800250 $cv.deviance.tab 1st 2nd 3rd mean fold1 0.9169525 1.104676 1.124027 1.071001 fold2 0.8862685 1.134290 1.131271 1.084082 fold3 0.9391730 1.085408 1.134095 1.065898 mean 0.9141313 1.108125 1.129798 1.073661 $cv.calib.int.tab 1st 2nd 3rd mean fold1 -0.09102156 -0.3947661 -0.053807250 -0.2658254 fold2 0.09053616 -0.6426365 -0.082110016 -0.3838967 fold3 -0.23062302 -0.3489606 0.161302587 -0.2232404 mean -0.07703614 -0.4621210 0.008461773 -0.2909875 $cv.calib.slope.tab 1st 2nd 3rd mean fold1 0.8513094 0.6078727 0.8356980 0.7021251 fold2 1.0036130 0.3987394 0.8942725 0.6188208 fold3 0.8209333 0.7291376 0.8813060 0.7779304 mean 0.8919519 0.5785833 0.8704255 0.6996254 attr(,"class") [1] "earth" ------------------------------------------------------------------------------- > > # poisson models > > counts <- c(18, 17, 15, 20, 10, 20, 25, 13, 12, + 18+2,17+2,15+2,20+2,10+2,20+2,25+2,13+2,12+2, + 18+3,17+3,15+3,20+3,10+3,20+3,25+3,13+3,12+3, + 18+4,17+4,15+4,20+4,10+4,20+4,25+4,13+4,12+4) > counts2 <- c(181,171,151,201,101,201,251,131,121, + 189,179,159,209,109,209,259,139,121, + 185,175,155,205,105,205,255,135,125, + 183,173,153,203,103,203,253,133,123) > outcome <- gl(3,1,4*9) > treatment <- gl(3,4*3) > d.AD <- data.frame(treatment, outcome, counts, counts2) > > # one response poisson model > cat("a8p: one response poisson model\n\n") a8p: one response poisson model > set.seed(1236) > a8p <- earth(counts ~ outcome + treatment, glm=list(family=poisson()), trace=0.5, pmethod="none", nfold=3) Full model GRSq 0.254 RSq 0.556, starting cross validation CV fold 1 CVRSq 0.512 n.oof 24 33% n.infold.nz 24 100% n.oof.nz 12 100% CV fold 2 CVRSq 0.163 n.oof 24 33% n.infold.nz 24 100% n.oof.nz 12 100% CV fold 3 CVRSq -1.743 n.oof 24 33% n.infold.nz 24 100% n.oof.nz 12 100% CV all CVRSq -0.356 n.infold.nz 36 100% > printh(a8p) === a8p GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged 41.6537 35 18.9744 31 0.544 200.2 4 1 Earth selected 5 of 5 terms, and 4 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 5 terms Importance: outcome2, outcome3, treatment3, treatment2 Number of terms at each degree of interaction: 1 4 (additive model) Earth GCV 17.16461 RSS 347.5833 GRSq 0.2538186 RSq 0.5559459 CVRSq -0.3563081 > printh(summary(a8p)) === summary(a8p) Call: earth(formula=counts~outcome+treatment, pmethod="none", trace=0.5, glm=list(family=poisson()), nfold=3) GLM coefficients counts (Intercept) 3.0492313 outcome2 -0.4001032 outcome3 -0.2605737 treatment2 0.1102031 treatment3 0.1733820 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged 41.6537 35 18.9744 31 0.544 200.2 4 1 Earth selected 5 of 5 terms, and 4 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 5 terms Importance: outcome2, outcome3, treatment3, treatment2 Number of terms at each degree of interaction: 1 4 (additive model) Earth GCV 17.16461 RSS 347.5833 GRSq 0.2538186 RSq 0.5559459 CVRSq -0.3563081 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 5.00 sd 0.00 nvars 4.00 sd 0.00 CVRSq sd MaxErr sd cor.tab sd MeanDev sd CalibInt sd CalibSlope sd -0.356 1.21 7.3 7.6 0.638 0.136 1 0.275 -0.003 2.19 0.986 0.73 > print.stripped.earth.model(a8p, "a8p") print.stripped.earth.model(a8p) $rsq [1] 0.5559459 $gcv [1] 17.16461 $grsq [1] 0.2538186 $dirs outcome2 outcome3 treatment2 treatment3 (Intercept) 0 0 0 0 outcome2 2 0 0 0 outcome3 0 2 0 0 treatment3 0 0 0 2 treatment2 0 0 2 0 $cuts outcome2 outcome3 treatment2 treatment3 (Intercept) 0 0 0 0 outcome2 0 0 0 0 outcome3 0 0 0 0 treatment3 0 0 0 0 treatment2 0 0 0 0 $selected.terms [1] 1 2 3 4 5 $prune.terms [,1] [,2] [,3] [,4] [,5] [1,] 1 0 0 0 0 [2,] 1 2 0 0 0 [3,] 1 2 3 0 0 [4,] 1 2 3 4 0 [5,] 1 2 3 4 5 $coefficients counts (Intercept) 21.500000 outcome2 -7.666667 outcome3 -5.333333 treatment3 3.250000 treatment2 2.000000 $rss.per.response [1] 347.5833 $rsq.per.response [1] 0.5559459 $gcv.per.response [1] 17.16461 $grsq.per.response [1] 0.2538186 $rss.per.subset [1] 782.7500 582.7500 412.0833 371.5833 347.5833 $gcv.per.subset [1] 23.00327 19.26446 15.43704 15.90606 17.16461 $leverages [1] 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 [20] 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 0.1388889 $pmethod [1] "none" $nprune NULL $penalty [1] 2 $nk [1] 21 $thresh [1] 0.001 $termcond [1] 4 $weights NULL $glm.list $glm.list[[1]] Call: glm(formula = yarg ~ ., family = family, data = bx.data.frame, weights = weights, na.action = na.action, offset = offset, control = control, model = TRUE, method = "glm.fit", x = TRUE, y = TRUE, contrasts = NULL, trace = (trace >= 2)) Coefficients: (Intercept) outcome2 outcome3 treatment3 treatment2 3.0492 -0.4001 -0.2606 0.1734 0.1102 Degrees of Freedom: 35 Total (i.e. Null); 31 Residual Null Deviance: 41.65 Residual Deviance: 18.97 AIC: 200.2 $glm.coefficients counts (Intercept) 3.0492313 outcome2 -0.4001032 outcome3 -0.2605738 treatment3 0.1733820 treatment2 0.1102031 $glm.stats nulldev df dev df devratio AIC iters converged 41.6537 35 18.97441 31 0.5444724 200.1817 4 1 $call earth(formula = counts ~ outcome + treatment, pmethod = "none", trace = 0.5, glm = list(family = poisson()), nfold = 3) $namesx.org [1] "outcome" "treatment" $namesx [1] "outcome" "treatment" $terms counts ~ outcome + treatment attr(,"variables") list(counts, outcome, treatment) attr(,"factors") outcome treatment counts 0 0 outcome 1 0 treatment 0 1 attr(,"term.labels") [1] "outcome" "treatment" attr(,"order") [1] 1 1 attr(,"intercept") [1] 1 attr(,"response") [1] 1 attr(,".Environment") attr(,"predvars") list(counts, outcome, treatment) attr(,"dataClasses") counts outcome treatment "numeric" "factor" "factor" $xlevels $xlevels$outcome [1] "1" "2" "3" $xlevels$treatment [1] "1" "2" "3" $cv.list $cv.list$fold1 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged 23.1498 23 12.0505 19 0.479 135.4 4 1 Earth selected 5 of 5 terms, and 4 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 5 terms Number of terms at each degree of interaction: 1 4 (additive model) Earth GCV 22.87241 RSS 214.4288 GRSq -0.2046498 RSq 0.4876253 $cv.list$fold2 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged 21.8976 23 9.45748 19 0.568 134.7 4 1 Earth selected 5 of 5 terms, and 4 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 5 terms Number of terms at each degree of interaction: 1 4 (additive model) Earth GCV 18.88197 RSS 177.0184 GRSq 0.02149684 RSq 0.5838125 $cv.list$fold3 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged 36.9761 23 10.6286 19 0.713 134.4 4 1 Earth selected 5 of 5 terms, and 4 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 5 terms Number of terms at each degree of interaction: 1 4 (additive model) Earth GCV 21.19515 RSS 198.7046 GRSq 0.3300528 RSq 0.7150508 $cv.nterms.selected.by.gcv fold1 fold2 fold3 mean 5 5 5 5 $cv.nvars.selected.by.gcv fold1 fold2 fold3 mean 4 4 4 4 $cv.groups cross fold [1,] 1 2 [2,] 1 3 [3,] 1 2 [4,] 1 1 [5,] 1 2 [6,] 1 2 [7,] 1 1 [8,] 1 3 [9,] 1 1 [10,] 1 3 [11,] 1 3 [12,] 1 1 [13,] 1 1 [14,] 1 2 [15,] 1 3 [16,] 1 1 [17,] 1 1 [18,] 1 1 [19,] 1 3 [20,] 1 3 [21,] 1 3 [22,] 1 3 [23,] 1 2 [24,] 1 2 [25,] 1 1 [26,] 1 2 [27,] 1 1 [28,] 1 2 [29,] 1 3 [30,] 1 3 [31,] 1 1 [32,] 1 2 [33,] 1 1 [34,] 1 2 [35,] 1 2 [36,] 1 3 $cv.rsq.tab counts mean fold1 0.5119511 0.5119511 fold2 0.1626068 0.1626068 fold3 -1.7434823 -1.7434823 mean -0.3563081 -0.3563081 $cv.maxerr.tab counts max fold1 -5.422496 -5.422496 fold2 -6.264971 -6.264971 fold3 7.298345 7.298345 max 7.298345 7.298345 $cv.cor.tab counts mean fold1 0.7894110 0.7894110 fold2 0.5962246 0.5962246 fold3 0.5275154 0.5275154 mean 0.6377170 0.6377170 $cv.deviance.tab counts mean fold1 0.6928746 0.6928746 fold2 1.2237638 1.2237638 fold3 1.0848099 1.0848099 mean 1.0004828 1.0004828 $cv.calib.int.tab counts mean fold1 -2.237385613 -2.237385613 fold2 0.082828613 0.082828613 fold3 2.145356708 2.145356708 mean -0.003066764 -0.003066764 $cv.calib.slope.tab counts mean fold1 1.7401555 1.7401555 fold2 0.9354657 0.9354657 fold3 0.2834395 0.2834395 mean 0.9863536 0.9863536 attr(,"class") [1] "earth" ------------------------------------------------------------------------------- > # two response poisson model > cat("a10: two response poisson model\n\n") a10: two response poisson model > set.seed(1237) > a10 <- earth(cbind(counts, counts2) ~ outcome + treatment, glm=list(fam="po"), trace=0.5, pmethod="none", nfold=3) Full model GRSq 0.303 RSq 0.522, starting cross validation CV fold 1 CVRSq 0.385 Per response CVRSq 0.345 0.425 n.oof 24 33% n.infold.nz 2424 n.oof.nz 1212 CV fold 2 CVRSq -0.540 Per response CVRSq -0.502 -0.578 n.oof 24 33% n.infold.nz 2424 n.oof.nz 1212 CV fold 3 CVRSq 0.468 Per response CVRSq 0.502 0.435 n.oof 24 33% n.infold.nz 2424 n.oof.nz 1212 CV all CVRSq 0.104 Per response CVRSq 0.115 0.094 n.infold.nz 3636 > printh(a10) === a10 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged counts 41.6537 35 22.3511 32 0.463 201.6 4 1 counts2 418.8258 35 204.9731 32 0.511 463.0 4 1 Earth selected 4 of 4 terms, and 3 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 4 terms Importance: outcome2, outcome3, treatment2, treatment3-unused Number of terms at each degree of interaction: 1 3 (additive model) Earth GCV RSS GRSq RSq CVRSq counts 17.59156 410.958 0.2352582 0.4749814 0.11487606 counts2 1461.64328 34145.611 0.3039166 0.5221174 0.09378626 All 1479.23484 34556.569 0.3031726 0.5216067 0.10433116 > printh(summary(a10)) === summary(a10) Call: earth(formula=cbind(counts,counts2)~outcome+treatment, pmethod="none", trace=0.5, glm=list(fam="po"), nfold=3) GLM coefficients counts counts2 (Intercept) 3.13967527 5.3622792 outcome2 -0.40010316 -0.4422645 outcome3 -0.26057375 -0.2900158 treatment2 0.01975915 0.0179835 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged counts 41.6537 35 22.3511 32 0.463 201.6 4 1 counts2 418.8258 35 204.9731 32 0.511 463.0 4 1 Earth selected 4 of 4 terms, and 3 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 4 terms Importance: outcome2, outcome3, treatment2, treatment3-unused Number of terms at each degree of interaction: 1 3 (additive model) Earth GCV RSS GRSq RSq CVRSq counts 17.59156 410.958 0.2352582 0.4749814 0.11487606 counts2 1461.64328 34145.611 0.3039166 0.5221174 0.09378626 All 1479.23484 34556.569 0.3031726 0.5216067 0.10433116 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 4.67 sd 0.58 nvars 3.67 sd 0.58 CVRSq sd MaxErr sd cor.tab sd MeanDev sd CalibInt sd CalibSlope sd counts 0.115 0.540 6.38 6.75 0.641 0.195 0.821 0.180 0.160 1.66 0.946 0.541 counts2 0.094 0.582 59.68 4.95 0.670 0.111 8.431 0.822 -0.072 2.89 1.014 0.558 All 0.104 0.560 59.68 4.95 0.655 0.153 4.626 0.497 0.044 2.17 0.980 0.523 > print.stripped.earth.model(a10, "a10") print.stripped.earth.model(a10) $rsq [1] 0.5216067 $gcv [1] 1479.235 $grsq [1] 0.3031726 $dirs outcome2 outcome3 treatment2 treatment3 (Intercept) 0 0 0 0 outcome2 2 0 0 0 outcome3 0 2 0 0 treatment2 0 0 2 0 $cuts outcome2 outcome3 treatment2 treatment3 (Intercept) 0 0 0 0 outcome2 0 0 0 0 outcome3 0 0 0 0 treatment2 0 0 0 0 $selected.terms [1] 1 2 3 4 $prune.terms [,1] [,2] [,3] [,4] [1,] 1 0 0 0 [2,] 1 2 0 0 [3,] 1 2 3 0 [4,] 1 2 3 4 $coefficients counts counts2 (Intercept) 23.125000 213.472222 outcome2 -7.666667 -76.666667 outcome3 -5.333333 -54.000000 treatment2 0.375000 3.083333 $rss.per.response [1] 410.9583 34145.6111 $rsq.per.response [1] 0.4749814 0.5221174 $gcv.per.response [1] 17.59156 1461.64328 $grsq.per.response [1] 0.2352582 0.3039166 $rss.per.subset [1] 72234.64 52300.42 34633.75 34556.57 $gcv.per.subset [1] 2122.814 1728.939 1297.414 1479.235 $leverages [1] 0.09722222 0.09722222 0.09722222 0.09722222 0.09722222 0.09722222 0.09722222 0.09722222 0.09722222 0.09722222 0.09722222 0.09722222 0.13888889 0.13888889 0.13888889 0.13888889 0.13888889 [18] 0.13888889 0.13888889 0.13888889 0.13888889 0.13888889 0.13888889 0.13888889 0.09722222 0.09722222 0.09722222 0.09722222 0.09722222 0.09722222 0.09722222 0.09722222 0.09722222 0.09722222 [35] 0.09722222 0.09722222 $pmethod [1] "none" $nprune NULL $penalty [1] 2 $nk [1] 21 $thresh [1] 0.001 $termcond [1] 4 $weights NULL $glm.list $glm.list[[1]] Call: glm(formula = yarg ~ ., family = family, data = bx.data.frame, weights = weights, na.action = na.action, offset = offset, control = control, model = TRUE, method = "glm.fit", x = TRUE, y = TRUE, contrasts = NULL, trace = (trace >= 2)) Coefficients: (Intercept) outcome2 outcome3 treatment2 3.13968 -0.40010 -0.26057 0.01976 Degrees of Freedom: 35 Total (i.e. Null); 32 Residual Null Deviance: 41.65 Residual Deviance: 22.35 AIC: 201.6 $glm.list[[2]] Call: glm(formula = yarg ~ ., family = family, data = bx.data.frame, weights = weights, na.action = na.action, offset = offset, control = control, model = TRUE, method = "glm.fit", x = TRUE, y = TRUE, contrasts = NULL, trace = (trace >= 2)) Coefficients: (Intercept) outcome2 outcome3 treatment2 5.36228 -0.44226 -0.29002 0.01798 Degrees of Freedom: 35 Total (i.e. Null); 32 Residual Null Deviance: 418.8 Residual Deviance: 205 AIC: 463 $glm.coefficients counts counts2 (Intercept) 3.13967527 5.36227924 outcome2 -0.40010316 -0.44226451 outcome3 -0.26057375 -0.29001580 treatment2 0.01975915 0.01798347 $glm.stats nulldev df dev df devratio AIC iters converged counts 41.6537 35 22.35113 32 0.4634058 201.5585 4 1 counts2 418.8258 35 204.97309 32 0.5106006 463.0048 4 1 $call earth(formula = cbind(counts, counts2) ~ outcome + treatment, pmethod = "none", trace = 0.5, glm = list(fam = "po"), nfold = 3) $namesx.org [1] "outcome" "treatment" $namesx [1] "outcome" "treatment" $terms cbind(counts, counts2) ~ outcome + treatment attr(,"variables") list(cbind(counts, counts2), outcome, treatment) attr(,"factors") outcome treatment cbind(counts, counts2) 0 0 outcome 1 0 treatment 0 1 attr(,"term.labels") [1] "outcome" "treatment" attr(,"order") [1] 1 1 attr(,"intercept") [1] 1 attr(,"response") [1] 1 attr(,".Environment") attr(,"predvars") list(cbind(counts, counts2), outcome, treatment) attr(,"dataClasses") cbind(counts, counts2) outcome treatment "nmatrix.2" "factor" "factor" $xlevels $xlevels$outcome [1] "1" "2" "3" $xlevels$treatment [1] "1" "2" "3" $cv.list $cv.list$fold1 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged counts 27.6662 23 12.8286 19 0.536 137.9 4 1 counts2 251.8846 23 129.2436 19 0.487 306.8 4 1 Earth selected 5 of 5 terms, and 4 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 5 terms Number of terms at each degree of interaction: 1 4 (additive model) Earth GCV RSS GRSq RSq counts 24.82015 232.6889 -0.03686803 0.5589881 counts2 2319.04449 21741.0421 -0.16581633 0.5041424 All 2343.86464 21973.7310 -0.16428305 0.5047945 $cv.list$fold2 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged counts 34.0184 23 11.2971 20 0.668 133.1 4 1 counts2 354.2817 23 125.3254 20 0.646 299.7 4 1 Earth selected 4 of 4 terms, and 3 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 4 terms Number of terms at each degree of interaction: 1 3 (additive model) Earth GCV RSS GRSq RSq counts 17.34194 208.8259 0.4032079 0.6739643 counts2 1775.77556 21383.2974 0.3549578 0.6476045 All 1793.11750 21592.1233 0.3554618 0.6478799 $cv.list$fold3 GLM (family poisson, link log): nulldev df dev df devratio AIC iters converged counts 20.5829 23 10.6389 19 0.483 134.3 4 1 counts2 223.8478 23 119.1064 19 0.468 295.2 4 1 Earth selected 5 of 5 terms, and 4 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 5 terms Number of terms at each degree of interaction: 1 4 (additive model) Earth GCV RSS GRSq RSq counts 20.6853 193.9247 -0.2073842 0.4864623 counts2 2054.2497 19258.5913 -0.2213879 0.4805061 All 2074.9350 19452.5160 -0.2212467 0.4805662 $cv.nterms.selected.by.gcv fold1 fold2 fold3 mean 5.000000 4.000000 5.000000 4.666667 $cv.nvars.selected.by.gcv fold1 fold2 fold3 mean 4.000000 3.000000 4.000000 3.666667 $cv.groups cross fold [1,] 1 2 [2,] 1 2 [3,] 1 1 [4,] 1 1 [5,] 1 3 [6,] 1 3 [7,] 1 3 [8,] 1 2 [9,] 1 1 [10,] 1 1 [11,] 1 3 [12,] 1 3 [13,] 1 2 [14,] 1 3 [15,] 1 1 [16,] 1 1 [17,] 1 1 [18,] 1 2 [19,] 1 1 [20,] 1 2 [21,] 1 3 [22,] 1 2 [23,] 1 1 [24,] 1 2 [25,] 1 3 [26,] 1 1 [27,] 1 1 [28,] 1 3 [29,] 1 2 [30,] 1 2 [31,] 1 3 [32,] 1 1 [33,] 1 2 [34,] 1 3 [35,] 1 2 [36,] 1 3 $cv.rsq.tab counts counts2 mean fold1 0.3449032 0.42465387 0.3847785 fold2 -0.5021829 -0.57808549 -0.5401342 fold3 0.5019078 0.43479040 0.4683491 mean 0.1148761 0.09378626 0.1043312 $cv.maxerr.tab counts counts2 max fold1 -5.537683 49.78533 49.78533 fold2 6.381273 55.14476 55.14476 fold3 5.908673 59.67596 59.67596 max 6.381273 59.67596 59.67596 $cv.cor.tab counts counts2 mean fold1 0.7542438 0.7299357 0.7420897 fold2 0.4158599 0.5418024 0.4788311 fold3 0.7526629 0.7374324 0.7450476 mean 0.6409222 0.6697235 0.6553228 $cv.deviance.tab counts counts2 mean fold1 0.6344484 7.487681 4.061065 fold2 0.9934619 8.996198 4.994830 fold3 0.8338995 8.809898 4.821899 mean 0.8206033 8.431259 4.625931 $cv.calib.int.tab counts counts2 mean fold1 -1.45098721 -1.28687109 -1.36892915 fold2 1.87307141 3.22473639 2.54890390 fold3 0.05919122 -2.15268988 -1.04674933 mean 0.16042514 -0.07160819 0.04440847 $cv.calib.slope.tab counts counts2 mean fold1 1.4583864 1.230922 1.3446541 fold2 0.3806876 0.380367 0.3805273 fold3 0.9982222 1.431200 1.2147109 mean 0.9457654 1.014163 0.9799641 attr(,"class") [1] "earth" ------------------------------------------------------------------------------- > # binomial pair model with keepxy > set.seed(2019) > bpair.mod <- earth(cbind(counts, counts2) ~ outcome + treatment, + glm=list(fam="quasib"), trace=1, + pmethod="none", nfold=3, keepxy=TRUE) x[36,4] with colnames outcome2 outcome3 treatment2 treatment3 y[36,2] with colnames counts counts2 weights used by earth internally: 199, 188, 166, 221, 111, 221, 276, 144, 133, 20... Response columns counts and counts2 are a binomial pair (6835 obs in total) yfrac[36,1] with colname counts, and values 0.09045, 0.09043, 0.09036, 0... Forward pass term 1, 2, 4, 6, 8, 10 RSq changed by less than 0.001 at 9 terms, 5 terms used (DeltaRSq 0) After forward pass GRSq 0.521 RSq 0.756 Prune none penalty 2 nprune null: selected 5 of 5 terms, and 4 of 4 preds After pruning pass GRSq 0.589 RSq 0.756 GLM counts devratio 0.76 dof 31/35 iters 3 Warning: No 'data' argument to earth so 'keepxy' is limited Full model GRSq 0.589 RSq 0.756, starting cross validation CV fold 1 CVRSq 0.726 n.oof 24 33% n.infold.nz 24 100% n.oof.nz 12 100% CV fold 2 CVRSq 0.527 n.oof 24 33% n.infold.nz 24 100% n.oof.nz 12 100% CV fold 3 CVRSq 0.735 n.oof 24 33% n.infold.nz 24 100% n.oof.nz 12 100% CV all CVRSq 0.663 n.infold.nz 36 100% > print(summary(bpair.mod)) Call: earth(formula=cbind(counts,counts2)~outcome+treatment, pmethod="none", keepxy=TRUE, trace=1, glm=list(fam="quasib"), nfold=3) GLM coefficients counts (Intercept) -2.31447853 outcome2 0.04632793 outcome3 0.03287022 treatment2 0.09145788 treatment3 0.17175093 GLM (family quasibinomial, link logit): nulldev df dev df devratio iters converged 4.17066 35 0.988449 31 0.763 3 1 Earth selected 5 of 5 terms, and 4 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 5 terms Importance: treatment3, treatment2, outcome2, outcome3 Number of terms at each degree of interaction: 1 4 (additive model) Earth GCV 0.004549784 RSS 0.09213313 GRSq 0.5894512 RSq 0.7556816 CVRSq 0.6627604 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 5.00 sd 0.00 nvars 4.00 sd 0.00 CVRSq sd MaxErr sd AUC sd MeanDev sd CalibInt sd CalibSlope sd 0.663 0.117 0.00985 0.00159 NaN NA 0.651 0.00213 0.049 0.7 1.02 0.322 > plot(bpair.mod, which=1, main="bpair.mod") > > bpair.data <- data.frame(counts, counts2, outcome, treatment) > set.seed(2019) > bpair.mod.Formula <- earth(counts+counts2 ~ outcome + treatment, data=bpair.data, + glm=list(fam="quasib"), trace=1, + pmethod="none", nfold=3, keepxy=TRUE) Using class "Formula" because lhs of formula has terms separated by "+" x[36,4] with colnames outcome2 outcome3 treatment2 treatment3 y[36,2] with colnames counts counts2 weights used by earth internally: 199, 188, 166, 221, 111, 221, 276, 144, 133, 20... Response columns counts and counts2 are a binomial pair (6835 obs in total) yfrac[36,1] with colname counts, and values 0.09045, 0.09043, 0.09036, 0... Forward pass term 1, 2, 4, 6, 8, 10 RSq changed by less than 0.001 at 9 terms, 5 terms used (DeltaRSq 0) After forward pass GRSq 0.521 RSq 0.756 Prune none penalty 2 nprune null: selected 5 of 5 terms, and 4 of 4 preds After pruning pass GRSq 0.589 RSq 0.756 GLM counts devratio 0.76 dof 31/35 iters 3 Full model GRSq 0.589 RSq 0.756, starting cross validation CV fold 1 CVRSq 0.726 n.oof 24 33% n.infold.nz 24 100% n.oof.nz 12 100% CV fold 2 CVRSq 0.527 n.oof 24 33% n.infold.nz 24 100% n.oof.nz 12 100% CV fold 3 CVRSq 0.735 n.oof 24 33% n.infold.nz 24 100% n.oof.nz 12 100% CV all CVRSq 0.663 n.infold.nz 36 100% > print(summary(bpair.mod.Formula)) Call: earth(formula=counts+counts2~outcome+treatment, data=bpair.data, pmethod="none", keepxy=TRUE, trace=1, glm=list(fam="quasib"), nfold=3) GLM coefficients counts (Intercept) -2.31447853 outcome2 0.04632793 outcome3 0.03287022 treatment2 0.09145788 treatment3 0.17175093 GLM (family quasibinomial, link logit): nulldev df dev df devratio iters converged 4.17066 35 0.988449 31 0.763 3 1 Earth selected 5 of 5 terms, and 4 of 4 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 5 terms Importance: treatment3, treatment2, outcome2, outcome3 Number of terms at each degree of interaction: 1 4 (additive model) Earth GCV 0.004549784 RSS 0.09213313 GRSq 0.5894512 RSq 0.7556816 CVRSq 0.6627604 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 5.00 sd 0.00 nvars 4.00 sd 0.00 CVRSq sd MaxErr sd AUC sd MeanDev sd CalibInt sd CalibSlope sd 0.663 0.117 0.00985 0.00159 NaN NA 0.651 0.00213 0.049 0.7 1.02 0.322 > plot(bpair.mod.Formula, which=1, main="bpair.mod.Formula") > check.models.equal(bpair.mod, bpair.mod.Formula, "bpair.mod, bpair.mod.Formula", newdata=bpair.data[1:3,]) bpair.mod, bpair.mod.Formula: models not identical Formulas differ: cbind(counts, counts2) ~ outcome + treatment and: ~counts + counts2 + (outcome + treatment) bpair.mod, bpair.mod.Formula: glm submodel formula strings are identical: yarg ~ treatment3 + treatment2 + outcome2 + outcome3 bpair.mod, bpair.mod.Formula: but the actual glm submodel formulas differ (classes are "formula" and "formula") bpair.mod, bpair.mod.Formula: glm submodels not identical (but coefs, residuals, fitted.values are the same) bpair.mod, bpair.mod.Formula: Models are equivalent, within numerical tolerances > > set.seed(427) > earth.mod.err <- earth(survived~., data=etitanic, degree=1, nfold=3, keepxy=FALSE) > expect.err(try(plot(earth.mod.err$cv.list[[1]])), "cannot get the original model response") Looked unsuccessfully for the original response in the following places: (1) object$y: NULL (2) model.frame: no formula in getCall(object) (3) getCall(object)$y: object 'infold.y' not found Error : cannot get the original model response (use keepxy=2 in the call to earth) Got error as expected from try(plot(earth.mod.err$cv.list[[1]])) > > # test plot.earth with cross-validated models (example from help page) > set.seed(427) > earth.mod.help <- earth(survived~., data=etitanic, trace=1, degree=2, nfold=5, keepxy=TRUE) x[1046,6] with colnames pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname survived, and values 1, 1, 0, 0, 0, 1, 1, 0, 1, 0,... Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.406 RSq 0.450 Prune backward penalty 3 nprune null: selected 8 of 17 terms, and 5 of 6 preds After pruning pass GRSq 0.42 RSq 0.439 Full model GRSq 0.420 RSq 0.439, starting cross validation CV fold 1 CVRSq 0.367 n.oof 834 20% n.infold.nz 341 41% n.oof.nz 86 41% CV fold 2 CVRSq 0.457 n.oof 841 20% n.infold.nz 341 41% n.oof.nz 86 42% CV fold 3 CVRSq 0.337 n.oof 840 20% n.infold.nz 342 41% n.oof.nz 85 41% CV fold 4 CVRSq 0.553 n.oof 832 20% n.infold.nz 342 41% n.oof.nz 85 40% CV fold 5 CVRSq 0.384 n.oof 837 20% n.infold.nz 342 41% n.oof.nz 85 41% CV all CVRSq 0.420 n.infold.nz 427 41% > print.stripped.earth.model(earth.mod.help, "earth.mod.help") print.stripped.earth.model(earth.mod.help) $rsq [1] 0.4389834 $gcv [1] 0.1404529 $grsq [1] 0.4197106 $dirs pclass2nd pclass3rd sexmale age sibsp parch (Intercept) 0 0 0 0 0 0 sexmale 0 0 2 0 0 0 pclass3rd 0 2 0 0 0 0 sexmale*h(age-16) 0 0 2 1 0 0 sexmale*h(16-age) 0 0 2 -1 0 0 pclass2nd*sexmale 2 0 2 0 0 0 pclass3rd*h(sibsp-4) 0 2 0 0 1 0 pclass3rd*h(4-sibsp) 0 2 0 0 -1 0 h(parch-1) 0 0 0 0 0 1 h(1-parch) 0 0 0 0 0 -1 pclass3rd*sexmale 0 2 2 0 0 0 sexmale*h(sibsp-1) 0 0 2 0 1 0 sexmale*h(1-sibsp) 0 0 2 0 -1 0 h(age-17)*h(1-parch) 0 0 0 1 0 -1 h(17-age)*h(1-parch) 0 0 0 -1 0 -1 h(age-32) 0 0 0 1 0 0 h(32-age) 0 0 0 -1 0 0 $cuts pclass2nd pclass3rd sexmale age sibsp parch (Intercept) 0 0 0 0 0 0 sexmale 0 0 0 0 0 0 pclass3rd 0 0 0 0 0 0 sexmale*h(age-16) 0 0 0 16 0 0 sexmale*h(16-age) 0 0 0 16 0 0 pclass2nd*sexmale 0 0 0 0 0 0 pclass3rd*h(sibsp-4) 0 0 0 0 4 0 pclass3rd*h(4-sibsp) 0 0 0 0 4 0 h(parch-1) 0 0 0 0 0 1 h(1-parch) 0 0 0 0 0 1 pclass3rd*sexmale 0 0 0 0 0 0 sexmale*h(sibsp-1) 0 0 0 0 1 0 sexmale*h(1-sibsp) 0 0 0 0 1 0 h(age-17)*h(1-parch) 0 0 0 17 0 1 h(17-age)*h(1-parch) 0 0 0 17 0 1 h(age-32) 0 0 0 32 0 0 h(32-age) 0 0 0 32 0 0 $selected.terms [1] 1 2 3 5 6 8 11 16 $prune.terms [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [,14] [,15] [,16] [,17] [1,] 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [2,] 1 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [3,] 1 2 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [4,] 1 2 3 6 0 0 0 0 0 0 0 0 0 0 0 0 0 [5,] 1 2 3 5 6 0 0 0 0 0 0 0 0 0 0 0 0 [6,] 1 2 3 5 6 8 0 0 0 0 0 0 0 0 0 0 0 [7,] 1 2 3 4 5 6 8 0 0 0 0 0 0 0 0 0 0 [8,] 1 2 3 5 6 8 11 16 0 0 0 0 0 0 0 0 0 [9,] 1 2 3 5 6 8 10 11 16 0 0 0 0 0 0 0 0 [10,] 1 2 3 5 6 8 9 10 11 16 0 0 0 0 0 0 0 [11,] 1 2 3 5 6 8 9 10 11 15 16 0 0 0 0 0 0 [12,] 1 2 3 5 6 8 9 10 11 14 15 16 0 0 0 0 0 [13,] 1 2 3 4 5 6 8 9 10 11 14 15 16 0 0 0 0 [14,] 1 2 3 4 5 6 8 9 10 11 12 14 15 16 0 0 0 [15,] 1 2 3 4 5 6 8 9 10 11 12 13 14 15 16 0 0 [16,] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 0 [17,] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 $coefficients survived (Intercept) 0.961709504 sexmale -0.570034960 pclass3rd -0.815453521 sexmale*h(16-age) 0.045052323 pclass2nd*sexmale -0.265689205 pclass3rd*h(4-sibsp) 0.102221809 pclass3rd*sexmale 0.193102034 h(age-32) -0.004719378 $rss.per.response [1] 141.7629 $rsq.per.response [1] 0.4389834 $gcv.per.response [1] 0.1404529 $grsq.per.response [1] 0.4197106 $rss.per.subset [1] 252.6893 179.5499 167.7515 159.6526 151.2288 145.4049 143.0839 141.7629 141.4108 140.6857 140.0308 139.7756 139.4650 139.2047 139.0511 138.9389 138.9223 $gcv.per.subset [1] 0.2420393 0.1728083 0.1622301 0.1551427 0.1476677 0.1426693 0.1410744 0.1404529 0.1407883 0.1407521 0.1407846 0.1412193 0.1416005 0.1420350 0.1425815 0.1431744 0.1438705 $leverages [1] 0.004844979 0.048080311 0.004844979 0.008718349 0.004844979 0.006944951 0.013758765 0.006963068 0.007618618 0.018340762 0.006822593 0.004844979 0.004844979 0.004844979 0.027277340 0.008718349 [17] 0.006382881 0.004844979 0.007528775 0.007309114 0.005426979 0.008718349 0.004455662 0.004844979 0.008718349 0.008718349 0.004844979 0.004401711 0.008718349 0.006671156 0.006836684 0.004844979 [33] 0.010300033 0.006677195 0.004945174 0.004844979 0.006741393 0.006944951 0.004750910 0.010929594 0.011590248 0.004354676 0.006671156 0.006677195 0.007618618 0.007528775 0.010300033 0.008374317 [49] 0.008718349 0.008718349 0.012291127 0.004844979 0.007528775 0.004316140 0.007098402 0.007528775 0.026389314 0.006731328 0.005426979 0.008718349 0.004666130 0.004316140 0.004844979 0.006671156 [65] 0.008718349 0.004844979 0.004844979 0.006822593 0.004245984 0.007309114 0.014543790 0.008597906 0.017503273 0.004316140 0.014543790 0.006963068 0.004238276 0.007498581 0.008718349 0.004666130 [81] 0.008718349 0.004844979 0.008718349 0.004844979 0.008023130 0.033080206 0.008092716 0.007282945 0.004844979 0.005714520 0.005714520 0.007098402 0.006963068 0.004844979 0.004238276 0.008092716 [97] 0.004316140 0.007528775 0.008718349 0.004844979 0.004844979 0.004844979 0.008718349 0.013131281 0.011590248 0.004844979 0.007282945 0.006644089 0.004844979 0.010838474 0.005714520 0.007309114 [113] 0.004401711 0.006822593 0.004401711 0.004844979 0.004945174 0.008718349 0.007098402 0.018340762 0.008023130 0.004844979 0.007120544 0.010300033 0.008718349 0.004945174 0.006731328 0.008718349 [129] 0.004844979 0.006944951 0.006033154 0.006671156 0.004401711 0.006836684 0.008718349 0.004844979 0.008672051 0.007175613 0.006677195 0.008672051 0.004844979 0.004750910 0.006763701 0.006677195 [145] 0.004401711 0.007779530 0.007120544 0.004401711 0.004238276 0.006382881 0.007098402 0.006731328 0.007282945 0.008542447 0.009878627 0.006741393 0.006677195 0.004945174 0.004245984 0.006033154 [161] 0.004844979 0.007779530 0.006677195 0.008597906 0.004844979 0.006763701 0.008718349 0.004844979 0.008718349 0.010300033 0.004844979 0.008718349 0.004844979 0.008718349 0.004844979 0.004844979 [177] 0.006731328 0.008332044 0.007528775 0.008718349 0.013782215 0.006642076 0.004666130 0.004261662 0.008718349 0.008672051 0.006822593 0.007309114 0.004844979 0.004844979 0.009878627 0.004844979 [193] 0.013131281 0.004245984 0.004844979 0.013782215 0.008718349 0.006697356 0.008718349 0.008718349 0.004844979 0.008718349 0.004844979 0.004844979 0.007745309 0.006822593 0.009134189 0.007120544 [209] 0.008718349 0.004587740 0.008718349 0.006671156 0.004666130 0.006731328 0.007528775 0.004666130 0.008672051 0.008092716 0.008374317 0.009734359 0.004844979 0.004844979 0.011365037 0.005714520 [225] 0.004844979 0.004401711 0.004844979 0.008061377 0.004284784 0.007779530 0.007282945 0.004245984 0.009043150 0.008718349 0.009043150 0.009043150 0.008718349 0.004844979 0.008718349 0.004844979 [241] 0.025261042 0.006671156 0.004284784 0.009445342 0.008718349 0.011922692 0.008332044 0.004587740 0.007175613 0.013004834 0.015177360 0.013758765 0.011365037 0.005714520 0.004844979 0.007745309 [257] 0.004245984 0.006944951 0.007098402 0.008718349 0.004245984 0.008718349 0.006836684 0.011365037 0.006822593 0.004401711 0.013131281 0.011590248 0.010838474 0.008332044 0.008718349 0.008597906 [273] 0.004844979 0.009445342 0.004945174 0.007282945 0.008718349 0.006382881 0.004844979 0.007498581 0.008718349 0.004844979 0.011922692 0.004316140 0.006891233 0.004844979 0.006891233 0.006891233 [289] 0.006891233 0.006638257 0.004316140 0.012668178 0.006891233 0.006891233 0.004316140 0.006891233 0.009509428 0.006891233 0.004844979 0.006891233 0.043204039 0.004844979 0.004844979 0.004316140 [305] 0.006638257 0.004844979 0.006891233 0.006891233 0.006870060 0.006891233 0.004844979 0.004844979 0.014667305 0.004284784 0.004844979 0.006891233 0.004316140 0.006891233 0.006870060 0.004455662 [321] 0.044082769 0.006891233 0.004844979 0.004401711 0.006891233 0.004750910 0.010948886 0.009958155 0.006491988 0.004844979 0.004844979 0.004945174 0.006891233 0.004844979 0.006891233 0.006891233 [337] 0.006891233 0.004844979 0.006891233 0.004844979 0.004844979 0.004844979 0.006891233 0.015733269 0.006891233 0.005714520 0.004844979 0.006891233 0.006891233 0.006891233 0.004844979 0.006891233 [353] 0.006891233 0.004844979 0.004518374 0.010948886 0.015733269 0.006870060 0.004518374 0.004844979 0.004844979 0.006891233 0.006891233 0.006891233 0.006625553 0.004844979 0.006891233 0.006509652 [369] 0.004238276 0.006558408 0.006505417 0.006638257 0.004518374 0.006891233 0.006891233 0.008025449 0.006891233 0.006891233 0.006891233 0.006891233 0.006638257 0.006891233 0.009958155 0.006891233 [385] 0.044971407 0.004844979 0.007238937 0.004844979 0.006891233 0.016155519 0.006891233 0.004844979 0.007038952 0.004945174 0.004844979 0.004844979 0.008705253 0.005714520 0.008597906 0.006891233 [401] 0.006891233 0.006891233 0.004844979 0.004844979 0.006891233 0.006509652 0.008092716 0.009091794 0.007238937 0.004844979 0.006891233 0.006870060 0.016946265 0.011590248 0.006749199 0.004844979 [417] 0.006870060 0.004844979 0.008025449 0.006891233 0.006891233 0.006891233 0.004844979 0.006638257 0.004844979 0.004844979 0.006558408 0.004945174 0.012668178 0.006891233 0.004844979 0.006891233 [433] 0.004844979 0.004844979 0.006891233 0.004844979 0.004844979 0.004518374 0.006509652 0.006891233 0.015395865 0.009091794 0.004455662 0.009701565 0.043204039 0.006891233 0.004844979 0.006891233 [449] 0.006625553 0.006891233 0.006891233 0.007732185 0.004844979 0.004354676 0.006891233 0.006549939 0.008349805 0.023352084 0.006891233 0.010948886 0.006549939 0.006891233 0.016155519 0.006816329 [465] 0.004844979 0.038151987 0.033475820 0.006496933 0.006891233 0.006891233 0.006891233 0.006891233 0.004844979 0.006549939 0.006891233 0.006891233 0.006891233 0.006891233 0.006382881 0.006891233 [481] 0.006732260 0.004844979 0.004844979 0.007038952 0.004844979 0.006638257 0.006891233 0.006891233 0.004844979 0.004844979 0.004666130 0.006509652 0.006638257 0.004844979 0.004844979 0.006891233 [497] 0.044082769 0.033475820 0.004844979 0.006382881 0.006891233 0.004844979 0.006891233 0.006891233 0.006891233 0.004844979 0.004844979 0.004844979 0.004844979 0.013969836 0.004844979 0.006558408 [513] 0.004284784 0.006891233 0.006732260 0.006891233 0.006891233 0.006846429 0.006382881 0.006891233 0.004844979 0.004844979 0.006891233 0.004844979 0.006625553 0.004844979 0.006891233 0.006891233 [529] 0.004844979 0.004844979 0.004284784 0.004751668 0.006891233 0.004844979 0.038151987 0.004844979 0.004844979 0.004844979 0.004844979 0.006509652 0.004666130 0.019505060 0.006891233 0.004844979 [545] 0.004844979 0.004135506 0.004452488 0.004046722 0.006769445 0.007704959 0.003404693 0.003404693 0.007704959 0.003404693 0.003404693 0.007383781 0.043382716 0.007704959 0.003404693 0.003404693 [561] 0.003404693 0.003404693 0.003404693 0.003297464 0.003404693 0.003404693 0.006773955 0.032986536 0.028775859 0.028775859 0.028775859 0.029121958 0.028775859 0.028775859 0.004261096 0.003404693 [577] 0.003404693 0.007198728 0.003404693 0.003404693 0.004046722 0.006773955 0.003404693 0.003297464 0.030734265 0.025484035 0.035614692 0.026247972 0.028775859 0.004416091 0.003404693 0.007044768 [593] 0.009652064 0.003404693 0.003404693 0.007704959 0.003404693 0.003404693 0.007704959 0.003404693 0.004046722 0.017285175 0.009975438 0.009975438 0.009975438 0.007704959 0.007704959 0.003740602 [609] 0.003404693 0.003404693 0.007704959 0.009652064 0.007704959 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.016055741 0.006773955 [625] 0.004416091 0.006773955 0.003404693 0.007704959 0.007704959 0.004046722 0.004046722 0.003404693 0.003297464 0.007704959 0.003404693 0.003404693 0.007704959 0.007704959 0.007704959 0.003404693 [641] 0.003470069 0.003404693 0.003404693 0.007704959 0.003404693 0.003404693 0.003404693 0.003404693 0.007704959 0.007831992 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.004046722 [657] 0.004046722 0.003404693 0.003404693 0.003404693 0.003323906 0.003404693 0.003404693 0.003404693 0.007704959 0.007704959 0.023276548 0.004379597 0.003297464 0.003404693 0.003404693 0.003404693 [673] 0.008506238 0.026988214 0.007744400 0.012513659 0.003404693 0.007704959 0.004654781 0.003404693 0.003404693 0.004961057 0.007704959 0.003404693 0.007704959 0.003404693 0.046172892 0.003952508 [689] 0.006773955 0.003404693 0.003404693 0.008821237 0.003404693 0.008821237 0.008821237 0.004009637 0.006830127 0.003404693 0.003404693 0.036155957 0.006773955 0.004046722 0.006741359 0.003404693 [705] 0.003404693 0.003323906 0.007704959 0.003404693 0.004135506 0.004379597 0.003404693 0.003404693 0.007704959 0.007704959 0.007704959 0.003337857 0.017616050 0.003404693 0.004046722 0.006773955 [721] 0.003404693 0.003404693 0.004961057 0.003589789 0.004046722 0.003556140 0.005666888 0.007704959 0.003827668 0.003827668 0.003404693 0.003404693 0.009975438 0.009975438 0.008821237 0.004046722 [737] 0.009983538 0.003404693 0.003404693 0.007704959 0.011111944 0.003984069 0.003922507 0.006773955 0.003470069 0.025484035 0.041998662 0.025114233 0.028775859 0.028775859 0.027378671 0.004416091 [753] 0.008125495 0.007451662 0.003404693 0.003404693 0.008839810 0.008821237 0.003404693 0.007704959 0.007704959 0.004046722 0.006773955 0.003404693 0.003404693 0.009414337 0.004046722 0.003404693 [769] 0.008775434 0.003404693 0.007030445 0.003404693 0.007704959 0.007704959 0.007704959 0.007704959 0.003404693 0.007704959 0.007704959 0.006773955 0.004379597 0.003404693 0.007704959 0.004135506 [785] 0.003404693 0.006773955 0.006773955 0.003404693 0.003404693 0.003404693 0.006066442 0.004046722 0.003302114 0.003404693 0.003404693 0.003337857 0.003404693 0.003404693 0.022968171 0.006773955 [801] 0.006497090 0.003337857 0.003404693 0.007704959 0.003404693 0.003404693 0.003404693 0.006773955 0.006773955 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003337857 0.003404693 [817] 0.007704959 0.003589789 0.003404693 0.003295902 0.004654781 0.009975438 0.008821237 0.007704959 0.017728237 0.006773955 0.006773955 0.004046722 0.007744400 0.003404693 0.007831992 0.007704959 [833] 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003295902 0.003323906 0.003589789 0.003404693 0.007704959 0.009652064 0.003982665 0.006773955 0.004046722 0.003404693 [849] 0.004046722 0.006773955 0.003404693 0.003404693 0.007451662 0.007704959 0.003404693 0.003404693 0.003404693 0.003404693 0.007704959 0.003297464 0.003337857 0.007704959 0.007687900 0.004046722 [865] 0.006773955 0.010054180 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.020053334 0.007704959 0.003302114 0.007704959 0.003404693 0.003404693 0.007704959 0.007704959 0.004046722 [881] 0.006773955 0.003337857 0.004339704 0.006773955 0.007704959 0.003404693 0.007704959 0.007704959 0.003404693 0.003922507 0.003589789 0.003404693 0.003404693 0.007704959 0.014090085 0.003404693 [897] 0.007704959 0.011111944 0.003404693 0.004135506 0.007704959 0.003404693 0.003404693 0.003404693 0.007704959 0.007704959 0.003404693 0.003404693 0.007704959 0.032074718 0.020458014 0.017309406 [913] 0.017309406 0.007704959 0.041998662 0.027357379 0.038618735 0.030767723 0.027378671 0.008493286 0.003404693 0.003404693 0.003404693 0.037407643 0.006773955 0.007704959 0.003404693 0.003404693 [929] 0.003404693 0.004046722 0.003404693 0.007704959 0.003404693 0.004046722 0.007704959 0.003404693 0.003404693 0.003404693 0.003470069 0.003404693 0.025111191 0.032986536 0.027357379 0.038618735 [945] 0.026232764 0.008100454 0.007704959 0.003297464 0.007676145 0.009549744 0.006773955 0.004046722 0.008493286 0.006958829 0.003404693 0.003404693 0.003526042 0.028084977 0.003404693 0.007704959 [961] 0.003589789 0.006773955 0.007704959 0.006773955 0.003404693 0.003404693 0.003404693 0.003404693 0.003404693 0.003740602 0.003404693 0.007704959 0.025514595 0.014855477 0.017309406 0.017309406 [977] 0.004416091 0.008775434 0.003404693 0.003404693 0.003404693 0.003337857 0.007704959 0.003404693 0.013684319 0.003404693 0.007704959 0.003404693 0.003404693 0.007704959 0.006773955 0.003404693 [993] 0.004654781 0.003404693 0.027368393 0.003727337 0.003404693 0.003404693 0.003302114 0.045700960 0.006773955 0.003404693 0.003404693 0.004654781 0.003404693 0.013163355 0.006773955 0.007704959 [1009] 0.003323906 0.007704959 0.021022916 0.004799198 0.003827668 0.007704959 0.003982665 0.006773955 0.003337857 0.003404693 0.003404693 0.005666888 0.009975438 0.017728237 0.008821237 0.006773955 [1025] 0.003404693 0.003404693 0.007704959 0.003404693 0.003404693 0.003367389 0.007950676 0.007451662 0.004046722 0.004046722 0.009549744 0.003404693 0.003404693 0.003404693 0.003323906 0.004046722 [1041] 0.006773955 0.005125855 0.006773955 0.003404693 0.003404693 0.003404693 $pmethod [1] "backward" $nprune NULL $penalty [1] 3 $nk [1] 21 $thresh [1] 0.001 $termcond [1] 7 $weights NULL $call earth(formula = survived ~ ., data = etitanic, keepxy = TRUE, trace = 1, degree = 2, nfold = 5) $namesx.org [1] "pclass" "sex" "age" "sibsp" "parch" $namesx [1] "pclass" "sex" "age" "sibsp" "parch" $terms survived ~ pclass + sex + age + sibsp + parch attr(,"variables") list(survived, pclass, sex, age, sibsp, parch) attr(,"factors") pclass sex age sibsp parch survived 0 0 0 0 0 pclass 1 0 0 0 0 sex 0 1 0 0 0 age 0 0 1 0 0 sibsp 0 0 0 1 0 parch 0 0 0 0 1 attr(,"term.labels") [1] "pclass" "sex" "age" "sibsp" "parch" attr(,"order") [1] 1 1 1 1 1 attr(,"intercept") [1] 1 attr(,"response") [1] 1 attr(,".Environment") attr(,"predvars") list(survived, pclass, sex, age, sibsp, parch) attr(,"dataClasses") survived pclass sex age sibsp parch "numeric" "factor" "factor" "numeric" "numeric" "numeric" $xlevels $xlevels$pclass [1] "1st" "2nd" "3rd" $xlevels$sex [1] "female" "male" $levels [1] 0 1 $data pclass survived sex age sibsp parch 1 1st 1 female 29.0000 0 0 2 1st 1 male 0.9167 1 2 3 1st 0 female 2.0000 1 2 4 1st 0 male 30.0000 1 2 5 1st 0 female 25.0000 1 2 6 1st 1 male 48.0000 0 0 7 1st 1 female 63.0000 1 0 8 1st 0 male 39.0000 0 0 9 1st 1 female 53.0000 2 0 10 1st 0 male 71.0000 0 0 11 1st 0 male 47.0000 1 0 12 1st 1 female 18.0000 1 0 13 1st 1 female 24.0000 0 0 14 1st 1 female 26.0000 0 0 15 1st 1 male 80.0000 0 0 17 1st 0 male 24.0000 0 1 18 1st 1 female 50.0000 0 1 19 1st 1 female 32.0000 0 0 20 1st 0 male 36.0000 0 0 21 1st 1 male 37.0000 1 1 22 1st 1 female 47.0000 1 1 23 1st 1 male 26.0000 0 0 24 1st 1 female 42.0000 0 0 25 1st 1 female 29.0000 0 0 26 1st 0 male 25.0000 0 0 27 1st 1 male 25.0000 1 0 28 1st 1 female 19.0000 1 0 29 1st 1 female 35.0000 0 0 30 1st 1 male 28.0000 0 0 31 1st 0 male 45.0000 0 0 32 1st 1 male 40.0000 0 0 33 1st 1 female 30.0000 0 0 34 1st 1 female 58.0000 0 0 35 1st 0 male 42.0000 0 0 36 1st 1 female 45.0000 0 0 37 1st 1 female 22.0000 0 1 39 1st 0 male 41.0000 0 0 40 1st 0 male 48.0000 0 0 42 1st 1 female 44.0000 0 0 43 1st 1 female 59.0000 2 0 44 1st 1 female 60.0000 0 0 45 1st 1 female 41.0000 0 0 46 1st 0 male 45.0000 0 0 48 1st 1 male 42.0000 0 0 49 1st 1 female 53.0000 0 0 50 1st 1 male 36.0000 0 1 51 1st 1 female 58.0000 0 1 52 1st 0 male 33.0000 0 0 53 1st 0 male 28.0000 0 0 54 1st 0 male 17.0000 0 0 55 1st 1 male 11.0000 1 2 56 1st 1 female 14.0000 1 2 57 1st 1 male 36.0000 1 2 58 1st 1 female 36.0000 1 2 59 1st 0 male 49.0000 0 0 61 1st 0 male 36.0000 1 0 62 1st 1 female 76.0000 1 0 63 1st 0 male 46.0000 1 0 64 1st 1 female 47.0000 1 0 65 1st 1 male 27.0000 1 0 66 1st 1 female 33.0000 1 0 67 1st 1 female 36.0000 0 0 68 1st 1 female 30.0000 0 0 69 1st 1 male 45.0000 0 0 72 1st 0 male 27.0000 1 0 73 1st 1 female 26.0000 1 0 74 1st 1 female 22.0000 0 0 76 1st 0 male 47.0000 0 0 77 1st 1 female 39.0000 1 1 78 1st 0 male 37.0000 1 1 79 1st 1 female 64.0000 0 2 80 1st 1 female 55.0000 2 0 82 1st 0 male 70.0000 1 1 83 1st 1 female 36.0000 0 2 84 1st 1 female 64.0000 1 1 85 1st 0 male 39.0000 1 0 86 1st 1 female 38.0000 1 0 87 1st 1 male 51.0000 0 0 88 1st 1 male 27.0000 0 0 89 1st 1 female 33.0000 0 0 90 1st 0 male 31.0000 1 0 91 1st 1 female 27.0000 1 2 92 1st 1 male 31.0000 1 0 93 1st 1 female 17.0000 1 0 94 1st 1 male 53.0000 1 1 95 1st 1 male 4.0000 0 2 96 1st 1 female 54.0000 1 1 97 1st 0 male 50.0000 1 0 98 1st 1 female 27.0000 1 1 99 1st 1 female 48.0000 1 0 100 1st 1 female 48.0000 1 0 101 1st 1 male 49.0000 1 0 102 1st 0 male 39.0000 0 0 103 1st 1 female 23.0000 0 1 104 1st 1 female 38.0000 0 0 105 1st 1 female 54.0000 1 0 106 1st 0 female 36.0000 0 0 110 1st 1 male 36.0000 0 0 111 1st 0 male 30.0000 0 0 112 1st 1 female 24.0000 3 2 113 1st 1 female 28.0000 3 2 114 1st 1 female 23.0000 3 2 115 1st 0 male 19.0000 3 2 116 1st 0 male 64.0000 1 4 117 1st 1 female 60.0000 1 4 118 1st 1 female 30.0000 0 0 120 1st 1 male 50.0000 2 0 121 1st 1 male 43.0000 1 0 123 1st 1 female 22.0000 0 2 124 1st 1 male 60.0000 1 1 125 1st 1 female 48.0000 1 1 127 1st 0 male 37.0000 1 0 128 1st 1 female 35.0000 1 0 129 1st 0 male 47.0000 0 0 130 1st 1 female 35.0000 0 0 131 1st 1 female 22.0000 0 1 132 1st 1 female 45.0000 0 1 133 1st 0 male 24.0000 0 0 134 1st 1 male 49.0000 1 0 136 1st 0 male 71.0000 0 0 137 1st 1 male 53.0000 0 0 138 1st 1 female 19.0000 0 0 139 1st 0 male 38.0000 0 1 140 1st 1 female 58.0000 0 1 141 1st 1 male 23.0000 0 1 142 1st 1 female 45.0000 0 1 143 1st 0 male 46.0000 0 0 144 1st 1 male 25.0000 1 0 145 1st 1 female 25.0000 1 0 146 1st 1 male 48.0000 1 0 147 1st 1 female 49.0000 1 0 149 1st 0 male 45.0000 1 0 150 1st 1 female 35.0000 1 0 151 1st 0 male 40.0000 0 0 152 1st 1 male 27.0000 0 0 154 1st 1 female 24.0000 0 0 155 1st 0 male 55.0000 1 1 156 1st 1 female 52.0000 1 1 157 1st 0 male 42.0000 0 0 159 1st 0 male 55.0000 0 0 160 1st 1 female 16.0000 0 1 161 1st 1 female 44.0000 0 1 162 1st 1 female 51.0000 1 0 163 1st 0 male 42.0000 1 0 164 1st 1 female 35.0000 1 0 165 1st 1 male 35.0000 0 0 166 1st 1 male 38.0000 1 0 168 1st 1 female 35.0000 1 0 169 1st 1 female 38.0000 0 0 170 1st 0 female 50.0000 0 0 171 1st 1 male 49.0000 0 0 172 1st 0 male 46.0000 0 0 173 1st 0 male 50.0000 0 0 174 1st 0 male 32.5000 0 0 175 1st 0 male 58.0000 0 0 176 1st 0 male 41.0000 1 0 178 1st 1 male 42.0000 1 0 179 1st 1 female 45.0000 1 0 181 1st 1 female 39.0000 0 0 182 1st 1 female 49.0000 0 0 183 1st 1 female 30.0000 0 0 184 1st 1 male 35.0000 0 0 186 1st 0 male 42.0000 0 0 187 1st 1 female 55.0000 0 0 188 1st 1 female 16.0000 0 1 189 1st 1 female 51.0000 0 1 190 1st 0 male 29.0000 0 0 191 1st 1 female 21.0000 0 0 192 1st 0 male 30.0000 0 0 193 1st 1 female 58.0000 0 0 194 1st 1 female 15.0000 0 1 195 1st 0 male 30.0000 0 0 196 1st 1 female 16.0000 0 0 198 1st 0 male 19.0000 1 0 199 1st 1 female 18.0000 1 0 200 1st 1 female 24.0000 0 0 201 1st 0 male 46.0000 0 0 202 1st 0 male 54.0000 0 0 203 1st 1 male 36.0000 0 0 204 1st 0 male 28.0000 1 0 206 1st 0 male 65.0000 0 0 207 1st 0 male 44.0000 2 0 208 1st 1 female 33.0000 1 0 209 1st 1 female 37.0000 1 0 210 1st 1 male 30.0000 1 0 211 1st 0 male 55.0000 0 0 212 1st 0 male 47.0000 0 0 213 1st 0 male 37.0000 0 1 214 1st 1 female 31.0000 1 0 215 1st 1 female 23.0000 1 0 216 1st 0 male 58.0000 0 2 217 1st 1 female 19.0000 0 2 218 1st 0 male 64.0000 0 0 219 1st 1 female 39.0000 0 0 221 1st 1 female 22.0000 0 1 222 1st 0 male 65.0000 0 1 223 1st 0 male 28.5000 0 0 225 1st 0 male 45.5000 0 0 226 1st 0 male 23.0000 0 0 227 1st 0 male 29.0000 1 0 228 1st 1 female 22.0000 1 0 229 1st 0 male 18.0000 1 0 230 1st 1 female 17.0000 1 0 231 1st 1 female 30.0000 0 0 232 1st 1 male 52.0000 0 0 233 1st 0 male 47.0000 0 0 234 1st 1 female 56.0000 0 1 235 1st 0 male 38.0000 0 0 237 1st 0 male 22.0000 0 0 239 1st 1 female 43.0000 0 1 240 1st 0 male 31.0000 0 0 241 1st 1 male 45.0000 0 0 243 1st 1 female 33.0000 0 0 244 1st 0 male 46.0000 0 0 245 1st 0 male 36.0000 0 0 246 1st 1 female 33.0000 0 0 247 1st 0 male 55.0000 1 0 248 1st 1 female 54.0000 1 0 249 1st 0 male 33.0000 0 0 250 1st 1 male 13.0000 2 2 251 1st 1 female 18.0000 2 2 252 1st 1 female 21.0000 2 2 253 1st 0 male 61.0000 1 3 254 1st 1 female 48.0000 1 3 256 1st 1 female 24.0000 0 0 258 1st 1 female 35.0000 1 0 259 1st 1 female 30.0000 0 0 260 1st 1 male 34.0000 0 0 261 1st 1 female 40.0000 0 0 262 1st 1 male 35.0000 0 0 263 1st 0 male 50.0000 1 0 264 1st 1 female 39.0000 1 0 265 1st 1 male 56.0000 0 0 266 1st 1 male 28.0000 0 0 267 1st 0 male 56.0000 0 0 268 1st 0 male 56.0000 0 0 269 1st 0 male 24.0000 1 0 271 1st 1 female 18.0000 1 0 272 1st 1 male 24.0000 1 0 273 1st 1 female 23.0000 1 0 274 1st 1 male 6.0000 0 2 275 1st 1 male 45.0000 1 1 276 1st 1 female 40.0000 1 1 277 1st 0 male 57.0000 1 0 279 1st 1 male 32.0000 0 0 280 1st 0 male 62.0000 0 0 281 1st 1 male 54.0000 1 0 282 1st 1 female 43.0000 1 0 283 1st 1 female 52.0000 1 0 285 1st 1 female 62.0000 0 0 286 1st 0 male 67.0000 1 0 287 1st 0 female 63.0000 1 0 288 1st 0 male 61.0000 0 0 289 1st 1 female 48.0000 0 0 290 1st 1 female 18.0000 0 2 291 1st 0 male 52.0000 1 1 292 1st 1 female 39.0000 1 1 293 1st 1 male 48.0000 1 0 295 1st 0 male 49.0000 1 1 296 1st 1 male 17.0000 0 2 297 1st 1 female 39.0000 1 1 299 1st 1 male 31.0000 0 0 300 1st 0 male 40.0000 0 0 301 1st 0 male 61.0000 0 0 302 1st 0 male 47.0000 0 0 303 1st 1 female 35.0000 0 0 304 1st 0 male 64.0000 1 0 305 1st 1 female 60.0000 1 0 306 1st 0 male 60.0000 0 0 307 1st 0 male 54.0000 0 1 308 1st 0 male 21.0000 0 1 309 1st 1 female 55.0000 0 0 310 1st 1 female 31.0000 0 2 311 1st 0 male 57.0000 1 1 312 1st 1 female 45.0000 1 1 313 1st 0 male 50.0000 1 1 314 1st 0 male 27.0000 0 2 315 1st 1 female 50.0000 1 1 316 1st 1 female 21.0000 0 0 317 1st 0 male 51.0000 0 1 318 1st 1 male 21.0000 0 1 320 1st 1 female 31.0000 0 0 322 1st 0 male 62.0000 0 0 323 1st 1 female 36.0000 0 0 324 2nd 0 male 30.0000 1 0 325 2nd 1 female 28.0000 1 0 326 2nd 0 male 30.0000 0 0 327 2nd 0 male 18.0000 0 0 328 2nd 0 male 25.0000 0 0 329 2nd 0 male 34.0000 1 0 330 2nd 1 female 36.0000 1 0 331 2nd 0 male 57.0000 0 0 332 2nd 0 male 18.0000 0 0 333 2nd 0 male 23.0000 0 0 334 2nd 1 female 36.0000 0 0 335 2nd 0 male 28.0000 0 0 336 2nd 0 male 51.0000 0 0 337 2nd 1 male 32.0000 1 0 338 2nd 1 female 19.0000 1 0 339 2nd 0 male 28.0000 0 0 340 2nd 1 male 1.0000 2 1 341 2nd 1 female 4.0000 2 1 342 2nd 1 female 12.0000 2 1 343 2nd 1 female 36.0000 0 3 344 2nd 1 male 34.0000 0 0 345 2nd 1 female 19.0000 0 0 346 2nd 0 male 23.0000 0 0 347 2nd 0 male 26.0000 0 0 348 2nd 0 male 42.0000 0 0 349 2nd 0 male 27.0000 0 0 350 2nd 1 female 24.0000 0 0 351 2nd 1 female 15.0000 0 2 352 2nd 0 male 60.0000 1 1 353 2nd 1 female 40.0000 1 1 354 2nd 1 female 20.0000 1 0 355 2nd 0 male 25.0000 1 0 356 2nd 1 female 36.0000 0 0 357 2nd 0 male 25.0000 0 0 358 2nd 0 male 42.0000 0 0 359 2nd 1 female 42.0000 0 0 360 2nd 1 male 0.8333 0 2 361 2nd 1 male 26.0000 1 1 362 2nd 1 female 22.0000 1 1 363 2nd 1 female 35.0000 0 0 365 2nd 0 male 19.0000 0 0 366 2nd 0 female 44.0000 1 0 367 2nd 0 male 54.0000 1 0 368 2nd 0 male 52.0000 0 0 369 2nd 0 male 37.0000 1 0 370 2nd 0 female 29.0000 1 0 371 2nd 1 female 25.0000 1 1 372 2nd 1 female 45.0000 0 2 373 2nd 0 male 29.0000 1 0 374 2nd 1 female 28.0000 1 0 375 2nd 0 male 29.0000 0 0 376 2nd 0 male 28.0000 0 0 377 2nd 1 male 24.0000 0 0 378 2nd 1 female 8.0000 0 2 379 2nd 0 male 31.0000 1 1 380 2nd 1 female 31.0000 1 1 381 2nd 1 female 22.0000 0 0 382 2nd 0 female 30.0000 0 0 384 2nd 0 male 21.0000 0 0 386 2nd 1 male 8.0000 1 1 387 2nd 0 male 18.0000 0 0 388 2nd 1 female 48.0000 0 2 389 2nd 1 female 28.0000 0 0 390 2nd 0 male 32.0000 0 0 391 2nd 0 male 17.0000 0 0 392 2nd 0 male 29.0000 1 0 393 2nd 1 female 24.0000 1 0 394 2nd 0 male 25.0000 0 0 395 2nd 0 male 18.0000 0 0 396 2nd 1 female 18.0000 0 1 397 2nd 1 female 34.0000 0 1 398 2nd 0 male 54.0000 0 0 399 2nd 1 male 8.0000 0 2 400 2nd 0 male 42.0000 1 1 401 2nd 1 female 34.0000 1 1 402 2nd 1 female 27.0000 1 0 403 2nd 1 female 30.0000 1 0 404 2nd 0 male 23.0000 0 0 405 2nd 0 male 21.0000 0 0 406 2nd 0 male 18.0000 0 0 407 2nd 0 male 40.0000 1 0 408 2nd 1 female 29.0000 1 0 409 2nd 0 male 18.0000 0 0 410 2nd 0 male 36.0000 0 0 412 2nd 0 female 38.0000 0 0 413 2nd 0 male 35.0000 0 0 414 2nd 0 male 38.0000 1 0 415 2nd 0 male 34.0000 1 0 416 2nd 1 female 34.0000 0 0 417 2nd 0 male 16.0000 0 0 418 2nd 0 male 26.0000 0 0 419 2nd 0 male 47.0000 0 0 420 2nd 0 male 21.0000 1 0 421 2nd 0 male 21.0000 1 0 422 2nd 0 male 24.0000 0 0 423 2nd 0 male 24.0000 0 0 424 2nd 0 male 34.0000 0 0 425 2nd 0 male 30.0000 0 0 426 2nd 0 male 52.0000 0 0 427 2nd 0 male 30.0000 0 0 428 2nd 1 male 0.6667 1 1 429 2nd 1 female 24.0000 0 2 430 2nd 0 male 44.0000 0 0 431 2nd 1 female 6.0000 0 1 432 2nd 0 male 28.0000 0 1 433 2nd 1 male 62.0000 0 0 434 2nd 0 male 30.0000 0 0 435 2nd 1 female 7.0000 0 2 436 2nd 0 male 43.0000 1 1 437 2nd 1 female 45.0000 1 1 438 2nd 1 female 24.0000 1 2 439 2nd 1 female 24.0000 1 2 440 2nd 0 male 49.0000 1 2 441 2nd 1 female 48.0000 1 2 442 2nd 1 female 55.0000 0 0 443 2nd 0 male 24.0000 2 0 444 2nd 0 male 32.0000 2 0 445 2nd 0 male 21.0000 2 0 446 2nd 0 female 18.0000 1 1 447 2nd 1 female 20.0000 2 1 448 2nd 0 male 23.0000 2 1 449 2nd 0 male 36.0000 0 0 450 2nd 1 female 54.0000 1 3 451 2nd 0 male 50.0000 0 0 452 2nd 0 male 44.0000 1 0 453 2nd 1 female 29.0000 1 0 454 2nd 0 male 21.0000 0 0 455 2nd 1 male 42.0000 0 0 456 2nd 0 male 63.0000 1 0 457 2nd 0 female 60.0000 1 0 458 2nd 0 male 33.0000 0 0 459 2nd 1 female 17.0000 0 0 460 2nd 0 male 42.0000 1 0 461 2nd 1 female 24.0000 2 1 462 2nd 0 male 47.0000 0 0 463 2nd 0 male 24.0000 2 0 464 2nd 0 male 22.0000 2 0 465 2nd 0 male 32.0000 0 0 466 2nd 1 female 23.0000 0 0 467 2nd 0 male 34.0000 1 0 468 2nd 1 female 24.0000 1 0 469 2nd 0 female 22.0000 0 0 471 2nd 0 male 35.0000 0 0 472 2nd 1 female 45.0000 0 0 473 2nd 0 male 57.0000 0 0 475 2nd 0 male 31.0000 0 0 476 2nd 0 female 26.0000 1 1 477 2nd 0 male 30.0000 1 1 479 2nd 1 female 1.0000 1 2 480 2nd 1 female 3.0000 1 2 481 2nd 0 male 25.0000 1 2 482 2nd 1 female 22.0000 1 2 483 2nd 1 female 17.0000 0 0 485 2nd 1 female 34.0000 0 0 486 2nd 0 male 36.0000 0 0 487 2nd 0 male 24.0000 0 0 488 2nd 0 male 61.0000 0 0 489 2nd 0 male 50.0000 1 0 490 2nd 1 female 42.0000 1 0 491 2nd 0 female 57.0000 0 0 493 2nd 1 male 1.0000 0 2 494 2nd 0 male 31.0000 1 1 495 2nd 1 female 24.0000 1 1 497 2nd 0 male 30.0000 0 0 498 2nd 0 male 40.0000 0 0 499 2nd 0 male 32.0000 0 0 500 2nd 0 male 30.0000 0 0 501 2nd 0 male 46.0000 0 0 502 2nd 1 female 13.0000 0 1 503 2nd 1 female 41.0000 0 1 504 2nd 1 male 19.0000 0 0 505 2nd 0 male 39.0000 0 0 506 2nd 0 male 48.0000 0 0 507 2nd 0 male 70.0000 0 0 508 2nd 0 male 27.0000 0 0 509 2nd 0 male 54.0000 0 0 510 2nd 0 male 39.0000 0 0 511 2nd 0 male 16.0000 0 0 512 2nd 0 male 62.0000 0 0 513 2nd 0 male 32.5000 1 0 514 2nd 1 female 14.0000 1 0 515 2nd 1 male 2.0000 1 1 516 2nd 1 male 3.0000 1 1 517 2nd 0 male 36.5000 0 2 518 2nd 0 male 26.0000 0 0 519 2nd 0 male 19.0000 1 1 520 2nd 0 male 28.0000 0 0 521 2nd 1 male 20.0000 0 0 522 2nd 1 female 29.0000 0 0 523 2nd 0 male 39.0000 0 0 524 2nd 1 male 22.0000 0 0 526 2nd 0 male 23.0000 0 0 527 2nd 1 male 29.0000 0 0 528 2nd 0 male 28.0000 0 0 530 2nd 1 female 50.0000 0 1 531 2nd 0 male 19.0000 0 0 533 2nd 0 male 41.0000 0 0 534 2nd 1 female 21.0000 0 1 535 2nd 1 female 19.0000 0 0 536 2nd 0 male 43.0000 0 1 537 2nd 1 female 32.0000 0 0 538 2nd 0 male 34.0000 0 0 539 2nd 1 male 30.0000 0 0 540 2nd 0 male 27.0000 0 0 541 2nd 1 female 2.0000 1 1 542 2nd 1 female 8.0000 1 1 543 2nd 1 female 33.0000 0 2 544 2nd 0 male 36.0000 0 0 545 2nd 0 male 34.0000 1 0 546 2nd 1 female 30.0000 3 0 547 2nd 1 female 28.0000 0 0 548 2nd 0 male 23.0000 0 0 549 2nd 1 male 0.8333 1 1 550 2nd 1 male 3.0000 1 1 551 2nd 1 female 24.0000 2 3 552 2nd 1 female 50.0000 0 0 553 2nd 0 male 19.0000 0 0 554 2nd 1 female 21.0000 0 0 555 2nd 0 male 26.0000 0 0 556 2nd 0 male 25.0000 0 0 557 2nd 0 male 27.0000 0 0 558 2nd 1 female 25.0000 0 1 559 2nd 1 female 18.0000 0 2 560 2nd 1 female 20.0000 0 0 561 2nd 1 female 30.0000 0 0 562 2nd 0 male 59.0000 0 0 563 2nd 1 female 30.0000 0 0 564 2nd 0 male 35.0000 0 0 565 2nd 1 female 40.0000 0 0 566 2nd 0 male 25.0000 0 0 567 2nd 0 male 41.0000 0 0 568 2nd 0 male 25.0000 0 0 569 2nd 0 male 18.5000 0 0 570 2nd 0 male 14.0000 0 0 571 2nd 1 female 50.0000 0 0 572 2nd 0 male 23.0000 0 0 573 2nd 1 female 28.0000 0 0 574 2nd 1 female 27.0000 0 0 575 2nd 0 male 29.0000 1 0 576 2nd 0 female 27.0000 1 0 577 2nd 0 male 40.0000 0 0 578 2nd 1 female 31.0000 0 0 579 2nd 0 male 30.0000 1 0 580 2nd 0 male 23.0000 1 0 581 2nd 1 female 31.0000 0 0 583 2nd 1 female 12.0000 0 0 584 2nd 1 female 40.0000 0 0 585 2nd 1 female 32.5000 0 0 586 2nd 0 male 27.0000 1 0 587 2nd 1 female 29.0000 1 0 588 2nd 1 male 2.0000 1 1 589 2nd 1 female 4.0000 1 1 590 2nd 1 female 29.0000 0 2 591 2nd 1 female 0.9167 1 2 592 2nd 1 female 5.0000 1 2 593 2nd 0 male 36.0000 1 2 594 2nd 1 female 33.0000 1 2 595 2nd 0 male 66.0000 0 0 597 2nd 1 male 31.0000 0 0 599 2nd 1 female 26.0000 0 0 600 2nd 0 female 24.0000 0 0 601 3rd 0 male 42.0000 0 0 602 3rd 0 male 13.0000 0 2 603 3rd 0 male 16.0000 1 1 604 3rd 1 female 35.0000 1 1 605 3rd 1 female 16.0000 0 0 606 3rd 1 male 25.0000 0 0 607 3rd 1 male 20.0000 0 0 608 3rd 1 female 18.0000 0 0 609 3rd 0 male 30.0000 0 0 610 3rd 0 male 26.0000 0 0 611 3rd 0 female 40.0000 1 0 612 3rd 1 male 0.8333 0 1 613 3rd 1 female 18.0000 0 1 614 3rd 1 male 26.0000 0 0 615 3rd 0 male 26.0000 0 0 616 3rd 0 male 20.0000 0 0 617 3rd 0 male 24.0000 0 0 618 3rd 0 male 25.0000 0 0 619 3rd 0 male 35.0000 0 0 620 3rd 0 male 18.0000 0 0 621 3rd 0 male 32.0000 0 0 622 3rd 1 female 19.0000 1 0 623 3rd 0 male 4.0000 4 2 624 3rd 0 female 6.0000 4 2 625 3rd 0 female 2.0000 4 2 626 3rd 1 female 17.0000 4 2 627 3rd 0 female 38.0000 4 2 628 3rd 0 female 9.0000 4 2 629 3rd 0 female 11.0000 4 2 630 3rd 0 male 39.0000 1 5 631 3rd 1 male 27.0000 0 0 632 3rd 0 male 26.0000 0 0 633 3rd 0 female 39.0000 1 5 634 3rd 0 male 20.0000 0 0 635 3rd 0 male 26.0000 0 0 636 3rd 0 male 25.0000 1 0 637 3rd 0 female 18.0000 1 0 638 3rd 0 male 24.0000 0 0 639 3rd 0 male 35.0000 0 0 640 3rd 0 male 5.0000 4 2 641 3rd 0 male 9.0000 4 2 642 3rd 1 male 3.0000 4 2 643 3rd 0 male 13.0000 4 2 644 3rd 1 female 5.0000 4 2 645 3rd 0 male 40.0000 1 5 646 3rd 1 male 23.0000 0 0 647 3rd 1 female 38.0000 1 5 648 3rd 1 female 45.0000 0 0 649 3rd 0 male 21.0000 0 0 650 3rd 0 male 23.0000 0 0 651 3rd 0 female 17.0000 0 0 652 3rd 0 male 30.0000 0 0 653 3rd 0 male 23.0000 0 0 654 3rd 1 female 13.0000 0 0 655 3rd 0 male 20.0000 0 0 656 3rd 0 male 32.0000 1 0 657 3rd 1 female 33.0000 3 0 658 3rd 1 female 0.7500 2 1 659 3rd 1 female 0.7500 2 1 660 3rd 1 female 5.0000 2 1 661 3rd 1 female 24.0000 0 3 662 3rd 1 female 18.0000 0 0 663 3rd 0 male 40.0000 0 0 664 3rd 0 male 26.0000 0 0 665 3rd 1 male 20.0000 0 0 666 3rd 0 female 18.0000 0 1 667 3rd 0 female 45.0000 0 1 668 3rd 0 female 27.0000 0 0 669 3rd 0 male 22.0000 0 0 670 3rd 0 male 19.0000 0 0 671 3rd 0 male 26.0000 0 0 672 3rd 0 male 22.0000 0 0 674 3rd 0 male 20.0000 0 0 675 3rd 1 male 32.0000 0 0 676 3rd 0 male 21.0000 0 0 677 3rd 0 male 18.0000 0 0 678 3rd 0 male 26.0000 0 0 679 3rd 0 male 6.0000 1 1 680 3rd 0 female 9.0000 1 1 684 3rd 0 male 40.0000 1 1 685 3rd 0 female 32.0000 1 1 686 3rd 0 male 21.0000 0 0 687 3rd 1 female 22.0000 0 0 688 3rd 0 female 20.0000 0 0 689 3rd 0 male 29.0000 1 0 690 3rd 0 male 22.0000 1 0 691 3rd 0 male 22.0000 0 0 692 3rd 0 male 35.0000 0 0 693 3rd 0 female 18.5000 0 0 694 3rd 1 male 21.0000 0 0 695 3rd 0 male 19.0000 0 0 696 3rd 0 female 18.0000 0 0 697 3rd 0 female 21.0000 0 0 698 3rd 0 female 30.0000 0 0 699 3rd 0 male 18.0000 0 0 700 3rd 0 male 38.0000 0 0 701 3rd 0 male 17.0000 0 0 702 3rd 0 male 17.0000 0 0 703 3rd 0 female 21.0000 0 0 704 3rd 0 male 21.0000 0 0 705 3rd 0 male 21.0000 0 0 708 3rd 0 male 28.0000 0 0 709 3rd 0 male 24.0000 0 0 710 3rd 1 female 16.0000 0 0 711 3rd 0 female 37.0000 0 0 712 3rd 0 male 28.0000 0 0 713 3rd 0 male 24.0000 0 0 714 3rd 0 male 21.0000 0 0 715 3rd 1 male 32.0000 0 0 716 3rd 0 male 29.0000 0 0 717 3rd 0 male 26.0000 1 0 718 3rd 0 male 18.0000 1 0 719 3rd 0 male 20.0000 0 0 720 3rd 1 male 18.0000 0 0 721 3rd 0 male 24.0000 0 0 722 3rd 0 male 36.0000 0 0 723 3rd 0 male 24.0000 0 0 724 3rd 0 male 31.0000 0 0 725 3rd 0 male 31.0000 0 0 726 3rd 1 female 22.0000 0 0 727 3rd 0 female 30.0000 0 0 728 3rd 0 male 70.5000 0 0 729 3rd 0 male 43.0000 0 0 730 3rd 0 male 35.0000 0 0 731 3rd 0 male 27.0000 0 0 732 3rd 0 male 19.0000 0 0 733 3rd 0 male 30.0000 0 0 734 3rd 1 male 9.0000 1 1 735 3rd 1 male 3.0000 1 1 736 3rd 1 female 36.0000 0 2 737 3rd 0 male 59.0000 0 0 738 3rd 0 male 19.0000 0 0 739 3rd 1 female 17.0000 0 1 740 3rd 0 male 44.0000 0 1 741 3rd 0 male 17.0000 0 0 742 3rd 0 male 22.5000 0 0 743 3rd 1 male 45.0000 0 0 744 3rd 0 female 22.0000 0 0 745 3rd 0 male 19.0000 0 0 746 3rd 1 female 30.0000 0 0 747 3rd 1 male 29.0000 0 0 748 3rd 0 male 0.3333 0 2 749 3rd 0 male 34.0000 1 1 750 3rd 0 female 28.0000 1 1 751 3rd 0 male 27.0000 0 0 752 3rd 0 male 25.0000 0 0 753 3rd 0 male 24.0000 2 0 754 3rd 0 male 22.0000 0 0 755 3rd 0 male 21.0000 2 0 756 3rd 0 male 17.0000 2 0 759 3rd 1 male 36.5000 1 0 760 3rd 1 female 36.0000 1 0 761 3rd 1 male 30.0000 0 0 762 3rd 0 male 16.0000 0 0 763 3rd 1 male 1.0000 1 2 764 3rd 1 female 0.1667 1 2 765 3rd 0 male 26.0000 1 2 766 3rd 1 female 33.0000 1 2 767 3rd 0 male 25.0000 0 0 770 3rd 0 male 22.0000 0 0 771 3rd 0 male 36.0000 0 0 772 3rd 1 female 19.0000 0 0 773 3rd 0 male 17.0000 0 0 774 3rd 0 male 42.0000 0 0 775 3rd 0 male 43.0000 0 0 777 3rd 0 male 32.0000 0 0 778 3rd 1 male 19.0000 0 0 779 3rd 1 female 30.0000 0 0 780 3rd 0 female 24.0000 0 0 781 3rd 1 female 23.0000 0 0 782 3rd 0 male 33.0000 0 0 783 3rd 0 male 65.0000 0 0 784 3rd 1 male 24.0000 0 0 785 3rd 0 male 23.0000 1 0 786 3rd 1 female 22.0000 1 0 787 3rd 0 male 18.0000 0 0 788 3rd 0 male 16.0000 0 0 789 3rd 0 male 45.0000 0 0 791 3rd 0 male 39.0000 0 2 792 3rd 0 male 17.0000 1 1 793 3rd 0 male 15.0000 1 1 794 3rd 0 male 47.0000 0 0 795 3rd 1 female 5.0000 0 0 797 3rd 0 male 40.5000 0 0 798 3rd 0 male 40.5000 0 0 800 3rd 0 male 18.0000 0 0 804 3rd 0 male 26.0000 0 0 807 3rd 0 female 21.0000 2 2 808 3rd 0 female 9.0000 2 2 810 3rd 0 male 18.0000 2 2 811 3rd 0 male 16.0000 1 3 812 3rd 0 female 48.0000 1 3 815 3rd 0 male 25.0000 0 0 818 3rd 0 male 22.0000 0 0 819 3rd 1 female 16.0000 0 0 821 3rd 1 male 9.0000 0 2 822 3rd 0 male 33.0000 1 1 823 3rd 0 male 41.0000 0 0 824 3rd 1 female 31.0000 1 1 825 3rd 0 male 38.0000 0 0 826 3rd 0 male 9.0000 5 2 827 3rd 0 male 1.0000 5 2 828 3rd 0 male 11.0000 5 2 829 3rd 0 female 10.0000 5 2 830 3rd 0 female 16.0000 5 2 831 3rd 0 male 14.0000 5 2 832 3rd 0 male 40.0000 1 6 833 3rd 0 female 43.0000 1 6 834 3rd 0 male 51.0000 0 0 835 3rd 0 male 32.0000 0 0 837 3rd 0 male 20.0000 0 0 838 3rd 0 male 37.0000 2 0 839 3rd 0 male 28.0000 2 0 840 3rd 0 male 19.0000 0 0 841 3rd 0 female 24.0000 0 0 842 3rd 0 female 17.0000 0 0 845 3rd 0 male 28.0000 1 0 846 3rd 1 female 24.0000 1 0 847 3rd 0 male 20.0000 0 0 848 3rd 0 male 23.5000 0 0 849 3rd 0 male 41.0000 2 0 850 3rd 0 male 26.0000 1 0 851 3rd 0 male 21.0000 0 0 852 3rd 1 female 45.0000 1 0 854 3rd 0 male 25.0000 0 0 856 3rd 0 male 11.0000 0 0 858 3rd 1 male 27.0000 0 0 860 3rd 0 female 18.0000 0 0 861 3rd 1 female 26.0000 0 0 862 3rd 0 female 23.0000 0 0 863 3rd 1 female 22.0000 0 0 864 3rd 0 male 28.0000 0 0 865 3rd 0 female 28.0000 0 0 867 3rd 1 female 2.0000 0 1 868 3rd 1 female 22.0000 1 1 869 3rd 0 male 43.0000 0 0 870 3rd 0 male 28.0000 0 0 871 3rd 1 female 27.0000 0 0 874 3rd 0 male 42.0000 0 0 876 3rd 0 male 30.0000 0 0 878 3rd 0 female 27.0000 1 0 879 3rd 0 female 25.0000 1 0 881 3rd 1 male 29.0000 0 0 882 3rd 1 male 21.0000 0 0 884 3rd 0 male 20.0000 0 0 885 3rd 0 male 48.0000 0 0 886 3rd 0 male 17.0000 1 0 889 3rd 0 male 34.0000 0 0 890 3rd 1 male 26.0000 0 0 891 3rd 0 male 22.0000 0 0 892 3rd 0 male 33.0000 0 0 893 3rd 0 male 31.0000 0 0 894 3rd 0 male 29.0000 0 0 895 3rd 1 male 4.0000 1 1 896 3rd 1 female 1.0000 1 1 897 3rd 0 male 49.0000 0 0 898 3rd 0 male 33.0000 0 0 899 3rd 0 male 19.0000 0 0 900 3rd 1 female 27.0000 0 2 905 3rd 0 male 23.0000 0 0 906 3rd 1 male 32.0000 0 0 907 3rd 0 male 27.0000 0 0 908 3rd 0 female 20.0000 1 0 909 3rd 0 female 21.0000 1 0 910 3rd 1 male 32.0000 0 0 911 3rd 0 male 17.0000 0 0 912 3rd 0 male 21.0000 0 0 913 3rd 0 male 30.0000 0 0 914 3rd 1 male 21.0000 0 0 915 3rd 0 male 33.0000 0 0 916 3rd 0 male 22.0000 0 0 917 3rd 1 female 4.0000 0 1 918 3rd 1 male 39.0000 0 1 920 3rd 0 male 18.5000 0 0 925 3rd 0 male 34.5000 0 0 926 3rd 0 male 44.0000 0 0 933 3rd 0 female 22.0000 2 0 934 3rd 0 male 26.0000 2 0 935 3rd 1 female 4.0000 0 2 936 3rd 1 male 29.0000 3 1 937 3rd 1 female 26.0000 1 1 938 3rd 0 female 1.0000 1 1 939 3rd 0 male 18.0000 1 1 940 3rd 0 female 36.0000 0 2 942 3rd 1 male 25.0000 0 0 944 3rd 0 female 37.0000 0 0 948 3rd 1 female 22.0000 0 0 950 3rd 1 male 26.0000 0 0 951 3rd 0 male 29.0000 0 0 952 3rd 0 male 29.0000 0 0 953 3rd 0 male 22.0000 0 0 954 3rd 1 male 22.0000 0 0 960 3rd 0 male 32.0000 0 0 961 3rd 0 male 34.5000 0 0 964 3rd 0 male 36.0000 0 0 965 3rd 0 male 39.0000 0 0 966 3rd 0 male 24.0000 0 0 967 3rd 0 female 25.0000 0 0 968 3rd 0 female 45.0000 0 0 969 3rd 0 male 36.0000 1 0 970 3rd 0 female 30.0000 1 0 971 3rd 1 male 20.0000 1 0 973 3rd 0 male 28.0000 0 0 975 3rd 0 male 30.0000 1 0 976 3rd 0 female 26.0000 1 0 978 3rd 0 male 20.5000 0 0 979 3rd 1 male 27.0000 0 0 980 3rd 0 male 51.0000 0 0 981 3rd 1 female 23.0000 0 0 982 3rd 1 male 32.0000 0 0 986 3rd 1 male 24.0000 0 0 987 3rd 0 male 22.0000 0 0 991 3rd 0 male 29.0000 0 0 993 3rd 0 female 30.5000 0 0 996 3rd 0 male 35.0000 0 0 997 3rd 0 male 33.0000 0 0 1008 3rd 1 female 15.0000 0 0 1009 3rd 0 female 35.0000 0 0 1011 3rd 0 male 24.0000 1 0 1012 3rd 0 female 19.0000 1 0 1016 3rd 0 male 55.5000 0 0 1018 3rd 1 male 21.0000 0 0 1020 3rd 0 male 24.0000 0 0 1021 3rd 0 male 21.0000 0 0 1022 3rd 0 male 28.0000 0 0 1025 3rd 0 male 25.0000 0 0 1026 3rd 1 male 6.0000 0 1 1027 3rd 1 female 27.0000 0 1 1032 3rd 0 male 34.0000 0 0 1041 3rd 1 female 24.0000 0 0 1046 3rd 0 male 18.0000 0 0 1047 3rd 0 male 22.0000 0 0 1048 3rd 1 female 15.0000 0 0 1049 3rd 1 female 1.0000 0 2 1050 3rd 1 male 20.0000 1 1 1051 3rd 1 female 19.0000 1 1 1052 3rd 0 male 33.0000 0 0 1057 3rd 1 male 12.0000 1 0 1058 3rd 1 female 14.0000 1 0 1059 3rd 0 female 29.0000 0 0 1060 3rd 0 male 28.0000 0 0 1061 3rd 1 female 18.0000 0 0 1062 3rd 1 female 26.0000 0 0 1063 3rd 0 male 21.0000 0 0 1064 3rd 0 male 41.0000 0 0 1065 3rd 1 male 39.0000 0 0 1066 3rd 0 male 21.0000 0 0 1067 3rd 0 male 28.5000 0 0 1068 3rd 1 female 22.0000 0 0 1069 3rd 0 male 61.0000 0 0 1076 3rd 0 male 23.0000 0 0 1080 3rd 1 female 22.0000 0 0 1083 3rd 1 male 9.0000 0 1 1084 3rd 0 male 28.0000 0 0 1085 3rd 0 male 42.0000 0 1 1087 3rd 0 female 31.0000 0 0 1088 3rd 0 male 28.0000 0 0 1089 3rd 1 male 32.0000 0 0 1090 3rd 0 male 20.0000 0 0 1091 3rd 0 female 23.0000 0 0 1092 3rd 0 female 20.0000 0 0 1093 3rd 0 male 20.0000 0 0 1094 3rd 0 male 16.0000 0 0 1095 3rd 1 female 31.0000 0 0 1097 3rd 0 male 2.0000 3 1 1098 3rd 0 male 6.0000 3 1 1099 3rd 0 female 3.0000 3 1 1100 3rd 0 female 8.0000 3 1 1101 3rd 0 female 29.0000 0 4 1102 3rd 0 male 1.0000 4 1 1103 3rd 0 male 7.0000 4 1 1104 3rd 0 male 2.0000 4 1 1105 3rd 0 male 16.0000 4 1 1106 3rd 0 male 14.0000 4 1 1107 3rd 0 female 41.0000 0 5 1108 3rd 0 male 21.0000 0 0 1109 3rd 0 male 19.0000 0 0 1111 3rd 0 male 32.0000 0 0 1112 3rd 0 male 0.7500 1 1 1113 3rd 0 female 3.0000 1 1 1114 3rd 0 female 26.0000 0 2 1118 3rd 0 male 21.0000 0 0 1119 3rd 0 male 25.0000 0 0 1120 3rd 0 male 22.0000 0 0 1121 3rd 1 male 25.0000 1 0 1126 3rd 0 male 24.0000 0 0 1127 3rd 0 female 28.0000 0 0 1128 3rd 0 male 19.0000 0 0 1130 3rd 0 male 25.0000 1 0 1131 3rd 0 female 18.0000 0 0 1132 3rd 1 male 32.0000 0 0 1134 3rd 0 male 17.0000 0 0 1135 3rd 0 male 24.0000 0 0 1140 3rd 0 male 38.0000 0 0 1141 3rd 0 male 21.0000 0 0 1142 3rd 0 male 10.0000 4 1 1143 3rd 0 male 4.0000 4 1 1144 3rd 0 male 7.0000 4 1 1145 3rd 0 male 2.0000 4 1 1146 3rd 0 male 8.0000 4 1 1147 3rd 0 female 39.0000 0 5 1148 3rd 0 female 22.0000 0 0 1149 3rd 0 male 35.0000 0 0 1153 3rd 0 male 50.0000 1 0 1154 3rd 0 female 47.0000 1 0 1157 3rd 0 female 2.0000 1 1 1158 3rd 0 male 18.0000 1 1 1159 3rd 0 female 41.0000 0 2 1161 3rd 0 male 50.0000 0 0 1162 3rd 0 male 16.0000 0 0 1166 3rd 0 male 25.0000 0 0 1170 3rd 0 male 38.5000 0 0 1172 3rd 0 male 14.5000 8 2 1182 3rd 0 male 24.0000 0 0 1183 3rd 1 female 21.0000 0 0 1184 3rd 0 male 39.0000 0 0 1188 3rd 1 female 1.0000 1 1 1189 3rd 1 female 24.0000 0 2 1190 3rd 1 female 4.0000 1 1 1191 3rd 1 male 25.0000 0 0 1192 3rd 0 male 20.0000 0 0 1193 3rd 0 male 24.5000 0 0 1197 3rd 1 male 29.0000 0 0 1202 3rd 0 male 22.0000 0 0 1204 3rd 0 male 40.0000 0 0 1205 3rd 0 male 21.0000 0 0 1206 3rd 1 female 18.0000 0 0 1207 3rd 0 male 4.0000 3 2 1208 3rd 0 male 10.0000 3 2 1209 3rd 0 female 9.0000 3 2 1210 3rd 0 female 2.0000 3 2 1211 3rd 0 male 40.0000 1 4 1212 3rd 0 female 45.0000 1 4 1218 3rd 0 male 19.0000 0 0 1219 3rd 0 male 30.0000 0 0 1221 3rd 0 male 32.0000 0 0 1223 3rd 0 male 33.0000 0 0 1224 3rd 1 female 23.0000 0 0 1225 3rd 0 male 21.0000 0 0 1226 3rd 0 male 60.5000 0 0 1227 3rd 0 male 19.0000 0 0 1228 3rd 0 female 22.0000 0 0 1229 3rd 1 male 31.0000 0 0 1230 3rd 0 male 27.0000 0 0 1231 3rd 0 female 2.0000 0 1 1232 3rd 0 female 29.0000 1 1 1233 3rd 1 male 16.0000 0 0 1234 3rd 1 male 44.0000 0 0 1235 3rd 0 male 25.0000 0 0 1236 3rd 0 male 74.0000 0 0 1237 3rd 1 male 14.0000 0 0 1238 3rd 0 male 24.0000 0 0 1239 3rd 1 male 25.0000 0 0 1240 3rd 0 male 34.0000 0 0 1241 3rd 1 male 0.4167 0 1 1245 3rd 1 female 16.0000 1 1 1249 3rd 0 male 32.0000 0 0 1252 3rd 0 male 30.5000 0 0 1253 3rd 0 male 44.0000 0 0 1255 3rd 1 male 25.0000 0 0 1257 3rd 1 male 7.0000 1 1 1258 3rd 1 female 9.0000 1 1 1259 3rd 1 female 29.0000 0 2 1260 3rd 0 male 36.0000 0 0 1261 3rd 1 female 18.0000 0 0 1262 3rd 1 female 63.0000 0 0 1264 3rd 0 male 11.5000 1 1 1265 3rd 0 male 40.5000 0 2 1266 3rd 0 female 10.0000 0 2 1267 3rd 0 male 36.0000 1 1 1268 3rd 0 female 30.0000 1 1 1270 3rd 0 male 33.0000 0 0 1271 3rd 0 male 28.0000 0 0 1272 3rd 0 male 28.0000 0 0 1273 3rd 0 male 47.0000 0 0 1274 3rd 0 female 18.0000 2 0 1275 3rd 0 male 31.0000 3 0 1276 3rd 0 male 16.0000 2 0 1277 3rd 0 female 31.0000 1 0 1278 3rd 1 male 22.0000 0 0 1279 3rd 0 male 20.0000 0 0 1280 3rd 0 female 14.0000 0 0 1281 3rd 0 male 22.0000 0 0 1282 3rd 0 male 22.0000 0 0 1286 3rd 0 male 32.5000 0 0 1287 3rd 1 female 38.0000 0 0 1288 3rd 0 male 51.0000 0 0 1289 3rd 0 male 18.0000 1 0 1290 3rd 0 male 21.0000 1 0 1291 3rd 1 female 47.0000 1 0 1295 3rd 0 male 28.5000 0 0 1296 3rd 0 male 21.0000 0 0 1297 3rd 0 male 27.0000 0 0 1299 3rd 0 male 36.0000 0 0 1300 3rd 0 male 27.0000 1 0 1301 3rd 1 female 15.0000 1 0 1302 3rd 0 male 45.5000 0 0 1305 3rd 0 female 14.5000 1 0 1307 3rd 0 male 26.5000 0 0 1308 3rd 0 male 27.0000 0 0 1309 3rd 0 male 29.0000 0 0 $y survived [1,] 1 [2,] 1 [3,] 0 [4,] 0 [5,] 0 [6,] 1 [7,] 1 [8,] 0 [9,] 1 [10,] 0 [11,] 0 [12,] 1 [13,] 1 [14,] 1 [15,] 1 [16,] 0 [17,] 1 [18,] 1 [19,] 0 [20,] 1 [21,] 1 [22,] 1 [23,] 1 [24,] 1 [25,] 0 [26,] 1 [27,] 1 [28,] 1 [29,] 1 [30,] 0 [31,] 1 [32,] 1 [33,] 1 [34,] 0 [35,] 1 [36,] 1 [37,] 0 [38,] 0 [39,] 1 [40,] 1 [41,] 1 [42,] 1 [43,] 0 [44,] 1 [45,] 1 [46,] 1 [47,] 1 [48,] 0 [49,] 0 [50,] 0 [51,] 1 [52,] 1 [53,] 1 [54,] 1 [55,] 0 [56,] 0 [57,] 1 [58,] 0 [59,] 1 [60,] 1 [61,] 1 [62,] 1 [63,] 1 [64,] 1 [65,] 0 [66,] 1 [67,] 1 [68,] 0 [69,] 1 [70,] 0 [71,] 1 [72,] 1 [73,] 0 [74,] 1 [75,] 1 [76,] 0 [77,] 1 [78,] 1 [79,] 1 [80,] 1 [81,] 0 [82,] 1 [83,] 1 [84,] 1 [85,] 1 [86,] 1 [87,] 1 [88,] 0 [89,] 1 [90,] 1 [91,] 1 [92,] 1 [93,] 0 [94,] 1 [95,] 1 [96,] 1 [97,] 0 [98,] 1 [99,] 0 [100,] 1 [101,] 1 [102,] 1 [103,] 0 [104,] 0 [105,] 1 [106,] 1 [107,] 1 [108,] 1 [109,] 1 [110,] 1 [111,] 1 [112,] 0 [113,] 1 [114,] 0 [115,] 1 [116,] 1 [117,] 1 [118,] 0 [119,] 1 [120,] 0 [121,] 1 [122,] 1 [123,] 0 [124,] 1 [125,] 1 [126,] 1 [127,] 0 [128,] 1 [129,] 1 [130,] 1 [131,] 1 [132,] 0 [133,] 1 [134,] 0 [135,] 1 [136,] 1 [137,] 0 [138,] 1 [139,] 0 [140,] 0 [141,] 1 [142,] 1 [143,] 1 [144,] 0 [145,] 1 [146,] 1 [147,] 1 [148,] 1 [149,] 1 [150,] 0 [151,] 1 [152,] 0 [153,] 0 [154,] 0 [155,] 0 [156,] 0 [157,] 1 [158,] 1 [159,] 1 [160,] 1 [161,] 1 [162,] 1 [163,] 0 [164,] 1 [165,] 1 [166,] 1 [167,] 0 [168,] 1 [169,] 0 [170,] 1 [171,] 1 [172,] 0 [173,] 1 [174,] 0 [175,] 1 [176,] 1 [177,] 0 [178,] 0 [179,] 1 [180,] 0 [181,] 0 [182,] 0 [183,] 1 [184,] 1 [185,] 1 [186,] 0 [187,] 0 [188,] 0 [189,] 1 [190,] 1 [191,] 0 [192,] 1 [193,] 0 [194,] 1 [195,] 1 [196,] 0 [197,] 0 [198,] 0 [199,] 0 [200,] 0 [201,] 1 [202,] 0 [203,] 1 [204,] 1 [205,] 1 [206,] 0 [207,] 1 [208,] 0 [209,] 0 [210,] 1 [211,] 0 [212,] 1 [213,] 1 [214,] 0 [215,] 0 [216,] 1 [217,] 0 [218,] 1 [219,] 0 [220,] 1 [221,] 1 [222,] 1 [223,] 0 [224,] 1 [225,] 1 [226,] 1 [227,] 1 [228,] 1 [229,] 1 [230,] 1 [231,] 0 [232,] 1 [233,] 1 [234,] 1 [235,] 0 [236,] 0 [237,] 0 [238,] 1 [239,] 1 [240,] 1 [241,] 1 [242,] 1 [243,] 1 [244,] 0 [245,] 1 [246,] 0 [247,] 1 [248,] 1 [249,] 1 [250,] 1 [251,] 0 [252,] 0 [253,] 0 [254,] 1 [255,] 1 [256,] 0 [257,] 1 [258,] 1 [259,] 0 [260,] 1 [261,] 1 [262,] 1 [263,] 0 [264,] 0 [265,] 0 [266,] 1 [267,] 0 [268,] 1 [269,] 0 [270,] 0 [271,] 0 [272,] 1 [273,] 1 [274,] 0 [275,] 1 [276,] 0 [277,] 0 [278,] 1 [279,] 1 [280,] 0 [281,] 1 [282,] 1 [283,] 0 [284,] 1 [285,] 0 [286,] 1 [287,] 0 [288,] 0 [289,] 0 [290,] 0 [291,] 1 [292,] 0 [293,] 0 [294,] 0 [295,] 1 [296,] 0 [297,] 0 [298,] 1 [299,] 1 [300,] 0 [301,] 1 [302,] 1 [303,] 1 [304,] 1 [305,] 1 [306,] 1 [307,] 0 [308,] 0 [309,] 0 [310,] 0 [311,] 1 [312,] 1 [313,] 0 [314,] 1 [315,] 1 [316,] 0 [317,] 1 [318,] 0 [319,] 0 [320,] 1 [321,] 1 [322,] 1 [323,] 1 [324,] 1 [325,] 0 [326,] 0 [327,] 0 [328,] 0 [329,] 0 [330,] 0 [331,] 1 [332,] 1 [333,] 0 [334,] 1 [335,] 0 [336,] 0 [337,] 1 [338,] 1 [339,] 0 [340,] 1 [341,] 1 [342,] 0 [343,] 0 [344,] 1 [345,] 0 [346,] 1 [347,] 1 [348,] 0 [349,] 0 [350,] 0 [351,] 1 [352,] 0 [353,] 0 [354,] 1 [355,] 1 [356,] 0 [357,] 1 [358,] 0 [359,] 1 [360,] 1 [361,] 1 [362,] 0 [363,] 0 [364,] 0 [365,] 0 [366,] 1 [367,] 0 [368,] 0 [369,] 0 [370,] 0 [371,] 0 [372,] 0 [373,] 1 [374,] 0 [375,] 0 [376,] 0 [377,] 0 [378,] 0 [379,] 0 [380,] 0 [381,] 0 [382,] 0 [383,] 0 [384,] 0 [385,] 1 [386,] 1 [387,] 0 [388,] 1 [389,] 0 [390,] 1 [391,] 0 [392,] 1 [393,] 0 [394,] 1 [395,] 1 [396,] 1 [397,] 0 [398,] 1 [399,] 1 [400,] 0 [401,] 0 [402,] 0 [403,] 0 [404,] 1 [405,] 0 [406,] 0 [407,] 1 [408,] 0 [409,] 0 [410,] 1 [411,] 0 [412,] 1 [413,] 0 [414,] 0 [415,] 0 [416,] 1 [417,] 0 [418,] 1 [419,] 0 [420,] 0 [421,] 0 [422,] 0 [423,] 1 [424,] 0 [425,] 1 [426,] 0 [427,] 0 [428,] 1 [429,] 0 [430,] 0 [431,] 0 [432,] 0 [433,] 1 [434,] 1 [435,] 0 [436,] 1 [437,] 1 [438,] 1 [439,] 0 [440,] 0 [441,] 0 [442,] 0 [443,] 1 [444,] 0 [445,] 1 [446,] 0 [447,] 1 [448,] 0 [449,] 0 [450,] 0 [451,] 0 [452,] 0 [453,] 1 [454,] 1 [455,] 1 [456,] 0 [457,] 0 [458,] 0 [459,] 0 [460,] 0 [461,] 0 [462,] 0 [463,] 0 [464,] 0 [465,] 1 [466,] 1 [467,] 1 [468,] 0 [469,] 0 [470,] 0 [471,] 0 [472,] 1 [473,] 1 [474,] 0 [475,] 1 [476,] 0 [477,] 1 [478,] 0 [479,] 1 [480,] 0 [481,] 0 [482,] 1 [483,] 1 [484,] 0 [485,] 1 [486,] 0 [487,] 1 [488,] 0 [489,] 1 [490,] 1 [491,] 1 [492,] 0 [493,] 0 [494,] 1 [495,] 1 [496,] 0 [497,] 1 [498,] 1 [499,] 1 [500,] 1 [501,] 0 [502,] 1 [503,] 0 [504,] 0 [505,] 0 [506,] 1 [507,] 1 [508,] 1 [509,] 1 [510,] 0 [511,] 1 [512,] 0 [513,] 1 [514,] 0 [515,] 0 [516,] 0 [517,] 0 [518,] 0 [519,] 1 [520,] 0 [521,] 1 [522,] 1 [523,] 0 [524,] 0 [525,] 0 [526,] 1 [527,] 0 [528,] 0 [529,] 1 [530,] 1 [531,] 1 [532,] 1 [533,] 0 [534,] 1 [535,] 1 [536,] 1 [537,] 1 [538,] 1 [539,] 1 [540,] 0 [541,] 1 [542,] 0 [543,] 1 [544,] 1 [545,] 0 [546,] 0 [547,] 0 [548,] 0 [549,] 1 [550,] 1 [551,] 1 [552,] 1 [553,] 1 [554,] 0 [555,] 0 [556,] 0 [557,] 1 [558,] 1 [559,] 1 [560,] 0 [561,] 0 [562,] 0 [563,] 0 [564,] 0 [565,] 0 [566,] 0 [567,] 1 [568,] 0 [569,] 0 [570,] 0 [571,] 1 [572,] 0 [573,] 0 [574,] 0 [575,] 0 [576,] 1 [577,] 0 [578,] 0 [579,] 0 [580,] 0 [581,] 0 [582,] 0 [583,] 0 [584,] 0 [585,] 0 [586,] 0 [587,] 1 [588,] 0 [589,] 1 [590,] 0 [591,] 1 [592,] 1 [593,] 1 [594,] 0 [595,] 0 [596,] 0 [597,] 0 [598,] 0 [599,] 1 [600,] 0 [601,] 0 [602,] 1 [603,] 1 [604,] 1 [605,] 1 [606,] 1 [607,] 1 [608,] 0 [609,] 0 [610,] 1 [611,] 0 [612,] 0 [613,] 0 [614,] 0 [615,] 0 [616,] 0 [617,] 0 [618,] 0 [619,] 1 [620,] 0 [621,] 0 [622,] 0 [623,] 0 [624,] 0 [625,] 0 [626,] 0 [627,] 0 [628,] 1 [629,] 0 [630,] 0 [631,] 0 [632,] 0 [633,] 0 [634,] 0 [635,] 1 [636,] 0 [637,] 0 [638,] 0 [639,] 0 [640,] 0 [641,] 0 [642,] 0 [643,] 0 [644,] 0 [645,] 0 [646,] 0 [647,] 0 [648,] 0 [649,] 1 [650,] 0 [651,] 0 [652,] 0 [653,] 0 [654,] 1 [655,] 0 [656,] 0 [657,] 0 [658,] 0 [659,] 1 [660,] 0 [661,] 0 [662,] 0 [663,] 0 [664,] 0 [665,] 1 [666,] 0 [667,] 0 [668,] 0 [669,] 0 [670,] 0 [671,] 0 [672,] 0 [673,] 1 [674,] 1 [675,] 1 [676,] 0 [677,] 0 [678,] 1 [679,] 0 [680,] 0 [681,] 0 [682,] 1 [683,] 0 [684,] 0 [685,] 1 [686,] 1 [687,] 0 [688,] 0 [689,] 0 [690,] 0 [691,] 0 [692,] 0 [693,] 0 [694,] 0 [695,] 0 [696,] 1 [697,] 1 [698,] 1 [699,] 0 [700,] 1 [701,] 1 [702,] 0 [703,] 1 [704,] 0 [705,] 0 [706,] 0 [707,] 1 [708,] 0 [709,] 0 [710,] 0 [711,] 0 [712,] 1 [713,] 1 [714,] 0 [715,] 1 [716,] 0 [717,] 0 [718,] 1 [719,] 0 [720,] 1 [721,] 0 [722,] 0 [723,] 0 [724,] 0 [725,] 0 [726,] 0 [727,] 0 [728,] 1 [729,] 0 [730,] 0 [731,] 0 [732,] 0 [733,] 0 [734,] 0 [735,] 0 [736,] 0 [737,] 0 [738,] 0 [739,] 0 [740,] 1 [741,] 1 [742,] 0 [743,] 0 [744,] 1 [745,] 0 [746,] 0 [747,] 0 [748,] 0 [749,] 0 [750,] 0 [751,] 0 [752,] 0 [753,] 0 [754,] 0 [755,] 0 [756,] 0 [757,] 0 [758,] 0 [759,] 0 [760,] 0 [761,] 0 [762,] 0 [763,] 1 [764,] 0 [765,] 0 [766,] 0 [767,] 0 [768,] 0 [769,] 1 [770,] 0 [771,] 0 [772,] 1 [773,] 0 [774,] 1 [775,] 0 [776,] 1 [777,] 0 [778,] 0 [779,] 1 [780,] 1 [781,] 0 [782,] 0 [783,] 1 [784,] 0 [785,] 0 [786,] 0 [787,] 0 [788,] 1 [789,] 1 [790,] 0 [791,] 0 [792,] 0 [793,] 0 [794,] 1 [795,] 0 [796,] 0 [797,] 0 [798,] 0 [799,] 1 [800,] 1 [801,] 0 [802,] 0 [803,] 0 [804,] 1 [805,] 0 [806,] 1 [807,] 0 [808,] 0 [809,] 0 [810,] 1 [811,] 0 [812,] 0 [813,] 0 [814,] 1 [815,] 0 [816,] 0 [817,] 1 [818,] 1 [819,] 0 [820,] 0 [821,] 0 [822,] 0 [823,] 0 [824,] 1 [825,] 1 [826,] 1 [827,] 0 [828,] 0 [829,] 0 [830,] 1 [831,] 0 [832,] 1 [833,] 1 [834,] 0 [835,] 0 [836,] 0 [837,] 1 [838,] 0 [839,] 0 [840,] 0 [841,] 0 [842,] 0 [843,] 0 [844,] 0 [845,] 0 [846,] 0 [847,] 1 [848,] 0 [849,] 0 [850,] 0 [851,] 0 [852,] 1 [853,] 0 [854,] 1 [855,] 1 [856,] 1 [857,] 0 [858,] 0 [859,] 0 [860,] 0 [861,] 0 [862,] 1 [863,] 0 [864,] 0 [865,] 0 [866,] 0 [867,] 1 [868,] 0 [869,] 0 [870,] 0 [871,] 0 [872,] 1 [873,] 1 [874,] 0 [875,] 1 [876,] 0 [877,] 0 [878,] 1 [879,] 1 [880,] 1 [881,] 1 [882,] 0 [883,] 1 [884,] 1 [885,] 0 [886,] 0 [887,] 1 [888,] 1 [889,] 0 [890,] 0 [891,] 1 [892,] 0 [893,] 0 [894,] 1 [895,] 0 [896,] 0 [897,] 1 [898,] 1 [899,] 0 [900,] 0 [901,] 0 [902,] 0 [903,] 1 [904,] 0 [905,] 0 [906,] 0 [907,] 0 [908,] 0 [909,] 1 [910,] 0 [911,] 0 [912,] 0 [913,] 0 [914,] 0 [915,] 0 [916,] 0 [917,] 0 [918,] 0 [919,] 0 [920,] 0 [921,] 0 [922,] 0 [923,] 0 [924,] 0 [925,] 0 [926,] 0 [927,] 0 [928,] 0 [929,] 0 [930,] 1 [931,] 0 [932,] 0 [933,] 0 [934,] 0 [935,] 0 [936,] 1 [937,] 0 [938,] 0 [939,] 0 [940,] 0 [941,] 0 [942,] 0 [943,] 0 [944,] 0 [945,] 0 [946,] 0 [947,] 0 [948,] 0 [949,] 0 [950,] 0 [951,] 0 [952,] 0 [953,] 0 [954,] 0 [955,] 0 [956,] 0 [957,] 0 [958,] 0 [959,] 0 [960,] 1 [961,] 0 [962,] 1 [963,] 1 [964,] 1 [965,] 1 [966,] 0 [967,] 0 [968,] 1 [969,] 0 [970,] 0 [971,] 0 [972,] 1 [973,] 0 [974,] 0 [975,] 0 [976,] 0 [977,] 0 [978,] 0 [979,] 0 [980,] 0 [981,] 0 [982,] 0 [983,] 1 [984,] 0 [985,] 0 [986,] 0 [987,] 0 [988,] 1 [989,] 0 [990,] 0 [991,] 0 [992,] 1 [993,] 1 [994,] 0 [995,] 0 [996,] 1 [997,] 0 [998,] 1 [999,] 0 [1000,] 1 [1001,] 1 [1002,] 0 [1003,] 0 [1004,] 0 [1005,] 1 [1006,] 1 [1007,] 1 [1008,] 1 [1009,] 0 [1010,] 1 [1011,] 1 [1012,] 0 [1013,] 0 [1014,] 0 [1015,] 0 [1016,] 0 [1017,] 0 [1018,] 0 [1019,] 0 [1020,] 0 [1021,] 0 [1022,] 0 [1023,] 0 [1024,] 0 [1025,] 1 [1026,] 0 [1027,] 0 [1028,] 0 [1029,] 0 [1030,] 0 [1031,] 1 [1032,] 0 [1033,] 0 [1034,] 0 [1035,] 1 [1036,] 0 [1037,] 0 [1038,] 0 [1039,] 0 [1040,] 0 [1041,] 1 [1042,] 0 [1043,] 0 [1044,] 0 [1045,] 0 [1046,] 0 $cv.list $cv.list$fold1 Selected 8 of 15 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 1 6 GCV 0.136884 RSS 109.1528 GRSq 0.435009 RSq 0.4584988 $cv.list$fold2 Selected 7 of 15 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 1 5 GCV 0.1423817 RSS 115.2301 GRSq 0.4107654 RSq 0.4316216 $cv.list$fold3 Selected 9 of 15 terms, and 5 of 6 predictors Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, age, pclass2nd, sibsp, parch-unused Number of terms at each degree of interaction: 1 1 7 GCV 0.1352779 RSS 108.0228 GRSq 0.4408923 RSq 0.4672305 $cv.list$fold4 Selected 8 of 15 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 2 5 GCV 0.1502926 RSS 119.5444 GRSq 0.3806768 RSq 0.4064867 $cv.list$fold5 Selected 9 of 16 terms, and 6 of 6 predictors Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, age, pclass2nd, sibsp, parch Number of terms at each degree of interaction: 1 3 5 GCV 0.1385498 RSS 110.2201 GRSq 0.4280118 RSq 0.4550523 $cv.nterms.selected.by.gcv fold1 fold2 fold3 fold4 fold5 mean 8.0 7.0 9.0 8.0 9.0 8.2 $cv.nvars.selected.by.gcv fold1 fold2 fold3 fold4 fold5 mean 5.0 5.0 5.0 5.0 6.0 5.2 $cv.groups cross fold [1,] 1 1 [2,] 1 5 [3,] 1 1 [4,] 1 5 [5,] 1 1 [6,] 1 3 [7,] 1 3 [8,] 1 3 [9,] 1 1 [10,] 1 1 [11,] 1 3 [12,] 1 3 [13,] 1 4 [14,] 1 2 [15,] 1 3 [16,] 1 3 [17,] 1 2 [18,] 1 4 [19,] 1 5 [20,] 1 5 [21,] 1 1 [22,] 1 3 [23,] 1 3 [24,] 1 4 [25,] 1 5 [26,] 1 2 [27,] 1 4 [28,] 1 2 [29,] 1 2 [30,] 1 2 [31,] 1 4 [32,] 1 5 [33,] 1 1 [34,] 1 4 [35,] 1 5 [36,] 1 5 [37,] 1 1 [38,] 1 4 [39,] 1 3 [40,] 1 1 [41,] 1 2 [42,] 1 5 [43,] 1 4 [44,] 1 2 [45,] 1 1 [46,] 1 2 [47,] 1 4 [48,] 1 3 [49,] 1 3 [50,] 1 5 [51,] 1 2 [52,] 1 5 [53,] 1 1 [54,] 1 2 [55,] 1 5 [56,] 1 3 [57,] 1 2 [58,] 1 1 [59,] 1 1 [60,] 1 4 [61,] 1 3 [62,] 1 4 [63,] 1 5 [64,] 1 2 [65,] 1 4 [66,] 1 3 [67,] 1 1 [68,] 1 4 [69,] 1 4 [70,] 1 1 [71,] 1 2 [72,] 1 2 [73,] 1 1 [74,] 1 4 [75,] 1 1 [76,] 1 1 [77,] 1 3 [78,] 1 3 [79,] 1 3 [80,] 1 1 [81,] 1 1 [82,] 1 3 [83,] 1 1 [84,] 1 2 [85,] 1 2 [86,] 1 2 [87,] 1 4 [88,] 1 4 [89,] 1 2 [90,] 1 5 [91,] 1 2 [92,] 1 1 [93,] 1 3 [94,] 1 5 [95,] 1 4 [96,] 1 4 [97,] 1 3 [98,] 1 2 [99,] 1 2 [100,] 1 4 [101,] 1 4 [102,] 1 3 [103,] 1 2 [104,] 1 1 [105,] 1 3 [106,] 1 5 [107,] 1 1 [108,] 1 5 [109,] 1 1 [110,] 1 2 [111,] 1 5 [112,] 1 2 [113,] 1 4 [114,] 1 3 [115,] 1 1 [116,] 1 2 [117,] 1 4 [118,] 1 2 [119,] 1 1 [120,] 1 5 [121,] 1 3 [122,] 1 1 [123,] 1 3 [124,] 1 2 [125,] 1 1 [126,] 1 2 [127,] 1 3 [128,] 1 3 [129,] 1 2 [130,] 1 4 [131,] 1 2 [132,] 1 4 [133,] 1 4 [134,] 1 2 [135,] 1 3 [136,] 1 3 [137,] 1 2 [138,] 1 5 [139,] 1 4 [140,] 1 5 [141,] 1 5 [142,] 1 1 [143,] 1 2 [144,] 1 5 [145,] 1 4 [146,] 1 2 [147,] 1 2 [148,] 1 1 [149,] 1 1 [150,] 1 5 [151,] 1 2 [152,] 1 1 [153,] 1 4 [154,] 1 2 [155,] 1 5 [156,] 1 3 [157,] 1 5 [158,] 1 2 [159,] 1 2 [160,] 1 2 [161,] 1 1 [162,] 1 2 [163,] 1 5 [164,] 1 5 [165,] 1 1 [166,] 1 3 [167,] 1 2 [168,] 1 4 [169,] 1 1 [170,] 1 5 [171,] 1 3 [172,] 1 1 [173,] 1 2 [174,] 1 2 [175,] 1 5 [176,] 1 5 [177,] 1 5 [178,] 1 2 [179,] 1 4 [180,] 1 4 [181,] 1 2 [182,] 1 4 [183,] 1 4 [184,] 1 1 [185,] 1 1 [186,] 1 1 [187,] 1 3 [188,] 1 2 [189,] 1 4 [190,] 1 2 [191,] 1 3 [192,] 1 4 [193,] 1 5 [194,] 1 5 [195,] 1 4 [196,] 1 1 [197,] 1 2 [198,] 1 5 [199,] 1 1 [200,] 1 1 [201,] 1 1 [202,] 1 2 [203,] 1 4 [204,] 1 3 [205,] 1 4 [206,] 1 2 [207,] 1 5 [208,] 1 2 [209,] 1 2 [210,] 1 4 [211,] 1 4 [212,] 1 4 [213,] 1 4 [214,] 1 4 [215,] 1 3 [216,] 1 1 [217,] 1 3 [218,] 1 5 [219,] 1 5 [220,] 1 1 [221,] 1 2 [222,] 1 3 [223,] 1 4 [224,] 1 4 [225,] 1 4 [226,] 1 2 [227,] 1 3 [228,] 1 5 [229,] 1 5 [230,] 1 4 [231,] 1 3 [232,] 1 5 [233,] 1 4 [234,] 1 2 [235,] 1 3 [236,] 1 4 [237,] 1 5 [238,] 1 4 [239,] 1 3 [240,] 1 5 [241,] 1 4 [242,] 1 5 [243,] 1 1 [244,] 1 3 [245,] 1 1 [246,] 1 2 [247,] 1 1 [248,] 1 5 [249,] 1 4 [250,] 1 2 [251,] 1 4 [252,] 1 1 [253,] 1 3 [254,] 1 3 [255,] 1 1 [256,] 1 3 [257,] 1 5 [258,] 1 1 [259,] 1 2 [260,] 1 1 [261,] 1 1 [262,] 1 3 [263,] 1 2 [264,] 1 4 [265,] 1 4 [266,] 1 3 [267,] 1 2 [268,] 1 3 [269,] 1 2 [270,] 1 4 [271,] 1 4 [272,] 1 5 [273,] 1 3 [274,] 1 5 [275,] 1 3 [276,] 1 1 [277,] 1 1 [278,] 1 1 [279,] 1 3 [280,] 1 5 [281,] 1 2 [282,] 1 3 [283,] 1 2 [284,] 1 5 [285,] 1 2 [286,] 1 4 [287,] 1 5 [288,] 1 2 [289,] 1 4 [290,] 1 2 [291,] 1 4 [292,] 1 4 [293,] 1 2 [294,] 1 4 [295,] 1 1 [296,] 1 2 [297,] 1 1 [298,] 1 1 [299,] 1 2 [300,] 1 1 [301,] 1 3 [302,] 1 5 [303,] 1 5 [304,] 1 4 [305,] 1 5 [306,] 1 1 [307,] 1 2 [308,] 1 5 [309,] 1 1 [310,] 1 5 [311,] 1 5 [312,] 1 5 [313,] 1 1 [314,] 1 1 [315,] 1 2 [316,] 1 5 [317,] 1 2 [318,] 1 4 [319,] 1 5 [320,] 1 5 [321,] 1 2 [322,] 1 3 [323,] 1 1 [324,] 1 2 [325,] 1 5 [326,] 1 1 [327,] 1 3 [328,] 1 5 [329,] 1 2 [330,] 1 2 [331,] 1 2 [332,] 1 2 [333,] 1 4 [334,] 1 4 [335,] 1 5 [336,] 1 2 [337,] 1 5 [338,] 1 5 [339,] 1 4 [340,] 1 3 [341,] 1 1 [342,] 1 1 [343,] 1 2 [344,] 1 3 [345,] 1 5 [346,] 1 3 [347,] 1 1 [348,] 1 2 [349,] 1 5 [350,] 1 5 [351,] 1 5 [352,] 1 3 [353,] 1 5 [354,] 1 5 [355,] 1 1 [356,] 1 1 [357,] 1 4 [358,] 1 4 [359,] 1 1 [360,] 1 1 [361,] 1 2 [362,] 1 1 [363,] 1 5 [364,] 1 3 [365,] 1 2 [366,] 1 2 [367,] 1 3 [368,] 1 4 [369,] 1 2 [370,] 1 4 [371,] 1 3 [372,] 1 4 [373,] 1 3 [374,] 1 3 [375,] 1 3 [376,] 1 5 [377,] 1 4 [378,] 1 2 [379,] 1 5 [380,] 1 1 [381,] 1 2 [382,] 1 5 [383,] 1 4 [384,] 1 4 [385,] 1 1 [386,] 1 4 [387,] 1 5 [388,] 1 2 [389,] 1 5 [390,] 1 5 [391,] 1 3 [392,] 1 5 [393,] 1 1 [394,] 1 2 [395,] 1 3 [396,] 1 1 [397,] 1 1 [398,] 1 3 [399,] 1 5 [400,] 1 3 [401,] 1 2 [402,] 1 1 [403,] 1 1 [404,] 1 3 [405,] 1 1 [406,] 1 5 [407,] 1 4 [408,] 1 4 [409,] 1 3 [410,] 1 1 [411,] 1 3 [412,] 1 5 [413,] 1 5 [414,] 1 4 [415,] 1 1 [416,] 1 4 [417,] 1 2 [418,] 1 5 [419,] 1 1 [420,] 1 2 [421,] 1 3 [422,] 1 3 [423,] 1 3 [424,] 1 1 [425,] 1 4 [426,] 1 3 [427,] 1 1 [428,] 1 2 [429,] 1 5 [430,] 1 3 [431,] 1 3 [432,] 1 5 [433,] 1 3 [434,] 1 3 [435,] 1 5 [436,] 1 4 [437,] 1 1 [438,] 1 3 [439,] 1 3 [440,] 1 3 [441,] 1 5 [442,] 1 5 [443,] 1 4 [444,] 1 3 [445,] 1 1 [446,] 1 3 [447,] 1 3 [448,] 1 2 [449,] 1 3 [450,] 1 4 [451,] 1 4 [452,] 1 2 [453,] 1 2 [454,] 1 4 [455,] 1 1 [456,] 1 1 [457,] 1 2 [458,] 1 1 [459,] 1 4 [460,] 1 5 [461,] 1 5 [462,] 1 3 [463,] 1 4 [464,] 1 5 [465,] 1 2 [466,] 1 1 [467,] 1 5 [468,] 1 3 [469,] 1 3 [470,] 1 5 [471,] 1 2 [472,] 1 3 [473,] 1 2 [474,] 1 2 [475,] 1 1 [476,] 1 3 [477,] 1 3 [478,] 1 1 [479,] 1 3 [480,] 1 2 [481,] 1 3 [482,] 1 4 [483,] 1 1 [484,] 1 1 [485,] 1 3 [486,] 1 2 [487,] 1 2 [488,] 1 4 [489,] 1 3 [490,] 1 5 [491,] 1 2 [492,] 1 3 [493,] 1 4 [494,] 1 3 [495,] 1 4 [496,] 1 3 [497,] 1 3 [498,] 1 4 [499,] 1 2 [500,] 1 4 [501,] 1 3 [502,] 1 1 [503,] 1 5 [504,] 1 2 [505,] 1 5 [506,] 1 2 [507,] 1 5 [508,] 1 3 [509,] 1 1 [510,] 1 4 [511,] 1 4 [512,] 1 1 [513,] 1 4 [514,] 1 4 [515,] 1 5 [516,] 1 2 [517,] 1 2 [518,] 1 1 [519,] 1 5 [520,] 1 1 [521,] 1 2 [522,] 1 5 [523,] 1 3 [524,] 1 1 [525,] 1 4 [526,] 1 4 [527,] 1 1 [528,] 1 1 [529,] 1 3 [530,] 1 4 [531,] 1 5 [532,] 1 5 [533,] 1 3 [534,] 1 2 [535,] 1 4 [536,] 1 4 [537,] 1 3 [538,] 1 4 [539,] 1 2 [540,] 1 5 [541,] 1 2 [542,] 1 2 [543,] 1 3 [544,] 1 1 [545,] 1 4 [546,] 1 2 [547,] 1 3 [548,] 1 3 [549,] 1 1 [550,] 1 2 [551,] 1 2 [552,] 1 5 [553,] 1 2 [554,] 1 3 [555,] 1 1 [556,] 1 1 [557,] 1 2 [558,] 1 1 [559,] 1 2 [560,] 1 1 [561,] 1 5 [562,] 1 1 [563,] 1 3 [564,] 1 5 [565,] 1 2 [566,] 1 3 [567,] 1 5 [568,] 1 5 [569,] 1 5 [570,] 1 4 [571,] 1 1 [572,] 1 3 [573,] 1 5 [574,] 1 4 [575,] 1 4 [576,] 1 1 [577,] 1 5 [578,] 1 2 [579,] 1 5 [580,] 1 4 [581,] 1 4 [582,] 1 1 [583,] 1 4 [584,] 1 5 [585,] 1 2 [586,] 1 2 [587,] 1 5 [588,] 1 4 [589,] 1 5 [590,] 1 4 [591,] 1 1 [592,] 1 4 [593,] 1 4 [594,] 1 4 [595,] 1 3 [596,] 1 5 [597,] 1 4 [598,] 1 1 [599,] 1 4 [600,] 1 5 [601,] 1 3 [602,] 1 3 [603,] 1 3 [604,] 1 2 [605,] 1 3 [606,] 1 3 [607,] 1 5 [608,] 1 4 [609,] 1 3 [610,] 1 1 [611,] 1 4 [612,] 1 1 [613,] 1 2 [614,] 1 3 [615,] 1 4 [616,] 1 4 [617,] 1 4 [618,] 1 4 [619,] 1 5 [620,] 1 4 [621,] 1 5 [622,] 1 4 [623,] 1 1 [624,] 1 4 [625,] 1 3 [626,] 1 5 [627,] 1 4 [628,] 1 1 [629,] 1 3 [630,] 1 5 [631,] 1 1 [632,] 1 1 [633,] 1 5 [634,] 1 4 [635,] 1 2 [636,] 1 1 [637,] 1 5 [638,] 1 5 [639,] 1 5 [640,] 1 2 [641,] 1 1 [642,] 1 3 [643,] 1 2 [644,] 1 1 [645,] 1 4 [646,] 1 3 [647,] 1 2 [648,] 1 3 [649,] 1 1 [650,] 1 4 [651,] 1 5 [652,] 1 2 [653,] 1 2 [654,] 1 3 [655,] 1 2 [656,] 1 4 [657,] 1 2 [658,] 1 2 [659,] 1 5 [660,] 1 1 [661,] 1 4 [662,] 1 3 [663,] 1 3 [664,] 1 5 [665,] 1 5 [666,] 1 1 [667,] 1 1 [668,] 1 4 [669,] 1 2 [670,] 1 1 [671,] 1 2 [672,] 1 4 [673,] 1 4 [674,] 1 1 [675,] 1 4 [676,] 1 5 [677,] 1 4 [678,] 1 4 [679,] 1 2 [680,] 1 4 [681,] 1 2 [682,] 1 5 [683,] 1 3 [684,] 1 3 [685,] 1 4 [686,] 1 4 [687,] 1 3 [688,] 1 3 [689,] 1 4 [690,] 1 2 [691,] 1 3 [692,] 1 1 [693,] 1 1 [694,] 1 1 [695,] 1 1 [696,] 1 1 [697,] 1 3 [698,] 1 3 [699,] 1 3 [700,] 1 4 [701,] 1 2 [702,] 1 2 [703,] 1 3 [704,] 1 5 [705,] 1 2 [706,] 1 1 [707,] 1 3 [708,] 1 2 [709,] 1 1 [710,] 1 4 [711,] 1 5 [712,] 1 5 [713,] 1 2 [714,] 1 4 [715,] 1 1 [716,] 1 5 [717,] 1 1 [718,] 1 3 [719,] 1 1 [720,] 1 5 [721,] 1 5 [722,] 1 3 [723,] 1 1 [724,] 1 4 [725,] 1 1 [726,] 1 1 [727,] 1 5 [728,] 1 2 [729,] 1 5 [730,] 1 5 [731,] 1 5 [732,] 1 3 [733,] 1 1 [734,] 1 4 [735,] 1 4 [736,] 1 1 [737,] 1 4 [738,] 1 5 [739,] 1 1 [740,] 1 4 [741,] 1 1 [742,] 1 3 [743,] 1 2 [744,] 1 4 [745,] 1 1 [746,] 1 2 [747,] 1 4 [748,] 1 1 [749,] 1 1 [750,] 1 5 [751,] 1 2 [752,] 1 1 [753,] 1 1 [754,] 1 1 [755,] 1 2 [756,] 1 3 [757,] 1 5 [758,] 1 5 [759,] 1 1 [760,] 1 5 [761,] 1 1 [762,] 1 1 [763,] 1 3 [764,] 1 1 [765,] 1 3 [766,] 1 1 [767,] 1 2 [768,] 1 3 [769,] 1 5 [770,] 1 1 [771,] 1 3 [772,] 1 5 [773,] 1 2 [774,] 1 2 [775,] 1 3 [776,] 1 3 [777,] 1 1 [778,] 1 4 [779,] 1 5 [780,] 1 3 [781,] 1 1 [782,] 1 2 [783,] 1 4 [784,] 1 3 [785,] 1 1 [786,] 1 4 [787,] 1 2 [788,] 1 3 [789,] 1 4 [790,] 1 4 [791,] 1 2 [792,] 1 3 [793,] 1 2 [794,] 1 5 [795,] 1 3 [796,] 1 5 [797,] 1 2 [798,] 1 3 [799,] 1 2 [800,] 1 3 [801,] 1 5 [802,] 1 1 [803,] 1 1 [804,] 1 5 [805,] 1 5 [806,] 1 3 [807,] 1 4 [808,] 1 3 [809,] 1 2 [810,] 1 2 [811,] 1 4 [812,] 1 5 [813,] 1 1 [814,] 1 3 [815,] 1 2 [816,] 1 2 [817,] 1 3 [818,] 1 2 [819,] 1 4 [820,] 1 4 [821,] 1 5 [822,] 1 4 [823,] 1 2 [824,] 1 1 [825,] 1 1 [826,] 1 5 [827,] 1 1 [828,] 1 2 [829,] 1 4 [830,] 1 5 [831,] 1 4 [832,] 1 4 [833,] 1 5 [834,] 1 2 [835,] 1 3 [836,] 1 3 [837,] 1 2 [838,] 1 2 [839,] 1 2 [840,] 1 3 [841,] 1 4 [842,] 1 4 [843,] 1 2 [844,] 1 3 [845,] 1 5 [846,] 1 4 [847,] 1 3 [848,] 1 1 [849,] 1 5 [850,] 1 5 [851,] 1 1 [852,] 1 1 [853,] 1 3 [854,] 1 1 [855,] 1 2 [856,] 1 1 [857,] 1 2 [858,] 1 5 [859,] 1 3 [860,] 1 5 [861,] 1 1 [862,] 1 5 [863,] 1 2 [864,] 1 3 [865,] 1 2 [866,] 1 1 [867,] 1 2 [868,] 1 3 [869,] 1 4 [870,] 1 1 [871,] 1 4 [872,] 1 3 [873,] 1 2 [874,] 1 5 [875,] 1 4 [876,] 1 2 [877,] 1 4 [878,] 1 4 [879,] 1 1 [880,] 1 3 [881,] 1 3 [882,] 1 4 [883,] 1 4 [884,] 1 4 [885,] 1 4 [886,] 1 2 [887,] 1 3 [888,] 1 1 [889,] 1 1 [890,] 1 5 [891,] 1 3 [892,] 1 1 [893,] 1 3 [894,] 1 4 [895,] 1 5 [896,] 1 4 [897,] 1 5 [898,] 1 4 [899,] 1 5 [900,] 1 4 [901,] 1 5 [902,] 1 5 [903,] 1 5 [904,] 1 2 [905,] 1 4 [906,] 1 3 [907,] 1 2 [908,] 1 4 [909,] 1 5 [910,] 1 2 [911,] 1 2 [912,] 1 4 [913,] 1 5 [914,] 1 5 [915,] 1 5 [916,] 1 1 [917,] 1 5 [918,] 1 2 [919,] 1 2 [920,] 1 4 [921,] 1 4 [922,] 1 1 [923,] 1 5 [924,] 1 5 [925,] 1 4 [926,] 1 5 [927,] 1 2 [928,] 1 5 [929,] 1 4 [930,] 1 5 [931,] 1 1 [932,] 1 4 [933,] 1 3 [934,] 1 2 [935,] 1 1 [936,] 1 3 [937,] 1 2 [938,] 1 2 [939,] 1 4 [940,] 1 3 [941,] 1 3 [942,] 1 4 [943,] 1 1 [944,] 1 1 [945,] 1 4 [946,] 1 3 [947,] 1 5 [948,] 1 4 [949,] 1 3 [950,] 1 3 [951,] 1 2 [952,] 1 3 [953,] 1 2 [954,] 1 1 [955,] 1 1 [956,] 1 1 [957,] 1 1 [958,] 1 2 [959,] 1 1 [960,] 1 3 [961,] 1 5 [962,] 1 1 [963,] 1 4 [964,] 1 1 [965,] 1 2 [966,] 1 4 [967,] 1 4 [968,] 1 5 [969,] 1 5 [970,] 1 5 [971,] 1 4 [972,] 1 2 [973,] 1 3 [974,] 1 1 [975,] 1 2 [976,] 1 5 [977,] 1 3 [978,] 1 4 [979,] 1 3 [980,] 1 4 [981,] 1 4 [982,] 1 1 [983,] 1 1 [984,] 1 4 [985,] 1 4 [986,] 1 5 [987,] 1 4 [988,] 1 5 [989,] 1 1 [990,] 1 3 [991,] 1 3 [992,] 1 2 [993,] 1 1 [994,] 1 1 [995,] 1 5 [996,] 1 1 [997,] 1 5 [998,] 1 5 [999,] 1 3 [1000,] 1 1 [1001,] 1 5 [1002,] 1 4 [1003,] 1 4 [1004,] 1 5 [1005,] 1 3 [1006,] 1 1 [1007,] 1 4 [1008,] 1 2 [1009,] 1 3 [1010,] 1 4 [1011,] 1 1 [1012,] 1 5 [1013,] 1 1 [1014,] 1 1 [1015,] 1 3 [1016,] 1 2 [1017,] 1 2 [1018,] 1 5 [1019,] 1 3 [1020,] 1 1 [1021,] 1 4 [1022,] 1 4 [1023,] 1 3 [1024,] 1 3 [1025,] 1 5 [1026,] 1 3 [1027,] 1 5 [1028,] 1 3 [1029,] 1 2 [1030,] 1 4 [1031,] 1 5 [1032,] 1 1 [1033,] 1 3 [1034,] 1 5 [1035,] 1 5 [1036,] 1 5 [1037,] 1 5 [1038,] 1 2 [1039,] 1 3 [1040,] 1 2 [1041,] 1 4 [1042,] 1 5 [1043,] 1 1 [1044,] 1 1 [1045,] 1 4 [1046,] 1 3 $cv.rsq.tab survived mean fold1 0.3667644 0.3667644 fold2 0.4568676 0.4568676 fold3 0.3372852 0.3372852 fold4 0.5526398 0.5526398 fold5 0.3843980 0.3843980 mean 0.4195910 0.4195910 $cv.maxerr.tab survived max fold1 1.1209055 1.1209055 fold2 -0.9346170 -0.9346170 fold3 0.9783652 0.9783652 fold4 -0.8896141 -0.8896141 fold5 1.0538007 1.0538007 all 1.1209055 1.1209055 $cv.class.rate.tab survived mean [1,] 0.7971698 0.7971698 [2,] 0.8097561 0.8097561 [3,] 0.7621359 0.7621359 [4,] 0.8504673 0.8504673 [5,] 0.7846890 0.7846890 [6,] 0.8008436 0.8008436 $cv.oof.rsq.tab nterms1 nterms2 nterms3 nterms4 nterms5 nterms6 nterms7 nterms8 nterms9 nterms10 nterms11 nterms12 nterms13 nterms14 nterms15 nterms16 nterms17 fold1 -4.280511e-05 0.2410547 0.2803369 0.2777117 0.3601483 0.3749521 0.3674743 0.3667644 0.3664157 0.3624462 0.3653130 0.3680153 0.3624974 0.3647649 0.3681238 NA NA fold2 -8.097523e-04 0.3023140 0.3492189 0.4050849 0.4330904 0.4467194 0.4568676 0.4599247 0.4621084 0.4611701 0.4557378 0.4560247 0.4556098 0.4581714 0.4567440 NA NA fold3 -1.238380e-04 0.2834391 0.3168678 0.3069891 0.3433210 0.3297127 0.3198552 0.3289499 0.3372852 0.3385858 0.3456020 0.3434422 0.3427104 0.3397266 0.3422500 NA NA fold4 -8.024815e-04 0.3100776 0.3973351 0.4333380 0.5172533 0.5513884 0.5361225 0.5526398 0.5331067 0.5409952 0.5335158 0.5451477 0.5442951 0.5485230 0.5500867 NA NA fold5 -1.501748e-05 0.3006279 0.3195227 0.3164532 0.3466321 0.3748809 0.3739104 0.3819652 0.3843980 0.3821277 0.3851601 0.3820491 0.3816940 0.3823281 0.3830321 0.3848859 NA all -3.587789e-04 0.2875026 0.3326563 0.3479154 0.4000890 0.4155307 0.4108460 0.4180488 0.4166628 0.4170650 0.4170657 0.4189358 0.4173613 0.4187028 0.4200473 NA NA $cv.infold.rsq.tab nterms1 nterms2 nterms3 nterms4 nterms5 nterms6 nterms7 nterms8 nterms9 nterms10 nterms11 nterms12 nterms13 nterms14 nterms15 nterms16 nterms17 fold1 0 0.3015666 0.3499884 0.3928144 0.4166581 0.4443956 0.4540534 0.4584988 0.4607575 0.4630470 0.4640720 0.4656666 0.4673211 0.4682133 0.4687018 NA NA fold2 0 0.2858897 0.3327046 0.3825129 0.4040994 0.4223877 0.4316216 0.4346068 0.4360674 0.4371045 0.4387849 0.4403698 0.4417074 0.4420979 0.4421165 NA NA fold3 0 0.2908492 0.3407652 0.3732852 0.4185117 0.4528131 0.4594098 0.4638176 0.4672305 0.4684257 0.4711853 0.4718532 0.4727303 0.4734210 0.4735164 NA NA fold4 0 0.2832731 0.3189834 0.3502650 0.3733132 0.3960947 0.4018947 0.4064867 0.4085816 0.4120536 0.4148032 0.4183371 0.4196274 0.4202378 0.4204300 NA NA fold5 0 0.2866398 0.3399566 0.3780271 0.4140211 0.4342947 0.4436503 0.4510192 0.4550523 0.4580077 0.4590682 0.4600342 0.4609702 0.4618915 0.4625679 0.4632783 NA all 0 0.2896437 0.3364796 0.3753809 0.4053207 0.4299971 0.4381260 0.4428858 0.4455379 0.4477277 0.4495827 0.4512522 0.4524713 0.4531723 0.4534665 NA NA attr(,"class") [1] "earth" ------------------------------------------------------------------------------- > plot(earth.mod.help) # the full model > > # test various options > old.par <- par(mfrow=c(2,2), mar=c(4, 3.2, 3, 3), mgp=c(1.6, 0.6, 0), par(cex = 0.8)) > > plot(earth.mod.help, which=1, main="plot.model.selection\ncol.oof.rsq=c(\"red\", \"green\")", + col.oof.rsq=c("red", "green"), do.par=F) > > plot(earth.mod.help, which=1, col.oof.rsq=0, col.npreds="gray", lty.npreds=1, + main="col.oof.rsq=0 col.npreds=gray", do.par=F) > > plot(earth.mod.help, which=1, main="col.infold.rsq=lightblue", + col.grsq = 0, col.rsq = NA, col.vline = 0, col.oof.vline = 0, + col.mean.infold.rsq="blue", col.infold.rsq="lightblue", + col.mean.oof.rsq="red", col.oof.rsq="pink", + col.pch.max.oof.rsq="purple", col.pch.cv.rsq=1, + do.par=F, legend.pos=c(5,0.32)) > > # expect Warning: cannot plot cross-validation data because keepxy not set in original call to earth > a0 <- earth(Volume ~ ., data = trees, nfold=2) > plot(a0, col.oof.rsq="pink", which=1, do.par=F) Warning: cannot plot cross-validation data because the earth model was not built with keepxy=TRUE > > par(old.par) > > # test plot.earth.models with cross-validated models > set.seed(428) > earth.mod <- earth(survived ~ ., data=etitanic, nfold=3, keepxy=TRUE) > plot.earth.models(earth.mod$cv.list, main="plot.earth.models with cross validated models") > > # test keepxy=2 > expect.err(try(plot(earth.mod.help$cv.list[[3]])), "cannot get the original model response (use keepxy=2 in the call to earth)") Looked unsuccessfully for the original response in the following places: (1) object$y: NULL (2) model.frame: no formula in getCall(object) (3) getCall(object)$y: object 'infold.y' not found Error : cannot get the original model response (use keepxy=2 in the call to earth) Got error as expected from try(plot(earth.mod.help$cv.list[[3]])) > expect.err(try(plotmo(earth.mod.help$cv.list[[3]])), "cannot get the original model predictors (use keepxy=2 in the call to earth)") 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 'infold.x' not found Error : cannot get the original model predictors (use keepxy=2 in the call to earth) Got error as expected from try(plotmo(earth.mod.help$cv.list[[3]])) > set.seed(2019) > earth.mod.help.keepxy2 <- earth(survived~., data=etitanic, nfold=3, keepxy=2) > plot(earth.mod.help.keepxy2$cv.list[[3]]) > plotmo(earth.mod.help.keepxy2$cv.list[[3]]) plotmo grid: pclass2nd pclass3rd sexmale age sibsp parch 0 0 1 28 0 0 > > # example in earth vignette > > library(bootstrap) # just for the "scor" data > set.seed(2) # for fold reproducibility, not strictly necessary > data(scor) > data <- data.frame(y=scor[,3], # didactic canonical data frame + x1=scor[,1], x2=scor[,2], x3=scor[,4], x4=scor[,5]) > > # Build an earth model with cross validation. Note that keepxy=TRUE > # to retain the cross-validation data for further processing. > > mod <- earth(y~., data=data, nfold=5, keepxy=TRUE) > plot(mod, which=1, col.rsq=0, caption="Cross Validated Models") > print(mod$cv.oof.rsq.tab, digits=2) # out-of-fold R-Squareds nterms1 nterms2 nterms3 nterms4 nterms5 nterms6 nterms7 nterms8 nterms9 nterms10 nterms11 nterms12 nterms13 nterms14 nterms15 fold1 -0.00271 0.350 0.52 0.61 0.586 0.55 0.568 0.566 0.558 0.474 0.404 0.37 0.368 0.384 0.400 fold2 -0.15113 0.081 0.15 0.45 -0.036 -1.11 -0.984 -1.364 -1.453 -1.619 -1.764 -1.76 -1.625 -1.691 -1.649 fold3 -0.02808 0.481 0.48 0.62 0.556 0.62 0.630 0.675 0.630 0.639 0.625 0.63 0.614 0.608 0.608 fold4 -0.00038 0.349 0.21 0.27 -0.027 0.18 0.026 0.033 -0.018 -0.017 -0.087 -0.12 -0.162 -0.066 -0.101 fold5 -0.01204 0.354 0.52 0.63 0.663 0.64 0.621 0.573 0.580 0.575 0.555 0.53 0.546 0.571 0.584 all -0.03887 0.323 0.38 0.52 0.348 0.18 0.172 0.097 0.060 0.010 -0.053 -0.07 -0.052 -0.039 -0.032 > > # Use the cross-validation results to select the optimum number-of-terms. > # This is the number of terms that gave the max mean RSq on the out-of-fold > # data, as displayed by the vertical dotted red line in the graph. > # (This is criterion (ii) in the next section. There are other approaches.) > > mean.oof.rsq.per.subset <- mod$cv.oof.rsq.tab[nrow(mod$cv.oof.rsq.tab),] > > nterms.selected.by.cv <- which.max(mean.oof.rsq.per.subset) > > cat("\nnterms selected by GCV (standard earth model):", length(mod$selected.terms), + "\nnterms selected by CV: ", nterms.selected.by.cv, "\n") nterms selected by GCV (standard earth model): 5 nterms selected by CV: 4 > > # Rebuild the earth model with the desired number of terms (and using > # all the data). > # The penalty=-1 tells earth to ignore the GCV (otherwise earth's usual > # selection-by-min-GCV may return a smaller model than the given nprune). > > mod.cv <- earth(y~., data=data, nprune=nterms.selected.by.cv, penalty=-1) > > # Test cross validation when calling earth from within a function > > formula.global <- Volume ~ . > data.global <- trees > weights.global <- rep(1, length.out=nrow(trees)) > weights.global[1] <- 2 > > lm.weights.local1 <- function() { + weights.local <- rep(1, length.out=nrow(trees)) + weights.local[1] <- 2 + lm(formula=Volume ~ ., data=trees, weights=weights.local) + } > cat("\n--lm.weights.local1\n") --lm.weights.local1 > print(summary(lm.weights.local1())) Call: lm(formula = Volume ~ ., data = trees, weights = weights.local) Weighted Residuals: Min 1Q Median 3Q Max -6.5173 -2.4335 -0.6085 1.9793 8.9436 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -56.4763 8.8306 -6.396 6.36e-07 *** Girth 4.6307 0.2658 17.420 < 2e-16 *** Height 0.3349 0.1342 2.496 0.0187 * --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 4.003 on 28 degrees of freedom Multiple R-squared: 0.9471, Adjusted R-squared: 0.9434 F-statistic: 250.9 on 2 and 28 DF, p-value: < 2.2e-16 > > earth.weights.local2 <- function() { + weights.local <- rep(1, length.out=nrow(trees)) + weights.local[1] <- 2 + earth(formula=Volume ~ ., data=trees, linpreds=TRUE, weights=weights.local) + } > cat("\n--earth.weights.local2\n") --earth.weights.local2 > print(summary(earth.weights.local2())) Call: earth(formula=Volume~., data=trees, weights=weights.local, linpreds=TRUE) coefficients (Intercept) -56.476323 Girth 4.630708 Height 0.334945 Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: Girth, Height Weights: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 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 20.5747 RSS 448.6613 GRSq 0.9296315 RSq 0.9471454 > > lm.weights.local2 <- function(){ + weights.local <- rep(1, length.out=nrow(trees)) + weights.local[1] <- 2 + lm(formula=formula.global, data=data.global, weights=weights.local) + } > cat("\n--lm.weights.local2\n") --lm.weights.local2 > try(lm.weights.local2()) # fails: object 'weights.local' not found Error in eval(extras, data, env) : object 'weights.local' not found > > earth.weights.local2 <- function(){ + weights.local <- rep(1, length.out=nrow(trees)) + weights.local[1] <- 2 + earth(formula=formula.global, data=data.global, linpreds=TRUE, weights=weights.local) + } > cat("\n--earth.weights.local2\n") --earth.weights.local2 > try(earth.weights.local2()) # fails: object 'weights.local' not found, so does lm (see lm.weights.local2 above) Error in eval(extras, data, env) : object 'weights.local' not found > > #--- cross validation tests > > earth.cv.1 <- function() { + set.seed(2017) + earth(formula=Volume ~ ., data=trees, weights=weights.global, linpreds=TRUE, + nfold=3) + } > cat("\n--earth.cv.1\n") --earth.cv.1 > print(earth.cv.1()) Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: Girth, Height Weights: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 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 20.5747 RSS 448.6613 GRSq 0.9296315 RSq 0.9471454 CVRSq 0.8805649 > earth.cv.2 <- function() { + weights.local <- rep(1, length.out=nrow(trees)) + weights.local[1] <- 2 + set.seed(2017) + earth(formula=Volume ~ ., data=trees, weights=weights.local, linpreds=TRUE, + nfold=3) + } > cat("\n--earth.cv.2\n") --earth.cv.2 > print(earth.cv.2()) Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: Girth, Height Weights: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 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 20.5747 RSS 448.6613 GRSq 0.9296315 RSq 0.9471454 CVRSq 0.8805649 > earth.cv.3 <- function(){ + set.seed(2017) + earth(formula=formula.global, data=data.global, weights=weights.global, linpreds=TRUE, + nfold=3) + } > cat("\n--earth.cv.3\n") --earth.cv.3 > print(earth.cv.3()) Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: Girth, Height Weights: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 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 20.5747 RSS 448.6613 GRSq 0.9296315 RSq 0.9471454 CVRSq 0.8805649 > > # earth.cv.4 <- function(){ # fails: object 'weights.local' not found, cf earth.weights.local2 above for simpler example > # weights.local <- rep(1, length.out=nrow(trees)) > # weights.local[1] <- 2 > # set.seed(2017) > # earth(formula=formula.global, data=data.global, weights=weights.local, linpreds=TRUE, > # nfold=3) > # } > # cat("\n--earth.cv.4\n") > # printt(earth.cv.4()) > > thresh.global <- .002 > earth.cv.1 <- function() { + set.seed(2017) + earth(formula=Volume ~ ., data=trees, thresh=thresh.global, + nfold=3) + } > cat("\n--earth.cv.1\n") --earth.cv.1 > print(earth.cv.1()) Selected 4 of 5 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.002 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 CVRSq 0.9295587 > earth.cv.2 <- function() { + thresh.local <- .002 + set.seed(2017) + earth(formula=Volume ~ ., data=trees, thresh=thresh.local, + nfold=3) + } > cat("\n--earth.cv.2\n") --earth.cv.2 > print(earth.cv.2()) Selected 4 of 5 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.002 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 CVRSq 0.9295587 > earth.cv.3 <- function(){ + set.seed(2017) + earth(formula=formula.global, data=data.global, thresh=thresh.global, + nfold=3) + } > cat("\n--earth.cv.3\n") --earth.cv.3 > print(earth.cv.3()) Selected 4 of 5 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.002 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 CVRSq 0.9295587 > earth.cv.4 <- function(){ + thresh.local <- .002 + set.seed(2017) + earth(formula=formula.global, data=data.global, thresh=thresh.local, + nfold=3) + } > cat("\n--earth.cv.4\n") --earth.cv.4 > print(earth.cv.4()) Selected 4 of 5 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.002 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 CVRSq 0.9295587 > earth.cv.5 <- function(){ + thresh <- .002 + set.seed(2017) + earth(formula=formula.global, data=data.global, thresh=thresh, + nfold=3) + } > cat("\n--earth.cv.5\n") --earth.cv.5 > print(earth.cv.5()) Selected 4 of 5 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.002 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 CVRSq 0.9295587 > > thresh.global <- .002 > earth.cv.1 <- function() { + set.seed(2017) + earth(formula=Volume ~ ., data=trees, thresh=thresh.global, + pmethod="cv", nfold=3) + } > cat("\n--earth.cv.1\n") --earth.cv.1 > print(earth.cv.1()) Selected 5 of 5 terms, and 2 of 2 predictors (pmethod="cv") Termination condition: RSq changed by less than 0.002 at 5 terms Importance: Girth, Height Number of terms at each degree of interaction: 1 4 (additive model) GRSq 0.9543159 RSq 0.9754321 mean.oof.RSq 0.9524348 (sd 0.025) pmethod="backward" would have selected: 4 terms 2 preds, GRSq 0.959692 RSq 0.9742029 mean.oof.RSq 0.9338342 > earth.cv.2 <- function() { # fails + thresh.local <- .002 + set.seed(2017) + a <- earth(formula=Volume ~ ., data=trees, thresh=thresh.local, + pmethod="cv", ncross=3, nfold=3, keepxy=TRUE) + # plot(a, which=1, ylim=c(.7, 1)) + # print(a) + a + } > cat("\n--earth.cv.2\n") --earth.cv.2 > print(earth.cv.2()) Selected 5 of 5 terms, and 2 of 2 predictors (pmethod="cv") Termination condition: RSq changed by less than 0.002 at 5 terms Importance: Girth, Height Number of terms at each degree of interaction: 1 4 (additive model) GRSq 0.9543159 RSq 0.9754321 mean.oof.RSq 0.9507128 (sd 0.0199) pmethod="backward" would have selected: 4 terms 2 preds, GRSq 0.959692 RSq 0.9742029 mean.oof.RSq 0.9407858 > a <- earth.cv.2() > earth.cv.3 <- function(){ + set.seed(2017) + earth(formula=formula.global, data=data.global, thresh=thresh.global, + pmethod="cv", nfold=3) + } > cat("\n--earth.cv.3\n") --earth.cv.3 > print(earth.cv.3()) Selected 5 of 5 terms, and 2 of 2 predictors (pmethod="cv") Termination condition: RSq changed by less than 0.002 at 5 terms Importance: Girth, Height Number of terms at each degree of interaction: 1 4 (additive model) GRSq 0.9543159 RSq 0.9754321 mean.oof.RSq 0.9524348 (sd 0.025) pmethod="backward" would have selected: 4 terms 2 preds, GRSq 0.959692 RSq 0.9742029 mean.oof.RSq 0.9338342 > earth.cv.4 <- function(){ # fails + thresh.local <- .002 + set.seed(2017) + earth(formula=formula.global, data=data.global, thresh=thresh.local, + pmethod="cv", nfold=3) + } > cat("\n--earth.cv.4\n") --earth.cv.4 > print(earth.cv.4()) Selected 5 of 5 terms, and 2 of 2 predictors (pmethod="cv") Termination condition: RSq changed by less than 0.002 at 5 terms Importance: Girth, Height Number of terms at each degree of interaction: 1 4 (additive model) GRSq 0.9543159 RSq 0.9754321 mean.oof.RSq 0.9524348 (sd 0.025) pmethod="backward" would have selected: 4 terms 2 preds, GRSq 0.959692 RSq 0.9742029 mean.oof.RSq 0.9338342 > earth.cv.5 <- function(){ # fails + thresh <- .002 + set.seed(2017) + earth(formula=formula.global, data=data.global, thresh=thresh, + pmethod="cv", nfold=3) + } > cat("\n--earth.cv.5\n") --earth.cv.5 > a.cv.5 <- earth.cv.5() > print(a.cv.5) Selected 5 of 5 terms, and 2 of 2 predictors (pmethod="cv") Termination condition: RSq changed by less than 0.002 at 5 terms Importance: Girth, Height Number of terms at each degree of interaction: 1 4 (additive model) GRSq 0.9543159 RSq 0.9754321 mean.oof.RSq 0.9524348 (sd 0.025) pmethod="backward" would have selected: 4 terms 2 preds, GRSq 0.959692 RSq 0.9742029 mean.oof.RSq 0.9338342 > cat("\n--summary(earth.cv.5)\n") --summary(earth.cv.5) > print(summary(a.cv.5)) Call: earth(formula=formula.global, data=data.global, pmethod="cv", nfold=3, thresh=thresh) coefficients (Intercept) 29.4114832 h(14.2-Girth) -3.2829829 h(Girth-14.2) 6.2798571 h(75-Height) -0.1918868 h(Height-75) 0.5005533 Selected 5 of 5 terms, and 2 of 2 predictors (pmethod="cv") Termination condition: RSq changed by less than 0.002 at 5 terms Importance: Girth, Height Number of terms at each degree of interaction: 1 4 (additive model) GRSq 0.9543159 RSq 0.9754321 mean.oof.RSq 0.9524348 (sd 0.025) pmethod="backward" would have selected: 4 terms 2 preds, GRSq 0.959692 RSq 0.9742029 mean.oof.RSq 0.9338342 > > source("test.epilog.R") earth/inst/slowtests/test.allowedfunc.R0000644000176200001440000001436513447012365020023 0ustar liggesusers# test.allowedfunc.R source("test.prolog.R") source("check.models.equal.R") library(earth) data(trees) printh <- function(x, expect.warning=FALSE, max.print=0) # like print but with a header { cat("===", deparse(substitute(x)), " ", sep="") if(expect.warning) cat(" expect warning -->") else if (NROW(x) > 1) cat("\n") if (max.print > 0) print(head(x, n=max.print)) else print(x) } example.nopred2 <- function(degree, pred, parents) { pred != 2 # disallow predictor 2, which is "Height" } a.nopred2 <- earth(Volume ~ ., data = trees, allowed = example.nopred2) printh(summary(a.nopred2)) example.noHeight <- function(degree, pred, parents, namesx) { namesx[pred] != "Height" # disallow "Height" } a.noHeight <- earth(Volume ~ ., data = trees, allowed = example.noHeight) newdata.global <- trees[seq(from=nrow(trees), to=1, by=-5),] check.models.equal(a.nopred2, a.noHeight, msg="\"allowed\" function a.nopred2 a.noHeight", newdata=newdata.global) # we explicitly set minspan and endspan here because they are calculated differently if number of predictors is different aGirthOnly <- earth(Volume ~ Girth, data = trees, trace=4, minspan=1, endspan=1) printh(summary(aGirthOnly)) a1c <- earth(Volume ~ ., data = trees, allowed = example.noHeight, trace=4, minspan=1, endspan=1) # can't use check.models.equal because e.g. dirs for a1c has two columns but aGirthOnly has only one column stopifnot(identical(predict(aGirthOnly), predict(a1c))) iheight <- 0 example.noHeight.first <- function(degree, pred, parents, namesx, first) { if (first) { iheight <<- which(namesx == "Height") # note use of <<- not <- if (length(iheight) != 1) stop("could not find Height in ", paste(namesx, collapse=" ")) } pred != iheight } a.noHeight.first <- earth(Volume ~ ., data = trees, allowed = example.noHeight.first) check.models.equal(a.nopred2, a.noHeight, msg="\"allowed\" function a.nopred2 a.noHeight.first", newdata=newdata.global) example.noHumidityInDegree2 <- function(degree, pred, parents) { # disallow humidity in terms of degree > 1 # 3 is the "humidity" column in the input matrix if (degree > 1 && (pred == 3 || parents[3])) return(FALSE) TRUE } a.noHumidityInDegree2 <- earth(O3 ~ ., data = ozone1, degree = 2, allowed = example.noHumidityInDegree2) printh(summary(a.noHumidityInDegree2)) example.Degree2OnlyHumidityAndTemp <- function(degree, pred, parents) { # allow only humidity and temp in terms of degree > 1 # 3 and 4 are the "humidity" and "temp" columns allowed.set = c(3,4) if (degree > 1 && (all(allowed.set != pred) || any(parents[-allowed.set]))) return(FALSE) TRUE } a.Degree2OnlyHumidityAndTemp <- earth(O3 ~ ., data = ozone1, degree = 2, allowed = example.Degree2OnlyHumidityAndTemp) printh(summary(a.Degree2OnlyHumidityAndTemp)) ihumidity.global <- NA itemp.global <- NA example.Degree2OnlyHumidityAndTemp.First <- function(degree, pred, parents, namesx, first) { if (first) { ihumidity.global <<- which(namesx == "humidity") # note use of <<- not <- if (length(ihumidity.global) != 1) stop("could not find humidity in ", paste(namesx, collapse=" ")) itemp.global <<- which(namesx == "temp") # note use of <<- not <- if (length(itemp.global) != 1) stop("could not find temp in ", paste(namesx, collapse=" ")) } # allow only humidity and temp in terms of degree > 1 allowed.set = c(ihumidity.global, itemp.global) if (degree > 1 && (all(allowed.set != pred) || any(parents[-allowed.set]))) return(FALSE) TRUE } a.Degree2OnlyHumidityAndTemp.First <- earth(O3 ~ ., data = ozone1, degree = 2, allowed = example.Degree2OnlyHumidityAndTemp) check.models.equal(a.Degree2OnlyHumidityAndTemp, a.Degree2OnlyHumidityAndTemp.First, msg="\"allowed\" function a.Degree2OnlyHumidityAndTemp a.Degree2OnlyHumidityAndTemp.First", newdata=newdata.global) #--- no predictor in PREDICTORS is allowed to interact with any predictor in PARENTS #--- but all other interactions are allowed PREDICTORS <- c("age") PARENTS <- c("survived", "parch") example4 <- function(degree, pred, parents, namesx) { if (degree > 1) { predictor <- namesx[pred] parents <- namesx[parents != 0] if((any(predictor %in% PREDICTORS) && any(parents %in% PARENTS)) || (any(predictor %in% PARENTS) && any(parents %in% PREDICTORS))) { return(FALSE) } } TRUE } a4.allowed <- earth(sex~., data=etitanic, degree=2, allowed=example4) printh(summary(a4.allowed)) plotmo(a4.allowed, caption="a4.allowed") #--- predictors in PREDICTORS are allowed to interact with predictors in PARENTS #--- but no other interactions are allowed PREDICTORS <- c("age") PARENTS <- c("survived", "parch") example5 <- function(degree, pred, parents, namesx) { if (degree <= 1) return(TRUE) predictor <- namesx[pred] parents <- namesx[parents != 0] if((any(predictor %in% PREDICTORS) && any(parents %in% PARENTS)) || (any(predictor %in% PARENTS) && any(parents %in% PREDICTORS))) { return(TRUE) } FALSE } a5.allowed <- earth(sex~., data=etitanic, degree=2, allowed=example5) printh(summary(a5.allowed)) plotmo(a5.allowed, caption="a5.allowed") # "allowed" function checks, these check error handling by forcing an error expect.err(try(earth(Volume ~ ., data = trees, allowed = 99)), "argument is not a function") example7 <- function(degree, pred) pred!=2 expect.err(try(earth(Volume ~ ., data = trees, allowed = example7)), "function does not have the correct number of arguments") expect.err(try(earth(Volume ~ ., data = trees, allowed = earth)), "your 'allowed' function does not have the correct number of arguments") example8 <- function(degree, pred, parents99) pred!=2 expect.err(try(earth(Volume ~ ., data = trees, allowed = example8)), "function needs the following arguments") example9 <- function(degree, pred, parents, namesx99) pred!=2 expect.err(try(earth(Volume ~ ., data = trees, allowed = example9)), "function needs the following arguments") source("test.epilog.R") earth/inst/slowtests/test.plotd.bat0000755000176200001440000000151213514230362017172 0ustar liggesusers@rem test.plotd.bat @rem Stephen Milborrow Mar 2008 Durban @echo test.plotd.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.plotd.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.plotd.Rout: @echo. @tail test.plotd.Rout @echo test.plotd.R @exit /B 1 :good1 mks.diff test.plotd.Rout test.plotd.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.plotd.save.ps @exit /B 1 :good2 @rem test.plotd.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.plotd.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.plotd.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.earthmain.out.save0000644000176200001440000000235513436071740021027 0ustar liggesusersForward pass: minspan 4 endspan 7 x[100,1] 800 Bytes bx[100,21] 16.4 kB GRSq RSq DeltaRSq Pred Cut Terms Par Deg 0 0.0000 0.0000 0 1 0.9797 0.9813 0.9813 0 0.43 1 2 1 3 0.9862 0.9878 0.006479 0 0.27 3 1 5 0.9987 0.9989 0.01106 0 0.59 4 1 7 0.9987 0.9990 0.0001232 0 0.91 5 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 7 terms, 5 terms used (DeltaRSq 0.00012) After forward pass GRSq 0.999 RSq 0.999 Forward pass complete: 7 terms, 5 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.5157 0.5351 2 0.9816 0.9830 3 0.9977 0.9980 4 0.9987 0.9989 Backward pass complete: selected 4 terms of 5, GRSq 0.999 RSq 0.999 Expression: 1.46 // 0 +0.971 * max(0, x[0] - 0.43) // 1 -3.29 * max(0, 0.43 - x[0]) // 2 -2.75 * max(0, x[0] - 0.27) // 3 -1.97 * max(0, x[0] - 0.59) // 4 f(0.1234) = 0.447907 earth/inst/slowtests/test.mods.bat0000755000176200001440000000237713514230362017024 0ustar liggesusers@Rem test.mods.R: test earth's ability to build various models @rem Stephen Milborrow Jan 2014 Berea @echo test.mods.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.mods.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.mods.Rout: @echo. @tail test.mods.Rout @echo test.mods.R @exit /B 1 :good1 @echo diff test.mods.Rout test.mods.Rout.save @rem egreps to deal with times @C:\Rtools\bin\echo -n "new " @egrep "^\[total time" test.mods.Rout @C:\Rtools\bin\echo -n "old " @egrep "^\[total time" test.mods.Rout.save @egrep -v "^\[total time" test.mods.Rout >test.mods.Rout1 @egrep -v "^\[total time" test.mods.Rout.save >test.mods.Rout.save1 @rem -w to treat \n same as \r\n @mks.diff -w test.mods.Rout1 test.mods.Rout.save1 @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.mods.save.ps @exit /B 1 :good2 @rem test.mods.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.mods.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.mods.Rout test.mods.Rout1 test.mods.Rout.save1 @rem @rm -f test.mods.pdf @exit /B 0 earth/inst/slowtests/test.earthmain.clang.bat0000755000176200001440000000513113447277553021126 0ustar liggesusers@rem test.earthmain.clang.bat: test the standalone earth.c with main() @rem @rem Stephen Milborrow Dec 2014 Shrewsbury @echo test.earthmain.clang.bat @cp "d:/bin/R320dll/i386/R.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Rblas.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Riconv.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Rgraphapp.dll" . @if %errorlevel% neq 0 goto error @cp "d:/bin/R320dll/i386/Rzlib.dll" . @if %errorlevel% neq 0 goto error @rem you may have to create Rdll.lib and Rblas.lib beforehand @cp "../../.#/Rdll.lib" . @if %errorlevel% neq 0 goto error @cp "../../.#/Rblas.lib" . @if %errorlevel% neq 0 goto error @rem get iconv.dll from /a/r/ra/src/gnuwin32/unicode @cp "../../.#/Rdll.lib" . @if %errorlevel% neq 0 goto error @rem modify the path to include clang, if needed @set | egrep -i "^PATH=.*LLVM" >NUL && goto donesetpath @echo Modifying path for clang @set path=C:\Program Files (x86)\LLVM\bin;%PATH% :donesetpath @rem Flags same as gcc where possible. @rem -U_MSC_VER is needed because some clang executables define this inherently https://stackoverflow.com/questions/38499462/how-to-tell-clang-to-stop-pretending-to-be-other-compilers @rem Some of these warning suppressions are necessary because we use R and BLAS routines. clang -DSTANDALONE -DMAIN -Wall -pedantic -Wextra -Weverything -O3 -std=gnu99^ -U_MSC_VER^ -Wno-strict-prototypes -Wno-reserved-id-macro -Wno-cast-qual -Wno-unknown-pragmas^ -Wno-float-equal -Wno-format-nonliteral -Wno-padded -Wno-sign-conversion -Wno-undef^ -Wno-shadow -Wno-missing-prototypes -Wno-deprecated-declarations -Wno-implicit-function-declaration^ -Wno-missing-noreturn^ -I"/a/r/ra/include" -I../../inst/slowtests ../../src/earth.c^ Rdll.lib Rblas.lib -o earthmain-clang.exe @if %errorlevel% neq 0 goto error @earthmain-clang.exe > test.earthmain-clang.out @rem no errorlevel test, diff will do check for discrepancies @rem @if %errorlevel% neq 0 goto error mks.diff test.earthmain-clang.out test.earthmain.out.save @if %errorlevel% neq 0 goto error @rm -f R.dll Rblas.dll Riconv.dll Riconv.dll Rgraphapp.dll Rzlib.dll Rdll.lib Rblas.lib earthmain-clang.* test.earthmain-clang.* *.o @exit /B 0 :error @exit /B %errorlevel% earth/inst/slowtests/test.multresp.R0000644000176200001440000004740613444551753017403 0ustar liggesusers# test.multresp.R: test multiple response models using the Formula interface # Stephen Milborrow Mar 2019 Petaluma source("test.prolog.R") source("check.models.equal.R") library(earth) show.earth.mod <- function(mod, modname, nresponses, caption, trace, ...) { set.seed(2019) cat("\nsummary:", modname, "\n\n") print(summary(mod)) cat("\nevimp:", modname, "\n\n") evimp <- evimp(mod) print(evimp) cat("\n") nrow <- 1 + max(1, ceiling(nresponses * nrow(evimp(mod)) / 2)) par(mfrow=c(nrow, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) if(nresponses == 1) plot(mod, which=c(1,3), do.par=0, caption=caption, trace=trace) else { plot(mod, nresponse=1, which=3, do.par=0, caption=caption, trace=trace, main="Response 1: Residuals vs Fitted") plot(mod, nresponse=max(nresponses), which=3, do.par=0, caption=caption, trace=trace, main=sprint("Response %d: Residuals vs Fitted", max(nresponses))) } cat("\nplotmo:", modname, "\n\n") if(nresponses == 1) plotmo(mod, do.par=0, pt.col="red", trace=trace) else for(iresponse in 1:nresponses) plotmo(mod, nresponse=iresponse, do.par=0, pt.col=iresponse+1, trace=trace) par(old.par) cat("-------------------------------------------------------------------------------\n\n") } show.earth.formula <- function(formula, data=trees, subset=NULL, nresponses=1, show=TRUE, caption=modname, trace=0, ...) { modname <- sprint("formula=%s (nresponses=%d)", deparse(substitute(formula)), nresponses) printf("%s\n", modname) # use formula, not Formula mod <- earth(formula=formula, data=data, subset=subset, trace=1, keepxy=TRUE) global.mod <<- mod n <- if(is.null(subset)) nrow(data) else nrow(data[subset,]) if(!(all(dim(mod$fitted.values) == c(n, nresponses)))) { cat("dim(mod$fitted.values)", dim(mod$fitted.values), "\n") stop("show.earth.formula: wrong response dimensions (see above)") } if(show) show.earth.mod(mod=mod, modname=modname, nresponses=nresponses, caption=caption, trace=trace, ...) mod } show.earth.Formula <- function(formula, data=trees, subset=NULL, nresponses=1, show=TRUE, caption=modname, trace=0, ...) { modname <- sprint("Formula=%s (nresponses=%d)", deparse(substitute(formula)), nresponses) printf("%s\n", modname) # use Formula, not formula # use trace=1 so so can that we can see trace message: # Using class "Formula" because lhs of formula has terms separated by "+" mod <- earth(formula=formula, data=data, subset=subset, trace=1, keepxy=TRUE) global.mod <<- mod if(!(all(dim(mod$fitted.values) == c(31, nresponses)))) { cat("dim(mod$fitted.values)", dim(mod$fitted.values), "\n") stop("show.earth.Formula: wrong response dimensions (see above)") } show.earth.mod(mod=mod, modname=modname, nresponses=nresponses, caption=caption, trace=trace, ...) mod } options(warn=2) VolNeg <- -sqrt(trees$Volume) SinVol <- sin(pi * trees$Volume / max(trees$Volume)) global.mod <- NULL # following use formula (not Formula) show.earth.formula(Volume/VolNeg ~., show=FALSE) # show=FALSE to save time show.earth.formula(Volume/99 ~., show=FALSE) show.earth.formula(Volume*99 ~., show=FALSE) show.earth.formula(Volume-99 ~., show=FALSE) show.earth.formula(Volume ~., show=FALSE) show.earth.formula(cbind(Volume+VolNeg)~., show=FALSE) show.earth.formula((Volume+VolNeg) ~., show=FALSE) show.earth.formula(I(Volume+VolNeg) ~., show=FALSE) show.earth.formula(VolNeg~Girth+Height, show=FALSE) # use formula, but multiple response show.earth.formula(cbind(VolNeg, SinVol)~., nresponses=2, show=FALSE) show.earth.formula(cbind(VolNeg, SinVol)~., nresponses=2, show=FALSE) show.earth.formula(cbind(VolNeg/33, SinVol)~., nresponses=2, show=FALSE) show.earth.formula(cbind(VolNeg+33, SinVol)~., nresponses=2, show=FALSE) show.earth.formula(cbind(VolNeg, SinVol)~Girth, nresponses=2, show=FALSE) randx <- c(0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0) show.earth.formula(VolNeg~randx, nresponses=1) # intercept only model VolVolNeg <- show.earth.formula(cbind(Volume, VolNeg)~Girth+Height, nresponses=2, trace=0) # Use a global variable for Volume trees1 <- trees Volume <- trees1$Volume # global Volume trees1$Volume <- NULL # Volume no longer available in trees1 cbind.Volume.VolNeg <- cbind(Volume, VolNeg) VolGlobalVolNeg <- show.earth.formula(cbind(Volume, VolNeg)~Girth+Height, data=trees1, nresponses=2, trace=0, caption="VolGlobalVolNeg: This page should be the same as the previous page") check.models.equal(VolVolNeg, VolGlobalVolNeg, msg="VolVolNeg, VolGlobalVolNeg", newdata=trees[3,]) # following use Formula (not formula) VolVolNega <- show.earth.Formula(Volume+VolNeg~Girth+Height, nresponses=2, caption="VolVolNega: This page should be the same as the previous page") check.models.equal(VolVolNega, VolVolNeg, msg="VolVolNega, VolVolNeg", newdata=trees[3,]) Vol.VolNeg.dot <- show.earth.Formula(Volume+VolNeg~., nresponses=2, # use dot caption="Vol.VolNeg.dot: This page should be the same as the previous page") check.models.equal(Vol.VolNeg.dot, VolVolNega, msg="Vol.VolNeg.dot, VolVolNega", newdata=trees[3,]) trees1 <- trees trees1$VolNeg <- VolNeg VolVolNegc <- show.earth.Formula(Volume+VolNeg~., data=trees1, nresponses=2, # all variables on lhs in data argument (none global) caption="Vol.VolNeg.trees1: This page should be the same as the previous page") check.models.equal(VolVolNegc, VolVolNega, msg="VolVolNegc, VolVolNega", newdata=trees1[2:3,]) # check without using keepxy=TRUE (because show.earth.Formula uses keepxy=TRUE) VolVolNega.nokeepxy <- earth(Volume+VolNeg~Girth+Height, data=trees, trace=1) check.models.equal(VolVolNega.nokeepxy, VolVolNega, msg="VolVolNega.nokeepxy, VolVolNega", newdata=trees1[2:3,]) caption <- "VolVolNega.nokeepxy This page should be the same as the previous page" par(mfrow=c(3, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) plot(VolVolNega.nokeepxy, nresponse=1, which=3, do.par=0, caption=caption, trace=0, main="Response 1: Residuals vs Fitted") plot(VolVolNega.nokeepxy, nresponse=2, which=3, do.par=0, caption=caption, trace=0, main="Response 2: Residuals vs Fitted") plotmo(VolVolNega.nokeepxy, nresponse=1, do.par=0, pt.col=2) plotmo(VolVolNega.nokeepxy, nresponse=2, do.par=0, pt.col=3) par(old.par) options(warn=1) plot(VolVolNega.nokeepxy) # Warning: Defaulting to nresponse=1, see above messages options(warn=2) # subset, single response # TODO we don't use show.earth.formula here because there are plotmo problems # with subset and keepxy when called inside a function subset2 <- seq(from=1, to=nrow(trees1), by=2) Vol.formula.subset.nokeepxy <- earth(Volume~Girth+Height, data=trees1, subset=subset2, trace=1) plot(Vol.formula.subset.nokeepxy, caption="Vol.formula.subset.nokeepxy") plotmo(Vol.formula.subset.nokeepxy, nresponse=1, trace=1, pt.col=2, caption="Vol.formula.subset.nokeepxy") Vol.formula.subset.keepxy <- earth(Volume~Girth+Height, data=trees1, subset=subset2, trace=1) plotmo(Vol.formula.subset.keepxy, nresponse=1, trace=1, pt.col=2, caption="Vol.formula.subset.keepxy") # subset, multiple response VolVolNega.formula.subset.nokeepxy <- earth(cbind.Volume.VolNeg~Girth+Height, data=trees1, subset=subset2, trace=1) VolVolNega.Formula.subset.nokeepxy <- earth(Volume+VolNeg ~Girth+Height, data=trees1, subset=subset2, trace=1) check.models.equal(VolVolNega.formula.subset.nokeepxy, VolVolNega.Formula.subset.nokeepxy, "VolVolNega.formula.subset.nokeepxy, VolVolNega.Formula.subset.nokeepxy", newdata=trees[3,]) caption <- "VolVolNega.formula.subset.nokeepxy" par(mfrow=c(3, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) plot(VolVolNega.formula.subset.nokeepxy, nresponse=1, which=3, do.par=0, caption=caption, trace=1, main="Response 1: Residuals vs Fitted") plot(VolVolNega.formula.subset.nokeepxy, nresponse=2, which=3, do.par=0, caption=caption, trace=1, main="Response 2: Residuals vs Fitted") plotmo(VolVolNega.formula.subset.nokeepxy, nresponse=1, do.par=0, pt.col=2) plotmo(VolVolNega.formula.subset.nokeepxy, nresponse=2, do.par=0, pt.col=3) par(old.par) caption <- "VolVolNega.Formula.subset.nokeepxy" par(mfrow=c(3, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) plot(VolVolNega.Formula.subset.nokeepxy, nresponse=1, which=3, do.par=0, caption=caption, trace=1, main="Response 1: Residuals vs Fitted") plot(VolVolNega.Formula.subset.nokeepxy, nresponse=2, which=3, do.par=0, caption=caption, trace=1, main="Response 2: Residuals vs Fitted") plotmo(VolVolNega.Formula.subset.nokeepxy, nresponse=1, do.par=0, pt.col=2) plotmo(VolVolNega.Formula.subset.nokeepxy, nresponse=2, do.par=0, pt.col=3) par(old.par) # subset, multiple response, keepxy subset2 <- seq(from=1, to=nrow(trees1), by=2) VolVolNega.formula.subset.keepxy <- earth(cbind.Volume.VolNeg~Girth+Height, data=trees1, subset=subset2, trace=1, keepxy=TRUE) VolVolNega.Formula.subset.keepxy <- earth(Volume+VolNeg ~Girth+Height, data=trees1, subset=subset2, trace=1, keepxy=TRUE) check.models.equal(VolVolNega.formula.subset.nokeepxy, VolVolNega.formula.subset.keepxy, msg="VolVolNega.formula.subset.nokeepxy, VolVolNega.formula.subset.keepxy", newdata=trees1[2:3,]) check.models.equal(VolVolNega.Formula.subset.nokeepxy, VolVolNega.Formula.subset.keepxy, msg="VolVolNega.Formula.subset.nokeepxy, VolVolNega.Formula.subset.keepxy", newdata=trees1[2:3,]) check.models.equal(VolVolNega.formula.subset.keepxy, VolVolNega.Formula.subset.keepxy, msg="VolVolNega.formula.subset.keepxy, VolVolNega.Formula.subset.keepxy", newdata=trees1[2:3,]) caption <- "VolVolNega.formula.subset.keepxy" par(mfrow=c(3, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) plot(VolVolNega.formula.subset.keepxy, nresponse=1, which=3, do.par=0, caption=caption, trace=1, main="Response 1: Residuals vs Fitted") plot(VolVolNega.formula.subset.keepxy, nresponse=2, which=3, do.par=0, caption=caption, trace=1, main="Response 2: Residuals vs Fitted") # TODO following fail: subset and keepxy try(plotmo(VolVolNega.formula.subset.keepxy, nresponse=1, do.par=0, pt.col=2)) try(plotmo(VolVolNega.formula.subset.keepxy, nresponse=2, do.par=0, pt.col=3)) par(old.par) caption <- "VolVolNega.Formula.subset.keepxy" par(mfrow=c(3, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) plot(VolVolNega.Formula.subset.keepxy, nresponse=1, which=3, do.par=0, caption=caption, trace=1, main="Response 1: Residuals vs Fitted") plot(VolVolNega.Formula.subset.keepxy, nresponse=2, which=3, do.par=0, caption=caption, trace=1, main="Response 2: Residuals vs Fitted") # TODO following fail: subset and keepxy try(plotmo(VolVolNega.Formula.subset.keepxy, nresponse=1, do.par=0, pt.col=2)) try(plotmo(VolVolNega.Formula.subset.keepxy, nresponse=2, do.par=0, pt.col=3)) par(old.par) # subset, multiple response, weights weights2 <- sqrt(1:nrow(trees1)) VolVolNega.formula.weights.subset.nokeepxy <- earth(cbind.Volume.VolNeg~Girth+Height, data=trees1, weights=weights2, subset=subset2, trace=1) VolVolNega.Formula.weights.subset.nokeepxy <- earth(Volume+VolNeg ~Girth+Height, data=trees1, weights=weights2, subset=subset2, trace=1) check.models.equal(VolVolNega.formula.weights.subset.nokeepxy, VolVolNega.Formula.weights.subset.nokeepxy, "VolVolNega.formula.weights.subset.nokeepxy, VolVolNega.Formula.weights.subset.nokeepxy") caption <- "VolVolNega.formula.weights.subset.nokeepxy" par(mfrow=c(3, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) plot(VolVolNega.formula.weights.subset.nokeepxy, nresponse=1, which=3, do.par=0, caption=caption, trace=1, main="Response 1: Residuals vs Fitted") plot(VolVolNega.formula.weights.subset.nokeepxy, nresponse=2, which=3, do.par=0, caption=caption, trace=1, main="Response 2: Residuals vs Fitted") plotmo(VolVolNega.formula.weights.subset.nokeepxy, nresponse=1, do.par=0, pt.col=2) plotmo(VolVolNega.formula.weights.subset.nokeepxy, nresponse=2, do.par=0, pt.col=3) par(old.par) caption <- "VolVolNega.Formula.weights.subset.nokeepxy" par(mfrow=c(3, 2), mar=c(3, 3, 3, 1), mgp=c(1.5, 0.5, 0), oma=c(0, 0, 5, 0)) plot(VolVolNega.Formula.weights.subset.nokeepxy, nresponse=1, which=3, do.par=0, caption=caption, trace=1, main="Response 1: Residuals vs Fitted") plot(VolVolNega.Formula.weights.subset.nokeepxy, nresponse=2, which=3, do.par=0, caption=caption, trace=1, main="Response 2: Residuals vs Fitted") plotmo(VolVolNega.Formula.weights.subset.nokeepxy, nresponse=1, do.par=0, pt.col=2) plotmo(VolVolNega.Formula.weights.subset.nokeepxy, nresponse=2, do.par=0, pt.col=3) par(old.par) # examples in earth vignette data(ozone1) mul1 <- earth(cbind(O3,wind) ~ ., data=ozone1) # formula interface mul2 <- earth(O3 + wind ~ ., data=ozone1) # use + on left of formula check.models.equal(mul2, mul1, "mul2, mul1", newdata=ozone1[1:3,]) mul3 <- earth(ozone1[,-c(1,3)], ozone1[,c(1,3)]) # x,y interface check.models.equal(mul3, mul1,"mul3, mul", newdata=ozone1[1:3,]) mul4 <- earth(cbind(log.O3=log(O3),wind) ~ ., data=ozone1) print(summary(mul4)) x1 <- ozone1$O3 x2 <- ozone1$win x3 <- ozone1$O3 y1 <- ozone1$temp y2 <- ozone1$doy mul5 <- earth(x=data.frame(x1, x2, log.x3=log(x3)), y=data.frame(y1, y2), trace=1) print(summary(mul5)) log.x3 <- log(x3) mul6 <- earth(y1 + y2 ~ x1 + x2 + log.x3, trace=1) stopifnot(all.equal(as.vector(mul5$coefficients), as.vector(mul6$coefficients))) stopifnot(all.equal(as.vector(mul5$dirs), as.vector(mul6$dirs))) mul7 <- earth(y1 + y2 ~ x1 + x2 + log(x3), trace=1) stopifnot(all.equal(as.vector(mul5$coefficients), as.vector(mul7$coefficients))) stopifnot(all.equal(as.vector(mul5$dirs), as.vector(mul7$dirs))) log.O3.wind <- log(ozone1$O3 + ozone1$wind) a10 <- earth(log.O3.wind + ibt ~ temp, data=ozone1, trace=1) a11 <- earth(log(O3 + wind) + ibt ~ temp, data=ozone1, trace=1) stopifnot(all.equal(as.vector(a10$coefficients), as.vector(a11$coefficients))) stopifnot(all.equal(as.vector(a10$dirs), as.vector(a11$dirs))) expect.err(try(show.earth.Formula(VolNeg+Volume~1, nresponses=2)), "'x' has no columns") # use lhs on rhs TODO earth itself should give an error message, not just plotmo expect.err(try(show.earth.Formula(VolNeg+Volume~Volume, nresponses=2)), "x is empty") # err from plotmo # formula has better error handling than Formula (model.matrix.default gives warning) expect.err(try(show.earth.formula(Volume~Volume)), "(converted from warning) the response appeared on the right-hand side and was dropped") show.earth.Formula(VolNeg+Volume~Girth, nresponses=2, subset=) show.earth.Formula(Volume+VolNeg+SinVol~., nresponses=3) show.earth.formula(VolNeg+SinVol~randx, nresponses=2) # intercept only model # TODO following should say "invalid formula: too many terms on the left hand side", but at least it gives an error message expect.err(try(earth(Volume+VolNeg|99~Girth+Height, data=trees, trace=1)), "multiple parts on left side of formula (because \"|\" was used)") expect.err(try(earth(Volume+VolNeg~Girth+Height|Volume, data=trees, trace=1)), "multiple parts on right side of formula (because \"|\" was used)") a1 <- earth(Volume+VolNeg~Girth+(Height|Volume), data=trees, trace=1) # ok, because | is in () (and earth will use formula, not Formula) stopifnot(NCOL(a1$coefficients) == 2) a2 <- earth(Volume+VolNeg~Girth+I(Height|Volume), data=trees, trace=1) # ok, because | is in I() stopifnot(NCOL(a2$coefficients) == 2) a3 <- earth((Volume+VolNeg)~Girth+Height, data=trees, trace=1) # ok, earth will build a single response model stopifnot(NCOL(a3$coefficients) == 1) # TODO it's a pity the following don't work expect.err(try(earth(Volume+VolNeg*999~., data=trees, trace=1)), "invalid model formula in ExtractVars") # use Formula expect.err(try(earth(Volume+VolNeg/99+SinVol~., data=trees, trace=1)), "invalid model formula in ExtractVars") # use Formula library(earth) data(ozone1) a10 <- earth(cbind(log.O3=log(O3),wind) ~ ., data=ozone1, trace=1) # ok a11 <- earth(log(O3) + wind ~ ., data=ozone1, trace=1) # wrong # TODO the following fails, it puts log(O3) on both sides of the formula try(stopifnot(all.equal(as.vector(a10$coefficients), as.vector(a11$coefficients)))) a1 <- earth(cbind(log.O3=log(O3),wind) ~ humidity+temp, data=ozone1) options(warn=2) expect.err(try(coef(a1)), "coef.earth: multiple response model: returning coefficients for just the first response") a2 <- earth(cbind(log(O3),wind) ~ humidity+temp, data=ozone1) stopifnot(all.equal(as.vector(a2$coefficients), as.vector(a1$coefficients))) log.O3 <- log(ozone1$O3) a3 <- earth(cbind(log.O3,wind) ~ humidity+temp, data=ozone1) stopifnot(all.equal(as.vector(a3$coefficients), as.vector(a1$coefficients))) a4 <- earth(log.O3+wind ~ humidity+temp, data=ozone1) stopifnot(all.equal(as.vector(a4$coefficients), as.vector(a1$coefficients))) a5 <- earth(log(O3)+wind ~ humidity+temp, data=ozone1) stopifnot(all.equal(as.vector(a5$coefficients), as.vector(a1$coefficients))) # multiple responses, mixed factors and numeric data(etitanic) pclass.age <- earth(pclass+age~sibsp, data=etitanic) plot(pclass.age, nresponse=4) par(mfrow=c(2,2)) options(warn=2) cat("plotmo(pclass.age, nresponse=1):\n") plotmo(pclass.age, nresponse=1, main="nresponse=1, pclass1st", do.par=FALSE) cat("plotmo(pclass.age, nresponse=2):\n") plotmo(pclass.age, nresponse=2, main="nresponse=2, pclass2nd", do.par=FALSE) cat("plotmo(pclass.age, nresponse=3):\n") plotmo(pclass.age, nresponse=3, main="nresponse=3, pclass3rd", do.par=FALSE) cat("plotmo(pclass.age, nresponse=4):\n") plotmo(pclass.age, nresponse=4, main="nresponse=4, age", do.par=FALSE) cat("plotmo(pclass.age, nresponse=5):\n") expect.err(try(plotmo(pclass.age, nresponse=5, main="nresponse=5", do.par=FALSE)), "nresponse is 5 but the number of columns is only 4") age.pclass <- earth(age+pclass~sibsp, data=etitanic) par(mfrow=c(2,2)) options(warn=2) cat("plotmo(age.pclass, nresponse=1):\n") plotmo(age.pclass, nresponse=1, main="nresponse=1, age", do.par=FALSE, trace=1) cat("plotmo(age.pclass, nresponse=2):\n") plotmo(age.pclass, nresponse=2, main="nresponse=2, pclass1st", do.par=FALSE) cat("plotmo(age.pclass, nresponse=3):\n") plotmo(age.pclass, nresponse=3, main="nresponse=3, pclass2nd", do.par=FALSE) cat("plotmo(age.pclass, nresponse=4):\n") plotmo(age.pclass, nresponse=4, main="nresponse=4, pclass3rd", do.par=FALSE) cat("plotmo(age.pclass, nresponse=5):\n") expect.err(try(plotmo(age.pclass, nresponse=5, main="nresponse=5", do.par=FALSE)), "nresponse is 5 but the number of columns is only 4") pclass.sex <- earth(pclass+sex~sibsp, data=etitanic) par(mfrow=c(2,2)) options(warn=2) cat("plotmo(pclass.sex, nresponse=1):\n") plotmo(pclass.sex, nresponse=1, main="nresponse=1, pclass1st", do.par=FALSE, trace=1) cat("plotmo(pclass.sex, nresponse=2):\n") plotmo(pclass.sex, nresponse=2, main="nresponse=2, pclass2nd", do.par=FALSE) cat("plotmo(pclass.sex, nresponse=3):\n") plotmo(pclass.sex, nresponse=3, main="nresponse=3, pclass3rd", do.par=FALSE) cat("plotmo(pclass.sex, nresponse=4):\n") plotmo(pclass.sex, nresponse=4, main="nresponse=4, age", do.par=FALSE) cat("plotmo(pclass.sex, nresponse=5):\n") expect.err(try(plotmo(pclass.sex, nresponse=5, main="nresponse=5", do.par=FALSE)), "nresponse is 5 but the number of columns is only 4") source("test.epilog.R") earth/inst/slowtests/test.plotd.R0000644000176200001440000003712113375574541016646 0ustar liggesusers# test.plotd.R source("test.prolog.R") library(earth) data(etitanic) printh <- function(caption) cat("===", caption, "\n", sep="") multifigure <- function(caption) { printh(caption) par(mfrow=c(2, 2)) par(cex = 0.7) par(mar = c(4, 3, 1.7, 0.5)) # small margins and text to pack figs in par(mgp = c(1.6, 0.6, 0)) # flatten axis elements oma <- par("oma") # make space for caption oma[3] <- 2.4 par(oma=oma) } do.caption <- function(caption) mtext(caption, outer=TRUE, font=2, line=1, cex=1) old.par <- par(no.readonly=TRUE) # test plotd basic functionality on a numeric response multifigure("a1") # start a new page a1 <- earth(survived ~ ., data=etitanic, degree=2, glm=list(family=binomial)) plotd(a1) do.caption("a1") plotd(a1, main="earth-glm, numeric, kernel=epan adjust=.3", trace=TRUE, kernel="epan", adjust=.3, legend.names=c("mylegend", "mylegend2"), legend.pos=c(.3,4), cex.legend=1, legend.extra=TRUE, col=c(1, "green"), fill="red") plotd(a1, main="earth-glm, numeric, type=earth, params", type="earth", xlab="my xlab", ylab="my ylab", legend.pos="topleft", xlim=c(-.5, 1.5), zero.line=TRUE, vline.col="green", col=c("pink", "red"), fill="pink") plotd(a1, main="earth-glm, numeric, type=link, params", type="link", legend=FALSE, col=c("red", "blue"), lty=c(1,2), vline.thresh=1, vline.col="gray", vline.lty=2) # test with earth.default (as opposed to earth.formula) multifigure("a2") # start a new page a2 <- earth(etitanic[,-2], etitanic$survived, degree=2, glm=list(family=binomial)) plotd(a2, main="earth.default-glm, numeric response") do.caption("a2") printh("a3") a3 <- earth(etitanic[,-1], etitanic$pclass, degree=2, glm=list(family=binomial)) plotd(a3, main="earth.default-glm, 3 lev fac") # test plotd with histograms plotd(a3, main="earth-glm, 3 lev fac, hist", hist=TRUE) plotd(a3, main="earth-glm, 3 lev fac, hist, params", hist=TRUE, col=c("green", "red", "black"), fill="pink", lty=c(1,3), xlab="my xlab", ylab="my ylab", xlim=c(-.2, 1.2), vline.thresh=.65, vline.col="brown", vline.lty=2, breaks=5) # xlim and ylim tests multifigure("xlim and ylim tests") # start a new page plotd(a1, xlim=c(.25,.75), fill="gray") printh("xlim and ylim tests") plotd(a1, xlim=c(.25,1), ylim=c(0,2)) plotd(a1, xlim=c(.25,.75), hist=TRUE) plotd(a1, xlim=c(.25,1), ylim=c(0,100), hist=TRUE) # test plotd with a logical response multifigure("a5") bool.survived <- as.logical(etitanic$survived) a5 <- earth(bool.survived ~ . - survived, data=etitanic, degree=2, glm=list(family=binomial)) plotd(a5, main="earth-glm, logical") do.caption("a5") plotd(a5, main="earth-glm, logical, hist", hist=TRUE) # test plotd with a two level factor multifigure("a6") a6 <- earth(sex ~ ., data=etitanic, glm=list(family=binomial)) plotd(a6, main="earth-glm, 2 lev fac", fill="gray70") do.caption("a6") plotd(a6, main="earth-glm, 2 lev fac, type=class", type="class", fill="gray70") plotd(a6, main="earth-glm, 2 lev fac, hist ", hist=TRUE) plotd(a6, main="earth-glm, 2 lev fac, hist, type=class", type="class", hist=TRUE, labels=TRUE) # test plotd with a 3 level factor multifigure("a7") a7 <- earth(pclass ~ ., data=etitanic, glm=list(family=binomial)) plotd(a7, main="earth-glm, 3 lev fac", col=c("pink", "red", "brown"), fill="pink") do.caption("a7") plotd(a7, main="earth-glm, 3 lev fac, params", xlab="my xlab", ylab="my ylab", xlim=c(-.2, 1.2), col=c("pink", "black", "green"), lty=c(1,3,1), vline.thresh=.2, vline.col="blue", vline.lty=3, adjust=.3) plotd(a7, main="earth-glm, 3 lev fac, hist", hist=TRUE) plotd(a7, main="earth-glm, 3 lev fac, hist, params", hist=TRUE, col=c("pink", "red", "black"), fill=c("pink"), lty=c(1,2,3), xlab="my xlab", ylab="my ylab", xlim=c(-.2, 1.2), vline.thresh=.65, vline.col="gray", vline.lty=1, breaks=5) multifigure("a7 part 2") plotd(a7, type="class", main="earth-glm, 3 lev fac, type=class", fill="gray70") do.caption("a7 part 2") plotd(a7, type="class", main="earth-glm, 3 lev fac, hist, type=class", hist=TRUE, labels=TRUE) # test nresponse multifigure("a7 with nresponse") plotd(a7, main="earth.default-glm, 3 lev fac") do.caption("a7 with nresponse") plotd(a7, main="earth.default-glm, 3 lev fac, nresp=1", nresp=1) plotd(a7, main="earth.default-glm, 3 lev fac, nresp=2", nresp=2) #plotd(a7, main="earth.default-glm, 3 lev fac, nresp=c(1,2)", nresp=c(1,2)) # test plotd with earth not glm multifigure("a8") a8 <- earth(survived ~ ., data=etitanic, degree=2) plotd(a8, main="earth, numeric, no glm arg") do.caption("a8") plotd(a8, main="earth, hist, num, no glm arg, type=class", hist=TRUE, type="class") printh("a9") a9 <- earth(survived - .5 ~ .-survived, data=etitanic, degree=2) plotd(a9, main="earth, survived-.5, type=class, thresh=0", hist=TRUE, type="class",thresh=0,vline.col="brown",xaxis.cex=.8, fill="pink",breaks=4,labels=TRUE) plotd(a9, main="earth, survived-.5, type=class, thresh=0.3", hist=TRUE, type="class",thresh=0.3,vline.col="brown", xaxis.cex=.7,breaks=3,labels=TRUE) multifigure("a10") bool.survived <- as.logical(etitanic$survived) a10 <- earth(bool.survived ~ . - survived, data=etitanic, degree=2) plotd(a10, main="earth, logical, no glm arg") do.caption("a10") printh("a11") a11 <- earth(sex ~ ., data=etitanic, degree=2) plotd(a11, main="earth, 2 lev fac, no glm arg") printh("a12") a12 <- earth(pclass ~ ., data=etitanic, degree=2) plotd(a12, main="earth, 3 lev fac, no glm arg") # test that we can change the order of the levels and still get the same results multifigure("compare pclass with different factor levels") printh("fit.pclass") fit.pclass <- earth(pclass ~ ., data=etitanic, degree=2) plotd(fit.pclass, type="class", hist=1, main="fit.pclass", fill=0, col=c(2, 1, "lightblue")) do.caption("left and right graphs should match, up to level order") printh("fit.pclass.reorder") tit <- etitanic pclass <- as.character(tit$pclass) pclass[pclass == "1st"] <- "first" pclass[pclass == "2nd"] <- "class2" pclass[pclass == "3rd"] <- "classthird" tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) fit.pclass.reorder <- earth(pclass ~ ., data=tit, degree=2) plotd(fit.pclass.reorder, type="class", hist=1, main="fit.pclass.reorder", col=c(1, "lightblue", 2), fill=0, legend.pos="topright") # examples from the man page printh("example(plotd)") example(plotd) do.caption("example(plotd)") multifigure("glm.model example from man page") library(earth); data(etitanic) glm.model <- glm(sex ~ ., data=etitanic, family=binomial) plotd(glm.model) do.caption("glm.model example from man page") printh("lm.model example from man page") library(earth); data(etitanic) lm.model <- lm(as.numeric(sex) ~ ., data=etitanic) plotd(lm.model, trace=2) plot(1,1) # empty.plot plot(1,1) # test with rpart (also test nresponse with a character value) printh("rpart") library(rpart); library(earth); data(etitanic) rpart.model <- rpart(sex ~ ., data = etitanic, method="class") plotd(rpart.model, type="prob", nresponse="female") plotd(rpart.model, type="prob", nresponse="ma") plotd(rpart.model, type="class", hist=TRUE, labels=TRUE) plotd(rpart.model, hist=TRUE, labels=TRUE) # default type is "vector" printh("lda.model examples from man pages") library(MASS); library(earth); data(etitanic) lda.model <- lda(sex ~ ., data=etitanic) plotd(lda.model, type="response") plotd(lda.model, hist=TRUE, labels=TRUE) library(MASS); library(earth); set.seed(420) example(lda) plotd(z, type="response", nresponse=1) # nresponse=1 selects first linear discriminant do.caption("lda.model example from example(lda)") a.qda <- qda(survived ~ ., data=etitanic) plotd(a.qda) plotd(a.qda, type="post") # test plotd with lm models multifigure("lm1") lm1 <- lm(survived ~ ., data=etitanic) plotd(lm1) do.caption("lm1") plotd(lm1, main="lm1, survived") plotd(lm1, hist=TRUE, main="lm1, survived, hist=TRUE, labels=1", labels=1) printh("lm2") bool.survived <- as.logical(etitanic$survived) lm2 <- lm(bool.survived ~ . - survived, data=etitanic) plotd(lm2, main="lm, logical") # following commented out because lm doesn't like factor responses(?) # printh("lm3") # lm3 <- lm(sex ~ ., data=etitanic) # plotd(lm3, main="lm, 2 lev fac") # # printh("lm4") # lm4 <- lm(pclass ~ ., data=etitanic) # plotd(lm4, main="lm, 3 lev fac") multifigure("lm5") lm5 <- lm(age - mean(age)~ ., data=etitanic) plotd(lm5, main="lm5, age - mean(age)") do.caption("lm5") printh("lm6") lm6 <- lm(unclass(pclass)-1 ~ ., data=etitanic) plotd(lm6, main="lm6, unclass(pclass)-1") plotd(lm6, main="lm6, unclass(pclass)-1, fac=TRUE", hist=TRUE) printh("lm7") lm7 <- lm(cbind(survived, sin(age)) ~ ., data=etitanic) # nonsense model plotd(lm7, xlim=c(-.5,1.5), hist=TRUE, main="lm7, NCOL(y)==2") multifigure("lm5") lm8 <- lm(cbind(survived, sin(age), cos(age)) ~ ., data=etitanic) # nonsense model plotd(lm8, hist=TRUE, main="lm8, NCOL(y)==3") do.caption("lm8") # test plotd with glm models multifigure("glm1") glm1 <- glm(survived ~ ., data=etitanic, family=binomial) plotd(glm1, main="glm1, survived") do.caption("glm1") printh("glm2") glm2 <- glm(pclass ~ ., data=etitanic, family=binomial) plotd(glm2, main="glm2, pclass") printh("glm3") glm3 <- glm(sex ~ ., data=etitanic, family=binomial) plotd(glm3, main="glm3, sex") multifigure("glm, 3 level factor with dichot") glm4 <- glm(pclass ~ ., data=etitanic, family=binomial) plotd(glm4, dichot = TRUE, type="link") do.caption("glm, 3 level factor with dichot") plotd(glm4, dichot = FALSE, type="link") plotd(glm4, dichot = TRUE) # default type="response" plotd(glm4, dichot = FALSE, type=NULL) # default type="response" # lda with formula interface library(MASS) multifigure("lda1") lda1 <- lda(sex ~ ., data=etitanic) plotd(lda1, main="lda1, 2 lev fac", trace=1) do.caption("lda1") plotd(lda1, main="lda1, 2 lev fac, hist=TRUE", type="response", hist=TRUE) plotd(lda1, main="lda1, 2 lev fac, hist=TRUE, type=post", hist=TRUE, type="post") plotd(lda1, main="lda1, 2 lev fac, hist=TRUE, type=class", hist=TRUE, type="class", labels=TRUE) multifigure("lda2") lda2 <- lda(pclass ~ ., data=etitanic) plotd(lda2, type="response", main="lda2, 3 lev fac, nresponse=1", jitter=TRUE, nresponse=1) do.caption("lda2") plotd(lda2, type="response", main="lda2, 3 lev fac, nresponse=1", jitter=TRUE, nresponse=1) plotd(lda2, type="response", main="lda2, 3 lev fac, nresponse=2", jitter=TRUE, nresponse=2) # plotd(lda2, main="lda2, 3 lev fac, nresponse=NULL", jitter=TRUE, nresponse=NULL) multifigure("lda2 part 2") # plotd(lda2, type="response", main="lda2, 3 lev fac, hist=TRUE", hist=TRUE) plotd(lda2, main="lda2, 3 lev fac, hist=TRUE, type=p, nresponse=1", hist=TRUE, type="p", nresponse=1) do.caption("lda2 part 2") plotd(lda2, main="lda2, 3 lev fac, type=p", type="p") plotd(lda2, main="lda2, 3 lev fac, hist=TRUE, type=class, nresponse=1", hist=TRUE, type="class", nresponse=1) multifigure("lda2 with dichot") plotd(lda2, main="lda2, 3 lev fac, type=p, nresponse=1", hist=TRUE, type="p", nresponse=1) do.caption("lda2 with dichot") plotd(lda2, main="lda2, 3 lev fac, dichot=1, type=p, nresponse=1", hist=TRUE, type="p", nresponse=1, dichot=TRUE) plotd(lda2, main="lda2, 3 lev fac, type=p, nresponse=1", type="p", nresponse=1) plotd(lda2, main="lda2, 3 lev fac, dichot=1, type=p, nresponse=1", type="p", nresponse=1, dichot=TRUE) multifigure("lda3") lda3 <- lda(survived ~ ., data=etitanic) plotd(lda3, type="response", main="lda3, logical") do.caption("lda3") plotd(lda3, type="response", main="lda3, logical, hist=TRUE", hist=TRUE) plotd(lda3, main="lda3, logical, hist=TRUE, type=posterior", hist=TRUE, type="posterior") plotd(lda3, main="lda3, logical, hist=TRUE, type=class", hist=TRUE, type="class", labels=TRUE) # lda with default interface # predict.lda (called by plotd) can't deal with factors in x argument etitanic1 <- etitanic etitanic1[,1] <- as.numeric(etitanic1[,1]) # pclass etitanic1[,3] <- as.numeric(etitanic1[,3]) # sex multifigure("ldad1") ldad1 <- lda(etitanic1[,-3], etitanic$sex) plotd(ldad1, type="response", main="ldad1, 2 lev fac") do.caption("ldad1") plotd(ldad1, type="response", main="ldad1, 2 lev fac, hist=TRUE", hist=TRUE) plotd(ldad1, main="ldad1, 2 lev fac, hist=TRUE, type=post", hist=TRUE, type="post") plotd(ldad1, main="ldad1, 2 lev fac, hist=TRUE, type=class", hist=TRUE, type="class") multifigure("ldad2") ldad2 <- lda(etitanic1[,-1], etitanic$pclass) # plotd(ldad2, type="response", main="ldad2, 3 lev fac", jitter=TRUE) plotd(ldad2, type="response", main="ldad2, 3 lev fac, nresponse=1", jitter=TRUE, nresponse=1) do.caption("ldad2") plotd(ldad2, type="response", main="ldad2, 3 lev fac, nresponse=2", jitter=TRUE, nresponse=2) multifigure("ldad2 part 2") plotd(ldad2, type="response", main="ldad2, 3 lev fac, hist=TRUE, nresponse=1", hist=TRUE, nresponse=1) do.caption("ldad2 part 2") plotd(ldad2, main="ldad2, 3 lev fac, hist=TRUE, type=p, nresponse=1", hist=TRUE, type="p", nresponse=1) plotd(ldad2, main="ldad2, 3 lev fac, type=p, nresponse=1", type="po", nresponse=1) plotd(ldad2, main="ldad2, 3 lev fac, hist=TRUE, type=class, nresponse=1", hist=TRUE, type="cla", nresponse=1) multifigure("ldad3") ldad3 <- lda(etitanic1[,-2], etitanic$survived) plotd(ldad3, type="response", main="ldad3, logical") do.caption("ldad3") plotd(ldad3, type="response", main="ldad3, logical, hist=TRUE", hist=TRUE) plotd(ldad3, main="ldad3, logical, hist=TRUE, type=post", hist=TRUE, type="post") plotd(ldad3, main="ldad3, logical, hist=TRUE, type=cl", hist=TRUE, type="cl") # err shading multifigure("err shading") a.shade <- earth(survived ~ ., data=etitanic, degree=2, glm=list(family=binomial)) plotd(a.shade, vline.col="gray", err.col=c("slategray1","slategray3"), fill=0) do.caption("err shading") plotd(a.shade, vline.col="gray", err.col=c(0, 0,"pink"), fill=0, vline.thresh = .6, err.border=c(0,0,2)) # try various err.shade options plotd(a.shade, vline.thresh = .7, vline.col=1, vline.lty=2, vline.lwd=3, fill=0, col=c(2,1), err.col=c("slategray1","slategray3","pink"), err.border=c(3,4,5), err.lwd=c(1,2,3)) # reverse direction of reducible error area a1.shade <- earth(!survived ~ ., data=etitanic, degree=2, glm=list(family=binomial)) plotd(a1.shade, vline.col="gray", err.col=c("slategray1","slategray3","pink"), err.border=c("slategray1","slategray3","red")) # clip xlim into the shaded area and make sure area is still shaded correctly multifigure("err shading with xlim") a.shade <- earth(survived ~ ., data=etitanic, degree=2, glm=list(family=binomial)) plotd(a.shade, vline.thresh = .7, vline.col=1, vline.lty=2, vline.lwd=3, fill=0, col=c(2,1), err.col=c("slategray1","slategray3","pink"), err.border=c(3,4,5), err.lwd=c(1,2,3), xlim=c(.3,1)) plotd(a.shade, vline.thresh = .7, vline.col=1, vline.lty=2, vline.lwd=3, fill=0, col=c(2,1), err.col=c("slategray1","slategray3","pink"), err.border=c(3,4,5), err.lwd=c(1,2,3), xlim=c(.5,1)) plotd(a.shade, vline.thresh = .7, vline.col=1, vline.lty=2, vline.lwd=3, fill=0, col=c(2,1), err.col=c("slategray1","slategray3","pink"), err.border=c(3,4,5), err.lwd=c(1,2,3), xlim=c(.3,.6)) # reverse direction of reducible error area a1.shade <- earth(!survived ~ ., data=etitanic, degree=2, glm=list(family=binomial)) plotd(a1.shade, vline.col="gray", err.col=c("slategray1","slategray3","pink"), err.border=c("slategray1","slategray3","red"), xlim=c(.52, .9)) par(old.par) source("test.epilog.R") earth/inst/slowtests/test.offset.bat0000755000176200001440000000152713514230362017344 0ustar liggesusers@rem test.offset.bat @rem Stephen Milborrow Dec 2018 Midtown @echo test.offset.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.offset.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.offset.Rout: @echo. @tail test.offset.Rout @echo test.offset.R @exit /B 1 :good1 mks.diff test.offset.Rout test.offset.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.offset.save.ps @exit /B 1 :good2 @rem test.offset.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.offset.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.offset.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.full.bat0000755000176200001440000000151213514230362017012 0ustar liggesusers@rem test.full.bat: this does a regression test of earth @rem Stephen Milborrow Apr 2007 Petaluma @echo test.full.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.full.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.full.Rout: @echo. @tail test.full.Rout @echo test.full.R @exit /B 1 :good1 mks.diff test.full.Rout test.full.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.full.save.ps @exit /B 1 :good2 @rem test.full.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.full.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.full.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.big.R0000644000176200001440000000573213447243663016266 0ustar liggesusers# test.big: test earth with a biggish model source("test.prolog.R") library(earth) options(digits=3) p <- 100 n <- 20000 # big enough to cross ten-thousand-cases barrier in plotres and plotmo # p <- 100; n <- 10e6 # earth 4.4.0: Error in forward.pass: Out of memory (could not allocate 15 GB) # ok with nk=21, 42 minutes to build model # earth 4.6.3: Stopped after two hours, much memory paging # p <- 100; n <- 9e6 # windows 64 bit system, 2.9 GHz i7, 32 gig ram, SSD drive: # earth 4.4.0: Out of memory (could not allocate 15 GB) # earth 4.6.3: ok (earth now uses .Call instead of .C to invoke ForwardPassR) # 55 mins to build model # p <- 100; n <- 8e6 # 51 minutes to build model, additional 1.5 minutes for plotmo and plotres # p <- 2; n <- 60e6 # ok # p <- 2; n <- 80e6 # ok (but not enough memory to get leverages) # # 18 minutes to build model, additional 8 minutes for plotmo and plotres # # p <- 2; n <- 100e6 # earth 4.6.3: thrashes, interupted after a few hours # # earth 4.4.0 Error in leaps.setup: Reached total allocation of 32673Mb # # ok with nk=11, not so much thrashing, 10 minutes cat("creating x\n") ran <- function() runif(n, min=-1, max=1) x <- matrix(ran(), ncol=1) if(p >= 2) x <- cbind(x, ran()) if(p >= 3) x <- cbind(x, ran()) if(p >= 4) { # xran saves time generating x, ok because func uses only columns x1, x2, and x3 xran <- ran() x <- cbind(x, matrix(xran, nrow=n, ncol=p-3)) } colnames(x) <- paste("x", 1:ncol(x), sep="") func <- function(x) # additive, no interactions { y <- sin(4 * x[,1]) if(p > 1) y <- y + x[,2] if(p > 2) y <- y + 2 * x[,3]^2 - 1 y } cat("creating y\n") y <- func(x) cat("testing memory handling when an error (Adjust.endspan = -999)\n") dummy.allowed <- function(degree, pred, parents) TRUE expect.err(try(earth(x, y, trace=1.5, allowed=dummy.allowed, Adjust.endspan = -999)), "Adjust.endspan is -999 but should be between 0 and 10") cat("calling earth\n") start.time <- proc.time() a <- earth(x, y, degree=1, trace=1.5) if(interactive()) printf("n %g p %g: earth time %.3f seconds (%.3f minutes)\n", n, p, (proc.time() - start.time)[3], (proc.time() - start.time)[3] / 60) cat("print(summary(a1)):\n") print(summary(a)) invisible(gc()) cat("calling plotmo\n") plotmo(a, trace=-1) invisible(gc()) cat("calling plotres\n") set.seed(2015) # TODO this is necessary, why? plot(a, trace=1) if(interactive()) { printf("n %g p %g: total time %.3f seconds (%.3f minutes)\n", n, p, (proc.time() - start.time)[3], (proc.time() - start.time)[3] / 60) x <- y <- 0 # free memory by reducing size of large matrices gc() # release memory back to operating system } source("test.epilog.R") earth/inst/slowtests/test.multresp.bat0000755000176200001440000000156013514230362017726 0ustar liggesusers@rem test.multresp.bat @rem Stephen Milborrow Mar 2019 Petaluma @echo test.multresp.bat @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.multresp.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.multresp.Rout: @echo. @tail test.multresp.Rout @echo test.multresp.R @exit /B 1 :good1 mks.diff test.multresp.Rout test.multresp.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.multresp.save.ps @exit /B 1 :good2 @rem test.multresp.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.multresp.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.multresp.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.varmod.mgcv.Rout.save0000644000176200001440000002051213560107140021407 0ustar liggesusers> # test.varmmod.mgcv.R > # mgcv has to be tested separately because of clashes between library(gam) and library(mgcv) > # Stephen Milborrow Apr 2015 Berea > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > options(warn=2) > > printh <- function(caption) + cat("===", caption, "\n", sep="") > > CAPTION <- NULL > > multifigure <- function(caption, nrow=3, ncol=3) + { + CAPTION <<- caption + printh(caption) + par(mfrow=c(nrow, ncol)) + par(cex = 0.8) + par(mar = c(3, 3, 5, 0.5)) # small margins but space for right hand axis + par(mgp = c(1.6, 0.6, 0)) # flatten axis elements + oma <- par("oma") # make space for caption + oma[3] <- 2 + par(oma=oma) + } > do.caption <- function() # must be called _after_ first plot on new page + mtext(CAPTION, outer=TRUE, font=2, line=1, cex=1) > old.par <- par(no.readonly=TRUE) > > library(mgcv) Loading required package: nlme This is mgcv 1.8-30. For overview type 'help("mgcv-package")'. > > for(varmod.method in c("gam", "x.gam")) { + + multifigure(sprint("varmod.method=\"%s\"", varmod.method), 2, 3) + par(mar = c(3, 3, 2, 3)) # space for right margin axis + + set.seed(6) + earth.mod <- earth(Volume~Girth, data=trees, nfold=3, ncross=3, + varmod.method=varmod.method, + trace=if(varmod.method %in% c("const", "lm", "power")) .3 else 0) + printh(sprint("varmod.method %s: summary(earth.mod)", varmod.method)) + printh("summary(earth.mod)") + print(summary(earth.mod)) + + # summary(mgcv) prints environment as hex address which messes up the diffs + printh("skipping summary(mgcv::gam) etc.\n") + + printh(sprint("varmod.method %s: predict(earth.mod, interval=\"pint\")", varmod.method)) + pints <- predict(earth.mod, interval="pint") + print(pints) + + plotmo(earth.mod$varmod, do.par=FALSE, col.response=2, clip=FALSE, + main="plotmo residual model", + xlab="x", ylab="varmod residuals") + + plotmo(earth.mod, level=.90, do.par=FALSE, col.response=1, clip=FALSE, + main="main model plotmo Girth") + do.caption() + + plot(earth.mod, which=3, do.par=FALSE, level=.95) + + # plot.varmod + plot(earth.mod$varmod, do.par=FALSE, which=1:3, info=(varmod.method=="earth")) + } ===varmod.method="gam" ===varmod.method gam: summary(earth.mod) ===summary(earth.mod) Call: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9266989 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.927 0.043 9.81 7.21 varmod: method "gam" (mgcv package) min.sd 0.381 iter.rsq 0.269 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 3.806614 0.535912 14 s(Volume).1 0.000000 NA NA s(Volume).2 0.000000 NA NA s(Volume).3 0.000000 NA NA s(Volume).4 0.000000 NA NA s(Volume).5 0.000000 NA NA s(Volume).6 0.000000 NA NA s(Volume).7 0.000000 NA NA s(Volume).8 0.000000 NA NA s(Volume).9 1.929016 NA NA mean smallest largest ratio 95% prediction interval 14.92165 5.262808 35.55661 6.756206 68% 80% 90% 95% response values in prediction interval 74 90 97 97 ===skipping summary(mgcv::gam) etc. ===varmod.method gam: predict(earth.mod, interval="pint") fit lwr upr 1 9.913855 7.282451 12.54526 2 10.942195 8.065628 13.81876 3 11.627755 8.587747 14.66776 4 17.455018 13.025754 21.88428 5 18.140578 13.547872 22.73328 6 18.483359 13.808931 23.15779 7 19.168919 14.331050 24.00679 8 19.168919 14.331050 24.00679 9 19.511699 14.592109 24.43129 10 19.854479 14.853168 24.85579 11 20.197259 15.114227 25.28029 12 20.540040 15.375287 25.70479 13 20.540040 15.375287 25.70479 14 21.568380 16.158464 26.97830 15 22.596721 16.941642 28.25180 16 25.681742 19.291175 32.07231 17 25.681742 19.291175 32.07231 18 27.052863 20.335412 33.77031 19 28.423983 21.379649 35.46832 20 28.766764 21.640708 35.89282 21 30.080913 22.641556 37.52027 22 31.395063 23.642404 39.14772 23 33.366287 25.143676 41.58890 24 43.222408 32.650036 53.79478 25 45.193632 34.151308 56.23596 26 51.764379 39.155548 64.37321 27 53.078529 40.156396 66.00066 28 55.706828 42.158092 69.25556 29 56.363903 42.658516 70.06929 30 56.363903 42.658516 70.06929 31 73.447846 55.669540 91.22615 ===varmod.method="x.gam" ===varmod.method x.gam: summary(earth.mod) ===summary(earth.mod) Call: earth(formula=Volume~Girth, data=trees, trace=if(varmod.method%in%c("const","lm","power"))0.3els...), nfold=3, ncross=3, varmod.method=varmod.method) coefficients (Intercept) 28.766764 h(13.8-Girth) -3.427802 h(Girth-13.8) 6.570747 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: Girth Number of terms at each degree of interaction: 1 2 (additive model) GCV 14.20145 RSS 309.6832 GRSq 0.949137 RSq 0.9617962 CVRSq 0.9266989 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.00 sd 0.00 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.927 0.043 9.81 7.21 varmod: method "x.gam" (mgcv package) min.sd 0.372 iter.rsq 0.346 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 3.721062 0.481473 13 s(Volume).1 0.000000 NA NA s(Volume).2 0.000000 NA NA s(Volume).3 0.000000 NA NA s(Volume).4 0.000000 NA NA s(Volume).5 0.000000 NA NA s(Volume).6 0.000000 NA NA s(Volume).7 0.000000 NA NA s(Volume).8 0.000000 NA NA s(Volume).9 1.638241 NA NA mean smallest largest ratio 95% prediction interval 14.5863 4.292688 29.87908 6.96046 68% 80% 90% 95% response values in prediction interval 77 90 97 97 ===skipping summary(mgcv::gam) etc. ===varmod.method x.gam: predict(earth.mod, interval="pint") fit lwr upr 1 9.913855 7.767511 12.06020 2 10.942195 8.483822 13.40057 3 11.627755 8.961363 14.29415 4 17.455018 13.020460 21.88958 5 18.140578 13.498001 22.78316 6 18.483359 13.736771 23.22995 7 19.168919 14.214312 24.12353 8 19.168919 14.214312 24.12353 9 19.511699 14.453082 24.57032 10 19.854479 14.691853 25.01711 11 20.197259 14.930623 25.46390 12 20.540040 15.169394 25.91069 13 20.540040 15.169394 25.91069 14 21.568380 15.885705 27.25106 15 22.596721 16.602016 28.59142 16 25.681742 18.750950 32.61253 17 25.681742 18.750950 32.61253 18 27.052863 19.706032 34.39969 19 28.423983 20.661114 36.18685 20 28.766764 20.899884 36.63364 21 30.080913 22.006014 38.15581 22 31.395063 23.112144 39.67798 23 33.366287 24.771339 41.96123 24 43.222408 33.067314 53.37750 25 45.193632 34.726509 55.66076 26 51.764379 40.257159 63.27160 27 53.078529 41.363289 64.79377 28 55.706828 43.575549 67.83811 29 56.363903 44.128614 68.59919 30 56.363903 44.128614 68.59919 31 73.447846 58.508304 88.38739 > par(old.par) > > source("test.epilog.R") earth/inst/doc/0000755000176200001440000000000013254263570013106 5ustar liggesusersearth/inst/doc/earth-varmod.pdf0000644000176200001440000103714713561364217016210 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4859 /Filter /FlateDecode /N 93 /First 786 >> stream x\[sF~?o뭭`lReYrY@5E*$e;̀P$䜒a===tPfS"B0ϴsTgq CgTE*25̚]f>,29S"ҨL{0T U`LdE!8 Oyͫ.grȪiV 9IOf%#{Q_#$4!نW$I<6~W9ItNS]>D]tOgZ~$s _3P nD}_.`>~2pN-tz=P#_9 @ rG\ost\i'PoȨ22EΦr250F{o9rߨs\̮秐ٛ%饊fT'sNߔ8zߖ Myvx</RaEd/¤2kEKIcֲHDDHDD&l F"L.jX>)N a0{9Je557xy^AR|(Nݺݍ&m2*: P1Տeu~-ScϞ쐽b?숽a-1^9 ;씝&)1&ќ,Pgף ;cg՗A9` i}f6) vɦlZMK6<)|flWleR-Ul̮& ;z,'6g (E-&[ż,]/+`?'NR p0/(*; tx{PMJkk}5,;qWuxzxF=rX-d(LoGî؇ԅIx<}/eE+]-: aKRz ?" a J (@ 00'҆s,= FOOU|fpJ^`zlR~čjF1 @_?I' J *UI_xQ沊MY`ϜFy2|i~pDoM ZТhO@C No 'zZJM4D +FG GSpUH+tB2E-$3OD#N9kKiCnc.pBp}#BXï6 g"FiOܣP.JoF3tf|׮:y=W{ށ~aA6l=oe[;Ea5bhX?ز6Bώ~ޛ#vmfcfkfcffoq&by4}VhB mB}\K)6t(){H< bV*yv4RB7iDwNvjG$] l} zrur9Z|0ES0*Ɍ# MU0֞엨mҜP׺ -elU@֍+:-:L*7srX<.'k'Lȉ"'FNԟ w`9a̓C>Ian#wͭ"r:.4SB͏?x¬ Ԭp7f7C^ w<fu:{evou4L#=:z\jKΆg6$R[·2-\SģV|}9IF5KZɐBl,Jn}clϥRމv O ]4o$#oXP4fhlpx/b?MQ&Lpیk]x;>OM _$ͣж¶_wVq$"߉%cNHntPA-! Da-邟_~XNtLֳHkh70!LٔRY]RE 9bitlV281ЇGzÕ$&B2/Qigeә )805 /+aaP^VS`v'``DsܙmsQi=J\ }P/&L^O_no6`zl;94=r+ҧ}:Bڿi-VzDL6@t-3~V4q;,)4༑RI:nQZDhuc>97T[y|6>n{PuaMMԏho4'L%VV^d2UpDk2D]%6w.g˚/)E.)2/8 ENlar lJ2LLz)K u>L:k}5>֛VLJVٴ4iLvdZ#]Z״F6Ջ4pF3gJ ­vFo:/IȈ6=Ӎ'r4?qu׋겚M[RߑP^agvC1r7J}=`.+SՍ tI_J<% .hF !dU!+SQCZ㷇GO?pcWꆺt0roVF'Iu4!nRЏ`NԙߐPC1j(Ms&f DCYWKH$%0c͠O5 0`ɅXT/,Z9! @ZYԗO4MAaX[xr&pV<קҝxߍ? `{FtM]+(D߭?,3% XZ3%Pݘ(rCz:;+^°*"E Jga> stream GPL Ghostscript 9.19 2019-11-08T12:57:51-08:00 2019-11-08T12:57:51-08:00 LaTeX with hyperref package Variance models in earthStephen MilborrowVariance models in earth endstream endobj 96 0 obj << /Type /ObjStm /Length 2702 /Filter /FlateDecode /N 93 /First 843 >> stream xZ]}c$i81ֆȃ+BZcn}ϡFZvG1593sfL-jj59#Go`r(Ԍ1O_2>HR<&x~d1;\bMaLW }4d&o)h>q#"\\ĂGQN0R1Ah&&$AĢT3<Ӧ P$)|MjGݤbFQD,/mf m$W|Ue؋bc kSk,5櫫_+ý}\j=[ϛo 㧛oW/_y7A?і3Rb:BtVyh9T!D,ELOX- W1c ۻ]wd[w*yvfڌT4aq-g["3\nJ!Jhچ^(l:`a ?m~~a=,~{'grxVz櫧/vϖW[X>^7/Wf1\9^|X_]Q_Ĵդo lbL*M#7>3f=mk= j;FsTkQg6_}K$ܽfywͻEwٽUwݭ/goWT@v'[1yfQr.~ֳ9v/ݘ w^4a뻟CED 7w%dz1v_v_k209Ez t;ƶ?sثm6O]e"uOMb0,x4R`#զ4i谏(2i=DGT- ur,o ,d\ЌCTjdP #Xũ@ a%C d ".>u4kd8&2dY`59711i"+N&}l 09.#O?dUnPˠ˗MDɉ AwS `=JAItXZEaМ$!p=Ոh$XJu٦ۈ`G {E˨unn3fKSvY c"B*Lɧi>OޤԝZ@AGTuEamrx6ьvJB}&=^CףԽB7VcFXRӒUMd(,o5!.hi7lfGoY? UlbhzƗ@ga %~im>~w_q͸{{wLqdo3?^ tǿm~Xۭn[->v__RmRSI 3 Gnr烇MS}ڦ}!nӒw6MR,Gz۠3CnJ;$Gh88cE&ԱQR:q9Œ)FNBE:E0>FXZ7 X.96S/%X} 괶BJMptAonT邤8tf)C/,^}x.pm>/ְ~͠endstream endobj 190 0 obj << /Type /ObjStm /Length 2873 /Filter /FlateDecode /N 93 /First 848 >> stream x[k_ P$ Q)m:E?(k+-Cə]jHyxy^2z㌯x-x 5F5MDd+IE|&8|*†7>&?_1 88HWeO+&$L\5Έ+|F0†IH|4RdjhQ!T_5Ç>!-hlA6 dr)!#bbvX88WH|T5I9DRD2)s@1qI%jA>cvLx4ɑULNDF8œ)()`WШ?-lxSlL0JFE;irRۦa% cʪPP1f6@Qjr9Hl)=t5O=Ճ6Ay2t5U̼+ĕ}-]}=0x(<['jUTeʳ9wW0G`H%D?|<~76asˋr33Mc7x6`G&b T{GV}/f~X\̓']T* lzgR՚,ĠBaI`j ,PKx=-&U!L1ZZg#[SPQAJeo3L>(`UUdK+>&›pZOl!LsLL̃iu7ϋ͈c@I(d#bbP Ǧר "12Jؾ*^8'f`^?C3v=s{r=WlѤcjn>}v[u5Xb4ϫY K "{{{}}uq> &_ĺfWɓ_Oώ#; º MR`D* M ~E aWؽ  Km=tg6k!=O(I`An\ЇlnBWdrT}+XaTU~;5N 犯~2>HnWKjVP@ZA]VP:A}}iݤԣVi$eyE=>7BzǸtW4uZЖd:wBkNEk!$0=V#bYCIn;@}ŜJĈ${[xP_ "`ͥ94X3YB>+GiCغˉC_F ء ϯqGU|Emkgg$;ٟU݉FVeX,iHXx`Y:*  YkaY ֳX`tdG0Tؐ@&Ξ3mh4Aj>#rlPAu TGY gbG.ǒבk3`ST5sNl5#՞ܧvdlA \Q PO3r[H M'?x{o|mAX_\\/޷:ϯxm!p/WW@uazg;9ד[} C)!52- V'ϧ:yŠdL~/n6iDs9}=i?0DT~r~9W)}ҿ_M/O/g| b/Vw״#g7AgXbyeK U X6EXHz#=gLhgӕ97{NК%v)6DPۃNMN͟$PPlYL"]C HkavܓXEjcRa{vܕ$=QN#XCrqQa0eK$T$ K{0F7vkjwB+5#`6RI OBad>,{XorH"ez80Lmd ӈ{HVHwW5~`<ɒyGy}P"=UK&@P({V,hJWشʄ)puh="rqK=J!"?V:(5YN:pƐ2*KN}by:΁ulv"V7ޠҫoDaBkjΛxm p`Lr·M;i䓇WS8oԃ>kUءtDe&`5qAH5H7?aB`Lf> stream x}[$u{C?;XdxM &i2}jΈ_k NvTɈ'}P_۫ڛWty?_G>WU}H~Q6Cy^樯o6~x|wmT SǏRvOz/NjJ俽 FZ/eT6,>|x۫UJg @ Q>𓑟LX7'`8>Psv2[X@Z/>/JwN.Sj JYA@O8R^ԡ'=K}.<Ο~>(o&.A$oLo,>~%p#"fǔsX~y:'%(j+QEb LbYŭc}+*= bhrNyȴ_OT r΂1=C o&9-FӇ\c t|ZwmC YVoJfCpցX4_+k6""/ ~N wW!W2#zuqG#NHYۉ:Oh$֠cFF"A^\'$mS PCq (Wg@*3`fPei*_b>q JcT)- bY~.qc^]{%+X7Lo\ƫ-N,IjDwNp[_쳽(Yg{;qpmE^ӱF>nsDY*Ǜ ;Z0;>x(_+ؘ4Wf#}?u VB:zq/W~InR(7[L4äYbIb!+Kb\7NKʡq|`L4q>B|XΪi6xg!CY n‹[֐G{S Yw̤IN 윜H9ZTQQU.'[$W.3? ^(ie9^T-)G3qߤuCK2"M× kk,~gVM8 Viz1b .gL Y\N>n$Ev/z!T>LCBEhoOV[%D1"ľ 3s2 @N]mD,6,U(N yYy[}e'_[e6iw‚l՟؛̔~^l0F~6ӓK=Ow߭0^oa5%oI5 ɥOC/"7:Dfk]wq#ZI.37V8(YaM!!}_;ڧU݂~+}G1s{SxU^,~(C^^cWQ`^,H=ub&SW;u=zJd7ƽWh:͗Rj/R#wlЙ̵,?1>|4Dcjϲr@CK *6j9GnYq989 I)a2t4%9hB9w4w[SB?g,io,V!-3 وaf_n@Y;q)s 4].U.lD<֙U|I_P>=|k'NR+>_X |Ӛc̗۱4xoU4F#,bE4Zq=~bQz)^t 8C_Ɠ,& 4ߕ>evV޸Wcj'J8KBre?W 'u7Dg62kZRBcOq3S-iWފI=2 ܱqiCg<6eBu"R&Qw(FJ7ި [(/G661F߿mZXV$JVYj(^Y\hxp{oѣvӟx~{|÷9/DD4((ǻ_W^ ;/"]dRM\SG@]T,$`#k=έ q3mA."4j; O Te{əŞ5h*j=$2,qü|aݫY@mwK[هh釰U[*o0S4rK-CX]hSؘ/Z[m5ЎvqI.٢L32XYgӇB=3WㄤS*4{hXdu1 ҩDqٜpޘƟp6,Ucč1g!#_f36G0.2b1g>?^T%ErGOlT8:q7܊Y."Wjm@]3)Hng+W߫up@1uvVr qMLݒޗ( 7?40\$%3wȹd6U6;n{ bv{XxqdžжLZ?XƵ/&{&? Di~#y3 iqS6 ]P2Rc*繽.ϲ #Ua ۿGp M}0y^UVk>f-hnIo.>S멽- !(%+IYkT&3ĚSfW'XMI:;fyJgԭ@ԟ'TM 5IuhbՔlqz9?M+}])cyJ&iHYl:uwuM^,)}l}usP|ɟ9= varɟ뼅AD(m/<=Z^7#z|q4kLmٯ`jD*1 >޵{r׍:O&ٻIп4>b^?+of;jUb7ɋ3cAIqxwû+L|+m둡oL汣;pQ#oy[^X,ԫLD ØyTeGˋܫ̽60zC Yta$X/%24UNG{cc}萦笮kYņ`S~KP]-^;BzZ^$VoY֭zU6֩49}K'QN/1Z_PƳ>2VY4Rc]{"2GkZȪ s23Uc¶)+Ytys |$fdR$l>S|Q2)>^k >=~ǻPQ.-Bp#2i2<GtOԓ Х ޢGԲbK,qp Q [eж!ڐc}d-AfyɈY1)KJD[Z[4şehqs>ʉ؅h BƱV=Z[!a#RZӂwЀ3^,I` - K2 JKQ&h"=,b!.oV\,fhx"ǓJPJZi-_PJqPZw?#8Gެ-c+A/1X5Cm ✥EpJX8A/x[J啶,c;Y*Ђ˩4dlI\$ %dez,YV/ghbm3%p)-Ip,rU5ȗ c]NzV g6Xa%`/Lpd;}*Udi|& EVhs0(i&!M#Nu`;%_ʙPj@u &4&$]) N/Ok<\HxWDFJT8g'4NčlU7Lbט%/TFR^8m\$oۆhтίr⤱Q94 */u ֙Ň|ѯ$8=`Bb̺jXuA%r !ˌȓ3S$Jjf,Jfg難49$t$2B>ک4+vޘYdm蜬T0C-%A`gՕ-0B f5Œ`d1^2p0Ȝ‘)geAD.1s>^G/!ayXDlq5'ԍSYxʺ,4YTzQ̕MZ&UbNz@7k"ED&T[h 6)|# eh*Kڿ|_Vq3Ic!іӰb2Q EU1!v7yrA':e1h2 ?k\tv-Bm2L5l?K{e# mş2mqx_ N >ݻ998LmTpDU Tv֜uh,IE v:-pxx OU5zϚ2CL~RP67r1Rv"f%("K($tCC2nCS7lcˮ caҒg(=#5y-@3漁9Ӝޜ050i]x $JaJ[: nϱE>JۖudM8Ft//aM|\Lty 6B^TɰaEѸNPdQtVEƎ}grzQ`sL+cZ j):2P%"(\p2Iw_ij>+1~ٚ&y#rY >+MK oBXr@+!)zC8pi| V̨4%r`T>E[*_pjP#Otj f=gO bxIl΅16nE3 ;2;uy+#-V*^unv3n(ʽXTñe,J%bD#޺xv0Tl񌉎GZ 1@jCm$ሓ1T~QπH7OxQOtƁ)[$QrV1%Sȋwty]̉F;DkS 3zf8yYQD]D"뺚(%pePzHh;6DŃs wG\RODb7%xHlb<:t$m< ~:O ?3lCs`:@3«41-=^PTQJ)Sq/g.*VZ\oT?WÊUVjE Sݭ[Q+wZM^ %j^,j(W(jZ pTOL2ez"YŹzb;khZWODyR nTOL1Zzb۲Vv)6'fjmV<1[Ȝ'fY(Vf9)s ֮Xt-0K[^6O|Si=ݵb`/Wv\OD_/gEa(;G5@u%Q1Њ ,FUAf-+:Aiث:ZQVsCbs%D_֎2i2?[4[RPDΰ`c%]T+ٷTcVEk^ P3 3S"; {'&@Q''En9ꔉ=FIA"3*D. Q-"*g4¼o_*Y( EJF rw-iky댃 PA7đ} EJSXMs,13"q΀"g:F>Nu R!k8hSm5$8 So1baS01I.2i'$<6I1 bq6}WC#ga&:XcpAnɔlb"Yϑ5F\-bU\r!a(:Ik=ۤGWDm#mOc\<Ƹ$NlIz֚$oYQb|%EDː "!(T)o "B\MQVHPeQ·c%%(3A̔ 1k\ıo;DH8()ikbI$Q ARJlZY;7 pu?c}S=CqYhGnuSp39jOZL\. $̆c~QZ 1%(\ lQMDz# ȇrQ_ '7 ,#Eb] bQ8I1pe%sY(k͹CDD9:=ˢcT hD KZb)ʑ "\I(*OVk@,) #F(nך&4!f]!9#+h(J:99  \ bG SXTQ[1c-rRGr&gCd4<īqvI"*LptbUPgd5Nac$u-< ZTxO<4 "#4hljͳiq8r xExʸDdP5-gC-SA,#%Pa ù}@%YA[Ĺr@.q:DJv.mGd'CWn B= "bÅ 'mlʅbPp n(jŠ3&ORrP,L/2̕{L Yz1^ŕqѠENx<5S3)\!Ĉ8%;j"`&ʹ m$!`AU2kXj8Y"˭+%v;'N)F&3aիLiN-s ss0Y4JU]zH:) N܄7G}Sjq)}JQ',ǣMmt`M]QO+ 9#doP'2*eܫzy쁹WkYjzM,g7@Ec;E#{E@3 ۥ'Bl \rhz#V!1)[@Fz.}\.bAGL UDY[oG,w^y8p-xxLadm:ܔ)Wq{u<>nV8}6ݻz{X}_,4 =[w=:uj-S'ceIԧ5]Ɲps2u/UNzK`>9~*%|-ա (K&$gmAYtWPXZJ]DBS|bGȠВoAUK‹Z[ESi! {-l`B3(|)-kAV60^  ˝TTa-d/^u0_ 8HD uXp9TP~gzLJ/o}iؕՋ^^7W Ձ[,ܮƻoR0]}뺞x{7^1Om\3Iw?{i }#{8L?yx~To>=2Wxp˯ĿҌ駻 !8/a~፰EE}5= 7`cxW &ILf(᥄^$~& 7hendstream endobj 285 0 obj << /Filter /FlateDecode /Length 2917 >> stream x\Ks#8[Nx#T$DKJ\Q `fⒻ%%^xG{zn!jX'O͉X\;xw׋ϨZHQ[+Iz\NZ?տ6xSX#BH[j]] AU]S;0JUV!(WS%dEtfy*->+UJO e$WS]74 Eίm{ڨ)6jUfVWlGw еV/N NC3$?%N9eR[tBiK 傷Gh$^|-D$>'}Co8o$U;a]ѴS}xWnMq2#x_.6-Py]y[IvY6vYa`t5u%/kOGM 6$Re>|5H@=,zlZ9U|{vIҫUÕB\ռ 0Z֎M;U1-d*q)iWE{vնl]A]hU4TVM*R!/;e[ RB@Po>|=@Rp{'j';~Xqva˴eθpQ-FvZ=&[AIW3k'.\ zb(bn }Sl: xY럊02FՌ :H8WB3E:V=G;U6n5, z[zBpCQrm-O8lq^kz&Lx7<{J2R&! ]҇GNxgO׊mZʪ  7bTkŮr/%&GpIF8CF4HR=|eH%& SSk'tL匙&1Ìqvr*$(yOBi$^ۨyuKj㬅ڔ&|Λ #AܵҎxA(5Q~ nT5Pzz;h=KSjV_3 ]Tu˛ 6t`z٬u v2U3AbW36?d} ;eeyωOp;Y _]zGéIAEsD ;0eKz@Oh¾rERVf:5h :bo&@Ĉ[3ʈserG[H>W-:lKQr0xΖ;(S-hJU :@u Wih RhIuQ?fW"LBĨoP5[JҔT{3+ny`u:6ė9cNX~.O06 JgZM&YNv 9&߅\ BB=8Gy-& @Mܗ[#2~_F7Nc5&a wN nبw:[vc탾}_}q^վ[<ޔHo25=苘 5].Kln_=@J8fS2Y>t}[[T8䥇ys/O_EQviRT| 49{l7l&T=siY҅~8]jsA'W}ۜ v.rd@0_o{'t4Y Dy(g+eݮ=}'` Y2TJFAhآ9ySeGaP3DrT{B*meZh@6}x`oDJh>Lʥs'ty5D7@~K0}8Y@8D:FӚӃ'+UjdճSQZ5hqk8P-eO*E`OS׎n\!HZTʔܳKl8xOGgWOk`۬ʙW-?2򺏜"-溝'ћ?ߨa_:6[ {BGR(i璉 Yԧ'ҦL%dFe0W2Ms-_G6BJ+?i4)@ʴ,=[([!5]?%+|go <K/WG7O+Mޑzę?0J"9[Ew~aH"1 <=!;+ShӀlAG IO~> stream x]Yo]q~g/ܷ\Ó{w#pxP$G5V~}S]^J |uا>n]n9{pޞt"读7߼a'"ѻ?WΛeUA ~份<=Bňӳuj߿DOCV|zY\s|Co/syp=u<>ߞ*ӹ&5úl;q;!`e|ؽ]\W!0'ؐW(Dĸt}"îȀ`ocTZ<4_MVAVǽA |v]Ix%L ^Dd״UA |weY Zzi{6s$˴*Ǵ7-uAPRfsVܳժ|_|-2i~:5 2v:pODsBqrpgygB/Z[|)bHiE֗3##98,ԜS8ÆMv), $T |}q6B6?FIc\%Lc>!;d- ;b /*Y'Mm~x2tȠAmg!.#Mski&6}Lw1hVjJZėH5| d'kΤRH!09ã$k}>={ Nɔ6a|B'ɟO? *!D;Lx!]jSE]OlBH%ZVgvgR/N!&ݩhTr+ 'PTV#Zr֭ņ0:" me8puЄ[rN&V57\7Wd  6tT<!놧KYh@0Ϧ麲 qu.قQ fDʰV,ڻ_@12G/\s_5V9ah4,S_^>dM hw=%I(mvVn/rLBbSw#|ųq-pZƗSi{Q+Z:ǧ6P8C[QVytziD{*6JT?lVX?$ fcՒ‰!ܣ|0):/"L`UTZIԞh@f|lܿ.*AcX fZ[:؛!]7Aa}DUq {T 2&CaeykUóIC6f4fXHA0NbBJLΘ}hq(_8sjB^V(\}QED7va #;Vc|HN ƞ8lvJ̴Pb|IV91` ׭̽H<_;$o#|Anƙ3)Xߐ." n!pDjQ4{6U[0yUm!]Am$AA;[Ţ3ՃN/!%SqQ+t(ZE!3H)LF,x 8$}< _O@1{#j42"|ٻ>38NyJM5p1X i5)QJNT!=6B@9s7A6FSrЙme,e@3E,@^K NAmuf޵=':|8!6an[d!s8'?|~af 4JD7"6m kAAKNBW{mU޶E?v2Eu^;+{zjEw Ւ0aș1}^"J3@9jB@VĥŠߏk}(9lV) zDDsVv՘8hWkcG^l`LYe]$n7Ĩ10BdnO*1\Jr() C"hk5ӑ;mY}a&w2DԲl@Ló ww$5AoɊ8dD+ Hξ2 8洨I*IձƬɽ_Cq܆ Y.{ JT!r )bl Q*="s~0+kcneUDk!5oSJ{K!5?!Ӆq(eWk#1Yр,ø*{$tS9=.YVQqlXdʾ믩9rYSsa[Y>Ct ˨v ƚ " ٤J~ej&d쭪Ӹ@Ρ eo/Fmᘇ ̸oLv.k?q*bkZ+9 !l%W$u.XnhےRaLHqwuRhV4I,BzDDWЮx~F޻ěiOQxӞif "sB$i!/aSɈkt ɼ/s͙2h ~LPX7t3fD$6SI?*UfT:0}[d ۻXq9 8 "H 5z**ɖzpaIm^*Wl;x#6b5,["QoקhbL612`cZm<$Y. K2;K)d5Z28={NiHPI *·j=[1vuS~G蜔MћnAR|M޷cnZX($@=33$2_T/[1OEDߖ$>0b܉[>/lI+Ȥ.fBf#ct$$7j*+OYJh Ԡq?=>F*'s#Frm[hCzq3՝37ОP œcYw gAZ|-y0o @JՆg_`Ԣ5V&矮(јz{5!0$t.JNL 6M2~J =D(9s(G'JLԶ(LL}" R;mHg dDtR-ERF:!sU(=ؓ{:w{ܸMd-=4_$ Lg}0C*q3,[KpF02f䬚mkp}"j dc%GOPT8ǢOٛད|AZ*;]fhU[:`flP261:J[KkW *,y! Pbf.esŢyH<@B9e+]I։4̈uIcfPfRk>({0`N כ1Focb-bXzQ*e#LO.BAgKNk԰WOAKfWf05_P\a^h:s @]g?>"vO_/3dD4{;Smz(GnG٦=6AkG.v+YP1~jb|Z?M;kuy$v3(V}ղZx%R^2SU[C @$pc-nN=Go4ER.ńc2I7_"ѓ'+ߺq%/qhS$fgaӬzB~ :p5.G\W+/3]F# kb_LWr.Ѡ 4u{x/7mxQHs,?^ ȁhENYo5o#jە"8حh89,^#kt#M 羮"+Y\削,9\ڑ "|يldKWE\9,2r9au+Y!c~\3j+M2Y*pyTeQݓ-2nGS?YBXsjYZRoco)Rϱ(ÇR׼) i=>KN𩞺?(6U;UH_D@L[~;14e8nEy' r3{)]ec.dOVf;((=ӀͮޤY)5ljQQo;XuLM(*մJ-/-NOe+ku5eS?J]K=CԶخ}Srډ0B{#RAv ^畾XP7ˤoq0/(U hr@ )z [}D>6fkB7@V6?i*#-Ax(ׯ-O^ LrV1Y3a+p=EC daVia=c޿207HgHݺޥ7J=B/YQ+[}"[nQ:a$u5ٺMQsVwot񫱳.^'z+C+t~c$7tͧk몝ؤibΡ8AVDa`cGAq4mkc_zxǓ/|.+ݷTR>`P_xWf_ +-?S.C }DgvS)XcɺT'ƞ "&S\|;k$ف5q`]J*lt ROaWhcHU'vx@$}&0nQ>ǧ(gQ+I_)#f^e]?ܽ#fQy`?#1Q'*|JR6m =~@xӀV=l~%l}y5ӌmӌk6{"V=7,tW8P~d0MF\fT1J\$;)Bfοp]afH^S ^M3,t$YRlV圸^q ɵo͔L%%Bd(f":-/5?R9<]y]aϔ"_7i&%gn/$}+eȧUҴk XQjELI+E[RraŌmŵx> stream x\Yq~G 2-py 6 c plk;WWEÝ'an:+3"3/䏗l K_[-.?<\?^e߮q|F^p?NOLz~i5wW<긾b^zgǘz ~uBϦzW|+V7lά'.̈́_sV;Cnv*~ ;jqz'zbo"'N*?Fb}yIʈf p~6QeGZ &OfZG2:dwwdHDpI!;SN]HZ HB9]KG4yOoJpef: $' qY^wm!7q3mdc+ ` -lE]\~zW+#Pއb) (-nlj/3YMB'?]x&cXn!|?Yf/V=Yړf\E$9F(w| @LBTƧR _0`*Iܧɕ  ےT J>i\lXֆWה$qwsFu*qWۇ&# ??<H CXn6$L"U |IKڡ5dk\=a'n}4 &{#$iFH |Z6=}XIX?* ]):ʸ en[qmmO.>qƜ4>oǴlOkNr µfu`F' tFW`\nޒ: dU UIˈ>>:] y?-֠"zLW7he942lIˎ-l < GdARr%f#6A 4zkv\3yU@}<$즅gC3I-?W6@ͻ&. YcPMʶ&gk ֬ ËkyaóH9A]t=aw45FT_-Τ*h荒4h7 !\bBp(J^)CIH/͵(lh[V e9'Q㓒H`73S/eyKx ϤLDy\ A0hj'DB? ޗLN 9t4VY"tACCsd#Zbߗ_-0 fz*s?uF{gC#pm$& 'iɠu5eLMtN:/m+!8ý AGؤLC\H;>դ}._ks,6'׿-'tGu#u`R,}G1KRqş/b\.a:sokH<6g\{RJCb&q m:x,bLmdy5pɇ mf#!Ӓ>uta@ͦ[/( ]k4;aTԎ-}s爎ѱLB| Bȑu<ߕ0P/UJhGzj,?'b/d<>o?(&SXˠ Iz+ės f]HVlZ}v~PKE DP">(TڀΗF#m\g\CLAmF*>Z,!1\eZb|\Ċ,͙N~FXqթg)+n:DWL?[!*fkJgiEw7*-uP@>:߷C4;1N4 ~2(# -j?ˢ Njst\/5iTD;'[Uɜ͠#g\1sTپ(ayFMƶi~9P] Ҳ,űX阹\/ݢX^ q5@OXF5~fԧ6P65D(I<)BPGmn9x0r_[x9(qw_qu Z U}4eN6J0B$0OXpK e@JCSUX E]E7q@Z <看@fZCU ר>mt ߯Ka\WxܻlyEM<{c2 /EͼKqS)z.tF夫:-<زkW7FA{R:,os'N/օD1,xI/3BB_IA,Sv_;"Ǿ 7{L&ɜ=0LS_@nY1i.NFORgުrqHĆn `:aNYdٶDM 9R.RibWa"]}\>#xIvj PJ} M?6Iپ$LH@Ҏ/j4>H9jo;1 F.,lQ1=kT,M~dsӳ }:JjEsrGr||=zi B}ٽ+g{_OA,'"ErCR~ǬWE'F%Q\sH]*6abtu[cuw2}w1tN,? W^1Υ~Zx5*XD\ 4>ΫxTXc! ˴#PDi:Ѐ\d(mGB]!q_@4Qa:B2iLFZj$wZW-wU6 .=JttYu$\pSs-Ƽ8zM9nI+bKLlO~-C^iobx;̦vJ#(J/4#JoO<K@4n@i uap\s>ٚ[˯{fO9?_`^FwMCh>LڙhB 5rMZR eMćZTB"7rxEυ-8!y/cEr潒WRV {O0ZG,5P▣Eh#>Y}xxm )듒DJm͠lv TЄ<qw>~{y~GlOoŗBgD&&657g&oU*vSAá h+,MɒُO[y* ) n_ Co"royy8YOJYk˛r IFKRݬ`fozr/ak1ݰCg32:eЕ [8:Ƽ!ZֿIMEl%V-XCxGCDބd`*y|r;Q$%&)I%Xiy?d54{@"{tW9OװMLdobe6jI!_=~5F7.q Zp q! >6:yGnjo2T&UuՋ |p+=2x]xFݢ増tj^T[NDYEt *jH\m'8$()~g; &{ÓXh5džrP&~uS輦JMZjhlm/Jy.tY}$4Cx1s}_/i1(TY)/T,-]?J5(W0rX )+DHPWgPK~2R%f ceo4ٌK#6F/lp*ʪZIB YT1 P&sNV9eL/׆0d~SvN޾O@ύG(e)7J _,j\j`@hI{p*kKDfY4aW/±KfSbR88j{6Dx!)%O G@djapSMzX! oMk)Z5i? V92ġN:6|fk`σi(-U>$/d[U N%tpi#?`+*vʨ^)(_$~@>1uߘ n~m7Ds %2"ޔ %|{ݲQ)yLh6#|='*Mq}tR?K +g]^JVC|ˑ~2}~ݸek@vN˖}w"Ս,G]KrIxXFv^Hk<^8YtO>Xqc2w;>$eOXq繢?)½]h20~/#* ]zZowVH.=EJuko.QMb@-/C, \W;4t4G*cF]?Tid o\샍ܳ}bil@Bb~Mkcl(^Odޗ֣mOlŷt/Yy?=h{3+1)#h r,Y8 `PޤQ8Z-rvܘznϫr?J=#f\BqOI_4Fcc&GO& /z2rߕ3C7*\Yq:t | l z`Y*PDSSLͮ@Etk$ucQ0iI6uD}٤'?&,!_jV$:#.Hؼh@&ZKbͼ8Yai&ٕMlɮOQ.^ 9I\$K((b^хnaDVz5V*^g:u endstream endobj 289 0 obj << /Filter /FlateDecode /Length 6708 >> stream x]Yoeqb r|w2  [=ꎵHw*S- `̹<\|~.b?oo~{#w׏g3ݥklvB,@ߝѧbͲ vΈ{}{=>/ń:PA/0Z[ec]ƫ_b Oo*oOڅ?D-~ w[\E_**ԝuힽ~þK‰j6F/"XQuTOxN@/"E=K cj\X]*=|c}WZW~GןZݝ)=W2}7 [^NS=|ڿ:= aR3΁i2E|/\E^DžЋ:r>F2B&Fq|SM"[ 6~KM׮IS,]р+p*zI`+z5MN*K4`q]ü0_7֕{{o(^;5,Th %) U]FeFR(\ߊPuNf۱u7o?g6Fܯ]fO!޷Vq9 UQ$e@8ȨjQ%}aŶzFM֜Ω*k9N7F- jO׸}v6)S\#_YZ%PAKJV ڡPp[ -R6]Cz&vH:Hu-G6=tfGj椭>#] @,$b<({X/ `O2N[D~ jOi^@M&4~c;/>ZT솚ҋ8'Apgi'$GP@^"إ_$BLi㺆yiMEe[AT?o`}$p-MAJ0ЕJLl&-KZMm:A \OYy8_v0Hb;_!x]]q/1JfK]3Ԍרk;p?MgQxPN\G"5Zfqk<~b&Qpoh*cEÌ:CqSnZ~jǾkfxVC< .8~D>-C:ѷ ڀgc>Ʋg&QQ9C%1W6SɡWqy3%d+6Y>׃ʨ>M/`iƀZf/A//@_! :_9"I7 - r.h&|50]>WHK;!9!rNo6#, M5°i;w# ]Rӱq a |3F9(ny~g(ԭjNyE+\X+s6ظHc +#LԖ9( " zф5ֈ>utL4!.U+5iF VX?)y͌\Fб%`+ЯPTrH$xG/B-FC![ R06/:bT~xE(c=`I-?/h њJHZûnw:Ϡo_y4~MC]A쿣倥 BizxwӷwOi>ߞJ[e]9YWpO^ j/4o2F\JkeyC`(hV'=NK4E50̿!+[tȇNаCL4 Ox?=n>;CaeQ1=dIS0yLtΡk9yc4/ :K2-tdv3+GsT9cTb ^(.#4}"{i%n@@aZNUo+ɂ J1(r8]rߤ%zJ(q4*ugNH8QΦ8kF:6ؒD\0' ɨnQ 㛛ibz,3H ZbwktKܺʴ.'f`R|fJ!m+By?R{>{\;-jwP?u׎5YgnU'VoÇ#8kTMB!8| δeED?,/fiC 95}l<R5e0\a7l*=vA~+Jb]"v>ngUfe<3KNc0;saU6{_}㜸vu-LjWXJ׳Tjb`@z40EicgQpl &9rTH1?R no?,Ye2j6F˟c&@uN6Ueߝއˀm=Uer-xVq!:LRZbeF:AfCP!ح\hYs6鈓W(N')])-ΜǨ @X_Dpe}.:Rhw嬓 U1{BMLgGzoaVU$t*` +_,D_RpB|dbͳyK6.ݖ[1|Z`N,1vO ޕ`я̗:(/6wj{qԐgK;Kz[RbX(WLӓyq<zP^x< 6xNyI]:R,gf1\kDydVi'TW18ĔKGPڷPN;i=4b:O:ǭnQXc= ր&*9餎PlN~GJYaYnqWwZM38G?M¸՝SJ^` ςو>-JqAe>1щ (_'Ӏ|T`j v/iw|y\U~: 2`V/I`XfX;0@O`OkSpWdt LqO'k\: qI.x>2Nsؼ-ݦRv@vGٹj3yyn_D*i5ik'#RZEsIX;3Ӣ">-E#5ׅr1Ź钧tj%1.%Պ<8ujFY[ER+L2paaU*Tm.j)JLiְ~N|F`і)94B  gjTkkZJNw)+碤x4uy[*XtfbʊX 6 Y,"t<hrRK9pGlCwŕ wQ}TeŽ-,QoXO/[b yK3h܀I G@t2sNqںGWcvI㏎Db*۞rmY@Ebj[7g7j 28Ģv2Ӽ)EqZ=n7%+* P;{eaǼ/ODz.иܵv`֑ EXz=xU=rw6JIbk8S :ȑĶE+BwSx(H3 &3%36p*-Dzlj$AGKo1+6R3p48I"fq8{KǴ]SƄ馹J~ a$o |^qkSNGhnHW6˛?Pxa~EED=wb'WvAM>7UH'h߹nIDگ80bPIn31CoiVщϮZ9CsiN6͉T1$4>Edm9}x*.9Ir^V./Lο;Wa0us !x3o;|(l]-"sx鐚E;*Fj~ '> AsVec-e5Yp1ye7, z߮"ك|>{}A|itx";[JB=DM4=GSu:\-iPQE>%,IlS)0$Mgp$Y<^䅺(k&E)Y)U&&xC={Z)i~H]SfB=ya*e W)O{gxW6_ |Ar&cϤ}i~iD<߾ekMxOŲج3uS5*U?%b*c]c d46 Z)O 1+ap\sIz~sy{BDZ:ERA.)Yq*tX40P;|#>Q8\B)jq86 M>EhL k->4\zxG"x?W\bƨ_qoU2@|ݧ@vO .%s Uk>gdnK_'¬$tTl Fy$Xe0Q3/X7?1INP xBZ (>, H;jn7Uݤ%5G?i(@]U.gW(Y^ް䫑1O5y!)v1"`s$A.اIFV[Jud`+;Y4O=V_M2?YTI{fR0j3ɩ|d" ?&[%o&ZHS4ݭl@^S M7H$boz d]~2Y'?}nZK&L[/kvQK3ƾ>g܏7uD/o>j??k)g[J`lo7WxyO+O+)ޤK*~ErCkkĆt;3Nė{VNz.oendstream endobj 290 0 obj << /Filter /FlateDecode /Length 4972 >> stream x\KoIr/_t)ߏ5^,0 !h P$&(Y̬|Tw /"#o1ɍW7o>$]7r-F)ZhyY*7NBGVN.Nn?gO;$co7Kr$UB>Fm j>QSv{'ɕPը{&g&wBvs'dZ5&%BX[ӓdL[i+:7N%NIHxdrΕ8]v/v䙒yj3-@r.AN8|za봮|Մ︌jOs7J+ + t̓|KF6vLƘ5/!Kָ7Y?ИwM:ϺG[\Jx~ʟ[>aI2@G\D "'A`@ b(d:83[|iR/VCVms5r_ ShX'jrhAJ n2i)߼ sXl̯̏`@Y(L aҕAP4ݲ436&ogYCL#"!N27R[ȓH)4Mds܀rc9>v(/#$+8$ HY7cm,VSpXoFJ 7ﹰF /Ҩݒnv Ud{(џ.rflPR&Lo\4~R~?S6^g`)04ty+hD-iZz<#B\ꍟ[k"Ȟ>u06YgÈVoMB]bI %b(4ĞJ^ G W4i j0Ncc$sv--L|H~iG$rnHoWlF"}*p_H..eM Arǿ]OAzStqǶYq=ڬلv ʫ ]g4gCq^/$%_=*hpy@ -.|t)%WE蚩̺ƲRrMݪZ?,ۃ}єU^ʽ:gFK3g(PڐT+r DF67~]ݺ)Z4;A;ujyMC ߸07%LLDq0Mr\JkD %kyEr#"%}0%/ [QxX+4I)ޮ,#K&й KI MdiYuZw 20lApPF襈Ð&-Db'%f+'@Ɵ :gzJ-țw"k  lR"_ǻduZ0ݑ Շ90OP5D8Vo:>͎*r>6OiĹYSO KaqlmWy'-as%ŜX ?cSF o)iuPk6ҨB=]+öYk9V +e4:DIק,A@>X,HLEMsNPO+!8>)苁ήW)w:j`*`Medvv)XQZdZ4Y~tz::W68~wbw/NG͟Dm=k9 lS_pt/A=nvL^QpW(r欋zȗĤѢ%#Wk"P? ׊2v( Ycg]pDPRtV+z tnX~T݂Z(=Y9goӜNz%׎DDנ,/^Z@!c0UkI١g2۟ڹ:C~8WPDҚea̚O51ٰ{6M)zI;ؕAb|o@et,KraM*.XB͖ Sx*Ps"8j:) $aF0⼋Ε6K\0_d3f>R@I3?.f;~ƒ/Lg"}ˆf\.+7e׻"f{zm!xع,Rh8(U29IhL\Ev[%[#c̐lMU_*_kݸbVj9%(Rw6G?gR7f&qIDæ*ײR贍/I-5}" *d YU5ǪB9#J0 &o*12:Jeh^8@VQp736k4'[3  :"pTIj:bz+ۨWI,^Dk)҅9gFz.-8MbNAs&YT%OZQä*S5&܇Tc燢x HlGxJm1a]V]V ߼]o1]рTXnXe`򸿹|x zL7xgn+gYχw5ymnƧvR-XKQ. Cap7s5IEbwJ)( +5Ow$W.ֽjJVzO'Rd&qQetL/ y9BBmwI!z[߽Öb2(:SA+r<7 Ur(QPXII嶂:T^NVIRa9#>bK--3>Y#A.-Q\0.Vp$v oR7E:|DbZBEgώT? s!r"0_R nXjnir9&6tڜhY8:פL\O{av'j _6#6)/ad~ |D3;XW`|d3}Z:R9%fQwRu;ն<ﴆb˵Gr9YOqO\NʲDfmL>HXi6~w]mB,"6x#험Bw6}l3{ "\ F*ό!>1eNp\1Kcq5e4`siN}K.U;ݴ;|Pba_ng|sۓ&)ق%C33!/]@vf7+ F/C ưP lĩfɇI%$!u`R< 8 60.yP/mr;wendstream endobj 291 0 obj << /Filter /FlateDecode /Length 5915 >> stream x]Yo]q~G ē^OwуA$;`")1!)5SUR4VUu##K=~ q/$(oE8nQҚ7_ĮE ћ)]ܽ>>.&>rQxwz,[k!.boEE NdWޝ_g }] q46_cXaB$pqxL!R,QP>%NY5uz&BZh*Zw:]X#o<Լ|[I4gLġ'XA ]1gG5mUUGrC D92O3M l} ~r"u8{5޼qij՛\z{s!k6{#Ă3{W'Kdާ g'O.a&h[wW_H /N?.׷y[?./ԫy:%ŶZ+}rϧ0r}ՏW?G\S0-SysOpBbN>3:k9LsǍvfז`k֛L[. ʤ\\%}OU j=O jrzr{ Sc#Y6~mnZ=F3Uٮl+ 2"+ҙjFY>N@"e͛NAԱي?* }b^h_ .psyрJFЦ2Ũ MrI 4']C8d r*:&( NjJɩD07-' UR!0#=e 3Tj[oVh|`TzدP!L]:Fʹ t蠄E (xv)n:F3JlIT0[}#|A$TК$"l@e#ԩuY$g` i$ApFOw ګu,NQ5J , VUV"9.Z] @r{F'h(b4>{ąq<k!c q6X[<'%?;DV664_I{ڝ\:L&=QDq} س>&9TĎ^g|tBbE-6>V ~ۉ8 6B?E*/\ ` oqVy̥zP 7CGDj)DJդ Ȫ!|?iS/8h ÈXEp.b])3_)n[q%[.@#6lmf6s&t~:"Cڦ~}~]s C/6^?vW8~6lDfR9m%0$="fDq6]aQ[g:Ѭ +,'z{RGNj1 &4%ʲt_(Mf%V&N3Mf!vC~~Y;{4̮4JR %h,fcM{m55\ /ٕ߯ؕqvy%R3dj}F AJIfdsev0Y'*e_u%c \0=2C{-jΗ,=DUG~93֕qK%͇mfaȈ|v)Xj\Bv*} :88R;C&ԎV\iV4|sܛsQZb+vīMҬ+Oc.7ru´o1 <ݑ1MTKNppmA[,Ulu1{ǜ2.ޡ!+Di_<1HAv̓d23c4 gi\Zs@ N~: @R b孢,=Jv_*B5$^fv1+X}i`âk.CQJO*1)=eo^&J8ȑĠAކכS:vڧQ+ucҏM'IV x4[6}iwx,Ƨz< nono/*خ.>_\CڊzyfU'<:1v%tYGJO_Kȥ[}J`5f2Z<.{~\"/M$h]X ou^y$RYrM"߽9j-7n+ 'X0wF3u[7H@{z%H5PA]N ƾy4[5[XYImX.g)IR>oO&'>#{! Kn:L)>}٬%$,N>5s}f > ^G hըtfxR@)VږgcEpI VE[ G6X6 ^Qݵ%84v)N?HoʺJ8FffET(R4/Gbṙ6Y]_!&Җ.P|bA0kK(M@BS)kP1g޲J8f꿦Whz E(dd)*\!<>tYy%sGJvw/Ujv|8ntXF-ߧsfbJVp.Rp:sST B}~5b+ ?R٪Vʒ9zVs<~PXԚ!+Td1ǴI:1uȕljC&LCJ2ItQ=|כKZLIUHH sAxpNvve.d]8LH1詌F)<M-8C4C0Ւ @2u#eOcd,xeG%H!7?2ukA=-TLG|=oFǹhtıXR颂d ntnjɍOYlWU!q;7<%cL#ϨzNj#1?>yP5 ގT WMwoGV4YϙQ_]{&oE.>vԡ\[^=s`{ΑaFLhqlÊ|sw},H=84 Hq_KM=Ϥⰿ `F>q!讄"R Q %fze~iefo abm])ō;V]n*mg:z#,V3a7Ugt96UǞo24?+-ti@dbPTM[y.sY'{ {kO rMC8pU6\HT\pL ]ܨWgIwW9xֵ˫&k~EV/J&‘Z$2ͅl/=~yt 4"-BSN%PAW+@no$;CB>s*  x_Q2q54p%{ K /MClDAY%Ghw"ll gAKmoׇ[P\vҐC8 >xUw+\_2,?EM?}~eFc=[ WZG%z=I&7w{:?<ec"w=Ʒ)˩cSѠƈs̃*)ft#ϻ% fB‡o"P:ͫЖ@;&?:͟Ώ[u-L::Oj26*8]:ӿDJN.(J$3HR罧^aLzn[ƉQF*=a(|aªnIeǡ8 (׽C2Pgx6lt"uU˯l_ i",D7BE[,{C*l{X^U |jUZgvW%qgWUN!404?cYW}l~+){ @ē3*7}&݀y!|ev3c\e N 4ָFR`Cq.]P#~6^7j7_PR=ة{W> stream xX XS׶>1prТ{Urm:u@ZQ s H0fa LUc6z:ԪZm_Nvzk}9Z#lQ@' 7`o a6-od;= (4dgiR;syiisGJC"d~2r)  )&ɢM?/"fDs[N!`'@i\H@'X>J"beR'wɎ@i$EQGJދ^&Ů+v \ngGW؆ &9m[oO:3fΚ=eqƿIQc:j=&AM<)/jZBySK{j J-Q+w ʍI͢VS)wj SC0j8eGFRP(ʗMԫkH 1 :eKє+L 8[8]xƆI9o;Uƈ,0tРaNJ^d7.oq#>ad^m{7ΨQFͯyo^|mD[ϏKRd#?Fo'V/P8Rf=Be(2 ˛Pss 7-̦mxPgBR3Z++_rNau{xl8stmn?*Vb#xw[`"]HDd?tw1B=8/z*SKhYxeSLaj$ v~=sx vag\lKaM癄쀝Q#ˣ0 FamHpz >=eq;Wx5I7?(kJl 5=Btdyc01i<|Â!1 wbP]X(sr&hl$\;Qk_QrT_aQ$l_ "kr-#ftkbF6TWY\˃9V Y[;.Z%!omS*zŏ _ ׈,lշYziw*DL]Eem_>gYw/+Ztzw'Vp>(dpNKd\ܦhθr0N bBk{QU*E >^<^bw!=w4VĀ;a%?㑆-%0<\.7*KvTU#lޘgDYҕ{ƳҖ,ٖJ{)Ӧ564 q9k=v7ߧ7WzXh_+?>SKn~rY*ћC,{}>`VC{To(Ju՛f#(ヅ|F+H +nh707l^~RRc5E{~z^.7 /^zF:1kW” Ea(SX"=2KЛh{l㾷P<~T\Uܢ{+:M75)šsJT 33bt@NJ3{ -N-h=PFciʐա=]O$(r]LxU; O>jc&d[2[,v)'lEYYй_pL;xBKIpd[WO̅KPHuR[fRe3X^zѩfRך 9lM Ztyچya9Dc>7awTw #cSCI03AZb=*Q/-qJQ׈ µWqCXLWYTTQ9U}ށJU4ӏ&8D X]i^bcP*T W:(253)CI+sE0NY#7g/zɽ=xXg b:u2#8d8X[-C)tww_5[*tAZ:F'Ib-^^; PUs.6bZtbV^YiS} B~&xj3e"9`}X].W'nrV~zteM'?E?"0ɪw?(H,2F@4;hXIsۯ-bg *U6w,⿚cE,2vg AgyyE}ʵ ָvqcyV)o FPR օI3mْYw咬D4 hl5aQ.܃x z9w;|<F!hLMJGplk90_.px5tHQn)I∜mGPduHEtc.\WVBGv] Q))15b3F{dNWo `K'_#K5 55 voX_q7$OfN]CJnSr;< -Z4cjaHlTŖHٰ}YKs*#LΙܢ:sCdδl?'8$ϛP/+QׇE1O|T2N+Mm8-Lh1&p{+n^i0Ge@gYSou;W’{ m Kx-lDOpfGߺNfa/ά`c5eAg0A *]: 6lڸ(4dO O~ sx6R'D-OB.DZNNHSfT)I%gcEDxܤ4UJa MG9f{hBކ#=SKNWed9,\vkFeJE$Rir8Mf=aeV<8M㎙JuZJrW* /N@;QW+*벾BksQ!r,Uҋ RWxk ,H) 2FdD)af+:h-h>'f-9!-;)ə}BE@=-(>2*!P[`~MlM'zD{3ٶ RU&E4F75s;ˏ~j 1$T 28ſVggtǸJPTQoe&O<﬙\)pc*)v ?X2_ /xOZQ)k|N"|PE"i ASI7%F֢ZSWBΰ?]az}ϔjr5q^3꘸W'Σ&R=-CvU3S*FJtܹ5R26]3RP2i@}t 2#H /u @:BNu &,lw3#Ś,ѨsHͬ s7b| 0itL=iOWvN%(+:;%|Vx!:SEZis*n3Ux̒fđE*?jre8{bng@p?ÞV)rPU\/cO  nޑ(* a*e+Z4N%r+QR-CELSl"+8<.4nTs3jsD@? oz9NZq{!/B˔fdI 8: y"lyyWd][f*a25ª<n2nu'opcǪJKnG: f-;-^x}[V6tweJ;_Z t4VCLC!6 ɰaLÆSV4endstream endobj 293 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7747 >> stream xyXTWG1a P,Xi0*C2 -55D$>I3Kn?gZ]z="cJ$I97kW$ +/v|߰ƷоhSH$ IHu  j7ciӦ7n<`_w2^?^Qvfn >vlDDw1> ni0@j|1柎a^v<}})Z3O1u~Ђ!B [$}i6(eў˽Vxzǚ.~km5tӰ97:cƍO8i)SM15E VPtjA !jj(FPéj5ZO9P #5rScj,G-SQ j"D9Qej95MqCR(;35J%RT7JJͦ[TOJ!RR)MEPP6-ՇK$΢. "Ց,&J=W|『V74v)tuuzMV:wvcY[[=/oW޽{+zw~9nsv>Tr}}jw罻wfqA~(lͮ1}A 2D$ȭۂZNȌXPSva'6*)}FPGBuvO ֑3A.8lmZrWǁ!e[dI\2˦%M z1X `iE<.U(GPGoS/G o%/e'@o%C*T#dK ?_>ul۵ ՌubZ(B t@V˼*[.s"BW bKyܛx轪fP7eX_n<2-SfO_>o8o-VT}U nh?bwo0IPߡށްXz4C p`ՁZ*=k6xvX)`H/`n"Q}~K,|'c8#Z K@Er!!r.Ux9jMUC"3ҡ@b >?^eHRC2l;`08vPhmݶ.6(j}$Tf%+duSj/ي=D<-FSCd˔)I|#YWG~Z^|` !]KۈX0Z/*!F <Á. n< =E,5;,)U_1oڕ$7}߀g˂4sq#hl?i&-Bc-<61ZH {YLa DrNxbd!h29DIݯBӔe*)F%Va$?|,^ %n{Ywo %Tя4A#2x:{:Da?KM·!p_m P{jobқKel{LT9T6׷ÑtBY,쌒x{c1Wvkuu҉猨FFzq[OÆIBx@?M8L2)o$7%Pb b$J,)xͭ}zXsŲO~e+iY|V[PYXutld2Db dT: P d<HTHT-%5zp%1&洞h~?=Q_#WS,NM@/}Kqm!Oµz˴Rރ(f,12,!+Igxް~ҡҘ0`oxca\j)) &Rx܏\uZSgaS+ӷZwI}j3g:GL$  /T>o2nQ uY&fY|ν;Ɇb=%1ZяP?GNahLėk'={ l (u\J8P@l4mXOϽi4Цїe89? LL<[:syTZE@o㫡>Wh^DO2'8p~<A2aj;F*7ˊ4sĬ<hk$[pӛBD'\.t{p蹖CtB_T l42̤Xp͖ٴ_xHP y6#M)Tm+,XLD,l9~h ~aUCdJB̏BQt{4/&^4ői0v7~J٧Rc }Cb_XvG*^f/U%Q$ )9t JHJE6CQ9 mAGNF$;V[v4@"o:9GVd,S Ȏ }1}@dqd o'I29NWl~ ]jyAzVFc/Z)V v!Hot۷}ϖB7`9,jb %%&)mЇ^yoϙ` ƇSaiX/8Q-9wرu[dfשHTcL+La![UuKeFl X up|A7yǟ{"\vS)pԤ$PDe:#9#IbJMKd&vw}JvU@ Zv@zx%Q+$^jtMg1 Dy)q  ɉKQY.f!} 4 ] GۨɄ峆vo5!BSs t{ 5wlJ!1qWiS({ɦ,B*dcᔱZH)*%rkF֢DOgdWddy˫\X(U^xd!>|pѕuDoY'Ȇƽ#0-2AxS窍b`w*ĤzjKoFXi%$%xcPiͤc Bl+jAkcLUtl9 )~hx{HM_d)PQk,IOj:z"ﴚuؖb aa[HILShti@i b T99I OP||`O?F_64,_/kb6M(I ZсiYӝ04(8\ hkg`C,afJmIk.|nFI$Tyx$ H,m؆ zV+:lN$E"'ٜ\SDIk*Jz"ى,ވԎMx,&rƭRfp6d8pES/QףMK. پM L墵W{ymMcM -I٣0a xg iaFK%*}l2:;9qB6i,BЪ4#\pnk&m-Y6IŴChgB/UywÒ pl|]"JH槂^;0C<^Cil4*2q4_*mޤ|֡oXG!{@lp<.74Gh&ͷ()$ p#xktL(S+Bs8kRbVFLN5e)TepH]ebCq゙.9i&7`3)tI$/={iXTnqW%a@T:rt3}GIb_#*v55a9W!KMA<W]֗Vm_3&/^@lvMbdj Nټ{c>vFQO\/OpE bLQYntPY[|/c'Rh*5\0_(GJeTbĎt8Aj_C/́+EV0qMcW9. I$֏Q7F3\G*{JNZ*w:0=b/|K4i _V Z`ni)M@24^OM FB;[^o4ԔV9$+G4-U:h 7FWO0]_3WN䭙*Rs_4l䩰;۱|nJXVz&|Ux20ph f殝?u˲ܪW{&zecf*?gyG8'ÙЃ{y[-8oj|5Lյ 09eb ٜ曦<777) YEr,^.P[W,CnDbԶtn~.RpFY-EH£ڥ6xtE6'`N<6))/ { yQY |vg[ ha41sU)r뇄qq;KP2POͻ׵ֻ?oRXճU8Μqaj傥>E%j¹ P*8ӆkeTdt!l ,g6aY\=V#CBLJ|# I"E*nPՈYNLj"Yh!4[݄g`wYjVdܹQ2DJ&׿!^q:[?z2Tu5^, DXd 6~ҨH׸A7I,DSdFoD?}1Z/[  Gur]FSxxp.ܠ/,:S#EryrDX&L0= $7|{D[͹⥆%c;o?)bRteyIFX:Ñz]*{6|+e342Ħ, ZᶙOCZ5DшrJ^F(,%} O!$Mt?@5ax\ڈ8i @ZR(#]L 2-}f?X[hU(b[qi <*FNGP]4"4ؿ'L pYX " ރe$Q'+RG7J*UOa/yJs |^^x_xVwYM鋮'b fTĿ6(^f1Yi(!GRmeP ͒ Kl|$ ޫ%(>A/#(:+L6L"N\#ەL4 I*Μ0QqA#0MZ 麊=UBOrNs`<>dyKHV!6`At!ZO,l2U LM!ɗ Fwmw8c)'h5kBbv0>fՑ%SMִ#[QX3U ) K6c9fҭ|6[i &L7^s /;: .GzSk 7 E{+ۺCMbt ʶT~z`OhY|s}|i+#lx?GGw~~xp{񨀣̅KM_uNnZuY}Ιndwo~pB% wi!R*t@,"dmzm0)ReB=Z~![ È$6poO&Y <@A8G*J++7j]a20SFN,d/ZLww~5;XM6y^^YWN򳮯PsE֢jDYگ&KF~v"|Sqgl}uի 1{lCr@fl59.|=N9tP3Djp# 1[Cx H(bb(V#jݵvw?gMq^ѹyenӴ5!"`> stream xX T׶X3hcőC" LDVDqHhB&fcti|D>r /yLIZoU͂Ϊ{9OL&cV,|QsL|a8I$$ qc1 xda)v}C=fY-\vՋ66ˬV{xX9z{/~VN>QV֯zxyn!^5*'jggp^+P7=7]P`+ خ ;:hMpH躰n<zsoYf,|q◖.]2Ladiff:81[Y6f6̸03f3k{f-YǬg1K&Ɓe`2#+Ɣg̙1Xf3y DƂdcgd3&LsWF#t#oM֛d* WE?zVŞpj #on6=9jffFgñc/;sn0>Y~'MM80Dbym0QP-w/S*59! (9EJ4h33! (hj5M5a EYe +/g5\l@_p,$ dymoqё<8)xUU~A끊j/pWn)yOqݍ8Y'/k!+Lx`I|2#8B #hZ ZUKx煰U:]n= (e_:wʃpp[YK*bjAWI$ی8 Nl=y̥ãdo[a]~g0;K KVׁ?'^)?GĂLs٨VלK>ug4//W꾁{25N"N{8 snt22{ug.mJ*m>嶥;Z S_"SKТ;3*/=kyW^|gTW'^E7Ni-p6)\Nf[NVGlWy}ܔ'm8 u*0Q1/z; g͏=DN{17")&(pP|U{Xo,#У47P7xoD&Y'\- /&UI1BzFBJZF`\/l 3ai4Cj6' l*(Vk3*²RjP w,b<dT}pcћEp;У IE\XzzYZ%3/Rw1 /+qe:qhBKdEsaz41*43^3kph2pVhp;M/F,ye3^ ' 5i)ZЦ%HRHx<8kTjР AaX\=0 RV 启+(s пWUd/ u=oC]!=Q5!G ^6+9'.;)+0@XA6[PZ ?EeԀeER~uVZ0e dURZ0нdGh%VPΪd1MukjhjԷUT, uP'T,y,C6E|;U@ЭC> bU2j9";ϳn8dh($FE%߂uUUCPi)T15Y8Zp,ڐ-ThfǦ,K5Nʹ;FeBf^*PNWuKg8j0f3[ݔmHb)N{لv*Bu&wFr\Tv{~7l ٧sݙ ka ߘ#7H)4뀳niTм`M(/A4e5RՒ1|nivE e>S͐pC& !44ю8Ȣ؀xݾk !!WT m!Dk^U̠4)kT.zH84!%'=ћqb^&Mj܎׷Fܷ*,y86#GpfI4xG(©pЬ\RBVFV+2̈́Ncj|;p#3`q`=p1!'u/]APVGo;ml&:ˬ{k~.]ZMӪҶFH|ړr0J<Ahqv1yEeQ?4 r xz6t74wd5YO))a9s$b7r75_@)mwN2Q/djz#+Y mb~|6+ٺ֝3·S>+Ԅ5 ,"&,h+!+tBQQAI}I}};&z Z [gd {LeITt* P-2G{H C\r6s[WYo[@FPDeU29@~..,*T MՖ p!(HNOMRK6 QgRfp[^\VRSE^2X-}LC:48" !36+=+x{ء>\{;I?*~-. \Q駱dfᄴX 6MD?J_:O5FfQrɹB3yЏm;{;F 7֖m9ד3Մ-?a_0eq>R{]5mb BKy bIORW)i`pu0dCi80/Nu~rfI^Ƽr\%Y݀[n '; zZ &SC6"+ q5Ho4AEqqf&ds񐖤 L#Z !>%kq hMb(cai_5l}[E}q>upY1#\!= X?)^irbusw7d]*AEHާ$e s_}!$B\]3ȫ8SjKUexHBLDāE/m,cM~,*x5+HҋHu(䶗p5Df;uS2IzIhѲ(;ERӝb/PoeE(nˡT7fmn՟e '{zn6;w$JQťҒQqG㳝p:H~ӑɄ _uUe,(k&#- mp .,hn5|x] *bǣ5:Yxdg HOSЦkR3 `.H9$]rkp!8[\fGi &^ TELS?ljY@|N`蔟Xg'1Pj=\us8^DaW'ZE;+Rt !tQL.e ť]7haޫv0ٷ=UOI{MkP>Q;mp4_zLpMU7.nBpWy0wk:D]ZkF]gzt B[*>p K/'0-~ je2*b#,PF>7B 9{^i L=S)%Nbjv)@f낳5EBMxz* r3tH[ %yyBI9畢Ʌ+iAWX&; X^17/b{=89Zͫtt@=#kqzz(«HcXJS_8yauhzր=ޚG5̉W~yИC z7h=kκ<ŢK%$^!hN-QnM]ݒ*9~nM0OhGܟIES]X$X)F &f#lt9/endstream endobj 295 0 obj << /Filter /FlateDecode /Length 277 >> stream x]1n0 EwB7dR\%Cd g&-1J^^C.oGoeP\g||fƔHaFDh{im9kO "<A܁]g`t:nYA2R; J1kAnS[F7{"BHY/O/1/ᘹZ1o)/`̲N)R.endstream endobj 296 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3997 >> stream xW TWO įjqa>Ukkj>kqq_%IƖ}N$DAwhjti |N<9?5f'OHܲGf#'D2ѯG50SZgnNGީH:Emk*DY3J_ʕ+/[te<(+=5?>!(SZo+H)z)%Kd2<_.\/*ʌ* DRAFƂ}>3f"GKHAi޳^i;2-D8`5U\톪AZdcJg5f-,: >G6 \PYZ?TV[?;`]7y "&*BGM 5]ㅀG jvw23ѕ(x~OoPCe4)ȴSB2;)?]ijd7uqهZx_%+$Ģ^= Ss{týsTM'8ە!]/H^.ĭMG>*G_u@FPkɍ+2w>1Y8;H}^] Z0iz#M0KYkĒhNC(@.'4IHi<`Z,v2&dvђqdqzX.ϨMBH[*n! K^\h4g\D-r׵5H(SQsMEerFc_z(0bڨUXWm?Q7Ui0VR[h3p->$.;$Gx5f\e-d"EnC PW&/ޟ4|Zԋ.TCKN;)j;vxo ݽko~uDay=yRг|2~~IAbuA0DAGH|*nY+ PS@jbf,u]ļLuN@0TD_LK7o |@ZuU DR.JsR=g:NH9Y'.К[)o:QgߦN -*~AQV7t?R_㠒x ;m>ldVŴΌ^[UA Vbozm;;|W=AyZuQg ER!HA7HkXw`dѻ+,v><.*\`%;cGg&&JwNR"흝xG$5v 0bfZk6M$)I7t A *qqw.͆=EZ4j=G&2q/e4%/)D@J _ȯ8|:ފYg|07pqt jKrq ,6Wz[hp)sZ IԗK@/@~HxZIP"Mud :faH~6(Hf}IEk36?Ysw/ب؉q~Č}8-BC( e8!)Q'y򵴊o, q˃cnrit4ȽCN.ee h|&:ʉ#'/`k.3K/{wI߶ .5TĄ R#*ȅoRPLsIa$W'$[KL ^]멻Oh.0+Df!(Y Vs `$NvId3~`԰5ba/~`E~}e)[,+$e3:i]X-tdg[8cEPZإ钶S@fש7Pf㪶jiGDl/\!K!l)4;] 8U }Y{-%׮Nވ]G0xϻjAqIw{fp*50;Bh]6Z]Fޠ'-D(TvTyn7iZ ׶FXh08*>|M$iOrgxaqP/d `CNSe-ݶ Rd:'v4g5XJKkЀDK2Z0|]m Pd%ȧ92(Es u(u"TyAWMw:V:9((cndA^a~N?St>@\Jֈ_ɬז7!5M'+Iyzi0¹DÜ YLz$wd%+2PvdE60Gt x5R=nCTU,.3yzWt{&DJ :b綣w&w7# E{^T2=&]LNZHk}endstream endobj 297 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7246 >> stream xyxa10DŒC9)@Bb;.nK=jM.ؖm\ptBCP ɽ''ޓs/yMǹA0^{C(@0lٺs8;N}vw0W#0rhݳz\)@ M,&dȢ#N p ;{7eѡ!BB_bHCÓ3ʬYiii3CfJe)0-:9*psxR,5<,p4>9p}H\xL. \' Se ߔHJ^:5-$ڌua7Dl%(fk춸SN3gϙK/|ec5@=Om&RIfj2BQ[i6j:A-vR˨.j95MI͢VPjzZCDͣRuzjESéT5FScԓzzzG#ŤP\CC~Q~_0`xˈ#zL>rs֌O-x9ccyb\!/z* O#L虜q%77eDLgw|)PvjMק٥K FKrm3߻uxw8wz+ GGÐw6xWsZлX`-.Af+AOl yX qwdvPZ,SnDŽyӞcА+ЫE zg csx*zy4+!WU!ϳ-WNյ}zI/&=|, hލYzWܻH60v pTfͫ1vԭ އp2VEh ܽc>+ՠU*_ WгN {/@#qfdCAȽ̓f pceI:V Ztgc:h"ǣs[֡M( ,~s~!!Woyk_`w,zu Ar f&l )Dyb[L:uDtQxZvxk67YޘK^tîFS=450Ś 6Sp(nc{Ne5d@z z&i : ǩt ́xyBO=oK34RNs,so.cFJ|_H$!-HZQMV<^ittWT7T$N5d2}E9j8" x\_ۯ+ -EwE:Vq^A)C-Tdgӳ@FJk OJl`T%+c 'ɯz?]vdI‡|NS+y)bgҗe ~M.r=jUq+e C2eGCLGrm>6ى8 gXpT;Qtt[pz;;T@O+ʒcG#&(K+yT. I/!;] 渉Dgra>@HxŻL%]tu{+I}փ>qNOD%~7d_9'5E2U 0 Z)4Ѩ>9%>V.KOVt y <|Gvg;_V^blUN(#AJO%@C&*<;%|$5q$Pٱ/oݤ8Yr_vupbDnn\lf*6\-h}FQ{: fEnٽh1k5Yk]6吳h%)BoO!@eԕ{H+-5`-vkmmĮʡ4~HD]'@(}QlyV*#dD\'Aq7M xPl/|<*3\c}g;Zm9L<3H twb{~ h,A͆B aj 479rRr f!j4 QbǏY@/EΒS=gR|\e Hr(.f;vLjZx)\iPnӎփ;BRp̘IBgwXNw8'Lcj`4̶eKK08.4^E`w-`2WaHύF~ϝj7ItJcf4PoP_?qJͣq#蝾L&CHH6ɷz% }ҚF26kj&oXD"7r. R4Ur7IX#B)2YDMkR+MZ9M eI()%) p:ھgRڦrZcIؓFNi8$vtB3i~u5y %*5(.$fe)CoOu-&ڨg6bUv̳`a~m^!T( W½{:-&=+8. +.m1cɨZIx˾afnCZ6ⷎR*с!OZZM#uy7Ѥ3x/*,?Cvr }s7G*т{h_u\x;fq;^3DJ?*=nAmt"AOAv~\yGk ]ʒía^᧢5L*1D8|D' sJ[:[Prr{h,W U$ zG 1(oh'/_Φ~hx`B?o=!C5cVo= cEyyyon$Ja!9'5c"e0'ɳNnzL1O)bDCnw.T'2c[巿ݻn&m_uȯ{H' yZΨT/zni-tSnƓrdDsKj-VC^K%AWhoDDKIFۮlA_O?Ox3El#j|7xU!Jtd[\*$/~\8EV]uS[g=cg.ri_)@zg/ZTcbx3vf4pjL<_`.芹KQ$=ڵU,O#>E#́L}f#r>Hrg{ N8}r8/W r^N2btM&Ǡ߾Y8wVnasԥΤm2ٛ:#Y_&{_fpG<ʶζc ֩e?ATV5To ޶7ٲ*MF==W{sMXN Aj2rv.! d7l``;_1Lc1Y<#DBGyJwo@s~|lϩȈ%u]YbJ%BTD׀ȷAeP⃦w1Uxx(m$9&dMhg-z!Wm3}[•r5xICB 1m}x-x&>OSI_B0 I^O:ߛx32(^S6ȝ-HAmeL#hP~ !>@Sђo}A1uh$廐?NHIHqɫvj B"AҤg3P%r$Tnٷ}7#k:ƢUG׹61oK<*pV{et F^c+9̠Eh5+ &)oFX*:w@D;c)d~oz(5Kػ膟] rl-2Ep CD_"H¢x\>헁tiܵ9)ulG $'o(hK8s {CЛ%hUhG$Hcʲ"ϓk|ZgBt;7Yd'?@EijASb-wwuLilBlJqfUMáþUR4BԠͫ O`ھe߽;k}:枻7ѥ㕤kNd/h٬x <^Y-x2,јbB6\%20v?֗VD_l;5uQ:w-{!ӍHAtI ?P3o_^,6mCʕJF%1,>EM7!ڄFwu|-[c)g+{"4Hif uu鞴&- ²|GȺIK"PNN남\&-kG5oW}WęjJ16xwM4vڜݛMK+X$8rkF_qi.LF^}[yYXy^td44P/3ee W^=-Rߩh8r>[h$uLN~ta9@N TeW{F,U4, *4k 50LM&=s um#3{o<4>xGZTK Q~RIo2֗sze5+o3go}2L%b91K[z(x6Xk="Oh W;U4:K0=гP-v:iV,~z63NK`;= MC[S0sKK}l!O[BtDz3=b zϧS˽(TR.<#.?ƌ{p}H;S]endstream endobj 298 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5870 >> stream xXXڞeav(3DcG Q#(De{ߥ7!eQ[b1Q&1|cg]ޟg9s}{c#B lg9-aS\K;4X7-fܘPn ۆB 0,&0H. = ?j֌ %{\]C]C ?M{CVy->]*Ns(\+w{$}ժPuV&?(,]be]@0pM'bz ^ޛ}7/x&혼sʮӦϘ5;jy`wzbp Gb3D8[6†N v+U Cb&%fvb.G"!Xb1D,"!b(0% 3b!&F.M$ ’cb4aB Ct1J#>3o\h2$iC-e~<3 H=y ^8!Nm*6u6uXé[sfs̢͎oOa3"w z}|H *s₥((Q*rH ZGS8şBn݌J0Iעbt1\l56Iuس[O-\`^Qϸ:)[,bğF2ůϵ: 9Oa166燎}1ϥo?7͘f̚-LµB(/^8{օs&[I7>z$Q x=t֏py  U0iXVpPU9+Uz{w&Qx,þF׎UiX] jTdI ?i?vr}kGt_>Ė'L .=vTK] ˱侜f[Իp) EW"7hmA̓ 7 n!e(iMQSb7j 淧GU@.C2i *եu󷮑udşN7ŝ WPL,i`vC Z?9\:4S! j?8IHhB~׬NTjC#R 9 t#Y/sS T\(}I"4敦2gSyZj$+~ioVAiQ A‘47#$}^{Sj.H-3/! @דXoc6EH_I'jA 3Y:j\ۥ_Ag#Y,"!Um'&*26x!/˓ &,%aft&dy5x(w jd/ AdyekkgTRidS_Q Q(ͬ^5SLkvNy9fj?+-J56+#?ǡEuI}^[riE(Q[O)tQ.̈PgΉ&*/E({F8xDٻh e+SPy Hh aA5N}8T:z&}y'I'ax]ЋV8cnljև{zkQ7; vlRy5R0vCŬX9˽(o]k nGchүkVa\z6hOEF9ԉ/TxFq%;!{"fșYz  Us!d~<z)jdJ/},52 ڠZ-h|Ry'Duѓ'֏š~hd$i+ÑU[^5}Ǫ/s`% 2}9pa so1 +ͮ'Ξ?zLJwnqpqqbgzCƸzVSXYT†*Y*]bX6owOc"F? yK򢭝ч(b/:nZDVDJ2Et%JD1*5JGř — ˎ-knV5y&uY{B_YBR8NMjd`[$(?%{hM >\uj07G7qkC/I[YzdJԼ`S!ŧƢ5V0oQ?bx3bS="Qn\,xCݻ*~OEz1h;~|:iRK5 g^ٙPz~v9 ga\Uer>ۅ-z|Wevqss_.+XA9)宅a`Tl&# Qg%E3n y'\h_/S48zju`-wt.7Y|ϲ[Prza/FFK)LZiH<O1 :V~'䗷Rn)}͕z q[1Z~ʁ#l؝E4oMLc0eoCH0ȑg;`? qtjۻ}Ngx_=3yH}ġ;Gd_!I"5r[@FX(]_gKsQ :Bn rrQU%+Tĥ"|KG2K`w oJ+ *9,>&=M- u;CȽ&C Z37hK/ETEi?[m94kkRUE-=aٙCRّIõQjpjp"R ~_C0VQEԅʖqrm)6s>š{BT <.nhNFOx ZEE9pKICB*&pbГЊҼb='h^2kiT)/K~`aԷ9MRAgnc.bY\0G<_E]Nm#QDi !+XPZ<x el|RRҚ #M8g\f8 ,\o8ٴCZHGRE祦qѢ0('\&ja6i<٦34J$lĆ脨D$LFv#5Xe,Ͼ}h_^Zk_ Z'o!XmI8_5"lc|W` .iPMKKV//x(ӫUO1x,Z=м U .pS0t:)?, QRe<>36#|Q,%e)=|XM83 \1sКA+w*cSIHJ)K"ʚ{ uoIK闀Hs/S4~ <叱xJkW,2>tC7q8_M{O(9RxwKCm-(JN)d~u]q\:F9eq9= N'_.h n_q/M4vLJdWJPD+sJn)ua x~``B[v0&xOnv'vx^ ̳!o˲$}S,U OELSUV_TÔ?tQ>5{l_gÛ՟GSEx|j"ɊS2sSJ07XꐬD(gs6gI`6++?Q2$4L;FQ #~hۨR\4 j~1rѥRELbRbD(>/0HFA(P!U!9(Qdge0(EEQTK% BZnZ~HcKhb ɿA#gI{!0  Ad^"9 m.e]Pc>X5m- W%|ɏ/E v5e|K;{ZPiLVȧ0\Z[.klx_1̈_X0^~ݍ1焜"(‡h;]MVefS2ЩcU9e(t곻gW[ϵuٖk :wvAQȧɂ6 ˵騘g/~2Todks][{=%L7;% ]0F-h 9#xmrorpÝ,QV[HYUxwz̧7nqT`ST8BӔPΔP_rK l ݆3{ނ.jo<.\Y[CIgmu޹&Z +Enٙ)y&a P1xԈjJ"Zqԅ(^ѾS[yв:Mua7|P$ ],E($ȏ2v:N<ؙgN )0S+r6/әY|5{iHeɱI(RV)/dѷ<.nںméSmo1sVѲG+ +\\dA;7;{;vlw߸lM'_;Ƣr7Y`4;4Ƀ$爴u!4endstream endobj 299 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 714 >> stream x@CMR8$v}-  /`WQmqCopyright (c) 1997, 2009 American Mathematical Society (), with Reserved Font Name CMR8.CMR8Computer Modern0123=v }j_:T]-}ogB(WI&;AxᚽӎtiFvċ鋿Ћі ٕz0T@GP1Sv"F}jpbcVs,jŦf,hjዸ⋴ #h,t`‹ ' <02ZYΤ<7#B? rGlwYx?{FvťbڽQ"DfVT@htkpozc,MI%ڧϋ1# :Q?f{ku؎׃$Ena}{mltNx~}vCoa  7 כ 8oendstream endobj 300 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3410 >> stream x]V XWJE"%((76 "ʢ%n\7qAD p .A *-6hC'-!hf{s&o}uUݪusΥ)01 1ik"WDsZ&~*A8i`@ H°@hpਅ3SŧYZ/ \>y8Ow\K5qIIzLBĘ457ZE&ZZmLL EQ׻oHLMۘ:3/+:fql@|DW멶;8nq1r9eE-%D* >R˨`j9 R;5ZAyP=EMQDQ(JA QʈSc)L)3JB)GB%PYT=mAҕae 2D.)tJo#de3S8"sU >u#[GG|2u ۠b٨Pa8``R/$HdHa(dR8x%3P_d Lb^W 5_^?U-YϽI + I _ѶTCZgJ[;Zaw3&uo0|fǶB6Ɵ,qr IDt'PXVڂ8\}  wG֍7A/9x ?!F@,RTtVJz lt,%Fќ<&|` EZzM[Y6{svm3_V[@ܤJ x;~9J1Q{JrK G4s{}G!~k3&>I攤Xе V;r|]U#SG,O Mǟ\N{H:j_hiLZ0vѦ~%d 3`3ΒYVtTrE垭YVX%~=6!zk3yn,;:V~2iQ uYNMA*\m+g@CX,`k+])e_;5뒈_FxYW7F)RoKܻf~wqϯ%ܸ-^oHG^|PrQq`YYt /?IţY)ikVoEOLEr1ɂcA߄RF(e`!.~Hǀ 3 HSGqH?&>kfWA!-f]-y&b^; ?B܃TcW:[mVXJt᪱+-f19VE#n3L(hzA!ST4QD?HxcAD̳8h00Z{D` J2=a;-.K|dl֎,|'VAHtƥL|CPAki=^cQw |,1! xb:hs5]'9'M<X5tSLH FheiM[w#U㢩i*_E_ъǵl 1 O8B\\]K,TV1[ ⑤ܭy~zo~Ov}*HtB|T}((ؚG1OpjӅuajv(bjTpXE~ 1G%o^:-%t8nhT0d`xQɆ`Ps;+o~~aˣ1 Q?|XH)~ʾYV?#2= Tp/ qr{!—{Jl%H~m '3ҡ#"a_tc؄8PZp+N?e<1ѷZ E[6b'{oWߗ@yff(J4(I~i|I<lTd?} (F-S'O !V_PWpGG|^3Mllb5q guwLM;)vcȪBӑwBJֈ f珖\{Y: Z7N[gށĄvSc"o 0UyK~S X{r]W[|?Io0N_7 ǁvluS(zGU(8孕sC27 vVr3-썱(eto5:?]\__XPXxıӨ(i "jR81HVؼ nVUw.)L.pu?: ~ڒZ(Pb*L\!"nn++"s<^ |@`0ry0O#t=o^[>sfZC YI:D9]NOls7L5lk!|_?TQGD/,u ;1X$}B~NtT8l??kWыvЈVhn} =g,~WW=6k%)8Y5s@6!JxA_$ 0?@Ej<ɴ瑏U#5 T3 6זMЪƊky#/;N34MhF `AH+Cѥ%LȚWC FQԿmkendstream endobj 301 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2842 >> stream x]V{\L?3'*j3lM m!.B讻iPҴi/.o&jEȥIrP.e.K}m̼<~}^21hHKMRMrF NU1239=, [B L9I 2%Bƍ?dIβyť$%$dPV%&)WKG')(ɪk}RRץEɈ _()xcT-EBJNSvbj <ʋ )ʉKM|)?j O9SSi|*RCM FR %'P&E]>o4(è衱¸̄6 6`h T1XkVoMMM퀉4@Eo<Ҁ,? -l;ۉyJwJLd3ËgP#iGjDlLXrumW u\&0F*q'&.RA] Ɇ|CpnrLcoӍ)n/O=,#5sY[O;n`I Ơ/7,S ug,#3LJX=m)X9[З(-VxbP>OPP?P?_$D;%80M`n )mx4l[QƗ;3BWgfu񪯋_ Wt],{w+?pF_/y҅8x, RV^s,3ckj,V*Y@<4!4 VLTkXا M :Lh a^.bt&1˱||l-k&}mm>NPggff 4\YXk]W^8G2AME0aPrc½’֕j.J _o/9|rE؝q.SE/"pgc_p25Vv^%Gh V,i\ZUN.poCsQڤ%,a>ǵ5zهbzZoJOxm?Q>yG ?# o`zE~o%_|]DV{DvIM`GRuF?ټ˱e)o q'>n.ܗY%l:3cCWQ @bՌ1 *`z&dE ffXvp`##wcbW/?OתЂNNJLvz3  WWu9R~~4ۆ{ϚbfI!~@Dny@Y׭:zwk a)5EdG1ÃY.&@Z>@!&We4vAM np(~ѕ(Pskbr'ANo Hhqr3F€)h)6*+,9*Y>>WAyCro3boZ65jW`R-zڎRĄfI]xXXg|؋,CF]{L 96kx0EzDٛRHFÁ`0¸ܸ\L?1jQR;޵K:b{,hVǫvE; ɍ#}Cu[ ֺs'.k^ܻ2;aFUikD+{rrW7;]/?Maqaaq5z^yz2O-ushjhDl\xX\ٳ55Ej-˜2?;vf\33 PBendstream endobj 302 0 obj << /Filter /FlateDecode /Length 160 >> stream x]O10 @E'B 8QC_Ct;,ֳ ":ր#MEY' ݕ> stream x[Ks3,Rz=-۱Glb x)їt@I\-=_wnl׊6GSlFԜ)9:< ]Ȫbvvt8:OZ:gǂM#tڦQTX4jޓ7y9'\uq`ZmDhiXpHjomlgnÌ 6nt~NMøVMP`x6'ı5s6L_u#1'po  ͬbeh 5a1ș55Q7M7C{LUyVNp- Wï%{Er7H; OU8g+lqLCFd30S1+|XɊ7d'Yr&`4!l^d_tBQM7<(F~Y.ʮsZ)jp̈́ A<A¤ÄZJVIaepfw[j֊@ pN.*ںOt#kS:?x*oXә>Va: TS2cs~ްv*$]>bq) h2ͪ\1(sV .[Qpe'YoKLW^QH-\bh|nJ>AR>[V[&E 0i{%LY{<('"E5Pdްݸ [X*7xB[8cyO!;Cɠݫ4Xƚ^evf{h\y˫MJE Fk$7…d-:EHW+&WYn.WBÙOl@ց p!To| oW wAװCr6 9(`\UHfsJjn[H~Oi}'H`]#(g"Yj`/9NuC`V׿% 1_<8G(Ui`P1[Jo g{p:m=񻼯(svoQ].%D{K[u%}1bC*:ܥC,lgL;#@ȶҪ 6Dh,kqDIh-_ "w"{@̈}|n)=GaCa? Yx>VЛ"~F tlj$o[ʨ4|̤D5xX'N%6(Y]L:{P:zGp(tܣOƇ 6p9vׁ'z'gޢzƇ3z\+_]=ޞLmz,]%NxfS1?Kx!DM<1%QOSfSJ0`t!)Ŗ Y^pRr@`5!B[ Qbמj\^$X˱'淴E*eܪ1 g9"˦dwꙿf )i8} a#V|P0HavjZvHt$C$V 6DQʘ<-(pD=8{Cj i[P#ڢ^=Kc1ő@^#;Fq7m.e&M ~b3YF̳M3)RGtoU}=d)qu'?(Hmgny;f;?\-7v@$W\ݷ-`޽>$`37RV>u_ Ò&ycm5q>;S:xBNvt2]of<4qxa]v>P(e }Lbђ c0qh UO$r!6 h򢍼œ0Pniұ`dH8wuPʿa!\FYl,fS7e .Ow g @8GZlS p#%Sr4ڭM&^$u288j(oj٩/űc|riܭ  ضOE)M_4s`ћnv>eZbJ@k W1Af6>_Zz 2`᯾]`v ,ErΨKГL2.ڤp؈+!gbƋKꩢJW$,MSO{ uGz.;HaPr)z~&Z)#owq{9C."7ߑ 19'a~&xA& dJ">hJgd7TA +Tl~hH,Kv̖ط/XH 9krʥAάbRb1q7bOK&t|v!Fo?K`.7͂@Ǔt;Gby M~酣yH{D9KjHmϵ  ǟz10#t~lk;X >ρ%'i:;mI\YNu( `!!M$ѵY~}TΒr]vk ײ^u9C,:k{\&_|҆.0m#J+yAEi{1GqQ#y6D#T>z3rיW 1N㼋qT?[车*^6xq&rVlFJtNYz-^i ,X$VRiF+?o|ug:Fc̓2YҘ+kW%tJq懋DBG3'jf:|# 6.:k sm?.n`C瓓wwӞ"l&5}?v4|J ZvP%B^R 3c@ UA.uA|ˠj m}G,T9]"~1*=?`|LЮ"N;ؓr͟U$,][ißKaYiX::Aly@Hq|迍'Ł[1ݕYlTs\\2-X;aE^[zX g26rlhM1dŪz2r}if,Oq9PaDy:KR7!Q5kϧv9hm,8T`wbpV-r2o%)m;8 >;yʗn@Oi'z˫`ŴE1EZ&+b.+T#o-N5?(WF#y T_ZʏGiendstream endobj 304 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1736 >> stream x{lSƏ|%YJG=%Z{C&H:Ъ4鍄K'8rcN۱__8v|lljsñs1@@h(T@m]k5Mݴ~BmL?O{)֎oo?%KI1]#iG萴VBﮡi[*- EZFtP[$'EoHiQA"zn3O k%r>IQ\/(͒_!Bq8L! 򉷉xvbH%x)R:li ]7a\GTX}kK!d`p bf?l)}O TŔ@Ig)6Cl N|XHv^=1Q R1!pFawʒc{ zb $9pOW.'4JT?8`hbÌBꉱ+ݓ,Cn66 (ӴPC9T w^"{KϷa=xBnGLX @?=Sp+4q;7 +:MAљDӡ(~1ʻ Oq]ߎ1!Lͥq/m~sc2Y&3{ m^o0=꣺ K NpD] >ğ>'V'B0/3 z7/>B5`4LV͠k%CHxrtIuJw=RkȶB |phYHK3< 8Y6,wf_ZN{FECszxdɭ{HsYmS՗ߝA直HN9 )6F|ϲqCEŜHoۣÚzFߐd _OE޸Ù\ˏ:&7͔nHVku\~i=:h%F tp{lfL1u]}nѨoSnZv e=2H/@vTvEn2~--kP 2MTcqA\ꓼ~v`bЍ&AkHWllx/'r8{Ysn /~B t-v߯kiZ4 D}gecNe#jzpO ]r dH'0(gjNo!9&M5[.?"3[yχe]1^:2u@SQWFAFendstream endobj 305 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 440 >> stream xRCMR7$,  ZUQmqCopyright (c) 1997, 2009 American Mathematical Society (), with Reserved Font Name CMR7.CMR7Computer Modern12Q͋oKL0bg͋§j~'eg #e'͋JiuP~>}L讧Ǻɋ !74/XWϡ=:4MFkgo0wCna  7 ڛ !endstream endobj 306 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3834 >> stream xWiXSg>!sT@%= X:hkZUF*{X Y$l- $,AY\qkcuԶZ:v봵=27 ֹo3_r]sy~y%Dk7Ο6&6? z=;3QD6 )iYe9, |a޼%REbLTJ(eT$?dRcʬKʴ>33sn<]p5dtpJa8^#}/Xlp޿PAh+.ɺÎԵ4#W*ޕ:gDm7|2JbS`<9 d=|~9waK;8 zLlpHR-UxD6`Ȏq ~eT{s.zf/x;ᄱ}uO 'O`).90hAD|eT1f\â @I`>9{a!b־4I `%5=(ȑi븉j _γVEKyG_xif 'ߝ;doeH4$g2v|mD Wn~E0Ric4xp5E4 2o13@/^;]2Ko^n2 IUHN|m9įʋ$v ~(ˡ<>E|Ţ0֮*B 1/ğz76&$؟Ά"KL`o8u`#Giy[A$="keUξAQ:_f⌅L56H~\]|NSI[!+])6Y%nOo|GW;,+JuVhC3X ?R KskJt]mz;La[vU?)nOΧ ^|!z\v^!c8 _y(~~kHo 2[npN(A4B,,3Lo&:^^ʥDp 4^#vmT %#㢕2`)^6X Zw{vM5)6镐1Fi P噊JT2Cqa뇖 FNwX 7 eggvm=`%QS [ P/Xb`d-"y=1ŒO*]U2ÿ4uKK`ɝȘ=ۅo9j뿶 cX~ ~Ζ4Gv~ :I{C;h臞؞mہYrj5RouVi4wXځ8$:UBD;xWq#A.ކcLZ΢Cߍ<^MlQ\aѕG 8¼X#Potژ͹Eq#'\-ih*t7I q)dҤ-MDP?|Q[떐_@`v^8iʂ&(.Cm6=}qLlBdVKjnh V볟dq4,/K6|дURaZƹVʗǟwl)ۤv;y7N B?!iϤg8um <$N3~lĠȻrHGh\5q"Yo.wB~*;vBz/dq/r~lFDD">S=䕓=:K!*wE`xјOrIﱫi47? 7)]-5Y,~6r|t8dQ4ADΖoWEtfLӝ>6u\W%ŌVSnC~ /)FJ24疣*X .Ţv {[g'KH5D6T55{\ŒAL[~.Asns*y7Bʇzas pڬ|P0kSw܁ azYgHIFܭF~-2?C?<qn5R؅fc{CRQ 70KfHUH(ScHXJړڧk˗ut+%]] `6j(` j+ c3#4Q\ԁ( +Wa:vIs Q 2g'GB zo3Eޙwrk ֲ֑N"cr.lg̕'O=},@4[ʠ$/jP4EZcq?Ϙ ;֖H?v-UJKOZv\CZw_D] sN~YkmM8p%;^^5~5'a:FS-#$;<nioއ4W* z|?k.B.!ug &яGKpg'/_a @|ӠC4<y ~ֵGiTa ml_6O؊y!5ڽ-]t 0^IJKOK몭*$/ѐf꺈deJU7n {H= ŠgHT/Dh={opB4ۚєҔJdPGJ:LKT =6Iɭ}s$#r25dbͣ#C2=_g&푋TQSuV#?;([╼]ei [Li:WF*G^LdEOd!c6E+5Oɉ9}<6vBV78l'Vw;X^\d'-|Uv>X"]E_ zlpendstream endobj 307 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 727 >> stream xPmlKa~߶kA{ItHd">2#dl2#v6ݺu vhN+B5!4!E"B$CJ0~#{]e1~'9G93R$M؏_)rPؗɌfqRvS n n(۷A`w\ Z._gwlrt`­aCоy$N ȇ#M7Ҝ/f} /4]Q7{!COsǺ}IV^ kZ WH p"NMx~><{ogxc|(ʗG~T%V&31 ?!}yGdǢ񞮘L,EjE[:pgGum^"pRn->lB %V K#=TOdIx[RJJi&tAJ0:WeSgJ_ $x2>~1΋kΩ91MzrzqjV}nRW1.lendstream endobj 308 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 310 >> stream xcd`ab`dddwu041UH3a!-ׄͬ<<,˾o)={ #c~iKs~AeQfzFFcnjQfrbobIFjnb ZRaQRR`_^^[_nPYZZTWqr-(-I-ROI-+JLXW  dX32EWuLc KĤݽ}Ӛ׵75-fU_:W>Mw|]\X*y87Ob^;n1endstream endobj 309 0 obj << /Filter /FlateDecode /Length 5245 >> stream x\oq3~1A2~u y_{f89ۑ_q-)hWB+o^C_r Z`?1Jߞ㋓S-wDŢ*cy|=.7>>~pr#>(|5}a߇ چXRyQلD918X{|_8!t5?ɩa@1ӓvYTmg}8׺5 dLYYϏ|=c3U<~FN:}zB/ ڃW{7HcUaN/# Iw t}3Uc}q|;*<lbcGZe~l\EM)KCag VUhdnΥnj9.ˆMfd!olXpN3e$y>M؁|3mD'$G*H+ @:r%Dz)\ /lʺfh6hE!cim qtKW5ЯE Y~$ UVgku=DI=ƾ1:*;o⮋# S#dKi8- l1T&jц%vŨUZi{aߤ9 O'IZMGX - e&7ERn+n&4oY_FO0rb<;]@Y|D KGsD^.h?28L'DS2rǩ!׭||@sfD/ ;uxS 9+SX1,P4aw !/W7< XMee6G)l=(u8{tc(dr,k0׷Z͂١y % l|9ϴK1*4Y"[K`Zba35)23:%&RRߢyp>-aI `+4+ܕݿg)!I b G WXچ:7ɏDnlKv>@fO$ԝ.LSrHٸtx΄é2[P=k^*؄E hMh9ѭp/ a >;{aY(W)BUHm%k#{ڌ8Xʂ*TLdd4P78ZMf$yJLi܁d:9S˃:zı`/\+[_ƫ^9H-*Cyé%RGpDWP0걧@-#wf.yf`.yȞ3qaP+i]x;7ө&2EPiq)atN:M9E🤘&x3 ҅L)=+CBDW`k9&s C4h-4 ő:`#Dy.233;KL=  n:e-"fo7 qCmfѨva ]LnB&R5laE a 0TZNDdSIYChJIɂ#um\H9hZ 5ƣxwئ ˆ$3h`0Y|Y }N*AK'umzՈhY]F1Q,hGtE+O \^T3h[yʤ e4tX(go$+kBO:%-/<0JjPxzg(9C#msNfs4:#rj3N3Trg_e -i7NSxZ$cea52<.Lan_LrhAYh+~9k"n 0"hi]ufi_!Ө@)*3$< 3{Cݭ7hƱ5Gj16撣r+J', Gː*kn///jKv`a RJuu\cn0\AQ:R.nWFaR%x%7<&& $m[`?&S|g|n.}Rx gyJ[JUF:pz 1v~C+n;&Ye% ;CBߵCĠ~vhv?3Š\A6%RJ)L3 ReծqqO6, ^oc[IU Dw63[N%&Jcp(DKϳ cqO2X'Y ,pr~G;oSDhC,"Y\YƵA<-AvmTWWRe}i.x7VyZRJSLj\߼⍐|8a<)[R `H%AP氽'$3L^/h}νy4XHb$Oi "hBŇ:50:I>l}:ڙ*zH?~)j?׺u,Yd,0M7fdm78+W8C·r U*YD:dVa~, }<-vZ>7⍿mĬ ۡ^? }CM]_3zV)0#XSEg1M"4ifaʅ}hH T;|ֿ b8"endstream endobj 310 0 obj << /Filter /FlateDecode /Length 11430 >> stream x}[Ǒ;ao8>]y50+<-vMi4/"N֭IɁa;UYqϬdO{~ó>ŝb/stռ[|NoӋgEcgDO˧lS[.#Snjuٟ~"?3q6:?y{Շ)Djٕঔg;wH)iJI%Ow5˙h'760] L9w5kգ]>NwO9OuDFZ/woڅT'cеl^8EZ\?>sah:%cDdoTtwrv"^4ߥir"R S],*a`ʦTe!]H|ta1g֙Bldtume ׁh9K;9%c>uVR>KOHdzqO ~ MAz͛ۛwW`η.|w{ӏ?z|' BJ-5Ґ+xAgBFl*h/ynL/RG7-ȽzhɆ`ON;p*.@&n]g&ݩYcO$nBu1CНRS̏ݳ=ƃHGFhhR, q5RsC;M$RtMVvB2HJa4|R&Chgdqi*7!BNR(%P&fHY1TؑPbhqx(x;tnCPɃXq;[P"m2OH{!p|i\6J4wh6AѲ82ƫVN3dߍÉ{Fg; !OE<4HhH v`UT]}1E=yCy_u[7yrsr[8&t5cyedHmc\^H!`'.sF 2x<ޒy2DԺdĐbGgTԅAј"ː,kI! QX9,588FܐLL#CP'?}LIevHdyH,bFY9۬c<-c`8×uhaGTE!iYWg$8mYc!䡅3&n;[)UvZ,!M58(KRFdN 6Ljʎɚnh nqZ{x_<Ď4TLTp҉ǿU 1qO1-)0|FB {$t%bmcƖO-_,2cr'miI[7u#7s>Γs\}ճ\0I! [Jӱ$.Ɯ 6yr2cLS#8׶{1,‹Cwu BƔ?o|cV3icb-<;Z:aEi疑B@5v>1km&3pQ6 # YQcZ=@cz=Ah}h +gLCmiC{2F^XBTD8Ә)>dZcb2Ii!:c=$~9б qaѲ/ps"#Om5:زQvhIy if쐍_2nX"uTTʰ-`9 |m*0fuf1pfpPƈ#z_MU uC?@b2f×xpv\ʹoOBط*>r& p cI@wO.G?F/9IDߵc#L|dlD߾E D ֲ dAOoK(ht.sx$ }4^"ɻ* ګlj}^q${ 1 %L@}$:`EH[_TxD x^9B IFeq: 2O!E{"CqqAl>@I8üBC y XAD/mo(!BEA?@pz>]>ƈHw'W GX᛼0h+$ě,sBճVG0 yb -] ˗X4Z`Џ,'ͺ`f5Y.&!$saPm$Vk$RaTe^ A^¢K(<;H?+l8)zZIX8yʢԇ^;F*FHCIhqU?x&rD01#N ; YOZxhY܌QRQZ U#OU dEu& ,%HwQ腎rdbAqdDBM0F&x5eiGkj<>'Y1эCn9) e륄F,>.FX5-B3bܭp+/]&$ˆ%$ )B35, ?b@ XyBȹ(X8Q7DAExf C#APLƲJ~b |J#$8iNs8CBrγGq6OzߔVB> g' xE.o'x `XiW[4IѭN])6unR'4Ģ_73b%.-[E.@zٗ741v3R9yWضa΂d֡`U qb2^OƢXRw+` )*bILwaH/CKeL2+A0`g(sImߜِ5wv $5R~jv3zRɈ4#^IF8+FI^ugôk j.oO)dJ/=C(lwNFC86 Iu|I>+ ߨH$!&3ȋ`pHU<3x=?>nU,~'ח GJȜGjd E*,QqaTTY38lc B;p(B g*U|"eY"Ȅ-Xմ'$>ÖOk%HFnxE #ʆK!Yy|I%,[' ('H,daӲFgT".$Yi;pt 4Lsn OACK4KmDNlD`-!#^ Q*$F`5%E_ula!@L3y0"s(K1E>E/*SX J[ Iju!(udDG^2۔`Uf] j9"[Hg; )VXnĊ_ْXM0"ƒzsp(YRa&dDne@J ] JAD U^#t?!F!<҇jQ(w>-eUB QɀRCN!bsWQXllWAd`l$[Na'dp` F݄X`Ne@?ؠL1m8=To}> >h@ (^NMV]^|Bx! د*IEn:(}:W).ѵw9hPH[֧I!^Eq63ɈlG P*21$-EH*1 OCIeUQBr2'y;IY* =Q^YԇȔ2aO<$iu$1LIeш#i̢h|~>-)̠YWJ}%B8'H,l,v*88NIAı xlS).(:+'")9Q0茺{)e$i\ՉD`i'ҳ6:QSzOҳNRE]UU(݌hq| ErM #PU}EIk@ oBL &2A~GZ9PN!dSLo 5l!VđHDlPDU!4,g7i^8,!ns@BA,Fhר0 DUɉ Y0#REYXαxw VQrUDx(⇹$&D %6IH%d QD ID8!J8D` :<| JdQ aSVIQkH#A@h9N,O-@;@A‡{ -2 /}(lm i,|9 V$@DWcLTE2E+n'cZ"1QSNqrQ?!b'XWL"^y.\pWr钺p!DiFR (s}J=Ia%٫#%E)#lV+ʴChStAPx:$C}ȤZq:$+o(Bc}CHV&.-iAKnR?Zƨn1!AtJ2r6JS?*$ޒ5C3lV(8UnAę4i7. ~aFdm? $%zn:%(%xqÅ O܇kTdfr5ptzAk:޽yxsίpgx|_z)OofOf/Ώo_OW~6/Ϟox& 4POogf]D_)??;7@h_Gd\DPq㫷˕!'H%xë7Vo?z|ɯ~FƂfƤxsaj" N8og$oWWfc[!NO/_⾷W?'/ &p ˰\7F:kMB62Qk)!} [pBeJ~6s.%RZ: sH &^'I~AEychDrXrsWM/,o"rM(`|\nbUKvݳgIs\effQiGsqՁ͓©TcEvYq-dݚW7,l;rk-Bc*܉_ >֭z`^71ed+f1f6D3_qk)sQjz76c'?"f#ew%Y:Y]}ȭKfmo-9;E,Q^߿ls?*<{61?,d1AL;ihfNc#`aTlEXu= OofOE,=lF`!!)iLƸ}Re:D:U*7v4ತ?W7 kLI&/ouF4, zXaauq"28Fa`Xu3)mS3}|vpD/ҥ8q|ٸV],Y,{V`|.zX[rs,n9:+[/ cm,pQIԮKW.$nuQ#:} fU+(PĚFLtůaglZ`JfPWkqZkE"=׵^6a\K ]]j%oW֭sr]gRY 5|1`CEWNV,X SnDI6iIg^8dQ$}Ykvf<ڔb6;.}''޹6RY^MG\Ң:DrdqX`}`ڱsgyM]r/iȵR8Ktu }[ڥJ$wVe?cJ X)B+qiU+]wM(imH7^-ɎwƢ@G]q륀o1ATí}mfܗK'ٱURhu >&:Y,p5T3,y>{ګUcdG]2nN(帝HOk;{ru]|/BKq'f$6RĨJ⌭U reClZqۑLZuGIr^9 M"m5ݸD}q[aW>O~@Iǥ `|'UeW1C<%sw\Ape c>.8}֐FWܻ׾amx7kh=X9 D(Jrij}wҐ7;`Y&W];եr{{bo#.$W(ݳϦxp$ȓ>bSr]~Gyf8Tλ8]t=anƧ$@pH:v)s@ YP"Y2)BZ8(| Z8(6e ۫SNFViGb鶻&͋/`'BL!iIih\>=_,|4@ɐC]~G{nyp6Q*=3wB ;xOۃl$}7Нl`)LOG"(ˢݲkpX:DJROE2 F0պ|6zt&㷨A bUODS6~#>41wy^9z{eۏoԲ[p`9hbKuK ZolG2k)<v.9 43'oTJ֕oX!끉JzFendstream endobj 311 0 obj << /Filter /FlateDecode /Length 10124 >> stream x}[Ir{c6ԵLzzшvmC-b79kթj,de%2n߿If_w_/yw9xni,en/>^fg>tO| 崟> ը}1r{O:Śɸ\**;4j^JYO6_lIdXQR5ϻ_1M9uxEkuPAJcLуS G]]7o.B&ELXmO4XL *eQ*5EBY*MƎ eQ*0i=*TT,Jn8jx~xSpIOOH$H4%J9|uTf35S?,Txjk;%*ܰD*%K_An> Yfr~!M>\"Op~yớoe=RQq ű=񙝴2pILj 9SY&w|}ؑWSԖe %y!TfX@f` 5VkZ캤dEcK^<ƌ6->aZ!"X"*Gr1ʥz$fuH~o@;ŊiMcbFX M@:M^,1j0S=ʔZ0q 2e1S]jco Ā&ڐa il̢8)/bڨ1ACdLQdiR!9aF0A@(U)iq$mHcCxj(&W4#6 +IS)фcʼnˁ@3%VX",1de^FmG']a"D&+OƑhxZefw"+a@-5C,Ҟ-M}boPe7þV.1#&dl jvqTL2TQS5T6c,&ڈFx&lHd); 33Š^&X[H?d`6` 3xeg֪;E%&Nڿ#a`܂"vl0V9 cYt5Z)G*'Kz:/"-AjAcw5Dтi> dLf2pzF UFRI$Y&c9ټM![)͎zpO5ocXIjP;ZEؒ -d9v).:IY.TcEM #4^h@zصk Ю` o `v^GEzCF˻&1\JgPe&, S|K꼲=;F(> r)ߚg͢]7F'C+ 4;17E vQ:éPxZ>vn S1f5ݘfy+eQ]QSL"q6uH Q0,h|4ӦQdPKh)m-9 sj- 2g r +ÛpwmL+La%ia0u1(_E܍9YM(KBk`Z!A/^mTm J)^Y ۶4ECV`=lLU ZT"wL@T,깑˴]s0#m::Wgbe6ZȒVJ$!;d=%̾`H2:T&Z>:ځ2xJ9TctogCP/zkd mφ#;$ !mgT 'M~!mv) D 0jzo\pO5&9y IdUA:Ӌ8D LT34Yڈ%]P!} ,Z٘0O$urM c | eTh_ov&`iQ[W"Apuw0a-tN@=Y/t܌{f{N@VcU דC#.X'!;ʃn0-2gXF@G[zr h 4{okM8D6 csF ;/>mE!H!؄ *l_ǖѝiUSƢ-@:DJda n"`hC&!Sx"E%4.lPN.|%8טm ,1'(E2E |0-mh(٣$~"\fIKk֟4PRܔ<%0هD L1`U[ۼMI(mSB'=3E  EI23%ވP١2Dv(2E $wʉ;>3lXTXbѸC!+{6OT۔H¨Ôv(~2q]^mR@TsB2%Qi^56)\I+,:%IBQs y)- _2Eog#Dqzb1pV;@k0\$eF0}&m l+\gPyvI QL-JTqBVxΩ)#AͦߡE*%;Fot7|ݤFgv(lze^ ;1mSeTܢ DP[':7)ϣzȐ5((9) b8vJ/e92lFNJ0W`hq\`ΗWS JI) ޮޮa K|zfoj˗\w}NT$m_{u a 4Riȼ PƑE(QFn4 pwP4* Y;켈=C[6Ӱ 8 wM HyξQM wCpOk.|UWށA wkմw˦ I*ꮉږp096ށB0hm5knu 3y ]j(A(A!5وJH9 Fvc8 x$0]qy$ &ߪijI) w5IkyoA% <aԵFn_(&yP}QȻF._E uFv|nkg+ x10]kAvۘ4+ z7 { kI&_` t Y7QػM%w{QػMw{Hu .k~'mF 5@+ | }GQ`w5㈂=?{=c^w^cw*Dﶀ ~j/wk@7ZQM%+6'oϬ-z[0cM ~-ˉOQnsa,Mwp}ߨ+0wšZv1Zw-wؒyk$`wﶰ }18 }AnɀwlD6CUm3`y7A m< 5U5 Ya 0n:xB -BytAUm[1pmf`bgE!  0Fo3a}QUx> &oFocowm> ;0&`:Av}=i<|N!v0^U@fx[[+6< *xwBAaA*o  x P0*'P-qۄ- ;Z ~s  x{ ׳EP͏Ac3(~۴ jV o¡6CmKۄ (ko5 8 €x?xC^~5 ~H[($3\us\ wNx=}@2Wxp|0# _5BmqVA>A%~;DZ~/ɐkBA5Gv((޶ Bm 043nx{&{,CQxFoP@g(<^!B3_zjfr#9K0dh -8y#8{qF&:elG(JtU(qc/fw(NL}*#|nQ2)dD) ns¸p,{_w(N2 }MF?ݠX}QR hdͿa^4v(N 6 b/[kܳmJ"2oQHp!1v0[aOR&/g$eD?=dik@JfAw(`׻׶9TDb!''Zj6 J"!hxJ?\^dJ1&|fI6~I;c?|OU_oyOx/\-+eܱ %OD?><=?񧛧t}T3u-LJ77=s{}w'H&͇/Dm~7\eLGN";jxxۢIF'ʙGFŖ5j#3\Jzue ;\1z\Mϓ{l{a-ˆY^ ;;zɚ㗁~t})\<.oy&'EԤIoߖjOǷO|X?^?]w&{x|',/ͻ?] ;oO'gf֏<-4ik4C77F@gqE~j-aS Ҡ CxNY( '&+-n397E0y(7>? Zq?w-Ŵ Pz(j嶆a9!۝og=~/" 㻡+{M^U~)7Y(dpl,x6&vUF9~"beF|<f&qwc)C%#tʦ%#ۜdG[$']n( m-o "l;wXx٫k#GV/_Pf6w~s4ahDeKRջPskR)^[ÿ)VcnI5l X<Ҋ\7AGF{a: jDLy_TMbtF˟7\&oHwrF'=jS*VK{/mNy]VDRבbN^ }äzRjo)l>gSiXbV^[;Uswf/X,YJ݋l*1~I|FE^QUYk .'Iwη<[!a&?X|Q-1m1˯^zRb+@xi,Hzr6#/]]}ī5ZVP['g7;K4 zK9Q|Rrc7[<+I>i{W۫RMjUm{sDvmYW {0'.wcC/}!{lǙ '!ws ?]3Ӵ_i:\i|I7]#n.!/i(JqNlgQ+^V) Cٌ}#7V.6eN<+ {S;CDrjYzH2mxtn|">/A/ؙ!o._m(u*ŧSU6Cɹ!Od>QeNic[\@wV\66$JSQ,$}o^Q^p/[iֆ|j6ѶZJ1atA;.׉,_͜}0^X.t~{vl2Rs{ov^ą$+ĽLCs=Umo92E}DwIV+g}v?v|"9, hӨy .3"69U5n$yJPECf#1NXL/i|9ϼi:"WLo7{)iqo7: 62v7@_Ο ΡGM_c%!pmݨJQe׻B@+4[kբ{IdHꊦUe :8'T{ 1+cĻϟb-3z=C}5yMZǖc+_򤣫2|mKoie0b:ʂwo>^pW{^&Zjev`HzM+Ckw̢ [n4v9\;/zH*>s>Ǎ툻G5X+4rDX Y/ s\) $沽`VԮR5s*;16~Wr)LܰmϹ^T<3r<'o˰eER8:2nՋP8r8}:iVˣt1K-3um-oKw\ޛ8rt[3g[e+L6輼UԥeQ<4Xxa^\OY0#L!i5㨖7nɏwҏ7/J/B76'gQVD 5N$/sSN MS14*=R˩)w0-΁endstream endobj 312 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1396 >> stream x{LSW掠*fz[N| Б`A"7#T[A+TmﯕRt : 3 Jƹi\6373gfd]eY?1n8/&.qU5,s==5B(e&ܼJiEeUkFX+ڨjq(NIbm`#JRJR^^ժօ燉yaJ́e+ErL(͓jID[ZQX!M-lrQ*T:T#SfI5s<$K*٭X%cl+âxlzbG{x ~?PuN4379%10vp3"ć|MtI=%;m}fi%SXM^!MH;(5f;0<_&v+(vOnWXÿ a N&ҁw\C]8L :(@s~dq[ag?\p?|fSl!HIv@3hol>5 辧iuB,@yjr_Fc/"nprT"xtv;mS+S8Twd77(;&c$ 0t:^Pà0oC%}!N-F.,Lc&c4a Yd׮UㇺʅW\}CKHq^Jxdz Y,6Yի^UGQP-48Yl+eǁNq4ߺ\A/4pzOeʁ\M–@G ӉfC-~H:߈wJ<@GDP <6Ad\z =+,78m'~q@ 2eu涋 W- x`whf7"*ee4]d%g#z G.$@%V;A ?XDm$4˾0{vpWOq U/PU|B^Qd&Ad{_}UpLCׄ6Oz,> stream xXMo7W,rp=@E-JlԒKIr% HVP{C>Jrb3j.& +'F?TIe@zd9z#|=FSF^o뱒i(2Z[fT5*PNh7ۜ)iݨ sllT"$]NV'}Ӕ5F+Szd` 01)OLk4cZM1,Wwk*h]ѳ)\r CARۂ U0DlXTWx*Z`bnΥ#&FJ)\DƐb?d)E܏*fוM:/Z{{6Pu6d񲵭Cpuu`=G`yΎvtKjmfw0ד0)Rڬ2W+}T̋C+LVؽ- bߧCg: &T b,GNVcdIou+Fy;endstream endobj 314 0 obj << /Filter /FlateDecode /Length 5115 >> stream x\[ou~W# S׮*#zka y C09HyLR.Hnvw׏[/nrty;ۥo6ezzwx|?2OI9urFT@ KlOon.WjD)X`83i$<9zytwz&&wv.f P}ܼ|2)|lJaq8IԽbݷϮ&0nV?WqA6Ȣ]^IAۋe#˘¼8tal @]` ㌙;z<4VdDN^NyW [c92-'gNE;3ف xSP,M^_%=0qzs1FoPTs;\Y^٢bpucbYkΉ-&];fg;H5`H3ͰWhLB=y$r /CF܌^ez˙E+EYp&ΞۚIpFG$X/ {ljw;>N!6سݿ&Xh(|{e:\,K nA I{Oz/ঐ??w c;OB&Y[&!MCGwxԙ)7Ǐt%,\l"w$.K 0; -Lt~ m.W`n Nﶗӂi0p_рgňYC~-ϷOH1l Ә3v#ݤ-zYd[ j6l9 KuK(߇JJ!сh3LpQj+o;C.npp$}Wp\ W L7j[8rX?qAVCLڕtPGA<`0|I`JY 7 JNg=?pA ;7 7BU0C)VuqWÿqI!|I~飏f)Y p3rxJQP^yWc9ÕhG> 5cE]xp~lU`#ۙ2TC}iRVԇC eo> hf"HLwϐӿRH2R낭tUq{ڬ#eCCs9 EDmB K`k u0E!꾩 (@uKm\BUh*x)(k&ͻo>0B#mp1>H֮`Wڇ\TH&r Kw[XXx8YS[15@>SgV}MݲQ ѰZ)[u@4j:GV8kw:Ht4grqZ}qِ\dIbd6zXV}߳Y2:ݚ ܺcŲ(3'4HQ}*U*@K\w7i@=8o{ʁEGzp @v~Qՙ]K59Y @=ĥaqށ>dZ4h`c%0Y-YIxo߲ȊyQ' VZY gҍJ ϬYٟWˢ6a?zL&M hK^y ڂZCn0R2#S4(5seQnaE ssFW:`x-bujy]ME.T#v֏ u&Lj7bS,y+j4ȩ&7g+5cTn8x^T~. %ՖpY.D tEP7NpiNpR|Fu;+6Ww!L21k+(C8Z EbxQKEE3/iq;}oJEyV"/;î<$8v89٣jOqsI>=;w~Q);66IcsUJ#Y!xiϞ4./1잕!Ϩ Q^S/RYscKY\QOYׅ|p{JX _-cQyn+TJ_s%ѱhC >/G.BNU$P)?ɂor(D(A;y*( #Tڐə"e:n"Xr*fo-#TP* B{]^![31鬒=)&,bHka#WL_b8/'(bvn޴Lļ`u'>T*@QZm/D).`A:vzv] b8˼EȞĢ ]YalH^E Y0TPF85qTҿan514}/DСG akl<^$(6I Ǭ^B\݌@I}{a +1ΒV ]K*ώy@)YR`J)+TR"xqe_RhRsR!rŌ`l4/a".:gXh=^fB=TvQe@;DXjPkH:JRᕞUɂE% LsbHiZ:գ}'\HW_;("뒄j^9ew 80}j1j=/:(:n\, dyI\Lm2-_NG$(^ao*y%WjӋ7e{CBs6#w:ޠG;s\\i5%,$,q5ln Pq6"_5ל ,V+zta‚1L +:. $zVT۪[<|e9Bk`'e_}g|ޱ1'/?P&3tx T%zTY+g86A9_⃺'3hr ~ ?uۻr҈j$Qm|3/ے8g5*vT7;-z=&ʝ)[^Ĩ*X%#%d<}y.~wba5s \Q+_}^@9(#)LVX#]x}TG#xg}E^x{># 5f`s3[߹5r*"Z'8 ^D0 *o ^?v>D> stream x\Yoq'|0XN> ۱6; `A"%Q(Z çW_3CLU8ȝ7v.O~nwq'AIkv//RW t;oŰ_^Io/b߽?TJo.ܿkݫ+G Drҩz DCM笍"&z|m%ޜpgQFGr Wq2셷ߦ5l:*qsáZj5D>^$=8<;o6 Z1hcJs%lΖ6eu͵]*a84q츃?v#T4paҬ F& .\0~^mCZ켑$X@5ޮa-3ߵ} Ye X |e0|} Y$#c{?ֳ wvy)ǻwpaA&q %(<Ռ`.kIJR G{2McƏ/,eW3Nk_~BIÆK*{u)PxKW;W=ETCGX7">!{ߏtA~$%Pl#[F_O8/3pO~U`ކDΚ|mHԮ+s~t Hn-=]isBgiT{4&"lN5H߱SUR\ϒ>"Fq2L97;28%Pz$TfRf;Rp!DP?y{ؾۣԤ#}Vb~$C-W |Jy %r.'AS҆$qa͸ =XzNgyJk]hl[$.3 „0p߾Si+փ Vͼ+|;ӈnա/ ]J_n-VIr;daw[UJnFSYX89 -+?.=28o+9hj&M^Wl&06Rlxj }QZN8m0zÀzف'wJ;9 Mwv ˰=vD"+g$؉VpgrJzs8ޢ l"1QjFo'}{WQfiӛ !#1qdEܩ;IL# _~@=gf3-EߏO`I|2qʬ,W̏@p{ofϓ1VQANRiyW,4&5CV6}=~٧_.Ln:<_,Q)ȭfcPBS>Bbc,ޝ9hME;yahf VN5E6R*}>fO_p%B3U'QZ45̟F7jj M4)q =F9͜=Q[QM:H#'O+ɴ&D8OWA_ʇd?}dIl)6]MכTx!,s< iu r F3aўT|*wuY G߱7Hs׉~*Ԑ[*Xg[ Zm!}oT&v=) @W~!% zɠ ƕ!Ap 8I3&yN8Kz&< /*D(Z94"Z<Ok1\)b)]lQh~/`; :-:35k9D]UcVMa-3bs68xzgbHaOT|2Ou#ଁHz`ar&<3 RrnǞTHΟe.J5Xp"#@ #5`~[hV.l-M^\Rl-MWFlCjqٹp*:]h]VL8Qӧ^RhYjg/!|V1?_^ ivy0D,E>c`zAW:پ#H'QS}VNvg 6;cKG*,DE-0anS2.CA}Y2I^b%Sqt(gGg9&.M`Қo[S&S%1!oއDcN+ReL[;0cǖ9N@ׄe9'óHc's9!U_3PN~H&(޳KSWD 3(βw2,9ޙZ T*b35. .!0Ĕso{At97E:݊lC5#j_5(QID''7W,?CҮt3d Yd7 ٓ 4}5'eWIRQQRg`[AZ~v-e6*)+F-iW:s{xL;AP Bu[p#˰EQ<9ŔU J 65m.DVig(Mi\E^H/Curuzs3v >=oB*da_P&hNJ Ƣ#+zeC@Mc!`c7XvkfG;ԛE&Ksz-zX!5\͖V<t81tϣl;zgQ慘\LJu"75Sg@Gm}ȥi͜3|Yc%j|L\tMǾU[*} ߻w _$P=H*d>\'A_'llR-kϷePܥ qZ(>{iѲwG/s JZ4yX:*?ba+ X=G(< W!(qkmyR~ 2;footZw})RspR[ʘ lwQ.HNKZ&Y~__u"d[c˃ӽ}ã> stream xZKoi6Nd@ȇAĥȅ%mJOUwuouCLwu=z4[X_'#7Oa}m%5wun+Z^ ׻U׻տ; !MoDf;C{gwW Afw /ݑ"tHpoijyϑI:w={-B8Qpb:]/V'0H-7[Lv9T6K3F"|J[}$uy+EwboqA-'|:d{1s wW\?`V[ c=2"d9" Az OҷQՁoDtGܳ'Ĉ8{=8n cAo!Iw~`l ;I& =WFղ"B:Q!FG΃p{va7Z^H T n% mKĘWYNK0ʾf a+ e8ʊJIP[pR‘ck~*< PkNXu,nyoȟOi;0Z~e㦊 ~kisۧSCHzF%hZZmq]6yi}*rO$V).Q'mcJ9#V9/.M+[s0蟸 <:] zP8,ǡ[VD:@Kx2$}"gWIMtIx !RUk С4$-w _+ ^'.*V#{DP 'f!,!01(.2_Dp'bZuLdm$Wt];NV_$,ll7=eSCԽӥx,vCYY șoZ. ϴGUכB4E-9W4z/*{bTTuK;YZL68 k9e;̱  (DZqErfo ` E5Gv '';rT'}ƒ'֘@ (]K\Q"?.lw ̂TPΞ*kD`OV K m[1ڴ8XOuP-8k̳S e #6l >K>Yq\*{z =U_{}RlꇨJhsN=V߶]SX$W"I1=ru]U3' MD^:Rl Ja Eۂ6J ٖ_4(+kkD"C$r.D᫰#,xǂGNsUX5ҙҘ yM8n -xQʫ0<6Evi'Cl!|aR@:Krs&e+h!1x XŒ0 *^$-t%܈'20 I s RܴEJQ?+Rtb]Ca8G qX譵]'xIA}o 36^ojmgil6.E7iԥK YNS7H4ٴqX pQ/mg[22P[_K˳1qd_f:6P ū1gN=eHj{%9:xNm=71m-o6/L1 ;94wָYE,Q1C|!Mb696QǚĨXXU2>J3.yss3ea l\*NHA/2qnAWlKꊿ荜1G8ų8x1}^oGv>)Nv@<x|sWyL$U^o)% )W4ct}IAʆ5OmtGglx, NG]g%|tY5Seeقĭ Kfө"fHSGnDm4NhIHLը͌B4o,wD\ Aл*K_<(H0`&@DUq6 V_ok;a],B+064aP6[G8zF| bٙ;_}PRu^|cǜ_t]l&"b4$UyI}ϛD `(;!I`Vl̜sd+\>3ºUMU4Ǵ־bF*xzY.rwܰr*_#1$Dm'{݌len>T.K>ZaeOjP‘|&عz9z{>+L\ȼdܸiDŽ_|$?jvt G K[#˟mh^/&`}E-mf_oz+Hw|[yGendstream endobj 317 0 obj << /Filter /FlateDecode /Length 5030 >> stream x][o}#--"K}Y`l&cypd[YIX1|TI#x`*N!j'_w9{xYIXs:aN{3;>{8wgAk:Gs/~O)~BڝV SIKBn)IvOowy #+vݒ>.ߞ91&?ӻOg?tg1Z-8*ZV( F/00: GH;=oN ^3BOqZ}$RBXoɱ"gD֬}gYa8X pw?I cFh5|Uy}"*Y%#_ܐ7#TF  T,/nXsU4§1~cw18ΨIxY #f#B>p5FAoG'}22kWvugկ/#5F<2Ụ8:ar c˾ j`;F2-þ\vplۆ[T5{_@g2e}r񆣎TxUӶddk oSgedf͎3ƨPa\ nfkxԎ^%*|Z 6`d!/7F>0su22v|sY癓!ϕkx Y_oИ sHe{6cdmRe[m=Q6UUFQWFƸ|sМQ]h- _i?g.6d䋕8ϕ/6>cVv#ch}b|Yj`cGׯ5Dλe(!=,1eՎl52>$fBZΧ3~>2ڱ2evd+Dz12}}gd̸ۍ퉇_( !=3b!_ƆQm3<EkmeedF^b8X#chs͖< ~Fyk_Y'FN WFYGͷ^O˼t| uk6iȷk}xZ=1LIɬzȖw !)DpnV狕+#cNȳ~G(7׍}Ԍ+Fx1gVFFU走OQ;V;gۨB# +1 3qkE}Ҹ1}Vc0~YEed![3+#cVZHF09,MX%Ah0/#9w%ml);@6-*#TF>MR>F%<3"}to2Ș&*#_Xke(KedPBD2ȷ _R=<>i}dGvFF|B&kc\ojGޠlOn7j>%#sX " >b]e|SXTZgfed+#[ZbfedSo`$VBIͨVFjpl1)EaRȻ,50/lu(/R &FcdAEҊ34F>;j'bԌ1-811ní|i1ݑ8ۮ8*I~]_ݝ#`QZI}ٷҠ,Z؍[H׊ :bk"]]o"V-oEgᝉ$*w"ϵ&b>.$!1&*,CkAS~_ґ+#f𴕲A#TU AپUCZ^t~}-ɎdP)1;"L1&9+ JEjbC{7$Ў dz)҇H  @h=8Mޯ_Y75BE%z>JI():ԟ?\߾y}xt~AI.?k\=f3\з`/`\ْov>]>>}C.쾿z$tМspr.tsӈ.`5#+e_7Ij@Q.[}h3jIGH" ҆ .7 BnB/Ήdǒ )cDIHpiԌU:F<eA0qjzԏc$"Sq(c2K$<9Iʈjw W%19/4 Qx?D$LZ|2Oc+BtNe~(IE&~oo g\|ŔIG̭NPCV1 4yGbL>D!kH"Q8Aht5,2C\ZCl  &= &U(c 6Z61,2!BO*Ye`޴2r廤y)6[cnaA]@rc$"^n:vi? OZ3A$ !IM'+1R7pt3CtZA@.ur,D]/ i^c+W%?zHC@ћt5[\Uʕc.Z*L*Lb4`J#U;H RŃA+RYRrH[« U<RjH91IqkVV7BxH6Ǝ&, v)HiT`FM, R)H3RtTAŽS Ks&HVzT5q4.R׾z=Ap"H.BJ=Apt_C RD^?Fp R(Y#[R)TJ)$L" CzmV|wc rGim9K%7BeFH걈R6rz|1R.\GHQl="*\t̺i]d EC ECUmj xj ڡ6{r iRVM9eBD ReUV7AL&w|T^'Ц!U'Dh&H vTd{iDj>I)#*DK ҔTB8ERHM|!*%1RBJl lLf"$e-tǿ$1RΔMRy=CRȋ8N29JBV*xT눥 E%`!E%xqTU"E%xeA<@Jy;_ :@ƃ H=AV0e1Bҙa:oԍOAO񐓫#mvJ u!pGHx=FUk'HxHT1RtBZV=EPIN,:)PCPnv6  E)z%hEٔB0n jhݐ+)!XoKnJ!8ڎ(]7TH%P)RBFQ'ȫ!\T.D_n{?ܞ_PdE;G)rўn-k E7~z]Zo%yN(_.vak/^CLi6.?7M;\-?>>+]7(0o;~?ubs{Z#eJq BϑFOO$˸.[d݇~,MTX|C(~0!"J\:oMsvavfL*Bske^w%.ddJۧκj Yn=Fih+1,+4G|-Nh:7Kd_Gg8LF.^B0MF@/I)m58JpN{e 7\ JQ))5%BH(W>=wKA63OY. 'Y;wЇl_?oZe~K9MՌd;3Е_9׫ukEґu\;x 9=Q9 !cMt9k}F7G؟MXSLBِ;AR}:bzld5?fH"& h*_5I1K gh֒fhS'cK;iwC¼Y"5!xC]iVGG'NP`9U#46mztvt0?i]+gܫ\u?X&S!fmK0-> stream x}YeGr{A?0O|ai`Aem=pb )2nR_dyS$s>[QYqs-cGG߼{O_FO`1Vh͛Ǻ?>0`]Nͻ|5m5UCnhmڪ1&ջLJ__?~6FY1cl`tKIJ`2 捧` [r0ns0 b50nʹd9LqΥcLqC;#sLrӖM֓0' v+KX`[S7.VcΜ}b s;*(SNƛE2%lRNf`ff-D eK^1Բ^@2esIı;BQtnv=Qwb܌E?CQjHkEa:cq+76N1 ?9 6gلr\cqU<r`4)8a4S{a8y9<QD֎Q8#cuPC c<džeŰQ1V?sɈ:qW+Zc)[wGhIBk`4vB(1P1#:8s96XFB1Ec "3xܖ4 8p_dnC_rQl^IkR[#a"Ja"4ѱ:F HЎPL|K""F8S&b^pW{1T!c冤-抯8'(jl}ͧfa= i[bubȡլ2$ ż\Ym7,IyT>r^we$wIRTxF>q!,u%cCFcG- 9ucY;8]z(uz֜p#9f_u`+z~QR ()#ԞQ&$Ej_JPOcc[8&v~ yiRd6c}Xj6a̜ c z1rc2u9c4,X'=OLs,_ n3L&+aIpQŽQXP[F z_㈊Q K3pHg=F5c$uȋy)8oE9IiP^X3F9&cm9~1"s2a3h\# isb,B=t ۃ゛VҍfNN= 5&Qp8َшc_GmS#ҳz?<ңҔ919A5ʌU2SXϼr> uńK+T[Zǁ1EPxhEsdf9_JY$i8G#G=-(0;r9cJ Q8U;vr֖)40b%x(\梵 eLj/VDUJ^Jե!הh}ƒvCAXDUZ&0"c,U~I6ᎱC'#*Bg8j8s<+EqϠGzPuu4PB9ϑ}3Gdȭ1"aQx¹#Du[$j 9%3(zYLjl=KP)YG\"S-RlBѻ7YDQ)19RͪsD?z빞gTʣsEXt0zT#͎R#s0c[(۴NzԎe8 c}99Q,QmT v{M5'OP qǎQ98OBRIslF2#CBnwxcD>EN@$(5Qbr/) #/X%9ߜG#Lr; &0c58K4~I:÷ᔶzDս|_bDUatS6ͣv4TarCͨ>kLuuWK8=xK|y=lD b~΀;3}/髿mGw)%wH"|ۗAThyإd4j@nFtI&1 'AqS=Ӫ8}=5*[mؿ}gri"I5 ܗqIx\(49 }ڙ?qm~>hD|P9?/|~z|׸Ӣ%8yqr%4|};iJ曮;zP}}B$_te>Oø0=epsL7jUCtGu<*A0Q1)SFuͨ>x7:g1J\I> `b^g@6N^~ϯ=KZbkE Hq&__ƿo!^C#Aڠth@\8 U{Խ' ' NTL|fpi.LDlխdm  @:DH=\G_ʛ& EE=RHDCH0:{Ƒ ֩Q5Cd 3=(y $m u;lyDmHxfN Y1$v rixyx1u~(!Ph A+_lwMFD1$]QwФ'MBͮHP{nWc| rMn;3 pǐ 7P;ĸ %ƭu3JeAql.&'a5%HEf5U4J.}؁4 y|(C5W]{י ݃!`7vcf{-1f2o:d==~=Ί8\FԻխ.O3厩G>?70'jk)E4Ɏ4'КclV׬dj!ckڲaΐzMޣ:(%Cn/U[İDEh%f OO1H+ l[틹x0CXxv+1{w-^sp+hkqo`;x9Ɖڢb^J_L4cW%˸F]{B,'+7{(֤:̶}zM C\C+sM 1DKJ׉j Q2!")"T$%˸^rAIZ ؾG6"AW 8c(" k+!z%WanVbܻgp%a,C5iJRnP 1^l gF t]IZbX=d[IhxFk7/WHqޮRC[,U ;NH5+i傠^2VO$/1=!<īQ(z^kFhEt%f+i dyjNSZ[3nwj&a!=)a:VPvOkjuuP kksf+u2Nui30-y[:g yj]tX}O|+I`l]"ށl(-RǑ]C;Sr 1V˖$&YҸ=;ZXq񆍧/p5)^ᝮȳ+_F+JfЧZ_ F۪ƕ9gv2/%?lڣ V(=D¯ur>+ʧ` %3Q*PLy UQ\?S(} ag+^nxYRbjUKVT=E/{e!9 ]W(Q{<$tQ޴:"+ jxkxFRX`(J6曕MmyS׸xq&L^#4.:דdKDʳ \+EN$^8 n1VdPSƪZO=iԹNU.GDG1hz]G24,e]̈́pOdJ׃{H$o(ҳ#I28)(l}駌%GJH'E}:U0StPV)!-ܚEbLZ݋cl]s<AdGg ފ ڎT]!W+Xrܓ>C++f Oyt &%HиR T$kH8Bf]"jRƻ<%~h0BCqt֊Z9;DNdumStBat3,?fhQ"W4bPؘCE 2d36Zqu㙢xUDiCfs>[ֈCOP\ݔ:Ĵ K)qMbR\qs1:;szxίb?5(.r O92SA )&BAtJ .U%6 .M t@G_t STnV=5=I*-5{њKoNѨR$SOjJ*c㐬7|ޡ&J,~}Tcƀ+L;:J Ӥ`^iF=Yͼ먟ϺVCNv\^?%Gճ 4_Od)jow;$kFa ͣ:d^d5&u/+Oq k#ia |˟7@4wӽm[t[Jofz9yOwZrM=< t7Ŷ#{ۿ⛼G@fv0Eq9VYhf]`Y]6\f᪭nbӣVrr9pW^J^?((I[U1Ѿq)`ꞙJ3* _YŎ@`fno=Fbc"me%cDE°JPF*Oi&+o%(fFBzVN[aiWʠ<1i9cnsBp/585<,h%*=oxp֍1<}˪9'&h $Qól6.ū+!ǶxLB@=EGL^ F} ֣ Fy8q1h !~ZE 3R9e¿JSZKHe5E %48j~QEr9bzFṬ;qhA^l)DJoJvFWsQ_q0SFn9 t$ش #x&ƉXޝFnsoxF%JɍLA<(G,U&xܚ^LJzg C9፳B0{9 |k=Οy0s!S`sѦa#ZœP$U _ikvnrԊjwTD+  cЂN9&")RvҾRazF>j<-_=UzY9{>G}Z&jiI͵(WĽ1&Sh7ZaR%/;?)iZY 99sV{b_-oZkω",-kWw3z{<'|s'WeL'I9)P%;qp9ԆQ7ñYnLNwPZy,Hl=Dapobb)PDpܕfQ`9Zވ)uN#&2iSfյKZ=KHp7 $;yEmsaJ+0jr*9puPW#z^: 'w0Ud Sa*#LLyꚲ+2Ct[))dJXl +#kU. Ǖ7 žh= 8{Ny$'{7G ?:0V'ҷk=(O-dy+vحpޕ%ݎjtE"UUfѡ qPOJ%5OY5ZL\ pBo|'k d\@^,ԬHqNJ)K\Q0=ѸPoN2S=R!̓*_^WsңT(ys}`RvUa׋Eۨ!ʱCT}"Q)8y^ˍڎ|)3DQ!-zіZ#$b'hJQq$t'!NچR[#CB4Bг0ޝSV#NUxas.(S{3h$vVaȮt A!Ѐ""1W"= g16H*'tJHo8 =6@ '464I-hl+iZHrZt+#ݏMj"沶M"n衕^|)$i_?\%zK#-Y^w>#]LW*}swasVo j/0fQ}.߽z͛ǿwo>zWiji/\6.MJ pp.Gt5߾ͻ?%^~W_|/0]|N^mۗ>#2KčdG HDȅ -|BvV'{>'c.O\6^7 ci>O1aOq;C9Vq˷ H.?LWw'8__?YKtRNl_9#Y/ ~Zj3l|ULB|,ijP&Қ"ttĢ9W?׷ox˿Mt]땫PR''RWOrxo`M1 SB1蛶Ŕ|EZ`qmsE*zptJXP_~wp9؆*ޱ;i̚}HxٟK.˱Vp͠Y X|au}tثcf|6߈OQۇۓElrTn1e $ QSIxjBz7Ĕgoz֮{1)Bk3r|FǤ޷pAVWr)T&Y&诧w_o??]"zoWW ͋h}Dw6U0Mn0@eG]B]wM~.z Gce>U\ [5G5$L/4N3En>ZF<ݧ;$?ݡ6t}C-DSq(o&"Y/__ҭ6J jdoPoK(K'ft@T}7@r]h=B]Tݍs}ggjwN*~ {UjSMipgoMMN?aM+7w 3s/־6djTjO u=;{U4yif/llFDÀCn5y^r]Rendstream endobj 319 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 492 >> stream xcd`ab`ddp 14U~H3a!O&nn?b ~%XP_PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*@s JKR|SR XYT XcawA߅$rejvJ~Be֬_'Tp.?yfymwnߕ|!{Q߂+w@F9~')˃31]oE7|[)-Zkk8'_=oنu \~ 6-+w"9KM[=8,_ݢMN_~ѩ+us> stream xZn7 cNmLl q&) UR Tʌ|ETe32^m6mxxM]nr#kyi_[g&=Zgvqɽ7MxmL=trOL0ƅ oXWvi#>Ko9sqcU0;}%C;i]!Y"bJoKh浪q9ma<ý|(STt`6 j!rO8S|jQmXUOWm!@@!s#Ku^ wU<>`\esr=0 8E.{!Jp6zwcB[tgs5+|t`;v®W;ܹI+J92nh1MMQ$snT5 Ȯ?<,[ mFޒ|O+>D,Vw64LΘbN SmS1R 5톌bkޜRx?eg Evw;ƧfSqo 0314VVc!{+wiof"䓏GW+`⅊^y,Y#F$1S Fr Kޤf,yNK=e b0iLDNyK唠)!}q08YHBP;l5o!򇩠)Yƛ=zN,c@&</bҝY1]Gd0^ITֿwN Bv/Wէ9MDMxJg2闝VAM(|BD}uTkKZ1t&J5S4ŏF#VgFӮMPe#gP6Rldwd#Ηl|HR״ې[ 73GXR0[2DHֶy#;G "n4V(ɸ\UuXs\DB>h!pVt'lA&ʋ=ǭp0.enTT(^ D>d vQ]T9(LOhyF66떝\TuTR5PÃ>aYϰuEiV p,PTH;1(:.דz8)tdU%iUӗ'ER4Ez-rF5D#c(ӶVPyYK0ݶ)'9n!TgP.AsL9Q/ኌOFc|ȄCVC$êu||Xl~ |`xmC56]aB{VT'ZBOúJʃPvkPmZk)]4mD%ڐNͨ!Gon5I034l (_:i RqV|u%>s Uq P˙_`[K.qTQ2浱ҭYdOqN0gBk>`ǚj{>.|:$'z3ܒc=;jxz+f`ߵ4R `u|miS) qZXHaU@Kb[{9LJ9"JRΈqɩڑ7 `]KvV@c*N-|%ח享ɨ#o SצYũPYcע`K?uPHYDWc58`Il&?PχSs` ɴឱ^an|Yu2= *J-_c\J q# @`,FuD+%m:;-s//EZMHEii7]wK=om#5|{룠 ǻgwܠ|/"c9a%s2 Y}=xdCRDu_%oP(ȧ& ]n}ɭPRp۽dtendstream endobj 321 0 obj << /Filter /FlateDecode /Length 6432 >> stream x=ndGr:@R7mM/0hck3j@%nlEnHlCT-"c_?$wI}y}?Y{sw&vo~:.pDI3i8Ur70F]}Wb2!<_Hd߾=r"?_N4j ?7 3l~%pįplŷZAeEZKm2i[/ޖ_wOsyO[q4ͺdI9kJaΞw: :֘-H1 fnOj<)VB LFaiq>.+:':ûb;܌x_d[H<9 _汄- ?q}<6A7bpf<,Mߗ^d(-ܞ1|;S ^+c7,ͼ=GJN%+_|R3O^v={pSʐ#_$38-\E@$R!sd D &O829g5iA8}97$ &R_!|m:+HgP7]#s _ЫtHQAtϵse9&IK 9Yak.#:@VnNJdm-:~cD|/2KG(W2|K4$](vI }ߺ"$b@6&~0>m>V+D͠&4T`Z) ŽrCHEh$zqe`&6}I<[`.tq`q"\%%cp.yB _q=.]?d@}$t <#R9<`ڈ+(Iz੝azMgJ?Y*g{y ͭ7mn$]_\W4DrR 2I,G5KΩz_4yT70phJq9[Q~s_K(X^`ʔNMmU<̵m=_:&phrw˵ZN>`PKvB|Qo'J]srheS3}W&(7uti &`GAi=]KW(BB}iw fg\`9 ~Jk)PPhHr[mF+!B< fWq,?y ) Neɐ' z2@ϊQT=Fd n3ɺ3293gՍxBk qWZ-zN)g>t>5Ēar@ @t+q !z Bˣz932:Zn4 [yBv;G1#PQ"5\.y*ZhJnJ~_tD;N}&SUpZxa48G?Ch+ɟ=!5s%x&Q#a^ɒk6&BUq2 MTslj $h 7= )p"s6ZGҕMӂ[0=0p+U~s}.&2zϽY&d4|)uR(,äSUnMvsj0ꘑ$j76h} BIuR7ўj"5\\^lxkh LXR䥜Cc:0W9gʤ 2H9z8,aBDMǖ*HV!7w[J9vާlÂFQ}"H'6@!Ԉ4C:"P0]f:~D>mk \ķ .eXygP9bƛm~`4Xg}[:*E?⋿!퍪ߪ|=ﮬ\eMʠS0VHwT|LA3G]yXBFrXvMcP;P V:9Pm&(Ǚ9d] 1hT쏱{(|Jߖ@bRSFly;e5s`Љ? 6ۧ)9͢Ҿ(4uλzh)Š\霗֝-1.вg+fϗ$>W="bi,7Df9~x&:H:>=+>5Q/q@-a&iv!58yx/XWTV蘥o^VTjR]sR^x „IH4fF|[@0UԡȲaRZ1e74a,W,X}M9O+GIS0WZEb xyK V; Z^7hIQݍ5pl˥cGL,˩:~Izb4FBy,0yU޸UwC4pQa GgHAJ174I䂡!~\\T^ln=]&$Ɂ0\:`F9}9VjG@b9V^nŨ_V3eF#I5Ji=2Դ1~~e; #m״a7v@]jYʩ9fnOETuiTv"Jw}Acع6 qL;b͡ŲaS=~hyx K1̧8LD@?|ߘlv@'ŭˤ*| zjC<>oιQҁA{a0`yo~hJbfv ߑeuWt麸5%e| LM֮U$ [ϱQbZEK?P.JU4ݘI;HK՜U`X"D*(q>މPZRM oH21ݪP7\λYabTGJ;GZ< `~!ȗz0='pDA>[\}f1drC4tw?98ypO(e!іr{!ZXs%/t Ȥ|g$0BS!eYb%\bĿTʹ84 ~ CX=H+,Yot/=Ek^4(VRHCH;FP*.RjgMlrw` (&e-Z8,hp֏u⑛I<"⤚Xkc""6\Uƀ0F-!]RRrhU+' A ohL~yxTT.)MLrE:"g E`y>(\6wn`qWJM#͒;86 q&)tI,99OY4XX~EQ=1>aG`iqb~{Mg fGo4QLj6jDU_(h #@ָTFᰄC$!,f.V1STfԪ{[9F2EKL^RFͮe-j*f:MGt]=Qy=PdUT `^LSGN7]KJ0SNh )4-I4= q1xH,A=|qfF&Y΃%F 87PS͇NQTmGEϦ"$$!(GiKOi?x¶c;ŷ$" !F񅂏- '6`,&1wt.SN3SMAnU xh#:6ԳvU\-Zb_ףkX.Jײ؜/U!}\+oIb6gu#Y f4 fڨxV9i2!7F##uX>K6^C^ |=b {7{0([ ̠+rbݾ0SOk}Z׺tS@|U:޵d 82]q +W_2,H^>ƢzRXqBI/ C&ͿkYCSn.UAųGf4 %VwΠVn)A')Y-',3R=.OrΔl:7/_kFMG+-9]Z]xGc i!-GurtBw@=͵gס ɷ$f;)^k{ٓ`Ir ?4()X0̆&m&c>ZŤSݫlLE* U~,P[n/8z lmOk4 D#BcA)>\ (PP'stgW/ xy[s}TNTȪ `L}/u|g똞,̈J{T&<.>JtZТV [/or/nQ!eɮ-4teCsztfەZl)!yyB*9uT6=eL`epeu^s6"-Y@8^ NbviDDßv9G.`/lTA ]}f^xzd7PcLt\ ! S#zQq= /1D`='ӎp\s:a)׎z]0IA֐e|c !<%/VrӔ$:rIq.|D|Z-!.#<]endstream endobj 322 0 obj << /Filter /FlateDecode /Length 4959 >> stream x[Msq#GM ]eR2bKB @xWUݝ3vlp1S{~ }w{\=z`z6.Q>OY죋vLm?6:SV>čܞCrsqťPrUPՕ*F ꊤjuRPcPՕOVRՕjqYj\Q揯a66ϊF[$Cڼ=|-D|qS|KAwZ^+{x}2ASZpQu!!Fy]P9%U]i=`+JCwXW$U=L$2 :[Iad=E h.+x%{L1Qfp%YEfJ0PItԃu L>" LB51aXoy\5HMT)Wx4% Lb@l\4Vyū>b+է'ćA'=c{򊍤BY'Qm %\2*U+ajoC^H* g4% V&IN vRJ22 Рu0xW @l p0y3f(b0)\+mf欭4:IgG01Hp ?CQF(T[4εF@3E;`1N;Dia_qի @͌A@ `8cM{D 8jލK3bu7j=D>z:&F 8Ѯ?^.5= ^jP26LKo^0zO&:mDv I ayXE iA1U$UN9a !>wX v ˰k5#J(t #uNQQqrB F<ެbkPLaأC2a;bY#+h{55!>f[;+~4k[mXʜ^:؁w*6v k6s`Vއ̣`_ɧQH awaD0"U24T2(l *v{:ơ"3àOD#{Uz#4=a_*lh W7 }S1~p-6zCđhDЅWN:q'JFn G$CvG8f8TN@ʱM T:rRMS9<c92kr!q"rr.:014.s9\Nq<Ys9DߌXf,Hl3CM;zj!ɹogs9\A XA\.gr.yZ3ζs9&f.+.5s9*KɹŖCMs9Of0=y||b979~E?`)ƫf0v0*?I's~%N4ħf4G̱dWdJ%U?M04_hOHN?=Wʿ?} 78P%M sD-@|#AuW`{9SS8@.?]h,S6{Cf>KS>Zwݽ6.y}~o0]qdjs>bRxWP΄q#"X)=\_nwwO7M6,`c?1]\(FJΒc~I6yd<~P|P)-{9!H,`0cIpq&)rIgp}at".QDM12 uX:|@M,NZaI{ğkd]_~ְ+atBSD=g>8A}07υ|%v09DCaOI%s4hsoqa|E} YTm)pdO!WU-PӲuoZ=◌bQ׺Vf(c*r@VNk!Q|{As8L.HmrxDv+? H`b-j0`س};*9-/F:b?nfة!7YbS;FkWb.񋺋hh$LOP=ctK+w[nΥcI+#9im'|GI3XYa{=G}T-[\]*ƼYCK5mܪP|' .gk*(wH}v+E,*9 ֙;,aPFWk?ͷtݰ7 =7:WÚ=-fUQG)WCGJ,%!G3CM|lOǛcޕnJ85џ';d7xO[7){İ9et TztW IDFw0vÝL-[E"b@'s=Sœ T Gw*RO%V"eB ecGݡVxIYM1Ӆ()|aK?(ye"et֛3BGVy,J qD eьU"g]%_ %2-O"J5x􉟴iaWpd]̩k$5 I]W 7 |C"b)F9x?sskr2gϾ Iחz%A&nsYLOw$ 98) Iu8,]<6mǛ6l_}Z /K=龎rZ7:9(GaZ.y慭}Q2L]iA_!=rSͻ"R}f':yfB3wUK<E#OMy؏>F=d01LY'v Oɾli9|XBb7!lVRAU9ŭRxqT$N)5ь`30JR*JY: 6=@Z I}Q]:>R<%@e4]YysюQm+Jy*?hendstream endobj 323 0 obj << /Filter /FlateDecode /Length 4911 >> stream xy #?^ĩ|Ĥ+d[].b` pn^oaL:>33Ӝg>[ƌfYW{/cOd`,KN9% xvui{Wv\&p>{ ӥ0B%3M{w`^qA8,{ѥ(o#sGPڕn"T*u~#A-/$wv<`@ < Wd\Exo>K;(eba١3&,s(2?WcKJ`^q5)|6c lƚ & ?CTflQy+˥Vp0jti%M4]KM8S]J)^)<3G:?aȜ 8kW9crUL'; (B瑩G:恷QOD1ºR>-M[/ldZ @ё kCt/q?9Sٕ\uđ ?άހwC/`Q K#-~(Qc+ 2?%P 4jQeG?SiH[ ny&Z\}ՠ`jA~DyKhMQA^q= ⇄p vI3` aof*OqK<raVmz\b`- 8( 0ZpT!v5N0$v]/48Zܧ%pS80 k7`m}%n:TaGUۖe=4mzӠv ƒ MzM}a NHrڠk[8 <|TM#Wָ3Ģn7 45MP"|]皽{C'Wf%|Ղ]HoJb`SnLɐKTq*JB sUA@T%|@ɏ =`l" z"RpؘOPH9i5 |y8dЊy8v"9L+u)'tRo ^Z m䘘tC7T/eU?ypыnvn:xC7~{E1#`f2i.N;C8,PULrqTG>b6^ o`8L1$bhLUxVh9w^XߛSx^ ǭ28Ihm (&"/gd`.هzYl pыLoXmI]P8C4@ D 7<ĽiFJ3ԢPX=HtR |^M9sZzg994w? '4e0k0Gm87.l@7鑂xG Tɒ3=3bO*x<-X1{9/t8 (Һ7\[Lx,udoLکM+|T2DS<$ e%`O֠d^!5NtH=Lqt 7=/%MbIqJYP4~/S8y9V2LZgk?^:՞6E1w,ze֍=He+Tl34 .٠l7Ge,T Du㠭) 6uz']lXe;#RJh-y'[ӮtTtPQo{UPJyROK`i<. ~N޴V'W'Cܡ ƴB>C0ZTJ? F#QApa9ɜk9$ P8:#*:{MsKa*/v˴Vnb<5Tn5ARHӆ \k#˭+X0ʄL xl'5  8"ʼn<8 , ́g4@ J^c@ݓAO1\S<3/8s.IN+\TU!+y?[~4H-{Or`C #^8/'ѽPɷ8*MU&RwA0Ȩf J2^ o• Dx~g@# s ϳqA+E)O&ԗMQ <+lsߘL;<M?p.<9ʸ-`󠘰u3%T0yeiVŒYf\Q>'"?U7rꛚ+Ra<ԇ5 t&=WU+&i_XԁϻfvOk.B\0y* |ZMCb2y==I@!Bw8f *(̼0ky|jE`1ow8n6ۗeyxx!L5ns"!ӛN~~x9Y{H'gO#\1K>T2M SufTR5cN QKbHRpYW OerJ-MOգ(eC HnHIa">l Qؙ7[`` kVfݑNI@B<0ĀЙtu}v_WtiWBc^=wu)[ׂ\*U #ZB+aFW/,\T(,N$Ճѡs D,&=x<IOE@QB(YⲂ-l3۲9^_l|l]\%Xot+?2 Epïr$t6XΉ_q ^*ZT7w.!dZڨ@81I'}iK.Mj?#"cQaځb8׃ ^ `# [bGʲ:iu*Ű'f¦!8f|v s=7:dS4)]" cT O3m03[%;avh٤p%yqŗk,!0w5o/;IPf0&ݎ7V;3!Dhn)J#UZ|6 ').7R4T6 Bӌ}_T^rօF١gTN-! |kXnuL_C;P6ט'5g9B$l%co^ԕ;u[.ZUX^kU5A@,mbsc|eF SV`y?29XOܠw Ib/̬tk')@ x?2*MfPT#{ߚq˞JRT<3gjQ{̓8K8&U1tq85BӢA{O6O4Z YL,L2-5UЃpO 7*d&SbAP}{!{ahO񮝑!)\)6v+|L\qƝ$4 GM5V U\<]՜22ft ssPxA1 D/O~-q/dP kB|JMs Ȉt/0ʞ[jtytP&65/z^^ fQX/n'On!Odcޠpp}w a̭#[r:U5lX7SeBɷ3K.# 'tJL`ӵ6wᵂ2!F/.Wz:MX=ƃ^KmL;>ќ[% E5\ЕZd"1a͗fhU.ҥ@Ȑ2F }mY !uBd+ᴤ^ٽ|^Tendstream endobj 324 0 obj << /Filter /FlateDecode /Length 3116 >> stream xn#Gnք!}(EQؤuчuV[7ۯmx8YkolCϝiBJ:!']/d<\tAIXOxcW U%RLn/V:Ѳ$Љܬ/b:R錔bomLQ13n آf:JhWEp:<"OӊЪICdXB@7ҐXRwU(OLCK4@ /GX*CդvHWJK#ȁY}eYi= 8"Z8,7N' !\$qW2rh@/px> }LCP4JF[8)Cw`7]HއBBk4D݈{4\`Sռ  ۃ:JW#?̯CqQ=L뤲x@GD*Rb1x pLi0j+8mlEYkM`BQYZr֞JJa'O3;ǰ@3ME ܧ&3K)\#nB͵y*e)2hi*9hHźzq)'?nӞ1yp[jEvY +tliP~j4l@;O `hB@+G+h]|߰C[)(lv1V i] g}X(tsÅO('rc!j'RT1(…g$'s4St߶p IC RCY*ݾ[.ۢr$X zG5?Wח;^ G5 sf hIs.upT_0 T)P,nuc&zesj+5Bd#2yY͜vXf>ceaC&BV~ fQ;=z/CࠋrrVoqHpTǮ#7~ζupS^IέטU`PbF*GdeM/19f׋ly/n3(]N˅y5+rˮawN1FsQ 'K a&! C:ih8mfdD̓Ky<<5S â!|m(&ܝ܇#excx81M40^d' 2vi IsgqSVfjbהꚦg6<P}sPssO ] |A]w͛$p<']u,@[oPn朗^Rh`5LtWs'Qq& *83YK;ǼnZw|mNCt?թoq{j >Rg jIYY}7P.RrӷWMaR~Ih3i{GnzӲ-xw9\MM-Iodu%i-F:q]%yp5#W uzuo13jw/'PܙVapdnU=&no7oJrMO2hQ\KGv[*&x=Zܤ,ƫ2S \ajOV~p\g&7Iz> stream x}Yq;a`kx%XZ~$mO|ԩ"[q 0Zݨ\"c%6}Q_OW\D]oOtz |q3ڻW%M٬/-:{y7WwWW*t}gs=|07H%*{}7<KxT߭?~d_-/6l>|yO7ק6Ji/}F6MV\#xų/R3>OR6eKgn3;QCkEN߾pxRk_[_^AO]2QY9ܖWX8?.R'};UM_mJM“vzy).x[aO+ ɖxs]j5+Gbvgg#ZVޔr.u=uRyt\IШ{nսvsAƕ*0s,&Y ^ħYxTAVk@m^CsW{OtTia7S~_?ǙΆga=τ '_WNvR86/Ncōkef?QeTa˚ٟy6gk J'I 6C%#˂v4muR5e~\yco9٥GrWYz0)S!1hFcӏwfx4CZmօsۊ*wE fz2}*]>:9{7'kRLS)jmHQ&2NhR?L ;>[h V/xWH+|xdlFAKWfoͷKz KBp}>wf#^H4ވbm YM")ʜKN3|TiR 7|7٬-C1[3WC  Վ[Ycԭ?߈at`9Rg`ǩ7]RK_T@]N:&u96'V yaHc-Ry'}Br+q_kDsxs(q:ZZFO C+ey'OdB֯-]a r"Ų͜?-7.̉'I}ZvKQ_|2[S!+,j 2lua30{:o[&2#׶gRU{#n%ܡ: ˧l:1& \p] ?ֲqW0},kp]LڝE$tcͶ2Z __-HvwQ OXˮ#ڭҜ*2k8F5x? 7{3y|!I`e̗?Nݲ)N]ޚ \Y8/7D!WW4ϝdׯF:7~20MpIq{O*%1gIп0æ=-Ulbd=gw_QϚG;8>XEWxK4rRRXw%z)=p?d힟f, )yFOԤojeHpz$44@zuL;<7ت ?R.M"fduCt=dGjJw^(Z@$vݢHTY4י qK{<*D~W&U ElرU)~ʔx)SCϱ3qt`vв-TNPxPvp8tZ{+bVQ W &͢Yf*k.I]RMӄX^==Au\*٭uHy~^N*K5t d0gZ"~12̑(`_2U;+iP l]w 敷~x$GHg]< @IWo?݇iܼvo_2@3LJW'!shSآulj_[>abo5]cܜu*r/wOx+If}:):a6-{fj]q~ݳގ$?yY q_w!UkT?$tʐ}X#,D&Ssߏ.M\yogtn*Mǹ`S?FB 97V 5ӂKϙd ˻ sd@+˭^kT 1) s>1/ xE_.Es熦V&7т:X!ҼYgVQP S{S_>lʔr1G? |oE8b~56#Klz}g}E%7!?oEOZ-IEaO_us`u۔ɓϷ&{YDUt=e]OfRIS+֥Zߕy씇2⁾+gȯ=f3sk jH03G<#0-mbGgn̾FnRv?M?܆Y)jԝi]0n-N 4afF; oO2vJ|!g#1*4仇?_<6I#>!C_m%~B*,z@4S" nDՑAE> 0#U:2QDLՑjmA)#Kڼ .lZkibw=묮jըyXuǒjW`(=!&bC}KCLfDԀ2 b`!Bt5`!jDSRw͚&i3xC*lOWulV o-:o;d &VgT 'HT.UgPz &'.#` 0˦W_>٫/ysn#[v &*[oWw#ɄLJW/=x@%1w|` rMKX)U]{ϾttԣďbU\JuT7GkbV&_NMeu I 19Ind@5bToL~tN.CV ;[2񈀟 d`BRΝ!y  Rg2HI^H J LvKtdEt%JoXL:m ļ"VK *$!\O]E[Gh-! obO@%ݵE}[-v@@ӟ 􄱌؆iΐ$ġHP4&\F /G]cɯ ]Hc$" 6 $Y ĝE"!z~N@Ӛ7z>FCV!ɦR68mM:1(}T4'UGH6-~ b Fc$q5 Bڈd.iֹc@BtuT9pPFflU8H0ؙ@;@ h=A9RdāM_!|VPD(C QzGOdJ6H?AE @A"7H8掁ʶG["8q6ER R6hu&ј&MlAì7ݦLS̴1V m7ơ#pOJgCR:TjG4f-ݞ\I\3 Ǖ$ԅVeLSm|Qp +:_h4n\10r:Ҵ|b}4FrmBF"JP@@HWؔРa8e<ɾ_WXLW p;3ҭAm ,?:8=Sx+5=TŞrM:;pv4y3f_6i=^;#lf CnX(FXäHt+  hOjL4MO Kȥ")1Tc"q܆NB^ǮXH0#\剦D7$ͮS7I8ScAyhR/ Ku0L7ЬK _aAjdai!8tpLJ )na^Fڢ[hРp!Tk B̩f w+MlȁHxb;&×jaP msslU&f_{BCH˪I9TIl_X)vY^h3b5f{j ٬MxI՞6@Ȩ) n V7Fb)ׂTG/x4=ۘ#T: ґ˃FUxiDLJR ܼTM (,X /d 9ƫLY֭W^fB9HsSa2SNM6^B:@ŷL9rw7WS$C3!F[T#*-/$ /Vi R%Xb,;B_V}\}FeU $o+ɽrNTmvE:nG3LMoU4_ <_yy⁨1!xNseY 1[ Ʈ Zb ׳f+56hZ$gHi\ıHp{FpH-bknqϔ@z&yA}+B-puB # bJZo,_9eX"xNɫYvM7\2ZLF/6$-V7;+Ÿh6 }FSj5pҴu&A4,ºN"IU#;TRwË{dҸmhzotD@b 1 fE85ܢpi%jV?ytB\ 4:Yz+ή3Is6>Icן$Q󾐰їp#̂Me mMs# Ce6fk!4ϱ8mψ_:8e֠O혙hT['4r~@|cFϗoy!N[D߇G9 iFτض4\4uL=/ vql g{hPLc A9N>]3 ;&o#8WL>ڪK_"`j C_aMh1_-0 'xslz qVC#[ ;#!obM}MɁtA7ӴuN;a]hM9Y4mDãWhuͮϷ[z]c/zq34׏;I-?Qm 0w /KTklLg_Z.\@LrWNDc슰>ܣo'T]ԗԻё~pc(i^W;y+TG2u\N\ 8^ye`3D[$襰n} <6a7Tb֤i8KSxC $!֪L֑r9~d>6`'`Gi{h|#WoKPy~XvOپ{G& ZI .Ie[Mʡ4 %:;D>?iqb!')'W8-ї;M8EJ$#!҆MINDA"ֵYUS)x8`W˴:>:KfD#%/5s2"%Bcҏ2C]KPCq/(G2pJdM$bS"Ծag]glKBd~sq/tJ%Lޥ%6_E:㋕=Jԙ#FcVu ,DѪXx*Ƨ~"cᅗ=.4eV ;b#hy\G'e $<`Gr7U2Iiɨq2-[ix7r~JD^ _( B2%qcEt%[\Bǭɢ4e݉'ZU"[E(l22Hĉd yct8EjK*A jn5gFF޲@&I28^+O> ˷\G'ga,j֭yS"[T[Ɉ&zp"Jd HEu9 6tJ!lFF`V90\nڗ c/ !o"H Ce<. LFV͔4?-I ! i-2Bl!ʱtH(j5>SQFi %Ȭ{,lB,mA&V״h/-S][Y#9ccDtM GfV&8lINȸM8*/UÆ22`{(GH0&=D72(pf=SNLPbQVp\&4q_x*QND19N @&^PFιx2Q\6g)(=WAod=2{XٖGJv%:͈FHJ /t O+%\N#(J؊GŽ-rFD+<"˿lsd:(iJɳF?El}݂!Ɛ*Hu׉ Ě);kl%72f"eBzDy ϔ#ﳊyK;) U-fBq V>!(z)'Mq?=2#6HzFYYH"mck mWZ]YtϘJ{a8b/뗸ˏJ_!(™<*g7b'$gpϩWOCR@: ]#VPq^&&NQľȅɨĠDj]A ,lMg!kًq5/żZ*F/~6!oPʓ[KsPШ_0ë#QD"Aq!d'} 1QK/sYeFq~<&s@,u_Ͳl;ů*^D)# QfF@=\gI 2{/5-cI֤ABt/ddk0#&)'n׵;\Gd4 VNȯ1Fe8}Y<\ʸxd2ӎ"c Se2{;@Z0ӕq.1:HIZfZޛ 7]1Ӻro;} r ytxp=Bt^xpAB9AZz_!: Q[Nw씚"=}>ɹ>g Enp6R|9-ҳy}pfOg~@ϿKh! .#=S'6q|z f@8F*lzu[l,Njfs@*obG'798 {}`;- ZTր5-`Mb%ܳ`}˝SMΌ# 4B SLen? ן%n?c"b~ vojMjmS!frTޗbX{G^rbP m|;i..}!-ͽyqzO'=*}e4itGm[J]egf+TZs[9>h26ܑij;#ލDfx.#4I1Cf{ݽpe ˿M-'e6+G5;b*֮$:dedNݑ^4 [0&sp䁌Zv7o}NTM{Įy5$l33BCQ3J|Is46|1f@ V=&;B|U,N[-FBaIۑ.Eg6MrZ+ª` X~o(FႰoű%nig:Za2Vs9fչ#c <ԯ4z,~͒t akg~k3awrfa e  hjBL{ڊ)0n X\}V;Y+ۙn gp-&p7bDHoDGxp Y2ӄn&W&1„ Zi* i :H4&$1p aqu3v+MX&/q MY(G;x&ֈ@;Bֱ4d}ɕ4X 4[ :zWb,@NH@R 8 ۙ.s؄uÄ47tq<]/i r:³_xJj#q8:HlQ<3=hX" [һ`l:c3@#T_f$OG:>P:fDLH3X/uUuꁩ.FS`IZv hZ]X*Vl h TijӐnuXFXJv7Dka)9[=PETL΢\]z`+'p.?+Wo*ek]O:D$W(%J.3,?qN_!͈ϣ+w?mͯ%@<5u>e<:ȯZC )^~~dro~xD\O7o߽}Q^|۷]{_Nf1y1CՐ6/R TIif *AOT\RUG&L:2-8>3d c@m堧&NlxswܬpՊW~ q9+r1 Q"I3.ٚ'3$ʕAyrjU&Mpe˨TA'XAӠ\ ""'-h 2,wH\=Qa'([ND葝IpGrmAˌ K@HFfZVEӻЖwŊ.9Y4.UȞaj ٍȌ#j@Te=EV}OY/P~GtG%zĥ2Ŏ6I_M(HF{I*Cpdh.nc{DqdžL,pᮗ rˆ^EjPDt3O(w#>"9]nl6t8K\ض(a]%/ÿ \.%3ԭD r"}sd wۉn,Dd̝6԰CH{\/SSTn-<\bX" uK$REZʶEb@[e+r"jJ w1)VS-CLYn*[4H7r!Efp^Œ.3eXW'\)SbS2b۫34e\)e^vBevIʔ(?I2z2c͉ eSHYƚS- ED%)k6ORl4c[sXՖL&˻Q[Bq[9ڢ<%ȑ ŶFL!tcM*z2zq0ƶs尖<0,sX^uu/Ԥe2,~'lA_eq"D5khԖdK߁n(7M ٯ= dlH]q>x]U$ps&$PjY2F!ɵ&>@rMZ&k|p!O>Ӻ}8$-i CM)k2=FD2-tIAhSȱ~y$?B2bV$c$b(}|Z6oOȯ|ӝNsXuH7.H~fi  "r8BM%ٳ9UVפH@ %n̖V,l K$bErgɃ~MSz[ !e9Y֠64 [UIG37tkվs&H\l9B'ߒ:X=Ń*?:5#R?cAS7א&W^TIÄol7/sfdZ;Xٻ;iמz$_~¬+i1o{]_>{W\_EԛUI-{IkI u}ۻD{MJ2 ݷ:wݽ?AI/o4_OK s ?N[g?wݧy잇3!F+OY_|b}>Ojlz~sR˙ݞ栚qқs5N_M O2NPSݼsMF詄]n;endstream endobj 326 0 obj << /Filter /FlateDecode /Length 10729 >> stream x}ێ]Ir{Yq0~Ccx$ YfhCYn ŋXd;VDdܷ"[4O-ΝȈd.dߗon럢;}x7S 9Ϝ|>=xk7y/7bIӍ=nSm9KMT&WCnSp)YJ/:r-L7vd(+՟RJ:Zʜ1<'7FSrŝ^'*8.Ӌ77ߞ.{~/5mb .ƞ]|/x/nR.ƠF^H6_𶔥RX*yo/) (cֆkU_4j:k. >`h|@ zvzndždʅVõ3d'ŠB ėD{ С7=t?ً[ *t9_K_͸K'W.![PG_Ul9-dANOR\HZA0X{rkEl<%z]ݢaps~58bmW(fHK7&OmGE&i}u{H?y̧d )2W,5$yN*>0:6]Sjtb$*Se無ϡ'V;sSB2_aQ7 eQ6FG5<%,5M̜V$ Sc9dY&bJ~w%Y.rBۜL$.AX7sw{Oϕ3C M94.0G)cRB< YA0'$526s)c;#S8Y(S!O5YTg){]lSj uiğz:E[g8T')k})mD{l0<_u6ś;ףnֹvCXΔ㭧\_-sv)Ӝw;k(Wrܤ%9+P:KNZK"<=q F;~ώԛm~Ms}sus6+seNֻݵdeL N\0ιlI5OczƮͥN9Z|?@Ok!xYfUS"WNl :(U`ri[&͊^V.a΁Cs)S߯pW8e*S']$T3蓮Ç8ܭ{BI7L޵zFd;s9U6gȥ#=ޛh<ÿ_3QgpErxWh: |9v 9ESvð)rL!P0N9>_5Cm, z[ˤrNrtKgR)J5I*mf n9.]$BSvJNqұ~:Ҷs8^Z0ٜxWhcRs,N_ٯ#;$y~ע7 YI/v[vn>+UMѤuf9Q)+ܜ[}|rwԀL f䞀`AO}9xr2;e1"#Pp"{daĈ^S _ E"#Яߘ!^ʻZtOGؑ<>@D z|rw8.  i>B0A#|_=G<;J[4)8x뛱`wL-.˩H2$ GlӷoY$Ld#FTƮDG.t]5/kmIsH"-pdx#8|"0B|b2"{b{H1$DWIؼX 2# $VCh'!"glOVZ$:֖idd1V;1T_[EWKefA2BCxpV{H> Zug4"obT|‰}Q.J?Lǰ?E"oZW,$n^f$5[ x "zϸ%RaOqOjX*hH|&+PHAOj e()i|&E+POŵED:;R Tl()(0 %ZcG ̑YS@t"N f$[ȗVUIU)I>Hg$w$˻mg 2'qGpSAH~`BV^(CJ kP w*}X̷Hh*-7A$@mRE>F]j{9AYʨB.nH5>3$\zb&@"b"@ w b)6A"$C@#>kU`,:pXٽY&$2_IHme*>FyE=u!O`8CHV~p:Fر[.p|gQEH%Xh4Fp9|ƅ(_&$+u@ (͈)*Uᑑj$B0 nk.dieH{,@UO>0k)LL mxhm{~J5b̻b"Y8 iD8v :7O> #Xd05BFYDI4j6tT:0 Q [.]T"ՠYHUڮT 4&aҼIɈEz0p0sycT)("-Z\r+#Tx P 5B6 L"q8F …ceB3v!'.˟˲Rv!K#$X͢nxf/c^CW킣Xu#FVd2$YC4 dVqD'XG.T\a>j)/*F&Kb*쇲MR Hagb. }ZXxFgRDGYaZd@ThG!FA"bϭ2%;"z7S%žt] bvDy!NSQ)yTC*%Y@T5Ta*XABl{:" jpZDb[X -;+'lBɺNJP;ZFdɥ#bxԌkrvm_kDb?iUTP,IEg*4'b%ZXAj)] b؂/yi(`?aS=[zJHk%4-S5fE:"5Yv|V"^H(ghȄׇ"Y)djb0.X-#!cWVE [PXQeഺ_Ǐ'!":ƾD yb2W +D L"EHH&|$8GZ`p Hƿa(4)r`@ ~~X3!7^Irx^,ѻ>.dmȀ7s8$|Q:Qڰ"YHpX#$tWښH8)HiUՂ@ZJ qIEs0/UAJGdُH.֣~"N!gv/E%~C<HSd jo (F)fwA-dYNJiK%dDA6IHU1p" 1VOEc' Y! |/D_4@l<%4;")xGZTù:>' k=PD{N#Ssp 'h1"&~T zKD1"f >g g_9xAYIThB $Cv}EL+ !eAwdMqɞ#A[h^uK@t/ʜdӟ!2Y4IhJQѦ0@IwVqȬd-d"+3Bp\) D@hP,HIK&@DG ="A()D_+"E^%|&xW$ha@]!#2p{D?}T]im=jpУ6 !bEC$I0Co,Jx^YЙb5k-0:BQ.W0TCgFbqЭQ.mz5"f:ScEow0EM&$(bOR.U6ހ hf$fp$J 0lļxN kp/NUr%ހHZB鈓j@1k]-a`גhk#(IX^Kx{:"@ѬnH$k~om7 U1Һ,ўG D2K–78 h-:WBRw3elܜ a~Ôy˭1"drzsqGQXIT"΀ψ,=Fa^;:j>S]ϳ?ݷs>3\{o/c>p{PYt}|pi-W#P^%B(s] Gh0N\)_kE{ uAGl]iz=wZjۻ?`(H ,i{z:ۍ}8L/$ f/$V~D*ȕKD7 ]]-.{-)*'ͦz ('bPE*vgVz-&Q/nǃ܎wA83Eiѐ>Jw^ EPض6NFNސ#>.ɋ|gm~hB`<6%ΗI{΍A+i{ 5Ug*ˁ(.jMhR8dHyr/\*A?{elGAu7߉ML-vh%al (&|b9ie8 j^FKZ-ew%r^j1א1Jgc"53܌Oڼ0Be,FҠu`s:g%bj VS= iUXԧ.a'̰Xܤq~DM?QcCy4 ˈ#xl=Za'L@)2pᏹ5a9x9ف|oF} գ)?ݷPq1k IJ|;#_*8v)8*y^imVlWLd-qzqL4߭uѽTgZʁu646s2]kߎQ ~S ଝ]9$GKVid٪Tٮ5qB'WʮHyۭq]kkprM6[3*v5ROd8pfDC?Mp-bw/`uu|:8y5֐|-]G J9 "oXqA35Ywpjh4~/*u8+0 VefÇD2m7|{WU{>PyACJ-5<2witcXo\g>szs9Xhay|~7VWWbq7ql G)uAU&848 +}_ %gNQ6] ZvL!m;W[". [FӶխŹl z$+3 mwE5ku^#.>-2? _CF陋pĢ cK)oߓǟ,qCJ, VG^]9,>N5-ݓH^0ft6ēn'A湀Dǖmr:*Wj5 C6Q5S[#޶n)eA#}zFa4Ѹ6J`CkD-{Q[QW6qDv^R4,x.rOAnʁ(fWA] eə - >gto}{.6HZUsf f6N-v~1.+ tZTVes:-s*y3oVg̈́YY"v.~6b7RWByW6ؑ9JhiEdK`6*1X] &Qb{ .s؉(G(ggM?C~1)䲉,څ_csna|Rbt@zoƜ㮭?k0ʾ kYD't}J4 Lshw)RP1JmIzԕz#\֣Ƹ+G=fŘU:~Mq};jo Mdw僽x%.~ =)yU>:TB KO喓]n!0?[GtSE9d*G94U28 3Kqgܮvш0s56kI\9vmOYb NdEFmUIYDY;R> Z&OrՂB\a^'gqA\㻮y?6-<.PeG^SK7$y-j@uqߋ%icY6[L[5Jz2ȉEu˃߆zL,mP8Zѽ C٩ (>gZk`3kjhpW%YֲN  6qiЄOOA>jG&ȋ],[+fNXIjYx]Ĵ\+継lrxG ",3㴏+5TNhXw93>3 k9Nq4\ ,kZS᭔m4wF_?' M8]Tay"SteTLc>9> stream xսkeq%FoHe ~=a`lB!d.[SUMuUҿwq='&Yd yo}#^;bſk?d>=f)q~x0/o~ʧ6=$bh}^oj鲥|#ۏ?~W7& }kb>(+LOfNJӧ*>ӧS'DILtZfsq(kvi%?|SFތk֗;?<'8UO?#_} n.z +GI2;__tbSms6ͷANERReAMY?ׇ=o}R:-m =rI]F1 Tr>\7 V.RfsKmg:p{o~8 "(-NFL MT@Yɶo2lx=_)6wɆg/J8pP#:|Ql}·z{a\^7d ͓l91efk9f|bK>+M_|&!mbbRb𭼥Q/c#vÃSd30|*-Ŷes*[K.[ YtJr[ jت2RlMpJXi[ $SŮxjN[{Ֆ9ɨekAFiq̹lbOi{4~}ۮvp`lj)lCP=>cvIq[ !Bpہҋ8|R76:G2>#o'd~:*ǃf v;c3"m8( altL۶?:d2q5QL]͵|_ݴ(M=@sz_Qlu5,Aw]:[5.` 6cXP5:l%8Vͨ5\7t4$hR!pgǤ5UiVDiKjVƲEbg\jL=y9f7ad<ј%`ht5QC5 #RzmQ$fM^G4;4kϗ p;Yj5C#u,nGQ`h4>u5nȉ::45 j7kBtG 9LMё+;-F0nE ҷmaDֶ@ftz1l~VˁլY$pD .c-\ii8yMs 1FɆiW kr ;(5.p7Y͢u«Ā2e"&4ρ-piEH׈p9Y#֙ Q5.vt$0%ڎrEő>P1-j92e(ρR>Ǹ9s!HlRp x11Tɱg[a1s (Q=|if&hCyiҢrV &f4{\1Nz^k(251.1\;"[Ubcլsr\:c>G@4o,QHc"HQ &f7[,a` /*U34U#:#<l"P&&4` qCy<B訊\?1I dr=?5gN**B4 2f9b\  e4cXc9:=GP@<&5Nx4'#iT4B:sy1'V8K2@pB04w'n[e9kvx4&5v^swlv E]pUz!*aT뚜M G B/*/tLjvd%q15F:LJll{jl^2L40)!JJ@L޺kRdfxccu dO:ckЉ^2Ѩ E RX7i8#5a~GW+;cmG{D3j-@H+D/SV#;jLpEVj!LLjvx8Ʊj ! ;U_6f*.QtclІ p<Yh=3Q@DeY\CiNqhu'uj]$ 14s;6}~YX(2w׸3.; N!/Ct`,pJ/fja&ޱۦSY1yH$qAk8ݳw$w<4k@kw~݁f~јMs=94̂㱸&O}yv#Qi86pKդ.|L;/7ͅᑷYp9Eޯ:l5ijHZyDѨ8`ض!ző@gƲG$1l4}7J10l/Xo@40(63RUUcC$̔# jh-y4X`LM41m: 8Pl)]p$a-paAiۀ&˛n9H86Қ"mpGpVz尷1<ە"0]1Oȗ% aE(6pˁUIý; Rrta`r)BG9FH O%:$뀫.)Gzz@`n^!#> n^ѓs1wi,uݎ Z? kq; ] t;W#ycR (p ^5Np`9VJ"8Z5,hurcDIv 4[))ˢ^Mf4/ ïv >f@צp:qh"[ ^4~H yYR@ zJ:srC)v,ϣP40Sp;twP=ɋ6- kuN#&MTJp:LN4AOr$w9ߜ,b9)ew:M %C9ir3ZFnp.I-8`j/9`u UyCu\Dd1%yc#MR:L# I:Kf7 >5 z+\-'9 M{fKro _FGrd%\ĐN 'j^G h81/&~¦K~s[)8me4 }2w;`ôkm vMpY^Bh"y:-ux?Ax~,bN#J3e뀲,u Ô욐L [YL̡KM<0 vOi8-4&;\o:4 >!7H뻄U8޲&W*!4:߭M(݄Up:#r8H^=kH^rBcp;תMɫ7QY1X %}R$~۱ѕT\$p;W p;WDXp;9v&RdFaEh.mٕ<_何Țׁ2:Lj%5QuaWrb֤Uw:5\:9,G4%G8 $ a"4u 2hJ^Q5܎*S퀝 '9*kvc5vLU<8NNJKr Fc ^4XLnƪp;[CSVyL n!yUc]9ջa*Aєz3Mc7: j4ʿاC!#W̦$%Qu<=㨉n:*˜݃v5 ՝eS.t\p:$rcEDBMx:H47WͶr"in.5An2'4 05ۻ^Y|MplЫhD8Q\Ǵp:k0Z8h˪`[GPqacЉvc#(c 4׃mw;Mnv_IvcvdQdIn{P[.n[-;G5V uRn&BqlLi.ks dnt0&vH kt&7,_xMf[rbZ 4{f_[,K-;4^Gjʤ,Gzh*{xv`6M'05i`KNeCqw<*Ⱦq:4j=iLHgkE'xho=;1^KcE]ֻ.XQ0 /M>]c ; vSvtQ!4Z#auV$먛ˠq+=Tӑp)bX]j PV]D4 qa؍Fd Bۙ֜w9*Ѩ&M ̓c5rdDqlCƃSE`hj#=dQ /9&=4jjv%/.u4)7~M)Vzjn# Ni6%iC_#F8U(F`ƖG_rSmzB#j%G fП^mxCxȟz`Gwʄ~E$Ȍ4PA_|Y!N,:BBM ](Ԑ B8u~„ a{(pE$7e%)=7ӟ}^M0̶ ֑ٔxިv]n+5'; o:DQ̞&㒸 }? Rh i] , 0P{ %N(")xx i AC7Gjp4Jmg!^ Y C>J1˅M%{ *o$nV(+Ww.TtZ$qerEp89-5 )AHI'{w(jYJycb$c^8 `:,䳒b18Woko_uҁi&vKL.ʠ b20ۧvSgϊs}M))au?l:sl߽~Ms=/m +ǀGBlo|kOf6o?}N޶?&p?an=r>Vsz[717#$ Ajo?V*>]7Oۇ~|j8AU&?>{igcڋ phL{:IN/)>?uw?bڶ㻏7 S6}?~|z}8ҷNt>%eZ9wɿ7(({'H?X`r/?ϐi%Ԙ=dy/~2հЫk=~Oi`m<'jOyt=)??cQ5F߾zû~u܁w_~0#^U|}`&Cc[qn l"~~|a,Gj<ܲxOvc$ fpϐ?I6yV+$~yr20?_ygyMs=ƣ/)E#ص+'C1V3̂meS96^FT]TIoTk2 Nm^㴹k|WmOĈ8ӕy83̍|= wΓ7i-L)c?24?'cgO]|8NcX%̇}\F } Ycg޿o>BHi>>ofg1L&v+m٣r֯Xϧ٣z}O7.ty47Bӭt;0۷<# }^\/d"y@7o[?{xf5U:Nb~vF.xOTs*\r4fK\a<.4p,/pcE#3ww9˚|.GsMUAw91Ưc˱^JW|xrg8"5٧bW.Ao_Q>wcCӦ2_}cbn4 "i.~p\ +\[ۙkttk`ESĻ ;sCw˳8$+W!ɊF5>x9l]0/V)w<ֻᲹ/Oy\nx<.[yƗgBXxPKX++^Qv#ziá{'*2#+ƀfq S_pip6ɡFRʾ_!s#N[L 3}7́Fl>Kw9:&c1/uSybNa ;k0?ڹӂr,h'H0z|9Z]~}h+k< N#]h"0//trwZܿ]!JҼ4ce{y]vݡ~90]~k{+:=qC=5:p 9w9"A] vEw9ڙG=./y!@m`c](zT0Y .;ԥQL,Mg١Glk޺15fSwգsp\p!n5Vd&(j$zhV0HI X 5L^cLЃ/oCsjP //zZ$DF)#Ih夂UpHAE͎dIܬ^YEIՊ#7]/Ļ)$/I~EK Uw"sM$N߼fh^N͸$(?':g_uG8 k5R" `_1t%M$.VpZFw9&"`2w9BB+ha8/%U MQX(ݩȒ;Aoc 6.Ln1nL*,26Ӹ^W.G;'ğGk49y᪮_$ <~<w9zdKa"sLɕ mƈ;I;%r\e^T IMܐHN _t;ļEg8!Nf״Sr@_ ?-4һDV G#wN OҀq=-kD܉۠<Ӹݽ|-{,T]E4ҲHؙݘԫMdc"s%Wg{#Gp2 VfHg0Fp4DbCw*W<\_qpgi_h:Iql<7r$4mDHoUEXngAJ(;!#1`C,oX3es^Ipbs$[ HfxURkQ.%yJ׎fbGRq j$&hYwO- Ĩm5cl^a[bt64v:PvrDByw5*'y%Ŏi%^Q6 IWQ(H :ZZpӄquH˫,:pSy約`Hb{GыD&wM2>8z@kinQ8^(+|=Ǒ%;MΞ]. I8YHoѓ 4 c}MG8GDا "\|p]3iP_ )_&F 5^<4]M  TCY/( M!SGzɔ]xMOoGO qDFd^cȎ"VDknjŘcc`p,祉b.WsaBrɚh~(cuM0OMVwEdGT0>ZW"qD ( ȥ"b*qM^M %Gر2D XjF٩#Z)HC UoDwx. E-82tʓj&P c5[юB\O2Fpl(1p0쨬qR:j/a1ف&3}+ƑH@:%2)oO&zNv.uFqnlzXYgF&-#r(X1{.[j#Jm!ZFnhn8508¼EbؤYvW*ૻ41=&=Ʊe^x8bI.(Np"F48`S܈ nn7X]q [%Eaz eȘ@o!ϣ+86Piwc m X83qĕcUǑ'y|SmDZ< siF5ig8x,;0;jN{O`: C]+Sԙ+47XH$x/^abFGG5iV"EnjT/ZKScTEQ{iS 8Vd$v}dhZt9[hB18C8$; wu]e'C+;k8nO̦BN/|$6YZ~mԠBiyv::iI}|P qW\D21JtĂ `-3"}#!Q4!FgDd" oR'O;DZpLU#7_#(f! +m$Yi"2ĺI&z6T."aMY$h (e͛Kh&E wPB "N՚C Qplt7K蒄-pDm 4cD铉>"d sDkY?%:2|~w7I5 vxQ(%#vҿ%hargH.JFE1-FΝ]I(%rWS[C7,ƗTKTI>f]GɡpnE K@JqټN뢈zB3xnSʚ?"vFYG4,{gzOI$Dk 1S][/<YǚPXC=nHrэF D` Hݖ-f9ϋU_Ppğ2 (<= Mաd~]%7y;"HcX4DLaiR&gq$BU"ü!B}@JG:e8a^M%9IՓL,ehl 6NFO @anbqJ  NNaځP%CJK"ut3%f/3 N$@Ʉa:!Ag>QP)stu*N@el15'VAYN`S)l=vCF8)Ǚ pږboA)+BWU4'tHxG@wgw.D+Gʌ)'),' NG,N[y$NRSV֕2o~/(||k씎xz|ɅI7;3؜RSfՍ. \#1Ig ::VX^>Q&u l~G;)c˗_G.e%(A3ejg NDє&{:QZuaᑂH:SLY.U_3j'|{,{#an-f#͙OZ2bC ϞD>kJAl+ (-():&ibڜco&sԘ+]5S\̹K0!NNX1;9@YRLiq\ v:hA:3PB Ng QW] Ω=~y!knkǣL׌WɚDY%u*ܦ/o.2,(ȶ>Q[mvY=7}%PmW 9 c)'?¼A6ʀ;RR(*.)ַ4^r0o}k`tL6B174ha|d\>+k;+9pZKGJ/OzU# W u0dC#c6nWe3Cxe3]Nl6a͹Shg3RWxjQzW &t}c ;eEO`*Pfg$l>5H'Yk=|iHA䔧[ 9TpA3Uw8%55 [)2ƒ2bo+$*ܲw'^/ 7IiDa)Ar}UqHng'S/A0_]Y{`W(Eu [>YlO0~P,.Aqbg){l!1-vV=Rלּ w + zZreK.^-R(ߜ8~v^+)Ŷ@9PBƢqR։CsΔ}I&9PP]P @)aq&T%q[OŅfA~v8a}%2*FS}|- wUcfmȿǙ"Pqhtb~g WC:pAy=QZ:fPBC7E_Z)L*ǡُN! xʜgʸR@#W y;{~ +OfD3Fh?SH(+Nnj)H}K-ub%>7)-@Ru9i@/(1 qmDB:!$q{e֣6e|݂ch;$J]GqALBיC_ =T`DrE*8SdS4T3QL>m=/lLia[B.e(y~+Oz#2Ǚ|^/PX]PV()b͟^okEWl'|݌2.Df >g#݌r eFT3DD(#<+ev6[F7N/zAgBFF| wgʼCeFX`PVķ3ʈ'8GJq *} 3@1ŻsQ@xz2suHN[g7g![y$c"ev{&(_8t+ g )₮׸8Ph{, c\)#"82"׽6GʽkgYwqqkEh!Q>oұ#Tϔ:gfSg)2ˆ1R1#!ꈔ2bE%3}}yl'7DЎ jq3oOo"hD rB@Oo=4ְA'J Qэ2#$\}I@D e3%una vB>c(-D-h=-hy(Hq rtO8R%NI>Bd3e'ՐSZp{1XN/#%B==2Bt8Rj3ϔ;Bϒbڃu~7ynjZ~_1u1^v)[_R^絶}gu{v|Mx63x͇Wzoz?=+']ޠw߾z ӔۼaEsS:ӷ& ',;z 3%9`'md#~UI(S\M[&p#%8ϣ,y$@dD"   pdK/8ɒy,URwBݳ`/,➛qMͥDmFxމj`LYJycW֠]hjS/O)8"+$1`w"i! ~m([Cfbit(xCf ,ƥW='Zga{ v<_ݞK8cgحS2Q^W[gIZ# q%p\86LF!]hHp:6 H)&$/8،]=Z:HGJ@[7kY#T MynpL¢vÆF^;E2nL$ا'%ޚ= 6u` a;) R彵ԕX{/.EGcDO4(~dk5 ܼ;i**x]Gq ) wOzd%J7!l\ͩ5Gt^ ^ՄX R iFH0`uc~fp*BKuAǾy֤-#u PREIEDPOİBb?t(X&-z1cG ;~׌ޚD[|0 "+pD3bˋ̝24v(6YW%=8cbcG82͵2^a+#L4H.%D7luBi'cn~ :8։DDT-oMJpl<ѴǙ.]4@*TY}}DS z8hKedOCkʄnf'-'^ňd EC sm9#5/ښk25x\v 8թBTFLe`ᢔ~FQ,CJSΘk&w,5 dfքIk~41\INmq}4b E_̆[ISvqf)~Mbc& JRqm>KXq8ސܡce1΄w@!r`$Aט4IPH@[HLhbJ569CIMqM-X%)Gtm^ qӈXV'HǴfQ 8p$-5V:!}x22闍U@uHoطl`1k6LD9T[W MAR5ZS$nwT$*)<",椲OߥIT9'T[0$m(I\GZ䚭P!/whն"J5FTBizP1Qkk۱+pm'Ou2&D;k4-=$Jq+89B =ܫ$qv01/ӣ]cK zZeET[`KvcEQ #( }QmʹX_}ű|=c"K*%M'plt1Rj&hOz!M0C E$MԚnEUd‚ñ$;өR1jkcڢw&*L x[@hNTҀn;< EnI\$GM4m] l[EպwSjE=mMBEzۢD)H%m!BþĖ&EXR(Nnkn&6I:mJ:k{]eNm*XpBR2@$:#k6xlݤhj趉I&32Pha=TDRE;mCczECM-Bx[kB'q5sw#ɲ wĸ4ImhCfvt[4R|D6n+}֮I;mR!e3V[-Ǩ9Xt`i`T0néhBU 2(Añ'&gֱ47IًN7 $91r6d%Ɯ;mh.XaUIG @0dT-zi@zd 8LO`yC"_k-@5Z h0_@nMLh;-zkFV袵FfkLs{MhrLÑ222D ;Cs03[ (92"v{Rӄp{ ~pk[CK^)@C[4#n C3DvFz,=-Q<}4/=߶q+Q&07v #men 1ݶMxvϭp~!xyWy#8jO_j{+AOiVƱ.+6 r֯9֧;jw\2?A|N~e#, c(c2{z-ұ yPFk˙SR"eq$)d~ol@(әZNJ˙;3ᬤX</< JO%wJF)QHu&)snj82,yo@ tmLoP)2sL)bIY}?Sб)#4KRәb~y|pdw:Q)>Δn6' +8E0~C ә2bD 3%ǼOY'J⚐8YL6SVNFV(̸9PPag)9fBB@QR }N@)SrJuB-w%X #p'R;әZfP>QNkK@)b8:LA>Sҥ~/ Dϔuق/lui BGI"(g(dy尜SVH+ F_&扰車,ARV+;_Rv ǃ|9)OG X?SsT@G[:SJIJr0ךΔEke{e54ز=9΄B[cSSzȏ+aQD؁69Sj(+ޕНB fd)Ait3eg 4z"Imr&+^] LWnRbW`u)vRB}6`uLY'klJYv)oi~}ubAvxz='J"[NS蓑0x)j퓚u P:.N&[Qę('B9n 8z7[Fp9Qܒ=luCj?D=~9<{?y.(+(#—bm\EmP`ϵx1ʸ Ҡb<)n]lywvFWHY bƙb2 }^!ɮbCeRF> 7kAzvB5Rc~"2V ϔKZ"{3> e[ s&pUo:2Ǣ)j% NEeHLYWfHe~W+7JТ7J ,Sm[cQZd7|mo0̍b;8Ӝ7ʾnyudM~Im>SQЦ)m7B Qvc/(۴UW#NY}FYq̮Ӿ)>WͶm8.ՑpGF[ nDx. 'A]77XW`խ *]X7xxQ­أF F gïNqv'Lw wB߂EkV"".<;\~l9g߽ `/WJrJx7eR\<*$FK3D_Rb?^ b%hRFK3Z4CH3dVO&&(N? ?#3ҙ좱g2 5N}*fn:jpfen*j4|.x3eE.  w~.:܎`jnG!3%<ؽ)O/r89#%WJ"uJLf5qߜ2}Ǚ2.ft'8=@J;S ᾤbkz&ulW Kv8ڔ}dn\cvvs~g.L01ynJCǿoYsǟ@;uwSi r߶272ͷ_YhozޘA?|:=Hi{l<~?^7 Jvxo7'nolV?]|h=5[m5^.oiW[|׻}4lk=?O|lZ?陑b}~C(O[z 7fⱛyF~^|oӿ0Â}ϧ뿂\-&1l s<3z-N9_aOw{{oV}!輰u?|;>9lɴUnR?%,#oI8xd빏1;ds~tަOs|ַ)=;6n0Cp~F:69 [Ǝ_6zb o㠾 i&^>Θ>|W~;_ےaӔêޤqU8}I3z|@*a?g{jI_ջnxϯaįo>s'Fg( %۔a+u4ƍ:݈ sb{u9'`15N3>[~ɩ̈ƮDfz)Vn+GCXL*_3r6sx"8?վF UOwםpldĪS;}Sadt+߁#='C}x:4 HF~z mGg#*{=AaЧߜiӚ[M~O?=c'9} kjz Lx|{`u_4y}'ǝ?߹yG ܶU{M s ~}ǟ:Kln,+y{"OS]цO~$J3qǯbcctJcnھޫu<~b#4yRP>/h0i?ѫ=)c'}OS==6LodY~q^!߅7A6xוweg=p.B:qV8>e#Ӂ?;O{=dvn!RVsOġ?'F|FvW8 .w%:0tgxVRr ݍ._UX)s;3c!R<qtЏ?}n7_J8C~ixC˵dv> |x~}| 󧏹 şY$!{|'c="`[A{]7.̚a\ 'n\^cFǼAq2Ns,6)[Jύgr|=[҂5 E90%WҸl+ܮ QpޟJ| yG/Đ {Fn[S8bq_ vr݁Łn?ߛ_ ͑N|.i~_h9`O!m/>YxvNɣ29O#kv#򑞘WhNawwHEy.!i^#_8q>8%M)xhls W!3/8Q_°g>v~t{Vk[x4[5/(endstream endobj 328 0 obj << /Filter /FlateDecode /Length 5313 >> stream x\YoIr~Gm˕ge.0l.lk$EC69MJwDQWwK3 bŌ_}~5_ܾ_/?}-X&)z*tLb1b]\=^nf2b^M;ys'nsg o̳6V-fob7V³PVW}hm0~\`*]F-F0bf cl^Xg|^`Y˅7@5YWW [yoиCchL03}ǞanF09Li5+k`4osÇg>hvZVKф&C'2x˭tHEYo} :8!ael]4Kdë`'_ס\~uJkb~? {~_٘=^-i|{b^,p$ ЩS}< 9B>=1g }蘿G ?biqũDlO.BOZ[N(l-&/DT$$>QdPqHQ:QzV$_xLczR$6-%>'$ND$u*du`zg- zfsV&7l(XlA-J 8) A[k@ ׃*q=z 5)Tj9D,QN"WdU;kh@U0W컯J{:\j ˌNK+睎Ds[HKͻd:e_۰R*. Gk^T ̡;n͟dp/WR7iڥVoOt"z" ;TxcPqAm4*;( A/-k\Fp7‡k]tc5&JԄU-yD\,K6d5eJc‚*[Q*ġdU g>As۰|9h0|C7BV |lLZ=)&Z6V[%z~CCpf{2j^`Fi\6ň[H=.VA,״f@Es`ԯSg fp:<6bcr ,gE׮6AErvXNFOBiI[ fpeA6C,QK1!0QZSR]CY} 'GAc$rbsx Q,>Q,%x'Ais^!:b9&]'li>Ev! E=j];G`o1HVaPE^۴Ru YV0ddE`q ~-Վ8H'ljQa4*_YamF +->=fp(h$tFr&p..EȓSұ66[#0!UND_x4RW| b߰_}q5%8Kt1:a\`+u`R>0G%ZUbٱ-+B;Oiq4p¬uskhBKSi6w"sS >V*V|Aqcqڠhu} i&'4Q2y \q#<,O^HID դ $=Sc Qm%P[Q^A0Iu->k܍(w%7TP?hI|? {~lLKe߰O=ٱ}9gd9V-q_[!Gs~ "B(k\9.3O'4g{XRRhV1P@[Wz̔^CTHVz!l?*\)`k"U6u3b!&0^W*7q@ˉK3qa[&P/r=WlRhbnr\w;u("ٮ6~P­!D/1̰G@*od,<B ɣ+NjH\r3Ŭ=t `;\^05J7i ֯w{ak,n퍓P79iڬ@9Qc*O&U*F`\-7â9øw*Fr=hGoc&e ~[sQvb-ܚZy,%69>=V)3wa@FsHywH;}]2#xIY-%$C% WZp^ƚ>l6Go3ei]B73;.:3wisɅF}ŴxqXe~j*AQ"m\ti.r}|}y>ޑ~-L01:Jp8手y "!+WCڗQZD@% \ 񚏒˸SC|-?a ee[kp_!SX)L,A#<Q""bq*6P> 7#^ bw[ q*t{Ӕ<cJ˕wr\ׯDy )jF 02PQ@7GӺ Jxm|?aĄ-c](s؇1jC E~`>;Ufv.R{WUEmNjZ$BM>(2!/Ee&K!YR{' 44.۟;9kuǩf)j!–?Gxz}R/QN}-{G q"Hygm=7^ʯVXR&|wU }Md>"=}-эc3Yo#03Mp Л y*u [2>SBCGߑc-jW+&3!6ctE)=į3E/vnG(Z(ㄘg);rIvM{8z`×fV84G' RՄG@dx@ 坟ڡ|P%qB}ɭe| UtaV=B]^H5X!Ke^M !{g0n.3^D] ~Y7Y.y/wl&yD:!%&=;s2UM4NE[Jۧth>g>Jط7@6Ċ-tgFc0ܖOF4MfP⁉!=Du.+7[Sf*.%8| l`a TVZ+=ǩz\LۤZӠT{ڗ /#0[7,'er螺or%,6CR;aWy`0˂8+aw 9͑hW@ncGHx\:߻nJ1y(3`ܧy iۻN87eH~Yݼn$OS X맗osUλC*qxˏ݌5b-ѲIfUTW jendstream endobj 329 0 obj << /Filter /FlateDecode /Length 17459 >> stream x՝]%rF~Âo'^i_rI,8HIcχ<3[o>Ρ֮f×vZ߯MZGy"*ҋNy9&jQJ8eRW ̜⠋0vTWd&y &)D2gf|.)b+zXX9\HxMmG۪V X'uBOmƒCP?7,t19@a 7e/%B/W]|(Q'qr\$n)YKð. 4_&s 9͉DA? aVAV>el+zYlDF靷9!μ@o35̌3z8:Z49"ҔVq++ˢ4|F =I=R3gٚ)dz%O:Ӣ _#`P|^of{'a^I!E s JOI⛈Z4 XVڜC-H2g*L*5Ҭғ~ [E.+AʹNGғxtu4ΩcU^(1Uz).I4*JTsQ+$NʢDdߦxuKsHg鉟SbD٤gNI>%[0D6[Ӝ1ԓUar:%ROB:<ʌJ2m/0%gL3mDȡM Ιp1R9eRG KRo%R"Ôa]"zz5BN(+uzR:Ee:dw6 ʬ1QW=C AԱZ>=$^02TG˧W Μ2fPMA>E+t7QGtזOdfNR-x-y֖Oh#Pz(̧Q8iZ>=1Iw]TpcD9wm/ۜqmLC UK|1]Kn(I>';(JTjLWL(p],^j((J=SL7l+JT^.L]9utz%Q`xuʈY˦' )kBR=kX2=})Cp]<^%d[.bi[(j=0<0r4* 2GQ&\IJ5ǂMizg?_;=`9ݳ)7y ÿ^?n@fY&/Fq[Enد8 ƋvpUw 55`l[.nxh'ʩOG9XQ~Ήk?,%+I>RaVB?!ڿHb. ?. imy&Y-E~ fB[W4x2*tƫ2^%!p[WY]Vӣ! ͧ&9Z$7sACc7wHqKmۻ-0uQ%~r2 Y}o5HPLjxM҅T'B_hb)6ck1БRy6y;y?Pm &Ғ̂Fm-B&N˕B(D؄+즥ִ^b8'"×4 ,>CcQ=y1"'O[ܰ^RィpZBKf kVSl]Tmbqڠ` ЛXLf Rk xb8{=c\*DY1`~Z,mDԥ틝J 㐄0$9/aH:10+RV![C+T*]cċQTC#^7#RY3F֕;,&clA+SYX["Oxb* ӵhL ~:"|ꙴ6Kcȁ+cSXFq< )Ѽ{"YFd!"yh` )uc1X9/F'2-֞L@$XXLa tT"C6M]E@$Ebל.je֠qw qa!O'"_7$mTE/xk׍acSߧqdeȪed: \7l+}U)BT,2 XUk--<8|SXLcclma5#;m]q70,&,&2ѓ,o) Um X k603#3ɌD[/n-DF1][c$"]mcP PmcLDTsˈ4vkJ@, Dl:4[ec]4Ⱥ$C_w2[EPm`G,0 -_LUcේ"D֭L H؜p u֥8DlM sQ_#҆K %q#h~CH 9F$BM DdSX{oL&tx̐J591,kS5Zftb+6P`5f1KZ #WIqHY+W}ebckqH&%IÐ60W-0qƚd!E>と RqV0D+`w8˂Jb V"EqŀHH7] ZN50e1 R=XI`h^>j@+ zj@RAQWRֈ)x] bF, EЌ*V,ma(Rg36#"Egj1"Rj1؂"XOP46)H45fF DJ+^)R#OVF̀HŶ< D `EDbF CMt%. kxH kօ<c5-0 A,t[!5.tBR40 tk꯱!d<[\bT hH]׈Em^!XT^|HPh_@3o>'Q=1KX2 PXF`id,a!_p`~8D .XKX X@iqy%,Vy&;! )KX6<OlN+i%,SF+aXJ6DB"Ǖ↕g난On59l1 cCRKM FrHBCx4ٗIxB )Pd͈)E_'St(|r8$PfKI([jLeb 9 JHR srL-,Mɐk. Q.auD Ke (! !rDe Q9$C 9L%Վ(S[:! %Ѣ.XH %TՀ$u Z!mJ!&!:,chJD+9% ,R/H| :ۨ3F+MŐVö'5q7K58 hpR7O\4fLkpLoI8XIl“*3:,dSէMbCdғn9I$2:Q&vg&044 kjGЛ;䒠D9V"&Q饡IDcAKmc1Ge@h{X%$~8dINL\Gr?CاnIi%\9 \9%yjpи$JlK_u0 L"䂠.69AHYQKVAH bI]`K%=\ %sI9D 38DR KɈ K֭8#5,YSWh;&$D:ٷtJ;[%+#%93(VgPVߣw(Y1J"Mr`yP-OBI<+.J"=([Xla5QzBI mPR,%bF JІQF)[8@KxK>5Òb%cIp TR"|gF%LרdYmeM.52YdIA ND,^& N9,&sɂTRJ87Ð+VgE& XH3 QHQ]i(bIB4T(DBE*Y'vze1*Yph' HyFF% ]Qɂt W`>c0*Yp̐?L"[~,8D d)#,14p(Yp D` 1lI".Z$)8Ʒ\S{*)8,8WI?@RmJL<+)[CɢX0dAJ%i^N% NipTpT.:5U#3Tvݢ46-&WFu"q =-{Njt H!3{..["eK(M<.[e9([4eǪ1S!] L]UEiM(f|2oE!7<@DZl==fK*a`^La /m# D%o/5OŸ:nsydh-=37rͲt(nvbx.v 9y]\]HڅeGM58 iV#EO=jU@. HHC,4y4)pQXIy: Dz; Dp Rհ'yi:Dk4r1v}vqぱ] ԥ] "@OU@:ty|WBo_=D>eYk~qH<ʏp*2?_? i0V}r񳜾F~+"k"=!JR=)'?|돯޽}HM^R"A^%?sv_}#R/a{;C{m{@?<>>w>筈6ݳ/~E c{f/>fq,o|w?z@R/Ib>Iu[^~?6y zޤ&O?|o-=/?'Ƈ*R׿*u'/~ҿZO />| ?{!EMx/oK?/?||ǗznwowAVܗښ_ sFy4ʳ{{ad~w+䇯~gBc =_,^ҏ?Q-ċwF,ʇ=o= .(1x=F ^՚4U+SKlH/0N8T^I/]{W^V*0lqdݵK𸿻,AF#F.AKŃ{K\ëgCI=áB}f&Q}%.ۡ?aYõyo~=i_&߿jsU}EZ&~dp_iק㷗`/1Sjh8=]pҁGóG5!{9IǙѫyzW3tZ+m]jƵW3_^> ,翸>?˹5qc)dLſ%IUp\}#Zsts류fCq 'ï9zodjn=o ojcaնa?s=O0!?cH 0w|[s7Y=xkc{6s} ''=Mtͥ z/h5ND -o/| >B2ozoL=/ Aj,\|GcfՑqxޗ6I0*1Տ[ {j3n{@rkv xl÷_^69/N?Jh.3ҼoQ3bVȽ}ɪ pPB-*yuEH{*KD=o+9Y*ջ.҃\OCjhaK\/ CW~/Z~}|zgEc+L٢O}Svr# D5\]cՇM|EPڇM0pa)@Ha4kqܝz$?=BSĝ6~b4Z] Dv.=|a~ eHKI`䄁caۍ|loK,S!S/{q!6}cd"T[XBLXo|.zZRvc/='w4z鼞j|5 2졀czg6^κunHӆJG_aMz7GǪ xWXP=Lo/B,qZ末gJ^+õXPo(\݄FDuZ׮YnFKxUMָؼmS3а.q~5B@y2XCWj͢Qed x#vK7i2m%I@jb؍vwo' \ Py ySڿ =@Yn>W{ q?kF2OO\_џ$6TҦYtlH]͊3w2_;ʍw6%zl}s_6_,CVnW#Z'tPɈpltz/tT/faT-i=qexR+4 OZ 3{_b(h1ƛܦh0qKͧU4lI˫I8ع}mI~g1xu/Ј6} .BͲIO4N pR=%|{En;4G8 Bd{Lޚzy*K[%4 ),@w%4/?Uy175oDx3 <ѣ:6TK̀+{{s.S,! V}ī(Bv s5Ņo^O_t]jvj@y.N58@=hA[A*D= {? 2-rXn8%k[sE܋m5ҫ|#O">_d)9Z`J/YQc1 FOw_)p& EyJ/wj CK'$*2+ǻcFjl [tԸuRi=^y[?rO!]m#P\֛c_6x [J WjXpE\z[֎C/OX> stream xcd`ab`ddds T~H3a!Rnn;G ~"ȘW_PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*&s JKR|SRx##羗d|Sr -*sdaly?ξk'ι<<@Y\endstream endobj 331 0 obj << /Filter /FlateDecode /Length 5388 >> stream x\o9r.,7"3w> r@6, kƶrzx5}>"jd; zHvXǯT T7'ѪӷqI]ޜ[RB7'WfœV.󛓟7w318!w736r y=}E{5BW%{D-'ػA_DPp_ ^l||NEɅ8u/@xҨJ?I*t<<0Os')|Q}gʾs~nIaD$u"`PcGMl̞ެnYW8(*oŸ EbGoKeP9HƱ|#Έr_-zK`gwJ$tCQ^:x$m_'ܚ~(QBdBq&=j7 ˊ.i`9X)T&o˷&7}%|\c7CP*dow,}ᥲV%} _`չ<_l\]&$םɬDʃ&ҏlhIv$1OhfR!m'͂.S, #џ8!ju+!mI98#aoļmqVVۣ[cl\_(Ld(@I35Rt5e%IJvyJ/Wݻ}LA98`[H4Jqx4rJh YYLp(7 no5yNu;4^?‸Bfख़B>)P/޶"#BS؂:>>%,/Ib݅M[=Ot\2(%%g; 0#=Jr&2_萘*ɿ}5D_WDfSfo\V$pCczXUg Y̳o)<ʅYakPoʎ]pC\dgư91I?OVo ~{}Sn,ddz_Ȧ Ńզce6$b!| ;;4;ͤoTg6g&ϝ=~=R@RH ':Y&VO1bџ=0Jg#2-Đ0U҅'%JĘ͘xՖ2.u퉴q #|/Z.UYlr\xé7b8=jWK_G Dщ?}.Rw]hphK6s ?A^lӃ/ǀHa KA `m2j2zθ:Jh`J3d*:^j@9"G'⹭fB=5BcAGR´wa $T dQ߼>4M7Sn`jQm; H4FaSv`v:e@aJ 0#<29y%!R-!ӓ1=y&Ǩ4rVR(G #;|[9BdZ fVh-ab?Gw+~O9f͊ AznvnϮGg Zw5_ϖ~hCnHa21ħK5 R~ReԾxDNp[J^H5GVAb#~Byw#IɳPE5tb$xx{`0PIZaWϛzuQU,CiǼq']aV*SPG@Q6C+4'O$NfB؍Wt0`_t\V }DHwi6,ݚBFKl[^^K;y2lޕcq$ Ӊ1ҟ4PIM` i:'l%aJ{!-A *6 /4[u @yb/pL4RPX7\PK@]r([ʔFlW'S&?# VR$0"2_2@[ 9ы=zO9,XB1߳<lDgl(F c`Z$Cѹ"V=SdU62 $*E*Iti萦jL(mbyk#Ƒ%X xh;Ďn d +CAfGY"67ʜs+$M"Z%(A\ YdT| /~ˆ~63"gsK͉/baiDX}s7$.D1m+HgÎ*!.c\Izk'E q'O]:WMTռF'7I䣍N#%xufRxkMN=%132|ngŲnZFql4z,-Mb msQe)GѣK=~u!ep{HIgݐG[Er,gR)}B}Z6A|d49oJ^vLKO$h*<=*$HpHB$0VšjqTr\ݺ;:-uOe!d9t>F 4ȞwS+%=$ˁ_c(7AJcfg.2vV*責 `܅)D(/OJdǴJtC<J8QP7#7O>UMiYiM# V6&*5FUwܯRq-DX$_D*Cj$.iϧ[6L"5:St!-۵ |#_ uۃoPN>ɴ(ƀ` Yתe ޞ:#?]{+02E*-µk7{")~֏5>Itؤ&}M-Pơ,6]ޗ{tD&V.s,t zq+ kRO/)<TR:kQWûntχMՖ_xЏd~J󯩋C7(걹^W8%.C]z*"6߂Ix69A))ԛL5}lGbHps`oNq* 0^9M[+#׏ÄP]x:TN$غmҰV~L!92d?E?<ر6ŕ vDZ!t9q-)7?24Ś)t&Hl!k*eUlc|K(LH\r]F0:LiШe.P& X1CiF(ŸR$>g߫BJ^' {a1>űƀ./$tWoab$IG/}Bp}U+aK%xyK32=_.n3F1"ח$endstream endobj 332 0 obj << /Type /XRef /Length 239 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 333 /ID [<094bba79c92f5c9e7fbc931b070f566e><3df31cc0bdc0604edb7719853344b220>] >> stream xcb&F~0 $8J Kl}4匒ĦKi43Jf >J-P )"ςH:) DH@Q~- "@)D2H %X,dWLB`PzCA~5H uXl;d"@~9n ,_Sb[}e"gMɺ˔ c+A endstream endobj startxref 277605 %%EOF earth/inst/doc/index.html0000644000176200001440000000105513000466773015103 0ustar liggesusers earth

Documents for the earth package

Notes on the earth package

Variance models in earth (prediction intervals, for more advanced users)

Wikipedia article on MARS (a good introduction)

Home page

earth/inst/doc/earth-notes.pdf0000644000176200001440000174406313561364217016052 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 5085 /Filter /FlateDecode /N 89 /First 752 >> stream x2 4Sfw :y͜)ÜA,syU0(y`A\`!I5. p,(0'0]p0K[- JB[+"\(43V8| Ra5@@+ =kk=k<гzz6flgcaq5a)ltcgbdzvF4^gXJ /f Kqeg/ a%,?XoĪHh|Fž# 'aaeP98 a zV2@QD``2jv#a/?ZVHPo7u384d))8 eu]3~হ؃M}}YOhq:MUgM'M<2J)҅E/we\Kl6` j/꿾Lggs?͸}F=} Y=ðl~=M94=} ׳Ͱ(~ɞ^N|8]7,V2B7 {p2m`Qf`.|7juh厦7~,1Ei@_.PH9T;TKZj%;f$A@*Ww% Q T4ʥRkќ6f 7()mc/UnN)9IƥrV0slKm4V~euR9*% 2DJG%7 忮xr3cS@bTff@\P2S`26 R 42kG)וDHN)7>ևX[[#zD(ZR?$ ,%>78CCLsH,)P)\ %V%:OJ'} +h1U@ߘSF"IA$G=E~[ }A!ҡ/Ҳ_?GPG!=G1Ÿg9ɏ _7=|0FlxsߛצGqd ySg8.tcP |ʧ5F.L<,hPE@P> G_|<_7͗)7m[Ϧ?$&C?.(fQPRvqDd'qZUa`Ռ ȠVG`PLxsgP^u[?;ӗoO`@*qK*ב #L_M X>&% !<%Lfg'$}kD-eTA`dEMC]L=:N eڊ + @$622{77"O#գr%)>'֏>vD %]ΧBia;0C)8 Ѱ2- 52S)OyoRwVI/!옦G{mbE6N_c?߉Ņw͵"71L՗kkN+Ȑ(r?MݏcԊuv!*n?K"I] ܓLrviUR2,4& j&GV'VyjD[PU{0-w__t0՝;)P:jZ;=wRJSX-7}Svkڮn*/`XZdjU"}»xAw%אWkmKvQ㧨$Hط=m [)ይ^Zv-Mg8,g oro++k63o\7m;rlk8Al ȈYd`mEdוq="ظ^Q2T yǐLL2))"0%`GiG^T'JS(ͳr.DsOzf_/RRJD}a aePD[ a aKa aU dh+š4uGN.W%!4,ylAT4@|yS].zn^m,—ZXٿ"(I.{r> ylDKQYcpSl<( 7o'/}i7z}yz2)ox8Ao͓HA{)K} Z+6o.|d}[hwN 5v8a1㬑P+Ih }iHN, S2`oxx%OPBmxx/c<<އcxLl0ZԾ)/ !SiWbv錓!:aw| Ę(3j%w( BVxl=lwGswO}[C/* ?=lqxV Ѹ5U}v $- &gfP]6W@!C ^G}c!AKaՙ29 $=}#},({rvĻ1#Ӄl? QMg~%O6wBQWP}WJ`{?((*@/Ê뵷Gƣy 6h8DiS`͝3JCMc|rL8 J@}{ =ua6? /io*40endstream endobj 91 0 obj << /Subtype /XML /Type /Metadata /Length 1672 >> stream GPL Ghostscript 9.19 MARS, Multivariate adaptive regression splines 2019-11-08T12:57:30-08:00 2019-11-08T12:57:30-08:00 LaTeX with hyperref package Notes on the earth packageStephen MilborrowNotes on the earth package endstream endobj 92 0 obj << /Type /ObjStm /Length 2754 /Filter /FlateDecode /N 89 /First 802 >> stream xZko_1sdJ $!M"Xؔ!х{phSZ&UR;yΝ8SxͦF#5Uf$ZLNT x~獗 ?{sDkɈe#= % v*b>{5! ]I&v%uJ1*1FC+7qEA0ѵ+jOhb$bB/Ĝ8&V^ $+CY튘ڕ`RlWԤԮDJL l2,jrӆ:cڡbrL)N8PS| "ЄdJ"i͢bJ= SaҔ)KA37D5 h+ʌO(Uhn*""5 $ğH$\)35(o^ 8yQ5ˋ ?/' g P&~GPdWTCקhS\Zy}=<4MJN( _拫W8*(8U0.p5~vV_7j#-pzQO7Vm?&`#gsx?[௫7?,no,O\y6,1W_}yXR6c ׁ2cŗ@&kn%`99[ڭ{׏C?j?~o[ۅ}~K^ҟ܏}.G>_>_>_>_iO|S"xXEx}'M8!8l,^)pAOk#;%LwIAPN#PQˤqK�ѽ5"B ; )QtR@c'YUȄDˤm]2?[w)EWj͒hNR;ڽ:l\ic)ݕCå lT4 +lއ}茂>xK˽tX.qTI[ s?qR{X"iJ뽥PcR}T oQ9AT凸SU4lۚdcAl`5#7v C} jTr<-Y'_ޮ~fI`f_#;hERzendstream endobj 182 0 obj << /Type /ObjStm /Length 2281 /Filter /FlateDecode /N 84 /First 753 >> stream xZn}W1yn {7@BȐư9iYng$sB)XSMUB T5Ղ$k( '>ÁDH[̚1@wNŧ[`YlD/l&@hqDL bM5Hg gn8(I@o Ӣ>&K51`3v 3DeVxl.Xx)k-d6wYd511JR "!fX(PJ)Pm([ի W'+ӬK@7 UuÜ5 y訖>'W4ے JoP>#ubo7 -A)77$hxpZCh5lKpZpb%F K">_KZ}}U|s}r{~a-n.1T UbZv߾۫4QOk;5XNXy ;l~w}x JkR4]A9 l2R*o*Ybu]IBK>Ć8>Iownarx߶/\~sq4#J{|~yA.o?_Ջ˽yeq>{v'W/וH۪XcERp W2 EIE) ]#uԓgJ٢!WBH)9ŊLU{fHS$ZAQ\ȃJiW][ @P8GO.,/C*sUC՘T"!qz) _ h"$?n)vJCq}I K`,0ќ[%<9Y*HuUSNl D\ԳuQVBhqGwML xVDUXπmdQ5dX;c2ԡHsRs[rsWU8i"]@tP !}7< '|7vۉ0on;^j5O2]tm+Juzt7)KuzMϙOǓ"xҺW@A2q9fq\<30ocC&@̽j^ƹTRQؘ+.TC@u]FTچ8s#qZ%qj $.Apْ3K l?"w.5*#XP.I2g5 OsCM GH5qˌkV Jy-/Bˑlݭ([(jq ˤ;_EA[KRrPF^.Ł2N`{"hme!/Ayq^v?CPzrMTX2t&00^#Xߢ,TYр ջ@ y BE}\PFeϻq*@C?Tռwπ<8^0_Lˀ (U$hBaLk罿]C7elm<].="F:U \*dzs3lǫ@{4Q=y2-6(e>AYf pT7~j;Aɐ0OL੦ZA|l/) reB|91Am1L !"x990inz /`sϷY ??p3@Q4{ᱪt<ʈbECx˯*42/0 ex8jc'Ep:#MO7`w9y4*qkwyT>ڒ>::(<'?po]̠ǢoPW &}Q]'2>%/K<4qO7H#)>[;uZUro/ R o'JGFw`<d;EN =xXLLѿbbEs,pv;8'Ga˽T RGWR.JP:YB%$?5 Gc0.Pm`Y' !-64 5wSO"l~O ow߿qܽ~x}.^]DII_>ٿ?t\Ylvi'~R ~G)p~}Z~i'/ 4endstream endobj 267 0 obj << /Type /ObjStm /Length 3168 /Filter /FlateDecode /N 89 /First 810 >> stream x[[s۸~f:qtvvqzNsdȒW䥿)e/mng(` L0"SF1ӑZɬhfQSk:I-hcDgN`2X ᙢH/<h\ħ1ûٷ9j hq\8 ؔ"-ZtHY#X t=j#uX^< @9OhqY,M.Tb[GҎKz]`">۪GURc)D%Q{C5@n@IKnOj[~@;w@bNIF/V"IQA]rh޵uG.$\źSԒ?s Y5yU;{_/ˣ#Dd4=gٛr;ʫ;gZCYy^OgH5ou$E2sQ5K)SBش~,z,[DQdNiD(ʓ%*?e/0˳QVd'iVfg$fd>ţdi tiTضK.E>4/13t\gE_/|\v''C{/uqo\Gۖ_c)eygד 0zՎ?߃wKKg+ث^W;\}*`jB􌅂N<Džy|)쬜\T+s0+ C~D߭EF_7nhy{DZe`:A eWW /5??}!Niw^I^TaB"gm^:#c4QM-S$%*.K,0 a7iĸJ yTz.l:z).ub25(1 Ib@7%ZZYrqVQXܽWחy#AC(SC(A}#)2.UNk8CHR(|SuX cT]t I) {{+}1d?X дE(^z`TF n5o W\[jRT_݀?bBe8]F3⓻̋iS> stream xZn#}W d{c^A8XhcI4ˬD$|{J\w3FY[\NUWW2ʅyQ^p"Ee1:U  .l$)l$+5%DnOV+8qJ2~6ONKx忔m#Tg*0#,Sg7LpLT>>'$+ nEDo$@J< <}DU\ ^UL„-Yh!S)*$B%`8-s@gxWT1*ɘx^t;J E$qx֩ćy8(SRgJ*[]EeKaY*{TʡT½xp/AEuj=bm+ 'Eq3h; `F'ևX10)#fBU9؝ fxYUEY<ufev-ry=PoJ5,FQg޻1cF{7~~tO<].OϾ]{d\lƥ9k7˛EQw?>ζm<躃ѳySg}x_c~/[Hz S/a*GDȳG탐^y1M%I@ IzTt5 !/qyIC[M@7DANWz;ġq*Am6n1$M$-y$#܏|O= D#vl=Sq|n݋~=a3"WR*95=y|z*VUO\lEwWwM[]m{/Yt!{u \f bYVD6etÝ-l|%f 3:_._7lѯW'$%n❪  ~y1"p0j_77rTi֋fZ5Yas7v.gMn_@@QC.:b7߮ +_L2pY[pQ0B Lk6S! e4:Hr ݄ hdmx?DF'$2kYL=҉W.X$*S3x& Gg\vQx8Ie+IJ(g:a5^ ` ; \PL-5Us: 20C]%.Sk"<,(YB?%@yEV,p Q! X%ݮeut:Nc9]w,+0tW;WߍhD")VEb `{;_˳avajop1YZ I{vw|J>>&Cv|R ػLCqV[W=n:s0=8; `IW zX4Qt,*?d 6is>)<>&Co,|pk~l\Q7Gm.ؖcx2%Tֆ AFcPؾDTƓTH&@>`&6v '*y~HA "`6ˋ ,Ἔ}%-F;ܩ/NP.cS <*$qzqf3K7 s =Jܒg$wvtǩxH8Õ;rqHH4ށYcdcq#7dg|>558b[ďŃvs"={.k!CK>亢8PG6?* 2 tH4D08[fɰ*aUiohR],fS sulX2T7_.E//5Oɛr{7/տ+ZigX7BɁ qЀ3atgኢEȜŋ Aw7#A!J~3uc|߁} ?qCZt֞OHxC6 פr'Ïl@$ILC->uБ&ݖ]%l ;xjbD"Հ|mB m%~`})$0`W$e*|z_ٓzoQ]jvY/gxlxR%w݄k4i?Ӆ&%c'; RJ` &C{.F[/,BH!M{H=` !;MC>xB^/&:E7^3fus^oާK\^,9/׳7ż/oxѴW{6#"º"e|K#~][H8& wY)Wl9ɏ)ЃUJP"hGxGJY >w ;8d\>"/$endstream endobj 447 0 obj << /Type /ObjStm /Length 2395 /Filter /FlateDecode /N 89 /First 806 >> stream xZIW19X^a 3 9P3-3 %|_IBIMMɁŪ-q&j$3b"k0"D4o "UQ&,qvb ƒ0k;x) *'Q9BvW!!Fكը,QUhhO"wʿWF \T,Z4|¹_&B_UcA> VobX&&j01+'$LrI6IDq8XRK1&e!#D"fWdD&kLGq&'1zp%9X) EU"t1WɑϦTǿSnRsU/fFS~F`v:=G `y.R0=8a"N)|"D) UPThTZv›5B{-+3fެͿ];sٟ̚nlSw{9*A\>0Ԅn}fuѭ k[ ᚃa`~0v7A?wl8x y9=ka9,=ZpGۜV(NAFBZ8k/ c!w!*j{=&2n<ϑ-1gpC*F~{V=I7[n`2 'E6co8P$eVS1Zbpx7/6_v7E}k@hl}ȶTl C&B֥^lA5H@{3LBewyTonzGTl3/lFoARY-'֓d $wRzE9 ^>lVN)80i-/,F2v&2WLb+%jUvyBœ0ďP&˴ӖRqظB(`԰ )Ǻ>YDl)PUڊabX!JO$ x2ZA~ |-d6VbikkNJBk~aŦmlWGv~=lqݲdLWLqJq$X!jX}f0SˢA\݃ uND4[ǶVʶ.}" m"11gںqYyx*,d&]bA"\V$يQ\ $7?E)Dm [&ݐ݁LP@rT'1|D**TY9. /M/DҲ- ]5g4mƝB-(,Fur+bj,Q!`鋭RiP9屌|,f.O[Mkgb^nfszo v6^,6|3ۼ[{7iZF. V`Zl6tݿ F+(-9GDt*OPU Ͱ P9W8*E&>xޡf"Vmr1 Q{:C۩,?򐀚!QdQ乡Dsϥucw !FGJc= P{Y+E7{>V˹|yh3|fhŷ"*=6|NP3kj+KP w⸪^k˗'i:ߺ=U?MsA*<kٓw=*~J.myTT 0iZ~jcbvS`¼ :t`yʣa"P0z) a/lh|6 gendstream endobj 537 0 obj << /Type /ObjStm /Length 2699 /Filter /FlateDecode /N 89 /First 807 >> stream xZ]|ϯG bC89@>Zu"$R}䉧=J= pr[]];Qq&j5_ >ńMTq0F|F#.pH;(Vg3b F*oyQ0k #8Ɨvu7F?U&1"hrQR9c*)/hY UL=b&fgBU|q$}9I>4srN|W%g̶:.$"& x5)r%`qMJӤ_ĒMF1UMbz\S=9 (brV^ G:'G̶vM5Bgrb 7% :5(5JfRLv)A58Ss@Lz&^b' Ιy.'zs=c &(D93gxx_MH>q̾]/7cf@O>1fB  g9/-:L=J> Lj=>~Ugf[,_Omx\mͣGX`zō. @"|2wy`Pp_ J9*l3ׇb9 AiBHZBM$u @mq]TDo*@ZY,9jBTwX+ 򋍈3"LTuhݠRo.R[bDe9Ab @0Up`iSn듷LAxhP ?a? )OF4)-wv_t4JJRLZdR V0E&? Z 9iB2LU#pUT&ѐIٳ *Kw}KKuH2!$^!#Sm< 0T`CAĵZn%fb=bpk\jϺz}m woۮvSܺIvl:q.gO_n>ztl]2PI R!O˨}T(bdFcѸh=S#՗I =vX.RuRp r)C9($wT7VT[<4SdP PDfLaRGz:X@ I$2UkN%[AB_єXډ=;,}YLB8b1x{Pw 1ȏPiPqSe(V^| o)!zVm`g^CPg6\lEFT RFcxMz06hR<ހ D=g|X-wei6W<ޮ֯fW?w?68=G9^cd 5SuIL9}־Y\\5Y5nmc 2W mQ)EAdͲ;vCk|C|fu}iuQwLĭ ٻۜں%zqQV~I<0}غ#5AmķGZ ȾlLcL~ɁQK:rr)bZu*gml̋ϝh}N4>EU9([NkލDSLW `LD&{lNg5(6&!w஀Ϯs mr5Pj'Gd7NB:mɓV#,z:LԆuzfvu#Nǐ"5Ag~Ig?M3 $Ahu(I;Z%SI|Kw{B zW!&]U$/;.:OKfG65:$?|bqqwkcvO&0~AA&jԫ%6%ܷ Fq狚R?s/zzkC*6i%b,1 ୠOT&ZH`mcHܧ$۶$?GH`g/m)qױJAqÔ ٘5ܫ' rHJh"2OF T_ꬦۿ⹓J[a2a#o [ R[^[?DӮ%Vӭ*x*hhv]]oV5xm:mۋZ 5hcYV@G5כnrqnv6wHT_(ԕ=uSqկ//M 7zan=C,ޠ 0-mnm(eR &MSw奃4X~TTmih`D|ߢ1k` H϶*GmcCKQf7>}`u6nI4|TBS>Fʎ ڒȇZizDd3t@_⊅n3%f?\_n /+u/ݫu/6Wepg3(ց983dZwMw|It~s}9*(%"1Ȃwq1Knh}OWh;Oendstream endobj 627 0 obj << /Filter /FlateDecode /Length 2486 >> stream xZY~Gz '> A DF/#jꃬnZ$:;D_y[nŻǕOdm +cRmWUyø sF0|ݭbBfD.Z ƹzÙߒhtpRV_Ջ83[a˷Q* 1RCj7_ Kl_uރbSP#+5I|r0fVEckXZ "YG>o6r]J>=JV p Ä[Bk>@Dc9R2L$j㨡4Ӻl0Q-ȍSqާah&0Ysp&<_xAY!lnJ+!Q)2 \ Zuʕ,pIDz2 `}z$N%u>RxU%?j /n(*}E4טUCK0N6BUup9;,l# Mn+WI~t LW^`Wx-)AT"3aL86.nz-m)=H'WJQD})i+(& o?M yhbnh8n@%GZ30N%pG%ned{5i1 2#jd"/d |r$`gTS#`ֈg `~ilҡ02 K+ǿ#K`C* p PËPgbs2+vPNr4n{ZJls[ExYM9%_.\\@EMY>EF QsK"gdAEOV_,H婙xaaE+gIѥ_چp|T(m0e2]YݥJ嘈*,\!TՖV95E8Ȯ Rp7f|l(bT/1[UȾ /ĔY6o$ho *=%so &qB6sn:B*)%2 g,f_r`݅:H/L %UK[}wDc%cq+ *xljTi V$}վ]G!*ދ$,Fb4 I OwQݺ&U1pAt9'FMH%%4>U`*vy%Q"L]z:QMN.M0 Wu2C KͰ:cfvNk"O7nDRMo֖ZQJZR҂?NR|gj71o]Xc' ڔy'ryp>b:r/kGΐ`Ds6 fD_8TݛU,DI-l|TaZΡ#(z"Eoanpji\Z)Ҵ|BiC(PuW- Lkf5,D_ }uGNT&Q9A 389.*Kz?Cf 5RZKXc0kVn0xwI;123ZmL?g.h$g֧ĉ7C _4UH"[<ݓ=@k7Mf-J5-6N/se }YaƗ/|\NIz>!G6tvԯ+Iуv7qi4!h,&o ;tM;^:&R cxyvV@XQ#OѩZg J4)[#_z6@Y޽&S693.9o@z-Ny:놼ߒ4*'$8~9LgIc$DһNT?Hh*|D8Ui{Lcsg/-/8:XjSO9ʧj /Hǹj:GOs'4?3||yՀ .:4i꛴_5Ba8%&/M |d)yfcZ9?q~qO3&8_G#*E$ɣN]>iUt?M 47/LP|QلNӺfr<|6C؍A[Og7tnu|Gǔ/KzNNKLr0 tkc懲Q]?Ф-)/ޔc6}:M:`j 5zho) = ={> stream x\Kofoq` , Jr)dקggffkgw:L8.N>;?D_gj3əޜ[LxϤ23S~vvu)g2#msc˹TycVyc͹1Tq 0U)nq\IV$ 1@Mܨ%y \诧 0,dw,\wno?'H AِףfB37 !jvjHy|qAg;as/2mi JDfiY[v{5?qt'Wl%Ӵ|G»+ˎ 7HWm#eNƂC?Μ73F'[ÂS K5ox5Wo񔯾RT7bmHwg'?$K4\RqhJb 2UwY BCP\dq K):H,/oYx5'ߗh%APuzTV'"BzSa$ʲ8A%d>}ܠ?wf.6[E=_5 3Ju|@X[f "zt>wA.of_jmAC.݆"x5=fW@}y7Wlɕ5D,lMla4Ww)/R*=kMoA\9Q$}i4CUh,UxJaQux P{s\CV3=*ψl5'jK9Y ,8B)iIyRG TূGуBUj@O ͠F"R`^Cpt/ Uf*ypt(}uR ԥ\'<[Q\?kÃPPv`nø~L]t*U{"Y>ꣾ:۵rЪՂ+Bɽî3L\A.pH }G\srE,YL ]P߱l1IAS*{\8}TT* PS۫2j<7xPF:;0%#7οT{T*R+Bf|Eƹ,VdT9:&Y54˜J0)cH,4 \bMzcċcZ=))GbƻT兂rE"I7sAq3R6`cl?WpI-_A@(^V=z|`iKkVJOyѐlsAy7kjɂ"S"Z;^vƝ,@qZ+fJґ3BHlmstO60&1u={Πڿ3(]`mS 4|޸>uۮmaG`SV)VRHQYNn^cUu0Lu姹P[G }ԝH J[)@$҂IUjbtx HTGE?Mڡ9DocJmDo̻rt.ŋbRA Hւhp=nR)yӢ-dJapv۴v{J+=XG@u?!Aj#}}V`GM*ok~. ǀTk{S\v8]IWknCAzl4Am S~xe@~[t% Sh$N n l 4 !1^k_u)֗AIn7e[[kNF },S&sYIi@I`birCve$e#w+Q_GG`!1G'tqoBL=>:RkLa Nhi}{.՝&Ԙ6x uJ3djM<^U,<ShЭ4鿫miRԑFZt:E>)-evE J+ٟ)6@> (_Ƚ՛j.xts,z^U3l! <@aƧ,kVn~UcZ^<c}Ro]Wwu͗zZ?zH%]"uV$qJJ_NW#*=%:㕘 >֝9źw;,X9{!>h@j&l47zWKx-fFn<~tϕQk7]£q[Cc_&2.V`uF-SA`ÏcSڲ-Wendstream endobj 629 0 obj << /Filter /FlateDecode /Length 4050 >> stream x[Yo~'#~l N>9l(H"b灗HZŒQA|y`@Tl!7Hbxx4 $L}J?G|VN*Oꉽ q9?F^w ̞^q5Jeca8O(@VSY9z {kգj8 &#l"  27Lt\|&5PٮA UD0P)FeNyt"J\x* @!wzk˔V^נ@ɥwn4 +s\[Ʃup'FJ1#hII?𸇣HrIྶqNzg_\$ O;NA|$VYӅGAQ:zcX@]d:#w~nh]I}eTmz`cgk~6y59͉]z1?@SXMtfu K)|NMI yS,R,喬yq<}#|DY4xӨʹsBJ閨}G@)a\Wk~ksV۪!R ~"vrv]gx`.wL.hQϣWow鯵72g~Q2-^λmL bj*) #)u+Rdu~ HT8}D=^}xVh(")&]@-dȏ <վ] 8T)tߗ@lnhNBM3M#bbdd落AYMw2na+mܾ[)'۫B.!a&ʼnI7 Yp}0WR3 oP^uT8]3Tt#QqBׄqd*1Q}Ӄg )r4,e 膾HE7)4t $t@u-{Kp% t#9(ve2xf踅S$xQ5)-Jk6p9tq Tqzw-Wh&Chţis~X dî *x,E#SbMe聋 Aekh:!p5-euǡ%X^B"Aogը 'ty}M ƐzwnCf`$F0 c9xր$dRW0CnPeLjG.GE"y ~.12^9xDb h((Ԡn'hlD۔$(P36F#),u#hvwVR{رt@$)n+ "7H ͅeI?Vdo9сX2*:i1UE2c(DjO%PZ}(ߢ4݋^46=7Zp] QYW%u^RNBhp}Q\3$ex4>;,KU֪bCPR C/;Ef SN)3YKHty\ ے憜yXPC% e~ kIpˌ/qT5ޘE9HޥTHE+@$y%_xm- 8=d?1-}h3UtSj.&oD|Y_˅vce0TTRoj݆hعTE/, { M)pr#Te> stream x;xs{$8blrJq$Г}dNDj3wVKHKϳ"'MJͧEZ iS߇M"gS{)R i 583, 4Ήʼnca|CpeGFYv5JF] kR sC$@/1r`z2B89HFEPw{ t|{7uSR `pq3&18²Ml)])CgbiPXw՜6HjDMg01Ri(_mU@Q-5ʋKCfQ/׾c}cgF;a@nWO0r"M9Yn^wzҥ4Na"`4x&: e콈tdi'?ߞ@ z|ظ#Iăm|TnJCg״R ).D[Т%ʣ*)P+BftMk)Uɕ 8^' v5 QgmE8s-w|W?.9'~|+%/,) ,~qCVX9SV&f\z wPb jvG $1 ,(cRMTkyCkJ)Eb$OX>,"G,Lپ_QJQad|ɼN=J`*;2:iY鞨G哸4ֶ"~M |XXŇD-9DEZ_\·xbIɎ7躴UY=G*-8M܊*AT48~XHf?=UK:[k7q -\$/:x{ e g1y詌*0cy" #AA &1^XÃ>Ueט$b1Zcrڼ.%!Ym}9NRؽӃ[9-ޱ@dqL]$&"! Nsto da: g'鱢ZHyU'~""C6ÚUB:-i 1,fc=bNlRb7Z+1ISiWP^hZUOljw;}wlǗ"'e)z_2;/Bν'?_&B)e[mnx'݈N⍆ G_~WTp|EJT 漹a?0TH+_ؗwHN(YRt)T&]vj Ei\چhi7_=HmV&0xjV Ŵ VGyH:-d۔08=mq09TLͻ8feӟ|%x^"Q1+!q#_Q'529jW~I;Lzى> *Kwf[c.C-+yFizHCbgDP ϗpjT`9kzZ=}_UW h'M:ַ -aYO#oK@@Հil[W}ߎz7wR?D6abf֝3\M9hߊ+Iڶ,&u]vka҈贒A:qTiQG WʤUGVZZUǰK "Xs6`TH 0)p)gOv>dM  I8TW4G2>HgG>ޑ? FaE6CaET$Ƙ-S\Kci ho9sݬ3m7os|`q*$rG,{7 Z0 {j'Լhxަ&O3m<K \gT*tqdE7P;βaKISX{Ӧ/鶭P',.Ea=14 rԲF'wT'swc̩6W 4bu!I59B- znW{-e6v#3&nnw%tγ7"K1|I 0GZg#j=e>[,_!Eڧ0ymyJc _\uLXz_ G<0 ;hyY_>O=0M`|)\1r28+n`#B v)-bdSHE\_ ٳVwL/"|Eg%W;+q\]H[EW=٫=F/`rwu83\v~PScpIQ/^79{c_tJw}Che4XP/>=:1o3~hFkuMe&ဩ>_lɻV(ufuHZ[ߚ2]'*Tz'zq:WfV_x.ҼH3[Bhb##qMp%G u믯.vo6N/Uo/ONKO.f =4 hk0J82`\endstream endobj 631 0 obj << /Filter /FlateDecode /Length 4807 >> stream x\Yo$~GZry`6 {{'>jI;R_;"HfdЩL88X?</ywD^DΡOJZsz$uNBGyꭘQw'화NVnzQLL! a7=?oϴYo~ܰ4R*N5r*v B?9JSKP^I*7Q>r:# JM4iIy4zV*CѧyPv6p%|ћllK|13Mm$D= gHET/R;bb<; 4&NZ6c;*jrvA+=i+w3&!zqȵ+ tQ0]Z>އ6^̫wP.XQ̑]O/twx 3eޱH`5^΁W:" KL iL=c acf=RCMJ@oIGC|Axp.t&9̇Z=ΝZUp1 U60iW^G pD+Gl_Yȩ%r_A2 Cb{z܃pa6{@3,j)4C؂ji'h78~x,4\_<+wHmq NZ< tٞ,A G BimNRëp`f>%(׿#`Ӟq#\`\I&x7?w2b]ik5 -?cV/Ah79g%>,.0 ˇ7;R[ j `aW{O|Oŵʁbᝋ֚I)9&]3]S|=%Lc@a/:/9Uk[ZPi~m9av}_9){+:CHJçm '|+5+#@֒{=Bop$`$o&S9{s`Z~gcz/L);URRWUjhINJgtϛ0'k&nzIڇ~U^R3d>š[ߔC(#!jad=Jsytks1NeKxlyP.W]gEJ~(Lzі_LfUÐ3-y 5-iCz:WlįٍJ[mws.r??}H[1EPX 4 .gUP6UQ&Z{F/wHaǼ>dʕ: Lk@7=Xܒ%9XOZlmr2p .&+0(ݲt[+hЁ7,翗0Jt0 _ T_ETZ5|!v}_rCR3AOAho"e7t9WXxI'nf iDo bݮ'3G$f@XXV5kcȴ -2j-r>lN nVPBŠNr| R"-C%}-aw+gjf,ֿ;D#|o6JXOtptp$06CNp 4]z&A?pUi߱ecph1;(rI^&t]p^nvq9RRzi bkYz-w_*!ٖkeڡ5-z-1*2dm0`%+ĩ-~#I4,6SV/Y/v(aƬɉhCnMq*CXD:aY-ukyh $y\J`C97[5)h5Q!ETIt2aR;`1ԉ*I/R|VυA+'"~r+nF%bUzO\VF18yU>ء9vnmVI[Kы/e'k۔L'X5I ը -ź4z<)b|l`#Ɨ̠?RJ-6 4mT-MS~m!S`I)Ŧ&R rQbs8WA~W般âj>-eu  eԊVfΗ }N6עx]Z'.G>Q@![qeL*|CM#.d"TLpE3Sur+J5_JĭX!6jz&XT}XB7a.P1iۢ_ VR{jN O?3x*?쵫qJ[~,\mnb; hV7Lb\48ZskԻ 5ZC^Nf]#uv { ix ~ ݁L?/dyC=sTۄMɎ#\*.3ab7AqnnmṔKTF6D,05rGD܌M;]+Q@)(@p!w RJ䇯͔_ڎUp!qv`o{q9L%&u +i-`Y_g"Fˋxy[*`/ZnP8Ec|Mӿp8SH{}HcԪJE*K#wݪ2ͤ}ea4N5L\P.P]>< fkIT2cjR&vΥ1~oa|B҇˃n@>Vz#'og%͇nR=ֽif-)0*=ѷ 44YGVj}ƿ:r'Ggwս^F]khs3oO!bi'wJ0QG朥'_=K(ڟrI?CN$*KFG=ayQ;knkM?rK)oy=c)豿='IFX9N>/VWvy#hyx/z6=FUa@.%~>CIhh,F|s% ըbxxd!,Mn=CjVe;-^œ$\2<= ۪#پ3/;~{l~ҾkAm*6UȪ_D_S^` t`=?s~ϻA!vr0i/jYRi@&3W ]nt\vIktJk+҇IN7Ҭa {h5WzgbPtܵZ|o9FhghN/KJWQ>'P^endstream endobj 632 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6447 >> stream xX TS׺>1prj{WJm:ŹjeTYT@I a a@aHegcUvEUTZmǷ$뽷ފky z7ω7vw~.p` k;nnp< n|x1aخP`Νi:/" rH5a!"dP(fԩ\& u &p^%r l1waA>6,^A2W&$$I;|B|wڵ:/lMu׻_0yۛVmS7}FY縍;oA#|xb1XME5$ŸL%\uzbH,%%6fb1XNL#VӉ ƒIx/b6M!|7C@™D &܉!Pb@,$7b$&G‰1=F C^(ڀQ^Wعiy$M INEPCfʁhנk4dʐ#Fr9c݈]#GvKZG7׿IvyJ89v|4iSi{F1f˜J?L`>JR`vFnmO{l_"H ͒G7z8@TT#(g"ASSd=M6 ;ȸ?p)L/8AHFGƯLfc"Nb`f%%6`QW N"X䓮Fm?EdFPU3cwԘϪEut^= "1rBz{[A"ny'ՂD0&l_ +|Gg0 oto2W*Ο_RWWB4U0!]k9,"&QgYaBXoyF4n4>)>JL?L~#K~KW|ufR#Wa2]|.EWh2]ddlyо] yh ~~K&+rX>Q(ِ) SYu|B6P7CB# &>܊MɺQz1 yml-={mKwv4.yoʊ,y[&Xi*i%ڀm3 {pg)ȉE=hNX3o ]ƅFa{ptbF,wZsyO;j ,*H}8Պ̭Mn/+W1b?L2h9x͂iHq[+b,š r0g)6PS\(J_dY{l+,ne.\GSL:F4|n0]{ U[QYXCk؃eQu-qPJFyMp8}Lñm,?cgG[m&KuF>MEzBD9naAu{lIy+fvz(˳K% ~1B>npHo Bvη[Z|56KZ+Aj0`(oCq07Pz|qęIeZX J$·fl&-"9jpB&1y?GNp`Ǒ{KL2M Hn ?ph-Ғ;[Ǡ=T@~٧&<'0~"@X[&gE)gPTc 6EاGoR=бg= 1%ۤG^z<č{q󇾳"~;:kɩ@}U*K:86 z#{˦j2 QK# s8 6`~ }O4PՀjT j@^_uX|]kv܈dVCrgFĔ  K*L\!ʖPzh?nzP^D4ٵ +_.n8n* ڰ@a^P p?eI< #85~khL`yLuJ-*!O*ZP 6h VNܘ >Q>fr4B)3L{g.&/$h]&c~lVzd6݁t[JKw0HaH qFޑVS0n5Y0ױIz3@u93S- TjR"aJ(5ԓH~R Cy B eRL&Ef/~t vT!'-Q:%Wj]`Z菜 G8iNXɇq Y u9鵉=^@# IJ\JTkwu8)hvWSj6#Ez@GzMEKW_}SWWV`>18¾Wto"H_q/6ω^[9jpTV}k}fM٥ } |/П6Tpq=S7 7hrj" yPXY7]vt3 0HLGo4hB#ZV&ĠtW•FHKOuN<t(?\v u-`>`A qM\7;Pz~29E;*j{/) >Y;A]6,~N߈grzO !u-,*dv/ȟ:?‘.4v N^ 1<χ~pZ_Sᕫ- mlCyZD6/jNi[#ٚȆ׆Ejڲ% BbٻVFeN\ vPnϼ0]|8-Hpѓg:c3ecl\}8Xͥw` /,f^,7q}١n)pV2efraIrUZ#ٛ^"Y@ (9*b*[dd\̆9IL26HksgY;hƻhrxmѵ o@TuXElC //gΉ˔gKb]@QώLKkK)DK`U򇣾6m> st}^(LL z}=uwԅHlX ӟß}tB,Pl+ \pU;4 H`e%UfGWŗA4v+\]nE1!舖904컿laq:fG,/H>Μ:yeZfCf߄z:PBi$HۣwƄF8(ũrDgphapSRr ^B &8fc%na6ptl f6g?#w:a%8Ⱦن'ZNfc}QlM^',w_n}ī;/hgc;o]34\_ػFf 3'$y]$Q~%>}zG8͢ I6U#C6ϟDlc;`UqB>-l{wVy IAN`gfN=Ż j(_jxg:!e6N@a;c.fDF2s[P_laQ ";Hz ;stOQmWOGPʥ]8M}n-ƽ܎ez( OGLK Y[&xm)WMpYVD5 З=zubx/p*P\&{P~()?$Ѽyzu9z =7|Fj(ghS\YnH9[hT.OR' ))(ı0HQ (]֠U8"Fw&~΋-fn޹) <hYC@[k$w2m7oGZ[XX'֪BY8eL@H RE w; yO UR*R"',R{?SK8 OV8:?)/)eT"NxGf~+x !#y^\VWPYK8Ͽp}dtцv'z<(O&VWmPd0/Bã)J5; lv}@e S̋V'Z'xϖ> ; "ERPY%59 =x/ MB'eʔ $e4c~ߛs/UM˔ =ASejYrrTd\FZ DQ$gj,%Udf'q@a rgNNTWQ^VY}a%BT^ʋ35Pd0f| (m7Wh .ό`)deqyb 6pY֊i>5'@+^="S4E`^ޡd͠\p |ؤ!2sR@L*ę#v&Fńǵh Uyp?(t en #v7656p}e_ayn[MZ].!I KP2ze˳@P)*J C)܏süL@<4S   ]_^< ^ogqe84D%)2x{uY) 9 J*tvS3=g܊+:f wj,˵ȧ M`lMUMyc\gk7M3]E1hMzfv6N>'k4u(C âOV#[Xóoǖ]{ƤgTy*_.Ŕ!:.!1-rcOG}tt'/kL8gT|r^%N%v'gw$deH Ҝ.݃ͷ8)red@Q /ikc@͐ Ţ$ RSuEJqPY-m4ߝ5WV= ù4ee520 𵩉 \>-IɋR1 a*1.#nV(##dH@\_PR4PO|e^s֯?.a ።9pݳEOM! dcx" 4/?f뒳YJ\]u홠(s=]8y?qv:Cs<R 2g}R2pE &Z"ӑ xPZTp-Ғ|s3A7H\{ o 61}D?oؗ6}3v D]}b7"fbDrra&ƣyVfQs|co|]ɥ/ߺcp9|w5z޿ĝ"LVApzS) vTbjPQ n'B2 d;JQ*U4OZnD1@N+EZRYQ㢪N5ƦEm|@Hu0 >h6}7s4AA33UeuJ' o;cVhWnПu۽s /¸pW/B/A,}Fq@&MJ*&`_^4C+3ET&D4E`1HR!{ B%E2PD5ƗKC@#!et$t7qC4Z=IpđJ(#j?M?AI)[Z jI$)3$C 1 J :endstream endobj 633 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7740 >> stream xy XSWㄶXp8<+γ:"(y) !J s@ 2΢ZVmZkoܴO <}zn$T.D"9Mr. 8iHG BϮzYp{ <<98$6,GHQfΜ>qę |.^;|"/k|#bF2k„^A77,aq<+xwࠐ0`09EQkʝ7:x, }=lq7"F-Z}EKJUwٹv{ຠsGl9Ԧc{m{'Oڴ3fΚ=-EFPYPj55FQé5j-5rFQzj rR)gjA-Sש bj"DA9RK2j JQ.tʕAqCP(;5 zQrjeKS>K˔KBT?*zj %t֒ãRjI/I~.w]_ZhC|*K_mLKҺ/fEOzgkckO1DL_+nԲك{YFخ>}0m@ր4iA>b̹r\? up^ z!# 7L2 *ێ00mfaQ"ڱ(Tg'@Uط]FN>Pn9L{iLl鋎"{;I}tYR WҺiBB+ B|l0 D]Dj+?9;FhF Lyޚ ȇTGyd˓\.=x+rFMc۱4Kwݹ/=1髙 ?S)hS{w)Q?,.\cL_bt>]a,{8}Xʏ_}<27mr]8QRw] h'Q?`;_y<PGߢ9oe`kD[p#68[SVc9է7·v飅1kj4H trlJ OTy<bWԞ΄l{Suf#g#Գ < ܺ(RU#o|^!YnAѴ:GiێQ fI!Z1-"]Vss] x9v$6썦h) A] ;YQ)x2f^ xAtD_+G<@UL1dIy[:3`UH~JKdpZ}O!-L޼"C_1/Jv'߹/3_gڂҺ#' \{{"{,2/P^d#*P CJRގlnh!)VB ׹Bm*d9Ȧ&F"tMVS RTf)KÃ&e2ێg:B CQ4 w<Mx׬HZq6ݺ"ްF3mNۧEկ:*%\pae~c}'Ge8l~3 Iikݗ+P b~x`IQ+}tmx҉̨^DҎQ) ṤefOS8@ɁcH% %x(S! E6rZ_O+x7` 죖@ťfNF^\j4ԅn&iT @OA#ɪ/ɪ|YZ[!'ϠdU/; 0[DOQ6Hut+v&g$CC& FaZd{Dn -} EdѼ?hʙ"՞HfmtSH.:+T$2XPZS]Iiv(Snܛׇd/- v*z{H=>PiSs ЗEQYia7<`d%l^ A @m/24WSC_ z5K~Y䍮g.%1 {fLe7+mwۙ L.dC(0J~VHa8`"R?fXQ _ތ\K;˽|2:T/-g}TZm̿ͲpLf>goV&"ֽΪ&SVn$|7'9Ӷ.Z0Sy4>`A4Ϊ֤~D#>L/I9#EzFRoJQ׸ 1$ r*kCBςX.RfI!Ƣ/ټCj0  XgA>!ET& v+jPkPN^ONW\[B~Fa tBȁl]NA2d!so,oq&~)´ӓvܼ=jU NYWL= ~.ۨ g u8JIBĄԱ$!9uaĀ2pHBA}mH$d.cuG3 ;saGYDvd%d 뎓ˤYəiL}cl7wUy`_9Y(^(ΰF CF0~{{3s2!ʃ[9$ޛ[T-%2 uD|FǞ?+HKd8!* eg ҙ`m!U m`q]J&O7$_H}(57l7Z+ mD/9pԥq)gA9/f!} jSYUsG)==CDH[xfF CiNn~Qi_kU-HtHM"n֝ }u:Յe2Z4EDnXZY:VYmY9~|k7y:wAWPZx|7^|twFp q5&5 d /vfU&F]],'EDճX~]H6K פ(ttLkg4=֤΋ Lba)ړ^L\־9AZLSY*#)˦4$EOUh<֢N[ n,CZܝpFj>K]2:ldO-_e g &5;߳#9C`o]K6@$/ 8|D6gohB$FtAnռ,ۄ{jG"m\v@MyuͼPI禂:/Iy.?A!2mc-p[g1i Yw. 1 gL=/xB'_^X6y(Mx#2e+ST߈kx-ZhE(C6 *;T:c=Ex,rNSDc$䌖h2; } 0E,􈲍$p1cu;z5D^ehR@D*-j7oz}0w+[e.UDv y ErD|\O_{oXꮾGmyQEÏLҙ$\FΗ FKc-P̽K\ڼk/ ˑjERLB~Rin)R!-Mç9{ ~.w2H~*$Xp>)')D]!<8*2$"PUB\4^p:#j}hʸMu>'$7hdP%=wb;b-G19T jJLQ\W ϏRaz3 {tyY:3 Ͽ;ZnD}*ۋE9'*ri >53ZJ4Uؙ֑S)LLttDQx;/Ϳw~dHMPF{!ZUb[JjU#8;9n 0ļ"lw>XP;r9!VwشXANXk]rbD"pSv,z ٓ`&[Wv*FL) X,|_0,ynYC)xN-&b^)؎/޲4^+w$|^ŽOSe+{)}p-=n6i$O?%xGSMJUᱝr;!UIn҉ZdֿpzЋ3Y" fDI }S^4"C^]֧!¯ ߤ IB&wfz^-j[Uwqe>Z%[H0Oyّl2F1a)>ol{HX߽*ZCuhӹG?Q5PWZ$P-)OXz76&$_YS|2,H!9q`zt6ŔR8W;c (JF߰Mqޖn2 W>($@=CVtuQDg/*;F1v!> (h@s5IVGV):~fj>< 1w=a\\AVsc֍o3w>28csKW]zxzͩ;筟=O޼pZ[%,N~cĕ0.[n̆&";.ԥ.z B(U஗&.'2=F2T5daw31G,n-1Û`ޘaiL3/R<^/? p|;:.H+nMesD1ׂr_E_MKD""E3pwl{uիg!)lSrBfi;t|ByL[BTr˧NK >2EMmE߳J3qUgi5vn?JOQ@is{qΑasRax?'3cu9vX\㎺޾a\h}0cpoop5B> stream xY XWDŨ)jqhD(+K ,{ADDiEED#1Q8F':^2nI|du9?Bbd2kpr Í:x8a7L'wxg ml'[eeec=kKK0{p\L:7hǻ&[z{Zqr qw Xn}?l}w vpwscf-^giHKn+WtXi:o?)S5cۣfY϶yǔaF1ь#3Y͌e0'f}z8^ ,Z:eo>-x1C i6̾45m;2|_/v<Ze2q[ TNI '?%E?-0-R~PנJ~v~F.hm8 uON~ꮥYr_#$Zaa D/C9pls=Mz:x%hK4VMIث*U8@G/[m i ñˏu,U/;TYw?'r8hY"3|c.ems%dљޥٶ*Mzq^vb5iOtb=s4Lɀ% zi"L9,XaSq|etQ2IpR/+&<פxаTu+L=s{x}6Bt\Rsj}ics]idw J-܆}]̤-z<٤c{wEp1ڳ #X}kqg@"ҏF`*J֋e 1\'!;*Y QBjZ\RJ,|D G{(kRəpw]hs.YWrZ,3t_PAGu[XZPO #"'~(cZxW~ǗJgndo[9>fg_qumQ,cǔk*4<@@#C=\5< ez3h3Ƭt):7Dє.8V+5[SMJ&yg `]!k',.MVpwp٥14sF64R㕣H!aC rtV{c22 iIda\Z^L{3)3*yi ^l$@B4P'D>7ŕC@#7)lF9pP'GOd GQ]#8Y)^I{ʷӌ7XOgٖr1%I%·ʍ1TT>Ay\{V4Bs~;% l[hkCY1oB0YUJ6 3˴eTGs! yUl ݾt :gQx%ףS-ōWeA[[.MN%5k,H,[$teiq$Gjb˖8c58윲Hۘ~LW_^w@5*MD^lC] G;oIsK~YOy2.c:K&w^=Dd$kS(׀[Vf)ݮ-%ʟge~g\ydW.TqV>ĀGXo9dP_al] t]x/(;4Qʀ^4AKu &fĄib4ʔM>!.%>E%%]'GOzc=Zg8$s)w#5:|Cn>^5 dYJs^q$CP ޲2*q'Oo!CtBFh{td&)M 66HhD~KQ̆/)PWFN2 ʃ8.QДAFCc'VWz'F>{[DVMPEޔ[ xE(2{8۝ߐI*-s*]×pN9ֹWHYr9rzPdԡuSCSS #8cQgRfk_p6-)(.,~,;ꄆhA~FB4uHԌ"5b5Gъȼ?P,=n51!8 ݙf:K3[.8PUf#+/^k >{v0|VafuJ -$#.9t|>mF\:=o7[= )uXB`ת,'74WS" yR=Geۻ;v۲;Rx9L !ܟ~v&}擣{%p#Mw^giJVt5k\A=85NMPkb;)Si|`bϲl#aȈNJSZ5oܓ,&eEdH#gJpb.Y]r*&Liv«rpږ@*PU]4lYwyT{ԖP{Egޔo'ڛ N椧C&=֚/կ=\?VX/<*1Qv)IZC I!aeTצ8 иv!b@V|N(ߣ@T<8ccz}&nJMV͇o& ^`Xm]M$KxC-eo3vlZ>Ƃ;j!G"ƽ:e+۱{ǎ:ꎿ[#9F-QT!XMuyBzmLf#bU؛~+p]ˆ\þ:Ѷ}&Sɘg,LCA'>&5An;?(d/OWhVgi<}.Ne)!f%?e]R2J š}ϭ} a45}p#Y)NH4~u1r %jn|\]>ǺDXT/k8Zz\Wǀ$I8 H,a\:F=蛭7#Kc \9Sjv%"kށ@⢢}}CCwIJ)diݢXO;XV ‚D.1 LU8mY JTM@ ^:JwA94GG|S.jћNi!IQI Zi~Y/cM,x QUu'|t>m:5g;oJI|Ih|՗pqec(#wͦzM.»<hm00!K3;+ Ň W2:6_ȴᛚ/W O8X#'o/Cp7u+XM&UIY 4KhHO jMf`bs R`ʤGjO: O{Љty(8EwJ qDT?XC>.5*?sPxFns윿4IM.#yodDo5ۡ4mKI3Mhr^ւm_{j?ae#~9~[a3OaxK3k{=)Nғ ͣ.VE{c|uEz5+Y_C 5xKܘHGG%LܒVȩ.* K'7h4[-1sG&|Z3E'YuM ƛaGgNho![6Ȓ|h=UNm[ZK Q3F9sm-ھv䩚DCzA)u9%!BmNu\*]n|NN/H"LC*o_ D?(X&.Su]̈́h o鐴"%?zDA҅R欈Y'4pLd"  Z>~?c8|N^#&D/䄕qT b D\^W [Y &F}{eU}5eX]endstream endobj 635 0 obj << /Filter /FlateDecode /Length 5442 >> stream x\Is9r3#xGG27a[lAD75iz~3*IIc;tcD_&CCg~oqήp-=~QҚÓU塷rq1\Gb11.V~9TJX{\)BXeI'`wG[hwgw; 5,2ّr: }y;&쎆mr~x:mc X~=wDea%-[^=e\ea;%|3Wa«f|lEes7]':kW{N' z<:W":=ߨ9sc#owX>!6,$4edbtԧm.3Jtvv{kq!ӱ41N"Hܫ]P"ו접;J7z,1IL;Sg;5r`L3#OT!%e8)J.q.hQJ55m t6+`ZE9UDKx}$`J4b4IFXIS%1s%v3DKI,8[=/38Iʾ[YH=$ȥ 4~a-7h@q2%4u5>/ޒhΆ<!|NM--eōFJ3/GAE&vT" lcca[mAB#<<2%9_-Bo=(d"HQ+ ~tMEJ+Ð䭒XO;._ÿc+cmzkѓTHd*="9Iu.b咋Fe<)QB*ltdS<ތl8n_۸{wB}_ (}ֲkĀ 64 eX8W=>OC[vJ޼ ߘdv26ǣ,V7&5"[1# u\'Q M.im =Mo jc#F#I|L:.*YtɟfE`/,QJ'iS:9=Ahxg$yOcbn^vpE 92:ȯDي` oV,TJgIQP#h;:.xUJ N+Dfi{9:Y\(H:^Zu2N#j8ʭͬ9QhrsIX} k7c{V\Ops>ѨI vd;CĞXycI19$Xh+#x4&!`'h{CNmL;Z)P4L (%,I53r}<0wpL@ MGRq]I"RZ k9e:/ 1QFh$#&nS<ϵ\;B ̜yjee\uH=Tr,̠ͥCN8g4J?rZu4])o쟒`hA2$jQI䥺tYY2xbDw4 < RieS5|^N,7eMugBii$t60,@bRUg=r-!JTʔs2^' ^v0H"FE ,UYhay_dtǭ. E ]\!pT؝^]v\Q1ڟcBև%$W6 .e7*= IM̕ k sG]CT`Aw>Ξ&q;u,BHVi*><5`t!aD4egdk=&ābU=\SڛIm*ؘM-0FynJW U2 E{jh"i܍kvV}Ɗpl {`/"1j[Y1tDx؀fӊtEpŖ |x>czAdlԙ/d3ԘqTZ&dS(xMQ8LNy4_'J~!]LDEIզe<\= WyT?.*݋ ܝ&, 8닇|MTA8;xpfL*ONǮC5sLH8 dqЁ=ͳ=T2$M ^/dH\}&وH(H2۠Wf: K~W_-Řr&L_ό/ӝ㕸:2/]UZYcry>(2uy:F5o4,}P ;7F oe !8șcs҂F(j] x2'[*ר%wŦlsB1. Z&%7)iII!aDc=`bK=\?dG4,m3' FX1hj#XK6 ^i\ 6>&f~e}Dwf^ 7+ VJInDڗY*U}? 8K}iXƒ_"|B;zYs&!}Jڢ^/0kx5Xʢ?T沷#*F.5Z 05y\$/g3]A˜I幽T[Uk JXW3!dcR=[󄣢2P,zHg7^CEu*`Z3_Qc\/:)J_gAZn=xdAѣ!na r\X*0XyKk_Z&[40ƅ>%IȔys<D6&IXD~[C}B傎bԮW }em*\@m+ιO9@ &/$TƃQ3B/IA\Y;Еj ={]`H&zfWQ|8-BG Y_.֕ǫHp?CeK9$f9=TӾ6;m0x3");5-༙7+]YPR5}AP!,7qPwt+;yz)d4OCY= 3lC{A%;X?;|βEҫK4 ͸~-+;gv<c7yJ淽vss֕w6.b+6%VD:¨*a^s tz pq[V4flfl_V"'4=la8l?j:YYSf)U ~2α!U$)oe'pY$qHnclCdn5ɉ3m5BN eF\qn9QD'*j׫:F"l3ʯJ'^=3E-)x85skaN#)lfj 6Gw'p#]+~GvXI軋T17{*.B^ RސY>Tl 5d>f.[YW(ZaF~Oӥiah&VZ0z3G,cϻK|Vu@*J.}x2Ti5י1dC+~fID_n4 eoI&ɛJ @CPZ3ع۳C}f6u?9<ů` \y>Ek—{D>ez[3[{wTx+c(r$eXK͟ZBendstream endobj 636 0 obj << /Filter /FlateDecode /Length 6042 >> stream x\Yo$Gr~D/.ڼ~Ya-x!X?h1na7g<*"iyDEdV$7OɆB .>]P< RNZ5\_rv:8y_?_F=Y)x}SB0B+5>8>]n~|!hT?9HJW ~*FU?E/$!LZGtw'%M0Æ JćxCwHg_z|ݵaf-z>Mۄj(34B?1oˍo.avG)_.ύY5>K'ذ?c%a%ack f#pgKpay>mfgr_WgmGv@FPrdd.JЖO$t1ԑ\x#?^nTZ%JeS+H9i/̅%تV+~ƺ6Jm%j#`f|7 @)*^,'V-_0o:ʃ'3e$t<D@611-Fz}\lRk NRϽR̩bΎ. |2b"[9̊Of-QqGc7گ}WȲ\Q5mQ3 |69 6A0y%]U_;J+*Zew˫,(]wGzI@'ʐlgBm$kqL͡iPb2CpK΍y&ڗ4"0wnLt['}k9t0Gड़W~/aI%BPܺL|hAg#J:?]\/U ت Ė,pw0e\?My>ӧp=3Whw >@ZkO%J8H^u@]gwuF!"=V 7s/ͳL."x- d|{'SK!02ϗk5ހfÁ$P@.vGϹgW)zX@&) 64ۃA,]PXHR*iKCZ +Jdh0QF#"D> : `opzjӮl4ج@aH1Ga+EZ_:y {,J:Ѝf ߕDVřѣV9oζy>,ncSGmV }Bb1>sQi0(4Ո8>;γwe}dx(Rv5K^vj B>oUZIپN~ZV@jQUmD pFA϶xL%w [?ߜNr|vՄb?u̳p!s^d m_mĔY4uuitʚHt-mʻH!kB8b854^lW)_u΂,y"|l%@#3j η2Yi;}JՔZۮjJ6SKŌAx@4&wtW7Ժl[R|2U("3\aH3hFl/*&$qO{^FP)6Goͦp}d H"}2Xk.:J;;i*\K'ͳi~m5\BT xPeWz)cDGd:$y\CF:[F2ՈCt/WDEWt4s]n i&?ݗ_X3Mf~=9ҐAJILtN`OArN'MRd_Y8R]E/T⩘'4ZMaQ.,VuBt :'vIc=0i H^У$S+ߗ\(0t7V"vCл*es dcϛϗN>v/Fve#yd-ډiէj`aWmӔ'\#2'nk-OjAWJ: 4I4Q~oq<"ttL^+U鈴u?b-!|BC^yգO䛷c .-)B wn &*_)Q!8= BtK\S7<32Mio>/na A;9!d7]x@uz[r=]4MHq{W‹| -.wyt7 EkCvn1 [7dȳ"GYT50 =1zV(-]C2"c>tzu~ssB24b߲Fq t屭wV_QrX_tЗ|3nu#+zH\Y:Γ iVY؋dHAp)9%ZLH LDl.IVA'F󿹾Q}z}2cY8oef*3x4+]GĴl?7FNj|K\n%Xi #]T%W?~^{iX&O-r\._R&4 PE H!y|P&a[{P A1"B2)JGY^rj a!zn2|܁tEߵ ݡ2){Y;Wia@'0UZh/0U zYX.cz7pi60*5W[f^AE{^Az^z^}@u^}@3!Dq2)A-q@D2/%ҠH@6Z~mWJq8` S"Ö}`o}xl)Wyj|o:JuO$ZKRm*(ꈞPШ)Հ&'NQm@VL3ana(ZhJ5h}kCh#:g^ΞXa&9789 /gZ/ D #`.ZD h)T_v rX|A4`J㛣\.}+ha* &qQ @X )T;X-03ߩ4`aeshe%;|D` zۡDqf |هlhQ~x|OPN(sDDHAfh$? k;uK騊7Nk1*R[Jը06M1)c~ڠQ1;ZIYtQ4wij|5 Χ8L]@TK,QܨS^O*U(jZ?@v4QKT"@qt{jFR!rSt\fQ;)&9">`oiy|uئ@g|釭~Q`j֖b^ϛgahOڢ-ځu*ˁmbrLԂ봷%J#2%Yi<,qjQbJ+]`_K#q<楎m;ɢ 7%d\Z6-O#2@i^Y1;t:3w/43C+C69"g1aD;)Sh|eWX$83fV</QAifN3 M9LfTKb4I# O0x< !: aْTۂG*xsaǵycR^ۯ{y`(N1^;rD@).!Bd]ymeNf^C_"9^s1\11=eһ1^+,5،u u3a>w U{s=O e\u~ŀv@90Nn0o% :od\FrG q"2!K,T ˝Qd1^0LB1[1liLYMl1NRGshoR3X oYZ^QtDjshXb+/-I;JvD7i0#ܹ=06G< THNkUfp] Xťq4WeTdEZ} •'('}u 29|=W = [>.&?juS0s%> stream x\Is3< ,vUr%e`L 0e)*k44|@դ<9s8z8RWG4z89X)γ9>{}ğ0OF}z1};;9UQJ{srwo'n~|2Iv?P ~>/1 -8_t:5}3hɩ aݯ1X瘄Ԭ#?y^J{k̰?9<]_ r+La*,)xCދy3:13LO̖_C[_x9X$Wpꓺ:Gj`!9hvvOYWHAo&sDfe.L~mqogLI)X$4}䜋L~^ƭy#6U'9~HbvW.56(UH_jo{s&DN:WCl#̏^\&\G)xzy0%]pXӻ,I֏#@ K2qZ"-%mA%E5%HDt{ʹfJ5 Xe2WX/3&PBw> Fpep6 !“G\9X9Rrx{)ߣ1}δ;8Hd%{nѧڂfdU"'I#$X]]_C+`@` 751Ag\V3_=d|Qzrҹ}1 9t ;8 'wF` 5qJۓLZ8σIxW]sXQjx(j#зjbKk1ㅀ͗X;0! uwzc$ϡw(}4IciyR~F+sEX2~TyJ& (scH+ŏ[lU㘠Yv&/Ag އYQ RG:Mc,{=3 (p=~ܪB8&]kK;4ځ|Q6W& Z>WvB"rВ QBK&E NmC(J%^8DV4$qذ0ruJ6b% G;p's,x*+̔In*r=S $s=`aqv0vx ,P7u9Cӆz]x4xHXbJ쇈*s9D_ۍV=EBmW_HVh~̅ rg9 +$҇(~K" TW ꡈ3$.23Z[cS#4`o#C_3$ZZg'8-[9ka&Ap Y @Ӝ! 9duFNgAgg;6)gE-&I&ƅ9 fګC 8Y jwA$+۾Z)u넘j|LW&ͦ41ĊQRA|Ҝ(/A_s/J%_=憎N{Qx.z/ 3MW#Qs[{OazY#^H$ƊS,s)/tmfendstream endobj 638 0 obj << /Filter /FlateDecode /Length 5672 >> stream x\iGr_1 lnW^؅! YAMEIwUWϐY+/"맓iN&7օׇGG?=RI˓/Bٜ(铧$ڽ:NN^>~lM0?vsݩͳvgQo?6ioUFmc zk [iR:nnhtץ56ɄyV> ry.ޤ:eDm9~i!_5LdTnW|)ފ_mq?q͕\s=S)SZ\xb0+pZ5i*k~R_&gS-nUm,rs\7e)|=>.y hl췻9xy dżE3 Zp5wZN٨y_ 11E3>Z E5df)29Ne%Fb,K96X$;G*:3Pg =KYf[EJO]ΎPO?j Jm&B$/O`A}ܜ^_7<4-LQ|û>;lS5L!]R;9w<'m%∥NS,rI mtUZ403xHm&: Y-I8NBUOZ';0 ɸs9rEV w ۄ6/ , zV]E@2UzG3*۽ TθKbzNdGSອp&I@ggdF_򲜧k-bx]KsMHi8bkf+%^|SW#G#Y.  mthZ} P.j84bf,k ii^k:C0u{GJc۰HC`hH*qUJiᵉ~w9duX]6 Ǥ#@4W t+ 8miF=hvv[ )[L"`C ΨK%*6u[,SL<єMNFhmW[z(>C<-*6UbqlFX|"yof[$ :ZrgT7OuR<+{T_i$-9ʕ2 LۄFUGp <[cEiLƁoҮ;Ծ ?[Đ#ğ]C ]f&3ftZg"͒E`f%Sl>GdG}j;/փ}E&dv ]B->H8,`yD,ϹȻb)z @xcvr&旄yc |/zf Vtxg,N Z+Y?SaGBZCa!/D #TN ţy7%Nv5okF%gdn&6EҤޤ7) >S/c&zvXv*d79d,5̷]~$ ź֛#l>0=;{߆yɏ!ג]ނ1ΓQG6>R_X3%)Zθ@sn& e)ŧlq}ؗµWΈNYÐYq7FN:h亶ҟ(GRy] }dBHTal+k^:QLO:/2RZQ(CmmFLLgPSoCHtj!*ϻDp7&.2J#NˏNxlkA;1C롂8crC%Ӂ=^6tDV+4G:}XD@U9#- *]=^H+ h8T),<;:/Q|qHݫX\4BG78-'S8Xp,!DwC480T+]T,;Brߎ{8NTD 9ݏׁeb ( ZSN/Au-vktA;Z'CT1f, !-Əi[MAZc RЅef"'P z߉=G^Dv k T&[LhkD$ g6g ;:OVСtH<=)LtU&m"WkqM2P[>/ K~P[9ǜM18Iu,}b?5=@_Ã*/LenLbGGEJ`F~wcUڦD ;ESqkQyo-endstream endobj 639 0 obj << /Filter /FlateDecode /Length 5512 >> stream x\Yo$q~' l@MC0 ,!axsɝ ;#"*` 󈌌Tl䩀' w'ɏ'=ڞyj4m:==4؍Qz7ZlL!fxBhWl-+Wߧ(B~TVwM~u3krC#jDvGzmBXm)ڲOgk+=δ-~:cVOg:u ޯJZ])~x!{phP| B.LIttU]Li40Z:̜oV!)FFz$[R k1piJԢ'.RN]S1q51dWu6άdZMhNZj :3p$ÙqPWRD,e#@#0 L4 ͯ?ez)S3*11îY4pI44$%;Rf ؀!SS 'N*9F30J LqņF>}vN&i56" ad4htP%UwlGPl!]%Z$EKH*Ht-lӉchM9TA49B6fW(n!5Y*8?UcH9HD'6R, szi:;Lm̨!_.*D7|P#oKK]+&k!va rkeD?2F6.ĺpB`SK’mY|_}Xe9=6~j5dPLwh2I*!mj&@^OͲpzHߏ^>2yYZju# w/Z}nhb#D\@ 'Z+ HU6\%HP0Kr:U&Bh/{6Zd>vJ_8ԡSdX >!e>-Z}j }T?f:q-?:Z]l'Cq,wPa[.K`ލ@a 5L'O<0PL>}X2ױP6aASxc*ȌFsxv@Y{S607D*H5ɼ5'%/geHLB̨VM}=LRe{ƠF9*#` Υg39g>O$єnWKGZ xJf7؁eocV$U2-ci4p npwr+!ԇB~J5EL.Yˤ΂L3{M+2Uv+fY,Sd"jNFzjf:ĜhΪ|o7Z|ߝ ='t7wN(`tRL  iBN,~j"mެ&{Y;Su*شB%Ǩ$Xeƅ"_.Dc҂N(2bg >eAwc b! (B"pAOF9utK`8Yg"F$!gFbT;֐%:ӝds\@ B,q W>2ISe)ɕC#yr%,]E0trMsl"XE)Z%4N8CyC Wṫ{jʼmsE}3y3-5K|~b(_&>$$2+@~jB>kp?;H(:=Ѥއ<]BXMYJd.WZ34hk#zh([:V(HVPEkЕJVTZ_ '/&OD[@\x9`09<\,"1TT]~E^DK vodG$Fvy8lbPUt˜H4m.Y/mC,)ا 2눚OچXPOY`[ $]^jyf]yM M~;P" g|j6xH61{xh73dxؓ6 SDGArUi?US- %Ei3|BxvU 0vT|"AM~7r-@~:J3 W8wUy0nQ=MMO{6R^OW0;]fc+` O2МÀ61.L s.>X~%HpGFn2Z<%TݪI->=`C+j-5 bKA{mQ#'ـ; &yp(fe% PzH{Hʌ||@i8<ܽauy1j/^~Frv{a"H$<==f~ uzڒY?n5V%F݌Pt,z vdcr_뮹=e@K@wGV # .\Gj o ڡ+="~q{| 'JBzZB{a,~n˻=e%TW.?0ut6&q Zkj>D og;;ԟO|שIy5Nm\3m %w3[CqҩM? 2M5cI3BK2o|.6(RN׹u$̑Ide<1DŽ9,c9bY5Xf>Z.ʭCN,zFz*R jhͱ xs1C[ʈՎ)2W4.۩f]y@-;hEegFe`E8WQmYj't2ba5|0B'$9F|"lPCWZ^_  !TW*e|흐:ҿy!7"R&W*xKэ#]Ӎ* sŏ*^ 3Qi~% W.ؙ_S%b=Ň36}cݮnOb ,v? ʑk ̵a1U>9,ŷGG}~ZF}M|O*}WQ:W9oowP(DZլZLxUzjvc\R4 -Wƕٝ1Zon~wsf}>U(H]Lڳ4 >, Jendstream endobj 640 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1197 >> stream x}mluhWT06w}#` S! 11:ֵ뎭]m)B qMh /W!앚C~c ۷oyz\,Õ :P'P4Ajy݋ϣڽisўnײھƲuCeݺVcZڭ^ej]n{K[Votz}67VZ{&t:AGekiu9,ݭܮ>ᱴ^ pvnܼ :&l; %͆+ۺwJ%aT0EvSlI>sıGqaeﴩ;Th vhb˿T*1ġmuػ`3SUz:1}eϛL\>С;q">KK<T$_Qic")Ňb91" 'sD L%UXպ2~zG$&. v:QZ\qE}5dTBpٹP ȐP!/&aB`aic¨=#z.luDHZ,~> stream xyPwwYHV2ZuV+ŞxJ!@ +H `@ QA⁊"UR;SԱ:Zoi`3o}Ix{$IDǮ[ 3IaYBhH(x}iІ)hT"Ih}FA\pxx >* j\yR+=[W|.7?BK.k32.[ͫL!K-xn\Ƣh6c+4pdAGg?>ӈ "Ex+2txEyݦSdnDƇ142͊LiFˍQƪD?ˣ'aq2SEtcn[?1q;ݎ}/M>ÒjZm׃m{,ODY}$)ӌ`C 5/}4"SvzcΞ(/y" @{6C ;CEJڥ *:.=CM!{D(Jn#QpnI\TJ}^C5jky sctyR7ؗc)NzG9Tt!xљʲvZ,; X|'  ˏd4ѐz=*qz8dkg >;|@dk%l0xgWŶ8 Oh4}07%&,bp?i]|&/{nޢI$٩[UT#=Cq(*06Z@Sd(Rnr[Ue~{Ds1EXC "O qQ_O^tBC?Rnx@?'peTuluVj26cC$rp䚺3-g: n~k|L\R*˔(:߱|:#uq[Gɞv?XV#r;0uJ&J%dA6bBaendstream endobj 642 0 obj << /Filter /FlateDecode /Length 5169 >> stream x²Id7}R '\@4 )\kf@CHk߈F_^p1N^;< \Z{D.&_h[ \9sVĻleɩHF;{|) ,)Z^&pfݓdLy!\꽲a~a4YȄBnd`籠gvn/{{k>ůdM(U2 i#Q#Um-o [qsgD7!0!(i;9xͧ(R됛<|psmRPMI~hGn*oGPC3'bs=HO<ӝsM"- Hم(՜>ORr _gFOV ӀrӅ9ӝRi+96%i$i;k{NmpmkYHNp'Oa!kgՒyo>\;:zҿ"{$7c;fb-F a|Bb/ n;?UhU% j-݋m5nfT#Pomr%k:J 흇 pr.4 nہ:*5%,$?4L4#i? i7~!#"\,}S8mA7u6q+=iI; 0UYals8(p œK^e͜nN!JvNwN&ƎeSI3xaZ[)>[Lx3FMuë=n;;8mvY볗k,9h?$z6.o LMw[ <yU j*?qq̸Ov!" ~$* YN7=S>&lLMy9%(EM4:F(h86۱!Wc>G098R bY;Z& '2A\/믫Q8}P%i"pLatHa P!#"ɊoPKbYei,U)r'3QUe25TTd+Âи)Q\qJS9q Hj)S[ FVnΤ:"->N(Pe"P8&j\; ͟>g0 DhRT/d?w&\6H 19))eDz nr:E2Őo^fj\ Xu_ѨJ`nM Z$P QҲ@Sp3x'kBT|Z''NnXvcSs!+`K>CemnVB""!8"%s:;O/, jT50Ul!gYb:" )I`tNdP⏘ub S)%[ydpJ16 w\5Pu_DQA^N?IOO!0l;A~3c&TxEeI1׋[p$>y>=V=䅘2'%y*Sc}9ŮsΐcSZܺI< 6gKM-} Ky"\fN#~ʙ9VtBSGcZFxbՒ. wnO#&|S?z3j>#3eZr2[diǡtzC)ԣ5+Eto#d`x6%+k<;ՆgcI~4W˟@7ѕQi>d$h&bb gH9)+l"ѣj(@v;ΣˈiS,ŋಒG Ck 2&FTX*{eef/82 <'7+SUZ|liUVaӘwn4д1IV˯:3 7DljOwvo8OW )Җ%//Oc4ɼKNs$g}56WYo}0vݛ}X*IiW7"Șw~_9O81ॄ+L :bHz{xJo9,,5+֢fJJ̡¨cjmacEI k=^.IT4 C Ȼ#Vyg?^dyBJm\{B,X.^V@LU$ oD]׊$$)zLji٤W,@YǯH-c{"9U4]*I.2巇b2^@gH-.}ӨqH^Ij)/7=i.jWߜΤű&hROT'S 5 P7D鴏Y[”Oۙ(}Ք(ncoh[ I0o4Ǧf'ȱ '11a(ϐ95U} 7P&27H^:;*OHӚQe^J˳mcrtYbpĘOVNQ_,[z´A=i<2x|&>Fh+gᠸY5fxGI6{]Mi_`" ƠRC?Qݤ06}2p67 c j8 3g3\UI2[bԿa)T+&nX7JPL֋ua7_I}"pcmO~|ڋ҂_#݆f謒t9nvNtfCxd*<#mqc D(cp[/5n0V7TyHם@?NG~XRE7UDK)tXj>28qe> stream x\[s#~W[[Vqj&x];hImTG$8~ߞstIRrjr>\555_ŗWv/:yzh1cvJEfVՍplf뇋痬b˦VY*m4KX0Q}y06vZU_ jxK|̜c NX^P}E:oɒ9ЁjOsꉴWZuêw83{ۦQL%=ҹ@7s%[{"Сs՛e6TnC];x몷9K{>s"oLřMsG՞~iUuH#tlw9 Y-^{X\Γ;V@\RSKfLRJEo?]H_"OOia7OU ^5?=a .%m3E= “ 2v{+`F}KW+Z_s Wv[ G_mxhj70\Z S"uA%L/sam&Tծ6<О#%r|).N!mVh6Ū6Bgjee ʙqT?̕w)uy˔EPO0 4Gsx&{>oGBi }",R-$) 7R&vuȮ,,8729oF"2:H GJހʚ+MuY5`.3e^"+ V[.BrS#EtL 7bvA6ф`=e4`<|3WmϹBaIoϧQ $2@튛᱕`:Qʶ8lljB&G+HS{bH4E;Sh]"5YwZ~:O,XaZ\-Bo("HXgWÒtiq G^30)HL`vh/uppU}4&yjK+hM.GADla;I\=y^mnnYחMÁ5 \]nC}G`_ơD:ˁ=_Aȷ}0 6v0?aG25ucYfYpOjt PEEܞal~vD:x$pOŸGǦTn:cb8Z*xe_=& &U&l粒˯K*>6:3-a  ?O&`)3vCڷG@Eae)xi5 sY %xF(<?K6S@h R߅Z4<%x /~&HxU hN,^Mhœ)$}eOo E2BuatіEǵ-# q|1h]ĕ=Jy!JѮOpg95UO-/RZk qt4\$|s+%$>24I?ƚ13ĉh~ Wh??%4.i 4}Cn"8&ּY5YP F>Njfq?=^)2 kN=DLB3m ƌԠ=}Okh+jv֨ڈ^cdE61#|IL@yr~I/?'5 ͺE4tST/=[ -5w&~lKeͬMr*VP p,@yr#敷ԧ;JF&?&A5K=S%rX)/izG-K8HeieX̄}x:]8Ѩ^֛<1ĘT \g981ө'aAOފ$G\r!: ? )Ƨ>!uFvEר&3෹n M$ V]yF' jܮw`уM~|ف-nvKIzkkH6#Z'ٯ@$ͧ,pb E-Xti0ڸ f.:F+jYrG*0f4LH~ R;җ}} 4 s;htpO>u<]M>P>iGIӉ]|ML~gy,"8x !b͜lj"btN,ф6NU 9A(Hmxm4VocFLbFsnM4X+HZC7n"I ? ju%f*))ֵTJ:y*§+aFYNxYk "ӌ:v#TM!K/9xOSi?QNRJ=( ZR]tO6s|*?TZSY/_)d ؅H^:@4mY &5f_#U=._]]cu=Qˑ/+@zwחv} g&8_ŒmpwF2ͥan_]&ϸPsm67~g݅w}Whܟ d[,/_k #1=rt[RckVrٛL2o#L *: y1O/-d\=L# rҌh"Rf2VcuiZ‹KKR2T%ƍsx .YejdmUՈcCT.CwLL_cm+*҇h(&fY^u #شVYm7w2b,UTyXn!ٍ,%( ]F3+@tU0D/(pmL0#`*[6$.q`D|1|mU6cQF(3YmuՍŽ P̀)'"2g1YS3+3+NRoۨmB~s2tBhbht} isayP2-:bߢr~(7,JІmtqZ'uI |vY !^2dF1-Knrez8[>d`Q>YJdڀ8zB=щlMx%J!]! ^ء֗5/; $bPZG[.&fv} A.+6,}`?pI?C\ ZkR@oP-9ZKTP!#>R?bQ`K{;0!D쪕`83?4ҟ%˘FE>D" !mn*45r1S!˕n} \h4M W &g5WT)'*iB6_q ZbDY5=H_gT<.ĞXz*/m9Ktz*`a m)T[N%(=o= Y,?UiE` M~#-WFb^QީSNx`CFrPѵpPQ8ksPGTQYk}oCqX]>a t̪_v"g:RD@3͔ 5M%^mAޠlx^zlc_Xݗ)DX 0O2}1:cz6cۦdւ| S}R?BWUר"LdQ<{_-Ehzzݓ>5(AE*V*+D^֒f!Y&I &HjAs7Jendstream endobj 644 0 obj << /Filter /FlateDecode /Length 5394 >> stream x]Ys#7~Wc1B}8b4m{=^=ݚql~DE7EiDJ~߾*%dFLL4T+?'K^\zM_'韋_Πnk]Ŧ|tͤym]\yﭷ%N|>h`B%~=9k@trr"y-́'PCC_'ʳVzz"uuz:P^U+&˘tƊjF>ޜ ]͘^c==gh#mƫ%ߐSYpc#sqB :ndͥ#>=ާyuUO 2 TZ3-SjΙf|]ެ.27cB*4S87S K͹.BIl7})&utuysLUOap bTջjd`&euq2i8B^ WRo!T* {`K}/{NiA{?^Hn)̝feǘE1 0RN{I06kDn+32yCkc˺)!?{aF(Pl] 8lYGk ΃h"BktOUɕpr +@sOUq==X9lݸKe=LlษMe!t(t1''TC!Y2(/ŏ\ קjXy.cMekRO#z\_x$TY,"Tzu'1]40ԾDۂPpަ:bw haBL?"D08р64Q2 .GQPΉޤâfMܡqǷHL8 nEz+(Zhx co MOD@2v6߷<sQakߑh<F@ܾszMQ@DC$n~ `!hH1w&~E2{t΍cp~9s}WNZ‚&|߅I6l)ەIXwMm/ u*0pZ9>y%Xͽdu/In)2qa&nM kjiU>OsR`pDZz@Ba }.%Avp$¹C8‡ y) oZ. h/kK"dF`1|N'm< sv{C)19!]_d8=.cki\YoEUh6HMmlH1`楠勫 Rml`]P"[aIXCCK%M׃\ <N0Ϧ 42psU;mvXo(ۦ!3&`ѾÆ&)fb`- 7+BՃVɠ$n75@\Qf9^ʣF[ `Tptg? j~l \t#QTCAO)])(͒@'wv^c9.(\ءmËײ0-u%}7"C(v4sTP~{x5i9&{U y3k{7U>D5GOdG7R&Ѐ6Է[6ۤJͬvI" u 5[~)udEE )戅&QK&dlخ>4e:$cܴ`}|t2maN Bm4-1tM1Z'd/4P!>w7ا֢USJUH4s Ď<]a"ru(ey d, #vGF2?.PPJŵ(PDkSyG7g,hEׄ9(IԀ j'#y$Os0TAh\>q UsO cN9q* 8 ƤAQR={۹!BnԈWhPoKF+wn6xÊŃS+g3.uE5ιl٥01o?7X @bz;K'J,5fW:è(cmt ~`T!]gHsI^tRk#CKLV XWujiC`!1ȺYc77ޝBv5pTb<. r$ c'p-d/f SDxjiD>q0Vs)11֚8PO){*pO=(:!M8JҼcw:v[<>`H55rH&z~`h[0q}yy"OB%zys<^n.>n(YWbqϗɭ}$c0 pյއĕYg`uqnbi-.vȪAoD3raʗRdfO(TY uP_]Kƻ$^ޏx ?pj[7s T &sjDAp ;'2%km:Lj-#f 15^a r;OK܎܎-J#]~܎24FvHAikR?.CU-ь֡`2hwUQ44hDKgzH{qx'ކ^B9'w2}pER̒'U~#.֦ZQ8 :qe"1^g+DFTb5,x!pȳ*KfeTvpOȷAt =S!mmBSs"@/GSo@@5@}#tXzFUa0/ eySyK`JI,LJqB|N+@;< UGcUt%Wu1z!2> <\+<bN^ :G*;^t=\C775v2ztJߪt@ـH7m?.4AB%hBz#ee%w-WȢM׋v Xn;F };X%2 7AQoztw.}I.q\HJ~[_.+6u#]8BbC e(7jKˋ$%^RʦTZ 83C/'ҏ(|֕`dQWD:V`&{B&>aID0I7w+y@R%џxl𾦲ͿnK/ɥ߿+,e!yx;\R{3x%|xn PC?#"҄-T5|ԈGI҉pAÑU `Μ\C/Yr•o/5N7?'WhFKx%|6r  W/7 kaTQRw0"uFѼeIH/p\x!릗$sjmvK嘊KaBI16wC<剿+YAHűp0lrER9˖-(J^[!ogx-2?|]T_-!Oz@ɣ>?(_|^oe`ys^Gx.UnUp5XFډ}(j$kܧCzKj\,NnXufҴ:N,IwAggsX<>Q *y19sàyq90:d{6'PyT'@/Y/8Fs&'^. VvB>ƚendstream endobj 645 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7150 >> stream xY XWמ ֺ[Z7Aq\ (o! KX uW\*.Am n_ն.@B/yͽ=g#'X:c7Ҍ?Eq:ZK>49YqCp'. z&nƼyL9}<;@/n ;'W\wz&.CO&HzM y/pWc%c28Hl#ˮۺDvN{DAA8/ YB2lxuC#smn=)`s.I}c)nSMΐ͔ϊxOF=ob4@%6gb+pW񡁻G+ H ȁ$)㒒A X 4K7H7[CV𖀀JPʾ$5ՠ09/6MJ2@e\8&!!6mzW3t5X FPYJJExjPGmEuD@ʺϜ+ ^ A׼)}[.`߬n;I.`y2GS'Hdh~Z1ͦ<ڵ7:NĞK=^"t JOLf)@#ݩ݊Mu#Gp~x/ ) H&~8?Pgt\>s~&Ti!N=xeaPC_xK?h㊅>N1haF@A޳ܢ|Y:e_'`tbSN' A;8~<NB,t9/hъlmDInwAWw2P:jgH4 ]?\cvL*A ?%aJi;?~nEL7н 0kq tr%e6n "$J;a8xi~P^<-d5td$otsKАt#e<} ʇP?]daIʵ%5#sZ ߽2#{Oz7`YltP(߳{i#p1H򽶏~0=5!SdzSM@o!ōM=譅/C3$̠UsCutZtC ctDb*=u9+|ڒm{MW$v@ D%S{fwX ;uTW8YzxL;h՘V]Y`̷ !')߾tE [c2dlH1>=͖cl G+l8t# u+-"\h}i>NXUG(v*"Q99Njb}nzC'tNU}s*|_Jz6ꔋL#84K#\߻ p52]֎4j(- p9]K* {X`_#+K~d#y͵ToĐMAN9"G-O9 y\[R~ג cQՓPjؖ hg _+N:F鐌 W2܆XȔxqᩉ"TxƢAdu:2CH-W=RSj2sK3ꗑP] @3H/(޹kaWt.S-&#>3=Ɓ:ieqmn9j6H]rـ$Zoh+/aD3h>@ +=Qn PN?o`%E2|ѐ-E5rPڏ_¢Ǽ;= hmtV`;`wgcwuEo5aaCCǿs3*Fq}J++}ܢ|(o`&a$ns9&f5wFℙS$$Fzч!ߘIQ*2LK, mOFo3lR4/Fꭔ:3RUQP[6Lea|n/ѵA I$2I1;5gYj}ڧL^ JG#g!˟A+UC1X絷ªV>EX{7 Q_^}uzk Q>P+d  deQpBOXrXinc*-l%&du>MjcuItdq+ -\)SMɱ mw8]FBW2=8L>Ϡ?yG O4GpA`&VPW*<؈[K,Ulrot08q QT0ub<[A+}Oa7n=F!jC锉OI Ni^^\^[[^^˼ =`5k[` ]|LmٵaA݌GMUJ*QȦKg52ҫXS7u\>[z ^XJ _/(j'mϴO bdMwx6m*pòd' íFꙸ(-Sк לy/3(: xx`}bdi8㧁lVG-@˫)tj5@w=-وTBAN>MfiHfF}CP`GO5H4M7t4eN> @p=8u?邦ipcqʈW\> D9lٲS/Yhiϟ?|3|W_u0}aF tFTɺ;w\:.Bb6G.NeNM)E$֦o3`ujJ@e 7p0kx8ZY/Q7} #zɣn$#7 W -O(vd\.ˤsJ2֎'.?-mqZ^+7mt~va(*" TBΠh")&DڂD)Rp/PRVPQftno0=֐ڴOpal0`;jiؐ~C66Mؕ[$$l\TEI}Nje_=x)<"~j_(P*C) N( tMyUZ 'Ѳs X]]?m"({ #At̯H\'S ۻ;kI+5 N5Vx'|xkӏ%HDl:֩KH-y9W>@S^,0{>Ph2]ԌXA;gu3s e#MU+%G⫉,<%vG\[-2F<0-7|a 3 А;-A?gg` B ENhƜ[zkLmkZ }NoI$A¹Wf4a/bшd $Uup=gc?"c(:5:Fh@-h$j B u >:dz>^q8 G_|U{<~]ݠwx\#Ǐm?y뇄u/54pS`:p"o4_v! OJUPzNGiMfUbD@YѬ* l 2olJ $IRX`*VA^j& @v6|)@V:ZhlJ=Zx9 KLdl՞K"bc9["RU-*M..;u93LTNM#^NXЗàK .Ҋd @ t ft;G]i=q|KAw 9{k4 MmAr")>q<s֊\5NϪf*в,I%׏BG. B+XYzq.ı?k,pR%O+]Wg,M<2t[XC }C@u{WH,W|үJ5()/5iha|w['$))2(+c1'ά޸e݋OY@KUFjEpgSF qɡh -Y=stDJ $Jt KYP8Ғ̬lN00FԀڒ .BڡҊĩ/7pV6 wM5/1Ǘ &@*FBO;)K Rrltl6@_}{g8a*NڨLčy9LMRa?? ^s>#D{>XC>#׋EVmp-c~ਟ?AI\f2~%aJ%UZM}p"7FCAޯ%$gu 3Fm[<)hӎ`ODRe)(TԹVjpvέ༬,׌N[Fh/ Ȍ&&Ʉp \-MKE!ɤ(b_z4=e-:nt|x ks gfL4-͍Q{=ijP#='Pk/g3΃sTgЦ4=܉j[3X ;N[϶ mqvr_3x @ݟs @,|b?C%k6,>,8Z=y%{5sZ W~|ra.s{5忉oJ͉ (.ݽۨe8Ig5F*gtf^l|0l1w1?kx4dďx#J223҆$сX ƖoDŽIobfBLggYA7ZoKJj]5S Ar((Msv8Zk93 I8p)/ 2d6beh^]d_QhvӅI) R*51%pū\GpZa,]ˡs/%Aūk:vۨy2 XGRnY3Yy9 H);^\8f9HC=*a ࠲3?vWC #ؗrZ^XC55ʂo\oyLsӏ 2^df1aY vspԡ<#sm0 i5>P:#/-ǸQ%F"\L%Ҳ ~;}{mnoptȚcj B#Cڄ+=mڸd.Z^=@OXvP\>,.'QT@0olOoiiH S=lendstream endobj 646 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7896 >> stream xyxWa10 +e!,5 @ŀո"[4:eU[nrFؘNL[z1 ْMn+z,˟hQQ<o5+~; Kl&W0|p틓8S|$$) ItdTrЉ͛Ӧ |;.\&$9*<.$#6p84:<9#p›Q O6%$.iX9oӢ7'KR׆ąnbq\BJr$p8,\OQ;o//Nؾ$ҤeSVJ߷:#tMfuAQ7l7~3b)Ӧxms{ M^1z j,GmSj5LMP[Eombj2ZBMvPPS4j5ZN^VR3Yjj6Chj(5zFP|ʟI=EԳsT%^ =A-%USwx= :8o!ӆ4ё%≈whOzrƧBGu阧/?3=幇O}煕/zů_ZRKfs'P(ۣ%~̓clc7i\ <:F!nbFm^LZn#S5PnN 2ҠfPNk,2H klMl4z(u gRͱ{zi}>/D٠Srim@W=]rg~=>2* zs¶5{BU@*.z4dS6W2RZ*uV[}Sx>||3] Խ9뀣a0Tsetm6];٠(ך[Zi/-11K\<䣂 -Pv Hՠ,~"J\ B1 Kh|}/[v?y׃/c2Yz"4Tp$(d㰀+zFZ5[GϚ2pC.K| / &G+hWCBc[.md {_L0oVIAީnp;_h3XHTqZPoĜZDx7XAӈw>+A:f75i.:Ђ/k'{d]Bh(&{txMO3BeJLJ VXPϹ;5d$B`BY@T ` h奫RiXȊ_,Ló@7ElJ a'z< y{_-|V5HT5`*Sv9y`,53뺅Ɠ|YW/J 2Ћf(f,~gv /wIxW٭H9FmNjoX{f &Lt֤QFDJ;e;yLBZb܌W]MA]V Uz:籰Bꉰf0m لuWp +ne/t<y}z# 9Nm c5THp*gĜ[>STǼ$HT)[Ǥ-H\d5Y O pǾ Hİ䠡e6/<  OPB&ӷE9P#ڄ_kq,mzHbeQiMae-ޢBy;@|nt_;E{XNɼiGz091VZ&}T271VC[&eY.8 _Zx&19Z ._=cK\Ъ|(`a--d*KJZGQj3%2\^Ã"9d1#.ϰ(ôkߋ;Kw8s:ꊫܩ1.Սrܞ ^ 2Nn5YVQ@`1{ l,CM&XЋ^@37Y~^Cg=t>ҿ$s5IP%44htыn|d~(('LMA+n0l_.Qf mŸMvՄuziذ+g[L"֗k.^y5{c=ltY6 "Hpc-rAA7.K&kc34a{dYjcE7P:(X+묆|tfŀO~yDLtQ-GY 3F ݊Ά*/BpѭIO / yNc} $<1u=3#g+%oor3&8 .w=ȣ} LfGNє 3gB3 64ДJO>4Bx20#]0jU+"@J'x?|_ۨ$DK^{F Gˡ,̈QקwE$){Uwbk;啿96 Չfaw[f:pJ_ yrH@kѴnXy"fڬ1H!bMlޮȕ:NtZ^b>Zۆf$x'>KK%rUr}b$c'ןkʐrt#D;.t.yUɀo +-v_B#kmmX&XV=v(ЕPe,I/pJYdn@ d8VKeĴЎֶ ƚTP˓H/'p6u`BGK˭YsrMRF9fӏikyHp %\䣓 Ci*rP~" [CMyr f\DE$$Lc`䇦W}۾P>~Z6ndNgFx)XlwLI J6BPb>#׽?oM%wQ\fuJKL <y?bu։~.ǔ7ڊbF'wk֘ݑQBU1Hd4U(~'Ϫ;]2߳3T(ѧC--S]!-kOcϯ=oNҪ&S(͋zyn`l>xp;ho?rjoFCɐw=`"W7$!!>W\'V d/1 b clnzs( xcQW")󭅞!ɏ+?$z&B-?acE.tu"4Al+I`(0EU5$١*bJ$Ό:|=]iU2NcmHC&d csIґ)P>G#Jii9*&agVvy%〴2}SIs&QX(io 16+K.k}?=rAi0M?M^aEvĽx@aB6 mz%BHֲb_~ ۢwȏdP}xFS7|GPWxOU )m!bSOą"\DF>DY&hTgġW0;/wjG? ;ì%lE}i/R_b7+xhCO=~ӳAF~R@C+~~ -mxN*㑻.^BGH]_ 17|`ph!rңUNyIeei}J*&V;K8tH3 1䔶XL`a-m(4MU$zG>sMPаW\ d្8)JQcC 1m}|-iG5G86cܷa'{B5#9,2$&zZxfG˯#'E_IFof_zw / J PzVU $A1wS/HHlnΞmh֩v?r K祦RS {yZ\u(F@tÁX<rHH ,$,X_H`'0-:g:EKe샿⣍Ey SkR痠ah8RnINJeENTy? l*bi7qʘsO<6`~ژ_rH[=a=(<+@Mz&3uyQru{c+bRf 3T[ST`*&w#|tMaHh69xSAkAr_/|6ٖ)MM)ά?]$z'ϡKDZ=jA@i,_88=zSZѸO#|mt]±J)5dzNY l=W=h+|Ѥ34z} Ym*$$2l/t1DeBDnoaRl0/u.Dvr5h -}U%U%Nw ?_}}&޳r~+T.kUZ5ш< c2d&GAu%Wnhdg73[1;W31 O'Hc/zNwդl :b.[JYK7ʖdgO0'wԝo]u$x>xV-WL% l ٴ}RȐ6{ +ꜥ]'ȯѰ&,:9\ol=?GY#>|%s?f, :2Z@_|֑,[W5wsw!+ \{JV2hj6e=hD}xit4;-DAbJ5FQjonY kjΠ[ Fs>,>v6ZV%`*a; `)DnQꠜ36ÒkYz&=scҭ{~xƸvGg]$GkjZp+9G|ޫ:pfScsӘYxd:^[蕥xp&1SzıkSN0xĦe3a=ʖ ߌt=L|$2ym1A/1–R2j͙e]oa_UZn#Us=%\F Dg5TU(ѝWO1_ aI7Z@cSXH*>zt_,\ G3ZݮӗPȻ8zWv$;ZGH凔ȿ7g-H#Ҫm!* CVh G} γҎ?2{'B؎%>=̰s\ÇlÇSfendstream endobj 647 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1210 >> stream x{LSgpfzzqrM.*F0+ԶPur/= 0@WP\a:Np"bR̸-aHe1KV>yH"@F$NHX>>!92i.V@>'d흁 $ ԂIYE\T\\nYdd.Acds;t=o9ʅY,պTc0/LڵpVE%fޔgp Mc C-%) :j+cb "%I"fS"HlOݖlA xuʟQLX&[FZ?+2`!k24l' ՗z=b!\xޡqJ͌^n-^P\rj-ߎvz~1M7ppLtĮWk=Γ;_֚脍YZ>ORܯemQh)^5_#_ 5v2ՇӗWkT=ʫPG/g ±_ن#W->,̾z w'U#-fk]>T {њ}U DNbXj'{PGJG9꣤Fx0%%)< 'Nx֨{WҨvՈb õIB(ycBR}A fb]77(Jo*Aa2{Uwд|3`496×`h9 =5(  NYħ|~:L/)=e`|n{oo}hk%.I;96j? ,P$CAFLOFImLEءt(*ӞyN,zg5 Ϡڟe> stream xYtSW}FXb'0N jB1 ܋p"[ґ -dc)5@ &@ B X9\%&&Y/B{g}vL^t'Y8NKṪ3I_=>bAsnHBEn v3e̙3ƻL4i˼m>^.+B/.a>\F gĘ ^!Q"3%f[tZ(~.B]Vz7sAXH"/eE_d(0慆-X(*ZtGWwϊxߕ~.(xCȇFo&MN2ufn_yYŬfF2k+3YǬg60c|f̼L`0 "f13YLa2Se4f:Y`V2o3yqa0!LƁ b #c3<* e10)LoFg7.َKJTh?~1 }3g~e+gsKߦ~3;Op P3gA;Ql><_?5Cr}ȯNNG8/v~8tП%4|?j4&ҮsD|s9YKP2O_6$rl,p\Ӡ=u )\c8Azҫ 9…`p8mXı )OX=aOR8XD6{]BKCd>≑uW&1}-нtD 东ʩ ׯHҿ p,Ie+|p [ɮ’J`Vvr~fVI&;D <AAcD+Q&{1pA8ͰNV=nဢƳրz#tp KSĠHS[d2?KV*U+]f;V{\C> Ի+Ql) %]4Ͽyq,{HVd*k_M wE{ٌ4` #dB|28,u5ʱ;Qa[r3GJ+ 1CڨkP94 ]gZa/qu|K*(;6اk~hj+;yf9N`*OZƤ@fL4=$ɓυ^݂Ό%Y|2=W6nPBlp;;䨽P3RcnυIq,]K@/ JVc9#3G4Dv}qoʺ >g&VPkSK89qb!0GzЗW:5Rʼn)E ^] Tz{L r*?!S)ɂ:+5-KW z~K\Kjr:INJ30 ]i%J90O:.jgߐz x|t::L4)he_ Z8&?ővazZWDzYgeY_nzeg$/bOO9+X:,JP!> 74P=j/̂@-Xp {`-i5V"%I5y܄&[I#Yj!ڃJ8bW!&IixYUvࢎњPm4DV}LE[ R;ؠ*kA`aCh]޶n[J`C>e&o{SԧxǨltj9ّ蒶M׆p1T.K n qԍJyftN}_ 9گ۰_*}GQ-Ԡ Pn3(/S]QADJyZs^G0Z4rj5)o)@MiWB7mv.;dźE@&>+d盠-Q$=zt5jVZVA%HI(3ny^$xU!ET|ξȠ!/dWP j*:aY?p2q8]|tڸԉշ$çp5l8#Fh#/z$fIΡr.C~v!j;;麮H_NsMObS(=ÉlPm!ڌ8u։"fqɮ͌R#*Yhp8rU$ܧ-؋ڇTJ)AIyxGZ>;<G/GBmI$,-I0Y~V^C{ {/E&joD4CFƓmxz8ΖԻNY')|ZVK7z/^ZmZXTiUGN;St^fnH2HN974z9BIEA>3MJ#'C*l-!Eh.w&`8n{_| x?AC d)YqE֗TV7nXֆag$]t;b>?` ^q!sɏL '/^t^O{2X[$/ũ0bЮj0w=s ʱx̗8˦g~Ub$Z]CY_TUoaTt6(1RC UeZ=tzKBKdyOsN9m0hYJHSJ *R|c|ס؍c uk`%7OeHrcѱ4?0}T]N6~vwv].4-B~`\$lcIvq]mݶw8~ٱ"rq'. ~SEI}50-Glq/i VG",ufc5_yR㩚 Tt`ˊߓps7]y=WЩ@U3V<զdkC[3̘:o \dk3vg# roZ0#tNΑ š fmA:_ +na%O/@g04lp+_䲫dִK!iy-vf̿fIΙ|Jc.^҈㠜r@c%Ds` 5'Xjx gj+c5HJ]مm d.26u@h(xFkkg셏hs8X:'z#MsN.v3siBʾr 6њCB%$CLRJzA(v$%slWƾ< Z~u4untډ]-[5s#hhIW4*A'*UlKi0S P/t̚0S^l@?yG/[_Jҷ _}בnuXxRSvy;ib6[Kggb л{i0BQiw#E@_~K,GN'C!h}qtvUdDqx)L0-F ( oUKU@CRVPƂ+))4\;_a+jQc*S)5!YtkkbRU*Aji`WvC?YJ|{鳪@Sym^O9N`|Zi v> B \&8➇dTja#B$ IY2޲r y4~C-#^sƎeGt"zѕJc3qg|1Yxٶ*lz ˉ3%mT`ꄸ8sg@UT ;_|}TuhhTThhuT}}uuo bmhCU8`gTjT}Ld?y $Seg|9>a"Ƕ@~.Q#%{I%%i Zkew $ #}^Ow7FW U$pk+Jwmw#oYJYFY#+ݔZ}^0(7@u:ma+=*=UE7o"+8=\uƮ%X3|awCNjdߑx3^ GxOZ9ޅٓ[xj8 _R ɑrg|b N36.U.p9b׆m -P }5 wA-`*VGJ(L[÷=:.lt" ϛ`Ͽ/}\"wvSO{cΪ9MJSQ7H,G.7brfM 7eZLk Jp)ڡ?p{׍ݨPEaoNaǙ4k'찦443}2JB ?9۵Z-aǾ3fgB`ƌ*._6ΔǤmY>5͘nPTHO#THw Bai[p[J=@XЌXf7oO :X-Pf^ZE*u/6k~pJI ݲ7 ^X5{…eEBH Og$Dϧ)xG{\ -~=mUg82=>B8 .n7[Dc2尕{{ةM80G;Dr? Mpu㽎X OZ0K\8yG䋯\[=tBPGuwv1~+YƳ˜G~5@s~YBhkN8p !aKF4X0{ώłNвkU"khN7aYI\P&).b-}.Q~.U0 Inendstream endobj 649 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2185 >> stream xUkPS>!GTIݞ/Ե""2H1@̍\HrI $@.@" /XmnwZWvNžL|<=1Ȥ}W\ZSLq'G&f@»ޚ8EE?Es0&!,' Eb^AYnݚwVX\/rd0+E\^P"|L&[-.]&lJXʑ$=bi~C@-L[6J$bN0/_,0l@$JʤܼD KvcqX*ۇatl kl+ KƢ91Ma3?!q?>2>ߞ2E4P Q8U$oYM師mdIQg)~`(Ё^UN$JH\jqv{9ap)rueC$byj7qM~+z3I^ ?FLlSOD/Aw! CԢ& Z~EP6;t1O\!{>yhwvY?;uCe -~œ4U]Wm:bך$>ڜ};9Tŧ(58Dt@GZ03ܝk_5F|ȉpo{*1DNvVM1B)g~Ect< ^j';xm' GmkOշ5=hQ}E 2iWD$O>V:ݾ1'zp[O7҂j^G?yWzOk"vOo/,j)hzwvYT>`gƺhfy20~a]tb4ALW13-Vr$(cmCٽ;_5Zy_m9uUVGlN|4HAp€ٝHtK;  `TR5Fq!y%gttz&T#\ն{#=|&EQY 2UxOIS? )6c{B2凙dmATyeu;b0OspdӨ=F&>GaIר3 R! GAE rz>h*=%EʼG@Ў:7mRKt*"q3{NER/W_F%;؈B.VCߵUs ]$W!aencмkrΏ Gmk,-Yhon%oi?xWyTǤ5t"iFIFkUGVWRym9vuD_! + +"PչD4=8:xJ|h7epioGh9I&B/* ע$J٘:Jay!mO2AG U*(&;eP4#(328kb61+|7j!* rsendstream endobj 650 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 393 /Subtype /Image /Width 920 /Length 24792 >> 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("`ycpǢ'ҒhkR(eF =Vg4T״Ic'trzzbkWƉh2MaHہ`t=-X0KMQ0)QERZCaZjV}w+6):Ia qWޢ6<Ή\[E#rpYcֽ3DӴ-Qh eNC\( ( ( ( ( ( ( ( ( ( ( ( ( ( |]}\Y˷tD*=sv*F't-nY10,C.7`P_e5YD$+30v#"j׶m$Ѭ,>N| |[o+xXƊ )1Dߺ~)[].&i 1_M5τn%yexAgv,&\>+@#:FF?SPMz[_x~rHO8ߵ[lcI?UUͅȌἙUֺ3m}E9ڊFMWO<]th&ya8"Lpp/A@Uiw56>ɑO1C}ia ꛲W?\]kdž Wپ`:|{x2M!LܭdsR9@QEQEQEQEQEQEQEQEQEQEQEQE2YR$/#U, ˱>+ǖ~a꧍;IѢ+G1`(Qֲ=4kjZ4j߻2pG|;u7zƛc2yio+ K2&kw5/;V9]I8qKZM;֩",A'$ ޳kl-EB_p'r μ p^Y.}2xZBݒ' k/.o쑫Ie km oa3+CK:xmm$QSPK.~,d-R-*1:W|YkKm WVm9+69K--<;+(KP0763Qid,}BL-lNciy/h,ėPZNH}%5eK;X$W ;sޫi}rMVPݐNy[YDŸf+\'4˙'m+E2t8#,=حK~\5nn?kY(އx>X,ഖ/6dY;$u]B-%16<޸Qq\[2,V=\¹Mo74.iob!PfFzgnI8P5oA!X U`$-QEQEQEQEQEQEQEQEQEQEQEQEQMwTFw`$6i(I@Y|=Lw!ڵ: `@y'׃Z:ƜF7 xpFʠ(v@sK@Ve׈{;ƴ @ $zu :nM%B8#r>hdjz?ơoh#cZq> OaXi`ӭJ8=wg{DҭM:;C'bF@$gf!R rsSPTߢ:q*.U@"h(((((((((((l;UPI'*a{i{m:t5;MZErI4%d *6о"٭C%LЫ +]@@\ hv2GG$OqєYw5k]KCQN1[kX;m[foA2%tBoc t3KYe0+͖2 6==eaogkn985W-'|E4OA]ݖ%m:IjXQv3 G𵎓v׊7wv}S+ ] YӔƚ|SkN.h]#DѢ;y$vbORǓIhv3]}Z8e2{Dch BŋEV?5.С#bL#P^; B@G(,:@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@5fǸ`[-{O/s.sEs7Ӥk{BNRGU)kamo A#up,O'(Y𽎱sԭqoy[YLrm(/2M4B[dew_BOoU[OZ1{mjd:UM댚lƙrm%_TX~0_x1 HX:ukkUѭH-#9F@@*jV2K%HJYkY_%LddGCXxMY{GHGO]:lܦ%T`#8 m_–:2]Z^Б֤|1\Kb%rdb ڢ)jl=&uN34&{a`ܳĄtk3,NnBFbv/?t^hVūx3rzԢt((((((((((((+3ķ iN+YYOSӬo^r(p[ĐFUi^FbI FFPukZ݃ã ?VF`_ӊZEK@ \wFX68D]]r-ު48gn?ʬ$1FHt@>=EWI|[sHWG%8H3-Q@Q@Q@RfI3@ E&ERf ( ( ( C2xkVhWs#; jVOԷ5^l1[Z;*,]PKOhJO%T )dif?”izp >ЈJEW:}P܏C af)ihJE4EyiPDh:"RQʖJJ( m?Kp"Q"ب!++Ҙ]-Y+(((LI2(h4f@sK@Q@Q@Q@Q@Q@vco{rnatLL$ҷ8?Y|5şJD*?OzZq0ؿlv1qo [P>uկڦ]%$kU mO]}u‡((((((((((((((((UYV@5UuHmC klm3_*_Ӗ\gɹ:[e@hP*~%!/<J-"I-CgQ\:٣vhz( ( ?TWG\,_\!]QEQE▲<[~g$}@ -e&%n}Ǿj4,-5' eXy]-t}}C?5@|EmOL礶1$^my^I]L,/8+9C`ׁgZ!qk9ޮRWȽ"dQ|F>/0`Aκ(]#ŖH'NDF95|Q}%,V7mlK[zSӟ]]Cyk 嬖1ʻ]d0 U( :? y.yw/ڴrN!'<'{(((\B@5T5Q4MRnGCȢ by&$X((((( K,g-h$`,0(XD5Q@:7lM11N0':NGEs"ŰrYQM0Shqn9{5˄27sWWMajڝwVS$J2Uu(Wš审d4Fɽ7Ȳ9e<»@((((jS{JW((<}e~Dov_@J訢((((((((((((((()RB1KI@Ey C&*6|Jp */>xI#e(z/1Ot=AY"Vt՚+c[17Xw;rHˆbߗ?ր(( 8[t;q$XfzU=,&E[Z,0Op#/#{*j񥟗O_3Pk`i.'_ 1$UA78U$J}N [;TtHfwf@p1@-7=2VEMXg ZIXκ 5)^=ѷg֗mo t?45=cq퐢5[-n.qsOa@(bևZդfQjDׇX:FOict`PE5xZҗH޷uu۴.xm,(|Jds%sh:D -jŵ7q,8ʺ0eaEA~EFӭw 7b3J`G鎪 Z(((((TvO0IJGuLYHNE(=)c.<7i{z-bV-a=*N0~$8dT WqI>iֻxc{k5Rheٻ؆Arp0UF9'jz,ӯxbq x9(ge!`gb,z+J߉D* 2-#D@} (u/]Z^S. [229EcBW'ѧU?9m0 I*"XYzOHkD r@'K^.y㐭/zƀ4h/@<'_ X5dm;>U@ p?cϾC+c@åSalg `WJZ|9w_ie*xA>lmຸ=\['0ta>h/l&Ҟ3 pW)=w y 2y淪[7 @1}FSn|9i<<6EnR0ST,޹7`W 8*}e"x*I'5j(8lf,Jrj7$0&7;>_@-6@÷jݖ(]uEsxH?)$T2xOLկPxlX81P S@vql5 xҏshۻO':Z{?Vb>qW|GᛝcSR{ͻ[\-$e`Z(m-cA D@<5/ _ wH.}UXK>?jR֛f~ݷ㦀14XZ5k-j3좮Um0cL*QEQEQEQEQEPWźV3[ܯ?ҷ5=cOPd$!q|aGr??Һ RHܠ9]G#y /,U]YiX08<=uluX4쇵7>t+ nT}GOi3MeLqpX!> [kj6q,sFqut fe ڊX$]T??ʀ1 G-%_6{W.-gO{)$vF U W/Vs+I![nވ@]N}L׷{sm uBA#k0GKKSQK|Lr ;eq<Oڵ"HUުh1cnw($nźuV%Y Mep~ӭ]6#ea9NYՍD<lEߥ" a"q|Q{Pm4ƊI~"qH8Oͪ]F鷐+|0$#8<(曦CYHIy,G,k&[C5S mPcdd koL[Gwm T]\ύ9c=W?c+^G&FETuPN2;BFgid3\|5c?$+GӡEajt ~#l@0(џܚ=2f7OZO_x_Z[h*c.|p3=x-MKm6Z[Fwbs9Gaz/JZ(_U\ճt>'Uʧ2VӜr ( x.>1S_ӗAZ騢((((((((((((((() -!@|jڪ΍$ҬUX~sg1lP*/T?{9kj|"ٴ'oPXg'+~jޮvE/ oPQK@ EP[0Drv:@G<3].EsrL`#NYڭ߉dQJIŷ//~Q{Ppij! I##5f ( \D&~ ~Ln7&}[w"t\:%OXm"X_+xgUL@yHp d cqi Χl/ "{k1;6>i>bޙOYjw*gxqxL,ۉ'@Q@Q@Q@Q@Q@W$.q+ql3r`և>XksĈeE\pDikK."O;Id`JZ(wFTn |#Sx\G|6m.%?uRZ(|3^mM:tYVDY F09ZV&hjite2#'<+$$TEARPxsPIi-wC3 ?1oAukoiKCgi+:<Yʨ^8 (9xn߹2#s]\JO Js2  ץ-Q@Q@ KEQEHObr ?Vgm`ZQE5N|N@bjj[$j9Q\,hܱ)PC~SPEQEQEQEQEQEQEQEQEQEQEQEQEQEQER8/f׵v3̍lҫr5#kGtZcԱx[ڙ4?|dݍ90(]au5 nWN?D80x[V%PDdA?t4P6.f륁 Kb)$ȰJx8:v!']iR$>%c/nߏ]Qq\.-/(Ix4<2!]ą8$xq@jT,n"G +gs/op]~o^8K2}2((#PP0((n%c3+r{YtSѸR0heַ(rBZ\XOj;btc`:]~hhȣ"L3@ E%#:rGROM3 rRccvsp'9S.!_F3]=s Ү4*Ioӽ;Yt4QEQEUnMCI_*K51W3OӼGgȰD['z/OWY(.߼ʅ2HG1u}eO??3V(sczsq֜~ o[أtW})OՂ'ccp?<58{IMw4jx{^H?5!#d5[SF(&w=.i[Xfwvܸ#W^`IʊU\*2LJZ+eu4;qcO5-PEPIKEs~;C+*75WoAKvLk.zr0/ZՃ( B(RfI3@ E&h-4KHE`x@5 FstҸ"cTӠhfu#Α8cb8((((\Vf[bBl9xC[ n$NWo1@@u(ؓ9R[ \[pGݫwF` ǥ˞Q1i;YHU}SʳDSqԅWa1@ށ<!C;yLX)T3ֺDѻ8(((((((((((((((9Lc u@:W= 1_B:PEQEQEqi:ZXݬ1nY_/ @ Rb k kcj EQEQERR@zcZ/^6Sڲ:Z@:}ҺJ·/g5iYb4?R> Q@xUC!YFPų]M&2l;S[·3ssMeLj]5ʯF ~ou&S7N7EtP[cH=kBJZ(((((((((((((( 6څ@ #A6=G -k2*@(dx d`޼dZy>Q@ʺj(quPEPEPEPEPEP=*{jJ3Sk;nOer U@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@%-02x CٚDMo F7ɟ[-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@Q@Q@Q@Q@Q@Q@Q@Q@lj='O:O[°AK_+tPEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQERsǷ2K2=W?/]Xg l-T}?xt(`QEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEs+*ATu |r4x.$^Ϋ%QɍtKҀ(()W$R{ I%Hi$uDAf8zX7>7u{rJk"::eDyNH8zM:vGQPt-'PclΫK C3; ?ke&9k;rsRka0NHE9Xl4jh{FyX1]!P@?Zċ>gBOo 2u{NZC7c|yAlG-z)€*=yV(k)$sURI֞Ef6m.պx-u#JH]y6^ }yR}sƊu5Y$$X\<2'eOֵ(84Rf$lp $+'JZ靈oL; #ƛkoy 4!#c I'=lQI+,Gʦ& YlrznlQ1H4qMp`lĿ-+Yd/%[Ɣ[FW$@CPj$8Q‰QT)l\iWSϦ%-ܖhՀB Ҧ+y<9B5UtiKeK|#`y#$=KxDcQSjg[ȥ^0+@EE{9s/-ԋkm,f{!ntdGn=/h֭v1ジ1zD*v@uݍƯy6IoڥGA$bz宓SL:ɵ[zk6ЙD$2rpZyH  ka#\Z[[KEg|'q=Hg(tSu5PB6ݜW8=H &=.cX{ %6 ѭtXqwq"F;1PEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEKV ?_UʧS @)RO)Pil-'9 QQ6[O8 z\EZ5*nkmTg+3Q𶑠In/N̤㏗ +/"g_0PKH)hۡy~"s`kUĶ=)c #U;ۥEw?Q߫kmLOStܜ ̳.n!ߞDdrU`?. -Đy X–xW3lz7utR,dBvzPd&z\@?1,fljNG p{EukE-RP1+MoGKv5W!{]@Yn=8STx}Ω@E6uQN?&uu gxԺYAA3ʹI5w\qyk^ xN$r8=*:zE%yuc7;37]Nh,ytٰ"YN=Aɭ|.O ѫ@ p]N$]z0r~';|;-!@((((4P)>[ul-\ "#΁\6J>eJ7u>ԑ\{j9{m˫n+kpLu4W'' Y̟zHb3B2.?$wQ\>/d&Ga! 8H^>=mvg"7h1|?DAN:/꿜v6Oo;Gq@tW4|]F0/4`?,&lyzFNOI)x{[?[N(J ɡI?wƛ f[ k,Ԋ訬ctMdqXHm YS7pxn z#O?4⡓MoAEsŃ8] \cdG"&kCݢJߢurqԶ^e@ι,/9Z^¿ɍt4W4uAu$OEtTW7nqHspqP?tW4u/ ?|Tgoh|RG(t+#(C)޶AEs\YM/ҏCzxEsz(r>SWgmSƚ3KǥEt4W= F|C7A񖖃2%g4\JseOO +|]X5hH h}qPm?kkIqMԠ{?Zߢ =a):G65hO[)?}C@PZآ|>:֟\)@V ͦ=M9l[`ĚߢN<;A8(>9~ddnG_( vjj)-IIaO,oE`W`LމTP|Nd:oQX a0_?)Őr?uj?bլ.vאy[3v9=ק4ܖ! VF,3PZfcM>2{Oa'PIEsM3>J?Zo,/ 'R g6MX^.f[m7#JwxGƚ]4}wO0`!H0r>՛}}Y^,G.UEnǨ@\cJJiy?3DeK,y`;ǘN:z(ijȍ4 n~v?"r{yNM*iQ{Da9E!Wh Y%WM3Ĭ)JZCҀ9&qs*57ݿN`zP-+K]$-q}wrIYS1S?6kV/i+#tV@~&wT/kȲ\Uxú?/QɮN$Ĝf(((()(G:ڮUHg?ULR8=iPF)hbLQZ(0(-(:n9-bLRE&(R@ E-RR@&)hJZ(PbR@ F9-PbR@ )h`R@ AR@ 1KE%Pf(ۖE'TOɝ6z0sU(Zz}aœucuoLļ~jgnHSc9#`PfƄhAPQ@ F)hR@ 1KE&P-[ӧ>U* hcޖ5 ]6$=ʫi׭a Ѵ jEK8O>U b[=}ko$j3ԕ P4I3g U=ؼ(9"c?TO굻@Q@Q@Q@!KHOi6S 髕x3K_WU@Q@Q@gLZޛ-ĒIh 0 Es[ ZƧ,%v2C/L6&+XV(X ,rHԴPEPEPEPEPER>5YO SjЍ[(h(((((((((((((((((((((((((((((((((((((ʷ>SXgUҀ(()Ԕż:.$Y}+p?NMhxs?ڑDÆY `]*Ηcw(iG%c@V j!§b?e |v/O>~ce|ef˞Fe.,-.J]u_I?,t |Y*u K?֩ BNanAE4`K :nVආvq/(QP<5nyyVl{jҘ D#&iy1)?ZF(7-cj] fyY؜kN ( ( ( ( ( ( ( ( ()g&K۷WGJZ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ()k WS?q(((((((((((((((((( $#َ諸*} _ՏUZ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ()i֭OYw uV9OEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQE斊J:\VqZ@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@FI-4RdQ@ E!84QEQEQERZ((d@KɠQEQEWSNʥ$H2=8]aRY@}cSPQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEP^u;ӎ5 zY6-[((((((((((((((((((((((((( -TCty kkQ)l[@b4(eb;8==ip*ȑ_O׵fjKկ2g_.#r#,~:U1%䞿tU/N$5^Fql.& "QM[mD3rJO_ rή|yv}߅%i4xBLFV-lhQUlM( 9j2-Wd!F9"ui,mHIfOrjMhH# .)neDxK`^oOa/ P̟."j;R@Q'bi7wr]K 0q㡩W`yYw#?ImiW"7 mοciu5ą-;39Ψi%HgA -0֐ Y}, RH>gh Gi$Y'aN6. ̻Xt,͏ƗgM}/n̲HVH؝qTiiiR>YaF)~ex>8Qi5U@Ac/4yY]{(/7qc8=nm,ܶc 2l>*3[٫yl KCzm'tdk J*-C LΞ mB?x=I $+R@#- (ʑ*flZ=*ƛaEPEPE̢ y%nB)lz.` M'Xjnn;6g m}vO;Z 1A ?4ѩJۧc8P3օ o:t}i% )~)DY]#CgwLP۩jO=䉀p\p]}T"]ig" sx €4(f7\WL*RTkǽOED0ǒ2K0z7Z<֪ǣEucYP?fhٳ}qMp .|ȡYثPj:b, ! V27@#'cXp)h (ie'܏WTȳG#C:^Ў-qQCpɊiF/CasТ65>C9ϧhB뀶2b?z)q,;~?L,g$r( GARQEQEQERE- m7Vg]dG]ghW+#A*q!RqYE݄kl `=]˒21pEVa2I+hi8kiG,t<`ڍ>[X. EmbPu }#!vr>jUuK9#XGa tZ-O;~ŀ!d*{qvM et (]\d kR{ OQ^E3]L`R ( kRPRX഑@˹z}&KX H#'zPL6%Ln,89=}Oޒ^@[81U9JG"{~tV((Ʃ|+5،%[3ҜҴhh((((((((((((((((((((((((((((((((((((((J1KE&(#Z(~gQ,/MiU;ej:R Z) 2NfMO,B1.Nxހ.˸ãOl5(YCAYH|AR :6/ @-!g9UsRZCҀ3L9aOZ-iu"QOJ[j= +<=`Haݻb ;y!Vx,SưY8 V}&) ʫ}<ViopJi4zm]V$ikE*Hq:V}xV(((((nڑ>]:PM'ehtiKۯRZERݨj?LԿk}7P*u/MԺnnJEQ/v7Ry@>v-!O'-&H;Qc(Id1}a_P'm U0SoBV7P*P+4e U"hmV?- mKZMz?tǩBGڏ@ijR?nHOJ ȿ UG~~?*AG7q^/Ye3Ƣ1^h.AhB}P﨏(EQu8`1X*?i'qvo GhƩOƀ/R jc”Hu[Sa(LI<-?M/}>*ˤG?cM77\ Lz/.{Ӿs ?ƀ.QTqo?ƓaI4z/.|'O U^=n]=T?ր/QTE?p=OMkʴv.n͋գw%GChKτTɇO*u|E@"C.7_o@-u?r_zEP<O/_ LWG?ƀ/T?|n祍ZEQ|s/? 4z/n?ivX.QT,04mhs*}#jhHM|N>B qhh iUmF3-j2zP GC-VeY u9 {՚((()JZkU$ڀ(O:+B4o%8fetp+N ( ( +2\֦) * [01KEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQE{K)[&1gk2axG~uފ]NG.w@?_4Psj{O#8k x[;}> stream x]W Tv#c &! M6*EŨqAE (O!\ # $hԗyw<݁%9sz]UWߥ)MIi9I+uwSsZ0BPp&_ D@f˜| (M{D&,Z6?seJjUDiӧL'LZa1\$Y2},,Фi{HQGƚEk=ezgdω[X85teXtW+i63g:8nt5b\eIS!$j15 ¨T8eEEPj!E-R *(oʞfRG9R5 9T%FR')}ʐM))58jeBє)eFjңQT#=n5W#$j)Έix7ƟYϴJJ%'Ykvy#F/wo5qԬQiG@jcpaQ}pHc Z.ؗB5 ޫIcxN> kİG SЄʄ2n>k"=!s>H[hxv6!@+XHSdR{WUI}v`M_PBRDž rĞK5U;pYo _=ovfvռ&9[! *jZ@\8ɱE-J>Փ 0A4,y^jBW'%R7F /1xT<{ oB@ ᮂW Ԣqp r! ~o w]q\`'qI E3MD}31䴷9b=ĭ)|,]킞y oHjʾ,3n'H7%` S~GaQfbu++ yA ZP"rZ_C`OW3F_SJ/q| IX;&<ŠlteI6լ#S ÇvӾ+.G}eCfWN=Cf9 8 8r\n<|O^[.nP|~}P2 fXa9E١1bagÇ~W?IVa-naLv`F?n,4OQkD\h=vdǮ*Y䳭 6esi5PtF6n텒^G&7Hua^N~\ĩ5wԳ՟ogC8Ŷ Һb \B\<U^m=З H> s Z"Z9}Srv]^ůlO9ߐAbks?*nȾ8}AvTfКi+>]X3M7/T .::ֹmC1mXKq .` bNJJ/FIФs=H.5etlBp>Y) Lz~VЌ%gJ'kmxFbTdV>ۑ_ºK~c$:ءG;T #+3Wk6=Rpj!)kK{Gu,aG0YXGܐquRQƫ~vDB8@&s~4NӌcJ ց)uBWBk ['KPw KBq.dRª0]3LO '[x\ s1yYlWY!TL%Ҍ':jՌvOybCJn(NݴP 9 5+4N#bE{ XSNIEhY嚫hvC?[~uZ8 f|'aK<|BJdC 5#g[JQ<-D/!';ˆgH;ii}c's葚;vI^ɦbnqO6WQJk*?("~|;\sꥣ>׍' C z"%M..:0FWa+|t`EX ދ3RG;\6d@P]Z H\23vl6Ǻ;ԍ~8~RVYD9U6O#pπΖC[d8sa̰_tEA‚(Ktc{iEd(=eT%CPjA 8V'e{Irbv0Ȼ0zǂk.CЃX/iD*rXNqV2#bW%}k^FZ7Dz!'j&%sa7K}&dM/Zu9Ĝ9C Sa8G+/Ӿǫ $Jr~&JGD杶|e΅D?ݭyD4JJP̺!O@{-r&Tl=L#L\ 8!pWX%Ȃ{ .8{&L?LpF'HQ:b!-7vyo̍&Io` &eG\N_Ti8?460fHl!CDl/1?ȒB| ñf yŋaJvJX xB$H)jv ;v$o߽aۍ:Iյd݌|26m[Ī׿>?N4!v肰U)l5go7҆gXL>X<7!KrXe`hqMn[ %6T_I{t=oi{mׯ>opv!o4 Twp fs1 z:k^Dm/Vz* ?#l0VX)99͎ly1Ҫe[T;ĵh"mvm uw/]y/[uBc575Œ眖'yxB&n-/Mdӵv_[ٰm ]V|Sgk]!LzTm=w,ٵrɞ] )?"(endstream endobj 652 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3260 >> stream xUWy\T0dAGT4p& (ʾƀ,"ch%E$$!QFTLArKdR12"5}~ 1ι9CSfMӃb2c2"{$EGj̄'ޯ 9ZpA-$Q4=;$|Nj}ZB\|yqұ..9:MWLzB\JM1I)u1 5骐t|hN(0;9ej/4t 5k#"GD.NY8Itqډ&opSQh*Z@R E3K-R(Oj5򢴔7CRDʏKM)7j 5 )wJAYRV 5`*)r%q,TuV]Kiff̓ͷ_ZX<It3D2mar.ˑ`U1k֯YϳNb]#5JllZ [aߌ$epQN1N ``!Kd d]; TC'ۅ:XGc=%SO]|+50J!w'2@%Š263{1cL4xx<xKS>Kg=וĉ a0}42CNl4p$p~XM3^jfv-|0_I%/,'$>'|X22GSC~__s=Rt{_{*uP_oݏ4u)ZH #zѕSuW!`H{_ُ-w1Oٳ 9;On!3<7< ǃ< yOC[㾗:V22a8Po5o( f7|GТ$ON5%^*U}ET}E$*J^@CԴf<3BĶ0ɋܘ&5.,$5"db0̉=b8~^D*'8)Yn}Fw3Zg#VaGmz2⧚۫}- .6wGL@L`Mh$ 5*A[V._]pn* 2&YԄ,~PGTO t(V,vuK y$HNC P`gF%$$BB/ 92F4A&*q5E\920`{h+1dAp'ļ I@$ŧTpʂ٬Xo`\3gA\}>7;;W!TtvmSR12<t^+74/U4|pS,Wj7݅ B'T}[iJ_wF:\V%,栔+|ivr!xz[s.D<27E@#o9D a쎈 0@Jjv}n0[)fwyE??QӮetX]"C !b2IaCB!1v*&Ńx+`P+!"wTo[ߗXǏů7<+g],LFmIJ1R~x,7О=W/`@&_PP1jtjC}\7O-\T !m?lF/Iqx=L|mŅ'rI9 <)ؙ\;auҺ\J)$)i ?'ǿlWI]DW!{s֔+(wL-ucV\|A^q]%I0 A 4xt|ԱYHr϶L9dD5yvGچ5GV h?Iٹq+"{wvIJ@)u6#N&"#\+bQ~.>_gA*ߖH2@JVJס Ƙ Om|>l=h,9SO>ʪKA ĺ:YAFb*/a, /b*%f*U{7x5H1[(xW,d^xCi="j9g`jQN^1~cB.֐=\ڛzCU-'*ϣۜ˚ycyTb6tA$>C5uub l4tmg/ر]”ϊEPڕ!\+k!J3'a#1xiπ 2c''ΐ2kZ&,l-d1Պ` scg(!YExB3v1*L$8#p:νIfrUWg38 " 9'<ɟgd7$%Ac]voJtP¾(o:fd% ! b>rq=ZvXFHԡIoC R %0TWyz ?ڊ~%Ji(~/Mg/Շ{HO&fR؀0NhJRaiTRt ߆ 6DKaasS`iIQ(ĵMT)#j5> stream x%Qhuk\C.w0F(0:6,il&kK/m&M.&5K2&vKMLk'!lUJ _(){i0LwvpTG-R{ti?~t0z ]~s8 Үq>dcցTgww ꥎn#ڬN3[?yzneǩ˺N{6F3C?Ay곺U:M[fz\1N2X ôc}=OcX?2v`0-96N3AFWw;' \کB0E 4vK.>:]dFfBjc}NA,1Jŵ9ęA"}&},\ͬ$[䤓~ws{*ču˷@ 2H'PYMR_ %JkoҬ<2b\-CHvi8 mB)îKQha1(LA$q~ٽʑi ?+ 1xp+]ݱdRi Ĭ@n\#jn+w69Β!:8^BŐ2fP72>`o{se2/gJ,S֥ ia>!ChʸwO3a?J]8 $JrOFz(7e=#א(6 A,S {?s~o t.3Ή Vv݉ ,˟қKK3A_l:'?!.f^N\#HmhI,"wM F3wշ37 _8 DVER^I ܤ?5j'V뮝endstream endobj 654 0 obj << /Filter /FlateDecode /Length 3160 >> stream x[Ko!aKF& Q[,#zx-ىSU$,,msXdX_b[l~|eFl?l~Huw~ f8r ֪&ʭAng+'fzwr ݜ[pBhv8(?O!;e A;PBHv?`arw76`]o7?)Y.AtB1D ]Vn^SH J`?'{b^m-b'*gօ/)4rݖNtAts h'd'kx"woN-B6uz!z8AyYcRt5|~_a\8)| BC~$K40G~qd׏d܇@ J񎯕ucFS8"~r@XH,9ц1#soz$B] ҁދ816X4rA4;GQ3(#D;w` B:|Ꮿ$K3ie+b fVyB9 b`YvLHӑʀ/ӂ`µZ/ D!`,Iu¯cXa; !N_!WWy^ ~B^-)V-;)Zt@>vUvSZU&Z!#1vtS1 h[ 91SO1=a ?rxB[Al&^WP#آvk) \؛K>Lf`G!pHΧY.ggRwQ}O}MkBe{@4\H*wpT,>3%#.7̺>_o s9bC绥*VTض 1a2M5 D=UqMKnLAc%#[%OHjIg4j#0g};A.U1]^*K4 BRA..x6>bMEURZmsB7uvkM&  Rp QЪx3%+p*Ak6A3)Ebi"wrk\ _8JI<24RQoϦe7o1O3@ )ٙQh~L[3ʥ u9̙I+E 0X^h$w)3'O.қ]4b8o\4Y. <(8X/mJY׊'.(UCQM7ZZl2C\qГ@&}f{4+|7D-~|eAC8B`FI)UCe͛bD0C)Bp@T<iKƎx)o%FW]\BnJO nPX]ݲTHʖMoF2M,2zYQ_Z)q鼾ˉIiW.G-Пf9\ 8uAP-+i9@Z5FܨOZF>$sg.;$"f%z%TUsL ؟qls*^bu |1Ӵ]aCO) MRZٚ$RxD?W;@ȫ…D[aE I:}m2nh{ؔJL-K*+&;t_M4Br v֎e^z?&[v?TӖT,5doŪCڊ-"|LVc7ϝ\ ;r&Y42m\}-͛gZ{(NW;zJl Jx1VTb."`5J99y:eMLa Dw0]8-.1Gr_pJ8H):/’2 "?vԸl47_0 WE\rBzW? Hc;G(c%Va,anM#UMڂǡ_)b}^a7 QY*f\ϷR!JΤT9vo rΨIm$-jJS>ިlMfoy);*zpywtSC` Uq}g8 SHȀ;XT'J!0}XA+ʥOQ6};}aЬfڬPi:0|gh䉩_vDx Y"ŕZCi+> stream xZKs7WqţڪVCl@Ą IYRD&ZFWou{nL˷Uf[#45ogykM 65luPj(bv~q_)eŇy[@ |or]=o-`?SeM;<ګsVԩN+KD]7spn(|KFycG͍ov#s1"[A3SuV! <5 p@ml ,O+8@B4@Sxe<\uEu^w ŷY+u{ }d9>L;bSY;Y*Zxn#6c|urS'5r8 hs "CS4}.?Sh~h{6?{ʹ-&d~Jv?:n(:Dw^zUђMȡ+hiuu@( N7)Lj_S}{5˳7$Z蕷vDCP6cl*ʛB^ϯ_:¤qdsxMӆ WԼlY@ݲ9w~5-ۺgOTSuc@tM> h$ eJlmmrQ^e)Sۤ hzW:KG%*)TkncrGԞϨV%c3"N ts%äwxW@'WV!C KB}0k%ɉ`n'7*lq|, v  iPx\@%h${ 2@3F5rGa!5MD-"rk˷)pMl>BBXr^r?Y''$B:GEI{ۖ'~@׻Z. 4jhY-im_ri_p\$A~B/iƾ[lW^-.8ap_ 6\>C[NY]YM_|ʸWse ʛV{[U}3sF+uRǧj}X)my/a֊ ,.!20N2nֱdAo;,-ee[H/17۴~ͻc5Nב^T伿 (HE*\Z[p ^BJ|ꋑ^\ ^. H)d\d z-L! D%9APўf3iy 쯺 H:iBN;i#pўgdLT&m=ϴLv<&I[3- Ӟg{5*x&8gDTrvDʤmUmC\I3 ̎INE{IQLIuXS3[a$yd I] Ŀ㊺ DNx[38><μd! < Z x&9.rDDv<<-TgFhRdr3M \zI4+K)Wx|<Dqi3 4_@3ᄠހoo_}953 _l == tqm20˧lEB }ⷹqbԲUŌf}sxϩқ?ȐjMy?y˧?ސ|5?G}Wȑ.N:]&3]P8tHuzq|\Jqy7)UWodMz3endstream endobj 656 0 obj << /Filter /FlateDecode /Length 4387 >> stream x\Yo$q~'GV2V ـV\ vI/eowDUY&51S]GS6S'vvzy OO:Fr; ه*?uzdSh;==`7[΅56[6*ƌp)9ҸQ[ `sw 7{r\nNjQe+Via@avp_n#U4NKSG%\ڑӭ4q8'\yUʎeE<ƸHa]Fp C6[/:c#6i@n|Y+|vχ'F;"1L,5 ;K3^ysސC^Auݧ!Bg@YOdx[tI Ss Bn!yI],YMp1ZnP< n8K:UWߞ] NqPG*tu\${rj!ء-WR@Re$ $JkR # 8oZzv'L"Jv*h)U?A}J8 aS(,}j,=]e 3cNT'IfZIc2_ڱ)L9cT<*!%n*, ̼q4+^Gk6D9&ꍟe/k)$-qɜd.ȡuh}f9J*+V1uah+ʮ6_B=!VQ^N;r*TI3fyH*VQݰ_>P=SPEi'Hw2MƦcLsou%;+` k^Fpp5Gob~q'XxM&T&q mŘB}4)c ٘ 4_rrħfd|J{<擴& Z,2oZM&%4Dh?z&&U#Dj c =\f`Kf@\>V eRr$1PAFr ao,'^!悲 v@nN&IV7 c.9DZD%&oM,@M.W31֓O MMB޷_i:Ú]`8ׯсV)QG,J¹XUd sDEەVRIIѩ?z٢2^g;{娕صѤPL7R/# IıY.:I&5i[V;w蒋jVEXRF}׿qJN5֠˙pG&Mqna9~?>:31+\ߖcg\?=? =ԡ_=Ϸ珟6FB&7N4ֆxʧ27l&qaNqQ\qw8._fP#uc~;7'@d, юJJ(/G[QcC?r^h ySiYniVs6:"M|ʞ.lU8C 椟U>РQ#`wĤGly@u^i|-'iZ7n~L+mj~(#EoCQm+iӐ$S;[g ϯuc\&e)!8-OqnΫX13d%$gW|mmL^&uhELlD9}0 Hb?ѦHʀ :i7ӝ hMU&? ’k TW*Oi`ScT=0YǢHj`+^J+"L i?w 8&> stream xko@W7Y4ZEZ((.tܝb;M;CrC.,-ڀ%~];ڞkeogg̿=]m;8gԺαpL=7˦>|T\Y4׏~w٬}?iTmawbOgLJ:~~Y'g#6Kn5\xf9_',n6lv3k~{H_Wn>n ]*Z!Q~y6`l_5Ww]'C ߼1\;/sr,~q "N#?^W(/*iqrٲ"o_L_? RJ_jl"HnOe?z<- @r9F`("wś9+Vfd ɝ=n]'n@Dyy9fHq|E|,ẕȕ\=;v(7@Y-!Criu~ݞ֒|7sP"M&t<.._x+Zq@LBpMZBrђZ!BpxcJq:[EZؓM4IWi;!K{E!+h:9.cR#1+Q 1+3݂)NΏ&:Fѭڅ`S&)Jlx,?EF!CUXۉ`(ssl+~ 2GG1L:P4Hh@QNU'ZmW'R%YxdҴeMB)3+C `BUfB@HYy]ûV +}q߶0Qbih֥]"n&G#?SEIsCl;Q&U ab!c_~Vtf-讼GCexYdvE$7dqMSt͟p(`[d*%f Ta{4%Y"gh:| lk̼CLX\)mWX&B,.I3gJo˚, VONRTM{'6e}spӱPcaӋV lB ed\7e> ;J^geZ\z:L'/x$ ._ss"G \,C{<&!>].DTf(>nqҖ2KQ0g;H֥iqԾ&Z]ݲZOEk33 Ź*6#7vjiQ5K#&&F {Mq|G!1Zv@0,vnoƕHću3k&Q)u5\7/ ="˕2YEIL}]C*D'R|{+0O%(`s>姩iSRTt-q=CG1s̈d"ReXj=FgD$B?l'sC cD4EQɵojܤlНϽJCSj/xR (̋Һ<b_6Pk8nh/1`eTʔ򻗹l1L]*%aObreLbX*́CN]\oH@v 6*dJ;9gXԌmkb^VxXru ݞeZ v ) qEsH @V-ӻJ?,^::m2]Bgߔw0 E쫳~\0;g P+\囓,׉x{\*?%c)@p$5u=P02xnY87ڛ\ޕb@\] E|ϳWF6ΐ'2D{66%n+̙5 Xz狙E?r6'խ#a &ЬO6X rύދggF/ʓJJ?C8-%@Q&HS݇@zq7 '^"W伢~E=> q-P.tNy*gr{ }"dtO%䃧t~@n8IËðnPzuu,u؂u &MGۄp"pdxrEƯ071P?D( bHV=WgܙqDendstream endobj 658 0 obj << /Filter /FlateDecode /Length 1928 >> stream xX[o~WEQbJqm 6Oqm(G$=g.Cr6[C~s!BL9WNov>04ZO )\;1]\OZSpWEt|~7gs#ua&bfoʱU{q?̾ڥwwfW(䇫vl}aMۧb!}_O*vrfйw}m㥛βզE9Po ʪப±|1AdlI!}z,_4m6Il]sCdf4ѕyR%M߽rz`?>H=Z1tLԎP@wJ"=ͅQDY0Bu^ ad~4~JjVKQ 45~)WA Kgs)8u`sjJP¶@~曷d>|ӜZ7v{v㿊*Y_vuE !LvœY*X$n_o xY(S.RmR~WϷ\ϴ\:\Îk_zT5T$gF%#H5k/t_>Y}_>jQNn&ZQk5~~QЅҥ XB괚yԲQM}5slU JBĺ {\<#]d іR6\s^8"  uNX[@$aH=s\%Xpr@rQk/Z1`[ q#8+`vBPR5pxs!VLJ`^:SLp ]Er:lW* xE * {4kB/(1N"zåa>4.;rWŋ تgLݣ4 !4OA|;QpQsf>C'X}"CO=q? ЛLVQ8fƱx.ĉ2'0>-ԐLJIZT&# q$M͡|.bV;#6恜r^fek:胬tpwC 2#Z3sP'RthJNs*|"jPYI>:uX^P M$ql8Luv> stream xTPTU][Yv69 g1SF&ʲl,rwU\E.?wuYV 5iEԚ򛲾~;\GoޙwΙy9syIBC$HI^1zT|ĈO2B  ys޻Qh]$zHkR&+SSW,U>|Z1UelIѩLҦTWkLVe*ɤ_llNTycQJsIєk4 ̤\i3%t^0ilPc,#"חT굚"m A#^$Fb5 #29NBN%>'5111Rd'7b9bmaQ''0*Syftgx֪JVPYb ԸVQGMkKqg SYaRߜ{͙[Ylߵv{@\'\Feb:ɠy?b<<%D7\oL{LƓ 'oOJbA&Bs~+-ߢZ†7?bRE2O1{]GN@8q-@sXj³<kF|1J& :u_( 4ׯO wrtX[BPD7.[^u+[h 9mjs@ߌxTMܖg}Mָͺj:=Pţ$0J ?D%baDVs6Nzx#z|Uuߦ*Sf=[ tjaT ܟ-zUNvG=ݖC5Pu\:؎Ej Zi_UDF·Xu莨wΚCmF,ޑp Gꏹ%P>['ƒﴷ6 ^Ys6Œt ՇCB]u ae9謴q^` q&}A &SC"w]1::C!II6- 輭'T7'iHM|SU4텺vN|SaTQ I )5uz=ՒmFUL}=K%VNP8`mh=mm yK$ ~"Ȼij l+P:MHbn - f*W [ڰM%t:`lR ƿ02c}m!?F Hشc!~&]:sg+ 2-! P#kW4?}!ÔDKDM(^l,^XFmg1{&c-V^ͷZkfj_*0$ 3yϣ{3-o8CgEgV>7..7 ~maendstream endobj 660 0 obj << /Filter /FlateDecode /Length 3950 >> stream x]IsW-*KJ,UIY6R9HJdCҢ) @hpqj4@=?0"+nЫGՇG?ЎnW_nRAF:yw'+-f H:c%5?10)[ " 9ƌ)a͙aL kR7@_\11i'E5={}}wi/вـGIRd4Q|ocTjS/H+kTJ0$HJ4 e7o܇V.^)CDJh}LbgWl^%aBBy(cn]UHi喛4Wkbj$aj1Bkܹ+O-j8}pgy:\zu`9`Ę+N|oEqO$ohg*̪PK7ofӐ[EvS4YY7"7 7$G|eSԥ`^[.Az@0[=Pd~ DRn^D[R(i"ǵmPb Y.s׊pK+&]ybPϣhA3iE RބG׌})5|PMf"isy6[[PloLvq\kj ΪxuNl=> tj4 %qF EI}׆"KfKxʵŃ%+t~|(AN7@ 3HYQ#= y6*.B2h[l U65:M]6E x *R*]5AXi];!7=M8t_ڥDzG;􂡃*Wmzf ezkiʺ`UJzӗR?_X->_XAܰ'l+Dt_pYwXAnbl1ĹB jfrwuVXp>iV[8K( rSt"K:L$tr\<fkmoez{Y:鰌ll1G VCV S7-~!KMZ ܠ.l0!Gք|H #)ZxWUrZw.AN}SҚݘ&1o&}qM05ȝ渍𻭷kE*^;L"^Os0/t>Q9(pc#C6* oS'a%PL;2c&!Lrճ)9YL'{Sʎ%Jމ}ɋ#n EIHa5A:84-6I JrәXڳvwKsh2 1ә>8x|Y\9_ǥFT uOK ee[903PClHP$ 7=rG!$:*,Zw}vg+e{8#㲞nNcJp +K up x"CI=4Etj HT61-֪vA*.P$i$9c8.=L3mľHat{iYa)ΔEe %A?'B 2YFh4} E7^ Ǝƭĸ^o1;Sq- y}bK8-M!=StNX+<%0ѽ@uOׁk:VT4ZsC|KPvlP짻hbTXU=rfIUHszKS帍dwm*aR<^I3JJqWzɈ XxۼJݳ' Q=g'dvhѕiRY]I_t\%uIXڄVXeԫM,j+Aw2iG*D(i-)g£_Av"`⼺9kM) َҹiBhƎ(0SiةlQZ3-?7-@H•{.dMC@[In7zd6e*>YbJ}Հjq.VVΊ!օA.]]1*4Y%=t`_yG&cC1]t\C?"ⱛY`Psg>E؏_(EO:_ʝ304Z!? ]h&x>mEAϜYL_ڗ'<$ ͷvG4y!]PA9cvwm(,08Pg.|Tn?uL\.1sF0 Njendstream endobj 661 0 obj << /Filter /FlateDecode /Length 4850 >> stream x\[odq~W_y?S`^Abd׊^I+ ˌ.;*^Nii',:Kꫯ/{~wo\=ɇIn?wߞA g7rfsI|Unr3[97gw'ۆݩNVn}w*&+~{M>C,=~3|G)`Q_Oo3l*la L2N͓ǯ ۾i8ulY'9f{xyݷ+&XrTIntаg޼NJ[Yr/qe/]>Ջ|OKiC%P5T=->?ihI[it޽:-TO՜H3n{\"7F>9*}=71~tn3TVp*d fl (u0Rml~l +I|fƑAIK }ܴYf:'M4hcfE-ewFsE/uhZg.;x!ÐwJqY$HJoX&`0XHsfwMM :+=|AN٦0,IJ +'S\xd.測aϕ!JJҨ992]@ԺzL,=7E/{7̝wHwV \V@PYxhWK2F"t藌i/wݕ_o)SZKO?0LS1BQQIyu LөpǝMr6Agclޔyf_pa$z!tLdE:#]ᖄ#'z3)A}xe/}j<8 Q?;$R,ڗr v7oG -Mݿ0 v8s'feudH k#H|n$K@&n KT\GX ߊ |hRWa>p.(ƨp.lAE'lJlvF13]6#wҗƒZG0g`OLOUߑc!F&Oq^twrťI3Ly|w)#enR Ց(mPLe"6K7TKw] -PtKV.B&N/e1#/eoW"t]H:xj1~Lw6Z,@釂Jڋ{^d\/Y1tvn|4ϔ|IЪFL*L 7+U%ܤ({<=8vbJX:e G#VHa2\Źa#.ה7r 3Sqz3S[|Dz1lE~V}]5cIG V/Gt\!NO?s$I X43N̈́NZfځ=mqzoЀU'j3YҖ1_tL4;`4|iF7ɮRfGIS䜰NbZ`̌&-B'Hl0w4E@ Sl:f9gӋ 1q]_]cu0SagxSSq%*'(_u({Lj(G \na*5M8oJJ#ƃ&Eo5WLsq^/Iq: FRnr%58UNԴj5y*ql &!xLpOE:9m3g{Lr/Q7*9ˊ-gʆ5YSAZӚ}نP͂wTgA@lP ,aee0M魬Dj,A(@dUp"OE e9ek@#&d?Kj%U-3ŷI8>nwx*?bJ Jq6aKq(„B4[蠋xkt =jL'8jCMoQPx>, -̸ANrV_޴`2QF7Ց,u b \q:ɗF2x佘i>qR)m4Lda -Vfs(>uM2eG'ymEX=Vs!f|4 ^'ʩ)V ǝ@㮇I@OKQA`@5/8J 4*Z-=BR(vZX#Fi[IqUsf5r')k\H(Br:WX}^n[:SJ\!6~#IL/!7^YW 6l"J޻-w@ӧӮ1]Vդ{)|,ũE_rޔ+Z9dT̹L>W4p47՗V7`kvJUۚ|8T, /E"\f,`E9 &:iFO PE=T1$B*(Nd/\Id[q{xm}'q/>S짗;#V?`#0O $˞ V%8UL+ Nj%(wq$Evj4`ʷb#Hu 7+7F'v~>f{>Ѱn=7ЧYHlMZhGyNIKQjfV..Uo? X1=hԂbQRjT3:F5yo&V.Y:񏑈( h[|Wϗᾏ"h2o-)I)h.Eu ‰ w"2Y~˜v.L:&UG%U'c|4U*L'dKd@\Q΂}pKQ |{c&9uC`UA X5%/ڔ &z+>>`hKsNTXkz,tA:V5~ͮ"~"i͎(WL4OiT~Wf?l,xj=a`ƓARɚ{u5c<7kG Msx8&c84`A@Ro.?^x0XnT2(^̳O_-9<[;'\sy)[/`[,k*Y==VZ(+;)wiq^F [:s,[Jy 0~HF~EƮ_-Rxn`:/ne>7Ŀ +%Km OO9eW/0)in,5ۤl(X<"uo)NIb؛-hؙҊTxJ}C?Y':9(N>@U]X'bX`D9a˓ۓ ^isM E?KfQK^g-wU\ XJcd+!oLX(̑CN )!3r>S(Lj']5M-mI)h7;:@M@@^w<8(vl,Jj:!3*'"SS9o4WFMn̘n|)i2uW{R OY$d&9}3[/ѐ~s4C |.ZHendstream endobj 662 0 obj << /Filter /FlateDecode /Length 5778 >> stream x\YoGv~g/ Ğں*yB`x% &)Z sS,!0 _vz,Y8U>U_|;7''ޞ9sḩZOa'UyR6u?ٹ\^݄g1;3~YS̼gv'VJ-nkǮ=>J`wz_= caз;^7~wc)}RvwWgߐXV˚-*>3o&`y8]պ{ ,҄.3.F/ikeڙA+yBs@>p1NJs\v2gѫ.hDww8%m}*& _3Ѵ_Qu|v\ʅx~'fim~}i H})rwe_%bg@Jo%@)Pi鲀IT'U(]l j[łn?pL}C\w HiP 3'J#%aKdAwV8k!vAYL^T0Β2HS;p4^F,.˃oGrBy w9з #7dr Hg=jh7Q"BV:N`lP$n46딸X#(H˪ .ry(q ;D/{0530\9th2W?EpZv Ш1lIM*RjϡhX]o }'Qx]_0nko]\ Vxs >y&I +O7%Ah,h b&JQ46|M+F32rԍG= UDL`d/Slb Lk #qk cr1!F!%ZEgbg¸-u5 0;"<$)Rrfp"B"+gMb v+fF*4r+|k[@p W Dž?6.p:ND^q~C _f9J&5xO/[#X]&u#*uZ @k ͨv:ݎp8 JäsQ`׾$\gF;˚;1_nsX>LYvi`* +&܀h|Yә*fPd6^JyYøNDc@CnxjC;2gAh,[Uap&a7\F|+ hU;A~fGQV)K6㲵XaOd`.6uqX\'UaO4K'6L+}QB.K@àv(*!e^6!PƝ\QeR(dPºYDBOqur N-!Lt"~-l>|Pym4ZQ3%z_L8eϋ3 - 昶6k5ӞCucn \PsȽ&F] DSq(MKU.Axf/ Ci` DA`(mr*r<kF (o"GS|8r Hj&5\?/qB$VwJ0 q%u1CnȐ-Gt9#5a9Cu[6Rdj9>& E]+1zE'g]^K9{ڡ鲏l&fSZC*lAWRv-Iu˱@EgWX0m3h"׹11כazvYu2#̼]΍ `<᭒˅{bNy0RD=I0k`[ʺ@ّH_TܗrUU%j7V=tl5*Oρ-Uo]~Di={r,mieuYr4^yP^%T0kqṙoK}(̷5tePg,Vt3\2]rϳS8BHt|#/LKҳ8U}$~;C3=΅WLP'oM " Iavhpߘ<>1f?NT~:Ir 8a>$%jKjiqn~jj$YrBJ,Aa:/VqJɋ@!Y>R6^㨌kAKx𩎑8=Tf޹\c4(P5+yԛ S[ Ǐ^/yE9/md`^IϸKjCh^n;eUĢ{xˆ%nT/Z׿y#lAJr 6"+i i3>4=;/KvQ`y׃)nj6<og+;@S\e${)u(q2Ć2ɭ[sY,!|á]F+SW'KWGn `y',*8/K"}9-L yX] 0ƈ;\)>]Papݳ(<ŵp)p8? <0N,s5f$ _c׸ R,kQIxPf\9 pz O(ùTS sx(Ge:,(W)Wn:8B2x17YG<ǻ\k0 k9okYʍ;ВsKTo.A)amuS?,YI)֣ ő  Ŋws Rz(dt tR]%E٢vX2_SщRב}U{151Af4r$E6 7Wy 1D&$Ln:#*pܹ"3QK Rw2SУ=ovL4fq*.wj|!wI+!5AIr̼u> v:uSqcuoP>)ٽNBls4j tTqqEOf}{5٨#ya",$HPx 7~n] ɵ8دW_u>r,[x+ߨJ)^ƣFcm/EI/FR ?oe7we2/W( ,Ɲ(S3OAd8e:  =Cs,KÙuMDH7IvP>(+Bƾ_ϝhb[:EeK%?M5w} |թ]}nS U}|J!~mv;5X}b)TU>~dŔ n$R 1ضe>%U/FoEm?nt*Cs (̀\-8G ߞ^%'^LǰFvm.ooȶ&gQ \)9scpyW8yqdV H;VE@1~NO_@#`FA Se+pP˜sv>XXWY47DEٝlP>%9~ꊖP#V&R] M>U9Q)JI1XСxvI V\ɹtWW_}ȬLɆ =hS ov>N,doQRww*_nV a2ʵC>(G w0 >:&lHUiNoQv,yj|vPp"E_QEN#>1\ K@fYoݔy&k>Aqlphw雫2[)f',6Tre"-oKVeGYn{> stream xŝ[$uϯ8/ qhZYYv%[Q .ą޷Ϊz0()$]o[z^?{_o~qsYSe_o[yknϿ|iy="ǺHuho>|Oξ_MUzKy3oEsz;V9VP>#+i-Gq5)Grn1Eݕ)j6jSLݎ[JsPQ׻d9wF**!-=+zˇSYno=u^4dXګש$K%~󳧿y# e),u7rVא߶]nUoBrJi Umy)*e>XR*R\L-HnZSOU>mCǧ|5ԈBۮXqo-O4޳N֭зۚߒV/ݫ|oët{ͷ_k]-K/_VVw_Zvkyϯs{f擧~ͯ^~7_|GoիWo~;=w)w_NNeJ]ZfI#. d]u~'ZEFBZ"d݇2\ۣ\sTK[ouJDuZQmʈ2ںyGw%iQ{ʈr^΢J}v׎ekҎ-* h!DPHVE$![42ii9ܿpW*2w%VGw%vhgQ]dZ{Pˆq]d~PbQCkS2ZdQsҷEi(5ݙZ<4+յȢ3xЎP_G.xLHT2ԒG МAvŢwf=%Q]L(:v!\TE(OFI<|Q]`<RdQE^T'-9}GuS]f]EUfZTZh4l>S4/8Իo}3\.o]7u~y^עmY(T-R$@UV.K(E?͹X?o{)fp2/~S}lWSKgI/P#k7=ݏ[|),\h~y%ffESv+G(MkЬjҤt:q<}n[+6qMmyIx(_MN*ҡ= 7Yz;+٦B/?)Wvq*Q'}'?qo\|=@իWlS&5MߑS|j jjIQ#uT9.6TPnZMLwXҍ^jlwzW{I~n~`$[f&*;ݛa DCwvSsҞ &˹ݕ]|S&=D6 hp%^Rz8gRy}llf(>Jźbݗ\(1?+ķ)JEc-X0)5i{|Hѝ-.pAWJSmx%ۮyY-1$'}nŔ]=gcYYDKGcRQߕ(vyY(:đ7..tF{m>\Xno %zrV6Ū)ߧo /fk@򢋩P[Mno6O|ګ9S[m+hSj]/UcV.joDټ˾mbĀ)~Gmb(v2d)d% 9Ivb([BVͯ"7%͕snt=kCi"wgoXOi9GqN=<,lqKt#{k(|^/ǍjB_O^j Y,Ⱥ"JT9}Hv"t/a}q5w|H L峲-!kbY5XөJmMQ:{K(^9ōfuMǍڰ&m1ūw)Z(ӺEk垥 h>=>取C͖ަxۺ-ņmjGu綥ٲ犡1o[Q1V>OxÕ=1 mRz/mv˫Z-ZfH2>]L=-kJ_'yϵ-qW%/>Ɋ[Sc+J?. [Tmx&MMY>z[{?VQe%;~b; 9?QѾ[ nQvoe([ԗݣh]~bK5n(F8׀*k2 6]/Lr]WQtU~->E ڬԸ^k5˰o^\;uM^rNUQEq[tNEʨ^u?q:կNOXS{<=/&6%e_ztO7+Ԭkr!7-I9tʺn7]~źwn gۮvDJ:Ƿ Iٗh5\f\O|(/D)qy%ɮv*卲j{u]Jʮ[S8hy^q% RFOMynkIs84u-VnԆĹ4g=khjmkסu.ݽF};5SYT[j~!uzk4ue;U-s9ʪ\D٣đW5^tUWݻw6UUm*U7)sZ)OT.Y%,/lۣ1ﺔU@*^O%na|%fŒ[cg\^+cLDF~?r;JЋ4-[(u5SG4wcgQ'趹-oW׶DV-:[ w%a}|)[uT(q'g%[ohks[7۵SrYut2ykхSР"{ЌN ۺX. ]隺p ?F~y7%[+PNQt~^zT((XrBlwՕS.|]{2EOy׬Bzپ4¬;0?_>$&2ס)MU r<PZuS[I-Y{ KϿ%j~@t;PE(g_?{7OUOz39E<ؙ wO/˟zۧy#got/j{~9L wrfjlK-?^,Qd%Nws'h.N?Ox6:m~7 ?U4yw#:[m~jZ7mmg yӏI3E3XW%no>I9uRcpU֣ ]fI1O9Wcg6[ݳ;qQL31mf`̬i3vFff|5mf̴Y;i3v&L36gg0mfĴY;i3vffLL363kgb̬Y;ff ڙ63kg4mff4v&L31mfgfLM363kqMյ8;ff ڙ63kg0mfĴY;i3v&M363kgtm&`̬i3vff팮L31mfh̬ڙ63kg0mfĴY;i3vFf ڙ63kg4mf`̬i3vff h ڙ63kg0mfĴY;i3vffLL363kgb̬ڙ63kg0mfĴY;i3vffLL363ko3:i3v& ĴY;i3vff팮L31mf`̬i3vff팮\ŵ8;f ڙ63kg0mfĴY;i3v&M363kgtm&`̬i3vffLL363kgb̬8;i3v&L31mfWffL\յ8;ff팦L31mf`̬i3vffLL363kgb̬Y;ff팦Lѵ8;i3v&Li3v63kgf̬ѴY;i3v& ĴY;i3v&L31mfh̬]յ8;ff ڙ63kg0mfĴY;i3vffLLŵ8;3ff `̬i3vFff|um&ĴY;i3v&L31mf`̬ѵ8;i3v6ggb̬Y;ff ]ɷ|i3vFff ڙ63kg0mfLY;ff ]36gg0mfĴY;i3v&L36gg0mfĴY;i3vffLLմY;f ڙ63kg0mfĴY;i3v6ggtm&`̬i3vff|m_g0mfĴY;i3vffLL363ko3:i3v&j̬i3vFff ]363kgtm&`̬i3v6ggb̬h|m_gb̬Y;ff ]յ8;ff팦L36gi3vL31mf`̬i3vf ڙ63kg0mfĴY;_]31mfWfLLյ8;ff팦L36gk3qv&j̬i3vffLL363kg0mfĴY;i3v&Li3vff팮\363kgb̬OW[gb̬Y;ff ڙ63kg4mffL363kgb̬ٙ63kg0mfLѴY;i3v&L31mf`̬ѵ8;i3v&M363kgb̬Y;ff|5mfĵ8;i3vFf쌦L31mf`̬i3vx\^  f@ (@3b @ 8@3b @̀@1  f @3 b @̀P1 f@ @ WȀ1  fp%2x f@ "8# @  (@3b @̀1  f @#2 b @̀0( f@ @p1 f@ @#2 b @̀1  f@ Bp @3 b @̀1  f@ (@p1 f@ @3b @ c@ (@!0 @̀1Fe@ (@3b @̀@( 2P @̀1  f@ (@3 b ʀP1 f@ @3 P @̀1  fb  (@3 b @̀P1 f@ @3 b @̀ A#2 b @  (@p1 f@ (@!0 @̀P1 f@ @@0($2b @̀1  f @3( f@ !0 @̀01$2b @̀1  f@ A3@(  f@ (@3`Pp1 f@ (@3`P @̀1Fe@ @3 b @̀0( f@ @3b f@  @3 b @̀ A#2 b @̀ Cpa @3`b @̀1d.3b f @3`P @̀@1  fP @+dpe.3 b @̀0($2b @̀0(3x f@ (@3b ʀP1 f@ ʀ A3@(  f @#2@(  fb @̀P1 f@ (@3bHe@ @#2 P @̀\ 3b@ @3 b @̀A3 b @  (@3`P @̀P1 f@ @#2 b @̀1  f@ (@P( f @3b @̀l _ox7~w~!>k__/'_#o_(?~rC -~ͻz/^%F? jw~nRRykW#4ϟ˫Isnxz5DF=zzyJ㈿N'h:ڷ+MZ/Ǫ^96|rZOkd%˓w*.K;LWq 8|~/To|"L_N?>W7_Loj|5W;Y _ա&RzYar~M Q/J!*_> #ݻW󜇄vҭR"SI1Я\%'+r+:3=o'k=˯~&v>"Wr?5cќLsPzo{٭y SZŃmHa|4l~T=h]q;D=tLٶk\1K?"`&;_M܋"Cz9޵Y> A?we28o^Ȥź?жq;z.ߝIU>Y/\>[/QyBr'зsH/I?U"\FP@t_7fW uYMou  9K'ě2|m}ױ꽼ֽ,^!W{dom?/Yo: v1}e=dK?TO?{eL:*/K6i% K7_|yZ]Ч~.Y˽^eOƕ>utV.\"olt19ׯӒT@}c}zYo^c>P9Q /_WZGvԠs#<谬b~}S;kMrh?)Q?a+QNIQevʼnuCRˣj/.˼Sw8i?5yQ tcV]]< κa|?bM:dT|tr-%L؏lX_y"٥G9>b>(DVh?8񋴝 ofO>dK2K~L+|[_^ /x沙2QqYzocZTyF'rnPaȿDzs鉎foֺe~VΒ!}}@7]j>|SFkEε/̃fqeJUh}F~=8_VpItO\ǁuQ_dg[ЯZ+W'۽C^WN5Id@4/[2gdA#Z 0czxCJMQø.@{AV7]~ҝd k-vvJ}F=_?mk;߷z޹W{LR?^ 2W0G`Dzo~z!6n$1x[ͯ`IyJ~}Yq=wiP֕>Z̘VE?NiNK_ubhގ;&7o{k5OǵVJ]YnKѬλ,Zҥ7[/Ggp4kBuַ (C}tƷ~u)IF˻ [%î^@_iKs_xM/ZW<ӘSV/qi6_>J.nTgsK.jBLM6Z2rU[ǹ4haCK'[{4[s]dŔwFO<[~l J os&ImL~!~%"ȣNWl'zN EJy5/Rl-\}79*t=@SAjvXI4l=}}f>lL7FLBm!|w/ߓr`l貙g_k.M\וUs3j~IݳvV_Dfh~4B)u6-J:xq;Yx @M;HfwDǺHWiI&m 3M^:n/yK/ z|wp~ˎ ;@ɣaQ[r"}zR?%S=?x6.O='>h{N >x{NĿ{)\hlHR]x`K߹k;7sȧܡ･ݼ ˁa~z-(uuq9q]OCg0̜^ʺvݤ6&z}.T ;ΙVKHr)uɓSoZѷJZi\{kL79:RqMlXFb-M :ϔ[E ԃqnbOyUlKwN\޽¦?E[5=mۏ6ɴ6.wc)q.6m.UյνSO넱%{;`o1ﯯ4Y3b8mHL_m8jm?f$^6֑$o ]|eI]|i|#-4åOa׏;}O\_FFد~Who[l>Lgo{4ygmmO.^.S%=K̢~S,+Ռ9ƿx˲^|R<&.kvH*-!uTrV^x@γrְeuY{ՋGʤgcc/ٴ߾.}k[+jZIsbts4/X>o=㓛]z2;KuKWajy5'k;Mbdm{:=y mZt|{8ޣ>?z^,M_ٟyپoet|OuI;6UIhZ~5.SȺ^ǹ7'FolSrsgӱ͙{O_esܣu92~.λLsӦ4rh's/'K۪^z];ևc)ly~9x],P2>͓y}_FؒrX>&E6eV疮5ն|&z e=ƪ@[{|^w"|F>9E=CXZsT/ANc63$fmaD<%ҷdHLt\/GdL:~@*UDҞ_=m9?sѱendstream endobj 664 0 obj << /Filter /FlateDecode /Length 5122 >> stream x\Yo]9r~WG ;LAf0`LdIb˒UE4>:Kӱco~?G$z99il\vJZs|>xr?>9FnO΄Cب퉔|uAgx^b7{ag}= eN M!Z6\?kRk \Ro*x[]&lk6{ͧr{~Ĉc;V}Ňӿ7Z !U|I 'zsUnErBh`&TM\X\k*G\n`,:~X~L/xKEs /04!-^;vRyk"Ej%u,^o/Oʨ !X/PZ;U4k}Q>D(ζ'Z蝏*O/ݲxҼvZ[[W-%4-Nă p^l6W U$Y4$/D1NnN0tN./ZTefCQ3ڪ<(K6Yj&*(qkxƂV6W8 q7+e+7Hh3~I~V% 8  x%13.؞mH?"Jh bD}kqŝ7L3Yh܍A>6n')yG-eE\|a^ |_M}Ǚï{U'!loh¹awQ [DŽ hwI!7/0Gw^j ! (P*ܛu-C.ZN+<̚9V{W 1:#]-פ֣26d\9eA z?T}E,&Pk_YP}\ [ARZ%p&;Xs75F3U'Wm`̹nV&8G 蒰tu E,Eh`eHx#&%1dx"Btπ[f!hِy Mn5w縃#@ n"WII0lc'` /?F/h}I'jr݂z̿qC,a{o񒦢IZ$ΨV0f &v#KۦZ.Baw D8&~]'ZB`}f|x}zP0y8>*BnyMaJKݯgJ/6Xug O+_ t4)NEr1ׄI"+"''U֚ 4Lo26)_ gz_-BoY#sr/85mY裣wWQ-4߽[GrWlb)H#& #e M튾vgA9SΗO_? bSGaDU(ȅLlyM}KSq;$j{{rR0GR9 xn7_&Lˆ3)]ҼHI͆imGYPQr\uBēhih #|'Ck׬+P X"lr1!("F~h?|L-`^ xNzoa3LpwKݰ~aƣY9 ]({6B( NL B,1jc+E%-a-`}hs3{'yaK1v%_W<;v`!LΫ9&OD*g5^ DOd9 =YIDZI"$+!0.3?w]J{SU Һwlp;V↷>k1ٕa].ڦ& QW܀3 &WZSENZE SZzR6-/!D͵% oڝTTS-`P{K:rV>\gy^K镙i} cUdE)ȫ^P"K L.2Qd((/'. b]Iie0`]!k.p:s´--9Qr붨l&ls&}c̼neE.O1r|FBS_-AB+m=^535i,HNXجG6>T=D!4Nt~^5S%JByvE5Υ6roVr(59QEta|gp)ߵYg$8PMH ȦHQp0=Z{KkTjtՠ6MA#@ Kg͚PZqC8#Y܎_?n-xvtMyY^uhCD HI0G'ꀼ/i+s ȰtԍA8 _'#pF)Ê|'k\$h8V˱c/Rڑ3yN!h mocյwX(A9#R ܗb!0~gTT3Ì4LڋA8 4Ļ:53"GͪХ+]}թ=@Xt]gG#ZH la,=v,&+軤!Qbe;"Uz<{KAXЋRH6p8ЂL'6?[e:!rN@86w7y8:(@BD$ +m+-j]Gήm{>:<0^ KEȍL<.%tgYuFaly¤1Shb9_ꃮH'i1Iʙv5Cw[Bn.r)MfV]=\!ZOvDIt&YpP׀hM{f؍]߳9<{xvz.s9mǣ" rU~))P.؂>Ӈ[z~RW~ϪU%\ fGUɂ"N6$x8ydr M;wܾ3R̳+R 2aϸz|z>_)fv xEN]1rTEr~$o41YZ{KJ<ڬ1;v']i6#t5zk#"֙l:/'ifrAVA XzӀ _^|['J.S7+\N+[55^:ob-Ouxr %`G<,#C7Kwnz*? dTH<LY#4=)sii>u`wa J,X$!Pm1MK7*нWЄ^Fn_cvt \ (7"E -{->vwn!Kk>~/Ė;> .u3O#k7w=F@fgrUA3~ !c+ h9u5]׷Cʀ~[끚Dx@VK:{tvOt&c7:M&GկY.A.Ѹ|ø 8i?"@endstream endobj 665 0 obj << /Filter /FlateDecode /Length 5564 >> stream x]YoGv~"/7;/AQf &͙<@Ęd.5ȏ9y)v`nTYTcc;ǯ;~swĎ}ï?ZyǧbW~¤Vxw|/ [c\ ]O0 zwYW{x)-3ˍ _Ƥ3U4[^zkikH5jB,LyXt#UF{'U"(v]yX3<& f_{1؅;We8cLsP~Z^X8\y6U [{ #ߝmm"qbc @n 㹸45)iz%)؇>7KyϪe xKZfˆbROZ& ^K2c*Ex/ X㍩QbD/o(7ܶ,D*Cd0$o'bG<_)~| aC&逝x3NFN2۔qXdáW&qXDmqdi+4$MeoߨGBSwrBYYuf?2"/}1̘Q_h&USC4TmV06ض77LfkGv@%$VwLVzhyq ^]~ a"['=DN#ݷ;OQz!LSvYJc4(eҁB\Lc& =˚%8Tƅ 7v3VHpqT:9yVlH<⯤]W$ZvHk1>`?+ٹo7614TIK"OC͵F/_!_۞dE),tG* k a*޵eV-1"$׈JÐSz T<BUNՌ/Ԁ&O|olQLPUG~P~1b/c9c:cIG ԅnSP-Z/,8ilyE}4`{ZWՖmEH fMNjDŽJC2zTm"nyfNہ/t0]0. 彉f%՛4bNՂkI:h d6^- %%*ړ(eJU)bb,m̱Mpc[} sՒf#ζL'=yl+qԀYwct)/6Vέ"79w M"/AkLݮfDa [djKbڎx){S@bn'FӍC >E\{5Att:a,8΃8Rlѣ3^[9U¢g033N"jǝ4<wtVJηvYk ˶4h>;G}%paj5nd*=xJ˃ÔHc3*9QAxxW5iƀyYsCz,b,@M6 nB_6r踉R1pТ :TZ,#쵆@'[=D-U Hv6,Eծڝ2 T:OIGc; ;Iz%HPS2Zim0۳BuiA4]]B`r /I؃"}v"^y5GS"3sRI9Z܉Z'[)$-Bخs|q dضrGd'; e@q&7f,/hD}+k&a ;jCr$VJbGyfg&)2I ]8v`u'L|_\,cEw8R j6N4kgYeOc Y/WL,Bc0@T|nA'aDF4ox&(ͯ0ʊ蝧@g`Ĵ Z{ Y8RLj!=8yt&߽&?\UwdDNY(t4YoٔgMg杅0рDų^ CRd=ybQOtTCѥ7{QOTt>Y fU߮84h QRoۼ>v!ҥL@fXk+-f޲6_),;F$M~58:Q=UWt8"D;>F&F`eZtM0fUh f>!,fNKߏ#8O.w]߸d;&Z[ww%y1 L(9p ;9%5?1<O?:7Ӌ(-»E&^kԼaT3Qx-=Mq !MNFR3[Ceg#&nLtu0RvBoylAM]+3&v jϥB0&⺤椳:k!.aV̟"߇.-u4):竛 )Fd(FD3h,D' M˘RiuĬ'e* (*I6K\`ȣ29@Y049hf鷭F(ʬ Uf+Sr$oNx oZ#/ ,+n3DXy&Gچٝ]m.s9%Vfu9Tl\NܼYXݑ}V*F%sXp`xτR%@Aݰх,)I Na;j1ElGF~)j&|>tw~sy/h}aT k^C&q]*$0OpH.0Lժc$ѻBe5Enc.nR_"Od򓨿z-e=VnY*W2c{Gz%ʷVf9T{46Pa!ۈg~I5 FGd;בhѝ.% C1V4#Sm԰q!ex"QMH1?XC;ch'BKsT*44Srt[@p7-X nӛ=+ `U87AOA$@|,$y9y矛27ELˆUưnFlV=R6[z9a& l^KBԟ3dsm_Z+jN f 07A&8(Yg Pςkp9c|B"}1ǟ3f,-F#H!EwoZô_ߑ痱J> #ȩ]T8yr$mn#KB1Loj:N$(,A%Lkg %XB2z l]q6};2'*az"Z sliYy,j.IGBTne*w; Gh"eokar5eT/o3zo}_0maii.rM:X|+Q֭xEOD[]cE44 P]c: ҠL 7F_}+aJN+]ࠥX>BuqCMHxCQ. lև׵H|uh"j_>I[u+W`"NK# |_n65U=Gh!BPa%/> A.6HS$u57;Uѝa 7Kp`_vV`#>}XXJ,65<hk_9D[J gW1-R O01P& IZ4->'~(:!uP,uP>hBrqeh_GшWqyl\2wYL-%PBn1kہUajïa^وq,P3DJ~$WD$5) 6IJZ[؄V"&1zruzy|ܿE_AY_e`ף1Nf)(,b&e83°`ݧD'19|.0w\sh.^z[F[38u^*"e`_Y.@fn?;@2?'Z/=9\: ?2\ny~T4J^#RFݬc0Oy;b j ob"C* ㍘+ uⰫqvIѤ1r?c\ d~1'&&jRǛ-x7%D,3m޺%D ur Gee> stream x\o#xX.Y4")Z yI`[QKv,C KRp'p7w~`Wo՛W?*s[}v#̰SW~X١qqvu{Zv:Tkuv.A/cv}lY:7zVЩ^@_rTUbX?1HLJ1cdX߳!~cFϣBlUN}w A3#: gZ3 TmӖ;Etp冧r6Hhf'ϋv%;mz۫}X :sKOsvD؀:hlXI^x)3Ms9 VH5c_'N;kF  N9>d>1Ň L/2xkz D.NuH|z>bϘ}Aى.+zǾ&)'@)#hҺn|%3_kp%))fgkF+mY9 ` .m0Ma:iJDF-}{g@In .)@r"̞]\5pc~b٘т{q3Kuv:3{{/ȉߗ :?SM8}ow0 x#R=|2#|/Lg>gu$xͩzi%m|kz-'mVF6azTQ8 kP0g0KQI>S7M0DߞYP?k]D6N ׉)PLIBq%&R9,`F@֙^lA=u?6jU;`~Z9MG:EזmrVbٶfo܍_.S`AFʪ?fm://VWh^FsGT;&2 86"Y`P(OԜuk=}=w 6S`Ͳ½GY`MNflZC&Mqj*_^Lϣ*{uP.!u#Hk>ANzC,"aA=]@0C5'n(щck ُ# YbSUGZF ğ>)UMssTi#]()b?ΥyDn[z(apL+ 7<}.uEzU c;ﱮjȷ+u|}@_ $Y&`t=pFؾj%KUo"r F3St > 7\%*#z< kUiChyAm-K*q5l]R "ċ9Ny3܃z̬DUXf2/dHI&Cj!Cq=C-ep%P,ߠxi6ZG`QM8Z>4 b g5⠑,_sMN&,]:`<x#*=POao \ꠛ73oCA=*c%[8y~*9Y)=-2^*Jsӽ 6 4@Awo}bHfxi^Wᣠ1óS.U[*Ɣ@s|̋ L s[G*6 wS^8E%Z#/G-":;]Zpa禛t V0X1N.v{íǗ"]Iݙ4"hLF͒ƶPۋSK%#1<5c3|d^fvJ+rd *JNDi6\TH[Br&Cp˭iWgI{OvpeH"-?֕V I+*3 EF)y:{p̾|R= f촰5X[,}fg%Ҿ4Xr|ߏUZXe!e™ƗԎ7-fJ6`9Ha_{( Q:Kǵ=MR-/$Aj\%ܫZq}Ҹ@BSI̧JGzSĕbӿ)=t GMYĄ!gH}dН ŗt Ic j z#!o܄`Ue7Ea Zсfӧ LwWuVj9T;o{RIn|؋$T_?!*DJ軴hLY7c0嵗Oy)pZ z~Hgs } <++LWFjk^ir޼2VG:;#8U09Z'.M`(^/цVIfשտKe3 )l'+1BKܕkx+K6o(lTmR J+Ưz[1ڶR55(PpY2iOhz :V7Uo#m#0}a1kOP֮Y 8VfW1 r*M1J̺^7tgUaIwB6潻@ޝGĚ{}7 ܱd%zp-ObQQσhIͬe20>b۾D].W<U:,̅/JCVcdRQTz [DֿS(](6cy 1GJcd@a!kU;Zd$1֮vGupL/.ulv{ȝؗ1Ȕcl8of΃dV:onB}6Oi$qJ{t81Фۉ[f1Y(v}9ίr3AOEhP/_(W2a'!p8 R]*mg_۾C,̎.4慻+]:-K=O~Q u-a#2zrx첱IoWz06b7F-ݿxM"_D.n62_ʬ=K- 2]k k;w-(ߵwZ] ?_pl)S?~p!<{߀%.؜s}_Y:t*lǧnwx 8߯R#o/|?|?(Ҳv\0۷9l/>7cĭVOOa/o/ZO- qEP&^ؓywbM _BțG!Faw԰o?5 SR };@Ż> Q('cԯmJW>+xtڈ,9?FeTawqwIltRE4ByG8*4?L`YùXY!eË aakzR"ǃsȠS'ævdZd4?/RB4ynn@8pAYXޙ&^G5'ܿ -;&"Vmބ&MDJA~c97M:5!$X?|{{ϐ"[L]x4 ]!%7 5( )t:ٔ( jt[S50R~9endstream endobj 667 0 obj << /Filter /FlateDecode /Length 2616 >> stream x[[o~E^2 t ("hRqU@Y+B,Q_Crf3\J,z;ax<^|ZA<>;p8^;;nFZOxNifV3pu ҙF^ݰ7_h5? pۀ#o n' wmmhRh~k3Jq3a8877it)N۱>xqAwi$.ݬ3 >3ν6K'H;7Zfii˹]l7ǟB[q!_?< A->G|q[Ώ5= ;DGɃuq| -'gi ˀkL2peXUkY2?ib*`Up%@v@qD'l@FJ$UFtHaOi7%U8ue%xǝc?PJ&ź0 .},+Q̬@3V=B|%;@>puAMǯ^ u 8\⒯Kx+[GX[3ŤΧ1"q4&?4"6vD\Qe0T>J'wRSBkAyȅn)b^6csk6LRRP%|./u.~L0y l UQ:TLw|h6ldh=߼ hA ڭm׻\ M}?JThSFOW;=rb H %MPiSXs+& 04_U xJB@~2~KLz:3'Tt(O~G}>\QXz1 S%&ьi*i*jbjhӼ7 m8Glyݳ`gNuDS6bm߻UuXn0-rzx}GĔYyo T{` GgQWkA-Ѣ6G=.ZBwIA,)Py Z tz|<[¶&pHMwc7&@NZ#1 V{#J-~u[83T5;ȜH<0c)Uj>\_(.bn3{'T P0FdaǷջq{>!T!')FSҹAc{\ yYz]2 q⠟d0ӇK;Hj5;9oˋjy[ńMH'K`låw7ʔ-2tR91?0^Gڟa0TxJe>]Ǖr#,zeiHu{  O9ۇTI9@H" j█.?9l Pe]YԉšpNW,UJ&yg{Emުޑ,&n=\ (朝-rN3҂lendstream endobj 668 0 obj << /Filter /FlateDecode /Length 3739 >> stream x[Ko$  ;40 qb[|jf%Y.⫋lHZ b=*]/؞m'lqy ..oOa zX? SIqvq=y9l'IǶfL Ķ]8OWפb)y8r%;';2bm[_8Q{Ҿ#qU[6taIɸmM,%[  +V`fk̻m5ߤeT=4ߌs>;P.8^Q ~oֺ/Xo 8p98p0Dp}Ol6aC$V9b7dLٓȜKa y ՚02Aj(AYxwDZT*(7VRkl 5aehSz8'ofk.r5neƩ̄=lt vY<!xCniㆧ]x.ˣ4#PejD8hUztqݻJXp!r~י>,'l ŦT_{` `&Q0%6SkErtqCǸ T()W{0mTp%o  Ɂ"HrL@v{~xmWv܀kެ7Wnll3.`VraaFClYS"ب x>(P,ьbD?I7ĘrTQ*WPFޅꆗ}yrW,R᠒h9B@ HCR']uTq+U܋lg,érgn0\/{/Ygrd#tQ 0tDL2 ?֗IVY\w1tCa:)m+kep{ثd kƏ)cJp]XqWs78pgƥ,׆9F}47k^j"Ci "cj;/Z ?dVs#MO-CN"9|BI!χ'l| T*rf{NT９&5fte3;(A@ D mN)ɋ6 MGS<2\Jjse@V`C^Tpp)M+#DJAHs**K #nlซ.>[Or{;NȈH=iof "F5XKvR 6_;#mUϪ6E8Spx5qq<*~Iγ1, @t|rg:=hb튃CRCАx:S(6>,o(7B"eKL&8?K 85Ł) BKI.g2_Q@Q HkWE8[SޓcpeRx5C'q僇H.;a6xGVÙQb>r|D(=l s ӂ W|m B4xQ<?~H>8-nj>2&2tܒ!#Zy,1fJUdU}}Pʻ'3KM^:#Vt5 zڒ-韃k'_zHGc /pxEaO5$SDS_sp!!PuoF_8emj+W`oxԹ9M{n Y.C-]yǺ* e.σ#囹HuK\֌3wiL뉴sF:}Q|PgGns:V 7ezJ #` H D6#BʖɖGU]r9DeNjz!Ħ.)kUh!^,HZ?aF?gL.S-0U+|'/kE5[uTAF-/EW)Nz]$TY{,nHb<`mEkv3}HPfw,sEKO3_l*'cҋȒ>O9X_%&&"-@{y 7].2@K1K;OzK&7G\[xp8~fφi#e4kc"C|`yx!P?ٲT߹UX[[oouSo2wM8^{ @4U|tQFwsU?Zf*SHG !ZèG_eIwy+hתJ4dOJmZH@W,ܧ@3z0B)g +IkotNtNچWi_l\D\ 2uX6ޘ$<,xiKfloO2;w^?~ ?(FTϫ9RXapJFA} $;n` `VVZ ."ޥN'G’\jv߿˥ 5Q^1Ysi%d#=w\uaH97<؅+..8ބ2} !a$N}wΕ^#ufzGċ0LCZݿ.1KxT:DV.ߌK2nu<[!ب#f2ɛfr/wm#'ťn { E$@6(t32 :h(@dڶLUpy$ϗ1g~K#yOת{!*S1M2m}LJշ#z?WpYwٜulϖ#'6yU\ ߎ 5%asϖoWOp65L{Y?aIClx<fizKysminw=\m3j$9ۯ}v G\M~?w4!R+!1e ØOC%endstream endobj 669 0 obj << /Filter /FlateDecode /Length 6363 >> stream x]io&qN 􎦏C@Ȳd+0lbVh\rC>ܥu 8 ft:_;Fʿ? CͰt]qx f+\r>%Xb@h:ԺE]3RErc&MĞ߰59ZHNy79Гڇ߳) . d'+v"\d`Z;gL yXC" 7*yU$ٟF6|~} :b-H[#47\̥u6Ls SuX.S$f>:a\DUbi`S|=H'za]OOR;q"2f!3Oyvtv< YC[PviVAhr|.yYuXx4p|QRnC.Y<Ijb\")&rS)\fzÃblNU\Gt6RX1q}~-cW tnzIBuK.Ѵfy'EŌ`f5 U+?bEVLZYwx[[ҬHݯ;3b$UiYJutY, BJg\2mb ъ=\bS7W/ g` )bW Bq&d%i3l *FBʉD)z%q0t\T )W)1P«baPܔ$ ڪhgT]82o3 U\]y5PX,aAz4y`&)u WGU4+*X܎܄xly_P<w4QQ8CWQ+c]= w-U<l#?3NriĴI<\i6ZQ?}s Ic\@ʎ>9 8wԠjb `Druz?iH)Qm4ғչ(¶ge,TϸtH!22!R75I+S;0UwV!v0g.7qbN'aŅ?scpZZPKJō[\pݕTFW'G]NTMpe I>jfs Ub?oW߾`?'k 4aok]oYON rwj$fq R@g"G}QaZ~ZaS(Xz,8,Vx4X3[tÇy7 %'gw(O)z`4W$s1,n}EVE w )r~{3i;3Blq1s-`98%!L]7'3U.j͐A*K9">#"\005TGrsw-(j2ֵ Kd=¸ p4(5߲ߤ S=Q8hCv}v7nzNc.]@iLjKɇ\3N$UZ ynĂJQS+_Sj^ `R{FV+B.De|˾=^?+ <۾k8^~?wWúWOJy5+>FrA7|I. ̷HEa 4&RR W ,95uYa =Ȥ^}%{=`({?c?j3WRjU[__ YfvIxkY<`[>kz18hicpsId1HiO1knX_{ܕ>mh|hhq(p -eBCۦMC(jɢe@&Qbx\&-Rbvw?K5%?2-X@ARCQnJt-8%>04od+lKNVۆu\ї\$ρS+Ur̜JE,HօmiV*v 6;XJ>yA<c'@A.m _-7_vHT]᜵`ޅ N; Ƶ4 ]\ބY܎5b-kݗnFi>IG$Wu/t_'rkt(x)%A ՀDs'`<Wۓv2Ì|{p7W:{~?aUzSB'nrb]QFxau8}'[%[+3U\?r:NЩ WR?7/=QնpenA503=!>OGRX S:)htEsTC=y&9y(E-y(;By(i4bsP`P@jP7snDU9 :Yӷ>XW23~Sy"_A-]М+ct62{B1G z^%9Q$w۞I_QK*6gOPV`h9wmw2Z4bDepf4?Ζԝ\<:oGȆq>^/C)LN**g}`}G@ML@]z0 htje.;6m>-Q',+pSRV=e'Ü#' 6_r[BG5DrWگ_z.K2PמEn.yU*MeaNc:Eڛm"y:;$P61 n^ʌWf\p%i£ ӕJq ]sO3&+fO(dB ^*P-ЕG[V71eMS ߅ٸ^#Bp5j=ΥD]{*KaL+6tV>?w fPzZ^TX˃ypz;=БFӟ"}{R ;~MNԎ]fXm80ZOe0NL~2rj-rk4Z k.GizSVT*:Ƿ_5JН;nSPծRQYUۮ_DjO ~vn!קzSfnt~.kIU:O֮qR%hGJTE,7ǥ;{fܫOJ.PU> %Wjѩ rBsf܌zOߟ*]Ϯs *{aQ)hFM z y8s\JSVVDNx/mj$~ϋ,_5! ]cٟareGSTu״X!R N+.";߆:vzǗòۨcujn HB[\sh> ݇0KMZ1 ȥ +7e_KGa<,endstream endobj 670 0 obj << /Filter /FlateDecode /Length 4046 >> stream x[Ko#+}(&~CA[HV#h!zT rvs%g3ҿh7;^ŏ<:K,w`y>smr3yk].k>\h[Eiۮ'|Zus8<74tַ߮t\pjWvwXdpݼ{>mN~ny&a `5[cǸl7us67aחY3[ oqz $Vi9[ E 8r!m9bw|j9Sgƕ6b=rߣ؎;8ӺuEpܒ}ԛ/WYՕҽT1gtPm&r |$izǸux?yWdιP aF::u Y[0'[D+[MmɌ6`R;3xTkY𗮥 WZA %D-l+ڃGxVWV3@__z >kA(DԵ^ۡOY tt4${nE4|:8!dHa% O.acKӍmƜpPMI 6O8D2!~AhHW/4(c4',B)rEV1BO@kKz4&8.֮ݑBvJA"Odxp0؄^aQ"üH؁Ȑf4 8Wj!Zy1 LZ2DFc/hf\Hu 4Oť+^k?,;EzL&w]IE%`N)Bق1*x.d!I:vy8Ba?&m  J(#z^'GwVGL`7eI(Т[:@b51n#)U*ZQ-0*e:ׁ6NM85Hpԙٛ%^Xr Y&ޮ/*c  9T6ƌ)yCJp>~WD&K2d M r͗m֊[:'% p\aԦ9l#4tZą B,i93|>w5Rqn#iE d2nߏF-[g}LXVWߏP,Vڱʡdik^(n,@;\ "&&!กLqWڢZLe J )~E$cX)^!>2?>5GIlDME&> p1?!>>MrJq8PJ#CqH/e.*ب.J2 󧤖2N#nwղTF>i PLZUN~WeB8H"р { Tzo2p+NB쇑`1+619cG۹(2D,_PҋtO&jST2Itx s`aNDXbBzLO޺Y+'g*n[JzT_1|BnCgy@y~̾tڃ֧S_ #2Glj NJ trCf9ۉ[fu!tvD"nh񋂓/h6 Z&d"_fp9b53Ʒp' ᳟t4z@Ve/(I'ۋoϿH DEZ?Pfdkړ B w}o&%_> oJ ڞRHsKGB EC_ zhL D痂:䰋K ' 6YwcK~ T.ѥ6zyI_PP! Em~*n\^:U>z [.mjcFcMRlcҝFEqYm85j|(T:y͌T'pk6FAIC(J^DϒjxA(̨d۸|!7}p[13_'#{r&:Ν$÷̦\{xŐ-I=3YhMsߗr j- {*ޖ*7r,J-͔.4td "" &Rv= jd̗x3_iYᕐc%8Q2Hn&nz0.ǖѲ<+9?ecQRGUVè`=ykNq8^ʓCcyayxUPWyarMpzmVyoz@g:Lf2G(1Frv@g…F@k+ T6wD3pq:w|h MUt~s& C$q)*o$*k|3q=RbSfendstream endobj 671 0 obj << /Filter /FlateDecode /Length 2274 >> stream xYKo$ #$A |HaW`H!լ$=쨛ٟ7bw?t&6>A|]7>G 6c0FnίQx3 ` 6rjBwPJ!@D6nwޫ13-ᇧN;mBP [iGn؎\:j5q["[%€!vQxeHwGQzg (Ƨwп  myd%^h/B$Uf%y6΍BȆX_%8DC<1w\m}3ec<__F#m$ nw(*(L ;`lJ;У:$ @K#;TRw5:swtԏhTD[/sO c8I/iB1]1FE8䖏JJJ I'V9}_e5ɋ/ (!R9jN?B1m߇:NRN"?s"Ԕk*T4sȤO>ɸXՔǫۣsEů̷;ظ5˝ 5"R2zI,DanJqoO8WTW[(*cXO֒>yq̨.x)e m1Xk*o )!mX'(j@_M- Zp$t0໋Q]a - to|JsKfQ(CP!eCUdt CЇkF(P%I= (`" H40*O 1ɓS{؅ &u:&F&LY`\5L %ꒊTgrAD"xNA\{WpoYy©i3^eA:k5hPwy C˼Ƌ1~o b k0hna*NG/E\s7o0JRP&A)m(\HQ|ԳVDotShi2̡J[[J9*~+N]At.&EM\$tHGFŸ@{RL걣WN cR1.aU:rws%f08G+]F]J}̜YKCMlo) %=U@ h۵a"A&sɲ.\`ꮔæ)rgcƅ`h8qΙy8ɿ_HG;_LLJvㄲn&ͅyȉLLA sfY4Ztf yl\o9N aJ.E_ 5]wQ !69eoQxB8aP@:z6):s:DQTԓϒT <|]!uoT1a𣱲UzRjxðqaϫt])$̣>|f[zJgؑ ؄̬>{{\H_`q2 teu0⑎).l35KFr'u9⻀s88h:10hKl,-}ӹp"u fY_,mc 5_ryic NX]VeM뛟;FZ>,w*5G8|XXI6Tn)[FljZ򮑾׮!;mYC7X kFH:v Զ`^ |Z .׊Yn-Y6n|n}ʲz/q16;CC4k_(@rendstream endobj 672 0 obj << /Filter /FlateDecode /Length 2929 >> stream xZoO FZJk")Jd<\[Cw}9XWNv4$eǻ=E]F" |9\TU1ypۉa3̨䄱\K'w+M ٤,m~ޭw7"E!8d|Z楮('`Zɥ֢`Ǫ($:"n}ta}K_Y*s8ְYqe-#x[85+DsƬZkj}3cu"Ky O_Z;{4fjT^Wn 2$UeHZ[2^9Je7rZ2ޓaU\W% Bv֫s]۵JX^:DX16ͳ./0M zDz?8 =2(CRQ~GĴƪQ\q%RKu|bXi(rG6Qd`+pKok)nl2iGJ~ svC `KTR29$xk1 }P")yv#$7?lyKUilb$䑴 a]^r@h]Sv8Ղ Ц;l|\QmL^Z,2ei.rsKyˆU%;I#h '7ߑbIRmZ;TvUJI5̛e-kk-3؊CFuL<*=mp/3d8%Te𰚠q[ 9tr`}zq\.a$ nj䆮%HK3,cHX^;ÑR3 s^l<կ'߱T'T'3nY:2뛢@Uxأùa4Y  sG~6Fi٥uFbCFɂ;q sE { w.'~ K1|.! z~ըk ƢKfMkHxLm(+S gU) &t&ݙ\$0O= @ v]XRh u&a{!v.Dhkr+E\E1FP6|DU/:NDw(LLR}=Gx-0jz!Bݡ%ݨɘޛNI<&r)un4tHrrzST"'ȸk0&qOQkQ ީ}zw\W塋i! q )[kP'wt/2Glcc~@1n2Xy햻s*3$=r<ͳOrc1 M/ʇoῚkvQk>EYvdxlk8 i/nj`ebjp֦yvYt5z՘G4[^M JylE-,erLLbZLbUD`ڗfЎ0C{=L mz7j,%v9w:i}? u7dش[۴Ykb,ǵWWȲ7e >=g,'̳fS 6]t\7&$_h~84`ӾYn޾CH7mѧD?Θ[>t(~i}rx6ʮ0 8<ZÜeS#zZ 7fo)'JSF?=2;LDу#E1~K*%T/FiLX'́)r(P&]Rp!f.#L,%LM2tS{ŴI*[}W󁀬q#"2ȡIBڧ ~k8МZGȕfQ:㢒'.ժ7۞v5$sԏ!IزNEMʜj2)AHC؛FPendstream endobj 673 0 obj << /Filter /FlateDecode /Length 6269 >> stream x\ێ9r}oGm;i`؝}=2a䇖$n_Ҏ>KdUU1e:$8$OYfYϐ7.^vSy{W`D1f.!ͫwSa^\1dœۼi˫ebln/@{Oh\7*"Qq;uHסôS>guU2gԬKTLWv[Ղku#Gur6y)R,Zӏmc,VO/ I?*-Fz[W^W]vSaTԺP y\eɦ[ usͫ?]sl_Zgp:?O݇mwpF:򹪿8^\oxu41&l,uisw0"Ĺp6?c,3fFhs`R]p7$W YQU(R2ƺFPH:HřeE AeC1b@OiᾨY#F<!cfasaCHs,8̒,g"fўzx9#F0Htt&b'0xN@H}f2g-YK8f,H+*nb*3$Hs c1(d'nB,hu#œnB:P-"73!ڨ݈@^7͸DynSsC!^J}l70L:dBGHrG(,l&aҏi"09`ddjf)JGX%P@uVN9]:I ~Mth9Kz:mA]F[@A||/By}}@YGSܵ@&P?^eBzF yE<%IJ#:"h w ⅋AMfJ<7<Ȕ9/4!Ӱk1-:EO9't4F)9CxRqQ ⇜霧E"yCOHADH )sU(ҺΑGXii003Y MKz@L#9#xN#*cag2Y]&:KDg5!eLTN g03tgDW ~AyDC%aY kSЀgCJD&"6szip_!=!xJڒ"h*RC*X0UK$`c^xrcaʹ,Y F 'OSh "z#[A^ g@+.'`Jkk * ͯ3F!QM=UR+9䐴㞾#Ax`xc<0V_"C>_O{4E,c팤քnW ޡP`FK˓CYF.XI_$Z0҄ pD U:@";Gi(_["ccSr튌`uut;Z%Ծ 5%% B~ *hj2{&$ LgkgQiM/Xҏ:iy^&3Ђ~9K "!!L쯱E^{S!CGjm4EQR:EEZWS)y 2-K_>4#J$TzvRWFRIM<ghgtl%ӕdJZ>U9{ƳG1J9箓!Z9\$Z9)xV{r#) p+(huu@:IIc"  )uy)r7N6<Ք7{se ݔAܗZ>R_Bs7Nr/oAB9!bHKNH% ^H ׼%דLZpeHc]S|Y8cNhN:eD< oLK(Kt+ss[lI~W~!ia!kZ1%~qOFnz|Gׁ ݇m„{/1R٪D(KDnwG~%O>Ex]i}^e"Ï P7*uGvکV;I-]w٦oח3Hv~7Q2-ٳX^*&m#y@”y}ywP )RiA[ Wo?o 7owvR w+}w2f=9;m?>\?Tb7w[2)J>*u4q_q잵l ۧK?ZZa+f\jUEkWӇu3Pouu':y'Օp9mg7i3IfKlmMeml@/UwS"EbUG:XQ(Vue#Ul`:JyE+۬HGnȊ6/ړnȊEnoȊ01IPXRUEu?vVtspO\)XگU_d6*O6=Y(wj^ )|Í%w"'^,ś͋hGYj1͂fD;%LRӌh ,^.bV>4Tޖ|ri~v Gh ^f͊,ՊRwEz\{X@V]f+ڑw̎G$qdz9iӬhŰ]Vf͈bh?obW#HݦkF4Ł,*auЫQXQj:)VGHګ9h%!̍RёtғzYJO:Ig)=٫"'͌>COFo1x;գku -yzh'/O5?wgtdoaR5uwaudDrB#Um bU;A:Xu _:Xu\:X{=qNjVA:RGF#3WgY*suV\2WgY*sUUN\=#sjC#&гT!5`f 9lFHlϲTMRG$ǪK&Vۤ#K<^MRGV8q$udVMR0dTMR<'}r` M*R+RGn+VGn+VGn+VGՑOhֱ(4 +Bk+9?cUK!kVU "[#XY ϬXͲ˞SX@}YYT/9x½`t%sBˇeb~(q\C03SGt~);ߨWdR˽VG2/>v@UGRrMJ֣?VXKʪIE;[GC,|<VѤPdyd9@l4C=׳yaՖi,.gu(q mxduF7<0r'̈́z4$jzbɫ΢@54L_>"e7/Gth ݎ(pfuDhfuDJq84fwD^Ցos$Z:nWBk/p [͋}o оYJ:k_g)u]\M}ӴsYN׾~뽡#2nj>FkBiWDF 8i{>cM7-U Hb%֣Ib!*ꐍ|J = ?I i2X]{Upqһ%mևlY'"G},뚫/Y 'c Sw[jL^K狹P( G,}ĥ3#Q6=9@I KPs}OJD'ni/$~-Q޾ʴ@9$34c! ׀V_ joMmrjiT9gAIl@l}NMQ179 !D6" H_U(^E%:z讅QmIg;eKsf n(~_SI ƘJHЩ#J;ydVG#ܠ DkZ;Glۡ9C{Pj =XC;+tg)НusBwNS fE:]{@{o!Uj<ڴ3Pk;<}vmχ3+~mGĘRБ&$+<١5a$UZ\*F$y9"?CG9Mne(7*cȱ#_ @yՕ1{Ⱦ[zĹ6^xd A_td ӄ/g;xtF4٭GEȯ`=Џvx$9YEqljȵqD9?CġYHew}-u-^}=}g-HЛGO<Wxx愗LP Oۛvy{#1zz||fܩ?<+Gu}_Ro#URwzÿk0դXxHc^ߥf%endstream endobj 674 0 obj << /Filter /FlateDecode /Length 4344 >> stream xn#_IG=8mp x$MKRSLu %F=u=so_fl~={7+&V(|R\NqR40-+mmx8iPH`ʔҎS +7.ʫ(̴F,QhwjDE},&) 3(6)+Y:]sѐ lz1]a/3Axr_ KRV$&&G33 "$ǝ΍@7P@XB wtsJntǸ@AAB)JAGgh0Ǹ z;]18ҫGErhdMXH!cAo &{4[x*'z=Hbh1¡3`҄q(S $=*+7z- BkXL bA*ٛڲњGkAWOMƢEr,`tۭGݿC3UO w0 RJI8)D=# 46ZtCH1qU6ڎ븃h)Bcy'L(;Qj,xۚkUpoH#eӿ.$ẁNa泏@ Ur;e52ADK;QIi#*󏉡 =GjNH?F`emeTʰb0f@i+ KB4 {I}N Y7nl4IGup4~u+]G 1%Մ;B<0I0[97kBQT/^-bE]-^u&pI]<ѹ\ LT,{^ bG`/R4X} l)~m*zm*SSX8Nn,DQct #d('2tieǣ0fd] ).d}h>M/*M %h43($ce@gaAE{5*Nnj7fceTA0L$r$ 沊0,tlL=OPEmJ75\d :=.|X`KOmS1SvCScԱ6cw,m/riƠ0!8V3Lֱ@gt:+G3ne{mF]2c^T]##P}^T* ),$OќrUނbc=R#]ͷ,u BN{Ou@BeBeПcBד 5u'!P S{6 )د_w)PΐtX+b~/kQ) *2c$ӔJ2TDRa;BPsB`Q(.tF<W13Z)heAkD]O])aZT\[~JcŤ頶 M1 ZFvlBFKחהI䓶w׃Q(Ut]_ rU%#B&IEhϟ[e؁q_c:QI ڡYiIs>Rtl t2E$++T4HM2GSB> -tYʇ-1][*XM\k)p$cE %NhbU8Uu>U@6"-vÒ^K$}FJ%U,VhY4 |'i3dj|ΫR *cp9whz.SdO0ˊ*wrӝ9 2CH9A r,5<ʂ0JGrW #Q²xS drtGx!4O9l°gq554[3TVa]+()'=&pr+ck*hH* 8J4*)1bxR2tWw &sqe* _+PW!٢*$':ZU8C^78@$H܀`h&=U4OAg48Hm`>4\ب H3H23ԫy9~wmAhNT|x%DVh/~hV"C8(,\Dct%f ^~dW[ qYs1ST,8Ӻ9ݤT)MhP̰)o!! wvVtpt`[(gE)Wz & =JH [q=esw8,_Mnµ .*RKBUt\iH Ţ-bendstream endobj 675 0 obj << /Filter /FlateDecode /Length 402 >> stream x}Rn1 +WbiRoҤK¾Ʊ.GZggFəHam]ءw/M-Q}rD{]WSI%hTNW=A$`Ϝ׿V=Me:Ճ)6 J5K$}.Acy֏$,Vok͌heR}d;QŠ $DO^?.ǓɽV~3+$B'LqfXH÷0 ܑa(> $P+mq#2ly.jG6VE7 jnhf\7oO~qGG )+-\钣@MVAĤh0:a}?endstream endobj 676 0 obj << /Filter /FlateDecode /Length 4938 >> stream x\YǑ~GRއ޴X\c!i?ȄA 1WE^Mj buq|qdc 1={vOO'M H$RD8lIPgB1p0rx9;NnvezXx[6%g$. z9\VZGӜqMnC_)S3 לO85߹m p7]nMgUdTɉb͝8gf]}!>o7z)`ఀ-!nWV50dzLnm H d &ޅ271q, 4m6caqtyz=Q\W 微7j|6RXQ{OkDZk?~ 9 2J ׎)I=ilrɅnG`*#vWǛ!7@GȢ b$_ ÐSf(*y/7xC`bù]YdkttQ6Ǵ"2M>:1&@v3^EjPU㙙o9a+›pLL`=cPƚHK35G+pNaUFQP8q4 Zk~FfmfGVO?uv+-fկv'$('! ~JWXb ).NGM EZhr=Eh+CG91wOGPhYFƻ`zb> Y3eӧ{CQcg~R,36@@}ݒa6F)]lX qfKeGw|P4DQC*EW%=Ӕ,[$P9dc{%\.$,ʨ(b!?FHbyNcI=lǛVb^s/,M!tXoO;o7 *u* $gQBZ듧\(QO WBħ[3B7eݶB}5O 6[H+Kz*2hp&ۚyf 4;jPHV;+vf][)G|}p#P))x|MjS-K}ߴ7AJj9i|2oh0_m's]^e#]a~,-!swVNϪ0w \ŪRf0_MΤϔŌq7YxRo{0az~&/ZJ"38SPZI.lwj֔S胇K;vyegs  VӔ  +}kvcqYǞ8f< xYi8\hX"lc!q;1 wOB( ?`4 DSPwX&G8sV`x"\$,5!0FkQ? ϕK s$lwXp WOYVqĔ"$,oGIj!mV9Xf#,IYQ9hf« wߪBp9o:Bj?)I vҞ o96Fj2* U7.KA>i.4~YbOdo߷gؓNe$$: KV:ؙ.CF$ u>\uYik!ug.LLw&dVV>%9g<7I0áE<"207-Nɵ  aTPg>*8x[)l;B bFY!.Jg2 gs!F+-3]ā*GHۡ i|Oz5tQ4f,_. &)t X67N\!ic]$/ӵQ@e x (&;s]k(KH$+x?U~3>F0&bO>p;aIisBW#?KK`K?09C@P0[1jsl5ͺ 6S%LCфY\Yyup&QO sZ|(/Z.[D`X=e(W867b epK ٱ%فI\sˎ %v4L@'(rRxY֥M?nyp'ŀQy1O֤՚f!JQfWa=.1^t<$z>~>v7PS$T@GTp;Ǖr x"DYe0Buj;Jl`Qv/A)EhtG\.sfhsAZm@)g相n(m'Or^fF)bE]c=ot0˜gKYv:|\%~[ŃV)\$KZ Um nmᒽDv0yK 0; G*c$k#GBMy(C ZT" 5B:юt*<|Lo)}V̓6%Uf@U/ajXތbZƘ ٻޕ\bV]l=.'YQU5o}5OK: KFcӡr;xh|Fp?b=}k9? {nJOZVg!31$_xLmfg&zs_|RX7(iL7x9<@8 ϥK[;.v~-ҀTnrf ҘpUsK*xߝDmE`JHrU׼X.x3$k[r>~,ڃ=1e)A.}qآ7֊zzaX]N'*Oq\Vo"#usWZi$aZJ _֣>]JiL4|:j\Gx}܎gAڅ*_) x~QúB OD3jC=°3mW 5D7?Z7Zxju9T_HB1đH,Blu5(LH]> stream x\[oǑ~W#00}$X>@dTUwT#Ey@5_UO'b'/_}'7ͫ^IIb'LͫUx; 䉳r?9:= |z&}ouA/젅wBR.7+tf4qj6ZvwOujg%w=MTq[D)XKj2'zu+4%,3żև a?r'ǧ] 5zU#{[Q▻R'Mx`Y,6Ŧ&7L'x\75P>Jl0jpS6)0b 1h}+U &Ǟ/C':.|4'ȖP+_-TxEt7a;Lҳݽso+++>SKZM?㢟!ޛϥleXt>yޛNOЫ\̭q[3ڛl 6t#2\X=TCa):tDՂ/_]_;lM3XhPg @~okRS~]]Zg\B j %ch`'ڰ|{O|mE[( 8 E ΅RG@hÛzGsÁCr.$b0n({zj!G'{κezk} KJ!v\m&QP{ߙGQwU/q(yRKܨn>|2Tee~iv\gD+iO[Iϋ|"YG%rW ` X\91a}k8a` R.i2D_֓%@dQσ}hB;=yT$z9x`^+o3og4Iхլ! vFN۪Q{tq:r~>%5K>#07rvU}YoeQ-jHjAUwImľjPҊhpB.ygE|`amJ¹}dT;d`Tg)KSybkW㷽l0(bC5qL(8JǴ6!Uno2=^JF| %MxffJ+WQڪU]mb+,!뙑3Qazן Fj;ebF#1IfE,;3|>vK;^!r,wI13lH)f ;7?A?\ eo)Ã% 3JXsҋQ.ZIbj 73ψ5JIeW%XOə\7 i},JP0=wRS cBG05 \AumC`'ycCUyYtQA*5k.2/TYj vl͆91Ժ[(C+LW Se]t&J/W&@eknrLc~X BeB+L )8رϐjYiseq1_hY]bY|6-wa˂ƮgT.jV-ڕ ^ r[o`̂pT ) Sbj%,c2b#VNG- GRDZy e0ܒ(Q 0\P˓s$*y qGHV;~^c|TD5a)(D-3Fɇ^"-w&k>l_= QbfۺsxJ /-\>WX"5uW7|}`O#q!EbpY\DS&n;ء҅${-RP|UgbXJC߹}_?Ng{aR$$i +]Nb/2aP)g58+c o,)3y'` &g:|k_ kCa,,T(uNJ}%eg1n9E*I3?{BdH"g0;je>^.6Q`a" ZS-IYg1sڟhN&F"rٕ秉BʃT:D;䴲xz Od`)oJC8iQX ^lG uDLvt.*q.^ՂG|(OM =B)ޞ-7k5f" $E2='Y5*cJL$̚< )y7f*Å@@X@E_tsn)܈)TrGM LbT|5q[#kC *M/CpdwڈA i9X]FqIfA*D0p5[>_sWP/MᾣU+j0(MBѼ?AV1e7/}JYͬ|h#cs7n9eQsL[:VVT&ѯBR^QBy-r?sRI?ˮ-C޲4[$}6<@cU9)%WdFPb ue0K^t{Q1ubeq9zdueYOJxv&7s۝¬[&߰5~76wqFUOlJ;m8zA{Vs4=LrQB8 (P6p+CІ=&cQfhO|m]T>^GqΖwPƻ~ 5GU&]$!fQ*zb" PF%ApR:5V#Dd=z lЅ8LU4th)C*~v*>`ﴲu5`I^,D)9}.jW*Zn8']E$x3H-f Zދ~fp09?0޾`DY|D->""QlgjY U&pfL;\uqQ62!Rڌ64 /=Aj^|`TYaXqqe'v?obZG'ឞm#rTL{"V_mn]{0\-legm&aU^ϽCn $>hfgLk%taSE$FMIG9.WEW*z3$ 6Rx|ѣhw\9DreL".Nj עTVKjБtSf/)$koba6YQVܨ=[.q9*:8KiyGBFCOzbkpbn0=o3-<|/Az7s!q֐Yb8U™R{P1^6 Oq:dM?:Ι.`@G:cWoSê _clnڞAq)٪j|7=4tŻb1fY^[M|1pn[N+ݒb lxܠNAzS^ja4[Wi8aG]F_MdQbw1hyse0 =gs,Qzx>v%e{8ekoDzg4xx3X)F6A阏@8H)`6ٵLu_Ш52XT1~%:2z!`.KM5`uɄ1T?- 6 %۴ZsnsןI>cǴ1U 2ߞoǠendstream endobj 678 0 obj << /Filter /FlateDecode /Length 4181 >> stream xnA.f%I`; ;_l$Dў!)%_j~U]3"dD٬z^zb_1?};wڭ.'luyꄇ߮_a+X8nu;a-NؠwޭN8z'Z3&\?g8b}?ݥ陴ps^s9k.۸\3~ "}pFpi|w\:/Š N :^_/7Gxkg"j )`9 v0qŸ#^q/ax+~u rvpIǣ8 >' F҈[1xk@L7 .9y"N*6u%{3d35׸#[ Fzׯ۫j4&s`My8h[|9>;>;=j3ّE P>c_{Np̀Ub@#@e@ 0bTɞ$퉰>rP-҄=N49FtHlJ]FpgJ (P%yK}g~@7~nv{^dst]\KyWy~B??`2FpIj*vPy];Q>vB* Ն͝=·\u`gf`,8}(X &aZE=H+/IP ddq2o)%L*ЁY,Cu~;;TZ?cd"yOqq:Jf/ Y  x7@:" Ax}NfpK4XC>0ӺMP_!3=wf;-kD*h\txChTK @zATӲsTv;C;?C*#[Ƴ!2Gm yqYMӴEyއB):R}yޜs38gEC4i/Үi G[| 6۶36xNeN$ѣeb&Z(C |nHX ku{O~V񮆯A 3/1 ć@fpZ}7jwOѻ{K5:A[ N%jU,?=| &OHlmo:l ? &)gAb_)4D3x1(~86,o-/3Z A-%M:t¯钴ؾlm !OSH`Жm\ q/l}(r[4FX/zC-nO\eQn̚H.æ@((IGIϓl5z XuԎV[h\BbS L?RTX"E6XA8ji˒ހm>->BGf[1ۓ8sJ,X,{n%{E_*}Ab@*iΟw#LX'Eauii]e!9=`us k5SpƧuu)l+CUqWԄ 3LqȬs73g=jGC Rn Gf0*m `JRF2qhNB/ÁsAУkotDg-H(}s=Z V~Sr4 w" ㉪^YZ942$seIд?cXWDŽ$u4/g3P=HUxۉ%v %b ,ꊴr[ HTHl(r$yX|SC|ጴېOD8%7]~꾼+,=pqr O*h~WF)?RC<u\ֲC igOF|M3gWD\׈޼xjRg՞˜$%G_F0(*Ԧd U}p5mT&J [l')0FY, wm;B Yxw]40f֯v'd>ɓn.ZQd;$_icvri'Yappgήr*@8s1Q2QuW\E1(p;n+[,&A..Z;&dļ [Ӡ& s$iz>-[jr1|dB),I$Rr8gzJBq{tS<dSn"^ƥހstʞ|z;zڞ.IԔY \ۘ0!)jlO1ɶ{X'xt0LA<"$BB$RhiBڊZh{k}zgg;HvT~amnTTioK S! g*uL]^j,( $CgTHzW;)"liI 3A}#=Ӂendstream endobj 679 0 obj << /Filter /FlateDecode /Length 6348 >> stream x=YoGr"ؗ&@vcZaJ")<$QtUu_53$꺫Xl局} ǗGÑ_e4[m:~yqDCq[o:\K6tQYZ$/}C BXgwtRӑ_msNh3lLI/W1ml_]15S h X3go^o `ϯa@Q'sk?;X+F8LCږ5k 6߶ku<,#uqH3t@^'5Ӕ]06\Lڳ?*hjho~WY=zIKMsQm7"Kާ[ EG&-<׶--gHbp0kr-gV=+M6:5< JoE20MG'^X;沣XNY=%DJq[謍#{l,M'v|+&-TpM&TL*n=3 J^p).5G\˚+ɵ!ZhF/,7etU`AG25CSw$3>G]!]hv }qADǭKA+hF ]JDث~cESЍUERn#_EX l~8e!fZVQ UTnE,kxNUu6ytN2tiVO]g[ G!}?iL%h+VQR?ba҃Ī"jevl=sZpZWSvG*9ēC [+d;'yhX(b▐BCVEp۶y@c@-yY,?]X]+ 1)!$x>=y0vHK-ϲ# ШV˙ĝ@0N.4R.l: =ufz^݌Y FT/,E: nmt!VH f'2a$iP( ;$()7Hu >I`y Ό7!]jqDvx8/wYhɲMN0ol18ȝ~ )>f*BLЍo\inx "|k9̟p0<}Qs|&.R>g~P9>r% 9{BbT`L ~b=\,˕?Y"y۪Aqn0 8Բk$-i(foa R!=|>s <'!Te8] @h]>*B迄q:z`B`Z؄d:GA9bQgWix􍗻bYe]O= e cVm7eo`=@Y$JT \ψO#JFUVa񗱬.`>^0qՕTXe*1T; ”.I4y{64YHΥW@eYȉ%fK]b ֡4ƈׂ*OBW \$M$7 Ե3sn|9Ev%FG(Ux { 6\H6%J m+3̰\Wd]ČR m.fHw0ee8g/|7P PǘpeFjPfբF`fXhg7MjdzԔ+LBѢS2 ]ߠx>,w}Ac8nJDҋ>|fIqlq:f"N+c]>2VUZpt:7뻒{ **>׹$3/m׀d8`&TrlIIh:%ط_Y q| [_D|{21$+7\TO6ZE" hx,<'}'}4%q֊i%Cn%aI)7p+ j}--'ˡ$s[k2Q'娤7C%w7Y>S>0wKIՋaQlv!jyXx| K3)]1AH7Hl |'r1$(/|[N D(M#r;MDW3:d'f>fkO0fVԍ\lR^ME]&k Z9Lv0<*hβYS- Gn6w*gx!5J4(NS&!]MI=%/6[sߘ&[y"\}BŠTzGA6ى`K|0tjId=z?0|ᵒsnAiFl ]\w)XfŦL7ׇ\̐xHX%J6bSJˠ\T)!Ҷ^ K3TY:&6lTߺ-/2w3T F-y kQ)6wD\ 6y^Hx)F7hd?=OݖƮ9d&_w؍K~<`+h|Lj߀[f0MЕ?i)Sk Y9蛇V5xKP`,Eyo5/=j?,kp p]12 dCl~5 cF%;V#ߎ#:{yex(;pn&G 4?ϵ**`>CM5b_guIDtO|ƾ!OΥyps{]wAбdnRE 2lJZ3o=Q]zd?K>*,5==(pgq_ГQ6G].\Wtg§zǼc2 # N/2`2yD!Pn$4r#X9[{J5 W9UYW׊U`yz + ~ 0ɹbv#UM~aQnX8yԣ(V[K3BnmF=tf]7$DӬQWTlM]hy7o x=%!tÒi̤2gg{ V]@lpˊ3vϳ:zU*:A@2 >" Rx"YX=9oLrz>7y Qeob;-r!#Q 0}xo $0dc }L ֞r` UCM/}@/RPYXg~q;woBEo,6 _Qba*}}C:L.[պ&xocidl?lC:xP,$RiJz/Kӗ9w "Z~\v$q`"mԷC#q`.)#|+Ŵ^is c/O:͙ '-N7`C5.@N'I"D"/頁nw$m̝$!+HJglJ>=/d(NMVAmVR9y֤ݺ(YF/*cyD'ҡ{Dh8 k! b0KiGHOsץ|k4!֢aWqsY[yɤM*EnBhIf'A=#I@dm4poGY4ԬsE=drḮ%CYNbh1]{ӵ3#L`wQC9+Co b 2V\Ǥe 8Dlm]z{` 8.EDq>eƝ|B)n~v=6v(O 8[neZ WT1)z霾RTwy3\{6H POtAAyWuMߡv%J0Z[[ fDg串,K!?{0dҷUζ!r)Fd'm.nD0셖 ]+H+Ww7W,K,d ἐgWf?@4zm˥|o3C>gJᗛ8#Y44ՌۄT*SyF tiNl%! [3>c!aE#pWx_zuܓ\0Pi¶ g2>CT#=jI33/NdI^Pt\ߞВ"Dph6UzW\?`5ĂXiE7Ǡj .qcPPsnj*g/gv?pPkUIzns!734 7pi"{ePO ʄ4[w!AW ae.N|0Jէ˯&<4ˍm.{b9Vc$> stream xUK6 WE)&*PEQ"fu4yޝK{),Sɏp, g}Zsyyk?SӖ,.Pq(Ot 9HEgiz\9ge<[Qh/k'yiKê‹BKnYj̇mFº$l99eG_)kP-$% DII(JkdB-F`mkûU Ðkk992ˑK;?@r~ VeH[ C҇5:EkYev=C3VrPJQ}~t5KMzZߪ\kCtgT%BK$Ye*ש ]BPޤ0N$yyZ Rr=g|f x3A1@55VԹ هݲ! Q ʉD,ؐ(/u QN܇iɍ#ᝓF'LBIǁԐk]LDT;c˾q5+%ǁe=Bc-ʻOL##գu5z+-ߥh@w2[4Rޗy!.Z υ{AJ w]OT ex?R'ЍDGٮGCWz`F+!3j73/ʢw>j::;Z6T^4mGa\Y%k4__= HaEQ9nڗMftr 5G9-Jasɟ@LpXZjzA"2Hx {,1b[Xp]@ DypsHQh_5& ~7QE*&QtMU{|G'K7Ԉosa}?uoR2wp̱C1N&;-?ߤʎ\KJ,Gf7Ylkdo<|}k%fw`0vȆ̯?7endstream endobj 681 0 obj << /Filter /FlateDecode /Length 3286 >> stream xZo. X}߮unQ̢(~DZd, IYUޝ,-Hݝ7˄|'={yx&gqu\N'j25Okd~{ϊOgVY*9q.tyÔ U[S O8Yn5K$j@2̘gu->BD~p ūt&|/+QVapz@m\ ;toY&ꒇ"qe$j8h6,icq<瀉29vZ{IQx;Gu5F~ ,jM NyE yЉ~|} cCxo2T8L%v9Kɰ߆q,hpA̷^) k/Ȱ1WA6Vp,Wtj``5Ӫ[AV0 , Y-cLDa*,kk];+b{9'DFLt``]H}LZ#d"fF8`%{׊2C`' &&N7޾+1,T+0 C.iS 0#u=۶ .DS ̳~ zIw$%EL]>CL|kȹ1^)C P>N=5ZM1X̃3iy@7Sdq* X樯Qpb ?WsFPahm!?BAP[N5; *w(>htd*׸/zJhx t2[nK1&a:6["I۳maeDt le|h[h"FMXIhX]xm؀}+=A 9/ArWDc52-4OzIQ}oz{vSn*[~ S G@0?eM qz:[,De: Op$@&Foop KmSZC} 6J+ tec5pn-Yo nr.iO@Uv䳫 2=6 6X4 r]b{u8Շtȩ/f6f]}xS _zO@<-lhΪ|u}Hpƿs:O/#uʪi;wuZV\}h/;&vp옻|Hxڴb.;u|sy\oDy Z:86i5<<ѓU>2pӱFg]\_ק_XϫS;\k}w6lO~ِeTfzִUS+@cZfYoGk5ZmWM0!?Vekϯ>p@zC d Ќ D7Dk=D:E,5p/*B2e=KhB;CJ`O+:$_ ô/v2T/+Ā7W4ڗ>AE"Am/" vxj.mf=*9&Lɦ#p"^&?MZ ^Sl: < //AmY( dG#mASΥ]1;7ك4v Jc o-FGbJVz5 A {jόF.ol.E,4L!ʓWO:(Ha+/gOF{_rbLZЦ-yސ1tt#ɱ /Y:8z~+0$]ioP[i2N l>oa~F{1j}i"  U& [w2zf_-ME~BF~%M8]}ب6 T]>vHd" ?9 `6mԵ݆j;49mRr|.K6Sw`?ie[1ΘQcBvAXsuӝ^@gt;?B2p-39 %G鹊 GOM:Ìl<Vb`ڲӐ'P: ( mLU"vm㈐->*`-> stream x][oq3cŇθ#aa##MVyђA~{/Ss#)mZ>=u{N꿧WG?Oo;OZ *tNif wGaքpwxv{{uuު! ]{yYyisdu~}􏯎:03D%*?Z:~,rZdR+:j^+*@YV2Uj?_ - "fPfj7(>E W@x1i"Q>!2cwvWooOݞ0rvXkcPvvǷ_OBH[ +lL yn]t(!C#jH_vik>(+XJg6gЂd*%iKqbP*:A t'bA,ҫ=Jja'x;(/)'a ` @̑*1\0TF ?f> ;E&=ry1IfqYŰZ7%\L5g-h& ePZNF9,|NQ\GqȢYz ֢لQl-Ny{ KmSӥZW>*c]YeZZ+ܜRjW_ft\$S/jWhck ^U\L].peإ_xcb0NnRKf1kf4v u\Wn)n~ū kuh6$~_\RT F~3l6Kmx휟\5p*oC+һɅsިz^;صu>`ηwA{yvzh/m>{Qxa)FP?H,m7)&/RL&M "M O&ŔAr3I1C_]+Ewn9~"XEFu:]=oʒ&@ő!KWwF 쳅v2:_qq|Px8-(R`X->'EOyoXurww>*oS ?RA;x魲avqzqs}|H>A_\ߟS26;5ӯP[=V`ǝݦNN[8ߔ9 'hg/0-u+m7DF?{wګ7riW:@Cc؆Wt޿<>>/o>\\ôX2fɲfR/P+IVנ`#. GPá72`*=\Ъ7cg~?8b˛?\Ix\5VŴ>{iՋ9`oa8_^^}1 /&PƝ 7W7 ^+{?\Ԭ/AHZ>`h׺@R{g_x0$ 9-{H)k>4^ j2rBzqzbi#MT. YKmչVDOKE(`-PXA'7߲6 XI/Hy3i)쯎-~v )#a2;:@3~Vclj9mbn~L{? 0& T?MV>l6q{A[{V~aYe8ycCJi4 E)ǛrAm}!i*׸dϼYyk6iwJ*{߳7gW0u(N{s#J&͛4PLs14JوW3=sј >FsMID\*>rr=W G@/"#f$6tۦS5iP x`rJ s8̈́0M3 0* й9xP:ێṮ4 MUo6Q@U*=GZϴY~abI9Azl4- io;V6KH͂ )ܗj趸.1͆=1S\+j6C333TefbΧtiiFu{dB)/h.:B vGbSoXuHvK7ɹ8XL08ibp5T-*׏|)dk03ew.AY[؈b5M*ĸKлbJdt,ƂZD-ޕ`L2GN5hH&`il:xS{ym(Թ ^{ܒy|{FP:eTs t4{]E*/`lJtE~*4(^HP}> 5+%Vғwk&vՂ/ F7 C5Ot;L`'n;g9_1m%űVR\?vrA}̈UЀWfS׬iOn[-LUEŦ;8D3=e| XN&N[@5h8 !+r..shVzV"pid҇r&RΉY'ӐTI|$y 8;x&X2Y\ds;UG`]F=^(5[s Ö$^My}R6.y|:lj/ k_Pк0maEpOq"GJP/Zjl/|5B|dm_gB ƍ%ь7$׼eq!z:op5s@ELm,Q$sTĻVQ3黟pcF\Zpa;UJYdVBYȈ$@ga gHtL}L4nhy;p*֛N0 78EYlW<A~Pϧi.ϧ<5c yrM#):ݘs26sh7KU@#J߂͆mҟ{xE)<k[]|}<4FבgcRۘ-nZs"5ajkOШ1GƒBB(X 2J*ʚl#*hRC5x/9,'ZFY%NE& S:C Y 9m<g7yIdqE8+)ԟN($HiK׊uQq17ѶGv=msDC"@pAXЧX!m)f4ny Rn1@ƖIó=p_zxfooR=Sd5?O1 (EC85!Ҿy*.! +tqC~+LQ. ?ɻ(NϷaÞn>u[:"tb9qNɆ2.sD%~N9^Qtj@twX ,céMiBχ? `H6(׳SB=l/ApD~`1j%o0{U_ZSxwd$DRBs˘qؖ^OZ+ 5=}G(/hHl =b4qeZrz>ߑ< ށ ȀbЗj ~je3Ōx!kf=X8ݾ0ٌ "li MdHˢ/)UТ!TqXܸλ5O|ij~[͂[JuA۽kõ!h{ ?qIfZq9_![d/+d)<8J|_U)ڬuR?k(뎵qSqdw0:Nubt$Fx/RM9IQZxvJ纈]9o8bbEcyRz,_c3uil΃5t6o!Cz)|'ׅodnzՁᗣBvA^ZI<383-!u #1q^1_/\7endstream endobj 683 0 obj << /Filter /FlateDecode /Length 5659 >> stream xڻd,bH(9!(ȏ{uRfOͫW|_{?v[]ݟ*ܯ=W^k:w#Uru?{3<7l4Ig>kOrh[f4oHzG$| {~Dh=gn^op'dF8xr9lrP;+|+r N l+Ƈ_\]27ʲOdt=Ú 3vWv<<ǻw2n]xQ9=ؔ=\FA%R߱84T1)\-0&VDooeQ#|LzK9Zck}I?-3A 27u$AniSMڷH8nh \PagFfIS |Q+)Jb>_Emqa0ǡܱ31GvTn R #\3~}k6SAKM5܀؇UVȸ?jMUdZtvEιjށ9,<**.ܻqo IJL/BC@ aACk"3 g (ǨRvkegFE)2&Ɉ۠@(yP@M%0Y;y{~6ryE?9iRXRλ%F![^{^O-N=b: ((.|/XY/陞X8}EIfl""#ЗSN?*vAHް8NeR`յs3znd GtvB%Uhr LS=dn5|1gK߶LC]ef0I ߅DvnqqA]LSQ0oRRבR4q.2\N6Qm>@*9YxȏQKŧvz?A?؎֧jC]0|ƨ y#oTg!4A\_ϰ)XL zSvا %*Q.^um U:ұY6t>FK\ɏrx>n`9:?g&NP"{ l69]xIIr'`?FTvCʒ 8MƍQrE8hV*ӞhYn.(s0fgw Zy@.Ŕ6b ,0zܑ 2zE;LƯkv %_{\rt+K?%w!U<焢EƋ,䜅qKUy\Zs<@4!DI\ԋH,Vy?"E>*4nQg)gqްk pSmn);%и]mf,J8 yAstpLq2#ٜ|MRoJ;T^UÅ#96f Ffx$:9]DL?Ue܍Fjnyc3BuuC}/)cZaeĀ% xN+3*6 N(UAe.bۥ[ U..~:e.>=nq*}SO77/.p=Ծ )C%c#?42WKՠS+7J)|?ISG: @ϒ:S_W,*zj&AفDJvб>zJ]vM`0f$$oZJT!? ~n?\Y+B))I۸v[hmKL+Lcu)P:sϻ~Kc+7'} =<{Nk+ߝ:n?_MvΉzɼ/k %bDžnD̶ |RL;~w鴡 BhIq'L͌e{C$}ܝRm[ ]H~F:$w8NJQM2cGvDHy|MSXiV阤uWq;Be8h,|I1SYC T VY~4E(<^Mcām:ȥ:pqu k<~t^.]r6ezz]m&JPFFńŬ=ԮYS}'C'ҙd>$ ^ oH[Nf+WQrvpʍ{FMŇNl;9tD٢S9wmjx(F9)8IuvSL -2 Đ͒xUR3ܬRvT4G LŰ#8!JDq3ϼӒr3?RJvk==RSdxBxA칔p2CGTi0߳WtKYKSZnM>MOD^p"C_h(Zf WC=,|Zx&W<;nqƄx6 ,W@X\(m`,L! ;]\:`#MO|D: ܷt՚^#eN%T PB ̷9A֤]hZ?sQ)W$^nΤzFg?n̨#pϸ#XN2dJn^aS_{ @l&4PY ( P 0PjJF'j2T|Fkh0,%2[_:B[b\.\CN qH> 40gG;,3e߀P t>=ޭwX)1ӵx4(0"\8=]ck>wG(\< F(T':و bmc42a ],2R/z;q|Aa/^a0êG`BOjΤOiʝGnCn@bnUG偉m ( T@K*2;*%=Wy Q( PEeX 0s/+P7( T@KJ2` w4oWw@w:X64ЗepFl,@yggǞ>O@$H!fE 11A Hs M@d1( T@APk Qx$(T@dO@-6Y4WŒN: (UBaBhPЧʩoVҏJK,-#꼤-z y$x4EqmN(*٪(eah 8IE`:hB0?vɅc-X) .DaY Ee @ph(bAH($3`ip@X`Y6JE-B@M;b%A"H".S4d31K&GkↃИQ}؝[tV)qG!re/\ 0gii8U*NɨiSB4 W7=ؠK15᰻]>vw~_Ԁ/Yj= /EQŶ聝;SV5VYR븺x7,eHS I*nqӸkb8?+,›[+;>v{}{M&8iN,j7T{2w4X2 &@qUieˀ'<!|)xL{g@bъM{nM4]p"IH5&MۗghU.ր,XS"[?%l@*D'WNZ2W6 nYkL0D1oo4 n63E6 $k9\\F"p" I?8qq2^x_׷=>8Ī, H͡' c`/:Cd{qx+l "Cnowo⯥YWZ3CP'I8_uOendstream endobj 684 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2263 >> stream x pSUo&xo\yZu²Z(-m4i4MG%i4mҤII -P^@)b >vA\ftVYgv=:7ά;ǜ=~/JOx<ܼqǎ'W&%%|7iŇY3~Dz{q}Ǔ2VQZ\-*Z,zr疉ZbhT(-*m.PJ\-+*+E/(UOO#ԃCptƁGmH Ck PrJG??zJ_.V9?e}#8΢wGic #Z*}1,ڨśO{(Y z+*29vtύ/dy'^ b&2z8N ?Cx+HTH'nǚHΥF26XϨbҾ]H:ADDY>up[!v7*@"Ců c0 \N257q#}mDI[NX80aZL1f7[A"j`{c/Z l8Cfz6%?G9kX܃ȂʖX5SS T[)tV v BRSu~i~$S2KO`:UiDmo ۮ  ga.{@5s<.<*JUOa/葿*XK2w5l]&wq\M~GGU : S`E>mWk2.w}3_bSz9zK t{G2?ASoj趎$0g7|l,r ":$o=dzxnnԪ$#\Zc5<.^ Z<45u6luF#.,,`a͉PRxlYn!Ƶ \}8_kiw(2 {TId[䁽k4#~7=n6Np[ǺGjj7ϾES{ţO\ M4Kw[}~f /!;5k[D㝖19͚͚EQUcendstream endobj 685 0 obj << /Filter /FlateDecode /Length 161 >> stream x]O10 Բ 0Um?eB:gm_Xց$i, x> stream xcd`ab`dddw 441U~H3a!Gk7s7['~.Ș__PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*@ܦs JKR|SR1ŢUS{蜹WvWVU]^>{<ߏ x8}ߌ)f01RR|d˓G_[zfr\,bi> stream x[Yo#~#y#@^r#dW@~gØtf|!\ەfΏ{ݟA N{nsxR[&ƹ^q;++2iƇە%g1.92WR(bLh;n?i6,ۑ 3)l;->ysݔUwF:dKi&e`%lݿ?~E Ykİv)D֘UIq,xN /9~A%$wW#g L(\4Kq=l+ Vis>} 1O4 8|*βm\h/mUheX ?ժ߶Pw|&ą2!T)&'*)9g$ݍ<aã0&pBW6ޅ}  ~>@Ҥ 6*54|o<3!/ "*Ax8s9OA8'4wYGA+ ?_-|\haKyWEK/RBJc}WBǥDM}X2NBj$؇G-5v7Rc!ρdwtN  H0 7\Z6 =H@IzRI@ v74e@JDƨIB(~B$8`&*H+7IG%rJL<@$A4(Q&Bt %sc)s&.`kBb˘! a$(#e ?4_SmrWp`xj_Gz2/y|857yn𺒠n4a@,ߗGHanRL.¨@TKea<3\fT?^EFcTd" *PhڔJHCe|OF(URQ~?Vh29ɡ 9ǢtA(8PJ98 ûߖ )U(i4ܵ 2}rf û D 4-ʢ'*'C8*5YI`9*G2BwF %RR8DVj$2"`H$8@kB,J".({,p{yp H@PG*Aqy@^(E{&G«potÝ[h ]kĕ.D.WJ;>N 7=se hUON*LY&xuSB.@Yaoˬ7m_ݬIY7 V2&&ڗ ])YQ7Il =Z `[o5Rcu@:)Ƈ¿BWX3 (֒FJ?+Z>U8b_>Xhž? jv:%"|)dE}>كm=zpn1> 3{#"}-Whl 茯f5w)D io33+U)M_RRR)Wfeza coDj̤M,/f5@nֽ c&12早"ZO^ ҫFAo(唎QMcmIjۮr.C!߀tmtFw~p=2kۥ*y FйK`&L:?h?+i4xjjRG pV@6#O$s%}'֑ O{2y5̡6O(Y?E PltVj8i`lw)&c4XoUzMLIY!z!ȉD:7E"m 0,BT1|H5pwfQ ^q|r_Q-{T 'E\jZ ![mk]֫3y2mRC uc!SK5o\.I u&k]^՚03C$;gjw1O4{$ȰnAtXPljfSe\p4Y3t ./RC 05kJH[1NkԵ.GbVSwV>CuGXƩ}dp^ {f0I)SފVP,67Ui4lS]sNŬmK  L比@*\|,S@wyH2n$'܍n`ƻlemjߦDX;ޞJQ)K.:YՇӹag36FP:cg] {eqGU?\NCy R(КF$% cH(Wۀ7T7T-SMm3AUhfInL1wi(Lh-SګgIE;vŋL^sH~uݩ @jp1۠d憻a2m€m9 X(q׶jL=d/Sؓ $1t7PB]-Nu:ln*%>&`J%z&1R#)%oNv?vp-© )[mNbrICT[#rV k/F'/M1N{'iЄ777^>s~Bc Njŵ4 _l5l48Yf,0\WH# mo^hOH#oyӈoat_47ð=o%^r<C|(*ݺ(tR]Xr^aKTR\[m}n)|e7]b_̦z}XW+…cԗf 2\` ̚^x9?! 7k8nqFth\ۃ%Ld)^6ʔH_ؑH /A֧;j ~{mߞ1;`BRP$7%{@.}~{[VޮrutYS|(!Wq.Z,WreOy4pL|3n.]mkt ϻ\xǞ/LYbMxلRH!7iiNBQ9BcUb[@BC@y/s_",(XHqI4.'K]HA#H4?oK2:ҺggCmv" /FD9 BqOSK3l 1М]z:SXr.DPſ;âQQ:%%Pg d8#_BK926?k,Lfi*V!>3<66\S&k#՘ _31GYfenAD{Ƚgr9 HL$zuqN%(/VeaLA"(^ѹ΅!.ᐈkX@*SjՐhԮQ` ˹y%XCߙ]HIj8s t8]Rus!Q}֬;5ܒQ>$Z4?umbɷk6N¯N?!*X-ԅh<]("Q ium3/[Ϛ;O5^|b&9&CGj-arUnT$R{ͺ#[jo-%G0;p 1ME0PU7}p-߯&C\j)z# XPu~ oYv\X%D q8<œ3tr尖WCV0 RQo"J yGv=z\I@4ӖZ)N_V%]:ɇ˽ ^rLVJDG啳Is?ˆ|rh9x~Ft \=9$zq,Rilux2_6ݹB'N ⩹bXuUV9@`@hP\jx8pŋ>E4 -‚ Jip{ ҥ^M>4x}awVTYHjMtendstream endobj 688 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 400 /Subtype /Image /Width 500 /Length 29046 >> 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( 5k}3 c&*p3VR⺺2K֬J4mG̍EeXG q\Jn=J-tm5g ~@LpORAMh]Z\#ɰQ[zlWPE<~Ld8=Ƭ`h d %l n#@ã02HUpKt>ZZ1`qxGҵ g֫me?*V6Sm-%B(98'L0ΝeJۦ#^ߕHfe]q$!R@ Gs'^:*m 4iz$q.j?{v*eдv`ATq!8ҥx9RZ7DKZ2# l˸QՅD _6lA IjjXSkKw+*ȬAƲo **- OD\$i l=: ֦w@OGU'V*(cEy'īKMvCjBg{QV>)o^tQE~a2B8?+^|;hI&f( IZ( t?+.F7OJs']rqQؕtw<#Kdی|©$Σ#}^zSCkTHr'o<'ۭ>jύ7^`ܫGP= ]=~ekk% ,I䁞jj{[{y} c k.Yx_S"[(k % \y ;Lq@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@S7 md8*ŀǿJX ս-A0 <޽=)0E'O$D! 4͍iqmR2swzQ1A"@W`J56Ộm֒"}rZ..욕R^bY  N>VPicm]'81 Z  }JT:ۘ$ <}(طe~Y [swr7}^+\]^awoxY`#xw;ԍYFvIcS*`gO ȥHZQ!M=ZȭXP Pxb / nXEk?6?u;HzcVDݝk7yO  ʺCPkC{X'deyOa/F쟛SF{ !y#vp 1crz\hQEaEފ>)o^tQEQEQEeæ uYw0jPOgY->1asYڌ>m:Fץm ciQL.k;Ȟ?a̵[wFq䖒]v1blV< HLJVx&[Mb592Vo|RW1)Y5ٯ//E>p|r]|{<<x\ұl1 ooJifc8ithDACpv;~Ʌ-75V9 0W;cuztKKUIhgsCI]!Ի(`Yq>-zne YK)t3¤ƒ~/>RZƒ{_-oOĮ?Ƶki0 0K".*{€$)8u%QEQEQEQEQEQEQEQEQEQEQEQEQEQEW12mيg€,QYVPG?cq5QK1 dp+Oo<7gui=O6cr^`9=3Mݖ~Sh簢_jVp#Ё@W/&KY >m0sO{(Ls@^W y#\'q֥`FP )2@z嵬0- e=:6W䲺M/ #va?^EsHJ1E 8;溣INqn.3䨤h k,M[qY,z L_}AZqa׃^߇` Jp3ѧq_]hGmq ="~?$y9;>{+3tIG>Gjj1$lIpC45 cg론L?t j$r=ѱ끑zz֤*<=jÕyh aq^q\Jr*# V6lr}AH, c?ƿ<y5u J8;UOȲ,QP Ċޘ?Jv;q{<دSՕi_'k i>h &(QEQEQEQEQEQEQEQEQEQEQEQEQEQEQE2Fڥ:{S摛G>Mʄ\Jtk@lg|d ?[BN~%25؊LLϊ0עoEaEފzQ@fk'VT&>`Ye/#3Ne1D6ܙ5z(.F 7J˼M8R*j |NIv"fb|y>Кr9{$JttMtШ(^F:mi\((6ll>t+HlqX2P!pn 8ncuD 't?JҽJ TUrS0tƖuj '=?Q,{IuL}\R;VmiKMԣ!/^? U=Eezj_yתC?)4HHl5̋A'm>Y|quh:w_fĎd|^M"=d T<6G?m7=N((( t?+.F7OJz7cn}+>h$x >{Pɶ r@T ;p[C0Ed8(xhPkqw+-g&r_Fr-$bH&3FdnQk66ޛ5%Q\OoFp-F&( Jq܇Ry$:,=r1GUJH$9gzTV7 _ 8j ۃB3TԴ.b# FpUxo-H;y]o3A噬5j1qf_SUM[M]B'so8gh 5 #mAC#OB+8;I'ΊSMivӳ4ܞ9}T͵f$ːa\c=*0\:)c1lcWTՎeizB0>#=qQUVl#  %-.QKP&=&%\laEH]cmzZð =J7Gq&gOG_Ϋ#b=EN+t>L3F4ZiAG>eҀ>d}ThG24R9i}ŏfOC5-Ww8?)Ry:>ROrJ*?:?N096c(((((((((*7}ǢnpR)~wg{ҹV9s)S3A436p,;(>#;PXfX8Td?dX?*f9g=\{AۀMLDXj>Vyg?m70עoE=N(+Fu-٣f3>HQ\dž5FHg 34,''##]=eæ uYw0jP{-9?)@;el97PO知l3#=+>X }u´jF3(젴'@LI؍POC~FP3{R${J"ǃ,f)A$r  1xg]FExk+SQu^uCBTȲh:4)w&T)lG 1Q[E*Pƹ$j@g?SԴ߶-d60oo=.G*Ar} r7ў R} 6?Σ57kc!}z IuGJcIZۮkMMgIxޥGw^!P7m;SJq@U9h; Îv?> ]OONW~m呑V!-#aϨ{\@z>y'YW=$K!׆+)v tdg{߂?0GW\~#m>(#ҋų1PORv ߷[#T0ĸ#12rs(wSa.H0m'?QÑC} 3#/@ԃA<8f:SiH`buY~Ty j݉hAEPEPEF`PYj?{@IEGT| QQ~~BAǞsR Po_ZsgvO 8$P=d/6[A僅LrB PR$ w'.Fl)v }}OiC !{ҐJvD '>4TQ# ;'95-2aEފ>)o^tVuγai|lD%k =pG?QWb'dHeYNA`!q,@Ն+Jj:eeM7ILR-7STk{{`v <wnna1W=:IeG2yerA8Wlͧl3wsq ` ެt?( LD)+G8.4Qܧa*"3«G!eh<(rzή=彄u1J0c+}ܞ 2e8`1ʐv?2{~GR9L%]z?LNS6+ās6?,5SZm*{yAd{fW ^ƣ%Vl+*sw!')E٢YF)4H`[;,c?[1 pW8Ұ|C*[`{b gtC! dll,tS9a+0qcR^=gz=^ddqb*R7;O׿֙!,Io\t#~$JGθ?58s{WFTy9֫ڤI A&9 =Ֆm=~@ r=;N:Y0.h=eZ7UYN'l?G=kh‡R8Eu$̭xM̺$dcG_N]3WMiu]ןucyR##OW@ܮUF>ݜnʸ}{06 [hp޳,n|VEqЎs|捂dw֖';xeiX22ЊB2Gq!g\o P#kdSq /ݚOnf׹ ;#>V\O$0̲d$89ZTйF)O$`X0H?CP(`#zwaxt9d4U%#K'Cx"Eܤt=N1 xbPQ  6ޠ=5%~hGЃ']z{QR+PA4]Fye9K*J( #տ4n@>Oy'qgA~Gi69៏F)w?hUP 0)ͮz g? ajK3LiYXu'9b}'L # >٧}P=ԀHܓzM(,9/hE(Iޔ/`K@_#r>gvcS!T4)/elʈ*AT[=;Sup=M9\4ǁ@]_B $- 1tpKxn pQG327qVh>`*cَH?Ξ zg6#P;sKl`sp݀}^b,pF*5aEފ>)o^:o*KėhmI-lBl9nxnh"t[ xB8;Y[jTɑI!pg}Mtz`#N|0i:⎀-EQEy#\'q֥eæ u@J }z"(^!(I?5j8@~n3Lu[{C*g%rЖqsO9*@[kt'(_#$>jVu eXcraGZP7<{};fq l^dcT ̭h!z~AdrH88?5=ux&v M|+y4=Qyo_`qV>x>uL yz>U[h5-6oXBFH ]jr6^VORB+W߮MGr`br{;=EXcr10 ztˁӐq֧^GA!̀nyVzjٽy e!TyCln#x"lu&Iԇ%Udt=ۏPMO\D$p >+ہ9Y5 HƵ%i;`a?OA"79ޠJhVhFE"0W!ޱ3/qdn{R$?O:K鮏M NWjTa.7-y9T4~\dRySb$loZ=68іHݎS8;QJ# 6;LK@Ju8NDV!fg}2,ҳ%WY BO_Z2?#9p[VV8$tN %yzj |hUd,8Io ip lNF0@Ɯ'g.2OY~#iPsץU+8$qZjSh8 0i<\R,al{g4j/w)?g% (<ޕʴx OC&߼nAه"[MY2+{`H&_-E) >bN4 釛~ciI! Plq⦪`xrrI'5H[YOF_ 6Lu-=F^x.nQ2 z|3g.>M FEf/je;OCo /;e1O9pkwO60OE?o6!#?ܵEJRxRuX =f>I'ށh3[YG,d$/(iP]:opZy#\'q֥E2Ln_GhG׸Wv>LgޫLuv3wP=9ۭTYC#&-0}}yb IV~n9jw!eNH݁#@hWBag?Z+ Rv2cYT:pW99RH*u\R\&ʤ=a(-E$8B2{z\H8l+&,!$dnJKv1? SNRZ9[$jt8kWLp'SO#(w 6>~kӑtvM)LeL>k?:NΣlJ uE+6B=as5@ߣ` u*$( C\}KMB$;pp:FNUJZF?2esbqk'rxnivpOO#.@#7銈Zgrn#Znr{Zg%=Y? oaeB0r9>0N@GA޲b{Y)jZqmmFp]Kﹻ#+FgN8?{lo1y/VME^ $az7ȡ#ޚieR+IkZL10E:?1ԯwn?iĨHARȭ#ߏ֨ i*bHCgnU?zfgiS7[jހIt%H2/P?]8k1|\|08l*%DNzqJw9~rN=Ʀ[uSIcb0yH`10|>^~HGsjxXb*&7b)N=xsqg:؇ v]ʇ8 @v2;+C/RS2 ;8݆i\%:.8HF$?Z$aP~V0~@OJ;p)Z`cJ<"` Upr@F=~U+̅P: ؕZM;mPGHiOn0.I䓞}z$HTJyg?m70עoE:_ݠPqu%q,,!u' [ \ɣX-BGF p~Jm&]lgKf`v†b>g!t>)+-H*(V@z`qBOsR|Kډ~+ *x VbL\Zgј7h^N9 1s9eo[^ ƀ?I>.Ko%?wPO@kD) ߱,$*OnÁ3\xβlѝkַk.F7OJT. U*53 {t>R%\w 4k3 [ln~?֒Uics~"\nE`QzU"-aj?Sɢ8d#H9uzHP>\}'g5JWDِE TDG\ qcsș#y zd$ж6G߅]Wexd@lZΞӻVITsç>XKA < 1RS=G!)EGF5KN c q:}>{ⵕʯg\ݫ;_ўad0vYs'^ӴMV-f `Unr>~]EmR1}WgOmmR|w; aJ\1T$qjFR>RO 62?>+.Z!ARp@<-2 zGNW]lÌR4480 _~)`c<=G=HG`8C+;5̤32=@FGW}G kzaؿtN)6a>S2Fv?uxգ;Wz˹XzfևL+.NIGT>9"8YY[MJWu,< Ն\Ns f'2ZIO\UMz+~wYQ"qd IK*TneU]zHĮA# KFmqdcБn07nJ'+ʐqTsצ2=zcm?4ݰ +c;tXs/V ME$!u=LGPݿZ!`A2vqi;W?ʚ<&^yQ;OZ9?ӏP/M}2}i]v@:00Xw䎋p#+[ w7ģ%eN1<#r_ҥ\"}Ԃ( 8$k2A&8*u YW@CvDoQ`qp֣MF=NԒBŽP;_qJL'}ӽ? 7 x;0cvz.%rLB'wc5f`' E6p\ʓ$B:OJW/MI `D&2'AQ-#rKΘ p~cs@DI1wmʞD['WWt`2H}:ƩY-"E;P}jv[G)ǚZGO/{J+xLr%KߟkCS]3}7rAS<0~JkX2຅|w8oti| kE赿.MW/+呲Sت֊V2 VkX֜QNϊ0עoEaEފ#c/|m%c4!Ev)da3޺}"x& 4qyJWOڹK",$ybT2;0mdl +k/o/Rn+ǯ~%=Z( (2?a:Ԭt?((YJ:sP *8 6DB$ "pXOҧ.FO?D9c(jhrS}ǿOqlAyrʍ3eIe#ʢU]wFs>u2y*sުH̎E ~qC0S;GP&TD݆ޠ~௙] G"Ҳ S#UPKCƱ.ii QpTC7;GC${6ߝ S~ңUIː7޴U|y]hfi:ը1), nOZ.谠ے?`m7i>[Fq~5[mSL݉Rćq+Zս?O>1+3J9Y$Lt$`?fJ̼^{`T}ْ52 Ϧ9MBp|O|2UG;}gǟ]  c3Y5fuFi,o?Ͽ(l.XpSG8.;q?)#@X~9Tm5:PO26:T :QCt,sNqX qR2ݽW'vMCsx7MoC faaYǖ*U/\&fQ!$.S g!]U4-Q Vq~?>QgSzUb&2˵Ѓ0(9!Ab%ǍzG-ǵJ#NME,qG:OZ~s79##ێ#LT뵆 lݩ{gN+Oh$ʮ3סh<хVm<#Rt/R?R #ys6:eiܗ"FAB0WNWQ8/gw*cr ܤQp.[Us젂~:r p!ݰm Ƌ%'+!i8!q2ZuLs'E卡"CihWHV^lc֐Й#7RU'U{kRE@Og'&v*1mkRyH=BgG.CHî6Y3xHKv;x6Ƕu\L!:x7Xj۸lEl:13uM*-KO$@G?G$^YK\sq&T~ 0'W1eXl_rHm5{ 4vZQQ $"u'NO?J\z_q_Ol4enR0Hs'{g'@OrIץpUxG,H$p6`i$y9MIݎg T c$z~4Fѫt?FYd2ޜ:.91J RnqUj!ܛ2xثh,# z/QOF_ Izּёa@* B u+*Y“Qʨ$9ا#` +{Wf db$ǘ+,ìj܁ (˼M8R?a:Ԡ(G4P<=Q*Q&B;Vj)ʌD(Z&˝s]a~hyS).nU zcM=nKZXٜ"2gX6@p'#Jx^LJlL-h6Hܹ=Gn1b2:r }OZ\hC$ ߞ3(nH^Sbi<áS Rp)=W5$&krl=.}O#B[eFc9ZڕWMt]}mY=" ta>?pyO:^;W72?|p-fu'DUQѲUUiGXUZ0,A|zy>㯥.DlKc eA*olsyQYF|˕\-mZQyij.A@ eaJcN[k)Z&V?tOaY8cxJ>Y*A\d *N8B%p;(7$`cp@}*7zw c<0''jz(5n)'#}E,GnKA!"`g!rS6O,x)"nf7#M1HH ise7)/-5{)/+Wn6#?.x;S,{2}=&V濮̏,W)CIr </5$qd{x._65]kf0o`'5?yRBIg} YI'G3;inq]Ԥ7aiDMsx[M"Ff'㷔A#HN orI{OPKjs](\NO#m qcL쫟iwJ |LoI7ˎiN6s͙S<<_JE!ZAf,[S_6h$oٴGO޳9 T]yK y*0V-Ƒb=bWc<' ^7du6nq՛ip Ff?Ehr: ӚO.F8!pN>rG!r[m׮)dmry'jvձRQ@)1"XmƜbe2aGSWI`;:aFAƬz g*q`9 "pzjnd'&NGNT|%݃4"4SM&~\cwK諎=@2Ƀqieb ( 1c~HrwLoF<.6p2?ZUԪ6z=Y[aEފ>)o^=N(u>PO3vO[@>מX(4jc[٢2,8@N=H 7gQ2-nV]0g+x̞D`kޥ-qH#Hn9~9bId2)2d-!F~XA > Ӽ0Oy)QEQEQE _+4~+?|ԌA G( $P;2OK!F@0GTe cBB8<`TFz,8ojȜJ4NG`F?:O'1B1"qzPj[JLr=Gldg;r5;tc l;*=F?E&F T % 9S$wKϖNGCj BD<Ur`۱d W>p sdet*p>ea}!hMQ]z~5:M^/u5Ƞ4attu ʿS@BBEҹqG-ƎX>+k5Y!ϯ2F(GӋ__UӶĎY0r=LbeQ4y+F?LU_,JN}w q???8ۖLoQv#Rˣmy?XMv@T̬ʸ=%AE26hـՓ#WN=8$}ώ;JJkPܧXe%HE Uʯss)Lu-4kEh2s4r @`ŸU59ʑ0*?~**7l.a?*o&%iT|bտQSw y"-\syxH 1@~#rK@m-VE;Œ/#y@r}$a`ty4**cWAQd:Fe'Aap;>ΓU":~HLDbyZB,t P;!~ 55$P?7:'N ;W>p(Џ濶@³?#“&sPf`e5`cn{ϥ<9 hz " G58lVOͰ;sUl ǷN rwXOZQ!v(=ާ (\p8Jcabyb7f?)*cR b`}(\L[1P&M?&_?jgX0()؇6~8i j}Qϊ0עoEaEފzQ@Q@Q@w0jV]:opZQEQEQET.Xc^שM\7Y+稨QݑJZV;Vf6ᒤ0e}?ȪB{ q\pϯNjqbJȭӍǏ^9H*FG^*40L2㚤CI4Dd\821Y#+>VE+ܜѕM'G~V#`ЖTGp@dc~_ʣA13s? )pJp}qЌTdW'oA{V3hFrA|E9V\>ϦxqC#azk}߼Y73rhѻw.:{lOg}렯fU[-V-(q">Cގ{WN]ۇr6;gsƊދ~"0qϾ{6ȓ-g{2`{sW:ߣUkkβ,EdjcrWPMʧ@#&7Q.N3^e&CɎx=rwr d |6elUpV@JTCB=)4RE>=Jt=^RE{vO7OӜjhV¶FU?CYhkgEb%Ed)*2?; I3MVouyW1PQ 2c+c8]㧘~C>*gU)2?ew>@?$''M( OȥbR?*B~_)? qN4̼򧪠?H=Rcr5L!tf zs˟pi8s;#Rr3uJ>o%큩hQ?Ri9hWvMQXUL wW vMKc?&vpO^˚7ASB({Qb}(l aҜZvk'*/iReEB3?ʞ!lTQas#jJ`0wjz(/LWc*90H>}f ܮGI dim$r$ lhϙXy =3G|8[=5}Qn%/g| ѱWWm+huV~|dEHdwH9>ǯqu]_@|6sixkzRM]دb{2GЁX΄mmzُrp1 '`U$3ǨǥD0 'C{RCo`+rz26AԂd_ˎV AcSdݐqV8_"8!1VD}idU ]5<74SUUGes񧨃P44T&+cGOҗWOE%-!Q@Q@Q@Q@Q@Q@Q@Q@Q@YOF_ 6@EPY:=ͥ\] VI O  ֬n$o{pd-0zq@i Q p)oK6/c9mw 34W*럼$V!tckHJ̐ˑxd:y#\'q֥`".'۲/oPEPEPEPEPEPEPLuH4(bbQ@*XUBuM 2R>eB2ga>ң|ɕb1*) Is"+(5bd3%UٞxEW/"cVZ)R:ñtS=RhpCl̝Moa_\jN8e?JqV@-qχm%7ɥ_ۮz/z*=OM]\nH5:oًolTtӷ5ei\q s'@#n![HX׾n7`}p8qַS\ smewɸ #gƹTHc-ot#e9? 7?{s&UR ~TVHK"~ 2? g}kx6X0ܧRGSbŜ~iBIʺD͌c4% @?T b W'w% )q1RkaJyo,@ 8u.NO#n=p =8*'Rixr={tY3?N/(lZj1x =@ҵ{сCҥxP|\}i(AgrG֧"YaF=g`r'{d*lXe~ο'"Qa߹b\#֧+};fL(0((((>)o^|SCz(袊+?Tm5eXI1M9# ; Т34NIK#Os)=Np1ZtQ@w0jV]:opZQEQEQEQEQEQEQEQETf4cE'Ԋ6X)\mi#!E;g(O1zx?SClh?uu[(?QLkxXaEW2'l9G?c ̀a8EiH~V~YMqf0jR7У'.[qRW=WcR?ϽC-AKc?J$CE\ .'4挰(dn63+)S܃ lQ5j:].2Ȓ1?Jݙƛ^ۯhG8]z[iHncr1CdcҺ*V+3x9NQ70y-մF7+wRVЮ#9HW(/u̵{|NJQ?p]|ҤpWvՅ> f i۬ޞmrß_?΋PVRt7L>E?8 <o4:-հo{iD'h4R4MR .tVFd HŔ ObV arL:#~p\vh,JUk6;A.h QrYʟȚƷմٹli=*PC+Ti{>f=?y"HL2(2@$(G% oʼ4Du"AE=01Y,9>d?\.6 8~"|nʟBA²qdQ>sAnxFsYk.L%J^)0|*GCU$$dFGohX&?ϟ¥X)$X>I".yy?4yy??ƫAJқy•Wep<Ȥ6uOP[YOF_ 6@S(((.F7OJ˼M8R ( ( ( ( ( ( ( ( ( ( ( ( JZ(@ݣQh>_\ʊ l3`I~*)r#5[>'zuIB?3HpYCh?5 |Mğ n=QOHDÔT"T$PѲ5PRFm6 N*TK#%IS,CIv@xĊδM*;m>q4HO͠i3qT8; 準nȿaj6tϰ?*v/!m{Wvm*wfMf95ЛYT~-BO?U ?{O}1};NCp5nAn_Sp1Oۧ#[`ckќ}WatIemuxؼn`gg>Ŀh !r'[vېGML-$^/OI ks2cvGd$??ތ(9mBw%$eW}#L|,z?:\nj apqN18oh-o8#9.n??6 Ճ]*=* {C͸ޯ>JmE}e?YOF_ 6YzQ@Su;=.O}pX*{9'U4Ǽx.yk˘B7S: bV @pU=2gWJ=Yn^ؓ &Kgc׻2,AdX2RM8RVAal }0Ʒ(((((((((((((((((((( 4PvAL0DO1!?bȦ59n**T60ZCB{E\4=_ٰL:d}hQG<DZѿ*G֍={lʹlKgj*[)$aEފ>)o^zQ@aIRT;vrwdnT8#r[-Fkge$"?1dr ;Q`w9't4Q@w0jU<^Ms=ІUxv0#ڳk14c$]?@(~˹֡|˹֡|N˹֡|˹֡|N˹֡|˹֡|N-lHqgrU?э\˹֡|N˹֡|˹֡|N˹֡|˹֡|N˹֡|˹֡|NRmfd _ YU컟 jn4컟 jn컟 jn4컟 jn컟 jn4컟 jnjַZUZE g@VX.HkP?/]7@tVg]7G]7@tVg]7G]7@tVg]7U$MZk7\N3hޢ?50?50Ӣ?50?50Ӣ?50?50Ӣ?50񺧥^[/2̌HEs tK{cotUgd0,EQETSA2U(z0#~U-dP6 bxiق@1?zp)kѵ^[kuc'{)"2 H͆!@$m{ ( ( \$pGT~TۦmkdY' |v v+ΫIdc4vݤn"SE)n3uTVn}5O,d5@Q@Q@E[HP"g yĒޡei%;Ir8T O~NpjuEٌJK"eS |ʹpyjC((()TL]]AԵ]چq{J4q*wę 7n9+KI{@$$QY pAVEPEPEGV+6ɡGSXM$\>#P)e+aՈ TO=H}q*RCq,VRܪpVRnb , %IXdGPсGMEPEPEPEP{X&]Ά7\ I<򛛋b0I'iQ@Q@Q@Q@/\]ZCwz`Ux#8!@DGE`ʦ ( ( k =iP{K[x5<ȝC*ĩ`V1$Q(HP` ((*ŌwNԹ@ܸ9*eitqs` o>18 ֢(({nn&[ 7`:7OrdNT3;xc jtpKEQEQEQEQEQEQEQEQEQEQEQEQEQEQEV4QI"Ĥf8U-XZh~h^'i5ޥJi3*ܨ VkO֮OLNXX)FZ$`{nTiMY E c2'e$ w 3l'\EuI@섎̬UACq2D[`U}$ :H$i#ϮO]Yƺ\3LM ~%.1?.&s2^&s=HHLsZix-lv)WRl0Fʄ #9%=sŃH:|myHeŽ9|g#ӊj b'pS'՘( W#m6ֲble BOֳ->y9tPhnYC BEB~x0ybI_kJHN8Ӏzizjz6awlPi@0f QxᶿIiS2#[O w.k'4dھpRW?Մ4kk[Ʋː~UbB|@՛{c!p8}1ڸ5]qz%յ{ I p6I괝VXm|FQlQE (((((((((((((((((((((((((((i4آH"HE8*"((VI(i P ΞȎT9RG8GOO dhUFI䜓(((((((((((endstream endobj 689 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 358 >> stream xcd`ab`dddwu041U~H3a!Wu7k7s7˲g ~*Ș_29(3=DA#YS\GR17(391O7$#57QOL-Tа())///K-/JQ(,PJ-N-*KMQp+QKMU8NB9)槤悌M(a``` ``b`bddkCd73J?͍] S{/k[Y^u[on?lp4_u?$~(}g^r?6u/tug]9}.n9.|͓xx%endstream endobj 690 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 393 >> stream x~CMMI7$+  ZWTnsCopyright (c) 1997, 2009 American Mathematical Society (), with Reserved Font Name CMMI7.CMMI7Computer ModerniJ(Ҫopnqnzv`~z\e~}t;_bdw揗cT(]z~ᷯpt|rMwCp`  7 [ɖendstream endobj 691 0 obj << /Filter /FlateDecode /Length 4596 >> stream x\Yo~'#~}ȃr8vExH"%i.)Q>U=3pI)g{:W ==M[=㈇_W/0ZOIWV*:\olq6[>lw~']^q7zZ337}sa{-gqfØtf_Ap#_->;4<~ {g5 !Dx|Nx`6}gU"IRvi%lpv4ߏkH|<ߐfdJAY/rΗ RR M><7yL\#aS<^~ $]y<)O}J3 <1eڷArr5(=;ן4㠣ÿeON+]&7i KJ3^ ¼.D+FiE:j(cSx8 '$e.cHfʚlIrtz}ue OЉ >퟈NmG*r~d"nm`3bպ܂B*q`1iu78eY45)WBlH *_k{h L .^Ev_dQI=z7D/} auCxQ2-*Y:/%zWV;;_HR-*r_DC@!ZHrQ}&U+XDheM'2 45ywU6H'V * TĨL#@`;&.U:ɮ8v> gAiLܔ"!x]~*u ,Z@wHh'\pq*5>@ p~Ǎ}@sd\AB Lۨd?V؁4hf ; bjܨ.9J,M1QavwSb# [䖗 _Bg= 3$5ݑ``S|_Py 9"ûz,I#+b*X^~w|!}]j.la6튋+1}CFJ K2(c{\nENc+.upjaj#oSlIl ?ns6ØoL76CPǰBqnMiPx%{.aGX 6t PA֥j+B}C"Ӱ9iO8b%4ɞ<f,^R`1<$@,c׿w)w[ g+|O;٬ak_c)jK͌cWhb))-s-NE1i!V#{U/Bt_VedW:Op3EY`W$B"SrVmI j%Nh[fsti`e 3Ll/80"mY3\;6>FYL2RO6s(+RM \,z(ʳH_P\**dH&Cv٥,rO3Mhd[DF;[D^7EжGBUJJsh<( Dcuӎ13IHhjmNR&C)+IY&j2&gF7O eB0όPLu%m ^Lq#^#T|L{PڧO)fcRgEC"$ДdRd@=@e~6U{b6cUg ZSˑ^̵W]!l旧9Dfjt^ng=^/+erq{}M?+bvX-ctv&hPe[P>Ձy$^ 4YY0ÚűZ-*pkZM2fsڱy=7M̕s]ՒBky^IE^ ۑð`jThlNWZHvVtY*]0[oU3h) 2A)[mN`x$'K=fJ;T/*"CoՇbzJtB"nuj CkktvRa|&~Lv?9]V3"`  C(0)@Sꞇ侔z02 R-D#k_{[w:O_86{j]5a>[X*QR%V[N g5x) [`PQ{p C * )L3'/Ekn7zq0l3k a|[cGiXڍNSkz=ۚ/q+ gL̯}?( ug^CҊuyfIц\\SDdPyH|o!Ll#㇃Su)vMvHf)4c6_ +.J=]B*LrKNE CC;A87 ũ#ǿQzT7jzM з҂2a|['Ў[L> stream x[Yo~XŻw  vlɃE}g%%90 Q]WU7b'ކͫyuL_7O0ٍlN_T v:ʍrr1lNO~^Je'+'ݾŤb:n೉1ĸfϗ Savem~0~L=ON%=_. ܾ^< 0W~A<4saXSN*;Io d}G A5H WH߈ +g"D4+N\5;܀g;8b5 e񆽿fsdT$\`U_/:tMn_q68bA;@v/H8;vi] dMpZ2 RJ^.'+szvZ(pO/LY?eAt&aٞ\k`ܰA͸'hXO"Fgm,7Jj Zyk%6hgDZ oCA-F3BU!-32N+ԆJ%@d{,_yؼZn$ pGzuD)8PIO%3!Kh& j6{n8lePg0^ЩM|zv.-ߍ _NO;ĺ 9 XM AV3$1 ]')lwbyN @$X!}n-qL3JI~ 9>:+ D8_ŋAx/0?%CJLjCߺU#*X99Kk]Yg xޱ8xQX_*1#/b0~(XFˇ$=zUS>qA+awr|K@iنOi;J/T:9 89wU:K7× d MZR>ʚ6TajT [M$ D2iɚBv9PhSѐ> &*@9a ?Ň͉yȢchRNϨ[UX-aO3x7e8)}:_q$1%dDMO̡⑑M4j5zޢQiehBd@^ EQp bS؛5XXhU@I꩛.Ilb16yJ% *נBy6xilN>ɂi8ړ[] %6أŰQ<~OA X[E2ىR{%s՜[zmV3 }\%\+|/K=>kyZ v_ӔH vueV CDbBC[oը8k. T̚I<eZ%)/fc"@;m-jl{>,NH&'?7vvAg"nCc[U\LI_)Wg5ad֤O‡yBT4 ~$x /K޷>l||e"@0u"pgS#W4щуE"]t&{P_)L*U 褳|1gp8r$iڮWz;nz*t)mFH!#W#oyߋ]W 0H+/qkUc _ȡQȶxO=/aQ}gt&$zG9:2 ]xh]#K65 Ϟ1"bfT\aa}םD נMĸG4k"SZ_ ]iB:;g7հK3 l,%296| IUh^pq+'cc.e7%39>cPh{7hNWT]ܑ;]פ ]{HmPSS!# V Ra <(;?GwؤSK{Ij6HnUufLL_S4U/$\6`kW)dY`FPH H ^AE3 ҼlR=-8=ke6,BȰ/E=XsE-6@oU']QAwGIQU"0w)y3zM۴pļxT/[ɶяhGKnNVv|%Z%Y+w>x[s.zkUzkP0wJG]"R9>lTTl̢&qyПYՙs",dN npU lv5@'ߘW9X(Z .Um7(flxRf-n Wu= XϏZ,\y=%s܇`L6SMSz/\0nnX@R3vpK"|dr@05qQ]3t)t)VY_.~Ϋ=[>hm ]ǙX875IfżX> stream x}]\ɑ{m@Ec6?6`i&R9"3;/'NyM0 LUtVތt{?.]x Y|(|[/}u(jɗ?] xcS|'([PҾTR>WRjQJ٘I wF5+QbWJuxR gq*)lXR>r֥h&Rq)lf )u"3*=e\NN$iN)b>Tr*yOJ74[aaLJVN_7֜SN_d7+vd4ҔqWqAv#'9Α8qjO`4l’RTFCv)2Z>(D *%!["90˾x9~t]O|*R)+%r!*Agln8MU-gdגip>K<)/2OBD"ƾMD@K^}S6<-R 6 T <)*3uK"fR ǯ|&?0-gшmQ> ;UEE(D#9%e4a)R" $tM BC8&&ėvV*b)Ԛ*a@7;c2JF3JQ>x` KҔ+r@>#$ͅ Q t8 !EǤJ(I H:)U r jфҕ>W,qN,Y('!"츁B f!6FbSDG\v[_v8#u;Dt HD*mP,8yĈ3"HFQ \XFtr9 dzfT(Y|`z[W a*mN屗hRU^]`HE( %P:L佖Q, w!uq^@;'BX=R3oMCZI-gMR T4h ,s 0]:#ZI1Ķ+"?us_28Rħ~{Ua 3"挰ʇSl"xV̳ !*g>x/M9M!1{,Y)Q"XN̏!ME1-J6N%Vh`P-"a>E#) K@3 )t"Z/vsoC !b3 h) 1^P˄B 8 B8삿Pׂyŀ+JeY:VBSMatJ*P^ Ѷ̱TMxv;䠥Βs棒A,.5OeY޶Zq8Y@}j TIjTmb %Qҧ~]TJ}X:2AfZ`jBƨ%JB [H;BI˳.ӣk De.=*fݠG12%$eS( ĥB]BŽRQJ4B$9YG%.6>f8<9) CEm>L@W:*ټ#­hg yB 孟C|V&42\d>]dYZŶT3@F3RCrZD) F"JO'r>XWjҵ[LǏ.r*"rڭp.ѕ&>]4S%>++lW3#'UkeHSrhc=4 'fQSN'jпT\"=2FHudH9,b)7g*֑M16"ԓx1J֩#GҭG7>( GoÀSʈBSg?j{ !mr@ͺ~Jh4Md L6ch4F|=Q!&rBa? ~}!m#xNڋ,OUNc\ 4Z2 Fk$ԃRmn#QTtt1)C2ZDw NFY[Qk^[6 5[N[-H2A9klcjAa#:OdsĈ9o#"e kfD@9㶁#8n9D* 'R:98h.DFYwVJ%(NF (@3QA%ҋ*(^[QWܯ9nj_,{.53%H>yjtŔIHDom ӵyZ5C"R3M?UښgRvIQsVM ivP4;"c"29mi).af)8VXȧęBXHHaKmWw=컋?\I^'"/Zggd7uۋ6HEhJ4^Vo~_F <0[ }A@]w,w]}xvzA}vi w<ʗ_Ram Dy?]HϊB"4(m(w#e:c`>)ZHIYZAHgC$Лrq̈_-XPCrO6)~J6U(V(f) < GuD-c?o5|k`ZQBȔX(m`f4f ؊@-2¡!j|M(,֊1"W"aW%lAg2JL: 6 AVKڣ7Hն,#zLrHJBEVȕbŘn G;X%\yȵM Bс+N܏;x =o-yͧY >ɒ'bBFJJ' V]GY+JhY%ztZyh( Uˮ߁4a DZ 48!*S!RncLKVWh;ZAtQJDa$mKqQ,ցQqbyTՅfɊ:R/ CzCX6*8Pt>ouj7i Mz!iY M} YĨi2 QpX8į @BVaE!˅X`$buj&*iK2#N}X*JѿPBJJ- `DjD tӀ!im8ف4۠L7ܑ6;O|☸9;,DSx @ճvR*.EbЖfZ%Ywv?DFe^@X! XE:GE)D|iGg4 ^ _8p]BbA΁a1yDяvҐ7% 7Ruf`8 )$~hiHSU*rsDk+S~5<L C/;Ś"hhP k۳&v-*%VkՓ[QXqʜX ;{Pf+p<nek(GMYfI[!@$+uwnARhkg)4eyDlԔ=DT0_55"N7%(`7(<0-0]d z$'өG([6\-xh1 b"ЬCfxLOeVPa`U2n@ Qxj 2(p$5f  v b5 ^v H3:_(3JInf{5{.APOX68X4& š4@ bX&q>!\sdڴWi ٕ|hHP8&e%n1;=XD0p@R(Ρ)%@X$%32NX`7Cb EmY$؃E [1 [fwBc0 C/,  +#2i%Mc$bneV sƝ(,,))C/ܡAA}qU\Р_jJ3cfMpS]N D/@ EX 晃X٢ǯBjjB3Q撅 Plw(=X-_jhH 2n H l@daPX!@21tD QX!@ B` RX"@b%I#`dUv*4 5o8 VEᨙV7H( )BF߱B`e['4څ",OB o`B(8<K X@JZ`@Ќ4 DODB =[8>pmL!C;"  |V @ǜQkISh> dGh}"[ !P-c} \sdžgm.N->`bB 1C2Z3AÀE"}0 1&ixJV3PQ4a(l>"[i ZD4nT,V5<RbNuI%Xme]Cx4XT[ sbJ2@Y vMG`iE֒w, fluC#n` !Tl Kh7;6kL'De3}k(Q!%+DmS( aj gq+.`A5n @PՆ.E ( (XpǼ Z8U㩲.kAc Box&@a`=Vn`2(* PG P):zџfbbL{VRa-uU +HTWXh8Ǟs`ei+1 4԰8&2/mqq(PQ2t*l"dVZR( %l"P WLDm АJ!{0v:6&FCA^%5ڭeA=ctYm$j [ OfBc/7^4>02k&*VV*X:k%J .Q" ""KgLjF ꜭ͊HÁ9c 򨗥GP9Tms2+[3m=@mQjޙLa7K*qeE%ܾuFaI2pQ/\ $:4Չ*hXW%)\lP[O1ir+(|@ifzqZ] u VXB ŏ5XA\ ݜ;pCz#r]h3qq@v"sMBrZAr7Vc(ij> ae ppPVātGÛ--W;g 4)lLc3hV0-`8jbsm؏PP\֡.3`MRaH Tw'آ1L .6jsdxh X=kP7֣o  ilK) KD"R @6>gH]\mkHfZw Q+-!BG/^?ew˻g+z?/PgE?4S,Y|r@c7DO]6~ t.+}Q:=V\>vөzp2^:2/BEn|dB+kt~C+"^{S)S5YӋb1hAɇJ| Z -y[e LxEoDRxhċ|~@[R/M♾mM"ʶcPA}AFuiQAc.6 24HKo寃eX622A|kXso_->q3ǝw%:wx`o&]!DtDŝaOy)LFAR $dtfcf 2ꗊ @'z 5Tx `m9?˯#˯l#[ /u<316} )$yD|?sO:'w`6_AG7Zah%tzT0qnht%y|7;Цq]=n{H6UxbP)LyBqT-Fspo|/́=M\kE:ܼc 3ͧ /wIͳ+hResݧ,*į:ދ ߮?łe=~^J%aU_ ~~y;}~?}>g $Emv>_peP )Jvs`㽊߃$mR9(2:udYGWorN|Wq0P9/<\z>6#]rq}̽c hD0'l#qWciW@ݔ¿~A@=W Q}z_R5yDy>V6Ȭw`Κ=+^Cʯ?dc$5*ȠyS6j7l7 AWCd(u^I*$;nUɹ-X7+3R>U&7-3dmB !T~14>EqE'"aLFKT8zR'v&V';uW(‹h⧳]Mռ9YM792;u|> 9}CY5wUw '.>xpYtoܷ>o*S3\XVz;6N;>kz|3ѓ6B:G=y8 #9a^q88Iᄴnո pi;u'5 ׾6rO\O_#^Vv0@'\_=̟?lwѐ -NYYơwHz?/M_>B^#1YH6 y?I ɲx.Mg40۩#EayߙЗvQtXY@qcWL7KiTO$wܷC8>!WE:q9}D3qŶ..3F,wsWeH?&F'HGQ=$Qi[bq}+TlӐyskʟA3t(œLs psՄwL(,qvYT ʥbJ<:!Wf$!1HvѾ,5_j2dPWe -oloW㳜o_>͏ׯ?1kf%yyw7uaooo>޿ؽ~o/ #X:S3j?ܾK XBr70_߼E.ӷodž̏p}|sLJ_T*O_ij$ޅ|q1g;W~Щ?S7 D+{ _^0bfh?f %;;)vtU{I?W_T!V%V'a?KzWxGDHį%*٢is`{vNy5 OAIw?_7A]5ɳzah>~w+7?|T_d{O3Mzg'x 2G29x [,W?>ӕm"0g 7W9GӌWL-YI/*YmR5b+3sp8b6]Y z{`9brn"GA8yً89)n4gG5+ q-ǭ=*ܯĮ7)tP1UZ'A}_M}xrfs/P,?^41'iZZk+cK1t1k.qBQW&Iqe/̻qTfiЇkdsCW5SA?G\VgM98Yo:46I޿MlŘW_xpω d\EC=WYǔpE RgYCHccB"h)vSbOvBbUWYF+1{5vmuzҨl}[thrB4v?a+G1"w11B MU#(oߡSSq83N:l[v;q0l'wb~6,NuO6/5 A;NV PGD@A(o:#Lf>pFGZwTRnZB99{IV*8}Ԗ>*hϑ5W8><QoQ U:/ۘ(K(mn6 ! tW48/ "PUvB-_BF{zCq z&&<`!#RB2oA %E]e/ JpnEcwC.{m"Exa1F[-HYD$([_1;^KZ2أ%Zth-MGkuʖT:YŹRU}%x0/o)z49NFrlփ!Y/uo8xEzto|0ɣ;M6~]Z\OV_; ֡ xx=\AEͧ)s{X~7KDmf<@p7l5Y!r\E|=0]ī4bmtӜ~2]9a$p7$vendstream endobj 694 0 obj << /Filter /FlateDecode /Length 4746 >> stream x[xnzOFK>l5u 73 6iaSZZ_K4y348尥n!82^ 1*W^kf_\_т1~\X0G%@tfG5pp%!v@ $\ny䴴T8یi= j "EOyWB0%()ցV.8^0q` M1;2dbL3Ø5/xkF @pX>8,^uבasFjvbBo8%2 -FUds*ٜ;P&r_}z+S2o䰮i7:-Jb:$,xrQN S4.'l hd:d6QtDEo4&#7|VSf}%_mUJG)Pzp-Foe%3Y0ybܚ=K@J[;@Yf!k;3~KE[BM7%o*TJ\{ ;} (A*Ƅ Ib%0&(S<{)"[(K&{-f.7ͣi^e~Bgb,|ٵ,^%*f#Z'C[gp?|j­ByW1ԏ8?on5קS<^ `\[?H7z,(0pA.M"n a+& 2 1</6ݼ(?_;"7\EV8.Mri@I ̨gX>L2j$ X5:wZrb+OOTN9-;Y39bP z]*T^+BX80y^]jbS2i )ޱ=[ǥAaEdw P3^5ˡ\3\`~[̙B͔+-S^#`U6Oycjkn*к=JTt탩ր WA#뾆sGF`r{y¡r1g;a_MX a#wbPLL1UB`>eQVc|#rlM^[笲 *ݒGSxX(uRFH̶z`%ztXfD|-@\Ɉ0mJg8eh` *Er1HĊijA]VX"ruLZjR= b6g6g-ҀstYHϟHwܔsO}p& 5尕7V1QTWZXxt\ui `|,(u)z;$0ۓuL1!@beRMxg~I<"W=-E7%4w8D&`y"[ GӖasN\SBoZZ]*xnjHmdo-kT,nPa~C 3St)T"l@\rKz:M8+uw} `KQ~Ylxc:mnaS|8MWE?z[,5 ~lA7ND?ӌWXH7cBew36N!q@I j 4$8nc{\z4>G.UQ3_A]MxCP_o8P.N Lｎl ڰ#ɛ2d)]0O)s5eҪΘ܏d:xv|4Z99]R =F:$W&D a(v3\hg QÆ/眛 rn .Ĵm7t]܈DBU֩U@ۅ`0[r|m:9l|ֈu8oc/&P/_Ndl~MeCWW.h蹴T޾ \X뉑֣4$+]yY/E,OF Ĵؖ^`^%{dۈԭ|j&u:7+$N=w#Ne`'&Cs(61 B5wODL1%ЍѲUs6<濵3b xM;tv),9.U5iV7<ƷB]$xHnaQVnUr}+@bgw%`br~ݽeKH=ǩ @hL*[7M\T905˜?? Tyc|m|_cS#A(d&zǥ`3 fyRi΀?@ .e\0i4GH=}=&fY&o|̇6 +F-A%O!t*t|$ <ŧݠuDmB:0Za4yXl]\ZP&8պ&EƾW{fqRLxRNOӹXM}c13TsF/Dv`K,4z?v=F''cאpPz w@ŀgH)=j:NmsE;6r' ȩ00 kR\4vɓ)²Slzp ]EU{i(fL\תCN~6 {s d9Ă7=:Dq&-]ub"5R9Y0a| 0ޣ Y*jx)PKva1SP$ךU[ǽ`o@ kra&ymѺq`x'>`% ױ!6%dZU]jxh6UH0݂*磷> stream x\Io$Gz 1b/hƆ(QlqiI>}~&,{~}ٰpQbc3U~|N]GG9rS0GrgGb͑QOZoszO &#kOoq2wr!N²NwR2EZk`-Nb8ȄЦs~)P苎 =})#c$ۜ^}'&x3ExMBo%5kY㿝ӣoqne΢qXUf~la{Nqx(8Y6IQvw}?uob+qc%:Ֆ~JoJ0{2&ͷU[^ƈI}ՖD^끁pbPE'՞tzmHRkv~ւjBl3ʠhmU* ?|&c:"d niqHR-*Ln4@J$|ГK}BF@$cpiI@pEuBPCL^fZ{jh4 w .i3.6@0 TͿo̓Mr(aaTbXXYYp2c<2 .8CMPObdXEf5WqCI7<f nc0i}%lJ-Z\S]$%,0)KOŒ>wuP!w;IN&(U8Uw6S /d;!|'np^ y 1̗]Cֽg }\ n2J "Ey&[[>$@$׬w4̪jl)-ݎ%odzd㰛[wcncS{0(W&$~$_un;]Ϗu3I~{;>>ܾ?yf鰽_B6[pf5"c㓓&4,Ka#}zCO nސWk Ӹ/Mh\My%7+kn"R3MhmgpD {uIJev, YgswLM4 U^vF=5Q;DRKM^-5zDiKM^<5zDe )fR3Ԅ{ejB[fl-5aa&XjBSynB^$MT5sGd=7aȢȒFrGXrh8g^KNTԓ%'C,9aYL䄡x8''%9hɉFN44ZvѳhD'*==Qh FOOT0zz hT hDç'>-?R,-?,-Ai OKP4EcKMPt|jShhh EgKP4 EcKP0EKMQ48ZQS.-ER hpE(rDFKQT0zr-GѨr-IѨђM$ES$-IѨђ-IIKR4MҒM$E`lTQblb[hicYkZbji!YV4vmMIq@lVBp,~Bg*"k! WimBOYf0+%p;AZK V3+dnUES4xEyȁ -հ5.[3W^,͠l(U%eC2GtFS ¥фA\H*t?gDefpIC…H&[0+gFL%ܘbw(%?Xe#Ӽ8CEjE @ML*lyQ<&[d+/i5dᛟb1ÕšLS!}0Et fđa5`,L %sFh(Gz|Nfnr\(c>@t~ nKJG%8[`a^ 51F0z4Ԕ . mu=gX7B[=kYdmbj (Pn#85x7* d%h!Ez]o0_n_\Na!g:2 dGAre\f]zيmZmSuHjCRmZn Znc -Zn I+N)N-5m*m\Dz_\p\' n"7CoF9T`NQp{P^p3# nƐv.X[N+]pQF~Բ0u;=zS:>'v"B#5QDhJׇ섀Xo] ް&]Z HOb5iZ,TQcSR?::5u7ߞۇKl@no),jiK'?_aP9AoCc5o -{޳狌TbnsYu7C6|DqEU`NňswPa@TzG Vxu/۟7*9UB iFȊްp2sAyNCTbVO#OlNQo&a%(Gni頣 x<\^#XlOxUϓ?R8doT'J8+Uf1=UXFk*zE("Svn؟42i^hپ$I|mEl3mbg6=>b[fw yEUiN消1^|HpetJf:^74$B ,YӉ 4긬.GPzRE%QwMy){fDnzj)*Y]WgU**m}6IbGW7(1!tƁAmP5Ba`Lуɬ%X%-&sCK;D8&( ={~lXo>?i"i~.ي |`.lΛÅﻉ Bѽal6}=o[OqpWŷ)]yӋ{"r[w=%I@M.LqgR'ځ l U}-Gf~_<_G]J0\*|EY䥕rtL `հ>EF9'yGk42k$! ?eƒ% h PN 쉗pz+=O͞kӷ,_lycϷ치(kl[;lQQWJFΔP}}fd@PXI+UK(oN42=-oޓfX>HQQF/i NXۜp1`OGB:g]&8Ng<3\)t̚uVR`Ř$xdd*x?R9d3T|] pLR`B[º/?h9|l.C<73q6|:N -Աm:mpRÎp ޤ1 ncE5 T[5i~#2X>Mlj#tv3o40!$ z37j wx҄|[}H mMg)kwVJOL洊m< o>e|_/`:KT_t/4x;YW3  Ǣ^tR*. e`d6pgrnZ2Pq^$L6؅J<iydEۙ)j1+h'3 P j z2O =8fR~9 *V^HD)ɉFYJdN[[3krk^V_e~PU*rj-x%}qފ El)VOߍ(BCc*@M"XAb9T a'ȟ=\?}УMڌK;{8{{z8:w}ިl;iq˯oN_A7NeK7Nd'm!ɶu~z#dtR+g+5Kwp=߀cJH6O AӱKrjĞ bbC_&-WNVs|;|a>?봪dW,Aڤ8ה=6F@E#T}5C/8^0xp3!܎Yҟ;7/ȢPzv7Rv H^"`R''`\rJNk(/2OGz˓g^Oe{{AϜi_3ꝲ_3Ӝ8(^6ɏWf13Ŷ'qr&4O,JMCٯIz_s1zEٶ,ux(?N"F)ϸUl#a~v+~-eF}GeMqp{$>A'/RZɲ!6%Tmg2TY.7%:zN8_C*UJQZj"z5oE5HM7kzA^{)"qe~?u,؟eu^O͡cOnrv"SECgwˍ˱Odk5EATEI`߇ ٪·WLUO'żJ3[%5yE\f&'}Wgylk$-Kl<%k_1ܯ3ݷocRd{WEcW9Q,(qVK⁺}9TjTaQY4Kj}>.㮳-/\62@1֒_W+Ԯ֤lh> stream x\IoGW< p_M@z {A_M{}DJ☋LRRӘ?YU[=ʶ}P^.|dFݻi3A?onvy- 1cY*vތ bTV󛳿^hB 'O{%h'3|"1 P;zx.&!2fx~ni5cqnpC a#|k|$q}nУҖvCQ w9;[kh0gLj0f4b8 Scd\h&}pܳbooNzeçB! Y+|=x#>>O-Jcܟiw20u@0={Ιb}ɞĞGެ[1zgrȏ$Fkakw|#{qF<8owŘvr6 l9ٺwX+iP©}R8+tAѐI#+q(K' D6:wyklP3? V85| ]sG+,Ԍ9d5Ydx/-#kLvP&\AјHw{/Y"~\6}!J_/2|1)AQ@)dQ8"!?AB@]_@?|?f٥&7܎wwoX;A?`;`8h 빭˜kSg~y}Rп'V(PZ$]fظR_R\QHnc-i n9{4D H0  1%ѶnJ"\NRX'Xz^PAA 5RGfi\0~F=_󪇚60l=FJd˥Pn5 %2CHUp<(Q O(Ӌ* ~,BlϐT?/ixN' ѹΙAǶɺ U X—"OR%EB[I$zi+2c`qv3c*dM gN#1q/G+D?V9\>-"$MWw:z`c]\G>۸8A3U / 6.b:2hoOq!VGyLR=Ro#5 qiˑ"Vd]cM]Amگ~)m+&tz,zVYx1X+1-墑@"%>5[\cbi׃,H\A?&peӤ܇z!QKsu|=35oO%:̋MCK#450i)ٴfDLKگ'0-,U-mKW%zLo`U,EE)-!MG l[j>Q=9;)t,0Hk MN-s*߅$mg|hGf|AV?n3} &W-Izi.$BI[OQ|5[+(ӒM5PYQE{q)J%Fc{={Sȭ|ÙN*l.$^Ybsliނɱ_٩r#l\J(v fБ! шfN9 yO<Ʊ1CF1#zJ')PyqώIF:@?6$r2A,b &lCokrǦ'L|`2O-`ϯ!> 偏bDj.IM89; I r.T^N-=_tNi5JѶIT4ѓ^]N.<0,"='zN|&uDl8YSA㰜ځ&J*4IҧգS @S6TE +pmг% uUh^xS\J2 7c`\pl·SZ-^o(:9{ Q@5 ²$[r"BxHnɃ]ݮa=3yVyhc>Z󳿞 S4:T'2\/\Ncn, [BrM)ԻI~jzyg* 0FFƠq-ٟQava$G._/ZnX폲]t8;~tw$x$xu]T p7R#A1"`>TD7]\9rGxqZiCoi$'cXdhI"qg$V?&Dž{s[}7LT)pw9Frul={!ŋ~} q8뀅? _X>6z &Y?6 "=ұN42ٽ8 pl.Pj }Hi6 )Z90ʨͰɌ~Y"{ :"VWsД7= Zվ=t3Xom30n$]u\xm*+ wBS-+ # 0^<~|yyTA ^ܒ$xqf4fE^n6mBTЁu&=T+FQko /2|,KFM\r>@tק@߿y$Қ\ )'R*k:5 nу ylQGSA9L!h\[!#ջ1F TL|7`^sWW!"8|2^ܫ5JEwOR) ^hOpDžUܹ`5DV6ެz8YkC5"D;)TJ;`.92#bUN^A\\)A1#A ʳ r&͘N3G _ҕo n=r>҅{ǪjEjTZFzT*"?@*c1! YlJv\Y7rz">kF1ԥ[zѱ߷!udS[$ "XU]Y>4=VV1n@vBN]Wlj/ԫfH/Z%{ 6)?ȑӯՁHg^,.6?o%UR|`CxiiBq \Zjx^Jn}؝NWߎ}xnzY?zM;6޵"1e~i0Twș .9܊lU IWU]ħkVՊW3ۢ0ĦMvaKDș݁L^BȚĈ[endstream endobj 697 0 obj << /Filter /FlateDecode /Length 5379 >> stream x}jlr8 }k9u '߾nsp6?&z#ak-6GTqzb|2m=I0ƅY= 3Yobw! f{Xq'/8[WG|O܋=yt=NGf>P޼4qU>AB@$ŵ4/۸J!rUxoq AVrlfz [Z^rc'ob&)KMF8,&E M8IK"sQLzBpk9Q²HPgiJӀ"؏2?ZRR)zE)TLz}e 1f<ed(K]@ (&u!:7: ᥂93(P~ih>%Tڇ<0*- ى )Q AFzQ'kX J@&@n2s/}_U?ԇOvpKx` j.5 Ӽ@)B0RU2 €]e`y4%&5RH^g&`)1uSR(0cڿ߶s]#CY_ `ѽȺ22m0,q'he019 gp`7U+{wڔc iV䇈K1rM`Ɲa LR&t-@PW}">F#Kt!rMv2Eg2hxx? )kF='8.MI@/ɓ?=z$ 6F$>KNMH4rHgHJ cK+~ 4IJث#ǥyS%DگW+ #A!K^/rr:BiFfG% q&+V&1 _޽T if8A푈g<-ψz>șȗ$c sHT@(S#+1\0=BM~F5Z:L)%8vsy~_ÓT(p%j7Qviu<:8꛰HJ}F#q`bK4$ CN6;"*Sh8O95h贩3&9aU}h?UOC)Vᾎ[X!eI2p#77}A^`0^|΄oF h笈y2okKʨHeB~<}m<@pdjm2@b4ܺFWSEӄn0/jgK27.}Yz!V%YzB*MT &c~lTFv < ^^-8Q;ג`-4h]PiG6X Ngxl f6="atb⽼MLAT㓓63eGVB£Q=mS(!%OgrN6z"nMJ.">A>lgE>D;iOʭ(SMm`6tLS7&|-p v{G唋T 1~CC z-S~8-cLrĽtDlvQfp ݜ2BO4("ʇA,Z* B7o€e>7:O-z,s͹u3b&ץpZM<=_3H~yu1HIE 8 ( ϥ)CNrm^;^"Bz'W;Aݤl弮^AvN'#YNKʼX %PD2.cM%J]|(_jeM2aQt-k4M{"2ȢAC.2r2,C忩U\|alX)FT8~1CRCa,R*2z+nRvb7ᦀʪaY] V3<1V]fUꥦ #{K-M/ b"y? Qnǜ r.=ϱ<~Zv><Ձ ^^/v»=Dܖ䘯 J;i=&dF~QH6& 8]Z6czpӸU${u7t4Nag+RA#%E_]=@^ѐFb'di"l?r58]Fgh ݋XӒsg|/lL6TvL6hj*jq7;+k3ujkXEKXP}I]nɽ)^! Ӊ7jQ&p]UWU5}'߯:Ml2:_lHrJnRg NyF1.,[T3Ucq'm2N ]VJUVBLR;ј`RҕOg+{*Yܠ.bc` "*Us=TN%}Xs&*J[eujFT9NQ{#R):LLF́γw_Qzm:T1mdQzep쀝Ep']}֫:kz",h`* kX;#/;DI^fVvLs{b_zJ/tgNźm7󪇳숤|v;;#e̊J6-Ks~ea>ۡrԘfgxp!vٜO9mX 3LUj h]R}QF4e$iY օjM[~RQ)4#m\Gm#bA7g +L@~c]EEw ա"-4Γ Fy7fgrwS^2~2k!skwaUz۱گ(JT28b8XgC:WQk5.b-yɋ', /O5p˜"̀*tgĺ}mmav 7[J "{07ni;`K.lS`B H/l/NcooY>aӎjaM;MIX|б= il6sQZ4 \Uׂ$^r*?0{ pt0ᓭKG&})t虁ݫП%_M:yy2(*|PIl>]_Ύ/+O ^[86^ Hϸ&V5h^|,t3&g!Odȡ\JK[Yttd-rJ<}1~&NlG3Fx ̙o%DW1N+lKIPoaYD^`Ehd]Y ^ }8|܆@ҺL#[M'v4ۘI~AG7U(?*. ?XB;Pimy*,rBv] t[!8'"+%c]eɨscOѠm9ޭ,/;=8BY)P(9DS`o?Fd(a39#-v?7NiL"O9) ~ NM'Dt{]i_#yQ7 /Tec8ƱCR;j!T3Kzk̍^ A0B-;O,\NT _Hwa<^endstream endobj 698 0 obj << /Filter /FlateDecode /Length 5112 >> stream x\[sr~g#YG;+9Sy8Iŋ"Wߞn40`fW] aյbɛ[>VO>vܮ zH)l[Y#޻o~1R޹7Y5OflڮstxzfS}^ٿ?Nξ[x?lj^}T -|owOWϧ]Yyӽ00tm_mDVr+OwWv׻Wi|_]ϧ=H{Hܲ l{!=Mzӵ렡٭70iY5{u-VNeOl^cޘugL,W j~뛷h>w{wy:߮a}']'k+uR IkpskSׅ:#L0IC·F9p8=LF̎s2'FmuE.xj;|N)v?n>l8xs(дH-= K_%p"u-:OQ`ؠ-iVBJ$CRV~{$mO5,M6 )۵(XErVO, z9v???[{'+®=쮗a=(}FE5j4~ſسg>k}ʫW6Iu ;Hu睅/:u8J-`վo^%e 44P&$J6iwOvD6Vځ;b+Ό{|gr Lb8r,Nez=,}@.\!sٽjhrp>P}jst' llJZH.;?M>ю ;j N %*J*Ϥp0 0>|Bcu͊q({Ώ&vY󌁡"+̈zG  (; @M6@Hf9 7 =jG9hH6qD!kނS pE@?` 4M]l)a ș!m&'=} #}[JU'*CA2Pz&aRr⸱j-l]԰IFǍta{D7 Q&"@Z8~c|uBOM4a.f]1OaFSv9qkB G"ȱ 䌾"37#Dt=o+{!"GBC8݁ Yj;ȱB!#t.:mΗh`֑/2K&+:9>4h]пȋbv$ u4{1s3zV-b/ 8 ha˹T7w=."} OVV!wlN| R]]؉?L5`cYQ|$F#0aGU*2xaХrـE*E}渘cE|ΕyZRP@ i3T5DWhgᲉ~^'2Ոǣua9Kw|x0 We'qRwpK$VXG)V ?'/,OS:~ 2Nhd_S]5{njP4Ɛ.c˭L9ClV flMYpy~(|SjsE,-i))tzş^bŎRzᆏ -rSQ֎{vP.q~ֲƅJQwM+MK}#O\RHe+#],]LF!<)R@YE/H˘wfl?zM~Ej3 wO {wy $K5WI]~\%-S'H[["41}Cуsq'CzérhN\ߗY08/_n[]AxA:s]EsqNBQn/ Yt 1$}kϘ}9ో`b仨UHLDяb ;@|L!9ycNE:k4S%u1 A&_FQGC3݀NG^&Ԣ( *VihL0PX7j((s\`9Ӽщ z)JU"alh_AF? AP3k}M֘jU;-/I<װZe>N iK^u*K! [1(f]mB-,_!+I$ZN9Ҵo  L%1&6\,ڤ!r:Ţd=wsX>7 P_[ߎ+SFz44|p( kWj;x)qmf/ZZ}=&Շ!UeSjȁ ,]xl&@ @3`؉_醚O/3g$!gACY8o*4Tׅ7V NK\oKp o$Al6E8F%o2  Jxxucs|op2D5a1fE>HBMNY4|ڱ=\,f 6 Zҧ,f;N,ܬ6~Eb mۨ .0tE0OzsC; A_K_<NmpNRGm죬1*fkH~vtr.$ NP}A,6EW^ |Aaӄ;F-ǂgZtVdϸKX&՘5bv*Z x|'fllƞhs]X|l8_emG5A/Xwh{=Ķ_UW g Z6Rb~Jw?Vflaյ(L GKof5{޳[qSfo{۩V! 2@v]|cAHX {_C"EN95t69|IIpwMH@@+ik1a?C& 7`'T hhk0<uT J$5曲Ʃ,tO [" '_mhVbK,HN> stream x\Ys\u~GT)% +qUyR^O߹TLϹ|uϼۈYn; 7OGbݑLnʟͿAB)9(7gWGY vM^ه9;nXe'珻73DWRO,yy mw7*-W/>zyog>zGgaKɺx޽D +3+>|ޖτNۋ})%oyF9ZH+2DJ3Ro0 }M|&i۟qpv_G)2Υ2Dj^ƅ0 "ؚ^[,Y6blFʔ@NNl'BBJe?1R- 3<$-?}8Jˀ!^XAO`.wA#C~ƒC5hckeϳcDP^K\g uCwlP~>*ǨOd [[6:9( '6V4IdҰXZx0kSh{2l⸀]&DwFMD{9{7'8'vY eD'C7L!=T#1F hZڬ73ݒ W.޷j+9/sHzz:<n)G7tf2imQ#_>?}K"0g2HIjDϖ$O4)^0~ȟfɅ|)DUҭ0?i0K=9]uBm䘺1[y_1S;63O6wpNJ?L2 V,0b<@sIh7P4ꇭeAJ*rSVB ]N--b{' k`LBQi4υ^p9~h_hBvSVYCg)sS8tWvSY6.,cR̊I1kɯ'_dK|XƤF3s C.(< LJz tY.NYhkXl)2p[{>[DrG16ӳd\Kd؋hF>.3!^S~Dɑ{VKMt)€%= >[RN؋yY \hR =fa 21pa7iyv{o^)x"l~:x>9Μ7 N>8h77oVsrH l_g6 =Kْ^8 GM+ZO8s ='Uuis\S^MMS^LMC:fMpX\%<#1"JU\?&EzOYNu4|.BXY t;YKxVdfR_6m%Ku90/SPhXV<ݵ$VƲ^H49yј&OTR{2[/"Hzz<&1;#fyͪ^"KϏ;:ۥI`>M%e%)&K+9; !nbs^ZcH[ᯓl3/3$9t n;ioW5ٔW}Z:ۻU^s)aI-" QO(7-htYkwwRKDZ^_r53z!M+x5%x-RB*z /@v:Tfg%\"9##MΚb#HhkK2{R!BɀҔ#1ҥsRޛp"B|L{T"\A.Mi-">Ng}j|X_9H @jlЁڐ_}#Ss隔pEZ -Z̈́J d{. u0APw0!K]ýǂpC:ˮ$JTN$smI7t:נ'&+x)YJ]#LUei(EԪӊWNAryڈ[\M`jBz%at19J=ZR?B4ED- /PU'J2E0"d3:M?znEǩW)bO-)>&*}9wEdhteK,RakYA!А2444HG 7+BGT0!#]G`H*"*eT+,OֲLGJNr$̍ LW%+ VT8b.G`Y8`deG%'lFbw˘ B;"Wb*2FIK&%`hRa/L˶Ÿ7lRy; ٬v" 'E2r/D6*K4-Nq Ĕdž\`# AQf5.#cVcO5=)lXKG0;;VU,U17V@أ"hK0L$K8s%q\\ :I[Hcm- $̮YHSMKTMewjUE*GRbSRe Me@\cf7uЉ"5G82] S@p.aat!^@M\ .D@uyVŭBE$& R2l J*Y$ Ö ƬTu<K YkӰ0&OÏ_,WN!>!j ,HBKi˙l¤sŕ2KS!T6jh3yvX[]O,sJ lnPM!8Y%QmVPhoU)؉hIIIռ IJ͡%UgMeMMM+sK:r4"ֹ_[1Y)X zOނ}U<|wB8NTR.R> jR]v-ZPO{D"S[ʙ<űSX2yt<)F^B`:*6tDgr@xڷT$XCG(dBev5(@i9šr$(JH8|8覨AA%|Zd *3 vr,"k)idC')Dz eWCɰ1tG б9=Ssw9N=!H C?E,F֘ :EMxQ|R& h  Jbװs' AM#0taA-f4PPgE UT$460{& JA1 nq( eCa`"@ CgԖCal.:5$ H< ɑ0T|6|NjVŠ {"lR8gӷFTO\St.)EMQN(:]\QeXEU=zץz)sI3@Fӫ v0j XШ_Gvu4LCQF:5km+ "Ej&FW&J t`">Ef^pRh).xKäZ JW\oRYy}Uh$h28wfЙehI73] }VL6%+ҥr0K?r`SDeQ83K!bP)ci2: y|3e;hdb]֤lz. *:p]dDB"\#[4$HH s \gu Y}# IB:WkZ– tVr}md-v[\1oW*IJ~ap~,E`OizvMi}~M*.HMԡvMt{LVԆn4_> stream x\KsIrsb.t {pX; #] JZkHP'v6 S:54H5z#[/lfa }O:8!-Mzw;0 mR[I/s7&QDz2A+mh gwb}^g$F8YIL: MzʀUdN)t'L]CkN2mDHC@!yeA8;g9"gOpaRuwwi?{zqXـg)?< T㸛}#8 hhNJH"VmR6tk<1l;%M`oq"ȇ*/;]YXv#FWصȢ9 a IN 8଍sq CЧrJg/iTڑjª%9̀rԟd % "F'kPg: &X/SX;:-gexKz$'q[Ne$ݡ@n,H%oo3w_ޜi)޳X;YH g[=>.Ybƥ#c}{*r}@o@*K7Q]Õߌ*4Xj$EY=3 |UUzѻIso[a2$1qB{xurTu/,EF(wq;xf|i9"] 13 t~8tAg׷pgB]t v"~5]wΨ=,i>ROitӯ Ջ؊Qk\Ƙ%6U7dד:PM"qpWQ~ &I2#uNUnuÂ/r"U*+XmA"mRP3o'$D}Nu2b.jzR9u^_ ygӅ\B~چQvj)]k^>TTE Yu-p컩z. IЮ+-1W*#<K1f=M R |~ mr` (A' g*Ѕ?wt-0 z e߭G^${ac+,1K}(xvև4HfV?jDE,IY>! @TbZpӄFG#(@n27He-rE6( E%sif}&Rp"pT?eR/$+\‘d8ȶ6CLఘ]L\l@!f&([r]KB9 g<[*5 BEU*L$r".s, c)?Q̗xy>Ҹ+FQ큢pmYiu;KQtR^zqqp+*%KWiU)@#zC0Ci340)g6T>RJjJKÿE1갢G\sS=WgkpA◓SiyԤؒZ5L+M ;),1vGN rX9˻2RK&PCYz=+E5#))J.U\xJBG)[Tϑ$OL-.-$ѼY]$RCqE0vSDOLh0C~s;d4Zd*PSCF hHoq09Ǟ!/p*"4pH\WpHMᠫV΍U8RI@ X>FqRUIs5|-9-T*1ܢ0Z-)1fG)Tx-yz Ou\G)U(Eb/:8#6nWR =Ͱd:ɳh`P zmT!)SQ XC-&.3`^3r^I BpF lFhOI5`snA}pxlCCLsBA:vၘ37(9ދqr³򆣘y0Zrޠ,]7ҝRqq@ȹNsQһ2+>Y|h=)ZgoY08%Y-Ui3,F }Q ڋ!KYvTH%0Xt-\*]ၖ(x`4' K@~>ʥ'fR'ȒGU G:daCL22hP%p3 ;00qypYfCMvON@Zr8Tz/3 PLZJ K Z`K]DCb 'aQU6a%!> %݄ $,.{LXj EO5a>{Rdk‚=׊GR;qMV yم#'_(%:SC:Ht@НrAJ i~)o~ 8+;GfxMnd6H_E0*ܫ͒)4gWl2n`Ռ`3ͪIk03͔r~\j^H3rbn-qh1WzGXY&CiBM^tNejddۚ|rØ˔Ib茑v btwSzy/t:"] a:~1xNBҹ !\*L+z[(;)ŖXŖ$az|6,(O:SNuENW1vLbz4@ $X@gJf įCZW顚uPt jQP{$@ wq(ݜơި'UƸr3R7D(: Oq7ɰ \2Ig4|ԏ|zQX3T ӂvz@껨HI|R4L%\sK!IXfpEHr/,ȋ_D8zI.t8%Da^<Q-#9C_3=O31>e(, ZmxI)ze|?i|kwy fLiHn|7tO\ ݐ MihĈ~RDGr'Ģ$`e& KzLW;=mv}{IK@yx<wwu'4kyϾ,.iPR76Oj(utKB6om%uE$g%u+JJDK2_N8*K~D >R;6is_^ul| J/?0Uij /z~j=OܮX%@㞞Y]ߕc2WҴ˕wߦgwt;Ϙ7ӁS_3esZuFt9&!IoTsTp֡JKUJ`u)ާ !pT!eB*XZ0gؖr wWfکVvRaXQ~&Dܠ|z\BFO`7kI,xzzv8!GPq-CpVHTF?}c38 e+z_ZB|̵ֲ'Qg^j 47iہ]q `և:Mc2by_L/,s>b:MPMi񽌌˿ DŽP#J7U+?7`endstream endobj 701 0 obj << /Filter /FlateDecode /Length 5495 >> stream x\Ys$q~ԭ%ۅc$[+aY>px %3lAIQ=1S7IrFlm׿ٜL[9MBgBA&~s";늽c?a}) HW'Jmd:z~{xspy:6#6x?$ b}y|S<~|pw>?}xz> ymG5U~UE0 $}]~^YRLOQju"}d&[ۧ:0 6.o58(/صD}'ey⢯2r㓋8Vg$|YCNL/3ScGkd 'I, o%6lK5 EMZN(뭛CQKz؏SdZĴ Z::x|48~kp򚆜;.0k-~w~(iEeRx0WFv(ric'`o`^MC*oڊp<}[-pfy}~ |W]L6 4BNSatXڀI?ds\&2R_s)Rհria6T@h Į {qӞdZ6Ho"q8[QlBnycq_ ={s"Yߜ(:çe(mpQUB[\6|W0ZjH0{[F &$,ZUCRsszgk(#48UO[)80I;xx>FC'fQ4d.qy?d>QeRCkԀfT u<2^@TrtkN^=Rjc!eS|t2N*mYRU@EAC{풠YlҞY_ڪ!-Ӹ+kQhx"|9rdZ 6gǬ@%HE Ksz<:u[EJM:ts5}p#;Gx,ZOFrIǸ݂Őo˱Nbגw_w`Z=(~S4FJ HXMNi J#s"3S1}nt=E:8Fwq641!SPxlBN9{" ~ VA=p;auwn~ Z)o~D^ԁGf-YS *,ٯfP+H-Yp UT18x ۇwq,fcn$/ZS4Tm [0=FfEȄN!OmIAFEp#PK6iPɇ*A*D 7=ڏFz̤[!yU=\~}r|O:|LKVFZ-p:DnvߒżS;d'Dh 1`0^3-T0¶?ݐ7|fQH5pv!Sa T`t Ccs%+I"f(5WbTyY^K'QB fȶAYr+t3`轸_]Z}ZQzTSR[AlX_i#V/qx^$:RNssH GZC6֪@Wc l(5SX%T*.v-h4|Ѳ2yA/. HV ( o04am<#_{ ]lGP.u"NnV3 R%+gu8dIP958{:dPdJE+Vd~]%%[D@-DxF>Q& h,jx?(!fDD /`O.Zr̟z\ѸN;"d{.m6`́yiFs'=&v~ܰD? 셲& 05vQǪZs\$V^7JKlDBq`Ql2m5U#+EⵛV!`c31&8y 14T 8(u,ʼnL[`!DJbBDPGEx,u & ,i..A֫ mWWo&C$ z{G؇S/)6QzT2 dW&Dk ]GHV1TM^! npNX5٪" {N!YJP, \N]ͳa^M_rNCQ{h0v]5ix gaωz^B/WZuO!PqXg)Nv li`I_Ø cAa?&ܜ&i`/`Q:Aj|{GRV<.b }JGdwa徊C$'ȗK19]R0=b`ÒR_cF>3,E,ZKf|{q~Q|(g A=0ͨg#*(>3XVFV1 uӱ%}dtjJ@Y6،(t,[ϒCd0?-saDH5j#a>!lqUH\h)pf4) ȅbZіZ4*u:H (HPn8lA & _Ƀ:le&yd'F$DŽ/Le,Ʃqo vv "NJo6^bۚ !Jg4^E]uνS[}.o@3Tojͱ䇁RK!ns4 rЈ)d>]jE5fGTAoxBUo XZxd徨ԑI̓Ш}y%K''QBC# +bcRgpMpHz6*q b^(RݿJ]0CݔunRdA >bhB]YzJEגE Vhޫ, QCZ HS8} -kk%Jwދ r2z(0Y (mO7a+ѧcɷ~NݲD{ /nq:D"(7ۍszKС38mt1)aѰ*i/ pУ|,Թjȵh./EqTǽC!l(Ys߼D+ ȔȂ\L50:%7E:dg~ .Z' ~ɱv+mvYW RIjٙVD9c ] > aU xf<3p{b mu@+P֙E,VMI,(!U7J{9>A=@xR9)O8o]r"4hKKhdfA2"A3IQzt I/eȀ;#.]Tew'<#D6 l&eYugKL=Zŋ8Ym?>GnOZ[kIa iXޚr.1SC, FUdG[۔CKW$Ntil*?e\j=\;,\!601p3ƔN7׹ӜE?E-ݬ){za, תk>W۩5C.Cka:Q~l  iC],kP+uheMSx$ON5;KB q{6V&><9|Z-V*rN&Q^MʚO(SsMwk,JAl՗1H7XJ_ cLv+S>51G7rIԅ縨k˔m.Z[octF#{: ^p= 25 1S㰯uwWF"owV=*@`r,[O.2XcgK&-3IJ84IJIy<37w bY039mݕ5%F51nfSTn4eAz=NW G--& fc,H[fj} ce:$. r0 ]'O |xq-65] dCs)\|Ctor)?PҡqhҪEi5w(0koIg؀|rq]yf xuJ%=wHn,o6t6…}fǶ,ݹn6acИM-J[0onԁmbI[`k{z޲TS3)/2o*?8Ȑmէi#oPA<d򃻣o+sQXe._hNR2`h*lV[LN(ŗP'(g:A9,'®5{Vkc]#, NpASxg:~6&8P `Q9 w 3X8gc^x.=+-]3?ȜH q6XdmCSp8:k !A/i8Lwُ|6d,ʌHBu`~D@ZrQ$:?{)i!#r}d}w?bPEsTXk;o ⮪cpCMUx7]ڬpa{2!x9گxɿAA:УbOendstream endobj 702 0 obj << /Filter /FlateDecode /Length 5446 >> stream x\Isq ̃hվȾ($9@6b!g띙Uݝ=<6՚˗KǍFob@l.>Hu;|w -H9EkA*7NBGVN.oTv{{x$wGbrBOc4lS;]6wzR=>|MGFwb -l+lT8e\ĘYZ\,/q'%ب }? f9T})@ҮO`F(cpJ?7| h$dq[ΰ N?ux 8f۴ԆC.+Rĥk;f2Ĵ#1oV%BaU?ia&H{lаFU]R;^Ϋ"겝բ<e ]J.:Wa spo8Oi`L}CeD٪1( qv3ɜL0z{yz̚+SJ)z4C&ӡ%lTZ*>UL$N&:⧝iUI36|#+ ~wMFO>J_tǢ0jbT`YX_jt~HQmߓw@bii rȈ&4ls|Ş/`PšR˒ID ~Yk W!Pu㓪JRpj}H]Pr, ЅBQ{($R`jHCdEWIlhPz`Jă5~F JƗǤɿ4ʘ,nO>;Z%9H{d}c˗4A|sF׈vDKu(u0Ac!mQ% b@N&KhP`{>2%r = !LԸ872 ?4z qv2nTc0_4l׺IͼF¡ I:,r8sYc ~:[`D;KfҋZ%јi(xx<x3 n;2 H0r+aG e\#%Ƒ|*WPqS3_3ڹ+]AX\Z)va+&'=0 ~bi,$>å],y=뼅8$?_vʓ $I^K3ֳ(N# ~V΢1@(.EINl1ƢS%lH7uu-K$3;u 3ǧ]95pVj8uЋV9Z؜ۋE7a>Ŵ6qdA{ Oddy g~D>6 Rds,FDdm.CxW7Y.r 0`+t:B#f6wi677O~~mwyzLNXZM@K9S~ ͙-Xz#:sM-5',7%v0WnނTqWlU4s JA3{DF˯Jxl<b< ODBٚ͑2ט@^]] F24jB$VUUPܐ_ ߔE;Į⦜Y+݇uuuO)ޏ)f/TH<➑d\.P Lv*`ZS;֬'V* pbU̎I8$5P[&L or1cNR\@hKSͭ]HIHQLfނUB:yJ2Yөa1G20['ɮLP^~] nIEl&`kavt5_ኖbũχHU~4sv0 tq1*+1Y>cHޙkd6 ш  u*,}\gBaMx&3F̧YC>in^:> v4vqQEx^5S /Aw~M4b5՞!(2{UB1wV9 M(E .+YK=WlR%B a A^hs V}R6k .'64z%UItbִ f!w'$3V"croɏ=^/)d# UWaM:-:E!ҽ8]Jn@0*! l﹨$Rz L(m1)цq/pZX0$qD׬j@;I&2\Ph\ e^0*s#4$Dz8諎9N5&d VRqm>ΗZYX͒pab8AuE`|~>FxܷW {L8ި5ĥcuDZ#2_*wMs"Sb)aA IƋ4(~Z]8d0q#jCTIz_NwdTS9D%K=geaTRf)]k*Q5i -בc&<,ck}>ɨC``H}57z(+0[}@2D;9"Hd4G)KzUR{Anቺ"ԄUׯWX؍O*XwέSGey>\Ux]nؤy-}saWDqJi f UgБ+sCaѰ\V0X54ÎH4<0'1[~krcV5_6Bi=ƒG9௤+0f,]`x X l:J2mzy=15M %@//Dno(2^Z],{qQ ݛ Qͳ DhS_n}yrNZ_)orP~5_+iR`kü<ԏ(MVL]TMu@B+n>׆r;dw~?xiFl2>ecp=ō@k~_5'mWK^G1ɼp|tL߼v7;79a(UP("'E+čz%F/CT#-jWBM-*5OsaZNjRL2]t<I?o[]41+\F2]c8K˜a9#UcһD+6 ˷n鬐pH/܈9}vj̒=5v& ]}hy+V~׵sp@'fdZ~"VvGTekq>u(^>̹~[MX\ݩ1-=\h^_mC[q׫02GE!NM:Y^9M*L"G(tJ߀n)-9P&۷_w͵64<ў/M71s H1k:nEd4:݂Aʽ .*p6y{ SBm}s`BKc] 7]GGőX+Xֆ>7>{D, zԞ<4OĠ$,iJ1*aܾacZMf^/'1`;*J~l륁mAgt[@GEWi^*D%wR3l@|Ȁc|Īʈ_,]-rF~뼌/-seo@S-^$uQL =3k j+_ *]H9V8ŢeL'yx1iH,,&Msu8&|;w+vCˆ^ }!8ˡb'6aTn" 'b-křfsukYͤbR']~aF+2e+_iBY^0|ާú]"S$Z#}>Ӈn0KػV"s(}Wy*__f7:1V׶g朷“AA^CM)h5R_xA mR"g%< x9nnS >ޞҁHƍ.C" ^V2q ~# Ág^\`DniLˇ=":cm3w; aM/.Mh`r{8LFxrm|4 WICLy8הocB (dwk| JSO5tX`~PKSV*0ZT}4}B똝%N>4:@6rNʎLUaaO`eu:`׃SZSۋ™.ڜ0ڞ'`_/>Gow!L}Y {;kp4>'A,FIHi=[GT qz1{DQا{KkHHvS$Y-pިY&l CA6QFSfb=~ka삘?߶X*SxxOG7+~~>|z13VdFkx!:t wt,fp^x2q' -bl*T13ғ=ϋё!sc"5։@n~y}M(( trd.u^PHNլ5LlxqygIp$<#Ŋ|42k'c\OtcrRl~K1 c*yg>?Xendstream endobj 703 0 obj << /Filter /FlateDecode /Length 6642 >> stream x]Yo$Gr~'# 6ca=Ȑ6ڑ caٻNysWVޞWjW1zus򧡜Yc%Ͼ ><:^Úpg\lJ^~~`;N_9 E.c3yuv^9jni.\G՘p{q>T;q+k(g.TbkusmCt#ĆD?P3=.|sMpzx,#zx.[{,x[u|1mC[(i eÑ+\Blw߲-4{Au-lOw]C%w:kDz-u ^1a #c@872ٍY"Ohԣ?ލע[wDŇui̥ᯧ1ĺ@e#8iWNp3"n,D[unm M{~9[3S3.i.wmZ2[]?SSRÏݐg|59 33LH['"n͎&^ٲCn'(P% xM`E=?Q,K-ߝN[H}[#A̮){ /bJȮ4# G @u9 ue$q{暂!  Dh[7AQkdsY$,r;ׇ'>1QV) Iae 0u5VX 㯧Vғe7q"2tBbD6˔{ 3,{@% qzg}ϻg)54 R pz#N$謤Ybt3Ih2rSQh3^z⽶1INLB[h#f⒎-c+> Y!u,JK!;͆lJVkn{7}M`m'ؤ~=رOOɫY)*,=a‰/ ˗14ɇjvZ87 n~> ױ[2=o}+;nNSٺ:BAo{u0}VDR xKC`.~"YOsucػjwlŞ&Ǝzm(z/oS Oԗrؑw7z^3j29YJ2Pe,[`SP==7"r Ф} F0zD/8Ӿ}Dl]gF)$'L5|L7['ٗygk=Y4E!ꏆS _jy_ұ\/Z~vYGm)RL?NN+wG[ɫXc %0-.#7&C`'qټzncH:\o^ߟpsq^!gnx{J.`8\<npq=|syl_wv7~%?Eqho۫۫ٶ7~I:w 8)BF@# D3?lnsh}b}s}z}qOas;?Lo"*hzw}M.o.=l.{ܽi{tG2; K`kyFv?W'iպ @ w'exJāFw-'|in?f$+JinzAߛ[^уmkn{@z/5U%#47u %hGH2 'L^L>*- Lwg̅I0(g+̺6wo?vD WrjLtV axEX8E+0"yPh 9z-sQDS y wS!xL[%bƿ:02FAUVxdր1qzKEP`BYS`TteI_LTQDfJАN΃O,@t* z𣘫*!4$(:Qev]BnU1FgPU!4Z:@ q10Fe23lt* X6rF_@3LO&5b )pP1ŇfTfT jG/qw F^yqAcUE#v#%qӯ@aBw9ꄴ-DZ舝(Lb6z 7$'B%(o4㪗:YEO&x#:<Ƚ$fjH"STo@ia}]ie0N6b*9jE:J|fU:`*$8/I܍Y[%Oq7UԪ;Ŵ,=W N H.\@ b¨d%ƚצ KV!L\)YE4.PjR_+Cj<*xu +CdJ֎c⸋r^< 'XzLDV*u8F,%ϔTvJdeZ+uh2O*ld :l"T2b\bp6u%b5XVXpp:G/ҁL DoG" h1ٕ^ty4)%StFtZcɥ$s*{a Xz,͞Hv12:x4)JfՉrDAXSF'`yKH - vW(uKm+Q'v˔'A$5Bd D0Lc Fa1I$bWDŽ,~ yCVȔ\%Lr%Ht/`TOT,$D$R?#WJ}U(E=^RijFr_k{m:Jkǽ4kB'5i, XCWBy``+WZφ}X+v-}wZN.ɰ:3& NVTd檛yH"@/ _^6Mu4p}ң?o<\>l/?W> ۫,J`-<.;@m MmM''/2W?0!cT*^# I3!*( f/\O.t){#YNW[U̦RIH 􈧧aARN%Hd3bdGKU¶nv*[ȟ@*a EB)K*fUR,ý/xJZN ŧv`J#y/JKg{N_ku*9}00+|Q0JnT7lou  ˢ$'r9 y.*-2cJv%$5kr8BK!mD/OQ*\YحbPsD#ȻBJ F`>2*OԠPd{'9 Yxbz Y[_%\%;:qR0b&%Ih_ccĥN) -$|nd֪lr]d@:l-yXѪP"YeVe2h+[bGN:ؖ[F1ICQɘ dV<$C) (-h8;@ݪ%+O3Fi;=tV;0HNׅ鰬BQ5 HJJ ApX*wDcPBSi$5deC*c^ʀynf 'uSiyQc AMQJW~25s j&TYZ(2 &T64Y'0Z>) -sB{D#e6\Å4L@TxXeAǺEYLU::t(#/ -PQ>: 6]9*n=Ll̚5'3,ē@4mT8e+m`vuoh%ϹcLJ;~Y$t@%B_ZҼ%wwwkJ^-9)m&ݽ? roy*PCyy5 go&<{@ t @ ޹a0`\1R^\opw;Ԯmyj [RjnNcvzyZ[]!uy%n\BuOYſ\y~{zrV7a\ y<3dyxl`;VTV<\9|xf/_ܮ܎g2LYmj ~z]ˤ0j̣.þ@Ӡd3a֝5R!|EJ;o7]=~_:7WJ4lnz"mS?nnaݻo7BWAA|vVȷ{okW&T5 n8#C`$m3y ]m77> ڇ2c!mnㄢb,| vD4lD** Ԑ,BD^Sz|j坾D eO{~yFO)$Ų~ {rI݌2nϼa)F>gr;^Y/?9+ |zVsdAqy1M} [bڙI fSWyB!=u}Ew51@hMIC˒I3EޤZ5w[?pyt5ƞn'1hbfR~Qt$wG2`^<8@f#i#>ya&nDN o> stream xfy7䙯9zëދa ,,fy4cR1}vypKVl֒λ;g`?Xs^5=o$5zgM"|ͽ wd%> )zY)L)q:7as?xiH+xZ:dC!fZͽ^ (-r"Ũ 󫓟N؞'z1ƅ襼}PLp wJ1u\%8'=PKH$N.XZo*UPה<G&z=o+wdKr*%"@s GZ`%20FF- r.K!*+ >cm:^ 0W{D1OG96@D:!g4I+-{D' Q ݥ.$ɿj eyVJCWϘ$:T޷@/hC_LE9hj`s3JO#cFv- tjh6FO=+ah0Vhv]t`>֨ u0iu.~BlY E9QT1Lv: lp%sboa9?hr&J;.&鸘e.*øW}%w"4?- ǁɭvT?‚w$,ƆIhlӈ`seAec~˃F>@TkQ݉~$q@NNRK}CBV9\IKjJ$lv 1@W-ѿTjcpcJ0y͋r& zS\wRE"E/ZkjT &2זMB~Om`yo,tZ F\A XU^ UNNQ'N֎_B:]OKB.0Nr#oj"(,"!<'HTvB.-pgJ^D=x4|ԅ/:s_&m [&fMQG EzMku%V@f |$cmf !Mb ȣPUg~2ĿR==oG,4HJBlty1 ҆] XL="4cUR¨bL%nSZ@긜"wS R@, ` tKR Q@XM (KCm+Bqwڠ!`r UgAfξD1 CUjcw]Jmjwp#b&sR 2|D)}T;FgG'=LgpOL(dq\BgIq8P/Sr!qrOb[{4[;hI7q͝BXN!)o`X5ОRJa_-{YI^M)Di*Ks5]J+2&K1lmX';cS,UİCVmpѧCƴs'S! QS^t>--n _ Pdm B+IazKw8ZԹm5`'5\#Nu$`yRrjmJU3 DKJ E<"(n >ϗ(MiLxqW/2LXBi `}y\-A 5gM5Qw9Sňi1t+IZdGTfVr͔/03{0igDW”1}a bk;W/KB}bE\< ]K;NvXf˸5*C&ѫ>3!oYM9>?%}kojK$0><́56I_ +ؗJE2UuJz%Yԇb6}g%X2|O&sR:Y r©]w 4Iz,AVd2 ZJ@J#hY0gXieH@xDU׃-6QJYSDz/-=b`Kۊph@ 4NwH#CIQ@Kq*/k, σ*|Egą-Gf54@?^胞Ӌ<_l w }t~mٍ!} ْBMӭH͌!s&dw9}v.L_w.ŔyY3KU*q6 Yf]:?ʹjQңG˧R G<c&q=g/`hqyrD|pKͨ4sސux5Ƙ}?8|sAߢZ*uvw3. /jhm)\x`pa6m0}9%Xfs1`GaJZȱdflӀŒ_ FoZʉBkO^T/@P[c& /xgܭ{xkqg{m )کU:^H$L Tǩ"w +˃]0?TFo0F\E)tBο cB0$VSӞ{sLDBaDɱ&)b̭W(3W+![9MCO7M3JG mC*5 r!m[F ]_kEt-۠Q!gTܭEגFX-׿>c{n\ 3 VҹZ2:S0Ô,/5rrάuyLMQٻ_ /j'.BJә"|pNeٱI0lא\+ ^Rn7 c 4 *ˈ' cRrnn!tc~Oug5 T'[P,ib_`Uffb(HK3XTvEBvB:?89\]heeCK[K!!MBд9l! <q({z\jCM+?ZB& 5~T"e[C!rG;t_vUv%HH=Q\ /A!2g \d2BT_Urſ.{w;#XU7J_9\Տl9mN0ŹJ)BA2 }8s1ZN  FyGV;XJÒ#b 0 ^UlTD+(lQ׀^ImF(=BM R"="™&{L4Do:I"`,2T!4(:!":@wBPMR"?$EA*QfzQV iD".kQxNVU#ܣFD q /UOOE} 3}¿'7s\i^ eHrnL~zx:_OjnG^OqOkl_}t 7y OiBix #n<ơa4ôF8̈rn7Wf{6ΧNw}3&uz29^Dz&)A*NN a> q^oqF*~?_ap!m> stream x\Is%q^k=AZfH F btowfm5f`*i5+/=ݿxc{?q~fwGbONkt}'&7OG7{|w`ĘۃC6iћC,ӛ'ggy:8k#65)6W.t=$$:gn@00a1i‚S 97qa3+xcX916deg`%a5Ɂ'˵\mttКXTy"ҙhtLjyLzv+G@ f&X .GGC_әF+h,L7:qDw {? ?jRJ@t߇Uvya;Mx 1R,݇UZZ~OdF)K?jr cR\j_Tz<..^քk8ghEeљ  : DZbZfcQ/P̯[ApОDŽuAt10bCE "31\7?Ic{Fa5cDZ;x9 1^~ ʦ O ?UdoIτe Of_P-Cn0Zm_S7QAVO(JBÝN97l/a;'Ƶʈ&oM;Ex3rţbK2B>`k{']~˃9<[KТ*ʍ| /A 1a6]UbV+F29 ׇq!vJF~;N_ɠe8L˜iM| :[5p %'ۡϔ':h%7Y I=^$ܿ6 yv7: /`hdZC $s8!9c }CJ>B{߄:Q߅<+ nHȪS}poߒx0!a {B*&1!?ku wr^jSc ^J>%z핰&)p8DOHO64/mCyd1A*@@;+U9@E8[8X@hD-|~1qdhݙmzh12OՄq/D4 `l[f{n':1)9?w9XYF۩(I$i=_& a@[hA]AL}&'` M]t^LV W|$|y(G7 k-U$> v@Ʈuܧ/!B R*/FH d #ia_Z9 9t؛YYrlTImx c^ -JM "#%CF2n륞]Ʊ$xR?ՄF"{_+MYN\xu#)wz)F— 虃җVN:v4kN]59B {/VTkMr0>#k0k]Mʲ)o#yp;o;:\a M" ۙ,%[`aLMWkzB91xSFhDT)G]X=3 ϝAEgHvЦ@ge\CeT ]2V>˜& Kʩw]{NU LY;qiВo0=&>>Hszxݞ><]{ހ xvv-KM}w}W:|߅vtSvN?7y-7__]\>F8p̰l~ Yޣ/way%C 2C c} ޛ[87 ci2sƹ͇^ HKW{_oXȕ`Q-c>%B-ŴU)ǰNrDqUR$V/siM_0C&TyF 4Et#~TP+hdr)t:X! C1;7XM_MfJ5ĒVfB%;~$twPNB񜬵Ckh<:ߑU_9TRZ kM0;3daÛ/{evǒ305sFDWYy_๓A&L]f3tH-/I$) ~v1+B_j*Y{ƨ\"Y]I$6j&" 1zIR K]cw|W&Nx؋`]f89{)}!{̭'GעvSc,8xeU~J_c*yW\M<=ޟ/2%=Y9E@TCgFʈCv=7g1[8>]8k5%%@VZ@G z-=UT;|^znO/&GRN[̔lSzMO9JB~ Q[iPxՇYZ`WUչ ÒUJp 5㋴!Wq P*}8;üނǪ&fl}DzRaQ.:Uw8>"CTZ||E⅓tYh.|`IrΖxLTP'+ջEÜM_ͥUj>z㈪6N*[C"F98vj {-4"'=ܫƮÞ0@'g+|0{ݠYjW[7b濈^ǐ j?s Z#*b\趰aIbg⏦Ek %nM ,łm,/Pxe$|ʘ*.чl 1,>+sFغT2d٘9UbY@3gmt{LL\:Kbj-BKS^N jVJ4]n' /nI%TxȏڠhnЍ\f^\֕Ws!iswFLRuحdӥ*uhFFFq:%Ni ڝb}nGP|9.WDJ`Z~_WҲ3Vƕ뮾!^ĶoX[=qx.x94L+HU8@S*eMxnbUu]B ~)bLA&ZE"t{s ѤywhAI6N *Ve1_$됮s)nR n;rmyן#"_-? K~ UIQ-rkjUZOobc!1lU4}dW!B*o1%y?XP=k$ZEV Rq+'lrggs/}5W{wXa1gTP8fU}ҥ!U7&Z7wi*v\N2rnunu"#oSuf/B]5𽗵tsT;yEH7]FC3pqU1 Az~*QN@^D ܖU#_MW?Smhr9 Q8o7>m)2y>ԟ-Sendstream endobj 706 0 obj << /Filter /FlateDecode /Length 6229 >> stream x=n$Gr/jbmڅ x IhqwFDfUUK @ӬʌȌL,L˻Wچ_~|%۳ٟޤNIDkٛ^ѫ,E(ϼݫo/K p~!bqB೏DsNXՐ{x,!^D0J(o4pT~qRBHS~d  R0@3Dw)Oy~[FU-ȇ-s>}wE׉ٔyח{щwixbo~*;-w:,^D$oI7 _7^.' 1aÿڸՙ%uKF+>a^"Qf1Dc@'C6:bZM$p?~d"enoϭ8MǨ_LbsL9Se?ii`;prD5Haÿ1@R%ZXHFY@.fLa{陏jW8ʠ!_N+piNeo)*a\ iNwvQcZ܁@?i%h)$;&Pۍlsn)Kt{Jo,e~=_ Z|'xN\{"TTC#R5JɴH]AHs˜eyr6QLˆcPq w B+b=;9U$?t'@ lsLǨmv x@YOn\NQ&rkCKbHNg &LZ)Sޏ3o㿛$zD"xjL6ZH25`[3 ٮu@Ox517-wc`Y"}\ h8]N(o8|?KISI a0+Bqg| Z`Z|koLo<\2ϐ3$ಽaM:yaL+@T=bkT']I\ L^pSCCKiad >MٶtVy`ɍNJYҟ@_7~FQ -xWCsQm@ DocJkBt#v.*=}͞KrN}Yb> ؑMb.'k|M;)G7;|'Gm6eҥg/l,a.]pAP mwӄR?< ᭷+MϻIPI CE;ٙt}ĀSD0Vl|X޳\1<|MfVǜ-Yキ& O;0y(_E;Y(xY*hё=MS7aۚ: B]/ 1vB>##u"'M'@0@s8gdbt`ÿ v`yΙS{$cC*Gw0z{O v]P=M"skҼS0ZDԞdZn^0¿ iG,G޶SJx m+ z=0:<Af»flQa(#0L灏y =-W):8?4^б>vHB[e}ƣXqpegZ&^Q(ܽ[ 3Ao  *Z!ߞْP4} w32o`FQNPzE+?^8<ie$^HGu_|4NOFJ{Ko"C1~.-`H t0kOGUTø.EsY77|50ZI'**'KW$!Mի7MUl!r(3{IKΣj].ax2gU&喯Z$Wm8 , hlUeM3d\%I>]ZK$T]d dԒuRu`&O JZ9;4Dkp xID5Z{ [Im BYbyTezc =A`U ʩL`OJƆ\,p0g{5`e&zA7!Nd撙Jj* ssz.ʵrRjhBe0B-5s}O՛whPHLIVX,ABG; Mʣ󑞪cgF 2Abup gzG`!t3l$1yCf\ ռ/#P|!Я3%iüL.'6 BDmN5aՅ8%g3XG10 ^d &?しIcI"!O&Lm^~uwm$ɃA;YD*uwQkz59ZD);/rI(EJ;s`yJbXV7ap(x#1.7 eM+g&cth-d0yi$p >0̍yI@V{ h;m_fɃ9ik깜֮SR\]*Fn-SUMdSGyU0 107*=þh.yy/; x+F5֖tV)D$d߲^ c uKQP)Up%%ydDQܭzraƚ Z)c-];F0\5A"aIXba\bSK3O\ yކ )*<^5%豓 L*5GcSs7̻CJ1(iqB c9FlҚPޑUk|Rjb^v{qޭ̶nxAEŭ-Udye keCAIܪoSSL\U<2wiXӟgyc;N!Fށ (+TZGiM (%H ./e|ݫޯ%P _*;k +kQ mU6g!`+/y XL^ /S<fM {|V?󿍙(pgjMp+ - 04*Wu˱N;U|*M ̎eE~bOUڍ/*dh0J'g_jUo{:Г]l2DXifpK}FJ kBvhjQ2I3NeE0\ ڸ\QĮ`D^%[FRw4N 9Gi"w )+q {|&37 $"i}b-Mp0~ /TGYX6i (@.3ѥfu?dVH mnY?JTpպdJTBߺvvܷy2nۤq/P&oVR~ph0V3Hݜ0g^G52(7 ;Q3PwNl9ެ]ߡ `zWAҳ`>ޗ!5mG}ɍ7jzgAwQk3ѠI1f9c%my,FKɣB89Iݚ\$_*"ZmSIrEY)r{`wt(E;4O1ݚñ(R؉%Ci52E"N+.p D[#Vm$uaM֬g]--'<~C%O]rh@kT = םiW%%9^lw+ ʉ_(I<[ w-τYQr$fyXXwRZeK6<4d=\r?l <}`Лo $ GnL %邘@_* ϊ鶱:ESP_F$mւml˛W{E?_l,3~=[ˀU{/2%} ;?3endstream endobj 707 0 obj << /Filter /FlateDecode /Length 5947 >> stream x]Isq#sуbܵW'HCЃơ̬{ (ٯ\\ ys2rA]ޜ+haͩ`<}$~*N/*Sgg^Y%-Æe=>?avywgʙzȅ}V-b߰oY-jq vg]FTVi९׉ { }HJev|b3kϩ)owrJ\'-j矆8l<% ?zqnxH9 as"U(xcڕ䳾b5>1&|6KN 3ґA5#=-d/ftLyX+(Bn*c~4J &N )HILNu/,"[I T3|ޙh;x'&٫Y ̴q.UGw} DqU*6|&xJMكQnvXE; ֪KO-֩g԰1ZW|xBj?(7!C GC4;P5f1p2N4;FD 4v%%Q:TnfQkB-gk|FlP! )Kte\10YR8{BVlV®`n2OLPgD(.,5D}d^'_i RseC`TfFOq` IV hyO95c8X{li~$ ,k؍;Ce@KZ{cw 0_^A]ÐJ{rr3P@/\[l-ўH9^Pڒ` >FPa`ZyOCv }\ 5W@%i!N]޳>XdWz>tfQTcQ٧U32oǽs[2K͓.d(èPM?y+2P+!z>D P(˚rg-2^8?Θ !8xu-s5n]]Dm'=S/2=J TF3'oag6$|2jŕzך]t@_2L(>NX|m+v]?IζP{$Av5f[1j%ɛPеRM/8MA"ۨ}Ec.UkO kdBc7AX#~i38İ 2 J09\, &aW70BQ &ӈlNri1oM,fSՌ[Ui4hF":g{$Bŗ111 3C,e(|yG@r!ZD̔@JmvA|| luzf泉b-I&p0l)z„b3Qnq%a*- 1FM$QNEıA:ZxƕDס75mEV0qf⡦4<{OM2de ^sx:Ep`d?fsh jƸ-g)N=՛_&j@*ois heP? btu " ^jbݪ*^rXiUS|CP1]*+K߮};r 'ڝ!+ q (@߹幏!5yόϹ9\iLrmlP4ֱHzVy,%d)tҐ_I,݆=@zޑ>+O9Q/tV[MlRΊu< gy؃]c3k5M^ U!5K_0תԄ5F.]I.yH⻫0E:3*1Y-*Y9NPњ?|YB/Y\!sJmymBP" 6Kv6:51 n'G)]bpbLNԾ o!N]| Vzy"BX7E]ĎP3W9u;vWXo 5r2jr?qqCŖu(R=}t5]|m¤aX4{ydRrWHNyB{EPw|#hq]WGNfw շQp)peʸh=J&P.(ߙ,[cS==~A=2+iBvE:]~WƁdawM<='C}].mKK]Zv27W"KalɍezD@Gy?wٟ-IDQf9'uKVm\`ѯu9tu(VluGFG൐r!MFR#t!2< h){ilY>Q[a)ZWʹ:b-46NxGb"Ѧ\>5 ;?lE\H; D͜OItXLU-jh{^}BBɘ:16k puXs8UU]Ѵ-XDcBNLAQO8 r/ ;6O+2G,T7|<}ЕHH񪵹WAiD@^L/$G7{PE *Xk9D>.:SYu:G$Ay7-J{鮴A(nn] h֩utRq'YMo.;8(+5굑&31G^P@hR{|l,bJ6a 浞ok(B_]BszC&ݑ7BݡX+螸X ttQӃj `囻vi[Ztױ4BDtGWsGnʨ!˵ &U}0n@,/KEybIF~TSf-f.^7<,!f̴ __gжŞޤhE֪1[kbs%PbE,+3ngŚr55ѧs`zD̀q G$({'tW'"LjSbt 9<JEA<.\䧪dǗɌ2:uH#u=,\r~k71 qВa#XSD ǫ<vd2v#cO"1%Jޜ[W.[ nYc1Reg~j0tH;Y|Tw@=$|?ś)ıcϭiZW+}= ]*&4zu=~)u7N$]=["a O :`GI?-3jdHIC0W~'(hjiJO eJqJq$.La~?лwƀ[|hN6u_r6+1σ7b]8V u5Kϱ1endstream endobj 708 0 obj << /Filter /FlateDecode /Length 4303 >> stream x[moHrˏ|7{#\E3 KGqoOUu7Y$e{vء~~Ӭ*Ŭ߾7vpf?]: ,g Q:cO3kJ91k(kgg7*mŧ(u).MV8svqNզ81 sRsJa,*eb?+tbшoZ$|V v 8{O8'YS8ڕUeA TU#[I%iU2iLK/^F>chHP0Ax1C |簻p$m؈~gQ*ؔ1QwűkJ f8J*3x(#Q7s+J G–6 H!ZV(Hh| Y<xI زsu@` yK~ Hc~Zұ=xp~sLltŃ {o)#Hl|F{4@uÆ3(?fݖt]:BOa. C7=.ɿ`:!7TSiؾ5)ަ ^oFU2#s;gy8Ҡ4Z/hm r@#\K ,6IkE$}\2޾7V[(p4bٛnrrwڄEnO~HC fSS.{&S$yX8 Kps[MChOP &٠ZA4oYg@l?f<"|KtJ =soL$:ϯvecqO&wk•,p~H\2V_*Wi5H'|^R:ھb Y7^!s;+Q!"?=:8^ $4C#Ƀ݀ru$[WV T OB80*pR趀L@TN2Ld $LzJFr&ъ 9"<NwiG-F cun0l?"߅_?5! KZ*G1PuM8lۇrt4RuWYOiiO1Xqn7ˇ햖>^ (DPfvE$}.c{;B Omaabaݖ/_i׏kf}oY?2?\_/DV{&]Hy nRCOӦ%ʐv[THK|'n zV!J~ v;ǰNy޷ח[fHO",j/牀f?.SS1]+ ;ַRey8WfmL.Q=>mN~WCgXqM- X'aLq ],?by8,# n':/6$oz v#Zs+|"BPpFnmL&v ;Ow%A/v+~H yv53̳ɷ74M$ pD>H!27^D"|+Z( G.#&byemтZl俹Xjrۓ܀bX lr8=JDxWám]yqAw´G`Z mfME)EﺢJVB 4O'1c>=KT$ck ֞V~jL"$Y}k"jV#lBP$6Ŷw}9I<1}a%-0_J\HХucSOx5+)4L;:dg98ۚꔾ4 !^#dSD2_ЍvEUi#GjFN4ь**of#D&V3AVza;W㜜.3S^UE>^[኎@)xy 4luV"eP>X_I<֓$նRϝ_)Y0}Mq5niMEHe^CEE<=ڿ**oJIF 8ʻ|ݬ%¨ se׈a뛴ٙ.u/m:jmG 1y օ\ES3HLDhUUUeRMW::5<{"s*w< V\E.H=%SzMX/>sm]o֦!Z^-AQOƛo;OqĶ~ n& %l@u{*<@ _V~Of$";(}pe ԊZ&4R@Ӟߙ*M_e> 0Aw MTt3toզ6Pct %Eb\4ש# i|Y'!B5Q{L;fD6T] y`w~Q8qXU'W?ϩ D׆M]tb{A|߭@^CPzLx~R5%GDFobPv5 }zbYb\E*҂2l«\L 8GWR[i]×p}5Dzg/$gL*'jᏈi c|-X89\)7]Xh+c<{ O8]DLN ܠ) ܑ骬1K5mbAd8u%>\lэ=C#>nث+5+Ab_i0ê.av97w)5ry^$Gu%sr5 &~]VE5I:IɨKwRNs{~R6y'Ul5dMvo7tZ!N )0>e0q B*5vw:!q4;޺3O;,F(NAu?T6^9_8+ Oo}alCFq7"&~Y'hԫ~Lladžl-*#-E+MuM4G1ۦnR_=de7PxX~ l` ofhOV Q;mPƣj^~Kj=OYjKJYk./5"~N~M/jԳLsY>0R&Ɲ-4-cO߰!]Rjo֡Cs)y|A3ozP}DxhFZ㱄w!y S?$.EU.{;]*˞jϡ@C2hik,0&m8z20KfL7sd?_<|jyNRT  i/Di@ Cۍo\ys̏/V+~ˌ…]iBM@T.m}b6Sxn7Pj3u/&03Ɛ-h08}1א93;"+̑ /nA JP,BޘҶ45|Gendstream endobj 709 0 obj << /Filter /FlateDecode /Length 3845 >> stream x[]f\2p4Ma}A?A>j8K:;{gHK vp8OM7z;2㤙NO: N| #2V[f⧲Qu#,ښvꪚ͛4ֳ9>W3Z+ߑ9hq%v&Z1=SM#8Gqa!xihXE 6ڒ0D0c _aVT? הrfɏWM[-8pދ";d06R2/8ȭs s]kFё@XѰ~5Bj-b[Q ~H L2O% yKA,5ek %<)? yGߦFH N[ Lɚa"1ܒg;1mq;dtV\ڬ7o@#.=aVPfw?,v+Xop6Yq=j8]U_n_Λ?ᑉ/鰾> 0|qaqu6۫oru8^ͮff( ֈ=7Ɲ]{vwWb<\V tX\.h8 Y + YgT{ߡ[CIe T1TogB+oTI dd~Ujfv؋sݹT3}QCPFޗlf ƹ]1 +:B9$v?E_B>ݶ6 e5݈10F| pFTH2T4QАql}\0Yk;>`^& +J@s QR`oZ8!Hݰ P^zl:9{hz# js+~̷hD\DztyZpk=_38M.(4":z6Q+j! [FT8t 0P C1°[XnO*#D`#5u!7;D0᩷QF6H%w@lfm;U- NTCпYr倞cL$61Oc+HEW)Gyg&Ջ0 UWqى̈r"r"zQ_8lwIF QG*8nof]R*m Pލ3}ghm2 R6BIigδ#zB _J*h{nJ\TvmE 6@\ZALv`U~EJKqc) Z2Y[-5},EA-a. a`9{Odzh_nAayN _ga2bR HT)LǬ?40 Z_ Cpm*WW_;jjmrD|,5F kPc"&'y&c Suή9k˻b hm\Ƃ[æ Z?9FkQ2Sk(:&9"e@Lz+Å*="'|J0\TpQ 7/FibTeۛj, ]G2n,4j@(t[ h]YG?w%^xU`A~5k kCD$;h!(v>I4ᇙapJd'hU`a'n/A C͓:mZ['4м<_#4ua P:&`cq$c(xHئ!DB:}Kx27ug߿)U!J%Up*QmI$< Q%y ^6Pْ  t+q,f߅0koci|pH@,ObePa}[IQAgsRp:o|LGQJVifqor6>qC!Y`@%~<,/ڬw_i}z] ]Y<{(luwXp^W775 ?s"Ӆbt.Ű>;S7x'i'+/ɋBixF̙C"f0 jI>h8k|{X.1TyWϿiGZVn%\wVY"pU ` \wXȵB8B?0>!Rk㧳= =B9An7>nB});! %5T vW߿ɣdSy]tiKOiƌ;aOR6<_&2Ȳ[iL_hTERY9\cLkNQu^C gJ0#*#Dclii*:[6;fKx,Sܝ7%6ygnDw"UbCRʠ;ckBBhG}@f#ʇ:zŤY@=X2LR]uaa_`Xj+^F4dwˆk'׷FWSg3\lw u%;%Z9,Kc$A"FsҬ-dt@6rx3ptJbhlJCPuN`2hɾ=ճwB//6HE Qm3T6chR8Nl_5Zn#qϹp5|\ 0j]A1٠'>8l.]2KotCINϻ/Z {`ZpwW ` EhfK>J=!8tnTͅoRBy5/'endstream endobj 710 0 obj << /Filter /FlateDecode /Length 4056 >> stream x[Y~ʏ`)0%p◤|\qYZ9ޤjKIJ<`,>K1 ϯ=f]f _>~>{wܯzsѫ-gJ_W̨ʹbv> Ƹjk狮]sӼYZ.}$(޴J z~ 4nphӬ<ߒy^kc각LZ#.q:ŵ.ey‰:ܭqq𪱪9ÒbXkIkg K NZiefh̯;(AQq02#\ .j<%” [LQͼ{ʎ=Y|[ t rupg 1R gC8 B8[@ amɽZ|&毋l{]o.7w%+T}:\.G:r1wR ?of A;p4n+@&y "(G{H]A:gPH]FH:כ%6&gh.`Oyj;jcƽ~v~홇λtrMs[ B MI:% 0jc۔oܢ 3[uL5]8w~ػNHB(; z>My6uTax(\iP:R/'?cmvtiV:vVy",E<v(-iF4Wo(E(e4 $+E~1YPmU `1=*,w S(/}vb{[ЂC}ĀR9trwQ&FBP\@/2c&}Ԡ:ق9I:W !@Ky_BRjZLZdw3*+/L=4´CUyJt"/6̱CFcwX>݄S^ x|JO]9uݧSG6o}Rg:[`5T@ڏsI#\>ӟ>Ee6?ZGhSL Z!xZÔ)%Ya)#BMu@`B%p$DL @n!30Y r_z§ip]ȟ}NAq5_YEqϷZ2i#v f'%l8| ($AWL&I#UH;s2S~lgspRdiU3aerb珮rI}6gX}U m`7L)ԣ|ӠnTbYM㞴_)O V*1o2=N$.gY%r\[xh,ABy0ߗS/#s6sAܸCZĄnH;>7 %;2$d|?׻!dp޶rnAKoo箮%ُYa+^A9^8\XBе%*ˎݫy6WZ"r3#MC|3vǭD9a3<p*m ?=Yƻ"̡W\1 .O8[Z_%HſVu1?;B~#İ1Z#MCkHh&$ʟG\(|Nk][C ;v E^w=N)[`V 1;Q?۸! Io~ OFRW 9$?Q1=$jsa|y"T 'C?k}wsX,_V/o㩀͕{= X/*Qǩ6G]KJSv˻B2`6Sh&;O /գo't]p&W%ABIMj9 9'?MA^0^b"W!MV}Ny9O$EqIu<'d'bKD%SX 5QNWV߁B=| (Y/ h ?K4a3GD#Y+b5 vl-10ޓP=A?9.U^y">ti5wl?@mLNP;ݗ:/6C"bX#jD(G짒sF+ϛha~nѡrVzj|e݅Jq%/<~ͺl,l DԆj{S3 cwyb^zH$EKׂmӶ־*N8* ?@}7v <((| dM6XBF/FHjµ5_  2e^"MaY2tj껌q1"Y,thCf ¢ j;sXkQ&0~kĽKʚ"#`QI^X'Opb{֗7mWlbc?aI v'@èb\ UT*To XwM.3HlQz&ptApB!> stream x[Kɍ(+lc<^003CK]R#벿}?2"2Y7X>2N/O~O'?hw9wW'.=w7'nADuvߟ͘.X`1Ib&:iCiVyV-B 62J(w1QjT )BU uλ:jDZ GbtGޝ:)gw:Yٝ]cH{t³vfTvІ̠?1AfQ{NOh () fw,ج1?K/e$ \& FnÛחgyhii!qU]Z"tIs _fL?Ϩ6VbDEwvh! Q  iFT hlU6֞p23>V>e$[p4!ʼbp3 j}WԮ>EVU 2G3<>6['\k3<2Knv.{8&V,~&cʯƴ"UV:@@'f&JȘ@(a6 RoHu)}b&U+o>VcIifi>MGϤ3Ϥ$gҚg3iM3i YYh}>|.-J1%G<3ͼӥd=D$nEMDL/h(| xAg"jƌ,q(H8o jzKs 6n({1ƠP1M44YR146 u6^9Wv6^yUnZg)u k $w6^EWnZg7lʦ6L$6a76O=߇k1öMtrN$#A=m4wУT`HG zvq2](`JTdt.JoM5 0;|B~oۉ.R3gP2H&upHǢ}v na1?5)'!s~z8(# ,.@4 >mx,[OHR[2'sWm f}՞1%=C0dUqqp|u[dSH8><^W@'7MK/wojL;GbՑ u+8LnvÁ x on^pvMQ7\oJaPyPq^E`o>/҆`_} PV??k|h]`M(A5{4o| o5ߓԀ-7RD2 ulΛsl֖mg>e$32اxhl覼ꓶķkg&MjnFM ],@^eIK4(`_@k#&wT`Xi^Sޝ$b֑ g[D0We8:EMt.>-bJB=EbrҮSB б߉YΗ!^Ӣ_֭ŴrN,FŢ5gn+ 2r1y@+V,hTYH $W2pu`|_ X{ܫc#L;iyzvT29o"!<)RgMfڒ_MZw)vXiOOꦏ瓭@xY695p9!8GOSbJ9%29uz2DTߊ1l,uN\\Zy#hJ:zmy?%M(0$$ccү׏ bnPV)Zkdr:ٲdjL!&r 7/&8Dҋ(+ɯ3AJ(ӭ?nMcsx#iY@*6?(^Q.M'A+'֑~v![XjsdM9{\_\˥C=aJ9$vdTR|odTȁ[Nf?,蓈&<%ǚVnUmc]ܕ \n)^02'ze/COBVRtƆ-B{˂\n1J雐!~Yʘins%,&F6xR9zpQ~(BgQyYu&co[ˋ:ۧyӧGYOM͵vzw)UkR\߯Jh^x;7S 16:پ~uwT 4QBzJ;˷\"2!-|y\~yRK2W6j*aB 9%40cTB}\ |QC^S> y]^m9`bz⤼A,oYWU۳B_ۋg4M?͂0><ۘFEB?Qq5J/r/i=蟢uzY۷>dB݂Ic z_]/JFUblHCϯ-SegftUf0=Ƞ6År㫃ߐD _a\ם3a 'w[1,_y! ԅf0I^gЖѯg_lZDͧݒs`gA-"vneqIv*)x~'g\Џ1jr8{|>FTEp2Won.?5]J˻35{9zxl_dCWֻ}W͑3Bendstream endobj 712 0 obj << /Filter /FlateDecode /Length 4562 >> stream x\Yo~'#nL_3A _bKݕoOU_S}.))ivOm[^[owgOg>=\|#:qXc7gUvU {Śt6n:ct& \Cf k>\33޶1SFNM9Nxk[d'Yam0G*pM`)|zÔL{ 6Fw.ҵʸ6qi$'-ɬҵe a2ZHBt#7lLr{F딷;5 / >;@7e/Yv#"ح#BiULAvTuJYFU31Y $w1H)#gQJ'Wڻy$35Lht<ö0goŎJhdnN_a5Pe?UXx%>ӳp;'O^2ƌѱ d؁Cǯ}JuAGDRQw˺bk3 vUa&)O E7cnOv4⯨yԀk\:ύOAd -\x4$.4QLU5Rfmq#XiN{ׅ%1/}>\U/+FhM&-jLgPpWS6 \ƙqXk`Eu0T/9+!8aY=(u3A^Y3m+bs4響ܲħDXP<͖J&SbEa>S Xt28nu'caF9xAL$dަb-J]w@ s9L7BFsͩ[4 gV`Ha0 n+X賈بpؖFw<%~k2sp H5q\JqC?_G}Cre9_scz 8 ,#@%97H-6]_p8P"r_*KQ$(.oW~`~RN?#Z>SȱQ"fBHZ6&خsAsY\73*٥_7op:8UYP^ kD(n*;k$!I|R dl+ˠAz%HBhv8eKWݰ.PKs? m[6WdX Vk+x#:ե/#:U P&$?i6`PD~#UX_[GBLSb,uo"Z,T ,#`jD 'Pm$9uw߸xnFֿOߥKq)4Sm 8S!_5KTxގм!op1r?3")h.# EPY&DMzghrJ?[0k^k=>pOr8WF͉pskA5Q)!_`c^;>6΅&%"NI}"AZ^8F&3Ӣ7DL S@ʊK%h 'LʱLE-5M4R;QFkuɻ5`y'R`쨙 i:aQMpn lHn,&!# ܨ?^MM0![w&qĭYwr) l7(H \<V$żkrZ;Wit;oXJ# ' D:N"UwD:al|;Y=i+KZmE 4+6 WBHBv! ij\XEB_ ќ5%b_cP4J%-U~Pq1" GtZa (8@%(Iѥr"0^qlr db/gr:bHhD+f<-^}e2 |;U!,"dU 8_QFDQ25{DFZ.zS+)^ Uk5 *Q=l6oTVl 0~$t6:Eє-Uϛ^D}KvGj*,ȵ+ҌOv{.qUgEZzZtZBiČ) xe'PG*IYcFI6f0#4kGk WmhHş+;lWBA)V7ZsG%IQ1GU19WI bm #/։k6^ NeX, (Zo78DtCf{qmCfVtCç/Ac6y[ڌYu0 }*ik͔&5@Ʉ#I?`i8$94!V|F+-45nj%0Ƥ7PagPU5UD,7]I`b3a3 uJUa7#̍nړ7d*^z֍OW^Cf&fL`V:Al5Xc/lLE?8ؘUq-[^Z ZT\NJM~Ѵ+pşMcFa*S6;K)ļS'ˬJńJ++dgֺZXg]?:hڶ1k=moKh:Kפ?(0!%CbBEL4뒶LO-!>/ 9?`O1'R~.VkVs@5mκ+}ϮρweLJj`V;]S1Ѩ};udk]FőZB5*܄20ҹ+v6!1!4W [p)!"6^ rvEsm.T䏳:|s\ﶛ5t7HL~3\“nxymQz(0;knUr5J@R̕d7,!QG+ˁ3o6Vwo ~?l6a7C<,ip{=\vݖw_]NG.v?n^9k__> stream xXKo6oK)"99$k$Sp(퐒ɂ7C~D++W7 Q]..dZ֛Ht ֪jqA[em+t킯VYֆOԟ*! $;[]|WN e..Z & o<-eE!/sNb ϤkbN{)u~Gc GlY>*&h #|ڗжLy{kAhuH,3 '95JFu&Ag{ԤL?"m)%:(- itq5r5:"CD" r1$ ~g`TP@kC*gsY|xRݢ׬xXo" i+HNw}9*%Z~d(:#bzL:i`e ʬ+dq NWE,%ːq P]VL7EK`$P4$KkڍX< P8.0 L7krd$P3m Z|QWD(i>{ʖS!^/8aK:I& TfݸM7pl2ZGfʨek)i n8nvZ8?}rDs↮NxȲE2Ə~)!3jb!)҇qϹ|hyM;:$c tryԣ"FU{D $ގmIL?aT,X8] .T⚖.["bIwC dNaw:t$7]ߏڠJ~t 0\k%wCE`k-D2'gƧ0B}< (b2ݢ #<,QR$#s9n0O%0g贿č Sn'jI}1~Tbj ϥSwf 0|yoH$Lޔ[1^KjpOW 0\_sִegQ+=+&)5M̟J:ݒ Dc>q$כQT Ix lHޜ zF9Je<Ʃb;YV囁8ޏbiqz9u{ &YI==uC%;{1zR! fQ 8O 2!k ;JƩ-Q3=`"N.'~G1ʣAL#K ]ZCXzوwmY׽=&P-s7sу a2@>";\-Nb{#Q5:􈪘cm31rZUm5碻3UtWpe8Cb}ȡ-vo̙ƯL|k,/\zk%00qj]| 10c0b nmendstream endobj 714 0 obj << /Filter /FlateDecode /Length 19436 >> stream x}]%q?b^uhze I6]P`r,=;OfVݾj `7# rg]]'~>^E!ZB}EN"߼݋r齔///==\9KJtPB{M?<wy[|qwaxf:Rެr]r*H/j44R9WY\Ü:g/s2c~z/~SA5%|Z=WxxxW5o!V38;/HDXde* PDǿf"BoCp6xLQ4CfNcK7ڸ1rRidaK1ޥ.5 9 w 0ܥ =Чh8 w)& YF\ mtXI4 9c5J3N޾yhh-Oxlud6E|цbHIӽʫnFHJ{~/LO:LYd.A(kl-^2n7Z?O1dv/o Y _AקC߿x|f'mϰB_jGō_\eB]8W=+X RlC*L)&Ȕb,RvDTj`v5CD&F*B^Q ׇ"SJ0ڳRw3R :H r'UIcT6R <CdʶEK@THJ:~9C (dQ!0=E( bYJ)/^Ɠ' )y DU)r2#XFjJ ߩ"* #J[QU .R4 DCaѣ)0e*c&ZDTJ16\O@3L1VD<&o"*XC7Ȕb4X_JJ)٭T)RdcKMtD*Tf@P"T9J \Cn/^ԯH e'R+T?)EL6Xֹ\hcHJ#v rR5?B: ETj`ψS?<&R"*5{Dђ2FMDu>Hx*P\h`dQ!_/cQ5J9R:}0RU;0'rs*Q1{bH R"*5\!9䉨ژI4"*X c.\'B U G~PTJBETj`yd2NQ)ŠTېw*Ȕ,^W`{M@n-p!_-+BJcC*^)%X󘽉bln cRX}r*3>f2(| J)X"SJ;]Y;AR >*Iʘɕ@c9ʘPDDjbYm6D~"Rc.c"􉨔bd,#B̀t'RAg2L)dNQ)ŚӝʺUGf*P׹VX )֣J;5+,X+Ru.9"SJځ<_bʘbO )u.6la"*4sG DIJZ5 tU-DTJ1e&WgJ vb.Gn܃ *5,36k@t/=MD#U)\|J .!ETJ1҂:#[QaKybe· ɷȭ3A*yqꈥ<*|2jcbQ)z6Z'RC7s~""&ۢwq"*52rw<Rlfd}:XҝrY"*5>2q‡NQiA_Ey& DEV,剨bd0ETj`Y7 XL)I&0!-X; ETh`Mw7 MdJ1BF>|HM QeQ屻5'PD gP2$!|ݺ5ETJ F2MdJ 6k\J 6dȔ,_mk\!iS!Yn@TJ1ڛd&""53ywQ)ӃYRe@TJ4kM6kTHz D&dwa C8xCM)%ȳTfJ)&M B e2)XFoQ%ݚdJ ,46z'LDFIq:JPh ЀʘǤS zL)mv;+"R뺷vi"*dQ}R|<RVW ʘ8Q)`ɘfD/rԃD9hEDjb]V< *Xc.L! Sd 1rU@*c&SoEDhbYFYu4ɑ!(4 WdJ J!@)X Aڊ"SJUGJ)&;"Kq@Tj`Y97X3TDI5'Bk!8'2=Efr'Uuwbndb'VDuR)Xq8 g *50O Ew& BjuϹbQ!h)LRqNfq Q)Hs! M)#Y(0XQ5 dJ T/tIETj`H#*O֓d:XUiGJ)QSmJ \>O@Ng2)O(rTd@IuCĺr~bٍVĪꆎ:REt*P=#3LD #3gDN*n*",?sxOP(j4 Q<P:6 Nb˥*@DjbeQ)`4)QeUJ \%J)Tb8/\)2 G+H*3̀F,wg @{[rdw+cv"*5.Br(g!hAXf)ίJ Vg⽍DVe'GG7gU',!ߕ"*"Ɂf0P2 Fb$ŢHMLi QrETJ1ʈ&>J FHAto *rjlT 2J7DDjbMv7B"lb8\'RhZBd"*X%W8"7Xݍ0DFֹs<D&D7"sETj`]v%;ETJu.7I@d&TY(pI 9~J!¤ȔL _SR̻1;"RC? LDRKr"KM֭fO'8o` *X Pul?+2*:ϒ.H ,9͈t".HM,NG@Tj`]vi QD6+"65@RȔb"#ċRDVt6{ Q)hMɥp8 27ĺfD)C)"Rk[#s"*5G6NDɘ6ΧHMlQ)WLHM,ngC &f oL)=̄vAg"*WB<4FBEw2g"*4" AC-aNT RKNQDDjb,K 2R ,TP@d&Tu.#/CX#U&"R+!%2wUs9zkHM,~u x""4u&G>Fa^-BLR@eTdKH[!X @ʸdbg\X}~:'1 EDjbM5CE.H ,د QWĘRIJh8}QP}4R(EpQq>*)"RCFHaԉĊbRDV48MXF'zQD&օ;jU1;A)%XS݀tEDj`>Wz;D&Vu6#{6M$l_Ʉ 2ʺ! q-EDH^nND&>Ma+T3 .ԉdc&"R2j ( g=MRLG&R#׎&RWLk@X)%c3–i6L,t `# a4XG2 V>†iLa|`#+a4X[G0 V>–i6Le|`#Lg| `#l+a4X[GP :†iLa| a|-`#l+a4X;G0 V>Žj6Le| `#l+aC5X `#+a4X[G0 V>–i6Ta|-`#l+a4XG2 V>Ži6L,t `#l+a4X[GP :†iL0 V>{+a4X;BG1 V>J5X[G0 V>–i6Le|kpF0 V>–i6Le| `#l+a4X[GP :†iL2 V>ži6Le|`#ܓ [G'ܑLa|-`#+a,t-`#l+a4X+`#l+a4XG2 V>†iL2 V>ži6TR :–i6Le| `#l+a4X;BG1 V>J5X[G0 V>Žj6Le|`#l+a4X+`# ae|=`#+a4X[G0 V>–i6Le|`#l+aG5XGQ :J5X[G1 V>J5X[G0 V>–i6Le|`#,Tg|jLa|-`#l+a4XBG0 V>–i6L,t `#l+a4XG2 V>†iLR :ŽjvL2 V>ži6L,t `#l+a!ܑVBGQ :†iLa|-`#+a4X[GX aG5X+`#l+a4XG2 V>4X{G0 V>Žj6L,t`#l+a4XG2 V>†ivTc| `#l+a4X[G0 V>–ivLa|`#Lg| `#l+a4XG2 V>†ivTa|-`#+a4X[G0 V>–i6L,t`#l+a4XG2 V>4X{G0 V>–i6Ta|-`#Te| `#l+a4XGQ :†iLa|-`#l a4X[G0 V>ŽjBGR :Ži6Le| `#l+a4X[GP :J5X[G0 V>–i6Le|`#l+a4XG2 V>J5X;BGX+=Lc| `#l+a,t-`#l+a4X;GL'YZ&!VCbHtRFj()tUSQWR(ud^hSc4ά:vQF16a(MCr#ar#z GԘ7:/Rm*[h}ҭa\ǡ/$˒ɽ> Œ.ێAdp1ry8䉻8Γ(%|??]rۧ-qb]]v;1G;pbt |?קw-!~.g>wΆIgäa0lt6L:& ΆIgäa0lt6Lz^("t6LzʢJ Dl0lRgäW iy,0ΆIBYaҫPUl4ΆIgäW{"˜ 0IΆI iy,0lꞴ|OYTaBZ!( ΆIgäa0lt6L:& ΆIgäa0lt6L:&0{Bg$:&-{Rg$:& ΆIgä?E58& TlH ^-{Rgä}pTl$Rgäa0iH =Paҫ{=Bgä}|=Paҫ}pTl$Rgäaҍ0ljadRMo}/yw߿y,ȞdϽ"rhl)W drj4vWd.H0A'IFό@+"sV 92k"i)ZCqj̤{ܲqx+d10ǔkd$Zx>i?)$bqELnn2 r3k%^GJ<09f5B{pql6' qF")ݞ6WA*b4L󰟤PC ^V?!f Lr41md옘\@vaHW8np,%l@fL,oUЕmwQ#*rRɈm7Nl)4|  GlcJ=z]0&A+D2A#l"oسKp-ۄQw`m3呈͋!G: G}#=6Ts'wۚy2c97)9]IOFY9Fe@myjT#C ZF:SW~ױ[( Ml,6ngCK u.l%bQ  &{eHX)8 iu m<6.5y`̗,^u4( lr%94XLUdz;U LKd{񴢍ŕw FVn m8M 偹`A?&'!"{Ym4Yl(<`s(`JPc3E<Ґ^ X& 0ӟP-$,Drq(&x|Ed&`i6]lNQK9˙` *nA1QÅACczoFg`؆kM6_Z6K1bcbgB4séI#sl9Io&g3*&8mmg,oy[|WCJoF񜍋dG9+9D l3w &tUDt&,esz?&P%u9DH&^:aNjsE+m2dh"΃G|j&U-qĊb&\ԃ欲`PCcec$X3!kdjeEU}|ɀ]=&87TKL& 2o&f-M5l (p-3bK79g$76٬Bx]K59JȬF}Y^ŏ"m! RJ2Edfb:Uj`5>}Mο4f33z/\s>A<,vZ1q|a$| \x5˓a"po3F=*X<4`BDbCgBG{Dyb6$2MҗBDh| ?uP`d969[ Ynb0{~Ump} ۨ|lKՊ+OBfٲ \8k5mɑP4x7\ bS3k5lsP'N6\Vl9H|gTG9ЁhQE^j,1_BFGը[Lpl"ɏS2bTG +(y|(6) t2Lʔ'(Jj5ih { Iη@o=y!TWF"9 "GdXXa6 V0%8!ip~j!!b= N}6մf MɜocǕ3mٶ-$6E[8p̔Y~Mxx꘭ ݠNI%/]1^moc'&YQ,fHQ=d!PoFUY7m(tAMprg%_HHG,nL K&M<& FB[Ԛ/6gYx6sct'%7&]2H BIp;4VQhkN&B^L(tyFYŧSwuxݬrhoEZN;auO|q2b34K4@i'B),$._oMSt+܏{ߑW /Σ[f:  r@7#ף|=pWRiBnepAV+-] 3_PO,M& O|73A>0B A/*UD7˕e[)3ShR'}Q>D4 'e{y{AhfhH*ja'^ #UP OLLu <b,$A aŐ| PFC*ƃyly$)|;(fn]*v(#fc8Ip|s|ƹw4A<1 <-7Iii@֥C0#U?Ž nX@ddȭ< ҲBL4m_eqa #+JD;'inYO*n7W.򅃳fE(_C*JC*KɖsHT$L!^ݧNN 5J! QH DY.A&zҶN`$˃KU.S?WHV;swʓyF|;=;z2CH)}TG ,Bi.Hi*#>cʘ>O2`ZA{Qe!rMDh1 R3v'ILqz{WedgAdԸ 6gƧ :O2,^r=|yrPv3 Wv7H0dKJGċ]!gS_,W@@iDQ='TѧDɺ(H]<++KY@`u@>uED {31Rǰ4ӝ~:2-6 UaeDMA:&T LuUJ#$@Jds6 G'|:Vc$zJڳ,'5z&PR~E/ X5u Q*$iL'Cf lIUQ "/ }iSN.veOHEۑU]-"G@{5f[qZ.% фCYv$/3'u<:bv^$4Uu E$QgA 0*gZv\ G1@MRqǹ.ÃER_q ؓfn-̃/N+u 8Չ)V_ KL rOa*͊WXUqV&!k И!aQ42!fedd!iAR篊kB6Zݔ`$b㨓8 u *x<RFG'!pƭ8XV6 䋠 7z2Z8jU,XD}4Qa< j y.$sO>xjbtY#m Vj?YLj/p +TįXEvwRt8$C#+pyg аSlx(B/IGkpľcͽ~H?o+ФC@9|g,=Y/%ٰ >f߉-r V1db'̄h()#DdSsm.&e }MՆk#3A_gF0 qS]*qF+rhvR,&SFpaC1 dQ6[ sYd+&ޡ!ς}PMrpgT B(rw& GQZ / emgȔwh;6˺ULcB%|hܤ.J\y`GZ">ټfI+hc|%MG"q(f&. +8F4qiNAZqY#ڍ %#RDsCG3qkf! ϛO/=} tGɨ5*5Gmy3` %ge&.A4c8p0M jgƚGG}LFPhz9rdsAs6פ +nQY[X'HtavUW)fs ¸p0p& Hx6cHkhhOG6lz^7ϥB @952FOm@vT &HQ%,Q%p'xFٶ c"쏰M@EHq l֨u!@o&! 8$߭𾕣qt(s([E#?q9.s+h- >[6Gs&4byS6:糤;؜$y2% l6,]#x'эt9H7rgQmf#j=ro3V.y.F MQ# lEK%\I5X\-N.\&}W!X:4;LB6e\CFͷa& lbe Sg6p:X6.ڒZ 8T=X6f$%fRyd)ؤFD'\4ꆃݺd(=b_X&Ԋr6`c:jY>mNQdVqIv$jDѺqMNvNq6{ñ 8 `ʧކ2CaYhW62"B6eǼg1VttLm,0GQq)SuTf]z좷(m D;sz>5I%(+Ӣ琏MjK˜bb s3P>%l48S{ˁ}6V+tA ƣ{L̵$3IZgcщG6W\w*wWrf<Mԃ*-ngRD7; QN䅩W%B0J{挢 %x( NL6ΎC2'=q>"ڜGG?_ןRUVyEmq7B=pG!WP*Up?m1O꘹OuQ+ { $)| P[#4{jL@+b Mp |9#i}埳vb?߬ޟ?`zyyOOd{BF{q+gHŷ͛w}9><{V}&sv;}9}g= }(gLMJ}9ٜTl(g= xv38M?Y\g2y{gN,qv3e{6}1}b]L&}}ho=٤ }O}v;}{&}<٬ETgs6zv߳0&{k{g?<}zv3::䠜l}Ĝ?Y,uv߳: }dU/K~Hk)E!r)\\=t-/x~B< 1O?M<u1塢L}?拷/ߣw"\K h-?~O߾}ï^^{;*4*nȗMBmO/s<P{O==;~/ <> 1wE/ΥLOH]= |x%#_- . _Kn2L*;W9>ϿϹ+~ί????_/_v7xh@l4;^=eZ|Ć1%X|x_sSh(Jփ##폇};\˗p1hq~*U}ywrR\~̨H߅Ǘ s3p-| Ve8 >w2σ70b߿}swxΧOzityޯ1]qo6,ґaσ}:a 0@͕rW2wdzp[G6lxt[{E]I|X6 cG?;̘inl_?ŏ\_a7w|0cNt\h{-o{?jwcA~|;zgxHf`a/Os_PI @#Zp09Z(9oіo?"h"@ZE>Oe`aG2y{šo^YXRţ;1O7^S7Byn;{66^//4qo7w^o[tqz7ooO.(Uq`IZz)uxzы~wzߎWW_n2kȗs۹4Zu hwK Uʷu@`mbYI"Ǎݙ%XU__^!ɲ=qywt A|?/>ϟo784dDdeP=@jOq1PRʅWS"3zo^ *ݿ{,Zm}|?f}\}AM6\N Ti)sIã:-ٴYǍ/9]^.C*U,*{7AoPKF%Ɲ[kQy AƷ՛tm^&?K_߿¯d5*nڎ[ 1h!\_\r'}Aߎo[}Aڽ1}>i (H-wAa}.rgO@ ߹G[I{؏;4Nanӟ4E|d`@Vwr?Sg9x5=買oBB|)AxЎƂ~rl| '39)7^w7lqend;ۯ)#@<ʭJMNXd ݣa.Ń #݄ӃJ>MS}>[@=Ҭ+k[U/Y)endstream endobj 715 0 obj << /Filter /FlateDecode /Length 21064 >> stream x}YWr;?v//VxƚCm=MRP҃/ު4;)`;Y]ǻ޾_qӋx1jkco=oG_o޽hzw?wEܧr4eCۇz<Åm>o:@VOuz%yzuzjS^pԓ{{_%}w_}b]K}_j틯w}lcCU35"1gc=/vu?~9Uk5 ,_n܋ OEY]?@6OPcg! &2?sױ9%9"3^w8T; *McGhy?R{,Gm:,]zS}F?ngii?̯t9jۓW^ާa{o޽zwO g;],> $zb7?>~߭"zת}WOxPwت`dˑd:wW~)< %mJfe(M\& cA/vG%V*?2rw Z1Eme@S>=}9)ϙBz'!'cq$#F9)g9ƌg¿y s'T>>LB\Z`@pa.Sz<.q\jb Iz !hv7({;}F!(UK*bYiM25bU%#utb C4%GQ](!KO) yp!>¨(2A}Frex2݇UT>GDR#PY֔ |)> \Xu&" # i8:}Qd9!e>h"Tzݙ2"(̄b$PDp&6 )Iix^\!},hWP|$L|`B'iYk>SLr9bo>(M'l M]V]@겯Lnψ5ڍBn[Q(># 4:hІ9x,}4 6 .;eIO{VJaV3ǩg r YcYU)`lT g-塒|>ƨ#TR1EiTLI%$NoY8a& EVϨм4:邍Yj]D'[Tvz'1O1NRV薅'(YUu8}`ǬZw%z>ZGnz}9iKGLUVVâGaK> AeP'oGEHzvcGQ]ΥUz(RCr‰%dFT0,E>0U]ñ E B'ϱWpU'PQ'DJDȪrRTt>LPHyX'Lٿm_.r;BP?7As, Rvqr"I}*\OB,|ȳAA0{\$d(.k}q?I9D :7zkmEU﷟QFlU#~:ȟJw0ȟ>⼨E'P2,Z}\"6N./oBm66Xc UL11$%Jwt2!n}FH4Ȫ5kNv7ѨEFsLMBh ZvwȀ݇J =y/m!+^Ԝr_40H4' \t^f's5)Tm:G 9Ԑ}ʃ=Z=2&$D(N#uPB:}DG wd@.L( 0Y|B!DA,># Qo)XH1wȵN '~Lƪ4)B|=(4܇N@kJˊOdB0㲕mD leP¶Oc["( ] oGrNvu1 Qj ʴr%'Bj8nAX PǚE5'V}.hagaAxʂ5p[:,0# QI.[H=!3q Jq.3z_T1 VWİ.6 Ԉ4V``u"{!,)#ДAwܗqC$[>MjX\ D" &Xai'x!(GOQmBSԣcu}͜Ny(@SgwhW.膘9MCt۞!'#|Fw)j>-rĀLۅPAھ(%VBj^KhdTaMD>^ mzQ.AZ7kR2Ը B3ŰζAJÄǻzHL qC A۬eOjIGU# <&>YŲZA ([-Nv~X=aP BhCG/&䆕_ĝsD:iN?& u _%>yNJ'Ui |PVy k5M9*fŠcTn{18U59Ei'ˇbN>~dUNrTDp WUnLNqi(ƆMyއ4"Qݴ"vZުO͊"(''G"#N0ݍˆq}9k,t4Xe@fg/^f.|)~.3C6 T">"ي$XHAM N3,paT;ѻUE׮%h@o} 25h)p["a_}2bD`~VB)M'$§\T5viPRjjH>n[90N81lthM lNClঞscd,~-U0&Cݪ`F@|G|w?lD`Ug&s0h+5gRT5^IRdgm&RJZSj岸K:UZ| QYLd]!3*g'%,Wofuz>,k9TmDu)m'PوnABpշFzPJQm>"f>V#ja>j-n"53T4EM:B*4c~,z֗DƼyRBP ^|\Ub#tl[/ڌFT܎/h%Lh$a^H#uj)@"| 6i ,U!(ånȈ$D$DؠB~XM R}D:!&A./"ˋvD 2V!-QEVR3!޲[Ȝ_홦EX@*_B9KDyҸd@2)BP䝀U[[CoQmmpWBl A38{ _jQ<!@ 'B+wL*D,b(pRq qL'ڷHåPHG6BF[  FF뉐: Lm94(DnA=SX'кLHrDa{m$^645gʎgw R8tHHJ ە Ev $V[Gr@(Vr}|dNUGB F_~x\άq@TFB qGWxf!+YngS;s$,^L&X.fDV _<Dq m'2'J."^#Dh3"DPXDq<\e, ,#0`G:Ŏ$s9=n &WRZDH/ D0Қ] )I[oFp![4 d2 5},#Dq2-  )B1 R4IGC@9ӂv$2 ̭ĖQtVH淅lZZ׹&ZNH䌱պ'[^9q 13 7 ՞7Id$' yVybJ'_!^Rơ0^q + =H*B!F!FJ(D#mcj ҟ=Bj һРp(@n8= Q*)vF2L"$Z66 +!T d)m)3Sپ~T@@4ҚATRDorqi *¶-$+HXM[N!Un!G6CTF[EAǸLy,XD]\tl `q&WB]nĪf*{j2E![Fm+@f4W,!1"Q֒pؽ FUq*$^ܭZ(^Ay ҍfSj3@+MB(U--_9V/F*l%ɖ )bE\=c0M)T#uL}BMkX5*2-ov i<} i$_׏7A>sp,zAHV? &ytZZ>'&Ju'9 ,&cPv3mg-V8) e#6glqHV(܀N!z~5 ` ԞjRLcQ5dwjMTmF%@n DZ#-0GqsƲBE&ljM3rYX"D% J "ha'[J devp;UAbP[f kJlG$[M%:oWףEi4mjPN`41׬bXlA P\44n:NB(L !T:($%E >hi 4 ΰ ɀ@4jڷS[g2 !V rðxh#PBe+=BHB{ ٺx/&H,@sp)j FKUbNEL,DFbC_{ц(3Sh1nԎ$B)saW|V&iz`7B$+ݚ9>X4h=YgNڒŊ)6Ŗ-X~j$3NO UҏI)FS69^#0BJf;~҈'ى?kG*wkǤh^'O%P#M/hQʢR<5@T%vqz żzd wϟv* k;_W2R_Hx/x6Z 䇡HHOZ.6eS-*Z=eS]nB y H ~96ϠDm yVzjyd8{:4P[zybLs:UחbȢ4_}ۇ/cǻ}xxݒ%:F"!͛^h52p+w_>qiRTbK*X?b̥jE:1X ٧z?sf?r 3MwiY tl_߮>U8 0t`"^S59:5a>0y}xBV!0B4n6I;bU.VXQ[AqY43Ck4O;0#O ꦥvB>7'_d+c֎VWO V S]>Ai1"mNjKaIȷ2?jNO-csQܴ}s'|8zϑVkxLNjb>?"IN2Tdk] jz s9n$>7F-M-> ߙ%}F?J#3$ p'4=S74u!oKHg.AZ@òP\*ត[dTg"gEL Ӛmg]wijKlg ƍ>*BHATKj$%uDfV5,am̚`HRҫ <'LbN̢wiEh>7^}ТBouFlLf}'£Dzi Kx:t7xp98N5}FD&^ QA+جʀED Iѷ4[̞ZjG,xbK+ԁs@ "M򰦩7Du"d8-NZ҅ An=1baa.]zkUQ&X.)ʄRzgHPhSd}hVvǨ:Y)ц@iAOFHܥ?leF؝,ꙮԌ t(̧(Sԏ@t,l%Hې]Z\2W4b]vZZr K5&4fLfݥ;;ھtRa6P̮9tGpYuFͯö{Ym~ɞwJCM¬q >o0k[&WXyBahgp)k%h ٢% 5J.ApC(7hFp,9P@<}iNa7O2_iO]r!e`(KTnA|rE0b`LO{JX*Pe ;:m#(Xt,K]k(<cPDÑju>#eV*@ʴS~)O²j8a1gӆRO3`dyK>[ǰ9]AǥӫbZ`r<ũu̖2Ub0'꒝~IwM TBAE{-1E\=2CmE5hQ>.5%X3:|ڙE I?,^;>lpz;GuJ>L 3\]Q>P"潘0Q'ه8">O#Swh >Zc6BKx :zx)ݢo ksK6DXhPi7TԊZ[}"u-WZT\|' # ΖQM^7&bIN 4湥k%\2ڷHy2|nеA5-a> y6*Lq)Ċ2>6Is&Kg`ASDew!ɘYp*cQZ'>BcDtB&ʓ T+>ڪB&󪙛4M#}O¤!x0ugAO&^ ݹğho\$. r*XIu kue˲S}r+X>t>U*`)rɷR(##uR#pr rJس:&k}L* ٶ3K`vD/zκ/éF9} i |dؤP}kf9:7u$h2 `[՚]pUhsa&mԨ d;}Rc\<8<֝#u6Ķ@#SOSOX@>2(,a9}戦,ƺe^V׫`[]Z/ڠvT܎/e~h;Th}Xe?MduTƚNe@r5JՎ:ـU' `촆˩ʎ4 dꂶL$F6Bҏ5pji dѴ,5Z hZBz`3@2{9 a#,^ Nb-omRZP djH@ 7B֧A~Igr\N%Ew]wr9ٛ}Xsol+Hbf@Os;F< $GB@u#v mɑ ПXT ֐^΍7pCBtlΣBaq 2#'=k̕Wˆ(}{2ta2wWE9RW|C"r{ZkK e Cfӝ_.{i.Bx{Y%u7vWPk6NCcִD6@U{p0%B:Vc AcuVHO[H[#: 86hc&I;NBb!$Р/Y`X ƿf9i]h̓Q՞!%@b@Gw9j[Zx-4Vv?# d?B9kvB`#9SR QhKG#.[=5ml*0qX)֐$@70!Bb0g#h=RRc2 ߒc"!a, i} id5I?g|@xd}"Dt  [H0& %rhi %Ӹ Ʊ:%iz> 9V `@/倅/kcҵC da ߕ6倂iq 1^$ZGyVQ@Pmҕ ;<*L ^%~% Smw^7{ːz-~O#' PFB-{MEZ3*Rq8Rɏ~C@*"PR܊^j@ G֕8Cs,wUI0aIUZT r/Uy`v]A6ڥ+AzBJ 5,Iu iʔQ-T 0A{lJk }.[RF(N)$rBSWS0t+vTh%@LP!P! $ǸPP䥂2MHkv"!^Ab*F:* vMB(Tx{U)8V'o <ؕN-[ kU}x|&Oi`]{L@S8CLQ`l+ap0X)d vO!%QАdT)*׮:@VOT~:@VO٨:@VOMx-3^)4(ڂ4؁lTzw__Ǧ]Iw E@VEQ[B D8d]/xSGQ(R! * PS<ЎS<˒ܻSY?H!l7~3\|q|BKÑyCGl{ -/R+T}\sq'SzF4Wg<6 < u;l4ܟw>ܽ}AgQnGkҪwy?IݫOO]Ȣ.'1C v_> zW=ʿ]Z@fO6 xSlvo 嵷O -U7@Dm4 z--`v"ņL&Ʒ  vJ1,p@Ei.H(JIh]#]X(.3:ntd_%<@m]s1,{rSѥ#Vߒy~Vm8ـiZ f1 -J_bZ֤K3o3t>fn%r>`l᱃\b$[rk.ma,tq)\1(G"[h'. EXC,Yr`րfVρlXsTvQ`(]tQ/.3'S\UN\t'$n꧋<,k.^FYL%H;⺇g\pb.R.NZMTb>/ t?9B."'TA * X"㎻Uqa񓣹(}ߗ]aԧsQ$# lca[؝GFlq{c:;{ q-;[ _ArHoR*`k5ҀS}8y(Wz)I+x*5f7?xSs~KtVt9Pz:Q[ĠS5B2OPK@* &ft }"eL}20ZҘ|U]27&_VDe.]xcЛ).#$UxQÉUfv=̻>L> ^p(Ez]BR6&;[\oOvgUQY?!28 6DL(B`˚[x_ kC-=u.CE|.I $ЩL$9 _4#.auP -|2Ua9ɧ F! q֍RKM-EY{j9PU=FP\Z=j/A]a'EN6m)[6t*Mx"-4>x:I=QWvʧjX>XY7jֺKVB}-nYӽZ˦Àp 0)8ū#ehF/##ژE&} [z] lv/5 E 5ؔkf}R[Kr̼mMbj5vFv?gQʬ-WNJ) i!0T͐O*[gC]rm%Mk8GD0C Fڐ_Yx Yp,VQ~ߺ4dMw-GYCum? 6 Ef}v gh>1DktׄձtsL7>àU-,"_Wsz[GEСćfk [XB #8=@Uܼ'u [).$Å-"x Z֬:"]+ ziV[qcP(GY"Dft9)<h.aH/,T*}0E&I:rxd}״6x.G_pSPضǟ k`8+._B%ۇǙKK`~>ڢoRhp):p' ]%=P%A.  Qu!ů%&3k^]^^/ jZPqkG0RA'x%vm\с9]KAPEb8BP\E[y8 u /WMDUH:@Y&! rjcRR C{5&d>z1AdAOKX!mv ڛwBL –].iH].+BUͳl*ɺD `lw/ K!hĊqo1':w~Z ]80(|=3 XY3fCA[Ldd096T6mhRge gUFm/Gh2 j4֬slEU+[ [C\*ղzٗ @J=֌We硭Bֽ)o-mVw:ߒ@sC$Z/Y anT6*D~+xҶNխBT "WMuV4/X hxFejef]ŋ -#p/UEȁk&tF^WQ&Y* D%.ZA;H !**җ6]OZ~ /`zA$6yaW/:cpZ /0\Ҵ^7(mvmk_ 5 %iCA9%`n!M#8!C^Q;BRg<j"&~,jn.nGyN4&S 4s 6K cEGՅQ*t Q !5#vY;T&=_VX ښZ 2( QB&;"m7@QE`vNu(B쫐!-nb %|b1@ ׀>6CHHVa!drqحo!QZ6riH^IЖ-jqYsm|&پ^ Q <6MNVoXr')*EjP}h9 {ZN$ځjO+-+mT#w(B~}BG8DI&M8cyMȼN&@ ҕV@߅j]ZjMn ikH9FFN@ cKэ-$rlԞcMfduX Ȣa  k !5H~OuARgLiXwLKF8Q恘\%0Е]g<`,X:P0fhx0b",< JMJq3ʂz=q#oL)ƹ+(+q4^a&$.DZ=PrIcIvE0Zˈljc2u9тɸ<ۂIv<a*xhjJ@1.KƄ"!5dhI6H=:4f=|րӍjPيj9P* lר$EiP_4IubA/V&4et -#$SS+و&T}=I$+DB`DPj|$'\D`,{#(LU`8X,v1T[x1K&f"9 ( 1h.Ywɺ E? `"@vi5 s,ϷoRU}#}V q|0c&e8@"ބuqVC H1h\%T{Dgj((j-iN*\Լ@Ժl5UWaRMO zKTVTQ@OE6Bp~ޞH04[3jH$S&,=(Р2L=3^CP"| gi;H6 ڟfM*}6h-gЎMM}NN.1ZH'Y-HS9BdctzQ) *_DPʩPlPK<Qy'Lk|DOMdrJҜeyN:Ny&@@<˟{Sha>{Ea\FJ uD!v8R 0ߣQ2t :쏥Rp o9XE o4E˅MA>,~nW__bˤ 1dã-3ʔW1ӛן^omem2Z+U!eqe=afqWOw= &ݣL-of|j߽B<"E:nC>K679\6|_˽\!X/kOj ~Nu8KЏ_eS%zM D_%)X mp=yӍLĬ|N)1>C!_;P'R0w(RR}Gpo%Ax0q@W?^|_;"nˤTWo/6zX~^yy=zl>ƏL,-4:Pz{d /\))Zt_F:_2 O/N{zx*@-˩}:гp. ϐ"`.Rp* ~}./=W>kC~EKXzqGf#R>?_-x**ǽS8㷯=Sv|D"ΝK(aR+׵ev]uF[¾:qY_\/).2ґK+s6ʗnJg]áBB -|XX[HY^s.ޝOd0λk||5•B7.svzslW=Y:7ώ>6GFf]ƛDY G|(z [FHe)V?pIpt}lvf͇=TӁgIcװ j6|=|lO:I+=rTt-E h1W֐$ҩQD'8P̬ *3bd>oMֿ="<ղaLZ@wA@]/q?ǿ;)7OG?,;_>5CNK?"{O:e&f2?1\yûWaH?}xO}zz[!f[O? ;e83_WNB zhX=&3U) @XR(P@n U6{IS wMC$okӲGgw{ߞެ|O/I]Ӳ.m~\ΦT-[֙AZɻ$|~F2XU[ a7\W`ng>]Z}_eR3b91|z[LZLP/1-gi+cn|1 ;QLZq+Zt9JiJ5 s^WVϡzBh?xP<3OE%?m}3ܜ-ԺY?7yĄ}\\me i5T#0ҵܭ % OlvAAsbqpwh50je@GUvEU;%O-mmo[Zqӭ,"RH.=h^sb;#7V(z* q,sp5ˡ,o}ߞ"ߓ|NS`K"ٷWF>ի2gl1Nk Qv׫Ux>3rW,2_Xѝ슽=zv ڞz,z{AbH 4>Tyg?$v r0ŒѼqEzfVwn)c_.~lY "3epgj$Ds/{#A~12ȶ)eUiAD|bDdprS3D;-IuNߜקW xj},*4>χ~X c.R݆Σ.aΖTrxM-W X5ߚOL㪶8}u%0Ymb1q& Ocb'`z י6[ajy&D̈́'>ܹ as;֐~w-a)5^.j5~ ƈCDgtxn^8syBe#'f7Z"~#P#NfP!STZ 0y#ႅ1&FZv}>'04δwy> 2`n(42DLbp{{<8Oo_="]BЁӼ#liשO8+I8a1k7O DR'acT99uE-2^BEJW` =N̙'fTjmʻkq.ބJ(<ga5n+aDȟ Lgkʼn?_W?eF}z5e ҥ܍$jʫVCqGL.֒HG/ʼlcQs!ױu>2h +dF~0 ]aڞ23 d5 UN/΄e t"CߔC,gQXv6MO/5HľlLKT{e BEp7-%oBE^e(sx*fb36TgPhwˑ#%4 {1L [Ȝk2%vӠ\atqٙٵ?` )iA p+1N¤v*ȏ1Tf3R7B W-sr{wUF^sC[T mG,|\bYpKnd%@͚zsϕ"!_fR+/YY؁a|\1h#~Z^8!C'; ]$TYrs:jk> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 717 /ID [] >> stream x+DQ{131̛ycR0ł2YLRj4 )QK+FD)RjJ,d!6,d'MJ e,(P,~S [|:={v )'?&BCY;vB\"t:;k{#?!,xܔܾ鍞 EkxtE!tz# o57No?UF14ealj&ߙ3Y!s` y`ɚ0Y69^՟1;D?> kg&Em..sfN2 VQg%A}6^淹֤1ꉁΚ:@ZOTŞ-/ܨ6> endobj 2 0 obj << /Type /Catalog /Pages 3 0 R >> endobj 7 0 obj << /Type /Page /Parent 3 0 R /Contents 8 0 R /Resources 4 0 R >> endobj 8 0 obj << /Length 1468 /Filter /FlateDecode >> stream xŗ˒S7)zi/ZE@A`flfL|!cOR}=\ŜKjuWgCg O7o~N/FVZkj?ݻizϝI%M)iٙݙS7~H6Sև5QAU|olsv7g+FlOd~򨶉*f< Kz7x6$4ڮbr9n'5 ~ID٧b~8@ql@qNܽ]o-73/xejƗUN` Q(qCƗK&gEVY?9fL 'gL$qO6e9adV*scJVb=aZVS2_[]G~wi(WeV.7EX'be-\uЙpaLUg-#`9 I,\W)v0 A9#HC.bhe  q3%_ӲX,9MV%dʊPK|JK%.X^H(('MV4Z4aL|ASiL2)j1"Y_5&)6NJzeJrXp *t,}a.*'2C-aƢPc T kJEC !=N m｜a'G-6&b>>`DC(z3bY;+2;KRc'??֢.#놵0:Vq`{K_54D @O"}ctQ,!#Kck%c\}n?%_> }N^k^oB!di:N !!!1f,Il/hw.W+&$S  !7<"[Iȝ~M${|(i=szK/G&Gw:@AtddG0$>!o1,`Ajj#pmL/qmX0’{3ܛj97endstream endobj 3 0 obj << /Type /Pages /Kids [ 7 0 R ] /Count 1 /MediaBox [0 0 432 201] >> endobj 4 0 obj << /ProcSet [/PDF /Text] /Font << /F1 10 0 R /F2 11 0 R /F3 12 0 R >> /ExtGState << >> /ColorSpace << /sRGB 5 0 R >> >> endobj 5 0 obj [/ICCBased 6 0 R] endobj 6 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~endstream endobj 9 0 obj << /Type /Encoding /BaseEncoding /WinAnsiEncoding /Differences [ 45/minus ] >> endobj 10 0 obj << /Type /Font /Subtype /Type1 /Name /F1 /BaseFont /ZapfDingbats >> endobj 11 0 obj << /Type /Font /Subtype /Type1 /Name /F2 /BaseFont /Helvetica /Encoding 9 0 R >> endobj 12 0 obj << /Type /Font /Subtype /Type1 /Name /F3 /BaseFont /Helvetica-Bold /Encoding 9 0 R >> endobj xref 0 13 0000000000 65535 f 0000000021 00000 n 0000000163 00000 n 0000001832 00000 n 0000001915 00000 n 0000002050 00000 n 0000002083 00000 n 0000000212 00000 n 0000000292 00000 n 0000004778 00000 n 0000004872 00000 n 0000004956 00000 n 0000005053 00000 n trailer << /Size 13 /Info 1 0 R /Root 2 0 R >> startxref 5155 %%EOF