earth/0000755000176200001440000000000014567114553011370 5ustar liggesusersearth/NAMESPACE0000644000176200001440000000341214567066341012610 0ustar liggesusersuseDynLib("earth") import(stats) importFrom(plotmo, plotmo.singles, plotmo.pairs, plotmo.y) 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(earth, fit) 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/0000755000176200001440000000000014334575364012304 5ustar liggesusersearth/data/etitanic.rda0000644000176200001440000001335612506752424014575 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.rda0000644000176200001440000001451212506752424014203 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/0000755000176200001440000000000014564734764012154 5ustar liggesusersearth/man/summary.earth.Rd0000644000176200001440000000742313427171430015226 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.Rd0000644000176200001440000001055114564734764013735 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.Rd0000644000176200001440000001203113425437405015157 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.Rd0000644000176200001440000003310214241603453013542 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), 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.Rd0000644000176200001440000000364414357776147013666 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{https://www.maths.bath.ac.uk/~jjf23} Hastie and Tibshirani (1990) \emph{Generalized Additive Models} \url{https://hastie.su.domains/pub.htm} } \seealso{ \code{\link{earth}} \code{\link[datasets]{airquality}} a different set of ozone data } \keyword{datasets} earth/man/plot.earth.models.Rd0000644000176200001440000000666012531335161015771 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.Rd0000644000176200001440000000440713000474705014671 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.Rd0000644000176200001440000007130014563605165013536 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{https://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} % CRAN check fails with "Message: Forbidden" % \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{https://hastie.su.domains/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{https://hastie.su.domains/pub.htm} Miller, Alan (1990, 2nd ed. 2002) \emph{Subset Selection in Regression} \url{https://wp.csiro.au/alanmiller/index.html} Wikipedia article on MARS \url{https://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.Rd0000644000176200001440000004331213740650137015000 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 (hinge value) 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] [,2] [,3] [,4] [,5] [,6] [,7] [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{modvars}}{ A matrix specifying which input variables are used in each column of the model matrix. (This field is \bold{new in earth 5.2.0}.)\cr Columns correspond to columns of the model matrix (same as cols of \code{dirs}, see above).\cr Rows correspond to variables in the formula. For example, the formula:\preformatted{ survived ~ age + pclass + sqrt(age) - sex } results in: \code{attr(terms,"factors")}:\preformatted{ age pclass sqrt(age) survived 0 0 0 # the response will be dropped age 1 0 0 pclass 0 1 0 sqrt(age) 0 0 1 # sqrt(age) will be merged with age sex 0 0 0 # sex is unused and will be dropped } \code{modvars}:\preformatted{ age pclass2nd pclass3rd sqrt(age) age 1 0 0 1 # age and sqrt(age) use "age" pclass 0 1 1 0 # pclass2nd and pclass3rd use "pclass" } Note that for models built with \code{earth.default} (\code{x,y} models), ``derived variables'' are not combined in \code{modvars} as they are for formula models. The row names of \code{modvars} match the column names of \code{x}, after factor expansion. Columns in \code{x} named \code{"age"} and \code{"sqrt(age)"} will be treated as two separate variables. % up to changes to conform the names to standard R variable names. % For example, if the column names of \code{x} are\cr % \code{"age", "pclass2nd", "pclass3rd", "sqrt_age"},\cr % then the row names of \code{modvars} will be\cr % \code{"age", "pclass2nd", "pclass3rd", "sqrt_age"}. } \item{\code{namesx}}{ Variable names in the input data. Deprecated (subsumed by \code{modvars}). } \item{\code{xlevels}}{ This component exists only if the model was built using \code{earth.formula}.\cr Same as \code{lm}. A record of the levels of the factors used in fitting, needed under certain conditions by \code{predict.earth}. } \item{\code{levels}}{ This component exists only if the model was built using \code{earth.default}.\cr 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.Rd0000644000176200001440000000467513410121427015523 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.Rd0000644000176200001440000001611614563612514014513 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}}. \bold{Acknowledgment} This function incorporates the function \code{spread.labs} from the orphaned package \code{TeachingDemos} written by Greg Snow. } \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.Rd0000644000176200001440000000411213000474714014512 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.Rd0000644000176200001440000000457314015537126014234 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{https://hbiostat.org/data/repo/titanic.html}\cr See also:\cr \url{https://biostat.app.vumc.org/wiki/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{https://biostat.app.vumc.org/wiki/bin/view/Main/RmS} } \seealso{ \code{\link{earth}} } \keyword{datasets} earth/man/expand.bpairs.Rd0000644000176200001440000000720313447765620015175 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.Rd0000644000176200001440000001046514362227223015022 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: # 29.0 # - 3.42 * h(14.2-Girth) # + 6.23 * h(Girth-14.2) # + 0.581 * h(Height-75) cat(format(earth.mod, style="pmax")) # yields: # 29.0 # - 3.42 * pmax(0, 14.2 - Girth) # + 6.23 * pmax(0, Girth - 14.2) # + 0.581 * pmax(0, Height - 75) cat(format(earth.mod, style="C")) # yields (note zero based indexing): # 29.0 # - 3.42 * max(0, 14.2 - x[0]) # + 6.23 * max(0, x[0] - 14.2) # + 0.581 * max(0, x[1] - 75) cat(format(earth.mod, style="bf")) # yields: # 29.0 # - 3.42 * bf1 # + 6.23 * bf2 # + 0.581 * bf3 # # bf1 h(14.2-Girth) # bf2 h(Girth-14.2) # bf3 h(Height-75) } \keyword{models} earth/man/evimp.Rd0000644000176200001440000000556414563600033013551 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.Rd0000644000176200001440000000643212525350744015017 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.Rd0000644000176200001440000000474713740413331015117 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}. \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.Rd0000644000176200001440000000655713730225301016135 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{ # Example 1 data(trees) earth.mod <- earth(Volume ~ ., data = trees) # standard earth model summary(earth.mod, decomp = "none") # "none" to print terms in same order as lm.mod below bx <- model.matrix(earth.mod) # earth model's basis mat (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 # Example 2 earth.mod <- earth(Volume~., data=trees) # standard earth model summary(earth.mod, decomp = "none") # "none" to print terms in same order as lm.mod below bx <- model.matrix(earth.mod) # earth model's basis mat (equivalent to bx <- earth.mod$bx) bx <- bx[, -1] # drop intercept column bx <- as.data.frame(bx) # lm requires a data frame bx$Volume <- trees$Volume # add Volume to data lm.mod <- lm(Volume~., data=bx) # standard linear regression on earth's basis mat summary(lm.mod) # yields same coeffs as above summary # displayed t values are not meaningful } \keyword{models} earth/man/contr.earth.response.Rd0000644000176200001440000000135412542772537016524 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.Rd0000644000176200001440000000372412506752426015357 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/DESCRIPTION0000644000176200001440000000162714567114553013104 0ustar liggesusersPackage: earth Version: 5.3.3 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.6.0), Suggests: gam (>= 1.20), mgcv (>= 1.8-26), mda (>= 0.5-2), 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: 2024-02-26 12:13:39 UTC; milbo Repository: CRAN Date/Publication: 2024-02-26 14:00:11 UTC RoxygenNote: 5.1.2 NeedsCompilation: yes earth/build/0000755000176200001440000000000014567100162012456 5ustar liggesusersearth/build/partial.rdb0000644000176200001440000000007514567100162014605 0ustar liggesusersb```b`afb`b1 H020piּb C"%!7earth/tests/0000755000176200001440000000000014563611177012532 5ustar liggesusersearth/tests/README.txt0000644000176200001440000000020113273376247014224 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.R0000644000176200001440000000153213447764145014743 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.save0000644000176200001440000000542714563611177016433 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 > 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/0000755000176200001440000000000014567100162012146 5ustar liggesusersearth/src/earth.h0000644000176200001440000001715414361741577013447 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 int UsedColsR[]); // in: specifies used columns in x (assume R LOGICAL is stored as int) #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.c0000644000176200001440000001354314564053706013757 0ustar liggesusers// allowed.c: routines for the "allowed" parameter of the R function earth(). #include "R.h" #include "Rinternals.h" #include // defines bool, true, false #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 != 0; FirstGlobal = FALSE; return EvalAllowedFunc(); } earth/src/leaps.f0000644000176200001440000020753014567076406013445 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. -1) 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. -1) 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/Makevars0000644000176200001440000000003713736221734013650 0ustar liggesusersPKG_LIBS=$(BLAS_LIBS) $(FLIBS) earth/src/rentries.c0000644000176200001440000002370314362303165014153 0ustar liggesusers// rentries.c: Register native routines for R. // The core of this file is the function R_init_earth. #define USING_R 1 #include "R.h" #include "Rinternals.h" // for REALSXP etc. #include "R_ext/Rdynload.h" #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 int UsedColsR[], assume R LOGICAL is stored as int }; // TODO: for below, "gcc --pedantic" gives "warning: cast between incompatible function types" 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.c0000644000176200001440000045650314564415303013435 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 #include // defines bool, true, false #if _MSC_VER // microsoft #include // microsoft malloc debugging library #define _C_ "C" // for externs in linpack library // disable warning: 'strcpy': This function or variable may be unsafe #pragma warning(disable: 4996) #else // not microsoft #define _C_ #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" #ifdef printf #undef printf // prevent clang warning #endif #define printf Rprintf #define FINITE(x) R_FINITE(x) #else // not R #define warning printf void error(const char* args, ...); #if _MSC_VER // microsoft #define ISNAN(x) _isnan(x) #define FINITE(x) _finite(x) #else // not microsoft #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 #ifndef USE_BLAS // ifndef here allows USE_BLAS to be defined on compiler cmdline #define USE_BLAS 1 // 1 is faster (tested on Windows XP Pentium with R BLAS) #endif // 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.3.3"; // 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); vsnprintf(s, sizeof(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); vsnprintf(s, sizeof(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) snprintf(s, sizeof(s), Align? "%6.3f GB": "%.3g GB", Size / ((size_t)1 << 30)); else if(Size >= 1e6) snprintf(s, sizeof(s), Align? "%6.0f MB": "%.3g MB", Size / ((size_t)1 << 20)); else if(Size >= 1e3) snprintf(s, sizeof(s), Align? "%6.0f kB": "%.3g kB", Size / ((size_t)1 << 10)); else snprintf(s, sizeof(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); vsnprintf(s, sizeof(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 reduces the effects of slight numerical differences across compilers // and machines (especially when comparing prints while testing). static INLINE double MaybeZero(double x) { return (x > -ALMOST_ZERO && 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 int UsedColsR[]) // in: specifies used columns in x (assume R LOGICAL is stored as int) { const size_t nCases1 = *pnCases; // type convert // convert UsedColsR from R_LOGICAL (int) to bool const int nCols = *pnCols; UsedCols = (bool*)malloc1(nCols * sizeof(bool), "UsedCols\t\tnCols %d sizeof(bool) %d", nCols, sizeof(bool)); int iCol; for(iCol = 0; iCol < nCols; iCol++) UsedCols[iCol] = UsedColsR[iCol] != 0; Regress(Betas, Residuals, Rss, Diags, pnRank, iPivots, x, y, nCases1, *pnResp, nCols, UsedCols); free1(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. 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; 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 0 // Oct 2020 Earth version 5.3.0: Removed the following code because // under certain conditions it caused an end knot to be reported as // as an internal knot (1 in the dirs matrix that should be a 2). // (The code's original purpose, 2008, was to fix a slight numerical // instability across architectures that is no longer an issue.) if(fabs(RssDeltaLin - *pBestRssDeltaForTerm) < ALMOST_ZERO) { tprintf(7, "RssDelta %g is almost zero\n", RssDeltaLin - *pBestRssDeltaForTerm); RssDeltaLin = *pBestRssDeltaForTerm; } #endif if(RssDeltaLin > *pBestRssDeltaForParent) *pBestRssDeltaForParent = 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) { 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 - RssDeltaForParPredPair), MaybeZero(RssDeltaForParPredPair), RssDeltaForParPredPair > *pBestRssDeltaForTerm? "best for term": "better"); UpdatedBestRssDelta = true; *pBestRssDeltaForTerm = RssDeltaForParPredPair; *pLinPredIsBest = false; *piBestCase = iBestCase; *piBestPred = iPred; *piBestParent = iParent; *pIsNewForm = IsNewForm; } 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) snprintf(sUsed, sizeof(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=] snprintf(sTerms, sizeof(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 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, MaybeZero(1 - BestGcv/GcvNull), MaybeZero(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: for adjusting endspan for interaction terms 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; ASSERT(nDigits >= 0); char sFormat[50]; snprintf(sFormat, sizeof(sFormat), "%%-%d.%dg", nDigits+6, nDigits); char sFormat1[50]; snprintf(sFormat1, sizeof(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]; snprintf(sPredFormat, sizeof(sPredFormat), "%%%dd", nPredWidth); char sPad[500]; snprintf(sPad, sizeof(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"); char s[1000]; 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: snprintf(s, sizeof(s), " * max(0, %s - %*sx[%s])", sFormat, nDigits+2, " ", sPredFormat); printf(s, Cuts_(iTerm, iPred), iPred); nKnots++; break; case 1: snprintf(s, sizeof(s), " * max(0, x[%s]%*s- %s)", sPredFormat, nDigits+2, " ", sFormat1); printf(s, iPred, Cuts_(iTerm, iPred)); nKnots++; break; case 2: snprintf(s, sizeof(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); vsnprintf(s, sizeof(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.f0000644000176200001440000000135213736221734014126 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.h0000644000176200001440000000067213736221734013761 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/R/0000755000176200001440000000000014567077013011570 5ustar liggesusersearth/R/varmod.R0000644000176200001440000015635014566602537013221 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") # TODO this won't work: varmod_internal assumes an earth parent model in some places 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 <- (parent.y - parent.predict(parent))^2 squared.resids <- correction * squared.resids + 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) { check.vec(yhat, "yhat") # exponents of neg numbers are allowed only for integer exponents if(floor(exponent) != exponent) { check.that.most.are.positive( yhat, "parent.fit", 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 <- parent.predict(parent) check.that.most.are.positive( parent.fit, "parent.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 <- parent.predict(parent) check.that.most.are.positive( parent.fit, "parent.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, ...) { parent.fit <- parent.predict(parent) data <- data.frame(abs.resids, apply.exponent(parent.fit, exponent)) # we use RHS instead of colnames(parent.y) because we have applied 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, ...) { parent.fit <- parent.predict(parent) data <- data.frame(abs.resids, apply.exponent(parent.fit, exponent)) # we use RHS instead of colnames(parent.y) because we have applied 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, ...) { parent.fit <- parent.predict(parent) data <- data.frame(abs.resids, apply.exponent(parent.fit, 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) parent.fit <- parent.predict(parent) RHS <- apply.exponent(parent.fit, 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 <- parent.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) } predict_pint <- function(object, newdata, level) # newdata allowed { se <- predict_se(object, newdata) parent.fit <- parent.predict(object$parent, 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 <- parent.predict(object$parent, 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, fixed=TRUE) # 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.fit <- parent.predict(object$parent, newdata=NULL) order <- order(parent.fit) 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.fit[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 fit <- predict.varmod(object, type="abs.residual") lines(parent.fit[order], fit[order], col=line.col, lwd=lwd) if(info) { # lowess smooth smooth <- lowess(parent.fit[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() } # This func exists because when predicting for variance calculations with earth-glm # models, we want to predict using the earth model itself (not the glm submodel). # Therefore for earth models, we force type="earth". parent.predict <- function(parent, newdata=NULL) { stopifnot(!is.null(parent)) type <- if(inherits(parent, "earth")) "earth" # ignore glm submodel of earth model, if any else plotmo::plotmo_type(parent, trace, "varmod") parent.fit <- predict(parent, newdata=newdata, type=type) check.vec(parent.fit, "parent.fit") stopifnot(!is.null(dim(parent.fit))) # check parent.fit is a matrix or dataframe parent.fit[,1] } earth/R/earth.prune.R0000644000176200001440000003305313725076573014157 0ustar liggesusers# earth.prune.R: # # Functions are in alphabetical order. # This exposes a problem, possibly in the leaps fortran code. # It 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 } } } # 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) } # 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) } 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()) } 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 } # 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_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) # Sep 2020: Keep best subset for all sizes up to nterms, not just nprune. # This gives clearer graphs in earth_plotmodsel for nprune models. # Don't do it for exhaustive because that's too slow. nprune.all <- if(pmethod != "exhaustive") nterms else nprune 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.all, 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.all) nprune <- min(nprune, length(rss.per.subset)) # probably unnecessary nprune.all <- min(nprune.all, length(rss.per.subset)) # probably unnecessary prune.terms <- prune.terms[seq_len(nprune.all), seq_len(nprune.all), drop=FALSE] stopifnot(all(prune.terms[,1] == 1)) # check intercept column gcv.per.subset <- get.gcv(rss.per.subset, seq_len(nprune.all), 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) 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[1:nprune]),] 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(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 } earth/R/earth.cv.R0000644000176200001440000005620314565632543013436 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, trace.org, glm.arg, degree, 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 # we set nprune=nterms so earth_plotmodsel shows oof.rsq # for all submodels even when the user specifies nprune # TODO with keepxy=TRUE, 70% of cv time is spent in update.earth # TODO check that subset arg of main call to earth is handled correctly here pruned.foldmod <- update.earth(foldmod, 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.earth(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) 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, pmethod, if(pmethod == "cv") "backward" else pmethod, trace.org, 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) { ret <- get.fold.rsq.per.subset(foldmod, oof.y, max.nterms, trace, must.print.dots) oof.rsq.tab[icross.fold,] <- ret$oof.rsq.per.subset infold.rsq.tab[icross.fold,] <- ret$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 && nresp > 1 && pmethod == "cv") cat("\n") trace1("\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, pmethod, pmethod1, trace.org, must.print.dots) { if(trace.org == .5) { if(must.print.dots || nresp > 1) cat("\n") printf("%s with pmethod=\"%s\": GRSq %.3f RSq %.3f nterms %d\n", if(pmethod == "cv") "Preliminary model" else "Model", pmethod1, object$grsq , object$rsq, length(object$selected.terms)) if(must.print.dots || nresp > 1) cat("\n") } else if(trace.org >= 1) { printf("\n") 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.R0000644000176200001440000002322013722412461013022 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") # 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.R0000644000176200001440000000472314565632543014203 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.R0000644000176200001440000000306514055547327014253 0ustar liggesusers# stop.if.dots.R: # stop.if.dots issues an an error message if any args in dots. # We use it to test if any dots arg of the calling function was used, for # functions that must have a dots arg (to match the generic method) but don't # actually use the dots. This helps the user catch mistyped or illegal args. stop.if.dots <- function(...) { dots <- match.call(expand.dots=FALSE)$... if(length(dots)) dots.used.err(STOPFUNC=base::stop, MSG=": unrecognized", ...) } warn.if.dots <- function(...) { dots <- match.call(expand.dots=FALSE)$... if(length(dots)) dots.used.err(STOPFUNC=base::warning, MSG=" ignored", ...) } dots.used.err <- function(..., STOPFUNC, MSG) # utility for stop.if.dots and friends { callers.name <- callers.name(n=2) dots <- match.call(expand.dots=FALSE)$... for(idot in seq_along(dots)) # STOPFUNC is either stop() or warning() { desc <- describe.dot(dots, idot) STOPFUNC(callers.name, MSG, desc, call.=FALSE) } } describe.dot <- function(dots, idot, n=4) # utility for dots.used.err { nchar <- nchar(names(dots)[idot]) if(length(nchar) && nchar > 0) return(sprint(" argument '%s'", names(dots[idot]))) # the argument that was passed in dots is unnamed call <- call.as.char(n=4) # n=4 to describe call to caller of stop.if.dots sprint(" unnamed argument\n The call was %s", paste0(strwrap(call, width=max(40, max(25, getOption("width")-20)), exdent=25), collapse="\n")) } earth/R/do.par.R0000644000176200001440000002104714566605422013102 0ustar liggesusers# do.par.R: functions setting par() and for setting the overall caption # main1 is not called main else would clash with main passed in dots (which # we ignore but cause an error message). Likewise for xlab1 and ylab1. do.par <- function(..., nfigs, caption, main1, xlab1, ylab1, trace, nlines.in.main=if(is.specified(main1)) nlines(main1) else 1, def.cex.main=1, def.font.main=2, # use 1 for compat with plot.lm def.right.mar=.8) { nrows <- ceiling(sqrt(nfigs)) # Note that the plain old cex argument is used in plotmo only in par() # (but we also query it later using par("cex")). # We use plain old cex relative to the cex calculated by nrows (so passing # cex=1 to plotmo causes no changes, and cex=.8 always makes things smaller). # TODO cex.axis etc. should be treated in the same way # TODO consider moving this into the dotargs functions, also extend for cex.axis, cex.main plain.old.cex <- dota("cex", DEF=1, ...) check.numeric.scalar(plain.old.cex) cex <- if(nrows == 1) 1 else if(nrows == 2) .83 else if(nrows >= 3) .66 cex <- plain.old.cex * cex # set oma to make space for caption if necessary stopifnot.string(caption, allow.empty=TRUE, null.ok=TRUE) def.oma <- dota("oma", ...) if(!is.specified(def.oma)) { def.oma <- par("oma") def.oma[3] <- max(def.oma[3], # .333 to limit cex adjustmment 2 + (plain.old.cex^.333 * nlines(caption))) } cex.lab <- dota("cex.lab", # make the labels small if multiple figures DEF=if(def.cex.main < 1) .8 * def.cex.main else 1, ...) mgp <- # compact title and axis annotations if(cex.lab < .6) c(1, 0.2, 0) else if(cex.lab < .8) c(1, 0.25, 0) else c(1.5, 0.4, 0) # margins are small to pack plots in, but make bigger if xlab # or ylab specified (note that xlab or ylab equal to NULL means # that we will later auto generate them) mar <- c( if(is.null(xlab1) || (is.specified(xlab1) && any(nzchar(xlab1)))) 4 else 3, # bottom if(is.null(ylab1) || (is.specified(ylab1) && any(nzchar(ylab1)))) 3 else 2, # left 1.2 * nlines.in.main, # top def.right.mar) # right if(nrows >= 5) # small margins if lots of figures mar <- cex * mar trace2(trace, "\n") call.dots(graphics::par, DROP="*", # drop everything KEEP="PREFIX,PAR.ARGS", # except args matching PREFIX and PAR.ARGS TRACE=if(trace >= 2) trace-1 else 0, SCALAR=TRUE, def.mfrow = c(nrows, nrows), def.mgp = mgp, # compact title and axis annotations def.tcl = -.3, # shorten tick length def.font.main = def.font.main, def.mar = mar, def.oma = def.oma, def.cex.main = def.cex.main, # ignored by most plot funcs so do it here def.cex.lab = cex.lab, def.cex.axis = cex.lab, force.cex = cex, # last, overrides any cex set by any arg above ...) # any remaining graphic dot args are also processed } # call do.par on any graphics args in dots, and return a list of their # old values so the caller can use on.exit to restore them do.par.dots <- function(..., trace=0) { dots <- match.call(expand.dots=FALSE)$... if(length(dots) == 0) return(NULL) oldpar <- args <- list() env <- parent.frame() for(dotname in PAR.ARGS) if(is.dot(dotname, ...)) { arg <- list(par(dotname)) names(arg) <- dotname oldpar <- append(oldpar, arg) dot.org <- dota(dotname, ...) dot <- try(eval(dot.org, envir=env, enclos=env), silent=TRUE) if(is.try.err(dot)) dot <- dot.org # TODO consider moving this into the dotargs functions, also extend for cex.axis, cex.main # special handling for cex args: we want cex to be relative # to the current setting, so e.g cex=1 causes no change if(substr(dotname, 1, 3) == "cex") { olddot <- par(dotname) dot <- dot[[1]] * olddot } else if(!(dotname %in% PAR.VEC) && length(dot) != 1) dot <- dot[[1]] # similar to handling of argument "scalar" in eval.dotlist arg <- list(dot) names(arg) <- dotname args <- append(args, arg) } if(length(args)) { if(trace >= 2) printf.wrap("\npar(%s)\n", list.as.char(args)) do.call(par, args) } oldpar # a list of old values of args that were changed, empty if none } check.do.par <- function(do.par, nfigs) # auto do.par if null, check is 0,1, or 2 { if(is.null(do.par)) do.par <- nfigs > 1 if(is.logical(do.par)) do.par <- as.numeric(do.par) stopifnot(length(do.par) == 1) if(!is.numeric(do.par) || (do.par != 0 && do.par != 1 &&do.par != 2)) stop0("do.par must be 0, 1, or 2") do.par } auto.caption <- function(caption, resp.name, type, model.call, object.name, my.call) { sresponse <- stype <- smodel <- scaption <- smy.call <- "" if(!is.null(caption)) scaption <- sprint("%s ", caption) # the test against "y" is because "y" may just be a fabricated # name created because the actual name was not available if(!is.null(resp.name) && resp.name != "y") sresponse <- paste0(resp.name, " ") if(type != "response") stype <- paste0("type=", type, " ") if(!is.null(model.call)) { smodel <- strip.deparse(model.call) smodel <- sub("\\(formula=", "(", smodel) # delete formula= } else smodel <- paste0("model: ", object.name) s <- paste0(scaption, sresponse, stype, smodel) smy.call <- process.my.call.for.caption(my.call) if(nzchar(smy.call)) s <- paste0(s, if(nzchar(s)) "\n" else "", smy.call) s } # Call this only after a plot is on the screen to avoid # an error message "plot.new has not been called yet" draw.caption <- function(caption, ...) { if(!is.null(caption) && any(nzchar(caption))) { # allow use of dot args for caption specs cex <- dota("caption.cex cex.caption", DEF=1, NEW=1, ...) font <- dota("caption.font font.caption", DEF=1, NEW=1, ...) col <- dota("caption.col col.caption", DEF=1, NEW=1, ...) line <- dota("caption.line", DEF=1, ...) # trim so caption fits # strwidth doesn't have units of device coords so work with usr coords # TODO the algorithm below is not quite correct caption <- strsplit(caption, "\n")[[1]] usr <- par("usr") # xmin, xmax, ymin, ymax n <- par("mfrow")[2] # number of figures horizontally across page avail <- .7 * n * (usr[2] - usr[1]) strwidth <- max(strwidth(caption)) if(strwidth > avail) { which <- strwidth(caption) > avail max <- max(nchar(caption)) max.nchar <- max * avail / strwidth if(max.nchar < max) { # TODO should always be FALSE but actually isn't caption <- substr(caption, 1, max.nchar) caption[which] <- paste0(caption[which], "...") } } caption <- paste(caption, collapse="\n") mtext(text=caption, line=line, outer=TRUE, cex=cex * par("cex")^.333, col=col, font=font) } caption } get.caption <- function(nfigs, do.par, caption, resp.name, type, model.call, object.name, my.call) { stopifnot.string(caption, null.ok=TRUE, allow.empty=TRUE) if(nfigs > 1 && do.par && (is.null(caption) || !is.null(my.call))) auto.caption(caption, resp.name, type, model.call, object.name, my.call) else paste0(if(is.null(caption)) "" else caption, if(!is.null(caption) && !is.null(my.call)) "\n" else "", if(!is.null(my.call)) "" else process.my.call.for.caption(my.call)) } process.my.call.for.caption <- function(my.call) { s <- "" if(!is.null(my.call)) { s <- sub("\\(object=", "(", my.call) # delete object= s <- sub(", trace=[-._$[:alnum:]]+", "", s) # delete trace=xxx s <- sub(", SHOWCALL=[-._$[:alnum:]]+", "", s) # delete SHOWCALL=xxx } s # a string, may be "" } earth/R/as.char.R0000644000176200001440000002257014564051603013232 0ustar liggesusers# as.char.R: brief description of an object as a string e.g. "c(1,2)" # this file also includes print_summary for matrices and data.frames as.char <- function(object, maxlen=20) { check.integer.scalar(maxlen, min=1) if(is.null(object)) "NULL" else if(is.name(object)) paste.trunc(object, maxlen=maxlen) # e.g. "..3" for unforced dot args else if(is.environment(object)) environment.as.char(object) else if(is.call(object)) { # e.g. x is a call object in foo(x=1:3) s <- strip.space.collapse(format(object)) if(nchar(s) > maxlen) s <- paste0(substr(s, 1, maxlen), "...)") s } else if(NCOL(object) == 1 && is.character(object)) paste.c(paste0("\"", object, "\"")) else if(NCOL(object) == 1 && is.logical(object)) paste.c(object) else if(NCOL(object) == 1 && is.numeric(object)) { # digits=4 is arb but seems about right, and zapsmall means more can # be displayed in limited space if just one val is say 3.553e-15 paste.c(signif(zapsmall(object, digits=4), digits=4)) } else if(length(dim(object)) == 2) sprint("%s[%g,%g]", class(object)[1], NROW(object), NCOL(object)) else if(class(object)[1] == "list") # not is.list() because e.g. lm objects are lists paste0("list(", paste.trunc(list.as.char(object), maxlen=maxlen+12), ")") else if(inherits(object, "Date")) paste0("Date:", paste.trunc(object, maxlen=maxlen+12)) else paste0(class.as.char(object), ".object") } # compact description of an object's class # typically quotify=TRUE for error messages (full class name with quotes), # and quotify=FALSE for trace messages (just first field of class name, no quotes) class.as.char <- function(object, quotify=FALSE) { if(quotify) quotify(paste.trunc(class(object), collapse=",", maxlen=60)) else class(object)[1] } # compact description of a list # maxlen is max length of each list element (not of the entire list) list.as.char <- function(object, maxlen=20) { stopifnot(is.list(object) || is.pairlist(object)) s <- "" names <- names(object) for(i in seq_along(object)) { if(i != 1) s <- sprint("%s, ", s) name.ok <- length(names) >= i && !is.na(names[i]) && nzchar(names[i]) if(name.ok && names[i] == "...") s <- sprint("%s...", s) # print dots as ... not as ...=pairlist.object else { if(name.ok) s <- sprint("%s%s=", s, names(object)[i]) s <- sprint("%s%s", s, as.char(object[[i]], maxlen=maxlen)) } } s # one element character vector e.g "x=1, 2" } environment.as.char <- function(env, maxlen=60) # compact description { if(is.null(env)) # illegal, but we still want to format it return("env(NULL)") stopifnot(is.environment(env)) # format(env) returns "" stripped.env <- gsub("", "", format(env)[1]) # if it's a standard environment return the environment's name if(grepl("^namespace:|^R_[[:alnum:]]+Env", stripped.env)) stripped.env # something like "namespace:stats" or "R_GlobalEnv" else # return the names of the objects in the environment sprint("env(%s)", paste.trunc(paste0(ls(env, all.names=TRUE), collapse=", "), maxlen=maxlen)) } # The main purpose of this routine is to summarize matrices and data.frames, # but it will also (semi)gracefully handle any object that is passed to it. # # Note that this only does anything if trace >= 2. # # If x is a matrix or dataframe or similar, print first few rows and last row. # If trace >= 4, then print all rows and cols, up to 1000 rows and 100 cols. # # the details argument: # 0=don't print data, print the colnames truncated to one line of output # 1=don't print data, print all colnames # -1=like print data but don't prefix the output with spaces # 2=print the data print_summary <- function(x, xname=trunc.deparse(substitute(x)), trace=2, msg="", prefix="", details=2) { check.numeric.scalar(trace) if(trace < 2) return() if(is.null(x)) { printf("%s: NULL\n", xname) return() } if(length(x) == 0) { printf("%s: length zero\n", xname) return() } # try(data.frame(), silent=TRUE) is not actually silent # for language objects, so handle them specially if(is.language(x)) { x$na.action <- NULL # don't want to print the na.action if there is one s <- try(format(x)) max <- if(trace <= 2) 8 else 1000 if(length(s) > max) { s <- s[1:max] s[max] <- paste(s[max], "\n...") } s <- gsub("[ \t\n]", "", s) # remove white space s <- gsub(",", ", ", s) # replace comma with comma space s <- paste(s, collapse="\n ", sep="") printf("%s%s%s:\n%s\n", prefix, xname, msg, s) return() } if(is.list(x) && !is.data.frame(x)) { # data.frames are lists, hence must check both if(details < 2 && trace < 4) { printf("%s: list with elements %s\n", xname, quotify.trunc(paste(names(x)))) return() } printf("%s ", xname) str(x) return() } df <- try(my.data.frame(x, trace, stringsAsFactors=FALSE), silent=TRUE) if(is.try.err(df)) { # be robust for whatever gets passed to this function printf("print_summary: cannot convert class \"%s\" to a data.frame (%s)\n", class(x)[1], cleantry(df)) printf("%s%s%s:\n", prefix, xname, msg) if(length(dim(x)) == 2) { # it's a matrix or other 2D object? if(trace >= 4) { try(print_with_strings_quoted(x)) try(print(summary(x))) } else { try(print_with_strings_quoted(head(x))) printf("...\n") } } else try(print_with_strings_quoted(x)) return() } if(details < 2 && trace < 4) { # don't print the data, just the dimensions and colnames if(details != -1) printf(" ") printf("%s%s[%d,%d]%s ", prefix, xname, nrow(df), ncol(df), msg) print_colnames(x, full=details == 2, newline="") if(NCOL(x) == 1 || NROW(x) == 1) # if a vector, print first few values cat0(", and values ", # if double, print 4 significant digits paste.trunc(if(is.double(x)) sprint("%.4g", x) else x, collapse=", ", maxlen=32)) cat0("\n") return() } colnames <- safe.colnames(x) printf("%s%s[%d,%d]%s%s:\n", prefix, xname, nrow(df), ncol(df), msg, if(is.null(colnames)) " with no column names" else "") df.short <- df maxrows <- if(trace >= 4) 1000 else 5 if(maxrows < nrow(df)) { df.short <- df[c(1:(maxrows-1), nrow(df)), , drop=FALSE] if(is.null(rownames(df.short))) rownames(df.short) <- c(1:(maxrows-1), nrow(df)) rownames(df.short)[maxrows-2+1] <- "..." } maxcols <- if(trace >= 4) 100 else 10 if(maxcols < ncol(df)) { df.short[,maxcols] <- "..." df.short <- df.short[, 1:maxcols, drop=FALSE] if(!is.null(colnames)) colnames(df.short)[maxcols] <- "..." } try(print_with_strings_quoted(df.short)) is.fac <- sapply(df, is.factor) if(is.null(colnames)) colnames(df) <- sprint("[,%d]", seq_len(NCOL(x))) if(any(is.fac)) { names <- paste0(colnames(df), ifelse(sapply(df, is.ordered), "(ordered)", "")) if(sum(is.fac) == 1) # only one fac, so enough space to print levels too printf(" %s is a factor with levels: %s\n", paste.trunc(names[is.fac]), paste.trunc(levels(df[,is.fac]))) else printf(" factors: %s\n", paste.trunc(names[is.fac])) } if(trace >= 4) try(print(summary(df))) } print_colnames <- function(x, full=FALSE, newline="\n") { colnames <- safe.colnames(x) if(is.null(colnames)) printf("with no column names%s", newline) else { colnames[which(colnames == "")] <- "\"\"" if(full) # full colnames (up to 1000 characters) printf("with colname%s %s%s", if(length(colnames(x)) > 1) "s" else "", paste.trunc(colnames, maxlen=max(25, getOption("width")-20)), newline) else # short version of colnames printf.wrap("with colname%s %s%s", if(length(colnames(x)) > 1) "s" else "", paste.trunc(colnames), newline) } } # Like print but puts quotes around strings. # Useful for disambiguating strings from factors. # # "..." is not quoted because it is used as a # "something was deleted" indicator in print_summary print_with_strings_quoted <- function(x) { if(length(dim(x)) == 2) for(j in seq_len(NCOL(x))) if(is.character(x[,j])) for(i in seq_along(x[,j])) if(x[i,j] != "...") x[i,j] <- paste0("\"", x[i,j], "\"") print(x) } earth/R/bpairs.R0000644000176200001440000003104614565632020013170 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.R0000644000176200001440000002150314565632067014405 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") 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") colnames(object$fitted.values) <- resp.names colnames(object$residuals) <- resp.names colnames(object$coefficients) <- resp.names dirs <- object$factor[object$all.terms, , drop=FALSE] modvars <- get.identity.modvars(dirs) # incorrect if terms like sqrt(num) in formula 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 # return fields in approximately the same order as earth.default rval <- structure(list( rss = rss, rsq = get.rsq(rss, rss.per.subset[1]), gcv = gcv, grsq = get.rsq(gcv, gcv.per.subset[1]), 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() fitted.values = object$fitted.values, residuals = residuals, coefficients = object$coefficients, 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, leverages = leverages, pmethod = "backward", nprune = NULL, penalty = object$penalty, nk = object$nk, thresh = object$thresh, call = newcall, namesx = rownames(modvars), modvars = modvars), 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.R0000644000176200001440000001476513727277535013767 0ustar liggesusers# expand.arg.R: # # This module provides, amongst others, the following function: # # expand.arg(x, env, is.y.arg, name) # Expand factors in x and convert to double mat with col names # Called by earth.formula, earth.default, get.earth.x # #----------------------------------------------------------------------------- # Return x with all values converted to double, and with factors expanded to ind cols. # # Always returns a matrix (never a vector) and always with column names. # # Factors in earth's y argument (is.y.arg==TRUE) are alays expanded # using contr.earth.response(), even if the factors are ordered. # i.e. one indicator column for each factor level. # # The internal strategy here is essentially: # if(x is already double) # return x unchanged (but add colnames if necessary) # else # convert x to a data.frame and invoke model.frame and model.matrix 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 name=NULL) # used for colnames when x has no name { expand.arg.modvars(x, env, trace, is.y.arg, name)$x } # like expand.arg but also return the modvars matrix # (modvars translates from the expanded x colnames to original var names) expand.arg.modvars <- 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 name=NULL) # used for colnames when x has no name { if(is.null(ncol(x))) # ensure 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.resp.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, name, if(is.y.arg) "y" else "x", trace) return(list(x=x, modvars=get.identity.modvars(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")) } colnames(x) <- gen.colnames(x, name, if(is.y.arg) "y" else "x", trace) x <- as.data.frame(x) ncol.org <- ncol(x) mf <- call("model.frame", formula = ~., data=x, na.action=na.pass) mf <- eval(mf, envir=env) terms <- terms(mf) x <- model.matrix(object=attr(mf, "terms"), data=mf) # the "assign" attribute has an entry for each column in x # giving the term in the formula which gave rise to the column xassign <- attr(x, "assign") xassign <- xassign[-1] # delete response (-1 correct even with multiple responses) intercept <- match("(Intercept)", colnames(x), nomatch=0) if(intercept) x <- x[, -intercept, drop=FALSE] # discard intercept # If x had only one col, model.matrix sometimes prepends "x" to the col names. # This seems to always happen if the column of x was a factor (which gets # expanded to multiple columns), but sometimes at other times. I don't know why. # If so, remove the "x" prefix. colnamesx <- colnames(x) if(ncol.org == 1 && all(substr(colnamesx, 1, 1) == "x") && # don't strip prefix if colnames are c("x","y") or c("x","x3") all(nchar(colnamesx[1]) > 1) && # don't strip x. prefix from orded factors (which get expanded to x.L x.Q x.C ..) any(substr(colnamesx, 1, 2) != "x.")) { # remove the "x" prefix. colnames(x) <- substr(colnamesx, 2, 61) # strip 1st char of each colname } list(x=x, # all cols of x are now of type double, with column names modvars=get.modvars(x, xassign, terms)) } # 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 } # 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.resp.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 N columns # if nbr unique strings is N, which is incorrect, so block that here stop0("y is a character variable: ", paste.with.quotes(y, maxlen=40)) } 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.R0000644000176200001440000000055114156173160013500 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.R0000644000176200001440000001323713717413343013705 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/earth.fit.R0000644000176200001440000011016414565632542013604 0ustar liggesusers# earth.fit.R: # # Functions are in alphabetical order. # 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 } 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 } 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) } # 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) } 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]) } # 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 && all(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.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) } # 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 } 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) } } } 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_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_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") } } } 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") } } 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 } earth/R/predict.earth.R0000644000176200001440000001536113730221233014437 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.R0000644000176200001440000004232414565631517013604 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.R0000644000176200001440000000436313713432451013200 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.collapse(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) } # 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.R0000644000176200001440000000710513443327320014452 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.R0000644000176200001440000000664213723577313013201 0ustar liggesusers# dotlib.R: miscellaneous functions for the dots routines # Arguments for par() which take a vector value (i.e. length of value is not one). PAR.VEC <- c("fig", "fin", "lab", "mai", "mar", "mfcol", "mfg", "mfrow", "mgp", "oma", "omd", "omi", "pin", "plt", "usr", "xaxp", "yaxp") # Add the elements of the extra list to the original list. Elements of the # original list that have the same names as extra elements get overwritten. # # Like utils::modifyList(keep.null=TRUE) except: # (i) input args can be NULL (NULL is treated as an empty list) # (ii) unnamed elements in extra are added to original (modifyList drops them) merge.list <- function(original, extra) { if(is.null(original)) original <- list() if(is.null(extra)) return(original) stopifnot(is.list(original)) stopifnot(is.list(extra)) # pairlist would probably be ok too for(i in seq_along(extra)) { e <- extra[[i]] name <- names(extra)[i] if(is.null(name) || !nzchar(name)) # extra element is unnamed? original <- c(original, if(is.null(e)) list(NULL) else e) else if(is.null(e)) original[name] <- list(NULL) # avoid "assign deletes elem if rhs is null" else original[[name]] <- e } original } # Evaluate each element of the list dots in the environment specified by n. # (This function can actually be used any list, but the evaluating # environment and enclosure are set up for dot arg lists.) # # TODO "scalar" is ugly, it is for par() alone and prevents # e.g. error: graphical parameter "lty" has the wrong length eval.dotlist <- function(dots, n=1, scalar=FALSE) { stopifnot(is.list(dots) || is.pairlist(dots)) env <- parent.frame(n) dotnames <- names(dots) for(i in seq_along(dots)) { e <- try(eval(dots[[i]], envir=env, enclos=env), silent=TRUE) if(!is.try.err(e)) { if(is.null(e)) dots[i] <- list(NULL) # avoid "assign deletes elem if rhs is null" else if(!scalar || (dotnames[i] %in% PAR.VEC) || length(e) == 1) dots[[i]] <- e else dots[[i]] <- e[[1]] # select first element of e only # TODO it would be better to drop the element entirely } } dots } # Is the string s a valid R lexigraphic identifier? # If allow.specials=TRUE we allow special chars used in DROP and KEEP strings. # The name argument is used only in error messages. stopifnot.identifier <- function(s, name=short.deparse(substitute(s)), allow.empty=FALSE, allow.specials=FALSE) { if(!is.character(s)) stop0(name, " is not a character variable (class(", name, ") is \"", class(s)[1], "\")") if(length(s) != 1) stop0(name, " has more than one element\n ", name, " = c(", paste.trunc("\"", s, "\"", sep=""), ")") if(!allow.empty && !nzchar(s)) stop0(name, " is an empty string") # TODO the following allows integers (no alphabetic characters), it shouldn't start <- if(allow.specials) # include , * $ regexpr("[^._:[:alnum:],*$]", s) else regexpr("[^._:[:alnum:]]", s) if(start > 0) stop0("illegal character \"", substr(s, start, start), "\" in ", name, " = \"", s, "\"") } earth/R/lib.R0000644000176200001440000012676214565632361012500 0ustar liggesusers# lib.R: miscellaneous functions for plotmo and related packages # functions in this file are in alphabetical order any1 <- function(x) { any(x != 0) # like any but no warning if x not logical } cat0 <- function(...) # cat with no added spaces { cat(..., sep="") } check <- function(object, object.name, check.name, check.func, na.ok=FALSE) { any <- check.func(object) if(na.ok) any <- any[!is.na(any)] else { which.na <- which(is.na(any)) if(length(which.na)) { stopf("NA in %s\n %s[%d] is %g", object.name, object.name, which.na[1], object[which.na[1]]) } } if(any(any)) { which <- which(check.func(object)) stopifnot(length(which) > 0) stopf("%s in %s\n %s[%d] is %g", check.name, object.name, object.name, which[1], object[which[1]]) } } # TODO commented out the following because it is too slow for big data # (the as.character is very slow) # # # The args argument is assumed to be a list of arguments for do.call. # # An argument in args will be an unforced promise if it couldn't be # # evaluated earlier e.g. if call.plot was invoked with arg=nonesuch. # # If an argument is such an unforced promise, issue an error message now # # to prevent very confusing error messages later. To do this, we have to # # determine if the arg is a promise, which we do with the if statement # # below. # # This makes me nervous, because the R language manual says "There is # # generally no way in R code to check whether an object is a promise or not". # # check.do.call.args <- function(func, args, fname) # { # stopifnot(is.list(args)) # for(i in seq_along(args)) { # if(length(args[i]) == 1 && !is.na(args[i]) && # substr(as.character(args[i]), 1, 2) == "..") { # printf("\n") # s <- paste0(strwrap(list.as.char(args), # width=getOption("width"), exdent=7), collapse="\n") # stop0("cannot evaluate ", quotify(names(args)[i], "'"), # " in\n ", fname, "(", s, ")") # } # } # } # mostly for checking user arguments (so error wording is for that) # but also occasionally used for other sanity checking check.boolean <- function(b) # b==0 or b==1 is also ok { if(length(b) != 1) stop0("the ", short.deparse(substitute(b), "given"), " argument is not FALSE, TRUE, 0, or 1") if(!(is.logical(b) || is.numeric(b)) || is.na(b) || !(b == 0 || b == 1)) stop0(short.deparse(substitute(b), "the argument"), "=", as.char(b), " but it should be FALSE, TRUE, 0, or 1") b != 0 # convert to logical } is.boolean <- function(b) # b==NA or b==0 or b==1 { length(b) == 1 && (is.logical(b) || is.numeric(b)) && (is.na(b) || b == 0 || b == 1) } check.classname <- function(object, substituted.object, allowed.classnames) { expected.classname <- quotify(allowed.classnames) if(length(allowed.classnames) > 1) expected.classname <- sprint("one of\n%s", expected.classname) if(is.null(object)) stopf("object is NULL but expected an object of class of %s", expected.classname) if(!inherits(object, allowed.classnames)) { stopf("the class of %s is \"%s\" but expected the class to be %s", quotify(paste.trunc(substituted.object, maxlen=30)), class(object)[1], expected.classname) } } # adjust name so e.g. error message is "argument is NULL" not "NULL is NULL" tweak.name <- function(name, quote=TRUE) { quoted.name <- quotify(name, quote="'") if(name %in% c("NULL", "NA") || (substr(name[1], 1, 1) %in% c("+", "-")) || grepl("[0-9]", substr(name[1], 1, 1))) { quoted.name <- name <- "argument" } if(quote) quoted.name else name } check.integer.scalar <- function(object, min=NA, max=NA, null.ok=FALSE, na.ok=FALSE, logical.ok=TRUE, char.ok=FALSE, object.name=short.deparse(substitute(object))) { stop.msg <- function(s) { s.null <- if(null.ok) ", or NULL" else "" s.na <- if(na.ok) ", or NA" else "" s.logical <- if(logical.ok) ", or TRUE or FALSE" else "" s.char <- if(char.ok) ", or a string" else "" stop0(s, " but it should be an integer", s.null, s.na, s.logical, s.char) } if(is.character(object)) { if(!char.ok || length(object) != 1) stop.msg(paste0(tweak.name(object.name), " is a string")) } else { check.numeric.scalar(object, min, max, null.ok, na.ok, logical.ok, char.ok.msg=char.ok, object.name=object.name) if(!is.null(object) && !is.na(object) && object != floor(object)) stop.msg(paste0(tweak.name(object.name, quote=FALSE), "=", object[1])) } object } check.level.arg <- function(level, zero.ok) { if(anyNA(level) || is.null(level)) # treat NA and NULL as 0 level <- 0 check.numeric.scalar(level) if(!((zero.ok && level == 0) || level >= .5 || level < 1)) { stop0("level=", level, " but it should be ", if(zero.ok) "zero or " else "", "between 0.5 and 1") } level } check.no.na.in.mat <- function(object) { if(anyNA(object)) { # quick initial check # detailed check for detailed error message for(icol in seq_along(ncol(object))) { check.name <- if(!is.null(colnames(object))) colnames(object)[icol] else sprint("%s[,%d]", short.deparse(substitute(object), "matrix"), icol) check(object[,icol], check.name, "NA", is.na, na.ok=FALSE) } } } # x can be a data.frame or matrix check.df.numeric.or.logical <- function(x, xname=trunc.deparse(substitute(x))) { stopifnot(!is.null(x), length(dim(x)) == 2) for(icol in seq_len(NCOL(x))) { if(!is.numeric(x[,icol]) && !is.logical(x[,icol])) stopf("the class of %s is \"%s\" (expected numeric or logical)", colname(x, icol, xname), class(x[,icol])) is.na <- is.na(x[,icol]) if(any(is.na)) stopf("%s[%g] is NA", colname(x, icol, xname), which(is.na)[1]) is.infinite <- !is.finite(x[,icol]) if(any(is.infinite)) stopf("%s[%g] is Inf", colname(x, icol, xname), which(is.infinite)[1]) } } check.numeric.scalar <- function(object, min=NA, max=NA, null.ok=FALSE, na.ok=FALSE, logical.ok=FALSE, char.ok.msg=FALSE, # only affects error msg object.name=short.deparse(substitute(object))) { s.logical <- if(logical.ok) ", or TRUE or FALSE" else "" if(na.ok) logical.ok <- TRUE # needed because NA is a logical any.na <- !is.null(object) && # following needed because anyNA gives error on some objects (is.numeric(object) || is.logical(object) || is.list(object) || is.character(object)) && anyNA(object) if(is.null(object)) { if(!null.ok) stop0(tweak.name(object.name), " is NULL") } else if(any.na && !na.ok) stop0(tweak.name(object.name), " is NA") else if(!is.numeric(object) && !(is.logical(object) && logical.ok)) { s.na <- if(na.ok) ", or NA" else "" s.null <- if(null.ok) ", or NULL" else "" s.char <- if(char.ok.msg) ", or a string" else "" stopf("%s must be numeric%s%s%s%s (whereas its current class is %s)", tweak.name(object.name), s.null, s.na, s.char, s.logical, class.as.char(object, quotify=TRUE)) } else if(length(object) != 1) stopf("the length of %s must be 1 (whereas its current length is %d)", tweak.name(object.name), length(object)) if(!is.null(object) && !any.na) { if(!is.na(min) && !is.na(max) && (object < min || object > max)) { stop0(tweak.name(object.name, quote=FALSE), "=", object, " but it should be between ", min, " and ", max) } if(!is.na(min) && object < min) { stop0(tweak.name(object.name, quote=FALSE), "=", object, " but it should be at least ", min) } if(!is.na(max) && object > max) { stop0(tweak.name(object.name, quote=FALSE), "=", object, " but it should not be greater than ", max) } } object } # We allow 20% of x to be nonpositive, useful if the response is essentially # positive, but the predicted response has a few nonpositive values at the extremes. # Needed for example if we will later take log(x) or sqrt(x). check.that.most.are.positive <- function(x, xname, user.arg, non.positive.msg, frac.allowed=.2) { check.numeric.scalar(frac.allowed) stopifnot(frac.allowed >= 0, frac.allowed <= 1) nonpos <- x <= 0 if(sum(nonpos, na.rm=TRUE) > frac.allowed * length(x)) { # more than frac.allowed nonpos? ifirst <- which(nonpos)[1] stop0(sprint( "%s is not allowed because too many %ss are %s\n", user.arg, unquote(xname), non.positive.msg), sprint( " %.2g%% are %s (%g%% is allowed)\n", 100 * sum(nonpos) / length(x), non.positive.msg, 100 * frac.allowed), sprint(" e.g. %s[%d] is %g", unquote(xname), ifirst, x[ifirst])) } } check.vec <- function(object, object.name, expected.len=NA, logical.ok=TRUE, na.ok=FALSE) { if(!(NROW(object) == 1 || NCOL(object) == 1)) stop0(tweak.name(object.name), " is not a vector\n ", "It has dimensions ", NROW(object), " by ", NCOL(object)) if(!((logical.ok && is.logical(object)) || is.numeric(object))) stop0(tweak.name(object.name), " is not numeric") if(!is.na(expected.len) && length(object) != expected.len) stop0(tweak.name(object.name), " has the wrong length ", length(object), ", expected ", expected.len) if(na.ok) object[is.na(object)] <- 1 # prevent check is.finite from complaining else check(object, object.name, "NA", is.na) check(object, object.name, "non-finite value", function(object) {!is.finite(object)}) } cleantry <- function(err) # clean up a try.err (remove "Error: " etc.) { stopifnot(is.try.err(err)) attributes(err) <- NULL err <- gsub("^[^:]*: *", "", err) # remove "Error: " (actually everything up to the first colon) err <- gsub("\n", " ", err, fixed=TRUE) # remove newlines err <- gsub(" +", " ", err) # multiple spaces to single spaces gsub(" $", "", err) # remove trailing space } # returns the column name, if that is not possible then something like x[,1] colname <- function(object, i, object.name=trunc.deparse(substitute(object))) { check.numeric.scalar(i) check.index(i, object.name, object, is.col.index=TRUE, allow.negatives=FALSE) colnames <- safe.colnames(object) if(!is.null(colnames)) colnames[i] else if(NCOL(object) > 1) sprint("%s[,%g]", object.name, i) else sprint(object.name) } # if trace>0 or the func fails, then print the call to func do.call.trace <- function(func, args, fname=short.deparse(deparse(func), "FUNC"), trace=0) { stopifnot(is.logical(trace) || is.numeric(trace), length(trace) == 1) # TODO commented out the following because it is too slow for big data # check.do.call.args(func, args, fname) trace <- as.numeric(trace) if(trace > 0) printf.wrap("%s(%s)\n", fname, list.as.char(args)) try <- try(do.call(what=func, args=args), silent=TRUE) if(is.try.err(try)) { if(trace == 0) # didn't print call above? then print it now printf.wrap("\n%s(%s)\n\n", fname, list.as.char(args)) else if(trace >= 2) # TODO is this best? printf("\n") # Re-call func so user can do a traceback within the function. Note that # if do.call.trace was called with try, this will be caught by that try. # TODO is there a better way to achieve this, perhaps using tryCatch # this could be confusing if func has side effects (unlikely) do.call(what=func, args=args) # should never get here stop0("second do.call(", fname, ", ...) did not give the expected error: ", try[1]) } invisible(try) # TODO is invisible necessary? } # identical to base::eval() but has trace and expr.name arguments eval.trace <- function( expr, envir = parent.frame(), enclos = if(is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv(), trace = 0, expr.name = NULL) { stopifnot(is.environment(envir)) stopifnot(is.environment(enclos)) if(trace >= 2) printf("eval(%s, %s)\n", if(is.null(expr.name)) trunc.deparse(substitute(expr)) else expr.name, environment.as.char(envir)) eval(expr, envir, enclos) } exp10 <- function(x) # e.g. exp10(-3) = 1e-3 { exp(x * log(10)) } # This function is used for checking both xlim and ylim. # This checks that lim is is a 2 element numeric vector. # Also, if xlim[1] == xlim[2], then plot() issues a confusing message. # We don't want that, so use this function to make sure xlim[2] # is different to xlim[1]. fix.lim <- function(lim) { if(!is.null(lim) && !inherits(lim, "Date")) { stopifnot(is.numeric(lim), length(lim) == 2) # constants below are arbitrary small <- max(1e-6, .01 * abs(lim[1] - lim[2])) if(abs(lim[2] - lim[1]) < small) # illegal lim? lim <- c(lim[1] - small, lim[2] + small) } lim } # Ensure all columns of x have column names. Won't overwrite existing column names. gen.colnames <- function(x, prefix="x", alt.prefix=prefix, trace=0) { if(NCOL(x) == 0) return(NULL) # If prefix is long and has characters like ( or [ then use the # alternate prefix. This is sometimes necessary when prefix is # generated using deparse and the arg is something like # "cbind(trees$Volume,trees$Volume+100)" if(any(nchar(prefix) > 30) && grepany("[([,]", prefix)) { trace2(trace, "using alt.prefix \"%s\" instead of prefix \"%s\"\n", alt.prefix, prefix) prefix <- alt.prefix } stopifnot(length(prefix) <= NCOL(x)) prefix <- substr(prefix, 1, 60) new.colnames <- if(NCOL(x) == length(prefix)) prefix else if(grepany("\\[", prefix)) new.colnames <- paste0(prefix, "[", seq_len(NCOL(x)), "]") else new.colnames <- paste0(prefix, seq_len(NCOL(x))) colnames <- org.colnames <- colnames(x) if(is.null(colnames)) colnames <- new.colnames else { missing <- !nzchar(colnames) if(any(missing)) colnames[missing] <- new.colnames[missing] } if(length(unique(colnames)) != length(colnames)) stop0("Duplicate colname in ", paste.trunc(prefix), " (colnames are ", paste.with.quotes(colnames, maxlen=60), ")") if(trace >= 2 && !identical(org.colnames, colnames)) trace2(trace, "colname%s %s now %s\n", if(length(colnames) > 1) "s were" else " was", if(is.null(org.colnames)) "NULL" else paste.trunc(quotify(org.colnames)), paste.trunc(quotify(colnames))) colnames } get.mean.rsq <- function(rss, tss, wp) { if(is.null(wp)) wp <- repl(1, length(rss)) stopifnot(length(rss) == length(tss), length(wp) == length(tss)) total.rsq <- 0 for(iresp in seq_along(rss)) total.rsq <- total.rsq + wp[iresp] * get.rsq(rss[iresp], tss[iresp]) sum(total.rsq) / sum(wp) } # Get the environment for evaluating the model data: # 1. Return the environment in which the model function # was originally called. # 2. Else if the model already has an attribute .Environment, use that. # 3. Else return the environment in which the caller of this function # was called (e.g. return the environment of plotmo's caller). get.model.env <- function(object, object.name="object", trace=0, use.submodel=FALSE) { # check args, because this func is called very early in plotmo (and friends) check.numeric.scalar(trace, logical.ok=TRUE) if(trace >= 2) { callers.name <- callers.name() my.call <- call.as.char(n=2) printf.wrap("%s trace %g: %s\n", callers.name, trace, my.call) printf("--get.model.env for object with class %s\n", class.as.char(object)) } stopifnot.string(object.name) if(is.null(object)) stopf("argument %s is NULL", object.name) if(!is.list(object)) stopf("%s is not an S3 model", object.name) if(class(object)[1] == "list") # some packages build models without a specific class stopf("%s is a plain list, not an S3 model", object.name) obj <- object # Special handling for parsnip models. Their class is like c("_earth", "model_fit"). # For these models, use the env if any saved with the submod (e.g. earth) # (We don't do this for caret models because caret models have a terms field.) # # TODO this code is preliminary (works with parsnip 0.1.3) # and only works if model saves the data (e.g. lm, earth(keepxy=TRUE), not rpart if(use.submodel && inherits(object, "model_fit")) { # parsnip trace2(trace, "plotmo parsnip model: will plot %s$fit, not %s itself\n", gsub("'", "", object.name), object.name) obj <- object[["fit"]] if(!is.list(obj)) # sanity check stopf("plotmo parsnip model: %s$fit is not an S3 model", gsub("'", "", object.name)) # TODO following is temporary, hopefully if(inherits(obj, "rpart") && is.null(obj$model)) stop0( "Cannot plot parsnip rpart model: need model=TRUE in call to rpart\n", " Do it like this: set_engine(\"rpart\", model=TRUE)") } if(trace >= 2) { call <- getCall(obj) if(is.null(call)) printf("object has no call field (it's class is %s)\n", class.as.char(object)) else printf.wrap("object call is %s\n", strip.deparse(call), maxlen=120) } terms <- try(terms(obj), silent=trace < 3) # Following will fail (correctly) for non-formula models because they have no terms. # # TODO Also, if use.submodel, don't use terms (because the term env was # inside the parsnip func that created the submodel) # But that also fails later when we eval the formula because # eval will use GlobalEnv instead of the data passed to the model if(!is.null(terms) && !is.try.err(terms)) { model.env <- attr(terms, ".Environment") if(is.null(model.env)) { if(inherits(obj, "glmnet.formula") || # glmnetUtils package inherits(obj, "cv.glmnet.formula")) if(inherits(obj, "glmnet.formula")) stop0( "for this plot, glmnet.formula must be called with use.model.frame=TRUE") if(inherits(obj, "cv.glmnet.formula")) stop0( "for this plot, cv.glmnet.formula must be called with use.model.frame=TRUE") stop0("attr(terms, \".Environment\") is NULL") } if(!is.environment(model.env)) stop0("attr(terms, \".Environment\") is not an environment") else { trace2(trace, "using the environment saved in $terms of the %s model: %s\n", class.as.char(obj), environment.as.char(model.env)) return(model.env) } } model.env <- attr(obj, ".Environment") if(is.environment(model.env)) { trace2(trace, "using attr(obj,\".Environment\") saved with %s model: %s\n", class.as.char(obj), environment.as.char(model.env)) return(model.env) } if(!is.null(model.env)) stop0("attr(obj, \".Environment\") is not an environment") # n=2 is the caller of the function that called get.model.env # for plotmo it will be the caller of plotmo, typically R_GlobalEnv model.env <- parent.frame(n=2) trace2(trace, "assuming the environment of the %s model is that of %s's caller: %s\n", class.as.char(obj), callers.name, environment.as.char(model.env)) model.env } get.rsq <- function(rss, tss) { rsq <- 1 - rss / tss # following makes testing easier across machines in presence of numerical error rsq[rsq > -1e-5 & rsq < 1e-5] <- 0 rsq } get.weighted.rsq <- function(y, yhat, w=NULL) # NAs will be dropped before calc { stopifnot(length(y) > 0, length(y) == length(yhat)) if(is.null(w)) { is.na <- is.na(y) | is.na(yhat) y <- y[!is.na] yhat <- yhat[!is.na] if(length(y) == 0) stop0("length(y) == 0 after deleting NAs in y or yhat") rss <- sos(y - yhat) tss <- sos(y - mean(y)) } else { stopifnot(length(w) == length(yhat)) is.na <- is.na(y) | is.na(yhat) | is.na(w) y <- y[!is.na] yhat <- yhat[!is.na] w <- w[!is.na] if(length(y) == 0) stop0("length(y) == 0 after deleting NAs in y or yhat or w") rss <- sos(y - yhat, w) tss <- sos(y - weighted.mean(y, w), w) } get.rsq(rss, tss) } # TRUE if pattern is in any of the strings in x grepany <- function(pattern, x, ignore.case=FALSE, ...) { any(grepl(pattern, x, ignore.case=ignore.case, ...)) } # scalar form of ifelse, with short name :-) # only evaluates the "no" argument if necessary ife <- function(ife.test, ife.yes, ife.no) { ife.test <- check.boolean(ife.test) stopifnot(!missing(ife.yes)) stopifnot(!missing(ife.no)) if(ife.test) ife.yes else ife.no } # returns an index, choices is a vector of strings imatch.choices <- function(arg, choices, argname=short.deparse(substitute(arg), "function"), errmsg.has.index=FALSE, # TRUE if integer "arg" is legal elsewhere errmsg="", # error message, "" for automatic errmsg.ext="") # extension to error message { errmsg.ext <- paste0( if(errmsg.has.index) " an integer index or" else "", if(nchar(errmsg.ext)) paste0(" ", errmsg.ext, " or") else "") if(nchar(errmsg) == 0) errmsg <- sprint("Choose%s one of: %s", errmsg.ext, quotify(choices)) if(!is.character(arg) || length(arg) != 1 || !nzchar(arg)) stopf("illegal %s argument\n%s", quotify(argname, "'"), errmsg) if(argname %in% c("NULL", "NA")) argname <- "argument" imatch <- pmatch(arg, choices) if(anyNA(imatch)) { imatch <- NULL for(i in seq_along(choices)) if(pmatch(arg, choices[i], nomatch=0)) imatch <- c(i, imatch) if(length(imatch) == 0) { if(length(choices) == 1) stopf("%s=\"%s\" is not allowed\n Only%s %s is allowed", argname, paste(arg), errmsg.ext, quotify(choices)) else stopf("%s=\"%s\" is not allowed\n%s", argname, paste(arg), errmsg) } if(length(imatch) > 1) stopf("%s=\"%s\" is ambiguous\n%s", argname, paste(arg), errmsg) } imatch } # TRUE if all values in object are integers, ignoring NAs # assumes object is numeric or logical (check this before call this function) is.integral <- function(object) { object <- object[!is.na(object)] length(object) > 0 && is.null(dim(object)) && # prevent error in floor for e.g. survival objects all(floor(object) == object) } # is.specified's main purpose is to see if a plot component should be # drawn, i.e., to see if the component "has a color" is.specified <- function(object) { try <- try(!is.null(object) && !anyNA(object) && !is.zero(object) && # following needed for e.g. col=c("red", 0) because 0 is converted to string !identical(object, "0") && !identical(object, "0L") && !identical(object, "NA"), silent=FALSE) if(is.try.err(try)) { # this occurs if object is say a closure and anyNA fails # anyNA was introduced in R 3.1.0 printf("\n") # separate from any message printed by try() above stop0(deparse(substitute(object)), ": illegal value") } try } is.try.err <- function(object) { class(object)[1] == "try-error" } is.zero <- function(object) # needed because identical(object, 0) fails if object is 0L { identical(object, 0) || identical(object, 0L) } # Lighten color by amount 0 ... 1 where 1 is white. # If amount is negative, then darken the color, -1 is black. lighten <- function(col, lighten.amount, alpha=1) { # stopifnot.scalar(lighten.amount) # stopifnot(lighten.amount >= -1 && lighten.amount <= 1) rgb <- col2rgb(col) / 255 # empirically, sqrt makes visual effect of lighten.amount more linear lighten.amount2 <- sqrt(abs(lighten.amount)) rgb <- if(lighten.amount > 0) rgb + lighten.amount2 * (c(1,1,1) - rgb) # move each r,g,b towards 1 else # darken rgb - lighten.amount2 * rgb # move each r,g,b towards 0 rgb[rgb < 0] <- 0 # clamp rgb[rgb > 1] <- 1 if(alpha == 1) rgb(rgb[1,], rgb[2,], rgb[3,]) else rgb(rgb[1,], rgb[2,], rgb[3,], alpha) } # returns the expanded arg (error msg if arg is not an allowed choice in calling func) match.arg1 <- function(arg, argname=deparse(substitute(arg))) { formal.args <- formals(sys.function(sys.parent())) formal.argnames <- eval(formal.args[[argname]]) formal.argnames[imatch.choices(arg[1], formal.argnames, argname)] } # returns a string, choices is a vector of strings # error msg if arg is not an allowed choice match.choices <- function(arg, choices, argname=deparse(substitute(arg)), errmsg="", # error message ("" for automatic) errmsg.ext="") # extension to error message { choices[imatch.choices(arg, choices, argname, errmsg=errmsg, errmsg.ext=errmsg.ext)] } # This uses the object's .Environment attribute, which was # pre-assigned to the object via get.model.env # If this gives an error saying that class(model.env) is "NULL" # then that pre-assignment wasn't done. model.env <- function(object) { model.env <- attr(object, ".Environment") if(!is.environment(model.env)) stopf("class(model.env) is \"%s\"", class(model.env)[1]) model.env } # Like as.data.frame() but retains the original colnames, if any, and can # handle matrices from the Matrix etc. packages, if as.matrix() works for # them. Also it has a stringsAsFactors argument which works even if x is # already a data.frame. my.data.frame <- function(x, trace, stringsAsFactors=TRUE) { if(is.data.frame(x)) { if(stringsAsFactors) { # Convert any character columns to factors. Note as.data.frame # won't do this for us when x is already a data.frame. # We don't have a levels argument to pass to factor() # but I believe that this will not be a problem in the # context in which we use my.data.frame (plotmo_x). for(i in seq_len(length(x))) if(is.character(x[[i]])) x[[i]] <- factor(x[[i]]) } return(x) } df <- try(as.data.frame(x, stringsAsFactors=stringsAsFactors), silent=TRUE) if(is.try.err(df)) { # come here for sparse matrices from the Matrix package df <- try(as.matrix(x)) if(is.try.err(df)) stopf("Cannot convert %s object to a data.frame or matrix", quotify(class(x)[1])) df <- as.data.frame(df, stringsAsFactors=stringsAsFactors) trace2(trace, "converted %s object to data.frame\n", class(x)[1]) } colnames(df) <- safe.colnames(x) # restore original column names df } # default min.nrow=3 to use fixed point only if more than intercept and one other term my.fixed.point <- function(x, digits, min.nrow=3) { if(is.null(dim(x))) x <- as.matrix(x) if(NROW(x) >= min.nrow) x <- apply(x, 2, zapsmall, digits+1) x } # If s is a string vector s, return the number of lines in # the element that has the most lines # Examples: nlines(c(" ", " \n ") is 2 # nlines(c(" ", " \n") is 2 # nlines(" ") is 1 # nlines("") is 0 (special case) nlines <- function(s) { if(!nzchar(s[1])) # special case, caption="" is not printed 0 else if(anyNA(s)) 0 else length(strsplit(s, "\n")[[1]]) } paste.c <- function(object, maxlen=16) # return 'x1' or 'c(x1, x2)' { if(length(object) == 1) paste.trunc(object) else paste0("c(", paste.trunc(object, collapse=",", maxlen=maxlen), ")") } paste.with.quotes <- function(object, maxlen=16) # return '"x1"' or '"x1", "x2"' { if(is.null(object[1])) "NULL" else if(length(object) == 0) "EMPTY" else paste0(paste.trunc("\"", object, "\"", collapse=", ", sep="", maxlen=maxlen)) } paste.collapse <- function(...) { paste(..., collapse=" ") } # collapse, and truncate if strings in ... are too long paste.trunc <- function(..., sep=" ", collapse=" ", maxlen=60) { s <- paste(..., sep=sep, collapse=collapse) if(nchar(s) > maxlen) { stopifnot(maxlen > 3) s <- paste0(substr(s, 1, maxlen-3), if(substr(s, maxlen-3, maxlen-3) == ".") ".." # avoid 4 dots else "...") } s } pastef <- function(s, fmt, ...) # paste the printf style args to s { paste0(s, sprint(fmt, ...)) } print_first_few_elements_of_vector <- function(x, trace, name=NULL) { try(cat(" min", min(x), "max", max(x)), silent=TRUE) spaces <- " " if(!is.null(name)) spaces <- sprint("%*s", nchar(name), " ") # nchar spaces cat0("\n", spaces, " value") len <- if(trace >= 4) length(x) else min(if(is.logical(x)) 20 else 10, length(x)) if(is.logical(x)) for(i in 1:len) cat0(if(x[i]) " T" else " F") else for(i in 1:len) cat0(" ", x[i]) if(length(x) > len) cat(" ...") cat("\n") if(trace >= 4) { cat("\n") print(summary(x)) } } # A safe version of sprintf. # Like sprintf except that %s on NULL prints "NULL" rather than # preventing the entire string from being printed # # e.g. sprintf("abc %s def", NULL) returns an empty string -- a silent failure! # but sprint("abc %s def", NULL) returns "abc NULL def" # # e.g. sprintf("abc %d def", NULL) returns an empty string! # but sprint("abc %d def", NULL) causes an error msg (not a silent failure) sprint <- function(fmt, ...) { dots <- list(...) dots <- lapply(dots, function(e) if(is.null(e)) "NULL" else e) do.call(sprintf, c(fmt, dots)) } printf <- function(fmt, ...) # like c printf { cat(sprint(fmt, ...), sep="") } # like printf but wrap at terminal width # exdent=NULL for automatic determination of xdent (line up to func opening paren) # TODO maxlen seems to be ignored, strwrap truncates before that? printf.wrap <- function(fmt, ..., exdent=NULL, maxlen=2000) { s <- paste.trunc(paste.collapse(sprint(fmt, ...)), maxlen=maxlen) if(is.null(exdent)) { # align to opening paren of func call e.g. "graphics::par(xxx)" or "foo$method(" # TODO this doesn't account for leading newlines if any exdent <- 4 igrep <- gregexpr("[ ._$:[:alnum:]]+\\(", s)[[1]] if(igrep[1] == 1) { len <- attr(igrep, "match.length")[1] exdent <- min(25, len) } } # strwrap doesn't preserve newlines in the input string, so do it manually :( for(i in seq_len(nchar(s))) # print leading newlines if(substr(s, i, i) == "\n") cat0("\n") else break cat(paste0(strwrap(s, width=getOption("width"), exdent=exdent), collapse="\n")) if(nchar(s) > i) for(j in nchar(s):i) # print trailing newlines if(substr(s, j, j) == "\n") cat0("\n") else break } pt.cex <- function(ncases, npoints=ncases) { n <- if(npoints > 0) min(npoints, ncases) else ncases if (n >= 20000) .2 else if(n >= 5000) .3 else if(n >= 3000) .4 else if(n >= 1000) .6 else if(n >= 300) .8 else if(n >= 30) 1 else 1.2 } # like short.deparse but quotify the deparsed obj (unless the alternative is used) quote.deparse <- function(object, alternative="object") { s <- strip.deparse(object) if(nchar(s) > 60) alternative else quotify(s, quote="'") } quote.with.c <- function(names) # return "x" or c("x1", "x2") { if(length(names) == 1) sprint("\"%s\"", names) else sprint("c(%s)", paste0("\"", paste(names, collapse="\", \""), "\"")) } quotify <- function(s, quote="\"") # add quotes and collapse to a single string { # called quotify because quote is taken if(is.null(s)) "NULL" else if(length(s) == 0) paste0(quote, quote) else if(substr(s[1], 1, 1) == "'" || substr(s[1], 1, 1) == "\"") paste.collapse(s) # already has quotes else paste0(quote, paste(s, collapse=paste0(quote, " ", quote)), quote) } # like quotify, but use the alternative name if s is too long quotify.short <- function(s, alternative="object", quote="\"") { stopifnot(is.character(s)) s <- paste0(s, collapse="") if(nchar(s) > 60) # 60 is arb but seems ok for plot titles etc alternative else quotify(s, quote) } quotify.trunc <- function(s, quote="\"", maxlen=60) { stopifnot(is.character(s)) s <- quotify(s, quote) if(nchar(s) > maxlen) { stopifnot(maxlen > 3) paste0(substr(s, 1, maxlen-3), "...") } else s } range1 <- function(object, ...) { stopifnot(length(dim(object)) <= 2) if(!is.null(dim(object))) object <- object[,1] if(is.factor(object)) c(1, nlevels(object)) else if(inherits(object, "Date")) # Sep 2020, R 4.0.2: range no longer works with Date objects c(min(object), max(object)) else range(object, finite=TRUE, ...) } recycle <- function(object, ref.object) { repl(object, length.out=length(ref.object)) } repl <- function(object, length.out) { # following "if" added for R-2.15.3 otherwise # get warning: 'x' is NULL so the result will be NULL if(is.null(object)) return(NULL) check.numeric.scalar(length.out) stopifnot(floor(length.out) == length.out) stopifnot(length.out > 0) rep(object, length.out=length.out) } # the standard colnames() can crash for certain objects # TODO figure out when and why safe.colnames <- function(object) { colnames <- try(colnames(object), silent=TRUE) if(is.try.err(colnames)) NULL else colnames } # if deparse(object) is too long, return the alternative short.deparse <- function(object, alternative="object") { s <- strip.deparse(object) if(nchar(s) > 60) alternative else s } # Remove duplicates in x, then sort (smallest first). # Also works for Dates. sort_unique <- function(x) { sort(unique(x), na.last=NA) # na.last=NA drops NAs } sos <- function(x, weights=NULL) # sum of squares { if(is.null(weights)) sum(as.vector(x^2)) else { stopifnot(length(weights) == length(x)) sum(weights * as.vector(x^2)) } } stop0 <- function(...) { stop(..., call.=FALSE) } stopf <- function(fmt, ...) # args like printf { stop(sprint(fmt, ...), call.=FALSE) } # stop if s is not a one element character vector stopifnot.string <- function(s, name=short.deparse(substitute(s)), null.ok=FALSE, allow.empty=FALSE) { if(name %in% c("NULL", "NA")) name <- "argument" if(is.null(s)) { if(null.ok) return() else stop0(quotify(name, "'"), " is NULL (it should be a string)") } if(!is.character(s)) stop0(quotify(name, "'"), " is not a character variable (class(", name, ") is \"", class(s), "\")") if(length(s) == 0) stop0(quotify(name, "'"), " is empty (it has no elements)") if(length(s) != 1) stop0(quotify(name, "'"), " has more than one element\n ", name, " = c(", paste.trunc("\"", s, "\"", sep=""), ")") if(!allow.empty && !nzchar(s)) stop0(quotify(name, "'"), " is an empty string") } strip.deparse <- function(object) # deparse, collapse, remove most white space { s <- strip.space.collapse(deparse(object)) gsub(",", ", ", s) # put back space after commas } strip.space <- function(s) { gsub("[ \t\n]", "", s) } strip.space.collapse <- function(s) # returns a single string { gsub("[ \t\n]", "", paste(s, collapse="")) # paste converts vec to single } # like text, but with a white background # TODO sign of adj is backwards? text.on.white <- function(x, y, label, cex=1, adj=.5, font=1, xmar=.3, srt=0, white="white", ...) { stopifnot(length(label) == 1) if(length(adj) == 1) adj <- c(adj, .5) width <- strwidth(label, cex=cex, font=font) char.width <- strwidth("X", cex=cex, font=font) height <- strheight(label, cex=cex, font=font) char.height <- strheight("X", cex=cex, font=font) if(srt == 0) { if(is.specified(label)) rect(x - adj[1] * width - xmar * char.width, y - adj[2] * height - .3 * char.height, # .3 for extra space at bottom x + (1-adj[1]) * width + xmar * char.width, y + (1-adj[2]) * height + .1 * char.height, col=white, border=NA) text(x=x, y=y, labels=label, cex=cex, adj=adj, font=font, ...) } else if(srt == 90 || srt == -90) { # width and height are in usr coords, adjust these for flip of coords usr <- par("usr") # xmin, xmax, ymin, ymax xrange <- abs(usr[2] - usr[1]) yrange <- abs(usr[4] - usr[3]) height <- xrange / yrange * height width <- yrange / xrange * width char.height <- xrange / yrange * char.height char.width <- yrange / xrange * char.width if(is.specified(label)) rect(x + (1-adj[1]) * height, # left y + (1-adj[2]) * width + xmar * char.width, # bottom x - adj[1] * height, # right y - adj[2] * width - xmar * char.width, # top col=white, border=NA) text(x=x, y=y, labels=label, cex=cex, adj=adj, font=font, srt=srt, ...) } else stop0("srt=", srt, " is not allowed (only 0, 90, and -90 are supported)") } to.logical <- function(object, len) # object can be a boolean or numeric vector { xlogical <- repl(FALSE, len) xlogical[object] <- TRUE xlogical } trace0 <- function(trace, fmt, ...) { stopifnot(!(is.numeric(trace) && is.logical(trace))) if(trace >= 0) cat(sprint(fmt, ...), sep="") } trace1 <- function(trace, fmt, ...) { stopifnot(!(is.numeric(trace) && is.logical(trace))) if(trace >= 1) cat(sprint(fmt, ...), sep="") } trace2 <- function(trace, fmt, ...) { stopifnot(is.numeric(trace)) if(trace >= 2) cat(sprint(fmt, ...), sep="") } # Truncate deparse(object) if it is too long. # Necessary because deparse(substitute(x)) might return something very # long, like c(1000, 1001, 1002, 1003, 1004, 1005, 1006, 1008, 1009, etc.) # Return a one element character vector. trunc.deparse <- function(object, maxlen=60) { s <- strip.deparse(object) if(nchar(s) > maxlen) { stopifnot(maxlen > 3) paste0(substr(s, 1, maxlen-3), "...") } else s } # Return the number of lines in s (where lines are separated by \n). try.eval <- function( expr, envir = parent.frame(), trace = 0, expr.name = NULL, silent = trace < 2) { if(trace && is.null(expr.name)) expr.name <- trunc.deparse(substitute(expr)) try(eval.trace(expr, envir, trace=trace, expr.name=expr.name), silent=silent) } unquote <- function(s) # remove leading and trailing quotes, if any { if(is.character(s)) { s <- gsub("^\"|^'", "", s) # leading quotes s <- gsub("\"$|'$", "", s) # trailing quotes } s } # warn.if.not.all.finite helps preempt confusing message from code later. # Return TRUE if warning issued. warn.if.not.all.finite <- function(object, text="unknown") { is.factors <- sapply(object, is.factor) if(any(is.factors)) { if(NCOL(object) == 1 || all(is.factors)) # TODO suspect return(FALSE) object <- object[, !is.factors] # remove factor columns before is.finite check } if(any(sapply(object, is.na))) { warning0("NA in ", text) return(TRUE) } if(!all(sapply(object, is.finite))) { warning0("non finite value in ", text) return(TRUE) } FALSE } warnf <- function(fmt, ...) # args like printf { warning(sprint(fmt, ...), call.=FALSE) } warning0 <- function(...) { warning(..., call.=FALSE) } # Binomial pairs response: fraction true for each row. # # This function is used by both earth and plotmo. # If you change it here, change it there too. # # The first column of y is considered to be "true", the second "false". # # Example y: # survived died # 1 1 # 0 0 # both values zero # 3 4 # # becomes: # survived # .5 # 1 / (1 + 1) # 0 # special case (both survived and died equal to 0) # .43 # 3 / (3 + 4) bpairs.yfrac <- function(y, trace) { stopifnot(NCOL(y) == 2) both.zero <- (y[,1] == 0) & (y[,2] == 0) y[both.zero, 2] <- 1 # so zero rows will be translated to 0 in next line yfrac <- y[, 1, drop=FALSE] / (y[,1] + y[,2]) # fraction true trace.bpairs.yfrac(yfrac, trace) yfrac } trace.bpairs.yfrac <- function(yfrac, trace) { # based on code in print.earth.fit.args if(trace >= 4) cat("\n") if(trace >= 1 && trace < 7) { # don't print matrices when doing very detailed earth.c tracing tracex <- if(trace >= 5) 4 else 2 # adjust trace for print_summary details <- if(trace >= 4) 2 else if(trace >= 1) -1 else 0 print_summary(yfrac, "yfrac", tracex, details=details) if(details > 1) printf("\n") } } earth/R/residuals.earth.R0000644000176200001440000000571413725066452015017 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.R0000644000176200001440000005071213727277566015441 0ustar liggesusers# model.matrix.earth.R: Functions for manipulating earth model matrices # # The main functions are: # # expand.arg(x, env, is.y.arg, name) in expand.arg.R (not in this module) # # Expand factors in x and convert to double mat with col names # Called by earth.formula, earth.default, get.earth.x # # # stats::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 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 } # called only by model.matrix.earth (used to generate a bx matrix) # 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) x } # object was created with earth.default, no formula # called only by get.earth.x get.earth.x.default <- function(object, data, env, trace, Callers.name) { x <- get.update.arg(data, "x", object, env, trace, Callers.name) namesx <- rownames(object$modvars) x <- possibly.convert.vector.to.matrix(x, namesx) # following allows data to be a list e.g. newdata=etitanic[1,,drop=TRUE] x <- possibly.convert.list.to.data.frame(x) x <- fix.newdata.cols(x, namesx, is.xy.model=TRUE, 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 # called only by get.earth.x 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) namesx <- rownames(object$modvars) data <- possibly.convert.vector.to.matrix(data, namesx) # following allows data to be a list e.g. newdata=etitanic[1,,drop=TRUE] data <- possibly.convert.list.to.data.frame(data) data <- fix.newdata.cols(data, namesx, is.xy.model=FALSE, 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) colnames(data) <- gsub("\`", "", colnames(data)) # remove backticks if any # 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) # # TODO Sep 2020: The R source code has changed for delete.response # Comment in new R source code (4.0.0 dev): "do this `by hand' as previous approach was vulnerable to re-ordering" # Therefore we need to update the code below to match the new R source code. 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 } check.expanded.ncols <- function(x, object) # called only by model.matrix.earth { if(NCOL(x) != NCOL(object$dirs)) { format <- paste0("model.matrix.earth could not interpret the data\n", " model.matrix returned %d column%s %s\n", " need %d column%s %s") stopf(format, NCOL(x), if(NCOL(x) == 1) ":" else "s:", if(NCOL(x) == 0) "" else paste.with.quotes(colnames(x), maxlen=50), NCOL(object$dirs), if(NCOL(object$dirs) == 1) ":" else "s:", paste.with.quotes(colnames(object$dirs), maxlen=50)) } } # 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 stats::model.frame can't interpret the data passed to it it silently # returns the fitted values. This routine makes that not silent. # Note that this won't work if where model.frame returns the wrong results # but coincidentally returns actual.nrows.expected.nrows. 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) { 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("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.with.quotes(colnames, maxlen=50)) } 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.newdata.cols <- function(x, namesx, is.xy.model, 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") ncol <- min(ncol(x), length(namesx)) colnames(x)[1:ncol] <- namesx[1:ncol] colnames <- colnames(x) } else if(ncolnames < nexpected) { ret <- add.missing.newdata.cols(x, namesx, trace, Callers.name) x <- ret$x colnames <- ret$colnames } else if(ncolnames > nexpected) { NULL # TODO not sure what to do here (do nothing so old regression tests pass) } else { ret <- fix.newdata.colnames(x, namesx, trace, Callers.name) x <- ret$x colnames <- ret$colnames } colnames(x) <- colnames x } # Allow user to specify less than the expected # nbr of columns -- which is ok if they specify all predictors # actually used by the model. # # Called only by fix.newdata.cols # which in turn is called only get.earth.x # (via get.earth.x.default and get.earth.x.formula) add.missing.newdata.cols <- function(x, namesx, trace, Callers.name) { colnames <- colnames(x) nexpected <- length(namesx) 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) format <- paste0("could not interpret newdata\n", " model.matrix returned %d column%s %s\n", " need %d column%s %s") stopf(format, NCOL(x), if(NCOL(x) == 1) ":" else "s:", if(NCOL(x) == 0) "" else paste.with.quotes(colnames(x), maxlen=50), length(namesx), if(length(namesx) == 1) ":" else "s:", paste.with.quotes(namesx, maxlen=50)) } # 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("newdata has missing columns, adding missing cols with all NAs\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 list(x=x, colnames=namesx) } # called only fix.newdata.cols (called when ncolnames == nexpected) fix.newdata.colnames <- function(x, namesx, trace, Callers.name) { colnames <- colnames(x) 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, "") } } list(x=x, colnames=colnames) } strip.func.call <- function(colnames) # e.g. "as.numeric(x3,99)" becomes "x3" { regex <- ".+\\(" # matches foo(, does not match (Intercept) if(any(grepl(regex, colnames))) { colnames <- gsub(regex, "", colnames) # replace foo( colnames <- gsub("[,)][^+-]*", "", colnames) # remove remaining ",arg1,arg2)" } colnames } earth/R/format.earth.R0000644000176200001440000003226514565632361014316 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/spread.labs.R0000644000176200001440000000757214563577756014143 0ustar liggesusers# Copied from the orphaned package TeachingDemos version 2.12.1 on Feb 16, 2024. # ------------------------------------------------------------------------------ # # --Title-- # # Spread out close points for labeling in plots # # --Description-- # # This function takes as set of coordinates and spreads out the close # values so that they can be used in labeling plots without overlapping. # # --Usage-- # # spread.labs(x, mindiff, maxiter = 1000, stepsize = 1/10, min = -Inf, max = Inf) # # --Arguments-- # # x The coordinate values (x or y, not both) to spread out. # mindiff The minimum distance between return values # maxiter The maximum number of iterations # stepsize How far to move values in each iteration # min Minimum bound for returned values # max Maximum bound for returned values # # --Details-- # # Sometimes the desired locations for labels in plots results in the # labels overlapping. This function takes the coordinate values (x or #- y, not both) and finds those points that are less than mindiff # (usually a function of strheight or strwidth ) apart and # increases the space between them (by stepsize * mindiff ). # This may or may not be enough and moving some points # away from their nearest neighbor may move them too close to another # neighbor, so the process is iterated until either maxiter steps # have been tried, or all the values are at least mindiff apart. # # The min and max arguments prevent the values from going # outside that range (they should be specified such that the original # values are all inside the range). # # The values do not need to be presorted. # # --Return Value-- # # A vector of coordinates (order corresponding to the original x ) # that can be used as a replacement for x in placing labels. # # --Author-- # # Greg Snow email 538280@gmail.com # # --See Also-- # # The spread.labels function in the plotrix package. # # --Examples-- # # # overlapping labels # plot(as.integer(state.region), state.x77[,1], ylab='Population', # xlab='Region',xlim=c(1,4.75), xaxt='n') # axis(1, at=1:4, lab=levels(state.region) ) # # text( as.integer(state.region)+.5, state.x77[,1], state.abb ) # segments( as.integer(state.region)+0.025, state.x77[,1], # as.integer(state.region)+.375, state.x77[,1] ) # # # now lets redo the plot without overlap # # tmp.y <- state.x77[,1] # for(i in levels(state.region) ) { # tmp <- state.region == i # tmp.y[ tmp ] <- spread.labs( tmp.y[ tmp ], 1.2*strheight('A'), # maxiter=1000, min=0 ) # } # # plot(as.integer(state.region), state.x77[,1], ylab='Population', # xlab='Region', xlim=c(1,4.75), xaxt='n') # axis(1, at=1:4, lab=levels(state.region) ) # # text( as.integer(state.region)+0.5, tmp.y, state.abb ) # segments( as.integer(state.region)+0.025, state.x77[,1], # as.integer(state.region)+0.375, tmp.y ) # } spread.labs <- function(x, mindiff, maxiter=1000, stepsize=1/10, min=-Inf, max=Inf) { unsort <- order(order(x)) x <- sort(x) df <- x[-1] - x[ -length(x) ] stp <- mindiff * stepsize i <- 1 while( any( df < mindiff ) ) { tmp <- c( df < mindiff, FALSE ) if( tmp[1] && (x[1] - stp) < min ) { # don't move bottom set tmp2 <- as.logical( cumprod(tmp) ) tmp <- tmp & !tmp2 } x[ tmp ] <- x[ tmp ] - stp tmp <- c( FALSE, df < mindiff ) if( tmp[length(tmp)] && (x[length(x)] + stp) > max ) { # don't move top tmp2 <- rev( as.logical( cumprod( rev(tmp) ) ) ) tmp <- tmp & !tmp2 } x[ tmp ] <- x[ tmp] + stp df <- x[-1] - x[-length(x)] i <- i + 1 if( i > maxiter ) { warning("Maximum iterations reached") break } } x[unsort] } earth/R/naken.R0000644000176200001440000001326513724000770013004 0ustar liggesusers# naken.R: # Like naken.collapse but don't collapse a vector of strings into a single string. # # e.g. c("num","sqrt(num)","ord","offset(off)") # becomes c("num","num" "ord", "off") naken <- function(s) { naked <- character(length(s)) for(i in seq_along(s)) naked[i] <- naken.collapse(s[i]) naked } # Collapse s to s single string and then "naken" it # (i.e. return only the variables in the string, separated by "+"). # # e.g. "x1" becomes "x1" # "sqrt(x1)" becomes "x1" # "s(x1,x4,df=4)" becomes "x1+x4" # "sqrt(x1) as.numeric(x4)" becomes "x1" # c("sqrt(x1)", "as.numeric(x4)") becomes "x1" # `x 3` becomes "`x 3`" (variables in backquotes unchanged) naken.collapse <- function(s, warn.if.minus=FALSE) { s <- paste.collapse(s) s.org <- s untouchable <- get.untouchable.for.naken(s) s <- strip.space(untouchable$s) # strip space from everything except untouchables # for "ident" gsubs below if(grepl("--", s, fixed=TRUE)) # '--'causes problems because '-' gets turned to '+' below warning0("Consecutive '-' in formula may cause problems\n Formula:", s.org) # # check for "- ident" in formula (but -1 is ok) # # # commented out because this is invisible to the user, because # # plotmo does not plot the -ident variable # # if(warn.if.minus && grepl("\\- *[._[:alpha:]]", s)[1]) # warnf("plotmo will include the variable prefixed by \"-\" in the formula\n Formula: %s", s) # TODO we can't ignore "-" below because of the paste0(collapse=" + ") later below s <- gsub("[-*/:]", "+", s) # replace - / * : with + # next two gsubs allow us to retain "x=x1" but drop "df=99" from "bs(x=x1, df=99)" s <- gsub("\\(._$[[:alnum:]]+=", "(", s) # replace "(ident=" with "(" s <- gsub("[._$[:alnum:]]+=[^,)]+", "", s) # delete "ident=any" # replace ",ident" with ")+f(ident", thus "s(x0,x1)" becomes "s(x0)f(x1)" s <- gsub(",([._$[:alpha:]])", ")+f(\\1", s) regex <- "[._$[:alnum:]]*\\(" if(grepl(regex, s)) { s <- gsub(regex, "", s) # replace ident( s <- gsub("[,)][^+-]*", "", s) # remove remaining ",arg1,arg2)" } # s is now something like x1+x2, split it on "+" for further processing s <- strsplit(s, "+", fixed=TRUE)[[1]] s <- unique(s) # remove duplicates # remove numbers e.g. sin(x1*x2/12) is nakened to x1+x1+12, we don't want the 12 is.num <- sapply(s, function(x) grepl("^([0-9]|\\.[0-9])", x)) # but keep the intercept if there is one which1 <- which(s == "1") is.num[which1] <- FALSE s <- paste0(s[!is.num], collapse=" + ") replace.untouchable.for.naken(s, untouchable$replacements) } # In the function naken.collapse(), terms such as [string] and `string` # must remain the same (regardless of the enclosed string). # That is, strings in brackets or backquotes must remain untouched. # # This function searches for such terms, replaces them with dummies, and # remembers where they were in the original string (for re-replacement later). # # For example, if s = "x1 + x[,2] + `x 3`" we return: # # out: "x1 + x!00000! + !00001!" # note the dummies !00000! and !00001! # # replacements: # replacement original # "[00000]" "[,2]" # "[00001]" "`x 3`" get.untouchable.for.naken <- function(s) # utility for naken { # for efficiency, check for most common case (no [ or ` in s) if(!grepl("[\\[\`]", s)[1]) return(list(s=s, replacements=NULL)) # no [ or ` in s stopifnot(length(s) == 1) # out and untouchables will be the returned string and table of untouchables # for simplicity, create untouchables as a vec and convert to a mat at the end out <- "" untouchables <- NULL cs <- strsplit(s, split="")[[1]] # split into individual chars for loop efficiency len <- length(cs) i <- 1 while(i <= len) { c <- cs[i] # i==len below is for malformed strings with extra [ or ` on end if((c != "[" && c != "\`") || i == len) # normal character out <- paste0(out, c) else { # char is [ or `, skip to matching ] or ` istart <- i nestdepth <- 0 endchar <- if(c == "[") "]" else "\`" for(i in (istart+1):len) { if(c == "[" && cs[i] == "[") nestdepth <- nestdepth + 1 # nested brackets if(cs[i] == endchar) { if(nestdepth <= 0) break else nestdepth <- nestdepth - 1 } } replacement <- sprint("!%05.5g!", length(untouchables) / 2) out <- paste0(out, replacement) untouchables <- c(untouchables, replacement, substr(s, istart, i)) } i <- i + 1 } if(length(untouchables)== 0) # malformed s="[" or s="`" return(list(s=s, replacements=NULL)) replacements <- matrix(untouchables, byrow=TRUE, ncol=2, nrow=length(untouchables) / 2) colnames(replacements) <- c("replacement", "original") list(s=out, replacements=replacements) } # undo the effect of get.untouchable.for.naken replace.untouchable.for.naken <- function(s, replacements) { for(i in seq_len(NROW(replacements))) s <- gsub(replacements[i, 1], replacements[i, 2], s, fixed=TRUE) s } earth/R/earth.regress.R0000644000176200001440000000675514565631311014477 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, name=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 int UsedColsR[]) in: specifies used columns in x # (assume R LOGICAL is stored as int) PACKAGE="earth") rval$fitted.values <- y - rval$residuals rval$call <- match.call() rval } earth/R/check.index.R0000644000176200001440000001724213723040630014070 0ustar liggesusers# check.index.R # Check that an index vector specified by the user is ok to index an object. # We want to preclude confusing R messages or behaviour later. # An example is when max(index) > length(object) which quietly # returns NA and can cause confusing downstream behaviour. # This returns a vector suitable for indexing into object (will # be identical to index unless index is a character vector). # # If index is a character vector, then matching (regex if is.col.index != 2) # is used against the names in the object, and an integer vector is returned. check.index <- function(index, index.name, object, colnames = NULL, is.col.index = 0, # 0=row index, 1=col index, 2=exact non-regex col name if char allow.empty = FALSE, # if index is char will warn if necessary regardless of allow.empty allow.zeros = FALSE, allow.negatives = TRUE, allow.dups = FALSE, treat.NA.as.one = FALSE, is.degree.spec = FALSE) # special handling for degree1 and degree2 specs { index.name <- quotify.short(index.name, "index", quote="'") # check that the given index and object can be evaluated try <- try(eval(index)) if(is.try.err(try)) stop0("illegal ", index.name) try <- try(eval(object)) if(is.try.err(try)) stop0("illegal ", quotify.short(object, quote="'")) is.col.index <- check.integer.scalar(is.col.index, min=0, max=2) allow.empty <- check.boolean(allow.empty) allow.zeros <- check.boolean(allow.zeros) allow.negatives <- check.boolean(allow.negatives) allow.dups <- check.boolean(allow.dups) treat.NA.as.one <- check.boolean(treat.NA.as.one) if(is.null(index)) { if(!allow.empty) stop0(index.name, " is NULL and cannot be used as an index") return(NULL) } if(treat.NA.as.one && (length(index) == 1 && is.na(index)[1])) index <- 1 if(anyNA(index)) stop0("NA in ", index.name) if(NROW(index) != 1 && NCOL(index) != 1) stop0(index.name, " must be a vector not a matrix (", index.name, " has dimensions ", NROW(index), " x ", NCOL(index), ")") len <- get.len(object, is.col.index) if(is.character(index)) # currently only works for column names of object check.character.index(index, index.name, object, colnames, len, is.fixed=(is.col.index==2), allow.empty, is.degree.spec) else if(is.logical(index)) check.logical.index(index, index.name, len, allow.empty) else if(is.numeric(index)) check.numeric.index(index, index.name, len, allow.empty, allow.negatives, allow.dups, allow.zeros, treat.NA.as.one) else stop0(index.name, " must be an index vector (numeric, logical, or character)") } get.len <- function(object, is.col.index) { if(is.col.index) len <- NCOL(object) # index is for columns of object else if(is.null(dim(object))) len <- length(object) else len <- NROW(object) # index is for rows of object # NROW also works for lists stopifnot(length(len) == 1) stopifnot(len > 0) len } matchmult <- function(x, tab) # like match but return multiple matches if present { matches <- integer(0) for(i in seq_along(x)) { xi <- x[i] for(itab in 1:length(tab)) if(xi == tab[itab]) matches <- c(matches, itab) } matches } # This does regex matching of index and returns an integer vector # index arg must be character # if names arg is NULL, use colnames(object) check.character.index <- function(index, index.name, object, names, len, is.fixed, allow.empty, is.degree.spec) { stopifnot(is.character(index)) is.fixed <- check.boolean(is.fixed) # certain regular expressions match everything, even if names not avail if(!is.fixed && length(index) == 1 && index %in% c("", ".", ".*")) return(1:len) if(is.null(names)) names <- colnames(object) if(length(names) == 0 || !is.character(names)) stop0(index.name, " specifies names but the names are unavailable") matches <- integer(0) warning.names <- integer(0) # these regexs don't match any column names for(i in seq_along(index)) { name <- index[i] if(!is.fixed) # regex match igrep <- grep(name, names) else { # exact match if(nchar(name) == 0) warning0(unquote(index.name), "[", i, "] is an empty string \"\"") igrep <- which(name == names) } if(length(igrep)) matches <- c(matches, igrep) else warning.names <- c(warning.names, name) } if(is.degree.spec) { if(is.null(dim(object))) # vector, degree1 matches <- matchmult(matches, object) else if(length(dim(object)) == 2) # 2D matrix, degree2 matches <- c(matchmult(matches, object[,1]), matchmult(matches, object[,2])) else stop0("that kind of object is not yet supported for ", index.name) } new.index <- unique(matches[!is.na(matches)]) for(name in warning.names) warning0("\"", name, "\" in ", unquote(index.name), " does not ", if(is.fixed) "" else "regex-", "match any names\n", " Available names are ", paste.trunc(quotify(names))) new.index } check.logical.index <- function(index, index.name, len, allow.empty) { stopifnot(is.logical(index)) if(!allow.empty) { if(length(index) == 0) stop0("length(", unquote(index.name), ") == 0") if(length(index[index == TRUE]) == 0) stop0(index.name, " is all FALSE") } # note that a single FALSE or TRUE is ok regardless of length(object) if(length(index) > len && length(index) != 1) { stop0("logical index ", index.name, " is too long.\n", " Its length is ", length(index), " and the max allowed length is ", len) } index } check.numeric.index <- function(index, index.name, len, allow.empty, allow.negatives, allow.dups, allow.zeros, treat.NA.as.one) { stopifnot(is.numeric(index)) if(!allow.empty) { if(length(index) == 0) stop0(index.name, " is empty, (its length is 0)") else if(all(index == 0)) if(length(index) == 1) stop0(index.name, " is 0") else stop0(index.name, " is all zeros") } if(!is.integral(index)) stop0(index.name, " is not an integer") if(any(index < 0) && any(index > 0)) stop0("mixed negative and positive values in ", index.name) if(!allow.zeros && any(index == 0) && length(index) != 1) warning0("zero in ", index.name) if(!allow.negatives && any(index < 0)) stop0("negative value in ", index.name) if(!allow.dups && any(duplicated(index))) warning0("duplicates in ", index.name) if(any(abs(index) > len)) { if(length(index) == 1) prefix <- paste0(unquote(index.name), "=", index, " but ") else prefix <- paste0(index.name, " is out of range, ") if(len != 1) stop0(prefix, "allowed values are 1 to ", len) else if(treat.NA.as.one) stop0(prefix, "the only allowed value is 1 (or NA)") else stop0(prefix, "the only allowed value is 1") } index } earth/R/print.earth.R0000644000176200001440000004000513722436026014143 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) if(!is.null(x$nprune)) printf(" (nprune=%g)", x$nprune) 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 (TODO correct?) } 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 } earth/R/plotd.R0000644000176200001440000007567313730243167013053 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 { # the following lines of code must match plotmo::plotmo() and plotmo::plotres() init.global.data() on.exit({init.global.data(); gc()}) # release memory on exit object.name <- short.deparse(substitute(object)) trace <- as.numeric(check.integer.scalar(trace, logical.ok=TRUE)) use.submodel <- dota("USE.SUBMODEL", DEF=TRUE, ...) # undoc arg (for parsnip models) use.submodel <- is.specified(use.submodel) # Associate the model environment with the object. # (This is instead of passing it as an argument to plotmo's data access # functions. It saves a few hundred references to model.env in the code.) object.env <- get.model.env(object, object.name, trace, use.submodel) ret <- plotmo::plotmo_prolog(object, object.name, trace, ...) object <- ret$object # the original object or a submodel (parsnip) my.call <- ret$my.call attr(object, ".Environment") <- object.env 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, "plotd", 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.as.char(object)), 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.R0000644000176200001440000012705714563577536014022 0ustar liggesusers# plot.earth.R: plotting routines for the earth package alt.vline.col <- "#00A000" # darkish green 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(FALSE) # 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) } TRUE } draw.oof.rsqs <- function() # plot rsq's measured on the out-of-fold data { if(!is.specified(col.oof.rsq)) return(FALSE) # 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=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) } } TRUE } draw.nbr.used.preds <- function() { if(!is.specified(col.npreds)) return(FALSE) 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 / 100 } lines(nused.preds.vec, type="l", col=col.npreds, lty=lty.npreds) TRUE } draw.vline.at.max.mean.oof.rsq <- function(is.vline.at.selected.model, is.vline.at.max.grsq) { if(!is.specified(col.mean.oof.rsq) || !is.specified(col.oof.vline)) return(FALSE) x <- xnudge <- which.max(mean.oof.rsq.per.subset) # possibly nudge right to prevent overplot of existing vertical lines if(is.vline.at.selected.model && x == length(object$selected.terms)) xnudge <- xnudge + nterms.on.horiz.axis / 100 else if(is.vline.at.max.grsq && x == which.min(object$gcv.per.subset)) xnudge <- xnudge + nterms.on.horiz.axis / 100 # possibly nudge to prevent overplot of grid if(is.specified(grid.col)) xnudge <- xnudge + nterms.on.horiz.axis / 100 abline(v=xnudge, col=col.oof.vline, lty="12", lwd=1.5) TRUE } show.nterms.max.mean.oof.rsq <- function(show.nterms.max.mean.oof.rsq) { if(!show.nterms.max.mean.oof.rsq || !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.nterms.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) } } # return TRUE if drew the line (only happens if col.vline is not specified) draw.vline.at.selected.model <- function(is.vline.at.max.grsq) { if(!is.specified(col.vline)) return(FALSE) x <- xnudge <- length(object$selected.terms) # possibly nudge to prevent overplot of grid if(is.specified(grid.col)) xnudge <- xnudge + nterms.on.horiz.axis / 100 abline(v=xnudge, # use a different color to disambiguate from vline at max.grsq col=if(is.vline.at.max.grsq) alt.vline.col else col.vline, lty=lty.vline, lwd=if(is.vline.at.max.grsq) 2 else 1.5) # 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) TRUE } show.nterms.selected.model <- function(is.vline.at.max.grsq, is.vline.at.selected.model) { if(!is.vline.at.selected.model || !is.specified(col.vline) || is.specified(col.vseg)) return() x <- length(object$selected.terms) usr <- par("usr") text.on.white(x, usr[3] + strheight("X"), x, cex=.8, col=if(is.vline.at.max.grsq) alt.vline.col else col.vline, xmar=.05) } # needed so we can change col of grsq line if selected.model line is drawn must.draw.line.at.max.grsq <- function() { if(!is.specified(col.vline)) return(FALSE) x <- which.min(object$gcv.per.subset) # prevent overplot of draw.vline.at.selected.model if(x == length(object$selected.terms)) return(FALSE) TRUE } # called only if must.draw.line.at.max.grsq is true draw.vline.at.max.grsq <- function() { 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 / 100 abline(v=xnudge, col=col.vline, lty=lty.vline, lwd=1.5) # 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.nterms.max.grsq <- function(is.vline.at.selected.model, is.vline.at.max.grsq) { if(!is.vline.at.max.grsq || !is.specified(col.vline) || is.specified(col.vseg)) return() x <- which.min(object$gcv.per.subset) # prevent overplot of draw.vline.at.selected.model if(is.vline.at.selected.model && x == length(object$selected.terms)) 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) } # note that function updates legend.text etc. (which are global to the function) 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.text <- if(show.cv.data) " (full data model)" else "" if(is.vline.at.selected.model) { update.legend("selected model", # use a different color to disambiguate from vline at max.grsq col=if(is.vline.at.max.grsq) alt.vline.col else col.vline, lty.vline, lwd=if(is.vline.at.max.grsq) 2 else 1.5, vert=TRUE) # add extra text if pmethod="none" or "cv", or nprune if(object$pmethod == "none" || object$pmethod == "cv") update.legend(paste0("pmethod \"", object$pmethod, "\""), "white", 1) if(length(object$selected.terms) == 1) update.legend("intercept-only model", "white", 1) if(!is.null(object$nprune)) update.legend(paste0("nprune ", object$nprune), "white", 1) if(object$pmethod == "none" || object$pmethod == "cv" || length(object$selected.terms) == 1 || !is.null(object$nprune)) update.legend("", 0) # dummy entry to leave a vertical space } if(is.specified(col.grsq)) update.legend(paste0("GRSq", full.model.text), lwd=lwd) if(is.vline.at.max.grsq) update.legend("max GRSq", col.vline, lty.vline, lwd=1.5, vert=TRUE) if(is.specified(col.rsq)) { RSq.string <- if(show.cv.data) "RSq (full data 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.5, 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.text), col.npreds, lty.npreds) } 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) 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 is.infold.rsqs <- draw.infold.rsqs() is.oof.rsqs <- draw.oof.rsqs() is.unused.preds <- draw.nbr.used.preds() is.vline.at.max.grsq <- must.draw.line.at.max.grsq() is.vline.at.selected.model <- draw.vline.at.selected.model(is.vline.at.max.grsq) if(is.vline.at.max.grsq) draw.vline.at.max.grsq() is.vline.at.max.mean.oof.rsq <- draw.vline.at.max.mean.oof.rsq( is.vline.at.selected.model, is.vline.at.max.grsq) draw.rsq() draw.mean.infold.rsq() draw.mean.oof.rsq() draw.grsq() show.nterms.selected.model(is.vline.at.max.grsq, is.vline.at.selected.model) show.nterms.max.grsq(is.vline.at.selected.model, is.vline.at.max.grsq) show.nterms.max.mean.oof.rsq(is.vline.at.max.mean.oof.rsq ) 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) min <- min - .2 # allow extra vertical space, needed for larger menu # 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) min <- min - .2 # allow extra vertical space, needed for larger menu 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]) fold.min.max <- get.fold.min.max() if(!is.specified(col.rsq)) rsq <- NULL if(ylim[1] == -1) { ylim[1] <- min(grsq[-1], rsq[-1], fold.min.max$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, fold.min.max$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.R0000644000176200001440000003174414567077013014132 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.R0000644000176200001440000002700113440642446013313 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.R0000644000176200001440000002164713725245221015774 0ustar liggesusers# plotmo.rpart.R: plotmo methods for earth objects plotmo.singles.earth <- function(object, x, nresponse, trace, all1, ...) { get.earth.vars.for.plotmo(ndegree=1, object, x, nresponse, trace, all=all1, ...) } plotmo.pairs.earth <- function(object, x, nresponse=1, trace=0, all2=FALSE, ...) { get.earth.vars.for.plotmo(ndegree=2, object, x, nresponse, trace, all=all2, ...) } get.earth.vars.for.plotmo <- function(ndegree, object, x, nresponse, trace, all, ...) { modvars <- object$modvars stopifnot(!is.null(modvars)) stopifnot(ndegree == 1 || ndegree == 2) stopifnot(nrow(modvars) == length(object$namesx)) # default return is all singles or all pairs def.return <- get.earth.vars.def.return(ndegree, modvars, x) if(all) # user wants all used predictors, not just those in ndegree terms? return(def.return) if(ncol(x) < nrow(modvars)) { if(ndegree == 1) { # so issue only one warning per invocation of plotmo format <- paste0("Cannot determine which variables to plot (use all1=TRUE?)\n", " ncol(x) %d < nrow(modvars) %d\n", " colnames(x)=%s\n", " rownames(modvars)=%s") warnf(format, ncol(x), nrow(modvars), paste.c(colnames(x), maxlen=100), paste.c(rownames(modvars), maxlen=100)) } return(def.return) } dirs <- object$dirs[object$selected.terms, , drop=FALSE] degree <- get.degrees.per.term(dirs) == ndegree # rows in dirs for terms of ndegree if(all(degree == 0)) { return(NULL) # no terms of ndegree } # set intercept row to 0 (else we will plot the # intercept for degree1 and degree2 plots) # we don't plot the offset by default because doing so can # supersize the ylim (thus compressing the curves on the other plots) # TODO inconsistent with glm models where we do plot the offset if(any(modvars == 9999)) { modvars[modvars == 9999] <- 0 if(ndegree == 1 && trace >= 0) 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") } dirs <- dirs[degree, , drop=FALSE] # rows in dirs for terms of ndegree stopifnot(ncol(modvars) == ncol(object$dirs)) singles <- NULL for(irow in seq_len(nrow(dirs))) { vars <- which(dirs[irow, ] != 0) if(length(vars) != ndegree) warnf("get.earth.vars.for.plotmo ndegree %d: irow %d length(vars) %d\n", ndegree, irow, length(vars)) # ivar1 will be length 2 for earth terms like x1:x2, or x1:x2 * h(3-x3) # because the term uses two variables, x1 and x2 # (there was a x1:x2 in the formula) ivar1 <- which(modvars[,vars[1]] != 0) if(ndegree == 2) { ivar2 <- which(modvars[,vars[2]] != 0) singles <- c(singles, generate.all.pairs(ivar1, ivar2)) } else { singles <- c(singles, ivar1) } } single.names <- rownames(modvars)[singles] single.names <- gsub("\`", "", single.names) # remove backticks if any # hack for booleans which get expanded by model.matrix from "bool" to "boolTRUE" # this currently only affects caret models (see above comments for caret models) if(any(grepl(".+TRUE$", single.names)) && !any(grepl(".+TRUE$", colnames(x)))) { if(trace >= 2) { format <- paste0("get.earth.vars.for.plotmo: ", "deleting \"TRUE\" in single.names=%s\n", " to match colnames(x)=%s\n") printf(format, paste.c(single.names, maxlen=100), paste.c(colnames(x), maxlen=100)) } single.names <- gsub("TRUE", "", single.names) } match <- match(single.names, colnames(x), nomatch=0) match <- matrix(match, ncol=ndegree, byrow=TRUE) # sanity checks if(any(match == 0) || length(match) %% ndegree != 0 || length(match) != length(single.names)) { if(ndegree == 1) { # so issue only one warning per invocation of plotmo if(trace >= 2) { cat("\nAdditional information for warning below:\n\n") printf("any(match == 0): %d\n", any(match == 0)) printf("length(match) %% ndegree != 0: %d\n", length(match) %% ndegree != 0) printf("length(match) != length(single.names): %d\n", length(match) != length(single.names)) printf("(ndegree == 1 && length(unique(match)) != length(match)): %d\n", (ndegree == 1 && length(unique(match)) != length(match))) cat("\nsingles:", singles, "\n") cat("\nmatch:\n") print(match) cat("\nhead(x):\n") print(head(x)) cat("\nhead(object$dirs):\n") print(head(object$dirs)) cat("\nhead(modvars):\n") print(head(modvars)) cat("\n") } format <- paste0("Cannot determine which variables to plot (use all1=TRUE?)\n", " single.names=%s\n", " colnames(x)=%s\n") warnf(format, paste.c(single.names, maxlen=100), paste.c(colnames(x), maxlen=100)) } match <- def.return } # end of sanity checks return(match) # plotmo will remove duplicate rows and "toggled dups" like c(2,5) and c(5,2) } # example 1: ivar=5 ivar2=8 return c(5,8) # example 2: ivar=c(5,6) ivar2=8 return c(5,8, 6,8) # example 3: ivar=c(5,6) ivar2=(8,9) return c(5,8, 5,9, 6,8, 6,9) generate.all.pairs <- function(ivar1, ivar2) { pairs <- NULL for(i in ivar1) for(j in ivar2) if(i != j) # necessary for terms like h(num-4)*sqrt(num) (both vars are "num") pairs <- c(pairs, c(i, j)) pairs } # get the default return for get.earth.vars.for.plotmo (all singles or all pairs) get.earth.vars.def.return <- function(ndegree, modvars, x) { # The min (for all.singles) below is necessary if ncol(x) < nrow(modvars) # This need for min currently only affects caret models. # This can happen with caret models because plotmo gets the caret data # from the formula call to caret, but caret calls earth.default with x # from the model.matrix() already applied to the formula. # For example a formula like y~fac+num (two vars) # gets passed to earth x as fac1 fac2 fac3 num (four vars). # This only affects formulas that have factors (and logicals) in them, because # the columns names in x don't match the variable names in the formula. all.singles <- seq_len(min(nrow(modvars), ncol(x))) # all singles def.return <- all.singles # default return, used if something goes wrong if(ndegree == 2) { if(length(all.singles) <= 1) def.return <- matrix(0, nrow=0, ncol=ndegree) # no pairs else { # plotmo_doubles will remove redundant "toggled duplicates" like c(2,5) and c(5,2) all.pairs <- generate.all.pairs(all.singles, all.singles) def.return <- matrix(all.pairs, ncol=ndegree, byrow=TRUE) # all pairs # limit number of pair plots to 20 (arb) def.return <- def.return[seq_len(min(nrow(def.return), 20)), , drop=FALSE] } } def.return } 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, name=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.R0000644000176200001440000013467514565632542013040 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 alphabetical order after earth.default and earth.formula. # 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") earth <- function(...) { UseMethod("earth") } earth.default <- function( # user called earth with x y args (not formula) 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$da)) # matches anything beginning with "da", doesn't alias with other args 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)) if(is.matrix(x) && is.double(x[,1])) { # x is already a double matrix, save memory and time by skipping expand.arg colnames(x) <- gen.colnames(x, xname, "x") modvars <- get.identity.modvars(x) } else { # expand factors, convert to double matrix with column names ret <- expand.arg.modvars(x, env, trace=0, is.y.arg=FALSE, name=xname) x <- ret$x modvars <- ret$modvars rownames(x) <- possibly.delete.rownames(x) } ylevels <- get.ylevels(y) y <- expand.arg(y, env, trace=0, is.y.arg=TRUE, name=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 # namesx is no longer used by earth but provided for back compat with other apps # (modvars subsumes namesx) rv$namesx <- rownames(modvars) # The modvars field was added to earth models in Sep 2020 (earth 5.2.0). # # rownames(modvars) for earth.default differs from earth.formula when for example: # earth(x, y) (where x has two columns, "num" and "sqrt(num)") # then rownames(modvars) = c("num", "sqrt(num)") # earth(y~num+sqrt(num), data=dat) (where dat has two columns, "y" and "num") # then rownames(modvars) = "num" rv$modvars <- modvars 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) { if(!is.null(subset)) stop0("'subset' cannot be used with 'nfold' (implementation restriction)") 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, trace.org=trace, glm.arg=glm.arg, degree=degree, 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),] # Sep 2020: nprune1 added else get (for some rand seeds): # evimp: Error in object$prune.terms[isubset, -1] : subscript out of bounds nprune1 <- if(is.specified(nprune)) nprune else length(mean.oof.rsq.per.subset) nterms.selected.by.cv <- which.max(mean.oof.rsq.per.subset[1:nprune1]) trace1(trace, "\n=== 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) if(trace == .5) printf("%sGRSq %.3f RSq %.3f nterms selected by cv %g", "Final model with pmethod=\"cv\": ", rv$grsq , rv$rsq, length(rv$selected.terms)) 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 } if(trace >= .5) printf("\n") } # 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) } rv$Scale.y <- NULL rv } earth.formula <- function( # user called earth with formula arg (not x y args) 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) formdat <- get.data.from.formula(mf=call2[c(1, m)], formula, data, env, trace) x <- formdat$x y <- formdat$y weights <- formdat$weights offset <- formdat$offset terms <- formdat$terms xlevels <- formdat$xlevels ylevels <- formdat$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 # namesx is no longer used by earth but provided for back compat with other apps # (modvars has subsumed namesx) rv$namesx <- rownames(formdat$modvars) rv$modvars <- formdat$modvars # modvars added to earth models in Sep 2020 (earth 5.2.0). 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) { if(!is.null(subset)) stop0("'subset' cannot be used with 'nfold' (implementation restriction)") 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, trace.org=trace, glm.arg=glm.arg, degree=degree, 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),] # Sep 2020: nprune1 added (necessary only for some rand seeds): # evimp: Error in object$prune.terms[isubset, -1] : subscript out of bounds nprune1 <- if(is.specified(nprune)) nprune else length(mean.oof.rsq.per.subset) nterms.selected.by.cv <- which.max(mean.oof.rsq.per.subset[1:nprune1]) trace1(trace, "\n=== 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) if(trace == .5) printf("%sGRSq %.3f RSq %.3f nterms selected by cv %g", "Final model with pmethod=\"cv\": ", rv$grsq , rv$rsq, length(rv$selected.terms)) 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 } if(trace >= .5) printf("\n") } # 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) } rv$Scale.y <- NULL rv } # 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 } 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) } # 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 } # called only by earth.formula get.data.from.formula <- function(mf, formula, data, env, trace) { 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 # for backward compat, use class "Formula" -- not "formula" -- only when necessary 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 `(weights)` column from 'Formula' model.matrix\n") x <- x[, colnames(x) != "`(weights)`", drop=FALSE] } y <- model.part(Formula, data=mf, lhs=1) # TODO Sep 2020: work around for model.matrix.Formula which incorrectly includes # `log(O3)` in x if log(O3) is used in y (i.e. on the lhs of the formula) # e.g. earth(log(O3) + wind ~ ., data=ozone1) is isn't handled correctly which <- which(colnames(y) != naken(colnames(y))) if(any(which)) stop0("terms like \'", colnames(y)[which[1]], "\' are not allowed on the LHS of a multiple-response formula") # add extra attributes to terms for use by earth attr(terms, "Formula") <- Formula attr(terms, "Response") <- 1:NCOL(y) # TODO is 1:NCOL(y) reliable here? iresp <- attr(terms, "Response") # is a vector if multiple responses # (empirically -1 works even with mult responses) } 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 <- attr(terms, "response") # is 1 even with cbind(survived, died)~. } # the "assign" attribute has an entry for each column in x # giving the term in the formula which gave rise to the column xassign <- attr(x, "assign") xassign <- xassign[-1] # delete response (-1 correct even with multiple responses) 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)") rownames(x) <- possibly.delete.rownames(x) ylevels <- get.ylevels(y) # TODO this always returns NULL if Formula was used # expand factors in y, convert to double matrix, add colnames if(length(iresp) > 1) # multiple columns yname <- "y" # generic name else yname <- names(attr(terms, "dataClasses"))[[iresp[1]]] # name of variable y <- expand.arg(y, env, trace=0, is.y.arg=TRUE, name=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, modvars=get.modvars(x, xassign, terms), # Sep 2020 xlevels=.getXlevelsMulti(terms, mf), ylevels=ylevels) } # modvars is a matrix specifying which input variables # are used in each column of the model matrix. # # Called by get.data.from.formula() # and by expand.arg.modvars() when the arg has to expanded by calling model.matrix. # # Columns correspond to columns of the model matrix (same as cols of earth$dirs). # Rows correspond to unique "naked" variables in the formula. # # Example (cf earth.object.Rd): # # formula: survived ~ age + pclass + sqrt(age) + sex + sex:parch + offset(off) # # attr(terms,"factors"), same colnames as earth$dirs: # # age pclass sqrt(age) sex sex:parch # survived 0 0 0 0 0 # response will be dropped # age 1 0 0 0 0 # pclass 0 1 0 0 0 # sqrt(age) 0 0 1 0 0 # sqrt(age) will be merged with age # sex 0 0 0 1 2 # 2 is inherited from attr(terms,"factors") # parch 0 0 0 0 1 # offset(off) 0 0 0 0 0 # offset will be marked as 9999 below # # modvars: # age pclass2nd pclass3rd sqrt(age) sexmale sexfemale:parch sexmale:parch # age 1 0 0 1 0 0 0 # pclass 0 1 1 0 0 0 0 # sex 0 0 0 0 1 2 2 # parch 0 0 0 0 0 1 1 # off 9999 9999 9999 9999 9999 9999 9999 get.modvars <- function(x, xassign, terms) { factors <- attr(terms,"factors") offset <- 0 if(!is.null(attr(terms,"offset"))) offset <- attr(terms,"offset") if(offset) # mark offset row as special factors[offset,] <- rep(9999, length.out=ncol(factors)) # drop response # following relies on extra attr "Response" added in get.data.from.formula is.Formula <- !is.null(attr(terms, "Response")) if(is.Formula) { # Formula interface: factors includes response rows and cols iresp <- attr(terms, "Response") if(all(iresp) > 0) factors <- factors[-iresp, -iresp, drop=FALSE] } else { # formula interface: includes response row but not response col iresp <- attr(terms, "response") if(all(iresp) > 0) # iresp will be 0 if no respose e.g. formula is ~x1+x2 factors <- factors[-iresp, , drop=FALSE] } # keep rows only for used variables # (note: variables will be unused if there is a "-" in the formula) # e.g. rownames num,int,fac,sqrt(num),ord,bool,offset(off) # becomes num, fac,sqrt(num),ord,bool,offset(off) factors <- factors[which(rowSums(factors) > 0), , drop=FALSE] modvars <- matrix(0, nrow=nrow(factors), ncol=ncol(x)) colnames(modvars) <- colnames(x) rownames(modvars) <- naken(rownames(factors)) # e.g. num,fac,sqrt(num),ord,bool,offset(off) # to num,fac,num ord,bool,off nrow <- nrow(modvars) unique <- rep(TRUE, length.out=nrow) if(nrow > 0) { for(irow in 1:nrow(modvars)) for(icol in 1:ncol(modvars)) modvars[irow, icol] <- factors[irow, xassign[icol]] } if(nrow > 1) { # merge rows with duplicate rownames into first row with that rowname rownames <- rownames(modvars) for(i in 1:(nrow-1)) for(j in (i+1):nrow) if(rownames[j] == rownames[i]) { # row j is a duplicate of row i? unique[j] <- FALSE modvars[i,] <- modvars[i,] + modvars[j,] # merge row j into row i } } # drop rows with duplicated rownames modvars <- modvars[unique, , drop=FALSE] # to num,fac, ord,bool,off modvars } get.identity.modvars <- function(x) # uses ncol(x) and colnames(x) { modvars <- diag(ncol(x)) colnames(modvars) <- rownames(modvars) <- colnames(x) modvars } 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) } # 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] == "|") } # 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") } } # 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.R0000644000176200001440000006706613722315615013610 0ustar liggesusers# call.dots.R: functions to handle prefixed dot arguments # # This file provides support for "prefixed" dot arguments. For example in # plotmo(), the user can specify predict.foo=3 as a dots argument. From # the prefix, plotmo recognizes that the argument is for predict, and # passes the argument to predict as foo=3. #----------------------------------------------------------------------------- # call.dots calls function FUNC with special processing of the dot arguments. # # It drops all args in dots matching DROP except those matching # PREFIX and FORMALS, then passes the remaining dot args to function FUNC. # By default FORMALS is the formal arguments of FUNC. # # If argname is prefixed with "force." then ignore any such arg in dots. # Any argname prefixed with "def." can be overridden by a user arg in dots. call.dots <- function( FUNC = NULL, # the function to call ..., PREFIX = NULL, # default NULL means no prefix DROP = "*", # default drops everything except args matching PREFIX KEEP = "PREFIX", TRACE = 0, # for debugging FNAME = if(is.character(FUNC)) FUNC else trunc.deparse(substitute(FUNC)), FORMALS = NULL, # formal args of FUNC (NULL means get automatically, but # can't always do that because because CRAN doesn't allow :::) SCALAR = FALSE, # see argument "scalar" in eval.dotlist CALLARGS = NULL, CALLER = NULL) { stopifnot(is.logical(TRACE) || is.numeric(TRACE), length(TRACE) == 1) TRACE <- as.numeric(TRACE) if(TRACE >= 2) { if(is.null(CALLER)) CALLER <- callers.name() printf("%s invoked call.dots\n", CALLER) } if(is.null(CALLARGS)) CALLARGS <- callargs(call.dots) args <- deprefix(FUNC=FUNC, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME=FNAME, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS) do.call.trace(FUNC, args, FNAME, trace=TRACE) } # A version of call.dots specialized for calling plotting functions. # This drops all args in dots except those matching PREFIX and PLOT.ARGS. call.plot <- function( FUNC = NULL, # same as call.dots ..., PREFIX = NULL, # if not specified, match only PLOT.ARGS TRACE = 0, # same as call.dots FORMALS = NULL, # same as call.dots SCALAR = FALSE) # same as call.dots { fname <- trunc.deparse(substitute(FUNC)) callargs <- callargs(call.plot) caller <- callers.name() # function that invoked call.plot call.dots(FUNC=FUNC, PREFIX=PREFIX, ..., DROP="*", # drop everything KEEP="PREFIX,PLOT.ARGS", # except args matching PREFIX and PLOT.ARGS TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=callargs, CALLER=caller) } deprefix <- function( FUNC = NULL, ..., PREFIX = NULL, DROP = NULL, KEEP = NULL, TRACE = 0, FNAME = if(is.character(FUNC)) FUNC else trunc.deparse(substitute(FUNC)), FORMALS = NULL, SCALAR = FALSE, CALLARGS = NULL) { stopifnot(is.logical(TRACE) || is.numeric(TRACE), length(TRACE) == 1) TRACE <- as.numeric(TRACE) if(!is.null(FUNC)) match.fun(FUNC) # check that FUNC is available and is a function FNAME <- init.fname(FNAME, FUNC, TRACE) higher.caller <- higher.caller.to.deprefix(..., FNAME=FNAME) PREFIX <- init.prefix(PREFIX, FUNC, FNAME) if(is.null(CALLARGS)) CALLARGS <- callargs(deprefix) DROP <- expand.drop(DROP, PREFIX, FUNC, FORMALS) KEEP <- expand.drop(KEEP, PREFIX, FUNC, FORMALS, namedrop="KEEP", callargs=CALLARGS, include.standard.prefixes=TRUE) dots <- match.call(expand.dots=FALSE)$... trace.prolog(TRACE, PREFIX, DROP, KEEP, dots, higher.caller) stopif.unnamed.dot(dots, higher.caller, ...) org.dots <- dots if(!is.null(DROP)) dots[grep(DROP, names(dots))] <- NULL stopifnot(!is.null(KEEP)) for(name in names(org.dots)) if(grepl(KEEP, name)) dots[[name]] <- org.dots[[name]] trace.after.dropkeep(TRACE, dots) args <- deprefix.aux(FUNC, dots, PREFIX, FNAME, FORMALS, TRACE) # workhorse eval.dotlist(args, n=2, scalar=SCALAR) # n=2 for caller of deprefix e.g. call.dots } deprefix.aux <- function(func, dots, prefix, fname, formals, trace) # workhorse { force <- "^force\\." # "force." as a regex def <- "^def\\." # "def." as a regex # change prefix to a regex, "plot." becomes "^plot\." prefix <- paste0("^", gsub(".", "\\.", prefix, fixed=TRUE)) groups <- list() # list with three elements: force, prefix, def args for(pref in c(force, prefix, def)) { # put args matching pref into group, with the prefix pre removed which <- grep(pref, names(dots)) # select only args matching pref group <- dots[which] # put them into the group group <- expand.dotnames(group, pref, func, fname, formals) names(group) <- sub(pref, "", names(group)) # remove prefix groups[[pref]] <- group dots[which] <- NULL # remove args in this group from dots } # dots is now just those arguments which did not have a special prefix dots <- expand.dotnames(dots, prefix="", func, fname) # "" matches anything args <- groups[[def]] # "def." args lowest precedence args <- merge.list(args, dots) # next come remaining dots args <- merge.list(args, groups[[prefix]]) args <- merge.list(args, groups[[force]]) # "force." args overrule all others args <- drop.args.prefixed.with.drop(args) order.args(args, trace) } # Argument names for plot functions. We exclude "overall" par() args like # mfrow that shouldn't be included when calling functions like plot(), # lines(), or text(). # # If specified in a DROP or KEEP string, the actual argument must exactly # match the PLOT.ARGS argument to be dropped or kept --- abreviated actual # args won't be matched (otherwise we would match too much, e.g. an actual # arg "s" would match "srt"). PLOT.ARGS <- c("add", "adj", "bty", "cex", "cex.axis", "cex.lab", "cex.main", "cex.sub", "col", "col.axis", "col.lab", "col.main", "col.sub", "crt", "family", "font", "font", "font.axis", "font.lab", "font.main", "font.sub", "lend", "ljoin", "lmitre", "lty", "lwd", "main", "pch", "srt", "xaxp", "xaxs", "xaxt", "xlab", "xlim", "xlog", "xpd", "yaxp", "yaxs", "yaxt", "ylab", "ylim", "ylog") # Arguments for par(). This list includes all par arguments except # readonly arguments (e.g. cin) and unimplemented arguments (e.g. err). # The actual argname must be an exact match to be recognized (no abbreviations). # Following omitted because they change too much: col, lwd PAR.ARGS <- c("adj", "ann", "ask", "bg", "bty", "cex", "cex.axis", "cex.lab", "cex.main", "cex.sub", "col.axis", "col.lab", "col.main", "col.sub", "crt", "err", "family", "fg", "fig", "fin", "font", "font.axis", "font.lab", "font.main", "font.sub", "lab", "las", "lend", "lheight", "ljoin", "lmitre", "lty", "mai", "mar", "mex", "mfcol", "mfg", "mfrow", "mgp", "mkh", "new", "oma", "omd", "omi", "pch", "pin", "plt", "ps", "pty", "srt", "tck", "tcl", "usr", "xaxp", "xaxs", "xaxt", "xlog", "xpd", "yaxp", "yaxs", "yaxt", "ylbias", "ylog") # Arguments for par() which take a vector value (i.e. length of value is not one). PAR.VEC <- c("fig", "fin", "lab", "mai", "mar", "mfcol", "mfg", "mfrow", "mgp", "oma", "omd", "omi", "pin", "plt", "usr", "xaxp", "yaxp") # Arguments that are used for subplots in plotmo and similar programs. # # Useful for dropping all args that could conceivably be plotting # arguments and will never(?) be a predict() or residuals() argument. # # When "PLOTMO.ARGS" is used in a DROP string, any actual arg _prefixed_ # with any of these is dropped (as opposed to PLOT.ARGS and PAR.ARGS we drop # actual argnames that _exactly_ match argnames in PLOT.ARGS and PAR.ARGS). # # "nresiduals", is for back compat with old versions of plot.earth PLOTMO.ARGS <- c( "caption.", "cex.", "col.", "contour.", "cum.", "degree1.", "degree2.", "density.", "filled.contour.", "font.", "func.", "grid.", "heatmap.", "image.", "jitter.", "legend.", "label.", "level.", "line.", "lines.", "lty.", "lty.", "lwd.", "main.", "mtext.", "nresiduals", "par.", "pch.", "persp.", "plot.", "plotmath.", "prednames.", "qq.", "qqline.", "pt.", "response.", "rug.", "smooth.", "text.", "title.", "vfont.") # from now on in this module function defs are in alphabetic order add.formals.to.drop <- function(drop, func, formals, namedrop) { stopifnot(grepl("FORMALS", drop)) if(is.null(func)) stop0("\"FORMALS\" specified in ", namedrop, ", but FUNC is NULL") formals <- merge.formals(func, formals, must.exist=TRUE) formals <- paste0(formals, collapse=",") # vector to string drop <- sub("FORMALS[,]", "", drop) # remove "FORMALS," from drop paste.drop(">FORMALS", formals, drop) # add the formal args } # Return the names of the actual args passed to the caller of this function, # ignoring args matching formals of the caller and ignoring dots. # # For example, for call.dots(foo, PREFIX="anything", x=1, y=1, ...), this # function returns c("x", "y"), because x and y are in the argument list # in the call to call.dots but don't match any of the formals of call.dots # (as PREFIX does). The "..." is ignored. # TODO if these were forced we wouldn't need the force.argument callargs <- function(func) { # names of arguments passed to the func that invoked callargs # args passed in dots will not appear in names names <- names(sys.call(-1)) names <- names[names != ""] # drop unnamed args # drop formal arguments (typically PREFIX, KEEP, etc.) names[!(names %in% names(formals(func)))] } # return string "a,b,c,d,e" if given c("a", "b,c", "d e") # i.e. white space converted to comma, c() collapsed to single string canonical.drop <- function(drop, namedrop) { drop <- gsub(" +|,+", ",", drop) # convert space or multi commas to comma drop <- gsub("^,+|,+$", "", drop) # drop leading and trailing commas drop <- unlist(strsplit(drop, split=",")) # convert to a vector drop <- paste0(drop, collapse=",") # collapse stopifnot.identifier(drop, namedrop, allow.specials=TRUE) drop } # TODO add this check elsewhere in earth and plotmo too check.regex <- function(s) # check for some common regex errors { if(grepl("||", s, fixed=TRUE)) stop0("\"||\" in following regex matches everything:\n", "\"", s, "\"") if(grepl("^\\|", s)) stop0("\"|\" at the start of the following regex matches everything:\n", "\"", s, "\"") if(grepl("\\|$", s)) stop0("\"|\" at the end of the following regex matches everything:\n", "\"", s, "\"") } # convert drop to a regex, "x,y*,prefix." becomes "^x|^y.*|^prefix\." convert.drop.to.regex <- function(drop) { drop <- gsub(",", "|", drop) # change comma to | drop <- gsub(".", "\\.", drop, fixed=TRUE) # escape period, "plot." becomes "plot\." drop <- gsub("*", ".*", drop, fixed=TRUE) # change * to .* # clean up, for example we now may have "||" in drop which must be changed to "|" for(iter in 1:2) { # two iterations seems sufficient in practice drop <- gsub(" +", "", drop) # delete spaces drop <- sub("^\\|", "", drop) # delete | at at start drop <- sub("^\\|", "", drop) # delete | at at end drop <- gsub("^^", "^", drop, fixed=TRUE) # change ^^ to single ^ drop <- gsub("||", "|", drop, fixed=TRUE) # change || to | } # prepend ^ to match prefixes only, "x|y" becomes "^x|^y" drop <- unlist(strsplit(drop, split="|", fixed=TRUE)) drop <- ifelse(substr(drop, 1, 1) == ">", drop, paste0("^", drop)) drop <- paste0(drop, collapse="|") check.regex(drop) # sanity check for some common regex errors drop } # TODO add to test suite (although this is tested implicitly in the plotmo tests) # what happens if the argname is abbreviated and no formals to match against? drop.args.prefixed.with.drop <- function(args) { for(name in names(args)) if(grepl("^drop\\.", name)) { check.integer.scalar(args[[name]], logical.ok=FALSE, object.name=name) if(args[[name]] != 1) stop0(name, "=1 is not TRUE") args[[name]] <- NULL # drop the drop.xxx argument itself name <- sub("drop.", "", name, fixed=TRUE) # delete "drop." from name # TODO allow dropping if just the prefix of name matches name <- paste0("^", name, "$") # turn it into a regex for exact matching args[grep(name, names(args))] <- NULL # drop args that exactly match name } args } # Only dot names that have the given prefix are considered. Expand the # suffix of each of those dot names to its full formal name using the # standard R argument matching rules. # # Example: with prefix = "persp." and func = persp.default, # "persp.sh" in dots gets expanded to "persp.shade", because # "shade" is the full name of an argument of persp.default. # # Among other things, This makes it possible for deprefix to properly # process two actual argument names that are different but both match # the same formal argument name. # # It also helps prevent downstream name aliasing issues, because here we # can pre-emptively check for argname matching problems, and issue clearer # error messages than the standard R arg matching error messages. expand.dotnames <- function( dots, prefix, # a regex, not a plain string func = NULL, # if NULL then we just check for duplicate args and go home fname, # used only in error messages formals = NULL) # manual additions to the formal arg list of func { stopifnot(is.list(dots)) dot.names <- names(dots) matches <- grep(prefix, dot.names) # indices of arg which match prefix if(length(matches) == 0) return(list()) if(is.null(func)) { duplicated <- which(duplicated(dot.names)) if(length(duplicated)) stop0("argument '", dot.names[duplicated[1]], "' for ", fname, "() is duplicated") return(dots[matches]) } # match against the formal arguments of func stopifnot(!is.null(dot.names)) unexpanded.names <- dot.names formals <- merge.formals(func, formals) for(idot in matches) { # for all arguments which match prefix dot.name <- dot.names[idot] stopifnot(nzchar(dot.name)) raw.prefix <- "" raw.dotname <- dot.name if(nzchar(prefix)) { # strip off the prefix substring in dot.name (we will put it back later) start <- regexpr(prefix, dot.name) stopifnot(start == 1) # prefix matches only prefixes stop <- start + attr(start, "match.length") stopifnot(stop > start) raw.prefix <- substr(dot.name, start=start, stop=stop-1) # as string not regex raw.dotname <- substring(dot.name, first=stop) # dotname with prefix removed } match <- charmatch(raw.dotname, formals) if(anyNA(match)) { # No match, not necessarily a problem assuming FUNC has a dots formal arg. # We will allow FUNC to check for itself later (if someone calls it). NULL } else if(match == 0) { # multiple matches matches <- grep(paste0("^", raw.dotname), formals) stopifnot(length(matches) >= 2) stop0("'", raw.dotname, "' matches both the '", formals[matches[1]], "' and '", formals[matches[2]], "' arguments of ", fname, "()") } else # single match, this is the ideal situation dot.names[idot] <- paste0(raw.prefix, formals[match]) # prepend prefix } stopifnot.expanded.dotnames.unique(dot.names, unexpanded.names, fname, formals, prefix) names(dots) <- dot.names dots } # returned the expanded the drop argument as a regex expand.drop <- function(drop, prefix, func, formals=NULL, # manual additions to the formal arg list of func namedrop="DROP", callargs=NULL, include.standard.prefixes=FALSE) { if(is.null(drop)) { if(include.standard.prefixes) return(paste0("^force.|^def.|^", prefix)) else return(NULL) } drop <- canonical.drop(drop, namedrop) if(drop == "*") return(".*") # regex to match everything # TODO following is helpful in the trace print only if # you put special identifiers AFTER the other identifiers drop <- paste.drop(">EXPLICIT", drop, "") if(length(callargs) > 0) drop <- paste.drop(">CALLARGS,", paste0(callargs, "$", collapse=","), drop) if(include.standard.prefixes) { drop <- sub("PREFIX", "", drop) # delete "PREFIX" from drop, if present drop <- paste.drop(">PREFIX,", prefix, drop) drop <- paste.drop(">STANDARDPREFIXES,", "force.,def.,drop.", drop) } else drop <- paste.drop(">PREFIX,", sub("PREFIX", prefix, drop), "") if(grepl("FORMALS", drop)) drop <- add.formals.to.drop(drop, func, formals, namedrop) temp <- paste.drop(">PLOT_ARGS,", paste0(PLOT.ARGS, "$", collapse=","), "") drop <- sub("PLOT.ARGS", temp, drop) temp <- paste.drop(">PAR_ARGS,", paste0(PAR.ARGS, "$", collapse=","), "") drop <- sub("PAR.ARGS", temp, drop) temp <- paste.drop(">PLOTMO_ARGS,", paste0(PLOTMO.ARGS, collapse=","), "") drop <- sub("PLOTMO.ARGS", temp, drop) convert.drop.to.regex(drop) # convert drop to a regex } higher.call.args <- function(..., CALLX, FNAME) { stopifnot(is.list(CALLX)) CALLX[1] <- NULL # remove fname from CALLX if(CALLX[length(CALLX)] == "...") # remove dots from CALLX CALLX[length(CALLX)] <- NULL args <- eval.dotlist(as.list(CALLX)) # add dots to args, if they are not already in args dots <- as.list(match.call(expand.dots=FALSE)$...) arg.names <- names(args) dot.names <- names(dots) for(i in seq_along(dots)) { if(!(dot.names[i] %in% arg.names)) { list <- list(eval(dots[[i]])) names(list) <- dot.names[i] args <- append(args, list) } } args[[1]] <- as.name(FNAME) list.as.char(args) } # used only for tracing and error messages # TODO simplify this and friends when match.call is working (R 3.2.0) higher.caller.to.deprefix <- function(..., FNAME=FNAME) { # search the stack looking for org caller of prefix e.g. call.plot sys.calls <- sys.calls() ncalls <- length(sys.calls) stopifnot(ncalls > 2) higher.fname <- "FUNC" try.was.used <- FALSE for(i in max(ncalls-10, 1) : ncalls) { fname <- paste(sys.calls[[i]][1]) # TODO is [1] in the correct position? if(grepl("^call\\.|^deprefix", fname)) break if(grepl("^doTry|^try", fname)) try.was.used <- TRUE else higher.fname <- fname } call <- as.list(sys.calls[[i]]) fname <- paste(call[[1]]) if(try.was.used) higher.fname <- paste0(higher.fname, " via try ") # use try here for paranoia args <- try(higher.call.args(..., CALLX=call, FNAME=FNAME), silent=TRUE) if(is.try.err(args)) args <- sprint("%s, ...", FNAME) sprint("%s called %s(%s)", higher.fname, fname, args) } init.fname <- function(FNAME, FUNC, TRACE) { # check deparse(substitute(FUNC)) issued a good function name # e.g. FNAME will be "NULL" if FUNC is NULL if(is.null(FNAME) || length(FNAME) != 1 || FNAME == "NULL") FNAME <- "FUNC" stopifnot.string(FNAME) FNAME <- sub(".*:+", "", FNAME) # graphics::lines becomes lines stopifnot.identifier(FNAME, "FNAME") FNAME } init.prefix <- function(PREFIX, FUNC, FNAME) { if(is.null(PREFIX)) { # automatic prefix, so check that we can generate it safely if(is.null(FUNC)) stop0("PREFIX must be specified when FUNC is NULL") PREFIX <- sub("\\..*$", "", FNAME) # lines.default becomes lines # Was deprefix invoked using FUNC=FUNC or in a try block? # This won't catch all cases of FUNC=unusable.name but it helps # The stopifnot.identifier() below also helps. if(PREFIX %in% c("FUNC", "doTryCatch")) stop0("PREFIX must be specified in this context ", "(because FNAME is \", fname, \")") PREFIX <- paste0(PREFIX, ".") # add a period stopifnot.identifier(PREFIX, "the automatically generated PREFIX") } stopifnot.identifier(PREFIX, "PREFIX", allow.empty=TRUE) if(PREFIX == "") PREFIX <- ">NOPREFIX" # no argname can match this PREFIX } # return a char vector: formal() of func plus names in manform # manform is manually specified formals merge.formals <- function(func, manform, must.exist=FALSE) { formals <- names(formals(func)) if(!is.null(manform)) formals <- c(formals, strsplit(canonical.drop(manform, "manform"), ",")[[1]]) if(must.exist) { if(length(formals) == 0) stop0("\"FORMALS\" specified but formals(FUNC) ", "returned no formal arguments") if(length(formals[formals != "..."]) == 0) stop0("\"FORMALS\" specified but formals(FUNC) returned only \"...\"") } formals <- formals[formals != "..."] # drop arg named "..." in formals, if any sapply(formals, stopifnot.identifier) # check that all names are valid unique(formals) } # Put the "anon" args first in the argument list. # Then put args named "object", "x", etc. at the front of the list # (after the anon args if any). This is necessary because all the # manipulation we have done has sadly done some reordering of the args # (meaning that the order of the args supplied to call.dots is only # partially retained). The names object, x, etc. are usually what we want # at the start for the predict and plot functions used with call.dots. order.args <- function(args, trace) { trace2(trace, "return dotnames ") if(length(args)) { # order anonymous args on their names, then delete their names which <- which(grepl("^anon", names(args))) anon <- args[which] # select args with "anon." prefix args[which] <- NULL # remove them from the arg list anon <- anon[order(names(anon))] # order them on their names trace2(trace, "%s", paste0(names(anon), collapse=" ")) names(anon) <- NULL # delete their names args1 <- anon # anon args go first in the arg list # Put arguments named "object", "x", etc. first (after anon args if any). # We want mfrow and mfcol early so subsequent args like cex have the last say. for(argname in c("object", "x", "y", "type", "main", "xlab", "ylab", "mfrow", "mfcol")) { args1[[argname]] <- args[[argname]] args[[argname]] <- NULL # remove from args } args <- append(args1, args) # append remaining args to the list if(trace >= 2) cat0(paste.collapse(names(args)), "\n") } trace2(trace, "\n") args } # paste.drop("prefix", "", drop) returns "prefix,DROP" # paste.drop("prefix", "x", drop) returns "prefix,x,DROP," # paste.drop("prefix", "x,y", drop) returns "prefix,x,y,DROP," # paste.drop("prefix", c("x","y"), drop) returns "prefix,x,y,DROP," paste.drop <- function(prefix, s, drop) { s <- paste(s, collapse=",") if(nzchar(s)) paste0(prefix, ",", s, ",", drop) else paste0(prefix, ",", drop) } stopif.unnamed.dot <- function(dots, higher.caller, ...) # called from deprefix() { which <- which(names(dots) == "") if(length(which)) { call <- sprint("\n %s\n", paste0(strwrap(higher.caller, width=getOption("width"), exdent=10), collapse="\n")) dot <- dots[[ which[1] ]] env <- parent.frame(2) arg <- try(eval(dot, envir=env, enclos=env), silent=TRUE) if(is.try.err(arg)) # fallback to weaker error message "(argument ..1 is unnamed)" stop0("Unnamed arguments are not allowed here", " (argument ", as.char(dot), " is unnamed)", call) else stop0("Unnamed arguments are not allowed here", "\n The argument's value is ", as.char(arg), call) } } stopifnot.expanded.dotnames.unique <- function(expanded.names, unexpanded.names, fname, formals, prefix) { duplicated <- which(duplicated(expanded.names)) if(length(duplicated) == 0) return() # no duplicates if(is.null(formals)) stop0("argument '", unexpanded.names[duplicated[1]], "' for ", fname, "() is duplicated") else { # a little processing is needed because we want to report the # error using the unexpanded.names, not the expanded names # get the index of the duplicated argument's twin duplicated <- duplicated[1] for(twin in 1:duplicated) if(expanded.names[twin] == expanded.names[duplicated]) break stopifnot(twin < duplicated) # get the formal argument matched by the duplicated arguments match <- charmatch(sub(prefix, "", expanded.names[duplicated]), formals) if(anyNA(match)) # Dot args are duplicated, but don't match any formal arg. Probably # because e.g. force.xlab is specified but force.xlab is also passed # in dots to call.dots (an error in the way call.dots is invoked). stop0("argument '", unexpanded.names[duplicated[1]], "' for ", fname, "() is duplicated") else if(unexpanded.names[twin] == unexpanded.names[duplicated]) # dot args are identical and they both match the formal stop0("argument '", unexpanded.names[duplicated[1]], "' for ", fname, "() is duplicated") else # dot args are not identical but both match the formal stop0("'", unexpanded.names[twin], "' and '", unexpanded.names[duplicated], "' both match the '", formals[match[1]], "' argument of ", fname, "()") } } trace.after.dropkeep <- function(trace, dots) { if(trace >= 2) printf("after DROP and KEEP %s\n", paste.collapse(names(dots))) } trace.prolog <- function(trace, prefix, drop, keep, dots, higher.caller) { if(trace >= 2) { printf.wrap("TRACE %s", higher.caller) printf("\nPREFIX %s\n", prefix) printf("DROP %s\n", if(is.null(drop)) "NULL" else gsub("\\|>", "\n >", drop)) printf("KEEP %s\n", if(is.null(keep)) "NULL" else gsub("\\|>", "\n >", keep)) names <- names(dots) names[which(names=="")] <- "UNNAMED" printf("input dotnames %s\n", paste.collapse(names)) } } earth/NEWS.md0000644000176200001440000011227114567100131012455 0ustar liggesusers# Changes to the earth package ## 5.3.3 Feb 16, 2024 Updates for R version 4.3.2. For example, had to change "sort.unique" to "sort_unique". On leaps.f, changed "IF (NBEST .GT. 0)" to "IF (NBEST .GT. -1)" in subroutines FORWRD and BAKWRD in order to match corresponding changes in the leaps package. Removed dependency on possibly orphaned package TeachingDemos. ## 5.3.2 Jan 26, 2023 Modified use of "bool" in the C code to conform to C23 (which predefines "bool"). Changed sprintf to snprintf to prevent a warning in the Debian build for CRAN. Changed the "NEWS" filename to "NEWS.md", and changed it to markdown format. Earth now issues an error if colnames in x are duplicated because of factor expansion. Thanks to Jens Heumann at Jacobs Center UZH for spotting this. ## 5.3.1 July 19, 2021 Minor updates for R version 4.1.0: o Updates to the test scripts for ordered factors. o Update to the code that reports missing arguments. ## 5.3.0 Oct 10, 2020 Fixed a minor bug where occasionally, for binary variables, earth put a 1 when it should have put a 2 into the dirs matrix. The bug was invisible unless you accessed earth's dirs matrix directly. In some circumstances this fix may cause earth to build slightly different models (an internal boundary check for almost-zero in earth.c was modified). Thanks to Max Kuhn for reporting this issue. Updated the .c and .h files to use the more modern header file where appropriate (i.e. when not in an R environment). We now also check that sizeof(bool)==sizeof(Rboolean) when called from R. Updated some trace prints in earth.c (only affects very high trace levels). Test suite additions: Added test.earthc.gcc.bat and test.earthc.clang.bat. Extended inst/slowtests/test.earthc.c to include binary predictors. Added test.numstab.R to test models which are known to give (slightly) different results with different compilers. Extended the clang tests. We now use version VC16 (Visual Studio 2019) of the Microsoft compiler. Miscellaneous other test updates. Minor documentation updates. ## 5.2.0 Sep 15, 2020 Earth now has better support for models with unusual variable names: for example, variable names with spaces in them, and formula terms like "as.numeric(x1)". Earth model selection graph: * The text "selected model" is now first in the menu. * Minor adjustments for vertical lines which overlay each other. * The graph with nprune or pmethod="cv" models is now a little clearer. Better support for residual plots for earth-glm models. By default, plotmo now plots the offset if specified in the earth model formula. Under certain circumstances when nprune was used with pmethod="cv", summary.earth would issue an incorrect error message. Fixed that with help from Boris Leroy at the Museum national d'Histoire naturelle (Paris). Earth objects now have a "modvars" field. See the help page for earth.object. Earth objects no longer have a "namesx.org" field, and the "namesx" field is deprecated. These fields have been subsumed by the "modvars" field. Updated the libraries shared with the earth and plotmo packages. Support for unusual variable names (mentioned above) required a fairly substantial change to the internal handling of formulas. It also affected the code that selects which variables to plot in plotmo. For easier maintenance, the source file earth.R was split into earth.R, earth.fit.R, and earth.prune.R. The new file naken.R was added for handling model variables. Extended the test scripts and updated them for R version 4.0.2. Added new test files test.emma.R and test.ordinal.R. Some documentation updates. ## 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 Jerome Guelat 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/MD50000644000176200001440000002266214567114553011710 0ustar liggesusers9d68b05056a357f56a738bc9f49308de *DESCRIPTION 0a72c23e5d519f4076f443d5aedcb5e3 *NAMESPACE bf55ef80438ddbf707bde7298f662d97 *NEWS.md 1467cd99f814516a11538ec00e136c45 *R/as.char.R f49721c94ea950302057e512ba82b184 *R/bpairs.R 4dcc6a18a5be035a1e4497dae7b7cedd *R/call.dots.R 8313e46b929e7315b0f6ab1b29aa3675 *R/check.index.R a121377a2962c8a2b3b5ea2f9952a34c *R/do.par.R 3c28173aa59055555bf5ed7079e0f51b *R/dot.R 5a08d54148030b9ae3a10edad3ec4691 *R/dotlib.R 80ad11d3a0d40cc5270881d13e787130 *R/earth.R 5b8b99e4a63db947da6a005bceb3b1cc *R/earth.cv.R b704ff531be0648caa56cae5036a9b92 *R/earth.cv.lib.R 8250f62778649a01d3d1968bffa996ed *R/earth.fit.R 994dd083fca001f51a58d7e9d634e5a1 *R/earth.glm.R 9bda58af45165858fb71c8e183167a2b *R/earth.leaps.R 4613864f6a19b1851859bfe46a2506a2 *R/earth.methods.R 7c82473386b533105c675559cbee5ada *R/earth.prune.R fb914aca46544a14e95f60ff0d317e9b *R/earth.regress.R aa67b6f1757775f2b4e184c3fe06841b *R/earthlib.R 861fba8a34b68a1dd39a3e0f62ab7f14 *R/elegend.R b1618f06a7e1d950eedeccae5bfbb1ad *R/evimp.R 31cfaf8532e88b3649e36f3d33094d0f *R/expand.arg.R 90a67037d8f611353126652ef1f113d5 *R/format.earth.R eb6a759ff9a07765a6e53b54809f702e *R/lib.R 8c638aba7dbfbb8e38f74ee385732776 *R/mars.to.earth.R 10bd52cb4c06db0dcd612ccf1fdf16bc *R/model.matrix.earth.R d69ebbe9df32a922e8886d735e779092 *R/naken.R fd2b18b51a74b84f315eb2a6008752d4 *R/offset.R da8a1ac04983b733353c550dfe6602ea *R/plot.earth.R 234728c0f2fd515c2906ce2ffba8e726 *R/plotd.R 3435b43a31925b0feae454ea02e33644 *R/plotmo.methods.earth.R f52fdeb376d75473e7167e5888111508 *R/predict.earth.R d0cba85d9f4febce7bfdb364ae64b644 *R/print.earth.R a7cfa01bdb6be6069eeed7f427df35ee *R/printcall.R 3da3e598c54833ba7afacefdfb254e85 *R/residuals.earth.R 52a0a2ea4b38645148ca48de84a0567b *R/spread.labs.R 10b221ee9b9f19e92623e133b629efe1 *R/stop.if.dots.R fd7cb440fb84aea7d07b86c319e3a0c2 *R/varmod.R b943a1546a1e17be4eea235ec7b4616b *build/partial.rdb ea521b18189dc9e26e3e8953602656de *data/etitanic.rda 15f5470c6245efd1c6d5e0ed0be996b4 *data/ozone1.rda 80c701f6d86dff4e6d5dab3cab33ae9a *inst/doc/Auto-linpreds-example.pdf dec569a1312ec3ebb215e6f013332d06 *inst/doc/earth-notes.pdf b9f44aedc56b9d5f3a23c79187305d89 *inst/doc/earth-varmod.pdf 58f7272bb093a45734854545a1b18224 *inst/doc/index.html d4aa9fde2958026574fe7ae4d6c7d0b2 *inst/slowtests/README.txt 6b172fd7356673f17958b185e169ca9a *inst/slowtests/check.earth.matches.glm.R ad43c84900ba29624c8036c9189e6c04 *inst/slowtests/check.models.equal.R ab7ac609cfe5a94d16de54049b8a0eab *inst/slowtests/earth.times.R 7abf7c4d8d96c0358a41554d5c5725e4 *inst/slowtests/earth.times.bat eaaa64e62138c8c744f1e33c9141f181 *inst/slowtests/earth.times.txt aefa5c83a29c929adda73d810fce508f *inst/slowtests/make.bat 03569b986889e504a6a817ba08bbc40b *inst/slowtests/makeclean.bat 80387dc1ec999cd4376789be312aed7e *inst/slowtests/test.allowedfunc.R 571b00874ac3fc35a7ab0f788d965010 *inst/slowtests/test.allowedfunc.Rout.save d7afa631ee39c21090b5f20c4eb7383c *inst/slowtests/test.allowedfunc.bat 0dac2b45b8553cd7ac2b63ae4040d37e *inst/slowtests/test.big.R aecadc82352670ebf09e2279ea89f1b2 *inst/slowtests/test.big.Rout.save c056d32582e668e04246df29102e63e2 *inst/slowtests/test.big.bat 8d78248617b29626ed9dfa499afc4231 *inst/slowtests/test.bpairs.R 546499cfaeeadaf1292b85b3d4c3f298 *inst/slowtests/test.bpairs.Rout.save d3bbd93fbc1ea6ca19d2ec54b8c304b6 *inst/slowtests/test.bpairs.bat 905c611a3a26660f8a8bd46254fa3142 *inst/slowtests/test.cv.R 0f4711d4f7139093290363d5760c4673 *inst/slowtests/test.cv.Rout.save 480888878e2fb700cc8ad7fcea2d7e4d *inst/slowtests/test.cv.bat 8e34b718d6f64a82a49ed6b3554fe344 *inst/slowtests/test.earthc.c 2cec709b1ada38470504131e35edd30f *inst/slowtests/test.earthc.clang.bat 01582f3a3f93b54a511ed0e786bea29c *inst/slowtests/test.earthc.gcc.bat 8d407ae379e8e17ff7a6c3667eebc265 *inst/slowtests/test.earthc.gcc.out.save 9cb1f452da28aba64115715370747499 *inst/slowtests/test.earthc.msc.bat a94ec506004e437b33ec0aae9c517555 *inst/slowtests/test.earthc.msc.mak 19b366b2f1bdcd9012b73bc41f6863ec *inst/slowtests/test.earthc.out.save 84c7cf82cfde5e9ac6d54745480cf94b *inst/slowtests/test.earthmain.clang.bat e32d9ee3790e3b4a6935ba86c3bd529d *inst/slowtests/test.earthmain.gcc.bat a47317f1e7814f82617c91adf6fd0518 *inst/slowtests/test.earthmain.gcc.out.save 5b580176a833e03c81437a06a7a918f2 *inst/slowtests/test.earthmain.msc.bat a47317f1e7814f82617c91adf6fd0518 *inst/slowtests/test.earthmain.out.save d0a1badfc3a6b587dc635ad270447969 *inst/slowtests/test.emma.R 75654f528223ea00dfbbdf8b9137b93b *inst/slowtests/test.emma.Rout e86a1a127cd4005d208eceb1f3ce9dff *inst/slowtests/test.emma.Rout.save f7de0536c539579efe9e36e950c5a1d1 *inst/slowtests/test.emma.bat 7306baea0c61d656121cd743183c8172 *inst/slowtests/test.epilog.R 6dab2e1ea90ceccde48050a77342ac25 *inst/slowtests/test.expand.bpairs.R 6ccd99815ba2eca3daafdf16ebf4b480 *inst/slowtests/test.expand.bpairs.Rout.save b4271daf05e65b09950063bfb03be3ff *inst/slowtests/test.expand.bpairs.bat 670cd78b6be404afd7d4e61507b0a71f *inst/slowtests/test.full.R 9f72448c4c66137323111ee6d4757d86 *inst/slowtests/test.full.Rout.save 6161a740e990022989dd8e26e24f6740 *inst/slowtests/test.full.bat 3b4ba8c66003dd099153d455f0912f3b *inst/slowtests/test.glm.R eb58e4ee5beb3dc32081fbb7f7fd8731 *inst/slowtests/test.glm.Rout.save 376248dec361f56ba51214486bba46aa *inst/slowtests/test.glm.bat 9b3d8f1bbc3581912075a8f36ffea7f4 *inst/slowtests/test.incorrect.R 537795be376114551d458bd0520e6ec5 *inst/slowtests/test.incorrect.Rout.save 49e6be005dfbf5079f2f2c5be6341e55 *inst/slowtests/test.incorrect.bat 5e562628c93379c73db7363f5fa25c88 *inst/slowtests/test.mem.R fae97000a11ed43d7ee2ed2ec3915bb8 *inst/slowtests/test.mem.Rout 3a07e730f90df7924977f0128d5d0496 *inst/slowtests/test.mem.Rout.save 21da8cf225fa0499157a594d5de4ce8b *inst/slowtests/test.mem.bat 201c6c2f71d90c0316850db2f924bb26 *inst/slowtests/test.mods.R 2bfb6c4801174e9e858e5f2a9350e618 *inst/slowtests/test.mods.Rout.save 9a5d814661df808a1f4b719d719788ec *inst/slowtests/test.mods.bat 57fc9cc24b187badef813e780c654948 *inst/slowtests/test.multresp.R 25a86a9d54a43fa73cce0c2e95c22c22 *inst/slowtests/test.multresp.Rout.save 77df7aaa26a23c9e448916db27a8e0fa *inst/slowtests/test.multresp.bat 44b9eb5cfc32d79609975be85621502f *inst/slowtests/test.numstab-mfpmath-387.Rout.save 839fdc8b410a8c2cdbf78cf6b52d3c25 *inst/slowtests/test.numstab.R 7de36421eae1f7df263cfa88169280bb *inst/slowtests/test.numstab.Rout.save 2cc1fdb7c70f1532e70f428a5d662840 *inst/slowtests/test.numstab.bat 375fcbc5845b30d1d862d3da673a4022 *inst/slowtests/test.offset.R 82f57710c8e0de2b8c4ffb4dde849610 *inst/slowtests/test.offset.Rout.save bc2bafd414c65f666286bdeb9f51ac69 *inst/slowtests/test.offset.bat 089daec84cd11d12ae2e96d855ef1c3f *inst/slowtests/test.ordinal.R ba19aba9edf4afc9abb5bc4189e73749 *inst/slowtests/test.ordinal.Rout.save 37f2a94405945e1a02a2a851a0363e9d *inst/slowtests/test.ordinal.bat b99852632741ce76087ce15a03b151f4 *inst/slowtests/test.plotd.R 1f3812f728c8bd2965456208e30b119d *inst/slowtests/test.plotd.Rout.save 3726a5b29dd1b14d8930903dc98ace78 *inst/slowtests/test.plotd.bat f1742efd763456b9d401a0c7b7e13a30 *inst/slowtests/test.pmethod.cv.R f3e5b916717459e939be51dcac5f78b4 *inst/slowtests/test.pmethod.cv.Rout.save f2fbb09e618306995cb109b4e55644fe *inst/slowtests/test.pmethod.cv.bat e152b8519f616894608c34ee2b5c27a9 *inst/slowtests/test.prolog.R 01c7bef3e050243ede802266ec7ceb4e *inst/slowtests/test.varmod.R 028b2cb2e64aa55ffb79ab009128f483 *inst/slowtests/test.varmod.Rout.save 6dca7883ad035e5225915c8a8a463f4b *inst/slowtests/test.varmod.bat 663384a3db761562525c858eba6c5e6f *inst/slowtests/test.varmod.mgcv.R 1b12dd39554ee0d04f3ea636527af126 *inst/slowtests/test.varmod.mgcv.Rout.save 5324022557308bd1e375c226515a4086 *inst/slowtests/test.varmod.mgcv.bat b47623f1bd3451f2a4f6556776eae5cd *inst/slowtests/test.weights.R a434a86eabb424e8a4235137cb2043c2 *inst/slowtests/test.weights.Rout.save 82c37e1658d949082f52be14bc5102d1 *inst/slowtests/test.weights.bat 5e8f2c2936cb04affe73d49102b2a151 *man/contr.earth.response.Rd b62b9589fc1b7e87f3dca68379b72f7c *man/earth.Rd a4a2af2dc2397224f44893499f74e1a1 *man/earth.object.Rd 0d5a443e9bfe590ebfd7b171bceabd9e *man/etitanic.Rd af099acb1ba78cbbb9ab6550e76f737e *man/evimp.Rd b97f7456181831a838ec529f68651902 *man/expand.bpairs.Rd 555803057ccb81fec7bedbe5888cf884 *man/format.earth.Rd fa3ac9aa1db811d2c809a87cfc334b38 *man/mars.to.earth.Rd dfa9617f1f9e1ca40cb76c59d50a10b5 *man/model.matrix.earth.Rd 4ccbfe52e6418b7aa550f54dad503e85 *man/ozone1.Rd f6c8a3df83bdcda16214b6ba030224a5 *man/plot.earth.Rd f856f9ec0fc3d79c80ce02f72618ed04 *man/plot.earth.models.Rd ee59058dbe1c343004fa8f112699e5ea *man/plot.evimp.Rd c9717666d3f944c0b4a1c82fe82dca6d *man/plot.varmod.Rd 46b6fbe82783a3a896ee98d47f6deee6 *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 d2bebc33965e1224286115326cae91e9 *man/varmod.Rd 8290d2e9740414e315237f0d5d4024bb *src/Makevars 4eb2f1364a1c47f704cb2cd022677946 *src/allowed.c c13959b9ec3e4b2ec8ff2c8755b0f092 *src/allowed.h acc1acf6b6e8a1092043c7225a073419 *src/earth.c 1445ac05084481f46f8289c31f4166b3 *src/earth.h e995cd8c4005687c22bc1476301493b5 *src/leaps.f f7b979854bdd049cda5b1e7c1e8ce5c4 *src/leapshdr.f 982b2dc288c49c1c295cd8ac2a050a06 *src/rentries.c 102bf0619953cf80628f770fe5da24ea *tests/README.txt 697b85ac96006ad37f389167033a8db7 *tests/test.earth.R f8f175c14db82293416e46f1dcfc33d6 *tests/test.earth.Rout.save earth/inst/0000755000176200001440000000000014334575364012350 5ustar liggesusersearth/inst/slowtests/0000755000176200001440000000000014567077660014423 5ustar liggesusersearth/inst/slowtests/test.prolog.R0000644000176200001440000000310513727246550017016 0ustar liggesusers# test.prolog.R # A safe version of sprintf. # Like sprintf except that %s on NULL prints "NULL" rather than # preventing the entire string from being printed # # e.g. sprintf("abc %s def", NULL) returns an empty string -- a silent failure! # but sprint("abc %s def", NULL) returns "abc NULL def" # # e.g. sprintf("abc %d def", NULL) returns an empty string! # but sprint("abc %d def", NULL) causes an error msg (not a silent failure) sprint <- function(fmt, ...) { dots <- list(...) dots <- lapply(dots, function(e) if(is.null(e)) "NULL" else e) do.call(sprintf, c(fmt, dots)) } printf <- function(fmt, ...) cat(sprint(fmt, ...), sep="") cat0 <- function(...) cat(..., sep="") strip.space <- function(s) gsub("[ \t\n]", "", s) # test that we got an error as expected from a try() call expect.err <- function(object, expected.msg="") { if(class(object)[1] != "try-error") stop("Did not get expected error: ", expected.msg) else { msg <- attr(object, "condition")$message[1] if(length(grep(expected.msg, msg, fixed=TRUE))) cat0("Got expected error from ", deparse(substitute(object)), "\n") else stop(sprint("Expected: %s\n Got: %s", expected.msg, substr(msg[1], 1, 1000))) } } empty.plot <- function() { plot(0, 0, col=0, bty="n", xaxt="n", yaxt="n", xlab="", ylab="", main="") } options(warn=1) # print warnings as they occur if(!interactive()) postscript(paper="letter") org.par <- par(no.readonly=TRUE) set.seed(2020) earth/inst/slowtests/test.expand.bpairs.R0000644000176200001440000003311713725313736020257 0ustar liggesusers# test.expand.bpairs.R: source("test.prolog.R") library(earth) options(warn=1) # print warnings as they occur # 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 =factor(c( "m", "m", "f", "f", "f", "f", "f", "f", "f", "f", "f")), pclass =factor(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("\n---print.default(stripped.long.expanded)------\n") print.default(stripped.long.expanded) printf("\n---print.default(long.ref)--------------------\n") print.default(long.ref) printf("\n----------------------------------------------\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) # treat warnings as errors 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) # print warnings as they occur 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.save0000644000176200001440000024607714565632542020503 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 > data(ozone1) > data(trees) > data(etitanic) > options(warn=1) # print warnings as they occur > > 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(org.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(org.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(org.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) 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)) 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) 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.033525 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(org.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(org.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 expected error 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~as.numeric(shade)+wide+tall*time, + data=lizards, glm=list(family="binomial"), + linpreds=TRUE, thresh=0, penalty=-1, trace=1) x[24,7] with colnames as.numeric(shade) wideTRUE tallTRUE timeMid timeLate tall... 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, 14, 16 No new term increases RSq (perhaps reached numerical limits) at 15 terms, 8 terms used After forward pass GRSq 0.852 RSq 0.852 Prune backward penalty -1 nprune null: selected 8 of 8 terms, and 7 of 7 preds After pruning pass GRSq 0.852 RSq 0.852 GLM grahami devratio 0.80 dof 15/22 iters 4 > print(summary(eliz)) Call: earth(formula=grahami.opalinus~as.numeric(shade)+wide+tall*time, data=lizards, trace=1, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1) GLM coefficients grahami (Intercept) 2.7497470 as.numeric(shade) -0.8524139 wideTRUE -0.7615229 tallTRUE 1.3647511 timeMid 0.2788588 timeLate -0.6100012 tallTRUE:timeMid -0.2352590 tallTRUE:timeLate -0.4958645 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 70.1018 22 13.682 15 0.805 86.51 4 1 Earth selected 8 of 8 terms, and 7 of 7 predictors Termination condition: No new term increases RSq at 8 terms Importance: tallTRUE, wideTRUE, timeLate, as.numeric(shade), timeMid, ... Number of terms at each degree of interaction: 1 7 (additive model) Earth GCV 0.06803856 RSS 1.632925 GRSq 0.852299 RSq 0.852299 > eliz.Formula <- earth(grahami+opalinus~as.numeric(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,7] with colnames as.numeric(shade) wideTRUE tallTRUE timeMid timeLate tall... 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, 14, 16 No new term increases RSq (perhaps reached numerical limits) at 15 terms, 8 terms used After forward pass GRSq 0.852 RSq 0.852 Prune backward penalty -1 nprune null: selected 8 of 8 terms, and 7 of 7 preds After pruning pass GRSq 0.852 RSq 0.852 GLM grahami devratio 0.80 dof 15/22 iters 4 > print(summary(eliz.Formula)) Call: earth(formula=grahami+opalinus~as.numeric(shade)+wide+tall*time, data=lizards, trace=1, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1) GLM coefficients grahami (Intercept) 2.7497470 as.numeric(shade) -0.8524139 wideTRUE -0.7615229 tallTRUE 1.3647511 timeMid 0.2788588 timeLate -0.6100012 tallTRUE:timeMid -0.2352590 tallTRUE:timeLate -0.4958645 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 70.1018 22 13.682 15 0.805 86.51 4 1 Earth selected 8 of 8 terms, and 7 of 7 predictors Termination condition: No new term increases RSq at 8 terms Importance: tallTRUE, wideTRUE, timeLate, as.numeric(shade), timeMid, ... Number of terms at each degree of interaction: 1 7 (additive model) Earth GCV 0.06803856 RSS 1.632925 GRSq 0.852299 RSq 0.852299 > gliz <- glm(grahami.opalinus~as.numeric(shade)+wide+tall*time, + data=lizards, family="binomial") > print(summary(gliz)) Call: glm(formula = grahami.opalinus ~ as.numeric(shade) + wide + tall * time, family = "binomial", data = lizards) Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) 2.7497 0.6226 4.416 1e-05 *** as.numeric(shade) -0.8524 0.3219 -2.648 0.008095 ** wideTRUE -0.7615 0.2115 -3.601 0.000317 *** tallTRUE 1.3648 0.4842 2.819 0.004820 ** timeMid 0.2789 0.2789 1.000 0.317437 timeLate -0.6100 0.3467 -1.759 0.078494 . tallTRUE:timeMid -0.2353 0.6215 -0.379 0.705032 tallTRUE:timeLate -0.4959 0.6885 -0.720 0.471368 --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 70.102 on 22 degrees of freedom Residual deviance: 13.682 on 15 degrees of freedom AIC: 86.506 Number of Fisher Scoring iterations: 4 > > check.earth.matches.glm(eliz, gliz, newdata=lizards[c(2:5),], max=1e-12) check eliz vs gliz > check.earth.matches.glm(eliz.Formula, gliz, newdata=lizards[c(2:5),], max=1e-12) check eliz.Formula vs gliz > print(evimp(eliz)) nsubsets gcv rss tallTRUE 7 100.0 100.0 wideTRUE 6 72.7 72.7 timeLate 5 53.5 53.5 as.numeric(shade) 4 35.8 35.8 timeMid 3 13.0 13.0 tallTRUE:timeMid 2 5.5 5.5 tallTRUE:timeLate 1 0.7 0.7 > 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(org.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 expected error 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 expected error 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 expected error 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 > > # Terms on lhs like I(20-numdead) are not supported in multiple response Formulas > # (else `log(O3)` is included in model matrix if log(O3) is used on lhs of the Formula) > # Tested Sep 2020, problem in Formula package? > expect.err(try(earth(I(20-numdead) + numdead ~ sex + ldose, data=df, trace=1, pmethod="none", + glm=list(family=binomial))), + "terms like 'I(20 - numdead)' are not allowed on the LHS of a multiple-response formula") Using class "Formula" because lhs of formula has terms separated by "+" Error : terms like 'I(20 - numdead)' are not allowed on the LHS of a multiple-response formula Got expected error from try(earth(I(20 - numdead) + numdead ~ sex + ldose, data = df, trace = 1, pmethod = "none", glm = list(family = binomial))) > > 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 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)) Warning in terms.formula(form, data = data) : 'varlist' has changed (from nvar=2) to new 3 after EncodeVars() -- should no longer happen! 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) > > 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) > > plotmo(pairmod_Formula, SHOWCALL=TRUE) plotmo grid: sex ldose female 0.5 > # plotmo(pairmod5, SHOWCALL=TRUE) > 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 expected error 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 expected error 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 expected error 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) 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) 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 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() > plot.earth.models(list(earth_cv, earth_cv$cv.list[[1]], earth_cv$cv.list[[2]]), which=1:2, do.par=0) > > # try plotmo on one of the fold models > expect.err(try(plotmo(earth_cv$cv.list[[1]])), "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 expected error from try(plotmo(earth_cv$cv.list[[1]])) > # can plotmo on a fold model if we use keepxy=2 in call to earth > set.seed(2020) > earth_cv.keepxy2 <- earth(good+bad~., data=data, glm=list(family=binomial), trace=.5, nfold=2, keepxy=2) Model with pmethod="backward": GRSq 0.949 RSq 0.963 nterms 4 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% > plotmo(earth_cv.keepxy2$cv.list[[1]], type="earth", SHOWCALL=TRUE) > > source("test.epilog.R") earth/inst/slowtests/test.numstab.R0000644000176200001440000004077414055552143017173 0ustar liggesusers# test.numstab.R: Expose any numerical instability of earth across platforms. # # This file was created by running earth and plotmo slowtests # with earth on Win7 built with "--mfpmath=387" (instead of "-mtune=native" # or "-mfpmath=sse -msse2"). # Differences between the output in the test suites from standard earth # were collected and put into this file. # So this code duplicates code in earth and plotmo slowtests. # Most but not all differences were captured and put into this file. # This file was originally created in in Oct 2020 for earth 5.3.0. source("test.prolog.R") library(earth) library(mda) data(ozone1) data(trees) data(etitanic) cat("\n#=== from test.full.R ===========================================\n") set.seed(2020) PLOT <- TRUE # TRUE to do plots too, FALSE for speed options.old <- options() options(warn=1) # print warnings as they occur 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) } 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("NUMSTAB 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 } set.seed(2020) data(ozone1) attach(ozone1) itest <- 1 set.seed(2020) 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 see "Fixed rank deficient bx by removing 2 terms, 7 terms remain" ozone.test(itest, "doy ~ wind+exp(humidity)", x.global, y, degree=1, nk=21, smooth.col=0, trace=2) # 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) set.seed(2020) cat("Auto.linpreds=TRUE pmethod=\"none\":\n") # trace==2 so we see "Fixed rank deficient bx by removing terms" # TODO why are we getting the rank deficient message? 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)))) set.seed(2020) 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("\n#=== from test.weights.R ===========================================\n") set.seed(2020) 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") a21.noweights <- earth(y~., data=data, # no weights for comparison minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) print(summary(a21.noweights)) 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) print(summary(a10)) cat("\n#=== from test.glm.R ===========================================\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)) cat("\n#=== from test.plotmo.R ===========================================\n") # check various types of predictors with grid.func and ndiscrete varied.type.data <- data.frame( y = 1:13, num = c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5), # 7 unique values (but one is non integral) int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L), # 8 unique values bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T), date = as.Date( c("2018-08-01", "2018-08-02", "2018-08-03", "2018-08-04", "2018-08-05", "2018-08-06", "2018-08-07", "2018-08-08", "2018-08-08", "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")), ord = ordered(c("ord3", "ord3", "ord3", "ord1", "ord2", "ord3", "ord1", "ord2", "ord3", "ord1", "ord1", "ord1", "ord1"), levels=c("ord1", "ord3", "ord2")), fac = as.factor(c("fac1", "fac1", "fac1", "fac2", "fac2", "fac2", "fac3", "fac3", "fac3", "fac1", "fac2", "fac3", "fac3")), str = c("str1", "str1", "str1", # will be treated like a factor "str2", "str2", "str2", "str3", "str3", "str3", "str3", "str3", "str3", "str3")) varied.type.earth <- earth(y ~ ., data = varied.type.data, thresh=0, penalty=-1, trace=1) print(summary(varied.type.earth)) cat("\n#=== from test.plotmo.args.R ===========================================\n") set.seed(2020) oz2 <- ozone1[1:40,] set.seed(2015) a <- earth(O3~temp+wind, dat=oz2, deg=2, nk=21, ncr=3, nfo=3, varmod.me="lm") print(summary(a)) plotmo(a, caption.col=3, caption.font=2, grid.col="pink", level=.8, SHOWCALL=TRUE) cat("\n#=== from test.plotmo3.R ===========================================\n") set.seed(2020) # basic tests of plotmo on abbreviated titanic data get.tita <- function() { tita <- etitanic pclass <- as.character(tita$pclass) # change the order of the factors so not alphabetical pclass[pclass == "1st"] <- "first" pclass[pclass == "2nd"] <- "class2" pclass[pclass == "3rd"] <- "classthird" tita$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) # log age is so we have a continuous predictor even when model is age~. set.seed(2015) tita$logage <- log(tita$age) + rnorm(nrow(tita)) tita$parch <- NULL # by=12 gives us a small fast model with an additive and a interaction term tita[seq(1, nrow(etitanic), by=12), ] } tita <- get.tita() # tita[,4] is age set.seed(2020) mod.earth.tita.age <- earth(tita[,-4], tita[,4], degree=2, nfold=3, ncross=3, trace=.5, varmod.method="lm") cat("\nsummary(mod.earth.tita.age)\n") print(summary(mod.earth.tita.age)) plotmo(mod.earth.tita.age, SHOWCALL=TRUE) set.seed(2020) mod.earth.sex <- earth(sex~., data=tita, degree=2, nfold=3, ncross=3, varmod.method="earth", glm=list(family=binomial), trace=.5) cat("\nsummary(mod.earth.sex)\n") print(summary(mod.earth.sex)) plotmo(mod.earth.sex, SHOWCALL=TRUE) cat("\n#=== from test.unusual.vars.R ===========================================\n") set.seed(2020) vdata <- data.frame( resp = 1:13, bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T), ord = ordered(c("ORD1", "ORD1", "ORD1", "ORD1", "ORD1", "ORD1", "ORD3", "ORD3", "ORD3", "ORD2", "ORD2", "ORD2", "ORD2"), levels=c("ORD1", "ORD3", "ORD2")), fac = as.factor(c("FAC1", "FAC1", "FAC1", "FAC2", "FAC2", "FAC2", "FAC3", "FAC3", "FAC3", "FAC1", "FAC2", "FAC3", "FAC3")), str = c("STR1", "STR1", "STR1", # WILL BE TREATED LIKE A FACTOR "STR2", "STR2", "STR2", "STR3", "STR3", "STR3", "STR3", "STR3", "STR3", "STR3"), num = c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5), # 7 unique values (but one is non integral) sqrt_num = sqrt(c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5)), int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L), # 8 unique values date = as.Date( c("2018-08-01", "2018-08-02", "2018-08-03", "2018-08-04", "2018-08-05", "2018-08-06", "2018-08-07", "2018-08-08", "2018-08-08", "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")), date_num = as.numeric(as.Date( c("2018-08-01", "2018-08-02", "2018-08-03", "2018-08-04", "2018-08-05", "2018-08-06", "2018-08-07", "2018-08-08", "2018-08-08", "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")))) vdata$off <- (1:nrow(vdata)) / nrow(vdata) resp2 <- 13:1 vweights <- rep(1, length.out=nrow(vdata)) vweights[1] <- 2 set.seed(2020) lognum.bool.ord.off <- earth(resp ~ log(num) + bool + ord + offset(off), degree=2, weights=vweights, data=vdata, pmethod="none", varmod.method="lm", nfold=2, ncross=3, trace=1) print(summary(lognum.bool.ord.off)) cat("\n#=== from test.caret.R ===========================================\n") set.seed(2020) library(caret) set.seed(2015) a.bag3 <- bagEarth(survived~., data=etitanic, degree=2, B=3, trace=1) print(a.bag3) plotmo(a.bag3, clip=F, caption="bagEarth, etitanic", trace=1, SHOWCALL=TRUE) plotres(a.bag3, clip=F, trace=1, SHOWCALL=TRUE) # Following commented out because too slow # # cat("\n#=== from test.parsnip.R ===========================================\n") # set.seed(2020) # # cat("loading parsnip libraries\n") # these libraries take several seconds to load # library(tidymodels) # library(timetk) # library(lubridate) # cat("loaded parsnip libraries\n") # cat("parsnip version:", as.character(packageVersion("parsnip")[[1]]), "\n") # # vdata <- data.frame( # resp = 1:23, # bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T, F, F, T, T, T, T, T, T, T, T), # ord = ordered(c("ORD1", "ORD1", "ORD1", # "ORD1", "ORD1", "ORD1", # "ORD1", "ORD3", "ORD1", # "ORD2", "ORD2", "ORD2", "ORD2", # "ORD2", "ORD2", "ORD2", # "ORD3", "ORD3", "ORD3", # "ORD2", "ORD2", "ORD2", "ORD2"), # levels=c("ORD1", "ORD3", "ORD2")), # fac = as.factor(c("FAC1", "FAC1", "FAC1", # "FAC2", "FAC2", "FAC2", # "FAC3", "FAC1", "FAC1", # "FAC1", "FAC2", "FAC2", "FAC2", # "FAC2", "FAC2", "FAC2", # "FAC3", "FAC3", "FAC3", # "FAC1", "FAC3", "FAC3", "FAC3")), # str = c("STR1", "STR1", "STR1", # WILL BE TREATED LIKE A FACTOR # "STR1", "STR1", "STR1", # "STR2", "STR2", "STR2", # "STR3", "STR3", "STR2", "STR3", # "STR2", "STR3", "STR2", # "STR3", "STR3", "STR3", # "STR3", "STR3", "STR3", "STR3"), # num = c(1, 9, 2, 3, 14, 5, 6, 4, 5, 6.5, 3, 6, 5, # 3, 4, 5, 6, 4, 5, 16.5, 3, 16, 15), # sqrt_num = sqrt( # c(1, 9, 2, 3, 14, 5, 6, 4, 5, 6.5, 3, 6, 5, # 3, 4, 5, 6, 4, 5, 16.5, 3, 16, 15)), # int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L, # 13L, 14L, 3L, 13L, 5L, 13L, 16L, 17L, 18L, 11L), # date = as.Date( # c("2018-08-01", "2018-08-02", "2018-08-03", # "2018-08-04", "2018-08-05", "2018-08-06", # "2018-08-07", "2018-08-08", "2018-08-08", # "2018-08-10", "2018-08-10", "2018-08-11", "2018-08-11", # "2018-08-11", "2018-08-12", "2018-08-13", # "2018-08-10", "2018-08-15", "2018-08-17", # "2018-08-04", "2018-08-19", "2018-08-03", "2018-08-18")), # date_num = as.numeric(as.Date( # c("2018-08-01", "2018-08-02", "2018-08-03", # "2018-08-04", "2018-08-05", "2018-08-06", # "2018-08-07", "2018-08-08", "2018-08-08", # "2018-08-10", "2018-08-10", "2018-08-11", "2018-08-11", # "2018-08-11", "2018-08-12", "2018-08-13", # "2018-08-10", "2018-08-15", "2018-08-17", # "2018-08-04", "2018-08-19", "2018-08-03", "2018-08-18")))) # # set.seed(2020) # splits <- initial_time_split(vdata, prop=.9) # # cat("===m750a first example===\n") # set.seed(2020) # m750a <- m4_monthly %>% # filter(id == "M750") %>% # select(-id) # print(m750a) # a tibble # set.seed(2020) # splits_a <- initial_time_split(m750a, prop = 0.9) # earth_m750a <- earth(log(value) ~ as.numeric(date) + month(date, label = TRUE), data = training(splits_a), degree=2) # print(summary(earth_m750a)) cat("\n#=== from test.non.earth.R ===========================================\n") set.seed(2020) # Following gives different results on different systems (Oct 2020, earth 5.3.0). # For example: # Win7 (Intel i7-4910MQ): Earth selected 7 of 19 terms, and 3 of 3 predictors, GRSq 0.20041 RSq 0.47214 # Ubuntu (Intel P8600): Earth selected 2 of 19 terms, and 1 of 3 predictors, GRSq 0.18687 RSq 0.23689 library(rpart) # for kyphosis data data(kyphosis) a <- earth(Kyphosis ~ ., data=kyphosis, degree=2, glm=list(family=binomial), trace=4) print(summary(a)) par(mfrow=c(3,3)) plotmo(a, type2="image", do.par=FALSE, col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), clip=F) plotmo(a, clip=F, degree1=0, do.par=FALSE) source("test.epilog.R") earth/inst/slowtests/test.mods.Rout.save0000644000176200001440000011770414563611062020147 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 > 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 <- TRUE > 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.3f 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 Loading required package: mda Loading required package: class Loaded mda 0.5-4 nterms 3 grsq 0.79 test.rsq 0.78 grsq-test.rsq -0.01 rsq.mars 0.782 delta 0.00 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 rsq.mars 0.751 delta 0.00 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 rsq.mars 0.872 delta 0.00 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 rsq.mars 0.876 delta 0.00 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 rsq.mars 0.872 delta -0.00 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 rsq.mars 0.743 delta -0.01 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 rsq.mars 0.887 delta -0.00 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 rsq.mars 0.849 delta 0.04 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 rsq.mars 0.667 delta 0.02 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 rsq.mars 0.842 delta 0.01 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 rsq.mars 0.863 delta -0.05 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 rsq.mars 0.841 delta -0.00 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 rsq.mars 0.861 delta 0.01 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 rsq.mars 0.858 delta -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 rsq.mars 0.989 delta 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 rsq.mars 0.976 delta 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 rsq.mars 0.982 delta 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 rsq.mars 0.792 delta 0.01 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 rsq.mars 0.952 delta 0.00 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 rsq.mars 0.955 delta 0.00 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 rsq.mars 0.794 delta 0.00 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 rsq.mars 0.956 delta -0.00 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 rsq.mars 0.920 delta 0.01 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 rsq.mars 0.788 delta 0.00 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 rsq.mars 0.950 delta -0.04 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 rsq.mars 0.908 delta 0.02 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 rsq.mars 0.779 delta -0.00 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 rsq.mars 0.963 delta 0.01 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 rsq.mars 0.998 delta -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 rsq.mars 0.998 delta 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 rsq.mars 0.998 delta 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 rsq.mars 0.983 delta 0.00 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 rsq.mars 0.983 delta -0.04 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 rsq.mars 0.972 delta 0.02 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 rsq.mars 0.638 delta -0.00 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 rsq.mars 0.533 delta -0.04 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 rsq.mars 0.536 delta 0.05 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 rsq.mars 0.584 delta 0.01 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 rsq.mars 0.606 delta 0.00 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 rsq.mars 0.594 delta -0.01 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 rsq.mars 0.999 delta -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 rsq.mars 0.999 delta -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 rsq.mars -0.121 delta 0.02 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 rsq.mars 0.997 delta -0.02 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 rsq.mars 0.262 delta 0.02 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 rsq.mars 0.981 delta -0.01 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 rsq.mars 0.312 delta -0.00 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 rsq.mars 0.521 delta -0.02 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 rsq.mars 0.998 delta -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 rsq.mars 0.995 delta 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 rsq.mars 0.995 delta 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 rsq.mars 0.998 delta -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 rsq.mars 0.995 delta 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 rsq.mars 0.995 delta 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 rsq.mars 0.998 delta -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 rsq.mars 0.995 delta 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 rsq.mars 0.995 delta 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 rsq.mars 0.998 delta -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 rsq.mars 0.995 delta 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 rsq.mars 0.995 delta 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 rsq.mars 0.834 delta 0.00 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 rsq.mars 0.800 delta -0.00 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 rsq.mars 0.837 delta -0.02 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 rsq.mars 0.852 delta -0.00 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 rsq.mars 0.833 delta 0.01 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 rsq.mars 0.786 delta 0.01 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 rsq.mars 0.758 delta 0.06 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 rsq.mars 0.860 delta -0.06 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 rsq.mars 0.995 delta -0.08 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 rsq.mars 0.995 delta 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 rsq.mars 0.995 delta 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 rsq.mars 0.843 delta -0.02 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 rsq.mars 0.945 delta -0.08 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 rsq.mars 0.945 delta -0.08 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 rsq.mars 0.835 delta -0.00 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 rsq.mars 0.799 delta -0.01 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 rsq.mars 0.797 delta 0.06 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 rsq.mars 0.796 delta 0.00 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 rsq.mars 0.803 delta -0.01 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 rsq.mars -0.003 delta 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 rsq.mars -0.019 delta 0.00 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 rsq.mars -0.027 delta 0.00 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 rsq.mars -0.004 delta 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 rsq.mars -0.003 delta 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 rsq.mars -0.000 delta 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 rsq.mars -0.019 delta 0.00 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 rsq.mars -0.099 delta 0.01 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 rsq.mars -0.193 delta 0.14 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 rsq.mars 0.776 delta -0.25 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 rsq.mars 0.590 delta 0.12 > 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)) + } mars.rsq: min 1% 5% 10% mean median 95% max -0.193 -0.129 -0.019 -0.001 0.754 0.855 0.997 0.999 mars.nterms: min 1% 5% 10% mean median 95% max 1.000 1.000 1.000 2.900 8.733 9.000 14.000 18.000 > if(TIME) + printf("[testn time %.3f]\n", (proc.time() - start.time)[3]) > source("test.epilog.R") earth/inst/slowtests/test.allowedfunc.bat0000755000176200001440000000162614563571565020403 0ustar liggesusers@rem test.allowedfunc.bat @rem Stephen Milborrow Dec 2014 Shrewsbury @echo test.allowedfunc.bat @"C:\PROGRA~1\R\R-4.3.2\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.R0000644000176200001440000001444214055553032016267 0ustar liggesusers# test.mem.R: test earth C code memory usage under both normal and error conditions # # TODO With some versions of R, test.mem gives different results per run. # First seen Sep 2020, R 4.0.3. 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.bat0000755000176200001440000000423414564114460020565 0ustar liggesusers@rem test.earthmain.gcc.bat: test 64 bit standalone earth.c with main() @rem @rem This tests the earth C code. It does this: builds test.earthmain.exe @rem (under gcc), runs it, and compares results to test.earthmain.out.save. @rem @rem You will need to tweak this file for your directories. @rem @rem You need to make R.lib first -- see instructions in gnuwin32/README.packages. @echo test.earthmain.gcc.bat @set CYGWIN=nodosfilewarning @rem Init environment for GCC compiler, if necessary @call D:\bin\milbo\rpath.bat cp "C:/Program Files/R/R-4.3.2/bin/x64/R.dll" . @if %errorlevel% neq 0 goto err cp "C:/Program Files/R/R-4.3.2/bin/x64/Rblas.dll" . @if %errorlevel% neq 0 goto err cp "C:/Program Files/R/R-4.3.2/bin/x64/Riconv.dll" . @if %errorlevel% neq 0 goto err cp "C:/Program Files/R/R-4.3.2/bin/x64/Rgraphapp.dll" . @if %errorlevel% neq 0 goto err @rem @rem you may have to create Rdll_x64.lib and Rblas_x64.lib beforehand @cp "../../.#/Rdll_x64.lib" R.lib @if %errorlevel% neq 0 goto err @cp "../../.#/Rblas_x64.lib" Rblas.lib @if %errorlevel% neq 0 goto err @rem TODO -USE_BLAS=0 else crashes in daxpy_ call in FindKnot @rem TODO -Wno-stringop-overflow else earth.c:3301:warning: 'memset' exceeds maximum object size gcc -DMAIN -DSTANDALONE -DUSE_BLAS=0 -Wall --pedantic -Wextra -O3 -std=gnu99 -m64^ -Wno-stringop-overflow^ -I"/a/r/ra/include" -I../../inst/slowtests^ ../../src/earth.c^ R.lib Rblas.lib^ -o earthmain.gcc.exe @if %errorlevel% neq 0 goto err earthmain.gcc.exe >test.earthmain.gcc.out @rem no errorlevel test, diff will do check for discrepancies @rem @if %errorlevel% neq 0 goto err mks.diff test.earthmain.gcc.out test.earthmain.gcc.out.save @if %errorlevel% neq 0 goto err @rm -f R.dll Rblas.dll R.lib Rblas.lib Riconv.dll Rgraphapp.dll R.lib Rblas.lib @rm -f earthmain.gcc.* test.earthmain.gcc.out *.o @exit /B 0 :err @exit /B %errorlevel% earth/inst/slowtests/test.glm.Rout.save0000644000176200001440000131512314565631517017771 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 > 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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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") 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 expected error 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 [1] "survived" "sex" "age" "sibsp" "parch" $modvars survived sexmale age sibsp parch 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 $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 expected error 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 [1] "survived" "sex" "age" "sibsp" "parch" $modvars survived sexmale age sibsp parch 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 $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 [1] "pclass" "survived" "age" "sibsp" "parch" $modvars pclass2nd pclass3rd survived age sibsp parch pclass 1 1 0 0 0 0 survived 0 0 1 0 0 0 age 0 0 0 1 0 0 sibsp 0 0 0 0 1 0 parch 0 0 0 0 0 1 $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" ------------------------------------------------------------------------------- > > expect.err(try(earth(sex ~ ., data=etitanic, nfold=2, # earth.formula + subset=rep(TRUE, length.out=nrow(etitanic)))), + "'subset' cannot be used with 'nfold' (implementation restriction)") Error : 'subset' cannot be used with 'nfold' (implementation restriction) Got expected error from try(earth(sex ~ ., data = etitanic, nfold = 2, subset = rep(TRUE, length.out = nrow(etitanic)))) > > expect.err(try(earth(etitanic$age, etitanic$sex, nfold=2, # earth.default + subset=rep(TRUE, length.out=nrow(etitanic)))), + "'subset' cannot be used with 'nfold' (implementation restriction)") Error : 'subset' cannot be used with 'nfold' (implementation restriction) Got expected error from try(earth(etitanic$age, etitanic$sex, nfold = 2, subset = rep(TRUE, length.out = nrow(etitanic)))) > > cat("glm.varmod: titanic data, one response which is a two level factor, with varmod and plotmo\n\n") glm.varmod: titanic data, one response which is a two level factor, with varmod and plotmo > set.seed(2020) > glm.varmod <- earth(sex ~ pclass+age+sibsp, data=etitanic, glm=list(family="binomial"), trace=.5, + nfold=5, ncross=3, varmod.method="lm") Model with pmethod="backward": GRSq 0.043 RSq 0.058 nterms 5 CV fold 1.1 CVRSq 0.043 n.oof 829 21% n.infold.nz 526 63% n.oof.nz 132 61% CV fold 1.2 CVRSq 0.064 n.oof 840 20% n.infold.nz 526 63% n.oof.nz 132 64% CV fold 1.3 CVRSq -0.001 n.oof 828 21% n.infold.nz 526 64% n.oof.nz 132 61% CV fold 1.4 CVRSq 0.042 n.oof 842 20% n.infold.nz 527 63% n.oof.nz 131 64% CV fold 1.5 CVRSq 0.023 n.oof 845 19% n.infold.nz 527 62% n.oof.nz 131 65% CV fold 2.1 CVRSq 0.034 n.oof 836 20% n.infold.nz 526 63% n.oof.nz 132 63% CV fold 2.2 CVRSq 0.073 n.oof 847 19% n.infold.nz 526 62% n.oof.nz 132 66% CV fold 2.3 CVRSq 0.008 n.oof 835 20% n.infold.nz 526 63% n.oof.nz 132 63% CV fold 2.4 CVRSq -0.017 n.oof 836 20% n.infold.nz 527 63% n.oof.nz 131 62% CV fold 2.5 CVRSq 0.072 n.oof 830 21% n.infold.nz 527 63% n.oof.nz 131 61% CV fold 3.1 CVRSq -0.022 n.oof 841 20% n.infold.nz 526 63% n.oof.nz 132 64% CV fold 3.2 CVRSq 0.044 n.oof 827 21% n.infold.nz 526 64% n.oof.nz 132 60% CV fold 3.3 CVRSq 0.079 n.oof 837 20% n.infold.nz 526 63% n.oof.nz 132 63% CV fold 3.4 CVRSq 0.047 n.oof 842 20% n.infold.nz 527 63% n.oof.nz 131 64% CV fold 3.5 CVRSq 0.054 n.oof 837 20% n.infold.nz 527 63% n.oof.nz 131 63% CV all CVRSq 0.036 n.infold.nz 658 63% varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) male 1 4.4 0.00 0.75 -0.49 2 6.1 13.60 0.81 -0.58 3 6.5 2.51 0.82 -0.60 4 6.6 0.53 0.83 -0.61 > cat("\nprint(glm.varmod)\n") print(glm.varmod) > print(glm.varmod) GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1379.57 1045 1318.2 1041 0.0445 1328 4 1 Earth selected 5 of 9 terms, and 4 of 4 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: sibsp, pclass3rd, age, pclass2nd Number of terms at each degree of interaction: 1 4 (additive model) Earth GCV 0.2236787 RSS 229.959 GRSq 0.0432477 RSq 0.05784047 CVRSq 0.03630886 > cat("\nsummary(glm.varmod)\n") summary(glm.varmod) > print(summary(glm.varmod)) Call: earth(formula=sex~pclass+age+sibsp, data=etitanic, trace=0.5, glm=list(family="binomial"), nfold=5, ncross=3, varmod.method="lm") GLM coefficients male (Intercept) -0.7705754 pclass2nd 0.4669103 pclass3rd 0.9302584 h(age-14) 0.0210683 h(1-sibsp) 0.6348306 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1379.57 1045 1318.2 1041 0.0445 1328 4 1 Earth selected 5 of 9 terms, and 4 of 4 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: sibsp, pclass3rd, age, pclass2nd Number of terms at each degree of interaction: 1 4 (additive model) Earth GCV 0.2236787 RSS 229.959 GRSq 0.0432477 RSq 0.05784047 CVRSq 0.03630886 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 5.73 sd 1.16 nvars 3.87 sd 0.35 CVRSq sd ClassRate sd MaxErr sd AUC sd MeanDev sd CalibInt 0.036 0.032 0.631 0.024 -0.917 0.42 0.628 0.035 1.28 0.0422 0.079 sd CalibSlope sd 0.189 0.838 0.323 varmod: method "lm" min.sd 0.0557 iter.rsq 0.139 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 1.0365640 0.0395354 4 male -0.7621124 0.0586009 8 mean smallest largest ratio 95% prediction interval 2.183977 1.195783 3.075882 2.572275 68% 80% 90% 95% response values in prediction interval 81 89 98 100 > plotmo(glm.varmod, type="earth", level=.8, ylim=c(-1, 2), SHOWCALL=TRUE) plotmo grid: pclass age sibsp 3rd 28 0 > options(warn=2) > expect.err(try(plotmo(glm.varmod, leve=.8)), "predict.earth: with earth-glm models, use type=\"earth\" when using the interval argument") plotmo grid: pclass age sibsp 3rd 28 0 Error : predict.earth: with earth-glm models, use type="earth" when using the interval argument Got expected error from try(plotmo(glm.varmod, leve = 0.8)) > expect.err(try(plotmo(glm.varmod, lev=.8, type="response")), "predict.earth: with earth-glm models, use type=\"earth\" when using the interval argument") plotmo grid: pclass age sibsp 3rd 28 0 Error : predict.earth: with earth-glm models, use type="earth" when using the interval argument Got expected error from try(plotmo(glm.varmod, lev = 0.8, type = "response")) > options(warn=1) > > 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" > > a7d1 <- earth(sex ~ .-pclass, data=etitanic, degree=2, glm=list(family="binomial"), trace=0, keepxy=1) > a7d1update <- 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(a7d1update, a7d1, msg="a7update a7d1 with keepxy", newdata=etitanic[5,]) a7update a7d1 with keepxy: models not identical Formulas differ: sex ~ survived + age + sibsp + parch and: sex ~ (pclass + survived + age + sibsp + parch) - pclass a7update a7d1 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 a7d1 with keepxy: but the actual glm submodel formulas differ (classes are "formula" and "formula") a7update a7d1 with keepxy: glm submodels not identical (but coefs, residuals, fitted.values are the same) a7update a7d1 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") 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.217e-15 2.000e-01 0.000 1.0000 treatment3 8.438e-16 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.88 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+07 0.2461 min 15 3 3.4484e+07 0.2406 15 4 3.0548e+07 0.2445 15 5 1.9834e+06 0.2724 min 15 6 2.0705e+07 0.2541 15 7 2.4297e+07 0.2506 15 8 6.3042e+06 0.2682 15 9 6.3458e+06 0.2681 15 10 8231.6 0.2743 min 15 11 1.5243e+07 0.2594 15 12 1.4677e+07 0.2600 15 13 1.0817e+07 0.2638 15 14 4.9902e+06 0.2695 15 15 4.2448e+06 0.2702 14 2 2.9403e+07 0.2456 min 14 3 3.491e+07 0.2402 14 4 3.0578e+07 0.2444 14 5 1.9758e+06 0.2724 min 14 6 2.074e+07 0.2541 14 7 2.4514e+07 0.2504 14 8 6.4997e+06 0.2680 14 9 6.995e+06 0.2675 14 11 1.5597e+07 0.2591 14 12 1.467e+07 0.2600 14 13 1.0901e+07 0.2637 14 14 5.1186e+06 0.2693 14 15 4.2486e+06 0.2702 13 2 4.1871e+07 0.2315 min 13 3 4.0788e+07 0.2325 min 13 4 3.2141e+07 0.2410 min 13 6 2.0184e+07 0.2527 min 13 7 2.3466e+07 0.2495 13 8 5.1563e+06 0.2674 min 13 9 7.0251e+06 0.2655 13 11 1.5565e+07 0.2572 13 12 2.1626e+07 0.2513 13 13 8.9657e+06 0.2636 13 14 3.173e+06 0.2693 min 13 15 3.5082e+06 0.2690 12 2 4.1546e+07 0.2287 min 12 3 7.7449e+07 0.1936 12 4 3.1892e+07 0.2381 min 12 6 2.3605e+07 0.2462 min 12 7 2.3299e+07 0.2465 min 12 8 4.9192e+06 0.2645 min 12 9 7.5636e+06 0.2619 12 11 1.5356e+07 0.2543 12 12 2.139e+07 0.2484 12 13 6.1065e+06 0.2633 12 15 2.5439e+06 0.2668 min 11 2 4.0833e+07 0.2269 min 11 3 7.5335e+07 0.1932 11 4 3.2208e+07 0.2353 min 11 6 2.3752e+07 0.2436 min 11 7 2.0994e+07 0.2463 min 11 8 4.7818e+06 0.2621 min 11 9 8.2607e+06 0.2587 11 11 1.3425e+07 0.2537 11 12 1.8871e+07 0.2484 11 13 3.5784e+06 0.2633 min 10 2 3.947e+07 0.2247 min 10 3 7.2626e+07 0.1923 10 4 2.897e+07 0.2350 min 10 6 2.2396e+07 0.2414 min 10 7 1.8734e+07 0.2450 min 10 8 4.7438e+06 0.2587 min 10 9 8.8185e+06 0.2547 10 11 1.0366e+07 0.2532 10 12 1.638e+07 0.2473 9 2 1.8992e+08 0.0730 min 9 3 7.3379e+07 0.1870 min 9 4 2.8502e+07 0.2308 min 9 6 2.5381e+07 0.2339 min 9 7 1.4043e+07 0.2450 min 9 9 1.3625e+07 0.2454 min 9 11 5.6644e+06 0.2531 min 9 12 1.5764e+07 0.2433 8 2 1.8436e+08 0.0729 min 8 3 7.3891e+07 0.1809 min 8 4 2.2897e+07 0.2308 min 8 6 2.6814e+07 0.2269 8 7 8.7055e+06 0.2446 min 8 9 9.3843e+06 0.2440 8 12 1.0108e+07 0.2433 7 2 1.9348e+08 0.0555 min 7 3 7.5359e+07 0.1710 min 7 4 1.7932e+07 0.2271 min 7 6 2.644e+07 0.2188 7 9 9.7584e+06 0.2351 min 7 12 8.2948e+06 0.2365 min 6 2 1.9155e+08 0.0493 min 6 3 7.663e+07 0.1616 min 6 4 1.17e+07 0.2251 min 6 6 3.1425e+07 0.2058 6 9 2.1466e+07 0.2155 5 2 1.8693e+08 0.0424 min 5 3 7.7548e+07 0.1493 min 5 6 3.258e+07 0.1932 min 5 9 2.2907e+07 0.2027 min 4 2 2.0575e+08 0.0016 min 4 3 7.681e+07 0.1276 min 4 6 3.0059e+07 0.1733 min 3 2 1.7662e+08 0.0007 min 3 3 6.448e+07 0.1103 min 2 2 1.1281e+08 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 expected error 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") + cat("sexmale:\n"); print(sexmale) + 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-28m", pm2.ref, pm) + + # Jun 2021: with R 4.1.0 no longer works, probably ok (old version of R gave err/warn msgs) + # something to do with change in how ordered factors are handled in model frames + # + # 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-28f", 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-29m", 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-29f", 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-31m", 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-31f", 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-31bm", 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-31bf", 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-32m1", pm, pf) + stop.if.not.identical("A-32m2", 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-32f", 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)), + "could not interpret newdata\n model.matrix returned 2 columns: \"sex.1.\", \"X.2\"\n need 3 columns: \"sexmale\", \"ldose\", \"ldose1\"") + + 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)), + "could not interpret newdata\n model.matrix returned 2 columns: \"sex.1.\", \"X.2\"\n need 3 columns: \"sex\", \"ldose\", \"ldose1\"") + + 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)), + "could not interpret newdata\n model.matrix returned 2 columns: \"sex.c.1..7..\", \"c..2...1.\"\n need 3 columns: \"sexmale\", \"ldose\", \"ldose1\"") + + 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)), + "could not interpret newdata\n model.matrix returned 2 columns: \"sex.c.1..7..\", \"c..2...1.\"\n need 3 columns: \"sex\", \"ldose\", \"ldose1\"") + 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 \"model.matrix.earth could not interpret the data\"\n", sep="") + a41 <- earth(my.response~my.input.mat, trace=trace) + expect.err(try(predict(a41, c(2.1, 0.6), trace=trace)), + "model.matrix.earth 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)), + "could not interpret newdata\n model.matrix returned 2 columns: \"sex3.1.\", \"X.2\"\n need 4 columns: \"sex3\", \"ldose\", \"ldose1\", \"fac3\"") + + 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)), + "could not interpret newdata\n model.matrix returned 2 columns: \"sex3.1.\", \"X.2\"\n need 4 columns: \"sex3\", \"ldose\", \"ldose1\", \"fac3\"") + + 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)), + "could not interpret newdata\n model.matrix returned 2 columns: \"sex3.c.1..7..\", \"c..2...1.\"\n need 4 columns: \"sex3\", \"ldose\", \"ldose1\", \"fac3\"") + + 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)), + "could not interpret newdata\n model.matrix returned 2 columns: \"sex3.c.1..7..\", \"c..2...1.\"\n need 4 columns: \"sex3\", \"ldose\", \"ldose1\", \"fac3\"") + 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)), "could not interpret newdata") + + 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)), "could not interpret newdata") + + 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)), "could not interpret newdata") + + 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)), + "could not interpret newdata\n model.matrix returned 2 columns: \"sex3.c.1..7..\", \"c..2...1.\"\n need 4 columns: \"sex3\", \"ldose\", \"ldose1\", \"fac3\"") + + 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 sexmale: [1] TRUE TRUE TRUE TRUE TRUE TRUE FALSE FALSE FALSE FALSE FALSE FALSE 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-28m 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-31m 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-31f 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-31bm 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-31bf 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-32m1 identical A-32m2 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-32f 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 : could not interpret newdata model.matrix returned 2 columns: "sex.1.", "X.2" need 3 columns: "sexmale", "ldose", "ldose1" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex.1.", "X.2" need 3 columns: "sex", "ldose", "ldose1" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex.c.1..7..", "c..2...1." need 3 columns: "sexmale", "ldose", "ldose1" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex.c.1..7..", "c..2...1." need 3 columns: "sex", "ldose", "ldose1" Got expected error 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 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-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 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-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 "model.matrix.earth could not interpret the data" 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.input.mat get.earth.x from model.matrix.earth from predict.earth: x[2,1]: my.input.mat 1 2.1 2 0.6 get.earth.x from model.matrix.earth from predict.earth: after call to model.frame: mf[2,1]: my.input.mat 1 2.1 2 0.6 Error : variable 'my.input.mat' was fitted with type "nmatrix.2" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are my.input.mat 1 2.1 2 0.6 Error : model.matrix.earth could not interpret the data model.matrix returned 1 column: "my.input.mat" need 2 columns: "my.input.matmy.x1", "my.input.matmy.x2" Got expected error 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) newdata has missing columns, adding missing cols with all NAs 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) newdata has missing columns, adding missing cols with all NAs 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) newdata has missing columns, adding missing cols with all NAs 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) newdata has missing columns, adding missing cols with all NAs 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.1.", "X.2" need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.1.", "X.2" need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.c.1..7..", "c..2...1." need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.c.1..7..", "c..2...1." need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.1.", "X.2" need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.1.", "X.2" need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.c.1..7..", "c..2...1." need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.c.1..7..", "c..2...1." need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 sexmale: [1] TRUE TRUE TRUE TRUE TRUE TRUE FALSE FALSE FALSE FALSE FALSE FALSE 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-28m identical A-31m predict(am, xdata.frame, trace=0) data frame with factors and wrong col names A-31m identical A-31f predict(af, xdata.frame, trace=0) data frame with factors and wrong col names A-31f identical A-31bm predict(am, xdata.frame, trace=0) data frame col names A-31bm identical A-31bf predict(af, xdata.frame, trace=0) data frame col names A-31bf identical A-32m predict(am, xdata.frame, trace=0) # data frame with names A-32m1 identical A-32m2 identical A-32f predict(af, xdata.frame, trace=0) # data frame with names A-32f 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 : could not interpret newdata model.matrix returned 2 columns: "sex.1.", "X.2" need 3 columns: "sexmale", "ldose", "ldose1" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex.1.", "X.2" need 3 columns: "sex", "ldose", "ldose1" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex.c.1..7..", "c..2...1." need 3 columns: "sexmale", "ldose", "ldose1" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex.c.1..7..", "c..2...1." need 3 columns: "sex", "ldose", "ldose1" Got expected error 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 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 "model.matrix.earth could not interpret the data" Error : variable 'my.input.mat' was fitted with type "nmatrix.2" but type "numeric" was supplied Continuing anyway, first few rows of modelframe are my.input.mat 1 2.1 2 0.6 Error : model.matrix.earth could not interpret the data model.matrix returned 1 column: "my.input.mat" need 2 columns: "my.input.matmy.x1", "my.input.matmy.x2" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.1.", "X.2" need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.1.", "X.2" need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.c.1..7..", "c..2...1." need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.c.1..7..", "c..2...1." need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.1.", "X.2" need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.1.", "X.2" need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.c.1..7..", "c..2...1." need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 : could not interpret newdata model.matrix returned 2 columns: "sex3.c.1..7..", "c..2...1." need 4 columns: "sex3", "ldose", "ldose1", "fac3" Got expected error 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 expected error 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 expected error 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 expected error 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)) > cat("summary(mod.Gamma):\n") summary(mod.Gamma): > print(summary(mod.Gamma)) Call: earth(formula=O3~.-doy, data=ozone1, glm=list(family=Gamma), degree=2) GLM coefficients O3 (Intercept) 0.059990770 h(58-temp) 0.005133954 h(ibh-1105) 0.000008963 h(2-dpg) 0.001426223 h(17-vis) 0.001446316 h(vis-17) 0.000116396 h(wind-5) * h(1105-ibh) 0.000011633 h(53-humidity) * h(temp-58) 0.000036902 h(humidity-46) * h(ibh-1105) 0.000000267 h(temp-58) * h(dpg-54) 0.000060348 h(temp-58) * h(54-dpg) -0.000024529 h(ibh-1105) * h(vis-40) 0.000000011 h(dpg-2) * h(ibt-115) -0.000004080 GLM (family Gamma, link inverse): nulldev df dev df devratio AIC iters converged 167.03 329 45.5397 317 0.727 1779 5 1 Earth selected 13 of 21 terms, and 7 of 8 predictors Termination condition: Reached nk 21 Importance: temp, humidity, dpg, ibt, ibh, vis, wind, vh-unused Number of terms at each degree of interaction: 1 5 7 Earth GCV 15.35284 RSS 4159.269 GRSq 0.7615117 RSq 0.8030221 > 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)) > cat("summary(mod.binomial):\n") summary(mod.binomial): > print(summary(mod.binomial)) Call: earth(formula=survived~., data=etitanic, glm=list(family=binomial), degree=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 > 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 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 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 (nprune=1) 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 (nprune=1) 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 (nprune=1) 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))) > expect.err(try(earth(numdead, cbind(sex1, sex2, sex1), trace=1)), # one duplicate name + "Duplicate colname in cbind(sex1, sex2, sex1) (colnames are \"sex1\", \"sex2\", \"sex1\"") Error : Duplicate colname in cbind(sex1, sex2, sex1) (colnames are "sex1", "sex2", "sex1") Got expected error from try(earth(numdead, cbind(sex1, sex2, sex1), trace = 1)) > sex1 <- factor(rep(c("male", "female"), times=c(6,6))) > sex2 <- factor(rep(c("male", "female"), times=c(6,6))) > expect.err(try(earth(numdead, cbind(sex1, sex2, sex1, sex1), trace=1)), # two duplicate names + "Duplicate colname in cbind(sex1, sex2, sex1, sex1) (colnames are \"sex1\", \"sex2\", \"sex1\", \"sex1\"") Error : Duplicate colname in cbind(sex1, sex2, sex1, sex1) (colnames are "sex1", "sex2", "sex1", "sex1") Got expected error from try(earth(numdead, cbind(sex1, sex2, sex1, sex1), trace = 1)) > > # 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", "male", "male... Got expected error 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", "male", "male... Got expected error 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 sex2male, and values 1, 1, 1, 1, 1, 1, 0, 0, 0, 0,... y[12,2] with colnames sex2female sex2male 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: sex2male Number of terms at each degree of interaction: 1 1 (additive model) GCV RSS GRSq RSq sex2female 2.154759e-31 1.454462e-30 1 1 sex2male 9.130335e-33 6.162976e-32 1 1 All 0.000000e+00 0.000000e+00 1 1 > > earth(sex2, data.frame(sex2=sex2, stringsAsFactors=TRUE), trace=1) # R 4.0.0 may 2020 x[12,1] with colname sex2male, 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: sex2male 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.R0000644000176200001440000002471113725313736020210 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/test.numstab.bat0000755000176200001440000000147314563571565017551 0ustar liggesusers@rem test.numstab.bat: @echo test.numstab.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.numstab.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.numstab.Rout: @echo. @tail test.numstab.Rout @echo test.numstab.R @exit /B 1 :good1 mks.diff test.numstab.Rout test.numstab.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.numstab.save.ps @exit /B 1 :good2 @rem test.numstab.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.numstab.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.numstab.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/earth.times.R0000644000176200001440000001356413725313736016772 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) # } cv5.time <- system.time(for (i in 1:niter) cv5 <- earth(x, y, nk=nk, degree=degree, minspan=0, nfold=5)) pmethcv.time <- system.time(for (i in 1:niter) pmethcv <- earth(x, y, nk=nk, degree=degree, minspan=0, nfold=5, pmethod="cv")) format <- paste( # nk degree nterms time mars nofast nobeta minspan1 allowed weights cv5 pmethcv "%2d %3d %4.0d %6.3f | %4.1f %5.1f %5.1f %5.1f %5.1f %7.0f %5.1f %5.1f ", # grsq mars nofast minspan1 weights pmethcv "| %4.2f %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), cv5.time[1] / earth.time[1], pmethcv.time[1] / earth.time[1], grsq, mars.grsq, no.fastmars$grsq, minspan1$grsq, weights$grsq, pmethcv$grsq) } print.header <- function () { printf("nk degree earth earth ") printf("| execution time ratio: ") printf("| grsq: \n") printf(" nterms time ") printf("| mars nofast nobeta minspan1 allowed weights cv5 pmethcv ") printf("| earth mars nofast minspan1 weights pmethcv\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("==== 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/test.emma.R0000644000176200001440000000113213725761170016427 0ustar liggesusers# test.emma.R: regression tests for emma (which uses earth internally) # Stephen Milborrow, Shrewsbury Nov 2014 source("test.prolog.R") print(R.version.string) library(emma) print(citation("emma")) in.name <- c("x1","x2") nlev <- c(10, 10) lower <- c(-2.048, -2.048) upper <- c(2.048, 2.048) out.name <- "y" weight <- 1 C <- 3 pr.mut <- c(0.1, 0.07, 0.04, rep(0.01, C-3)) emma(in.name, nlev, lower, upper, out.name, opt = "mn", nd = 8, na = 5, weight, C , w1 = 0.7, w2 = 0.4, c1i = 2.5, c1f = 0.5, c2i = 0.5, c2f = 2.5, b = 5, pr.mut, graph = "yes", fn1 = ackley) source("test.epilog.R") earth/inst/slowtests/test.earthmain.gcc.out.save0000644000176200001440000000235514564112026021556 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.earthc.msc.bat0000755000176200001440000000436014360241665020113 0ustar liggesusers@rem test.earthc.msc.bat: @rem @rem This tests the earth C code. It does this: builds test.earthc.exe @rem (under Microsoft C VC16 (Visual Studio 2019) 32 bit, runs it, @rem and compares results to test.earthc.out.save. @rem @rem You will need to tweak this file and test.earthc.msc.mak for your directories. @rem @rem You need to make R.lib first -- see instructions in gnuwin32/README.packages. @rem @rem To set up the environment for the call to "cl" and "link" in the makefile below, invoke: @rem C:\Program Files (x86)\Microsoft Visual Studio\2019\Community\VC\Auxiliary\Build\vcvars32.bat @rem @rem Stephen Milborrow Mar 2007 Forden, Wales @echo test.earthc.msc.bat @set CYGWIN=nodosfilewarning @rem The following is a basic check that you have Visual Studio 2019 for 32 bit targets @mks.which cl | egrep -i "Visual.Studio.2019.Community.VC.Tools.MSVC.*.bin.Hostx.*x86.cl" >NUL && goto donesetpath @echo Environment is not VC16 (Visual Studio 2019) 32 bit -- please invoke vc16-32.bat @exit /B 1 :donesetpath @mks.cp "D:\bin\milbo\R400devdll\i386\R.dll" . @if %errorlevel% neq 0 goto err @mks.cp "D:\bin\milbo\R400devdll\i386\Rblas.dll" . @if %errorlevel% neq 0 goto err @mks.cp "D:\bin\milbo\R400devdll\i386\Riconv.dll" . @if %errorlevel% neq 0 goto err @mks.cp "D:\bin\milbo\R400devdll\i386\Rgraphapp.dll" . @if %errorlevel% neq 0 goto err @rem you may have to create R.lib and Rblas.lib beforehand mks.cp "D:\bin\milbo\R400devdll\i386\R.lib" . @if %errorlevel% neq 0 goto err mks.cp "D:\bin\milbo\R400devdll\i386\Rblas.lib" . @if %errorlevel% neq 0 goto err @rem @md Release @rem @nmake -nologo CFG=Release -f test.earthc.msc.mak @rem The advantage of using Debug is that memory leaks are reported. @rem It is much slower though. @md Debug @nmake -nologo CFG=Debug -f test.earthc.msc.mak @if %errorlevel% equ 0 goto good @echo error: errorlevel %errorlevel% @exit /B %errorlevel% :good @rm -f R.dll Rblas.dll R.lib Rblas.lib iconv.dll Riconv.dll Rgraphapp.dll @rm -f test.earthc.main.exe test.earthc.main.map test.earthc.main.ilk *.pdb @rm -rf Debug @rm -rf Release @exit /B 0 earth/inst/slowtests/earth.times.bat0000755000176200001440000000021314563571565017334 0ustar liggesusers"C:\PROGRA~1\R\R-4.3.2\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 > options(warn=1) # print warnings as they occur > 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 expected error 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 expected error 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 xx, 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 xx 5 2 3 1 4 0.9323 0.9323 0.01846 1 xx 6 4 1 6 1.0000 1.0000 0.0677 1 xx 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) 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 > 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), 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(org.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) > # par(org.par) > > # 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), 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.22-3 > 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) > 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) > 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 expected error from try(earth(y ~ ., data = data, wp = 3, Scale.y = TRUE)) > expect.err(try(earth(y~., data=data, Scale.y=999)), "Scale.y=999 but it should be FALSE, TRUE, 0, or 1") Error : Scale.y=999 but it should be FALSE, TRUE, 0, or 1 Got expected error from try(earth(y ~ ., data = data, Scale.y = 999)) > 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") 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) > 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) > 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) > 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.01293 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.01293 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.01293 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") > > 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 > > # trace=2 so we see "Fixed rank deficient bx" > mod7 <- earth(O3~., ozone1, weights=sqrt(ozone1$O3), Scale.y=FALSE, trace=2) x[330,9] with colnames vh wind humidity temp ibh dpg ibt vis doy y[330,1] with colname O3, and values 3, 5, 5, 6, 4, 4, 6, 7, 4, 6,... weights[330]: 1.732, 2.236, 2.236, 2.449, 2, 2, 2.449, 2.646, 2, 2.449,... Forward pass: minspan 6 endspan 10 x[330,9] 23.2 kB bx[330,21] 54.1 kB weighted GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.6345 0.6433 0.6433 4 temp 58 2 3 1 4 0.6799 0.6953 0.05198 5 ibh 777 4 5 1 6 0.6962 0.7180 0.02268 6 dpg 6 6 7 1 8 0.7169 0.7438 0.02585 9 doy 150 8 9 1 10 0.7358 0.7670 0.02316 8 vis 150 10 11 1 12 0.7420 0.7783 0.01129 1 vh 5890 12 13 1 14 0.7459 0.7873 0.009072 3 humidity 32 14 15 1 16 0.7454 0.7925 0.005168 7 ibt 256 16 17 1 18 0.7444 0.7973 0.004762 2 wind 6 18 19 1 20 0.7419 0.8008 0.003582 7 ibt 132 20 21 1 final (reached nk 21) Reached nk 21 After forward pass GRSq 0.742 RSq 0.801 Forward pass complete: 21 terms Fixed rank deficient bx by removing 1 term, 20 terms remain Prune backward penalty 2 nprune null: selected 14 of 20 terms, and 9 of 9 preds After pruning pass GRSq 0.764 RSq 0.8 > mod8 <- earth(O3~., ozone1, weights=sqrt(ozone1$O3), Scale.y=TRUE, trace=2) x[330,9] with colnames vh wind humidity temp ibh dpg ibt vis doy y[330,1] with colname O3, and values 3, 5, 5, 6, 4, 4, 6, 7, 4, 6,... weights[330]: 1.732, 2.236, 2.236, 2.449, 2, 2, 2.449, 2.646, 2, 2.449,... Forward pass: minspan 6 endspan 10 x[330,9] 23.2 kB bx[330,21] 54.1 kB weighted GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.6345 0.6433 0.6433 4 temp 58 2 3 1 4 0.6799 0.6953 0.05198 5 ibh 777 4 5 1 6 0.6962 0.7180 0.02268 6 dpg 6 6 7 1 8 0.7169 0.7438 0.02585 9 doy 150 8 9 1 10 0.7358 0.7670 0.02316 8 vis 150 10 11 1 12 0.7420 0.7783 0.01129 1 vh 5890 12 13 1 14 0.7459 0.7873 0.009072 3 humidity 32 14 15 1 16 0.7454 0.7925 0.005168 7 ibt 256 16 17 1 18 0.7444 0.7973 0.004762 2 wind 6 18 19 1 20 0.7419 0.8008 0.003582 7 ibt 132 20 21 1 final (reached nk 21) Reached nk 21 After forward pass GRSq 0.742 RSq 0.801 Forward pass complete: 21 terms Fixed rank deficient bx by removing 1 term, 20 terms remain Prune backward penalty 2 nprune null: selected 14 of 20 terms, and 9 of 9 preds After pruning pass GRSq 0.764 RSq 0.8 > 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.R0000644000176200001440000000423413727246550017743 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=1) # print warnings as they occur 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) 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(org.par) source("test.epilog.R") earth/inst/slowtests/check.earth.matches.glm.R0000644000176200001440000001270614565631517021127 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) { # earth and glm handle backquoted names slightly differently names.earth_glm <- gsub("\`", "", names(coef(earth_glm))) names.earth_glm <- sort(names.earth_glm) names.glm <- gsub("\`", "", names(coef(glm))) names.glm <- sort(names.glm) stopifnot(identical(names.earth_glm, names.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.txt0000644000176200001440000000112113306011747016074 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.c0000644000176200001440000005346413737447611017022 0ustar liggesusers// test.c: main() for testing earth c routines // Comments containing "TODO" mark known issues #include #include #include #include #include #include #include // defines bool, true, false #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)); } //----------------------------------------------------------------------------- // We want the same random numbers across all compilers, so define our own // functions. They don't have to be very good for this application. static unsigned int rand_g; #define MY_RAND_MAX 0x7fff static void Srand(unsigned int const seed) // initialize all random number generators { rand_g = seed; } static int Rand() // returns int in range [0,32767] inclusive { // code is the same as microsoft crt/stdlib/rand.c rand_g = rand_g * 214013 + 2531011; return (rand_g >> 16) & MY_RAND_MAX; } static double RandUniform(void) // uniform rand number from -1 to +1 { // we use 2000 (and not say 20000) for compatibility across compilers return (double)((Rand() % 2000) - 1000) / 1000; } static double RandGauss(void) // standard normal random number { double r = 0; // by central limit theorem sum of uniforms is approximately gaussian for (int i = 0; i < 12; i++) 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]; } #if 0 // unused static double func4lin(const double x[], const int iResponse) { return x[0] + x[1] + x[3] + x[4]; } #endif 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 func8a(const double x[], const int iResponse) { // like above but more noise 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] + + 2 * RandGauss(); } #if 0 // unused static double func9(const double x[], const int iResponse) { return x[1]; } #endif 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 #if 0 // unused static double func1collinear(const double x[], const int iResponse) { return x[0] + x[1] + .001 * RandGauss(); } #endif 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, // used for testing NewVarPenalty const bool Prune, // Prune argument for call to Earth() const bool Binary) // binary predictors { #define y_(i,iResponse) y[(i) + (iResponse)*(nCases)] char sTestName1[200]; sprintf(sTestName1, "%s%s%s", Binary? "binary ": "", sTestName, Prune? "": " (no prune)"); 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)); // printf("nMaxTerms %d nPreds %d sizeof(int) %d total %d\n", nMaxTerms, nPreds, sizeof(int), nMaxTerms * nPreds); int *Dirs = (int *) malloc(nMaxTerms * nPreds * sizeof(int)); // printf("&Dirs[0] %lu &BestSet[0] %lu &Dirs[0]-&BestSet[0] %d\n", // (long unsigned int)&Dirs[0], (long unsigned int)&BestSet[0], &Dirs[0]-&BestSet[0]); // fflush(stdout); 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, sTestName1, nCases, nPreds); // init x Srand(seed); int i; for (i = 0; i < nCases; i++) for (int iPred = 0; iPred < nPreds; iPred++) { double xtemp; xtemp = RandUniform(); // rand number from -1 to +1 if(Binary) xtemp = (double)(xtemp > 0); // rand 0 or 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); #if PRINT_TIME clock_t Time = clock(); #endif 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 Prune, // 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); double RSq = 1 - Rss/Tss; if(RSq <= 0 && RSq > -1e-10) RSq = 0; // prevent negative zero printed by some compilers const double GcvNull = getGcv(1, nCases, Tss, Penalty); double GRSq = 1 - getGcv(nUsedTerms, nCases, Rss, Penalty) / GcvNull; if(GRSq <= 0 && GRSq > -1e-10) GRSq = 0; #if PRINT_TIME double TimeDelta = (double)(clock() - Time) / CLOCKS_PER_SEC; #else double TimeDelta = 99.99; #endif // show results (print only 4 digits for RSq so compatible across compilers) if (nResponses > 1) { printf("RESULT %d Response %d: GRSq %6.4f RSq %6.4f 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]", sTestName1, nCases, nPreds, TimeDelta); printf("\n"); } else printf("RESULT %d: GRSq %6.4f RSq %6.4f nTerms %d of %d of %d " "FUNCTION %s n=%d p=%d [%.2f secs]\n", nTest, GRSq, RSq, nUsedTerms, nTerms, nMaxTerms, sTestName1, nCases, nPreds, TimeDelta); } if (Format && Trace != 0) { printf("\nTEST %d: FUNCTION %s n=%d p=%d\n", nTest, sTestName1, 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) { #if PRINT_TIME clock_t Time = clock(); #endif // func nCases nResp nPreds nMaxDegree nMaxTerms Trace Form Thresh K B N s C P B TestEarth("noise", funcNoise, 1000, 1, 1, 2, 51, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("x0", func0, 10, 1, 1, 2, 51, 7,true,0.001,20,1,0,99,0,1,0); // intercept only models TestEarth("x0", func0, 10, 1, 1, 2, 1, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("x0", func0, 10, 1, 1, 2, 2, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("x0", func0, 1000, 1, 1, 2, 51, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("x0 + noise", func0, 1000, 1, 1+1, 2, 51, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("x0 + x1", func1, 1000, 1, 2, 2, 11, 7,true,0.001,20,1,0,99,0,1,0); TestEarth("x0 + x1 + noise", func1, 1000, 1, 2+8, 2, 51, 0,true,0.001,20,1,0,99,0,1,0); TestEarth("x0 + x1 + x0*x1", func2, 30, 1, 2, 2, 51, 4,true,0.001,20,1,0,99,0,1,0); TestEarth("x0 + x1 + x0*x1", func2, 1000, 1, 2, 2, 51, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("x0 + x1 + x0*x1", func2, 1000, 1, 2, 2, 51, 1.5,true,0.001,20,1,0,99,0,1,0); TestEarth("cos(x0) + x1", func3, 1000, 1, 2, 2, 51, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("sin(2*x0)+2*x1*.5*x0*x1", func4, 1000, 1, 2, 2, 51, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("sin(2*x0)+2*x1*.5*x0*x1", func4, 1000, 1, 3, 2, 51, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("3rd order, mi=2 ni=11", func5, 1000, 1, 6, 2, 11, 1,true,0.001,20,1,0,99,0,1,0); TestEarth("3rd order, mi=2 ni=51", func5, 1000, 1, 6, 2, 51, 2,true,0.001,20,1,0,99,0,1,0); TestEarth("3rd order, mi=3", func5, 1000, 1, 6, 3, 51, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("5 preds + noise", func6, 200, 1, 5+10, 2, 101, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("5 preds clean", func6clean, 200, 1, 5+10, 2, 101, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("10 preds + noise", func7, 200, 1, 10+40, 2, 101, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("20 preds + noise", func8, 100, 1, 20+10, 2, 101, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("20 preds + noise", func8, 400, 1, 20+10, 2, 101, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("3rd order, mi=3 + noise", func5, 1000, 1, 10, 2, 51, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("eqn56 mi=1", func56, 300, 1, 6, 1, 101, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("eqn56 mi=2", func56, 300, 1, 6, 2, 51, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("eqn56 mi=10", func56, 300, 1, 6, 10, 51, 3,true,0.001,20,1,0,99,0,1,0); // 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,0,1,0); // TestEarth("eqn56 mi=10", func56, 5000, 1, 6, 10, 101, 3,true,0.001,20,1,0,99,0,1,0); TestEarth("x0 + x1 + x0*x1", func2, 30, 1, 2, 2, 51, 3,true,0.001,99,1,0,99,0,1,0); TestEarth("x0 + x1 + x0*x1", func2, 30, 1, 2, 2, 51, 3,true,0.001, 4,0,0,99,0,1,0); TestEarth("x0 + x1 + x0*x1", func2, 30, 1, 2, 2, 51, 3,true,0.001, 4,1,0,99,0,1,0); // 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,0,1,0); TestEarth("x0|x+x1+noise", func0_1, 100, 2, 2, 1, 51, 3, true,0.001,20,1,0,99,0,1,0); 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,0,1,0); 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,0,1,0); 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,0,1,0); 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,0,1,0); 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,0,1,0); 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,0,1,0); //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,0,1,0); // 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,1,0); // 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,1,0); // test Prune and binary predictors // func nCases nResp nPreds nMaxDegree nMaxTerms Trace Form Thresh K B N s C P B TestEarth("20 preds + muchnoise", func8a, 100, 1, 20+10, 2, 101, 3,true,0.001,20,1,0,99,0,1,1); TestEarth("20 preds + muchnoise", func8a, 100, 1, 20+10, 2, 101, 3,true,0.001,20,1,0,99,0,0,1); #if PRINT_TIME printf("[Total time %.2f secs]\n", (double)(clock() - Time) / CLOCKS_PER_SEC); #endif return 0; } earth/inst/slowtests/test.numstab.Rout.save0000644000176200001440000017054714564113056020663 0ustar liggesusers> # test.numstab.R: Expose any numerical instability of earth across platforms. > # > # This file was created by running earth and plotmo slowtests > # with earth on Win7 built with "--mfpmath=387" (instead of "-mtune=native" > # or "-mfpmath=sse -msse2"). > # Differences between the output in the test suites from standard earth > # were collected and put into this file. > # So this code duplicates code in earth and plotmo slowtests. > # Most but not all differences were captured and put into this file. > # This file was originally created in in Oct 2020 for earth 5.3.0. > > source("test.prolog.R") > > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > library(mda) Loading required package: class Loaded mda 0.5-4 > data(ozone1) > data(trees) > data(etitanic) > > cat("\n#=== from test.full.R ===========================================\n") #=== from test.full.R =========================================== > set.seed(2020) > > PLOT <- TRUE # TRUE to do plots too, FALSE for speed > options.old <- options() > options(warn=1) # print warnings as they occur > > 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) + } > > 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("NUMSTAB 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 + } > set.seed(2020) > data(ozone1) > attach(ozone1) > itest <- 1 > > set.seed(2020) > 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 see "Fixed rank deficient bx by removing 2 terms, 7 terms remain" > 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 x2 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 x2 1.7848e+08< 7 1 12 0.0534 0.1323 0.001868 2 x2 1.7848e+08< 8 1 14 0.0432 0.1340 0.001792 2 x2 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 1 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 > > # 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) > > set.seed(2020) > cat("Auto.linpreds=TRUE pmethod=\"none\":\n") Auto.linpreds=TRUE pmethod="none": > # trace==2 so we see "Fixed rank deficient bx by removing terms" > # TODO why are we getting the rank deficient message? > 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)))) > > set.seed(2020) > 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("\n#=== from test.weights.R ===========================================\n") #=== from test.weights.R =========================================== > set.seed(2020) > > 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") > > a21.noweights <- earth(y~., data=data, # no weights for comparison + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) > print(summary(a21.noweights)) Call: earth(formula=y~., data=data, trace=-1, minspan=1, endspan=1, penalty=-1, thresh=1e-08) coefficients (Intercept) 5.070 h(5-x1) -0.990 h(x1-5) -0.465 h(x1-7) -0.050 h(x1-8) 0.010 h(x2-3) 0.475 h(6-x2) -0.020 h(x2-6) 1.010 Selected 8 of 8 terms, and 2 of 2 predictors Termination condition: Reached maximum RSq 1.0000 at 8 terms Importance: x1, x2 Number of terms at each degree of interaction: 1 7 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > 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) > print(summary(a10)) Call: earth(formula=y~., data=data, weights=weights, trace=-1, minspan=1, endspan=1, penalty=-1, thresh=1e-08) coefficients (Intercept) 5.07 h(x1-4) 0.95 h(5-x1) -0.99 h(x1-5) -0.94 h(x1-7) -0.05 h(x1-8) 0.01 h(6-x2) -0.02 h(x2-6) 1.01 Selected 8 of 8 terms, and 2 of 2 predictors Termination condition: Reached maximum RSq 1.0000 at 8 terms Importance: x1, x2 Weights: 1, 1, 1, 1, 0.5, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 7 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > > cat("\n#=== from test.glm.R ===========================================\n") #=== from test.glm.R =========================================== > > 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+07 0.2461 min 15 3 3.4484e+07 0.2406 15 4 3.0548e+07 0.2445 15 5 1.9834e+06 0.2724 min 15 6 2.0705e+07 0.2541 15 7 2.4297e+07 0.2506 15 8 6.3042e+06 0.2682 15 9 6.3458e+06 0.2681 15 10 8231.6 0.2743 min 15 11 1.5243e+07 0.2594 15 12 1.4677e+07 0.2600 15 13 1.0817e+07 0.2638 15 14 4.9902e+06 0.2695 15 15 4.2448e+06 0.2702 14 2 2.9403e+07 0.2456 min 14 3 3.491e+07 0.2402 14 4 3.0578e+07 0.2444 14 5 1.9758e+06 0.2724 min 14 6 2.074e+07 0.2541 14 7 2.4514e+07 0.2504 14 8 6.4997e+06 0.2680 14 9 6.995e+06 0.2675 14 11 1.5597e+07 0.2591 14 12 1.467e+07 0.2600 14 13 1.0901e+07 0.2637 14 14 5.1186e+06 0.2693 14 15 4.2486e+06 0.2702 13 2 4.1871e+07 0.2315 min 13 3 4.0788e+07 0.2325 min 13 4 3.2141e+07 0.2410 min 13 6 2.0184e+07 0.2527 min 13 7 2.3466e+07 0.2495 13 8 5.1563e+06 0.2674 min 13 9 7.0251e+06 0.2655 13 11 1.5565e+07 0.2572 13 12 2.1626e+07 0.2513 13 13 8.9657e+06 0.2636 13 14 3.173e+06 0.2693 min 13 15 3.5082e+06 0.2690 12 2 4.1546e+07 0.2287 min 12 3 7.7449e+07 0.1936 12 4 3.1892e+07 0.2381 min 12 6 2.3605e+07 0.2462 min 12 7 2.3299e+07 0.2465 min 12 8 4.9192e+06 0.2645 min 12 9 7.5636e+06 0.2619 12 11 1.5356e+07 0.2543 12 12 2.139e+07 0.2484 12 13 6.1065e+06 0.2633 12 15 2.5439e+06 0.2668 min 11 2 4.0833e+07 0.2269 min 11 3 7.5335e+07 0.1932 11 4 3.2208e+07 0.2353 min 11 6 2.3752e+07 0.2436 min 11 7 2.0994e+07 0.2463 min 11 8 4.7818e+06 0.2621 min 11 9 8.2607e+06 0.2587 11 11 1.3425e+07 0.2537 11 12 1.8871e+07 0.2484 11 13 3.5784e+06 0.2633 min 10 2 3.947e+07 0.2247 min 10 3 7.2626e+07 0.1923 10 4 2.897e+07 0.2350 min 10 6 2.2396e+07 0.2414 min 10 7 1.8734e+07 0.2450 min 10 8 4.7438e+06 0.2587 min 10 9 8.8185e+06 0.2547 10 11 1.0366e+07 0.2532 10 12 1.638e+07 0.2473 9 2 1.8992e+08 0.0730 min 9 3 7.3379e+07 0.1870 min 9 4 2.8502e+07 0.2308 min 9 6 2.5381e+07 0.2339 min 9 7 1.4043e+07 0.2450 min 9 9 1.3625e+07 0.2454 min 9 11 5.6644e+06 0.2531 min 9 12 1.5764e+07 0.2433 8 2 1.8436e+08 0.0729 min 8 3 7.3891e+07 0.1809 min 8 4 2.2897e+07 0.2308 min 8 6 2.6814e+07 0.2269 8 7 8.7055e+06 0.2446 min 8 9 9.3843e+06 0.2440 8 12 1.0108e+07 0.2433 7 2 1.9348e+08 0.0555 min 7 3 7.5359e+07 0.1710 min 7 4 1.7932e+07 0.2271 min 7 6 2.644e+07 0.2188 7 9 9.7584e+06 0.2351 min 7 12 8.2948e+06 0.2365 min 6 2 1.9155e+08 0.0493 min 6 3 7.663e+07 0.1616 min 6 4 1.17e+07 0.2251 min 6 6 3.1425e+07 0.2058 6 9 2.1466e+07 0.2155 5 2 1.8693e+08 0.0424 min 5 3 7.7548e+07 0.1493 min 5 6 3.258e+07 0.1932 min 5 9 2.2907e+07 0.2027 min 4 2 2.0575e+08 0.0016 min 4 3 7.681e+07 0.1276 min 4 6 3.0059e+07 0.1733 min 3 2 1.7662e+08 0.0007 min 3 3 6.448e+07 0.1103 min 2 2 1.1281e+08 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 > > cat("\n#=== from test.plotmo.R ===========================================\n") #=== from test.plotmo.R =========================================== > > # check various types of predictors with grid.func and ndiscrete > > varied.type.data <- data.frame( + y = 1:13, + num = c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5), # 7 unique values (but one is non integral) + int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L), # 8 unique values + bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T), + date = as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")), + ord = ordered(c("ord3", "ord3", "ord3", + "ord1", "ord2", "ord3", + "ord1", "ord2", "ord3", + "ord1", "ord1", "ord1", "ord1"), + levels=c("ord1", "ord3", "ord2")), + fac = as.factor(c("fac1", "fac1", "fac1", + "fac2", "fac2", "fac2", + "fac3", "fac3", "fac3", + "fac1", "fac2", "fac3", "fac3")), + str = c("str1", "str1", "str1", # will be treated like a factor + "str2", "str2", "str2", + "str3", "str3", "str3", + "str3", "str3", "str3", "str3")) > > varied.type.earth <- earth(y ~ ., data = varied.type.data, thresh=0, penalty=-1, trace=1) x[13,10] with colnames num int boolTRUE date ord.L ord.Q facfac2 facfac3 strstr2... y[13,1] with colname y, and values 1, 2, 3, 4, 5, 6, 7, 8, 9, 10... Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18 Reached maximum RSq 1.0000 at 19 terms, 13 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Prune backward penalty -1 nprune null: selected 13 of 13 terms, and 9 of 10 preds After pruning pass GRSq 1 RSq 1 > print(summary(varied.type.earth)) Call: earth(formula=y~., data=varied.type.data, trace=1, thresh=0, penalty=-1) coefficients (Intercept) 9.5964912 boolTRUE -2.0473684 ord.L 0.4986964 ord.Q 0.0859470 facfac2 -4.4157895 facfac3 -3.1526316 strstr2 3.2526316 h(4-num) 1.4105263 h(num-4) -0.3157895 h(4-int) 2.1157895 h(int-4) 0.3421053 h(17749-date) -3.8210526 h(date-17749) 1.4368421 Selected 13 of 13 terms, and 9 of 10 predictors Termination condition: Reached maximum RSq 1.0000 at 13 terms Importance: date, facfac2, facfac3, int, strstr2, boolTRUE, num, ord.L, ... Number of terms at each degree of interaction: 1 12 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > > cat("\n#=== from test.plotmo.args.R ===========================================\n") #=== from test.plotmo.args.R =========================================== > set.seed(2020) > > oz2 <- ozone1[1:40,] > set.seed(2015) > a <- earth(O3~temp+wind, dat=oz2, deg=2, nk=21, ncr=3, nfo=3, varmod.me="lm") > print(summary(a)) Call: earth(formula=O3~temp+wind, data=oz2, degree=2, nfold=3, ncross=3, varmod.method="lm", nk=21) coefficients (Intercept) 3.8636364 h(temp-42) 0.1581028 Selected 2 of 13 terms, and 1 of 2 predictors Termination condition: Reached nk 21 Importance: temp, wind-unused Number of terms at each degree of interaction: 1 1 (additive model) GCV 4.813872 RSS 160.332 GRSq 0.1971602 RSq 0.2967894 CVRSq -0.01337941 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 2.11 sd 0.33 nvars 1.11 sd 0.33 CVRSq sd MaxErr sd -0.013 0.283 8.7 4.66 varmod: method "lm" min.sd 0.252 iter.rsq 0.064 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 1.0887149 0.855322 79 O3 0.2608246 0.161143 62 mean smallest largest ratio 95% prediction interval 9.890959 8.217919 12.58237 1.53109 68% 80% 90% 95% response values in prediction interval 78 90 100 100 > plotmo(a, caption.col=3, caption.font=2, grid.col="pink", + level=.8, SHOWCALL=TRUE) plotmo grid: temp wind 53.5 4 > > cat("\n#=== from test.plotmo3.R ===========================================\n") #=== from test.plotmo3.R =========================================== > set.seed(2020) > > # basic tests of plotmo on abbreviated titanic data > > get.tita <- function() + { + tita <- etitanic + pclass <- as.character(tita$pclass) + # change the order of the factors so not alphabetical + pclass[pclass == "1st"] <- "first" + pclass[pclass == "2nd"] <- "class2" + pclass[pclass == "3rd"] <- "classthird" + tita$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) + # log age is so we have a continuous predictor even when model is age~. + set.seed(2015) + tita$logage <- log(tita$age) + rnorm(nrow(tita)) + tita$parch <- NULL + # by=12 gives us a small fast model with an additive and a interaction term + tita[seq(1, nrow(etitanic), by=12), ] + } > tita <- get.tita() > # tita[,4] is age > set.seed(2020) > mod.earth.tita.age <- earth(tita[,-4], tita[,4], degree=2, nfold=3, ncross=3, trace=.5, varmod.method="lm") Model with pmethod="backward": GRSq 0.335 RSq 0.512 nterms 6 CV fold 1.1 CVRSq -0.047 n.oof 58 34% n.infold.nz 58 100% n.oof.nz 30 100% CV fold 1.2 CVRSq -0.022 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 1.3 CVRSq -0.045 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 2.1 CVRSq 0.133 n.oof 58 34% n.infold.nz 58 100% n.oof.nz 30 100% CV fold 2.2 CVRSq 0.338 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 2.3 CVRSq 0.149 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 3.1 CVRSq 0.419 n.oof 58 34% n.infold.nz 58 100% n.oof.nz 30 100% CV fold 3.2 CVRSq 0.107 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 3.3 CVRSq 0.307 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV all CVRSq 0.149 n.infold.nz 88 100% varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) tita[, 4] 1 1.4 0.0 13 -0.032 2 1.2 7.1 12 -0.018 3 1.3 3.0 13 -0.024 4 1.3 1.2 13 -0.022 5 1.3 0.5 13 -0.023 > cat("\nsummary(mod.earth.tita.age)\n") summary(mod.earth.tita.age) > print(summary(mod.earth.tita.age)) Call: earth(x=tita[,-4], y=tita[,4], trace=0.5, degree=2, nfold=3, ncross=3, varmod.method="lm") coefficients (Intercept) 25.664968 pclassfirst 9.028974 h(sibsp-1) -12.096706 h(1.68119-logage) -7.502937 sexmale * h(logage-2.48137) 5.062358 sibsp * h(logage-1.68119) 3.280947 Selected 6 of 14 terms, and 4 of 6 predictors Termination condition: Reached nk 21 Importance: logage, sexmale, pclassclassthird-unused, sibsp, pclassfirst, ... Number of terms at each degree of interaction: 1 3 2 GCV 174.7603 RSS 11022.31 GRSq 0.335155 RSq 0.5124778 CVRSq 0.1487371 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.89 sd 1.05 nvars 3.22 sd 0.97 CVRSq sd MaxErr sd 0.149 0.174 -39.1 32.3 varmod: method "lm" min.sd 1.49 iter.rsq 0.001 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 15.7287403 2.77398 18 tita[, 4] -0.0283536 0.0837154 295 mean smallest largest ratio 95% prediction interval 58.24711 55.23254 62.56685 1.13279 68% 80% 90% 95% response values in prediction interval 84 90 97 99 > plotmo(mod.earth.tita.age, SHOWCALL=TRUE) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > > set.seed(2020) > mod.earth.sex <- earth(sex~., data=tita, degree=2, nfold=3, ncross=3, varmod.method="earth", glm=list(family=binomial), trace=.5) Model with pmethod="backward": GRSq 0.333 RSq 0.478 nterms 5 CV fold 1.1 CVRSq -0.249 n.oof 61 31% n.infold.nz 39 64% n.oof.nz 20 74% CV fold 1.2 CVRSq 0.038 n.oof 57 35% n.infold.nz 39 68% n.oof.nz 20 65% CV fold 1.3 CVRSq 0.293 n.oof 58 34% n.infold.nz 40 69% n.oof.nz 19 63% CV fold 2.1 CVRSq -1.534 n.oof 59 33% n.infold.nz 39 66% n.oof.nz 20 69% CV fold 2.2 CVRSq 0.289 n.oof 54 39% n.infold.nz 39 72% n.oof.nz 20 59% CV fold 2.3 CVRSq 0.212 n.oof 63 28% n.infold.nz 40 63% n.oof.nz 19 76% CV fold 3.1 CVRSq 0.144 n.oof 59 33% n.infold.nz 39 66% n.oof.nz 20 69% CV fold 3.2 Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred CVRSq -0.452 n.oof 59 33% n.infold.nz 39 66% n.oof.nz 20 69% CV fold 3.3 CVRSq 0.522 n.oof 58 34% n.infold.nz 40 69% n.oof.nz 19 63% CV all CVRSq -0.082 n.infold.nz 59 67% varmod method="earth" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) h(male-0.425371) 1 14 0 0.73 -1 h(0.425371-male) -1.1 > cat("\nsummary(mod.earth.sex)\n") summary(mod.earth.sex) > print(summary(mod.earth.sex)) Call: earth(formula=sex~., data=tita, trace=0.5, glm=list(family=binomial), degree=2, nfold=3, ncross=3, varmod.method="earth") GLM coefficients male (Intercept) 2.2100473 survived -5.5463575 pclassclassthird * h(31-age) -0.1144390 survived * h(age-31) 0.2623977 survived * h(31-age) 0.1814641 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 111.559 87 67.1605 83 0.398 77.16 5 1 Earth selected 5 of 12 terms, and 3 of 6 predictors Termination condition: Reached nk 21 Importance: survived, age, pclassclassthird, pclassfirst-unused, ... Number of terms at each degree of interaction: 1 1 3 Earth GCV 0.1507171 RSS 10.15456 GRSq 0.3332684 RSq 0.4777313 CVRSq -0.08180991 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.78 sd 1.39 nvars 2.89 sd 1.17 CVRSq sd ClassRate sd MaxErr sd AUC sd MeanDev sd CalibInt -0.082 0.619 0.745 0.08 -1 0.951 0.719 0.14 2.61 2.77 0.27 sd CalibSlope sd 0.612 0.63 0.588 varmod: method "earth" min.sd 0.0412 iter.rsq 0.246 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 0.9211535 0.104791 11 h(0.425371-male) -1.4199715 0.37374 26 h(male-0.425371) -1.2999441 0.247601 19 mean smallest largest ratio 95% prediction interval 1.615511 0.9644817 3.610856 3.74383 68% 80% 90% 95% response values in prediction interval 90 92 94 94< > plotmo(mod.earth.sex, SHOWCALL=TRUE) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > > cat("\n#=== from test.unusual.vars.R ===========================================\n") #=== from test.unusual.vars.R =========================================== > set.seed(2020) > > vdata <- data.frame( + resp = 1:13, + bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T), + ord = ordered(c("ORD1", "ORD1", "ORD1", + "ORD1", "ORD1", "ORD1", + "ORD3", "ORD3", "ORD3", + "ORD2", "ORD2", "ORD2", "ORD2"), + levels=c("ORD1", "ORD3", "ORD2")), + fac = as.factor(c("FAC1", "FAC1", "FAC1", + "FAC2", "FAC2", "FAC2", + "FAC3", "FAC3", "FAC3", + "FAC1", "FAC2", "FAC3", "FAC3")), + str = c("STR1", "STR1", "STR1", # WILL BE TREATED LIKE A FACTOR + "STR2", "STR2", "STR2", + "STR3", "STR3", "STR3", + "STR3", "STR3", "STR3", "STR3"), + num = c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5), # 7 unique values (but one is non integral) + sqrt_num = sqrt(c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5)), + int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L), # 8 unique values + date = as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")), + date_num = as.numeric(as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")))) > > vdata$off <- (1:nrow(vdata)) / nrow(vdata) > > resp2 <- 13:1 > > vweights <- rep(1, length.out=nrow(vdata)) > vweights[1] <- 2 > > set.seed(2020) > lognum.bool.ord.off <- earth(resp ~ log(num) + bool + ord + offset(off), degree=2, weights=vweights, + data=vdata, pmethod="none", varmod.method="lm", + nfold=2, ncross=3, + trace=1) x[13,4] with colnames log(num) boolTRUE ord.L ord.Q y[13,1] with colname resp, and values 0.9231, 1.846, 2.769, 3.692, ... weights[13]: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Forward pass term 1, 2, 4, 6, 8 GRSq -Inf at 7 terms, 5 terms used After forward pass GRSq -in RSq 0.966 Prune none penalty 3 nprune null: selected 5 of 5 terms, and 3 of 4 preds After pruning pass GRSq -0.732 RSq 0.952 CV fold 1.1 CVRSq -0.476 n.oof 6 54% n.infold.nz 6 100% n.oof.nz 7 100% CV fold 1.2 CVRSq 0.823 n.oof 7 46% n.infold.nz 7 100% n.oof.nz 6 100% CV fold 2.1 CVRSq -0.622 n.oof 6 54% n.infold.nz 6 100% n.oof.nz 7 100% CV fold 2.2 CVRSq 0.816 n.oof 7 46% n.infold.nz 7 100% n.oof.nz 6 100% CV fold 3.1 CVRSq 0.559 n.oof 6 54% n.infold.nz 6 100% n.oof.nz 7 100% CV fold 3.2 CVRSq 0.698 n.oof 7 46% n.infold.nz 7 100% n.oof.nz 6 100% CV all CVRSq 0.300 n.infold.nz 13 100% varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) resp 1 1.6 0.00 1.76 0.045 2 2.2 39.64 1.55 0.076 3 2.9 19.19 1.40 0.098 4 3.5 12.21 1.29 0.115 5 4.1 8.66 1.21 0.127 6 4.6 6.50 1.15 0.137 7 5.0 5.05 1.10 0.145 8 5.5 4.02 1.06 0.152 9 5.8 3.25 1.03 0.157 10 6.1 2.66 1.00 0.162 11 6.4 2.19 0.98 0.165 12 6.7 1.82 0.97 0.168 13 6.9 1.52 0.95 0.171 14 7.1 1.28 0.94 0.173 15 7.3 1.08 0.93 0.175 16 7.4 0.91 0.92 0.176 > print(summary(lognum.bool.ord.off)) Call: earth(formula=resp~log(num)+bool+ord+offset(off), data=vdata, weights=vweights, pmethod="none", trace=1, degree=2, nfold=2, ncross=3, varmod.method="lm") coefficients (Intercept) 6.273213 boolTRUE 1.111403 h(-7.85046e-17-ord.L) -7.600147 h(ord.L- -7.85046e-17) 4.568998 log(num) * h(-7.85046e-17-ord.L) 3.100021 Selected 5 of 5 terms, and 3 of 4 predictors (pmethod="none") Termination condition: GRSq -Inf at 5 terms Importance: ord.L, log(num), boolTRUE, ord.Q-unused Offset: off with values 0.07692308, 0.1538462, 0.2307692, 0.3076923, 0.3... Weights: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 3 1 GCV 28.70012 RSS 8.830806 GRSq -0.7319038 RSq 0.9518916 CVRSq 0.2995745 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 2.33 sd 0.52 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.3 0.666 -6 3.53 varmod: method "lm" min.sd 0.27 iter.rsq 0.204 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 1.151190 0.759983 66 resp 0.220811 0.131375 59 mean smallest largest ratio 95% prediction interval 10.57312 5.357389 14.56643 2.718942 68% 80% 90% 95% response values in prediction interval 100 100 100 100 > > cat("\n#=== from test.caret.R ===========================================\n") #=== from test.caret.R =========================================== > set.seed(2020) > > library(caret) Loading required package: ggplot2 Loading required package: lattice > set.seed(2015) > a.bag3 <- bagEarth(survived~., data=etitanic, degree=2, B=3, trace=1) x[1046,7] with colnames pclass1st pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname subY, and values 0, 0, 0, 0, 1, 1, 1, 0, 0, 0,... weights: no weights (because all weights equal) Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.435 RSq 0.472 Prune backward penalty 3 nprune null: selected 10 of 15 terms, and 6 of 7 preds After pruning pass GRSq 0.444 RSq 0.468 x[1046,7] with colnames pclass1st pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname subY, and values 0, 0, 1, 1, 1, 0, 0, 0, 1, 1,... weights: no weights (because all weights equal) Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.385 RSq 0.434 Prune backward penalty 3 nprune null: selected 12 of 18 terms, and 6 of 7 preds After pruning pass GRSq 0.402 RSq 0.433 x[1046,7] with colnames pclass1st pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname subY, and values 1, 1, 0, 1, 1, 1, 0, 1, 0, 0,... weights: no weights (because all weights equal) Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.451 RSq 0.487 Prune backward penalty 3 nprune null: selected 13 of 15 terms, and 6 of 7 preds After pruning pass GRSq 0.456 RSq 0.487 > print(a.bag3) Call: bagEarth.formula(formula = survived ~ ., data = etitanic, B = 3, degree = 2, trace = 1) Data: # variables: 7 # samples: 1046 case weights used B: 3 > plotmo(a.bag3, clip=F, caption="bagEarth, etitanic", trace=1, SHOWCALL=TRUE) stats::predict(bagEarth.object, data.frame[3,7], type="response") stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead assuming "survived" in the model.frame is the response, because terms(object) did not return the terms assuming "survived" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(survived ~ ., data=call$data, na.action="na.fail") plotmo grid: pclass1st pclass2nd pclass3rd sexmale age sibsp parch 0 0 0 1 28 0 0 > plotres(a.bag3, clip=F, trace=1, SHOWCALL=TRUE) stats::residuals(object=bagEarth.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(bagEarth.object, data.frame[3,7], type="response", clip=FALSE) stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead assuming "survived" in the model.frame is the response, because terms(object) did not return the terms assuming "survived" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(survived ~ ., data=call$data, na.action="na.fail") assuming "survived" in the model.frame is the response, because terms(object) did not return the terms training rsq 0.44 > > # Following commented out because too slow > # > # cat("\n#=== from test.parsnip.R ===========================================\n") > # set.seed(2020) > # > # cat("loading parsnip libraries\n") # these libraries take several seconds to load > # library(tidymodels) > # library(timetk) > # library(lubridate) > # cat("loaded parsnip libraries\n") > # cat("parsnip version:", as.character(packageVersion("parsnip")[[1]]), "\n") > # > # vdata <- data.frame( > # resp = 1:23, > # bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T, F, F, T, T, T, T, T, T, T, T), > # ord = ordered(c("ORD1", "ORD1", "ORD1", > # "ORD1", "ORD1", "ORD1", > # "ORD1", "ORD3", "ORD1", > # "ORD2", "ORD2", "ORD2", "ORD2", > # "ORD2", "ORD2", "ORD2", > # "ORD3", "ORD3", "ORD3", > # "ORD2", "ORD2", "ORD2", "ORD2"), > # levels=c("ORD1", "ORD3", "ORD2")), > # fac = as.factor(c("FAC1", "FAC1", "FAC1", > # "FAC2", "FAC2", "FAC2", > # "FAC3", "FAC1", "FAC1", > # "FAC1", "FAC2", "FAC2", "FAC2", > # "FAC2", "FAC2", "FAC2", > # "FAC3", "FAC3", "FAC3", > # "FAC1", "FAC3", "FAC3", "FAC3")), > # str = c("STR1", "STR1", "STR1", # WILL BE TREATED LIKE A FACTOR > # "STR1", "STR1", "STR1", > # "STR2", "STR2", "STR2", > # "STR3", "STR3", "STR2", "STR3", > # "STR2", "STR3", "STR2", > # "STR3", "STR3", "STR3", > # "STR3", "STR3", "STR3", "STR3"), > # num = c(1, 9, 2, 3, 14, 5, 6, 4, 5, 6.5, 3, 6, 5, > # 3, 4, 5, 6, 4, 5, 16.5, 3, 16, 15), > # sqrt_num = sqrt( > # c(1, 9, 2, 3, 14, 5, 6, 4, 5, 6.5, 3, 6, 5, > # 3, 4, 5, 6, 4, 5, 16.5, 3, 16, 15)), > # int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L, > # 13L, 14L, 3L, 13L, 5L, 13L, 16L, 17L, 18L, 11L), > # date = as.Date( > # c("2018-08-01", "2018-08-02", "2018-08-03", > # "2018-08-04", "2018-08-05", "2018-08-06", > # "2018-08-07", "2018-08-08", "2018-08-08", > # "2018-08-10", "2018-08-10", "2018-08-11", "2018-08-11", > # "2018-08-11", "2018-08-12", "2018-08-13", > # "2018-08-10", "2018-08-15", "2018-08-17", > # "2018-08-04", "2018-08-19", "2018-08-03", "2018-08-18")), > # date_num = as.numeric(as.Date( > # c("2018-08-01", "2018-08-02", "2018-08-03", > # "2018-08-04", "2018-08-05", "2018-08-06", > # "2018-08-07", "2018-08-08", "2018-08-08", > # "2018-08-10", "2018-08-10", "2018-08-11", "2018-08-11", > # "2018-08-11", "2018-08-12", "2018-08-13", > # "2018-08-10", "2018-08-15", "2018-08-17", > # "2018-08-04", "2018-08-19", "2018-08-03", "2018-08-18")))) > # > # set.seed(2020) > # splits <- initial_time_split(vdata, prop=.9) > # > # cat("===m750a first example===\n") > # set.seed(2020) > # m750a <- m4_monthly %>% > # filter(id == "M750") %>% > # select(-id) > # print(m750a) # a tibble > # set.seed(2020) > # splits_a <- initial_time_split(m750a, prop = 0.9) > # earth_m750a <- earth(log(value) ~ as.numeric(date) + month(date, label = TRUE), data = training(splits_a), degree=2) > # print(summary(earth_m750a)) > > cat("\n#=== from test.non.earth.R ===========================================\n") #=== from test.non.earth.R =========================================== > set.seed(2020) > > # Following gives different results on different systems (Oct 2020, earth 5.3.0). > # For example: > # Win7 (Intel i7-4910MQ): Earth selected 7 of 19 terms, and 3 of 3 predictors, GRSq 0.20041 RSq 0.47214 > # Ubuntu (Intel P8600): Earth selected 2 of 19 terms, and 1 of 3 predictors, GRSq 0.18687 RSq 0.23689 > > library(rpart) # for kyphosis data > data(kyphosis) > a <- earth(Kyphosis ~ ., data=kyphosis, degree=2, glm=list(family=binomial), trace=4) Call: earth(formula=Kyphosis~., data=kyphosis, trace=4, glm=list(family=binomial), degree=2) x[81,3]: Age Number Start 1 71 3 5 2 158 3 14 3 128 4 5 ... 2 5 1 81 36 4 13 y[81,1]: present 1 0 2 0 3 1 ... 0 81 0 Forward pass: minspan 4 endspan 8 x[81,3] 1.9 kB bx[81,21] 13.3 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.1485 0.2516 0.2516 3 Start 6 2 3 1 4 0.1233 0.3288 0.07718 1 Age 97 4 5 1 6 0.0792 0.3921 0.06334 1 Age 114 6 7 2 2 8 -0.0291 0.4212 0.02903 2 Number 3 8 9 5 2 10 -0.1701 0.4470 0.02581 2 Number 3 10 11 2 2 12 -0.3036 0.4908 0.04382 2 Number 6 12 13 1 14 -0.4432 0.5434 0.05258 1 Age 78 14 15 13 2 16 -0.4927 0.5787 0.03535 2 Number 3 16 1 18 -0.8279 0.5984 0.01966 1 Age 42 17 18 16 2 20 -1.0151 0.6143 0.01592 3 Start 5 19 1 final (reached nk 21) Reached nk 21 After forward pass GRSq -1.015 RSq 0.614 Forward pass complete: 21 terms, 19 terms used Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 2 0.1869 0.2369 0.1869 1 1 2 3 0.1901 0.2882 0.0032 2 1 2 5 4 0.1995 0.3426 0.0094 2 1 2 5 7 5 0.1810 0.3729 -0.0186 3 1 2 5 7 8 6 0.1708 0.4097 -0.0102 3 1 2 5 7 10 13 chosen 7 0.2004 0.4721 0.0296 3 1 2 5 7 10 13 17 8 0.1859 0.5031 -0.0145 3 1 2 5 7 10 13 17 19 9 0.1364 0.5142 -0.0494 3 1 2 5 7 10 12 13 15 17 10 0.1063 0.5383 -0.0302 3 1 2 5 7 10 13 15 17 18 19 11 0.0736 0.5621 -0.0326 3 1 2 5 7 10 12 13 15 17 18 19 12 0.0143 0.5755 -0.0593 3 1 2 5 7 10 11 12 13 15 17 18 19 13 -0.0384 0.5944 -0.0527 3 1 2 5 7 8 10 11 12 13 15 17 18 19 14 -0.1170 0.6062 -0.0786 3 1 2 5 6 7 8 10 11 12 13 15 17 18 19 15 -0.2333 0.6098 -0.1163 3 1 2 5 6 7 8 9 10 11 12 13 15 17 18 19 16 -0.3686 0.6137 -0.1353 3 1 2 5 6 7 8 9 10 11 12 13 15 16 17 18 19 17 -0.5432 0.6142 -0.1746 3 1 2 3 5 6 7 8 9 10 11 12 13 15 16 17 18 19 18 -0.7555 0.6143 -0.2123 3 1 2 3 4 5 6 7 8 9 10 11 12 13 15 16 17 18 19 19 -1.0151 0.6143 -0.2596 3 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 Prune backward penalty 3 nprune null: selected 7 of 19 terms, and 3 of 3 preds After pruning pass GRSq 0.2 RSq 0.472 glm y[81,1]: present 1 0 2 0 3 1 ... 0 81 0 glm weights: NULL GLM present devratio 0.56 dof 74/80 iters 8 > print(summary(a)) Call: earth(formula=Kyphosis~., data=kyphosis, trace=4, glm=list(family=binomial), degree=2) GLM coefficients present (Intercept) 12.4739052 h(97-Age) -0.1563678 h(6-Number) -3.8334755 h(Start-6) -0.3798750 h(Age-42) * h(Number-3) -0.0197570 h(114-Age) * h(Start-6) 0.0089521 h(Number-3) * h(Start-6) -0.3545004 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 83.2345 80 36.4652 74 0.562 50.47 8 1 Earth selected 7 of 19 terms, and 3 of 3 predictors Termination condition: Reached nk 21 Importance: Start, Age, Number Number of terms at each degree of interaction: 1 3 3 Earth GCV 0.1359306 RSS 7.090206 GRSq 0.2004084 RSq 0.4721446 > par(mfrow=c(3,3)) > plotmo(a, type2="image", do.par=FALSE, + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + clip=F) plotmo grid: Age Number Start 87 4 13 > plotmo(a, clip=F, degree1=0, do.par=FALSE) > > source("test.epilog.R") earth/inst/slowtests/test.plotd.Rout.save0000644000176200001440000005304314563605665020336 0ustar liggesusers> # test.plotd.R > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > 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) > > # 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) Warning in terms.formula(formula, data = data) : 'varlist' has changed (from nvar=6) to new 7 after EncodeVars() -- should no longer happen! > 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) Warning in terms.formula(formula, data = data) : 'varlist' has changed (from nvar=6) to new 7 after EncodeVars() -- should no longer happen! > 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) Warning in terms.formula(formula, data = data) : 'varlist' has changed (from nvar=6) to new 7 after EncodeVars() -- should no longer happen! > > 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), 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) --get.model.env for object with class lm object call is lm(formula=as.numeric(sex)~., data=etitanic) using the environment saved in $terms of 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(org.par) > > source("test.epilog.R") earth/inst/slowtests/test.pmethod.cv.bat0000755000176200001440000000175714563571565020154 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-4.3.2\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 -w to treat \n same as \r\n @mks.diff -w test.pmethod.cv.Rout test.pmethod.cv.Rout.save @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 @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.mem.Rout0000644000176200001440000002776614563615214017041 0ustar liggesusers> # test.mem.R: test earth C code memory usage under both normal and error conditions > # > # TODO With some versions of R, test.mem gives different results per run. > # First seen Sep 2020, R 4.0.3. > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > > # 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) + } Warning: 'memory.size()' is no longer supported Warning: 'memory.size()' is no longer supported mem NaN ncells 19 vcells 29 Warning: 'memory.size()' is no longer supported mem NaN ncells 1579 vcells 3668 Warning: 'memory.size()' is no longer supported mem NaN ncells 1779 vcells 4248 Warning: 'memory.size()' is no longer supported mem NaN ncells 1779 vcells 4248 Warning: 'memory.size()' is no longer supported mem NaN ncells 1779 vcells 4248 > 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) + } Warning: 'memory.size()' is no longer supported Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 > # 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) + } Warning: 'memory.size()' is no longer supported Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 > # 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) + } Warning: 'memory.size()' is no longer supported Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 > # 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 expected error 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) + } Warning: 'memory.size()' is no longer supported Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 > > # 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 expected error 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) + } Warning: 'memory.size()' is no longer supported Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 Warning: 'memory.size()' is no longer supported mem NaN ncells 8 vcells 0 > > cat("nlm "); print(nlm) nlm [1] NaN NaN NaN NaN NaN > cat("nstandardearth"); print(nstandardearth) nstandardearth[1] NaN NaN NaN NaN NaN > cat("ngoodallowed "); print(ngoodallowed) ngoodallowed [1] NaN NaN NaN NaN NaN > cat("nbadallowed "); print(nbadallowed) nbadallowed [1] NaN NaN NaN NaN NaN > cat("nbadendspan "); print(nbadendspan) nbadendspan [1] NaN NaN NaN NaN NaN > > # 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) Error in plot.window(...) : need finite 'ylim' values Calls: plotmem -> plot -> plot.default -> localWindow -> plot.window Execution halted earth/inst/slowtests/test.glm.bat0000755000176200001440000000141214563571565016650 0ustar liggesusers@rem test.glm.bat @echo test.glm.bat @"C:\PROGRA~1\R\R-4.3.2\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.ordinal.bat0000755000176200001440000000162414563571565017526 0ustar liggesusers@rem test.ordinal.bat: ordinal models by way of package "ordinal" and earth's bx matrix @rem Sep 2020 Petaluma @echo test.ordinal.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.ordinal.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.ordinal.Rout: @echo. @tail test.ordinal.Rout @echo test.ordinal.R @exit /B 1 :good1 mks.diff test.ordinal.Rout test.ordinal.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.ordinal.save.ps @exit /B 1 :good2 @rem test.ordinal.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.ordinal.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.ordinal.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.full.R0000644000176200001440000024643014565631311016462 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) plotmo(a1a) a1b <- earth(etitanic[,-2,drop=FALSE], etitanic[,2,drop=FALSE], degree=2, trace=1, glm=list(family=binomial)) printh(a1b) plotmo(a1b) # test modvars for the example in the man page earth.object.Rd aform <- earth(survived ~ age + pclass + sqrt(age) - sex, data=etitanic) cat("\nattr(aform$terms, \"factors\")\n") print(attr(aform$terms, "factors")) cat("\na$modvars\n") print(aform$modvars) cat("\n") axy.dat <- data.frame(age=etitanic$age, pclass=etitanic$pclass, sqrt_age=sqrt(etitanic$age)) axy <- earth(axy.dat, etitanic$survived) cat("\nattr(axy$terms, \"factors\")\n") print(attr(axy$terms, "factors")) cat("\na$modvars\n") print(axy$modvars) cat("\n") # x and y dataframes but with missing column names xdf_nonames <- etitanic[,-2,drop=FALSE] cat("original colnames of xdf_nonames:", paste(colnames(xdf_nonames)), "\n") ydf_nonames <- etitanic[,2,drop=FALSE] colnames(xdf_nonames) <- NULL # weird for a dataframe, but earth still works colnames(ydf_nonames) <- NULL earth_df_nonames <- earth(xdf_nonames, ydf_nonames, degree=2, trace=1, glm=list(family=binomial)) cat("earth_df_nonames:\n") print(summary(earth_df_nonames)) cat("\nearth_df_nonames$modvars\n") print(earth_df_nonames$modvars) options(warn=2) expect.err(try(plotmo(earth_df_nonames)), "Cannot determine which variables to plot") plotmo(earth_df_nonames, all1=TRUE, SHOWCALL=TRUE) options(warn=1) plotmo(earth_df_nonames, trace=1, SHOWCALL=TRUE) # xmat in canonical form (double matrix) but with missing column names xmat_nonames <- etitanic[,"age",drop=FALSE] xmat_nonames$pclass <- as.numeric(etitanic[,"pclass"]) xmat_nonames <- as.matrix(xmat_nonames) cat("original colnames of xmat_nonames:", paste(colnames(xmat_nonames)), "\n") ymat_nonames <- as.numeric(etitanic[,"survived"]) ymat_nonames <- as.matrix(ymat_nonames) colnames(xmat_nonames) <- NULL colnames(ymat_nonames) <- NULL earth_mat_nonames <- earth(xmat_nonames, ymat_nonames, degree=2, trace=1) cat("earth_mat_nonames:\n") print(summary(earth_mat_nonames)) options(warn=2) expect.err(try(plotmo(earth_mat_nonames)), "Cannot determine which variables to plot") options(warn=1) plotmo(earth_mat_nonames) # xmat in canonical form (double matrix) but with some missing column names xmat_partial <- etitanic[,"age",drop=FALSE] xmat_partial$pclass <- as.numeric(etitanic[,"pclass"]) xmat_partial$sibsp <- as.numeric(etitanic[,"sibsp"]) xmat_partial <- as.matrix(xmat_partial) cat("original colnames of xmat_partial:", paste(colnames(xmat_partial)), "\n") colnames(xmat_partial) <- c("", "x2", "") # some column names are missing (earth will create them) ymat_partial <- as.numeric(etitanic[,"survived"]) ymat_partial <- as.matrix(ymat_partial) colnames(ymat_partial) <- "yy" earth_mat_partialnames <- earth(xmat_partial, ymat_partial, degree=2, trace=1) cat("earth_mat_partialnames:\n") print(summary(earth_mat_partialnames)) options(warn=2) expect.err(try(plotmo(earth_mat_partialnames)), "Cannot determine which variables to plot") options(warn=1) plotmo(earth_mat_partialnames) # use a partial column name that will cause a duplicate within gen.colnames colnames(xmat_partial) <- c("", "xmat_partial1", "") expect.err(try(earth(xmat_partial, ymat_partial, degree=2, trace=1)), "Duplicate colname in xmat_partial (colnames are \"xmat_partial1\", \"xmat_partial1\", \"xmat_partial3\")") 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) mars.mod <- mars(trees[,-3], trees[,3]) cat("print.default(mars.mod):\n") print.default(mars.mod) mars.to.earth.mod <- mars.to.earth(mars.mod) cat("print.default(mars.to.earth.mod):\n") print.default(mars.to.earth.mod) printh(mars.to.earth.mod) printh(summary(mars.to.earth.mod)) printh(summary(mars.to.earth.mod, style="bf")) stopifnot(length(mars.mod$coeff) == length(mars.to.earth.mod$coeff)) stopifnot(max(mars.mod$coeff - mars.to.earth.mod$coeff) < 1e-10) earth.mod <- earth(trees[,-3], trees[,3]) stopifnot(length(mars.mod$coeff) == length(earth.mod$coeff)) # coeff differences can be big because forward passes are different stopifnot(max(mars.mod$coeff - earth.mod$coeff) < .3) par(mfrow=c(3,4), mar=c(4, 3.2, 3, 3), mgp=c(1.6, 0.6, 0), cex = 0.7) plot(mars.to.earth.mod, which=c(1,3), do.par=FALSE) plotmo(mars.to.earth.mod, do.par=FALSE) mars.to.earth.mod2 <- update(mars.to.earth.mod) plot(mars.to.earth.mod2, which=c(1,3), do.par=FALSE) plotmo(mars.to.earth.mod2, do.par=FALSE) plot(earth.mod, which=c(1,3), do.par=FALSE) plotmo(earth.mod, do.par=FALSE) par(org.par) 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)), "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") options(warn=2) # TODO column naming for the following maybe needs work? # nresponse="cbind(Volume, Volume + 100)2" is confusing (2 should be in brackets?) expect.err(try(plot(a)), "Defaulting to nresponse=1, see above messages") options(warn=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, 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 xy interface ---\n") iris.earth <- earth(iris[,1:3], iris[,4]) x <- iris[1,] predict.with.message("default interface and vector", iris.earth, newdata=x) # tests the "Fix: April 2010" in get.earthx() 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", print.mars=FALSE) { fite <- earth(x, y, degree=degree, nk=nk, trace=trace) fitm <- mars(x, y, degree=degree, nk=nk) fitme <- mars.to.earth(fitm) 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)), "RSq", sprint("%4.2g", fite$rsq), "GRSq", sprint("%4.2g", fite$grsq), "mars RSq", sprint("%4.2g", fitme$rsq), "ratio", sprint("%.2f", fite$rsq / fitme$rsq), "GRSq", sprint("%4.2g", fitme$grsq), "ratio", sprint("%.2f", fite$grsq / fitme$grsq), "\n") if(print.mars) { fitme1 <- update(fitme) # generate model selection data printh(summary(fitme1)) cat("\n") } printh(summary(fite)) if(plotit) { caption <- paste("itest ", itest, ": ", sModel, " degree=", degree, " nk=", nk, sep="") 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 see "Fixed rank deficient bx by removing 2 terms, 7 terms remain" 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, print.mars=TRUE) 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() par(org.par) 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) plot(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) 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(org.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 par(mfrow=c(2,2), mar=c(4, 3.2, 3, 3), mgp=c(1.6, 0.6, 0), 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(org.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") # trace==2 so we see "Fixed rank deficient bx by removing terms" # TODO why are we getting the rank deficient message? 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, xy 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 # TODO June 2021: this doesn't actually check factors and never has, see note below ff <- factor(substring("statistics", 1:10, 1:10), levels=letters, ordered=TRUE) # NOTE: Jun 2021: added as.numeric for backward compability with R pre version R 4.1.0 ff <- as.numeric(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") expect.err(try(earth(cbind(O3, O3) ~ ., data=ozone1, wp=c(1, .01))), "Duplicate colname in cbind(O3, O3) (colnames are \"O3\", \"O3\")") oz2 <- ozone1 oz2$O3a <- ozone1$O3 e4 <- earth(cbind(O3, O3a) ~ ., data=oz2, 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("--- /a/r/earth/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("--- example in earth vignette \"How do I get p values for earth model coefficients?\" ---\n") earth.mod <- earth(Volume~., data=trees) # standard earth model bx <- earth.mod$bx[,-1] # earth model's basis mat (-1 to drop intercept) bx <- as.data.frame(bx) # lm requires a data frame bx$Volume <- trees$Volume # add Volume to data lm.mod <- lm(Volume~., data=bx) # standard linear regression on earth's basis mat summary(lm.mod) # prints p values remove(earth.mod, bx, lm.mod) # tidy up cat("--- examples in model.matrix.earth.Rd ---------------------------------------\n") # Example 1 data(trees) earth.mod <- earth(Volume ~ ., data = trees) # standard earth model 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 # Example 2 earth.mod <- earth(Volume~., data=trees) # standard earth model summary(earth.mod, decomp = "none") # "none" to print terms in same order as lm.mod below bx <- model.matrix(earth.mod) # earth model's basis mat (equivalent to bx <- earth.mod$bx) bx <- bx[, -1, drop=FALSE] # -1 to drop intercept bx <- as.data.frame(bx) # lm requires a data frame bx$Volume <- trees$Volume # add Volume to data lm.mod <- lm(Volume~., data=bx) # standard linear regression on earth's basis mat summary(lm.mod) # yields same coeffs as above summary # displayed t values are not meaningful remove(earth.mod, bx, lm.mod) # tidy up 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 print(predict.earth - predict.lm) stopifnot(max(abs(predict.lm - predict.earth)) < 1e-15) # Check fix for bug reported by Max Kuhn (Oct 2020, fixed in earth 5.3.0): # Occasionally we used to put a 1 when we should have put a 2 into the dirs matrix. options.old <- options() options(width=1000) library(modeldata) data(ames) vars <- c("Sale_Price", "Gr_Liv_Area", "Alley", "Mas_Vnr_Type", "BsmtFin_Type_2", "Condition_2") ames2 <- ames[,vars,drop=FALSE] ames2$Sale_Price <- log10(ames2$Sale_Price) # change colnames to something easier to work with colnames(ames2) <- c("Sale_Price", "g", "a", "m", "b", "c") ames2 <- as.data.frame(ames2) ames2.mod <- earth(Sale_Price ~ ., data = ames2, degree = 2, trace=4, pmethod="none") cat("\nsummary(ames2.mod)\n") print(summary(ames2.mod)) cat("\names2.mod$dirs\n") print(ames2.mod$dirs) plotmo(ames2.mod, SHOWCALL=TRUE) # check that there are no 1s in dirs, except for the "g" variable # all entries should be 0 or 2, because all vars are indicators (binary), so no knots stopifnot(all(ames2.mod$dirs[,-1,drop=FALSE] != 1)) # -1 drops "g" column stopifnot(ames2.mod$dirs["h(g-3390)*mStone", "mStone"] == 2) # same as above but with Auto.linpreds=FALSE ames2.mod.Auto.linpreds.FALSE <- earth(Sale_Price ~ ., data = ames2, degree = 2, pmethod="none", Auto.linpreds=FALSE) cat("\nsummary(ames2.mod.Auto.linpreds.FALSE)\n") print(summary(ames2.mod.Auto.linpreds.FALSE)) cat("\nAuto.linpreds.FALSE$dirs\n") print(ames2.mod.Auto.linpreds.FALSE$dirs) # check that there are no 2s in dirs with Auto.linpreds=FALSE stopifnot(all(ames2.mod.Auto.linpreds.FALSE$dirs != 2)) stopifnot(abs(ames2.mod$rsq - ames2.mod.Auto.linpreds.FALSE$rsq) < 1e-10) # Oct 2021 (earth 5.3.2): issue an error if x colnames are duplicated because of factor expansion. iris.dup <- transform(iris, Species=factor(as.numeric(Species) + 20), Species2=factor(as.numeric(Species))) # TODO $$ Mar 2022: We no longer get the expected error below, # but get it if we manually call try(earth(Sepal.Length ~ ., data=iris.dup)) # expect.err(try(earth(Sepal.Length ~ ., data=iris.dup)), # "Duplicate colname in x (colnames are \"Sepal.Width\", \"Petal.Length\", \"Petal.Width\", \"Species22\", \"Species23\", \"Species22\", \"Species23\")") # expect.err(try(earth(iris.dup[,-1], iris.dup[,1])), # "Duplicate colname in x (colnames are \"Sepal.Width\", \"Petal.Length\", \"Petal.Width\", \"Species22\", \"Species23\", \"Species22\", \"Species23\")") # check that lm has the same problem (but doesn't report it) lm.dup <- lm(Sepal.Length ~ ., data=iris.dup) stopifnot(identical(names(coef(lm.dup)), c("(Intercept)", "Sepal.Width", "Petal.Length", "Petal.Width", "Species22", "Species23", "Species22", "Species23"))) options(options.old) # no more width=1000 source("test.epilog.R") earth/inst/slowtests/test.offset.Rout.save0000644000176200001440000011066014565631517020476 0ustar liggesusers> # test.offset.R > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > > 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)) + 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(org.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 expected error 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 expected error 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 expected error 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 ~ offset(log(Holders)) + Group + Age + day, + 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: Holders Group Age day 136 <1l <25 0.5078125 > 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(org.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: Holders Group Age day 20 <1l <25 0.5078125 > 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(org.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 > par(org.par) > 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 > cat("\nnearth31.weights.offset$modvars:\n") nearth31.weights.offset$modvars: > print.default(earth31.weights.offset$modvars) Girth Girth 1 Height 9999 > > source("test.epilog.R") earth/inst/slowtests/test.ordinal.Rout.save0000644000176200001440000003021014563605665020633 0ustar liggesusers> # test.ordinal.R: ordinal models by way of package "ordinal" and earth's bx matrix > > source("test.prolog.R") > source("check.models.equal.R") > options(warn=1) # print warnings as they occur > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > > # toy data, where response is non-monotonic with input > > input <- 1:20 > > resp <- ifelse(input < 8, "low", ifelse(input > 16, "med", "high")) > resp[8] <- resp[15] <- "med" # add some noise to make it more interesting > resp <- ordered(resp, levels=c("low", "med", "high")) > cat("\nsummary(resp)\n") summary(resp) > print(summary(resp)) low med high 7 6 7 > > dat <- data.frame(input=input, resp=resp) > > library(ordinal) > clm.mod <- clm(resp ~ input, data=dat) > cat("\nsummary(clm.mod)\n") summary(clm.mod) > print(summary(clm.mod)) formula: resp ~ input data: dat link threshold nobs logLik AIC niter max.grad cond.H logit flexible 20 -18.33 42.66 4(0) 8.39e-08 1.8e+03 Coefficients: Estimate Std. Error z value Pr(>|z|) input 0.20637 0.08507 2.426 0.0153 * --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Threshold coefficients: Estimate Std. Error z value low|med 1.5160 0.9898 1.532 med|high 3.1978 1.1894 2.688 > > earth.mod <- earth(resp ~ input, data=dat) > cat("\nsummary(earth.mod)\n") summary(earth.mod) > print(summary(earth.mod)) Call: earth(formula=resp~input, data=dat) low med high (Intercept) -0.06040609 0.071573604 0.9888325 h(12-input) 0.11855099 -0.001430549 -0.1171204 h(input-12) 0.01065990 0.129526227 -0.1401861 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: input Number of terms at each degree of interaction: 1 2 (additive model) GCV RSS GRSq RSq low 0.06968774 0.7839871 0.7235464 0.8276952 med 0.16177956 1.8200200 0.3047331 0.5666619 high 0.15663983 1.7621981 0.3786046 0.6127037 All 0.38810713 4.3662052 0.4732832 0.6717139 > > bx <- earth.mod$bx > bx <- bx[,-1,drop=FALSE] # drop intercept column > bx <- as.data.frame(bx) > bx$resp <- dat$resp # add resp (needed for formula interface below) > > clm.earth <- clm(resp ~ ., data=bx) > cat("\nsummary(clm.earth)\n") summary(clm.earth) > print(summary(clm.earth)) formula: resp ~ `h(input-12)` + `h(12-input)` data: bx link threshold nobs logLik AIC niter max.grad cond.H logit flexible 20 -6.11 20.21 7(0) 7.06e-08 1.2e+03 Coefficients: Estimate Std. Error z value Pr(>|z|) `h(input-12)` -1.4290 0.6555 -2.180 0.0293 * `h(12-input)` -2.4560 1.0300 -2.384 0.0171 * --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Threshold coefficients: Estimate Std. Error z value low|med -12.188 5.047 -2.415 med|high -6.311 2.945 -2.143 > > earth.bx.mod <- earth(resp ~ input, data=bx) > cat("\nsummary(earth.bx.mod)\n") summary(earth.bx.mod) > print(summary(earth.bx.mod)) Call: earth(formula=resp~input, data=bx) low med high (Intercept) -0.06040609 0.071573604 0.9888325 h(12-input) 0.11855099 -0.001430549 -0.1171204 h(input-12) 0.01065990 0.129526227 -0.1401861 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: input Number of terms at each degree of interaction: 1 2 (additive model) GCV RSS GRSq RSq low 0.06968774 0.7839871 0.7235464 0.8276952 med 0.16177956 1.8200200 0.3047331 0.5666619 high 0.15663983 1.7621981 0.3786046 0.6127037 All 0.38810713 4.3662052 0.4732832 0.6717139 > > cat("\n=== models after converting ordered response to numeric ===\n") === models after converting ordered response to numeric === > # i.e. artificially impose equal distance between each level in the response > > dat.numeric.resp <- data.frame(input=input, resp=as.numeric(resp)) > > earth.numeric.resp <- earth(resp ~ input, data=dat.numeric.resp) > cat("\nsummary(earth.numeric.resp)\n") summary(earth.numeric.resp) > print(summary(earth.numeric.resp)) Call: earth(formula=resp~input, data=dat.numeric.resp) coefficients (Intercept) 3.0492386 h(12-input) -0.2356714 h(input-12) -0.1508460 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: input Number of terms at each degree of interaction: 1 2 (additive model) GCV 0.2908756 RSS 3.27235 GRSq 0.6249783 RSq 0.7662607 > > bx.numeric.resp <- earth.numeric.resp$bx > bx.numeric.resp <- bx.numeric.resp[,-1,drop=FALSE] # drop intercept column > bx.numeric.resp <- as.data.frame(bx.numeric.resp) > bx.numeric.resp$resp <- resp # add resp (needed for formula interface below) > # note that for clm() we use the ORIGINAL resp (ordered factor, not numeric) > > clm.earth.numeric.resp <- clm(resp ~ ., data=bx.numeric.resp) > cat("\nsummary(clm.earth.numeric.resp)\n") summary(clm.earth.numeric.resp) > print(summary(clm.earth.numeric.resp)) formula: resp ~ `h(input-12)` + `h(12-input)` data: bx.numeric.resp link threshold nobs logLik AIC niter max.grad cond.H logit flexible 20 -6.11 20.21 7(0) 7.06e-08 1.2e+03 Coefficients: Estimate Std. Error z value Pr(>|z|) `h(input-12)` -1.4290 0.6555 -2.180 0.0293 * `h(12-input)` -2.4560 1.0300 -2.384 0.0171 * --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Threshold coefficients: Estimate Std. Error z value low|med -12.188 5.047 -2.415 med|high -6.311 2.945 -2.143 > > bx.numeric.resp$resp <- as.numeric(resp) > # add resp (needed for formula interface below) > # note that for earth() we use as.mumeric(resp) > # (else we generate a multiple resp model, which we don't want here) > > earth.bx.numeric.resp.mod <- earth(resp ~ input, data=bx.numeric.resp) > cat("\nsummary(earth.bx.numeric.resp.mod)\n") summary(earth.bx.numeric.resp.mod) > print(summary(earth.bx.numeric.resp.mod)) Call: earth(formula=resp~input, data=bx.numeric.resp) coefficients (Intercept) 3.0492386 h(12-input) -0.2356714 h(input-12) -0.1508460 Selected 3 of 4 terms, and 1 of 1 predictors Termination condition: RSq changed by less than 0.001 at 4 terms Importance: input Number of terms at each degree of interaction: 1 2 (additive model) GCV 0.2908756 RSS 3.27235 GRSq 0.6249783 RSq 0.7662607 > > cat("\n== use plots to compare predicted to measured response ==\n") == use plots to compare predicted to measured response == > > # color points using measured response values (the "true" response) > col <- ifelse(resp == "low", "red", ifelse(resp == "med", "pink", "green")) > > par(mfrow = c(3,3), mar = c(4, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > > cat("\nplot measured response\n") plot measured response > > plot(input, resp, main="measured response", + yaxp=c(1,3,2), pch=20, col=col, ylab="measured response") > > legend("topleft", legend=c("low", "med", "high"), + col=c("red", "pink", "green"), pch=20, cex=.8) > > cat("\nplot response predicted by clm model\n") plot response predicted by clm model > > predict.clm <- predict(clm.mod, type="class")$fit > > plot(input, predict.clm, main="clm.mod", + yaxp=c(1,3,2), pch=20, col=col, ylab="predicted response") > > points(input, predict.clm, # black rings around wrong predictions + col=ifelse(predict.clm == as.character(resp), 0, "black")) > > plot.legend <- function() + { + legend("topleft", legend=c("low", "med", "high", "wrong"), + col=c("red", "pink", "green", "black"), pch=c(20,20,20,1), cex=.8) + } > plot.legend() > > empty.plot() > > cat("\nplot response predicted by earth.bx model\n") plot response predicted by earth.bx model > > predict.earth.bx.mod <- predict(earth.bx.mod, type="class") > predict.earth.bx.mod <- ifelse(predict.earth.bx.mod == "low", 1, + ifelse(predict.earth.bx.mod == "med", 2, + 3)) > > plot(input, predict.earth.bx.mod, main="earth.bx.mod", + yaxp=c(1,3,2), pch=20, col=col, ylab="predicted response") > > points(input, predict.earth.bx.mod, # black rings around wrong predictions + col=ifelse(predict.earth.bx.mod == as.numeric(resp), 0, "black"), cex=1) > > plot.legend() > > cat("\nplot response predicted by clm/earth model\n") plot response predicted by clm/earth model > > predict.clm.earth <- predict(clm.earth, type="class")$fit > > plot(input, predict.clm.earth, main="clm.earth", + yaxp=c(1,3,2), pch=20, col=col, ylab="predicted response") > > points(input, predict.clm.earth, # black rings around wrong predictions + col=ifelse(predict.clm.earth == as.character(resp), 0, "black"), cex=1) > > plot.legend() > > empty.plot() > > cat("\nplot response predicted by earth.bx model with as.numeric(resp)\n") plot response predicted by earth.bx model with as.numeric(resp) > > predict.earth.bx.numeric.resp.mod <- predict(earth.bx.numeric.resp.mod) > predict.earth.bx.numeric.resp.mod <- ifelse(predict(earth.bx.numeric.resp.mod) < 1.5, 1, + ifelse(predict(earth.bx.numeric.resp.mod) < 2.5, 2, + 3)) > > plot(input, predict.earth.bx.numeric.resp.mod, main="earth.bx.numeric.resp.mod", + yaxp=c(1,3,2), pch=20, col=col, ylab="predicted response") > > points(input, predict.earth.bx.numeric.resp.mod, # black rings around wrong predictions + col=ifelse(predict.earth.bx.numeric.resp.mod == as.numeric(resp), 0, "black"), cex=1) > > plot.legend() > > cat("\nplot response predicted by clm/earth model with as.numeric(resp)\n") plot response predicted by clm/earth model with as.numeric(resp) > > predict.clm.earth.numeric.resp <- predict(clm.earth.numeric.resp, type="class")$fit > > plot(input, predict.clm.earth.numeric.resp, main="clm.earth.numeric.resp", + yaxp=c(1,3,2), pch=20, col=col, ylab="predicted response") > > points(input, predict.clm.earth.numeric.resp, # black rings around wrong predictions + col=ifelse(predict.clm.earth.numeric.resp == as.character(resp), 0, "black"), cex=1) > > plot.legend() > > empty.plot() > > par(org.par) > > cat("\n=== plotmo plots ===\n") === plotmo plots === > > par(mfrow = c(3,3), mar = c(4, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > > # in the plotmo plots below we use nresp=1 to select the first response level ("low"), > # and predict probabilites by setting type="prob" for predict.clm > plotmo(clm.mod, type="prob", do.par=0, nresp=1, main="clm.mod: is.low") > plotmo(clm.mod, type="prob", do.par=0, nresp=2, main="clm.mod: is.med") > plotmo(clm.mod, type="prob", do.par=0, nresp=3, main="clm.mod: is.high") > > plotmo(earth.mod, do.par=0, nresp=1, main="earth.mod: is.low") > plotmo(earth.mod, do.par=0, nresp=2, main="earth.mod: is.med") > plotmo(earth.mod, do.par=0, nresp=3, main="earth.mod: is.high") > > # plotmo(clm.earth, do.par=0, nresp=1, all2=TRUE) # main="clm.earth: is.low") > # plotmo(clm.earth, do.par=0, nresp=2, all2=TRUE) # main="clm.earth: is.med") > plotmo(clm.earth, do.par=0, nresp=3, all2=TRUE) # main="clm.earth: is.high") plotmo grid: h(input-12) h(12-input) 0 1.5 > > par(org.par) > > cat("\n=== plotmo plots with as.numeric(response) ===\n") === plotmo plots with as.numeric(response) === > > par(mfrow = c(3,3), mar = c(4, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > > plotmo(earth.numeric.resp, do.par=0, all2=TRUE, main="earth.numeric.resp") > empty.plot() > empty.plot() > > plotmo(clm.earth.numeric.resp, do.par=0, nresp=3, all2=2) plotmo grid: h(input-12) h(12-input) 0 1.5 > > par(org.par) > > source("test.epilog.R") earth/inst/slowtests/test.numstab-mfpmath-387.Rout.save0000644000176200001440000015274514563605665022647 0ustar liggesusers# Oct 2020: This is the Rout file generated with "gcc -O2 -mfpmath=387" > # test.numstab.R: Expose numerical instability of earth if any across platforms. > # > # This file was in Oct 2020 created by running earth and plotmo slowtests > # with earth on Win7 built with "--mfpmath=387" (instead of "-mtune=native" > # or "-mfpmath=sse -msse2"). > # Differences between the output in the test suites from standard earth > # were collected and put into this file. > # So this code duplicates code in earth and plotmo slowtests. > # Most but not all differences were captured and put into this file. > > source("test.prolog.R") > > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > library(mda) Loading required package: class Loaded mda 0.5-3 > data(ozone1) > data(trees) > data(etitanic) > > cat("\n#=== from test.full.R ===========================================\n") #=== from test.full.R =========================================== > set.seed(2020) > > PLOT <- TRUE # TRUE to do plots too, FALSE for speed > options.old <- options() > options(warn=1) # print warnings as they occur > > 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) + } > > 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 + } > set.seed(2020) > data(ozone1) > attach(ozone1) > itest <- 1 > > set.seed(2020) > 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 see "Fixed rank deficient bx by removing 2 terms, 7 terms remain" > 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 x2 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 x2 1.7848e+08< 7 1 12 0.0543 0.1330 0.002654 2 x2 1.7848e+08< 8 1 14 0.0451 0.1357 0.002654 2 x2 1.7848e+08< 9 1 16 0.0327 0.1357 0 - reject (no DeltaRsq) RSq changed by less than 0.001 at 15 terms, 9 terms used (DeltaRSq 0) After forward pass GRSq 0.033 RSq 0.136 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 1 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 > > # 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) > > set.seed(2020) > cat("Auto.linpreds=TRUE pmethod=\"none\":\n") Auto.linpreds=TRUE pmethod="none": > # trace==2 so we see "Fixed rank deficient bx by removing terms" > # TODO why are we getting the rank deficient message? > 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 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, 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.433296 h(x1- -0.9549) -1.423639 h(-0.9549-x1) 7.344119 h(x3- -0.0781) -3.590121 h(-0.0781-x3) -5.326988 h(x1- -0.9549) * x4 -1.258111 h(x1- -0.9549) * x3 0.881005 h(-0.9549-x1) * x3 30.606021 h(x1- -0.216) 1.862792 x1 * 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 > 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)))) > > set.seed(2020) > 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 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, 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("\n#=== from test.weights.R ===========================================\n") #=== from test.weights.R =========================================== > set.seed(2020) > > 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") > > a21.noweights <- earth(y~., data=data, # no weights for comparison + minspan=1, endspan=1, penalty=-1, thresh=1e-8, trace=-1) > print(summary(a21.noweights)) Call: earth(formula=y~., data=data, trace=-1, minspan=1, endspan=1, penalty=-1, thresh=1e-08) coefficients (Intercept) 5.545 h(x1-3) 0.475 h(5-x1) -0.515 h(x1-5) -0.940 h(x1-7) -0.050 h(x1-8) 0.010 h(6-x2) -0.495 h(x2-6) 1.485 Selected 8 of 8 terms, and 2 of 2 predictors Termination condition: Reached maximum RSq 1.0000 at 8 terms Importance: x1, x2 Number of terms at each degree of interaction: 1 7 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > 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) > print(summary(a10)) Call: earth(formula=y~., data=data, weights=weights, trace=-1, minspan=1, endspan=1, penalty=-1, thresh=1e-08) coefficients (Intercept) 5.070 h(5-x1) -0.990 h(x1-5) -0.465 h(x1-8) 0.010 h(x2-3) 0.475 h(6-x2) -0.020 h(x2-6) 1.010 h(x2-7) -0.050 Selected 8 of 8 terms, and 2 of 2 predictors Termination condition: Reached maximum RSq 1.0000 at 8 terms Importance: x1, x2 Weights: 1, 1, 1, 1, 0.5, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 7 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > > cat("\n#=== from test.glm.R ===========================================\n") #=== from test.glm.R =========================================== > > 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 7 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 4.1155e+005 0.2739 min 15 4 3.0548e+007 0.2445 15 5 1.9834e+006 0.2724 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 7.8586e+005 0.2736 15 14 5.964e+006 0.2685 15 15 4.2448e+006 0.2702 14 2 2.9403e+007 0.2456 min 14 3 4.0992e+005 0.2739 min 14 4 3.0578e+007 0.2444 14 5 1.9758e+006 0.2724 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 7.8286e+005 0.2736 14 14 5.9908e+006 0.2685 14 15 4.2486e+006 0.2702 13 2 2.9318e+007 0.2453 min 13 4 3.4284e+007 0.2404 13 5 1.9771e+006 0.2720 min 13 6 2.0927e+007 0.2535 13 7 2.5764e+007 0.2488 13 8 6.4562e+006 0.2676 13 9 7.283e+006 0.2668 13 11 1.5187e+007 0.2591 13 12 1.4282e+007 0.2600 13 13 7.6983e+005 0.2732 min 13 14 1.6727e+007 0.2576 13 15 3.4888e+007 0.2398 12 2 2.9426e+007 0.2444 min 12 4 3.7551e+007 0.2365 12 5 1.982e+006 0.2712 min 12 6 2.1198e+007 0.2525 12 7 2.7686e+007 0.2461 12 8 6.4937e+006 0.2668 12 9 7.059e+006 0.2663 12 11 1.8035e+007 0.2556 12 12 1.855e+007 0.2551 12 14 1.673e+007 0.2568 12 15 3.4909e+007 0.2391 11 2 4.1892e+007 0.2303 min 11 4 4.4477e+007 0.2278 11 6 2.0636e+007 0.2511 min 11 7 2.7648e+007 0.2442 11 8 5.1374e+006 0.2662 min 11 9 7.0891e+006 0.2643 11 11 1.9442e+007 0.2522 11 12 4.2683e+007 0.2295 11 14 1.7813e+007 0.2538 11 15 4.0764e+007 0.2314 10 2 1.9259e+008 0.0780 min 10 4 4.3937e+007 0.2233 min 10 6 2.3667e+007 0.2431 min 10 7 2.2527e+007 0.2442 min 10 9 1.1557e+007 0.2549 min 10 11 1.5895e+007 0.2507 10 12 4.1804e+007 0.2254 10 14 1.7356e+007 0.2493 10 15 4.0292e+007 0.2268 9 2 1.9815e+008 0.0612 min 9 4 4.6123e+007 0.2098 min 9 6 2.1283e+007 0.2341 min 9 7 1.6444e+007 0.2389 min 9 11 9.1512e+006 0.2460 min 9 12 4.5701e+007 0.2103 9 14 1.8792e+007 0.2366 9 15 4.2341e+007 0.2135 8 2 1.9213e+008 0.0582 min 8 4 3.6978e+007 0.2098 min 8 6 2.2769e+007 0.2237 min 8 7 7.3146e+006 0.2388 min 8 12 4.2428e+007 0.2045 8 14 1.7261e+007 0.2291 8 15 3.8504e+007 0.2083 7 2 2.0358e+008 0.0398 min 7 4 5.1358e+007 0.1886 min 7 6 2.259e+007 0.2167 min 7 12 3.956e+007 0.2002 7 14 1.7694e+007 0.2215 min 7 15 3.9765e+007 0.2000 6 2 1.9363e+008 0.0322 min 6 4 4.834e+007 0.1743 min 6 6 2.7208e+007 0.1949 min 6 12 3.6257e+007 0.1861 6 15 6.052e+007 0.1624 5 2 1.6654e+008 0.0321 min 5 4 5.3902e+007 0.1422 min 5 12 4.0495e+007 0.1553 min 5 15 4.6141e+007 0.1498 4 2 1.4973e+008 0.0090 min 4 4 1.3585e+007 0.1421 min 4 15 3.1228e+007 0.1248 3 2 1.4521e+008 0.0001 min 3 15 3.2522e+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.1338 0.1421 0.0278 3 1 2 15 4 0.1431 0.1553 0.0093 3 1 2 4 15 5 0.1793 0.1949 0.0362 3 1 2 4 12 15 6 0.2026 0.2215 0.0233 4 1 2 4 6 12 15 7 0.2165 0.2388 0.0139 4 1 2 4 6 12 14 15 8 0.2201 0.2460 0.0036 4 1 2 4 6 7 12 14 15 9 0.2256 0.2549 0.0055 4 1 2 4 6 7 11 12 14 15 10 0.2336 0.2662 0.0080 5 1 2 4 6 7 9 11 12 14 15 chosen 11 0.2351 0.2712 0.0015 5 1 2 4 6 7 8 9 11 12 14 15 12 0.2334 0.2732 -0.0017 5 1 2 4 5 6 7 8 9 11 12 14 15 13 0.2304 0.2739 -0.0030 5 1 2 4 5 6 7 8 9 11 12 13 14 15 14 0.2270 0.2743 -0.0034 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 11 of 15 terms, and 5 of 5 preds After pruning pass GRSq 0.235 RSq 0.271 glm y[1046,1]: y1 1 1 2 2 3 1 ... 2 1046 2 glm weights: NULL GLM y1 devratio 0.32 dof 1035/1045 iters 2 glm y[1046,1]: y2 1 841 2 0 3 4 ... 900 1046 841 glm weights: NULL GLM y2 devratio 0.27 dof 1035/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.87118586 2022.0223 pclass3rd -0.24639972 -1720.7486 survived -0.52209649 -313.2841 h(sibsp-1) 0.01624482 -159.5522 h(parch-1) -0.11109875 -995.9459 h(parch-2) 0.05537183 2458.2205 pclass2nd * h(1-parch) 0.09821900 1359.2200 pclass2nd * h(2-parch) -0.05519696 -1055.2056 pclass3rd * h(parch-2) -0.03777698 -2620.2967 pclass3rd * h(2-parch) 0.13171785 311.8731 pclass3rd * h(parch-1) 0.04818545 1443.0507 GLM coefficients y1 y2 (Intercept) 1.87118586 2022.0223 pclass3rd -0.24639972 -1720.7486 survived -0.52209649 -313.2841 h(sibsp-1) 0.01624482 -159.5522 h(parch-1) -0.11109875 -995.9459 h(parch-2) 0.05537183 2458.2205 pclass2nd * h(1-parch) 0.09821900 1359.2200 pclass2nd * h(2-parch) -0.05519696 -1055.2056 pclass3rd * h(parch-2) -0.03777698 -2620.2967 pclass3rd * h(2-parch) 0.13171785 311.8731 pclass3rd * h(parch-1) 0.04818545 1443.0507 GLM y1 deviance residuals: Min 1Q Median 3Q Max -0.9044667 -0.3369144 0.1117782 0.1409891 0.9602237 GLM y1 coefficients (family gaussian, link identity) Estimate Std. Error t value Pr(>|t|) (Intercept) 1.87118586 0.03058203 61.18579 < 2e-16 pclass3rd -0.24639972 0.10657574 -2.31197 0.020975 h(parch-2) 0.05537183 0.14776100 0.37474 0.707931 survived -0.52209649 0.02764612 -18.88498 < 2e-16 pclass3rd * h(parch-2) -0.03777698 0.19976891 -0.18910 0.850049 pclass3rd * h(2-parch) 0.13171785 0.05515850 2.38799 0.017119 h(sibsp-1) 0.01624482 0.02402220 0.67624 0.499038 pclass3rd * h(parch-1) 0.04818545 0.13119405 0.36728 0.713482 h(parch-1) -0.11109875 0.06110990 -1.81802 0.069351 pclass2nd * h(1-parch) 0.09821900 0.12909899 0.76080 0.446948 pclass2nd * h(2-parch) -0.05519696 0.06625249 -0.83313 0.404963 GLM y1 dispersion parameter for gaussian family taken to be 0.1606984 GLM y2 deviance residuals: Min 1Q Median 3Q Max -1733.0223 -501.0223 -187.7382 299.9801 4691.2618 GLM y2 coefficients (family gaussian, link identity) Estimate Std. Error t value Pr(>|t|) (Intercept) 2022.02230 64.74562 31.23026 < 2.22e-16 pclass3rd -1720.74861 225.63289 -7.62632 5.4561e-14 h(parch-2) 2458.22048 312.82673 7.85809 9.7355e-15 survived -313.28406 58.52996 -5.35254 1.0679e-07 pclass3rd * h(parch-2) -2620.29668 422.93336 -6.19553 8.3706e-10 pclass3rd * h(2-parch) 311.87310 116.77677 2.67068 0.0076885 h(sibsp-1) -159.55220 50.85771 -3.13723 0.0017537 pclass3rd * h(parch-1) 1443.05073 277.75263 5.19545 2.4589e-07 h(parch-1) -995.94592 129.37656 -7.69804 3.2160e-14 pclass2nd * h(1-parch) 1359.21996 273.31715 4.97305 7.7115e-07 pclass2nd * h(2-parch) -1055.20558 140.26401 -7.52300 1.1597e-13 GLM y2 dispersion parameter for gaussian family taken to be 720277.3 GLM (family gaussian, link identity): nulldev df dev df devratio AIC iters converged y1 2.44077e+02 1045 1.66323e+02 1035 0.319 1069 2 1 y2 1.02296e+09 1045 7.45487e+08 1035 0.271 17090 2 1 Earth selected 11 of 15 terms, and 5 of 5 predictors Termination condition: Reached nk 21 Importance: pclass3rd, pclass2nd, parch, survived, sibsp Number of terms at each degree of interaction: 1 5 5 Earth GCV RSS GRSq RSq y1 0.17 166 0.2847494 0.3185625 y2 749499.58 745486964 0.2350858 0.2712468 All 749499.75 745487130 0.2350858 0.2712468 > > cat("\n#=== from test.plotmo.R ===========================================\n") #=== from test.plotmo.R =========================================== > > # check various types of predictors with grid.func and ndiscrete > > varied.type.data <- data.frame( + y = 1:13, + num = c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5), # 7 unique values (but one is non integral) + int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L), # 8 unique values + bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T), + date = as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")), + ord = ordered(c("ord3", "ord3", "ord3", + "ord1", "ord2", "ord3", + "ord1", "ord2", "ord3", + "ord1", "ord1", "ord1", "ord1"), + levels=c("ord1", "ord3", "ord2")), + fac = as.factor(c("fac1", "fac1", "fac1", + "fac2", "fac2", "fac2", + "fac3", "fac3", "fac3", + "fac1", "fac2", "fac3", "fac3")), + str = c("str1", "str1", "str1", # will be treated like a factor + "str2", "str2", "str2", + "str3", "str3", "str3", + "str3", "str3", "str3", "str3")) > > varied.type.earth <- earth(y ~ ., data = varied.type.data, thresh=0, penalty=-1, trace=1) x[13,10] with colnames num int boolTRUE date ord.L ord.Q facfac2 facfac3 strstr2... y[13,1] with colname y, and values 1, 2, 3, 4, 5, 6, 7, 8, 9, 10... Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18 Reached maximum RSq 1.0000 at 19 terms, 13 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Prune backward penalty -1 nprune null: selected 13 of 13 terms, and 9 of 10 preds After pruning pass GRSq 1 RSq 1 > print(summary(varied.type.earth)) Call: earth(formula=y~., data=varied.type.data, trace=1, thresh=0, penalty=-1) coefficients (Intercept) 9.5964912 boolTRUE -2.0473684 ord.L 0.4986964 ord.Q 0.0859470 facfac2 -4.4157895 facfac3 -3.1526316 strstr2 3.2526316 h(4-num) 1.4105263 h(num-4) -0.3157895 h(4-int) 2.1157895 h(int-4) 0.3421053 h(17749-date) -3.8210526 h(date-17749) 1.4368421 Selected 13 of 13 terms, and 9 of 10 predictors Termination condition: Reached maximum RSq 1.0000 at 13 terms Importance: date, facfac2, facfac3, int, strstr2, num, boolTRUE, ord.L, ... Number of terms at each degree of interaction: 1 12 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > > cat("\n#=== from test.plotmo.args.R ===========================================\n") #=== from test.plotmo.args.R =========================================== > set.seed(2020) > > oz2 <- ozone1[1:40,] > set.seed(2015) > a <- earth(O3~temp+wind, dat=oz2, deg=2, nk=21, ncr=3, nfo=3, varmod.me="lm") > print(summary(a)) Call: earth(formula=O3~temp+wind, data=oz2, degree=2, nfold=3, ncross=3, varmod.method="lm", nk=21) coefficients (Intercept) 3.8636364 h(temp-42) 0.1581028 Selected 2 of 13 terms, and 1 of 2 predictors Termination condition: Reached nk 21 Importance: temp, wind-unused Number of terms at each degree of interaction: 1 1 (additive model) GCV 4.813872 RSS 160.332 GRSq 0.1971602 RSq 0.2967894 CVRSq -0.04034235 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 2.11 sd 0.33 nvars 1.22 sd 0.44 CVRSq sd MaxErr sd -0.04 0.285 8.7 4.68 varmod: method "lm" min.sd 0.253 iter.rsq 0.069 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 1.0479440 0.855721 82 O3 0.2703642 0.161551 60 mean smallest largest ratio 95% prediction interval 9.93681 8.202579 12.72666 1.551544 68% 80% 90% 95% response values in prediction interval 78 92 100 100 > plotmo(a, caption.col=3, caption.font=2, grid.col="pink", + level=.8, SHOWCALL=TRUE) plotmo grid: temp wind 53.5 4 > > cat("\n#=== from test.plotmo3.R ===========================================\n") #=== from test.plotmo3.R =========================================== > set.seed(2020) > > # basic tests of plotmo on abbreviated titanic data > > get.tita <- function() + { + tita <- etitanic + pclass <- as.character(tita$pclass) + # change the order of the factors so not alphabetical + pclass[pclass == "1st"] <- "first" + pclass[pclass == "2nd"] <- "class2" + pclass[pclass == "3rd"] <- "classthird" + tita$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) + # log age is so we have a continuous predictor even when model is age~. + set.seed(2015) + tita$logage <- log(tita$age) + rnorm(nrow(tita)) + tita$parch <- NULL + # by=12 gives us a small fast model with an additive and a interaction term + tita[seq(1, nrow(etitanic), by=12), ] + } > tita <- get.tita() > # tita[,4] is age > set.seed(2020) > mod.earth.tita.age <- earth(tita[,-4], tita[,4], degree=2, nfold=3, ncross=3, trace=.5, varmod.method="lm") Model with pmethod="backward": GRSq 0.335 RSq 0.512 nterms 6 CV fold 1.1 CVRSq -0.047 n.oof 58 34% n.infold.nz 58 100% n.oof.nz 30 100% CV fold 1.2 CVRSq -0.022 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 1.3 CVRSq -0.045 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 2.1 CVRSq 0.133 n.oof 58 34% n.infold.nz 58 100% n.oof.nz 30 100% CV fold 2.2 CVRSq 0.338 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 2.3 CVRSq 0.149 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 3.1 CVRSq 0.419 n.oof 58 34% n.infold.nz 58 100% n.oof.nz 30 100% CV fold 3.2 CVRSq 0.107 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 3.3 CVRSq -0.048 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV all CVRSq 0.109 n.infold.nz 88 100% varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) tita[, 4] 1 1.2 0.00 13 -0.0158 2 1.1 3.74 12 -0.0086 3 1.1 1.69 12 -0.0118 4 1.1 0.75 12 -0.0104 > cat("\nsummary(mod.earth.tita.age)\n") summary(mod.earth.tita.age) > print(summary(mod.earth.tita.age)) Call: earth(x=tita[,-4], y=tita[,4], trace=0.5, degree=2, nfold=3, ncross=3, varmod.method="lm") coefficients (Intercept) 25.664968 pclassfirst 9.028974 h(sibsp-1) -12.096706 h(1.68119-logage) -7.502937 sexmale * h(logage-2.48137) 5.062358 sibsp * h(logage-1.68119) 3.280947 Selected 6 of 14 terms, and 4 of 6 predictors Termination condition: Reached nk 21 Importance: logage, sexmale, pclassclassthird-unused, sibsp, pclassfirst, ... Number of terms at each degree of interaction: 1 3 2 GCV 174.7603 RSS 11022.31 GRSq 0.335155 RSq 0.5124778 CVRSq 0.1092556 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 4.00 sd 1.00 nvars 3.22 sd 0.97 CVRSq sd MaxErr sd 0.109 0.173 41.4 34.3 varmod: method "lm" min.sd 1.52 iter.rsq 0.000 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 15.6092331 2.77993 18 tita[, 4] -0.0129731 0.0843626 650 mean smallest largest ratio 95% prediction interval 59.62756 58.24825 61.60404 1.057612 68% 80% 90% 95% response values in prediction interval 84 91 97 99 > plotmo(mod.earth.tita.age, SHOWCALL=TRUE) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > > set.seed(2020) > mod.earth.sex <- earth(sex~., data=tita, degree=2, nfold=3, ncross=3, varmod.method="earth", glm=list(family=binomial)) > cat("\nsummary(mod.earth.sex)\n") summary(mod.earth.sex) > print(summary(mod.earth.sex)) Call: earth(formula=sex~., data=tita, glm=list(family=binomial), degree=2, nfold=3, ncross=3, varmod.method="earth") GLM coefficients male (Intercept) 2.2150018 survived * age -0.1784818 pclassclassthird * h(31-age) -0.1140654 survived * h(age-31) 0.4396082 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 111.559 87 67.1647 84 0.398 75.16 5 1 Earth selected 4 of 12 terms, and 3 of 6 predictors Termination condition: Reached nk 21 Importance: survived, age, pclassclassthird, pclassfirst-unused, ... Number of terms at each degree of interaction: 1 0 3 Earth GCV 0.1413927 RSS 10.15497 GRSq 0.374517 RSq 0.4777105 CVRSq -0.07918303 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.67 sd 1.22 nvars 2.89 sd 1.17 CVRSq sd ClassRate sd MaxErr sd AUC sd MeanDev sd CalibInt -0.079 0.617 0.745 0.08 -1 0.951 0.726 0.137 2.54 2.74 0.272 sd CalibSlope sd 0.615 0.632 0.585 varmod: method "earth" min.sd 0.0408 iter.rsq 0.249 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 0.9095818 0.102755 11 h(0.428854-male) -1.3805358 0.363514 26 h(male-0.428854) -1.2913970 0.244534 19 mean smallest largest ratio 95% prediction interval 1.600401 0.9672622 3.565495 3.686172 68% 80% 90% 95% response values in prediction interval 90 92 94 94< > plotmo(mod.earth.sex, SHOWCALL=TRUE) > > cat("\n#=== from test.unusual.vars.R ===========================================\n") #=== from test.unusual.vars.R =========================================== > set.seed(2020) > > vdata <- data.frame( + resp = 1:13, + bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T), + ord = ordered(c("ORD1", "ORD1", "ORD1", + "ORD1", "ORD1", "ORD1", + "ORD3", "ORD3", "ORD3", + "ORD2", "ORD2", "ORD2", "ORD2"), + levels=c("ORD1", "ORD3", "ORD2")), + fac = as.factor(c("FAC1", "FAC1", "FAC1", + "FAC2", "FAC2", "FAC2", + "FAC3", "FAC3", "FAC3", + "FAC1", "FAC2", "FAC3", "FAC3")), + str = c("STR1", "STR1", "STR1", # WILL BE TREATED LIKE A FACTOR + "STR2", "STR2", "STR2", + "STR3", "STR3", "STR3", + "STR3", "STR3", "STR3", "STR3"), + num = c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5), # 7 unique values (but one is non integral) + sqrt_num = sqrt(c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5)), + int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L), # 8 unique values + date = as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")), + date_num = as.numeric(as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")))) > > vdata$off <- (1:nrow(vdata)) / nrow(vdata) > > resp2 <- 13:1 > > vweights <- rep(1, length.out=nrow(vdata)) > vweights[1] <- 2 > > set.seed(2020) > lognum.bool.ord.off <- earth(resp ~ log(num) + bool + ord + offset(off), degree=2, weights=vweights, + data=vdata, pmethod="none", varmod.method="lm", + nfold=2, ncross=3, + trace=1) x[13,4] with colnames log(num) boolTRUE ord.L ord.Q y[13,1] with colname resp, and values 0.9231, 1.846, 2.769, 3.692, ... weights[13]: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Forward pass term 1, 2, 4, 6, 8 GRSq -Inf at 7 terms, 5 terms used After forward pass GRSq -in RSq 0.966 Prune none penalty 3 nprune null: selected 5 of 5 terms, and 3 of 4 preds After pruning pass GRSq -0.732 RSq 0.952 CV fold 1.1 CVRSq 0.708 n.oof 6 54% n.infold.nz 6 100% n.oof.nz 7 100% CV fold 1.2 CVRSq 0.823 n.oof 7 46% n.infold.nz 7 100% n.oof.nz 6 100% CV fold 2.1 CVRSq 0.461 n.oof 6 54% n.infold.nz 6 100% n.oof.nz 7 100% CV fold 2.2 CVRSq 0.816 n.oof 7 46% n.infold.nz 7 100% n.oof.nz 6 100% CV fold 3.1 CVRSq 0.559 n.oof 6 54% n.infold.nz 6 100% n.oof.nz 7 100% CV fold 3.2 CVRSq 0.698 n.oof 7 46% n.infold.nz 7 100% n.oof.nz 6 100% CV all CVRSq 0.677 n.infold.nz 13 100% varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) resp 1 2.3 0.00 0.98 0.050 2 2.4 3.54 0.96 0.053 3 2.4 0.53 0.96 0.053 > print(summary(lognum.bool.ord.off)) Call: earth(formula=resp~log(num)+bool+ord+offset(off), data=vdata, weights=vweights, pmethod="none", trace=1, degree=2, nfold=2, ncross=3, varmod.method="lm") coefficients (Intercept) 7.384615 h(-7.85046e-17-ord.L) -9.171908 h(ord.L- -7.85046e-17) 4.568998 log(num) * h(-7.85046e-17-ord.L) 3.100021 boolTRUE * h(-7.85046e-17-ord.L) 1.571761 Selected 5 of 5 terms, and 3 of 4 predictors (pmethod="none") Termination condition: GRSq -Inf at 5 terms Importance: ord.L, log(num), boolTRUE, ord.Q-unused Offset: off with values 0.07692308, 0.1538462, 0.2307692, 0.3076923, 0.3... Weights: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 2 2 GCV 28.70012 RSS 8.830806 GRSq -0.7319038 RSq 0.9518916 CVRSq 0.6774271 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 2.33 sd 0.52 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.677 0.143 3.77 3.77 varmod: method "lm" min.sd 0.167 iter.rsq 0.076 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 1.20311748 0.484791 40 resp 0.06662794 0.0699109 105 mean smallest largest ratio 95% prediction interval 6.544853 4.971048 7.749802 1.558988 68% 80% 90% 95% response values in prediction interval 92 100 100 100 > > cat("\n#=== from test.caret.R ===========================================\n") #=== from test.caret.R =========================================== > set.seed(2020) > > library(caret) Loading required package: lattice Loading required package: ggplot2 > set.seed(2015) > a.bag3 <- bagEarth(survived~., data=etitanic, degree=2, B=3, trace=1) x[1046,7] with colnames pclass1st pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname subY, and values 0, 0, 0, 0, 1, 1, 1, 0, 0, 0,... weights: no weights (because all weights equal) Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.434 RSq 0.473 Prune backward penalty 3 nprune null: selected 10 of 16 terms, and 5 of 7 preds After pruning pass GRSq 0.442 RSq 0.466 x[1046,7] with colnames pclass1st pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname subY, and values 0, 0, 1, 1, 1, 0, 0, 0, 1, 1,... weights: no weights (because all weights equal) Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.385 RSq 0.434 Prune backward penalty 3 nprune null: selected 12 of 18 terms, and 6 of 7 preds After pruning pass GRSq 0.402 RSq 0.433 x[1046,7] with colnames pclass1st pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname subY, and values 1, 1, 0, 1, 1, 1, 0, 1, 0, 0,... weights: no weights (because all weights equal) Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.451 RSq 0.487 Prune backward penalty 3 nprune null: selected 13 of 15 terms, and 6 of 7 preds After pruning pass GRSq 0.456 RSq 0.487 > print(a.bag3) Call: bagEarth.formula(formula = survived ~ ., data = etitanic, B = 3, degree = 2, trace = 1) Data: # variables: 7 # samples: 1046 case weights used B: 3 > plotmo(a.bag3, clip=F, caption="bagEarth, etitanic", trace=1, SHOWCALL=TRUE) stats::predict(bagEarth.object, data.frame[3,7], type="response") stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead assuming "survived" in the model.frame is the response, because terms(object) did not return the terms assuming "survived" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(survived ~ ., data=call$data, na.action="na.fail") plotmo grid: pclass1st pclass2nd pclass3rd sexmale age sibsp parch 0 0 0 1 28 0 0 > plotres(a.bag3, clip=F, trace=1, SHOWCALL=TRUE) stats::residuals(object=bagEarth.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(bagEarth.object, data.frame[3,7], type="response", clip=FALSE) stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead assuming "survived" in the model.frame is the response, because terms(object) did not return the terms assuming "survived" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(survived ~ ., data=call$data, na.action="na.fail") assuming "survived" in the model.frame is the response, because terms(object) did not return the terms training rsq 0.44 > > # Following commented out because too slow > # > # cat("\n#=== from test.parsnip.R ===========================================\n") > # set.seed(2020) > # > # cat("loading parsnip libraries\n") # these libraries take several seconds to load > # library(tidymodels) > # library(timetk) > # library(lubridate) > # cat("loaded parsnip libraries\n") > # cat("parsnip version:", as.character(packageVersion("parsnip")[[1]]), "\n") > # > # vdata <- data.frame( > # resp = 1:23, > # bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T, F, F, T, T, T, T, T, T, T, T), > # ord = ordered(c("ORD1", "ORD1", "ORD1", > # "ORD1", "ORD1", "ORD1", > # "ORD1", "ORD3", "ORD1", > # "ORD2", "ORD2", "ORD2", "ORD2", > # "ORD2", "ORD2", "ORD2", > # "ORD3", "ORD3", "ORD3", > # "ORD2", "ORD2", "ORD2", "ORD2"), > # levels=c("ORD1", "ORD3", "ORD2")), > # fac = as.factor(c("FAC1", "FAC1", "FAC1", > # "FAC2", "FAC2", "FAC2", > # "FAC3", "FAC1", "FAC1", > # "FAC1", "FAC2", "FAC2", "FAC2", > # "FAC2", "FAC2", "FAC2", > # "FAC3", "FAC3", "FAC3", > # "FAC1", "FAC3", "FAC3", "FAC3")), > # str = c("STR1", "STR1", "STR1", # WILL BE TREATED LIKE A FACTOR > # "STR1", "STR1", "STR1", > # "STR2", "STR2", "STR2", > # "STR3", "STR3", "STR2", "STR3", > # "STR2", "STR3", "STR2", > # "STR3", "STR3", "STR3", > # "STR3", "STR3", "STR3", "STR3"), > # num = c(1, 9, 2, 3, 14, 5, 6, 4, 5, 6.5, 3, 6, 5, > # 3, 4, 5, 6, 4, 5, 16.5, 3, 16, 15), > # sqrt_num = sqrt( > # c(1, 9, 2, 3, 14, 5, 6, 4, 5, 6.5, 3, 6, 5, > # 3, 4, 5, 6, 4, 5, 16.5, 3, 16, 15)), > # int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L, > # 13L, 14L, 3L, 13L, 5L, 13L, 16L, 17L, 18L, 11L), > # date = as.Date( > # c("2018-08-01", "2018-08-02", "2018-08-03", > # "2018-08-04", "2018-08-05", "2018-08-06", > # "2018-08-07", "2018-08-08", "2018-08-08", > # "2018-08-10", "2018-08-10", "2018-08-11", "2018-08-11", > # "2018-08-11", "2018-08-12", "2018-08-13", > # "2018-08-10", "2018-08-15", "2018-08-17", > # "2018-08-04", "2018-08-19", "2018-08-03", "2018-08-18")), > # date_num = as.numeric(as.Date( > # c("2018-08-01", "2018-08-02", "2018-08-03", > # "2018-08-04", "2018-08-05", "2018-08-06", > # "2018-08-07", "2018-08-08", "2018-08-08", > # "2018-08-10", "2018-08-10", "2018-08-11", "2018-08-11", > # "2018-08-11", "2018-08-12", "2018-08-13", > # "2018-08-10", "2018-08-15", "2018-08-17", > # "2018-08-04", "2018-08-19", "2018-08-03", "2018-08-18")))) > # > # set.seed(2020) > # splits <- initial_time_split(vdata, prop=.9) > # > # cat("===m750a first example===\n") > # set.seed(2020) > # m750a <- m4_monthly %>% > # filter(id == "M750") %>% > # select(-id) > # print(m750a) # a tibble > # set.seed(2020) > # splits_a <- initial_time_split(m750a, prop = 0.9) > # earth_m750a <- earth(log(value) ~ as.numeric(date) + month(date, label = TRUE), data = training(splits_a), degree=2) > # print(summary(earth_m750a)) > > source("test.epilog.R") earth/inst/slowtests/earth.times.txt0000644000176200001440000003563713730233362017405 0ustar liggesusersTiming test results on pre-release earth version 5.2.0 Sep 15, 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 nofast nobeta minspan1 allowed weights cv5 pmethcv | earth mars nofast minspan1 weights pmethcv | | 5 1 5 0.005 | 0.2 1.0 1.0 1.0 1.0 3 5.0 23.3 | 0.69 0.69 0.69 0.70 0.70 0.69 5 2 4 0.005 | 0.2 1.0 1.0 1.0 1.0 5 5.0 22.4 | 0.69 0.69 0.69 0.69 0.69 0.69 5 3 4 0.006 | 0.2 0.9 0.9 1.0 1.0 5 4.8 21.5 | 0.69 0.69 0.69 0.69 0.69 0.69 | | 21 1 12 0.007 | 0.5 1.0 1.0 1.1 1.1 46 5.7 67.3 | 0.77 0.77 0.77 0.78 0.77 0.77 21 2 12 0.014 | 1.3 1.0 1.1 1.1 1.0 83 5.6 44.2 | 0.79 0.78 0.79 0.79 0.78 0.76 21 3 15 0.016 | 1.2 1.0 1.1 1.2 1.0 89 5.5 38.9 | 0.79 0.78 0.79 0.79 0.78 0.77 | | 51 1 16 0.011 | 1.2 1.0 1.1 1.3 1.0 277 6.2 96.2 | 0.78 0.77 0.78 0.80 0.78 0.78 51 2 25 0.025 | 5.0 1.8 1.2 0.9 1.0 142 5.4 65.6 | 0.81 0.80 0.82 0.80 0.79 0.72 51 3 27 0.050 | 3.5 1.5 1.2 1.2 1.0 303 5.1 48.4 | 0.82 0.82 0.82 0.80 0.80 0.76 ==== robot arm 1000 x 20 ======== nk degree earth earth | execution time ratio: | grsq: nterms time | mars nofast nobeta minspan1 allowed weights cv5 pmethcv | earth mars nofast minspan1 weights pmethcv | | 5 1 5 0.013 | 0.2 0.8 0.8 0.9 0.8 20 3.5 12.3 | 0.54 0.54 0.54 0.54 0.54 0.54 5 2 5 0.012 | 0.4 1.0 1.1 1.0 1.1 34 4.5 14.2 | 0.54 0.54 0.54 0.54 0.54 0.54 5 3 5 0.012 | 0.4 1.1 1.0 1.2 1.1 35 4.6 14.1 | 0.54 0.54 0.54 0.54 0.54 0.54 | | 21 1 13 0.022 | 0.7 0.9 1.0 1.0 0.9 283 4.5 27.0 | 0.78 0.77 0.78 0.78 0.78 0.77 21 2 20 0.066 | 1.2 1.0 1.1 1.2 1.0 328 4.8 15.5 | 0.88 0.88 0.88 0.88 0.88 0.88 21 3 21 0.093 | 1.4 1.0 1.1 1.2 1.0 311 4.9 12.9 | 0.89 0.88 0.89 0.89 0.89 0.89 | | 51 1 13 0.025 | 2.9 1.0 1.1 1.3 1.0 380 6.6 36.3 | 0.78 0.77 0.78 0.78 0.78 0.77 51 2 28 0.103 | 4.8 2.7 1.1 1.2 1.0 438 5.1 18.9 | 0.93 0.94 0.95 0.92 0.93 0.93 51 3 38 0.345 | 3.1 1.6 1.2 1.2 1.0 648 4.7 13.4 | 0.97 0.96 0.97 0.97 0.97 0.97 Timing Test Results On Earth Version 5.1.2 (released version, not locally compiled) ----------------------------------------------------------------------------------- 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 nofast nobeta minspan1 allowed weights cv5 pmethcv | earth mars nofast minspan1 weights pmethcv | | 5 1 5 0.004 | 0.3 1.0 1.0 0.9 0.9 3 6.2 30.7 | 0.69 0.69 0.69 0.70 0.70 0.69 5 2 4 0.004 | 0.4 1.0 1.0 1.0 1.0 7 6.4 30.9 | 0.69 0.69 0.69 0.69 0.69 0.69 5 3 4 0.004 | 0.3 1.1 1.1 1.1 1.1 6 7.1 33.8 | 0.69 0.69 0.69 0.69 0.69 0.69 | | 21 1 12 0.006 | 0.6 1.0 1.0 1.0 1.0 55 6.6 81.7 | 0.77 0.77 0.77 0.78 0.77 0.77 21 2 12 0.012 | 1.4 1.0 1.1 1.1 1.0 92 6.0 49.8 | 0.79 0.78 0.79 0.79 0.78 0.76 21 3 15 0.015 | 1.3 1.0 1.1 1.2 1.0 98 6.0 43.5 | 0.79 0.78 0.79 0.79 0.78 0.77 | | 51 1 16 0.009 | 1.4 1.0 1.0 1.3 1.0 313 6.8 109.7 | 0.78 0.77 0.78 0.80 0.78 0.78 51 2 25 0.024 | 5.2 1.8 1.2 0.9 1.1 148 5.6 69.2 | 0.81 0.80 0.82 0.80 0.79 0.72 51 3 27 0.048 | 3.6 1.5 1.2 1.2 1.1 314 5.3 50.1 | 0.82 0.82 0.82 0.80 0.80 0.76 ==== robot arm 1000 x 20 ======== nk degree earth earth | execution time ratio: | grsq: nterms time | mars nofast nobeta minspan1 allowed weights cv5 pmethcv | earth mars nofast minspan1 weights pmethcv | | 5 1 5 0.008 | 0.4 1.0 1.0 1.0 1.0 33 5.5 19.5 | 0.54 0.54 0.54 0.54 0.54 0.54 5 2 5 0.010 | 0.4 0.7 0.8 1.1 0.9 40 5.2 16.5 | 0.54 0.54 0.54 0.54 0.54 0.54 5 3 5 0.010 | 0.5 0.9 1.0 0.9 0.9 40 5.0 16.9 | 0.54 0.54 0.54 0.54 0.54 0.54 | | 21 1 13 0.019 | 0.9 0.9 1.0 1.1 0.9 327 5.2 31.4 | 0.78 0.77 0.78 0.78 0.78 0.77 21 2 20 0.062 | 1.2 1.0 1.1 1.2 1.0 349 5.1 16.5 | 0.88 0.88 0.88 0.88 0.88 0.88 21 3 21 0.089 | 1.5 1.0 1.1 1.2 1.1 325 5.1 13.4 | 0.89 0.88 0.89 0.89 0.89 0.89 | | 51 1 13 0.023 | 3.2 1.0 1.0 1.2 1.0 413 7.0 39.3 | 0.78 0.77 0.78 0.78 0.78 0.77 51 2 28 0.098 | 5.0 2.9 1.1 1.2 1.0 460 5.4 20.0 | 0.93 0.94 0.95 0.92 0.93 0.93 51 3 38 0.342 | 3.1 1.6 1.2 1.2 1.0 653 4.7 13.4 | 0.97 0.96 0.97 0.97 0.97 0.97 Timing 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.emma.bat0000755000176200001440000000150414563571565017012 0ustar liggesusers@rem test.emma.R: regression tests for emma with plotmo @rem Stephen Milborrow, Shrewsbury Nov 2014 @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.emma.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.emma.Rout: @echo. @tail test.emma.Rout @echo test.emma.R @exit /B 1 :good1 mks.diff test.emma.Rout test.emma.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @rem @diffps -s Rplots.ps ..\..\.#\test-reference\test.emma.save.ps @exit /B 1 :good2 @rem test.emma.save.ps is too big to be included in the release @rem so it is stored elsewhere @rem diffps Rplots.ps ..\..\.#\test-reference\test.emma.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.emma.Rout @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.varmod.R0000644000176200001440000004110413727246550017005 0ustar liggesusers# test.varmod.R source("test.prolog.R") library(earth) options(warn=1) # print warnings as they occur 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) 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') par(org.par) # 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 plot(mod.temp.vh.doy, which=1, versus="b:doy") 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") cat("\npredict(earth.mod, interval=\"pint\")\n") print(head(predict)) 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=.5) 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,])) expect.err(try(summary(earth.mod1, newdata=c(1,2,3))), "plotmo_response: newdata must be a matrix or data.frame") expect.err(try(summary(earth.mod1, newdata=ozone1[1:100,1:3])), "response with newdata object 'temp' not found") # earth.default O3 <- ozone1$O3 temper <- ozone1$temp set.seed(4) earth.default <- earth(temper, O3, nfold=5, ncross=3, varmod.method="lm") cat("summary(earth.default)\n") print(summary(earth.default)) expect.err(try(summary(earth.default, newdata=ozone1[1:100,])), "model.matrix.earth could not interpret the data") newdata_temper <- matrix(c(O3[1:100], temper[1:100]), ncol=2) expect.err(try(summary(earth.default, newdata=newdata_temper)), "cannot get response from newdata because newdata has no column names") colnames(newdata_temper) <- c("O3", "temper") cat("summary(earth.default, newdata=newdata_temper)\n") print(summary(earth.default, newdata=newdata_temper)) plot(earth.default, level=.80, caption="earth.default") options(warn=2) # treat warnings as errors expect.err(try(plotmo(earth.default, level=.80, col.response=3)), "Cannot determine which variables to plot (use all1=TRUE?)") plotmo(earth.default, all1=TRUE, level=.80, col.response=3, caption="earth.default\nlevel = .80") options(warn=1) # print warnings as they occur multifigure("plot(earth.mod2)", 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) 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(org.par) source("test.epilog.R") earth/inst/slowtests/test.cv.bat0000755000176200001440000000145114564114425016471 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-4.3.2\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.bat0000755000176200001440000000172114563571565016635 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-4.3.2\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 @mks.diff test.big.Rout test.big.Rout.save @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 @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/make.bat0000755000176200001440000000503514564113201016011 0ustar liggesusers@rem earth/inst/slowtests/make.bat @rem TODO Removed clang because 32-bit builds are no longer supported by rtools43 @rem @call test.earthmain.clang.bat @rem @if %errorlevel% NEQ 0 goto err @rem @call test.earthc.clang.bat @rem @if %errorlevel% NEQ 0 goto err call test.earthmain.gcc.bat @if %errorlevel% NEQ 0 goto err call test.earthc.gcc.bat @if %errorlevel% NEQ 0 goto err call test.earthmain.msc.bat @if %errorlevel% NEQ 0 goto err call test.earthc.msc.bat @if %errorlevel% NEQ 0 goto err call test.numstab.bat @if %errorlevel% NEQ 0 goto err @call test.mods.bat @if %errorlevel% NEQ 0 goto err @call test.incorrect.bat @if %errorlevel% NEQ 0 goto err @call test.big.bat @if %errorlevel% NEQ 0 goto err @call test.weights.bat @if %errorlevel% NEQ 0 goto err @call test.expand.bpairs.bat @if %errorlevel% NEQ 0 goto err @call test.bpairs.bat @if %errorlevel% NEQ 0 goto err @call test.full.bat @if %errorlevel% NEQ 0 goto err @call test.glm.bat @if %errorlevel% NEQ 0 goto err @call test.allowedfunc.bat @if %errorlevel% NEQ 0 goto err @call test.cv.bat @if %errorlevel% NEQ 0 goto err @call test.pmethod.cv.bat @if %errorlevel% NEQ 0 goto err @call test.varmod.bat @if %errorlevel% NEQ 0 goto err @call test.varmod.mgcv.bat @if %errorlevel% NEQ 0 goto err @call test.plotd.bat @if %errorlevel% NEQ 0 goto err @call test.offset.bat @if %errorlevel% NEQ 0 goto err @call test.ordinal.bat @if %errorlevel% NEQ 0 goto err @call test.multresp.bat @if %errorlevel% NEQ 0 goto err @rem TODO R 4.2.0: Removed following because "Warning: package 'emma' is not available for this version of R" @rem @call test.emma.bat @rem @if %errorlevel% NEQ 0 goto err @rem TODO With some versions of R, test.mem gives different results per run (first seen Sep 2020, R 4.0.3) @rem @call test.mem.bat @if %errorlevel% NEQ 0 goto err @goto done :err @echo ==== ERROR ==== @exit /B %errorlevel% :done @rm -f ../../src/earth_res.rc ../Makedeps @rm -f test.*.pdf *.dll *.lib *.pdb @exit /B 0 earth/inst/slowtests/test.allowedfunc.Rout.save0000644000176200001440000003646314563605665021526 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 > 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 expected error 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 expected error 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 expected error 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 expected error 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 expected error from try(earth(Volume ~ ., data = trees, allowed = example9)) > > source("test.epilog.R") earth/inst/slowtests/test.expand.bpairs.Rout.save0000644000176200001440000006141314563614572021747 0ustar liggesusers> # test.expand.bpairs.R: > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > options(warn=1) # print warnings as they occur > > # 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 =factor(c( "m", "m", "f", "f", "f", "f", "f", "f", "f", "f", "f")), + pclass =factor(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("\n---print.default(stripped.long.expanded)------\n") + print.default(stripped.long.expanded) + printf("\n---print.default(long.ref)--------------------\n") + print.default(long.ref) + printf("\n----------------------------------------------\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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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 expected error from try(expand.bpairs(short.data.frame, "nonesuch")) > expect.err(try(expand.bpairs(short.data.frame, nonesuch)), "object 'nonesuch' not found") Error : object 'nonesuch' not found Got expected error from try(expand.bpairs(short.data.frame, nonesuch)) > options(warn=2) # treat warnings as errors > 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 expected error 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 expected error 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 expected error 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 expected error from try(expand.bpairs(short.data.frame, c("success", ""))) > options(warn=1) # print warnings as they occur > 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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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.earthc.gcc.bat0000755000176200001440000000421414564114477020071 0ustar liggesusers@rem test.earthc.gcc.bat: @rem @rem This tests the earth C code. It does this: builds test.earthc.exe @rem (under gcc), runs it, and compares results to test.earthc.out.save. @rem @rem You will need to tweak this file for your directories. @rem @rem You need to make R.lib first -- see instructions in gnuwin32/README.packages. @echo test.earthc.gcc.bat @set CYGWIN=nodosfilewarning @rem Init environment for GCC compiler, if necessary @call D:\bin\milbo\rpath.bat cp "C:/Program Files/R/R-4.3.2/bin/x64/R.dll" . @if %errorlevel% neq 0 goto err cp "C:/Program Files/R/R-4.3.2/bin/x64/Rblas.dll" . @if %errorlevel% neq 0 goto err cp "C:/Program Files/R/R-4.3.2/bin/x64/Riconv.dll" . @if %errorlevel% neq 0 goto err cp "C:/Program Files/R/R-4.3.2/bin/x64/Rgraphapp.dll" . @if %errorlevel% neq 0 goto err @rem @rem you may have to create Rdll_x64.lib and Rblas_x64.lib beforehand @cp "../../.#/Rdll_x64.lib" R.lib @if %errorlevel% neq 0 goto err @cp "../../.#/Rblas_x64.lib" Rblas.lib @if %errorlevel% neq 0 goto err @rem TODO -USE_BLAS=0 else crashes in daxpy_ call in FindKnot @rem TODO -Wno-stringop-overflow else earth.c:3301:warning: 'memset' exceeds maximum object size gcc -DSTANDALONE -DUSE_BLAS=0 -Wall --pedantic -Wextra -O3 -std=gnu99 -m64^ -Wno-stringop-overflow -Wno-unused-parameter^ -I"/a/r/ra/include" -I../../inst/slowtests^ ../../src/earth.c test.earthc.c^ R.lib Rblas.lib^ -o test.earthc.exe @if %errorlevel% neq 0 goto err test.earthc.exe >test.earthc.gcc.out @if %errorlevel% neq 0 goto err @rem we use -w on diff so it treats \r\n the same as \n diff -w test.earthc.gcc.out test.earthc.gcc.out.save @if %errorlevel% neq 0 goto err @if %errorlevel% equ 0 goto good :err @echo error: errorlevel %errorlevel% @exit /B %errorlevel% :good @rm -f R.dll Rblas.dll R.lib Rblas.lib Riconv.dll Rgraphapp.dll R.lib Rblas.lib @rm -f test.earthc.exe test.earthc.gcc.out @exit /B 0 earth/inst/slowtests/test.pmethod.cv.R0000644000176200001440000001166213725313740017564 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") # 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, main="a100.form: pmethod=\"back\"") par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0), oma=c(0,0,2,0)) set.seed(2) cat("\n") a101.form <- earth(survived ~ ., data=etitanic, degree=2, trace=1, pmethod="cv", nfold=2, ncross=2) 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, caption="formula interface") # test trace=.5 set.seed(2) a101a.form <- earth(survived ~ ., data=etitanic, degree=2, trace=.5, pmethod="cv", nfold=2, ncross=3) # 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) # test trace=.5 with multiple response model set.seed(2015) a102.form <- earth(pclass ~ ., data=etitanic, degree=2, trace=.5, pmethod="cv", nfold=3) # multiple response model # following is useful because the model selected by cv is same as that selected by gcv set.seed(1900) # don't change a103.form <- earth(pclass ~ ., data=etitanic, degree=2, pmethod="cv", nfold=3, nprune=9) 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) # don't change a104.form <- earth(pclass ~ ., data=etitanic, degree=2, pmethod="cv", nfold=3, nprune=7) cat("\nprint(a104.form)\n") print(a104.form) plot(a104.form, which=1, nresponse=1, grid=T, main="a104.form: pmethod=\"cv\" nprune=7", 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,2,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="xy 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(1900) # don't change a103.xy <- earth(x.except.pclass, pclass, degree=2, pmethod="cv", nfold=3, nprune=9) 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) # don't change a104.xy <- earth(x.except.pclass, pclass, degree=2, pmethod="cv", nfold=3, nprune=7) cat("\nprint(a104.xy)\n") print(a104.xy) plot(a104.xy, which=1, nresponse=1, grid=T, main="a104.xy: pmethod=\"cv\" nprune=7", cex.main=.8) # This model used to cause following error: (fixed July 2020, see nprune1 code in earth.R) # evimp: Error in object$prune.terms[isubset, -1] : subscript out of bounds set.seed(1900) a3 <- earth(survived~., data=etitanic, degree=2, nprune=4, nfold=2, pmethod="cv", trace=.5) print(evimp(a3, trim=FALSE)) plot(a3, which=1, main="a3: pmethod=\"cv\" nprune=4", cex.main=.8, ylim=c(0,.5)) source("test.epilog.R") earth/inst/slowtests/test.mem.Rout.save0000644000176200001440000002410314563605665017765 0ustar liggesusers> # test.mem.R: test earth C code memory usage under both normal and error conditions > # > # TODO With some versions of R, test.mem gives different results per run. > # First seen Sep 2020, R 4.0.3. > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > > # 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 1.93 ncells 19 vcells 29 mem 1.75 ncells 1577 vcells 3666 mem 1.91 ncells 1777 vcells 4246 mem 1.91 ncells 1777 vcells 4246 mem 1.91 ncells 1777 vcells 4246 > 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 8 vcells 0 mem 0 ncells 8 vcells 0 mem 0 ncells 8 vcells 0 mem 0 ncells 8 vcells 0 mem 0 ncells 8 vcells 0 > # 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 8 vcells 0 mem 0 ncells 8 vcells 0 mem 0 ncells 8 vcells 0 mem 0 ncells 8 vcells 0 mem 0 ncells 8 vcells 0 > # 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 8 vcells 0 mem 0 ncells 8 vcells 0 mem 0 ncells 8 vcells 0 mem 0 ncells 8 vcells 0 mem 0 ncells 8 vcells 0 > # 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 expected error 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 8 vcells 0 mem 0 ncells 8 vcells 0 mem 0 ncells 8 vcells 0 mem 0 ncells 8 vcells 0 mem 0 ncells 8 vcells 0 > > # 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 expected error 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 8 vcells 0 mem 0 ncells 8 vcells 0 mem 0 ncells 8 vcells 0 mem 0 ncells 8 vcells 0 mem 0 ncells 8 vcells 0 > > cat("nlm "); print(nlm) nlm [1] 8 8 8 8 8 > cat("nstandardearth"); print(nstandardearth) nstandardearth[1] 8 8 8 8 8 > cat("ngoodallowed "); print(ngoodallowed) ngoodallowed [1] 8 8 8 8 8 > cat("nbadallowed "); print(nbadallowed) nbadallowed [1] 8 8 8 8 8 > cat("nbadendspan "); print(nbadendspan) nbadendspan [1] 8 8 8 8 8 > > # 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.save0000644000176200001440000002345114563605665017755 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 > 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 2.284, -1.301, 0.9086, -1.968... 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 201 B: BoolFullSet nMaxTerms 201 sizeof(bool) 1 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 expected error 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 2.284, -1.301, 0.9086, -1.968... 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 201 B: BoolFullSet nMaxTerms 201 sizeof(bool) 1 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.00076) 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 13 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.091 h(-0.60442-x1) 3.837 h(x1- -0.60442) -1.477 h(x1- -0.363047) 3.482 h(x1- -0.211628) 1.520 h(x1-0.278173) -3.181 h(x1-0.478679) -3.776 h(0.699946-x2) -1.000 h(x2-0.699946) 1.000 h(x3- -0.529421) 1.895 h(-0.0152655-x3) 3.060 h(x3- -0.0152655) -0.734 h(x3-0.584854) 2.162 Selected 13 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 12 (additive model) GCV 0.00293 RSS 58.5 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.R0000644000176200001440000000305013725313736017502 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.bat0000755000176200001440000000176214563571565020324 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-4.3.2\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.save0000644000176200001440000004713314563605665021266 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 > 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 > > # 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, + main="a100.form: pmethod=\"back\"") > > par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0), oma=c(0,0,2,0)) > > set.seed(2) > cat("\n") > a101.form <- earth(survived ~ ., data=etitanic, 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 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 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.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.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=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.form, which=1, legend.cex=.5, main="a101.form: pmethod=\"cv\"", cex.main=.8, caption="formula interface") > > # test trace=.5 > set.seed(2) > a101a.form <- earth(survived ~ ., data=etitanic, degree=2, trace=.5, pmethod="cv", nfold=2, ncross=3) Preliminary model with pmethod="backward": GRSq 0.420 RSq 0.439 nterms 8 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% Final model with pmethod="cv": GRSq 0.417 RSq 0.434 nterms selected by cv 7 > > # 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) > > # test trace=.5 with multiple response model > set.seed(2015) > a102.form <- earth(pclass ~ ., data=etitanic, degree=2, trace=.5, pmethod="cv", nfold=3) Preliminary model with pmethod="backward": GRSq 0.175 RSq 0.206 nterms 9 CV fold 1 CVRSq 0.175 Per response CVRSq 0.251 0.002 0.272 n.oof 697 33% n.infold.nz 189 174 334 n.oof.nz 95 87 167 CV fold 2 CVRSq 0.165 Per response CVRSq 0.276 0.019 0.200 n.oof 697 33% n.infold.nz 189 174 334 n.oof.nz 95 87 167 CV fold 3 CVRSq 0.174 Per response CVRSq 0.251 0.032 0.237 n.oof 698 33% n.infold.nz 190 174 334 n.oof.nz 94 87 167 CV all CVRSq 0.171 Per response CVRSq 0.259 0.018 0.237 n.infold.nz 284 261 501 Final model with pmethod="cv": GRSq 0.175 RSq 0.222 nterms selected by cv 13 > > # multiple response model > # following is useful because the model selected by cv is same as that selected by gcv > set.seed(1900) # don't change > a103.form <- earth(pclass ~ ., data=etitanic, degree=2, + pmethod="cv", nfold=3, nprune=9) > cat("\nprint(a103.form)\n") print(a103.form) > print(a103.form) Selected 9 of 17 terms, and 5 of 5 predictors (pmethod="cv") (nprune=9) Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 4 4 GCV RSS GRSq RSq mean.oof.RSq sd(mean.oof.RSq) 1st 0.1479 148.5 0.253820 0.28211 2nd 0.1870 187.8 0.003405 0.04119 3rd 0.1896 190.4 0.241873 0.27061 All 0.5244 526.7 0.175230 0.20650 0.1752 0.02776 pmethod="backward" would have selected the same model: 9 terms 5 preds, GRSq 0.17523 RSq 0.2065 mean.oof.RSq 0.17523 > 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) # don't change > a104.form <- earth(pclass ~ ., data=etitanic, degree=2, pmethod="cv", nfold=3, nprune=7) > cat("\nprint(a104.form)\n") print(a104.form) > print(a104.form) Selected 6 of 17 terms, and 5 of 5 predictors (pmethod="cv") (nprune=7) Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 2 3 GCV RSS GRSq RSq mean.oof.RSq sd(mean.oof.RSq) 1st 0.1500 152.9 0.24282 0.26083 2nd 0.1899 193.6 -0.01218 0.01189 3rd 0.1958 199.5 0.21699 0.23561 All 0.5357 546.0 0.15742 0.17745 0.1455 0.03024 pmethod="backward" would have selected: 7 terms 5 preds, GRSq 0.16411 RSq 0.18793 mean.oof.RSq 0.14452 > plot(a104.form, which=1, nresponse=1, grid=T, main="a104.form: pmethod=\"cv\" nprune=7", 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,2,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 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="xy 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(1900) # don't change > a103.xy <- earth(x.except.pclass, pclass, degree=2, + pmethod="cv", nfold=3, nprune=9) > cat("\nprint(a103.xy)\n") print(a103.xy) > print(a103.xy) Selected 9 of 17 terms, and 5 of 5 predictors (pmethod="cv") (nprune=9) Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 4 4 GCV RSS GRSq RSq mean.oof.RSq sd(mean.oof.RSq) 1st 0.1479 148.5 0.253820 0.28211 2nd 0.1870 187.8 0.003405 0.04119 3rd 0.1896 190.4 0.241873 0.27061 All 0.5244 526.7 0.175230 0.20650 0.1752 0.02776 pmethod="backward" would have selected the same model: 9 terms 5 preds, GRSq 0.17523 RSq 0.2065 mean.oof.RSq 0.17523 > 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=9, nfold=3) 1st 2nd 3rd (Intercept) 0.13968 0.138216 0.72211 survived 0.35186 0.160235 -0.51209 sexmale 0.10937 0.136529 -0.24590 h(sibsp-1) -0.04796 -0.067564 0.11552 h(2-parch) 0.21733 0.009423 -0.22676 survived * sexmale -0.09593 -0.303270 0.39920 survived * h(16-age) -0.02326 0.018686 0.00457 h(55-age) * h(2-parch) -0.00785 0.000036 0.00781 h(1-sibsp) * h(1-parch) -0.16239 -0.032878 0.19527 Selected 9 of 17 terms, and 5 of 5 predictors (pmethod="cv") (nprune=9) Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 4 4 GCV RSS GRSq RSq mean.oof.RSq sd(mean.oof.RSq) 1st 0.1479 148.5 0.253820 0.28211 2nd 0.1870 187.8 0.003405 0.04119 3rd 0.1896 190.4 0.241873 0.27061 All 0.5244 526.7 0.175230 0.20650 0.1752 0.02776 pmethod="backward" would have selected the same model: 9 terms 5 preds, GRSq 0.17523 RSq 0.2065 mean.oof.RSq 0.17523 > 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) # don't change > a104.xy <- earth(x.except.pclass, pclass, degree=2, pmethod="cv", nfold=3, nprune=7) > cat("\nprint(a104.xy)\n") print(a104.xy) > print(a104.xy) Selected 6 of 17 terms, and 5 of 5 predictors (pmethod="cv") (nprune=7) Termination condition: Reached nk 21 Importance: age, parch, survived, sibsp, sexmale Number of terms at each degree of interaction: 1 2 3 GCV RSS GRSq RSq mean.oof.RSq sd(mean.oof.RSq) 1st 0.1500 152.9 0.24282 0.26083 2nd 0.1899 193.6 -0.01218 0.01189 3rd 0.1958 199.5 0.21699 0.23561 All 0.5357 546.0 0.15742 0.17745 0.1455 0.03024 pmethod="backward" would have selected: 7 terms 5 preds, GRSq 0.16411 RSq 0.18793 mean.oof.RSq 0.14452 > plot(a104.xy, which=1, nresponse=1, grid=T, main="a104.xy: pmethod=\"cv\" nprune=7", cex.main=.8) > > # This model used to cause following error: (fixed July 2020, see nprune1 code in earth.R) > # evimp: Error in object$prune.terms[isubset, -1] : subscript out of bounds > set.seed(1900) > a3 <- earth(survived~., data=etitanic, degree=2, nprune=4, nfold=2, pmethod="cv", trace=.5) Preliminary model with pmethod="backward": GRSq 0.359 RSq 0.368 nterms 4 CV fold 1 CVRSq 0.380 n.oof 535 49% n.infold.nz 213 40% n.oof.nz 214 42% CV fold 2 CVRSq 0.447 n.oof 511 51% n.infold.nz 214 42% n.oof.nz 213 40% CV all CVRSq 0.414 n.infold.nz 427 41% Final model with pmethod="cv": GRSq 0.359 RSq 0.368 nterms selected by cv 4 > print(evimp(a3, trim=FALSE)) nsubsets gcv rss sexmale 3 100.0 100.0 pclass3rd 2 45.1 46.2 pclass2nd 1 28.6 29.5 age-unused 0 0.0 0.0 sibsp-unused 0 0.0 0.0 parch-unused 0 0.0 0.0 > plot(a3, which=1, main="a3: pmethod=\"cv\" nprune=4", cex.main=.8, ylim=c(0,.5)) > > source("test.epilog.R") earth/inst/slowtests/test.glm.R0000644000176200001440000022032414055537162016274 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") expect.err(try(earth(sex ~ ., data=etitanic, nfold=2, # earth.formula subset=rep(TRUE, length.out=nrow(etitanic)))), "'subset' cannot be used with 'nfold' (implementation restriction)") expect.err(try(earth(etitanic$age, etitanic$sex, nfold=2, # earth.default subset=rep(TRUE, length.out=nrow(etitanic)))), "'subset' cannot be used with 'nfold' (implementation restriction)") cat("glm.varmod: titanic data, one response which is a two level factor, with varmod and plotmo\n\n") set.seed(2020) glm.varmod <- earth(sex ~ pclass+age+sibsp, data=etitanic, glm=list(family="binomial"), trace=.5, nfold=5, ncross=3, varmod.method="lm") cat("\nprint(glm.varmod)\n") print(glm.varmod) cat("\nsummary(glm.varmod)\n") print(summary(glm.varmod)) plotmo(glm.varmod, type="earth", level=.8, ylim=c(-1, 2), SHOWCALL=TRUE) options(warn=2) expect.err(try(plotmo(glm.varmod, leve=.8)), "predict.earth: with earth-glm models, use type=\"earth\" when using the interval argument") expect.err(try(plotmo(glm.varmod, lev=.8, type="response")), "predict.earth: with earth-glm models, use type=\"earth\" when using the interval argument") options(warn=1) 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) a7d1 <- earth(sex ~ .-pclass, data=etitanic, degree=2, glm=list(family="binomial"), trace=0, keepxy=1) a7d1update <- update(a7, form=sex ~ .-pclass) check.models.equal(a7d1update, a7d1, msg="a7update a7d1 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") cat("sexmale:\n"); print(sexmale) 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-28m", pm2.ref, pm) # Jun 2021: with R 4.1.0 no longer works, probably ok (old version of R gave err/warn msgs) # something to do with change in how ordered factors are handled in model frames # # 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-28f", 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-29m", 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-29f", 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-31m", 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-31f", 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-31bm", 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-31bf", 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-32m1", pm, pf) stop.if.not.identical("A-32m2", 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-32f", 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)), "could not interpret newdata\n model.matrix returned 2 columns: \"sex.1.\", \"X.2\"\n need 3 columns: \"sexmale\", \"ldose\", \"ldose1\"") 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)), "could not interpret newdata\n model.matrix returned 2 columns: \"sex.1.\", \"X.2\"\n need 3 columns: \"sex\", \"ldose\", \"ldose1\"") 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)), "could not interpret newdata\n model.matrix returned 2 columns: \"sex.c.1..7..\", \"c..2...1.\"\n need 3 columns: \"sexmale\", \"ldose\", \"ldose1\"") 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)), "could not interpret newdata\n model.matrix returned 2 columns: \"sex.c.1..7..\", \"c..2...1.\"\n need 3 columns: \"sex\", \"ldose\", \"ldose1\"") 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 \"model.matrix.earth could not interpret the data\"\n", sep="") a41 <- earth(my.response~my.input.mat, trace=trace) expect.err(try(predict(a41, c(2.1, 0.6), trace=trace)), "model.matrix.earth 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)), "could not interpret newdata\n model.matrix returned 2 columns: \"sex3.1.\", \"X.2\"\n need 4 columns: \"sex3\", \"ldose\", \"ldose1\", \"fac3\"") 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)), "could not interpret newdata\n model.matrix returned 2 columns: \"sex3.1.\", \"X.2\"\n need 4 columns: \"sex3\", \"ldose\", \"ldose1\", \"fac3\"") 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)), "could not interpret newdata\n model.matrix returned 2 columns: \"sex3.c.1..7..\", \"c..2...1.\"\n need 4 columns: \"sex3\", \"ldose\", \"ldose1\", \"fac3\"") 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)), "could not interpret newdata\n model.matrix returned 2 columns: \"sex3.c.1..7..\", \"c..2...1.\"\n need 4 columns: \"sex3\", \"ldose\", \"ldose1\", \"fac3\"") 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)), "could not interpret newdata") 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)), "could not interpret newdata") 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)), "could not interpret newdata") 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)), "could not interpret newdata\n model.matrix returned 2 columns: \"sex3.c.1..7..\", \"c..2...1.\"\n need 4 columns: \"sex3\", \"ldose\", \"ldose1\", \"fac3\"") 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)) cat("summary(mod.Gamma):\n") print(summary(mod.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)) cat("summary(mod.binomial):\n") print(summary(mod.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))) expect.err(try(earth(numdead, cbind(sex1, sex2, sex1), trace=1)), # one duplicate name "Duplicate colname in cbind(sex1, sex2, sex1) (colnames are \"sex1\", \"sex2\", \"sex1\"") sex1 <- factor(rep(c("male", "female"), times=c(6,6))) sex2 <- factor(rep(c("male", "female"), times=c(6,6))) expect.err(try(earth(numdead, cbind(sex1, sex2, sex1, sex1), trace=1)), # two duplicate names "Duplicate colname in cbind(sex1, sex2, sex1, sex1) (colnames are \"sex1\", \"sex2\", \"sex1\", \"sex1\"") # 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) earth(sex2, data.frame(sex2=sex2, stringsAsFactors=TRUE), trace=1) # R 4.0.0 may 2020 # 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.bat0000755000176200001440000000154614563571565017553 0ustar liggesusers@rem test.weights.bat @rem Stephen Milborrow Dec 2014 Shrewsbury @echo test.weights.bat @"C:\PROGRA~1\R\R-4.3.2\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.emma.Rout0000644000176200001440000000047014563615203017157 0ustar liggesusers> # test.emma.R: regression tests for emma (which uses earth internally) > # Stephen Milborrow, Shrewsbury Nov 2014 > > source("test.prolog.R") > print(R.version.string) [1] "R version 4.3.2 (2023-10-31 ucrt)" > library(emma) Error in library(emma) : there is no package called 'emma' Execution halted earth/inst/slowtests/test.incorrect.Rout.save0000644000176200001440000000540114563611062021163 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 > 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.bat0000755000176200001440000000141214563571565016647 0ustar liggesusers@rem test.mem.bat @echo test.mem.bat @"C:\PROGRA~1\R\R-4.3.2\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/makeclean.bat0000755000176200001440000000075414273324162017026 0ustar liggesusers@rem makeclean.bat: clean up R package slowtests directory @rem make sure we are in the right directory @cd ..\..\.. @if %errorlevel% NEQ 0 goto err @cd earth\inst\slowtests @if %errorlevel% NEQ 0 goto err rm -rf Debug Release .vs rm -f ../../src/earth_res.rc ../Makedeps rm -f *.dll *.lib *.pdb *.map *.ilk rm -f *.ps *.pdf *.Rout *.exe *.out @goto done :err @echo ==== ERROR ==== @exit /B %errorlevel% :done @exit /B 0 earth/inst/slowtests/test.ordinal.R0000644000176200001440000001601713727246550017152 0ustar liggesusers# test.ordinal.R: ordinal models by way of package "ordinal" and earth's bx matrix source("test.prolog.R") source("check.models.equal.R") options(warn=1) # print warnings as they occur library(earth) # toy data, where response is non-monotonic with input input <- 1:20 resp <- ifelse(input < 8, "low", ifelse(input > 16, "med", "high")) resp[8] <- resp[15] <- "med" # add some noise to make it more interesting resp <- ordered(resp, levels=c("low", "med", "high")) cat("\nsummary(resp)\n") print(summary(resp)) dat <- data.frame(input=input, resp=resp) library(ordinal) clm.mod <- clm(resp ~ input, data=dat) cat("\nsummary(clm.mod)\n") print(summary(clm.mod)) earth.mod <- earth(resp ~ input, data=dat) cat("\nsummary(earth.mod)\n") print(summary(earth.mod)) bx <- earth.mod$bx bx <- bx[,-1,drop=FALSE] # drop intercept column bx <- as.data.frame(bx) bx$resp <- dat$resp # add resp (needed for formula interface below) clm.earth <- clm(resp ~ ., data=bx) cat("\nsummary(clm.earth)\n") print(summary(clm.earth)) earth.bx.mod <- earth(resp ~ input, data=bx) cat("\nsummary(earth.bx.mod)\n") print(summary(earth.bx.mod)) cat("\n=== models after converting ordered response to numeric ===\n") # i.e. artificially impose equal distance between each level in the response dat.numeric.resp <- data.frame(input=input, resp=as.numeric(resp)) earth.numeric.resp <- earth(resp ~ input, data=dat.numeric.resp) cat("\nsummary(earth.numeric.resp)\n") print(summary(earth.numeric.resp)) bx.numeric.resp <- earth.numeric.resp$bx bx.numeric.resp <- bx.numeric.resp[,-1,drop=FALSE] # drop intercept column bx.numeric.resp <- as.data.frame(bx.numeric.resp) bx.numeric.resp$resp <- resp # add resp (needed for formula interface below) # note that for clm() we use the ORIGINAL resp (ordered factor, not numeric) clm.earth.numeric.resp <- clm(resp ~ ., data=bx.numeric.resp) cat("\nsummary(clm.earth.numeric.resp)\n") print(summary(clm.earth.numeric.resp)) bx.numeric.resp$resp <- as.numeric(resp) # add resp (needed for formula interface below) # note that for earth() we use as.mumeric(resp) # (else we generate a multiple resp model, which we don't want here) earth.bx.numeric.resp.mod <- earth(resp ~ input, data=bx.numeric.resp) cat("\nsummary(earth.bx.numeric.resp.mod)\n") print(summary(earth.bx.numeric.resp.mod)) cat("\n== use plots to compare predicted to measured response ==\n") # color points using measured response values (the "true" response) col <- ifelse(resp == "low", "red", ifelse(resp == "med", "pink", "green")) par(mfrow = c(3,3), mar = c(4, 3, 3, 1), mgp = c(1.5, 0.5, 0)) cat("\nplot measured response\n") plot(input, resp, main="measured response", yaxp=c(1,3,2), pch=20, col=col, ylab="measured response") legend("topleft", legend=c("low", "med", "high"), col=c("red", "pink", "green"), pch=20, cex=.8) cat("\nplot response predicted by clm model\n") predict.clm <- predict(clm.mod, type="class")$fit plot(input, predict.clm, main="clm.mod", yaxp=c(1,3,2), pch=20, col=col, ylab="predicted response") points(input, predict.clm, # black rings around wrong predictions col=ifelse(predict.clm == as.character(resp), 0, "black")) plot.legend <- function() { legend("topleft", legend=c("low", "med", "high", "wrong"), col=c("red", "pink", "green", "black"), pch=c(20,20,20,1), cex=.8) } plot.legend() empty.plot() cat("\nplot response predicted by earth.bx model\n") predict.earth.bx.mod <- predict(earth.bx.mod, type="class") predict.earth.bx.mod <- ifelse(predict.earth.bx.mod == "low", 1, ifelse(predict.earth.bx.mod == "med", 2, 3)) plot(input, predict.earth.bx.mod, main="earth.bx.mod", yaxp=c(1,3,2), pch=20, col=col, ylab="predicted response") points(input, predict.earth.bx.mod, # black rings around wrong predictions col=ifelse(predict.earth.bx.mod == as.numeric(resp), 0, "black"), cex=1) plot.legend() cat("\nplot response predicted by clm/earth model\n") predict.clm.earth <- predict(clm.earth, type="class")$fit plot(input, predict.clm.earth, main="clm.earth", yaxp=c(1,3,2), pch=20, col=col, ylab="predicted response") points(input, predict.clm.earth, # black rings around wrong predictions col=ifelse(predict.clm.earth == as.character(resp), 0, "black"), cex=1) plot.legend() empty.plot() cat("\nplot response predicted by earth.bx model with as.numeric(resp)\n") predict.earth.bx.numeric.resp.mod <- predict(earth.bx.numeric.resp.mod) predict.earth.bx.numeric.resp.mod <- ifelse(predict(earth.bx.numeric.resp.mod) < 1.5, 1, ifelse(predict(earth.bx.numeric.resp.mod) < 2.5, 2, 3)) plot(input, predict.earth.bx.numeric.resp.mod, main="earth.bx.numeric.resp.mod", yaxp=c(1,3,2), pch=20, col=col, ylab="predicted response") points(input, predict.earth.bx.numeric.resp.mod, # black rings around wrong predictions col=ifelse(predict.earth.bx.numeric.resp.mod == as.numeric(resp), 0, "black"), cex=1) plot.legend() cat("\nplot response predicted by clm/earth model with as.numeric(resp)\n") predict.clm.earth.numeric.resp <- predict(clm.earth.numeric.resp, type="class")$fit plot(input, predict.clm.earth.numeric.resp, main="clm.earth.numeric.resp", yaxp=c(1,3,2), pch=20, col=col, ylab="predicted response") points(input, predict.clm.earth.numeric.resp, # black rings around wrong predictions col=ifelse(predict.clm.earth.numeric.resp == as.character(resp), 0, "black"), cex=1) plot.legend() empty.plot() par(org.par) cat("\n=== plotmo plots ===\n") par(mfrow = c(3,3), mar = c(4, 3, 3, 1), mgp = c(1.5, 0.5, 0)) # in the plotmo plots below we use nresp=1 to select the first response level ("low"), # and predict probabilites by setting type="prob" for predict.clm plotmo(clm.mod, type="prob", do.par=0, nresp=1, main="clm.mod: is.low") plotmo(clm.mod, type="prob", do.par=0, nresp=2, main="clm.mod: is.med") plotmo(clm.mod, type="prob", do.par=0, nresp=3, main="clm.mod: is.high") plotmo(earth.mod, do.par=0, nresp=1, main="earth.mod: is.low") plotmo(earth.mod, do.par=0, nresp=2, main="earth.mod: is.med") plotmo(earth.mod, do.par=0, nresp=3, main="earth.mod: is.high") # plotmo(clm.earth, do.par=0, nresp=1, all2=TRUE) # main="clm.earth: is.low") # plotmo(clm.earth, do.par=0, nresp=2, all2=TRUE) # main="clm.earth: is.med") plotmo(clm.earth, do.par=0, nresp=3, all2=TRUE) # main="clm.earth: is.high") par(org.par) cat("\n=== plotmo plots with as.numeric(response) ===\n") par(mfrow = c(3,3), mar = c(4, 3, 3, 1), mgp = c(1.5, 0.5, 0)) plotmo(earth.numeric.resp, do.par=0, all2=TRUE, main="earth.numeric.resp") empty.plot() empty.plot() plotmo(clm.earth.numeric.resp, do.par=0, nresp=3, all2=2) par(org.par) source("test.epilog.R") earth/inst/slowtests/test.varmod.Rout.save0000644000176200001440000031554614563615072020506 0ustar liggesusers> # test.varmod.R > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > options(warn=1) # print warnings as they occur > 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) > > 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) $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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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, minspan = minspan) $namesx [1] "RHS" $modvars RHS RHS 1 $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') > par(org.par) > > # 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 expected error 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 expected error 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 expected error 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 > 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 > > 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) 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") > cat("\npredict(earth.mod, interval=\"pint\")\n") predict(earth.mod, interval="pint") > print(head(predict)) fit lwr upr 1 4.745556 -0.4564985 9.947611 2 5.532021 -0.2056124 11.269655 3 6.947658 0.2459826 13.649334 4 3.959091 -0.7073845 8.625567 5 5.532021 -0.2056124 11.269655 6 7.104951 0.2961598 13.913743 > > 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=.5) Model with pmethod="backward": GRSq 0.651 RSq 0.660 nterms 3 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% varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) O3 1 11 0.00 1.7 0.18 2 15 15.79 1.4 0.21 3 16 2.25 1.4 0.21 4 16 0.32 1.3 0.21 > 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 expected error 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 > > expect.err(try(summary(earth.mod1, newdata=c(1,2,3))), + "plotmo_response: newdata must be a matrix or data.frame") Error : plotmo_response: newdata must be a matrix or data.frame Got expected error from try(summary(earth.mod1, newdata = c(1, 2, 3))) > expect.err(try(summary(earth.mod1, newdata=ozone1[1:100,1:3])), + "response with newdata object 'temp' not found") Error : response with newdata object 'temp' not found Got expected error from try(summary(earth.mod1, newdata = ozone1[1:100, 1:3])) > > # earth.default > O3 <- ozone1$O3 > temper <- ozone1$temp > set.seed(4) > earth.default <- earth(temper, O3, nfold=5, ncross=3, varmod.method="lm") > cat("summary(earth.default)\n") summary(earth.default) > print(summary(earth.default)) Call: earth(x=temper, y=O3, nfold=5, ncross=3, varmod.method="lm") coefficients (Intercept) 7.5768304 h(58-temper) -0.1572930 h(temper-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: temper 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 > expect.err(try(summary(earth.default, newdata=ozone1[1:100,])), + "model.matrix.earth could not interpret the data") stats::predict(earth.object, data.frame[100,10], type="response") Error : model.matrix.earth could not interpret the data model.matrix returned 0 columns: need 1 column: "temper" Got expected error from try(summary(earth.default, newdata = ozone1[1:100, ])) > newdata_temper <- matrix(c(O3[1:100], temper[1:100]), ncol=2) > expect.err(try(summary(earth.default, newdata=newdata_temper)), + "cannot get response from newdata because newdata has no column names") Error : cannot get response from newdata because newdata has no column names Got expected error from try(summary(earth.default, newdata = newdata_temper)) > colnames(newdata_temper) <- c("O3", "temper") > cat("summary(earth.default, newdata=newdata_temper)\n") summary(earth.default, newdata=newdata_temper) > print(summary(earth.default, newdata=newdata_temper)) 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") > options(warn=2) # treat warnings as errors > expect.err(try(plotmo(earth.default, level=.80, col.response=3)), + "Cannot determine which variables to plot (use all1=TRUE?)") Error : (converted from warning) Cannot determine which variables to plot (use all1=TRUE?) single.names=c(temper,temper) colnames(x)=x Got expected error from try(plotmo(earth.default, level = 0.8, col.response = 3)) > plotmo(earth.default, all1=TRUE, level=.80, col.response=3, caption="earth.default\nlevel = .80") > options(warn=1) # print warnings as they occur > > multifigure("plot(earth.mod2)", 2, 2) ===plot(earth.mod2) > 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)) 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)) 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) 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) 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) + 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" 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" 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.80 0.35 0.19 0.78 5 15 10.17 0.28 0.21 0.76 6 15 3.92 0.30 0.20 0.77 7 15 1.22 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.3731063 4.80734 big coef 0.2564899 1.41384 551 exponent 0.7682587 1.19522 156 mean smallest largest ratio 95% prediction interval 14.92662 7.320158 28.74623 3.926996 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.5e-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.2046 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.499e-09 ===varmod.method power: predict(earth.mod, interval="pint") fit lwr upr 1 9.913855 6.253775 13.57393 2 10.942195 7.051413 14.83298 3 11.627755 7.585971 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.515591 27.62117 15 22.596721 16.350065 28.84338 16 25.681742 18.865271 32.49821 17 25.681742 18.865271 32.49821 18 27.052863 19.988309 34.11742 19 28.423983 21.114245 35.73372 20 28.766764 21.396162 36.13737 21 30.080913 22.478506 37.68332 22 31.395063 23.563187 39.22694 23 33.366287 25.194327 41.53825 24 43.222408 33.413638 53.03118 25 45.193632 35.068459 55.31881 26 51.764379 40.606627 62.92213 27 53.078529 41.718012 64.43905 28 55.706828 43.944227 67.46943 29 56.363903 44.501475 68.22633 30 56.363903 44.501475 68.22633 31 73.447846 59.074729 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.3806261 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.6e-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.643e-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.634402 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.816522 32.54696 17 25.681742 18.816522 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.421822 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" 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, 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.22-3 ===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: NA 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, 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" ===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: NA 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(org.par) > > source("test.epilog.R") earth/inst/slowtests/test.full.Rout.save0000644000176200001440000135431514567071344020160 0ustar liggesusers> # test.full.R: test earth > > print(R.version.string) [1] "R version 4.3.2 (2023-10-31 ucrt)" > > source("test.prolog.R") > source("check.models.equal.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > library(mda) Loading required package: class Loaded mda 0.5-4 > 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: Hastie SMDfmbT, wrapper. RTUAMFuwTLl (2011). _earth: Multivariate Adaptive Regression Splines_. R package version 5.3.3, . 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.3.3}, 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 expected error 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 expected error 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 expected error 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 > plotmo(a1a) plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > > a1b <- earth(etitanic[,-2,drop=FALSE], etitanic[,2,drop=FALSE], + 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(a1b) ===a1b 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 > plotmo(a1b) plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > > # test modvars for the example in the man page earth.object.Rd > > aform <- earth(survived ~ age + pclass + sqrt(age) - sex, data=etitanic) > cat("\nattr(aform$terms, \"factors\")\n") attr(aform$terms, "factors") > print(attr(aform$terms, "factors")) age pclass sqrt(age) survived 0 0 0 age 1 0 0 pclass 0 1 0 sqrt(age) 0 0 1 sex 0 0 0 > cat("\na$modvars\n") a$modvars > print(aform$modvars) age pclass2nd pclass3rd sqrt(age) age 1 0 0 1 pclass 0 1 1 0 > cat("\n") > > axy.dat <- data.frame(age=etitanic$age, pclass=etitanic$pclass, sqrt_age=sqrt(etitanic$age)) > axy <- earth(axy.dat, etitanic$survived) > cat("\nattr(axy$terms, \"factors\")\n") attr(axy$terms, "factors") > print(attr(axy$terms, "factors")) NULL > cat("\na$modvars\n") a$modvars > print(axy$modvars) age pclass2nd pclass3rd sqrt_age age 1 0 0 0 pclass 0 1 1 0 sqrt_age 0 0 0 1 > cat("\n") > > # x and y dataframes but with missing column names > xdf_nonames <- etitanic[,-2,drop=FALSE] > cat("original colnames of xdf_nonames:", paste(colnames(xdf_nonames)), "\n") original colnames of xdf_nonames: pclass sex age sibsp parch > ydf_nonames <- etitanic[,2,drop=FALSE] > colnames(xdf_nonames) <- NULL # weird for a dataframe, but earth still works > colnames(ydf_nonames) <- NULL > earth_df_nonames <- earth(xdf_nonames, ydf_nonames, + degree=2, trace=1, + glm=list(family=binomial)) x[1046,6] with colnames xdf_nonames12nd xdf_nonames13rd xdf_nonames2male xdf_nona... y[1046,1] with colname ydf_nonames, 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 ydf_nonames devratio 0.37 dof 1038/1045 iters 5 > cat("earth_df_nonames:\n") earth_df_nonames: > print(summary(earth_df_nonames)) Call: earth(x=xdf_nonames, y=ydf_nonames, trace=1, glm=list(family=binomial), degree=2) GLM coefficients ydf_nonames (Intercept) 2.9135260 xdf_nonames13rd -5.0300560 xdf_nonames2male -3.1856245 h(xdf_nonames3-32) -0.0375715 xdf_nonames12nd * xdf_nonames2male -1.7680945 xdf_nonames13rd * xdf_nonames2male 1.2226954 xdf_nonames13rd * h(4-xdf_nonames4) 0.6186527 xdf_nonames2male * h(16-xdf_nonames3) 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: xdf_nonames2male, xdf_nonames13rd, xdf_nonames12nd, ... Number of terms at each degree of interaction: 1 3 4 Earth GCV 0.1404529 RSS 141.7629 GRSq 0.4197106 RSq 0.4389834 > cat("\nearth_df_nonames$modvars\n") earth_df_nonames$modvars > print(earth_df_nonames$modvars) xdf_nonames12nd xdf_nonames13rd xdf_nonames2male xdf_nonames3 xdf_nonames1 1 1 0 0 xdf_nonames2 0 0 1 0 xdf_nonames3 0 0 0 1 xdf_nonames4 0 0 0 0 xdf_nonames5 0 0 0 0 xdf_nonames4 xdf_nonames5 xdf_nonames1 0 0 xdf_nonames2 0 0 xdf_nonames3 0 0 xdf_nonames4 1 0 xdf_nonames5 0 1 > options(warn=2) > expect.err(try(plotmo(earth_df_nonames)), "Cannot determine which variables to plot") Error : (converted from warning) Cannot determine which variables to plot (use all1=TRUE?) single.names=c(xdf_nonames2,xdf_nonames1,xdf_nonames3) colnames(x)=c(x1,x2,x3,x4,x5) Got expected error from try(plotmo(earth_df_nonames)) > plotmo(earth_df_nonames, all1=TRUE, SHOWCALL=TRUE) plotmo grid: x1 x2 x3 x4 x5 3rd male 28 0 0 > options(warn=1) > plotmo(earth_df_nonames, trace=1, SHOWCALL=TRUE) stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from getCall(object)$y Warning: Cannot determine which variables to plot (use all1=TRUE?) single.names=c(xdf_nonames2,xdf_nonames1,xdf_nonames3) colnames(x)=c(x1,x2,x3,x4,x5) plotmo grid: x1 x2 x3 x4 x5 3rd male 28 0 0 > > # xmat in canonical form (double matrix) but with missing column names > xmat_nonames <- etitanic[,"age",drop=FALSE] > xmat_nonames$pclass <- as.numeric(etitanic[,"pclass"]) > xmat_nonames <- as.matrix(xmat_nonames) > cat("original colnames of xmat_nonames:", paste(colnames(xmat_nonames)), "\n") original colnames of xmat_nonames: age pclass > ymat_nonames <- as.numeric(etitanic[,"survived"]) > ymat_nonames <- as.matrix(ymat_nonames) > colnames(xmat_nonames) <- NULL > colnames(ymat_nonames) <- NULL > earth_mat_nonames <- earth(xmat_nonames, ymat_nonames, degree=2, trace=1) x[1046,2] with colnames xmat_nonames1 xmat_nonames2 y[1046,1] with colname ymat_nonames, and values 1, 1, 0, 0, 0, 1, 1, 0, 1, 0,... Forward pass term 1, 2, 4, 6, 8, 10 RSq changed by less than 0.001 at 9 terms (DeltaRSq 0.00055) After forward pass GRSq 0.120 RSq 0.162 Prune backward penalty 3 nprune null: selected 6 of 9 terms, and 2 of 2 preds After pruning pass GRSq 0.137 RSq 0.158 > cat("earth_mat_nonames:\n") earth_mat_nonames: > print(summary(earth_mat_nonames)) Call: earth(x=xmat_nonames, y=ymat_nonames, trace=1, degree=2) coefficients (Intercept) 0.47789359 h(18-xmat_nonames1) 0.03051719 h(xmat_nonames1-18) -0.00609975 h(2-xmat_nonames2) 0.28092736 h(xmat_nonames2-2) -0.16376873 h(23-xmat_nonames1) * h(xmat_nonames2-2) -0.01570789 Selected 6 of 9 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: xmat_nonames2, xmat_nonames1 Number of terms at each degree of interaction: 1 4 1 GCV 0.2088003 RSS 212.8039 GRSq 0.1373292 RSq 0.1578438 > options(warn=2) > expect.err(try(plotmo(earth_mat_nonames)), "Cannot determine which variables to plot") Error : (converted from warning) Cannot determine which variables to plot (use all1=TRUE?) single.names=c(xmat_nonames2,xmat_nonames2,xmat_nonames1,xmat_nonames1) colnames(x)=c(x1,x2) Got expected error from try(plotmo(earth_mat_nonames)) > options(warn=1) > plotmo(earth_mat_nonames) Warning: Cannot determine which variables to plot (use all1=TRUE?) single.names=c(xmat_nonames2,xmat_nonames2,xmat_nonames1,xmat_nonames1) colnames(x)=c(x1,x2) plotmo grid: x1 x2 28 2 > > # xmat in canonical form (double matrix) but with some missing column names > xmat_partial <- etitanic[,"age",drop=FALSE] > xmat_partial$pclass <- as.numeric(etitanic[,"pclass"]) > xmat_partial$sibsp <- as.numeric(etitanic[,"sibsp"]) > xmat_partial <- as.matrix(xmat_partial) > cat("original colnames of xmat_partial:", paste(colnames(xmat_partial)), "\n") original colnames of xmat_partial: age pclass sibsp > colnames(xmat_partial) <- c("", "x2", "") # some column names are missing (earth will create them) > ymat_partial <- as.numeric(etitanic[,"survived"]) > ymat_partial <- as.matrix(ymat_partial) > colnames(ymat_partial) <- "yy" > earth_mat_partialnames <- earth(xmat_partial, ymat_partial, degree=2, trace=1) x[1046,3] with colnames xmat_partial1 x2 xmat_partial3 y[1046,1] with colname yy, 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 RSq changed by less than 0.001 at 19 terms, 17 terms used (DeltaRSq 0.0009) After forward pass GRSq 0.126 RSq 0.195 Prune backward penalty 3 nprune null: selected 7 of 17 terms, and 3 of 3 preds After pruning pass GRSq 0.157 RSq 0.181 > cat("earth_mat_partialnames:\n") earth_mat_partialnames: > print(summary(earth_mat_partialnames)) Call: earth(x=xmat_partial, y=ymat_partial, trace=1, degree=2) coefficients (Intercept) 0.93106453 h(xmat_partial1-5) -0.03561187 h(xmat_partial1-18) 0.03022469 h(2-x2) 0.27484540 h(x2-2) -0.18280547 h(18-xmat_partial1) * h(xmat_partial3-2) -0.04797511 h(18-xmat_partial1) * h(xmat_partial3-3) 0.04721023 Selected 7 of 17 terms, and 3 of 3 predictors Termination condition: RSq changed by less than 0.001 at 17 terms Importance: x2, xmat_partial1, xmat_partial3 Number of terms at each degree of interaction: 1 4 2 GCV 0.2040487 RSS 206.9554 GRSq 0.1569604 RSq 0.1809888 > options(warn=2) > expect.err(try(plotmo(earth_mat_partialnames)), "Cannot determine which variables to plot") Error : (converted from warning) Cannot determine which variables to plot (use all1=TRUE?) single.names=c(x2,x2,xmat_partial1,xmat_partial1) colnames(x)=c(x1,x2,x3) Got expected error from try(plotmo(earth_mat_partialnames)) > options(warn=1) > plotmo(earth_mat_partialnames) Warning: Cannot determine which variables to plot (use all1=TRUE?) single.names=c(x2,x2,xmat_partial1,xmat_partial1) colnames(x)=c(x1,x2,x3) plotmo grid: x1 x2 x3 28 2 0 > > # use a partial column name that will cause a duplicate within gen.colnames > colnames(xmat_partial) <- c("", "xmat_partial1", "") > expect.err(try(earth(xmat_partial, ymat_partial, degree=2, trace=1)), + "Duplicate colname in xmat_partial (colnames are \"xmat_partial1\", \"xmat_partial1\", \"xmat_partial3\")") Error : Duplicate colname in xmat_partial (colnames are "xmat_partial1", "xmat_partial1", "xmat_partial3") Got expected error from try(earth(xmat_partial, ymat_partial, degree = 2, trace = 1)) > > 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 expected error 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 [1] "cyl" "disp" "hp" "drat" "wt" "qsec" "vs" "am" "gear" "carb" $modvars cyl disp hp drat wt qsec vs am gear carb 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 $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 expected error 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> # 29.0 frmt.r> # - 3.42 * h(14.2-Girth) frmt.r> # + 6.23 * h(Girth-14.2) frmt.r> # + 0.581 * 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> # 29.0 frmt.r> # - 3.42 * pmax(0, 14.2 - Girth) frmt.r> # + 6.23 * pmax(0, Girth - 14.2) frmt.r> # + 0.581 * 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> # 29.0 frmt.r> # - 3.42 * max(0, 14.2 - x[0]) frmt.r> # + 6.23 * max(0, x[0] - 14.2) frmt.r> # + 0.581 * 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> # 29.0 frmt.r> # - 3.42 * bf1 frmt.r> # + 6.23 * bf2 frmt.r> # + 0.581 * bf3 frmt.r> # frmt.r> # bf1 h(14.2-Girth) frmt.r> # bf2 h(Girth-14.2) 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) > mars.mod <- mars(trees[,-3], trees[,3]) > cat("print.default(mars.mod):\n") print.default(mars.mod): > print.default(mars.mod) $call mars(x = trees[, -3], y = trees[, 3]) $all.terms [1] 1 2 3 4 5 6 8 10 $selected.terms [1] 1 2 3 8 $penalty [1] 2 $degree [1] 1 $nk [1] 21 $thresh [1] 0.001 $gcv [1] 10.22537 $factor Girth Height [1,] 0 0 [2,] 1 0 [3,] -1 0 [4,] 0 1 [5,] 0 -1 [6,] 1 0 [7,] -1 0 [8,] 0 1 [9,] 0 -1 [10,] 0 1 [11,] 0 -1 $cuts [,1] [,2] [1,] 0.0 0 [2,] 13.8 0 [3,] 13.8 0 [4,] 0.0 75 [5,] 0.0 75 [6,] 11.4 0 [7,] 11.4 0 [8,] 0.0 72 [9,] 0.0 72 [10,] 0.0 80 [11,] 0.0 80 $residuals [,1] [1,] 1.4581315 [2,] 0.5079983 [3,] -0.2254239 [4,] 0.5904880 [5,] -2.1221305 [6,] -2.5342186 [7,] -1.7930674 [8,] -0.6861328 [9,] 0.9087137 [10,] 0.3804450 [11,] 2.3729800 [12,] 0.3493344 [13,] 0.7493344 [14,] 1.6899552 [15,] -2.9532435 [16,] -2.2059546 [17,] 3.9194721 [18,] -4.2450607 [19,] -0.2442662 [20,] -1.3609773 [21,] 4.0303181 [22,] -0.9876327 [23,] 4.7646376 [24,] -1.4092887 [25,] -1.4315918 [26,] 3.2647855 [27,] 1.8445232 [28,] 2.9947526 [29,] -4.4165342 [30,] -4.9165342 [31,] 1.7061874 $fitted.values [,1] [1,] 8.841869 [2,] 9.792002 [3,] 10.425424 [4,] 15.809512 [5,] 20.922131 [6,] 22.234219 [7,] 17.393067 [8,] 18.886133 [9,] 21.691286 [10,] 19.519555 [11,] 21.827020 [12,] 20.650666 [13,] 20.650666 [14,] 19.610045 [15,] 22.053243 [16,] 24.405955 [17,] 29.880528 [18,] 31.645061 [19,] 25.944266 [20,] 26.260977 [21,] 30.469682 [22,] 32.687633 [23,] 31.535362 [24,] 39.709289 [25,] 44.031592 [26,] 52.135215 [27,] 53.855477 [28,] 55.305247 [29,] 55.916534 [30,] 55.916534 [31,] 75.293813 $lenb [1] 11 $coefficients [,1] [1,] 26.2609773 [2,] 6.1128688 [3,] -3.1671107 [4,] 0.4976885 $x [,1] [,2] [,3] [,4] [1,] 1 0.0 5.5 0 [2,] 1 0.0 5.2 0 [3,] 1 0.0 5.0 0 [4,] 1 0.0 3.3 0 [5,] 1 0.0 3.1 9 [6,] 1 0.0 3.0 11 [7,] 1 0.0 2.8 0 [8,] 1 0.0 2.8 3 [9,] 1 0.0 2.7 8 [10,] 1 0.0 2.6 3 [11,] 1 0.0 2.5 7 [12,] 1 0.0 2.4 4 [13,] 1 0.0 2.4 4 [14,] 1 0.0 2.1 0 [15,] 1 0.0 1.8 3 [16,] 1 0.0 0.9 2 [17,] 1 0.0 0.9 13 [18,] 1 0.0 0.5 14 [19,] 1 0.0 0.1 0 [20,] 1 0.0 0.0 0 [21,] 1 0.2 0.0 6 [22,] 1 0.4 0.0 8 [23,] 1 0.7 0.0 2 [24,] 1 2.2 0.0 0 [25,] 1 2.5 0.0 5 [26,] 1 3.5 0.0 9 [27,] 1 3.7 0.0 10 [28,] 1 4.1 0.0 8 [29,] 1 4.2 0.0 8 [30,] 1 4.2 0.0 8 [31,] 1 6.8 0.0 15 attr(,"class") [1] "mars" > mars.to.earth.mod <- mars.to.earth(mars.mod) Converted mars(x=trees[,-3], y=trees[,3]) to earth(x=trees[,-3], y=trees[,3]) > cat("print.default(mars.to.earth.mod):\n") print.default(mars.to.earth.mod): > print.default(mars.to.earth.mod) $rss [1] 189.9939 $rsq [1] 0.9765616 $gcv [1] 10.22537 $grsq [1] 0.9633775 $bx (Intercept) h(Girth-13.8) h(13.8-Girth) h(11.4-Girth) [1,] 1 0.0 5.5 0 [2,] 1 0.0 5.2 0 [3,] 1 0.0 5.0 0 [4,] 1 0.0 3.3 0 [5,] 1 0.0 3.1 9 [6,] 1 0.0 3.0 11 [7,] 1 0.0 2.8 0 [8,] 1 0.0 2.8 3 [9,] 1 0.0 2.7 8 [10,] 1 0.0 2.6 3 [11,] 1 0.0 2.5 7 [12,] 1 0.0 2.4 4 [13,] 1 0.0 2.4 4 [14,] 1 0.0 2.1 0 [15,] 1 0.0 1.8 3 [16,] 1 0.0 0.9 2 [17,] 1 0.0 0.9 13 [18,] 1 0.0 0.5 14 [19,] 1 0.0 0.1 0 [20,] 1 0.0 0.0 0 [21,] 1 0.2 0.0 6 [22,] 1 0.4 0.0 8 [23,] 1 0.7 0.0 2 [24,] 1 2.2 0.0 0 [25,] 1 2.5 0.0 5 [26,] 1 3.5 0.0 9 [27,] 1 3.7 0.0 10 [28,] 1 4.1 0.0 8 [29,] 1 4.2 0.0 8 [30,] 1 4.2 0.0 8 [31,] 1 6.8 0.0 15 $dirs Girth Height (Intercept) 0 0 h(Girth-13.8) 1 0 h(13.8-Girth) -1 0 h(Height-75) 0 1 h(75-Height) 0 -1 h(Girth-11.4) 1 0 h(Height-72) 0 1 h(Height-80) 0 1 $cuts Girth Height (Intercept) 0.0 0 h(Girth-13.8) 13.8 0 h(13.8-Girth) 13.8 0 h(Height-75) 0.0 75 h(75-Height) 0.0 75 h(Girth-11.4) 11.4 0 h(Height-72) 0.0 72 h(Height-80) 0.0 80 $selected.terms [1] 1 2 3 7 $prune.terms NULL $fitted.values y [1,] 8.841869 [2,] 9.792002 [3,] 10.425424 [4,] 15.809512 [5,] 20.922131 [6,] 22.234219 [7,] 17.393067 [8,] 18.886133 [9,] 21.691286 [10,] 19.519555 [11,] 21.827020 [12,] 20.650666 [13,] 20.650666 [14,] 19.610045 [15,] 22.053243 [16,] 24.405955 [17,] 29.880528 [18,] 31.645061 [19,] 25.944266 [20,] 26.260977 [21,] 30.469682 [22,] 32.687633 [23,] 31.535362 [24,] 39.709289 [25,] 44.031592 [26,] 52.135215 [27,] 53.855477 [28,] 55.305247 [29,] 55.916534 [30,] 55.916534 [31,] 75.293813 $residuals [,1] [1,] 1.4581315 [2,] 0.5079983 [3,] -0.2254239 [4,] 0.5904880 [5,] -2.1221305 [6,] -2.5342186 [7,] -1.7930674 [8,] -0.6861328 [9,] 0.9087137 [10,] 0.3804450 [11,] 2.3729800 [12,] 0.3493344 [13,] 0.7493344 [14,] 1.6899552 [15,] -2.9532435 [16,] -2.2059546 [17,] 3.9194721 [18,] -4.2450607 [19,] -0.2442662 [20,] -1.3609773 [21,] 4.0303181 [22,] -0.9876327 [23,] 4.7646376 [24,] -1.4092887 [25,] -1.4315918 [26,] 3.2647855 [27,] 1.8445232 [28,] 2.9947526 [29,] -4.4165342 [30,] -4.9165342 [31,] 1.7061874 $coefficients y (Intercept) 26.2609773 h(Girth-13.8) 6.1128688 h(13.8-Girth) -3.1671107 h(11.4-Girth) 0.4976885 $rss.per.response [1] 189.9939 $rsq.per.response [1] 0.9765616 $gcv.per.response [1] 10.22537 $grsq.per.response [1] 0.9633775 $rss.per.subset [1] 8106.0839 NA NA 189.9939 NA NA NA [8] NA $gcv.per.subset [1] 279.20956 NA NA 10.22537 NA NA NA [8] NA $leverages [1] 0.23257376 0.20337574 0.18555587 0.08723624 0.12248572 0.17248005 [7] 0.07641904 0.05073854 0.08780610 0.04741454 0.06734919 0.04425746 [13] 0.04425746 0.07509704 0.04728244 0.08085017 0.21454775 0.26167636 [19] 0.16017614 0.16788561 0.10621610 0.10955549 0.11166012 0.16467557 [25] 0.07594784 0.09429047 0.10722497 0.12495379 0.13133163 0.13133163 [31] 0.41334716 $pmethod [1] "backward" $nprune NULL $penalty [1] 2 $nk [1] 21 $thresh [1] 0.001 $call earth(x = trees[, -3], y = trees[, 3]) $namesx [1] "Girth" "Height" $modvars Girth Height Girth 1 0 Height 0 1 attr(,"class") [1] "earth" > printh(mars.to.earth.mod) ===mars.to.earth.mod 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.22537 RSS 189.9939 GRSq 0.9633775 RSq 0.9765616 > printh(summary(mars.to.earth.mod)) ===summary(mars.to.earth.mod) Call: earth(x=trees[,-3], y=trees[,3]) coefficients (Intercept) 26.2609773 h(13.8-Girth) -3.1671107 h(Girth-13.8) 6.1128688 h(11.4-Girth) 0.4976885 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.22537 RSS 189.9939 GRSq 0.9633775 RSq 0.9765616 > printh(summary(mars.to.earth.mod, style="bf")) ===summary(mars.to.earth.mod, style = "bf") Call: earth(x=trees[,-3], y=trees[,3]) y = 26.26098 - 3.167111 * bf1 + 6.112869 * bf2 + 0.4976885 * 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.22537 RSS 189.9939 GRSq 0.9633775 RSq 0.9765616 > stopifnot(length(mars.mod$coeff) == length(mars.to.earth.mod$coeff)) > stopifnot(max(mars.mod$coeff - mars.to.earth.mod$coeff) < 1e-10) > earth.mod <- earth(trees[,-3], trees[,3]) > stopifnot(length(mars.mod$coeff) == length(earth.mod$coeff)) > # coeff differences can be big because forward passes are different > stopifnot(max(mars.mod$coeff - earth.mod$coeff) < .3) > > par(mfrow=c(3,4), mar=c(4, 3.2, 3, 3), mgp=c(1.6, 0.6, 0), cex = 0.7) > plot(mars.to.earth.mod, which=c(1,3), do.par=FALSE) > plotmo(mars.to.earth.mod, do.par=FALSE) plotmo grid: Girth Height 12.9 76 > mars.to.earth.mod2 <- update(mars.to.earth.mod) > plot(mars.to.earth.mod2, which=c(1,3), do.par=FALSE) > plotmo(mars.to.earth.mod2, do.par=FALSE) plotmo grid: Girth Height 12.9 76 > plot(earth.mod, which=c(1,3), do.par=FALSE) > plotmo(earth.mod, do.par=FALSE) plotmo grid: Girth Height 12.9 76 > par(org.par) > > 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 (nprune=8) 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)), "Could not convert vector x to matrix because length(x) 1\n is not a multiple of the number 2 of predictors") Error : 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 expected error 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 expected error 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 expected error from try(earth(cbind(Volume, Volume + 100) ~ ., data = trees, nfold = 3, ncross = 3, varmod.method = "lm")) > > options(warn=2) > # TODO column naming for the following maybe needs work? > # nresponse="cbind(Volume, Volume + 100)2" is confusing (2 should be in brackets?) > expect.err(try(plot(a)), "Defaulting to nresponse=1, see above messages") predict.earth[31,2]: Volume cbind(Volume, Volume + 100)2 1 8.883097 108.8831 2 9.909039 109.9090 3 10.593000 110.5930 ... 16.406671 116.4067 31 75.905218 175.9052 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="cbind(Volume, Volume + 100)2" Error : (converted from warning) Defaulting to nresponse=1, see above messages Got expected error from try(plot(a)) > options(warn=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, 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 xy interface ---\n") --- earth.predict with NAs, with xy interface --- > > iris.earth <- earth(iris[,1:3], iris[,4]) > x <- iris[1,] > predict.with.message("default interface and vector", iris.earth, newdata=x) # tests the "Fix: April 2010" in get.earthx() 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", print.mars=FALSE) + { + fite <- earth(x, y, degree=degree, nk=nk, trace=trace) + fitm <- mars(x, y, degree=degree, nk=nk) + fitme <- mars.to.earth(fitm) + + 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)), + "RSq", sprint("%4.2g", fite$rsq), + "GRSq", sprint("%4.2g", fite$grsq), + "mars RSq", sprint("%4.2g", fitme$rsq), + "ratio", sprint("%.2f", fite$rsq / fitme$rsq), + "GRSq", sprint("%4.2g", fitme$grsq), + "ratio", sprint("%.2f", fite$grsq / fitme$grsq), + "\n") + if(print.mars) { + fitme1 <- update(fitme) # generate model selection data + printh(summary(fitme1)) + cat("\n") + } + printh(summary(fite)) + if(plotit) { + caption <- paste("itest ", itest, ": ", sModel, " degree=", degree, " nk=", nk, sep="") + 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 RSq 0.26 GRSq 0.2 mars RSq 0.21 ratio 1.25 GRSq 0.17 ratio 1.21 ===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 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 RSq 0.28 GRSq 0.17 mars RSq 0.26 ratio 1.10 GRSq 0.18 ratio 0.94 ===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 > > # 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 see "Fixed rank deficient bx by removing 2 terms, 7 terms remain" > 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 x2 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 x2 1.7848e+08< 7 1 12 0.0534 0.1323 0.001868 2 x2 1.7848e+08< 8 1 14 0.0432 0.1340 0.001792 2 x2 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 RSq 0.12 GRSq 0.1 mars RSq 0.099 ratio 1.24 GRSq 0.077 ratio 1.32 ===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 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 RSq 0.83 GRSq 0.79 mars RSq 0.82 ratio 1.01 GRSq 0.78 ratio 1.01 ===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 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, print.mars=TRUE) 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 RSq 0.87 GRSq 0.81 mars RSq 0.86 ratio 1.01 GRSq 0.8 ratio 1.01 ===summary(fitme1) Call: earth(x=x, y=y, degree=degree, nk=nk, Object=fitme) coefficients (Intercept) 13.1186756 h(56-humidity) -0.1031673 h(humidity-56) -0.1085360 h(dpg-8) -0.0587153 h(125-ibt) -0.0434807 h(ibt-125) 0.0626181 h(ibt-194) -0.0655497 h(90-vis) 0.0508188 h(96-doy) -0.1101954 h(doy-158) -0.0561658 h(vh-5890) * h(humidity-56) 0.0164870 h(vh-5760) * h(1049-ibh) 0.0000837 h(wind-4) * h(90-vis) -0.0209123 h(humidity-56) * h(1571-ibh) -0.0001258 h(humidity-28) * h(8-dpg) -0.0023565 h(humidity-41) * h(ibt-125) 0.0029711 h(1049-ibh) * h(60-dpg) -0.0000749 h(dpg-52) * h(ibt-194) -0.0102805 h(ibt-242) * h(90-vis) 0.0041764 h(ibt-261) * h(90-vis) -0.0096904 h(295-ibt) * h(doy-158) 0.0001535 h(ibt-295) * h(doy-158) 0.0028195 Selected 22 of 48 terms, and 8 of 9 predictors Termination condition: Unknown Importance: humidity, ibt, doy, ibh, dpg, vh, vis, wind, temp-unused Number of terms at each degree of interaction: 1 9 12 GCV 12.6843 RSS 2938.616 GRSq 0.8029643 RSq 0.8608307 ===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 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" > par(org.par) > > 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 expected error 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 expected error 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 (nprune=7) 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 > plot(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) ===a Selected 7 of 21 terms, and 5 of 9 predictors (nprune=7) 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 (nprune=7) 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") (nprune=10) 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 (nprune=10) 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") (nprune=4) 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 (nprune=10) 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 (nprune=10) 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 (nprune=10) 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) > 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 expected error 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 = -2.808667e-16 + 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(org.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 > par(mfrow=c(2,2), mar=c(4, 3.2, 3, 3), mgp=c(1.6, 0.6, 0), 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(org.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": > # trace==2 so we see "Fixed rank deficient bx by removing terms" > # TODO why are we getting the rank deficient message? > 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 expected error 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: 8 Percent Between-Group Variance Explained: v1 v2 v3 v4 v5 v6 v7 v8 46.60 74.43 85.71 92.48 95.56 98.06 99.20 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, xy interface--------------------------\n") ----- update and keepxy, xy 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.3.3 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 2nd 3rd 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 3rd 0< 2 1 4 0.0116 0.0210 0.003025 1 2nd 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 3rd 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: 3rd, 2nd-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 3rd Selected 2 of 3 terms, and 1 of 2 predictors Termination condition: RSq changed by less than 0.001 at 3 terms Importance: 3rd, 2nd-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 male, 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 male 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 male -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: male 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 2nd 3rd 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 3rd 0< 2 1 4 0.1640 0.1720 0.05838 1 2nd 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 2nd -9.653213 3rd -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: 3rd, 2nd 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 > # TODO June 2021: this doesn't actually check factors and never has, see note below > ff <- factor(substring("statistics", 1:10, 1:10), levels=letters, ordered=TRUE) > # NOTE: Jun 2021: added as.numeric for backward compability with R pre version R 4.1.0 > ff <- as.numeric(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 ff, 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 ff 9 2 3 1 4 0.5250 0.7012 0.005454 1 ff 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-ff) -0.1445003 h(ff-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: ff 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) Warning: Cannot determine which variables to plot (use all1=TRUE?) single.names=c(ff,ff) colnames(x)=x > 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 > > expect.err(try(earth(cbind(O3, O3) ~ ., data=ozone1, wp=c(1, .01))), + "Duplicate colname in cbind(O3, O3) (colnames are \"O3\", \"O3\")") Error : Duplicate colname in cbind(O3, O3) (colnames are "O3", "O3") Got expected error from try(earth(cbind(O3, O3) ~ ., data = ozone1, wp = c(1, 0.01))) > > oz2 <- ozone1 > oz2$O3a <- ozone1$O3 > e4 <- earth(cbind(O3, O3a) ~ ., data=oz2, 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 O3a 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,O3a)~., data=oz2, wp=c(1,0.01)) O3 O3a (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 O3a 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) --get.model.env for object with class earth object call is earth(formula=O3~., data=se, keepxy=0, degree=2) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'a' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=O3~., data=se, keepxy=0, degree=2) get.x.from.model.frame: formula(object) is O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis ... naked formula is the same formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") x=model.frame[,-1] is usable and has column names vh wind humidity temp ibh dpg ibt vis doy plotmo_x returned[330,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5710 4 28 40 2693 -25 87 250 33 2 5700 3 37 45 590 -24 128 100 34 3 5760 3 51 54 1450 25 139 60 35 ... 5720 4 69 35 1568 15 121 60 36 330 5550 4 85 39 5000 8 44 100 390 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[330,1]: O3 1 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 ... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name O3 plotmo_y returned[330,1]: O3 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=NULL is [330,1]: O3 1 3 2 5 3 5 ... 6 330 1 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=O3~., data=se, keepxy=0, degree=2) get.y.from.model.frame: formula(object) is O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis ... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name O3 got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") plotmo_y returned[330,1]: O3 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=1 is [330,1]: O3 1 3 2 5 3 5 ... 6 330 1 got response name "O3" from yhat resp.levs is NULL ----Metadata: done number of x values: vh 53 wind 11 humidity 65 temp 63 ibh 196 dpg 128 ibt 193... ----plotmo_singles for earth object singles: 4 temp, 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) --get.model.env for object with class earth object call is earth(formula=O3~., data=se, keepxy=1, degree=2) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'a' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=O3~., data=se, keepxy=1, degree=2) get.x.from.model.frame: formula(object) is O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis ... naked formula is the same formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=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 expected error 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 expected error 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 expected error 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 expected error 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 expected error 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("--- /a/r/earth/tests/test.earth.R -------------------------\n") --- /a/r/earth/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 Loading required package: MASS Loading required package: nlme > 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("--- example in earth vignette \"How do I get p values for earth model coefficients?\" ---\n") --- example in earth vignette "How do I get p values for earth model coefficients?" --- > > earth.mod <- earth(Volume~., data=trees) # standard earth model > bx <- earth.mod$bx[,-1] # earth model's basis mat (-1 to drop intercept) > bx <- as.data.frame(bx) # lm requires a data frame > bx$Volume <- trees$Volume # add Volume to data > lm.mod <- lm(Volume~., data=bx) # standard linear regression on earth's basis mat > summary(lm.mod) # prints p values Call: lm(formula = Volume ~ ., data = bx) Residuals: Min 1Q Median 3Q Max -4.977 -2.178 0.083 1.376 5.371 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 29.060 1.073 27.07 < 2e-16 *** `h(Girth-14.2)` 6.230 0.390 15.99 2.7e-15 *** `h(14.2-Girth)` -3.420 0.331 -10.32 7.2e-11 *** `h(Height-75)` 0.581 0.159 3.66 0.0011 ** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 2.78 on 27 degrees of freedom Multiple R-squared: 0.974, Adjusted R-squared: 0.971 F-statistic: 340 on 3 and 27 DF, p-value: <2e-16 > > remove(earth.mod, bx, lm.mod) # tidy up > > cat("--- examples in model.matrix.earth.Rd ---------------------------------------\n") --- examples in model.matrix.earth.Rd --------------------------------------- > > # Example 1 > data(trees) > earth.mod <- earth(Volume ~ ., data = trees) # standard earth model > summary(earth.mod, decomp = "none") # "none" to print terms in same order as lm.mod below Call: earth(formula=Volume~., data=trees) coefficients (Intercept) 29.060 h(Girth-14.2) 6.230 h(14.2-Girth) -3.420 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 > > 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 Call: lm(formula = trees$Volume ~ bx[, -1]) Residuals: Min 1Q Median 3Q Max -4.977 -2.178 0.083 1.376 5.371 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 29.060 1.073 27.07 < 2e-16 *** bx[, -1]h(Girth-14.2) 6.230 0.390 15.99 2.7e-15 *** bx[, -1]h(14.2-Girth) -3.420 0.331 -10.32 7.2e-11 *** bx[, -1]h(Height-75) 0.581 0.159 3.66 0.0011 ** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 2.78 on 27 degrees of freedom Multiple R-squared: 0.974, Adjusted R-squared: 0.971 F-statistic: 340 on 3 and 27 DF, p-value: <2e-16 > # displayed t values are not meaningful > > # Example 2 > earth.mod <- earth(Volume~., data=trees) # standard earth model > summary(earth.mod, decomp = "none") # "none" to print terms in same order as lm.mod below Call: earth(formula=Volume~., data=trees) coefficients (Intercept) 29.060 h(Girth-14.2) 6.230 h(14.2-Girth) -3.420 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 > bx <- model.matrix(earth.mod) # earth model's basis mat (equivalent to bx <- earth.mod$bx) > bx <- bx[, -1, drop=FALSE] # -1 to drop intercept > bx <- as.data.frame(bx) # lm requires a data frame > bx$Volume <- trees$Volume # add Volume to data > lm.mod <- lm(Volume~., data=bx) # standard linear regression on earth's basis mat > summary(lm.mod) # yields same coeffs as above summary Call: lm(formula = Volume ~ ., data = bx) Residuals: Min 1Q Median 3Q Max -4.977 -2.178 0.083 1.376 5.371 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 29.060 1.073 27.07 < 2e-16 *** `h(Girth-14.2)` 6.230 0.390 15.99 2.7e-15 *** `h(14.2-Girth)` -3.420 0.331 -10.32 7.2e-11 *** `h(Height-75)` 0.581 0.159 3.66 0.0011 ** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 2.78 on 27 degrees of freedom Multiple R-squared: 0.974, Adjusted R-squared: 0.971 F-statistic: 340 on 3 and 27 DF, p-value: <2e-16 > # displayed t values are not meaningful > > remove(earth.mod, bx, lm.mod) # tidy up > > 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 > print(predict.earth - predict.lm) Sepal.Length [1,] -8.88e-16 > stopifnot(max(abs(predict.lm - predict.earth)) < 1e-15) > > # Check fix for bug reported by Max Kuhn (Oct 2020, fixed in earth 5.3.0): > # Occasionally we used to put a 1 when we should have put a 2 into the dirs matrix. > options.old <- options() > options(width=1000) > > library(modeldata) > data(ames) > vars <- c("Sale_Price", "Gr_Liv_Area", "Alley", "Mas_Vnr_Type", "BsmtFin_Type_2", "Condition_2") > ames2 <- ames[,vars,drop=FALSE] > ames2$Sale_Price <- log10(ames2$Sale_Price) > # change colnames to something easier to work with > colnames(ames2) <- c("Sale_Price", "g", "a", "m", "b", "c") > ames2 <- as.data.frame(ames2) > ames2.mod <- earth(Sale_Price ~ ., data = ames2, degree = 2, + trace=4, pmethod="none") Call: earth(formula=Sale_Price~., data=ames2, pmethod="none", trace=4, degree=2) x[2930,20]: g aNo_Alley_Access aPaved mBrkFace mCBlock mNone mStone bBLQ bGLQ ... 1 1656 1 0 0 0 0 1 0 0 ... 2 896 1 0 0 0 1 0 0 0 ... 3 1329 1 0 1 0 0 0 0 0 ... ... 2110 1 0 0 0 1 0 0 0 ... 2930 2000 1 0 1 0 0 0 0 0 ... y[2930,1]: Sale_Price 1 5.33 2 5.02 3 5.24 ... 5.39 2930 5.27 Forward pass: minspan 8 endspan 11 x[2930,20] 458 kB bx[2930,41] 939 kB GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.0000 0.0000 (Intercept) 2 0.5117 0.5134 0.5134 1 g 1822 2 3 1 4 0.5575 0.5598 0.04638 6 mNone 0< 4 1 6 0.5769 0.5798 0.02 11 bNo_Basement 0< 5 1 8 0.5859 0.5894 0.009625 2 aNo_Alley_Ac 0< 6 4 2 10 0.5946 0.5988 0.009388 7 mStone 0< 7 1 12 0.6031 0.6079 0.009102 1 g 3390 8 1 14 0.6103 0.6163 0.008397 1 g 954 9 10 4 2 16 0.6159 0.6231 0.00684 1 g 2295 11 12 10 2 18 0.6211 0.6289 0.005752 3 aPaved 0< 13 4 2 20 0.6232 0.6316 0.002692 7 mStone 0< 14 12 2 22 0.6250 0.6339 0.002325 4 mBrkFace 0< 15 1 24 0.6261 0.6356 0.001703 15 cNorm 0< 16 4 2 26 0.6274 0.6376 0.001973 16 cPosA 0< 17 1 28 0.6282 0.6390 0.001401 9 bGLQ 0< 18 1 30 0.6286 0.6400 0.001017 5 mCBlock 0< 19 3 2 32 0.6290 0.6409 0.0009439 13 bUnf 0< 20 10 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 31 terms, 19 terms used (DeltaRSq 0.00094) After forward pass GRSq 0.629 RSq 0.641 Forward pass complete: 31 terms, 19 terms used Subset size GRSq RSq DeltaGRSq nPreds Terms (col nbr in bx) 1 0.0000 0.0000 0.0000 0 1 2 0.4817 0.4825 0.4817 1 1 3 3 0.5117 0.5134 0.0301 1 1 2 3 4 0.5575 0.5598 0.0458 2 1 2 3 4 5 0.5769 0.5798 0.0194 3 1 2 3 4 5 6 0.5880 0.5915 0.0112 4 1 2 3 5 7 15 7 0.6019 0.6060 0.0139 4 1 2 3 5 7 14 15 8 0.6108 0.6154 0.0089 6 1 2 3 5 6 7 14 15 9 0.6157 0.6209 0.0049 6 1 2 3 5 6 7 10 14 15 10 0.6197 0.6256 0.0041 6 1 2 3 5 6 7 9 10 14 15 11 0.6245 0.6309 0.0048 7 1 2 3 5 6 7 9 10 13 14 15 12 0.6243 0.6313 -0.0002 7 1 2 3 4 5 6 7 9 10 13 14 15 13 0.6254 0.6331 0.0011 8 1 2 3 4 5 6 7 9 10 13 14 15 16 14 0.6269 0.6351 0.0015 9 1 2 3 4 5 6 7 9 10 13 14 15 16 17 15 0.6279 0.6367 0.0010 9 1 2 3 4 5 6 7 9 10 12 13 14 15 16 17 16 0.6287 0.6381 0.0008 10 1 2 3 4 5 6 7 9 10 12 13 14 15 16 17 18 17 0.6291 0.6391 0.0004 11 1 2 3 4 5 6 7 9 10 12 13 14 15 16 17 18 19 18 0.6293 0.6400 0.0002 11 1 2 3 4 5 6 7 8 9 10 12 13 14 15 16 17 18 19 chosen 19 0.6286 0.6400 -0.0006 11 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 Prune none penalty 3 nprune null: selected 19 of 19 terms, and 11 of 20 preds After pruning pass GRSq 0.629 RSq 0.64 > cat("\nsummary(ames2.mod)\n") summary(ames2.mod) > print(summary(ames2.mod)) Call: earth(formula=Sale_Price~., data=ames2, pmethod="none", trace=4, degree=2) coefficients (Intercept) 5.275 mBrkFace 0.082 mNone -0.152 mStone 0.207 bGLQ 0.062 bNo_Basement -0.151 cPosA 0.216 h(1822-g) 0.000 h(g-1822) 0.000 h(g-3390) 0.000 aNo_Alley_Access * mNone 0.112 aPaved * mNone 0.119 mNone * cNorm 0.096 h(1822-g) * mCBlock -0.001 h(954-g) * mNone 0.000 h(g-954) * mNone 0.000 h(2295-g) * mStone 0.000 h(g-2295) * mStone 0.000 h(g-3390) * mStone -0.001 Selected 19 of 19 terms, and 11 of 20 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 19 terms Importance: g, bNo_Basement, mNone, mBrkFace, mStone, aNo_Alley_Access, aPaved, cNorm, cPosA, bGLQ, mCBlock, bBLQ-unused, bLwQ-unused, bRec-unused, bUnf-unused, cFeedr-unused, cPosN-unused, cRRAe-unused, cRRAn-unused, cRRNn-unused Number of terms at each degree of interaction: 1 9 9 GCV 0.0116 RSS 33 GRSq 0.629 RSq 0.64 > cat("\names2.mod$dirs\n") ames2.mod$dirs > print(ames2.mod$dirs) g aNo_Alley_Access aPaved mBrkFace mCBlock mNone mStone bBLQ bGLQ bLwQ bNo_Basement bRec bUnf cFeedr cNorm cPosA cPosN cRRAe cRRAn cRRNn (Intercept) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 h(g-1822) 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 h(1822-g) -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 mNone 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 bNo_Basement 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 aNo_Alley_Access*mNone 0 2 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 mStone 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 h(g-3390) 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 h(g-954)*mNone 1 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 h(954-g)*mNone -1 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 h(g-2295)*mStone 1 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 h(2295-g)*mStone -1 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 aPaved*mNone 0 0 2 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 h(g-3390)*mStone 1 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 mBrkFace 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 mNone*cNorm 0 0 0 0 0 2 0 0 0 0 0 0 0 0 2 0 0 0 0 0 cPosA 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 bGLQ 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 h(1822-g)*mCBlock -1 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 > plotmo(ames2.mod, SHOWCALL=TRUE) plotmo grid: g a m b c 1442 No_Alley_Access None Unf Norm > # check that there are no 1s in dirs, except for the "g" variable > # all entries should be 0 or 2, because all vars are indicators (binary), so no knots > stopifnot(all(ames2.mod$dirs[,-1,drop=FALSE] != 1)) # -1 drops "g" column > stopifnot(ames2.mod$dirs["h(g-3390)*mStone", "mStone"] == 2) > > # same as above but with Auto.linpreds=FALSE > ames2.mod.Auto.linpreds.FALSE <- earth(Sale_Price ~ ., data = ames2, degree = 2, + pmethod="none", Auto.linpreds=FALSE) > cat("\nsummary(ames2.mod.Auto.linpreds.FALSE)\n") summary(ames2.mod.Auto.linpreds.FALSE) > print(summary(ames2.mod.Auto.linpreds.FALSE)) Call: earth(formula=Sale_Price~., data=ames2, pmethod="none", degree=2, Auto.linpreds=FALSE) coefficients (Intercept) 5.275 h(1822-g) 0.000 h(g-1822) 0.000 h(g-3390) 0.000 mBrkFace 0.082 mNone -0.152 mStone 0.207 bGLQ 0.062 bNo_Basement -0.151 cPosA 0.216 h(1822-g) * mCBlock -0.001 h(954-g) * mNone 0.000 h(g-954) * mNone 0.000 h(2295-g) * mStone 0.000 h(g-2295) * mStone 0.000 h(g-3390) * mStone -0.001 aNo_Alley_Access * mNone 0.112 aPaved * mNone 0.119 mNone * cNorm 0.096 Selected 19 of 19 terms, and 11 of 20 predictors (pmethod="none") Termination condition: RSq changed by less than 0.001 at 19 terms Importance: g, bNo_Basement, mNone, mBrkFace, mStone, aNo_Alley_Access, aPaved, cNorm, cPosA, bGLQ, mCBlock, bBLQ-unused, bLwQ-unused, bRec-unused, bUnf-unused, cFeedr-unused, cPosN-unused, cRRAe-unused, cRRAn-unused, cRRNn-unused Number of terms at each degree of interaction: 1 9 9 GCV 0.0116 RSS 33 GRSq 0.629 RSq 0.64 > cat("\nAuto.linpreds.FALSE$dirs\n") Auto.linpreds.FALSE$dirs > print(ames2.mod.Auto.linpreds.FALSE$dirs) g aNo_Alley_Access aPaved mBrkFace mCBlock mNone mStone bBLQ bGLQ bLwQ bNo_Basement bRec bUnf cFeedr cNorm cPosA cPosN cRRAe cRRAn cRRNn (Intercept) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 h(g-1822) 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 h(1822-g) -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 mNone 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 bNo_Basement 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 aNo_Alley_Access*mNone 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 mStone 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 h(g-3390) 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 h(g-954)*mNone 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 h(954-g)*mNone -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 h(g-2295)*mStone 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 h(2295-g)*mStone -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 aPaved*mNone 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 h(g-3390)*mStone 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 mBrkFace 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 mNone*cNorm 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 cPosA 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 bGLQ 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 h(1822-g)*mCBlock -1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 > # check that there are no 2s in dirs with Auto.linpreds=FALSE > stopifnot(all(ames2.mod.Auto.linpreds.FALSE$dirs != 2)) > stopifnot(abs(ames2.mod$rsq - ames2.mod.Auto.linpreds.FALSE$rsq) < 1e-10) > > # Oct 2021 (earth 5.3.2): issue an error if x colnames are duplicated because of factor expansion. > iris.dup <- transform(iris, Species=factor(as.numeric(Species) + 20), + Species2=factor(as.numeric(Species))) > # TODO $$ Mar 2022: We no longer get the expected error below, > # but get it if we manually call try(earth(Sepal.Length ~ ., data=iris.dup)) > # expect.err(try(earth(Sepal.Length ~ ., data=iris.dup)), > # "Duplicate colname in x (colnames are \"Sepal.Width\", \"Petal.Length\", \"Petal.Width\", \"Species22\", \"Species23\", \"Species22\", \"Species23\")") > # expect.err(try(earth(iris.dup[,-1], iris.dup[,1])), > # "Duplicate colname in x (colnames are \"Sepal.Width\", \"Petal.Length\", \"Petal.Width\", \"Species22\", \"Species23\", \"Species22\", \"Species23\")") > > # check that lm has the same problem (but doesn't report it) > lm.dup <- lm(Sepal.Length ~ ., data=iris.dup) > stopifnot(identical(names(coef(lm.dup)), + c("(Intercept)", "Sepal.Width", "Petal.Length", "Petal.Width", + "Species22", "Species23", "Species22", "Species23"))) > > options(options.old) # no more width=1000 > > source("test.epilog.R") earth/inst/slowtests/test.earthc.out.save0000644000176200001440000050453014564111644020330 0ustar liggesusers============================================================================= 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.0078 0.0022 0.002234 0 -0.276 1 2 1 3 -0.0117 0.0034 0.001201 0 0.919 3 1 5 -0.0160 0.0042 0.0007921 0 0.891 4 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 5 terms, 4 terms used (DeltaRSq 0.00079) After forward pass GRSq -0.016 RSq 0.004 Forward pass complete: 5 terms, 4 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.0000 0.0015 2 0.0000 0.0022 3 0.0000 0.0034 Backward pass complete: selected 0 terms of 4, GRSq 0.000 RSq 0.000 RESULT 1: GRSq 0.0000 RSq 0.0000 nTerms 1 of 4 of 51 FUNCTION noise n=1000 p=1 [99.99 secs] TEST 1: FUNCTION noise n=1000 p=1 -0.161 // 0 ============================================================================= TEST 2: x0 n=10 p=1 y x0 0 -0.81000 -0.81000 1 -0.68100 -0.68100 2 -0.63900 -0.63900 3 -0.37100 -0.37100 4 -0.30300 -0.30300 5 0.23500 0.23500 6 0.32700 0.32700 7 0.40900 0.40900 8 0.58600 0.58600 9 0.77700 0.77700 earth.c version 5.3.3 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 3.04222 |Parent 0 Pred 0 Case -1 Cut -0.81< Rss 0 RssDelta 0 GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 1.0000 1.0000 1 0 -0.81< 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 -8.78e-18 | . | . 01 1 1 | 2 | linear 02 -- -- | -1 | -0.81 EvalSubsetsUsingXtx: nTerms iTerm DeltaRss RSq 2 1 3.0121 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 -8.78e-18 | . | . 01 1 1 | 2 | linear RESULT 2: GRSq 1.0000 RSq 1.0000 nTerms 2 of 2 of 51 FUNCTION x0 n=10 p=1 [99.99 secs] TEST 2: FUNCTION x0 n=10 p=1 -8.78e-18 // 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 0.0000 RSq 0.0000 nTerms 1 of 1 of 1 FUNCTION x0 n=10 p=1 [99.99 secs] TEST 3: FUNCTION x0 n=10 p=1 -0.047 // 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 0.0000 RSq 0.0000 nTerms 1 of 1 of 2 FUNCTION x0 n=10 p=1 [99.99 secs] TEST 4: FUNCTION x0 n=10 p=1 -0.047 // 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.999< 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.0000 RSq 1.0000 nTerms 2 of 2 of 51 FUNCTION x0 n=1000 p=1 [99.99 secs] TEST 5: FUNCTION x0 n=1000 p=1 7.02e-18 // 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.997< 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.0000 RSq 1.0000 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 2.81e-17 // 0 +1 * x[0] // 1 ============================================================================= TEST 7: x0 + x1 n=1000 p=2 y x0 x1 0 -0.83465 -0.99700 0.23500 1 -0.59490 -0.99700 0.40900 2 -0.67085 -0.99600 0.32700 3 -1.25240 -0.99600 -0.37100 4 -0.26395 -0.99400 0.77700 5 -1.59585 -0.98700 -0.53900 6 -1.03970 -0.98400 -0.26500 7 -1.58370 -0.98400 -0.54400 8 -0.63490 -0.98200 0.37400 9 -0.93700 -0.98200 0.09400 10 -1.58785 -0.97900 -0.59200 11 -1.91730 -0.97500 -0.77700 12 -1.13290 -0.97100 -0.20200 13 -0.19910 -0.97000 0.70100 14 -1.18845 -0.96700 -0.21700 15 -1.16210 -0.96300 -0.25700 16 -1.04860 -0.95900 -0.12600 17 -0.68290 -0.95800 0.19200 18 -0.59315 -0.95800 0.56900 19 -0.09750 -0.95400 0.80700 20 -2.00705 -0.95400 -0.95300 21 -0.95325 -0.94800 -0.05600 22 -0.72035 -0.94700 0.35500 23 -1.78625 -0.94500 -0.73300 24 -0.69975 -0.94500 0.27700 25 -0.88050 -0.94400 0.01100 26 -1.11780 -0.94400 -0.13600 27 -1.62420 -0.94100 -0.63000 28 -0.25955 -0.94000 0.80000 29 -1.86865 -0.93900 -0.87700 30 -0.52385 -0.93800 0.22300 31 -1.12985 -0.93700 -0.20000 32 -0.82815 -0.93600 -0.01300 33 -0.81025 -0.93600 0.15700 34 -1.01925 -0.93400 0.09700 35 -0.72505 -0.93000 0.20500 36 -1.83290 -0.92800 -0.71200 37 -1.27905 -0.92800 -0.13300 38 -0.74965 -0.92700 -0.00100 39 -1.12375 -0.91900 -0.34100 40 -0.74890 -0.91600 0.28900 41 -1.45560 -0.91200 -0.52500 42 -1.64410 -0.91100 -0.69300 43 -1.46965 -0.91100 -0.61200 44 -1.16095 -0.90700 -0.22200 45 -1.07570 -0.90500 -0.17900 46 -0.50365 -0.90400 0.45800 47 -1.47520 -0.89700 -0.58200 48 -0.67925 -0.89700 0.29300 49 -0.12635 -0.89700 0.76100 50 -0.43495 -0.89500 0.47300 51 -2.01450 -0.89500 -0.97100 52 0.05170 -0.89500 0.91700 53 -0.67050 -0.89400 0.35800 54 -0.67285 -0.89000 0.10000 55 -0.65200 -0.89000 0.22500 56 -0.63220 -0.88900 0.17900 57 -0.20145 -0.88700 0.78000 58 -1.80910 -0.88600 -0.76800 59 -0.59435 -0.88600 0.21300 60 -0.98055 -0.88200 -0.18800 61 -0.93190 -0.88200 -0.01300 62 -0.47090 -0.88100 0.24200 63 -0.73270 -0.88000 0.14100 64 -0.13145 -0.87800 0.60800 65 -1.22615 -0.87500 -0.32600 66 -1.85105 -0.87300 -0.87400 67 -1.10630 -0.87300 -0.21500 68 -1.66680 -0.87000 -0.85900 69 -0.04170 -0.86300 0.83300 70 -1.69005 -0.86100 -0.80600 71 -1.17155 -0.85900 -0.30900 72 -1.38305 -0.85400 -0.49400 73 0.20820 -0.85300 0.97500 74 -1.75685 -0.85200 -0.99200 75 -0.67255 -0.84000 0.22100 76 -0.62220 -0.83700 0.23700 77 -1.26875 -0.83600 -0.57800 78 -0.99950 -0.83100 -0.03300 79 -1.37195 -0.83000 -0.42300 80 -0.45155 -0.82600 0.23700 81 -0.16175 -0.82400 0.55300 82 -0.60940 -0.82200 0.13000 83 -1.26055 -0.82200 -0.35300 84 -1.28200 -0.82100 -0.57500 85 -1.30685 -0.82000 -0.37900 86 -1.16720 -0.81800 -0.47200 87 -0.02910 -0.81700 0.85100 88 -0.62860 -0.81500 0.08700 89 -1.28120 -0.81400 -0.44300 90 0.12955 -0.81000 0.94600 91 -1.31945 -0.81000 -0.45200 92 -0.16925 -0.81000 0.64500 93 -1.00390 -0.80200 -0.25200 94 -1.33045 -0.79900 -0.56700 95 -1.03895 -0.79700 -0.29800 96 0.00030 -0.79700 0.74000 97 -1.41750 -0.79700 -0.80100 98 0.00090 -0.79600 0.96500 99 -0.87990 -0.79400 0.01700 100 -0.54300 -0.79400 0.25600 101 -0.38875 -0.79400 0.26400 102 0.14590 -0.79200 0.91800 103 -0.60930 -0.79000 0.09500 104 0.06010 -0.78900 0.76200 105 -1.30710 -0.78800 -0.30000 106 0.31220 -0.78700 0.92700 107 -0.15965 -0.78700 0.69800 108 -1.07870 -0.78600 -0.34600 109 -0.09035 -0.78200 0.73400 110 -1.38485 -0.78100 -0.45800 111 -1.57420 -0.78000 -0.67600 112 -0.49275 -0.77900 0.23600 113 -0.31495 -0.77700 0.46600 114 -0.22215 -0.77600 0.51800 115 -1.04990 -0.77500 -0.26700 116 -1.38295 -0.77500 -0.85300 117 -0.46880 -0.77500 0.29100 118 -1.18580 -0.77400 -0.33800 119 -0.13610 -0.77100 0.64900 120 -0.27220 -0.77000 0.62600 121 -0.80475 -0.76900 0.10200 122 -0.67490 -0.76900 0.07900 123 -1.95140 -0.76600 -0.99300 124 -1.61635 -0.76600 -0.79500 125 -0.68390 -0.76300 0.13200 126 0.17805 -0.75900 0.91300 127 -0.67900 -0.75600 0.08300 128 -1.77670 -0.75500 -0.89800 129 -1.62150 -0.75500 -0.64400 130 -0.67990 -0.75400 0.31800 131 -1.33180 -0.75200 -0.60300 132 -1.30470 -0.74900 -0.59900 133 -0.96840 -0.74900 -0.32100 134 -1.65160 -0.74600 -0.84300 135 -0.28015 -0.74400 0.56800 136 -1.36510 -0.74400 -0.66500 137 -1.05320 -0.74300 -0.39800 138 -1.48440 -0.74200 -0.90300 139 -1.34275 -0.74100 -0.58800 140 -1.67170 -0.74000 -0.80300 141 -0.59575 -0.73700 0.14300 142 -1.42950 -0.73500 -0.73600 143 -1.50000 -0.73300 -0.78000 144 -0.87450 -0.73100 -0.03000 145 -1.29095 -0.73100 -0.68400 146 -1.33740 -0.73100 -0.69900 147 -0.78280 -0.72700 -0.02400 148 -0.88315 -0.72500 -0.18800 149 0.10615 -0.72400 0.85000 150 -0.36640 -0.72300 0.21400 151 -0.07665 -0.72200 0.74000 152 -1.13395 -0.72200 -0.42900 153 -1.13475 -0.72100 -0.20900 154 -1.18915 -0.72000 -0.37800 155 0.11130 -0.71900 0.91100 156 -1.39720 -0.71700 -0.68500 157 -1.53385 -0.71500 -0.58700 158 -0.85035 -0.71500 -0.27600 159 -0.26235 -0.71400 0.50100 160 0.16740 -0.71100 0.79900 161 -0.86075 -0.70800 0.08200 162 -0.39575 -0.70700 0.27400 163 -0.83310 -0.70700 0.03800 164 -1.07505 -0.70300 -0.27100 165 -0.52665 -0.70200 0.21400 166 -1.74855 -0.70200 -0.95300 167 -0.99150 -0.70200 -0.34700 168 -0.08110 -0.70100 0.73100 169 -1.18075 -0.69700 -0.52100 170 -1.48550 -0.69500 -0.83500 171 -1.35525 -0.69300 -0.66300 172 -1.08700 -0.69000 -0.19000 173 -0.62515 -0.68900 0.11200 174 0.26885 -0.68500 0.82800 175 -0.26615 -0.68400 0.36700 176 -1.29620 -0.68100 -0.49900 177 0.12260 -0.68100 0.76500 178 -1.21340 -0.68000 -0.54700 179 -0.52800 -0.67800 0.21500 180 0.06050 -0.67700 0.76200 181 -1.26675 -0.67700 -0.60700 182 -0.77600 -0.67600 -0.25600 183 -0.90540 -0.67400 -0.14200 184 -1.30760 -0.67300 -0.45400 185 -1.41490 -0.67300 -0.84700 186 -0.65255 -0.67200 0.18300 187 -0.02865 -0.66600 0.89100 188 -1.45895 -0.66500 -0.81600 189 -0.09960 -0.66400 0.55100 190 -0.88085 -0.66400 -0.24800 191 -0.89660 -0.66300 -0.21300 192 0.05375 -0.66200 0.54900 193 -0.59640 -0.65400 -0.00100 194 -0.46330 -0.64500 -0.00100 195 -0.57415 -0.64200 -0.02900 196 -1.34310 -0.64000 -0.45700 197 0.05210 -0.63900 0.92500 198 -0.77070 -0.63700 -0.19800 199 -1.23510 -0.63700 -0.49100 200 -0.17475 -0.63400 0.23000 201 -1.37210 -0.63200 -0.71500 202 -0.02425 -0.63100 0.69900 203 -1.49690 -0.62900 -0.93300 204 0.19545 -0.62900 0.66100 205 -1.60755 -0.62700 -0.97500 206 -0.28860 -0.62500 0.31400 207 0.04555 -0.62400 0.55900 208 0.38500 -0.62400 0.97500 209 -0.63465 -0.62300 0.09500 210 -0.04605 -0.62300 0.64000 211 -0.39780 -0.62100 0.37000 212 0.31540 -0.61800 0.95900 213 -1.16450 -0.61600 -0.36700 214 0.19015 -0.61500 0.89300 215 -0.21460 -0.61200 0.35800 216 -0.13660 -0.61100 0.32700 217 -1.02045 -0.60600 -0.43700 218 -1.35270 -0.60600 -0.78200 219 -0.86295 -0.60500 -0.26900 220 -0.28370 -0.60200 0.33000 221 -0.74035 -0.60000 -0.18400 222 -1.27795 -0.59900 -0.72800 223 -1.07215 -0.59600 -0.37900 224 0.15065 -0.59600 0.99400 225 -1.18595 -0.59200 -0.65100 226 -0.73905 -0.59200 -0.18500 227 -1.29510 -0.58500 -0.69200 228 -0.09515 -0.58500 0.45900 229 -0.72075 -0.58400 -0.28300 230 -0.08140 -0.58300 0.56000 231 -1.14395 -0.58100 -0.54900 232 -1.33325 -0.57800 -0.66600 233 -0.30870 -0.57800 0.12300 234 -1.20585 -0.57300 -0.65200 235 -1.02690 -0.56700 -0.42300 236 0.40895 -0.56500 0.99900 237 0.37540 -0.56400 0.88300 238 0.36275 -0.56000 0.95400 239 -1.43265 -0.55900 -0.79600 240 -0.91130 -0.55800 -0.31300 241 -0.66890 -0.55500 -0.26300 242 -0.06445 -0.55500 0.60500 243 -1.16460 -0.55400 -0.48700 244 -0.88070 -0.55300 -0.25300 245 0.36655 -0.55100 0.89600 246 0.46285 -0.55000 0.98700 247 0.55480 -0.54800 0.97300 248 -1.24670 -0.54700 -0.69300 249 -0.99090 -0.54000 -0.45100 250 -1.06690 -0.53900 -0.66400 251 -1.27935 -0.53700 -0.63300 252 -0.83665 -0.53200 -0.26900 253 -0.23420 -0.53200 0.17000 254 -0.35325 -0.53100 0.16900 255 -1.06080 -0.53000 -0.39700 256 0.23800 -0.52900 0.85300 257 -0.56330 -0.52700 -0.01200 258 -1.49670 -0.52300 -0.80700 259 -1.27940 -0.52200 -0.68700 260 -1.09585 -0.52100 -0.45000 261 -1.15280 -0.51700 -0.66000 262 -1.16740 -0.51700 -0.69600 263 -0.25660 -0.51300 0.40400 264 -1.27100 -0.51300 -0.67500 265 -0.90310 -0.51100 -0.35900 266 -1.35880 -0.51000 -0.85800 267 -0.98510 -0.50900 -0.54000 268 0.34670 -0.50700 0.91900 269 -0.36780 -0.50500 0.06900 270 0.36575 -0.50400 0.82800 271 -1.39635 -0.50200 -0.98000 272 -0.32195 -0.49800 0.08500 273 0.35060 -0.49600 0.97200 274 -1.13760 -0.49500 -0.52400 275 -0.25925 -0.49500 0.33200 276 0.50270 -0.49300 0.85200 277 -1.12480 -0.49200 -0.33600 278 0.26550 -0.48800 0.97200 279 0.39925 -0.48300 0.82400 280 -1.12575 -0.48200 -0.50800 281 -0.63935 -0.48200 -0.28000 282 -0.96680 -0.47900 -0.47200 283 -0.65395 -0.47700 -0.18400 284 -0.77905 -0.47200 -0.32600 285 -0.90220 -0.47200 -0.58000 286 -0.14520 -0.47000 0.25300 287 0.46615 -0.46900 0.95000 288 -1.30120 -0.46700 -0.76900 289 0.04940 -0.46700 0.61800 290 -0.72500 -0.46400 -0.31400 291 -1.11615 -0.46300 -0.66900 292 -1.18405 -0.46100 -0.80200 293 -0.93065 -0.46100 -0.30000 294 -0.68115 -0.46000 -0.36600 295 0.24670 -0.45800 0.91400 296 -0.42340 -0.45700 0.17000 297 -0.70950 -0.45700 -0.28800 298 0.08470 -0.45300 0.49900 299 -0.72495 -0.45200 -0.30900 300 0.03575 -0.45100 0.43700 301 -1.38910 -0.45000 -0.95300 302 -0.09945 -0.44900 0.40100 303 0.40530 -0.44800 0.95300 304 0.24815 -0.44700 0.69800 305 -0.33895 -0.44600 0.23000 306 0.43935 -0.44500 0.99800 307 -0.68640 -0.44500 -0.10000 308 -0.86715 -0.43900 -0.38000 309 -1.01030 -0.43700 -0.73600 310 -0.72525 -0.43700 -0.12800 311 0.01420 -0.43500 0.64800 312 0.00235 -0.43300 0.27600 313 0.19885 -0.43100 0.60200 314 -0.89890 -0.42800 -0.36600 315 -0.74390 -0.42600 -0.52400 316 -0.16445 -0.42300 0.36800 317 0.56945 -0.42200 0.99000 318 0.11920 -0.42200 0.64200 319 -0.89770 -0.42000 -0.27500 320 -0.84350 -0.41800 -0.38600 321 -0.61725 -0.41500 -0.13500 322 -1.09820 -0.41500 -0.77200 323 -0.31815 -0.41200 0.16100 324 0.38100 -0.40900 0.94100 325 -1.48950 -0.40800 -0.91500 326 -0.58375 -0.40700 -0.16200 327 -1.36570 -0.40700 -0.86000 328 -0.94275 -0.40700 -0.54700 329 -0.75875 -0.40700 -0.48100 330 -0.14900 -0.40600 0.21900 331 0.56590 -0.40500 0.86100 332 -1.31165 -0.40200 -0.81400 333 0.69065 -0.40200 0.96900 334 -0.75170 -0.40000 -0.24800 335 -1.36015 -0.39900 -0.74200 336 -1.33020 -0.39700 -0.79500 337 0.38495 -0.39500 0.79300 338 0.44575 -0.39500 0.83400 339 -0.26540 -0.39500 0.13600 340 -1.26645 -0.39500 -0.99000 341 -1.06990 -0.39400 -0.59100 342 0.13960 -0.39000 0.62900 343 -0.80660 -0.39000 -0.43600 344 0.29500 -0.38900 0.66700 345 -0.86985 -0.38900 -0.42700 346 0.20340 -0.38700 0.64600 347 -0.55175 -0.38700 -0.09800 348 -0.21360 -0.38300 0.09900 349 0.21845 -0.38300 0.68800 350 -0.67210 -0.38100 -0.38900 351 -1.11770 -0.37900 -0.85600 352 -0.64195 -0.37800 -0.12400 353 -0.50030 -0.37700 -0.03200 354 -0.63690 -0.37700 -0.32300 355 -0.52715 -0.37600 -0.08500 356 -0.71440 -0.37600 -0.07000 357 -1.02000 -0.37300 -0.60300 358 -0.39510 -0.37300 -0.01900 359 -1.38820 -0.37200 -0.83800 360 -1.17815 -0.37200 -0.85800 361 -0.54570 -0.37000 -0.13800 362 -0.33925 -0.36300 -0.05200 363 0.40050 -0.36300 0.71700 364 -0.76620 -0.36200 -0.35600 365 -1.23350 -0.36000 -0.93200 366 0.29220 -0.35400 0.57700 367 0.18640 -0.35400 0.57500 368 -0.36010 -0.34800 0.13400 369 0.05110 -0.34600 0.32400 370 0.41510 -0.34000 0.72800 371 -0.65185 -0.33900 -0.35200 372 -0.58880 -0.33800 -0.40200 373 -0.00750 -0.33700 0.19300 374 -0.59195 -0.33700 -0.19500 375 -0.06120 -0.33600 0.30800 376 -0.88225 -0.33300 -0.40900 377 -1.22700 -0.33300 -0.84000 378 0.60665 -0.33300 0.86900 379 -0.22065 -0.33000 0.25900 380 -1.35620 -0.33000 -0.92300 381 0.32420 -0.32900 0.70700 382 0.23210 -0.32400 0.58100 383 -0.41595 -0.32300 0.03900 384 -0.38920 -0.32100 -0.03200 385 -0.51870 -0.32100 0.01500 386 -0.94305 -0.32000 -0.56800 387 -1.11155 -0.31900 -0.91100 388 -0.90465 -0.31700 -0.29800 389 -0.28115 -0.31400 0.15800 390 0.00015 -0.31400 0.35000 391 -1.27535 -0.31300 -0.86000 392 -0.95655 -0.31200 -0.71400 393 -0.87580 -0.31000 -0.53900 394 -0.99345 -0.30900 -0.74400 395 -1.35200 -0.30800 -0.92000 396 -0.11770 -0.30700 0.21300 397 0.52685 -0.30400 0.95900 398 -0.72705 -0.30300 -0.27500 399 -1.04610 -0.29800 -0.84000 400 -1.05050 -0.29600 -0.83500 401 -0.65875 -0.29500 -0.36000 402 0.38730 -0.29100 0.80800 403 0.67900 -0.29100 0.82100 404 0.26215 -0.29000 0.64900 405 -0.11660 -0.28800 0.09800 406 0.47000 -0.28700 0.80700 407 -1.16225 -0.28400 -0.76700 408 -0.62025 -0.28400 -0.24600 409 0.57090 -0.28100 0.74000 410 0.30010 -0.28000 0.83000 411 0.02555 -0.27900 0.56400 412 0.07125 -0.27800 0.35700 413 0.47005 -0.27600 0.85400 414 -0.13675 -0.27300 0.29000 415 0.42950 -0.27100 0.85900 416 0.16225 -0.26300 0.53100 417 0.00615 -0.26300 0.24700 418 -0.51640 -0.26300 -0.41800 419 0.22265 -0.25800 0.56400 420 -0.78610 -0.25600 -0.59200 421 -0.98090 -0.25600 -0.72900 422 -0.49835 -0.25400 -0.22300 423 0.14065 -0.25200 0.38700 424 -1.13415 -0.25100 -0.91600 425 0.38725 -0.25000 0.65300 426 -1.12980 -0.24800 -0.97800 427 0.72520 -0.24700 0.92800 428 0.32080 -0.24600 0.60500 429 0.30545 -0.24600 0.64200 430 0.17835 -0.24400 0.42700 431 0.01495 -0.24400 0.42200 432 0.17090 -0.24000 0.36200 433 -0.53250 -0.23900 -0.36500 434 -0.74630 -0.23700 -0.41400 435 -1.22130 -0.23500 -0.97000 436 -0.10950 -0.23000 -0.03000 437 -0.61495 -0.23000 -0.31700 438 0.69500 -0.22900 0.96300 439 -1.23220 -0.22900 -0.92600 440 0.72870 -0.22800 0.85100 441 -0.02065 -0.22800 0.07200 442 -0.50420 -0.22600 -0.39900 443 -0.84825 -0.22400 -0.78200 444 0.28105 -0.21800 0.61200 445 0.37110 -0.21700 0.55300 446 0.00695 -0.21700 0.16000 447 0.18185 -0.21300 0.43500 448 0.08080 -0.20700 0.28300 449 0.17075 -0.20600 0.51800 450 -0.21485 -0.20500 0.06100 451 0.56695 -0.20400 0.83500 452 0.39000 -0.20200 0.58300 453 -1.36935 -0.19900 -0.97600 454 -1.38265 -0.19800 -0.98600 455 -1.16590 -0.19600 -0.93800 456 -0.56460 -0.19300 -0.34400 457 -0.45150 -0.19200 -0.14700 458 -0.15200 -0.19100 0.04600 459 0.53010 -0.18800 0.85200 460 -0.30160 -0.18800 -0.01400 461 -0.58970 -0.18600 -0.26700 462 -0.91130 -0.17100 -0.77300 463 0.44885 -0.16700 0.61600 464 0.42420 -0.16500 0.63800 465 -0.61315 -0.16400 -0.40900 466 -1.09275 -0.16000 -0.80900 467 -0.88030 -0.15800 -0.57300 468 0.43710 -0.15400 0.52100 469 -0.68930 -0.15400 -0.57100 470 0.29455 -0.15100 0.45000 471 0.75690 -0.14800 0.95100 472 -0.87840 -0.14800 -0.87700 473 -0.64720 -0.14800 -0.70000 474 0.11130 -0.14500 0.17400 475 0.54245 -0.14500 0.54000 476 -0.46640 -0.14200 -0.33600 477 -0.48430 -0.14100 -0.38700 478 0.27835 -0.13900 0.46600 479 0.62925 -0.13700 0.75100 480 0.15130 -0.13500 0.33000 481 -0.43395 -0.13400 -0.46600 482 0.47740 -0.13400 0.72700 483 -0.73800 -0.13300 -0.45000 484 -0.59670 -0.13100 -0.38600 485 -0.38650 -0.12800 -0.21400 486 0.28990 -0.12600 0.43000 487 -0.48495 -0.12500 -0.29100 488 -0.25185 -0.12300 -0.10100 489 0.04245 -0.12000 0.16500 490 0.68130 -0.12000 0.74400 491 0.52200 -0.11500 0.59600 492 0.74530 -0.11500 0.83800 493 -1.35435 -0.11100 -0.99900 494 -0.66750 -0.11000 -0.64300 495 -0.35585 -0.10800 -0.08200 496 0.46800 -0.10800 0.52000 497 0.55425 -0.10600 0.70700 498 -0.74390 -0.10200 -0.63400 499 -0.89025 -0.10100 -0.91600 500 -0.95600 -0.09900 -0.81800 501 -0.62095 -0.09700 -0.56900 502 -0.95320 -0.09600 -0.94100 503 0.25535 -0.09400 0.36800 504 -0.85730 -0.08900 -0.80800 505 -0.55690 -0.08800 -0.58400 506 0.36650 -0.08800 0.39000 507 0.02365 -0.08700 0.16300 508 0.99895 -0.08300 0.95500 509 -0.60155 -0.08300 -0.54400 510 0.35490 -0.07800 0.32500 511 0.31125 -0.07700 0.33500 512 0.06415 -0.07400 0.15900 513 0.84185 -0.07300 0.68700 514 0.00805 -0.07100 -0.02000 515 -0.93600 -0.06900 -0.79500 516 -0.54235 -0.06900 -0.43000 517 0.47220 -0.06900 0.61100 518 0.76270 -0.06800 0.77600 519 0.71010 -0.06800 0.79200 520 0.94585 -0.06300 0.93100 521 -0.07450 -0.06300 0.00500 522 -0.93000 -0.06000 -0.85100 523 -0.09780 -0.05800 -0.01600 524 -0.00715 -0.05800 0.02400 525 0.38505 -0.05600 0.52400 526 -0.26750 -0.05500 -0.33500 527 -0.31425 -0.05500 -0.18300 528 0.24445 -0.05100 0.45600 529 0.08700 -0.05100 0.26400 530 -0.35235 -0.04800 -0.22500 531 0.69135 -0.04700 0.68900 532 0.12750 -0.04200 0.14600 533 0.65955 -0.04000 0.63200 534 1.02160 -0.03900 0.96600 535 -0.20965 -0.03800 -0.32200 536 -0.65410 -0.03500 -0.39600 537 -0.55160 -0.03100 -0.66800 538 0.44035 -0.02900 0.47100 539 0.79255 -0.02700 0.86900 540 -0.44515 -0.02500 -0.46000 541 -0.48260 -0.02100 -0.57200 542 -0.52745 -0.01500 -0.45300 543 -0.06390 -0.00800 -0.06000 544 -0.43485 -0.00500 -0.35700 545 0.50210 0.00200 0.67900 546 1.07100 0.00800 0.90600 547 -0.02470 0.00900 -0.08700 548 0.17365 0.01000 0.06900 549 -0.69310 0.01100 -0.59500 550 -0.26285 0.02400 -0.34800 551 -0.53675 0.02600 -0.68000 552 -0.07620 0.02700 -0.04600 553 -0.87380 0.02900 -0.75500 554 0.57560 0.03000 0.44400 555 -0.12860 0.03000 -0.00700 556 -0.57780 0.03300 -0.44000 557 -0.13100 0.03500 -0.15900 558 -0.28830 0.03600 -0.15200 559 0.98820 0.03700 0.95200 560 0.97805 0.04000 0.97500 561 -0.70415 0.04100 -0.84400 562 -0.73580 0.04600 -0.60500 563 -0.82150 0.05300 -0.68500 564 0.84115 0.05300 0.75500 565 -0.84325 0.05400 -0.86900 566 -0.23410 0.05500 -0.50100 567 0.99365 0.05500 0.84700 568 0.80660 0.05900 0.98200 569 0.02760 0.05900 0.04100 570 -0.99815 0.06100 -0.97300 571 0.79095 0.06300 0.59600 572 1.09790 0.07200 0.86000 573 -0.68555 0.07600 -0.58300 574 0.11320 0.07700 0.01800 575 0.44230 0.07800 0.39700 576 -0.72075 0.07900 -0.49900 577 0.10135 0.08200 0.13600 578 0.38585 0.08600 0.21100 579 -0.19545 0.08600 -0.29500 580 -0.62600 0.08800 -0.58600 581 -0.15645 0.08800 -0.31200 582 -0.09535 0.08900 -0.18900 583 0.28030 0.09000 0.22000 584 -0.78020 0.09200 -0.98500 585 -0.45865 0.10400 -0.46600 586 -0.04230 0.10700 -0.10700 587 0.04665 0.10800 -0.01800 588 -0.29040 0.11500 -0.45700 589 -0.17895 0.11800 -0.20300 590 0.03435 0.11800 -0.01500 591 0.01005 0.12100 -0.11700 592 0.05880 0.12300 -0.24400 593 1.05965 0.12500 0.96900 594 0.07705 0.12700 -0.11100 595 0.54235 0.13100 0.41700 596 0.91595 0.13300 0.73900 597 -0.47275 0.13400 -0.59500 598 0.17040 0.13700 0.06700 599 -0.06740 0.14000 -0.23500 600 -0.80560 0.14100 -0.89800 601 0.53630 0.14200 0.45400 602 -0.89965 0.14800 -0.95000 603 0.71280 0.15300 0.59100 604 0.17045 0.15900 -0.03100 605 0.90445 0.16600 0.76500 606 0.18975 0.16700 0.01300 607 -0.64175 0.16800 -0.61400 608 1.08465 0.16900 0.83600 609 0.05180 0.16900 -0.23900 610 -0.41670 0.17400 -0.55400 611 -0.14330 0.17800 -0.07500 612 1.02685 0.18100 0.75700 613 0.64570 0.18400 0.59400 614 -0.30685 0.18900 -0.38100 615 -0.33830 0.19100 -0.42800 616 1.07635 0.19200 0.85100 617 0.08830 0.19200 -0.02500 618 0.11490 0.19200 -0.08700 619 0.37755 0.19500 0.15900 620 -0.47250 0.19500 -0.47700 621 -0.12285 0.19600 -0.37500 622 0.56485 0.19900 0.54000 623 -0.09505 0.20100 -0.28600 624 0.22875 0.20600 0.09500 625 0.06375 0.20600 -0.17000 626 -0.71810 0.20900 -0.99900 627 -0.25925 0.21700 -0.46900 628 -0.40030 0.21800 -0.55800 629 0.98375 0.22200 0.78400 630 -0.40710 0.22200 -0.77100 631 0.57505 0.22500 0.40000 632 -0.47470 0.22700 -0.64300 633 0.89295 0.22900 0.79500 634 0.92185 0.23100 0.84200 635 1.06805 0.23300 0.79000 636 -0.84340 0.23300 -0.92300 637 1.11570 0.23700 0.89800 638 -0.20865 0.23700 -0.58300 639 -0.01280 0.24200 -0.26100 640 0.18090 0.24400 -0.09300 641 1.25785 0.24500 0.94600 642 -0.41320 0.24600 -0.68500 643 -0.56110 0.24600 -0.62700 644 1.09975 0.25100 0.86600 645 -0.73015 0.25200 -0.81900 646 -0.65685 0.26400 -0.93800 647 -0.14890 0.26700 -0.46400 648 -0.30820 0.27100 -0.49100 649 0.90805 0.27400 0.52100 650 0.33665 0.27700 0.07100 651 0.10505 0.28600 -0.11500 652 0.93435 0.28700 0.83000 653 -0.44595 0.28900 -0.75400 654 0.72455 0.29100 0.36200 655 -0.29710 0.29100 -0.53100 656 1.30940 0.29100 0.90400 657 -0.39845 0.29300 -0.67600 658 0.48565 0.29300 0.09100 659 1.03025 0.29700 0.88200 660 0.10825 0.29700 -0.17800 661 1.10715 0.29700 0.97800 662 -0.48550 0.30000 -0.83900 663 0.33950 0.30300 -0.13000 664 0.39520 0.30500 -0.01400 665 0.34860 0.30500 -0.02400 666 1.10215 0.30900 0.93300 667 0.25595 0.31000 -0.02200 668 0.70455 0.31000 0.47100 669 1.01235 0.31400 0.85500 670 0.83650 0.31600 0.50400 671 -0.28795 0.32100 -0.55900 672 -0.76585 0.32300 -0.95300 673 0.62935 0.32400 0.39500 674 0.35185 0.33000 0.13800 675 0.85170 0.33000 0.62600 676 -0.06130 0.33100 -0.33800 677 0.85870 0.33100 0.58400 678 0.85860 0.33500 0.50800 679 0.89450 0.33500 0.65700 680 0.13940 0.33600 -0.27500 681 0.33005 0.33600 -0.03000 682 -0.49840 0.33800 -0.75300 683 0.51260 0.33800 0.13400 684 -0.06875 0.33900 -0.52100 685 0.70425 0.33900 0.35500 686 -0.37650 0.34000 -0.85400 687 0.92450 0.34200 0.55700 688 0.59445 0.34700 0.24700 689 -0.13720 0.35000 -0.42300 690 0.73365 0.35200 0.44000 691 0.27670 0.35600 0.00500 692 -0.55460 0.35900 -0.77500 693 0.36845 0.36200 0.08600 694 -0.60710 0.36300 -0.80900 695 0.09035 0.36400 -0.31900 696 0.19190 0.36600 -0.08300 697 1.43955 0.36800 0.99000 698 0.76135 0.37800 0.39400 699 -0.09140 0.37800 -0.21400 700 0.10845 0.38300 -0.40900 701 1.21805 0.38300 0.82800 702 0.31970 0.38400 -0.07200 703 1.00995 0.39000 0.55400 704 0.09655 0.39100 -0.25400 705 0.35530 0.39200 -0.03500 706 0.99690 0.39400 0.62000 707 0.77655 0.39700 0.48300 708 0.29375 0.39700 -0.08800 709 0.70150 0.39800 0.32300 710 1.03240 0.39900 0.70700 711 0.35625 0.40200 -0.13800 712 0.08140 0.40200 -0.45300 713 0.68715 0.40300 0.27600 714 -0.21540 0.40300 -0.52700 715 1.04800 0.40400 0.73200 716 -0.53085 0.40800 -0.89700 717 0.62765 0.40900 0.10500 718 1.32100 0.41000 0.97200 719 -0.17860 0.41200 -0.76700 720 -0.57205 0.41300 -0.96300 721 0.89445 0.41300 0.63900 722 0.67635 0.41800 0.17400 723 0.81645 0.42100 0.35600 724 -0.19810 0.42200 -0.62200 725 0.26740 0.42400 -0.18300 726 0.31345 0.42500 -0.04000 727 -0.16395 0.42600 -0.58400 728 1.05100 0.42800 0.62200 729 1.09410 0.42800 0.74800 730 0.56515 0.43400 0.21800 731 0.95120 0.43500 0.53400 732 0.63260 0.43800 0.26200 733 -0.29815 0.43800 -0.60700 734 1.29740 0.43900 0.73200 735 -0.07770 0.44000 -0.47100 736 0.35320 0.44100 -0.12600 737 -0.49945 0.44400 -0.87300 738 0.59905 0.44900 0.31200 739 0.48200 0.44900 0.28800 740 -0.06455 0.45400 -0.46400 741 0.76585 0.45500 0.30300 742 -0.32440 0.45800 -0.73900 743 0.01620 0.45800 -0.30500 744 1.41420 0.45900 0.94300 745 1.00580 0.46100 0.54200 746 1.21080 0.46100 0.70100 747 1.27970 0.46200 0.65400 748 0.64970 0.46300 0.18100 749 1.39985 0.46700 0.95800 750 -0.52955 0.47000 -0.92800 751 1.48780 0.47300 0.90500 752 0.56630 0.47300 -0.19900 753 1.66520 0.47400 0.94100 754 0.30985 0.47400 -0.19300 755 0.57425 0.47500 0.23900 756 1.27385 0.47600 0.85700 757 -0.14125 0.47700 -0.49900 758 1.18645 0.47800 0.79400 759 -0.15420 0.47900 -0.65300 760 -0.46295 0.48100 -0.97000 761 0.69030 0.48700 0.24200 762 0.02385 0.48700 -0.52500 763 1.18485 0.49000 0.62200 764 0.50110 0.49100 -0.07700 765 0.36465 0.49300 -0.02500 766 0.72590 0.49800 0.03300 767 0.56720 0.50000 -0.03700 768 0.50100 0.50100 0.15400 769 -0.16635 0.50300 -0.72700 770 0.57265 0.50600 -0.08200 771 -0.31695 0.50700 -0.69500 772 0.71450 0.50900 0.07000 773 1.09345 0.51100 0.81100 774 1.31495 0.51900 0.92100 775 0.39620 0.52100 -0.14700 776 1.21530 0.52200 0.73000 777 -0.22230 0.52400 -0.81600 778 0.64340 0.52600 0.19600 779 0.61250 0.52700 0.02900 780 0.77440 0.52800 0.34500 781 0.42025 0.52800 0.06800 782 0.00175 0.53100 -0.47400 783 0.29085 0.53500 -0.17000 784 0.20460 0.53600 -0.24400 785 1.08055 0.53600 0.53200 786 -0.08555 0.54200 -0.53300 787 0.51420 0.54300 -0.12200 788 0.86745 0.54600 0.15900 789 0.15340 0.54600 -0.38300 790 0.63695 0.54700 -0.12900 791 -0.38555 0.54900 -0.94100 792 -0.04125 0.54900 -0.62000 793 0.09330 0.55000 -0.38300 794 0.43595 0.55100 -0.07300 795 0.50425 0.56000 0.06700 796 1.20665 0.56300 0.86200 797 0.23820 0.56500 -0.38700 798 1.39880 0.56700 0.87300 799 -0.00795 0.56800 -0.46300 800 1.05930 0.56800 0.45500 801 1.00805 0.57000 0.34000 802 0.39930 0.57300 -0.24200 803 -0.24565 0.57400 -0.81700 804 0.49710 0.57500 -0.10100 805 0.23555 0.57500 -0.24900 806 -0.17160 0.57600 -0.71300 807 1.41535 0.57600 0.87800 808 1.43815 0.57800 0.87500 809 1.22290 0.58400 0.53900 810 1.03655 0.58400 0.37300 811 1.00165 0.58500 0.29600 812 0.22540 0.58500 -0.38900 813 1.03625 0.58600 0.66600 814 0.58950 0.58700 0.03100 815 0.00350 0.58900 -0.58600 816 0.35405 0.59300 -0.10800 817 0.76810 0.59500 0.30600 818 0.16050 0.59800 -0.33600 819 0.62905 0.60300 0.04200 820 -0.50600 0.60600 -0.90900 821 0.04740 0.61500 -0.50700 822 1.81270 0.61900 0.98300 823 0.57375 0.61900 0.05500 824 0.46400 0.62000 -0.16800 825 1.37330 0.62200 0.63100 826 0.19310 0.62500 -0.58700 827 1.37905 0.62600 0.80400 828 -0.02195 0.62900 -0.71300 829 -0.07370 0.62900 -0.73300 830 0.94845 0.63000 0.37000 831 1.19780 0.63000 0.62000 832 0.16360 0.63300 -0.50100 833 0.25960 0.63700 -0.28100 834 0.53035 0.64200 -0.23100 835 1.52365 0.64200 0.88100 836 1.28445 0.64900 0.55800 837 0.54955 0.66100 -0.12500 838 1.16855 0.66300 0.64700 839 1.59925 0.66400 0.93200 840 0.81230 0.66400 0.19400 841 1.23990 0.66500 0.55800 842 0.64315 0.66500 0.03200 843 1.48480 0.66800 0.81500 844 1.57120 0.67000 0.84300 845 -0.12295 0.67000 -0.86300 846 0.04430 0.67100 -0.56600 847 0.59760 0.67200 -0.08500 848 0.08315 0.67200 -0.57300 849 0.90075 0.67400 0.31300 850 1.22475 0.67400 0.52800 851 1.49400 0.67700 0.95400 852 0.59395 0.67800 0.14900 853 0.25035 0.68300 -0.39100 854 0.44425 0.68400 -0.16000 855 1.15045 0.68700 0.68700 856 0.00770 0.68800 -0.60600 857 0.23830 0.68900 -0.57000 858 0.19410 0.69000 -0.61000 859 1.59015 0.69200 0.84900 860 0.90865 0.69500 0.25500 861 0.54875 0.69500 -0.02200 862 -0.08750 0.70100 -0.89800 863 1.72595 0.70300 0.89100 864 1.15840 0.70700 0.38900 865 -0.03260 0.70900 -0.65400 866 -0.28050 0.71100 -0.96200 867 0.51345 0.71200 -0.41700 868 0.82580 0.71500 -0.03300 869 1.39280 0.71700 0.62300 870 -0.39395 0.71700 -0.93400 871 0.04415 0.71700 -0.67400 872 0.63680 0.71800 -0.11300 873 1.56175 0.71800 0.80900 874 1.55380 0.71900 0.82200 875 0.44340 0.71900 -0.20600 876 1.18470 0.72100 0.52200 877 0.69720 0.72700 -0.05700 878 -0.08075 0.73300 -0.56900 879 1.41510 0.73400 0.74100 880 1.48705 0.73400 0.88800 881 1.73260 0.73500 0.98400 882 0.60055 0.73600 -0.19800 883 1.60960 0.73900 0.91800 884 0.61440 0.74100 -0.09100 885 0.16990 0.74500 -0.70600 886 0.26885 0.74600 -0.53200 887 0.49700 0.74700 -0.30900 888 1.49055 0.75200 0.69100 889 -0.45615 0.75400 -0.99500 890 0.69905 0.75700 0.00000 891 -0.06230 0.76000 -0.63000 892 0.01125 0.76600 -0.79500 893 -0.01480 0.76700 -0.83200 894 0.06645 0.77300 -0.57900 895 0.63440 0.77500 -0.04900 896 0.23010 0.77500 -0.61900 897 0.10395 0.77600 -0.61900 898 0.19095 0.77600 -0.49900 899 0.97195 0.78000 0.24900 900 1.67640 0.79000 0.89500 901 0.94445 0.79200 -0.02000 902 0.84040 0.79600 0.06300 903 0.77860 0.80300 0.22100 904 0.29885 0.80400 -0.46100 905 0.09460 0.80500 -0.75600 906 1.61945 0.80600 0.77300 907 0.25830 0.80700 -0.63900 908 0.56555 0.81000 -0.18500 909 1.05045 0.81100 0.23800 910 0.43330 0.81400 -0.36100 911 0.95625 0.81400 0.14600 912 -0.11460 0.81800 -0.81300 913 1.13730 0.81900 0.36800 914 -0.02945 0.81900 -0.85000 915 0.07200 0.82100 -0.60900 916 0.88095 0.82300 0.10000 917 1.19710 0.82700 0.25900 918 0.76760 0.82700 0.04200 919 0.93200 0.82800 0.18800 920 0.32610 0.82900 -0.50300 921 0.28560 0.83000 -0.49900 922 0.63440 0.83200 -0.06700 923 -0.06160 0.83200 -0.84900 924 0.05430 0.83200 -0.80700 925 0.93060 0.83300 0.18300 926 0.41370 0.83400 -0.40300 927 1.13270 0.84100 0.24600 928 0.52535 0.84900 -0.42100 929 0.68625 0.85000 -0.24000 930 1.60970 0.85100 0.71000 931 0.59430 0.85300 -0.24000 932 1.21045 0.85300 0.49200 933 0.35860 0.85500 -0.61500 934 0.14180 0.85500 -0.76200 935 0.73465 0.86100 -0.30500 936 -0.01870 0.87000 -0.88300 937 0.32230 0.87200 -0.56800 938 0.74120 0.87300 -0.16100 939 1.84400 0.87500 0.95700 940 0.46575 0.87600 -0.33400 941 0.19955 0.88500 -0.74700 942 1.90145 0.88700 0.98500 943 1.76010 0.88700 0.77200 944 1.28625 0.89000 0.38900 945 1.55965 0.89100 0.59100 946 0.57505 0.89400 -0.45100 947 0.91860 0.89500 -0.09200 948 0.75425 0.89700 0.06400 949 1.74200 0.89800 0.60000 950 1.81100 0.90100 0.89000 951 0.67435 0.90100 -0.32000 952 0.62800 0.90200 -0.02600 953 0.54545 0.90400 -0.55600 954 0.72755 0.90500 -0.20400 955 1.55890 0.90500 0.59300 956 1.70155 0.90800 0.89100 957 1.89680 0.91000 0.91100 958 -0.16715 0.91400 -0.94400 959 0.73150 0.91500 -0.15800 960 0.70230 0.92100 -0.29600 961 0.01600 0.92400 -0.89200 962 1.15210 0.92400 0.13800 963 1.17410 0.92500 0.14700 964 0.14910 0.92700 -0.93600 965 0.62770 0.93200 -0.41000 966 0.84605 0.93400 0.11100 967 0.84065 0.93500 -0.09000 968 1.70000 0.93700 0.66900 969 1.01220 0.93800 0.09100 970 1.48545 0.93900 0.51500 971 0.72115 0.93900 -0.05900 972 0.25910 0.94000 -0.75600 973 1.53630 0.94100 0.60400 974 1.24580 0.94200 0.31700 975 0.41905 0.94500 -0.35800 976 0.28865 0.94800 -0.59600 977 0.16860 0.95000 -0.76100 978 0.91525 0.96000 -0.10600 979 1.65740 0.96100 0.69300 980 1.80560 0.96500 0.76300 981 0.84645 0.96500 0.02900 982 0.37700 0.96800 -0.57900 983 0.79595 0.96800 -0.24700 984 1.40310 0.96900 0.36200 985 0.44430 0.97200 -0.55600 986 1.61615 0.97600 0.58100 987 1.48025 0.97800 0.47900 988 0.67395 0.97800 -0.34000 989 1.77695 0.98000 0.69400 990 1.10205 0.98200 0.06900 991 1.68265 0.98200 0.72200 992 0.57415 0.98700 -0.37300 993 1.83130 0.98800 0.89600 994 1.17575 0.98800 0.10400 995 0.34005 0.99000 -0.47800 996 1.21080 0.99300 0.22600 997 1.46035 0.99600 0.50000 998 0.55140 0.99800 -0.48500 999 0.34305 0.99800 -0.59100 earth.c version 5.3.3 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 701.914 |Parent 0 Pred 0 Case 747 Cut 0.462 Rss 340.28 RssDelta 354.68 best for term |Parent 0 Pred 1 Case -1 Cut -0.999< Rss 350.29 RssDelta 0 GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 1 0.5054 0.5104 0.5104 0 0.462 1 2 1 ----------------------------------------------------------------------------- |FindTerm: Searching for new term 3 RssDelta 0 MaxLegalRssDelta 343.684 |Parent 1 Pred 0 skip (pred is in parent) |Parent 1 Pred 1 Case 837 Cut 0.693 Rss 279.94 RssDelta 60.343 best for term |Parent 2 Pred 0 skip (pred is in parent) |Parent 2 Pred 1 Case 179 Cut -0.607 Rss 145.57 RssDelta 194.71 best for term |Parent 0 Pred 0 Case -1 Cut -0.997< Rss 340.28 RssDelta 0 |Parent 0 Pred 1 Case 142 Cut -0.685 Rss 10.145 RssDelta 330.14 best for term GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 3 0.9851 0.9854 0.475 1 -0.685 3 4 1 ----------------------------------------------------------------------------- |FindTerm: Searching for new term 5 RssDelta 0 MaxLegalRssDelta 10.2469 |Parent 3 Pred 0 Case 295 Cut -0.458 Rss 10.116 RssDelta 0.029136 best for term |Parent 3 Pred 1 skip (pred is in parent) |Parent 4 Pred 0 Case -1 Cut -0.997< Rss 10.144 RssDelta 0 |Parent 4 Pred 1 skip (pred is in parent) |Parent 0 Pred 0 Case -1 Cut -0.997< Rss 10.145 RssDelta 0 |Parent 0 Pred 1 Case -1 Cut -0.999< Rss 10.145 RssDelta 0 |Parent 2 Pred 0 skip (pred is in parent) |Parent 2 Pred 1 Case -1 Cut -0.999< Rss 10.144 RssDelta 0 |Parent 1 Pred 0 skip (pred is in parent) |Parent 1 Pred 1 Case 559 Cut 0.067 Rss 10.115 RssDelta 0.030714 best for term GRSq RSq DeltaRSq Pred PredName Cut Terms Par Deg 5 0.9850 0.9854 4.419e-05 1 0.067 5 6 1 2 reject (small DeltaRSq) ----------------------------------------------------------------------------- RSq changed by less than 0.001 at 5 terms (DeltaRSq 4.4e-05) After forward pass GRSq 0.985 RSq 0.985 Forward pass complete: 5 terms nFacs Beta 00 0 -0.239 | . . | . . 01 1 1.05 | 1 . | 0.462 . 02 1 -0.996 | -1 . | 0.462 . 03 1 0.997 | . 1 | . -0.685 04 1 -1.05 | . -1 | . -0.685 EvalSubsetsUsingXtx: nTerms iTerm DeltaRss RSq 5 1 14.83 0.9641 min 5 2 164.08 0.7493 5 3 235.79 0.6461 5 4 3.6426 0.9802 min 4 1 15.42 0.9580 min 4 2 163.26 0.7452 4 3 326.49 0.5104 3 2 325.57 0.4895 min 3 3 321.9 0.4948 min 2 2 343.86 -0.0000 min Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.4922 0.4948 2 0.9575 0.9580 3 0.9799 0.9802 4 0.9851 0.9854 Backward pass complete: selected 4 terms of 5, GRSq 0.985 RSq 0.985 nFacs Beta 00 0 -0.239 | . . | . . 01 1 1.05 | 1 . | 0.462 . 02 1 -0.996 | -1 . | 0.462 . 03 1 0.997 | . 1 | . -0.685 04 1 -1.05 | . -1 | . -0.685 RESULT 7: GRSq 0.9851 RSq 0.9854 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.239 // 0 +1.05 * max(0, x[0] - 0.462) // 1 -0.996 * max(0, 0.462 - x[0]) // 2 +0.997 * max(0, x[1] - -0.685) // 3 -1.05 * max(0, -0.685 - x[1]) // 4 ============================================================================= TEST 8: x0 + x1 + noise n=1000 p=10 RESULT 8: GRSq 0.9846 RSq 0.9848 nTerms 3 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.92096 -0.93600 0.23500 1 -0.85206 -0.89500 0.40900 2 -0.74787 -0.81000 0.32700 3 -0.87231 -0.79700 -0.37100 4 -0.58951 -0.76900 0.77700 5 -0.85294 -0.68100 -0.53900 6 -0.73540 -0.64000 -0.26500 7 -0.83538 -0.63900 -0.54400 8 -0.45315 -0.60200 0.37400 9 -0.44534 -0.49300 0.09400 10 -0.78662 -0.47700 -0.59200 11 -0.87623 -0.44500 -0.77700 12 -0.49965 -0.37300 -0.20200 13 0.18560 -0.30300 0.70100 14 -0.44172 -0.28700 -0.21700 15 -0.45984 -0.27300 -0.25700 16 -0.30517 -0.20500 -0.12600 17 0.15028 -0.03500 0.19200 18 0.60979 0.02600 0.56900 19 1.39247 0.32400 0.80700 20 -0.93523 0.37800 -0.95300 21 0.33387 0.41300 -0.05600 22 0.92952 0.42400 0.35500 23 -0.57654 0.58600 -0.73300 24 1.07513 0.62500 0.27700 25 0.73690 0.71800 0.01100 26 0.51805 0.75700 -0.13600 27 -0.31550 0.85000 -0.63000 28 2.56040 0.97800 0.80000 29 -0.75548 0.98800 -0.87700 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.1408 0.4116 0.4116 0 0.378 1 2 1 3 0.6817 0.8634 0.4518 1 -0.371 3 4 1 5 0.9791 0.9932 0.1299 0 -0.936< 5 3 2 7 1.0000 1.0000 0.006751 0 -0.936< 6 4 2 final (max RSq) Reached maximum RSq 0.9990 at 9 terms, 7 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 9 terms, 7 terms used EvalSubsetsUsingXtx: nTerms iTerm DeltaRss RSq 7 1 0.16221 0.9922 min 7 2 0.7364 0.9645 7 3 3.0858 0.8512 7 4 0.40816 0.9803 7 5 1.1392 0.9451 7 6 0.13998 0.9932 min 6 1 0.054247 0.9906 min 6 2 0.60283 0.9642 6 3 3.1693 0.8404 6 4 0.65874 0.9615 6 5 2.6928 0.8634 5 2 0.8218 0.9510 min 5 3 3.238 0.8345 5 4 0.61338 0.9611 min 5 5 2.9612 0.8478 4 2 0.41069 0.9412 min 4 3 8.0351 0.5735 4 5 4.0564 0.7654 3 3 8.2149 0.5450 min 3 5 12.048 0.3602 2 5 11.301 0.0000 min Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.4552 0.5450 2 0.9142 0.9412 3 0.9291 0.9611 4 0.9782 0.9906 5 0.9791 0.9932 6 1.0000 1.0000 Backward pass complete: selected 6 terms of 7, GRSq 1.000 RSq 1.000 RESULT 9: GRSq 1.0000 RSq 1.0000 nTerms 7 of 7 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.133 // 0 +0.629 * max(0, x[0] - 0.378) // 1 -0.629 * max(0, 0.378 - x[0]) // 2 +1 * max(0, x[1] - -0.371) // 3 -1 * max(0, -0.371 - x[1]) // 4 +1 * x[0] * max(0, x[1] - -0.371) // 5 -1 * x[0] * max(0, -0.371 - x[1]) // 6 ============================================================================= 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.4474 0.4530 0.453 0 0.462 1 2 1 3 0.8553 0.8582 0.4052 1 0.896 3 4 1 5 0.9999 0.9999 0.1417 0 0.458 5 6 4 2 final (max RSq) Reached maximum RSq 0.9990 at 7 terms (RSq 0.9999) 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.4388 0.4416 2 0.8407 0.8423 3 0.9760 0.9764 4 0.9940 0.9942 5 0.9997 0.9997 6 0.9999 0.9999 Backward pass complete: selected 6 terms of 7, GRSq 1.000 RSq 1.000 RESULT 10: GRSq 0.9999 RSq 0.9999 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 1.78 // 0 +1.9 * max(0, x[0] - 0.462) // 1 -1.91 * max(0, 0.462 - x[0]) // 2 +0.891 * max(0, x[1] - 0.896) // 3 -1.46 * max(0, 0.896 - x[1]) // 4 -1 * max(0, x[0] - 0.458) * max(0, 0.896 - x[1]) // 5 +1.01 * max(0, 0.458 - x[0]) * max(0, 0.896 - 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 0.9999) 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 0.9999 RSq 0.9999 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 1.78 // 0 +1.9 * max(0, x[0] - 0.462) // 1 -1.91 * max(0, 0.462 - x[0]) // 2 +0.891 * max(0, x[1] - 0.896) // 3 -1.46 * max(0, 0.896 - x[1]) // 4 -1 * max(0, x[0] - 0.458) * max(0, 0.896 - x[1]) // 5 +1.01 * max(0, 0.458 - x[0]) * max(0, 0.896 - 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.9477 0.9482 0.9482 1 0.223 1 2 1 3 0.9972 0.9972 0.04904 0 0.011 3 4 1 5 0.9983 0.9983 0.001096 0 -0.581 5 1 7 0.9997 0.9998 0.001412 0 0.507 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.8283 0.8291 2 0.9477 0.9482 3 0.9570 0.9576 4 0.9982 0.9983 5 0.9996 0.9996 6 0.9997 0.9998 Backward pass complete: selected 6 terms of 7, GRSq 1.000 RSq 1.000 RESULT 12: GRSq 0.9997 RSq 0.9998 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 1.52 // 0 +1 * max(0, x[1] - 0.223) // 1 -1 * max(0, 0.223 - x[1]) // 2 +0.177 * max(0, x[0] - 0.011) // 3 -0.749 * max(0, 0.011 - x[0]) // 4 -0.46 * max(0, x[0] - -0.581) // 5 -0.396 * max(0, x[0] - 0.507) // 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.896 1 2 1 3 0.9770 0.9774 0.2959 0 -0.664 3 4 1 5 0.9964 0.9965 0.01909 0 0.603 5 6 2 2 7 0.9988 0.9989 0.002343 0 0.576 7 1 9 0.9996 0.9996 0.0007336 0 -0.426 8 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 9 terms, 8 terms used (DeltaRSq 0.00073) 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.6798 0.6814 2 0.9770 0.9772 3 0.9859 0.9861 4 0.9983 0.9983 5 0.9986 0.9986 6 0.9988 0.9988 7 0.9988 0.9989 Backward pass complete: selected 7 terms of 8, GRSq 0.999 RSq 0.999 RESULT 13: GRSq 0.9988 RSq 0.9989 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.389 // 0 +2.03 * max(0, x[1] - 0.896) // 1 -2.3 * max(0, 0.896 - x[1]) // 2 +2.13 * max(0, x[0] - -0.664) // 3 +0.154 * max(0, -0.664 - x[0]) // 4 -0.476 * max(0, x[0] - 0.603) * max(0, 0.896 - x[1]) // 5 +0.506 * max(0, 0.603 - x[0]) * max(0, 0.896 - x[1]) // 6 -1.71 * max(0, x[0] - 0.576) // 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.6667 0.6700 0.67 1 0.898 1 2 1 3 0.9763 0.9768 0.3068 0 0.712 3 4 1 5 0.9957 0.9958 0.01903 0 -0.572 5 6 2 2 7 0.9982 0.9983 0.002462 0 -0.51 7 1 9 0.9997 0.9997 0.001394 0 0.424 8 1 final (max RSq) Reached maximum RSq 0.9990 at 11 terms, 9 terms used (RSq 0.9997) After forward pass GRSq 1.000 RSq 1.000 Forward pass complete: 11 terms, 9 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.6670 0.6687 2 0.9728 0.9731 3 0.9870 0.9872 4 0.9985 0.9985 5 0.9988 0.9988 6 0.9993 0.9993 7 0.9996 0.9996 8 0.9997 0.9997 Backward pass complete: selected 8 terms of 9, GRSq 1.000 RSq 1.000 RESULT 14: GRSq 0.9997 RSq 0.9997 nTerms 9 of 9 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 1.38 // 0 +1.94 * max(0, x[1] - 0.898) // 1 -1.71 * max(0, 0.898 - x[1]) // 2 -0.498 * max(0, x[0] - 0.712) // 3 -0.601 * max(0, 0.712 - x[0]) // 4 -0.501 * max(0, x[0] - -0.572) * max(0, 0.898 - x[1]) // 5 +0.533 * max(0, -0.572 - x[0]) * max(0, 0.898 - x[1]) // 6 +1.67 * max(0, x[0] - -0.51) // 7 -0.988 * max(0, x[0] - 0.424) // 8 ============================================================================= 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.865 RSq 0.871 RESULT 15: GRSq 0.8646 RSq 0.8706 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 3.28 // 0 -1.94 * max(0, 0.969 - x[5]) // 1 +1.01 * max(0, x[0] - 0.514) // 2 -1 * max(0, 0.514 - x[0]) // 3 -5.84 * max(0, x[4] - 0.901) // 4 -0.982 * max(0, 0.901 - x[4]) // 5 +0.907 * max(0, x[1] - -0.685) // 6 -1.71 * max(0, -0.685 - x[1]) // 7 +0.544 * max(0, x[3] - 0.594) // 8 -0.966 * max(0, 0.594 - x[3]) // 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.4474 0.4529 0.4529 5 0.969 1 2 1 3 0.5490 0.5580 0.1051 0 0.514 3 4 1 5 0.6531 0.6634 0.1054 4 0.901 5 6 1 7 0.7553 0.7650 0.1016 1 -0.685 7 8 1 9 0.8646 0.8713 0.1063 3 0.594 9 10 1 11 0.9034 0.9092 0.03788 3 0.454 11 12 2 2 13 0.9396 0.9438 0.03462 4 0.738 13 14 2 2 15 0.9564 0.9598 0.01605 2 0.915 15 16 7 2 17 0.9846 0.9859 0.02611 2 0.339 17 18 1 19 0.9851 0.9865 0.0006067 1 -0.706 19 20 18 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 19 terms (DeltaRSq 0.00061) After forward pass GRSq 0.985 RSq 0.987 Forward pass complete: 19 terms RESULT 16: GRSq 0.9848 RSq 0.9859 nTerms 16 of 19 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.47 // 0 -3.19 * max(0, 0.969 - x[5]) // 1 +1.03 * max(0, x[0] - 0.514) // 2 -1.01 * max(0, 0.514 - x[0]) // 3 -1.95 * max(0, 0.901 - x[4]) // 4 +1.99 * max(0, x[1] - -0.685) // 5 -1.11 * max(0, -0.685 - x[1]) // 6 +1.75 * max(0, x[3] - 0.594) // 7 -1.94 * max(0, 0.594 - x[3]) // 8 -0.841 * max(0, x[3] - 0.454) * max(0, 0.969 - x[5]) // 9 +0.976 * max(0, 0.454 - x[3]) * max(0, 0.969 - x[5]) // 10 -0.708 * max(0, x[4] - 0.738) * max(0, 0.969 - x[5]) // 11 +0.999 * max(0, 0.738 - x[4]) * max(0, 0.969 - x[5]) // 12 -1.07 * max(0, x[1] - -0.685) * max(0, 0.915 - x[2]) // 13 -0.848 * max(0, x[2] - 0.339) // 14 +0.698 * max(0, 0.339 - x[2]) // 15 ============================================================================= 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.4474 0.4529 0.4529 5 0.969 1 2 1 3 0.5490 0.5580 0.1051 0 0.514 3 4 1 5 0.6531 0.6634 0.1054 4 0.901 5 6 1 7 0.7553 0.7650 0.1016 1 -0.685 7 8 1 9 0.8646 0.8713 0.1063 3 0.594 9 10 1 11 0.9034 0.9092 0.03788 3 0.454 11 12 2 2 13 0.9396 0.9438 0.03462 4 0.738 13 14 2 2 15 0.9564 0.9598 0.01605 2 0.915 15 16 7 2 17 0.9846 0.9859 0.02611 2 0.339 17 18 1 19 0.9887 0.9898 0.003855 3 0.859 19 20 14 3 21 0.9992 0.9993 0.009496 3 -0.949 21 22 6 2 final (max RSq) Reached maximum RSq 0.9990 at 23 terms (RSq 0.9993) After forward pass GRSq 0.999 RSq 0.999 Forward pass complete: 23 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.4446 0.4474 2 0.5489 0.5534 3 0.6520 0.6573 4 0.7515 0.7564 5 0.8573 0.8609 6 0.8975 0.9005 7 0.9323 0.9347 8 0.9483 0.9504 9 0.9701 0.9715 10 0.9737 0.9750 11 0.9802 0.9813 12 0.9807 0.9819 13 0.9879 0.9887 14 0.9928 0.9933 15 0.9968 0.9970 16 0.9983 0.9985 17 0.9989 0.9990 18 0.9991 0.9992 19 0.9992 0.9992 20 0.9992 0.9993 21 0.9992 0.9993 22 0.9992 0.9993 Backward pass complete: selected 21 terms of 23, GRSq 0.999 RSq 0.999 RESULT 17: GRSq 0.9992 RSq 0.9993 nTerms 22 of 23 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.97 // 0 -3.54 * max(0, 0.969 - x[5]) // 1 +1.01 * max(0, x[0] - 0.514) // 2 -0.997 * max(0, 0.514 - x[0]) // 3 +1.88 * max(0, x[4] - 0.901) // 4 -1.06 * max(0, 0.901 - x[4]) // 5 +1.97 * max(0, x[1] - -0.685) // 6 -1.07 * max(0, -0.685 - x[1]) // 7 +2.87 * max(0, x[3] - 0.594) // 8 -2.82 * max(0, 0.594 - x[3]) // 9 -1.79 * max(0, x[3] - 0.454) * max(0, 0.969 - x[5]) // 10 +1.77 * max(0, 0.454 - x[3]) * max(0, 0.969 - x[5]) // 11 -1.01 * max(0, x[4] - 0.738) * max(0, 0.969 - x[5]) // 12 +1.88 * max(0, 0.738 - x[4]) * max(0, 0.969 - x[5]) // 13 +1.41 * max(0, x[1] - -0.685) * max(0, x[2] - 0.915) // 14 -1.06 * max(0, x[1] - -0.685) * max(0, 0.915 - x[2]) // 15 -0.788 * max(0, x[2] - 0.339) // 16 +0.744 * max(0, 0.339 - x[2]) // 17 +1.04 * max(0, x[3] - 0.859) * max(0, 0.738 - x[4]) * max(0, 0.969 - x[5]) // 18 -1.02 * max(0, 0.859 - x[3]) * max(0, 0.738 - x[4]) * max(0, 0.969 - x[5]) // 19 -0.955 * max(0, x[3] - -0.949) * max(0, 0.901 - x[4]) // 20 +0.697 * max(0, -0.949 - x[3]) * max(0, 0.901 - x[4]) // 21 ============================================================================= 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.1648 0.2063 0.2063 5 0.873 1 2 1 3 0.3163 0.3833 0.177 2 0.832 3 4 1 5 0.4259 0.5092 0.1259 0 0.527 5 6 1 7 0.5631 0.6465 0.1373 4 0.833 7 8 1 9 0.7157 0.7827 0.1361 3 0.409 9 10 1 11 0.8323 0.8791 0.0964 1 -0.68 11 12 1 13 0.8841 0.9213 0.04219 4 -0.451 13 14 2 2 15 0.9303 0.9555 0.03426 3 -0.022 15 16 4 2 17 0.9919 0.9951 0.03962 0 0.581 17 18 11 2 19 0.9922 0.9956 0.0004927 1 -0.68 19 20 6 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 19 terms (DeltaRSq 0.00049) After forward pass GRSq 0.992 RSq 0.996 Forward pass complete: 19 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.0926 0.1152 2 0.2556 0.2925 3 0.4259 0.4684 4 0.5551 0.5987 5 0.7093 0.7447 6 0.7994 0.8285 7 0.8980 0.9151 8 0.9378 0.9497 9 0.9585 0.9674 10 0.9708 0.9776 11 0.9799 0.9851 12 0.9846 0.9889 13 0.9873 0.9911 14 0.9905 0.9935 15 0.9912 0.9942 16 0.9919 0.9948 17 0.9920 0.9951 18 0.9920 0.9951 Backward pass complete: selected 17 terms of 19, GRSq 0.992 RSq 0.995 RESULT 18: GRSq 0.9920 RSq 0.9951 nTerms 18 of 19 of 101 FUNCTION 5 preds + noise n=200 p=15 [99.99 secs] TEST 18: FUNCTION 5 preds + noise n=200 p=15 3.45 // 0 -0.508 * max(0, 0.873 - x[ 5]) // 1 +1.84 * max(0, x[ 2] - 0.832) // 2 -0.946 * max(0, 0.832 - x[ 2]) // 3 +0.382 * max(0, x[ 0] - 0.527) // 4 -0.237 * max(0, 0.527 - x[ 0]) // 5 +1.82 * max(0, x[ 4] - 0.833) // 6 -1.89 * max(0, 0.833 - x[ 4]) // 7 +1.87 * max(0, x[ 3] - 0.409) // 8 -1.88 * max(0, 0.409 - x[ 3]) // 9 +1.62 * max(0, x[ 1] - -0.68) // 10 -1.06 * max(0, -0.68 - x[ 1]) // 11 -1.04 * max(0, x[ 4] - -0.451) * max(0, 0.873 - x[ 5]) // 12 +0.878 * max(0, -0.451 - x[ 4]) * max(0, 0.873 - x[ 5]) // 13 -1.03 * max(0, 0.832 - x[ 2]) * max(0, x[ 3] - -0.022) // 14 +0.997 * max(0, 0.832 - x[ 2]) * max(0, -0.022 - x[ 3]) // 15 +0.785 * max(0, x[ 0] - 0.581) * max(0, x[ 1] - -0.68) // 16 -1.07 * max(0, 0.581 - x[ 0]) * max(0, x[ 1] - -0.68) // 17 ============================================================================= 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.1698 0.2110 0.211 5 0.873 1 2 1 3 0.3231 0.3895 0.1785 2 0.832 3 4 1 5 0.4362 0.5180 0.1285 0 0.527 5 6 1 7 0.5768 0.6576 0.1396 4 0.741 7 8 1 9 0.7198 0.7858 0.1282 3 0.409 9 10 1 11 0.8354 0.8813 0.09554 1 -0.68 11 12 1 13 0.8877 0.9237 0.04243 4 -0.521 13 14 2 2 15 0.9352 0.9586 0.03488 0 0.041 15 16 11 2 17 0.9989 0.9994 0.04076 3 -0.623 17 18 4 2 final (max RSq) Reached maximum RSq 0.9990 at 19 terms (RSq 0.9994) After forward pass GRSq 0.999 RSq 0.999 Forward pass complete: 19 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.2472 0.2660 2 0.3716 0.4028 3 0.5532 0.5863 4 0.6956 0.7254 5 0.8127 0.8355 6 0.8613 0.8814 7 0.9103 0.9254 8 0.9528 0.9618 9 0.9674 0.9744 10 0.9780 0.9832 11 0.9870 0.9904 12 0.9905 0.9932 13 0.9929 0.9950 14 0.9951 0.9967 15 0.9979 0.9986 16 0.9986 0.9991 17 0.9989 0.9993 18 0.9989 0.9994 Backward pass complete: selected 18 terms of 19, GRSq 0.999 RSq 0.999 RESULT 19: GRSq 0.9989 RSq 0.9994 nTerms 19 of 19 of 101 FUNCTION 5 preds clean n=200 p=15 [99.99 secs] TEST 19: FUNCTION 5 preds clean n=200 p=15 3.31 // 0 +0.691 * max(0, x[ 5] - 0.873) // 1 -0.463 * max(0, 0.873 - x[ 5]) // 2 +1.41 * max(0, x[ 2] - 0.832) // 3 -0.365 * max(0, 0.832 - x[ 2]) // 4 +0.271 * max(0, x[ 0] - 0.527) // 5 -0.234 * max(0, 0.527 - x[ 0]) // 6 +1.84 * max(0, x[ 4] - 0.741) // 7 -1.91 * max(0, 0.741 - x[ 4]) // 8 +1.84 * max(0, x[ 3] - 0.409) // 9 -1.86 * max(0, 0.409 - x[ 3]) // 10 +1.05 * max(0, x[ 1] - -0.68) // 11 -1.01 * max(0, -0.68 - x[ 1]) // 12 -1.02 * max(0, x[ 4] - -0.521) * max(0, 0.873 - x[ 5]) // 13 +1 * max(0, -0.521 - x[ 4]) * max(0, 0.873 - x[ 5]) // 14 +1.06 * max(0, x[ 0] - 0.041) * max(0, x[ 1] - -0.68) // 15 -1.07 * max(0, 0.041 - x[ 0]) * max(0, x[ 1] - -0.68) // 16 -1.01 * max(0, 0.832 - x[ 2]) * max(0, x[ 3] - -0.623) // 17 +1.05 * max(0, 0.832 - x[ 2]) * max(0, -0.623 - x[ 3]) // 18 ============================================================================= 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.0819 0.1274 0.1274 0 0.153 1 2 1 3 0.1637 0.2456 0.1182 6 -0.067 3 4 1 5 0.2405 0.3507 0.105 7 0.367 5 6 1 7 0.2968 0.4310 0.08035 4 0.711 7 8 1 9 0.3653 0.5148 0.08376 9 0.483 9 10 1 11 0.4214 0.5827 0.06791 3 -0.407 11 12 1 13 0.5156 0.6710 0.08831 2 0.429 13 14 11 2 15 0.5994 0.7443 0.07327 1 -0.729 15 16 1 17 0.6696 0.8021 0.05786 8 -0.7 17 18 1 19 0.7709 0.8716 0.06945 5 -0.755 19 20 1 21 0.8320 0.9120 0.04046 4 0.64 21 22 19 2 23 0.8821 0.9425 0.03044 6 0.024 23 24 6 2 25 0.9260 0.9664 0.02396 9 0.17 25 26 17 2 27 0.9735 0.9889 0.02242 0 -0.148 27 28 15 2 29 0.9888 0.9957 0.006798 2 -0.845 29 30 1 31 0.9938 0.9978 0.002121 6 -0.512 31 32 5 2 33 0.9986 0.9995 0.001752 3 -0.416 33 34 29 2 final (max RSq) Reached maximum RSq 0.9990 at 35 terms (RSq 0.9995) After forward pass GRSq 0.999 RSq 1.000 Forward pass complete: 35 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.1109 0.1331 2 0.1252 0.1686 3 0.2341 0.2908 4 0.3149 0.3821 5 0.4130 0.4844 6 0.5056 0.5773 7 0.5967 0.6645 8 0.7109 0.7661 9 0.8151 0.8545 10 0.8559 0.8898 11 0.8718 0.9048 12 0.8942 0.9237 13 0.9136 0.9395 14 0.9319 0.9538 15 0.9490 0.9664 16 0.9651 0.9777 17 0.9784 0.9866 18 0.9842 0.9905 19 0.9865 0.9922 20 0.9881 0.9934 21 0.9899 0.9945 22 0.9914 0.9955 23 0.9933 0.9966 24 0.9949 0.9975 25 0.9962 0.9982 26 0.9973 0.9988 27 0.9976 0.9989 28 0.9981 0.9992 29 0.9986 0.9994 30 0.9986 0.9995 31 0.9987 0.9995 32 0.9987 0.9995 33 0.9987 0.9995 34 0.9987 0.9995 Backward pass complete: selected 31 terms of 35, GRSq 0.999 RSq 1.000 RESULT 20: GRSq 0.9987 RSq 0.9995 nTerms 32 of 35 of 101 FUNCTION 10 preds + noise n=200 p=50 [99.99 secs] TEST 20: FUNCTION 10 preds + noise n=200 p=50 -2.52 // 0 +0.268 * max(0, x[ 0] - 0.153) // 1 -0.196 * max(0, 0.153 - x[ 0]) // 2 +1.39 * max(0, x[ 6] - -0.067) // 3 -1.36 * max(0, -0.067 - x[ 6]) // 4 +0.629 * max(0, x[ 7] - 0.367) // 5 -1.02 * max(0, 0.367 - x[ 7]) // 6 -0.216 * max(0, 0.711 - x[ 4]) // 7 +0.201 * max(0, x[ 9] - 0.483) // 8 -0.26 * max(0, 0.483 - x[ 9]) // 9 +1.43 * max(0, x[ 3] - -0.407) // 10 -0.142 * max(0, -0.407 - x[ 3]) // 11 +1.14 * max(0, x[ 2] - 0.429) * max(0, x[ 3] - -0.407) // 12 -0.99 * max(0, 0.429 - x[ 2]) * max(0, x[ 3] - -0.407) // 13 +0.861 * max(0, x[ 1] - -0.729) // 14 -1.06 * max(0, -0.729 - x[ 1]) // 15 +1.15 * max(0, x[ 8] - -0.7) // 16 -1.09 * max(0, -0.7 - x[ 8]) // 17 +1.64 * max(0, x[ 5] - -0.755) // 18 -1.19 * max(0, -0.755 - x[ 5]) // 19 +1.19 * max(0, x[ 4] - 0.64) * max(0, x[ 5] - -0.755) // 20 -1.02 * max(0, 0.64 - x[ 4]) * max(0, x[ 5] - -0.755) // 21 -1.02 * max(0, x[ 6] - 0.024) * max(0, 0.367 - x[ 7]) // 22 +0.989 * max(0, 0.024 - x[ 6]) * max(0, 0.367 - x[ 7]) // 23 +1.08 * max(0, x[ 8] - -0.7) * max(0, x[ 9] - 0.17) // 24 -1.03 * max(0, x[ 8] - -0.7) * max(0, 0.17 - x[ 9]) // 25 +1.01 * max(0, x[ 0] - -0.148) * max(0, x[ 1] - -0.729) // 26 -1.09 * max(0, -0.148 - x[ 0]) * max(0, x[ 1] - -0.729) // 27 +0.594 * max(0, x[ 2] - -0.845) // 28 +0.874 * max(0, x[ 6] - -0.512) * max(0, x[ 7] - 0.367) // 29 -1.42 * max(0, -0.512 - x[ 6]) * max(0, x[ 7] - 0.367) // 30 -1.02 * max(0, x[ 2] - -0.845) * max(0, -0.416 - x[ 3]) // 31 ============================================================================= 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.0994 0.1881 0.1881 7 -0.45 1 2 1 3 0.1526 0.3151 0.127 0 0.536 3 4 1 5 0.1949 0.4204 0.1052 19 -0.195 5 6 1 7 0.2171 0.5014 0.08109 8 0.827 7 8 1 9 0.2647 0.5892 0.08775 17 0.046 9 10 8 2 11 0.2865 0.6534 0.06424 16 0.181 11 12 1 13 0.3327 0.7211 0.0677 15 0.575 13 14 1 15 0.3288 0.7616 0.0405 26 -0.136 15 16 1 17 0.3213 0.7981 0.03646 20 -0.39 17 18 5 2 19 0.3010 0.8288 0.03068 17 0.134 19 20 1 21 0.2297 0.8478 0.01907 21 0.289 21 22 1 23 0.1383 0.8663 0.01843 8 -0.141 23 24 20 2 25 0.0515 0.8881 0.02185 15 -0.124 25 26 4 2 27 -0.1764 0.8991 0.01093 13 -0.117 27 28 1 29 -0.5139 0.9110 0.01197 0 -0.142 29 30 1 2 31 -1.0105 0.9259 0.01492 17 -0.317 31 32 5 2 33 -2.2163 0.9357 0.009732 1 -0.358 33 34 1 35 -5.1609 0.9491 0.0134 25 0.291 35 36 1 37 -26.2821 0.9555 0.006379 11 -0.282 37 38 27 2 reject (negative GRSq) Reached minimum GRSq -10 at 37 terms (GRSq -26) After forward pass GRSq -26.282 RSq 0.955 Forward pass complete: 37 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.0681 0.1146 2 0.1893 0.2691 3 0.2335 0.3452 4 0.3053 0.4385 5 0.3924 0.5361 6 0.4531 0.6063 7 0.5198 0.6745 8 0.5403 0.7073 9 0.5466 0.7293 10 0.5607 0.7545 11 0.5652 0.7732 12 0.5822 0.7970 13 0.6103 0.8241 14 0.6291 0.8450 15 0.6402 0.8612 16 0.6422 0.8729 17 0.6422 0.8801 18 0.6422 0.8920 19 0.6422 0.9030 20 0.6422 0.9103 21 0.6422 0.9171 22 0.6422 0.9244 23 0.6422 0.9306 24 0.6422 0.9368 25 0.6422 0.9398 26 0.6422 0.9421 27 0.6422 0.9442 28 0.6422 0.9459 29 0.6422 0.9470 30 0.6422 0.9478 31 0.6422 0.9484 32 0.6422 0.9488 33 0.6422 0.9491 34 0.6422 0.9491 35 0.6422 0.9491 36 0.6422 0.9491 Backward pass complete: selected 16 terms of 37, GRSq 0.642 RSq 0.873 RESULT 21: GRSq 0.6422 RSq 0.8729 nTerms 17 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 -3.09 // 0 +0.866 * max(0, x[ 7] - -0.45) // 1 -3.61 * max(0, -0.45 - x[ 7]) // 2 +4.07 * max(0, x[ 0] - 0.536) // 3 +4.32 * max(0, x[19] - -0.195) // 4 +23.4 * max(0, x[ 8] - 0.827) // 5 +2.85 * max(0, x[16] - 0.181) // 6 +1.69 * max(0, x[26] - -0.136) // 7 +2.02 * max(0, -0.136 - x[26]) // 8 -2.26 * max(0, x[19] - -0.195) * max(0, x[20] - -0.39) // 9 -7.14 * max(0, x[19] - -0.195) * max(0, -0.39 - x[20]) // 10 +1.94 * max(0, x[17] - 0.134) // 11 +2.62 * max(0, x[21] - 0.289) // 12 -6.82 * max(0, -0.141 - x[ 8]) * max(0, 0.134 - x[17]) // 13 -3.76 * max(0, 0.536 - x[ 0]) * max(0, -0.124 - x[15]) // 14 -1.39 * max(0, -0.117 - x[13]) // 15 -1.44 * max(0, x[17] - -0.317) * max(0, x[19] - -0.195) // 16 ============================================================================= 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.0916 0.1142 0.1142 4 0.924 1 2 1 3 0.1530 0.1950 0.08078 8 -0.043 3 4 1 5 0.2166 0.2744 0.0794 2 0.125 5 6 1 7 0.2724 0.3435 0.06918 10 0.014 7 8 1 9 0.3162 0.3992 0.05568 6 0.543 9 10 1 11 0.3637 0.4558 0.05653 16 0.776 11 12 1 13 0.4115 0.5103 0.05451 3 0.931 13 14 1 15 0.4607 0.5634 0.05312 7 -0.378 15 16 9 2 17 0.5069 0.6119 0.04848 9 -0.085 17 18 2 2 19 0.5485 0.6546 0.04272 0 -0.904 19 20 1 21 0.5896 0.6949 0.04035 5 0.738 21 22 19 2 23 0.6260 0.7300 0.03511 19 -0.721 23 24 1 25 0.6662 0.7661 0.03607 1 -0.788 25 26 19 2 27 0.6997 0.7958 0.02969 14 -0.755 27 28 1 29 0.7233 0.8176 0.02176 18 0.409 29 30 1 31 0.7463 0.8379 0.0203 17 0.437 31 32 1 33 0.7721 0.8588 0.02096 15 -0.956 33 34 1 35 0.8017 0.8811 0.02226 11 0.915 35 36 1 37 0.8299 0.9013 0.02017 13 -0.809 37 38 1 39 0.8693 0.9266 0.02532 12 0.864 39 40 1 41 0.8952 0.9431 0.01652 7 0.684 41 42 1 43 0.9093 0.9524 0.009343 2 0.148 43 44 14 2 45 0.9243 0.9616 0.009196 9 0.18 45 46 1 47 0.9416 0.9715 0.009833 8 0.023 47 48 46 2 49 0.9567 0.9796 0.008133 5 -0.839 49 50 1 51 0.9771 0.9896 0.01001 4 -0.708 51 52 49 2 53 0.9942 0.9975 0.007853 7 -0.759 53 54 10 2 55 0.9973 0.9989 0.001413 8 -0.422 55 56 45 2 57 0.9976 0.9990 0.0001438 1 0.533 57 58 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 57 terms (DeltaRSq 0.00014) After forward pass GRSq 0.998 RSq 0.999 Forward pass complete: 57 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.1689 0.1793 2 0.2842 0.3020 3 0.3522 0.3763 4 0.4215 0.4502 5 0.4688 0.5016 6 0.4982 0.5352 7 0.5380 0.5777 8 0.5785 0.6197 9 0.6234 0.6647 10 0.6599 0.7012 11 0.6965 0.7369 12 0.7285 0.7678 13 0.7645 0.8013 14 0.8004 0.8339 15 0.8370 0.8662 16 0.8721 0.8965 17 0.9064 0.9253 18 0.9303 0.9452 19 0.9431 0.9559 20 0.9580 0.9679 21 0.9657 0.9741 22 0.9726 0.9796 23 0.9759 0.9824 24 0.9807 0.9861 25 0.9841 0.9887 26 0.9865 0.9905 27 0.9886 0.9921 28 0.9905 0.9935 29 0.9921 0.9947 30 0.9925 0.9951 31 0.9937 0.9959 32 0.9946 0.9966 33 0.9951 0.9969 34 0.9955 0.9972 35 0.9958 0.9974 36 0.9960 0.9976 37 0.9963 0.9978 38 0.9965 0.9980 39 0.9967 0.9981 40 0.9969 0.9983 41 0.9972 0.9984 42 0.9973 0.9985 43 0.9975 0.9987 44 0.9976 0.9988 45 0.9976 0.9988 46 0.9977 0.9988 47 0.9977 0.9988 48 0.9977 0.9988 49 0.9977 0.9989 50 0.9977 0.9989 51 0.9977 0.9989 52 0.9977 0.9989 53 0.9977 0.9989 54 0.9977 0.9989 55 0.9977 0.9989 56 0.9977 0.9989 Backward pass complete: selected 47 terms of 57, GRSq 0.998 RSq 0.999 RESULT 22: GRSq 0.9977 RSq 0.9988 nTerms 48 of 57 of 101 FUNCTION 20 preds + noise n=400 p=30 [99.99 secs] TEST 22: FUNCTION 20 preds + noise n=400 p=30 1.52 // 0 -0.178 * max(0, 0.924 - x[ 4]) // 1 +1.18 * max(0, x[ 8] - -0.043) // 2 -1.23 * max(0, -0.043 - x[ 8]) // 3 +1.91 * max(0, x[ 2] - 0.125) // 4 -1.96 * max(0, 0.125 - x[ 2]) // 5 +1.01 * max(0, x[10] - 0.014) // 6 -0.988 * max(0, 0.014 - x[10]) // 7 +0.606 * max(0, x[ 6] - 0.543) // 8 -0.181 * max(0, 0.543 - x[ 6]) // 9 +0.831 * max(0, x[16] - 0.776) // 10 -1.03 * max(0, 0.776 - x[16]) // 11 +2.66 * max(0, x[ 3] - 0.931) // 12 -1.16 * max(0, 0.931 - x[ 3]) // 13 +0.993 * max(0, x[ 6] - 0.543) * max(0, x[ 7] - -0.378) // 14 +0.159 * max(0, x[ 0] - -0.904) // 15 +1.01 * max(0, x[19] - -0.721) // 16 -0.729 * max(0, -0.721 - x[19]) // 17 +1.09 * max(0, x[ 0] - -0.904) * max(0, x[ 1] - -0.788) // 18 -1.18 * max(0, x[ 0] - -0.904) * max(0, -0.788 - x[ 1]) // 19 +1.02 * max(0, x[14] - -0.755) // 20 -1.1 * max(0, -0.755 - x[14]) // 21 +0.933 * max(0, x[18] - 0.409) // 22 -1.01 * max(0, 0.409 - x[18]) // 23 +0.979 * max(0, x[17] - 0.437) // 24 -0.991 * max(0, 0.437 - x[17]) // 25 +1.01 * max(0, x[15] - -0.956) // 26 -1.01 * max(0, 0.915 - x[11]) // 27 +0.996 * max(0, x[13] - -0.809) // 28 -1.1 * max(0, -0.809 - x[13]) // 29 +1.77 * max(0, x[12] - 0.864) // 30 -0.978 * max(0, 0.864 - x[12]) // 31 +1.47 * max(0, x[ 7] - 0.684) // 32 -1.59 * max(0, 0.684 - x[ 7]) // 33 -0.999 * max(0, x[ 2] - 0.148) * max(0, 0.931 - x[ 3]) // 34 +0.996 * max(0, 0.148 - x[ 2]) * max(0, 0.931 - x[ 3]) // 35 +0.484 * max(0, x[ 9] - 0.18) // 36 -1.05 * max(0, 0.18 - x[ 9]) // 37 -0.969 * max(0, x[ 8] - 0.023) * max(0, 0.18 - x[ 9]) // 38 +1.06 * max(0, 0.023 - x[ 8]) * max(0, 0.18 - x[ 9]) // 39 +0.327 * max(0, x[ 5] - -0.839) // 40 -1.42 * max(0, -0.839 - x[ 5]) // 41 +0.955 * max(0, x[ 4] - -0.708) * max(0, x[ 5] - -0.839) // 42 -1.18 * max(0, -0.708 - x[ 4]) * max(0, x[ 5] - -0.839) // 43 -1.06 * max(0, 0.543 - x[ 6]) * max(0, x[ 7] - -0.759) // 44 +0.505 * max(0, 0.543 - x[ 6]) * max(0, -0.759 - x[ 7]) // 45 +1.09 * max(0, x[ 8] - -0.422) * max(0, x[ 9] - 0.18) // 46 -0.579 * max(0, -0.422 - x[ 8]) * max(0, x[ 9] - 0.18) // 47 ============================================================================= 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.3984 0.4044 0.4044 5 0.959 1 2 1 3 0.5322 0.5415 0.1371 0 0.898 3 4 1 5 0.6471 0.6576 0.1161 1 -0.567 5 6 1 7 0.7610 0.7705 0.1129 4 0.86 7 8 1 9 0.8779 0.8839 0.1134 3 0.558 9 10 1 11 0.9083 0.9137 0.02975 4 0.393 11 12 2 2 13 0.9409 0.9450 0.03129 3 -0.64 13 14 2 2 15 0.9585 0.9618 0.01679 2 -0.072 15 16 5 2 17 0.9815 0.9831 0.02134 2 0.239 17 18 1 19 0.9828 0.9845 0.001389 2 -0.278 19 20 6 2 21 0.9832 0.9850 0.000486 5 -0.802 21 22 10 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 21 terms (DeltaRSq 0.00049) After forward pass GRSq 0.983 RSq 0.985 Forward pass complete: 21 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.3999 0.4029 2 0.5332 0.5378 3 0.6445 0.6498 4 0.7591 0.7639 5 0.8694 0.8727 6 0.8980 0.9011 7 0.9169 0.9198 8 0.9297 0.9325 9 0.9460 0.9484 10 0.9587 0.9607 11 0.9677 0.9694 12 0.9746 0.9761 13 0.9790 0.9803 14 0.9819 0.9832 15 0.9823 0.9836 16 0.9828 0.9841 17 0.9829 0.9844 18 0.9830 0.9845 19 0.9830 0.9845 20 0.9830 0.9845 Backward pass complete: selected 18 terms of 21, GRSq 0.983 RSq 0.984 RESULT 23: GRSq 0.9830 RSq 0.9845 nTerms 19 of 21 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 4.79 // 0 +4.14 * max(0, x[5] - 0.959) // 1 -1.8 * max(0, 0.959 - x[5]) // 2 -1.02 * max(0, 0.898 - x[0]) // 3 +0.918 * max(0, x[1] - -0.567) // 4 -0.847 * max(0, -0.567 - x[1]) // 5 -1.89 * max(0, 0.86 - x[4]) // 6 +1.81 * max(0, x[3] - 0.558) // 7 -1.85 * max(0, 0.558 - x[3]) // 8 -0.759 * max(0, x[4] - 0.393) * max(0, 0.959 - x[5]) // 9 +0.961 * max(0, 0.393 - x[4]) * max(0, 0.959 - x[5]) // 10 -0.876 * max(0, x[3] - -0.64) * max(0, 0.959 - x[5]) // 11 +1.1 * max(0, -0.64 - x[3]) * max(0, 0.959 - x[5]) // 12 +0.911 * max(0, x[1] - -0.567) * max(0, x[2] - -0.072) // 13 -1.03 * max(0, x[1] - -0.567) * max(0, -0.072 - x[2]) // 14 -0.437 * max(0, x[2] - 0.239) // 15 +0.544 * max(0, 0.239 - x[2]) // 16 -1.02 * max(0, -0.567 - x[1]) * max(0, x[2] - -0.278) // 17 +1.4 * max(0, -0.567 - x[1]) * max(0, -0.278 - x[2]) // 18 ============================================================================= 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.1290 0.1522 0.1522 1 0.852 1 2 1 3 0.1115 0.1584 0.006232 0 0.76 3 4 1 5 0.1049 0.1638 0.005378 0 -0.423 5 1 7 0.0854 0.1690 0.005246 3 -0.524 6 7 1 9 0.0846 0.1799 0.01088 3 -0.275 8 1 11 0.0650 0.1859 0.005953 5 0.327 9 10 1 13 0.0710 0.2027 0.01685 5 0.174 11 1 15 0.1207 0.2562 0.05346 5 0.374 12 1 17 0.2227 0.3520 0.09583 5 0.242 13 1 19 0.2229 0.3617 0.009675 0 -0.916 14 1 21 0.2263 0.3738 0.01209 0 -0.886 15 1 23 0.2258 0.3827 0.008906 3 -0.452 16 1 25 0.2721 0.4282 0.04559 3 -0.554 17 1 27 0.2728 0.4374 0.009112 1 0.941 18 1 29 0.2604 0.4451 0.007704 4 0.939 19 20 1 31 0.2597 0.4531 0.008005 3 -0.418 21 1 33 0.2541 0.4575 0.004412 1 -0.032 22 1 35 0.2478 0.4614 0.00397 0 -0.836 23 1 37 0.2453 0.4682 0.00672 0 -0.537 24 1 39 0.2426 0.4747 0.00654 0 -0.377 25 1 41 0.2362 0.4787 0.00403 0 -0.685 26 1 43 0.2316 0.4841 0.005367 3 -0.335 27 1 45 0.2247 0.4879 0.003797 0 -0.746 28 1 47 0.2169 0.4912 0.003335 0 -0.348 29 1 49 0.2084 0.4942 0.00297 0 -0.284 30 1 51 0.1994 0.4970 0.002795 0 -0.467 31 1 53 0.1949 0.5027 0.005677 0 -0.505 32 1 55 0.1854 0.5053 0.002644 4 0.851 33 1 57 0.1754 0.5078 0.002487 4 0.902 34 1 59 0.1641 0.5097 0.001892 0 0.885 35 1 61 0.1524 0.5115 0.001756 3 -0.584 36 1 63 0.1398 0.5129 0.001416 3 -0.674 37 1 65 0.1273 0.5146 0.001701 3 -0.926 38 1 67 0.1143 0.5161 0.001555 5 0.851 39 1 69 0.1013 0.5179 0.001732 3 0.821 40 1 71 0.0883 0.5198 0.001926 0 0.727 41 1 73 0.0746 0.5215 0.001748 5 -0.38 42 1 75 0.0631 0.5245 0.002996 5 -0.183 43 1 77 0.0569 0.5303 0.005789 5 -0.45 44 1 79 0.0431 0.5325 0.002157 0 0.629 45 1 81 0.0284 0.5343 0.001844 3 0.875 46 1 83 0.0129 0.5360 0.001661 1 -0.569 47 1 85 -0.0030 0.5377 0.001688 3 0.542 48 1 87 -0.0198 0.5392 0.001487 1 -0.252 49 1 89 -0.0360 0.5411 0.001932 1 -0.13 50 1 91 -0.0753 0.5427 0.00157 2 0.938 51 52 1 93 -0.0893 0.5461 0.003462 2 0.819 53 1 95 -0.1070 0.5483 0.00217 2 0.872 54 1 97 -0.1261 0.5500 0.001749 1 0.577 55 1 99 -0.1458 0.5518 0.001781 5 -0.92 56 1 final (reached nk 101) Reached maximum number of terms 101 After forward pass GRSq -0.146 RSq 0.552 Forward pass complete: 101 terms, 57 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.0000 0.0028 2 0.0067 0.0331 3 0.1498 0.1836 4 0.2642 0.3031 5 0.2642 0.3033 6 0.2642 0.3079 7 0.3115 0.3744 8 0.3115 0.3823 9 0.3115 0.3865 10 0.3115 0.3977 11 0.3115 0.3981 12 0.3115 0.4079 13 0.3115 0.4165 14 0.3115 0.4225 15 0.3115 0.4281 16 0.3115 0.4369 17 0.3115 0.4424 18 0.3115 0.4535 19 0.3115 0.4597 20 0.3115 0.4661 21 0.3115 0.4672 22 0.3115 0.4728 23 0.3115 0.4737 24 0.3115 0.4791 25 0.3115 0.4807 26 0.3115 0.4862 27 0.3115 0.4884 28 0.3115 0.4946 29 0.3115 0.4958 30 0.3115 0.5012 31 0.3115 0.5059 32 0.3115 0.5101 33 0.3115 0.5126 34 0.3115 0.5140 35 0.3115 0.5180 36 0.3115 0.5192 37 0.3115 0.5226 38 0.3115 0.5259 39 0.3115 0.5297 40 0.3115 0.5327 41 0.3115 0.5352 42 0.3115 0.5374 43 0.3115 0.5397 44 0.3115 0.5397 45 0.3115 0.5419 46 0.3115 0.5440 47 0.3115 0.5452 48 0.3115 0.5466 49 0.3115 0.5466 50 0.3115 0.5477 51 0.3115 0.5490 52 0.3115 0.5500 53 0.3115 0.5510 54 0.3115 0.5518 55 0.3115 0.5518 56 0.3115 0.5518 Backward pass complete: selected 7 terms of 57, GRSq 0.311 RSq 0.374 RESULT 24: GRSq 0.3115 RSq 0.3744 nTerms 8 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 -1.01 // 0 +173 * max(0, x[1] - 0.852) // 1 -1.25e+03 * max(0, x[3] - -0.524) // 2 -1.4e+03 * max(0, x[5] - 0.327) // 3 +905 * max(0, x[5] - 0.374) // 4 +496 * max(0, x[5] - 0.242) // 5 +366 * max(0, x[3] - -0.452) // 6 +885 * max(0, x[3] - -0.554) // 7 ============================================================================= 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.1231 0.1522 0.1522 1 0.852 1 2 1 3 0.2010 0.2406 0.08841 4 -0.994< 3 1 2 5 0.2709 0.3189 0.07829 0 -0.997< 4 1 2 7 0.2887 0.3469 0.02806 3 -0.999< 5 1 2 9 0.3383 0.4030 0.0561 2 -0.997< 6 1 2 11 0.3554 0.4286 0.02561 5 -0.999< 7 1 2 13 0.3465 0.4412 0.01254 0 0.251 8 9 1 15 0.3469 0.4515 0.01034 1 0.883 10 1 17 0.3295 0.4573 0.005762 2 -0.46 11 12 1 19 0.3286 0.4766 0.0193 2 -0.457 13 14 2 2 21 0.3152 0.4862 0.009577 1 0.521 15 16 13 2 23 0.3012 0.4957 0.009505 2 0.082 17 18 14 2 25 0.3196 0.5186 0.02294 1 0.362 19 18 2 27 0.3220 0.5298 0.01114 1 0.78 20 17 2 29 0.3091 0.5399 0.01013 1 0.762 21 22 14 2 31 0.2927 0.5481 0.008162 3 -0.321 23 24 18 2 33 0.2728 0.5546 0.006568 4 0.291 25 26 14 2 35 0.2880 0.5732 0.01856 4 -0.373 27 14 2 37 0.2854 0.5808 0.007649 4 0.363 28 14 2 39 0.2892 0.5921 0.01127 4 0.222 29 14 2 41 0.2845 0.5984 0.006294 4 -0.312 30 14 2 43 0.2875 0.6090 0.01059 4 -0.428 31 14 2 45 0.2688 0.6166 0.007618 3 -0.614 32 33 14 2 47 0.2648 0.6234 0.006764 1 0.707 34 17 2 49 0.2645 0.6320 0.008628 1 0.691 35 14 2 final (reached nk 51) Reached maximum number of terms 51 After forward pass GRSq 0.265 RSq 0.632 Forward pass complete: 51 terms, 36 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.1378 0.1522 2 0.2145 0.2406 3 0.2834 0.3189 4 0.3010 0.3469 5 0.3511 0.4042 6 0.3806 0.4412 7 0.4058 0.4733 8 0.4264 0.5006 9 0.4264 0.5009 10 0.4313 0.5224 11 0.4506 0.5470 12 0.4506 0.5471 13 0.4506 0.5571 14 0.4580 0.5775 15 0.4657 0.5913 16 0.4668 0.5999 17 0.4668 0.6005 18 0.4668 0.6087 19 0.4668 0.6129 20 0.4668 0.6160 21 0.4668 0.6170 22 0.4668 0.6211 23 0.4668 0.6229 24 0.4668 0.6254 25 0.4668 0.6271 26 0.4668 0.6282 27 0.4668 0.6292 28 0.4668 0.6303 29 0.4668 0.6312 30 0.4668 0.6316 31 0.4668 0.6318 32 0.4668 0.6318 33 0.4668 0.6319 34 0.4668 0.6320 35 0.4668 0.6320 Backward pass complete: selected 16 terms of 36, GRSq 0.467 RSq 0.600 RESULT 25: GRSq 0.4668 RSq 0.5999 nTerms 17 of 36 of 51 FUNCTION eqn56 mi=2 n=300 p=6 [99.99 secs] TEST 25: FUNCTION eqn56 mi=2 n=300 p=6 0.761 // 0 +1.06e+03 * max(0, x[1] - 0.852) // 1 +296 * max(0, x[1] - 0.852) * x[4] // 2 -438 * x[0] * max(0, x[1] - 0.852) // 3 -319 * max(0, x[1] - 0.852) * x[3] // 4 +98.8 * max(0, x[1] - 0.852) * x[5] // 5 -965 * max(0, x[1] - 0.883) // 6 +80.4 * max(0, x[0] - 0.251) * max(0, x[1] - 0.521) // 7 -91.3 * max(0, x[1] - 0.362) * max(0, -0.46 - x[2]) // 8 -621 * max(0, x[1] - 0.78) * max(0, x[2] - -0.46) // 9 -595 * max(0, 0.251 - x[0]) * max(0, x[4] - 0.291) // 10 +865 * max(0, 0.251 - x[0]) * max(0, x[4] - -0.373) // 11 +294 * max(0, 0.251 - x[0]) * max(0, x[4] - 0.363) // 12 +300 * max(0, 0.251 - x[0]) * max(0, x[4] - 0.222) // 13 -407 * max(0, 0.251 - x[0]) * max(0, x[4] - -0.312) // 14 -457 * max(0, 0.251 - x[0]) * max(0, x[4] - -0.428) // 15 +204 * max(0, x[1] - 0.707) * max(0, x[2] - -0.46) // 16 ============================================================================= 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.1231 0.1522 0.1522 1 0.852 1 2 1 3 0.2010 0.2406 0.08841 4 -0.994< 3 1 2 5 0.2910 0.3376 0.09704 0 -0.997< 4 3 3 7 0.4456 0.4910 0.1534 0 -0.997< 5 1 2 9 0.4641 0.5165 0.02548 5 -0.999< 6 1 2 11 0.4775 0.5369 0.02038 1 0.941 7 1 13 0.4810 0.5481 0.01119 3 -0.999< 8 1 2 15 0.4858 0.5603 0.01221 2 -0.997< 9 1 2 17 0.4981 0.5785 0.01821 2 -0.997< 10 9 3 19 0.5036 0.5907 0.01224 1 0.883 11 1 21 0.4986 0.6016 0.01091 0 0.347 12 13 1 23 0.5396 0.6411 0.03944 2 -0.997< 14 13 3 25 0.5283 0.6461 0.004992 4 0.939 15 16 1 27 0.5164 0.6510 0.004944 4 0.811 17 18 2 2 29 0.5020 0.6546 0.003611 3 -0.524 19 20 1 31 0.4891 0.6597 0.005111 3 -0.558 21 22 2 2 33 0.4776 0.6662 0.006473 3 0.095 23 24 22 2 35 0.4616 0.6703 0.00405 5 -0.742 25 26 22 2 37 0.4604 0.6765 0.006273 5 -0.501 27 22 2 39 0.4458 0.6820 0.005414 0 -0.314 28 29 26 2 41 0.4431 0.6875 0.005502 5 0.358 30 22 2 43 0.4485 0.6973 0.009886 5 0.701 31 22 2 45 0.4465 0.7031 0.005716 5 0.213 32 22 2 47 0.4414 0.7071 0.00408 5 -0.782 33 22 2 49 0.4513 0.7255 0.01832 1 0.274 34 35 33 3 final (reached nk 51) Reached maximum number of terms 51 After forward pass GRSq 0.451 RSq 0.725 Forward pass complete: 51 terms, 36 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.1014 0.1164 2 0.2454 0.2704 3 0.3491 0.3814 4 0.4552 0.4910 5 0.5388 0.5766 6 0.5614 0.6043 7 0.5740 0.6224 8 0.5750 0.6299 9 0.5883 0.6480 10 0.5914 0.6569 11 0.5914 0.6573 12 0.5914 0.6656 13 0.5914 0.6738 14 0.5914 0.6748 15 0.5914 0.6816 16 0.5914 0.6882 17 0.5914 0.6929 18 0.5914 0.6979 19 0.5914 0.7030 20 0.5914 0.7077 21 0.5914 0.7127 22 0.5914 0.7153 23 0.5914 0.7175 24 0.5914 0.7193 25 0.5914 0.7208 26 0.5914 0.7216 27 0.5914 0.7223 28 0.5914 0.7231 29 0.5914 0.7238 30 0.5914 0.7243 31 0.5914 0.7250 32 0.5914 0.7252 33 0.5914 0.7253 34 0.5914 0.7255 35 0.5914 0.7255 Backward pass complete: selected 10 terms of 36, GRSq 0.591 RSq 0.657 RESULT 26: GRSq 0.5914 RSq 0.6569 nTerms 11 of 36 of 51 FUNCTION eqn56 mi=10 n=300 p=6 [99.99 secs] TEST 26: FUNCTION eqn56 mi=10 n=300 p=6 1.21 // 0 +198 * max(0, x[1] - 0.852) // 1 +384 * max(0, x[1] - 0.852) * x[4] // 2 -916 * x[0] * max(0, x[1] - 0.852) * x[4] // 3 -527 * x[0] * max(0, x[1] - 0.852) // 4 +183 * max(0, x[1] - 0.852) * x[5] // 5 +634 * max(0, x[1] - 0.941) // 6 -378 * max(0, x[1] - 0.852) * x[2] * x[5] // 7 +535 * max(0, x[1] - 0.852) * x[2] * x[3] // 8 -2.77 * max(0, 0.347 - x[0]) * max(0, x[5] - -0.742) // 9 +47.4 * max(0, 0.347 - x[0]) * max(0, x[1] - 0.274) * max(0, x[3] - 0.095) // 10 ============================================================================= 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.1408 0.4116 0.4116 0 0.378 1 2 1 3 0.6817 0.8634 0.4518 1 -0.371 3 4 1 5 0.9791 0.9932 0.1299 0 -0.936< 5 3 2 7 1.0000 1.0000 0.006751 0 -0.936< 6 4 2 final (max RSq) Reached maximum RSq 0.9990 at 9 terms, 7 terms used (RSq 1.0000) 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.4552 0.5450 2 0.9142 0.9412 3 0.9291 0.9611 4 0.9782 0.9906 5 0.9791 0.9932 6 1.0000 1.0000 Backward pass complete: selected 6 terms of 7, GRSq 1.000 RSq 1.000 RESULT 27: GRSq 1.0000 RSq 1.0000 nTerms 7 of 7 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.133 // 0 +0.629 * max(0, x[0] - 0.378) // 1 -0.629 * max(0, 0.378 - x[0]) // 2 +1 * max(0, x[1] - -0.371) // 3 -1 * max(0, -0.371 - x[1]) // 4 +1 * x[0] * max(0, x[1] - -0.371) // 5 -1 * x[0] * max(0, -0.371 - x[1]) // 6 ============================================================================= 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.1408 0.4116 0.4116 0 0.378 1 2 1 3 0.6817 0.8634 0.4518 1 -0.371 3 4 1 5 0.9791 0.9932 0.1299 0 -0.936< 5 3 2 7 1.0000 1.0000 0.006751 0 -0.936< 6 4 2 final (max RSq) Reached maximum RSq 0.9990 at 9 terms, 7 terms used (RSq 1.0000) 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.4552 0.5450 2 0.9142 0.9412 3 0.9291 0.9611 4 0.9782 0.9906 5 0.9791 0.9932 6 1.0000 1.0000 Backward pass complete: selected 6 terms of 7, GRSq 1.000 RSq 1.000 RESULT 28: GRSq 1.0000 RSq 1.0000 nTerms 7 of 7 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.133 // 0 +0.629 * max(0, x[0] - 0.378) // 1 -0.629 * max(0, 0.378 - x[0]) // 2 +1 * max(0, x[1] - -0.371) // 3 -1 * max(0, -0.371 - x[1]) // 4 +1 * x[0] * max(0, x[1] - -0.371) // 5 -1 * x[0] * max(0, -0.371 - x[1]) // 6 ============================================================================= 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.1408 0.4116 0.4116 0 0.378 1 2 1 3 0.6817 0.8634 0.4518 1 -0.371 3 4 1 5 0.9791 0.9932 0.1299 0 -0.936< 5 3 2 7 1.0000 1.0000 0.006751 0 -0.936< 6 4 2 final (max RSq) Reached maximum RSq 0.9990 at 9 terms, 7 terms used (RSq 1.0000) 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.4552 0.5450 2 0.9142 0.9412 3 0.9291 0.9611 4 0.9782 0.9906 5 0.9791 0.9932 6 1.0000 1.0000 Backward pass complete: selected 6 terms of 7, GRSq 1.000 RSq 1.000 RESULT 29: GRSq 1.0000 RSq 1.0000 nTerms 7 of 7 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.133 // 0 +0.629 * max(0, x[0] - 0.378) // 1 -0.629 * max(0, 0.378 - x[0]) // 2 +1 * max(0, x[1] - -0.371) // 3 -1 * max(0, -0.371 - x[1]) // 4 +1 * x[0] * max(0, x[1] - -0.371) // 5 -1 * x[0] * max(0, -0.371 - x[1]) // 6 ============================================================================= 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.6428 0.7345 0.7345 0 -0.602 1 2 1 3 1.0000 1.0000 0.2655 1 -0.953< 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.6849 0.7269 2 0.9824 0.9869 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.0000 RSq 1.0000 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.0000 RSq 1.0000 nTerms 4 of 4 of 51 TEST 30: FUNCTION x0|x0+x1 degree=1 n=30 p=2 Response 0: -0.602 // 0 +1 * max(0, x[0] - -0.602) // 1 -1 * max(0, -0.602 - x[0]) // 2 Response 1: -0.602 // 0 +1 * max(0, x[0] - -0.602) // 1 -1 * max(0, -0.602 - 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.7117 0.7346 0.7346 0 0.773 1 2 1 3 0.9912 0.9926 0.258 1 -0.63 3 4 1 5 0.9910 0.9927 0.0001543 1 0.458 5 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00015) After forward pass GRSq 0.991 RSq 0.993 Forward pass complete: 5 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.7154 0.7268 2 0.9855 0.9866 3 0.9894 0.9906 4 0.9912 0.9926 Backward pass complete: selected 4 terms of 5, GRSq 0.991 RSq 0.993 RESULT 31 Response 1: GRSq 1.0000 RSq 1.0000 nTerms 5 of 5 of 51 FUNCTION x0|x+x1+noise n=100 p=2 [99.99 secs] RESULT 31 Response 2: GRSq 0.9863 RSq 0.9885 nTerms 5 of 5 of 51 TEST 31: FUNCTION x0|x+x1+noise n=100 p=2 Response 0: 0.773 // 0 +1 * max(0, x[0] - 0.773) // 1 -1 * max(0, 0.773 - x[0]) // 2 Response 1: 0.0949 // 0 +0.9 * max(0, x[0] - 0.773) // 1 -1.01 * max(0, 0.773 - x[0]) // 2 +1.06 * max(0, x[1] - -0.63) // 3 -0.688 * max(0, -0.63 - 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.4651 0.5075 0.5075 1 0.761 1 2 1 3 0.8681 0.8885 0.381 0 -0.509 3 4 1 5 0.8632 0.8895 0.0009622 1 0.608 5 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 5 terms (DeltaRSq 0.00096) After forward pass GRSq 0.863 RSq 0.889 Forward pass complete: 5 terms Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.4362 0.4587 2 0.8218 0.8359 3 0.8536 0.8708 4 0.8681 0.8885 Backward pass complete: selected 4 terms of 5, GRSq 0.868 RSq 0.889 RESULT 32 Response 1: GRSq 0.8681 RSq 0.8885 nTerms 5 of 5 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 0.8681 RSq 0.8885 nTerms 5 of 5 of 51 TEST 32: FUNCTION x0+x1+x0*x1|x0+x1+x0*x1 degree=1 n=100 p=2 Response 0: 0.259 // 0 +4.97 * max(0, x[1] - 0.761) // 1 -0.955 * max(0, 0.761 - x[1]) // 2 +0.88 * max(0, x[0] - -0.509) // 3 -1.14 * max(0, -0.509 - x[0]) // 4 Response 1: 0.259 // 0 +4.97 * max(0, x[1] - 0.761) // 1 -0.955 * max(0, 0.761 - x[1]) // 2 +0.88 * max(0, x[0] - -0.509) // 3 -1.14 * max(0, -0.509 - x[0]) // 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.4537 0.5075 0.5075 1 0.761 1 2 1 3 0.8621 0.8885 0.381 0 -0.509 3 4 1 5 0.9997 0.9998 0.1113 0 -0.378 5 6 2 2 final (max RSq) Reached maximum RSq 0.9990 at 7 terms (RSq 0.9998) 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.4303 0.4587 2 0.9612 0.9650 3 0.9814 0.9841 4 0.9880 0.9903 5 0.9956 0.9966 6 0.9997 0.9998 Backward pass complete: selected 6 terms of 7, GRSq 1.000 RSq 1.000 RESULT 33 Response 1: GRSq 0.9997 RSq 0.9998 nTerms 7 of 7 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 0.9997 RSq 0.9998 nTerms 7 of 7 of 51 TEST 33: FUNCTION x0+x1+x0*x1|x0+x1+x0*x1 degree=2 n=100 p=2 Response 0: -0.16 // 0 +1.6 * max(0, x[1] - 0.761) // 1 -0.602 * max(0, 0.761 - x[1]) // 2 +1.79 * max(0, x[0] - -0.509) // 3 -1.72 * max(0, -0.509 - x[0]) // 4 -1.03 * max(0, x[0] - -0.378) * max(0, 0.761 - x[1]) // 5 +0.981 * max(0, -0.378 - x[0]) * max(0, 0.761 - x[1]) // 6 Response 1: -0.16 // 0 +1.6 * max(0, x[1] - 0.761) // 1 -0.602 * max(0, 0.761 - x[1]) // 2 +1.79 * max(0, x[0] - -0.509) // 3 -1.72 * max(0, -0.509 - x[0]) // 4 -1.03 * max(0, x[0] - -0.378) * max(0, 0.761 - x[1]) // 5 +0.981 * max(0, -0.378 - x[0]) * max(0, 0.761 - x[1]) // 6 ============================================================================= 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.5502 0.5725 0.5725 1 0.239 1 2 1 3 0.9806 0.9825 0.4099 0 -0.689 3 4 1 5 0.9946 0.9954 0.01294 0 0.449 5 6 2 2 7 0.9977 0.9981 0.002631 0 0.67 7 1 9 0.9986 0.9989 0.0008206 0 -0.395 8 9 1 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 9 terms, 8 terms used (DeltaRSq 0.00082) 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.4921 0.5048 2 0.9260 0.9297 3 0.9789 0.9804 4 0.9860 0.9874 5 0.9943 0.9950 6 0.9965 0.9970 7 0.9977 0.9981 Backward pass complete: selected 7 terms of 8, GRSq 0.998 RSq 0.998 RESULT 34 Response 1: GRSq 1.0000 RSq 1.0000 nTerms 8 of 8 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.9972 RSq 0.9977 nTerms 8 of 8 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.689 // 0 +1 * max(0, x[0] - -0.689) // 3 -1 * max(0, -0.689 - x[0]) // 4 Response 1: -0.772 // 0 +1.94 * max(0, x[1] - 0.239) // 1 -2.25 * max(0, 0.239 - x[1]) // 2 +1.82 * max(0, x[0] - -0.689) // 3 +0.72 * max(0, -0.689 - x[0]) // 4 -1.03 * max(0, x[0] - 0.449) * max(0, 0.239 - x[1]) // 5 +0.549 * max(0, 0.449 - x[0]) * max(0, 0.239 - x[1]) // 6 -1.74 * max(0, x[0] - 0.67) // 7 ============================================================================= 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.5854 0.6060 0.606 1 0.253 1 2 1 3 0.9551 0.9595 0.3535 0 -0.592 3 4 1 5 0.9934 0.9943 0.03487 1 -0.527 5 6 3 2 7 0.9987 0.9989 0.004543 0 0.534 7 1 9 0.9995 0.9996 0.0007087 1 -0.982< 8 4 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 9 terms, 8 terms used (DeltaRSq 0.00071) 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.4937 0.5063 2 0.8901 0.8956 3 0.9658 0.9683 4 0.9866 0.9879 5 0.9926 0.9935 6 0.9964 0.9969 7 0.9987 0.9989 Backward pass complete: selected 7 terms of 8, GRSq 0.999 RSq 0.999 RESULT 35 Response 1: GRSq 1.0000 RSq 1.0000 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.9973 RSq 0.9978 nTerms 8 of 8 of 101 RESULT 35 Response 3: GRSq 0.9990 RSq 0.9992 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.592 // 0 +1 * max(0, x[ 0] - -0.592) // 3 -1 * max(0, -0.592 - x[ 0]) // 4 Response 1: -0.513 // 0 +0.351 * max(0, x[ 1] - 0.253) // 1 -0.325 * max(0, 0.253 - x[ 1]) // 2 +0.437 * max(0, x[ 0] - -0.592) // 3 -0.94 * max(0, -0.592 - x[ 0]) // 4 +1.07 * max(0, x[ 0] - -0.592) * max(0, x[ 1] - -0.527) // 5 -1.09 * max(0, x[ 0] - -0.592) * max(0, -0.527 - x[ 1]) // 6 -0.0125 * max(0, x[ 0] - 0.534) // 7 Response 2: -0.601 // 0 +1.67 * max(0, x[ 1] - 0.253) // 1 -1.66 * max(0, 0.253 - x[ 1]) // 2 +1.45 * max(0, x[ 0] - -0.592) // 3 +0.234 * max(0, -0.592 - x[ 0]) // 4 +0.543 * max(0, x[ 0] - -0.592) * max(0, x[ 1] - -0.527) // 5 -0.529 * max(0, x[ 0] - -0.592) * max(0, -0.527 - x[ 1]) // 6 -1.63 * max(0, x[ 0] - 0.534) // 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.5854 0.6060 0.606 1 0.253 1 2 1 3 0.9551 0.9595 0.3535 0 -0.592 3 4 1 5 0.9934 0.9943 0.03487 1 -0.527 5 6 3 2 7 0.9987 0.9989 0.004543 0 0.534 7 1 9 0.9995 0.9996 0.0007087 1 -0.982< 8 4 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 9 terms, 8 terms used (DeltaRSq 0.00071) 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.4937 0.5063 2 0.8901 0.8956 3 0.9658 0.9683 4 0.9866 0.9879 5 0.9926 0.9935 6 0.9964 0.9969 7 0.9987 0.9989 Backward pass complete: selected 7 terms of 8, GRSq 0.999 RSq 0.999 RESULT 36 Response 1: GRSq 0.9973 RSq 0.9978 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.9990 RSq 0.9992 nTerms 8 of 8 of 101 RESULT 36 Response 3: GRSq 1.0000 RSq 1.0000 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.513 // 0 +0.351 * max(0, x[ 1] - 0.253) // 1 -0.325 * max(0, 0.253 - x[ 1]) // 2 +0.437 * max(0, x[ 0] - -0.592) // 3 -0.94 * max(0, -0.592 - x[ 0]) // 4 +1.07 * max(0, x[ 0] - -0.592) * max(0, x[ 1] - -0.527) // 5 -1.09 * max(0, x[ 0] - -0.592) * max(0, -0.527 - x[ 1]) // 6 -0.0125 * max(0, x[ 0] - 0.534) // 7 Response 1: -0.601 // 0 +1.67 * max(0, x[ 1] - 0.253) // 1 -1.66 * max(0, 0.253 - x[ 1]) // 2 +1.45 * max(0, x[ 0] - -0.592) // 3 +0.234 * max(0, -0.592 - x[ 0]) // 4 +0.543 * max(0, x[ 0] - -0.592) * max(0, x[ 1] - -0.527) // 5 -0.529 * max(0, x[ 0] - -0.592) * max(0, -0.527 - x[ 1]) // 6 -1.63 * max(0, x[ 0] - 0.534) // 7 Response 2: -0.592 // 0 +1 * max(0, x[ 0] - -0.592) // 3 -1 * max(0, -0.592 - 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.5854 0.6060 0.606 1 0.253 1 2 1 3 0.9551 0.9595 0.3535 0 -0.592 3 4 1 5 0.9934 0.9943 0.03487 1 -0.527 5 6 3 2 7 0.9987 0.9989 0.004543 0 0.534 7 1 9 0.9995 0.9996 0.0007087 1 -0.982< 8 4 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 9 terms, 8 terms used (DeltaRSq 0.00071) 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.4937 0.5063 2 0.8901 0.8956 3 0.9658 0.9683 4 0.9866 0.9879 5 0.9926 0.9935 6 0.9964 0.9969 7 0.9987 0.9989 Backward pass complete: selected 7 terms of 8, GRSq 0.999 RSq 0.999 RESULT 37 Response 1: GRSq 0.9990 RSq 0.9992 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.9973 RSq 0.9978 nTerms 8 of 8 of 101 RESULT 37 Response 3: GRSq 1.0000 RSq 1.0000 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.601 // 0 +1.67 * max(0, x[ 1] - 0.253) // 1 -1.66 * max(0, 0.253 - x[ 1]) // 2 +1.45 * max(0, x[ 0] - -0.592) // 3 +0.234 * max(0, -0.592 - x[ 0]) // 4 +0.543 * max(0, x[ 0] - -0.592) * max(0, x[ 1] - -0.527) // 5 -0.529 * max(0, x[ 0] - -0.592) * max(0, -0.527 - x[ 1]) // 6 -1.63 * max(0, x[ 0] - 0.534) // 7 Response 1: -0.513 // 0 +0.351 * max(0, x[ 1] - 0.253) // 1 -0.325 * max(0, 0.253 - x[ 1]) // 2 +0.437 * max(0, x[ 0] - -0.592) // 3 -0.94 * max(0, -0.592 - x[ 0]) // 4 +1.07 * max(0, x[ 0] - -0.592) * max(0, x[ 1] - -0.527) // 5 -1.09 * max(0, x[ 0] - -0.592) * max(0, -0.527 - x[ 1]) // 6 -0.0125 * max(0, x[ 0] - 0.534) // 7 Response 2: -0.592 // 0 +1 * max(0, x[ 0] - -0.592) // 3 -1 * max(0, -0.592 - 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.3524 0.3589 0.3589 1 0.674 1 2 1 3 0.5670 0.5756 0.2167 0 0.648 3 4 1 5 0.6806 0.6902 0.1146 2 0.863 5 6 1 7 0.7540 0.7637 0.07359 3 0.974 7 8 1 9 0.8289 0.8374 0.07364 5 0.649 9 10 1 11 0.8984 0.9044 0.06706 4 0.937 11 12 1 13 0.9348 0.9393 0.03482 0 -0.555 13 14 2 2 15 0.9679 0.9704 0.03113 3 -0.805 15 16 6 2 17 0.9948 0.9953 0.0249 5 0.371 17 18 12 2 19 0.9965 0.9968 0.001509 0 -0.572 19 1 21 0.9969 0.9972 0.0003714 0 0.293 20 21 1 2 reject (small DeltaRSq) RSq changed by less than 0.001 at 21 terms, 20 terms used (DeltaRSq 0.00037) After forward pass GRSq 0.997 RSq 0.997 Forward pass complete: 21 terms, 20 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.3540 0.3572 2 0.5631 0.5675 3 0.6472 0.6525 4 0.7800 0.7844 5 0.8525 0.8562 6 0.9242 0.9265 7 0.9560 0.9575 8 0.9809 0.9816 9 0.9854 0.9861 10 0.9895 0.9900 11 0.9903 0.9908 12 0.9926 0.9930 13 0.9946 0.9949 14 0.9955 0.9958 15 0.9960 0.9963 16 0.9964 0.9967 17 0.9965 0.9968 18 0.9965 0.9968 19 0.9965 0.9968 Backward pass complete: selected 17 terms of 20, GRSq 0.997 RSq 0.997 RESULT 38 Response 1: GRSq 0.9988 RSq 0.9989 nTerms 18 of 20 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 -5.5309 RSq -4.9870 nTerms 18 of 20 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.612 // 0 +1.94 * max(0, x[1] - 0.674) // 1 -1.71 * max(0, 0.674 - x[1]) // 2 -1.83 * max(0, x[0] - 0.648) // 3 -0.362 * max(0, 0.648 - x[0]) // 4 -0.0479 * max(0, x[2] - 0.863) // 5 +0.00238 * max(0, 0.863 - x[2]) // 6 -0.00414 * max(0, 0.974 - x[3]) // 7 -0.0695 * max(0, x[5] - 0.649) // 8 -0.0013 * max(0, 0.649 - x[5]) // 9 -0.00138 * max(0, 0.937 - x[4]) // 10 -0.526 * max(0, x[0] - -0.555) * max(0, 0.674 - x[1]) // 11 +0.561 * max(0, -0.555 - x[0]) * max(0, 0.674 - x[1]) // 12 -0.006 * max(0, 0.863 - x[2]) * max(0, x[3] - -0.805) // 13 -0.0228 * max(0, 0.863 - x[2]) * max(0, -0.805 - x[3]) // 14 +0.0199 * max(0, 0.937 - x[4]) * max(0, x[5] - 0.371) // 15 -0.00126 * max(0, 0.937 - x[4]) * max(0, 0.371 - x[5]) // 16 +1.69 * max(0, x[0] - -0.572) // 17 Response 1: -0.385 // 0 +1.6 * max(0, x[1] - 0.674) // 1 -1.64 * max(0, 0.674 - x[1]) // 2 +1.33 * max(0, x[0] - 0.648) // 3 -0.189 * max(0, 0.648 - x[0]) // 4 -1.88 * max(0, x[2] - 0.863) // 5 +2.13 * max(0, 0.863 - x[2]) // 6 -1.92 * max(0, 0.974 - x[3]) // 7 -1.35 * max(0, x[5] - 0.649) // 8 -1.09 * max(0, 0.649 - x[5]) // 9 +0.869 * max(0, 0.937 - x[4]) // 10 -1 * max(0, x[0] - -0.555) * max(0, 0.674 - x[1]) // 11 +1.07 * max(0, -0.555 - x[0]) * max(0, 0.674 - x[1]) // 12 -1.07 * max(0, 0.863 - x[2]) * max(0, x[3] - -0.805) // 13 +0.984 * max(0, 0.863 - x[2]) * max(0, -0.805 - x[3]) // 14 +0.125 * max(0, 0.937 - x[4]) * max(0, x[5] - 0.371) // 15 +1.07 * max(0, 0.937 - x[4]) * max(0, 0.371 - x[5]) // 16 -1.07 * max(0, x[0] - -0.572) // 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.8491 0.8610 0.861 1 0.062785 1 2 1 3 0.8501 0.8734 0.01234 0 0.683 3 4 1 5 0.8611 0.8878 0.01441 1 -0.38899 5 1 7 0.8604 0.8922 0.004396 0 0.217 6 1 9 0.8552 0.8933 0.001135 0 0.773 7 1 11 0.8498 0.8944 0.001105 0 0.885 8 1 13 0.8432 0.8950 0.0006473 1 0.36317 9 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 13 terms, 9 terms used (DeltaRSq 0.00065) After forward pass GRSq 0.843 RSq 0.895 Forward pass complete: 13 terms, 9 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.2512 0.2811 2 0.8390 0.8518 3 0.8611 0.8774 4 0.8717 0.8916 5 0.8717 0.8921 6 0.8717 0.8932 7 0.8717 0.8944 8 0.8717 0.8944 Backward pass complete: selected 4 terms of 9, GRSq 0.872 RSq 0.892 RESULT 39: GRSq 0.8717 RSq 0.8916 nTerms 5 of 9 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.61 // 0 -0.607 * max(0, 0.0628 - x[1]) // 1 -0.464 * max(0, 0.683 - x[0]) // 2 -0.666 * max(0, x[1] - -0.389) // 3 -0.769 * max(0, x[0] - 0.217) // 4 ============================================================================= 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.8491 0.8610 0.861 1 0.062785 1 2 1 3 0.8501 0.8734 0.01234 0 0.683 3 4 1 5 0.8611 0.8878 0.01441 1 -0.38899 5 1 7 0.8604 0.8922 0.004396 0 0.217 6 1 9 0.8552 0.8933 0.001135 0 0.773 7 1 11 0.8498 0.8944 0.001105 0 0.885 8 1 13 0.8432 0.8950 0.0006473 1 0.36317 9 1 reject (small DeltaRSq) RSq changed by less than 0.001 at 13 terms, 9 terms used (DeltaRSq 0.00065) After forward pass GRSq 0.843 RSq 0.895 Forward pass complete: 13 terms, 9 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.2512 0.2811 2 0.8390 0.8518 3 0.8611 0.8774 4 0.8717 0.8916 5 0.8717 0.8921 6 0.8717 0.8932 7 0.8717 0.8944 8 0.8717 0.8944 Backward pass complete: selected 4 terms of 9, GRSq 0.872 RSq 0.892 RESULT 40: GRSq 0.8717 RSq 0.8916 nTerms 5 of 9 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.61 // 0 -0.607 * max(0, 0.0628 - x[1]) // 1 -0.464 * max(0, 0.683 - x[0]) // 2 -0.666 * max(0, x[1] - -0.389) // 3 -0.769 * max(0, x[0] - 0.217) // 4 ============================================================================= TEST 41: binary 20 preds + muchnoise 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.0919 0.1372 0.1372 8 0< 1 1 3 0.1702 0.2519 0.1147 19 0< 2 1 5 0.2182 0.3321 0.08027 1 0< 3 1 7 0.2399 0.3857 0.05358 7 0< 4 3 2 9 0.2521 0.4290 0.04328 9 0< 5 1 11 0.2809 0.4823 0.05329 18 0< 6 1 13 0.2933 0.5211 0.03879 0 0< 7 1 2 15 0.3283 0.5723 0.05116 3 0< 8 1 2 17 0.3362 0.6036 0.03136 26 0< 9 1 2 19 0.3508 0.6373 0.03366 6 0< 10 1 21 0.3730 0.6730 0.03569 6 0< 11 5 2 23 0.3824 0.7000 0.02703 26 0< 12 5 2 25 0.3856 0.7228 0.02277 16 0< 13 1 2 27 0.3767 0.7395 0.01676 16 0< 14 5 2 29 0.3617 0.7537 0.01417 15 0< 15 9 2 31 0.3502 0.7692 0.01554 5 0< 16 1 33 0.3311 0.7821 0.0129 25 0< 17 9 2 35 0.3036 0.7928 0.01068 21 0< 18 1 2 37 0.2856 0.8067 0.01385 21 0< 19 5 2 39 0.2582 0.8183 0.01161 20 0< 20 19 2 41 0.2167 0.8272 0.00891 14 0< 21 11 2 43 0.1806 0.8381 0.01095 21 0< 22 1 45 0.1222 0.8458 0.007623 10 0< 23 11 2 47 0.0551 0.8534 0.007611 7 0< 24 1 2 49 0.0084 0.8652 0.01184 7 0< 25 11 2 51 -0.0438 0.8769 0.01167 15 0< 26 19 2 53 -0.1288 0.8857 0.008835 18 0< 27 5 2 55 -0.2223 0.8951 0.009403 11 0< 28 1 2 57 -0.3281 0.9048 0.009721 25 0< 29 5 2 59 -0.5329 0.9099 0.00507 27 0< 30 1 61 -0.8069 0.9148 0.004869 12 0< 31 1 2 63 -1.1705 0.9201 0.005272 15 0< 32 3 2 65 -1.6973 0.9251 0.005022 29 0< 33 3 2 67 -2.5280 0.9294 0.004372 22 0< 34 1 2 69 -3.8549 0.9345 0.005043 0 0< 35 11 2 71 -6.2539 0.9401 0.00556 24 0< 36 11 2 73 -11.6389 0.9455 0.005466 24 0< 37 9 2 reject (negative GRSq) Reached minimum GRSq -10 at 73 terms, 37 terms used (GRSq -12) After forward pass GRSq -11.639 RSq 0.946 Forward pass complete: 73 terms, 37 terms used Backward pass: SubsetSize GRSq RSq 0 0.0000 0.0000 1 0.1206 0.1645 2 0.2202 0.2970 3 0.2757 0.3813 4 0.3316 0.4598 5 0.3551 0.5077 6 0.4060 0.5724 7 0.4421 0.6219 8 0.4421 0.6325 9 0.4421 0.6609 10 0.4421 0.6851 11 0.4823 0.7300 12 0.4823 0.7405 13 0.4823 0.7631 14 0.4829 0.7839 15 0.4829 0.7995 16 0.4829 0.8069 17 0.4829 0.8155 18 0.4829 0.8295 19 0.4829 0.8449 20 0.4829 0.8495 21 0.4829 0.8596 22 0.4829 0.8683 23 0.4829 0.8762 24 0.4829 0.8841 25 0.4829 0.8939 26 0.4829 0.9007 27 0.4829 0.9075 28 0.4829 0.9093 29 0.4829 0.9141 30 0.4829 0.9203 31 0.4829 0.9252 32 0.4829 0.9305 33 0.4829 0.9361 34 0.4829 0.9390 35 0.4829 0.9400 36 0.4829 0.9401 Backward pass complete: selected 14 terms of 37, GRSq 0.483 RSq 0.784 RESULT 41: GRSq 0.4829 RSq 0.7839 nTerms 15 of 37 of 101 FUNCTION binary 20 preds + muchnoise n=100 p=30 [99.99 secs] TEST 41: FUNCTION binary 20 preds + muchnoise n=100 p=30 4.9 // 0 +4.33 * x[ 1] // 1 +1.57 * x[ 7] * x[19] // 2 +1.82 * x[ 0] * x[ 8] // 3 +2.4 * x[ 3] * x[ 8] // 4 +1.83 * x[ 8] * x[26] // 5 +1.79 * x[ 6] // 6 -2.12 * x[ 1] * x[ 6] // 7 -2.01 * x[ 1] * x[26] // 8 +1.28 * x[ 8] * x[16] // 9 +1.66 * x[ 9] * x[15] // 10 -3.23 * x[ 8] * x[21] // 11 +2.18 * x[ 6] * x[20] // 12 +2.2 * x[14] * x[18] // 13 +1.92 * x[21] // 14 ============================================================================= TEST 42: binary 20 preds + muchnoise (no prune) 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.0919 0.1372 0.1372 8 0< 1 1 3 0.1702 0.2519 0.1147 19 0< 2 1 5 0.2182 0.3321 0.08027 1 0< 3 1 7 0.2399 0.3857 0.05358 7 0< 4 3 2 9 0.2521 0.4290 0.04328 9 0< 5 1 11 0.2809 0.4823 0.05329 18 0< 6 1 13 0.2933 0.5211 0.03879 0 0< 7 1 2 15 0.3283 0.5723 0.05116 3 0< 8 1 2 17 0.3362 0.6036 0.03136 26 0< 9 1 2 19 0.3508 0.6373 0.03366 6 0< 10 1 21 0.3730 0.6730 0.03569 6 0< 11 5 2 23 0.3824 0.7000 0.02703 26 0< 12 5 2 25 0.3856 0.7228 0.02277 16 0< 13 1 2 27 0.3767 0.7395 0.01676 16 0< 14 5 2 29 0.3617 0.7537 0.01417 15 0< 15 9 2 31 0.3502 0.7692 0.01554 5 0< 16 1 33 0.3311 0.7821 0.0129 25 0< 17 9 2 35 0.3036 0.7928 0.01068 21 0< 18 1 2 37 0.2856 0.8067 0.01385 21 0< 19 5 2 39 0.2582 0.8183 0.01161 20 0< 20 19 2 41 0.2167 0.8272 0.00891 14 0< 21 11 2 43 0.1806 0.8381 0.01095 21 0< 22 1 45 0.1222 0.8458 0.007623 10 0< 23 11 2 47 0.0551 0.8534 0.007611 7 0< 24 1 2 49 0.0084 0.8652 0.01184 7 0< 25 11 2 51 -0.0438 0.8769 0.01167 15 0< 26 19 2 53 -0.1288 0.8857 0.008835 18 0< 27 5 2 55 -0.2223 0.8951 0.009403 11 0< 28 1 2 57 -0.3281 0.9048 0.009721 25 0< 29 5 2 59 -0.5329 0.9099 0.00507 27 0< 30 1 61 -0.8069 0.9148 0.004869 12 0< 31 1 2 63 -1.1705 0.9201 0.005272 15 0< 32 3 2 65 -1.6973 0.9251 0.005022 29 0< 33 3 2 67 -2.5280 0.9294 0.004372 22 0< 34 1 2 69 -3.8549 0.9345 0.005043 0 0< 35 11 2 71 -6.2539 0.9401 0.00556 24 0< 36 11 2 73 -11.6389 0.9455 0.005466 24 0< 37 9 2 reject (negative GRSq) Reached minimum GRSq -10 at 73 terms, 37 terms used (GRSq -12) After forward pass GRSq -11.639 RSq 0.946 Forward pass complete: 73 terms, 37 terms used RESULT 42: GRSq -6.2539 RSq 0.9401 nTerms 37 of 37 of 101 FUNCTION binary 20 preds + muchnoise (no prune) n=100 p=30 [99.99 secs] TEST 42: FUNCTION binary 20 preds + muchnoise (no prune) n=100 p=30 4.73 // 0 -4.37 * x[ 8] // 1 -1.33 * x[19] // 2 +3.33 * x[ 1] // 3 +2.09 * x[ 7] * x[19] // 4 +1.65 * x[ 9] // 5 +1.47 * x[18] // 6 +2.88 * x[ 0] * x[ 8] // 7 +1.97 * x[ 3] * x[ 8] // 8 +2.08 * x[ 8] * x[26] // 9 +3.76 * x[ 6] // 10 -2.94 * x[ 1] * x[ 6] // 11 -2.06 * x[ 1] * x[26] // 12 +1.92 * x[ 8] * x[16] // 13 -0.384 * x[ 1] * x[16] // 14 +2.32 * x[ 9] * x[15] // 15 +0.937 * x[ 5] // 16 -2.57 * x[ 9] * x[25] // 17 -4.5 * x[ 8] * x[21] // 18 +0.0399 * x[ 1] * x[21] // 19 +1.5 * x[ 6] * x[20] // 20 +2.16 * x[14] * x[18] // 21 +1.86 * x[21] // 22 +0.581 * x[10] * x[18] // 23 +2.95 * x[ 7] * x[ 8] // 24 -2.59 * x[ 7] * x[18] // 25 -2.9 * x[ 6] * x[15] // 26 +1.25 * x[ 1] * x[18] // 27 +1.31 * x[ 8] * x[11] // 28 +1.57 * x[ 1] * x[25] // 29 -1.05 * x[27] // 30 +1.47 * x[ 8] * x[12] // 31 +1.13 * x[15] * x[19] // 32 +1.04 * x[19] * x[29] // 33 +0.95 * x[ 8] * x[22] // 34 -1.16 * x[ 0] * x[18] // 35 +0.867 * x[18] * x[24] // 36 earth/inst/slowtests/test.weights.R0000644000176200001440000006463614241600503017166 0ustar liggesusers# test.weights.R source("test.prolog.R") source("check.models.equal.R") library(earth) options(warn=1) # print warnings as they occur 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 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), 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(org.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) # par(org.par) # 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), 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) expect.err(try(earth(y~., data=data, wp=3, Scale.y=TRUE)), "Scale.y=TRUE is not allowed with wp") expect.err(try(earth(y~., data=data, Scale.y=999)), "Scale.y=999 but it should be FALSE, TRUE, 0, or 1") 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") 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,]) # trace=2 so we see "Fixed rank deficient bx" mod7 <- earth(O3~., ozone1, weights=sqrt(ozone1$O3), Scale.y=FALSE, trace=2) mod8 <- earth(O3~., ozone1, weights=sqrt(ozone1$O3), Scale.y=TRUE, trace=2) 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.R0000644000176200001440000005312014565631517017006 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)) 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(org.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 ~ offset(log(Holders)) + Group + Age + day, 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(org.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(org.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\"") par(org.par) 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)) cat("\nnearth31.weights.offset$modvars:\n") print.default(earth31.weights.offset$modvars) source("test.epilog.R") earth/inst/slowtests/test.bpairs.bat0000755000176200001440000000145614563571565017361 0ustar liggesusers@rem test.bpairs.bat @echo test.bpairs.bat @"C:\PROGRA~1\R\R-4.3.2\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.bat0000755000176200001440000000160214563571565020630 0ustar liggesusers@rem test.expand.bpairs.bat @echo test.expand.bpairs.bat @"C:\PROGRA~1\R\R-4.3.2\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.R0000644000176200001440000000034013725313736016770 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.save0000644000176200001440000021432214563605665021066 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") > options(warn=1) # print warnings as they occur > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > 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(org.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 + } > 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 > VolNeg.randx <- earth(VolNeg~randx, trace=1) # intercept only model 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 > plotmo(VolNeg.randx) > 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(org.par) > 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 > > # 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(org.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(org.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(org.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(org.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(org.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(org.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))) > > # TODO Sep 2020: work around for model.matrix.Formula which incorrectly includes log(03) on lhs > expect.err(try(earth(log(O3 + wind) + ibt ~ temp, data=ozone1, trace=1)), + "terms like 'log(O3 + wind)' are not allowed on the LHS of a multiple-response formula") Using class "Formula" because lhs of formula has terms separated by "+" Error : terms like 'log(O3 + wind)' are not allowed on the LHS of a multiple-response formula Got expected error from try(earth(log(O3 + wind) + ibt ~ temp, data = ozone1, trace = 1)) > > 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 expected error 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 expected error from try(show.earth.Formula(VolNeg + Volume ~ Volume, nresponses = 2)) > # formula has better error handling than Formula (model.matrix.default gives warning) > options(warn=2) > 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 expected error from try(show.earth.formula(Volume ~ Volume)) > options(warn=1) # print warnings as they occur > 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 > VolNeg.SinVol.randx <- earth(VolNeg+SinVol~randx, trace=1) # intercept only model 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 > plotmo(VolNeg.SinVol.randx, nresponse=2) > > # 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 expected error 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 expected error 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 expected error 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 expected error from try(earth(Volume + VolNeg/99 + SinVol ~ ., data = trees, trace = 1)) > > library(earth) > data(ozone1) > > # TODO Sep 2020: work around for model.matrix.Formula which incorrectly includes log(03)+wind on lhs > expect.err(try(earth(log(O3) + wind ~ ., data=ozone1, trace=1)), + "terms like 'log(O3)' are not allowed on the LHS of a multiple-response formula") Using class "Formula" because lhs of formula has terms separated by "+" Error : terms like 'log(O3)' are not allowed on the LHS of a multiple-response formula Got expected error from try(earth(log(O3) + wind ~ ., data = ozone1, trace = 1)) > > 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 expected error from try(coef(a1)) > options(warn=1) > 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))) > > # TODO Sep 2020: work around for model.matrix.Formula which incorrectly includes log(03) on lhs > expect.err(try(earth(log(O3)+wind ~ humidity+temp, data=ozone1)), + "terms like 'log(O3)' are not allowed on the LHS of a multiple-response formula") Error : terms like 'log(O3)' are not allowed on the LHS of a multiple-response formula Got expected error from try(earth(log(O3) + wind ~ humidity + temp, data = ozone1)) > > # 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)) > 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): > options(warn=2) > 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 expected error from try(plotmo(pclass.age, nresponse = 5, main = "nresponse=5", do.par = FALSE)) > options(warn=1) > > age.pclass <- earth(age+pclass~sibsp, data=etitanic) > par(mfrow=c(2,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): > options(warn=2) > 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 expected error from try(plotmo(age.pclass, nresponse = 5, main = "nresponse=5", do.par = FALSE)) > options(warn=1) > > pclass.sex <- earth(pclass+sex~sibsp, data=etitanic) > par(mfrow=c(2,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): > options(warn=2) > 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 expected error from try(plotmo(pclass.sex, nresponse = 5, main = "nresponse=5", do.par = FALSE)) > options(warn=1) > > # try to delete a varname (expose bug in model.matrix.Formula) > options(warn=2) > expect.err(try(earth(pclass+sex~.-survived, data=etitanic)), "'varlist' has changed (from nvar=4) to new 5 after EncodeVars() -- should no longer happen!") Error in terms.formula(form, data = data) : (converted from warning) 'varlist' has changed (from nvar=4) to new 5 after EncodeVars() -- should no longer happen! Got expected error from try(earth(pclass + sex ~ . - survived, data = etitanic)) > options(warn=1) > expect.err(try(earth(pclass+sex~.-survived, data=etitanic)), "model frame and formula mismatch in model.matrix()") Warning in terms.formula(form, data = data) : 'varlist' has changed (from nvar=4) to new 5 after EncodeVars() -- should no longer happen! Error in model.matrix.default(mt, data = data, ...) : model frame and formula mismatch in model.matrix() Got expected error from try(earth(pclass + sex ~ . - survived, data = etitanic)) > > # try to delete a varname not in data (expose bug in model.matrix.Formula) > options(warn=2) > expect.err(try(earth(pclass+sex~.-nonesuch, data=etitanic)), "'varlist' has changed (from nvar=5) to new 6 after EncodeVars() -- should no longer happen!") Error in terms.formula(fi, ...) : (converted from warning) 'varlist' has changed (from nvar=5) to new 6 after EncodeVars() -- should no longer happen! Got expected error from try(earth(pclass + sex ~ . - nonesuch, data = etitanic)) > options(warn=1) > expect.err(try(earth(pclass+sex~.-nonesuch, data=etitanic)), "model frame and formula mismatch in model.matrix()") Warning in terms.formula(fi, ...) : 'varlist' has changed (from nvar=5) to new 6 after EncodeVars() -- should no longer happen! Warning in terms.formula(form, data = data) : 'varlist' has changed (from nvar=5) to new 6 after EncodeVars() -- should no longer happen! Error in model.matrix.default(mt, data = data, ...) : model frame and formula mismatch in model.matrix() Got expected error from try(earth(pclass + sex ~ . - nonesuch, data = etitanic)) > > source("test.epilog.R") earth/inst/slowtests/test.varmod.bat0000755000176200001440000000153214563571565017364 0ustar liggesusers@rem test.varmod.bat @rem Stephen Milborrow Dec 2014 Shrewsbury @echo test.varmod.bat @"C:\PROGRA~1\R\R-4.3.2\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.cv.R0000644000176200001440000003340314565632543016132 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 par(mfrow=c(2,2), mar=c(4, 3.2, 3, 3), mgp=c(1.6, 0.6, 0), 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(org.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.R0000644000176200001440000006355313737701220016462 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 <- TRUE 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.3f 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.bat0000755000176200001440000000174014563571565020065 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-4.3.2\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 -w to treat \n same as \r\n @mks.diff -w test.incorrect.Rout test.incorrect.Rout.save @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 @rm -f Rplots.ps @exit /B 0 earth/inst/slowtests/test.bpairs.R0000644000176200001440000006435014565632543017007 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) options(warn=1) # print warnings as they occur 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(org.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(org.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(org.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(org.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(org.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~as.numeric(shade)+wide+tall*time, data=lizards, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1, trace=1) print(summary(eliz)) eliz.Formula <- earth(grahami+opalinus~as.numeric(shade)+wide+tall*time, data=lizards, glm=list(family="binomial"), linpreds=TRUE, thresh=0, penalty=-1, trace=1) print(summary(eliz.Formula)) gliz <- glm(grahami.opalinus~as.numeric(shade)+wide+tall*time, data=lizards, family="binomial") print(summary(gliz)) check.earth.matches.glm(eliz, gliz, newdata=lizards[c(2:5),], max=1e-12) check.earth.matches.glm(eliz.Formula, gliz, newdata=lizards[c(2:5),], max=1e-12) 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(org.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) # Terms on lhs like I(20-numdead) are not supported in multiple response Formulas # (else `log(O3)` is included in model matrix if log(O3) is used on lhs of the Formula) # Tested Sep 2020, problem in Formula package? expect.err(try(earth(I(20-numdead) + numdead ~ sex + ldose, data=df, trace=1, pmethod="none", glm=list(family=binomial))), "terms like 'I(20 - numdead)' are not allowed on the LHS of a multiple-response formula") 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() plot.earth.models(list(earth_cv, earth_cv$cv.list[[1]], earth_cv$cv.list[[2]]), which=1:2, do.par=0) # try plotmo on one of the fold models expect.err(try(plotmo(earth_cv$cv.list[[1]])), "cannot get the original model predictors (use keepxy=2 in the call to earth)") # can plotmo on a fold model if we use keepxy=2 in call to earth set.seed(2020) earth_cv.keepxy2 <- earth(good+bad~., data=data, glm=list(family=binomial), trace=.5, nfold=2, keepxy=2) plotmo(earth_cv.keepxy2$cv.list[[1]], type="earth", SHOWCALL=TRUE) source("test.epilog.R") earth/inst/slowtests/test.cv.Rout.save0000644000176200001440000161553414565632543017633 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 > 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) Model with pmethod="backward": GRSq 0.960 RSq 0.974 nterms 4 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 [1] "Girth" "Height" $modvars Girth Height Girth 1 0 Height 0 1 $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 [1] "Girth" "Height" $modvars Girth Height Girth 1 0 Height 0 1 $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 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) Model with pmethod="backward": GRSq 0.960 RSq 0.974 nterms 4 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) Model with pmethod="backward": GRSq 0.949 RSq 0.962 nterms 3 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) Model with pmethod="backward": GRSq 0.960 RSq 0.974 nterms 4 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) Model with pmethod="backward": GRSq 0.420 RSq 0.439 nterms 8 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 [1] "pclass" "sex" "age" "sibsp" "parch" $modvars pclass2nd pclass3rd sexmale age sibsp parch pclass 1 1 0 0 0 0 sex 0 0 1 0 0 0 age 0 0 0 1 0 0 sibsp 0 0 0 0 1 0 parch 0 0 0 0 0 1 $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) Model with pmethod="backward": GRSq 0.420 RSq 0.439 nterms 8 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 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 [1] "survived" "sex" "age" "sibsp" "parch" $modvars survived sexmale age sibsp parch 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 $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)) Model with pmethod="backward": GRSq 0.116 RSq 0.158 nterms 11 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 [1] "survived" "sex" "age" "sibsp" "parch" $modvars survived sexmale age sibsp parch 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 $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) Model with pmethod="none": GRSq 0.254 RSq 0.556 nterms 5 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 [1] "outcome" "treatment" $modvars outcome2 outcome3 treatment2 treatment3 outcome 1 1 0 0 treatment 0 0 1 1 $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) Model with pmethod="none": GRSq 0.303 RSq 0.522 nterms 4 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 [1] "outcome" "treatment" $modvars outcome2 outcome3 treatment2 treatment3 outcome 1 1 0 0 treatment 0 0 1 1 $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 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 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 expected error 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 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 [1] "pclass" "sex" "age" "sibsp" "parch" $modvars pclass2nd pclass3rd sexmale age sibsp parch pclass 1 1 0 0 0 0 sex 0 0 1 0 0 0 age 0 0 0 1 0 0 sibsp 0 0 0 0 1 0 parch 0 0 0 0 0 1 $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 > par(mfrow=c(2,2), mar=c(4, 3.2, 3, 3), mgp=c(1.6, 0.6, 0), 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(org.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 expected error 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 expected error 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.R0000644000176200001440000001436513725313736020030 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.bat0000755000176200001440000000151214563571565017214 0ustar liggesusers@rem test.plotd.bat @rem Stephen Milborrow Mar 2008 Durban @echo test.plotd.bat @"C:\PROGRA~1\R\R-4.3.2\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.save0000644000176200001440000000235513737371134021033 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.bat0000755000176200001440000000165114563571565017040 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-4.3.2\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 -w to treat \n same as \r\n @mks.diff -w test.mods.Rout test.mods.Rout.save @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 @rem @rm -f test.mods.pdf @exit /B 0 earth/inst/slowtests/test.emma.Rout.save0000644000176200001440000001714414563605665020135 0ustar liggesusers> # test.emma.R: regression tests for emma (which uses earth internally) > # Stephen Milborrow, Shrewsbury Nov 2014 > > source("test.prolog.R") > print(R.version.string) [1] "R version 4.1.1 (2021-08-10)" > library(emma) Loading required package: earth Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: clusterSim Loading required package: cluster Loading required package: MASS > print(citation("emma")) To cite package 'emma' in publications use: Laura Villanova, Kate Smith-Miles and Rob J Hyndman. (2011). emma: Evolutionary model-based multiresponse approach. R package version 0.1-0. https://CRAN.R-project.org/package=emma A BibTeX entry for LaTeX users is @Manual{, title = {emma: Evolutionary model-based multiresponse approach}, author = {Laura Villanova and Kate Smith-Miles and Rob J Hyndman.}, year = {2011}, note = {R package version 0.1-0}, url = {https://CRAN.R-project.org/package=emma}, } ATTENTION: This citation information has been auto-generated from the package DESCRIPTION file and may need manual editing, see 'help("citation")'. > > in.name <- c("x1","x2") > nlev <- c(10, 10) > lower <- c(-2.048, -2.048) > upper <- c(2.048, 2.048) > out.name <- "y" > weight <- 1 > C <- 3 > pr.mut <- c(0.1, 0.07, 0.04, rep(0.01, C-3)) > > emma(in.name, nlev, lower, upper, out.name, opt = "mn", nd = 8, na = 5, + weight, C , w1 = 0.7, w2 = 0.4, c1i = 2.5, c1f = 0.5, c2i = 0.5, + c2f = 2.5, b = 5, pr.mut, graph = "yes", fn1 = ackley) [1] "PERFORM THE FOLLOWING EXPERIMENTS ( t = 0 )" x1 x2 28 1.1377778 -1.1377778 87 0.6826667 1.5928889 22 -1.5928889 -1.1377778 88 1.1377778 1.5928889 65 -0.2275556 0.6826667 17 0.6826667 -1.5928889 36 0.2275556 -0.6826667 42 -1.5928889 -0.2275556 [1] "PERFORM THE FOLLOWING EXPERIMENTS ( t = 1 )" x1 x2 18 1.1377778 -1.5928889 96 0.2275556 2.0480000 92 -1.5928889 2.0480000 59 1.5928889 0.2275556 21 -2.0480000 -1.1377778 [1] "PERFORM THE FOLLOWING EXPERIMENTS ( t = 2 )" x1 x2 66 0.2275556 0.6826667 95 -0.2275556 2.0480000 76 0.2275556 1.1377778 44 -0.6826667 -0.2275556 63 -1.1377778 0.6826667 $xpop x1 x2 28 1.1377778 -1.1377778 87 0.6826667 1.5928889 22 -1.5928889 -1.1377778 88 1.1377778 1.5928889 65 -0.2275556 0.6826667 17 0.6826667 -1.5928889 36 0.2275556 -0.6826667 42 -1.5928889 -0.2275556 18 1.1377778 -1.5928889 96 0.2275556 2.0480000 92 -1.5928889 2.0480000 59 1.5928889 0.2275556 21 -2.0480000 -1.1377778 66 0.2275556 0.6826667 95 -0.2275556 2.0480000 76 0.2275556 1.1377778 44 -0.6826667 -0.2275556 63 -1.1377778 0.6826667 $ypop y1 28 4.876776 87 6.528924 22 6.643627 88 6.643627 65 3.779749 17 6.528924 36 3.779749 42 6.081880 18 6.643627 96 6.044857 92 7.798963 59 6.081880 21 6.129994 66 3.779749 95 6.044857 76 4.261612 44 3.779749 63 5.014016 $xspace x1 x2 1 -2.0480000 -2.0480000 2 -1.5928889 -2.0480000 3 -1.1377778 -2.0480000 4 -0.6826667 -2.0480000 5 -0.2275556 -2.0480000 6 0.2275556 -2.0480000 7 0.6826667 -2.0480000 8 1.1377778 -2.0480000 9 1.5928889 -2.0480000 10 2.0480000 -2.0480000 11 -2.0480000 -1.5928889 12 -1.5928889 -1.5928889 13 -1.1377778 -1.5928889 14 -0.6826667 -1.5928889 15 -0.2275556 -1.5928889 16 0.2275556 -1.5928889 17 0.6826667 -1.5928889 18 1.1377778 -1.5928889 19 1.5928889 -1.5928889 20 2.0480000 -1.5928889 21 -2.0480000 -1.1377778 22 -1.5928889 -1.1377778 23 -1.1377778 -1.1377778 24 -0.6826667 -1.1377778 25 -0.2275556 -1.1377778 26 0.2275556 -1.1377778 27 0.6826667 -1.1377778 28 1.1377778 -1.1377778 29 1.5928889 -1.1377778 30 2.0480000 -1.1377778 31 -2.0480000 -0.6826667 32 -1.5928889 -0.6826667 33 -1.1377778 -0.6826667 34 -0.6826667 -0.6826667 35 -0.2275556 -0.6826667 36 0.2275556 -0.6826667 37 0.6826667 -0.6826667 38 1.1377778 -0.6826667 39 1.5928889 -0.6826667 40 2.0480000 -0.6826667 41 -2.0480000 -0.2275556 42 -1.5928889 -0.2275556 43 -1.1377778 -0.2275556 44 -0.6826667 -0.2275556 45 -0.2275556 -0.2275556 46 0.2275556 -0.2275556 47 0.6826667 -0.2275556 48 1.1377778 -0.2275556 49 1.5928889 -0.2275556 50 2.0480000 -0.2275556 51 -2.0480000 0.2275556 52 -1.5928889 0.2275556 53 -1.1377778 0.2275556 54 -0.6826667 0.2275556 55 -0.2275556 0.2275556 56 0.2275556 0.2275556 57 0.6826667 0.2275556 58 1.1377778 0.2275556 59 1.5928889 0.2275556 60 2.0480000 0.2275556 61 -2.0480000 0.6826667 62 -1.5928889 0.6826667 63 -1.1377778 0.6826667 64 -0.6826667 0.6826667 65 -0.2275556 0.6826667 66 0.2275556 0.6826667 67 0.6826667 0.6826667 68 1.1377778 0.6826667 69 1.5928889 0.6826667 70 2.0480000 0.6826667 71 -2.0480000 1.1377778 72 -1.5928889 1.1377778 73 -1.1377778 1.1377778 74 -0.6826667 1.1377778 75 -0.2275556 1.1377778 76 0.2275556 1.1377778 77 0.6826667 1.1377778 78 1.1377778 1.1377778 79 1.5928889 1.1377778 80 2.0480000 1.1377778 81 -2.0480000 1.5928889 82 -1.5928889 1.5928889 83 -1.1377778 1.5928889 84 -0.6826667 1.5928889 85 -0.2275556 1.5928889 86 0.2275556 1.5928889 87 0.6826667 1.5928889 88 1.1377778 1.5928889 89 1.5928889 1.5928889 90 2.0480000 1.5928889 91 -2.0480000 2.0480000 92 -1.5928889 2.0480000 93 -1.1377778 2.0480000 94 -0.6826667 2.0480000 95 -0.2275556 2.0480000 96 0.2275556 2.0480000 97 0.6826667 2.0480000 98 1.1377778 2.0480000 99 1.5928889 2.0480000 100 2.0480000 2.0480000 $yspace y 1 5.580142 2 5.580142 3 5.580142 4 5.580142 5 5.580142 6 5.580142 7 5.580142 8 5.580142 9 5.580142 10 5.580142 11 5.580142 12 5.580142 13 5.580142 14 5.580142 15 5.580142 16 5.580142 17 6.528924 18 6.643627 19 5.580142 20 5.580142 21 6.129994 22 6.643627 23 5.580142 24 5.580142 25 5.580142 26 5.580142 27 5.580142 28 4.876776 29 5.580142 30 5.580142 31 5.580142 32 5.580142 33 5.580142 34 5.580142 35 5.580142 36 3.779749 37 5.580142 38 5.580142 39 5.580142 40 5.580142 41 5.580142 42 6.081880 43 5.580142 44 3.779749 45 5.580142 46 5.580142 47 5.580142 48 5.580142 49 5.580142 50 5.580142 51 5.580142 52 5.580142 53 5.580142 54 5.580142 55 5.580142 56 5.580142 57 5.580142 58 5.580142 59 6.081880 60 5.580142 61 5.580142 62 5.580142 63 5.014016 64 5.580142 65 3.779749 66 3.779749 67 5.580142 68 5.580142 69 5.580142 70 5.580142 71 5.580142 72 5.580142 73 5.580142 74 5.580142 75 5.580142 76 4.261612 77 5.580142 78 5.580142 79 5.580142 80 5.580142 81 5.580142 82 5.580142 83 5.580142 84 5.580142 85 5.580142 86 5.580142 87 6.528924 88 6.643627 89 5.580142 90 5.580142 91 5.580142 92 7.798963 93 5.580142 94 5.580142 95 6.044857 96 6.044857 97 5.580142 98 5.580142 99 5.580142 100 5.580142 $opt [1] "mn" $nd [1] 8 $na [1] 5 $tested [1] 28 87 22 88 65 17 36 42 18 96 92 59 21 66 95 76 44 63 $time [1] 2 $weight [1] 1 $Gb 65 65 $Pb [1] 28 96 65 36 42 $Gb.arch 65 65 65 $Pb.arch [1] 28 87 65 36 42 28 96 65 36 42 $v x1 x2 28 -0.8597044 2.2016894 87 -0.4895059 0.2665904 65 1.7812152 -1.3195367 36 -2.0677833 -0.3277724 42 0.9917643 1.7606130 $sam.x [1] 66 95 76 44 63 $add [1] 0 attr(,"class") [1] "emma" > > source("test.epilog.R") earth/inst/slowtests/test.earthmain.clang.bat0000755000176200001440000000623714364453406021126 0ustar liggesusers@rem test.earthmain.clang.bat: test the standalone earth.c with main() @rem @rem The gcc, Microsoft, and clang compiler batch files all test @rem against the same reference file "test.earthmain.out.save" @rem @rem Stephen Milborrow Dec 2014 Shrewsbury. Updated Petaluma May 2020. @echo test.earthmain.clang.bat @rem The following is a basic check that you have Visual Studio 2019 for 32 bit targets @mks.which cl | egrep -i "Visual.Studio.2019.Community.VC.Tools.MSVC.*.bin.Hostx.*x86.cl" >NUL && goto donesetpath @echo Environment is not VC16 (Visual Studio 2019) 32 bit -- please invoke vc16-32.bat @exit /B 1 :donesetpath @mks.cp "D:\bin\milbo\R400devdll\i386\R.dll" . @if %errorlevel% neq 0 goto err @mks.cp "D:\bin\milbo\R400devdll\i386\Rblas.dll" . @if %errorlevel% neq 0 goto err @mks.cp "D:\bin\milbo\R400devdll\i386\Riconv.dll" . @if %errorlevel% neq 0 goto err @mks.cp "D:\bin\milbo\R400devdll\i386\Rgraphapp.dll" . @if %errorlevel% neq 0 goto err @rem you may have to create R.lib and Rblas.lib beforehand @mks.cp "D:\bin\milbo\R400devdll\i386\R.lib" . @if %errorlevel% neq 0 goto err @mks.cp "D:\bin\milbo\R400devdll\i386\Rblas.lib" . @if %errorlevel% neq 0 goto err set CLANGEXE="C:\Program Files (x86)\Microsoft Visual Studio/2019/BuildTools/VC/Tools/Llvm/bin/clang.exe" @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. @rem -Wno-extra-semi-stmt prevents "remove unnecessary ';'" in "free1();" @rem -Wno-tautological-value-range-compare prevents "comparison 1-bit unsigned value" in "nMaxDegree > 1" @rem Jan 2023: Tested with clang version 12.0.0 %CLANGEXE% --version %CLANGEXE% -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-deprecated-declarations -Wno-implicit-function-declaration^ -Wno-missing-noreturn^ -Wno-extra-semi-stmt -Wno-tautological-value-range-compare^ -I"/a/r/ra/include" -I../../inst/slowtests ../../src/earth.c^ R.lib Rblas.lib -o earthmain-clang.exe @if %errorlevel% neq 0 goto err @rem $$ TODO crashes (because wrong stdio.h is used in earth.c?) @rem earthmain-clang.exe > test.earthmain-clang.out @rem @rem no errorlevel test, diff will do check for discrepancies @rem @rem @if %errorlevel% neq 0 goto err @rem mks.diff test.earthmain-clang.out test.earthmain.out.save @rem @if %errorlevel% neq 0 goto err @rm -f R.dll Rblas.dll Riconv.dll Riconv.dll Rgraphapp.dll R.lib Rblas.lib earthmain-clang.* test.earthmain-clang.* *.o @exit /B 0 :err @exit /B %errorlevel% earth/inst/slowtests/test.earthc.clang.bat0000755000176200001440000000576414362005536020423 0ustar liggesusers@rem test.earthc.clang.bat: test the standalone earth.c with main() @rem @rem This tests the earth C code. It does this: builds test.earthc.exe @rem (under clang), runs it, and compares results to test.earthc.out.save. @rem @rem You will need to tweak this file and test.earthc.gcc.mak for your directories. @rem @rem You need to make R.lib first -- see instructions in gnuwin32/README.packages. @echo test.earthc.clang.bat @mks.cp "D:\bin\milbo\R400devdll\i386\R.dll" . @if %errorlevel% neq 0 goto err @mks.cp "D:\bin\milbo\R400devdll\i386\Rblas.dll" . @if %errorlevel% neq 0 goto err @mks.cp "D:\bin\milbo\R400devdll\i386\Riconv.dll" . @if %errorlevel% neq 0 goto err @mks.cp "D:\bin\milbo\R400devdll\i386\Rgraphapp.dll" . @if %errorlevel% neq 0 goto err @rem you may have to create R.lib and Rblas.lib beforehand @mks.cp "D:\bin\milbo\R400devdll\i386\R.lib" . @if %errorlevel% neq 0 goto err @mks.cp "D:\bin\milbo\R400devdll\i386\Rblas.lib" . @if %errorlevel% neq 0 goto err set CLANGEXE="C:\Program Files (x86)\Microsoft Visual Studio/2019/BuildTools/VC/Tools/Llvm/bin/clang.exe" @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. @rem -Wno-extra-semi-stmt prevents "remove unnecessary ';'" in "free1();" @rem -Wno-tautological-value-range-compare prevents "comparison 1-bit unsigned value" in "nMaxDegree > 1" @rem Jan 2023: Tested with clang version 12.0.0 %CLANGEXE% --version %CLANGEXE% -DSTANDALONE -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-deprecated-declarations -Wno-implicit-function-declaration^ -Wno-missing-noreturn -Wno-missing-prototypes -Wno-unused-parameter^ -Wno-extra-semi-stmt -Wno-tautological-value-range-compare^ -I"/a/r/ra/include" -I../../inst/slowtests ../../src/earth.c test.earthc.c^ R.lib Rblas.lib -o earthc-clang.exe @if %errorlevel% neq 0 goto err @rem $$ TODO crashes (because wrong stdio.h is used in earth.c?) @rem earthc-clang.exe > test.earthc-clang.out @rem @rem no errorlevel test, diff will do check for discrepancies @rem @rem @if %errorlevel% neq 0 goto err @rem mks.diff test.earthc-clang.out test.earthc.out.save @rem @if %errorlevel% neq 0 goto err @rm -f R.dll Rblas.dll Riconv.dll Riconv.dll Rgraphapp.dll R.lib Rblas.lib earthc-clang.* test.earthc-clang.* *.o @exit /B 0 :err @exit /B %errorlevel% earth/inst/slowtests/test.multresp.R0000644000176200001440000005162413727246550017400 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") options(warn=1) # print warnings as they occur 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(org.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 } 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 VolNeg.randx <- earth(VolNeg~randx, trace=1) # intercept only model plotmo(VolNeg.randx) 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(org.par) plot(VolVolNega.nokeepxy) # Warning: Defaulting to nresponse=1, see above messages # 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(org.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(org.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(org.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(org.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(org.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(org.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))) # TODO Sep 2020: work around for model.matrix.Formula which incorrectly includes log(03) on lhs expect.err(try(earth(log(O3 + wind) + ibt ~ temp, data=ozone1, trace=1)), "terms like 'log(O3 + wind)' are not allowed on the LHS of a multiple-response formula") 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) options(warn=2) expect.err(try(show.earth.formula(Volume~Volume)), "(converted from warning) the response appeared on the right-hand side and was dropped") options(warn=1) # print warnings as they occur 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 VolNeg.SinVol.randx <- earth(VolNeg+SinVol~randx, trace=1) # intercept only model plotmo(VolNeg.SinVol.randx, nresponse=2) # 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) # TODO Sep 2020: work around for model.matrix.Formula which incorrectly includes log(03)+wind on lhs expect.err(try(earth(log(O3) + wind ~ ., data=ozone1, trace=1)), "terms like 'log(O3)' are not allowed on the LHS of a multiple-response formula") 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") options(warn=1) 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))) # TODO Sep 2020: work around for model.matrix.Formula which incorrectly includes log(03) on lhs expect.err(try(earth(log(O3)+wind ~ humidity+temp, data=ozone1)), "terms like 'log(O3)' are not allowed on the LHS of a multiple-response formula") # 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)) 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") options(warn=2) 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") options(warn=1) age.pclass <- earth(age+pclass~sibsp, data=etitanic) par(mfrow=c(2,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") options(warn=2) 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") options(warn=1) pclass.sex <- earth(pclass+sex~sibsp, data=etitanic) par(mfrow=c(2,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") options(warn=2) 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") options(warn=1) # try to delete a varname (expose bug in model.matrix.Formula) options(warn=2) expect.err(try(earth(pclass+sex~.-survived, data=etitanic)), "'varlist' has changed (from nvar=4) to new 5 after EncodeVars() -- should no longer happen!") options(warn=1) expect.err(try(earth(pclass+sex~.-survived, data=etitanic)), "model frame and formula mismatch in model.matrix()") # try to delete a varname not in data (expose bug in model.matrix.Formula) options(warn=2) expect.err(try(earth(pclass+sex~.-nonesuch, data=etitanic)), "'varlist' has changed (from nvar=5) to new 6 after EncodeVars() -- should no longer happen!") options(warn=1) expect.err(try(earth(pclass+sex~.-nonesuch, data=etitanic)), "model frame and formula mismatch in model.matrix()") source("test.epilog.R") earth/inst/slowtests/test.plotd.R0000644000176200001440000003705713727246550016653 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) # 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(org.par) source("test.epilog.R") earth/inst/slowtests/test.offset.bat0000755000176200001440000000152714563571565017366 0ustar liggesusers@rem test.offset.bat @rem Stephen Milborrow Dec 2018 Midtown @echo test.offset.bat @"C:\PROGRA~1\R\R-4.3.2\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.earthmain.msc.bat0000755000176200001440000000537614563573372020635 0ustar liggesusers@rem test.earthmain.bat: test the standalone earth.c with main() @rem @rem The gcc, Microsoft, and clang compiler batch files all test @rem against the same reference file "test.earthmain.out.save" @rem @rem Stephen Milborrow Apr 2007 Petaluma @echo test.earthmain.msc.bat @set CYGWIN=nodosfilewarning @rem The following is a basic check that you have Visual Studio 2019 for 32 bit targets @mks.which cl | egrep -i "Visual.Studio.2019.Community.VC.Tools.MSVC.*.bin.Hostx.*x86.cl" >NUL && goto donesetpath @echo Environment is not VC16 (Visual Studio 2019) 32 bit -- please invoke vc16-32.bat @exit /B 1 :donesetpath @mks.cp "D:\bin\milbo\R400devdll\i386\R.dll" . @if %errorlevel% neq 0 goto err @mks.cp "D:\bin\milbo\R400devdll\i386\Rblas.dll" . @if %errorlevel% neq 0 goto err @mks.cp "D:\bin\milbo\R400devdll\i386\Riconv.dll" . @if %errorlevel% neq 0 goto err @mks.cp "D:\bin\milbo\R400devdll\i386\Rgraphapp.dll" . @if %errorlevel% neq 0 goto err @rem you may have to create R.lib and Rblas.lib beforehand @mks.cp "D:\bin\milbo\R400devdll\i386\R.lib" . @if %errorlevel% neq 0 goto err @mks.cp "D:\bin\milbo\R400devdll\i386\Rblas.lib" . @if %errorlevel% neq 0 goto err @md Debug @rem Note: Use Microsoft VC16 (Visual Studio 2019) 32 bit. @rem (Other versions haven't been tested and may cause spurious errors.) @rem @rem To set up the environment for the call to "cl" and "link" below, invoke: @rem C:\Program Files (x86)\Microsoft Visual Studio\2019\Community\VC\Auxiliary\Build\vcvars32.bat @rem @rem We use -W4 below (insteadof -W3) for lint-like warnings cl -nologo -DSTANDALONE -DMAIN -TP -Zi -W3 -MDd -I"%ProgramFiles%\R\R-4.3.2"\src\include -I. -FpDebug\vc60.PCH -Fo"Debug/" -c ..\..\src\earth.c @if %errorlevel% neq 0 goto err @rem linker needs to be called explicitly, else we may call the wrong link program (e.g. /rtools43/usr/bin/link) "C:\Program Files (x86)\Microsoft Visual Studio\2019\Community\VC\Tools\MSVC\14.29.30133\bin\HostX64\x86\link.exe" -nologo -debug -out:earthmain.exe Debug\earth.obj R.lib Rblas.lib @if %errorlevel% neq 0 goto err earthmain.exe > Debug\test.earthmain.out @rem no errorlevel test, diff will do check for discrepancies @rem @if %errorlevel% neq 0 goto err mks.diff Debug\test.earthmain.out test.earthmain.out.save @if %errorlevel% neq 0 goto err @rm -f R.dll Rblas.dll R.lib Rblas.lib iconv.dll Riconv.dll Rgraphapp.dll earthmain.exe *.map *.ilk *.pdb @rm -rf Debug @exit /B 0 :err @exit /B %errorlevel% earth/inst/slowtests/test.full.bat0000755000176200001440000000151214563571565017034 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-4.3.2\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.R0000644000176200001440000000573213725313736016264 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.bat0000755000176200001440000000156014563571565017750 0ustar liggesusers@rem test.multresp.bat @rem Stephen Milborrow Mar 2019 Petaluma @echo test.multresp.bat @"C:\PROGRA~1\R\R-4.3.2\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.save0000644000176200001440000002043314563615110021416 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 > options(warn=1) # print warnings as they occur > > 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) > > library(mgcv) Loading required package: nlme This is mgcv 1.9-1. 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.262806 35.55662 6.756209 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.065629 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.114228 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.379648 35.46832 20 28.766764 21.640708 35.89282 21 30.080913 22.641556 37.52027 22 31.395063 23.642403 39.14772 23 33.366287 25.143675 41.58890 24 43.222408 32.650035 53.79478 25 45.193632 34.151307 56.23596 26 51.764379 39.155546 64.37321 27 53.078529 40.156394 66.00066 28 55.706828 42.158090 69.25557 29 56.363903 42.658514 70.06929 30 56.363903 42.658514 70.06929 31 73.447846 55.669537 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(org.par) > > source("test.epilog.R") earth/inst/slowtests/test.earthc.msc.mak0000644000176200001440000000630314563571565020123 0ustar liggesusers# test.earthc.msc.mak: makefile for test.earthc.main.exe with Microsoft VC16 (Visual Studio 2019) 32 bit. # This builds the executable, runs it, then diffs the results against the reference. # # To set up the environment before calling this batch file, run # "C:\Program Files (x86)\Microsoft Visual Studio\2019\Community\VC\Auxiliary\Build\vcvars32.bat" all: test.earthc.out # LINK needs to be explicitly set, else we may call the wrong link program (e.g. /rtools/usr/bin/link) LINK = "C:\Program Files (x86)\Microsoft Visual Studio\2019\Community\VC\Tools\MSVC\14.29.30133\bin\HostX64\x86\link.exe" R_DIR="%ProgramFiles%\r\R-4.3.2" 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 R.lib, see for example https://www.asawicki.info/news_1420_generating_lib_file_for_dll_library # See also D:\bin\ddl2lib.bat LIBS=R.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 R.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 R.libs see instructions in gnuwin32\README.packages LIBS=R.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 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.msc.mak cl $(CFLAGS) ..\..\src\earth.c $(OUTDIR)/test.earthc.obj: test.earthc.c ..\..\src\earth.c test.earthc.msc.mak earth/inst/doc/0000755000176200001440000000000014334575364013115 5ustar liggesusersearth/inst/doc/earth-varmod.pdf0000644000176200001440000104122714055550570016200 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4898 /Filter /FlateDecode /N 94 /First 795 >> stream x\[sܶ~_SBrT,r[-T%x4̌l'~Ff$6Fw!JfWyVL`F;&&%c(PRm S:K˔r ="G9g`Fj48GwV@t !2ZHcs@{Ϝ7>g./SyxZ21)@Nk2mX]aHk& 5ޡ)F%r D=`0Fk (hd)K`A- k/P:_ hYf*<(l 0MDdcd〡d#0  [Aobd1Ȗx20@O gOxQ]X ^_}OybNdv\I9]jbu6GjZ^"j"* MB=ҳD7o:HZ=IN:Ot5h}K՝ս]]V*S*rgb"$ar@ߘ?hYʉ sEfW)5<9 ̟AEA#Ȭ$>s@c=#Fqd&HW *LK EbiEhB"ql+nZeͭ L_Ķf5ʻP+S w8V.tmae3hYYA+rxo&&.ZZ' UjJb6˪ݠmukktu;7mDEJHi)Vq?Bf@4^<#J~@$yoli`\H ! !!.zd/3Z\uMo'e:Ϟ?ף#`Ο̎'wlYm^WdAK@6j "' 'IhduʱysdЛrDxy\QŤ*jG[amB-%|bmT;llg-6I4q_bhԚ\&l:0 W vklo-vc4]?zN<ɂ!Ǵ1ڨ;1V;;788zw꾗Ɔ #5/1.koӬ=6wO{C0B< v„dv'㪊|^UӓGͧڰmcgP.?M57׏5]1HX#Mg[C4>pۄkT} n}G?Eu_ ͫЮ®LVo6~$OUE}2uBt O*t'] ie_7z ˦1-}0^}6_sȆ٦kAgm7bZˀN=E|rSȮ4v::YXol_޽|z2ւFXW˭8mKWu4+-bPV满~EN2@t#;~ִq߶;H,(4RI^<maz\ÉZnad-\>[S1~ͅ! NyaMMmH eRC&uz.(:>璥E~dT݆uӳgN];r|)%3EtBЂPd MD@kTl"eWЧ"SdZYJy&r efm*Srhi׹)4eR)qͧԔhRurfJyM2*%̨1~NOpR"rg6aGoh]o]_2=JLw6e˟56see|nbP~ļ^9JtT헤̓u5.(L]^EFPFQkxGC}fZ 4q> Ŷi=.Zo]-juFG^}y-ok7M?^lu3[yk ,d3KƠbC45NS[=zQ: ˾.L\.vKO& )Fă|@ 62 ݘqbu[objDcUUk۷kXqZJoÞqJdNFosȬs(94.27pjx*AݝR^5RnH>Lc sl3ECaF#}0} fKyi3:h 9gaSv[xT 9:=xTK99+l%H:̈́Å-^'Ur"ƅ3O:i!hY!ZQ>yH%TP0A:k԰&z '/XwJqxxb'R\tٌN ~/ paٟ> D!K!kZv+9Tb?VbA3 ø+3c. ,՜R |y_d:\v,F|ｧ/P->1jEow\oYP?d#ZVr10*i1>-&'1E5,faᶸ"Pa\zoj(]` 4n]48cp04S%,(O،w/d4a6˔QLK\"D 1x>ڨ4b[}gRNG+Aδ:ӊ$QT5Dk$Tb]$6;+'-) '$!0 qEYabftH* +)`yC((>ҎQ ~,7cmROyNM[D[Y8I9ܡO`u[L68'E{+w]0A_pѭ ˂]W /3,ަ-KsXF +[86Z#&Рw@(c&k k5i(ggl~Ztnw'`X¾ Č~%YS?8!AH:w1vi hHGHcm@hFMf4,]O8cj7#msV5SRVYw)=W!-uڲ˸b8TJ9endstream endobj 96 0 obj << /Subtype /XML /Type /Metadata /Length 1622 >> stream GPL Ghostscript 9.19 2021-06-01T16:31:49-07:00 2021-06-01T16:31:49-07:00 LaTeX with hyperref package Variance models in earthStephen MilborrowVariance models in earth endstream endobj 97 0 obj << /Type /ObjStm /Length 2700 /Filter /FlateDecode /N 92 /First 834 >> stream xZ]}c  ;M'pyPw[ZkHrjH;apf.=gj5^ ;o&ւ)59NA6s}/Oxo A00jBA4d' *ʠ)qW#X#͈fԨ+x*DA-ФIx6hƗ}FK@N8&6V`]5Qu1FlGJ61 b h50l 9c6H IBb@i4S\Mʎ |irKx(7ٷ`rh3@ $Sž\Ha,&6SMqXɛL4)M)d#R6շbx>UMUd`/ٛ X \,#H$"|!cR L*+ |:`o!k>Ar(d ! 2ӷߚr0.o;toՙsm9MO/uCVMB2 xb7XÿW}?5ݏL+l `lB,MP?1UP"[}TZ ,Jj=*Uu(Æ/BÓ 8[a4NLTމ}reXOP BOL  *eL:`:?*Dh:y6tl3"Xefmەd^W9V_O/g'$ Ɔ];.?,.Ko=j6<ëo^,/^Nw@ /}hCɛ`}39K/[:`yK=wDJS3rs}&8#n쯩cIܑv=[|E ` }|\) 7+cT3㶰as>| WV@*֡! N Xl ȁn._{\eg o3sǻoΞ#//g7e6<_n'€ېb~uhFIy-I/[2O*|h}}:ն(diBޝMm:{v?A&u7.nͺ]7﮻EK_{{YR]<و3{6"er+&烈rjvxjr v7 amoݯQsNkhHKȂ9i3f$۸5C(dK zz^| _{u ?'nH*wUnFf]P$8j찋(j;d ~A/[Oh>@6D4H\:0ނU ;^ V2`; TcC'fbK+N~ԼŧLNJHfa",0ݚ, MFIm˶vLFq]^:pꤐZ˺~I:(p+ܲ+c NZQNVd {'TW-^R``. {CX>(H‡'maOwe}QK{^L90D#\->̓]J5ۑ\B;v5ͳrwdZ7M o"S{轥sy12ΑfF#@=,Z [Hj% Vr*s˷< #P`Bo-'B~88ӰBj:jȶj^Xm6{X_1kƛ1 p:^ w A ,+qGq `NijbVp۬#srh}чmm/*,/ ԆIǦsk…C=* x\b9 =Q>Uy%ZzCĄG.|G]ɩxk5EM`tM*̗Ւu#Tq]Hf FC"pt!a U]cc $HY*Pxd$OS)y x-BtDv)lhDjelg'Ri6JE}ZKV  }O%7 J"D4[Uw&=^p~gu oyjEy@[4ŠB=8vЀSQV&DJf9 $fFbYщm"b78ÈMwϯ?z"\wpӟz`{.?tߴbƛ [>v.4іb3]r{owlȬlNwnYJv;ۆp=c}yM)bgx4SNɱ_:qWwnn,\CEAf I:tfީh D3*̈  }rS?B"60SnyV~H~> stream x[[o}. Pȏb bSv4[&z9H=R:F `8M~ %U3R-xkSj3೬S)1ׅKI;|b$&g L@?rN4{U6>:rN5{yq&?1g~MP 5!$PK2p8/٨T/h(X^*ǝ3b4Eh!ȁ(O&j;A61FN5pLr A)I5$!H/e.2JWd =%cArLNDA:`a$gW0БMWpjJȁ7%zĔR<losTI| "`)61FWpH$cx|]+$Aʜ wH)s%OIsdL8>W*G>L^-B H 4$c=$qeLe{@0*lż=@YQăbL]]]@'3yټ-Wxx;3 T`f(Nlh-bdؒy~33aLOy@RmU!gԚ T(`hbiaz,m_ 6xbL-O &,lK9yy6f@+ *'ftt T2&$z`xl}`*^ ?U{Yrcޘz3tOힱ{ۓZf 5&fgWS'HAR^cY-n/fKCLj5&ŷW3`KkyE<x+=AÚhVTAl,Pzл *E0Gܗ `Q1N`CZ!޺:P+v䯴?O_GɣIe t;qmv;t'{8 :2mNP;AgbgŢAF^1ZCϫ汐;HQHۃ4.CIA|YgKX4/sJh 6_DBemH";*'(JŞ=ʐ) @ H|[xP_Hy[s,"$1e[xƯE)f WfIg:0Dҥ *KjdC䢷%oP%UJEO4#Y:4]Κٛn}qqnxjk>^^㵹x\]]Dvvsn+כ[}`RZyk,/g>y>+efmVM4K'mg!L_rFS`^/._θr B4&:l5_liC}'ypX_نz-̧3ŋАOW )nR-XIe%5$ Ʈ߶`u+M{^"Jk]K$'͇GO#&=-sMU"B ( t@2@q0gK @)36L55ؽ]?体텱ԛSU;A2ث,k34Eg:p H|D\]7x ]eI&@.@lnW=W kFl“BdMFuIP) 9dk*X~=b. Y=X J7Y8Sr]`OGjVf I!/#}JȑF~Q7UeoQv P ǖL#pBo-$\|#׭xXjܲd&"c) ta ozڲs3 b7VL>}dS곝^؛_'o~zz~߶l5]R^bh"R SƲЈY{ި ,װo0. dA%  Tn0-(9[[iɩ*_N նK clu7 nY ;qh|bi{>U['PT roCٶW6y3_<],z`1Xwqi;%\endstream endobj 285 0 obj << /Filter /FlateDecode /Length 10753 >> 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 286 0 obj << /Filter /FlateDecode /Length 2905 >> stream x\KoF s+nW{/A!C6{5,@35ί*vK# '3ME[볿lj{&WgΠzH?.׋/ZHQZ+Y t 'Tb}KJ)^,ϱR⎮EҀ.ك AUl:0JtBP6JRP6\Z+U=2Z l+)n[SR^|O5F*5 ]^t49*sЌ4/ՒZG8C59 >@xڒB⇶ K/$XI׷KLv 7t.]=BZ4dž-U\Yota#UHv[k~uM p8Q^RՠL|Saffh}2W%pIM !F0*8,*݄J H;ޔBX-U"!]<(iDpBVJ6Abu=[5כ%[clP5$*:[cKel[:̉ler[WJ AecqQ[AY Ӛu}MUZ~ AOE2/ƅbttt8\|I4&S Oۢ$"<ʗ-kv_?vKv#2ZRuiAgCT(r0ŇCcid,6Z! B0mȵ}y[>ƊMwW%|څGH#YÎh4Y(f~(ꞻp%4(Ad qaDID!G\qdMCOv<5 Rd"Ꮓ]w}]_m$N_KV6SN_X#s"1# #U-p`KV<ٶ5ET2mLW|rTroShlUܚq.kv=26]/&x(=LGXC2X3^݂;Jz3ݿ ?ܥp.`f}ۡ-z#;yzYVQ2~UTW\NfMt4RUwlOm><6e~)„"PӺ4A1t2Hk"vQ89Ӱ0pytysA`c`Bd_ {!I0l)F?ZUE9 lg8:V0 DBF&o, gn L%@o ysaoU]\[ʩ " w bT[r?%:HR#0Rrlϫ,IL4laZxN5 J?&*yxf(%'*sSgaH'gjcQGmpmkx6|?HiwIQR)5 }#-pHLIAk3Y;-Mxfj8B9o&qK;uzٛHm7;sbP9=a5/̚*#Z}M 6b٤u2U3AbU3&Cx22r)^kE9|s!Nr,-ڿi`13,j lrQ,e:*&ELT95d DZ`6 絉f&*F \H>W-:lJOR(xN;(ɦ.w*V)@Dv1B^P60)8ϊ1ԓꬺ̬y5D, ĘoP%%qJh׳ z+nydu:6T/snNXnn5 r_M$Y7>ӧf &߇Z BB=8'iO/`ԌM7&y<* l8Wl\w|{2x}󶭻 *}xqhbz81/+],{N; qL;d2?9t:4Uuy@^{Ƚ{*{*Eޤ.JmVS%DZ䲙ަHrΰZ*E{YcqE[k#J7E9:) *dX1pZӪA 2N1cbҕعp@1 zZI$O 5V*u\iR 72~6y}ڌ3Qsiix.L3 I%f7]9yJ} tfuߣhp.wnW`܊{rIG}b#D3eҸQ98ږZ l.;2ubЁ#9 g@ov3;K_>>h(%4g>F}d:RA%}:?O|)5ݎ `CojߋÚ8Y@̸*b|=-5kz 5vq%sY Tgh(erDLq`[T{UyUPOSWmv:XĊN>\٦`XOI#ܣj7AT0mV+{syEN]Ve2o0x::SҐ~8J)Y'-d\%}dhJ02gMS-_tǮzW~jwiR*iYz\zBZJv_חT|TLe<30r F`>nZ'N=Y>ɪwJckat8^b=&?r1l/xC5e?jendstream endobj 287 0 obj << /Filter /FlateDecode /Length 6134 >> 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 290 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 291 0 obj << /Filter /FlateDecode /Length 4916 >> stream x\Ko$qր/Ʋ)a 0 %ÎpI.21wDdfUjGdd~gmg?Įb4 6Έ9۟ٝt TY9 췟wNy2lمޞ AY͓ͧݩr ld8e1*ȞK<+ovqI&R۟Y{!N삍ܰ׬Gly $aStJ!vOGN&'n' .SRv\KAW'a/l+w|NfwX&Ejl8|8zZ1|wI"½I>ϙ(#mj> e?} Ciϵ@W`XKL݃)P!P> nZQ hFܙ}-8)QD١Mx.F.Wsf  ۨJNVfRޫ7=1Lqw<[4,~ͯU`@y8J̓.)48fig+l&sIީHbE9 BFJNQd9h#ǥ?Q.CY|!Ya`, elnVY|-)8O+nse~.KNv ?9sb'|*:RI Mm'xpfys{+ 9y2*wVe=M"HgjfdO;A 4O-t}*VcKYr}ýgm oL*hf%e a$ Rﺌ'djb2V 8jcaIגܬb,l&1_Xl Pc[MKi#0J\0v$1%2p? ;8lRWZ ,;SD,v8Fo ܗ8+`/BN" aDmh^`a*!p\1 ` "uCnTDbpR/g{ ߴWЫi8|5'N11~ҹ8Os&=_A(و7O3%٥:ۥdis!#@ΡϓI=^A`!lko-rEdm_6#P!@SxY@MP3{>=I l W@=Ė= Ѡ;/Ȁ!%҅6P.,Kn, /E,Dܭc^xsy]HlUcںNۉEАJwS ,mY䖆]G }oYBL'qj]+&Tn6Y6")gFVn0R]^Fp-x:F0$xސ K|MM~slM%d1W$(כₓA$`ApF!M澕`ׂRK J3=[)WMފ;Q2$L.40X@EOvvIChk$|}sU(:;AV95b)|iaFbHD`6\^.Fk/Hγ+ŸoLN?d>Rtt}LRU ɼth\4t=whr3|aokp5r ֨^6NagׂŌ" %'AsXz#l;e~/t]n%Kֳ((Lv>f)Hg#jsfًn!&6 ԜAu6bwMI65aaQjHjF13K:.8@ ~0G0x)JVlu k6O-;\^3L* F:\|wս%W`] 4P}t~ t 6Ygov zƂ8G%T0 ^[ɍvxbMdsML$)̪q*WY: Tzrdu Ӄ{~vD)&  &ֈ S ee@RIQh}Lw}\EBeCM~b1=})yn9^GVnt`({A+J7se~FJR^q&zÒKA.l! MRJqȫWdF#&};נ˕n%Pb1ߣ,X[VUI ﷥7xWrƍ3H[$MZɱ, G_Y2uԆ%ڜs 4AŢUU315=o`IHvHUw!F\(ٱ?w(^R &W9l)MZrۘXl^U&*@FuEaxR UEaJzej.-n$eB(627˄1'cBQ>@H%n8oT J3UamplKr2RvI7QpkSlg1ʲ5\c6-<N[p >0)umG#C<s_s9P% ci&PAr>J8I߿MlY cʡvpXxEҪM(H-|n~#zST ] lhvKdqS3m,h18rqUR9yn=K@X2UmTe/rbt"R@}PE׀T~b:aa+g>}>‹dc>=Wv D7Ɓt aot HK=F钺R`u78I*P!wl-ܑ谁6N519*BJSD .MJ' MR_"7Voq;2N?&Uԓ맸.U7$zxAo<=ܠ`"qir@c}hs<>bN#bJZH҈L#DbٵRbmm(.<.;* ZPK k\!:{u]|Ū } cQMjYN- 3hL1.|*YjwlyJZZlGI>CijVʌp`X^d4 9. jcbS%($ JuҘJ'ڬ;s~u#{JjL> 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 294 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 296 0 obj << /Filter /FlateDecode /Length 277 >> stream x]1n0 EwB7dR\%Cd g&-1J^^C.oGo2{(3>JXCa3j cJ`Y'tN0H' vDY=a@u# "Bje='DZIH 30:q7, hН^ )-盽c' p\g7ٔld[fY ̋endstream endobj 297 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 298 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 299 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 300 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 301 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 302 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 303 0 obj << /Filter /FlateDecode /Length 160 >> stream x]O10 @E'B2D! }I:g9\/W#8|QcYZ`ɲYy!' d ԖU]B4-^!Θ^?ifwhZ,CIT @s$Lg)nSendstream endobj 304 0 obj << /Filter /FlateDecode /Length 4051 >> 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 305 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 306 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 307 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4549 >> stream xXyXSgֿ!{]@!Ak2֊(Z֥Ze_1$9I$l $\qkZ-:֪nόj /oހ|3?; (@ |$oo#+NBuw `罯zoQ~(%⒲'(e[#B{M=y$?p8pi^5\73J.Ox'K&"gU:<)\-<{a|{E4ܻ/}?KppYEQ'$ʒ%ےCS#"Y+0nߜ87mi~5ZI}@VSk:j=Cm6Rԇ{Dj3ZH-SKTjZA͠PrfSnʝ򠴔b?Q#7I)gJ/!pT,t {7;7rWajZ:ko]7t2rȶ!]C-zgobw_GMah^֝v/4v򣻗eڢTH:7S14mk -`FݱM2ͨ/$pM}A y^5-Ka]^ E&[.X!rOwPXC,&5Fb폽X$h/7[ .c[+W<_{JQ*XZ|Rq·7^,[h-!Y4l3}c?GHD @saA8-j>bd UN 1^oG,W .~ً4Hr:P"^{' 6k0Iv 4GEbY"~8 fQp80WM.u t3衚dT<#kr[&? :|a}FwFbfvbH1X!FHHI̼]Sד|g.AwXDc }m#zG`Ƒ6z"A*2itəě,؆ N|mD.N"T/UMVQʏGah=k&3BgM<}g;)&rI@@ 0TV >3Ї?IRItcXqp13#mwSog0ePP%"U238Mގ긅 QHEt 4B,waĝ?"8mmIU+gQ U7}Qq-p[q5@ve\uIP|ۼ붐Bl;\_K [ 6u)DNv费o`'"K^6t Uk%ڔu+ ]K VoxNىco:NjEN}E"뚥-zv[ E&b\jzaԥC?bh2q,d[8cxbq phAfgLhU) lI5Z gNA3tL)$O%hͳxˑuQigT{ m,jY`~!![c4zS"n$ېUgk16Ay(\g kGSo[{B4"уݐSf'5쮮mhZ/Gq{_*i>8>sAGhgU!Nk􍻭Қ܃]LL)%efXȇvM0?tu]kMmHZT(QUA&RY^RUTS 悛 `&.\8;n&HSFC# ,ܞ2%&B"74כӏoׯdȃ Gcp'k=h|"aں6>, Ubt\Π_g3\.-Wv ~-/5Oj _ZW&ceXEBb%^o57:ZaT-zpd0aץS箣w,xF@!W >epQ ! O5 SK)=9Ēhf4zܻU4t-lм0_[W`*@o46oy!' &%3+*~l/m дMPI^5 #[!}4+j7>ghx(=vu0Tî|WvG E!Zн}Y*^4I`+a֗PA} З~o)+Tg?{JQ7$ {F߰9Us]u4kjMV}zCC-$iE,"1 !Ϝ3FZxbI\RݑG ZM@yhr/s6#SgT]pS&22a׏Y<` E?Fdd E.+ѐi CրJ)y448=<{dd0’@Oȩ 6=ظg~_3~oi {[Z`)!cYeHpF'/GV|Nx r==-;\VL-|'k;Nă6bE"{tvcy:1q PXZg/$F)+ZK Kߏ_EV򘜂7ͽTASXj&WɘE+LRJ \ w ړlCRm\\RR\\mRCCmmAiBŷ|׹_G}w`X C&,̝|w}%NWk*7aUwYxX| J\Eeո5.,9H~ڄǿ 4}7 _ ёal-@ 0t59ꄍM86{DýT 1LCD'UؓYo Z5OvcOQD|}3G/$aoM^s ͥ6-*[ : W٩3|mw6\\hÇ%y#&,W#-'{ (_ VG[!?v*M\nzO%N>ޏfr, dfslVwendstream endobj 308 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 309 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 310 0 obj << /Filter /FlateDecode /Length 5256 >> stream x\oq3y1A2VۣIgB}rxJhxhrv}t1}A.A vv~㳓S F)Sy|qrW1hXRsl!%s^ާǯң.u=QnZ~'港Ӱ;QXVZ^|U*/*4?1/^ 'Gs9952,H={}S8fz.ogZמ5Lg~E\9EvʽAP߰Wg&I?-JdZRI[@~]V-z踨IY`{wi`r2qNjoNJd)}}O\'hƠ I!#H?<+itl}.jp[9NV8+[4iq|i4v=6T QڷR}U_.c$~g>=d6SdDc&_/XL/`0h'_QNЋC`'D.2GUSCy]Lبro\5N OhXVٮtQqz AؙB%nqvZ>si1ppϲkzYh["ܦ>L1v^@ivCf_Lۢ:m*`m'Ii;J/+4>逤FY39BLKwZ%❡to]CsʟO@?X]M'nW\Iq.ZrZ U=pv 9SYI*@ {Uix;!t N_': 7Rhaux<[fV:ėQ1L`kjeҧ8~!Q O+9 >a;Q)rTqjyu=m=&>g56G$"dx;МYgQyantoc 0P8g{ +?6Fsuq8@^D!giƐb;"]%'b3ut` Xn1e 5M+Y0;?8vci:F<&K${KQH<G Bʕɫb+ee{s=©2}8F´T: V"A@S8|ߎĊPw:@*::0hL9Ҳ5 a"U!m3zq'7jHB!ecum0hc=~_OrC݇p&U(-ުG"쵙Dp_O E!Y5Fkb3*(tds6YZ ހ|sy=A*oXI^i&8ɣb5øTaX^n,O((2 OWtEg@N/.qvee׏EсDȈV>^XHZ+H}|2z4v1i"1G8;EWS/%ޚ o~% ? G b_I4$NH Iu0gFi(0lNjZ]9u+?)TS%[.9QXat}+|͖I5P@-ZhfH9 /\MIBnB8x0KNn O%f[/jBD(6-:3ySOe̘v|ޖ$ miT:wF?}YuCan/Ez%Y.nɥ|fטrT(:A(3rwOGٿe/0+Ca;$hh6H{DX(d{t9a:O#|Y_._7>,a|XfP,n67jm❫۔`咖ȥzV )ҘiK"hٷ[wub!W!ht7&_)j|6&׶Nkꓩ(to뜢;C[Ӱn;c/X??{zvk{^scc.9*ܾ~¢ppo~}zS\e O㕵T/|̡ ,UJq f¶|c4(J'"Qʅ^/# ꎁ\( cӚԸ  j(B@#nWF2rڊj7)w/_ ݇N uP(J,0)}|S+bsm_ 0=T"`K{z*> stream x}[Gr;1p}tm/+qș&a7%/"N֭IQI[;UYqϬdO~*ww3Wo9}fN=,{3#_>eۊtƩVGH3g󓷧X}B] nJyF}s׌\|WCv2cC S]Ր˔cWCV=݅3|Zi?=#jO6z=D+o}sW.:{m5g5)2r_ [G)&Zof${üsА].EwOYܕbRRdqWݥHW6*] YܥFⓦ Su9LbH$]k+Sx|m׎.@3Y񥧖ρ/9mcj̔@9\zF$sS}ZpS0$h ۯo޼p}WtY}Wwo??~x8-w=hRno_JC6O viK3AKݠB& 2)S 'b>;A0éawۛt&[;Gd= ! ,CwJ1O2?m34)я6h1\X 4k<'vH鴛<*8D3ebH7!iHqL84:4*"U nC5H&;&PJ=M̐I/DWb # 0fT?SyӘi+d0X˜UNEHq`i#qa6zY'$ r"-xɐ9p1 hZ !NLS6CL#ϐN2!1CDd3d2 #ycF1XϴN :~Ȓl̺ߏ1mg̲<cVq'ju%'jۢc,/0"9F pj)XH1A!VYBu܎l'rhXejN4 a*$7ą$Z-K1cCmJu-f)4cT)RXhhL|upna?4 L-f74tÏO@͐^ɠN\-SHCPc(Msch-I\Zi64L˨GyPZf$.8fag۬ S4Wb{pc7 ?uEHe5Crx&tH#-81i/_,ḏIO^c˾iAv)Ȏ cB%OD14"CVֹlhh2leqeW"f  ɍvC;<&yniHl">w!bz8nH1R208HKqLjx0bȐLSǸmCO\> Tdx%duɒ-!Ŏԩd) 1E!Y֒ C,QZ)sYjqq(!F. N~O<$=$$XEŌr.ri'K1Y)1xZLqԇ/fClÐ ,PNCH =pڲ%5&C*6[-C gLvx[5ƶn-*~<'%SS6SAcr'ͤV0TBxCoM?ew &#\ ב>p/21%9,b/i-xɟ$cZTS`IDPaK<9&dX-ߟ[Xd$N0ҒnFn}PM';$gaBV)1c %2EI\9l[[.e2DŽ/)VFnGqٯm#4b Y;&@0)5~0\ǬfdĂ[5 2y.uwul)-#8&2~k|:c`Lfl< FAƴ8{$zVΘpJۂ6xe>1mͱ8p1cSG}dP+:B u8zHLrcwWTO=âe_$DG +$kṯe㣎В98p!;e6/ E:F_ϩeAHA\  8P!y \=-HhD,wUAW;!Y5jS$;qkdTy-璢ŵ |t Ʃr>$pu(dCLcD >b |]s; Y"uqyg@ >@^"8QCVx||q* N@@7yac V6HtW7 B%Y=VgX!w|2 ` "f[R@/&i5>y>q_e$' pçZyvu_uH>;߈7| e(sYw۞36YuԤfh@C}]"H X HbERՖyO&7zA j,բ$X| QH-k9Fl$a3)Rx Z!!Ů%U4v3қ`1Č8*BZ8fAdh-V|SZ} BS, $L =ڇ!b$ab _Bou&9G:u#֡IʞB|9A0lqjNUtHi9:f_BZ5bsK@\]aۆ: YW4ƉACTxES<Fbq Kݭ&'1oTE#A/ 1p!>p\DWY(' C|s*gCրߥۅZJͬ^FHu2V$#BҌ[nH xE<'I1:&{AI ӮeR(u=뾧m*h$vV M89 ذ2$ ԙI(&H0l|^#yޒ` /ׂ!VU$!~W۲\_&)^*#svj!18 FD DžQQe͈D>1!N֢%W1V鋔eM#N`UӞ [>U I%A$*,deY$l(4 $l)MˊgR(+$jdU︊BѵL2͹E2L'>/, BXN};. F xDư֫?ՐH|y*E_T3hK$Y,Q.XlM:Oa@/..*m=*$Qׅ۫>$bHԑYR{lSUEu1B~ Ln!ݟ"*Yb+FD@(gKb5HO @W1Ķ+KͅRQd}kHr +w/H+~%T {!Hkt bHE cKWIV n[2D%J q;]]EbU]_] 2Zl%;AƆIJq+uj b91`2$RU% PYxh Ox 8E7Y ty H3(ܲb2\&-X^9DD^uCY"inYF$]x.o9$#uxVBD:"!UƔ3`<}fr%9WE !@W$esB( #jDy TfD#:Sr#SSFI ?iP֩w0!$M Hb{OD#1ޣEhA0zF#g])I" ک:%"*GIM]кZ. ڧDqȖW3iUqU'w ś]*ܖ{Hϊ"$GO=E*N{H:}JinzivW-"VT4w3XEw$L8 \A4a[D,@?SR&r5V1)@^F;'A!F@RL2"*.hhDqRk g /{uҦ)ȓa15kdj# Ƌڙ <~=kD,40FH3\pFT\|<*@55@WA"^\!'Q1jas' 1 ~(`i@D;,ND9HN1+v@DdzXi7G"APJrUаJJޤUx2Kd hjJXEvIv"]:.'DH".6{ T%'dyJJHeb.:K(9.X GyUᡈw_[5B$!U%D"2V%'$(9^҃Y(cD)MOY'Eѯ!Ih*j;A<LLyh$[h NC5b.Xb$]E2Q):Q@DV#$kBWDpNI:E`C^y05 xp "\7K¡*IY,k!3[)$iRdF?H[( .O"AG m!ϋgk! zrLQvߏqy)"ZCDɪ/Ihezń)Ao|(NzKtͤYV gҤ ޸$J X깩`b ZB EВ̓H_UBmBBZZU!}W^miHBY^WH_r1`,z>I$ ,55BFsbB{zZBZ40!IXԜhX椠|?.gBh&kk2нpEb7!UBˏmO:!IH˼R>EZ$ CҫiL"Pr uU4¥ӞCbsxNZ${*&mCϮ0'4Pthǥ+@6dx~7=8=|w!onޞn^ۇ׏?5yǻ+Ϸşo߽N/EBnka^It7fbD{!5^-u?+r{~|7FAK_HL j~_26 y|Bb8Ē$3qwךۃ|x}Ê7׏xoX0̘ԗn?=L"G_]zƩ`9&q?y}T0)$+D0HO$d, [ysZ[s=*,WЃp'_o4d]޶}Nw+fUE^Ow>n&W=vݒ.:0%,Z|ѵl^>S$qjQBJ[hxx&o_gaAoSMc5>L V 7o=n'a,i)t+lm5!mtIQ# bVl[i< ZooiƤm+4o5554 \w]8#$3$^$kP=vH:R]}??Pb"%{uPXS/X|L7q 5oV?hYW+&S_^U-~Oz>\M;EMOxWͽ&pQw'ڞG~h!^R[a',$&^F,jywҋ;ķ׳z3_ݯ%zV+.9#D8#!$tw\eҍ%KodcΛASdϞiwuQUUBH7ҍ RwVC,+/':g:4>R%'uڤ ~oYsVgvCK ~+!K| 5 !qpH˪|lUڪAo +t]%PNiG[v;iH;) x$6_Sm3>"Hx &A 3m=]ljȖ>}BtzAo7?XLzUbFH4vbhsͥ1jANHv8~#e>z+J4 ,H :Vn.YO)|rNCOf›Kn~`i<be#qO8x#_eL=xw43Vy UkPذ'):r0>ޯ@/i=Era M_4 ,eӋ[H}@mA 9TR佨Q$x!C7=ʞbn'@|IV%ԕf6ԑD k-0lgLBjF6.}6kZ]/adr}w]>bs"zgJd~v'Zb[C\[Mq^Mf75w\r:dk\Jr1Mn^"m3c'Ҧ?H-6nbdŭWvPDrnk(Fp?ex gV&X( 7nZ3ԢnDOʱelҏLjyK_*7f+0o\&'"!YLnyzonL[Ҳɩz, Oѐe\2LBukP U|ۉo9qCӱ 2~ L'bQ:zi5"tO(NZtJRQ.ѠJܸ}ny.B;;+>oF yz&܀]QU!:e Rˡhe[rcieRmN'|`k~\$,c@R?'6[g6&\KGpڸ[26v'x 8h*òH۶_ -#`SXl|P֫[iʫjwhˎYVߩku6BQGr[4kh%iYgV7p5WvY8XŸYd n53*PQU1A]uC֏zvi*31A[*cV&w 4Oz +*sU/ 8Ұ 2+וB/ZnhwJo)Dwk ۤcp؍img*g=Jaޒ@HVG`e}h4HoުP6$ dctG߬-h")mNZ۵x\uDg; {ru]؉7{3~+e+Q$9zxQH͗҈D+4pǁ)ɝZN*vIߎv_ZQhXPRRLİnwT.D|4۫ꍜG%vu"zWYT}l.%oUK8~8䆸rmGAoYg.K%^X-ىDgWճU,/X.h 8fae/[-޽uM Fb%lhF.%*\ ;Cx4Ob[aOBbxxطX>~=]܄SGwUeXbp8ԴRC|3jS.nea|O_5v\囨nm;%̼HoUH[ɽ#vΝl~sI!sU0o*`UlMyYberOKZ8TO8O纓d-i)C-^Gh[5Q|( 1NFc^a]n-ixg"l{#d (xpơ }5{~_|Z4/ICp8UklQumu~50zM{K_H8CR{=l K 7=y$J7ک>{DY4o4\}Fz-U !عG$pk["0bB :)B ߇˦BoKP٥( wZ#˗b鶻&/$>"Rw`I89~y::Ws& +M.GO,O ]}`aŽ4p'`ww{z{$ضo'k>XK_i?:bY~O(fs㥾][)i\ a]]Yo͢P]Fy3@yܑyvs$CkD /)DW摞F6N-;.xn,G//^J8)\vF-)9>y1;rfET}  ۍŪYTendstream endobj 312 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 313 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 315 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\[o\q~'L`N~y b$H0HaErW\iC?>UT %9X@;KuwuWi'r'뇋U BүoEITҚջU= [yt1.K)=ZRM!-bTz}r߳wK‰@k-zDCa{(}H9kc(aj 19n(oNoó(#Ki8~|{miM0a\qhsϬs9~~N&"8G=Ep֧ym ژ\I/?efYMs--rpN2c`wpHd da4+H VVߤVmg 7 H5;6q7E~/>#?,tC/,>?0J2?2rvt^x˞n./%x\X+iܧa(_p>$"%7 GZK'Gۅ?M(^]hkY9 L`/j5w-ڙu{X/I ?ܤnCmQtc|JYt6(BJ">º!q!~e Vx )(xde[ P6?[*-}–:G| :Z?'Ղ8V$r䃬Gղ3Jx1?Q@uk鉧[:K$أ1gWl*o9z~ϧ?oTl,{FxeP=D "4 _bٴKsVJTpEDP][.owUQQ0 h6 5yȈmX ws7e.s<*Xzp9]'4W1-,_x<ӕƢ߀ػI qU uNw*ydnlZ[S!!ߡzzU5(Tw` ڻFYĸvp 䋧cջ9ć_/> /@b*]V;4ǼcEl}/oZc5NR߄L;7<#qnyg>jV‘/cf_F.$44(O˄NȻAh+QH,FF|=HU0nKD bvg77˼I'y2n} T*6) .p7U;}Yxbs1ޭ߳y_=%FBGB> . [|f_.&|-mrqkd7qMk{=`κL  sHVSoPdvjpZ!e}zTsunsczgd-B^D8_L:IYMY ̶t L]l18Mfh\6.ؘeWaӡ< dBBVQ2A?)틭x]In<9Nց P'{ AO39s;$b,8'A ? eΜgtVAJ\'rr4U6./Ed9ߋUwgamG.|Nޤn52 BbIg>?v7V<$7i ԋ9;r$ ˁڂ(n4=MAP6ү gG6hv?аɱ%˙Cڤ1Gφ4Mg3l {u쒣Khj!0x*Q[.df5:-yZDmfwbgA!M +trSzQaHrmU2~z?\߰I{SYcrܟ3 T"߱HkC-*wkd4wުWq@3a8ڍ~W/% iPOZ թB[瞑։.::Wqf tAT^޳;GsdsovhX+qp ILmX]W~wtUh]FQ#-D]6MQ\DS%+;$Ώi;W&Ud:(sJd{5pV,B>ଵq$-V@a@3=<$y?C\_ ױ\6> U3`~[hZ.R0~HPFd[/Zd\p*]0KVYi3aW8R>L7ێiIlŴbh~M]a)zXEk+/cĦ.Y)fWmd1ެ(%%Z`3vdp aɴ jVoڦ$k]ӧ0,uL8ZNא'VC)7̈́*J_z^;5z6PPE[@kMg4SInO3f.6XgdB34f)zXJOlFE=Y5h$)qw_pqg\e4E zs0\,C'3 =ͶWT(\Ctkſ#gZΑZ?M D<>IfVrB8(\>2'ߓx5j'ˬƥp/Ӷ^ XH* +Q7KW`z)iyu VuzgB䙯ItS 8! pz#Cy.}vY+ȡ M= `zY[dXAoOAt;OB;'k`GP}]e-4[VˑVӧ@ ]ytdŁs7IؿnQE4*f `\f[L IgДʫQqG-JZ5*bӪ-mJoID۷ 9aH~j]<{r>=4?U 7|х _U!-ѠtjƕJO-.dMz2N{7.#)DD&9Fr| 6v|LC%-\jyqI1NhtoBi; {KPW(HL&.'^%JJ*u4.XDW3һ) 2VW2y?J%6ďUJAYh-ג,^*|FbuP*O0NsMt;^Pn:B$/v]MIDJ[,86eY qu@ /S˗)ݲ-0H) h p– {ȥRsy> p점`Zr-:Wz/[7ZYm%ՃGj; .K.$y\ 3EZluN,Mi>/W8cc>& PHiK`w!2yͻjn.h=4{6d蟼pkQ Kjȗϋ 8燲cOVXJW5E_>:*O#ciRNk<B V8%w:I+A5XH7BףRqbd h5cSfؒʘ qSsɥhk:5,WH;:y%{{jm(ifSԬK jMCDϏU@Ğ9hљ?.)w6,.y endstream endobj 317 0 obj << /Filter /FlateDecode /Length 2934 >> stream xZKoO'to, î'lFk-TSdweo,mz~`ڍF/vǟWcwu%.WNA U*:oQ9#|] FכqC.~|#>;xV?dR7l =q^z;>?M?ۿ%ȳNV? YdwH" :Qj^o3MȡY~7Bcg2[)'t_s|MQB>4Mv\*i f/ǭbƐ=2"dKs@ OߞU Țsр"Ĉ81x=8vK ѐyNa;?16 tgݡjQM:DG{&\t2b$G2b!#a Memӟ/,޳kY"B2R# A8]va,q/xx~`*7ĘW[BU{aO;}ͪQV8>T+bJK Gq^Pdc @NXu,$~ƤUI+*.gHS*N(g [m.>GV).Qg]cJOр@T ]Hpܦ %lx-'n~*Tf=zʁH<,L %Dd(&$}Ky !RUkС4$I)[@o|0xS:f(bFA)XƠ\|%<&6Uw1 "ǭ~׺dUF<_5I=8] w.`(+4+$rt\(zSa%*FEeo#LUU7-;gZ;uLb[̱4P9Yuۖ)5ɋڽk0FBm'hjd oGNuG!!<8m$l )C[\Ud_e%i+9&qq, B e82X1 {:4nC+fs@6JSS:59̲L K;KAOÒ/mbߝ*{Sqe5!zT a ԏJhK]ϻ}23_[m+:nʼnnE cz vYW pn44.S+v!bpiZ_/.hdmU4ng['ט(g"^U)_蠀#Aa} , Vkok;~hXW%x MXHfŭ G8zA| b.ٙ;_}XRu}c_5eĶ Eh^Sfa)֤N3NDݔZGB+ /viWI`VKs }g ]\Es7wH;b+x㽋%SŐ=XLGt3Ws/Ӗ$S,^|sljb:Q#CT&.˱զ0q&ai?OZ00F?XN#vXk84#[#B:@:t! :>cxSΉ@!,uZo8Z՞Xaڼ ߨ+5$jcjo\8jYyEгJZfaѲB\*jn౑F?> 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 4916 >> stream x\Yo#ו~"*a q8j- #Jmj[>ܥ܍mpJźYi&bobuw`.xuvk®8/?^ġ|Ĥ+d[].o}}y&~}y+Ľ^o1{\|Nc^p 2f4Sܭ^y~^~kxX㙬1Kvi9\I1 ϟUc<ƙW9]wRIz?N5|`^lq!8Lkѩ(o#sǣ3D;TN@g8߿v!ހ6n?/j pFUdF@_3x㸴\!Mܑ:߄i%S Ү8H!S^c^q5)|_jS&gV$ k b0ċ^3g1z/X( '(ZYqt' !3ZhL%v-3$q[/4tL֢i{M!zj?Cqq7hzjU#ۖu/f {hlAoPAt5:j!to4iFTvd D`b17 ԒyfS"+AjW+5Tw/PqFjW(8Е@zS2KWH9g %C.%fSǡh+5̉S$'sdeQ'عI13tKwQH9i5'p"q90-T/LVhK *^Y m䘄tl!+?/uUe?y܈"m)rG'\*BV|"zLfljsLA=yh d7Fݜ41zy@~`11snp^AYv[G)H5jT]$Os&D+|ͷ?x¬4rժՕPou fz{?O 5vX!-i URrxy _=M^C3N+ i7{wx'CLi:̿5gYv??]+\<`:X<`~y=>o?~|}>y|痂&҂ΘOUMxb4^"f ô3-9RׂI##XyJ70چ߬ow/zDg+h7-d]*ݔw&m Pz(S 0 >xYu?tb_hd-VNrchRA'*PLƧr)ʠU*'+*Сx {tge7!W -b!J("oŕ$ B$w dbx sc4}[a\wh6 /ҖoF;z 7!.n]5:˝gX@`@K3"1c}7g.;h |=>GTP:ГB|xչ'ExE׿BHTs*ϼuk;mn.-[!;j_{:Bi6f.bMP-?Ng&T x24u46hFU8&[ɬpIPP=Rw* 3vYcyok-6WMoL.xR ΠѪBhu*wfg/d|4EUs("^wsM8ȏ,X&d\*:V,{#!C;luv{d>ݸrt& *E XKFoxlmT4uL.w/OdE dEX2mɓmz(N%4ucn3y.x(9ˢqLA!n(`ܤzBB"=Xb؜ e(3oj'&O(r l =Ȓ_}xyoU']mƜ y6,j.G990je6ОAڟVXFp4WY65쌲яEݪ= \>Ԑaw49$m.T ~BU|?0 -}?OMGN1I^a?a32i!vs֡ƫ%,~(BTO`:Sܥ]3;._jğUAT_GwaSb:V"5^@K92\$UeTA~nٜMAmv/l?"endstream 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 5407 >> stream x#-.ygǧg5.!4Guu˩/'|oqI]O#S)`a8U+5џV.ɏL0\mόn~`Y !U璽}Z#l6!hNF/ib~qBi-;!}?n7*{{''>0ȐX a?[1TCِognOl!Mj1X맳K=[سڞְ`OYE^*/At ]@s[BQ9ۂKg[ǝSi3#1Y1!!hg GT~TNrvc \ѴmsxSFk#xZ0'M<$?mP\ m jϡ(pDZU Y?]\8g$<=o{S=R>s]ZܢQc˻;;oS.lx۾SoWzV\-]?t~@\ ))׸pq2 K/@;]!&5ݪ v}.gxCTr G!3 )HBZaUb9rNQ4S!#yW?n5` 2X@=ȕOzFTxb`T5 Sm(9_L1DJXLwϲـQ~SxBXgmu3awM?8ɤ }#4rmk[b?0=Gv?b>{veI$(ZZsc_e3: Txk0ژ=3, ('==3E;P y (nDr9#~!c|/sPo"H"=+neU8@wUdK/F <+Ey4r%o%xO,j^׳mQLO9#j.v*!.:,hqt';O Z#>?aZ-vo^.Qs &9h`knGtAAI L.l8KJ 븯K lreW_❎6Am@S"\~IdzhhQ~n6biN ЯmDy項2b0n-cR3 (O'1y|+X{4-╁{|?M&  E)&f)Bn<{fVfJ*?Xx(2|_ZPlS3sj0<:UA vh13oveBLߖNK!ɐ(?S| v"n`ɖE '`$8z|3xл~.rn14f|Q AiވZL <6j)}h fuFjI?-ۡE-W(|4!~w .ZIf<]= O=RXw->dIYQ_{wsysuԜJLt9G82(Td5&.9TezL0*>WmE֖,}y__&z^b ZMPx^Q^UxCTe{EshWS{示 vȦeD ayf4.Y-njJE0UEB4ј/+kwHګJYAh0 &b j?4, g 0'B#[v=Xir( ¼^*Vq؈sL5,/'WwEȹ}FЙV|?]YcHU0-h8X)fAB|"DE.* ,5&wTk+b#܀b@ ղ J}x^ByA'V U!º[χc~v+:]zUnj}\,fT]Nr#f><;FEm&+iXURQd.[na6A>_yM@D E1`ݘco_>URW9-8JTѨq}m#>S4'X 4ԫH 3<e['ڵDvׅ{ܜj"jKrύfFG_Ifm0\˴Ń ڑ#N f3܏TnZ}l Z|ضI4:"QWkuhT+<-{}w6#1m035UUD\a0yИq:Z+U:-d#:[̉ =^hAvbFUX( 4I8Qbܕ3bOj;y~*0@%2~>0T 0&ycbKKKx,b;/zIEld7!=qLЉ c婺D<ʖ]:9 cx肩j.- ('+.[*%M,vT[N.mbi9qw#ḉsi3Prی9Wҷ`DU['!}_&XOEO8L]{h4">]`17>[fs/ c JE|/"?pq;Օ6윗Ϲ\?'kXbR(pt&J*+K¶f=ykE?,J2c8{7Uv"6*S".ܫU^98?wxU"$CRUmeޟ;6SUAu\ ^ZŮZ_{ jk&Wqd1&ƃ9pdUhX&w%SUE笕Y扬$>wԉȂԱ\gZ\ kn%BJE9 Ա"OVpq&m AI,&vDctuYgoݳ[eVR7݆\*k+M ߵ\LvtBlhxf-U3c)Ptg 2i*f^"g< v'5}r)$&":+̞”Way5}|G,4QO#P@NKh6?%x7c8gUzg LlNoRIo|{W9W 9_);#K({(TlOCSW l!OWU$Y7Ii0YXMqa4;T}|emDAE}|>a/e6G}v;٪/+6j2d4y $(#!ny I(pgy@MRh*ԟ/D(iџendstream endobj 332 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-> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 334 /ID [<84b31799dddc702c95146e591467aafe><3f9a74f1b9f895ad1ca1c67ff8b9b414>] >> stream xcb&F~0 $8JD/W33JN3S2Jr A(p/ RD Ru RLH@Q~- "@)D2H`K*_UʂHve$KfK [toA$yɲ, &@$l< lJy@fZmL@d 9 q4H&X*{ endstream endobj startxref 278681 %%EOF earth/inst/doc/index.html0000644000176200001440000000104413740647357015113 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.pdf0000644000176200001440000175442114055550430016042 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4712 /Filter /FlateDecode /N 89 /First 751 >> stream x\Ysɑ~_QoĚ]DyDICɖ&$Q~YH@h*1B +N "QhHBGE-tmZ c 0^&*%&9qq?kk܏p.t-2 _G\+k'BP8z{Wh$L-JĐZ$9#OL]H))jSA `IY搜h N4N: m8qѡO8 `A4&F tN(jAR@2eHl=xP$n6i[G (; AyPve j_ h$ `4@ ^M"1h hƁN$0mtA#qT4tR N"Ȃ5TAH\up H,8:(:C jH ڨ:%Pxc0A9D! R0"4ICH1g!ysQk(ov>_B>L|}~b~>oy;d:\}Ӷ''ͼ@xZ=PJ#"/wq5s|l:mOe3 \ُd&>jnÒ{ DGc]Y>:>[ŗ]s6rݵ67b lq|, ̯|c}<91Y︝>M|]$|trl%>|ݰ];WsSkKEddz+h1q%O/`Z̮DVG0h/Bh\c{n> fORub}i1A\¿ޥWq~/!?ϨI֮?]wX;<O|tixxv ^J<t|3w$6 {*fAV|6È{bz.^)퇧5eI j2hFB~sWQ̧ZyO?>|˧d8>pp<^x6ϛ)d]0._6܆z&6t<ۤ֏|eOoץm1h?e.hgxUҰ=#X>O3\ _ȗP~Q3;s9?_MB.tgɴ$?w?0p:Qs6EVGPdIM>Zʢ׈h7b 15VFp0s:/=\]a.?{|h [KTǷ i\_TlKvHYϥ:7(cCDGjGG*r)kG;+ÐÙQ}wx|tMsL]c K*GSٚ2T]GI?PcG,Б~Dױc:;/[gW.N$qw((A ebT c*zuo|՝v(r1p7"^qO([q+:Y7 j܎_kHufgVDC:}Qr[Fh ;Z3H#e?$EH F22RS(\:& u,&"2Afk/(4ndk HR?ΰ`w:R@ 6KaU|+.{oU3M-F7fukQm؋ppIFPmi5-ي 3lO=[j~"+?iκrjʜ>mIZ=`b]J+#rzã>1]9݌}0].._.s+0V@l ބ-} 7AkM=!+ƞťP Qja)_Ԛe{6ׄ$ĕuRr[E*rT.\rZqVN7k9F*!Zbѩ2x-,ēO< P8/`8" \fw.7..;..?UePK[hknKqdQV![{K [*lMβ[匴唴圴Ա$,+%Rx@3=Fy@cu\sT-('])rqRq\Us ,0=c8+zOXؚ"ͽan%72UiJ(c w-2JUmTS?<+H)_Y U[+MTEUӕҝx͋׏(gb=.ٽgԴK8T.ʡ0g_&+f>?֩FZF r0%{g6d:[!Dܥ^M_&q|+V]_w-Z"1&%%ѽ$Ů)^V0`7a 0)7G>tyvjŽYiqf{o۳>dmw^~fJR4}[ڶ\fefN04A6OQs[m8FggJ/n\m'dGW-j%77m~% F:tANTm3ѻ:ݓC&IuwےQQ\dϩ"3'~\LY(J}sWTEK}G,{ش>kkym5j׵SηE߹wtb{J}ց[Hs=,E=C@S*Ϭd;t?;]чH.bjq诫w4ek2ߏS8=4J55/fhq#@7AȔ4Ծ 5IUt=3V;Ѽ mv]VRR]U{J Ncy봍1ljLiiSɰ,0yGp-/( -SZ>XIH:W%pu|J]C9tG[yӳs歐=zl0 Kn=8/gr6c7NOG 4PQWqv0y{NfN[;Ýx8\ Ϧd]ܮzsm~p"xU|ܫnp8,lN)[  2{M)5Ѥ.f8L .|,n,$UT#W(eTPQVئsxm(қ'`hBֺh7{J EY(z3x Z H ?s˞k])E[?U&bFUHRJ'Pt $BxIJagE1VlS강.zW$0*haMn̨*QTҖX [FLjm2H#D97@Up߄)6WG6@!r5-v֮}CJ)Q;߅s)2yGoiG1:2~hkDmj פ}7݉}h3ai,J+kXRE+n2أVu.Lh4_n2]@P=@@ȟ Fª'4@59L6?C^UQ^DYoX3`ca@ bE;ɴ:kG8GFi-ɫf6[\lC`4lS]9R1\=̖]ݠ<(IVAm*{#-fb8iB㣇@VʹPPW"bӰF6"SM_qz a| SLLiTW&r@&w?zOû:@?g|TB&7rq\/([W\-ËvtLͫf!l0d1,lGXzlV'% H1!W {LФyr]AS@>X7Rͤ SnA$&fQgz2<=m`v\G_ 兝j!OO来kikeEmZt}c2+st'.y:b^ֿ ?8@7Yw UC3endstream endobj 91 0 obj << /Subtype /XML /Type /Metadata /Length 1672 >> stream GPL Ghostscript 9.19 MARS, Multivariate adaptive regression splines 2021-06-01T16:30:13-07:00 2021-06-01T16:30:13-07:00 LaTeX with hyperref package Notes on the earth packageStephen MilborrowNotes on the earth package endstream endobj 92 0 obj << /Type /ObjStm /Length 2817 /Filter /FlateDecode /N 89 /First 803 >> stream x[ko_1H Ȳ ANE`0Fb-I9áDyIwZ- s>ν3V(. . ϻ$"HxŸZ'Fh0 3 tvQ)" c,,MJy쪍0c0mUvj/{a-eAXJuSݳ٠Q©^F g<#\X|Bcㄋp2Ax hYxU‡ AbX'ACm1"1omD YD GrZHxhLI%Ie"vA$yEHn2"yH^"ވ9^8 ^d)caIETȝ=T ACm`8\S`s,zA:x*UA8}bJL:LT:ݣĢS8RGW?ީxE5P,bQH) ocJJb?3QIEݷߊ|y.a,hNq7/(q!7-3X-^lTXH̜O2BA@B4|h~މr}2ٳG 墒~&CJu?T:IU? KBa\핒;T6*Ie=$U2u[R>ਥWNM&Hct*ӷi;TVk9`$㍒vT} N*k݄%I朑qdhRT /k6IʃR* b BG:C1>tgVA[g ixV4n4QU"F~. @ xdrHPQßU8Tb@lTjL~$O*x^Gu{d&k饀)T+Vf{PM ҃ZilIzIUnVmrgvWMz^M'矪3dEX^+_~Zf=Ygrw_i9k?1g[Q'@PJ?>gͨG  FyɌդQJ xE s<*q#SpZR7^ɴB:P P\_ EfYVэ'3,ɬ(pQ]sȣ2df<>;^uJDJɒoB$ fruaa$ծ ."oyX `QM*IAJ\7I==M~eX=+Za`VO05AX?1KCǴ4yǠc~9%|.+gӹ{^ mg!T*e:.,zw%C%2[ Q:`drzq*[}z>p*N9h'ȹ 7X~Pz,5Y{szzr~.Ltv-jzl\Oo&K|p^.|Y?Lj#Vz+?M7*+nשp_og8C:^CԷĨ]nxD]ShC-0`kLօ\Бh-=*vRN"!6BӢF.fUk#wg;HAE|'/yP'E%ވ5\Oͣ'7b98y-/.rnwЄ?曢w؃r|ى ތ)9|?u^dëSާ]oC$JH-Bn{,6yK;e+(#K|O6Rs|?ڈ}7q~EoG[Y`e$ƕ~ W[v^(9 Pא%ڽ΁5YB]{=!wj#1#Mö>iψܮȾ0we{lW+v ŅrX =mCziqܐ֔-/rqu^ g.1m=hob6endstream endobj 182 0 obj << /Type /ObjStm /Length 2246 /Filter /FlateDecode /N 88 /First 792 >> stream xZَ|W 8̃b>a,v1chF`ػ*YfKykx-Ǹ2-1s'F :hxo0g!8FM|ϩo4p.͊QqH`AkBS!lE% fܫlTV&*h7߄oo?| ?0{s|#&ǞYͧ~ׇ|T"<F- W>9?rkxss{޼JT$*5mG$E{* ϵ5O9ھ23A#c3Lv9Dw.VmL#pk(U/|#ڴ-e@*2>,hOzZn XU, 3yx t ׼\r˵-X?\yĖ2,, bt.%b(D>4LJ$˥q6#vfP=3QQVw9yjJPIX`+Du.c׵ղl|.1RIՍ.^{ ̨fM6ɅQbܥ6#UG`9jvUwH~@QGө1ܲẲbѝN[ ]bmQBgd5J(@.B!P p-C7P.2S.=?rEn$uHrcbCd-P>WdpCcqtnF]TNP̃@n$KO=,,'Y/zTnAgs E|*sIwQoI8H,|I&//Şa9!>չ5Tx~ j>g#ll*$t46<[W3{˺cU;dB9<, <3v<.----|i[|']/3 |zGAylkޏqi۲Q+|ݨǐ[u$< geI<%q0ȝng<82@uNH+PY$&쟫GG6ȗFRcmYUغ%9s-4?0`_]όw.uMw8` EI>yC=?H/ -̿dҒ&dKz'..<_'Gȅ$Raܑ z ;pRuNM8=:/?pIα3;+K8AVC^GKᕼ@ ؐ8Ւ/%d>}ٞo_e'uQbW RlQffd 2>6~v+|DGOt]^RP3[R6N_.!"_3zH1QVċ ]G;M/n I8◬(iGF;5qNtG}|9:z*zW4Ӕ}ח> stream x[ks~>&b[T K!/kVWV|IkyyNR.2#hLOw鞉*:SF4Tzz2oJ@C&e0LjJM̤TQΣNNol,@}jjLoѫ !BS̴ĸ*Lk/̴!@3=Uף6A0`1 zQZDO̬6F|W 900S 9ߵp EOy览 1 @f^G(H0љwɼ!m1'H96΂LoBH `4*JdBZChYxɢĂԢVˢ՘$>1ex+9CAJ%&\ 9!ޑ&"tA42 [JE"I̕jC/X%Ԡl` <}HR c(1$e$ʒXMƯc@k1:T0/0vKm%]ҀbQߝu]dIϛҶkKߖ-cSBqRJ,u1G7}'Q[|x#B{}4kE8[M*#~{^ul&5xᤧgyQW(>oP,i=Tn_%TaTu @rALF,&e.r=!} 7t#E\ mVS3Tf3C#loU]gtشe;cXmѲ V꒖i[=!ղT!me[kړK"o-FnA$c26zH__iLYv_G) ;l~T+BR?omؐ_=x?ȗNki$/c~OV|ZTjW_f@]Qǃi~R%R0^ĩA=^7?>(eKҫ,ǣ:iIYUX$ t]~qB-JvXV |]Ͽk2Έ1ϦSjyXLYlD`6Ȉ#=}&kYGRyh`RyӺ^bޗ%[N8='gӺa1=/rkB;Q^pCC¦Hьn,nSYFM9C)vf;Rk*.cW8hi$_doqmwaŸgWQP&,<ŋ?) #"3 ɟ- /),uS[~ŊRY.Xx'L>](/(,VKIO3(kcqMem ս|w-G#V#ď;jbbf)] M!)vgTt4igXr23ABm%a:SI{ߘTrՠM&"jL%I’Ȏ52d2[ zɍ\c,3 3,>:|եK(DSh~=ҮÇڌ4\fv`c8N- n6ql 7M]:lA3ᲪOr:> Mcyԟ~ P ~(,1+ xg {Hm\Й¸j?REH."7;GE\9:Z1f`2:斲#b/b1qĊB11sk氤d(yi-!GqW[4Xke0OBHӺPmPKn_Zahymz&O&f1! ccQ޺aa"F,c҂:%g4w7J@V,ͦitϲ5@)h8ag~Xk7M-ia(Ygˀ8$tEd{]|5z5|-v t_XI-/لc[(Voia)~[yYOrgϯƧ@nCJ{1NQ#FH a~.b,knSMg릻GǸ=u5x?]Khuendstream endobj 361 0 obj << /Type /ObjStm /Length 2869 /Filter /FlateDecode /N 89 /First 810 >> stream xZ[sܶ~c28f6HiӸjXm;XEZJ*,AùEk% "Z/Bq)8 /$Aơ g<:$(h ZP,,?Bk͓V%t. tTwͿ0 C/;^Xexp~Z[ 4)aŜDº-l1q ,c< MG|3;Q8IyJ @$$^@}<:8UAxYJ,HJC'2U  4bq0;qV:$+D -1XmDdZmEt U;1bU!x(f:d^S!|E/F@ H)=q8ĉ㣁( HEk z7wG[ #9lLV0(@Dx{Z%-(bֆ%ZRMNfyۈgiW4 5]kuеkSnŋfXէ՚j\矰K<+!+*V{U3^F0Wڿe[A& 4F+(Ż|tVXx(~>XmQwN q{afoz? qǃ {[㐯 Q{N`gvGaI|iWMzNSSԴ aNa{8 {}a(()U{ǁ-hLC>{Br߱0q3h5xY5<п~y/Zeן]O&<LL00CRq0R!̳6xS>1e nșz&0jl7WmSQȦ\ oM[M9OGhZ"JAtFtDy%""|VjM# F-䬙_h!Gi岑WtrU@"ɱdCQ(#6b!4 ؛bl!*Y>l\E)Pj|X-y;kɦ{ 4Cu5,9f p^@DAg jG Il$06xBO:x(¶;xpF.JȚCAQ-*R0H*-ރ P$ˑvfbå 4l#C(5"&$2ڞRu4 *ֿ2GaJ6[l\H@i>h胝iw|)J.@% D=@ԃ_@@0}]AI]kñNحq& K: q@juy qa׷J ~T2RB`ġCHcڷ˞ߠJJZbTakLP,d<<D=]r_u;g?&4>,C sN@a\bs=,XviOX5rCw$ѸnG!I{TXxuچQzxde>$=Â^` kfB80 V2Hu:aᎬkBݾ_7ȟt|[!S/3 cg%, 1D$6eNc eK}!Mo/Dj6e.i_\K sMxGzΗ$OzSvsfycZz^qM&R> stream x[MI+r2>KZYx/ Y=, ݀2]qUj\ Ȳ++*3*#ŋȴg )x qqE U\kA;J )L â1AbԒF u-hyԃVTSV 04alx^h`ױaB5N$TȁZFZKɡV -QTCV (f9$4*ZQ|hhuXh}x k%hCe;?Yz͚'W(6c{3 Hit8 [--}-GѢ]0<أahl`aQ|NC͘?B?K&R#w؇EϾ*|x{ͯp#Ǜw7(>p~Z ,@^1ϪhXqגb%Ww7onٳknYXKp%,[ E U,`ЙUaA [ Jqv#Wy(qwkݽy{Q.R1}yGa n]ǻ=>^>_o^>w1gOxyݗ/kiP*錮a#ZK4xfM9v ԕ;?'Um09@K$|]Y*u(T iKXGiDSM*ic$J<Ş&Oʠsʂg6 `0g,+XFPu<`^V6w]B3OTr!e&[8(7O2]낲m+e'WT|]U*w~]<%,:n 8 'g k &6KX@9)!MQo.TnY>o~a<$V栗s-(Tv`H*HckEϒ3V5EHx% 2yM(I4DqcySkZ Tu*}ݍN"KleCo)͋_+|n;okЌy("TFT`鸲iת)KB"_Yf3e9{.J}@##T"9> hKPdi%`?ǵᎉt@#OߑArrr[Vq|l t+;~6n=) 0JdXXR=a5JiH*0%v +i̧,q,9`TuQ|ĤtpR#&)r[ {nʋTAq, ObbQtbiXÆUrsMK>Ւ3H>[:ğk&SgɌFz?_I e,nO2t%jZB* SԱm6M.s't5`<#v<ˉ:<,iiVU)h!}YXojXtwgzYN5O.]\z*&xYc!yfEl25_s<*\bN$EXGe!ۖ/* SEo^Aե]b<0%bg|l&۸V.I1zX ǬkVbew:MEBy9Pa8+lzvChBdpTT鋈:%n?}k:1RlPkV#-_y|F kvKH92R_bendstream endobj 541 0 obj << /Type /ObjStm /Length 2852 /Filter /FlateDecode /N 89 /First 798 >> stream xZr7}߯S)cpleS%ת奔)?Xb"Z9 "92GΖKt7O7;# N{/lN5,IDq",W"&^y#x[h84Gã1B;A|ڗѲs: |PcVh`00Za'L0hCV9՜+$a-Xk1JX}†`- }tip98ß"o%H|K|=Oi6Tc)>ao4& jA6>E.o%"Ox#+H bFMd+֌Q%ً,"gP^r2g8$Ɖcl4 Y$ً Q( $SEU4E> Rd(E,7h+R6x];UW(2F%EPZ0Jd@F:Mf(``wAU) G h= P\R'QL&\VĠ|yu_]Ct'xgQ}:>~8J"pb9V5ӏQ=ɗųpQO1tR{5F^=~*39YP]|j#=!jw@pëu-y]_?_ zd2'gz=LOdz|8U\FOHa4_-Bd W4v,j9ݻ/>~yǿwk2fU2Jpx~H)TϫAu\ QUWgy5.I5Sͪy糺U^ 气5ܒ_[t|Q7磗˺xt09ѵ:~4ϡ'Nj_D}CsZެOw?CX]V5cZ?)x9 d@wb{7H[~Ȁ"\c}`mCSfHAFJ i=-^rsGάeq9 3uU" {26 ?{3|Vij@f+U8p} v OQ$ji 2֎t.K%Q& #AĪL%@RBFr-pP qX(A[Lp"v2;C$sWvsprx[ԍaoLZF@Uemi+mat6[eW8W䅡­sZ󻆛•Y7wˣBYdk'*, 1"Y5L ަINdp?+:b,"p}gΜcgb쪨Ȁz7YY-qpjT}64X_HaE 99)Nwt7}7 l W֚(<&٥4~ɊڮN:1Z/LE^g ,=8_,K9xx5E쬺Wn壀E_L$.Z@4o:AnMg#F ;>u?Գz“Jaf9_endstream endobj 631 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\[o~#}*Kޚ") CyWJ+G89\ڝr !-/]^ewGtq~ .ҟ?-8%Zs8ywe f-B- DѿǔpՍokJfJ!3ߖ*UǂrFcu*{·Bq4N~5Hd8̓P+)z-/8{of³/kLZ1+~ځB.G,$Bjx'űDz*_;d`:N),X9Ǩ ̵z=r]%, qҫp$z^WC17Z#?wgx Gq?z4mZ0*cVDj qq'޳s'g#ڍ T|wrQdq>rgV*[( @ ,QM6 'tK,ɹ_ ju~Gu(, TD89Zζ'[y)?%TUq* to[TxC׿ȜnվM`۩"Jv_G+`d axdֿ.Qkowk(Y 7в_]ӱIݭɜb85bf.J˚?%,jubOFeb@vmek2{I'pPJ $ Xbs%_6m_3^&Z?@I8 - X{l1k}*T=RsjC ? K ZɄ"JQq Uinj3-d.j9zZL^*N{pp(}5{!ؤ\"ߗHG."t҃%*{x2K#4<_ |Uz=W1F311c`]'7(NL" y[FPDTNm׃NQ*YD 0utԽ|=5HʵU2k=o8!ăc͏[aqZ 6Y)9 b>jK6YTOA#9vūS¸|¯F5&r@(տjI3@ru<SD0Qnd9EAS:%Tffx~9pj XXӓ" }1& ͣXl'w|L9o>F闊cEl-p<BSFRtYPF3ר2LHQOk_bYFAg/5)52.(S(A}&]:) ReCn㻀/bƟlb6EIz<FƠsWQlg#sdiA} fҔ0ӃPڦ5{lP+ѳˊg,L4%T+('XSPChD=g4$ HlTaI۬% !v7uΨ90VԸI"B8#u!8]rFP=EAgҀ!K7 7ئ L(`by$CmaSƿV$T2LjLJYC䕹40<ܷISmY [K ~ؓHgہ'DJ jI*Q- x[n~k~%E}V3`Ѳ:z}q-¼!Jsչ\od9{Y3FdDcF^1c\|! 6fۑ&IJ_TZb\y^#lY #F{:|`M NWrYJgvVwGygꙿ˥oIGsIm)w}_;ѹUctwMqҘ~^9sMz;kM Ft8^Pƙ&S_qv{.^FsJR~p*wur"dK^wU)Awy&69j=#ӕ[&qW#|Q#mj֞:C\4(cBb'yǔłEh'${|"od8OvwiCk4Fp>,aL'&l> stream x\Yo7~G >d^dH,%΃%:ɲ[Elrf$":*az`'{vs矴[\l>,.;zcN^B?~[W765p9sU 7}J}krK&ǙQo̩ w\~vQ,gK-p»˷gnx^ςfY]~fA]A+.!AC+.{|_\i H "R`  -W[ca@ٹGmQz^#eY)\<~8wkT6(Qh܂ L+(;;$Fa# JKt|в; 8Ζ`"`g{lI=.%dKcP)u8{kk][ <k6,a7bJ1q<t 1eFڬӕF#M\R:nKv,l-4nP v$i$ܔ=^0:Rk)@;>cnz OiI22I4t&$:`H%6ψ҉49$և_b&L 3i ݒbMkc(>v໧(0Ɔ5v(]iiNu/ӈ.z$JfxUJh+m ^)bØ 1dC4#><#F%o'x 2HvdcM y"8,{S,T 6INB3U=blyɚ1 {Ճ|K8װ6n_2zRdC6txU0Ї js-Uf 9#y[f(?C1K5sLE7r:qhA(tM[Nf#Շ8=Df@Z O3TPB@( 損 >I[xR#NN@l_"yKt JAN y ^nTIt8R; :%aPlrNL{7/h&ChEUq紈(HXb dî *y,E'S\d1Ep`2P䵠z4\ ~sY]q"7%eD>H04^u~x[\#ROcp-r$]/-0Ҭ|5ؐNTTt(UPY2c(DjӶ%PZ}hԕߢ$݋V4V#7ZpSUh̯" (%ʫY56{ӂ!r!DI.;KA@{}aV%+gq*G@!FP+&-Rfq[UךԾzi,kxxJ<6PZ5 ;WTqzF?;!DO;&V.u5MHMrMcW9ժ:MIݐowv%ڱ~wO50fb֢e%Bb #Aش\;ȵK fJPz$K*FIlx>ys 4pB17lc 4^]*A_o¡+ˡY:d1L.6t6Xz@޶ PŐ)i&Y ncO.Z8{*x(ZY,:c./u5j<pZ0t֯4p_ 񢎊Rǫ\!W3 d=:(vR/e:zB6p5 0s)bd~Mާ(M\ {;*U^8.̚Syh2(2F潤tisNޣzw@GWt;-^1Y.mEn9*Rt1zW#lP8Xp$zz3V9/!萇2r3~H-{rYAJ[v{ k8 Ű?ix͌m7DSx[|ݐ&f4`{DVJjPpr}=af:m!Q |\ X4O+!<]LN*/֩n}8p{y[U3)X+늚a d&\=(LUm%L[MNUh.4FEJ`hCOB}J?]i ] ~I)桔b^.6!Z=, f_^tQ>!")#W]Ɨ8QoLրnHd蒛x T "2K a$_xfgO4@T5D܀s$нS;Afy[o֛(0ĺ*azj6δ .A ;B p*wvԿqԛ2s^ǵ=^N#SRi#rwFQ56]9iQ FNe,;PK[/PqW3##M Ui3#_h䱰z_ȶxޕFs燏M1;-9eVo½ L1^X7!lu 8,ǚt0av.9'Tr!;LOcBS 1;Qq?FdpB%$ifZfCsU̥Q|EF xq-ïɘȗu"s*@b0`<{YdSvų#J@!0'tpGC$bVq/xd,A˅5dab9'DۅG!=UG4Ds'T] _j*n)%A[޶ID&|ÛP9nss~y^61|P ClＥak,RpjNl/5OٸW5@FLבr  USF%<*P)r"rg-ާlbsRG6hendstream endobj 634 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ۓ8sʬ,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.]Qd;$_icvri'_appgή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}#=PӐendstream endobj 635 0 obj << /Filter /FlateDecode /Length 5558 >> 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##r67vbi.mcqg<yzf?.oz+QOw__.w7g=:NM.f_]}u{ywz}y5z{}yzuZ wzv5Yɥ1X`5G[9nPbWB`aendstream endobj 636 0 obj << /Filter /FlateDecode /Length 6347 >> 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`.)#|+Ŵ>90:bXӜI`X}$pC5.@N'I"D"/頁nw$m̝$!+HJglJ>=/d(NMX jZ"&E25g$Lx &P C-#:#&2EHm\ N(=)7\H;Bz Pt.u]  bߏ{̺kM&oPuF圵1l|7ldl/4'[n2o-[,td2}@ӣ h[HSiR7u_h *~`gD#=0D6d6h_̈']"gs<9.t3jGkN2=RwL"Űxoȅ{;bfK-i%K T=h&."wcEڣ]8/} nd¿ÌY V~ik鈖=&-cL-V!bkKDGSo[řHvP," gN(3KJquuw#EyZpre.JV]I+L|p ;q:e޳g|Gz ʻbkumw-!T'r:ߪN.7kT%?x&Ǖ`9] ރ1 uMr#,H1z& td8isqvsu=$a/ UZAB._ܼJg9Xحd!n 煴.x85kS̶X.{9S }̢f44&P5jxKsd+! I0ؚS )+zs䂁 FHM-WN0ȧD |9Q7ZJzsv̟YaN.TPС`{?ĒjVz-TDe>.jNĤ-c*Zi@H5(>sX9߮M΅}NXi n ع|DQ ?k1+sVɥl7Muٛ-|RP&T@-޺ j\+tpj_Q0Hn>]~U6a^nlsc%ϱ$!硒ֳB%L=b\F ZR4lVII*0v99tendstream endobj 637 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_ET =8)n_螁 zB ZFK}E9,ÿ B M*ޮ?q0kN#*|Npt#vw89 $0[dJO*߼glYCUh%Togsj wWpֈSr,;*CA1rϔc_$b 7ГAdp]@&yښ-H"1ڊjgE\Js*uvSiM,qn \D8lU6ke!oc~;QrxB ]#rU%ғ51;, V`)$x+* lXoef 4)Nj0PͬЀE}sϬ*EtIтژ:x(CJ/ff/iqt9|34E`83#8YC8tuvQ:ӥUoYg{|^YBH-C>GֆGYAigK2*W4`L7뚆vݷ;P̩RKg(&] ՟hQ8`#R1 ζ\3.,ikQߔ!k9+a^M($NnIeDE~zqC 3f LNDgnov(o G戓T!YDD t fc/ё} C9L Gvi_ )ɺ<-famJVJxsWD+uSx'sD%b`>K#J%Njs# mnwsU˭7=la>½G_>..oP&/yڴ*:$K1[J=e友~BIm|vl|G7Ǔ4Ml; ao[>טc:"9r/:ɍYYT\["ᰬ:S4 ۅ^hʼqPj%-~4Bը_"$:Pw)D]be>+{MH CAB7TNP1V'XsX+#|<*hYEc`R;wƤ%EŲmJo Tpr,`Ě$jTb]=_VFuU>6T|K fPAhn%N6*)JFG3I4%XաTZXARn7JaNJ7 bXT ǹ%³7”p =Z*rϩ7fZrKk05x'1"Dz! I%oȠ)tW_Lⵀ .Ph&c:NqeSKU[u@,i+^j+'5opw-Js}S?^vLSιtÓ5-s\HyZ~ypmuuǪ1X[cp-0Qغ5 L%S86&0s@͵7^g[|@Ⱦk m~~cncԸ)D,QI4jsӜg)ES.gc)DeI^޷H7 l#:jgummͲUGb)e^-!Gz,=G⤔9ɝh;=)\.u#E&ULjs إd_0x(  ^aouğ`RT/6:$)׭Hܪ@6uҳKsYtտ1aa[u#~xet{o֝a_w-29(MWަY+k˼nR,:G|xy7(nR&esCmÙ:K<9cXj 38 hd A#RԺэk.\U]ov> 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=C3VrPHhe;1]Mz)عi_O[iɵF1D AyFU"D;9۾M"{!.8\',]BPޤ0 '\v.CX+A;>C!6>LJo⚚R+\ n)FHCԩbDr">Uؐ*P@/u_#$Kڹ+ҒG~S;'N䙄o$n֚뺋~}s *Ý1e\ b pIqjE(=pz4fTowU3vw)3e}ˢ碴Bnp'Dm\m#W&~N]Uw::|̜(E#}cն;uHu vmz?/9PUS(䬓jxs [Jasɟ@LpXZjzA"2Hxi儅=-,."<9`WMbɂ b*蚪N/ݠ5N}9No' mya}?uoecn? btM56L㿕Zl*;r-"G(QsnƏfBg/IIOxF."F0*~ޮߦHendstream endobj 639 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 640 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7660 >> stream xyXTWG1a,ał& C҆2b`}f"EE&FM4Ѩ1j탛Knnss>Zzn$TvD"9.Y1^i["i'+/Z:gHҷPMW%H A>[C솸;eʤvcL&[-k3$n!!SG![Vx{yz9yڙ7/ 43ng iz7c͸1vcPѝtqhdmjUws~ݭ1mmg֊ug/ 蝁ll7{3zgV/nw;w۸os;wa߲~?u+ukf0 i]̦3b *&f" #jT;7nAF{hu Nⱺ8Po-qrL{,kPfٴ"!zE geB#> ."Ra9JaTݐsrb8A[YI.<.7B!&hy}EqpGNOWN;W։qvn]@qŀ$=o 4VE{\\,Cvw矔\7{w8<"-[yCe&8/X3K!kUG&y̩NBT7HoRmc;#Ñ u|mxGj>h5(/ңf#,/ K7 ­V$oI{cWdihI.V)vxN%9GƊ:D?y@eǐ*F ^:C2a܁rsiuN-6֭kLMGBpծu[:EFH\o:5l"lOc4BFBL8\r:e=fq $x 6#K%?^DE7H|8%AMA􋧈E=F~%6,NQh̋@ʷm rXCjnQ`n|8ǝ揟+ׇ!e"%{Uwo =J)24 B{x*{ςaU?GM ΁A+5#Wt$Ri!hko"I%lkTdY$6ǷC:/h1da{<$S ̬eu[&[G9oB56r)vGl, g,/{H;/EE ù1H%4 uxS* DVmMr̒_{pE7 Wx߷$a1ƇfiA%HF^_d0WVTm(iT{ uTiOB5TǯIjn|YZU*.Udگ;j+0GWH8g$KFrPΫpߒ`Z]p 0D <(EiHMH|wfl'Y`U]E;<ãb2/̵>~[*<~drq,X=$)HUb>NN7~ko`EGUN=Jq\wn|="鉛7Eyq_7Aea4,mMqHwK#>DO<#FzER}nK%7R1 $0?RYKhB{ }:t( $)B5]ZB*=ru BDF$٧A<$ʸ8G ζJkȬFԅe)IEK]V,&<a?q&ɱgh8z݄0d~#Ӷ7`6W~2eYjeu 1;vx͹>DTּ ^*|O*=@[,$-; @Rb4.f[UFr~;ٱҲչmf8ک';m+|u$dbˎc$Qw\]9jyt;tlͅ\FyChśz"Ku] \y\SV^\\ |پ#%:9wFլI0Mُ6sj0.?^ ' G١6l;l̼:-ɟ7 IlaBġwniM QSO#6&}4 c_ VN$B%zR<>hW''iڔT%$3ްüֲtۏL&I$EQffi{RJgU5gyRkY(mnQyQ`ëW{FU!DoY'( yjLG UfCM!$ߐ C}T=X:;8B3)Xghgr0`01bbWX,e/Ƶ/S<7Q<ԦזGGF)^'N5=_AouئR c`KpqTytiè'b TIJШT|g?g`@#/NF{/W˅R:MkH 6I`;a_'^kp(玄3s6BjmvCܬ?U'PzѲPh##3 IN*% fsEbr ×dxU,{}=$12]H-r薬- %`YzIT;7IXr^N LkRfP6d(jw@G6_¶,)*&4x:`1V_k,jknّEeS.-ֱlB&5|Hl?$m/-4xJuvЫMNL&6=UWh~bjZ = rmmP9a9EZпp~`ٸ~"ʘLON$SNz? AUh6SlUI2pT6uzI[נoXG {@LP<.W4Eh>ơͷ(3{V|g07# >^r!JʄiAСBur J9R۴~t0C\ʉ`:H䈸2߷^< 05ҳh]=6QD{݌=#%g +{taF˟V&6lm< :rZT@<WU+-ںc{t W5ϟ+'6(K1v7a=^NNؙtfi bL'HH"'AF(()`)q+y:W0($Dr?E0~PdU`"+lֆ$Z票AEСR!5E'-@F4CwȮOx@ZC*r΁lE"$%i$G୰Bꃯ2xI;b=@ Ңޏ5i+f3 Y'߼% L!}!,1ʥOh2v&5 \UȌc.AӳSm67,=IǖL2ScAhc+C#kJ*J9a'B ;i^/Ej 3FNK0].0WO M.7gp8Hy+&S@liyI\_Zz&|Yx2 pH3d[=g%]SivkD}w7nF6/K2gֹGlݼM9 -">by$•$:XXZQ//`s"ndP@\ !\.KOMYTIpPTdΜ{ }$ 徭SٶHLaϮCDBj IY i[|x (pu TbgZFN&/v0Ib%7bEwN}°xQ;$ZUbJbU)(ۍ2riF o@C= y O1PLFh߆iVFpG5.8~["pY|31kzcB'[)l:X) v-,r>ڲ"(tGmmf[@|jhb[Oy'.\hn2-s+ ;L[М&9NYMv6*QGmD4i,╫O@9mId* (PFff{m+lxAI'cPaeï{ZHy"_lt)ِ%B4U(Aڊt:U(uDB\=Z/ii+m>e JDEOlgWBXMF&\f gcْ2F2/ 6Bá=zkN7\e|"Ea4F~MhbP˫2ڔ)C]BwB"u 2ӻFI+?,)ō*cE gκ0l"j¨AjШOeQ|QĬ'T %\=VEӫXZF@(DT,Tn+ ur1:Y(Sx ̀Wo0;*,5J֩\(w2DLF9Ni_/AL4~K/ѴEthD]'ayl2(4j!`pd%~Ù#jM//-.)ϫ91:L.3BXPFW+Ml#A՚\^+epiidp0ZQ. \꺑OQCXz:W1PvE[4aJ€Q`ۭJJlOjTh4 iiQ ~~BIF&_y^2kt -o|)*GL bO-&\|<*E! yxHΈRcؤ8r%TphK;-HU%*9etqcAteݔ ',Uc ,9rKS0,ӡnYW}h>n:]wCff| K"$CI^tұt~B ""0+)[U[Q )^i +Rʲe.#i?Yުq\V} -TKSGۜ^җ^b~ 3 }ݕ t6TJ\ؑ vb deg/Tqx z̧C&=iƊ]Uz*NE`<>gD+ìqa_./K.?Dk1\0I@pHe[]O)HRě^S?80kL7 /< |ܚrzN5]5\~LbJfGq&GRs+ADy[QKppi@¶u)(Za@\E%q[cj5"C^[%! ^ F L"$q3<]jj^WtYpɊ*HuOJ6/<NAS\*((20ce":M{okh_neOZtNU  i*4A)w?`QRW=d*.76Useئułѝw<8<`c+(srӥk8:,[͢.+kMt8w_#0uJv, ^Ve2uPϔFwD.ivB]-Cqݰ$6>r'Kh & #M%LrB .0IqfEW+O'!nbgT[E6+uԡ^u5:HQkkWIw)YD?ad[_vکHx㐉Мk'g v3_OPF6 tP)ܢ =!&Œ9}&u}x3D\I݉ݩ?OMNP@iq;_oȰ8-P0:h>PXTe~nk:w .~.q7z!qeÇ (# c S D[4Ytaev>ͰQ^kM k/ヺzEsU$F(J5I ikB,?'(nN\ ;;wXԹ EA&endstream endobj 641 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6303 >> 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 642 0 obj << /Filter /FlateDecode /Length 4786 >> stream x[Isc #^2_z_RCY*IJ#Qm.Wt%IC65@ֻM|`_j3k w3~?W0聫I*#˛Y|NOLz>Xa'p}39λ~֌I!Gw1\Iwdx{1VMޫq{?[XEq=cBqVWVkNxX2.s1QŎ2!>͚+2]QnQ9P9It=QqtLd}vK@|Zn/C?)}ޝ6cc@0C (: q!|χcSp~+{=58ECxH]ۨa.T8zΏ4~# 3 Sf?Bk Zz̀ؐL;J?\8o,Q[\q.$ \d20$m zU) 56#P|$VCݗYƧEu <&Nz%;EƮWuw-n)t=5 ـ,|푶PTK @٭_<AryW`uD7x;5*@z{?'$z,iDNw>}~\~Za};ItfTDVv)`ıvIf0_nk[lOFO ' n/p~|#p?7bOBP)ASCʵ]Az|p2އpiCKZs_?Xq?!j@*𴣳SQa{sZd$p G{RSfK䀘jڗ\چgu\A>}TzsB=#9'hM QKa9sޥtt}4 =a c}gP(XSx}BbO WI\&((2ruBY?\b"īY[\p5CwuCoG >7z~{Z)ql3s>M3HŮ鐞rhڮs2+=:-c zYߣ, +jL⠶݇cX.VWnB T)o.mmy(b ;yl_mo>:KmG: _QOg9е*<.ŭnZ=.| Hť(;xlJ.P#0m~̫b\- kFLZ5=h{JN| c\YK,yuX8thBM$,zo>nBm%?>}q5~ezRI`QFֳO*#H,c$G,$9G,!Ye΂6c#tSPE:+Y2#tVgb/2K>ōmKp5A2)4 >QJC:kl\  xZ#0 OP|A$gVL1\LwA^!Ry-4?n.p ~8;~P Hc^ 4Ix:kM#t`GYI2h#Ќn8fpd8#7r<غ =>Vc !q_+S; U@B>&(\'!1m"0l#Y SLL@=Pa3 , GǑL.0b&+g"z6GF[4EOFP5 4*ωO1Vz!U#߇|11XA"CBdV9FX1Edy艫#EZ;jk$F>bYF";TE@`GFoO!Ţ+I梦@T N "XVb9BBR( ^ q<V4f,bX0Tׄq#!ˤzVjsBA%uш9ߑ$F *vJ J% l]{\P фITaTD_SW,"cSqEauREutE6q4#mk:܋8ЬhKuA})M_vqp ύec܁C>S.>ZM5t1W/= ]JpzȡUL5Sj !EPX> c(_{fP 4 iv3 tJ{0ԡ4j C%mm4AN"T"KId3(/BQ5x| !*XcAXUw6%XqprCXC0}&GlO; ɩ9n^Alc5Q a[x4U˿֛/.6l5Hѫ~\x۝Hp!)9t'粱hӝ 1uEy9]_#x0L1U~hpńWC&T0BlEK,sTT9KKRR25ⵡ35)YQ㚖.mm 1>ҢmrHۙ"1 JK }^5}R}|.QCZ?\K$X_dk&Waߛ=fävt>X[MrmSQ߹h'1"Rj[&g"DC ;] *ϼL+@Tb '^Sn  ‹k#PxV^G?5x<}Si D85 UH/y9WXiޓKR5#6V u[_WbA2p`tݣ<EwxcJs 7s}7 W MP~G9_ʦ~+L~~^]/kr-޹Wғ qލS_O,譗WpN@+Va+z2"޽TI1ޑM̤  fD&o`fӍpUP}wʰ."DRp/ n{X̎} d-fOE8mjܽfxHx[Bn0OM~f'īv&^;_!<9ʻd nRf/oͥ˚mͺMdZt;`_Q?JMendstream endobj 643 0 obj << /Filter /FlateDecode /Length 3940 >> 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,fendstream endobj 644 0 obj << /Filter /FlateDecode /Length 5675 >> stream x\iGr_1 lnWiXXH ZDZ C3$g55=%aȬzh%@Ϊx"~:d_^>o]8y}x4~#E<)D}tN<}U'dvjc8yzͳv7v6϶۝~z'QŨN{2jsnc~ 3lI鸹9F^7.&yí7/ohzꔃ10v} a"~RVLVo;T뇧kҰOOa/D\\kXbOުcIY~y+L}WT r;`Y 7t)4܃6>@ef0mP c.-2|hznF(zi';gU|)wY }@9kR;esPK;lS5L!]R;9w<'m%∥NS,rI mtUZ40gHUI&7,M&u5[p4';0 ɸs3sPrEV w ۄ6/ XwaV]E@2UzG3*۽ Tz\إly='#)p{8$3I׍3]g,iFZKXżC=<2^R\S,$m'vD25<ؚJg*ՈfH|V|C]cqzw @o3ԯ:( <oe-! ?kZG|(Nq~HIt{i m^:\=J\);6+{3OVژ9sL: D{5O@AˑݰCƉa 6J48AU$,!yXˣ{{xJ oD{<-3Zeگw)b =%1E$&ZlUmHqɖ<{-~^0BD_|VI^k///bߌ]NG(N;} @rqiZk=$ wfv v:+d91Cxgz Y3֕Mbq*}--X)93])E yŅr52^6p1Y^J6gh*0be e9:3-{QEmZஆل [c !UOUX&đs>aJy͇a pCE bث˫lu5#3F<2r H;</^M9̍P(Ne(|M/#++ el{4뀊)g(-_Ķ:,6!vkh D|\նUXr`rdXog-zDrha!6⚴A?lQiwy[h@hZv#5^r4$1OMkLR =hu^).8"l΋E~-_ -^z9ؽRhV(Z_x` KG5w܊x=7Xx̾Zf(:[АT"bZe2#el)jFZ(yGOވJz.1DB[jkSe,mT'j{m0xj˝a|P^SBc2׿ :t]Qw}tanCv!E6qHG7ȏzmKG?dRWJ74|OLz۶(!ܪ#C.Y2 &әiȷ٘s<}U !.np| ''3ftZg"͒E`f%Sl>GdG}j;/v׋!%^LZ3{,=72"W ( 7>v .KC^tfYb 7EG*_ߋGnJ\k^ Rxɇmz9eₛ;taLD=ߝ&Uvv3(J -wR-gUz^zb\AdH:yUWy!vtBH;tp1`pšΕ|ټd`n$vyһjOP>DZrnӥ5 LPK-}EJ]#_8/xEpT8?%;dDέwHdKm3􄴽{&! J@/ɱZ %>^QbfvC d\e`B<3Q{eAt._] ۛ$6.W ݇+7E,JLUjs+)7!g.zk}'|m *l`dKNnII1E):!!;#QNq"a堃#J:2QO6 @͈EX~l2U4[ \tjZ yʖ\S"%˅mQ<\[穜mΪ6bDirTSuQ Kk5bhaBe+IVif BEo%`߆U*0hc;r$G3#"'\OD2.3w, !2•e9CR[&8&'uL$}&^²Đ371~2:Y#J=Ce\ %y{зC=G3RgWg7[c h/v4^ f]l{~{~}}K.~3uKrJ7gSTz&}!%@A붛8M47&A'cj%X="0cxbH*S%!kg1e5J# o(崵ac@9G 7D76ʾ%3xh Ϲjm N 5[yߴw\dEL%_Ir'5NxlkA;1C롂8crC%Ӂ=^6tDV+4G:}XD@U9#- *]=^H+ h8T),<;:/Q|qHݫX\4BG78-'S8Xp,!DwC480T+]T,;Brߎ{8NTD 9ݏׁeb ( ZSN^P[t 肪wND3bxrIu2̒/ q3d ۚ@ t&kN gkG\&WByIѬCJ٣&#}/GmJ|ECp{DE@p5oƶ钳.9`4kZI*(Á&'u`YѰb_+,+cR sqRFȁ<=„ַ"STfyvSK/렆@^h{1"!XdB_vMIMRW9$k*&fL?wBd$6o*fs!~aONk87FJ4F$B'95I}L~1 n!.30 ̍dbѥdF`RG0OC Es"5E 6CVll'BPeC/Z—%4NK6)Pxi?Ib7߄}k}L)MY56k*f R*ջ%pО',E'?mtgrx?lajFI2U֧)`2 WtN-Yw;gG]M~R{ NODY^TFגW 0-\Lfg9V{Iy8mô.$nsq DC:NLhS3܂QXWU+UT;%^0R2-}FJ Jn(!o5; 1չIq QkV#yv\8ʹCޔA\7”B <_: wW(䴸N/-O=Y <'0Ib8{c{ӫ gvC?VG 9.tniEɂuao ؋g"Q,Yq #R; %.D:#|Z Ոxb q|?TuX`f$vYtRcs,xruFatmq-u?գZLښ/Ү)r36 ]y_drl/S nlNBD.tE_lY!oWhm1 G2=s̸950s ${u*_.٭Rlktzfݲq%㒠L'iS\o:bJdL󃈎2W?~1Hxq|1vs?`Pf9$x{dyKJoAu>f, !-Əi[MAZc RЅe<q(LDžh[OϞ#/"5T*I-ir"r3h?3jxhuut(3eOer *]UEIZ:GD =ԖK=Ē8.?lW/v0}YNcqy屃gT 9sw(d"FQcTǏ#wQb}oyV=ő8wDLOB(#E) "͞3 >SkIJ4^f[VχrZbB߃JJfd7!v{ı2NHלש_!+3XGT ,-e ;;%'6cTyT.Yendstream endobj 645 0 obj << /Filter /FlateDecode /Length 5560 >> stream x\[odq~_ b@n#A8#Ph0Krw )]F~{OWfȵ,ᙾTW]>?<o}gهq͏o$zw;bgҬ7U9˳Yl+y~!{J5<[!ҫBJeV F,wLyo^u=Z;16 \=&74Z^VD\X +=Z_' 8XPϤ\{kei@{ -q"chRyW{( ګX@bOZ)<)t mni²aa *}rE'F(!Q LbV?EnmQ +1J[<߲r51p&mWiV̗̋.5F6!xmCq%M}=gs6Ab*DΝ غareb 5jו:|X;)Ć/AX3I"4a+JvnD3F. aJ:[ͱ~i}ƁDU^'Cԅ?Dʼh'}OC)RajuɆZ7hIſDqV o] Պ6ܩ]H#`C(\ؾc,Ae.^5Tl#o~,B 1P: wYd@АH~}B8_8в0&kѾ#=u((R76vD e'R=) &SEX vO'4kWKeD@7~J .L)ZDq;vnca&s`>I]= "d"g]H4gs:$ FX+9e#'0~,`u0s`(u h0Kn|l.[8%lvehb h 5)+% ;%a9mBk8pRɾ5cqrWlhWl"ylBVm1,RN TݲA Tײ"UIg-'^,BA<FHʮDȜ0ILP"OsHWxM:SgG&  5f ӓP4b3w} X@>6]`ەS6`)qͼ(R/Y&J'®rGk.F6-Z׶PkU(?fNFsPj~W e%.I)X>öKލ@o|`55 'yvaFv&>ux, bj`(H4Rq0C"GT%_,2#M7D* 0oZE i9@>aV׋I*n|(/s 8G4}v!񙦜.Jj$~`dFIv4{uEr'Jv1pq;I]R}(TK]=K0<.0t9Կ=+!MU])F'bwI&oM:ɍRcY>&mF7V M+feŒR-Z0fs՜oQ'0=WA ҧEjy b%-$|tDiOU9ҽts:Ҕ*,6O2Z;p)/ 14zSy(Fسc/=m}b7tZ]y2 S)H,978aùx0}(,eGYdFePITx ܻ)[98+ӈ7Ǔ4JmUax0:5ՍpҨ]4ݟ#0Uf\9~4ia9U7@PgeM)Z2yR0Ċd2LE(;#ii4ջ͌ʴpr$2088܏<*]@. ~JL7)P %QV9yPxⳉ 7jk}|*cD})ȀOlVE#_|ˆ͑iD\Y' .%! w@ oҬҖ(L%qvHwiX8'܊(p:20u H-yHqz젒<*e?O/>#}$-.N[.Ѭ>ܼ^rÝ/78uY2c:ݰ..Bw760<~e^??v L&\E_WkGh^F}# S{[5WbR8 xE ОՀegZCʻ.`W{8Vn0 *^Ц؈ׯLĢ\cG%tE3(q34c] ˁhe&!>xiU[N/yhj&"p scTt. \mR|mNVUf,jʭ !&-#xULA 8 l|)6\]hVbV+ʻ8K JuU5fyŞkܦDB<˅Huto\u}xPfzihb\1h]/ ÚT~"jetOU3،hJpx3E9;5_MR8r[PBUG 0#Gk"ҎϴxS՗.FQK!-%@^T*e U]K>>n#xEq5/eJb*`+:qphU ЂNiN.uM%⁆2h>liEgyf^[iB¸J:Z==k؎s& ׻0 e4$tNns!p\pIJԥ#0z8B?I)-AV&h]~H C\\pR"72G_ҍNyEqFuZ𖑩tkP""K"XcHijz[bQ {P}ՀIn.K۸qʿ2 9ǝ'ru扗FUGNNAe4u`d FmhNNEXAu"ڞuA f}_|?$ vw<1w\Rj%5b]BeɌ̆=a*Uזr[3OE ~ޠVȡT[Q] PWKN ӋU,~u,mCS_PzQ`~Hp("s>)U#=&nPCka:YP!_UΚ)A]/ٺW>W&g3Ë5|܁NcsfO]ěo{~-_f%h /0a AAauJX U_*}+jT ?-X2JՍWN8PZ˿JymFE^ Ғ2qQ./+Homb T5Zerÿl$endstream endobj 646 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1209 >> 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 647 0 obj << /Filter /FlateDecode /Length 5222 >> stream x\o$q7 fQR,9F`w@<IK.OUgfԝ-X~UWU=;շo.+]W<ҟ}Pq>xEwaI;+` Tg?3p_7⿞_J{/oi=|jbL;=v`^HaL:Hp"bLh[fB5? oW~|X,GHs 6x ep'GV_[s`aJWNB-ςxnan87n@ogZI-$crNR4ú4\adm>䋕RpN%q@a0=Zj00[7#1β֪R0 (qo{U:=XOD G]f(:EZ:n*KR{M׵0ط>aQ M zA>ȃU|JXPۼݲ[/-sm9xN0xqAV.D{#a槱yA]PRp*z`lgKp, z,7ܵ~l ht稙`5)2*[/.+]O|#y.Jn"2#wP_ HK>sp1Lj$ԥEhw g.Cpb8]$~O0‚>QFd <(e:DE, M;[E)麳\Ukۣ2p9 rK9#;B՘L6InNaGHM-:u<+EPlor/3@\,H ހ9:5v>s$pT L❯9㙜I^:- xqnIgFZgVe$ӹmQD7a+<L%[EmMÀbƹď2Ba<"!5X3U82N%v@("G("|]>> sh$:r8bS FAcMilp&Uy=0n-0{!Di0̖&jWxy@9Zekpd ] W'jAa :3s4qҴ:[&POgغglFaӥpT𛾣3Х\WZ<h*R љrgDQuj.B#XG83LB 3՚:f#h3)g1>,U-J))_q>A`|YpC+t(|\g`6=3S)@?3\l$McjyTĨ4~},e 5d=wxPK A5Ȝ6q]dV< 8b#  d>icg^ +C9p1_tυ90Kvzb'C>^A !t$7Eu6QQd%TO3 `?&,,"'%nFeXSr2a+!OTu)-"~:,<M[?E!oݻqx:]];W#0feة) ̤S=an[o[H»Ŏ6ճ .\y{^-,mN&u;h 3冰<3LMh` -'VRY;' ´1MLyдX|j'*'<}j?)m eSɜ6,~!<Zt易cYSt̰OT:y׵3'|,Su+tpMҴ0M]TPs' =57ɚDIO{CHN' 8/_<%e~"͔:1egc\ ZDlw+ 372\֡\CcirH͈kRiTZ7r$A/Juhl#Pfc-ĘgPGU0e0=>w_aѬq[働`cU"p3 d&a`f ܋h>qӑ/ VA\RZ /؄@C);&EʈKrRxi>_R/kUV5gxu}z_rIA8HNY.'\X$࡫T׹nBْ4HEd߼E9iQKxV1s^,e u=yhP՜nw'a7qJ4㱐A{bw6cRSuM SXzkirbql(iG3yrگ8Py\}LWbaehtN$MA~M8c+^Xrn]6ҺC%'HZfr4) jj5YL#WnQh9{rl`DM#IwghHbg n޾Z2V **)&$\rU3l'dl"TiZ<_%>M Z7cS zJ¬ 3Ҫo9D8o͵8Mnѷz¬[-al,8VF72UN!&Ie1ޔͅZ$|HKHVޝǛm :n@6E'܃%Pl`vI/Q<< &.z{lb_8dG#^% Bs=2!΄MEg k 0.SGr~PRsonq79<,,S h9l\)vcK7mvU:%r`s oy'*At3I#0cPS< м˺s4 bfN>Ŵt&C QѲ~G,'167Rh=?#_$ކGάm7rjBF0~96uCO܂[EEfkGէ,z=5 Mn9$Wt[YÓu7fukwnݧu?`ug*p憛)Mi ;<`bHYBFYr) FX;Mn 4@@hq k. #MŸXVediZYP5ګe!ȗh__ҧ=Z7Kj],%kq㑦B*@xri ec~b a-ˊĜ??y m]hX8rNE!ik>0- w*TTqJZ(U^HEu:ˑ;ǂ<% x1 &(Jqx<Az]a5ΣLCO@Gun\`ja,M͌ (ۤ(5TDK"2 $P-ٹ3خ"D-ZÊ(+%Yl!D"Z5߹"ZY߹-I bsüF'Yp9H=冚" ڄ(5TD(5L4gc@ IRCE 8BW$'"@$'4ae!J ]d NPq '@RCE)tE-7̛QG+3U 3!6:cxϝĹl^_ħdcqPx2a bƖlsOl*EDh0!{l+BX@-* Ww U-D&3c ;0|b2csQ]C`@⸅ V(P%|^!X\LpEcl蓣u$H՘̗)F3m+EiK˼~pi0 ~:pS#N"X<{j8"aXjJ%v)ހl'@].wnݬ_K+2DW j7 h} _!ʿYG RXU LLk,,H_?^i)ߐtW!MΏpT[+ ožPj /"$~3Rgp pԚKM6}X3EzK珻H 6:Pk)^_>"p . ]\!>o8ƹv7{mPyXq10a\ݾ>arϽ7϶J}N$*K+WN"weig(ZCF5 h jr`/-үrm4}͹, 8e~}%Ԋ o.7?oyt}{1' L9@h*I@ks GQ> stream xϮ}^?GLүGgGzHiFx, Gn]d;zqǝ<>yߋw})2-޼v/rp|2[h7B݆QrzRWXn5[5po^?aBewF5 g3I9eդG/{~vXpɇ+= x8pg΄SwgcNOgħ=;Vf^EOiW\vV~~#Lųo@J"~Rel.`b?FSuB,r<^vKvNH "K݇+Ⱥ3C9yx%'-Q84ݬu?~u\#L#7a(c/뽜ǎ⠽4z7خu3k~q5 -QU=qXp 4<tSk o!A%Os?c^{Rς_=FSx*p>\@wf6NuSU/++.'f.A_ާ1r\AYdXx#ɂeNk9gIe|O|*.)"v0ysηNY6fxЍjq\0#pb J|neB9P`ߗest`d|5H @mtf4M;fuL-_,ә8 3@]s~rgXri} : HbG(@F#XxY5yo}ڭ}$yZ'[)3CFڠńSI戲OB.c l؁ܪW8Tu+kF0eχ8+/]@ _q:כV}h a#W5^zb%jiJ,>mOlʀ]d$P拾tn\%uk4V#=p6!5jZμoXcRFV㜕JU8.򓸟ڇmq.GulG3aⲐ-D@hՄCc\՘㼥CO -qcԙd^%#_ ƌPH %csJRQ:.M#?J{ O8a?|bA!+%>iѭ(w26S0hSݛ39 &ϒ7<<%ԫƞԒSbpYM76AV6#4CXƛC7A& s k&@YP` ̛H@6+D.R[}b]n.a7ffbK3h^E"3(%6Cb욓S[ 1zUd"/܂+mh^*Ѳ7㽷aB4`'y-US0ͮ&8F{ه-:a oPh]PAIyʢ&WxCBti~la헃׬k؏ +|ź_b헬^_v@e2( m߮ͧ˪\>/3ѸG l!;yÅdʶg%|N'jajG׈38ߕVcNᷣIǞ %BR>#~@a$΁՟0Z3TIi1(7i[5z:fF&jnt0I^+}~0@tDsh 6\Z7\ 9k m芽']FfsB~7\AnKET- YN9o >tGnX(adۃn@]c *EfhTj/upFw:Pu!fӖ| 6r,6׵M9})ܰu>i+W]/LۏNi,|Ig`K6ϭ!,+Ѧ]\BQ]f42饲r Yr ,ĺቱ,  8D"27?4hU[J JIᎳe er֫m@̫⹫UiFVż_cP4CsOFR[03jj8iII6v@pȴ{I˙c&%\2đa z&n{*ⶋ|,Rc璵In׳Eg/E^z:cO$IzIBIi Ljs>9mHJpB01Jj1,'aI7᯾+8JyRlK}TFUq/ObF&`!EXH}xHpcܚSE\{YfDolC(#Gqty7.&tbÁB@ab n gO44݀e'1MKbL>])^/ ׷;(pb@4H,nJ J]M yt ̸HO*xq`˜L"Q^J?_aH^0ǙV?6̀+y.$ $Jv}PENPG./O,1 ($Y%QBhWx*~7 p6T.VjRESg) KnE)D#_\I38`' GQ㒔 5U lci*P9{/͵NGcL+\ȏDB'" ܤtVLM:ߤҒ`Y0J4jVޒdMZbH~t,enrcCp\m SY9fCu^6,vCu=N9Z]jE =If9S*3# 3I+(p4f-B_3Y`YuSN8ZWlU.}.D8[:6P#cs2-,'&KryXF:93FIƗo ‘>tcC:ɆWÿwFN^yFf6I7|~Lqoˉ>KtG!eMʝ.u2\V od j5j(,vh(QQs)9xe~$wiulK RG̳Li_Ns$'E]AIJݫvCQ9;q( 0kHC ONqnꌑP& i ͏+wXhI#p XiTld/qɵMɟPgZz * OŧFQkjC˼ n6|Pr|H 76Pɻ7#(2hB\my?2IiYn\vUv[C)0_Mp~2N7UAVav8?- ~%8ԒۘITNJ6_1ѵ"Φ Y'#![QW1ְ G"qPEb\T%T8Q%e&kUNl/Sf>#W_Gc9iNDxOꓸq k<ʹ)UJݹ 5qu.Ar()aLSˌÐa>]UͩL"SJRJ[kZ_TK6OiC?ēyHJl-tȫ< XrLNdCAQ5mđ|)l:|+x{*Drm*t@!WM}e].D) 1.]gE"P.4U7J?>_Oy\$WB+EHs"CX!d.2~-><7,fMS{#ʺ45ңzI:o:ІQ=sf5oa$D7srׯ_92U/u ̝AE]x^P$; oC3Z&QWEMu"O_]RM&snF_R]&Χ uxësoD,L( ĭ 5 wbƢg|`ܸVf/R>Y9^dthX0{ճZZSikPSF $RfPt *[{77嵳E[J8orO|i`uQbߤ#o{cň%@3*_)%$I'E:ʐ; ل6x~C2&|TN0=uzTI%ojIeBdXWw?\Q>}?f(%&>>Zw|_ЊrՠRAx=ft7|ZocO^Mf6N+JOۣ*f71RvsWupi%QwG9kW=k*/Xw^>*||S5wkm#fUʒXN2Yg_5gEoj\r.d}*VLJ{6ͫ:I]ff| JR9/LRE=Om/8X8[Xt-Q]zǼ;;K$GZ% W3U:4ЁyGeM< =lGa헁%9ŸW nJnaQ>&45⻐bAm>ǰ@-m K-n9 ^,oГې:':i'9^V=&K#p6:Z:kKQ3i"\!gJHG'Lafn/]Gtп@s5nkf smZ_loɪf<۽+b}oRG~˾0JoK$KX=]NN%Ra[flS]N%E*o0 "N,-~ب3KGT4XWk#g5ڬ=Ћ.Rζ}&T4;Ri( ?pFU]Ui;ն~&*9m=.8>nSvDK[> stream x\[o#~7#QMwr>lӤ6iMbjdɵMsHtj啲m`/5s.߹P454/}񥲓E3N\A-&N)>CĪMbvvrumt*65rUIlVWΤcuD%>Mø]hUs:Ֆ9[=M&%VQ}B:ɒ)ЁjOsꑴZuê78m(@7s![{$Сsի.Pnky!U}CW%?Ž0޺uNnGgW䍩Z$=7-P-niΒvӿ^q`9UM%r\q||/3!L-̘.Amc$-Dlv)>% ^5?a .%m3E'%P+l׿6lǩtڪn[ؕ>Y-:vEsծ0TZ S"A& C嫩€6jvhOMO9t'Ӑ6+X` bUd̗@3z8fJ:.nW_]x@1=@cxd8m#ov$<ߐ )s/I%i!=۴d 9M5s\[y)=ma>#svg>}yՖ D۔[) 8dWA᜷_  $#%ato@e͕HȺ,G0 \ckN~4)jevPZq#&3ʰ&t) I<[Y䋜msHnS@z{>W qjW߆VITD)[5fɫ8 Oc`k`"=0팡~ t]dݽG֓?ƨ~Zg"I"x_KG38OAڟ1Qڠ"6hL jn;+hM S"$μ~X.Vݦ_EVep`Mv}]O`_ơD:ˁ<@WBtX}o|;x^{X/ `v XV}65Fìnsc@bvD_?G%Eja = G8%? IGo1Pw  Gٳ} I [(qjkR43<ρ DKX{acG{I)E "nj]p^X+y?/䡑`.k4(J;S]a3 / 0,%ME\b{hr / dICp֒eڛ‹l^b ?/ gՑG|Ӕo }>.Ii~[u ZduNZ$a[ )K]H+mY|\H2)G'v퀸2óg\)2Dɕ>5;cIC.,8 иE [kby^_< g\ÿ<;à0k|P:>| #F@zm7>ʔ$e<8NA. -TvD $ dP1e0 cIvh4sܙZʝXdڇ F/%'ABޛ7ng\lY=N^}.ÕAR< XN=CTcI3Q@8 ~ QC)eO[Sr)1i|YZJ4:9^7àA= `OlJ7u:>gj߾qS:f\Q%3| ]C Gh^QFF45%,)O` ,zwM XMz9 f`l5(r杢x)Jmfg G,56afo_"Z[B)kwCT$8Oİgʓ14>%Q221Xꉔ5S,ż0uI?&sѢ䀃tZf/P6Ōڇ'hNSܥy1nc!hIIe;y:z4XPJ2 q$ϵ-gk؀S ?91{ؐra|jRka.r\o5d|7 q <`j \;$Y̟ zɗ6;զ󝤷k3%y].N gޭ*0fbm`q`3^tV>%7>,yJr\Le;8~87N^5ً+,{/G:KA~- Z4:a4jy13a ,c<ΥS( ro-Ya;CdVWw"BɸGgI_*rO3o1˹ ďݛXU:+1^ⰥM8I딾B9xZb6ZS܅e%~U wFMK&n"Eq<Z;ǼDJ |l3{LMR pcMK+đ55 0twUjVGFF3H~ R;җ} RA:iwٹќ&?h' }y?"0|}QY$MGew}߾KO=m]$fq"RS"&yH!B.D+rZM8Hކsbé!628|$ /Ƨxט띭p :D!<8RAjO$iA]ݴXZbfyBr_Hb]@i"|PktuF[k)2H!c9K$+ҿ=:Nq,A.X8#$cza%Od3w!ZcJX =B]x՟DvP!jRZCk&8|jqU݂vGj92yB^q{.ڭ/K1 ΠY4,~ }GQ͚~3yƅo>;.LվYln/W=-\Cm\?Z]`y)G5 |>Uqc3O\vqT5BT#掕o_S}؅r0WTS/%RPZM%4 ;/T1Ʀj}jo؋kC\VoQR [mC5Y8JP@Af&BWm`x^Pژ>);aGn>WXwCe\>,"؛:qD:e _@́XD1k"++ʢ~1DVp@au#c=T`3q/ ;#턈mdV|H(J$6*=mD1?Ea1}(E9  :s!AQ414?>G7$Cڜxo?d།(~a1oQ?psj}lh6:qZ'5MX,{ur2֯򘖥WNW2p=c~<44XT,s%ڀ8zB=mlyx%J!]! =el`v!xQ]X!O"/uEbb8qLHqOxC!zņU.gH<:+R?8;\0)||帔+H2##9B̮ZY+ ֏=a9Sl,@0*d0cӠq_d  !?ڔThdcY^"Y^w{FnsşD*\?Eil޸Z09፬b?]NK?U> 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#sqBfJ\*X0S_3}W'\.ÿ^M5ӲlN1jZg"zh1&B3x3հԜ"4vSߧZlRNW7wKT /VMu_[HfRV'S.T텚pU+e8  LLڹdgﾷ0, ,TzmOXviXt#9[ #崧T*cF/Q[ƙ,#pn b=C|uv(5|&A"q4Dl[&}=-kauMȰ̠t J`)f%bX{¡ 9(tL2jrEXLu_XOQ(ߑ5ɘ9zȹ2FEnys~ա IZ;>_6푞"s.g *Wd]'DW۫Ej".0! i\gáÜNS+kA(ܬIP%g2TTh'jiB!d@yrS}k+mߓE u:eFmIDwQ8esB[]޵-6;Tq/N \0%:%+ sI/FP_z`ahr@9k.@gbD6rSQX|H(^1䪫>ʷiKWo|= .6myCts,4ti Ѹ?g-#A)8ZIWٚ/Hۻˆ)-twݱ$-!`uGFzh)Xn ,}ȏ^G ?2n0Nz5lњ%e Z]S81EUr%Dq&#nJ4z*PFܵASguU\tr5)||7R٭r/ƹ$# 8n*-qSGY? ]C ɉU;PH|  ) x#)@tޯ ~S$g0 %(vuVh}˄=պwILg L:Ѷ ?\{^Df!iy*t$*H hC%*  Қ|4/MZ<,j<<zw|{YY:诧r}/7(:LD@t>+ZkhSh}Xσ8 Z:8Cp[j: 4Y;g4L4D_ޚ2F,T{nRW*sGAh?Fqi_ 'Z:z1}z.,Xl]X=d#&]uPxGə5QKAiWIVzi閒-kk4V?W@+MT.5>$gRrdoaH1*1#|PhG墀8$@aT tƳgX8gW/0!hbڅl\Z>Mcٳ2Ff9_^F[ nmtjV f^ PZ զ& u%bEE<<4Tڄx=ȵ`c CljLZ/ GZ:W\Fmm*2ob ;lhkh&!Hݢx"k[=h zLvQCAϻUj% BE>}- SNRw!]w(2Z2+mG?G9Q鷗'yPP̜c7qQ+k.ݐW1Yɽw\%CT#x$Hvt~1 eBQ h0+A}eMZ|̺_mt-NQ0[c>駘p,QIZT bXme~iJƆ:_n.C_ZL2q8M ^ѧwN*)3)І(̌FC>uBHB1= %RzwC|}h-: i_:Ԏ@h8\<8%xL 9oR`]WP+6]J@N*^sz?p{ p-&J *`zQrZcox`qխ= O MEPw ٵdMOr`p``g}:Le@o2WFz`zq!Q֦׮?o&А1{(_֐PS?u&1O˝7RZ`QL=1ey8v|M RV; P=#DZD/ noW)a7I!X3$`9^!)+rwZچg8Jfqdn3- /7r",1s%(є)J=?b2b{ {;zY7@kK_*\RQ֑ǹt/!f(\Vaߑ]V%?,ƧZOstuMC/c؛JHۢt?K Cc$\n+X/;:$P2i & /v'-]Ec^|NKSFt?pi[ym%]휣y~0-m,|Wt-EH,{R7{Rg^)amzà^&^n.z.n̨"LdDu)VɪL?{Ĺ4?Z3_ j?Bg_S(]7ݎ¤Ǹ-ԿB -]OQu4V%JW{UJ0r,c e`2Y!v+Xh>epC;뉚~"UM3J1tsyQgAyk'IǫOQ?Nt tAnd.t*JP,T\98}ѯ7Rf^VzY|,ZNjqXo71AuEaf'4n<.M ?{á{3O',7Q7lpv• N#$]ѱYmk* දHAkP\R:gj)U7W‡'U<3""M؂KUsGp:)w8+:IJ P 9u qǗe9q`x˗?`A zmezx3Z+(zFmf SwBLIƨҳa6C DqMk)$Ww@,dMb#Qx,?]-Kp>53>E7))Pޒ KߺӸ!:wݥx\3CNoS? E{,٦(]Au#1b.[̨ľ0h3tr8\8/.'\F2SuT1oBR;Sn4ҁԚ791%r M'ߎMNendstream endobj 651 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 652 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 653 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 655 0 obj << /Filter /FlateDecode /Length 3844 >> 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* 4l6nY=,WoހF\{D/&HUxXW0wl5{jq8,#F7#_a}}aaMU7tUmWp]͞P5zo ;7,f{vy;$S鰸^]0Gp Vn 0C5@1 ^cbߤ |VPWMjl(ϫ5sy-:7fbXn/XsccgWtnrI~ߡ}£mm #97pkc`}1Ս%-9(2HጨTkeIh 0![ ,`֒wZѻ}XUiLVzDK4-X6޺p.C.a] {:H&uF〳ק=2(3`%DH> Et0p|Tq̺Uy!HpPw15y~ʂvLPe}dgb7T(įeA&l;.sNU,.'&w= SOY)2SkJA״xELO>LȇT뀳kniW ְd~ZZʟΣIqqF0P<p GϬ %$># 2f7U iT˷Qo#{& CaQ@F Mt2ZWQm]d%sX_ZEoGd%Z]iqOMaf08CXǪKPCPN֖ "4~ dM3G]X+C>(ɪ(lc*伸Xgu?^3r9i=N,+^e/-@,{|JcnEgAt0cT[OCvDI)`qBIQْ  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/'4endstream endobj 656 0 obj << /Filter /FlateDecode /Length 4055 >> 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 g\8 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珮rD;`"0y~A?{8wƋc,]_qOP+y.ܘz'wV-wZ/M$:!g_lbXÑ5$\XXcaOS\#.ًώrvke .p-!K|^"d/㻞vk-0U֝mm7ՏJN?'C+KH$?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^Xg(Ypb{֗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 Gbv7ZoI9+^gbǐC:36lGeY9:4ˍ:_N;;`1KD|=~TntZ>8)ӊNVtZYdU%R+*<%$jtQjUIU-'>t17/HgCHt^'Y s|BSFIIU0ϼdHfXb)#YR6Q0`v?޼|8=CKK !k= FdzLZS4 61si@/3xTpxt5ɚ?u%h8y dA4i@r"qPY$guRƫbM $g $.8+Rp۬R?Kn{qƉ']=.j=$V6y씊@,쫠1TI:-B(S *ꞅg.jp<Ȯb;USb{؋Ћ:)Z[1\ WAtkMhx'ZL4|A3b>YmBߕڡu>h4\Fh4\֖ HR)[Uuh@[{ Z^ l9>eL+>+*:^Q" R9[Ub3;>[N oRpn.e ( tZ회)ӊTYLA@*"cVj ٤&J/"]t5WDV%LZ}&}4>>`IkbIKϤ5Ϥ%gg:o>(+Ĕ4NpQ5I4i3󁎢cOl(!pћ32Kġ#(1 -́aW$IJDf4CkDŽ6lfI,f&x\9xU-kYt6`Su6Blx]%j 0*0T < | dۦ63Oo= 9E?<1gpp`HAR?"pzu6pvy0QZ*Sѹ(c70VA<_Ym'J̈́SB 7##^ #)"i$R~]pPw䟄y̏6ԻD,#u~dl=!6KHPǯo89\-U{t?4) Wmyqn?N!5pp{&_9Oׇ4-=x|T޽53a_WG3ԭ\07v.3yV՛5E kp* χCz;|\UC]y}q><Ͽ*cHH^/i#~"BZ]tqu6P$CPD %9gրs?|OR~ж>K0!9o2" >Z[]Nc^aaZOڦBin4-Js4͞3Tnvy%q.Ѥ:;}xOIP\QYyb{MOqxw YGR0DYnE1\]7 ҹn) 4}]JnN 1CN|'f9_xON|Y޾ʩ;2֜ HW3y[b\[Qeh#&'Xfv&^s,G;m:/})cqk!"G0-O!7S3gO2ʀpY؊k8K5!XLkK{~7iݥbM>r>/>Oetdf>2=Oyv)R얘#CbzS}+ưy9sqi U*E!T+e4dKV_?*?OݺBYjR0}2JACQJ9Kw瀛Hޗ Z"EWݠJ%}D~ &ݱe^Nl4,i lB & WH?E-I^qIl5ӹ &応zhpd/_pjRqˡ`% gfRh4p.y(.iAZa-CޘQcn'Gu|BZl==-+\*d 7u|M3|T,p5bI.0ٯ,+.n;L{q(#b9c0 'gE>y:ұ<.>nua NRùҳ=2ӂQ1r:lsJ 8"1<*LX$q| l/3UEŃ(dpBuQLzCEr_Q&y6J r&@ʷjuc1ź ]VcHK=v)mMYE,FQKD-ھ-hmgB_ve@hPWoiWTmo=Py 3;2*iH7ybt- e3D}ZIDP~^ڒcMZ+*zݮ~gr_ TfgjZɓaͲ~[!+g):BcoeH{z.M,}e4v9s|#Bj Mx{B!D)pZּ.6h㜊G [vvNVqRޠJzo{/ų~΃f~mLRzâsڨΏCK ~9A迗sO:]i[2!Cn$O1c=Jǯ] %*O6$!W 3}]O3:*3__dPYBoHopt_0.Йt{ʓۘdg,%jIFE*w/]BJZٗ>>SeeF HK@%xQ(MzOɞ:Vz>X_s]1Z fWWZWrP^lʌ0~o1b$žoKe 1w[TT~ SB3VZRkjZzu3y} `hKU~3YjjcO-cnP9tĠOAQ;xz7^ݲXٸ$z;@<\6f'g\Џ1jr8{|>FTEp2Won.?5]J˻35{9zxl_dCWֻ}W͑3\ێ8endstream endobj 658 0 obj << /Filter /FlateDecode /Length 3503 >> stream xZKs7WqţڪVCl@Ą IYRD&ZFWou{nL˷Uf[#45ogykM 65luPj(bv~q_)eŇy[@ |or]=o-`?SeM;<ګsV# rDd,a}3w v^ `ͧ)j=FyFikG?2Ws-ϱ?3ePwk2zXԦȦ(ҼLT9)DOd9_YW#zUWH[D^guY|Qgp_xGxHYô#0%\+S5 xG62n3WG+7usyrqPֿM|1𞮪EK_Jt8_im0\V:4{;ތ ^3V$= cOBo֓O¹z,3T{L!Zm$pcmQv\Z? =iC\t5Ϲo`av=5- M{ˡ|..v'(bqLNrK0,NW+me)]BzI~؆Y<\1tP/s) 8E}yǤ\ӣua<ٶ0y\>|Rj=r|d{3P~GQȠ\w3GaoZI/4^z[϶ݴ:Gm<6b[ s-)oҞ,!n"ȱ74L:N*@44 [chc6%c(Ewo)m r4=v\rDCM)v-bI LBQJ3;_>M'9q\Q4LE'n ON]@)›@\f r+Eݱ{gKWmFK|7#l63ʦ!j[IiLC+8 rܤ2a}@N8 hW,ތhyW CD]}(+o yon?~N Ƒ5M2\ *rReaht(ߝBWl=QO=>B?37Le7Ģ,D)9 SMJG+{LՏn.[t],y9*XHSUh-ݯUXkUQ{?ZlbsLXl:7@9 u;]L_YR>~ƻ|Z mc w d&CY>W\m^nOOM4RP;2B | T|(9:؀vhߖ$gmK;Z9"Zl0H mbDJWIr"s\( Sz(N"q`8Qr |)#t"&~tHmI~,ˡ ӓ\4'CB$6ֲ(D:0IY%|H5OsY 4J@(-AD m258vnK= `(8(++|HnМ!nu0pA"ceI p Z#,xH9"pp%",X0ї"? ' b?V[!-gLl+7,A,"¡`F+ϡ3$F A {9#[M!rdPG5QE!8 4)֥ơ* ,x[v /%viǃD0 |hg`HWaBf-$"9qUd^%-π%$" *KYޙY$m4{{O:AzƠhF.8;W<EDn9~-[0x_vv7IG@aR(KK'UH#i`p?|o(zUa!T-t-7k}}X6}^C7"W%-">wJЫcu'Cu_UXچz}whr;+8 2i\OjntSalAyj/vwc>"BofsbN#6]-yW8+-7#%ZQt~%D&I:L/mGe2`ti%fxկyz:k$eqȰZ ^t pAK[O}1K4 ^~!˅)催˴WY%)$hJ.sюhS < > 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*TI3fB7yy?g&0$LidWj'Ge N&Z8p#)BMn63[iu_aRh|OR&/%+|a y ϼ!1IX7h5@#Qp2dn(E&Z"<%⚘B5=;%2S} []Gf\;!83Ӭg; L9)jIiFc0=9]~#~.B.Ԇn&edp͘Fh Lefk21 rBpشnx֏.eCWKdIf1yTnw #ʌ EGǼC~FAQ9WN$&֏Zяٳ-7zTeUߒk>`/EqG4 $ok WC-{B\MD0(,R &r4W.ʸn}?fkb]Bz,Kyk!!rVtzqR /΢ǣ:e{ z.NVLF:8%C ;6^2MQk*QmGM/yNaE=L~-XbĮ:Ja"+8u03d.rQ殍ܨȦg=IJG`WC~W qӫa An@C XҘf )*a)ce|p.HB%XPUxA'_8$DU.Აtح{G*SV4=˧#e ג6l BÞDx&3YG\OfFPO#y)aj&*V8)E1]OUReq9t%/d΂,gYCԹ'mT'Ha7#s󙒅*J;AQOJ4q͝n260c>(|#H=Dhdݨ+\c^59Ҷ}ï7w;Lo25ch-<I4K-`ELŠCLG >5 S1D6aBdmyMj4)IpwX'BK41%RKn7[2)j("'a8 ` z0k{g9Q]nw 3Xrs2 MZktɩ Ҫ&*68}s\mbh `vyw|dhjDOHSL?i֌BH~=-H_>:fQz=='[ #*7߮J LFNы@-t=4 [.GXǮ&b]ɕzYH/N$EՈrI"`5I[ݲ1C\U :u/-h>2BTgu: \Ā>2ljUMs`\}e{f֙)Y|}m;;ooq"z.0=ڇ| "Ov&]dLvׇƼ$p}tTǫ닫z&: 9xLջ7Ϸg޹P;:9vrNL{8 ci`px=H}g_7z0<̡4.h xvc(TX\>t6W>(qe,u41 H=u" HűXv7`247g۹q>"davįwWRBx?ڊEɳߠ%JrKBYibSv`wO0'\l1ʇY%&='>gJ 6_nh9IԺqSeZi;UC)|~o^I;uܥǏ/ &.:[<}~:7)K 9msu^B&+%9k@lkcz?0qUC8- `b#Z&8oE 6ERdIOt0d@mB4xo^X\|\f҅RJDh깵W5gɢ>EBS+_R_aZHkkhe0}6A'Hp@!@N@^(9#0&v-MF8ퟢ#na Xg˖w4SrU|He,dY}H|QT|*B?/|g4~ .3W"x +҄oX:DŽk:GSfY8U%BgOB w Jj~6;Z>* QERVendstream endobj 660 0 obj << /Filter /FlateDecode /Length 3236 >> stream xko@W7Y4ZEZ((.tܝb;M;CrC.,-ڀ%~];ڞkeogg̿=]m;PԺαpiFV;{~={oVۇ/Yv9Aݗ߼];[V\|K=A*WpQ1 2gA'}N9 )q㭙\ndå n#>;guǚmIn!;j$k&4ᠭ4܀:CCsf\l^hkB&5h80JŒlG=+Oy9F No!A|PdMG=eLj$fx2!fse[0ؤ^x"! u}Blw$EZ-O0g(($xH Kt; e.x ~ůRpU1\6(昉V'  1jD˴-D Ѽ$O욜}uZVI( efe`h!cLH@*tLX)#3wxw*9EO~"&J,0ͺK$cG{7tcnm'ʄB\:L,d̙ҊN٬ݕWh(/LѮ&,1n |`{ s|lyKޗL[E"l!*l$"^$ MR'OXam-w}i˂+ D%xLpY3|c| R*pޱQrzĦv|n:TJ},L3}zʷR+w _sK̇>\a'Qi,LKOP 3[ErX\b 4z}nY(AwxhO$\Чe-n UڒQW~}) lIӺ6-.ДD 4K[Vzmfq{F8w\Fvt&SN-- fiHaw)?$fT&m@ո@r}|pfM?*e`}#EGdR&()C1k@ԘUoof)l·4ս4-vTxۀVʕ.74'}ɔ=֕wrϰU tMh:=/ 65SA:س/ Zw~Xt2*'ud<)arWg{'/@U'avV/@7'Y)U~J:RHjT{ `yGe,8pn*Χ7-+_b9'yp2/Z K^MXkxNi df08 Xz]GAZDz^-]+` |M!G'WhJs5ʎ~J~- .v ]яTnu޳u/AgqVendstream endobj 661 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 Kv7i5B;e9+@ jTQ٪d-Εu%m?<(5"U!#>yc\Od |OD4F{"~ 7uzQpPm͌c!\edO`|8Z!_]>4TYel/MG@6'ℙI@Ch] R14`LwFm97c%B)4$4t%Y=䩡ejaGZ_g+Cyl=& !K:;ფJ~("uDPvo^ u ):p+@/+=5:/tnBpmGS`U{_N |Oa Zi9U؍D: nՠ|u44IpR@\yI=4EmzҐ0E%tv'Q<'v!OBXN5h(ܞV `j8ՁFׂ1.~X'v4,衮6eD%z6xtB!1LMRڲ3ќ?xҤhl^j(^7#dB8AWr%‚ ;%$DZFeRwwZ` *OE,pg <ގrz3Mۓ`l)颬eTSe.;Ԓ݊jbȄH=97t;%` U: wܑZ$~'dW 8Uzww*48r` kGGF\yzyGD%\@ 샹mo=Ҩ?6$~~eixs*6A/Ha3XOH4C"az4bs`!M?PtE2sU8wX:~쏇o#n endstream endobj 662 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1590 >> 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 663 0 obj << /Filter /FlateDecode /Length 3938 >> stream x][s}ׯ[hK_:N2Nl+C([lE_߽ &OK$0k~^c$aR41D4sջ1SI39Øּn>6cbҜKO닼kl/{"$yj 2'+o^e};Lȸiƾ2ժz_*\W T_J0$HJ4 e7o܇V.^(CDJhyLbgWl%aBBy(cn]UHi喛4WKbj$aj1Bkܹ+O-j8}pgy:\z<0En0bLCx o >8G7rX3fUQdlwp3@qȭS;),Lɛm#n~G0 czuW}=n{TT 2zF")D7Wі@ڿHqiXqF" I>~d&(Z_Z5㼹qqG 5TH'}m fKaVךڵ4=*`ݪ`6a'ͻ}IC!EnRuߵHYry`J8%_.1J b R'EԈt}.1)S:yýBݸ(jJ0 `shϮumcPtAv:fלgKz'`Ynﲊ-*8\XUpVP= zHo^5ә߻."hI> ,@_=1I:ӯ)mWq+U_JraqraQqqU±*+ƊO r `!\P[4ؽ‚wǥtLJ,YBGYNRYa"È05E\k{{8,/۹Iedӷ'~9X& A"ͿaMh$6f)(]:gmJ8ua$e 8&UL`GO»+p!d7]Pw`v2$Fs f,]-ִ5If^@jX' SixKz?Z4)Ѯd,Uꁀ4‰Hg}~# , m֋OJJ߰(& Zl&K9bwٔH av &M=1 eǁC%ľExؑZ{gIo"W阁5E nIJP;F0$֞EXjYEcdi3<QIG`^ԝOKO<.}$K~FŗmYXt@ "B(-nX(H8O3V.rl~{d\)bLi5;euit.`!դ -DKЩ)"Qpu<\}ZUT]I( tIBsp`1\z&ʁ}G ),0gJ2a Rm!,h4} E7^ Ǝƭĸ^1;Sq- y]bKr)g|^zyKy 0&F*.͟ǜ9A*F;ݠ+*@.2V{CYE/,r\T9n2 0)^WRfqWzɈ XxJݳ_' Q="NؐIʴ,/s$,mR+,s2*O}%pZTs[/+h+ا(W &ssg I\HEfC;);eڽ¶`]^y4oBc* ulW4P T/uw*dB @-FuZG`&ȋDA"%"kGY;2 y=8pR#S7roV1n& JA4L7wI%^۝n @3_pf+-S U(0/ DכPegJ 2]'b@b #aSI}bj,lhzy|@ [IOE8X2e;\ cf eD`bba8c/&\yEx% HYvajF =9N$vNtDOT*JHs)t\gw'!FUHv>D}g/+a=A` 5WBJ=?Dn¢R+dSB`ŋ\a|*p#7vj8g;x@OԎXIb?ޡ!_b ECMb}'8KOW$N, T#R2.b|W.^SpAX0>%<}n694OSA'H}|h*3vTЫB֒r,㘱(ztVfi:&YVJ sh6}%YXp#<ɍܥ1"T?aw.Ec58zܪBH($Ƨ`}}Pc>h.\[&4<\jUK8GRJяKB; yd&pZh(Z.:} X.H?e8=gjr 2P[JWؚwYyc{Zb+PON~ 3I ՈAo~;93:Ȏ2N`v 49qF`KCP 04lʚZdSncBtiڡ7# X5Tbw[AJΨi^-Il̙GʟPfS$=Nx ~!is\$PU=s22CH6YbJ}7Հjq.VVΊ!օA.01*4Y%t`_yG&cC1^t\}?"MC̰F(俹W@@WwA" ez ͧv/dItL{VbMta4]Z#x붢'{,IZ[qS#CM.C79h- PX`q2\*~똸\c΍`< Ћendstream endobj 664 0 obj << /Filter /FlateDecode /Length 1633 >> 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 665 0 obj << /Filter /FlateDecode /Length 4486 >> 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{ReƇHM} lO4]K muSi;?S\^{re﷍tf:w7c}mv-&,+SMPauqS33˞QQq 3ut~J aKrmhjvZj| Y[^X;v[/]f7]_dcƎFF-Šoʹb>׽em[*USR~zXJg~*CMߍZsi%xS9v1Ce횵 kevc aĬuCxVEΌ,'9`c޻ ݹzAw~;HOVR^l $҅bS>נl>sd4F 2VU%{O6IBCjlA{{$^g]XRm]f܉}# oLI9 Ȇfk>t`&s|a~H|1oG]ooۏ%Tݾ=|Ϲ`Sow߾$nuz|OnL<M$F|x{yu=T|hI+O7ž{U' oR/e(B< X6 -xY Lۉ,*޽a<^'GQ<+~^֤~mSi_Fwe-i0z.mC&Md/,R?;QL_aΥ aE(^d' '\דY?՜C-G:6f$B$ɘvsb8ǁ N~4 6??q]ox1j&L4i"jW̹ onԁ 'IB|b= 6?1o:N-9`AQN9ΠӉϦFQ ؚrِN8W?Fendstream endobj 666 0 obj << /Filter /FlateDecode /Length 2619 >> stream x[[o~E^2 t("h qU@Y+B,Q_Crf3\J,z!}ƣ3`ßnHj!v3rbvxzvL{760_pf842иBD8\n އ[f@5?usF&> mknSoEsD\+Q戌m| KʼnI{2:c}6(\wi$.ݬ= >3ν6ť_$q.~^ˬ¼9-x9+IxCz9xm!=@hb9?&(&mAZ&_).0 9dqv˰ײd% ~2+TJ쀔NHـH.-g3' :645Uue%xǝE(%TFb]c>^(yfVb!{{`xKv+|@AD"vA kN*@:1x8ފrBofIiOcD㌑iLE h0E6mTǹ-`J|vR6+`S(ż]mKkwp;& l%¥襠=k,\^&]fЙ:atAj8 vr#,ab Gy[Yh~.=h \JHs5t L7B<;#(QbN>&K[G.5%"@_J`ҦyVp4O!Aa(hH# ATDJB@_3e=CmunOPa+|*v0 8tYcrW#ҋ0v@W=;F:i'Q uр7&m^w#+8 ρgME"^(hRB!Ye4bJNY&yH 9M*[ =11 R"m{,XL9Yyz[ٳ`2a۰Ũ2%Y7SJ9Vdzlx9FqŪowMӒEiF^ұRFK<1+y!/h\NJʽ*nLm=-@-ՖQ[1fiP-3tU/=Ɣ$U5ץDUAA%:  qer=Y8$$3[$wUo"j][.C˾RQw8mb>eu]Sۙ^/J Уox4NQVj⬳ny%0 ~SmԎ|_)QEa @Gs>+:r45jK6ZjM.KԲPgMKѷ-{%Dnr"Q!"KG)CO&q B sl;·=5o p/-DQz#/ghX=zPF&su&22 Lad kJ9,'=m5&%pAeee8۴ZL(ܛAK{u7 1%%GY/GAcLvH#j54j`񼼘i#EizҴzSsyvˍx)h24q8ۧnkNUcY4+''T?IoI&H<.i@ټDzP0(،+Uc._\{]Giv]0.Wɼ9tՕhq .*GB-mPRWvSv̔PxG_/HVISU?0#l4F3͘<}dn(8vS;Aw> J@ۋi;VIaAxS:fe@ L5 hY*EFJz*ke = rI eP~@E dzyJ!ln l̽QƇF#ӴֈaD<ȹH.ZV_kxV}5׬;RȜH<0c)Uj>\g_(.fv P%@AW'Žo;w3Fg)}Bsםa4$Ĕ0~JX0hLyπ^!/KXRF5 m!*:ШyJ?(8}8tSFߖNGQ-A=SE>TrL)JTEVU8TDt!@?aK(*n'΢NƆveV2)zn?c.F^|]e79Xw>9gg %5\݌$|xendstream endobj 667 0 obj << /Filter /FlateDecode /Length 3854 >> stream x[[oc~w#m9dE "}H"(<ؖvud[w3M> iC f}o>볟ϸ: ?n֓/`D+'ϭbrOLZ>4L.g?4_m+d[]\0ƅmNE7wZeUs> ksݬ3@f=znM5G8ƨt:kl! &+2&MӀrf7WnZj?l/~Fu[CRq1iGףm0gpZ`P6^8zD/ Ӽ"dL:7nLy6UȐs־Qo쀟?^LJ ],@`Wͧov?B:8s H琑 ?,p\)eF <-R`*-ޏ)d*sbONGE 6Nd7"2-sZKe2mdPHnMmo>Hi9JA²ws7AT"=*VxVq -o=Kޭ UI*B+ m,v x8puw0K:~G; =|Og-V?nŘ4t+؋luFj*\2o^|xx7*]0oW>fe(eQq dLy<&ϯ^i5loJvԛ̊} R*Un`eiGj;gΤh8\ͫ@Q;9gߒVzh_ܽ14k~X{(<[YJoÃxF ⏧E[ͫS@4CE=>K)t2akl0%K-@+^*O!l}4=y-A_nR&_]ᇆ;i$iE4;'v鿙J2Mv@f'#U~vϾc/ȸ8I".o=xb_7x7ml *_lP cbح8g[ R<_F5Q.P7E'~\3`ߥFžzm\%} znVAXBƀ¨A;p7P &,Kui>)ljT.2WOaEO|]f!nR@nnrF,"QDnTEL pI7yq,AϱTu=]}fxm[a(5k slZdst.}SIE4tVeďkOeYQJl]iA'9 ;=x~byGby]^l7XgM&z$`S! (B*4L65.\~VһTQ"At)'Paɱ>8 ENU~*atPIFěސi0QNrwWwuwiA%`$1SwY>Va˫Fnz+{ev3SM qD>WmÔ`uS dsV$eP1B(eňqWȋ2Z˚l~W;ߖ|*BV$) KƱd.UBMXqUs؊58ᔐ 77.e@> nݗ ‹Fn#vI+S׹G%DXS9kI>*GfsLS) jU^XŭA2*a6- >Ҩ&-s4Oۧ3~U^i;CʅR=Qͧ dz#7-7.?u/4@^>侯^nƕe6{[P̯I. Ӡ-Y9Zi9)܌=z":3d^d"` 9i/Ow"`8 J;ɷ(-wiWRRq7 d37څ4YZoIhM(pdyˤT'Lkg̍&o(~%;z|OfDg yA4| e8lkҦ-^[`єR^_ > k4 o$c1W˵w&꠹HOR+/&i 3SE1nXn`=SCʢaН}m5x/b6BP:1D"]ZOL{3oDiȐc 8V̼E+5:m _ERSݖǥ|$7{8}wZekQN.fDD)3.DH œG#y\osr0(ibuΈWV`ȗ$ [%)ZSI7 U, +AC;%&*JGX$eҴ #oHf `aV< f|AJ[O|%2a͂(\}:5dkn֤M0韓%UKe;Ǿ/4RS IAQ9|_{U-!!gA$07DRD5K2J35cFY[;~g{9zݣsoUktǓƩ2YNd2SdJ7k=cD|,-gi/CJV#gRͣ c 6}LfՕ֜ІTzC},W6c1l~4жЦ6@{;2EOyQA{_$o$P$#srR@Y6GBw#<C#UJ br,[|TfkYP(v/R'Ab\ N_ɧt/>?. S.8ed"1̐cc|J0QS%j6瘟) 5yT@z2?q?4HH97ZF: ]iOJH/&CR1p\ '}<{Cٛtxst ~7ʧуF?Qs]j9{YueGZB,^w9my{-4r QKtn Ucmʕ^j/* E=g>dSVr)sT05NfZ[+=Z)?Kendstream endobj 668 0 obj << /Filter /FlateDecode /Length 3725 >> stream xko#! d H4"_88tl*>I3|,\ξk{\r8 ǯg]f _m>^ᬛݜ>c,wVh1cJfJYX]l~n.kMd/4~u ||! o;&nҭR N熵 ٜ&+[kU2kYgW'^t5/SǼ͞o'!GbWkXw^%wj{4dуV+bW9ȃa'{r3TX0 4c2Z^47d=2,) ;# "-l| '^+52 @̌}fsz2H(\9-9%pXoQ2@ꛒ3(CF}dM <.I΀3 7dq):pFԐ9Qq4%0Ϡ53}zS+eAw+ g ֘Qk,VaI$#cM 2_l [Oa-h㇀g5BV34 .k f-Wiq}Pp1P "']О ˃IƝb|F/Ւ@<5E-Op?wS`QA 8vE ~?>{(~`QPR50Wݩi'`.'֏nZ~z^E j 赒C`b-$RJeM#Sp2ANư1`j$=G?g Qw~,/pbh3[o`CAlɬhW_-w^#b(#DDŽzk{pm+ P@ *b#T1(gX>ܩA`o|0Ɩ2|k# ǰ۳O,.1 TF_vwg;XoSd1İ\fmi%hKg: 'ɄFCRK8aS+ D  $yh 3A0LZs̑})у꭪WU۝KH/orbC*:(i&V7Krmv'\Ex !iJm]c%DKcݖBtHNT]dsudhf2U.%oSղ>%G-v)E a)J?4‡#"b @^7j1eK855w)Y* # :$Wl,q"*YFzS4!Sia^1vՠ'y*o|غ:7&nrժ|(eծ AG[ҽR[b~!:wLQEfNҾrpՇd*:&4rQ)w85 rv U 藛2j .B"n`۩@KhJ"Lg^cx|DuG{Ӟ"L^(Lă}Ej@G[<GC 3?@ѧj`#2o^J1d&YY*K\ 2 X=ݻ%G@6Fqzan8.zCO/bl0= *%`4+Xy멘 "/3C)CgߝNs_[neo~/~tL'(ؙ!F{8Ŗ,MkH|N!L'{Nhΰ?"OX;+PY.N*nc֐s; ( _XQw s"Z._^4OZ3)ԱB-d|WRgOdzB2ȡ_{zct d).k?T #r`]\,2 U̚6sNKQ3JcbQm[o&)2,:U)s*k>.<.N3i BMP}QMoФN6ymlh(CRO<<;YZ.!;r1(;gp5Xُw=1>/O!4+( jXb˟sOeRmUq *zx{n Cn点"#(3#Yӄd#nxِqG/m(cB;OY胹M:b AosX$&8/^z,=oc5m֖V(KVtѱDZg7ɽtuΜKtp -x??NJ#M"oAT)%G2 ߓdi_ )Mz*]T@:Q0w#2i I,nOa (R%74rSھV z!Qډ{t ŕB9=Jc(DsI'qe`|bܞqM{Гx r%s +o. =1S;:?=u(EAyO/oȆ_#:Ss^Ήdk^s%̝Dg<]>akx>t]~>aF `FY dR'(8>񶼸8IiH쯻Q}pP7JR tP(a`}HO&+$o P!Ke@Ν0-j!v[Nn{竦%Gi:^3𝪊Mߴql0ZϑFظ2V* 2b? UqIߝBJendstream endobj 669 0 obj << /Filter /FlateDecode /Length 4049 >> stream x[Ko#+}(&~CA[HV#h!zT rvs%g3ҿh7;^ŏ<:K,w`y>s9mvTnn皧f3={ڞ.u .[]757}^oYwo֧ͩo_<6!,fcwݛxnnf>62s9=v~}$}3[@=D*-g x!^:Y_.-U.V0Нo€A-'|jW^5̸2V_ cvGQ~{ۑq'gZ7['ᰌ"YǘI2p3év6<)hLْχz ?kRS5F,n[\.q{<ᑏd69=m|XB^0X997 !SR\|!k|Kc"h?^]"by-pLjgƁXBOjqm? ҵ4 ^ ?hzhճ-soE{pWj}jHK/agv2(\VKp;)ᛎDyϭOG4 0DҠ%TB|lcMܘ1s:҆ 1H&  4H$ i1msA v"_ i|GI' M%L Jwc `oCcgkWs!;@ '2]>ᮒ  :c D/䛬΢H,SZ@#X bB$E젔1XکaZmVݩ+jUa>)ۋY*R.GqiWbfm3xDW(rQ#aʣPfic0^ YHb]iu2⭅$W1t}ҷL_ ~$vC2zjdNw\dUtpC2 :P+<W]\hIUZZ.^WB6De*&S3-]uu>i+3_,60bUJF4'-9@r(1D%pp@zQѢ$hQMJATb" IHWNg WA*Y3oZ6d7p}=Lz# JP:hD-6 5A,8nE 0rl^VK>$lPa&G-% 5Q䔪< P<:?*4bt˭IQeR+vG&,}aXľSr(U72y72 ]"6@//.ad>!:JȾ6'HfD=cI rGY(QTXG?Uiԝ{ȉк8mm*.UQ1gAFҭdGoy^I>û@y`r],w!K)vK(ïSbf$% RɊIl k[(܇8le, GVQ '_z`X.΄7KzTJ*BXĭ0Q!z~&U8 nn r50sJY7 E:_ϼ)Z|4RL*&="PpGN&nʒPEA_tujbFf#SFT,[`Uvu8yR'} ǡ/YHEY}w]~N~yخ3icu\6awwLȆ{^.0u<InxOn>u\ޮãЁ٭o`Kߙ"?Vn՟. \9wsl.fٜ97Idm7oPgʣ[ %zϋg!qvyٯ*= DM(iBV6|l5qjBz̋q,,oW1SAv*ncWN̻ ?8G ~O᭳>&,p[~XIjle{+lnXUx5mS؇Y{7mP Jp@m@8+mQ-v__&ղZXFA1l Qt#$Ń 6x\vpqCB̘ߐCNi{&98Ew(pÑ8sVx 2gxglT T%SRK7_o;AjYz*#@x4 {[(э R'?FIv̫A!̍x`$h@RXsG*LO JYIuMrb WDN{|bkh0 X]Ŝ1#sEOFj}CEȧ bnk)s*L$ic\e*̼fNY5Fq{!iuYA%/gIgy5< wAfTum>8}-ɘuT|ԁvT=9C͇OR[fuL=lbȖ,t4&ɎKM9t=QoK}eӛ^CfJ:2fˁ})R5ug2KցجJHgyTܱ~{n${7 Q=ichY?UpΟ1W()*\aTP{3 Sn@zc~APU X`8H)=NIH*^6fAhħhL;X

> 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 <|]!uoT m_F K6~VT_͌ s^}}O1vχ~t%a.t4Lyty`dk Vwq.p@?u^7;ɮqޯt@A׉As]dpfn3ޞ΅KgX7 h}f)8hWnC]Ks\Mklp԰,k Xt1ҾGw5uײ7fS`W9lҞJ1eptK6bSG8wv ͠i*^X5@ ױݸ}xsR\(zDW(`tuVG ~ Uwm1Jɰusnu6Sջ~C؎?d\nz~O06@sendstream endobj 671 0 obj << /Filter /FlateDecode /Length 2930 >> 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 9aM[3m8ֻL`چ[H̅pz}4ϊ?ɩTf 4$6+j9 ۥEeoۧUVf q\'8g澸E-q[f5IJUcoC(vnaz57o*ͲY`F鶰M˩21ejʋi1jʊ)SVRDk_A;*ø02c|Ѳ@ܷy4ցg@ÒbvoAn.:gnY^A^DA3ᬊ]"*#sw q۵> 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ɦ[ usnڰ5hzuEsUq N?h6cLY"`Dswf3m~<Yjǧxf7<;g 3of[I|98%1)N);HPd0u:H"u@3ˊԁAIyan54=*ddR/L?4HbQcxHs'TdP =lБBX*bh+NȝV*b՚*::zYJ^꿄qkt*,iN~:֧{HC2rhRb¶w#,mhWet+a2ۏw^YZ6CdЇ3lXxF%Bk3BY71b s$9Q1 ʘU7!4 όSPρzaNrXj7!EC]mnE` /iJf\<)刡 aH/>Fh&H@2!#$9H!f6c,e(h-z?*9YCNH8j(s.EJpJHjzIzZ0G4t?Pno02F2X3B”tD%#,DYJ: T' .Pju@YL%P^m` ݏہ.G-Z >ŗ\KLȼ>K)Zlooi_O=`#-D]G㡁)tR2ۯ~#>,Fnn? '3NW7dP{r\w~}~D1aoeSA+Gã}UL> h5λq_q잵l ۧK?ZZa+f\jUEkWӇu3Pouu':y'Օp9mg7i3IfKlm0MQY ` dZug[8,R(V~#U}bUWF:XV ~ np\diۼ"Z͊T}䆬XHn=醬X䶭` 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 DZqR ʩ-5&t \pl HH>Oӑ(Vt_ Ela؎'Yb%M 4h zioyeڙfk@ 5䷦6|^9P5LGɳ$c6Cs >Ltxu"c$ɯjz"bc=t6qҳ՝%937t?ӯ\ N)$w{zcL%tra<#EtnPX{uյ?G?`Vj}М֡ tbv(`5НBwVWR J;)t o"=oн7 5mG5X}}>;ڶ?uFbLz)HHXК0l*-.#vn&72fu1ؑ/]v J`ZS=Yd-S r\z/<2t f/:2iA :#u]cuƣ"v[W\G<86o8SL^VVǂq{̡I,2ٻ>o:>퉏3CsCrh}nMoݣuSKJ>3hԟ}}/)* Qi;5jbu!YuǼKͶɻendstream endobj 673 0 obj << /Filter /FlateDecode /Length 4343 >> stream xn_YvzH$H6QdPhe.%9F{={fܯws9߫^k7>znyku39@9Z,ns[&=[[fsbZY/p\aL:eqTƵ{U6wv!tkM͛R>(Tܑ^si ~pg񱃣{viavMh^F[|j @9k|'6&p"R< 2jupI a[ťFuT;JBzP5M/Y1!o/B哚@2:%Y H 0T `7Ҡy;L)P5Wn ךc qFU[t da=4@}!Kx@AAB)JFgjpx F;\[1GErimXHP!co &ɽ -hYOv$5 Kҫphy>a+Kpi4rnא"RT/o3Nv](3[<)UbqM ]#`nĿvu^x\f~7klgU8ns?hɠes?K/@7vz6~9J@]S۫LM]~l<;/1r#@";vz{qa=^XiX2w;zƃr18_gasl,)3V ߦ`{EHwԪavb9.ӂlbC_Uǫ.d!'07wsBs+A_@X/2-p_*iMUtk ~O YX2ƹ3:d2 G^m%+,:*a2P6Hꯏ׉%Oe 걎)ْ\\TC60y H!}eUQJG54uѩC]]Oeɇ3oG% a>07nBzߓ@>h|VCM}HNtؐ#M7]/1(A[!*C s?Β3  My=! H6w l!UkO>e2EȬz^6VGU=  0pFBy8|"ϦBB ٕRU O 8 ]~愍?M`}t}_8T|f!N|ʡ6̠J؏iQaCTqd8z*jWvFXpю=Xp pC ,*҉6T>w) pQg4fALtކa}:-=[T,L9 Mc릎uc˨~AO#<Ä R,ZT2!#xIjX-+G3mn랄=>6!b1/Ux/h>/Wwy '}vgchHmgwW个nSqי[NF#n&Wy`h}22O9!rIU(Li=p(8 _w)PΐtY+~/kQ)L*:cdOӖF24ĕ`;B BQ.t1F$⊨+m:AkF]O])aZT<[yJcŤ렾JM9 ZGwlBGPJחE䓾w׃Q(k:QMDqUQ g.| I2Hx4m#.@* Hx!NJ{ hR%FHU҉fS3pQ(fAS@JŘdtr1L'O)@ 2e)L}rlѶ4b? ?Zh̀s$kZ(vG;ǩyvU)Hj7l)ᵔ[!=@xT :_fEAБQw>NFo)漚h`?w(s)2LyML9h1h`F'CzYlj^:m$a=\&|kjd"Lq*06iFƵ!؂' Ѓypͥ-DrW/ 8̖+^sBW.q]Pi`?P'<^?"H.`$u_~W6JGP4O˝O]ϥz]#C?]L3<ԃty^6/0?g~j54ۀk{sav= 6ϝ99JMxƙn&3Bfog?oAT?쾅i=2?j$ona7q([c\(UI ZW(TD9RiV&ʥhs8~~u6^ eaYz)qTuz. 5֭cyE(HkB<-X\L{7 >@I\hl<ěοowxsbHfmeN7o6 nh'z}RMs0tgf=8<ѭP(%8C W (%]> stream x[Yo~_Kw c1$%KfHAٞ/[6-??hٰ n_Wǰ-Zl_m|Ĥ[d6?^h'xo]G{ao~1` qڏ3GHpo31wz:grd1a-y~?U{ܶYǀHgw(,^ Ip;>Ư3)y>:O=ө)91x>Kš.ފ;Pץ.{3K.@*)odݒwFG@ زZLL3WtFv8쩬ܝ'X‹x{$R>^/CWEsNMHSRœCuEIߴPNZ@&A7t%H}βIub`hrLe'׀Q(/IJU14tjƹ``fp@Φ7r$%[,afӞpcmKf5/r1NLG*7Dz 2HQ `M l%K?8[mWlHi~=Ҩҵ Pσ.xGiZ#&o͓)<:i@v5ԅKOTr:EFONaoGg=pwDnZ,7yjHVuyz`S2_ _˘!2tKJyN':o~M 1QK&-񁐕R.\ fP#4\b횘hܡag *MŽ .`l6-2񁣛 "fZssO9֢ "Vԏ`ZJ~OlvY.fxvHP ۉ?+<ƄAL(:i$!7;-lEZ~GXw,;EMޓ/ 0~MK!}KeG]qmA&A4_bUO ܑ/֙v$q3<ɣz4HtߒKgEO; bR̔QV+Խ%keHVAtP`Yp6UP {m-}bs}6jnIkR K? 2Qcிj. ȑ|`x:Ʒך,`6 U\g+HtmO8Em!!l"Rs|S36 LuE&|a TQJA 8=rMS9$塋>DΌ־T$6A*wH F)N֋^zy@큅D+&Ҋ!Ekq7<,!|Ȱgb)j -96\(XKjHROaI_lZpAGL;é=Kq TE2 +xw3F <&"cIeU˙.l-5<_-9zsĜhԨ&cr[ J ^j;XZ2tKp$GKU!'1@"hb"}a 18IVMsy J)G6>N!^QrX/m]Azf&$(8,K$QÜhVnd (jpu6}-"q |[rZJƮPFw0H-(u_ =Ɋα)Uf73Gj2f.-eĀڶZJ,@f=:W Ҥ;R# p:φf0b ,*@V$E+CMLIlERڔj#8@r>D p+P Np7'Y1MqaMI.VLW5ޘB#:ȶhU}hl{9  Xą2j˭@4$l,){ `~3/kMJבdžEuZ&R ʃu=Rw ۑR+Ϳ xb#!o0V[m0x <GC $3 DŽy9̦ hl&& )Sڗp q|9R0n@gBfD-4dc9Gfh=6N1{C:[Sۼ"uZ$kb LI&V`+i&V|I|bpogW;FQP@=D#o`P7?iE<58iML"|iX<rZڵn j7dk6gۆn2''ggꇦc9Ls?t1qk?*OeI^#'ɮ-n ==*%YB>3#XPmIzjËuV9yl4GJU-?Gd?̆VK&- NʶӰRrdU/8ŁA ٍ*D_)K͗:6y%qj~`-[BP3Qj梦%e9!t7#.&a#@5C *).8xn00PSM݈8]8on1$z䪅yn[Q,H_^١IMJ}l ;7Fɠ3G@ @QU*WcZFkkZb4D7?9x[ ` 5 KXMYn~yثn_(#dPCфרwOB3gVz$A;{蹻Voi=zG3?K3s3bn2%XX< Em8\Vw!@ϡ.o1 Az_:|y<3/ƉVFׂy3ٟ#O DpL#Q.|s9F%iOiKӴ-UQx#nfb;ȉEvQEHG^L}iHԴiV^}nEeEV&-ߥY9#)|V.yOL'~ʨaG'Y4ʁU{q1US BKendstream endobj 675 0 obj << /Filter /FlateDecode /Length 4881 >> stream x\YǑ~14iw6 IA& rfH98(;"0<"3ic'{q{^=ݫNxu90z"V'+90jv'?B/rznd`VK Zx-³tk|֌J{!;@Yu~w6td VIa"y~}z&pI#} cҙ#V#c[DG'#eUN0ʰD"ckfr/3]$)50]/ԗ%cy<nfow&Q,2L_[^1.zB<Ƶ78=tpZZWyt^WMn~uBni( ;+;jQҋ{oNJbé0J;@D9^jŁ$Iuj^;N?L/AsvHu(|N)WwK-aP(QecnZrKbseu47n $:4p͹C[ܦsIjzyZ=Fe(9CIx`eէu\rmG(QFIYyD{Qv錳ҙ/;lwؙíysT+"Uo'mKΓpywݕYerx0.YqhΣ֣>?l衾 &##q֝Uj3TJ5pd8eE5E2/…:׍uzἨ^~@QCxM46MZHte.˭7DOӂ byjfk3):^|u?#1ۖ郲s-ʊt'W""8*–#|Gk鐱C3`2L.RK$pDJ%}!xD.-GAO!*$rgIҜu]W^ wd QJ )se%~I_<~XtaP m5Qk 0k< JY8O9{M0'vL)j@>TйlUgXhUq\%ѝ =Ɖ9܆1&Kv8wG@"Nx5ޘ#Խ0e8;Kn- 8 HTp]{,cH ةUu\b6"ȮGأMROgS_%#5yoMQ& !58#1-ד"F%XmE;@9# ǰېINYJ`/pXۆx7UTfI :Nh׋j1B8i[E)IF254JZY&7'xDA(kbh*]sӷO=` ʠLӆn3DFD7*u@ziWA*깇vIS( Xؚړv/W\>~ĥ9Bo7poy {p~,jkh+`LBEh8 9ofgaR\ Nl d1{m:x4&txAUAgf;udž o11[x&^tthAk. Fj,h|`69QarTrxTGEAƱT$ cjKJ盵ݚY9<٭W" ̝t8:+.);\bAW;7 *\;jeHTa=ȯa=AͣeQ*΂c[.P3dؗnN B ]rF1CxRI:sa-fn3adߟʦ5)qgH T&:dy]QCEW%=Ӕ,[$P9bc{%D.$,ʨ(b!?FH"R~Jrh P)' x|MjS-K}ߴ;AJj9i|2oh_m's]\e#]a~,-!swVOj0w \ŪRe0s_MΤsϔƌq7YxRw{0az~*̃QHf(p\|UgS]Z9 *v ;;9@jϭ)7F:>hƖ = ͈"L1" b6G;ScO5@w,jQH@mp$n&_>!^D4IHW\ <8UAax鏣cuzu ;`\I\Q[U5hS=&EM ҝD*bDZ6"t@:.!ɢ{LuXv)d !nyD'47E\ v0f3/H+B9kEdhRӖ| yVbMw4; Ҹ)q%cWMno |B݇1F\0u̥6sHK@Na(cF\0=LcO1\q@e=4zZm}vy'ZZ0wǴIbڿ`N#@V P(uG缢! f'Uq s55ttf~R23G=rlii~̛lzu4,l'ہI3hI'Z2/~s%+Q!gQ!#yk:Nc6Ժ:Rسa(;e`|+M+Y Ҝ3QH +f5y,+ Grqr-g-ԙO. EVF4KhyA/+%@tuY@ly Ves8P {;4|!)#p]."sܾ~Ȍ۵$NtP gi><xL %v6 0Q$vM.RrۏVp!~(&&}•ae'MĞ;zT ?  mNh:!?[(v1ɑV3ެ˼`n3WD1L~刕WX7!cRG!h7sZ|(/Z.SD^XD=e(ܸ6a pK ٱفITsˊ \$v0L 'qRxY֥M?ny`'ŀz19JN I~Ӡ^,U):"3&כDɮfj 1 _jnxrBXVZO\h FZ-`])4 ,VO,~nIx'ipP, w!Giũ!M4R /0Bɯm. h|byj'uAh)B!F6 Xr!Y5aQ[ee UO7t{L(=UlhAFhG\>shۄC 73M\7mnA zI0u2H cZN6 uq*ZE/,i5t._T&i@,z!?Ю{Dkj-5Fj{J `x18Ivв` xD^!9 mx#*z3@Ź'$S[FJti3aŢ 2rrx[i}|m8XHQf쇥tnwR5DU&4}\EOkpiMbq۫}+dktۛ}ynj $On*nVC!P5ݼ)dg?pOAj634_A`uTlvM;oq7-S׻jP|xsEyЮsBf^U\൶RͅF8 N2#g]]0}ʣ@#ZHⅻ\WqfE؄䄓JUB.c % h$b}Bnyl?^2W7N@+1h9Nw ^5dP(WEwBjsM5Xge15u;>%?y+(DBMj%n^ CH^2V _S%Q[{W]9hJƴ)OVml={fDtFqXr?o$,SR~LoIp&/3~v˛XoD/7Y=`WLT| Mvw/V *%+/P LKFʔMLG,S*ȕ. ^ojtkt]YޱqZ[ Xl:Quw'u>endstream endobj 676 0 obj << /Filter /FlateDecode /Length 4908 >> stream x\oGr+#  $",}g_󑒵ᰟU|"y"_o8z I==9pDEN߼H]IQx+틿XL!ž陔.1Fⳇ.Yh>~|߬қÏymz/҇3aB<8%=MTp[D%ZKj1Nē{q4(<%,3;L6p0Kp8ektOZJ*3wfCgc5ƙ?E".9` `m ,WS4D~vY|>*_m`kxÀ(c` P ڞ)h;!/I3TbSlh9Em}*h./3$-erZ0/}i%U]F|d7'p#1etSF*!Y|D b7N\Vm-vRket|@w5M &>@>k)cਓʏYӈHPu}F .@={`Cétغ( |S(8NdX~&`'Q1gJYP¢pyw@?u=+x`6bXghrq Y8!Mz4B(A.[;| ǧ}PxjUç߱}aٜ/l>b˺k/D*Sp@OzЌS&J"޹EշU%&_؋R̗s6r2:̈́o<j]'z})Oy[3ڛ u'2\XTSa:tDӂ/_M_lM3XhPH`D鵃rm]S}(۰>B=אzZ@bcd =,P;V3`Voa"Zj %1R{ڢSdZT\[*ixt?n?X1iw4:wx< ]%9oV<;@cOoٌ"hU5dYBoA BH!Rp]D5؁D#B8JWy4zy/8\1#6a;Ijͧ5fpJO0AB^M{R,ڭ=Ë> :?MM+1Fj*`q뮙㄁Z04j՚,2'#J~lwƯKPzy@mDE?α Z[|0װ:#/xײڀ$,W^s+/oaD:#t4[M KGrptV܈8{MuMhf:qi!Gi"o]JGTg G(AK+:IŌ?>(MbHтa+y 2I퐁SuRSc[V;l1𨆺`Ck8(IeuimBx_^#^JAє| %Mxf\J+6IڪWCm˄j+-S3#-fخ? ՝FY&UISYد{!~$SJڑcfS97oOQs  (f3$WߦS={ RÖ0H+Y2ߵcIjGh=&'킩1?#:'ړ^}a=U'gVr`(DN*kBCaOKi3N- Ln'Nre{l;"*fRM RmȲP{f].ڱͯ6Pf5S0m\0 \ՂLi˝7QkW!2/rsJ[t`:J*U.3z]0b` C>C>uΕm`BuswQ{^Zy C,,hGKb߇Ѯ|XjV|sX<cVZOm2#6+a!U;r>aAXp#–'k.S$#wDʈTПrĨRԜ#T ͫu48BOomC15gLCT\"It#8(h|icDcgq2=0UOCX8F,?,gw׬O׈~K Zz߬,8&o-ˑQVW`+Iێv ! y$z{)(tdю?f7RwCqx 3O=ٸ(% 'Iڧ.O qq\W0(㕷e+c,9ގ<7r{>D;Ia7bth L 3hDeMg=Dok?MCWhԟEOJ>`֞d0oB5b͜Оɩrl)}Alo,/рt u,u1JW?jd4ٛB6BARD7N :ʦӶhY6 .b;Ҹjgg;·*,۠g 2= ~3o j<XGZ*WSOTCcw c$]w*w$?j=G$ FO) r"d!\qUƫ JȺ/u𵐿C.w;T^Bpq4|KVU2'et[kJ`xB83?B!^Ul9Yp R[(USF`jXUp%y؃6WѤ_YRScJX˸8Li/]~-r2߃KjwbVn4j!"#oX9FJ(?pKRؗqLM,! G%(x͒`87G4՝]#]ARc F*T ('+v0rD3o΋\RqD85{e2Sn2Upr$] VMI7ͦ 55rxɗv8bEg*RuN d+L QB6=r|w1V۲[Ǯ{}B4]1nɀh-I7_eR< Iɪ*l`Do `CzWN5!ih<6Ii {nTiA 5o ?A:I̍χ8O~2o7/pޯ&YyʏFjZr$Ը~*j;>'eQ5n@bhokׂ8[xK F"uye|P#p`\QEje^$%!"ZkT2'eTt( 8)]DuͼeH^W},az,CH1e{WGUL`NOo&;rj%7PkE ǨˆU26i;>8:SL-pwIm+Nc.TL OhpTQ$*Lm;k>?@3tB?|ϔ-<Ɇ6XCF"ij6 =I6'}`TYiXҕqu'v ,WꧼbZg'YJ]itD8˟3ֱ^uÌi (m \v;CU}"~zWs5|KSdu_ 8\_N "Bݤ>Jxf-12-WPSvC՟R)/4c#vXY`~GJ-Kݏ'摋gCmf 93d[`3=*7YʶQT1F&:뉸ABr)D.=U O,k=jz_s(0^^*}ԋ4~ܔդV yaξ> ɧmsic!諾;hP182k{YJ8UtʙG'™VȽl/Mg8׮pT ޣUrKz55d=֡Y?)N*Js9CbFYy:ENYG.S%YmصZ^~o8;LBϿ@ު=ϩh]I߇%};d;ˍ3%fovU8H)`6k['@zHB pfy*(ޒ.Mvb5:f/,m,zeGU>l>tOi?%gY2d4;e֧endstream endobj 677 0 obj << /Filter /FlateDecode /Length 6061 >> stream x\[oy}g /1_ l1+?PPwHJH/9_]!)iذ,VnZ\ oaQbe3ݑU~|N]vGG?n~HH~82IuNO)ddmD̝\Sk蝔 frXq|IX2!*]|+tTQOtXU nur}ZlMf~mh^Kj2PoeʢqUf~}g!3"y8/@ɊFNʇ>^ޭn/Vۻͱ}~ ^Ĩ9J: /'jLu-C/#za2*-aL/ -Gb:czpƥbX]m T{aI9S[ jI-W'G~zaZ?:fԕAa>b5fu]8)W0 Ո 8h5*bY ȔH!1%J=70%̩b`xi7 O|TyN5xn5`i' %Z'FdXxA[P@M^q!€a-d@$hF-Eq ia1€L=NqbbVuD VP1'luS,7r30!Kx,S 8l%py8sE9pCU6<`p! -njxS[~ ZeaC:QlxP8!ҊY1@툴1Hq,..Aْr|]!AcFDųI +I1~')BjZΦzj=[ i0{7`_@x1P—^]ٹ•D M<瞔@d׬w<̢jRl)-/]ldzd㰚b[WcNcS^R{!0([&֤ q[]ߞowo6#?Wh}m˓?ޞެno//6by t`N[/!y(;AՉwO &s+>:G*zC74Z4/k m@$ WY DXH\F9Jʐ<;V-3eB ĕs¸&7&5*zF=n&j.MN\h4z1ijDŤ&M^\h4z}45hIq7K m!5iB#L1iBS6U/itmP∜k"L0*P: zM"ơEI&Nd6]0Tĉθ8(DC N44:QDE&OT0MhlD#K'Y@O(>MhliEcK(:>UTF(ΖP44)-EtEI *Q44ѥI &Q48D`@hEkQ4f4QiMhh"E#MhMhh"Es$Mh͓4)["(1D*-H WM=H55W+B8[M !$y= !fT5XF4G6 ! ctq lꮖ <֌{U3$OT!`cyUfo@e4j=(CZ gp 3dx?/X\쀁arb0aW! #8*T'0c&d8 jz;#gXKe8P̠ p;ՄXr4x`ga00n,tܷb0 phA<lŅLsًؑ~فUTo" ݍ&T_Z%z]H^aXKL- Uc rzɍ%`scrP& 䐙ORТgScEvݿDCj/8U jEb5sBѿx\yܿXm^*ې6bx2 C=߲{>H,ym.;5`ce։z`ӇN\irB_'DUZ4/o?Oti{<,!` Quu?dF#^Q;y~euxx?҅06[%8t1l961#ÛnX[jy^}G74&{ws[U!n%2Hzt$Br}{twu~pu{3m v!&iG0Y}\v}(=Rz[CCʻ<GrϜ=kDg`l󿙟aD#eʀj'az۝iiJ[MK0܂A]#α{nNE>*'Oi$;iӒ=,oe]|444Jf6[9eu h>0}gBy<[s@)b8P^;ϣ<-%D!"&@|Zw6<;3Ys"O6 ʽ Fʦ(o[ɤ\Y4"5li_σ5H*hqe@l|B˃s#rh0-$ZJ8σb"k*DnOz/mk,lra<74͚89ӑ yr ke]U_E&h7?{^}0 ,}uԬ&r_ϗjy630J2el =yvJ8T!ձ/m񥪄INmCRdYIvr.|"{eEwJ՝D0oC"׏쇌u$Н'(Hj&&yO(SmcF^KYHm3a+]sIi3򅆷p*k)aZptgUpJFy0ϲ+嵺d&L日AOɆT"4i*D,zH> K[}tO(ޅTpk\QUŶBZȭ$r!*?U52ʾPvn ۺ,;EA;{VWe\Kr }EI Ld*%}"kb&"I <+}~ ].ʤ5Trqy?%_`RzQ*ZMs=`hVivc}VYR<{(?yAB>ms|{o[c)?a_ }*ҥL 2swn2]\k}JpEŻvq>`k_? +iܗ@b_x*8M˖hJF:4o&> RtLa%S}ED:|%ٲnwW x$sѧ/EІ(b%Kendstream endobj 678 0 obj << /Filter /FlateDecode /Length 5450 >> stream x\[or~ "/g_as@p rp64xfvȏOUunX8;nڈN67?pZוMssh j8HiTsuJMel'tױF7WZވbh{ nz# ׵*N^ThBZNhoCڵT5HplRy`CYymoXt0Hc8e]su xUVJ&v)Gt0m)aiHpHEkۍRs59R?R&883 c&R={^co)U>ù9<(=:Y5>!(1ق#`! ʫ_`)NO5!,n+;Fx6ڢ=c2vtv`qk|X7vB7 ڇڨImJk D)eFU Y[r^z(CPfa|S)^&i^_Vw2XU|#8AY؝j\U9dUOB@b)Psݾ_oTԺ 4ـ)0ljxgfJpk փYsg+^dď|4 |1Պx[͛ %c$+NX'GQ~vԤ{&gB  Wg┴Yr<D{ɮQRP ?{߳-7qƤa8VJ /&Nx8f02 Ct+p(49rE9T,{pa nz~aϻYb s @y@cA519n3./+G& <j8wcr|x%"6ccUPo "i?-J0ZMt`$9b9(5.kH"NTF" g fȬȹtA8a>ZU} 㦹jZ`C~ƄQ]]h#3(n)#܌[jbkrFf_I{4ҠQF[@8}FAMKÌ p}p/\enk81$&,~Y$ZM` ® ]ы38jHK2 I`=w?m Op!sFRda-Հ3K\"AM|7V}bmϓՃņz%H0`IK*JpGĀ =rfHxNRֵZ(½fJl[^tVU?_BaEQg0W!4 ,,m((\×՝w3mEk}3L;ש/G$8GfJۉ@?~<9@ p܈pυn]c|٠I~8/ Coin }!oh)5"CMuQT{Im.23LLLbS_dZ&pICeRO7O\ۮKȤOԣx9 4f6|&g f @j=IOro^9g;kGU؆o}kBpbusF8kTx˫`lr'f1z0l64uڕ}eK/20nƹ9آ1K)@YL:ll̜wnΗ2 *g׃ڬjrIXiᷟINۆo9仴!T=>#ajj_k>X;Y`L?Oڇ)g"EI|1'm8P\JfYs+HD8pJMM352G1!}0O \22 ~d䅱$&`' Οe$~a(g˦̹*.I9Bpj2Vj!Xe)\ZxiYAӝסC` 9[_X|$="ѭ)m15ē'dLۖV5"#c?lf6JqȽ(Cis)8% V.3Ʌ}K|S 0a ]xM40=+{b|_y6$;/T:A4sXXB0vaXI3Vdj"vPL`pYe!+빀j6]wjNYeZ >1.SR~Ar*$J3w9 i,Hr"=wLE,=[[0Gmڡ؉ Lf)(p?-Hhc~KeWzN̗tJ)ӦQJ/=F:C~ p;cʙD"=MXAMv*W^™$0BQ9Г¬3دW)PGd(J4?$ ^lqJwJ}Dd4jQ/+)-,0JؔJX>Kq on6xH3xylDR8ҮK<^̴@dK AIn4)^Цx} (|O;χyR^v*4\Zpxs$л:yVGJ Uu^hN.u<{V%f5U^ :R $ ՁP؂ ?ƒC-& ͫ) Yi~˪+yN xPY`u1,-e{`H pJ(*)xKuimeDfaI@ô_ǎ (ؑbW'+x%iQ l Jl\>`U8~TK=Ze?I"&쩁 Vz WyF G` # t͈!}px$tg;lj%5# teB31Sd{bk`*x=F;%9y,a9}<w}'O2{ث3'U' φ'Ԗ'pD j!+@0<ǸLH!`cPɍV%( v|R;4XvuޟoY6Cтՠq> o.IJH:%@n00"=zh~B܇yyܭө>o .S\!-r\a^w4c/9g˛^s0p:ft1!>žV٬ݗV7t{6`jr^?VQ"́VM?S :ɏhUyp `'T{wy.`0̟ߝO\}JoS\ OzcyhOc~{C-iw Lpth I?믋^vدpC]`R6#0 ӼǀFx.kV'M v/X_c[Y`u}}Ӈ]6CYxnOxBi s$ =C~Xoh뛏HۇY$ jFRbfkycf)MCuZ8(M:Bͫҁ A3K:QIrGoR 8[xh` HqiRf ,`SlH)S-O'TDbQB/L'Ù^k/"]Xfd<)~GLcMPϧ~ j%Ϧ R89{N r} ÿb$ RH{wx#SwGZ8 {;<nA]XMD6}Oܴ!f9d80[n>Č߼>DNc]|H C: M6?㐤VY32͗-'zߛrwp%HM{p7>0 /4wxߡǟ?m 6v;RӤqnXsߦO!ɟ1K0ܩ_~7m;eᅅWLqe~M>#} Fޢ6*0> stream x]Ysu~GRp/7%z_fӊ-])y  Mb~}e6AEs{Owg?i&aoׯۼ=`?&r#hak-6G|Ĥd]1Gmw|{;NMG g:(9NmlŽnOk7cʫu|Pq.h@M"XsqqQžw5>Ƥ3y)f{99uqLͼSEd@>{ y۰Ӛqf qt xi kSbǀDἉvylH3\",):;Ū'&R>Nbm&LN{/H/8wz &[; }Ps|R}UtߓwFc6`]Ko} \NK:z{" BG?Ǐ[1sDCBn-̅4߾JMq4M{)vF4R{ƄJSJ~ ϧ]HDZ[i5JbXio?6xb& 6Jgh%Y ow@Ǵ <x^|P4RLDkc3ZٕoT_١%_ˣ7dfi7Bޟ cؙkX0DQhmé#P锰g2O:_5TH7A[nm0`?l߼lFr7nW˷c^ŗ.ҎJgf`Ksd|ak О nl^p-\'ł!qV.cQ7;2*J v,+7 !v[|9xn0"y>0 <3ӓ|^U63P3c 1@S {ĂV@1@y/]m;E]_)d~ti6?TFJ#).z,Ռ\b 5f't>]#<»B W.A"iu㴕A_Dts@A(=6 `I"XIiNΫޜ-Kx:C)Ŭ> itHn ㎋7bǝ$خDo0 C@=~fP3925*E:jeXiَ4-!%iW=1+0q%PRbmFzCлؕkEo,ndT)6a[//C#ɾJ M}_ r;)P?=Zs5g{EF\L?{l!{W$K6f\cnxt\/nRc$/"p/-"DsIsȥ@ #'a2TT  wLJ}׷/6[ـed(/e=@aTPiRhRvZ/f5Lb,:‹#kSOj<&ICr Ҥ#<&ENØ}v`X 9JpA%A Qhǜ6@B3[s5Hz d ԟ+j-;mzޓ!U,ۨc`ig_mXY`PR p*$2 l#[b^w (&N&MGU(.߽gZ=hweenn1 è\Q_i˜C14d1&!\"AszCh) iXq̹ܤCd DnӲ ,'gB:=iQt}Jv1OjV΍BUHa[)[59sa=ޯ5y욪];k-Uab2btF\K ?#wmdNgޗ@̻ñ0vf\L訮霊W3eN:[dΪ/p,(00$g*0L/"jBd(VFq^vWia޳ҥ,mHp(jSαD:X?@)>PϛuUk7::]68T|4Plk'krɱ.؍"7c#oOpHU::3F+%T:K _q{ʹH,]Uzn@'eȜʼlL-V5ϫq,$*%gG Q ) iL+2={ cO0JSoIx?OqY ޤaŐ'HF_k+d[PV; PZLhNܐ",ȱߍs4oG;=RPiT>uRWڱ"93mE Jq2C7C}KQ]_H O-9+4G6s PHP@s#˩uy8t-r)rAḥ|n[_vIw(c:ȫGO5ryƓS:g-2{$~q?5 yH^PTim$lIsuJb; 0c[?>PVQ<}F0(T܈}ܓ%{0{VM5`k^:ԐaA4ڡ>||JɗGcO SS I-vIԛgŕ23%m Xj7> g)'-=2ԡBs@?{8v}['R ہeP'SAaj( ݾHD*wm .(ѹGT\<)l+._XK^!UbgXǜ&Rm#qS '5t}sOkpɫ!gM &h.Z->-Od]ײB6p+, OܟЩ8BG)Ԕ=$'i]O)jm^ڥYl K~;8_fs| bWq{%l456A V$f5ʳܗǻ:K_+!ʸt3#z>`PZ!ܑ<#bTuO Tap>)a*jˀ`]46H}ilwO+|DaMtp/Vcisz w.D(&Lqi&'3\;L~Iad_j`/&VR<ť/R(̋ J0Y'Qb#x%53sTL zAhEf|^#i߂^;Z{+g G n"9?˺{EsINܙQT64$;/_[ZڥvT.6*aje|X^͇NjMط5(z8`@l>ʟ7jfJe|r&W E戊QɹR) %xX*|:tOn"Sx:}iC)r!t7hKy,mczVqo Q5[xO>B9z5ۃt.@SєܡX$; ir5Gar䜅hlUخm~|a@}Lo.~!fg:ƒde Ul} 7~Fx!2nP/NE7u Gb x;@d}18F/0R[|-Ma+wYE8,3$Jͧ<&vZ0t^|\Ǎ*FDŸgE9 D|G|{zӱ"rF !Ki|WKi!Xfwe𒧬3aNpz} r|AaZbi°Aifd2뻸X=N5<7o}"ZhAv;Ա.4$>&4R\jRD^ ~rṆw˵"_q( p5 :*TlI/>T2Y8!;'gg̗@ONPOdz?Aд7o `PB".Y46bc3Ɯ P &$"1%; 9 Dm qҁKO0>_h  VwQ6 /B8ق3oq[vL8VmCcSΐnr/˗9 r 瓻XU7-\?]aQ0q9R"6y׃.endstream endobj 680 0 obj << /Filter /FlateDecode /Length 5438 >> 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ǭtr+8_A_O.oU>+9vp k}0 ".}9' r%%&9t2 P41)+c/g}<;Z) *Zuk}9?Ϡ@$aƱ-BsҶ{hb*~)ǶW+tZHG/t&ԧ1>!Vsyod s1x:&,}}&3k!. ::oTjxɭYdc;'R(qjaᛄ`XlT݅:?ǕǶTXH62o$@[ ?;t,s@G  z& mⱵiLKa\SL7@daN5KK5w*T.).6Izվ|xȍWP܆ϮBٶrh JnBBem<e+8#%뚵 ]pc﹗<u&$?lbg&q~-A*e·.t E1]`]~#q?,^/Ib3| <_1C1;l#73("N#^P^ΛU%%X'~r7 qg鸍MWaB<wBiAO4 A 9C64.TeN{Q,[/DϮЌ7ߢH;f>oɓ1p*K a?F d~{\`77j]9 `g#I벜 VbSbEO,(o5B籰 eE3i_fkey-rZ\AUn/8e]Uμ'REVv2( XERG-0666D|P8V#9p\fuZN{r:naM!¶<8tE3]YђY0$>†`ܠnsqt7{7ҵdū˟4pH^} "u! Ieʶ9PKl沕u>U?l$q4]?Jalծ x Z7st2̗luqy?Q]^2=߇'CVzyK6<nKKcP֑*O orKD ;/j:U8[=;aoSS3\*NSvq+|GtSv:w׏ ?{M ><+"GRw?NHendstream endobj 681 0 obj << /Filter /FlateDecode /Length 6265 >> stream x\Yo$q~D/*ۥ~B,0vv ?hм 91 vGUYU͞l,vXGd_DfFůٰx/dvS\?n~z8r֪kOkWZr^ 5GKU᫭U.u=gm I퇛 3J&Fa Q5xA RT<.YO-Za4t'3e%t<D@6)1-Fz}\lRk NRϽfR̩b.  |2b"[9̊rLf-Qpc׽/}WȲ\Q5mQ3 |6/) 6A0y%]T_;J3*,.p8o<cFtղ%V9*Cc FwK Ae25C Fdyȃ@')%ڗ4"00nLt['}k9t0Gड़W~/aI%LPܲL:Ag#J1?ix_j+D: \;#]w25άVHF2^J&޲YRՙ)b&7dZ {>L)L5/0t,K<&UWjS@@HV\'u^E:cn欓S@8O ePM`IhwEdRLPzWUNL D)4_HDv^V̓Ma'˪aӁt.>n!zca ʸb|*Ol{f)U/x2|s'fEv(iMw AQydwp8C(!$3a|GY0qK,hm ФK[~(=D&8vXj3dmZ4pv[`R(C`p3<,qGBO17x2uU@!~X7dVс\쎞sbϡRbLR@liOXZHR*iOCZ +Jdh0QF#"D> :`एzjӡl4جf@aH1'a YZ_:y {*J:Ѝf ?DVřУV9/oζy>,nc[Gm }Bb1>,SQi0 (4ňXGliٻ2D>2o"Z8g_LV;7g,lE3]5O\m,,hȜj"MWr1%k} }]5Y#wZ:&"]v[b.RZqN/Ne3tb`K`9a15D*Ȍt=LVyNgS5ZPɳru1c8)! ;FM@Msl "-q#G#%L ?WRy u=Q,d* ۋJ =qӞko#TD#wfSszP+y*=C:HqmkmeCWXXBigG0M㝋~Δ8)j =IB8rMY̅Cwe)jW98^!:1J!A;rmb)ZW>H֢O6Q]Vt! f>My~$K: sⶖFDq!xωn~ύ L}; Ac:OZz/ͮv5EkFs؋'7[YRr)@a|N ®% _P _9= Bts[*S64#2MYo:/^a A;9!U1.<׏sxABJ=T9w0E~|_+ބ2!>ŽvMYw+<1x]KLks-1aC<,/y}qe$ϢUՔo>Y)k}˦^LAh+ӮvKNbmlC*FM`x8F b(lk_j6J d^j6|0gP+e"-d%2- )cǬ(:xY{;<-_ Y68^,n0Wz~;'e‡JI-P6gv@[Lɀ×xN%KcEtn0[Ӊ<ي:eèjaZ8c>kH q2T$]l#k.7r}5 K<2x{9/Q.i)|( _3__ C”s Wqv5S yڂAMZHwJ  %UZh/%QUZX/c@=UZXnGiShV'Sh\Mԧ6R!4xhL߄@&hXa0}c|l- tsLyp oZh/^uWma@vB{ <<0U[XB+E?L :W`VG ۱`= ]bI]Q"}Z5Hxq/--" -uԼZ=4᱗fCDwo-;l;>n_T:×|b4X- *pat}Y?w6q~|F},h7d  Nr3jPi|L4 (pKIz&JSH't_n7N =0,ͻ%/W[&_תXU}@u^'}@u^t$jyF $  *\`JW$,Hc F }9XR/40  eh` hW\%bVr 8"'!Zph]7mD ܹe L?PAXX:8 (@Rc@4=vh/Y3V;m^~RXkD:Oo͔:,)êrJ?؛8l")5ڔb%x K,Eo:RQ NWr';Lk`"4_Zv|O8IrL97qJ^vy8xJé%i;e[gTti,-[D4,-!HY4ݾIZv#pc " 9«e״F.؜LTΧ OQ7yI,OŚ6, ƅ`Uu T6!u}'yWCB[LAB&3yK}QQOƈj4Kp#}UK,,~VC.aCƓ.Mwڗ8Ulb`zd-ȌU\ q,"bW4CD*5=JX|-r泑"i{@n}O^~/k*ҝހi-"/^v>J/Útg8uya#%ӯ&ݗ6wtS *\Z 6͗'oc~!A/g]A6_ ?K_LtOendstream endobj 682 0 obj << /Filter /FlateDecode /Length 4350 >> stream x[o 9y߷T(ڢiZ (P$MRՠ;ٽ;ZrOwo&_'OW0 ZLnT>fIym\ݟז+YmZۦ:L/X-UΫ;ǙN/x6nύsʩv;i '{H@Z5ox03V8/l cҚjo]x{9kXό'78E&w+{NyotSa`[&[+2k!⁼K V!k2veTjJ eJ gqr -S׸m(u054컳f 7ns^ކ1oѼ]( ` .kOEuXӎ3[o0e|^ʀvCy -zuxm^G|]lN~4 -"k5Yv6=qu\/[ru9|z/_Oc |iעn σkop"nyyGBH \g^:uv=Z%<!QC}?[m.A[Fua_Cvqy]Ag nl2׉ jJ\A7./O3̷lwwg$sbUᤨY Rt a.»jq]WHe}|D1>AԾ6gd:uyDNWrkͨgzvb>1t~^&b^m@7ht;W..>ܬyPvBݮݱW_:MMNzkUeb$ɦzpɛoc !X{"X|vNp 9%L Uz_>Z a÷Z J|TŴ j ;< CB`4/#|!u$QnIR;X[ɀ0Ű_ xģl g"*^!r\ #kp)q*CKIⲿ\5~F(( x ~ d9b"ZnrTr3O#Tyit+ekںO=@8GU<U C/{9#[ą*| 0Xtݢ 0ETC 7;MmL],Ljtjg/$h]m.\ lTE3dHЌDḻ?M%|bl=r[`A۰"S&,JH\=oLt܃=wOИAR_1i1[ =>Wݩbyq5L6L[4}I9K=P7 'PxʓH`޻ֲ |VƕGr{F8Hm^e:`0(<}-!tcJXP LԵh~~m Q(|7jd/8/A .dx-yUYyA%ysbQyIkG~-yϔ9Ior!hO=z IYLnxRL󻡂:z¼q_H  řhf6S?k~ qP6~ ߆+fIݠhR?#whc*'p RrP\ pBqZ2gm!xhԼIAO Hl(Fײ a{~Ì&{qγd&λPA](<}'Ï DuG>n!.kTm#`EpLz0rz}') Zud&RYG3#7W!Ûi4kP+^dZ:fQCBD٤7UrJfoql օ\]VqH/&x+_$lGӹ5d?{^`5^ Ά'z\s ܉|62-|cXԲwih.q؜7A^38Ds }ft;xQ;|+?kRkx;8RVęoZ _p#ՄK7rD,>~[!ǎusN!*`x>U &]t'i#ǹoeg $3]SL( H2 ʄ7Jc1BV_[ qm>;ߝendstream endobj 683 0 obj << /Filter /FlateDecode /Length 3285 >> 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>NI~IGXBKڪӃXDU<8!<tCn> I<Yx߫Ѐe'̝s9-zH+?n unˌֶ c .dTL nr9 HGfr+4n0?@'ecq ac+=;f\ZYKDIV6%+6*rk4<e9݅׆ xi\ݷ2ԐXz\_$'{%N;V-Bdx{e7W}g70ulV!)A0+xs ñXބPhNwMQ%B4ZָC۫_~`TG db'ސy ĺl9%91ԧi9Aɻ@W=[8ТJ%&R. TKh.J>E5P!qܣkk㸝`K .w_Wi_\}X\^L?JbnisYa770Uz!ƼnWׇg;J |Z4ɲ^3 "/I[ֳ{-4S< b!ȯC0LRa'CB (qCqE})T$o1R i.fJ8f*y2#kb˔l:2-2X%hdžXj5RTaveqX0^ˎMvd145\*Qq.=ImW͠(D8V bۈz.dWA8hԿ8<\T>-mN4<~9-N/㌲ R?zyn4%.FmZߒ CI1𒥃緲)i NBuߞ*!&?fZ(lgMط/YPeug,GoX.dqZ҄uهj K@ckwdH&)Ϟϟ{aJ8{ )mc٦ L]mv As1!%:'"ڱd1unq>О靦_ia5&4i|4(U9Z{:Ÿ~FC#$ ;P |09p4ЄlS\0xp_&'n%-=< pj{Ӏd]!m7v;ق@CR  rCwe0\ ʚm ٗ t.ito9; 5k,{UklRxJT)tXو?{:Q`ffJԜ oEO$~}9ߎ|`5T&h)$~zwX8k(p5 bP HbбhهI9mxV\2*Tᒦ˱ \XыO᪒0ሮ܎DK|J.*N >IXr'T:[45,p\!JcO)P*?)7ތx3K/z5D {W2k ɚ 9PtʆOgM$endstream endobj 684 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 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 686 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4033 >> 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 687 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]O10 Բ 0Um?eB:gm_Xց$i, x> 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 690 0 obj << /Filter /FlateDecode /Length 2961 >> stream xZnohnc&1<6 d aDR`.HjL#"3"j5%Ru.xQ6bg'߿aDlޞ|8&svF8r֪雓4Unr㭜\ 듗绽ln/ 'n{Sv=1hp|!c"l9aM?_ow{-,eٗEM5 &TlgB !U\V[6M~]dg#e U8W tBy+}ym}6-$S,)W'꣢d0ӿ(&<9M&}^%n+ng隄movUD?vgo(5a{S#0j_f2Ĥ(@)o{^Ֆ>΋KC2PoV)6Mtµv`_𵆧W*x%\$Pjr>>5ԩ i?)SS8l/L/Yg9.֖Dl:.se!<0e#,7ܺ >܄PŊrtP(篷t>(|BGz&;kYuU19]!_İXbՀDeu6apx뻄(Y>"+HREq6U@B5~a*Tmhjf[YlCG jvY ](54 F)ZuޓbVK&HMcky 엵bpJµu^14 )V#F_ɀzCkHE? .a\Lks4nvlO j!Rw(l(U6+.U݄Td8V/\-1+E 0 )TtL!?ec%I]Ms ˜#-B]t[B4QsC?] H׾MI uҐou3,y}!V2) 6z1JW] J=WM+afc?Oba]24c/d k5yML+Z6C)b5@kYJҖ#EouVmF5C_d:N6D3 6䟸҇\Ԛ:SbSt+ 0sv]mcOZ9csu9mNUURcIF()YU!wVl~m@dXjtخ󹕋|ETzuM.ӆgܙZm^/@ۈ`Gu =Sd(mI  !Cs\+:Խ!P&e[llC@5%WkpE%\SڀX@2n.:2m%c z(Q`qPS59h>HKVD @T̀M(eg٭Yʨ2i.7e U]]"5Vipn=8*8hR|+땉5r`5ٮבmSmPίtaf!,l&5֐/ELhȔS2G\X-)䃬0T;h*>y9Vry.T#{Yp4LiiC{L zw<9(sRؗH͋Iw,4Hg*Gɿ2#cH^:e=WLVXnw[`<:iߠORf',<,"? F"<exmAt8ӁĐ4klJ@Wk[#P,F-HzLBDubAS`|˻p8l`܀c PMX~u&zZ_^Zݲ&d(QsA'g<}VgMhfn@89"0:XWXm{1[h2Rx (4<}[tendstream endobj 691 0 obj << /Filter /FlateDecode /Length 4576 >> stream x\Yo~'#~2Ȏ>A9'pbbA<$֒4)JOUwOO5\Q Xٞm&a_l'6ooGFn8bs(>7NOLzOƻM1.o/wR +`lώv1>e5ۏ&z{ nk2um@:߳Uސ^5K{^LޅϗMM#PU|s/$HW95!3E:+%5< ƁA2b% 6qxX[;> ο !~5B@ٶwd68J:<oY> rg S ]*1@> fޓGf@ӌnRy˒GKy.mbyFD-P@g>)એc)1^@j $ j`#BNꠗ8B9ȨrC$H+]4p`G0CrMp|ot 谎OK'߿& 0yW<utp2oX1`eɗi]F2;b_+ JE ik]]o 8owA*Le R|?p;W1 `h3/Tb@< WĢ"P4!ʠbq`<hZKu_Ũ%pbJd3 .{n|Ih.S M\$ىw/tdVI=wx/=:5lR#< ˊe-Dڟ۟t^h'-V6w*gIʨHHY.8kRY4uژҝ>!] >l.lfpR\ 8Aou4x%J|$O|L~|RKdȤpx^ϙ}ESzr/'6FJ* TèdAvp*ov;+2\z;7 3gNU8—jLY'*k>fg\1q*t ~CwN vv*̩kY}ԓTZ؁B.$3nz;dGDܕt`tÄ8׃ψk"v:I6QEp1MF2#)c( ^:W٢]&4Y0$x(lR F~PiqOe3 ixAMB=@MQ07`5n$u`ol-c̋/9m[:4*-?k0wqq[/4KW PpO1q@ 5iQLAю{kU ~"S!@F?rVHIyH#:c;Q@]z':2z{:s!`[F׃?x_:6#CF]oWY<|`9ԛXVKE\˄Ոȳ H8`mz&;O0BsX 8Nl陛 *͌X_|o.f//%uN;a cfò+8,ا8ƨlVZsnyW\ƙ\8^rdmr03`Vce )()3MU_ǰFe<}켩7 wU `H2&˼ ץo='#V&E|OÖ B֋=UW3rh"kJQf@e L- *C)xAQwQak s!)~0XYQO8P>M 8MGd2YJRn-8 ]^| ,78p̤X&qqq!uaցF 4 W#+^]U:)S~U,$%g[n\PN2&CzXa^-QnTy(q ,}| c+&LI^ 3DX)ԃhNq`v)K 禭'T56,Q&MG!}$-$BJMF;uhvN?︚1x NRDr0UUu*ul\`EO8昬p/I)q.g|pJ!LLesyPu>4ul 8c:MmbƂv"|(oٔt҄lxM0HFQjM/Opq+ةI&ֶU?#80yG?EvT1'P>AvL4uס&\M+B$¤<6(Cޘ3+c1?ߤ:pn?1H, b#?He?$xpp!q' v_KK^83it>K5ur8!?oX\H#>KNG^⨬2K! ڣe纋 ~H\Rƚݵ@֑N;gYZ.eYhiR(p`l<|DcE M&nt,jx*vp?E2W6h(9.ez= ,d ȍj)63WsJQjmXa)cPR1lTe2ۖqykIKNT,=+/ ܜmM*r0C!PqU[gGFj+l5@]VO(qOSmC,hXt*|ABH3LUS_Q@/smr̔Pۯ!4`EݷWМv.g,ά+  þ ܰɡ:uاSu/8&+ke)@TZG"b hrs}acѳ #y##I1jdG֡8](ski&GpH]t{_5 0&ӻNA_`$.}@BRxGV]"'"oJJ1Ptbwͦؑ>OZ.t<FK!?QhWp*-]8]s}ftƒNcQ&1D :90O-- ae_gHҩ:g7_i6-`9t0Sw9w9qk BL6i}(C!d5ţgUs9_&HkB&)4oQzer*RxP7~ø;IQc-Ȩuma$ٓ0ΎH#2*{(@=L& ZЬWl}idN >lnt$^\e[~KMtb&L1@hNiTUY~Iմ} M|HQ >xkW<+S>z2gU1'4)6XZ28L{[Ѱ&) Z ؜M'h~S;TIv1&f7/4ЮP~\z?;r6,!-N)S%q#lTi!HAoT _.Kkxh> 4̐ 4+7J` k7_ks5}a%ՒIwPBz_ -Q)mrPHW)YXjVX/ȝ;V5SR> 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{ww{zm=VWpบ\:BO߅6ni )ۋz/H a^ v) 0>r%߀wWA('Zg;~1 DGQ&\")%Kx2hʎ 2ג-"c lQB<#a(j4j5y\3" E0 v@j`ep-X` = .hg'i2=X6b04;S?n؎o"@`HNBY@ RHUCl(VcU9X]micCqL/KypɥQ?qyg8(mYusǚ*[i"@b M+]uMxexwS:Dz-{OJ%1s!"c #"g:cNpY]ayHUk񶫫7@!hѽ#@)BQrd(=Q}*DSbī|?5Ed.#$&f/Ԑ]7Bg'lU=ÈI%`(`I.'Y0JOg/P[|ۡNm4b;Ǯށ4l3vM`=si+:w'`Q'Cd;Or6~;rX,vE8&&~ ^Ri 4N3¶Pcg 86?KmwoA4SHZȱK%ȟGI4rdޤOă1ՠbPnxSxq4oc@ Y> =#Y)+Ob1>{jC2kr_!Y%Ә.)zH1BM0_aI@c )/1z"N]|-Kg%^ =w 8?ۂ(wS MY]`{fԳuȍe[߃v,A+#՘@~|>2:lU%^\Ho,n lFhU:sYgɡ2"$50͸p*A.f8MAIxh~B1hhKMvy:G$\{$Zb6 daB2<2#cE_Ը;;'er7/mMU %ókt:MY`->yWkOQyPC5{yUA)WG|9FARat hƔ 2.^Ojn`3g#7{E*DmU7WqV,-mr_TH$WYhԾp% (!`v͡1cA&J8$=?uh81Ԉu )_%{ G sԡn:7R fv2AZb4,ik"|`Y+xUdXz!IUind>ُ{ᵒp b;EOh\eƬ@ɧӱ}[kt?A'ngRkX 8kZF S9=%ajP@qi6K:ܘhXQ]yDSh\qz|m4jqv8PQ6r,ZNo^vɅ^dEJdA.f xPؒЛ"3RHr {XJcsX;6W׫Mk$LL+e1ᄮWZw]Ӫ]Y3{o }8=6: "D $do*%Q½ ОqE onczl' Q.I9to%%~4T|U2V{ C nuޤ(=C:2d{wf yU.;Q"B8 2o޴U\ x6R2j:峥FZ 㬶ϣLLB-5^04hx,woMD9\!mtmJ͍B{'QV462}Wi.j.x{iltIcJb'\iƢ SJNn֔=qjskյ\Ԛ!Aȵ0(`w?DɆUW4ڡ.5㕺HL&ĩEHñ`}n9Fd<]QWRF\uk9e.vy>ݡvRfHdmиZ4z iUi]";sEȵ$3l@^3c[\]7z؉V?01h&-ABSr?bƷ؈Pr^wK61Q$-0ص ==oY*Wtss7ҍsdM@A6HѴ7 b tIa2ѷ9-X= 5+I*3[ bXmҒqj J$lSg6X16P5f=~`/SjR;bm x>9! .H?| _&[D93?, 6'.a>y l ϥ`ִs'!n/ᐌ {s NX^>v $ (%mZx`534EI]̏"H\Γ\2AǑt/%m#S09`DGLrΗJK`pqG=tAUu γxi Kv?l@&o;gR/70H6OGbvendstream endobj 693 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 ?> /$˸Rޏ O|Ѱ_Jo'4"L >D$e-l9l},֧#J/jGcZ^!H Z[Yθ6A@fv$(#E)s,F[G\A)@>M|yXjvtaq=kO\ZDH,g3px v8|# +O6#Z'A{-XP&;&.g\[9gghZ\tc%-+_:MBQDŽXiOi\^㊌*h*o(Ccd,-5k]j6|DXpNtN)g֮E#`յ.윷:X vYr|O3##$OYp3JA/~pZy|;(jasn/Pw0{vTƑ65?1Y` 4-e=_1 8Mci5-LcF~+4g`t"/@f5לߔhyf&mb#.0%8XOPjJi6AIɖ/@ ;D]NVhF`X afR\5y R-£]UMV'<3(K-c*᱑pp|'t<- igk6GL^cfyw_3w+Ѐ la[VͮV (CqCnXRo~]7Sbm6*rfi Ȟ>wձ= z?Rqr {Fq@.0٩AhOXLX0P!, W1;b&p: XBGB o0I+jŌ9IQreNң.C.kO5rt"%"E1YCz V )Id#NjȾ(rwll'2!@zue4t8A'[ɲuL8;Y^}b%L~a+ZNq>s: U|8"iC n/qĕ̫dMQ yg1)"0YF#bN&,!ԳɯjsB5ᙴ1*vg qyH0p?iiEfX]{Oi/&h5Ґ8brW{<W AY4E0 /2wCNjvf /ϣ1554phc^gJC<[.n$-\XAȽ=$?R/xva$V]K7 \`"R+Jׇ|JF"v*Az|MNzTz(`nT碒H[2FKlDFN@ĽZi `*Z1DxB\qs=\$dorB!s5yAÌV3n$>HА)ᰣ:b8.ׄj`1Z]xKQ-8_j5sgy`iZ7KaUgmmsrUasבݖ%+yeH12OD<˓hhdq^1v2xR&GSi`l#55aL͊E{&(&/Liyv/ՎT˪ S&E}e;+ߑa.RM,a+~b'ꖅQITw\zG)% '\Gu֒L'j كY#HmgwHomd{PC# =(>^6.Y*bU-KzY':Pn ZV%^^aa76?b}n:5 L-sUe wa浠uvυ)_iƑ* %%T DjBGFD ErY]nNR8G8` ;" |2ou$ʍEzH<ZZuTh~=PU:Jt`KM kg䀿:tMM$`.([jV\ȋ_j,]+rptg 4XCzu*gp] T{i)wm,G5to*DM7*AO}YFu_8j}9@eՄ~ZkJgӯ P?*4[1ыvt[S5 ᯸7_=ēzo#yW+cW?>xGVF7gY|D]]/9z'|}' I3}A_wܠz䄡WCĊlȟ[7 S,"]y 5=:w {u0޷Uo5aaru_|0p8pQ#x} TlZ^2lzN_Tp~ X:m6fyf\7M"0Y*)}0@l~uR;4@_G{ڿ6ϙ YLĬiӠwt )*0Ñjs&lNu !ͭў -u".7tw*1Gb`ZF| T4*V6R{ <>γ)NǨtEs{LieJ4uyՂ|ޞ(#s8ǀd|h>j*\nןIJniz]yQЪ`Ŗ}J#Xcb#>U"*#~)tzI2 \O3oSMɷxǒE#\G喣25̬VЪX+wE#WZE1ꞟŤ]"mJR45΍7LULV } #rx._P,n؄RM[+T؋Ю=g ݮe5UFJaw@ʼy f{շT2{"t(gPLhL06/aZ|ϡ8]~|}m-T w Zit\2^sކ O}Omz E4B0K}3VH6A X4Tr= 丹9PNNFiS:p}_;)c߸eHP:n:rii@ks۹t- CHnrG~It1hD[ۓp=tf2֗k4WJf鸦|eF!,[ϧ`)Ч:G,A ?)Nr+~Y}w>LEP >uNm'h[9'aek練0ȧCk2:)IEBgxLmNm]LWjSov&ྫྷ Ľ J5E8i} W{$-~y{Fi8=iÚJ-B kKH.(D"7sIv~̞#㈘=(dw=%5I$)8[tdo,M f! Jt(#)]3H}5or0vALo[IN,)ca#ǏO?n?_]\>=YIWi#U:x;:M pf38/<dw剄16*cIrrʞȐvXgv͚pM j m`v`?Ph þ&}`Ύ:92h/( VjV c`܋ 6}gx.UX1R9)@6X?D1?ӲY endstream endobj 694 0 obj << /Filter /FlateDecode /Length 3948 >> stream x[Yo~X;N; #EJclק>f5飺ίjܰo=>ݷm.Glsq_7音͟N`n'ڜ=SI7Vx9>~+w =i=9r^^>+k|IoNxrm?, z9?I&xޞך1<_Γ {\IOok˘6nu(o޽%_Yt,XOY!0cb{K3*>[t9;ޓp>yޓ4oNqt:o-g$opWFG`, <3i6IgqA< =aq!8'o)ӑɳ5k2{/bGWmEM'.lup+\fp2pȃY&-=yP$ -C8Z(>oJCx jйM5?ʈNjU@²MvЂog(Z7ys_d( ~`u@bl5K dT=V\#=_Uj%ZG)=ZЂpo@Z "=eQp +8PV n:'J`QjXYeK©  ̌+/i6YT:ғ&d9cʩ sR>KHw.ZǜIjZV2w_IL.ǻ6R{c޴kN']#ӵegK"<"~4w /8+4LP1k6'n:x^J^UCHdnfzѷKm<*Mk躝^3jlS7̡,Ҋtn1JpJē\5adV['ćY jK:1-oOcr!Vxsў ]jE_K9$qS)wYF%iSJJmr1/cus a-ۖ QSNBzPt‰-_gZ X O5˔/la"qL >ߌ УU.p`%{/>MGRE.qկisID[oޞ]V!s6MW);#ȑxN4!$} pb~d# S_/.RŸƼRe:]4Ew3P"eZJ%M_E^P;uf`]Vr;x"TL&Ye4HޠOc>$zꪻJ?B:mfWJ-5=Dm+t+^欴čˢ¶espبv%?uGD4VUM)jDx4)Sial@]2Rҧ,#q.'t#BȰ*酬9̪ xj^"D50&$Ssӆ&5J68}]-eS'|֐bS:!9& JUpǔR阎[47gp7ds',)7'JzY4T 81w$1oI1EMuVNmE f"t i. c$1znᇁ_]^Q20CVl;p}t6nAzǀ[RmAx[6hY/Uf%V~g'Ss|Qb̊} 7cI#Vf>B8UukώdgS z"[&=-o\`9HS>x@A7$m XȨRmڋ?бŭBS !j~$!ֳ. a#c~Ω DӷffI{҉=׈ b&Ċ# H;{resl뒅XeFD3ӗQϭ4ڗCP:h ]3]>1Z^*LX2\(Hr>;Bο@CE2C > 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&Cr$.wcUm Tn.1ګA#dL} o/@i> |~Y?C.ηo7_zn|nۯ(z{uw~{57Ə?IN'E?`D"huznO]o^/.)lng!MBDM vz/m/\_Ho'5as]Aqwil-0wnu^$Z(Wĺ ArB ܜ8䏏; l[xE;-]/{sK+z0{-}H;ػ^qqUsu`K | %qO)-<3?HktݭuP$e,Rmk-@G4!Q/ zw }'hK7au\ P]a)پ԰4a%Vψ^ uǴNu`ab@㣕G?}qZJGsK0ՈhzғW+\Y\\ɞ'L\ z T؆<|6۫~^e̙R;<^\b dv)F2~L!Aj҇ҭ1xYDdg$S7;' 71Ƽ@!3q^CQMšGdMzUIcMMC *0npŪ aJ sݙ0-sa$0 :. ۏBdZ+axÄl<",FrDsW ԂDݼ WCg 4 {J=@9٨H)<)<& [EZnju`dj׫ 0:Eec f:x TxpTu+w%Uڏn'G- κ1pBaT12wJUr p u-,%naN6$&3f£(S˘tJƿEeLu@ :M@)JLjH21̘-,O9,ubDFc+œ1FEFcO֑UwuBd4<L; %]\"J|X2d!ڕ!BYT@ G1WU BhHPtJ3햻 ܪct1J' NC69h^uy$GL55A`d0exdZFnx.Ag>hmcg9lA{/ȝ|\ב+c`JʈegT.l`*4f %Lj@Rbd9ً&R1-1Ԏ*_UܽƪBFZ!!FK_.:1r i;*?C[c;QlnIN#JP#h*n 9U/ SuD0xU s5A&1WcE2RxOL J,q TQU+VP5ҩW&yInt:*x:͈V/gq܀/x\$xqZF$v^F$+g4֬6Y Ye_J*=GvIRj_RFUNǫKX'Tv]T*9ƪcj%W1b)Y|S"+Za@3ynTe#ل Df!G-,y*F8U9zdJ &D4x;ZIV@Ȯt:CΣI) J<-K65`ZTsH.%S [8ciD#1E(oHU2CN#Rš2:Cs_ZFh}F@D:^X0natD/`TOT,$D$R?#WJ}U(E=^RijFr_k{m:Jkǽ4kB'5i, XK:}%J`F-|l{܇rawLN}(] >SKiԁah%JLv]nx*R L/QjeӤ 1^wAwnM/=j8,f_'Sǖ*s{I*ܰ:ZR?o!CԶ?PǚtR~r,s1H5ڐ4sO2 وpa{ȵQɈB7Q}k+Ձ0]l*TOĐ[Axz**o*!:TZD:#FpĹ\5\O lnRE5_$Ӈ1 ,̚yTIHWj)yk9:5bD؁E*A_(-9}uV^ E$*Q?߰ե7`4,rs֟Ɔju'発 r"l~p_*._ەĮQ˝㨒_ -.X?f>E_peMcAc̥Ϣ15+T:INC8q&-qoS2I%_"p$ٴ*ۿ1q'[K^0{*5ƒHVUٶ ,Vؑ%VmLPT2&2PJ 2B.J 1ijʓQNmd]v5 ASjua:,PuB/vBy>3ĥ4AZTZw^AT#HPSԲU_c\ã Ufֻ=̂ eV VkO zr+E˜H Wp! &Ūf9*VYбnkjQSNm% 爥" 7G(TMrlN{ qyj=<[fc A0 d95hYJX*VF*ȳ8k0H-xI)k% ,N6U84JW9$ ɔurC^ v9ɾ7\^&iw ˆG;&ۑyJ0,0Z7#J\Fbep:C :ku&r3*#T^Ӫ@۫T[EFhR i-gXX&4-wשw%/+d0_`VӬh'@4PY^ǭ0mhj3FIsX_3L, 1(enw'E`o0>}Vζ#aH&"UQidRG (7&ڞPS+%jH({BK3zH!(M o~wޓKzfԗu{ WϽL?49=h4رrg<|5XQHֳ# ˋyxl+HzG=o$xHe/MP0' /dBkfnM|O^L)(&J7ٸ> stream xOYfv싁9ȰngK̡d7YY%X2^DdVQ1LFF}kFb[]o_Gfy7䙯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%nSQ )?*ŃlU!4 osV q1kbz*YWiRؿ({*Hr "@Rn%HP%m;K9j᫝;am1 1HJQ KƗ)Bɰ XA/UHɐ5J! OѤ΀4:"w7 &'Pu6kK4*;"itIaFG}:hL;g~2K5MbYJաLݶP-tM\uK]6Q vR5TLb '>,6ďiK\5M$ zP#)Mp\ɯ}GiJKeӈzaz ,M[sF:m J 5Ej`DߕL9#Ǧ&Y Mʀh*Ye*eœMwc7!1UUo\D5+eL˶x -n+¡k'8!%E d.{ |*{EPxkg(<agXyTOzzN/|!}4'߁EIf7҇q.h\gK ac:L,&[ 7y{pL"53Ιݭx۹0}ݱSf捖f,U'ُ~Xڀkg wCl4rE-J-JQ38.6hU%Bn@Bdcl+Eu-5Jv5RN()\r۱׌^D8fŘ0'P|_:fZa] k%3z"yլDF>uƃثPif" {AP}:C]nqbwh.juq]% [;x7kVx"H2)|:R*.vģb4TRpWrapNa 9*B.u[ 4V"XMM{qn4ϝ3: %ǚ r1_m\go6WY?4}M;L^<~o `:޴$T%l&kF0s|J[3[rb9?6\([J'g.7* lqm]7t}-2lFRqn^KcpxVPs_(%r1nRGS4XIkLe Sn W 8:=33y7Eg~ܚ҆`?d )J) Lg%9QdL R'Ur°]CRp|tx]+oKdh :(U$04;,#d.ՎJ!)Yme>֝$PmA&ޓ}u g0BU1~d"/̀sb5SYE `hJrw=zIB-m}/4 ,+/C>vL8@ nT/{z\jCM QUmp !HA.+|9-ݗhը] /iF?ׂ*/KP YW\/Kd^pՍ/TG  6YbG  loh@>s1ZN  FyGV;XJÒ#b 0 ^UlTD+(lQ׀^ImF(=BM R"="™&{L4Do:I"`,2T!4(:!":@wBPMR"?$EA*QfzQV iD".kQxNVU#ܣFQoabbO3{P&|+ՋQ9L1I΍8O\Ih).i<|m2!Br)MsB(xq;-ow7y᰻y84,fO^n߭jxl/Æ2ށ_׷/qƤN_]&뛀׾_$%HE8xa^"Qf1Dc@'C6:bZM$p?~tO&,"X܊t$V{87TAo?<5[:c& ~7!MT\ό6+iA$%[d,2?Јg{6*}Θv EMം!NH &$X yБ6}gk;x^B.:LN\ӊokռȶ:떚DdYVoq8@"^Ňx4%W BME=>B.U#L[D4G {XFݟ'gO$8eoppN ,θ",ֳSEr]0Sqo>K' &o?t:}~i $35TΗien$ia8Ky\0̭D-pn< `KWcis&hN03b-}J\We%]kit>\?dD-N(>RcVq%m"Q8$/d넰!zz`b<P;%j>s6IG$:v ded`-ZÚx ! 5# QOLOWsy?Raj|7*,0̵6~f*# ?"^wFȗE,&If5-sp{i ɏ(?#YKrn|l.O\~:MgFDU8W^ ޳!j@z ۅąH75>89KOfZӔmK'j,Ёf{(4qK[' ougtЉOی7mq54H;K@6=Fof D7Boҳk؇$$}߇U*c*Y(rM$RYpKYJ yC7}rTfX&]z"zvg9M(.zҴ;;];<I0_9IAG 8uATa.x&χuJ={#:iVku٢8. hR`𴣱ü'_֨S 4uIX/tLhoAc'3r;R^'qXzLt 0gsF&f @:y0`h .0AM26B{t7jHn nEt ~:&ͫ;Y{} J@i_AZ|_a o*o&)R?k`pNUTO Z-IB$Wo雪CP: f5 ,Gպ]k(eΪPM-_I j?q2X4AVِ? +2)! %:gZ9ɸ4K}R#%H$Uɨ% .bfQx{|ZE59Lj P)|"M( zrw zi,xI?XQC+OkT'*2@<+x$I(k{tΫZ1S?V +X4d#aLψ4 k1>L0,/b*o8C@%3,T!$ X >/<\Pk~ c aZj"7j=a%:y[ XvRwJ5G#=UK)'z5(dpeΈVC44sg HbH@&p ,9y_FB_gK8 ҆yɏ,k]OlH ڜ%k75 =qK>M+fc`|H M/)ǒD)9.}gPWeC|/9M9=,/Xw*&3IC6wh/+z!UB/* 8=kr /R(wc_+?~2CI9ɏ?nPfFcTͭ]Dop} ʤ\+kWECMT"2Z4ax+t1H:@ |ha3*4VU٭Lu\wJ۾ms>s9]6=TvC[FЧR`p84caoU{L}]2^nww:`W 3eG)4j-̭RHEoe3qw떪ͣ.Sƫ ᨭKJrF[=5KGR,Z*w$=ajTD  dyf1I*¸ŦxKc'wXUj>Ǧnxf`ڪmτCV^@4Z^(G;]x8JMo9~3UQΰ՚7V>b3ZZPA`iT.qi c,>jW cefeW*a@ qPY .]9 ,eG9ؽJU1ThFsHӢE>pRW.ILgoHEdM:[6`pG^4l0<\UQիyŠ7A1|l]gK2~ɬ ~ƕ u!M&/ש*'u)4\oReuݶI^Lެ([a4g9Zk9a>ϼkePo`]vf5fr^OYC03@g|/Cko܏o ΂&5ﶻۣ.fL+A(crƎ J ) r?LY*:t_GwׅTe)pr85HUpkWEۦ0<^S9*Pvic 52cQGK (keEԝtV ]x2)@*/8G &Hušj'Y)W[z[Nx<*0J(Ѐ֨zd)!$; +h 7J Jts` 8]E=V?GQx0*2"[ /F%H"&6¥ʖmx/>i$Xm{\~.@(}yxګ8cSnL.b*$kOL5panmiMؼ"]׌KMGUHCyc%>(>#)lcT405>MPnYL.j832ax^2L;`ucGEw&K{v"M_ d. 5jԁ(TIڵ"'v1+| mIydv=v; mػeO=)Jا#OèR/Fw]oblO26Bn/ Ok [g,mWQuuD;M|?uC VwuTcZcV꛽|,: 7I:ďܤY/kŃgOAJ1hTcmc>u>惑^Iڬo 77~&YgF-61b{֋C#=;^dK@%.~ Q7 }^!۫J4endstream endobj 698 0 obj << /Filter /FlateDecode /Length 5943 >> 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;G;}`> RLbaY$qWq"I^ߞIWhWoT ߔ=fYd 0lt(jyJ x~UH ]·-J!|b;2QxԞ1DþU~l# 'MZ!@cHD@%tI8ۢk>$&|*_!QC|-;TCJnW LN=m4U+AfL3ԙ83ʹ K QYI?h}\j9;Ƥn`؂`l5ZuENXz"5D6ig0V^;[ڷDK4vP{YВ1A؝ /ch0 ^\%3#/*Ћ5WnaKg8{&chNd5m1Dl<胪(/?eWq P@ _mZF>`ϻ82Y"hᕭ?YUpk{|LqoܖR ) 0*TS{gu}JL!0J/Qv-fY 8sN"3f!p,q|kG[{)cnIK#CLuARQ~ 1c̼qwq&f 91З S+ S-&#z)_ ]Gp%'-잪>I>n9zluEZI&6tmnt NA#|eP6j_јKڢSy'Y؍p)ֈ_:dw:1#%!22 Hjd2 EiI.$F`PT'-,a~I4"0\dZhKs2tz5mlU /QȦ'"3w4w*d缀PZU+ވy.I@4xƽaF?^8$l3Eُ#XQAߦu1e@Z]SR59ӷ9'D{cZ_ϲ /5&G[24~ p5O=ff7%Z&ϴ Yg5S,uTuN톩+Ć% ;1Av bzd:[#n茣HNdY/mnZ۪GFt#!C1l{T4 -i ie2V,cfZPF">U\S5Fx$ChB[kwȕe,h5"P5qeVl`%i4Rn[ * e/<xmBWPCQЋD@mx)baAxp+ZDZ |&/cdJOilpeLL/;q̂$m8Ȍ#i _h^@"D93%н1RA`F4_CƁ2[l/;7AK0E Lb)[0L[\I BDf6Hflѣ`{S$gSpqlq%uMFM[r2L0x)-M)ޓpLp0G$%dN'=/1nfSeO&𗉚/smT-O2ݵE]At$; tZT28%Tsz, R+x_ɁvgJCC,lgB>7wnyc;&hM=O1%ƱY*i4)+_U .HpvwuԢ 9^g6}|Z JK 1 " N0~l/8G3sn7Ae%zl\-յ:+GU{?t,\o]¥`~|\땭!Ģ(䲩t|m~'C5:|( (X2~o<%u0"aU^3K&Y/]4sl,2Kawϊ/- hN jFxbl9OY|x0`ZMBUhsj-56pM kjHWƵer):K·q$Y;ˆB0΅ t-#ISsLGj>7 "%"fǒU?T(4yy  פE U&5o9hDDkr.8k-b)@;땫'T]<`츄fHw!aZ.b\WvG]Cm33k"i \٤2.ZI@c#90w&XEkymazbG+4Ay=ppU>q`j!!dL5Gl:,9.hږr ,1!' V{E'M@' M#V>>BYhXx\4" K /&p|SvG=(̢} }H:U{# 怼LWڛPSGtWeĠ 7^4iT:r)~`n۬&7?J}x]ͿP#/qde 4S)و=6UJ1%lu0{fZϷ5h~T9kС` A!`PX|,Oc╋ALstO\C ::U` (A5@|q{ed]4--:pbdP!"9#7ve|ܐZC [>M7 З%<$#f~)3?ǛQdei C ~lfV g3hbMoR"Uk՘5Zo("}ٙ?7dx}biy t~hpjzfET+cD_`Pb1:rSC[i TKI.SqdF b|NvN9PlaVra8hɰAv)a"njwtUm;2VYoZh늱'Œ? o̭+e XNp\|3?5k_:䝬t>; W ͔{gݱ4v- +ߕ}gJD ˏo[~O}~jJ\!'UwGZQ:&I\ۀ` t9Q̕TAԍк蚥XFGxxeendstream endobj 699 0 obj << /Filter /FlateDecode /Length 5375 >> stream x\YsGr~#|ь꺺7Z?X"V`#@`@E`(/άH{]gV_5ǁoW?(sh<~{wr-&q`gG+;6jeZa?W [=7`FG̬Y]wK|ǑqᳶVZ?|;Q(:~8~Ys O|Ƞ)Qiuٔ78eȊfSYh:okaH:=0|{{pX)k~)@+bu]8I0UpH 3lEH[7`<{[8^Vvop\d/F>ήįki'|@ZŴxޮ09I5X.L%_L?əYƄv0V&<8? ՔF9SМ[֤MmQ=01(i'5Zs!G1־fye"p  #pƮWDL6Ɋ9·36ᬖ4JٝofoJp =lCe=~'ꭗ'9UìO~VXR?Q,,qY+装&]8\G.%2YjJ)w~h3Ѭ>Fdkȩֹ[GQs˙B!` 3$zhf|+K]s@7g%/'#./ٟRi() q@ |4^:`d8 @R8Ev12!6v#|f__[67A(q~r`AGh81Ÿm  s2a˽了"Tm?a5Cq{C7 .1X[:炦Ji*H?}K1@|*V PczN sx^eӠVNDzk &?D<#]SY&>xݜp(Wӻ3y{ܞJXNۿ} ':ywys@t#jjg0%_ v VU\SMJ-K :CJ?hɈF;U%ї":rҀyG&;{-'qư8V6@p2(Q T|.:p.zЪ#!̓nijhRYSTCQD4rH32Ѷt6Q5]}'Sn #0UzFΔHVx~WS8?7iLQw~]*f|i&DNgH-tK?1݋YP26ΐ0}#6 F4Cg@鱦>v1J:ȇƎObjR4lԟE$7P%8KmĠu(xyW@W*:SV&]ѶDu.@yLF j`jvf؝y'10'rlnѾpc$ x¤@ 9jXs`k,ǜrSԽl EH.3S |H͵qضǏs G}d|۩bhiMWGF@› GަQ \_MZHco* ʸy}@*M)C}-͂F ߟ:ʏ Z]BQ E#Ho(T6zSt0 7úL);\0.fqٖi ~I#pr!Guy/7Z T^ Jh'S}eNZv+˴}?%86pMft}1˼ҤR~jN6w5<=[]ӔL?}zҒ;'.|ͽ5d\ǜ̕/5yhȹt!Sde,gXgc0EE۵a54j`sS^Xreiy` T,~c%Fp]2jA\9H9xA9y3|mY/{;3Owȷu/ ]Z7 Wű\~rU;p>D 6L*ʱx~Th?~a/{vm}1OQlK+-;(b:IM Sc<i/IC3y;p;qb݆X0(\~MӲ2^{};sh<ՉL'tK^T.|Q5$.lH1T.'p K~CaE٠I:\K׬ڼ)$-O9S*6=T 4Vheq8-H2Rli(T#]{)]JTP.ۉ 3D$FӥmF%ֶ9OHԬwIs`jPOU0tQ}՘VBQ\LPћR?)^*!҇U}eז0>xc1vJ](sY}!asn7,ZY,^MD Q ;zLR+*S)aeKgg , >TWtþ  [&m^=^:kT|k7*^*H[Q,\YVU؇h p0K_$V(O %vٖ-ie[&mkf xv9zW$ XeLVluëST7 %X,af+VWa}>J?sqe1z"9U`9Xl>)e'1ϭP\yIn.?пhV07}{OnnVoRMXJ.2WTj6 m,A5i8?PF0kҪ@P`#gs|Cv^1``!8 *\Z Sm60p,N:\̞ Z"1ڣ9h%j`5;<&=ph4{Ů/eCXq,SxRXY`*NYޔhxRWr׊#u`VdqWn ѭgM,&Z""0eT9i kȐL<>]i$ KLsE<5hԙyIY f\Vy.9c5w0@S D\go eKN!%fQ>8ZJl0I'71-\H7x<7} W!IyН#~ ^ Dӈ* 5oM#vD$FT'i3_Bad )\vᖻM+4Mޏt,Vz޶d#fL :1ۈ>>_ۨͤ+ehW]缴#\V(d_BE-YzY<]XR`uc(k'1dju~'ZV.27\q0wqєxltV/]Fe HzcaBR_5&,-A;JKA篃#ɵREݬSve$?$dS:R:x,]PnO ojݻ91sVs#&exﷺ{E}i/+L/' "Z4O!ί \C,(O2zgl$ދu%dKݹ)t[x]4: )IeVd!ǝ߸}n*2O%oϝy~C9JsS;YQd~`y.4@.]9F .ף[92?N~> 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\[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'v16z4[i[ڬQުӭn-nRRԴqC)wO#VL5}lbT%댎uwMޛI.~|g1ըKmc$"J;={3ږ,>c#kzwsy#$[KJu KQp"ݺL_0ff]x ŧIhI X2$ME7 &+i`qu<*\&v-&ޘ:5tINDz"yUPB3VtMuɋ6%ɯ(x%Jk-y;{!=?Ú} 8)]aCtŇ{{Z}-8͓msُi)K3ZAO =dP$E{k`T^] OQh `2N9 X<&W V[?=$  {2z( B:\n5}J 3˚ ujcV$+N9+sJRSzNC4@ՋL x4K 6)!5 ϢFG`"haEiҭ`n/f `49v"՟c{8,yRnayINN J8.Eji2Vo~ÉXi&79F;Q`/CWzBgʦݢ%(%/鳖 S.Ey,AߍQd1 •7]K&,]oyzȈa'`UNW}9) &5ړ\&_t &B ;jyp;a6QfR¨zlx.rf%5 _XTa͕<~Sm:3Gmߥ~ovDƃv &m՞T S7.INߦ."B4{8#PB.|s,ԡbendstream endobj 702 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 t-y 0LB_B;y{0kB"b3VO1s-,BiptZ$45NU$8 neP~컣8O묌QTE[ C:Dz4]ddj`dÄKYR4)|Spηw$Q8ѷ-h}=u-*ˈ3trPZz.;7c;H`'l2s7(P;;/_E[_F7D+`hdZ{!Ux  _;ejMt MM6m*}4'^Gq(;-?TGn9$5빺\mv_;9I_9FGaʯkiԜR}&QId6C\JuT.(EEj:6gϫ/](9 bEM&.O%֖ BbV e"QsNTŧn\ w$2 >_/JmotSQSq 9wNb5 qK( 8]Z{ޢ(Q"IW@% |,7nʼv _rI]Ƞ8}t 8R^~C;F_U]~j *RD%Dp+xܲ|J=Jd#{Q0Xdz9[\Rקnv[yѧ[Gqp::G`6U8> stream xŝ[$uϯ8/ qhZYYv%[Q .ą޷Ϊz0()$]o[z^?{_o~qsYSe_o[yknϿ|iy="ǺHuho>|Oξ_MUzKy3oEsz;V9VP>#+i-Gq5)Grn1Eݕ)j6jSLݎ[JsPQ׻d9wF**[ٞ|)=uC,\7ey:/U^},qG}Tz[K勒H?߼ZLBn{Ҍ?֛T9+kHo.*ŷO!]9Em4GrRN e˶}_|ZoR~oݗV,Z^__||o~՛Neir]i-WSzm{RײYjR/Yz]"߉Vѻ*PֹY(h;-[]Q]+zTۆ2L;n]mGކ2\;G?FݵcYoڣc eD&x~ٕ M%QC%!e-!4mQFIr^UJyJJ z9M+յVGZߺQ];DzWFiEl뭔xКY%#CJDVivDTפJ}~+57/#iJDu1-jQUUEǀDTפ ɐ-3ꚔW" 9ȮDPך֝:()?+mbQwMFQ.DJ$s-F}(5 "jCQIjYm)c(2C #H,<&kJurUK+ښYe(յ>o2P"*-"}ϕ嚴 *Y]ɈWG%mE]mZ,jJDu(Ӽ(7 !BjZ,fI}W"(4ڪC:;JDuMVm(C{Qe#$g"FZyWFiރhRQC R%c(յ>T(ՒBA %n)ۺQI#J[2\:ШԞ1]u wKGuMFˡ$kuDTJ2#YtW"k0HCжMgPuh?ՕZIEGxT׊$ճ!Xl2#ii(Xlqy}rcrԡ(d^ jgWRekCQU+[Ԯ5+ a>/:;(C1*kJDVS̰TIu(#ʵrCz"KGTiPFilُG JgWFiG̺Q](2:rMWV>*"(gW^M %Y$/s,w%Vb PP"kG̑w%BӵV+:Q]Bct%B(ţVcpQQ[OGjIQ]uE]u%Bfj=JAWFk=O\d6}'}Ud2)յ-R} %tQwa1/iw!bB1*uM!]i 2JDuMɖG.xL4yPW"k%VE w%\+sqJDuMzܣtʈr5,ކbQCѨ4Zm, %!4ז!e%ޮDTzU3%Bqȳx{UDW"k%F=Y.+ֳճhʈrMf ҡ}ӥs2EB3gLlJuWlDThW5?P m҅RϱR{uMG Xw3!DKKA֪{JuXweweDzuo>%s,]~xrɅRϰҋ?#D.=뛀c(ҵ[}&ؕZϭ01 -j] ŢZyUfBЬ#ՠ@믇Q]yՋryUݤA(ZMMl`1wUGWUDThU۲k'BԳMje(}nr12>vţֳMC S՞@y(ԵȪ6Y| yei?#BMVS:և!]k1Ҿd+յgTۆQ]զ{@֡xTj~[u܅ iT|b肇tl*=zz6U%Bl*eDvD6m_1wgSU)u(#.>Y`[Q]Ԧ{PTNmw%T;u].=z;m(յMV"ȥ|J=eŘ}|yG R+QK T}6uȼ"].heP W"k=zwOCȸѕZϣRusy(ZyCu(5G=-ZWUQu"*xTda7cYTQv>I,j:k߇Q]TtW"kE٭>ջV"WG -YQm(յ=-w[ͻ1C\jƺ>w޵ԼQC\jkR(v%B;UE+յȦfۻQ]^lp(յȦ*SxThLؚa !xP"MS}]S%}C!E.5kX]\jYICȦJIGW>OՋ_uСhԤE6uwq&of #d }@3 b @̀ @3 b @̀0( f@ @3b @̀1  f@ (@3 P1 f@ P @@gĀ A3 b @̀P1 f@ @3`P @̀1Fe@ (@3@1 f@ (@3`P @̀01 f@ @A3b @̀01 f@ @3@1 f@ (@3 b @̀ Cpa @32ƀ01 f @3 b @̀0(BeP ʀP1 f@ @3`b @̀@1  f@ (@3b ʀP1 f@  @̀@ A3`b @̀1  f@ (@3b @̀01$2`P @̀ A3@1 f @32ƀ1  f@ (@3@(FeP @̀P1 f@ @3b@e @2ƀP1 fP @̀P1 f@ @#2`bHe@ @3 b \ f @3 b ʀP1 f A3b @̀1Fe@ (@3 b @ (A3b @̀01$2`P @̀1d.3b @̀P1 f 1 b @ 8@3 b ʀ0( f@ ʀ Bp 1b @̀1FeP @̀1Feb @3 b @̀@1  f@ (@@P1$2bHe@ @3`PHe@  @̀1  f @3 b @  (@3`P ʀP1 DpF (@3b @̀01 2b @̀ A3 b ʀ1  f@ (@3`P @̀01 f@ @3@1Je@ A3 b @̀P1M;U˱c}vm 1i%MI V]lgͮJd쵸b3X(ֳ#ݏӬzU(K5e}h?r#K{/>_E .E_ņm6SДtL5FݔE.c߬џ\ /}K)6kb{6c^D.h|J]~KT_ĈP@4\w3$9kX~XoSWЛk/QUU{Y,1A"()+7͋&?"|G[L)>K[WM"_^s1&i}=f[V+e+U˭T/ɿ%=GJOEs.۞fJ T(ۦՔ/&Y gHMF!wel_Ki'_nYєJ4+23ŷ-fE4)N.r.OgEM\mS[j^^bWS,t~1HiVJЋo՟]Jn*I߉OܛC:6mPj[Iow{)kC-Z;aRHݽb7UcbK :Vӽ/]#ֆtcG(W<۟읳z_6X:ɖe~)J;GfXC,ݔ'/ rnwe. nj>Q 1Sm?{֫ݳ hhsa+”\]so} ūDIsHiaԖ%e~4#Uն$-epŷ4ku4cXJtQNaEWR)(:fP}nyۼ].zkT[ݖ}XÔz=KSZ-Fj=QSHoS.fr3%GiyK M[UPTڇrxԗfuX2RUoS:"ZsPE>䴶mXO"DƺЏ=RGW0JZk]b.u#ÑqtKj?7U]XGp"Xl +o2b{ς*0`:\ç^mٽT^)RG.X'}7:=JeŊ+-1t{ĮRQvXtwK(LJM^g|-+RtF|s}Ĺ7 \G̊WESh YSOkϓ[J:q=~j\~+TT=.0EgWUx55ʚ*.mC9M \-$k_gl%@oQ<6+5nZ2)Ƴ'6}?&Nu]׺ܶmmTeQk(.]&S2*lON+2OϋIoD٢썺 5ߚ\A7mD dzr&oM_Bٶƻ/jRr--|R%Z8׾E/&.&JK6QJ\^yhʡhyD]W/꼲Voy6ZWcI'ȡxu=k۽nZ\Mnge6[4iq.MnYhj㚷5Zcۣuh~kGwoQ߼N͔rVǩ6U7_f< ?pkNhKo4W%Qh qU4}UmU.Mkս{aMJ\a{qKV hK(hDwLǻ.%=ED+G4Jӟu[_ Yd|;S(ߦNEҲ-"Mm(J]ԑ)ݘYnm~I:mDuU-QգhN]lX&keV!.1z:I'YĖiۮ9Z\v-hT\jZ|DDt44=ȶ.)(9K,d#HWu.ļ` ndJt}=*S.)J)P(@fDu4_}W樾e56LQ?Sk5m/0 O_>dA?>u~FSe]VCRK^otGmo$&)C?}tٗgO_b}\[7ə-9U_ȿ{zY՛>9}]{Q㰽݋fO`ln7Sc^jbz'-v?5PFsvn~³nKQ߯No)j[/cUo=}O?+:iZt;#yUVNdS'9/0V W9j=jy誾eTAd٘z5vo=9Y;ff ڙ63kg4mfWffL363kgb̬Y;k3qvffLL363kg0mfĴY;i3v&L31mf`̬i3vFff|mFcgb̬Y;ff|vm&ԴY;i3v7_mѴY;_]31mf`̬i3vffLL363kgb̬ѴY;i3vFf ڙ63kg0mfLY;ff팦j̬i3vffLL363kgtm&`̬i3vFff ڙ63kg0mf`ی`̬i3vffLL363kg0mfĴY;i3v&j̬i3vffLL363kg0mfĴY;i3v6363kgb̬ϾLL363kg0mfLY;ff ڙ63kg0mfL8;_\3qm&`̬i3vffLL363kgb̬ѴY;i3vFf ڙ63kg0mfĴY;i3v&\363kgb̬Y;ff|5mfĵ8;_]31mfh̬Y;ff ڙ63kg0mfĴY;i3v&L31mfh̬]363kgb̬ٙ63ki3vfM363kgb̬ϾLL363kgb̬Y;ff팦Lѵ8;_]31mf`̬i3vffLL363kg0mfĴY;_\33mf`̬ ڙ63kg4mfWfLL363kgb̬Y;ff ]363kk3qv&L31mf`̬ѵ8;|י63kg4mf`̬i3vff팮L31mf`̬ѵ8;k3qvffLL363kgb̬Y;k3qvffLL363kg0mfĴY;_M3qm&`̬i3vffLL363kk3qvFf ڙ63kg0mfWfuffLL363kg0mfĴY;i3v6363kgb̬ڙ63kg4mf`̬ѵ8;i3vFf ڙ63kk3qv&jیgfu&L31mf`̬ѵ8;_]31mfh̬Y;k3qv63kgj̬Y;ff ڙ63kgpm&`̬i3vffLLյ8;ff|um&ĴY;_]31mfh̬Y;k3qv6ggb̬ڙ63kg0mfĴY;i3vffLL363kgb̬ٙ63kg0mfL8;i3v&d|u&L31mf`̬i3vFff|qm&̴Y;i3v&Li3vff팮M363kgb̬Y;ff ]363kgb̬ѴY;i3v&L31mfWffL\363kgtm&h̬Y;ff ڙ63k|1b @̀1  f  @̀1  f@ A3b @̀P1 f@ @3 b @̀Bp (@3bW(b @ 3b ʀ1  f@ (@3b @̀0( f@ @#2 b @̀ @3 b @̀0( f@ @3b @̀ WȀP1 f@ @3b @̀ @3 b @̀1  f@ !0 @̀\ c@ @3`P @̀1  f@ A!2(Je@ (@3b @̀01 f @3 b @̀P1Be@ (@3b f@  ʀ01 f@ @3 b @̀P1 f@ @@0( f@ ʀ @3`b @̀\ c@ @3 b @̀ A#2@(  f@ (@3b @̀P1 2b @ c@ (@3@(  f@ (@3b @̀@01$2b @̀1Fepa.3`b @̀1Fe@ (@3`P ʀP1 f@ @#2 b @̀1  fb ʀP1 f@ @@0( f@ @2ƀP1 f@ (@3@1  fb @̀1Fe@ A3bHe@ !BWP1 f@ @#2@(  f @#21b @̀1  f@ @3 b @  (@@P1$2b @̀0($2b f @3`b @̀1  fP @̀0(Be@ (@"8# @̀P1 f@ @@p1 f@ ʀ1Fe @3 b @̀0( f@ @3b @̀ @%2 b ʀ1  f@ (@Ȧ`w'9⃿~+\?B'7dR]Oa?/W߼{kYm_o.ˠ|7_,%O_}52ISzϞ767^ZCdJУwd8t};|?ҤrzI~8忟c7~-t븜O^ ݚ0U|œ^?OyOlWX7Z/<ҡW^~?}scA[{@:JDM,uD.=2itm}y&ƯHf>\:GYJer*Q3}Z[?romzyWk/ſ̓Rz~rΏ2Ɛq2BUܟKmuEحAhLrs*z YVe5s8Zڨ\پoy]hU0OD?QP}9N- njL !O:wd02ŕ)LVᓣqSULe~Y;%ӑ>sG}!K=MoAj\alz]9&6ѼlsDR{s[I_^{kjh)Hvdu@+5YGծuXtIIw"%Eҿ+ ~#G>~|Zh`zr_]2RhK9x-^<}ظd:Ƅ2fm6&浫*9es#ݥAK XWBj1c[=X:9-U|Wp׉qwcy;hi\-EH?Z)Ӫj+w)zdb:f~-bF:﮳hIoGѬ Y߂/ 4lF a{pVb&~-2oJ%ywZݓv~śѬyL (˷`+Ub/4wkݵne,;.w>=$Gm=6VˉMRܧJh>O_0ٸۺK?}N\j91'99|rQ,#Iu6k/ h~>RސcLU_xI=7~&O/We6d{t>+lSe_-ݶH?nӟL oB|']>bߟhҟ[U]˚ܛ<%N{Z3x ?Ju{8#cۆ$ 6kf>mfI¯\eٮ oA@^?JnI]'ŧ·O0__:rY OK>\J{o$jԉytƹGwKV2Uҳ,="n[Qh7iȻ,K> ųhoqwktbZw͟,)I%Gju؏ğii>ڵ+c;^74!x5Foښw^Szj۫{ mXm_FN߲ e*Q}c@\޷.G;Ԣ,pQ'5մ ;5n]۴ [s!/uWژ#pi;,{/{: lRl[9e[@}{%>hO+_Sɕ.hs;mĽ I5;z|so_}R>v&S;Vj?h٢6_;.t^qʹĿ/m&}> stream x}]o\I;aѬedz ,l3}̓EI~8q"[U(u0Bb0+oFf|˿]t17/v}/e/}~_O[p}we_C- O_.ܾp>/M>wBa"%QJ%s%YiJ {IhYR%vT*p9OͶ*Q*:~+a]Ji y)fߐҽqZ(2RY]6X)}E;[Orv4)3J%2}SJ&I(}Ϥd4ipc)84e=Av kWJVNO)M9 !gN9 ym7|ҙ I~FC&,)Ee4hR!53HBĸY% Y{7JD0̧(+吢R< R |T{#A(85J*&(A;. FSQJVFȮHNN#F֒S4*E$ f"`JJTF e`S)]-xJ^"z*r,y,‡IAĴ/G69HhU# FlF0J*2ǙEP1se+V\֜S#@SH !hsbE(0NN8,*˩!D.'W\(1ӕvto1"S+*n FbJءq8ƸTq^+b.*BA5HFeKކh!LȨYr-YĸO}y"1lr0%:Z꛲ lR gVWIU|[1CD9~3mQ> Fl gݩb%(,E1%h))QCMja kJ&?21Y7 *VӘHT Ql၍B 839kUy(eiߜ-N øG<@2ZƞuVF4UTݮ `e\`W#UĽ6*-7IaPFG"r+)H)M5<-RɨP8 ɖCB$ʹlli"66~A"7aA1JGh@տ(%O9PzfXbN%ipѤR c̈́2p190-11q&R&bB\(JF%`|,Q QrCXaT(t&ޡ m [4FƣUN4yrDL}Ҝ68 @c[$wwp5IvS+%n{u*bN>a R 6aGW);RuqM)ĴK,6"dĩq"Q)\|'AI_vUubXCUrDK>]'%*ȁQ [ yg ENQ6=G,fL]f0RJ'0)9w4A/8cfHRqr BEDR]D$ynQDNS17\̟qbQ1&;w^TeZSQpYw֝iP"5"fPkX"|F_i!$hn.ϔE(ĖOQ)t8&UBIh@"IhQ&>LjFPbtbuB\8i1d JP6A1:$:R~K;1!c TDB=&%Ti[ReƑ#F\D 4a2CLIP'p4BIPr#ۺ2 Smt*GK#F*BhW(a*%﵌b)O@ E618?%ꑒG)Ԕ=Kr$OH2 5!3Cl ݜ""iYI0WcW`GsyS4o\t}vXB39ȁ9#,Ɣb%(0lBٺ{%+gKSd2Gt*&#!KV3}VlHSyLR0dShU7GKHdO:ƈ{oJaPL Ȧx ֋[P=H⡶X (!k q ~pWG&2PBr2P27`j^1ʣp@YFytVx$x䲕ДGpFsDRJ'ׂnms,{ E9h)e-K atSA(vmkV\NP8:`>U҃>U9*BsTD`6n;q2ڧnP1jIlbĆ>PB"·PA˳(ڼ(Q`{!p@KO l7(Qdmv Ơ~ mysE(qi'xkdEquT gNQfjaO&O{tC)Pe۵&8tVJ6p+Yb~z3B(ey _$ M W)OYq" ,Fm+LPhƌPdtV0QB)t1AQ$RgO(֕%yt- ȣv+ etzTϊJK1IZY<Ҕ1X ɨYԔ'$Ia'l=)7/!.44HF+ m$:RN3 XG 뙊ulEL}aE$cDLRuHQ9tkэ(}qPRɣa@)eDSy69f]?s%uds4n@&LJ&14R #>Ϟ 9?ɾJӶ<'E*1Z.rwPUN5JA)\^6m̑(V*?!dl;'v,ȉ5OA-z-YeB Qڠ5~WJ1MK0 őuLqdTYbĜ7́L53MTqڌS7xoSbwS)jBd4s{";+Uz'HRBʈgE| (+WڊRrϜ؍A7/=Ě惒QB$<5?b$F6ڼaF@JڡYz)*NmͳS)IQl(u`ž9s&rP4(Hn1 Dq@N0LN[+,ZSJUPJa,UsS$S$`TN06tl|s舫J; k|.v$c-곳D:Xl` "4q%/+O~_F <0[ Z4jN*siQ6Pٔ yeyTE.}5(Qdhri]yO.0=3bDy;]ѓO- T]KQ&=},DW,|" E%֭__|_U{yZ^6P4uSdxs <3p <3p <AR3p <o3p <3p <3p3p $ <3p <3p8.Go`[YH7t,m2Pb0T@gRRXZQ70U (َcp`jPX]bOE6ģrQôiAKS0+vZmNQ+dA@ayf/{NѪG0GJz֊B:"),,cF*lƂ~_}!LPůBi(}F1KMɘGNI`>"} -V#jy_3ZEDB)nS7#1Vn)w Q$lB gL}V(g :Qeyo/a Z!Drōfc2`6CVr*H p@S@-t9*ʳ0G@D?mh\q ܏~[~kcl>Eϊl@XlVH<s54RJV:ifP=ZֆVB*ѣGCF|hd`8XvtDKXG %Ҫ  UB,uV֐rcZGE E5\T" nk\byc_⴯.40#nVOV֑7| PP,Ų!h'VƙX62h(yS+I{~]o֫vxiL!mK0R$'FUOa !~U@¶ + 1 ^.b&9S3 TI[hv%#&7VPX8TT@m#U# 0$TW Ik5!0mgjᎴɐxھa!l֞2ShsRm4p(r$6/ɺK!7-/ ~ ( \>9J$.b}L1&K8b<[Q^iŁB0[ *T4 vD&~LO]Gv~pq,Iic0ipM! G?y(A Diyhj$[(#=٘N="h}@¼fijCmhfg2,c|-eR k5èюovR;GT[ A)#@5 ̆xdS8co`-2 mU@֙BIQ2MZu 46#C{w}ŲAŢ1Xl֤ad d2!wF뜰g |A BprB H5=1qj7pG _3W4 3%Ӧ*lM3Wm8ϮLU0 DC11$(.wA"s$wBqP$vOA(,:"(,.q’S(,h "(,,H(e@ުi2"Ài~dL hd_(I.i#_t8v+J3Da`QN HO  J,v 24p`f4V#P3l:4Pt zqt7j\,,p@j0,078,&(45!Y@m.Y(PvXbރB1ffA- "#Y@h!@L$Y!@G _؀/%Z!&X"4ƮALVeBhNz*P`YiuDxjϊ,)4n+V%pB?P@]h<- (yk<`X , &-XĐԯDJa}(N>N$TL+@Ѓp[s>F$2<4#P;X}7{`jtI0 ;6@vxZ0-B@a`뷺Y Xޭh;!j=w,ql{y{t?:"Z`&!T bC:$5`4 X$ sh׬`1UN3`h<†!n#EAKbU#Xi Ձ>(Vt0XT]O0T,=ʁNeA0-VT + 8hdpPQ! xl-y`]74:F`ipYHjyh(Joư4v3Xkd]pB _6g m 6]`H-1r6aH{WYRX%_mxR xKbA@w|̻uQU0*D? P ha^ , 83Jae6 . u󯗞Zyk&+Ľge,>&RW2DzŁs9VZ;2{@C c"+HKoz+Xk8aRXE+mA&iHfe%K,@[ &] qhz\DݖP yXcQyqy˨nc"hT0UZX*]3F5FV@밻Ű(XiQP!8qËEc]#CV;kbukkM!5\Vr`M%-*!$PzdaĠٚ߬4h# 0Vn zYzh# @u6'"5&X;AyT^X[;{BWV`1 X[gp+ w@᪣^KSدqY;F LV-¹Ϸz+fՅQ ^`%D [X` iX=YS w@172!56j7 pQ*"Lp1$-Nnj-;ql1l볍[Q  nEX@ |4Im0rXpV@4ں9xoآ&6׶uhZz?X<9o1s Ĩ -ELu{Rza-`=c"`36MX6- ø uc=Z "ЛƶRxn0?M$" B dS \sDŕ߶fdF|w/ߠ>""N.0.zS}{&3A-"A. epZ\H R0' `g%L$3Ǡ3D3[yPTd:Lѥz8mk;Zi_دg;IL}yA@>?_MH$O'͓$3|q=$;p ? 3F.{hяc}p7GF.۽ف672MpC D a«8㞀RNan5"_w~YliJ%X;/ E[ )n>Mx9/Mb^n]A.7\>Md^V!~]^ex>v*,zPV* zJV>K )lC.1 /iOVEO3U%hʁ$Dɘѩ#:Bܽzß+QdPw/Cx 5#jc>๏+ xiܻ >иF~=_N~]?6w5vM +{g0D:s5wc5dkkۢ"LHe`SOD[,*\?L]?AWKce̊y&~y?iٳ2q%=:C6V NRsR^ G?e=0X|{|tu:A?DFb^a`dABV;u#?#Sepb 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? o}%qBGbdzmj&es ];$chaSGj{e{b94*31/ |Ɂ¯ o6l%ӨHon}q|C6tZrLg&Sm3灡]\4gX犯V. MOd{pIӶb!W6ߧ!c ה?1ۃDg)xQ"9əA8ǫ %RP7P&YӳөwKŔytT3ZCHCb>6E}!E/]5-˫2ٖ7r'D,'x|@d u^޿߬_]p}m{sۛ/v_{g_Rh.V?븽~= Luo|~"f[YϿcCI~y~|sLJ_T*O_ij$ޅ|q1g;W~Щ?S7 D+{ _^0bfi3X}ѝ[z몽/* \Ɠ0%or+#p`G"|$Jג lщ4b0̽ ;'<ͤxf~BzEËݻ/vᛠîĚ\~^˰OI_[ 땛^yf/=??&i~ݏz=~U{ⳓ y֣D^MC߆z-63yМi+Pì$*YmR5b+3sp8b6]Y z{`9brn"GA8yً89)n4gG5+ q-ǭ=*ܯĮ7)tP1UZ'A}_M}xrfs/P,?^41'iZZk+cK1t]|mT ARr>ŋ9n-'п4f /爫ت)g0k͡W&Y#k91a+yha* }hA3zl qh)Acb7q̃Q(0YG-L(s=h5gW- }[$zn_}dʇ4ş?2@|J=WNH*9h>fwƮm#ٿNs_O5>Ã͹ڿO2>~kM^!N'|=l#r':#DKZ5{:5sy9m4+ЫöhG`  ʖRzL, g7T)|>f+;Ye뗓+x@Yޫ(NQQuFx-|"ʵև;,ݧrr 9T8 q2lgߩ-}U,ў#k8*$qғ}xIjVߢht^ן1QlPwxKf?mB| hp_Dz}vB-_BF{zCq z&&<`!#RB2oA %E]2ޗhx%^"屻!W6o^N̉?^g=we%(R?#$ɯ8 tW̎fƹVF hɪ1$}Kњcpyb%ikFq}c@#g̋;}rʽM󳓑9%;3[2lcK݀|+N#i*ݷ=i[.<LNl>דdu?EO95WP$oxi}vJ\pA^49M{aR;*f`qvw6O7P xFV.-W3EL*:MgvX[=4`W5P&ø+'.79P$endstream endobj 705 0 obj << /Filter /FlateDecode /Length 4097 >> stream x[Yo~'#yl=Al'Ab++J"KKZT1S}̒<ί`=_0/䏧.Oɇ]_-z#^\ۓ0/t|1hggW'?u|br:ױs{ͻ<ߐ=>,̅VK#z$ZnK|֌f wƏqi1tw˕`Lw[|-aSƩt~jw5w6tie@  Ei-znqϓ?G ˕bwNSMSx 74vKa`1Ik[|Aؒ=va u .18>|)7HȤnp@C6Ӱt$ V T 6?, q;2;*Ha<(O/Do3KmHb;2HP'o{S&BI[cM0C*Am@-oJVeˠ3|R+% u8Xx#.~1 !CF4Xo.Wp[BSgAaLv/Ja.UZ qШM&t:3<SLQdרٜj6̟I>>Ʌ7HXnM[#t 0I[F 3.fRmR dIl;t*rlM/4+!vC9.oXI aUrkpIih4jEYL2y9Pa49WA!ѵr Y!K?3~K%+uI̷@ߨLI(71Wy$İLn\^G(T?HTPS8<|NJڛ5|Ҡ8#fd4H#B (ӻ%n,De+N[MJW$x|Rд`\)jhA {,iDypchdBRzXs8im/v&ݴiAȢDMFzdO^@&6zg:'?&Mڍ.@=~gd _Vs߃ۅ4_?`K.GSIv꨽v qW8C_:MzlDP<rNj׫c4gX%roKZ-]}>;$#kj)~H )NxfI{4ygoQ)o_g`,dۿUb5:,j)\aҕ>PxmHQɢB#nJq.v̹.oaqxZ"=ue-JS|C7MoT>8s)8|rp_7)D=̝>ϹS p9`ps|lCiX>^rF?J@XƢ?VN^e S^1ric)'X?T; ~"z<龡]K|^^:]8k0s|Q9]gsg$bf"gF S!iήb%U!_+ ^v^gu_o77M]"[_niLJ/NEqnR6~{sRŋxcENZ^`! s}?}[_%c1&.ppv @ʷ/L[4UfW\:|0[}{ô:jbau| M/<84P绛OzB绛~u\\nyO'yef#쁣Hf{O ^i 02=9x֗n:9]+(L1?~OW`viqԅD 2ѽ\vڔǯwAX.KqH"(^1<$1AJ$ b;-9Pd3ʔ҈3e# y$G 0w,_+~Rhv `oeOǥ)%ʩpgx-ڣ54" >`;iԏn[O;  3\`;o~9̑BŘ+cZSUVi}.j+nD)"̸pse dDS݄1@|Ru=f%(+-F iۆ Z=-lβ}X_r:2yJexʆIoD}4͂cq1\;jgb "UF MDf-iHZՆfdSD4KU:BUa-p,#yQe.Le@٣486qԇ\020eRoNs O?F~^QBq .V*Y^JSY4٫VYش=*PgѴEOF;'=6=jkn"ꓔ>TU46f0 =jZ-rNō NlvK$w?*$TlPy()%5ծ"8>NJ F)BaDt* MmCys%3ۑCREj" $QՌ*~+W YeBM~* J=j i.acaՀT=#n ʢCXpCAonZ{kX>?&vJ8e zD3N6VUFDVQw4.]W4+@ &+8cfab|4'U.>Ӷ J|d Muϥʪ&Y iBl( gEA,X`MҜy!ni̽ճwɫe]0ƍًnkiטt+zhRNupD grM>yZѨN_AKXpb㣚o|urEc6H+66y^b0Ӹ n{1SQbƩ@(MjC_ Fm+Cq'o21<+E.b4ׁxTU%So4  *):bMlcR8|"C_ :>&r,G}s8ڇ5$KG> stream xZKoWe`r$8;ɒ]קdwHHS=dXϯ=lo~LJ3x ⯛fsat󫳴6B8 ~s~sc۝u>NqOc#S4{k'[;吤Ppz+{C~-ƻ/[+{).sBjKO1'}7} w#ߘguҋ%{mE؜?v+@|螶O,Z$q4!B\'!Gȅ:s zPl8qRpʚD1_;_iܒ55ŕ^㛐dHxp-$ &N`=u_x+$j5(.o$O* $&Բ؇yk6[V&&7>n$X>tծ^yPO%@'_o)4 $8XO? Kt|RLT3&`~qDŽAU 6hHCUy`Ȯ]) )i.KPqz?0m;du22 tHno ;,>qw[v|N%\yI BH? u>%Q<"iZg!բHT6[O='Fmb:]rleqriv3"L.fdƕ 3T"_aߝp*𜡸q ه6iWSa{IcX*!v 7;%i ͽu-ioFq`R&g լ@!p~ J|>ng 9O ߳0 OP<n'a']PConx4zc$q^8#̀_+K iO]{x!$A㒵2-ȴع.UʡB)leȵ: 3io[54-BM-;&UV6f(G_Y@\?F\5@ 8"ǓyLʻYtC*ܴ/8t6JE3ABY /M_EooW]EJ8!%) 3N8!Ҧ|LaS:&ca3 d @(\A8`Ԉ SΥ:۠P8>O%o [ J9U J ej?-eCF L͓!OݥQ)/;S";8$}.o8W߻Aeo{"`:dANyDS](Q5鶾b|qJI0/%Y*h11Zn+e/.W(Y~[} mЋ/+"I=:,w59`dȟiUoZ3>b¡N'){_Vȇ@)~.Ʀn8Li<*fKLog^!!< sfoLm.ToEgOf7KA7.^YXfDq|hhQS "ѥ)Y!ωf7{l}Yzcѳ-k@YgThWendstream endobj 707 0 obj << /Filter /FlateDecode /Length 6781 >> stream x\r$q2^ /2A8cI4tK;U5 xQa*/^?]Em&r|=.﮾_o?>noD7G[~{}~~4]ŶHcϧ=jhz؍O߾e9/\V1W&o~#e9&o&-,42wɼa "N<kPeJ2m HSu 0S b7{VЫ .y ZGQҴ'>-57b,̽EtfQ5Bt.Ky޲c|6dt6#bsEHvP^*L_†pP5MsjPm%ΐB, q ;4ca"A#!CDP=ڇ ݝp;JF`4E${fnBϏRd:.B+] ]|(595#F1#I5x(KC•%tE0Lc[HF /(-4էC U$9ȡg '!:z T0=$sbQo@a`択AX%J9̫ݟ\ X]D΋l=_V2Jvfxstp0E TJ2fa rջ2@ѻfRe,<-^(_@g oAD*˿q掍#!l\.bP;vc0tˊh^X,wЭvq ܜ~tƨD|cCxPLy,8hA~ ?.Hg/{pOKg̕Yqn_{`c_3!,Hg5""M 3yq9=u!c^ zo+(Z@Y;"8S_:.ڍtZ/OL!_{&#<+b lϊn}Yԙmi_ɧKI蝺\*c$ sT_6 Wp > N=SMJpw;]qz3uLeG0혟\2%5_El gr5Xs؄ F+vgJ_S:䯠=ࢳsG%½Jy>+O4YL隗%>S՜+[^\ūQSzN xW\;MiW*4%%mAw>K]ڋM)v,p]VPZ3Jv3) 11{(=%th,Ւ0f9&2X>ф2Wzj[p*͊9dp8/F߷?\.,aWy7ߴ?iHT\=ni |GcY2;vGT[h2u+ISW SwY5lAZ3ٸ =p@+5䘍2L1G. L TVX8[ {"أCw^7|sa} se/y/F70w xV07PYR GDuU^j=#2J;=RDV)P)[mj!eA# A\iK}QU.da9x%u/ɘ);ݮp}<͞6 L/yD+'(}|s4 0/j8p.`¢O'^״2 (5 qc*;,_4ow,* .Nƣi>Ż9}⤛BQ_NE;~=ꪄ_[qM (BiaYHHM<~v~n&Y/|3d.N$QbQUnJ T'qeQ۸ViOLVy鳐75 ^ Z{q]Z<7sϫϷ/f  ٍX:®B% cEȗ3KI,~kĚf7TH&3'A ռ+,_ވd<mXٖ˼' 6{W ULʋ8hY_X":@bJSP55zXұ䍓?%f'kH%gArOO**=S6gin3?:ΤF7^CMt* JYe-Vis` w*-J^5a:uS;'״pڍ?Tn<AG8I=Hj֒}qtNV[TPڨe gOPVfciC>nn6-+p9+rQFҁ-|KīS i֫t,#NJ #jKˁ֫|׉z)-]l5G7\Uwj~Ó6_t#b/Y@:l>Rol6/#0 D@׌AK2! GÙ8eC¢!u0cl[ӹKZ[Z2]Sy oɑVޑB нp'̬{NX)'M-aP>-'edGY(yC䰦KQ>>ّȫv#:Yl*3(g6o2C:lBz*/A3^8}y!s^g< ! Bx@AÙ!]LpfH%Gi83$Ss(ݤX6. D+ L0jR8bMY@7|Lsv@])KSaR!UxЋ[t7 ?BqeU9K/n;^p("Um5*>Ԑ5H-ʽT4y%9逊@8Li6B5Dn]"dr8X7 S E.9Wv)gR[7" 1,,=ЍH)I_Wk 6o!=iՅN`!mFW󽆉`LFweEfol!'sT{/.Ej`&o nąAuYuVne_L8)_e:+H#ы7ݺ(ؙ_aUF\:pN`b`I3J1~h?.lrG;~PhFe$zdcptQKr4xz eg2pall+y)f c'.ҺJPe./t9|SԌd|و g:px>dEO٥JKUYv ۣKm(ZҔeCoʲ|rIfƛ? ۙ3ZOgLIT`R~ ;Zuv6̠:msh`3\'H3ӂ`ܼ{<v-m'7S7TK_R;y1%>M0/3&]L/ _bB!Ow#wϿHP*aƄr/9^'k wh /?ȓI/Z 21`ְRàJMix55,FB3(ntPQSy:Q-v))g51O"nޟ>3kvwiM~|x9O&aw)?͓`~[hAv:l3 lWV)E(k}cw=~< ϵlv qӇ{bw魔;31J%AESj &v ;/T/ur78_FЋD!5wwOѻTy۞܊rW@ϥv;/_zF4E.\'Lz~A0[H7<80M%.wL_ǣH-8KH{Y86!|M?B_9lʲhͰt{dn@@wwjOQ^@tVZZFTawypu7-qCRgd&a*)_)mI$ԩ6)P{H3x%3SJ۩WiGqZ.y} z0^Ms>H(˧28ue:h`1t@JRNo6ĺRl~ [l-EtdlIkl{ _߈Eֆ\-&R{ ?u ,/^i).)GJY̠М$??"JAv:*?SF} iU4otF\_!OK򹠛S)7*endstream endobj 708 0 obj << /Filter /FlateDecode /Length 4245 >> stream x\Io@$A$D|rHjI)ʯOUuL2GʀჇzZя;1ɝϯOƆ{}㉤_w׻`;)hڝ:IS.I(wŰ;>~}8S1|q/R%>gSm$KoN~a 0/_`D?g#>Gbn{8U~c3يYh oak|EgcƄpj+vlL~#rxq5VnйBwX@wJ`H3_:O5Ccu3SіR%ރsR{bwUg"9͖rZ#@blCSQgw2]O1EB&e|7(AiQXD9]$k PeRѺϵ:hcZ+jU`kߕökaz4'B ޟ'7W#Yy>(H'wLdA8cHQ>=0CѻNSQ<6M\.qɭ1W*"t]$C(eM:"PkE]J/$ 7R y)D@5qwZM.GPFmF826hPjT5B MkU>Vg6 sf{zY@5ʬc$ˀƷ$ƻ-4%/iTCc\P4Nt7e)vD(` GHu_ Zp]?¬֫-s&hi] "z":ZK.ڵ[?) aUsr*1kEp18]k/0d;TV|_k5?sFYgĞ_<2=VO* ULӻ< ?21#j][f`h쳢!pI5>9Vj|/`}Rʜ$$'9׵0Y#8ȵqr Kg Vj3s!0% #eKFIAŒS;W y+jc%o-,_)NIV>6ʼn;FC֚;8UZ.lC0 q2b&Ztmz=١j(\ɳa$tApbhh.s7IjMZ0ed!q[%M9Z2+-%KASl0"=_ϖIG7o ޑhM#\NЎOio£č_6$<=V^1yZ)*@S5V$GbU9K'팥-ȳx&t,fs9'n[mqmiwOb- g34HCػi =:]6_,^7uءf'u]2c*C qyMp|搿:9j5Sȉk[k`\%:82^IEHW% B)+J G%frXϓ8Rams\_MtJ#<%:e Z B^uھ{iot;V 6+!DH6hDHdxQ$x2 7%%-6a1>izΓ: h+&7 ô+s>|q=?[l9B}Ag%/ez^G3A0* /dB0\kmRB#-Tj_tWm茧FSn bS} a(߅!u..z1;mׅ氊 nY]=+]I.$Yϴ ٻE8˛ ;K2[*Hl ݈SZ3 h8v< W67Xx^r;c[ BseP j]B=t[b>ȓs"*F LV%0]oMv\d]PpO3j\1n 0E*UTQA(1.ǿ:UJ rog'_ƛOw&ԋz66NA׻t jO:4|۸Ѱ]-b-K%ul"5Fs Kك9c.]Q6QmB*f'뱼39!ASɚ%0bKuZN.Y8)KיX{=j;׺JZZsg _= .><4QeEztxS.GU|^xQ> Gc#:+@Qխ99BV9RSF ˍ6ErkIxC UbQ9DPS4a;P Z ܀fAehޯi4\o{K*)ڡr#Q`,֋2B.3Tﲺ,`Q:Y\MHp%ax jvqP3VYYCRɝb9F%Bo3*Ѥ^H?St"{ Cԫ=1;:& ,T 8>T:(utφ]JHk\Fw-UQiכIdP|$Ǒs^|q P1A&%y.>'oy&jftcSIOא(FJAa(/o)m#TAok6C( 8!|_oR2E,<،Xu.%,4k)d }e0->J!:lJk:_%AxB lX)/0?r( 'eB,c>9$;V. 6lE`#Ok]m;-ݸ 5m BSd46R^9ajTpXmVjw6T^-җ(2Cg+cHʶfGS-WNiRT {Jޛ] :OSqiWN2pR篅Ems9XlXmYA`V# }8Jnq.'#S$EhXfN+MÕՊE H, XF*)@%®5gb wEϜb:OL[^hRVoe*$ 299<6"28gӻα)T424JouZ 5,HpMZD4Dޥ6[%guFb|wHthx/hL ?\" WM]r±:#jO躚IU}m ɞ$vYȭ5b"ҵ[JMQTT橜d"R7ˋϨeK tP9ۘ ]BiX$=qQ7g'O٧F`@&cp GV\ UZ?[^NDgIm#[_ԂA'oIA+-jDiendstream endobj 709 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͚Pr;3ւlaIG%{1xPW?>Onq&j:D[MD st2W` KG(tM3u2Qg(j2wkxlErQj+`9R( @(I8'1y+=A>Җy1]]K%N>"y+5})&,wFI53Os4knxd2^oNLi#_>#rԬ+9Q]~i_p}\_A70H5x/yd=dv1|г*`brK ѡ,_+BY5dz!dǏ-xج<tiSř_\JH/4 }oMÏjswG]c_= -KDJٰˌ F]Jے!zuzxzQ{t;(,Ѻ)6%@&׷^5(3[(IPݹ6o#\L+xVP=bKg'ͳsU&n#3EFjMI[M,Su_HdfJ-CNïZ>F?#Zbg0XaPO,™5yۣxfS;'0.Z:^tNNm5P: Q5.al Y$!fAӢ<Ƙ0f 5m?뇔 仺ЦM$x9mPjA,)qhed  9>my2+nXPVBV"n+|iJadJӁ^t~Jp[$^RZ@g@xUgdXبF+L C o<>5Kމ&>:t3yn롻-}^!7 H&]3SsG;k$TCtP,J(k@4MB=@Ʈ=v;g|=|6Q9*ҔBEUxf( lA\-f~?@G)@}O+gժ.sfdsWS'}a =h3Qu;jK"'W.QƘ wDV"s9V?P7O,ڽ֋fC%Uvd}m֘.4ËZ V5D 6tD3 ꠄkjdi@Nu%KVCh t N_Lψ|V/7KpS':Kt^\#CT%;@7m= `O_f|DC*^xvzÞ9鏴4lw ;Z0\m%, Wxuww6WMצbޫ|zURHhBRkYǯ1nwFAC;i[.RrY|xD=;;7Iå5Jbn:ՙʧW޵ˋh# 3]39Ȫ B?Q_ ~i: ֮!s`U{@e@z-|@s"K ܥzq:;M:xSͱnxׁu, Fch\>S[arՂȉq;'^Bendstream endobj 710 0 obj << /Filter /FlateDecode /Length 5563 >> 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 GerGdendstream endobj 711 0 obj << /Filter /FlateDecode /Length 6341 >> stream x\r\uݗ"Ѓ` [!uHa+-/Z@@ n/>7Ǜ^d;"ܓwʬz _{qKo6bfn#ӧn EEWW; &Cؾ|7]ON2s qZO㇛^+,yy 7*ݛ-W/7}w?듓Fl^wۇk7}o._H@'RX1cY W0|&t]oM.AO?w$}~[ۗNo,c_ONŬ h*1#5ӞЇNhvI6|xjV2/mAMi&]G W\4aO7:. R~ v˞r4rZM'<({IOee.ج:qybcHD& C^]wc`mOXpUY@k"ӄh! j/gT'. dh)$z t7M=@&`;RVc^a%geIo>BO'M?٬R&M-jQ=}{oYCwL/s_) Y%M?Lf'0Yr=(_Qt;FZG;G!BB<~dWkl[rqF?=nCøeyL&S"BB'z) P+j<wZd(2"#!aklGjЮJbBkSFd4:wKɂ,$cT-Mfs\TUg>A\rom ˘𿬁?bRt ?ck,aWb9?M₁FFHpG)QC7«cVKsShcRBZH]9!bxsh= ^ne5O,YdjM-"Ey#jY2%D 2osDiu4#TIs 晀VEV/)?HPk t+W&e:)€%= >XRN8yY \hR =fa 21pa7iyv{M*b ɣuZKW V$s:b,8}axbl:ܿY!m!d&8,eKxC4 5ۖ˯h0uu*4'$T_upNy5 ^7OyYr27 uԗQ 4yavOOrJ܏Ĉ*Bc Wr-n8rVVso?e90 ag2Yd-)Z1I~QH8ڴ |s8Fg6Ƃ%Y6E9ȣ܃e4|ڛ٪|hA%0191kV>?jY]}~16.M97'm*Q-h>/I|7]Z&U^]ziۍ_'Q7r'v#߂qi'Tkݜ k6D=.Z0ҥsRU^IGF:?x%j ٍ˵W =#S } 'fcG=iKKO>7W0jp4>uq.% BݖtS5:UT{>\mTP䩯gzȜu)tKk-\ +-3aK.erL|!S^J?[bA f/(=Ʀw da "<;RfٻvO^j6U܆ ZQoZҿl_B_ȳ5[ЙNYglA#ak簩!K' j j((AɗDK@rE(iKZbCOEڝԢ1?C!5a cGa=FvAK C)g Ϟ8AM mdT8E44GH ȵD1׬9PpdhXavp ARġ+-hX e *V!0a]ڏh`x!`ƌH4U4fDlkω0^B4 [93 r`Zi̠EeVfxf93-"ZCEO՞9:0kqx/̬;B ҩCFX5|hp|] #ˤ@Hi]9WҢSš8@Z/9sD[j8!J-2YJm + !&nHYNFSlMä R[:[ :[dw ax}ucu,JyIiKfM2h-ʰzrX+lY,գ/׎ NډjǛJͪo*n{ǫjz/=#ltűtDZZ`lY ^oHHW8"A^5DH&oHR"ޯطTo/yDF ёR*Psֈ`ns ?CWtQ(+PShAOV`?7fyvȱyPy!)r?UݴJD:4y;;\)0)dZ>eUX_uӲnlG5MmP$`5a60MuNiyB.1Lkeݱz}B"kѱZ.'](Lnw~}x?}::˔ P@:TT؎ IE=N5U@6?U־80.d\J$s5tRHvraCE)~Gm1Z3]֚ݝHq׽:k L&zH ^MD ^ d^ A5N"Y WHxڒTo{0{iPm`24HLtԧaP&^h h'k))E*%bfsSp10jSY:l8׭CA? ȗS" :RR43``d ~Vp:[HkEPioL~E.S!.T!dIôkrXn@gٕ2RId-.BTĤ7po213Kk L1-hӘZuZj ;"7SA8Oq+#zkI5QL-SH79.&G)_GKGߘh "D=]&hQFlB)GTí8U"E%AS/箈lNSCli%b`T40l-44(uRV(fP1S( Qr0d Y\X@ŹL1ܑ*R)ZSIDQ `d%W@ G%9`җHL:KxӾ 1ڨ~@ t!BȁvCJLCy_&T>i{ كФ ZJ;%iR:T*}'!UNR䡈TFN2Fe)?Ƀy9Nrؐ LAc֘J.~i!kmii;$§X9:B \t)r9Zb|V_SSFxɖSrJ?F yb&kKÖeNImmz])篿6rA8f f:[fH+TK++T+PO,ZbYxf٤Zf٤Xj٤Zj٤2#G#⯝[.u%S -(W%S\w'D1\D%"(M#a(eע GD-2ZS8%=QU,GMǣbhi%D S@244 .ǣվ"yT6( _=B!C( $w.AAJˡ̖#AEPBBkő@7EM *q T%;nXе|TU ?!XSce}YˀNI#:N '=Q(RJP;DuF;tpYeLJUup IG%8``5|av(b1:(ط X(jÈ 2Q@ThXU@;X8l j1æ2X!+Pz"ж3HUj/ X7(9=PtCa( )Z: csѩ!a@xoO;зsR4}EfV\sgeg85r/켠z暢sq -% >pM):owpEw䊢-Ī(J԰׻.KKRg%?Jܜ20J؝^%`QSF:5hdu4J_m4]a ӈ/rFP31:PSiqMUѧhLaJ 5?%3C32BW{TkaR*?-]j9 >ۡxL|*P's[A2Drt^r ~Lgk2 _j_b___~U~Ue~Me~U%~M+?nO%~ ~]MGΌ;:tC-) &{+aϊ&tXTNƠ9cQ'\,zy ґԕ8 guvf)D*el2M&]$2<zlg̜p"XؚԒmZo9P嘺 AZǑΔ+HH^r$vˑ@Õ d+A!kP۠o~XA!PHjm|"CXr!`Q W:+c3—ڰpaALłvVP cͅ Db9v괠T%YlPh|rRXHZ5(( -T(t)}~J?bc.z~o&uhuݝPUh7!='=.!gs{6=f<]NyB F?ݜL;PW=⽡/4} X]au u:MTh?A~ ]OOW駙cVԃLZvk`RWP3h7Nʇ@XAχ~DȿDJ#Q/2uiEywGۥp9yz#5KI%Yendstream endobj 712 0 obj << /Filter /FlateDecode /Length 7922 >> stream x][o%qγcGvNN68Lb 04;u4#oWuH`kE._添qPW]w.?$B9?ӣN5w7'~*D~x2~uOC;F;>!٨KJ-5j^+YZ0șj%`,Jx-g4JxyQ`u7kgaW]%fXK۽|}RHVC"~'^^|7AyQmyN{W޷jFxxy% vqGm0׽ hTnӷ!0cTKfV-J. FZjN8pzTFC[c]{EFie] )ϖc5L$kF+ QzV%\!Dɢ̪]~:_ܝ*7cww]侴JɎylTvwУ„aO?N1kLUɃef1b:lE}s5XxUE N8xRoHT1_lGPKcuHoKQ gHoEHv.qH*ueFj<\Ҡn*jhܒˣ`a.{޽;_u=(9 : ¦짤b$! (eH$̀@1كJtI'kY2A^ˍ`Kui/GP)NY&lGNj0 "›! IU6R/5LSqU?MNqE &`D A4i)ْmM0HjP9 tDmMt ASL<2(1 ykPB^8NPjVB^IAlQҁcbXS^L+IsYZ D^AS*V아-"奝rԉSy42&J+'S4bJ0@ji )'1KӁV@Ł4X@u}T Kc->#6[54 F6RMiю-L=;,5q Ӯ}crYqh[%[کAl'XiIC4b-EA N9IubRycm b2X7`mocPWM0sr'i>F-bbſmJgv!8h;+:UL-5*Zv^ԨSlmS:CȦ-})܊~T,tjѧاk>*vD4G%(uÅkcC1W93Ÿ>o!O/O}B}Op\.5bJS[NR ^K <>B4Ol '9mC%(vXˡ,YBq%SH WH}̯X Ҋ"@xn5j#),t=]~%T]ĤT,wZ_'5D/ZVݑ/gGì0?gBǙѡ:Go)}Oa3=*"dI߅+TA[V;x % `X߻9a'ϛ} @ @YR"4)R[Zp=Td+$u53jxQX9ٿfCUbݫ=cv]3_x|N3g:j;zތ A7qv*f&oo{z]}f|p{.[b)[JB7@$c |Bsٙ“#C g <^PPEgz$Y1VAj;c]#z[B9wn.iF<5kg;CCDXi97:*䯊CffmԑhAV\zU7+ Q5z "`',Y\E7DER^tϞ5WH-+wJ&̀-݈ءfaBJ7+-E+z#&Ce{&ˣɧ؂z7 1{ fJ%fʐ陁?Sڌ:bbo+Y*.|_]Q*6%qoک.ݼ#gKq0k OSfFGӪl\?V󹐭*Fe-,IY*R9u9.A"/yc %BGyHc) lŻ4kw@#9ſlc<sMi@;P3k%htVJYMS-L!u2)ҕi/7y3/̪Vs ώPo l> ?t־D.ynDB &h*2hQqiAyF/`./D:C ~ڟje*U\RRԫ&먪RS x vH/0,r#\\u.~3#r\5HЎ?VEWF dT)%GMͦgp㍴-0ͣIqcp~,0ƥ̠x!h?3P}4 xs+wWyJtˆ;4KțRC儑ǂ-eo3BN˔7$@S[*;}lf:-B_WE vkA6w:6T/UtI!Kox=33i^6@51?(n)}9#8|򁊍!W!F[u C cΦSa0aeyEW,56 ($[U˱={vf$PTLD HsIi>~2Ap|U.?@mQ*V慓l@OU\0H[o t$H)wfsHu 2?D=.Qی1^z:?gr)AX%R 9!񱉤V/D^U M&cHe@ EZlȏn zbzб2Q49v:H/ 6+۹\%&.dINsƇ3u?"MT"kB55yR*mX=5wϹpkx2)LhlW<)&ȧ_쮥n+'ו *Wkc@B(?+^F`Y\2m:_:Y8REVD#O4zG+V--:#comy[jl~өMx~B*QwlV]*>e|8:敞x77]FP?3PhR0|6#Y, ).o$9"|)OSl 3A׋ec1éW8 ?~3$ص-:F@Ena.S?|tu,JeM㓅CpTD FoJ(9c2){[^71ޗD B? wS ks7->!2)}hö!}:_2XtU:|l ۧ7P/bB.qUjcKՀcqtWͿYdʧ3D᝘v1,f/%Sq΅ ٲ%,Uu+E4>[_酪$:1<Ԧ'ud@-lZcSWcBf3 h">:q"@O ,ԇ^EӎVGJȋNM ;4H#72υ(ߏϣG܁&ؔkeV*榭#):;2o'edTq,EX>TQF^޼s͆{eڟcCvn\[=j{s_nF4(4 Ŀ*_)hS1y.Vcw8z>f(r꼲l'݇xc0Y\5V_ՋZfh\ջB^NܹLXؼ6oJMV[ liҰ rjMyz۩-TdnC56o ެhKNQ`do @~(ĶgLƊGf9?' VP;>Cj%A[rt9wWִogt'gttKF,%Z%B?u'eyS>#Yw,G\ ]=S$!&h_~Ys5J4psG2U Cq\NT<4'd|[@6䨦Mqo>T(p~1X.z\acVS7-$i7B D <-TDsGՂ'k =#Y?>ѲdNwkQFGc>Q DŽHӷL &r! l4tg(_#oXPxawX6Z)kؖ(*&R2d hT\ݴ6 hQc(pJ)oNӡ,5:kDX*]P3}otpݚ9YmS;xrO[9*=8SD5f##ft.FLB*dH/Sո/kG M.*&[NQЪ> E] ɤY|kiE7i0>Gz!ud6wsa(+۳}^{uct/O!6oKxT׺R̓endstream endobj 713 0 obj << /Filter /FlateDecode /Length 5267 >> stream x\Yo$q~'G4ncTyg k2VjiF3/Y vGUWw3l:Ȉ/扭f/Vvh^}<NWr -Z19 QVVMple룿f;O9Z < .B,7[Ƹ?/6Mϛ0j2֭nó|Ծ0՜Y̌3~ Z;'EF4!2q wN1MkK^r%f?"#7vR/πs7s3Oy6ƞhiS7i>J,]@˖K`Zma/qKb]ݥ qKD^sH/ooA_߷YLB/Ŋ)[oj+$ױ -nK|AHὰlb֮O"^>s< 뉹Y 9Zp@T)i~K g$ gu?.VHn79e DYoG?{ƘK[hE;qd(~xcg (mXmkFu-MrWj0]RMٗhK{uFpZzIF=w%6 h>o$:kTd$,WĖGM_]P-IG3T, n#/l<#yo3 _,eאp#YSZẄ}Wa:QBp`خoyXY.o`Й;'XK\sa:ĺte,̄>^{ ,oSg/iuA lgGw(x8 ÉOKUG]l5~@na\t%$1 |̰La&0<{ k Ip. 0\d)9;#`ŀ| z׉oka?PΉJ k6 CyYa! ]i_=Ļ98`ACZ ܠ TAOik9 +eUMsb 92dkITVͥf ^!ֵ~ Q1Q6Y i= BH0 hRثMZcLHiH#wge\44e02c-(’CqS!퍫!+%o)gA*I$ڊr4B"\j@\"(D.p4&HOUHotD WQJo}y_0[s7f;b "{8O4^>V W+̼Le׵zPk'+,u$Q_PbT?ɞL_,Dt6J>daW"1[Qαz ?Du-ԓ9[1*M/Fg9>kwupU'3-=HաЯRwVq\`t b"\LWֱL!้uUGnYaS\D 5g@xcXjk&6:ˈV5 rPIv`:AMf/l՚]\ \v2) cڙwhD܃@L#C- &.#:mg=x[ 6;Y9@0k<ҡϧYF?^Ar-w U$SGc p.R&WpmY>EAz١ 0uR?k*Co 1s=8%XB[D{H.׎Se{] 2flи~x̩A I9k}RW8fz&x^[ uItClD(=fKJKP )- =zjcWiNXEtB52As I`O!? ˲e;r!Q̻lu`+*,s"cL-1秩&~e>pYLhZbhkdPr0zT5acI\HVtTH$S)o[lh g2`lRk< v@\y+V(1n`Oi_:#Nc D}\*mbJ)֧r$KTx>h!?:U(mK||S$LA>Y&(a!/6!-Al^y9V s7.c 8XF Y><Vj#'{?'.ٶm <$mLL^ X%2<7D %@A BOwY #L-ZgzljߴGC4μoZ糮#JX0JEXQ hEJ ]CT,VC-4^;Y`Ҳq)r*֍/G|i ;c_J(\I%-jEZd<=-xH>l(IW^1Lv<91{stR_ER43K9~e-I` !8{8*3LZd`*o2)79 ]'Z gqO-(þe[ܤ͊zsǫ`;>[fcD)gZ1F/l'0Xt\MMzGaX!rԲ$at)󕃗'W1\L1Fu}}+ +PD[Y׉~"KR924 uADLɡ `ص"wfvq@c]kc}]΄V# CvzJtitt Y2gmY޽>KjP!D&A?LMMdOYW'76FgwWIse2!Q* ,V*lNϜE4`or=V:Y=eZKu-BLڲK3t4qᎫCK%E.M˚M ,QNz$}YL`PLJ M-TJ0l8P-Gtk\'zAVdzh<}??xڂ ?9=+r3!@&oNnٻͦ3qbZNj,O^Fn̂:?oFDrfmlW|WFdtuSn'.%M*phFeTd[:{|RURf:})JmVnY>LV- R4bC$!9\ pAQڋO馧YgaĊ) m;G$v*hjn&|!xEa `xxǁڡ0)RGJ &zGuy?J VfM7RaR(amBgcbބ; F)m k(E;^L$e媫# Exs_X'k,Oe!չ :3W30RʂH^@@F` b)q!}Kj.dn\-Vu>f) *DsrfG٦&veRT˛.bL"pDX ]NMm2$۶;Nw\hW]0W+.$-bi1 Ҋ3>[C/# 7q$ꛅv:R-,Wh;=s(H,|cWYhRhu\U0O'g`\=O o.Uzׁ+#{cUh&갭 aȲ6 l&| RR_aMԭ+!0t|`A_7R3 5/>7&dQ4=CP雷O?$#`V_ M'dBSSȜCH+,(bT[}[Txu&d+apLMSg:ǬD秸%,MĉH]#0 Δ<з?*C 5*Sunj M(+e5;WP4.sHxS׻__㖢@~ϭ%haP Et_r،CzŃ3B%M3?%᯿e3^xazX!%'Kk,^+It>2K.3~.SמFZ׻beULh4k z$g] `>5 lqm^!ya|+;re ؒ>b`m)7w6.[.|@ָ4؜Ri:17d|F!z'Lxs/x5/ݯ՟.㋔4iTO ɈV_X8U&7ڎ?0]@TppO S+U{fCViOdR@ b֤y/eendstream endobj 714 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 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 716 0 obj << /Filter /FlateDecode /Length 19434 >> 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#G c=eb1dsICd34ȜUC &HZaZ<3)=l4q B2Y "9L1%Z2Y.OO yW& 7qVucm^3y!'gisl,r3\M&NUز0p IڬgOty=Oi#s|\d&'[i!SjqabsBd⻉mLLnyd "͚&1w&kDz 6z ㅜ rKݥ;2uSgT^f ۡx$IDe1Xxl5شdlV57L&cКHCyh` _fy`y3Ƅr5Y&όR虃hcAqz,,Mf7'$s,IP{lҡ#L킾C5fR?&+7-=PUNi ^⊁7+%*c}͓hv@+"ma,b,%([v$ɛ1;VA\ƷXFHm6URd=l|JWcAᓂis5i+J3q>I 1TNee; `b3&K@962vLLF. 0+lz8@l|~؊j6Wl}F\~3bt&WDvDW7{v6U;|a9dh6'Q6mF>wfbbN1%=.Gg{m"y 6pBٷd%Gm(;B0ӶHDŐ##ľyxUM9q̂m 1؜w.护'baۜO2 <5!z-w+m-&K6hu7ٳPإ:6WNgrٍ]L`oCd=2$aIl4ESN: aK_6Af|D 0K :`bD6b,&*=͝*&%xZƂ;A#J+AZ6gn̉&~Q\h ؟]~ؽ6,qU69 0%p(뱙"Rfijr z/U]|B`<ɥơ fdy3j#jaېBvm9E-,g&L)NuDy&;%ɂa³ 6t,ji,ňeZ&%  &Ov$! #؟K,(vD8IoZF+"oI~n&V~]m+=s6.B^MB Aѓhb̈́` UM%*vl|VpP-1$ȄJ `bd@691pr6Autj'!3IlxІR.56G|mEI.H Y  9(zF\w+6獜$> @M¢p/]5d/!eWgjԭ &8 6^JW x)CQ`lle_Ty|m:#2&"j)2O+FtVN7"a viS_Oԃȝڂen#$Qq){z40LI_Lh~MU+:k(qh\*}6F,&I[TQ1 K,!edisootI{G'F5, 0D8֞FMtRl!6aE9^tM 6yI1Lcrc"05HQdr ~76v|،6q72N@&2Z.zMiѠ38jqc lAw' lfTNPFps3Z.p ;&AmFXsqjTm+B5Oyl1ZtdDiL$ZG'0'bd%p9vTg"/ELT-7MNBasf^jBJ[qBޚc뉶WCV$ ;F6(rYo&C39f*SN*x,*դmI&}2&E;86vvP]m(Q|ȦaaͿ0XJчf>Ɔ<:I#48!VӚ'l6sP'sQfW2R<(3fB˷؈JFm9T2Sf5"/6E6c*tvV8U&[l—H wŪƤ{Mp,gFG鳘!Y(F#TrjQVC}wUeM4{B96]ɆO^j&fFI`>hToBFӱqL`S|!!pһM21/6t(<d mQk؜!dp΍9ߌtˌ# ~v&-Ҕ[eD5;ަ" mx2mU+fOmvkwzˡmj963zl=5ePWeˈ,j\Ӱݿk؆ |5O!ts?V}G^l.T@k8n)J0$2w]`݌p\!(U_ HF aYޯt%KGτG|y@?A4H)L8d> #("Tp#VAA,W2nHOKIU~!F|C0yDbXnc¾}#^{)TC(g>!31Ձ;_ U .C)@UD AF䱑SvZT>&vA N۱{v= R@~J&i­tq^HpK Tp$[]YTj&DairB#8c:hJ 1Ҵ*~q ąH+h#OFes_>HE\rVu||"u^*ME/%[a8~ Q0Gx;t.:3 :!2,(Id2Do+#Y.\PrCYd5JFB8=,.UL\.#Y@٫~*:(OF%# QEJ^,'| Y 1 J+c <ɀ&kEU2[yR*5AQYTDB [\nj2+HΨcSpT"ډ|'}3_eЛ^]SP "7\dH訣ns<@xɪB4^U8ڕ[N#1.)]$/ t}0L}\A} EG!T>RD% A;wǯWz[,euYςqHҼ~JOwF@xL"h'T w 6xDRU20U)@ ++?ͥlld@X )ijBV THxCKă cUԍDEe2i*np`sCpBv%$}D&UE*(O9]drہ Q?: EoGWv n!A`k憞il\!.Wo@7@-uJ"]v9%*(Nf_dh u1ǜ="2F$*Н^ZK W KM͟VT5'MP ^l5ɞ$۲"}jV՘mw8Fhʻ7Deّtӏ*̜s.yAmH7+FS^5^@LHb^WpK[e+@cjDH+GȄe$ʳ#%Ғ++phҧI*: ECheD8^vSBF& (&KoN $ׁ[XYXHyោ|cY!ۄgC7 c/Z(_Ed ;( []d1CYHIHu1ҿNԥ1FcI2cb+(#*jl$N D] 31Yll oh}W0|DBFRɦ xr]JdqnLGn g$'8Eo=6cɶMv)Ɖ&MP.ihr5sdz͹Iݤzf7EXM&̉6IXTx6+&}[tsDpFv$ۀi'yI$7W"фb CyK\Otlr1.S~pEפ8 رY09HA)|dBF0NVηI"(QAK^oI ̲IN{4 9{oœDl MųI]_N'D`4ƢyΑF*gj\FQD>KCd DZ6v/&3ˤ"}\L FTg?&ό`R &/8Uށ}W3ƙY& MӍ:†b6 *ɤϣl<@4FWLCcC)$4.Ψx1&<,* MQGL*p@^@Τ)-w/luVJ5޹I \6Z-(6FER}yHUVf9K`ٛ4D`'P`MH/\Vrqh0C;ҜⲸGKG~6fhC@7_zV#2ʓQkTk$!͋ g6JTfM\܃hRqa`v)5 6<(1>Rb3s8mIAWţlN7HR(A2q`LlǐyP霜#;lpŚ.7LͱjXQ7#0 5C(B_@13ls.dnJ .ac,'JFg2i[e/ i򃮨Asr)Qp7tpxYfYQR6'dۃr# 6d`ś$URɧr9x|QĤ'ef4/(id2.ry8C$w" al8|4E Ӥ f6b|NmR*VuغBAMokX6E`V&+"qbR sҹ={QP=6yy蔍J (3Tsb,w 29ޱ0 \dꃴ66taacVʭu\*dY؜S#Hl6IdGUpm *E[R PW{'lm 2&+PfZWRflbҀCyl [9K'8>=犢U41'6ݲG.*)6fYWL =Qi^cŀQo@0+mufgIw9I@d#JlY2F|-V1{"FKl36+<u m6"%l N$Aƈρ\CjIl.sdA侈m,Qbčl&Qsc2.ȇpL 6k҈J f[*(bv͂A#ā#ZmcjҍhAh(I2Ψn~وQR]XUjD#i}~I^ !͚\ 0JE\CN}&r-pEv; V+Y*M[RW mQj")B8ȠɴGM֎RJ?qRJ ;WĮUS|]Oa釈6gяG1gi0{vUDy<}q)tP*QÕp#3w~ )p#y:Oe:fSsʆ4'1}/B*7H<͞m:&0ÊHB\n7jAk7zZߺx칷7}>Xg=5sv3>:gyv߳LlƳI,g{6gzvmg2{F/g|v38>Yg={HG&}a>ŏu*D]o$x vy-,9S?'$ݯ?|x_w}Zˏ}o߼מkJ|'Ƈ%sөPۥhc'r#oSOoNAi ~d8OCV$ޡ7i+:2]~/D<>0[_p??bJ4:z|w?|~޾糿;/wbA_K~rXxi ۗ(bE#/Y~˗O(q[~~п4[dz~ @`xu0t:~!cы/#9&NnϷ NnܩX?>gnop/__Ǡ~.ͫ(WU#UHq1"} J:_N}; -w[ *8ߵ8|w?Wߌvˆ}w]9ƃ>Uy:ǘwf_LJ+UwB{k;Q m{Co>ǿ=|HFj7K c9|(-$/X\JR(Loy\B͑Bq|;|Q7|Ak9ݶԧt|-"W_˧200ɜC߼ƙ4ß :݋Gwb0Un>>n'=,w2lld_^_hn3ȷxDe:*v~%uQ_Gި?iTk%]j饌E/F<\EU|;^e\m|YYL!_ʧm~jA{l-'VT9*Ny7y%ag%EX7vg`aW2Vf|9{$- \_o=%߿?(>œ!z@v5v?ŀBI)n>KR\MIXGz%owz7v[~oLk_͎qs//~m5rF;q.P' z괼rfd7>O8"wy s^Ww #_[{@-;?w>ofDVoӵyx,}} \Y#kk;o5| or}rFkޟ};|#oכoA,iFoYTȯS6p#lߍ7{|χ}i=7vmٷ&c?hIӠ:iO aAS[6L7z󫛷X޾ QB; ɱ2'hp\6Kxd0Ǖ?nBDX(*y79a2w~o(ltOF+ 4O7/lm\{xbJأnMT= endstream endobj 717 0 obj << /Filter /FlateDecode /Length 21063 >> 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?>~߭"C:i_~sӛן^=>AJ{crU.G]!d!PpD+Ķ)铛[qnbwi]F]D+1M2Lh0`ǿ>>9SH/0bR>;#5b,.d(3>;y?ܘ1Q7cr^s!sIYl.LeB/օ:NK-S,!QW#.f!e/Vq(' ~ "rxIJ1AO(pQNk %)ByDe&`.'##1VsgD`H(d }uQt8\xhWw.qV>2F Q9y QQ,˳8ͱX&XF챪2}2`c֣N,aD(ʺ%dzi4բ:!OR.GE&(qψ] Oв}=ՇT| 9ܚRႏ6%G7 6pĞ\Dpa!MG> >',GMd]9*BO;\FP2bfYa!%) Ӌ+Edc,R$-kgIn3GgtҲ;r4˪ #7[]uɭF1µ]m+QS7 gD!][F 0OE׾FwBpF#t'T5cs5 ~J9 UW|8An!{1J5%cs"sf]Uǔ;8]Q8Pͺdp=N$4fC ݲDu5'U >BDOGHMﴏ#':-z)"*}jX!lɇ! )@cs>T#nl^(ʵ˹j"BEJw>_N8DЈ G q q8v!AD9jd34>ۘq8YP)cYՑ] _ه "Ki>1WpvWbG&X}A!v<\.X$ W#vSuy6?fu+ r>")ǂAFoMTs7ʈj~4SGSNcs?GuJ~2E_镘`EQmqkLQBtԲ5"] uB(8(egD#-Q0K)> '$rp>6Q)2#nuT*>yVs\X8B&X NDQs/Ds%e2N5nwd3bاI Kѝ\TчHd+>"0DE^)MUhxzq/)oEtJ~e73iܖ^ܗ}rӽ1BddV0|!U\W}1|:HixW!n_>!rI")c?`Ǔ50xe7\8 JAm(ܰ|r~A_`7}9N"@w# #J9w*oWaI0'wPeT3LX}q1 L~:VQ::ܝlfqS|B̩ivx%:Eh#u3j@v77"҈KST`*N9s:N-w/&j ա#(-Y,PǏ,WInݛNWʍ). ذ"F Vd[y֎@[YQe$#HdI^Q"N}>g0V=Uq(lˌۅ/4:}cfHFJǡU:[Q+XX>XáI>TitN=jw'?z=ڵ 譏A-Qs4B$OF/J3š0qĜD+8.w<j3CSMMɃ'Mpv+5g 2M >AZ- |mZܱ"ԓX|nLere Dv[<r(6dNu=x&b}얔V*ƫV<^PDWRZRcS\wpI QouB!J;靬9dFXEB$RE-Ѭ]Aχe-ǢY"ԣN>*1-2HnHJ@5GX,gjsD- GQMdճf桶8B[h}>?\efCя%W(x֘7UJT ËVV]J2uĐmEq܈ Ē6+;)=}XmtcB<T}HoA!]&Mᚥ*e4 Tڏ: W꾏V'P;EdybߎA@B*D%B2wJ@j&[w 1]똹=4=H HK(g"rY HBtB^>S8jak!-J-"h[W{FQP 0`K-QW D]aI%B .@*Q!9.iD\i fRh D(p=R-^ӑ0Hg UdZ r_5? skF ZNA N0Y@ I$syrȎ@*B~P*P./㓏lҩBH˯O2˙53*HH4 \,Ăq%ajgαd3P4Ӌ Q0( BQV<[ఁDd5~VEktmAdPa  ҕeTPBd. c@J+W:ehCFZs+u!%i !ÈC>"{cFLR~=Α@e{\#7R!E(ƴAʾ!u(#wZn@䁹ߞRU QM Z A>B:7V1Zd5+'P!<yq@3F #J:ෲ@ @$+$K8+Av%P^'BIV#$(H (pm>S\S@GTHMVAzT. t!J%eۮHI$U"YƦa#d ,M:t{p5׏J  _Z3BVU"HJMn2N6m!C%[@ضD^qzrZ qi5*-D(2<;`h (7\I= Vk ,.JHK܍X<]7qO;CM&(dRzkӨmE?(ulc󪶓%1F$2Z7HU0 9NċUqū7"Q@8/AlTm&HrEI E+QWء Ҟ!EKgP~Bia2Ł3ձjķN)UHi6BEc͎!o!&ȧqNaE/h1)'!$nrZK{4A)n`0V$d,Ѷ`rflEj6:'l^56Jpi"DU/f5L{3\M },JNiН-DލdHk(nX6[ՄM |]T7 @"RA\2p Q@Ci4:߹}*_7@9(TQB,jK PAy]pMAhz^zTP<9fuq RL&U8=Zz]- SGUIi@z!*_EޘDh6M0pfa~ô$0@&UM0}j ጧf-pM ,𒑛Y)4V֪QYhpeMm|(kG&! AymJHlGɚBh2"=[)cՀ(wc0ESmpHx B Љ HbWԈY{ȴko5vf 5"MB\1Y(e4Ϫ2BOFHt[3'g3I[X4ز2U6+R¯P-6@uۉI}J28(v &~aD7FHBUC?lrםnpT>NX{'="Ta|X{?&`NG:y*kJ=HxDʠW󧎐ȴO ǧr(YS.ͼS's]T{feVaXz'|归z%2_D{ǯ~#HV ? FBzrOE^/ljQ )lr\?eSD"]=eS=D LJ y j[?dSS}#qԽG&ס0Ҧ#cϝȼ ;,pK lT$ EyPIp֊ǐR~{xA9vO>}x P?޽O==薜8,Qd5 o|x E#[ͼO6Nӝlg!lB|ʟu%y%! H=aFr)%m4$4老@>%4izUri}}*LZ^=WLAH52ap){=TANX:D%5H91XcHSt xe>3ѥU >7p&r0VC=2#Gi5\}d{p [8PicDx q!#+ r0i.>zf:.p\C5K^V(. ,`t {ƈ(m%]Vf%)bh̭%hrAǸxp .7GgK/4Lyi,%|b>-/.OF`f R|[9H mOF7#M\Jji~习ڼG&O:dQ!ksj/轒xS'j1k `]sUu\2FLP e"fTEimJ"%ur\*,*fED@3QeK|emKc:vY5IA𚒭 > р3P q MaׇU&G(rź ʌˢGD}X\~؁_8&yX0W7-]0B89d"[u f Lwv4Uz=gq 2MC8yl;^\ KBQcuFxjI>`훓<6Գ>~B']s]crR#Hp"^RlP˹GDT?t#1mioL,q'6Tٞ!Y`<陪 )05n3áGu5w} =G\rsRX+6h(n R.w534Ixm4 w lZՆ\*e$%jeKH>- `Y'%L;}u\ jIi6rՋ|ո˪^q@d}5X]B:s jzzP |e"ϥ/< aH4tr`UݴK$-B&H1HJVz6b`2S -=F>F~t>Wca+Dz؆ (齢벓\jTl0]Ϩ11;fT4.5XեC `bv͡C>˪3j~ F%XKo;KSZjfK } ^Z4 C;KY-, -@f },QAWBv #tGDID%5cJ#`Sj}K8{ij+]jXɁBا:#M Mst |لJ[_}2(8蒳 ,{PG_*r0m+c}SZV|-kX iAcYZCYuVf?&|eT TCQ.ڶPU,N~rXU\ )>SD6f}j c[Q޺6> T>.u^ ?E)N e [T=>QCHhZZΧ*kU= )i5j+A+v1-*,XhHaQGa#ۑ}<2Cy Cc0t1`cO\BS^~9T+ēNyE_Xl-D힘]!BOYjmVcAmٿҢ;MQ'-Oth蔬eE1KzuR1`1-\X-R'оG+4w i {HȳVeK%VI_;4X>+"7TU/ iLƬ@ȂSDFOj4ht8UF#4P|hZVU2WܤnA& >z2mՕQ%D{"qI(SqrNhT@5NX+[[ը"WO[GDNBeSVž1Y c*T} ɶY>%} s}N5ʙب#P6OkdS'&C(4^{6׹#Eq-EV4;D 3iFmP&]CYQ T 5LG ŧzzB5EIf 3G4e$5-ְ^CHZ׺]v|)kEۡ G*qh";+B4tZ/ӬQv$Dw>YMe5\N=Wv֦Y Ue%0R~qoπcUsXLk eFʷy/hyv4Vk!mfZpky˶h^ւR S@R> H8Bv*)Ú{Lg\A4xݱm@Ű6i a<me2TlHlԶĢm$rn)l]R4 Efut kyh9AYd]6D@+@k ᰼Ӹ(ʑBiۛТ][?.DNˆ5vKsd]kͪ-ȼ28XZu6B.ٞVZoɥ LJ.W K42mΑ]:qjjE#^:!p1li-p g;V1J͵'J`M(.8;Dyn:i{ kH5d1VH[H#3\HH>sؕ\³W$#8!ڥ[ HxB5T`_(@?،$=Fs@O{f-mk7)dLN9ȱR]|y,,|Y+|X WH5)L[ꥅ@&кD ^)10  wL)m!d JHd 5K9%I_CpLM9{489m7PވTzcJr){BJ$G7HPObݣg%k1+yWLoꝪ? ^Ӈ2N $گV_Fm" y5bpQ$d,B)D%!CgTD_]: ĸ@SA50ÏG,9Ba2{l l ȣ uB8?Ԥl಑2f˞FS BTf)N#{f7J1T4‘u-`%ΐ\%]U5@1L!cha#dXapCcU* K~^,ح]WfvJP^!RBx xRB2%@T )>?<STj>/J4?|5V Y+SGHIa)44~|Y=UʵS-UǧSj6*SކC p| ;Jam2 vzחgGRBv`Ԗp3.Y`?~;nfTQ=!B: $;TA0橊yA6Oo%cA6O$nAORzg" !` zy|8{a߁"Rp$jސD-90[v<4y0CNjv@ U~\ Ծ#Yyw0 B gëwo߿~Pj{T[ڤo|O/al{Ón89IݗOo^z :S y|=3k<n Xoh-g6Nxmj zUc]#fn<PD <~|h9îe0|KsY[*Uoia&%|YMB%;ۣۼa}> 7Eymg,y"HNpTV.Hh´(-tCFYZb"=wa%["EbޗL!^3E;VS{ԦTm!˅@$.ҷ. = sP\ 3 g䈋ڥ&~K-i ?NhBǀQg\&5E0-oڭ|ˀ !h-/Abm~׮F}w* &/ެ>"}EqҠ2-/Nf~ߒK~ i"RR-˗f(MJ.VǻrbpWB) Uimoip[_>_tvZ>.UDGi>"D>@'[__ HsSGKuIn.|TGmD w#Q@vM~4Յy(B:%V.H WmmldnӴ'9(A[Z*cC,10 j5,=&i hK#;0k@ .7 7( sqpŠ3coD,6e` dʁEDZVUn?OBF`0KVcf5]\fȸ.%(7|( مOG〇D3F\X Y6?aQQoEբwEΜLq.nT9qѝPT. xbg1U< MV qF$_dԚ9X`zMfu/@caE ˸h;U#!3Ek1+`bF ihQ['P&'%WE!CJxsa5kEITrx,Ł7YR]e*PD*D3h]g\&l/]8".!Z-mA7'rQ*CAÀ"l&r@lhce-m/Nҵa!Dᖞ:u">TUuv {TAw҅/@\T 0׺O(K>0ӜS?# ]̸AFI%Ϧf=A]d(ƪ#a(.NKYa򠮰i'HK6-NŋW@^ A&<ŀVOKJ$|+;@S r`G,ppT,\ KQk%`Z+U!>ڬMM-ea@bՑ2|C|Gm̢}>G-.6VPLŢBlJ_5Z^>)­tk%qf^IH2e.g HUvCuh1>qr&q1QAPr5MF;[Z(pe P+cO`fH~D.VR6΂&q5Yk#Lxt #mȇ,b}}T(o]}nZbHbɢq>3g45TkX[f׹k {HaPv9@ң"PC׵K,C!C\*}n`׆)G2qp2"3\Z \k)gA% qԹ^UA.QO'Nu8:K>d-En kBj"\줇zt]9 ֿZ k@p W v$$r+U298ַI(- 4pL/g$\h˖؍pظ،dd>lcc/` iIls&'7,"b5(>؅=Vx-'X@'ĕ6*ߑQ{ !C?>!#"$Ah&d^'cJ+ wBrk_z ʨ4|q;ʛ6+lúmdz b1B@H+P/ͦO퉺:Ⱥxۚ4H mF6QZ aŐ,VaPZA~`_0 ] i/uvOdzwd e[Bs%{Kd[y6~F"y| m~!oU~Bf?z){e-yF4?DusdpKb[0wb.!(O!\Nnt9W GŽG$gK ;rBMމ([I0 iSgKEBQV{G!2Y>\ѵ/xya ]u˂%!mFI#&RԤ,_1,hY17R ;)1Q4.+b8B"* */MoBq)4&dW*eYf>:&S-ʣٸ-A $IoǓABI겄aLH/b,QODhԣOJcm (=  BPqamA]EjZ7*beB#1QF2B2;5/hBדDB$8X FMrQEOJƲw0r´h*[VɏUbW i,Nedl&nӋb阥q7K ]ts -0agʝVꙀ=|KV-E(P:2ou 0}' >3Pi8PJ$MXm59ȨpS_HGz"F^ےH DK^CPuv,ENT M`ED4Xd#T@5#D2~xy(G]w@ce>'Qp0.;w)o C|_vW?~xraHi=,wo?y(w0B8[L޽V~%&yL ":C6zt|ð?~(Dʓ)b_H=dq]CdpSkϗ\x߼2~?9 km޼~ي?{߯FݠwTg_ߊl߿]?^[O:5aQ@׻/_B5o~Qݾnw=8D:+rZ#j`p~C8(Պzz !s=~"%!w$_k /=^{zW+#R;߽LN~ac?xCohҒLNŝ︑EeT%!ͰjYjOiQea4sOnn'ŗ0|{:w+'`Sl0^B7]o^MVn &s|N9ڲXߗ:.8xݢH^ n\NO0E鉀t'2oFP|BE߼ܾyy\2$øWG12o^O{x*77xSHoqxL`XK=dWb/|HYn{!Ѯx n̰7qsy3W볧͎7< kٲڧ# =| )b"Js36Wdwm?(}hmE‹g|qHAhr܋^_L<3~C>ejG!+r܉lﱄ!Eyr]^kUg+쫣_ߏ|>?qIpzR?.--H?o|6*ѩd}5*Ľ-DH '厴Z:gBt@kO۝ȇ?ˇ1Qc*\!t>gG(q;ves;}،o]ksopT)+:`;JneIpI@{ķeDQv_bgGfk|C5axFj*_4Y~ `n'sߜ"#)'@E^xsm w6JL"NFul@S72*2/ψf7YLsHTˆ&3CjBU£uƾ?ܧG?߿LbP\~p 9-L?餖 ;`\8pYOLJ^}|e"U~<>ͻo-n=6EP|^;S^_3%^pDb)L(Tixq0T~9'O##\&b5 HUi~Oqe~{zNha?$qgvO겻A^q9r2RԂ~o9Xgk%VS:$cyVm5kl~^ݧK?_TP[~/,UjFB,'OoI JXB~\"c>me-/&!w'%% rə>]񔃿]óz/VTM471+Ȫ6' I Wt>^zE5AA ;M&^?` 9TO1Pgƙ "qT$5~~Ɠ^Z{`uEDQ eG-kNC xqDfjtu%PR]:2Ŕr.rf9ԝMS{2i lWTB;J"x#h6|٧zU{0-f֩~mD;ʂ.z{~Grf3yXV ;S]_8>p.zb^SEo/"Y,1Ƈ?PLN>vQF4;7#X;WBVhXC/x ܍vmYݿw?9?׊EQkXZZ]5ûZFGΌטE:Y>XV28A+8 PsdWw{KFtQE>S;E d-^1y cE3\^mpQT[gܸ_YGz7?r#<#/_ Zcҧeُ-D~} LĞhea$"ү0Ff6ű*60_VZNujhؽe:9;jO E%ؒ"!z~VJېyt%l8"=x]`"㱩j냿[׿=i\ϢN֢F"?M"&at3QdVW["Ba:o5L<τ]s0ҲYD{yz}܇;wـ!lPWv?{2N70%#1ES?!qLtm+3yN"3׹Z|EƋShHi} lxwډ9ČG.-Z"Mt*/-"lw-$%`?.ۮэgl\ (é1gl^a{rv?יkݢӿ/iJ{2twEݹla1Tm_VMgؿV6__ywm5z}:΅gh^cߞK/ \[o|A/pp3kFOWxm^^動ǭsf^Gqe9X?+K/.@7ua?ބOz/& = ~՝|oT?<6ϙqir'%ou'.ێmUgNKq.bĬN2//;@!X88Z슸̚)JEr]ڵ\]v4:Nĉ݌ O\(/3rUjK/kǛPɞ%,me <3|tM8ǶL(Է] ba^DPy`v}>.%;`Zh%ÝV7m7r.#Suby:·_mąA+lY_,&!*IřqNd20x,*[k:baطݞ qIjݳ,AH}eMpu׫~`ecOe,Pb}؆#At rn9~p`}8 dk}sMnT+Tn4.;9b!<-A@neV1U{\N1*ՌcFF}~ʴvB.~/uJU:Ktnh+5PcJwMeq۹`C,+nm{lHYS1~1R^D=]Y:7߬^jEE9< ;0=mO :paa*:KnwOTmY>Ekp49Gԡo'˶dWXrxkWnuxpmhM˞2?\G:Its&LY GJendstream endobj 718 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 719 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 720 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 721 0 obj << /Type /XRef /Length 412 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 722 /ID [<7ad711c768ddf3fab1059178a1ac591f><7d935ef13acd9c558ff0d62c639bc612>] >> stream x+Da{3ø3daC&bGXZ(Y!fGRj¤V,1)3Jݿ۹<>M]]kJW# Q|<ۯMqlFnE!wE$eH\!z#:xChF, o7Vo3FjU!zc )Nol@ &~XǪIRm/#g0 nfKtS`Ya1,>{@,YK iNAob2'?aUдgj̍=}3T``܌@okl:佸IW:qC^Tmtsۅ.ypt3 %poY?&/w> 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