mgcv/0000755000177400001440000000000013046677730011415 5ustar murdochusersmgcv/po/0000755000177400001440000000000013046052674012025 5ustar murdochusersmgcv/po/mgcv.pot0000755000177400001440000000366013046052674013515 0ustar murdochusers# SOME DESCRIPTIVE TITLE. # Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER # This file is distributed under the same license as the mgcv package. # FIRST AUTHOR , YEAR. # #, fuzzy msgid "" msgstr "" "Project-Id-Version: mgcv 1.8-17\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2017-02-06 09:59+0000\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" "Language: \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=CHARSET\n" "Content-Transfer-Encoding: 8bit\n" #: magic.c:444 msgid "magic requires smoothing parameter starting values if L supplied" msgstr "" #: magic.c:562 msgid "magic, the gcv/ubre optimizer, failed to converge after 400 iterations." msgstr "" #: matrix.c:80 msgid "Failed to initialize memory for matrix." msgstr "" #: matrix.c:142 matrix.c:200 msgid "An out of bound write to matrix has occurred!" msgstr "" #: matrix.c:148 msgid "INTEGRITY PROBLEM in the extant matrix list." msgstr "" #: matrix.c:180 msgid "You are trying to check matrix integrity without defining RANGECHECK." msgstr "" #: matrix.c:238 msgid "Target matrix too small in mcopy" msgstr "" #: matrix.c:258 matrix.c:266 matrix.c:279 matrix.c:287 msgid "Incompatible matrices in matmult." msgstr "" #: matrix.c:374 msgid "Attempt to invert() non-square matrix" msgstr "" #: matrix.c:396 msgid "Singular Matrix passed to invert()" msgstr "" #: matrix.c:1316 msgid "svd() not converged" msgstr "" #: matrix.c:1392 #, c-format msgid "svdroot matrix not +ve semi def. %g" msgstr "" #: matrix.c:1420 msgid "Sort failed" msgstr "" #: qp.c:59 msgid "ERROR in addconQT." msgstr "" #: qp.c:465 msgid "QPCLS - Rank deficiency in model" msgstr "" #: tprs.c:40 msgid "You must have 2m>d for a thin plate spline." msgstr "" #: tprs.c:375 tprs.c:383 msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" mgcv/po/R-fr.po0000755000177400001440000011235313046052674013203 0ustar murdochusers# Translation of R-mgcv.pot to French # Copyright (C) 2005 The R Foundation # This file is distributed under the same license as the mgcv R package. # Philippe Grosjean , 2005. # msgid "" msgstr "" "Project-Id-Version: mgcv 1.3-10\n" "Report-Msgid-Bugs-To: bugs@r-project.org\n" "POT-Creation-Date: 2017-02-06 09:59\n" "PO-Revision-Date: 2005-12-09 09:13+0100\n" "Last-Translator: Philippe Grosjean \n" "Language-Team: French \n" "Language: fr\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=ISO-8859-1\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n > 1);\n" msgid "bam can not discretize with this nesting structure" msgstr "" msgid "discretization can not handle smooth ids" msgstr "" msgid "'family' argument seems not to be a valid family object" msgstr "" #, fuzzy msgid "cannot find valid starting values: please specify some" msgstr "" "Impossible de trouver des valeurs de dpart valides : veuillez en spcifier" msgid "Deviance = %s Iterations - %d" msgstr "" msgid "Non-finite deviance" msgstr "" #, fuzzy msgid "non-finite coefficients at iteration %d" msgstr "Coefficients non finis l'itration" #, fuzzy msgid "algorithm did not converge" msgstr "L'algorithme n'a pas converg" msgid "fitted probabilities numerically 0 or 1 occurred" msgstr "probabilits d'ajustement numrique de 0 ou 1 rencontres" msgid "fitted rates numerically 0 occurred" msgstr "taux d'ajustement numriques de 0 rencontrs" msgid "Too many cluster nodes to use all efficiently" msgstr "" #, fuzzy msgid "iterms reset to terms" msgstr "Type inconnu, rinitialis `terms'." msgid "exclude ignored by discrete prediction at present" msgstr "" msgid "family not recognized" msgstr "famille non reconnue" msgid "extended families not supported by bam" msgstr "" msgid "un-supported smoothness selection method" msgstr "" msgid "discretization only available with fREML" msgstr "" msgid "discrete method does not use parallel cluster - use nthreads instead" msgstr "" msgid "min.sp not supported with fast REML computation, and ignored." msgstr "" msgid "Not enough (non-NA) data to do anything meaningful" msgstr "Pas assez de donnes (non-NA) pour faire quoi que ce soit d'utile" msgid "AR.start must be logical" msgstr "" msgid "chunk.size < number of coefficients. Reset to %d" msgstr "" msgid "unknown tensor constraint type" msgstr "" msgid "Model has more coefficients than data" msgstr "Le modle a plus de coefficients que le nombre de donnes" msgid "AR1 parameter rho unused with generalized model" msgstr "" msgid "samfrac too small - ignored" msgstr "" msgid "Model can not be updated" msgstr "" msgid "link not available for coxph family; available link is \"identity\"" msgstr "" msgid "NA times supplied for cox.ph prediction" msgstr "" msgid "cox.ph does not yet handle offsets" msgstr "" msgid "" "link not available for ordered categorical family; available links are " "\"identity\"" msgstr "" msgid "Must supply theta or R to ocat" msgstr "" msgid "Response should be integer class labels" msgstr "" msgid "values out of range" msgstr "" msgid "" "link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" msgid "negative values not allowed for the negative binomial family" msgstr "" msgid "link \"%s\" not available for Tweedie family." msgstr "" msgid "Tweedie p must be in interval (a,b)" msgstr "" msgid "" "link not available for beta regression; available links are \"logit\", " "\"probit\", \"cloglog\" and \"cauchit\"" msgstr "" msgid "saturated likelihood may be inaccurate" msgstr "" msgid "" "link not available for scaled t distribution; available links are \"identity" "\", \"log\", and \"inverse\"" msgstr "" #, fuzzy msgid "scaled t df must be >2" msgstr "la valeur de epsilon doit tre > 0" msgid "NA values not allowed for the scaled t family" msgstr "" msgid "" "link not available for zero inflated; available link for `lambda' is only " "\"loga\"" msgstr "" msgid "negative values not allowed for the zero inflated Poisson family" msgstr "" msgid "Non-integer response variables are not allowed with ziP" msgstr "" msgid "Using ziP for binary data makes no sense" msgstr "" msgid "Possible divergence detected in fast.REML.fit" msgstr "" msgid "fast REML optimizer reached iteration limit" msgstr "" msgid "Huber scale estiamte not converged" msgstr "" msgid "unsupported order of differentiation requested of gam.fit3" msgstr "" msgid "illegal `family' argument" msgstr "argument `family' non autoris" msgid "Invalid linear predictor values in empty model" msgstr "Valeurs de prdiction linaire dans un modle vide" msgid "Invalid fitted means in empty model" msgstr "Moyennes ajustes incorrectes dans un modle vide" #, fuzzy msgid "Length of start should equal %d and correspond to initial coefs for %s" msgstr " et correspond aux coefs initiaux pour " msgid "Can't find valid starting values: please specify some" msgstr "" "Impossible de trouver des valeurs de dpart valides : veuillez en spcifier" msgid "NAs in V(mu)" msgstr "NAs dans V(mu)" msgid "0s in V(mu)" msgstr "0s dans V(mu)" msgid "NAs in d(mu)/d(eta)" msgstr "NAs dans d(mu)/d(eta)" #, fuzzy msgid "No observations informative at iteration %d" msgstr "Aucune observation informative l'itration" msgid "Not enough informative observations." msgstr "Pas assez d'observations informatives." #, fuzzy msgid "Non-finite coefficients at iteration %d" msgstr "Coefficients non finis l'itration" msgid "" "no valid set of coefficients has been found:please supply starting values" msgstr "" "pas d'ensemble de coefficients valide trouv : veuillez fournir les valeurs " "de dpart" msgid "Step size truncated due to divergence" msgstr "La taille du pas est tronque cause d'une divergence" msgid "inner loop 1; can't correct step size" msgstr "boucle interne 1 ; Impossible de corriger la taille du pas" msgid "Step size truncated: out of bounds" msgstr "Taille du pas tronque: hors de plage." msgid "inner loop 2; can't correct step size" msgstr "boucle interne 2 ; Impossible de corriger la taille du pas" msgid "penalized deviance = %s" msgstr "" msgid "inner loop 3; can't correct step size" msgstr "boucle interne 3 ; Impossible de corriger la taille du pas" msgid "Step halved: new penalized deviance = %g" msgstr "" msgid "" "Non finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" msgid "" "Non-finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" msgid "Algorithm did not converge" msgstr "L'algorithme n'a pas converg" msgid "Algorithm stopped at boundary value" msgstr "L'algorithme est arrt aux valeurs limites" msgid "deriv should be 1 or 2" msgstr "" msgid "L must be a matrix." msgstr "" msgid "L must have at least as many rows as columns." msgstr "" #, fuzzy msgid "L has inconsistent dimensions." msgstr "H a des mauvaises dimensions" msgid "Fitting terminated with step failure - check results carefully" msgstr "" msgid "Iteration limit reached without full convergence - check carefully" msgstr "" msgid "link not implemented for extended families" msgstr "" msgid "fam not a family object" msgstr "fam n'est pas un objet family" msgid "unrecognized (vector?) link" msgstr "link non reconnu (vecteur ?)" msgid "link not recognised" msgstr "link non reconnu" msgid "variance function not recognized for quasi" msgstr "function de variance non reconnue pour quasi" msgid "family not recognised" msgstr "famille non reconnue" msgid "'theta' must be specified" msgstr "" msgid "" "%s link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" msgid "H has wrong dimension" msgstr "H a des mauvaises dimensions" msgid "only scalar `rho' and `theta' allowed." msgstr "" msgid "1 0" msgid "number of linear predictors doesn't match" msgstr "" msgid "response not in 0 to number of predictors + 1" msgstr "" msgid "ziplss requires 2 links specified as character strings" msgstr "" msgid "link not available for" msgstr "" msgid "parameter of ziplss" msgstr "" msgid "Non-integer response variables are not allowed with ziplss" msgstr "" msgid "Using ziplss for binary data makes no sense" msgstr "" msgid "gevlss requires 3 links specified as character strings" msgstr "" #, fuzzy msgid "An object of length %d does not match the required parameter size" msgstr "ne correspond pas au paramtre taille requis" msgid "NA's in pdTens factor" msgstr "valeurs manquantes (NA) dans le fateur pdTens" msgid "Cannot extract the matrix from an uninitialized object" msgstr "Impossible d'extraire la matrice d'un objet non initialis" msgid "NA's in pdTens matrix" msgstr "valeurs manquantes (NA) dans la matrice pdTens" msgid "Cannot extract the matrix from an uninitialized pdMat object" msgstr "Impossible d'extraire la matrice d'un objet pdMat non initialis" msgid "Cannot extract the matrix with uninitialized dimensions" msgstr "Impossible d'extraire la matrice ayant des dimensions non initialises" msgid "An object of length" msgstr "Un objet de longueur" msgid "does not match the required parameter size" msgstr "ne correspond pas au paramtre taille requis" msgid "Must give names when initializing pdIdnot from parameter." msgstr "" "Il faut fournir des noms lors de l'initialisation de pdIdnot depuis un " "paramtre." msgid "without a formula" msgstr "sans une formule" msgid "Cannot extract the dimensions" msgstr "Impossible d'extraire les dimensions" msgid "Cannot extract the inverse from an uninitialized object" msgstr "Impossible d'extraire l'inverse depuis un objet non initialis" msgid "Can not convert this smooth class to a random effect" msgstr "" msgid "te smooths not useable with gamm4: use t2 instead" msgstr "" msgid "gamm can not fix only some margins of tensor product." msgstr "" "gamm ne peut arranger seulement quelques marges de produits de tenseurs." msgid "" "Tensor product penalty rank appears to be too low: please email Simon.Wood@R-" "project.org with details." msgstr "" "Le rang de la pnalit pour le produit tensoriel semble trop bas : veuillez " "envoyer un email Simon.Wood@R-project.org avec les dtails" #, fuzzy msgid "No data supplied to gamm.setup" msgstr "Aucune donne fournie gam.setup" msgid "" "gamm can not handle linked smoothing parameters (probably from use of `id' " "or adaptive smooths)" msgstr "" msgid "only one level of smooth nesting is supported by gamm" msgstr "" msgid "side conditions not allowed for nested smooths" msgstr "" msgid "object does not appear to be of class lme" msgstr "l'objet ne semble pas tre de la classe lme" msgid "inner groupings not nested in outer!!" msgstr "" "le regroupement interne n'est pas imbriqu dans le regroupement externe !!" msgid "iteration %d" msgstr "" msgid "gamm not converged, try increasing niterPQL" msgstr "" msgid "family are not designed for use with gamm!" msgstr "" msgid "random argument must be a *named* list." msgstr "l'argument random doit tre une liste *nomme*." msgid "all elements of random list must be named" msgstr "tous les lments d'une liste de nombres alatoires doivent tre nomms" msgid "gamm() can only handle random effects defined as named lists" msgstr "" "gamm() peut seulement utiliser des effets alatoires dfinis comme listes " "nommes" msgid "" "gamm models must have at least 1 smooth with unknown smoothing parameter or " "at least one other random effect" msgstr "" "les modles gamm doivent avoir au moins 1 lissage avec des parmtres inconnus " "ou au moins un autre effet alatoire" msgid "weights must be like glm weights for generalized case" msgstr "" msgid "Nested smooths must be fully random" msgstr "" msgid "sorry link not yet handled" msgstr "" #, fuzzy msgid "weights ignored" msgstr "argument test ignor" #, fuzzy msgid "family not implemented yet" msgstr "famille non reconnue" msgid "jagam requires a file for the JAGS model specification" msgstr "" msgid "smoothing parameter prior choise not recognised, reset to gamma" msgstr "" msgid "coefficient simulation data is missing" msgstr "" msgid "burnin too large, reset" msgstr "" msgid "rho missing from simulation data edf.type reset to 2" msgstr "" #, fuzzy msgid "residuals argument not supported" msgstr "argument test ignor" msgid "unconditional argument not meaningful here" msgstr "" #, fuzzy msgid "by.resids argument not supported" msgstr "argument test ignor" #, fuzzy msgid "all.terms argument not supported" msgstr "argument test ignor" msgid "silly tolerance supplied" msgstr "" msgid "argument k must be positive." msgstr "" msgid "A not square" msgstr "" msgid "Can not have more eigenvalues than nrow(A)" msgstr "" msgid "nrow(M$X) != length(M$y)" msgstr "nrow(M$X) != length(M$y)" msgid "ncol(M$X) != length(M$p)" msgstr "ncol(M$X) != length(M$p)" msgid "length(M$w) != length(M$y)" msgstr "length(M$w) != length(M$y)" msgid "nrow(M$Ain) != length(M$bin)" msgstr "nrow(M$Ain) != length(M$bin)" msgid "nrow(M$Ain) != length(M$p)" msgstr "nrow(M$Ain) != length(M$p)" #, fuzzy msgid "initial parameters not feasible" msgstr "les paramtres initiaux sont trs proches des contraintes d'ingalit" #, fuzzy msgid "initial point very close to some inequality constraints" msgstr "les paramtres initiaux sont trs proches des contraintes d'ingalit" msgid "initial parameters very close to inequality constraints" msgstr "les paramtres initiaux sont trs proches des contraintes d'ingalit" msgid "ncol(M$C) != length(M$p)" msgstr "ncol(M$C) != length(M$p)" msgid "M$S and M$off have different lengths" msgstr "M$S et M$off ont des longueurs diffrentes" msgid "M$sp has different length to M$S and M$off" msgstr "M$sp a une longueur diffrente de M$S et M$off" #, fuzzy msgid "M$S[%d] is too large given M$off[%d]" msgstr "] est trop large, tant donn M$off[" msgid "Penalized model matrix must have no more columns than rows" msgstr "" msgid "Model matrix not full column rank" msgstr "" msgid "can't handle [[ in formula" msgstr "" #, fuzzy msgid "single linear predictor indices are ignored" msgstr "Valeurs de prdiction linaire dans un modle vide" #, fuzzy msgid "linear predictor labels out of range" msgstr "Valeurs de prdiction linaire dans un modle vide" msgid "model has repeated 1-d smooths of same variable." msgstr "le modle a des lissages 1-d rpts des mmes variables" msgid "`id' linked smooths must have same number of arguments" msgstr "" msgid "`rank' has wrong length in `paraPen'" msgstr "" #, fuzzy msgid "a parametric penalty has wrong dimension" msgstr "H a des mauvaises dimensions" #, fuzzy msgid "L has wrong dimension in `paraPen'" msgstr "H a des mauvaises dimensions" msgid "`sp' dimension wrong in `paraPen'" msgstr "" msgid "`sp' too short" msgstr "" msgid "No data supplied to gam.setup" msgstr "Aucune donne fournie gam.setup" msgid "paraPen not supported for multi-formula models" msgstr "" msgid "absorb.cons must be TRUE for multi-formula models" msgstr "" msgid "length(drop.intercept) should be equal to number of model formulas" msgstr "" msgid "shared offsets not allowed" msgstr "" msgid "dropping unidentifiable parametric terms from model" msgstr "" msgid "First argument is no sort of formula!" msgstr "Le premier argument n'est pas une formule." msgid "You've got no model...." msgstr "Vous n'avez aucun modle..." msgid "" "Later terms sharing an `id' can not have more smoothing parameters than the " "first such term" msgstr "" msgid "Supplied smoothing parameter vector is too short - ignored." msgstr "" "Le vecteur des paramtres de lissage fourni est trop court - il est ignor." msgid "NA's in supplied smoothing parameter vector - ignoring." msgstr "" "Valeurs manquantes (NA) dans le vecteur de paramtres de lissage fixe - ignor." msgid "incorrect number of smoothing parameters supplied for a smooth term" msgstr "" msgid "length of min.sp is wrong." msgstr "la longueur de min.sp est fausse." msgid "NA's in min.sp." msgstr "valeurs manquantes (NA) dans min.sp" msgid "elements of min.sp must be non negative." msgstr "les lments de min.sp doivent tre positifs ou nulls." #, fuzzy msgid "unknown outer optimization method." msgstr "Mthode d'optimisation externe GAM inconnue." msgid "Extended Fellner Schall only implemented for general families" msgstr "" msgid "Please provide a single value for theta or use nb to estimate it" msgstr "" msgid "nlm.fd only available for GCV/UBRE" msgstr "" msgid "unknown optimizer" msgstr "" msgid "unknown smoothness selection criterion" msgstr "" msgid "Reset optimizer to outer/newton" msgstr "" msgid "in.out incorrect: see documentation" msgstr "" msgid "incorrect number of linear predictors for family" msgstr "" msgid "edge.correct must be logical or a positive number" msgstr "" msgid "nthreads must be a positive integer" msgstr "" msgid "IRLS regularizing parameter must be a non-negative number." msgstr "le paramtre de rgularisation IRLS doit tre positif ou null." msgid "value of epsilon must be > 0" msgstr "la valeur de epsilon doit tre > 0" msgid "maximum number of iterations must be > 0" msgstr "le nombre maximum d'itrations doit tre > 0" msgid "" "silly value supplied for rank.tol: reset to square root of machine precision." msgstr "" "valeur aberrante fournie pour rank.tol : rinitialise la racine carre de la " "prcision de la machine." msgid "Model seems to contain no terms" msgstr "Le modle semble ne contenir aucun terme" msgid "Discrete Theta search not available with performance iteration" msgstr "" msgid "y must be univariate unless binomial" msgstr "y doit tre univari moins d'tre binomial" #, fuzzy msgid "Length of start should equal %d and correspond to initial coefs." msgstr "et correspondre aux coefficients initiaux." msgid "" "iterative weights or data non-finite in gam.fit - regularization may help. " "See ?gam.control." msgstr "" "pondrations itratives ou donnes non finies dans gam.fit - une rgularisation " "peut aider. Voyez ?gam.control." msgid "Step size truncated: out of bounds." msgstr "Taille du pas tronque : hors de plage." #, fuzzy msgid "`object' is not of class \"gam\"" msgstr "l'objet ne semble pas tre de la classe lme" #, fuzzy msgid "unrecognised na.action" msgstr "link non reconnu (vecteur ?)" msgid "na.action not character or function" msgstr "" msgid "Smoothness uncertainty corrected covariance not available" msgstr "" msgid "Unknown type, reset to terms." msgstr "Type inconnu, rinitialis `terms'." msgid "predict.gam can only be used to predict from gam objects" msgstr "" "predict.gam peut seulement tre utilis pour des prdictions partir d'objets " "gam" msgid "newdata is a model.frame: it should contain all required variables" msgstr "" "newdata est un model.frame : il devrait contenir toutes les variables " "requises" msgid "not all required variables have been supplied in newdata!" msgstr "les variables requises n'ont pas toutes t fournies dans newdata!" msgid "type iterms not available for multiple predictor cases" msgstr "" msgid "non-existent terms requested - ignoring" msgstr "terme inexistant requis - il est ignor" #, fuzzy msgid "non-existent exclude terms requested - ignoring" msgstr "terme inexistant requis - il est ignor" msgid "requires an object of class gam" msgstr "" msgid "nothing to do for this model" msgstr "" msgid "" "Pearson residuals not available for this family - returning deviance " "residuals" msgstr "" msgid "lambda and h should have the same length!" msgstr "" msgid "recov works with fitted gam objects only" msgstr "" msgid "m can't be in re" msgstr "" msgid "p-values may give low power in some circumstances" msgstr "" msgid "p-values un-reliable" msgstr "" msgid "p-values may give very low power" msgstr "" msgid "" "p-values for any terms that can be penalized to zero will be unreliable: " "refit model to fix this." msgstr "" msgid "p.type!=0 is deprecated, and liable to be removed in future" msgstr "" msgid "The following arguments to anova.glm(..) are invalid and dropped:" msgstr "Les arguments suivants de anova.glm(..) sont incorrects et ignors :" msgid "," msgstr "," msgid "un-supported test" msgstr "" msgid "test argument ignored" msgstr "argument test ignor" msgid "anova.gam called with non gam object" msgstr "anova.gam appel sur un objet qui n'est pas gam" #, fuzzy msgid "not a gam object" msgstr "fam n'est pas un objet family" #, fuzzy msgid "argument is not a gam object" msgstr "fam n'est pas un objet family" msgid "S.scale vector doesn't match S list - please report to maintainer" msgstr "" msgid "Supplied matrix not symmetric" msgstr "La matrice fournie n'est pas symtrique" msgid "singular values not returned in order" msgstr "les valeurs singulires ne sont pas renvoyes dans l'ordre" msgid "Something wrong - matrix probably not +ve semi definite" msgstr "" "Quelque chose d'anormal s'est produit - la matrice n'est probablement pas " "+ve semi dfinie" msgid "method not recognised." msgstr "mthode non reconnue." #, fuzzy msgid "S[[%d]] matrix is not +ve definite." msgstr "]] n'est pas +ve dfinie." msgid "dimensions of supplied w wrong." msgstr "les dimensions du w fourni sont mauvaises." msgid "w different length from y!" msgstr "w n'a pas la mme longueur que y !" msgid "X lost dimensions in magic!!" msgstr "X a perdu ses dimensions dans magic !!" #, fuzzy msgid "mu dimensions wrong" msgstr "la dimension de fx est incorrecte" #, fuzzy msgid "something wrong with inputs to LAPACK routine" msgstr "il y a quelque chose d'anormal avec l'argument d." msgid "not positive definite" msgstr "" msgid "don't be silly" msgstr "" msgid "sd should have exactly one less entry than ld" msgstr "" msgid "internal error in vcorr, please report to simon.wood@r-project.org" msgstr "" msgid "a has wrong number of rows" msgstr "" msgid "mvn requires 2 or more dimensional data" msgstr "" msgid "mvn does not yet handle offsets" msgstr "" msgid "mvn dimension error" msgstr "" msgid "object is not a glm or gam" msgstr "" msgid "names of z and pc must match" msgstr "" msgid "" "Partial residuals do not have a natural x-axis location for linear " "functional terms" msgstr "" msgid "no automatic plotting for smooths of more than two variables" msgstr "aucun graphe automatique pour les lissages de plus de deux variables" msgid "no automatic plotting for smooths of more than one variable" msgstr "aucun graphe automatique pour les lissages de plus d'une variable" msgid "residuals argument to plot.gam is wrong length: ignored" msgstr "" "l'argument residuals plot.gam est de la mauvaise longueur : il est ignor" msgid "No variance estimates available" msgstr "Aucun estimateur de variance n'est disponible" msgid "No terms to plot - nothing for plot.gam() to do." msgstr "Aucun terme reprsenter graphiquement - rien faire pour plot.gam()." msgid "grid vectors are different lengths" msgstr "les vecteurs de grille ont des longueurs diffrentes" msgid "data vectors are of different lengths" msgstr "les vecteurs de donnes ont des longueurs diffrentes" msgid "supplied dist negative" msgstr "dist fournie ngative" #, fuzzy msgid "Model does not seem to have enough terms to do anything useful" msgstr "" "Le modle ne semble pas avoir suffisamment de terme pour faire quoi que ce " "soit d'utile" #, fuzzy msgid "view variables must be one of %s" msgstr "les variables `view' doivent tre prises parmis" msgid "" "Don't know what to do with parametric terms that are not simple numeric or " "factor variables" msgstr "" #, fuzzy msgid "View variables must contain more than one value. view = c(%s,%s)." msgstr "Les variables `view' doivent contenir plus d'une valeur. view = c(" msgid "type must be \"link\" or \"response\"" msgstr "type doit tre \"link\" ou \"response\"" msgid "Something wrong with zlim" msgstr "Quelque chose d'anormal s'est produit avec zlim" msgid "color scheme not recognised" msgstr "schma de couleurs non reconnu" msgid "sorry no option for contouring with errors: try plot.gam" msgstr "" "dsol, aucune option pour effectuer les contours avec erreurs : essayez plot." "gam" msgid "At least three knots required in call to mono.con." msgstr "Au moins trois noeuds requis pour mono.con." msgid "lower bound >= upper bound in call to mono.con()" msgstr "limite infrieure >= limite suprieure dans l'appel mono.con()" msgid "x is null" msgstr "x est null" msgid "uniquecombs has not worked properly" msgstr "" msgid "order too low" msgstr "" msgid "too few knots" msgstr "trop peu de noeuds" msgid "x out of range" msgstr "" msgid "something wrong with argument d." msgstr "il y a quelque chose d'anormal avec l'argument d." msgid "one or more supplied k too small - reset to default" msgstr "" "un ou plusieurs k spcifis trop petits - rinitialisation aux valeurs par dfaut" msgid "dimension of fx is wrong" msgstr "la dimension de fx est incorrecte" #, fuzzy msgid "xt argument is faulty." msgstr "arguments supplmentaires limins" msgid "bs wrong length and ignored." msgstr "bs, de longueur incorrecte, est ignor." msgid "m wrong length and ignored." msgstr "m, de longueur incorrecte, est ignor." msgid "Repeated variables as arguments of a smooth are not permitted" msgstr "Les variables rptes comme arguments d'un lissage ne sont pas permises" msgid "only first element of `id' used" msgstr "" msgid "supply a value for each variable for a point constraint" msgstr "" msgid "ord is wrong. reset to NULL." msgstr "" msgid "ord contains out of range orders (which will be ignored)" msgstr "" msgid "by=. not allowed" msgstr "by=. n'est pas permis" msgid "s(.) not yet supported." msgstr "s(.) pas encore support" msgid "argument k of s() should be integer and has been rounded" msgstr "l'argument k de s() doit tre un entier et a t arrondi" msgid "attempt to use unsuitable marginal smooth class" msgstr "" msgid "" "Sorry, tensor products of smooths with multiple penalties are not supported." msgstr "" msgid "reparameterization unstable for margin: not done" msgstr "" msgid "" "single penalty tensor product smooths are deprecated and likely to be " "removed soon" msgstr "" msgid "basis not usable with reduced te" msgstr "" msgid "fx length wrong from t2 term: ignored" msgstr "" msgid "length of sp incorrect in t2: ignored" msgstr "" msgid "d can not be negative in call to null.space.dimension()." msgstr "d ne peut tre ngatif dans l'appel null.space.dimension()" msgid "arguments of smooth not same dimension" msgstr "" msgid "components of knots relating to a single smooth must be of same length" msgstr "" "les composants des noeuds relatifs un mme lissage doivent tre de mme " "longueur" msgid "more knots than data in a tp term: knots ignored." msgstr "" "plus de noeuds que de donnes dans un terme tp : des noeuds sont ignors." msgid "basis dimension, k, increased to minimum possible" msgstr "la dimension de base, k, est augmente la valeur minimale possible" msgid "no data to predict at" msgstr "pas de donnes pour la prdiction " #, fuzzy msgid "Basis only handles 1D smooths" msgstr "la base cr ne fonctionne que pour les lissages 1-d !" msgid "number of supplied knots != k for a cr smooth" msgstr "le nombre de noeuds fournis != k pour un lissage 'cr'" msgid "F is missing from cr smooth - refit model with current mgcv" msgstr "" msgid "more knots than unique data values is not allowed" msgstr "il n'est pas autoris d'avoir plus de noeuds que de valeurs uniques" msgid "number of supplied knots != k for a cc smooth" msgstr "le nombre de noeuds fournis != k pour un lissage 'cc'" msgid "basis dimension too small for b-spline order" msgstr "" msgid "knot range does not include data" msgstr "" msgid "there should be" msgstr "" #, fuzzy msgid "supplied knots" msgstr "dist fournie ngative" msgid "knots supplied" msgstr "" msgid "" "knot range is so wide that there is *no* information about some basis " "coefficients" msgstr "" msgid "penalty order too high for basis dimension" msgstr "" msgid "there is *no* information about some basis coefficients" msgstr "" msgid "basis dimension is larger than number of unique covariates" msgstr "" msgid "requested non-existent derivative in B-spline penalty" msgstr "" msgid "fs smooths can only have one factor argument" msgstr "" msgid "\"fs\" smooth cannot use a multiply penalized basis (wrong basis in xt)" msgstr "" #, fuzzy msgid "no factor supplied to fs smooth" msgstr "Aucune donne fournie gam.setup" msgid "\"fs\" terms can not be fixed here" msgstr "" msgid "" "fs smooth not suitable for discretisation with more than one metric predictor" msgstr "" msgid "the adaptive smooth class is limited to 1 or 2 covariates." msgstr "" msgid "penalty basis too large for smoothing basis" msgstr "" msgid "penalty basis too small" msgstr "" msgid "random effects don't work with ids." msgstr "" msgid "" "Please put term with most levels last in 're' to avoid spoiling supplied " "penalties" msgstr "" #, fuzzy msgid "supplied S matrices are wrong diminsion" msgstr "H a des mauvaises dimensions" #, fuzzy msgid "argument of mrf should be a factor variable" msgstr "l'argument k de s() doit tre un entier et a t arrondi" msgid "MRF basis dimension set too high" msgstr "" msgid "data contain regions that are not contained in the knot specification" msgstr "" msgid "" "penalty matrix, boundary polygons and/or neighbours list must be supplied in " "xt" msgstr "" msgid "no spatial information provided!" msgstr "" msgid "mismatch between nb/polys supplied area names and data area names" msgstr "" #, fuzzy msgid "Something wrong with auto- penalty construction" msgstr "il y a quelque chose d'anormal avec l'argument d." msgid "supplied penalty not square!" msgstr "" #, fuzzy msgid "supplied penalty wrong dimension!" msgstr "H a des mauvaises dimensions" msgid "penalty column names don't match supplied area names!" msgstr "" msgid "Can only deal with a sphere" msgstr "" #, fuzzy msgid "more knots than data in an sos term: knots ignored." msgstr "" "plus de noeuds que de donnes dans un terme tp : des noeuds sont ignors." #, fuzzy msgid "more knots than data in a ds term: knots ignored." msgstr "" "plus de noeuds que de donnes dans un terme tp : des noeuds sont ignors." msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" msgid "s value reduced" msgstr "" msgid "s value increased" msgstr "" msgid "No suitable s (i.e. m[2]) try increasing m[1]" msgstr "" msgid "s value modified to give continuous function" msgstr "" #, fuzzy msgid "basis dimension reset to minimum possible" msgstr "la dimension de base, k, est augmente la valeur minimale possible" msgid "incorrect arguments to GP smoother" msgstr "" #, fuzzy msgid "more knots than data in an ms term: knots ignored." msgstr "" "plus de noeuds que de donnes dans un terme tp : des noeuds sont ignors." msgid "smooth objects should not have a qrc attribute." msgstr "les objets lissage ne devraient pas avoir d'attribut qrc." msgid "unimplemented sparse constraint type requested" msgstr "" msgid "" "handling `by' variables in smooth constructors may not work with the " "summation convention" msgstr "" msgid "Can't find by variable" msgstr "Impossible de trouver la variable 'by'" msgid "" "sweep and drop constraints unlikely to work well with self handling of by " "vars" msgstr "" msgid "factor `by' variables can not be used with matrix arguments." msgstr "" msgid "`by' variable must be same dimension as smooth arguments" msgstr "" msgid "Number of prediction and fit constraints must match" msgstr "" msgid "x and y must be same length" msgstr "" msgid "variable names don't match boundary names" msgstr "" msgid "x and y not same length" msgstr "" #, fuzzy msgid "bnd must be a list." msgstr "l'argument random doit tre une liste *nomme*." msgid "lengths of k and bnd are not compatible." msgstr "" msgid "attempt to select non existent basis function" msgstr "" msgid "coefficient vector wrong length" msgstr "" msgid "knots must be specified for soap" msgstr "" msgid "soap films are bivariate only" msgstr "" msgid "need at least one interior knot" msgstr "" msgid "can't soap smooth without a boundary" msgstr "" msgid "bnd must be a list of boundary loops" msgstr "" msgid "faulty bnd" msgstr "" msgid "k and bnd lengths are inconsistent" msgstr "" msgid "data outside soap boundary" msgstr "" msgid "no free coefs in sf smooth" msgstr "" msgid "only deals with 2D case" msgstr "" msgid "not enough unique values to find k nearest" msgstr "" msgid "cubic spline only deals with 1D data" msgstr "" msgid "object not fully initialized" msgstr "" #, fuzzy #~ msgid "non-finite coefficients at iteration" #~ msgstr "Coefficients non finis l'itration" #~ msgid "x has no row attribute" #~ msgstr "x n'a pas d'attribut de lignes" #~ msgid "x has no col attribute" #~ msgstr "x n'a pas d'attribut de colonnes" #~ msgid "" #~ "NA's passed to eig: please email Simon.Wood@R-project.org with details" #~ msgstr "" #~ "NA pass eig : veuillez envoyer un email Simon.Wood@R-project.org avec " #~ "les dtails" #~ msgid "" #~ "NA eigenvalues returned by eigen: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "Valeurs propres NA renvoyes par eigen : veuillez envoyer un email Simon." #~ "Wood@R-project.org avec les dtails" #~ msgid "" #~ "NA's in eigenvectors from eigen: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "Valeurs manquantes (NA) dans les vecteurs propres pour eigen : veuillez " #~ "envoyer un email Simon.Wood@R-project.org" #~ msgid "" #~ "NA singular values returned by svd: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "Valeurs singulires NA renvoyes par svd : veuillez envoyer un email Simon." #~ "Wood@R-project.org" #~ msgid "" #~ "NA's in singular vectors from svd: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "Valeurs manqsuantes (NA) dans les vecteurs singuliers pour svd : veuillez " #~ "envoyer un email Simon.Wood@R-project.org" #~ msgid "" #~ "NA problem resolved using svd, but please email Simon.Wood@R-project.org " #~ "anyway" #~ msgstr "" #~ "Problme de valeurs manquantes (NA) rsolu en utilisant svd, veuillez " #~ "envoyer un email Simon.Wood@R-project.org" #~ msgid "Problem with linear algebra routines." #~ msgstr "Problme avec les routines d'algbre linaire." #~ msgid "gamm() requires package nlme to be installed" #~ msgstr "gamm() ncessite le package nlme pour tre install" #~ msgid "gamm() requires package MASS to be installed" #~ msgstr "gamm() ncessite le package MASS pour tre install" #~ msgid "M$S[" #~ msgstr "M$S[" #~ msgid "]" #~ msgstr "]" #~ msgid "Can't mix fixed and estimated penalties in mgcv() - use magic()" #~ msgstr "" #~ "Impossible de mixer des pnalits fixes et estimes dans mgcv() - utilisez " #~ "magic() plutt" #~ msgid "meaninglessly low k; reset to 2" #~ msgstr "k trop bas et insignifiant ; Rinitialis 2" #~ msgid "can't predict outside range of knots with periodic smoother" #~ msgstr "" #~ "impossible d'effectuer une prdiction en dehors de la plage des noeuds " #~ "avec un lissage priodique" #~ msgid "supplied sp has wrong length" #~ msgstr "le sp fourni n'a pas la bonne longueur" #~ msgid "supplied min.sp has wrong length" #~ msgstr "min.sp fourni n'a pas la bonne longueur" #~ msgid "Unknown additive model fit method." #~ msgstr "Mthode d'ajustement de modle additif inconnue." #~ msgid "Unknown *generalized* additive model fit method." #~ msgstr "Mthode d'ajustement de modle additif *gnralis* inconnue." #~ msgid "pearson should be TRUE or FALSE - set to FALSE." #~ msgstr "'pearson' doit tre 'TRUE' ou 'FALSE' - valeur 'FALSE' utilise ici" #~ msgid "" #~ "Negative binomial family not (yet) usable with type 2 iteration methods." #~ msgstr "" #~ "Famille binomiale ngative pas (encore) utilisable avec les mthodes " #~ "d'itration de type 2." #~ msgid "" #~ "Must use gam.control(absorb.cons=TRUE), for type 2 iteration\n" #~ " methods." #~ msgstr "" #~ "Il faut utiliser gam.control(absorb.cons = TRUE), pour des mthodes " #~ "d'itration de type 2." #~ msgid "nb.theta.mult must be >= 2" #~ msgstr "nb.theta.mult doit tre >= 2" #~ msgid "dispersion argument ignored" #~ msgstr "argument dispersion ignor" #~ msgid ")." #~ msgstr ")." #~ msgid "S[[" #~ msgstr "la matrice S[[" mgcv/po/de.po0000644000177400001440000000552212765741177012773 0ustar murdochusers# Translation of mgcv.pot to German # Copyright (C) 2005-2009 The R Foundation # This file is distributed under the same license as the mgcv package. # Chris Leick , 2009. # msgid "" msgstr "" "Project-Id-Version: R 2.10.0 / mgcv 1.5-5\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2016-08-19 13:28+0100\n" "PO-Revision-Date: 2009-10-08 16:16+0200\n" "Last-Translator: Chris Leick \n" "Language-Team: German \n" "Language: de\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n != 1);\n" #: magic.c:444 msgid "magic requires smoothing parameter starting values if L supplied" msgstr "magic benötigt Glättungsparameter-Startwerte, wenn L angegeben" #: magic.c:562 msgid "magic, the gcv/ubre optimizer, failed to converge after 400 iterations." msgstr "" "magic, der gcv/ubre-Optimierer, konvergierte nach 400 Iterationen noch nicht." #: matrix.c:80 msgid "Failed to initialize memory for matrix." msgstr "Initialisieren von Speicher für Matrix fehlgeschlagen." #: matrix.c:142 matrix.c:200 msgid "An out of bound write to matrix has occurred!" msgstr "Ein Schreiben außerhalb der Matrixgrenze ist aufgetreten!" #: matrix.c:148 msgid "INTEGRITY PROBLEM in the extant matrix list." msgstr "INTEGRITÄTSPROBLEM in der bestehenden Matrix-Liste." #: matrix.c:180 msgid "You are trying to check matrix integrity without defining RANGECHECK." msgstr "" "Sie versuchen die Integrität der Matrix zu prüfen ohne RANGECHECK zu " "definieren." #: matrix.c:238 msgid "Target matrix too small in mcopy" msgstr "Zielmatrix zu klein in mcopy" #: matrix.c:258 matrix.c:266 matrix.c:279 matrix.c:287 msgid "Incompatible matrices in matmult." msgstr "Inkompatible Matrizen in matmult." #: matrix.c:374 msgid "Attempt to invert() non-square matrix" msgstr "Versuch des Aufrufs von invert() für nicht-quadratische Matrix" #: matrix.c:396 msgid "Singular Matrix passed to invert()" msgstr "Singuläre Matrix an invert() übergeben" #: matrix.c:1316 msgid "svd() not converged" msgstr "svd() nicht konvergiert" #: matrix.c:1392 #, c-format msgid "svdroot matrix not +ve semi def. %g" msgstr "svdroot-Matrix nicht +ve def. %g" #: matrix.c:1420 msgid "Sort failed" msgstr "Sortieren fehlgeschlagen" #: qp.c:59 msgid "ERROR in addconQT." msgstr "FEHLER in addconQT." #: qp.c:465 msgid "QPCLS - Rank deficiency in model" msgstr "QPCLS - Rang-Defizit im Modell" #: tprs.c:40 msgid "You must have 2m>d for a thin plate spline." msgstr "Es muss 2m>d für einen dünnwandige Spline gelten." #: tprs.c:375 tprs.c:383 msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" "Ein Term hat weniger einzigartige Kombinationen von Kovariaten als maximal " "angegebene Freiheitsgrade" mgcv/po/R-mgcv.pot0000755000177400001440000006111313046052674013711 0ustar murdochusersmsgid "" msgstr "" "Project-Id-Version: mgcv 1.8-17\n" "POT-Creation-Date: 2017-02-06 09:59\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=CHARSET\n" "Content-Transfer-Encoding: 8bit\n" msgid "bam can not discretize with this nesting structure" msgstr "" msgid "discretization can not handle smooth ids" msgstr "" msgid "'family' argument seems not to be a valid family object" msgstr "" msgid "cannot find valid starting values: please specify some" msgstr "" msgid "Deviance = %s Iterations - %d" msgstr "" msgid "Non-finite deviance" msgstr "" msgid "non-finite coefficients at iteration %d" msgstr "" msgid "algorithm did not converge" msgstr "" msgid "fitted probabilities numerically 0 or 1 occurred" msgstr "" msgid "fitted rates numerically 0 occurred" msgstr "" msgid "Too many cluster nodes to use all efficiently" msgstr "" msgid "iterms reset to terms" msgstr "" msgid "exclude ignored by discrete prediction at present" msgstr "" msgid "family not recognized" msgstr "" msgid "extended families not supported by bam" msgstr "" msgid "un-supported smoothness selection method" msgstr "" msgid "discretization only available with fREML" msgstr "" msgid "discrete method does not use parallel cluster - use nthreads instead" msgstr "" msgid "min.sp not supported with fast REML computation, and ignored." msgstr "" msgid "Not enough (non-NA) data to do anything meaningful" msgstr "" msgid "AR.start must be logical" msgstr "" msgid "chunk.size < number of coefficients. Reset to %d" msgstr "" msgid "unknown tensor constraint type" msgstr "" msgid "Model has more coefficients than data" msgstr "" msgid "AR1 parameter rho unused with generalized model" msgstr "" msgid "samfrac too small - ignored" msgstr "" msgid "Model can not be updated" msgstr "" msgid "link not available for coxph family; available link is \"identity\"" msgstr "" msgid "NA times supplied for cox.ph prediction" msgstr "" msgid "cox.ph does not yet handle offsets" msgstr "" msgid "link not available for ordered categorical family; available links are \"identity\"" msgstr "" msgid "Must supply theta or R to ocat" msgstr "" msgid "Response should be integer class labels" msgstr "" msgid "values out of range" msgstr "" msgid "link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"" msgstr "" msgid "negative values not allowed for the negative binomial family" msgstr "" msgid "link \"%s\" not available for Tweedie family." msgstr "" msgid "Tweedie p must be in interval (a,b)" msgstr "" msgid "link not available for beta regression; available links are \"logit\", \"probit\", \"cloglog\" and \"cauchit\"" msgstr "" msgid "saturated likelihood may be inaccurate" msgstr "" msgid "link not available for scaled t distribution; available links are \"identity\", \"log\", and \"inverse\"" msgstr "" msgid "scaled t df must be >2" msgstr "" msgid "NA values not allowed for the scaled t family" msgstr "" msgid "link not available for zero inflated; available link for `lambda' is only \"loga\"" msgstr "" msgid "negative values not allowed for the zero inflated Poisson family" msgstr "" msgid "Non-integer response variables are not allowed with ziP" msgstr "" msgid "Using ziP for binary data makes no sense" msgstr "" msgid "Possible divergence detected in fast.REML.fit" msgstr "" msgid "fast REML optimizer reached iteration limit" msgstr "" msgid "Huber scale estiamte not converged" msgstr "" msgid "unsupported order of differentiation requested of gam.fit3" msgstr "" msgid "illegal `family' argument" msgstr "" msgid "Invalid linear predictor values in empty model" msgstr "" msgid "Invalid fitted means in empty model" msgstr "" msgid "Length of start should equal %d and correspond to initial coefs for %s" msgstr "" msgid "Can't find valid starting values: please specify some" msgstr "" msgid "NAs in V(mu)" msgstr "" msgid "0s in V(mu)" msgstr "" msgid "NAs in d(mu)/d(eta)" msgstr "" msgid "No observations informative at iteration %d" msgstr "" msgid "Not enough informative observations." msgstr "" msgid "Non-finite coefficients at iteration %d" msgstr "" msgid "no valid set of coefficients has been found:please supply starting values" msgstr "" msgid "Step size truncated due to divergence" msgstr "" msgid "inner loop 1; can't correct step size" msgstr "" msgid "Step size truncated: out of bounds" msgstr "" msgid "inner loop 2; can't correct step size" msgstr "" msgid "penalized deviance = %s" msgstr "" msgid "inner loop 3; can't correct step size" msgstr "" msgid "Step halved: new penalized deviance = %g" msgstr "" msgid "Non finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam.contol'" msgstr "" msgid "Non-finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam.contol'" msgstr "" msgid "Algorithm did not converge" msgstr "" msgid "Algorithm stopped at boundary value" msgstr "" msgid "deriv should be 1 or 2" msgstr "" msgid "L must be a matrix." msgstr "" msgid "L must have at least as many rows as columns." msgstr "" msgid "L has inconsistent dimensions." msgstr "" msgid "Fitting terminated with step failure - check results carefully" msgstr "" msgid "Iteration limit reached without full convergence - check carefully" msgstr "" msgid "link not implemented for extended families" msgstr "" msgid "fam not a family object" msgstr "" msgid "unrecognized (vector?) link" msgstr "" msgid "link not recognised" msgstr "" msgid "variance function not recognized for quasi" msgstr "" msgid "family not recognised" msgstr "" msgid "'theta' must be specified" msgstr "" msgid "%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"" msgstr "" msgid "H has wrong dimension" msgstr "" msgid "only scalar `rho' and `theta' allowed." msgstr "" msgid "1 0" msgstr "" msgid "maximum number of iterations must be > 0" msgstr "" msgid "silly value supplied for rank.tol: reset to square root of machine precision." msgstr "" msgid "Model seems to contain no terms" msgstr "" msgid "Discrete Theta search not available with performance iteration" msgstr "" msgid "y must be univariate unless binomial" msgstr "" msgid "Length of start should equal %d and correspond to initial coefs." msgstr "" msgid "iterative weights or data non-finite in gam.fit - regularization may help. See ?gam.control." msgstr "" msgid "Step size truncated: out of bounds." msgstr "" msgid "`object' is not of class \"gam\"" msgstr "" msgid "unrecognised na.action" msgstr "" msgid "na.action not character or function" msgstr "" msgid "Smoothness uncertainty corrected covariance not available" msgstr "" msgid "Unknown type, reset to terms." msgstr "" msgid "predict.gam can only be used to predict from gam objects" msgstr "" msgid "newdata is a model.frame: it should contain all required variables" msgstr "" msgid "not all required variables have been supplied in newdata!" msgstr "" msgid "type iterms not available for multiple predictor cases" msgstr "" msgid "non-existent terms requested - ignoring" msgstr "" msgid "non-existent exclude terms requested - ignoring" msgstr "" msgid "requires an object of class gam" msgstr "" msgid "nothing to do for this model" msgstr "" msgid "Pearson residuals not available for this family - returning deviance residuals" msgstr "" msgid "lambda and h should have the same length!" msgstr "" msgid "recov works with fitted gam objects only" msgstr "" msgid "m can't be in re" msgstr "" msgid "p-values may give low power in some circumstances" msgstr "" msgid "p-values un-reliable" msgstr "" msgid "p-values may give very low power" msgstr "" msgid "p-values for any terms that can be penalized to zero will be unreliable: refit model to fix this." msgstr "" msgid "p.type!=0 is deprecated, and liable to be removed in future" msgstr "" msgid "The following arguments to anova.glm(..) are invalid and dropped:" msgstr "" msgid "," msgstr "" msgid "un-supported test" msgstr "" msgid "test argument ignored" msgstr "" msgid "anova.gam called with non gam object" msgstr "" msgid "not a gam object" msgstr "" msgid "argument is not a gam object" msgstr "" msgid "S.scale vector doesn't match S list - please report to maintainer" msgstr "" msgid "Supplied matrix not symmetric" msgstr "" msgid "singular values not returned in order" msgstr "" msgid "Something wrong - matrix probably not +ve semi definite" msgstr "" msgid "method not recognised." msgstr "" msgid "S[[%d]] matrix is not +ve definite." msgstr "" msgid "dimensions of supplied w wrong." msgstr "" msgid "w different length from y!" msgstr "" msgid "X lost dimensions in magic!!" msgstr "" msgid "mu dimensions wrong" msgstr "" msgid "something wrong with inputs to LAPACK routine" msgstr "" msgid "not positive definite" msgstr "" msgid "don't be silly" msgstr "" msgid "sd should have exactly one less entry than ld" msgstr "" msgid "internal error in vcorr, please report to simon.wood@r-project.org" msgstr "" msgid "a has wrong number of rows" msgstr "" msgid "mvn requires 2 or more dimensional data" msgstr "" msgid "mvn does not yet handle offsets" msgstr "" msgid "mvn dimension error" msgstr "" msgid "object is not a glm or gam" msgstr "" msgid "names of z and pc must match" msgstr "" msgid "Partial residuals do not have a natural x-axis location for linear functional terms" msgstr "" msgid "no automatic plotting for smooths of more than two variables" msgstr "" msgid "no automatic plotting for smooths of more than one variable" msgstr "" msgid "residuals argument to plot.gam is wrong length: ignored" msgstr "" msgid "No variance estimates available" msgstr "" msgid "No terms to plot - nothing for plot.gam() to do." msgstr "" msgid "grid vectors are different lengths" msgstr "" msgid "data vectors are of different lengths" msgstr "" msgid "supplied dist negative" msgstr "" msgid "Model does not seem to have enough terms to do anything useful" msgstr "" msgid "view variables must be one of %s" msgstr "" msgid "Don't know what to do with parametric terms that are not simple numeric or factor variables" msgstr "" msgid "View variables must contain more than one value. view = c(%s,%s)." msgstr "" msgid "type must be \"link\" or \"response\"" msgstr "" msgid "Something wrong with zlim" msgstr "" msgid "color scheme not recognised" msgstr "" msgid "sorry no option for contouring with errors: try plot.gam" msgstr "" msgid "At least three knots required in call to mono.con." msgstr "" msgid "lower bound >= upper bound in call to mono.con()" msgstr "" msgid "x is null" msgstr "" msgid "uniquecombs has not worked properly" msgstr "" msgid "order too low" msgstr "" msgid "too few knots" msgstr "" msgid "x out of range" msgstr "" msgid "something wrong with argument d." msgstr "" msgid "one or more supplied k too small - reset to default" msgstr "" msgid "dimension of fx is wrong" msgstr "" msgid "xt argument is faulty." msgstr "" msgid "bs wrong length and ignored." msgstr "" msgid "m wrong length and ignored." msgstr "" msgid "Repeated variables as arguments of a smooth are not permitted" msgstr "" msgid "only first element of `id' used" msgstr "" msgid "supply a value for each variable for a point constraint" msgstr "" msgid "ord is wrong. reset to NULL." msgstr "" msgid "ord contains out of range orders (which will be ignored)" msgstr "" msgid "by=. not allowed" msgstr "" msgid "s(.) not yet supported." msgstr "" msgid "argument k of s() should be integer and has been rounded" msgstr "" msgid "attempt to use unsuitable marginal smooth class" msgstr "" msgid "Sorry, tensor products of smooths with multiple penalties are not supported." msgstr "" msgid "reparameterization unstable for margin: not done" msgstr "" msgid "single penalty tensor product smooths are deprecated and likely to be removed soon" msgstr "" msgid "basis not usable with reduced te" msgstr "" msgid "fx length wrong from t2 term: ignored" msgstr "" msgid "length of sp incorrect in t2: ignored" msgstr "" msgid "d can not be negative in call to null.space.dimension()." msgstr "" msgid "arguments of smooth not same dimension" msgstr "" msgid "components of knots relating to a single smooth must be of same length" msgstr "" msgid "more knots than data in a tp term: knots ignored." msgstr "" msgid "basis dimension, k, increased to minimum possible" msgstr "" msgid "no data to predict at" msgstr "" msgid "Basis only handles 1D smooths" msgstr "" msgid "number of supplied knots != k for a cr smooth" msgstr "" msgid "F is missing from cr smooth - refit model with current mgcv" msgstr "" msgid "more knots than unique data values is not allowed" msgstr "" msgid "number of supplied knots != k for a cc smooth" msgstr "" msgid "basis dimension too small for b-spline order" msgstr "" msgid "knot range does not include data" msgstr "" msgid "there should be" msgstr "" msgid "supplied knots" msgstr "" msgid "knots supplied" msgstr "" msgid "knot range is so wide that there is *no* information about some basis coefficients" msgstr "" msgid "penalty order too high for basis dimension" msgstr "" msgid "there is *no* information about some basis coefficients" msgstr "" msgid "basis dimension is larger than number of unique covariates" msgstr "" msgid "requested non-existent derivative in B-spline penalty" msgstr "" msgid "fs smooths can only have one factor argument" msgstr "" msgid "\"fs\" smooth cannot use a multiply penalized basis (wrong basis in xt)" msgstr "" msgid "no factor supplied to fs smooth" msgstr "" msgid "\"fs\" terms can not be fixed here" msgstr "" msgid "fs smooth not suitable for discretisation with more than one metric predictor" msgstr "" msgid "the adaptive smooth class is limited to 1 or 2 covariates." msgstr "" msgid "penalty basis too large for smoothing basis" msgstr "" msgid "penalty basis too small" msgstr "" msgid "random effects don't work with ids." msgstr "" msgid "Please put term with most levels last in 're' to avoid spoiling supplied penalties" msgstr "" msgid "supplied S matrices are wrong diminsion" msgstr "" msgid "argument of mrf should be a factor variable" msgstr "" msgid "MRF basis dimension set too high" msgstr "" msgid "data contain regions that are not contained in the knot specification" msgstr "" msgid "penalty matrix, boundary polygons and/or neighbours list must be supplied in xt" msgstr "" msgid "no spatial information provided!" msgstr "" msgid "mismatch between nb/polys supplied area names and data area names" msgstr "" msgid "Something wrong with auto- penalty construction" msgstr "" msgid "supplied penalty not square!" msgstr "" msgid "supplied penalty wrong dimension!" msgstr "" msgid "penalty column names don't match supplied area names!" msgstr "" msgid "Can only deal with a sphere" msgstr "" msgid "more knots than data in an sos term: knots ignored." msgstr "" msgid "more knots than data in a ds term: knots ignored." msgstr "" msgid "A term has fewer unique covariate combinations than specified maximum degrees of freedom" msgstr "" msgid "s value reduced" msgstr "" msgid "s value increased" msgstr "" msgid "No suitable s (i.e. m[2]) try increasing m[1]" msgstr "" msgid "s value modified to give continuous function" msgstr "" msgid "basis dimension reset to minimum possible" msgstr "" msgid "incorrect arguments to GP smoother" msgstr "" msgid "more knots than data in an ms term: knots ignored." msgstr "" msgid "smooth objects should not have a qrc attribute." msgstr "" msgid "unimplemented sparse constraint type requested" msgstr "" msgid "handling `by' variables in smooth constructors may not work with the summation convention" msgstr "" msgid "Can't find by variable" msgstr "" msgid "sweep and drop constraints unlikely to work well with self handling of by vars" msgstr "" msgid "factor `by' variables can not be used with matrix arguments." msgstr "" msgid "`by' variable must be same dimension as smooth arguments" msgstr "" msgid "Number of prediction and fit constraints must match" msgstr "" msgid "x and y must be same length" msgstr "" msgid "variable names don't match boundary names" msgstr "" msgid "x and y not same length" msgstr "" msgid "bnd must be a list." msgstr "" msgid "lengths of k and bnd are not compatible." msgstr "" msgid "attempt to select non existent basis function" msgstr "" msgid "coefficient vector wrong length" msgstr "" msgid "knots must be specified for soap" msgstr "" msgid "soap films are bivariate only" msgstr "" msgid "need at least one interior knot" msgstr "" msgid "can't soap smooth without a boundary" msgstr "" msgid "bnd must be a list of boundary loops" msgstr "" msgid "faulty bnd" msgstr "" msgid "k and bnd lengths are inconsistent" msgstr "" msgid "data outside soap boundary" msgstr "" msgid "no free coefs in sf smooth" msgstr "" msgid "only deals with 2D case" msgstr "" msgid "not enough unique values to find k nearest" msgstr "" msgid "cubic spline only deals with 1D data" msgstr "" msgid "object not fully initialized" msgstr "" mgcv/po/pl.po0000644000177400001440000001142012765741177013010 0ustar murdochusersmsgid "" msgstr "" "Project-Id-Version: mgcv 1.7-28\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2016-08-19 13:28+0100\n" "PO-Revision-Date: 2014-03-24 17:59+0100\n" "Last-Translator: Łukasz Daniel \n" "Language-Team: Łukasz Daniel \n" "Language: pl_PL\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=3; plural=(n==1 ? 0 : n%10>=2 && n%10<=4 && (n%100<10 " "|| n%100>=20) ? 1 : 2);\n" "X-Poedit-SourceCharset: iso-8859-1\n" "X-Generator: Poedit 1.5.4\n" # mgcv/src/magic.c: 440 # error(_("magic requires smoothing parameter starting values if L supplied")) #: magic.c:444 msgid "magic requires smoothing parameter starting values if L supplied" msgstr "" "'magic' wymaga wartości startowych dla parametru wygładzającego jeśli L " "zostało dostarczone" # mgcv/src/magic.c: 558 # error(_("magic, the gcv/ubre optimizer, failed to converge after 400 iterations.")) #: magic.c:562 msgid "magic, the gcv/ubre optimizer, failed to converge after 400 iterations." msgstr "" "'magic', omptymalizator gcv/ubre, nie zdodał uzbieżnić się po 400 iteracjach." # mgcv/src/matrix.c: 85 # (_("Failed to initialize memory for matrix."),1) #: matrix.c:80 msgid "Failed to initialize memory for matrix." msgstr "Nie udało się zainicjalizować pamięci dla macierzy." # mgcv/src/matrix.c: 147 # (_("An out of bound write to matrix has occurred!"),1) # mgcv/src/matrix.c: 210 # (_("An out of bound write to matrix has occurred!"),1) #: matrix.c:142 matrix.c:200 msgid "An out of bound write to matrix has occurred!" msgstr "Nastąpił zapis poza zakresem macierzy!" # mgcv/src/matrix.c: 153 # (_("INTEGRITY PROBLEM in the extant matrix list."),1) #: matrix.c:148 msgid "INTEGRITY PROBLEM in the extant matrix list." msgstr "PROBLEM SPÓJNOŚCI w istniejącej liście macierzy." # mgcv/src/matrix.c: 186 # (_("You are trying to check matrix integrity without defining RANGECHECK.")) #: matrix.c:180 msgid "You are trying to check matrix integrity without defining RANGECHECK." msgstr "Próbujesz sprawdzić integralność macierzy bez określania 'RANGECHECK'" # mgcv/src/matrix.c: 248 # (_("Target matrix too small in mcopy"),1) #: matrix.c:238 msgid "Target matrix too small in mcopy" msgstr "Docelowa macierz jest zbyt mała, aby wykonać 'mcopy'" # mgcv/src/matrix.c: 268 # (_("Incompatible matrices in matmult."),1) # mgcv/src/matrix.c: 276 # (_("Incompatible matrices in matmult."),1) # mgcv/src/matrix.c: 289 # (_("Incompatible matrices in matmult."),1) # mgcv/src/matrix.c: 297 # (_("Incompatible matrices in matmult."),1) #: matrix.c:258 matrix.c:266 matrix.c:279 matrix.c:287 msgid "Incompatible matrices in matmult." msgstr "Niespójne macierze w 'matmult'." # mgcv/src/matrix.c: 384 # (_("Attempt to invert() non-square matrix"),1) #: matrix.c:374 msgid "Attempt to invert() non-square matrix" msgstr "Próba odwrócenia metodą 'invert()' niekwadratowej macierzy" # mgcv/src/matrix.c: 406 # (_("Singular Matrix passed to invert()"),1) #: matrix.c:396 msgid "Singular Matrix passed to invert()" msgstr "Przekazano osobliwą macierz do 'invert()'" # mgcv/src/matrix.c: 1327 # (_("svd() not converged"),1) #: matrix.c:1316 msgid "svd() not converged" msgstr "'svd()' nie uzbieżnił się" # mgcv/src/matrix.c: 1403 # sprintf(err,_("svdroot matrix not +ve semi def. %g"),w.V[i]*w.V[i]) #: matrix.c:1392 #, c-format msgid "svdroot matrix not +ve semi def. %g" msgstr "macierz 'svdroot' nie jest dodatnio określona %g" # mgcv/src/matrix.c: 1431 # (_("Sort failed"),1) #: matrix.c:1420 msgid "Sort failed" msgstr "Sortowanie nie powiodło się" # mgcv/src/qp.c: 60 # (_("ERROR in addconQT."),1) #: qp.c:59 msgid "ERROR in addconQT." msgstr "BŁĄD w addconQT." # mgcv/src/qp.c: 466 # (_("QPCLS - Rank deficiency in model"),1) #: qp.c:465 msgid "QPCLS - Rank deficiency in model" msgstr "QPCLS - Niedobór rang w modelu" # mgcv/src/tprs.c: 46 # (_("You must have 2m>d for a thin plate spline."),1) # mgcv/src/tprs.c: 81 # (_("You must have 2m>d for a thin plate spline."),1) #: tprs.c:40 msgid "You must have 2m>d for a thin plate spline." msgstr "Musisz mieć 2m>d dla cienkiej płyty splajnu." # mgcv/src/tprs.c: 417 # (_("A term has fewer unique covariate combinations than specified maximum degrees of freedom"),1) # mgcv/src/tprs.c: 425 # (_("A term has fewer unique covariate combinations than specified maximum degrees of freedom"),1) # mgcv/R/smooth.r: 2518 # stop( # "A term has fewer unique covariate combinations than specified maximum degrees of freedom") #: tprs.c:375 tprs.c:383 msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" "Człon posiada mniej unikalnych kombinacji zmiennych niezależnych niż " "określona maksymalna liczba stopni swobody" mgcv/po/R-de.po0000644000177400001440000014126713046052674013167 0ustar murdochusers# Translation of R-mgcv.pot to German # Copyright (C) 2005-2015 The R Foundation # This file is distributed under the same license as the mgcv package. # Chris Leick , 2009 # Detlef Steuer , 2015 # msgid "" msgstr "" "Project-Id-Version: R 3.2.0 / mgcv 1.8-5\n" "Report-Msgid-Bugs-To: bugs@r-project.org\n" "POT-Creation-Date: 2017-02-06 09:59\n" "PO-Revision-Date: 2015-03-26 13:29+0100\n" "Last-Translator: Detlef Steuer \n" "Language-Team: R-Core \n" "Language: de\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n != 1);\n" msgid "bam can not discretize with this nesting structure" msgstr "" msgid "discretization can not handle smooth ids" msgstr "" msgid "'family' argument seems not to be a valid family object" msgstr "'family' Argument scheint kein zulässiges family Objekt zu sein" msgid "cannot find valid starting values: please specify some" msgstr "Kann keine gültigen Startwerte finden: Bitte geben Sie einige an" msgid "Deviance = %s Iterations - %d" msgstr "Devianz = %s Iterationen - %d" msgid "Non-finite deviance" msgstr "nicht-endliche Devianz" msgid "non-finite coefficients at iteration %d" msgstr "nicht-endliche Koeffizienten bei Iteration %d" msgid "algorithm did not converge" msgstr "Algorithmus hat nicht konvergiert" msgid "fitted probabilities numerically 0 or 1 occurred" msgstr "" "Es trat der Fall auf, dass die angepassten Wahrscheinlichkeiten numerisch 0 " "oder 1 waren" msgid "fitted rates numerically 0 occurred" msgstr "" "Es trat der Fall auf, dass die angepassten Quoten numerisch 0 oder 1 waren" msgid "Too many cluster nodes to use all efficiently" msgstr "" #, fuzzy msgid "iterms reset to terms" msgstr "Unbekannter Typ, wird auf terms zurückgesetzt." msgid "exclude ignored by discrete prediction at present" msgstr "" msgid "family not recognized" msgstr "family nicht erkannt" msgid "extended families not supported by bam" msgstr "" msgid "un-supported smoothness selection method" msgstr "nicht unterstützte Methode zur Glattheitswahl" msgid "discretization only available with fREML" msgstr "" msgid "discrete method does not use parallel cluster - use nthreads instead" msgstr "" msgid "min.sp not supported with fast REML computation, and ignored." msgstr "" "min.sp wird bei schneller REML Berechnung nicht unterstützt und ignoriert." msgid "Not enough (non-NA) data to do anything meaningful" msgstr "Nicht genug (nicht-NA-) Daten, um etwas Sinnvolles zu tun" msgid "AR.start must be logical" msgstr "AR.start muss logisch sein" msgid "chunk.size < number of coefficients. Reset to %d" msgstr "chunk.size < number of coefficients. Zurückgesetzt auf %d" #, fuzzy msgid "unknown tensor constraint type" msgstr "nicht implementierter dünn besetzter Nebenbedingungstyp verlangt" msgid "Model has more coefficients than data" msgstr "Modell hat mehr Koeffizienten als Daten" msgid "AR1 parameter rho unused with generalized model" msgstr "AR1 Parameter rho unbenutzt im verallgemeinerten Modell" msgid "samfrac too small - ignored" msgstr "samfrac zu klein - ignoriert" msgid "Model can not be updated" msgstr "Modell kann nicht aktualisiert werden" msgid "link not available for coxph family; available link is \"identity\"" msgstr "" "Link nicht verfügbar für die coxph Familie; \"identity\" Link ist verfügbar" msgid "NA times supplied for cox.ph prediction" msgstr "NA Zeiten für die coxph Vorhersage angegeben" msgid "cox.ph does not yet handle offsets" msgstr "" msgid "" "link not available for ordered categorical family; available links are " "\"identity\"" msgstr "" "Link nicht verfügbar für die angeordnete kategorielle Familie; \"identity\" " "Link ist verfügbar" msgid "Must supply theta or R to ocat" msgstr "theta oder R müssen an ocat übergeben werden" msgid "Response should be integer class labels" msgstr "" msgid "values out of range" msgstr "Werte außerhalb des zulässigen Bereichs" msgid "" "link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" "Link nicht verfügbar für die negativ-binomial-Familie; verfügbare\n" "Links sind \"identity\", \"log\", und \"sqrt\"" msgid "negative values not allowed for the negative binomial family" msgstr "negative Werte sind bei der negativ-binomial-Familie unzulässig" msgid "link \"%s\" not available for Tweedie family." msgstr "Link \"%s\" nicht verfügbar für die Tweedie-Familie" msgid "Tweedie p must be in interval (a,b)" msgstr "Tweedie p muss aus dem Intervall (a, b) sein" msgid "" "link not available for beta regression; available links are \"logit\", " "\"probit\", \"cloglog\" and \"cauchit\"" msgstr "" "Link nicht verfügbar für die beta Regression; verfügbare Links sind \"logit" "\", \"probit\", \"cloglog\" und \"cauchit\"" msgid "saturated likelihood may be inaccurate" msgstr "saturierte Likelihood kann ungenau sein" msgid "" "link not available for scaled t distribution; available links are \"identity" "\", \"log\", and \"inverse\"" msgstr "" "Link nicht verfügbar für die skalierte t-Verteilung; verfügbare Links sind " "\"identity\", \"log\" und \"inverse\"" msgid "scaled t df must be >2" msgstr "skalierte t df müssen >2 sein" msgid "NA values not allowed for the scaled t family" msgstr "NA Werte für die skalierte t-Verteilung nicht zulässig" msgid "" "link not available for zero inflated; available link for `lambda' is only " "\"loga\"" msgstr "" "Link nicht verfügbar für Null-Inflation; einziger verfügbarer Link für " "'lambda' ist \"loga\"" msgid "negative values not allowed for the zero inflated Poisson family" msgstr "" "negative Werte nicht zulässig für die null-inflationierte Poisson-Familie" msgid "Non-integer response variables are not allowed with ziP" msgstr "" "Nicht-ganzzahlige Antwortvariablen nicht zulässig bei null-inflationierter " "Poisson-Verteilung" msgid "Using ziP for binary data makes no sense" msgstr "" "Für binäre Daten macht Gebrauch null-inflationierter Poisson-Verteilung " "keinen Sinn" msgid "Possible divergence detected in fast.REML.fit" msgstr "" msgid "fast REML optimizer reached iteration limit" msgstr "schneller REML Optimierer erreichte max. Iterationszahl" msgid "Huber scale estiamte not converged" msgstr "" msgid "unsupported order of differentiation requested of gam.fit3" msgstr "nicht unterstützte Ordnung der Ableitung für gam.fit3 gefordert" msgid "illegal `family' argument" msgstr "unerlaubtes 'family'-Argument" # http://de.wikipedia.org/wiki/Prädiktor msgid "Invalid linear predictor values in empty model" msgstr "Ungültige Werte des linearen Prädiktors in leerem Modell" msgid "Invalid fitted means in empty model" msgstr "Ungültige angepasste Mittelwerte in leerem Modell" msgid "Length of start should equal %d and correspond to initial coefs for %s" msgstr "" "Länge von start sollte gleich %d sein und mit den initialen Koeffizienten " "für %s korrespondieren" msgid "Can't find valid starting values: please specify some" msgstr "" "Es wurden keine gültigen Startwerte gefunden: Bitte geben Sie einige an" msgid "NAs in V(mu)" msgstr "NAs in V(mu)" msgid "0s in V(mu)" msgstr "0s in V(mu)" msgid "NAs in d(mu)/d(eta)" msgstr "NAs in d(mu)/d(eta)" msgid "No observations informative at iteration %d" msgstr "Keine informativen Beobachtungen bei Iteration %d" msgid "Not enough informative observations." msgstr "Nicht genug informative Beobachtungen." msgid "Non-finite coefficients at iteration %d" msgstr "Nicht-endliche Koeffizienten bei Iteration %d" msgid "" "no valid set of coefficients has been found:please supply starting values" msgstr "" "es wurde keine gültige Menge von Koeffizienten gefunden: Bitte stellen Sie " "Startwerte bereit" msgid "Step size truncated due to divergence" msgstr "Schrittweite wurde wegen Divergenz reduziert" msgid "inner loop 1; can't correct step size" msgstr "innere Schleife 1; Schrittweite kann nicht korrigiert werden" msgid "Step size truncated: out of bounds" msgstr "Schrittweite verkleinert: Außerhalb der Begrenzung" msgid "inner loop 2; can't correct step size" msgstr "innere Schleife 2; Schrittweite kann nicht korrigiert werden" msgid "penalized deviance = %s" msgstr "penalisierte Devianz = %s" msgid "inner loop 3; can't correct step size" msgstr "innere Schleife 3; Schrittweite kann nicht korrigiert werden" msgid "Step halved: new penalized deviance = %g" msgstr "Schrittweite halbiert: neue penalisierte Devianz = %g" msgid "" "Non finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" "Unendliche Ableitungen. Versuchen Sie die Anpassungstoleranz zu reduzieren! " "Siehe 'epsilon' in 'gam.control'" msgid "" "Non-finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" "Unendliche Ableitungen. Versuchen Sie die Anpassungstoleranz zu reduzieren! " "Siehe 'epsilon' in 'gam.control'" msgid "Algorithm did not converge" msgstr "Algorithmus konvergierte nicht" msgid "Algorithm stopped at boundary value" msgstr "Algorithmus stoppte beim Randwert" msgid "deriv should be 1 or 2" msgstr "deriv sollte 1 oder 2 sein" msgid "L must be a matrix." msgstr "L muss eine Matrix sein." msgid "L must have at least as many rows as columns." msgstr "L muss mindestens so viele Zeilen wie Spalten haben." msgid "L has inconsistent dimensions." msgstr "L hat inkonsistente Dimensionen." msgid "Fitting terminated with step failure - check results carefully" msgstr "" msgid "Iteration limit reached without full convergence - check carefully" msgstr "" msgid "link not implemented for extended families" msgstr "Link nicht implementiert für erweiterte Familien" msgid "fam not a family object" msgstr "fam ist kein family-Objekt" msgid "unrecognized (vector?) link" msgstr "unerkannter (Vektor?) Verweis" msgid "link not recognised" msgstr "Verweis nicht erkannt" msgid "variance function not recognized for quasi" msgstr "Varianzfunktion für quasi nicht erkannt" # R/gam.fit3.r msgid "family not recognised" msgstr "family nicht erkannt" msgid "'theta' must be specified" msgstr "'theta' muss angegeben werden" msgid "" "%s link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" "%s Link nicht verfügbar für die negativ-binomial-Familie; verfügare Links " "sind \"identity\", \"log\" und \"sqrt\"" msgid "H has wrong dimension" msgstr "H hat falsche Dimension" msgid "only scalar `rho' and `theta' allowed." msgstr "Nur skalare 'rho' und 'theta' erlaubt." msgid "1 0 sein" #, fuzzy msgid "number of linear predictors doesn't match" msgstr "falsche Anzahl linearer Prädiktoren für diese Familie" msgid "response not in 0 to number of predictors + 1" msgstr "" msgid "ziplss requires 2 links specified as character strings" msgstr "ziplss verlangt 2 Links, angegeben als Zeichenketten" msgid "link not available for" msgstr "Link nicht verfügbar für" msgid "parameter of ziplss" msgstr "Parameter von ziplss" msgid "Non-integer response variables are not allowed with ziplss" msgstr "Nicht-ganzzahlige Antwortvariablen bei ziplss nicht erlaubt" msgid "Using ziplss for binary data makes no sense" msgstr "Gebrauch von ziplss bei binären Daten ergibt keinen Sinn" #, fuzzy msgid "gevlss requires 3 links specified as character strings" msgstr "gaulss verlangt 2 Links, angegeben als Zeichenketten" msgid "An object of length %d does not match the required parameter size" msgstr "" "Ein Objekt der Länge %d entspricht nicht der erforderlichen Parametergröße" msgid "NA's in pdTens factor" msgstr "NA's in pdTens-Faktor" msgid "Cannot extract the matrix from an uninitialized object" msgstr "" "Die Matrix kann nicht aus einem uninitialisierten Objekt extrahiert werden" msgid "NA's in pdTens matrix" msgstr "NA's in pdTens-Matrix" msgid "Cannot extract the matrix from an uninitialized pdMat object" msgstr "" "Die Matrix kann nicht aus einem uninitialisierten pdMat-Objekt extrahiert " "werden" msgid "Cannot extract the matrix with uninitialized dimensions" msgstr "" "Die Matrix kann nicht mit uninitialisierten Dimensionen extrahiert werden" msgid "An object of length" msgstr "Ein Objekt der Länge" msgid "does not match the required parameter size" msgstr "entspricht nicht der erforderlichen Parametergröße" msgid "Must give names when initializing pdIdnot from parameter." msgstr "" "Wenn pdIdnot vom Parameter initialisiert wird, müssen Namen vergeben werden." msgid "without a formula" msgstr "ohne eine Formel" msgid "Cannot extract the dimensions" msgstr "Die Dimensionen können nicht extrahiert werden" msgid "Cannot extract the inverse from an uninitialized object" msgstr "" "Die Inverse kann nicht von einem uninitialisierten Objekt extrahiert werden" msgid "Can not convert this smooth class to a random effect" msgstr "Kann diese glatte Klasse nicht in zufälligen Effekt konvertieren" msgid "te smooths not useable with gamm4: use t2 instead" msgstr "te Glättungen nicht nutzbar bei gamm4: nutze stattdessen t2" msgid "gamm can not fix only some margins of tensor product." msgstr "gamm kann nicht nur einige Ränder des Tensorproduktes reparieren." msgid "" "Tensor product penalty rank appears to be too low: please email Simon.Wood@R-" "project.org with details." msgstr "" "Tensorprodukt-Strafrang scheint zu niedrig zu sein: Bitte E-Mail mit Details " "an Simon.Wood@R-project.org" msgid "No data supplied to gamm.setup" msgstr "Keine Daten für gamm.setup bereitgestellt" msgid "" "gamm can not handle linked smoothing parameters (probably from use of `id' " "or adaptive smooths)" msgstr "" "gamm kann mit gelinkten Glättungsparametern nicht umgehen (vermutlich aus " "der Nutzung von 'id' oder adaptiven Glättern)" msgid "only one level of smooth nesting is supported by gamm" msgstr "nur eine Stufe von Glättungsverschachtelung wird von gamm unterstützt" msgid "side conditions not allowed for nested smooths" msgstr "Nebenbedingungnen nicht erlaubt für verschachtelte Glättungen" msgid "object does not appear to be of class lme" msgstr "Objekt scheint nicht von der Klasse lme zu sein" msgid "inner groupings not nested in outer!!" msgstr "innere Gruppierungen nicht in äußeren verschachtelt!" msgid "iteration %d" msgstr "Iteration %d" msgid "gamm not converged, try increasing niterPQL" msgstr "gamm ist nicht konvergiert, versuche niterPQL zu erhöhen" msgid "family are not designed for use with gamm!" msgstr "" # R/gamm.r msgid "random argument must be a *named* list." msgstr "random-Argument muss eine *benannte* Liste sein." msgid "all elements of random list must be named" msgstr "alle Elemente der random-Liste müssen benannt sein" msgid "gamm() can only handle random effects defined as named lists" msgstr "" "gamm() kann nur random-Effekte handhaben, die als benannte Liste definiert " "sind" msgid "" "gamm models must have at least 1 smooth with unknown smoothing parameter or " "at least one other random effect" msgstr "" "gamm-Modelle müssen mindestens 1 Glättung mit unbekanntem Glättungsparameter " "haben oder mindestens eine mit anderem random-Effekt" msgid "weights must be like glm weights for generalized case" msgstr "Gewichte müssen wie glm-Gewichte sein für verallgemeinerten Fall" msgid "Nested smooths must be fully random" msgstr "Verschachtelte Glättungen müssen komplett zufällig sein" msgid "sorry link not yet handled" msgstr "Sorry, Link noch nicht implementiert" msgid "weights ignored" msgstr "Gewichte ignoriert" # R/gam.fit3.r msgid "family not implemented yet" msgstr "Familie noch nicht implementiert" msgid "jagam requires a file for the JAGS model specification" msgstr "jagam verlangt eine Datei für die JAGS Modellspezifikation" msgid "smoothing parameter prior choise not recognised, reset to gamma" msgstr "Glättungsparameterwahl nicht erkannt, falle zurück auf gamma" msgid "coefficient simulation data is missing" msgstr "Koeffizienten-Simulationsdaten fehlen" msgid "burnin too large, reset" msgstr "Vorlauf zu groß, zurückgesetzt" msgid "rho missing from simulation data edf.type reset to 2" msgstr "rho fehlt in den Simulationsdaten, edf.type auf 2 zurückgesetzt" msgid "residuals argument not supported" msgstr "Argument residuals wird nicht unterstützt" msgid "unconditional argument not meaningful here" msgstr "das unbedingte Argument hat hier keine Bedeutung" msgid "by.resids argument not supported" msgstr "by.resids Argument wird nicht unterstützt" msgid "all.terms argument not supported" msgstr "all.terms Argument wird nicht unterstützt" msgid "silly tolerance supplied" msgstr "unangemessene Toleranz angegeben" msgid "argument k must be positive." msgstr "Argument k muss positiv sein" msgid "A not square" msgstr "A ist nicht quadratisch" msgid "Can not have more eigenvalues than nrow(A)" msgstr "Es kann maximal nrow(A) Eigenwerte geben" msgid "nrow(M$X) != length(M$y)" msgstr "nrow(M$X) != length(M$y)" msgid "ncol(M$X) != length(M$p)" msgstr "ncol(M$X) != length(M$p)" msgid "length(M$w) != length(M$y)" msgstr "length(M$w) != length(M$y)" msgid "nrow(M$Ain) != length(M$bin)" msgstr "nrow(M$Ain) != length(M$bin)" msgid "nrow(M$Ain) != length(M$p)" msgstr "nrow(M$Ain) != length(M$p)" msgid "initial parameters not feasible" msgstr "Anfangsparameter sind nicht nutzbar" msgid "initial point very close to some inequality constraints" msgstr "Anfangsparameter sehr nah an einigen Ungleichungsnebenbedingungen" msgid "initial parameters very close to inequality constraints" msgstr "Anfangsparameter sehr nah an den Ungleichungsnebenbedingungen" msgid "ncol(M$C) != length(M$p)" msgstr "ncol(M$C) != length(M$p)" msgid "M$S and M$off have different lengths" msgstr "M$S und M$off haben unterschiedliche Längen" msgid "M$sp has different length to M$S and M$off" msgstr "M$sp hat unterschiedliche Länge zu M$S und M$off" msgid "M$S[%d] is too large given M$off[%d]" msgstr "M$[%d] ist zu groß zum gegeben M$off[%d]" msgid "Penalized model matrix must have no more columns than rows" msgstr "Die penalisierte Modellmatrix darf nicht mehr Spalten als Zeilen haben" msgid "Model matrix not full column rank" msgstr "Modellmatrix hat keinen vollen Spaltenrang" msgid "can't handle [[ in formula" msgstr "" # http://de.wikipedia.org/wiki/Prädiktor #, fuzzy msgid "single linear predictor indices are ignored" msgstr "Ungültige Werte des linearen Prädiktors in leerem Modell" #, fuzzy msgid "linear predictor labels out of range" msgstr "Werte außerhalb des zulässigen Bereichs" msgid "model has repeated 1-d smooths of same variable." msgstr "Modell hat 1-d-Glättungen derselben Variable wiederholt." msgid "`id' linked smooths must have same number of arguments" msgstr "'id' gelinkte Glätter müssen die selbe Anzahl von Argumenten haben" msgid "`rank' has wrong length in `paraPen'" msgstr "'rank' hat die falsche Länge in 'paraPen'" msgid "a parametric penalty has wrong dimension" msgstr "ein parametrischer Strafterm hat die falsche Dimension" msgid "L has wrong dimension in `paraPen'" msgstr "L hat falsche Dimension in 'paraPen'" msgid "`sp' dimension wrong in `paraPen'" msgstr "'sp' Dimension in 'paraPen' falsch" msgid "`sp' too short" msgstr "'sp' zu kurz" msgid "No data supplied to gam.setup" msgstr "Keine Daten für gam.setup bereitgestellt" msgid "paraPen not supported for multi-formula models" msgstr "paraPen für multi-formel Modelle nicht unterstützt" msgid "absorb.cons must be TRUE for multi-formula models" msgstr "absorb.cons muss für multi-formel Modelle TRUE sein" msgid "length(drop.intercept) should be equal to number of model formulas" msgstr "" msgid "shared offsets not allowed" msgstr "" msgid "dropping unidentifiable parametric terms from model" msgstr "" msgid "First argument is no sort of formula!" msgstr "Erstes Argument ist keine Art von Formel" msgid "You've got no model...." msgstr "Sie haben kein Modell ..." msgid "" "Later terms sharing an `id' can not have more smoothing parameters than the " "first such term" msgstr "" "Später auftretende Terme, die eine 'id' teilen, können nicht mehr " "Glättungsparameter haben als der erste solche Term" msgid "Supplied smoothing parameter vector is too short - ignored." msgstr "Angegebener Glättungsparameter-Vektor ist zu kurz - ignoriert." msgid "NA's in supplied smoothing parameter vector - ignoring." msgstr "NAs in angegebenem Glättungsparameter-Vektor ist zu kurz - ignoriert." msgid "incorrect number of smoothing parameters supplied for a smooth term" msgstr "" "falsche Anzahl von Glättungsparametern an einen Glättungsterm übergeben" msgid "length of min.sp is wrong." msgstr "Länge von min.sp ist falsch." msgid "NA's in min.sp." msgstr "NA's in min.sp." msgid "elements of min.sp must be non negative." msgstr "Elemente von min.sp dürfen nicht negativ sein." msgid "unknown outer optimization method." msgstr "Unbekannte äußere Optimierungsmethode" #, fuzzy msgid "Extended Fellner Schall only implemented for general families" msgstr "Link nicht implementiert für erweiterte Familien" msgid "Please provide a single value for theta or use nb to estimate it" msgstr "" msgid "nlm.fd only available for GCV/UBRE" msgstr "nlm.fd nur verfügbar für GCV/UBRE" msgid "unknown optimizer" msgstr "unbekannter Optimierer" msgid "unknown smoothness selection criterion" msgstr "unbekanntes Glattheitswahl-Kriterium" msgid "Reset optimizer to outer/newton" msgstr "Optimierer auf outer/newton zurückgesetzt" msgid "in.out incorrect: see documentation" msgstr "in.out falsch: bitte in der Dokumentation nachsehen" msgid "incorrect number of linear predictors for family" msgstr "falsche Anzahl linearer Prädiktoren für diese Familie" msgid "edge.correct must be logical or a positive number" msgstr "" msgid "nthreads must be a positive integer" msgstr "nthreads muss eine positive, ganze Zahl sein" msgid "IRLS regularizing parameter must be a non-negative number." msgstr "IRLS-regelnder Parameter muss eine nicht-negative Zahl sein." msgid "value of epsilon must be > 0" msgstr "Wert von epsilon muss > 0 sein" msgid "maximum number of iterations must be > 0" msgstr "maximale Anzahl der Iterationen muss > 0 sein" msgid "" "silly value supplied for rank.tol: reset to square root of machine precision." msgstr "" "dummer Wert für rank.tol angegeben: Wird auf Quadratwurzel der " "Maschinenpräzision zurückgesetzt." msgid "Model seems to contain no terms" msgstr "Modell scheint keine Terme zu enthalten" msgid "Discrete Theta search not available with performance iteration" msgstr "Diskrete Theta-Suche nicht mit Leistungsiteration verfügbar" # http://de.wikipedia.org/wiki/Transferfunktionsmodell msgid "y must be univariate unless binomial" msgstr "Y muss univariat sein, falls nicht binomisch" msgid "Length of start should equal %d and correspond to initial coefs." msgstr "" "Länge von start sollte %d sein und mit den initialen Koeffizienten " "korrespondieren" msgid "" "iterative weights or data non-finite in gam.fit - regularization may help. " "See ?gam.control." msgstr "" "iterative Gewichte oder nicht-endliche Daten in gam.fit - Regularisierung " "könnte helfen. Siehe ?gam.control." msgid "Step size truncated: out of bounds." msgstr "Schrittgröße verkleinert: Außerhalb der Begrenzungen." msgid "`object' is not of class \"gam\"" msgstr "'object' ist nicht aus der Klasse \"gam\"" #, fuzzy msgid "unrecognised na.action" msgstr "unerkannter (Vektor?) Verweis" msgid "na.action not character or function" msgstr "" msgid "Smoothness uncertainty corrected covariance not available" msgstr "Glattheitsunsicherheits-korrigierte Kovarianz ist nicht verfügbar" msgid "Unknown type, reset to terms." msgstr "Unbekannter Typ, wird auf terms zurückgesetzt." msgid "predict.gam can only be used to predict from gam objects" msgstr "" "predict.gam kann nur benutzt werden, um auf Basis von gam-Objekten " "vorherzusagen" msgid "newdata is a model.frame: it should contain all required variables" msgstr "" "newdata ist ein model.frame: Es soll alle benötigten Variablen enthalten" msgid "not all required variables have been supplied in newdata!" msgstr "nicht alle benötigten Variablen wurden in newdata angegeben!" msgid "type iterms not available for multiple predictor cases" msgstr "Typ iterms ist für den Fall multipler Prädiktoren nicht verfügbar" msgid "non-existent terms requested - ignoring" msgstr "nicht existierende Terme angefordert - wird ignoriert" #, fuzzy msgid "non-existent exclude terms requested - ignoring" msgstr "nicht existierende Terme angefordert - wird ignoriert" msgid "requires an object of class gam" msgstr "verlangt ein Objekt der Klasse gam" msgid "nothing to do for this model" msgstr "nichts zu tun für dieses Modell" msgid "" "Pearson residuals not available for this family - returning deviance " "residuals" msgstr "" "Pearson-Residuen für diese Familie nicht verfügbar - geben Devianz-Residuen " "zurück" msgid "lambda and h should have the same length!" msgstr "lambda und h sollten die selbe Länge haben!" msgid "recov works with fitted gam objects only" msgstr "recov funktioniert nur bei gefitteten gam Objekten" msgid "m can't be in re" msgstr "m kann nicht in re sein" msgid "p-values may give low power in some circumstances" msgstr "p-Werte können unter Umständen geringere Power geben" msgid "p-values un-reliable" msgstr "p-Werte unzuverlässig" msgid "p-values may give very low power" msgstr "p-Werte geben evtl. sehr geringe Power" msgid "" "p-values for any terms that can be penalized to zero will be unreliable: " "refit model to fix this." msgstr "" "Die p-Werte für einen Term, der auf Null bestraft werden kann, sind " "unzuverlässig: Modell wird neu angepasst, um dies zu korrigieren." msgid "p.type!=0 is deprecated, and liable to be removed in future" msgstr "p.type!=0 ist veraltet und wird in der Zukunft entfernt" msgid "The following arguments to anova.glm(..) are invalid and dropped:" msgstr "Die folgenden Argumente für anova.glm(..) sind ungültig und entfallen:" msgid "," msgstr "," msgid "un-supported test" msgstr "" msgid "test argument ignored" msgstr "Argument test ignoriert" msgid "anova.gam called with non gam object" msgstr "anova.gam mit einem nicht-gam-Objekt aufgerufen" msgid "not a gam object" msgstr "kein gam Objekt" msgid "argument is not a gam object" msgstr "Argument ist kein gam Objekt" msgid "S.scale vector doesn't match S list - please report to maintainer" msgstr "" msgid "Supplied matrix not symmetric" msgstr "Angegebene Matrix nicht symmetrisch" msgid "singular values not returned in order" msgstr "Singulärwerte wurden nicht sortiert zurückgeliefert" msgid "Something wrong - matrix probably not +ve semi definite" msgstr "Etwas stimmt nicht - Matrix wahrscheinlich nicht +ve halb definit" msgid "method not recognised." msgstr "Methode nicht erkannt." msgid "S[[%d]] matrix is not +ve definite." msgstr "S[[%d]] Matrix ist nicht +ve definit." msgid "dimensions of supplied w wrong." msgstr "Dimensionen des angegebenen w sind falsch." msgid "w different length from y!" msgstr "w hat eine von y verschiedene Länge!" msgid "X lost dimensions in magic!!" msgstr "X verlor Dimensionen in magic!!" #, fuzzy msgid "mu dimensions wrong" msgstr "Dimension von fx ist falsch" #, fuzzy msgid "something wrong with inputs to LAPACK routine" msgstr "Etwas stimmt nicht mit der automatischen Straftermkonstruktion" msgid "not positive definite" msgstr "" msgid "don't be silly" msgstr "" msgid "sd should have exactly one less entry than ld" msgstr "" msgid "internal error in vcorr, please report to simon.wood@r-project.org" msgstr "" msgid "a has wrong number of rows" msgstr "a hat die falsche Zeilenzahl" msgid "mvn requires 2 or more dimensional data" msgstr "mvn benötigt zwei- oder höherdimensionale Daten" msgid "mvn does not yet handle offsets" msgstr "" msgid "mvn dimension error" msgstr "" msgid "object is not a glm or gam" msgstr "Obejekt ist weder glm noch gam" msgid "names of z and pc must match" msgstr "Namen von z und pc müssen übereinstimmen" msgid "" "Partial residuals do not have a natural x-axis location for linear " "functional terms" msgstr "" "Partielle Residuen haben keine natürliche x-Achsen Lage für lineare " "funktionale Ausdrücke" msgid "no automatic plotting for smooths of more than two variables" msgstr "" "keine automatische Darstellung für Glättungen von mehr als zwei Variablen" msgid "no automatic plotting for smooths of more than one variable" msgstr "" "keine automatische Darstellung für Glättungen von mehr als einer Variable" msgid "residuals argument to plot.gam is wrong length: ignored" msgstr "Residuen-Argument für plot.gam hat falsche Länge: Ignoriert" msgid "No variance estimates available" msgstr "Keine Varianzschätzungen verfügbar" msgid "No terms to plot - nothing for plot.gam() to do." msgstr "Keine Terme zum Darstellen - nichts für plot.gam() zu tun." msgid "grid vectors are different lengths" msgstr "Gittervektoren haben unterschiedliche Längen" msgid "data vectors are of different lengths" msgstr "Datenvektoren haben unterschiedliche Längen" msgid "supplied dist negative" msgstr "angegebene Entfernung negativ" msgid "Model does not seem to have enough terms to do anything useful" msgstr "Modell scheint nicht genug Terme zu haben, um etwas Nützliches zu tun" msgid "view variables must be one of %s" msgstr "Die view Variablen müssen aus %s gewählt werden" msgid "" "Don't know what to do with parametric terms that are not simple numeric or " "factor variables" msgstr "" "Weiß nichts anzufangen mit parametrischen Ausdrücken, die weder einfach " "numerisch noch Faktorvariablen sind" msgid "View variables must contain more than one value. view = c(%s,%s)." msgstr "View-Variablen müssen mehr als einen Wert enthalten. view = c(%s,%s)" msgid "type must be \"link\" or \"response\"" msgstr "Typ muss 'link' oder 'response' sein" msgid "Something wrong with zlim" msgstr "Etwas stimmt nicht mit zlim" msgid "color scheme not recognised" msgstr "Farbschema nicht erkannt" msgid "sorry no option for contouring with errors: try plot.gam" msgstr "" "Entschuldigung. Keine Option für Formgebung mit Fehlern: Versuchen Sie plot." "gam" msgid "At least three knots required in call to mono.con." msgstr "Mindestens drei Knoten im Aufruf von mono.con benötigt." msgid "lower bound >= upper bound in call to mono.con()" msgstr "untere Grenze >= obere Grenze im Aufruf von mono.con()" msgid "x is null" msgstr "x ist Null" msgid "uniquecombs has not worked properly" msgstr "" msgid "order too low" msgstr "Ordnung zu klein" msgid "too few knots" msgstr "zu wenige Knoten" msgid "x out of range" msgstr "x außerhalb des Wertebereichs" msgid "something wrong with argument d." msgstr "etwas stimmt nicht mit Argument d." msgid "one or more supplied k too small - reset to default" msgstr "" "ein oder mehrere bereitgestellte k zu klein - wird auf Standard zurückgesetzt" msgid "dimension of fx is wrong" msgstr "Dimension von fx ist falsch" msgid "xt argument is faulty." msgstr "xt-Argument ist fehlerhaft." msgid "bs wrong length and ignored." msgstr "bs hat falsche Länge und wird ignoriert." msgid "m wrong length and ignored." msgstr "m hat falsche Länge und wird ignoriert." msgid "Repeated variables as arguments of a smooth are not permitted" msgstr "Wiederholte Variablen als Argumente einer Glättung sind nicht erlaubt" msgid "only first element of `id' used" msgstr "nur das erste Element von 'id' wird genutzt" msgid "supply a value for each variable for a point constraint" msgstr "" msgid "ord is wrong. reset to NULL." msgstr "ord ist falsch, wird auf NULL zurückgesetzt" msgid "ord contains out of range orders (which will be ignored)" msgstr "" "ord enthält Ordungen außerhalb des Wertebereichs (die ignoriert werden)" msgid "by=. not allowed" msgstr "by=. nicht erlaubt" msgid "s(.) not yet supported." msgstr "s(.) wird noch nicht unterstützt." msgid "argument k of s() should be integer and has been rounded" msgstr "Argument k von s() sollte ganzzahlig sein und wurde gerundet" msgid "attempt to use unsuitable marginal smooth class" msgstr "Versuch unpassende Randglätterklasse zu nutzen" msgid "" "Sorry, tensor products of smooths with multiple penalties are not supported." msgstr "" "Sorry, Tensorprodukte von Glättern mit multiplen Strafen werden nicht " "unterstützt." msgid "reparameterization unstable for margin: not done" msgstr "Reparametrisierung für den Rand instabil: nicht durchgeführt" msgid "" "single penalty tensor product smooths are deprecated and likely to be " "removed soon" msgstr "" "Tensorprodukt-Glätter mit einfachem Strafterm sind veraltet und werden " "wahrscheinlich bald entfernt" msgid "basis not usable with reduced te" msgstr "" msgid "fx length wrong from t2 term: ignored" msgstr "falsche Länge für fx aus dem t2 Ausdruck: wird ignoriert" msgid "length of sp incorrect in t2: ignored" msgstr "falsche Länge für sp in t2: wird ignoriert" msgid "d can not be negative in call to null.space.dimension()." msgstr "d kann im Aufruf von null.space.dimension() nicht negativ sein." msgid "arguments of smooth not same dimension" msgstr "Argumente der Glättung haben nicht dieselbe Dimension" msgid "components of knots relating to a single smooth must be of same length" msgstr "" "Komponenten der Knoten, die sich auf eine einzige Glättung beziehen, müssen " "die gleiche Länge haben" msgid "more knots than data in a tp term: knots ignored." msgstr "mehr Knoten als Daten in einem tp-Term: Knoten ignoriert." msgid "basis dimension, k, increased to minimum possible" msgstr "Basisdimension, k, erhöht auf mögliches Minimum" msgid "no data to predict at" msgstr "keine Daten zum Vorausberechnen von" msgid "Basis only handles 1D smooths" msgstr "Basis arbeitet nur mit 1D-Glättungen" msgid "number of supplied knots != k for a cr smooth" msgstr "Anzahl der angegebenen Knoten != k für eine cr-Glättung" msgid "F is missing from cr smooth - refit model with current mgcv" msgstr "F fehlt im cr-Glätter - Modell wird mit aktuellem mgcv neu angepasst" msgid "more knots than unique data values is not allowed" msgstr "mehr Knoten als einheitliche Datenwerte sind nicht erlaubt" msgid "number of supplied knots != k for a cc smooth" msgstr "Anzahl der angegebenen Knoten != k für eine cc-Glättung" msgid "basis dimension too small for b-spline order" msgstr "Basisdimension zu klein für die b-Spline Ordnung" msgid "knot range does not include data" msgstr "Bereich der Knoten enthält keine Daten" msgid "there should be" msgstr "da sollten sein" msgid "supplied knots" msgstr "angegebene Knoten" msgid "knots supplied" msgstr "Knoten angegeben" msgid "" "knot range is so wide that there is *no* information about some basis " "coefficients" msgstr "" "Knotenbereich ist so weit, dass er *keine* Information über einige " "Basiskoeffizienten enthält. " msgid "penalty order too high for basis dimension" msgstr "Straftermordnung zu groß für die Basisdimension" #, fuzzy msgid "there is *no* information about some basis coefficients" msgstr "" "Knotenbereich ist so weit, dass er *keine* Information über einige " "Basiskoeffizienten enthält. " msgid "basis dimension is larger than number of unique covariates" msgstr "" "Basisdimension ist größer als die Zahl der unterschiedlichen Kovariaten" msgid "requested non-existent derivative in B-spline penalty" msgstr "" msgid "fs smooths can only have one factor argument" msgstr "fs-Glätter können nur ein Faktorargument haben" msgid "\"fs\" smooth cannot use a multiply penalized basis (wrong basis in xt)" msgstr "" "\"fs\" Glätter kann keine mehrfach bestrafte Basis nutzen (falsche Basis\n" "in xt)" #, fuzzy msgid "no factor supplied to fs smooth" msgstr "Keine Daten für gam.setup bereitgestellt" msgid "\"fs\" terms can not be fixed here" msgstr "\"fs\" Ausdrücke können nicht hier festgelegt werden" msgid "" "fs smooth not suitable for discretisation with more than one metric predictor" msgstr "" msgid "the adaptive smooth class is limited to 1 or 2 covariates." msgstr "Die adaptive Glätterklasse ist beschränkt auf 1 oder 2 Kovariaten." msgid "penalty basis too large for smoothing basis" msgstr "Straftermbasis ist zu groß für die Glättungsbasis" msgid "penalty basis too small" msgstr "Straftermordnung zu klein" msgid "random effects don't work with ids." msgstr "zufällige Effekte arbeiten nicht mit ids" msgid "" "Please put term with most levels last in 're' to avoid spoiling supplied " "penalties" msgstr "" #, fuzzy msgid "supplied S matrices are wrong diminsion" msgstr "Angegebener Strafterm hat falsche Dimension!" #, fuzzy msgid "argument of mrf should be a factor variable" msgstr "Argument k von s() sollte ganzzahlig sein und wurde gerundet" msgid "MRF basis dimension set too high" msgstr "MRF Basisdimension ist zu hoch gesetzt" msgid "data contain regions that are not contained in the knot specification" msgstr "" "Daten enthalten Gebiete, die nicht in der Knotenspezifikation enthalten sind" msgid "" "penalty matrix, boundary polygons and/or neighbours list must be supplied in " "xt" msgstr "" "Straftermmatrix, Grenzpolygone und/oder die Nachbarliste muss in xt " "angegeben werden" msgid "no spatial information provided!" msgstr "keine räumliche Information angegeben!" msgid "mismatch between nb/polys supplied area names and data area names" msgstr "area names aus nb/poly und Daten passen nicht zusammen" msgid "Something wrong with auto- penalty construction" msgstr "Etwas stimmt nicht mit der automatischen Straftermkonstruktion" msgid "supplied penalty not square!" msgstr "angegebener Strafterm nicht quadratisch!" msgid "supplied penalty wrong dimension!" msgstr "Angegebener Strafterm hat falsche Dimension!" msgid "penalty column names don't match supplied area names!" msgstr "Straftermspaltennamen passen nicht zu den angegebenen area names!" msgid "Can only deal with a sphere" msgstr "Kann nur mit einer Sphäre umgehen" msgid "more knots than data in an sos term: knots ignored." msgstr "mehr Knoten als Daten in einem sos Term: Knoten ignoriert." msgid "more knots than data in a ds term: knots ignored." msgstr "mehr Knoten als Daten in einem ds Term: Knoten ignoriert." msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" "Ein Ausdruck hat weniger eindeutige Kombinationen von Kovariaten als die " "angegebene maximale Zahl von Freiheitsgraden" msgid "s value reduced" msgstr "s Wert reduziert" msgid "s value increased" msgstr "s Wert erhöht" msgid "No suitable s (i.e. m[2]) try increasing m[1]" msgstr "Kein passendes s (z.B. m[2]), versuche m[1] zu erhöhen" msgid "s value modified to give continuous function" msgstr "S Wert verändert, um eine stetige Funktion zu erhalten" msgid "basis dimension reset to minimum possible" msgstr "Basisdimension auf mögliches Minimum zurückgesetzt" msgid "incorrect arguments to GP smoother" msgstr "" #, fuzzy msgid "more knots than data in an ms term: knots ignored." msgstr "mehr Knoten als Daten in einem sos Term: Knoten ignoriert." msgid "smooth objects should not have a qrc attribute." msgstr "Glättungsobjekte sollten kein qrc-Attribut haben" msgid "unimplemented sparse constraint type requested" msgstr "nicht implementierter dünn besetzter Nebenbedingungstyp verlangt" msgid "" "handling `by' variables in smooth constructors may not work with the " "summation convention" msgstr "" "die Handhabung von 'by' Variablen in der Glättungskonstruktion funktioniert " "evtl. nicht mit der Summationskonvention" msgid "Can't find by variable" msgstr "Kann nicht über Variable gefunden werden" msgid "" "sweep and drop constraints unlikely to work well with self handling of by " "vars" msgstr "" msgid "factor `by' variables can not be used with matrix arguments." msgstr "" "Faktor-'by'-Variablen können nicht mit Matrixargumenten benutzt werden." msgid "`by' variable must be same dimension as smooth arguments" msgstr "" "'by'-Variable muss die gleiche Dimension wie die Glättungsargumente haben" msgid "Number of prediction and fit constraints must match" msgstr "" "Anzahl der Restriktionen für Vorhersage und Anpassung müssen übereinstimmen" msgid "x and y must be same length" msgstr "x und y müssen gleich lang sein" msgid "variable names don't match boundary names" msgstr "Variablennamen passen nicht zu Begrenzungsnamen" msgid "x and y not same length" msgstr "x und y sind nicht gleich lang" msgid "bnd must be a list." msgstr "bnd muss eine Liste sein" msgid "lengths of k and bnd are not compatible." msgstr "Längen von k und bnd sind nicht kompatibel" msgid "attempt to select non existent basis function" msgstr "Versuch nicht exisitierende Basisfunktionen zu wählen" msgid "coefficient vector wrong length" msgstr "Koeffizientenvektor hat falsche Länge" msgid "knots must be specified for soap" msgstr "Knoten müssen für soap spezifiziert werden" msgid "soap films are bivariate only" msgstr "soap films nur für bivariaten Fall" msgid "need at least one interior knot" msgstr "mindestens ein Knoten im Inneren nötig" msgid "can't soap smooth without a boundary" msgstr "soap Glätter braucht Grenze" msgid "bnd must be a list of boundary loops" msgstr "bnd muss eine Liste von Grenz-Schleifen sein" msgid "faulty bnd" msgstr "fehlerhaftes bnd" msgid "k and bnd lengths are inconsistent" msgstr "Längen von k und bnd sind inkonsistent" msgid "data outside soap boundary" msgstr "Daten außerhalb der soap Grenze" msgid "no free coefs in sf smooth" msgstr "keine freien Koeffizienten in sf-Glättung" msgid "only deals with 2D case" msgstr "behandelt nur den 2D Fall" msgid "not enough unique values to find k nearest" msgstr "nicht genug eindeutige Werte um die k nächsten zu finden" msgid "cubic spline only deals with 1D data" msgstr "kubische Splines behandeln nur 1D Daten" msgid "object not fully initialized" msgstr "Objekt nicht voll initialisiert" #~ msgid "non-finite coefficients at iteration" #~ msgstr "nicht-endliche Koeffizienten bei Iteration" #~ msgid "sparse=TRUE not supported with fast REML, reset to REML." #~ msgstr "" #~ "sparse=TRUE nicht unterstützt bei schneller REML, rückgesetzt auf REML" #~ msgid "model matrix too dense for any possible benefit from sparse" #~ msgstr "" #~ "Modellmatrix zu dicht besetzt um von Behandlung als dünn besetzt zu " #~ "profitieren" #~ msgid "AR1 parameter rho unused with sparse fitting" #~ msgstr "AR1 Parameter rho bei sparse fitting unbenutzt" #~ msgid "Pearson scale estimate maybe unstable. See ?gam.scale." #~ msgstr "Pearson Skalenschätzung evtl. instabil. Siehe ?gam.scale." #~ msgid "" #~ "`negbin' with unknown theta and outer iteration is deprecated - use `nb'." #~ msgstr "" #~ "'negbin' mit unbekanntem theta und äußeren Iterationen ist veraltet - " #~ "bitte 'nb' nutzen" #~ msgid "nlm.fd not available with negative binomial Theta estimation" #~ msgstr "nlm.fd nicht verfügbar bei der negativ-binomialen Theta-Schätzung" #~ msgid "" #~ "only outer methods `newton' & `bfgs' supports `negbin' family and theta " #~ "selection: reset" #~ msgstr "" #~ "nur die äußere Methoden 'newton' & 'bfgs' unterstützen 'negbin'-Familie " #~ "und theta-Auswahl: Wird zurückgesetzt" #~ msgid "sorry, general families currently ignore offsets" #~ msgstr "sorry, allgemeine Familien ignorieren momentan Offsets" # R/smooth.r #~ msgid "x has no row attribute" #~ msgstr "x hat kein Zeilenattribut" #~ msgid "x has no col attribute" #~ msgstr "x hat kein Spaltenattribut" #~ msgid "" #~ "NA's passed to eig: please email Simon.Wood@R-project.org with details" #~ msgstr "" #~ "NAs an eig übergeben: Bitte E-Mail mit Details an Simon.Wood@R-project." #~ "org senden." #~ msgid "" #~ "NA eigenvalues returned by eigen: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "NA-Eigenwerte von eigen zurückgegeben: Bitte E-Mail mit Details an Simon." #~ "Wood@R-project.org senden." #~ msgid "" #~ "NA's in eigenvectors from eigen: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "NAs in Eigenvektoren von eigen: Bitte E-Mail mit Details an Simon.Wood@R-" #~ "project.org senden." #~ msgid "" #~ "NA singular values returned by svd: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "NA-Singulärwerte von svd zurückgegeben: Bitte E-Mail mit Details an Simon." #~ "Wood@R-project.org senden." #~ msgid "" #~ "NA's in singular vectors from svd: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "NAs in Singulärvektoren von svd: Bitte E-Mail mit Details an Simon.Wood@R-" #~ "project.org senden." #~ msgid "" #~ "NA problem resolved using svd, but please email Simon.Wood@R-project.org " #~ "anyway" #~ msgstr "" #~ "NA-Problem durch Benutzen von svd gelöst, aber bitte trotzdem eine E-Mail " #~ "an Simon.Wood@R-project.org sendne." #~ msgid "Problem with linear algebra routines." #~ msgstr "Problem mit linearen Algebra-Routinen." #~ msgid "gamm() requires package nlme to be installed" #~ msgstr "gamm() benötigt nlme, um installiert zu werden" #~ msgid "gamm() requires package MASS to be installed" #~ msgstr "gamm() benötigt das Paket MASS, um installiert zu werden" #~ msgid "M$S[" #~ msgstr "M$S[" #~ msgid "]" #~ msgstr "]" #~ msgid "Can't mix fixed and estimated penalties in mgcv() - use magic()" #~ msgstr "" #~ "Feste und geschätzte Strafen in mgcv() können nicht gemischt werden - " #~ "benutzen Sie magic()" #~ msgid "meaninglessly low k; reset to 2" #~ msgstr "bedeutungslos niedriges k; wird auf 2 zurückgesetzt" #~ msgid "can't predict outside range of knots with periodic smoother" #~ msgstr "" #~ "es kann nicht außerhalb des Bereichs von Knoten mit periodischem Glätter " #~ "vorausberechnet werden" #~ msgid "supplied sp has wrong length" #~ msgstr "angegebener sp hat falsche Länge" #~ msgid "supplied min.sp has wrong length" #~ msgstr "angegebener min.sp hat falsche Länge" #~ msgid "Unknown additive model fit method." #~ msgstr "Unbekannte zusätzliche Modellanpassungsmethode." #~ msgid "Unknown *generalized* additive model fit method." #~ msgstr "Unbekannte *verallgemeinerte* zusätzliche Modellanpassungsmethode." #~ msgid "pearson should be TRUE or FALSE - set to FALSE." #~ msgstr "pearson sollte TRUE oder FALSE sein - auf FALSE gesetzt." #~ msgid "nb.theta.mult must be >= 2" #~ msgstr "nb.theta.mult muss >= 2 sein" #~ msgid "dispersion argument ignored" #~ msgstr "Argument dispersion ignoriert" #~ msgid "extra arguments discarded" #~ msgstr "zusätzliche Argumente verworfen" #~ msgid ")." #~ msgstr ")." #~ msgid "S[[" #~ msgstr "S[[" #~ msgid "Unkwown flavour of GCV" #~ msgstr "Unbekannte Art von GCV" #~ msgid "GACV only supported with newton optimization, GCV type reset" #~ msgstr "GACV nur mit newton-Optimierung unterstützt, GCV-Typ zurückgesetzt" #~ msgid "" #~ "Pearson based GCV is unsupported for newton or nlm outer methods, reset" #~ msgstr "" #~ "Pearson-basierte GCV ist nicht unterstützt für newton- oder äußere nlm-" #~ "Methoden. Wird zurückgesetzt." #~ msgid "\"perf.magic\" is deprecated: reset to \"perf\"" #~ msgstr "»perf.magic« ist missbilligt: wird auf »perf« zurückgesetzt" mgcv/po/fr.po0000755000177400001440000000541612765741177013017 0ustar murdochusers# Translation of mgcv.pot to French # Copyright (C) 2005 The R Foundation # This file is distributed under the same license as the mgcv R package. # Philippe Grosjean , 2005. # msgid "" msgstr "" "Project-Id-Version: mgcv 1.3-10\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2016-08-19 13:28+0100\n" "PO-Revision-Date: 2005-12-08 00:40+0100\n" "Last-Translator: Philippe Grosjean \n" "Language-Team: French \n" "Language: fr\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=ISO-8859-1\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n > 1);\n" #: magic.c:444 msgid "magic requires smoothing parameter starting values if L supplied" msgstr "" #: magic.c:562 msgid "magic, the gcv/ubre optimizer, failed to converge after 400 iterations." msgstr "magic, l'optimisateur gcv/ubre, n'a pas converg aprs 400 itrations." #: matrix.c:80 msgid "Failed to initialize memory for matrix." msgstr "L'initialisation de la mmoire pour une matrice a chou." #: matrix.c:142 matrix.c:200 msgid "An out of bound write to matrix has occurred!" msgstr "Une crite hors des limites de la matrice s'est produite !" #: matrix.c:148 msgid "INTEGRITY PROBLEM in the extant matrix list." msgstr "PROBLEME D'INTEGRITE dans la liste de la matrice tendue." #: matrix.c:180 msgid "You are trying to check matrix integrity without defining RANGECHECK." msgstr "" "Vous essayez de vrifier l'intgrit de la matrice sans avoir dfini " "RANGECHECK." #: matrix.c:238 msgid "Target matrix too small in mcopy" msgstr "Matrice cible trop petite dans mcopy" #: matrix.c:258 matrix.c:266 matrix.c:279 matrix.c:287 msgid "Incompatible matrices in matmult." msgstr "Matrices incompatibles dans matmult." #: matrix.c:374 msgid "Attempt to invert() non-square matrix" msgstr "Tentative d'inversion d'une matrice non carre" #: matrix.c:396 msgid "Singular Matrix passed to invert()" msgstr "Matrice singulire passe invert()" #: matrix.c:1316 msgid "svd() not converged" msgstr "svd() n'a pas converg" #: matrix.c:1392 #, c-format msgid "svdroot matrix not +ve semi def. %g" msgstr "la matrice svdroot n'est pas +ve semi def. %g" #: matrix.c:1420 msgid "Sort failed" msgstr "Le tri a chou" #: qp.c:59 msgid "ERROR in addconQT." msgstr "ERREUR dans addconQT." #: qp.c:465 msgid "QPCLS - Rank deficiency in model" msgstr "QPCLS - Dficience de rang dans le modle" #: tprs.c:40 msgid "You must have 2m>d for a thin plate spline." msgstr "Vous devez avoir 2m > d pour une 'thin plate spline'" #: tprs.c:375 tprs.c:383 msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" "Un terme a moins de combinaisons de covariables uniques que le degr de " "libert maximum spcifi" mgcv/po/ko.po0000644000177400001440000000457512765741177013023 0ustar murdochusers# Korean translations for mgcv package. # Recommended/mgcv/po/ko.po # Maintainer: Simon Wood # # This file is distributed under the same license as the R mgcv package. # Chel Hee Lee , 2013-2015. # msgid "" msgstr "" "Project-Id-Version: mgcv 1.8-4\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2016-08-19 13:28+0100\n" "PO-Revision-Date: 2015-02-21 16:01-0600\n" "Last-Translator:Chel Hee Lee \n" "Language-Team: Chel Hee Lee \n" "Language: ko\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=1; plural=0;\n" #: magic.c:444 msgid "magic requires smoothing parameter starting values if L supplied" msgstr "" "L에 주어진 값이 없다면 스무딩 파라미터(smoothing parameter)에 대한 초기값" "(starting values)가 필요합니다." #: magic.c:562 msgid "magic, the gcv/ubre optimizer, failed to converge after 400 iterations." msgstr "" #: matrix.c:80 msgid "Failed to initialize memory for matrix." msgstr "행렬생성에 필요한 메모리 초기화에 실패했습니다." #: matrix.c:142 matrix.c:200 msgid "An out of bound write to matrix has occurred!" msgstr "" #: matrix.c:148 msgid "INTEGRITY PROBLEM in the extant matrix list." msgstr "" #: matrix.c:180 msgid "You are trying to check matrix integrity without defining RANGECHECK." msgstr "" #: matrix.c:238 msgid "Target matrix too small in mcopy" msgstr "" #: matrix.c:258 matrix.c:266 matrix.c:279 matrix.c:287 msgid "Incompatible matrices in matmult." msgstr "" #: matrix.c:374 msgid "Attempt to invert() non-square matrix" msgstr "" #: matrix.c:396 msgid "Singular Matrix passed to invert()" msgstr "특이함수(singular matrix)가 invert()에 전달되었습니다." #: matrix.c:1316 msgid "svd() not converged" msgstr "" #: matrix.c:1392 #, c-format msgid "svdroot matrix not +ve semi def. %g" msgstr "" #: matrix.c:1420 msgid "Sort failed" msgstr "정렬에 실패했습니다." #: qp.c:59 msgid "ERROR in addconQT." msgstr "addconQT 에서 에러가 발생했습니다." #: qp.c:465 msgid "QPCLS - Rank deficiency in model" msgstr "" #: tprs.c:40 msgid "You must have 2m>d for a thin plate spline." msgstr "" #: tprs.c:375 tprs.c:383 msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" mgcv/po/R-en@quot.po0000755000177400001440000004304612174413534014206 0ustar murdochusers# All this catalog "translates" are quotation characters. # The msgids must be ASCII and therefore cannot contain real quotation # characters, only substitutes like grave accent (0x60), apostrophe (0x27) # and double quote (0x22). These substitutes look strange; see # http://www.cl.cam.ac.uk/~mgk25/ucs/quotes.html # # This catalog translates grave accent (0x60) and apostrophe (0x27) to # left single quotation mark (U+2018) and right single quotation mark (U+2019). # It also translates pairs of apostrophe (0x27) to # left single quotation mark (U+2018) and right single quotation mark (U+2019) # and pairs of quotation mark (0x22) to # left double quotation mark (U+201C) and right double quotation mark (U+201D). # # When output to an UTF-8 terminal, the quotation characters appear perfectly. # When output to an ISO-8859-1 terminal, the single quotation marks are # transliterated to apostrophes (by iconv in glibc 2.2 or newer) or to # grave/acute accent (by libiconv), and the double quotation marks are # transliterated to 0x22. # When output to an ASCII terminal, the single quotation marks are # transliterated to apostrophes, and the double quotation marks are # transliterated to 0x22. # msgid "" msgstr "" "Project-Id-Version: R 2.3.0\n" "Report-Msgid-Bugs-To: bugs@r-project.org\n" "POT-Creation-Date: 2005-12-09 07:31\n" "PO-Revision-Date: 2005-12-09 07:31\n" "Last-Translator: Automatically generated\n" "Language-Team: none\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n != 1);\n" msgid "illegal `family' argument" msgstr "illegal ‘family’ argument" msgid "Invalid linear predictor values in empty model" msgstr "Invalid linear predictor values in empty model" msgid "Invalid fitted means in empty model" msgstr "Invalid fitted means in empty model" msgid "Length of start should equal" msgstr "Length of start should equal" msgid "and correspond to initial coefs for" msgstr "and correspond to initial coefs for" msgid "Can't find valid starting values: please specify some" msgstr "Can't find valid starting values: please specify some" msgid "NAs in V(mu)" msgstr "NAs in V(mu)" msgid "0s in V(mu)" msgstr "0s in V(mu)" msgid "NAs in d(mu)/d(eta)" msgstr "NAs in d(mu)/d(eta)" msgid "No observations informative at iteration" msgstr "No observations informative at iteration" msgid "Not enough informative observations." msgstr "Not enough informative observations." msgid "Non-finite coefficients at iteration" msgstr "Non-finite coefficients at iteration" msgid "" "no valid set of coefficients has been found:please supply starting values" msgstr "" "no valid set of coefficients has been found:please supply starting values" msgid "Step size truncated due to divergence" msgstr "Step size truncated due to divergence" msgid "inner loop 1; can't correct step size" msgstr "inner loop 1; can't correct step size" msgid "Step size truncated: out of bounds" msgstr "Step size truncated: out of bounds" msgid "inner loop 2; can't correct step size" msgstr "inner loop 2; can't correct step size" msgid "inner loop 3; can't correct step size" msgstr "inner loop 3; can't correct step size" msgid "Algorithm did not converge" msgstr "Algorithm did not converge" msgid "Algorithm stopped at boundary value" msgstr "Algorithm stopped at boundary value" msgid "fitted probabilities numerically 0 or 1 occurred" msgstr "fitted probabilities numerically 0 or 1 occurred" msgid "fitted rates numerically 0 occurred" msgstr "fitted rates numerically 0 occurred" msgid "fam not a family object" msgstr "fam not a family object" msgid "unrecognized (vector?) link" msgstr "unrecognized (vector?) link" msgid "link not recognised" msgstr "link not recognised" msgid "variance function not recognized for quasi" msgstr "variance function not recognized for quasi" msgid "family not recognised" msgstr "family not recognised" msgid "H has wrong dimension" msgstr "H has wrong dimension" msgid "An object of length" msgstr "An object of length" msgid "does not match the required parameter size" msgstr "does not match the required parameter size" msgid "NA's in pdTens factor" msgstr "NA's in pdTens factor" msgid "Cannot extract the matrix from an uninitialized object" msgstr "Cannot extract the matrix from an uninitialized object" msgid "NA's in pdTens matrix" msgstr "NA's in pdTens matrix" msgid "Cannot extract the matrix from an uninitialized pdMat object" msgstr "Cannot extract the matrix from an uninitialized pdMat object" msgid "Cannot extract the matrix with uninitialized dimensions" msgstr "Cannot extract the matrix with uninitialized dimensions" msgid "Must give names when initializing pdIdnot from parameter." msgstr "Must give names when initializing pdIdnot from parameter." msgid "without a formula" msgstr "without a formula" msgid "Cannot extract the dimensions" msgstr "Cannot extract the dimensions" msgid "Cannot extract the inverse from an uninitialized object" msgstr "Cannot extract the inverse from an uninitialized object" msgid "No data supplied to gam.setup" msgstr "No data supplied to gam.setup" msgid "NA's passed to eig: please email Simon.Wood@R-project.org with details" msgstr "NA's passed to eig: please email Simon.Wood@R-project.org with details" msgid "" "NA eigenvalues returned by eigen: please email Simon.Wood@R-project.org with " "details" msgstr "" "NA eigenvalues returned by eigen: please email Simon.Wood@R-project.org with " "details" msgid "" "NA's in eigenvectors from eigen: please email Simon.Wood@R-project.org with " "details" msgstr "" "NA's in eigenvectors from eigen: please email Simon.Wood@R-project.org with " "details" msgid "" "NA singular values returned by svd: please email Simon.Wood@R-project.org " "with details" msgstr "" "NA singular values returned by svd: please email Simon.Wood@R-project.org " "with details" msgid "" "NA's in singular vectors from svd: please email Simon.Wood@R-project.org " "with details" msgstr "" "NA's in singular vectors from svd: please email Simon.Wood@R-project.org " "with details" msgid "" "NA problem resolved using svd, but please email Simon.Wood@R-project.org " "anyway" msgstr "" "NA problem resolved using svd, but please email Simon.Wood@R-project.org " "anyway" msgid "Problem with linear algebra routines." msgstr "Problem with linear algebra routines." msgid "First argument is no sort of formula!" msgstr "First argument is no sort of formula!" msgid "You've got no model...." msgstr "You've got no model...." msgid "gamm can not fix only some margins of tensor product." msgstr "gamm can not fix only some margins of tensor product." msgid "" "Tensor product penalty rank appears to be too low: please email Simon.Wood@R-" "project.org with details." msgstr "" "Tensor product penalty rank appears to be too low: please email Simon.Wood@R-" "project.org with details." msgid "object does not appear to be of class lme" msgstr "object does not appear to be of class lme" msgid "inner groupings not nested in outer!!" msgstr "inner groupings not nested in outer!!" msgid "gamm() requires package nlme to be installed" msgstr "gamm() requires package nlme to be installed" msgid "gamm() requires package MASS to be installed" msgstr "gamm() requires package MASS to be installed" msgid "random argument must be a *named* list." msgstr "random argument must be a *named* list." msgid "all elements of random list must be named" msgstr "all elements of random list must be named" msgid "gamm() can only handle random effects defined as named lists" msgstr "gamm() can only handle random effects defined as named lists" msgid "Not enough (non-NA) data to do anything meaningful" msgstr "Not enough (non-NA) data to do anything meaningful" msgid "family not recognized" msgstr "family not recognized" msgid "" "gamm models must have at least 1 smooth with unknown smoothing parameter or " "at least one other random effect" msgstr "" "gamm models must have at least 1 smooth with unknown smoothing parameter or " "at least one other random effect" msgid "At least three knots required in call to mono.con." msgstr "At least three knots required in call to mono.con." msgid "lower bound >= upper bound in call to mono.con()" msgstr "lower bound >= upper bound in call to mono.con()" msgid "x is null" msgstr "x is null" msgid "x has no row attribute" msgstr "x has no row attribute" msgid "x has no col attribute" msgstr "x has no col attribute" msgid "d can not be negative in call to null.space.dimension()." msgstr "d can not be negative in call to null.space.dimension()." msgid "nrow(M$X) != length(M$y)" msgstr "nrow(M$X) != length(M$y)" msgid "ncol(M$X) != length(M$p)" msgstr "ncol(M$X) != length(M$p)" msgid "length(M$w) != length(M$y)" msgstr "length(M$w) != length(M$y)" msgid "nrow(M$Ain) != length(M$bin)" msgstr "nrow(M$Ain) != length(M$bin)" msgid "nrow(M$Ain) != length(M$p)" msgstr "nrow(M$Ain) != length(M$p)" msgid "initial parameters very close to inequality constraints" msgstr "initial parameters very close to inequality constraints" msgid "ncol(M$C) != length(M$p)" msgstr "ncol(M$C) != length(M$p)" msgid "M$S and M$off have different lengths" msgstr "M$S and M$off have different lengths" msgid "M$sp has different length to M$S and M$off" msgstr "M$sp has different length to M$S and M$off" msgid "M$S[" msgstr "M$S[" msgid "] is too large given M$off[" msgstr "] is too large given M$off[" msgid "]" msgstr "]" msgid "Can't mix fixed and estimated penalties in mgcv() - use magic()" msgstr "Can't mix fixed and estimated penalties in mgcv() - use magic()" msgid "something wrong with argument d." msgstr "something wrong with argument d." msgid "one or more supplied k too small - reset to default" msgstr "one or more supplied k too small - reset to default" msgid "dimension of fx is wrong" msgstr "dimension of fx is wrong" msgid "bs wrong length and ignored." msgstr "bs wrong length and ignored." msgid "m wrong length and ignored." msgstr "m wrong length and ignored." msgid "Repeated variables as arguments of a smooth are not permitted" msgstr "Repeated variables as arguments of a smooth are not permitted" msgid "by=. not allowed" msgstr "by=. not allowed" msgid "s(.) not yet supported." msgstr "s(.) not yet supported." msgid "argument k of s() should be integer and has been rounded" msgstr "argument k of s() should be integer and has been rounded" msgid "meaninglessly low k; reset to 2" msgstr "meaninglessly low k; reset to 2" msgid "cr basis only works with 1-d smooths!" msgstr "cr basis only works with 1-d smooths!" msgid "Can't find by variable" msgstr "Can't find by variable" msgid "components of knots relating to a single smooth must be of same length" msgstr "components of knots relating to a single smooth must be of same length" msgid "more knots than data in a tp term: knots ignored." msgstr "more knots than data in a tp term: knots ignored." msgid "basis dimension, k, increased to minimum possible" msgstr "basis dimension, k, increased to minimum possible" msgid "number of supplied knots != k for a cr smooth" msgstr "number of supplied knots != k for a cr smooth" msgid "more knots than unique data values is not allowed" msgstr "more knots than unique data values is not allowed" msgid "too few knots" msgstr "too few knots" msgid "number of supplied knots != k for a cc smooth" msgstr "number of supplied knots != k for a cc smooth" msgid "can't predict outside range of knots with periodic smoother" msgstr "can't predict outside range of knots with periodic smoother" msgid "no data to predict at" msgstr "no data to predict at" msgid "smooth objects should not have a qrc attribute." msgstr "smooth objects should not have a qrc attribute." msgid "model has repeated 1-d smooths of same variable." msgstr "model has repeated 1-d smooths of same variable." msgid "supplied sp has wrong length" msgstr "supplied sp has wrong length" msgid "supplied min.sp has wrong length" msgstr "supplied min.sp has wrong length" msgid "Supplied smoothing parameter vector is too short - ignored." msgstr "Supplied smoothing parameter vector is too short - ignored." msgid "NA's in supplied smoothing parameter vector - ignoring." msgstr "NA's in supplied smoothing parameter vector - ignoring." msgid "length of min.sp is wrong." msgstr "length of min.sp is wrong." msgid "NA's in min.sp." msgstr "NA's in min.sp." msgid "elements of min.sp must be non negative." msgstr "elements of min.sp must be non negative." msgid "Unknown additive model fit method." msgstr "Unknown additive model fit method." msgid "Unknown *generalized* additive model fit method." msgstr "Unknown *generalized* additive model fit method." msgid "Unknown GAM outer optimizing method." msgstr "Unknown GAM outer optimizing method." msgid "pearson should be TRUE or FALSE - set to FALSE." msgstr "pearson should be TRUE or FALSE - set to FALSE." msgid "" "Negative binomial family not (yet) usable with type 2 iteration methods." msgstr "" "Negative binomial family not (yet) usable with type 2 iteration methods." msgid "" "Must use gam.control(absorb.cons=TRUE), for type 2 iteration\n" " methods." msgstr "" "Must use gam.control(absorb.cons=TRUE), for type 2 iteration\n" " methods." msgid "Model has more coefficients than data" msgstr "Model has more coefficients than data" msgid "IRLS regularizing parameter must be a non-negative number." msgstr "IRLS regularizing parameter must be a non-negative number." msgid "value of epsilon must be > 0" msgstr "value of epsilon must be > 0" msgid "maximum number of iterations must be > 0" msgstr "maximum number of iterations must be > 0" msgid "nb.theta.mult must be >= 2" msgstr "nb.theta.mult must be >= 2" msgid "" "silly value supplied for rank.tol: reset to square root of machine precision." msgstr "" "silly value supplied for rank.tol: reset to square root of machine precision." msgid "Model seems to contain no terms" msgstr "Model seems to contain no terms" msgid "y must be univariate unless binomial" msgstr "y must be univariate unless binomial" msgid "and correspond to initial coefs." msgstr "and correspond to initial coefs." msgid "" "iterative weights or data non-finite in gam.fit - regularization may help. " "See ?gam.control." msgstr "" "iterative weights or data non-finite in gam.fit - regularization may help. " "See ?gam.control." msgid "Step size truncated: out of bounds." msgstr "Step size truncated: out of bounds." msgid "Unknown type, reset to terms." msgstr "Unknown type, reset to terms." msgid "predict.gam can only be used to predict from gam objects" msgstr "predict.gam can only be used to predict from gam objects" msgid "newdata is a model.frame: it should contain all required variables" msgstr "newdata is a model.frame: it should contain all required variables" msgid "not all required variables have been supplied in newdata!" msgstr "not all required variables have been supplied in newdata!" msgid "non-existent terms requested - ignoring" msgstr "non-existent terms requested - ignoring" msgid "residuals argument to plot.gam is wrong length: ignored" msgstr "residuals argument to plot.gam is wrong length: ignored" msgid "No terms to plot - nothing for plot.gam() to do." msgstr "No terms to plot - nothing for plot.gam() to do." msgid "No variance estimates available" msgstr "No variance estimates available" msgid "no automatic plotting for smooths of more than two variables" msgstr "no automatic plotting for smooths of more than two variables" msgid "no automatic plotting for smooths of more than one variable" msgstr "no automatic plotting for smooths of more than one variable" msgid "The following arguments to anova.glm(..) are invalid and dropped:" msgstr "The following arguments to anova.glm(..) are invalid and dropped:" msgid "," msgstr "," msgid "dispersion argument ignored" msgstr "dispersion argument ignored" msgid "test argument ignored" msgstr "test argument ignored" msgid "anova.gam called with non gam object" msgstr "anova.gam called with non gam object" msgid "extra arguments discarded" msgstr "extra arguments discarded" msgid "grid vectors are different lengths" msgstr "grid vectors are different lengths" msgid "data vectors are of different lengths" msgstr "data vectors are of different lengths" msgid "supplied dist negative" msgstr "supplied dist negative" msgid "Model doesn't seem to have enough terms to do anything useful" msgstr "Model doesn't seem to have enough terms to do anything useful" msgid "view variables must be one of" msgstr "view variables must be one of" msgid "View variables must contain more than one value. view = c(" msgstr "View variables must contain more than one value. view = c(" msgid ")." msgstr ")." msgid "type must be \"link\" or \"response\"" msgstr "type must be “link” or “response”" msgid "Something wrong with zlim" msgstr "Something wrong with zlim" msgid "color scheme not recognised" msgstr "color scheme not recognised" msgid "sorry no option for contouring with errors: try plot.gam" msgstr "sorry no option for contouring with errors: try plot.gam" msgid "Supplied matrix not symmetric" msgstr "Supplied matrix not symmetric" msgid "singular values not returned in order" msgstr "singular values not returned in order" msgid "Something wrong - matrix probably not +ve semi definite" msgstr "Something wrong - matrix probably not +ve semi definite" msgid "method not recognised." msgstr "method not recognised." msgid "S[[" msgstr "S[[" msgid "]] matrix is not +ve definite." msgstr "]] matrix is not +ve definite." msgid "dimensions of supplied w wrong." msgstr "dimensions of supplied w wrong." msgid "w different length from y!" msgstr "w different length from y!" msgid "X lost dimensions in magic!!" msgstr "X lost dimensions in magic!!" mgcv/po/en@quot.po0000755000177400001440000001417012174413534014003 0ustar murdochusers# English translations for R package. # Copyright (C) 2005 The R Foundation # This file is distributed under the same license as the R package. # Automatically generated, 2005. # # All this catalog "translates" are quotation characters. # The msgids must be ASCII and therefore cannot contain real quotation # characters, only substitutes like grave accent (0x60), apostrophe (0x27) # and double quote (0x22). These substitutes look strange; see # http://www.cl.cam.ac.uk/~mgk25/ucs/quotes.html # # This catalog translates grave accent (0x60) and apostrophe (0x27) to # left single quotation mark (U+2018) and right single quotation mark (U+2019). # It also translates pairs of apostrophe (0x27) to # left single quotation mark (U+2018) and right single quotation mark (U+2019) # and pairs of quotation mark (0x22) to # left double quotation mark (U+201C) and right double quotation mark (U+201D). # # When output to an UTF-8 terminal, the quotation characters appear perfectly. # When output to an ISO-8859-1 terminal, the single quotation marks are # transliterated to apostrophes (by iconv in glibc 2.2 or newer) or to # grave/acute accent (by libiconv), and the double quotation marks are # transliterated to 0x22. # When output to an ASCII terminal, the single quotation marks are # transliterated to apostrophes, and the double quotation marks are # transliterated to 0x22. # msgid "" msgstr "" "Project-Id-Version: R 2.3.0\n" "Report-Msgid-Bugs-To: bugs@R-project.org\n" "POT-Creation-Date: 2005-12-09 07:31+0000\n" "PO-Revision-Date: 2005-12-09 07:31+0000\n" "Last-Translator: Automatically generated\n" "Language-Team: none\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n != 1);\n" #: gcv.c:290 #, c-format msgid "" "Overall smoothing parameter estimate on upper boundary.\n" "Boundary GCV score change: %g. Largest change: %g" msgstr "" "Overall smoothing parameter estimate on upper boundary.\n" "Boundary GCV score change: %g. Largest change: %g" #: gcv.c:875 msgid "resetting -ve inf" msgstr "resetting -ve inf" #: gcv.c:877 msgid "resetting +ve inf" msgstr "resetting +ve inf" #: gcv.c:1014 msgid "" "Multiple GCV didn't improve autoinitialized relative smoothing parameters" msgstr "" "Multiple GCV didn't improve autoinitialized relative smoothing parameters" #: magic.c:809 msgid "magic, the gcv/ubre optimizer, failed to converge after 400 iterations." msgstr "" "magic, the gcv/ubre optimizer, failed to converge after 400 iterations." #: matrix.c:85 msgid "Failed to initialize memory for matrix." msgstr "Failed to initialize memory for matrix." #: matrix.c:147 matrix.c:210 msgid "An out of bound write to matrix has occurred!" msgstr "An out of bound write to matrix has occurred!" #: matrix.c:153 msgid "INTEGRITY PROBLEM in the extant matrix list." msgstr "INTEGRITY PROBLEM in the extant matrix list." #: matrix.c:186 msgid "You are trying to check matrix integrity without defining RANGECHECK." msgstr "You are trying to check matrix integrity without defining RANGECHECK." #: matrix.c:255 #, c-format msgid "" "\n" "%s not found, nothing read ! " msgstr "" "\n" "%s not found, nothing read ! " #: matrix.c:325 msgid "Target matrix too small in mcopy" msgstr "Target matrix too small in mcopy" #: matrix.c:345 matrix.c:353 matrix.c:366 matrix.c:374 msgid "Incompatible matrices in matmult." msgstr "Incompatible matrices in matmult." #: matrix.c:480 msgid "Attempt to invert() non-square matrix" msgstr "Attempt to invert() non-square matrix" #: matrix.c:502 msgid "Singular Matrix passed to invert()" msgstr "Singular Matrix passed to invert()" #: matrix.c:655 msgid "Not a +ve def. matrix in choleski()." msgstr "Not a +ve def. matrix in choleski()." #: matrix.c:873 msgid "Error in Covariance(a,b) - a,b not same length." msgstr "Error in Covariance(a,b) - a,b not same length." #: matrix.c:1812 msgid "svd() not converged" msgstr "svd() not converged" #: matrix.c:1968 #, c-format msgid "%s not found by routine gettextmatrix().\n" msgstr "%s not found by routine gettextmatrix().\n" #: matrix.c:2190 #, c-format msgid "svdroot matrix not +ve semi def. %g" msgstr "svdroot matrix not +ve semi def. %g" #: matrix.c:2414 msgid "Sort failed" msgstr "Sort failed" #: matrix.c:2542 msgid "eigen_tri() failed to converge" msgstr "eigen_tri() failed to converge" #: matrix.c:2698 #, c-format msgid "eigenvv_tri() Eigen vector %d of %d failure. Error = %g > %g" msgstr "eigenvv_tri() Eigen vector %d of %d failure. Error = %g > %g" #: matrix.c:2832 msgid "Lanczos failed" msgstr "Lanczos failed" #: mgcv.c:868 msgid "" "Numerical difficulties obtaining tr(A) - apparently resolved. Apply some " "caution to results." msgstr "" "Numerical difficulties obtaining tr(A) - apparently resolved. Apply some " "caution to results." #: mgcv.c:872 msgid "tr(A) utter garbage and situation un-resolvable." msgstr "tr(A) utter garbage and situation un-resolvable." #: mgcv.c:873 msgid "" "Numerical difficulties calculating tr(A). Not completely resolved. Use " "results with care!" msgstr "" "Numerical difficulties calculating tr(A). Not completely resolved. Use " "results with care!" #: mgcv.c:958 msgid "Termwise estimate degrees of freedom are unreliable" msgstr "Termwise estimate degrees of freedom are unreliable" #: qp.c:59 msgid "ERROR in addconQT." msgstr "ERROR in addconQT." #: qp.c:465 msgid "QPCLS - Rank deficiency in model" msgstr "QPCLS - Rank deficiency in model" #: tprs.c:45 msgid "You must have 2m>d for a thin plate spline." msgstr "You must have 2m>d for a thin plate spline." #: tprs.c:99 msgid "You must have 2m > d" msgstr "You must have 2m > d" #: tprs.c:357 tprs.c:367 msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" #: tprs.c:359 msgid "" "Too many knots for t.p.r.s term: see `gam.control' to increase limit, or use " "a different basis, or see large data set help for `gam'." msgstr "" "Too many knots for t.p.r.s term: see ‘gam.control’ to increase limit, or use " "a different basis, or see large data set help for ‘gam’." mgcv/po/R-pl.po0000644000177400001440000026250213046052674013206 0ustar murdochusersmsgid "" msgstr "" "Project-Id-Version: mgcv 1.7-28\n" "Report-Msgid-Bugs-To: bugs@r-project.org\n" "POT-Creation-Date: 2017-02-06 09:59\n" "PO-Revision-Date: 2014-03-25 17:39+0100\n" "Last-Translator: Łukasz Daniel \n" "Language-Team: Łukasz Daniel \n" "Language: pl_PL\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=3; plural=(n==1 ? 0 : n%10>=2 && n%10<=4 && (n%100<10 " "|| n%100>=20) ? 1 : 2);\n" "X-Poedit-SourceCharset: iso-8859-1\n" "X-Generator: Poedit 1.5.4\n" msgid "bam can not discretize with this nesting structure" msgstr "" msgid "discretization can not handle smooth ids" msgstr "" # mgcv/R/bam.r: 161 # stop("'family' argument seems not to be a valid family object") # mgcv/R/bam.r: 480 # stop("'family' argument seems not to be a valid family object") msgid "'family' argument seems not to be a valid family object" msgstr "" "argument 'family' wydaje się nie być poprawnym obiektem klasy \"family\"" # mgcv/R/bam.r: 184 # stop("cannot find valid starting values: please specify some") # mgcv/R/bam.r: 503 # stop("cannot find valid starting values: please specify some") msgid "cannot find valid starting values: please specify some" msgstr "" "Nie mnżna znaleźć poprawnych wartości startowych: proszę określić kilka" # mgcv/R/bam.r: 336 # gettextf("Deviance = %s Iterations - %d", dev, iter, domain = "R-mgcv") # mgcv/R/bam.r: 544 # gettextf("Deviance = %s Iterations - %d", dev, iter, domain = "R-mgcv") # mgcv/R/gam.fit3.r: 347 # gettextf("Deviance = %s Iterations - %d", dev, iter, domain = "R-mgcv") # mgcv/R/mgcv.r: 1951 # gettextf("Deviance = %s Iterations - %d", dev, iter, domain = "R-mgcv") msgid "Deviance = %s Iterations - %d" msgstr "Odchylenie = %s Iteracje - %d" # mgcv/R/bam.r: 338 # stop("Non-finite deviance") # mgcv/R/bam.r: 546 # stop("Non-finite deviance") msgid "Non-finite deviance" msgstr "Nieskończone odchylenie" # mgcv/R/bam.r: 425 # warning(gettextf("non-finite coefficients at iteration %d", iter)) # mgcv/R/bam.r: 600 # warning(gettextf("non-finite coefficients at iteration %d", iter)) #, fuzzy msgid "non-finite coefficients at iteration %d" msgstr "nieskończone współczynniki w iteracji" # mgcv/R/gam.fit3.r: 663 # warning("Algorithm did not converge") # mgcv/R/mgcv.r: 2004 # warning("Algorithm did not converge") msgid "algorithm did not converge" msgstr "Algorytm nie uzbieżnił się" # mgcv/R/bam.r: 446 # warning("fitted probabilities numerically 0 or 1 occurred") # mgcv/R/bam.r: 611 # warning("fitted probabilities numerically 0 or 1 occurred") # mgcv/R/gam.fit3.r: 669 # warning("fitted probabilities numerically 0 or 1 occurred") # mgcv/R/mgcv.r: 2011 # warning("fitted probabilities numerically 0 or 1 occurred") msgid "fitted probabilities numerically 0 or 1 occurred" msgstr "" "dopasowane prawdopodobieństwa okazały się być numerycznie równe 0 lub 1" # mgcv/R/bam.r: 450 # warning("fitted rates numerically 0 occurred") # mgcv/R/bam.r: 615 # warning("fitted rates numerically 0 occurred") # mgcv/R/gam.fit3.r: 673 # warning("fitted rates numerically 0 occurred") # mgcv/R/mgcv.r: 2015 # warning("fitted rates numerically 0 occurred") msgid "fitted rates numerically 0 occurred" msgstr "dopasowane wskaźniki numerycznie okazały się być równe 0" msgid "Too many cluster nodes to use all efficiently" msgstr "" # mgcv/R/mgcv.r: 2100 # warning("Unknown type, reset to terms.") #, fuzzy msgid "iterms reset to terms" msgstr "Nieznany typ, resetowanie do 'terms'" msgid "exclude ignored by discrete prediction at present" msgstr "" # mgcv/R/gamm.r: 1433 # stop("family not recognized") # mgcv/R/bam.r: 1075 # stop("family not recognized") # mgcv/R/mgcv.r: 1564 # stop("family not recognized") msgid "family not recognized" msgstr "'family' nie został rozpoznany" msgid "extended families not supported by bam" msgstr "" # mgcv/R/bam.r: 1079 # stop("unsupported smoothness selection method") msgid "un-supported smoothness selection method" msgstr "niewspierana metoda wyboru wygładzania" msgid "discretization only available with fREML" msgstr "" msgid "discrete method does not use parallel cluster - use nthreads instead" msgstr "" # mgcv/R/bam.r: 1082 # warning("min.sp not supported with fast REML computation, and ignored.") msgid "min.sp not supported with fast REML computation, and ignored." msgstr "" "'min.sp' nie jest wspierane dla szybkich obliczeń REML, parametr został " "zignorowany." # mgcv/R/gamm.r: 1414 # stop("Not enough (non-NA) data to do anything meaningful") # mgcv/R/bam.r: 1106 # stop("Not enough (non-NA) data to do anything meaningful") # mgcv/R/mgcv.r: 1540 # stop("Not enough (non-NA) data to do anything meaningful") msgid "Not enough (non-NA) data to do anything meaningful" msgstr "" "Brak wystarczającej (nie NA) liczby danych, aby wykonać cokolwiek sensownego" # mgcv/R/bam.r: 1109 # stop("'AR.start' argumentmust be logical") #, fuzzy msgid "AR.start must be logical" msgstr "argument 'AR.start' musi być wartością logiczną" msgid "chunk.size < number of coefficients. Reset to %d" msgstr "" # mgcv/R/smooth.r: 2842 # stop("unimplemented sparse constraint type requested") #, fuzzy msgid "unknown tensor constraint type" msgstr "zażądano niezaimplementowanego typu rzadkiego więzu" # mgcv/R/bam.r: 1153 # stop("Model has more coefficients than data") # mgcv/R/mgcv.r: 1579 # stop("Model has more coefficients than data") msgid "Model has more coefficients than data" msgstr "Model posiada więcej współczynników niż danych" # mgcv/R/bam.r: 1187 # warning("AR1 parameter rho unused with generalized model") msgid "AR1 parameter rho unused with generalized model" msgstr "parametr rho AR1 jest nieużywany z uogólnionym modelem" # mgcv/R/bam.r: 1191 # warning("samfrac too small - ignored") msgid "samfrac too small - ignored" msgstr "'samfrac' jest zbyt małe - zignorowano" # mgcv/R/bam.r: 1286 # stop("Model can not be updated") msgid "Model can not be updated" msgstr "Model nie może zostać zaktualizowany" # mgcv/R/gam.fit3.r: 2093 # stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"", linktemp)) #, fuzzy msgid "link not available for coxph family; available link is \"identity\"" msgstr "" ": połączenie nie jest dostępne dla rodziny rozkładu Pascala; dostępne " "połączenia to \"identity\", \"log\" oraz \"sqrt\"" msgid "NA times supplied for cox.ph prediction" msgstr "" msgid "cox.ph does not yet handle offsets" msgstr "" # mgcv/R/gam.fit3.r: 2093 # stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"", linktemp)) #, fuzzy msgid "" "link not available for ordered categorical family; available links are " "\"identity\"" msgstr "" ": połączenie nie jest dostępne dla rodziny rozkładu Pascala; dostępne " "połączenia to \"identity\", \"log\" oraz \"sqrt\"" msgid "Must supply theta or R to ocat" msgstr "" msgid "Response should be integer class labels" msgstr "" # mgcv/R/smooth.r: 177 # stop("'x' out of range") #, fuzzy msgid "values out of range" msgstr "argument 'x' jest poza zakresem" # mgcv/R/gam.fit3.r: 2093 # stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"", linktemp)) msgid "" "link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" ": połączenie nie jest dostępne dla rodziny rozkładu Pascala; dostępne " "połączenia to \"identity\", \"log\" oraz \"sqrt\"" # mgcv/R/gam.fit3.r: 2126 # stop("negative values not allowed for the negative binomial family") msgid "negative values not allowed for the negative binomial family" msgstr "ujemne wartości nie są dozwolone dla rozkładu z rodziny Pascala" # mgcv/R/gam.fit3.r: 2300 # stop(gettextf("link \"%s\" is not available for Tweedie family.", linktemp), domain = "R-mgcv") #, fuzzy msgid "link \"%s\" not available for Tweedie family." msgstr "" "połączenie \"%s\" nie jest dostępne dla rozkładów z rodziny rozkładów " "poissona" # mgcv/R/gam.fit3.r: 2360 # stop("p must be in (1,2)") #, fuzzy msgid "Tweedie p must be in interval (a,b)" msgstr "argument 'p' musi być w przedziale (1,2)" # mgcv/R/gam.fit3.r: 2093 # stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"", linktemp)) #, fuzzy msgid "" "link not available for beta regression; available links are \"logit\", " "\"probit\", \"cloglog\" and \"cauchit\"" msgstr "" ": połączenie nie jest dostępne dla rodziny rozkładu Pascala; dostępne " "połączenia to \"identity\", \"log\" oraz \"sqrt\"" msgid "saturated likelihood may be inaccurate" msgstr "" # mgcv/R/gam.fit3.r: 2093 # stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"", linktemp)) #, fuzzy msgid "" "link not available for scaled t distribution; available links are \"identity" "\", \"log\", and \"inverse\"" msgstr "" ": połączenie nie jest dostępne dla rodziny rozkładu Pascala; dostępne " "połączenia to \"identity\", \"log\" oraz \"sqrt\"" # mgcv/R/mgcv.r: 1678 # stop("value of epsilon must be > 0") #, fuzzy msgid "scaled t df must be >2" msgstr "wartość 'epsilon' musi być > 0" # mgcv/R/gam.fit3.r: 2126 # stop("negative values not allowed for the negative binomial family") #, fuzzy msgid "NA values not allowed for the scaled t family" msgstr "ujemne wartości nie są dozwolone dla rozkładu z rodziny Pascala" # mgcv/R/gam.fit3.r: 2093 # stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"", linktemp)) #, fuzzy msgid "" "link not available for zero inflated; available link for `lambda' is only " "\"loga\"" msgstr "" ": połączenie nie jest dostępne dla rodziny rozkładu Pascala; dostępne " "połączenia to \"identity\", \"log\" oraz \"sqrt\"" # mgcv/R/gam.fit3.r: 2126 # stop("negative values not allowed for the negative binomial family") #, fuzzy msgid "negative values not allowed for the zero inflated Poisson family" msgstr "ujemne wartości nie są dozwolone dla rozkładu z rodziny Pascala" msgid "Non-integer response variables are not allowed with ziP" msgstr "" msgid "Using ziP for binary data makes no sense" msgstr "" msgid "Possible divergence detected in fast.REML.fit" msgstr "" # mgcv/R/fast-REML.r: 640 # warning("fast REML optimizer reached iteration limit") msgid "fast REML optimizer reached iteration limit" msgstr "szybki optymalizator REML osiągnął granicę iteracji" msgid "Huber scale estiamte not converged" msgstr "" # mgcv/R/gam.fit3.r: 125 # stop("unsupported order of differentiation requested of 'gam.fit3()'") msgid "unsupported order of differentiation requested of gam.fit3" msgstr "niewspierany porządek różniczkowania zażądany od 'gam.fit3()'" # mgcv/R/gam.fit3.r: 202 # stop("invalid 'family' argument") msgid "illegal `family' argument" msgstr "niepoprawny argument 'family'" # mgcv/R/gam.fit3.r: 231 # stop("Invalid linear predictor values in empty model") msgid "Invalid linear predictor values in empty model" msgstr "Niepoprawne wartości liniowej zmiennej niezależnej w pustym modelu" # mgcv/R/gam.fit3.r: 234 # stop("Invalid fitted means in empty model") msgid "Invalid fitted means in empty model" msgstr "Niepoprawnie dopasowane średnie w pustym modelu" # mgcv/R/gam.fit3.r: 256 # stop(gettextf("Length of start should equal %d and correspond to initial coefs for %s", nvars, deparse(xnames))) #, fuzzy msgid "Length of start should equal %d and correspond to initial coefs for %s" msgstr "oraz odpowiadać początkowym współczynnikom dla" # mgcv/R/gam.fit3.r: 267 # stop("Can't find valid starting values: please specify some") # mgcv/R/mgcv.r: 1875 # stop("Can't find valid starting values: please specify some") msgid "Can't find valid starting values: please specify some" msgstr "" "Nie można znaleźć poprawnych wartości startowych: proszę określić kilka" # mgcv/R/gam.fit3.r: 286 # stop("0s in V(mu)") # mgcv/R/gam.fit3.r: 458 # stop("0s in V(mu)") # mgcv/R/mgcv.r: 1892 # stop("0s in V(mu)") msgid "NAs in V(mu)" msgstr "wartości NA w 'V(mu)'" # mgcv/R/gam.fit3.r: 286 # stop("0s in V(mu)") # mgcv/R/gam.fit3.r: 458 # stop("0s in V(mu)") # mgcv/R/mgcv.r: 1892 # stop("0s in V(mu)") msgid "0s in V(mu)" msgstr "zera w 'V(mu)'" # mgcv/R/gam.fit3.r: 289 # stop("NA values in d(mu)/d(eta)") # mgcv/R/gam.fit3.r: 461 # stop("NA values in d(mu)/d(eta)") # mgcv/R/mgcv.r: 1895 # stop("NA values in d(mu)/d(eta)") msgid "NAs in d(mu)/d(eta)" msgstr "wartości NA w 'd(mu)/d(eta)'" # mgcv/R/gam.fit3.r: 295 # warning(gettextf("No observations informative at iteration %d", iter)) # mgcv/R/mgcv.r: 1899 # warning(gettextf("No observations informative at iteration %d", iter)) #, fuzzy msgid "No observations informative at iteration %d" msgstr "Brak informacyjnych obserwacji w iteracji" # mgcv/R/gam.fit3.r: 314 # stop("Not enough informative observations.") msgid "Not enough informative observations." msgstr "Zbyt mało informacyjnych obserwacji" # mgcv/R/gam.fit3.r: 339 # warning(gettextf("Non-finite coefficients at iteration %d", iter)) # mgcv/R/mgcv.r: 1940 # warning(gettextf("Non-finite coefficients at iteration %d", iter)) #, fuzzy msgid "Non-finite coefficients at iteration %d" msgstr "Nieskończone współczynniki w iteracji" # mgcv/R/gam.fit3.r: 353 # stop("no valid set of coefficients has been found:please supply starting values", call. = FALSE) # mgcv/R/mgcv.r: 1955 # stop("no valid set of coefficients has been found:please supply starting values", call. = FALSE) msgid "" "no valid set of coefficients has been found:please supply starting values" msgstr "" "nie znaleziono poprawnego zestawu współczynników: proszę dostarczyć wartości " "startowe" # mgcv/R/gam.fit3.r: 358 # warning("Step size truncated due to divergence", call. = FALSE) # mgcv/R/mgcv.r: 1956 # warning("Step size truncated due to divergence", call. = FALSE) msgid "Step size truncated due to divergence" msgstr "Rozmiar kroku przycięty z uwagi na rozbieżność" # mgcv/R/gam.fit3.r: 362 # stop("inner loop 1; can't correct step size") # mgcv/R/mgcv.r: 1960 # stop("inner loop 1; can't correct step size") msgid "inner loop 1; can't correct step size" msgstr "wewnętrzna pętla 1; nie można poprawić rozmiaru kroku" # mgcv/R/gam.fit3.r: 374 # warning("Step size truncated: out of bounds", call. = FALSE) msgid "Step size truncated: out of bounds" msgstr "Rozmiar kroku przycięty: poza granicami" # mgcv/R/gam.fit3.r: 378 # stop("inner loop 2; can't correct step size") # mgcv/R/mgcv.r: 1977 # stop("inner loop 2; can't correct step size") msgid "inner loop 2; can't correct step size" msgstr "wewnętrzna pętla 2; nie można poprawić rozmiaru kroku" # mgcv/R/gam.fit3.r: 393 # gettextf("penalized deviance = %s", pdev, domain = "R-mgcv") msgid "penalized deviance = %s" msgstr "karne odchylenie = %s" # mgcv/R/gam.fit3.r: 362 # stop("inner loop 1; can't correct step size") # mgcv/R/mgcv.r: 1960 # stop("inner loop 1; can't correct step size") msgid "inner loop 3; can't correct step size" msgstr "wewnętrzna pętla 3; nie można poprawić rozmiaru kroku" # mgcv/R/gam.fit3.r: 415 # gettextf("Step halved: new penalized deviance = %s", pdev, domain = "R-mgcv") #, fuzzy msgid "Step halved: new penalized deviance = %g" msgstr "Krok został skrócony o połowę: nowe karne odchylenie = %s" # mgcv/R/gam.fit3.r: 569 # stop("Non-finite derivatives. Try decreasing fit tolerance! See 'epsilon' in 'gam.contol'") # mgcv/R/gam.fit3.r: 630 # stop("Non-finite derivatives. Try decreasing fit tolerance! See 'epsilon' in 'gam.contol'") # mgcv/R/gam.fit3.r: 645 # stop("Non-finite derivatives. Try decreasing fit tolerance! See 'epsilon' in 'gam.contol'") msgid "" "Non finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" "Nieskończone pochodne. Spróbuj zmniejszyć tolerancję dopasowania! Zobacz " "'epsilon' w 'gam.contol'" # mgcv/R/gam.fit3.r: 569 # stop("Non-finite derivatives. Try decreasing fit tolerance! See 'epsilon' in 'gam.contol'") # mgcv/R/gam.fit3.r: 630 # stop("Non-finite derivatives. Try decreasing fit tolerance! See 'epsilon' in 'gam.contol'") # mgcv/R/gam.fit3.r: 645 # stop("Non-finite derivatives. Try decreasing fit tolerance! See 'epsilon' in 'gam.contol'") msgid "" "Non-finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" "Nieskończone pochodne. Spróbuj zmniejszyć tolerancję dopasowania! Zobacz " "'epsilon' w 'gam.contol'" # mgcv/R/gam.fit3.r: 663 # warning("Algorithm did not converge") # mgcv/R/mgcv.r: 2004 # warning("Algorithm did not converge") msgid "Algorithm did not converge" msgstr "algorytm nie uzbieżnił się" # mgcv/R/gam.fit3.r: 665 # warning("Algorithm stopped at boundary value") # mgcv/R/mgcv.r: 2007 # warning("Algorithm stopped at boundary value") msgid "Algorithm stopped at boundary value" msgstr "Algorytm zatrzymał się na wartości granicznej" # mgcv/R/gam.fit3.r: 785 # stop("deriv should be 1 or 2") msgid "deriv should be 1 or 2" msgstr "'deriv' powinien wynosić 1 lub 2" # mgcv/R/gam.fit3.r: 956 # stop("'L' argument must be a matrix.") # mgcv/R/gam.fit3.r: 998 # stop("'L' argument must be a matrix.") # mgcv/R/gam.fit3.r: 1275 # stop("'L' argument must be a matrix.") # mgcv/R/gam.fit3.r: 1518 # stop("'L' argument must be a matrix.") # mgcv/R/mgcv.r: 3524 # stop("'L' argument must be a matrix.") msgid "L must be a matrix." msgstr "argument 'L' musi być macierzą" # mgcv/R/gam.fit3.r: 957 # stop("'L' argument must have at least as many rows as columns.") # mgcv/R/gam.fit3.r: 999 # stop("'L' argument must have at least as many rows as columns.") # mgcv/R/gam.fit3.r: 1276 # stop("'L' argument must have at least as many rows as columns.") # mgcv/R/gam.fit3.r: 1519 # stop("'L' argument must have at least as many rows as columns.") # mgcv/R/mgcv.r: 3525 # stop("'L' argument must have at least as many rows as columns.") msgid "L must have at least as many rows as columns." msgstr "argument 'L' musi mieć co najmniej tyle wierszy co kolumn" # mgcv/R/gam.fit3.r: 958 # stop("'L' argument has inconsistent dimensions.") # mgcv/R/gam.fit3.r: 1000 # stop("'L' argument has inconsistent dimensions.") # mgcv/R/gam.fit3.r: 1277 # stop("'L' argument has inconsistent dimensions.") # mgcv/R/gam.fit3.r: 1520 # stop("'L' argument has inconsistent dimensions.") # mgcv/R/mgcv.r: 3526 # stop("'L' argument has inconsistent dimensions.") msgid "L has inconsistent dimensions." msgstr "argument 'L' ma niespójne wymiary" msgid "Fitting terminated with step failure - check results carefully" msgstr "" msgid "Iteration limit reached without full convergence - check carefully" msgstr "" msgid "link not implemented for extended families" msgstr "" msgid "fam not a family object" msgstr "argument 'fam' nie jest obiektem klasy \"family\"" # mgcv/R/gam.fit3.r: 1831 # stop("unrecognized (vector?) link") msgid "unrecognized (vector?) link" msgstr "nierozpoznane (wektorowe?) połączenie" # mgcv/R/gam.fit3.r: 1923 # stop("link not recognised") msgid "link not recognised" msgstr "połączenie nie zostało rozpoznane" # mgcv/R/gam.fit3.r: 1963 # stop("variance function not recognized for quasi") msgid "variance function not recognized for quasi" msgstr "funkcja wariancji nie została rozpoznana dla kwazi" # mgcv/R/gam.fit3.r: 1986 # stop("family not recognised") # mgcv/R/gam.fit3.r: 2055 # stop("family not recognised") msgid "family not recognised" msgstr "rodzina nie została rozpoznana" # mgcv/man/negbin.Rd: 27 # stop("'theta' must be specified") # mgcv/R/gam.fit3.r: 2072 # stop("'theta' must be specified") msgid "'theta' must be specified" msgstr "argument 'theta' musi być określony" # mgcv/R/gam.fit3.r: 2093 # stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"", linktemp)) #, fuzzy msgid "" "%s link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" ": połączenie nie jest dostępne dla rodziny rozkładu Pascala; dostępne " "połączenia to \"identity\", \"log\" oraz \"sqrt\"" # mgcv/R/gam.fit3.r: 2156 # stop("'H' argument has wrong dimension") # mgcv/R/gam.fit3.r: 2178 # stop("'H' argument has wrong dimension") msgid "H has wrong dimension" msgstr "argument 'H' ma niepoprawny wymiar" # mgcv/R/gam.fit3.r: 2218 # stop("only scalar 'p' and 'phi' allowed.") msgid "only scalar `rho' and `theta' allowed." msgstr "tylko skalarne 'p' oraz 'phi' są dozwolone" msgid "1 0") #, fuzzy msgid "number of categories must be at least 2" msgstr "maksymalna liczba iteracji musi być > 0" # mgcv/R/mgcv.r: 822 # stop("incorrect number of smoothing parameters supplied for a smooth term") # mgcv/R/mgcv.r: 830 # stop("incorrect number of smoothing parameters supplied for a smooth term") #, fuzzy msgid "number of linear predictors doesn't match" msgstr "" "niepoprawna liczba parametrów wygładzających dostarczona do członu 'smooth'" msgid "response not in 0 to number of predictors + 1" msgstr "" msgid "ziplss requires 2 links specified as character strings" msgstr "" # mgcv/R/gam.fit3.r: 2300 # stop(gettextf("link \"%s\" is not available for Tweedie family.", linktemp), domain = "R-mgcv") #, fuzzy msgid "link not available for" msgstr "" "połączenie \"%s\" nie jest dostępne dla rozkładów z rodziny rozkładów " "poissona" msgid "parameter of ziplss" msgstr "" msgid "Non-integer response variables are not allowed with ziplss" msgstr "" msgid "Using ziplss for binary data makes no sense" msgstr "" msgid "gevlss requires 3 links specified as character strings" msgstr "" # mgcv/R/gamm.r: 115 # stop(gettextf("An object of length %d does not match the required parameter size", aux)) # mgcv/R/gamm.r: 243 # stop(gettextf("An object of length %d does not match the required parameter size", length(val))) #, fuzzy msgid "An object of length %d does not match the required parameter size" msgstr "nie zgadza się z wymaganym rozmiarem parametru" msgid "NA's in pdTens factor" msgstr "wartości NA w czynniku klasy \"pdTens\"" # mgcv/R/gamm.r: 145 # stop("Cannot extract the matrix from an uninitialized object") msgid "Cannot extract the matrix from an uninitialized object" msgstr "Nie można wyodrębnić macierzy z niezainicjalizowanego obiektu" msgid "NA's in pdTens matrix" msgstr "wartości NA w macierzy klasy \"pdTens\"" # mgcv/R/gamm.r: 206 # stop("Cannot extract the matrix from an uninitialized pdMat object") # mgcv/R/gamm.r: 265 # stop("Cannot extract the matrix from an uninitialized pdMat object") msgid "Cannot extract the matrix from an uninitialized pdMat object" msgstr "" "Nie można wyodrębnić macierzy z niezainicjalizowanego obiektu klasy \"pdMAt\"" # mgcv/R/gamm.r: 209 # stop(paste("Cannot extract the matrix with uninitialized dimensions")) # mgcv/R/gamm.r: 268 # stop("Cannot extract the matrix with uninitialized dimensions") msgid "Cannot extract the matrix with uninitialized dimensions" msgstr "Nie można wyodrębnić macierzy z niezainicjalizowanymi wymiarami" msgid "An object of length" msgstr "Obiekt o długości" # mgcv/R/gamm.r: 115 # stop(gettextf("An object of length %d does not match the required parameter size", aux)) # mgcv/R/gamm.r: 243 # stop(gettextf("An object of length %d does not match the required parameter size", length(val))) msgid "does not match the required parameter size" msgstr "nie zgadza się z wymaganym rozmiarem parametru" # mgcv/R/gamm.r: 246 # stop("Must give names when initializing pdIdnot from parameter without a formula") msgid "Must give names when initializing pdIdnot from parameter." msgstr "" "Nazwy są wymagane podczas inicjalizowania obiektu klasy \"pdIdnot\" z " "parametru" msgid "without a formula" msgstr "bez formuły" # mgcv/R/gamm.r: 302 # stop("Cannot extract the dimensions") msgid "Cannot extract the dimensions" msgstr "Nie można wyodrębnić wymiarów" # mgcv/R/gamm.r: 317 # stop("Cannot extract the inverse from an uninitialized object") msgid "Cannot extract the inverse from an uninitialized object" msgstr "Nie można wyodrębnić odwrotności z niezainicjalizowanego obiektu" # mgcv/R/gamm.r: 663 # stop("Can not convert this smooth class to a random effect") msgid "Can not convert this smooth class to a random effect" msgstr "Nie można przekonwertować tej gładkiej klasy na efekt losowy" # mgcv/R/gamm.r: 724 # stop("te smooths not useable with gamm4: use t2 instead") msgid "te smooths not useable with gamm4: use t2 instead" msgstr "wygładzania 'te' nie są stosowalne z 'gamm4': zamiast tego użyj t2" # mgcv/R/gamm.r: 397 # warning("gamm can not fix only some margins of tensor product.") # mgcv/R/gamm.r: 727 # warning("gamm can not fix only some margins of tensor product.") msgid "gamm can not fix only some margins of tensor product." msgstr "" "funkcja 'gamm()' nie może ustalić tylko niektórych granic produktu " "tensorowego." # mgcv/R/gamm.r: 437 # stop("Tensor product penalty rank appears to be too low: please email Simon.Wood@R-project.org with details.") # mgcv/R/gamm.r: 748 # stop("Tensor product penalty rank appears to be too low: please email Simon.Wood@R-project.org with details.") msgid "" "Tensor product penalty rank appears to be too low: please email Simon.Wood@R-" "project.org with details." msgstr "" "Produkt tensorowy rang kar wydaje się być zbyt niski: proszę przesłać email " "na adresSimon.Wood@R-project.org ze szczegółami." # mgcv/R/mgcv.r: 561 # stop("No data supplied to gam.setup") msgid "No data supplied to gamm.setup" msgstr "Nie dostarczono danych do funkcji 'gam.setup()'" # mgcv/R/gamm.r: 361 # stop("gamm can not handle linked smoothing parameters (probably from use of 'id' or adaptive smooths)") # mgcv/R/gamm.r: 804 # stop("gamm can not handle linked smoothing parameters (probably from use of 'id' or adaptive smooths)") msgid "" "gamm can not handle linked smoothing parameters (probably from use of `id' " "or adaptive smooths)" msgstr "" "funkcja 'gamm()' nie może obsłużyć dołączonych parametrów wygładzania " "(prawdopodobnie z użycia 'id' lub adaptacyjnych wygładzeń)" # mgcv/R/gamm.r: 832 # stop("only one level of smooth nesting is supported by gamm") msgid "only one level of smooth nesting is supported by gamm" msgstr "" "tylko jeden poziom zagnieżdżania gładkości jest wspierane przez funkcję " "'gamm()'" # mgcv/R/gamm.r: 833 # stop("side conditions are not allowed for nested smooths") #, fuzzy msgid "side conditions not allowed for nested smooths" msgstr "warunki boczne nie są dozwolone dla zagnieżdżonych wygładzeń" # mgcv/R/plots.r: 90 # stop("'object' argument is not an object of class \"glm\" or \"gam\"") msgid "object does not appear to be of class lme" msgstr "argument nie jest obiektem klasy \"lme\"" # mgcv/R/gamm.r: 1049 # stop("inner groupings not nested in outer!!") msgid "inner groupings not nested in outer!!" msgstr "wewnętrzne grupowanie nie jest zagnieżdżone w zewnętrznym grupowaniu!!" # mgcv/R/gamm.r: 1327 # message(gettextf("iteration %d", i)) #, fuzzy msgid "iteration %d" msgstr "iteracja" # mgcv/R/gamm.r: 1343 # warning("gamm not converged, try increasing niterPQL") msgid "gamm not converged, try increasing niterPQL" msgstr "" "funkcja 'gamm()' nie uzbieżniła się, spróbuj zwiększyć parametr 'niterPQL'" msgid "family are not designed for use with gamm!" msgstr "" # mgcv/R/gamm.r: 1366 # stop("random argument must be a *named* list.") msgid "random argument must be a *named* list." msgstr "argument 'random' musi być *nazwaną* listą." # mgcv/R/gamm.r: 1367 # stop("all elements of random list must be named") msgid "all elements of random list must be named" msgstr "wszystkie elementy listy 'random' muszą być nazwane" # mgcv/R/gamm.r: 1369 # stop("'gamm()' can only handle random effects defined as named lists") msgid "gamm() can only handle random effects defined as named lists" msgstr "" "funkcja 'gamm()' może obsłużyć jedynie efekty losowe zdefiniowane jaki " "nazwane listy" # mgcv/R/gamm.r: 1444 # stop("gamm models must have at least 1 smooth with unknown smoothing parameter or at least one other random effect") msgid "" "gamm models must have at least 1 smooth with unknown smoothing parameter or " "at least one other random effect" msgstr "" "modele 'gamm' muszą mieć co najmniej 1 wygładzenie z nieznanym parametrem " "wygładzania lub co najmniej jeden inny efekt losowy" # mgcv/R/gamm.r: 1505 # stop("weights must be like glm weights for generalized case") msgid "weights must be like glm weights for generalized case" msgstr "wagi muszą być jak wagi w 'glm' dla ogólnego przypadku" # mgcv/R/gamm.r: 1553 # stop("Nested smooths must be fully random") msgid "Nested smooths must be fully random" msgstr "Zagnieżdżone wygładzania muszą być w pełni losowe" msgid "sorry link not yet handled" msgstr "" # mgcv/R/mgcv.r: 3063 # warning("'test' argument ignored") #, fuzzy msgid "weights ignored" msgstr "argument 'test' został zignorowany" # mgcv/R/gamm.r: 1433 # stop("family not recognized") # mgcv/R/bam.r: 1075 # stop("family not recognized") # mgcv/R/mgcv.r: 1564 # stop("family not recognized") #, fuzzy msgid "family not implemented yet" msgstr "'family' nie został rozpoznany" msgid "jagam requires a file for the JAGS model specification" msgstr "" msgid "smoothing parameter prior choise not recognised, reset to gamma" msgstr "" msgid "coefficient simulation data is missing" msgstr "" msgid "burnin too large, reset" msgstr "" msgid "rho missing from simulation data edf.type reset to 2" msgstr "" # mgcv/R/mgcv.r: 3063 # warning("'test' argument ignored") #, fuzzy msgid "residuals argument not supported" msgstr "argument 'test' został zignorowany" msgid "unconditional argument not meaningful here" msgstr "" # mgcv/R/mgcv.r: 3063 # warning("'test' argument ignored") #, fuzzy msgid "by.resids argument not supported" msgstr "argument 'test' został zignorowany" # mgcv/R/mgcv.r: 3063 # warning("'test' argument ignored") #, fuzzy msgid "all.terms argument not supported" msgstr "argument 'test' został zignorowany" # mgcv/R/mgcv.r: 30 # stop("silly tolerance supplied") msgid "silly tolerance supplied" msgstr "dostarczono mało wiarygodną tolerancję" # mgcv/R/mgcv.r: 32 # stop("argument 'k' must be positive.") msgid "argument k must be positive." msgstr "argument 'k' musi być dodatni" # mgcv/R/mgcv.r: 36 # stop("matrix 'A' is not square") msgid "A not square" msgstr "macierz 'A' nie jest kwadratowa" # mgcv/R/mgcv.r: 37 # stop("Can not have more eigenvalues than nrow(A)") msgid "Can not have more eigenvalues than nrow(A)" msgstr "Nie można mieć więcej wartości własnych niż 'nrow(A)'" msgid "nrow(M$X) != length(M$y)" msgstr "nrow(M$X) != length(M$y)" msgid "ncol(M$X) != length(M$p)" msgstr "ncol(M$X) != length(M$p)" msgid "length(M$w) != length(M$y)" msgstr "length(M$w) != length(M$y)" msgid "nrow(M$Ain) != length(M$bin)" msgstr "nrow(M$Ain) != length(M$bin)" msgid "nrow(M$Ain) != length(M$p)" msgstr "nrow(M$Ain) != length(M$p)" # mgcv/R/mgcv.r: 102 # warning("initial parameters very close to inequality constraints") #, fuzzy msgid "initial parameters not feasible" msgstr "początkowe parametry bardzo blisko więzów nierowności" # mgcv/R/mgcv.r: 102 # warning("initial parameters very close to inequality constraints") #, fuzzy msgid "initial point very close to some inequality constraints" msgstr "początkowe parametry bardzo blisko więzów nierowności" # mgcv/R/mgcv.r: 102 # warning("initial parameters very close to inequality constraints") msgid "initial parameters very close to inequality constraints" msgstr "początkowe parametry bardzo blisko więzów nierowności" msgid "ncol(M$C) != length(M$p)" msgstr "ncol(M$C) != length(M$p)" # mgcv/R/mgcv.r: 106 # stop("'M$S' and 'M$off' have different lengths") msgid "M$S and M$off have different lengths" msgstr "'M$S' oraz 'M$off' mają różne długości" # mgcv/R/mgcv.r: 107 # stop("'M$sp' has different length to 'M$S' and 'M$off'") msgid "M$sp has different length to M$S and M$off" msgstr "'M$sp' ma inną długość niż 'M$S' oraz 'M$off'" # mgcv/R/mgcv.r: 116 # stop(gettextf("M$S[%d] is too large given M$off[%d]", i, i)) #, fuzzy msgid "M$S[%d] is too large given M$off[%d]" msgstr "] jest zbyt duże dla podanego M$off[" # mgcv/R/mgcv.r: 120 # stop("Penalized model matrix must have no more columns than rows") msgid "Penalized model matrix must have no more columns than rows" msgstr "Macierz modelu kary nie może mieć więcej kolumn niż wierszy" # mgcv/R/mgcv.r: 131 # stop("Model matrix not full column rank") msgid "Model matrix not full column rank" msgstr "Macierz modelu nie ma pełnej rangi kolumny" msgid "can't handle [[ in formula" msgstr "" # mgcv/R/gam.fit3.r: 231 # stop("Invalid linear predictor values in empty model") #, fuzzy msgid "single linear predictor indices are ignored" msgstr "Niepoprawne wartości liniowej zmiennej niezależnej w pustym modelu" # mgcv/R/smooth.r: 177 # stop("'x' out of range") #, fuzzy msgid "linear predictor labels out of range" msgstr "argument 'x' jest poza zakresem" # mgcv/R/mgcv.r: 356 # warning("model has repeated 1-d smooths of same variable.") msgid "model has repeated 1-d smooths of same variable." msgstr "model powtórzył jednowymiarowe wygładzania tej samiej zmiennej" # mgcv/R/mgcv.r: 458 # stop("'id' linked smooths must have same number of arguments") msgid "`id' linked smooths must have same number of arguments" msgstr "" "wygładzania połączone poprzez 'id' muszą mieć tę samą liczbę argumentów" # mgcv/R/mgcv.r: 515 # stop("'rank' has wrong length in 'paraPen'") msgid "`rank' has wrong length in `paraPen'" msgstr "'rank' posiada niepoprawną długość w 'paraPen'" # mgcv/R/mgcv.r: 520 # stop("a parametric penalty has wrong dimension") msgid "a parametric penalty has wrong dimension" msgstr "parametryczna kara ma niepoprawny wymiar" # mgcv/R/mgcv.r: 529 # stop("'L' has wrong dimension in 'paraPen'") msgid "L has wrong dimension in `paraPen'" msgstr "'L' posiada niepoprawny wymiar w 'paraPen'" # mgcv/R/mgcv.r: 537 # stop("'sp' dimension wrong in 'paraPen'") msgid "`sp' dimension wrong in `paraPen'" msgstr "wymiar 'sp' jest niepoprawny w 'paraPen'" # mgcv/R/mgcv.r: 551 # stop("'sp' is too short") msgid "`sp' too short" msgstr "'sp' jest zbyt krótkie" # mgcv/R/mgcv.r: 561 # stop("No data supplied to gam.setup") msgid "No data supplied to gam.setup" msgstr "Nie dostarczono danych do gam.setup" # mgcv/R/mgcv.r: 570 # stop("First argument is no sort of formula!") #, fuzzy msgid "paraPen not supported for multi-formula models" msgstr "Pierwszy argument nie jest typu formuły!" # mgcv/R/mgcv.r: 570 # stop("First argument is no sort of formula!") #, fuzzy msgid "absorb.cons must be TRUE for multi-formula models" msgstr "Pierwszy argument nie jest typu formuły!" msgid "length(drop.intercept) should be equal to number of model formulas" msgstr "" msgid "shared offsets not allowed" msgstr "" msgid "dropping unidentifiable parametric terms from model" msgstr "" # mgcv/R/mgcv.r: 570 # stop("First argument is no sort of formula!") msgid "First argument is no sort of formula!" msgstr "Pierwszy argument nie jest typu formuły!" # mgcv/R/mgcv.r: 572 # stop("You've got no model....") msgid "You've got no model...." msgstr "Nie posiadasz modelu..." # mgcv/R/mgcv.r: 714 # stop("Later terms sharing an 'id' can not have more smoothing parameters than the first such term") msgid "" "Later terms sharing an `id' can not have more smoothing parameters than the " "first such term" msgstr "" "Dalsze człony współdzielące 'id' nie mogą mieć więcej parametrów " "wygładzających niż pierwszy taki człon" # mgcv/R/mgcv.r: 802 # warning("Supplied smoothing parameter vector is too short - ignored.") msgid "Supplied smoothing parameter vector is too short - ignored." msgstr "" "Dostarczony wektor parametrów wygładzania jest zbyt krótki - zignorowano" # mgcv/R/mgcv.r: 803 # warning("NA's in supplied smoothing parameter vector - ignoring.") msgid "NA's in supplied smoothing parameter vector - ignoring." msgstr "" "Dostarczono wartości NA w wektorze parametrów wygładzających - ignorowanie" # mgcv/R/mgcv.r: 822 # stop("incorrect number of smoothing parameters supplied for a smooth term") # mgcv/R/mgcv.r: 830 # stop("incorrect number of smoothing parameters supplied for a smooth term") msgid "incorrect number of smoothing parameters supplied for a smooth term" msgstr "" "niepoprawna liczba parametrów wygładzających dostarczona do członu 'smooth'" # mgcv/R/mgcv.r: 863 # stop("length of min.sp is wrong.") msgid "length of min.sp is wrong." msgstr "długość 'min.sp' jest niepoprawna" # mgcv/R/mgcv.r: 864 # stop("NA's in min.sp.") msgid "NA's in min.sp." msgstr "wartości NA w 'min.sp'" # mgcv/R/mgcv.r: 865 # stop("elements of min.sp must be non negative.") msgid "elements of min.sp must be non negative." msgstr "elementy 'min.sp' muszą być nieujemne" # mgcv/R/mgcv.r: 1143 # stop("unknown outer optimization method.") msgid "unknown outer optimization method." msgstr "nieznana zewnętrzna metoda optymalizacji" msgid "Extended Fellner Schall only implemented for general families" msgstr "" msgid "Please provide a single value for theta or use nb to estimate it" msgstr "" # mgcv/R/mgcv.r: 1153 # stop("nlm.fd only available for GCV/UBRE") msgid "nlm.fd only available for GCV/UBRE" msgstr "'nlm.fd' jest dostępne jedynie dla GCV/UBRE" # mgcv/R/mgcv.r: 1275 # stop("unknown optimizer") msgid "unknown optimizer" msgstr "nieznany optymalizator" # mgcv/R/mgcv.r: 1276 # stop("unknown smoothness selection criterion") msgid "unknown smoothness selection criterion" msgstr "nieznane kryterium wyboru wygładzania" # mgcv/R/mgcv.r: 1282 # warning("Reset optimizer to outer/newton") msgid "Reset optimizer to outer/newton" msgstr "Resetowanie optymalizatora na zewnętrzny/newtona" # mgcv/R/mgcv.r: 1355 # stop("in.out incorrect: see documentation") msgid "in.out incorrect: see documentation" msgstr "'in.out' jest niepoprawne: zobacz dokumentację" # mgcv/R/mgcv.r: 822 # stop("incorrect number of smoothing parameters supplied for a smooth term") # mgcv/R/mgcv.r: 830 # stop("incorrect number of smoothing parameters supplied for a smooth term") #, fuzzy msgid "incorrect number of linear predictors for family" msgstr "" "niepoprawna liczba parametrów wygładzających dostarczona do członu 'smooth'" msgid "edge.correct must be logical or a positive number" msgstr "" # mgcv/R/mgcv.r: 32 # stop("argument 'k' must be positive.") #, fuzzy msgid "nthreads must be a positive integer" msgstr "argument 'k' musi być dodatni" # mgcv/R/mgcv.r: 1676 # stop("IRLS regularizing parameter must be a non-negative number.") msgid "IRLS regularizing parameter must be a non-negative number." msgstr "parametr regularyzacyjny IRLS musi być nieujemną liczbą" # mgcv/R/mgcv.r: 1678 # stop("value of epsilon must be > 0") msgid "value of epsilon must be > 0" msgstr "wartość 'epsilon' musi być > 0" # mgcv/R/mgcv.r: 1680 # stop("maximum number of iterations must be > 0") msgid "maximum number of iterations must be > 0" msgstr "maksymalna liczba iteracji musi być > 0" # mgcv/R/mgcv.r: 1683 # warning("silly value supplied for rank.tol: reset to square root of machine precision.") msgid "" "silly value supplied for rank.tol: reset to square root of machine precision." msgstr "" "śmieszna wartość została dostarczona do 'rank.tol': ustawianie pierwiastka " "kwadratowego z precyzji maszyny" # mgcv/R/mgcv.r: 1805 # stop("Model seems to contain no terms") msgid "Model seems to contain no terms" msgstr "Model wydaje się nie zawierać żadnych członów" # mgcv/R/mgcv.r: 1815 # warning("Discrete Theta search not available with performance iteration") msgid "Discrete Theta search not available with performance iteration" msgstr "Poszukiwania dyskretnej thety nie są dostępne z wykonywaną iteracją" # mgcv/R/mgcv.r: 1857 # stop("'y' must be univariate unless binomial") msgid "y must be univariate unless binomial" msgstr "'y' musi zawierać jedną zmienną jeśli nie zawiera dwóch" # mgcv/R/mgcv.r: 1865 # stop(gettextf("Length of start should equal %d and correspond to initial coefs.", nvars)) #, fuzzy msgid "Length of start should equal %d and correspond to initial coefs." msgstr "oraz odpowiadać początkowym współczynnikom" # mgcv/R/mgcv.r: 1918 # stop("iterative weights or data non-finite in gam.fit - regularization may help. See ?gam.control.") msgid "" "iterative weights or data non-finite in gam.fit - regularization may help. " "See ?gam.control." msgstr "" "iteracyjne wagi lub nieskończone dane w 'gam.fit' - regularyzacja może " "pomóc. Zobacz '?gam.control'" # mgcv/R/gam.fit3.r: 374 # warning("Step size truncated: out of bounds", call. = FALSE) msgid "Step size truncated: out of bounds." msgstr "Rozmiar kroku przycięty: poza granicami" # mgcv/R/plots.r: 90 # stop("'object' argument is not an object of class \"glm\" or \"gam\"") msgid "`object' is not of class \"gam\"" msgstr "argument 'object' nie jest obiektem klasy \"gam\"" # mgcv/R/gam.fit3.r: 1831 # stop("unrecognized (vector?) link") #, fuzzy msgid "unrecognised na.action" msgstr "nierozpoznane (wektorowe?) połączenie" msgid "na.action not character or function" msgstr "" msgid "Smoothness uncertainty corrected covariance not available" msgstr "" # mgcv/R/mgcv.r: 2100 # warning("Unknown type, reset to terms.") msgid "Unknown type, reset to terms." msgstr "Nieznany typ, resetowanie do 'terms'" # mgcv/R/mgcv.r: 2103 # stop("predict.gam can only be used to predict from gam objects") msgid "predict.gam can only be used to predict from gam objects" msgstr "" "funkcja 'predict.gam()' może być użyta jedynie do przewidywania z obiektów " "klasy \"gam\"" # mgcv/R/mgcv.r: 2127 # stop("newdata is a model.frame: it should contain all required variables\n") msgid "newdata is a model.frame: it should contain all required variables" msgstr "" "\"newdata\" jest klasy \"model.frame\": powinien zawierać wszystkie wymagane " "zmienne" # mgcv/R/mgcv.r: 2139 # warning("not all required variables have been supplied in newdata!\n") msgid "not all required variables have been supplied in newdata!" msgstr "nie wszystkie wymagane zmienne zostały dostarczone w \"newdata\"!" msgid "type iterms not available for multiple predictor cases" msgstr "" # mgcv/R/mgcv.r: 2284 # warning("non-existent terms requested - ignoring") msgid "non-existent terms requested - ignoring" msgstr "zażądano nieistniejących członów - ignorowanie" # mgcv/R/mgcv.r: 2284 # warning("non-existent terms requested - ignoring") #, fuzzy msgid "non-existent exclude terms requested - ignoring" msgstr "zażądano nieistniejących członów - ignorowanie" # mgcv/R/mgcv.r: 2350 # stop("'b' argument is not an object of class \"gam\"") msgid "requires an object of class gam" msgstr "argument nie jest obiektem klasy \"gam\"" # mgcv/R/mgcv.r: 2352 # stop("nothing to do for this model") msgid "nothing to do for this model" msgstr "nic do zrobienia dla tego modelu" msgid "" "Pearson residuals not available for this family - returning deviance " "residuals" msgstr "" # mgcv/R/mgcv.r: 2494 # stop("'lambda' and 'h' arguments should have the same length!") msgid "lambda and h should have the same length!" msgstr "argumenty 'lambda' oraz 'h' powinny mieć tę samą długość!" msgid "recov works with fitted gam objects only" msgstr "argument nie jest obiektem klasy \"gam\"" msgid "m can't be in re" msgstr "argument 'm' nie może być w argumencie 're'" # mgcv/R/mgcv.r: 2716 # warning("p-values may give low power in some circumstances") msgid "p-values may give low power in some circumstances" msgstr "p-wartość może dać niską moc w pewnych okolicznościach" # mgcv/R/mgcv.r: 2719 # warning("p-values un-reliable") msgid "p-values un-reliable" msgstr "p-wartość nie jest wiarygodna" # mgcv/R/mgcv.r: 2723 # warning("p-values may give very low power") msgid "p-values may give very low power" msgstr "p-wartości mogą dać bardzo niską moc" # mgcv/R/mgcv.r: 2822 # warning("p-values for any terms that can be penalized to zero will be unreliable: refit model to fix this.") msgid "" "p-values for any terms that can be penalized to zero will be unreliable: " "refit model to fix this." msgstr "" "p-wartości dla jakichkolwiek członów, które da się ukarać do zera, będą " "nierzetelne: ponownie dopasuj model aby to naprawić" msgid "p.type!=0 is deprecated, and liable to be removed in future" msgstr "" # mgcv/R/mgcv.r: 3053 # warning(gettext("The following arguments to anova.glm(..) are invalid and dropped: ", domain = "R-mgcv"), paste(deparse(dotargs[named]), collapse = ", "), domain = NA) msgid "The following arguments to anova.glm(..) are invalid and dropped:" msgstr "" "Następujące argumenty przekazywane do funkcji 'anova.glm(..)' są niepoprawne " "i zostały odrzucone:" msgid "," msgstr "," msgid "un-supported test" msgstr "" # mgcv/R/mgcv.r: 3063 # warning("'test' argument ignored") msgid "test argument ignored" msgstr "argument 'test' został zignorowany" msgid "anova.gam called with non gam object" msgstr "argument 'object' nie jest obiektem klasy \"gam\"" msgid "not a gam object" msgstr "argument nie jest obiektem klasy \"gam\"" # mgcv/R/mgcv.r: 2350 # stop("'b' argument is not an object of class \"gam\"") msgid "argument is not a gam object" msgstr "argument nie jest obiektem klasy \"gam\"" msgid "S.scale vector doesn't match S list - please report to maintainer" msgstr "" # mgcv/R/mgcv.r: 3315 # stop("Supplied matrix not symmetric") msgid "Supplied matrix not symmetric" msgstr "Dostarczona macierz nie jest symetryczna" # mgcv/R/mgcv.r: 3319 # stop("singular values not returned in order") msgid "singular values not returned in order" msgstr "osobliwe wartości nie zostały zwrócone w w sposób uporządkowany" # mgcv/R/mgcv.r: 3325 # stop("Something wrong - matrix probably not +ve semi definite") msgid "Something wrong - matrix probably not +ve semi definite" msgstr "Coś nie tak - prawdopodobnie macierz nie jest dodatnio określona" # mgcv/R/mgcv.r: 3340 # stop("method not recognised") msgid "method not recognised." msgstr "metoda nie została rozpoznana" # mgcv/R/mgcv.r: 3463 # stop(gettextf("S[[%d]] matrix is not +ve definite.", i)) #, fuzzy msgid "S[[%d]] matrix is not +ve definite." msgstr "]] nie jest dodatnio określona" # mgcv/R/mgcv.r: 3570 # stop("dimensions of supplied 'w' argument is wrong") msgid "dimensions of supplied w wrong." msgstr "wymiary dostarczonego argumentu 'w' są niepoprawne." # mgcv/R/mgcv.r: 3574 # stop("'w' argument has different length from 'y' argument!") msgid "w different length from y!" msgstr "argument 'w' posiada długość inną niż argument 'y'!" # mgcv/R/mgcv.r: 3581 # stop("'X' lost dimensions in magic!!") msgid "X lost dimensions in magic!!" msgstr "'X' utraciło wymiary w 'magic()!'!" # mgcv/R/smooth.r: 284 # warning("dimension of 'fx' is wrong") #, fuzzy msgid "mu dimensions wrong" msgstr "wymiar 'fx' jest niepoprawny" # mgcv/R/smooth.r: 2112 # stop("Something wrong with auto- penalty construction") #, fuzzy msgid "something wrong with inputs to LAPACK routine" msgstr "Coś nie tak z konstrukcją automatycznej kary" msgid "not positive definite" msgstr "" msgid "don't be silly" msgstr "" msgid "sd should have exactly one less entry than ld" msgstr "" msgid "internal error in vcorr, please report to simon.wood@r-project.org" msgstr "" msgid "a has wrong number of rows" msgstr "" msgid "mvn requires 2 or more dimensional data" msgstr "" msgid "mvn does not yet handle offsets" msgstr "" msgid "mvn dimension error" msgstr "" # mgcv/R/plots.r: 90 # stop("'object' argument is not an object of class \"glm\" or \"gam\"") msgid "object is not a glm or gam" msgstr "argument 'object' nie jest obiektem klasy \"glm\" lub \"gam\"" # mgcv/R/plots.r: 581 # stop("names of 'z' and 'pc' must match") msgid "names of z and pc must match" msgstr "nazwy 'z' oraz 'pc' muszą się zgadzać" # mgcv/R/plots.r: 882 # warning("Partial residuals do not have a natural x-axis location for linear functional terms") msgid "" "Partial residuals do not have a natural x-axis location for linear " "functional terms" msgstr "" "Częsciowe reszty nie posiadają naturalnego położenia osi 'x' dla liniowych " "członów funkcyjnych" # mgcv/R/plots.r: 916 # warning("no automatic plotting for smooths of more than two variables") msgid "no automatic plotting for smooths of more than two variables" msgstr "" "brak automatycznego rysowania dla wygładzeń o więcej niż dwóch zmiennych" # mgcv/R/plots.r: 959 # warning("no automatic plotting for smooths of more than one variable") msgid "no automatic plotting for smooths of more than one variable" msgstr "" "brak automatycznego rysowania dla wygładzeń o więcej niż jednej zmiennej" # mgcv/R/plots.r: 1012 # warning("residuals argument to plot.gam is wrong length: ignored") msgid "residuals argument to plot.gam is wrong length: ignored" msgstr "" "argument reszt przekazywany do 'plot.gam' ma niepoprawną długość: zignorowano" # mgcv/R/plots.r: 1038 # warning("No variance estimates available") msgid "No variance estimates available" msgstr "Brak dostępnego oszacowania wariancji" # mgcv/R/plots.r: 1105 # stop("No terms to plot - nothing for plot.gam() to do.") msgid "No terms to plot - nothing for plot.gam() to do." msgstr "Brak członów do rysowania - nic do wykonania przez 'plot.gam()'." # mgcv/R/mgcv.r: 3295 # stop("grid vectors are different lengths") # mgcv/R/plots.r: 1225 # stop("grid vectors are different lengths") msgid "grid vectors are different lengths" msgstr "wektory siatki są różnej długości" # mgcv/R/mgcv.r: 3296 # stop("data vectors are of different lengths") # mgcv/R/plots.r: 1226 # stop("data vectors are of different lengths") msgid "data vectors are of different lengths" msgstr "wektory danych są różnej długości" # mgcv/R/mgcv.r: 3297 # stop("supplied dist negative") # mgcv/R/plots.r: 1227 # stop("supplied dist negative") msgid "supplied dist negative" msgstr "dostarczona odległość jest ujemna" # mgcv/R/plots.r: 1283 # stop("Model does not seem to have enough terms to do anything useful") msgid "Model does not seem to have enough terms to do anything useful" msgstr "" "Model nie wydaje się mieć wystarczającej liczby członów aby zrobić coś " "użytecznego" # mgcv/R/plots.r: 1285 # stop(gettextf("view variables must be one of %s", paste(v.names, collapse = ", "))) #, fuzzy msgid "view variables must be one of %s" msgstr "zmienne podglądu muszą jednym z" # mgcv/R/plots.r: 1288 # stop("Don't know what to do with parametric terms that are not simple numeric or factor variables") msgid "" "Don't know what to do with parametric terms that are not simple numeric or " "factor variables" msgstr "" "Nie wiadomo co zrobić z członami parametrycznymi, które nie są zmiennymi o " "prostych liczbach lub czynnikami" # mgcv/R/plots.r: 1298 # stop(gettextf("View variables must contain more than one value. view = c(%s,%s).", view[1], view[2])) #, fuzzy msgid "View variables must contain more than one value. view = c(%s,%s)." msgstr "zmienne 'view' muszą zawierać więcej niż jedną wartość. view =c(" # mgcv/R/plots.r: 1346 # stop("type must be \"link\" or \"response\"") msgid "type must be \"link\" or \"response\"" msgstr "'type' musi mieć wartość \"link\" lub \"response\"" # mgcv/R/plots.r: 1373 # stop("Something wrong with zlim") # mgcv/R/plots.r: 1433 # stop("Something wrong with zlim") msgid "Something wrong with zlim" msgstr "Coś nie tak z 'zlim'" # mgcv/R/plots.r: 1389 # stop("color scheme not recognised") msgid "color scheme not recognised" msgstr "nie rozpoznano schematu kolorów" # mgcv/R/plots.r: 1442 # warning("sorry no option for contouring with errors: try plot.gam") msgid "sorry no option for contouring with errors: try plot.gam" msgstr "przykro mi, brak opcji rysowania konturu z błędami: spróbuj 'plot.gam'" # mgcv/R/smooth.r: 142 # stop("At least three knots required in call passed to 'mono.con()'.") msgid "At least three knots required in call to mono.con." msgstr "" "Co najmniej trzy węzły są wymagane w wywołaniu przekazywanym do funkcji " "'mono.con()'" # mgcv/R/smooth.r: 145 # stop("lower bound >= upper bound in call passed to 'mono.con()'") msgid "lower bound >= upper bound in call to mono.con()" msgstr "" "dolny zakres >= górny zakres w wywołaniu przekazywanym do funkcji 'mono." "con()'" # mgcv/R/smooth.r: 157 # stop("'x' is null") msgid "x is null" msgstr "'x' ma wartość NULL" msgid "uniquecombs has not worked properly" msgstr "" # mgcv/R/smooth.r: 173 # stop("order too low") msgid "order too low" msgstr "zbyt mała wartość argumentu 'ord'" # mgcv/R/smooth.r: 174 # stop("too few knots") # mgcv/R/smooth.r: 1323 # stop("too few knots") msgid "too few knots" msgstr "zbyt mało węzłów" # mgcv/R/smooth.r: 177 # stop("'x' out of range") msgid "x out of range" msgstr "argument 'x' jest poza zakresem" # mgcv/R/smooth.r: 265 # warning("something wrong with argument 'd'.") # mgcv/R/smooth.r: 373 # warning("something wrong with argument 'd'.") msgid "something wrong with argument d." msgstr "coś nie tak z argumentem 'd'" # mgcv/R/smooth.r: 274 # warning("one or more supplied k too small - reset to default") # mgcv/R/smooth.r: 382 # warning("one or more supplied k too small - reset to default") msgid "one or more supplied k too small - reset to default" msgstr "" "jeden lub więcej dostarczonych 'k' jest zbyt mały - przyjmowanie wartości " "domyślnej" # mgcv/R/smooth.r: 284 # warning("dimension of 'fx' is wrong") msgid "dimension of fx is wrong" msgstr "wymiar 'fx' jest niepoprawny" # mgcv/R/smooth.r: 394 # stop("xt argument is faulty.") msgid "xt argument is faulty." msgstr "argument 'xt' jest błędny" # mgcv/R/smooth.r: 296 # warning("bs wrong length and ignored.") # mgcv/R/smooth.r: 398 # warning("bs wrong length and ignored.") msgid "bs wrong length and ignored." msgstr "'bs' posiada niepoprawną długość przez co został zignorowany" # mgcv/R/smooth.r: 296 # warning("bs wrong length and ignored.") # mgcv/R/smooth.r: 398 # warning("bs wrong length and ignored.") msgid "m wrong length and ignored." msgstr "'m' posiada niepoprawną długość przez co został zignorowany" # mgcv/R/smooth.r: 308 # stop("Repeated variables as arguments of a smooth are not permitted") # mgcv/R/smooth.r: 410 # stop("Repeated variables as arguments of a smooth are not permitted") # mgcv/R/smooth.r: 483 # stop("Repeated variables as arguments of a smooth are not permitted") msgid "Repeated variables as arguments of a smooth are not permitted" msgstr "Powtórzone zmienne jako argumenty wygładzenia nie są dozwolone" # mgcv/R/smooth.r: 331 # warning("only first element of 'id' used") # mgcv/R/smooth.r: 441 # warning("only first element of 'id' used") # mgcv/R/smooth.r: 491 # warning("only first element of 'id' used") msgid "only first element of `id' used" msgstr "został użyty jedynie pierwszy element 'id'" msgid "supply a value for each variable for a point constraint" msgstr "" # mgcv/R/smooth.r: 428 # warning("ord is wrong. reset to NULL.") msgid "ord is wrong. reset to NULL." msgstr "argument 'ord' jest błędny. Przywracanie wartości NULL" # mgcv/R/smooth.r: 430 # warning("ord contains out of range orders (which will be ignored)") msgid "ord contains out of range orders (which will be ignored)" msgstr "'ord' zawiera porządki poza zakresem (zostaną one zignorowane)" # mgcv/R/smooth.r: 468 # stop("by=. not allowed") msgid "by=. not allowed" msgstr "'by=.' nie jest dozwolone" # mgcv/R/smooth.r: 470 # stop("s(.) not yet supported.") # mgcv/R/smooth.r: 474 # stop("s(.) not yet supported.") msgid "s(.) not yet supported." msgstr "funkcja 's(.)' nie jest jeszcze wspierana" # mgcv/R/smooth.r: 480 # warning("argument k of s() should be integer and has been rounded") msgid "argument k of s() should be integer and has been rounded" msgstr "" "argument 'k' w funkcji 's()' powinie być liczbą calkowitą więc został " "zaokrąglony" # mgcv/R/smooth.r: 568 # stop("attempt to use unsuitable marginal smooth class") # mgcv/R/smooth.r: 812 # stop("attempt to use unsuitable marginal smooth class") msgid "attempt to use unsuitable marginal smooth class" msgstr "próba użycia niepasującej granicznej gładkiej klasy" # mgcv/R/smooth.r: 572 # stop("Sorry, tensor products of smooths with multiple penalties are not supported.") # mgcv/R/smooth.r: 816 # stop("Sorry, tensor products of smooths with multiple penalties are not supported.") msgid "" "Sorry, tensor products of smooths with multiple penalties are not supported." msgstr "" "Przykro mi, produkty tensorowe wygładzeń z wielokrotnymi karami nie są " "wpierane" # mgcv/R/smooth.r: 600 # warning("reparameterization unstable for margin: not done") msgid "reparameterization unstable for margin: not done" msgstr "ponowna parametryzacja nie jest stabilna dla marginesu: nie wykonano" msgid "" "single penalty tensor product smooths are deprecated and likely to be " "removed soon" msgstr "" msgid "basis not usable with reduced te" msgstr "" # mgcv/R/smooth.r: 855 # warning("fx length wrong from t2 term: ignored") msgid "fx length wrong from t2 term: ignored" msgstr "długość 'fx' z członu 't2' jest błędna: zignorowano" # mgcv/R/smooth.r: 861 # warning("length of sp incorrect in t2: ignored") msgid "length of sp incorrect in t2: ignored" msgstr "długość 'sp' jest niepoprawna w 't2': zignorowano" # mgcv/R/smooth.r: 987 # stop("'d' can not be negative in call passed to 'null.space.dimension()'.") msgid "d can not be negative in call to null.space.dimension()." msgstr "" "'d' nie może być ujemne w wywołaniu przekazywanym do funkcji 'null.space." "dimension()'" # mgcv/R/smooth.r: 1025 # stop("arguments of smooth not same dimension") # mgcv/R/smooth.r: 1157 # stop("arguments of smooth not same dimension") # mgcv/R/smooth.r: 2288 # stop("arguments of smooth not same dimension") # mgcv/R/smooth.r: 2495 # stop("arguments of smooth not same dimension") # mgcv/R/smooth.r: 2648 # stop("arguments of smooth not same dimension") msgid "arguments of smooth not same dimension" msgstr "argumenty wygładzania nie mają tego samego wymiaru" # mgcv/R/smooth.r: 1037 # stop("components of knots relating to a single smooth must be of same length") # mgcv/R/smooth.r: 2301 # stop("components of knots relating to a single smooth must be of same length") # mgcv/R/smooth.r: 2508 # stop("components of knots relating to a single smooth must be of same length") msgid "components of knots relating to a single smooth must be of same length" msgstr "" "komponenty węzłów odwołujące się do pojedynczego wygładzenia muszą być tej " "samej długości" # mgcv/R/smooth.r: 1042 # warning("more knots than data in a tp term: knots ignored.") msgid "more knots than data in a tp term: knots ignored." msgstr "więcej węzłów niż danych w członie 'tp': węzły zostały zignorowane" # mgcv/R/smooth.r: 1079 # warning("basis dimension, k, increased to minimum possible\n") # mgcv/R/smooth.r: 1217 # warning("basis dimension, k, increased to minimum possible\n") # mgcv/R/smooth.r: 1365 # warning("basis dimension, k, increased to minimum possible\n") msgid "basis dimension, k, increased to minimum possible" msgstr "wymiar podstawy, k, zwiększył się do minimalnego możliwego" # mgcv/R/smooth.r: 1158 # stop("no data to predict at") # mgcv/R/smooth.r: 1287 # stop("no data to predict at") # mgcv/R/smooth.r: 1419 # stop("no data to predict at") msgid "no data to predict at" msgstr "brak danych na których można oprzeć przewidywanie" # mgcv/R/smooth.r: 1205 # stop("Basis only handles 1D smooths") # mgcv/R/smooth.r: 1361 # stop("Basis only handles 1D smooths") # mgcv/R/smooth.r: 1442 # stop("Basis only handles 1D smooths") # mgcv/R/smooth.r: 1507 # stop("Basis only handles 1D smooths") msgid "Basis only handles 1D smooths" msgstr "Podstawa obsługuje jedynie jednowymiarowe wygładzania" # mgcv/R/smooth.r: 1231 # stop("number of supplied knots != k for a cr smooth") msgid "number of supplied knots != k for a cr smooth" msgstr "liczba dostarczonych węzłów != k dla wygładzania 'cr'" # mgcv/R/smooth.r: 1294 # stop("F is missing from cr smooth - refit model with current mgcv") msgid "F is missing from cr smooth - refit model with current mgcv" msgstr "" "Brakuje 'F' w wygładzaniu 'cr' - ponownie dopasuj model z bieżącym mgcv" # mgcv/R/smooth.r: 1322 # stop("more knots than unique data values is not allowed") msgid "more knots than unique data values is not allowed" msgstr "" "większa liczba węzłów niż unikalnych wartości danych nie jest dozwolona" # mgcv/R/smooth.r: 1375 # stop("number of supplied knots != k for a cc smooth") msgid "number of supplied knots != k for a cc smooth" msgstr "liczba dostarczonych węzłów != k dla wygładzania 'cc'" # mgcv/R/smooth.r: 1441 # stop("basis dimension too small for b-spline order") # mgcv/R/smooth.r: 1506 # stop("basis dimension too small for b-spline order") msgid "basis dimension too small for b-spline order" msgstr "wymiar podstawy jest zbyt mały dla rzędu b-splajnu" # mgcv/R/smooth.r: 1449 # stop("knot range does not include data") # mgcv/R/smooth.r: 1513 # stop("knot range does not include data") msgid "knot range does not include data" msgstr "zakres węzła nie zawiera danych" # mgcv/R/gam.fit3.r: 785 # stop("deriv should be 1 or 2") msgid "there should be" msgstr "liczba dostarczonych węzłów powinna być równa:" # mgcv/R/smooth.r: 2116 # stop("supplied penalty not square!") msgid "supplied knots" msgstr " " msgid "knots supplied" msgstr " " # mgcv/R/smooth.r: 1463 # warning("knot range is so wide that there is *no* information about some basis coefficients") # mgcv/R/smooth.r: 1526 # warning("knot range is so wide that there is *no* information about some basis coefficients") msgid "" "knot range is so wide that there is *no* information about some basis " "coefficients" msgstr "" "zakres węzła jest tak szeroki, że *brak* informacji o niektórych " "podstawowych współczynnikach" # mgcv/R/smooth.r: 1470 # stop("penalty order too high for basis dimension") msgid "penalty order too high for basis dimension" msgstr "rząd kar jest zbyt duży dla podstawy wymiaru" # mgcv/R/smooth.r: 1463 # warning("knot range is so wide that there is *no* information about some basis coefficients") # mgcv/R/smooth.r: 1526 # warning("knot range is so wide that there is *no* information about some basis coefficients") #, fuzzy msgid "there is *no* information about some basis coefficients" msgstr "" "zakres węzła jest tak szeroki, że *brak* informacji o niektórych " "podstawowych współczynnikach" msgid "basis dimension is larger than number of unique covariates" msgstr "" msgid "requested non-existent derivative in B-spline penalty" msgstr "" # mgcv/R/smooth.r: 1600 # stop("fs smooths can only have one factor argument") msgid "fs smooths can only have one factor argument" msgstr "wygładzania 'fs' mogą mieć tylko jeden argument czynnikowy" # mgcv/R/smooth.r: 1632 # stop("\"fs\" smooth cannot use a multiply penalized basis (wrong basis in xt)") msgid "\"fs\" smooth cannot use a multiply penalized basis (wrong basis in xt)" msgstr "" "wygładzanie \"fs\" nie może użyć wielokrotnie ukaranej bazy (błędna baza w " "xt)" # mgcv/R/mgcv.r: 561 # stop("No data supplied to gam.setup") #, fuzzy msgid "no factor supplied to fs smooth" msgstr "Nie dostarczono danych do gam.setup" # mgcv/R/smooth.r: 1664 # stop("\"fs\" terms can not be fixed here") msgid "\"fs\" terms can not be fixed here" msgstr "człony \"fs\" nie mogą być poprawione tutaj" msgid "" "fs smooth not suitable for discretisation with more than one metric predictor" msgstr "" # mgcv/R/smooth.r: 1805 # stop("the adaptive smooth class is limited to 1 or 2 covariates.") msgid "the adaptive smooth class is limited to 1 or 2 covariates." msgstr "adaptacyjna klasa wygładzania jest ograniczona do 1 lub 2 zmiennych" # mgcv/R/smooth.r: 1821 # stop("penalty basis too large for smoothing basis") # mgcv/R/smooth.r: 1872 # stop("penalty basis too large for smoothing basis") msgid "penalty basis too large for smoothing basis" msgstr "podstawa kar jest zbyt duża dla podstawy wygładzania" # mgcv/R/smooth.r: 1892 # stop("penalty basis too small") msgid "penalty basis too small" msgstr "podstawa kar jest zbyt mała" # mgcv/R/smooth.r: 1934 # stop("random effects don't work with ids.") msgid "random effects don't work with ids." msgstr "losowe efekty nie działają z 'ids'" msgid "" "Please put term with most levels last in 're' to avoid spoiling supplied " "penalties" msgstr "" # mgcv/R/smooth.r: 2117 # stop("supplied penalty wrong dimension!") #, fuzzy msgid "supplied S matrices are wrong diminsion" msgstr "dostarczona kara ma niepoprawny wymiar!" # mgcv/R/smooth.r: 480 # warning("argument k of s() should be integer and has been rounded") #, fuzzy msgid "argument of mrf should be a factor variable" msgstr "" "argument 'k' w funkcji 's()' powinie być liczbą calkowitą więc został " "zaokrąglony" # mgcv/R/smooth.r: 2062 # stop("MRF basis dimension set too high") msgid "MRF basis dimension set too high" msgstr "ustawiony bazowy wymiar MRF jest zbyt wysoki" # mgcv/R/smooth.r: 2065 # stop("data contain regions that are not contained in the knot specification") msgid "data contain regions that are not contained in the knot specification" msgstr "dane zawierają regiony, które nie są zawarte w specyfikacji węzła" # mgcv/R/smooth.r: 2075 # stop("penalty matrix, boundary polygons and/or neighbours list must be supplied in xt") msgid "" "penalty matrix, boundary polygons and/or neighbours list must be supplied in " "xt" msgstr "" "macierz kary, wielokąty brzegowe oraz/lub lista sąsiadów muszą być " "dostarczone w xt" # mgcv/R/smooth.r: 2097 # stop("no spatial information provided!") msgid "no spatial information provided!" msgstr "nie dostarczono informacji przestrzennej!" # mgcv/R/smooth.r: 2102 # stop("mismatch between nb/polys supplied area names and data area names") msgid "mismatch between nb/polys supplied area names and data area names" msgstr "" "niezgodność pomiędzy dostarczonymi nazwami obszarów nb/polys a nazwami " "obszarów danych" # mgcv/R/smooth.r: 2112 # stop("Something wrong with auto- penalty construction") msgid "Something wrong with auto- penalty construction" msgstr "Coś nie tak z konstrukcją automatycznej kary" # mgcv/R/smooth.r: 2116 # stop("supplied penalty not square!") msgid "supplied penalty not square!" msgstr "dostarczona kara nie jest kwadratowa!" # mgcv/R/smooth.r: 2117 # stop("supplied penalty wrong dimension!") msgid "supplied penalty wrong dimension!" msgstr "dostarczona kara ma niepoprawny wymiar!" # mgcv/R/smooth.r: 2121 # stop("penalty column names don't match supplied area names!") msgid "penalty column names don't match supplied area names!" msgstr "nazwa kolumny kary nie zgadza się z dostarczonymi nazwami obszaru!" # mgcv/R/smooth.r: 2281 # stop("Can only deal with a sphere") msgid "Can only deal with a sphere" msgstr "można obsługiwać jedynie sferę" # mgcv/R/smooth.r: 2307 # warning("more knots than data in an sos term: knots ignored.") msgid "more knots than data in an sos term: knots ignored." msgstr "więcej węzłów niż danych w członie 'sos': węzły zostały zignorowane" # mgcv/R/smooth.r: 2514 # warning("more knots than data in a ds term: knots ignored.") msgid "more knots than data in a ds term: knots ignored." msgstr "więcej węzłów niż danych w członie 'ds': węzły zostały zignorowane" # mgcv/src/tprs.c: 417 # (_("A term has fewer unique covariate combinations than specified maximum degrees of freedom"),1) # mgcv/src/tprs.c: 425 # (_("A term has fewer unique covariate combinations than specified maximum degrees of freedom"),1) # mgcv/R/smooth.r: 2518 # stop( # "A term has fewer unique covariate combinations than specified maximum degrees of freedom") msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" "człon posiada mniej unikalnych kombinacji zmiennych niezależnych niż " "określona maksymalna liczba stopni swobody" # mgcv/R/smooth.r: 2559 # warning("s value reduced") msgid "s value reduced" msgstr "wartość 's' została zmniejszona" # mgcv/R/smooth.r: 2563 # warning("s value increased") msgid "s value increased" msgstr "wartość 's' została zwiększona" # mgcv/R/smooth.r: 2569 # stop("No suitable s (i.e. m[2]) try increasing m[1]") msgid "No suitable s (i.e. m[2]) try increasing m[1]" msgstr "Brak odpowiedniego 's' (tj.: m[2]), spróbuj zwiększyć 'm[1]'" # mgcv/R/smooth.r: 2570 # warning("s value modified to give continuous function") msgid "s value modified to give continuous function" msgstr "wartość 's' została zmieniona aby dać ciągłą funkcję" # mgcv/R/smooth.r: 2596 # warning("basis dimension reset to minimum possible") msgid "basis dimension reset to minimum possible" msgstr "wymiar podstawy został przywrócony do minimalnego możliwego" msgid "incorrect arguments to GP smoother" msgstr "" # mgcv/R/smooth.r: 2307 # warning("more knots than data in an sos term: knots ignored.") #, fuzzy msgid "more knots than data in an ms term: knots ignored." msgstr "więcej węzłów niż danych w członie 'sos': węzły zostały zignorowane" # mgcv/R/smooth.r: 2804 # warning("smooth objects should not have a qrc attribute.") msgid "smooth objects should not have a qrc attribute." msgstr "gładkie obiekty nie powinny mieć atrybutu 'qrc'" # mgcv/R/smooth.r: 2842 # stop("unimplemented sparse constraint type requested") msgid "unimplemented sparse constraint type requested" msgstr "zażądano niezaimplementowanego typu rzadkiego więzu" # mgcv/R/smooth.r: 2893 # warning("handling 'by' variables in smooth constructors may not work with the summation convention") msgid "" "handling `by' variables in smooth constructors may not work with the " "summation convention" msgstr "" "obsługiwanie zmiennych 'by' w konstruktorach wygładzenia może nie działać z " "konwencją sumacyjną" # mgcv/R/smooth.r: 2910 # stop("Can't find by variable") # mgcv/R/smooth.r: 3175 # stop("Can't find by variable") # mgcv/R/smooth.r: 3200 # stop("Can't find by variable") msgid "Can't find by variable" msgstr "Nie można znaleźć poprzez zmienną" msgid "" "sweep and drop constraints unlikely to work well with self handling of by " "vars" msgstr "" # mgcv/R/smooth.r: 2913 # stop("factor 'by' variables can not be used with matrix arguments.") msgid "factor `by' variables can not be used with matrix arguments." msgstr "faktoryzacja zmiennych 'by' nie może być użyta z argumentami macierzy" # mgcv/R/smooth.r: 2933 # stop("'by' variable must be same dimension as smooth arguments") # mgcv/R/smooth.r: 3206 # stop("'by' variable must be same dimension as smooth arguments") msgid "`by' variable must be same dimension as smooth arguments" msgstr "zmienna 'by' musi mieć ten sam wymiar co argumenty wygładzania" # mgcv/R/smooth.r: 3137 # stop("Number of prediction and fit constraints must match") msgid "Number of prediction and fit constraints must match" msgstr "Liczba przewidywań oraz więzów dopasowania musi się zgadzać" # mgcv/R/soap.r: 92 # stop("x and y must be same length") msgid "x and y must be same length" msgstr "x oraz y muszą mieć tę samą długość" # mgcv/R/soap.r: 109 # stop("variable names don't match boundary names") # mgcv/R/soap.r: 114 # stop("variable names don't match boundary names") msgid "variable names don't match boundary names" msgstr "nazwy zmiennych nie zgadzają się z nazwami granic" # mgcv/R/soap.r: 133 # stop("x and y not same length") msgid "x and y not same length" msgstr "'x' oraz 'y' nie mają tej samej długości" # mgcv/R/soap.r: 177 # stop("bnd must be a list.") msgid "bnd must be a list." msgstr "'bnd' musi być listą" # mgcv/R/soap.r: 181 # stop("lengths of k and bnd are not compatible.") msgid "lengths of k and bnd are not compatible." msgstr "długości 'k' oraz 'bnd' nie są zgodne" # mgcv/R/soap.r: 306 # stop("attempt to select non existent basis function") msgid "attempt to select non existent basis function" msgstr "próba wybrania nieistniejącej funkcji bazowej" # mgcv/R/soap.r: 309 # stop("coefficient vector wrong length") msgid "coefficient vector wrong length" msgstr "błędna długość wektora współczynników" # mgcv/R/soap.r: 418 # stop("knots must be specified for soap") # mgcv/R/soap.r: 522 # stop("knots must be specified for soap") # mgcv/R/soap.r: 627 # stop("knots must be specified for soap") msgid "knots must be specified for soap" msgstr "węzły muszą być określone dla 'soap'" # mgcv/R/soap.r: 419 # stop("soap films are bivariate only") # mgcv/R/soap.r: 523 # stop("soap films are bivariate only") # mgcv/R/soap.r: 628 # stop("soap films are bivariate only") msgid "soap films are bivariate only" msgstr "filmy 'soap' są tylko dwuwymiarowe" # mgcv/R/soap.r: 426 # stop("need at least one interior knot") # mgcv/R/soap.r: 530 # stop("need at least one interior knot") # mgcv/R/soap.r: 635 # stop("need at least one interior knot") msgid "need at least one interior knot" msgstr "potrzeba przynajmniej jednego wewnętrznego węzła" # mgcv/R/soap.r: 429 # stop("can't soap smooth without a boundary") # mgcv/R/soap.r: 533 # stop("can't soap smooth without a boundary") # mgcv/R/soap.r: 638 # stop("can't soap smooth without a boundary") msgid "can't soap smooth without a boundary" msgstr "nie można wygładzić 'soap' bez granicy" # mgcv/R/soap.r: 430 # stop("bnd must be a list of boundary loops") # mgcv/R/soap.r: 534 # stop("bnd must be a list of boundary loops") # mgcv/R/soap.r: 639 # stop("bnd must be a list of boundary loops") msgid "bnd must be a list of boundary loops" msgstr "'bnd' musi być listą pętel granic" # mgcv/R/soap.r: 435 # stop("faulty bnd") # mgcv/R/soap.r: 438 # stop("faulty bnd") # mgcv/R/soap.r: 539 # stop("faulty bnd") # mgcv/R/soap.r: 542 # stop("faulty bnd") # mgcv/R/soap.r: 644 # stop("faulty bnd") # mgcv/R/soap.r: 647 # stop("faulty bnd") msgid "faulty bnd" msgstr "błędne 'bnd'" # mgcv/R/soap.r: 445 # stop("k and bnd lengths are inconsistent") # mgcv/R/soap.r: 549 # stop("k and bnd lengths are inconsistent") # mgcv/R/soap.r: 654 # stop("k and bnd lengths are inconsistent") msgid "k and bnd lengths are inconsistent" msgstr "długości 'k' oraz 'bnd' są niezgodne" # mgcv/R/soap.r: 456 # stop("data outside soap boundary") # mgcv/R/soap.r: 559 # stop("data outside soap boundary") # mgcv/R/soap.r: 665 # stop("data outside soap boundary") msgid "data outside soap boundary" msgstr "dane poza granicami 'soap'" # mgcv/R/soap.r: 561 # stop("no free coefs in sf smooth") msgid "no free coefs in sf smooth" msgstr "brak wolnych współczynników w wygładzaniu sf" # mgcv/R/sparse.r: 103 # stop("only deals with 2D case") msgid "only deals with 2D case" msgstr "obsługiwanie jedynie dwuwymiarowych przypadków" # mgcv/R/sparse.r: 141 # stop("not enough unique values to find k nearest") msgid "not enough unique values to find k nearest" msgstr "zbyt mało unikalnych wartości aby znaleźć k najbliższych" # mgcv/R/sparse.r: 248 # stop("cubic spline only deals with 1D data") msgid "cubic spline only deals with 1D data" msgstr "sześcienny splajn radzi sobie jedynie z danymi jednowymiarowymi" # mgcv/R/sparse.r: 288 # stop("object not fully initialized") msgid "object not fully initialized" msgstr "obiekt nie został w pełni zainicjalizowany" # mgcv/R/bam.r: 425 # warning(gettextf("non-finite coefficients at iteration %d", iter)) # mgcv/R/bam.r: 600 # warning(gettextf("non-finite coefficients at iteration %d", iter)) #~ msgid "non-finite coefficients at iteration" #~ msgstr "nieskończone współczynniki w iteracji" # mgcv/R/bam.r: 1086 # warning("sparse=TRUE not supported with fast REML, reset to REML.") #~ msgid "sparse=TRUE not supported with fast REML, reset to REML." #~ msgstr "" #~ "'sparse=TRUE' nie jest wspierane dla szybkiego REML, przywracanie REML." # mgcv/R/bam.r: 1175 # warning("model matrix too dense for any possible benefit from sparse") #~ msgid "model matrix too dense for any possible benefit from sparse" #~ msgstr "macierz modelu jest zbyt gęsta aby móc skorzystać z zalez 'sparse'" # mgcv/R/bam.r: 1178 # warning("AR1 parameter rho unused with sparse fitting") #~ msgid "AR1 parameter rho unused with sparse fitting" #~ msgstr "parametr rho AR1 jest nieużywany podczas dopasowania 'sparse'" # mgcv/R/mgcv.r: 1152 # stop("nlm.fd not available with negative binomial Theta estimation") #~ msgid "nlm.fd not available with negative binomial Theta estimation" #~ msgstr "" #~ "'nlm.fd' nie jest dostępne z ujemnym oszacowaniem Theta rozkładu Pascala" # mgcv/R/mgcv.r: 1175 # warning("only outer methods 'newton' & 'bfgs' supports 'negbin' family and theta selection: reset") #~ msgid "" #~ "only outer methods `newton' & `bfgs' supports `negbin' family and theta " #~ "selection: reset" #~ msgstr "" #~ "tylko zewnętrzne metody 'newton' oraz 'bfgs' wspierają rodzinę 'negbin' " #~ "oraz wybór theta: reset" # mgcv/R/smooth.r: 158 # stop("'x' has no row attribute") #~ msgid "x has no row attribute" #~ msgstr "'x' nie posiada atrybutu 'row'" # mgcv/R/smooth.r: 159 # stop("'x' has no col attribute") #~ msgid "x has no col attribute" #~ msgstr "'x' nie posiada atrybutu 'col'" # mgcv/R/bam.r: 45 # stop("Choleski based method failed, switch to QR") #~ msgid "Choleski based method failed, switch to QR" #~ msgstr "" #~ "metoda oparta na algorytmie Choleskiego nie powiodła się, przełączania na " #~ "algorytm QR" #~ msgid "gamm() requires package nlme to be installed" #~ msgstr "funkcja 'gamm()' wymaga aby pakiet 'nlme' był zainstalowany" #~ msgid "M$S[" #~ msgstr "M$S[" #~ msgid "]" #~ msgstr "]" # mgcv/R/mgcv.r: 3265 # warning("extra arguments were discarded") #~ msgid "extra arguments discarded" #~ msgstr "dodatkowe argumenty zostały odrzucone" #~ msgid "S[[" #~ msgstr "S[[" #~ msgid ")." #~ msgstr ")." #~ msgid "can't predict outside range of knots with periodic smoother" #~ msgstr "" #~ "nie można przewidywać poza zakresem węzłów z periodycznym wygładzaniem" #~ msgid "k too small for balanced neighbours" #~ msgstr "'k' jest zbyt małe dla zbalansowanych sąsiadów" #~ msgid "only 2D case available so far" #~ msgstr "na chwilę obecną tylko dwuwymiarowe przypadki są dostępne" # mgcv/R/bam.r: 1170 # gettext("Setup complete. Calling fit", domain = "R-mgcv") #~ msgid "Setup complete. Calling fit" #~ msgstr "Ustawienie jest kompletne. Wywoływanie dopasowania." # mgcv/R/bam.r: 1209 # gettext("Fit complete. Finishing gam object.", domain = "R-mgcv") #~ msgid "Fit complete. Finishing gam object." #~ msgstr "Dopasowanie jest kompletne. Kończenie obiektu klasy \"gam\"." # mgcv/R/fast-REML.r: 641 # gettext("step failed", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1247 # gettext("step failed", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1424 # gettext("step failed", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1684 # gettext("step failed", domain = "R-mgcv") #~ msgid "step failed" #~ msgstr "krok nie powiódł się" # mgcv/R/fast-REML.r: 642 # gettext("no convergence in 200 iterations", domain = "R-mgcv") #~ msgid "no convergence in 200 iterations" #~ msgstr "brak zbieżności w 200 iteracjach" # mgcv/R/fast-REML.r: 643 # gettext("full convergence", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1249 # gettext("full convergence", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1426 # gettext("full convergence", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1689 # gettext("full convergence", domain = "R-mgcv") #~ msgid "full convergence" #~ msgstr "pełna zbieżność" # mgcv/R/gam.fit3.r: 284 # stop("NA values in V(mu)") # mgcv/R/gam.fit3.r: 457 # stop("NA values in V(mu)") # mgcv/R/mgcv.r: 1890 # stop("NA values in V(mu)") #~ msgid "NA values in V(mu)" #~ msgstr "wartości NA w 'V(mu)'" # mgcv/R/gam.fit3.r: 362 # stop("inner loop 1; can't correct step size") # mgcv/R/mgcv.r: 1960 # stop("inner loop 1; can't correct step size") #~ msgid "inner loop %d; can't correct step size" #~ msgstr "wewnętrzna pętla %d; nie można poprawić rozmiaru kroku" # mgcv/R/gam.fit3.r: 371 # gettextf("Step halved: new deviance = %s", dev, domain = "R-mgcv") # mgcv/R/gam.fit3.r: 387 # gettextf("Step halved: new deviance = %s", dev, domain = "R-mgcv") # mgcv/R/mgcv.r: 1970 # gettextf("Step halved: new deviance = %s", dev, domain = "R-mgcv") # mgcv/R/mgcv.r: 1987 # gettextf("Step halved: new deviance = %s", dev, domain = "R-mgcv") #~ msgid "Step halved: new deviance = %s" #~ msgstr "Krok został skrócony o połowę: nowe odchylenie = %s" # mgcv/R/gam.fit3.r: 521 # gettext("calling gdi...", domain = "R-mgcv") #~ msgid "calling gdi..." #~ msgstr "wywoływanie gdi..." # mgcv/R/gam.fit3.r: 546 # gettext("done!", domain = "R-mgcv") #~ msgid "done!" #~ msgstr "wykonano!" # mgcv/R/gam.fit3.r: 705 # gettextf("Proportion time in C: %s ls: %s gdi: %s",(tc+tg)/at,tc/at,tg/at, domain = "R-mgcv") #~ msgid "Proportion time in C: %s ls: %s gdi: %s" #~ msgstr "Czas proporcji w C: %s ls: %s gdi: %s" # mgcv/R/gam.fit3.r: 774 # gettext("differences", domain = "R-mgcv") #~ msgid "differences" #~ msgstr "różnice" # mgcv/R/gam.fit3.r: 868 # gettext("Pearson Statistic...", domain = "R-mgcv") #~ msgid "Pearson Statistic..." #~ msgstr "Statystyka Pearson'a..." # mgcv/R/gam.fit3.r: 887 # gettext("Deviance...", domain = "R-mgcv") #~ msgid "Deviance..." #~ msgstr "Odchylenie..." # mgcv/R/gam.fit3.r: 897 # gettext("The objective...", domain = "R-mgcv") #~ msgid "The objective..." #~ msgstr "Cel..." # mgcv/R/gam.fit3.r: 1248 # gettext("iteration limit reached", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1425 # gettext("iteration limit reached", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1688 # gettext("iteration limit reached", domain = "R-mgcv") #~ msgid "iteration limit reached" #~ msgstr "osiągnięto limit iteracji" # mgcv/R/gam.fit3.r: 2361 # stop("'mu' argument must be non negative") #~ msgid "'mu' argument must be non negative" #~ msgstr "argument 'mu' musi być nieujemny" #~ msgid "Deta: rdiff = %s cor = %s" #~ msgstr "Deta: rdiff = %s korelacja = %s" #~ msgid "Dth[%d]: rdiff = %s cor = %s" #~ msgstr "Dth[%d]: rdiff = %s korelacja = %s" #~ msgid "Deta2: rdiff = %s cor = %s" #~ msgstr "Deta2: rdiff = %s korelacja = %s" #~ msgid "Deta3: rdiff = %s cor = %s" #~ msgstr "Deta3: rdiff = %s korelacja = %s" #~ msgid "Deta4: rdiff = %s cor = %s" #~ msgstr "Deta4: rdiff = %s korelacja = %s" #~ msgid "Detath[%d]: rdiff = %s cor = %s" #~ msgstr "Detath[%d]: rdiff = %s korelacja = %s" #~ msgid "Deta2th[%d]: rdiff = %s cor = %s" #~ msgstr "Deta2th[%d]: rdiff = %s korelacja = %s" #~ msgid "Deta3th[%d]: rdiff = %s cor = %s" #~ msgstr "Deta3th[%d]: rdiff = %s korelacja = %s" #~ msgid "Dth2[%d]: rdiff = %s cor = %s" #~ msgstr "Dth2[%d]: rdiff = %s korelacja = %s" #~ msgid "Deta2th2[%d]: rdiff = %s cor = %s" #~ msgstr "Deta2th2[%d]: rdiff = %s korelacja = %s" #~ msgid "Dmu: rdiff = %s cor = %s" #~ msgstr "Dmu: rdiff = %s korelacja = %s" #~ msgid "Dmu2: rdiff = %s cor = %s" #~ msgstr "Dmu2: rdiff = %s korelacja = %s" #~ msgid "Dmu3: rdiff = %s cor = %s" #~ msgstr "Dmu3: rdiff = %s korelacja = %s" #~ msgid "Dmu4: rdiff = %s cor = %s" #~ msgstr "Dmu4: rdiff = %s korelacja = %s" #~ msgid "Dmuth[%d]: rdiff = %s cor = %s" #~ msgstr "Dmuth[%d]: rdiff = %s korelacja = %s" #~ msgid "Dmu2th[%d]: rdiff = %s cor = %s" #~ msgstr "Dmu2th[%d]: rdiff = %s korelacja = %s" #~ msgid "Dmu3th[%d]: rdiff = %s cor = %s" #~ msgstr "Dmu3th[%d]: rdiff = %s korelacja = %s" #~ msgid "Dmu2th2[%d]: rdiff = %s cor = %s" #~ msgstr "Dmu2th2[%d]: rdiff = %s korelacja = %s" # mgcv/R/gam.sim.r: 31 # stop("distribution was not recognised") #~ msgid "distribution was not recognised" #~ msgstr "rozkład nie został rozpoznany" # mgcv/R/gam.sim.r: 35 # gettext("Bivariate smoothing example", domain = "R-mgcv") #~ msgid "Bivariate smoothing example" #~ msgstr "przykład dwuwymiarowego wygładzania" # mgcv/R/gam.sim.r: 50 # gettext("Continuous 'by' variable example", domain = "R-mgcv") #~ msgid "Continuous 'by' variable example" #~ msgstr "Przykład z ciągłą zmienną 'by'" # mgcv/R/gam.sim.r: 60 # gettext("Factor 'by' variable example", domain = "R-mgcv") #~ msgid "Factor 'by' variable example" #~ msgstr "Przykład ze zmienną czynnikową 'by'" # mgcv/R/gam.sim.r: 76 # gettext("Additive model + factor", domain = "R-mgcv") #~ msgid "Additive model + factor" #~ msgstr "Model addytywny + czynnik" # mgcv/R/gamm.r: 131 # warning("NA values in factor of class \"pdTens\"") #~ msgid "NA values in factor of class \"pdTens\"" #~ msgstr "wartości Na w czynniku klasy \"pdTens\"" # mgcv/R/gamm.r: 154 # warning("NA values in matrix of class \"pdTens\"") #~ msgid "NA values in matrix of class \"pdTens\"" #~ msgstr "wartości Na w macierzy klasy \"pdTens\"" # mgcv/R/gamm.r: 176 # gettext("Tensor product smooth term", domain = "R-mgcv") #~ msgid "Tensor product smooth term" #~ msgstr "człon wygładzania produktu tensorowego" # mgcv/R/gamm.r: 338 # stop("No data supplied to gamm.setup") # mgcv/R/gamm.r: 781 # stop("No data supplied to gamm.setup") #~ msgid "No data supplied to 'gamm.setup()'" #~ msgstr "Nie dostarczono danych do 'gamm.setup()'" # mgcv/R/gamm.r: 1506 # gettext("Maximum number of PQL iterations: ", domain = "R-mgcv") #~ msgid "Maximum number of PQL iterations:" #~ msgstr "Maksymalna liczba iteracji PQL:" # mgcv/R/gamm.r: 1746 # gettextf("TEST FAILED: fit.cor = %s",fit.cor, domain = "R-mgcv") #~ msgid "TEST FAILED: fit.cor = %s" #~ msgstr "TEST NIE POWIÓDŁ SIĘ: fit.cor = %s" # mgcv/R/gamm.r: 1747 # gettext("TEST FAILED: edf.diff = %s",edf.diff, domain = "R-mgcv") #~ msgid "TEST FAILED: edf.diff = %s" #~ msgstr "TEST NIE POWIÓDŁ SIĘ: edf.diff = %s" # mgcv/R/gamm.r: 1748 # gettext("TEST PASSED", domain = "R-mgcv") #~ msgid "TEST PASSED" #~ msgstr "TEST PRZESZEDŁ POMYŚLNIE" # mgcv/R/gamm.r: 1754 # gettext("testing covariate scale invariance ... ", domain = "R-mgcv") #~ msgid "testing covariate scale invariance ..." #~ msgstr "testowanie niezależności skali zmiennej objaśniającej ..." # mgcv/R/gamm.r: 1760 # gettext("testing invariance w.r.t. response ... ", domain = "R-mgcv") #~ msgid "testing invariance w.r.t. response ..." #~ msgstr "testowanie niezmienniczości ze względu na zmienną zależną ..." # mgcv/R/gamm.r: 1765 # gettext("testing equivalence of te(x) and s(x) ... ", domain = "R-mgcv") #~ msgid "testing equivalence of te(x) and s(x) ..." #~ msgstr "testowanie równoważności 'te(x)' oraz 's(x)' ..." # mgcv/R/gamm.r: 1770 # gettext("testing equivalence of gam and gamm with same sp ... ", domain = "R-mgcv") #~ msgid "testing equivalence of gam and gamm with same sp ..." #~ msgstr "testowanie równoważności 'gam' oraz 'gamm' z tym samym sp ..." # mgcv/R/mgcv.r: 561 # stop("No data supplied to gam.setup") #~ msgid "No data supplied to 'gam.setup()'" #~ msgstr "Nie dostarczono danych do 'gam.setup()'" mgcv/po/R-ko.po0000644000177400001440000012022513046052674013177 0ustar murdochusers# Korean translations for mgcv package. # Recommended/mgcv/po/R-ko.po # Maintainer: Simon Wood # # This file is distributed under the same license as the R mgcv package. # Chel Hee Lee , 2013-2015. # # Reviewing process is in progress (06-FEB-2015) # The original source code review is in progress (06-FEB-2015) # QC: PASS # Freezing on 06-FEB-2015 for R-3.1.3 # msgid "" msgstr "" "Project-Id-Version: R 3.1.3\n" "Report-Msgid-Bugs-To: bugs.r-project.org\n" "POT-Creation-Date: 2017-02-06 09:59\n" "PO-Revision-Date: 2015-02-21 16:01-0600\n" "Last-Translator:Chel Hee Lee \n" "Language-Team: Chel Hee Lee \n" "Language: ko\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=1; plural=0;\n" msgid "bam can not discretize with this nesting structure" msgstr "" msgid "discretization can not handle smooth ids" msgstr "" msgid "'family' argument seems not to be a valid family object" msgstr "'family' 인자는 올바른 family 객체가 아닌 것 같이 보입니다." msgid "cannot find valid starting values: please specify some" msgstr "사용가능한 초기값을 찾을 수 없습니다. 값을 지정해 주시길 바랍니다." msgid "Deviance = %s Iterations - %d" msgstr "편차(deviance)= %s 반복(iterations) - %d" msgid "Non-finite deviance" msgstr "편차(deviance)가 유한(finite)한 값을 가지지 않습니다." msgid "non-finite coefficients at iteration %d" msgstr "" "%d번째 반복에서 얻어진 계수(coefficients)가 유한(finite)한 값을 가지지 않습니" "다." msgid "algorithm did not converge" msgstr "알고리즘이 수렴하지 않습니다." msgid "fitted probabilities numerically 0 or 1 occurred" msgstr "적합된 확률값이 수치적으로 0 또는 1 입니다." msgid "fitted rates numerically 0 occurred" msgstr "적합된 비율(rates)가 수치적으로 0입니다." msgid "Too many cluster nodes to use all efficiently" msgstr "" msgid "iterms reset to terms" msgstr "" msgid "exclude ignored by discrete prediction at present" msgstr "" msgid "family not recognized" msgstr "family에 대한 정보를 찾을 수 없습니다." msgid "extended families not supported by bam" msgstr "" msgid "un-supported smoothness selection method" msgstr "지원되지 않는 평활화 선택법(smoothness selection method)입니다." msgid "discretization only available with fREML" msgstr "" msgid "discrete method does not use parallel cluster - use nthreads instead" msgstr "" msgid "min.sp not supported with fast REML computation, and ignored." msgstr "" "fREML(fast REML 연산)을 method로 선택한 경우 min.sp는 사용되지 않습니다." msgid "Not enough (non-NA) data to do anything meaningful" msgstr "" "어떤 의미있는 작업을 하기에는 NA가 아닌 데이터의 개수가 충분하지 않습니다." msgid "AR.start must be logical" msgstr "AR.start는 반드시 논리형(logical)이어야 합니다." msgid "chunk.size < number of coefficients. Reset to %d" msgstr "" msgid "unknown tensor constraint type" msgstr "" msgid "Model has more coefficients than data" msgstr "모형(model)이 가진 계수(coefficients)가 데이터의 개수보다 많습니다." msgid "AR1 parameter rho unused with generalized model" msgstr "" msgid "samfrac too small - ignored" msgstr "samfrac의 값이 너무 작기 때문에 이용되지 않습니다." msgid "Model can not be updated" msgstr "모델을 업데이트할 수 없습니다." msgid "link not available for coxph family; available link is \"identity\"" msgstr "" "coxph 페밀리(family)에 사용할 수 있는 링크(link)가 아닙니다. 사용가능한 링크" "(link)는 \"identity\"입니다." msgid "NA times supplied for cox.ph prediction" msgstr "" msgid "cox.ph does not yet handle offsets" msgstr "" msgid "" "link not available for ordered categorical family; available links are " "\"identity\"" msgstr "" "순서범주형 페밀리(ordered categorical family)에 사용할 수 있는 링크(link)가 " "아닙니다. 사용가능한 링크(link)는 \"identity\"입니다." msgid "Must supply theta or R to ocat" msgstr "theta 또는 R을 ocat에 제공해주어야 합니다." msgid "Response should be integer class labels" msgstr "" msgid "values out of range" msgstr "범위 외의 값을 가집니다." msgid "" "link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" "음이항분포 페밀리(negative binomial family)에 사용할 수 없는 링크(link)입니" "다. 사용가능한 링크(link)에는 \"identity\", \"log\" 그리고 \"sqrt\"가 있습니" "다." msgid "negative values not allowed for the negative binomial family" msgstr "" "음이항분포 페밀리(negative binomial family)에 음의 값은 사용할 수 없습니다." msgid "link \"%s\" not available for Tweedie family." msgstr "" "트위디 페밀리(tweedie family)에 링크(link) \"%s\"는 사용할 수 없습니다." msgid "Tweedie p must be in interval (a,b)" msgstr "트위디(tweedie) p는 반드시 구간 (a,b)내에 존재해야 합니다." msgid "" "link not available for beta regression; available links are \"logit\", " "\"probit\", \"cloglog\" and \"cauchit\"" msgstr "" "베타회귀(beta regression)에 사용할 수 있는 링크(link)가 아닙니다. 사용가능" "한 링크(link)에는 \"logit\", \"probit\", \"cloglog\" 그리고 \"cauchit\"가 있" "습니다. " msgid "saturated likelihood may be inaccurate" msgstr "" msgid "" "link not available for scaled t distribution; available links are \"identity" "\", \"log\", and \"inverse\"" msgstr "" "스케일드 t 분포(scaled t distribution)에 사용할 수 있는 링크(link)가 아닙니" "다. 사용가능한 링크(link)에는 \"identity\", \"log\", 그리고 \"inverse\"가 있" "습니다." msgid "scaled t df must be >2" msgstr "스케일드 t 분포(scaled t)의 자유도(df)는 2보다 커야합니다." msgid "NA values not allowed for the scaled t family" msgstr "스케일드 t 페밀리(scaled t family)에는 NA 값을 사용할 수 없습니다." msgid "" "link not available for zero inflated; available link for `lambda' is only " "\"loga\"" msgstr "" "영과잉(zero inflated)모형에 사용할 수 있는 링크(link)가 아닙니다. " "`lambda'에 사용할 수 있는 링크(link)는 오로지 \"loga\"입니다." msgid "negative values not allowed for the zero inflated Poisson family" msgstr "" "영과잉 포아송 페밀리(zero inflated Poisson family)에는 음의 값을 사용할 수 없" "습니다." msgid "Non-integer response variables are not allowed with ziP" msgstr "" msgid "Using ziP for binary data makes no sense" msgstr "" msgid "Possible divergence detected in fast.REML.fit" msgstr "" msgid "fast REML optimizer reached iteration limit" msgstr "" msgid "Huber scale estiamte not converged" msgstr "" msgid "unsupported order of differentiation requested of gam.fit3" msgstr "" msgid "illegal `family' argument" msgstr "`family' 인자의 값이 올바르지 않습니다." msgid "Invalid linear predictor values in empty model" msgstr "" msgid "Invalid fitted means in empty model" msgstr "" msgid "Length of start should equal %d and correspond to initial coefs for %s" msgstr "" "start의 길이는 %d와 같아야 하며 %s에 대응하는 계수의 초기값을 가지고 있어야 " "합니다." msgid "Can't find valid starting values: please specify some" msgstr "사용가능한 초기값을 찾을 수 없습니다. 값을 정해주시길 바랍니다." msgid "NAs in V(mu)" msgstr "V(mu)에서 NA가 발견되었습니다." msgid "0s in V(mu)" msgstr "V(mu)에서 0이 발견되었습니다." msgid "NAs in d(mu)/d(eta)" msgstr "d(mu)/d(eta)로부터 NA가 발견되었습니다." msgid "No observations informative at iteration %d" msgstr "" msgid "Not enough informative observations." msgstr "" msgid "Non-finite coefficients at iteration %d" msgstr "%d번째 반복에서 얻은 계수의 추정치가 유한(finite)하지 않습니다." msgid "" "no valid set of coefficients has been found:please supply starting values" msgstr "" msgid "Step size truncated due to divergence" msgstr "" msgid "inner loop 1; can't correct step size" msgstr "" msgid "Step size truncated: out of bounds" msgstr "" msgid "inner loop 2; can't correct step size" msgstr "" msgid "penalized deviance = %s" msgstr "" msgid "inner loop 3; can't correct step size" msgstr "" msgid "Step halved: new penalized deviance = %g" msgstr "" msgid "" "Non finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" msgid "" "Non-finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" msgid "Algorithm did not converge" msgstr "알고리즘이 수렴하지 않았습니다." msgid "Algorithm stopped at boundary value" msgstr "알고리즘이 경계값(boundary value)에서 멈추었습니다." msgid "deriv should be 1 or 2" msgstr "deriv의 값은 1 또는 2이어야 합니다." msgid "L must be a matrix." msgstr "L은 반드시 행렬(matrix)이어야 합니다." msgid "L must have at least as many rows as columns." msgstr "L이 가지고 있는 행의 개수는 적어도 열의 개수만큼 있어야 합니다." msgid "L has inconsistent dimensions." msgstr "" msgid "Fitting terminated with step failure - check results carefully" msgstr "" msgid "Iteration limit reached without full convergence - check carefully" msgstr "" msgid "link not implemented for extended families" msgstr "본 페밀리(family)에 사용가능한 링크(link)가 없습니다." msgid "fam not a family object" msgstr "fam은 family라는 클래스를 가진 객체가 아닙니다." msgid "unrecognized (vector?) link" msgstr "알 수 없는 (벡터 또는) 링크입니다." msgid "link not recognised" msgstr "알 수 없는 링크(link)입니다." msgid "variance function not recognized for quasi" msgstr "" "family에 quasi가 주어진 경우에 사용되어야 하는 분산함수(variance function)을 " "찾을 수 없습니다." msgid "family not recognised" msgstr "family에 알 수 없는 값이 입력되었습니다." msgid "'theta' must be specified" msgstr "'theta'의 값은 반드시 주어져야 합니다." msgid "" "%s link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" "%s는 음이항분포 페밀리(negative binomial family)에 사용할 수 있는 링크(link)" "가 아닙니다. 사용가능한 링크들에는 \"identity\", \"log\" 그리고 \"sqrt\"가 " "있습니다." msgid "H has wrong dimension" msgstr "H의 열과 행의 길이가 같아야 합니다." msgid "only scalar `rho' and `theta' allowed." msgstr "`rho'와 `theta'는 오로지 스칼라(scalar) 값만을 가질 수 있습니다." msgid "1 0" msgstr "epsilon의 값은 반드시 0 보다 커야 합니다." msgid "maximum number of iterations must be > 0" msgstr "최대 반복수(iteration)는 반드시 0 보다 커야 합니다." msgid "" "silly value supplied for rank.tol: reset to square root of machine precision." msgstr "" "rank.tol에 주어진 값은 올바르지 않습니다: reset to square root of machine " "precision." msgid "Model seems to contain no terms" msgstr "모델이 아무런 항(term)도 포함하지 않는 것 같습니다." msgid "Discrete Theta search not available with performance iteration" msgstr "" msgid "y must be univariate unless binomial" msgstr "" msgid "Length of start should equal %d and correspond to initial coefs." msgstr "" msgid "" "iterative weights or data non-finite in gam.fit - regularization may help. " "See ?gam.control." msgstr "" msgid "Step size truncated: out of bounds." msgstr "" msgid "`object' is not of class \"gam\"" msgstr "`object'는 클래스 \"gam\"가 아닙니다." #, fuzzy msgid "unrecognised na.action" msgstr "알 수 없는 (벡터 또는) 링크입니다." msgid "na.action not character or function" msgstr "" msgid "Smoothness uncertainty corrected covariance not available" msgstr "" msgid "Unknown type, reset to terms." msgstr "" msgid "predict.gam can only be used to predict from gam objects" msgstr "" msgid "newdata is a model.frame: it should contain all required variables" msgstr "" "newdata는 model.frame이므로 필요한 모든 변수들을 포함하고 있어야 합니다." msgid "not all required variables have been supplied in newdata!" msgstr "필요한 모든 변수들을 newdata로부터 찾을 수 없습니다!" msgid "type iterms not available for multiple predictor cases" msgstr "" msgid "non-existent terms requested - ignoring" msgstr "" msgid "non-existent exclude terms requested - ignoring" msgstr "" msgid "requires an object of class gam" msgstr "클래스 gam으로부터 얻어진 객체가 필요합니다." msgid "nothing to do for this model" msgstr "" msgid "" "Pearson residuals not available for this family - returning deviance " "residuals" msgstr "" "이 페밀리(family)에서는 피어슨 잔차(Pearson residuals)를 얻을 수 없어 이탈잔" "차(deviance residuals)를 구합니다." msgid "lambda and h should have the same length!" msgstr "lambda와 h 모두 같은 길이를 가져야 합니다." msgid "recov works with fitted gam objects only" msgstr "recov 함수는 오로지 적합된 gam 객체만을 사용합니다." msgid "m can't be in re" msgstr "m은 re 내에 있을 수 없습니다." msgid "p-values may give low power in some circumstances" msgstr "" msgid "p-values un-reliable" msgstr "" msgid "p-values may give very low power" msgstr "" msgid "" "p-values for any terms that can be penalized to zero will be unreliable: " "refit model to fix this." msgstr "" msgid "p.type!=0 is deprecated, and liable to be removed in future" msgstr "" msgid "The following arguments to anova.glm(..) are invalid and dropped:" msgstr "다음의 인자들은 anova.glm(..)에 유효하지 않으므로 사용되지 않습니다: " msgid "," msgstr "," msgid "un-supported test" msgstr "" msgid "test argument ignored" msgstr "" msgid "anova.gam called with non gam object" msgstr "" msgid "not a gam object" msgstr "객체의 클래스가 gam이 아닙니다." msgid "argument is not a gam object" msgstr "인자의 클래스가 gam이 아닙니다." msgid "S.scale vector doesn't match S list - please report to maintainer" msgstr "" msgid "Supplied matrix not symmetric" msgstr "입력된 행렬은 대칭(symmetric)이 아닙니다." msgid "singular values not returned in order" msgstr "" msgid "Something wrong - matrix probably not +ve semi definite" msgstr "" msgid "method not recognised." msgstr "알 수 없는 method입니다." msgid "S[[%d]] matrix is not +ve definite." msgstr "" msgid "dimensions of supplied w wrong." msgstr "입력된 w의 차원(dimensions)가 올바르지 않습니다." msgid "w different length from y!" msgstr "w의 길이가 y의 길이와 다릅니다!" msgid "X lost dimensions in magic!!" msgstr "" #, fuzzy msgid "mu dimensions wrong" msgstr "fx의 차원(dimension)이 올바르지 않습니다." #, fuzzy msgid "something wrong with inputs to LAPACK routine" msgstr "zlim이 올바르지 않습니다." msgid "not positive definite" msgstr "" msgid "don't be silly" msgstr "" msgid "sd should have exactly one less entry than ld" msgstr "" msgid "internal error in vcorr, please report to simon.wood@r-project.org" msgstr "" msgid "a has wrong number of rows" msgstr "a가 가진 행의 개수가 올바르지 않습니다." msgid "mvn requires 2 or more dimensional data" msgstr "mvn은 둘 이상의 차원을 가진 데이터를 필요로 합니다." msgid "mvn does not yet handle offsets" msgstr "" msgid "mvn dimension error" msgstr "" msgid "object is not a glm or gam" msgstr "object의 클래스가 glm 또는 gam이 아닙니다." msgid "names of z and pc must match" msgstr "" "z의 구성요소에 주어진 이름들과 pc의 구성요소에 주어진 이름들은 반드시 서로 일" "치해야 합니다." msgid "" "Partial residuals do not have a natural x-axis location for linear " "functional terms" msgstr "" msgid "no automatic plotting for smooths of more than two variables" msgstr "" msgid "no automatic plotting for smooths of more than one variable" msgstr "" msgid "residuals argument to plot.gam is wrong length: ignored" msgstr "" "plot.gam에 전달되는 인자 residuals의 길이가 올바르지 않아 무시되었습니다. " msgid "No variance estimates available" msgstr "사용할 수 있는 분산의 추정치를 찾을 수 없습니다." msgid "No terms to plot - nothing for plot.gam() to do." msgstr "" msgid "grid vectors are different lengths" msgstr "그리드 벡터(grid vectors) g1과 g2의 길이가 서로 다릅니다." msgid "data vectors are of different lengths" msgstr "데이터 벡터(data vectors) d1과 d2의 길이가 서로 다릅니다." msgid "supplied dist negative" msgstr "입력된 dist에서 음수가 발견되었습니다." msgid "Model does not seem to have enough terms to do anything useful" msgstr "" msgid "view variables must be one of %s" msgstr "view 변수들은 반드시 %s 중에 하나 이어야 합니다." msgid "" "Don't know what to do with parametric terms that are not simple numeric or " "factor variables" msgstr "" msgid "View variables must contain more than one value. view = c(%s,%s)." msgstr "" msgid "type must be \"link\" or \"response\"" msgstr "type은 반드시 \"link\" 또는 \"response\"이어야 합니다." msgid "Something wrong with zlim" msgstr "zlim이 올바르지 않습니다." msgid "color scheme not recognised" msgstr "알 수 없는 색상표(color scheme)입니다." msgid "sorry no option for contouring with errors: try plot.gam" msgstr "" msgid "At least three knots required in call to mono.con." msgstr "mono.con을 호출하기 위해서는 최소한 세개의 노트(knots)가 필요합니다." msgid "lower bound >= upper bound in call to mono.con()" msgstr "" "mono.con()함수에 전달된 lower 인자의 값이 upper 인자의 값보다 크거나 같습니" "다." msgid "x is null" msgstr "x는 아무런 구성요소도 가지고 있지 않습니다." msgid "uniquecombs has not worked properly" msgstr "" msgid "order too low" msgstr "" msgid "too few knots" msgstr "노트(knots)의 개수 nk가 너무 작은 값을 가집니다." msgid "x out of range" msgstr "x가 범위 밖에 놓여 있습니다." msgid "something wrong with argument d." msgstr "" msgid "one or more supplied k too small - reset to default" msgstr "" msgid "dimension of fx is wrong" msgstr "fx의 차원(dimension)이 올바르지 않습니다." msgid "xt argument is faulty." msgstr "인자 xt가 올바르지 않습니다." msgid "bs wrong length and ignored." msgstr "bs의 길이가 올바르지 않아 사용되지 않습니다." msgid "m wrong length and ignored." msgstr "m의 길이가 올바르지 않아 사용되지 않습니다." msgid "Repeated variables as arguments of a smooth are not permitted" msgstr "" msgid "only first element of `id' used" msgstr "`id'의 첫번째 요소만이 사용되었습니다." msgid "supply a value for each variable for a point constraint" msgstr "" msgid "ord is wrong. reset to NULL." msgstr "ord가 올바르지 않아 NULL로 설정합니다." msgid "ord contains out of range orders (which will be ignored)" msgstr "" msgid "by=. not allowed" msgstr "by=.는 사용할 수 없습니다." msgid "s(.) not yet supported." msgstr "s(.)는 아직 지원되지 않습니다." msgid "argument k of s() should be integer and has been rounded" msgstr "s()의 인자 k는 반드시 정수이어야 하므로 반올림되었습니다." msgid "attempt to use unsuitable marginal smooth class" msgstr "" msgid "" "Sorry, tensor products of smooths with multiple penalties are not supported." msgstr "" msgid "reparameterization unstable for margin: not done" msgstr "" msgid "" "single penalty tensor product smooths are deprecated and likely to be " "removed soon" msgstr "" msgid "basis not usable with reduced te" msgstr "" msgid "fx length wrong from t2 term: ignored" msgstr "" msgid "length of sp incorrect in t2: ignored" msgstr "" msgid "d can not be negative in call to null.space.dimension()." msgstr "null.space.dimension()에 지정된 인자 d는 음수를 가질 수 없습니다." msgid "arguments of smooth not same dimension" msgstr "" msgid "components of knots relating to a single smooth must be of same length" msgstr "" msgid "more knots than data in a tp term: knots ignored." msgstr "" msgid "basis dimension, k, increased to minimum possible" msgstr "" msgid "no data to predict at" msgstr "" msgid "Basis only handles 1D smooths" msgstr "" msgid "number of supplied knots != k for a cr smooth" msgstr "" msgid "F is missing from cr smooth - refit model with current mgcv" msgstr "" msgid "more knots than unique data values is not allowed" msgstr "" msgid "number of supplied knots != k for a cc smooth" msgstr "" msgid "basis dimension too small for b-spline order" msgstr "" msgid "knot range does not include data" msgstr "" msgid "there should be" msgstr "" msgid "supplied knots" msgstr "" msgid "knots supplied" msgstr "" msgid "" "knot range is so wide that there is *no* information about some basis " "coefficients" msgstr "" msgid "penalty order too high for basis dimension" msgstr "" msgid "there is *no* information about some basis coefficients" msgstr "" msgid "basis dimension is larger than number of unique covariates" msgstr "" msgid "requested non-existent derivative in B-spline penalty" msgstr "" msgid "fs smooths can only have one factor argument" msgstr "" msgid "\"fs\" smooth cannot use a multiply penalized basis (wrong basis in xt)" msgstr "" #, fuzzy msgid "no factor supplied to fs smooth" msgstr "gam.setup에 이용될 데이터가 없습니다." msgid "\"fs\" terms can not be fixed here" msgstr "" msgid "" "fs smooth not suitable for discretisation with more than one metric predictor" msgstr "" msgid "the adaptive smooth class is limited to 1 or 2 covariates." msgstr "" msgid "penalty basis too large for smoothing basis" msgstr "" msgid "penalty basis too small" msgstr "" msgid "random effects don't work with ids." msgstr "" msgid "" "Please put term with most levels last in 're' to avoid spoiling supplied " "penalties" msgstr "" #, fuzzy msgid "supplied S matrices are wrong diminsion" msgstr "H의 열과 행의 길이가 같아야 합니다." #, fuzzy msgid "argument of mrf should be a factor variable" msgstr "s()의 인자 k는 반드시 정수이어야 하므로 반올림되었습니다." msgid "MRF basis dimension set too high" msgstr "" msgid "data contain regions that are not contained in the knot specification" msgstr "" msgid "" "penalty matrix, boundary polygons and/or neighbours list must be supplied in " "xt" msgstr "" msgid "no spatial information provided!" msgstr "" msgid "mismatch between nb/polys supplied area names and data area names" msgstr "" msgid "Something wrong with auto- penalty construction" msgstr "" msgid "supplied penalty not square!" msgstr "" msgid "supplied penalty wrong dimension!" msgstr "" msgid "penalty column names don't match supplied area names!" msgstr "" msgid "Can only deal with a sphere" msgstr "" msgid "more knots than data in an sos term: knots ignored." msgstr "" msgid "more knots than data in a ds term: knots ignored." msgstr "" msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" msgid "s value reduced" msgstr "" msgid "s value increased" msgstr "" msgid "No suitable s (i.e. m[2]) try increasing m[1]" msgstr "" msgid "s value modified to give continuous function" msgstr "" msgid "basis dimension reset to minimum possible" msgstr "" msgid "incorrect arguments to GP smoother" msgstr "" msgid "more knots than data in an ms term: knots ignored." msgstr "" msgid "smooth objects should not have a qrc attribute." msgstr "" msgid "unimplemented sparse constraint type requested" msgstr "" msgid "" "handling `by' variables in smooth constructors may not work with the " "summation convention" msgstr "" msgid "Can't find by variable" msgstr "by 변수(variable)를 찾을 수 없습니다." msgid "" "sweep and drop constraints unlikely to work well with self handling of by " "vars" msgstr "" msgid "factor `by' variables can not be used with matrix arguments." msgstr "" msgid "`by' variable must be same dimension as smooth arguments" msgstr "" msgid "Number of prediction and fit constraints must match" msgstr "" msgid "x and y must be same length" msgstr "x의 길이와 y의 길이는 반드시 같아야 합니다." msgid "variable names don't match boundary names" msgstr "" msgid "x and y not same length" msgstr "x의 길이가 y의 길이와 같지 않습니다." msgid "bnd must be a list." msgstr "bnd는 반드시 리스트(list)이어야 합니다." msgid "lengths of k and bnd are not compatible." msgstr "k의 길이와 bnd의 길이가 서로 일치하지 않습니다." msgid "attempt to select non existent basis function" msgstr "" msgid "coefficient vector wrong length" msgstr "" msgid "knots must be specified for soap" msgstr "" msgid "soap films are bivariate only" msgstr "" msgid "need at least one interior knot" msgstr "최소한 하나 이상의 내부 노트(interior knot)가 필요합니다." msgid "can't soap smooth without a boundary" msgstr "" msgid "bnd must be a list of boundary loops" msgstr "" msgid "faulty bnd" msgstr "" msgid "k and bnd lengths are inconsistent" msgstr "k와 bnd의 길이가 서로 일치하지 않습니다." msgid "data outside soap boundary" msgstr "" msgid "no free coefs in sf smooth" msgstr "" msgid "only deals with 2D case" msgstr "2차원(2D)인 경우만을 다룰 수 있습니다." msgid "not enough unique values to find k nearest" msgstr "" msgid "cubic spline only deals with 1D data" msgstr "" "삼차 스플라인(cubic spline)은 오로지 1차원 데이터(1D data)만을 다룹니다." msgid "object not fully initialized" msgstr "완전히 초기화된 object가 아닙니다." #~ msgid "non-finite coefficients at iteration" #~ msgstr "" #~ "다음의 반복단계에서 얻어진 계수(coefficients)의 값이 유한(finite)하지 않습" #~ "니다." #~ msgid "sparse=TRUE not supported with fast REML, reset to REML." #~ msgstr "" #~ "sparse=TRUE인 경우 method는 fREML(fast REML)을 사용할 수 없으므로 REML을 " #~ "사용합니다." #~ msgid "Pearson scale estimate maybe unstable. See ?gam.scale." #~ msgstr "" #~ "피어슨 척도 (Pearson scale)에 대한 추정치가 안정적(stable)이지 않은 것 같" #~ "습니다. ?gam.scale을 확인해 보시길 바랍니다." #~ msgid "nlm.fd not available with negative binomial Theta estimation" #~ msgstr "nlm.fd 방법은 음이항분포의 Theta 추정에 사용할 수 없습니다." #~ msgid "" #~ "only outer methods `newton' & `bfgs' supports `negbin' family and theta " #~ "selection: reset" #~ msgstr "" #~ "오로지 `newton'와 `bfgs' 방법만이 `negbin' 페밀리와 theta 선택에 사용될 " #~ "수 있습니다: reset" #~ msgid "x has no row attribute" #~ msgstr "x는 행속성(row attribute)를 가지고 있지 않습니다." #~ msgid "x has no col attribute" #~ msgstr "x는 열속성(col attribute)를 가지고 있지 않습니다." mgcv/inst/0000755000177400001440000000000013020254562012354 5ustar murdochusersmgcv/inst/po/0000755000177400001440000000000012506730517013001 5ustar murdochusersmgcv/inst/po/pl/0000755000177400001440000000000012475145647013425 5ustar murdochusersmgcv/inst/po/pl/LC_MESSAGES/0000755000177400001440000000000013046052673015201 5ustar murdochusersmgcv/inst/po/pl/LC_MESSAGES/mgcv.mo0000644000177400001440000000505312765741176016507 0ustar murdochusers<X- %8^'q,! "  , 8EY+@G T#hs(=0n74 */Z6xJ.`) Q  1     A term has fewer unique covariate combinations than specified maximum degrees of freedomAn out of bound write to matrix has occurred!Attempt to invert() non-square matrixERROR in addconQT.Failed to initialize memory for matrix.INTEGRITY PROBLEM in the extant matrix list.Incompatible matrices in matmult.QPCLS - Rank deficiency in modelSingular Matrix passed to invert()Sort failedTarget matrix too small in mcopyYou are trying to check matrix integrity without defining RANGECHECK.You must have 2m>d for a thin plate spline.magic requires smoothing parameter starting values if L suppliedmagic, the gcv/ubre optimizer, failed to converge after 400 iterations.svd() not convergedsvdroot matrix not +ve semi def. %gProject-Id-Version: mgcv 1.7-28 Report-Msgid-Bugs-To: POT-Creation-Date: 2016-08-19 13:28+0100 PO-Revision-Date: 2014-03-24 17:59+0100 Last-Translator: Łukasz Daniel Language-Team: Łukasz Daniel Language: pl_PL MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=3; plural=(n==1 ? 0 : n%10>=2 && n%10<=4 && (n%100<10 || n%100>=20) ? 1 : 2); X-Poedit-SourceCharset: iso-8859-1 X-Generator: Poedit 1.5.4 Człon posiada mniej unikalnych kombinacji zmiennych niezależnych niż określona maksymalna liczba stopni swobodyNastąpił zapis poza zakresem macierzy!Próba odwrócenia metodą 'invert()' niekwadratowej macierzyBŁĄD w addconQT.Nie udało się zainicjalizować pamięci dla macierzy.PROBLEM SPÓJNOŚCI w istniejącej liście macierzy.Niespójne macierze w 'matmult'.QPCLS - Niedobór rang w modeluPrzekazano osobliwą macierz do 'invert()'Sortowanie nie powiodło sięDocelowa macierz jest zbyt mała, aby wykonać 'mcopy'Próbujesz sprawdzić integralność macierzy bez określania 'RANGECHECK'Musisz mieć 2m>d dla cienkiej płyty splajnu.'magic' wymaga wartości startowych dla parametru wygładzającego jeśli L zostało dostarczone'magic', omptymalizator gcv/ubre, nie zdodał uzbieżnić się po 400 iteracjach.'svd()' nie uzbieżnił sięmacierz 'svdroot' nie jest dodatnio określona %gmgcv/inst/po/pl/LC_MESSAGES/R-mgcv.mo0000644000177400001440000007763013046052673016706 0ustar murdochusersul@EA 7  "X//#2 >4\*5%7C6{<7'>E[;%B:X#."(-<[j$* 3T>m%!9N^t7 # % -D 0r  S $!S%b>/>> >8>0?G?V?!s?1??:?@ (@!6@(X@.@@"@&@ A:(AcA)A*AA5A&B8BTB lBvBB5B/B$C'CR;E,EHE%F*F,F;FWFswF8F$G0BGsGXG7G?H;XH"H%HNH!,IDNI@INIB#JfJGJoJJN[4[>[$\&\A=\\)\N\-] @]da]@]X^F`^^&^!^ _4(_]_/}_'_H_/`N`n`7``L`="a=`a9aRa+bbP9cXc&cf dqd/dOd9eJIe9e9e9ffBf'f!fcf)Wgg?g$g4gh(8hxah$hPh-Pi@~i(i+ijV3j[jAjK(kKtkLkM l([lll3lBlQ-m,mLmMm4Gn0|n)n[n33o&go@o=o p.pKpfp9p9p&p9q,TqWq0q, rU7r+r+r@r9&s$`s)s)ss<^t(ttt6t1uCNuXu.uZv.uv$v&vDv&5wQ\w#w<w#x)3x']x x)xnxD?y1y#yyIy$Bzgz%iz'zEz#zD!{3f{{1{'{6 |@|)W|&|'|B|!}35}3i}8}9} ~*~+H~t~~~W~<<[S z@^hskp< e27C 3&TZFoWx4\.u8`t'?f:Rdn,m-)>; r16M+Q#BvgAHI $ 5L~YiG D=qb]y w*9O/ N0XlV[j ({%}!JcP|K _"EaU"fs" smooth cannot use a multiply penalized basis (wrong basis in xt)"fs" terms can not be fixed here'family' argument seems not to be a valid family object'theta' must be specified,0s in V(mu)1= upper bound in call to mono.con()m can't be in rem wrong length and ignored.maximum number of iterations must be > 0mean, mu, must be non negativemethod not recognised.min.sp not supported with fast REML computation, and ignored.mismatch between nb/polys supplied area names and data area namesmodel has repeated 1-d smooths of same variable.more knots than data in a ds term: knots ignored.more knots than data in a tp term: knots ignored.more knots than data in an sos term: knots ignored.more knots than unique data values is not allowednames of z and pc must matchncol(M$C) != length(M$p)ncol(M$X) != length(M$p)need at least one interior knotnegative values not allowed for the negative binomial familynewdata is a model.frame: it should contain all required variablesnlm.fd only available for GCV/UBREno automatic plotting for smooths of more than one variableno automatic plotting for smooths of more than two variablesno data to predict atno free coefs in sf smoothno spatial information provided!no valid set of coefficients has been found:please supply starting valuesnon-existent terms requested - ignoringnot a gam objectnot all required variables have been supplied in newdata!not enough unique values to find k nearestnothing to do for this modelnrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)number of supplied knots != k for a cc smoothnumber of supplied knots != k for a cr smoothobject does not appear to be of class lmeobject is not a glm or gamobject not fully initializedone or more supplied k too small - reset to defaultonly deals with 2D caseonly first element of `id' usedonly one level of smooth nesting is supported by gammonly scalar `p' and `phi' allowed.only scalar `rho' and `theta' allowed.ord contains out of range orders (which will be ignored)ord is wrong. reset to NULL.order too lowp must be in (1,2)p must be in [1,2]p-values for any terms that can be penalized to zero will be unreliable: refit model to fix this.p-values may give low power in some circumstancesp-values may give very low powerp-values un-reliablepenalized deviance = %spenalty basis too large for smoothing basispenalty basis too smallpenalty column names don't match supplied area names!penalty matrix, boundary polygons and/or neighbours list must be supplied in xtpenalty order too high for basis dimensionpredict.gam can only be used to predict from gam objectsrandom argument must be a *named* list.random effects don't work with ids.recov works with fitted gam objects onlyreparameterization unstable for margin: not donerequires an object of class gamresiduals argument to plot.gam is wrong length: ignoreds value increaseds value modified to give continuous functions value reduceds(.) not yet supported.samfrac too small - ignoredscale parameter must be positivesilly tolerance suppliedsilly value supplied for rank.tol: reset to square root of machine precision.singular values not returned in ordersmooth objects should not have a qrc attribute.soap films are bivariate onlysomething wrong with argument d.sorry no option for contouring with errors: try plot.gamsupplied dist negativesupplied knotssupplied penalty not square!supplied penalty wrong dimension!te smooths not useable with gamm4: use t2 insteadtest argument ignoredthe adaptive smooth class is limited to 1 or 2 covariates.there should betoo few knotstype must be "link" or "response"un-supported smoothness selection methodunimplemented sparse constraint type requestedunknown optimizerunknown outer optimization method.unknown smoothness selection criterionunrecognized (vector?) linkunsupported order of differentiation requested of gam.fit3value of epsilon must be > 0variable names don't match boundary namesvariance function not recognized for quasiw different length from y!weights must be like glm weights for generalized casewithout a formulax and y must be same lengthx and y not same lengthx is nullx out of rangext argument is faulty.y must be an integer multiple of phi for Tweedie(p=1)y must be strictly positive for a Gamma densityy must be univariate unless binomialProject-Id-Version: mgcv 1.7-28 Report-Msgid-Bugs-To: bugs@r-project.org POT-Creation-Date: 2017-02-06 09:59 PO-Revision-Date: 2014-03-25 17:39+0100 Last-Translator: Łukasz Daniel Language-Team: Łukasz Daniel Language: pl_PL MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=3; plural=(n==1 ? 0 : n%10>=2 && n%10<=4 && (n%100<10 || n%100>=20) ? 1 : 2); X-Poedit-SourceCharset: iso-8859-1 X-Generator: Poedit 1.5.4 wygładzanie "fs" nie może użyć wielokrotnie ukaranej bazy (błędna baza w xt)człony "fs" nie mogą być poprawione tutajargument 'family' wydaje się nie być poprawnym obiektem klasy "family"argument 'theta' musi być określony,zera w 'V(mu)'1= górny zakres w wywołaniu przekazywanym do funkcji 'mono.con()'argument 'm' nie może być w argumencie 're''m' posiada niepoprawną długość przez co został zignorowanymaksymalna liczba iteracji musi być > 0średnia wartość 'mu' musi być nieujemnametoda nie została rozpoznana'min.sp' nie jest wspierane dla szybkich obliczeń REML, parametr został zignorowany.niezgodność pomiędzy dostarczonymi nazwami obszarów nb/polys a nazwami obszarów danychmodel powtórzył jednowymiarowe wygładzania tej samiej zmiennejwięcej węzłów niż danych w członie 'ds': węzły zostały zignorowanewięcej węzłów niż danych w członie 'tp': węzły zostały zignorowanewięcej węzłów niż danych w członie 'sos': węzły zostały zignorowanewiększa liczba węzłów niż unikalnych wartości danych nie jest dozwolonanazwy 'z' oraz 'pc' muszą się zgadzaćncol(M$C) != length(M$p)ncol(M$X) != length(M$p)potrzeba przynajmniej jednego wewnętrznego węzłaujemne wartości nie są dozwolone dla rozkładu z rodziny Pascala"newdata" jest klasy "model.frame": powinien zawierać wszystkie wymagane zmienne'nlm.fd' jest dostępne jedynie dla GCV/UBREbrak automatycznego rysowania dla wygładzeń o więcej niż jednej zmiennejbrak automatycznego rysowania dla wygładzeń o więcej niż dwóch zmiennychbrak danych na których można oprzeć przewidywaniebrak wolnych współczynników w wygładzaniu sfnie dostarczono informacji przestrzennej!nie znaleziono poprawnego zestawu współczynników: proszę dostarczyć wartości startowezażądano nieistniejących członów - ignorowanieargument nie jest obiektem klasy "gam"nie wszystkie wymagane zmienne zostały dostarczone w "newdata"!zbyt mało unikalnych wartości aby znaleźć k najbliższychnic do zrobienia dla tego modelunrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)liczba dostarczonych węzłów != k dla wygładzania 'cc'liczba dostarczonych węzłów != k dla wygładzania 'cr'argument nie jest obiektem klasy "lme"argument 'object' nie jest obiektem klasy "glm" lub "gam"obiekt nie został w pełni zainicjalizowanyjeden lub więcej dostarczonych 'k' jest zbyt mały - przyjmowanie wartości domyślnejobsługiwanie jedynie dwuwymiarowych przypadkówzostał użyty jedynie pierwszy element 'id'tylko jeden poziom zagnieżdżania gładkości jest wspierane przez funkcję 'gamm()'tylko skalarne 'p' oraz 'phi' są dozwolonetylko skalarne 'p' oraz 'phi' są dozwolone'ord' zawiera porządki poza zakresem (zostaną one zignorowane)argument 'ord' jest błędny. Przywracanie wartości NULLzbyt mała wartość argumentu 'ord'argument 'p' musi być w przedziale (1,2)argument 'p' musi być w przedziale [1,2]p-wartości dla jakichkolwiek członów, które da się ukarać do zera, będą nierzetelne: ponownie dopasuj model aby to naprawićp-wartość może dać niską moc w pewnych okolicznościachp-wartości mogą dać bardzo niską mocp-wartość nie jest wiarygodnakarne odchylenie = %spodstawa kar jest zbyt duża dla podstawy wygładzaniapodstawa kar jest zbyt małanazwa kolumny kary nie zgadza się z dostarczonymi nazwami obszaru!macierz kary, wielokąty brzegowe oraz/lub lista sąsiadów muszą być dostarczone w xtrząd kar jest zbyt duży dla podstawy wymiarufunkcja 'predict.gam()' może być użyta jedynie do przewidywania z obiektów klasy "gam"argument 'random' musi być *nazwaną* listą.losowe efekty nie działają z 'ids'argument nie jest obiektem klasy "gam"ponowna parametryzacja nie jest stabilna dla marginesu: nie wykonanoargument nie jest obiektem klasy "gam"argument reszt przekazywany do 'plot.gam' ma niepoprawną długość: zignorowanowartość 's' została zwiększonawartość 's' została zmieniona aby dać ciągłą funkcjęwartość 's' została zmniejszonafunkcja 's(.)' nie jest jeszcze wspierana'samfrac' jest zbyt małe - zignorowanoparametr skali musi być dodatnidostarczono mało wiarygodną tolerancjęśmieszna wartość została dostarczona do 'rank.tol': ustawianie pierwiastka kwadratowego z precyzji maszynyosobliwe wartości nie zostały zwrócone w w sposób uporządkowanygładkie obiekty nie powinny mieć atrybutu 'qrc'filmy 'soap' są tylko dwuwymiarowecoś nie tak z argumentem 'd'przykro mi, brak opcji rysowania konturu z błędami: spróbuj 'plot.gam'dostarczona odległość jest ujemna dostarczona kara nie jest kwadratowa!dostarczona kara ma niepoprawny wymiar!wygładzania 'te' nie są stosowalne z 'gamm4': zamiast tego użyj t2argument 'test' został zignorowanyadaptacyjna klasa wygładzania jest ograniczona do 1 lub 2 zmiennychliczba dostarczonych węzłów powinna być równa:zbyt mało węzłów'type' musi mieć wartość "link" lub "response"niewspierana metoda wyboru wygładzaniazażądano niezaimplementowanego typu rzadkiego więzunieznany optymalizatornieznana zewnętrzna metoda optymalizacjinieznane kryterium wyboru wygładzanianierozpoznane (wektorowe?) połączenieniewspierany porządek różniczkowania zażądany od 'gam.fit3()'wartość 'epsilon' musi być > 0nazwy zmiennych nie zgadzają się z nazwami granicfunkcja wariancji nie została rozpoznana dla kwaziargument 'w' posiada długość inną niż argument 'y'!wagi muszą być jak wagi w 'glm' dla ogólnego przypadkubez formułyx oraz y muszą mieć tę samą długość'x' oraz 'y' nie mają tej samej długości'x' ma wartość NULLargument 'x' jest poza zakresemargument 'xt' jest błędnyargument 'y' musi być całkowitą wielokrotnością argumentu 'phi' dla 'Tweedie(p=1)'argument 'y' musi być ściśle dodatni dla gęstości Gamma'y' musi zawierać jedną zmienną jeśli nie zawiera dwóchmgcv/inst/po/en@quot/0000755000177400001440000000000012475145647014425 5ustar murdochusersmgcv/inst/po/en@quot/LC_MESSAGES/0000755000177400001440000000000013046052673016201 5ustar murdochusersmgcv/inst/po/en@quot/LC_MESSAGES/mgcv.mo0000644000177400001440000000427713046052673017504 0ustar murdochusers<X- %8^'q,! "  , 8EY+@G T#hWX-=%k',! "< _ kE+@G?#    A term has fewer unique covariate combinations than specified maximum degrees of freedomAn out of bound write to matrix has occurred!Attempt to invert() non-square matrixERROR in addconQT.Failed to initialize memory for matrix.INTEGRITY PROBLEM in the extant matrix list.Incompatible matrices in matmult.QPCLS - Rank deficiency in modelSingular Matrix passed to invert()Sort failedTarget matrix too small in mcopyYou are trying to check matrix integrity without defining RANGECHECK.You must have 2m>d for a thin plate spline.magic requires smoothing parameter starting values if L suppliedmagic, the gcv/ubre optimizer, failed to converge after 400 iterations.svd() not convergedsvdroot matrix not +ve semi def. %gProject-Id-Version: mgcv 1.8-17 Report-Msgid-Bugs-To: POT-Creation-Date: 2017-02-06 09:59+0000 PO-Revision-Date: 2017-02-06 09:59+0000 Last-Translator: Automatically generated Language-Team: none Language: en MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n != 1); A term has fewer unique covariate combinations than specified maximum degrees of freedomAn out of bound write to matrix has occurred!Attempt to invert() non-square matrixERROR in addconQT.Failed to initialize memory for matrix.INTEGRITY PROBLEM in the extant matrix list.Incompatible matrices in matmult.QPCLS - Rank deficiency in modelSingular Matrix passed to invert()Sort failedTarget matrix too small in mcopyYou are trying to check matrix integrity without defining RANGECHECK.You must have 2m>d for a thin plate spline.magic requires smoothing parameter starting values if L suppliedmagic, the gcv/ubre optimizer, failed to converge after 400 iterations.svd() not convergedsvdroot matrix not +ve semi def. %gmgcv/inst/po/en@quot/LC_MESSAGES/R-mgcv.mo0000644000177400001440000012435213046052673017700 0ustar murdochusers \!E! "d8"7""" "" #X$#}#/####$A$2[$$4$*$ %(%5?%u%7%6%<&7?&w&>&[&=0';n'%'>'("%(:H(#(.(B()"8)[)-o)[))F*@]*$*$*** +4+>M+%+!++9+.,'M,-u,,,,7, -$-#8-\-z-+---0-$.SD.$.'.S.9/7M/:/2/$/30L0Sb0N0:1@@1R1-1=2@2'`2A2#2927(3/`33L3(3% 4"F4#i44;4f4AN5-5#55(6+)6AU6668667<7$[7!777(717'8)B88l8 8#8$89,98I9+9&9-9/:23::f:):,:1: *;$K;p;;; ;;;$<6+<0b<&<<<F<"==$`=8=E=>%>E>\>u>D>(>(?,?*@?k?3z?1?(? @1$@&V@<}@@*@@A.A+DA pA0{A#AMA,B%KB5qB_BlC+tC<C6C6D"KDYnDD#D"E0)ECZE+EE7E7"F%ZF%F%F%FBF 5G*BG\mGG6G"H :HR[H HH)HI%#IIIBdI(I$I+I!Jg8JAJ-JaKQrK4KcKQ]L*LL0LM0M(LMuMM=MAM0+N1\N1N2N3N1'OYOmOO'O#OO P#Pc5Ncccc ccc5c/0d$`d6d6dEe 9fdZf;ffg g'g AgXNgg/gg# h/hACh2hh4h* i6iRi5iii7i6i<,j7ijj>j[j=Zk;k%k>k9l"Ol:rl#l.lBmCm"bmm-m[m#nF@n@n$n$n*o =o^o>wo%o!oo9pXp'wp-pppp7 q AqNq#bqqq+q-q0rNrSnr$r'rSscs7ws:s2s$t3BtvtStNt:/u@juVu-v=0vnv'vAv#v9w7Vw/wwLw(%x%Nx"tx#xx;xfyA|y-y#yz(.z+WzAzzz8z63{j{${!{{{({1#|U|)p|8| |#|$}=}Z}8w}+}&}-~/1~2a~:~)~,~1& X$y $46Y0&F$"k$8E2%MsDÂ((1Z*n31܃(71R&<*+F\+r 0#څM,L%y5_Նl5+<·6 6B"yY#"40WC+̉77P%%%Ԋ%B c*p\6"E hR ܌) 6%QwB(Ս$+#OgfAΎ-a>Q4c'Q*ݐ0M^(z‘=ّA0Y1123!1U'ϓ#8Qj<@ǔB"K;n< 8IY/'Ӗ'#:4*o͗#'B)j--˜)53R5"&8>w aȚ1* \};.Λ+)U5mO*8'W#(0̝53 S7t-4ڞ,!N^v& ڟ-.:iM+РR%O/u? -$R8m'¢!-7ON1֣:7Y 6!(1*C.n#"ӥ&<S:oǦ)ۦ* 0Ql5|ħ 5(/^$6@I=fJ,5#B aP\+3 Xh*[mgcv8VSH 2kPeF.YQN{AdxOiD1KM)jH.nGz)_<*7vmwun%Bk,+Z; _g# |{e!2bCIa qM]~]sUY/l-C/!$hV%AJc5N" $rSr"y`bEO4oWp:( x69  =7\0}-l;f}X9Q^tdL<(zUtT36&u1'oR&4p ~KLwWET|i[@y:> 0?qR`s^GZF?'Dj8>"fs" smooth cannot use a multiply penalized basis (wrong basis in xt)"fs" terms can not be fixed here%s link not available for negative binomial family; available links are "identity", "log" and "sqrt"'family' argument seems not to be a valid family object'theta' must be specified,0s in V(mu)1= upper bound in call to mono.con()m can't be in rem wrong length and ignored.maximum number of iterations must be > 0mean, mu, must be non negativemethod not recognised.min.sp not supported with fast REML computation, and ignored.mismatch between nb/polys supplied area names and data area namesmodel has repeated 1-d smooths of same variable.more knots than data in a ds term: knots ignored.more knots than data in a tp term: knots ignored.more knots than data in an ms term: knots ignored.more knots than data in an sos term: knots ignored.more knots than unique data values is not allowedmu dimensions wrongmvn dimension errormvn does not yet handle offsetsmvn requires 2 or more dimensional datana.action not character or functionnames of z and pc must matchncol(M$C) != length(M$p)ncol(M$X) != length(M$p)need at least one interior knotnegative values not allowed for the negative binomial familynegative values not allowed for the zero inflated Poisson familynewdata is a model.frame: it should contain all required variablesnlm.fd only available for GCV/UBREno automatic plotting for smooths of more than one variableno automatic plotting for smooths of more than two variablesno data to predict atno factor supplied to fs smoothno free coefs in sf smoothno spatial information provided!no valid set of coefficients has been found:please supply starting valuesnon-existent exclude terms requested - ignoringnon-existent terms requested - ignoringnon-finite coefficients at iteration %dnot a gam objectnot all required variables have been supplied in newdata!not enough unique values to find k nearestnot positive definitenothing to do for this modelnrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)nthreads must be a positive integernumber of categories must be at least 2number of linear predictors doesn't matchnumber of supplied knots != k for a cc smoothnumber of supplied knots != k for a cr smoothobject does not appear to be of class lmeobject is not a glm or gamobject not fully initializedone or more supplied k too small - reset to defaultonly deals with 2D caseonly first element of `id' usedonly one level of smooth nesting is supported by gammonly scalar `p' and `phi' allowed.only scalar `rho' and `theta' allowed.ord contains out of range orders (which will be ignored)ord is wrong. reset to NULL.order too lowp must be in (1,2)p must be in [1,2]p-values for any terms that can be penalized to zero will be unreliable: refit model to fix this.p-values may give low power in some circumstancesp-values may give very low powerp-values un-reliablep.type!=0 is deprecated, and liable to be removed in futureparaPen not supported for multi-formula modelsparameter of ziplsspenalized deviance = %spenalty basis too large for smoothing basispenalty basis too smallpenalty column names don't match supplied area names!penalty matrix, boundary polygons and/or neighbours list must be supplied in xtpenalty order too high for basis dimensionpredict.gam can only be used to predict from gam objectsrandom argument must be a *named* list.random effects don't work with ids.recov works with fitted gam objects onlyreparameterization unstable for margin: not donerequested non-existent derivative in B-spline penaltyrequires an object of class gamresiduals argument not supportedresiduals argument to plot.gam is wrong length: ignoredresponse not in 0 to number of predictors + 1rho missing from simulation data edf.type reset to 2s value increaseds value modified to give continuous functions value reduceds(.) not yet supported.samfrac too small - ignoredsaturated likelihood may be inaccuratescale parameter must be positivescaled t df must be >2sd should have exactly one less entry than ldshared offsets not allowedside conditions not allowed for nested smoothssilly tolerance suppliedsilly value supplied for rank.tol: reset to square root of machine precision.single linear predictor indices are ignoredsingle penalty tensor product smooths are deprecated and likely to be removed soonsingular values not returned in ordersmooth objects should not have a qrc attribute.smoothing parameter prior choise not recognised, reset to gammasoap films are bivariate onlysomething wrong with argument d.something wrong with inputs to LAPACK routinesorry link not yet handledsorry no option for contouring with errors: try plot.gamstep failed: max abs grad =supplied S matrices are wrong diminsionsupplied dist negativesupplied knotssupplied penalty not square!supplied penalty wrong dimension!supply a value for each variable for a point constraintsweep and drop constraints unlikely to work well with self handling of by varste smooths not useable with gamm4: use t2 insteadtest argument ignoredthe adaptive smooth class is limited to 1 or 2 covariates.there is *no* information about some basis coefficientsthere should betoo few knotstype iterms not available for multiple predictor casestype must be "link" or "response"un-supported smoothness selection methodun-supported testunconditional argument not meaningful hereunimplemented sparse constraint type requesteduniquecombs has not worked properlyunknown optimizerunknown outer optimization method.unknown smoothness selection criterionunknown tensor constraint typeunrecognised na.actionunrecognized (vector?) linkunsupported order of differentiation requested of gam.fit3value of epsilon must be > 0values out of rangevariable names don't match boundary namesvariance function not recognized for quasiview variables must be one of %sw different length from y!weights ignoredweights must be like glm weights for generalized casewithout a formulax and y must be same lengthx and y not same lengthx is nullx out of rangext argument is faulty.y must be an integer multiple of phi for Tweedie(p=1)y must be strictly positive for a Gamma densityy must be univariate unless binomialziplss requires 2 links specified as character stringsProject-Id-Version: mgcv 1.8-17 POT-Creation-Date: 2017-02-06 09:59 PO-Revision-Date: 2017-02-06 09:59 Last-Translator: Automatically generated Language-Team: none MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Language: en Plural-Forms: nplurals=2; plural=(n != 1); "fs" smooth cannot use a multiply penalized basis (wrong basis in xt)"fs" terms can not be fixed here%s link not available for negative binomial family; available links are "identity", "log" and "sqrt"‘family’ argument seems not to be a valid family object‘theta’ must be specified,0s in V(mu)1= upper bound in call to mono.con()m can't be in rem wrong length and ignored.maximum number of iterations must be > 0mean, mu, must be non negativemethod not recognised.min.sp not supported with fast REML computation, and ignored.mismatch between nb/polys supplied area names and data area namesmodel has repeated 1-d smooths of same variable.more knots than data in a ds term: knots ignored.more knots than data in a tp term: knots ignored.more knots than data in an ms term: knots ignored.more knots than data in an sos term: knots ignored.more knots than unique data values is not allowedmu dimensions wrongmvn dimension errormvn does not yet handle offsetsmvn requires 2 or more dimensional datana.action not character or functionnames of z and pc must matchncol(M$C) != length(M$p)ncol(M$X) != length(M$p)need at least one interior knotnegative values not allowed for the negative binomial familynegative values not allowed for the zero inflated Poisson familynewdata is a model.frame: it should contain all required variablesnlm.fd only available for GCV/UBREno automatic plotting for smooths of more than one variableno automatic plotting for smooths of more than two variablesno data to predict atno factor supplied to fs smoothno free coefs in sf smoothno spatial information provided!no valid set of coefficients has been found:please supply starting valuesnon-existent exclude terms requested - ignoringnon-existent terms requested - ignoringnon-finite coefficients at iteration %dnot a gam objectnot all required variables have been supplied in newdata!not enough unique values to find k nearestnot positive definitenothing to do for this modelnrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)nthreads must be a positive integernumber of categories must be at least 2number of linear predictors doesn't matchnumber of supplied knots != k for a cc smoothnumber of supplied knots != k for a cr smoothobject does not appear to be of class lmeobject is not a glm or gamobject not fully initializedone or more supplied k too small - reset to defaultonly deals with 2D caseonly first element of `id' usedonly one level of smooth nesting is supported by gammonly scalar `p' and `phi' allowed.only scalar `rho' and `theta' allowed.ord contains out of range orders (which will be ignored)ord is wrong. reset to NULL.order too lowp must be in (1,2)p must be in [1,2]p-values for any terms that can be penalized to zero will be unreliable: refit model to fix this.p-values may give low power in some circumstancesp-values may give very low powerp-values un-reliablep.type!=0 is deprecated, and liable to be removed in futureparaPen not supported for multi-formula modelsparameter of ziplsspenalized deviance = %spenalty basis too large for smoothing basispenalty basis too smallpenalty column names don't match supplied area names!penalty matrix, boundary polygons and/or neighbours list must be supplied in xtpenalty order too high for basis dimensionpredict.gam can only be used to predict from gam objectsrandom argument must be a *named* list.random effects don't work with ids.recov works with fitted gam objects onlyreparameterization unstable for margin: not donerequested non-existent derivative in B-spline penaltyrequires an object of class gamresiduals argument not supportedresiduals argument to plot.gam is wrong length: ignoredresponse not in 0 to number of predictors + 1rho missing from simulation data edf.type reset to 2s value increaseds value modified to give continuous functions value reduceds(.) not yet supported.samfrac too small - ignoredsaturated likelihood may be inaccuratescale parameter must be positivescaled t df must be >2sd should have exactly one less entry than ldshared offsets not allowedside conditions not allowed for nested smoothssilly tolerance suppliedsilly value supplied for rank.tol: reset to square root of machine precision.single linear predictor indices are ignoredsingle penalty tensor product smooths are deprecated and likely to be removed soonsingular values not returned in ordersmooth objects should not have a qrc attribute.smoothing parameter prior choise not recognised, reset to gammasoap films are bivariate onlysomething wrong with argument d.something wrong with inputs to LAPACK routinesorry link not yet handledsorry no option for contouring with errors: try plot.gamstep failed: max abs grad =supplied S matrices are wrong diminsionsupplied dist negativesupplied knotssupplied penalty not square!supplied penalty wrong dimension!supply a value for each variable for a point constraintsweep and drop constraints unlikely to work well with self handling of by varste smooths not useable with gamm4: use t2 insteadtest argument ignoredthe adaptive smooth class is limited to 1 or 2 covariates.there is *no* information about some basis coefficientsthere should betoo few knotstype iterms not available for multiple predictor casestype must be "link" or "response"un-supported smoothness selection methodun-supported testunconditional argument not meaningful hereunimplemented sparse constraint type requesteduniquecombs has not worked properlyunknown optimizerunknown outer optimization method.unknown smoothness selection criterionunknown tensor constraint typeunrecognised na.actionunrecognized (vector?) linkunsupported order of differentiation requested of gam.fit3value of epsilon must be > 0values out of rangevariable names don't match boundary namesvariance function not recognized for quasiview variables must be one of %sw different length from y!weights ignoredweights must be like glm weights for generalized casewithout a formulax and y must be same lengthx and y not same lengthx is nullx out of rangext argument is faulty.y must be an integer multiple of phi for Tweedie(p=1)y must be strictly positive for a Gamma densityy must be univariate unless binomialziplss requires 2 links specified as character stringsmgcv/inst/po/ko/0000755000177400001440000000000012475145647013423 5ustar murdochusersmgcv/inst/po/ko/LC_MESSAGES/0000755000177400001440000000000013046052673015177 5ustar murdochusersmgcv/inst/po/ko/LC_MESSAGES/mgcv.mo0000644000177400001440000000205212765741175016500 0ustar murdochusersL |'" @{T-DCCERROR in addconQT.Failed to initialize memory for matrix.Singular Matrix passed to invert()Sort failedmagic requires smoothing parameter starting values if L suppliedProject-Id-Version: mgcv 1.8-4 Report-Msgid-Bugs-To: POT-Creation-Date: 2016-08-19 13:28+0100 PO-Revision-Date: 2015-02-21 16:01-0600 Last-Translator:Chel Hee Lee Language-Team: Chel Hee Lee Language: ko MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=1; plural=0; addconQT 에서 에러가 발생했습니다.행렬생성에 필요한 메모리 초기화에 실패했습니다.특이함수(singular matrix)가 invert()에 전달되었습니다.정렬에 실패했습니다.L에 주어진 값이 없다면 스무딩 파라미터(smoothing parameter)에 대한 초기값(starting values)가 필요합니다.mgcv/inst/po/ko/LC_MESSAGES/R-mgcv.mo0000644000177400001440000005665113046052673016704 0ustar murdochusers\ d!7 #4XAl2* 5#Y6w<% /"Eh-|F$$3*X%-/?U7k $!'Fn2N:T;rA#$3!Xz1)#?\8y6+$G8l%*/(Z0#+7<c6"#87X7 *")#Mh(+gAW-aQ)4{cQ *f  0   (!,!K!=b!'!!!!"<7"@t"B"""'#C#:T######$$<$T$"t$&$$$$.%0%'D%(l%%7%%& !&B&Y&Mr&& &!&('"0'&S'z'''*' '(.(J( b(l({(5(/(6(/)*Mz+3++'+:&,<a,-,C,-X!-[z-_-/6.[f.7.P.VK/,/t/1D0Kv010Y0N1rb1?1D2JZ2+2W2F)37p3U3,3;+4;g4m4(52:51m525D5h6V6D6i7=77>N8"868l8]T9L9,9E,:Nr:&:7:x ;*;c;q(<+<:<P=4R=>=#=_=0J>]{>R>I,?.v?5???*@AF@D@K@?A6YA3A<A6BL8BBTCItC4CWCNKD\DcD[EFuE7E8E.-F?\FAFWF 6G@GGKHHIR)J|J;KFK%$LfJL'L=LCM([MMZMGMGN=N=OKEO`OkO_^POPhQ+wQGQAQ?-R=mR7R6R.S4IS5~SNSRT3VT:T9TpT1pUiUE V>RVbV)VDWEcWLWLWbCX5X@X>YN\Y>YOY/:Z6jZ"ZyZA>[+[<[2[=\'Z\'\Y\O]TT]8=y<Yp wLV-M|\v4 ueUB+Hos"TKxf _ ~i:q(lRnQg1IN37;EF]5m/dt'C%kaz9$J ` D6^>GXW0*b#}{?,OchZP![A&2Sj).r@%s link not available for negative binomial family; available links are "identity", "log" and "sqrt"'family' argument seems not to be a valid family object'theta' must be specified,0s in V(mu)1= upper bound in call to mono.con()m can't be in rem wrong length and ignored.maximum number of iterations must be > 0mean, mu, must be non negativemethod not recognised.min.sp not supported with fast REML computation, and ignored.mvn requires 2 or more dimensional datanames of z and pc must matchncol(M$C) != length(M$p)ncol(M$X) != length(M$p)need at least one interior knotnegative values not allowed for the negative binomial familynegative values not allowed for the zero inflated Poisson familynewdata is a model.frame: it should contain all required variablesnlm.fd only available for GCV/UBREnon-finite coefficients at iteration %dnot a gam objectnot all required variables have been supplied in newdata!nrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)nthreads must be a positive integerobject is not a glm or gamobject not fully initializedonly deals with 2D caseonly first element of `id' usedonly scalar `p' and `phi' allowed.only scalar `rho' and `theta' allowed.ord is wrong. reset to NULL.p must be in (1,2)p must be in [1,2]paraPen not supported for multi-formula modelsparameter of ziplssrandom argument must be a *named* list.recov works with fitted gam objects onlyrequires an object of class gamresiduals argument to plot.gam is wrong length: ignoreds(.) not yet supported.samfrac too small - ignoredscale parameter must be positivescaled t df must be >2silly tolerance suppliedsilly value supplied for rank.tol: reset to square root of machine precision.supplied dist negativetoo few knotstype must be "link" or "response"un-supported smoothness selection methodunknown outer optimization method.unknown smoothness selection criterionunrecognized (vector?) linkvalue of epsilon must be > 0values out of rangevariance function not recognized for quasiview variables must be one of %sw different length from y!x and y must be same lengthx and y not same lengthx is nullx out of rangext argument is faulty.y must be an integer multiple of phi for Tweedie(p=1)y must be strictly positive for a Gamma densityziplss requires 2 links specified as character stringsProject-Id-Version: R 3.1.3 Report-Msgid-Bugs-To: bugs.r-project.org POT-Creation-Date: 2017-02-06 09:59 PO-Revision-Date: 2015-02-21 16:01-0600 Last-Translator:Chel Hee Lee Language-Team: Chel Hee Lee Language: ko MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=1; plural=0; %s는 음이항분포 페밀리(negative binomial family)에 사용할 수 있는 링크(link)가 아닙니다. 사용가능한 링크들에는 "identity", "log" 그리고 "sqrt"가 있습니다.'family' 인자는 올바른 family 객체가 아닌 것 같이 보입니다.'theta'의 값은 반드시 주어져야 합니다.,V(mu)에서 0이 발견되었습니다.1d for a thin plate spline.magic, the gcv/ubre optimizer, failed to converge after 400 iterations.svd() not convergedsvdroot matrix not +ve semi def. %gProject-Id-Version: mgcv 1.3-10 Report-Msgid-Bugs-To: POT-Creation-Date: 2016-08-19 13:28+0100 PO-Revision-Date: 2005-12-08 00:40+0100 Last-Translator: Philippe Grosjean Language-Team: French Language: fr MIME-Version: 1.0 Content-Type: text/plain; charset=ISO-8859-1 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n > 1); Un terme a moins de combinaisons de covariables uniques que le degr de libert maximum spcifiUne crite hors des limites de la matrice s'est produite !Tentative d'inversion d'une matrice non carreERREUR dans addconQT.L'initialisation de la mmoire pour une matrice a chou.PROBLEME D'INTEGRITE dans la liste de la matrice tendue.Matrices incompatibles dans matmult.QPCLS - Dficience de rang dans le modleMatrice singulire passe invert()Le tri a chouMatrice cible trop petite dans mcopyVous essayez de vrifier l'intgrit de la matrice sans avoir dfini RANGECHECK.Vous devez avoir 2m > d pour une 'thin plate spline'magic, l'optimisateur gcv/ubre, n'a pas converg aprs 400 itrations.svd() n'a pas convergla matrice svdroot n'est pas +ve semi def. %gmgcv/inst/po/fr/LC_MESSAGES/R-mgcv.mo0000644000177400001440000003376213046052673016700 0ustar murdochusers    #  2" U 5l  7 6 </ 7l %  : # .? n $ * % 9![k7 0?$_2$=7R%l"#;f3A)/#Y$}81 *;FW8%*6(a0#5#lY<"&7@%x%%%\m0(-0D1u1B ;N<I'':O-- )73a8'7.MF%/ 8 D[ q!*  2$<a  )$ N +c & I $!=%!9c!?!E!*#"N";k"/"/"##)+#-U#7#'#P##4$-X$.$M$%%(%DH%-%"%@%&&EF&Y&/&4'%K'&q'&'I' (C("(&()B7)'z).)5)B*&J*q**N*9*3.+!b+*+++3+,-,B,6W,*,H,o-Nr-3--A.IU.:.:.:/kP/!///= 0%H0*n0030G0B*1m11N1A1D02 u2S2&2@3R3o335353*4M:4N4-4I5O5cg585961>6Op6666"67!<7,^7!77 7(7qGpMw%S7WgA^ +.?85e\6(Oyh,QJx E:#oC{f i02d)Nu>_<T/`ZXY1V&Bs~"[4r=F 9 $m3|@ncHb!zjl*tv'}kDK;L P-aU]RI,0s in V(mu)Algorithm did not convergeAlgorithm stopped at boundary valueAn object of lengthAt least three knots required in call to mono.con.Can't find by variableCan't find valid starting values: please specify someCannot extract the dimensionsCannot extract the inverse from an uninitialized objectCannot extract the matrix from an uninitialized objectCannot extract the matrix from an uninitialized pdMat objectCannot extract the matrix with uninitialized dimensionsFirst argument is no sort of formula!H has wrong dimensionIRLS regularizing parameter must be a non-negative number.Invalid fitted means in empty modelInvalid linear predictor values in empty modelLength of start should equalM$S and M$off have different lengthsM$sp has different length to M$S and M$offModel has more coefficients than dataModel seems to contain no termsMust give names when initializing pdIdnot from parameter.NA's in min.sp.NA's in pdTens factorNA's in pdTens matrixNA's in supplied smoothing parameter vector - ignoring.NAs in V(mu)NAs in d(mu)/d(eta)No data supplied to gam.setupNo terms to plot - nothing for plot.gam() to do.No variance estimates availableNon-finite coefficients at iterationNot enough (non-NA) data to do anything meaningfulNot enough informative observations.Repeated variables as arguments of a smooth are not permittedSomething wrong - matrix probably not +ve semi definiteSomething wrong with zlimStep size truncated due to divergenceStep size truncated: out of boundsStep size truncated: out of bounds.Supplied matrix not symmetricSupplied smoothing parameter vector is too short - ignored.Tensor product penalty rank appears to be too low: please email Simon.Wood@R-project.org with details.The following arguments to anova.glm(..) are invalid and dropped:Unknown type, reset to terms.X lost dimensions in magic!!You've got no model....all elements of random list must be namedand correspond to initial coefs foranova.gam called with non gam objectargument k of s() should be integer and has been roundedbasis dimension, k, increased to minimum possiblebs wrong length and ignored.by=. not allowedcolor scheme not recognisedcomponents of knots relating to a single smooth must be of same lengthd can not be negative in call to null.space.dimension().data vectors are of different lengthsdimension of fx is wrongdimensions of supplied w wrong.does not match the required parameter sizeelements of min.sp must be non negative.fam not a family objectfamily not recognisedfamily not recognizedfitted probabilities numerically 0 or 1 occurredfitted rates numerically 0 occurredgamm can not fix only some margins of tensor product.gamm models must have at least 1 smooth with unknown smoothing parameter or at least one other random effectgamm() can only handle random effects defined as named listsgrid vectors are different lengthsillegal `family' argumentinitial parameters very close to inequality constraintsinner groupings not nested in outer!!inner loop 1; can't correct step sizeinner loop 2; can't correct step sizeinner loop 3; can't correct step sizeiterative weights or data non-finite in gam.fit - regularization may help. See ?gam.control.length of min.sp is wrong.length(M$w) != length(M$y)link not recognisedlower bound >= upper bound in call to mono.con()m wrong length and ignored.maximum number of iterations must be > 0method not recognised.model has repeated 1-d smooths of same variable.more knots than data in a tp term: knots ignored.more knots than unique data values is not allowedncol(M$C) != length(M$p)ncol(M$X) != length(M$p)newdata is a model.frame: it should contain all required variablesno automatic plotting for smooths of more than one variableno automatic plotting for smooths of more than two variablesno data to predict atno valid set of coefficients has been found:please supply starting valuesnon-existent terms requested - ignoringnot all required variables have been supplied in newdata!nrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)number of supplied knots != k for a cc smoothnumber of supplied knots != k for a cr smoothobject does not appear to be of class lmeone or more supplied k too small - reset to defaultpredict.gam can only be used to predict from gam objectsrandom argument must be a *named* list.residuals argument to plot.gam is wrong length: ignoreds(.) not yet supported.silly value supplied for rank.tol: reset to square root of machine precision.singular values not returned in ordersmooth objects should not have a qrc attribute.something wrong with argument d.sorry no option for contouring with errors: try plot.gamsupplied dist negativetest argument ignoredtoo few knotstype must be "link" or "response"unrecognized (vector?) linkvalue of epsilon must be > 0variance function not recognized for quasiw different length from y!without a formulax is nully must be univariate unless binomialProject-Id-Version: mgcv 1.3-10 Report-Msgid-Bugs-To: bugs@r-project.org POT-Creation-Date: 2017-02-06 09:59 PO-Revision-Date: 2005-12-09 09:13+0100 Last-Translator: Philippe Grosjean Language-Team: French Language: fr MIME-Version: 1.0 Content-Type: text/plain; charset=ISO-8859-1 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n > 1); ,0s dans V(mu)L'algorithme n'a pas convergL'algorithme est arrt aux valeurs limitesUn objet de longueurAu moins trois noeuds requis pour mono.con.Impossible de trouver la variable 'by'Impossible de trouver des valeurs de dpart valides : veuillez en spcifierImpossible d'extraire les dimensionsImpossible d'extraire l'inverse depuis un objet non initialisImpossible d'extraire la matrice d'un objet non initialisImpossible d'extraire la matrice d'un objet pdMat non initialisImpossible d'extraire la matrice ayant des dimensions non initialisesLe premier argument n'est pas une formule.H a des mauvaises dimensionsle paramtre de rgularisation IRLS doit tre positif ou null.Moyennes ajustes incorrectes dans un modle videValeurs de prdiction linaire dans un modle videLa longueur de start doit tre gale M$S et M$off ont des longueurs diffrentesM$sp a une longueur diffrente de M$S et M$offLe modle a plus de coefficients que le nombre de donnesLe modle semble ne contenir aucun termeIl faut fournir des noms lors de l'initialisation de pdIdnot depuis un paramtre.valeurs manquantes (NA) dans min.spvaleurs manquantes (NA) dans le fateur pdTensvaleurs manquantes (NA) dans la matrice pdTensValeurs manquantes (NA) dans le vecteur de paramtres de lissage fixe - ignor.NAs dans V(mu)NAs dans d(mu)/d(eta)Aucune donne fournie gam.setupAucun terme reprsenter graphiquement - rien faire pour plot.gam().Aucun estimateur de variance n'est disponibleCoefficients non finis l'itrationPas assez de donnes (non-NA) pour faire quoi que ce soit d'utilePas assez d'observations informatives.Les variables rptes comme arguments d'un lissage ne sont pas permisesQuelque chose d'anormal s'est produit - la matrice n'est probablement pas +ve semi dfinieQuelque chose d'anormal s'est produit avec zlimLa taille du pas est tronque cause d'une divergenceTaille du pas tronque: hors de plage.Taille du pas tronque : hors de plage.La matrice fournie n'est pas symtriqueLe vecteur des paramtres de lissage fourni est trop court - il est ignor.Le rang de la pnalit pour le produit tensoriel semble trop bas : veuillez envoyer un email Simon.Wood@R-project.org avec les dtailsLes arguments suivants de anova.glm(..) sont incorrects et ignors :Type inconnu, rinitialis `terms'.X a perdu ses dimensions dans magic !!Vous n'avez aucun modle...tous les lments d'une liste de nombres alatoires doivent tre nomms et correspond aux coefs initiaux pour anova.gam appel sur un objet qui n'est pas gaml'argument k de s() doit tre un entier et a t arrondila dimension de base, k, est augmente la valeur minimale possiblebs, de longueur incorrecte, est ignor.by=. n'est pas permisschma de couleurs non reconnules composants des noeuds relatifs un mme lissage doivent tre de mme longueurd ne peut tre ngatif dans l'appel null.space.dimension()les vecteurs de donnes ont des longueurs diffrentesla dimension de fx est incorrecteles dimensions du w fourni sont mauvaises.ne correspond pas au paramtre taille requisles lments de min.sp doivent tre positifs ou nulls.fam n'est pas un objet familyfamille non reconnuefamille non reconnueprobabilits d'ajustement numrique de 0 ou 1 rencontrestaux d'ajustement numriques de 0 rencontrsgamm ne peut arranger seulement quelques marges de produits de tenseurs.les modles gamm doivent avoir au moins 1 lissage avec des parmtres inconnus ou au moins un autre effet alatoiregamm() peut seulement utiliser des effets alatoires dfinis comme listes nommesles vecteurs de grille ont des longueurs diffrentesargument `family' non autorisles paramtres initiaux sont trs proches des contraintes d'ingalitle regroupement interne n'est pas imbriqu dans le regroupement externe !!boucle interne 1 ; Impossible de corriger la taille du pasboucle interne 2 ; Impossible de corriger la taille du pasboucle interne 3 ; Impossible de corriger la taille du paspondrations itratives ou donnes non finies dans gam.fit - une rgularisation peut aider. Voyez ?gam.control.la longueur de min.sp est fausse.length(M$w) != length(M$y)link non reconnulimite infrieure >= limite suprieure dans l'appel mono.con()m, de longueur incorrecte, est ignor.le nombre maximum d'itrations doit tre > 0mthode non reconnue.le modle a des lissages 1-d rpts des mmes variablesplus de noeuds que de donnes dans un terme tp : des noeuds sont ignors.il n'est pas autoris d'avoir plus de noeuds que de valeurs uniquesncol(M$C) != length(M$p)ncol(M$X) != length(M$p)newdata est un model.frame : il devrait contenir toutes les variables requisesaucun graphe automatique pour les lissages de plus d'une variableaucun graphe automatique pour les lissages de plus de deux variablespas de donnes pour la prdiction pas d'ensemble de coefficients valide trouv : veuillez fournir les valeurs de dpartterme inexistant requis - il est ignorles variables requises n'ont pas toutes t fournies dans newdata!nrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)le nombre de noeuds fournis != k pour un lissage 'cc'le nombre de noeuds fournis != k pour un lissage 'cr'l'objet ne semble pas tre de la classe lmeun ou plusieurs k spcifis trop petits - rinitialisation aux valeurs par dfautpredict.gam peut seulement tre utilis pour des prdictions partir d'objets gaml'argument random doit tre une liste *nomme*.l'argument residuals plot.gam est de la mauvaise longueur : il est ignors(.) pas encore supportvaleur aberrante fournie pour rank.tol : rinitialise la racine carre de la prcision de la machine.les valeurs singulires ne sont pas renvoyes dans l'ordreles objets lissage ne devraient pas avoir d'attribut qrc.il y a quelque chose d'anormal avec l'argument d.dsol, aucune option pour effectuer les contours avec erreurs : essayez plot.gamdist fournie ngativeargument test ignortrop peu de noeudstype doit tre "link" ou "response"link non reconnu (vecteur ?)la valeur de epsilon doit tre > 0function de variance non reconnue pour quasiw n'a pas la mme longueur que y !sans une formulex est nully doit tre univari moins d'tre binomialmgcv/inst/po/de/0000755000177400001440000000000012475145647013402 5ustar murdochusersmgcv/inst/po/de/LC_MESSAGES/0000755000177400001440000000000013046052673015156 5ustar murdochusersmgcv/inst/po/de/LC_MESSAGES/mgcv.mo0000644000177400001440000000455712765741175016473 0ustar murdochusers<X- %8^'q,! "  , 8EY+@G T#hd:?74K!(R 3s@M6 N     A term has fewer unique covariate combinations than specified maximum degrees of freedomAn out of bound write to matrix has occurred!Attempt to invert() non-square matrixERROR in addconQT.Failed to initialize memory for matrix.INTEGRITY PROBLEM in the extant matrix list.Incompatible matrices in matmult.QPCLS - Rank deficiency in modelSingular Matrix passed to invert()Sort failedTarget matrix too small in mcopyYou are trying to check matrix integrity without defining RANGECHECK.You must have 2m>d for a thin plate spline.magic requires smoothing parameter starting values if L suppliedmagic, the gcv/ubre optimizer, failed to converge after 400 iterations.svd() not convergedsvdroot matrix not +ve semi def. %gProject-Id-Version: R 2.10.0 / mgcv 1.5-5 Report-Msgid-Bugs-To: POT-Creation-Date: 2016-08-19 13:28+0100 PO-Revision-Date: 2009-10-08 16:16+0200 Last-Translator: Chris Leick Language-Team: German Language: de MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n != 1); Ein Term hat weniger einzigartige Kombinationen von Kovariaten als maximal angegebene FreiheitsgradeEin Schreiben außerhalb der Matrixgrenze ist aufgetreten!Versuch des Aufrufs von invert() für nicht-quadratische MatrixFEHLER in addconQT.Initialisieren von Speicher für Matrix fehlgeschlagen.INTEGRITÄTSPROBLEM in der bestehenden Matrix-Liste.Inkompatible Matrizen in matmult.QPCLS - Rang-Defizit im ModellSinguläre Matrix an invert() übergebenSortieren fehlgeschlagenZielmatrix zu klein in mcopySie versuchen die Integrität der Matrix zu prüfen ohne RANGECHECK zu definieren.Es muss 2m>d für einen dünnwandige Spline gelten.magic benötigt Glättungsparameter-Startwerte, wenn L angegebenmagic, der gcv/ubre-Optimierer, konvergierte nach 400 Iterationen noch nicht.svd() nicht konvergiertsvdroot-Matrix nicht +ve def. %gmgcv/inst/po/de/LC_MESSAGES/R-mgcv.mo0000644000177400001440000011624713046052673016661 0ustar murdochusers\ (E) od7-G IU oX|/#9]Aq24 *9 d  5  7 6#!<Z!7!!>![,";"%"":##;#._##"##-#[$n$F$@$$%$8%*]% %%>%%&!'&I&9i&&'&-&'('>'7T' ''#'''+(-:(0h((S($ )'2)SZ))7):)25*$h*3**S*N++:z+=++#,97,7q,/,,L,(@-%i-"-#--;-f0.A.#..(/+D/Ap///8/6 0W0$v0!000(011B1)]1 1#1$1128+2&d2-2/2:2)$3,N31{3$3334 4<4$M46r404&45!5F=5$585E5(6%C6i6666*6(6!7<<7y7777+7 808#@8,d8%858_8lM9+9<96#:"Z:Y}::#:0;CF;+;;7;7<%F<%l<%<%< <*<\=6s="= =R= A>b>)q>>%>>(>+ ?L?gc?A?- @a;@Q@4@c$AQA*AB0BJB(wBBB=BAC0VC1C1C3C1D'QDyDDDD<D@%EBfE"E;E<FEF[F vFIF'F' G1G:BG*}GGGGG#H-:H-hH)HHH3H,IDI5dI"I&I8IJ :JHJ[JanJ1J K#K;8K.tKKK+KK5LOIL*L8L'L#%M(IM0rMM M7M4NQN,cNNNN&N NO.3ObOM{ORO%P/BP?rPP PP8 QEQaQxQQ!Q1QQ:RIR YR6gR!R(R*R.SCS"US&xSS:SST)'T*QT |TTT5TTU,U DUNU]U5tU/U$U6U6VNW4XoJX@XXY Y'Y?YuWYY7Y Z!?ZaZMwZ8Z%ZA$[(f["[)[H[/%\KU\J\P\I=]]<]m]EP^(^^<^2_:G_ _$__4_w`#`b`Sa,ia)a1a&a%bF?b'b*b'bMc.Oc-~c8ccc dF!d hdud:d)d*d1e7Ke;e$ele.Qf-flfg^2g;g9g&hN.h}h\hUhFHiFi*i%jB'jAjj>jjTk5\k,k3k8k#,l?PlhlHl,Bm/omUm9mE/nunnJnDn'?o*go"o oo6o4p!Kp3mp*p/p/p,qIq<fq6q6q/rIAr4r1r1r,$sQs)js s*sssAt:Rt%t&ttft'Zu?uLu v,0v]vxv*vv4v/w7wHVww www7x=xXNxJx0x:#yB^yyyz9zOz4*{-_{u{|3!|7U|J|.|#}=+}Ai}6}<}<~<\~ ~.~m~;C''a,1^,o,+3.bq}L6<ms_=Am^1L~6˄(- ':bKy6Ņ9969p::1 *R}'@ׇKId#K҈K#j*']5?-u=9 +Li,9ʋ9/>nN+GB"&Iԍ,K\r6&Gn744!VApT1P90)2>"W*z=@$73k"|'!?% ecd5O1>#"$=Pb&ږ( ,3<`D D$`.0A''>$fA) /4(d1%B; Lm Aқ0,E4r89o#g*%(M+ESFA1?Zm.au~4z<F&i@wQ4M@5 /_7;N#y.9KqNDKpcv/D"P=b0V|Q& :$rnf !Z2U!;1T\+LI=Y5Gs% IR3H'6[)0'B\Ye[L l} j`AO<*>82"G:Ph3T  CUd->X$,(6HExC] kJWtV7?{XRO-  B^ S),WJ"fs" smooth cannot use a multiply penalized basis (wrong basis in xt)"fs" terms can not be fixed here%s link not available for negative binomial family; available links are "identity", "log" and "sqrt"'family' argument seems not to be a valid family object'theta' must be specified,0s in V(mu)1= upper bound in call to mono.con()m can't be in rem wrong length and ignored.maximum number of iterations must be > 0mean, mu, must be non negativemethod not recognised.min.sp not supported with fast REML computation, and ignored.mismatch between nb/polys supplied area names and data area namesmodel has repeated 1-d smooths of same variable.more knots than data in a ds term: knots ignored.more knots than data in a tp term: knots ignored.more knots than data in an sos term: knots ignored.more knots than unique data values is not allowedmvn requires 2 or more dimensional datanames of z and pc must matchncol(M$C) != length(M$p)ncol(M$X) != length(M$p)need at least one interior knotnegative values not allowed for the negative binomial familynegative values not allowed for the zero inflated Poisson familynewdata is a model.frame: it should contain all required variablesnlm.fd only available for GCV/UBREno automatic plotting for smooths of more than one variableno automatic plotting for smooths of more than two variablesno data to predict atno free coefs in sf smoothno spatial information provided!no valid set of coefficients has been found:please supply starting valuesnon-existent terms requested - ignoringnon-finite coefficients at iteration %dnot a gam objectnot all required variables have been supplied in newdata!not enough unique values to find k nearestnothing to do for this modelnrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)nthreads must be a positive integernumber of supplied knots != k for a cc smoothnumber of supplied knots != k for a cr smoothobject does not appear to be of class lmeobject is not a glm or gamobject not fully initializedone or more supplied k too small - reset to defaultonly deals with 2D caseonly first element of `id' usedonly one level of smooth nesting is supported by gammonly scalar `p' and `phi' allowed.only scalar `rho' and `theta' allowed.ord contains out of range orders (which will be ignored)ord is wrong. reset to NULL.order too lowp must be in (1,2)p must be in [1,2]p-values for any terms that can be penalized to zero will be unreliable: refit model to fix this.p-values may give low power in some circumstancesp-values may give very low powerp-values un-reliablep.type!=0 is deprecated, and liable to be removed in futureparaPen not supported for multi-formula modelsparameter of ziplsspenalized deviance = %spenalty basis too large for smoothing basispenalty basis too smallpenalty column names don't match supplied area names!penalty matrix, boundary polygons and/or neighbours list must be supplied in xtpenalty order too high for basis dimensionpredict.gam can only be used to predict from gam objectsrandom argument must be a *named* list.random effects don't work with ids.recov works with fitted gam objects onlyreparameterization unstable for margin: not donerequires an object of class gamresiduals argument not supportedresiduals argument to plot.gam is wrong length: ignoredrho missing from simulation data edf.type reset to 2s value increaseds value modified to give continuous functions value reduceds(.) not yet supported.samfrac too small - ignoredsaturated likelihood may be inaccuratescale parameter must be positivescaled t df must be >2side conditions not allowed for nested smoothssilly tolerance suppliedsilly value supplied for rank.tol: reset to square root of machine precision.single penalty tensor product smooths are deprecated and likely to be removed soonsingular values not returned in ordersmooth objects should not have a qrc attribute.smoothing parameter prior choise not recognised, reset to gammasoap films are bivariate onlysomething wrong with argument d.sorry link not yet handledsorry no option for contouring with errors: try plot.gamstep failed: max abs grad =supplied dist negativesupplied knotssupplied penalty not square!supplied penalty wrong dimension!te smooths not useable with gamm4: use t2 insteadtest argument ignoredthe adaptive smooth class is limited to 1 or 2 covariates.there should betoo few knotstype iterms not available for multiple predictor casestype must be "link" or "response"un-supported smoothness selection methodunconditional argument not meaningful hereunimplemented sparse constraint type requestedunknown optimizerunknown outer optimization method.unknown smoothness selection criterionunrecognized (vector?) linkunsupported order of differentiation requested of gam.fit3value of epsilon must be > 0values out of rangevariable names don't match boundary namesvariance function not recognized for quasiview variables must be one of %sw different length from y!weights ignoredweights must be like glm weights for generalized casewithout a formulax and y must be same lengthx and y not same lengthx is nullx out of rangext argument is faulty.y must be an integer multiple of phi for Tweedie(p=1)y must be strictly positive for a Gamma densityy must be univariate unless binomialziplss requires 2 links specified as character stringsProject-Id-Version: R 3.2.0 / mgcv 1.8-5 Report-Msgid-Bugs-To: bugs@r-project.org POT-Creation-Date: 2017-02-06 09:59 PO-Revision-Date: 2015-03-26 13:29+0100 Last-Translator: Detlef Steuer Language-Team: R-Core Language: de MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n != 1); "fs" Glätter kann keine mehrfach bestrafte Basis nutzen (falsche Basis in xt)"fs" Ausdrücke können nicht hier festgelegt werden%s Link nicht verfügbar für die negativ-binomial-Familie; verfügare Links sind "identity", "log" und "sqrt"'family' Argument scheint kein zulässiges family Objekt zu sein'theta' muss angegeben werden,0s in V(mu)1= obere Grenze im Aufruf von mono.con()m kann nicht in re seinm hat falsche Länge und wird ignoriert.maximale Anzahl der Iterationen muss > 0 seinmean und mu müssen nicht-negativ sein.Methode nicht erkannt.min.sp wird bei schneller REML Berechnung nicht unterstützt und ignoriert.area names aus nb/poly und Daten passen nicht zusammenModell hat 1-d-Glättungen derselben Variable wiederholt.mehr Knoten als Daten in einem ds Term: Knoten ignoriert.mehr Knoten als Daten in einem tp-Term: Knoten ignoriert.mehr Knoten als Daten in einem sos Term: Knoten ignoriert.mehr Knoten als einheitliche Datenwerte sind nicht erlaubtmvn benötigt zwei- oder höherdimensionale DatenNamen von z und pc müssen übereinstimmenncol(M$C) != length(M$p)ncol(M$X) != length(M$p)mindestens ein Knoten im Inneren nötignegative Werte sind bei der negativ-binomial-Familie unzulässignegative Werte nicht zulässig für die null-inflationierte Poisson-Familienewdata ist ein model.frame: Es soll alle benötigten Variablen enthaltennlm.fd nur verfügbar für GCV/UBREkeine automatische Darstellung für Glättungen von mehr als einer Variablekeine automatische Darstellung für Glättungen von mehr als zwei Variablenkeine Daten zum Vorausberechnen vonkeine freien Koeffizienten in sf-Glättungkeine räumliche Information angegeben!es wurde keine gültige Menge von Koeffizienten gefunden: Bitte stellen Sie Startwerte bereitnicht existierende Terme angefordert - wird ignoriertnicht-endliche Koeffizienten bei Iteration %dkein gam Objektnicht alle benötigten Variablen wurden in newdata angegeben!nicht genug eindeutige Werte um die k nächsten zu findennichts zu tun für dieses Modellnrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)nthreads muss eine positive, ganze Zahl seinAnzahl der angegebenen Knoten != k für eine cc-GlättungAnzahl der angegebenen Knoten != k für eine cr-GlättungObjekt scheint nicht von der Klasse lme zu seinObejekt ist weder glm noch gamObjekt nicht voll initialisiertein oder mehrere bereitgestellte k zu klein - wird auf Standard zurückgesetztbehandelt nur den 2D Fallnur das erste Element von 'id' wird genutztnur eine Stufe von Glättungsverschachtelung wird von gamm unterstütztNur skalare 'p' und 'phi' erlaubt.Nur skalare 'rho' und 'theta' erlaubt.ord enthält Ordungen außerhalb des Wertebereichs (die ignoriert werden)ord ist falsch, wird auf NULL zurückgesetztOrdnung zu kleinp muss aus (1,2) seinp muss aus [1,2] seinDie p-Werte für einen Term, der auf Null bestraft werden kann, sind unzuverlässig: Modell wird neu angepasst, um dies zu korrigieren.p-Werte können unter Umständen geringere Power gebenp-Werte geben evtl. sehr geringe Powerp-Werte unzuverlässigp.type!=0 ist veraltet und wird in der Zukunft entferntparaPen für multi-formel Modelle nicht unterstütztParameter von ziplsspenalisierte Devianz = %sStraftermbasis ist zu groß für die GlättungsbasisStraftermordnung zu kleinStraftermspaltennamen passen nicht zu den angegebenen area names!Straftermmatrix, Grenzpolygone und/oder die Nachbarliste muss in xt angegeben werdenStraftermordnung zu groß für die Basisdimensionpredict.gam kann nur benutzt werden, um auf Basis von gam-Objekten vorherzusagenrandom-Argument muss eine *benannte* Liste sein.zufällige Effekte arbeiten nicht mit idsrecov funktioniert nur bei gefitteten gam ObjektenReparametrisierung für den Rand instabil: nicht durchgeführtverlangt ein Objekt der Klasse gamArgument residuals wird nicht unterstütztResiduen-Argument für plot.gam hat falsche Länge: Ignoriertrho fehlt in den Simulationsdaten, edf.type auf 2 zurückgesetzts Wert erhöhtS Wert verändert, um eine stetige Funktion zu erhaltens Wert reduzierts(.) wird noch nicht unterstützt.samfrac zu klein - ignoriertsaturierte Likelihood kann ungenau seinSkalenparameter muss positiv seinskalierte t df müssen >2 seinNebenbedingungnen nicht erlaubt für verschachtelte Glättungenunangemessene Toleranz angegebendummer Wert für rank.tol angegeben: Wird auf Quadratwurzel der Maschinenpräzision zurückgesetzt.Tensorprodukt-Glätter mit einfachem Strafterm sind veraltet und werden wahrscheinlich bald entferntSingulärwerte wurden nicht sortiert zurückgeliefertGlättungsobjekte sollten kein qrc-Attribut habenGlättungsparameterwahl nicht erkannt, falle zurück auf gammasoap films nur für bivariaten Falletwas stimmt nicht mit Argument d.Sorry, Link noch nicht implementiertEntschuldigung. Keine Option für Formgebung mit Fehlern: Versuchen Sie plot.gamSchritt fehlgeschlagen: max abs grad =angegebene Entfernung negativangegebene Knotenangegebener Strafterm nicht quadratisch!Angegebener Strafterm hat falsche Dimension!te Glättungen nicht nutzbar bei gamm4: nutze stattdessen t2Argument test ignoriertDie adaptive Glätterklasse ist beschränkt auf 1 oder 2 Kovariaten.da sollten seinzu wenige KnotenTyp iterms ist für den Fall multipler Prädiktoren nicht verfügbarTyp muss 'link' oder 'response' seinnicht unterstützte Methode zur Glattheitswahldas unbedingte Argument hat hier keine Bedeutungnicht implementierter dünn besetzter Nebenbedingungstyp verlangtunbekannter OptimiererUnbekannte äußere Optimierungsmethodeunbekanntes Glattheitswahl-Kriteriumunerkannter (Vektor?) Verweisnicht unterstützte Ordnung der Ableitung für gam.fit3 gefordertWert von epsilon muss > 0 seinWerte außerhalb des zulässigen BereichsVariablennamen passen nicht zu BegrenzungsnamenVarianzfunktion für quasi nicht erkanntDie view Variablen müssen aus %s gewählt werdenw hat eine von y verschiedene Länge!Gewichte ignoriertGewichte müssen wie glm-Gewichte sein für verallgemeinerten Fallohne eine Formelx und y müssen gleich lang seinx und y sind nicht gleich langx ist Nullx außerhalb des Wertebereichsxt-Argument ist fehlerhaft.y muss für Tweedie(p=1) ein ganzzahliges Vielfaches von phi seiny muss für die Gamma-Dichte streng positiv seinY muss univariat sein, falls nicht binomischziplss verlangt 2 Links, angegeben als Zeichenkettenmgcv/inst/CITATION0000744000177400001440000000447213020254562013521 0ustar murdochuserscitHeader("2011 for generalized additive model method; 2004 for strictly additive GCV based model method and basics of gamm; 2006 for overview; 2003 for thin plate regression splines; 2016 for jagam.") bibentry( bibtype="Article", title="Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models", journal="Journal of the Royal Statistical Society (B)", volume= "73", number="1", pages="3-36", year="2011", author="S. N. Wood", textVersion="Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36" ) bibentry( bibtype="Article", title= "Stable and efficient multiple smoothing parameter estimation for generalized additive models", journal="Journal of the American Statistical Association", volume= "99", number="467", pages="673-686", year="2004", author="S. N. Wood", textVersion="Wood, S.N. (2004) Stable and efficient multiple smoothing parameter estimation for generalized additive models.Journal of the American Statistical Association. 99:673-686." ) bibentry( bibtype="Book", title="Generalized Additive Models: An Introduction with R", year="2006", author="S.N Wood", publisher="Chapman and Hall/CRC", textVersion="Wood, S.N. (2006) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC. " ) bibentry( bibtype="Article", title="Thin-plate regression splines", journal="Journal of the Royal Statistical Society (B)", volume= "65", number="1", pages="95-114", year="2003", author="S. N. Wood", textVersion="Wood, S.N. (2003) Thin-plate regression splines. Journal of the Royal Statistical Society (B) 65(1):95-114." ) bibentry(bibtype = "Article", title = "Just Another Gibbs Additive Modeler: Interfacing {JAGS} and {mgcv}", author = "S. N. Wood", journal = "Journal of Statistical Software", year = "2016", volume = "75", number = "7", pages = "1--15", doi = "10.18637/jss.v075.i07", textVersion = paste("Simon N. Wood (2016).", "Just Another Gibbs Additive Modeler: Interfacing JAGS and mgcv.", "Journal of Statistical Software, 75(7), 1-15.", "doi:10.18637/jss.v075.i07") ) mgcv/src/0000755000177400001440000000000013046054035012167 5ustar murdochusersmgcv/src/mgcv.h0000755000177400001440000002640213046054035013303 0ustar murdochusers/* main method routines */ #include #include /* Most compilers with openMP support supply a pre-defined compiler macro _OPENMP. Following facilitates selective turning off (by testing value or defining multiple versions OPENMP_ON1, OPENMP_ON2...) */ #if defined _OPENMP #define OPENMP_ON 1 #endif /* ... note also that there is no actual *need* to protect #pragmas with #ifdef OPENMP_ON, since C ignores undefined pragmas, but failing to do so may produce alot of compilation warnings if openMP is not supported. In contrast functions from omp.h must be protected, and there is non-avoidable use of these in the mgcv code. */ //#define OMP_REPORT // define to have all routines using omp report on start and end. /* sed -i 's/old-text/new-text/g' *.c is quite useful!! */ // For safe memory handling from R... #define CALLOC R_chk_calloc #define FREE R_chk_free // Can reset to check for memory errors... //#define CALLOC calloc //#define FREE free void magic(double *y,double *X,double *sp0,double *def_sp,double *S,double *H,double *L, double *lsp0,double *gamma,double *scale, int *control,int *cS,double *rank_tol, double *tol,double *b,double *rV,double *norm_const,int *n_score,int *nt); void gdi1(double *X,double *E,double *Es,double *rS,double *U1, double *sp,double *z,double *w,double *wf,double *alpha,double *mu,double *eta, double *y, double *p_weights,double *g1,double *g2,double *g3,double *g4,double *V0, double *V1,double *V2,double *V3,double *beta,double *b1,double *w1,double *D1,double *D2, double *P0, double *P1,double *P2,double *trA, double *trA1,double *trA2,double *rV,double *rank_tol,double *conv_tol, int *rank_est, int *n,int *q, int *M,int *Mp,int *Enrow,int *rSncol,int *deriv, int *REML,int *fisher,int *fixed_penalty,int *nthreads,double *dVkk); void gdi2(double *X,double *E,double *Es,double *rS,double *U1, double *sp,double *theta,double *z,double *w,double *wz,double *wf, double *Dth,double *Det,double *Det2,double *Dth2,double *Det_th, double *Det2_th,double *Det3,double *Det_th2, double *Det4, double *Det3_th, double *Det2_th2, double *beta,double *b1,double *w1,double *D1,double *D2,double *P,double *P1,double *P2, double *ldet, double *ldet1,double *ldet2,double *rV, double *rank_tol,int *rank_est, int *n,int *q, int *M,int *n_theta, int *Mp,int *Enrow,int *rSncol,int *deriv, int *fixed_penalty,int *nt,int *type,double *dVkk); void pls_fit1(double *y,double *X,double *w,double *wy,double *E,double *Es,int *n,int *q,int *rE,double *eta, double *penalty,double *rank_tol,int *nt,int *use_wy); void get_detS2(double *sp,double *sqrtS, int *rSncol, int *q,int *M, int * deriv, double *det, double *det1, double *det2, double *d_tol, double *r_tol,int *fixed_penalty); /* stable determinant of sum evaluation */ void get_stableS(double *S,double *Qf,double *sp,double *sqrtS, int *rSncol, int *q,int *M, int * deriv, double *det, double *det1, double *det2, double *d_tol, double *r_tol,int *fixed_penalty); /* cox model routines */ void coxpred(double *X,double *t,double *beta,double *Vb,double *a,double *h,double *q, double *tr,int *n,int *p, int *nt,double *s,double *se); void coxpp(double *eta,double *X,int *r, int *d,double *h,double *q,double *km, int *n,int *p, int *nt); void coxlpl(double *eta,double *X,int *r, int *d,double *tr, int *n,int *p, int *nt,double *lp,double *g,double *H, double *d1beta,double *d1H,double *d2beta, double *d2H,int *n_sp,int *deriv); /* MVN smooth additive */ void mvn_ll(double *y,double *X,double *XX,double *beta,int *n,int *lpi, int *m,double *ll,double *lb,double *lbb,double *dbeta, double *dH,int *deriv,int *nsp,int *nt); /* discretized covariate methods */ void XWXd(double *XWX,double *X,double *w,int *k,int *ks, int *m,int *p, int *n, int *nx, int *ts, int *dt, int *nt,double *v,int *qc,int *nthreads,int *ar_stop, int *ar_row,double *ar_weights); void XWyd(double *XWy,double *y,double *X,double *w,int *k, int *ks, int *m,int *p, int *n, int *nx, int *ts, int *dt, int *nt,double *v,int *qc, int *ar_stop,int *ar_row,double *ar_weights); void Xbd(double *f,double *beta,double *X,int *k, int *ks, int *m,int *p, int *n, int *nx, int *ts, int *dt, int *nt,double *v,int *qc,int *bc); void diagXVXt(double *diag,double *V,double *X,int *k,int *ks,int *m,int *p, int *n, int *nx, int *ts, int *dt, int *nt,double *v,int *qc,int *pv,int *nthreads); /* various service routines */ void tweedious(double *w,double *w1,double *w2, double *w1p,double *w2p,double *w2pp, double *y,double *eps,int *n, double *th,double *rho,double *a, double *b); void tweedious2(double *w,double *w1,double *w2, double *w1p,double *w2p,double *w2pp, double *y,double *eps,int *n, double *th,double *rho,double *a, double *b); void psum(double *y, double *x,int *index,int *n); void rwMatrix(int *stop,int *row,double *w,double *X,int *n,int *p,int *trans,double *work); void in_out(double *bx, double *by, double *break_code, double *x,double *y,int *in, int *nb, int *n); void Rlanczos(double *A,double *U,double *D,int *n, int *m, int *lm,double *tol,int *nt); void RuniqueCombs(double *X,int *ind,int *r, int *c); void RPCLS(double *Xd,double *pd,double *yd, double *wd,double *Aind,double *bd,double *Afd,double *Hd,double *Sd,int *off,int *dim,double *theta, int *m,int *nar); void RMonoCon(double *Ad,double *bd,double *xd,int *control,double *lower,double *upper,int *n); /*void MinimumSeparation(double *gx,double *gy,int *gn,double *dx,double *dy, int *dn,double *dist);*/ void MinimumSeparation(double *x,int *n, int *d,double *t,int *m,double *dist); void rksos(double *x,int *n,double *eps); void pivoter(double *x,int *r,int *c,int *pivot, int *col, int *reverse); /* Routines for linear algebra with direct access to linpack and lapack */ void band_chol(double *B,int *n,int *k,int *info); void tri_chol(double *ld,double *sd,int *n,int *info); void mgcv_omp(int *a); void mgcv_chol(double *a,int *pivot,int *n,int *rank); void mgcv_svd(double *x,double *u, double *d,int *r,int *c); void mgcv_qrqy(double *b,double *a,double *tau,int *r,int *c,int *k,int *left,int *tp); void mgcv_qrqy0(double *b,double *a,double *tau,int *r,int *c,int *k,int *left,int *tp); void mgcv_backsolve(double *R,int *r,int *c,double *B,double *C, int *bc, int *right); void mgcv_forwardsolve(double *R,int *r,int *c,double *B,double *C, int *bc, int *right); void mgcv_qr(double *x, int *r, int *c,int *pivot,double *tau); void mgcv_qr2(double *x, int *r, int *c,int *pivot,double *tau); void update_qr(double *Q,double *R,int *n, int *q,double *lam, int *k); extern void mgcv_mmult(double *A,double *B,double *C,int *bt,int *ct,int *r,int *c,int *n); void mgcv_pmmult(double *A,double *B,double *C,int *bt,int *ct,int *r,int *c,int *n,int *nt); SEXP mgcv_pmmult2(SEXP b, SEXP c,SEXP bt,SEXP ct, SEXP nthreads); void mgcv_mmult0(double *A,double *B,double *C,int *bt,int *ct,int *r,int *c,int *n); void mgcv_svd_full(double *x,double *vt,double *d,int *r,int *c); void mgcv_symeig(double *A,double *ev,int *n,int *use_dsyevd, int *get_vectors,int *descending); void mroot(double *A,int *rank,int *n); void R_cond(double *R,int *r,int *c,double *work,double *Rcondition); void mgcv_td_qy(double *S,double *tau,int *m,int *n, double *B,int *left,int *transpose); void mgcv_tri_diag(double *S,int *n,double *tau); void mgcv_trisymeig(double *d,double *g,double *v,int *n,int getvec,int descending); void getXtWX(double *XtWX, double *X,double *w,int *r,int *c,double *work); void getXtX(double *XtX,double *X,int *r,int *c); void getXtMX(double *XtMX,double *X,double *M,int *r,int *c,double *work); void getXXt(double *XXt,double *X,int *r,int *c); void read_mat(double *M,int *r,int*c, char *path); void row_block_reorder(double *x,int *r,int *c,int *nb,int *reverse); void mgcv_pqr(double *x,int *r, int *c,int *pivot, double *tau, int *nt); void getRpqr(double *R,double *x,int *r, int *c,int *rr,int *nt); void mgcv_pqrqy(double *b,double *a,double *tau,int *r,int *c,int *cb,int *tp,int *nt); SEXP mgcv_Rpiqr(SEXP X, SEXP BETA,SEXP PIV,SEXP NT,SEXP NB); void mgcv_tmm(SEXP x,SEXP t,SEXP D,SEXP M, SEXP N); void mgcv_Rpbsi(SEXP A, SEXP NT); void mgcv_RPPt(SEXP a,SEXP r, SEXP NT); SEXP mgcv_Rpchol(SEXP Amat,SEXP PIV,SEXP NT,SEXP NB); void dchol(double *dA, double *R, double *dR,int *p); void vcorr(double *dR,double *Vr,double *Vb,int *p,int *M); SEXP mgcv_Rpforwardsolve(SEXP R, SEXP B,SEXP NT); SEXP mgcv_Rpcross(SEXP A, SEXP NT,SEXP NB); /* basis constructor/prediction routines*/ void crspl(double *x,int *n,double *xk, int *nk,double *X,double *S, double *F,int *Fsupplied); void predict_tprs(double *x, int *d,int *n,int *m,int *k,int *M,double *Xu,int *nXu, double *UZ,double *by,int *by_exists,double *X); void construct_tprs(double *x,int *d,int *n,double *knt,int *nk,int *m,int *k,double *X,double *S, double *UZ,double *Xu,int *nXu,double *C); void gen_tps_poly_powers(int *pi,int *M,int *m, int *d); void boundary(int *G, double *d, double *dto, double *x0, double *y0, double *dx, double *dy, int *nx, int *ny, double *x, double *y,double *break_code, int *n, int *nb); void gridder(double *z,double *x,double *y,int *n,double *g, int *G,int *nx, int *ny,double *x0, double *y0,double *dx,double *dy,double NA_code); void pde_coeffs(int *G,double *x,int *ii,int *jj,int *n,int *nx,int *ny,double *dx,double *dy); /* sparse smooth related routines */ typedef struct { /* defines structure for kd-tree box */ double *lo,*hi; /* box defining co-ordinates */ int parent,child1,child2, /* indices of parent and 2 offspring */ p0,p1; /* indices of first and last point in box */ } box_type; typedef struct { box_type *box; int *ind, /* index of points in coordinate matrix which tree relates to */ *rind, /* where is ith row of X in ind? */ n_box, /* number of boxes */ d, /* dimension */ n; /* number of points that tree relates to */ double huge; /* number indicating an open boundary */ } kdtree_type; void k_newn_work(double *Xm,kdtree_type kd,double *X,double *dist,int *ni,int*m,int *n,int *d,int *k); void k_nn(double *X,double *dist,double *a,int *ni,int *n,int *d,int *k,int *get_a); void Rkdtree(double *X,int *n, int *d,int *idat,double *ddat); void Rkdnearest(double *X,int *idat,double *ddat,int *n,double *x, int *m, int *ni, double *dist,int *k); void Rkradius(double *r,int *idat,double *ddat,double *X,double *x,int *m,int *off,int *ni,int *op); double xidist(double *x,double *X,int i,int d, int n); int closest(kdtree_type *kd, double *X,double *x,int n,int *ex,int nex); void kd_tree(double *X,int *n, int *d,kdtree_type *kd); void free_kdtree(kdtree_type kd); void tri2nei(int *t,int *nt,int *n,int *d,int *off); void nei_penalty(double *X,int *n,int *d,double *D,int *ni,int *ii,int *off, int *m,int *a_weight,double *kappa); void sspl_construct(double *lambda,double *x,double *w,double *U,double *V, double *diagA,double *lb,int *n,double *tol); void sspl_mapply(double *y,double *x,double *w,double *U,double *V,int *n,int *nf,double *tol,int *m); mgcv/src/matrix.c0000755000177400001440000015120713046054035013650 0ustar murdochusers/* Copyright (C) 1991-2005 Simon N. Wood simon.wood@r-project.org 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. (www.gnu.org/copyleft/gpl.html) You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.*/ /* Routines for basic matrix manipulation creation, destruction and file i/o for matrices. See end of file for update log */ #include #include #include #include #include #include #include "mgcv.h" #include "matrix.h" #include "general.h" #define RANGECHECK #define PAD 1 #define ROUND(a) ((a)-(int)floor(a)>0.5) ? ((int)floor(a)+1):((int)floor(a)) matrix null_mat; /* matrix for passing when you don't actually need to */ #define PADCON (-1.234565433647588392902028934e270) /* counter for memory used */ long memused=0L,matrallocd=0L; /* the routines */ struct mrec { matrix mat; struct mrec *fp,*bp; }; typedef struct mrec MREC; matrix null_mat; MREC *top,*bottom; matrix initmat(int rows,int cols) /* Don't alter this without altering freemat() as well !! */ { matrix A;int i,j,pad; #ifdef RANGECHECK pad=PAD; #else pad=0; #endif A.vec=0; A.M=(double **)CALLOC((size_t)(rows+2*pad),sizeof(double *)); if ((cols==1)||(rows==1)) { if (A.M) A.M[0]=(double *)CALLOC((size_t)(cols*rows+2*pad),sizeof(double)); for (i=1;i0)) { error(_("Failed to initialize memory for matrix."));} if (pad) /* This lot is debugging code that checks out matrix errors on allocation and release */ { if (A.vec) { A.V=A.M[0];for (i=0;imat=top->mat=A;top->bp=bottom;bottom->fp=top; } else /* expanding the linked list by one */ { top->fp=(MREC *)CALLOC(1,sizeof(MREC)); top->fp->mat=A;top->fp->bp=top;top=top->fp; /* crystal clear, no? */ } } A.V=A.M[0];/* This allows vectors to be accessed using A.V[i] */ return(A); } matrix initvec(int rows) { return(initmat(1,rows));} void freemat(matrix A) { int i,j,pad;int ok=1; MREC *delet; #ifdef RANGECHECK pad=PAD; #else pad=0; #endif /* if (A.original_r*A.original_c!=0L) */ { if (pad) { if (A.vec) { for (i=-pad;i<0;i++) if ((A.V[i]!=PADCON)||(A.V[i+A.original_r*A.original_c+pad]!=PADCON)) ok=0; } else { for (i=-pad;imat.M!=A.M)) { i++;delet=delet->fp;} if (i==matrallocd) { error(_("INTEGRITY PROBLEM in the extant matrix list.")); } else { if (i) delet->bp->fp=delet->fp; else bottom=delet->fp; if (i!=matrallocd-1) delet->fp->bp=delet->bp; else top=delet->bp; FREE(delet); } /* repositioning pointers so that what was allocated gets freed */ if (!A.vec) for (i=0;imat; if (A.vec) { for (i=-pad;i<0;i++) if ((A.V[i]!=PADCON)||(A.V[i+A.original_r*A.original_c+pad]!=PADCON)) ok=0; } else { for (i=-pad;ifp; } } void vmult(matrix *A,matrix *b,matrix *c,int t) /* fast multiplication of vector by matrix c=Ab if t==0 c=A'b otherwise*/ { double **AM,*bV,*cV,*p; int i,j,cr,br; cr=c->r;br=b->r; AM=A->M;bV=b->V;cV=c->V; if (t) /* then A transposed */ for (i=0;ir>B->r||A->c>B->c) error(_("Target matrix too small in mcopy")); BM=B->M;Ac=A->c; for (AM=A->M;AMM+A->r;AM++) { pB= *BM; for (pA= *AM;pA< *AM+Ac; pA++) *(pB++) = *pA; BM++; } } void matmult(C,A,B,tA,tB) matrix C,A,B;int tA,tB; /* Puts A*B in C. A will be transposed in this calculation if tA is not zero. B will be transposed if tB is not zero */ { int i,j,k; double temp,*p,*p1,*p2,**CM,**AM,**BM; AM=A.M;BM=B.M;CM=C.M; /* Saves address calculation involved in C.M */ if (tA) { if (tB) { if ((A.r!=B.c)||(A.c!=C.r)||(B.r!=C.c)) { error(_("Incompatible matrices in matmult."));} for (i=0;i2) temp0=initmat(r,c);else temp0=C; matmult(temp0,M[0],M[1],t[0],t[1]); for (i=1;i2) { matmult(C,temp0,M[n-1],0,t[n-1]); freemat(temp0); } FREE(t); FREE(M); va_end(argptr); } void invert(matrix *A) /* Matrix inversion by Guass-Jordan Elimination with full pivoting. See "Numerical Recipes", and Burden and Faires "Numerical Analysis", for basis of method (but not actual code). This version written as part of elimination of "Numerical Recipes" routines from my code. Tested against Numerical Recipes code with a variety of random matrices - fine on accuracy and speed. 13/1/2000 */ { double **AM,*p,*p1,max,x; int *c,*rp,*cp,i,j,k,pr=0,pc=0,*d,cj,ck; if (A->r!=A->c) error(_("Attempt to invert() non-square matrix")); c=(int *)CALLOC((size_t)A->c,sizeof(int)); /* index of columns, used for column pivoting */ d=(int *)CALLOC((size_t)A->c,sizeof(int)); rp=(int *)CALLOC((size_t)A->c,sizeof(int)); /* row changes */ cp=(int *)CALLOC((size_t)A->c,sizeof(int)); /* row changes */ for (i=0;ic;i++) { c[i]=i;d[i]=i;} AM=A->M; /* saving adress calculations*/ for (j=0;jc;j++) /* loop through columns to be reduced */ { max=0.0; for (i=j;ir;i++) /* loop through rows to search for pivot */ { p=AM[i]; for (k=j;kc;k++) /* loop through cols to search for pivot */ { x=p[c[k]];if (fabs(x)>max) { max=fabs(x);pr=i;pc=k;}} } /* now move pivot to element j,j */ p=AM[j];AM[j]=AM[pr];AM[pr]=p; /* rows exchanged */ k=c[j];c[j]=c[pc];c[pc]=k; /* columns exchanged */ rp[j]=pr; /* stores row pivoted with */ cp[j]=pc; /* stores column pivoted with */ cj=c[j]; /* save time */ /* Now reduce the column */ x=AM[j][cj]; if (x==0.0) error(_("Singular Matrix passed to invert()")); for (p=AM[j];pc;p++) *p/=x; /* divide row j by pivot element */ AM[j][cj]=1.0/x; for (i=0;ir;i++) /* work down rows eliminating column j */ { p=AM[i];p1=AM[j]; if (i!=j) { x = -p[cj]; /* multiplier for this row */ for (k=0;kc;k++) /* cols of A */ { ck=c[k];p[ck]+=x*p1[ck];} } } } for (i=A->r-1;i>=0;i--) /*work down through column re-ordering */ { if (cp[i]!=i) { p=AM[i];AM[i]=AM[cp[i]];AM[cp[i]]=p; /* row exchange */ } } for (j=0;jc-1;j++) /* implement column exchange */ if (c[j]!=j) { if (c[j]r;i++) { p=AM[i];x=p[j];p[j]=p[k];p[k]=x;} d[k]=d[j];d[j]=c[j]; c[d[k]]=k; } for (i=A->r-1;i>=0;i--) /* column exchange implied by row re-ordering */ if (rp[i]!=i) { for (k=0;kr;k++) { p=AM[k];x=p[i];p[i]=p[rp[i]];p[rp[i]]=x;} /* column exchange */ } FREE(c);FREE(rp);FREE(cp);FREE(d); } void tricholeski(matrix *T,matrix *l0,matrix *l1) /* Routine for choleski decomposition of the tridiagonal matrix T. If L is the matrix with leading diagonal in vector l0 and leading subdiagonal in l1, then T=LL'. The routine is O(n). Note that not only is multiplication of a matrix by L 0(n^2), but formation of A=inv(L)B can be done in O(n^2) by solution of LA=B. Note also that the trace of the inverse of a tri-diagonal matrix can be found cheaply using Elden's trick - see p137 of Wahba. 20/11/99: Now has steps to deal with +ve semi definite matrices by a slight modification of the choleski decomposition. The modification zeros elements of the decomposition, as needed. The zeroing steps are valid for +ve semi-definite (non-negative definite) matrices (only), for the following reasons: 0. a +ve semi definite matrix that is not +ve definite, must have zero eigenvalues as is easily seen by spectral decomposition. 1. A properly tri-diagonal symmetric rank m (sub)matrix has m or m+1 non-zero rows and columns. This can be seen by counting up the number of possible independent rows and columns of an m+1 by m+1 properly tri-diagonal matrix. 2. So a +ve semi-definite properly tridiagonal (sub) matrix has at most 1 non-independent row/col, i.e. at most one zero eigenvalue. 3. When present, this non-independence leads to a zero on the final element of the leading diagonal of the choleski decomposition of a properly tridiagonal +ve semi-definite (sub)matrix (I thought I had a proof of this, but am now not sure!). 4. Zeroing outside properly tridiagonal sections of the matrix is clearly ok. Note that these arguments only hold for +ve semi-definite tri-diagonal matrices. Merely being symmetric won't do, and neither will merely being +ve semi-definite! NOTE: that this routine will not detect none +ve semi-definite matrices, the only way to do that is to check whether the decomposition actually works (it won't for a matrix that isn't +ve semi-definite) */ { double **TM,*l1V,*l0V,z=1.0; int k1,k; TM=T->M;l0V=l0->V;l1V=l1->V; l0V[0]=sqrt(TM[0][0]); for (k=1;kr;k++) { k1=k-1; if (z>0.0) l1V[k1]=TM[k][k1]/l0V[k1]; /* no problem */ else l1V[k1]=0.0; /* assume TM[k][k1]=0, so no problem */ z=l1V[k1];z=TM[k][k]-z*z; if (z>0.0) l0V[k]=sqrt(z); else l0V[k]=0.0; } } double dot(a,b) matrix a,b; { int i,k=0;double c=0.0,*p,*p1; if (a.vec) { p1=b.V;for (p=a.V;pm) m=y; } else for (i=0;im) m=y;}/* m=max(m,fabs(*p)); */ if (!m) return(0.0); if (d.vec) for (p=d.V;pV; u->r=t1+1; for (i=0;ir;i++) uV[i]=aV[i]-bV[i]; v=enorm((*u))/sqrt(2.0); for (i=0;ir;i++) uV[i]/=v; } void Hmult(C,u) matrix C,u; /* This routine is for post multiplication by Housholder matrices only */ { double temp,*p,*p1,*uV,**CuM,**CM; int i,j; matrix Cu; Cu=initmat(C.r,u.c); uV=u.V;CuM=Cu.M;CM=C.M; for (i=0;i CQ; p==0,t==1 => CQ'; p==1,t==0 => QC; p==1,t==1 => Q'C NOTE that the routine expects C to be compatible with the Hi's - if this routine is being used for projection in and out of Null spaces, then make sure that C is appropriately packed with zeroes. If appropriate zero packing conventions have been used then OrthMult() is more efficient.... */ { double *u,*CuV,**CM; matrix Cu; int i,j,k; if (p) Cu=initmat(C.c,1);else Cu=initmat(C.r,1); CuV=Cu.V;CM=C.M; if (p) { if (t) { for (k=0;k=0;k--) /* loop through the householder matrices */ { u=U.M[k]; for (i=0;i=0;k--) /* loop through the householder matrices */ { u=U.M[k]; for (i=0;i0) { for (i=0;im) m=x;} /* scale factor */ if (m) for (j=0;jc,A->r); AM=A->M;AtM=At.M; for (i=0;ir;i++) for (j=0;jc;j++) AtM[j][i]=AM[i][j]; t=1-t; } else At=*A; AM=At.M;QM=Q->M;Ar=At.r;Qc=Q->c; for (kk=0;kkM; for (i=0;iV;yV=y->V; if (y->r==1) /* then p and y are vectors */ { if (transpose) /* solve R'p=y for p */ { RM=R->M; for (i=0;ir;i++) { x=0.0;dum=pV;for (j=0;jr-1;i>=0;i--) { RMi=R->M[i]; x=0.0;for (j=i+1;jr;j++) x+=RMi[j]*pV[j]; pV[i]=(yV[i]-x)/RMi[i]; } } else /* p and y are matrices */ { pM=p->M;yM=y->M; if (transpose) /* solve R'p=y for p */ { RM=R->M; for (k=0;kc;k++) for (i=0;ir;i++) { x=0.0;for (j=0;jc;k++) for (i=R->r-1;i>=0;i--) { RMi=R->M[i]; x=0.0;for (j=i+1;jr;j++) x+=RMi[j]*pM[j][k]; pM[i][k]=(yM[i][k]-x)/RMi[i]; } } } int QR(matrix *Q,matrix *R) /* Does a QR factorisation of the matrix supplied in R. In Q the householder vectors are supplied to perform the transformation QR(in) -> R(out) R(out) is upper triangular (elements are 0 below leading diagonal). If Q->r is none zero then the vectors u are stored in successive rows of Q. The u vectors make up Q as a series of (stable) householder transformations. (I-uu'). The transformations are to be applied from the left in row order. The first i elements of the ith u are zero (i starting at zero). If A is the matrix input in R then QA=R, so that A=Q'R. Q can be used with OrthoMult(). Under/overflow avoidance added 13/1/2000 along with more efficient calculation of length of u (modifications tested). */ { int i,j,k,n,Rr; double *u,t,z,**RM,*p,m; RM=R->M;Rr=R->r; if (Rrc) n=Rr; else n=R->c; u=(double *)CALLOC((size_t)Rr,sizeof(double)); for (k=0;km) m=z;} if (m) for (i=k;i0.0) t = -sqrt(t);else t= sqrt(t); /* value of new RM[k][k] (stable) */ for (i=k+1;ic;j++) { t=0.0;for (i=k;ir) /* store vectors u for making Q */ { p=Q->M[k]; for (i=k;iM; if (col) for (k=0;kr;k++) { t=MM[k][i];MM[k][i]=MM[k][j];MM[k][j]=t;} else for (k=0;kc;k++) { t=MM[i][k];MM[i][k]=MM[j][k];MM[j][k]=t;} } void UTU(matrix *T,matrix *U) /* does orthogonal tridiagonalisation of the symmetric matrix supplied in T; U is returned with successive householder vectors in successive rows of U. The first i+1 elements of the ith row will be zero (i starts at 0). There are only T->r - 2 non-zero rows. The transformations must be applied in order from the right. Recall that a householder transformation to take a->b is constructed as follows: u=a-b; u=u/sqrt(u'u/2); H=(I-uu'); then Ha=b and a'H=b' (of course to form Ha... form u'a; form u(u'a); form a-u(u'a); never form H first!). If A is the input matrix then U'AU=T => A=UTU' Underflow and overflow protection added 13/1/2000, and lt efficiency improved. Improved code tested with variety of random matrices. (Householder rotations are stable.) OrthoMult() works with U storage convention used here. */ { int i,j,k; double *u,*t,lt,x,m; for (i=0;ir-2;i++) { u=U->M[i];t=T->M[i];lt=0.0; m=0.0;for (j=i+1;jc;j++) { x=fabs(t[j]); if (mc;j++) t[j]/=m; /* avoid over/underflow */ for (j=i+1;jc;j++) lt+=t[j]*t[j]; if (t[i+1]>0.0) lt= -sqrt(lt);else lt=sqrt(lt); /* ensures stability (by maximising element i+1 of u) */ x=t[i+1]; /* stored for altering lt efficiently */ u[i+1]=lt-t[i+1];T->M[i+1][i]=t[i+1]=lt*m; lt*=lt;lt+= -x*x+u[i+1]*u[i+1]; for (j=i+2;jc;j++) { u[j]= -t[j];T->M[j][i]=t[j]=0.0;} if (lt>0.0) /* only do this if u is non-zero */ { lt=sqrt(0.5*lt); for (j=i+1;jc;j++) u[j]/=lt; } for (j=i+1;jc;j++) /* apply rotations to remaining rows */ { t=T->M[j];lt=0.0; for (k=i+1;kc;k++) lt+=u[k]*t[k]; for (k=i+1;kc;k++) t[k] -= u[k]*lt; } /* Apply rotations from the left */ for (j=i+1;jc;j++) { lt=0.0; for (k=i+1;kc;k++) lt+=u[k]*T->M[k][j]; for (k=i+1;kc;k++) T->M[k][j] -= u[k]*lt; } } } void root(matrix *M,matrix *C,double tol) /* produces a square root of non-negative definite M, by obtaining M=UTU', then getting the choleski decomposition of the non-zero part of T. T=LL' so C=UL and M=CC'.... C will have as few columns as possible. C is initialised in this routine. Upgraded 20/11/99: Previous version assumed that zero rows and columns only occured at the end of T. This is no longer the case. tricholeski() has been modified to deal with non-negative definite T (although this may still be weakest link). If L contains a column of zeros then this column is ommitted from C altogether. zero is judged relative to tol multiplied by the maximum element on the leading diagonal of L if tol>0, otherwise zero is any number that leads to no change in the maximum element when added to it. Algorithm appears to be substantially better than svdroot() (and should be much quicker). Commented out code is the old code, left in in case of future difficulties: when it is removed some further tidying could be done. 16/1/2000: tested with variety of random rank deficient matrices, and theoretical basis re-checked more carefully - see tricholeski() comments. */ { matrix T,U,u0,u1; int i,j,k,rows; int fswap=0,ok; double max,uc,*u,x,m; T=initmat(M->r,M->c); U=initmat(M->r,M->c); for (i=0;iM[i][j]; UTU(&T,&U); /* make absolutely symmetric */ for (i=0;imax) max=fabs(T.M[i][i]); ok=1;x=u0.V[0]*u0.V[0]-T.M[0][0];m=0.0; if (x>m) m=x; for (i=1;im) { m=x;k=i;} x=u1.V[i-1]*u1.V[i-1]+u0.V[i]*u0.V[i]-T.M[i][i];x=fabs(x); if (x>m) { m=x;k=i;} } if (m>10.0*DOUBLE_EPS*max) ok=0; if (!ok) { (*C)=svdroot(*M,tol); freemat(U);freemat(T);freemat(u0);freemat(u1); return; } freemat(T); T=initmat(U.r,u0.r); /* now apply householder rotations from the left to obtain C=UL */ for (i=0;i=0;i--) { u=U.M[i]; /* first i+1 elements of u are zero */ for (j=0;jtol*max)||(fabs(T.M[i][j])>tol*max)) {ok=1;break;}} if (ok) /* then include this column */ { for (i=0;ir;i++) C->M[i][k]=T.M[i][j]; k++; } } C->c=k; if (fswap) { interchange(C,1,0,0);} freemat(T);freemat(U);freemat(u0);freemat(u1); } void bidiag(matrix *A,matrix *wl,matrix *ws,matrix *V) /* This routine bi-diagonalizes A using Housholder rotations applied from left and right. wl and ws are vectors of dimension A.c and A.c-1 respectively. V is an orthogonal A.c by A.c matrix. Let W be the matrix with wl as leading diagonal and ws as leading superdiagonal, then: A = UWV' where U is orthogonal and output in A. The routine's main use is as the first stage in a singular value decomposition of A. The Orthogonal matrices are composed of Householder rotations applied left, right, left, right, left, right etc. The left rotations (reflectors) zero elements of A in columns below the leading diagonal starting from the left. The right reflectors zero elements of A in rows left of the first super diagonal starting from the top. Reflectors are calculated as described on p149 of Watkins (1991) Fundamentals of Matrix Computations, Wiley (but note that \gamma<-1/\sigma x_1 should read \gamma<-(\sigma x_1 )!!). Reflectors are of the form H=(I-g*uu'), where u is a vector and g a scalar. This routine has been tested on a variety of random matrices of differing dimensions as well as on strictly singular matrices. The tests checked that A = UWV'. Most important address optimization has been performed. 9/1/2000 */ { double m,s=0.0,g,temp,**AM,**VM,*p,*p1; int i,j,k,nv,nu; nv=0; /* counts up number of v_i's */ AM=A->M;VM=V->M; for (i=0;ic;i++) { wl->V[i]=0.0;if (ic-1) ws->V[i]=0.0; if (ir) /* zero subdiagonal column i */ { m=0.0;for (j=i;jr;j++) { s=fabs(AM[j][i]); if (s>m) m=s;} /* max of column for scaling */ if (m==0.0) g=0.0; else /* work out reflector elements */ { s=0.0;for (j=i;jr;j++) { AM[j][i]/=m;s+=AM[j][i]*AM[j][i];} /* scale reflector etc. */ s=sqrt(s); if (AM[i][i]<0.0) s = -s; /* avoid cancellation error */ AM[i][i]+=s; g=1/(AM[i][i]*s); s*=m; } /* Now u is stored in rows i to A.r of column i of A */ wl->V[i] = -s; VM[i][i] = g; /* temporary storage for g, for use in later assembly of U */ /* must apply reflector to remaining columns */ for (j=i+1;jc;j++) { s=0.0;for (k=i;kr;k++) s+=AM[k][i]*AM[k][j]; s*=g;for (k=i;kr;k++) AM[k][j] += -s*AM[k][i]; } } /* zero elements i+2 to A.c of row i ..... */ if ((ir) && (ic-1)) { m=0.0;/*for (j=i+1;jc;j++) { s=fabs(AM[i][j]); if (s>m) m=s;} */ /* max for scaling */ for (p=AM[i]+i+1;pc;p++) { s=fabs(*p);if (s>m) m=s;} /* max for scaling */ if (m==0.0) g=0.0; else { s=0.0;/*for (j=i+1;jc;j++) { AM[i][j]/=m;s+=AM[i][j]*AM[i][j];} */ for (p=AM[i]+i+1;pc;p++) { *p/=m;s+=(*p)*(*p);} s=sqrt(s); if (AM[i][i+1]<0.0) s = -s; /* avoid cancellation error */ AM[i][i+1] += s; g=1.0/(AM[i][i+1]*s); s*=m; } ws->V[i] = -s; VM[i][i+1]=g; /* temporary storage */ /* Now apply reflector to remaining rows */ for (j=i+1;jr;j++) { s=0.0;/*for (k=i+1;kc;k++) s+=AM[i][k]*AM[j][k]; */ p1=AM[j]+i+1;for (p=AM[i]+i+1;pc;p++) { s+=(*p)*(*p1);p1++;} s*=g;/*for (k=i+1;kc;k++) AM[j][k] += -s*AM[i][k]; */ p1=AM[j]+i+1;for (p=AM[i]+i+1;pc;p++) { *p1 += -s*(*p);p1++;} } nv++; /* number of v_i's */ } } /* At this point wl and ws are complete, but U and V are stored in A as reflector vectors, with associated g values stored on the leading diagonal and leading superdiagonal of V. Now form U and V. U is the first A.c columns of U_1 U_2 U_3 .... i.e. U_1 U_2 U_3 ... [I,0]'(same dim as A) where U_i = (I - g_i u_i u_i'): g_i is in V->M[i][i] and u_i is zero up to element i, with the remaining elements stored in rows i to A.r of column i of A. V= V_1 V_2 V_3 ... where V_i = (I-d_i v_i v_i') where d_i=V->M[i][i+1]. v_i is zero until element i+1, with remaining elements stored in columns i+1 to A.c of row i of A. */ /* first form V in order to free up space in A */ /* initialize rows nv to A->c of V */ nu=A->c; if (A->rr; /* number of U_i's */ for (i=nv+1;ic;i++) for (p=VM[i];pc;p++) *p=0.0; for (i=A->c-1;i>nv;i--) { if (i=0;i--) /* working down through the V_i's */ { temp=VM[i+1][i+1]; /* for (j=0;jc;j++) VM[i+1][j]=0.0; */ for (p=VM[i+1];pc;p++) *p=0.0; VM[i+1][i+1]=1.0; /* initialize row of V */ for (j=A->c-1;j>i;j--) /* columns affected by V_i */ { s=0.0;p=AM[i]+i+1;for (k=i+1;kc;k++) { s+=VM[k][j]*(*p);p++;} s*=VM[i][i+1]; p=AM[i]+i+1;for (k=i+1;kc;k++) { VM[k][j] += -s*(*p);p++;} } AM[i][i+1]=temp; /* temporary storage for g_i's */ } /* Now all but first row and column of V are formed, but V->M[0][0] still contains g_0, while g_i is in AM[i-1][i] otherwise, so form U now and then finish off V */ for (i=nu-1;i>=0;i--) /* work down through the u_i's */ { if (i>0) g=AM[i-1][i]; else g=VM[0][0]; for (j=0;jc-1;j>i;j--) /* columns above i are affected */ { s=0.0;for (k=i;kr;k++) s+= AM[k][i]*AM[k][j]; s*=g; for (k=i;kr;k++) AM[k][j] += -s*AM[k][i]; } /* as is column i itself.... */ for (j=A->r-1;j>i;j--) AM[j][i]*= -g*AM[i][i]; AM[i][i] = 1 - g*AM[i][i]*AM[i][i]; } /* now finish off V */ p=VM[0];for (i=0;ic;i++) { *p=VM[i][0]=0.0;p++;} VM[0][0]=1.0; } void svd_bidiag(matrix *U, matrix *w, matrix *ws,matrix *V) /* This routine produces a singular value decomposition of the matrix UWV', where: 1. W is a di-diagonal matrix with leading diagonal w, and leading super diagonal ws. 2. U and V are orthogonal. Because W is not always properly bi-diagonal the following steps are needed: i) Deflate the problem if possible, which may involve zeroing an element of the super-diagonal. ii) Check whether (deflated) bi-diagonal matrix can be partioned, if so find start of final partition (again may need to zero an element on the super diagonal) iii) Apply iteration of implicit QR algorithm (p405 Watkins) to the sub matrix identified above. iv) Return to (i) assuming that there are singular values left to find. Note that the Givens Rotators used here are calculated as follows to avoid rounding problems: assume xj to be zeroed into xi: m = max(fabs(xi),fabs(xj)); xi/=m;xj/=m r=sqrt(xi*xi+xj*xj); c=xi/r;s=xj/r; xi=m*r;xj=0.0; (c and s can obviously be applied to other vectors without needing to know m.) See page 271 of Watkins, for suggestion of how to test for zeroes. Most important address optimization has been done (stopped when it was as efficient as Numerical Recipes code). (Commented out code is pre-optimization, left in for readability) Tested against NR routine for a variety of random matrices and matrices that are rank deficient in various ways. Check for m>0.0 added 15/5/00 - otherwise division by zero is possible, leading to failure of routine! */ { double wnorm=0.0,x,y,s,c,m,r,a,b,sig,**VM,**UM,*wV,*wsV,*p1,*p2,tol; int finished=0,end,start,i,j,k,maxreps=100; tol=DOUBLE_EPS; /* convergence tolerance */ VM=V->M;UM=U->M;wV=w->V;wsV=ws->V; for (i=0;ir;i++) /* get something against which to judge zero */ { x=fabs(wV[i]);y=fabs(wsV[i]);if (xr-1; while (!finished) { for (k=0;ktol*wnorm) { /* Series of rotators (Givens rotations from right) zero this element */ y=wsV[end-1];wsV[end-1]=0.0; for (i=end-1;i>=0;i--) /* work out sequence of rotations */ { m=fabs(y);x=fabs(wV[i]); if (x>m) m=x; x=wV[i]; if (m>0.0) { y/=m;x/=m; /* now rotate y into x */ r=sqrt(y*y+x*x); c=x/r;s=y/r; } else {r=0.0;c=1.0;s=0.0;} wV[i]=r*m; /* rotation zeros y (implicitly) */ if (i>0) /* propagate the problem element! */ { y= -wsV[i-1]*s; wsV[i-1]*=c; } /* Need to update V as well V -> V G where G is the rotation just applied.... */ for (j=0;jr;j++) /* work down the rows */ { p2=VM[j]+end;p1=VM[j]+i;x=*p1; /*x=VM[j][i]; */ /*VM[j][i]=c*x+s*VM[j][end]; */ *p1=c*x+s*(*p2); /*VM[j][end]*=c;VM[j][end] += -s*x; */ *p2 *= c; *p2 += -s*x; } } } end--; /* */ /* Check here for termination ..... */ if (end<=0) finished=1; break; /* successfully deflated, so start new QR iteration cycle or finish */ } else if (fabs(wsV[end-1])<=tol*wnorm) /* inelegant condition needed because below can fail in R because of register optimizations */ /*if (wsV[end-1]+wnorm==wnorm)*/ /*too restrictive?? wV[end] is a singular value => deflate */ { end--; if (end==0) finished=1; /* all elements of ws are zeroed so we're done */ break; /* deflated so start new QR cycle or finish */ } else /* no deflation possible, search for start of sub-matrix */ { start=end-1; /* while ((wnorm+wV[start]!=wnorm)&&(wnorm+wsV[start]!=wnorm)&&(start>=0)) start--; R needs less elegant version below*/ while ((fabs(wV[start])>tol*wnorm)&&(fabs(wsV[start])>tol*wnorm)&&(start>=0)) start--; start++; /* this is now the row and column starting the sub-matrix */ /*if ((start>0)&&(wnorm+wV[start-1]==wnorm)&&(wnorm+wsV[start-1]!=wnorm)) R needs sloppier version in order to use fp register opts. */ if ((start>0)&&(fabs(wV[start-1])<=tol*wnorm)&&(fabs(wsV[start-1])>tol*wnorm)) { /* ws.V[start-1] must be zeroed.... */ y=wsV[start-1];wsV[start-1]=0.0; for (i=start;i<=end;i++) /* get sequence of rotators from left.... */ { m=fabs(y);x=fabs(wV[i]); if (x>m) m=x; x=wV[i]; if (m>0.0) { x/=m;y/=m; r=sqrt(x*x+y*y); c=x/r;s=y/r; } else {r=1.0;c=1.0;s=0.0;} wV[i]=r*m; /* y zeroed implicitly */ if (ir;j++) /* work down the rows */ { p1=UM[j]+start-1;x = *p1;p2=UM[j]+i;/*x=UM[j][start-1]; */ /* UM[j][start-1] = c*x-s*UM[j][i]; */ *p1 = c*x - s*(*p2); /* UM[j][i]*=c; UM[j][i] += +s*x; */ *p2 *= c; *p2 += s*x; } } } } /* iterate QR algorithm on sub-matrix */ /* First find the Wilkinson shift which is given by the eigenvalue of the bottom right 2 by 2 submatrix, closest to the final matrix element. The required eigenvalues are found directly from the characteristic equation. See page 405 of Watkins.*/ a=wV[end-1]*wV[end-1]+wsV[end-1]*wsV[end-1];b=wV[end];b*=b; c=wV[end]*wsV[end-1]; y=sqrt((a-b)*(a-b)+4*c*c)/2; x=(a+b)/2+y;y=(a+b)/2-y; /* x and y are the eigenvalues */ if (fabs(x-b)m) m=fabs(y); if (m>0.0) { y/=m;x/=m; /* avoid over/underflow */ r=sqrt(y*y+x*x); c=x/r;s=y/r; /* elements of rotator to apply from right operating in start,start+1 plane */ } else { r=1.0;c=1.0;s=0.0;} for (i=start;im) m=fabs(x); if (m>0.0) { x/=m;y/=m; /* avoiding overflow */ r=sqrt(x*x+y*y); c=x/r;s=y/r; } else {r=1.0;c=1.0;s=0.0;} /* rotator for zeroing y (at i-1,i+1) int x at (i-1,i) */ wsV[i-1]=r*m;y=0.0; } /* now apply rotator from right to rows i and i+1.... */ x=wV[i]; wV[i]=c*x+s*wsV[i]; wsV[i]=c*wsV[i]-s*x; y=s*wV[i+1];wV[i+1]*=c; /* y contains the bulge at (i+1,i) */ /* and also apply from right to V.... */ for (j=0;jr;j++) /* work down the rows */ { p1=VM[j]+i;x= *p1;p2=VM[j]+i+1; /*x=VM[j][i]; */ /*VM[j][i]=c*x+s*VM[j][i+1]; */ *p1=c*x + s* (*p2); /*VM[j][i+1]*=c;VM[j][i+1] += -s*x; */ *p2 *= c; *p2 += -s*x; } /* Obtain rotator from left to zero element at (i+1,i) into element at (i,i) thereby creating new bulge at (i,i+2) */ x=wV[i]; m=fabs(y);if (fabs(x)>m) m = fabs(x); if (m>0.0) { x/=m;y/=m; /* avoid overflow */ r=sqrt(x*x+y*y); c=x/r;s=y/r; } else {r=1.0;c=1.0;s=0.0;} /* transform to zero y into x (i+1,i) into (i,i) */ wV[i]=r*m;y=0.0; /* apply from left.... */ x=wsV[i]; wsV[i]=c*x+s*wV[i+1]; wV[i+1]=c*wV[i+1]-s*x; if (ir;j++) /* work down the rows */ { p1=UM[j]+i;x= *p1;p2=UM[j]+i+1;/*x=UM[j][i]; */ /*UM[j][i]=c*x+s*UM[j][i+1]; */ *p1=c*x+s*(*p2); /*UM[j][i+1]*=c; UM[j][i+1] += -s*x; */ *p2 *= c; *p2 += -s*x; } } } if (k==maxreps) error(_("svd() not converged")); } /* make all singular values non-negative */ for (i=0;ir;i++) if (wV[i]<0.0) { wV[i]= -wV[i]; for (j=0;jr;j++) VM[j][i]= -VM[j][i]; } } void svd(matrix *A, matrix *w, matrix *V) /* This routine produces a singular value decomposition of A. On exit V will be an A.c by A.c orthogonal matrix, w will be a vector of A.c singular values and A will contain U of the same dimension as A such that U'U=I. If W is the diagonal matrix with w as its leading diagonal then: A=UWV' - the singluar value decomposition. This routine is based on: Watkins (1991) Fundamentals of Matrix Computations, Wiley. (see section 7.2) The algorithm has 2 steps: 1. Bi-diagonalise A using reflectors (Householder transformations) from left and right - this is achieved by routine bidiag(), above. 2. Find singular values of Bi-diagonal matrix. This is achieved by routine svd_bidiag(), above. */ { matrix *U,ws; int i; if (A->c==1) /* then the svd is trivial to compute */ { w->V[0]=0.0; for (i=0;ir;i++) w->V[0]+=A->M[i][0]*A->M[i][0]; w->V[0]=sqrt(w->V[0]); for (i=0;ir;i++) A->M[i][0]/=w->V[0]; V->M[0][0]=1.0; return; } ws=initmat(w->r-1,1); /* bi-diagonalize A, so A=UWV', w = l.diag(W), ws=l.super.diag(W), A contains U */ bidiag(A,w,&ws,V); U=A; /* Now call svd_bidiag() for a result..... */ svd_bidiag(U,w,&ws,V); freemat(ws); } matrix svdroot(matrix A,double reltol) /* Finds smallest squareroot of a non-negative definite matrix. reltol is used to decide which columns to remove... */ { int k=0l,i,j; double tol=0.0,prod; char err[100]; matrix a,v,w; a=initmat(A.r,A.c);mcopy(&A,&a); v=initmat(A.r,A.c); w=initmat(A.r,1); svd(&a,&w,&v); /*a * diag(w) * v' */ for (i=0;itol) tol=w.V[i];} tol*=sqrt(reltol); for (i=0;itol) { for (j=0;j*(double *)b) return(1); return(0); } void sort(matrix a) /* sorts a vector, in situ, using standard routine qsort */ { int i; qsort(a.V,(size_t)a.r*a.c,sizeof(a.V[0]),elemcmp); for (i=0;ia.V[i+1]) error(_("Sort failed")); } int real_elemcmp(const void *a,const void *b,int el) /* declaring this inline static slows it down!! */ { static int k=0; double *na,*nb,*nak; if (el>0) { k=el;return(0);} na=(*(double **)a);nb=(*(double **)b); nak = na + k; for (;na *nb) return(1); } return(0); } int melemcmp(const void *a,const void *b) { return(real_elemcmp(a,b,-1)); } void msort(matrix a) /* sorts a matrix, in situ, using standard routine qsort so that its first col is in ascending order, its second col is in ascending order for any ties in the first col, and so on..... */ { double z=0.0; real_elemcmp(&z,&z,a.c); qsort(a.M,(size_t)a.r,sizeof(a.M[0]),melemcmp); } void RArrayFromMatrix(double *a,int r,matrix *M) /* copies matrix *M into R array a where r is the number of rows of A treated as a matrix by R */ { int i,j; for (i=0;ir;i++) for (j=0;jc;j++) a[i+r*j]=M->M[i][j]; } matrix Rmatrix(double *A,int r,int c) /* produces a matrix from the array containing a (default) R matrix stored: A[0,0], A[1,0], A[2,0] .... etc */ { int i,j; matrix M; M=initmat(r,c); for (i=0;i if (wsV[end-1]+wnorm==wnorm) test for convergence of singular values is rather too stringent! Replaced with something more reasonable. 25/2/2000 15/5/2000 - convergence criteria changed back - eigenvalue used for shift was calculated in a manner that allowed bad cancellation errors - this caused convergence problems AND occasional imaginary eigenvalues for the shift. Fixing this fixed the convergence problem. 9. svd() bug fixed - it division by zero was possible while trying to avoid over/ underflow in Givens rotations - check added to fix problem. 15/5/00 10. initmat() problem fixed. There was a hangover from segmented memory architectures left in initmat(): this meant that vectors could not be accessed using a.V[i] if they were larger than about 8192 elements ("about" because the out of bound write checking mechanism uses some elements when switched on). This restriction has now been removed. 11. 21/5/01 svd() could not cope with single column matrices. Fixed. 12. 23/5/01 svd() re-structured so that svd on bi-diagonal matrix is now done in a separate service routine. This allows efficient svd of matrices with special structure, by allowing different versions of svd() with special bi-diagonalization steps, which can then call the new routine svd_bidiag(). 15. msort() added, to sort the rows of a matrix so that the first column is in ascending order, entries in 2nd col are ascending if corresponding 1st col entries are tied, etc. 19. 1/5/02: R default compile options allow dangerous use of register variables which can result in: double a,b;a=b;if(a==b) evaluating as false. This means that Watkins suggested convergence check if (big+small==big) can fail. Hence replaced in svd and eigen routines. All routines now default to using DOUBLE_EPS in place of any hard coded 1e-14's! Also Watkins construction changed to: if (small<=DOUBLE_EPS*big). header called general.h is good place to define DOUBLE_EPS - will be defined in R.h, which can be included there. 20. 5/5/02 One convergence test in svd had been left unchanged - fixed this and loosened convergence criteria by 2 bits. */ mgcv/src/Makevars0000644000177400001440000000044313046054035013664 0ustar murdochusersPKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) $(SHLIB_OPENMP_CFLAGS) PKG_CFLAGS = $(SHLIB_OPENMP_CFLAGS) ## *Both* the above must be *uncommented* for release #PKG_CFLAGS = -Wall -pedantic $(SHLIB_OPENMP_CFLAGS) ## `#' out previous line for release (but not without uncommenting openMP) mgcv/src/mvn.c0000644000177400001440000002723513046054035013144 0ustar murdochusers/* (c) Simon N Wood. 2014. Released under GPL2. likelihood and derivative evaluation for multivariate Gaussian additive models. */ #include #include #include #include #include #include "mgcv.h" void mvn_ll(double *y,double *X,double *XX,double *beta,int *n,int *lpi, /* note zero indexing */ int *m,double *ll,double *lb,double *lbb,double *dbeta, double *dH,int *deriv,int *nsp,int *nt) { /* inputs: * 'y' is an m by n matrix, each column of which is a m-dimensional observation of a multivariate normal r.v. * 'X' is a sequence of model matrices. The first (0th) model matrix runs from columns 0 to lpi[0]-1, the jth from cols lpi[j-1] to lpi[j]-1. lpi indexing starts from 0!! * XX is the pre-computed X'X matrix. * 'beta' is a parameter vector corresponding to X. The m*(m+1)/2 elements starting at lpi[m] are the parameters of the Choleki factor of the precision matrix. * nt is number of threads to use. outputs: * 'll' is the evaluated log likelihood. * 'lb' is the grad vector */ double *R,*theta,ldetR,*Xl,*bl,oned=1.0,zerod=0.0,*p,*p1,*p2,*p3,xx,zz,yy,*yty, *mu,*Rymu,rip,*dtheta,*db,*deriv_theta,*yX,*yRX; int i,j,k,l,pl,one=1,bt,ct,nb,*din,ntheta,ncoef,*rri,*rci,ri,rj,ril,rjl,rik,rjk,rij,rjj,q,r; const char not_trans='N'; ntheta = *m * (*m+1)/2;ncoef = lpi[*m-1]; nb = ncoef + ntheta; /* number of coefficients overall */ /* Create the Choleski factor of the precision matrix */ R = (double *)CALLOC((size_t)*m * *m,sizeof(double)); theta = beta + lpi[*m-1]; /* parameters of R */ ldetR = 0.0; /* log|R| */ rri = (int *)CALLOC((size_t)ntheta,sizeof(int)); /* theta to R row index */ rci = (int *)CALLOC((size_t)ntheta,sizeof(int)); /* theta to R col index */ deriv_theta = (double *)CALLOC((size_t)ntheta,sizeof(double)); /* exp(theta) or 1*/ for (k=0,i=0;i<*m;i++) { /* fill out R */ deriv_theta[k] = exp(theta[k]); R[i + *m * i] = deriv_theta[k];ldetR += theta[k]; rri[k]=rci[k]=i;k++; for (j=i+1;j<*m;j++) { R[i + *m * j] = theta[k]; deriv_theta[k] = 1.0; rri[k]=i;rci[k]=j;k++; } } /* obtain y - mu */ mu = (double *)CALLOC((size_t)*n,sizeof(double)); for (l=0;l<*m;l++) { /* loop through components */ if (l==0) { Xl = X;pl = lpi[0];bl=beta;} /* Xl is lth model matrix with pl columns, coef vec bl */ else { Xl = X + *n * lpi[l-1];pl = lpi[l]-lpi[l-1];bl = beta + lpi[l-1];} F77_CALL(dgemv)(¬_trans,n,&pl,&oned,Xl,n, bl, &one,&zerod, mu, &one); /* BLAS call for mu = Xl bl */ /* now subtract mu from relevant component of y */ for (p=mu,p1= mu + *n,p2=y+l;p=k */ /* inner product of col l and col k of R ... */ for (p=R+l * *m,p1=R+k * *m,rip=0.0,p2=p1+k;p1<=p2;p++,p1++) rip += *p * *p1; lbb[i + nb * j] = lbb[j + nb * i] = -XX[i + ncoef * j]*rip; /* -xx*rip; */ } /* now the mixed blocks */ for (i=0;i #include #include #include #include #include "mgcv.h" /* Compute reproducing kernel for spline on the sphere */ void rksos(double *x,int *n,double *eps) { /* Function to compute reproducing kernel for spline on the sphere, based on Jim Wendelberger's (1981) thesis. Returns evaluated kernel rk(x) in n vector x. */ double dl1,xi,rk,xk,xx; int i,k; dl1 = acos(0)*2; dl1 = dl1*dl1/6; /* dilog(1) = pi^2/6, dilog(0)=0 */ for (i=0;i< *n;i++) { xi = x[i]; if (xi <= 0) { if (xi < -1) xi = -1; rk = 1.0 - dl1; xk = xi = xi/2 + 0.5; for (k=1;k<1000;k++) { xx = xk/(k*k); rk += xx; xk *= xi; if (xx < *eps) break; } } else { if (xi>1) xi=1; if (xi/2>=.5) rk=1.0; else rk = 1 - log(.5+xi/2)*log(.5-xi/2); xk = xi = .5 - xi/2; for (k=1;k<1000;k++) { xx = xk/(k*k); rk += -xx; xk *= xi; if (xk < *eps) break; } } x[i] = rk; } } /* inside polygon tester.... */ void in_out(double *bx, double *by, double *break_code, double *x,double *y,int *in, int *nb, int *n) /* finds out whether points in arrays x,y are inside boundary or outside, by counting boundary crossings. The boundaries nodes are defined by bx, by. bx[i] and by[i] less than or equal to break_code signals a break in the boundary (e.g. between island and external boundary.) Each section of boundary is assumed to be a closed loop. nb is dimenion of bx and by; n is dimension of x and y. `in' will contain a 1 for an interior point and a 0 otherwise, on exit. Both bx[i] and by[i] or neither must be less than the break_code. */ { double xx,yy,dum,x0,x1,y0,y1; int i,j,count,start,swap; for (i=0;i<*n;i++) { /* loop through all test points */ xx=x[i];yy=y[i]; /* the current test point */ start=0; /* start of current boundary section */ for (count=0,j=0;j<*nb;j++) { /* loop through entire boundary */ x0 = bx[j]; /* start node */ if (x0 <= *break_code) start=j+1; /* next segment start */ else { /* not a new section start */ if (j==*nb-1) x1=bx[start]; else x1 = bx[j+1]; /* end node */ if (x1 <= *break_code) x1 = bx[start]; /* must join up segment end */ if (x0!=x1) { /* x0==x1 => segment immaterial to decision */ if (x1=xx) { /* might have a crossing */ y0 = by[j]; /* start node y co-ord */ if (j==*nb-1) y1=by[start]; else y1 = by[j+1]; /* end node y co-ord */ if (y1 <= *break_code) y1=by[start]; /* must join up */ if (y0<=yy&&y1<=yy) count++; /* definite crossing */ else { /* more detail needed to determine crossing */ if (!(y0>yy&&y1>yy)) { /* could still be one */ if (swap) {dum=y0;y0=y1;y1=dum;} dum = (xx-x0)*(y1-y0)/(x1-x0)+y0; /* at what y does vertical cross segment */ if (yy>=dum) count++; /* it's a crossing */ } /* end - could still be one */ } /* end - more detail */ } /* end - might be a crossing */ } /* end - does seg matter */ } /* end - not skipped because break */ } /* end boundary loop */ if (count%2) in[i]=1;else in[i]=0; /* record result */ } /* end x,y test loop */ } /* end of in_out */ /******************************/ /* Tweedie distribution stuff */ /******************************/ void psum(double *y, double *x,int *index,int *n) { /* y is of length max(index). x and index are of the same length, n. This routine fills y[index[i]-1] so that it contains the sum of the x[i]'s sharing index[i]. It is assumed that y is cleared to zero on entry. */ int i; for (i=0;i< *n;i++) { y[index[i]-1] += x[i]; } } double *forward_buf(double *buf,int *jal,int update) /* extend buffer forward 1000 */ { double *buf2,*p,*p1,*p2; int n=1000; buf2 = (double *)CALLOC((size_t)(*jal+n),sizeof(double)); for (p=buf,p1=buf + *jal,p2=buf2;p *j0-1) n = *j0 - 1; /* only extend back to j=1 */ if (n==0) return(buf); buf2 = (double *)CALLOC((size_t)(*jal+n),sizeof(double)); for (p=buf,p1=buf + *jal,p2=buf2 + n;p0) { exp_th = exp(- *th); //drho_const = (1+exp_th)/(1 - *b + (1 - *a)*exp_th); x = 1 + exp_th;p = (*b + *a * exp_th)/x; x1 = x*x;dpth1 = exp_th*(*b - *a)/x1; dpth2 = ((*a - *b)*exp_th+(*b - *a)*exp_th*exp_th)/(x1*x); } else { exp_th = exp(*th); //drho_const = (1+exp_th)/((1 - *b)*exp_th + 1 - *a); x = exp_th+1;p = (*b * exp_th + *a)/x; x1 = x*x;dpth1 = exp_th*(*b - *a)/x1; dpth2 = ((*a - *b)*exp_th*exp_th+(*b - *a)*exp_th)/(x*x1); } log_eps = log(*eps); onep = 1 - p;onep2 = onep * onep; alpha = (2 - p)/onep; /* get terms that are repeated in logWj etc., but simply multiplied by j */ w_base = alpha * log(p-1) + *rho/onep - log(2 - p); wp_base = (log(-onep) + *rho)/onep2 - alpha/onep + 1/(2 - p); wp2_base= 2*(log(-onep) + *rho)/(onep2*onep) - (3*alpha-2)/(onep2) + 1/((2 - p)*(2 - p)); /* initially establish the min and max y values, and hence the initial buffer range, at the same time produce the alpha log(y) log(y)/(1-p)^2 and log(y)/(1-p)^3 vectors. */ alogy = (double *)CALLOC((size_t)*n,sizeof(double)); logy1p2 = (double *)CALLOC((size_t)*n,sizeof(double)); logy1p3 = (double *)CALLOC((size_t)*n,sizeof(double)); ymax = ymin = *y; *alogy = alpha * log(*y); *logy1p2 = log(*y)/(onep2); *logy1p3 = *logy1p2/onep; for (p1=y+1,p2=y+ *n,p3=alogy+1,p4=logy1p2+1,p5=logy1p3+1;p1 ymax) ymax = *p1; else if (*p1 < ymin) ymin = *p1; } x = pow(ymin,2 - p)/(phi * (2 - p)); j_lo = (int) floor(x);if (j_lo<1) j_lo = 1; x = pow(ymax,2 - p)/(phi * (2 - p)); j_hi = (int) ceil(x);if (j_hi .5||j_max<1) j_max++; j_max -= j0; /* converted to buffer index */ j = j_max+j0; jalogy = j*alogy[i]; wdW2d2W= wdlogwdp=dWpp=0.0; wi=w1i=w2i=0.0; // 1.0; wmax = wb[j_max] - jalogy;wmin = wmax + log_eps; // w1max = wb1[j_max] - jalogy;w1min = w1max + log_eps; // w2max = wb2[j_max] - jalogy;w2min = w2max + log_eps; /* start upsweep to convergence or end of available buffered values */ ok = 0;//xmax=x1max=x2max=0.0; for (j=j_max+j0,jb=j_max;jb<=j_hi;jb++,j++) { // note initially wi etc initialized to 1 and summation starts 1 later jalogy = j * alogy[i]; wj = wb[jb] - jalogy; w1j = wb1[jb]; wp1j = wp1[jb] - j * logy1p2[i]; /* d log W / dp */ wp2j = wp2[jb] - 2 * j * logy1p3[i]; /* d^2 log W/ dp^2 */ /* transform to working parameterization ... */ wp2j = wp1j * dpth2 + wp2j * dpth1 * dpth1; /* d^2 log W/ dth^2 */ wp1j *= dpth1; /* d log W / dth */ wppj = wpp[jb] * dpth1; wj_scaled = exp(wj-wmax); wi += wj_scaled; /* sum of the scaled W_j */ w1i += wj_scaled * w1j; /* sum W_j dlogW_j / d rho */ w2i += wj_scaled * w1j*w1j; /* sum W_j d^2logW_j / d rho^2 */ x = wj_scaled*wp1j; wdlogwdp += x; /* sum_j W_j dlogW_j/dp */ x1 = wj_scaled*(wp1j*wp1j + wp2j); wdW2d2W += x1; /* sum_j (dlog W_j/dp)^2 + W_j d^2logW_j/dp^2 */ x2 = wj_scaled*(wp1j*j/onep + wppj); dWpp += x2; // x=fabs(x);x1=fabs(x1);x2=fabs(x2); // if (x>xmax) {xmax=x;wp1jmin=x * *eps;} //if (x1>x1max) {x1max=x1;wdW2min=x1 * *eps;} //if (x2>x2max) {x2max=x2;Wppmin=x2 * *eps;} if (wj < wmin) { ok=1;break;} //&&(w1j < w1min)&&(w2j < w2min)&& // (x < wp1jmin)&&(x1 < wdW2min)&&(x2 < Wppmin)) { ok=1;break;} /* converged on upsweep */ } /* end of upsweep to buffer end */ while (!ok) { /* while upsweep unconverged need to fill in more buffer */ for (;jb jal-1) j_hi = jal-1; /* set j_hi to last element filled */ if (!ok) { /* need to expand buffer storage*/ /*Rprintf("forward buffer expansion\n");*/ wb = forward_buf(wb,&jal,0); wb1 = forward_buf(wb1,&jal,0); // wb2 = forward_buf(wb2,&jal,0); wp1 = forward_buf(wp1,&jal,0); wp2 = forward_buf(wp2,&jal,0); wpp = forward_buf(wpp,&jal,1); } } /* finished upsweep and any buffer expansion */ /* start downsweep to convergence or start of available buffered values */ ok=0; for (j=j_max-1+j0,jb=j_max-1;jb>=j_lo;jb--,j--) { jalogy = j * alogy[i]; wj = wb[jb] - jalogy; w1j = wb1[jb]; wp1j = wp1[jb] - j * logy1p2[i]; /* d log W / dp */ wp2j = wp2[jb] - 2 * j * logy1p3[i]; /* d^2 log W/ dp^2 */ /* transform to working parameterization ... */ wp2j = wp1j * dpth2 + wp2j * dpth1 * dpth1; /* d^2 log W/ dth^2 */ wp1j *= dpth1; /* d log W / dth */ wppj = wpp[jb] * dpth1; wj_scaled = exp(wj-wmax); wi += wj_scaled; /* sum of the scaled W_j */ w1i += wj_scaled * w1j; /* sum W_j dlogW_j / d rho */ w2i += wj_scaled * w1j*w1j; /* sum W_j d^2logW_j / d rho^2 */ x = wj_scaled*wp1j; wdlogwdp += x; /* sum_j W_j dlogW_j/dp */ x1 = wj_scaled*(wp1j*wp1j + wp2j); wdW2d2W += x1; /* sum_j (dlog W_j/dp)^2 + W_j d^2logW_j/dp^2 */ x2 = wj_scaled*(wp1j*j/onep + wppj); dWpp += x2; if (wj < wmin) { ok=1;break;} /* converged on downsweep */ } /* end of downsweep to buffer end */ if (j<=1&&j_lo==0) ok=1; /* don't care about element size if reached base */ while (!ok) { /* while downsweep unconverged need to fill in more buffer */ for (jb=j_lo-1;jb>=0;jb--,j--) { /* fill buffers and calculate w terms */ wb[jb] = j * w_base - lgamma((double)j+1) - lgamma(-j * alpha); wb1[jb] = -j/onep; xx = j/onep2; x = xx*digamma(-j*alpha); wp1[jb] = j * wp_base + x; /* base for d logW_j/dp */ xx = trigamma(-j*alpha) * xx * xx; wp2[jb] = j * wp2_base + 2*x/onep - xx; wpp[jb] = j /onep2; jalogy = j * alogy[i]; wj = wb[jb] - jalogy; w1j = wb1[jb]; wp1j = wp1[jb] - j * logy1p2[i]; /* d log W / dp */ wp2j = wp2[jb] - 2 * j * logy1p3[i]; /* d^2 log W/ dp^2 */ /* transform to working parameterization ... */ wp2j = wp1j * dpth2 + wp2j * dpth1 * dpth1; /* d^2 log W/ dth^2 */ wp1j *= dpth1; /* d log W / dth */ wppj = wpp[jb] * dpth1; wj_scaled = exp(wj-wmax); wi += wj_scaled; /* sum of the scaled W_j */ w1i += wj_scaled * w1j; /* sum W_j dlogW_j / d rho */ w2i += wj_scaled * w1j*w1j; /* sum W_j d^2logW_j / d rho^2 */ x = wj_scaled*wp1j; wdlogwdp += x; /* sum_j W_j dlogW_j/dp */ x1 = wj_scaled*(wp1j*wp1j + wp2j); wdW2d2W += x1; /* sum_j (dlog W_j/dp)^2 + W_j d^2logW_j/dp^2 */ x2 = wj_scaled*(wp1j*j/onep + wppj); dWpp += x2; if (wj < wmin) { ok=1;break;} /* converged on upsweep */ } if (j<=1) ok=1; /* don't care about element size if reached base */ j_lo = jb; if (j_lo<0) j_lo=0; /* set j_lo to first element filled */ if (!ok) { /* need to expand buffer storage*/ /*Rprintf("backward buffer expansion\n");*/ wb = backward_buf(wb,&jal,&j0,&j_lo,&j_hi,0); wb1 = backward_buf(wb1,&jal,&j0,&j_lo,&j_hi,0); // wb2 = backward_buf(wb2,&jal,&j0,&j_lo,&j_hi,0); wp1 = backward_buf(wp1,&jal,&j0,&j_lo,&j_hi,0); wp2 = backward_buf(wp2,&jal,&j0,&j_lo,&j_hi,0); wpp = backward_buf(wpp,&jal,&j0,&j_lo,&j_hi,1); /* final '1' updates jal,j0 etc. */ } } /* finished downsweep and any buffer expansion */ /* Summation now complete: need to do final transformations */ w[i] = wmax + log(wi); /* contains log W */ w2[i] = w2i/wi - (w1i/wi)*(w1i/wi); w2p[i] = wdW2d2W/wi - (wdlogwdp/wi)*(wdlogwdp/wi); w2pp[i] = (w1i/wi)*(wdlogwdp/wi) + dWpp/wi; w1[i] = -w1i/wi; w1p[i] = wdlogwdp/wi; } /* end of looping through y */ FREE(alogy);FREE(wb);FREE(wb1);//FREE(wb2); FREE(logy1p2);FREE(logy1p3);FREE(wp1);FREE(wp2);FREE(wpp); } /* tweedious */ void tweedious2(double *w,double *w1,double *w2,double *w1p,double *w2p, double *w2pp,double *y,double *eps,int *n, double *th,double *rho,double *a, double *b) /* Routine to perform tedious series summation needed for Tweedie distribution evaluation, following Dunn & Smyth (2005) Statistics and Computing 15:267-280. Notation as in that paper. For log W returned in w. (where W means sum_j W_j) d logW / drho in w1, d2 logW / d rho2 in w2. d logW / dth in w1p d2 logW / dth2 in w2p d2 logW / dth drho in W2pp rho=log(phi), and th defines p = (a + b * exp(th))/(exp(th)+1). note, 10) { exp_th = exp(-th[i]); x = 1 + exp_th;p = (*b + *a * exp_th)/x; x1 = x*x;dpth1 = exp_th*(*b - *a)/x1; dpth2 = ((*a - *b)*exp_th+(*b - *a)*exp_th*exp_th)/(x1*x); } else { exp_th = exp(th[i]); x = exp_th+1;p = (*b * exp_th + *a)/x; x1 = x*x;dpth1 = exp_th*(*b - *a)/x1; dpth2 = ((*a - *b)*exp_th*exp_th+(*b - *a)*exp_th)/(x*x1); } /* first find the location of the series maximum... */ x = pow(y[i],2 - p)/(phi * (2 - p)); j_max = (int) floor(x); if (x - j_max > .5||j_max<1) j_max++; j = j_max; onep = 1 - p;onep2 = onep * onep; twop = 2 - p; alpha = twop/onep; alogy = log(y[i]); logy1p2 = alogy/(onep2); logy1p3 = logy1p2/onep; alogy *= alpha; /* alpha * log(y[i]) */ wdW2d2W= wdlogwdp=dWpp=0.0; wi=w1i=w2i=0.0; /* get terms that are repeated in logWj etc., but simply multiplied by j */ w_base = alpha * log(-onep) + rho[i]/onep - log(twop); wp_base = (log(-onep) + rho[i])/onep2 - alpha/onep + 1/twop; wp2_base= 2*(log(-onep) + rho[i])/(onep2*onep) - (3*alpha-2)/(onep2) + 1/(twop*twop); wmax = j * w_base - lgamma((double)j+1) - lgamma(-j * alpha) - j*alogy; wmin = wmax + log_eps; /* start upsweep/downsweep to convergence */ ok = 0;//xmax=x1max=x2max=0.0; //for (j=j_max+j0,jb=j_max;jb<=j_hi;jb++,j++) { // note initially wi etc initialized to 1 and summation starts 1 later incr = 1; lgammaj1 = lgamma((double)j+1); // lgamma(j+1) to be computed by recursion while (!ok) { wbj = j * w_base - lgammaj1 - lgamma(-j * alpha); wb1j = -j/onep; xx = j/onep2; x = xx*digamma(-j*alpha); wp1jb = j * wp_base + x; /* base for d logW_j/dp */ xx = trigamma(-j*alpha) * xx * xx; wp2jb = j * wp2_base + 2*x/onep - xx; wppjb = j /onep2; jalogy = j * alogy; wj = wbj - jalogy; w1j = wb1j; wp1j = wp1jb - j * logy1p2; /* d log W / dp */ wp2j = wp2jb - 2 * j * logy1p3; /* d^2 log W/ dp^2 */ /* transform to working parameterization ... */ wp2j = wp1j * dpth2 + wp2j * dpth1 * dpth1; /* d^2 log W/ dth^2 */ wp1j *= dpth1; /* d log W / dth */ wppj = wppjb * dpth1; wj_scaled = exp(wj-wmax); wi += wj_scaled; /* sum of the scaled W_j */ w1i += wj_scaled * w1j; /* sum W_j dlogW_j / d rho */ w2i += wj_scaled * w1j*w1j; /* sum W_j d^2logW_j / d rho^2 */ x = wj_scaled*wp1j; wdlogwdp += x; /* sum_j W_j dlogW_j/dp */ //Rprintf("wdlogwdp=%g wj_scaled=%g wp1j=%g\n",wdlogwdp,wj_scaled,wp1j); x1 = wj_scaled*(wp1j*wp1j + wp2j); wdW2d2W += x1; /* sum_j (dlog W_j/dp)^2 + W_j d^2logW_j/dp^2 */ x2 = wj_scaled*(wp1j*j/onep + wppj); dWpp += x2; j += incr; if (incr>0) { // upsweep lgammaj1 += log(j); if (wj < wmin) { j = j_max - 1;incr = -1; if (j==0) ok=1; // finished lgammaj1 = lgamma((double)j+1); } // change to downsweep } else { lgammaj1 += -log(j+1); if (wj < wmin||j<1) ok=1; // finished } } /* end of upsweep/downsweep */ //Rprintf("wdlogwdp = %g\n",wdlogwdp); /* Summation now complete: need to do final transformations */ w[i] = wmax + log(wi); /* contains log W */ w2[i] = w2i/wi - (w1i/wi)*(w1i/wi); w2p[i] = wdW2d2W/wi - (wdlogwdp/wi)*(wdlogwdp/wi); w2pp[i] = (w1i/wi)*(wdlogwdp/wi) + dWpp/wi; w1[i] = -w1i/wi; w1p[i] = wdlogwdp/wi; } /* end of looping through y */ } /* tweedious2 */ /* test code for tweedious... library(mgcv);library(tweedie) phi <- 2 p <- 1.1 mu <- .001 y <- c(1,1,2,1,3,0,0,30,67) eps <- 1e-6 l0 <- colSums(mgcv:::ldTweedie(y,mu=mu,p=p,phi=phi)) l1 <- colSums(mgcv:::ldTweedie(y,mu=mu,p=p,phi=phi+eps)) (l1-l0)/eps;l0 log(dtweedie(y,power=p,mu=mu,phi=phi)) j <- 1:100 alpha <- (2-p)/(1-p) w <- -j*alpha*log(y)+alpha*j*log(p-1)-j*(1-alpha)*log(phi)-j*log(2-p)-lgamma(j+1) - lgamma(-j*alpha) theta <- mu^(1-p) k.theta <- mu*theta/(2-p) theta <- theta/(1-p) (y*theta-k.theta)/phi - log(y) + log(sum(exp(w))) n <- 20 mu <- rep(1,n) ml <- mgcv:::ldTweedie(1:n,mu,p=1.5,phi=1);ml dl <- log(dtweedie.series(1:n,power=1.5,mu,phi=1));dl x <- seq(.05,100,by=.1) mu <- 1+x*0 sum(dtweedie(x,power=1.5,mu,phi=1))*.1 + dtweedie(0,power=1.5,1,phi=1) sum(exp(mgcv:::ldTweedie(x,mu,p=1.5,phi=1)))*.1 + exp(mgcv:::ldTweedie(0,1,p=1.5,phi=1)) x <- rtweedie(10000,power=1.5,mu=1,phi=1) system.time(d1 <- dtweedie(x,power=1.5,mu=1,phi=1)) system.time(d2 <- mgcv:::ldTweedie(x,mu=1,p=1.5,phi=1)) range(d2-log(d1)) */ /*******************************************************/ /** Fast re-weighting routines */ /*******************************************************/ void rwMatrix(int *stop,int *row,double *w,double *X,int *n,int *p,int *trans,double *work) { /* Function to recombine rows of n by p matrix X (column ordered). ith row of X' is made up of row[stop[i-1]+1...stop[i]], weighted by w[stop[i-1]+1...stop[i]]. stop[-1]=-1 by convention. stop is an n vector. If (trans==0) the the operation on a column x is x'[i] += w[row[j]] * X[row[j]] over the j from stop[i-1]+1 to stop[i]. Otherwise the tranposed operation x'[row[j]] += w[row[j]] * x[i] is used with the same j range. x' zero at outset. work is same dimension as X See rwMatrix in bam.r for call from R. */ ptrdiff_t i,j,jump,start=0,end,off; double *X1p,*Xp,weight,*Xpe,*X1; /* create storage for output matrix, cleared to zero */ X1 = work; jump = *n; off = *n * (ptrdiff_t) *p; for (X1p=X1,Xpe=X1p+off;X1p= *nt-r) { i -= *nt - r; r++;} c = r + i; */ #include #include #include #include #include #include #include #include #include "mgcv.h" #ifdef OPENMP_ON #include #endif /* basic extraction operations */ void singleXj(double *Xj,double *X, int *m, int *k, int *n,int *j) { /* Extract a column j of matrix stored in compact form in X, k into Xj. X has m rows. k is of length n. ith row of result is Xj = X[k(i),j] (an n vector). This function is O(n). Thread safe. */ double *pe; X += *m * *j; /* shift to start of jth column */ for (pe = Xj + *n;Xj < pe;Xj++,k++) *Xj = X[*k]; } /* singleXj */ void tensorXj(double *Xj, double *X, int *m, int *p,int *dt, int *k, int *n, int *j, int *kstart,int *koff) { /* Extract a column j of tensor product term matrix stored in compact form in X, k into Xj. There are dt sub matrices in Xj. The ith is m[i] by p[i]. There are dt index n - vectors stacked end on end in k. The ith component (starting at 0) has index vector at column kstart[i] + *koff of k. This function is O(n*dt) This routine performs pure extraction only if Xj is a vector of 1s on entry. Otherwise the jth column is multiplied element wise by the contents of Xj on entry. Thread safe. */ int q=1,l,i,jp,*kp; double *p0,*p1,*M; p1 = Xj + *n; /* pointer for end of Xj */ for (i = 0;i < *dt;i++) q *= p[i]; jp = *j; for (i = 0;i < *dt; i++) { q /= p[i]; /* update q */ l = jp/q; /* column of current marginal */ jp = jp%q; M = X + m[i] * l; /* M now points to start of col l of ith marginal model matrix */ kp = k + (kstart[i] + *koff) * (ptrdiff_t) *n; for (p0=Xj;p00 && j==dt[i]-1) { c1 = pt[i] * (ptrdiff_t) m[q]; if (c1>dC) dC = c1; /* dimension of working matrix C */ } if (j==0) pt[i] = p[q]; else pt[i] *= p[q]; /* term dimension */ } if (qc[i]>0) voff[i+1] = voff[i] + pt[i]; else voff[i+1] = voff[i]; /* start of ith v matrix */ if (maxp < pt[i]) maxp = pt[i]; if (qc[i]<=0) tps[i+1] = tps[i] + pt[i]; /* where ith terms starts in param vector */ else tps[i+1] = tps[i] + pt[i] - 1; /* there is a tensor constraint to apply - reducing param count*/ } /* now form the product term by term... */ i = *n; if (i *pv) *nthreads = *pv; xv = (double *) CALLOC((size_t) *nthreads * *n,sizeof(double)); /* storage for cols of XV */ xi = (double *) CALLOC((size_t) *nthreads * *n,sizeof(double)); /* storage for cols of X */ ei = (double *) CALLOC((size_t) *nthreads * *pv,sizeof(double)); /* storage for identity matrix cols */ dc = (double *) CALLOC((size_t) *nthreads * *n,sizeof(double)); /* storage for components of diag */ if (*nthreads>1) { bs = *pv / *nthreads; while (bs * *nthreads < *pv) bs++; while (bs * *nthreads - bs >= *pv) (*nthreads)--; bsf = *pv - (bs * *nthreads - bs); } else { bsf = bs = *pv; } #ifdef OPENMP_ON #pragma omp parallel for private(j,bsj,i,kk,p0,p1,p2,p3) num_threads(*nthreads) #endif for (j=0;j < *nthreads;j++) { if (j == *nthreads - 1) bsj = bsf; else bsj = bs; for (i=0;i0) ei[j * *pv + kk - 1] = 0; /* Note thread safety of XBd means this must be only memory allocator in this section*/ Xbd(xv + j * *n,V + kk * *pv,X,k,ks,m,p,n,nx,ts,dt,nt,v,qc,&one); /* XV[:,kk] */ Xbd(xi + j * *n,ei + j * *pv,X,k,ks,m,p,n,nx,ts,dt,nt,v,qc,&one); /* X[:,kk] inefficient, but deals with constraint*/ p0 = xi + j * *n;p1=xv + j * *n;p2 = dc + j * *n;p3 = p2 + *n; for (;p2=0) { /* model has AR component, requiring sqrt(weights) */ for (p0 = w,p1 = w + *n;p00) voff[i+1] = voff[i] + pt[i]; else voff[i+1] = voff[i]; /* start of ith Q matrix */ if (maxp < pt[i]) maxp=pt[i]; if (qc[i]<=0) tps[i+1] = tps[i] + pt[i]; /* where ith terms starts in param vector */ else tps[i+1] = tps[i] + pt[i] - 1; /* there is a tensor constraint to apply - reducing param count*/ } Xy0 = (double *) CALLOC((size_t)maxp,sizeof(double)); work = (double *) CALLOC((size_t)*n,sizeof(double)); work1 = (double *) CALLOC((size_t)maxm,sizeof(double)); /* apply W to y */ Wy = (double *) CALLOC((size_t)*n,sizeof(double)); /* Wy */ for (p0=Wy,p1=Wy + *n,p2=w;p0=0) { /* AR components present (weights are sqrt, therefore) */ rwMatrix(ar_stop,ar_row,ar_weights,Wy,n,&one,&zero,work); rwMatrix(ar_stop,ar_row,ar_weights,Wy,n,&one,&one,work); /* transpose of transform applied */ for (p0=w,p1=w + *n,p2=Wy;p01) { /* it's a tensor */ //tensorXty(Xy0,work,work1,Wy,X+off[ts[i]],m+ts[i],p+ts[i],dt+i,k+ts[i] * (ptrdiff_t) *n,n); for (q=0;q0) { /* there is a constraint to apply Z'Xy0: form Q'Xy0 and discard first row... */ /* Q' = I - vv' */ for (x=0.0,p0=Xy0,p1=p0 + pt[i],p2=v+voff[i];p0=0) { /* model has AR component, requiring sqrt(weights) */ for (p0 = w,p1 = w + *n;p00) voff[i+1] = voff[i] + pt[i]; else voff[i+1] = voff[i]; /* start of ith v vector */ if (maxppd[c]) { /* Form Xr'WXc */ a=r;b=c; } else { /* Form Xc'WXr */ a=c;b=r; } /* split cols between threads... */ dk = pt[b] / *nthreads; //rk = pt[b] % *nthreads; if (dk * *nthreads < pt[b]) dk++; start[0]=0; for (i=0;i<*nthreads;i++) { start[i+1] = start[i] + dk; if (start[i+1]>pt[b]) start[i+1]=pt[b]; } #ifdef OPENMP_ON #pragma omp parallel private(Xi,Xj,i,q,add,temp,tempn,p0,p1,p2) num_threads(*nthreads) #endif { /* begin parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (kk=0;kk<*nthreads;kk++) { /* allocate thread specific storage... */ temp = tempB + kk * (ptrdiff_t) maxm; Xi = XiB + kk * (ptrdiff_t) *n; Xj = XjB + kk * (ptrdiff_t) *n; tempn = tempnB + kk * (ptrdiff_t) *n; for (i=start[kk];i1) { /* tensor */ for (p0=Xi,p1=p0+*n;p01) { /* tensor */ for (p0=Xj,p1=p0+*n;p0=0) { /* AR components present (weights are sqrt, therefore) */ rwMatrix(ar_stop,ar_row,ar_weights,Xi,n,&one,&zero,tempn); rwMatrix(ar_stop,ar_row,ar_weights,Xi,n,&one,&one,tempn); /* transpose of transform applied */ for (p0=w,p1=w + *n,p2=Xi;p01) { /* tensor */ tensorXty(xwx + i * pt[a],tempn,temp,Xi,X+off[ts[a]],m+ts[a],p+ts[a], dt+a,k, n,&add,ks+ts[a],&q); } else { /* singleton */ singleXty(xwx + i * pt[a],temp,Xi,X+off[ts[a]],m+ts[a],p+ts[a],k + (ptrdiff_t)*n * (q + ks[ts[a]]),n,&add); } add = 1; /* for q>0 accumulate result */ } } /* loop over columns of Xb */ } /* so now xwx contains pt[a] by pt[b] matrix Xa'WXb */ } /* end parallel section */ /* if Xb is tensor, may need to apply constraint */ if (dt[a]>1&&qc[a]>0) { /* first term is a tensor with a constraint */ x0=x1=xwx; /* pointers to columns of xwx */ /* col by col form (I-vv')xwx, dropping first row... */ for (j=0;j1&&qc[b]>0) { /* second term is a tensor with a constraint */ /* copy xwx to xwx0 */ for (p0=xwx,p1=p0 + pt[b] * (ptrdiff_t) pa,p2=xwx0;p0pd[c]) { /* xwx = Xr'WXc */ for (i=0;i #include #include #include "general.h" #include "mgcv.h" #include "matrix.h" #ifdef OPENMP_ON #include #endif double ***array3d(int ni,int nj,int nk) /* allocate 3d array */ { double ***a,***p,**p1,*p2; int j; a=(double ***)CALLOC((size_t)(ni),sizeof(double **)); *a=(double **)CALLOC((size_t)(ni*nj),sizeof(double *)); **a=(double *)CALLOC((size_t)(ni*nj*nk),sizeof(double)); p2 = **a; p1= *a;p=a; for (p=a;p0||control[3]) mroot(St,&rank_S,&q); /* St replaced by its square root */ else rank_S=0; /* Now form the augmented R matrix [R',St']' */ r=rank_S+q; R=(double *)CALLOC((size_t)(r*q),sizeof(double)); getRpqr(R,X,&n,&q,&r,nt); /*for (j=0;j1 then X should have nt*q^2 extra (double) memory tagged on the end sp0 - an mp-array of (underlying) smoothing parameters (any -ve => autoinitialize) def_sp - an array of default values for sp0's (any -ve => set up internally) b - a q dimensional parameter vector S - an array of dimension q columns of square roots of the m S_i penalty matrices. There are cS[i] columns for the ith penalty, and they are packed starting from i=0. H - a q by q fixed penalty matrix L - m by mp matrix mapping log(sp0) to log coeffs multiplying S terms. ignored if control[6] is negative. lsp0 - constant vector in linear transformation of log(sp0). So sp = Llog(sp0)+lsp0 also ignored if control[6] is negative. gamma - a factor by which to inflate the model degrees of freedom in GCV/UBRE scores. norm_const - a constant to be added to the residual sum of squares (squared norm) term in the GCV/UBRE and scale estimation calculations. scale - the scale parameter (fixed for UBRE, will be estimated for GCV). Elements of control are as follows: control[0] - 1 for GCV 0 for UBRE control[1] - n, the number of data control[2] - q, the number of parameters control[3] - 1 if H is to be used, 0 to ignore it control[4] - m, the number of penalty matrices in S. control[5] - the maximum number of step halvings to try control[6] - mp, the number of actual smoothing parameters: -ve signals that it's m and L is to be taken as the identity, but ignored. cS[i] gives the number of columns of S relating to S_i (column 0 is the first column of S_0). rank_tol is the tolerance to use in rank determination square root of the machine precision is quite good. tol is the convergence tolerance for the iterative score optimisation. b is the q dimensional parameter vector. rV is a square root of the parameter covariance matrix (to within the scale factor) cov(b)=rV rV' scale nt is the number of threads to use for parts of the calculation if openMP is supported The m square roots of smoothing penalty matrices are packed one after another in S. Currently first guess smoothing parameters are 1/tr(S_i), and second guess are \sigma^2 rank(S_i) / b'S_ib The routine modifies the following arguments on exit: b contains parameter estimates sp contains the smoothing parameter estimates gamma contains the estimated GCV/UBRE score scale - the estimated scale parameter if GCV used tol - the root mean square gradient of the GCV/UBRE score at convergence rV - square root of the param. cov. matrix cov(b) = rV%*%rV'*scale, rV is q by rank. control[0] - the final rank estimate control[1] - 1 if converged, 0 if step failure without meeting convergence criteria control[2] - 1 if the final Hessian was +ve definite control[3] - the number of iterations used control[4] - the number of score function evaluations control[5] - maximum number of step halvings to try control[6] - The maximum number of iterations before giving up Note that the effective degrees of freedom for each parameter are given by the leading diagonal of cov(b)X'X/scale. Appropriate initialization of the smoothing parameters is important for this algorithm, particularly since there is no line search in this approach. Whether the initial estimates are auto-generated or supplied, it is important to start with values such that the partial derivatives of the score w.r.t. the smoothing parameters are all "large", meeaning well above the level judged to have converged. To this end initial values are all checked for derivative magnitude. Any parameters for which the derivative magnitude is too small are modified in an attempt to increase the derivative magnitude. */ { int *pi,*pivot,q,n,autoinit,ScS,m,mp,i,j,tp,k,use_sd=0,rank,converged,iter=0,ok,*cucS, gcv,try,fit_call=0,step_fail=0,max_half,*spok,def_supplied,use_dsyevd=1,L_exists,TRUE=1,FALSE=0; double *sp=NULL,*p,*p1,*p2,*tau,xx,*y1,*y0,yy,**Si=NULL,*work,score,*sd_step,*n_step,*U1,*V,*d,**M,**K, *VS,*U1U1,**My,**Ky,**yK,*dnorm,*ddelta,**d2norm,**d2delta,norm,delta,*grad,**hess,*nsp, min_score,*step,d_score=1e10,*ev=NULL,*u,msg=0.0,Xms,*rSms,*bag,*bsp,sign,*grad1,*u0,*R; #ifdef OPENMP_ON m = omp_get_num_procs(); /* detected number of processors */ if (*nt > m || *nt < 1) *nt = m; /* no point in more threads than m */ omp_set_num_threads(*nt); /* set number of threads to use */ #else *nt = 1; #endif gcv=control[0];q=control[2];n=control[1];m=control[4];max_half=control[5];mp=control[6]; /* first get the QR decomposition of X */ tau=(double *)CALLOC((size_t)q *(1 + *nt),sizeof(double)); /* part of reflector storage */ pivot=(int *)CALLOC((size_t)q,sizeof(int)); /* Accuracy can be improved by pivoting on some occasions even though it's not going to be `used' as such here - see Golub and Van Loan (1983) section 6.4. page 169 for reference. */ /* mgcv_qr(X,&n,&q,pivot,tau);*/ mgcv_pqr(X,&n,&q,pivot,tau,nt); /* Apply pivoting to the parameter space - this simply means reordering the rows of the S_i stored in S doing the same for H, and then unscrambling the parameter vector at the end (along with covariance matrix) pivot[i] gives the unpivoted position of the ith pivoted parameter. */ cucS = (int *)CALLOC((size_t)m,sizeof(int)); /* cumulative cols in S */ for (i=1;i0) { Si=array2d(m,q*q); i=0;j=1; for (p=S,k=0;k0) sp = (double *)CALLOC((size_t)m,sizeof(double)); /* to hold actual log(sp[i]) terms multiplying penalties */ autoinit=0;for (p=sp0;p0&&!def_supplied) /* generate default sp's (only possible if there is no L)*/ { rSms=(double *)CALLOC((size_t)m,sizeof(double)); /* first get some sort of norm for X */ Xms=0.0;for (j=0;j0) /* allocate derivative related storage */ { M=array2d(m,q*q);K=array2d(m,q*q); VS=(double *)CALLOC((size_t)(q * q * *nt),sizeof(double)); My=array2d(m,q);Ky=array2d(m,q);yK=array2d(m,q); hess=array2d(m,m); grad=(double *)CALLOC((size_t)mp,sizeof(double)); grad1=(double *)CALLOC((size_t)m,sizeof(double)); dnorm=(double *)CALLOC((size_t)m,sizeof(double)); ddelta=(double *)CALLOC((size_t)m,sizeof(double)); nsp=(double *)CALLOC((size_t)mp,sizeof(double)); d2norm=array2d(m,m);d2delta=array2d(m,m); ev=(double *)CALLOC((size_t)mp,sizeof(double)); u=(double *)CALLOC((size_t)(m*m),sizeof(double)); u0=(double *)CALLOC((size_t)(m*mp),sizeof(double)); U1U1=(double *)CALLOC((size_t)(q*q),sizeof(double)); spok=(int *)CALLOC((size_t)m,sizeof(int)); /*dir_sp=(int *)CALLOC((size_t)m,sizeof(int));*/ bsp=(double *)CALLOC((size_t)m,sizeof(double)); bag=(double *)CALLOC((size_t)m,sizeof(double)); } else { M=K=My=Ky=yK=hess=d2norm=d2delta=NULL; u0=VS=grad1=grad=dnorm=ddelta=nsp=ev=u=U1U1=bsp=bag=NULL; spok=NULL;/*dir_sp=NULL;*/ } fit_magic(X,sp,Si,H,gamma,scale,control,*rank_tol,yy,y0,y1,U1,V,d,b,&score,&norm,&delta,&rank,norm_const,n_score,nt); fit_call++; /* .... U1 and V are q by rank matrices, d is a dimension rank vector */ /* Now check that all derivatives are large enough that SD or Newton can be expected to work... */ if (mp>0&&!autoinit) { magic_gH(U1U1,M,K,VS,My,Ky,yK,hess,grad1,dnorm,ddelta,sp,d2norm,d2delta,S, U1,V,d,y1,rank,q,m,cS,cucS,gcv,gamma,scale,norm,delta,*n_score,norm_const); xx=1e-4*(1+fabs(score)); ok=1; /* reset to default any sp w.r.t. which score is flat */ if (L_exists) { /* transform to grad w.r.t. sp0 */ i=0;j=1;mgcv_mmult(grad,L,grad1,&j,&i,&mp,&j,&m); } else { p = grad;grad=grad1;grad1=p; } for (i=0;i0) { converged=0;iter=0; while (!converged) { iter++; if (iter>400) error(_("magic, the gcv/ubre optimizer, failed to converge after 400 iterations.")); if (iter>1||(autoinit&&!def_supplied)) ok=1; /* try out step */ else ok=0; /* no step to try yet */ try=0; if (use_sd) step=sd_step; else step=n_step; while (ok) /* try out step, shrinking it if need be */ { try++; if (try==4&&!use_sd) {use_sd=1;step=sd_step;} for (i=0;i3) /* test for convergence */ { converged=1; if (d_score> *tol*(1+min_score)) converged=0; for (xx=0.0,i=0;ipow(*tol,1/3.0)*(1+fabs(min_score))) converged=0; if (try==max_half) converged=1; /* can't improve score */ if (converged) { msg=sqrt(xx*xx/mp);if (try==max_half) step_fail=1;} } /* now get derivatives */ { if (L_exists) { i=0;j=1;mgcv_mmult(sp,L,sp0,&i,&i,&m,&j,&mp); /* form sp = L sp0 */ for (p=sp,p1=lsp0,p2=sp+m;pxx) xx=fabs(n_step[i]); if (xx>5.0) /* scale step to max component length 5 */ { xx=5.0/xx;for (i=0;i0) {... )*/ /* prepare ``outputs''... */ /* now get rV (in unpivoted space) */ for (p2=V,p1=d;p10) {FREE(sp);free2d(Si);} /* unpivot R from QR factor of X */ for (i=0;i /* required for R specific stuff */ #ifdef ENABLE_NLS #include #define _(String) dgettext ("mgcv", String) #else #define _(String) (String) #endif mgcv/src/qp.c0000744000177400001440000006145513046054035012767 0ustar murdochusers/* Copyright (C) 1991-2005 Simon N. Wood simon.wood@r-project.org 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. (www.gnu.org/copyleft/gpl.html) You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.*/ /* Routines for quadratic programming and other constrained optimization. */ #include #include #include #include #include "matrix.h" #include "qp.h" #include "general.h" #include "mgcv.h" #define DELMAX 35 #define max(a,b) (((a) > (b)) ? (a) : (b)) #define min(a,b) (((a) < (b)) ? (a) : (b)) #define round(a) ((a)-floor(a) <0.5 ? (int)floor(a):(int) floor(a)+1) matrix addconQT(Q,T,a,u) matrix *Q,T,a,*u; /* A constraint, a (a row vector), is added to the QT factorization of the working set. T must have been initialised square, and then had T.r set to correct length. */ { int q,i,j; double la,ra=0.0,*cV,*bV,*T1V; matrix b,c; c=initmat(Q->r,1);b=initmat(Q->r,1);(*u)=initmat(Q->r,1); for (i=0;iM[j][i]; la=dot(c,c); cV=c.V;bV=b.V; q=T.c-T.r-1; if (q!=0) { for (i=q+1;i0.0) bV[q]= -bV[q]; householder(u,c,b,q); Hmult((*Q),(*u)); } else for (i=0;ic-T->r-1 rows to store the Givens rotations and must be initialized outside the routine. */ { int q,i,j; double Qi,r,cc,ss,*bV,*sV,*cV,**QM,*QV,bb,bb1; matrix b; b.V=T->M[T->r]; b.r=Q->r;b.c=1; for (i=0;ic;i++) b.V[i]=0.0; for (i=0;ir;j++) b.V[i]+=Q->M[j][i]*a->V[j]; /* now calculate a series of Givens rotations that will rotate the null basis so that it is orthogonal to new constraint a */ bV=b.V;cV=c->V;sV=s->V;QM=Q->M; q=T->c-T->r-1; /* number of Givens transformations needed */ for (i=0;ir;j++) { QV=QM[j]; Qi=QV[i]; QV[i]=cc*Qi + ss*QV[i+1]; QV[i+1]=ss*Qi - cc*QV[i+1]; } } T->r++; } void LSQPaddcon(matrix *Ain,matrix *Q,matrix *T,matrix *Rf,matrix *Py,matrix *PX, matrix *s,matrix *c,int sth) /* Adds the sth row of Ain to the avtive set, updates Q and T using a sequence of T->c-T->r-1 Givens rotations from the right, coefficients of which are stored in s and c. The ith rotation acts on elements (i,i+1) (i=0,1,...). Updates the upper triangular (lower left 0) matrix Rf = PXQ, by applying the above Givens rotations from the right (updating Q) which introduces elements on the sub diagonal of Rf; these subdiaogonal elements are then zeroed using Givens rotations from the left, by way of updating P. Hence Py and PX can be updated at the same time. */ { matrix a; double RfMji,*RfV,*RfV1,ss,cc,r,x1,x2; int i,j,k; a.V=Ain->M[sth];a.r=Ain->c;a.c=1; /* vector containing sth constraint */ s->r=T->c-T->r-1; /* number of Givens rotations about to be returned */ /* Update Q and T and return Givens rotations required to do so ....*/ GivensAddconQT(Q,T,&a,s,c); /* Now apply the rotations from the right to Rf....*/ for (i=0;ir;i++) { cc=c->V[i];ss=s->V[i]; k=i+2;if (k>Rf->r) k--; for (j=0;jM[j]; RfMji=RfV[i]; RfV[i]=cc*RfMji+ss*RfV[i+1]; RfV[i+1]=ss*RfMji - cc*RfV[i+1]; } } /* Now zero the subdiagonal elements that have just been introduced, and apply the Givens rotations from the left, used to do this, to Py and PX */ for (i=0;ir;i++) /* work through the extra subdiagonal elements */ { /* this will act on rows i and i+1, zeroing i+1,i - work out coefficients */ RfV=Rf->M[i];RfV1=Rf->M[i+1]; x1=RfV[i];x2=RfV1[i]; r=sqrt(x1*x1+x2*x2);ss=x2/r;cc=x1/r; Rf->M[i][i]=r;Rf->M[i+1][i]=0.0; for (j=i+1;jc;j++) /* apply rotation along the rows */ { x1=RfV[j];x2=RfV1[j]; RfV[j]=cc*x1+ss*x2; RfV1[j]=ss*x1-cc*x2; } /* Apply this rotation to Py */ x1=Py->V[i];x2=Py->V[i+1]; Py->V[i]=cc*x1+ss*x2; Py->V[i+1]=ss*x1-cc*x2; /* and apply the same rotation to PX */ for (j=0;jc;j++) /* work along the rows */ { x1=PX->M[i][j];x2=PX->M[i+1][j]; PX->M[i][j]=cc*x1+ss*x2; PX->M[i+1][j]=ss*x1-cc*x2; } } } int LSQPstep(int *ignore,matrix *Ain,matrix *b,matrix *p1,matrix *p,matrix *pk) /* This is the stepping routine for the constrained least squares fitting routine. It should be faster than step, but more or less does the same thing. The return value is -1 for a minimum, otherwise the row of Ain containing the constraint to add is returned. ignore[i] should be set to 1 to ignore row i of Ain, to 0 to include it. Starting from p a step is taken to p+pk, if this would violate any constraints in the working set, then a step is taken from p along pk, to the closest constraint. The constraints are Ain p >= b. On exit: p1 contains the new parameter vector; the return value is -1 for a minimum, otherwise the constraint that needs to be added (i.e. the row of Ain) */ { double Ap1,ap,apk,alpha,alphamin,*AV,*pV,*p1V,*pkV; int imin,i,j; alphamin=1.0;imin= -1; p1V=p1->V;pV=p->V;pkV=pk->V; for (i=0;ir;i++) p1V[i]=pV[i]+pkV[i]; /* step all the way to minimum */ for (i=0;ir;i++) /* work through the constraints */ { AV=Ain->M[i]; if (!ignore[i]) /* skip any already in working set */ { Ap1=0.0; for (j=0;jc;j++) Ap1+=AV[j]*p1V[j]; /* form A p1 = A(p+pk) */ if ((b->V[i]-Ap1)>0.0) /* does p+pk violate the ith constraint? */ { ap=0.0;apk=0.0; /* working out quantities needed to find distance to constraint from p */ for (j=0;jc;j++) { ap+=AV[j]*pV[j]; apk+=AV[j]*pkV[j]; } if (fabs(apk)>0.0) { alpha=(b->V[i]-ap)/apk; /* p + alpha*pk is on the ith constraint */ if (alphar;j++) p1V[j]=pV[j]+alphamin*pkV[j]; /* 2/2/97 - avoids distance calc for all that would violate full step */ } } } } } return(imin); } void LSQPdelcon(matrix *Q,matrix *T,matrix *Rf,matrix *Py,matrix *PX,int sth) /* This routine deletes row s from the active set matrix, A, say, where AQ=[0,T] and T is reverse lower triangular (upper left is zero). It updates Q and T using Givens rotations from the right. These rotations induce subdiagonal elements in Rf=PXQ from column Rf->c-T->r to column Rf->c-s+2, where T->r is the number of active constraints before deletion. Note however that the Givens rotations that update Q and T, have to be applied in an order that works back through the columns of Rf=PXQ - this has the potential to produce a triangular block of elements below the diagonal, if they are all applied before applying the update rotations for P. Hence the appropriate thing to do is to apply each rotation from the left to Rf, as it is obtained and then work out the Givens rotation from the left that will immediately zero the unwanted subdiagonal element - this being an update of P, which should immediately be applied to PX and Py. */ { int i,j,colj,coli,k,Tr,Tc,Qr,T1r,T1c; double r,s,c,xi,xj,**TM,**QM,*TV,*QV,*T1V,*RfV,*RfV1; Tr=T->r;TM=T->M;QM=Q->M;Tc=T->c;Qr=Q->r; for (i=sth+1;iM[j]; /* row to apply rotation to */ xi=RfV[coli]; RfV[coli]= -c*xi+s*RfV[colj]; RfV[colj]=s*xi+c*RfV[colj]; } /* There is now an unwanted element at row colj, column coli */ /* Calculate a rotation from the right that will zero the extra element */ xi=Rf->M[coli][coli];xj=Rf->M[colj][coli]; /* xj to be zeroed */ r=sqrt(xi*xi+xj*xj); s=xj/r;c=xi/r; /* Givens coefficients to zero xj into xi */ Rf->M[coli][coli]=r;Rf->M[colj][coli]=0.0; /* Now apply to rest of row from column colj (column coli already done) */ RfV=Rf->M[coli];RfV1=Rf->M[colj]; for (j=colj;jc;j++) { xi=RfV[j];xj=RfV1[j]; RfV[j]=c*xi+s*xj; RfV1[j]=s*xi-c*xj; } /* And apply this rotation from the right to Py and PX */ /* Apply this rotation to Py */ xi=Py->V[coli];xj=Py->V[colj]; Py->V[coli]=c*xi+s*xj; Py->V[colj]=s*xi-c*xj; /* and apply the same rotation to PX */ for (j=0;jc;j++) /* work along the rows */ { xi=PX->M[coli][j];xj=PX->M[colj][j]; PX->M[coli][j]=c*xi+s*xj; PX->M[colj][j]=s*xi-c*xj; } } /* Now actually remove the extra row from T - this could be done awefully efficiently */ /* by shuffling the pointers to rows, but it would probably end in tears, so I haven't */ T->r--;T1r=T->r;T1c=T->c; for (k=0;k l'[0,T]=g'Q, and to find l, solve l'T=x, where x is the last tk=T->r rows of g'Q - this also yields the minimum of ||A'l-g||, which is appropriate. Note that T passed to the routine actually contains [0,T] and the first fixed_cons rows of T relate to the fixed constraints (if any). p1 and y1 are workspace matrices of length p->r and X->r respectively The routine returns -1 if there are no -ve multiplier estimates, otherwise it returns the index of *Inequlity* constraint with the most negative one. fixed[i] is set to 1 if the corresponding inequlity constraint is to be left in the active set regardless of lagrange multiplier - this is part of a strategy to avoid repeatedly deleting constraints wrongly. */ { int i,j,tk; double x; tk=T->r; vmult(X,p,y1,0); /* form y1= Xp */ vmult(X,y1,p1,1); /* form p1 = X'Xp */ for (i=0;ir;i++) p1->V[i]+= -Xy->V[i]; /* form p1 = g = X'Xp - X'y */ /* now create the last tk=T->r elements of g'Q and store in y1 */ for (i=0;iV[i]=0.0; for (j=0;jr;j++) y1->V[i]+=p1->V[j]*Q->M[j][Q->c-tk+i]; } /* Now solve l'T=g'Q (where first tk rows of y1 contain g'Q).... */ for (i=tk-1;i>=fixed_cons;i--) /* work down through the the lagrange multipliers */ { x=0.0;for (j=i+1;jV[j]*T->M[j][T->c-i-1]; if (T->M[i][T->c-i-1]!=0.0) p1->V[i]=(y1->V[tk-i-1]-x)/T->M[i][T->c-i-1];else p1->V[i]=0.0; } /* Now look for the most negative multiplier for an inequlity constraint */ x=0.0;j=-1; for (i=fixed_cons;iV[i]V[i];} /* if (j==-1) if (p1->V[i]V[i];} */ /* only delete last constraint added if it has only -ve multiplier */ if (j!=-1) j -= fixed_cons; return(j); /* returns index of inequality constraint to delete */ } /***************************************************************************/ /* Main Public Routines. */ /***************************************************************************/ void QPCLS(matrix *Z,matrix *X, matrix *p, matrix *y,matrix *Ain,matrix *b,matrix *Af,int *active) /* This routine aims to fit linearly constrained least squares problems of the form: min ||Xp-y||^2 subject to Ain p>=b and Af p = constant *without* forming X'X directly. By suitable redefinition of X and y it's easy to perform weighted and/or penalized regressions using this routine...... The routine uses working matrices T, Q, Rf, PX and working vectors Py, Xy, pz, pk, Pd In addition the routine creates workspace for the various service routines called by it, in order to avoid excessive memory allocation and deallocation. The Algorithm is as follows... 1. Form the QT factorisation of Af: Af Q = [0,T] T reverse lower triangular (i.e top left 0). Q contains column bases for the null and range spaces of Af: Q=[Z,Y]. Apply Q to X to get XQ(=[XZ,XY]). Form Q explicitly to give ready access to the null space basis Z. 2. Perform QR decomposition: XQ = P'Rf where P is orthogonal and Rf is upper triangular (lower left 0). Hence Rf= PXQ=[PXZ,PXY], as required. Apply P to y to get Py. Apply P to X to get PX. 3. Form Pd = Py-PXp, and solve: minimise || R pz - Pd ||^2, where R is the first p->r-tk-Af->r rows and columns of Rf. Solution occurs when R pz=x and x is the first p->r - tk - Af->r rows of Pd. (Note that Gill et al. get the sign wrong for Pd.) 4. Evaluate pk=Z pz, and step along it to minimum (goto 6.) or constraint. 5. Add constraint to working set: update QT factorisation; update Rf; update Py and PX. Return to 3. 6. Evaluate Lagrange multipliers l where Ac'l=g and g=X'Xp-X'y - Ac is the active constraint matrix. Clearly g involves X'X, which is unfortunate, but I can't figure out a way around it - however, it is only the signs of l that matter, so hopefully this is not critical. If multipliers are all +ve goto 8. otherwise proceed.... 7. Delete the constraint with the most -ve multiplier, updating Q, T, Rf, Py and PX at the same time. Return to 3. 8. Convergence! A minimum has been achieved. Free the workspace matrices and vectors and the indexing arrays, obtain Z, and return. On exit active[] contains the number of active inequlity constraints in active[0], and the row number of these constraints in Ain in the remaining elements of active[], active must be initialized to length p.r+1 on entry. See documentation in service routines: LSQPlagrange(); LSQPaddcon(); LSQPdelcon(); (above) Rsolv() (in matrix.c) for further details on steps 6, 5, 7 and 3. The approach is taken from Gill, Murray and Wright (1981) Practical Optimization page 180-181 Section 5.3.3. (But note wrong signs on p181 first display equation and definition of d_k) Routine has been tested against less numerically stable alternative using QP(). 20/11/99 */ { matrix Q,T,Rf,PX,Py,a,P,p1,s,c,Xy,y1,u,Pd,pz,pk; int k,i,j,tk,*I,*ignore,iter=0,*fixed,*delog,maxdel=100; double x; I=(int *)CALLOC((size_t) p->r,sizeof(int)); /* I[i] is the row of Ain containing ith active constraint */ fixed=(int *)CALLOC((size_t) p->r,sizeof(int)); /* fixed[i] is set to 1 when the corresponding inequality constraint is to be left in regardless of l.m. estimate */ ignore=(int *)CALLOC((size_t) Ain->r,sizeof(int)); /* ignore[i] is 1 if ith row of Ain is in active set, 0 otherwise */ delog=(int *)CALLOC((size_t) Ain->r,sizeof(int)); /* counts up number of times a constraint is deleted */ p1=initmat(p->r,1); /* a working space vector for stepping & lagrange */ y1=initmat(y->r,1); /* a work space vector for lagrange */ s=initmat(p->r,1);c=initmat(p->r,1); /* working space vectors for Givens rotation */ Xy=initmat(p->r,1); /* vector storing X'y for use in lagrange multiplier calculation */ vmult(X,y,&Xy,1); /* form X'y */ Rf=initmat(X->r,X->c); /* Rf=PXQ, where P and Q are orthogonal */ mcopy(X,&Rf); /* initialize Rf while P and Q are identity matrices */ T=initmat(p->r,p->r); /* initialised to max possible size */ Q=initmat(p->r,p->r); /* required for access to Z for null space to full space transform */ /* initialize Q, T and Rf using fixed constraints (if any) .... */ for (i=0;ir;i++) for (j=0;jr;j++) Q.M[i][j]=0.0; for (i=0;ir;i++) Q.M[i][i]=1.0; T.r=0;a.r=1;a.c=Af->c; for (i=0;ir;i++) { a.V=Af->M[i]; T=addconQT(&Q,T,a,&u); /* adding constraint from Af to working set */ Hmult(Rf,u); /* updating Rf (=XQ, at present) */ freemat(u); /* freeing u created by addconQT() */ } /* Now Form Rf, proper. i.e. PXQ, using QR factorization */ P=initmat(Rf.c,Rf.r); QR(&P,&Rf); /* Rf now contains Rf=PXQ (on entry it contained XQ) */ Py=initmat(y->r,1);mcopy(y,&Py); OrthoMult(&P,&Py,0,(int)P.r,0,1,1); /* Form Py */ PX=initmat(X->r,X->c);mcopy(X,&PX); OrthoMult(&P,&PX,0,(int)P.r,0,1,1); /* Form PX */ freemat(P); /* no longer needed */ P=initmat(b->r,1); /* used solely for feasibility checking */ Pd=initmat(y->r,1);pz=initmat(p->r,1);pk=initmat(p->r,1); tk=0; /* The number of inequality constraints currently active */ /*printf("\nLSQ");*/ while(1) { iter++; /* Form Pd=Py-PXp and minimize ||R pz - Pd|| */ vmult(&PX,p,&Pd,0); /* Pd = PXp */ for (i=0;ir-tk-Af->r; /* Restrict attention to QR factor of PXZ */ for (i=0;ir;Rf.c=X->c; /* Restore Rf */ pz.r=p->r-tk-Af->r; /* Find pk = Z pz, the search direction */ for (i=0;i-1) /* add a constraint to the working set and update Rf, Py and PX */ { I[tk]=k;ignore[k]=1; /* keeping track of what's in working set */ LSQPaddcon(Ain,&Q,&T,&Rf,&Py,&PX,&s,&c,k);tk++; if (delog[k]>maxdel) fixed[tk-1]=1; /*Rprintf("+");*/ } else /* it's a minimum - check lagrange multipliers */ { k=LSQPlagrange(X,&Q,&T,p,&Xy,&p1,&y1,fixed,(int)Af->r); if (k>-1) /* then a constraint must be deleted */ { LSQPdelcon(&Q,&T,&Rf,&Py,&PX,k+(int)Af->r); /* the Af.r added to k ensures that correct row of T deleted */ /*Rprintf("-");*/ /* update the fixed constraint list */ { for (i=k;i-1) /* updating indexing arrays */ { ignore[I[k]]=0; delog[I[k]]++; for (i=k;iV[i]V[i]; /*printf("P\n Worst feasibility violation %g",x);*/ /* create Z - this version is a full null space matrix, rather than sequence of rotations */ *Z=Q; Z->c -= tk; /* copy active constraint information to active */ active[0]=tk; for (i=0;i=b & Af p = "a constant vector" ...where B is a sum of m S[i] matrices multiplied by smoothing parameters theta[i]. The S[i]'s may be smaller than B (p->r by p->r) so S[i] is added to B starting at row and column off[i]. B must be non-negative definite, which means that the S[k]'s must be. W is the diagnoal matrix having w on the leading diagonal. In many applications the ith element of w will be the reciprocal of the variance associated with the ith element of i. The routine uses the fact that the problem can be re-written as.... minimise || Fp - z ||^2 Subject to Ain p >= b Af p = constant ... where F = [ X'W^0.5, B^0.5']' and z = [y'W^0.5, 0]'. This rewrite is performed and then QPCLS is called to obtain the solution. If H->r==y->r on entry, then an influence (or "hat") matrix is returned in H. At present the calculation of H is inefficient and none too stable. On exit active[] contains a list of the active inequlity constraints in elements 1->active[0]. This array should be initialized to length p.r+1 on entry. 20/11/99 */ { int i,j,k; matrix z,F,W,Z,B,C; double x,xx; /* form transformed data vector z */ if (m>0) z=initmat(y->r+p->r,1);else z=initmat(y->r,1); W=initmat(w->r,1); for (i=0;ir;i++) { W.V[i]=sqrt(w->V[i]);z.V[i]=W.V[i]*y->V[i];} /* form transformed design matrix X */ F=initmat(z.r,p->r); /* first put in W^0.5X */ for (i=0;ir;i++) for (j=0;jc;j++) F.M[i][j]=W.V[i]*X->M[i][j]; /* add up the Penalties */ if (m>0) { B=initmat(p->r,p->r); for (k=0;kr rows of F */ for (i=0;ir][i]=C.M[i][j]; freemat(B);freemat(C); } /* printf("\ncond(F)=%g",condition(F));*/ /* Which means that the problem is now in a form where QPCLS can solve it.... */ QPCLS(&Z,&F,p,&z,Ain,b,Af,active); /* note that at present Z is full not HH */ if (H->r==y->r) /* then calculate the influence matrix XZ(Z'F'FZ)^{-1}Z'X'W */ { freemat(W);W=initmat(Z.c,Z.c); multi(4,W,Z,F,F,Z,1,1,0,0);invert(&W); /* Wildly inefficient!! */ multi(5,*H,*X,Z,W,Z,*X,0,0,0,1,1); /* ditto */ for (i=0;ir;i++) for (j=0;jc;j++) H->M[i][j]*=w->V[j]; } /* working out value of objective at minimum */ B=initmat(z.r,1);matmult(B,F,*p,0,0); xx=0.0;for (i=0;i #include #include #include "mgcv.h" #include "matrix.h" #include "general.h" #include "tprs.h" #include /* Code for thin plate regression splines */ #define ROUND(a) ((a)-(int)floor(a)>0.5) ? ((int)floor(a)+1):((int)floor(a)) double eta_const(int m,int d) { /* compute the irrelevant constant for TPS basis */ double pi=PI,Ghalf; double f; int i,k,d2,m2; Ghalf = sqrt(pi); /* Gamma function of 0.5 = sqrt(pi) */ d2 = d/2;m2 = 2*m; if (m2 <= d) error(_("You must have 2m>d for a thin plate spline.")); if (d%2==0) /* then d even */ { if ((m+1+d2)%2) f= -1.0; else f=1.0; /* finding (-1)^{m+1+d/2} */ for (i=0;ir,X->r); EM = E->M; eta0 = eta_const(m,d); XMi = X->M;Xr = X->r;Xc = X->c; for (i=0;iM,j=0;jM[i][k]-X->M[j][k];*/ x = *xi - *xj; r+=x*x; } /*r=sqrt(r);*/ /* r= ||x_j-x_i||^2 where x_k is kth location vector */ EM[i][j]=EM[j][i]=fast_eta(m,d,r,eta0); } } void gen_tps_poly_powers(int *pi /* **pi */,int *M,int *m, int *d) /* generates the sequence of powers required to specify the M polynomials spanning the null space of the penalty of a d-dimensional tps with wiggliness penalty order m So, if x_i are the co-ordinates the kth polynomial is x_1^pi[k][1]*x_2^pi[k][2] .... pi[k][j] actually stored as pi[k + M * j] */ { int *index,i,j,sum; index=(int *)CALLOC((size_t) *d,sizeof(int)); for (i=0;i < *M;i++) { /* copy index to pi */ /* for (j=0;jr,M); for (i=0;ir;i++) for (j=0;jM[i][k]; */ for (k=0;kM[i][k]; T->M[i][j]=x; } /*for (i=0;id+1 */ { int M,i; if (2*m<=d) {m=1;while (2*m0) { m=0;while (2*m0&&sm>0) { /*for (i=0;i0) /* get a new basis for the null space of the penalty */ { M=1; /* dimension of penalty null space */ for (i=0;iM;n = X->r; for (pb=b,i=0;ir) g += *pb *p->V[i]; } off=1-constant; for (i=off;iV[i+X->r-off]=r;*/ if (p->r) g+=p->V[i+n-off]*r; } return(g); } int Xd_row_comp(double *a,double *b,int k) /* service routine for Xd_strip(), compares k elements of two rows for equality */ { int i; for (i=0;ir-1. These are vital for constructing the index. On exit Xd->r will contain the number of unique covariate points. */ { int *yxindex,start,stop,ok,i; double xi,**dum; yxindex = (int *)CALLOC((size_t)Xd->r,sizeof(int)); dum = (double **)CALLOC((size_t)Xd->r,sizeof(double *)); msort(*Xd); start=stop=0;ok=1; while(ok) { /* look for start of run of equal rows ..... */ while(startr-1&&!Xd_row_comp(Xd->M[start],Xd->M[start+1],Xd->c-1)) { /* Xd->M[start] not tied with anything, nothing to erase.... */ xi=Xd->M[start][Xd->c-1]; yxindex[ROUND(xi)]=start; start++; } if (start==Xd->r-1) { ok=0; /* reached end with no more ties */ xi=Xd->M[start][Xd->c-1]; yxindex[ROUND(xi)]=start; /* final index entry needed */ } if (ok) /* search for end of run */ { stop=start+1; while(stopr-1&&Xd_row_comp(Xd->M[stop],Xd->M[stop+1],Xd->c-1)) stop++; for (i=start;i<=stop;i++) /* fill out the index array */ { xi=Xd->M[i][Xd->c-1]; yxindex[ROUND(xi)]=start; dum[i-start]=Xd->M[i]; /* Rows stored to copy back onto end, so matrix can be freed properly */ } for (i=stop+1;ir;i++) { Xd->M[i-stop+start]=Xd->M[i];} Xd->r -= stop-start; for (i=1;i<=stop-start;i++) { Xd->M[Xd->r-1+i]=dum[i];} } } FREE(dum); return(yxindex); } void tprs_setup(double **x,double **knt,int m,int d,int n,int k,int constant,matrix *X,matrix *S, matrix *UZ,matrix *Xu,int n_knots) /* Takes d covariates x_1,..,x_d and creates the truncated basis for an order m smoothing spline, returning the design matrix and wiggliness penalty matrix for this spline, along with the matrix transforming back to the regular basis. The dimension of the truncated basis must be greater than the dimension of the null space of the penalty. The inputs are: x[i] = array of n values for covariate i (i=0..d-1) m = the order of the penalty (order of derivatives in penalty) if 2m>d is not satisfied (e.g. if m==0) then m is set to smallest value such that 2m>d+1 (ensures visual smoothness) d = the dimension of the spline = number of covariates. n = number of data. k = dimension of truncated basis. This must be greater than the dimension of the null space of the penalty, which is M=(m+d-1)!/[d!(m-1)!] constant = 0 if there is to be no intercept term in the model, 1 otherwise knt[i] array of n_knot knot location values for covariate i n_knot number of knots supplied - 0 for none meaning that the values in x are the knots. n_knots XW UZ -> UZW S -> WSW Provided the user uses UZ to transform back to the t.p.s parameters the rescaling is transparent. */ { matrix X1,E,U,v,TU,T,Z,p; const char trans='T'; int l,i,j,M,*yxindex,pure_knot=0,nk,minus=-1,kk,one=1; double w,*xc,*XMi,*Ea,*Ua,tol=DOUBLE_EPS,*b,*a,*uz,alpha=1.0,beta=0.0,*p0,*p1; tol = pow(tol,.7); if (n_knotsM[i][j]=x[j][i];Xu->M[i][d]=(double)i;} } else /* knot locations supplied */ { *Xu=initmat(n_knots,d+1); for (i=0;iM[i][j]=knt[j][i];Xu->M[i][d]=(double)i;} } /* Now the number of unique covariate "points" must be obtained */ /* and these points stored in Xu, to avoid problems with E */ yxindex=Xd_strip(Xu); /*yxindex[i] is the row of Xu corresponding to y[i] */ Xu->c--; /* hide indexing column */ if (Xu->rrr==k) pure_knot=1; /* basis dimension is number of knots - don't need eigen step */ if (pure_knot) /* don't need the lanczos step, but need to "fake" various matrices to make up for it! */ { *UZ=initmat(T.r+M-1+constant,T.r); UZ->r=T.r; TU=initmat(T.c,T.r); for (i=0;ir=U.r; mcopy(&U,UZ); HQmult(*UZ,Z,0,0);UZ->c -= M; /* Now UZ multiplied by truncated delta gives full delta */ UZ->c += M-1+constant; /* adding cols for un-constrained terms to UZ */ } UZ->r +=M-1+constant; /* Now add the elements required to get UZ to map from whole real parameter vector to whole t.p.s. vector */ for (i=0;ic;j++) UZ->M[i][j]=0.0; for (i=0;iM[UZ->r-i-1][UZ->c-i-1]=1.0; /* Now construct the design matrix X = [Udiag(v)Z,T] .... */ if (n_knotsM[i][j]=X1.M[l][j]; } freemat(X1); } else /* the user supplied a set of knots to generate the original un-truncated basis */ { p.r=0; /* don't want a value from tps_g() */ xc=(double *)CALLOC((size_t)d,sizeof(double)); kk = (int) UZ->r; b=(double *)CALLOC((size_t)kk,sizeof(double)); /* initmat((long)UZ->r,1L);*/ *X=initmat(n,k); a = (double *)CALLOC((size_t)k,sizeof(double)); /* following loop can dominate computational cost, so it is worth using BLAS routines and paying some attention to efficiency */ uz = (double *) CALLOC((size_t)(kk*k),sizeof(double)); RArrayFromMatrix(uz,kk,UZ); for (i=0;iM[i]; for (p0=a,p1=a+k;p0M[i]; UZM=UZ->M; for (j=0;jM[i][i]=v.V[i]; HQmult(*S,Z,0,0);HQmult(*S,Z,1,1); for (i=0;ir;i++) for (j=S->r-M;jr;j++) S->M[i][j]=S->M[j][i]=0.0; if (!constant) {S->r--;S->c--;} /* Now linearly transform everything so that numerical properties of X are as nice as possible. Specifically, rescale each column of X so that it has rms value 1. X -> XW. This means that S -> WSW and UZ -> UZW. */ for (i=0;ic;i++) { w=0; for (j=0;jr;j++) w+=X->M[j][i]*X->M[j][i]; w=sqrt(w/X->r); for (j=0;jr;j++) X->M[j][i]/=w; for (j=0;jr;j++) UZ->M[j][i]/=w; for (j=0;jr;j++) S->M[i][j]/=w; for (j=0;jr;j++) S->M[j][i]/=w; } FREE(yxindex);freemat(Z);freemat(TU);freemat(E);freemat(T); if (!pure_knot) {freemat(U);freemat(v);} } void construct_tprs(double *x,int *d,int *n,double *knt,int *nk,int *m,int *k,double *X,double *S, double *UZ,double *Xu,int *nXu,double *C) /* inputs: x contains the n values of each of the d covariates, stored end to end knt contains the nk knot locations packed as x m is the order of the penalty k is the basis dimension max_knots is the maximum number of knots to allow in t.p.r.s. setup. outputs: X is the n by k model matrix S is the K by K penalty matrix UZ is the (nXu+M) by k matrix transforming from the truncated to full bases Xu is the nXu by d matrix of unique covariate combinations C is the 1 by k sum to zero constraint matrix */ { double **xx,**kk=NULL,*dum,**XM; matrix Xm,Sm,UZm,Xum; int i,j,Xr; xx=(double **)CALLOC((size_t)(*d),sizeof(double*)); for (i=0;i<*d;i++) xx[i]=x + i * *n; if (*nk) { kk=(double **)CALLOC((size_t)(*d),sizeof(double*)); for (i=0;i<*d;i++) kk[i]=knt + i * *nk; } tprs_setup(xx,kk,*m,*d,*n,*k,1,&Xm,&Sm,&UZm,&Xum,*nk); /* Do actual setup */ RArrayFromMatrix(X,Xm.r,&Xm); RArrayFromMatrix(S,Sm.r,&Sm); RArrayFromMatrix(UZ,UZm.r,&UZm); RArrayFromMatrix(Xu,Xum.r,&Xum); *nXu=Xum.r; /* construct the sum to zero constraint */ dum=C;XM=Xm.M;Xr=Xm.r; for (i=0;i< *k;i++) { *dum = 0.0; for (j=0;j 0) { *m = 0;while ( 2 * *m < *d+2) (*m)++;} /* get null space polynomial powers */ pin=(int *)CALLOC((size_t) (*M * *d),sizeof(int)); gen_tps_poly_powers(pin, M, m, d); eta0 = eta_const(*m,*d); /*Xum=Rmatrix(Xu,*nXu,*d);*/ nobsM = *nXu + *M; /* UZm=Rmatrix(UZ,nobsM,*k);*/ b=(double *)CALLOC((size_t)nobsM,sizeof(double)); /* initmat(UZm.r,1L);*/ a=(double *)CALLOC((size_t)*k,sizeof(double)); /* Xm=initmat((long)*n,(long)*k);*/ xx=(double*)CALLOC((size_t) *d,sizeof(double)); for (Xp=X,xp=x,i=0;i< *n;i++,xp++,Xp++) { if (*by_exists) by_mult=by[i]; else by_mult=1.0; if (by_mult==0.0) { /* then don't waste flops on calculating stuff that will only be zeroed */ /*for (j=0;j< *k ;j++) Xm.M[i][j]=0.0;*/ for (xxp=Xp,j=0;j < *k;j++,xxp+= *n) *xxp = 0.0; } else { /* proceed as normal */ for (xxp=xx,xxp1=xx + *d,xp1=xp;xxp < xxp1;xxp++,xp1 += *n) *xxp = *xp1; /*xx[j]=x[j * *n + i];*/ /* evaluate radial basis */ for (Xup=Xu,Xup1=Xu+*nXu,pb=b;Xupd not satisfied. 11/2/2002 - tprs_setup now retains the largest magnitude eigen-vectors irrespective of sign this was not correctly handled previously: -ve's were always kept, due to an error in the original tprs optimality derivation. 2-3/2002 - tprs_setup modified to allow knot based tprs bases - pure knot based or knot and then eigen are both allowed. 6/5/2002 - bug fix: full spline bases failed - part of tprs_setup treated them as knot based and part as eigen-based - resulted in seg fault. 3/10/2002 - tps_g() has a fix so that if told to clear up before having anything to clear up, it doesn't write all sorts of things to un-allocated memory. Many thanks to Luke Tierney for finding this. 3/10/2002 - tprs_setup now tells tps_g() to clear up before returning 1/11/2005 - eta() constants `wrong' for odd d: fixed. */ mgcv/src/soap.c0000744000177400001440000003252413046054035013304 0ustar murdochusers/* Code for soap film smoothing. Copyright Simon Wood 2006-2012. R CMD SHLIB soap.c creates appropriate soap.so from this, can then be loaded by dyn.load("soap.so") and called with .C() */ #include #include #include #include #include "mgcv.h" /****************************************************************************************************/ /* Boundary handling utilities from here on.... */ /****************************************************************************************************/ void boundary(int *G, double *d, double *dto, double *x0, double *y0, double *dx, double *dy, int *nx, int *ny, double *x, double *y,double *break_code, int *n, int *nb) /* Function to create solution grid definition matrix G (nx by ny). Lower left cell centre is at x0, y0. cells are dx by dy. On entry matrices d and dto are same dimension as G. The boundary is supplied in n-arrays, `x' and `y'. Sub loops are separated by elements <= break_code. nb must have dimension of number of loops. On exit: G[i,j] < - nx * ny is outside boundary, otherwise G[i,j] <= 0 is on boundary, and -G[i,j] indexes cell in d and g. G[i,j] > 0 indexes cell in g. On exit d contains the distances along the boundary, stored sequentially from element 0 (i.e. d is a 1D array). nb contains the length of each boundary loop in d (i.e. its cell count). 'g' refers to the solution grid itself, which will contain only interior and boundary points. The boundary in x,y must be *strictly* within the outer grid cells. `G' is stored column-wise (R default). `dto' is a working matrix containing distances from the boundary to the cell centre. This is needed for judging which of multiple boundary segments should supply the boundary value (the closest). The term `vertical' means parallel to y axis. The basic principle is that the boundaries between grid cells are given by a set of evenly spaced horizontal and vertical lines. It is easy to work out which lines are crossed by a boundary line segment, and where this crossing occurs. Cells whose cell boundaries are cut are treated as boundary cells. */ { int segi,j,j0,j1,k,kk,i,reversed,*inb,*ip,*ip1,*ip2,bnd_count,ii,out_lim; double x1,y1,x2,y2,xb0,yb0,xl,yl,xc,yc,dist,dist_to,grad=0.0,b,len2,*p1,*p2; /* first step is to mark outside points in grid */ p1 = d;p2 = dto; for (x1 = *x0,i=0;i<*nx;i++,x1 += *dx) { for (y1 = *y0,j=0;j<*ny;j++,y1 += *dy,p1++,p2++) { *p1 = x1;*p2 = y1; /* cell centres */ } } k = *nx * *ny; /* total size of G, d, dto */ out_lim = -k; inb = (int *)CALLOC((size_t)k,sizeof(int)); in_out(x,y,break_code,d,dto,inb,n,&k); /* test all cell centres for in/out */ j = -(k + 10); for (ip = inb,ip1 = G,p2 = dto,ip2=G+k;ip10) grad = (y2-y1)/(x2-x1); else j1=j0-1; for (j=j0;j<=j1;j++) { /* loop through intersected lines */ xl = xb0 + j * *dx; /* line location */ yl = y1 + (xl - x1)*grad; /* y intersection location */ k = (int) floor(( yl - yb0)/ *dy); /* so nodes j,k and (j-1),k are boundary nodes */ kk = (j-1) * *ny + k; if (G[kk]>0||G[kk]< out_lim) { /* otherwise already a boundary cell */ G[kk] = -ii; ii++; nb[bnd_count]++; } kk += *ny; /* j * *ny + k */ if (G[kk]>0||G[kk]< out_lim) { /* otherwise already a boundary cell */ G[kk] = -ii; ii++; nb[bnd_count]++; } /* Now get the distance along/to the boundary */ for (i=0;i<2;i++) { /* loop over the two cells concerned */ xl = x2-x1;yl=y2-y1; xc = (j-i) * *dx + *x0; yc = k * *dy + *y0; xc -= x1;yc -= y1; /* cell centre done */ len2 = yl*yl + xl*xl; b = (xc*xl + yc*yl)/len2; xl = xl*b+x1;yl = yl * b + y1; /* location of projection from node to line */ if (xl < x1) {xl = x1;yl = y1;} if (xl > x2) {xl = x2;yl = y2;} /* constrained to *within* segment */ dist_to = sqrt((xl-xc)*(xl-xc) + (yl-yc)*(yl-yc)); kk = (j-i) * *ny + k; if (dist_to < dto[kk] || dto[kk]<0) { dto[kk] = dist_to; xl -= x1; yl -= y1; if (reversed) d[-G[kk]] = dist + sqrt(len2) - sqrt(xl*xl + yl*yl); else d[-G[kk]] = dist + sqrt(xl*xl + yl*yl); /* distance along boundary */ } } } /* end of vertical line processing */ /* Now deal with horizontal lines */ if (y[segi-1]0) grad = (x2-x1)/(y2-y1); else j1=j0-1; for (j=j0;j<=j1;j++) { /* loop through intersected lines */ yl = yb0 + j * *dy; /* line location */ xl = x1 + (yl - y1)*grad; /* y intersection location */ k = (int) floor(( xl - xb0)/ *dx); /* so nodes k,j and k, (j-1) are boundary nodes */ kk = k * *ny + j - 1; if (G[kk]>0||G[kk]< out_lim) {G[kk] = -ii;ii++;nb[bnd_count]++;} /* otherwise already a boundary cell */ kk ++; /* k * *ny + j */ if (G[kk]>0||G[kk]< out_lim) {G[kk] = -ii;ii++;nb[bnd_count]++;} /* otherwise already a boundary cell */ /* Now get the distance along/to the boundary */ for (i=0;i<2;i++) { /* loop over the two cells concerned */ xl = x2-x1;yl=y2-y1; yc = (j-i) * *dy + *y0; xc = k * *dx + *x0; xc -= x1;yc -= y1; /* cell centre done */ len2 = yl*yl + xl*xl; b = (xc*xl + yc*yl)/len2; xl = xl*b+x1;yl = yl * b + y1; /* location of projection from node to line */ if (yl < y1) {xl = x1;yl = y1;} if (yl > y2) {xl = x2;yl = y2;} /* constrained to *within* segment */ dist_to = sqrt((xl-xc)*(xl-xc) + (yl-yc)*(yl-yc)); kk = k * *ny + j-i; if (dist_to < dto[kk] || dto[kk]<0) { dto[kk] = dist_to; xl -= x1; yl -= y1; if (reversed) d[-G[kk]] = dist + sqrt(len2) - sqrt(xl*xl + yl*yl); else d[-G[kk]] = dist + sqrt(xl*xl + yl*yl); /* distance along boundary */ } } } /* end of horizontal line processing */ /* update `dist' */ x2 = x2-x1;y2=y2-y1; dist += sqrt(x2*x2+y2*y2); /* now look ahead to see if we are at the end of a sub-loop */ if (segi < *n - 1 && x[segi+1] <= *break_code) { /* reached segment end */ dist = 0.0; /* reset for new loop */ segi++;segi++; /* move past the break */ bnd_count++; /* loop counter */ if (segi < *n) nb[bnd_count] = 0; /* set cell counter for this loop */ } } /* end of line segment loop */ /* Clear the remainder of d to -ve */ k = *nx * *ny;for (i=ii;i 0) {*ip1 = ii;ii++;} } /* end of boundary */ void pde_coeffs(int *G,double *x,int *ii,int *jj,int *n,int *nx,int *ny,double *dx,double *dy) { /* Takes nx by ny grid G produced by function boundary, and produces corresponding PDE coefficient matrix, for soap PDEs in sparse triplet form. On entry x, ii and jj should be of length 5 times the number of cells within the boundary. On exit n will contain their exact required length. */ int i,j,*ip,outside,Gk0,Gk1,k0,k1; double xc,dx2,dy2,thresh=0.0; thresh = dx2= 1.0/(*dx * *dx);dy2 = 1.0/(*dy * *dy); if (dy2 < thresh) thresh = dy2; thresh *= .5; outside = - *nx * *ny - 1; *n=0; for (ip=G,i=0;i<*nx;i++) for (j=0;j<*ny;j++,ip++) if (*ip > outside){ if (*ip <= 0) { /* boundary cell */ *x=1.0;*jj = *ii= - *ip; x++;ii++;jj++;*n += 1; } else { /* interior */ xc=0.0; /* diagonal coefficient */ if (i>0&&i< *nx-1) { /* FD w.r.t. x may be possible */ k0 = (i-1) * *ny + j; /* backwards diff */ k1 = k0 + 2 * *ny; /* forwards diff */ Gk0 = G[k0];Gk1 = G[k1]; if (Gk0 > outside && Gk1 > outside) { /* difference is possible */ xc += 2*dx2; if (Gk0<0) Gk0 = -Gk0; *x = -dx2;*ii = *ip;*jj = Gk0; x++;ii++;jj++;*n += 1; if (Gk1<0) Gk1 = -Gk1; *x = -dx2;*ii = *ip;*jj = Gk1; x++;ii++;jj++;*n += 1; } } /* FD in x direction finished */ if (j>0&&j< *ny-1) { /* FD w.r.t. x may be possible */ k0 = i * *ny + j - 1; /* backwards diff */ k1 = k0 + 2; /* forwards diff */ Gk0 = G[k0];Gk1 = G[k1]; if (Gk0 > outside && Gk1 > outside) { /* difference is possible */ xc += 2*dy2; if (Gk0<0) Gk0 = -Gk0; *x = -dy2;*ii = *ip;*jj = Gk0; x++;ii++;jj++;*n += 1; if (Gk1<0) Gk1 = -Gk1; *x = -dy2;*ii = *ip;*jj = Gk1; x++;ii++;jj++;*n += 1; } if (xc > thresh) { /* there is a difference for this cell */ *x = xc;*ii = *jj = *ip; x++;ii++;jj++;*n += 1; } } } /* interior branch end*/ } /* main loop end */ } /* end of pde_coeffs */ void gridder(double *z,double *x,double *y,int *n,double *g, int *G,int *nx, int *ny,double *x0, double *y0,double *dx,double *dy,double NA_code) { /* Takes solution g indexed by ny by nx matrix G. lower left cell of G is centred at x0, y0 and cell sizes are dx by dy. Interpolates solution to n locations in x, y, returning NA code for out of area. Does not do strict boundary testing here, since this routine is often called several times with same geometry. */ int i,ix,iy,ok,Gthresh,Gk,k,ok00,ok01,ok10,ok11; double xx,yy,xx0,yy0,dmax,xa,ya,g00=0.0,g01=0.0,g10=0.0,g11=0.0,b0,b1,b2,b3,dist,d1; dmax = (*dx * *dx + *dy * *dy)*2; xx0 = *x0;yy0 = *y0; Gthresh = - *nx * *ny; /* G below with implies out of area */ for (i=0;i < *n;i++) { /* loop through x,y locations */ xx = x[i];yy = y[i]; ix = (int) floor((xx - xx0) / *dx); iy = (int) floor((yy - yy0) / *dy); k = ix * *ny + iy; ok = 0; /* node 00... */ if (ix<0||ix>=*nx||iy<0||iy>=*ny) ok00 = 0; else { Gk=G[k]; if (Gk < Gthresh) ok00 = 0; else { ok00 = 1; ok++; if (Gk < 0) Gk = -Gk; g00 = g[Gk]; } } /* end of node 00 */ iy++;k++; /* node 01 */ if (ix<0||ix>=*nx||iy<0||iy>=*ny) ok01 = 0; else { Gk=G[k]; if (Gk < Gthresh) ok01 = 0; else { ok01 = 1; ok++; if (Gk < 0) Gk = -Gk; g01 = g[Gk]; } } /* end of node 01 */ ix++; k += *ny; /* node 11 */ if (ix<0||ix>=*nx||iy<0||iy>=*ny) ok11 = 0; else { Gk=G[k]; if (Gk < Gthresh) ok11 = 0; else { ok11 = 1; ok++; if (Gk < 0) Gk = -Gk; g11 = g[Gk]; } } /* end of node 11 */ iy--;k--; /* node 10 */ if (ix<0||ix>=*nx||iy<0||iy>=*ny) ok10 = 0; else { Gk=G[k]; if (Gk < Gthresh) ok10 = 0; else { ok10 = 1; ok++; if (Gk < 0) Gk = -Gk; g10 = g[Gk]; } } /* end of node 10 */ ix--; if (ok==4) { /* all nodes are ok, full bilinear */ b0 = g00; b1 = (g10-g00) / *dx; b2 = (g01-g00) / *dy; b3 = (g11-g10-g01+g00)/( *dx * *dy); xx = xx - xx0 - ix * *dx; yy = yy - yy0 - iy * *dy; /* evaluate interpolating polynomial */ z[i] = b0 + b1 * xx + b2 * yy + b3 * xx * yy; } else if (!ok) { /* no good neighbours - NA */ z[i] = NA_code; } else { /* resort to nearest neighbour */ xa = xx - xx0 - ix * *dx; ya = yy - yy0 - iy * *dy; dist = dmax; if (ok00) { dist = xa*xa + ya*ya; z[i] = g00; } if (ok01) { ya = *dy - ya; d1 = xa*xa + ya*ya; if (d1 < dist) { dist=d1; z[i] = g01; } } if (ok11) { xa = *dx - xa; d1 = xa*xa + ya*ya; if (d1 < dist) { dist=d1; z[i] = g11; } } if (ok10) { ya = *dy - ya; d1 = xa*xa + ya*ya; if (d1 < dist) { z[i] = g10; } } } /* end of nearest neighbour */ } } /* end of gridder */ mgcv/src/mgcv.c0000744000177400001440000004564413046054035013305 0ustar murdochusers/* Source code for mgcv.dll/.so multiple smoothing parameter estimation code, suitable for interfacing to R Copyright (C) 2000-2012 Simon N. Wood simon.wood@r-project.org 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. (www.gnu.org/copyleft/gpl.html) You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include #include #include #include #include #include "tprs.h" #include "mgcv.h" #include "matrix.h" #include "qp.h" #include "general.h" #include #include #define round(a) ((a)-floor(a) <0.5 ? (int)floor(a):(int) floor(a)+1) /* The following are some rather ancient routines used to set up an example additive model using regression (cubic) splines, via RGAMsetup(). */ void RUnpackSarray(int m,matrix *S,double *RS) /* unpacks the R array RS into an array of matrices initialized to the correct dimensions let kk = sum_{i=0}^k S[i].r*S[i].c Then the kth matrix starts at element kk of RS and stops at element k(k+1) ... let this extracted array be M. S[k].M[i][j]=M[i+S[k].r*j] - in this way we ensure that M can be extracted straight to a matrix in R with A<-matrix(M,S[k].r,S[k].c) */ { int start,i,j,k; start=0; for (k=0;k=b ensuring monotonic change of the cubic spline interpolating (x_i,y_i) where h_i=x_{i+1}-x_i control indicates type of constraints: up=control/4 - 0 for decrease, 1 for increase lo=(control-up*4)/2 - 1 for lower bound, 0 no lower bound hi=(control-up*4-lo*2) - 1 for upper bound, 0 no upper bound control = 4*up+2*lo+hi */ { long i,j,n; int up,lo,hi; double m; matrix h,D; h=initmat(x->r-1,1L); n=h.r; for (i=0;iV[i+1]-x->V[i]; D=getD(h,0); up=control/4;control=control%4; lo=control/2;control=control%2; hi=control; if (up) m= -1.0; else m=1.0; (*A)=initmat(4*n+hi+lo,n+1); for (i=0;iM[i][j]=(D.M[i][j]+3.0/h.V[i])*m; /**not certain of d.M update**/ A->M[i+n][j]=(D.M[i+1][j]+3.0/h.V[i])*m; A->M[i+2*n][j]=m; A->M[i+3*n][j]= -D.M[i][j]*m; } else if (j==(i+1)) { A->M[i][j]=(D.M[i][j]-3.0/h.V[i])*m; A->M[i+n][j]=(D.M[i+1][j]-3.0/h.V[i])*m; A->M[i+2*n][j]= -m; A->M[i+3*n][j]= -D.M[i][j]*m; } else { A->M[i][j]=D.M[i][j]*m; A->M[i+n][j]=D.M[i+1][j]*m; A->M[i+2*n][j]=0.0; A->M[i+3*n][j]= -D.M[i][j]*m; } } } *b = initmat(A->r,1L); if (lo) { for (j=0;jM[4*n][j]=0.0; if (up) A->M[4*n][0]=1.0; else A->M[4*n][n]=1.0; b->V[4*n]=lower; } if (hi) { for (j=0;jM[4*n][j]=0.0; if (up) A->M[4*n+lo][n]=-1.0; else A->M[4*n+lo][0]=-1.0; b->V[4*n+lo]=upper; } freemat(D); freemat(h); } void getFS(double *x,int n,double *S,double *F) { /* x contains ascending knot sequence for a cubic regression spline Routine finds wigglness penalty S and F such that F' maps function values at knots to second derivatives. See Wood 2006 section 4.1.2. F and S are n by n. F is F' in 4.1.2 notation. */ double *D,*ldB,*sdB,*h,*Di,*Di1,*Di2,*Fp,*Sp,a,b,c; int i,j,n1,n2; /* create knot spacing vector h */ h = (double *)CALLOC((size_t)(n-1),sizeof(double)); for (i=1;i3) { a = -1/h[0] - 1/h[1];b = 1/h[1]; /* row 1 */ for (Sp=S+1,Di1=D+1,Di=D,i=0;ikmax) { extrapolate=1; } else if (i>0 && fabs(xlast-xi) < 2*h) { /* use simple direct search */ while (xi <= xk[j] && j > 0) j--; while (xi > xk[j+1] && j < *nk-2) j++; /* next line should not be needed, except under dodgy use of fpu registers during optimization... */ if (j<0) j=0; if (j > *nk-2) j = *nk - 2; /* now xk[j] <= x[i] <= xk[j+1] */ } else { /* bisection search required */ j=0;jup=*nk-1; while (jup-j>1) { jmid = (jup+j) >> 1; /* a midpoint */ if (xi > xk[jmid]) j = jmid; else jup = jmid; } /* now xk[j] <= x[i] <= xk[j+1] */ } /* end of bisection */ /* knot interval containing x[i] now known. Compute spline basis */ if (extrapolate) { /* x[i] is outside knot range */ if (xikmax */ j = *nk-1; h = kmax - xk[j-1]; xik = xi - kmax; cjm= xik*h/6; cjp = xik*h/3; Xp = X + i; /* ith row of X */ for (Fp1 = F+ j * *nk,Fp = Fp1 - *nk,k=0;k < *nk;k++,Xp += *n,Fp++) *Xp = cjm * *Fp + cjp * *Fp1 ; X[i + *n * (*nk-2)] += - xik/h; X[i + *n * (*nk-1)] += 1+ xik/h; } } else { /* routine evaluation */ xj = xk[j];xj1=xk[j+1]; h = xj1-xj; /* interval width */ ajm = (xj1 - xi);ajp = (xi-xj); cjm = (ajm*(ajm*ajm/h - h))/6; cjp = (ajp*(ajp*ajp/h - h))/6; ajm /= h;ajp /= h; Xp = X + i; /* ith row of X */ for (Fp = F+ j * *nk, Fp1 = F+(j+1)* *nk,k=0;k < *nk;k++,Xp += *n,Fp++,Fp1++) *Xp = cjm * *Fp + cjp * *Fp1; Xp = X + i + j * *n; *Xp += ajm; Xp += *n; *Xp += ajp; } /* basis computation complete */ xlast=xi; } } /* end crspl */ void MinimumSeparation(double *x,int *n, int *d,double *t,int *m,double *dist) { /* For each of n ppoints point x[i,] calculates the minimum Euclidian distance to a point in m by d matrix t. These distances are stored in dist. */ int one=1,*ni; kdtree_type kd; kd_tree(t,m,d,&kd); /* build kd tree for target points */ ni = (int *)CALLOC((size_t)*n,sizeof(int)); k_newn_work(x,kd,t,dist,ni,n,m,d,&one); // for (i=0;i<*n;i++) { // k = closest(&kd,t,x + i * *d,*m,&j,-1); /* index of nearest neighbour of x[i,] */ // dist[i] = xidist(x + i * *d,t,k,*d, *m); /* distance to this nearest neighbour */ //} FREE(ni); free_kdtree(kd); } void MinimumSeparation_old(double *gx,double *gy,int *gn,double *dx,double *dy, int *dn,double *dist) /* For each point gx[i],gy[i] calculates the minimum Euclidian distance to a point in dx[], dy[]. These distances are stored in dist. Aweful routine: O(gn * dn) cost!! */ { double sep,xx,yy,*dum,*xdum,*ydum; int n,m; n = *gn;m = *dn; for (dum=dist;dum < dist + n; dum++,gx++,gy++) { xx= *gx - *dx;yy = *gy - *dy;*dum = xx*xx + yy*yy; /* first separation */ for (xdum=dx+1,ydum=dy+1;xdum < dx + m;xdum++,ydum++) { xx= *gx - *xdum;yy = *gy - *ydum;sep = xx*xx + yy*yy; /* subsequent separations */ if (sep < *dum) *dum = sep; } *dum = sqrt(*dum); } } void RuniqueCombs(double *X,int *ind,int *r, int *c) /* X is a matrix. This routine finds its unique rows and strips out the duplicates. This is useful for finding out the number of unique covariate combinations present in a set of data. */ { matrix B,Xd; int i,*ind1; B=Rmatrix(X,(long)(*r),(long)(*c)); Xd=initmat(B.r,B.c+1); Xd.c--;mcopy(&B,&Xd);freemat(B);Xd.c++; for (i=0;i= b & Af p = "constant" where B = \sum_{i=1}^m \theta_i S_i and W=diag(w) - in fact S_i are not stored whole - rather the smallest non-zero sub-matrix of each S_i is stored in a densely packed form in S[]: see routines RpackSarray() and RUnpackSarray() for details of the sub-matrix packing. off[i],off[i] is the location within the full S_i to insert the sub-matrix actually stored which is of dimension dim[i] by dim[i]. W = diag(w) on exit p contains the best fit parameter vector. */ { matrix y,X,p,w,Ain,Af,b,H,*S; int n,np,i,*active; np=nar[1];n=nar[0]; /* unpack from R into matrices */ X=Rmatrix(Xd,(long)n,(long)np); p=Rmatrix(pd,(long)np,1L); y=Rmatrix(yd,(long)n,1L); w=Rmatrix(wd,(long)n,1L); if (nar[2]>0) Ain=Rmatrix(Aind,(long)nar[2],(long)np); else Ain.r=0L; if (nar[3]>0) Af=Rmatrix(Afd,(long)nar[3],(long)np); else Af.r=0L; if (nar[2]>0) b=Rmatrix(bd,(long)nar[2],1L);else b.r=0L; if (*m) S=(matrix *)CALLOC((size_t) *m,sizeof(matrix)); else S=&H; /* avoid spurious compiler warning */ for (i=0;i< *m;i++) S[i]=initmat((long)dim[i],(long)dim[i]); RUnpackSarray(*m,S,Sd); if (nar[4]) H=initmat(y.r,y.r); else H.r=H.c=0L; active=(int *)CALLOC((size_t)(p.r+1),sizeof(int)); /* array for active constraints at best fit active[0] will be number of them */ /* call routine that actually does the work */ PCLS(&X,&p,&y,&w,&Ain,&b,&Af,&H,S,off,theta,*m,active); /* copy results back into R arrays */ for (i=0;i #include #include #include #include "mgcv.h" #ifdef OPENMP_ON #include #endif #define ANSI /*#define DEBUG*/ double trBtAB(double *A,double *B,int *n,int*m) /* form tr(B'AB) where A is n by n and B is n by m, m < n, basic point is that this is sum_ijk A_ik B_ij B_kj */ { double tr=0.0,x,*p,*p1,*p2; int j,k; for (j=0;j<*m;j++) for (k=0;k<*n;k++) { p = A + *n * k;p2 = p + *n; p1 = B + *n * j; x = B[k + j * *n]; for (;p0) { for (pa=A,pb=B,p1=pa + *r,pd=d;pa1) for (m=0;m < *M;m++) { /* Hessian */ bt=0;ct=0;mgcv_mmult(work1,E,b1+m * *q,&bt,&ct,Enrow,&one,q); bt=1;ct=0;mgcv_mmult(work,E,work1,&bt,&ct,q,&one,Enrow); /* S dbeta/drho_m */ for (k=m;k < *M;k++) { km=k * *M + m;mk=m * *M + k; /* second derivatives needed */ /* d2beta'/drho_k drho_m S beta */ for (xx=0.0,p0=Sb,p1=Sb + *q;p0j) j = rSncol[i]; j += *M0; /* work space needed */ work = (double *)CALLOC((size_t)j,sizeof(double)); Sb = (double *)CALLOC((size_t)*q,sizeof(double)); bt=0;ct=0;mgcv_mmult(work,E,beta,&bt,&ct,Enrow,&one,q); bt=1;ct=0;mgcv_mmult(Sb,E,work,&bt,&ct,q,&one,Enrow); /* S \hat \beta */ for (*bSb=0.0,i=0;i<*q;i++) *bSb += beta[i] * Sb[i]; /* \hat \beta' S \hat \beta */ if (*deriv <=0) {FREE(work);FREE(Sb);return;} work1 = (double *)CALLOC((size_t)j,sizeof(double)); Skb = (double *)CALLOC((size_t)*M * *q,sizeof(double)); for (p1=Skb,rSoff=0,i=0;i<*M;i++) { /* first part of first derivatives */ /* form S_k \beta * sp[k]... */ bt=1;ct=0;mgcv_mmult(work,rS + rSoff ,beta,&bt,&ct,rSncol+i,&one,q); for (j=0;j1) for (m=0;m < Mtot;m++) { /* Hessian */ bt=0;ct=0;mgcv_mmult(work1,E,b1 + m * *q,&bt,&ct,Enrow,&one,q); bt=1;ct=0;mgcv_mmult(work,E,work1,&bt,&ct,q,&one,Enrow); /* S dbeta/drho_m */ for (k=m;k < Mtot;k++) { km= k * Mtot + m ; mk= m * Mtot + k ; /* second derivatives needed */ /* d2beta'/drho_k drho_m S beta */ for (xx=0.0,p0=Sb,p1=Sb + *q;p0= *M0) { for (xx=0.0,p0=Skb + (k- *M0) * *q,p1=p0 + *q,p2= b1+ m * *q;p0= *M0) { for (xx=0.0,p0=Skb + (m - *M0) * *q,p1=p0 + *q,p2= b1 + k * *q;p0 pivot[i] row of unpivoted */ for (pd=dum,pd1=dum+*r,p1=p;pd ith row of pivoted */ for (pd=dum,pd1=dum+*r,p1=p;pd pivot[i] row of unpivoted */ for (i=0;i<*r;i++) p[i] = tau[i]; /* store unpivoted column in Xi */ } FREE(Qt); } /* end if (*get_inv) */ FREE(pivot);FREE(tau); return(ldet); } /* end qr_ldet_inv */ void get_detS2(double *sp,double *sqrtS, int *rSncol, int *q,int *M, int * deriv, double *det, double *det1, double *det2, double *d_tol, double *r_tol,int *fixed_penalty) /* Routine to evaluate log|S| and its derivatives wrt log(sp), in a stable manner, using an orthogonal transformation strategy based on QR decomposition. Inputs are: `sp' the array of smoothing parameters. `sqrtS' the `M' square root penalty matrices. The ith is `q' by `rSncol[i]'. They are packed one after the other. `deriv' is the order of derivatives required. 0,1 or 2. `d_tol' is the tolerance to use for grouping dominant terms. `r_tol' (<< d_tol) is the tolerance used for rank determination. `fixed_penalty' non-zero indicates that there is a fixed component of total penalty matrix S, the square root of which is in the final q * rSncol[M+1] elements of sqrtS. Outputs are: `det' the log determinant. `det1' M-array of derivatives of log det wrt log sp. `det2' M by M Hessian of log det wrt log sp. */ { double *R,*work,*tau,*rS1,*rS2, *S,*Si,*Sb,*B,*Sg,*p,*p1,*p2,*p3,*p4,*frob,max_frob,x,*spf,Rcond; int *pivot,iter,i,j,k,bt,ct,rSoff,K,Q,Qr,*gamma,*gamma1,*alpha,r,max_col,Mf,tot_col=0,left,tp; if (*fixed_penalty) { Mf = *M + 1; /* total number of components, including fixed one */ spf = (double *)CALLOC((size_t)Mf,sizeof(double)); for (i=0;i<*M;i++) spf[i]=sp[i]; spf[*M]=1.0; /* includes sp for fixed term */ } else {spf=sp;Mf = *M;} /* total number of components, including fixed one */ /* Create working copies of sqrtS, which can be modified: rS1 is repeatedly orthogonally transformed, while rS2 is row pivoted. */ if (*deriv) { /* only need to modify if derivatives needed */ for (j=i=0;imax_col) max_col=rSncol[i]; p = Si = (double *)CALLOC((size_t)*q * max_col * Mf,sizeof(double)); for (rSoff=i=0;imax_frob) max_frob=frob[i] * spf[i]; } /* Find sets alpha and gamma' */ for (i=0;i max_frob * *d_tol) { alpha[i] = 1;gamma1[i] = 0; /* deal with it now */ } else { alpha[i] = 0;gamma1[i] = 1; /* put it off */ } } else { /* wasn't in gamma, so not in alpha or gamma1 */ alpha[i] = gamma1[i] = 0; } } /* Form the scaled sum of the Si in alpha and get its rank by pivoted QR and condition estimation... */ for (p=Sb,p1=p + *q * Q;p 1) { r--;R_cond(Sb,&Q,&r,work,&Rcond);} Qr = Q-r; /* ... r is the rank of Sb, or any other positively weighted sum over alpha */ /* printf("\n iter = %d, rank = %d, Q = %d",iter,r,Q); printf("\n gamma = ");for (i=0;imax_col) max_col=rSncol[i]; } /* Initialize the sub-dominant set gamma and the counters */ K = 0; /* counter for coefs already deal with */ Q = *q; /* How many coefs left to deal with */ frob = (double *)CALLOC((size_t)Mf,sizeof(double)); gamma = (int *)CALLOC((size_t)Mf,sizeof(int)); /* terms remaining to deal with */ gamma1 = (int *)CALLOC((size_t)Mf,sizeof(int)); /* new gamma */ alpha = (int *)CALLOC((size_t)Mf,sizeof(int)); /* dominant terms */ for (i=0;imax_frob) max_frob=frob[i] * spf[i]; } /* Find sets alpha and gamma' */ n_gamma1=0; for (i=0;i max_frob * *d_tol) { alpha[i] = 1;gamma1[i] = 0; /* deal with it now */ } else { alpha[i] = 0;gamma1[i] = 1; n_gamma1++; /* put it off */ } } else { /* wasn't in gamma, so not in alpha or gamma1 */ alpha[i] = gamma1[i] = 0; } } /* Form the scaled sum of the Si in alpha and eigen-decompose it to get its rank */ if (n_gamma1) { /* stuff left in gamma1, so have to work out rank of contents of alpha */ for (p=Sb,p1=p+Q*Q;pev[Q-1] * *r_tol)) r++; } else { /* nothing left in gamma1, so... */ r=Q; } /* ... r is the rank of Sb, or any other positively weighted sum over alpha */ /* If Q==r then terminate (form S first if it's the first iteration) */ if (Q==r) { if (iter==1 ) { /* form S and Qf*/ for (p=Si,i=0;i0) { /* deal with upper right component B */ /* first copy out K by Q matrix B */ for (j=0;j0) { rSoff[0] = 0;for (m=0;m < *M-1;m++) rSoff[m+1] = rSoff[m] + rSncol[m]; } tid = 0; #ifdef OPENMP_ON #pragma omp parallel private(m,bt,ct,tid) num_threads(nthreads) #endif { /* parallel section start */ #ifdef OPENMP_ON #pragma omp for #endif for (m=0;m < *M;m++) { /* loop through penalty matrices */ #ifdef OPENMP_ON tid = omp_get_thread_num(); /* thread running this bit */ #endif bt=1;ct=0;mgcv_mmult(PtrSm + tid * *r * max_col,P,rS+rSoff[m] * *q,&bt,&ct,r,rSncol+m,q); /*rSoff += rSncol[m];*/ trPtSP[m] = sp[m] * diagABt(work + *n * tid,PtrSm + tid * *r * max_col, PtrSm + tid * *r * max_col,r,rSncol+m); /* sp[m]*tr(P'S_mP) */ det1[m + *M0] += trPtSP[m]; /* completed first derivative */ if (deriv2) { /* get P'S_mP */ bt=0;ct=1;mgcv_mmult(PtSP+ m * *r * *r,PtrSm + tid * *r * max_col, PtrSm+ tid * *r * max_col ,&bt,&ct,r,r,rSncol+m); } } } /* end of parallel section */ FREE(rSoff); /* Now accumulate the second derivatives */ // #ifdef OPENMP_ON //#pragma omp parallel private(m,k,km,mk,xx,tid,pdKK,p1,pTkm) num_threads(nthreads) //#endif if (deriv2) { /* start of parallel section */ //if (deriv2) #ifdef OPENMP_ON #pragma omp parallel for private(m,k,km,mk,xx,tid,pdKK,p1,pTkm) num_threads(nthreads) #endif for (m=0;m < Mtot;m++) { #ifdef OPENMP_ON tid = omp_get_thread_num(); /* thread running this bit */ #endif if (m==0) pTkm = Tkm; else pTkm = Tkm + (m * Mtot - (m*(m-1))/2) * *n; for (k=m;k < Mtot;k++) { km=k * Mtot + m;mk=m * Mtot + k; /* tr(Tkm KK') */ /*for (xx=0.0,pdKK=diagKKt,p1=pdKK + *n;pdKK= *M0 && k==m) det2[km] += trPtSP[m - *M0]; /* -sp[m]*tr(K'T_kKP'S_mP) */ if (m >= *M0) det2[km] -= sp[m - *M0]*diagABt(work + *n * tid,KtTK + k * *r * *r,PtSP + (m - *M0) * *r * *r,r,r); /* -sp[k]*tr(K'T_mKP'S_kP) */ if (k >= *M0) det2[km] -= sp[k - *M0]*diagABt(work + *n * tid,KtTK + m * *r * *r,PtSP + (k - *M0) * *r * *r,r,r); /* -sp[m]*sp[k]*tr(P'S_kPP'S_mP) */ if (k >= *M0 && m >= *M0) det2[km] -= sp[m - *M0]*sp[k - *M0]* diagABt(work + *n * tid,PtSP + (k - *M0) * *r * *r,PtSP + (m - *M0) * *r * *r,r,r); det2[mk] = det2[km]; } } } /* end of parallel section */ /* free up some memory */ if (deriv2) {FREE(PtSP);FREE(KtTK);} FREE(diagKKt);FREE(work); FREE(PtrSm);FREE(trPtSP); } /* end get_ddetXWXpS */ void get_trA2(double *trA,double *trA1,double *trA2,double *P,double *K,double *sp, double *rS,int *rSncol,double *Tk,double *Tkm,double *w,int *n,int *q, int *r,int *M,int *deriv,int *nt) /* obtains trA and its first two derivatives wrt the log smoothing parameters * P is q by r * K is n by r * U1 is q by r * this routine assumes that sp contains smoothing parameters, rather than log smoothing parameters. * If deriv is 0 then only tr(A) is obtained here. * This version uses only K and P, and is for the case where expressions involve weights which are reciprocal variances, not the squares of weights which are reciprocal standard deviations. * Note that tr(A) = tr(KK') and it is tempting to view diag(K'K) as giving the edfs of the parameters, but this seems to be wrong. It gives the edfs for R \beta, where R is (pseudo) inverse of P. * uses nt threads via openMP. Assumes thread number already set on entry and nt already reset to 1 if no openMP support. */ { double *diagKKt,*diagKKtKKt,xx,*KtTK,*KtTKKtK,*KKtK,*KtK,*work,*pTk,*pTm,*pdKKt,*pdKKtKKt,*p0,*p1,*p2,*p3,*pd, *PtrSm,*PtSP,*KPtrSm,*diagKPtSPKt,*diagKPtSPKtKKt,*PtSPKtK, *KtKPtrSm, *KKtKPtrSm,*Ip,*IpK/*,lowK,hiK*/; int i,m,k,bt,ct,j,one=1,km,mk,*rSoff,deriv2,neg_w=0,tid=0; #ifdef OMP_REPORT Rprintf("get_trA2 (d=%d)...",*deriv); #endif if (*deriv==2) deriv2=1; else deriv2=0; /* Get the sign array for negative w_i */ Ip = (double *)CALLOC((size_t)*n,sizeof(double)); for (p0=w,p1=p0+ *n,p2=Ip;p0hiK) hiK= *p1; else if (*p1=0;k--) { for (xx=0.0,j=k+1;j <=i;j++) xx += R[k + j * *r] * rc[j]; rc[k]=(eye-xx)/R[k + k * *r]; eye=0; } for (k=i+1;k<*c;k++) rc[k]=0.0; rc += *ri; } } void pearson2(double *P, double *P1, double *P2, double *y,double *mu,double *V, double *V1,double *V2,double *g1,double *g2, double *p_weights,double *eta1, double *eta2,int n,int M,int deriv, int deriv2) /* Alternative calculation of the derivatives of the Pearson statistic, which avoids assuming that z and w are based on Fisher scoring */ { double resid,xx,*Pe1,*Pe2,*pp,*p1,*p0,*v2,*Pi1,*Pi2; int i,k,m,n_2dCols=0,one=1; if (deriv) { Pe1 = (double *)CALLOC((size_t)n,sizeof(double)); /* for dP/deta */ Pi1 = (double *)CALLOC((size_t) n * M,sizeof(double)); /* for dPi/drho */ if (deriv2) { n_2dCols = (M * (1 + M))/2; Pe2 = (double *)CALLOC((size_t)n,sizeof(double)); /* for d2P/deta2 */ v2 = (double *)CALLOC((size_t)n,sizeof(double)); Pi2 = (double *)CALLOC((size_t)n_2dCols*n,sizeof(double)); /* for d2P_i/drho */ } else {Pe2=v2=Pi2=NULL;} } else {Pi1 = Pe2 = v2 = Pe1 = Pi2 = NULL;} *P=0.0; for (i=0; i < n;i++) { resid = y[i]-mu[i]; xx = resid*p_weights[i]/V[i]; *P += xx*resid; if (deriv) { Pe1[i] = - xx* (2 + resid*V1[i])/g1[i]; if (deriv2) { Pe2[i] = - Pe1[i]*g2[i]/g1[i] + (2*p_weights[i]/V[i]+2*xx*V1[i] - Pe1[i]*V1[i]*g1[i] - xx*resid*(V2[i]-V1[i]*V1[i]))/(g1[i]*g1[i]); } } } /* derivs wrt eta completed */ if (deriv) { /* transform to derivs wrt rho */ rc_prod(Pi1,Pe1,eta1,&M,&n); /* Pi1 = dP_i/drho_k done */ if (deriv2) { rc_prod(Pi2,Pe1,eta2,&n_2dCols,&n); for (pp=Pi2,m=0;m < M;m++) for (k=m;k < M;k++) { rc_prod(Pe1,eta1 + n * m,eta1 + n * k,&one,&n); rc_prod(v2,Pe2,Pe1,&one,&n); p1=v2 + n; for (p0=v2;p0=0;j--) { /* back through columns */ for (i=r-1;i>drop[n_drop-1];i--,X--,Xs--) *X = *Xs; *X = 0.0;X--; for (k=n_drop-1;k>0;k--) { for (i=drop[k]-1;i>drop[k-1];i--,X--,Xs--) *X = *Xs; *X = 0.0;X--; } for (i=drop[0]-1;i>=0;i--,X--,Xs--) *X = *Xs; } } /* end undrop rows */ double MLpenalty1(double *det1,double *det2,double *Tk,double *Tkm,double *nulli, double *X, double *R,double *Q, int *nind,double *sp,double *rS,int *rSncol,int *q,int *n, int *Ms,int *M,int *M0,int *neg_w,double *rank_tol,int *deriv, int *nthreads,int *type) { /* Routine to obtain the version of log|X'WX+S| that applies to ML, rather than REML. This version assumes that we are working in an already truncated range-null separated space. * nulli is an array indicating whether a parameter (column) relates to the null space (+ve) or range space (-ve) of the total penalty matrix. Because of pivoting they can be in any order. * Q, R are the QR factors of diag(abs(W))X augmenented by the square root of S * nind is the array indexing the locations of the `neg_w' -ve elements of W. * q is the number of model coefficients * Ms is the penalty null space dimension. * M is number of smoothing parameters, and M0 the number of theta parameters. * n is the number of rows in Q. Basic task of the routine is to project Hessian of the penalized log likelihood into the range space of the penalty, in order to obtain the correction term that applies for ML. NOTE: rS is over-written by this. */ double *RU1,*tau,*work,*Ri,*Qb=NULL,*K,*P,*IQ,*IQQ,*Vt,*XU1=NULL, *d,*p0,*p1,*p2,*p3,ldetXWXS,ldetI2D=0.0; int ScS,bt,ct,qM,*pivot,i,j,k,left,tp,n_drop=0,*drop,FALSE=0; drop = (int *)CALLOC((size_t)*Ms,sizeof(int)); for (i=0;i < *q;i++) if (nulli[i]>0.0) { drop[n_drop] = i;n_drop++; } for (ScS=0.0,i=0;i<*M;i++) ScS += rSncol[i]; /* total columns of rS */ qM = *q - n_drop; RU1 = (double *)CALLOC((size_t) *q * *q ,sizeof(double)); for (p1=RU1,p2=R,p3=R+ *q * *q;p2 < p3;p1++,p2++) *p1 = *p2; drop_cols(RU1,*q,*q,drop,n_drop); /* drop the null space columns from R */ /* A pivoted QR decomposition of RU1 is needed next */ tau=(double *)CALLOC((size_t)qM,sizeof(double)); /* part of reflector storage */ pivot=(int *)CALLOC((size_t)qM,sizeof(int)); mgcv_qr(RU1,q,&qM,pivot,tau); /* RU1 and tau now contain the QR decomposition information */ /* pivot[i] gives the unpivoted position of the ith pivoted parameter.*/ /* Ri needed */ Ri = (double *)CALLOC((size_t) qM * qM,sizeof(double)); Rinv(Ri,RU1,&qM,q,&qM); /* getting R^{-1} */ if (*type==0||*neg_w) { /* new Q factor needed explicitly */ Qb = (double *)CALLOC((size_t) *q * qM,sizeof(double)); for (i=0;i< qM;i++) Qb[i * *q + i] = 1.0; left=1;tp=0;mgcv_qrqy(Qb,RU1,tau,q,&qM,&qM,&left,&tp); /* Q from the QR decomposition */ } else { /* need X with null space cols dropped */ XU1 = (double *)CALLOC((size_t) *n * *q,sizeof(double)); for (p1=XU1,p2=X,p3=X + *n * *q;p2 < p3;p1++,p2++) *p1 = *p2; drop_cols(XU1,*n,*q,drop,n_drop); /* drop the null space columns from X */ } FREE(tau); K = (double *)CALLOC((size_t) *n * qM,sizeof(double)); P = (double *)CALLOC((size_t) qM * qM,sizeof(double)); if (*neg_w) { /* need to deal with -ve weight correction */ if (*neg_w < *q+1) k = *q+1; else k = *neg_w; IQ = (double *)CALLOC((size_t) k * *q,sizeof(double)); for (i=0;i< *neg_w;i++) { /* Copy the rows of Q corresponding to -ve w_i into IQ */ p0 = IQ + i;p1 = Q + nind[i]; for (j=0;j<*q;j++,p0+=k,p1+= *n) *p0 = *p1; } /* Note that IQ may be zero padded, for convenience */ IQQ = (double *)CALLOC((size_t) k * qM,sizeof(double)); bt=0;ct=0;mgcv_mmult(IQQ,IQ,Qb,&bt,&ct,&k,&qM,q); /* I^-Q_1 \bar Q is k by rank */ FREE(IQ); /* Get the SVD of IQQ */ Vt = (double *)CALLOC((size_t) qM * qM,sizeof(double)); d = (double *)CALLOC((size_t) qM,sizeof(double)); mgcv_svd_full(IQQ,Vt,d,&k,&qM); /* SVD of IQ */ FREE(IQQ); for (i=0;i 1) { (*rank)--;R_cond(R,&nr,rank,work,&Rcond);} /* Now have to drop the unidentifiable columns from R1, E and the corresponding rows from rS The columns to drop are indexed by the elements of pivot1 from pivot1[rank] onwards. Before returning, zeros will need to be inserted in the parameter vector at these locations. */ for (i=0;i<*q - *Mp;i++) nulli[i] = -1.0; /* parameter in penalty range space */ for (i= *q - *Mp;i < *q;i++) nulli[i] = 1.0; /* parameter in penalty null space */ *n_drop = *q - *rank; if (*n_drop) { for (i=0;i < *n_drop;i++) drop[i] = pivot1[*rank+i]; qsort(drop,*n_drop,sizeof(int),icompare); /* key assumption of the drop/undrop routines is that `drop' is ascending */ /* drop columns indexed in `drop'... */ drop_cols(R1,*q,*q,drop,*n_drop); /* R1 now q by rank */ drop_cols(E,*Enrow,*q,drop,*n_drop); /* E now q by rank */ drop_cols(X,*n,*q,drop,*n_drop); /* X now n by rank */ drop_rows(rS,*q,ScS,drop,*n_drop); /* rS now rank by ScS */ drop_rows(nulli,*q,1,drop,*n_drop); /* keeps track of null space params */ } /* At this stage the parameter space has been purged of terms that are theoretically unidentifiable, given WX and the penalties */ /* Now augment R1 with the real square root penalty (not the nicely scaled version), result in R... */ for (j=0;j < *rank;j++) { for (i=0;i< *q;i++) R[i + nr * j] = R1[i + *q * j]; for (i=0;i< *Enrow;i++) R[i + *q + nr * j] = E[i + *Enrow * j]; } mgcv_qr(R,&nr,rank,pivot1,tau1); /* The final QR decomposition */ i=1;pivoter(nulli,rank,&i,pivot1,&FALSE,&FALSE); /* pivoting the rows of nulli */ if (deriv2) { /* get first bit of X'WX (hessian of the deviance)*/ pivoter(R1,q,rank,pivot1,&TRUE,&FALSE); /* pivot the columns of R1 */ getXtX(dev_hess,R1,q,rank); } /* Form Q1 = Qf Qs[1:q,] where Qf and Qs are orthogonal factors from first and final QR decomps respectively ... */ if (neg_w || *type==0) { /* Q1 needed if neg_w correction needed, and anyway for type==0 */ Q = (double *)CALLOC((size_t) nr * *rank,sizeof(double)); for (i=0;i < *rank;i++) Q[i * nr + i] = 1.0; left=1;tp=0;mgcv_qrqy(Q,R,tau1,&nr,rank,rank,&left,&tp); /* Q from the second QR decomposition */ /* Q1 = Qb Q[1:q,] where Qb from first QR decomposition... */ for (i=0;i<*q;i++) for (j=0;j < *rank;j++) Q1[i + *q * j] = Q[i + nr * j]; tp=0;mgcv_pqrqy(Q1,WX,tau,n,q,rank,&tp,&nt1); /* so, at this stage WX = Q1 R, dimension n by rank */ } Ri = (double *)CALLOC((size_t) *rank * *rank,sizeof(double)); Rinv(Ri,R,rank,&nr,rank); /* getting R^{-1} */ ldetI2D = 0.0; /* REML determinant correction */ if (neg_w) { /* then the correction for the negative w_i has to be evaluated */ if (neg_w < *rank + 1) k = *rank + 1; else k = neg_w; IQ = (double *)CALLOC((size_t) k * *rank,sizeof(double)); for (i=0;i < neg_w;i++) { /* Copy the rows of Q corresponding to -ve w_i into IQ */ p0 = IQ + i;p1 = Q1 + nind[i]; for (j=0;j < *rank;j++,p0+=k,p1+= *n) *p0 = *p1; } /* Note that IQ may be zero padded, for convenience */ d = (double *)CALLOC((size_t) *rank,sizeof(double)); mgcv_svd_full(IQ,Vt,d,&k,rank); /* SVD of IQ */ FREE(IQ); if (deriv2) { /* correct the Hessian of the deviance */ /* put DV'R into P, temporarily */ p1=P; for (j=0;j < *rank;j++,p1 += *rank) { p0 = R + j * nr; /* start of column j of R */ for (p2=Vt,p3=p1,p4=p1 + *rank;p30) { for (*ldetXWXS=0.0,i=0;i < *rank;i++) *ldetXWXS += log(fabs(R[i + i * nr])); *ldetXWXS *= 2; *ldetXWXS += ldetI2D; /* correction for negative weights */ } /* Apply pivoting to the parameter space - this simply means reordering the cols of E and X and the rows of the rS_i, and then unscrambling the parameter vector at the end (along with any covariance matrix) pivot1[i] gives the unpivoted position of the ith pivoted parameter. */ pivoter(rS,rank,&ScS,pivot1,&FALSE,&FALSE); /* row pivot of rS */ pivoter(E,Enrow,rank,pivot1,&TRUE,&FALSE); /* column pivot of E */ pivoter(X,n,rank,pivot1,&TRUE,&FALSE); /* column pivot of X */ if (*type==1) { /* create K = XP... */ applyP(K,X,R,Vt,neg_w,nr,*rank,*n,1); } else { /* start PK'z --- the pivoted coefficients...*/ bt=1;ct=0;mgcv_mmult(work,K,zz,&bt,&ct,rank,&one,n); /* K'z */ mgcv_mmult(work + *q *2,Q1,zz,&bt,&ct,rank,&one,n); /* Q1'z */ } if (*type==1) { bt=1;ct=0;mgcv_mmult(work,K,z,&bt,&ct,rank,&one,n); /* K'Wz */ applyP(PKtz,work,R,Vt,neg_w,nr,*rank,1,0); } else { /* Create Wz (not sqrt(|W|)z)... */ for (i=0;i<*n;i++) zz[i] = raw[i] * raw[i] * z[i]; for (i=0;i *rank_tol * norm2) { //Rprintf("gdi2 instability detected norm1= %g norm2 = %g\n",norm1,norm2); applyPt(zz,work + *q,R,Vt,neg_w,nr,*rank,1,0); /* P'X'Wz */ applyP(PKtz,zz,R,Vt,neg_w,nr,*rank,1,0); } else applyP(PKtz,work,R,Vt,neg_w,nr,*rank,1,0); } FREE(WX);FREE(tau);FREE(Ri);FREE(R1); FREE(tau1); if (neg_w || *type==0) FREE(Q); FREE(pivot); if (*type==0) FREE(zz); } /* gdiPK */ void gdi2(double *X,double *E,double *Es,double *rS,double *U1, double *sp,double *theta,double *z,double *w,double *wz,double *wf, double *Dth,double *Det,double *Det2,double *Dth2,double *Det_th, double *Det2_th,double *Det3,double *Det_th2, double *Det4, double *Det3_th, double *Det2_th2, double *beta,double *b1,double *w1, double *D1,double *D2,double *P0,double *P1,double *P2, double *ldet, double *ldet1,double *ldet2,double *rV, double *rank_tol,int *rank_est, int *n,int *q, int *M,int *n_theta, int *Mp,int *Enrow,int *rSncol,int *deriv, int *fixed_penalty,int *nt,int *type,double *dVkk) /* Extended GAM derivative function, for independent data beyond exponential family. On entry *ldet < 0 indicates that ML ingredients should be computed, else REML type == 0 is the original computation involving (|w|)^{-1}dw/drho whereas type == 1 avoids the (|w|)^{-1} to avoid problems with zero weights (and/or badly scaled sqrt(|w|)z). Identifiability truncation is based on the "well scaled" penalty square root, Es, and is assuming that a stability enhancing reparameterization and stable E are being employed. This version deals properly with negative weights, which can occur with Newton based PIRLS. In consequence w's in this routine are proportional to reciprocal variances, not reciprocal standard deviations. The function is to be called at convergence of a P-IRLS scheme, estimating model coefficients by P-IRLS. All names ending in 1,2 or 3 are derivatives of some sort, with the integer indicating the order of differentiation. The arguments of this function point to the following: *i X is and n by q model matrix. On output this will contain K. *i E is a q by Enrow square root of the total penalty matrix, so E'E=S *i Es is the square root of a "well scaled" version of the total penalty, suitable for numerical determination of the theoretical rank of the problem. *i rS is a list of square roots of individual penalty matrices, packed in one array. The ith such matrix rSi, say, has dimension q by rSncol[i] and the ith penalty is [rSi][rSi]'. *i U1 is an (orthogonal) basis for the penalty range space (q by (q-Mp), where Mp is the null space dimension). *i sp is an M array of smoothing parameters (NOT log smoothing parameters) *i theta is the n_theta vector of extra parameters of the likelihood. *i z and w are pseudodata and iterative newton weights. *i wf are Fisher weights *i Dth, Dth2, Det, Det2, Det_th, Det2_th, Det3, Det_th2, Det4, Det3_th, Det2_th2 give derivs of deviance wrt eta (linear predictor) and theta (extra params) in obvious notation, where e.g Detj_thk is derivative of deviance j times wrt eta and k times wrt theta. absence of a j or k implies they are 1. *o beta - coefficients. *o b1 - first deriv of coefs w.r.t. sps (incl. theta) *o w1 - first deriv of weights w.r.t. sps (incl. theta) *o D1, D2 - first and second deriv of deviance w.r.t. sps (incl. theta) *o P0, P1, P2 - penalty b'Sb and its first and second derivs wrt sps. (incl theta) *o ldet, ldet1, ldet2, log|X'WX + S| & derivs wrt sp (incl theta) *o rV sqrt covariance matrix of coefs. *i rank_tol tol to use for rank estimation *o rank_est estiamted rank *i n , q, M, n_theta number of data, coefs, smoothing params and theta params. *i Mp penalty null space dimension *i Enrow rows of E. *i *rSncol array of number of cols in components of rS *i deriv order of deriv required (0, 1 or 2) *i fixed_penalty, non-zero indicates that S includes a fixed penalty component, the range space projected square root of which is in the final element of `UrS'. This information is used by get_detS2(). *i nt number of threads to use, if supported. *i type 0 for computation using |w|^{-1} scaling, 1 to avoif this. *o dVkk is M by M matrix containing curvature terms for objective w.r.t smoothing params (is zero when second deriv is zero, but otherwise is not second deriv). The method has 4 main parts: 1. The initial QR- decomposition and negative w correction SVD are performed, and various quantities which are independent of derivatives are created 2. IFT used to obtain derivatives of the coefficients wrt the log smoothing parameters. 3. Evaluation of the derivatives of the deviance wrt the log smoothing parameters (i.e. calculation of D1 and D2) The method involves first and second derivatives of a number of k-vectors wrt log smoothing parameters (\rho), where k is q or n. Consider such a vector, v. * v1 will contain dv/d\rho_0, dv/d\rho_1 etc. So, for example, dv_i/d\rho_j (indices starting at zero) is located in v1[q*j+i]. * v2 will contain d^2v/d\rho_0d\rho_0, d^2v/d\rho_1d\rho_0,... but rows will not be stored if they duplicate an existing row (e.g. d^2v/d\rho_0d\rho_1 would not be stored as it already exists and can be accessed by interchanging the sp indices). So to get d^2v_k/d\rho_id\rho_j: i) if i m || *nt < 1) *nt = m; /* no point in more threads than m */ omp_set_num_threads(*nt); /* set number of threads to use */ #else *nt = 1; #endif if (*ldet<0) ML=1; /* require ML not REML */ if (*deriv==2) deriv2=1; else deriv2=0; ScS=0;for (pi=rSncol;pi0) raw[i] = sqrt(w[i]); else { *type=1; } /* zero weights so we have to use type 1 method */ if (neg_w) { Vt = (double *)CALLOC((size_t) *q * *q,sizeof(double)); nind = (int *)CALLOC((size_t)neg_w,sizeof(int)); /* index the negative w_i */ k=0;for (i=0;i< *n;i++) if (w[i]<0) { nind[k]=i;k++;} } else { nind = (int *)NULL; Vt = (double *)NULL;} /* get R,nulli,dev_hess,P,K,Vt,PKtz (== beta),Q1, nind,pivot1,drop,rank,n_drop,ldetXWXS */ if (*type==1) z=wz; /* need to pass wz to gdiPK */ gdiPK(work,X,E,Es,rS,U1,z,raw, R,Rh,nulli,dev_hess,P,K,Vt,PKtz,Q1, nind,pivot1,drop, n,q,Mp,neg_w,nt,Enrow, &rank,&n_drop, deriv2,ScS,&TRUE, rank_tol,ldet,type); FREE(raw); /* now call ift2 to get derivatives of coefs w.r.t. smoothing/theta parameters */ ntot = *M + *n_theta; n_2dCols = (ntot * (1 + ntot))/2; if (*deriv) { //b1 = (double *)CALLOC((size_t) rank * ntot,sizeof(double)); eta1 = (double *)CALLOC((size_t) *n * ntot,sizeof(double)); if (deriv2) { b2 = (double *)CALLOC((size_t) rank * n_2dCols,sizeof(double)); eta2 = (double *)CALLOC((size_t) *n * n_2dCols,sizeof(double)); } ift2(R,Vt,X,rS,PKtz,sp,theta, Det_th,Det2_th,Det3,Det_th2, b1,b2,eta1,eta2, n,&rank,M,n_theta,rSncol,&deriv2,&neg_w,&nr); if (*M>0) { i=0;mgcv_mmult(work,Rh,b1,&i,&i,&rank,M,&rank); /* Rh db/drho */ /* Now obtain dVkk = db'/drho Rh' Rh db/drho ... */ getXtX(dVkk,work,&rank,M); } /* compute the grad of the deviance... */ for (p4 = Dth,p0=D1,p1=eta1,i=0;i < *n_theta;i++,p0++) { for (*p0=0.0,p2 = Det,p3=Det + *n;p2=0;j--) { p0 = b1 + rank * j; /* start of source column */ for (i=0;i< rank;i++) beta[pivot1[i]] = p0[i]; undrop_rows(beta,*q,1,drop,n_drop); /* zero rows inserted */ p1 = b1 + *q * j; /* start of target column */ for (p0=beta,p2=p0 + *q;p0 m || *nt < 1) *nt = m; /* no point in more threads than m */ omp_set_num_threads(*nt); /* set number of threads to use */ #else *nt = 1; #endif nt1 = *nt; /* allows threading to be switched off for QR for debugging*/ if (*deriv==2) deriv2=1; else deriv2=0; ScS=0;for (pi=rSncol;pi leave readable!)*/ a1=(double *)CALLOC((size_t)*n,sizeof(double)); a2=(double *)CALLOC((size_t)*n,sizeof(double)); alpha1=alpha2 =(double *)NULL; if (*fisher) { /* Fisher scoring updates */ /* set up constants involved in w updates */ /* dw/deta = - w[i]*(V'/V+2g''/g')/g' */ for (i=0;i< *n;i++) a1[i] = - w[i] *(V1[i] + 2*g2[i])/g1[i]; /* d2w/deta2 .... */ for (i=0;i< *n;i++) a2[i] = a1[i]*(a1[i]/w[i]-g2[i]/g1[i]) - w[i]*(V2[i]-V1[i]*V1[i] + 2*g3[i]-2*g2[i]*g2[i])/(g1[i]*g1[i]) ; } else { /* full Newton updates */ alpha1 = (double *) CALLOC((size_t)*n,sizeof(double)); alpha2 = (double *) CALLOC((size_t)*n,sizeof(double)); for (i=0;i< *n;i++) { xx = V2[i]-V1[i]*V1[i]+g3[i]-g2[i]*g2[i]; /* temp. storage */ alpha1[i] = (-(V1[i]+g2[i]) + (y[i]-mu[i])*xx)/alpha[i]; alpha2[i] = (-2*xx + (y[i]-mu[i])*(V3[i]-3*V1[i]*V2[i]+2*V1[i]*V1[i]*V1[i]+g4[i]-3*g3[i]*g2[i]+2*g2[i]*g2[i]*g2[i]))/alpha[i]; } /* end of preliminaries, now setup the multipliers that go forward */ /* dw/deta ... */ for (i=0;i<*n;i++) a1[i] = w[i]*(alpha1[i]-V1[i]-2*g2[i])/g1[i]; /* d2w/deta2... */ for (i=0;i<*n;i++) a2[i] = a1[i]*(a1[i]/w[i]-g2[i]/g1[i]) - w[i]*(alpha1[i]*alpha1[i] - alpha2[i] + V2[i]-V1[i]*V1[i] + 2*g3[i]-2*g2[i]*g2[i])/(g1[i]*g1[i]) ; if (! *REML) { /* then Fisher versions of a1 and a2 also needed */ af1=(double *)CALLOC((size_t)*n,sizeof(double)); af2=(double *)CALLOC((size_t)*n,sizeof(double)); /* dwf/deta = - w[i]*(V'/V+2g''/g')/g' */ for (i=0;i< *n;i++) af1[i] = - wf[i] *(V1[i] + 2*g2[i])/g1[i]; /* d2wf/deta2 .... */ for (i=0;i< *n;i++) af2[i] = af1[i]*(af1[i]/wf[i]-g2[i]/g1[i]) - wf[i]*(V2[i]-V1[i]*V1[i] + 2*g3[i]-2*g2[i]*g2[i])/(g1[i]*g1[i]) ; } FREE(alpha1);FREE(alpha2); } /* end of full Newton setup */ /* get gradient vector and Hessian of deviance wrt coefficients */ for (i=0;i< *n ;i++) v1[i] = -2*p_weights[i]*(y[i]-mu[i])/(V0[i]*g1[i]); dev_grad=(double *)CALLOC((size_t) rank,sizeof(double)); bt=1;ct=0;mgcv_mmult(dev_grad,X,v1,&bt,&ct,&rank,&one,n); if (deriv2) { /* get hessian of deviance w.r.t. beta */ for (p0=dev_hess,p1=p0 + rank * rank;p00) { i=0;mgcv_mmult(work,Rh,b1,&i,&i,&rank,M,&rank); /* Rh db/drho */ /* Now obtain dVkk = diag(db'/drho Rh' Rh db/drho) ... */ getXtX(dVkk,work,&rank,M); } /* Now use IFT based derivatives to obtain derivatives of W and hence the T_* terms */ /* get derivatives of w */ rc_prod(w1,a1,eta1,M,n); /* w1 = dw/d\rho_k done */ if (deriv2) { rc_prod(w2,a1,eta2,&n_2dCols,n); for (pw2=w2,m=0;m < *M;m++) for (k=m;k < *M;k++) { rc_prod(v1,eta1 + *n * m,eta1 + *n * k,&one,n); rc_prod(v2,a2,v1,&one,n); p1=v2 + *n; for (p0=v2;p01) for (p0=trA2,p1 = P2,p2 = P2 + *M * *M;p11) for (p1 = P2,p2 = P2 + *M * *M;p1=0;j--) { p0 = b1 + rank * j; /* start of source column */ for (i=0;i< rank;i++) beta[pivot1[i]] = p0[i]; undrop_rows(beta,*q,1,drop,n_drop); /* zero rows inserted */ p1 = b1 + *q * j; /* start of target column */ for (p0=beta,p2=p0 + *q;p00) { /* It's REML */ /* Now deal with log|X'WX+S| */ reml_penalty = ldetXWXS; get_ddetXWXpS(trA1,trA2,P,K,sp,rS,rSncol,Tk,Tkm,n,&rank,&rank,M,&FALSE,deriv,*nt); /* trA1/2 really contain det derivs */ } /* So trA1 and trA2 actually contain the derivatives for reml_penalty */ if (*REML<0) { /* it's ML, and more complicated */ /* get derivs of ML log det in trA1 and trA2... */ reml_penalty = MLpenalty1(trA1,trA2,Tk,Tkm,nulli,X,R,Q1,nind,sp,rS,rSncol, &rank,n,Mp,M,&FALSE,&neg_w,rank_tol,deriv,nt,&FALSE); FREE(R);FREE(Q1);FREE(nind); } /* note that rS scrambled from here on... */ /* clean up memory, except what's needed to get tr(A) and derivatives */ if (neg_w) FREE(Vt); FREE(work);FREE(PKtz); if (*deriv) { //FREE(b1); FREE(eta1); FREE(eta2); FREE(a1);FREE(a2);FREE(wi);FREE(dev_grad); //FREE(w1); FREE(w2);FREE(b2); if (deriv2) { FREE(dev_hess);} } /* Note: the following gets only trA if REML is being used, so as not to overwrite the derivatives actually needed, which also means that it doesn't matter if MLpenalty has messed up rS */ if (*fisher) { /* then all quantites are the ones required for EDF calculations */ wf = w;Tfk=Tk;Tfkm=Tkm; } else { /* Need expected value versions of everything for EDF calculation */ /* form sqrt(wf)X augmented with E */ nr = *n + *Enrow; /* st WX = (double *)CALLOC((size_t)nr * rank,sizeof(double)); */ WX = (double *) CALLOC((size_t) ( (nr + *nt * rank) * rank),sizeof(double)); for (p0=w,p1=w + *n,p2=wf;p0=0;k--) { yp = (1-p[k])/R[k + *r *k]; ym = (-1-p[k])/R[k + *r *k]; for (pp_norm=0.0,i=0;i= fabs(ym)+pm_norm) { y[k]=yp; for (i=0;iy_inf) y_inf=kappa; } for (i=0;i<*c;i++) { for (kappa=0.0,j=i;j<*c;j++) kappa += fabs(R[i + *r * j]); if (kappa>R_inf) R_inf = kappa; } kappa=R_inf*y_inf; *Rcondition=kappa; } /* end R_cond */ void pls_fit1(double *y,double *X,double *w,double *wy,double *E,double *Es,int *n,int *q,int *rE,double *eta, double *penalty,double *rank_tol,int *nt,int *use_wy) /* Fast but stable PLS fitter. Obtains linear predictor, eta, of weighted penalized linear model, without evaluating the coefficients, but also returns coefficients in case they are needed. Uses QR approach, but tests that X'Wz = R'Q_1'sqrt(\bar w)\bar z (in Wood 2011 notation), to ensure that rhs is stable, and uses R^{-T}X'Wy in plce of Q_1'sqrt(\bar w)\bar z if not. The reason for this is that it is possible for sqrt(w)*z to be *very* badly scaled when w*z is well scaled.... Also has the option to not test, but simply use X'Wy directly, if *use_wy is non-zero. This is useful in situations in which y is pseudodata involving a reciprocal w and some w_i is zero. Note that here E'E = S, while Es'Es = `well scaled version of S' In this version the w_i are the w_i in \sum_i w_i (y_i - X_i \beta)^2 rather than being the square root of these. Some w_i may be negative (as may occur when using Newton, rather than Fisher updates on IRLS). Note that it is still assumed that any zero weighted data will have been dropped before the call. If nt>1 and openMP is available then routine computes with the optimal number of threads up to nt. On return: * if *n is -ve then X'WX+E'E was not +ve definite (which means that the routine should be called again with weights based on Fisher scoring). otherwise: * eta contains the linear predictor * penalty is the evaluated penalty * the first q elements of y are the coefficients. */ { int i,j,k,rank,one=1,*pivot,*pivot1,left,tp,neg_w=0,*nind,bt,ct,nr,n_drop=0,*drop,TRUE=1,FALSE=0,nz; double *z,*WX,*tau,Rcond,xx,zz,zz1,*work,*Q,*Q1,*IQ,*raw,*d,*Vt,*p0,*p1, *R1,*tau1,Rnorm,Enorm,*R,*Xp; #ifdef OPENMP_ON int m; m = omp_get_num_procs(); /* detected number of processors */ if (*nt > m || *nt < 1) *nt = m; /* no point in more threads than m */ omp_set_num_threads(*nt); /* set number of threads to use */ #else *nt = 1; /* no openMP support - turn off threading */ #endif nr = *q + *rE; nz = *n; if (nz 1) { rank--;R_cond(R,&nr,&rank,work,&Rcond);} /* Now have to drop the unidentifiable columns from R1, E and the corresponding rows from rS The columns to drop are indexed by the elements of pivot1 from pivot1[rank] onwards. Before returning, zeros will need to be inserted in the parameter vector at these locations. */ n_drop = *q - rank; if (n_drop) { drop = (int *)CALLOC((size_t)n_drop,sizeof(int)); /* original locations of dropped parameters */ for (i=0;i *rank_tol * zz) { *use_wy = 1; //Rprintf("instability detected zz1= %g zz = %g\n",zz1,zz); } } if (*use_wy) { /* then R'Q'wz unstable or this computation signalled on entry */ for (k=0;k=0;k--) { for (xx=0.0,j=k+1;j < rank;j++) xx += R[k + nr * j]*z[j]; z[k] = (y[k] - xx)/R[k + nr * k]; } /* unpivot result (in z) into y */ for (i=0;i< rank;i++) y[pivot1[i]] = z[i]; /* insert zeroes for unidentifiables */ undrop_rows(y,*q,1,drop,n_drop); if (*use_wy) { /* re-compute other results from beta, as originals appear unstable or this method requested */ bt=0;ct=0;mgcv_mmult(eta,X,y,&bt,&ct,n,&one,q); bt=0;ct=0;mgcv_mmult(work,E,y,&bt,&ct,rE,&one,q); for (*penalty=0.0,i=0;i < *rE;i++) *penalty += work[i]*work[i]; /* the penalty term */ } FREE(z); FREE(WX);FREE(tau);FREE(pivot);FREE(raw); FREE(R);FREE(pivot1);FREE(tau1); FREE(work); if (n_drop) FREE(drop); if (neg_w) { FREE(nind);FREE(d);FREE(Vt);} } /* end pls_fit1 */ mgcv/src/sparse-smooth.c0000644000177400001440000020117513046054035015145 0ustar murdochusers/* Copyright Simon N. Wood, 2011-13 Code to implement kd tree based nearest neighbour routines in C. Based on approach of Press et al Numerical Recipes 3rd ed. 21.2, but re-implemented in vanilla C. Design is based on principles from Press et al. but due to licensing, this is a re-write. So results need not correspond to Press et al. code in detail (e.g. exactly which point is in which box of tree, and exact indexing details). Efficiency should be same, however. R CMD SHLIB kd-tree.c to build. dyn.load("kd-tree.so") to load into R. */ #include #include #include #include #include #include "mgcv.h" /* kd-tree tasks: 1. Build and return kd tree. 2. Find nearest neighbour of points x in given kd tree. 3. Find k nearest neighbours of points x in given kd tree. 4. Build kd tree, compute k nearest neighbours for all nodes, return these, and optionally tree. 5. Find all points in given tree within r-ball of each point in x. key routines: * kd_tree and free_kdtree for creating and freeing kd trees. * closest - find closest point in kd tree to a new point x. * k_nn_work finds k nearest neighbours of each node in kd tree * k_nn forms kd tree and then obtains k nearest neighbours * kd_sizes, kd_dump, kd_read are concerned with encoding kd tree in form suitable for storage in R and reading from this format. needed: * k_closest - find k nearest neighbours in kd tree to points not in kd tree. * r_ball - find points in kd tree within r-balls around points not in kd tree. */ void kd_sizes(kdtree_type kd,int *ni,int *nd) { /* reports size of integer array and double array (ni and nd) required to hold full kd tree in packed storage for passing back to R */ *nd = 1 + kd.d * kd.n_box * 2; /* to hold huge, lo and hi data for boxes */ *ni = 2 + /* n_box and d */ 2 * kd.n + /* ind, rind */ 5 * kd.n_box; /* parent,child1,child2,p0,p1*/ } void kd_dump(kdtree_type kd,int *idat,double *ddat) { /* writes a kdtree structure to arrays idat and ddat, initialized to the sizes determined by kd_sizes for kd. The point is that these are suitable for passing to R, say. */ int *p,*p0,*p1,i,nb,d,*pc1,*pc2,*pp,n; double *pd,*pd1; nb = idat[0] = kd.n_box; /* number of boxes */ d = idat[1] = kd.d; /* dimension of boxes/points */ n = idat[2] = kd.n; /* number of points tree relates to */ *ddat = kd.huge;ddat++; /* copy kd.ind... */ for (p=idat+3,p0=kd.ind,p1=p0+n;p0n_box = idat[0]; /* number of boxes */ d = kd->d = idat[1]; /* dimensions of boxes etc. */ n = kd->n = idat[2]; /* number of points tree relates to */ kd->ind = idat + 3; kd->rind = idat + 3 + n; kd->huge = *ddat;ddat++; /* Now make an array of boxes (all cleared to zero)... */ kd->box = (box_type *)CALLOC((size_t)nb,sizeof(box_type)); /* now work through boxes loading contents */ pp = idat + 3 + 2*n; /* parents */ pc1 = pp + nb; /* child1 */ pc2 = pc1 + nb; /* child2 */ p0 = pc2 + nb; /* p0 */ p1 = p0 + nb; /* p1 */ box = kd->box; for (i=0;ilo = ddat;ddat += d; box->hi = ddat;ddat += d; box->parent = *pp;pp++; box->child1 = *pc1;pc1++; box->child2 = *pc2;pc2++; box->p0 = *p0;p0++; box->p1 = *p1;p1++; } } void kd_sanity(kdtree_type kd) { int ok=1,i,*count,n=0; for (i=0;in) n = kd.box[i].p1; count = (int *)CALLOC((size_t)n,sizeof(int)); for (i=0;i1) { Rprintf("More than 2 points in a box!!\n");ok=0;} count[kd.box[i].p0]++; if (kd.box[i].p1!=kd.box[i].p0) count[kd.box[i].p1]++; } for (i=0;i=x[ind[k]]))==0 */ int l,r,m,ip,ri,li,dum; double xp; l = 0; /* leftmost point of current partition */ r = *n-1; /* rightmost point of current partitions */ while (1) { if (r > l+1) { /* partition large enough to need work still */ m = (l+r) / 2; /* pick a point from partition midpoint (by location not value) (Press et al say to do this to avoid poor behaviour on already sorted x).*/ dum = ind[l+1];ind[l+1] = ind[m];ind[m] = dum; /* swap points m and l+1 */ /* now re-arrange so that x[ind[l]] < x[ind[l+1]] < x[ind[r]]... */ if (x[ind[l]] > x[ind[r]]) { /* swap r and l */ dum = ind[r];ind[r] = ind[l];ind[l] = dum; } if (x[ind[l]] > x[ind[l+1]]) { /* swap l and l+1 */ dum = ind[l];ind[l] = ind[l+1];ind[l+1] = dum; } else if (x[ind[l+1]] > x[ind[r]]) { /* swap l+1 and r */ dum = ind[l+1];ind[l+1] = ind[r];ind[r] = dum; } ip = ind[l+1]; /* index of pivot */ xp = x[ip]; /* pivot value */ /* so pivot is xp = x[ind[l+1]]. start proccess of shuffling array into two partitions containing all the values less than xp, and all those larger than xp... */ ri = r; /* start searching down partition from here for wrongly located values (pos r above pivot already) */ li = l+1; /* start searching up from here (pos l is already below pivot, l+1 is pivot)*/ while (1) { /* BUG: can get stuck in here, when there are tied values, so that li and ri stay unmodified, but ri > li... changing to <= >= allows ri and li to move out of [0,n], which causes segfault!*/ li++;ri--; /* always move by one, or you can get stuck */ while(x[ind[li]] < xp) li++; /* move up until value on wrong side (or equal) found */ while(x[ind[ri]] > xp) ri--; /* move down until value on wrong side (or equal) found */ if (ri < 0) Rprintf("ri<0!!\n"); if (li >= *n) Rprintf("li >= n!!\n"); if (ri= *k ) r = ri - 1; /*else l=li;*/ /* if (ri <= *k + 1) l = li;*/ /* had else l=li; here */ if (ri <= *k ) l = li; } else { /* the partition can only contain 1 or 2 points */ if (r == l+1 && x[ind[r]] < x[ind[l]]) { /* contains two points, but in wrong order */ dum = ind[r];ind[r] = ind[l];ind[l] = dum; /* so swap indices */ } return; /* x[ind[k]] is kth largest value in x */ } } /* end while(1) - main loop */ } void free_kdtree(kdtree_type kd) { /* free a kdtree. Only use for tree created entirely from complied code, not one read from R. For R only versions FREE(kd.box) is all that is needed, as rest uses memory sent in from R.*/ FREE(kd.ind);FREE(kd.rind); FREE(kd.box[0].lo); /* storage for box coordinates */ FREE(kd.box); } void kd_tree(double *X,int *n, int *d,kdtree_type *kd) { /* Create a kd tree for the points in n by d matrix X. X is in column order. Each row is one point. At end of process... * box[i] contains points indexed by ind[box[i].p0..box[i].p1] * box[i] has one parent and 2 children, unless it contains only one or 2 points, in which case it has no children. */ int *ind,*rind,*p,i,m,todo[50],todo_d[50],item,bi,nb,np,k,dim,b,p0,p1; box_type *box; double huge=1e100,*pd,*x,*dum1,*dum2,*dum3; /* create index for points... */ ind = (int *)CALLOC((size_t) *n,sizeof(int)); for (i=0,p=ind;i < *n;i++,p++) *p = i; /* Find the number of boxes in the tree */ m=2;while (m < *n) m *= 2; nb = *n * 2 - m / 2 - 1; if (nb > m-1) nb = m - 1; /* Now make an array of boxes (all cleared to zero)... */ box = (box_type *)CALLOC((size_t)nb,sizeof(box_type)); /* allocate storage for box defining coordinates... */ pd = (double *)CALLOC((size_t)nb * (2 * *d),sizeof(double)); for (i=0;i= 0) { /* todo list still has items */ b = todo[item]; /* current box */ dim = todo_d[item]; /* dimension on which to split box */ p0 = box[b].p0;p1=box[b].p1; np = p1-p0+1; /* number of points in box k */ x = X + dim * *n; /* array of co-ordinates for current dimension to sort on */ k = (np-1)/2; /* split the box around kth value in box */ /* next line re-orders the point index for this box only. after reordering the index is split into two parts, indexing points below and above the kth largest value */ k_order(&k,ind+p0,x,&np); /*... so the box is now split at a plane/line through x[ind[p0+k-1]] */ item--; /* basically done that item */ /* create the offspring boxes... */ bi++; /* lower box first */ if (bi>nb-1) Rprintf("too many boxes!!"); box[b].child1=bi;/* record box relationships */ /* copy box coordinates... */ for (dum1=box[bi].lo,dum2=dum1 + *d,dum3=box[b].lo;dum11) { /* more than two points , so more work needed */ item++; todo[item] = bi; todo_d[item] = dim+1; if (todo_d[item] == *d) todo_d[item] = 0; } bi++; /* now the higher box */ if (bi>nb-1) Rprintf("too many boxes!!"); box[b].child2=bi;/* record box relationships */ /* copy box coordinates... */ for (dum1=box[bi].lo,dum2=dum1 + *d,dum3=box[b].lo;dum13) { /* more than two points , so more work needed */ item++; todo[item] = bi; todo_d[item] = dim+1; if (todo_d[item] == *d) todo_d[item] = 0; } } if (bi!=nb-1) Rprintf("bi not equal to nb-1 %d %d\n",bi,nb-1); rind = (int *)CALLOC((size_t) *n,sizeof(int)); /* now create index of where ith row of X is in ind */ for (i=0;i<*n;i++) rind[ind[i]]=i; /* now put tree into kd object */ kd->box = box;kd->ind = ind;kd->rind = rind;kd->n_box = nb;kd->huge = huge; kd->d = *d;kd->n = *n; } /* end of kd_tree */ void Rkdtree(double *X,int *n, int *d,int *idat,double *ddat) { /* Routine to export kdtree data to R m <- 2; while (m h[2*i+1] and h[i] > h[2*i+2] (each applying whenever elements exist). The exception is that h[0], may not obey these conditions. This function re-arranges h so that it does. It also applies the same re-arrangement to ind. Figure 8.3.1 of Press et al (2007) shows what's going on. */ double h0; int i,i0,ind0; h0 = h[0]; /* h0 should be largest element, in properly ordered heap */ ind0 = ind[0]; /* index vector to re-shuffle exactly as h vector */ i0 = 0; /* current position of h0 */ i = 1; /* index for first child node of i0 */ while (i < n) { /* work through to end of heap */ if (i < n-1&&h[i] h[i]) break; /* h0 should be at h[i0] */ /* since h0 <= h[i], move h[i] 'up' heap into h[i0], and move i0, the nominal position for h0 'down' heap to i */ h[i0] = h[i]; ind[i0] = ind[i]; i0 = i; i = 2*i+1; /* now move on to first child of h[i]... */ } h[i0] = h0; /* put h0 into location it should occupy in heap */ ind[i0] = ind0; } double box_dist(box_type *box,double *x,int d) { /* find distance from d dimensional box to point x */ double d2 = 0.0,z,*bl,*bh,*xd; for (xd=x+d,bl=box->lo,bh=box->hi; x < xd;x++,bl++,bh++) { if (*x < *bl) { z = *x - *bl;d2 += z*z;} if (*x > *bh) { z = *x - *bh;d2 += z*z;} } return(sqrt(d2)); } int which_box(kdtree_type *kd,int j) { /* Finds smallest box in kd tree containing jth point from point set used to create tree */ int i,bi,b1; i = kd->rind[j]; /* where jth point is in kd->ind */ bi=0; while (kd->box[bi].child1) { /* still haven't reached smallest */ b1 = kd->box[bi].child1; /* index of first child */ if (kd->box[b1].p1>=i) bi = b1; /* point is in child1 */ else bi = kd->box[bi].child2; /* kd->box[bi].child1 must be in child2 */ } return(bi); /* index of smallest box containing jth point */ } int xbox(kdtree_type *kd,double *x) { /* which box of the kd tree is point x located in? For maximal efficiency use the fact that nested boxes are split along one dimension, and that the split dimensions are cycled through in the same order, while descending the tree. */ int bi,d,b1; box_type *box; bi=0; /* root of the tree - the big box */ box = kd->box; d=0; /* dimension for first split */ while (box[bi].child1) { /* still not reached the outermost twig - smallest box*/ b1 = box[bi].child1; if (box[b1].hi[d]!=box[box[bi].child2].lo[d]) Rprintf("child boundary problem\n"); /* note that points on boundary are in lower box (child1) */ if (x[d] <= box[b1].hi[d]) bi = b1; else bi = box[bi].child2; d++; if (d == kd->d) d=0; } return(bi); } double ijdist(int i, int j, double *X,int n,int d) { /* return Euclidian distance between ith and jth rows of n by d matrix X */ double *pi,*pj,*pil,dist=0.0,x; for (pi=X+i,pil=pi+n*d,pj=X+j;pid is dimension. n is number of rows in X. rows of X are points in tree. if nex>0 then ex is a list of points to exclude. NOTE: may be buggy... */ int bx,ni,i,j,k,d,todo[100],bi,*ind,item,ok=0; double nd,d1,dix; box_type *box; if (nex<0) nex=0; nd = kd->huge; bx = xbox(kd,x); /* box containing x */ /* get closest point within that box */ d = kd->d; box = kd->box; ind = kd->ind; ni = -1; while (ni<0) { /* open larger boxes until one contains a non-excluded neighbour */ for (j=box[bx].p0;j=0) { /* items on the todo list */ if (todo[item]==bx) { /* this is the initializing box - already dealt with */ item--; } else { bi = todo[item]; /* box to deal with now */ item--; if (box_dist(box+bi,x,d)d!=2) Rprintf("\n star only useful in 2D\n"); pi25 = asin(1)*4/5; x0[0] = X[i0];x0[1] = X[i0 + n]; ex[0] = i0; for (i=0;i<5;i++) { dx = dist*sin(pi25*i);dy = dist*cos(pi25*i); x[0] = x0[0] + dx;x[1] = x0[1] + dy; /* current star point */ /* find closest point in X/kd, not in exclusion list */ ex[i+1] = ni[i] = closest(kd,X,x,n,ex,i+1); } } void p_area(double *a,double *X,kdtree_type kd,int n,int d) { /* Associates the volume of its kd box with each point. If the point shares a box then the volume is split. If the box has an open boundary then that boundary is shrunk so that the point is enclosed in it. Results returned in a. */ double *wa,*lo,*hi,*x0,*x1,min_w,x; int np,bi,i,j,k,ok=1,*count,check; wa = (double *)CALLOC((size_t)d,sizeof(double)); lo = (double *)CALLOC((size_t)d,sizeof(double)); hi = (double *)CALLOC((size_t)d,sizeof(double)); x0 = (double *)CALLOC((size_t)d,sizeof(double)); x1 = (double *)CALLOC((size_t)d,sizeof(double)); count = (int *)CALLOC((size_t)d,sizeof(int)); /* get average box widths, for fallback purposes */ for (bi=0;bi1) { /* there is a second point to consider */ k = kd.ind[kd.box[bi].p1]; if (k==i) check=1; for (j=0;j1 && x1[j]1 && x1[j]>x) x = x1[j]; if (x > lo[j]) hi[j] = x; /* sorted! */ else ok=0; /* not sorted! */ } if (lo[j] != -kd.huge && hi[j] != kd.huge) { x = hi[j]-lo[j]; if (min_w < 0 || x < min_w) min_w = x; } } /* end of first pass through limits */ if (!ok) { /* then there are unfixed limits left to deal with */ for (j=0;j1 && x1[j]0) x -= min_w; else x -= wa[j]; lo[j] = x; /* sorted! */ } if (hi[j] == kd.huge) { /* attempt to shrink boundary to (highest) point */ x = x0[j]; if (np>1 && x1[j]>x) x = x1[j]; if (min_w>0) x += min_w; else x += wa[j]; hi[j] = x; /* sorted! */ } } } /* all limits now reset */ } /* box is now finite */ /* compute box volume */ for (x=1.0,j=0;j= box[c2].lo[dim]) bi = c2; /* r-ball completely in child 2 */ dim++; if (dim==d) dim = 0; if (bi==bi_old) break; /* neither child contained whole r-ball, so use box[bi] */ } /* box[bi] completely encloses the r-ball around x. Now check whether its points lie within r-ball around x... */ item=0; /* index of end of task list */ todo[0] = bi; /* initial task - box bi */ while (item>=0) { bi = todo[item];item--; if (box_dist(box+bi,x,d) < r) { /* box could contain a point in r-ball so check */ if (box[bi].child1) { /* box has children, so add them to todo list */ item++;todo[item] = box[bi].child1; item++;todo[item] = box[bi].child2; } else { /* reached small end of tree - check actual points */ for (i=box[bi].p0;i<=box[bi].p1;i++) { if (xidist(x,X,ind[i],d,n) < r) { list[*nlist] = ind[i]; (*nlist)++; } } } } } } /* k_radius */ void Rkradius(double *r,int *idat,double *ddat,double *X,double *x,int *m,int *off,int *ni,int *op) { /* Given kd tree defined by idat, ddat and X, from R, this routine finds all points in the tree less than distance r from each point in x. x contains the points stored end-to-end. Routine must be called twice. First with op==0, which does the work, but only returns the length required for ni, in off[m+1]. The second call must have op==1, and ni initialized to the correct length. Then neighbour information is returned in off, ni. neighbours of ith point are in ni[off[i]:(off[i+1]-1)], where off is an m+1 vector. All indexes 0 based (C style). Add one to off and ni to get R style. */ static int *nei,nn; kdtree_type kd; double *xx; int d,i,j,n_buff=0,nlist,*list; if (*op) { /* output saved nei data */ for (i=0;in_buff) { /* expand nei */ n_buff *= 2; nei = (int *)R_chk_realloc(nei,(size_t)n_buff*sizeof(int)); } for (j=nn;j> k .... */ /*bi = which_box(&kd,i);*/ /* bi is smallest box containing ith point */ bi = xbox(&kd,x); /* bi is smallest box containing ith point, x */ while (box[bi].p1-box[bi].p0 < *k) bi = box[bi].parent; /* note k does not include self */ /* Rprintf("Initial box %d contains %d need %d\n",bi,kd.box[bi].p1-kd.box[bi].p0+1,*k); */ /* now find k nearest points in the box and put in dk... */ for (j=box[bi].p0;j<=box[bi].p1;j++) { pcount++; /*dij = ijdist(i,ind[j],X,*n,*d);*/ /* distance between points i and j */ dij = xidist(x,X,ind[j],*d,*n); if (dij1) update_heap(dk,ik,*k); /* update heap so it still obeys heap ordering */ } } /* finished initialising heap (dk, ik) */ /* Now search the rest of the tree. Basic idea is that if a box is further from the ith point than dk[0] (the largest of the current neighbour distances), then we can ignore all the points it contains (and hence its descendents) */ todo[0] = 0; /* index of root box... first to check */ item=0; bii = bi; /* index of initializing box */ while (item>=0) { /* items on the todo list */ if (todo[item]==bii) { /* this is the initializing box - already dealt with */ item--; } else { bi = todo[item]; /* box to deal with now */ item--; if (box_dist(box+bi,x,*d)1) update_heap(dk,ik,*k); /* update heap so it still obeys heap ordering */ } /* end of point addition */ } /* done the one or two points in this box */ } /* finished with this small box */ } /* finished with possible candiate box */ } /* end of else branch */ } /* todo list end */ /* So now the dk, ik contain the distances and indices of the k nearest neighbours */ for (j=0;j<*k;j++) { /* copy to output matrices */ dist[i + j * *m] = dk[j]; ni[i + j * *m] = ik[j]; } } /* end of points loop (i) */ FREE(dk); FREE(ik); FREE(x); *n = pcount; } /* k_newn_work */ void Rkdnearest(double *X,int *idat,double *ddat,int *n,double *x, int *m, int *ni, double *dist,int *k) { /* given points in n rows of X and a kd tree stored in idat, ddat in R, find the k neares neighbours to each row of x m by d matrix x. * outputs ni is m by k matrix of neighbour indices dist is m by k matrix of neighbour distances */ kdtree_type kd; int d; kd_read(&kd,idat,ddat); /* unpack kd tree */ d = kd.d; /* dimension */ /* get the nearest neighbour information... */ k_newn_work(x,kd,X,dist,ni,m,n,&d,k); FREE(kd.box); /* free storage created by kd_read */ } void k_nn_work(kdtree_type kd,double *X,double *dist,int *ni,int *n,int *d,int *k) { /* Given a kd tree, this routine does the actual work of finding the nearest neighbours. */ int i,j,bi,*ik,bii,todo[100],item,pcount,*ind; box_type *box; double *dk,huge,*p,*p1,*p2,dij,*x; huge = kd.huge; ind = kd.ind; box = kd.box; dk = (double *)CALLOC((size_t)*k,sizeof(double)); /* distance k-array */ ik = (int *)CALLOC((size_t)*k,sizeof(int)); /* corresponding index array */ x = (double *)CALLOC((size_t)*d,sizeof(double)); /* array for current point */ pcount=0; for (i=0;i < *n;i++) { /* work through all the points in X */ for (p=X+i,p1=x,p2=p1 + *d;p1> k .... */ bi = which_box(&kd,i); /* bi is smallest box containing ith point */ /* for (j=0;j<*d;j++) if (x[j]kd.box[bi].hi[j]) { Rprintf("%d ",i); for (j=0;j<*d;j++) Rprintf("%g ",x[j]); for (j=0;j<*d;j++) Rprintf("%g ",kd.box[bi].lo[j]); for (j=0;j<*d;j++) Rprintf("%g ",kd.box[bi].hi[j]); Rprintf("\n"); } Rprintf("%d ",bi);*/ while (box[bi].p1-box[bi].p0 < *k) bi = box[bi].parent; /* note k does not include self */ /* Rprintf("Initial box %d contains %d need %d\n",bi,kd.box[bi].p1-kd.box[bi].p0+1,*k); */ /* now find k nearest points in the box and put in dk... */ for (j=box[bi].p0;j<=box[bi].p1;j++) if (ind[j]!=i) { /* avoid self! */ pcount++; dij = ijdist(i,ind[j],X,*n,*d); /* distance between points i and j */ if (dij1) update_heap(dk,ik,*k); /* update heap so it still obeys heap ordering */ } } /* finished initialising heap (dk, ik) */ /* Now search the rest of the tree. Basic idea is that if a box is further from the ith point than dk[0] (the largest of the current neighbour distances), then we can ignore all the points it contains (and hence its descendents) */ todo[0] = 0; /* index of root box... first to check */ item=0; bii = bi; /* index of initializing box */ while (item>=0) { /* items on the todo list */ if (todo[item]==bii) { /* this is the initializing box - already dealt with */ item--; } else { bi = todo[item]; /* box to deal with now */ item--; if (box_dist(box+bi,x,*d)1) update_heap(dk,ik,*k); /* update heap so it still obeys heap ordering */ } /* end of point addition */ } /* done the one or two points in this box */ } /* finished with this small box */ } /* finished with possible candiate box */ } /* end of else branch */ } /* todo list end */ /* So now the dk, ik contain the distances and indices of the k nearest neighbours */ for (j=0;j<*k;j++) { /* copy to output matrices */ dist[i + j * *n] = dk[j]; ni[i + j * *n] = ik[j]; } } /* end of points loop (i) */ FREE(dk); FREE(ik); FREE(x); *n = pcount; } /* k_nn_work */ void k_nn(double *X,double *dist,double *a,int *ni,int *n,int *d,int *k,int *get_a) { /* NOTE: n modified on exit!! no tie handling... impractical without! X is an n by d matrix. Each row is the location of a point in some Euclidean d-space. Find k nearest neighbours in X of all points in X. ni and dist are both n by k. each row of ni contains the neighbour list. Each row of dist is contains the corresponding distances. if get_a is non zero, then volumes of kd boxes are associated with each point and returned in a. Some R test code... cd ~simon/mgcv-related/sparse-smooth R CMD SHLIB kd-tree.c R dyn.load("kd-tree.so") set.seed(2) n <- 100;d <- 2;k <- 5 X <- matrix(runif(n*d),n,d) dist <- matrix(0,n,k) system.time(oo <- .C("k_nn",X=as.double(X),dist=as.double(dist),a=as.double(1:n),ni=as.integer(dist), n=as.integer(n),d=as.integer(d),k=as.integer(k),get.a=as.integer(1))) oo$n/n^2 ## efficiency dist1 <- dist <- matrix(oo$dist,n,k) ni1 <- ni <- matrix(oo$ni+1,n,k) ## checking code... for (i in 1:n) { Xi <- t(t(X)-X[i,]) di <- rowSums(Xi^2)^.5 oi <- order(di) ni1[i,] <- (1:n)[oi[2:(k+1)]] dist1[i,] <- di[ni1[i,]] oi <- order(dist[i,]) dist[i,] <- dist[i,oi] ni[i,] <- ni[i,oi] } range(ni-ni1) range(dist-dist1) */ kdtree_type kd; kd_tree(X,n,d,&kd); /* set up the tree */ if (*get_a) p_area(a,X,kd,*n,*d); k_nn_work(kd,X,dist,ni,n,d,k); free_kdtree(kd); } void kba_nn(double *X,double *dist,double *a,int *ni,int *n,int *d,int *k, int *get_a,double *cut_off) { /* REDUNDANT Obtains a roughly balanced set of 2d + k nearish neighbours. Idea is to take nearest neighbour from kd box immediately above or below each point's box, in each dimension, and to add k further points from the nearest neigbours not already included. For each point: 1. get 2d+k nearest neighbours. 2. get 2d balanced neighbours. 3. find k nearest neighbours in set 1 that are not in set 2. Step 3 can go through nearest looking for self and largest. */ int ii,i,j,nn,d2k,bi,bj,max_i,q,n1,n2,*count,method=1; double dx,*x,max_dist,d1,d2,maxnd,xj,*db,*p,*p1,d0; kdtree_type kd; kd_tree(X,n,d,&kd); /* set up the tree */ kd_sanity(kd); /* DEBUG only */ if (*get_a) p_area(a,X,kd,*n,*d); d2k = 2 * *d + *k; nn = *n; /* following modifies n!!*/ k_nn_work(kd,X,dist,ni,&nn,d,&d2k); /* get 2d+k nearest neighbours */ /* d0 = average of distance to 2d+k nearest neighbours - a useful basic length scale */ for (d0=0.0,p=dist,p1=dist+ *n * d2k;p -kd.huge&&kd.box[bi].hi[j] < kd.huge) { db[j] += kd.box[bi].hi[j] - kd.box[bi].lo[j]; count[j] ++; } } for (j=0;j<*d;j++) { db[j] /= (count[j]+1); if (db[j]==0.0) db[j]=1.0; } for (i=0;i<*n;i++) { /* work through points */ if (i==112) { Rprintf("hello\n"); } bi = which_box(&kd,i); /* get centre of box containing i, if possible. This leads to fewer occasions on which same box turns up twice as a balanced neighbour. */ if (method==0) { for (j=0;j<*d;j++) { if (kd.box[bi].hi[j] < kd.huge && kd.box[bi].lo[j] > -kd.huge) x[j] = (kd.box[bi].hi[j] + kd.huge && kd.box[bi].lo[j])*0.5; else x[j] = X[i + j * *n]; } } else { for (j=0;j<*d;j++) x[j] = X[i + j * *n]; } for (j=0;j<*d;j++) { /* get the balanced neighbours, j indexes dimension */ xj = x[j]; /* upper neighbour ... */ if (kd.box[bi].hi[j]!=kd.huge) { /* then there is a neighbour in this direction */ if (method==0) { if (kd.box[bi].lo[j] > -kd.huge) dx = (kd.box[bi].hi[j] - kd.box[bi].lo[j])*1e-6; else dx = db[j]*1e-6; if (dx <=0) dx = db[j]*1e-6; x[j] = kd.box[bi].hi[j]+dx; } else { /* idea here is to avoid e.g. neighbours that have same co-ord in this direction */ x[j] += d0; if (x[j] <= kd.box[bi].hi[j]) x[j] = kd.box[bi].hi[j] + d0; } bj = xbox(&kd,x); /* box above bi on axis j*/ if (bj==bi) { Rprintf("%d upper neighbour claimed to be self d=%d!\n",i,j); for (q=0;q<*d;q++) { Rprintf("%g %g %g\n",kd.box[bi].lo[q],x[q],kd.box[bi].hi[q]); } Rprintf("\n"); } x[j] = xj; /* now get nearest point to i from box bj */ n1 = kd.ind[kd.box[bj].p0]; d1 = ijdist(i,n1,X,*n,*d); if (kd.box[bj].p1>kd.box[bj].p0) { n2 = kd.ind[kd.box[bj].p1]; d2 = ijdist(i,n2,X,*n,*d); if (d2 maxnd) maxnd = dist[ii]; if (ni[ii] == n1) { /* point is already in neighbour set */ ni[ii] = -(n1+1); /* signal to ignore for replacement */ max_i = -1; /* signal that no replacement needed */ break; } /* it is not impossible for the same point to turn up twice as an upper and lower neighbour. This can happen when a point is right on the box boundary, so that an upper neighbour is also detected as a side neighbour */ if (n1== -ni[ii]-1) { /* point already in set and marked no replace*/ max_i = -1; /* signal that no replacement needed */ break; } /* find furthest point among replaceables */ if (ni[ii]>=0&&dist[ii]>max_dist) { max_dist = dist[ii];max_i=ii; } } if (max_i >= 0 && d1 < *cut_off * maxnd) { /* replace furthest replacable item with n1 */ ni[max_i] = -(n1+1); /* signal not to replace later */ dist[max_i] = d1; } } /* upper neighbour done */ /* lower neighbour... */ if (kd.box[bi].lo[j]!=-kd.huge) { /* then there is a neigbour in this direction */ if (method==0) { if (kd.box[bi].hi[j] < kd.huge) dx = (kd.box[bi].hi[j] - kd.box[bi].lo[j])*1e-6; else dx = db[j]*1e-6; if (dx <=0) dx = db[j]*1e-6; x[j] = kd.box[bi].lo[j] - dx; } else { x[j] -= d0; if (x[j] >= kd.box[bi].lo[j]) x[j] = kd.box[bi].lo[j] - d0; } bj = xbox(&kd,x); /* box below bi on axis j*/ if (bj==bi) { Rprintf("lower neighbour claimed to be self!\n"); } x[j] = xj; /* now find point closest to point i in box bj */ n1 = kd.ind[kd.box[bj].p0]; d1 = ijdist(i,n1,X,*n,*d); if (kd.box[bj].p1>kd.box[bj].p0) { n2 = kd.ind[kd.box[bj].p1]; d2 = ijdist(i,n2,X,*n,*d); if (d2maxnd) maxnd = dist[ii]; if (ni[ii] == n1) { /* point is already in neighbour set */ ni[ii] = -(n1+1); /* signal to ignore for replacement */ max_i = -1; /* signal that no replacement needed */ break; } if (n1== -ni[ii]-1) { /* point already in set and marked no replace*/ max_i = -1; /* signal that no replacement needed */ break; } if (ni[ii]>=0&&dist[ii]>max_dist) { max_dist = dist[ii];max_i=ii; } } if (max_i>=0 && d1 < *cut_off * maxnd) { /* replace furthest replacable item with n1 */ ni[max_i] = -(n1+1); /* signal not to replace later */ dist[max_i] = d1; } } /* lower neighbour done */ } /* collected balanced neighbours */ /* finally reset the negative indices to positive */ for (q=0;q < d2k;q++) { ii = i + *n * q; if (ni[ii]<0) ni[ii] = -ni[ii] - 1; } } FREE(x); free_kdtree(kd);FREE(db);FREE(count); } void tri2nei(int *t,int *nt,int *n,int *d,int *off) { /* Takes a triangulation of n points in d dimensions, and turns this into a neighbours list. t is nt by d+1 and contains the indices of triangle vertices in its rows, on entry. The indices must run from 0 to n-1. off is an n vector. On exit t[0..off[0]-1] contains the neighbours of point 0, and t[off[i-1] .. off[i]-1] contain the neigbours of point i if i>0. IMPORTANT: t should be initialised to double its actual size (triangulation packed first). */ int i,j,k,l,ii,jj,*p,*p1,*nn,k0,k1; /* count d times the number of triangles each point is part of... */ for (p=off,p1=off + *n;p1. on exit ii[off[i-1]:(off[i]-1)] == i X is n by d, and each row of X contains the location of a point. There are no repeat points in X. D contains the finite difference approximation coefficients. D[i] is the coeff in row ii[i], col ni[i] This routine uses least squares/min norm solutions if there are more/fewer points in neighbourhood than are required for FD approximation. Set up is general to allow for future extension of this routine, but currently only the d==2, m=3, k=6 TPS like case is dealt with here. */ int i,j,k,true=1,kk,l,i0,i1,max_nn=0,jj,di,doff; double *M,*Mi,*Vt,*sv, /* matrix mapping derivatives to function values */ x,z; /* first strip out distant neighbours */ z = 10.0; ni_dist_filter(X,n,d,ni,off,&z); /* now find the maximum number of neighbours */ i0 = 0; for (j=0;j<*n;j++) { i1 = off[j]; if (i1-i0>max_nn) max_nn = i1-i0; /* maximum number of neighbours */ i0=i1; } max_nn++; /* self! */ if (max_nn<6) max_nn=6; M = (double *)CALLOC((size_t) 6 * max_nn,sizeof(double)); Mi = (double *)CALLOC((size_t) 6 * max_nn,sizeof(double)); Vt = (double *)CALLOC((size_t) 6 * 6,sizeof(double)); sv = (double *)CALLOC((size_t) 6,sizeof(double)); /* Rprintf("Starting main loop...\n");*/ di = i0 = 0; doff = off[*n-1] + *n; /* total number of neighbours + selves */ for (j=0;j<*n;j++) { /* work through all points */ i1 = off[j]; /* neighbours of i are i0..i1-1 */ k = kk = i1-i0 + 1; /* number of neighbours + self */ if (kk<6) { /* will need to pack M with zero rows */ kk=6; for (i=0;i<6*kk;i++) M[i]=0.0; } l=0; /* row index */ /* NOTE: d= 2 hard coded! */ M[0] = 1.0;for (i=1;i<6;i++) M[i*kk] = 0.0; /* self row */ for (i=i0;i Mg as neighbours approach point i. Now pseudo invert M, to estimate g using g = M^{-}f */ /* call mgcv_svd_full to pseudoinvert M */ i = 6; mgcv_svd_full(M,Vt,sv,&kk,&i); /* Rprintf("%d done svd...\n",i);*/ jj = k; if (jj>6) jj=6; kappa[i] = sv[0]/sv[jj-1]; /* condition number */ for (i=0;isv[0]*1e-10) sv[i] = 1/sv[i]; else sv[i]=0.0; /* if k < kk, need to remove trailing rows of M */ if (k=0;i--) { V0c--;V0s--;V1c--;V1s--;U0c--;U0s--;U1c--;U1s--; L13 = - *V1s;L11 = *V1c; L21 = L23 * *V1s;L23 *= *V1c; L31 = L33 * *V1s;L33 *= *V1c; givens(L11,L31,&c,&s);s = -s; /** Rotation to remove upper element BEFORE it propagates **/ L11 = L11*c - L31*s; L12 =- L11 * *V0s; L11 *= *V0c; Lt = L21 * *V0c + L22 * *V0s; L22 = L22 * *V0c - L21 * *V0s; L21=Lt; X1 = -L11 * *U0s; L11 *= *U0c; L12 = L12 * *U1c + X1 * *U1s; X2 = -L21 * *U0s; L21 *= *U0c; L22 = L22 * *U1c + X2 * *U1s; givens(L11,L21,&c,&s); /** Second rotation removing upper element **/ L11 = L11*c+L21*s; Lt = L12*c+L22*s; L22 = L22*c-L12*s;L12=Lt; diagA[i+2]=L33*L33+L23*L23+L13*L13; if (i!=0) { L33=L22;L23=L12;L22=L11; } } diagA[1]=L22*L22+L12*L12; diagA[0]=L11*L11; for (i=0;i<*n;i++) diagA[i] = 1.0 - diagA[i]; FREE(ub); } void sspl_apply(double *y,double *x,double *w,double *U,double *V,int *n,int *nf,double *tol) { /* Apply the smoothing spline stored in U and V to the data in y, with weights w. The smoothed values are returned in y. x and w are also modified here. nf is length of y and x. n is the number of unique x values. */ int i,k,ok; double *Wy,*U0s,*U0c,*U1s,*U1c, *V0s,*V0c,*V1s,*V1c,*p,*p1,*p2,w2,*xx; if (*nf > *n) { /* deal with duplicates */ xx = (double *)CALLOC((size_t)*nf,sizeof(double)); for (p=x,p1=x + *nf,p2=xx;p=0;i--) { QTz(i,i+2,V1c[i],V1s[i],Wy); QTz(i,i+1,V0c[i],V0s[i],Wy); QTz(i,*n+i,U0c[i],U0s[i],Wy); if (i != *n-3) QTz(i+1,*n+i,U1c[i],U1s[i],Wy); } /* get fitted values... */ for (i=0;i<*n;i++) Wy[i] = y[i] - Wy[i]*w[i]; if (*nf > *n) { /* deal with duplicates */ k=0;ok=1; y[0] = Wy[0]; for (i=1;i<*nf;i++) if (x[k] + *tol < x[i]) { /* distinct */ k++;x[k] = x[i]; y[i] = Wy[k]; } else { /* a duplicate */ y[i] = Wy[k]; } } else { for (i=0;i<*n;i++) y[i] = Wy[i]; } FREE(Wy); } void sspl_mapply(double *y,double *x,double *w,double *U,double *V,int *n,int *nf,double *tol,int *m) { /* apply smoothing spline to the m columns of y */ int i,xw_store=0; double *xx,*ww,*p,*p1,*p2; if (*m > 1 && *nf != *n) xw_store=1; if (xw_store) { /* must store original x and w */ xx = (double *)CALLOC((size_t)*nf,sizeof(double)); ww = (double *)CALLOC((size_t)*nf,sizeof(double)); for (p=xx,p1=xx + *nf,p2=x;p=0;i--) c[i+1]=(z[i]-lb1[i]*c[i+2])/lb[i]; b[*n-1]=d[*n-1]=0; for (i=0;i<*n-1;i++) { d[i]=(c[i+1]-c[i])/(3*h[i]); b[i]=(a[i+1]-a[i])/h[i]-c[i]*h[i]-d[i]*h[i]*h[i]; } FREE(GTA);FREE(z);FREE(h); } mgcv/src/init.c0000644000177400001440000000616313046054035013304 0ustar murdochusers/* Symbol registration initialization: original provided by Brian Ripley. Anything called from R should be registered here (and declared in mgcv.h). (See also NAMESPACE:1) */ #include #include #include #include "mgcv.h" R_CallMethodDef CallMethods[] = { {"mgcv_pmmult2", (DL_FUNC) &mgcv_pmmult2,5}, {"mgcv_Rpiqr", (DL_FUNC) &mgcv_Rpiqr,5}, { "mgcv_tmm",(DL_FUNC)&mgcv_tmm,5}, { "mgcv_Rpbsi",(DL_FUNC)&mgcv_Rpbsi,2}, { "mgcv_RPPt",(DL_FUNC)&mgcv_RPPt,3}, { "mgcv_Rpchol",(DL_FUNC)&mgcv_Rpchol,4}, { "mgcv_Rpforwardsolve",(DL_FUNC)&mgcv_Rpforwardsolve,3}, { "mgcv_Rpcross",(DL_FUNC)&mgcv_Rpcross,3}, {NULL, NULL, 0} }; R_CMethodDef CEntries[] = { {"band_chol",(DL_FUNC) band_chol,4}, {"tri_chol",(DL_FUNC) tri_chol,4}, {"diagXVXt", (DL_FUNC) &diagXVXt,16}, {"XWXd", (DL_FUNC) &XWXd,18}, {"XWyd", (DL_FUNC) &XWyd,18}, {"Xbd", (DL_FUNC) &Xbd,15}, {"vcorr", (DL_FUNC) &vcorr, 5}, {"dchol", (DL_FUNC) &dchol, 4}, {"mgcv_omp", (DL_FUNC) &mgcv_omp, 1}, {"coxpred", (DL_FUNC) &coxpred, 13}, {"coxpp", (DL_FUNC) &coxpp, 10}, {"coxlpl", (DL_FUNC) &coxlpl, 17}, {"mvn_ll", (DL_FUNC) &mvn_ll,15}, {"RMonoCon", (DL_FUNC) &RMonoCon, 7}, {"RuniqueCombs", (DL_FUNC) &RuniqueCombs, 4}, {"RPCLS", (DL_FUNC) &RPCLS, 14}, {"construct_tprs", (DL_FUNC) &construct_tprs, 13}, {"crspl", (DL_FUNC) &crspl,8}, {"predict_tprs", (DL_FUNC) &predict_tprs, 12}, {"MinimumSeparation", (DL_FUNC) &MinimumSeparation, 6}, {"magic", (DL_FUNC) &magic, 19}, {"mgcv_mmult", (DL_FUNC) &mgcv_mmult,8}, {"mgcv_pmmult", (DL_FUNC) &mgcv_pmmult,9}, {"gdi1",(DL_FUNC) &gdi1,49}, {"gdi2",(DL_FUNC) &gdi2,48}, {"R_cond",(DL_FUNC) &R_cond,5} , {"pls_fit1",(DL_FUNC)&pls_fit1,14}, {"tweedious",(DL_FUNC)&tweedious,13}, {"tweedious2",(DL_FUNC)&tweedious2,13}, {"psum",(DL_FUNC)&psum,4}, {"get_detS2",(DL_FUNC)&get_detS2,12}, {"get_stableS",(DL_FUNC)&get_stableS,14}, {"mgcv_tri_diag",(DL_FUNC)&mgcv_tri_diag,3}, {"mgcv_td_qy",(DL_FUNC)&mgcv_td_qy,7}, {"mgcv_symeig",(DL_FUNC)&mgcv_symeig,6}, {"read_mat",(DL_FUNC)&read_mat,4}, {"rwMatrix",(DL_FUNC)&rwMatrix,8}, {"in_out",(DL_FUNC)&in_out,8}, {"Rlanczos",(DL_FUNC)&Rlanczos,8}, {"rksos",(DL_FUNC)&rksos,3}, {"gen_tps_poly_powers",(DL_FUNC)&gen_tps_poly_powers,4}, {"k_nn",(DL_FUNC)&k_nn,8}, {"Rkdtree",(DL_FUNC)&Rkdtree,5}, {"Rkdnearest",(DL_FUNC)&Rkdnearest,9}, {"Rkradius",(DL_FUNC)&Rkradius,9}, {"sspl_construct",(DL_FUNC)&sspl_construct,9}, {"sspl_mapply",(DL_FUNC)&sspl_mapply,9}, {"tri2nei",(DL_FUNC)&tri2nei,5}, {"nei_penalty",(DL_FUNC)&nei_penalty, 10}, {"boundary",(DL_FUNC)&boundary, 14}, {"pde_coeffs",(DL_FUNC)&pde_coeffs, 9}, {"gridder",(DL_FUNC)&gridder, 13}, {"row_block_reorder",(DL_FUNC)&row_block_reorder,5}, {"mgcv_pqr",(DL_FUNC)&mgcv_pqr,6}, {"getRpqr",(DL_FUNC)&getRpqr,6}, {"mgcv_pqrqy",(DL_FUNC)&mgcv_pqrqy,8}, {NULL, NULL, 0} }; void R_init_mgcv(DllInfo *dll) { R_registerRoutines(dll, CEntries, CallMethods, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } mgcv/src/coxph.c0000644000177400001440000003635213046054035013465 0ustar murdochusers/* The Cox Proportional Hazard model for survival data, for mgcv. (c) Simon N. Wood 2013-14 See for example, Hastie and Tibshirani (1990) for the log partial likelihood (Peto's, 1972, approximation for ties). For details of hazard estimation see... Klein, J.P and Moeschberger, M.L. (2003) Survival Analysis: Techniques for Censored and Truncated Data (2nd ed.) Springer */ #include #include #include #include #include "mgcv.h" void coxpred(double *X,double *t,double *beta,double *Vb,double *a,double *h,double *q, double *tr,int *n,int *p, int *nt,double *s,double *se) { /* Function to predict the survivor function for the new data in X (n by p), t, given fit results in a, h, q, Vb, and original event times tr (length nt). The new data are in descending order on entry, as is tr. On exit n - vectors s and se contain the estimated survival function and its se. */ double eta,*p1,*p2,*p3,*v,*pv,*pa,x,vVv,hi,exp_eta; int ir=0,i=0; v = (double *)CALLOC((size_t)*p,sizeof(double)); for (i=0;i<*n;i++) { /* loop through new data */ while (ir < *nt && t[i]0) for (i=0;i<*n;i++) gamma[i] = exp(eta[i]); else for (p1=gamma,p2=p1 + *n;p10) { gamma_p[j] = gamma_p[j-1]; gamma_np[j] = gamma_np[j-1]; /* copy b^+_{j-1}, bj1, into b^+_j, bj */ for (p1=bj,p2=p1 + *p;p1=0;j--) { /* back recursion, forwards in time */ y = dc[j]; x = y/gamma_p[j]; y/=gamma_np[j]; h[j] = h[j+1] + x; km[j] = km[j+1] + y; /* kaplan meier hazard estimate */ x /= gamma_p[j]; q[j] = q[j+1] + x; /* now accumulate the a vectors into X for return */ i = j * *p; //for (aj=X+i,aj1=p1=aj+ *p,p2=b+i;aj=0) { b_p = (double *)CALLOC((size_t)*p,sizeof(double)); A_p = (double *)CALLOC((size_t)(*p * *p),sizeof(double)); } /* form exponential of l.p. */ for (i=0;i<*n;i++) gamma[i] = exp(eta[i]); if (*deriv>0) { /* prepare for first derivatives */ /* Get basic first derivatives given d1beta */ d1eta = (double *)CALLOC((size_t)(*n * *n_sp),sizeof(double)); mgcv_mmult(d1eta,X,d1beta,&tB,&tC,n,n_sp,p); p1=d1gamma = (double *)CALLOC((size_t)(*n * *n_sp),sizeof(double)); p2=d1eta; for (j=0;j<*n_sp;j++) for (i=0;i<*n;i++) { *p1 = *p2 * gamma[i]; p1++; p2++; } /* accumulation storage */ d1gamma_p = (double *)CALLOC((size_t)*n_sp,sizeof(double)); d1b_p = (double *)CALLOC((size_t)(*n_sp * *p),sizeof(double)); } if (*deriv>2) { /* prepare for second derivative calculations */ /* Basic second derivative derived from d2beta */ nhh = *n_sp * (*n_sp+1) / 2; /* elements in `half hessian' */ d2eta = (double *)CALLOC((size_t)(*n * nhh),sizeof(double)); mgcv_mmult(d2eta,X,d2beta,&tB,&tC,n,&nhh,p); p1=d2gamma = (double *)CALLOC((size_t)(*n * nhh),sizeof(double)); p2=d2eta; for (j=0;j<*n_sp;j++) { /* create d2gamma */ for (k=j;k<*n_sp;k++) { p3 = d1eta + j * *n; p4 = d1eta + k * *n; for (i=0;i<*n;i++) { *p1 = gamma[i] * (*p2 + *p3 * *p4); p1++;p2++;p3++;p4++; } } } /* end of d2gamma loop */ /* accumulation storage */ d2gamma_p = (double *)CALLOC((size_t) nhh,sizeof(double)); d2b_p = (double *)CALLOC((size_t)( nhh * *p),sizeof(double)); } if (*deriv>0) { /* Derivatives of H are required */ /* create storage for accumulating derivatives */ d1A_p = (double *)CALLOC((size_t)(*n_sp * *p * *p),sizeof(double)); /* clear incoming storage */ for (j = *n_sp * *p * *p,k=0;k2) { d2ldA_p = (double *)CALLOC((size_t)(nhh * *p),sizeof(double)); for (j = nhh * *p,k=0;k= 0) { for (k=0;k<*p;k++) b_p[k] += gamma[i]*X[i + *n * k]; if (d[i]==1) for (k=0;k<*p;k++) g[k] += X[i + *n * k]; /* and second derivatives */ for (k = 0;k < *p;k++) for (m = k;m < *p ;m++) A_p[k + *p *m] += gamma[i]*X[i + *n * k] * X[i + *n * m]; } /* derivatives w.r.t. smoothing parameters */ if (*deriv >0 ) { /* first derivative stuff only */ for (k=0;k<*n_sp;k++) d1gamma_p[k] += d1gamma[i + *n * k]; for (m=0;m<*n_sp;m++) { xx = d1gamma[i + *n * m]; for (k=0;k<*p;k++) d1b_p[k + *p * m] += xx * X[i + *n * k]; } } /* end of first derivative accumulation */ if (*deriv>2) { /* second derivative accumulation */ off = 0; for (m=0;m<*n_sp;m++) for (k=m;k<*n_sp;k++) { /* second derivates loop */ d2gamma_p[off] += d2gamma[i+ off * *n]; for (l=0;l<*p;l++) d2b_p[l + off * *p] += d2gamma[i+ off * *n] * X[i + *n * l]; off++; } /* end k-loop */ } if (*deriv>0) { /* H derivatives needed */ for (m=0;m<*n_sp;m++) { /* First derivatives of A_p */ xx = d1gamma[i + *n * m]; for (k = 0;k < *p;k++) for (l = k;l < *p ;l++) d1A_p[k + *p * l + m * *p * *p] += xx * X[i + *n * k] * X[i + *n * l]; } if (*deriv>2) { off = 0; for (m=0;m<*n_sp;m++) for (k=m;k<*n_sp;k++) { /* second derivates of leading diagonal of A_p loop */ for (l=0;l<*p;l++) d2ldA_p[l + off * *p] += d2gamma[i+ off * *n] * X[i + *n * l] * X[ i + *n *l]; off++; } /* end m/k -loop */ } } i++; } /* finished getting this event's information */ lpl += eta_sum - dr * log(gamma_p); if (*deriv>=0) { for (k=0;k<*p;k++) g[k] += - dr/gamma_p * b_p[k]; for (k = 0;k < *p;k++) for (m = k;m < *p ;m++) H[k + *p * m] += - dr * A_p[k + *p *m] /gamma_p + dr * b_p[k]*b_p[m]/(gamma_p*gamma_p); } if (*deriv>0) { /* need derivatives of H */ for (m=0;m<*n_sp;m++) { /* first derivatives of H */ xx0 =dr/gamma_p; xx = d1gamma_p[m]*xx0/gamma_p; xx1 = xx0/gamma_p; xx2 = xx1*2*d1gamma_p[m]/gamma_p; for (k = 0;k < *p;k++) for (l = k;l < *p ;l++) { off = k + *p * l + m * *p * *p; d1H[off] += xx1 * (d1b_p[k + *p *m] * b_p[l] + b_p[k] * d1b_p[l + *p *m]) - xx2 * b_p[k] * b_p[l] + xx * A_p[k + *p * l] - xx0 * d1A_p[off]; } } /* m-loop end */ if (*deriv>2) { xx = dr/gamma_p; xx0 = xx/gamma_p; /* dr/gamma_p^2 */ xx1 = xx0/gamma_p; /* dr/gamma_p^3 */ xx2 = xx1/gamma_p; off = 0; for (m=0;m<*n_sp;m++) { xx3 = -2*xx1*d1gamma_p[m]; for (k=m;k<*n_sp;k++) { /* second derivates of leading diagonal of H */ for (l=0;l<*p;l++) { d2H[l + off * *p] += xx3 * (A_p[l + *p *l] * d1gamma_p[k] + 2 * d1b_p[l + *p * k] * b_p[l]) + xx0 * (d1A_p[l + l * *p + m * *p * *p] * d1gamma_p[k] + A_p[l + *p * l] * d2gamma_p[off] + d2b_p[l + off * *p] * b_p[l] + 2 * d1b_p[l + *p * k] * d1b_p[ l + *p * m] + b_p[l] * d2b_p[l + off * *p]) + xx0 * d1gamma_p[m] * d1A_p[l + l * *p + k * *p * *p] - xx * d2ldA_p[l + off * *p] + 6 * xx2 * d1gamma_p[m] * b_p[l] * b_p[l] * d1gamma_p[k] - 2 * xx1 * (2*d1b_p[l + *p * m] * b_p[l] * d1gamma_p[k] + b_p[l]*b_p[l]*d2gamma_p[off]); } off++; } /* end k -loop */ } /* end m - loop */ } /* end if (*deriv>2) */ } /* end of H derivatives */ } /* end of j loop (work back in time) */ for (k=0;k<*p;k++) for (m=0;m1) for (m=0;m<*n_sp;m++) { off = *p * *p * m; for (k = 0;k < *p;k++) for (l = 0;l < k ;l++) d1H[k + *p * l + off] = d1H[l + *p * k + off]; } if (*deriv>=0) { FREE(A_p);FREE(b_p);} FREE(gamma); if (*deriv > 0) { /* clear up first derivative storage */ FREE(d1eta);FREE(d1gamma); FREE(d1gamma_p);FREE(d1b_p); FREE(d1A_p); } if (*deriv > 2) { /* clear up second derivative storage */ FREE(d2eta);FREE(d2gamma); FREE(d2gamma_p);FREE(d2b_p); FREE(d2ldA_p); } *lp = lpl; } /* end coxlpl */ mgcv/src/mat.c0000755000177400001440000032561013046054035013126 0ustar murdochusers/* Convenient C wrappers for calling LAPACK and LINPACK + other matrix routines using same packing format.... See R-x/include/R_ext/Lapack.h... parallel support (using openMP) offered by... * mgcv_pqr - parallel QR based on row blocking ok for few cores and n>>p but somewhat involved. Advantage is that just one thread used per core, so threading overhead minimal. Disadvantage is that an extra single thread QR is used to combine everything. * mgcv_piqr - pivoted QR that simply parallelizes the 'householder-to-unfinished-cols' step. Storage exactly as standard LAPACK pivoted QR. * mgcv_Rpiqr - wrapper for above for use via .call * mgcv_pmmult - parallel matrix multiplication. * mgcv_Rpbsi - parallel inversion of upper triangular matrix. * Rlanczos - parallel on leading order cost step (but note that standard BLAS seems to use Strassen for square matrices.) */ #include "mgcv.h" #include #include #include #include #include /* only needed for pivoted chol - see note in mgcv_chol */ #include #include #ifdef OPENMP_ON #include #endif /*#include */ void mgcv_omp(int *a) { #ifdef OPENMP_ON *a=1; #else *a=0; #endif } void dump_mat(double *M,int *r,int*c,const char *path) { /* dump r by c matrix M to path - intended for debugging use only */ FILE *mf; mf = fopen(path,"wb"); if (mf == NULL) { Rprintf("\nFailed to open file\n"); return; } fwrite(r,sizeof(int),1,mf); fwrite(c,sizeof(int),1,mf); fwrite(M,sizeof(double),*r * *c,mf); fclose(mf); } void read_mat(double *M,int *r,int*c,char *path) { /* routine to facilitate reading dumped matrices back into R - debugging use only e.g. (actually path doesn't work here) oo <- .C("read_mat",as.double(0),r=as.integer(0),c=as.integer(0), as.character("/home/sw283/tmp/badmat.dat"),PACKAGE="mgcv") oo <- .C("read_mat",M=as.double(rep(0,oo$c*oo$r)),r=as.integer(oo$r),c=as.integer(oo$c), as.character("/home/sw283/tmp/badmat.dat"),PACKAGE="mgcv") M <- matrix(oo$M,oo$r,oo$c) */ size_t j; FILE *mf; mf = fopen("/home/sw283/tmp/badmat.dat","rb"); if (mf == NULL) { Rprintf("\nFailed to open file\n"); return; } if (*r < 1) { /* dimension query */ j=fread(r,sizeof(int),1,mf); j=fread(c,sizeof(int),1,mf); } else { j=fread(r,sizeof(int),1,mf); j=fread(c,sizeof(int),1,mf); j=fread(M,sizeof(double),*r * *c,mf); if (j!= *r * *c) Rprintf("\nfile dim problem\n"); } fclose(mf); } void mgcv_tensor_mm(double *X,double *T,int *d,int *m,int *n) { /* Code for efficient production of row tensor product model matrices. X contains rows of matrices to be producted. Contains m matrices, d[i] is number of columns in ith matrix (which are stored in ascending order). Each column has n rows. T is the target matrix, with n rows and \prod_i d[i] columns. */ ptrdiff_t start, i,j,k, tp=1, xp=0,pd; double *Xj,*Xj1,*Xk, *Tk,*p,*p1,*p2; /*Rprintf("m = %d n = %d d = ",*m,*n); for (i=0;i<*m;i++) Rprintf(" %d,",d[i]);*/ /* compute total columns in X, xp, and total columns in T, tp ... */ for (i=0;i<*m;i++) { xp += d[i];tp *= d[i];} Xk = X + (xp-d[*m-1]) * *n; /* start of last matrix in X */ Tk = T + (tp-d[*m-1]) * *n; /* start of last (filled) block in T */ /* initialize by putting final matrix in X into end block of T... */ p = Xk;p1 = Xk + *n * (ptrdiff_t) d[*m-1];p2 = Tk; for (;p=0;i--) { /* work down through matrices stored in X */ Xk -= *n * (ptrdiff_t) d[i]; /* start of ith X matrix */ Xj = Xk; start = tp - pd * d[i]; /* start column of target block in T */ p = T + start * *n; /* start location in T */ for (j=0;j m || nt < 1) nt = m; /* no point in more threads than m */ /*Rprintf("\n open mp %d cores, %d used\n",m,nt);*/ #else /*Rprintf("\n no openmp\n");*/ nt = 1; /* no openMP support - turn off threading */ #endif mgcv_pmmult(A,B,C,&Bt,&Ct,&r,&col,&n,&nt); UNPROTECT(1); return(a); } /* mgcv_pmmult2 */ int mgcv_bchol(double *A,int *piv,int *n,int *nt,int *nb) { /* Lucas (2004) "LAPACK-Style Codes for Level 2 and 3 Pivoted Cholesky Factorizations" block pivoted Choleski algorithm 5.1. Note some misprints in paper, noted below. nb is block size, nt is number of threads, A is symmetric +ve semi definite matrix and piv is pivot sequence. */ int i,j,k,l,q,r=-1,*pk,*pq,jb,n1,m,N,*a,b; double tol=0.0,*dots,*pd,*p1,*Aj,*Aq0,*Aj0,*Aj1,*Ajn,*Ail,xmax,x,*Aq,*Ajj,*Aend; dots = (double *)CALLOC((size_t) *n,sizeof(double)); for (pk = piv,i=0;i < *n;pk++,i++) *pk = i; /* initialize pivot record */ jb = *nb; /* block size, allowing final to be smaller */ n1 = *n + 1; Ajn = A; m = *nt;if (m<1) m=1;if (m>*n) m = *n; /* threads to use */ a = (int *)CALLOC((size_t) (*nt+1),sizeof(int)); /* thread block cut points */ a[m] = *n; for (k=0;k<*n;k+= *nb) { if (*n - k < jb) jb = *n - k ; /* end block */ for (pd = dots + k,p1 = dots + *n;pdk) for (;pdxmax) { xmax = x;q=l;} /* find the pivot */ } if (j==0) tol = *n * xmax * DOUBLE_EPS; Aq = A + *n * q + q; // Rprintf("\n n = %d k = %d j = %d q = %d, A[q,q] = %g ",*n,k,j,q,*Aq); if (*Aq - dots[q] k&&j < *n) { /* Lucas (2004) has '1' in place of 'k' */ Aj = Ajn + *n; Aq = Aj + k; /* Lucas (2004) has '1' in place of 'k' */ Aj += j; Aj1 = Ajn + k; /* Lucas (2004) has '1' in place of 'k' */ for (;Aj 0) break; /* now the main work - updating the trailing factor... */ if (k + jb < *n) { /* create the m work blocks for this... */ N = *n - j; /* block to be processed is N by N */ if (m > N) { m = N;a[m] = *n; } /* number of threads to use must be <= r */ *a = j; /* start of first block */ x = (double) N;x = x*x / m; /* compute approximate optimal split... */ for (i=1;i < m;i++) a[i] = round(N - sqrt(x*(m-i)))+j; for (i=1;i <= m;i++) { /* don't allow zero width blocks */ if (a[i]<=a[i-1]) a[i] = a[i-1]+1; } #ifdef OPENMP_ON #pragma omp parallel private(b,i,l,Aj,Aend,Aq,Aj1,Ail,Aj0,Aq0) num_threads(m) #endif { /* start parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (b=0;b *n) *nt = *n; m = *nt; a = (int *)CALLOC((size_t) (*nt+1),sizeof(int)); a[0] = 0;a[m] = *n; /* ... initialize column block splitting array */ r = 0;n1 = *n + 1; for (pk = piv,i=0;i < *n;pk++,i++) *pk = i; /* initialize pivot record */ for (pk=piv,k=0;k< *n;k++,pk++) { kn = k * *n; /* find largest element of diag(A), from k onwards */ Ak = A + kn + k;x = *Ak;q=k;Ak+=n1; for (i=k+1;i < *n;i++,Ak+=n1) if (*Ak>x) {x = *Ak;q=i;} qn = q * *n; if (k==0) thresh = *n * x * DOUBLE_EPS; if (x>thresh) { /* A[q,q] =x > 0 */ r++; /* piv[k] <-> piv[q] */ pq = piv + q;i = *pq; *pq = *pk;*pk = i; /* A[k,k] <-> A[q,q] */ Ak = A + kn + k;Aq = A + qn + q; x = *Ak;*Ak = *Aq;*Aq = x; /* A[k+1:q-1,k] <-> A[q,k+1:q-1] */ Ak++; Aend = Aq; Aq = A + q + kn + *n; for (;Aq A[k,1:k-1] */ Ak = A + k;Aend=Ak + kn;Aq = A + q; for (;Ak < Aend;Ak += *n,Aq += *n) {x = *Aq;*Aq = *Ak;*Ak = x;} /* A[q+1:n,k] <-> A[q+1:n,q] */ Ak = A + kn; Aq = A + qn+q+1;Aend = Ak + *n;Ak+=q+1; for (;Ak N) { m = N;a[m] = *n; } /* number of threads to use must be <= r */ (*a)++; x = (double) N;x = x*x / m; /* compute approximate optimal split... */ for (i=1;i < m;i++) a[i] = round(N - sqrt(x*(m-i)))+k+1; for (i=1;i <= m;i++) { /* don't allow zero width blocks */ if (a[i]<=a[i-1]) a[i] = a[i-1]+1; } /* check load balance... */ // for (i=0;inb0) nb = nb0;/* attempted block size */ for (a0=F,a1=F+nb*pb;a0x) { x = *a0;q=i; } /* find pivot col q */ if (q!=k) { /* then pivot */ i = piv[q];piv[q]=piv[k];piv[k] = i; x = cn[q];cn[q]=cn[k];cn[k] = x; x = icn[q];icn[q]=icn[k];icn[k] = x; Aq = A + q * (ptrdiff_t) n;Ak = A + k * (ptrdiff_t) n;a1 = Aq + n; for (;Aq A[:,q] */ Aq = F + q - jb;Ak = F + j;a1 = F + nb * (ptrdiff_t) pb; for (;Aq F[j,:] */ } /* update the pivot column: A[k:n-1,k] -= A[k:n-1,jb:k-1]F[j,0:j-1]' using BLAS call to DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) y := alpha*A*x + beta*y (or A' if TRANS='T')*/ m = n-k;Ak = A + (ptrdiff_t)n * k + k; if (j) { q = m ; /* total number of rows to split between threads */ rt = q/nt;if (rt*nt < q) rt++; /* rows per thread */ nth = nt; while (nth>1&&(nth-1)*rt>q) nth--; /* reduce number of threads if some empty */ kb[0] = k; /* starting row */ for (i=0;i1&&(nth-1)*rt>q) nth--; /* reduce number of threads if some empty */ kb[0] = j+1; for (i=0;i0) { q = j ; /* total number of rows to split between threads */ rt = q/nt;if (rt*nt < q) rt++; /* rows per thread */ nth = nt; while (nth>1&&(nth-1)*rt>q) nth--; /* reduce number of threads if some empty */ kb[0] = jb; /* starting row */ for (i=0;i1&&(nth-1)*rt>q) nth--; /* reduce number of threads if some empty */ kb[0] = 0; /* starting row */ for (i=0;i1&&(nth-1)*rt>q) nth--; /* reduce number of threads if some empty */ kb[0] = j+1; /* starting col in F, and jb to this to get start in A */ for (i=0;i1&&(nth-1)*rt>m) nth--; /* reduce number of threads if some empty */ kb[0] = k+1; for (i=0;itau) {tau=xx;k=i;} } r = -1; nh = n; /* householder length */ while (tau > 0) { r++; i=piv[r]; piv[r] = piv[k];piv[k] = i; /* swap r with k O(n) */ xx = c[r];c[r] = c[k];c[k] = xx; for (p0 = x + n * r, p1 = x + (ptrdiff_t)n * k,p2 = p0 + n;p0tau) { tau = c[i]; k=i; } } if (r==n-1) tau = 0.0; } /* end while (tau > 0) */ FREE(c); FREE(work); #ifdef OMP_REPORT Rprintf("done\n"); #endif return(r+1); } /* mgcv_piqr */ SEXP mgcv_Rpiqr(SEXP X, SEXP BETA,SEXP PIV,SEXP NT, SEXP NB) { /* routine to QR decompose N by P matrix X with pivoting. Work is done by bpqr. Designed for use with .call rather than .C Return object is as 'qr' in R. */ int n,p,nt,*piv,r,*rrp,nb; double *x,*beta; SEXP rr; nt = asInteger(NT);nb = asInteger(NB); n = nrows(X); p = ncols(X); x = REAL(X);beta = REAL(BETA); piv = INTEGER(PIV); r = bpqr(x,n,p,beta,piv,nb,nt); /* block version */ /* should return rank (r+1) */ rr = PROTECT(allocVector(INTSXP, 1)); rrp = INTEGER(rr); *rrp = r; UNPROTECT(1); return(rr); } /* mgcv_piqr */ void mgcv_pmmult(double *A,double *B,double *C,int *bt,int *ct,int *r,int *c,int *n,int *nt) { /* Forms r by c product, A, of B and C, transposing each according to bt and ct. n is the common dimension of the two matrices, which are stored in R default column order form. This version uses openMP parallelization. nt is number of threads to use. The strategy is rather simple, and this routine is really only useful when B and C have numbers of rows and columns somewhat higher than the number of threads. Assumes number of threads already set on entry and nt reset to 1 if no openMP support. BLAS version A is c (result), B is a, C is b, bt is transa ct is transb r is m, c is n, n is k. Does nothing if r,c or n <= zero. */ char transa='N',transb='N'; int lda,ldb,ldc,cpt,cpf,c1,i,nth; double alpha=1.0,beta=0.0; if (*r<=0||*c<=0||*n<=0) return; #ifdef OMP_REPORT Rprintf("mgcv_pmmult..."); #endif if (B==C) { /* this is serial, unfortunately. note case must be caught as B can be re-ordered! */ if (*bt&&(!*ct)&&(*r==*c)) { getXtX(A,B,n,r);return;} else if (*ct&&(!*bt)&&(*r==*c)) { getXXt(A,B,c,n);return;} } #ifndef OPENMP_ON *nt = 1; #endif if (*nt == 1) { mgcv_mmult(A,B,C,bt,ct,r,c,n); /* use single thread version */ return; } if (*bt) { /* so B is n by r */ transa = 'T'; lda = *n; } else lda = *r; /* B is r by n */ if (*ct) { /* C is c by n */ transb = 'T'; ldb = *c; } else ldb = *n; /* C is n by c */ ldc = *r; if (*ct) { /* have to split on B, which involves re-ordering */ if (*bt) { /* B'C': can split on columns of n by r matrix B, but (r by c) A then needs re-ordering */ cpt = *r / *nt; /* cols per thread */ if (cpt * *nt < *r) cpt++; nth = *r/cpt; if (nth * cpt < *r) nth++; cpf = *r - cpt * (nth-1); /* columns on final block */ #ifdef OPENMP_ON #pragma omp parallel private(i,c1) num_threads(nth) #endif { /* open parallel section */ //c1 = cpt; #ifdef OPENMP_ON #pragma omp for #endif for (i=0;i0) F77_CALL(dgemm)(&transa,&transb,&c1,c,n, &alpha, B + i * (ptrdiff_t) cpt * *n, n ,C, c,&beta, A + i * (ptrdiff_t) cpt * *c, &c1); } } /* parallel section ends */ /* now re-order the r by c matrix A, which currently contains the sequential blocks corresponding to each cpt rows of A */ row_block_reorder(A,r,c,&cpt,bt); /* bt used here for 'reverse' as it contains a 1 */ } else { /* BC':worst case - have to re-order r by n mat B and then reverse re-ordering of B and A at end */ cpt = *r / *nt; /* cols per thread */ if (cpt * *nt < *r) cpt++; nth = *r/cpt; if (nth * cpt < *r) nth++; cpf = *r - cpt * (nth-1); /* columns on final block */ /* re-order cpt-row blocks of B into sequential cpt by n matrices (in B) */ row_block_reorder(B,r,n,&cpt,bt); /* bt contains a zero - forward mode here */ #ifdef OPENMP_ON #pragma omp parallel private(i,c1) num_threads(nth) #endif { /* open parallel section */ //c1 = cpt; #ifdef OPENMP_ON #pragma omp for #endif for (i=0;i0) F77_CALL(dgemm)(&transa,&transb,&c1,c,n, &alpha, B + i * (ptrdiff_t) cpt * *n, &c1,C,c,&beta, A + i * (ptrdiff_t) cpt * *c, &c1); } } /* parallel ends */ /* now reverse the re-ordering */ row_block_reorder(B,r,n,&cpt,ct); row_block_reorder(A,r,c,&cpt,ct); } } else { /* can split on columns of n by c matrix C, which avoids re-ordering */ cpt = *c / *nt; /* cols per thread */ if (cpt * *nt < *c) cpt++; nth = *c/cpt; if (nth * cpt < *c) nth++; cpf = *c - cpt * (nth-1); /* columns on final block */ #ifdef OPENMP_ON #pragma omp parallel private(i,c1) num_threads(*nt) #endif { /* open parallel section */ //c1 = cpt; #ifdef OPENMP_ON #pragma omp for #endif for (i=0;i< nth;i++) { if (i == nth-1) c1 = cpf;else c1=cpt; /* how many columns in this block */ if (c1>0) F77_CALL(dgemm)(&transa,&transb,r,&c1,n, &alpha, B, &lda,C + i * (ptrdiff_t) *n * cpt, &ldb,&beta, A + i * (ptrdiff_t) *r * cpt, &ldc); } } /* end parallel */ } #ifdef OMP_REPORT Rprintf("done\n"); #endif } /* end mgcv_pmmult */ void pcrossprod(double *B, double *A,int *R, int *C,int *nt,int *nb) { /* B=A'A if t==0. A is R by C. nb^2 is the target number of elements in a block. nt is the number of threads to use. B is C by C. 30/4 memorial edition */ int M,N,nf,nrf,kmax,kk,i,r,c,k,bn,an,cn; ptrdiff_t as,bs,cs; char uplo = 'U',trans='T',ntrans='N'; double alpha=1.0,beta=1.0; M = ceil(((double) *C)/ *nb); N = ceil(((double) *R)/ *nb); if (M==1) { /* perform single threaded crossprod */ beta = 0.0; F77_CALL(dsyrk)(&uplo,&trans,C,R,&alpha,A,R,&beta,B,C); } else { nf = *C - (M-1) * *nb; /* cols in last col block of A */ nrf = *R - (N-1) * *nb; /* rows in last row block of A */ kmax = (M+1)*M/2; /* number of blocks in upper triangle */ #ifdef OPENMP_ON #pragma omp parallel for private(kk,i,r,c,bn,bs,k,as,an,beta,cs,cn) num_threads(*nt) #endif for (kk=0;kk= M-r) { i -= M - r; r++;}; c = r + i; /* convert kk to row/col */ if (r==M-1) bn = nf; else bn = *nb; /* (row) B block size */ bs = r * (ptrdiff_t) *nb; /* (row) B block start */ if (c==r) { /* diagonal block */ for (k=0;k 0) *XtWX = xx; for (i=0;i< *c;i++) for (j=0;j0) { /* R is transposed */ for (i=0;i<*p;i++) { for (p0=Vi,k=0;k<*M;k++) { /* Vi is i by M */ p1 = dR + k * *p * *p + i * *p; /* start of col i of kth dR */ p2 = p1 + i + 1; /* first zero in col i of kth dR */ for (;p1i) dR[k] = (dA[k] - x - R[k]*dR[i + i * *p])/R[i + i * *p]; else dR[k] = (dA[k] - x)*.5/R[i + i * *p]; } } /* dchol */ void mgcv_chol(double *a,int *pivot,int *n,int *rank) /* a stored in column order, this routine finds the pivoted choleski decomposition of matrix a library(mgcv) X<-matrix(rnorm(16),4,4);D<-X%*%t(X) rank<-0 er<-.C("mgcv_chol",as.double(D),as.integer(rep(0,4)),as.integer(4),as.integer(rank)) rD<-matrix(er[[1]],4,4);piv<-er[[2]] chol(D,pivot=TRUE);rD;piv n<-length(piv);ind<-1:n; ind[piv]<-1:n rD<-rD[,ind] L<-mroot(D) D;t(rD)%*%rD;L%*%t(L) NOTE: This uses LINPACK - dpstf2.f is LAPACK version, but not in R headers yet! */ { double *work,*p1,*p2,*p; int piv=1; work=(double *)CALLOC((size_t) *n,sizeof(double)); F77_CALL(dchdc)(a,n,n,work,pivot,&piv,rank); /* zero stuff below the leading diagonal */ for (p2=a+ *n,p1=a+1;p20.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); /* actual call */ F77_CALL(dgesvd)(&jobu,&jobvt, r, c, x, &lda, d, u, &ldu, vt,&ldvt, work, &lwork, &info); FREE(work); } void mgcv_svd_full(double *x,double *vt,double *d,int *r,int *c) /* call LA_PACK svd routine to form x=UDV'. U returned in x. V' returned in vt. assumed r >= c. U is r by c. D is length c. V is c by c. # Here is R test code..... library(mgcv) n<-4;q<-3 X<-matrix(rnorm(n*q),n,q) um<-.C("mgcv_svd_full",as.double(X),double(q*q),double(q),as.integer(n),as.integer(q), PACKAGE="mgcv") er<-La.svd(X) matrix(um[[1]],n,q);er$u um[[3]];er$d matrix(um[[2]],q,q);er$v */ { const char jobu='O',jobvt='A'; int lda,ldu,ldvt,lwork; int info; double work1,*work,*u=NULL; ldu=lda= *r;ldvt = *c; lwork=-1; /* workspace query */ F77_CALL(dgesvd)(&jobu,&jobvt, r, c, x, &lda, d, u, &ldu, vt,&ldvt, &work1, &lwork, &info); lwork=(int)floor(work1); if (work1-lwork>0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); /* actual call */ F77_CALL(dgesvd)(&jobu,&jobvt, r, c, x, &lda, d, u, &ldu, vt,&ldvt, work, &lwork, &info); FREE(work); } void mgcv_td_qy(double *S,double *tau,int *m,int *n, double *B,int *left,int *transpose) /* Multiplies m by n matrix B by orthogonal matrix returned from mgcv_tri_diag and stored in S, tau. B is overwritten with result. Note that this is a bit inefficient if really only a few rotations matter! Calls LAPACK routine dormtr */ { char trans='N',side='R',uplo='U'; int nq,lwork=-1,info; double *work,work1; if (*left) { side = 'L';nq = *m;} else nq = *n; if (*transpose) trans = 'T'; /* workspace query ... */ F77_CALL(dormtr)(&side,&uplo,&trans,m,n,S,&nq,tau,B,m,&work1,&lwork,&info); lwork=(int)floor(work1);if (work1-lwork>0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); /* actual call ... */ F77_CALL(dormtr)(&side,&uplo,&trans,m,n,S,&nq,tau,B,m,work,&lwork,&info); FREE(work); } void tri_chol(double *ld,double *sd,int *n,int *info) { /* compute LDL' decomposition of n by n symm tridiagonal matrix with leading diagonal ld and sub/sup diagonals sd. Returns D in ld and sub-diagonal of L in sd (leading diagonal of L is all ones). info is 0 for success, -k if kth argument illegal and k0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); /* Actual call... */ F77_CALL(dsytrd)(&uplo,n,S,n,d,e,tau,work,&lwork,&info); FREE(work);FREE(d);FREE(e); } void mgcv_backsolve0(double *R,int *r,int *c,double *B,double *C, int *bc) /* BLAS free version Finds C = R^{-1} B where R is the c by c matrix stored in the upper triangle of r by c argument R. B is c by bc. (Possibility of non square argument R facilitates use with output from mgcv_qr). This is just a standard back substitution loop. */ { int i,j,k; double x,*pR,*pC; for (j=0;j<*bc;j++) { /* work across columns of B & C */ for (i = *c-1;i>=0;i--) { /* work up each column of B & C */ x = 0.0; /* for (k=i+1;k<*c;k++) x += R[i + *r * k] * C[k + j * *c]; ...following replaces...*/ pR = R + i + (i+1) * (ptrdiff_t)*r;pC = C + j * (ptrdiff_t)*c + i + 1; for (k=i+1;k<*c;k++,pR+= *r,pC++) x += *pR * *pC; C[i + (ptrdiff_t)j * *c] = (B[i + (ptrdiff_t)j * *c] - x)/R[i + (ptrdiff_t)*r * i]; } } } void mgcv_backsolve(double *R,int *r,int *c,double *B,double *C, int *bc,int *right) /* BLAS version If *right==0: Finds C = R^{-1} B where R is the c by c matrix stored in the upper triangle of r by c argument R. B is c by bc. (Possibility of non square argument R facilitates use with output from mgcv_qr). This is just a standard back substitution loop. Otherwise: Finds C=BR^{-1} where B is bc by c */ { double *pR,*pC,alpha=1.0; int n,m; char side='L',uplo='U',transa='N',diag='N'; if (*right) { side = 'R';m = *bc,n= *c;} else {m = *c;n= *bc;} for (pC=C,pR=pC+ *bc * (ptrdiff_t)*c;pC *r) *nt = *r; /* no point having more threads than columns */ /* now obtain block start columns, a. a[i] is start column of block i. */ a = (int *)CALLOC((size_t) (*nt+1),sizeof(int)); a[0] = 0;a[*nt] = *r; x = (double) *r;x = x*x*x / *nt; /* compute approximate optimal split... */ for (i=1;i < *nt;i++) a[i] = round(pow(x*i,1/3.0)); for (i=*nt-1;i>0;i--) { /* don't allow zero width blocks */ if (a[i]>=a[i+1]) a[i] = a[i+1]-1; } r1 = *r + 1; #ifdef OPENMP_ON #pragma omp parallel private(b,i,j,k,zz,z,z1,rr,Rjj,dk) num_threads(*nt) #endif { /* open parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (b=0;b< *nt;b++) { /* b is thread/block index */ for (i=a[b];i=0;j--) { Rjj -= r1; dk = z + j; *dk /= - *Rjj; for (zz=z,z1=z+j,rr=Rjj-j;zz0;i--) { /* don't allow zero width blocks */ if (a[i]>=a[i+1]) a[i] = a[i+1]-1; } #ifdef OPENMP_ON #pragma omp parallel private(b,i,k,zz,rr,r2) num_threads(*nt) #endif { /* open parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (b=0;b<*nt;b++) { for (i=a[b];i *r) *nt = *r; /* no point having more threads than columns */ a = (int *)CALLOC((size_t) (*nt+1),sizeof(int)); a[0] = 0;a[*nt] = *r; /* It is worth transposing R into lower triangle */ x = (double) *r;x = x*x / *nt; /* compute approximate optimal split... */ for (i=1;i < *nt;i++) a[i] = round(*r - sqrt(x*(*nt-i))); for (i=1;i <= *nt;i++) { /* don't allow zero width blocks */ if (a[i]<=a[i-1]) a[i] = a[i-1]+1; } #ifdef OPENMP_ON #pragma omp parallel private(b,i,ru,rl,r1) num_threads(*nt) #endif { /* open parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (b=0;b<*nt;b++) { for (i=a[b];i *nb * k) { nbf = *r - *nb * k;k++; /* nbf number of rows in final block */ } /* first task is to pad the end block segments, so that all segments have equal length, otherwise efficient segment swapping is not possible. This requires spilling over into extra storage. */ ns = k * *c; /* total number of segments */ if (nbf) { /* only do this if final block shorter than rest */ ns_main = (*r * *c) / *nb; /* full segments fitting in x */ ns_extra = ns - ns_main; /* segments requiring extra storage */ extra = (double *) CALLOC((size_t) (*nb * ns_extra),sizeof(double)); x0 = extra + *nb * ns_extra - 1; /* end of extra */ x1 = x + *r * *c -1 ; /* end of x */ if (*reverse) { /* blocks back into single matrix */ /* expand end segments out into extra storge */ for (i=ns-1;i >= ns_main;i--) { x0 -= *nb - nbf; /* skip padding in target */ for (j=0;j= ns - *c;i--) { x0 -= *nb - nbf; /* skip padding in target */ for (j=0;j=ns_main;i--) { /* work down through segments */ if ((i+1)%k) { /* not a short segment */ for (j = 0;j < *nb;j++,x0--,x1--) *x0 = *x1; } else { x0 -= (*nb - nbf); /* skip padding in target */ for (j = 0;j < nbf;j++,x0--,x1--) *x0 = *x1; /* fill rest from source */ } } /* now copy segments into x with padding ... */ x0 = x + ns_main * *nb - 1; /* end of main block segment storage */ for (;i>=0;i--) { /* continue down through segments */ if ((i+1)%k) { /* not a short segment */ for (j = 0;j < *nb;j++,x0--,x1--) *x0 = *x1; } else { x0 -= (*nb - nbf); for (j = 0;j < nbf;j++,x0--,x1--) *x0 = *x1; } } } /* end of forward mode padding */ } else { /* segments already equal length */ ns_main = ns;ns_extra=0; /* all segments fit into x */ } /* now re-arrange row-block wise... */ /* a[i] is original segment now in segment i... */ a = (ptrdiff_t *) CALLOC((size_t) (k * *c),sizeof(ptrdiff_t)); /* s[i] is segment now containing original segment i */ s = (ptrdiff_t *) CALLOC((size_t) (k * *c),sizeof(ptrdiff_t)); for (i=0;i *nt) k = *nt; else { fkd = floor(kd);ckd = ceil(kd); if (fkd>1) x = *r / fkd + fkd * *c; else x = *r; if (*r / ckd + ckd * *c < x) k = (int)ckd; else k = (int)fkd; } return(k); #else return(1); /* can only use 1 thread if no openMP support */ #endif } void getRpqr(double *R,double *x,int *r, int *c,int *rr,int *nt) { /* x contains qr decomposition of r by c matrix as computed by mgcv_pqr This routine simply extracts the c by c R factor into R. R has rr rows, where rr == c if R is square. */ int i,j,n; double *Rs; Rs = x;n = *r; for (i=0;i<*c;i++) for (j=0;j<*c;j++) if (i>j) R[i + *rr * j] = 0; else R[i + *rr * j] = Rs[i + n * j]; } /* getRpqr */ void getRpqr0(double *R,double *x,int *r, int *c,int *rr,int *nt) { /* x contains qr decomposition of r by c matrix as computed by mgcv_pqr This routine simply extracts the c by c R factor into R. R has rr rows, where rr == c if R is square. This version matches mgcv_pqrqy0, which is inferior to current code. */ int i,j,k,n; double *Rs; k = get_qpr_k(r,c,nt); /* number of blocks used */ if (k==1) { /* actually just a regular serial QR */ Rs = x;n = *r; } else { n = k * *c; /* rows of R */ Rs = x + *r * *c; /* source R */ } for (i=0;i<*c;i++) for (j=0;j<*c;j++) if (i>j) R[i + *rr * j] = 0; else R[i + *rr * j] = Rs[i + n * j]; } /* getRpqr0 */ void mgcv_pqrqy0(double *b,double *a,double *tau,int *r,int *c,int *cb,int *tp,int *nt) { /* Applies factor Q of a QR factor computed in parallel to b. If b is physically r by cb, but if tp = 0 it contains a c by cb matrix on entry, while if tp=1 it contains a c by cb matrix on exit. Unused elments of b on entry assumed 0. a and tau are the result of mgcv_pqr This version matches mgcv_pqr0, which scales less well than current code. */ int i,j,k,l,left=1,n,nb,nbf,nq,TRUE=1,FALSE=0; double *x0,*x1,*Qb; #ifdef OMP_REPORT Rprintf("mgcv_pqrqy0..."); #endif k = get_qpr_k(r,c,nt); /* number of blocks in use */ if (k==1) { /* single block case */ if (*tp == 0 ) {/* re-arrange so b is a full matrix */ x0 = b + *r * *cb -1; /* end of full b (target) */ x1 = b + *c * *cb -1; /* end of used block (source) */ for (j= *cb;j>0;j--) { /* work down columns */ /*for (i = *r;i > *c;i--,x0--) *x0 = 0.0;*/ /* clear unused */ x0 -= *r - *c; /* skip unused */ for (i = *c;i>0;i--,x0--,x1--) { *x0 = *x1; /* copy */ if (x0!=x1) *x1 = 0.0; /* clear source */ } } } /* if (*tp) */ mgcv_qrqy(b,a,tau,r,cb,c,&left,tp); if (*tp) { /* need to strip out the extra rows */ x1 = x0 = b; for (i=0;i < *cb;i++,x1 += *r - *c) for (j=0;j < *c;j++,x0++,x1++) *x0 = *x1; } return; } /* multi-block case starts here */ nb = (int)ceil(*r/(double)k); /* block size - in rows */ nbf = *r - (k-1)*nb; /* end block size */ Qb = (double *)CALLOC((size_t) (k * *c * *cb),sizeof(double)); nq = *c * k; if (*tp) { /* Q'b */ /* first the component Q matrices are applied to the blocks of b */ if (*cb > 1) { /* matrix case - repacking needed */ row_block_reorder(b,r,cb,&nb,&FALSE); } #ifdef OPENMP_ON #pragma omp parallel private(i,j,l,n,x1) num_threads(k) #endif { /* open parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (i=0;i1) row_block_reorder(b,r,cb,&nb,&TRUE); } #ifdef OMP_REPORT Rprintf("done\n"); #endif FREE(Qb); } /* mgcv_pqrqy0 */ void mgcv_pqrqy(double *b,double *a,double *tau,int *r,int *c,int *cb,int *tp,int *nt) { /* Applies factor Q of a QR factor computed by mgcv_pqr to b. b is physically r by cb, but if tp = 0 it contains a c by cb matrix on entry, while if tp=1 it contains a c by cb matrix on exit. Unused elments of b on entry assumed 0. a and tau are the result of mgcv_pqr. Note that in multi-threaded mode this uses mgcv_pqr0, which is thread safe, but level 2. mgcv_pqr is level 3 but not thread safe. mgcv_pqrqy itself is not thread safe - i.e. this should not be called from a parallel section (which would be dumb anyway). */ int i,j,ki,k,left=1,nth; double *x0,*x1,*aii,*p0; #ifdef OMP_REPORT Rprintf("mgcv_pqrqy..."); #endif //Rprintf("pqrqy %d ",*nt); if (*tp == 0 ) {/* re-arrange so b is a full matrix */ x0 = b + *r * *cb -1; /* end of full b (target) */ x1 = b + *c * *cb -1; /* end of used block (source) */ for (j= *cb;j>0;j--) { /* work down columns */ /*for (i = *r;i > *c;i--,x0--) *x0 = 0.0;*/ /* clear unused */ x0 -= *r - *c; /* skip unused */ for (i = *c;i>0;i--,x0--,x1--) { *x0 = *x1; /* copy */ if (x0!=x1) *x1 = 0.0; /* clear source */ } } } /* if (*tp) */ if (*cb==1 || *nt==1) mgcv_qrqy(b,a,tau,r,cb,c,&left,tp); else { /* split operation by columns of b */ /* set leading diagonal elements of a to 1 and store them */ aii = (double *)CALLOC((size_t)*c,sizeof(double)); for (k=*r+1,x0=aii,x1=aii + *c,p0=a;x0 *cb) nth = *cb; k = *cb/nth; if (k*nth < *cb) k++; /* otherwise last thread is rate limiting */ if (k*(nth-1) >= *cb) nth--; /* otherwise last thread has no work */ #ifdef OPENMP_ON #pragma omp parallel private(i,j,ki) num_threads(nth) #endif { /* open parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (i=0;i>p, not so good otherwise. - this is old code, which is uniformly less efficient than replacement. */ int i,j,k,l,*piv,nb,nbf,n,TRUE=1,FALSE=0,nr; double *R,*R1,*xi; #ifdef OMP_REPORT Rprintf("mgcv_pqr0..."); #endif k = get_qpr_k(r,c,nt);/* number of threads to use */ if (k==1) mgcv_qr(x,r,c,pivot,tau); else { /* multi-threaded version */ nb = (int)ceil(*r/(double)k); /* block size */ nbf = *r - (k-1)*nb; /* end block size */ /* need to re-arrange row blocks so that they can be split between qr calls */ row_block_reorder(x,r,c,&nb,&FALSE); piv = (int *)CALLOC((size_t) (k * *c),sizeof(int)); R = x + *r * *c ; /* pointer to combined unpivoted R matrix */ nr = *c * k; /* number of rows in R */ #ifdef OPENMP_ON #pragma omp parallel private(i,j,l,n,xi,R1) num_threads(k) #endif { /* open parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (i=0;i0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); /* actual call */ F77_CALL(dgeqp3)(r,c,x,r,pivot,tau,work,&lwork,&info); FREE(work); /*if (*r<*c) lwork= *r; else lwork= *c;*/ for (ip=pivot;ip < pivot + *c;ip++) (*ip)--; /* ... for 'tis C in which we work and not the 'cursed Fortran... */ } /* end mgcv_qr */ void mgcv_qr2(double *x, int *r, int *c,int *pivot,double *tau) /* call LA_PACK to get QR decomposition of x tau is an array of length min(r,c) pivot is array of length c, zeroed on entry, pivoting order on return. On exit upper triangle of x is R. Below upper triangle plus tau represent reflectors making up Q. pivoting is not performed in this case, but the pivoting index is returned anyway. library(mgcv) r<-4;c<-3 X<-matrix(rnorm(r*c),r,c) pivot<-rep(1,c);tau<-rep(0,c) um<-.C("mgcv_qr",as.double(X),as.integer(r),as.integer(c),as.integer(pivot),as.double(tau)) qr.R(qr(X));matrix(um[[1]],r,c)[1:c,1:c] */ { int info,*ip,i; double *work; work=(double *)CALLOC((size_t)*r,sizeof(double)); /* actual call */ /* Args: M, N, A, LDA, TAU, WORK, INFO */ F77_CALL(dgeqr2)(r,c,x,r,tau,work,&info); FREE(work); /*if (*r<*c) lwork= *r; else lwork= *c;*/ for (i=0,ip=pivot;ip < pivot + *c;ip++,i++) *ip = i; /* ... pivot index equivalent to no pivoting */ } /* end mgcv_qr2 */ void mgcv_qrqy0(double *b,double *a,double *tau,int *r,int *c,int *k,int *left,int *tp) { /* mgcv_qrqy is not thread safe, because of the behaviour of dormqr (and similar functions). This version uses dlarf for a thread safe routine, but this is then level 2, *and requires modification of a before entry*. Applies k reflectors of Q of a QR decomposition to r by c matrix b. Apply Q from left if left!=0, right otherwise. Transpose Q only if tp!=0. Information about Q has been returned from mgcv_qr, and is stored in tau and *on and* below the leading diagonal of a. In fact the leading diagonal elements must be set to 1 before entry to this routine. SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) */ char side='L'; int lda,lwork=-1,incv=1,ri,i0,i1,ii,i; double *work,*v; if (! *left) { side='R';lda = *c;lwork = *r; } else { lda= *r;lwork = *c; } /* calloc is thread safe, CALLOC ambiguous */ work=(double *)calloc((size_t)lwork,sizeof(double)); if ((*left && ! *tp)||(! *left && *tp)) { /* kth H applied first */ i0 = *k - 1;i1=-1;ii=-1; } else { /* 1st H applied first */ i0 = 0;i1 = *k;ii=1; } for (i=i0;i!=i1;i+=ii) { v = a + lda * i + i; /* start of v */ ri = *r - i; /* number of rows in sub-block to which this applies */ F77_CALL(dlarf)(&side,&ri,c,v,&incv,tau+i,b+i,r,work); } free(work); } /* mgcv_qrqy0 */ void mgcv_qrqy(double *b,double *a,double *tau,int *r,int *c,int *k,int *left,int *tp) /* applies k reflectors of Q of a QR decomposition to r by c matrix b. Apply Q from left if left!=0, right otherwise. Transpose Q only if tp!=0. Information about Q has been returned from mgcv_qr, and is stored in tau and below the leading diagonal of a. library(mgcv) r<-4;c<-3 X<-matrix(rnorm(r*c),r,c) qrx<-qr(X) pivot<-rep(1,c);tau<-rep(0,c) um<-.C("mgcv_qr",a=as.double(X),as.integer(r),as.integer(c),as.integer(pivot),tau=as.double(tau)) y<-1:4;left<-1;tp<-0;cy<-1 er<-.C("mgcv_qrqy",as.double(y),as.double(um$a),as.double(um$tau),as.integer(r),as.integer(cy),as.integer(c), as.integer(left),as.integer(tp),PACKAGE="mgcv") er[[1]];qr.qy(qrx,y) dormqr is not thread safe (with feasible memory use, at least). A block threadsafe version could be built using dlarft, dlarfb. A level 2 thread safe version could be built using dlarf (as in dorm2r) */ { char side='L',trans='N'; int lda,lwork=-1,info; double *work,work1; if (! *left) { side='R';lda = *c;} else lda= *r; if ( *tp) trans='T'; /* workspace query */ F77_CALL(dormqr)(&side,&trans,r,c,k,a,&lda,tau,b,r,&work1,&lwork,&info); lwork=(int)floor(work1);if (work1-lwork>0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); /* actual call */ F77_CALL(dormqr)(&side,&trans,r,c,k,a,&lda,tau,b,r,work,&lwork,&info); FREE(work); } void update_qr(double *Q,double *R,int *n, int *q,double *lam, int *k) /* Let X=QR where X is n by q and R is q by q upper triangular and Q is n by q. A single element extra row, x, is to be appended to X and Q and R updated accordingly. x is zero except for kth element lam. Let Q* be the full orthogonal matrix of which Q is the upper left portion, then [X] = [Q* 0][R] [x] [0 1][0] [x] The rhs of the above can be bought into standard QR form by application of givens rotations from the left to the augmented R matrix and the corresponding inverse rotations from the right to the augmented Q* matrix. The rotations from the right applied to the augmented Q* have the effect of rotating columns of Q into the final column of the augmented matrix and vice-versa. Since the columns between Q and the final column are not involved, only Q and R need to be updated here, the rest of Q* being irrelevant. This routine does not augment the Q by an extra row, it is assumed that the calling function only requires the update of the input rows. All matrices are assumed to be packed in column order. Some very minor further optimizations could be added (e.g. using fact that working and most of x are zero at first iteration), but it's really unlikely to yield a worthwhile saving. Some R code for testing the routine: library(mgcv) n<-4;q<-3 X<-matrix(rnorm(n*q),n,q) #X[,q-1]<-X[,q] qrx<-qr(X,tol=0) Q<-qr.Q(qrx);R<-qr.R(qrx);lam<-1 um<-.C("update_qr",as.double(Q),as.double(R),as.integer(n),as.integer(q), as.double(lam),as.integer(q-1),PACKAGE="mgcv") R1<-matrix(um[[2]],q,q);Q1<-matrix(um[[1]],n,q) Xa<-matrix(0,n+1,q) Xa[1:n,]<-X;Xa[n+1,q]<-lam qr.R(qr(Xa,tol=0)) */ { double *x,*work,c,s,r,x0,x1,m,*xip,*xjp,*riip,*rijp,*Qp,*wp; x=(double *)CALLOC((size_t)*q,sizeof(double)); work=(double *)CALLOC((size_t)*n,sizeof(double)); /* working extra column of Q */ x[*k] = *lam; /* conceptually i runs from k to q in the following loop */ for (Qp=Q+ *k * *n,riip=R+ *k * *q + *k,xip=x+ *k ;xip< x+ *q;xip++,riip+= *q+1) { /* rotate x[i] into R[i,i], using over/underflow proof rotator */ x0= *xip; /* x[i] */ x1= *riip; /* R[1 * *q + i] */ m = fabs(x0);s=fabs(x1); if (s>m) m=s; x1/=m;x0/=m; r=sqrt(x0*x0+x1*x1); c=x1/r;s=x0/r; *riip=m*r;/* *xip=0.0; but never neaded*/ /* conceptually j runs from i+1 to q in the following loop */ for (rijp=riip + *q,xjp=xip+1;xjp0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); liwork = iwork1;iwork= (int *)CALLOC((size_t)liwork,sizeof(int)); F77_CALL(dsyevd)(&jobz,&uplo,n,A,n,ev,work,&lwork,iwork,&liwork,&info); FREE(work);FREE(iwork); if (*descending) for (i=0;i<*n/2;i++) { /* work in from left and right swapping cols */ p = A + i * *n; /* start of left col */ p1 = A + *n * (*n - 1 - i); /* start of right col */ for (p2 = p + *n;p0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); liwork = iwork1;iwork= (int *)CALLOC((size_t)liwork,sizeof(int)); F77_CALL(dsyevr)(&jobz,&range,&uplo, n,A,n,&dum1,&dum1,&dumi,&dumi, &abstol,&n_eval,ev, Z,n,isupZ, work,&lwork,iwork,&liwork,&info); FREE(work);FREE(iwork); /* if (*descending) for (i=0;i<*n/2;i++) { x = ev[i]; ev[i] = ev[*n-i-1];ev[*n-i-1] = x; } - now below*/ if (*get_vectors) { /* copy vectors back into A */ p1 = A; if (*descending) { /* need to reverse order */ dum2 = Z + *n * (*n-1); for (work=dum2;work>=Z;work -= *n) for (p=work;p1e-14) { x += fabs(p[i + *n * j]);k++; } Rprintf("**\n"); j=k; if (k) Rprintf("Non orthogonal eigenvectors %d %g\n",k,x/k); x=0.0;k=0; for (i=0;i<*n;i++) if (fabs(p[i + *n * i]-1)>1e-14) { x += fabs(p[i + *n * i]-1);k++; } if (k) Rprintf("Eigenvectors not normalized %d %g\n",k,x/k); if (k+j>0) dump_mat(Acopy,n,n,"/home/sw283/tmp/badmat.dat"); FREE(p);FREE(Acopy); } } /* mgcv_symeig */ void mgcv_trisymeig(double *d,double *g,double *v,int *n,int getvec,int descending) /* Find eigen-values and vectors of n by n symmetric tridiagonal matrix with leading diagonal d and sub/super diagonals g. eigenvalues returned in d, and eigenvectors in columns of v, if getvec!=0. If *descending!=0 then eigenvalues returned in descending order, otherwise ascending. eigen-vector order corresponds. Routine is divide and conquer followed by inverse iteration. dstevd could be used instead, with just a name change. dstevx may be faster, but needs argument changes. */ { char compz; double *work,work1,x,*dum1,*dum2; int ldz=0,info,lwork=-1,liwork=-1,*iwork,iwork1,i,j; if (getvec) { compz='I';ldz = *n;} else { compz='N';ldz=0;} /* workspace query first .... */ F77_CALL(dstedc)(&compz,n, d, g, /* lead and su-diag */ v, /* eigenvectors on exit */ &ldz, /* dimension of v */ &work1, &lwork, &iwork1, &liwork, &info); lwork=(int)floor(work1);if (work1-lwork>0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); liwork = iwork1; iwork= (int *)CALLOC((size_t)liwork,sizeof(int)); /* and the actual call... */ F77_CALL(dstedc)(&compz,n, d, g, /* lead and su-diag */ v, /* eigenvectors on exit */ &ldz, /* dimension of v */ work, &lwork, iwork, &liwork, &info); if (descending) { /* need to reverse eigenvalues/vectors */ for (i=0;i<*n/2;i++) { /* reverse the eigenvalues */ x = d[i]; d[i] = d[*n-i-1];d[*n-i-1] = x; dum1 = v + *n * i;dum2 = v + *n * (*n-i-1); /* pointers to heads of cols to exchange */ for (j=0;j<*n;j++,dum1++,dum2++) { /* work down columns */ x = *dum1;*dum1 = *dum2;*dum2 = x; } } } FREE(work);FREE(iwork); *n=info; /* zero is success */ } /* mgcv_trisymeig */ void Rlanczos(double *A,double *U,double *D,int *n, int *m, int *lm,double *tol,int *nt) { /* Faster version of lanczos_spd for calling from R. A is n by n symmetric matrix. Let k = m + max(0,lm). U is n by k and D is a k-vector. m is the number of upper eigenvalues required and lm the number of lower. If lm<0 then the m largest magnitude eigenvalues (and their eigenvectors) are returned Matrices are stored in R (and LAPACK) format (1 column after another). If nt>1 and there is openMP support then the routine computes the O(n^2) inner products in parallel. ISSUE: 1. Currently all eigenvectors of Tj are found, although only the next unconverged one is really needed. Might be better to be more selective using dstein from LAPACK. 2. Basing whole thing on dstevx might be faster 3. Is random start vector really best? Actually Demmel (1997) suggests using a random vector, to avoid any chance of orthogonality with an eigenvector! 4. Could use selective orthogonalization, but cost of full orth is only 2nj, while n^2 of method is unavoidable, so probably not worth it. */ int biggest=0,f_check,i,k,kk,ok,l,j,vlength=0,ni,pi,converged,incx=1,ri,ci=0,cir,one=1; double **q,*v=NULL,bt,xx,yy,*a,*b,*d,*g,*z,*err,*p0,*p1,*zp,*qp,normTj,eps_stop,max_err,alpha=1.0,beta=0.0; unsigned long jran=1,ia=106,ic=1283,im=6075; /* simple RNG constants */ const char uplo='U',trans='T'; #ifdef OMP_REPORT Rprintf("Rlanczos"); #endif #ifndef OPENMP_ON *nt = 1; /* reset number of threads to 1 if openMP not available */ #endif if (*nt > *n) *nt = *n; /* don't use more threads than columns! */ eps_stop = *tol; if (*lm<0) { biggest=1;*lm=0;} /* get m largest magnitude eigen-values */ f_check = (*m + *lm)/2; /* how often to get eigen_decomp */ if (f_check<10) f_check =10; kk = (int) floor(*n/10); if (kk<1) kk=1; if (kk1 */ if (*nt>1) { ci = *n / *nt; /* cols per thread */ cir = *n - ci * (*nt - 1); /* cols for final thread */ if (cir>ci) { /* final thread has more work than normal thread - redo */ ci++; /* up work per thread by one */ *nt = (int)ceil(*n/ci); /* drop number of threads */ cir = *n - ci * (*nt - 1); /* recompute cols for final thread */ } if (cir == 0) { (*nt)--;cir=ci; } /* no cols left for final thread so drop it */ } //Rprintf("nt = %d, ci = %d, cir = %d\n",*nt,ci,cir); /* The main loop. Will break out on convergence. */ for (j=0;j< *n;j++) { /* form z=Aq[j]=A'q[j], the O(n^2) step ... */ /*blas free version ... for (Ap=A,zp=z,p0=zp+*n;zp1) { /* use parallel computation for the z = A q[j] */ #ifdef OPENMP_ON #pragma omp parallel private(i,ri) num_threads(*nt) #endif { #ifdef OPENMP_ON #pragma omp for #endif for (i=0;i<*nt;i++) { if (i < *nt-1) ri = ci; else ri = cir; /* number of cols of A to process */ /* note that symmetry, A' == A, is exploited here, (rows a:b of A are same as cols a:b of A, but latter are easier to access as a block) */ F77_CALL(dgemv)(&trans,n,&ri,&alpha,A+i * ci * *n,n,q[j], &one,&beta,z+i*ci,&one); } } /* end parallel */ } else F77_CALL(dsymv)(&uplo,n,&alpha, A,n, q[j],&incx, &beta,z,&incx); /* Now form a[j] = q[j]'z.... */ for (xx=0.0,qp=q[j],p0=qp+*n,zp=z;qp= *m + *lm)&&(j%f_check==0))||(j == *n-1)) /* no point doing this too early or too often */ { for (i=0;inormTj) normTj=fabs(d[j]); for (k=0;k= *m + *lm) { max_err=normTj*eps_stop; if (biggest) { /* getting m largest magnitude eigen values */ /* only one convergence test is sane here: 1. Find the *m largest magnitude elements of d. (*lm is 0) 2. When all these have converged, we are done. */ pi=ni=0;converged=1; while (pi+ni < *m) if (fabs(d[pi])>= fabs(d[j-ni])) { /* include d[pi] in largest set */ if (err[pi]>max_err) {converged=0;break;} else pi++; } else { /* include d[j-ni] in largest set */ if (err[ni]>max_err) {converged=0;break;} else ni++; } if (converged) { *m = pi; *lm = ni; j++;break; } } else /* number of largest and smallest supplied */ { ok=1; for (i=0;i < *m;i++) if (err[i]>max_err) ok=0; for (i=j;i > j - *lm;i--) if (err[i]>max_err) ok=0; if (ok) { j++;break;} } } } } /* At this stage, complete construction of the eigen vectors etc. */ /* Do final polishing of Ritz vectors and load va and V..... */ /* for (k=0;k < *m;k++) // create any necessary new Ritz vectors { va->V[k]=d[k]; for (i=0;iM[i][k]=0.0; for (l=0;lM[i][k]+=q[l][i]*v[k][l];} }*/ /* assumption that U is zero on entry! */ for (k=0;k < *m;k++) /* create any necessary new Ritz vectors */ { D[k]=d[k]; for (l=0;l Copyright (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. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. mgcv/data/0000755000177400001440000000000012174413534012315 5ustar murdochusersmgcv/data/columb.polys.rda0000644000177400001440000002010612174413534015432 0ustar murdochusers\xUI$-3sM!PC.J {TPHQPiP)4{uR^龧v^LZmS]ax>/1?|9s~N* ߛs>?[@cF쫆N@ށ@x~EΒWawDnk(Or7d374~:ns娶_ ,*nL@?оko@AяkPIO>-ͧ2 un ;ƕ͠/ƞ(o%Q?+cFyg"~*Ս7|5X > ZJo{4~"UʏrJȯ{|V=]ЊW4 Z6Q9s%S>>9g5>Ftv^ s}J?sl" ? ǗVvu~CoGfg+ Cv_}@Km&7R #="րef zA'_b#NO)旲{ʋawuΔUDch1uǜ5&1. <PﴕqA}#?}O>"?oƸeg[s_TKm!0&TژC@hV?Km:,5^D{wىq)s3z tB1 y!k΀hgPƶq@3[*q _if,ԱSRRƜl9.) ]=!z~Zz/ 17xV _+:Ao-'>r.ߋ{7a"O.-z79Ñut͘ 1NguEwϊ?Eg>*:yqgϕ.rURhi7?x3۬>3b ('IF_ ?1SFf('AlkE{u牝fI+Q_S<-|KX~U1?O_o(G6eR^+)㽧_qSXϻ~ޝuu#J:?+IdLUks(:Zc/mp9Qg[ic!c#c冱ԯ@'wb\.Aׁ~1/XOcdD^ ɋgD9O{x?#}7~ B7rtc;?U@l܌x׻(迻?l\ 헁{,O$7>dZHt5h |Y;^Lg,|H۴p}Lꚅ~p/|:Rx9*-9l>ÉˉQ{{{Te;u^C{#4 FTOAHO˻^{: _~}1΁X⾵W|ވ}9 x>VjK<3{{Wem1~0Q8CQ>qgO?5cm-7J7=-~^?bU}0honę]aBo}ˏ+_/aM;׊ Gt3?+8ķFhݦ<sfxPNE,20#s0=LڝqBǥր^+gѦ_k˸gƵ{4r;@}ԏ4>/H9䆥BX3eo63o&.}hh*6ƚ 9S y=9s1ʩwo39Z\ʡq;ʋ'$f;ANV +}Q AOXmpSa5]3aNKٻn&kmЅww_(T>ޑoBbL m ꩽw¹57$|S}VRow4NN}kO {?!ʳ_[kˏ/-=7ǂ^d }Buyw1A+< V{31P_Főg/-+ ;ߌ>DΰuQ>mC;.Y6!1 bZ'9A-wwnTݕSu?A y׷>ٵ|X[Dƻ7H=J};IQΒw/<ywjSe!OPN/|w\N1J\[_HxWEh61_an5.5 6=~$[o-UxXKMܭq8b|04#3CScO_o+BFJNRVZ^bfjnrvz~b7~|û>/֭zxLȺw)7RH9XͿQ"]]uў0~zoppp/qo齦"rxJg"77 >T>|1hYkkkkkkkw=G闃ϟwdо3G>dfdde\eeܝPsy9q8J 㱊:^2~22ƽ5}s>¥*7չ]u.ܖ.s_ ̓` ׽(+K[0A+2wd.ܒ&sOMLD91:7`|K܅+ g2B۴]GO?W=.b]0\h/nB#קOv .r%{/U;p=yؓo)|3x5ǵb(-1^OJ K[w?I^s"ԯ@㜻AQuΪszs6FL(GgsER"[kPW%נּw콕Uyzެ|M6 }D}0=}J.b0x8x@x';< o+N;祽|"xse̥[3frq:W'9IlsR&\ѕ£><W 9YH |e#<ʸ_~Au5v?ʋ&}7gF=]3J:bsx<&i(b{nVŰd%N2WwbQ_as)93'7f#((rH,\=:Ss?Emy %A]]kqZ>{(({0f lo)=0aNeH]8yWy֋NCyUƻOmC_Qw/JM-u,eleUz8ϸp6y;pމQ1qI <:|#?)m| ~**=s2 FذEQ"#&g<ڂQOd` cJXA&CS_~ F\(w EŊ~!:>ss_NDy s>gxWXQ;Ka Duo}} -~y7[}[aGܱ;.]n ; s񾽥)׭^\\\jp}Y#7uUn\q?1&1GGOW_gow>Se ӱO+θ:亜j˅DoýF'8a ثcc#׉Z7\Ga(ߚ"x%B.)"XBc/❎ LF0)"\HFΟfJs f`'ck&6XV:NY?+2"l,a %mH8+Arxߔ6h0. :c]%el܂/!Am}yP?3n!-Cn_#/ x#vHCzж3CC|^(PбW!OcK/QYdWv>{Cpz=F:ZX5 X<BG{]|K`5%se|*俁jk6ʞ\`F} 5n$$$$$%.][t4 o7ne'EPXx-ڇc/]_?QH=qO9_=gsYo=3()O=*Eo%g?/(Iqi6Jq:OmEWAJVŢ$GXj<_A>=k+25Y1-kJo8}\d_=ş>!Sa͙kva.F:}t.$ZIȱj\Qw[5݋mP_߷7ߖv$b=o5J8LƙUIQYaiqy e^} 17bܩ"݇Яi΋ عqZR *<ߜZS5 [ν1mP?B9&皇9#q9= k5/Pg%?tt?zXڃa̟Y\"&*𝧫Kah'.S4!6QXz6tJ3kUp ubsE{z=n~q.o:,6*g1PN5,l_b5+ִ<7ed̾Ps6׸W <,A_ho\+(z^*ϊ.zPxܺD9qNsx9[?- gqݠB^4gO 8_~CuwPw[_HY @I/8K2?C\=9O[%Vx f=JxvT8rLeԏ zO]#:?a䰦܎k#u^Pu|?\KQUt wp7ׅ;Oc +0wPs k0`.܄Kc}_Z~&WXQ.Ή5R~ st7;\>ߓz^0'`9s 90'aœv0!A^"~~LѦ5[QqЎ mk|K)8 :{tϏjYj'3q_iŻf|m66*Ds468:<> 5N$n_&=;'j!g0(rg͟50߾1oG|竹,K*Ok{O0oTaNxxxxx~ŷV&`dq}9p8gCΩSlU591?߾Xg=sɹ\CE?̀nɯqe2O48JQ?GU#bUQѿb8+^Uֿ_ZFeh1ZFeh1ZFejZFejZFejZFeiqZFeiqZF\,?"KTmgcv/data/columb.rda0000644000177400001440000000551112174413534014270 0ustar murdochusers행?'d)DY#f 3ؗ&DnqCĸɾS$-lnd$kQ)H7nI3ys><9ys|3H$Ib&+K) gtHL䚨$&A}M'wSmŵ7Oɵy7QwRJ>fܧhH1SSQѷIwщŋ7F~\\0ѕ"srХ7 FoEos:~vCVOE<4d,]//{:u?֥A:ȬqE&,ݪЕu/>O>G-XyJ¡{c;$d7+nZU?_CU{ nEdmkԲ.vzjiPop?j|׺> XVDw VסY>6աwF3/:֨duzO&jxe 6*o89*{>pqN+\: {j0m .{G{[)=udx#a ۝I.|iHX_$jxmnaIaN}&#ⰗfwEf[%%:"?֢8DKh^M%s1,_{X=Y_)~d Hc%~{;:3z*P/'7-EZK 2:`xߔ  5`J?k`? t,|^c`P5t#Q:Q >y~ST@- |b<|`uaGJZ8@3~W G-w-4WoJ*,b{)*?5vL 0ﷹ퀍 E?&|؍R<D>X Kvkցyv-gpNaiLlkR/ݶ9z=I??<a`yټ5;#}ddLpu{k*#~x 1/;:k3V ] -> 8In}C[{H]Q xT/#\Pu$rʖ pi&xe< .L:T7p~x'ۢ3 ǚ'F B~ǃfq^miN<8[| )pOԍW4hm]sgs_;ylkU8gaC.(ʸ}QG`[*UKb6}E**WQ$! ;dVM$#ݵs_݄~|I]hA*$32*ϩarcoQQ}9Df~cy<ԲU4"K4pwX|KYڸkȲ<[Z'>S0qѹuW4[ٌMH "f]pk˫ѐۊ,D*[}w´R!╵ΚPrBZOTʂ9Wj#pfixv R鹟L0hb뜮j K-I  -ÿO.QtQ4X-Xpł'ba&ba!"!aC(P\BeJ(3BʂPFx`Fx`Fx`Fx`Fx`\ƒKxp .%<<ƒGx# ^v`ݏG. 5}h'yMK.RPAsߜ~N 3}w.O};a@w+tj%Zk{vS!/kR?*]@;l[ڃٯ/өX17^M2bde@WghZ ^Mh?~NQ|$ "=cULdmpc ۈ1>̈G$[dCCūzC$r1L;+7ҿ&aV}mgcv/R/0000755000177400001440000000000013046054035011601 5ustar murdochusersmgcv/R/smooth.r0000755000177400001440000047326113036715120013313 0ustar murdochusers## R routines for the package mgcv (c) Simon Wood 2000-2016 ## This file is primarily concerned with defining classes of smoother, ## via constructor methods and prediction matrix methods. There are ## also wrappers for the constructors to automate constraint absorption, ## `by' variable handling and the summation convention used for general ## linear functional terms. SmoothCon, PredictMat and the generics are ## at the end of the file. ############################## ## First some useful utilities ############################## nat.param <- function(X,S,rank=NULL,type=0,tol=.Machine$double.eps^.8,unit.fnorm=TRUE) { ## X is an n by p model matrix. ## S is a p by p +ve semi definite penalty matrix, with the ## given rank. ## * type 0 reparameterization leaves ## the penalty matrix as a diagonal, ## * type 1 reduces it to the identity. ## * type 2 is not really natural. It simply converts the ## penalty to rank deficient identity, with some attempt to ## control the condition number sensibly. ## * type 3 is type 2, but constructed to force a constant vector ## to be the final null space basis function, if possible. ## type 2 is most efficient, but has highest condition. ## unit.fnorm == TRUE implies that the model matrix should be ## rescaled so that its penalized and unpenalized model matrices ## both have unit Frobenious norm. ## For natural param as in the book, type=0 and unit.fnorm=FALSE. ## test code: ## x <- runif(100) ## sm <- smoothCon(s(x,bs="cr"),data=data.frame(x=x),knots=NULL,absorb.cons=FALSE)[[1]] ## np <- nat.param(sm$X,sm$S[[1]],type=3) ## range(np$X-sm$X%*%np$P) if (type==2||type==3) { ## no need for QR step er <- eigen(S,symmetric=TRUE) if (is.null(rank)||rank<1||rank>ncol(S)) { rank <- sum(er$value>max(er$value)*tol) } null.exists <- rank < ncol(X) ## is there a null space, or is smooth full rank E <- rep(1,ncol(X));E[1:rank] <- sqrt(er$value[1:rank]) X <- X%*%er$vectors col.norm <- colSums(X^2) col.norm <- col.norm/E^2 ## col.norm[i] is now what norm of ith col will be, unless E modified... av.norm <- mean(col.norm[1:rank]) if (null.exists) for (i in (rank+1):ncol(X)) { E[i] <- sqrt(col.norm[i]/av.norm) } P <- t(t(er$vectors)/E) X <- t(t(X)/E) ## if type==3 re-do null space so that a constant vector is the ## final element of the null space basis, if possible... if (null.exists && type==3 && rank < ncol(X)-1) { ind <- (rank+1):ncol(X) rind <- ncol(X):(rank+1) Xn <- X[,ind,drop=FALSE] ## null basis n <- nrow(Xn) one <- rep(1,n) Xn <- Xn - one%*%(t(one)%*%Xn)/n um <- eigen(t(Xn)%*%Xn,symmetric=TRUE) ## use ind in next 2 lines to have const column last, ## rind to have it first (among null space cols) X[,rind] <- X[,ind,drop=FALSE]%*%um$vectors P[,rind] <- P[,ind,drop=FALSE]%*%(um$vectors) } if (unit.fnorm) { ## rescale so ||X||_f = 1 ind <- 1:rank scale <- 1/sqrt(mean(X[,ind]^2)) X[,ind] <- X[,ind]*scale;P[ind,] <- P[ind,]*scale if (null.exists) { ind <- (rank+1):ncol(X) scalef <- 1/sqrt(mean(X[,ind]^2)) X[,ind] <- X[,ind]*scalef;P[ind,] <- P[ind,]*scalef } } else scale <- 1 ## see end for return list defs return(list(X=X,D=rep(scale^2,rank),P=P,rank=rank,type=type)) ## type of reparameterization } qrx <- qr(X,tol=.Machine$double.eps^.8) R <- qr.R(qrx) RSR <- forwardsolve(t(R),t(forwardsolve(t(R),t(S)))) er <- eigen(RSR,symmetric=TRUE) if (is.null(rank)||rank<1||rank>ncol(S)) { rank <- sum(er$value>max(er$value)*tol) } null.exists <- rank < ncol(X) ## is there a null space, or is smooth full rank ## D contains +ve elements of diagonal penalty ## (zeroes at the end)... D <- er$values[1:rank] ## X is the model matrix... X <- qr.Q(qrx,complete=FALSE)%*%er$vectors ## P transforms parameters in this parameterization back to ## original parameters... P <- backsolve(R,er$vectors) if (type==1) { ## penalty should be identity... E <- c(sqrt(D),rep(1,ncol(X)-length(D))) P <- t(t(P)/E) X <- t(t(X)/E) ## X%*%diag(1/E) D <- D*0+1 } if (unit.fnorm) { ## rescale so ||X||_f = 1 ind <- 1:rank scale <- 1/sqrt(mean(X[,ind]^2)) X[,ind] <- X[,ind]*scale;P[,ind] <- P[,ind]*scale D <- D * scale^2 if (null.exists) { ind <- (rank+1):ncol(X) scalef <- 1/sqrt(mean(X[,ind]^2)) X[,ind] <- X[,ind]*scalef;P[,ind] <- P[,ind]*scalef } } ## unpenalized always at the end... list(X=X, ## transformed model matrix D=D, ## +ve elements on leading diagonal of penalty P=P, ## transforms parameter estimates back to original parameterization ## postmultiplying original X by P gives reparam version rank=rank, ## penalty rank (number of penalized parameters) type=type) ## type of reparameterization } ## end nat.param mono.con<-function(x,up=TRUE,lower=NA,upper=NA) # Takes the knot sequence x for a cubic regression spline and returns a list with # 2 elements matrix A and array b, such that if p is the vector of coeffs of the # spline, then Ap>b ensures monotonicity of the spline. # up=TRUE gives monotonic increase, up=FALSE gives decrease. # lower and upper are the optional lower and upper bounds on the spline. { if (is.na(lower)) {lo<-0;lower<-0;} else lo<-1 if (is.na(upper)) {hi<-0;upper<-0;} else hi<-1 if (up) inc<-1 else inc<-0 control<-4*inc+2*lo+hi n<-length(x) if (n<4) stop("At least three knots required in call to mono.con.") A<-matrix(0,4*(n-1)+lo+hi,n) b<-array(0,4*(n-1)+lo+hi) if (lo*hi==1&&lower>=upper) stop("lower bound >= upper bound in call to mono.con()") oo<-.C(C_RMonoCon,as.double(A),as.double(b),as.double(x),as.integer(control),as.double(lower), as.double(upper),as.integer(n)) A<-matrix(oo[[1]],dim(A)[1],dim(A)[2]) b<-array(oo[[2]],dim(A)[1]) list(A=A,b=b) } ## end mono.con uniquecombs <- function(x,ordered=FALSE) { ## takes matrix x and counts up unique rows ## `unique' now does this in R if (is.null(x)) stop("x is null") if (is.null(nrow(x))||is.null(ncol(x))) x <- data.frame(x) recheck <- FALSE if (inherits(x,"data.frame")) { xoo <- xo <- x ## reset character, logical and factor to numeric, to guarantee that text versions of labels ## are unique iff rows are unique (otherwise labels containing "*" could in principle ## fool it). is.char <- rep(FALSE,length(x)) for (i in 1:length(x)) { if (is.character(xo[[i]])) { is.char[i] <- TRUE xo[[i]] <- as.factor(xo[[i]]) } if (is.factor(xo[[i]])||is.logical(xo[[i]])) x[[i]] <- as.numeric(xo[[i]]) if (!is.numeric(x[[i]])) recheck <- TRUE ## input contains unknown type cols } #x <- data.matrix(xo) ## ensure all data are numeric } else xo <- NULL if (ncol(x)==1) { ## faster to use R xu <- if (ordered) sort(unique(x[,1])) else unique(x[,1]) ind <- match(x[,1],xu) if (is.null(xo)) x <- matrix(xu,ncol=1,nrow=length(xu)) else { x <- data.frame(xu) names(x) <- names(xo) } } else { ## no R equivalent that directly yields indices if (ordered) { chloc <- Sys.getlocale("LC_CTYPE") Sys.setlocale("LC_CTYPE","C") } ## txt <- paste("paste0(",paste("x[,",1:ncol(x),"]",sep="",collapse=","),")",sep="") ## ... this can produce duplicate labels e.g. x[,1] = c(1,11), x[,2] = c(12,2)... ## solution is to insert separator not present in representation of a number (any ## factor codes are already converted to numeric by data.matrix call above.) txt <- paste("paste0(",paste("x[,",1:ncol(x),"]",sep="",collapse=",\"*\","),")",sep="") xt <- eval(parse(text=txt)) ## text representation of rows dup <- duplicated(xt) ## identify duplicates xtu <- xt[!dup] ## unique text rows x <- x[!dup,] ## unique rows in original format #ordered <- FALSE if (ordered) { ## return unique in same order regardless of entry order ## ordering of character based labels is locale dependent ## so that e.g. running the same code interactively and via ## R CMD check can give different answers. coloc <- Sys.getlocale("LC_COLLATE") Sys.setlocale("LC_COLLATE","C") ii <- order(xtu) Sys.setlocale("LC_COLLATE",coloc) Sys.setlocale("LC_CTYPE",chloc) xtu <- xtu[ii] x <- x[ii,] } ind <- match(xt,xtu) ## index each row to the unique duplicate deleted set } if (!is.null(xo)) { ## original was a data.frame x <- as.data.frame(x) names(x) <- names(xo) for (i in 1:ncol(xo)) { if (is.factor(xo[,i])) { ## may need to reset factors to factors xoi <- levels(xo[,i]) x[,i] <- if (is.ordered(xo[,i])) ordered(x[,i],levels=1:length(xoi),labels=xoi) else factor(x[,i],levels=1:length(xoi),labels=xoi) contrasts(x[,i]) <- contrasts(xo[,i]) } if (is.char[i]) x[,i] <- as.character(x[,i]) if (is.logical(xo[,i])) x[,i] <- as.logical(x[,i]) } } if (recheck) { if (all.equal(xoo,x[ind,],check.attributes=FALSE)!=TRUE) warning("uniquecombs has not worked properly") } attr(x,"index") <- ind x } ## uniquecombs uniquecombs0 <- function(x,ordered=FALSE) { ## takes matrix x and counts up unique rows ## `unique' now does this in R if (is.null(x)) stop("x is null") if (is.null(nrow(x))||is.null(ncol(x))) x <- data.frame(x) if (inherits(x,"data.frame")) { xo <- x x <- data.matrix(xo) ## ensure all data are numeric } else xo <- NULL if (ncol(x)==1) { ## faster to use R xu <- if (ordered) sort(unique(x)) else unique(x) ind <- match(as.numeric(x),xu) x <- matrix(xu,ncol=1,nrow=length(xu)) } else { ## no R equivalent that directly yields indices if (ordered) { chloc <- Sys.getlocale("LC_CTYPE") Sys.setlocale("LC_CTYPE","C") } ## txt <- paste("paste0(",paste("x[,",1:ncol(x),"]",sep="",collapse=","),")",sep="") ## ... this can produce duplicate labels e.g. x[,1] = c(1,11), x[,2] = c(12,2)... ## solution is to insert separator not present in representation of a number (any ## factor codes are already converted to numeric by data.matrix call above.) txt <- paste("paste0(",paste("x[,",1:ncol(x),"]",sep="",collapse=",\":\","),")",sep="") xt <- eval(parse(text=txt)) ## text representation of rows dup <- duplicated(xt) ## identify duplicates xtu <- xt[!dup] ## unique text rows x <- x[!dup,] ## unique rows in original format #ordered <- FALSE if (ordered) { ## return unique in same order regardless of entry order ## ordering of character based labels is locale dependent ## so that e.g. running the same code interactively and via ## R CMD check can give different answers. coloc <- Sys.getlocale("LC_COLLATE") Sys.setlocale("LC_COLLATE","C") ii <- order(xtu) Sys.setlocale("LC_COLLATE",coloc) Sys.setlocale("LC_CTYPE",chloc) xtu <- xtu[ii] x <- x[ii,] } ind <- match(xt,xtu) ## index each row to the unique duplicate deleted set } if (!is.null(xo)) { ## original was a data.frame x <- as.data.frame(x) names(x) <- names(xo) for (i in 1:ncol(xo)) if (is.factor(xo[,i])) { ## may need to reset factors to factors xoi <- levels(xo[,i]) x[,i] <- if (is.ordered(xo[,i])) ordered(x[,i],levels=1:length(xoi),labels=xoi) else factor(x[,i],levels=1:length(xoi),labels=xoi) contrasts(x[,i]) <- contrasts(xo[,i]) } } attr(x,"index") <- ind x } ## uniquecombs0 cSplineDes <- function (x, knots, ord = 4,derivs=0) { ## cyclic version of spline design... ##require(splines) nk <- length(knots) if (ord<2) stop("order too low") if (nkknots[nk]) stop("x out of range") xc <- knots[nk-ord+1] ## wrapping involved above this point ## copy end intervals to start, for wrapping purposes... knots <- c(k1-(knots[nk]-knots[(nk-ord+1):(nk-1)]),knots) ind <- x>xc ## index for x values where wrapping is needed X1 <- splines::splineDesign(knots,x,ord,outer.ok=TRUE,derivs=derivs) x[ind] <- x[ind] - max(knots) + k1 if (sum(ind)) { ## wrapping part... X2 <- splines::splineDesign(knots,x[ind],ord,outer.ok=TRUE,derivs=derivs) X1[ind,] <- X1[ind,] + X2 } X1 ## final model matrix } ## cSplineDes get.var <- function(txt,data,vecMat = TRUE) # txt contains text that may be a variable name and may be an expression # for creating a variable. get.var first tries data[[txt]] and if that # fails tries evaluating txt within data (only). Routine returns NULL # on failure, or if result is not numeric or a factor. # matrices are coerced to vectors, which facilitates matrix arguments # to smooths. { x <- data[[txt]] if (is.null(x)) { x <- try(eval(parse(text=txt),data,enclos=NULL),silent=TRUE) if (inherits(x,"try-error")) x <- NULL } if (!is.numeric(x)&&!is.factor(x)) x <- NULL if (is.matrix(x)) { if (ncol(x)==1) { x <- as.numeric(x) ismat <- FALSE } else ismat <- TRUE } else ismat <- FALSE if (vecMat&&is.matrix(x)) x <- as.numeric(x) if (ismat) attr(x,"matrix") <- TRUE x } ## get.var ################################################ ## functions for use in `gam(m)' formulae ...... ################################################ ti <- function(..., k=NA,bs="cr",m=NA,d=NA,by=NA,fx=FALSE,np=TRUE,xt=NULL,id=NULL,sp=NULL,mc=NULL,pc=NULL) { ## function to use in gam formula to specify a te type tensor product interaction term ## ti(x) + ti(y) + ti(x,y) is *much* preferable to te(x) + te(y) + te(x,y), as ti(x,y) ## automatically excludes ti(x) + ti(y). Uses general fact about interactions that ## if identifiability constraints are applied to main effects, then row tensor product ## of main effects gives identifiable interaction... ## mc allows selection of which marginals to apply constraints to. Default is all. by.var <- deparse(substitute(by),backtick=TRUE) #getting the name of the by variable object <- te(...,k=k,bs=bs,m=m,d=d,fx=fx,np=np,xt=xt,id=id,sp=sp,pc=pc) object$inter <- TRUE object$by <- by.var object$mc <- mc substr(object$label,2,2) <- "i" object } ## ti te <- function(..., k=NA,bs="cr",m=NA,d=NA,by=NA,fx=FALSE,mp=TRUE,np=TRUE,xt=NULL,id=NULL,sp=NULL,pc=NULL) # function for use in gam formulae to specify a tensor product smooth term. # e.g. te(x0,x1,x2,k=c(5,4,4),bs=c("tp","cr","cr"),m=c(1,1,2),by=x3) specifies a rank 80 tensor # product spline. The first basis is rank 5, t.p.r.s. basis penalty order 1, and the next 2 bases # are rank 4 cubic regression splines with m ignored. # k, bs,d and fx can be supplied as single numbers or arrays with an element for each basis. # m can be a single number, and array with one element for each basis, or a list, with an # array for each basis # Returns a list consisting of: # * margin - a list of smooth.spec objects specifying the marginal bases # * term - array of covariate names # * by - the by variable name # * fx - array indicating which margins should be treated as fixed (i.e unpenalized). # * label - label for this term # * mp - TRUE to use a penalty per dimension, FALSE to use a single penalty { vars <- as.list(substitute(list(...)))[-1] # gets terms to be smoothed without evaluation dim <- length(vars) # dimension of smoother by.var <- deparse(substitute(by),backtick=TRUE) #getting the name of the by variable term <- deparse(vars[[1]],backtick=TRUE) # first covariate if (dim>1) # then deal with further covariates for (i in 2:dim) term[i]<-deparse(vars[[i]],backtick=TRUE) for (i in 1:dim) term[i] <- attr(terms(reformulate(term[i])),"term.labels") # term now contains the names of the covariates for this model term # check d - the number of covariates per basis if (sum(is.na(d))||is.null(d)) { n.bases<-dim;d<-rep(1,dim)} # one basis for each dimension else # array d supplied, the dimension of each term in the tensor product { d<-round(d) ok<-TRUE if (sum(d<=0)) ok<-FALSE if (sum(d)!=dim) ok<-FALSE if (ok) n.bases<-length(d) else { warning("something wrong with argument d.") n.bases<-dim;d<-rep(1,dim) } } # now evaluate k if (sum(is.na(k))||is.null(k)) k<-5^d else { k<-round(k);ok<-TRUE if (sum(k<3)) { ok<-FALSE;warning("one or more supplied k too small - reset to default")} if (length(k)==1&&ok) k<-rep(k,n.bases) else if (length(k)!=n.bases) ok<-FALSE if (!ok) k<-5^d } # evaluate fx if (sum(is.na(fx))||is.null(fx)) fx<-rep(FALSE,n.bases) else if (length(fx)==1) fx<-rep(fx,n.bases) else if (length(fx)!=n.bases) { warning("dimension of fx is wrong") fx<-rep(FALSE,n.bases) } # deal with `xt' extras list xtra <- list() if (is.null(xt)||length(xt)==1) for (i in 1:n.bases) xtra[[i]] <- xt else if (length(xt)==n.bases) xtra <- xt else stop("xt argument is faulty.") # now check the basis types if (length(bs)==1) bs<-rep(bs,n.bases) if (length(bs)!=n.bases) {warning("bs wrong length and ignored.");bs<-rep("cr",n.bases)} bs[d>1&(bs=="cr"|bs=="cs"|bs=="ps"|bs=="cp")]<-"tp" # finally the spline/penalty orders if (!is.list(m)&&length(m)==1) m <- rep(m,n.bases) if (length(m)!=n.bases) { warning("m wrong length and ignored."); m <- rep(0,n.bases) } if (!is.list(m)) m[m<0] <- 0 ## Duchon splines can have -ve elements in a vector m # check for repeated variables in function argument list if (length(unique(term))!=dim) stop("Repeated variables as arguments of a smooth are not permitted") # Now construct smooth.spec objects for the margins j <- 1 # counter for terms margin <- list() for (i in 1:n.bases) { j1<-j+d[i]-1 if (is.null(xt)) xt1 <- NULL else xt1 <- xtra[[i]] ## ignore codetools stxt<-"s(" for (l in j:j1) stxt<-paste(stxt,term[l],",",sep="") stxt<-paste(stxt,"k=",deparse(k[i],backtick=TRUE),",bs=",deparse(bs[i],backtick=TRUE), ",m=",deparse(m[[i]],backtick=TRUE),",xt=xt1", ")") margin[[i]]<- eval(parse(text=stxt)) # NOTE: fx and by not dealt with here! j<-j1+1 } # assemble term.label if (mp) mp <- TRUE else mp <- FALSE if (np) np <- TRUE else np <- FALSE full.call<-paste("te(",term[1],sep="") if (dim>1) for (i in 2:dim) full.call<-paste(full.call,",",term[i],sep="") label<-paste(full.call,")",sep="") # label for parameters of this term if (!is.null(id)) { if (length(id)>1) { id <- id[1] warning("only first element of `id' used") } id <- as.character(id) } ret<-list(margin=margin,term=term,by=by.var,fx=fx,label=label,dim=dim,mp=mp,np=np, id=id,sp=sp,inter=FALSE) if (!is.null(pc)) { if (length(pc)1) # then deal with further covariates for (i in 2:dim) { term[i]<-deparse(vars[[i]],backtick=TRUE) } for (i in 1:dim) term[i] <- attr(terms(reformulate(term[i])),"term.labels") # term now contains the names of the covariates for this model term # check d - the number of covariates per basis if (sum(is.na(d))||is.null(d)) { n.bases<-dim;d<-rep(1,dim)} # one basis for each dimension else # array d supplied, the dimension of each term in the tensor product { d<-round(d) ok<-TRUE if (sum(d<=0)) ok<-FALSE if (sum(d)!=dim) ok<-FALSE if (ok) n.bases<-length(d) else { warning("something wrong with argument d.") n.bases<-dim;d<-rep(1,dim) } } # now evaluate k if (sum(is.na(k))||is.null(k)) k<-5^d else { k<-round(k);ok<-TRUE if (sum(k<3)) { ok<-FALSE;warning("one or more supplied k too small - reset to default")} if (length(k)==1&&ok) k<-rep(k,n.bases) else if (length(k)!=n.bases) ok<-FALSE if (!ok) k<-5^d } fx <- FALSE # deal with `xt' extras list xtra <- list() if (is.null(xt)||length(xt)==1) for (i in 1:n.bases) xtra[[i]] <- xt else if (length(xt)==n.bases) xtra <- xt else stop("xt argument is faulty.") # now check the basis types if (length(bs)==1) bs<-rep(bs,n.bases) if (length(bs)!=n.bases) {warning("bs wrong length and ignored.");bs<-rep("cr",n.bases)} bs[d>1&(bs=="cr"|bs=="cs"|bs=="ps"|bs=="cp")]<-"tp" # finally the spline/penalty orders if (!is.list(m)&&length(m)==1) m <- rep(m,n.bases) if (length(m)!=n.bases) { warning("m wrong length and ignored."); m <- rep(0,n.bases) } if (!is.list(m)) m[m<0] <- 0 ## Duchon splines can have -ve elements in a vector m # check for repeated variables in function argument list if (length(unique(term))!=dim) stop("Repeated variables as arguments of a smooth are not permitted") # Now construct smooth.spec objects for the margins j<-1 # counter for terms margin<-list() for (i in 1:n.bases) { j1<-j+d[i]-1 if (is.null(xt)) xt1 <- NULL else xt1 <- xtra[[i]] ## ignore codetools stxt<-"s(" for (l in j:j1) stxt<-paste(stxt,term[l],",",sep="") stxt<-paste(stxt,"k=",deparse(k[i],backtick=TRUE),",bs=",deparse(bs[i],backtick=TRUE), ",m=",deparse(m[[i]],backtick=TRUE),",xt=xt1", ")") margin[[i]]<- eval(parse(text=stxt)) # NOTE: fx and by not dealt with here! j<-j1+1 } # check ord argument if (!is.null(ord)) { if (sum(ord%in%0:n.bases)==0) { ord <- NULL warning("ord is wrong. reset to NULL.") } if (sum(ord<0)>0||sum(ord>n.bases)>0) warning("ord contains out of range orders (which will be ignored)") } # assemble term.label full.call<-paste("t2(",term[1],sep="") if (dim>1) for (i in 2:dim) full.call<-paste(full.call,",",term[i],sep="") label<-paste(full.call,")",sep="") # label for parameters of this term if (!is.null(id)) { if (length(id)>1) { id <- id[1] warning("only first element of `id' used") } id <- as.character(id) } full <- as.logical(full) if (is.na(full)) full <- FALSE ret<-list(margin=margin,term=term,by=by.var,fx=fx,label=label,dim=dim, id=id,sp=sp,full=full,ord=ord) if (!is.null(pc)) { if (length(pc)1) # then deal with further covariates for (i in 2:d) { term[i]<-deparse(vars[[i]],backtick=TRUE,width.cutoff=500) if (term[i]==".") stop("s(.) not yet supported.") } for (i in 1:d) term[i] <- attr(terms(reformulate(term[i])),"term.labels") # term now contains the names of the covariates for this model term # now evaluate all the other k.new <- round(k) # in case user has supplied non-integer basis dimension if (all.equal(k.new,k)!=TRUE) {warning("argument k of s() should be integer and has been rounded")} k <- k.new # check for repeated variables in function argument list if (length(unique(term))!=d) stop("Repeated variables as arguments of a smooth are not permitted") # assemble label for term full.call<-paste("s(",term[1],sep="") if (d>1) for (i in 2:d) full.call<-paste(full.call,",",term[i],sep="") label<-paste(full.call,")",sep="") # used for labelling parameters if (!is.null(id)) { if (length(id)>1) { id <- id[1] warning("only first element of `id' used") } id <- as.character(id) } ret <- list(term=term,bs.dim=k,fixed=fx,dim=d,p.order=m,by=by.var,label=label,xt=xt, id=id,sp=sp) if (!is.null(pc)) { if (length(pc)1) for (i in (m-1):1) { X0 <- X1;X1 <- matrix(0,n,0) for (j in 1:ncol(X[[i]])) X1 <- cbind(X1,X[[i]][,j]*X0) } X1 } ## end tensor.prod.model.matrix1 tensor.prod.model.matrix <- function(X) { # X is a list of model matrices, from which a tensor product model matrix is to be produced. # e.g. ith row is basically X[[1]][i,]%x%X[[2]][i,]%x%X[[3]][i,], but this routine works # column-wise, for efficiency, and does work in compiled code. m <- length(X) ## number to row tensor product d <- unlist(lapply(X,ncol)) ## dimensions of each X n <- nrow(X[[1]]) ## columns in each X X <- as.numeric(unlist(X)) ## append X[[i]]s columnwise T <- numeric(n*prod(d)) ## storage for result .Call(C_mgcv_tmm,X,T,d,m,n) ## produce product ## Give T attributes of matrix. Note that initializing T as a matrix ## requires more time than forming the row tensor product itself (R 3.0.1) attr(T,"dim") <- c(n,prod(d)) class(T) <- "matrix" T } ## end tensor.prod.model.matrix tensor.prod.penalties <- function(S) # Given a list S of penalty matrices for the marginal bases of a tensor product smoother # this routine produces the resulting penalties for the tensor product basis. # e.g. if S_1, S_2 and S_3 are marginal penalties and I_1, I_2, I_3 are identity matrices # of the same dimensions then the tensor product penalties are: # S_1 %x% I_2 %x% I_3, I_1 %x% S_2 %x% I_3 and I_1 %*% I_2 %*% S_3 # Note that the penalty list must be in the same order as the model matrix list supplied # to tensor.prod.model() when using these together. { m <- length(S) I <- list(); for (i in 1:m) { n <- ncol(S[[i]]) I[[i]] <- diag(n) } TS <- list() if (m==1) TS[[1]] <- S[[1]] else for (i in 1:m) { if (i==1) M0 <- S[[1]] else M0 <- I[[1]] for (j in 2:m) { if (i==j) M1 <- S[[i]] else M1 <- I[[j]] M0<-M0 %x% M1 } TS[[i]] <- if (ncol(M0)==nrow(M0)) (M0+t(M0))/2 else M0 # ensure exactly symmetric } TS }## end tensor.prod.penalties smooth.construct.tensor.smooth.spec <- function(object,data,knots) { ## the constructor for a tensor product basis object inter <- object$inter ## signal generation of a pure interaction m <- length(object$margin) # number of marginal bases if (inter) { ## interaction term so at least some marginals subject to constraint object$mc <- if (is.null(object$mc)) rep(TRUE,m) else as.logical(object$mc) ## which marginals to constrain object$sparse.cons <- if (is.null(object$sparse.cons)) rep(0,m) else object$sparse.cons } else { object$mc <- rep(FALSE,m) ## all marginals unconstrained } Xm <- list();Sm<-list();nr<-r<-d<-array(0,m) C <- NULL object$plot.me <- TRUE mono <- rep(FALSE,m) ## indicator for monotonic parameteriztion margins for (i in 1:m) { if (!is.null(object$margin[[i]]$mono)&&object$margin[[i]]$mono!=0) mono[i] <- TRUE knt <- dat <- list() term <- object$margin[[i]]$term for (j in 1:length(term)) { dat[[term[j]]] <- data[[term[j]]] knt[[term[j]]] <- knots[[term[j]]] } object$margin[[i]] <- if (object$mc[i]) smoothCon(object$margin[[i]],dat,knt,absorb.cons=TRUE,n=length(dat[[1]]), sparse.cons=object$sparse.cons[i])[[1]] else smooth.construct(object$margin[[i]],dat,knt) Xm[[i]] <- object$margin[[i]]$X if (!is.null(object$margin[[i]]$te.ok)) { if (object$margin[[i]]$te.ok == 0) stop("attempt to use unsuitable marginal smooth class") if (object$margin[[i]]$te.ok == 2) object$plot.me <- FALSE ## margin has declared itself unplottable in a te term } if (length(object$margin[[i]]$S)>1) stop("Sorry, tensor products of smooths with multiple penalties are not supported.") Sm[[i]] <- object$margin[[i]]$S[[1]] d[i] <- nrow(Sm[[i]]) r[i] <- object$margin[[i]]$rank nr[i] <- object$margin[[i]]$null.space.dim if (!inter&&!is.null(object$margin[[i]]$C)&&nrow(object$margin[[i]]$C)==0) C <- matrix(0,0,0) ## no centering constraint needed } ## Re-parameterization currently breaks monotonicity constraints ## so turn it off. An alternative would be to shift the marginal ## basis functions to force non-negativity. if (sum(mono)) { object$np <- FALSE ## need the re-parameterization indicator for the whole term, ## by combination of those for single terms. km <- which(mono) g <- list(); for (i in 1:length(km)) g[[i]] <- object$margin[[km[i]]]$g.index for (i in 1:length(object$margin)) { dx <- ncol(object$margin[[i]]$X) for (j in length(km)) if (i!=km[j]) g[[j]] <- if (i > km[j]) rep(g[[j]],each=dx) else rep(g[[j]],dx) } object$g.index <- as.logical(rowSums(matrix(unlist(g),length(g[[1]]),length(g)))) } XP <- list() if (object$np) for (i in 1:m) { # reparameterize if (object$margin[[i]]$dim==1) { # only do classes not already optimal (or otherwise excluded) if (is.null(object$margin[[i]]$noterp)) { ## apply repara x <- get.var(object$margin[[i]]$term,data) np <- ncol(object$margin[[i]]$X) ## number of params ## note: to avoid extrapolating wiggliness measure ## must include extremes as eval points knt <- if(is.factor(x)) { unique(x) } else { seq(min(x), max(x), length=np) } pd <- data.frame(knt) names(pd) <- object$margin[[i]]$term sv <- if (object$mc[i]) svd(PredictMat(object$margin[[i]],pd)) else svd(Predict.matrix(object$margin[[i]],pd)) if (sv$d[np]/sv$d[1]<.Machine$double.eps^.66) { ## condition number rather high XP[[i]] <- NULL warning("reparameterization unstable for margin: not done") } else { XP[[i]] <- sv$v%*%(t(sv$u)/sv$d) object$margin[[i]]$X <- Xm[[i]] <- Xm[[i]]%*%XP[[i]] Sm[[i]] <- t(XP[[i]])%*%Sm[[i]]%*%XP[[i]] } } else XP[[i]] <- NULL } else XP[[i]] <- NULL } # scale `nicely' - mostly to avoid problems with lme ... for (i in 1:m) Sm[[i]] <- Sm[[i]]/eigen(Sm[[i]],symmetric=TRUE,only.values=TRUE)$values[1] max.rank <- prod(d) r <- max.rank*r/d # penalty ranks X <- tensor.prod.model.matrix(Xm) if (object$mp) { # multiple penalties S <- tensor.prod.penalties(Sm) for (i in m:1) if (object$fx[i]) { S[[i]] <- NULL # remove penalties for un-penalized margins r <- r[-i] # remove corresponding rank from list } } else { # single penalty warning("single penalty tensor product smooths are deprecated and likely to be removed soon") S <- Sm[[1]];r <- object$margin[[i]]$rank if (m>1) for (i in 2:m) { S <- S%x%Sm[[i]] r <- r*object$margin[[i]]$rank } if (sum(object$fx)==m) { S <- list();object$fixed=TRUE } else { S <-list(S);object$fixed=FALSE } nr <- max.rank-r object$bs.dim <- max.rank } if (!is.null(object$margin[[1]]$xt$dropu)&&object$margin[[1]]$xt$dropu) { ind <- which(colSums(abs(X))!=0) X <- X[,ind] if (!is.null(object$g.index)) object$g.index <- object$g.index[ind] #for (i in 1:length(S)) { ## next line is equivalent to setting coefs for deleted to zero! #S[[i]] <- S[[i]][ind,ind] #} ## Instead we need to drop the differences involving deleted coefs for (i in 1:m) { if (is.null(object$margin[[i]]$D)) stop("basis not usable with reduced te") Sm[[i]] <- object$margin[[i]]$D ## differences } S <- tensor.prod.penalties(Sm) ## tensor prod difference penalties ## drop rows corresponding to differences that involve a dropped ## basis function, and crossproduct... for (i in 1:m) { D <- S[[i]][rowSums(S[[i]][,-ind,drop=FALSE])==0,ind] r[i] <- nrow(D) ## penalty rank S[[i]] <- crossprod(D) } object$udrop <- ind ## rank r ?? } object$X <- X;object$S <- S; if (inter) object$C <- matrix(0,0,0) else object$C <- C ## really just in case a marginal has implied that no cons are needed object$df <- ncol(X) object$null.space.dim <- prod(nr) # penalty null space rank object$rank <- r object$XP <- XP class(object)<-"tensor.smooth" object } ## end smooth.construct.tensor.smooth.spec Predict.matrix.tensor.smooth <- function(object,data) ## the prediction method for a tensor product smooth { m <- length(object$margin) X <- list() for (i in 1:m) { term <- object$margin[[i]]$term dat <- list() for (j in 1:length(term)) dat[[term[j]]] <- data[[term[j]]] X[[i]] <- if (object$mc[i]) PredictMat(object$margin[[i]],dat,n=length(dat[[1]])) else Predict.matrix(object$margin[[i]],dat) } mxp <- length(object$XP) if (mxp>0) for (i in 1:mxp) if (!is.null(object$XP[[i]])) X[[i]] <- X[[i]]%*%object$XP[[i]] T <- tensor.prod.model.matrix(X) if (is.null(object$udrop)) T else T[,object$udrop] }## end Predict.matrix.tensor.smooth ######################################################################### ## Type 2 tensor product methods start here - separate identity penalties ######################################################################### t2.model.matrix <- function(Xm,rank,full=TRUE,ord=NULL) { ## Xm is a list of marginal model matrices. ## The first rank[i] columns of Xm[[i]] are penalized, ## by a ridge penalty, the remainder are unpenalized. ## this routine constructs a tensor product model matrix, ## subject to a sequence of non-overlapping ridge penalties. ## If full is TRUE then the result is completely invariant, ## as each column of each null space is treated separately in ## the construction. Otherwise there is an element of arbitrariness ## in the invariance, as it depends on scaling of the null space ## columns. ## ord is the list of term orders to include. NULL indicates all ## terms are to be retained. Zi <- Xm[[1]][,1:rank[1],drop=FALSE] ## range space basis for first margin X2 <- list(Zi) order <- 1 ## record order of component (number of range space components) lab2 <- "r" ## list of term labels "r" denotes range space null.exists <- rank[1] < ncol(Xm[[1]]) ## does null exist for margin 1 no.null <- FALSE if (full) pen2 <- TRUE if (null.exists) { Xi <- Xm[[1]][,(rank[1]+1):ncol(Xm[[1]]),drop=FALSE] ## null space basis margin 1 if (full) { pen2[2] <- FALSE colnames(Xi) <- as.character(1:ncol(Xi)) } X2[[2]] <- Xi ## working model matrix component list lab2[2]<- "n" ## "n" is null space order[2] <- 0 } else no.null <- TRUE ## tensor product will have *no* null space... n.m <- length(Xm) ## number of margins X1 <- list() n <- nrow(Zi) if (n.m>1) for (i in 2:n.m) { ## work through margins... Zi <- Xm[[i]][,1:rank[i],drop=FALSE] ## margin i range space null.exists <- rank[i] < ncol(Xm[[i]]) ## does null exist for margin i if (null.exists) { Xi <- Xm[[i]][,(rank[i]+1):ncol(Xm[[i]]),drop=FALSE] ## margin i null space if (full) colnames(Xi) <- as.character(1:ncol(Xi)) } else no.null <- TRUE ## tensor product will have *no* null space... X1 <- X2 if (full) pen1 <- pen2 lab1 <- lab2 ## labels order1 <- order k <- 1 for (ii in 1:length(X1)) { ## form products with Zi if (!full || pen1[ii]) { ## X1[[ii]] is penalized and treated as a whole A <- matrix(0,n,0) for (j in 1:ncol(X1[[ii]])) A <- cbind(A,X1[[ii]][,j]*Zi) X2[[k]] <- A if (full) pen2[k] <- TRUE lab2[k] <- paste(lab1[ii],"r",sep="") order[k] <- order1[ii] + 1 k <- k + 1 } else { ## X1[[ii]] is un-penalized, columns to be treated separately cnx1 <- colnames(X1[[ii]]) for (j in 1:ncol(X1[[ii]])) { X2[[k]] <- X1[[ii]][,j]*Zi lab2[k] <- paste(cnx1[j],"r",sep="") order[k] <- order1[ii] + 1 pen2[k] <- TRUE k <- k + 1 } } } ## finished dealing with range space for this margin if (null.exists) { for (ii in 1:length(X1)) { ## form products with Xi if (!full || !pen1[ii]) { ## treat product as whole if (full) { ## need column labels to make correct term labels cn <- colnames(X1[[ii]]);cnxi <- colnames(Xi) cnx2 <- rep("",0) } A <- matrix(0,n,0) for (j in 1:ncol(X1[[ii]])) { if (full) cnx2 <- c(cnx2,paste(cn[j],cnxi,sep="")) ## column labels A <- cbind(A,X1[[ii]][,j]*Xi) } if (full) colnames(A) <- cnx2 lab2[k] <- paste(lab1[ii],"n",sep="") order[k] <- order1[ii] X2[[k]] <- A; if (full) pen2[k] <- FALSE ## if full, you only get to here when pen1[i] FALSE k <- k + 1 } else { ## treat cols of Xi separately (full is TRUE) cnxi <- colnames(Xi) for (j in 1:ncol(Xi)) { X2[[k]] <- X1[[ii]]*Xi[,j] lab2[k] <- paste(lab1[ii],cnxi[j],sep="") ## null space labels => order unchanged order[k] <- order1[ii] pen2[k] <- TRUE k <- k + 1 } } } } ## finished dealing with null space for this margin } ## finished working through margins rm(X1) ## X2 now contains a sequence of model matrices, all but the last ## should have an associated ridge penalty. if (!is.null(ord)) { ## may need to drop some terms ii <- order %in% ord ## terms to retain X2 <- X2[ii] lab2 <- lab2[ii] if (sum(ord==0)==0) no.null <- TRUE ## null space dropped } xc <- unlist(lapply(X2,ncol)) ## number of columns of sub-matrix X <- matrix(unlist(X2),n,sum(xc)) if (!no.null) { xc <- xc[-length(xc)] ## last block unpenalized lab2 <- lab2[-length(lab2)] ## don't need label for unpenalized block } attr(X,"sub.cols") <- xc ## number of columns in each seperately penalized sub matrix attr(X,"p.lab") <- lab2 ## labels for each penalty, identifying how space is constructed ## note that sub.cols/xc only contains dimension of last block if it is penalized X } ## end t2.model.matrix smooth.construct.t2.smooth.spec <- function(object,data,knots) ## the constructor for an ss-anova style tensor product basis object. ## needs to check `by' variable, to see if a centering constraint ## is required. If it is, then it must be applied here. { m <- length(object$margin) # number of marginal bases Xm <- list();Sm <- list();nr <- r <- d <- array(0,m) Pm <- list() ## list for matrices by which to postmultiply raw model matris to get repara version C <- NULL ## potential constraint matrix object$plot.me <- TRUE for (i in 1:m) { ## create marginal model matrices and penalties... ## pick up the required variables.... knt <- dat <- list() term <- object$margin[[i]]$term for (j in 1:length(term)) { dat[[term[j]]] <- data[[term[j]]] knt[[term[j]]] <- knots[[term[j]]] } ## construct marginal smooth... object$margin[[i]]<-smooth.construct(object$margin[[i]],dat,knt) Xm[[i]]<-object$margin[[i]]$X if (!is.null(object$margin[[i]]$te.ok)) { if (object$margin[[i]]$te.ok==0) stop("attempt to use unsuitable marginal smooth class") if (object$margin[[i]]$te.ok==2) object$plot.me <- FALSE ## margin declared itself unplottable } if (length(object$margin[[i]]$S)>1) stop("Sorry, tensor products of smooths with multiple penalties are not supported.") Sm[[i]]<-object$margin[[i]]$S[[1]] d[i]<-nrow(Sm[[i]]) r[i]<-object$margin[[i]]$rank ## rank of penalty for this margin nr[i]<-object$margin[[i]]$null.space.dim ## reparameterize so that penalty is identity (and scaling is nice)... np <- nat.param(Xm[[i]],Sm[[i]],rank=r[i],type=3,unit.fnorm=TRUE) Xm[[i]] <- np$X; dS <- rep(0,ncol(Xm[[i]]));dS[1:r[i]] <- 1; Sm[[i]] <- diag(dS) ## penalty now diagonal Pm[[i]] <- np$P ## maps original model matrix to reparameterized if (!is.null(object$margin[[i]]$C)&& nrow(object$margin[[i]]$C)==0) C <- matrix(0,0,0) ## no centering constraint needed } ## margin creation finished ## Create the model matrix... X <- t2.model.matrix(Xm,r,full=object$full,ord=object$ord) sub.cols <- attr(X,"sub.cols") ## size (cols) of penalized sub blocks ## Create penalties, which are simple non-overlapping ## partial identity matrices... nsc <- length(sub.cols) ## number of penalized sub-blocks of X S <- list() cxn <- c(0,cumsum(sub.cols)) if (nsc>0) for (j in 1:nsc) { dd <- rep(0,ncol(X));dd[(cxn[j]+1):cxn[j+1]] <- 1 S[[j]] <- diag(dd) } names(S) <- attr(X,"p.lab") if (length(object$fx)==1) object$fx <- rep(object$fx,nsc) else if (length(object$fx)!=nsc) { warning("fx length wrong from t2 term: ignored") object$fx <- rep(FALSE,nsc) } if (!is.null(object$sp)&&length(object$sp)!=nsc) { object$sp <- NULL warning("length of sp incorrect in t2: ignored") } object$null.space.dim <- ncol(X) - sum(sub.cols) ## penalty null space rank ## Create identifiability constraint. Key feature is that it ## only affects the unpenalized parameters... nup <- sum(sub.cols[1:nsc]) ## range space rank ##X.shift <- NULL if (is.null(C)) { ## if not null then already determined that constraint not needed if (object$null.space.dim==0) { C <- matrix(0,0,0) } else { ## no null space => no constraint if (object$null.space.dim==1) C <- ncol(X) else ## might as well use set to zero C <- matrix(c(rep(0,nup),colSums(X[,(nup+1):ncol(X),drop=FALSE])),1,ncol(X)) ## constraint on null space ## X.shift <- colMeans(X[,1:nup]) ## X[,1:nup] <- sweep(X[,1:nup],2,X.shift) ## make penalized columns orthog to constant col. ## last is fine because it is equivalent to adding the mean of each col. times its parameter ## to intercept... only parameter modified is the intercept. ## .... amounted to shifting random efects to fixed effects -- not legitimate } } object$X <- X object$S <- S object$C <- C ##object$X.shift <- X.shift if (is.matrix(C)&&nrow(C)==0) object$Cp <- NULL else object$Cp <- matrix(colSums(X),1,ncol(X)) ## alternative constraint for prediction object$df <- ncol(X) object$rank <- sub.cols[1:nsc] ## ranks of individual penalties object$P <- Pm ## map original marginal model matrices to reparameterized versions object$fixed <- as.logical(sum(object$fx)) ## needed by gamm/4 class(object)<-"t2.smooth" object } ## end of smooth.construct.t2.smooth.spec Predict.matrix.t2.smooth <- function(object,data) ## the prediction method for a t2 tensor product smooth { m <- length(object$margin) X <- list() rank <- rep(0,m) for (i in 1:m) { term <- object$margin[[i]]$term dat <- list() for (j in 1:length(term)) dat[[term[j]]] <- data[[term[j]]] X[[i]]<-Predict.matrix(object$margin[[i]],dat)%*%object$P[[i]] rank[i] <- object$margin[[i]]$rank } T <- t2.model.matrix(X,rank,full=object$full,ord=object$ord) T } ## end of Predict.matrix.t2.smooth split.t2.smooth <- function(object) { ## function to split up a t2 smooth into a list of separate smooths if (!inherits(object,"t2.smooth")) return(object) ind <- 1:ncol(object$S[[1]]) ## index of penalty columns ind.para <- object$first.para:object$last.para ## index of coefficients sm <- list() ## list to receive split up smooths sm[[1]] <- object ## stores everything in original object St <- object$S[[1]]*0 for (i in 1:length(object$S)) { ## work through penalties indi <- ind[diag(object$S[[i]])!=0] ## index of penalized coefs. label <- paste(object$label,".frag",i,sep="") sm[[i]] <- list(S = list(object$S[[i]][indi,indi]), ## the penalty first.para = min(ind.para[indi]), last.para = max(ind.para[indi]), fx=object$fx[i],fixed=object$fx[i], sp=object$sp[i], null.space.dim=0, df = length(indi), rank=object$rank[i], label=label, S.scale=object$S.scale[i] ) class(sm[[i]]) <- "t2.frag" St <- St + object$S[[i]] } ## now deal with the null space (alternative would be to append this to one of penalized terms) i <- length(object$S) + 1 indi <- ind[diag(St)==0] ## index of unpenalized elements if (length(indi)) { ## then there are unplenalized elements label <- paste(object$label,".frag",i,sep="") sm[[i]] <- list(S = NULL, ## the penalty first.para = min(ind.para[indi]), last.para = max(ind.para[indi]), fx=TRUE,fixed=TRUE, null.space.dim=0, label = label, df = length(indi) ) class(sm[[i]]) <- "t2.frag" } sm } ## split.t2.smooth expand.t2.smooths <- function(sm) { ## takes a list that may contain `t2.smooth' objects, and expands it into ## a list of `smooths' with single penalties m <- length(sm) not.needed <- TRUE for (i in 1:m) if (inherits(sm[[i]],"t2.smooth")&&length(sm[[i]]$S)>1) { not.needed <- FALSE;break} if (not.needed) return(NULL) smr <- list() ## return list k <- 0 for (i in 1:m) { if (inherits(sm[[i]],"t2.smooth")) { smi <- split.t2.smooth(sm[[i]]) comp.ind <- (k+1):(k+length(smi)) ## index of all fragments making up complete smooth for (j in 1:length(smi)) { k <- k + 1 smr[[k]] <- smi[[j]] smr[[k]]$comp.ind <- comp.ind } } else { k <- k+1; smr[[k]] <- sm[[i]] } } smr ## return expanded list } ## expand.t2.smooths ########################################################## ## Thin plate regression splines (tprs) methods start here ########################################################## null.space.dimension <- function(d,m) # vectorized function for calculating null space dimension for tps penalties of order m # for dimension d data M=(m+d-1)!/(d!(m-1)!). Any m not satisfying 2m>d is reset so # that 2m>d+1 (assuring "visual" smoothness) { if (sum(d<0)) stop("d can not be negative in call to null.space.dimension().") ind <- 2*m < d+1 if (sum(ind)) # then default m required for some elements { m[ind] <- 1;ind <- 2*m < d+2 while (sum(ind)) { m[ind]<-m[ind]+1;ind <- 2*m < d+2;} } M <- m*0+1;ind <- M==1;i <- 0 while(sum(ind)) { M[ind] <- M[ind]*(d[ind]+m[ind]-1-i);i <- i+1;ind <- i1;i <- 2 while(sum(ind)) { M[ind] <- M[ind]/i;ind <- d>i;i <- i+1 } M } ## null.space.dimension smooth.construct.tp.smooth.spec <- function(object,data,knots) ## The constructor for a t.p.r.s. basis object. { shrink <- attr(object,"shrink") ## deal with possible extra arguments of "tp" type smooth xtra <- list() if (is.null(object$xt$max.knots)) xtra$max.knots <- 2000 else xtra$max.knots <- object$xt$max.knots if (is.null(object$xt$seed)) xtra$seed <- 1 else xtra$seed <- object$xt$seed ## now collect predictors x<-array(0,0) shift<-array(0,object$dim) for (i in 1:object$dim) { ## xx <- get.var(object$term[[i]],data) xx <- data[[object$term[i]]] shift[i]<-mean(xx) # centre covariates xx <- xx - shift[i] if (i==1) n <- length(xx) else if (n!=length(xx)) stop("arguments of smooth not same dimension") x<-c(x,xx) } if (is.null(knots)) {knt<-0;nk<-0} else { knt<-array(0,0) for (i in 1:object$dim) { dum <- knots[[object$term[i]]]-shift[i] if (is.null(dum)) {knt<-0;nk<-0;break} # no valid knots for this term knt <- c(knt,dum) nk0 <- length(dum) if (i > 1 && nk != nk0) stop("components of knots relating to a single smooth must be of same length") nk <- nk0 } } if (nk>n) { nk <- 0 warning("more knots than data in a tp term: knots ignored.")} ## deal with possibility of large data set if (nk==0 && n>xtra$max.knots) { ## then there *may* be too many data xu <- uniquecombs(matrix(x,n,object$dim),TRUE) ## find the unique `locations' nu <- nrow(xu) ## number of unique locations if (nu>xtra$max.knots) { ## then there is really a problem seed <- try(get(".Random.seed",envir=.GlobalEnv),silent=TRUE) ## store RNG seed if (inherits(seed,"try-error")) { runif(1) seed <- get(".Random.seed",envir=.GlobalEnv) } kind <- RNGkind(NULL) RNGkind("default","default") set.seed(xtra$seed) ## ensure repeatability nk <- xtra$max.knots ## going to create nk knots ind <- sample(1:nu,nk,replace=FALSE) ## by sampling these rows from xu knt <- as.numeric(xu[ind,]) ## ... like this RNGkind(kind[1],kind[2]) assign(".Random.seed",seed,envir=.GlobalEnv) ## RNG behaves as if it had not been used } } ## end of large data set handling ##if (object$bs.dim[1]<0) object$bs.dim <- 10*3^(object$dim-1) # auto-initialize basis dimension object$p.order[is.na(object$p.order)] <- 0 ## auto-initialize M <- null.space.dimension(object$dim,object$p.order[1]) if (length(object$p.order)>1&&object$p.order[2]==0) object$drop.null <- M else object$drop.null <- 0 def.k <- c(8,27,100) ## default penalty range space dimension for different dimensions dd <- min(object$dim,length(def.k)) if (object$bs.dim[1]<0) object$bs.dim <- M+def.k[dd] ##10*3^(object$dim-1) # auto-initialize basis dimension k<-object$bs.dim if (k0) { ind <- 1:(k-M) if (FALSE) { ## nat param version np <- nat.param(object$X,object$S[[1]],rank=k-M,type=0) object$P <- np$P object$S[[1]] <- diag(np$D) object$X <- np$X[,ind] } else { ## original param object$S[[1]] <- object$S[[1]][ind,ind] object$X <- object$X[,ind] object$cmX <- colMeans(object$X) object$X <- sweep(object$X,2,object$cmX) } object$null.space.dim <- 0 object$df <- object$df - M object$bs.dim <- object$bs.dim -M object$C <- matrix(0,0,ncol(object$X)) # null constraint matrix } class(object) <- "tprs.smooth" object } ## smooth.construct.tp.smooth.spec smooth.construct.ts.smooth.spec <- function(object,data,knots) # implements a class of tprs like smooths with an additional shrinkage # term in the penalty... this allows for fully integrated GCV model selection { attr(object,"shrink") <- 1e-1 object <- smooth.construct.tp.smooth.spec(object,data,knots) class(object) <- "ts.smooth" object } ## smooth.construct.ts.smooth.spec Predict.matrix.tprs.smooth <- function(object,data) # prediction matrix method for a t.p.r.s. term { x<-array(0,0) for (i in 1:object$dim) { xx <- data[[object$term[i]]] xx <- xx - object$shift[i] if (i==1) n <- length(xx) else if (length(xx)!=n) stop("arguments of smooth not same dimension") if (length(xx)<1) stop("no data to predict at") x<-c(x,xx) } by<-0;by.exists<-FALSE ## following used to be object$null.space.dim, but this is now *post constraint* M <- null.space.dimension(object$dim,object$p.order[1]) ind <- 1:object$bs.dim if (is.null(object$drop.null)) object$drop.null <- 0 ## pre 1.7_19 compatibility if (object$drop.null>0) object$bs.dim <- object$bs.dim + M X<-matrix(0,n,object$bs.dim) oo<-.C(C_predict_tprs,as.double(x),as.integer(object$dim),as.integer(n),as.integer(object$p.order[1]), as.integer(object$bs.dim),as.integer(M),as.double(object$Xu), as.integer(nrow(object$Xu)),as.double(object$UZ),as.double(by),as.integer(by.exists),X=as.double(X)) X<-matrix(oo$X,n,object$bs.dim) if (object$drop.null>0) { if (FALSE) { ## nat param X <- (X%*%object$P)[,ind] ## drop null space } else { ## original X <- X[,ind] X <- sweep(X,2,object$cmX) } } X } ## Predict.matrix.tprs.smooth Predict.matrix.ts.smooth <- function(object,data) # this is the prediction method for a t.p.r.s # with shrinkage { Predict.matrix.tprs.smooth(object,data) } ## Predict.matrix.ts.smooth ############################################# ## Cubic regression spline methods start here ############################################# smooth.construct.cr.smooth.spec <- function(object,data,knots) { # this routine is the constructor for cubic regression spline basis objects # It takes a cubic regression spline specification object and returns the # corresponding basis object. Efficient code. shrink <- attr(object,"shrink") if (length(object$term)!=1) stop("Basis only handles 1D smooths") x <- data[[object$term]] nx <- length(x) if (is.null(knots)) ok <- FALSE else { k <- knots[[object$term]] if (is.null(k)) ok <- FALSE else ok<-TRUE } if (object$bs.dim < 0) object$bs.dim <- 10 ## default if (object$bs.dim <3) { object$bs.dim <- 3 warning("basis dimension, k, increased to minimum possible\n") } xu <- unique(x) nk <- object$bs.dim if (length(xu)n) stop("more knots than unique data values is not allowed") if (nk<2) stop("too few knots") if (nk==2) return(range(x)) delta<-(n-1)/(nk-1) # how many data steps per knot lbi<-floor(delta*1:(nk-2))+1 # lower interval bound index frac<-delta*1:(nk-2)+1-lbi # left over proportion of interval x.shift<-x[-1] knot<-array(0,nk) knot[nk]<-x[n];knot[1]<-x[1] knot[2:(nk-1)]<-x[lbi]*(1-frac)+x.shift[lbi]*frac knot } ## place.knots smooth.construct.cc.smooth.spec <- function(object,data,knots) # constructor function for cyclic cubic splines { getBD<-function(x) # matrices B and D in expression Bm=Dp where m are s"(x_i) and # p are s(x_i) and the x_i are knots of periodic spline s(x) # B and D slightly modified (for periodicity) from Lancaster # and Salkauskas (1986) Curve and Surface Fitting section 4.7. { n<-length(x) h<-x[2:n]-x[1:(n-1)] n<-n-1 D<-B<-matrix(0,n,n) B[1,1]<-(h[n]+h[1])/3;B[1,2]<-h[1]/6;B[1,n]<-h[n]/6 D[1,1]<- -(1/h[1]+1/h[n]);D[1,2]<-1/h[1];D[1,n]<-1/h[n] for (i in 2:(n-1)) { B[i,i-1]<-h[i-1]/6 B[i,i]<-(h[i-1]+h[i])/3 B[i,i+1]<-h[i]/6 D[i,i-1]<-1/h[i-1] D[i,i]<- -(1/h[i-1]+1/h[i]) D[i,i+1]<- 1/h[i] } B[n,n-1]<-h[n-1]/6;B[n,n]<-(h[n-1]+h[n])/3;B[n,1]<-h[n]/6 D[n,n-1]<-1/h[n-1];D[n,n]<- -(1/h[n-1]+1/h[n]);D[n,1]<-1/h[n] list(B=B,D=D) } # end of getBD local function # evaluate covariate, x, and knots, k. if (length(object$term)!=1) stop("Basis only handles 1D smooths") x <- data[[object$term]] if (object$bs.dim < 0 ) object$bs.dim <- 10 ## default if (object$bs.dim <4) { object$bs.dim <- 4 warning("basis dimension, k, increased to minimum possible\n") } nk <- object$bs.dim k <- knots[[object$term]] if (is.null(k)) k <- place.knots(x,nk) if (length(k)==2) { k <- place.knots(c(k,x),nk) } if (length(k)!=nk) stop("number of supplied knots != k for a cc smooth") um<-getBD(k) BD<-solve(um$B,um$D) # s"(k)=BD%*%s(k) where k are knots minus last knot if (!object$fixed) { object$S<-list(t(um$D)%*%BD) # the penalty object$S[[1]]<-(object$S[[1]]+t(object$S[[1]]))/2 # ensure exact symmetry } object$BD<-BD # needed for prediction object$xp<-k # needed for prediction X<-Predict.matrix.cyclic.smooth(object,data) object$X<-X object$rank<-ncol(X)-1 # rank of smoother matrix object$df<-object$bs.dim-1 # degrees of freedom, accounting for cycling object$null.space.dim <- 1 class(object)<-"cyclic.smooth" object$noterp <- TRUE # do not re-parameterize in te object } ## smooth.construct.cc.smooth.spec cwrap <- function(x0,x1,x) { ## map x onto [x0,x1] in manner suitable for cyclic smooth on ## [x0,x1]. h <- x1-x0 if (max(x)>x1) { ind <- x>x1 x[ind] <- x0 + (x[ind]-x1)%%h } if (min(x)max(knots)||min(x)min(x)||x10) warning("knot range is so wide that there is *no* information about some basis coefficients") } ## now construct penalty... p.ord <- m[2] np <- ncol(object$X) if (p.ord>np-1) stop("penalty order too high for basis dimension") De <- diag(np + p.ord) if (p.ord>0) { for (i in 1:p.ord) De <- diff(De) D <- De[,-(1:p.ord)] D[,(np-p.ord+1):np] <- D[,(np-p.ord+1):np] + De[,1:p.ord] } else D <- De object$S <- list(t(D)%*%D) # get penalty ## other stuff... object$rank <- np-1 # penalty rank object$null.space.dim <- 1 # dimension of unpenalized space object$knots <- k; object$m <- m # store p-spline specific info. class(object)<-"cpspline.smooth" # Give object a class object } ## smooth.construct.cp.smooth.spec Predict.matrix.cpspline.smooth <- function(object,data) ## prediction method function for the cpspline smooth class { x <- data[[object$term]] k0 <- min(object$knots);k1 <- max(object$knots) if (min(x)k1) x <- cwrap(k0,k1,x) X <- cSplineDes(x,object$knots,object$m[1]+2) X } ## Predict.matrix.cpspline.smooth ############################## ## P-spline methods start here ############################## smooth.construct.ps.smooth.spec <- function(object,data,knots) # a p-spline constructor method function { ##require(splines) if (length(object$p.order)==1) m <- rep(object$p.order,2) else m <- object$p.order # m[1] - basis order, m[2] - penalty order m[is.na(m)] <- 2 ## default object$p.order <- m if (object$bs.dim<0) object$bs.dim <- max(10,m[1]+1) ## default nk <- object$bs.dim - m[1] # number of interior knots if (nk<=0) stop("basis dimension too small for b-spline order") if (length(object$term)!=1) stop("Basis only handles 1D smooths") x <- data[[object$term]] # find the data k <- knots[[object$term]] if (is.null(k)) { xl <- min(x);xu <- max(x) } else if (length(k)==2) { xl <- min(k);xu <- max(k); if (xl>min(x)||xu0) warning("there is *no* information about some basis coefficients") } if (length(unique(x)) < object$bs.dim) warning("basis dimension is larger than number of unique covariates") ## check and set montonic parameterization indicator: 1 increase, -1 decrease, 0 no constraint if (is.null(object$mono)) object$mono <- 0 if (object$mono!=0) { ## scop-spline requested p <- ncol(object$X) B <- matrix(as.numeric(rep(1:p,p)>=rep(1:p,each=p)),p,p) ## coef summation matrix if (object$mono < 0) B[,2:p] <- -B[,2:p] ## monotone decrease case object$D <- cbind(0,-diff(diag(p-1))) if (object$mono==2||object$mono==-2) { ## drop intercept term object$D <- object$D[,-1] B <- B[,-1] object$null.space.dim <- 1 object$g.index <- rep(TRUE,p-1) object$C <- matrix(0,0,ncol(object$X)) # null constraint matrix } else { object$g.index <- c(FALSE,rep(TRUE,p-1)) object$null.space.dim <- 2 } ## ... g.index is indicator of which coefficients must be positive (exponentiated) object$X <- object$X %*% B object$S <- list(crossprod(object$D)) ## penalty for a scop-spline object$B <- B object$rank <- p-2 } else { ## now construct conventional P-spline penalty object$D <- S <- if (m[2]>0) diff(diag(object$bs.dim),differences=m[2]) else diag(object$bs.dim); ## if (m[2]) for (i in 1:m[2]) S <- diff(S) ##object$S <- list(t(S)%*%S) # get penalty ##object$S[[1]] <- (object$S[[1]]+t(object$S[[1]]))/2 # exact symmetry object$S <- list(crossprod(S)) object$rank <- object$bs.dim-m[2] # penalty rank object$null.space.dim <- m[2] # dimension of unpenalized space } object$knots <- k; object$m <- m # store p-spline specific info. class(object)<-"pspline.smooth" # Give object a class object } ### end of p-spline constructor Predict.matrix.pspline.smooth <- function(object,data) # prediction method function for the p.spline smooth class { ##require(splines) m <- object$m[1]+1 ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (is.null(object$deriv)) object$deriv <- 0 if (sum(ind)==n) { ## all in range X <- splines::spline.des(object$knots,x,m,rep(object$deriv,n))$design } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- splines::spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix nin <- sum(ind) if (nin>0) X[ind,] <- splines::spline.des(object$knots,x[ind],m,rep(object$deriv,nin))$design ## interior rows ## Now add rows for linear extrapolation (of smooth itself)... if (object$deriv<2) { ## under linear extrapolation higher derivatives vanish. ind <- x < ll if (sum(ind)>0) X[ind,] <- if (object$deriv==0) cbind(1,x[ind]-ll)%*%D[1:2,] else matrix(D[2,],sum(ind),ncol(D),byrow=TRUE) ind <- x > ul if (sum(ind)>0) X[ind,] <- if (object$deriv==0) cbind(1,x[ind]-ul)%*%D[3:4,] else matrix(D[4,],sum(ind),ncol(D),byrow=TRUE) } } if (object$mono==0) X else X %*% object$B } ## Predict.matrix.pspline.smooth ############################## ## B-spline methods start here ############################## smooth.construct.bs.smooth.spec <- function(object,data,knots) { ## a B-spline constructor method function ## get orders: m[1] is spline order, 3 is cubic. m[2] is order of derivative in penalty. if (length(object$p.order)==1) m <- c(object$p.order,max(0,object$p.order-1)) else m <- object$p.order # m[1] - basis order, m[2] - penalty order if (is.na(m[1])) if (is.na(m[2])) m <- c(3,2) else m[1] <- m[2] + 1 if (is.na(m[2])) m[2] <- max(0,m[1]-1) object$m <- object$p.order <- m if (object$bs.dim<0) object$bs.dim <- max(10,m[1]) ## default nk <- object$bs.dim - m[1] + 1 # number of interior knots if (nk<=0) stop("basis dimension too small for b-spline order") if (length(object$term)!=1) stop("Basis only handles 1D smooths") x <- data[[object$term]] # find the data k <- knots[[object$term]] if (is.null(k)) { xl <- min(x);xu <- max(x) } else if (length(k)==2) { xl <- min(k);xu <- max(k); if (xl>min(x)||xu0) warning("there is *no* information about some basis coefficients") } if (length(unique(x)) < object$bs.dim) warning("basis dimension is larger than number of unique covariates") ## now construct derivative based penalty. Order of derivate ## is equal to m, which is only a conventional spline in the ## cubic case... object$knots <- k; class(object) <- "Bspline.smooth" # Give object a class k0 <- k[m[1]+1:nk] ## the interior knots object$deriv <- m[2] pord <- m[1]-m[2] ## order of derivative polynomial 0 is step function if (pord<0) stop("requested non-existent derivative in B-spline penalty") h <- diff(k0) ## the difference sequence... ## now create the sequence at which to obtain derivatives if (pord==0) k1 <- (k0[2:nk]+k0[1:(nk-1)])/2 else { h1 <- rep(h/pord,each=pord) k1 <- cumsum(c(k0[1],h1)) } dat <- data.frame(k1);names(dat) <- object$term D <- Predict.matrix.Bspline.smooth(object,dat) ## evaluate basis for mth derivative at the k1 object$deriv <- NULL ## reset or the smooth object will be set to evaluate derivs in prediction! if (pord==0) { ## integrand is just a step function... object$D <- sqrt(h)*D } else { ## integrand is a piecewise polynomial... P <- solve(matrix(rep(seq(-1,1,length=pord+1),pord+1)^rep(0:pord,each=pord+1),pord+1,pord+1)) i1 <- rep(1:(pord+1),pord+1)+rep(1:(pord+1),each=pord+1) ## i + j H <- matrix((1+(-1)^(i1-2))/(i1-1),pord+1,pord+1) W1 <- t(P)%*%H%*%P h <- h/2 ## because we map integration interval to to [-1,1] for maximum stability ## Create the non-zero diagonals of the W matrix... ld0 <- rep(sdiag(W1),length(h))*rep(h,each=pord+1) i1 <- c(rep(1:pord,length(h)) + rep(0:(length(h)-1) * (pord+1),each=pord),length(ld0)) ld <- ld0[i1] ## extract elements for leading diagonal i0 <- 1:(length(h)-1)*pord+1 i2 <- 1:(length(h)-1)*(pord+1) ld[i0] <- ld[i0] + ld0[i2] ## add on extra parts for overlap B <- matrix(0,pord+1,length(ld)) B[1,] <- ld for (k in 1:pord) { ## create the other diagonals... diwk <- sdiag(W1,k) ## kth diagonal of W1 ind <- 1:(length(ld)-k) B[k+1,ind] <- (rep(h,each=pord)*rep(c(diwk,rep(0,k-1)),length(h)))[ind] } ## ... now B contains the non-zero diagonals of W B <- bandchol(B) ## the banded cholesky factor. ## Pre-Multiply D by the Cholesky factor... D1 <- B[1,]*D for (k in 1:pord) { ind <- 1:(nrow(D)-k) D1[ind,] <- D1[ind,] + B[k+1,ind] * D[ind+k,] } object$D <- D1 } object$S <- list(crossprod(object$D)) object$rank <- object$bs.dim-m[2] # penalty rank object$null.space.dim <- m[2] # dimension of unpenalized space object } ### end of B-spline constructor Predict.matrix.Bspline.smooth <- function(object,data) { object$mono <- 0 object$m <- object$m - 1 ## for consistency with p-spline defn of m Predict.matrix.pspline.smooth(object,data) } ####################################################################### # Smooth-factor interactions. Efficient alternative to s(x,by=fac,id=1) ####################################################################### smooth.construct.fs.smooth.spec <- function(object,data,knots) { ## Smooths in which one covariate is a factor. Generates a smooth ## for each level of the factor, with penalties on null space ## components. Smooths are not centred. xt element specifies basis ## to use for smooths. Only one smoothing parameter for the whole term. ## If called from gamm, is set up for efficient computation by nesting ## smooth within factor. ## Unsuitable for tensor products. if (!is.null(attr(object,"gamm"))) gamm <- TRUE else ## signals call from gamm gamm <- FALSE if (is.null(object$xt)) object$base.bs <- "tp" ## default smooth class else if (is.list(object$xt)) { if (is.null(object$xt$bs)) object$base.bs <- "tp" else object$base.bs <- object$xt$bs } else { object$base.bs <- object$xt object$xt <- NULL ## avoid messing up call to base constructor } object$base.bs <- paste(object$base.bs,".smooth.spec",sep="") fterm <- NULL ## identify the factor variable for (i in 1:length(object$term)) if (is.factor(data[[object$term[i]]])) { if (is.null(fterm)) fterm <- object$term[i] else stop("fs smooths can only have one factor argument") } ## deal with no factor case, just base smooth constructor if (is.null(fterm)) { class(object) <- object$base.bs return(smooth.construct(object,data,knots)) } ## deal with factor only case, just transfer to "re" class if (length(object$term)==1) { class(object) <- "re.smooth.spec" return(smooth.construct(object,data,knots)) } ## Now remove factor term from data... fac <- data[[fterm]] data[[fterm]] <- NULL k <- 1 oterm <- object$term ## and strip it from the terms... for (i in 1:object$dim) if (object$term[i]!=fterm) { object$term[k] <- object$term[i] k <- k + 1 } object$term <- object$term[-object$dim] object$dim <- length(object$term) ## call base constructor... spec.class <- class(object) class(object) <- object$base.bs object <- smooth.construct(object,data,knots) if (length(object$S)>1) stop("\"fs\" smooth cannot use a multiply penalized basis (wrong basis in xt)") ## save some base smooth information object$base <- list(bs=class(object),bs.dim=object$bs.dim, rank=object$rank,null.space.dim=object$null.space.dim, term=object$term) object$term <- oterm ## restore original term list ## Re-parameterize to separate out null space. rp <- nat.param(object$X,object$S[[1]],rank=object$rank,type=3) ## copy range penalty and create null space penalties... null.d <- ncol(object$X) - object$rank ## null space dim object$S[[1]] <- diag(c(rp$D,rep(0,null.d))) ## range space penalty for (i in 1:null.d) { ## create null space element penalties object$S[[i+1]] <- object$S[[1]]*0 object$S[[i+1]][object$rank+i,object$rank+i] <- 1 } object$P <- rp$P ## X' = X%*%P, where X is original version object$fterm <- fterm ## the factor name... if (!is.factor(fac)) warning("no factor supplied to fs smooth") object$flev <- levels(fac) ## now full penalties ... #fullS <- list() #fullS[[1]] <- diag(rep(c(rp$D,rep(0,null.d)),nf)) ## range space penalties #for (i in 1:null.d) { ## null space penalties # um <- rep(0,ncol(rp$X));um[object$rank+i] <- 1 # fullS[[i+1]] <- diag(rep(um,nf)) #} ## Now the model matrix if (gamm) { ## no duplication, gamm will handle this by nesting if (object$fixed==TRUE) stop("\"fs\" terms can not be fixed here") object$X <- rp$X object$fac <- fac ## gamm should use this for grouping object$te.ok <- 0 ## would break special handling ## rank?? } else { ## duplicate model matrix columns, and penalties... nf <- length(object$flev) ## creating the model matrix... object$X <- rp$X * as.numeric(fac==object$flev[1]) if (nf>1) for (i in 2:nf) { object$X <- cbind(object$X,rp$X * as.numeric(fac==object$flev[i])) } ## now penalties... #object$S <- fullS object$S[[1]] <- diag(rep(c(rp$D,rep(0,null.d)),nf)) ## range space penalties for (i in 1:null.d) { ## null space penalties um <- rep(0,ncol(rp$X));um[object$rank+i] <- 1 object$S[[i+1]] <- diag(rep(um,nf)) } object$bs.dim <- ncol(object$X) object$te.ok <- 0 object$rank <- c(object$rank*nf,rep(nf,null.d)) } object$side.constrain <- FALSE ## don't apply side constraints - these are really random effects object$null.space.dim <- 0 object$C <- matrix(0,0,ncol(object$X)) # null constraint matrix object$plot.me <- TRUE class(object) <- if ("tensor.smooth.spec"%in%spec.class) c("fs.interaction","tensor.smooth") else "fs.interaction" if ("tensor.smooth.spec"%in%spec.class) { ## give object margins like a tensor product smooth... ## need just enough for fitting and discrete prediction to work object$margin <- list() if (object$dim>1) stop("fs smooth not suitable for discretisation with more than one metric predictor") form1 <- as.formula(paste("~",object$fterm,"-1")) fac -> data[[fterm]] object$margin[[1]] <- list(X=model.matrix(form1,data),term=object$fterm,form=form1,by="NA") class(object$margin[[1]]) <- "random.effect" object$margin[[2]] <- object object$margin[[2]]$X <- rp$X object$margin[[2]]$margin.only <- TRUE ## list(X=rp$X,term=object$base$term,base=object$base,margin.only=TRUE,P=object$P,by="NA") ## class(object$margin[[2]]) <- "fs.interaction" ## note --- no re-ordering at present - inefficiecnt as factor should really ## be last, but that means complete re-working of penalty structure. } ## finished tensor like setup object } ## end of smooth.construct.fs.smooth.spec Predict.matrix.fs.interaction <- function(object,data) # prediction method function for the smooth-factor interaction class { ## first remove factor from the data... fac <- data[[object$fterm]] data[[object$fterm]] <- NULL ## now get base prediction matrix... class(object) <- object$base$bs object$rank <- object$base$rank object$null.space.dim <- object$base$null.space.dim object$bs.dim <- object$base$bs.dim object$term <- object$base$term Xb <- Predict.matrix(object,data)%*%object$P if (!is.null(object$margin.only)) return(Xb) X <- matrix(0,nrow(Xb),0) for (i in 1:length(object$flev)) { X <- cbind(X,Xb * as.numeric(fac==object$flev[i])) } X } ## Predict.matrix.fs.interaction ########################################## ## Adaptive smooth constructors start here ########################################## mfil <- function(M,i,j,m) { ## sets M[i[k],j[k]] <- m[k] for all k in 1:length(m) without ## looping.... nr <- nrow(M) a <- as.numeric(M) k <- (j-1)*nr+i a[k] <- m matrix(a,nrow(M),ncol(M)) } ## mfil D2 <- function(ni=5,nj=5) { ## Function to obtain second difference matrices for ## coefficients notionally on a regular ni by nj grid ## returns second order differences in each direction + ## mixed derivative, scaled so that ## t(Dcc)%*%Dcc + t(Dcr)%*%Dcr + t(Drr)%*%Drr ## is the discrete analogue of a thin plate spline penalty ## (the 2 on the mixed derivative has been absorbed) Ind <- matrix(1:(ni*nj),ni,nj) ## the indexing matrix rmt <- rep(1:ni,nj) ## the row index cmt <- rep(1:nj,rep(ni,nj)) ## the column index ci <- Ind[2:(ni-1),1:nj] ## column index n.ci <- length(ci) Drr <- matrix(0,n.ci,ni*nj) ## difference matrices rr.ri <- rmt[ci] ## index to coef array row rr.ci <- cmt[ci] ## index to coef array column Drr <- mfil(Drr,1:n.ci,ci,-2) ## central coefficient ci <- Ind[1:(ni-2),1:nj] Drr <- mfil(Drr,1:n.ci,ci,1) ## back coefficient ci <- Ind[3:ni,1:nj] Drr <- mfil(Drr,1:n.ci,ci,1) ## forward coefficient ci <- Ind[1:ni,2:(nj-1)] ## column index n.ci <- length(ci) Dcc <- matrix(0,n.ci,ni*nj) ## difference matrices cc.ri <- rmt[ci] ## index to coef array row cc.ci <- cmt[ci] ## index to coef array column Dcc <- mfil(Dcc,1:n.ci,ci,-2) ## central coefficient ci <- Ind[1:ni,1:(nj-2)] Dcc <- mfil(Dcc,1:n.ci,ci,1) ## back coefficient ci <- Ind[1:ni,3:nj] Dcc <- mfil(Dcc,1:n.ci,ci,1) ## forward coefficient ci <- Ind[2:(ni-1),2:(nj-1)] ## column index n.ci <- length(ci) Dcr <- matrix(0,n.ci,ni*nj) ## difference matrices cr.ri <- rmt[ci] ## index to coef array row cr.ci <- cmt[ci] ## index to coef array column ci <- Ind[1:(ni-2),1:(nj-2)] Dcr <- mfil(Dcr,1:n.ci,ci,sqrt(0.125)) ## -- coefficient ci <- Ind[3:ni,3:nj] Dcr <- mfil(Dcr,1:n.ci,ci,sqrt(0.125)) ## ++ coefficient ci <- Ind[1:(ni-2),3:nj] Dcr <- mfil(Dcr,1:n.ci,ci,-sqrt(0.125)) ## -+ coefficient ci <- Ind[3:ni,1:(nj-2)] Dcr <- mfil(Dcr,1:n.ci,ci,-sqrt(0.125)) ## +- coefficient list(Dcc=Dcc,Drr=Drr,Dcr=Dcr,rr.ri=rr.ri,rr.ci=rr.ci,cc.ri=cc.ri, cc.ci=cc.ci,cr.ri=cr.ri,cr.ci=cr.ci,rmt=rmt,cmt=cmt) } ## D2 smooth.construct.ad.smooth.spec <- function(object,data,knots) ## an adaptive p-spline constructor method function ## This is the simplifies and more efficient version... { bs <- object$xt$bs if (length(bs)>1) bs <- bs[1] if (is.null(bs)) { ## use default bases bs <- "ps" } else { # bases supplied, need to sanity check if (!bs%in%c("cc","cr","ps","cp")) bs[1] <- "ps" } if (bs == "cc"||bs=="cp") bsp <- "cp" else bsp <- "ps" ## if basis is cyclic, then so should penalty if (object$dim> 2 ) stop("the adaptive smooth class is limited to 1 or 2 covariates.") else if (object$dim==1) { ## following is 1D case... if (object$bs.dim < 0) object$bs.dim <- 40 ## default if (is.na(object$p.order[1])) object$p.order[1] <- 5 pobject <- object pobject$p.order <- c(2,2) class(pobject) <- paste(bs[1],".smooth.spec",sep="") ## get basic spline object... if (is.null(knots)&&bs[1]%in%c("cr","cc")) { ## must create knots x <- data[[object$term]] knots <- list(seq(min(x),max(x),length=object$bs.dim)) names(knots) <- object$term } ## end of knot creation pspl <- smooth.construct(pobject,data,knots) nk <- ncol(pspl$X) k <- object$p.order[1] ## penalty basis size if (k>=nk-2) stop("penalty basis too large for smoothing basis") if (k <= 0) { ## no penalty pspl$fixed <- TRUE pspl$S <- NULL } else if (k>=2) { ## penalty basis needed ... x <- 1:(nk-2)/nk;m=2 ## All elements of V must be >=0 for all S[[l]] to be +ve semi-definite if (k==2) V <- cbind(rep(1,nk-2),x) else if (k==3) { m <- 1 ps2 <- smooth.construct(s(x,k=k,bs=bsp,m=m,fx=TRUE),data=data.frame(x=x),knots=NULL) V <- ps2$X } else { ## general penalty basis construction... ps2 <- smooth.construct(s(x,k=k,bs=bsp,m=m,fx=TRUE),data=data.frame(x=x),knots=NULL) V <- ps2$X } Db<-diff(diff(diag(nk))) ## base difference matrix ##D <- list() # for (i in 1:k) D[[i]] <- as.numeric(V[,i])*Db # L <- matrix(0,k*(k+1)/2,k) S <- list() for (i in 1:k) { S[[i]] <- t(Db)%*%(as.numeric(V[,i])*Db) ind <- rowSums(abs(S[[i]]))>0 ev <- eigen(S[[i]][ind,ind],symmetric=TRUE,only.values=TRUE)$values pspl$rank[i] <- sum(ev>max(ev)*.Machine$double.eps^.9) } pspl$S <- S } } else if (object$dim==2){ ## 2D case ## first task is to obtain a tensor product basis object$bs.dim[object$bs.dim<0] <- 15 ## default k <- object$bs.dim;if (length(k)==1) k <- c(k[1],k[1]) tec <- paste("te(",object$term[1],",",object$term[2],",bs=bs,k=k,m=2)",sep="") pobject <- eval(parse(text=tec)) ## tensor smooth specification object pobject$np <- FALSE ## do not re-parameterize if (is.null(knots)&&bs[1]%in%c("cr","cc")) { ## create suitable knots for (i in 1:2) { x <- data[[object$term[i]]] knots <- list(seq(min(x),max(x),length=k[i])) names(knots)[i] <- object$term[i] } } ## finished knots pspl <- smooth.construct(pobject,data,knots) ## create basis ## now need to create the adaptive penalties... ## First the penalty basis... kp <- object$p.order if (length(kp)!=2) kp <- c(kp[1],kp[1]) kp[is.na(kp)] <- 3 ## default kp.tot <- prod(kp);k.tot <- (k[1]-2)*(k[2]-2) ## rows of Difference matrices if (kp.tot > k.tot) stop("penalty basis too large for smoothing basis") if (kp.tot <= 0) { ## no penalty pspl$fixed <- TRUE pspl$S <- NULL } else { ## penalized, but how? Db <- D2(ni=k[1],nj=k[2]) ## get the difference-on-grid matrices pspl$S <- list() ## delete original S list if (kp.tot==1) { ## return a single fixed penalty pspl$S[[1]] <- t(Db[[1]])%*%Db[[1]] + t(Db[[2]])%*%Db[[2]] + t(Db[[3]])%*%Db[[3]] pspl$rank <- ncol(pspl$S[[1]]) - 3 } else { ## adaptive if (kp.tot==3) { ## planar adaptiveness V <- cbind(rep(1,k.tot),Db[[4]],Db[[5]]) } else { ## spline adaptive penalty... ## first check sanity of basis dimension request ok <- TRUE if (sum(kp<2)) ok <- FALSE if (!ok) stop("penalty basis too small") m <- min(min(kp)-2,1); m<-c(m,m);j <- 1 ps2 <- smooth.construct(te(i,j,bs=bsp,k=kp,fx=TRUE,m=m,np=FALSE), data=data.frame(i=Db$rmt,j=Db$cmt),knots=NULL) Vrr <- Predict.matrix(ps2,data.frame(i=Db$rr.ri,j=Db$rr.ci)) Vcc <- Predict.matrix(ps2,data.frame(i=Db$cc.ri,j=Db$cc.ci)) Vcr <- Predict.matrix(ps2,data.frame(i=Db$cr.ri,j=Db$cr.ci)) } ## spline adaptive basis finished ## build penalty list S <- list() for (i in 1:kp.tot) { S[[i]] <- t(Db$Drr)%*%(as.numeric(Vrr[,i])*Db$Drr) + t(Db$Dcc)%*%(as.numeric(Vcc[,i])*Db$Dcc) + t(Db$Dcr)%*%(as.numeric(Vcr[,i])*Db$Dcr) ev <- eigen(S[[i]],symmetric=TRUE,only.values=TRUE)$values pspl$rank[i] <- sum(ev>max(ev)*.Machine$double.eps*10) } pspl$S <- S pspl$pen.smooth <- ps2 ## the penalty smooth object } ## adaptive penalty finished } ## penalized case finished } pspl$te.ok <- 0 ## not suitable as a tensor product marginal pspl } ## end of smooth.construct.ad.smooth.spec ######################################################## # Random effects terms start here. Plot method in plot.r ######################################################## smooth.construct.re.smooth.spec <- function(object,data,knots) ## a simple random effects constructor method function ## basic idea is that s(x,f,z,...,bs="re") generates model matrix ## corresponding to ~ x:f:z: ... - 1. Corresponding coefficients ## have an identity penalty. If object inherits from "tensor.smooth.spec" ## then terms depending on more than one variable are set up with a te ## smooth like structure (used e.g. in bam(...,discrete=TRUE)) { ## id's with factor variables are problematic - should terms have ## same levels, or just same number of levels, for example? ## => ruled out if (!is.null(object$id)) stop("random effects don't work with ids.") form <- as.formula(paste("~",paste(object$term,collapse=":"),"-1")) object$X <- model.matrix(form,data) object$bs.dim <- ncol(object$X) if (inherits(object,"tensor.smooth.spec")) { ## give object margins like a tensor product smooth... object$margin <- list() maxd <- maxi <- 0 for (i in 1:object$dim) { form1 <- as.formula(paste("~",object$term[i],"-1")) object$margin[[i]] <- list(X=model.matrix(form1,data),term=object$term[i],form=form1,by="NA") class(object$margin[[i]]) <- "random.effect" d <- ncol(object$margin[[i]]$X) if (d>maxd) {maxi <- i;maxd <- d} } ## now re-order so that largest margin is last... if (maxi= lo1)|(hi1[k] <= hi1 & hi1[k] >= lo1)| (lo1 <= hi1[k] & lo1 >= lo1[k])|(hi1 <= hi1[k] & hi1 >= lo1[k]) ol2 <- (lo2[k] <= hi2 & lo2[k] >= lo2)|(hi2[k] <= hi2 & hi2[k] >= lo2)| (lo2 <= hi2[k] & lo2 >= lo2[k])|(hi2 <= hi2[k] & hi2 >= lo2[k]) ol <- ol1&ol2;ol[k] <- FALSE ind <- (1:n.poly)[ol] ## index of potential neighbours of poly k ## co-ordinates of polygon k... cok <- pc[[k]] if (length(ind)>0) for (j in 1:length(ind)) { co <- rbind(pc[[ind[j]]],cok) cou <- uniquecombs(co) n.shared <- nrow(co) - nrow(cou) ## if there are common vertices add area from which j comes ## to vector of neighbour indices if (n.shared>0) nb[[k]] <- c(nb[[k]],ind[j]) } } for (i in 1:length(pc)) nb[[i]] <- unique(nb[[i]]) names(nb) <- names(pc) list(nb=nb,xlim=c(min(lo1),max(hi1)),ylim=c(min(lo2),max(hi2))) } ## end of pol2nb smooth.construct.mrf.smooth.spec <- function(object, data, knots) { ## Argument should be factor or it will be coerced to factor ## knots = vector of all regions (may include regions with no data) ## xt must contain at least one of ## * `penalty' - a penalty matrix, with row and column names corresponding to the ## levels of the covariate, or the knots. ## * `polys' - a list of lists of polygons, defining the areas, names(polys) must correspond ## to the levels of the covariate or the knots. polys[[i]] is ## a 2 column matrix defining the vertices of polygons defining area i's boundary. ## If there are several polygons they should be separated by an NA row. ## * `nb' - is a list defining the neighbourhood structure. names(nb) must correspond to ## the levels of the covariate or knots. nb[[i]][j] is the index of the jth neighbour ## of area i. i.e. the jth neighbour of area names(nb)[i] is area names(nb)[nb[[i]][j]]. ## Being a neighbour should be a symmetric state!! ## `polys' is only stored for subsequent plotting if `nb' or `penalty' are supplied. ## If `penalty' is supplied it is always used. ## If `penalty' is not supplied then it is computed from `nb', which is in turn computed ## from `polys' if `nb' is missing. ## Modified from code by Thomas Kneib. if (!is.factor(data[[object$term]])) warning("argument of mrf should be a factor variable") x <- as.factor(data[[object$term]]) k <- knots[[object$term]] if (is.null(k)) { k <- as.factor(levels(x)) # default knots = all regions in the data } else k <- as.factor(k) if (object$bs.dim<0) object$bs.dim <- length(levels(k)) if (object$bs.dim>length(levels(k))) stop("MRF basis dimension set too high") if (sum(!levels(x)%in%levels(k))) stop("data contain regions that are not contained in the knot specification") ##levels(x) <- levels(k) ## to allow for regions with no data x <- factor(x,levels=levels(k)) ## to allow for regions with no data object$X <- model.matrix(~x-1,data.frame(x=x)) ## model matrix ## now set up the penalty... if(is.null(object$xt)) stop("penalty matrix, boundary polygons and/or neighbours list must be supplied in xt") ## If polygons supplied as list with duplicated names, then re-format... if (!is.null(object$xt$polys)) { a.name <- names(object$xt$polys) d.name <- unique(a.name[duplicated(a.name)]) ## find duplicated names if (length(d.name)) { ## deal with duplicates for (i in 1:length(d.name)) { ind <- (1:length(a.name))[a.name==d.name[i]] ## index of duplicates for (j in 2:length(ind)) object$xt$polys[[ind[1]]] <- ## combine matrices for duplicate names rbind(object$xt$polys[[ind[1]]],c(NA,NA),object$xt$polys[[ind[j]]]) } ## now delete the un-wanted duplicates... ind <- (1:length(a.name))[duplicated(a.name)] if (length(ind)>0) for (i in length(ind):1) object$xt$polys[[ind[i]]] <- NULL } object$plot.me <- TRUE object$dim <- 2 ## signal that it's really 2D here to avoid attempt to plot in te term ## polygon list in correct format } else { object$plot.me <- FALSE ## can't plot without polygon information } ## actual penalty building... if (is.null(object$xt$penalty)) { ## must construct penalty if (is.null(object$xt$nb)) { ## no neighbour list... construct one if (is.null(object$xt$polys)) stop("no spatial information provided!") object$xt$nb <- pol2nb(object$xt$polys)$nb } ## now have a neighbour list a.name <- names(object$xt$nb) if (all.equal(sort(a.name),sort(levels(k)))!=TRUE) stop("mismatch between nb/polys supplied area names and data area names") np <- ncol(object$X) S <- matrix(0,np,np) rownames(S) <- colnames(S) <- levels(k) for (i in 1:np) { ind <- object$xt$nb[[i]] lind <- length(ind) S[a.name[i],a.name[i]] <- lind if (lind>0) for (j in 1:lind) S[a.name[i],a.name[ind[j]]] <- -1 } if (sum(S!=t(S))>0) stop("Something wrong with auto- penalty construction") object$S[[1]] <- S } else { ## penalty given, just need to check it object$S[[1]] <- object$xt$penalty if (ncol(object$S[[1]])!=nrow(object$S[[1]])) stop("supplied penalty not square!") if (ncol(object$S[[1]])!=ncol(object$X)) stop("supplied penalty wrong dimension!") if (!is.null(colnames(object$S[[1]]))) { a.name <- colnames(object$S[[1]]) if (all.equal(levels(k),sort(a.name))!=TRUE) { stop("penalty column names don't match supplied area names!") } else { if (all.equal(sort(a.name),a.name)!=TRUE) { ## re-order penalty to match object$X object$S[[1]] <- object$S[[1]][levels(k),] object$S[[1]] <- object$S[[1]][,levels(k)] } } } } ## end of check -- penalty ok if we got this far ## Following (optionally) constructs a low rank approximation based on the ## natural parameterization given in Wood (2006) 4.1.14 if (object$bs.dim0) { ## create dummy obs for missing... object$X <- rbind(matrix(0,length(mi),np),object$X) for (i in 1:length(mi)) object$X[i,mi[i]] <- 1 } rp <- nat.param(object$X,object$S[[1]],type=0) ## now retain only bs.dim least penalized elements ## of basis, which are the final bs.dim cols of rp$X ind <- (np-object$bs.dim+1):np object$X <- if (length(mi)) rp$X[-(1:length(mi)),ind] else rp$X[,ind] ## model matrix object$P <- rp$P[,ind] ## re-para matrix ##ind <- ind[ind <= rp$rank] ## drop last element as zeros not returned in D object$S[[1]] <- diag(c(rp$D[ind[ind <= rp$rank]],rep(0,sum(ind>rp$rank)))) object$rank <- sum(ind <= rp$rank) ## rp$rank ## penalty rank } else { ## full rank basis, but need to ## numerically evaluate mrf penalty rank... ev <- eigen(object$S[[1]],symmetric=TRUE,only.values=TRUE)$values object$rank <- sum(ev >.Machine$double.eps^.8*max(ev)) ## ncol(object$X)-1 } object$null.space.dim <- ncol(object$X) - object$rank object$knots <- k object$df <- ncol(object$X) object$te.ok <- 2 ## OK in te but not to plot object$noterp <- TRUE ## do not re-para in te terms class(object)<-"mrf.smooth" object } ## smooth.construct.mrf.smooth.spec Predict.matrix.mrf.smooth <- function(object, data) { x <- factor(data[[object$term]],levels=levels(object$knots)) ##levels(x) <- levels(object$knots) X <- model.matrix(~x-1) if (!is.null(object$P)) X <- X%*%object$P X } ## Predict.matrix.mrf.smooth ############################# # Splines on the sphere.... ############################# makeR <- function(la,lo,lak,lok,m=2) { ## construct a matrix R the i,jth element of which is ## R(p[i],pk[j]) where p[i] is the point given by ## la[i], lo[i] and something similar holds for pk[j]. ## Wahba (1981) SIAM J Sci. Stat. Comput. 2(1):5-14 is the ## key reference, although some expressions are oddly unsimplified ## there. There's an errata in 3(3):385-386, but it doesn't ## change anything here (only higher order penalties) ## Return null space basis matrix T as attribute... pi180 <- pi/180 ## convert to radians la <- la * pi180;lo <- lo * pi180 lak <- lak * pi180;lok <- lok * pi180 og <- expand.grid(lo=lo,lok=lok) ag <- expand.grid(la=la,lak=lak) ## get array of angles between points (lo,la) and knots (lok,lak)... #v <- 1 - cos(ag$la)*cos(og$lo)*cos(ag$lak)*cos(og$lok) - # cos(ag$la)*sin(og$lo)*cos(ag$lak)*sin(og$lok)- # sin(ag$la)*sin(ag$lak) #v[v<0] <- 0 #gamma <- 2*asin(sqrt(v*0.5)) v <- sin(ag$la)*sin(ag$lak)+cos(ag$la)*cos(ag$lak)*cos(og$lo-og$lok) v[v > 1] <- 1;v[v < -1] <- -1 gamma <- acos(v) if (m == -1) { ## Jean Duchon's unpublished proposal... z <- 2*sin(gamma/2) ## Euclidean 3 - distance between points eps <- .Machine$double.xmin*10 z[z 0 is 1 W <- z/2;C <- sqrt(W) A <- log(1+1/C);C <- C*2 if (m==1) { ## order 3/2 penalty q1 <- 2*A*W - C + 1 R <- matrix((q1-1/2)/(2*pi),length(la),length(lak)) ## rk matrix attr(R,"T") <- matrix(1,nrow(R),1) attr(R,"Tc") <- matrix(1,ncol(R),1) ## constraint return(R) } W2 <- W*W if (m==2) { ## order 2 penalty q2 <- A*(6*W2-2*W)-3*C*W+3*W+1/2 ## This is Wahba's pseudospline r.k. alternative would be to ## sum series to get regular spline kernel, as in m=0 case above R <- matrix((q2/2-1/6)/(2*pi),length(la),length(lak)) ## rk matrix attr(R,"T") <- matrix(1,nrow(R),1) attr(R,"Tc") <- matrix(1,ncol(R),1) ## constraint return(R) } W3 <- W2*W if (m==3) { ## order 5/2 penalty q3 <- (A*(60*W3 - 36*W2) + 30*W2 + C*(8*W-30*W2) - 3*W + 1)/3 R <- matrix( (q3/6-1/24)/(2*pi),length(la),length(lak)) ## rk matrix attr(R,"T") <- matrix(1,nrow(R),1) attr(R,"Tc") <- matrix(1,ncol(R),1) ## constraint return(R) } W4 <- W3*W if (m==4) { ## order 3 penalty q4 <- A*(70*W4-60*W3 + 6*W2) +35*W3*(1-C) + C*55*W2/3 - 12.5*W2 - W/3 + 1/4 R <- matrix( (q4/24-1/120)/(2*pi),length(la),length(lak)) ## rk matrix attr(R,"T") <- matrix(1,nrow(R),1) attr(R,"Tc") <- matrix(1,ncol(R),1) ## constraint return(R) } } ## makeR smooth.construct.sos.smooth.spec<-function(object,data,knots) ## The constructor for a spline on the sphere basis object. ## Assumption: first variable is lat, second is lon!! { ## deal with possible extra arguments of "sos" type smooth xtra <- list() if (is.null(object$xt$max.knots)) xtra$max.knots <- 2000 else xtra$max.knots <- object$xt$max.knots if (is.null(object$xt$seed)) xtra$seed <- 1 else xtra$seed <- object$xt$seed if (object$dim!=2) stop("Can only deal with a sphere") ## now collect predictors x<-array(0,0) for (i in 1:2) { xx <- data[[object$term[i]]] if (i==1) n <- length(xx) else if (n!=length(xx)) stop("arguments of smooth not same dimension") x<-c(x,xx) } if (is.null(knots)) { knt<-0;nk<-0} else { knt<-array(0,0) for (i in 1:2) { dum <- knots[[object$term[i]]] if (is.null(dum)) {knt<-0;nk<-0;break} # no valid knots for this term knt <- c(knt,dum) nk0 <- length(dum) if (i > 1 && nk != nk0) stop("components of knots relating to a single smooth must be of same length") nk <- nk0 } } if (nk>n) { ## more knots than data - silly. nk <- 0 warning("more knots than data in an sos term: knots ignored.") } ## deal with possibility of large data set if (nk==0) { ## need to create knots xu <- uniquecombs(matrix(x,n,2),TRUE) ## find the unique `locations' nu <- nrow(xu) ## number of unique locations if (n > xtra$max.knots) { ## then there *may* be too many data if (nu>xtra$max.knots) { ## then there is really a problem seed <- try(get(".Random.seed",envir=.GlobalEnv),silent=TRUE) ## store RNG seed if (inherits(seed,"try-error")) { runif(1) seed <- get(".Random.seed",envir=.GlobalEnv) } kind <- RNGkind(NULL) RNGkind("default","default") set.seed(xtra$seed) ## ensure repeatability nk <- xtra$max.knots ## going to create nk knots ind <- sample(1:nu,nk,replace=FALSE) ## by sampling these rows from xu knt <- as.numeric(xu[ind,]) ## ... like this RNGkind(kind[1],kind[2]) assign(".Random.seed",seed,envir=.GlobalEnv) ## RNG behaves as if it had not been used } else { knt <- xu;nk <- nu } ## end of large data set handling } else { knt <- xu;nk <- nu } ## just set knots to data } if (object$bs.dim[1]<0) object$bs.dim <- 50 # auto-initialize basis dimension ## Now get the rk matrix... if (is.na(object$p.order)) object$p.order <- 0 object$p.order <- round(object$p.order) if (object$p.order< -1) object$p.order <- -1 if (object$p.order>4) object$p.order <- 4 R <- makeR(la=knt[1:nk],lo=knt[-(1:nk)],lak=knt[1:nk],lok=knt[-(1:nk)],m=object$p.order) T <- attr(R,"Tc") ## constraint matrix ind <- 1:ncol(T) k <- object$bs.dim if (k nk) { ## split into chunks to save memory n.chunk <- n %/% nk for (i in 1:n.chunk) { ## build predict matrix in chunks ind <- 1:nk + (i-1)*nk Xc <- makeR(la=la[ind],lo=lo[ind], lak=lak,lok=lok,m=object$p.order) Xc <- cbind(Xc%*%object$UZ,attr(Xc,"T")) if (i == 1) X <- Xc else { X <- rbind(X,Xc);rm(Xc)} } ## finished size nk chunks if (n > ind[nk]) { ## still some left over ind <- (ind[nk]+1):n ## last chunk Xc <- makeR(la=la[ind],lo=lo[ind], lak=lak,lok=lok,m=object$p.order) Xc <- cbind(Xc%*%object$UZ,attr(Xc,"T")) X <- rbind(X,Xc);rm(Xc) } } else { X <- makeR(la=la,lo=lo, lak=lak,lok=lok,m=object$p.order) X <- cbind(X%*%object$UZ,attr(X,"T")) } if (!is.null(object$xc.scale)) X <- t(t(X)*object$xc.scale) ## apply column scaling X } ## Predict.matrix.sos.smooth ########################### # Duchon 1977.... ########################### poly.pow <- function(m,d) { ## create matrix containing powers of (m-1)th order polynomials in d dimensions ## p[i,j] is power for x_j in ith basis component. p has d columns M <- choose(m+d-1,d) ## total basis size p <- matrix(0,M,d) oo <- .C(C_gen_tps_poly_powers,p=as.integer(p),M=as.integer(M),m=as.integer(m),d=as.integer(d)) matrix(oo$p,M,d) } ## poly.pow DuchonT <- function(x,m=2,n=1) { ## Get null space basis for Duchon '77 construction... ## n is dimension in Duchon's notation, so x is a matrix ## with n columns. m is penalty order. p <- poly.pow(m,n) M <- nrow(p) ## basis size if (!is.matrix(x)) x <- matrix(x,length(x),1) nx <- nrow(x) T <- matrix(0,nx,M) for (i in 1:M) { y <- rep(1,nx) for (j in 1:n) y <- y * x[,j]^p[i,j] T[,i] <- y } T } ## DuchonT DuchonE <- function(x,xk,m=2,s=0,n=1) { ## Get the r.k. matrix for a Duchon '77 construction... ind <- expand.grid(x=1:nrow(x),xk=1:nrow(xk)) ## get d[i,j] the Euclidian distance from x[i] to xk[j]... d <- matrix(sqrt(rowSums((x[ind$x,,drop=FALSE]-xk[ind$xk,,drop=FALSE])^2)),nrow(x),nrow(xk)) k <- 2*m + 2*s - n if (k%%2==0) { ## even ind <- d==0 E <- d E[!ind] <- d[!ind]^k * log(d[!ind]) } else { E <- d^k } ## k == 1 => -ve - then sign flips every second k value ## i.e. if floor(k/2+1) is odd then sign is -ve, otherwise +ve signE <- 1-2*((floor(k/2)+1)%%2) rm(d) E*signE } ## DuchonE smooth.construct.ds.smooth.spec <- function(object,data,knots) ## The constructor for a Duchon 1977 smoother { ## deal with possible extra arguments of "ds" type smooth xtra <- list() if (is.null(object$xt$max.knots)) xtra$max.knots <- 2000 else xtra$max.knots <- object$xt$max.knots if (is.null(object$xt$seed)) xtra$seed <- 1 else xtra$seed <- object$xt$seed ## now collect predictors x<-array(0,0) for (i in 1:object$dim) { xx <- data[[object$term[i]]] if (i==1) n <- length(xx) else if (n!=length(xx)) stop("arguments of smooth not same dimension") x<-c(x,xx) } if (is.null(knots)) { knt<-0;nk<-0} else { knt<-array(0,0) for (i in 1:object$dim) { dum <- knots[[object$term[i]]] if (is.null(dum)) {knt<-0;nk<-0;break} # no valid knots for this term knt <- c(knt,dum) nk0 <- length(dum) if (i > 1 && nk != nk0) stop("components of knots relating to a single smooth must be of same length") nk <- nk0 } } if (nk>n) { ## more knots than data - silly. nk <- 0 warning("more knots than data in a ds term: knots ignored.") } xu <- uniquecombs(matrix(x,n,object$dim),TRUE) ## find the unique `locations' if (nrow(xu) xtra$max.knots) { ## then there *may* be too many data if (nu>xtra$max.knots) { ## then there is really a problem seed <- try(get(".Random.seed",envir=.GlobalEnv),silent=TRUE) ## store RNG seed if (inherits(seed,"try-error")) { runif(1) seed <- get(".Random.seed",envir=.GlobalEnv) } kind <- RNGkind(NULL) RNGkind("default","default") set.seed(xtra$seed) ## ensure repeatability nk <- xtra$max.knots ## going to create nk knots ind <- sample(1:nu,nk,replace=FALSE) ## by sampling these rows from xu knt <- as.numeric(xu[ind,]) ## ... like this RNGkind(kind[1],kind[2]) assign(".Random.seed",seed,envir=.GlobalEnv) ## RNG behaves as if it had not been used } else { knt <- xu;nk <- nu } ## end of large data set handling } else { knt <- xu;nk <- nu } ## just set knots to data } ## if (object$bs.dim[1]<0) object$bs.dim <- 10*3^(object$dim[1]-1) # auto-initialize basis dimension ## Check the conditions on Duchon's m, s and n (p.order[1], p.order[2] and dim)... if (is.na(object$p.order[1])) object$p.order[1] <- 2 ## default penalty order 2 if (is.na(object$p.order[2])) object$p.order[2] <- 0 ## default s=0 (tps) object$p.order[1] <- round(object$p.order[1]) ## m is integer object$p.order[2] <- round(object$p.order[2]*2)/2 ## s is in halfs if (object$p.order[1]< 1) object$p.order[1] <- 1 ## m > 0 ## -n/2 < s < n/2... if (object$p.order[2] >= object$dim/2) { object$p.order[2] <- (object$dim-1)/2 warning("s value reduced") } if (object$p.order[2] <= -object$dim/2) { object$p.order[2] <- -(object$dim-1)/2 warning("s value increased") } ## m + s > n/2 for continuity... if (sum(object$p.order)<=object$dim/2) { object$p.order[2] <- 1/2 + object$dim/2 - object$p.order[1] if (object$p.order[2]>=object$dim/2) stop("No suitable s (i.e. m[2]) try increasing m[1]") warning("s value modified to give continuous function") } x <- matrix(x,n,object$dim) knt <- matrix(knt,nk,object$dim) ## centre the covariates... object$shift <- colMeans(x) x <- sweep(x,2,object$shift) knt <- sweep(knt,2,object$shift) ## Get the E matrix... E <- DuchonE(knt,knt,m=object$p.order[1],s=object$p.order[2],n=object$dim) T <- DuchonT(knt,m=object$p.order[1],n=object$dim) ## constraint matrix ind <- 1:ncol(T) def.k <- c(10,30,100) dd <- min(object$dim,length(def.k)) if (object$bs.dim[1]<0) object$bs.dim <- ncol(T) + def.k[dd] ## default basis dimension if (object$bs.dim < ncol(T)+1) { object$bs.dim <- ncol(T)+1 warning("basis dimension reset to minimum possible") } k <- object$bs.dim if (k nk) { ## split into chunks to save memory n.chunk <- n %/% nk for (i in 1:n.chunk) { ## build predict matrix in chunks ind <- 1:nk + (i-1)*nk Xc <- DuchonE(x=x[ind,,drop=FALSE],xk=object$knt,m=object$p.order[1],s=object$p.order[2],n=object$dim) Xc <- cbind(Xc%*%object$UZ,DuchonT(x=x[ind,,drop=FALSE],m=object$p.order[1],n=object$dim)) if (i == 1) X <- Xc else { X <- rbind(X,Xc);rm(Xc)} } ## finished size nk chunks if (n > ind[nk]) { ## still some left over ind <- (ind[nk]+1):n ## last chunk Xc <- DuchonE(x=x[ind,,drop=FALSE],xk=object$knt,m=object$p.order[1],s=object$p.order[2],n=object$dim) Xc <- cbind(Xc%*%object$UZ,DuchonT(x=x[ind,,drop=FALSE],m=object$p.order[1],n=object$dim)) X <- rbind(X,Xc);rm(Xc) } } else { X <- DuchonE(x=x,xk=object$knt,m=object$p.order[1],s=object$p.order[2],n=object$dim) X <- cbind(X%*%object$UZ,DuchonT(x=x,m=object$p.order[1],n=object$dim)) } X } ## end of Predict.matrix.duchon.spline ################################################## # Matern splines following Kammann and Wand (2003) ################################################## gpT <- function(x) { ## T matrix for Kamman and Wand Matern Spline... cbind(x[,1]*0+1,x) } ## gpT gpE <- function(x,xk,defn = NA) { ## Get the E matrix for a Kammann and Wand Matern spline. ## rho is the range parameter... set to K&W default if not supplied ind <- expand.grid(x=1:nrow(x),xk=1:nrow(xk)) ## get d[i,j] the Euclidian distance from x[i] to xk[j]... E <- matrix(sqrt(rowSums((x[ind$x,,drop=FALSE]-xk[ind$xk,,drop=FALSE])^2)),nrow(x),nrow(xk)) rho <- -1; k <- 1 if ((length(defn)==1&&is.na(defn))||length(defn)<1) { type <- 3 } else if (length(defn)>0) type <- round(defn[1]) if (length(defn)>1) rho <- defn[2] if (length(defn)>2) k <- defn[3] if (rho <= 0) rho <- max(E) ## approximately the K & W choise E <- E/rho if (!type%in%1:5||k>2||k<=0) stop("incorrect arguments to GP smoother") if (type>2) eE <- exp(-E) E <- switch(type, (1 - 1.5*E + 0.5 *E^3)*(E <= 1), ## 1 spherical exp(-E^k), ## 2 power exponential (1 + E) * eE, ## 3 Matern k = 1.5 eE + (E*eE)*(1+E/3), ## 4 Matern k = 2.5 eE + (E*eE)*(1+.4*E+E^2/15) ## 5 Matern k = 3.5 ) attr(E,"defn") <- c(type,rho,k) E } ## gpE smooth.construct.gp.smooth.spec <- function(object,data,knots) ## The constructor for a Kamman and Wand (2003) Matern Spline, and other GP smoothers. ## See also Handcock, Meier and Nychka (1994), and Handcock and Stein (1993). { ## deal with possible extra arguments of "gp" type smooth xtra <- list() if (is.null(object$xt$max.knots)) xtra$max.knots <- 2000 else xtra$max.knots <- object$xt$max.knots if (is.null(object$xt$seed)) xtra$seed <- 1 else xtra$seed <- object$xt$seed ## now collect predictors x <- array(0,0) for (i in 1:object$dim) { xx <- data[[object$term[i]]] if (i==1) n <- length(xx) else if (n!=length(xx)) stop("arguments of smooth not same dimension") x<-c(x,xx) } if (is.null(knots)) { knt <- 0; nk <- 0} else { knt <- array(0,0) for (i in 1:object$dim) { dum <- knots[[object$term[i]]] if (is.null(dum)) { knt <- 0; nk <- 0; break} # no valid knots for this term knt <- c(knt,dum) nk0 <- length(dum) if (i > 1 && nk != nk0) stop("components of knots relating to a single smooth must be of same length") nk <- nk0 } } if (nk>n) { ## more knots than data - silly. nk <- 0 warning("more knots than data in an ms term: knots ignored.") } xu <- uniquecombs(matrix(x,n,object$dim),TRUE) ## find the unique `locations' if (nrow(xu) < object$bs.dim) stop( "A term has fewer unique covariate combinations than specified maximum degrees of freedom") ## deal with possibility of large data set if (nk==0) { ## need to create knots nu <- nrow(xu) ## number of unique locations if (n > xtra$max.knots) { ## then there *may* be too many data if (nu > xtra$max.knots) { ## then there is really a problem seed <- try(get(".Random.seed",envir=.GlobalEnv),silent=TRUE) ## store RNG seed if (inherits(seed,"try-error")) { runif(1) seed <- get(".Random.seed",envir=.GlobalEnv) } kind <- RNGkind(NULL) RNGkind("default","default") set.seed(xtra$seed) ## ensure repeatability nk <- xtra$max.knots ## going to create nk knots ind <- sample(1:nu,nk,replace=FALSE) ## by sampling these rows from xu knt <- as.numeric(xu[ind,]) ## ... like this RNGkind(kind[1],kind[2]) assign(".Random.seed",seed,envir=.GlobalEnv) ## RNG behaves as if it had not been used } else { knt <- xu; nk <- nu } ## end of large data set handling } else { knt <- xu;nk <- nu } ## just set knots to data } x <- matrix(x,n,object$dim) knt <- matrix(knt,nk,object$dim) ## centre the covariates... object$shift <- colMeans(x) x <- sweep(x,2,object$shift) knt <- sweep(knt,2,object$shift) ## Get the E matrix... E <- gpE(knt,knt,object$p.order) object$gp.defn <- attr(E,"defn") def.k <- c(10,30,100) dd <- ncol(knt) if (object$bs.dim[1] < 0) object$bs.dim <- ncol(knt) + 1 + def.k[dd] ## default basis dimension if (object$bs.dim < ncol(knt)+2) { object$bs.dim <- ncol(knt)+2 warning("basis dimension reset to minimum possible") } object$null.space.dim <- ncol(knt) + 1 k <- object$bs.dim - object$null.space.dim if (k < nk) { er <- slanczos(E,k,-1) ## truncated eigen decomposition of E D <- diag(c(er$values,rep(0,object$null.space.dim))) ## penalty matrix } else { ## no point using eigen-decomp D <- matrix(0,object$bs.dim,object$bs.dim) D[1:k,1:k] <- E ## penalty er <- list(vectors=diag(k)) ## U is identity here } rm(E) object$S <- list(S=D) object$UZ <- er$vectors ## UZ - (original params) = UZ %*% (working params) object$knt = knt ## save the knots object$df <- object$bs.dim object$rank <- k class(object)<-"gp.smooth" object$X <- Predict.matrix.gp.smooth(object,data) object } ## end of smooth.construct.gp.smooth.spec Predict.matrix.gp.smooth <- function(object,data) # prediction method function for the gp (Matern) smooth class { nk <- nrow(object$knt) ## number of 'knots' ## get evaluation points.... for (i in 1:object$dim) { xx <- data[[object$term[i]]] if (i==1) { n <- length(xx) x <- matrix(xx,n,object$dim) } else { if (n!=length(xx)) stop("arguments of smooth not same dimension") x[,i] <- xx } } x <- sweep(x,2,object$shift) ## apply centering if (n > nk) { ## split into chunks to save memory n.chunk <- n %/% nk for (i in 1:n.chunk) { ## build predict matrix in chunks ind <- 1:nk + (i-1)*nk Xc <- gpE(x=x[ind,,drop=FALSE],xk=object$knt,object$gp.defn) Xc <- cbind(Xc%*%object$UZ,gpT(x=x[ind,,drop=FALSE])) if (i == 1) X <- Xc else { X <- rbind(X,Xc);rm(Xc)} } ## finished size nk chunks if (n > ind[nk]) { ## still some left over ind <- (ind[nk]+1):n ## last chunk Xc <- gpE(x=x[ind,,drop=FALSE],xk=object$knt,object$gp.defn) Xc <- cbind(Xc%*%object$UZ,gpT(x=x[ind,,drop=FALSE])) X <- rbind(X,Xc);rm(Xc) } } else { X <- gpE(x=x,xk=object$knt,object$gp.defn) X <- cbind(X%*%object$UZ,gpT(x=x)) } X } ## end of Predict.matrix.gp.smooth ################################### # Soap film smoothers are in soap.r ################################### ############################ ## The generics and wrappers ############################ smooth.construct <- function(object,data,knots) UseMethod("smooth.construct") smooth.construct2 <- function(object,data,knots) { ## This routine does not require that `data' contains only ## the evaluated `object$term's and the `by' variable... it ## obtains such a data object from `data' and also deals with ## multiple evaluations at the same covariate points efficiently dk <- ExtractData(object,data,knots) object <- smooth.construct(object,dk$data,dk$knots) ind <- attr(dk$data,"index") ## repeats index if (!is.null(ind)) { ## unpack the model matrix offs <- attr(object$X,"offset") object$X <- object$X[ind,] if (!is.null(offs)) attr(object$X,"offset") <- offs[ind] } class(object) <- c(class(object),"mgcv.smooth") object } ## smooth.construct2 smooth.construct3 <- function(object,data,knots) { ## This routine does not require that `data' contains only ## the evaluated `object$term's and the `by' variable... it ## obtains such a data object from `data' and also deals with ## multiple evaluations at the same covariate points efficiently ## In contrast to smooth.constuct2 it returns an object in which ## `X' contains the rows required to make the full model matrix, ## and ind[i] tells you which row of `X' is the ith row of the ## full model matrix. If `ind' is NULL then `X' is the full model matrix. dk <- ExtractData(object,data,knots) object <- smooth.construct(object,dk$data,dk$knots) ind <- attr(dk$data,"index") ## repeats index object$ind <- ind class(object) <- c(class(object),"mgcv.smooth") if (!is.null(object$point.con)) { ## 's' etc has requested a point constraint object$C <- Predict.matrix3(object,object$point.con)$X ## handled by 's' attr(object$C,"always.apply") <- TRUE ## if constraint requested then always apply it! } object } ## smooth.construct3 Predict.matrix <- function(object,data) UseMethod("Predict.matrix") Predict.matrix2 <- function(object,data) { dk <- ExtractData(object,data,NULL) X <- Predict.matrix(object,dk$data) ind <- attr(dk$data,"index") ## repeats index if (!is.null(ind)) { ## unpack the model matrix offs <- attr(X,"offset") X <- X[ind,] if (!is.null(offs)) attr(X,"offset") <- offs[ind] } X } ## Predict.matrix2 Predict.matrix3 <- function(object,data) { ## version of Predict.matrix matching smooth.construct3 dk <- ExtractData(object,data,NULL) X <- Predict.matrix(object,dk$data) ind <- attr(dk$data,"index") ## repeats index list(X=X,ind=ind) } ## Predict.matrix3 ExtractData <- function(object,data,knots) { ## `data' and `knots' contain the data needed to evaluate the `terms', `by' ## and `knots' elements of `object'. This routine does so, and returns ## a list with element `data' containing just the evaluated `terms', ## with the by variable as the last column. If the `terms' evaluate matrices, ## then a check is made of whether repeat evaluations are being made, ## and if so only the unique evaluation points are returned in data, along ## with the `index' attribute required to re-assemble the full dataset. knt <- dat <- list() for (i in 1:length(object$term)) { dat[[object$term[i]]] <- get.var(object$term[i],data) knt[[object$term[i]]] <- get.var(object$term[i],knots) } names(dat) <- object$term; m <- length(object$term) if (!is.null(attr(dat[[1]],"matrix"))) { ## strip down to unique covariate combinations n <- length(dat[[1]]) X <- matrix(unlist(dat),n,m) if (is.numeric(X)) { X <- uniquecombs(X) if (nrow(X)1) for (i in 2:length(sm$S)) upen <- upen & rowMeans(abs(sm$S[[i]]))==0 if (sum(upen)>0) drop <- min(which(upen)) else { drop <- min(which(!sm$g.index)) } } else drop <- 1 sm$g.index <- sm$g.index[-drop] } else drop <- -1 ## signals not to use sweep and drop (may be modified below) if (is.null(sm$C)) { if (sparse.cons<=0) { sm$C <- matrix(colMeans(sm$X),1,ncol(sm$X)) ## following 2 lines implement sweep and drop constraints, ## which are computationally faster than QR null space ## however note that these are not appropriate for ## models with by-variables requiring constraint! if (sparse.cons == -1) { vcol <- apply(sm$X,2,var) ## drop least variable column drop <- min((1:length(vcol))[vcol==min(vcol)]) } } else if (sparse.cons>0) { ## use sparse constraints for sparse terms if (sum(sm$X==0)>.1*sum(sm$X!=0)) { ## treat term as sparse if (sparse.cons==1) { xsd <- apply(sm$X,2,FUN=sd) if (sum(xsd==0)) ## are any columns constant? sm$C <- ((1:length(xsd))[xsd==0])[1] ## index of coef to set to zero else { ## xz <- colSums(sm$X==0) ## find number of zeroes per column (without big memory footprint)... xz <- apply(sm$X,2,FUN=function(x) {sum(x==0)}) sm$C <- ((1:length(xz))[xz==min(xz)])[1] ## index of coef to set to zero } } else if (sparse.cons==2) { sm$C = -1 ## params sum to zero } else { stop("unimplemented sparse constraint type requested") } } else { ## it's not sparse anyway sm$C <- matrix(colSums(sm$X),1,ncol(sm$X)) } } else { ## end of sparse constraint handling sm$C <- matrix(colSums(sm$X),1,ncol(sm$X)) ## default dense case } ## conSupplied <- FALSE alwaysCon <- FALSE } else { ## sm$C supplied if (modCon==2&&!is.null(sm$Cp)) sm$C <- sm$Cp ## reset fit con to predict if (modCon>=3) sm$Cp <- NULL ## get rid of separate predict con ## should supplied constraint be applied even if not needed? if (is.null(attr(sm$C,"always.apply"))) alwaysCon <- FALSE else alwaysCon <- TRUE } ## set df fields (pre-constraint)... if (is.null(sm$df)) sm$df <- sm$bs.dim ## automatically discard penalties for fixed terms... if (!is.null(object$fixed)&&object$fixed) { sm$S <- NULL } ## The following is intended to make scaling `nice' for better gamm performance. ## Note that this takes place before any resetting of the model matrix, and ## any `by' variable handling. From a `gamm' perspective this is not ideal, ## but to do otherwise would mess up the meaning of smoothing parameters ## sufficiently that linking terms via `id's would not work properly (they ## would have the same basis, but different penalties) sm$S.scale <- rep(1,length(sm$S)) if (scale.penalty && length(sm$S)>0 && is.null(sm$no.rescale)) # then the penalty coefficient matrix is rescaled { maXX <- norm(sm$X,type="I")^2 ##mean(abs(t(sm$X)%*%sm$X)) # `size' of X'X for (i in 1:length(sm$S)) { maS <- norm(sm$S[[i]])/maXX ## mean(abs(sm$S[[i]])) / maXX sm$S[[i]] <- sm$S[[i]] / maS sm$S.scale[i] <- maS ## multiply S[[i]] by this to get original S[[i]] } } ## check whether different data to be used for basis setup ## and model matrix... if (!is.null(dataX)) { er <- Predict.matrix3(sm,dataX) sm$X <- er$X sm$ind <- er$ind rm(er) } ## check whether smooth called with matrix argument if ((is.null(sm$ind)&&nrow(sm$X)!=n)||(!is.null(sm$ind)&&length(sm$ind)!=n)) { matrixArg <- TRUE ## now get the number of columns in the matrix argument... if (is.null(sm$ind)) q <- nrow(sm$X)/n else q <- length(sm$ind)/n if (!is.null(sm$by.done)) warning("handling `by' variables in smooth constructors may not work with the summation convention ") } else { matrixArg <- FALSE if (!is.null(sm$ind)) { ## unpack model matrix + any offset offs <- attr(sm$X,"offset") sm$X <- sm$X[sm$ind,,drop=FALSE] if (!is.null(offs)) attr(sm$X,"offset") <- offs[sm$ind] } } offs <- NULL ## pick up "by variables" now, and handle summation convention ... if (matrixArg||(object$by!="NA"&&is.null(sm$by.done))) { #drop <- -1 ## sweep and drop constraints inappropriate if (is.null(dataX)) by <- get.var(object$by,data) else by <- get.var(object$by,dataX) if (matrixArg&&is.null(by)) { ## then by to be taken as sequence of 1s if (is.null(sm$ind)) by <- rep(1,nrow(sm$X)) else by <- rep(1,length(sm$ind)) } if (is.null(by)) stop("Can't find by variable") offs <- attr(sm$X,"offset") if (!is.factor(by)) { ## test for cases where no centring constraint on the smooth is needed. if (!alwaysCon) { if (matrixArg) { L1 <- as.numeric(matrix(by,n,q)%*%rep(1,q)) if (sd(L1)>mean(L1)*.Machine$double.eps*1000) { ## sml[[1]]$C <- sm$C <- matrix(0,0,1) ## if (!is.null(sm$Cp)) sml[[1]]$Cp <- sm$Cp <- NULL if (!is.null(sm$Cp)) sm$Cp <- NULL } else sm$meanL1 <- mean(L1) ## else sml[[1]]$meanL1 <- mean(L1) ## store mean of L1 for use when adding intercept variability } else { ## numeric `by' -- constraint only needed if constant if (sd(by)>mean(by)*.Machine$double.eps*1000) { ## sml[[1]]$C <- sm$C <- matrix(0,0,1) ## if (!is.null(sm$Cp)) sml[[1]]$Cp <- sm$Cp <- NULL if (!is.null(sm$Cp)) sm$Cp <- NULL } } } ## end of constraint removal } } ## end of initial setup of by variables if (absorb.cons&&drop>0&&nrow(sm$C)>0) { ## sweep and drop constraints have to be applied before by variables if (!is.null(sm$by.done)) warning("sweep and drop constraints unlikely to work well with self handling of by vars") qrc <- c(drop,as.numeric(sm$C)[-drop]) class(qrc) <- "sweepDrop" sm$X <- sm$X[,-drop,drop=FALSE] - matrix(qrc[-1],nrow(sm$X),ncol(sm$X)-1,byrow=TRUE) if (length(sm$S)>0) for (l in 1:length(sm$S)) { # some smooths have > 1 penalty sm$S[[l]]<-sm$S[[l]][-drop,-drop] } attr(sm,"qrc") <- qrc attr(sm,"nCons") <- 1 sm$Cp <- sm$C <- 0 sm$rank <- pmin(sm$rank,ncol(sm$X)) sm$df <- sm$df - 1 sm$null.space.dim <- max(0,sm$null.space.dim-1) } if (matrixArg||(object$by!="NA"&&is.null(sm$by.done))) { ## apply by variables if (is.factor(by)) { ## generates smooth for each level of by if (matrixArg) stop("factor `by' variables can not be used with matrix arguments.") sml <- list() lev <- levels(by) ## if by variable is an ordered factor then first level is taken as a ## reference level, and smooths are only generated for the other levels ## this can help to ensure identifiability in complex models. if (is.ordered(by)&&length(lev)>1) lev <- lev[-1] for (j in 1:length(lev)) { sml[[j]] <- sm ## replicate smooth for each factor level by.dum <- as.numeric(lev[j]==by) sml[[j]]$X <- by.dum*sm$X ## multiply model matrix by dummy for level sml[[j]]$by.level <- lev[j] ## store level sml[[j]]$label <- paste(sm$label,":",object$by,lev[j],sep="") if (!is.null(offs)) { attr(sml[[j]]$X,"offset") <- offs*by.dum } } } else { ## not a factor by variable sml <- list(sm) if ((is.null(sm$ind)&&length(by)!=nrow(sm$X))|| (!is.null(sm$ind)&&length(by)!=length(sm$ind))) stop("`by' variable must be same dimension as smooth arguments") if (matrixArg) { ## arguments are matrices => summation convention used #if (!apply.by) warning("apply.by==FALSE unsupported in matrix case") if (is.null(sm$ind)) { ## then the sm$X is in unpacked form sml[[1]]$X <- as.numeric(by)*sm$X ## normal `by' handling ## Now do the summation stuff.... ind <- 1:n X <- sml[[1]]$X[ind,] for (i in 2:q) { ind <- ind + n X <- X + sml[[1]]$X[ind,] } sml[[1]]$X <- X if (!is.null(offs)) { ## deal with any term specific offset (i.e. sum it too) ## by variable multiplied version... offs <- attr(sm$X,"offset")*as.numeric(by) ind <- 1:n offX <- offs[ind,] for (i in 2:q) { ind <- ind + n offX <- offX + offs[ind,] } attr(sml[[1]]$X,"offset") <- offX } ## end of term specific offset handling } else { ## model sm$X is in packed form to save memory ind <- 0:(q-1)*n offs <- attr(sm$X,"offset") if (!is.null(offs)) offX <- rep(0,n) else offX <- NULL sml[[1]]$X <- matrix(0,n,ncol(sm$X)) for (i in 1:n) { ## in this case have to work down the rows ind <- ind + 1 sml[[1]]$X[i,] <- colSums(by[ind]*sm$X[sm$ind[ind],,drop=FALSE]) if (!is.null(offs)) { offX[i] <- sum(offs[sm$ind[ind]]*by[ind]) } } ## finished all rows attr(sml[[1]]$X,"offset") <- offX } } else { ## arguments not matrices => not in packed form + no summation needed sml[[1]]$X <- as.numeric(by)*sm$X if (!is.null(offs)) attr(sml[[1]]$X,"offset") <- if (apply.by) offs*as.numeric(by) else offs } if (object$by == "NA") sml[[1]]$label <- sm$label else sml[[1]]$label <- paste(sm$label,":",object$by,sep="") } ## end of not factor by branch } else { ## no by variables sml <- list(sm) } ########################### ## absorb constraints.....# ########################### if (absorb.cons) { k<-ncol(sm$X) ## If Cp is present it denotes a constraint to use in place of the fitting constraints ## when predicting. if (!is.null(sm$Cp)&&is.matrix(sm$Cp)) { ## identifiability cons different for prediction pj <- nrow(sm$Cp) qrcp <- qr(t(sm$Cp)) for (i in 1:length(sml)) { ## loop through smooth list sml[[i]]$Xp <- t(qr.qty(qrcp,t(sml[[i]]$X))[(pj+1):k,]) ## form XZ sml[[i]]$Cp <- NULL if (length(sml[[i]]$S)) { ## gam.side requires penalties in prediction para sml[[i]]$Sp <- sml[[i]]$S ## penalties in prediction parameterization for (l in 1:length(sml[[i]]$S)) { # some smooths have > 1 penalty ZSZ <- qr.qty(qrcp,sml[[i]]$S[[l]])[(pj+1):k,] sml[[i]]$Sp[[l]]<-t(qr.qty(qrcp,t(ZSZ))[(pj+1):k,]) ## Z'SZ } } } } else qrcp <- NULL ## rest of Cp processing is after C processing if (is.matrix(sm$C)) { ## the fit constraints j <- nrow(sm$C) if (j>0) { # there are constraints indi <- (1:ncol(sm$C))[colSums(sm$C)!=0] ## index of non-zero columns in C nx <- length(indi) if (nx < ncol(sm$C)&&drop<0) { ## then some parameters are completely constraint free nc <- j ## number of constraints nz <- nx-nc ## reduced null space dimension qrc <- qr(t(sm$C[,indi,drop=FALSE])) ## gives constraint null space for constrained only for (i in 1:length(sml)) { ## loop through smooth list if (length(sm$S)>0) for (l in 1:length(sm$S)) # some smooths have > 1 penalty { ZSZ <- sml[[i]]$S[[l]] ZSZ[indi[1:nz],]<-qr.qty(qrc,sml[[i]]$S[[l]][indi,,drop=FALSE])[(nc+1):nx,] ZSZ <- ZSZ[-indi[(nz+1):nx],] ZSZ[,indi[1:nz]]<-t(qr.qty(qrc,t(ZSZ[,indi,drop=FALSE]))[(nc+1):nx,]) sml[[i]]$S[[l]] <- ZSZ[,-indi[(nz+1):nx],drop=FALSE] ## Z'SZ ## ZSZ<-qr.qty(qrc,sm$S[[l]])[(j+1):k,] ## sml[[i]]$S[[l]]<-t(qr.qty(qrc,t(ZSZ))[(j+1):k,]) ## Z'SZ } sml[[i]]$X[,indi[1:nz]]<-t(qr.qty(qrc,t(sml[[i]]$X[,indi,drop=FALSE]))[(nc+1):nx,]) sml[[i]]$X <- sml[[i]]$X[,-indi[(nz+1):nx]] ## sml[[i]]$X<-t(qr.qty(qrc,t(sml[[i]]$X))[(j+1):k,]) ## form XZ attr(sml[[i]],"qrc") <- qrc attr(sml[[i]],"nCons") <- j; attr(sml[[i]],"indi") <- indi ## index of constrained parameters sml[[i]]$C <- NULL sml[[i]]$rank <- pmin(sm$rank,k-j) sml[[i]]$df <- sml[[i]]$df - j sml[[i]]$null.space.dim <- max(0,sml[[i]]$null.space.dim - j) ## ... so qr.qy(attr(sm,"qrc"),c(rep(0,nrow(sm$C)),b)) gives original para.'s } ## end smooth list loop } else { ## full null space created # if (drop>0) { ## sweep and drop constraints # qrc <- c(drop,as.numeric(sm$C)[-drop]) # class(qrc) <- "sweepDrop" # for (i in 1:length(sml)) { ## loop through smooth list # ## sml[[i]]$X <- sweep(sml[[i]]$X[,-drop],2,qrc[-1]) # sml[[i]]$X <- sml[[i]]$X[,-drop] - # matrix(qrc[-1],nrow(sml[[i]]$X),ncol(sml[[i]]$X)-1,byrow=TRUE) # if (length(sm$S)>0) # for (l in 1:length(sm$S)) { # some smooths have > 1 penalty # sml[[i]]$S[[l]]<-sml[[i]]$S[[l]][-drop,-drop] # } # } # } else { ## full QR based approach qrc<-qr(t(sm$C)) for (i in 1:length(sml)) { ## loop through smooth list if (length(sm$S)>0) for (l in 1:length(sm$S)) { # some smooths have > 1 penalty ZSZ<-qr.qty(qrc,sm$S[[l]])[(j+1):k,] sml[[i]]$S[[l]]<-t(qr.qty(qrc,t(ZSZ))[(j+1):k,]) ## Z'SZ } sml[[i]]$X <- t(qr.qty(qrc,t(sml[[i]]$X))[(j+1):k,]) ## form XZ } ## ... so qr.qy(attr(sm,"qrc"),c(rep(0,nrow(sm$C)),b)) gives original para.'s ## and qr.qy(attr(sm,"qrc"),rbind(rep(0,length(b)),diag(length(b)))) gives ## null space basis Z, such that Zb are the original params, subject to con. } for (i in 1:length(sml)) { ## loop through smooth list attr(sml[[i]],"qrc") <- qrc attr(sml[[i]],"nCons") <- j; sml[[i]]$C <- NULL sml[[i]]$rank <- pmin(sm$rank,k-j) sml[[i]]$df <- sml[[i]]$df - j sml[[i]]$null.space.dim <- max(0,sml[[i]]$null.space.dim-j) } ## end smooth list loop } # end full null space version of constraint } else { ## no constraints for (i in 1:length(sml)) { attr(sml[[i]],"qrc") <- "no constraints" attr(sml[[i]],"nCons") <- 0; } } ## end else no constraints } else if (sm$C>0) { ## set to zero constraints for (i in 1:length(sml)) { ## loop through smooth list if (length(sm$S)>0) for (l in 1:length(sm$S)) { # some smooths have > 1 penalty sml[[i]]$S[[l]] <- sml[[i]]$S[[l]][-sm$C,-sm$C] } sml[[i]]$X <- sml[[i]]$X[,-sm$C] attr(sml[[i]],"qrc") <- sm$C attr(sml[[i]],"nCons") <- 1; sml[[i]]$C <- NULL sml[[i]]$rank <- pmin(sm$rank,k-1) sml[[i]]$df <- sml[[i]]$df - 1 sml[[i]]$null.space.dim <- max(sml[[i]]$null.space.dim-1,0) ## so insert an extra 0 at position sm$C in coef vector to get original } ## end smooth list loop } else if (sm$C <0) { ## params sum to zero for (i in 1:length(sml)) { ## loop through smooth list if (length(sm$S)>0) for (l in 1:length(sm$S)) { # some smooths have > 1 penalty sml[[i]]$S[[l]] <- diff(t(diff(sml[[i]]$S[[l]]))) } sml[[i]]$X <- t(diff(t(sml[[i]]$X))) attr(sml[[i]],"qrc") <- sm$C attr(sml[[i]],"nCons") <- 1; sml[[i]]$C <- NULL sml[[i]]$rank <- pmin(sm$rank,k-1) sml[[i]]$df <- sml[[i]]$df - 1 sml[[i]]$null.space.dim <- max(sml[[i]]$null.space.dim-1,0) ## so insert an extra 0 at position sm$C in coef vector to get original } ## end smooth list loop } ## finish off treatment of case where prediction constraints are different if (!is.null(qrcp)) { for (i in 1:length(sml)) { ## loop through smooth list attr(sml[[i]],"qrc") <- qrcp if (pj!=attr(sml[[i]],"nCons")) stop("Number of prediction and fit constraints must match") attr(sml[[i]],"indi") <- NULL ## no index of constrained parameters for Cp } } } else for (i in 1:length(sml)) attr(sml[[i]],"qrc") <-NULL ## no absorption ## now convert single penalties to identity matrices, if requested. ## This is relatively expensive, so is not routinely done. However ## for expensive inference methods, such as MCMC, it is often worthwhile ## as in speeds up sampling much more than it slows down setup if (diagonal.penalty && length(sml[[1]]$S)==1) { ## recall that sml is a list that may contain several 'cloned' smooths ## if there was a factor by variable. They have the same penalty matrices ## but different model matrices. So cheapest re-para is to use a version ## that does not depend on the model matrix (e.g. type=2) S11 <- sml[[1]]$S[[1]][1,1];rank <- sml[[1]]$rank; p <- ncol(sml[[1]]$X) if (is.null(rank) || max(abs(sml[[1]]$S[[1]] - diag(c(rep(S11,rank),rep(0,p-rank))))) > abs(S11)*.Machine$double.eps^.8 ) { np <- nat.param(sml[[1]]$X,sml[[1]]$S[[1]],rank=sml[[1]]$rank,type=2,unit.fnorm=FALSE) sml[[1]]$X <- np$X;sml[[1]]$S[[1]] <- diag(p) diag(sml[[1]]$S[[1]]) <- c(np$D,rep(0,p-np$rank)) sml[[1]]$diagRP <- np$P if (length(sml)>1) for (i in 2:length(sml)) { sml[[i]]$X <- sml[[i]]$X%*%np$P ## reparameterized model matrix sml[[i]]$S <- sml[[1]]$S ## diagonalized penalty (unpenalized last) sml[[i]]$diagRP <- np$P ## re-parameterization matrix for use in PredictMat } } ## end of if, otherwise was already diagonal, and there is nothing to do } ## The idea here is that term selection can be accomplished as part of fitting ## by applying penalties to the null space of the penalty... if (null.space.penalty) { ## then an extra penalty on the un-penalized space should be added ## first establish if there is a quick method for doing this nsm <- length(sml[[1]]$S) if (nsm==1) { ## only have quick method for single penalty S11 <- sml[[1]]$S[[1]][1,1] rank <- sml[[1]]$rank; p <- ncol(sml[[1]]$X) if (is.null(rank) || max(abs(sml[[1]]$S[[1]] - diag(c(rep(S11,rank),rep(0,p-rank))))) > abs(S11)*.Machine$double.eps^.8 ) need.full <- TRUE else { need.full <- FALSE ## matrix is already a suitable diagonal if (p>rank) for (i in 1:length(sml)) { sml[[i]]$S[[2]] <- diag(c(rep(0,rank),rep(1,p-rank))) sml[[i]]$rank[2] <- p-rank sml[[i]]$S.scale[2] <- 1 sml[[i]]$null.space.dim <- 0 } } } else need.full <- if (nsm > 0) TRUE else FALSE if (need.full) { St <- sml[[1]]$S[[1]] if (length(sml[[1]]$S)>1) for (i in 1:length(sml[[1]]$S)) St <- St + sml[[1]]$S[[i]] es <- eigen(St,symmetric=TRUE) ind <- es$values0) { ## there were constraints to absorb - need to untransform k<-ncol(X) if (inherits(qrc,"qr")) { indi <- attr(object,"indi") ## index of constrained parameters if (is.null(indi)) { if (sum(is.na(X))) { ind <- !is.na(rowSums(X)) X1 <- t(qr.qty(qrc,t(X[ind,,drop=FALSE]))[(j+1):k,,drop=FALSE]) ## XZ X <- matrix(NA,nrow(X),ncol(X1)) X[ind,] <- X1 } else { X <- t(qr.qty(qrc,t(X))[(j+1):k,,drop=FALSE]) } } else { ## only some parameters are subject to constraint nx <- length(indi) nc <- j;nz <- nx - nc if (sum(is.na(X))) { ind <- !is.na(rowSums(X)) X[ind,indi[1:nz]]<-t(qr.qty(qrc,t(X[ind,indi,drop=FALSE]))[(nc+1):nx,]) X <- X[,-indi[(nz+1):nx]] X[!ind,] <- NA } else { X[,indi[1:nz]]<-t(qr.qty(qrc,t(X[,indi,drop=FALSE]))[(nc+1):nx,,drop=FALSE]) X <- X[,-indi[(nz+1):nx]] } } } else if (inherits(qrc,"sweepDrop")) { ## Sweep and drop constraints. First element is index to drop. ## Remainder are constants to be swept out of remaining columns ## Actually better handled first (see above) #X <- X[,-qrc[1],drop=FALSE] - matrix(qrc[-1],nrow(X),ncol(X)-1,byrow=TRUE) } else if (qrc>0) { ## simple set to zero constraint X <- X[,-qrc] } else if (qrc<0) { ## params sum to zero X <- t(diff(t(X))) } } } ## apply any reparameterization that resulted from diagonalizing penalties ## in smoothCon ... if (!is.null(object$diagRP)) X <- X %*% object$diagRP ## drop columns eliminated by side-conditions... del.index <- attr(object,"del.index") if (!is.null(del.index)) X <- X[,-del.index,drop=FALSE] attr(X,"offset") <- offset X } ## end of PredictMat mgcv/R/bam.r0000644000177400001440000026507412766454124012554 0ustar murdochusers## routines for very large dataset generalized additive modelling. ## (c) Simon N. Wood 2009-2015 ls.size <- function(x) { ## If `x' is a list, return the size of its elements, in bytes, in a named array ## otherwise return the size of the object if (is.list(x)==FALSE) return(object.size(x)) xn <- names(x) n <- length(x) sz <- rep(-1,n) for (i in 1:n) sz[i] <- object.size(x[[i]]) names(sz) <- xn sz } ## ls.size rwMatrix <- function(stop,row,weight,X,trans=FALSE) { ## Routine to recombine the rows of a matrix X according to info in ## stop, row and weight. Consider the ith row of the output matrix ## ind <- 1:stop[i] if i==1 and ind <- (stop[i-1]+1):stop[i] ## otherwise. The ith output row is then X[row[ind],]*weight[ind] if (is.matrix(X)) { n <- nrow(X);p<-ncol(X);ok <- TRUE} else { n<- length(X);p<-1;ok<-FALSE} stop <- stop - 1;row <- row - 1 ## R indices -> C indices oo <-.C(C_rwMatrix,as.integer(stop),as.integer(row),as.double(weight),X=as.double(X), as.integer(n),as.integer(p),trans=as.integer(trans),work=as.double(rep(0,n*p))) if (ok) return(matrix(oo$X,n,p)) else return(oo$X) } ## rwMatrix chol2qr <- function(XX,Xy,nt=1) { ## takes X'X and X'y and returns R and f ## equivalent to qr update. op <- options(warn = -1) ## otherwise warns if +ve semidef R <- if (nt) pchol(XX,nt=nt) else chol(XX,pivot=TRUE) options(op) p <- length(Xy) ipiv <- piv <- attr(R,"pivot");ipiv[piv] <- 1:p rank <- attr(R,"rank");ind <- 1:rank if (rank1 and use.chol=FALSE then parallel QR is used { p <- ncol(Xn) y.norm2 <- y.norm2+sum(yn*yn) if (use.chol) { if (is.null(R)) { R <- crossprod(Xn) fn <- as.numeric(t(Xn)%*%yn) } else { R <- R + crossprod(Xn) fn <- f + as.numeric(t(Xn)%*%yn) } return(list(R=R,f=fn,y.norm2=y.norm2)) } else { ## QR update if (!is.null(R)) { Xn <- rbind(R,Xn) yn <- c(f,yn) } qrx <- if (nt==1) qr(Xn,tol=0,LAPACK=TRUE) else pqr2(Xn,nt) fn <- qr.qty(qrx,yn)[1:p] rp <- qrx$pivot;rp[rp] <- 1:p # reverse pivot return(list(R = qr.R(qrx)[,rp],f=fn,y.norm2=y.norm2)) } } ## qr.update qr.up <- function(arg) { ## routine for parallel computation of the QR factorization of ## a large gam model matrix, suitable for calling with parLapply. wt <- rep(0,0) dev <- 0 for (b in 1:arg$n.block) { ind <- arg$start[b]:arg$stop[b] X <- predict(arg$G,newdata=arg$mf[ind,],type="lpmatrix",newdata.guaranteed=TRUE,block.size=length(ind)) rownames(X) <- NULL if (is.null(arg$coef)) eta1 <- arg$eta[ind] else eta1 <- drop(X%*%arg$coef) + arg$offset[ind] mu <- arg$linkinv(eta1) y <- arg$G$y[ind] ## arg$G$model[[arg$response]] weights <- arg$G$w[ind] mu.eta.val <- arg$mu.eta(eta1) good <- (weights > 0) & (mu.eta.val != 0) z <- (eta1 - arg$offset[ind])[good] + (y - mu)[good]/mu.eta.val[good] w <- (weights[good] * mu.eta.val[good]^2)/arg$variance(mu)[good] dev <- dev + sum(arg$dev.resids(y,mu,weights)) wt <- c(wt,w) w <- sqrt(w) ## note assumption that nt=1 in following qr.update - i.e. each cluster node is strictly serial if (b == 1) qrx <- qr.update(w*X[good,],w*z,use.chol=arg$use.chol) else qrx <- qr.update(w*X[good,],w*z,qrx$R,qrx$f,qrx$y.norm2,use.chol=arg$use.chol) rm(X);if(arg$gc.level>1) gc() ## X can be large: remove and reclaim } qrx$dev <- dev;qrx$wt <- wt if (arg$gc.level>1) { rm(arg,ind,mu,y,weights,mu.eta.val,good,z,w,wt,w);gc()} qrx } ## qr.up compress.df <- function(dat,m=NULL) { ## Takes dataframe in dat and compresses it by rounding and duplicate ## removal. For metric variables we first find the unique cases. ## If there are <= m of these then these are employed, otherwise ## rounding is used. Factors are always reduced to the number of ## levels present in the data. Idea is that this function is called ## with columns of dataframes corresponding to single smooths or marginals. d <- ncol(dat) ## number of variables to deal with n <- nrow(dat) ## number of data/cases if (is.null(m)) m <- if (d==1) 1000 else if (d==2) 100 else 25 else if (d>1) m <- round(m^{1/d}) + 1 mf <- mm <- 1 ## total grid points for factor and metric for (i in 1:d) if (is.factor(dat[,i])) { mf <- mf * length(unique(as.vector(dat[,i]))) } else { mm <- mm * m } if (is.matrix(dat[[1]])) { ## must replace matrix terms with vec(dat[[i]]) dat0 <- data.frame(as.vector(dat[[1]])) if (d>1) for (i in 2:d) dat0[[i]] <- as.vector(dat[[i]]) names(dat0) <- names(dat) dat <- dat0;rm(dat0) } xu <- uniquecombs(dat,TRUE) if (nrow(xu)>mm*mf) { ## too many unique rows to use only unique for (i in 1:d) if (!is.factor(dat[,i])) { ## round the metric variables xl <- range(dat[,i]) xu <- seq(xl[1],xl[2],length=m) dx <- xu[2]-xu[1] kx <- round((dat[,i]-xl[1])/dx)+1 dat[,i] <- xu[kx] ## rounding the metric variables } xu <- uniquecombs(dat,TRUE) } k <- attr(xu,"index") ## shuffle rows in order to avoid induced dependencies between discretized ## covariates (which can mess up gam.side)... ## any setting should be done in routine calling this one!! #seed <- try(get(".Random.seed",envir=.GlobalEnv),silent=TRUE) ## store RNG seed #if (inherits(seed,"try-error")) { # runif(1) # seed <- get(".Random.seed",envir=.GlobalEnv) #} #kind <- RNGkind(NULL) #RNGkind("default","default") ## following line must be different to that used in ## tp constructor subsampling! #set.seed(8547) ## ensure repeatability ii <- sample(1:nrow(xu),nrow(xu),replace=FALSE) ## shuffling index #RNGkind(kind[1],kind[2]) #assign(".Random.seed",seed,envir=.GlobalEnv) ## RNG behaves as if it had not been used xu[ii,] <- xu ## shuffle rows of xu k <- ii[k] ## correct k index accordingly ## ... finished shuffle ## if arguments were matrices, then return matrix index if (length(k)>n) k <- matrix(k,nrow=n) k -> attr(xu,"index") xu } ## compress.df check.term <- function(term,rec) { ## utility function for discrete.mf. Checks whether variables in "term" ## have already been discretized, and if so whether this discretization ## can be re-used for the current "term". Stops if term already discretized ## but we can't re-use discretization. Otherwise returns index of k index ## or 0 if the term is not in the existing list. ii <- which(rec$vnames%in%term) if (length(ii)) { ## at least one variable already discretized if (length(term)==rec$d[min(ii)]) { ## dimensions match previous discretization if (sum(!(term%in%rec$vnames[ii]))) ("bam can not discretize with this nesting structure") else return(rec$ki[min(ii)]) ## all names match previous - retun index of previous } else stop("bam can not discretize with this nesting structure") } else return(0) ## no match } ## check.term discrete.mf <- function(gp,mf,pmf,m=NULL,full=TRUE) { ## discretize the covariates for the terms specified in smooth.spec ## id not allowed. pmf is a model frame for just the ## parametric terms --- mini.mf is applied to this. ## if full is FALSE then parametric and response terms are ignored ## and what is returned is a list where columns can be of ## different lengths. ## On exit... ## * mf is a model frame containing the unique discretized covariate ## values, in randomized order, padded to all be same length ## * nr records the number of unique discretized covariate values ## i.e. the number of rows before the padding starts ## * k.start contains the starting column in index vector k, for ## each variable. ## * k is the index matrix. The ith record of the 1st column of the ## jth variable is in row k[i,k.start[j]] of the corresponding ## column of mf. ## ... there is an element of nr and k.start for each variable of ## each smooth, but varaibles are onlt discretized and stored in mf ## once. If there are no matrix variables then k.start = 1:(ncol(k)+1) # if (is.null(attr(mf,"terms"))) mf <- eval(gp$fake.formula[-2],mf) ## assumes model frame below ## some sub sampling here... want to set and restore RNG state used for this ## to ensure strict repeatability. seed <- try(get(".Random.seed",envir=.GlobalEnv),silent=TRUE) ## store RNG seed if (inherits(seed,"try-error")) { runif(1) seed <- get(".Random.seed",envir=.GlobalEnv) } kind <- RNGkind(NULL) RNGkind("default", "default") set.seed(8547) ## keep different to tps constructor! mf0 <- list() nk <- 0 ## count number of index vectors to avoid too much use of cbind for (i in 1:length(gp$smooth.spec)) nk <- nk + as.numeric(gp$smooth.spec[[i]]$by!="NA") + if (inherits(gp$smooth.spec[[i]],"tensor.smooth.spec")) length(gp$smooth.spec[[i]]$margin) else 1 k <- matrix(0,nrow(mf),nk) ## each column is an index vector k.start <- 1:(nk+1) ## record last column for each term ik <- 0 ## index counter nr <- rep(0,nk) ## number of rows for term ## structure to record terms already processed... rec <- list(vnames = rep("",0), ## variable names ki = rep(0,0), ## index of original index vector var relates to d = rep(0,0)) ## dimension of terms involving this var ## loop through the terms discretizing the covariates... for (i in 1:length(gp$smooth.spec)) { nmarg <- if (inherits(gp$smooth.spec[[i]],"tensor.smooth.spec")) length(gp$smooth.spec[[i]]$margin) else 1 maxj <- if (gp$smooth.spec[[i]]$by=="NA") nmarg else nmarg + 1 mi <- if (is.null(m)||length(m)==1) m else m[i] if (!is.null(gp$smooth.spec[[i]]$id)) stop("discretization can not handle smooth ids") j <- 0 for (jj in 1:maxj) { ## loop through marginals if (jj==1&&maxj!=nmarg) termi <- gp$smooth.spec[[i]]$by else { j <- j + 1 termi <- if (inherits(gp$smooth.spec[[i]],"tensor.smooth.spec")) gp$smooth.spec[[i]]$margin[[j]]$term else gp$smooth.spec[[i]]$term } ik.prev <- check.term(termi,rec) ## term already discretized? ik <- ik + 1 ## increment index counter if (ik.prev==0) { ## new discretization required mfd <- compress.df(mf[termi],m=mi) ki <- attr(mfd,"index") if (is.matrix(ki)) { ind <- (ik+1):length(k.start) k.start[ind] <- k.start[ind] + ncol(ki)-1 ## adjust start indices k <- cbind(k,matrix(0,nrow(k),ncol(ki)-1)) ## extend index matrix ind <- k.start[ik]:(k.start[ik+1]-1) k[,ind] <- ki } else { k[,k.start[ik]] <- ki } nr[ik] <- nrow(mfd) mf0 <- c(mf0,mfd) ## record variable discretization info... d <- length(termi) rec$vnames <- c(rec$vnames,termi) rec$ki <- c(rec$ki,rep(ik,d)) rec$d <- c(rec$d,rep(d,d)) } else { ## re-use an earlier discretization... ind.prev <- k.start[ik.prev]:(k.start[ik.prev+1]-1) ind <- (ik+1):length(k.start) k.start[ind] <- k.start[ind] + length(ind.prev)-1 ind <- k.start[ik]:(k.start[ik+1]-1) k[,ind] <- k[,ind.prev] #k[,ik] <- k[,ik.prev] nr[ik] <- nr[ik.prev] } } ## end marginal jj loop } ## term loop (i) ## obtain parametric terms and.. ## pad mf0 so that all rows are the same length ## padding is necessary if gam.setup is to be used for setup if (full) { maxr <- max(nr) pmf0 <- mini.mf(pmf,maxr) ## deal with parametric components if (nrow(pmf0)>maxr) maxr <- nrow(pmf0) mf0 <- c(mf0,pmf0) ## add parametric terms to end of mf0 for (i in 1:length(mf0)) { me <- length(mf0[[i]]) if (me < maxr) mf0[[i]][(me+1):maxr] <- sample(mf0[[i]],maxr-me,replace=TRUE) } ## add response so that gam.setup can do its thing... mf0[[gp$response]] <- sample(mf[[gp$response]],maxr,replace=TRUE) ## mf0 is the discretized model frame (actually a list), padded to have equal length rows ## k is the index vector for each sub-matrix, only the first nr rows of which are ## to be retained... Use of check.names=FALSE ensures, e.g. 'offset(x)' not changed... ## now copy back into mf so terms unchanged #mf <- mf[1:maxr,] mf <- mf[sample(1:nrow(mf),maxr,replace=TRUE),] for (na in names(mf0)) mf[[na]] <- mf0[[na]] } else mf <- mf0 ## reset RNG to old state... RNGkind(kind[1], kind[2]) assign(".Random.seed", seed, envir = .GlobalEnv) ## finally one more pass through, expanding k, k.start and nr to deal with replication that ## will occur with factor by variables... ik <- ncol(k)+1 ## starting index col for this term in k.start for (i in length(gp$smooth.spec):1) { ## work down through terms so insertion painless if (inherits(gp$smooth.spec[[i]],"tensor.smooth.spec")) nd <- length(gp$smooth.spec[[i]]$margin) else nd <- 1 ## number of indices ik <- ik - nd ## starting index if no by if (gp$smooth.spec[[i]]$by!="NA") { ik <- ik - 1 ## first index nd <- nd + 1 ## number of indices byvar <- mf[[gp$smooth.spec[[i]]$by]] if (is.factor(byvar)) { ## then need to expand nr and index matrix nex <- length(levels(byvar)) ## number of copies of term indices if (is.ordered(byvar)) nex <- nex - 1 ## first level dropped if (nex>0) { ## insert index copies ii0 <- if (ik>1) 1:(ik-1) else rep(0,0) ## earlier ii1 <- if (ik+nd-1 < length(nr)) (ik+nd):length(nr) else rep(0,0) ## later ii <- ik:(ik+nd-1) ## cols for this term ## indices for columns of k... kk0 <- if (ik>1) 1:(k.start[ik]-1) else rep(0,0) ## earlier kk1 <- if (ik+nd-1 < length(nr)) k.start[ik+nd]:ncol(k) else rep(0,0) ## later kk <- k.start[ik]:(k.start[ik+nd]-1) ## cols for this term k <- cbind(k[,kk0,drop=FALSE],k[,rep(kk,nex),drop=FALSE],k[,kk1,drop=FALSE]) nr <- c(nr[ii0],rep(nr[ii],nex),nr[ii1]) ## expand k.start... nkk <- length(kk) ## number of k columns in term to be repeated k.start <- c(k.start[ii0],rep(k.start[ii],nex)+rep(0:(nex-1),each=nkk)*nkk, (nex-1)*nkk+c(k.start[ii1],k.start[length(k.start)])) } } ## factor by } ## existing by } ## smooth.spec loop list(mf=mf,k=k,nr=nr,k.start=k.start) } ## discrete.mf mini.mf <-function(mf,chunk.size) { ## takes a model frame and produces a representative subset of it, suitable for ## basis setup. ## first count the minimum number of rows required for representiveness mn <- 0 for (j in 1:length(mf)) mn <- mn + if (is.factor(mf[[j]])) length(levels(mf[[j]])) else 2 if (chunk.size < mn) chunk.size <- mn n <- nrow(mf) if (n <= chunk.size) return(mf) seed <- try(get(".Random.seed",envir=.GlobalEnv),silent=TRUE) ## store RNG seed if (inherits(seed,"try-error")) { runif(1) seed <- get(".Random.seed",envir=.GlobalEnv) } kind <- RNGkind(NULL) RNGkind("default", "default") set.seed(66) ## randomly sample from original frame... ind <- sample(1:n,chunk.size) mf0 <- mf[ind,,drop=FALSE] ## ... now need to ensure certain sorts of representativeness ## work through elements collecting the rows containing ## max and min for each variable, and a random row for each ## factor level.... ind <- sample(1:n,n,replace=FALSE) ## randomized index for stratified sampling w.r.t. factor levels fun <- function(X,fac,ind) ind[fac[ind]==X][1] ## stratified sampler k <- 0 for (j in 1:length(mf)) if (is.numeric(mf0[[j]])) { if (is.matrix(mf0[[j]])) { ## find row containing minimum j.min <- min((1:n)[as.logical(rowSums(mf[[j]]==min(mf[[j]])))]) j.max <- min((1:n)[as.logical(rowSums(mf[[j]]==max(mf[[j]])))]) } else { ## vector j.min <- min(which(mf[[j]]==min(mf[[j]]))) j.max <- min(which(mf[[j]]==max(mf[[j]]))) } k <- k + 1; mf0[k,] <- mf[j.min,] k <- k + 1; mf0[k,] <- mf[j.max,] } else if (is.factor(mf[[j]])) { ## factor variable... ## randomly sample one row from each factor level... find <- apply(X=as.matrix(levels(mf[[j]])),MARGIN=1,FUN=fun,fac=mf[[j]],ind=ind) find <- find[is.finite(find)] ## in case drop.unused.levels==FALSE, so that there ar levels without rows nf <- length(find) mf0[(k+1):(k+nf),] <- mf[find,] k <- k + nf } RNGkind(kind[1], kind[2]) assign(".Random.seed", seed, envir = .GlobalEnv) mf0 } ## mini.mf bgam.fitd <- function (G, mf, gp ,scale , coef=NULL,etastart = NULL, mustart = NULL, offset = rep(0, nobs),rho=0, control = gam.control(), intercept = TRUE, gc.level=0,nobs.extra=0,npt=1) { ## This is a version of bgam.fit1 designed for use with discretized covariates. ## Difference to bgam.fit1 is that XWX, XWy and Xbeta are computed in C ## code using compressed versions of X. Parallelization of XWX formation ## is performed at the C level using openMP. ## Alternative fitting iteration using Choleski only, including for REML. ## Basic idea is to take only one Newton step for parameters per iteration ## and to control the step length to ensure that at the end of the step we ## are not going uphill w.r.t. the REML criterion... y <- mf[[gp$response]] weights <- G$w conv <- FALSE nobs <- nrow(mf) offset <- G$offset if (rho!=0) { ## AR1 error model ld <- 1/sqrt(1-rho^2) ## leading diagonal of root inverse correlation sd <- -rho*ld ## sub diagonal N <- nobs ## see rwMatrix() for how following are used... ar.row <- c(1,rep(1:N,rep(2,N))[-c(1,2*N)]) ## index of rows to reweight ar.weight <- c(1,rep(c(sd,ld),N-1)) ## row weights ar.stop <- c(1,1:(N-1)*2+1) ## (stop[i-1]+1):stop[i] are the rows to reweight to get ith row if (!is.null(mf$"(AR.start)")) { ## need to correct the start of new AR sections... ii <- which(mf$"(AR.start)"==TRUE) if (length(ii)>0) { if (ii[1]==1) ii <- ii[-1] ## first observation does not need any correction ar.weight[ii*2-2] <- 0 ## zero sub diagonal ar.weight[ii*2-1] <- 1 ## set leading diagonal to 1 } } } else {## AR setup complete ar.row <- ar.weight <- ar.stop <- -1 ## signal no re-weighting } family <- G$family additive <- if (family$family=="gaussian"&&family$link=="identity") TRUE else FALSE variance <- family$variance dev.resids <- family$dev.resids linkinv <- family$linkinv mu.eta <- family$mu.eta if (!is.function(variance) || !is.function(linkinv)) stop("'family' argument seems not to be a valid family object") valideta <- family$valideta if (is.null(valideta)) valideta <- function(eta) TRUE validmu <- family$validmu if (is.null(validmu)) validmu <- function(mu) TRUE if (is.null(mustart)) { eval(family$initialize) } else { mukeep <- mustart eval(family$initialize) mustart <- mukeep } eta <- if (!is.null(etastart)) etastart else family$linkfun(mustart) mu <- linkinv(eta) if (!(validmu(mu) && valideta(eta))) stop("cannot find valid starting values: please specify some") dev <- sum(dev.resids(y, mu, weights))*2 ## just to avoid converging at iter 1 conv <- FALSE G$coefficients <- rep(0,ncol(G$X)) class(G) <- "gam" ## need to reset response and weights to post initialization values ## in particular to deal with binomial properly... G$y <- y G$w <- weights Sl <- Sl.setup(G) ## setup block diagonal penalty object rank <- 0 for (b in 1:length(Sl)) rank <- rank + Sl[[b]]$rank Mp <- ncol(G$X) - rank ## null space dimension Nstep <- 0 for (iter in 1L:control$maxit) { ## main fitting loop devold <- dev dev <- 0 ## accumulate the QR decomposition of the weighted model matrix if (iter==1||!additive) { qrx <- list() if (iter>1) { ## form eta = X%*%beta eta <- Xbd(G$Xd,coef,G$kd,G$ks,G$ts,G$dt,G$v,G$qc,G$drop) } mu <- linkinv(eta) mu.eta.val <- mu.eta(eta) good <- mu.eta.val != 0 mu.eta.val[!good] <- .1 ## irrelvant as weight is zero z <- (eta - offset) + (G$y - mu)/mu.eta.val w <- (G$w * mu.eta.val^2)/variance(mu) dev <- sum(dev.resids(G$y,mu,G$w)) qrx$y.norm2 <- if (rho==0) sum(w*z^2) else ## AR mod needed sum(rwMatrix(ar.stop,ar.row,ar.weight,sqrt(w)*z,trans=FALSE)^2) ## form X'WX efficiently... qrx$R <- XWXd(G$Xd,w,G$kd,G$ks,G$ts,G$dt,G$v,G$qc,npt,G$drop,ar.stop,ar.row,ar.weight) ## form X'Wz efficiently... qrx$f <- XWyd(G$Xd,w,z,G$kd,G$ks,G$ts,G$dt,G$v,G$qc,G$drop,ar.stop,ar.row,ar.weight) if(gc.level>1) gc() ## following reparameterizes X'X and f=X'y, according to initial reparameterizarion... qrx$XX <- Sl.initial.repara(Sl,qrx$R,inverse=FALSE,both.sides=TRUE,cov=FALSE,nt=npt) qrx$Xy <- Sl.initial.repara(Sl,qrx$f,inverse=FALSE,both.sides=TRUE,cov=FALSE,nt=npt) G$n <- nobs } else { ## end of if (iter==1||!additive) dev <- qrx$y.norm2 - sum(coef*qrx$f) ## actually penalized deviance } if (control$trace) message(gettextf("Deviance = %s Iterations - %d", dev, iter, domain = "R-mgcv")) if (!is.finite(dev)) stop("Non-finite deviance") ## preparation for working model fit is ready, but need to test for convergence first if (iter>2 && abs(dev - devold)/(0.1 + abs(dev)) < control$epsilon) { conv <- TRUE #coef <- start break } ## use fast REML code ## block diagonal penalty object, Sl, set up before loop if (iter==1) { ## need to get initial smoothing parameters lambda.0 <- initial.sp(qrx$R,G$S,G$off,XX=TRUE) ## note that this uses the untrasformed X'X in qrx$R ## convert intial s.p.s to account for L lsp0 <- log(lambda.0) ## initial s.p. if (!is.null(G$L)) lsp0 <- if (ncol(G$L)>0) as.numeric(coef(lm(lsp0 ~ G$L-1+offset(G$lsp0)))) else rep(0,0) n.sp <- length(lsp0) } ## carry forward scale estimate if possible... if (scale>0) log.phi <- log(scale) else { if (iter==1) { if (is.null(coef)||qrx$y.norm2==0) lsp0[n.sp+1] <- log(var(as.numeric(G$y))*.05) else lsp0[n.sp+1] <- log(qrx$y.norm2/(nobs+nobs.extra)) } } ## get beta, grad and proposed Newton step... repeat { ## Take a Newton step to update log sp and phi lsp <- lsp0 + Nstep if (scale<=0) log.phi <- lsp[n.sp+1] prop <- Sl.fitChol(Sl,qrx$XX,qrx$Xy,rho=lsp[1:n.sp],yy=qrx$y.norm2,L=G$L,rho0=G$lsp0,log.phi=log.phi, phi.fixed=scale>0,nobs=nobs,Mp=Mp,nt=npt,tol=dev*.Machine$double.eps^.7) if (max(Nstep)==0) { Nstep <- prop$step;lsp0 <- lsp; break } else { if (sum(prop$grad*Nstep)>dev*1e-7) Nstep <- Nstep/2 else { Nstep <- prop$step;lsp0 <- lsp;break; } } } ## end of sp update coef <- Sl.initial.repara(Sl,prop$beta,inverse=TRUE,both.sides=FALSE,cov=FALSE) if (any(!is.finite(coef))) { conv <- FALSE warning(gettextf("non-finite coefficients at iteration %d", iter)) break } } ## end fitting iteration if (!conv) warning("algorithm did not converge") eps <- 10 * .Machine$double.eps if (family$family == "binomial") { if (any(mu > 1 - eps) || any(mu < eps)) warning("fitted probabilities numerically 0 or 1 occurred") } if (family$family == "poisson") { if (any(mu < eps)) warning("fitted rates numerically 0 occurred") } Mp <- G$nsdf if (length(G$smooth)>1) for (i in 1:length(G$smooth)) Mp <- Mp + G$smooth[[i]]$null.space.dim scale <- exp(log.phi) reml <- (dev/scale - prop$ldetS + prop$ldetXXS + (length(y)-Mp)*log(2*pi*scale))/2 if (rho!=0) { ## correct REML score for AR1 transform df <- if (is.null(mf$"(AR.start)")) 1 else sum(mf$"(AR.start)") reml <- reml - (nobs-df)*log(ld) } for (i in 1:ncol(prop$db)) prop$db[,i] <- ## d beta / d rho matrix Sl.initial.repara(Sl,as.numeric(prop$db[,i]),inverse=TRUE,both.sides=TRUE,cov=TRUE,nt=npt) object <- list(db.drho=prop$db, gcv.ubre=reml,mgcv.conv=conv,rank=prop$r, scale.estimated = scale<=0,outer.info=NULL, optimizer=c("perf","chol")) object$coefficients <- coef ## form linear predictor efficiently... object$linear.predictors <- Xbd(G$Xd,coef,G$kd,G$ks,G$ts,G$dt,G$v,G$qc,G$drop) + G$offset PP <- Sl.initial.repara(Sl,prop$PP,inverse=TRUE,both.sides=TRUE,cov=TRUE,nt=npt) F <- pmmult(PP,qrx$R,FALSE,FALSE,nt=npt) ##crossprod(PP,qrx$R) - qrx$R contains X'WX in this case object$edf <- diag(F) object$edf1 <- 2*object$edf - rowSums(t(F)*F) object$sp <- exp(lsp[1:n.sp]) object$sig2 <- object$scale <- scale object$Vp <- PP * scale object$Ve <- pmmult(F,object$Vp,FALSE,FALSE,nt=npt) ## F%*%object$Vp ## sp uncertainty correction... if (!is.null(G$L)) prop$db <- prop$db%*%G$L M <- ncol(prop$db) if (M>0) { ev <- eigen(prop$hess,symmetric=TRUE) ind <- ev$values <= 0 ev$values[ind] <- 0;ev$values[!ind] <- 1/sqrt(ev$values[!ind]) rV <- (ev$values*t(ev$vectors))[,1:M] Vc <- pcrossprod(rV%*%t(prop$db),nt=npt) } else Vc <- 0 Vc <- object$Vp + Vc ## Bayesian cov matrix with sp uncertainty object$edf2 <- rowSums(Vc*qrx$R)/scale object$Vc <- Vc object$outer.info <- list(grad = prop$grad,hess=prop$hess) object$AR1.rho <- rho object$R <- pchol(qrx$R,npt) piv <- attr(object$R,"pivot") object$R[,piv] <- object$R object$iter <- iter object$wt <- w object$y <- G$y object$prior.weights <- G$w rm(G);if (gc.level>0) gc() object } ## end bgam.fitd bgam.fit <- function (G, mf, chunk.size, gp ,scale ,gamma,method, coef=NULL,etastart = NULL, mustart = NULL, offset = rep(0, nobs), control = gam.control(), intercept = TRUE, cl = NULL,gc.level=0,use.chol=FALSE,nobs.extra=0,samfrac=1,npt=1) { y <- mf[[gp$response]] weights <- G$w conv <- FALSE nobs <- nrow(mf) ##nvars <- ncol(G$X) offset <- G$offset family <- G$family G$family <- gaussian() ## needed if REML/ML used G$family$drop.intercept <- family$drop.intercept ## needed in predict.gam variance <- family$variance dev.resids <- family$dev.resids ## aic <- family$aic linkinv <- family$linkinv mu.eta <- family$mu.eta if (!is.function(variance) || !is.function(linkinv)) stop("'family' argument seems not to be a valid family object") valideta <- family$valideta if (is.null(valideta)) valideta <- function(eta) TRUE validmu <- family$validmu if (is.null(validmu)) validmu <- function(mu) TRUE if (is.null(mustart)) { eval(family$initialize) } else { mukeep <- mustart eval(family$initialize) mustart <- mukeep } ##coefold <- NULL eta <- if (!is.null(etastart)) etastart else family$linkfun(mustart) mu <- linkinv(eta) if (!(validmu(mu) && valideta(eta))) stop("cannot find valid starting values: please specify some") dev <- sum(dev.resids(y, mu, weights))*2 ## just to avoid converging at iter 1 ##boundary <- conv <- FALSE G$coefficients <- rep(0,ncol(G$X)) class(G) <- "gam" ## need to reset response and weights to post initialization values ## in particular to deal with binomial properly... G$y <- y G$w <- weights ## set up cluster for parallel computation... if (!is.null(cl)&&inherits(cl,"cluster")) { n.threads <- length(cl) while(nobs/n.threads < ncol(G$X)) n.threads <- n.threads - 1 if (n.threads < length(cl)) { warning("Too many cluster nodes to use all efficiently") } } else n.threads <- 1 if (n.threads>1) { ## set up thread argument lists ## number of obs per thread nt <- rep(ceiling(nobs/n.threads),n.threads) nt[n.threads] <- nobs - sum(nt[-n.threads]) arg <- list() n1 <- 0 for (i in 1:n.threads) { n0 <- n1+1;n1 <- n1+nt[i] ind <- n0:n1 ## this threads data block from mf n.block <- nt[i]%/%chunk.size ## number of full sized blocks stub <- nt[i]%%chunk.size ## size of end block if (n.block>0) { start <- (0:(n.block-1))*chunk.size+1 stop <- (1:n.block)*chunk.size if (stub>0) { start[n.block+1] <- stop[n.block]+1 stop[n.block+1] <- nt[i] n.block <- n.block+1 } } else { n.block <- 1 start <- 1 stop <- nt[i] } arg[[i]] <- list(nobs= nt[i],start=start,stop=stop,n.block=n.block, linkinv=linkinv,dev.resids=dev.resids,gc.level=gc.level, mu.eta=mu.eta,variance=variance,mf = mf[ind,], eta = eta[ind],offset = offset[ind],G = G,use.chol=use.chol) arg[[i]]$G$w <- G$w[ind];arg[[i]]$G$model <- NULL arg[[i]]$G$y <- G$y[ind] } } else { ## single thread, requires single indices ## construct indices for splitting up model matrix construction... n.block <- nobs%/%chunk.size ## number of full sized blocks stub <- nobs%%chunk.size ## size of end block if (n.block>0) { start <- (0:(n.block-1))*chunk.size+1 stop <- (1:n.block)*chunk.size if (stub>0) { start[n.block+1] <- stop[n.block]+1 stop[n.block+1] <- nobs n.block <- n.block+1 } } else { n.block <- 1 start <- 1 stop <- nobs } } ## single thread indices complete conv <- FALSE if (method=="fREML") Sl <- Sl.setup(G) ## setup block diagonal penalty object for (iter in 1L:control$maxit) { ## main fitting loop ## accumulate the QR decomposition of the weighted model matrix wt <- rep(0,0) devold <- dev dev <- 0 if (n.threads == 1) { ## use original serial update code for (b in 1:n.block) { ind <- start[b]:stop[b] X <- predict(G,newdata=mf[ind,],type="lpmatrix",newdata.guaranteed=TRUE,block.size=length(ind)) rownames(X) <- NULL if (is.null(coef)) eta1 <- eta[ind] else eta1 <- drop(X%*%coef) + offset[ind] mu <- linkinv(eta1) y <- G$y[ind] ## G$model[[gp$response]] ## - G$offset[ind] weights <- G$w[ind] mu.eta.val <- mu.eta(eta1) good <- (weights > 0) & (mu.eta.val != 0) z <- (eta1 - offset[ind])[good] + (y - mu)[good]/mu.eta.val[good] w <- (weights[good] * mu.eta.val[good]^2)/variance(mu)[good] dev <- dev + sum(dev.resids(y,mu,weights)) wt <- c(wt,w) w <- sqrt(w) ## note that QR may be parallel using npt>1, even under serial accumulation... if (b == 1) qrx <- qr.update(w*X[good,],w*z,use.chol=use.chol,nt=npt) else qrx <- qr.update(w*X[good,],w*z,qrx$R,qrx$f,qrx$y.norm2,use.chol=use.chol,nt=npt) rm(X);if(gc.level>1) gc() ## X can be large: remove and reclaim } if (use.chol) { ## post proc to get R and f... y.norm2 <- qrx$y.norm2 qrx <- chol2qr(qrx$R,qrx$f,nt=npt) qrx$y.norm2 <- y.norm2 } } else { ## use parallel accumulation for (i in 1:length(arg)) arg[[i]]$coef <- coef res <- parallel::parLapply(cl,arg,qr.up) ## single thread debugging version #res <- list() #for (i in 1:length(arg)) { # res[[i]] <- qr.up(arg[[i]]) #} ## now consolidate the results from the parallel threads... if (use.chol) { R <- res[[1]]$R;f <- res[[1]]$f;dev <- res[[1]]$dev wt <- res[[1]]$wt;y.norm2 <- res[[1]]$y.norm2 for (i in 2:n.threads) { R <- R + res[[i]]$R; f <- f + res[[i]]$f wt <- c(wt,res[[i]]$wt); dev <- dev + res[[i]]$dev y.norm2 <- y.norm2 + res[[i]]$y.norm2 } qrx <- chol2qr(R,f,nt=npt) qrx$y.norm2 <- y.norm2 } else { ## proper QR R <- res[[1]]$R;f <- res[[1]]$f;dev <- res[[1]]$dev wt <- res[[1]]$wt;y.norm2 <- res[[1]]$y.norm2 for (i in 2:n.threads) { R <- rbind(R,res[[i]]$R); f <- c(f,res[[i]]$f) wt <- c(wt,res[[i]]$wt); dev <- dev + res[[i]]$dev y.norm2 <- y.norm2 + res[[i]]$y.norm2 } ## use parallel QR here if npt>1... qrx <- if (npt>1) pqr2(R,npt) else qr(R,tol=0,LAPACK=TRUE) f <- qr.qty(qrx,f)[1:ncol(R)] rp <- qrx$pivot;rp[rp] <- 1:ncol(R) # reverse pivot qrx <- list(R=qr.R(qrx)[,rp],f=f,y.norm2=y.norm2) } } ## if the routine has been called with only a random sample of the data, then ## R, f and ||y||^2 can be corrected to estimate the full versions... qrx$R <- qrx$R/sqrt(samfrac) qrx$f <- qrx$f/sqrt(samfrac) qrx$y.norm2 <- qrx$y.norm2/samfrac G$n <- nobs rss.extra <- qrx$y.norm2 - sum(qrx$f^2) if (control$trace) message(gettextf("Deviance = %s Iterations - %d", dev, iter, domain = "R-mgcv")) if (!is.finite(dev)) stop("Non-finite deviance") ## preparation for working model fit is ready, but need to test for convergence first if (iter>2 && abs(dev - devold)/(0.1 + abs(dev)) < control$epsilon) { conv <- TRUE coef <- start break } if (method=="GCV.Cp") { fit <- magic(qrx$f,qrx$R,G$sp,G$S,G$off,L=G$L,lsp0=G$lsp0,rank=G$rank, H=G$H,C=matrix(0,0,ncol(qrx$R)), ##C=G$C, gamma=gamma,scale=scale,gcv=(scale<=0), extra.rss=rss.extra,n.score=nobs+nobs.extra) post <- magic.post.proc(qrx$R,fit,qrx$f*0+1) } else if (method=="fREML") { ## use fast REML code ## block diagonal penalty object, Sl, set up before loop um <- Sl.Xprep(Sl,qrx$R,nt=npt) lambda.0 <- initial.sp(qrx$R,G$S,G$off) lsp0 <- log(lambda.0) ## initial s.p. ## carry forward scale estimate if possible... if (scale>0) log.phi <- log(scale) else { if (iter>1) log.phi <- log(object$scale) else { if (is.null(coef)||qrx$y.norm2==0) log.phi <- log(var(as.numeric(G$y))*.05) else log.phi <- log(qrx$y.norm2/(nobs+nobs.extra)) } } fit <- fast.REML.fit(um$Sl,um$X,qrx$f,rho=lsp0,L=G$L,rho.0=G$lsp0, log.phi=log.phi,phi.fixed=scale>0,rss.extra=rss.extra, nobs =nobs+nobs.extra,Mp=um$Mp,nt=npt) res <- Sl.postproc(Sl,fit,um$undrop,qrx$R,cov=FALSE,L=G$L,nt=npt) object <- list(coefficients=res$beta,db.drho=fit$d1b, gcv.ubre=fit$reml,mgcv.conv=list(iter=fit$iter, message=fit$conv),rank=ncol(um$X), Ve=NULL,scale.estimated = scale<=0,outer.info=fit$outer.info, optimizer=c("perf","newton")) if (scale<=0) { ## get sp's and scale estimate nsp <- length(fit$rho) object$sig2 <- object$scale <- exp(fit$rho[nsp]) object$sp <- exp(fit$rho[-nsp]) nsp <- length(fit$rho.full) object$full.sp <- exp(fit$rho.full[-nsp]) } else { ## get sp's object$sig2 <- object$scale <- scale object$sp <- exp(fit$rho) object$full.sp <- exp(fit$rho.full) } class(object)<-c("gam") } else { ## method is one of "ML", "P-REML" etc... y <- G$y; w <- G$w; n <- G$n;offset <- G$offset G$y <- qrx$f G$w <- G$y*0+1 G$X <- qrx$R G$n <- length(G$y) G$offset <- G$y*0 G$dev.extra <- rss.extra G$pearson.extra <- rss.extra G$n.true <- nobs+nobs.extra object <- gam(G=G,method=method,gamma=gamma,scale=scale,control=gam.control(nthreads=npt)) y -> G$y; w -> G$w; n -> G$n;offset -> G$offset } if (method=="GCV.Cp") { object <- list() object$coefficients <- fit$b object$edf <- post$edf object$edf1 <- post$edf1 ##object$F <- post$F object$full.sp <- fit$sp.full object$gcv.ubre <- fit$score object$hat <- post$hat object$mgcv.conv <- fit$gcv.info object$optimizer="magic" object$rank <- fit$gcv.info$rank object$Ve <- post$Ve object$Vp <- post$Vb object$sig2 <- object$scale <- fit$scale object$sp <- fit$sp names(object$sp) <- names(G$sp) class(object)<-c("gam") } coef <- object$coefficients if (any(!is.finite(coef))) { conv <- FALSE warning(gettextf("non-finite coefficients at iteration %d", iter)) break } } ## end fitting iteration if (method=="fREML") { ## do expensive cov matrix cal only at end res <- Sl.postproc(Sl,fit,um$undrop,qrx$R,cov=TRUE,scale=scale,L=G$L,nt=npt) object$edf <- res$edf object$edf1 <- res$edf1 object$edf2 <- res$edf2 ##object$F <- res$F object$hat <- res$hat object$Vp <- res$Vp object$Ve <- res$Ve object$Vc <- res$Vc } if (!conv) warning("algorithm did not converge") eps <- 10 * .Machine$double.eps if (family$family == "binomial") { if (any(mu > 1 - eps) || any(mu < eps)) warning("fitted probabilities numerically 0 or 1 occurred") } if (family$family == "poisson") { if (any(mu < eps)) warning("fitted rates numerically 0 occurred") } object$R <- qrx$R object$iter <- iter object$wt <- wt object$y <- G$y object$prior.weights <- G$w rm(G);if (gc.level>0) gc() object } ## end bgam.fit ar.qr.up <- function(arg) { ## function to perform QR updating with AR residuals, on one execution thread if (arg$rho!=0) { ## AR1 error model ld <- 1/sqrt(1 - arg$rho^2) ## leading diagonal of root inverse correlation sd <- -arg$rho * ld ## sub diagonal } yX.last <- NULL qrx <- list(R=NULL,f=array(0,0),y.norm2=0) ## initial empty qr object for (i in 1:arg$n.block) { ind <- arg$start[i]:arg$end[i] if (arg$rho!=0) { ## have to find AR1 transform... N <- arg$end[i]-arg$start[i]+1 ## note first row implied by this transform ## is always dropped, unless really at beginning of data. row <- c(1,rep(1:N,rep(2,N))[-c(1,2*N)]) weight <- c(1,rep(c(sd,ld),N-1)) stop <- c(1,1:(N-1)*2+1) if (!is.null(arg$mf$"(AR.start)")) { ## need to correct the start of new AR sections... ii <- which(arg$mf$"(AR.start)"[ind]==TRUE) if (length(ii)>0) { if (ii[1]==1) ii <- ii[-1] ## first observation does not need any correction weight[ii*2-2] <- 0 ## zero sub diagonal weight[ii*2-1] <- 1 ## set leading diagonal to 1 } } } ## arg$G$model <- arg$mf[ind,] w <- sqrt(arg$G$w[ind]) X <- w*predict(arg$G,newdata=arg$mf[ind,],type="lpmatrix",newdata.guaranteed=TRUE,block.size=length(ind)) y <- w*(arg$mf[ind,arg$response] - arg$offset[ind]) ## w*(arg$G$model[[arg$response]] - arg$offset[ind]) if (arg$rho!=0) { ## Apply transform... if (arg$last&&arg$end[i]==arg$nobs) yX.last <- c(y[nrow(X)],X[nrow(X),]) ## store final row, in case of update if (arg$first&&i==1) { X <- rwMatrix(stop,row,weight,X) y <- rwMatrix(stop,row,weight,y) } else { X <- rwMatrix(stop,row,weight,X)[-1,] y <- rwMatrix(stop,row,weight,y)[-1] } } ## dealt with AR1 qrx <- qr.update(X,y,qrx$R,qrx$f,qrx$y.norm2,use.chol=arg$use.chol) rm(X);if (arg$gc.level>1) {gc()} ## X can be large: remove and reclaim } ## all blocks dealt with qrx$yX.last <- yX.last if (arg$gc.level>1) {rm(arg,w,y,ind);gc()} qrx } ## ar.qr.up pabapr <- function(arg) { ## function for parallel calling of predict.gam ## QUERY: ... handling? predict.gam(arg$object,newdata=arg$newdata,type=arg$type,se.fit=arg$se.fit,terms=arg$terms, block.size=arg$block.size,newdata.guaranteed=arg$newdata.guaranteed, na.action=arg$na.action) } predict.bam <- function(object,newdata,type="link",se.fit=FALSE,terms=NULL,exclude=NULL, block.size=50000,newdata.guaranteed=FALSE,na.action=na.pass, cluster=NULL,discrete=TRUE,n.threads=1,...) { ## function for prediction from a bam object, possibly in parallel #if (is.function(na.action)) na.action <- deparse(substitute(na.action)) ## otherwise predict.gam can't detect type if (discrete && !is.null(object$dinfo)) { return(predict.bamd(object,newdata,type,se.fit,terms,exclude, block.size,newdata.guaranteed,na.action,n.threads,...)) } ## remove some un-needed stuff from object object$Sl <- object$qrx <- object$R <- object$F <- object$Ve <- object$Vc <- object$G <- object$residuals <- object$fitted.values <- object$linear.predictors <- NULL gc() if (!is.null(cluster)&&inherits(cluster,"cluster")) { ## require(parallel) n.threads <- length(cluster) } else n.threads <- 1 if (missing(newdata)) n <- nrow(object$model) else { n <- if (is.matrix(newdata[[1]])) nrow(newdata[[1]]) else length(newdata[[1]]) } if (n < 100*n.threads) n.threads <- 1 ## not worth the overheads if (n.threads==1) { ## single threaded call if (missing(newdata)) return( predict.gam(object,newdata=object$model,type=type,se.fit=se.fit,terms=terms,exclude=exclude, block.size=block.size,newdata.guaranteed=newdata.guaranteed, na.action=na.action,...) ) else return( predict.gam(object,newdata=newdata,type=type,se.fit=se.fit,terms=terms,exclude=exclude, block.size=block.size,newdata.guaranteed=newdata.guaranteed, na.action=na.action,...)) } else { ## parallel call... nt <- rep(floor(n/n.threads),n.threads) nt[1] <- n - sum(nt[-1]) arg <- list() n1 <- 0 for (i in 1:n.threads) { n0 <- n1+1;n1 <- n1+nt[i] ind <- n0:n1 ## this thread's data block from mf arg[[i]] <- list(object=object,type=type,se.fit=se.fit,terms=terms,exclude=exclude, block.size=block.size,newdata.guaranteed=newdata.guaranteed, na.action=na.action) arg[[i]]$object$model <- object$model[1:2,] ## save space if (missing(newdata)) { arg[[i]]$newdata <- object$model[ind,] } else { arg[[i]]$newdata <- newdata[ind,] } } ## finished setting up arguments ## newdata and object no longer needed - all info in thread lists... if (!missing(newdata)) rm(newdata) rm(object) gc() res <- parallel::parLapply(cluster,arg,pabapr) ## perform parallel prediction gc() ## and splice results back together... if (type=="lpmatrix") { X <- res[[1]] for (i in 2:length(res)) X <- rbind(X,res[[i]]) return(X) } else if (se.fit==TRUE) { rt <- list(fit = res[[1]]$fit,se.fit = res[[1]]$se.fit) if (type=="terms") { for (i in 2:length(res)) { rt$fit <- rbind(rt$fit,res[[i]]$fit) rt$se.fit <- rbind(rt$se.fit,res[[i]]$se.fit) } } else { for (i in 2:length(res)) { rt$fit <- c(rt$fit,res[[i]]$fit) rt$se.fit <- c(rt$se.fit,res[[i]]$se.fit) } } return(rt) } else { ## no se's returned rt <- res[[1]] if (type=="terms") { for (i in 2:length(res)) rt <- rbind(rt,res[[i]]) } else { for (i in 2:length(res)) rt <- c(rt,res[[i]]) } return(rt) } } } ## end predict.bam bam.fit <- function(G,mf,chunk.size,gp,scale,gamma,method,rho=0, cl=NULL,gc.level=0,use.chol=FALSE,npt=1) ## function that does big additive model fit in strictly additive case { ## first perform the QR decomposition, blockwise.... n <- nrow(mf) if (rho!=0) { ## AR1 error model ld <- 1/sqrt(1-rho^2) ## leading diagonal of root inverse correlation sd <- -rho*ld ## sub diagonal } if (n>chunk.size) { ## then use QR accumulation approach if (!is.null(cl)&&inherits(cl,"cluster")) { n.threads <- length(cl) while(n/n.threads < ncol(G$X)) n.threads <- n.threads - 1 if (n.threads < length(cl)) { warning("Too many cluster nodes to use all efficiently") } } else n.threads <- 1 G$coefficients <- rep(0,ncol(G$X)) class(G) <- "gam" if (n.threads>1) { ## set up thread argument lists ## number of obs per thread nt <- rep(ceiling(n/n.threads),n.threads) nt[n.threads] <- n - sum(nt[-n.threads]) arg <- list() n1 <- 0 for (i in 1:n.threads) { n0 <- n1+1;n1 <- n1+nt[i] if (i>1&&rho!=0) { ## need to start from end of last block if rho!=0 n0 <- n0-1;nt[i] <- nt[i]+1 } ind <- n0:n1 ## this thread's data block from mf n.block <- nt[i]%/%chunk.size ## number of full sized blocks stub <- nt[i]%%chunk.size ## size of end block if (n.block>0) { ## each block is of size start <- (0:(n.block-1))*chunk.size+1 end <- start + chunk.size - 1 if (stub>0) { start[n.block+1] <- end[n.block]+1 end[n.block+1] <- nt[i] n.block <- n.block+1 } if (rho!=0) { ## then blocks must overlap ns <- length(start) if (ns>1) start[2:ns] <- start[2:ns]-1 } } else { n.block <- 1 start <- 1 end <- nt[i] } arg[[i]] <- list(nobs= nt[i],start=start,end=end,n.block=n.block, rho=rho,mf = mf[ind,],gc.level=gc.level, offset = G$offset[ind],G = G,response=gp$response, first=FALSE,last=FALSE,use.chol=use.chol) if (i==1) arg[[1]]$first <- TRUE if (i==n.threads) arg[[i]]$last <- TRUE arg[[i]]$G$w <- G$w[ind];arg[[i]]$G$model <- NULL } } else { ## single thread, requires single indices n.block <- n%/%chunk.size ## number of full sized blocks stub <- n%%chunk.size ## size of end block if (stub>0) n.block <- n.block + 1 start <- 0:(n.block-1)*chunk.size ## block starts end <- start + chunk.size; ## block ends end[n.block] <- n if (rho==0) start <- start + 1 ## otherwise most blocks go to 1 before block start start[1] <- 1 } if (n.threads==1) { ## use original single thread method... qrx <- list(R=NULL,f=array(0,0),y.norm2=0) ## initial empty qr object for (i in 1:n.block) { ind <- start[i]:end[i] if (rho!=0) { N <- end[i]-start[i]+1 row <- c(1,rep(1:N,rep(2,N))[-c(1,2*N)]) weight <- c(1,rep(c(sd,ld),N-1)) stop <- c(1,1:(N-1)*2+1) if (!is.null(mf$"(AR.start)")) { ## need to correct the start of new AR sections... ii <- which(mf$"(AR.start)"[ind]==TRUE) if (length(ii)>0) { if (ii[1]==1) ii <- ii[-1] ## first observation does not need any correction weight[ii*2-2] <- 0 ## zero sub diagonal weight[ii*2-1] <- 1 ## set leading diagonal to 1 } } } #G$model <- mf[ind,] w <- sqrt(G$w[ind]) X <- w*predict(G,newdata=mf[ind,],type="lpmatrix",newdata.guaranteed=TRUE,block.size=length(ind)) y <- w*(mf[ind,gp$response]-G$offset[ind]) ## w*(G$model[[gp$response]] - G$offset[ind]) if (rho!=0) { ## Apply transform... if (end[i]==n) yX.last <- c(y[nrow(X)],X[nrow(X),]) ## store final row, in case of update if (i==1) { X <- rwMatrix(stop,row,weight,X) y <- rwMatrix(stop,row,weight,y) } else { X <- rwMatrix(stop,row,weight,X)[-1,] y <- rwMatrix(stop,row,weight,y)[-1] } } qrx <- qr.update(X,y,qrx$R,qrx$f,qrx$y.norm2,use.chol=use.chol,nt=npt) rm(X) if (gc.level>1) {gc()} ## X can be large: remove and reclaim } ## end of single thread block loop if (use.chol) { ## post proc to get R and f... y.norm2 <- qrx$y.norm2 qrx <- chol2qr(qrx$R,qrx$f,nt=npt) qrx$y.norm2 <- y.norm2 } } else { ## use parallel accumulation res <- parallel::parLapply(cl,arg,ar.qr.up) ## Single thread de-bugging... # res <- list() # for (i in 1:length(arg)) { # res[[i]] <- ar.qr.up(arg[[i]]) # } ## now consolidate the results from the parallel threads... R <- res[[1]]$R;f <- res[[1]]$f; ## dev <- res[[1]]$dev y.norm2 <- res[[1]]$y.norm2 for (i in 2:n.threads) { if (use.chol) { R <- R + res[[i]]$R; f <- f + res[[i]]$f } else { R <- rbind(R,res[[i]]$R); f <- c(f,res[[i]]$f) } y.norm2 <- y.norm2 + res[[i]]$y.norm2 } if (use.chol) { qrx <- chol2qr(R,f,nt=npt) qrx$y.norm2 <- y.norm2 } else { ## proper QR ## use parallel QR if npt>1... qrx <- if (npt>1) pqr2(R,npt) else qr(R,tol=0,LAPACK=TRUE) f <- qr.qty(qrx,f)[1:ncol(R)] rp <- qrx$pivot;rp[rp] <- 1:ncol(R) # reverse pivot qrx <- list(R=qr.R(qrx)[,rp],f=f,y.norm2=y.norm2) } yX.last <- res[[n.threads]]$yX.last } G$n <- n G$y <- mf[[gp$response]] } else { ## n <= chunk.size if (rho==0) qrx <- qr.update(sqrt(G$w)*G$X,sqrt(G$w)*(G$y-G$offset),use.chol=use.chol,nt=npt) else { row <- c(1,rep(1:n,rep(2,n))[-c(1,2*n)]) weight <- c(1,rep(c(sd,ld),n-1)) stop <- c(1,1:(n-1)*2+1) if (!is.null(mf$"(AR.start)")) { ## need to correct the start of new AR sections... ii <- which(mf$"(AR.start)"==TRUE) if (length(ii)>0) { if (ii[1]==1) ii <- ii[-1] ## first observation does not need any correction weight[ii*2-2] <- 0 ## zero sub diagonal weight[ii*2-1] <- 1 ## set leading diagonal to 1 } } yX.last <- c(G$y[n],G$X[n,]) ## store final row, in case of update X <- rwMatrix(stop,row,weight,sqrt(G$w)*G$X) y <- rwMatrix(stop,row,weight,sqrt(G$w)*G$y) qrx <- qr.update(X,y,use.chol=use.chol,nt=npt) rm(X); if (gc.level>1) gc() ## X can be large: remove and reclaim } if (use.chol) { ## post proc to get R and f... y.norm2 <- qrx$y.norm2 qrx <- chol2qr(qrx$R,qrx$f,nt=npt) qrx$y.norm2 <- y.norm2 } } rss.extra <- qrx$y.norm2 - sum(qrx$f^2) if (method=="GCV.Cp") { fit <- magic(qrx$f,qrx$R,G$sp,G$S,G$off,L=G$L,lsp0=G$lsp0,rank=G$rank, H=G$H,C=matrix(0,0,ncol(qrx$R)), ##C=G$C, gamma=gamma,scale=scale,gcv=(scale<=0), extra.rss=rss.extra,n.score=n) post <- magic.post.proc(qrx$R,fit,qrx$f*0+1) } else if (method=="fREML"){ ## use fast REML code Sl <- Sl.setup(G) ## setup block diagonal penalty object um <- Sl.Xprep(Sl,qrx$R,nt=npt) lambda.0 <- initial.sp(qrx$R,G$S,G$off) lsp0 <- log(lambda.0) ## initial s.p. if (scale<=0) log.phi <- log(var(as.numeric(G$y))*.05) else ## initial phi guess log.phi <- log(scale) fit <- fast.REML.fit(um$Sl,um$X,qrx$f,rho=lsp0,L=G$L,rho.0=G$lsp0, log.phi=log.phi,phi.fixed=scale>0,rss.extra=rss.extra, nobs =n,Mp=um$Mp,nt=npt) res <- Sl.postproc(Sl,fit,um$undrop,qrx$R,cov=TRUE,scale=scale,L=G$L,nt=npt) object <- list(coefficients=res$beta,edf=res$edf,edf1=res$edf1,edf2=res$edf2,##F=res$F, db.drho=fit$d1b, gcv.ubre=fit$reml,hat=res$hat,mgcv.conv=list(iter=fit$iter, message=fit$conv),rank=ncol(um$X), Ve=res$Ve,Vp=res$Vp,Vc=res$Vc, scale.estimated = scale<=0,outer.info=fit$outer.info, optimizer=c("perf","newton")) if (scale<=0) { ## get sp's and scale estimate nsp <- length(fit$rho) object$sig2 <- object$scale <- exp(fit$rho[nsp]) object$sp <- exp(fit$rho[-nsp]) nsp <- length(fit$rho.full) object$full.sp <- exp(fit$rho.full[-nsp]) } else { ## get sp's object$sig2 <- object$scale <- scale object$sp <- exp(fit$rho) object$full.sp <- exp(fit$rho.full) } if (rho!=0) { ## correct RE/ML score for AR1 transform df <- if (is.null(mf$"(AR.start)")) 1 else sum(mf$"(AR.start)") object$gcv.ubre <- object$gcv.ubre - (n-df)*log(ld) } G$X <- qrx$R;G$dev.extra <- rss.extra G$pearson.extra <- rss.extra;G$n.true <- n object$Sl <- Sl ## to allow for efficient update class(object)<-c("gam") } else { ## method is "ML", "P-REML" or similar y <- G$y; w <- G$w; n <- G$n;offset <- G$offset G$y <- qrx$f G$w <- G$y*0+1 G$X <- qrx$R G$n <- length(G$y) G$offset <- G$y*0 G$dev.extra <- rss.extra G$pearson.extra <- rss.extra G$n.true <- n object <- gam(G=G,method=method,gamma=gamma,scale=scale,control=gam.control(nthreads=npt)) y -> G$y; w -> G$w; n -> G$n;offset -> G$offset if (rho!=0) { ## correct RE/ML score for AR1 transform df <- if (is.null(mf$"(AR.start)")) 1 else sum(mf$"(AR.start)") object$gcv.ubre <- object$gcv.ubre - (n-df)*log(ld) } } if (method=="GCV.Cp") { object <- list() object$coefficients <- fit$b object$edf <- post$edf object$edf1 <- post$edf1 ##object$F <- post$F object$full.sp <- fit$sp.full object$gcv.ubre <- fit$score object$hat <- post$hat object$mgcv.conv <- fit$gcv.info object$optimizer="magic" object$rank <- fit$gcv.info$rank object$Ve <- post$Ve object$Vp <- post$Vb object$sig2 <- object$scale <- fit$scale object$sp <- fit$sp class(object)<-c("gam") } else { } G$smooth <- G$X <- NULL object$prior.weights <- G$w object$AR1.rho <- rho if (rho!=0) { ## need to store last model matrix row, to allow update object$yX.last <- yX.last } object$R <- qrx$R object$gamma <- gamma;object$G <- G;object$qrx <- qrx ## to allow updating of the model object$y <- mf[[gp$response]] object$iter <- 1 object } # end of bam.fit predict.bamd <- function(object,newdata,type="link",se.fit=FALSE,terms=NULL,exclude=NULL, block.size=50000,newdata.guaranteed=FALSE,na.action=na.pass,n.threads=1,...) { ## function for prediction from a bam object, by discrete methods ## remove some un-needed stuff from object object$Sl <- object$qrx <- object$R <- object$F <- object$Ve <- object$Vc <- object$G <- object$residuals <- object$fitted.values <- object$linear.predictors <- NULL gc() if (missing(newdata)) newdata <- object$model convert2mf <- is.null(attr(newdata,"terms")) if (type=="iterms") { type <- "terms" warning("iterms reset to terms") } if (!is.null(exclude)) warning("exclude ignored by discrete prediction at present") newdata <- predict.gam(object,newdata=newdata,type="newdata",se.fit=se.fit,terms=terms,exclude=exclude, block.size=block.size,newdata.guaranteed=newdata.guaranteed, na.action=na.action,...) ## Parametric terms have to be dealt with safely, but without forming all terms ## or a full model matrix. Strategy here is to use predict.gam, having removed ## key smooth related components from model object, so that it appears to be ## a parametric model... offset <- 0 if (object$nsdf) { ## deal with parametric terms... ## save copies of smooth info... smooth <- object$smooth; coef <- object$coefficients; Vp <- object$Vp ## remove key smooth info from object object$coefficients <- object$coefficients[1:object$nsdf] object$Vp <- object$V[1:object$nsdf,1:object$nsdf] object$smooth <- NULL ## get prediction for parametric component. Always "lpmatrix", unless terms required. ptype <- if (type %in% c("terms","iterms")) type else "lpmatrix" pp <- predict.gam(object,newdata=newdata,type=ptype,se.fit=se.fit,terms=terms,exclude=exclude, block.size=block.size,newdata.guaranteed=TRUE, na.action=na.action,...) ## restore smooths to 'object' object$coefficients <- coef object$Vp <- Vp object$smooth <- smooth if (ptype=="lpmatrix") { offset <- attr(pp,"model.offset") if (is.null(offset)) offset <- 0 } } ## parametric component dealt with ## now discretize covariates... if (convert2mf) newdata <- model.frame(object$dinfo$gp$fake.formula[-2],newdata) dk <- discrete.mf(object$dinfo$gp,mf=newdata,pmf=NULL,full=FALSE) Xd <- list() ### list of discrete model matrices... if (object$nsdf>0) { Xd[[1]] <- if (type%in%c("term","iterms")) matrix(0,0,0) else pp kd <- cbind(1:nrow(newdata),dk$k) ## add index for parametric part to index list kb <- k <- 2; dk$k.start <- c(1,dk$k.start+1) ## and adjust k.start accordingly dk$nr <- c(NA,dk$nr) ## need array index to match elements of Xd } else { kb <- k <- 1; kd <- dk$k } ## k[,ks[j,1]:ks[j,2]] gives index columns for term j, thereby allowing ## summation over matrix covariates.... ks <- cbind(dk$k.start[-length(dk$k.start)],dk$k.start[-1]) ts <- object$dinfo$ts dt <- object$dinfo$dt for (i in 1:length(object$smooth)) { ## work through the smooth list ## first deal with any by variable (as first marginal of tensor)... if (object$smooth[[i]]$by!="NA") { by.var <- dk$mf[[object$smooth[[i]]$by]][1:dk$nr[k]] if (is.factor(by.var)) { ## create dummy by variable... by.var <- as.numeric(by.var==object$smooth[[i]]$by.level) } Xd[[k]] <- matrix(by.var,dk$nr[k],1) k <- k + 1 } ## ... by done if (inherits(object$smooth[[i]],"tensor.smooth")) { nmar <- length(object$smooth[[i]]$margin) if (!is.null(object$smooth[[i]]$rind)) { ## terms re-ordered for efficiency, so the same has to be done on indices... rind <- k:(k+dt[kb]-1) ## could use object$dinfo$dt[kb] dk$nr[rind] <- dk$nr[k+object$smooth[[i]]$rind-1] ks[rind,] <- ks[k+object$smooth[[i]]$rind-1,] # either this line or next not both ##kd[,rind] <- kd[,k+object$smooth[[i]]$rind-1] } XP <- object$smooth[[i]]$XP for (j in 1:nmar) { Xd[[k]] <- PredictMat(smooth[[i]]$margin[[j]],dk$mf,n=dk$nr[k]) if (!is.null(XP)&&(j<=length(XP))&&!is.null(XP[[j]])) Xd[[k]] <- Xd[[k]]%*%XP[[j]] k <- k + 1 } } else { ## not a tensor smooth object$smooth[[i]]$by <- "NA" ## have to ensure by not applied here! Xd[[k]] <- PredictMat(object$smooth[[i]],dk$mf,n=dk$nr[k]) k <- k + 1 } kb <- kb + 1 } ## end of discrete set up se <- se.fit if (type=="terms") { if (object$nsdf>0) { if (se) { fit <- cbind(pp$fit,matrix(0,nrow(kd),length(object$smooth))) se.fit <- cbind(pp$se.fit,matrix(0,nrow(kd),length(object$smooth))) } else fit <- cbind(pp,matrix(0,nrow(kd),length(object$smooth))) k <- 2; ## starting Xd kk <- ncol(fit) - length(object$smooth) + 1 ## starting col of fit for smooth terms } else { if (se) { fit <- matrix(0,nrow(kd),length(object$smooth)) se.fit <- matrix(0,nrow(kd),length(object$smooth)) } else fit <- matrix(0,nrow(kd),length(object$smooth)) k <- 1; ## starting Xd kk <- 1 ## starting col of fit for smooth terms } for (i in 1:length(object$smooth)) { ii <- ts[k]:(ts[k]+dt[k]-1) ## index components for this term ind <- object$smooth[[i]]$first.para:object$smooth[[i]]$last.para ## index coefs for this term if (!is.null(object$dinfo$drop)) { drop <- object$dinfo$drop-object$smooth[[i]]$first.para+1 drop <- drop[drop<=length(ii)] } else drop <- NULL fit[,kk] <- Xbd(Xd[ii],object$coefficients[ind],kd,ks[ii,], ##kd[,ii,drop=FALSE] 1,dt[k],object$dinfo$v[k],object$dinfo$qc[k],drop=drop) if (se) se.fit[,kk] <- diagXVXd(Xd[ii],object$Vp[ind,ind],kd,ks[ii,], #kd[,ii,drop=FALSE], 1,dt[k],object$dinfo$v[k],object$dinfo$qc[k],drop=drop,n.threads=n.threads)^.5 k <- k + 1; kk <- kk + 1 } fit.names <- c(if (se) colnames(pp$fit) else colnames(pp),unlist(lapply(object$smooth,function(x) x$label))) colnames(fit) <- fit.names if (se) { colnames(se.fit) <- fit.names fit <- list(fit=fit,se.fit=se.fit) } } else if (type=="lpmatrix") { fit <- Xbd(Xd,diag(length(object$coefficients)),kd,ks,ts,dt,object$dinfo$v,object$dinfo$qc,drop=object$dinfo$drop) } else { ## link or response fit <- Xbd(Xd,object$coefficients,kd,ks,ts,dt,object$dinfo$v,object$dinfo$qc,drop=object$dinfo$drop) + offset if (type=="response") { linkinv <- object$family$linkinv dmu.deta <- object$family$mu.eta } else linkinv <- dmu.deta <- NULL if (se==TRUE) { se.fit <- diagXVXd(Xd,object$Vp,kd,ks,ts,dt,object$dinfo$v,object$dinfo$qc,drop=object$dinfo$drop,n.threads=n.threads)^.5 if (type=="response") { se.fit <- se.fit * abs(dmu.deta(fit)) fit <- linkinv(fit) } fit <- list(fit=fit,se.fit=se.fit) } else if (type=="response") fit <- linkinv(fit) } fit } ## end predict.bamd tero <- function(sm) { ## te smooth spec re-order so that largest marginal is last. maxd <- 0 ns <- length(sm$margin) for (i in 1:ns) if (sm$margin[[i]]$bs.dim>=maxd) { maxi <- i;maxd <- sm$margin[[i]]$bs.dim } if (maxi0) { if (ii[1]==1) ii <- ii[-1] ## first observation does not need any correction ar.weight[ii*2-2] <- 0 ## zero sub diagonal ar.weight[ii*2-1] <- 1 ## set leading diagonal to 1 } } rwMatrix(ar.stop,ar.row,ar.weight,rsd) } ## AR.resid bam <- function(formula,family=gaussian(),data=list(),weights=NULL,subset=NULL,na.action=na.omit, offset=NULL,method="fREML",control=list(),select=FALSE,scale=0,gamma=1,knots=NULL,sp=NULL, min.sp=NULL,paraPen=NULL,chunk.size=10000,rho=0,AR.start=NULL,discrete=FALSE, cluster=NULL,nthreads=NA,gc.level=1,use.chol=FALSE,samfrac=1,coef=NULL, drop.unused.levels=TRUE,G=NULL,fit=TRUE,drop.intercept=NULL,...) ## Routine to fit an additive model to a large dataset. The model is stated in the formula, ## which is then interpreted to figure out which bits relate to smooth terms and which to ## parametric terms. ## This is a modification of `gam' designed to build the QR decompostion of the model matrix ## up in chunks, to keep memory costs down. ## If cluster is a parallel package cluster uses parallel QR build on cluster. ## 'n.threads' is number of threads to use for non-cluster computation (e.g. combining ## results from cluster nodes). If 'NA' then is set to max(1,length(cluster)). { control <- do.call("gam.control",control) if (control$trace) t3 <- t2 <- t1 <- t0 <- proc.time() if (is.null(G)) { ## need to set up model! if (is.character(family)) family <- eval(parse(text = family)) if (is.function(family)) family <- family() if (is.null(family$family)) stop("family not recognized") if (inherits(family,"extended.family")) stop("extended families not supported by bam") ##family = gaussian() ## no choise here if (family$family=="gaussian"&&family$link=="identity") am <- TRUE else am <- FALSE if (scale==0) { if (family$family%in%c("poisson","binomial")) scale <- 1 else scale <- -1} if (!method%in%c("fREML","GCV.Cp","REML", "ML","P-REML","P-ML")) stop("un-supported smoothness selection method") if (is.logical(discrete)) { discretize <- discrete discrete <- NULL ## use default discretization, if any } else { discretize <- if (is.numeric(discrete)) TRUE else FALSE } if (discretize) { if (method!="fREML") { discretize <- FALSE warning("discretization only available with fREML") } else { if (!is.null(cluster)) warning("discrete method does not use parallel cluster - use nthreads instead") } } if (method%in%c("fREML")&&!is.null(min.sp)) { min.sp <- NULL warning("min.sp not supported with fast REML computation, and ignored.") } gp <- interpret.gam(formula) # interpret the formula if (discretize) { ## re-order the tensor terms for maximum efficiency, and ## signal that "re"/"fs" terms should be constructed with marginals ## also for efficiency if (length(gp$smooth.spec)>0) for (i in 1:length(gp$smooth.spec)) { if (inherits(gp$smooth.spec[[i]],"tensor.smooth.spec")) gp$smooth.spec[[i]] <- tero(gp$smooth.spec[[i]]) if (inherits(gp$smooth.spec[[i]],c("re.smooth.spec","fs.smooth.spec"))&&gp$smooth.spec[[i]]$dim>1) { #gp$smooth.spec[[i]]$xt <- "tensor" class(gp$smooth.spec[[i]]) <- c(class(gp$smooth.spec[[i]]),"tensor.smooth.spec") ##c("re.smooth.spec","tensor.smooth.spec") gp$smooth.spec[[i]]$margin <- list() ## only ok for 'fs' with univariate metric variable (caught in 'fs' construcor)... for (j in 1:gp$smooth.spec[[i]]$dim) gp$smooth.spec[[i]]$margin[[j]] <- list(term=gp$smooth.spec[[i]]$term[j]) } } } cl <- match.call() # call needed in gam object for update to work mf <- match.call(expand.dots=FALSE) mf$formula <- gp$fake.formula mf$method <- mf$family<-mf$control<-mf$scale<-mf$knots<-mf$sp<-mf$min.sp <- mf$gc.level <- mf$gamma <- mf$paraPen<- mf$chunk.size <- mf$rho <- mf$cluster <- mf$discrete <- mf$use.chol <- mf$samfrac <- mf$nthreads <- mf$G <- mf$fit <- mf$select <- mf$drop.intercept <- mf$coef <- mf$...<-NULL mf$drop.unused.levels <- drop.unused.levels mf[[1]] <- quote(stats::model.frame) ## as.name("model.frame") pmf <- mf pmf$formula <- gp$pf pmf <- eval(pmf, parent.frame()) # pmf contains all data for parametric part pterms <- attr(pmf,"terms") ## pmf only used for this and discretization, if selected. if (gc.level>0) gc() mf <- eval(mf, parent.frame()) # the model frame now contains all the data # if ("matrix"%in%unlist(lapply(mf,class))) { # mfattr <- attributes(mf) # mf <- lapply(mf,drop) # avoid single column matrices # mfattr -> attributes(mf) # } if (nrow(mf)<2) stop("Not enough (non-NA) data to do anything meaningful") terms <- attr(mf,"terms") if (gc.level>0) gc() if (rho!=0&&!is.null(mf$"(AR.start)")) if (!is.logical(mf$"(AR.start)")) stop("AR.start must be logical") ## summarize the *raw* input variables ## note can't use get_all_vars here -- buggy with matrices vars <- all.vars1(gp$fake.formula[-2]) ## drop response here inp <- parse(text = paste("list(", paste(vars, collapse = ","),")")) ## allow a bit of extra flexibility in what `data' is allowed to be (as model.frame actually does) if (!is.list(data)&&!is.data.frame(data)) data <- as.data.frame(data) dl <- eval(inp, data, parent.frame()) if (!control$keepData) { rm(data);gc()} ## save space names(dl) <- vars ## list of all variables needed var.summary <- variable.summary(gp$pf,dl,nrow(mf)) ## summarize the input data rm(dl); if (gc.level>0) gc() ## save space ## should we force the intercept to be dropped, meaning that the constant is removed ## from the span of the parametric effects? if (is.null(family$drop.intercept)) { ## family does not provide information if (is.null(drop.intercept)) drop.intercept <- FALSE else { drop.intercept <- drop.intercept[1] ## force drop.intercept to correct length if (drop.intercept) family$drop.intercept <- drop.intercept ## ensure prediction works } } else drop.intercept <- as.logical(family$drop.intercept) ## family overrides argument ## need mini.mf for basis setup, then accumulate full X, y, w and offset if (discretize) { ## discretize the data, creating list mf0 with discrete values ## and indices giving the discretized value for each element of model frame. ## 'discrete' can be null, or contain a discretization size, or ## a discretization size per smooth term. dk <- discrete.mf(gp,mf,pmf,m=discrete) mf0 <- dk$mf ## padded discretized model frame sparse.cons <- 0 ## default constraints required for tensor terms } else { mf0 <- mini.mf(mf,chunk.size) sparse.cons <- -1 } rm(pmf); ## no further use if (control$trace) t1 <- proc.time() reset <- TRUE while (reset) { G <- gam.setup(gp,pterms=pterms, data=mf0,knots=knots,sp=sp,min.sp=min.sp, H=NULL,absorb.cons=TRUE,sparse.cons=sparse.cons,select=select, idLinksBases=TRUE,scale.penalty=control$scalePenalty, paraPen=paraPen,apply.by=!discretize,drop.intercept=drop.intercept,modCon=2) if (!discretize&&ncol(G$X)>=chunk.size) { ## no point having chunk.size < p chunk.size <- 4*ncol(G$X) warning(gettextf("chunk.size < number of coefficients. Reset to %d",chunk.size)) if (chunk.size>=nrow(mf)) { ## no sense splitting up computation mf0 <- mf ## just use full dataset } else reset <- FALSE } else reset <- FALSE } if (control$trace) t2 <- proc.time() if (discretize) { v <- G$Xd <- list() ## have to extract full parametric model matrix from pterms and mf G$Xd[[1]] <- model.matrix(G$pterms,mf) if (drop.intercept) { xat <- attributes(G$Xd[[1]]);ind <- xat$assign>0 ## index of non intercept columns G$Xd[[1]] <- G$Xd[[1]][,ind,drop=FALSE] ## drop intercept xat$assign <- xat$assign[ind];xat$dimnames[[2]]<-xat$dimnames[[2]][ind]; xat$dim[2] <- xat$dim[2]-1;attributes(G$Xd[[1]]) <- xat } #G$kd <- cbind(1:nrow(mf),dk$k) ## add index for parametric part to index list #dk$k.start <- c(1,dk$k.start+1) ## and adjust k.start accordingly ## k[,ks[j,1]:ks[j,2]] gives index columns for term j, thereby allowing ## summation over matrix covariates.... #G$ks <- cbind(dk$k.start[-length(dk$k.start)],dk$k.start[-1]) ## create data object suitable for discrete data methods, from marginal model ## matrices in G$smooth and G$X (stripping out padding, of course) if (ncol(G$Xd[[1]])) { G$kd <- cbind(1:nrow(mf),dk$k) ## add index for parametric part to index list dk$k.start <- c(1,dk$k.start+1) ## and adjust k.start accordingly kb <- k <- 2; qc <- dt <- ts <- rep(0,length(G$smooth)+1) dt[1] <- ts[1] <- 1; dk$nr <- c(NA,dk$nr) ## need array index to match elements of Xd } else { G$kd <- dk$k kb <- k <- 1; qc <- dt <- ts <- rep(0,length(G$smooth)) } ## k[,ks[j,1]:ks[j,2]] gives index columns for term j, thereby allowing ## summation over matrix covariates.... G$ks <- cbind(dk$k.start[-length(dk$k.start)],dk$k.start[-1]) drop <- rep(0,0) ## index of te related columns to drop for (i in 1:length(G$smooth)) { ts[kb] <- k ## first deal with any by variable (as first marginal of tensor)... if (G$smooth[[i]]$by!="NA") { dt[kb] <- 1 by.var <- dk$mf[[G$smooth[[i]]$by]][1:dk$nr[k]] if (is.factor(by.var)) { ## create dummy by variable... by.var <- as.numeric(by.var==G$smooth[[i]]$by.level) } G$Xd[[k]] <- matrix(by.var,dk$nr[k],1) k <- k + 1 } else dt[kb] <- 0 ## ... by done if (inherits(G$smooth[[i]],"tensor.smooth")) { nmar <- length(G$smooth[[i]]$margin) dt[kb] <- dt[kb] + nmar if (inherits(G$smooth[[i]],"fs.interaction")&&which(G$smooth[[i]]$fterm==G$smooth[[i]]$term)!=1) { ## have to reverse the terms because tensor representation assumes factor is first G$smooth[[i]]$rind <- 2:1 ## (k+1):k } if (!is.null(G$smooth[[i]]$rind)) { ## terms re-ordered for efficiency, so the same has to be done on indices... rind <- k:(k+dt[kb]-1) dk$nr[rind] <- dk$nr[k+G$smooth[[i]]$rind-1] G$ks[rind,] <- G$ks[k+G$smooth[[i]]$rind-1,] # either this line or next not both #G$kd[,rind] <- G$kd[,k+G$smooth[[i]]$rind-1] } for (j in 1:nmar) { G$Xd[[k]] <- G$smooth[[i]]$margin[[j]]$X[1:dk$nr[k],,drop=FALSE] k <- k + 1 } ## deal with any side constraints on tensor terms di <- attr(G$smooth[[i]],"del.index") if (!is.null(di)&&length(di>0)) { di <- di + G$smooth[[i]]$first.para + length(drop) - 1 drop <- c(drop,di) } ## deal with tensor smooth constraint qrc <- attr(G$smooth[[i]],"qrc") ## compute v such that Q = I-vv' and Q[,-1] is constraint null space basis if (inherits(qrc,"qr")) { v[[kb]] <- qrc$qr/sqrt(qrc$qraux);v[[kb]][1] <- sqrt(qrc$qraux) qc[kb] <- 1 ## indicate a constraint } else { v[[kb]] <- rep(0,0) ## if (!inherits(qrc,"character")||qrc!="no constraints") warning("unknown tensor constraint type") } } else { ## not a tensor smooth v[[kb]] <- rep(0,0) dt[kb] <- dt[kb] + 1 G$Xd[[k]] <- G$X[1:dk$nr[k],G$smooth[[i]]$first.para:G$smooth[[i]]$last.para] k <- k + 1 } kb <- kb + 1 } if (length(drop>0)) G$drop <- drop ## index of terms to drop as a result of side cons on tensor terms ## ... Xd is the list of discretized model matrices, or marginal model matrices ## kd contains indexing vectors, so the ith model matrix or margin is Xd[[i]][kd[i,],] ## ts[i] is the starting matrix in Xd for the ith model matrix, while dt[i] is the number ## of elements of Xd that make it up (1 for a singleton, more for a tensor). ## v is list of Householder vectors encoding constraints and qc the constraint indicator. G$v <- v;G$ts <- ts;G$dt <- dt;G$qc <- qc } ## if (discretize) if (control$trace) t3 <- proc.time() ## no advantage to "fREML" with no free smooths... if (((!is.null(G$L)&&ncol(G$L) < 1)||(length(G$sp)==0))&&method=="fREML") method <- "REML" G$var.summary <- var.summary G$family <- family G$terms<-terms; G$pred.formula <- gp$pred.formula n <- nrow(mf) if (is.null(mf$"(weights)")) G$w<-rep(1,n) else G$w<-mf$"(weights)" G$offset <- model.offset(mf) if (is.null(G$offset)) G$offset <- rep(0,n) if (!discretize && ncol(G$X)>nrow(mf)) stop("Model has more coefficients than data") if (ncol(G$X) > chunk.size && !discretize) { ## no sense having chunk.size < p chunk.size <- 4*ncol(G$X) warning(gettextf("chunk.size < number of coefficients. Reset to %d",chunk.size)) } G$cl<-cl; G$am <- am G$min.edf<-G$nsdf #-dim(G$C)[1] if (G$m) for (i in 1:G$m) G$min.edf<-G$min.edf+G$smooth[[i]]$null.space.dim G$discretize <- discretize G$formula<-formula ## environment(G$formula)<-environment(formula) environment(G$pterms) <- environment(G$terms) <- environment(G$pred.formula) <- environment(G$formula) <- .BaseNamespaceEnv } else { ## G supplied scale <- G$scale mf <- G$mf; G$mf <- NULL gp <- G$gp; G$gp <- NULL na.action <- G$na.action; G$na.action <- NULL } ## end of G setup if (!fit) { G$scale <- scale G$mf <- mf;G$na.action <- na.action;G$gp <- gp return(G) } ## number of threads to use for non-cluster node computation if (!is.finite(nthreads)||nthreads<1) nthreads <- max(1,length(cluster)) G$conv.tol<-control$mgcv.tol # tolerence for mgcv G$max.half<-control$mgcv.half # max step halving in bfgs optimization ## now build up proper model matrix, and deal with y, w, and offset... if (control$trace) cat("Setup complete. Calling fit\n") colnamesX <- colnames(G$X) if (G$am&&!G$discretize) { if (nrow(mf)>chunk.size) G$X <- matrix(0,0,ncol(G$X)); if (gc.level>1) gc() object <- bam.fit(G,mf,chunk.size,gp,scale,gamma,method,rho=rho,cl=cluster, gc.level=gc.level,use.chol=use.chol,npt=nthreads) } else if (G$discretize) { object <- bgam.fitd(G, mf, gp ,scale ,nobs.extra=0,rho=rho,coef=coef, control = control,npt=nthreads,gc.level=gc.level,...) } else { G$X <- matrix(0,0,ncol(G$X)); if (gc.level>1) gc() if (rho!=0) warning("AR1 parameter rho unused with generalized model") if (samfrac<1 && samfrac>0) { ## sub-sample first to get close to right answer... ind <- sample(1:nrow(mf),ceiling(nrow(mf)*samfrac)) if (length(ind)<2*ncol(G$X)) warning("samfrac too small - ignored") else { Gw <- G$w;Goffset <- G$offset G$w <- G$w[ind];G$offset <- G$offset[ind] control1 <- control control1$epsilon <- 1e-2 object <- bgam.fit(G, mf[ind,], chunk.size, gp ,scale ,gamma,method=method,nobs.extra=0, control = control1,cl=cluster,npt=nthreads,gc.level=gc.level,coef=coef, use.chol=use.chol,samfrac=1,...) G$w <- Gw;G$offset <- Goffset coef <- object$coefficients } } ## fit full dataset object <- bgam.fit(G, mf, chunk.size, gp ,scale ,gamma,method=method,coef=coef, control = control,cl=cluster,npt=nthreads,gc.level=gc.level, use.chol=use.chol,...) } if (gc.level>0) gc() if (control$trace) t4 <- proc.time() if (control$trace) cat("Fit complete. Finishing gam object.\n") if (scale < 0) { object$scale.estimated <- TRUE;object$scale <- object$scale.est} else { object$scale.estimated <- FALSE; object$scale <- scale } object$assign <- G$assign # applies only to pterms object$boundary <- FALSE # always FALSE for this case object$call<-G$cl # needed for update() to work object$cmX <- G$cmX ## column means of model matrix --- useful for CIs object$contrasts <- G$contrasts object$control <- control object$converged <- TRUE ## no iteration object$data <- NA ## not saving it in this case object$df.null <- nrow(mf) object$df.residual <- object$df.null - sum(object$edf) object$family <- family object$formula<-G$formula if (method=="GCV.Cp") { if (scale<=0) object$method <- "GCV" else object$method <- "UBRE" } else { object$method <- method } object$min.edf<-G$min.edf object$model <- mf;rm(mf);if (gc.level>0) gc() object$na.action <- attr(object$model,"na.action") # how to deal with NA's object$nsdf <- G$nsdf if (G$nsdf>0) names(object$coefficients)[1:G$nsdf] <- colnamesX[1:G$nsdf] object$offset <- G$offset ##object$prior.weights <- G$w object$pterms <- G$pterms object$pred.formula <- G$pred.formula object$smooth <- G$smooth object$terms <- G$terms object$var.summary <- G$var.summary if (is.null(object$wt)) object$weights <- object$prior.weights else object$weights <- object$wt object$xlevels <- G$xlevels #object$y <- object$model[[gp$response]] object$NA.action <- na.action ## version to use in bam.update names(object$sp) <- names(G$sp) if (!is.null(object$full.sp)) names(object$full.sp) <- names(G$lsp0) names(object$coefficients) <- G$term.names names(object$edf) <- G$term.names ## note that predict.gam assumes that it must be ok not to split the ## model frame, if no new data supplied, so need to supply explicitly class(object) <- c("bam","gam","glm","lm") if (!G$discretize) { object$linear.predictors <- as.numeric(predict.bam(object,newdata=object$model,block.size=chunk.size,cluster=cluster)) } else { ## store discretization specific information to help with discrete prediction object$dinfo <- list(gp=gp, v = G$v, ts = G$ts, dt = G$dt, qc = G$qc, drop = G$drop) } rm(G);if (gc.level>0) gc() object$fitted.values <- family$linkinv(object$linear.predictors) object$residuals <- sqrt(family$dev.resids(object$y,object$fitted.values,object$prior.weights)) * sign(object$y-object$fitted.values) if (rho!=0) object$std.rsd <- AR.resid(object$residuals,rho,object$model$"(AR.start)") dev <- object$deviance <- sum(object$residuals^2) if (rho!=0&&family$family=="gaussian") dev <- sum(object$std.rsd^2) object$aic <- family$aic(object$y,1,object$fitted.values,object$prior.weights,dev) - 2 * (length(object$y) - sum(sum(object$model[["(AR.start)"]])))*log(1/sqrt(1-rho^2)) + ## correction for AR 2*sum(object$edf) if (!is.null(object$edf2)&&sum(object$edf2)>sum(object$edf1)) object$edf2 <- object$edf1 object$null.deviance <- sum(family$dev.resids(object$y,weighted.mean(object$y,object$prior.weights),object$prior.weights)) if (!is.null(object$full.sp)) { if (length(object$full.sp)==length(object$sp)&& all.equal(object$sp,object$full.sp)==TRUE) object$full.sp <- NULL } environment(object$formula) <- environment(object$pred.formula) <- environment(object$terms) <- environment(object$pterms) <- environment(attr(object$model,"terms")) <- .GlobalEnv if (control$trace) { t5 <- proc.time() t5 <- rbind(t1-t0,t2-t1,t3-t2,t4-t3,t5-t4)[,1:3] row.names(t5) <- c("initial","gam.setup","pre-fit","fit","finalise") print(t5) } names(object$gcv.ubre) <- method object } ## end of bam bam.update <- function(b,data,chunk.size=10000) { ## update the strictly additive model `b' in the light of new data in `data' ## Need to update modelframe (b$model) if (is.null(b$qrx)) { stop("Model can not be updated") } gp<-interpret.gam(b$formula) # interpret the formula X <- predict(b,newdata=data,type="lpmatrix",na.action=b$NA.action) ## extra part of model matrix rownames(X) <- NULL cnames <- names(b$coefficients) AR.start <- NULL ## keep R checks happy ## now get the new data in model frame form... getw <- "(weights)"%in%names(b$model) getARs <- "(AR.start)"%in%names(b$model) if (getw&&getARs) { mf <- model.frame(gp$fake.formula,data,weights=weights,AR.start=AR.start, xlev=b$xlev,na.action=b$NA.action) w <- mf[["(weights)"]] } else if (getw) { mf <- model.frame(gp$fake.formula,data,weights=weights,xlev=b$xlev,na.action=b$NA.action) w <- mf[["(weights)"]] } else if (getARs) { mf <- model.frame(gp$fake.formula,data,AR.start=AR.start,xlev=b$xlev,na.action=b$NA.action) w <- rep(1,nrow(mf)) } else { mf <- model.frame(gp$fake.formula,data,xlev=b$xlev,na.action=b$NA.action) w <- rep(1,nrow(mf)) } b$model <- rbind(b$model,mf) ## complete model frame --- old + new ## get response and offset... off.col <- attr(attr(b$model,"terms"),"offset") if (is.null(off.col)) offset <- rep(0,nrow(mf)) else offset <- mf[,off.col] y <- mf[,attr(attr(b$model,"terms"),"response")] - offset ## update G b$G$y <- c(b$G$y,y) b$G$offset <- c(b$G$offset,offset) b$G$w <- c(b$G$w,w) b$G$n <- nrow(b$model) n <- b$G$n; ## update the qr decomposition... w <- sqrt(w) if (b$AR1.rho!=0) { ## original model had AR1 error structure... rho <- b$AR1.rho ld <- 1/sqrt(1-rho^2) ## leading diagonal of root inverse correlation sd <- -rho*ld ## sub diagonal ## append the final row of weighted X and y from original fit, first wy <- c(b$yX.last[1],w*y) wX <- rbind(b$yX.last[-1],w*X) m <- nrow(wX) b$yX.last <- c(wy[m],wX[m,]) row <- c(1,rep(1:m,rep(2,m))[-c(1,2*m)]) weight <- c(1,rep(c(sd,ld),m-1)) stop <- c(1,1:(m-1)*2+1) if (!is.null(mf$"(AR.start)")) { ## need to correct the start of new AR sections... ii <- which(mf$"(AR.start)"==TRUE) if (length(ii)>0) { if (ii[1]==1) ii <- ii[-1] ## first observation does not need any correction weight[ii*2-2] <- 0 ## zero sub diagonal weight[ii*2-1] <- 1 ## set leading diagonal to 1 } } ## re-weight to independence.... wX <- rwMatrix(stop,row,weight,wX)[-1,] wy <- rwMatrix(stop,row,weight,wy)[-1] ## update b$qrx <- qr.update(wX,wy,b$qrx$R,b$qrx$f,b$qrx$y.norm2) } else { b$qrx <- qr.update(w*X,w*y,b$qrx$R,b$qrx$f,b$qrx$y.norm2) } ## now do the refit... rss.extra <- b$qrx$y.norm2 - sum(b$qrx$f^2) if (b$method=="GCV"||b$method=="UBRE") method <- "GCV.Cp" else method <- b$method if (method=="GCV.Cp") { if (b$method=="GCV") scale <- -1 else scale = b$sig2 fit <- magic(b$qrx$f,b$qrx$R,b$sp,b$G$S,b$G$off,L=b$G$L,lsp0=b$G$lsp0,rank=b$G$rank, H=b$G$H,C= matrix(0,0,ncol(b$qrx$R)),##C=b$G$C, gamma=b$gamma,scale=scale,gcv=(scale<=0), extra.rss=rss.extra,n.score=n) post <- magic.post.proc(b$qrx$R,fit,b$qrx$f*0+1) b$y <- b$G$y;b$offset <- b$G$offset; b$G$w -> b$weights -> b$prior.weights; } else if (method=="fREML") { ## fast REML um <- Sl.Xprep(b$Sl,b$qrx$R) lsp0 <- log(b$sp) ## initial s.p. log.phi <- log(b$sig2) ## initial or fixed scale fit <- fast.REML.fit(um$Sl,um$X,b$qrx$f,rho=lsp0,L=b$G$L,rho.0=b$G$lsp0, log.phi=log.phi,phi.fixed = !b$scale.estimated,rss.extra=rss.extra, nobs =n,Mp=um$Mp,nt=1) if (b$scale.estimated) scale <- -1 else scale=b$sig2 res <- Sl.postproc(b$Sl,fit,um$undrop,b$qrx$R,cov=TRUE,scale=scale,L=b$g$L) object <- list(coefficients=res$beta,edf=res$edf,edf1=res$edf1,edf2=res$edf2,##F=res$F, gcv.ubre=fit$reml,hat=res$hat,outer.info=list(iter=fit$iter, message=fit$conv),optimizer="fast-REML",rank=ncol(um$X), Ve=NULL,Vp=res$V,Vc=res$Vc,db.drho=fit$d1b,scale.estimated = scale<=0) if (scale<=0) { ## get sp's and scale estimate nsp <- length(fit$rho) object$sig2 <- object$scale <- exp(fit$rho[nsp]) object$sp <- exp(fit$rho[-nsp]) nsp <- length(fit$rho.full) object$full.sp <- exp(fit$rho.full[-nsp]) } else { ## get sp's object$sig2 <- object$scale <- scale object$sp <- exp(fit$rho) object$full.sp <- exp(fit$rho.full) } if (b$AR1.rho!=0) { ## correct RE/ML score for AR1 transform df <- if (getARs) sum(b$model$"(AR.start)") else 1 object$gcv.ubre <- object$gcv.ubre - (n-df)*log(ld) } b$G$X <- b$qrx$R;b$G$dev.extra <- rss.extra b$G$pearson.extra <- rss.extra;b$G$n.true <- n b$y <- b$G$y;b$offset <- b$G$offset; b$G$w -> b$weights -> b$prior.weights; } else { ## method is "REML" or "ML" y <- b$G$y; w <- b$G$w;offset <- b$G$offset b$G$y <- b$qrx$f b$G$w <- b$G$y*0+1 b$G$X <- b$qrx$R b$G$n <- length(b$G$y) b$G$offset <- b$G$y*0 b$G$dev.extra <- rss.extra b$G$pearson.extra <- rss.extra b$G$n.true <- n if (b$scale.estimated) scale <- -1 else scale = b$sig2 in.out <- list(sp=b$sp,scale=b$reml.scale) object <- gam(G=b$G,method=method,gamma=b$gamma,scale=scale,in.out=in.out) if (b$AR1.rho!=0) { ## correct RE/ML score for AR1 transform df <- if (getARs) sum(b$model$"(AR.start)") else 1 object$gcv.ubre <- object$gcv.ubre - (n-df)*log(ld) } offset -> b$G$offset -> b$offset w -> b$G$w -> b$weights -> b$prior.weights; n -> b$G$n y -> b$G$y -> b$y; } if (method=="GCV.Cp") { b$coefficients <- fit$b b$edf <- post$edf b$edf1 <- post$edf1 ##b$F <- post$F b$full.sp <- fit$sp.full b$gcv.ubre <- fit$score b$hat <- post$hat b$mgcv.conv <- fit$gcv.info b$optimizer="magic" b$rank <- fit$gcv.info$rank b$Ve <- post$Ve b$Vp <- post$Vb b$sig2 <- b$scale <- fit$scale b$sp <- fit$sp } else { ## REML or ML b$coefficients <- object$coefficients b$edf <- object$edf b$edf1 <- object$edf1 ##b$F <- object$F b$full.sp <- object$sp.full b$gcv.ubre <- object$gcv.ubre b$hat <- object$hat b$outer.info <- object$outer.info b$rank <- object$rank b$Ve <- object$Ve b$Vp <- object$Vp b$sig2 <- b$scale <- object$sig2 b$sp <- object$sp if (b$AR1.rho!=0) { ## correct RE/ML score for AR1 transform b$gcv.ubre <- b$gcv.ubre - (n-1)*log(ld) } } b$R <- b$qrx$R b$G$X <- NULL b$linear.predictors <- as.numeric(predict.gam(b,newdata=b$model,block.size=chunk.size)) b$fitted.values <- b$linear.predictor ## strictly additive only! b$residuals <- sqrt(b$family$dev.resids(b$y,b$fitted.values,b$prior.weights)) * sign(b$y-b$fitted.values) b$deviance <- sum(b$residuals^2) b$aic <- b$family$aic(b$y,1,b$fitted.values,b$prior.weights,b$deviance) + 2 * sum(b$edf) if (b$AR1.rho!=0) { ## correct aic for AR1 transform df <- if (getARs) sum(b$model$"(AR.start)") else 1 b$aic <- b$aic + 2*(n-df)*log(ld) } b$null.deviance <- sum(b$family$dev.resids(b$y,mean(b$y),b$prior.weights)) names(b$coefficients) <- names(b$edf) <- cnames b } ## end of bam.update #### ISSUES: ## ? negative binomial support --- docs say it's there... ## offset unused in bam/bgam.fit, also gp only needed for "response", ## so could efficiently be replaced mgcv/R/gamm.r0000755000177400001440000020053312723257137012724 0ustar murdochusers ### the following two functions are for use in place of log and exp ### in positivity ensuring re-parameterization.... they have `better' ### over/underflow characteristics, but are still continuous to second ### derivative. notExp <- function(x) # overflow avoiding C2 function for ensuring positivity { f <- x ind <- x > 1 f[ind] <- exp(1)*(x[ind]^2+1)/2 ind <- (x <= 1)&(x > -1) f[ind] <- exp(x[ind]) ind <- (x <= -1) x[ind] <- -x[ind] ;f[ind] <- exp(1)*(x[ind]^2+1)/2; f[ind]<-1/f[ind] f } notLog <- function(x) # inverse function of notExp { f <- x ind <- x> exp(1) f[ind] <- sqrt(2*x[ind]/exp(1)-1) ind <- !ind & x > exp(-1) f[ind] <- log(x[ind]) ind <- x <= exp(-1) x[ind]<- 1/x[ind]; f[ind] <- sqrt(2*x[ind]/exp(1)-1);f[ind] <- -f[ind] f } ## notLog/notExp replacements. ## around 27/7/05 nlme was modified to use a new optimizer, which fails with ## indefinite Hessians. This is a problem if smoothing parameters are zero ## or infinite. The following attempts to make the notLog parameterization ## non-monotonic, to artificially reduce the likelihood at very large and very ## small parameter values. ## note gamm, pdTens, pdIdnot, notExp and notExp2 .Rd files all modified by ## this change. notExp2 <- function (x,d=.Options$mgcv.vc.logrange,b=1/d) ## to avoid needing to modify solve.pdIdnot, this transformation must ## maintain the property that 1/notExp2(x) = notExp2(-x) { exp(d*sin(x*b)) } notLog2 <- function(x,d=.Options$mgcv.vc.logrange,b=1/d) { x <- log(x)/d x <- pmin(1,x) x <- pmax(-1,x) asin(x)/b } #### pdMat class definitions, to enable tensor product smooths to be employed with gamm() #### Based on various Pinheiro and Bates pdMat classes. pdTens <- function(value = numeric(0), form = NULL, nam = NULL, data = sys.frame(sys.parent())) ## Constructor for the pdTens pdMat class: # the inverse of the scaled random effects covariance matrix for this class # is given by a weighted sum of the matrices in the list that is the "S" attribute of # a pdTens formula. The weights are the exponentials of the class parameters. # i.e. the inverse of the r.e. covariance matrix is # \sum_i \exp(\theta_i) S_i / \sigma^2 # The class name relates to the fact that these objects are used with tensor product smooths. { object <- numeric(0) class(object) <- c("pdTens", "pdMat") nlme::pdConstruct(object, value, form, nam, data) } ## Methods for local generics pdConstruct.pdTens <- function(object, value = numeric(0), form = formula(object), nam = nlme::Names(object), data = sys.frame(sys.parent()), ...) ## used to initialize pdTens objects. Note that the initialization matrices supplied ## are (factors of) trial random effects covariance matrices or their inverses. ## Which one is being passed seems to have to be derived from looking at its ## structure. ## Class tested rather thoroughly with nlme 3.1-52 on R 2.0.0 { val <- NextMethod() if (length(val) == 0) { # uninitiliazed object class(val) <- c("pdTens","pdMat") return(val) } if (is.matrix(val)) { # initialize from a positive definite S <- attr(form,"S") m <- length(S) ## codetools gets it wrong about `y' y <- as.numeric((crossprod(val))) # it's a factor that gets returned in val lform <- "y ~ as.numeric(S[[1]])" if (m>1) for (i in 2:m) lform <- paste(lform," + as.numeric(S[[",i,"]])",sep="") lform <- formula(paste(lform,"-1")) mod1 <- lm(lform) mod1.r2 <- 1-sum(residuals(mod1)^2)/sum((y-mean(y))^2) y <- as.numeric(solve(crossprod(val))) ## ignore codetools complaint about this mod2 <- lm(lform) mod2.r2 <- 1-sum(residuals(mod2)^2)/sum((y-mean(y))^2) ## `value' and `val' can relate to the cov matrix or its inverse: ## the following seems to be only way to tell which. #if (summary(mod2)$r.sq>summary(mod1)$r.sq) mod1<-mod2 if (mod2.r2 > mod1.r2) mod1 <- mod2 value <- coef(mod1) value[value <=0] <- .Machine$double.eps * mean(as.numeric(lapply(S,function(x) max(abs(x))))) value <- notLog2(value) attributes(value) <- attributes(val)[names(attributes(val)) != "dim"] class(value) <- c("pdTens", "pdMat") return(value) } m <- length(attr(form,"S")) if ((aux <- length(val)) > 0) { if (aux && (aux != m)) { stop(gettextf("An object of length %d does not match the required parameter size",aux)) } } class(val) <- c("pdTens","pdMat") val } pdFactor.pdTens <- function(object) ## The factor of the inverse of the scaled r.e. covariance matrix is returned here ## it should be returned as a vector. { sp <- as.vector(object) m <- length(sp) S <- attr(formula(object),"S") value <- S[[1]]*notExp2(sp[1]) if (m>1) for (i in 2:m) value <- value + notExp2(sp[i])*S[[i]] if (sum(is.na(value))>0) warning("NA's in pdTens factor") value <- (value+t(value))/2 c(t(mroot(value,rank=nrow(value)))) } pdMatrix.pdTens <- function(object, factor = FALSE) # the inverse of the scaled random effect covariance matrix is returned here, or # its factor if factor==TRUE. If A is the matrix being factored and B its # factor, it is required that A=B'B (not the mroot() default!) { if (!nlme::isInitialized(object)) { stop("Cannot extract the matrix from an uninitialized object") } sp <- as.vector(object) m <- length(sp) S <- attr(formula(object),"S") value <- S[[1]]*notExp2(sp[1]) if (m>1) for (i in 2:m) value <- value + notExp2(sp[i])*S[[i]] value <- (value + t(value))/2 # ensure symmetry if (sum(is.na(value))>0) warning("NA's in pdTens matrix") if (factor) { value <- t(mroot(value,rank=nrow(value))) } dimnames(value) <- attr(object, "Dimnames") value } #### Methods for standard generics coef.pdTens <- function(object, unconstrained = TRUE, ...) { if (unconstrained) NextMethod() else { val <- notExp2(as.vector(object)) names(val) <- paste("sp.",1:length(val), sep ="") val } } summary.pdTens <- function(object, structName = "Tensor product smooth term", ...) { NextMethod(object, structName, noCorrelation=TRUE) } # .... end of pdMat definitions for tensor product smooths ### pdIdnot: multiple of the identity matrix - the parameter is ### the notLog2 of the multiple. This is directly modified form ### Pinheiro and Bates pdIdent class. ####* Constructor pdIdnot <- ## Constructor for the pdIdnot class function(value = numeric(0), form = NULL, nam = NULL, data = sys.frame(sys.parent())) { #cat(" pdIdnot ") object <- numeric(0) class(object) <- c("pdIdnot", "pdMat") nlme::pdConstruct(object, value, form, nam, data) } ####* Methods for local generics corMatrix.pdIdnot <- function(object, ...) { if (!nlme::isInitialized(object)) { stop("Cannot extract the matrix from an uninitialized pdMat object") } if (is.null(Ncol <- attr(object, "ncol"))) { stop(paste("Cannot extract the matrix with uninitialized dimensions")) } val <- diag(Ncol) ## REMOVE sqrt() to revert ... attr(val, "stdDev") <- rep(sqrt(notExp2(as.vector(object))), Ncol) if (length(nm <- nlme::Names(object)) == 0) { len <- length(as.vector(object)) nm <- paste("V", 1:len, sep = "") dimnames(val) <- list(nm, nm) } names(attr(val, "stdDev")) <- nm val } pdConstruct.pdIdnot <- function(object, value = numeric(0), form = formula(object), nam = nlme::Names(object), data = sys.frame(sys.parent()), ...) { #cat(" pdConstruct.pdIdnot ") val <- NextMethod() if (length(val) == 0) { # uninitialized object if ((ncol <- length(nlme::Names(val))) > 0) { attr(val, "ncol") <- ncol } return(val) } if (is.matrix(val)) { # value <- notLog2(sqrt(mean(diag(crossprod(val))))) value <- notLog2(mean(diag(crossprod(val)))) ## REPLACE by above to revert attributes(value) <- attributes(val)[names(attributes(val)) != "dim"] attr(value, "ncol") <- dim(val)[2] class(value) <- c("pdIdnot", "pdMat") return(value) } if (length(val) > 1) { stop(paste("An object of length", length(val), "does not match the required parameter size")) } if (((aux <- length(nlme::Names(val))) == 0) && is.null(formula(val))) { stop(paste("Must give names when initializing pdIdnot from parameter.", "without a formula")) } else { attr(val, "ncol") <- aux } val } pdFactor.pdIdnot <- function(object) { ## UNCOMMENT first line, comment 2nd to revert # notExp2(as.vector(object)) * diag(attr(object, "ncol")) #cat(" pdFactor.pdIdnot ") sqrt(notExp2(as.vector(object))) * diag(attr(object, "ncol")) } pdMatrix.pdIdnot <- function(object, factor = FALSE) { #cat(" pdMatrix.pdIdnot ") if (!nlme::isInitialized(object)) { stop("Cannot extract the matrix from an uninitialized pdMat object") } if (is.null(Ncol <- attr(object, "ncol"))) { stop(paste("Cannot extract the matrix with uninitialized dimensions")) } value <- diag(Ncol) ## REPLACE by #1,#2,#3 to revert if (factor) { #1 value <- notExp2(as.vector(object)) * value #2 attr(value, "logDet") <- Ncol * log(notExp2(as.vector(object))) value <- sqrt(notExp2(as.vector(object))) * value attr(value, "logDet") <- Ncol * log(notExp2(as.vector(object)))/2 } else { #3 value <- notExp2(as.vector(object))^2 * value value <- notExp2(as.vector(object)) * value } dimnames(value) <- attr(object, "Dimnames") value } ####* Methods for standard generics coef.pdIdnot <- function(object, unconstrained = TRUE, ...) { #cat(" coef.pdIdnot ") if (unconstrained) NextMethod() else structure(notExp2(as.vector(object)), names = c(paste("sd(", deparse(formula(object)[[2]],backtick=TRUE),")",sep = ""))) } Dim.pdIdnot <- function(object, ...) { if (!is.null(val <- attr(object, "ncol"))) { c(val, val) } else { stop("Cannot extract the dimensions") } } logDet.pdIdnot <- function(object, ...) { ## REMOVE /2 to revert .... attr(object, "ncol") * log(notExp2(as.vector(object)))/2 } solve.pdIdnot <- function(a, b, ...) { if (!nlme::isInitialized(a)) { stop("Cannot extract the inverse from an uninitialized object") } atr <- attributes(a) a <- -coef(a, TRUE) attributes(a) <- atr a } summary.pdIdnot <- function(object, structName = "Multiple of an Identity", ...) { #cat(" summary.pdIdnot ") # summary.pdMat(object, structName, noCorrelation = TRUE) ## ... summary.pdMat is not exported in the nlme NAMESPACE file, so.... NextMethod(object, structName, noCorrelation=TRUE) } ### end of pdIdnot class smooth2random <- function(object,vnames,type=1) UseMethod("smooth2random") smooth2random.fs.interaction <- function(object,vnames,type=1) { ## conversion method for smooth-factor random interactions. ## For use with gamm4, this needs to generate a sparse version of ## each full model matrix, with smooth coefs re-ordered so that the ## penalties are not interwoven, but blocked (i.e. this ordering is ## as for gamm case). if (object$fixed) return(list(fixed=TRUE,Xf=object$X)) ##if (type == 2) require(Matrix) colx <- ncol(object$X) diagU <- rep(1,colx) ind <- 1:colx flev <- levels(object$fac) n.lev <- length(flev) if (type==2) { ## index which params in fit parameterization are penalized by each penalty. ## e.g. pen.ind==1 is TRUE for each param penalized by first penalty and ## FALSE otherwise... pen.ind <- rep(ind*0,n.lev) } else pen.ind <- NULL random <- list() k <- 1 rinc <- rind <- rep(0,0) for (i in 1:length(object$S)) { ## work through penalties indi <- ind[diag(object$S[[i]])!=0] ## index of penalized cols X <- object$X[,indi,drop=FALSE] ## model matrix for this component D <- diag(object$S[[i]])[indi] diagU[indi] <- 1/sqrt(D) ## transform that reduces penalty to identity X <- X%*%diag(diagU[indi],ncol=length(indi)) term.name <- new.name("Xr",vnames) vnames <- c(vnames,term.name) rind <- c(rind,k:(k+ncol(X)-1)) rinc <- c(rinc,rep(ncol(X),ncol(X))) k <- k + n.lev * ncol(X) if (type==1) { ## gamm form for use with lme ## env set to avoid 'save' saving whole environment to file... form <- as.formula(paste("~",term.name,"-1",sep=""),env=.GlobalEnv) random[[i]] <- pdIdnot(form) names(random)[i] <- object$fterm ## supplied factor name attr(random[[i]],"group") <- object$fac ## factor supplied as part of term attr(random[[i]],"Xr.name") <- term.name attr(random[[i]],"Xr") <- X # rind <- c(rind,k:(k+ncol(X)-1)) # rinc <- c(rinc,rep(ncol(X),ncol(X))) # k <- k + n.lev * ncol(X) } else { ## gamm4 form --- whole sparse matrices Xr <- as(matrix(0,nrow(X),0),"dgCMatrix") ii <- 0 for (j in 1:n.lev) { ## assemble full sparse model matrix Xr <- cbind2(Xr,as(X*as.numeric(object$fac==flev[j]),"dgCMatrix")) pen.ind[indi+ii] <- i;ii <- ii + colx } # rind <- c(rind,k:(k+ncol(Xr)-1)) # rinc <- c(rinc,rep(ncol(Xr),ncol(Xr))) random[[i]] <- Xr names(random)[i] <- term.name attr(random[[i]],"s.label") <- object$label } } if (type==2) { ## expand the rind (rinc not needed) ind <- 1:length(rind) ni <- length(ind) rind <- rep(rind,n.lev) if (n.lev>1) for (k in 2:n.lev) { rind[ind+ni] <- rind[ind]+rinc ind <- ind + ni } D <- rep(diagU,n.lev) } else D <- diagU ## b_original = D*b_fit Xf <- matrix(0,nrow(object$X),0) list(rand=random,trans.D=D,Xf=Xf,fixed=FALSE,rind=rind,rinc=rinc, pen.ind=pen.ind) ## pen.ind==i is TRUE for coefs penalized by ith penalty } ## smooth2random.fs.interaction smooth2random.t2.smooth <- function(object,vnames,type=1) { ## takes a smooth object and turns it into a form suitable for estimation as a random effect ## vnames is a list of names to avoid when assigning variable names. ## type==1 indicates an lme random effect. ## Returns 1. a list of random effects, including grouping factors, and ## a fixed effects matrix. Grouping factors, model matrix and ## model matrix name attached as attributes, to each element. ## 2. rind: and index vector such that if br is the vector of ## random coefficients for the term, br[rind] is the coefs in ## order for this term. rinc - dummy here. ## 3. A matrix, trans.D, that transforms coefs, in order [rand1, rand2,... fix] ## back to original parameterization. If null, then not needed. ## 4. A matrix Xf for the fixed effects, if any. ## 5. fixed TRUE/FALSE if its fixed or not. If fixed the other stuff is ## not returned. ## This version deals only with t2 smooths conditioned on a whole ## dataset dummy factor. ## object must contain model matrix for smooth. if (object$fixed) return(list(fixed=TRUE,Xf=object$X)) fixed <- rep(TRUE,ncol(object$X)) random <- list() diagU <- rep(1,ncol(object$X)) ind <- 1:ncol(object$X) pen.ind <- ind*0 n.para <- 0 for (i in 1:length(object$S)) { ## work through penalties indi <- ind[diag(object$S[[i]])!=0] ## index of penalized cols pen.ind[indi] <- i X <- object$X[,indi,drop=FALSE] ## model matrix for this component D <- diag(object$S[[i]])[indi] diagU[indi] <- 1/sqrt(D) ## transform that reduces penalty to identity X <- X%*%diag(diagU[indi]) fixed[indi] <- FALSE term.name <- new.name("Xr",vnames) group.name <- new.name("g",vnames) vnames <- c(vnames,term.name,group.name) if (type==1) { ## gamm form for lme ## env set to avoid 'save' saving whole environment to file... form <- as.formula(paste("~",term.name,"-1",sep=""),env=.GlobalEnv) random[[i]] <- pdIdnot(form) names(random)[i] <- group.name attr(random[[i]],"group") <- factor(rep(1,nrow(X))) attr(random[[i]],"Xr.name") <- term.name attr(random[[i]],"Xr") <- X } else { ## lmer form as used by gamm4 random[[i]] <- X names(random)[i] <- term.name attr(random[[i]],"s.label") <- object$label } n.para <- n.para + ncol(X) } if (sum(fixed)) { ## then there are fixed effects! Xf <- object$X[,fixed,drop=FALSE] } else Xf <- matrix(0,nrow(object$X),0) list(rand=random,trans.D=diagU,Xf=Xf,fixed=FALSE, rind=1:n.para,rinc=rep(n.para,n.para),pen.ind=pen.ind) } ## smooth2random.t2.smooth smooth2random.mgcv.smooth <- function(object,vnames,type=1) { ## takes a smooth object and turns it into a form suitable for estimation as a random effect ## vnames is a list of names to avoid when assigning variable names. ## type==1 indicates an lme random effect. ## Returns 1. a list of random effects, including grouping factors, and ## a fixed effects matrix. Grouping factors, model matrix and ## model matrix name attached as attributes, to each element. ## 2. rind: an index vector such that if br is the vector of ## random coefficients for the term, br[rind] is the coefs in ## order for this term. rinc - dummy here. ## 3. A matrix, U, + vec D that transforms coefs, in order [rand1, rand2,... fix] ## back to original parameterization. b_origonal = U%*%(D*b_fit) ## 4. A matrix Xf for the fixed effects, if any. ## 5. fixed TRUE/FALSE if its fixed or not. If fixed the other stuff is ## not returned. ## This version deals only with single penalty smooths conditioned on a whole ## dataset dummy factor. ## object must contain model matrix for smooth. if (object$fixed) return(list(fixed=TRUE,Xf=object$X)) if (length(object$S)>1) stop("Can not convert this smooth class to a random effect") ## reparameterize so that unpenalized basis is separated out and at end... ev <- eigen(object$S[[1]],symmetric=TRUE) null.rank <- object$df - object$rank p.rank <- object$rank if (p.rank>ncol(object$X)) p.rank <- ncol(object$X) U <- ev$vectors D <- c(ev$values[1:p.rank],rep(1,null.rank)) D <- 1/sqrt(D) UD <- t(t(U)*D) ## U%*%[b,beta] returns coefs in original parameterization X <- object$X%*%UD if (p.rank1) for (l in 2:length(object$S)) { sum.S <- sum.S + object$S[[l]]/mean(abs(object$S[[l]])) #dfl <- ncol(object$margin[[l]]$X) ## actual df of term (`df' may not be set by constructor) #null.rank <- null.rank * (dfl-object$margin[[l]]$rank) #bs.dim <- bs.dim * dfl } null.rank <- object$null.space.dim #null.rank <- null.rank - bs.dim + object$df ##sum.S <- (sum.S+t(sum.S))/2 # ensure symmetry ev <- eigen(sum.S,symmetric=TRUE) p.rank <- ncol(object$X) - null.rank if (p.rank>ncol(object$X)) p.rank <- ncol(object$X) U <- ev$vectors D <- c(ev$values[1:p.rank],rep(1,null.rank)) if (sum(D<=0)) stop( "Tensor product penalty rank appears to be too low: please email Simon.Wood@R-project.org with details.") ## D <- 1/sqrt(D) U <- U ## maps coefs back to untransformed versions X <- object$X%*%U if (p.rank0) ind <- 1:G$nsdf else ind <- rep(0,0) X <- G$X[,ind,drop=FALSE] # accumulate fixed effects into here xlab <- rep("",0) ## first have to create a processing order, so that any smooths conditional on ## multi-level factors are processed last, and hence end up at the end of the ## random list (right is nested in left in this list!) if (G$m>0) { pord <- 1:G$m done <- rep(FALSE,length(pord)) k <- 0 f.name <- NULL for (i in 1:G$m) if (is.null(G$smooth[[i]]$fac)) { k <- k + 1 pord[k] <- i done[i] <- TRUE } else { if (is.null(f.name)) f.name <- G$smooth[[i]]$fterm else if (f.name!=G$smooth[[i]]$fterm) stop("only one level of smooth nesting is supported by gamm") if (!is.null(attr(G$smooth[[i]],"del.index"))) stop("side conditions not allowed for nested smooths") } if (k < G$m) pord[(k+1):G$m] <- (1:G$m)[!done] ## .... ordered so that nested smooths are last } if (G$m) for (i in 1:G$m) { ## work through the smooths sm <- G$smooth[[pord[i]]] sm$X <- G$X[,sm$first.para:sm$last.para,drop=FALSE] rasm <- smooth2random(sm,names(data)) ## convert smooth to random effect and fixed effects sm$fixed <- rasm$fixed if (!is.null(sm$fac)) { flev <- levels(sm$fac) ## grouping factor for smooth ##n.lev <- length(flev) } ##else n.lev <- 1 ## now append constructed variables to model frame and random effects to main list n.para <- 0 ## count random coefficients ## rinc <- rind <- rep(0,0) if (!sm$fixed) { # kk <- 1; for (k in 1:length(rasm$rand)) { group.name <- names(rasm$rand)[k] group <- attr(rasm$rand[[k]],"group") Xr.name <- attr(rasm$rand[[k]],"Xr.name") Xr <- attr(rasm$rand[[k]],"Xr") attr(rasm$rand[[k]],"group") <- attr(rasm$rand[[k]],"Xr") <- attr(rasm$rand[[k]],"Xr.name") <- NULL # rind <- c(rind,kk:(kk+ncol(Xr)-1)) # rinc <- c(rinc,rep(ncol(Xr),ncol(Xr))) ## increment for rind # kk <- kk + n.lev * ncol(Xr) n.para <- n.para + ncol(Xr) data[[group.name]] <- group data[[Xr.name]] <- Xr } random <- c(random,rasm$rand) sm$trans.U <- rasm$trans.U ## matrix mapping fit coefs back to original sm$trans.D <- rasm$trans.D ## so b_original = U%*%(D*b_fit) } if (ncol(rasm$Xf)) { ## lme requires names Xfnames <- rep("",ncol(rasm$Xf)) k <- length(xlab)+1 for (j in 1:ncol(rasm$Xf)) { xlab[k] <- Xfnames[j] <- new.name(paste(sm$label,"Fx",j,sep=""),xlab) k <- k + 1 } colnames(rasm$Xf) <- Xfnames } X <- cbind(X,rasm$Xf) # add fixed model matrix to overall fixed X ## update the counters indicating which elements of the whole model ## fixed and random coef vectors contain the coefs for this smooth. ## note convention that smooth coefs are [random, fixed] sm$first.f.para <- first.f.para first.f.para <- first.f.para + ncol(rasm$Xf) sm$last.f.para <- first.f.para - 1 ## note less than sm$first.f.para => no fixed sm$rind <- rasm$rind - 1 + first.r.para sm$rinc <- rasm$rinc # sm$first.r.para <- first.r.para first.r.para <- first.r.para+n.para # sm$last.r.para <- first.r.para-1 sm$n.para <- n.para ## convention is that random coefs for grouped smooths will be ## packed [coefs for level 1, coefs for level 2, ...] ## n.para is number of random paras at each level. ## so coefs for ith level will be indexed by ## rind + (i-1)*n.para ## first.r.para:last.r.para + (i-1)*n.para if (!is.null(sm$fac)) { ## there is a grouping factor for this smooth ## have to up this first.r.para to allow a copy of coefs for each level of fac... first.r.para <- first.r.para + n.para*(length(flev)-1) } sm$X <- NULL ## delete model matrix if (G$m>0) G$smooth[[pord[i]]] <- sm ## replace smooth object with extended version } G$random <- random G$X <- X ## fixed effects model matrix G$data <- data if (G$m>0) G$pord <- pord ## gamm needs to run through smooths in same order as here G } ## end of gamm.setup varWeights.dfo <- function(b,data) ## get reciprocal *standard deviations* implied by the estimated variance ## structure of an lme object, b, in *original data frame order*. { w <- nlme::varWeights(b$modelStruct$varStruct) # w is not in data.frame order - it's in inner grouping level order group.name <- names(b$groups) # b$groups[[i]] doesn't always retain factor ordering ind <- NULL order.txt <- paste("ind<-order(data[[\"",group.name[1],"\"]]",sep="") if (length(b$groups)>1) for (i in 2:length(b$groups)) order.txt <- paste(order.txt,",data[[\"",group.name[i],"\"]]",sep="") order.txt <- paste(order.txt,")") eval(parse(text=order.txt)) w[ind] <- w # into data frame order w } extract.lme.cov2<-function(b,data,start.level=1) # function to extract the response data covariance matrix from an lme fitted # model object b, fitted to the data in data. "inner" == "finest" grouping # start.level is the r.e. grouping level at which to start the construction, # levels outer to this will not be included in the calculation - this is useful # for gamm calculations # # This version aims to be efficient, by not forming the complete matrix if it # is diagonal or block diagonal. To this end the matrix is returned in a form # that relates to the data re-ordered according to the coarsest applicable # grouping factor. ind[i] gives the row in the original data frame # corresponding to the ith row/column of V. # V is either returned as an array, if it's diagonal, a matrix if it is # a full matrix or a list of matrices if it is block diagonal. { if (!inherits(b,"lme")) stop("object does not appear to be of class lme") grps <- nlme::getGroups(b) # labels of the innermost groupings - in data frame order n <- length(grps) # number of data n.levels <- length(b$groups) # number of levels of grouping (random effects only) # if (n.levels 0 iff it determines the coarsest grouping ## level if > start.level. if (n.levels1) for (i in 2:length(vnames)) { lab <- paste(lab,"/",eval(parse(text=vnames[i]),envir=b$data),sep="") } grps <- factor(lab) } if (n.levels >= start.level||n.corlevels >= start.level) { if (n.levels >= start.level) Cgrps <- nlme::getGroups(b,level=start.level) # outer grouping labels (dforder) else Cgrps <- grps #Cgrps <- nlme::getGroups(b$modelStruct$corStruct) # ditto Cind <- sort(as.numeric(Cgrps),index.return=TRUE)$ix # Cind[i] is where row i of sorted Cgrps is in original data frame order rCind <- 1:n; rCind[Cind] <- 1:n # rCind[i] is location of ith original datum in the coarse ordering ## CFgrps <- grps[Cind] # fine group levels in coarse group order (unused!!) Clevel <- levels(Cgrps) # levels of coarse grouping factor n.cg <- length(Clevel) # number of outer groups size.cg <- array(0,n.cg) for (i in 1:n.cg) size.cg[i] <- sum(Cgrps==Clevel[i]) # size of each coarse group ## Cgrps[Cind] is sorted by coarsest grouping factor level ## so e.g. y[Cind] would be data in c.g.f. order } else {n.cg <- 1;Cind<-1:n} if (is.null(b$modelStruct$varStruct)) w<-rep(b$sigma,n) ### else { w <- 1/nlme::varWeights(b$modelStruct$varStruct) # w is not in data.frame order - it's in inner grouping level order group.name<-names(b$groups) # b$groups[[i]] doesn't always retain factor ordering order.txt <- paste("ind<-order(data[[\"",group.name[1],"\"]]",sep="") if (length(b$groups)>1) for (i in 2:length(b$groups)) order.txt <- paste(order.txt,",data[[\"",group.name[i],"\"]]",sep="") order.txt <- paste(order.txt,")") eval(parse(text=order.txt)) w[ind] <- w # into data frame order w <- w*b$sigma } w <- w[Cind] # re-order in coarse group order if (is.null(b$modelStruct$corStruct)) V<-array(1,n) else { c.m<-nlme::corMatrix(b$modelStruct$corStruct) # correlation matrices for each innermost group if (!is.list(c.m)) { # copy and re-order into coarse group order V <- c.m;V[Cind,] -> V;V[,Cind] -> V } else { V<-list() # V[[i]] is cor matrix for ith coarse group ind <- list() # ind[[i]] is order index for V[[i]] for (i in 1:n.cg) { V[[i]] <- matrix(0,size.cg[i],size.cg[i]) ind[[i]] <- 1:size.cg[i] } # Voff[i] is where, in coarse order data, first element of V[[i]] # relates to ... Voff <- cumsum(c(1,size.cg)) gr.name <- names(c.m) # the names of the innermost groups n.g<-length(c.m) # number of innermost groups j0<-rep(1,n.cg) # place holders in V[[i]]'s ii <- 1:n for (i in 1:n.g) # work through innermost groups { # first identify coarse grouping Clev <- unique(Cgrps[grps==gr.name[i]]) # level for coarse grouping factor if (length(Clev)>1) stop("inner groupings not nested in outer!!") k <- (1:n.cg)[Clevel==Clev] # index of coarse group - i.e. update V[[k]] # now need to get c.m into right place within V[[k]] j1<-j0[k]+nrow(c.m[[i]])-1 V[[k]][j0[k]:j1,j0[k]:j1]<-c.m[[i]] ind1 <- ii[grps==gr.name[i]] # ind1 is the rows of original data.frame to which c.m[[i]] applies # assuming that data frame order is preserved at the inner grouping ind2 <- rCind[ind1] # ind2 contains the rows of the coarse ordering to which c.m[[i]] applies ind[[k]][j0[k]:j1] <- ind2 - Voff[k] + 1 # ind[k] accumulates rows within coarse group k to which V[[k]] applies j0[k]<-j1+1 } for (k in 1:n.cg) { # pasting correlations into right place in each matrix V[[k]][ind[[k]],]<-V[[k]];V[[k]][,ind[[k]]]<-V[[k]] } } } # now form diag(w)%*%V%*%diag(w), depending on class of V if (is.list(V)) # it's a block diagonal structure { for (i in 1:n.cg) { wi <- w[Voff[i]:(Voff[i]+size.cg[i]-1)] V[[i]] <- as.vector(wi)*t(as.vector(wi)*V[[i]]) } } else if (is.matrix(V)) { V <- as.vector(w)*t(as.vector(w)*V) } else # it's a diagonal matrix { V <- w^2*V } # ... covariance matrix according to fitted correlation structure in coarse # group order ## Now work on the random effects ..... X <- list() grp.dims <- b$dims$ncol # number of Zt columns for each grouping level (inner levels first) # inner levels are first in Zt Zt <- model.matrix(b$modelStruct$reStruct,data) # a sort of proto - Z matrix # b$groups and cov (defined below have the inner levels last) cov <- as.matrix(b$modelStruct$reStruct) # list of estimated covariance matrices (inner level last) i.col<-1 Z <- matrix(0,n,0) # Z matrix if (start.level<=n.levels) { for (i in 1:(n.levels-start.level+1)) # work through the r.e. groupings inner to outer { # get matrix with columns that are indicator variables for ith set of groups... # groups has outer levels first if(length(levels(b$groups[[n.levels-i+1]]))==1) { ## model.matrix needs >1 level X[[1]] <- matrix(rep(1,nrow(b$groups))) } else { X[[1]] <- model.matrix(~b$groups[[n.levels-i+1]]-1, contrasts.arg=c("contr.treatment","contr.treatment")) } # Get `model matrix' columns relevant to current grouping level... X[[2]] <- Zt[,i.col:(i.col+grp.dims[i]-1),drop=FALSE] i.col <- i.col+grp.dims[i] # tensor product the X[[1]] and X[[2]] rows... Z <- cbind(Z,tensor.prod.model.matrix(X)) } # so Z assembled from inner to outer levels # Now construct overall ranef covariance matrix Vr <- matrix(0,ncol(Z),ncol(Z)) start <- 1 for (i in 1:(n.levels-start.level+1)) { k <- n.levels-i+1 for (j in 1:b$dims$ngrps[i]) { stop <- start+ncol(cov[[k]])-1 Vr[start:stop,start:stop]<-cov[[k]] start <- stop+1 } } Vr <- Vr*b$sigma^2 ## Now re-order Z into coarse group order Z <- Z[Cind,] ## Now Z %*% Vr %*% t(Z) is block diagonal: if Z' = [Z1':Z2':Z3': ... ] ## where Zi contains th rows of Z for the ith level of the coarsest ## grouping factor, then the ith block of (Z Vr Z') is (Zi Vr Zi') if (n.cg == 1) { if (is.matrix(V)) { V <- V+Z%*%Vr%*%t(Z) } else V <- diag(V) + Z%*%Vr%*%t(Z) } else { # V has a block - diagonal structure j0 <- 1 Vz <- list() for (i in 1:n.cg) { j1 <- size.cg[i] + j0 -1 Zi <- Z[j0:j1,,drop=FALSE] Vz[[i]] <- Zi %*% Vr %*% t(Zi) j0 <- j1+1 } if (is.list(V)) { for (i in 1:n.cg) V[[i]] <- V[[i]]+Vz[[i]] } else { j0 <-1 for (i in 1:n.cg) { kk <- size.cg[i] j1 <- kk + j0 -1 Vz[[i]] <- Vz[[i]] + diag(x=V[j0:j1],nrow=kk,ncol=kk) j0 <- j1+1 } V <- Vz } } } list(V=V,ind=Cind) } extract.lme.cov<-function(b,data,start.level=1) # function to extract the response data covariance matrix from an lme fitted # model object b, fitted to the data in data. "inner" == "finest" grouping # start.level is the r.e. grouping level at which to start the construction, # levels outer to this will not be included in the calculation - this is useful # for gamm calculations { if (!inherits(b,"lme")) stop("object does not appear to be of class lme") grps<-nlme::getGroups(b) # labels of the innermost groupings - in data frame order n<-length(grps) # number of data if (is.null(b$modelStruct$varStruct)) w<-rep(b$sigma,n) ### else { w<-1/nlme::varWeights(b$modelStruct$varStruct) # w is not in data.frame order - it's in inner grouping level order group.name<-names(b$groups) # b$groups[[i]] doesn't always retain factor ordering order.txt <- paste("ind<-order(data[[\"",group.name[1],"\"]]",sep="") if (length(b$groups)>1) for (i in 2:length(b$groups)) order.txt <- paste(order.txt,",data[[\"",group.name[i],"\"]]",sep="") order.txt <- paste(order.txt,")") eval(parse(text=order.txt)) w[ind] <- w # into data frame order w<-w*b$sigma } if (is.null(b$modelStruct$corStruct)) V<-diag(n) #*b$sigma^2 else { c.m<-nlme::corMatrix(b$modelStruct$corStruct) # correlation matrices for each group if (!is.list(c.m)) V<-c.m else { V<-matrix(0,n,n) # data cor matrix gr.name <- names(c.m) # the names of the groups n.g<-length(c.m) # number of innermost groups j0<-1 ind<-ii<-1:n for (i in 1:n.g) { j1<-j0+nrow(c.m[[i]])-1 V[j0:j1,j0:j1]<-c.m[[i]] ind[j0:j1]<-ii[grps==gr.name[i]] j0<-j1+1 } V[ind,]<-V;V[,ind]<-V # pasting correlations into right place in overall matrix # V<-V*b$sigma^2 } } V <- as.vector(w)*t(as.vector(w)*V) # diag(w)%*%V%*%diag(w) # ... covariance matrix according to fitted correlation structure X<-list() grp.dims<-b$dims$ncol # number of Zt columns for each grouping level (inner levels first) # inner levels are first in Zt Zt<-model.matrix(b$modelStruct$reStruct,data) # a sort of proto - Z matrix # b$groups and cov (defined below have the inner levels last) cov<-as.matrix(b$modelStruct$reStruct) # list of estimated covariance matrices (inner level last) i.col<-1 n.levels<-length(b$groups) Z<-matrix(0,n,0) # Z matrix if (start.level<=n.levels) { for (i in 1:(n.levels-start.level+1)) # work through the r.e. groupings inner to outer { # get matrix with columns that are indicator variables for ith set of groups... # groups has outer levels first if(length(levels(b$groups[[n.levels-i+1]]))==1) { ## model.matrix needs >1 level X[[1]] <- matrix(rep(1,nrow(b$groups))) } else { X[[1]] <- model.matrix(~b$groups[[n.levels-i+1]]-1, contrasts.arg=c("contr.treatment","contr.treatment")) } # Get `model matrix' columns relevant to current grouping level... X[[2]] <- Zt[,i.col:(i.col+grp.dims[i]-1),drop=FALSE] i.col <- i.col+grp.dims[i] # tensor product the X[[1]] and X[[2]] rows... Z <- cbind(Z,tensor.prod.model.matrix(X)) } # so Z assembled from inner to outer levels # Now construct overall ranef covariance matrix Vr <- matrix(0,ncol(Z),ncol(Z)) start <- 1 for (i in 1:(n.levels-start.level+1)) { k <- n.levels-i+1 for (j in 1:b$dims$ngrps[i]) { stop <- start+ncol(cov[[k]])-1 Vr[start:stop,start:stop]<-cov[[k]] start <- stop+1 } } Vr <- Vr*b$sigma^2 V <- V+Z%*%Vr%*%t(Z) } V } formXtViX <- function(V,X) ## forms X'V^{-1}X as efficiently as possible given the structure of ## V (diagonal, block-diagonal, full) ## Actually returns R where R'R = X'V^{-1}X { X <- X[V$ind,,drop=FALSE] # have to re-order X according to V ordering if (is.list(V$V)) { ### block diagonal case Z <- X j0 <- 1 for (i in 1:length(V$V)) { Cv <- chol(V$V[[i]]) j1 <- j0+nrow(V$V[[i]])-1 Z[j0:j1,] <- backsolve(Cv,X[j0:j1,,drop=FALSE],transpose=TRUE) j0 <- j1 + 1 } #res <- t(Z)%*%Z } else if (is.matrix(V$V)) { ### full matrix case Cv <- chol(V$V) Z <- backsolve(Cv,X,transpose=TRUE) #res <- t(Z)%*%Z } else { ### diagonal matrix case Z <- X/sqrt(as.numeric(V$V)) #res <- t(X)%*%(X/as.numeric(V$V)) } qrz <- qr(Z,LAPACK=TRUE) R <- qr.R(qrz);R[,qrz$pivot] <- R colnames(R) <- colnames(X) #res <- crossprod(R) #res R } new.name <- function(proposed,old.names) # finds a name based on proposed, that is not in old.names # if the proposed name is in old.names then ".xx" is added to it # where xx is a number chosen to ensure the a unique name { prop <- proposed k <- 0 while (sum(old.names==prop)) { prop<-paste(proposed,".",k,sep="") k <- k + 1 } prop } gammPQL <- function (fixed, random, family, data, correlation, weights, control, niter = 30, verbose = TRUE, ...) ## service routine for `gamm' to do PQL fitting. Based on glmmPQL ## from the MASS library (Venables & Ripley). In particular, for back ## compatibility the numerical results should be identical with gamm ## fits by glmmPQL calls. Because `gamm' already does some of the ## preliminary stuff that glmmPQL does, gammPQL can be simpler. It also ## deals with the possibility of the original data frame containing ## variables called `zz' `wts' or `invwt' { off <- model.offset(data) if (is.null(off)) off <- 0 wts <- weights if (is.null(wts)) wts <- rep(1, nrow(data)) wts.name <- new.name("wts",names(data)) ## avoid overwriting what's already in `data' data[[wts.name]] <- wts fit0 <- NULL ## keep checking tools happy ## initial fit (might be better replaced with `gam' call) eval(parse(text=paste("fit0 <- glm(formula = fixed, family = family, data = data,", "weights =",wts.name,",...)"))) w <- fit0$prior.weights eta <- fit0$linear.predictors zz <- eta + fit0$residuals - off wz <- fit0$weights fam <- family ## find non clashing name for pseudodata and insert in formula zz.name <- new.name("zz",names(data)) eval(parse(text=paste("fixed[[2]] <- quote(",zz.name,")"))) data[[zz.name]] <- zz ## pseudodata to `data' ## find non-clashing name for inverse weights, and make ## varFixed formula using it... invwt.name <- new.name("invwt",names(data)) data[[invwt.name]] <- 1/wz w.formula <- as.formula(paste("~",invwt.name,sep="")) converged <- FALSE if (family$family %in% c("poisson","binomial")) { control$sigma <- 1 ## set scale parameter to 1 control$apVar <- FALSE ## not available } for (i in 1:niter) { if (verbose) message(gettextf("iteration %d", i)) fit <- lme(fixed=fixed,random=random,data=data,correlation=correlation, control=control,weights=varFixed(w.formula),method="ML",...) etaold <- eta eta <- fitted(fit) + off if (sum((eta - etaold)^2) < 1e-06 * sum(eta^2)) { converged <- TRUE break } mu <- fam$linkinv(eta) mu.eta.val <- fam$mu.eta(eta) ## get pseudodata and insert in `data' data[[zz.name]] <- eta + (fit0$y - mu)/mu.eta.val - off wz <- w * mu.eta.val^2/fam$variance(mu) data[[invwt.name]] <- 1/wz } ## end i in 1:niter if (!converged) warning("gamm not converged, try increasing niterPQL") fit$y <- fit0$y fit$w <- w ## prior weights fit } gamm <- function(formula,random=NULL,correlation=NULL,family=gaussian(),data=list(),weights=NULL, subset=NULL,na.action,knots=NULL,control=list(niterEM=0,optimMethod="L-BFGS-B"), niterPQL=20,verbosePQL=TRUE,method="ML",drop.unused.levels=TRUE,...) # Routine to fit a GAMM to some data. Fixed and smooth terms are defined in the formula, but the wiggly # parts of the smooth terms are treated as random effects. The onesided formula random defines additional # random terms. correlation describes the correlation structure. This routine is basically an interface # between the basis constructors provided in mgcv and the gammPQL routine used to estimate the model. { if (inherits(family,"extended.family")) warning("family are not designed for use with gamm!") ## lmeControl turns sigma=NULL into sigma=0, but if you supply sigma=0 rejects it, ## which will break the standard handling of the control list. Following line fixes. ## but actually Martin M has now fixed lmeControl... ##if (!is.null(control$sigma)&&control$sigma==0) control$sigma <- NULL control <- do.call("lmeControl",control) # check that random is a named list if (!is.null(random)) { if (is.list(random)) { r.names<-names(random) if (is.null(r.names)) stop("random argument must be a *named* list.") else if (sum(r.names=="")) stop("all elements of random list must be named") } else stop("gamm() can only handle random effects defined as named lists") random.vars<-c(unlist(lapply(random, function(x) all.vars(formula(x)))),r.names) } else random.vars<-NULL if (!is.null(correlation)) { cor.for<-attr(correlation,"formula") if (!is.null(cor.for)) cor.vars<-all.vars(cor.for) } else cor.vars<-NULL ## now establish whether weights is varFunc or not... wisvf <- try(inherits(weights,"varFunc"),silent=TRUE) if (inherits(wisvf,"try-error")) wisvf <- FALSE if (wisvf) { ## collect its variables if (inherits(weights,"varComb")) { ## actually a list of varFuncs vf.vars <- rep("",0) for (i in 1:length(weights)) { vf.vars <- c(vf.vars,all.vars(attr(weights[[i]],"formula"))) } vf.vars <- unique(vf.vars) } else { ## single varFunc vf.for<-attr(weights,"formula") if (!is.null(vf.for)) vf.vars<-all.vars(vf.for) } } else vf.vars <- NULL # create model frame..... gp <- interpret.gam(formula) # interpret the formula ##cl<-match.call() # call needed in gamm object for update to work mf <- match.call(expand.dots=FALSE) mf$formula <- gp$fake.formula if (wisvf) { mf$correlation <- mf$random <- mf$family <- mf$control <- mf$scale <- mf$knots <- mf$sp <- mf$weights <- mf$min.sp <- mf$H <- mf$gamma <- mf$fit <- mf$niterPQL <- mf$verbosePQL <- mf$G <- mf$method <- mf$... <- NULL } else { mf$correlation <- mf$random <- mf$family <- mf$control <- mf$scale <- mf$knots <- mf$sp <- mf$min.sp <- mf$H <- mf$gamma <- mf$fit <- mf$niterPQL <- mf$verbosePQL <- mf$G <- mf$method <- mf$... <- NULL } mf$drop.unused.levels <- drop.unused.levels mf[[1]] <- quote(stats::model.frame) ## as.name("model.frame") pmf <- mf gmf <- eval(mf, parent.frame()) # the model frame now contains all the data, for the gam part only gam.terms <- attr(gmf,"terms") # terms object for `gam' part of fit -- need this for prediction to work properly if (!wisvf) weights <- gmf[["(weights)"]] allvars <- c(cor.vars,random.vars,vf.vars) if (length(allvars)) { mf$formula <- as.formula(paste(paste(deparse(gp$fake.formula,backtick=TRUE),collapse=""), "+",paste(allvars,collapse="+"))) mf <- eval(mf, parent.frame()) # the model frame now contains *all* the data } else mf <- gmf rm(gmf) if (nrow(mf)<2) stop("Not enough (non-NA) data to do anything meaningful") ##Terms <- attr(mf,"terms") ## summarize the *raw* input variables ## note can't use get_all_vars here -- buggy with matrices vars <- all.vars1(gp$fake.formula[-2]) ## drop response here inp <- parse(text = paste("list(", paste(vars, collapse = ","),")")) dl <- eval(inp, data, parent.frame()) names(dl) <- vars ## list of all variables needed var.summary <- variable.summary(gp$pf,dl,nrow(mf)) ## summarize the input data rm(dl) ## save space pmf$formula <- gp$pf pmf <- eval(pmf, parent.frame()) # pmf contains all data for parametric part pTerms <- attr(pmf,"terms") if (is.character(family)) family<-eval(parse(text=family)) if (is.function(family)) family <- family() if (is.null(family$family)) stop("family not recognized") # now call gamm.setup G <- gamm.setup(gp,pterms=pTerms, data=mf,knots=knots,parametric.only=FALSE,absorb.cons=TRUE) #G$pterms <- pTerms G$var.summary <- var.summary mf <- G$data n.sr <- length(G$random) # number of random smooths (i.e. s(...,fx=FALSE,...) terms) if (is.null(random)&&n.sr==0) stop("gamm models must have at least 1 smooth with unknown smoothing parameter or at least one other random effect") offset.name <- attr(mf,"names")[attr(attr(mf,"terms"),"offset")] yname <- new.name("y",names(mf)) eval(parse(text=paste("mf$",yname,"<-G$y",sep=""))) Xname <- new.name("X",names(mf)) eval(parse(text=paste("mf$",Xname,"<-G$X",sep=""))) fixed.formula <- paste(yname,"~",Xname,"-1") if (length(offset.name)) { fixed.formula <- paste(fixed.formula,"+",offset.name) } fixed.formula <- as.formula(fixed.formula) ## Add any explicit random effects to the smooth induced r.e.s rand <- G$random if (!is.null(random)) { r.m <- length(random) r.names <- c(names(rand),names(random)) for (i in 1:r.m) rand[[n.sr+i]]<-random[[i]] names(rand) <- r.names } ## need to modify the correlation structure formula, in order that any ## grouping factors for correlation get nested within at least the ## constructed dummy grouping factors. if (length(formula(correlation))) # then modify the correlation formula { # first get the existing grouping structure .... corGroup <- paste(names(rand),collapse="/") groupForm<-nlme::getGroupsFormula(correlation) if (!is.null(groupForm)) { groupFormNames <- all.vars(groupForm) exind <- groupFormNames %in% names(rand) groupFormNames <- groupFormNames[!exind] ## dumping duplicates if (length(groupFormNames)) corGroup <- paste(corGroup,paste(groupFormNames,collapse="/"),sep="/") } # now make a new formula for the correlation structure including these groups corForm <- as.formula(paste(deparse(nlme::getCovariateFormula(correlation)),"|",corGroup)) attr(correlation,"formula") <- corForm } ### Actually do fitting .... ret <- list() if (family$family=="gaussian"&&family$link=="identity"&& length(offset.name)==0) lme.used <- TRUE else lme.used <- FALSE if (lme.used&&!is.null(weights)&&!wisvf) lme.used <- FALSE if (lme.used) { ## following construction is a work-around for problem in nlme 3-1.52 eval(parse(text=paste("ret$lme<-lme(",deparse(fixed.formula), ",random=rand,data=strip.offset(mf),correlation=correlation,", "control=control,weights=weights,method=method)" ,sep="" ))) ##ret$lme<-lme(fixed.formula,random=rand,data=mf,correlation=correlation,control=control) } else { ## Again, construction is a work around for nlme 3-1.52 if (wisvf) stop("weights must be like glm weights for generalized case") if (verbosePQL) cat("\n Maximum number of PQL iterations: ",niterPQL,"\n") eval(parse(text=paste("ret$lme<-gammPQL(",deparse(fixed.formula), ",random=rand,data=strip.offset(mf),family=family,", "correlation=correlation,control=control,", "weights=weights,niter=niterPQL,verbose=verbosePQL)",sep=""))) G$y <- ret$lme$y ## makes sure that binomial response is returned as a vector! ##ret$lme<-glmmPQL(fixed.formula,random=rand,data=mf,family=family,correlation=correlation, ## control=control,niter=niterPQL,verbose=verbosePQL) } ### .... fitting finished # now fake a gam object object <- list(model=mf,formula=formula,smooth=G$smooth,nsdf=G$nsdf,family=family, df.null=nrow(G$X),y=G$y,terms=gam.terms,pterms=G$pterms,xlevels=G$xlevels, contrasts=G$contrasts,assign=G$assign,na.action=attr(mf,"na.action"), cmX=G$cmX,var.summary=G$var.summary,scale.estimated=TRUE) pvars <- all.vars(delete.response(object$terms)) object$pred.formula <- if (length(pvars)>0) reformulate(pvars) else NULL ####################################################### ## Transform parameters back to the original space.... ####################################################### bf <- as.numeric(ret$lme$coefficients$fixed) # br <- as.numeric(unlist(ret$lme$coefficients$random)) ## Grouped random coefs are returned in matrices. Each row relates to one ## level of the grouping factor. So to get coefs in order, with all coefs ## for each grouping factor level contiguous, requires the following... br <- as.numeric(unlist(lapply(ret$lme$coefficients$random,t))) fs.present <- FALSE if (G$nsdf) p <- bf[1:G$nsdf] else p <- array(0,0) if (G$m>0) for (i in 1:G$m) { fx <- G$smooth[[i]]$fixed first <- G$smooth[[i]]$first.f.para;last <- G$smooth[[i]]$last.f.para if (first <=last) beta <- bf[first:last] else beta <- array(0,0) ## fixed coefs if (fx) p <- c(p, beta) else { ## not fixed so need to undo transform of random effects etc. ind <- G$smooth[[i]]$rind ##G$smooth[[i]]$first.r.para:G$smooth[[i]]$last.r.para if (!is.null(G$smooth[[i]]$fac)) { ## nested term, need to unpack coefs at each level of fac fs.present <- TRUE if (first<=last) stop("Nested smooths must be fully random") flev <- levels(G$smooth[[i]]$fac) for (j in 1:length(flev)) { b <- br[ind] b <- G$smooth[[i]]$trans.D*b if (!is.null(G$smooth[[i]]$trans.U)) b <- G$smooth[[i]]$trans.U%*%b ind <- ind + G$smooth[[i]]$rinc p <- c(p,b) } } else { ## single level b <- c(br[ind],beta) b <- G$smooth[[i]]$trans.D*b if (!is.null(G$smooth[[i]]$trans.U)) b <- G$smooth[[i]]$trans.U%*%b p <- c(p,b) } } } var.param <- coef(ret$lme$modelStruct$reStruct) n.v <- length(var.param) # k <- 1 spl <- list() if (G$m>0) for (i in 1:G$m) # var.param in reverse term order, but forward order within terms!! { ii <- G$pord[i] n.sp <- length(object$smooth[[ii]]$S) # number of s.p.s for this term if (n.sp>0) { if (inherits(object$smooth[[ii]],"tensor.smooth")) ## ... really mean pdTens used here... ## object$sp[k:(k+n.sp-1)] spl[[ii]] <- notExp2(var.param[(n.v-n.sp+1):n.v]) else ## object$sp[k:(k+n.sp-1)] spl[[ii]] <- 1/notExp2(var.param[n.v:(n.v-n.sp+1)]) } # k <- k + n.sp n.v <- n.v - n.sp } object$sp <- rep(0,0) if (length(spl)) for (i in 1:length(spl)) if (!is.null(spl[[i]])) object$sp <- c(object$sp,spl[[i]]) if (length(object$sp)==0) object$sp <- NULL object$coefficients <- p V <- extract.lme.cov2(ret$lme,mf,n.sr+1) # the data covariance matrix, excluding smooths ## obtain XVX and S.... first.para <- last.para <- rep(0,G$m) ## collect first and last para info relevant to expanded Xf if (fs.present) { ## First create expanded Xf... Xf <- G$Xf[,1:G$nsdf,drop=FALSE] if (G$m>0) for (i in 1:G$m) {# Accumulate the total model matrix ind <- object$smooth[[i]]$first.para:object$smooth[[i]]$last.para if (is.null(object$smooth[[i]]$fac)) { ## normal smooth first.para[i] <- ncol(Xf)+1 Xf <- cbind(Xf,G$Xf[,ind]) last.para[i] <- ncol(Xf) } else { ## smooth conditioned on multilevel factor. Expand Xf flev <- levels(object$smooth[[i]]$fac) first.para[i] <- ncol(Xf)+1 for (k in 1:length(flev)) { Xf <- cbind(Xf,G$Xf[,ind]*as.numeric(object$smooth[[i]]$fac==flev[k])) } last.para[i] <- ncol(Xf) } } object$R <- formXtViX(V,Xf) ## inefficient, if there are smooths conditioned on factors XVX <- crossprod(object$R) nxf <- ncol(Xf) } else { if (G$m>0) for (i in 1:G$m) { first.para[i] <- object$smooth[[i]]$first.para last.para[i] <- object$smooth[[i]]$last.para } object$R <- formXtViX(V,G$Xf) XVX <- crossprod(object$R) nxf <- ncol(G$Xf) } object$R <- object$R*ret$lme$sigma ## correction to what is required by summary.gam ## Now S... S <- matrix(0,nxf,nxf) ## penalty matrix first <- G$nsdf+1 k <- 1 if (G$m>0) for (i in 1:G$m) {# Accumulate the total penalty matrix if (is.null(object$smooth[[i]]$fac)) { ## simple regular smooth... ind <- first.para[i]:last.para[i] ns <-length(object$smooth[[i]]$S) if (ns) for (l in 1:ns) { S[ind,ind] <- S[ind,ind] + object$smooth[[i]]$S[[l]]*object$sp[k] k <- k+1 } } else { ## smooth conditioned on factor flev <- levels(object$smooth[[i]]$fac) ind <- first.para[i]:(first.para[i]+object$smooth[[i]]$n.para-1) ns <- length(object$smooth[[i]]$S) for (j in 1:length(flev)) { if (ns) for (l in 1:ns) { S[ind,ind] <- S[ind,ind] + object$smooth[[i]]$S[[l]]*object$sp[k] k <- k+1 } k <- k - ns ## same smoothing parameters repeated for each factor level ind <- ind + object$smooth[[i]]$n.para } k <- k + ns } } S <- S/ret$lme$sigma^2 # X'V^{-1}X divided by \sigma^2, so should S be ## now replace original first.para and last.para with expanded versions... if (G$m) for (i in 1:G$m) { object$smooth[[i]]$first.para <- first.para[i] object$smooth[[i]]$last.para <- last.para[i] } ## stable computation of coefficient covariance matrix... ev <- eigen(XVX+S,symmetric=TRUE) ind <- ev$values != 0 iv <- ev$values;iv[ind] <- 1/ev$values[ind] Vb <- ev$vectors%*%(iv*t(ev$vectors)) object$edf<-rowSums(Vb*t(XVX)) object$df.residual <- length(object$y) - sum(object$edf) object$sig2 <- ret$lme$sigma^2 if (lme.used) { object$method <- paste("lme.",method,sep="")} else { object$method <- "PQL"} if (!lme.used||method=="ML") Vb <- Vb*length(G$y)/(length(G$y)-G$nsdf) object$Vp <- Vb object$Ve <- Vb%*%XVX%*%Vb object$prior.weights <- weights class(object) <- "gam" ## If prediction parameterization differs from fit parameterization, transform now... ## (important for t2 smooths, where fit constraint is not good for component wise ## prediction s.e.s) if (!is.null(G$P)) { object$coefficients <- G$P %*% object$coefficients object$Vp <- G$P %*% object$Vp %*% t(G$P) object$Ve <- G$P %*% object$Ve %*% t(G$P) } object$linear.predictors <- predict.gam(object,type="link") object$fitted.values <- object$family$linkinv(object$linear.predictors) object$residuals <- residuals(ret$lme) #as.numeric(G$y) - object$fitted.values if (G$nsdf>0) term.names<-colnames(G$X)[1:G$nsdf] else term.names<-array("",0) n.smooth <- length(G$smooth) if (n.smooth) { for (i in 1:n.smooth) { k <- 1 for (j in object$smooth[[i]]$first.para:object$smooth[[i]]$last.para) { term.names[j] <- paste(object$smooth[[i]]$label,".",as.character(k),sep="") k <- k+1 } } if (!is.null(object$sp)) names(object$sp) <- names(G$sp) } names(object$coefficients) <- term.names # note - won't work on matrices!! names(object$edf) <- term.names if (is.null(weights)) object$prior.weights <- object$y*0+1 else if (wisvf) object$prior.weights <- varWeights.dfo(ret$lme,mf)^2 else object$prior.weights <- ret$lme$w object$weights <- object$prior.weights if (!is.null(G$Xcentre)) object$Xcentre <- G$Xcentre ## column centering values ## set environments to global to avoid enormous saved object files environment(attr(object$model,"terms")) <- environment(object$terms) <- environment(object$pterms) <- environment(object$formula) <-environment(object$pred.formula) <- .GlobalEnv ret$gam <- object environment(attr(ret$lme$data,"terms")) <- environment(ret$lme$terms) <- .GlobalEnv if (!is.null(ret$lme$modelStruct$varStruct)) { environment(attr(ret$lme$modelStruct$varStruct,"formula")) <- .GlobalEnv } if (!is.null(ret$lme$modelStruct$corStruct)) { environment(attr(ret$lme$modelStruct$corStruct,"formula")) <- .GlobalEnv } class(ret) <- c("gamm","list") ret } ## end gamm test.gamm <- function(control=nlme::lmeControl(niterEM=3,tolerance=1e-11,msTol=1e-11)) ## this function is a response to repeated problems with nlme/R updates breaking ## the pdTens class. It tests for obvious breakages! { test1<-function(x,z,sx=0.3,sz=0.4) { x<-x*20 (pi**sx*sz)*(1.2*exp(-(x-0.2)^2/sx^2-(z-0.3)^2/sz^2)+ 0.8*exp(-(x-0.7)^2/sx^2-(z-0.8)^2/sz^2)) } compare <- function(b,b1,edf.tol=.001) { edf.diff <- abs(sum(b$edf)-sum(b1$edf)) fit.cor <- cor(fitted(b),fitted(b1)) if (fit.cor<.999) { cat("FAILED: fit.cor = ",fit.cor,"\n");return()} if (edf.diff>edf.tol) { cat("FAILED: edf.diff = ",edf.diff,"\n");return()} cat("PASSED \n") } n<-500 x<-runif(n)/20;z<-runif(n); f <- test1(x,z) y <- f + rnorm(n)*0.2 control$sigma <- NULL ## avoid failure on silly test cat("testing covariate scale invariance ... ") b <- gamm(y~te(x,z), control=control ) x1 <- x*100 b1 <- gamm(y~te(x1,z),control=control) res <- compare(b$gam,b1$gam) cat("testing invariance w.r.t. response ... ") y1 <- y*100 b1 <- gamm(y1~te(x,z),control=control) res <- compare(b$gam,b1$gam) cat("testing equivalence of te(x) and s(x) ... ") b2 <- gamm(y~te(x,k=10,bs="cr"),control=control) b1 <- gamm(y~s(x,bs="cr",k=10),control=control) res <- compare(b2$gam,b1$gam,edf.tol=.1) cat("testing equivalence of gam and gamm with same sp ... ") b1 <- gam(y~te(x,z),sp=b$gam$sp) res <- compare(b$gam,b1) if (FALSE) cat(res,x1,y1) ## fool codetools } mgcv/R/misc.r0000644000177400001440000003636212654640624012742 0ustar murdochusers## (c) Simon N. Wood 2011-2014 ## Many of the following are simple wrappers for C functions, used largely ## for testing purposes rmvn <- function(n,mu,V) { ## generate multivariate normal deviates. e.g. ## V <- matrix(c(2,1,1,2),2,2); mu <- c(1,1);n <- 1000;z <- rmvn(n,mu,V);crossprod(sweep(z,2,colMeans(z)))/n p <- ncol(V) R <- mroot(V,rank=ncol(V)) ## RR' = V if (is.matrix(mu)) { if (ncol(mu)!=p||nrow(mu)!=n) stop("mu dimensions wrong") z <- matrix(rnorm(p*n),n,p)%*%t(R) + mu } else { if (length(mu)!=p) stop("mu dimensions wrong") z <- t(R%*% matrix(rnorm(p*n),p,n) + mu) if (n==1) z <- as.numeric(z) } z } ## rmvn sdiag <- function(A,k=0) { ## extract sub or super diagonal of matrix (k=0 is leading) p <- ncol(A) n <- nrow(A) if (k>p-1||-k > n-1) return() if (k >= 0) { i <- 1:n j <- (k+1):p } else { i <- (-k+1):n j <- 1:p } if (length(i)>length(j)) i <- i[1:length(j)] else j <- j[1:length(i)] ii <- i + (j-1) * n A[ii] } ## sdiag "sdiag<-" <- function(A,k=0,value) { p <- ncol(A) n <- nrow(A) if (k>p-1||-k > n-1) return() if (k >= 0) { i <- 1:n j <- (k+1):p } else { i <- (-k+1):n j <- 1:p } if (length(i)>length(j)) i <- i[1:length(j)] else j <- j[1:length(i)] ii <- i + (j-1) * n A[ii] <- value A } ## "sdiag<-" bandchol <- function(B) { ## obtain R such that R'R = A. Where A is banded matrix contained in R. n <- ncol(B) k <- 0 if (n==nrow(B)) { ## square matrix. Extract the diagonals A <- B*0 for (i in 1:n) { b <- sdiag(B,i-1) if (sum(b!=0)!=0) { k <- i ## largest index of a non-zero band A[i,1:length(b)] <- b } } B <- A[1:k,] } oo <- .C(C_band_chol,B=as.double(B),n=as.integer(n),k=as.integer(nrow(B)),info=as.integer(0)) if (oo$info<0) stop("something wrong with inputs to LAPACK routine") if (oo$info>0) stop("not positive definite") B <- matrix(oo$B,nrow(B),n) if (k>0) { ## was square on entry, so also on exit... A <- A * 0 for (i in 1:k) sdiag(A,i-1) <- B[i,1:(n-i+1)] B <- A } B } ## bandchol trichol <- function(ld,sd) { ## obtain chol factor R of symm tridiag matrix, A, with leading diag ## ld and sub/super diags sd. R'R = A. On exit ld is diag of R and ## sd its super diagonal. n <- length(ld) if (n<2) stop("don't be silly") if (n!=length(sd)+1) stop("sd should have exactly one less entry than ld") oo <- .C(C_tri_chol,ld=as.double(ld),sd=as.double(sd),n=as.integer(n),info=as.integer(0)) if (oo$info<0) stop("something wrong with inputs to LAPACK routine") if (oo$info>0) stop("not positive definite") ld <- sqrt(oo$ld) sd <- oo$sd*ld[1:(n-1)] list(ld=ld,sd=sd) } mgcv.omp <- function() { ## does open MP appear to be available? oo <- .C(C_mgcv_omp,a=as.integer(-1)) if (oo$a==1) TRUE else FALSE } mvn.ll <- function(y,X,beta,dbeta=NULL) { ## to facilitate testing of MVN routine mvn_ll. ## X is a sequence of m model matrices bound columnwise, with m dim attribute lpi ## indicating where the next starts in all cases. ## beta is parameter vector - last m*(m+1)/2 elements are chol factor of precision params. ## y is m by n data matrix. lpi <- attr(X,"lpi")-1;m <- length(lpi) nb <- length(beta) if (is.null(dbeta)) { nsp = 0;dbeta <- dH <- 0 } else { nsp = ncol(dbeta) dH = rep(0,nsp*nb*nb) } oo <- .C(C_mvn_ll,y=as.double(y),X=as.double(X),XX=as.double(crossprod(X)),beta=as.double(beta),n=as.integer(nrow(X)), lpi=as.integer(lpi),m=as.integer(m),ll=as.double(0),lb=as.double(beta*0), lbb=as.double(rep(0,nb*nb)), dbeta = as.double(dbeta), dH = as.double(dH), deriv = as.integer(nsp>0),nsp = as.integer(nsp),nt=as.integer(1)) if (nsp==0) dH <- NULL else { dH <- list();ind <- 1:(nb*nb) for (i in 1:nsp) { dH[[i]] <- matrix(oo$dH[ind],nb,nb) ind <- ind + nb*nb } } list(l=oo$ll,lb=oo$lb,lbb=matrix(oo$lbb,nb,nb),dH=dH) } ## mvn.ll ## discretized covariate routines... XWXd <- function(X,w,k,ks,ts,dt,v,qc,nthreads=1,drop=NULL,ar.stop=-1,ar.row=-1,ar.w=-1) { ## Form X'WX given weights in w and X in compressed form in list X. ## each element of X is a (marginal) model submatrix. Full version ## is given by X[[i]][k[,i],]. list X relates to length(ts) separate ## terms. ith term starts at matrix ts[i] and has dt[i] marginal matrices. ## Terms with several marginals are tensor products and may have ## constraints (if qc[i]>1), stored as a householder vector in v[[i]]. ## check ts and k index start (assumed 1 here) ## if drop is non-NULL it contains index of rows/cols to drop from result m <- unlist(lapply(X,nrow));p <- unlist(lapply(X,ncol)) nx <- length(X);nt <- length(ts) n <- length(w);pt <- 0; for (i in 1:nt) pt <- pt + prod(p[ts[i]:(ts[i]+dt[i]-1)]) - as.numeric(qc[i]>0) oo <- .C(C_XWXd,XWX =as.double(rep(0,pt^2)),X= as.double(unlist(X)),w=as.double(w), k=as.integer(k-1),ks=as.integer(ks-1),m=as.integer(m),p=as.integer(p), n=as.integer(n), ns=as.integer(nx), ts=as.integer(ts-1), as.integer(dt), nt=as.integer(nt), v = as.double(unlist(v)),qc=as.integer(qc),nthreads=as.integer(nthreads), ar.stop=as.integer(ar.stop-1),ar.row=as.integer(ar.row-1),ar.weights=as.double(ar.w)) if (is.null(drop)) matrix(oo$XWX,pt,pt) else matrix(oo$XWX,pt,pt)[-drop,-drop] } ## XWXd XWyd <- function(X,w,y,k,ks,ts,dt,v,qc,drop=NULL,ar.stop=-1,ar.row=-1,ar.w=-1) { ## X'Wy... m <- unlist(lapply(X,nrow));p <- unlist(lapply(X,ncol)) nx <- length(X);nt <- length(ts) n <- length(w);pt <- 0; for (i in 1:nt) pt <- pt + prod(p[ts[i]:(ts[i]+dt[i]-1)]) - as.numeric(qc[i]>0) oo <- .C(C_XWyd,XWy=rep(0,pt),y=as.double(y),X=as.double(unlist(X)),w=as.double(w),k=as.integer(k-1), ks=as.integer(ks-1), m=as.integer(m),p=as.integer(p),n=as.integer(n), nx=as.integer(nx), ts=as.integer(ts-1), dt=as.integer(dt),nt=as.integer(nt),v=as.double(unlist(v)),qc=as.integer(qc), ar.stop=as.integer(ar.stop-1),ar.row=as.integer(ar.row-1),ar.weights=as.double(ar.w)) if (is.null(drop)) oo$XWy else oo$XWy[-drop] } ## XWyd Xbd <- function(X,beta,k,ks,ts,dt,v,qc,drop=NULL) { ## note that drop may contain the index of columns of X to drop before multiplying by beta. ## equivalently we can insert zero elements into beta in the appropriate places. n <- if (is.matrix(k)) nrow(k) else length(k) ## number of data m <- unlist(lapply(X,nrow)) ## number of rows in each discrete model matrix p <- unlist(lapply(X,ncol)) ## number of cols in each discrete model matrix nx <- length(X) ## number of model matrices nt <- length(ts) ## number of terms if (!is.null(drop)) { b <- if (is.matrix(beta)) matrix(0,nrow(beta)+length(drop),ncol(beta)) else rep(0,length(beta)+length(drop)) if (is.matrix(beta)) b[-drop,] <- beta else b[-drop] <- beta beta <- b } bc <- if (is.matrix(beta)) ncol(beta) else 1 ## number of columns in beta oo <- .C(C_Xbd,f=as.double(rep(0,n*bc)),beta=as.double(beta),X=as.double(unlist(X)),k=as.integer(k-1), ks = as.integer(ks-1), m=as.integer(m),p=as.integer(p), n=as.integer(n), nx=as.integer(nx), ts=as.integer(ts-1), as.integer(dt), as.integer(nt),as.double(unlist(v)),as.integer(qc),as.integer(bc)) if (is.matrix(beta)) matrix(oo$f,n,bc) else oo$f } ## Xbd diagXVXd <- function(X,V,k,ks,ts,dt,v,qc,drop=NULL,n.threads=1) { ## discrete computation of diag(XVX') n <- if (is.matrix(k)) nrow(k) else length(k) m <- unlist(lapply(X,nrow));p <- unlist(lapply(X,ncol)) nx <- length(X);nt <- length(ts) if (!is.null(drop)) { pv <- ncol(V)+length(drop) V0 <- matrix(0,pv,pv) V0[-drop,-drop] <- V V <- V0;rm(V0) } else pv <- ncol(V) oo <- .C(C_diagXVXt,diag=as.double(rep(0,n)),V=as.double(V),X=as.double(unlist(X)),k=as.integer(k-1), ks=as.integer(ks-1), m=as.integer(m),p=as.integer(p), n=as.integer(n), nx=as.integer(nx), ts=as.integer(ts-1), as.integer(dt), as.integer(nt),as.double(unlist(v)),as.integer(qc),as.integer(pv),as.integer(n.threads)) oo$diag } ## diagXVXd dchol <- function(dA,R) { ## if dA contains matrix dA/dx where R is chol factor s.t. R'R = A ## then this routine returns dR/dx... p <- ncol(R) oo <- .C(C_dchol,dA=as.double(dA),R=as.double(R),dR=as.double(R*0),p=as.integer(ncol(R))) return(matrix(oo$dR,p,p)) } ## dchol vcorr <- function(dR,Vr,trans=TRUE) { ## Suppose b = sum_k op(dR[[k]])%*%z*r_k, z ~ N(0,Ip), r ~ N(0,Vr). vcorr returns cov(b). ## dR is a list of p by p matrices. 'op' is 't' if trans=TRUE and I() otherwise. p <- ncol(dR[[1]]) M <- if (trans) ncol(Vr) else -ncol(Vr) ## sign signals transpose or not to C code if (abs(M)!=length(dR)) stop("internal error in vcorr, please report to simon.wood@r-project.org") oo <- .C(C_vcorr,dR=as.double(unlist(dR)),Vr=as.double(Vr),Vb=as.double(rep(0,p*p)), p=as.integer(p),M=as.integer(M)) return(matrix(oo$Vb,p,p)) } ## vcorr pinv <- function(X,svd=FALSE) { ## a pseudoinverse for n by p, n>p matrices qrx <- qr(X,tol=0,LAPACK=TRUE) R <- qr.R(qrx);Q <- qr.Q(qrx) rr <- Rrank(R) if (svd&&rr0) -> ii;a[ii]+b[ii]*n->ii ## library(mgcv);R <- matrix(0,n,n);R[ii] <- runif(n*(n+1)/2) ## Note: A[a-b<=0] <- 0 zeroes upper triangle ## system.time(A <- mgcv:::pRRt(R,2)) ## system.time(A2 <- tcrossprod(R));range(A-A2) n <- nrow(R) A <- matrix(0,n,n) .Call(C_mgcv_RPPt,A,R,nt) A } block.reorder <- function(x,n.blocks=1,reverse=FALSE) { ## takes a matrix x divides it into n.blocks row-wise blocks, and re-orders ## so that the blocks are stored one after the other. ## e.g. library(mgcv); x <- matrix(1:18,6,3);xb <- mgcv:::block.reorder(x,2) ## x;xb;mgcv:::block.reorder(xb,2,TRUE) r = nrow(x);cols = ncol(x); if (n.blocks <= 1) return(x); if (r%%n.blocks) { nb = ceiling(r/n.blocks) } else nb = r/n.blocks; oo <- .C(C_row_block_reorder,x=as.double(x),as.integer(r),as.integer(cols), as.integer(nb),as.integer(reverse)); matrix(oo$x,r,cols) } ## block.reorder pqr <- function(x,nt=1) { ## parallel QR decomposition, using openMP in C, and up to nt threads (only if worthwhile) ## library(mgcv);n <- 20;p<-4;X <- matrix(runif(n*p),n,p);er <- mgcv:::pqr(X,nt=2) x.c <- ncol(x);r <- nrow(x) oo <- .C(C_mgcv_pqr,x=as.double(c(x,rep(0,nt*x.c^2))),as.integer(r),as.integer(x.c), pivot=as.integer(rep(0,x.c)), tau=as.double(rep(0,(nt+1)*x.c)),as.integer(nt)) list(x=oo$x,r=r,c=x.c,tau=oo$tau,pivot=oo$pivot+1,nt=nt) } pqr.R <- function(x) { ## x is an object returned by pqr. This extracts the R factor... ## e.g. as pqr then... ## R <- mgcv:::pqr.R(er); R0 <- qr.R(qr(X,tol=0)) ## svd(R)$d;svd(R0)$d oo <- .C(C_getRpqr,R=as.double(rep(0,x$c^2)),as.double(x$x),as.integer(x$r),as.integer(x$c), as.integer(x$c),as.integer(x$nt)) matrix(oo$R,x$c,x$c) } pqr.qy <- function(x,a,tr=FALSE) { ## x contains a parallel QR decomp as computed by pqr. a is a matrix. computes ## Qa or Q'a depending on tr. ## e.g. as above, then... ## a <- diag(p);Q <- mgcv:::pqr.qy(er,a);crossprod(Q) ## X[,er$pivot+1];Q%*%R ## Qt <- mgcv:::pqr.qy(er,diag(n),TRUE);Qt%*%t(Qt);range(Q-t(Qt)) ## Q <- qr.Q(qr(X,tol=0));z <- runif(n);y0<-t(Q)%*%z ## mgcv:::pqr.qy(er,z,TRUE)->y ## z <- runif(p);y0<-Q%*%z;mgcv:::pqr.qy(er,z)->y if (is.matrix(a)) a.c <- ncol(a) else a.c <- 1 if (tr) { if (is.matrix(a)) { if (nrow(a) != x$r) stop("a has wrong number of rows") } else if (length(a) != x$r) stop("a has wrong number of rows") } else { if (is.matrix(a)) { if (nrow(a) != x$c) stop("a has wrong number of rows") } else if (length(a) != x$c) stop("a has wrong number of rows") a <- c(a,rep(0,a.c*(x$r-x$c))) } oo <- .C(C_mgcv_pqrqy,a=as.double(a),as.double(x$x),as.double(x$tau),as.integer(x$r), as.integer(x$c),as.integer(a.c),as.integer(tr),as.integer(x$nt)) if (tr) return(matrix(oo$a[1:(a.c*x$c)],x$c,a.c)) else return(matrix(oo$a,x$r,a.c)) } pmmult <- function(A,B,tA=FALSE,tB=FALSE,nt=1) { ## parallel matrix multiplication (not for use on vectors or thin matrices) ## library(mgcv);r <- 10;c <- 5;n <- 8 ## A <- matrix(runif(r*n),r,n);B <- matrix(runif(n*c),n,c);range(A%*%B-mgcv:::pmmult(A,B,nt=1)) ## A <- matrix(runif(r*n),n,r);B <- matrix(runif(n*c),n,c);range(t(A)%*%B-mgcv:::pmmult(A,B,TRUE,FALSE,nt=1)) ## A <- matrix(runif(r*n),n,r);B <- matrix(runif(n*c),c,n);range(t(A)%*%t(B)-mgcv:::pmmult(A,B,TRUE,TRUE,nt=1)) ## A <- matrix(runif(r*n),r,n);B <- matrix(runif(n*c),c,n);range(A%*%t(B)-mgcv:::pmmult(A,B,FALSE,TRUE,nt=1)) if (tA) { n = nrow(A);r = ncol(A)} else {n = ncol(A);r = nrow(A)} if (tB) { c = nrow(B)} else {c = ncol(B)} C <- rep(0,r * c) oo <- .C(C_mgcv_pmmult,C=as.double(C),as.double(A),as.double(B),as.integer(tA),as.integer(tB),as.integer(r), as.integer(c),as.integer(n),as.integer(nt)); matrix(oo$C,r,c) }mgcv/R/soap.r0000755000177400001440000007436212765741174012763 0ustar murdochusers## code for soap film smoothing to deal with difficult boundary regions ## Copyright Simon Wood 2006-2012 unconstrain <- function(object,beta) { ## function to produce full version of constrained coefficients of ## smooth object. Returned vector may have an attribute "constant" ## to be subtraccted from results. ## NOTE: sum to zero on some parameters only branch is not fully ## tested (also unused at present)! del.index <- attr(object,"del.index") if (!is.null(del.index)) { beta.full <- rep(0,length(beta)+length(del.index)) k <- 1;j <- 1 for (i in 1:length(beta.full)) { if (j <= length(del.index) && i==del.index[j]) { beta.full[i] <- 0;j <- j + 1 } else { beta.full[i] <- beta[k];k <- k + 1 } } beta <- beta.full } ## end of del.index handling qrc <- attr(object,"qrc") if (!is.null(qrc)) { ## then smoothCon absorbed constraints j <- attr(object,"nCons") if (j>0) { ## there were constraints to absorb - need to untransform k <- length(beta) + j if (inherits(qrc,"qr")) { indi <- attr(object,"indi") ## index of constrained parameters if (is.null(indi)) { ## X <- t(qr.qty(qrc,t(X))[(j+1):k,,drop=FALSE]) ## XZ beta <- qr.qy(qrc,c(rep(0,j),beta)) } else { ## only some parameters are subject to constraint ## NOTE: this branch not fully tested ##nx <- length(indi) ##nc <- j;nz <- nx - nc Xbeta <- qr.qy(qrc,c(rep(0,j),beta[indi])) beta.full <- rep(0,length(beta)+j) ib <- 1;ii <- 1 for (i in 1:length(beta.full)) { if (i==indi[ii]) { beta.full[i] <- Xbeta[ii]; ii <- ii + 1 } else { beta.full[i] <- beta[ib]; ib <- ib + 1 } } ##X[,indi[1:nz]]<-t(qr.qty(qrc,t(X[,indi,drop=FALSE]))[(nc+1):nx,,drop=FALSE]) ## X <- X[,-indi[(nz+1):nx]] beta <- beta.full } } else if (inherits(qrc,"sweepDrop")) { ## Sweep and drop constraints. First element is index to drop. ## Remainder are constants to be swept out of remaining columns ## X <- sweep(X[,-qrc[1],drop=FALSE],2,qrc[-1]) #X <- X[,-qrc[1],drop=FALSE] - matrix(qrc[-1],nrow(X),ncol(X)-1,byrow=TRUE) cnst <- sum(beta*qrc[-1]) if (qrc[1]==1) beta <- c(0,beta) else if (qrc[1]==length(beta)+1) beta <- c(beta,0) else beta <- c(beta[1:(qrc[1]-1)],0,beta[qrc[1]:length(beta)]) attr(beta,"constant") <- cnst } else if (qrc>0) { ## simple set to zero constraint ##X <- X[,-qrc] if (qrc==1) beta <- c(0,beta) else if (qrc==length(beta)+1) beta <- c(beta,0) else beta <- c(beta[1:(qrc-1)],0,beta[qrc:length(beta)]) } else if (qrc<0) { ## params sum to zero # X <- t(diff(t(X))) beta <- t(diff(diag(length(beta)+1)))%*%beta } } ## end if (j>0) } ## end if qrc exists beta } ## end of unconstrain bnd2C <- function(bnd) { ## converts boundary loop list to form required in C code. n.loop <- 1 if (is.null(bnd$x)) { ## translate into form that C routine needs bn <- list(x=bnd[[1]]$x,y=bnd[[1]]$y) n.loop <- length(bnd) if (length(bnd)>1) for (i in 2:n.loop) { bn$x <- c(bn$x,NA,bnd[[i]]$x);bn$y <- c(bn$y,NA,bnd[[i]]$y) } bnd <- bn } ## replace NA segment separators with a numeric code lowLim <- min(c(bnd$x,bnd$y),na.rm=TRUE)-1 ind <- is.na(bnd$x)|is.na(bnd$y) bnd$x[ind] <- bnd$y[ind] <- lowLim - 1 bnd$n <- length(bnd$x) if (bnd$n != length(bnd$y)) stop("x and y must be same length") bnd$breakCode <-lowLim bnd$n.loop <- n.loop bnd } ## end bnd2C inSide <- function(bnd,x,y) ## tests whether each point x[i],y[i] is inside the boundary defined ## by bnd$x, bnd$y, or by multiple boundary loops in bnd[[1]]$x, ## bnd[[1]]$y, bnd[[2]]$x, ... etc. ## names in bnd must match those of x and y, but do not need to be "x" and "y" { ## match the names up first... xname <- deparse(substitute(x)) yname <- deparse(substitute(y)) bnd.name <- names(bnd) if (is.null(bnd.name)) for (i in 1:length(bnd)) { bnd.name <- names(bnd[[i]]) if (xname%in%bnd.name==FALSE||yname%in%bnd.name==FALSE) stop("variable names don't match boundary names") bnd.name[xname==bnd.name] <- "x" bnd.name[yname==bnd.name] <- "y" names(bnd[[i]]) <- bnd.name } else { if (xname%in%bnd.name==FALSE||yname%in%bnd.name==FALSE) stop("variable names don't match boundary names") bnd.name[xname==bnd.name] <- "x" bnd.name[yname==bnd.name] <- "y" names(bnd) <- bnd.name } ## now do the real stuff... bnd <- bnd2C(bnd) um <-.C(C_in_out,bx=as.double(bnd$x),by=as.double(bnd$y),break.code=as.double(bnd$breakCode), x=as.double(x),y=as.double(y),inside=as.integer(y*0),nb=as.integer(bnd$n), n=as.integer(length(x))) as.logical(um$inside) } ## end inSide process.boundary <- function(bnd) ## takes a list of boundary loops, makes sure that they join up ## and add a distance along loop array, d to each list element. { for (i in 1:length(bnd)) { x <- bnd[[i]]$x;y<-bnd[[i]]$y;n <- length(x) if (length(y)!=n) stop("x and y not same length") if (x[1]!=x[n]||y[1]!=y[n]) { ## then loop not closed, so close it n<-n+1;x[n] <- x[1];y[n] <- y[1] if (inherits(bnd[[i]],"data.frame")) bnd[[i]][n,] <-bnd[[i]][1,] else { ## hopefully a list! bnd[[i]]$x[n] <- x[1];bnd[[i]]$y[n] <- y[1] if (!is.null(bnd[[i]]$f)) bnd[[i]]$f[n] <- bnd[[i]]$f[1] } } len <- c(0,sqrt((x[1:(n-1)]-x[2:n])^2+(y[1:(n-1)]-y[2:n])^2)) ## seg lengths bnd[[i]]$d<-cumsum(len) ## distance along boundary } bnd } ## end process.boundary crunch.knots <- function(G,knots,x0,y0,dx,dy) ## finds indices of knot locations in solution grid ## the knot x,y locations are given in the `knots' argument. { nk <- length(knots$x) nx <- ncol(G);ny <- nrow(G) ki <- rep(0,nk) if (nk==0) return(ki) for (k in 1:nk) { i <- round((knots$x[k]-x0)/dx)+1 j <- round((knots$y[k]-y0)/dy)+1 if (i>1&&i<=nx&&j>1&&j<=ny) { ki[k] <- G[j,i] if (ki[k] <= 0) { str <- paste("knot",k,"is on or outside boundary") stop(str) } } } ## all knots done ki ## ki[k] indexes kth knot in solution grid } ## end crunch.knots setup.soap <- function(bnd,knots,nmax=100,k=10,bndSpec=NULL) { ## setup soap film smooth - nmax is number of grid cells for longest side ## it's important that grid cells are square! ## check boundary... if (!inherits(bnd,"list")) stop("bnd must be a list.") n.loops <- length(bnd) if (n.loops!=length(k)) { if (length(k)==1) k <- rep(k,n.loops) else stop("lengths of k and bnd are not compatible.") } bnd <- process.boundary(bnd) ## add distances and close any open loops ## create grid on which to solve Laplace equation ## Obtain grid limits from boundary 'bnd'.... x0 <- min(bnd[[1]]$x);x1 <- max(bnd[[1]]$x) y0 <- min(bnd[[1]]$y);y1 <- max(bnd[[1]]$y) if (length(bnd)>1) for (i in 2:length(bnd)) { x0 <- min(c(x0,bnd[[i]]$x)); x1 <- max(c(x1,bnd[[i]]$x)) y0 <- min(c(y0,bnd[[i]]$y)); y1 <- max(c(y1,bnd[[i]]$y)) } ## now got the grid limits, can set it up if (x1-x0>y1-y0) { ## x is longest side dy <- dx <- (x1-x0) /(nmax-1) nx <- nmax ny <- ceiling((y1-y0)/dy)+1 } else { ## y is longest side dy <- dx <- (y1-y0) /(nmax-1) ny <- nmax nx <- ceiling((x1-x0)/dy)+1 } ## so grid is now nx by ny, cell size is dx by dy (but dx=dy) ## x0, y0 is "lower left" cell centre ## Create grid index G bnc <- bnd2C(bnd) ## convert boundary to form required in C code G <- matrix(0,ny,nx) nb <- rep(0,bnc$n.loop) oo <- .C(C_boundary,G=as.integer(G), d=as.double(G), dto=as.double(G), x0=as.double(x0), y0 = as.double(y0), dx=as.double(dx), dy = as.double(dy), nx=as.integer(nx),as.integer(ny), x=as.double(bnc$x),y=as.double(bnc$y), breakCode=as.double(bnc$breakCode),n=as.integer(bnc$n),nb=as.integer(nb)) ret <- list(G=matrix(oo$G,ny,nx),nb=oo$nb,d=oo$d[oo$d >= 0],x0=x0,y0=y0,dx=dx,dy=dy,bnd=bnd) rm(oo) ## Now create the PDE coefficient matrix n.inside <- sum(ret$G > - nx*ny) xx <- rep(0,5*n.inside) o1 <- .C(C_pde_coeffs,as.integer(ret$G),xx=as.double(xx),ii=as.integer(xx),jj=as.integer(xx), n=as.integer(0),as.integer(nx),as.integer(ny),as.double(dx),as.double(dy)) ind <- 1:o1$n X <- sparseMatrix(i=o1$ii[ind]+1,j=o1$jj[ind]+1,x=o1$xx[ind]) er <- expand(lu(X)) ret$Q <- er$Q;ret$U <- er$U;ret$L <- er$L;ret$P <- er$P ret$ng <- n.inside ## the number of cells to solve for rm(er);rm(X) ## ... so the sparse LU decomposition of X can be used to solve PDE. ## X = PLUQ where P and Q are permuation matrices. ## now obtain location of knots in solution ... ret$ki <- crunch.knots(ret$G,knots,x0,y0,dx,dy) ## setup the boundary conditions/boundary splines bc <- list() ## to hold boundary conditions start <- 1 for (i in 1:length(bnd)) { stop <- start - 1 + ret$nb[i] ## ret$d[start:stop] = dist along boundary loop i if (is.null(bnd[[i]]$f)) { ## this boundary is free d <- c(ret$d[start:stop],0) # boundary gridpoint distances along smooth if (is.null(bndSpec)) { bsm <- smooth.construct(s(d,bs="cc",k=k[i]),data=data.frame(d=d),knots=NULL) } else if (bndSpec$bs=="cc"){ if (bndSpec$knot.space=="even") knots <- seq(min(d),max(d),length=k[i]) else knots <- quantile(unique(d),seq(0,1,length=k[i])) bsm <- smooth.construct(s(d,bs="cc",k=k[i]),data=data.frame(d=d),knots=NULL) } else { ## use "cp" P-spline bsm <- smooth.construct(s(d,bs="cp",k=k[i],m=bndSpec$m),data=data.frame(d=d),knots=NULL) } bc[[i]] <- list(bsm=bsm,X=bsm$X[1:ret$nb[i],],S=bsm$S[[1]],free.bound=TRUE) } else { ## boundary is fixed ## pmax/pmin needed to avoid rounding error induced NA's d <- pmax(pmin(ret$d[start:stop],max(bnd[[i]]$d)),min(bnd[[i]]$d)) ui <- !duplicated(bnd[[i]]$d) ff <- approx(bnd[[i]]$d[ui],bnd[[i]]$f[ui],d)$y ## fixed values for BC bc[[i]] <- list(f=ff,free.bound=FALSE) } start <- stop + 1 } ret$bc <- bc ret } ## end of setup.soap soap.basis <- function(sd,x=NA,y=NA,film=TRUE,wiggly=TRUE,penalty=TRUE,plot=FALSE,beta=1) { ## function to evaluate soap basis using soap definition object 'sd' ## returned by setup.soap. x and y are values at which to evaluate. ## If plot==TRUE then then data suitable for plotting are returned at the resolution ## of the solution grid. Then beta contains either the coefficients, or a single number ## representing the single basis function to return (0 for the offset). if (!plot) { indout <- inSide(sd$bnd,x,y); n <- length(x) } else { penalty <- FALSE ## Some constraints result in the need to add a constant ## to the field (e.g. sweep and drop) cnst <- attr(beta,"constant") if (is.null(cnst)) cnst <- 0 else cnst <- -cnst } offset.needed <- FALSE; nc <- length(sd$ki)*as.numeric(wiggly) ## number of interior knots nb <- 0 ## boundary basis dimension offset <- NULL if (film) { stop <- 0 for (i in 1:length(sd$bc)) { ## work through boundary loops start <- stop + 1;stop <- start - 1 + sd$nb[i] if (sd$bc[[i]]$free.bound) nb <- nb + ncol(sd$bc[[i]]$X) else { ## fixed boundary, so offset required if (!offset.needed) { bndOff <- rep(0,sd$ng) ## array for fixed boundary conditions offset.needed <- TRUE } bndOff[start:stop] <- sd$bc[[i]]$f } ## fixed boundary done } ## finished first pass through loops } ## finished first if film if (plot) { ## preliminaries for plotting info if (length(beta)==1) { ## just one basis function to be returned if (beta<0||beta>nc+nb||(beta==0&&!offset.needed)) stop("attempt to select non existent basis function") select.basis <- TRUE } else { ## whole smooth to be returned if (length(beta)!=nc+nb) stop("coefficient vector wrong length") select.basis <- FALSE } G <- sd$G ## solution grid G[G < - length(G)] <- NA ## exterior marked as NA ind <- !is.na(G) gind <- G[ind] <- abs(G[ind])+1 ## need to create the indices such that G[gind] <- g is correct... gind[G[ind]] <- (1:length(G))[ind] G[ind] <- cnst ## now clear interior of G } ## finished preliminary if (plot) if (film) { if (offset.needed) { ## solve for offset soap film bndOff <- solve(sd$Q,solve(sd$U,solve(sd$L,solve(t(sd$P),bndOff)))) if (plot) { ## grid is all that's needed if (select.basis&&beta==0||!select.basis) { G[gind] <- bndOff } } else { ## need full interpolation NAcode <- max(bndOff)*2 offset <- .C(C_gridder,z=as.double(x),as.double(x),as.double(y),as.integer(length(x)),as.double(bndOff), as.integer(sd$G),nx=as.integer(ncol(sd$G)),ny=as.integer(nrow(sd$G)),as.double(sd$x0), as.double(sd$y0),as.double(sd$dx),as.double(sd$dy),as.double(NAcode*2))$z offset[offset>NAcode] <- NA offset[!indout] <- NA } } } ## finished preliminary if (film) if (!plot) { X <- matrix(0,n,nb+nc) ## model matrix if (penalty) { S <- list();off <- 1;nS=0} else {off <- S <- NULL} } k <- 1 ## model matrix column if (film&&nb>0) { ## now work through boundary bases stop <- 0 for (i in 1:length(sd$bc)) { ## work through boundary loops start <- stop + 1;stop <- start - 1 + sd$nb[i] ind <- start:stop ## index of this loop in solution grid if (sd$bc[[i]]$free.bound) { if (penalty) { nS <- nS + 1 off[nS] <- k S[[nS]] <- sd$bc[[i]]$S } ## penalty done for (j in 1:ncol(sd$bc[[i]]$X)) { ## loop over loop basis cols z <- rep(0,sd$ng) z[ind] <- sd$bc[[i]]$X[,j] ## PDE rhs z <- solve(sd$Q,solve(sd$U,solve(sd$L,solve(t(sd$P),z)))) if (plot) { if (select.basis) { if (beta==k) G[gind] <- z } else G[gind] <- G[gind] + beta[k]*z } else { NAcode <- max(z)*2 Xj <- .C(C_gridder,z=as.double(x),as.double(x),as.double(y),as.integer(length(x)),as.double(z), as.integer(sd$G),nx=as.integer(ncol(sd$G)),ny=as.integer(nrow(sd$G)),as.double(sd$x0), as.double(sd$y0),as.double(sd$dx),as.double(sd$dy),as.double(NAcode*2))$z Xj[Xj>NAcode] <- NA;X[,k] <- Xj; } k <- k + 1 } ## basis done } ## end of free boundary } ## end of boundary loops } ## end of film processing if (wiggly) { ## interior basis functions required g <- matrix(0,sd$ng,nc) for (i in 1:nc) g[sd$ki[i],i] <- 1 g <- as(solve(sd$Q,solve(sd$U,solve(sd$L,solve(t(sd$P),g)))),"matrix") g <- sweep(g,2,apply(g,2,max),"/") ## normalize - not really needed if (penalty) { ## get soap penalty nS <- nS + 1;off[nS] <- k S[[nS]] <- crossprod(g) * sd$dx * sd$dy } g <- solve(sd$Q,solve(sd$U,solve(sd$L,solve(t(sd$P),g)))) NAcode <- max(g)*2 for (i in 1:nc) { if (plot) { if (select.basis) { if (k==beta) G[gind] <- g[,i] } else G[gind] <- G[gind] + beta[k]*g[,i] } else { Xj <- .C(C_gridder,z=as.double(x),as.double(x),as.double(y),as.integer(length(x)),as.double(g[,i]), as.integer(sd$G),nx=as.integer(ncol(sd$G)),ny=as.integer(nrow(sd$G)),as.double(sd$x0), as.double(sd$y0),as.double(sd$dx),as.double(sd$dy),as.double(NAcode*2))$z Xj[Xj>NAcode] <- NA;X[,k] <- Xj } k <- k + 1 } } if (plot) { return(t(G)) } else { X[!indout,] <- NA return(list(X=X,S=S,off=off,offset=offset)) } } ## end soap.basis smooth.construct.so.smooth.spec<-function(object,data,knots) ## a full soap film smooth constructor method function for ## integration with mgcv::gam { if (is.null(knots)) stop("knots must be specified for soap") if (object$dim!=2) stop("soap films are bivariate only") x <- data[[object$term[1]]] y <- data[[object$term[2]]] knt <- list(x=knots[[object$term[1]]],y=knots[[object$term[2]]]) if (length(knt$x)<1) stop("need at least one interior knot") bnd <- object$xt$bnd if (is.null(bnd)) stop("can't soap smooth without a boundary") if (!inherits(bnd,"list")) stop("bnd must be a list of boundary loops") for (i in 1:length(bnd)) { ## re-lable boundary nm <- names(bnd[[i]]) ind <- nm==object$term[1] if (sum(ind)!=1) stop("faulty bnd") names(bnd[[i]])[ind] <- "x" ind <- nm==object$term[2] if (sum(ind)!=1) stop("faulty bnd") names(bnd[[i]])[ind] <- "y" } if (length(object$bs.dim)==1) k <- rep(object$bs.dim,length(bnd)) else { if (length(object$bs.dim)==length(bnd)) k <- object$bs.dim else stop("k and bnd lengths are inconsistent") } if (is.null(object$xt$nmax)) nmax <- 200 else nmax <- object$xt$nmax ## setup the soap defining structures sd <- setup.soap(bnd,knots=knt,nmax=nmax,k=k,bndSpec=object$xt$bndSpec) b <- soap.basis(sd,x,y,film=TRUE,wiggly=TRUE,penalty=TRUE) if (sum(is.na(b$X))>0) stop("data outside soap boundary") # b <- soap.construct(x,y,bnd,knots=knt,k=k,n.grid=n.grid,basis.type=2, # depth=depth,rel.eps=rel.eps,abs.eps=abs.eps, # bndSpec=object$xt$bndSpec) ## get penalty null space for the term... ns.dim <- 0;n <- length(sd$bc) if (n>0) for (i in 1:n) if (sd$bc[[i]]$free.bound) ns.dim <- ns.dim + sd$bc[[i]]$bsm$null.space.dim object$null.space.dim <- ns.dim need.con <- TRUE for (i in 1:length(sd$bc)) if (!sd$bc[[i]]$free.bound) need.con <- FALSE ## rescale basis for nice conditioning.... irng <- 1/as.numeric(apply(b$X,2,max)-apply(b$X,2,min)) b$X <- t(t(b$X)*irng) ## now apply rescaling for (i in 1:length(b$S)) { a <- irng[b$off[i]:(b$off[i]+ncol(b$S[[i]])-1)] b$S[[i]] <- diag(a)%*%b$S[[i]]%*%diag(a) } object$irng <- irng ## the column scaling factor object$X <- b$X ## model matrix attr(object$X,"offset") <- b$offset if (!object$fixed) { ## have to unpack a bit... S <- list();n <- ncol(object$X) for (i in 1:length(b$S)) { S[[i]] <- matrix(0,n,n) m <- ncol(b$S[[i]]) ind <- b$off[i]:(b$off[i]+m-1) S[[i]][ind,ind] <- b$S[[i]] } object$S <- S ## penalties } rr <- ncol(b$S[[1]])-1 if (length(b$S)>1) for (i in 2:length(b$S)) rr <- c(rr,ncol(b$S[[i]])-1) rr[length(rr)] <- rr[length(rr)]+1 object$rank <- rr # penalty ranks if (!need.con) object$C <- matrix(0,0,ncol(object$X)) ## no con object$df <- ncol(object$X) # -nrow(object$C) for (i in 1:length(sd$bc)) { sd$bc[[i]]$bsm <- sd$bc[[i]]$S <- NULL } object$sd <- sd class(object)<-"soap.film" # Give object a class object } ## end of full soap constructor smooth.construct.sf.smooth.spec<-function(object,data,knots) ## a soap film smooth boundary interpolating film only constructor ## method function for integration with mgcv::gam { if (is.null(knots)) stop("knots must be specified for soap") if (object$dim!=2) stop("soap films are bivariate only") x <- data[[object$term[1]]] y <- data[[object$term[2]]] knt <- list(x=knots[[object$term[1]]],y=knots[[object$term[2]]]) ## if (length(knt$x)<1) stop("need at least one interior knot") bnd <- object$xt$bnd if (is.null(bnd)) stop("can't soap smooth without a boundary") if (!inherits(bnd,"list")) stop("bnd must be a list of boundary loops") for (i in 1:length(bnd)) { ## re-lable boundary nm <- names(bnd[[i]]) ind <- nm==object$term[1] if (sum(ind)!=1) stop("faulty bnd") names(bnd[[i]])[ind] <- "x" ind <- nm==object$term[2] if (sum(ind)!=1) stop("faulty bnd") names(bnd[[i]])[ind] <- "y" } if (length(object$bs.dim)==1) k <- rep(object$bs.dim,length(bnd)) else { if (length(object$bs.dim)==length(bnd)) k <- object$bs.dim else stop("k and bnd lengths are inconsistent") } if (is.null(object$xt$nmax)) nmax <- 200 else nmax <- object$xt$nmax ## setup the soap defining structures sd <- setup.soap(bnd,knots=knt,nmax=nmax,k=k,bndSpec=object$xt$bndSpec) b <- soap.basis(sd,x,y,film=TRUE,wiggly=FALSE,penalty=TRUE) if (sum(is.na(b$X))>0) stop("data outside soap boundary") if (ncol(b$X)==0) stop("no free coefs in sf smooth") # b <- soap.construct(x,y,bnd,knots=knt,k=k,n.grid=n.grid,basis.type=2, # depth=depth,rel.eps=rel.eps,abs.eps=abs.eps,film=TRUE, # wiggly=FALSE,bndSpec=object$xt$bndSpec) ## get penalty null space for term ns.dim <- 0;n <- length(sd$bc) k <- 0 ## counter for b$S rr <- rep(0,length(b$S)) if (n>0) for (i in 1:n) if (sd$bc[[i]]$free.bound) { nsd <- sd$bc[[i]]$bsm$null.space.dim ns.dim <- ns.dim + nsd k <- k + 1 rr[k] <- ncol(b$S[[k]]) - nsd ## rank of b$S[[k]] } object$null.space.dim <- ns.dim object$rank <- rr # penalty ranks need.con <- TRUE for (i in 1:length(sd$bc)) if (!sd$bc[[i]]$free.bound) need.con <- FALSE ## rescale basis for nice conditioning.... irng <- 1/as.numeric(apply(b$X,2,max)-apply(b$X,2,min)) b$X <- t(t(b$X)*irng) ## now apply rescaling if (length(b$S)>0) for (i in 1:length(b$S)) { a <- irng[b$off[i]:(b$off[i]+ncol(b$S[[i]])-1)] b$S[[i]] <- diag(a)%*%b$S[[i]]%*%diag(a) } object$irng <- irng ## the column scaling factor object$X <- b$X ## model matrix attr(object$X,"offset") <- b$offset if (!object$fixed) { ## have to unpack a bit... S <- list();n <- ncol(object$X) if (length(b$S)>0) for (i in 1:length(b$S)) { S[[i]] <- matrix(0,n,n) m <- ncol(b$S[[i]]) ind <- b$off[i]:(b$off[i]+m-1) S[[i]][ind,ind] <- b$S[[i]] } object$S <- S ## penalties } if (!need.con) object$C <- matrix(0,0,ncol(object$X)) ## no con object$df <- ncol(object$X) # -nrow(object$C) for (i in 1:length(sd$bc)) { sd$bc[[i]]$bsm <- sd$bc[[i]]$S <- NULL } object$sd <- sd class(object)<-c("sf","soap.film") # Give object a class object } ## end of boundary film component soap constructor smooth.construct.sw.smooth.spec<-function(object,data,knots) ## a soap film smooth wiggly component only constructor method function for ## integration with mgcv::gam { if (is.null(knots)) stop("knots must be specified for soap") if (object$dim!=2) stop("soap films are bivariate only") x <- data[[object$term[1]]] y <- data[[object$term[2]]] knt <- list(x=knots[[object$term[1]]],y=knots[[object$term[2]]]) if (length(knt$x)<1) stop("need at least one interior knot") bnd <- object$xt$bnd if (is.null(bnd)) stop("can't soap smooth without a boundary") if (!inherits(bnd,"list")) stop("bnd must be a list of boundary loops") for (i in 1:length(bnd)) { ## re-lable boundary nm <- names(bnd[[i]]) ind <- nm==object$term[1] if (sum(ind)!=1) stop("faulty bnd") names(bnd[[i]])[ind] <- "x" ind <- nm==object$term[2] if (sum(ind)!=1) stop("faulty bnd") names(bnd[[i]])[ind] <- "y" } if (length(object$bs.dim)==1) k <- rep(object$bs.dim,length(bnd)) else { if (length(object$bs.dim)==length(bnd)) k <- object$bs.dim else stop("k and bnd lengths are inconsistent") } if (is.null(object$xt$nmax)) nmax <- 200 else nmax <- object$xt$nmax ## setup the soap defining structures sd <- setup.soap(bnd,knots=knt,nmax=nmax,k=k,bndSpec=object$xt$bndSpec) b <- soap.basis(sd,x,y,film=FALSE,wiggly=TRUE,penalty=TRUE) if (sum(is.na(b$X))>0) stop("data outside soap boundary") object$null.space.dim <- 0 ## penalty is full rank, for this case ## rescale basis for nice conditioning.... irng <- 1/as.numeric(apply(b$X,2,max)-apply(b$X,2,min)) b$X <- t(t(b$X)*irng) ## now apply rescaling for (i in 1:length(b$S)) { a <- irng[b$off[i]:(b$off[i]+ncol(b$S[[i]])-1)] b$S[[i]] <- diag(a)%*%b$S[[i]]%*%diag(a) } object$irng <- irng ## the column scaling factor object$X <- b$X ## model matrix if (!object$fixed) { ## have to unpack a bit... S <- list();n <- ncol(object$X) for (i in 1:length(b$S)) { S[[i]] <- matrix(0,n,n) m <- ncol(b$S[[i]]) ind <- b$off[i]:(b$off[i]+m-1) S[[i]][ind,ind] <- b$S[[i]] } object$S <- S ## penalties } rr <- ncol(b$S[[1]])-1 if (length(b$S)>1) for (i in 2:length(b$S)) rr <- c(rr,ncol(b$S[[i]])-1) rr[length(rr)] <- rr[length(rr)]+1 object$rank <- rr # penalty ranks object$df <- ncol(object$X) # -nrow(object$C) for (i in 1:length(sd$bc)) { sd$bc[[i]]$bsm <- sd$bc[[i]]$S <- NULL } object$sd <- sd object$C <- matrix(0,0,ncol(object$X)) ## this is tied to zero class(object)<-c("sw","soap.film") # Give object a class object } ## end of wiggly component of soap constructor Predict.matrix.soap.film<-function(object,data) # prediction method function for the soap.film smooth class { x <- get.var(object$term[1],data) y <- get.var(object$term[2],data) b <- soap.basis(object$sd,x,y,film=TRUE,wiggly=TRUE,penalty=FALSE) X <- t(object$irng*t(b$X)) attr(X,"offset") <- b$offset X } Predict.matrix.sf <- function(object,data) # prediction method function for the sf smooth class --- the boundary interpolating film # component of a soap film smooth { x <- get.var(object$term[1],data) y <- get.var(object$term[2],data) b <- soap.basis(object$sd,x,y,film=TRUE,wiggly=FALSE,penalty=FALSE) X <- t(object$irng*t(b$X)) attr(X,"offset") <- b$offset X } Predict.matrix.sw <- function(object,data) # prediction method function for the sw smooth class --- the wiggly # component of a soap film smooth { x <- get.var(object$term[1],data) y <- get.var(object$term[2],data) X <- soap.basis(object$sd,x,y,film=FALSE,wiggly=TRUE,penalty=FALSE)$X X <- t(object$irng*t(X)) X } plot.soap.film <- function(x,P=NULL,data=NULL,label="",se1.mult=1,se2.mult=2, partial.resids=FALSE,rug=TRUE,se=TRUE,scale=-1,n=100,n2=40, pers=FALSE,theta=30,phi=30,jit=FALSE,xlab=NULL,ylab=NULL,main=NULL, ylim=NULL,xlim=NULL,too.far=0.1,shade=FALSE,shade.col="gray80", shift=0,trans=I,by.resids=FALSE,scheme=0,hcolors=heat.colors(100), contour.col=1,...) { ## plot method function for soap.smooth terms if (scheme==3) { if (is.null(P)) outline <- FALSE else outline <- TRUE if (is.null(xlim)) xlim <- c(x$sd$x0,x$sd$x0+ncol(x$sd$G)*x$sd$dx) if (is.null(ylim)) ylim <- c(x$sd$y0,x$sd$y0+nrow(x$sd$G)*x$sd$dy) P0 <- plot.mgcv.smooth(x=x,P=P,data=data,label=label,se1.mult=se1.mult,se2.mult=se2.mult, partial.resids=partial.resids,rug=rug,se=se,scale=scale,n=n,n2=n2, pers=pers,theta=theta,phi=phi,jit=jit,xlab=xlab,ylab=ylab,main=main, ylim=ylim,xlim=xlim,too.far=too.far,shade=shade,shade.col=shade.col, shift=shift,trans=trans,by.resids=by.resids,hcolors=hcolors, ## don't pass scheme!! contour.col=contour.col,...) if (outline) { if (is.null(names(P$bnd))) { for (i in 1:length(P$bnd)) lines(P$bnd[[i]],lwd=2) } else lines(P$bnd,lwd=2) } else { P0$bnd <- x$sd$bnd} return(P0) } if (is.null(P)) { ## get plotting information... if (!x$plot.me) return(NULL) ## shouldn't or can't plot ## get basic plot data beta <- unconstrain(x,attr(x,"coefficients"))*x$irng ## coefs raw <- data[x$term] film <- wiggly <- TRUE if (inherits(x,"sw")) film <- FALSE else if (inherits(x,"sf")) wiggly <- FALSE soap.basis(x$sd,film=film,wiggly=wiggly,plot=TRUE,beta=beta) -> G if (is.null(xlab)) xlabel<- x$term[1] else xlabel <- xlab if (is.null(ylab)) ylabel <- x$term[2] else ylabel <- ylab xscale <- x$sd$x0 + 0:(nrow(G)-1) * x$sd$dx yscale <- x$sd$y0 + 0:(ncol(G)-1) * x$sd$dy main <- if (is.null(main)) label return(list(fit=G,scale=FALSE,se=FALSE,raw=raw,xlab=xlabel,ylab=ylabel, xscale=xscale,yscale=yscale,main=main,bnd=x$sd$bnd)) } else { ## do plot if (scheme==0) { xlim <- range(P$xscale);dx = xlim[2] - xlim[1] ylim <- range(P$yscale);dy = ylim[2] - ylim[1] plot(P$xscale[1],P$yscale[1],xlab=P$xlab,ylab=P$ylab,main=P$main,xlim=xlim,ylim=ylim,...) rect(xlim[1]-dx,ylim[1]-dy,xlim[2]+dx,ylim[2]+dy,col="lightgrey") image(P$xscale,P$yscale,P$fit,add=TRUE,col=hcolors,...) contour(P$xscale,P$yscale,P$fit,add=TRUE,col=contour.col,...) } else if (scheme==1) { image(P$xscale,P$yscale,P$fit,col=grey(0:50/50),xlab=P$xlab, ylab=P$ylab,main=P$main,...) contour(P$xscale,P$yscale,P$fit,add=TRUE,col=contour.col,...) } else if (scheme==2) { contour(P$xscale,P$yscale,P$fit,xlab=P$xlab, ylab=P$ylab,main=P$main,col=contour.col,...) if (is.null(names(P$bnd))) { for (i in 1:length(P$bnd)) lines(P$bnd[[i]],lwd=2) } else lines(P$bnd,lwd=2) } } } ## end plot.soap.smooth fs.test <- function(x,y,r0=.1,r=.5,l=3,b=1,exclude=TRUE) ## test function based on Tim Ramsay (2002) J.R.Statist. Soc. B ## 64(2):307-319 "Spline smoothing over difficult regions" { q <- pi*r/2 ## 1/2 length of semi-circle part of centre curve a <- d <- x*0 ## along and distance to arrays ## convert x,y to along curve and distance to curve (a,d) ## co-ordinates. 0 distance along is at (x=-r,y=0) ind <- x>=0 & y>0 a[ind] <- q + x[ind] d[ind] <- y[ind]-r ind <- x>=0 & y<=0 a[ind] <- -q - x[ind] d[ind] <- -r - y[ind] ind <- x < 0 a[ind] <- -atan(y[ind]/x[ind])*r d[ind] <- sqrt(x[ind]^2+y[ind]^2) - r ## create exclusion index ind <- abs(d)>r-r0 | (x>l & (x-l)^2+d^2 > (r-r0)^2) # f <- a*b # the original f <- a*b+d^2 if (exclude) f[ind] <- NA attr(f,"exclude") <- ind f } fs.boundary <- function(r0=.1,r=.5,l=3,n.theta=20) ## produce boundary file for fs.test { rr <- r+(r-r0) theta <- seq(pi,pi/2,length=n.theta) x <- rr*cos(theta); y <- rr*sin(theta) theta <- seq(pi/2,-pi/2,length=2*n.theta) x <- c(x,(r-r0)*cos(theta)+l); y <- c(y,(r-r0)*sin(theta)+r) theta <- seq(pi/2,pi,length=n.theta) x <- c(x,r0*cos(theta)); y <- c(y,r0*sin(theta)) n<-length(x) x <- c(x,x[n:1]);y <- c(y,-y[n:1]) return(list(x=x,y=y)) } mgcv/R/fast-REML.r0000644000177400001440000014361413044332500013461 0ustar murdochusers## code for fast REML computation. key feature is that first and ## second derivatives come at no increase in leading order ## computational cost, relative to evaluation! ## (c) Simon N. Wood, 2010-2016 Sl.setup <- function(G) { ## Sets up a list representing a block diagonal penalty matrix. ## from the object produced by `gam.setup'. ## Return object is a list, Sl, with an element for each block. ## For block, b, Sl[[b]] is a list with the following elements ## * repara - should re-parameterization be applied to model matrix etc ## usually false if non-linear in coefs ## * start, stop: start:stop indexes the parameters of this block ## * S a list of penalty matrices for the block (dim = stop-start+1) ## - If length(S)==1 then this will be an identity penalty. ## - Otherwise it is a multiple penalty, and an rS list of square ## root penalty matrices will be added. S (if repara) and rS (always) ## will be projected into range space of total penalty matrix. ## * rS sqrt penalty matrices if it's a multiple penalty. ## * D a reparameterization matrix for the block ## - Applies to cols/params from start:stop. ## - If numeric then X[,start:stop]%*%diag(D) is repara X[,start:stop], ## b.orig = D*b.repara ## - If matrix then X[,start:stop]%*%D is repara X[,start:stop], ## b.orig = D%*%b.repara ## The penalties in Sl are in the same order as those in G ## Also returns attribute "E" a square root of the well scaled total ## penalty, suitable for rank deficiency testing, and attribute "lambda" ## the corresponding smoothing parameters. ##if (!is.null(G$H)) stop("paraPen min sp not supported") Sl <- list() b <- 1 ## block counter if (G$n.paraPen) { ## Have to proccess paraPen stuff first off <- unique(G$off[1:G$n.paraPen]) ## unique offset lists relating to paraPen for (i in 1:length(off)) { ## loop over blocks ind <- (1:G$n.paraPen)[G$off[1:G$n.paraPen]%in%off[i]] ## terms in same block if (length(ind)>1) { ## additive block nr <- 0;for (k in 1:length(ind)) nr <- max(nr,nrow(G$S[[ind[k]]])) ## get block size ## now fill Sl[[b]]$S, padding out any penalties that are not "full size" Sl[[b]] <- list() Sl[[b]]$S <- list() St <- matrix(0,nr,nr) ## accumulate a total matrix for rank determination for (k in 1:length(ind)) { ## work through all penalties for this block nk <- nrow(G$S[[ind[k]]]) if (nr>nk) { ## have to pad out this one Sl[[b]]$S[[k]] <- matrix(0,nr,nr) Sl[[b]]$S[[k]][1:nk,1:nk] <- G$S[[ind[k]]] } else Sl[[b]]$S[[k]] <- G$S[[ind[[k]]]] St <- St + Sl[[b]]$S[[k]] } Sl[[b]]$start <- off[ind[1]] Sl[[b]]$stop <- Sl[[b]]$start + nr - 1 Sl[[b]]$lambda <- rep(1,length(ind)) ## dummy at this stage } else { ## singleton Sl[[b]] <- list(start=off[ind], stop=off[ind]+nrow(G$S[[ind]])-1, rank=G$rank[ind],S=list(G$S[[ind]])) Sl[[b]]$S <- list(G$S[[ind]]) Sl[[b]]$lambda <- 1 ## dummy at this stage } ## finished singleton b <- b + 1 } ## finished this block } ## finished paraPen ## now work through the smooths.... if (length(G$smooth)) for (i in 1:length(G$smooth)) { if (!is.null(G$smooth[[i]]$fixed)&&G$smooth[[i]]$fixed) m <- 0 else m <- length(G$smooth[[i]]$S) if (m>0) { Sl[[b]] <- list() Sl[[b]]$start <- G$smooth[[i]]$first.para Sl[[b]]$stop <- G$smooth[[i]]$last.para ## if the smooth has a g.index field it indicates non-linear params, ## in which case re-parameterization will usually break the model! Sl[[b]]$repara <- if (is.null(G$smooth[[i]]$g.index)) TRUE else FALSE } if (m==0) {} else ## fixed block if (m==1) { ## singleton Sl[[b]]$rank <- G$smooth[[i]]$rank Sl[[b]]$S <- G$smooth[[i]]$S Sl[[b]]$lambda <- 1 b <- b + 1 } else { ## additive block... ## first test whether block can *easily* be split up into singletons ## easily here means no overlap in penalties Sl[[b]]$S <- G$smooth[[i]]$S Sl[[b]]$lambda <- rep(1,m) nb <- nrow(Sl[[b]]$S[[1]]) sbdiag <- sbStart <- sbStop <- rep(NA,m) ut <- upper.tri(Sl[[b]]$S[[1]],diag=FALSE) ## overlap testing requires the block ranges for (j in 1:m) { ## get block range for each S[[j]] sbdiag[j] <- sum(abs(Sl[[b]]$S[[j]][ut]))==0 ## is penalty diagonal?? ir <- range((1:nb)[rowSums(abs(Sl[[b]]$S[[j]]))>0]) sbStart[j] <- ir[1];sbStop[j] <- ir[2] ## individual ranges } split.ok <- TRUE for (j in 1:m) { ## test for overlap itot <- rep(FALSE,nb) if (all(sbdiag)) { ## it's all diagonal - can allow interleaving for (k in 1:m) if (j!=k) itot[diag(Sl[[b]]$S[[k]])!=0] <- TRUE if (sum(itot[diag(Sl[[b]]$S[[j]])!=0])>0) { ## no good, some overlap detected split.ok <- FALSE; break } } else { ## not diagonal - really need on overlapping blocks for (k in 1:m) if (j!=k) itot[sbStart[k]:sbStop[k]] <- TRUE if (sum(itot[sbStart[j]:sbStop[j]])>0) { ## no good, some overlap detected split.ok <- FALSE; break } } } if (split.ok) { ## can split this block into m separate singleton blocks for (j in 1:m) { Sl[[b]] <- list() ind <- sbStart[j]:sbStop[j] Sl[[b]]$S <- list(G$smooth[[i]]$S[[j]][ind,ind,drop=FALSE]) Sl[[b]]$start <- G$smooth[[i]]$first.para + sbStart[j]-1 Sl[[b]]$stop <- G$smooth[[i]]$first.para + sbStop[j]-1 Sl[[b]]$rank <- G$smooth[[i]]$rank[j] Sl[[b]]$repara <- TRUE ## signals ok to linearly reparameterize if (!is.null(G$smooth[[i]]$g.index)) { ## then some parameters are non-linear - can't re-param if (any(G$smooth[[i]]$g.index[ind])) Sl[[b]]$repara <- FALSE } b <- b + 1 } } else { ## not possible to split Sl[[b]]$S <- G$smooth[[i]]$S b <- b + 1 ## next block!! } ## additive block finished } ## additive block finished } ## At this stage Sl contains the penalties, identified as singletons or ## multiple S blocks. Now the blocks need re-parameterization applied. ## Singletons need to be transformed to identity penalties, while ## multiples need to be projected into total penalty range space. if (length(Sl)==0) return(Sl) ## nothing to do np <- ncol(G$X) E <- matrix(0,np,np) ## well scaled square root penalty lambda <- rep(0,0) for (b in 1:length(Sl)) { ## once more into the blocks, dear friends... if (length(Sl[[b]]$S)==1) { ## then we have a singleton if (sum(abs(Sl[[b]]$S[[1]][upper.tri(Sl[[b]]$S[[1]],diag=FALSE)]))==0) { ## S diagonal ## Reparameterize so that S has 1's or zero's on diagonal ## In new parameterization smooth specific model matrix is X%*%diag(D) ## ind indexes penalized parameters from this smooth's set. D <- diag(Sl[[b]]$S[[1]]) ind <- D > 0 ## index penalized elements D[ind] <- 1/sqrt(D[ind]);D[!ind] <- 1 ## X' = X%*%diag(D) Sl[[b]]$D <- D; Sl[[b]]$ind <- ind } else { ## S is not diagonal es <- eigen(Sl[[b]]$S[[1]],symmetric=TRUE) U <- es$vectors;D <- es$values if (is.null(Sl[[b]]$rank)) { ## need to estimate rank Sl[[b]]$rank <- sum(D>.Machine$double.eps^.8*max(D)) } ind <- rep(FALSE,length(D)) ind[1:Sl[[b]]$rank] <- TRUE ## index penalized elements D[ind] <- 1/sqrt(D[ind]);D[!ind] <- 1 Sl[[b]]$D <- t(D*t(U)) ## D <- U%*%diag(D) Sl[[b]]$Di <- t(U)/D ## so if X is smooth model matrix X%*%D is re-parameterized form ## crossprod(Sl[[b]]$Di[1:Sl[[b]]$rank]) is the original penalty Sl[[b]]$ind <- ind } ## add penalty square root into E if (Sl[[b]]$repara) { ## then it is just the identity ind <- (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind] diag(E)[ind] <- 1 lambda <- c(lambda,1) ## record corresponding lambda } else { ## need scaled root penalty in *original* parameterization D <- Sl[[b]]$Di[1:Sl[[b]]$rank,] D.norm <- norm(D); D <- D/D.norm indc <- Sl[[b]]$start:(Sl[[b]]$start+ncol(D)-1) indr <- Sl[[b]]$start:(Sl[[b]]$start+nrow(D)-1) E[indr,indc] <- D lambda <- c(lambda,1/D.norm^2) } } else { ## multiple S block ## must be in range space of total penalty... Sl[[b]]$rS <- list() ## needed for adaptive re-parameterization S <- Sl[[b]]$S[[1]] for (j in 2:length(Sl[[b]]$S)) S <- S + Sl[[b]]$S[[j]] ## scaled total penalty es <- eigen(S,symmetric=TRUE);U <- es$vectors; D <- es$values Sl[[b]]$D <- U if (is.null(Sl[[b]]$rank)) { ## need to estimate rank Sl[[b]]$rank <- sum(D>.Machine$double.eps^.8*max(D)) } ind <- 1:Sl[[b]]$rank for (j in 1:length(Sl[[b]]$S)) { ## project penalties into range space of total penalty bob <- t(U[,ind])%*%Sl[[b]]$S[[j]]%*%U[,ind] bob <- (t(bob) + bob)/2 ## avoid over-zealous chol sym check if (Sl[[b]]$repara) { ## otherwise want St and E in original parameterization Sl[[b]]$S[[j]] <- bob } Sl[[b]]$rS[[j]] <- mroot(bob,Sl[[b]]$rank) } Sl[[b]]$ind <- rep(FALSE,ncol(U)) Sl[[b]]$ind[ind] <- TRUE ## index penalized within sub-range ## now compute well scaled sqrt S.norm <- norm(Sl[[b]]$S[[1]]) St <- Sl[[b]]$S[[1]]/S.norm lambda <- c(lambda,1/S.norm) for (j in 2:length(Sl[[b]]$S)) { S.norm <- norm(Sl[[b]]$S[[1]]) St <- St + Sl[[b]]$S[[j]]/S.norm lambda <- c(lambda,1/S.norm) } St <- (t(St) + St)/2 ## avoid over-zealous chol sym check St <- t(mroot(St,Sl[[b]]$rank)) indc <- Sl[[b]]$start:(Sl[[b]]$start+ncol(St)-1) indr <- Sl[[b]]$start:(Sl[[b]]$start+nrow(St)-1) E[indr,indc] <- St } } ## re-para finished attr(Sl,"E") <- E ## E'E = scaled total penalty attr(Sl,"lambda") <- lambda ## smoothing parameters corresponding to E Sl ## the penalty list } ## end of Sl.setup Sl.initial.repara <- function(Sl,X,inverse=FALSE,both.sides=TRUE,cov=TRUE,nt=1) { ## Routine to apply initial Sl re-parameterization to model matrix X, ## or, if inverse==TRUE, to apply inverse re-para to parameter vector ## or cov matrix. if inverse is TRUE and both.sides=FALSE then ## re-para only applied to rhs, as appropriate for a choleski factor. ## If both.sides==FALSE, X is a vector and inverse==FALSE then X is ## taken as a coefficient vector (so re-para is inverse of that for model ## matrix...) if (length(Sl)==0) return(X) ## nothing to do if (inverse) { ## apply inverse re-para if (is.matrix(X)) { if (cov) { ## then it's a covariance matrix for (b in 1:length(Sl)) if (Sl[[b]]$repara) { ind <- Sl[[b]]$start:Sl[[b]]$stop if (is.matrix(Sl[[b]]$D)) { if (both.sides) X[ind,] <- if (nt==1) Sl[[b]]$D%*%X[ind,,drop=FALSE] else pmmult(Sl[[b]]$D,X[ind,,drop=FALSE],FALSE,FALSE,nt=nt) X[,ind] <- if (nt==1) X[,ind,drop=FALSE]%*%t(Sl[[b]]$D) else pmmult(X[,ind,drop=FALSE],Sl[[b]]$D,FALSE,TRUE,nt=nt) } else { ## Diagonal D X[,ind] <- t(Sl[[b]]$D * t(X[,ind,drop=FALSE])) if (both.sides) X[ind,] <- Sl[[b]]$D * X[ind,,drop=FALSE] } } } else { ## regular matrix: need to use Di for (b in 1:length(Sl)) if (Sl[[b]]$repara) { ind <- Sl[[b]]$start:Sl[[b]]$stop if (is.matrix(Sl[[b]]$D)) { Di <- if(is.null(Sl[[b]]$Di)) t(Sl[[b]]$D) else Sl[[b]]$Di if (both.sides) X[ind,] <- if (nt==1) t(Di)%*%X[ind,,drop=FALSE] else pmmult(Di,X[ind,,drop=FALSE],TRUE,FALSE,nt=nt) X[,ind] <- if (nt==1) X[,ind,drop=FALSE]%*%Di else pmmult(X[,ind,drop=FALSE],Di,FALSE,FALSE,nt=nt) } else { ## Diagonal D Di <- 1/Sl[[b]]$D X[,ind] <- t(Di * t(X[,ind,drop=FALSE])) if (both.sides) X[ind,] <- Di * X[ind,,drop=FALSE] } } } } else { ## it's a parameter vector for (b in 1:length(Sl)) if (Sl[[b]]$repara) { ind <- Sl[[b]]$start:Sl[[b]]$stop if (is.matrix(Sl[[b]]$D)) X[ind] <- Sl[[b]]$D%*%X[ind] else X[ind] <- Sl[[b]]$D*X[ind] } } } else for (b in 1:length(Sl)) if (Sl[[b]]$repara) { ## model matrix re-para ind <- Sl[[b]]$start:Sl[[b]]$stop if (is.matrix(X)) { if (is.matrix(Sl[[b]]$D)) { if (both.sides) X[ind,] <- if (nt==1) t(Sl[[b]]$D)%*%X[ind,,drop=FALSE] else pmmult(Sl[[b]]$D,X[ind,,drop=FALSE],TRUE,FALSE,nt=nt) X[,ind] <- if (nt==1) X[,ind,drop=FALSE]%*%Sl[[b]]$D else pmmult(X[,ind,drop=FALSE],Sl[[b]]$D,FALSE,FALSE,nt=nt) } else { if (both.sides) X[ind,] <- Sl[[b]]$D * X[ind,,drop=FALSE] X[,ind] <- t(Sl[[b]]$D*t(X[,ind,drop=FALSE])) ## X[,ind]%*%diag(Sl[[b]]$D) } } else { if (both.sides) { ## signalling vector to be treated like model matrix X... if (is.matrix(Sl[[b]]$D)) X[ind] <- t(Sl[[b]]$D)%*%X[ind] else X[ind] <- Sl[[b]]$D*X[ind] } else { ## both.sides == FALSE is just a signal that X is a parameter vector if (is.matrix(Sl[[b]]$D)) X[ind] <- if (is.null(Sl[[b]]$Di)) t(Sl[[b]]$D)%*%X[ind] else Sl[[b]]$Di%*%X[ind] else X[ind] <- X[ind]/Sl[[b]]$D } } } X } ## end Sl.initial.repara ldetSblock <- function(rS,rho,deriv=2,root=FALSE,nt=1) { ## finds derivatives wrt rho of log|S| where ## S = sum_i tcrossprod(rS[[i]]*exp(rho[i])) ## when S is full rank +ve def and no ## reparameterization is required.... lam <- exp(rho) S <- pcrossprod(rS[[1]],trans=TRUE,nt=nt)*lam[1] ##tcrossprod(rS[[1]])*lam[1] ## parallel p <- ncol(S) m <- length(rS) if (m > 1) for (i in 2:m) S <- S + pcrossprod(rS[[i]],trans=TRUE,nt=nt)*lam[i] ## S <- S + tcrossprod(rS[[i]])*lam[i] ## parallel if (!root) E <- S d <- diag(S);d[d<=0] <- 1;d <- sqrt(d) S <- t(S/d)/d ## diagonally pre-condition R <- if (nt>1) pchol(S,nt) else suppressWarnings(chol(S,pivot=TRUE)) piv <- attr(R,"pivot") r <- attr(R,"rank") if (r0) { ## then not all sp's are fixed dind <- k.deriv:(k.deriv+nd-1) d1.ldS[dind] <- grp$det1 d2.ldS[dind,dind] <- grp$det2 k.deriv <- k.deriv + nd } ## now store the reparameterization information if (repara) { rp[[k.rp]] <- list(block =b,ind = (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind],Qs = grp$Qs,repara=Sl[[b]]$repara) k.rp <- k.rp + 1 for (i in 1:m) { Sl[[b]]$Srp[[i]] <- Sl[[b]]$lambda[i]*grp$rS[[i]]%*%t(grp$rS[[i]]) } } k.sp <- k.sp + m if (Sl[[b]]$repara) { if (root) { ## unpack the square root E'E ic <- Sl[[b]]$start:(Sl[[b]]$start+ncol(grp$E)-1) ir <- Sl[[b]]$start:(Sl[[b]]$start+nrow(grp$E)-1) E[ir,ic] <- grp$E Sl[[b]]$St <- crossprod(grp$E) } else { ## gam.reparam always returns root penalty in E, but ## ldetSblock returns penalty in E if root==FALSE Sl[[b]]$St <- if (repara) crossprod(grp$E) else grp$E } } else { ## square root block and St need to be in original parameterization... Sl[[b]]$St <- Sl[[b]]$lambda[1]*Sl[[b]]$S[[1]] for (i in 2:m) { Sl[[b]]$St <- Sl[[b]]$St + Sl[[b]]$lambda[i]*Sl[[b]]$S[[i]] } if (root) { Eb <- t(mroot(Sl[[b]]$St,Sl[[b]]$rank)) indc <- Sl[[b]]$start:(Sl[[b]]$start+ncol(Eb)-1) indr <- Sl[[b]]$start:(Sl[[b]]$start+nrow(Eb)-1) E[indr,indc] <- Eb } } } ## end of multi-S block branch } ## end of block loop if (root) E <- E[rowSums(abs(E))!=0,,drop=FALSE] ## drop zero rows. list(ldetS=ldS,ldet1=d1.ldS,ldet2=d2.ldS,Sl=Sl,rp=rp,E=E) } ## end ldetS Sl.addS <- function(Sl,A,rho) { ## Routine to add total penalty to matrix A. Sl is smooth penalty ## list from Sl.setup, so initial reparameterizations have taken place, ## and should have already been applied to A using Sl.initial.repara k <- 1 for (b in 1:length(Sl)) { ind <- (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind] if (length(Sl[[b]]$S)==1) { ## singleton diag(A)[ind] <- diag(A)[ind] + exp(rho[k]) ## penalty is identity times sp k <- k + 1 } else { for (j in 1:length(Sl[[b]]$S)) { A[ind,ind] <- A[ind,ind] + exp(rho[k]) * Sl[[b]]$S[[j]] k <- k + 1 } } } A } ## Sl.addS Sl.repara <- function(rp,X,inverse=FALSE,both.sides=TRUE) { ## Apply re-parameterization from ldetS to X, blockwise. ## If X is a matrix it is assumed to be a model matrix ## whereas if X is a vector it is assumed to be a parameter vector. ## If inverse==TRUE applies the inverse of the re-para to ## parameter vector X or cov matrix X... nr <- length(rp);if (nr==0) return(X) if (inverse) { if (is.matrix(X)) { ## X is a cov matrix for (i in 1:nr) if (rp[[i]]$repara) { if (both.sides) X[rp[[i]]$ind,] <- rp[[i]]$Qs %*% X[rp[[i]]$ind,,drop=FALSE] X[,rp[[i]]$ind] <- X[,rp[[i]]$ind,drop=FALSE] %*% t(rp[[i]]$Qs) } } else { ## X is a vector for (i in 1:nr) if (rp[[i]]$repara) X[rp[[i]]$ind] <- rp[[i]]$Qs %*% X[rp[[i]]$ind] } } else { ## apply re-para to X if (is.matrix(X)) { for (i in 1:nr) if (rp[[i]]$repara) X[,rp[[i]]$ind] <- X[,rp[[i]]$ind]%*%rp[[i]]$Qs } else { for (i in 1:nr) if (rp[[i]]$repara) X[rp[[i]]$ind] <- t(rp[[i]]$Qs) %*% X[rp[[i]]$ind] } } X } ## end Sl.repara Sl.mult <- function(Sl,A,k = 0,full=TRUE) { ## Sl contains the blocks of block diagonal penalty S. ## If k<=0 this routine forms S%*%A. ## If k>0 then the routine forms S_k%*%A, zero padded ## if full==TRUE, but in smallest number of rows form otherwise. nb <- length(Sl) ## number of blocks Amat <- is.matrix(A) if (k<=0) { ## apply whole penalty B <- A*0 for (b in 1:nb) { ## block loop if (length(Sl[[b]]$S)==1) { ## singleton ind <- Sl[[b]]$start:Sl[[b]]$stop if (Sl[[b]]$repara) { ind <- ind[Sl[[b]]$ind] if (Amat) B[ind,] <- Sl[[b]]$lambda*A[ind,] else B[ind] <- Sl[[b]]$lambda*A[ind] } else { ## original penalty has to be applied if (Amat) B[ind,] <- Sl[[b]]$lambda*Sl[[b]]$S[[1]] %*% A[ind,] else B[ind] <- Sl[[b]]$lambda*Sl[[b]]$S[[1]] %*% A[ind] } } else { ## multi-S block ind <- (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind] if (Amat) B[ind,] <- Sl[[b]]$St %*% A[ind,] else B[ind] <- Sl[[b]]$St %*% A[ind] } } ## end of block loop A <- B } else { ## single penalty matrix selected j <- 0 ## S counter for (b in 1:nb) { ## block loop for (i in 1:length(Sl[[b]]$S)) { ## S loop within blocks j <- j + 1 if (j==k) { ## found block if (length(Sl[[b]]$S)==1) { ## singleton ind <- Sl[[b]]$start:Sl[[b]]$stop if (Sl[[b]]$repara) { ind <- ind[Sl[[b]]$ind] if (full) { ## return zero answer with all zeroes in place B <- A*0 if (Amat) B[ind,] <- Sl[[b]]$lambda*A[ind,] else B[ind] <- Sl[[b]]$lambda*A[ind] A <- B } else { ## strip zero rows from answer if (Amat) A <- Sl[[b]]$lambda*A[ind,] else A <- as.numeric(Sl[[b]]$lambda*A[ind]) } } else { ## not reparamterized version if (full) { B <- A*0 if (Amat) B[ind,] <- Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind,] else B[ind] <- Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind] A <- B } else { if (Amat) A <- Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind,] else A <- as.numeric(Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind]) } } ## not repara } else { ## multi-S block ind <- if (Sl[[b]]$repara) (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind] else Sl[[b]]$start:Sl[[b]]$stop if (full) { ## return zero answer with all zeroes in place B <- A*0 if (Amat) { B[ind,] <- if (is.null(Sl[[b]]$Srp)||!Sl[[b]]$repara) Sl[[b]]$lambda[i]*(Sl[[b]]$S[[i]]%*%A[ind,]) else Sl[[b]]$Srp[[i]]%*%A[ind,] } else { B[ind] <- if (is.null(Sl[[b]]$Srp)||!Sl[[b]]$repara) Sl[[b]]$lambda[i]*(Sl[[b]]$S[[i]]%*%A[ind]) else Sl[[b]]$Srp[[i]]%*%A[ind] } A <- B } else { ## strip zero rows from answer if (is.null(Sl[[b]]$Srp)||!Sl[[b]]$repara) { A <- if (Amat) Sl[[b]]$lambda[i]*(Sl[[b]]$S[[i]]%*%A[ind,]) else Sl[[b]]$lambda[i]*as.numeric(Sl[[b]]$S[[i]]%*%A[ind]) } else { A <- if (Amat) Sl[[b]]$Srp[[i]]%*%A[ind,] else as.numeric(Sl[[b]]$Srp[[i]]%*%A[ind]) } } } break } } ## end of S loop if (j==k) break } ## end of block loop } A } ## end Sl.mult Sl.termMult <- function(Sl,A,full=FALSE,nt=1) { ## returns a list containing the product of each element S of Sl ## with A. If full==TRUE then the results include the zero rows ## otherwise these are stripped out, but in that case each element ## of the return object contains an "ind" attribute, indicating ## which rows of the full matrix it relates to. Amat <- is.matrix(A) SA <- list() k <- 0 ## component counter nb <- length(Sl) ## number of blocks for (b in 1:nb) { ## block loop if (length(Sl[[b]]$S)==1) { ## singleton k <- k + 1 ind <- Sl[[b]]$start:Sl[[b]]$stop if (Sl[[b]]$repara) { ind <- ind[Sl[[b]]$ind] if (full) { ## return zero answer with all zeroes in place B <- A*0 if (Amat) B[ind,] <- Sl[[b]]$lambda*A[ind,,drop=FALSE] else B[ind] <- Sl[[b]]$lambda*A[ind] SA[[k]] <- B } else { ## strip zero rows from answer if (Amat) SA[[k]] <- Sl[[b]]$lambda*A[ind,,drop=FALSE] else SA[[k]] <- as.numeric(Sl[[b]]$lambda*A[ind]) attr(SA[[k]],"ind") <- ind } } else { if (full) { ## return zero answer with all zeroes in place B <- A*0 if (Amat) B[ind,] <- Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind,,drop=FALSE] else B[ind] <- Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind] SA[[k]] <- B } else { ## strip zero rows from answer if (Amat) SA[[k]] <- Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind,,drop=FALSE] else SA[[k]] <- as.numeric(Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind]) attr(SA[[k]],"ind") <- ind } } } else { ## multi-S block ind <- if (Sl[[b]]$repara) (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind] else Sl[[b]]$start:Sl[[b]]$stop for (i in 1:length(Sl[[b]]$S)) { ## work through S terms k <- k + 1 if (full) { ## return answer with all zeroes in place B <- A*0 if (is.null(Sl[[b]]$Srp)||!Sl[[b]]$repara) { if (Amat) { B[ind,] <- if (nt==1) Sl[[b]]$lambda[i]*(Sl[[b]]$S[[i]]%*%A[ind,,drop=FALSE]) else Sl[[b]]$lambda[i]*pmmult(Sl[[b]]$S[[i]],A[ind,,drop=FALSE],nt=nt) } else B[ind] <- Sl[[b]]$lambda[i]*(Sl[[b]]$S[[i]]%*%A[ind]) } else { if (Amat) { B[ind,] <- if (nt==1) Sl[[b]]$Srp[[i]]%*%A[ind,,drop=FALSE] else pmmult(Sl[[b]]$Srp[[i]],A[ind,,drop=FALSE],nt=nt) } else B[ind] <- Sl[[b]]$Srp[[i]]%*%A[ind] } SA[[k]] <- B } else { ## strip zero rows from answer if (is.null(Sl[[b]]$Srp)||!Sl[[b]]$repara) { if (Amat) { SA[[k]] <- if (nt==1) Sl[[b]]$lambda[i]*(Sl[[b]]$S[[i]]%*%A[ind,,drop=FALSE]) else Sl[[b]]$lambda[i]*pmmult(Sl[[b]]$S[[i]],A[ind,,drop=FALSE],nt=nt) } else SA[[k]] <- Sl[[b]]$lambda[i]*as.numeric(Sl[[b]]$S[[i]]%*%A[ind]) } else { if (Amat) { SA[[k]] <- if (nt==1) Sl[[b]]$Srp[[i]]%*%A[ind,,drop=FALSE] else pmmult(Sl[[b]]$Srp[[i]],A[ind,,drop=FALSE],nt=nt) } else SA[[k]] <- as.numeric(Sl[[b]]$Srp[[i]]%*%A[ind]) } attr(SA[[k]],"ind") <- ind } } ## end of S loop for block b } } ## end block loop SA } ## end Sl.termMult d.detXXS <- function(Sl,PP,nt=1) { ## function to obtain derivatives of log |X'X+S| given unpivoted PP' where ## P is inverse of R from the QR of the augmented model matrix. SPP <- Sl.termMult(Sl,PP,full=FALSE,nt=nt) ## SPP[[k]] is S_k PP' nd <- length(SPP) d1 <- rep(0,nd);d2 <- matrix(0,nd,nd) for (i in 1:nd) { indi <- attr(SPP[[i]],"ind") d1[i] <- sum(diag(SPP[[i]][,indi,drop=FALSE])) for (j in i:nd) { indj <- attr(SPP[[j]],"ind") d2[i,j] <- d2[j,i] <- -sum(t(SPP[[i]][,indj,drop=FALSE])*SPP[[j]][,indi,drop=FALSE]) } d2[i,i] <- d2[i,i] + d1[i] } list(d1=d1,d2=d2) } ## end d.detXXS Sl.ift <- function(Sl,R,X,y,beta,piv,rp) { ## function to obtain derviatives of \hat \beta by implicit differentiation ## and to use these directly to evaluate derivs of b'Sb and the RSS. ## piv and rp are the pivots and inverse pivots from the qr that produced R. ## rssj and bSbj only contain the terms that will not cancel in rssj + bSbj beta <- beta[rp] ## unpivot Sb <- Sl.mult(Sl,beta,k = 0) ## unpivoted Skb <- Sl.termMult(Sl,beta,full=TRUE) ## unpivoted rsd <- (X%*%beta - y) #Xrsd <- t(X)%*%rsd ## X'Xbeta - X'y nd <- length(Skb) np <- length(beta) db <- matrix(0,np,nd) rss1 <- bSb1 <- rep(0,nd) for (i in 1:nd) { ## compute the first derivatives db[,i] <- -backsolve(R,forwardsolve(t(R),Skb[[i]][piv]))[rp] ## d beta/ d rho_i ## rss1[i] <- 0* 2 * sum(db[,i]*Xrsd) ## d rss / d rho_i bSb1[i] <- sum(beta*Skb[[i]]) ## + 2 * sum(db[,i]*Sb) ## d b'Sb / d_rho_i } XX.db <- t(X)%*%(X%*%db) S.db <- Sl.mult(Sl,db,k=0) ## Sk.db <- Sl.termMult(Sl,db,full=TRUE) ## Sk.db[[j]][,k] is S_j d beta / d rho_k rss2 <- bSb2 <- matrix(0,nd,nd) for (k in 1:nd) { ## second derivative loop for (j in k:nd) { ## d2b <- (k==j)*db[,k] - backsolve(R,forwardsolve(t(R),Sk.db[[j]][piv,k]+Sk.db[[k]][piv,j]))[rp] rss2[j,k] <- rss2[k,j] <- 2 * sum(db[,j]*XX.db[,k]) ## + 2 * sum(d2b*Xrsd) bSb2[j,k] <- bSb2[k,j] <- (k==j)*sum(beta*Skb[[k]]) + 2*(sum(db[,k]*(Skb[[j]]+S.db[,j])) + sum(db[,j]*Skb[[k]])) ## + 2 * (sum(d2b*Sb) } } list(bSb=sum(beta*Sb),bSb1=bSb1,bSb2=bSb2,d1b=db,rss =sum(rsd^2),rss1=rss1,rss2=rss2) } ## end Sl.ift Sl.iftChol <- function(Sl,XX,R,d,beta,piv) { ## function to obtain derviatives of \hat \beta by implicit differentiation ## and to use these directly to evaluate derivs of b'Sb and the RSS. ## piv contains the pivots from the chol that produced R. ## rssj and bSbj only contain the terms that will not cancel in rssj + bSbj Sb <- Sl.mult(Sl,beta,k = 0) ## unpivoted Skb <- Sl.termMult(Sl,beta,full=TRUE) ## unpivoted nd <- length(Skb) np <- length(beta) db <- matrix(0,np,nd) rss1 <- bSb1 <- rep(0,nd) for (i in 1:nd) { ## compute the first derivatives db[piv,i] <- -backsolve(R,forwardsolve(t(R),Skb[[i]][piv]/d[piv]))/d[piv] ## d beta/ d rho_i bSb1[i] <- sum(beta*Skb[[i]]) ## d b'Sb / d_rho_i } XX.db <- XX%*%db #XX.db[piv,] <- d[piv]*(t(R)%*%(R%*%(d[piv]*db[piv,]))) ## X'Xdb S.db <- Sl.mult(Sl,db,k=0) ##Sk.db <- Sl.termMult(Sl,db,full=TRUE) ## Sk.db[[j]][,k] is S_j d beta / d rho_k rss2 <- bSb2 <- matrix(0,nd,nd) for (k in 1:nd) { ## second derivative loop for (j in k:nd) { rss2[j,k] <- rss2[k,j] <- 2 * sum(db[,j]*XX.db[,k]) bSb2[j,k] <- bSb2[k,j] <- (k==j)*sum(beta*Skb[[k]]) + 2*(sum(db[,k]*(Skb[[j]]+S.db[,j])) + sum(db[,j]*Skb[[k]])) } } list(bSb=sum(beta*Sb),bSb1=bSb1,bSb2=bSb2, d1b=db ## BUG - this needs transforming as coef - here, or where used ,rss1=rss1,rss2=rss2) } ## end Sl.iftChol Sl.fitChol <- function(Sl,XX,f,rho,yy=0,L=NULL,rho0=0,log.phi=0,phi.fixed=TRUE,nobs=0,Mp=0,nt=1,tol=0) { ## given X'WX in XX and f=X'Wy solves the penalized least squares problem ## with penalty defined by Sl and rho, and evaluates a REML Newton step, the REML ## gradiant and the the estimated coefs bhat. If phi.fixed=FALSE then we need ## yy = y'Wy in order to get derivsatives w.r.t. phi. rho <- if (is.null(L)) rho + rho0 else L%*%rho + rho0 if (length(rho)1) pchol(t(XXp/d)/d,nt) else suppressWarnings(chol(t(XXp/d)/d,pivot=TRUE)) r <- min(attr(R,"rank"),Rrank(R)) p <- ncol(XXp) piv <- attr(R,"pivot") #;rp[rp] <- 1:p if (r tol)|(abs(diag(reml2))>tol) hess <- reml2 grad <- reml1 if (length(grad)>0) { if (sum(uconv.ind)!=ncol(reml2)) { reml1 <- reml1[uconv.ind] reml2 <- reml2[uconv.ind,uconv.ind] } er <- eigen(reml2,symmetric=TRUE) er$values <- abs(er$values) me <- max(er$values)*.Machine$double.eps^.5 er$values[er$values4) step <- 4*step/ms } else step <- 0 ## return the coefficient estimate, the reml grad and the Newton step... list(beta=beta,grad=grad,step=step,db=dift$d1b,PP=PP,R=R,piv=piv,rank=r, hess=hess,ldetS=ldS$ldetS,ldetXXS=ldetXXS) } ## Sl.fitChol Sl.fit <- function(Sl,X,y,rho,fixed,log.phi=0,phi.fixed=TRUE,rss.extra=0,nobs=NULL,Mp=0,nt=1) { ## fits penalized regression model with model matrix X and ## initialised block diagonal penalty Sl to data in y, given ## log smoothing parameters rho. ## Returns coefs, reml score + grad and Hessian. np <- ncol(X) ## number of parameters n <- nrow(X) phi <- exp(log.phi) if (is.null(nobs)) nobs <- n ## get log|S|_+ stably... ldS <- ldetS(Sl,rho,fixed,np,root=TRUE,nt=nt) ## apply resulting stable re-parameterization to X... X <- Sl.repara(ldS$rp,X) ## get pivoted QR decomp of augmented model matrix (in parallel if nt>1) qrx <- if (nt>1) pqr2(rbind(X,ldS$E),nt=nt) else qr(rbind(X,ldS$E),LAPACK=TRUE) rp <- qrx$pivot;rp[rp] <- 1:np ## reverse pivot vector ## find pivoted \hat beta... R <- qr.R(qrx) Qty0 <- qr.qty(qrx,c(y,rep(0,nrow(ldS$E)))) beta <- backsolve(R,Qty0)[1:np] rss.bSb <- sum(Qty0[-(1:np)]^2) + rss.extra ## get component derivatives based on IFT... dift <- Sl.ift(ldS$Sl,R,X,y,beta,qrx$pivot,rp) ## and the derivatives of log|X'X+S|... P <- pbsi(R,nt=nt,copy=TRUE) ## invert R ## P <- backsolve(R,diag(np))[rp,] ## invert R and row unpivot ## crossprod and unpivot (don't unpivot if unpivoting P above) PP <- if (nt==1) tcrossprod(P)[rp,rp] else pRRt(P,nt)[rp,rp] ## PP' ldetXXS <- 2*sum(log(abs(diag(R)))) ## log|X'X+S| dXXS <- d.detXXS(ldS$Sl,PP,nt=nt) ## derivs of log|X'X+S| ## all ingredients are now in place to form REML score and ## its derivatives.... reml <- (rss.bSb/phi + (nobs-Mp)*log(2*pi*phi) + ldetXXS - ldS$ldetS)/2 reml1 <- (dXXS$d1[!fixed] - ldS$ldet1 + # dift$bSb1[!fixed]/phi)/2 (dift$rss1[!fixed] + dift$bSb1[!fixed])/phi)/2 reml2 <- (dXXS$d2[!fixed,!fixed] - ldS$ldet2 + #dift$bSb2[!fixed,!fixed]/phi)/2 (dift$rss2[!fixed,!fixed] + dift$bSb2[!fixed,!fixed])/phi)/2 ## finally add in derivatives w.r.t. log.phi if (!phi.fixed) { n <- length(reml1) reml1[n+1] <- (-rss.bSb/phi + nobs - Mp)/2 #d <- c(-(dift$bSb1[!fixed]),rss.bSb)/(2*phi) d <- c(-(dift$rss1[!fixed] + dift$bSb1[!fixed]),rss.bSb)/(2*phi) reml2 <- rbind(cbind(reml2,d[1:n]),d) } ## following are de-bugging lines for testing derivatives of components... #list(reml=ldetXXS,reml1=dXXS$d1,reml2=dXXS$d2) #list(reml=ldS$ldetS,reml1=ldS$ldet1,reml2=ldS$ldet2) #list(reml=dift$rss,reml1=dift$rss1,reml2=dift$rss2) #list(reml=dift$bSb,reml1=dift$bSb1,reml2=dift$bSb2) list(reml=as.numeric(reml),reml1=reml1,reml2=reml2,beta=beta[rp],PP=PP, rp=ldS$rp,rss=dift$rss+rss.extra,nobs=nobs,d1b=dift$d1b) } ## Sl.fit fast.REML.fit <- function(Sl,X,y,rho,L=NULL,rho.0=NULL,log.phi=0,phi.fixed=TRUE, rss.extra=0,nobs=NULL,Mp=0,conv.tol=.Machine$double.eps^.5,nt=1) { ## estimates log smoothing parameters rho, by optimizing fast REML ## using Newton's method. On input Sl is a block diagonal penalty ## structure produced by Sl.setup, while X is a model matrix ## reparameterized to correspond to any re-parameterization ## used in Sl. Both will have had been modified to drop any ## structurally un-identifiable coefficients. ## Note that lower bounds on smoothing parameters are not handled. maxNstep <- 5 if (is.null(nobs)) nobs <- nrow(X) np <- ncol(X) if (nrow(X) > np) { ## might as well do an initial QR step qrx <- if (nt>1) pqr2(X,nt=nt) else qr(X,LAPACK=TRUE) rp <- qrx$pivot rp[rp] <- 1:np X <- qr.R(qrx)[,rp] y <- qr.qty(qrx,y) rss.extra <- rss.extra + sum(y[-(1:np)]^2) y <- y[1:np] } if (is.null(L)) { L <- diag(length(rho)) if (is.null(rho.0)) rho.0 <- rep(0,nrow(L)) } else { ## convert intial s.p.s to account for L if (is.null(rho.0)) rho.0 <- rep(0,nrow(L)) rho <- as.numeric(coef(lm(rho ~ L-1+offset(rho.0)))) } fixed <- rep(FALSE,nrow(L)) best <- Sl.fit(Sl,X,y,L%*%rho+rho.0,fixed,log.phi,phi.fixed,rss.extra,nobs,Mp,nt=nt) ## get a typical scale for the reml score... reml.scale <- abs(best$reml) + best$rss/best$nobs nr <- length(rho.0) if (!phi.fixed) { rho <- c(rho,log.phi) ## append log.phi for fitting rho.0 <- c(rho.0,0) L <- rbind(cbind(L,L[,1]*0),c(L[1,]*0,1)) } grad <- as.numeric(t(L)%*% best$reml1) hess <- t(L)%*% best$reml2%*%L grad2 <- diag(hess) ## create and index for the unconverged... ## idea in following is only to exclude terms with zero first and second derivative ## from optimization, as it is only these that slow things down if included... uconv.ind <- (abs(grad) > reml.scale*conv.tol*.1)|(abs(grad2)>reml.scale*conv.tol*.1) ## if all appear converged at this stage, then there is probably something wrong, ## but reset anyway to see if situation can be recovered. If we don't do this then ## need to abort immediately, otherwise fails trying to eigen a 0 by 0 matrix if (sum(uconv.ind)==0) { warning("Possible divergence detected in fast.REML.fit",call.=FALSE,immediate.=TRUE) uconv.ind <- rep(TRUE,length(grad)) } step.failed <- FALSE for (iter in 1:200) { ## the Newton loop ## Work only with unconverged (much quicker under indefiniteness) hess <- (t(L)%*% best$reml2%*%L)[uconv.ind,uconv.ind] grad <- as.numeric(t(L)%*%best$reml1)[uconv.ind] ## check that Hessian is +ve def. Fix if not. eh <- eigen(hess,symmetric=TRUE) ## flip negative eigenvalues to get +ve def... ind <- eh$values < 0 eh$values[ind] <- -eh$values[ind] ## avoid indefiniteness by further manipulation... thresh <- max(abs(eh$values))*.Machine$double.eps^.5 ind <- eh$values < thresh eh$values[ind] <- thresh ## get the Newton direction, -ve inverse hessian times gradient uc.step <- - eh$vectors%*%((t(eh$vectors)%*%grad)/eh$values) ## now make sure step is not too far... ms <- max(abs(uc.step)) if (ms>maxNstep) uc.step <- maxNstep * uc.step/ms step <- rep(0,length(uconv.ind)); ## full step (including converged) step[uconv.ind] <- uc.step ## step includes converged ## try out the step... rho1 <- L%*%(rho + step)+rho.0; if (!phi.fixed) log.phi <- rho1[nr+1] trial <- Sl.fit(Sl,X,y,rho1[1:nr],fixed,log.phi,phi.fixed,rss.extra,nobs,Mp,nt=nt) k <- 0 while (trial$reml>best$reml && k<35) { ## step half until improvement step <- step/2;k <- k + 1 rho1 <- L%*%(rho + step)+rho.0; if (!phi.fixed) log.phi <- rho1[nr+1] trial <- Sl.fit(Sl,X,y,rho1[1:nr],fixed,log.phi,phi.fixed,rss.extra,nobs,Mp,nt=nt) } if ((k==35 && trial$reml>best$reml)||(sum(rho != rho + step)==0)) { ## step has failed step.failed <- TRUE break ## can get no further } ## At this stage the step has been successful. ## Need to test for convergence... converged <- TRUE grad <- as.numeric(t(L)%*%trial$reml1) hess <- t(L)%*%trial$reml2%*%L;grad2 <- diag(hess) ## idea in following is only to exclude terms with zero first and second derivative ## from optimization, as it is only these that slow things down if included... uconv.ind <- (abs(grad) > reml.scale*conv.tol*.1)|(abs(grad2)>reml.scale*conv.tol*.1) ## now do the convergence testing... ## First check gradiants... if (sum(abs(grad)>reml.scale*conv.tol)) converged <- FALSE ## Now check change in REML values if (abs(best$reml-trial$reml)>reml.scale*conv.tol) { if (converged) uconv.ind <- uconv.ind | TRUE ## otherwise can't progress converged <- FALSE } best <- trial ## trial becomes current best. rho <- rho + step ## and new log sp accepted. if (converged) break ## ok done, leave loop reml.scale <- abs(best$reml) + best$rss/best$nobs ## update for next iterate } ## end of Newton loop if (iter==200) warning("fast REML optimizer reached iteration limit") if (step.failed) best$conv <- "step failed" else if (iter==200) best$conv <- "no convergence in 200 iterations" else best$conv <- "full convergence" best$iter <- iter best$outer.info <- list(conv = best$conv, iter = best$iter,grad = grad,hess = hess) best$rho <- rho best$rho.full <- as.numeric(L%*%rho+rho.0) best ## return the best fit (note that it will need post-processing to be useable) } ## end fast.REML.fit ident.test <- function(X,E,nt=1) { ## routine to identify structurally un-identifiable coefficients ## for model with model matrix X and scaled sqrt penalty matrix E ## lambda is smoothing parameter vector corresponding to E, ## and the routine also suggests starting values for lambda ## based on scaling of X and E. ## If length(drop)>0 then X[,-drop] is new model matrix ## if beta contains coefs with unidentified dropped, and ## if beta.full is a vector of zeroes for each original coef ## then beta.full[undrop] <- beta, is the full, zero padded ## coeff vector, with dropped coefs re-nstated as zeroes. Xnorm <- norm(X,type="F") qrx <- if (nt>1) pqr2(rbind(X/Xnorm,E),nt=nt) else qr(rbind(X/Xnorm,E),LAPACK=TRUE) ## pivoted QR rank <- Rrank(qr.R(qrx),tol=.Machine$double.eps^.75) drop <- qrx$pivot[-(1:rank)] ## index of un-identifiable coefs undrop <- 1:ncol(X) if (length(drop)>0) undrop <- undrop[-drop] list(drop=drop,undrop=undrop) } ## ident.test Sl.drop <- function(Sl,drop,np) { ## routine to drop coefs in drop, from block diagonal penalty ## stored in Sl. np is total number of coeffs if (length(drop)==0) return(Sl) keep <- rep(TRUE,np) keep[drop] <- FALSE ## logical indexing of retained coefs ## let b1 be coefs after dropping and b0 be full vector before. ## new.loc gives location in b1 of ith element in b0. If i is ## in drop then new.loc[i] is position of last b0[j] not dropped. ## i.e. for i not in drop, b0[i] = b1[new.loc[i]]. ## for i in drop, b1[new.loc[i]] = b0[j] where j is largest ## j < i s.t. j not in drop. ## These indices facilitate easy dropping from parts of blocks ## corresponding to coef indices in drop. new.loc <- cumsum(keep) dropped.blocks <- FALSE for (b in 1:length(Sl)) { ind <- (Sl[[b]]$start:Sl[[b]]$stop)##[Sl[[b]]$ind] if (length(Sl[[b]]$S)==1) { ## singleton ## need to count terms dropped from penalty, ## adjusting rank, ind, start and stop bdrop <- ind%in%drop ## which are dropped here? npd <- sum(bdrop[Sl[[b]]$ind]) ## number of penalized dropped Sl[[b]]$ind <- Sl[[b]]$ind[!bdrop] ## retain not dropped Sl[[b]]$rank <- Sl[[b]]$rank - npd ## reduce rank by penalized dropped if (Sl[[b]]$rank <=0) dropped.blocks <- TRUE Sl[[b]]$start <- new.loc[Sl[[b]]$start] Sl[[b]]$stop <- new.loc[Sl[[b]]$stop] } else { ## multi-S bdrop <- ind%in%drop ## which are dropped here? keep <- !bdrop[Sl[[b]]$ind] ## index of what to keep in the penalties npd <- sum(!keep) ## number of penalized dropped Sl[[b]]$ind <- Sl[[b]]$ind[!bdrop] ## retain not dropped Sl[[b]]$rank <- Sl[[b]]$rank - npd ## reduce rank by penalized dropped if (Sl[[b]]$rank <=0) dropped.blocks <- TRUE ## need to drop rows and cols from S and and rows from rS for (i in 1:length(Sl[[b]]$S)) { Sl[[b]]$rS[[i]] <- Sl[[b]]$rS[[i]][keep,] Sl[[b]]$S[[i]] <- Sl[[b]]$S[[i]][keep,keep] } Sl[[b]]$start <- new.loc[Sl[[b]]$start] Sl[[b]]$stop <- new.loc[Sl[[b]]$stop] } } if (dropped.blocks) { new.b <- 1 for (i in 1:length(Sl)) { if (Sl[[b]]$rank>0) { Sl[[new.b]] <- Sl[[b]] new.b <- new.b + 1 } } } Sl } ## Sl.drop Sl.Xprep <- function(Sl,X,nt=1) { ## Sl is block diag object from Sl.setup, X is a model matrix ## this routine applies preliminary Sl transformations to X ## tests for structural identifibility problems and drops ## un-identifiable parameters. X <- Sl.initial.repara(Sl,X,inverse=FALSE,both.sides=FALSE,cov=FALSE,nt=nt) ## apply re-para used in Sl to X id <- ident.test(X,attr(Sl,"E"),nt=nt) ## deal with structural identifiability ## id contains drop, undrop, lambda if (length(id$drop)>0) { ## then there is something to do here Sl <- Sl.drop(Sl,id$drop,ncol(X)) ## drop unidentifiable from Sl X <- X[,-id$drop] ## drop unidentifiable from X } rank <- 0 for (b in 1:length(Sl)) rank <- rank + Sl[[b]]$rank ## the total penalty rank ## Also add Mp, the total mull space dimension to return list. list(X=X,Sl=Sl,undrop=id$undrop,rank=rank,Mp=ncol(X)-rank) } ## end Sl.Xprep Sl.postproc <- function(Sl,fit,undrop,X0,cov=FALSE,scale = -1,L,nt=nt) { ## reverse the various fitting re-parameterizations. ## X0 is the orginal model matrix before any re-parameterization ## or parameter dropping. Sl is also the original *before parameter ## dropping* np <- ncol(X0) beta <- rep(0,np) beta[undrop] <- Sl.repara(fit$rp,fit$beta,inverse=TRUE) beta <- Sl.initial.repara(Sl,beta,inverse=TRUE,both.sides=TRUE,cov=TRUE,nt=nt) if (cov) { d1b <- matrix(0,np,ncol(fit$d1b)) ## following construction a bit ugly due to Sl.repara assumptions... d1b[undrop,] <- t(Sl.repara(fit$rp,t(fit$d1b),inverse=TRUE,both.sides=FALSE)) for (i in 1:ncol(d1b)) d1b[,i] <- Sl.initial.repara(Sl,as.numeric(d1b[,i]),inverse=TRUE,both.sides=TRUE,cov=TRUE,nt=nt) ## d beta / d rho matrix PP <- matrix(0,np,np) PP[undrop,undrop] <- Sl.repara(fit$rp,fit$PP,inverse=TRUE) PP <- Sl.initial.repara(Sl,PP,inverse=TRUE,both.sides=TRUE,cov=TRUE,nt=nt) #XPP <- crossprod(t(X0),PP)*X0 #hat <- rowSums(XPP);edf <- colSums(XPP) XPP <- crossprod(t(X0),PP) hat <- rowSums(XPP*X0) F <- crossprod(XPP,X0) edf <- diag(F) edf1 <- 2*edf - rowSums(t(F)*F) ## edf <- rowSums(PP*crossprod(X0)) ## diag(PP%*%(t(X0)%*%X0)) if (scale<=0) { scale <- fit$rss/(fit$nobs - sum(edf)) } Vp <- PP * scale ## cov matrix ## sp uncertainty correction... if (!is.null(L)) d1b <- d1b%*%L M <- ncol(d1b) ev <- eigen(fit$outer.info$hess,symmetric=TRUE) ind <- ev$values <= 0 ev$values[ind] <- 0;ev$values[!ind] <- 1/sqrt(ev$values[!ind]) rV <- (ev$values*t(ev$vectors))[,1:M] Vc <- crossprod(rV%*%t(d1b)) Vc <- Vp + Vc ## Bayesian cov matrix with sp uncertainty edf2 <- rowSums(Vc*crossprod(X0))/scale ##bias <- as.numeric(beta-F%*%beta) ## estimate of smoothing bias in beta return(list(beta=beta,Vp=Vp,Vc=Vc,Ve=F%*%Vp,edf=edf,edf1=edf1,edf2=edf2,hat=hat,F=F)) } else return(list(beta=beta)) } ## Sl.postproc ## USEAGE SEQUENCE: ## 1. Use gam.setup to setup gam object, G, say, as usual ## 2. Call Sl.setup which uses info in G$smooth and G$paraPen ## to set up a block diagonal penalty structure, Sl, say ## 3. At this stage reweight the model matrix in G if needed ## (e.g. in IRLS) to get X ## 4. um <- Sl.Xprep(Sl,X) to deal with identifiability and re-para. ## 5. initial smoothing parameters from initial.sp(X,G$S,G$off), ## initial phi from, say variance of y over 10?? ## 6. fit <- fast.REML.fit(um$Sl,um$X,G$y,rho,L=G$L,rho.0=G$lsp0, ## log.phi=log.phi,phi.fixed=FALSE/TRUE,Mp=um$Mp) ## 7. res <- Sl.postproc(Sl,fit,um$undrop,X,cov=TRUE), to get postproc ## stuff ## Notice: that only steps 3-7 are needed in an IRLS loop and cov=TRUE ## is only needed after convergence of such a loop. ## Warning: min.sp not handled by this approach. mgcv/R/mvam.r0000644000177400001440000002442012730062715012731 0ustar murdochusers## (c) Simon N. Wood (2013-2015) mvn model extended family. ## Released under GPL2 ... lpi.expand <- function(X,trailing=TRUE) { ## takes a model matrix X, with "lpi" attribute, and produces ## full redundant version in which each column block is the full ## model matrix for one linear predictor, which may involve ## repeating columns between blocks. ## See mvn family (ll) for prototypic application lpi <- attr(X,"lpi") if (!attr(lpi,"overlap")) return(X) ## nothing to do ip <- unlist(lpi) if (trailing&&max(ip)lip) nt <- nrow(x)-lip else if (ncol(x)>lip) nt <- ncol(x) - lip } else if (length(x)>lip) nt <- length(x) - lip if (nt>0) { ## there is a trailing block - index it in lpi lpi[[length(lpi)+1]] <- 1:nt + max(ip) ip <- unlist(lpi) } } p <- max(ip) ## dimension of result if (is.matrix(x)) { if (type=="c"||type=="rc") { ## column contraction k <- 0 z <- matrix(0,nrow(x),p) for (i in 1:length(lpi)) { ii <- 1:length(lpi[[i]]) + k k <- k + length(ii) z[,lpi[[i]]] <- z[,lpi[[i]]] + x[,ii] } if (type=="rc") x <- z } if (type=="r"||type=="rc") { ## row contraction z <- matrix(0,p,ncol(x)) k <- 0 for (i in 1:length(lpi)) { ii <- 1:length(lpi[[i]]) + k k <- k + length(ii) z[lpi[[i]],] <- z[lpi[[i]],] + x[ii,] } } } else { ## vector z <- rep(0,p);k <- 0 for (i in 1:length(lpi)) { ii <- 1:length(lpi[[i]]) + k k <- k + length(ii) z[lpi[[i]]] <- z[lpi[[i]]] + x[ii] } } z } ## lpi.contract mvn <- function(d=2) { ## Extended family object for multivariate normal additive model. if (d<2) stop("mvn requires 2 or more dimensional data") stats <- list() for (i in 1:d) { stats[[i]] <- make.link("identity") } ##env <- new.env(parent = .GlobalEnv) validmu <- function(mu) all(is.finite(mu)) ## initialization has to add in the extra parameters of ## the cov matrix... preinitialize <- expression({ ## code to evaluate in estimate.gam... ## extends model matrix with dummy columns and ## finds initial coefficients ydim <- ncol(G$y) ## dimension of response nbeta <- ncol(G$X) ntheta <- ydim*(ydim+1)/2 ## number of cov matrix factor params lpi <- attr(G$X,"lpi") #offs <- attr(G$X,"offset") XX <- crossprod(G$X) G$X <- cbind(G$X,matrix(0,nrow(G$X),ntheta)) ## add dummy columns to G$X #G$cmX <- c(G$cmX,rep(0,ntheta)) ## and corresponding column means G$term.names <- c(G$term.names,paste("R",1:ntheta,sep=".")) attr(G$X,"lpi") <- lpi #offs -> attr(G$X,"offset") attr(G$X,"XX") <- XX ## pad out sqrt of balanced penalty matrix to account for extra params attr(G$Sl,"E") <- cbind(attr(G$Sl,"E"),matrix(0,nbeta,ntheta)) G$family$data <- list(ydim = ydim,nbeta=nbeta) G$family$ibeta = rep(0,ncol(G$X)) ## now get initial parameters and store in family... for (k in 1:ydim) { sin <- G$off %in% lpi[[k]] #Sk <- G$S[sin] um <- magic(G$y[,k],G$X[,lpi[[k]]],rep(-1,sum(sin)),G$S[sin], match(G$off[sin],lpi[[k]]), ## turn G$off global indices into indices for this predictor nt=control$nthreads) G$family$ibeta[lpi[[k]]] <- um$b G$family$ibeta[nbeta+1] <- -.5*log(um$scale) ## initial log root precision nbeta <- nbeta + ydim - k + 1 } }) postproc <- expression({ ## code to evaluate in estimate.gam, to do with estimated factor of ## precision matrix, etc... ydim <- G$family$data$ydim R <- matrix(0,ydim,ydim) ind <- G$family$data$nbeta + 1:(ydim*(ydim+1)/2); theta <- object$coefficients[ind] k <- 1;for (i in 1:ydim) for (j in i:ydim) { if (i==j) R[i,j] <- exp(theta[k]) else R[i,j] <- theta[k] k <- k + 1 } object$family$data <- list(R=R) rsd <- R%*%t(object$y-object$fitted.values) object$deviance <- sum(rsd^2) rsd <- R%*%(t(object$y)-colMeans(object$y)) object$null.deviance <- sum(rsd^2) }) initialize <- expression({ ## called in gam.fit5 and initial.spg n <- rep(1, nobs) if (is.null(start)) start <- family$ibeta ## need to re-parameterize XX is non-standard if (exists("rp",inherits=FALSE)&&length(rp$rp)>0) attr(x,"XX") <- Sl.repara(rp$rp,t(Sl.repara(rp$rp,attr(x,"XX")))) }) residuals <- function(object,type=c("response","deviance")) { type <- match.arg(type) res <- object$y - object$fitted.values if (type=="deviance") res <- res%*%t(object$family$data$R) res } ## residuals ##rd <- qf <- NULL ## these functions currently undefined for ll <- function(y,X,coef,wt,family,offset=NULL,deriv=0,d1b=NULL,d2b=NULL,Hp=NULL,rank=0,fh=NULL,D=NULL) { ## function defining the Multivariate Normal model log lik. ## Calls C code "mvn_ll" ## deriv codes: 0 - evaluate the log likelihood ## 1 - evaluate the grad and Hessian, H, of log lik w.r.t. coefs (beta) ## 2/3 - evaluate d1H =dH/drho given db/drho in d1b ## (2 is diagonal only - not implemented efficiently) ## 4 - given d1b and d2b evaluate trHid2H= tr(Hp^{-1}d2H/drhodrho') (not implemented) ## Hp is the preconditioned penalized hessian of the log lik ## which is of rank 'rank'. ## fh is a factorization of Hp - either its eigen decomposition ## or its Choleski factor ## D is the diagonal pre-conditioning matrix used to obtain Hp ## if Hr is the raw Hp then Hp = D*t(D*Hr) if (!is.null(offset)) { for (i in 1:length(offset)) if (sum(offset[[i]]!=0)) stop("mvn does not yet handle offsets") } lpi <- attr(X,"lpi") ## lpi[[k]] is index of model matrix columns for dim k overlap <- attr(lpi,"overlap") ## do dimensions share terms? drop <- attr(X,"drop") if (!is.null(drop)) { ## the optimizer has dropped some parameters ## it will have adjusted lpi automatically, but XX is mvn specific attr(X,"XX") <- attr(X,"XX")[-drop,-drop] } m <- length(lpi) ## number of dimensions of MVN if (overlap) { ## linear predictors share terms - expand to redundant representation ip <- unlist(lpi) XX <- attr(X,"XX")[ip,ip] X <- lpi.expand(X) attr(X,"XX") <- XX;rm(XX) lpi0 <- lpi ## need to save this for contraction of results lpi <- attr(X,"lpi") ## this indexes the cols of each l.p in the expanded X ## need to expand coef beta, leaving m*(m+1)/2 final coefs of R at end ind <- (max(ip)+1):length(coef) if (length(ind)!=m*(m+1)/2) stop("mvn dimension error") coef <- c(coef[ip],coef[ind]) ## do same for derivatives of coef wrt log smoothing params... if (!is.null(d1b)) d1b <- rbind(d1b[ip,],d1b[ind,]) } else ind <- NULL lpstart <- rep(0,m) for (i in 1:(m-1)) lpstart[i] <- lpi[[i+1]][1] lpstart[m] <- lpi[[m]][length(lpi[[m]])]+1 nb <- length(coef) ## total number of parameters if (deriv<2) { nsp = 0;d1b <- dH <- 0 } else { nsp = ncol(d1b) dH = rep(0,nsp*nb*nb) } #cat("\nderiv=",deriv," lpstart=",lpstart," dim(y) = ",dim(y), # "\ndim(XX)=",dim(attr(X,"XX"))," m=",m," nsp=",nsp,"\n") oo <- .C("mvn_ll",y=as.double(t(y)),X=as.double(X),XX=as.double(attr(X,"XX")), beta=as.double(coef),n=as.integer(nrow(X)), lpi=as.integer(lpstart-1),m=as.integer(m),ll=as.double(0),lb=as.double(coef*0), lbb=as.double(rep(0,nb*nb)), dbeta = as.double(d1b), dH = as.double(dH), deriv = as.integer(nsp>0),nsp = as.integer(nsp),nt=as.integer(1),PACKAGE="mgcv") lb <- oo$lb;lbb <- matrix(oo$lbb,nb,nb) if (overlap) { ## need to apply lpi contraction lb <- lpi.contract(lb,lpi0) ## lpi.contract will automatically carry across the R coef related stuff lbb <- lpi.contract(lbb,lpi0) } if (nsp==0) d1H <- NULL else if (deriv==2) { d1H <- matrix(0,nb,nsp) for (i in 1:nsp) { dH <- matrix(oo$dH[ind],nb,nb) if (overlap) dH <- lpi.contract(dH,lpi0) d1H[,i] <- diag(dH) ind <- ind + nb*nb } } else { ## deriv==3 d1H <- list();ind <- 1:(nb*nb) for (i in 1:nsp) { dH <- matrix(oo$dH[ind],nb,nb) if (overlap) dH <- lpi.contract(dH,lpi0) d1H[[i]] <- dH ind <- ind + nb*nb } } list(l=oo$ll,lb=lb,lbb=lbb,d1H=d1H) } ## ll # environment(dev.resids) <- environment(aic) <- environment(getTheta) <- # environment(rd)<- environment(qf)<- environment(variance) <- environment(putTheta) ##environment(aic) <- ##environment(ll) <- env structure(list(family = "Multivariate normal", ## link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, ll=ll,nlp=d, initialize = initialize,preinitialize=preinitialize,postproc=postproc, residuals=residuals, validmu = validmu, ## valideta = stats$valideta, ## rd=rd,qf=qf, linfo = stats, ## link information list d2link=1,d3link=1,d4link=1, ## signals to fix.family.link that all done ls=1, ## signal ls not needed available.derivs = 1 ## signal only first derivatives available... ), class = c("general.family","extended.family","family")) } ## mvn mgcv/R/efam.r0000644000177400001440000021002313015113067012667 0ustar murdochusers## (c) Simon N. Wood (ocat, tw, nb, ziP) & Natalya Pya (scat, beta), ## 2013-2015. Released under GPL2. ## extended families for mgcv, standard components. ## family - name of family character string ## link - name of link character string ## linkfun - the link function ## linkinv - the inverse link function ## mu.eta - d mu/d eta function (derivative of inverse link wrt eta) ## note: for standard links this information is supplemented using ## function fix.family.link.extended.family with functions ## gkg where k is 2,3 or 4 giving the kth derivative of the ## link over the first derivative of the link to the power k. ## for non standard links these functions muct be supplied. ## dev.resids - function computing deviance residuals. ## Dd - function returning derivatives of deviance residuals w.r.t. mu and theta. ## aic - function computing twice - log likelihood for 2df to be added to. ## initialize - expression to be evaluated in gam.fit4 and initial.spg ## to initialize mu or eta. ## preinitialize - optional expression evaluated in estimate.gam to ## e.g. initialize theta parameters (see e.g. ocat) ## postproc - expression to evaluate in estimate.gam after fitting (see e.g. betar) ## ls - function to evaluated log saturated likelihood and derivatives w.r.t. ## phi and theta for use in RE/ML optimization. If deviance used is just -2 log ## lik. can njust return zeroes. ## validmu, valideta - functions used to test whether mu/eta are valid. ## n.theta - number of theta parameters. ## no.r.sq - optional TRUE/FALSE indicating whether r^2 can be computed for family ## ini.theta - function for initializing theta. ## putTheta, getTheta - functions for storing and retriving theta values in function ## environment. ## rd - optional function for simulating response data from fitted model. ## residuals - optional function for computing residuals. ## predict - optional function for predicting from model, called by predict.gam. ## family$data - optional list storing any family specific data for use, e.g. in predict ## function. ## extended family object for ordered categorical ocat <- function(theta=NULL,link="identity",R=NULL) { ## extended family object for ordered categorical model. ## one of theta and R must be supplied. length(theta) == R-2. ## weights are ignored. #! is stuff removed under re-definition of ls as 0 linktemp <- substitute(link) if (!is.character(linktemp)) linktemp <- deparse(linktemp) if (linktemp %in% c("identity")) stats <- make.link(linktemp) else if (is.character(link)) { stats <- make.link(link) linktemp <- link } else { if (inherits(link, "link-glm")) { stats <- link if (!is.null(stats$name)) linktemp <- stats$name } else stop(linktemp, " link not available for ordered categorical family; available links are \"identity\"") } if (is.null(theta)&&is.null(R)) stop("Must supply theta or R to ocat") if (!is.null(theta)) R <- length(theta) + 2 ## number of catergories ## Theta <- NULL; n.theta <- R-2 ## NOTE: data based initialization is in preinitialize... if (!is.null(theta)&&sum(theta==0)==0) { if (sum(theta<0)) iniTheta <- log(abs(theta)) ## initial theta supplied else { iniTheta <- log(theta) ## fixed theta supplied n.theta <- 0 } } else iniTheta <- rep(-1,length=R-2) ## inital log theta value env <- new.env(parent = .GlobalEnv) assign(".Theta", iniTheta, envir = env) putTheta <-function(theta) assign(".Theta", theta,envir=environment(sys.function())) getTheta <-function(trans=FALSE) { theta <- get(".Theta") if (trans) { ## transform to (finite) cut points... R = length(theta)+2 alpha <- rep(0,R-1) ## the thresholds alpha[1] <- -1 if (R > 2) { ind <- 2:(R-1) alpha[ind] <- alpha[1] + cumsum(exp(theta)) } theta <- alpha } theta } postproc <- expression({ object$family$family <- paste("Ordered Categorical(",paste(round(object$family$getTheta(TRUE),2),collapse=","),")",sep="") }) validmu <- function(mu) all(is.finite(mu)) dev.resids <- function(y, mu, wt,theta=NULL) { #F <- function(x) { # h <- ind <- x > 0; h[ind] <- 1/(exp(-x[ind]) + 1) # x <- exp(x[!ind]); h[!ind] <- (x/(1+x)) # h #} Fdiff <- function(a,b) { ## cancellation resistent F(b)-F(a), b>a h <- rep(1,length(b)); h[b>0] <- -1; eb <- exp(b*h) h <- h*0+1; h[a>0] <- -1; ea <- exp(a*h) ind <- b<0;bi <- eb[ind];ai <- ea[ind] h[ind] <- bi/(1+bi) - ai/(1+ai) ind1 <- a>0;bi <- eb[ind1];ai <- ea[ind1] h[ind1] <- (ai-bi)/((ai+1)*(bi+1)) ind <- !ind & !ind1;bi <- eb[ind];ai <- ea[ind] h[ind] <- (1-ai*bi)/((bi+1)*(ai+1)) h } if (is.null(theta)) theta <- get(".Theta") R = length(theta)+2 alpha <- rep(0,R+1) ## the thresholds alpha[1] <- -Inf;alpha[R+1] <- Inf alpha[2] <- -1 if (R > 2) { ind <- 3:R alpha[ind] <- alpha[2] + cumsum(exp(theta)) } al1 <- alpha[y+1];al0 = alpha[y] ## cut points above and below y ## Compute sign for deviance residuals, based on sign of interval ## midpoint for each datum minus the fitted value of the latent ## variable. This makes first and last categories like 0s and 1s in ## logistic regression.... s <- sign((al1 + al0)/2-mu) ## sign for deviance residuals al1mu <- al1-mu;al0mu <- al0-mu ## f1 <- F(al1mu);f0 <- F(al0mu); ##f <- pmax(f1 - f0,.Machine$double.eps) f <- Fdiff(al0mu,al1mu) ##a1 <- f1^2 - f1;a0 <- f0^2 - f0; a <- a1 -a0 #! al1al0 <- (al1-al0)/2;al0al1 <- (al0-al1)/2 ##g1 <- F(al1al0);g0 <- F(al0al1) ##A <- pmax(g1 - g0,.Machine$double.eps) #! A <- Fdiff(al0al1,al1al0) rsd <- -2*log(f) #! 2*(log(A)-log(f)) attr(rsd,"sign") <- s rsd } ## end of dev.resids Dd <- function(y, mu, theta, wt=NULL, level=0) { ## derivatives of the deviance... # F <- function(x) { ## e^(x)/(1+e^x) without overflow # h <- ind <- x > 0; h[ind] <- 1/(exp(-x[ind]) + 1) # x <- exp(x[!ind]); h[!ind] <- (x/(1+x)) # h # } Fdiff <- function(a,b) { ## cancellation resistent F(b)-F(a), b>a h <- rep(1,length(b)); h[b>0] <- -1; eb <- exp(b*h) h <- h*0+1; h[a>0] <- -1; ea <- exp(a*h) ind <- b<0;bi <- eb[ind];ai <- ea[ind] h[ind] <- bi/(1+bi) - ai/(1+ai) ind1 <- a>0;bi <- eb[ind1];ai <- ea[ind1] h[ind1] <- (ai-bi)/((ai+1)*(bi+1)) ind <- !ind & !ind1;bi <- eb[ind];ai <- ea[ind] h[ind] <- (1-ai*bi)/((bi+1)*(ai+1)) h } abcd <- function(x,level=-1) { bj <- cj <- dj <- NULL ## compute f_j^2 - f_j without cancellation error ## x <- 10;F(x)^2-F(x);abcd(x)$aj h <- rep(1,length(x)); h[x>0] <- -1; ex <- exp(x*h) ex1 <- ex+1;ex1k <- ex1^2 aj <- -ex/ex1k if (level>=0) { ## compute f_j - 3 f_j^2 + 2f_j^3 without cancellation error ## x <- 10;F(x)-3*F(x)^2+2*F(x)^3;abcd(x,0)$bj ex1k <- ex1k*ex1;ex2 <- ex^2 bj <- h*(ex-ex^2)/ex1k if (level>0) { ## compute -f_j + 7 f_j^2 - 12 f_j^3 + 6 f_j^4 ## x <- 10;-F(x)+7*F(x)^2-12*F(x)^3+6*F(x)^4;abcd(x,1)$cj ex1k <- ex1k*ex1;ex3 <- ex2*ex cj <- (-ex3 + 4*ex2 - ex)/ex1k if (level>1) { ## compute d_j ## x <- 10;F(x)-15*F(x)^2+50*F(x)^3-60*F(x)^4+24*F(x)^5;abcd(x,2)$dj ex1k <- ex1k*ex1;ex4 <- ex3*ex dj <- h * (-ex4 + 11*ex3 - 11*ex2 + ex)/ex1k } } } list(aj=aj,bj=bj,cj=cj,dj=dj) } R = length(theta)+2 alpha <- rep(0,R+1) ## the thresholds alpha[1] <- -Inf;alpha[R+1] <- Inf alpha[2] <- -1 if (R > 2) { ind <- 3:R alpha[ind] <- alpha[2] + cumsum(exp(theta)) } al1 <- alpha[y+1];al0 = alpha[y] al1mu <- al1-mu;al0mu <- al0 - mu ##f1 <- F(al1mu);f0 <- F(al0mu); ##f <- pmax(f1 - f0,.Machine$double.eps) f <- pmax(Fdiff(al0mu,al1mu),.Machine$double.xmin) r1 <- abcd(al1mu,level); a1 <- r1$aj r0 <- abcd(al0mu,level); a0 <- r0$aj ## a1 <- f1^2 - f1;a0 <- f0^2 - f0; a <- a1 - a0 #!al1al0 <- (al1-al0)/2; #! al0al1 <- (al0-al1)/2 ##g1 <- F(al1al0);g0 <- F(al0al1) ##A <- pmax(g1 - g0,.Machine$double.eps) #! A <- Fdiff(al0al1,al1al0) if (level>=0) { ## b1 <- f1 - 3 * f1^2 + 2 * f1^3;b0 <- f0 - 3 * f0^2 + 2 * f0^3 b1 <- r1$bj;b0 <- r0$bj b <- b1 - b0 } if (level>0) { ##c1 <- -f1 + 7 * f1^2 - 12* f1^3 + 6 * f1^4 ##c0 <- -f0 + 7 * f0^2 - 12* f0^3 + 6 * f0^4 c1 <- r1$cj;c0 <- r0$cj c <- c1 - c0 #! R1 <- abcd(al1al0,level-2) #! R0 <- abcd(al0al1,level-2) ## B <- g1^2 - g1 + g0^2 - g0 #! B <- R1$aj + R0$aj } if (level>1) { ##d1 <- f1 - 15 * f1^2 + 50 * f1^3 - 60 * f1^4 + 24 * f1^5 ##d0 <- f0 - 15 * f0^2 + 50 * f0^3 - 60 * f0^4 + 24 * f0^5 d1 <- r1$dj;d0 <- r0$dj d <- d1 - d0 ##C <- 2 * g1^3 - 3 * g1^2 + g1 - 2 * g0^3 + 3 * g0^2 - g0 #! C <- R1$bj - R0$bj } oo <- list(D=NULL,Dmu=NULL,Dmu2=NULL,Dth=NULL,Dmuth=NULL, Dmu2th=NULL) n <- length(y) ## deviance... oo$D <- -2 * log(f) #! 2*(log(A)-log(f)) if (level >= 0) { ## get derivatives used in coefficient estimation oo$Dmu <- -2 * a / f a2 <- a^2 oo$EDmu2 <- oo$Dmu2 <- 2 * (a2/f - b)/f } if (R<3) level <- 0 ## no free parameters if (level > 0) { ## get first derivative related stuff f2 <- f^2;a3 <- a2*a oo$Dmu3 <- 2*(- c - 2 * a3/f2 + 3 * a * b/f)/f Dmua0 <- 2 * (a0 * a/f - b0)/f Dmua1 <- -2 * (a1 * a /f - b1)/f Dmu2a0 <- -2* (c0 + (a0*(2*a2/f - b)- 2*b0*a )/f)/f Dmu2a1 <- 2*(c1 + (2*(a1*a2/f - b1*a) - a1*b)/f)/f Da0 <- -2*a0/f #! + B/A; Da1 <- 2 * a1/f #! - B/A ## now transform to derivatives w.r.t. theta... oo$Dmu2th <- oo$Dmuth <- oo$Dth <- matrix(0,n,R-2) for (k in 1:(R-2)) { etk <- exp(theta[k]) ind <- y == k+1 oo$Dth[ind,k] <- Da1[ind]*etk oo$Dmuth[ind,k] <- Dmua1[ind]*etk oo$Dmu2th[ind,k] <- Dmu2a1[ind]*etk if (R>k+2) { ind <- y > k+1 & y < R oo$Dth[ind,k] <- (Da1[ind]+Da0[ind])*etk oo$Dmuth[ind,k] <- (Dmua1[ind]+Dmua0[ind])*etk oo$Dmu2th[ind,k] <- (Dmu2a1[ind]+Dmu2a0[ind])*etk } ind <- y == R oo$Dth[ind,k] <- Da0[ind]*etk oo$Dmuth[ind,k] <- Dmua0[ind]*etk oo$Dmu2th[ind,k] <- Dmu2a0[ind]*etk } } if (level >1) { ## and the second derivative components oo$Dmu4 <- 2*((3*b^2 + 4*a*c)/f + a2*(6*a2/f - 12*b)/f2 - d)/f Dmu3a0 <- 2 * ((a0*c + 3*c0*a + 3*b0*b)/f - d0 + 6*a*(a0*a2/f - b0*a - a0*b)/f2 )/f Dmu3a1 <- 2 * (d1 - (a1*c + 3*(c1*a + b1*b))/f + 6*a*(b1*a - a1*a2/f + a1*b)/f2)/f Dmua0a0 <- 2*(c0 + (2*a0*(b0 - a0*a/f) - b0*a)/f )/f Dmua1a1 <- 2*( (b1*a + 2*a1*(b1 - a1*a/f))/f - c1)/f Dmua0a1 <- 2*(a0*(2*a1*a/f - b1) - b0*a1)/f2 Dmu2a0a0 <- 2*(d0 + (b0*(2*b0 - b) + 2*c0*(a0 - a))/f + 2*(b0*a2 + a0*(3*a0*a2/f - 4*b0*a - a0*b))/f2)/f Dmu2a1a1 <- 2*( (2*c1*(a + a1) + b1*(2*b1 + b))/f + 2*(a1*(3*a1*a2/f - a1*b) - b1*a*(a + 4*a1))/f2 - d1)/f Dmu2a0a1 <- 0 ## (8*a0*b1*a/f^3 + 8*b0*a1*a/f^3 - 12*a0*a1*a/f^4 - 4*b0*b1/f^2 + ## 4*a0*a1*b/f^3 - 2*c0*a1/f^2 - 2*c1*a0/f^2) Da0a0 <- 2 * (b0 + a0^2/f)/f #! + .5 * (C - B^2/A)/A Da1a1 <- -2* (b1 - a1^2/f)/f #! + .5 * (C - B^2/A)/A Da0a1 <- -2*a0*a1/f2 #! - .5 * (C - B^2/A)/A ## now transform to derivatives w.r.t. theta... n2d <- (R-2)*(R-1)/2 oo$Dmu3th <- matrix(0,n,R-2) oo$Dmu2th2 <- oo$Dmuth2 <- oo$Dth2 <- matrix(0,n,n2d) i <- 0 for (j in 1:(R-2)) for (k in j:(R-2)) { i <- i + 1 ## the second deriv col ind <- y >= j ## rest are zero ar1.k <- ar.k <- rep(exp(theta[k]),n) ar.k[y==R | y <= k] <- 0; ar1.k[yk&yk+1] <- exp(theta[k]) oo$Dmu3th[ind,k] <- Dmu3a1[ind]*ar.k[ind] + Dmu3a0[ind]*ar1.k[ind] } oo$Dth2[,i] <- Da1a1*ar.k*ar.j + Da0a1*ar.k*ar1.j + Da1 * ar.kj + Da0a0*ar1.k*ar1.j + Da0a1*ar1.k*ar.j + Da0 * ar1.kj oo$Dmuth2[,i] <- Dmua1a1*ar.k*ar.j + Dmua0a1*ar.k*ar1.j + Dmua1 * ar.kj + Dmua0a0*ar1.k*ar1.j + Dmua0a1*ar1.k*ar.j + Dmua0 * ar1.kj oo$Dmu2th2[,i] <- Dmu2a1a1*ar.k*ar.j + Dmu2a0a1*ar.k*ar1.j + Dmu2a1 * ar.kj + Dmu2a0a0*ar1.k*ar1.j + Dmu2a0a1*ar1.k*ar.j + Dmu2a0 * ar1.kj } } oo } ## end of Dd aic <- function(y, mu, theta=NULL, wt, dev) { Fdiff <- function(a,b) { ## cancellation resistent F(b)-F(a), b>a h <- rep(1,length(b)); h[b>0] <- -1; eb <- exp(b*h) h <- h*0+1; h[a>0] <- -1; ea <- exp(a*h) ind <- b<0;bi <- eb[ind];ai <- ea[ind] h[ind] <- bi/(1+bi) - ai/(1+ai) ind1 <- a>0;bi <- eb[ind1];ai <- ea[ind1] h[ind1] <- (ai-bi)/((ai+1)*(bi+1)) ind <- !ind & !ind1;bi <- eb[ind];ai <- ea[ind] h[ind] <- (1-ai*bi)/((bi+1)*(ai+1)) h } if (is.null(theta)) theta <- get(".Theta") R = length(theta)+2 alpha <- rep(0,R+1) ## the thresholds alpha[1] <- -Inf;alpha[R+1] <- Inf alpha[2] <- -1 if (R > 2) { ind <- 3:R alpha[ind] <- alpha[2] + cumsum(exp(theta)) } al1 <- alpha[y+1];al0 = alpha[y] ##f1 <- F(al1-mu);f0 <- F(al0-mu);f <- f1 - f0 f <- Fdiff(al0-mu,al1-mu) -2*sum(log(f)) } ## end aic ls <- function(y,w,n,theta,scale) { ## the log saturated likelihood function. #! actually only first line used since re-def as 0 return(list(ls=0,lsth1=rep(0,R-2),lsth2=matrix(0,R-2,R-2))) F <- function(x) { h <- ind <- x > 0; h[ind] <- 1/(exp(-x[ind]) + 1) x <- exp(x[!ind]); h[!ind] <- (x/(1+x)) h } Fdiff <- function(a,b) { ## cancellation resistent F(b)-F(a), b>a h <- rep(1,length(b)); h[b>0] <- -1; eb <- exp(b*h) h <- h*0+1; h[a>0] <- -1; ea <- exp(a*h) ind <- b<0;bi <- eb[ind];ai <- ea[ind] h[ind] <- bi/(1+bi) - ai/(1+ai) ind1 <- a>0;bi <- eb[ind1];ai <- ea[ind1] h[ind1] <- (ai-bi)/((ai+1)*(bi+1)) ind <- !ind & !ind1;bi <- eb[ind];ai <- ea[ind] h[ind] <- (1-ai*bi)/((bi+1)*(ai+1)) h } R = length(theta)+2 alpha <- rep(0,R+1) ## the thresholds alpha[1] <- -Inf;alpha[R+1] <- Inf alpha[2] <- -1 if (R > 2) { ind <- 3:R alpha[ind] <- alpha[2] + cumsum(exp(theta)) } al1 <- alpha[y+1];al0 = alpha[y] g1 <- F((al1-al0)/2);g0 <- F((al0-al1)/2) ##A <- pmax(g1 - g0,.Machine$double.eps) A <- Fdiff((al0-al1)/2,(al1-al0)/2) ls <- sum(log(A)) B <- g1^2 - g1 + g0^2 - g0 C <- 2 * g1^3 - 3 * g1^2 + g1 - 2 * g0^3 + 3 * g0^2 - g0 Da0 <- .5 * B/A ; Da1 <- -0.5 *B/A Da0a0 <- .25 * C/A - .25 * B^2/A^2 Da1a1 <- .25 * C/A - .25 * B^2/A^2 Da0a1 <- - .25 * C/A + .25 * B^2/A^2 i <- 0 n2d <- (R-2)*(R-1)/2 n <- length(y) Dth <- matrix(0,n,R-2) Dth2 <- matrix(0,n,n2d) for (j in 1:(R-2)) for (k in j:(R-2)) { i <- i + 1 ## the second deriv col ind <- y >= j ## rest are zero ar1.k <- ar.k <- rep(exp(theta[k]),n) ar.k[y==R | y <= k] <- 0; ar1.k[yk&yk+1] <- exp(theta[k]) Dth[ind,k] <- Da1[ind]*ar.k[ind] + Da0[ind]*ar1.k[ind] } Dth2[,i] <- Da1a1*ar.k*ar.j + Da0a1*ar.k*ar1.j + Da1 * ar.kj + Da0a0*ar1.k*ar1.j + Da0a1*ar1.k*ar.j + Da0 * ar1.kj } lsth2=colSums(Dth2) if (R>2) { ls2 <- matrix(0,R-2,R-2);ii <- 0 for (i in 1:(R-2)) for (j in i:(R-2)) { ii <- ii + 1 ls2[i,j] <- ls2[j,i] <- lsth2[ii] } } list(ls=ls,lsth1=colSums(Dth),lsth2=ls2) } ## end of ls ## initialization is interesting -- needs to be with reference to initial cut-points ## so that mu puts each obs in correct category initially... preinitialize <- expression({ ocat.ini <- function(R,y) { ## initialize theta from raw counts in each category if (R<3) return() y <- c(1:R,y) ## make sure there is *something* in each class p <- cumsum(tabulate(y[is.finite(y)])/length(y[is.finite(y)])) eta <- if (p[1]==0) 5 else -1 - log(p[1]/(1-p[1])) ## mean of latent theta <- rep(-1,R-1) for (i in 2:(R-1)) theta[i] <- log(p[i]/(1-p[i])) + eta theta <- diff(theta) theta[theta <= 0.01] <- 0.01 theta <- log(theta) } R3 <- length(G$family$getTheta())+2 if (!is.numeric(G$y)) stop("Response should be integer class labels") if (R3>2&&G$family$n.theta>0) { Theta <- ocat.ini(R3,G$y) G$family$putTheta(Theta) } }) initialize <- expression({ R <- length(family$getTheta())+2 ## don't use n.theta as it's used to signal fixed theta if (any(y < 1)||any(y>R)) stop("values out of range") n <- rep(1, nobs) ## get the cut points... alpha <- rep(0,R+1) ## the thresholds alpha[1] <- -2;alpha[2] <- -1 if (R > 2) { ind <- 3:R alpha[ind] <- alpha[2] + cumsum(exp(family$getTheta())) } alpha[R+1] <- alpha[R] + 1 mustart <- (alpha[y+1] + alpha[y])/2 }) residuals <- function(object,type=c("deviance","working","response")) { if (type == "working") { res <- object$residuals } else if (type == "response") { theta <- object$family$getTheta() mu <- object$linear.predictors R = length(theta)+2 alpha <- rep(0,R+1) ## the thresholds alpha[1] <- -Inf;alpha[R+1] <- Inf alpha[2] <- -1 if (R > 2) { ind <- 3:R alpha[ind] <- alpha[2] + cumsum(exp(theta)) } fv <- mu*NA for (i in 1:(R+1)) { ind <- mu>alpha[i] & mu<=alpha[i+1] fv[ind] <- i } res <- object$y - fv } else if (type == "deviance") { y <- object$y mu <- object$fitted.values wts <- object$prior.weights res <- object$family$dev.resids(y,mu,wts) s <- attr(res,"sign") if (is.null(s)) s <- sign(y-mu) res <- as.numeric(sqrt(pmax(res,0)) * s) } res } ## residuals predict <- function(family,se=FALSE,eta=NULL,y=NULL,X=NULL, beta=NULL,off=NULL,Vb=NULL) { ## optional function to give predicted values - idea is that ## predict.gam(...,type="response") will use this, and that ## either eta will be provided, or {X, beta, off, Vb}. family$data ## contains any family specific extra information. ocat.prob <- function(theta,lp,se=NULL) { ## compute probabilities for each class in ocat model ## theta is finite cut points, lp is linear predictor, se ## is standard error on lp... R <- length(theta) dp <- prob <- matrix(0,length(lp),R+2) prob[,R+2] <- 1 for (i in 1:R) { x <- theta[i] - lp ind <- x > 0 prob[ind,i+1] <- 1/(1+exp(-x[ind])) ex <- exp(x[!ind]) prob[!ind,i+1] <- ex/(1+ex) dp[,i+1] <- prob[,i+1]*(prob[,i+1]-1) } prob <- t(diff(t(prob))) dp <- t(diff(t(dp))) ## dprob/deta if (!is.null(se)) se <- as.numeric(se)*abs(dp) list(prob,se) } ## ocat.prob theta <- family$getTheta(TRUE) if (is.null(eta)) { ## return probabilities mu <- X%*%beta + off se <- if (se) sqrt(pmax(0,rowSums((X%*%Vb)*X))) else NULL ##theta <- cumsum(c(-1,exp(theta))) p <- ocat.prob(theta,mu,se) if (is.null(se)) return(p) else { ## approx se on prob also returned names(p) <- c("fit","se.fit") return(p) } } else { ## return category implied by eta (i.e mean of latent) R = length(theta)+2 alpha <- rep(0,R) ## the thresholds alpha[1] <- -Inf;alpha[R] <- Inf fv <- eta*NA for (i in 1:(R+1)) { ind <- eta>alpha[i] & eta<=alpha[i+1] fv[ind] <- i } return(fv) } } ## predict rd <- function(mu,wt,scale) { ## simulate data given fitted latent variable in mu theta <- get(".Theta") R = length(theta)+2 alpha <- rep(0,R+1) ## the thresholds alpha[1] <- -Inf;alpha[R+1] <- Inf alpha[2] <- -1 if (R > 2) { ind <- 3:R alpha[ind] <- alpha[2] + cumsum(exp(theta)) } ## ... cut points computed, now simulate latent variable, u y <- u <- runif(length(mu)) u <- mu + log(u/(1-u)) ## and allocate categories according to u and cut points... for (i in 1:R) { y[u > alpha[i]&u <= alpha[i+1]] <- i } y } environment(dev.resids) <- environment(aic) <- environment(putTheta) <- environment(getTheta) <- environment(rd) <- environment(predict) <- env structure(list(family = "Ordered Categorical", link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, dev.resids = dev.resids,Dd=Dd, aic = aic, mu.eta = stats$mu.eta, initialize = initialize,postproc=postproc, preinitialize = preinitialize, ls=ls,rd=rd,residuals=residuals, validmu = validmu, valideta = stats$valideta,n.theta=n.theta, ini.theta = iniTheta,putTheta=putTheta,predict=predict,step = 1, getTheta=getTheta,no.r.sq=TRUE), class = c("extended.family","family")) } ## end of ocat ####################### ## negative binomial... ####################### nb <- function (theta = NULL, link = "log") { ## Extended family object for negative binomial, to allow direct estimation of theta ## as part of REML optimization. Currently the template for extended family objects. linktemp <- substitute(link) if (!is.character(linktemp)) linktemp <- deparse(linktemp) if (linktemp %in% c("log", "identity", "sqrt")) stats <- make.link(linktemp) else if (is.character(link)) { stats <- make.link(link) linktemp <- link } else { if (inherits(link, "link-glm")) { stats <- link if (!is.null(stats$name)) linktemp <- stats$name } else stop(linktemp, " link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"") } ## Theta <- NULL; n.theta <- 1 if (!is.null(theta)&&theta!=0) { if (theta>0) { iniTheta <- log(theta) ## fixed theta supplied n.theta <- 0 ## signal that there are no theta parameters to estimate } else iniTheta <- log(-theta) ## initial theta supplied } else iniTheta <- 0 ## inital log theta value env <- new.env(parent = .GlobalEnv) assign(".Theta", iniTheta, envir = env) getTheta <- function(trans=FALSE) if (trans) exp(get(".Theta")) else get(".Theta") # get(".Theta") putTheta <- function(theta) assign(".Theta", theta,envir=environment(sys.function())) variance <- function(mu) mu + mu^2/exp(get(".Theta")) validmu <- function(mu) all(mu > 0) dev.resids <- function(y, mu, wt,theta=NULL) { if (is.null(theta)) theta <- get(".Theta") theta <- exp(theta) ## note log theta supplied 2 * wt * (y * log(pmax(1, y)/mu) - (y + theta) * log((y + theta)/(mu + theta))) } Dd <- function(y, mu, theta, wt, level=0) { ## derivatives of the deviance... ##ltheta <- theta theta <- exp(theta) yth <- y + theta muth <- mu + theta r <- list() ## get the quantities needed for IRLS. ## Dmu2eta2 is deriv of D w.r.t mu twice and eta twice, ## Dmu is deriv w.r.t. mu once, etc... r$Dmu <- 2 * wt * (yth/muth - y/mu) r$Dmu2 <- -2 * wt * (yth/muth^2 - y/mu^2) r$EDmu2 <- 2 * wt * (1/mu - 1/muth) ## exact (or estimated) expected weight if (level>0) { ## quantities needed for first derivatives r$Dth <- -2 * wt * theta * (log(yth/muth) + (1 - yth/muth) ) r$Dmuth <- 2 * wt * theta * (1 - yth/muth)/muth r$Dmu3 <- 4 * wt * (yth/muth^3 - y/mu^3) r$Dmu2th <- 2 * wt * theta * (2*yth/muth - 1)/muth^2 } if (level>1) { ## whole damn lot r$Dmu4 <- 2 * wt * (6*y/mu^4 - 6*yth/muth^4) r$Dth2 <- -2 * wt * theta * (log(yth/muth) + theta*yth/muth^2 - yth/muth - 2*theta/muth + 1 + theta /yth) r$Dmuth2 <- 2 * wt * theta * (2*theta*yth/muth^2 - yth/muth - 2*theta/muth + 1)/muth r$Dmu2th2 <- 2 * wt * theta * (- 6*yth*theta/muth^2 + 2*yth/muth + 4*theta/muth - 1) /muth^2 r$Dmu3th <- 4 * wt * theta * (1 - 3*yth/muth)/muth^3 } r } aic <- function(y, mu, theta=NULL, wt, dev) { if (is.null(theta)) theta <- get(".Theta") Theta <- exp(theta) term <- (y + Theta) * log(mu + Theta) - y * log(mu) + lgamma(y + 1) - Theta * log(Theta) + lgamma(Theta) - lgamma(Theta + y) 2 * sum(term * wt) } ls <- function(y,w,n,theta,scale) { ## the log saturated likelihood function. Theta <- exp(theta) ylogy <- y;ind <- y>0;ylogy[ind] <- y[ind]*log(y[ind]) term <- (y + Theta) * log(y + Theta) - ylogy + lgamma(y + 1) - Theta * log(Theta) + lgamma(Theta) - lgamma(Theta + y) ls <- -sum(term*w) ## first derivative wrt theta... yth <- y+Theta lyth <- log(yth) psi0.yth <- digamma(yth) psi0.th <- digamma(Theta) term <- Theta * (lyth - psi0.yth + psi0.th-theta) lsth <- -sum(term*w) ## second deriv wrt theta... psi1.yth <- trigamma(yth) psi1.th <- trigamma(Theta) term <- Theta * (lyth - Theta*psi1.yth - psi0.yth + Theta/yth + Theta * psi1.th + psi0.th - theta -1) lsth2 <- -sum(term*w) list(ls=ls, ## saturated log likelihood lsth1=lsth, ## first deriv vector w.r.t theta - last element relates to scale, if free lsth2=lsth2) ## Hessian w.r.t. theta, last row/col relates to scale, if free } initialize <- expression({ if (any(y < 0)) stop("negative values not allowed for the negative binomial family") n <- rep(1, nobs) mustart <- y + (y == 0)/6 }) postproc <- expression({ object$family$family <- paste("Negative Binomial(",round(object$family$getTheta(TRUE),3),")",sep="") }) rd <- function(mu,wt,scale) { Theta <- exp(get(".Theta")) rnbinom(mu,size=Theta,mu=mu) } qf <- function(p,mu,wt,scale) { Theta <- exp(get(".Theta")) qnbinom(p,size=Theta,mu=mu) } environment(dev.resids) <- environment(aic) <- environment(getTheta) <- environment(rd)<- environment(qf)<- environment(variance) <- environment(putTheta) <- env structure(list(family = "negative binomial", link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, dev.resids = dev.resids,Dd=Dd,variance=variance, aic = aic, mu.eta = stats$mu.eta, initialize = initialize,postproc=postproc,ls=ls, validmu = validmu, valideta = stats$valideta,n.theta=n.theta, ini.theta = iniTheta,putTheta=putTheta,getTheta=getTheta,rd=rd,qf=qf), class = c("extended.family","family")) } ## nb ## Tweedie.... tw <- function (theta = NULL, link = "log",a=1.01,b=1.99) { ## Extended family object for Tweedie, to allow direct estimation of p ## as part of REML optimization. ## p = (a+b*exp(theta))/(1+exp(theta)), i.e. a < p < b ## NOTE: The Tweedie density computation at low phi, low p is susceptible ## to cancellation error, which seems unavoidable. Furthermore ## there are known problems with spurious maxima in the likelihood ## w.r.t. p when the data are rounded. linktemp <- substitute(link) if (!is.character(linktemp)) linktemp <- deparse(linktemp) if (linktemp %in% c("log", "identity", "sqrt","inverse")) stats <- make.link(linktemp) else if (is.character(link)) { stats <- make.link(link) linktemp <- link } else { if (inherits(link, "link-glm")) { stats <- link if (!is.null(stats$name)) linktemp <- stats$name } else stop(gettextf("link \"%s\" not available for Tweedie family.", linktemp, collapse = ""), domain = NA) } ## Theta <- NULL; n.theta <- 1 if (!is.null(theta)&&theta!=0) { if (abs(theta)<=a||abs(theta)>=b) stop("Tweedie p must be in interval (a,b)") if (theta>0) { ## fixed theta supplied iniTheta <- log((theta-a)/(b-theta)) n.theta <- 0 ## so no theta to estimate } else iniTheta <- log((-theta-a)/(b+theta)) ## initial theta supplied } else iniTheta <- 0 ## inital log theta value env <- new.env(parent = .GlobalEnv) assign(".Theta", iniTheta, envir = env) assign(".a",a, envir = env);assign(".b",b, envir = env) getTheta <- function(trans=FALSE) { ## trans transforms to the original scale... th <- get(".Theta") a <- get(".a");b <- get(".b") if (trans) th <- if (th>0) (b+a*exp(-th))/(1+exp(-th)) else (b*exp(th)+a)/(exp(th)+1) th } putTheta <- function(theta) assign(".Theta", theta,envir=environment(sys.function())) validmu <- function(mu) all(mu > 0) variance <- function(mu) { th <- get(".Theta");a <- get(".a");b <- get(".b") p <- if (th>0) (b+a*exp(-th))/(1+exp(-th)) else (b*exp(th)+a)/(exp(th)+1) mu^p } dev.resids <- function(y, mu, wt,theta=NULL) { if (is.null(theta)) theta <- get(".Theta") a <- get(".a");b <- get(".b") p <- if (theta>0) (b+a*exp(-theta))/(1+exp(-theta)) else (b*exp(theta)+a)/(exp(theta)+1) y1 <- y + (y == 0) theta <- if (p == 1) log(y1/mu) else (y1^(1 - p) - mu^(1 - p))/(1 - p) kappa <- if (p == 2) log(y1/mu) else (y^(2 - p) - mu^(2 - p))/(2 - p) pmax(2 * (y * theta - kappa) * wt,0) } Dd <- function(y, mu, theta, wt, level=0) { ## derivatives of the deviance... a <- get(".a");b <- get(".b") th <- theta p <- if (th>0) (b+a*exp(-th))/(1+exp(-th)) else (b*exp(th)+a)/(exp(th)+1) dpth1 <- if (th>0) exp(-th)*(b-a)/(1+exp(-th))^2 else exp(th)*(b-a)/(exp(th)+1)^2 dpth2 <- if (th>0) ((a-b)*exp(-th)+(b-a)*exp(-2*th))/(exp(-th)+1)^3 else ((a-b)*exp(2*th)+(b-a)*exp(th))/(exp(th)+1)^3 mu1p <- mu^(1-p) mup <- mu^p r <- list() ## get the quantities needed for IRLS. ## Dmu2eta2 is deriv of D w.r.t mu twice and eta twice, ## Dmu is deriv w.r.t. mu once, etc... ymupi <- y/mup r$Dmu <- 2*wt*(mu1p - ymupi) r$Dmu2 <- 2*wt*(mu^(-1-p)*p*y + (1-p)/mup) r$EDmu2 <- (2*wt)/mup ## expected Dmu2 (weight) if (level>0) { ## quantities needed for first derivatives i1p <- 1/(1-p) y1 <- y + (y==0) ##ylogy <- y*log(y1) logmu <- log(mu) mu2p <- mu * mu1p r$Dth <- 2 * wt * ( (y^(2-p)*log(y1) - mu2p*logmu)/(2-p) + (y*mu1p*logmu - y^(2-p)*log(y1))/(1-p) - (y^(2-p) - mu2p)/(2-p)^2 + (y^(2-p) - y*mu1p)*i1p^2) *dpth1 r$Dmuth <- 2 * wt * logmu * (ymupi - mu1p)*dpth1 mup1 <- mu^(-p-1) r$Dmu3 <- -2 * wt * mup1*p*(y/mu*(p+1) + 1-p) r$Dmu2th <- 2 * wt * (mup1*y*(1-p*logmu)-(logmu*(1-p)+1)/mup )*dpth1 } if (level>1) { ## whole damn lot mup2 <- mup1/mu r$Dmu4 <- 2 * wt * mup2*p*(p+1)*(y*(p+2)/mu + 1 - p) y2plogy <- y^(2-p)*log(y1);y2plog2y <- y2plogy*log(y1) r$Dth2 <- 2 * wt * (((mu2p*logmu^2-y2plog2y)/(2-p) + (y2plog2y - y*mu1p*logmu^2)/(1-p) + 2*(y2plogy-mu2p*logmu)/(2-p)^2 + 2*(y*mu1p*logmu-y2plogy)/(1-p)^2 + 2 * (mu2p - y^(2-p))/(2-p)^3+2*(y^(2-p)-y*mu^(1-p))/(1-p)^3)*dpth1^2) + r$Dth*dpth2/dpth1 r$Dmuth2 <- 2 * wt * ((mu1p * logmu^2 - logmu^2*ymupi)*dpth1^2) + r$Dmuth*dpth2/dpth1 r$Dmu2th2 <- 2 * wt * ( (mup1 * logmu*y*(logmu*p - 2) + logmu/mup*(logmu*(1-p) + 2))*dpth1^2) + r$Dmu2th * dpth2/dpth1 r$Dmu3th <- 2 * wt * mup1*(y/mu*(logmu*(1+p)*p-p -p-1) +logmu*(1-p)*p + p - 1 + p)*dpth1 } r } aic <- function(y, mu, theta=NULL, wt, dev) { if (is.null(theta)) theta <- get(".Theta") a <- get(".a");b <- get(".b") p <- if (theta>0) (b+a*exp(-theta))/(1+exp(-theta)) else (b*exp(theta)+a)/(exp(theta)+1) scale <- dev/sum(wt) -2 * sum(ldTweedie(y, mu, p = p, phi = scale)[, 1] * wt) + 2 } ls <- function(y, w, n, theta, scale) { ## evaluate saturated log likelihood + derivs w.r.t. working params and log(scale) a <- get(".a");b <- get(".b") LS <- colSums(w * ldTweedie(y, y, rho=log(scale), theta=theta,a=a,b=b)) lsth1 <- c(LS[4],LS[2]) lsth2 <- matrix(c(LS[5],LS[6],LS[6],LS[3]),2,2) list(ls=LS[1],lsth1=lsth1,lsth2=lsth2) } initialize <- expression({ n <- rep(1, nobs) mustart <- y + (y == 0)*.1 }) postproc <- expression({ object$family$family <- paste("Tweedie(p=",round(object$family$getTheta(TRUE),3),")",sep="") }) rd <- function(mu,wt,scale) { th <- get(".Theta") a <- get(".a");b <- get(".b") p <- if (th>0) (b+a*exp(-th))/(1+exp(-th)) else (b*exp(th)+a)/(exp(th)+1) if (p == 2) rgamma(mu, shape = 1/scale, scale = mu * scale) else rTweedie(mu, p = p, phi = scale) } environment(Dd) <- environment(ls) <- environment(dev.resids) <- environment(aic) <- environment(getTheta) <- environment(rd) <- environment(variance) <- environment(putTheta) <- env structure(list(family = "Tweedie", link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, dev.resids = dev.resids,Dd=Dd,variance=variance,rd=rd, aic = aic, mu.eta = stats$mu.eta, initialize = initialize,postproc=postproc,ls=ls, validmu = validmu, valideta = stats$valideta,canonical="none",n.theta=n.theta, ini.theta = iniTheta,putTheta=putTheta,getTheta=getTheta,scale = -1), class = c("extended.family","family")) } ## tw ## beta regression betar <- function (theta = NULL, link = "logit",eps=.Machine$double.eps*100) { ## Extended family object for beta regression ## length(theta)=1; log theta supplied ## This serves as a prototype for working with -2logLik ## as deviance, and only dealing with saturated likelihood ## at the end. ## Written by Natalya Pya. 'saturated.ll' by Simon Wood linktemp <- substitute(link) if (!is.character(linktemp)) linktemp <- deparse(linktemp) if (linktemp %in% c("logit", "probit", "cloglog", "cauchit")) stats <- make.link(linktemp) else if (is.character(link)) { stats <- make.link(link) linktemp <- link } else { if (inherits(link, "link-glm")) { stats <- link if (!is.null(stats$name)) linktemp <- stats$name } else stop(linktemp, " link not available for beta regression; available links are \"logit\", \"probit\", \"cloglog\" and \"cauchit\"") } n.theta <- 1 if (!is.null(theta)&&theta!=0) { if (theta>0) { iniTheta <- log(theta) ## fixed theta supplied n.theta <- 0 ## signal that there are no theta parameters to estimate } else iniTheta <- log(-theta) ## initial theta supplied } else iniTheta <- 0 ## inital log theta value env <- new.env(parent = .GlobalEnv) assign(".Theta", iniTheta, envir = env) assign(".betarEps",eps, envir = env) getTheta <- function(trans=FALSE) if (trans) exp(get(".Theta")) else get(".Theta") putTheta <- function(theta) assign(".Theta", theta,envir=environment(sys.function())) variance <- function(mu) { th <- get(".Theta") mu*(1 - mu)/(1+exp(th)) } validmu <- function(mu) all(mu > 0 & mu < 1) dev.resids <- function(y, mu, wt,theta=NULL) { ## '-2*loglik' instead of deviance in REML/ML expression if (is.null(theta)) theta <- get(".Theta") theta <- exp(theta) ## note log theta supplied muth <- mu*theta ## yth <- y*theta 2* wt * (-lgamma(theta) +lgamma(muth) + lgamma(theta - muth) - muth*(log(y)-log1p(-y)) - theta*log1p(-y) + log(y) + log1p(-y)) } Dd <- function(y, mu, theta, wt, level=0) { ## derivatives of the -2*loglik... ## ltheta <- theta theta <- exp(theta) onemu <- 1 - mu; ## oney <- 1 - y muth <- mu*theta; ## yth <- y*theta onemuth <- onemu*theta ## (1-mu)*theta psi0.th <- digamma(theta) psi1.th <- trigamma(theta) psi0.muth <- digamma(muth) psi0.onemuth <- digamma(onemuth) psi1.muth <- trigamma(muth) psi1.onemuth <- trigamma(onemuth) psi2.muth <- psigamma(muth,2) psi2.onemuth <- psigamma(onemuth,2) psi3.muth <- psigamma(muth,3) psi3.onemuth <- psigamma(onemuth,3) log.yoney <- log(y)-log1p(-y) r <- list() ## get the quantities needed for IRLS. ## Dmu2eta2 is deriv of D w.r.t mu twice and eta twice, ## Dmu is deriv w.r.t. mu once, etc... r$Dmu <- 2 * wt * theta* (psi0.muth - psi0.onemuth - log.yoney) r$Dmu2 <- 2 * wt * theta^2*(psi1.muth+psi1.onemuth) r$EDmu2 <- r$Dmu2 if (level>0) { ## quantities needed for first derivatives r$Dth <- 2 * wt *theta*(-mu*log.yoney - log1p(-y)+ mu*psi0.muth+onemu*psi0.onemuth -psi0.th) r$Dmuth <- r$Dmu + 2 * wt * theta^2*(mu*psi1.muth -onemu*psi1.onemuth) r$Dmu3 <- 2 * wt *theta^3 * (psi2.muth - psi2.onemuth) r$Dmu2th <- 2* r$Dmu2 + 2 * wt * theta^3* (mu*psi2.muth + onemu*psi2.onemuth) } if (level>1) { ## whole lot r$Dmu4 <- 2 * wt *theta^4 * (psi3.muth+psi3.onemuth) r$Dth2 <- r$Dth +2 * wt *theta^2* (mu^2*psi1.muth+ onemu^2*psi1.onemuth-psi1.th) r$Dmuth2 <- r$Dmuth + 2 * wt *theta^2* (mu^2*theta*psi2.muth+ 2*mu*psi1.muth - theta*onemu^2*psi2.onemuth - 2*onemu*psi1.onemuth) r$Dmu2th2 <- 2*r$Dmu2th + 2* wt * theta^3* (mu^2*theta*psi3.muth +3*mu*psi2.muth+ onemu^2*theta*psi3.onemuth + 3*onemu*psi2.onemuth ) r$Dmu3th <- 3*r$Dmu3 + 2 * wt *theta^4*(mu*psi3.muth-onemu*psi3.onemuth) } r } aic <- function(y, mu, theta=NULL, wt, dev) { if (is.null(theta)) theta <- get(".Theta") theta <- exp(theta) muth <- mu*theta term <- -lgamma(theta)+lgamma(muth)+lgamma(theta-muth)-(muth-1)*log(y)- (theta-muth-1)*log1p(-y) ## `-' log likelihood for each observation 2 * sum(term * wt) } ls <- function(y,w,n,theta,scale) { ## the log saturated likelihood function. ## ls is defined as zero for REML/ML expression as deviance is defined as -2*log.lik list(ls=0,## saturated log likelihood lsth1=0, ## first deriv vector w.r.t theta - last element relates to scale lsth2=0) ##Hessian w.r.t. theta } ## preinitialization to reset G$y values of <=0 and >=1... ## code to evaluate in estimate.gam... ## reset G$y values of <=0 and >= 1 to eps and 1-eps... preinitialize <- NULL ## keep codetools happy eval(parse(text=paste("preinitialize <- expression({\n eps <- ",eps, "\n G$y[G$y >= 1-eps] <- 1 - eps\n G$y[G$y<= eps] <- eps })"))) # preinitialize <- expression({ # eps <- 1e-7 # G$y[G$y >= 1-eps] <- 1 - eps # G$y[G$y<= eps] <- eps # }) saturated.ll <- function(y,wt,theta=NULL){ ## function to find the saturated loglik by Newton method, ## searching for the mu (on logit scale) that max loglik given theta and data... gbh <- function(y,eta,phi,deriv=FALSE,a=1e-8,b=1-a) { ## local function evaluating log likelihood (l), gradient and second deriv ## vectors for beta... a and b are min and max mu values allowed. ## mu = (a + b*exp(eta))/(1+exp(eta)) ind <- eta>0 expeta <- mu <- eta; expeta[ind] <- exp(-eta[ind]);expeta[!ind] <- exp(eta[!ind]) mu[ind] <- (a*expeta[ind] + b)/(1+expeta[ind]) mu[!ind] <- (a + b*expeta[!ind])/(1+expeta[!ind]) l <- dbeta(y,phi*mu,phi*(1-mu),log=TRUE) if (deriv) { g <- phi * log(y) - phi * log1p(-y) - phi * digamma(mu*phi) + phi * digamma((1-mu)*phi) h <- -phi^2*(trigamma(mu*phi)+trigamma((1-mu)*phi)) dmueta2 <- dmueta1 <- eta dmueta1 <- expeta*(b-a)/(1+expeta)^2 dmueta2 <- sign(eta)* ((a-b)*expeta+(b-a)*expeta^2)/(expeta+1)^3 h <- h * dmueta1^2 + g * dmueta2 g <- g * dmueta1 } else g=h=NULL list(l=l,g=g,h=h,mu=mu) } ## gbh ## now Newton loop... eps <- get(".betarEps") eta <- y a <- eps;b <- 1 - eps y[y1-eps] <- 1-eps eta[y<=eps*1.2] <- eps *1.2 eta[y>=1-eps*1.2] <- 1-eps*1.2 eta <- log((eta-a)/(b-eta)) mu <- LS <- ii <- 1:length(y) for (i in 1:200) { ls <- gbh(y,eta,theta,TRUE,a=eps/10) conv <- abs(ls$g)0) { ## some convergences occured LS[ii[conv]] <- ls$l[conv] ## store converged mu[ii[conv]] <- ls$mu[conv] ## store mu at converged ii <- ii[!conv] ## drop indices if (length(ii)>0) { ## drop the converged y <- y[!conv];eta <- eta[!conv] ls$l <- ls$l[!conv];ls$g <- ls$g[!conv];ls$h <- ls$h[!conv] } else break ## nothing left to do } h <- -ls$h hmin <- max(h)*1e-4 h[h2 delta[ind] <- sign(delta[ind])*2 ## step length limit ls1 <- gbh(y,eta+delta,theta,FALSE,a=eps/10); ## did it work? ind <- ls1$l0&&k<20) { ## step halve only failed steps k <- k + 1 delta[ind] <- delta[ind]/2 ls1$l[ind] <- gbh(y[ind],eta[ind]+delta[ind],theta,FALSE,a=eps/10)$l ind <- ls1$l0) { LS[ii] <- ls$l warning("saturated likelihood may be inaccurate") } list(f=sum(wt*LS),term=LS,mu=mu) ## fields f (sat lik) and term (individual datum sat lik) expected } ## saturated.ll postproc <- expression({ ## code to evaluate in estimate.gam, to find the saturated ## loglik by Newton method ## searching for the mu (on logit scale) that max loglik given theta... wts <- object$prior.weights theta <- object$family$getTheta(trans=TRUE) ## exp theta lf <- object$family$saturated.ll(G$y, wts,theta) ## storing the saturated loglik for each datum... object$family$data <- list(ls = lf$term,mu.ls = lf$mu) l2 <- object$family$dev.resids(G$y,object$fitted.values,wts) object$deviance <- 2*lf$f + sum(l2) wtdmu <- if (G$intercept) sum(wts * G$y)/sum(wts) else object$family$linkinv(G$offset) object$null.deviance <- 2*lf$f + sum(object$family$dev.resids(G$y, wtdmu, wts)) object$family$family <- paste("Beta regression(",round(theta,3),")",sep="") }) initialize <- expression({ n <- rep(1, nobs) mustart <- y }) residuals <- function(object,type=c("deviance","working","response","pearson")) { if (type == "working") { res <- object$residuals } else if (type == "response") { res <- object$y - object$fitted.values } else if (type == "deviance") { y <- object$y mu <- object$fitted.values wts <- object$prior.weights # sim <- attr(y,"simula") # if (!is.null(sim)) { ## if response values simulated, Newton search called to get saturated log.lik lf <- object$family$saturated.ll(y, wts,object$family$getTheta(TRUE)) object$family$data$ls <- lf$term # } res <- 2*object$family$data$ls + object$family$dev.resids(y,mu,wts) res[res<0] <- 0 s <- sign(y-mu) res <- sqrt(res) * s } else if (type == "pearson") { mu <- object$fitted.values res <- (object$y - mu)/object$family$variance(mu)^.5 } res } ## residuals rd <- function(mu,wt,scale) { ## simulate data given fitted latent variable in mu Theta <- exp(get(".Theta")) r <- rbeta(mu,shape1=Theta*mu,shape2=Theta*(1-mu)) eps <- get(".betarEps") r[r>=1-eps] <- 1 - eps r[r=1-eps] <- 1 - eps q[q2") if (sum(theta<0)) { iniTheta <- c(log(abs(theta[1])-2),log(abs(theta[2]))) ## initial theta supplied } else { ## fixed theta supplied iniTheta <- c(log(theta[1]-2),log(theta[2])) n.theta <- 0 ## no thetas to estimate } } else iniTheta <- c(-2,-1) ## inital log theta value env <- new.env(parent = .GlobalEnv) assign(".Theta", iniTheta, envir = env) getTheta <- function(trans=FALSE) { ## trans transforms to the original scale... th <- get(".Theta") if (trans) { th <- exp(th); th[1] <- th[1] + 2 } th } putTheta <- function(theta) assign(".Theta", theta,envir=environment(sys.function())) variance <- function(mu) { th <- get(".Theta") nu <- exp(th[1])+2; sig <- exp(th[2]) sig^2*nu/(nu-2) } validmu <- function(mu) all(is.finite(mu)) dev.resids <- function(y, mu, wt,theta=NULL) { if (is.null(theta)) theta <- get(".Theta") nu <- exp(theta[1])+2; sig <- exp(theta[2]) wt * (nu + 1)*log1p((1/nu)*((y-mu)/sig)^2) } Dd <- function(y, mu, theta, wt, level=0) { ## derivatives of the deviance... ## ltheta <- theta nu <- exp(theta[1])+2; sig <- exp(theta[2]) nu1 <- nu + 1; ym <- y - mu; nu2 <- nu - 2; a <- 1 + (ym/sig)^2/nu oo <- list() ## get the quantities needed for IRLS. ## Dmu2eta2 is deriv of D w.r.t mu twice and eta twice, ## Dmu is deriv w.r.t. mu once, etc... nu1ym <- nu1*ym sig2a <- sig^2*a nusig2a <- nu*sig2a f <- nu1ym/nusig2a f1 <- ym/nusig2a oo$Dmu <- -2 * wt * f oo$Dmu2 <- 2 * wt * nu1*(1/nusig2a- 2*f1^2) # - 2*ym^2/(nu^2*sig^4*a^2) term <- 2*nu1/sig^2/(nu+3) n <- length(y) oo$EDmu2 <- rep(term,n) if (level>0) { ## quantities needed for first derivatives nu1nusig2a <- nu1/nusig2a nu2nu <- nu2/nu fym <- f*ym; ff1 <- f*f1; f1ym <- f1*ym; fymf1 <- fym*f1 ymsig2a <- ym/sig2a oo$Dmu2th <- oo$Dmuth <- oo$Dth <- matrix(0,n,2) oo$Dth[,1] <- 1 * wt * nu2 * (log(a) - fym/nu) oo$Dth[,2] <- -2 * wt * fym oo$Dmuth[,1] <- 2 * wt *(f - ymsig2a - fymf1)*nu2nu oo$Dmuth[,2] <- 4* wt* f* (1- f1ym) oo$Dmu3 <- 4 * wt * f * (3/nusig2a - 4*f1^2) oo$Dmu2th[,1] <- 2* wt * (-nu1nusig2a + 1/sig2a + 5*ff1- 2*f1ym/sig2a - 4*fymf1*f1)*nu2nu oo$Dmu2th[,2] <- 4*wt*(-nu1nusig2a + ff1*5 - 4*ff1*f1ym) } if (level>1) { ## whole lot ## nu1nu2 <- nu1*nu2; nu1nu <- nu1/nu fymf1ym <- fym*f1ym; f1ymf1 <- f1ym*f1 oo$Dmu4 <- 12 * wt * (-nu1nusig2a/nusig2a + 8*ff1/nusig2a - 8*ff1 *f1^2) n2d <- 3 # number of the 2nd order derivatives oo$Dmu3th <- matrix(0,n,2) oo$Dmu2th2 <- oo$Dmuth2 <- oo$Dth2 <- matrix(0,n,n2d) oo$Dmu3th[,1] <- 4*wt*(-6*f/nusig2a + 3*f1/sig2a + 18*ff1*f1 - 4*f1ymf1/sig2a - 12*nu1ym*f1^4)*nu2nu oo$Dmu3th[,2] <- 48*wt* f* (- 1/nusig2a + 3*f1^2 - 2*f1ymf1*f1) oo$Dth2[,1] <- 1*wt *(nu2*log(a) +nu2nu*ym^2*(-2*nu2-nu1+ 2*nu1*nu2nu - nu1*nu2nu*f1ym)/nusig2a) ## deriv of D w.r.t. theta1 theta1 oo$Dth2[,2] <- 2*wt*(fym - ym*ymsig2a - fymf1ym)*nu2nu ## deriv of D wrt theta1 theta2 oo$Dth2[,3] <- 4 * wt * fym *(1 - f1ym) ## deriv of D wrt theta2 theta2 term <- 2*nu2nu - 2*nu1nu*nu2nu -1 + nu1nu oo$Dmuth2[,1] <- 2*wt*f1*nu2*(term - 2*nu2nu*f1ym + 4*fym*nu2nu/nu - fym/nu - 2*fymf1ym*nu2nu/nu) oo$Dmuth2[,2] <- 4*wt* (-f + ymsig2a + 3*fymf1 - ymsig2a*f1ym - 2*fymf1*f1ym)*nu2nu oo$Dmuth2[,3] <- 8*wt* f * (-1 + 3*f1ym - 2*f1ym^2) oo$Dmu2th2[,1] <- 2*wt*nu2*(-term + 10*nu2nu*f1ym - 16*fym*nu2nu/nu - 2*f1ym + 5*nu1nu*f1ym - 8*nu2nu*f1ym^2 + 26*fymf1ym*nu2nu/nu - 4*nu1nu*f1ym^2 - 12*nu1nu*nu2nu*f1ym^3)/nusig2a oo$Dmu2th2[,2] <- 4*wt*(nu1nusig2a - 1/sig2a - 11*nu1*f1^2 + 5*f1ym/sig2a + 22*nu1*f1ymf1*f1 - 4*f1ym^2/sig2a - 12*nu1*f1ymf1^2)*nu2nu oo$Dmu2th2[,3] <- 8*wt * (nu1nusig2a - 11*nu1*f1^2 + 22*nu1*f1ymf1*f1 - 12*nu1*f1ymf1^2) } oo } ## end of Dd aic <- function(y, mu, theta=NULL, wt, dev) { if (is.null(theta)) theta <- get(".Theta") nu <- exp(theta[1])+2; sig <- exp(theta[2]) term <- -lgamma((nu+1)/2)+ lgamma(nu/2) + log(sig*(pi*nu)^.5) + (nu+1)*log1p(((y-mu)/sig)^2/nu)/2 ## `-'log likelihood for each observation 2 * sum(term * wt) } ls <- function(y,w,n,theta,scale) { ## the log saturated likelihood function. nu <- exp(theta[1])+2; sig <- exp(theta[2]); nu2 <- nu-2; nu2nu <- nu2/nu; nu12 <- (nu+1)/2 term <- lgamma(nu12) - lgamma(nu/2) - log(sig*(pi*nu)^.5) ls <- sum(term*w) ## first derivative wrt theta... lsth <- rep(0,2) lsth2 <- matrix(0,2,2) ## rep(0, 3) term <- nu2 * digamma(nu12)/2- nu2 * digamma(nu/2)/2 - 0.5*nu2nu lsth[1] <- sum(w*term) lsth[2] <- sum(-1*w) ## second deriv... term <- nu2^2 * trigamma(nu12)/4 + nu2 * digamma(nu12)/2 - nu2^2 * trigamma(nu/2)/4 - nu2 * digamma(nu/2)/2 + 0.5*(nu2nu)^2 - 0.5*nu2nu lsth2[1,1] <- sum(term*w) lsth2[1,2] <- lsth2[2,1] <- lsth2[2,2] <- 0 list(ls=ls,## saturated log likelihood lsth1=lsth, ## first derivative vector wrt theta lsth2=lsth2) ## Hessian wrt theta } preinitialize <- expression({ ## initialize theta from raw observations.. if (G$family$n.theta>0) { Theta <- c(-1, log(0.2*var(G$y)^.5)) G$family$putTheta(Theta) } ## otherwise fixed theta supplied }) initialize <- expression({ if (any(is.na(y))) stop("NA values not allowed for the scaled t family") n <- rep(1, nobs) mustart <- y + (y == 0)*.1 }) postproc <- expression({ object$family$family <- paste("Scaled t(",paste(round(object$family$getTheta(TRUE),3),collapse=","),")",sep="") }) rd <- function(mu,wt,scale) { ## simulate data given fitted latent variable in mu theta <- get(".Theta") nu <- exp(theta[1])+2; sig <- exp(theta[2]) n <- length(mu) stats::rt(n=n,df=nu)*sig + mu } environment(dev.resids) <- environment(aic) <- environment(getTheta) <- environment(rd)<- environment(variance) <- environment(putTheta) <- env structure(list(family = "scaled t", link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, dev.resids = dev.resids,Dd=Dd,variance=variance,postproc=postproc, aic = aic, mu.eta = stats$mu.eta, initialize = initialize,ls=ls, preinitialize=preinitialize, validmu = validmu, valideta = stats$valideta,n.theta=n.theta, ini.theta = iniTheta,putTheta=putTheta,getTheta=getTheta, rd=rd), class = c("extended.family","family")) } ## scat ## zero inflated Poisson (Simon Wood)... lind <- function(l,th,deriv=0,k=0) { ## evaluate th[1] + exp(th[2])*l and some derivs th[2] <- exp(th[2]) r <- list(p = th[1] + (k+th[2])*l) r$p.l <- k + th[2] ## p_l r$p.ll <- 0 ## p_ll if (deriv) { n <- length(l); r$p.lllth <- r$p.llth <- r$p.lth <- r$p.th <- matrix(0,n,2) r$p.th[,1] <- 1 ## dp/dth1 r$p.th[,2] <- th[2]*l ## dp/dth2 r$p.lth[,2] <- th[2] ## p_lth2 r$p.llll <- r$p.lll <- 0 ## p_lll,p_llll r$p.llth2 <- r$p.lth2 <- r$p.th2 <- matrix(0,n,3) ## ordered l_th1th1,l_th1th2,l_th2th2 r$p.th2[,3] <- l*th[2] ## p_th2th2 r$p.lth2[,3] <- th[2] ## p_lth2th2 } r } ## lind logid <- function(l,th,deriv=0,a=0,trans=TRUE) { ## evaluate exp(th[1]+th[2]*l)/(1+exp(th[1]+th[2]*l)) ## and some of its derivatives ## if trans==TRUE then it is assumed that the ## transformation th[2] = exp(th[2]) is applied on input b <- 1-2*a ## x is dth[2]/dth[2]' where th[2]' is input version, xx is second deriv over first if (trans) { xx <- 1; x <- th[2] <- exp(th[2])} else { x <- 1;xx <- 0} p <- f <- th[1] + th[2] * l ind <- f > 0; ef <- exp(f[!ind]) p[!ind] <- ef/(1+ef); p[ind] <- 1/(1+exp(-f[ind])) r <- list(p = a + b * p) a1 <- p*(1-p); a2 <- p*(p*(2*p-3)+1) r$p.l <- b * th[2]*a1; ## p_l r$p.ll <- b * th[2]^2*a2 ## p_ll if (deriv>0) { n <- length(l); r$p.lth <- r$p.th <- matrix(0,n,2) r$p.th[,1] <- b * a1 ## dp/dth1 r$p.th[,2] <- b * l*a1 * x ## dp/dth2 r$p.lth[,1] <- b * th[2]*a2 ## p_lth1 r$p.lth[,2] <- b * (l*th[2]*a2 + a1) * x ## p_lth2 a3 <- p*(p*(p*(-6*p + 12) -7)+1) r$p.lll <- b * th[2]^3*a3 ## p_lll r$p.llth <- matrix(0,n,2) r$p.llth[,1] <- b * th[2]^2 * a3 ## p_llth1 r$p.llth[,2] <- b * (l*th[2]^2*a3 + 2*th[2]*a2) * x ## p_ppth2 a4 <- p*(p*(p*(p*(p*24-60)+50)-15)+1) r$p.llll <- b * th[2]^4*a4 ## p_llll r$p.lllth <- matrix(0,n,2) r$p.lllth[,1] <- b * th[2]^3*a4 ## p_lllth1 r$p.lllth[,2] <- b * (th[2]^3*l*a4 + 3*th[2]^2*a3) * x ## p_lllth2 r$p.llth2 <- r$p.lth2 <- r$p.th2 <- matrix(0,n,3) ## ordered l_th1th1,l_th1th2,l_th2th2 r$p.th2[,1] <- b * a2 ## p_th1th1 r$p.th2[,2] <- b * l*a2 * x ## p_th1th2 r$p.th2[,3] <- b * l*l*a2 * x * x + xx* r$p.th[,2] ## p_th2th2 r$p.lth2[,1] <- b * th[2]*a3 ## p_lth1th1 r$p.lth2[,2] <- b * (th[2]*l*a3 + a2) * x ## p_lth1th2 r$p.lth2[,3] <- b * (l*l*a3*th[2] + 2*l*a2) *x * x + xx*r$p.lth[,2] ## p_lth2th2 r$p.llth2[,1] <- b * th[2]^2*a4 ## p_llth1th1 r$p.llth2[,2] <- b * (th[2]^2*l*a4 + 2*th[2]*a3) *x ## p_llth1th2 r$p.llth2[,3] <- b * (l*l*th[2]^2*a4 + 4*l*th[2]*a3 + 2*a2) *x*x + xx*r$p.llth[,2] ## p_llth2th2 } r } ## logid ziP <- function (theta = NULL, link = "identity",b=0) { ## zero inflated Poisson parameterized in terms of the log Poisson parameter, gamma. ## eta = theta[1] + exp(theta[2])*gamma), and 1-p = exp(-exp(eta)) where p is ## probability of presence. linktemp <- substitute(link) if (!is.character(linktemp)) linktemp <- deparse(linktemp) if (linktemp %in% c("identity")) { stats <- make.link(linktemp) } else stop(linktemp, " link not available for zero inflated; available link for `lambda' is only \"loga\"") ## Theta <- NULL; n.theta <- 2 if (!is.null(theta)) { ## fixed theta supplied iniTheta <- c(theta[1],theta[2]) n.theta <- 0 ## no thetas to estimate } else iniTheta <- c(0,0) ## inital theta value - start at Poisson env <- new.env(parent = environment(ziP))# new.env(parent = .GlobalEnv) if (b<0) b <- 0; assign(".b", b, envir = env) assign(".Theta", iniTheta, envir = env) getTheta <- function(trans=FALSE) { ## trans transforms to the original scale... th <- get(".Theta") if (trans) { th[2] <- get(".b") + exp(th[2]) } th } putTheta <- function(theta) assign(".Theta", theta,envir=environment(sys.function())) validmu <- function(mu) all(is.finite(mu)) dev.resids <- function(y, mu, wt,theta=NULL) { ## this version ignores saturated likelihood if (is.null(theta)) theta <- get(".Theta") b <- get(".b") p <- theta[1] + (b + exp(theta[2])) * mu ## l.p. for prob present -2*zipll(y,mu,p,deriv=0)$l } Dd <- function(y, mu, theta, wt=NULL, level=0) { ## here mu is lin pred for Poisson mean so E(y) = exp(mu) ## Deviance for log lik of zero inflated Poisson. ## code here is far more general than is needed - could deal ## with any 2 parameter mapping of lp of mean to lp of prob presence. if (is.null(theta)) theta <- get(".Theta") deriv <- 1; if (level==1) deriv <- 2 else if (level>1) deriv <- 4 b <- get(".b") g <- lind(mu,theta,level,b) ## the derviatives of the transform mapping mu to p z <- zipll(y,mu,g$p,deriv) oo <- list();n <- length(y) if (is.null(wt)) wt <- rep(1,n) oo$Dmu <- -2*wt*(z$l1[,1] + z$l1[,2]*g$p.l) oo$Dmu2 <- -2*wt*(z$l2[,1] + 2*z$l2[,2]*g$p.l + z$l2[,3]*g$p.l^2 + z$l1[,2]*g$p.ll) ## WARNING: following requires z$El1 term to be added if transform modified so ## that g$p.ll != 0.... oo$EDmu2 <- -2*wt*(z$El2[,1] + 2*z$El2[,2]*g$p.l + z$El2[,3]*g$p.l^2) if (level>0) { ## l,p - ll,lp,pp - lll,llp,lpp,ppp - llll,lllp,llpp,lppp,pppp oo$Dth <- -2*wt*z$l1[,2]*g$p.th ## l_p p_th oo$Dmuth <- -2*wt*(z$l2[,2]*g$p.th + z$l2[,3]*g$p.l*g$p.th + z$l1[,2]*g$p.lth) oo$Dmu2th <- -2*wt*(z$l3[,2]*g$p.th + 2*z$l3[,3]*g$p.l*g$p.th + 2* z$l2[,2]*g$p.lth + z$l3[,4]*g$p.l^2*g$p.th + z$l2[,3]*(2*g$p.l*g$p.lth + g$p.th*g$p.ll) + z$l1[,2]*g$p.llth) oo$Dmu3 <- -2*wt*(z$l3[,1] + 3*z$l3[,2]*g$p.l + 3*z$l3[,3]*g$p.l^2 + 3*z$l2[,2]*g$p.ll + z$l3[,4]*g$p.l^3 +3*z$l2[,3]*g$p.l*g$p.ll + z$l1[,2]*g$p.lll) } if (level>1) { p.thth <- matrix(0,n,3);p.thth[,1] <- g$p.th[,1]^2 p.thth[,2] <- g$p.th[,1]*g$p.th[,2];p.thth[,3] <- g$p.th[,2]^2 oo$Dth2 <- -2*wt*(z$l2[,3]*p.thth + z$l1[,2]*g$p.th2) p.lthth <- matrix(0,n,3);p.lthth[,1] <- g$p.th[,1]*g$p.lth[,1]*2 p.lthth[,2] <- g$p.th[,1]*g$p.lth[,2] + g$p.th[,2]*g$p.lth[,1]; p.lthth[,3] <- g$p.th[,2]*g$p.lth[,2]*2 oo$Dmuth2 <- -2*wt*( z$l3[,3]*p.thth + z$l2[,2]*g$p.th2 + z$l3[,4]*g$p.l*p.thth + z$l2[,3]*(g$p.th2*g$p.l + p.lthth) + z$l1[,2]*g$p.lth2) p.lthlth <- matrix(0,n,3);p.lthlth[,1] <- g$p.lth[,1]*g$p.lth[,1]*2 p.lthlth[,2] <- g$p.lth[,1]*g$p.lth[,2] + g$p.lth[,2]*g$p.lth[,1]; p.lthlth[,3] <- g$p.lth[,2]*g$p.lth[,2]*2 p.llthth <- matrix(0,n,3);p.llthth[,1] <- g$p.th[,1]*g$p.llth[,1]*2 p.llthth[,2] <- g$p.th[,1]*g$p.llth[,2] + g$p.th[,2]*g$p.llth[,1]; p.llthth[,3] <- g$p.th[,2]*g$p.llth[,2]*2 oo$Dmu2th2 <- -2*wt*(z$l4[,3]*p.thth + z$l3[,2]*g$p.th2 + 2*z$l4[,4] * p.thth *g$p.l + 2*z$l3[,3]*(g$p.th2*g$p.l + p.lthth) + 2*z$l2[,2]*g$p.lth2 + z$l4[,5]*p.thth*g$p.l^2 + z$l3[,4]*(g$p.th2*g$p.l^2 + 2*p.lthth*g$p.l + p.thth*g$p.ll) + z$l2[,3]*(p.lthlth + 2*g$p.l*g$p.lth2 + p.llthth + g$p.th2*g$p.ll) + z$l1[,2]*g$p.llth2) oo$Dmu3th <- -2*wt*(z$l4[,2]*g$p.th + 3*z$l4[,3]*g$p.th*g$p.l + 3*z$l3[,2]*g$p.lth + 2*z$l4[,4]*g$p.th*g$p.l^2 + z$l3[,3]*(6*g$p.lth*g$p.l + 3*g$p.th*g$p.ll) + 3*z$l2[,2]*g$p.llth + z$l4[,4]*g$p.th*g$p.l^2 + z$l4[,5]*g$p.th*g$p.l^3 + 3*z$l3[,4]*(g$p.l^2*g$p.lth + g$p.th*g$p.l*g$p.ll) + z$l2[,3]*(3*g$p.lth*g$p.ll + 3*g$p.l*g$p.llth + g$p.th*g$p.lll) + z$l1[,2]*g$p.lllth) oo$Dmu4 <- -2*wt*(z$l4[,1] + 4*z$l4[,2]*g$p.l + 6*z$l4[,3]*g$p.l^2 + 6*z$l3[,2]*g$p.ll + 4*z$l4[,4]*g$p.l^3 + 12*z$l3[,3]*g$p.l*g$p.ll + 4*z$l2[,2]*g$p.lll + z$l4[,5] * g$p.l^4 + 6*z$l3[,4]*g$p.l^2*g$p.ll + z$l2[,3] *(4*g$p.l*g$p.lll + 3*g$p.ll^2) + z$l1[,2]*g$p.llll) } oo } ## end Dd for ziP aic <- function(y, mu, theta=NULL, wt, dev) { if (is.null(theta)) theta <- get(".Theta") b <- get(".b") p <- theta[1] + (b+ exp(theta[2])) * mu ## l.p. for prob present sum(-2*wt*zipll(y,mu,p,0)$l) } ls <- function(y,w,n,theta,scale) { ## the log saturated likelihood function. ## ls is defined as zero for REML/ML expression as deviance is defined as -2*log.lik list(ls=0,## saturated log likelihood lsth1=c(0,0), ## first deriv vector w.r.t theta - last element relates to scale lsth2=matrix(0,2,2)) ##Hessian w.r.t. theta } initialize <- expression({ if (any(y < 0)) stop("negative values not allowed for the zero inflated Poisson family") if (all.equal(y,round(y))!=TRUE) { stop("Non-integer response variables are not allowed with ziP ") } if ((min(y)==0&&max(y)==1)) stop("Using ziP for binary data makes no sense") n <- rep(1, nobs) mustart <- log(y + (y==0)/5) }) postproc <- expression({ object$family$family <- paste("Zero inflated Poisson(",paste(round(object$family$getTheta(TRUE),3),collapse=","),")",sep="") ## need to fix deviance here!! ## wts <- object$prior.weights lf <- object$family$saturated.ll(G$y,family, object$prior.weights) ## storing the saturated loglik for each datum... object$family$data <- list(ls = lf) l2 <- object$family$dev.resids(G$y,object$linear.predictors,object$prior.weights) object$deviance <- sum(l2-lf) fnull <- function(gamma,object) { ## evaluate deviance for single parameter model sum(object$family$dev.resids(object$y, rep(gamma,length(object$y)), object$prior.weights)) } meany <- mean(object$y) object$null.deviance <- optimize(fnull,interval=c(meany/5,meany*3),object=object)$objective - sum(lf) ## object$weights <- pmax(0,object$working.weights) ## Fisher can be too extreme ## E(y) = p * E(y) - but really can't mess with fitted.values if e.g. rd is to work. }) # fv <- function(lp,theta=NULL) { # ## optional function to give fitted values... # if (is.null(theta)) theta <- get(".Theta") # th1 <- theta[1]; th2 <- exp(theta[2]); # eta <- th1 + th2*lp # p <- 1 - exp(-exp(eta)) # fv <- lambda <- exp(lp) # ind <- lp < log(.Machine$double.eps)/2 # fv[!ind] <- p[!ind] * lambda[!ind]/(1-exp(-lambda[!ind])) # fv[ind] <- p[ind] # fv # } ## fv rd <- function(mu,wt,scale) { ## simulate data given fitted latent variable in mu rzip <- function(gamma,theta) { ## generate ziP deviates according to model and lp gamma y <- gamma; n <- length(y) lambda <- exp(gamma) mlam <- max(c(lambda[is.finite(lambda)],.Machine$double.eps^.2)) lambda[!is.finite(lambda)] <- mlam b <- get(".b") eta <- theta[1] + (b+exp(theta[2]))*gamma p <- 1- exp(-exp(eta)) ind <- p > runif(n) y[!ind] <- 0 #np <- sum(ind) ## generate from zero truncated Poisson, given presence... lami <- lambda[ind] yi <- p0 <- dpois(0,lami) nearly1 <- 1 - .Machine$double.eps*10 ii <- p0 > nearly1 yi[ii] <- 1 ## lambda so low that almost certainly y=1 yi[!ii] <- qpois(runif(sum(!ii),p0[!ii],nearly1),lami[!ii]) y[ind] <- yi y } rzip(mu,get(".Theta")) } saturated.ll <- function(y,family,wt=rep(1,length(y))) { ## function to get saturated ll for ziP - ## actually computes -2 sat ll. pind <- y>0 ## only these are interesting wt <- wt[pind] y <- y[pind]; mu <- log(y) keep.on <- TRUE theta <- family$getTheta() r <- family$Dd(y,mu,theta,wt) l <- family$dev.resids(y,mu,wt,theta) lmax <- max(abs(l)) ucov <- abs(r$Dmu) > lmax*1e-7 k <- 0 while (keep.on) { step <- -r$Dmu/r$Dmu2 step[!ucov] <- 0 mu1 <- mu + step l1 <- family$dev.resids(y,mu1,wt,theta) ind <- l1>l & ucov kk <- 0 while (sum(ind)>0&&kk<50) { step[ind] <- step[ind]/2 mu1 <- mu + step l1 <- family$dev.resids(y,mu1,wt,theta) ind <- l1>l & ucov kk <- kk + 1 } mu <- mu1;l <- l1 r <- family$Dd(y,mu,theta,wt) ucov <- abs(r$Dmu) > lmax*1e-7 k <- k + 1 if (all(!ucov)||k==100) keep.on <- FALSE } l1 <- rep(0,length(pind));l1[pind] <- l l1 } ## saturated.ll residuals <- function(object,type=c("deviance","working","response")) { if (type == "working") { res <- object$residuals } else if (type == "response") { res <- object$y - predict.gam(object,type="response") } else if (type == "deviance") { y <- object$y mu <- object$linear.predictors wts <- object$prior.weights res <- object$family$dev.resids(y,mu,wts) res <- res - object$family$saturated.ll(y,object$family,wts) fv <- predict.gam(object,type="response") s <- attr(res,"sign") if (is.null(s)) s <- sign(y-fv) res <- as.numeric(sqrt(pmax(res,0)) * s) } res } ## residuals predict <- function(family,se=FALSE,eta=NULL,y=NULL,X=NULL, beta=NULL,off=NULL,Vb=NULL) { ## optional function to give predicted values - idea is that ## predict.gam(...,type="response") will use this, and that ## either eta will be provided, or {X, beta, off, Vb}. family$data ## contains any family specific extra information. theta <- family$getTheta() if (is.null(eta)) { ## return probabilities gamma <- drop(X%*%beta + off) ## linear predictor for poisson parameter se <- if (se) drop(sqrt(pmax(0,rowSums((X%*%Vb)*X)))) else NULL ## se of lin pred } else { se <- NULL; gamma <- eta} ## now compute linear predictor for probability of presence... b <- get(".b") eta <- theta[1] + (b+exp(theta[2]))*gamma et <- exp(eta) mu <- p <- 1 - exp(-et) fv <- lambda <- exp(gamma) ind <- gamma < log(.Machine$double.eps)/2 mu[!ind] <- lambda[!ind]/(1-exp(-lambda[!ind])) mu[ind] <- 1 fv <- list(p*mu) ## E(y) if (is.null(se)) return(fv) else { dp.dg <- p ind <- eta < log(.Machine$double.xmax)/2 dp.dg[!ind] <- 0 dp.dg <- exp(-et)*et*exp(theta[2]) dmu.dg <- (lambda + 1)*mu - mu^2 fv[[2]] <- abs(dp.dg*mu+dmu.dg*p)*se names(fv) <- c("fit","se.fit") return(fv) } } ## predict environment(saturated.ll) <- environment(dev.resids) <- environment(Dd) <- environment(aic) <- environment(getTheta) <- environment(rd) <- environment(predict) <- environment(putTheta) <- env structure(list(family = "zero inflated Poisson", link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, dev.resids = dev.resids,Dd=Dd, rd=rd,residuals=residuals, aic = aic, mu.eta = stats$mu.eta, g2g = stats$g2g,g3g=stats$g3g, g4g=stats$g4g, #preinitialize=preinitialize, initialize = initialize,postproc=postproc,ls=ls,no.r.sq=TRUE, validmu = validmu, valideta = stats$valideta,n.theta=n.theta,predict=predict, ini.theta = iniTheta,putTheta=putTheta,getTheta=getTheta,saturated.ll = saturated.ll), class = c("extended.family","family")) } ## ziP mgcv/R/coxph.r0000644000177400001440000002040612757634153013124 0ustar murdochusers## (c) Simon N. Wood (2013, 2014) coxph model general family. ## Released under GPL2 ... cox.ph <- function (link = "identity") { ## Extended family object for Cox PH. linktemp <- substitute(link) if (!is.character(linktemp)) linktemp <- deparse(linktemp) if (linktemp %in% c("identity")) stats <- make.link(linktemp) else if (is.character(link)) { stats <- make.link(link) linktemp <- link } else { if (inherits(link, "link-glm")) { stats <- link if (!is.null(stats$name)) linktemp <- stats$name } else stop(linktemp, " link not available for coxph family; available link is \"identity\" ") } env <- new.env(parent = .GlobalEnv) validmu <- function(mu) all(is.finite(mu)) ## initialization is tough here... need data frame in reverse time order, ## and intercept removed from X... preinitialize <- expression({ ## code to evaluate in estimate.gam... ## sort y (time) into decending order, and ## re-order weights and rows of X accordingly G$family$data <- list() y.order <- order(G$y,decreasing=TRUE) G$family$data$y.order <- y.order G$y <- G$y[y.order] attrX <- attributes(G$X) G$X <- G$X[y.order,,drop=FALSE] attributes(G$X) <- attrX G$w <- G$w[y.order] }) postproc <- expression({ ## code to evaluate in estimate.gam, to do with data ordering and ## baseline hazard estimation... ## first get the estimated hazard and prediction information... G$X <- Sl.initial.repara(G$Sl,G$X,inverse=TRUE,cov=FALSE,both.sides=FALSE) object$family$data <- G$family$hazard(G$y,G$X,object$coefficients,G$w) rumblefish <- G$family$hazard(G$y,matrix(0,nrow(G$X),0),object$coefficients,G$w) s0.base <- exp(-rumblefish$h[rumblefish$r]) ## no model baseline survival s0.base[s0.base >= 1] <- 1 - 2*.Machine$double.eps ## avoid NA later ## now put the survivor function in object$fitted object$fitted.values <- exp(-object$family$data$h[object$family$data$r]*exp(object$linear.predictors)) ## compute the null deviance... s.base <- exp(-object$family$data$h[object$family$data$r]) ## baseline survival s.base[s.base >= 1] <- 1 - 2*.Machine$double.eps ## avoid NA later object$null.deviance <- ## sum of squares of null deviance residuals 2*sum(abs((object$prior.weights + log(s0.base) + object$prior.weights*(log(-log(s0.base)))))) ## and undo the re-ordering... object$linear.predictors[y.order] <- object$linear.predictors object$fitted.values[y.order] <- object$fitted.values object$y[y.order] <- object$y object$prior.weights[y.order] <- object$prior.weights }) initialize <- expression({ n <- rep(1, nobs) if (is.null(start)) start <- rep(0,ncol(x)) }) hazard <- function(y, X,beta,wt) { ## get the baseline hazard function information, given times in descending order in y ## model matrix (same ordering) in X, coefs in beta and censoring in wt (1 = death, 0 ## = censoring) tr <- unique(y);r <- match(y,tr);nt <- length(tr) oo <- .C("coxpp",as.double(X%*%beta),A=as.double(X),as.integer(r),d=as.integer(wt), h=as.double(rep(0,nt)),q=as.double(rep(0,nt)),km=as.double(rep(0,nt)), n=as.integer(nrow(X)),p=as.integer(ncol(X)), nt=as.integer(nt),PACKAGE="mgcv") p <- ncol(X) list(tr=tr,h=oo$h,q=oo$q,a=matrix(oo$A[1:(p*nt)],p,nt),nt=nt,r=r,km=oo$km) } residuals <- function(object,type=c("deviance","martingale")) { type <- match.arg(type) w <- object$prior.weights;log.s <- log(object$fitted.values) res <- w + log.s ## martingale residuals if (type=="deviance") { log.s[log.s>-1e-50] <- -1e-50 res <- sign(res)*sqrt(-2*(res + w * log(-log.s))) } res } predict <- function(family,se=FALSE,eta=NULL,y=NULL, X=NULL,beta=NULL,off=NULL,Vb=NULL) { ## prediction function. if (sum(is.na(y))>0) stop("NA times supplied for cox.ph prediction") ii <- order(y,decreasing=TRUE) ## C code expects non-increasing n <- nrow(X) oo <- .C("coxpred",as.double(X[ii,]),t=as.double(y[ii]),as.double(beta),as.double(Vb), a=as.double(family$data$a),h=as.double(family$data$h),q=as.double(family$data$q), tr = as.double(family$data$tr), n=as.integer(n),p=as.integer(ncol(X)),nt = as.integer(family$data$nt), s=as.double(rep(0,n)),se=as.double(rep(0,n)),PACKAGE="mgcv") s <- sef <- oo$s s[ii] <- oo$s sef[ii] <- oo$se if (se) return(list(fit=s,se.fit=sef)) else return(list(fit=s)) } rd <- qf <- NULL ## these functions currently undefined for Cox PH ll <- function(y,X,coef,wt,family,offset=NULL,deriv=0,d1b=0,d2b=0,Hp=NULL,rank=0,fh=NULL,D=NULL) { ## function defining the cox model log lik. ## Calls C code "coxlpl" ## deriv codes: 0 - evaluate the log likelihood ## 1 - evaluate the grad and Hessian, H, of log lik w.r.t. coefs (beta) ## 2/3 - evaluate d1H =dH/drho given db/drho in d1b ## (2 is for evaluation of diagonal only) ## 4 - given d1b and d2b evaluate trHid2H= tr(Hp^{-1}d2H/drhodrho') ## Hp is the preconditioned penalized hessian of the log lik ## which is of rank 'rank'. ## fh is a factorization of Hp - either its eigen decomposition ## or its Choleski factor ## D is the diagonal pre-conditioning matrix used to obtain Hp ## if Hr is the raw Hp then Hp = D*t(D*Hr) if (!is.null(offset)&&sum(offset!=0)) stop("cox.ph does not yet handle offsets") ##tr <- sort(unique(y),decreasing=TRUE) tr <- unique(y) r <- match(y,tr) p <- ncol(X) deriv <- deriv - 1 mu <- X%*%coef g <- rep(0,p);H <- rep(0,p*p) if (deriv > 0) { M <- ncol(d1b) d1H <- if (deriv==1) rep(0,p*M) else rep(0,p*p*M) } else M <- d1H <- 0 if (deriv > 2) { d2H <- rep(0,p*M*(M+1)/2) if (is.list(fh)) { ev <- fh } else { ## need to compute eigen here ev <- eigen(Hp,symmetric=TRUE) if (rank < p) ev$values[(rank+1):p] <- 0 } X <- X%*%(ev$vectors*D) d1b <- t(ev$vectors)%*%(d1b/D); d2b <- t(ev$vectors)%*%(d2b/D) } else trHid2H <- d2H <- 0 ## note that the following call can not use .C(C_coxlpl,...) since the ll ## function is not in the mgcv namespace. oo <- .C("coxlpl",as.double(mu),as.double(X),as.integer(r),as.integer(wt), as.double(tr),n=as.integer(length(y)),p=as.integer(p),nt=as.integer(length(tr)), lp=as.double(0),g=as.double(g),H=as.double(H), d1b=as.double(d1b),d1H=as.double(d1H),d2b=as.double(d2b),d2H=as.double(d2H), n.sp=as.integer(M),deriv=as.integer(deriv),PACKAGE="mgcv"); if (deriv==1) d1H <- matrix(oo$d1H,p,M) else if (deriv>1) { ind <- 1:(p^2) d1H <- list() for (i in 1:M) { d1H[[i]] <- matrix(oo$d1H[ind],p,p) ind <- ind + p^2 } } if (deriv>2) { d2H <- matrix(oo$d2H,p,M*(M+1)/2) #trHid2H <- colSums(d2H) d <- ev$values d[d>0] <- 1/d[d>0];d[d<=0] <- 0 trHid2H <- colSums(d2H*d) } assign(".log.partial.likelihood", oo$lp, envir=environment(sys.function())) list(l=oo$lp,lb=oo$g,lbb=matrix(oo$H,p,p),d1H=d1H,d2H=d2H,trHid2H=trHid2H) } # environment(dev.resids) <- environment(aic) <- environment(getTheta) <- # environment(rd)<- environment(qf)<- environment(variance) <- environment(putTheta) #environment(aic) <- environment(ll) <- env structure(list(family = "Cox PH", link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, ll=ll, ## aic = aic, mu.eta = stats$mu.eta, initialize = initialize,preinitialize=preinitialize,postproc=postproc, hazard=hazard,predict=predict,residuals=residuals, validmu = validmu, valideta = stats$valideta, rd=rd,qf=qf,drop.intercept = TRUE, ls=1, ## signal ls not needed available.derivs = 2 ## can use full Newton here ), class = c("general.family","extended.family","family")) } ## cox.ph mgcv/R/gam.fit3.r0000755000177400001440000037604413042644346013423 0ustar murdochusers## R routines for gam fitting with calculation of derivatives w.r.t. sp.s ## (c) Simon Wood 2004-2013 ## These routines are for type 3 gam fitting. The basic idea is that a P-IRLS ## is run to convergence, and only then is a scheme for evaluating the ## derivatives via the implicit function theorem used. gam.reparam <- function(rS,lsp,deriv) ## Finds an orthogonal reparameterization which avoids `dominant machine zero leakage' between ## components of the square root penalty. ## rS is the list of the square root penalties: last entry is root of fixed. ## penalty, if fixed.penalty=TRUE (i.e. length(rS)>length(sp)) ## lsp is the vector of log smoothing parameters. ## *Assumption* here is that rS[[i]] are in a null space of total penalty already; ## see e.g. totalPenaltySpace & mini.roots ## Ouputs: ## S -- the total penalty matrix similarity transformed for stability ## rS -- the component square roots, transformed in the same way ## Qs -- the orthogonal transformation matrix S = t(Qs)%*%S0%*%Qs, where S0 is the ## untransformed total penalty implied by sp and rS on input ## E -- the square root of the transformed S (obtained in a stable way by pre-conditioning) ## det -- log |S| ## det1 -- dlog|S|/dlog(sp) if deriv >0 ## det2 -- hessian of log|S| wrt log(sp) if deriv>1 { q <- nrow(rS[[1]]) rSncol <- unlist(lapply(rS,ncol)) M <- length(lsp) if (length(rS)>M) fixed.penalty <- TRUE else fixed.penalty <- FALSE d.tol <- .Machine$double.eps^.3 ## group `similar sized' penalties, to save work r.tol <- .Machine$double.eps^.75 ## This is a bit delicate -- too large and penalty range space can be supressed. oo <- .C(C_get_stableS,S=as.double(matrix(0,q,q)),Qs=as.double(matrix(0,q,q)),sp=as.double(exp(lsp)), rS=as.double(unlist(rS)), rSncol = as.integer(rSncol), q = as.integer(q), M = as.integer(M), deriv=as.integer(deriv), det = as.double(0), det1 = as.double(rep(0,M)),det2 = as.double(matrix(0,M,M)), d.tol = as.double(d.tol), r.tol = as.double(r.tol), fixed_penalty = as.integer(fixed.penalty)) S <- matrix(oo$S,q,q) S <- (S+t(S))*.5 p <- abs(diag(S))^.5 ## by Choleski, p can not be zero if S +ve def p[p==0] <- 1 ## but it's possible to make a mistake!! ##E <- t(t(chol(t(t(S/p)/p)))*p) St <- t(t(S/p)/p) St <- (St + t(St))*.5 ## force exact symmetry -- avoids very rare mroot fails E <- t(mroot(St,rank=q)*p) ## the square root S, with column separation Qs <- matrix(oo$Qs,q,q) ## the reparameterization matrix t(Qs)%*%S%*%Qs -> S k0 <- 1 for (i in 1:length(rS)) { ## unpack the rS in the new space crs <- ncol(rS[[i]]); k1 <- k0 + crs * q - 1 rS[[i]] <- matrix(oo$rS[k0:k1],q,crs) k0 <- k1 + 1 } ## now get determinant + derivatives, if required... if (deriv > 0) det1 <- oo$det1 else det1 <- NULL if (deriv > 1) det2 <- matrix(oo$det2,M,M) else det2 <- NULL list(S=S,E=E,Qs=Qs,rS=rS,det=oo$det,det1=det1,det2=det2,fixed.penalty = fixed.penalty) } ## gam.reparam get.Eb <- function(rS,rank) ## temporary routine to get balanced sqrt of total penalty ## should eventually be moved to estimate.gam, or gam.setup, ## as it's sp independent, but that means re doing gam.fit3 call list, ## which should only be done after method is tested { q <- nrow(rS[[1]]) S <- matrix(0,q,q) for (i in 1:length(rS)) { Si <- tcrossprod(rS[[i]]) ## rS[[i]]%*%t(rS[[i]]) S <- S + Si/sqrt(sum(Si^2)) } t(mroot(S,rank=rank)) ## E such that E'E = S } ## get.Eb huberp <- function(wp,dof,k=1.5,tol=.Machine$double.eps^.5) { ## function to obtain huber estimate of scale from Pearson residuals, simplified ## from 'hubers' from MASS package s0 <- mad(wp) ## initial scale estimate th <- 2*pnorm(k) - 1 beta <- th + k^2 * (1 - th) - 2 * k * dnorm(k) for (i in 1:50) { r <- pmin(pmax(wp,-k*s0),k*s0) ss <- sum(r^2)/dof s1 <- sqrt(ss/beta) if (abs(s1-s0) 0 kd[ind] <- wd[ind]*median(wp[ind]/wd[ind]) ind <- wd < 0 kd[ind] <- wd[ind]*median(wp[ind]/wd[ind]) robust <- (sum(kd^2)+extra)/dof ## force estimate to lie between deviance and pearson estimators if (pearson > deviance) { if (robust < deviance) robust <- deviance if (robust > pearson) robust <- pearson } else { if (robust > deviance) robust <- deviance if (robust < pearson) robust <- pearson } } list(pearson=pearson,deviance=deviance,robust=robust) } gam.fit3 <- function (x, y, sp, Eb,UrS=list(), weights = rep(1, nobs), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, nobs),U1=diag(ncol(x)), Mp=-1, family = gaussian(), control = gam.control(), intercept = TRUE,deriv=2, gamma=1,scale=1,printWarn=TRUE,scoreType="REML",null.coef=rep(0,ncol(x)), pearson.extra=0,dev.extra=0,n.true=-1,Sl=NULL,...) { ## Inputs: ## * x model matrix ## * y response ## * sp log smoothing parameters ## * Eb square root of nicely balanced total penalty matrix used for rank detection ## * UrS list of penalty square roots in range space of overall penalty. UrS[[i]]%*%t(UrS[[i]]) ## is penalty. See 'estimate.gam' for more. ## * weights prior weights (reciprocal variance scale) ## * start initial values for parameters. ignored if etastart or mustart present (although passed on). ## * etastart initial values for eta ## * mustart initial values for mu. discarded if etastart present. ## * control - control list. ## * intercept - indicates whether model has one. ## * deriv - order 0,1 or 2 derivatives are to be returned (lower is cheaper!) ## * gamma - multiplier for effective degrees of freedom in GCV/UBRE. ## * scale parameter. Negative signals to estimate. ## * printWarn print or supress? ## * scoreType - type of smoothness selection to use. ## * null.coef - coefficients for a null model, in order to be able to check for immediate ## divergence. ## * pearson.extra is an extra component to add to the pearson statistic in the P-REML/P-ML ## case, only. ## * dev.extra is an extra component to add to the deviance in the REML and ML cases only. ## * n.true is to be used in place of the length(y) in ML/REML calculations, ## and the scale.est only. ## ## Version with new reparameterization and truncation strategy. Allows iterative weights ## to be negative. Basically the workhorse routine for Wood (2011) JRSSB. ## A much modified version of glm.fit. Purpose is to estimate regression coefficients ## and compute a smoothness selection score along with its derivatives. ## if (control$trace) { t0 <- proc.time();tc <- 0} if (inherits(family,"extended.family")) { ## then actually gam.fit4/5 is needed if (inherits(family,"general.family")) { return(gam.fit5(x,y,sp,Sl=Sl,weights=weights,offset=offset,deriv=deriv, family=family,control=control,Mp=Mp,start=start)) } else return(gam.fit4(x, y, sp, Eb,UrS=UrS, weights = weights, start = start, etastart = etastart, mustart = mustart, offset = offset,U1=U1, Mp=Mp, family = family, control = control, deriv=deriv, scale=scale,scoreType=scoreType,null.coef=null.coef,...)) } if (family$link==family$canonical) fisher <- TRUE else fisher=FALSE ## ... if canonical Newton = Fisher, but Fisher cheaper! if (scale>0) scale.known <- TRUE else scale.known <- FALSE if (!scale.known&&scoreType%in%c("REML","ML")) { ## the final element of sp is actually log(scale) nsp <- length(sp) scale <- exp(sp[nsp]) sp <- sp[-nsp] } if (!deriv%in%c(0,1,2)) stop("unsupported order of differentiation requested of gam.fit3") x <- as.matrix(x) nSp <- length(sp) if (nSp==0) deriv.sp <- 0 else deriv.sp <- deriv rank.tol <- .Machine$double.eps*100 ## tolerance to use for rank deficiency xnames <- dimnames(x)[[2]] ynames <- if (is.matrix(y)) rownames(y) else names(y) q <- ncol(x) if (length(UrS)) { ## find a stable reparameterization... grderiv <- deriv*as.numeric(scoreType%in%c("REML","ML","P-REML","P-ML")) rp <- gam.reparam(UrS,sp,grderiv) ## note also detects fixed penalty if present ## Following is for debugging only... # deriv.check <- FALSE # if (deriv.check&&grderiv) { # eps <- 1e-4 # fd.grad <- rp$det1 # for (i in 1:length(sp)) { # spp <- sp; spp[i] <- spp[i] + eps/2 # rp1 <- gam.reparam(UrS,spp,grderiv) # spp[i] <- spp[i] - eps # rp0 <- gam.reparam(UrS,spp,grderiv) # fd.grad[i] <- (rp1$det-rp0$det)/eps # } # print(fd.grad) # print(rp$det1) # } T <- diag(q) T[1:ncol(rp$Qs),1:ncol(rp$Qs)] <- rp$Qs T <- U1%*%T ## new params b'=T'b old params null.coef <- t(T)%*%null.coef if (!is.null(start)) start <- t(T)%*%start ## form x%*%T in parallel x <- .Call(C_mgcv_pmmult2,x,T,0,0,control$nthreads) ## x <- x%*%T ## model matrix 0(nq^2) rS <- list() for (i in 1:length(UrS)) { rS[[i]] <- rbind(rp$rS[[i]],matrix(0,Mp,ncol(rp$rS[[i]]))) } ## square roots of penalty matrices in current parameterization Eb <- Eb%*%T ## balanced penalty matrix rows.E <- q-Mp Sr <- cbind(rp$E,matrix(0,nrow(rp$E),Mp)) St <- rbind(cbind(rp$S,matrix(0,nrow(rp$S),Mp)),matrix(0,Mp,q)) } else { T <- diag(q); St <- matrix(0,q,q) rSncol <- sp <- rows.E <- Eb <- Sr <- 0 rS <- list(0) rp <- list(det=0,det1 = rep(0,0),det2 = rep(0,0),fixed.penalty=FALSE) } iter <- 0;coef <- rep(0,ncol(x)) conv <- FALSE n <- nobs <- NROW(y) ## n is just to keep codetools happy if (n.true <= 0) n.true <- nobs ## n.true is used in criteria in place of nobs nvars <- ncol(x) EMPTY <- nvars == 0 if (is.null(weights)) weights <- rep.int(1, nobs) if (is.null(offset)) offset <- rep.int(0, nobs) variance <- family$variance dev.resids <- family$dev.resids aic <- family$aic linkinv <- family$linkinv mu.eta <- family$mu.eta if (!is.function(variance) || !is.function(linkinv)) stop("illegal `family' argument") valideta <- family$valideta if (is.null(valideta)) valideta <- function(eta) TRUE validmu <- family$validmu if (is.null(validmu)) validmu <- function(mu) TRUE if (is.null(mustart)) { eval(family$initialize) } else { mukeep <- mustart eval(family$initialize) mustart <- mukeep } ## Added code if (family$family=="gaussian"&&family$link=="identity") strictly.additive <- TRUE else strictly.additive <- FALSE ## end of added code D1 <- D2 <- P <- P1 <- P2 <- trA <- trA1 <- trA2 <- GCV<- GCV1<- GCV2<- GACV<- GACV1<- GACV2<- UBRE <- UBRE1<- UBRE2<- REML<- REML1<- REML2 <-NULL if (EMPTY) { eta <- rep.int(0, nobs) + offset if (!valideta(eta)) stop("Invalid linear predictor values in empty model") mu <- linkinv(eta) if (!validmu(mu)) stop("Invalid fitted means in empty model") dev <- sum(dev.resids(y, mu, weights)) w <- (weights * mu.eta(eta)^2)/variance(mu) ### BUG: incorrect for Newton residuals <- (y - mu)/mu.eta(eta) good <- rep(TRUE, length(residuals)) boundary <- conv <- TRUE coef <- numeric(0) iter <- 0 V <- variance(mu) alpha <- dev trA2 <- trA1 <- trA <- 0 if (deriv) GCV2 <- GCV1<- UBRE2 <- UBRE1<-trA1 <- rep(0,nSp) GCV <- nobs*alpha/(nobs-gamma*trA)^2 UBRE <- alpha/nobs - scale + 2*gamma/n*trA scale.est <- alpha / (nobs - trA) } ### end if (EMPTY) else { ##coefold <- NULL eta <- if (!is.null(etastart)) etastart else if (!is.null(start)) if (length(start) != nvars) stop(gettextf("Length of start should equal %d and correspond to initial coefs for %s", nvars, deparse(xnames))) else { coefold <- start offset + as.vector(if (NCOL(x) == 1) x * start else x %*% start) } else family$linkfun(mustart) #etaold <- eta ##muold <- mu <- linkinv(eta) #if (!(validmu(mu) && valideta(eta))) # stop("Can't find valid starting values: please specify some") boundary <- conv <- FALSE rV=matrix(0,ncol(x),ncol(x)) ## need an initial `null deviance' to test for initial divergence... ## Note: can be better not to shrink towards start on ## immediate failure, in case start is on edge of feasible space... ## if (!is.null(start)) null.coef <- start coefold <- null.coef etaold <- null.eta <- as.numeric(x%*%null.coef + as.numeric(offset)) old.pdev <- sum(dev.resids(y, linkinv(null.eta), weights)) + t(null.coef)%*%St%*%null.coef ## ... if the deviance exceeds this then there is an immediate problem ii <- 0 while (!(validmu(mu) && valideta(eta))) { ## shrink towards null.coef if immediately invalid ii <- ii + 1 if (ii>20) stop("Can't find valid starting values: please specify some") if (!is.null(start)) start <- start * .9 + coefold * .1 eta <- .9 * eta + .1 * etaold mu <- linkinv(eta) } for (iter in 1:control$maxit) { ## start of main fitting iteration good <- weights > 0 var.val <- variance(mu) varmu <- var.val[good] if (any(is.na(varmu))) stop("NAs in V(mu)") if (any(varmu == 0)) stop("0s in V(mu)") mu.eta.val <- mu.eta(eta) if (any(is.na(mu.eta.val[good]))) stop("NAs in d(mu)/d(eta)") good <- (weights > 0) & (mu.eta.val != 0) if (all(!good)) { conv <- FALSE warning(gettextf("No observations informative at iteration %d", iter)) break } mevg<-mu.eta.val[good];mug<-mu[good];yg<-y[good] weg<-weights[good];var.mug<-var.val[good] if (fisher) { ## Conventional Fisher scoring z <- (eta - offset)[good] + (yg - mug)/mevg w <- (weg * mevg^2)/var.mug } else { ## full Newton c = yg - mug alpha <- 1 + c*(family$dvar(mug)/var.mug + family$d2link(mug)*mevg) alpha[alpha==0] <- .Machine$double.eps z <- (eta - offset)[good] + (yg-mug)/(mevg*alpha) ## ... offset subtracted as eta = X%*%beta + offset w <- weg*alpha*mevg^2/var.mug } ## Here a Fortran call has been replaced by pls_fit1 call if (sum(good) control$maxit) stop("inner loop 1; can't correct step size") ii <- ii + 1 start <- (start + coefold)/2 eta <- (eta + etaold)/2 mu <- linkinv(eta) dev <- sum(dev.resids(y, mu, weights)) } boundary <- TRUE penalty <- t(start)%*%St%*%start if (control$trace) cat("Step halved: new deviance =", dev, "\n") } if (!(valideta(eta) && validmu(mu))) { warning("Step size truncated: out of bounds", call. = FALSE) ii <- 1 while (!(valideta(eta) && validmu(mu))) { if (ii > control$maxit) stop("inner loop 2; can't correct step size") ii <- ii + 1 start <- (start + coefold)/2 eta <- (eta + etaold)/2 mu <- linkinv(eta) } boundary <- TRUE penalty <- t(start)%*%St%*%start dev <- sum(dev.resids(y, mu, weights)) if (control$trace) cat("Step halved: new deviance =", dev, "\n") } pdev <- dev + penalty ## the penalized deviance if (control$trace) message(gettextf("penalized deviance = %s", pdev, domain = "R-mgcv")) div.thresh <- 10*(.1+abs(old.pdev))*.Machine$double.eps^.5 ## ... threshold for judging divergence --- too tight and near ## perfect convergence can cause a failure here if (pdev-old.pdev>div.thresh) { ## solution diverging ii <- 1 ## step halving counter if (iter==1) { ## immediate divergence, need to shrink towards zero etaold <- null.eta; coefold <- null.coef } while (pdev -old.pdev > div.thresh) { ## step halve until pdev <= old.pdev if (ii > 100) stop("inner loop 3; can't correct step size") ii <- ii + 1 start <- (start + coefold)/2 eta <- (eta + etaold)/2 mu <- linkinv(eta) dev <- sum(dev.resids(y, mu, weights)) pdev <- dev + t(start)%*%St%*%start ## the penalized deviance if (control$trace) message(gettextf("Step halved: new penalized deviance = %g", pdev, "\n")) } } if (strictly.additive) { conv <- TRUE;coef <- start;break;} if (abs(pdev - old.pdev)/(0.1 + abs(pdev)) < control$epsilon) { ## Need to check coefs converged adequately, to ensure implicit differentiation ## ok. Testing coefs unchanged is problematic under rank deficiency (not guaranteed to ## drop same parameter every iteration!) grad <- 2 * t(x[good,])%*%(w*((x%*%start)[good]-z))+ 2*St%*%start if (max(abs(grad)) > control$epsilon*max(abs(start+coefold))/2) { ##if (max(abs(start-coefold))>control$epsilon*max(abs(start+coefold))/2) { ## if (max(abs(mu-muold))>control$epsilon*max(abs(mu+muold))/2) { old.pdev <- pdev coef <- coefold <- start etaold <- eta ##muold <- mu } else { conv <- TRUE coef <- start etaold <- eta break } } else { old.pdev <- pdev coef <- coefold <- start etaold <- eta } } ### end main loop wdr <- dev.resids(y, mu, weights) dev <- sum(wdr) wdr <- sign(y-mu)*sqrt(pmax(wdr,0)) ## used below in scale estimation ## Now call the derivative calculation scheme. This requires the ## following inputs: ## z and w - the pseudodata and weights ## X the model matrix and E where EE'=S ## rS the single penalty square roots ## sp the log smoothing parameters ## y and mu the data and model expected values ## g1,g2,g3 - the first 3 derivatives of g(mu) wrt mu ## V,V1,V2 - V(mu) and its first two derivatives wrt mu ## on output it returns the gradient and hessian for ## the deviance and trA good <- weights > 0 var.val <- variance(mu) varmu <- var.val[good] if (any(is.na(varmu))) stop("NAs in V(mu)") if (any(varmu == 0)) stop("0s in V(mu)") mu.eta.val <- mu.eta(eta) if (any(is.na(mu.eta.val[good]))) stop("NAs in d(mu)/d(eta)") good <- (weights > 0) & (mu.eta.val != 0) mevg <- mu.eta.val[good];mug <- mu[good];yg <- y[good] weg <- weights[good];etag <- eta[good] var.mug<-var.val[good] if (fisher) { ## Conventional Fisher scoring z <- (eta - offset)[good] + (yg - mug)/mevg w <- (weg * mevg^2)/var.mug alpha <- wf <- 0 ## Don't need Fisher weights separately } else { ## full Newton c <- yg - mug alpha <- 1 + c*(family$dvar(mug)/var.mug + family$d2link(mug)*mevg) ### can't just drop obs when alpha==0, as they are informative, but ### happily using an `effective zero' is stable here, and there is ### a natural effective zero, since E(alpha) = 1. alpha[alpha==0] <- .Machine$double.eps z <- (eta - offset)[good] + (yg-mug)/(mevg*alpha) ## ... offset subtracted as eta = X%*%beta + offset wf <- weg*mevg^2/var.mug ## Fisher weights for EDF calculation w <- wf * alpha ## Full Newton weights } g1 <- 1/mevg g2 <- family$d2link(mug) g3 <- family$d3link(mug) V <- family$variance(mug) V1 <- family$dvar(mug) V2 <- family$d2var(mug) if (fisher) { g4 <- V3 <- 0 } else { g4 <- family$d4link(mug) V3 <- family$d3var(mug) } if (TRUE) { ### TEST CODE for derivative ratio based versions of code... g2 <- g2/g1;g3 <- g3/g1;g4 <- g4/g1 V1 <- V1/V;V2 <- V2/V;V3 <- V3/V } P1 <- D1 <- array(0,nSp);P2 <- D2 <- matrix(0,nSp,nSp) # for derivs of deviance/ Pearson trA1 <- array(0,nSp);trA2 <- matrix(0,nSp,nSp) # for derivs of tr(A) rV=matrix(0,ncol(x),ncol(x)); dum <- 1 if (control$trace) cat("calling gdi...") REML <- 0 ## signals GCV/AIC used if (scoreType%in%c("REML","P-REML")) {REML <- 1;remlInd <- 1} else if (scoreType%in%c("ML","P-ML")) {REML <- -1;remlInd <- 0} if (REML==0) rSncol <- unlist(lapply(rS,ncol)) else rSncol <- unlist(lapply(UrS,ncol)) if (control$trace) t1 <- proc.time() oo <- .C(C_gdi1,X=as.double(x[good,]),E=as.double(Sr),Eb = as.double(Eb), rS = as.double(unlist(rS)),U1=as.double(U1),sp=as.double(exp(sp)), z=as.double(z),w=as.double(w),wf=as.double(wf),alpha=as.double(alpha), mu=as.double(mug),eta=as.double(etag),y=as.double(yg), p.weights=as.double(weg),g1=as.double(g1),g2=as.double(g2), g3=as.double(g3),g4=as.double(g4),V0=as.double(V),V1=as.double(V1), V2=as.double(V2),V3=as.double(V3),beta=as.double(coef),b1=as.double(rep(0,nSp*ncol(x))), w1=as.double(rep(0,nSp*length(z))), D1=as.double(D1),D2=as.double(D2),P=as.double(dum),P1=as.double(P1),P2=as.double(P2), trA=as.double(dum),trA1=as.double(trA1),trA2=as.double(trA2), rV=as.double(rV),rank.tol=as.double(rank.tol), conv.tol=as.double(control$epsilon),rank.est=as.integer(1),n=as.integer(length(z)), p=as.integer(ncol(x)),M=as.integer(nSp),Mp=as.integer(Mp),Enrow = as.integer(rows.E), rSncol=as.integer(rSncol),deriv=as.integer(deriv.sp), REML = as.integer(REML),fisher=as.integer(fisher), fixed.penalty = as.integer(rp$fixed.penalty),nthreads=as.integer(control$nthreads), dVkk=as.double(rep(0,nSp*nSp))) if (control$trace) { tg <- sum((proc.time()-t1)[c(1,4)]) cat("done!\n") } ## get dbeta/drho, directly in original parameterization db.drho <- if (deriv) T%*%matrix(oo$b1,ncol(x),nSp) else NULL dw.drho <- if (deriv) matrix(oo$w1,length(z),nSp) else NULL rV <- matrix(oo$rV,ncol(x),ncol(x)) ## rV%*%t(rV)*scale gives covariance matrix Kmat <- matrix(0,nrow(x),ncol(x)) Kmat[good,] <- oo$X ## rV%*%t(K)%*%(sqrt(wf)*X) = F; diag(F) is edf array coef <- oo$beta; eta <- drop(x%*%coef + offset) mu <- linkinv(eta) if (!(validmu(mu)&&valideta(eta))) { ## if iteration terminated with step halving then it can be that ## gdi1 returns an invalid coef, because likelihood is actually ## pushing coefs to invalid region. Probably not much hope in ## this case, but it is worth at least returning feasible values, ## even though this is not quite consistent with derivs. coef <- start eta <- etaold mu <- linkinv(eta) } trA <- oo$trA; # wpr <- (y-mu) *sqrt(weights/family$variance(mu)) ## weighted pearson residuals # se <- gam.scale(wpr,wdr,n.true-trA,dev.extra) ## get scale estimates # pearson.warning <- NULL # if (control$scale.est=="pearson") { # scale.est <- se$pearson # if (scale.est > 4 * se$robust) pearson.warning <- TRUE # } else scale.est <- if (control$scale.est=="deviance") se$deviance else se$robust if (control$scale.est%in%c("pearson","fletcher","Pearson","Fletcher")) { pearson <- sum(weights*(y-mu)^2/family$variance(mu)) scale.est <- (pearson+dev.extra)/(n.true-trA) if (control$scale.est%in%c("fletcher","Fletcher")) { ## Apply Fletcher (2012) correction ## note limited to 10 times Pearson... s.bar = max(-.9,mean(family$dvar(mu)*(y-mu)*sqrt(weights)/family$variance(mu))) if (is.finite(s.bar)) scale.est <- scale.est/(1+s.bar) } } else { ## use the deviance estimator scale.est <- (dev+dev.extra)/(n.true-trA) } reml.scale <- NA if (scoreType%in%c("REML","ML")) { ## use Laplace (RE)ML ls <- family$ls(y,weights,n,scale)*n.true/nobs ## saturated likelihood and derivatives Dp <- dev + oo$conv.tol + dev.extra REML <- Dp/(2*scale) - ls[1] + oo$rank.tol/2 - rp$det/2 - remlInd*Mp/2*log(2*pi*scale) attr(REML,"Dp") <- Dp/(2*scale) if (deriv) { REML1 <- oo$D1/(2*scale) + oo$trA1/2 - rp$det1/2 if (deriv==2) REML2 <- (matrix(oo$D2,nSp,nSp)/scale + matrix(oo$trA2,nSp,nSp) - rp$det2)/2 if (sum(!is.finite(REML2))) { stop("Non finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam.contol'") } } if (!scale.known&&deriv) { ## need derivatives wrt log scale, too ##ls <- family$ls(y,weights,n,scale) ## saturated likelihood and derivatives dlr.dlphi <- -Dp/(2 *scale) - ls[2]*scale - Mp/2*remlInd d2lr.d2lphi <- Dp/(2*scale) - ls[3]*scale^2 - ls[2]*scale d2lr.dspphi <- -oo$D1/(2*scale) REML1 <- c(REML1,dlr.dlphi) if (deriv==2) { REML2 <- rbind(REML2,as.numeric(d2lr.dspphi)) REML2 <- cbind(REML2,c(as.numeric(d2lr.dspphi),d2lr.d2lphi)) } } reml.scale <- scale } else if (scoreType%in%c("P-REML","P-ML")) { ## scale unknown use Pearson-Laplace REML reml.scale <- phi <- (oo$P*(nobs-Mp)+pearson.extra)/(n.true-Mp) ## REMLish scale estimate ## correct derivatives, if needed... oo$P1 <- oo$P1*(nobs-Mp)/(n.true-Mp) oo$P2 <- oo$P2*(nobs-Mp)/(n.true-Mp) ls <- family$ls(y,weights,n,phi)*n.true/nobs ## saturated likelihood and derivatives Dp <- dev + oo$conv.tol + dev.extra K <- oo$rank.tol/2 - rp$det/2 REML <- Dp/(2*phi) - ls[1] + K - Mp/2*log(2*pi*phi)*remlInd attr(REML,"Dp") <- Dp/(2*phi) if (deriv) { phi1 <- oo$P1; Dp1 <- oo$D1; K1 <- oo$trA1/2 - rp$det1/2; REML1 <- Dp1/(2*phi) - phi1*(Dp/(2*phi^2)+Mp/(2*phi)*remlInd + ls[2]) + K1 if (deriv==2) { phi2 <- matrix(oo$P2,nSp,nSp);Dp2 <- matrix(oo$D2,nSp,nSp) K2 <- matrix(oo$trA2,nSp,nSp)/2 - rp$det2/2 REML2 <- Dp2/(2*phi) - (outer(Dp1,phi1)+outer(phi1,Dp1))/(2*phi^2) + (Dp/phi^3 - ls[3] + Mp/(2*phi^2)*remlInd)*outer(phi1,phi1) - (Dp/(2*phi^2)+ls[2]+Mp/(2*phi)*remlInd)*phi2 + K2 } } } else { ## Not REML .... P <- oo$P delta <- nobs - gamma * trA delta.2 <- delta*delta GCV <- nobs*dev/delta.2 GACV <- dev/nobs + P * 2*gamma*trA/(delta * nobs) UBRE <- dev/nobs - 2*delta*scale/nobs + scale if (deriv) { trA1 <- oo$trA1 D1 <- oo$D1 P1 <- oo$P1 if (sum(!is.finite(D1))||sum(!is.finite(P1))||sum(!is.finite(trA1))) { stop( "Non-finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam.contol'") } delta.3 <- delta*delta.2 GCV1 <- nobs*D1/delta.2 + 2*nobs*dev*trA1*gamma/delta.3 GACV1 <- D1/nobs + 2*P/delta.2 * trA1 + 2*gamma*trA*P1/(delta*nobs) UBRE1 <- D1/nobs + gamma * trA1 *2*scale/nobs if (deriv==2) { trA2 <- matrix(oo$trA2,nSp,nSp) D2 <- matrix(oo$D2,nSp,nSp) P2 <- matrix(oo$P2,nSp,nSp) if (sum(!is.finite(D2))||sum(!is.finite(P2))||sum(!is.finite(trA2))) { stop( "Non-finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam.contol'") } GCV2 <- outer(trA1,D1) GCV2 <- (GCV2 + t(GCV2))*gamma*2*nobs/delta.3 + 6*nobs*dev*outer(trA1,trA1)*gamma*gamma/(delta.2*delta.2) + nobs*D2/delta.2 + 2*nobs*dev*gamma*trA2/delta.3 GACV2 <- D2/nobs + outer(trA1,trA1)*4*P/(delta.3) + 2 * P * trA2 / delta.2 + 2 * outer(trA1,P1)/delta.2 + 2 * outer(P1,trA1) *(1/(delta * nobs) + trA/(nobs*delta.2)) + 2 * trA * P2 /(delta * nobs) GACV2 <- (GACV2 + t(GACV2))*.5 UBRE2 <- D2/nobs +2*gamma * trA2 * scale / nobs } ## end if (deriv==2) } ## end if (deriv) } ## end !REML # end of inserted code if (!conv&&printWarn) warning("Algorithm did not converge") if (printWarn&&boundary) warning("Algorithm stopped at boundary value") eps <- 10 * .Machine$double.eps if (printWarn&&family$family[1] == "binomial") { if (any(mu > 1 - eps) || any(mu < eps)) warning("fitted probabilities numerically 0 or 1 occurred") } if (printWarn&&family$family[1] == "poisson") { if (any(mu < eps)) warning("fitted rates numerically 0 occurred") } residuals <- rep.int(NA, nobs) residuals[good] <- z - (eta - offset)[good] ## undo reparameterization.... coef <- as.numeric(T %*% coef) rV <- T %*% rV names(coef) <- xnames } ### end if (!EMPTY) names(residuals) <- ynames names(mu) <- ynames names(eta) <- ynames ww <- wt <- rep.int(0, nobs) if (fisher) { wt[good] <- w; ww <- wt} else { wt[good] <- wf ## note that Fisher weights are returned ww[good] <- w } names(wt) <- ynames names(weights) <- ynames names(y) <- ynames if (deriv && nrow(dw.drho)!=nrow(x)) { w1 <- dw.drho dw.drho <- matrix(0,nrow(x),ncol(w1)) dw.drho[good,] <- w1 } wtdmu <- if (intercept) sum(weights * y)/sum(weights) else linkinv(offset) nulldev <- sum(dev.resids(y, wtdmu, weights)) n.ok <- nobs - sum(weights == 0) nulldf <- n.ok - as.integer(intercept) aic.model <- aic(y, n, mu, weights, dev) # note: incomplete 2*edf needs to be added if (control$trace) { t1 <- proc.time() at <- sum((t1-t0)[c(1,4)]) cat("Proportion time in C: ",(tc+tg)/at," ls:",tc/at," gdi:",tg/at,"\n") } list(coefficients = coef, residuals = residuals, fitted.values = mu, family = family, linear.predictors = eta, deviance = dev, null.deviance = nulldev, iter = iter, weights = wt, working.weights=ww,prior.weights = weights, df.null = nulldf, y = y, converged = conv,##pearson.warning = pearson.warning, boundary = boundary,D1=D1,D2=D2,P=P,P1=P1,P2=P2,trA=trA,trA1=trA1,trA2=trA2, GCV=GCV,GCV1=GCV1,GCV2=GCV2,GACV=GACV,GACV1=GACV1,GACV2=GACV2,UBRE=UBRE, UBRE1=UBRE1,UBRE2=UBRE2,REML=REML,REML1=REML1,REML2=REML2,rV=rV,db.drho=db.drho, dw.drho=dw.drho,dVkk = matrix(oo$dVkk,nSp,nSp), scale.est=scale.est,reml.scale= reml.scale,aic=aic.model,rank=oo$rank.est,K=Kmat) } ## end gam.fit3 Vb.corr <- function(X,L,lsp0,S,off,dw,w,rho,Vr,nth=0,scale.est=FALSE) { ## compute higher order Vb correction... ## If w is NULL then X should be root Hessian, and ## dw is treated as if it was 0, otherwise X should be model ## matrix. ## dw is derivative w.r.t. all the smoothing parameters and family parameters as if these ## were not linked, but not the scale parameter, of course. Vr includes scale uncertainty, ## if scale estimated... ## nth is the number of initial elements of rho that are not smoothing ## parameters, scale.est is TRUE if scale estimated by REML and must be ## dropped from s.p.s M <- length(off) ## number of penalty terms if (scale.est) { ## drop scale param from L, rho and Vr... rho <- rho[-length(rho)] if (!is.null(L)) L <- L[-nrow(L),-ncol(L),drop=FALSE] Vr <- Vr[-nrow(Vr),-ncol(Vr),drop=FALSE] } if (is.null(lsp0)) lsp0 <- if (is.null(L)) rho*0 else rep(0,nrow(L)) ## note that last element of lsp0 can be a scale parameter... lambda <- if (is.null(L)) exp(rho+lsp0[1:length(rho)]) else exp(L%*%rho + lsp0[1:nrow(L)]) ## Re-create the Hessian, if is.null(w) then X assumed to be root ## unpenalized Hessian... H <- if (is.null(w)) crossprod(X) else H <- t(X)%*%(w*X) if (M>0) for (i in 1:M) { ind <- off[i] + 1:ncol(S[[i]]) - 1 H[ind,ind] <- H[ind,ind] + lambda[i+nth] * S[[i]] } R <- try(chol(H),silent=TRUE) ## get its Choleski factor. if (inherits(R,"try-error")) return(0) ## bail out as Hessian insufficiently well conditioned ## Create dH the derivatives of the hessian w.r.t. (all) the smoothing parameters... dH <- list() if (length(lambda)>0) for (i in 1:length(lambda)) { ## If w==NULL use constant H approx... dH[[i]] <- if (is.null(w)) H*0 else t(X)%*%(dw[,i]*X) if (i>nth) { ind <- off[i-nth] + 1:ncol(S[[i-nth]]) - 1 dH[[i]][ind,ind] <- dH[[i]][ind,ind] + lambda[i]*S[[i-nth]] } } ## If L supplied then dH has to be re-weighted to give ## derivatives w.r.t. optimization smoothing params. if (!is.null(L)) { dH1 <- dH;dH <- list() if (length(rho)>0) for (j in 1:length(rho)) { ok <- FALSE ## dH[[j]] not yet created if (nrow(L)>0) for (i in 1:nrow(L)) if (L[i,j]!=0.0) { dH[[j]] <- if (ok) dH[[j]] + dH1[[i]]*L[i,j] else dH1[[i]]*L[i,j] ok <- TRUE } } rm(dH1) } ## dH now w.r.t. optimization parameters if (length(dH)==0) return(0) ## nothing to correct ## Get derivatives of Choleski factor w.r.t. the smoothing parameters dR <- list() for (i in 1:length(dH)) dR[[i]] <- dchol(dH[[i]],R) rm(dH) ## need to transform all dR to dR^{-1} = -R^{-1} dR R^{-1}... for (i in 1:length(dR)) dR[[i]] <- -t(forwardsolve(t(R),t(backsolve(R,dR[[i]])))) ## BUT: dR, now upper triangular, and it relates to RR' = Vb not R'R = Vb ## in consequence of which Rz is the thing with the right distribution ## and not R'z... dbg <- FALSE if (dbg) { ## debugging code n.rep <- 10000;p <- ncol(R) r <- rmvn(n.rep,rep(0,M),Vr) b <- matrix(0,n.rep,p) for (i in 1:n.rep) { z <- rnorm(p) if (M>0) for (j in 1:M) b[i,] <- b[i,] + dR[[j]]%*%z*(r[i,j]) } Vfd <- crossprod(b)/n.rep } vcorr(dR,Vr,FALSE) ## NOTE: unscaled!! } ## Vb.corr gam.fit3.post.proc <- function(X,L,lsp0,S,off,object) { ## get edf array and covariance matrices after a gam fit. ## X is original model matrix, L the mapping from working to full sp scale <- if (object$scale.estimated) object$scale.est else object$scale Vb <- object$rV%*%t(object$rV)*scale ## Bayesian cov. # PKt <- object$rV%*%t(object$K) PKt <- .Call(C_mgcv_pmmult2,object$rV,object$K,0,1,object$control$nthreads) # F <- PKt%*%(sqrt(object$weights)*X) F <- .Call(C_mgcv_pmmult2,PKt,sqrt(object$weights)*X,0,0,object$control$nthreads) edf <- diag(F) ## effective degrees of freedom edf1 <- 2*edf - rowSums(t(F)*F) ## alternative ## check on plausibility of scale (estimate) ##if (object$scale.estimated&&!is.null(object$pearson.warning)) warning("Pearson scale estimate maybe unstable. See ?gam.scale.") ## edf <- rowSums(PKt*t(sqrt(object$weights)*X)) ## Ve <- PKt%*%t(PKt)*object$scale ## frequentist cov Ve <- F%*%Vb ## not quite as stable as above, but quicker hat <- rowSums(object$K*object$K) ## get QR factor R of WX - more efficient to do this ## in gdi_1 really, but that means making QR of augmented ## a two stage thing, so not clear cut... qrx <- pqr(sqrt(object$weights)*X,object$control$nthreads) R <- pqr.R(qrx);R[,qrx$pivot] <- R if (!is.na(object$reml.scale)&&!is.null(object$db.drho)) { ## compute sp uncertainty correction hess <- object$outer.info$hess edge.correct <- if (is.null(attr(hess,"edge.correct"))) FALSE else TRUE K <- if (edge.correct) 2 else 1 for (k in 1:K) { if (k==1) { ## fitted model computations db.drho <- object$db.drho dw.drho <- object$dw.drho lsp <- log(object$sp) } else { ## edge corrected model computations db.drho <- attr(hess,"db.drho1") dw.drho <- attr(hess,"dw.drho1") lsp <- attr(hess,"lsp1") hess <- attr(hess,"hess1") } M <- ncol(db.drho) ## transform to derivs w.r.t. working, noting that an extra final row of L ## may be present, relating to scale parameter (for which db.drho is 0 since it's a scale parameter) if (!is.null(L)) { db.drho <- db.drho%*%L[1:M,,drop=FALSE] M <- ncol(db.drho) } ## extract cov matrix for log smoothing parameters... ev <- eigen(hess,symmetric=TRUE) d <- ev$values;ind <- d <= 0 d[ind] <- 0;d[!ind] <- 1/sqrt(d[!ind]) rV <- (d*t(ev$vectors))[,1:M] ## root of cov matrix Vc <- crossprod(rV%*%t(db.drho)) ## set a prior precision on the smoothing parameters, but don't use it to ## fit, only to regularize Cov matrix. exp(4*var^.5) gives approx ## multiplicative range. e.g. var = 5.3 says parameter between .01 and 100 times ## estimate. Avoids nonsense at `infinite' smoothing parameters. d <- ev$values; d[ind] <- 0; d <- if (k==1) 1/sqrt(d+1/10) else 1/sqrt(d+1e-7) Vr <- crossprod(d*t(ev$vectors)) ## Note that db.drho and dw.drho are derivatives w.r.t. full set of smoothing ## parameters excluding any scale parameter, but Vr includes info for scale parameter ## if it has been estimated. nth <- if (is.null(object$family$n.theta)) 0 else object$family$n.theta ## any parameters of family itself drop.scale <- object$scale.estimated && !(object$method %in% c("P-REML","P-ML")) Vc2 <- scale*Vb.corr(R,L,lsp0,S,off,dw.drho,w=NULL,lsp,Vr,nth,drop.scale) Vc <- Vb + Vc + Vc2 ## Bayesian cov matrix with sp uncertainty ## finite sample size check on edf sanity... if (k==1) { ## compute edf2 only with fitted model, not edge corrected edf2 <- rowSums(Vc*crossprod(R))/scale if (sum(edf2)>sum(edf1)) { edf2 <- edf1 } } } ## k loop } else edf2 <- Vc <- NULL list(Vc=Vc,Vb=Vb,Ve=Ve,edf=edf,edf1=edf1,edf2=edf2,hat=hat,F=F,R=R) } ## gam.fit3.post.proc score.transect <- function(ii, x, y, sp, Eb,UrS=list(), weights = rep(1, length(y)), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, length(y)),U1,Mp,family = gaussian(), control = gam.control(), intercept = TRUE,deriv=2, gamma=1,scale=1,printWarn=TRUE,scoreType="REML",eps=1e-7,null.coef=rep(0,ncol(x)),...) { ## plot a transect through the score for sp[ii] np <- 200 if (scoreType%in%c("REML","P-REML","ML","P-ML")) reml <- TRUE else reml <- FALSE score <- spi <- seq(-30,30,length=np) for (i in 1:np) { sp[ii] <- spi[i] b<-gam.fit3(x=x, y=y, sp=sp,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=0, control=control,gamma=gamma,scale=scale, printWarn=FALSE,mustart=mustart,scoreType=scoreType,null.coef=null.coef,...) if (reml) { score[i] <- b$REML } else if (scoreType=="GACV") { score[i] <- b$GACV } else if (scoreType=="UBRE"){ score[i] <- b$UBRE } else { ## default to deviance based GCV score[i] <- b$GCV } } par(mfrow=c(2,2),mar=c(4,4,1,1)) plot(spi,score,xlab="log(sp)",ylab=scoreType,type="l") plot(spi[1:(np-1)],score[2:np]-score[1:(np-1)],type="l",ylab="differences") plot(spi,score,ylim=c(score[1]-.1,score[1]+.1),type="l") plot(spi,score,ylim=c(score[np]-.1,score[np]+.1),type="l") } ## score.transect deriv.check <- function(x, y, sp, Eb,UrS=list(), weights = rep(1, length(y)), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, length(y)),U1,Mp,family = gaussian(), control = gam.control(), intercept = TRUE,deriv=2, gamma=1,scale=1,printWarn=TRUE,scoreType="REML",eps=1e-7, null.coef=rep(0,ncol(x)),Sl=Sl,...) ## FD checking of derivatives: basically a debugging routine { if (!deriv%in%c(1,2)) stop("deriv should be 1 or 2") if (control$epsilon>1e-9) control$epsilon <- 1e-9 b<-gam.fit3(x=x, y=y, sp=sp,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, control=control,gamma=gamma,scale=scale,printWarn=FALSE, start=start,etastart=etastart,mustart=mustart,scoreType=scoreType, null.coef=null.coef,Sl=Sl,...) P0 <- b$P;fd.P1 <- P10 <- b$P1; if (deriv==2) fd.P2 <- P2 <- b$P2 trA0 <- b$trA;fd.gtrA <- gtrA0 <- b$trA1 ; if (deriv==2) fd.htrA <- htrA <- b$trA2 dev0 <- b$deviance;fd.D1 <- D10 <- b$D1 ; if (deriv==2) fd.D2 <- D2 <- b$D2 if (scoreType%in%c("REML","P-REML","ML","P-ML")) reml <- TRUE else reml <- FALSE if (reml) { score0 <- b$REML;grad0 <- b$REML1; if (deriv==2) hess <- b$REML2 } else if (scoreType=="GACV") { score0 <- b$GACV;grad0 <- b$GACV1;if (deriv==2) hess <- b$GACV2 } else if (scoreType=="UBRE"){ score0 <- b$UBRE;grad0 <- b$UBRE1;if (deriv==2) hess <- b$UBRE2 } else { ## default to deviance based GCV score0 <- b$GCV;grad0 <- b$GCV1;if (deriv==2) hess <- b$GCV2 } fd.grad <- grad0 if (deriv==2) fd.hess <- hess for (i in 1:length(sp)) { sp1 <- sp;sp1[i] <- sp[i]+eps/2 bf<-gam.fit3(x=x, y=y, sp=sp1,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, control=control,gamma=gamma,scale=scale,printWarn=FALSE, start=start,etastart=etastart,mustart=mustart,scoreType=scoreType, null.coef=null.coef,Sl=Sl,...) sp1 <- sp;sp1[i] <- sp[i]-eps/2 bb<-gam.fit3(x=x, y=y, sp=sp1, Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, control=control,gamma=gamma,scale=scale,printWarn=FALSE, start=start,etastart=etastart,mustart=mustart,scoreType=scoreType, null.coef=null.coef,Sl=Sl,...) if (!reml) { Pb <- bb$P;Pf <- bf$P P1b <- bb$P1;P1f <- bf$P1 trAb <- bb$trA;trAf <- bf$trA gtrAb <- bb$trA1;gtrAf <- bf$trA1 devb <- bb$deviance;devf <- bf$deviance D1b <- bb$D1;D1f <- bf$D1 } if (reml) { scoreb <- bb$REML;scoref <- bf$REML; if (deriv==2) { gradb <- bb$REML1;gradf <- bf$REML1} } else if (scoreType=="GACV") { scoreb <- bb$GACV;scoref <- bf$GACV; if (deriv==2) { gradb <- bb$GACV1;gradf <- bf$GACV1} } else if (scoreType=="UBRE"){ scoreb <- bb$UBRE; scoref <- bf$UBRE; if (deriv==2) { gradb <- bb$UBRE1;gradf <- bf$UBRE1} } else { ## default to deviance based GCV scoreb <- bb$GCV;scoref <- bf$GCV; if (deriv==2) { gradb <- bb$GCV1;gradf <- bf$GCV1} } if (!reml) { fd.P1[i] <- (Pf-Pb)/eps fd.gtrA[i] <- (trAf-trAb)/eps fd.D1[i] <- (devf - devb)/eps } fd.grad[i] <- (scoref-scoreb)/eps if (deriv==2) { fd.hess[,i] <- (gradf-gradb)/eps if (!reml) { fd.htrA[,i] <- (gtrAf-gtrAb)/eps fd.P2[,i] <- (P1f-P1b)/eps fd.D2[,i] <- (D1f-D1b)/eps } } } if (!reml) { cat("\n Pearson Statistic... \n") cat("grad ");print(P10) cat("fd.grad ");print(fd.P1) if (deriv==2) { fd.P2 <- .5*(fd.P2 + t(fd.P2)) cat("hess\n");print(P2) cat("fd.hess\n");print(fd.P2) } cat("\n\n tr(A)... \n") cat("grad ");print(gtrA0) cat("fd.grad ");print(fd.gtrA) if (deriv==2) { fd.htrA <- .5*(fd.htrA + t(fd.htrA)) cat("hess\n");print(htrA) cat("fd.hess\n");print(fd.htrA) } cat("\n Deviance... \n") cat("grad ");print(D10) cat("fd.grad ");print(fd.D1) if (deriv==2) { fd.D2 <- .5*(fd.D2 + t(fd.D2)) cat("hess\n");print(D2) cat("fd.hess\n");print(fd.D2) } } cat("\n\n The objective...\n") cat("grad ");print(grad0) cat("fd.grad ");print(fd.grad) if (deriv==2) { fd.hess <- .5*(fd.hess + t(fd.hess)) cat("hess\n");print(hess) cat("fd.hess\n");print(fd.hess) } NULL } ## deriv.check rt <- function(x,r1) { ## transform of x, asymptoting to values in r1 ## returns derivatives wrt to x as well as transform values ## r1[i] == NA for no transform x <- as.numeric(x) ind <- x>0 rho2 <- rho1 <- rho <- 0*x if (length(r1)==1) r1 <- x*0+r1 h <- exp(x[ind])/(1+exp(x[ind])) h1 <- h*(1-h);h2 <- h1*(1-2*h) rho[ind] <- r1[ind]*(h-0.5)*2 rho1[ind] <- r1[ind]*h1*2 rho2[ind] <- r1[ind]*h2*2 rho[!ind] <- r1[!ind]*x[!ind]/2 rho1[!ind] <- r1[!ind]/2 ind <- is.na(r1) rho[ind] <- x[ind] rho1[ind] <- 1 rho2[ind] <- 0 list(rho=rho,rho1=rho1,rho2=rho2) } ## rt rti <- function(r,r1) { ## inverse of rti. r <- as.numeric(r) ind <- r>0 x <- r if (length(r1)==1) r1 <- x*0+r1 r2 <- r[ind]*.5/r1[ind] + .5 x[ind] <- log(r2/(1-r2)) x[!ind] <- 2*r[!ind]/r1[!ind] ind <- is.na(r1) x[ind] <- r[ind] x } ## rti simplyFit <- function(lsp,X,y,Eb,UrS,L,lsp0,offset,U1,Mp,family,weights, control,gamma,scale,conv.tol=1e-6,maxNstep=5,maxSstep=2, maxHalf=30,printWarn=FALSE,scoreType="deviance", mustart = NULL,null.coef=rep(0,ncol(X)),Sl=Sl,...) ## function with same argument list as `newton' and `bfgs' which simply fits ## the model given the supplied smoothing parameters... { reml <- scoreType%in%c("REML","P-REML","ML","P-ML") ## REML/ML indicator ## sanity check L if (is.null(L)) L <- diag(length(lsp)) else { if (!inherits(L,"matrix")) stop("L must be a matrix.") if (nrow(L)lsp1.max lsp[ind] <- lsp1.max[ind]-1 ## reset lsp's already over limit delta <- rti(lsp,lsp1.max) ## initial optimization parameters } else { ## optimization parameters are just lsp delta <- lsp } ## code designed to be turned on during debugging... check.derivs <- FALSE;sp.trace <- FALSE if (check.derivs) { deriv <- 2 eps <- 1e-4 deriv.check(x=X, y=y, sp=L%*%lsp+lsp0, Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, control=control,gamma=gamma,scale=scale, printWarn=FALSE,start=start,mustart=mustart, scoreType=scoreType,eps=eps,null.coef=null.coef,Sl=Sl,...) } # ii <- 0 # if (ii>0) { # score.transect(ii,x=X, y=y, sp=L%*%lsp+lsp0, Eb=Eb,UrS=UrS, # offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, # control=control,gamma=gamma,scale=scale, # printWarn=FALSE,mustart=mustart, # scoreType=scoreType,eps=eps,null.coef=null.coef,...) # } ## ... end of debugging code ## initial fit b<-gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=2, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=start, mustart=mustart,scoreType=scoreType,null.coef=null.coef,pearson.extra=pearson.extra, dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) mustart <- b$fitted.values etastart <- b$linear.predictors start <- b$coefficients if (reml) { old.score <- score <- b$REML;grad <- b$REML1;hess <- b$REML2 } else if (scoreType=="GACV") { old.score <- score <- b$GACV;grad <- b$GACV1;hess <- b$GACV2 } else if (scoreType=="UBRE"){ old.score <- score <- b$UBRE;grad <- b$UBRE1;hess <- b$UBRE2 } else { ## default to deviance based GCV old.score <- score <- b$GCV;grad <- b$GCV1;hess <- b$GCV2 } grad <- t(L)%*%grad hess <- t(L)%*%hess%*%L if (!is.null(lsp.max)) { ## need to transform to delta space rho <- rt(delta,lsp1.max) nr <- length(rho$rho1) hess <- diag(rho$rho1,nr,nr)%*%hess%*%diag(rho$rho1,nr,nr) + diag(rho$rho2*grad) grad <- rho$rho1*grad } if (reml) score.scale <- abs(log(b$scale.est)) + abs(score) else score.scale <- b$scale.est + abs(score) uconv.ind <- abs(grad) > score.scale*conv.tol ## check for all converged too soon, and undo ! if (!sum(uconv.ind)) uconv.ind <- uconv.ind | TRUE score.hist <- rep(NA,200) ################################ ## Start of Newton iteration.... ################################ qerror.thresh <- .8 ## quadratic approx error to tolerate in a step for (i in 1:200) { if (control$trace) { cat("\n",i,"newton max(|grad|) =",max(abs(grad)),"\n") } ## debugging code for checking derivatives .... okc <- check.derivs while (okc) { okc <- FALSE eps <- 1e-4 deriv <- 2 deriv.check(x=X, y=y, sp=L%*%lsp+lsp0, Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, control=control,gamma=gamma,scale=scale, printWarn=FALSE,etastart=etastart,start=start, scoreType=scoreType,eps=eps,null.coef=null.coef,Sl=Sl,...) if (inherits(family,"general.family")) { ## call gam.fit5 checking eps <- 1e-6 spe <- 1e-3 er <- deriv.check5(x=X, y=y, sp=L%*%lsp+lsp0, weights = weights, start = start, offset = offset,Mp=Mp,family = family, control = control,deriv=deriv,eps=eps,spe=spe, Sl=Sl,...) ## ignore codetools warning } } ## end of derivative checking # ii <- 0 # if (ii>0) { # score.transect(ii,x=X, y=y, sp=L%*%lsp+lsp0, Eb=Eb,UrS=UrS, # offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, # control=control,gamma=gamma,scale=scale, # printWarn=FALSE,mustart=mustart, # scoreType=scoreType,eps=eps,null.coef=null.coef,...) # } ## exclude dimensions from Newton step when the derviative is ## tiny relative to largest, as this space is likely to be poorly ## modelled on scale of Newton step... uconv.ind <- uconv.ind & abs(grad)>max(abs(grad))*.001 ## exclude apparently converged gradients from computation hess1 <- hess[uconv.ind,uconv.ind] grad1 <- grad[uconv.ind] ## get the trial step ... eh <- eigen(hess1,symmetric=TRUE) d <- eh$values;U <- eh$vectors ## set eigen-values to their absolute value - heuristically appealing ## as it avoids very long steps being proposed for indefinte components, ## unlike setting -ve e.v.s to very small +ve constant... ind <- d < 0 pdef <- if (sum(ind)>0) FALSE else TRUE ## is it positive definite? d[ind] <- -d[ind] ## see Gill Murray and Wright p107/8 low.d <- max(d)*.Machine$double.eps^.7 ind <- d < low.d if (sum(ind)>0) pdef <- FALSE ## not certain it is positive definite d[ind] <- low.d ind <- d != 0 d[ind] <- 1/d[ind] Nstep <- 0 * grad Nstep[uconv.ind] <- -drop(U%*%(d*(t(U)%*%grad1))) # (modified) Newton direction Sstep <- -grad/max(abs(grad)) # steepest descent direction ms <- max(abs(Nstep)) ## note smaller permitted step if !pdef mns <- maxNstep # mns <- if (pdef) maxNstep else maxNstep/3 ## more cautious if not pdef # if (!all(Nstep*Sstep >= 0)) mns <- mns/2 ## bit more cautious if directions differ if (ms>maxNstep) Nstep <- mns * Nstep/ms sd.unused <- TRUE ## steepest descent direction not yet tried ## try the step ... if (sp.trace) cat(lsp,"\n") if (!is.null(lsp.max)) { ## need to take step in delta space delta1 <- delta + Nstep lsp1 <- rt(delta1,lsp1.max)$rho ## transform to log sp space while (max(abs(lsp1-lsp))>maxNstep) { ## make sure step is not too long Nstep <- Nstep / 2 delta1 <- delta + Nstep lsp1 <- rt(delta1,lsp1.max)$rho } } else lsp1 <- lsp + Nstep ## if pdef==TRUE then get grad and hess immediately, otherwise postpone as ## the steepest descent direction should be tried as well as Newton b <- gam.fit3(x=X, y=y, sp=L%*%lsp1+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=as.numeric(pdef)*2, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=start, mustart=mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) ## get the change predicted for this step according to the quadratic model pred.change <- sum(grad*Nstep) + 0.5*t(Nstep) %*% hess %*% Nstep if (reml) { score1 <- b$REML } else if (scoreType=="GACV") { score1 <- b$GACV } else if (scoreType=="UBRE") { score1 <- b$UBRE } else score1 <- b$GCV ## accept if improvement, else step halve ii <- 0 ## step halving counter score.change <- score1 - score qerror <- abs(pred.change-score.change)/(max(abs(pred.change),abs(score.change))+score.scale*conv.tol) ## quadratic approx error if (is.finite(score1) && score.change<0 && pdef && qerror < qerror.thresh) { ## immediately accept step if it worked and positive definite old.score <- score mustart <- b$fitted.values etastart <- b$linear.predictors start <- b$coefficients lsp <- lsp1 if (reml) { score <- b$REML;grad <- b$REML1;hess <- b$REML2 } else if (scoreType=="GACV") { score <- b$GACV;grad <- b$GACV1;hess <- b$GACV2 } else if (scoreType=="UBRE") { score <- b$UBRE;grad <- b$UBRE1;hess <- b$UBRE2 } else { score <- b$GCV;grad <- b$GCV1;hess <- b$GCV2} grad <- t(L)%*%grad hess <- t(L)%*%hess%*%L if (!is.null(lsp.max)) { ## need to transform to delta space delta <- delta1 rho <- rt(delta,lsp1.max) nr <- length(rho$rho1) hess <- diag(rho$rho1,nr,nr)%*%hess%*%diag(rho$rho1,nr,nr) + diag(rho$rho2*grad) grad <- rho$rho1*grad } } else if (!is.finite(score1) || score1>=score||qerror >= qerror.thresh) { ## initial step failed, try step halving ... step <- Nstep ## start with the (pseudo) Newton direction while ((!is.finite(score1) || score1>=score ||qerror >= qerror.thresh) && ii < maxHalf) { if (ii==3&&i<10) { ## Newton really not working - switch to SD, but keeping step length s.length <- min(sum(step^2)^.5,maxSstep) step <- Sstep*s.length/sum(Sstep^2)^.5 ## use steepest descent direction sd.unused <- FALSE ## signal that SD already tried } else step <- step/2 if (!is.null(lsp.max)) { ## need to take step in delta space delta1 <- delta + step lsp1 <- rt(delta1,lsp1.max)$rho ## transform to log sp space } else lsp1 <- lsp + step b1<-gam.fit3(x=X, y=y, sp=L%*%lsp1+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=0, control=control,gamma=gamma,scale=scale, printWarn=FALSE,start=start,mustart=mustart,scoreType=scoreType, null.coef=null.coef,pearson.extra=pearson.extra, dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) pred.change <- sum(grad*step) + 0.5*t(step) %*% hess %*% step ## Taylor prediction of change if (reml) { score1 <- b1$REML } else if (scoreType=="GACV") { score1 <- b1$GACV } else if (scoreType=="UBRE") { score1 <- b1$UBRE } else score1 <- b1$GCV score.change <- score1 - score qerror <- abs(pred.change-score.change)/(max(abs(pred.change),abs(score.change))+score.scale*conv.tol) ## quadratic approx error if (is.finite(score1) && score.change < 0 && qerror < qerror.thresh) { ## accept if (pdef||!sd.unused) { ## then accept and compute derivatives b <- gam.fit3(x=X, y=y, sp=L%*%lsp1+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=2, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=start, mustart=mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) mustart <- b$fitted.values etastart <- b$linear.predictors start <- b$coefficients old.score <- score;lsp <- lsp1 if (reml) { score <- b$REML;grad <- b$REML1;hess <- b$REML2 } else if (scoreType=="GACV") { score <- b$GACV;grad <- b$GACV1;hess <- b$GACV2 } else if (scoreType=="UBRE") { score <- b$UBRE;grad <- b$UBRE1;hess <- b$UBRE2 } else { score <- b$GCV;grad <- b$GCV1;hess <- b$GCV2} grad <- t(L)%*%grad hess <- t(L)%*%hess%*%L if (!is.null(lsp.max)) { ## need to transform to delta space delta <- delta1 rho <- rt(delta,lsp1.max) nr <- length(rho$rho1) hess <- diag(rho$rho1,nr,nr)%*%hess%*%diag(rho$rho1,nr,nr) + diag(rho$rho2*grad) grad <- rho$rho1*grad } } else { ## still need to try the steepest descent step to see if it does better b <- b1 score2 <- score1 ## store temporarily and restore below } score1 <- score - abs(score) - 1 ## make sure that score1 < score (restore once out of loop) } # end of if (score1<= score ) # accept if (!is.finite(score1) || score1>=score || qerror >= qerror.thresh) ii <- ii + 1 } ## end while (score1>score && ii < maxHalf) if (!pdef&&sd.unused&&iiscore2)||kk==40) ok <- FALSE } ## while (ok) ## step length control loop ## now pick the step that led to the biggest decrease if (is.finite(score2) && score2 score.scale*conv.tol*.1)|(abs(grad2)>score.scale*conv.tol*.1) if (sum(abs(grad)>score.scale*conv.tol*5)) converged <- FALSE if (abs(old.score-score)>score.scale*conv.tol) { if (converged) uconv.ind <- uconv.ind | TRUE ## otherwise can't progress converged <- FALSE } if (ii==maxHalf) converged <- TRUE ## step failure if (converged) break } ## end of iteration loop if (ii==maxHalf) { ct <- "step failed" warning("Fitting terminated with step failure - check results carefully") } else if (i==200) { ct <- "iteration limit reached" warning("Iteration limit reached without full convergence - check carefully") } else ct <- "full convergence" b$dVkk <- NULL if (as.logical(edge.correct)&&reml) { ## for those smoothing parameters that appear to be at working infinity ## reduce them until there is a detectable increase in RE/ML... flat <- which(abs(grad2) < abs(grad)*100) ## candidates for reduction REML <- b$REML alpha <- if (is.logical(edge.correct)) .02 else abs(edge.correct) ## target RE/ML change per sp b1 <- b; lsp1 <- lsp if (length(flat)) for (i in flat) { REML <- b1$REML + alpha while (b1$REML < REML) { lsp1[i] <- lsp1[i] - 1 b1 <- gam.fit3(x=X, y=y, sp=L%*%lsp1+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=0, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=start, mustart=mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) } } b1 <- gam.fit3(x=X, y=y, sp=L%*%lsp1+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=2, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=start, mustart=mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) score1 <- b1$REML;grad1 <- b1$REML1;hess1 <- b1$REML2 grad1 <- t(L)%*%grad1 hess1 <- t(L)%*%hess1%*%L if (!is.null(lsp.max)) { ## need to transform to delta space delta <- delta1 rho <- rt(delta,lsp1.max) nr <- length(rho$rho1) hess1 <- diag(rho$rho1,nr,nr)%*%hess1%*%diag(rho$rho1,nr,nr) + diag(rho$rho2*grad1) grad1 <- rho$rho1*grad1 } attr(hess,"edge.correct") <- TRUE attr(hess,"hess1") <- hess1 attr(hess,"db.drho1") <- b1$db.drho attr(hess,"dw.drho1") <- b1$dw.drho attr(hess,"lsp1") <- lsp1 attr(hess,"rp") <- b1$rp } ## if edge.correct list(score=score,lsp=lsp,lsp.full=L%*%lsp+lsp0,grad=grad,hess=hess,iter=i, conv =ct,score.hist = score.hist[!is.na(score.hist)],object=b) } ## newton bfgs <- function(lsp,X,y,Eb,UrS,L,lsp0,offset,U1,Mp,family,weights, control,gamma,scale,conv.tol=1e-6,maxNstep=3,maxSstep=2, maxHalf=30,printWarn=FALSE,scoreType="GCV",start=NULL, mustart = NULL,null.coef=rep(0,ncol(X)),pearson.extra=0, dev.extra=0,n.true=-1,Sl=NULL,...) ## BFGS optimizer to estimate smoothing parameters of models fitted by ## gam.fit3.... ## ## L is the matrix such that L%*%lsp + lsp0 gives the logs of the smoothing ## parameters actually multiplying the S[[i]]'s. sp's do not include the ## log scale parameter here. ## ## BFGS is based on Nocedal & Wright (2006) Numerical Optimization, Springer. ## In particular the step lengths are chosen to meet the Wolfe conditions ## using their algorithms 3.5 (p60) and 3.6 (p61). On p143 they recommend a post step ## adjustment to the initial Hessian. I can't understand why one would do anything ## other than adjust so that the initial Hessian would give the step taken, and ## indeed the latter adjustment seems to give faster convergence than their ## proposal, and is therefore implemented. ## { zoom <- function(lo,hi) { ## local function implementing Algorithm 3.6 of Nocedal & Wright ## (2006, p61) Numerical Optimization. Relies on R scoping rules. ## alpha.lo and alpha.hi are the bracketing step lengths. ## This routine bisection searches for a step length that meets the ## Wolfe conditions. lo and hi are both objects containing fields ## `score', `alpha', `dscore', where `dscore' is the derivative of ## the score in the current step direction, `grad' and `mustart'. ## `dscore' will be NULL if the gradiant has yet to be evaluated. for (i in 1:40) { trial <- list(alpha = (lo$alpha+hi$alpha)/2) lsp <- ilsp + step * trial$alpha b <- gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=0, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=lo$start, mustart=lo$mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) trial$mustart <- fitted(b) trial$scale.est <- b$scale.est ## previously dev, but this differs from newton trial$start <- coef(b) if (reml) { trial$score <- b$REML; } else if (scoreType=="GACV") { trial$score <- b$GACV; } else if (scoreType=="UBRE"){ trial$score <- b$UBRE; } else { ## default to deviance based GCV trial$score <- b$GCV; } rm(b) if (trial$score>initial$score+trial$alpha*c1*initial$dscore||trial$score>=lo$score) { hi <- trial ## failed Wolfe 1 } else { ## met Wolfe 1 b <- gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=1, control=control,gamma=gamma,scale=scale,printWarn=FALSE, start=trial$start,mustart=trial$mustart, scoreType=scoreType,null.coef=null.coef,pearson.extra=pearson.extra, dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) if (reml) { trial$grad <- t(L)%*%b$REML1; } else if (scoreType=="GACV") { trial$grad <- t(L)%*%b$GACV1; } else if (scoreType=="UBRE"){ trial$grad <- t(L)%*%b$UBRE1 } else { ## default to deviance based GCV trial$grad <- t(L)%*%b$GCV1; } trial$dVkk <- diag(t(L0) %*% b$dVkk %*% L0) trial$scale.est <- b$scale.est;rm(b); trial$dscore <- sum(step*trial$grad) ## directional derivative if (abs(trial$dscore) <= -c2*initial$dscore) return(trial) ## met Wolfe 2 ## failed Wolfe 2 ... if (trial$dscore*(hi$alpha-lo$alpha)>=0) { hi <- lo } lo <- trial } } ## end while(TRUE) return(NULL) ## failed } ## end zoom reml <- scoreType%in%c("REML","P-REML","ML","P-ML") ## REML/ML indicator ## sanity check L if (is.null(L)) L <- diag(length(lsp)) else { if (!inherits(L,"matrix")) stop("L must be a matrix.") if (nrow(L)=0) { ## step not descending! ## Following would really be in the positive definite space... ##step[uconv.ind] <- -solve(chol2inv(chol(B))[uconv.ind,uconv.ind],initial$grad[uconv.ind]) step <- -diag(B)*initial$grad ## simple scaled steepest descent step[!uconv.ind] <- 0 ## don't move if apparently converged } ms <- max(abs(step)) trial <- list() if (ms>maxNstep) { trial$alpha <- maxNstep/ms alpha.max <- trial$alpha*1.05 ## step <- maxNstep * step/ms #alpha.max <- 1 ## was 50 in place of 1 here and below } else { trial$alpha <- 1 alpha.max <- min(2,maxNstep/ms) ## 1*maxNstep/ms } initial$dscore <- sum(step*initial$grad) prev <- initial deriv <- 1 ## only get derivatives immediately for initial step length while(TRUE) { ## step length control Alg 3.5 of N&W (2006, p60) lsp <- ilsp + trial$alpha*step b <- gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=prev$start, mustart=prev$mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) ### Derivative testing code. Not usually called and not part of BFGS... ok <- check.derivs while (ok) { ## derivative testing #deriv <- 1 ok <- FALSE ## set to TRUE to re-run (e.g. with different eps) deriv.check(x=X, y=y, sp=L%*%lsp+lsp0, Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=1, control=control,gamma=gamma,scale=scale, printWarn=FALSE,mustart=mustart,start=start, scoreType=scoreType,eps=eps,null.coef=null.coef,Sl=Sl,...) ## deal with fact that deriv might be 0... bb <- if (deriv==1) b else gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=1, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=prev$start, mustart=prev$mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) fdH <- bb$dH fdb.dr <- bb$db.drho*0 for (j in 1:length(lsp)) { ## check dH and db.drho lsp1 <- lsp;lsp1[j] <- lsp[j] + eps ba <- gam.fit3(x=X, y=y, sp=L%*%lsp1+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=1, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=prev$start, mustart=prev$mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) fdH[[j]] <- (ba$H - bb$H)/eps fdb.dr[,j] <- (ba$coefficients - bb$coefficients)/eps } } ### end of derivative testing. BFGS code resumes... if (reml) { trial$score <- b$REML; } else if (scoreType=="GACV") { trial$score <- b$GACV; } else if (scoreType=="UBRE"){ trial$score <- b$UBRE; } else { ## default to deviance based GCV trial$score <- b$GCV; } if (deriv>0) { if (reml) { trial$grad <- t(L)%*%b$REML1; } else if (scoreType=="GACV") { trial$grad <- t(L)%*%b$GACV1; } else if (scoreType=="UBRE"){ trial$grad <- t(L)%*%b$UBRE1 } else { ## default to deviance based GCV trial$grad <- t(L)%*%b$GCV1; } trial$dVkk <- diag(t(L0) %*% b$dVkk %*% L0) ## curvature testing matrix trial$dscore <- sum(trial$grad*step) deriv <- 0 } else trial$grad <- trial$dscore <- NULL trial$mustart <- b$fitted.values trial$start <- b$coefficients trial$scale.est <- b$scale.est rm(b) Wolfe2 <- TRUE ## check the first Wolfe condition (sufficient decrease)... if (trial$score>initial$score+c1*trial$alpha*initial$dscore||(deriv==0&&trial$score>=prev$score)) { trial <- zoom(prev,trial) ## Wolfe 1 not met so backtracking break } if (is.null(trial$dscore)) { ## getting gradients b <- gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=1, control=control,gamma=gamma,scale=scale,printWarn=FALSE, start=trial$start,mustart=trial$mustart, scoreType=scoreType,null.coef=null.coef,pearson.extra=pearson.extra, dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) if (reml) { trial$grad <- t(L)%*%b$REML1; } else if (scoreType=="GACV") { trial$grad <- t(L)%*%b$GACV1; } else if (scoreType=="UBRE"){ trial$grad <- t(L)%*%b$UBRE1 } else { ## default to deviance based GCV trial$grad <- t(L)%*%b$GCV1; } trial$dscore <- sum(trial$grad*step) trial$scale.est <- b$scale.est trial$dVkk <- diag(t(L0) %*% b$dVkk %*% L0) ## curvature testing matrix rm(b) } ## Note that written this way so that we can pass on to next test when appropriate... if (abs(trial$dscore) <= -c2*initial$dscore) break; ## `trial' is ok. (2nd Wolfe condition met). Wolfe2 <- FALSE if (trial$dscore>=0) { ## increase at end of trial step trial <- zoom(trial,prev) Wolfe2 <- if (is.null(trial)) FALSE else TRUE break } prev <- trial if (trial$alpha == alpha.max) break ## { trial <- NULL;break;} ## step failed trial <- list(alpha = min(prev$alpha*1.3, alpha.max)) ## increase trial step to try to meet Wolfe 2 } ## end of while(TRUE) ## Now `trial' contains a suitable step, or is NULL on complete failure to meet Wolfe, ## or contains a step that fails to meet Wolfe2, so that B can not be updated if (is.null(trial)) { ## step failed lsp <- ilsp break ## failed to move, so nothing more can be done. } else { ## update the Hessian etc... yg <- trial$grad-initial$grad step <- step*trial$alpha if (Wolfe2) { ## only update if Wolfe2 is met, otherwise B can fail to be +ve def. if (i==1) { ## initial step --- adjust Hessian as p143 of N&W B <- B * trial$alpha ## this is my version ## B <- B * sum(yg*step)/sum(yg*yg) ## this is N&W } rho <- 1/sum(yg*step) B <- B - rho*step%*%(t(yg)%*%B) ## Note that Wolfe 2 guarantees that rho>0 and updated B is ## +ve definite (left as an exercise for the reader)... B <- B - rho*(B%*%yg)%*%t(step) + rho*step%*%t(step) } score.hist[i+1] <- trial$score lsp <- ilsp <- ilsp + step ## test for convergence converged <- TRUE if (reml) score.scale <- 1 + abs(trial$score) ## abs(log(trial$dev/nrow(X))) + abs(trial$score) else score.scale <- abs(trial$scale.est) + abs(trial$score) ##trial$dev/nrow(X) + abs(trial$score) uconv.ind <- abs(trial$grad) > score.scale*conv.tol if (sum(uconv.ind)) converged <- FALSE if (length(uconv.ind)>length(trial$dVkk)) trial$dVkk <- c(trial$dVkk,score.scale) ## following must be tighter than convergence... uconv.ind <- abs(trial$grad) > score.scale*conv.tol*.1 | abs(trial$dVkk) > score.scale * conv.tol*.1 if (abs(initial$score-trial$score) > score.scale*conv.tol) { if (!sum(uconv.ind)) uconv.ind <- uconv.ind | TRUE ## otherwise can't progress converged <- FALSE } ## roll back any `infinite' smoothing parameters to the point at ## which score carries some information about them and continue ## optimization. Guards against early long steps missing shallow minimum. if (converged) { ## try roll back for `working inf' sps... if (sum(!uconv.ind)==0||rolled.back) break rolled.back <- TRUE counter <- 0 uconv.ind0 <- uconv.ind while (sum(!uconv.ind0)>0&&counter<5) { ## shrink towards initial values... lsp[!uconv.ind0] <- lsp[!uconv.ind0]*.8 + initial.lsp[!uconv.ind0]*.2 b <- gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=1, control=control,gamma=gamma,scale=scale,printWarn=FALSE, start=trial$start,mustart=trial$mustart, scoreType=scoreType,null.coef=null.coef,pearson.extra=pearson.extra, dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) if (reml) { trial$score <- b$REML trial$grad <- t(L)%*%b$REML1; } else if (scoreType=="GACV") { trial$score <- b$GACV trial$grad <- t(L)%*%b$GACV1; } else if (scoreType=="UBRE"){ trial$score <- b$UBRE trial$grad <- t(L)%*%b$UBRE1 } else { ## default to deviance based GCV trial$score <- b$GCV trial$grad <- t(L)%*%b$GCV1; } trial$dscore <- sum(trial$grad*step) trial$scale.est <- b$scale.est trial$dVkk <- diag(t(L0) %*% b$dVkk %*% L0) ## curvature testing matrix if (length(uconv.ind)>length(trial$dVkk)) trial$dVkk <- c(trial$dVkk,score.scale) rm(b);counter <- counter + 1 ## note that following rolls back until there is clear signal in derivs... uconv.ind0 <- abs(trial$grad) > score.scale*conv.tol*20 | abs(trial$dVkk) > score.scale * conv.tol * 20 uconv.ind0 <- uconv.ind0 | uconv.ind ## make sure we don't start rolling back unproblematic sps } uconv.ind <- uconv.ind | TRUE ## following line is tempting, but will likely reduce usefullness of B as approximtion ## to inverse Hessian on return... ##B <- diag(diag(B),nrow=nrow(B)) ilsp <- lsp } initial <- trial initial$alpha <- 0 } } ## end of iteration loop if (is.null(trial)) { ct <- "step failed" lsp <- ilsp trial <- initial } else if (i==max.step) ct <- "iteration limit reached" else ct <- "full convergence" ## final fit b <- gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=1, control=control,gamma=gamma,scale=scale,printWarn=FALSE, start=trial$start,mustart=trial$mustart, scoreType=scoreType,null.coef=null.coef,pearson.extra=pearson.extra, dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) if (reml) { score <- b$REML;grad <- t(L)%*%b$REML1; } else if (scoreType=="GACV") { score <- b$GACV;grad <- t(L)%*%b$GACV1; } else if (scoreType=="UBRE"){ score <- b$UBRE;grad <- t(L)%*%b$UBRE1 } else { ## default to deviance based GCV score <- b$GCV;grad <- t(L)%*%b$GCV1; } b$dVkk <- NULL ## get approximate Hessian... ev <- eigen(B,symmetric=TRUE) ind <- ev$values>max(ev$values)*.Machine$double.eps^.9 ev$values[ind] <- 1/ev$values[ind] ev$values[!ind] <- 0 B <- ev$vectors %*% (ev$values*t(ev$vectors)) list(score=score,lsp=lsp,lsp.full=L%*%lsp+lsp0,grad=grad,hess=B,iter=i,conv =ct, score.hist=score.hist[!is.na(score.hist)],object=b) } ## end of bfgs gam2derivative <- function(lsp,args,...) ## Performs IRLS GAM fitting for smoothing parameters given in lsp ## and returns the derivatives of the GCV or UBRE score w.r.t the ## smoothing parameters for the model. ## args is a list containing the arguments for gam.fit3 ## For use as optim() objective gradient { reml <- args$scoreType%in%c("REML","P-REML","ML","P-ML") ## REML/ML indicator if (!is.null(args$L)) { lsp <- args$L%*%lsp + args$lsp0 } b<-gam.fit3(x=args$X, y=args$y, sp=lsp,Eb=args$Eb,UrS=args$UrS, offset = args$offset,U1=args$U1,Mp=args$Mp,family = args$family,weights=args$w,deriv=1, control=args$control,gamma=args$gamma,scale=args$scale,scoreType=args$scoreType, null.coef=args$null.coef,n.true=args$n.true,Sl=args$Sl,...) if (reml) { ret <- b$REML1 } else if (args$scoreType=="GACV") { ret <- b$GACV1 } else if (args$scoreType=="UBRE") { ret <- b$UBRE1 } else { ret <- b$GCV1} if (!is.null(args$L)) ret <- t(args$L)%*%ret ret } ## gam2derivative gam2objective <- function(lsp,args,...) ## Performs IRLS GAM fitting for smoothing parameters given in lsp ## and returns the GCV or UBRE score for the model. ## args is a list containing the arguments for gam.fit3 ## For use as optim() objective { reml <- args$scoreType%in%c("REML","P-REML","ML","P-ML") ## REML/ML indicator if (!is.null(args$L)) { lsp <- args$L%*%lsp + args$lsp0 } b<-gam.fit3(x=args$X, y=args$y, sp=lsp,Eb=args$Eb,UrS=args$UrS, offset = args$offset,U1=args$U1,Mp=args$Mp,family = args$family,weights=args$w,deriv=0, control=args$control,gamma=args$gamma,scale=args$scale,scoreType=args$scoreType, null.coef=args$null.coef,n.true=args$n.true,Sl=args$Sl,start=args$start,...) if (reml) { ret <- b$REML } else if (args$scoreType=="GACV") { ret <- b$GACV } else if (args$scoreType=="UBRE") { ret <- b$UBRE } else { ret <- b$GCV} attr(ret,"full.fit") <- b ret } ## gam2objective gam4objective <- function(lsp,args,...) ## Performs IRLS GAM fitting for smoothing parameters given in lsp ## and returns the GCV or UBRE score for the model. ## args is a list containing the arguments for gam.fit3 ## For use as nlm() objective { reml <- args$scoreType%in%c("REML","P-REML","ML","P-ML") ## REML/ML indicator if (!is.null(args$L)) { lsp <- args$L%*%lsp + args$lsp0 } b<-gam.fit3(x=args$X, y=args$y, sp=lsp, Eb=args$Eb,UrS=args$UrS, offset = args$offset,U1=args$U1,Mp=args$Mp,family = args$family,weights=args$w,deriv=1, control=args$control,gamma=args$gamma,scale=args$scale,scoreType=args$scoreType, null.coef=args$null.coef,Sl=args$Sl,start=args$start,...) if (reml) { ret <- b$REML;at <- b$REML1 } else if (args$scoreType=="GACV") { ret <- b$GACV;at <- b$GACV1 } else if (args$scoreType=="UBRE") { ret <- b$UBRE;at <- b$UBRE1 } else { ret <- b$GCV;at <- b$GCV1} attr(ret,"full.fit") <- b if (!is.null(args$L)) at <- t(args$L)%*%at attr(ret,"gradient") <- at ret } ## gam4objective ## ## The following fix up family objects for use with gam.fit3 ## fix.family.link.general.family <- function(fam) fix.family.link.family(fam) fix.family.link.extended.family <- function(fam) { ## extended families require link derivatives in ratio form. ## g2g= g''/g'^2, g3g = g'''/g'^3, g4g = g''''/g'^4 - these quanitities are often ## less overflow prone than the raw derivatives if (!is.null(fam$g2g)&&!is.null(fam$g3g)&&!is.null(fam$g4g)) return(fam) link <- fam$link if (link=="identity") { fam$g2g <- fam$g3g <- fam$g4g <- function(mu) rep.int(0,length(mu)) return(fam) } if (link == "log") { fam$g2g <- function(mu) rep(-1,length(mu)) fam$g3g <- function(mu) rep(2,length(mu)) fam$g4g <- function(mu) rep(-6,length(mu)) return(fam) } if (link == "inverse") { ## g'(mu) = -1/mu^2 fam$g2g <- function(mu) 2*mu ## g'' = 2/mu^3 fam$g3g <- function(mu) 6*mu^2 ## g''' = -6/mu^4 fam$g4g <- function(mu) 24*mu^3 ## g'''' = 24/mu^5 return(fam) } if (link == "logit") { ## g = log(mu/(1-mu)) g' = 1/(1-mu) + 1/mu = 1/(mu*(1-mu)) fam$g2g <- function(mu) mu^2 - (1-mu)^2 ## g'' = 1/(1 - mu)^2 - 1/mu^2 fam$g3g <- function(mu) 2*mu^3 + 2*(1-mu)^3 ## g''' = 2/(1 - mu)^3 + 2/mu^3 fam$g4g <- function(mu) 6*mu^4 - 6*(1-mu)^4 ## g'''' = 6/(1-mu)^4 - 6/mu^4 return(fam) } if (link == "sqrt") { ## g = sqrt(mu); g' = .5*mu^-.5 fam$g2g <- function(mu) - mu^-.5 ## g'' = -.25 * mu^-1.5 fam$g3g <- function(mu) 3 * mu^-1 ## g''' = .375 * mu^-2.5 fam$g4g <- function(mu) -15 * mu^-1.5 ## -0.9375 * mu^-3.5 return(fam) } if (link == "probit") { ## g(mu) = qnorm(mu); 1/g' = dmu/deta = 1/dnorm(eta) fam$g2g <- function(mu) { eta <- fam$linkfun(mu) ## g'' = eta/fam$mu.eta(eta)^2 eta } fam$g3g <- function(mu) { eta <- fam$linkfun(mu) ## g''' = (1 + 2*eta^2)/fam$mu.eta(eta)^3 (1 + 2*eta^2) } fam$g4g <- function(mu) { eta <- fam$linkfun(mu) ## g'''' = (7*eta + 6*eta^3)/fam$mu.eta(eta)^4 (7*eta + 6*eta^3) } return(fam) } ## probit if (link == "cauchit") { ## uses general result that if link is a quantile function then ## d mu / d eta = f(eta) where f is the density. Link derivative ## is one over this... repeated differentiation w.r.t. mu using chain ## rule gives results... fam$g2g <- function(mu) { eta <- fam$linkfun(mu) ## g'' = 2*pi*pi*eta*(1+eta*eta) eta/(1+eta*eta) } fam$g3g <- function(mu) { eta <- fam$linkfun(mu) eta2 <- eta*eta ## g''' = 2*pi*pi*pi*(1+3*eta2)*(1+eta2) (1+3*eta2)/(1+eta2)^2 } fam$g4g <- function(mu) { eta <- fam$linkfun(mu) eta2 <- eta*eta ## g'''' = 2*pi^4*(8*eta+12*eta2*eta)*(1+eta2) ((8+ 12*eta2)/(1+eta2)^2)*(eta/(1+eta2)) } return(fam) } ## cauchit if (link == "cloglog") { ## g = log(-log(1-mu)), g' = -1/(log(1-mu)*(1-mu)) fam$g2g <- function(mu) { l1m <- log1p(-mu) -l1m - 1 } fam$g3g <- function(mu) { l1m <- log1p(-mu) l1m*(2*l1m + 3) + 2 } fam$g4g <- function(mu){ l1m <- log1p(-mu) -l1m*(l1m*(6*l1m+11)+12)-6 } return(fam) } stop("link not implemented for extended families") } ## fix.family.link.extended.family fix.family.link.family <- function(fam) # adds d2link the second derivative of the link function w.r.t. mu # to the family supplied, as well as a 3rd derivative function # d3link... # All d2link and d3link functions have been checked numerically. { if (!inherits(fam,"family")) stop("fam not a family object") if (is.null(fam$canonical)) { ## note the canonical link - saves effort in full Newton if (fam$family=="gaussian") fam$canonical <- "identity" else if (fam$family=="poisson"||fam$family=="quasipoisson") fam$canonical <- "log" else if (fam$family=="binomial"||fam$family=="quasibinomial") fam$canonical <- "logit" else if (fam$family=="Gamma") fam$canonical <- "inverse" else if (fam$family=="inverse.gaussian") fam$canonical <- "1/mu^2" else fam$canonical <- "none" } if (!is.null(fam$d2link)&&!is.null(fam$d3link)&&!is.null(fam$d4link)) return(fam) link <- fam$link if (length(link)>1) if (fam$family=="quasi") # then it's a power link { lambda <- log(fam$linkfun(exp(1))) ## the power, if > 0 if (lambda<=0) { fam$d2link <- function(mu) -1/mu^2 fam$d3link <- function(mu) 2/mu^3 fam$d4link <- function(mu) -6/mu^4 } else { fam$d2link <- function(mu) lambda*(lambda-1)*mu^(lambda-2) fam$d3link <- function(mu) (lambda-2)*(lambda-1)*lambda*mu^(lambda-3) fam$d4link <- function(mu) (lambda-3)*(lambda-2)*(lambda-1)*lambda*mu^(lambda-4) } return(fam) } else stop("unrecognized (vector?) link") if (link=="identity") { fam$d4link <- fam$d3link <- fam$d2link <- function(mu) rep.int(0,length(mu)) return(fam) } if (link == "log") { fam$d2link <- function(mu) -1/mu^2 fam$d3link <- function(mu) 2/mu^3 fam$d4link <- function(mu) -6/mu^4 return(fam) } if (link == "inverse") { fam$d2link <- function(mu) 2/mu^3 fam$d3link <- function(mu) { mu <- mu*mu;-6/(mu*mu)} fam$d4link <- function(mu) { mu2 <- mu*mu;24/(mu2*mu2*mu)} return(fam) } if (link == "logit") { fam$d2link <- function(mu) 1/(1 - mu)^2 - 1/mu^2 fam$d3link <- function(mu) 2/(1 - mu)^3 + 2/mu^3 fam$d4link <- function(mu) 6/(1-mu)^4 - 6/mu^4 return(fam) } if (link == "probit") { fam$d2link <- function(mu) { eta <- fam$linkfun(mu) eta/fam$mu.eta(eta)^2 } fam$d3link <- function(mu) { eta <- fam$linkfun(mu) (1 + 2*eta^2)/fam$mu.eta(eta)^3 } fam$d4link <- function(mu) { eta <- fam$linkfun(mu) (7*eta + 6*eta^3)/fam$mu.eta(eta)^4 } return(fam) } if (link == "cloglog") { ## g = log(-log(1-mu)), g' = -1/(log(1-mu)*(1-mu)) fam$d2link <- function(mu) { l1m <- log1p(-mu) -1/((1 - mu)^2*l1m) *(1+ 1/l1m) } fam$d3link <- function(mu) { l1m <- log1p(-mu) mu3 <- (1-mu)^3 (-2 - 3*l1m - 2*l1m^2)/mu3/l1m^3 } fam$d4link <- function(mu){ l1m <- log1p(-mu) mu4 <- (1-mu)^4 ( - 12 - 11 * l1m - 6 * l1m^2 - 6/l1m )/mu4 /l1m^3 } return(fam) } if (link == "sqrt") { fam$d2link <- function(mu) -.25 * mu^-1.5 fam$d3link <- function(mu) .375 * mu^-2.5 fam$d4link <- function(mu) -0.9375 * mu^-3.5 return(fam) } if (link == "cauchit") { ## uses general result that if link is a quantile function then ## d mu / d eta = f(eta) where f is the density. Link derivative ## is one over this... repeated differentiation w.r.t. mu using chain ## rule gives results... fam$d2link <- function(mu) { eta <- fam$linkfun(mu) 2*pi*pi*eta*(1+eta*eta) } fam$d3link <- function(mu) { eta <- fam$linkfun(mu) eta2 <- eta*eta 2*pi*pi*pi*(1+3*eta2)*(1+eta2) } fam$d4link <- function(mu) { eta <- fam$linkfun(mu) eta2 <- eta*eta 2*pi^4*(8*eta+12*eta2*eta)*(1+eta2) } return(fam) } if (link == "1/mu^2") { fam$d2link <- function(mu) 6 * mu^-4 fam$d3link <- function(mu) -24 * mu^-5 fam$d4link <- function(mu) 120 * mu^-6 return(fam) } if (substr(link,1,3)=="mu^") { ## it's a power link ## note that lambda <=0 gives log link so don't end up here lambda <- get("lambda",environment(fam$linkfun)) fam$d2link <- function(mu) (lambda*(lambda-1)) * mu^{lambda-2} fam$d3link <- function(mu) (lambda*(lambda-1)*(lambda-2)) * mu^{lambda-3} fam$d4link <- function(mu) (lambda*(lambda-1)*(lambda-2)*(lambda-3)) * mu^{lambda-4} return(fam) } stop("link not recognised") } ## fix.family.link.family fix.family.link <- function(fam) UseMethod("fix.family.link") fix.family.var <- function(fam) # adds dvar the derivative of the variance function w.r.t. mu # to the family supplied, as well as d2var the 2nd derivative of # the variance function w.r.t. the mean. (All checked numerically). { if (inherits(fam,"extended.family")) return(fam) if (!inherits(fam,"family")) stop("fam not a family object") if (!is.null(fam$dvar)&&!is.null(fam$d2var)&&!is.null(fam$d3var)) return(fam) family <- fam$family if (family=="gaussian") { fam$d3var <- fam$d2var <- fam$dvar <- function(mu) rep.int(0,length(mu)) return(fam) } if (family=="poisson"||family=="quasipoisson") { fam$dvar <- function(mu) rep.int(1,length(mu)) fam$d3var <- fam$d2var <- function(mu) rep.int(0,length(mu)) return(fam) } if (family=="binomial"||family=="quasibinomial") { fam$dvar <- function(mu) 1-2*mu fam$d2var <- function(mu) rep.int(-2,length(mu)) fam$d3var <- function(mu) rep.int(0,length(mu)) return(fam) } if (family=="Gamma") { fam$dvar <- function(mu) 2*mu fam$d2var <- function(mu) rep.int(2,length(mu)) fam$d3var <- function(mu) rep.int(0,length(mu)) return(fam) } if (family=="quasi") { fam$dvar <- switch(fam$varfun, constant = function(mu) rep.int(0,length(mu)), "mu(1-mu)" = function(mu) 1-2*mu, mu = function(mu) rep.int(1,length(mu)), "mu^2" = function(mu) 2*mu, "mu^3" = function(mu) 3*mu^2 ) if (is.null(fam$dvar)) stop("variance function not recognized for quasi") fam$d2var <- switch(fam$varfun, constant = function(mu) rep.int(0,length(mu)), "mu(1-mu)" = function(mu) rep.int(-2,length(mu)), mu = function(mu) rep.int(0,length(mu)), "mu^2" = function(mu) rep.int(2,length(mu)), "mu^3" = function(mu) 6*mu ) fam$d3var <- switch(fam$varfun, constant = function(mu) rep.int(0,length(mu)), "mu(1-mu)" = function(mu) rep.int(0,length(mu)), mu = function(mu) rep.int(0,length(mu)), "mu^2" = function(mu) rep.int(0,length(mu)), "mu^3" = function(mu) rep.int(6,length(mu)) ) return(fam) } if (family=="inverse.gaussian") { fam$dvar <- function(mu) 3*mu^2 fam$d2var <- function(mu) 6*mu fam$d3var <- function(mu) rep.int(6,length(mu)) return(fam) } stop("family not recognised") } ## fix.family.var fix.family.ls<-function(fam) # adds ls the log saturated likelihood and its derivatives # w.r.t. the scale parameter to the family object. { if (!inherits(fam,"family")) stop("fam not a family object") if (!is.null(fam$ls)) return(fam) family <- fam$family if (family=="gaussian") { fam$ls <- function(y,w,n,scale) { nobs <- sum(w>0) c(-nobs*log(2*pi*scale)/2 + sum(log(w[w>0]))/2,-nobs/(2*scale),nobs/(2*scale*scale)) } return(fam) } if (family=="poisson") { fam$ls <- function(y,w,n,scale) { res <- rep(0,3) res[1] <- sum(dpois(y,y,log=TRUE)*w) res } return(fam) } if (family=="binomial") { fam$ls <- function(y,w,n,scale) { c(-binomial()$aic(y,n,y,w,0)/2,0,0) } return(fam) } if (family=="Gamma") { fam$ls <- function(y,w,n,scale) { res <- rep(0,3) y <- y[w>0];w <- w[w>0] scale <- scale/w k <- -lgamma(1/scale) - log(scale)/scale - 1/scale res[1] <- sum(k-log(y)) k <- (digamma(1/scale)+log(scale))/(scale*scale) res[2] <- sum(k/w) k <- (-trigamma(1/scale)/(scale) + (1-2*log(scale)-2*digamma(1/scale)))/(scale^3) res[3] <- sum(k/w^2) res } return(fam) } if (family=="quasi"||family=="quasipoisson"||family=="quasibinomial") { ## fam$ls <- function(y,w,n,scale) rep(0,3) ## Uses extended quasi-likelihood form... fam$ls <- function(y,w,n,scale) { nobs <- sum(w>0) c(-nobs*log(scale)/2 + sum(log(w[w>0]))/2,-nobs/(2*scale),nobs/(2*scale*scale)) } return(fam) } if (family=="inverse.gaussian") { fam$ls <- function(y,w,n,scale) { nobs <- sum(w>0) c(-sum(log(2*pi*scale*y^3))/2 + sum(log(w[w>0]))/2,-nobs/(2*scale),nobs/(2*scale*scale)) ## c(-sum(w*log(2*pi*scale*y^3))/2,-sum(w)/(2*scale),sum(w)/(2*scale*scale)) } return(fam) } stop("family not recognised") } ## fix.family.ls fix.family <- function(fam) { ## allows families to be patched... if (fam$family[1]=="gaussian") { ## sensible starting values given link... fam$initialize <- expression({ n <- rep.int(1, nobs) if (family$link == "inverse") mustart <- y + (y==0)*sd(y)*.01 else if (family$link == "log") mustart <- pmax(y,.01*sd(y)) else mustart <- y }) } fam } ## fix.family negbin <- function (theta = stop("'theta' must be specified"), link = "log") { ## modified from Venables and Ripley's MASS library to work with gam.fit3, ## and to allow a range of `theta' values to be specified ## single `theta' to specify fixed value; 2 theta values (first smaller than second) ## are limits within which to search for theta; otherwise supplied values make up ## search set. ## Note: to avoid warnings, get(".Theta")[1] is used below. Otherwise the initialization ## call to negbin can generate warnings since get(".Theta") returns a vector ## during initialization (only). linktemp <- substitute(link) if (!is.character(linktemp)) linktemp <- deparse(linktemp) if (linktemp %in% c("log", "identity", "sqrt")) stats <- make.link(linktemp) else if (is.character(link)) { stats <- make.link(link) linktemp <- link } else { if (inherits(link, "link-glm")) { stats <- link if (!is.null(stats$name)) linktemp <- stats$name } else stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"",linktemp)) } env <- new.env(parent = .GlobalEnv) assign(".Theta", theta, envir = env) variance <- function(mu) mu + mu^2/get(".Theta")[1] ## dvaraince/dmu needed as well dvar <- function(mu) 1 + 2*mu/get(".Theta")[1] ## d2variance/dmu... d2var <- function(mu) rep(2/get(".Theta")[1],length(mu)) d3var <- function(mu) rep(0,length(mu)) getTheta <- function() get(".Theta") validmu <- function(mu) all(mu > 0) dev.resids <- function(y, mu, wt) { Theta <- get(".Theta")[1] 2 * wt * (y * log(pmax(1, y)/mu) - (y + Theta) * log((y + Theta)/(mu + Theta))) } aic <- function(y, n, mu, wt, dev) { Theta <- get(".Theta")[1] term <- (y + Theta) * log(mu + Theta) - y * log(mu) + lgamma(y + 1) - Theta * log(Theta) + lgamma(Theta) - lgamma(Theta + y) 2 * sum(term * wt) } ls <- function(y,w,n,scale) { Theta <- get(".Theta")[1] ylogy <- y;ind <- y>0;ylogy[ind] <- y[ind]*log(y[ind]) term <- (y + Theta) * log(y + Theta) - ylogy + lgamma(y + 1) - Theta * log(Theta) + lgamma(Theta) - lgamma(Theta + y) c(-sum(term*w),0,0) } initialize <- expression({ if (any(y < 0)) stop("negative values not allowed for the negative binomial family") n <- rep(1, nobs) mustart <- y + (y == 0)/6 }) rd <- function(mu,wt,scale) { Theta <- get(".Theta")[1] rnbinom(mu,size=Theta,mu=mu) } qf <- function(p,mu,wt,scale) { Theta <- get(".Theta")[1] qnbinom(p,size=Theta,mu=mu) } environment(qf) <- environment(rd) <- environment(dvar) <- environment(d2var) <- environment(d3var) <-environment(variance) <- environment(validmu) <- environment(ls) <- environment(dev.resids) <- environment(aic) <- environment(getTheta) <- env famname <- paste("Negative Binomial(", format(round(theta,3)), ")", sep = "") structure(list(family = famname, link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, variance = variance,dvar=dvar,d2var=d2var,d3var=d3var, dev.resids = dev.resids, aic = aic, mu.eta = stats$mu.eta, initialize = initialize,ls=ls, validmu = validmu, valideta = stats$valideta,getTheta = getTheta,qf=qf,rd=rd,canonical="log"), class = "family") } ## negbin totalPenalty <- function(S,H,off,theta,p) { if (is.null(H)) St <- matrix(0,p,p) else { St <- H; if (ncol(H)!=p||nrow(H)!=p) stop("H has wrong dimension") } theta <- exp(theta) m <- length(theta) if (m>0) for (i in 1:m) { k0 <- off[i] k1 <- k0 + nrow(S[[i]]) - 1 St[k0:k1,k0:k1] <- St[k0:k1,k0:k1] + S[[i]] * theta[i] } St } ## totalPenalty totalPenaltySpace <- function(S,H,off,p) { ## function to obtain (orthogonal) basis for the null space and ## range space of the penalty, and obtain actual null space dimension ## components are roughly rescaled to avoid any dominating Hscale <- sqrt(sum(H*H)); if (Hscale==0) H <- NULL ## H was all zeroes anyway! if (is.null(H)) St <- matrix(0,p,p) else { St <- H/sqrt(sum(H*H)); if (ncol(H)!=p||nrow(H)!=p) stop("H has wrong dimension") } m <- length(S) if (m>0) for (i in 1:m) { k0 <- off[i] k1 <- k0 + nrow(S[[i]]) - 1 St[k0:k1,k0:k1] <- St[k0:k1,k0:k1] + S[[i]]/sqrt(sum(S[[i]]*S[[i]])) } es <- eigen(St,symmetric=TRUE) ind <- es$values>max(es$values)*.Machine$double.eps^.66 Y <- es$vectors[,ind,drop=FALSE] ## range space Z <- es$vectors[,!ind,drop=FALSE] ## null space - ncol(Z) is null space dimension E <- sqrt(as.numeric(es$values[ind]))*t(Y) ## E'E = St list(Y=Y,Z=Z,E=E) } ## totalPenaltySpace mini.roots <- function(S,off,np,rank=NULL) # function to obtain square roots, B[[i]], of S[[i]]'s having as few # columns as possible. S[[i]]=B[[i]]%*%t(B[[i]]). np is the total number # of parameters. S is in packed form. rank[i] is optional supplied rank # of S[[i]], rank[i] < 1, or rank=NULL to estimate. { m<-length(S) if (m<=0) return(list()) B<-S if (is.null(rank)) rank <- rep(-1,m) for (i in 1:m) { b <- mroot(S[[i]],rank=rank[i]) B[[i]] <- matrix(0,np,ncol(b)) B[[i]][off[i]:(off[i]+nrow(b)-1),] <- b } B } ldTweedie0 <- function(y,mu=y,p=1.5,phi=1,rho=NA,theta=NA,a=1.001,b=1.999) { ## evaluates log Tweedie density for 1<=p<=2, using series summation of ## Dunn & Smyth (2005) Statistics and Computing 15:267-280. ## Original fixed p and phi version. if (!is.na(rho)&&!is.na(theta)) { ## use rho and theta and get derivs w.r.t. these if (length(rho)>1||length(theta)>1) stop("only scalar `rho' and `theta' allowed.") if (a>=b||a<=1||b>=2) stop("10) (b+a*exp(-th))/(1+exp(-th)) else (b*exp(th)+a)/(exp(th)+1) dpth1 <- if (th>0) exp(-th)*(b-a)/(1+exp(-th))^2 else exp(th)*(b-a)/(exp(th)+1)^2 dpth2 <- if (th>0) ((a-b)*exp(-th)+(b-a)*exp(-2*th))/(exp(-th)+1)^3 else ((a-b)*exp(2*th)+(b-a)*exp(th))/(exp(th)+1)^3 } else { ## still need working params for tweedious call... work.param <- FALSE if (length(p)>1||length(phi)>1) stop("only scalar `p' and `phi' allowed.") rho <- log(phi) if (p>1&&p<2) { if (p <= a) a <- (1+p)/2 if (p >= b) b <- (2+p)/2 pabp <- (p-a)/(b-p) theta <- log((p-a)/(b-p)) dthp1 <- (1+pabp)/(p-a) dthp2 <- (pabp+1)/((p-a)*(b-p)) -(pabp+1)/(p-a)^2 } } if (p<1||p>2) stop("p must be in [1,2]") ld <- cbind(y,y,y);ld <- cbind(ld,ld*NA) if (p == 2) { ## It's Gamma if (sum(y<=0)) stop("y must be strictly positive for a Gamma density") ld[,1] <- dgamma(y, shape = 1/phi,rate = 1/(phi * mu),log=TRUE) ld[,2] <- (digamma(1/phi) + log(phi) - 1 + y/mu - log(y/mu))/(phi*phi) ld[,3] <- -2*ld[,2]/phi + (1-trigamma(1/phi)/phi)/(phi^3) return(ld) } if (length(mu)==1) mu <- rep(mu,length(y)) if (p == 1) { ## It's Poisson like ## ld[,1] <- dpois(x = y/phi, lambda = mu/phi,log=TRUE) if (all.equal(y/phi,round(y/phi))!=TRUE) stop("y must be an integer multiple of phi for Tweedie(p=1)") ind <- (y!=0)|(mu!=0) ## take care to deal with y log(mu) when y=mu=0 bkt <- y*0 bkt[ind] <- (y[ind]*log(mu[ind]/phi) - mu[ind]) dig <- digamma(y/phi+1) trig <- trigamma(y/phi+1) ld[,1] <- bkt/phi - lgamma(y/phi+1) ld[,2] <- (-bkt - y + dig*y)/(phi*phi) ld[,3] <- (2*bkt + 3*y - 2*dig*y - trig *y*y/phi)/(phi^3) return(ld) } ## .. otherwise need the full series thing.... ## first deal with the zeros ind <- y==0;ld[ind,] <- 0 ind <- ind & mu>0 ## need mu condition otherwise may try to find log(0) ld[ind,1] <- -mu[ind]^(2-p)/(phi*(2-p)) ld[ind,2] <- -ld[ind,1]/phi ## dld/d phi ld[ind,3] <- -2*ld[ind,2]/phi ## d2ld/dphi2 ld[ind,4] <- -ld[ind,1] * (log(mu[ind]) - 1/(2-p)) ## dld/dp ld[ind,5] <- 2*ld[ind,4]/(2-p) + ld[ind,1]*log(mu[ind])^2 ## d2ld/dp2 ld[ind,6] <- -ld[ind,4]/phi ## d2ld/dphidp if (sum(!ind)==0) return(ld) ## now the non-zeros ind <- y==0 y <- y[!ind];mu <- mu[!ind] w <- w1 <- w2 <- y*0 oo <- .C(C_tweedious,w=as.double(w),w1=as.double(w1),w2=as.double(w2),w1p=as.double(y*0),w2p=as.double(y*0), w2pp=as.double(y*0),y=as.double(y),eps=as.double(.Machine$double.eps^2),n=as.integer(length(y)), th=as.double(theta),rho=as.double(rho),a=as.double(a),b=as.double(b)) if (!work.param) { ## transform working param derivatives to p/phi derivs... oo$w2 <- oo$w2/phi^2 - oo$w1/phi^2 oo$w1 <- oo$w1/phi oo$w2p <- oo$w2p*dthp1^2 + dthp2 * oo$w1p oo$w1p <- oo$w1p*dthp1 oo$w2pp <- oo$w2pp*dthp1/phi ## this appears to be wrong } log.mu <- log(mu) mu1p <- theta <- mu^(1-p) k.theta <- mu*theta/(2-p) ## mu^(2-p)/(2-p) theta <- theta/(1-p) ## mu^(1-p)/(1-p) l.base <- mu1p*(y/(1-p)-mu/(2-p))/phi ld[!ind,1] <- l.base - log(y) ## log density ld[!ind,2] <- -l.base/phi ## d log f / dphi ld[!ind,3] <- 2*l.base/(phi*phi) ## d2 logf / dphi2 x <- theta*y*(1/(1-p) - log.mu)/phi + k.theta*(log.mu-1/(2-p))/phi ld[!ind,4] <- x ld[!ind,5] <- theta * y * (log.mu^2 - 2*log.mu/(1-p) + 2/(1-p)^2)/phi - k.theta * (log.mu^2 - 2*log.mu/(2-p) + 2/(2-p)^2)/phi ## d2 logf / dp2 ld[!ind,6] <- - x/phi ## d2 logf / dphi dp if (work.param) { ## transform derivs to derivs wrt working ld[,3] <- ld[,3]*phi^2 + ld[,2]*phi ld[,2] <- ld[,2]*phi ld[,5] <- ld[,5]*dpth1^2 + ld[,4]*dpth2 ld[,4] <- ld[,4]*dpth1 ld[,6] <- ld[,6]*dpth1*phi } if (TRUE) { ## DEBUG disconnetion of a terms ld[!ind,1] <- ld[!ind,1] + oo$w ## log density ld[!ind,2] <- ld[!ind,2] + oo$w1 ## d log f / dphi ld[!ind,3] <- ld[!ind,3] + oo$w2 ## d2 logf / dphi2 ld[!ind,4] <- ld[!ind,4] + oo$w1p ld[!ind,5] <- ld[!ind,5] + oo$w2p ## d2 logf / dp2 ld[!ind,6] <- ld[!ind,6] + oo$w2pp ## d2 logf / dphi dp } if (FALSE) { ## DEBUG disconnetion of density terms ld[!ind,1] <- oo$w ## log density ld[!ind,2] <- oo$w1 ## d log f / dphi ld[!ind,3] <- oo$w2 ## d2 logf / dphi2 ld[!ind,4] <- oo$w1p ld[!ind,5] <- oo$w2p ## d2 logf / dp2 ld[!ind,6] <- oo$w2pp ## d2 logf / dphi dp } ld } ## ldTweedie0 ldTweedie <- function(y,mu=y,p=1.5,phi=1,rho=NA,theta=NA,a=1.001,b=1.999,all.derivs=FALSE) { ## evaluates log Tweedie density for 1<=p<=2, using series summation of ## Dunn & Smyth (2005) Statistics and Computing 15:267-280. n <- length(y) if (!is.na(rho)&&!is.na(theta)) { ## use rho and theta and get derivs w.r.t. these #if (length(rho)>1||length(theta)>1) stop("only scalar `rho' and `theta' allowed.") if (a>=b||a<=1||b>=2) stop("1 0;dpth1 <- dpth2 <-p <- rep(0,n) ethi <- exp(-th[ind]) ethni <- exp(th[!ind]) p[ind] <- (b+a*ethi)/(1+ethi) p[!ind] <- (b*ethni+a)/(ethni+1) dpth1[ind] <- ethi*(b-a)/(1+ethi)^2 dpth1[!ind] <- ethni*(b-a)/(ethni+1)^2 dpth2[ind] <-((a-b)*ethi+(b-a)*ethi^2)/(ethi+1)^3 dpth2[!ind] <- ((a-b)*ethni^2+(b-a)*ethni)/(ethni+1)^3 #p <- if (th>0) (b+a*exp(-th))/(1+exp(-th)) else (b*exp(th)+a)/(exp(th)+1) #dpth1 <- if (th>0) exp(-th)*(b-a)/(1+exp(-th))^2 else exp(th)*(b-a)/(exp(th)+1)^2 #dpth2 <- if (th>0) ((a-b)*exp(-th)+(b-a)*exp(-2*th))/(exp(-th)+1)^3 else # ((a-b)*exp(2*th)+(b-a)*exp(th))/(exp(th)+1)^3 } else { ## still need working params for tweedious call... work.param <- FALSE if (all.derivs) warning("all.derivs only available in rho, theta parameterization") #if (length(p)>1||length(phi)>1) stop("only scalar `p' and `phi' allowed.") buffer <- if (length(unique(p))==1&&length(unique(phi))==1) TRUE else FALSE rho <- log(phi) if (min(p)>=1&&max(p)<=2) { ind <- p>1&p<2 if (sum(ind)) { p.ind <- p[ind] if (min(p.ind) <= a) a <- (1+min(p.ind))/2 if (max(p.ind) >= b) b <- (2+max(p.ind))/2 pabp <- theta <- dthp1 <- dthp2 <- rep(0,n) pabp[ind] <- (p.ind-a)/(b-p.ind) theta[ind] <- log((p.ind-a)/(b-p.ind)) dthp1[ind] <- (1+pabp[ind])/(p.ind-a) dthp2[ind] <- (pabp[ind]+1)/((p.ind-a)*(b-p.ind)) -(pabp[ind]+1)/(p.ind-a)^2 } } } if (min(p)<1||max(p)>2) stop("p must be in [1,2]") ld <- cbind(y,y,y);ld <- cbind(ld,ld*NA) if (work.param&&all.derivs) ld <- cbind(ld,ld[,1:3]*0,y*0) if (length(p)!=n) p <- array(p,dim=n); if (length(phi)!=n) phi <- array(phi,dim=n) if (length(mu)!=n) mu <- array(mu,dim=n) ind <- p == 2 if (sum(ind)) { ## It's Gamma if (sum(y[ind]<=0)) stop("y must be strictly positive for a Gamma density") ld[ind,1] <- dgamma(y[ind], shape = 1/phi[ind],rate = 1/(phi[ind] * mu[ind]),log=TRUE) ld[ind,2] <- (digamma(1/phi[ind]) + log(phi[ind]) - 1 + y[ind]/mu[ind] - log(y[ind]/mu[ind]))/(phi[ind]*phi[ind]) ld[ind,3] <- -2*ld[ind,2]/phi[ind] + (1-trigamma(1/phi[ind])/phi[ind])/(phi[ind]^3) #return(ld) } ind <- p == 1 if (sum(ind)) { ## It's Poisson like ## ld[,1] <- dpois(x = y/phi, lambda = mu/phi,log=TRUE) if (all.equal(y[ind]/phi[ind],round(y[ind]/phi[ind]))!=TRUE) stop("y must be an integer multiple of phi for Tweedie(p=1)") indi <- (y[ind]!=0)|(mu[ind]!=0) ## take care to deal with y log(mu) when y=mu=0 bkt <- y[ind]*0 bkt[indi] <- ((y[ind])[indi]*log((mu[ind]/phi[ind])[indi]) - (mu[ind])[indi]) dig <- digamma(y[ind]/phi[ind]+1) trig <- trigamma(y[ind]/phi[ind]+1) ld[ind,1] <- bkt/phi[ind] - lgamma(y[ind]/phi[ind]+1) ld[ind,2] <- (-bkt - y[ind] + dig[ind]*y[ind])/(phi[ind]^2) ld[ind,3] <- (2*bkt + 3*y[ind] - 2*dig*y[ind] - trig * y[ind]^2/phi[ind])/(phi[ind]^3) #return(ld) } ## .. otherwise need the full series thing.... ## first deal with the zeros ind <- y==0&p>1&p<2;ld[ind,] <- 0 ind <- ind & mu>0 ## need mu condition otherwise may try to find log(0) if (sum(ind)) { mu.ind <- mu[ind];p.ind <- p[ind];phii <- phi[ind] ld[ind,1] <- -mu.ind^(2-p.ind)/(phii*(2-p.ind)) ld[ind,2] <- -ld[ind,1]/phii ## dld/d phi ld[ind,3] <- -2*ld[ind,2]/phii ## d2ld/dphi2 ld[ind,4] <- -ld[ind,1] * (log(mu.ind) - 1/(2-p.ind)) ## dld/dp ld[ind,5] <- 2*ld[ind,4]/(2-p.ind) + ld[ind,1]*log(mu.ind)^2 ## d2ld/dp2 ld[ind,6] <- -ld[ind,4]/phii ## d2ld/dphidp if (work.param&&all.derivs) { mup <- mu.ind^p.ind ld[ind,7] <- -mu.ind/(mup*phii) ld[ind,8] <- -(1-p.ind)/(mup*phii) ld[ind,9] <- log(mu.ind)*mu.ind/(mup*phii) ld[ind,10] <- -ld[ind,7]/phii } } if (sum(!ind)==0) return(ld) ## now the non-zeros ind <- which(y>0&p>1&p<2) y <- y[ind];mu <- mu[ind];p<- p[ind] w <- w1 <- w2 <- y*0 if (length(ind)>0) { if (buffer) { ## use code that can buffer expensive lgamma,digamma and trigamma evaluations... oo <- .C(C_tweedious,w=as.double(w),w1=as.double(w1),w2=as.double(w2),w1p=as.double(y*0),w2p=as.double(y*0), w2pp=as.double(y*0),y=as.double(y),eps=as.double(.Machine$double.eps^2),n=as.integer(length(y)), th=as.double(theta[1]),rho=as.double(rho[1]),a=as.double(a),b=as.double(b)) } else { ## use code that is not able to buffer as p and phi variable... if (length(theta)!=n) theta <- array(theta,dim=n) if (length(rho)!=n) rho <- array(rho,dim=n) oo <- .C(C_tweedious2,w=as.double(w),w1=as.double(w1),w2=as.double(w2),w1p=as.double(y*0),w2p=as.double(y*0), w2pp=as.double(y*0),y=as.double(y),eps=as.double(.Machine$double.eps^2),n=as.integer(length(y)), th=as.double(theta[ind]),rho=as.double(rho[ind]),a=as.double(a),b=as.double(b)) } phii <- phi[ind] if (!work.param) { ## transform working param derivatives to p/phi derivs... if (length(dthp1)!=n) dthp1 <- array(dthp1,dim=n) if (length(dthp2)!=n) dthp2 <- array(dthp2,dim=n) dthp1i <- dthp1[ind] oo$w2 <- oo$w2/phii^2 - oo$w1/phii^2 oo$w1 <- oo$w1/phii oo$w2p <- oo$w2p*dthp1i^2 + dthp2[ind] * oo$w1p oo$w1p <- oo$w1p*dthp1i oo$w2pp <- oo$w2pp*dthp1i/phii ## this appears to be wrong } log.mu <- log(mu) onep <- 1-p twop <- 2-p mu1p <- theta <- mu^onep k.theta <- mu*theta/twop ## mu^(2-p)/(2-p) theta <- theta/onep ## mu^(1-p)/(1-p) a1 <- (y/onep-mu/twop) l.base <- mu1p*a1/phii ld[ind,1] <- l.base - log(y) ## log density ld[ind,2] <- -l.base/phii ## d log f / dphi ld[ind,3] <- 2*l.base/(phii^2) ## d2 logf / dphi2 x <- theta*y*(1/onep - log.mu)/phii + k.theta*(log.mu-1/twop)/phii ld[ind,4] <- x ld[ind,5] <- theta * y * (log.mu^2 - 2*log.mu/onep + 2/onep^2)/phii - k.theta * (log.mu^2 - 2*log.mu/twop + 2/twop^2)/phii ## d2 logf / dp2 ld[ind,6] <- - x/phii ## d2 logf / dphi dp } ## length(ind)>0 if (work.param) { ## transform derivs to derivs wrt working ld[,3] <- ld[,3]*phi^2 + ld[,2]*phi ld[,2] <- ld[,2]*phi ld[,5] <- ld[,5]*dpth1^2 + ld[,4]*dpth2 ld[,4] <- ld[,4]*dpth1 ld[,6] <- ld[,6]*dpth1*phi colnames(ld)[1:6] <- c("l","rho","rho.2","th","th.2","th.rho") } if (work.param&&all.derivs&&length(ind)>0) { #ld <- cbind(ld,ld[,1:4]*0) a2 <- mu1p/(mu*phii) ## 1/(mu^p*phii) ld[ind,7] <- a2*(onep*a1-mu/twop) ## deriv w.r.t mu ld[ind,8] <- -a2*(onep*p*a1/mu+2*onep/twop) ## 2nd deriv w.r.t. mu ld[ind,9] <- a2*(-log.mu*onep*a1-a1 + onep*(y/onep^2-mu/twop^2)+mu*log.mu/twop-mu/twop^2) ## mu p ld[ind,10] <- a2*(mu/(phii*twop) - onep*a1/phii) ## mu phi ## transform to working... ld[,10] <- ld[,10]*phi ld[,9] <- ld[,9]*dpth1 colnames(ld) <- c("l","rho","rho.2","th","th.2","th.rho","mu","mu.2","mu.theta","mu.rho") } if (length(ind)>0) { ld[ind,1] <- ld[ind,1] + oo$w ## log density ld[ind,2] <- ld[ind,2] + oo$w1 ## d log f / dphi ld[ind,3] <- ld[ind,3] + oo$w2 ## d2 logf / dphi2 ld[ind,4] <- ld[ind,4] + oo$w1p ld[ind,5] <- ld[ind,5] + oo$w2p ## d2 logf / dp2 ld[ind,6] <- ld[ind,6] + oo$w2pp ## d2 logf / dphi dp } if (FALSE) { ## DEBUG disconnetion of density terms ld[ind,1] <- oo$w ## log density ld[ind,2] <- oo$w1 ## d log f / dphi ld[ind,3] <- oo$w2 ## d2 logf / dphi2 ld[ind,4] <- oo$w1p ld[ind,5] <- oo$w2p ## d2 logf / dp2 ld[ind,6] <- oo$w2pp ## d2 logf / dphi dp } ld } ## ldTweedie Tweedie <- function(p=1,link=power(0)) { ## a restricted Tweedie family if (p<=1||p>2) stop("Only 1= 0) dev.resids <- function(y, mu, wt) { y1 <- y + (y == 0) if (p == 1) theta <- log(y1/mu) else theta <- (y1^(1 - p) - mu^(1 - p))/(1 - p) if (p == 2) kappa <- log(y1/mu) else kappa <- (y^(2 - p) - mu^(2 - p))/(2 - p) pmax(2 * wt * (y * theta - kappa),0) } initialize <- expression({ n <- rep(1, nobs) mustart <- y + 0.1 * (y == 0) }) ls <- function(y,w,n,scale) { power <- p colSums(w*ldTweedie(y,y,p=power,phi=scale)) } aic <- function(y, n, mu, wt, dev) { power <- p scale <- dev/sum(wt) -2*sum(ldTweedie(y,mu,p=power,phi=scale)[,1]*wt) + 2 } if (p==2) { rd <- function(mu,wt,scale) { rgamma(mu,shape=1/scale,scale=mu*scale) } } else { rd <- function(mu,wt,scale) { rTweedie(mu,p=p,phi=scale) } } structure(list(family = paste("Tweedie(",p,")",sep=""), variance = variance, dev.resids = dev.resids,aic = aic, link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, mu.eta = stats$mu.eta, initialize = initialize, validmu = validmu, valideta = stats$valideta,dvar=dvar,d2var=d2var,d3var=d3var,ls=ls,rd=rd,canonical="none"), class = "family") } ## Tweedie rTweedie <- function(mu,p=1.5,phi=1) { ## generate Tweedie random variables, with 1=2) stop("p must be in (1,2)") if (sum(mu<0)) stop("mean, mu, must be non negative") if (phi<=0) stop("scale parameter must be positive") lambda <- mu^(2-p)/((2-p)*phi) shape <- (2-p)/(p-1) scale <- phi*(p-1)*mu^(p-1) n.sim <- length(mu) ## how many Gamma r.v.s to sum up to get Tweedie ## 0 => none, and a zero value N <- rpois(length(lambda),lambda) ## following is a vector of N[i] copies of each gamma.scale[i] ## concatonated one after the other gs <- rep(scale,N) ## simulate gamma deviates to sum to get tweedie deviates y <- rgamma(gs*0+1,shape=shape,scale=gs) ## create summation index... lab <- rep(1:length(N),N) ## sum up each gamma sharing a label. 0 deviate if label does not occur o <- .C(C_psum,y=as.double(rep(0,n.sim)),as.double(y),as.integer(lab),as.integer(length(lab))) o$y } ## rTweedie mgcv/R/gam.fit4.r0000644000177400001440000015670213044344152013410 0ustar murdochusers## (c) Simon N. Wood (2013-2015). Provided under GPL 2. ## Routines for gam estimation beyond exponential family. dDeta <- function(y,mu,wt,theta,fam,deriv=0) { ## What is available directly from the family are derivatives of the ## deviance and link w.r.t. mu. This routine converts these to the ## required derivatives of the deviance w.r.t. eta. ## deriv is the order of derivative of the smoothing parameter score ## required. ## This version is based on ratios of derivatives of links rather ## than raw derivatives of links. g2g = g''/g'^2, g3g = g'''/g'^3 etc r <- fam$Dd(y, mu, theta, wt, level=deriv) d <- list(Deta=0,Dth=0,Dth2=0,Deta2=0,EDeta2=0,Detath=0, Deta3=0,Deta2th=0,Detath2=0, Deta4=0,Deta3th=0,Deta2th2=0) if (fam$link=="identity") { ## don't waste time on transformation d$Deta <- r$Dmu;d$Deta2 <- r$Dmu2 d$EDeta2 <- r$EDmu2;d$Deta.Deta2 <- r$Dmu/r$Dmu2 d$Deta.EDeta2 <- r$Dmu/r$EDmu2 if (deriv>0) { d$Dth <- r$Dth; d$Detath <- r$Dmuth d$Deta3 <- r$Dmu3; d$Deta2th <- r$Dmu2th } if (deriv>1) { d$Deta4 <- r$Dmu4; d$Dth2 <- r$Dth2; d$Detath2 <- r$Dmuth2 d$Deta2th2 <- r$Dmu2th2; d$Deta3th <- r$Dmu3th } return(d) } ig1 <- fam$mu.eta(fam$linkfun(mu)) ig12 <- ig1^2 g2g <- fam$g2g(mu) ## ig12 <- ig1^2;ig13 <- ig12 * ig1 d$Deta <- r$Dmu * ig1 d$Deta2 <- r$Dmu2*ig12 - r$Dmu*g2g*ig1 d$EDeta2 <- r$EDmu2*ig12 d$Deta.Deta2 <- r$Dmu/(r$Dmu2*ig1 - r$Dmu*g2g) d$Deta.EDeta2 <- r$Dmu/(r$EDmu2*ig1) if (deriv>0) { ig13 <- ig12 * ig1 d$Dth <- r$Dth d$Detath <- r$Dmuth * ig1 g3g <- fam$g3g(mu) d$Deta3 <- r$Dmu3*ig13 - 3*r$Dmu2 * g2g * ig12 + r$Dmu * (3*g2g^2 - g3g)*ig1 d$Deta2th <- r$Dmu2th*ig12 - r$Dmuth*g2g*ig1 } if (deriv>1) { g4g <- fam$g4g(mu) d$Deta4 <- ig12^2*r$Dmu4 - 6*r$Dmu3*ig13*g2g + r$Dmu2*(15*g2g^2-4*g3g)*ig12 - r$Dmu*(15*g2g^3-10*g2g*g3g +g4g)*ig1 d$Dth2 <- r$Dth2 d$Detath2 <- r$Dmuth2 * ig1 d$Deta2th2 <- ig12*r$Dmu2th2 - r$Dmuth2*g2g*ig1 d$Deta3th <- ig13*r$Dmu3th - 3 *r$Dmu2th*g2g*ig12 + r$Dmuth*(3*g2g^2-g3g)*ig1 } d } ## dDmu fetad.test <- function(y,mu,wt,theta,fam,eps = 1e-7,plot=TRUE) { ## test family derivatives w.r.t. eta dd <- dDeta(y,mu,wt,theta,fam,deriv=2) dev <- fam$dev.resids(y, mu, wt,theta) mu1 <- fam$linkinv(fam$linkfun(mu)+eps) dev1 <- fam$dev.resids(y,mu1, wt,theta) Deta.fd <- (dev1-dev)/eps cat("Deta: rdiff = ",range(dd$Deta-Deta.fd)," cor = ",cor(dd$Deta,Deta.fd),"\n") plot(dd$Deta,Deta.fd);abline(0,1) nt <- length(theta) for (i in 1:nt) { th1 <- theta;th1[i] <- th1[i] + eps dev1 <- fam$dev.resids(y, mu, wt,th1) Dth.fd <- (dev1-dev)/eps um <- if (nt>1) dd$Dth[,i] else dd$Dth cat("Dth[",i,"]: rdiff = ",range(um-Dth.fd)," cor = ",cor(um,Dth.fd),"\n") plot(um,Dth.fd);abline(0,1) } ## second order up... dd1 <- dDeta(y,mu1,wt,theta,fam,deriv=2) Deta2.fd <- (dd1$Deta - dd$Deta)/eps cat("Deta2: rdiff = ",range(dd$Deta2-Deta2.fd)," cor = ",cor(dd$Deta2,Deta2.fd),"\n") plot(dd$Deta2,Deta2.fd);abline(0,1) Deta3.fd <- (dd1$Deta2 - dd$Deta2)/eps cat("Deta3: rdiff = ",range(dd$Deta3-Deta3.fd)," cor = ",cor(dd$Deta3,Deta3.fd),"\n") plot(dd$Deta3,Deta3.fd);abline(0,1) Deta4.fd <- (dd1$Deta3 - dd$Deta3)/eps cat("Deta4: rdiff = ",range(dd$Deta4-Deta4.fd)," cor = ",cor(dd$Deta4,Deta4.fd),"\n") plot(dd$Deta4,Deta4.fd);abline(0,1) ## and now the higher derivs wrt theta... ind <- 1:nt for (i in 1:nt) { th1 <- theta;th1[i] <- th1[i] + eps dd1 <- dDeta(y,mu,wt,th1,fam,deriv=2) Detath.fd <- (dd1$Deta - dd$Deta)/eps um <- if (nt>1) dd$Detath[,i] else dd$Detath cat("Detath[",i,"]: rdiff = ",range(um-Detath.fd)," cor = ",cor(um,Detath.fd),"\n") plot(um,Detath.fd);abline(0,1) Deta2th.fd <- (dd1$Deta2 - dd$Deta2)/eps um <- if (nt>1) dd$Deta2th[,i] else dd$Deta2th cat("Deta2th[",i,"]: rdiff = ",range(um-Deta2th.fd)," cor = ",cor(um,Deta2th.fd),"\n") plot(um,Deta2th.fd);abline(0,1) Deta3th.fd <- (dd1$Deta3 - dd$Deta3)/eps um <- if (nt>1) dd$Deta3th[,i] else dd$Deta3th cat("Deta3th[",i,"]: rdiff = ",range(um-Deta3th.fd)," cor = ",cor(um,Deta3th.fd),"\n") plot(um,Deta3th.fd);abline(0,1) ## now the 3 second derivative w.r.t. theta terms Dth2.fd <- (dd1$Dth - dd$Dth)/eps um <- if (nt>1) dd$Dth2[,ind] else dd$Dth2 er <- if (nt>1) Dth2.fd[,i:nt] else Dth2.fd cat("Dth2[",i,",]: rdiff = ",range(um-er)," cor = ",cor(as.numeric(um),as.numeric(er)),"\n") plot(um,er);abline(0,1) Detath2.fd <- (dd1$Detath - dd$Detath)/eps um <- if (nt>1) dd$Detath2[,ind] else dd$Detath2 er <- if (nt>1) Detath2.fd[,i:nt] else Detath2.fd cat("Detath2[",i,",]: rdiff = ",range(um-er)," cor = ",cor(as.numeric(um),as.numeric(er)),"\n") ## cat("Detath2[",i,",]: rdiff = ",range(dd$Detath2-Detath2.fd)," cor = ",cor(dd$Detath2,Detath2.fd),"\n") plot(um,er);abline(0,1) Deta2th2.fd <- (dd1$Deta2th - dd$Deta2th)/eps um <- if (nt>1) dd$Deta2th2[,ind] else dd$Deta2th2 er <- if (nt>1) Deta2th2.fd[,i:nt] else Deta2th2.fd cat("Deta2th2[",i,",]: rdiff = ",range(um-er)," cor = ",cor(as.numeric(um),as.numeric(er)),"\n") ## cat("Deta2th2[",i,",]: rdiff = ",range(dd$Deta2th2-Deta2th2.fd)," cor = ",cor(dd$Deta2th2,Deta2th2.fd),"\n") ind <- max(ind)+1:(nt-i) plot(um,er);abline(0,1) } } ## fetad.test fmud.test <- function(y,mu,wt,theta,fam,eps = 1e-7) { ## test family deviance derivatives w.r.t. mu dd <- fam$Dd(y, mu, theta, wt, level=2) dev <- fam$dev.resids(y, mu, wt,theta) dev1 <- fam$dev.resids(y, mu+eps, wt,theta) Dmu.fd <- (dev1-dev)/eps cat("Dmu: rdiff = ",range(dd$Dmu-Dmu.fd)," cor = ",cor(dd$Dmu,Dmu.fd),"\n") nt <- length(theta) for (i in 1:nt) { th1 <- theta;th1[i] <- th1[i] + eps dev1 <- fam$dev.resids(y, mu, wt,th1) Dth.fd <- (dev1-dev)/eps um <- if (nt>1) dd$Dth[,i] else dd$Dth cat("Dth[",i,"]: rdiff = ",range(um-Dth.fd)," cor = ",cor(um,Dth.fd),"\n") } ## second order up... dd1 <- fam$Dd(y, mu+eps, theta, wt, level=2) Dmu2.fd <- (dd1$Dmu - dd$Dmu)/eps cat("Dmu2: rdiff = ",range(dd$Dmu2-Dmu2.fd)," cor = ",cor(dd$Dmu2,Dmu2.fd),"\n") Dmu3.fd <- (dd1$Dmu2 - dd$Dmu2)/eps cat("Dmu3: rdiff = ",range(dd$Dmu3-Dmu3.fd)," cor = ",cor(dd$Dmu3,Dmu3.fd),"\n") Dmu4.fd <- (dd1$Dmu3 - dd$Dmu3)/eps cat("Dmu4: rdiff = ",range(dd$Dmu4-Dmu4.fd)," cor = ",cor(dd$Dmu4,Dmu4.fd),"\n") ## and now the higher derivs wrt theta ind <- 1:nt for (i in 1:nt) { th1 <- theta;th1[i] <- th1[i] + eps dd1 <- fam$Dd(y, mu, th1, wt, level=2) Dmuth.fd <- (dd1$Dmu - dd$Dmu)/eps um <- if (nt>1) dd$Dmuth[,i] else dd$Dmuth cat("Dmuth[",i,"]: rdiff = ",range(um-Dmuth.fd)," cor = ",cor(um,Dmuth.fd),"\n") Dmu2th.fd <- (dd1$Dmu2 - dd$Dmu2)/eps um <- if (nt>1) dd$Dmu2th[,i] else dd$Dmu2th cat("Dmu2th[",i,"]: rdiff = ",range(um-Dmu2th.fd)," cor = ",cor(um,Dmu2th.fd),"\n") Dmu3th.fd <- (dd1$Dmu3 - dd$Dmu3)/eps um <- if (nt>1) dd$Dmu3th[,i] else dd$Dmu3th cat("Dmu3th[",i,"]: rdiff = ",range(um-Dmu3th.fd)," cor = ",cor(um,Dmu3th.fd),"\n") ## now the 3 second derivative w.r.t. theta terms... Dth2.fd <- (dd1$Dth - dd$Dth)/eps um <- if (nt>1) dd$Dth2[,ind] else dd$Dth2 er <- if (nt>1) Dth2.fd[,i:nt] else Dth2.fd cat("Dth2[",i,",]: rdiff = ",range(um-er)," cor = ",cor(as.numeric(um),as.numeric(er)),"\n") Dmuth2.fd <- (dd1$Dmuth - dd$Dmuth)/eps um <- if (nt>1) dd$Dmuth2[,ind] else dd$Dmuth2 er <- if (nt>1) Dmuth2.fd[,i:nt] else Dmuth2.fd cat("Dmuth2[",i,",]: rdiff = ",range(um-er)," cor = ",cor(as.numeric(um),as.numeric(er)),"\n") Dmu2th2.fd <- (dd1$Dmu2th - dd$Dmu2th)/eps um <- if (nt>1) dd$Dmu2th2[,ind] else dd$Dmu2th2 er <- if (nt>1) Dmu2th2.fd[,i:nt] else Dmu2th2.fd cat("Dmu2th2[",i,",]: rdiff = ",range(um-er)," cor = ",cor(as.numeric(um),as.numeric(er)),"\n") ind <- max(ind)+1:(nt-i) } } gam.fit4 <- function(x, y, sp, Eb,UrS=list(), weights = rep(1, nobs), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, nobs),U1=diag(ncol(x)), Mp=-1, family = gaussian(), control = gam.control(), deriv=2, scale=1,scoreType="REML",null.coef=rep(0,ncol(x)),...) { ## Routine for fitting GAMs beyond exponential family. ## Inputs as gam.fit3 except that family is of class "extended.family", while ## sp contains the vector of extended family parameters, followed by the log smoothing parameters, ## followed by the log scale parameter if scale < 0 ## some families have second derivative of deviance, and hence iterative weights ## very close to zero for some data. This can lead to poorly scaled sqrt(w)z ## and it is better to base everything on wz... if (is.null(family$use.wz)) family$use.wz <- FALSE if (family$n.theta>0) { ## there are extra parameters to estimate ind <- 1:family$n.theta theta <- sp[ind] ## parameters of the family family$putTheta(theta) sp <- sp[-ind] ## log smoothing parameters } else theta <- family$getTheta() ## fixed value ## penalized <- if (length(UrS)>0) TRUE else FALSE if (scale>0) scale.known <- TRUE else { ## unknown scale parameter, trial value supplied as ## final element of sp. scale.known <- FALSE nsp <- length(sp) scale <- exp(sp[nsp]) sp <- sp[-nsp] } x <- as.matrix(x) nSp <- length(sp) rank.tol <- .Machine$double.eps*100 ## tolerance to use for rank deficiency q <- ncol(x) n <- nobs <- nrow(x) xnames <- dimnames(x)[[2]] ynames <- if (is.matrix(y)) rownames(y) else names(y) ## Now a stable re-parameterization is needed.... if (length(UrS)) { rp <- gam.reparam(UrS,sp,deriv) T <- diag(q) T[1:ncol(rp$Qs),1:ncol(rp$Qs)] <- rp$Qs T <- U1%*%T ## new params b'=T'b old params null.coef <- t(T)%*%null.coef if (!is.null(start)) start <- t(T)%*%start ## form x%*%T in parallel x <- .Call(C_mgcv_pmmult2,x,T,0,0,control$nthreads) rS <- list() for (i in 1:length(UrS)) { rS[[i]] <- rbind(rp$rS[[i]],matrix(0,Mp,ncol(rp$rS[[i]]))) } ## square roots of penalty matrices in current parameterization Eb <- Eb%*%T ## balanced penalty matrix rows.E <- q-Mp Sr <- cbind(rp$E,matrix(0,nrow(rp$E),Mp)) St <- rbind(cbind(rp$S,matrix(0,nrow(rp$S),Mp)),matrix(0,Mp,q)) } else { T <- diag(q); St <- matrix(0,q,q) rSncol <- rows.E <- Eb <- Sr <- 0 rS <- list(0) rp <- list(det=0,det1 = 0,det2 = 0,fixed.penalty=FALSE) } ## re-parameterization complete. Initialization.... nvars <- ncol(x) if (nvars==0) stop("emtpy models not available") if (is.null(weights)) weights <- rep.int(1, nobs) if (is.null(offset)) offset <- rep.int(0, nobs) linkinv <- family$linkinv valideta <- family$valideta validmu <- family$validmu dev.resids <- family$dev.resids ## need an initial `null deviance' to test for initial divergence... ## if (!is.null(start)) null.coef <- start - can be on edge of feasible - not good null.eta <- as.numeric(x%*%null.coef + as.numeric(offset)) #old.pdev <- sum(dev.resids(y, linkinv(null.eta), weights,theta)) + t(null.coef)%*%St%*%null.coef #if (!is.null(start)) { ## check it's at least better than null.coef # pdev <- sum(dev.resids(y, linkinv(x%*%start+as.numeric(offset)), weights,theta)) + t(start)%*%St%*%start # if (pdev>old.pdev) start <- mustart <- etastart <- NULL #} ## call the families initialization code... if (is.null(mustart)) { eval(family$initialize) mukeep <- NULL } else { mukeep <- mustart eval(family$initialize) #mustart <- mukeep } old.pdev <- sum(dev.resids(y, linkinv(null.eta), weights,theta)) + t(null.coef)%*%St%*%null.coef if (!is.null(start)) { ## check it's at least better than null.coef pdev <- sum(dev.resids(y, linkinv(x%*%start+as.numeric(offset)), weights,theta)) + t(start)%*%St%*%start if (pdev>old.pdev) start <- mukeep <- etastart <- NULL } if (!is.null(mukeep)) mustart <- mukeep ## and now finalize initialization of mu and eta... eta <- if (!is.null(etastart)) etastart else if (!is.null(start)) if (length(start) != nvars) stop("Length of start should equal ", nvars, " and correspond to initial coefs for ", deparse(xnames)) else { coefold <- start etaold <- offset + as.vector(if (NCOL(x) == 1) x * start else x %*% start) } else family$linkfun(mustart) mu <- linkinv(eta);etaold <- eta coefold <- null.coef conv <- boundary <- FALSE for (iter in 1:control$maxit) { ## start of main fitting iteration if (control$trace) cat(iter," ") dd <- dDeta(y,mu,weights,theta,family,0) ## derivatives of deviance w.r.t. eta # good <- is.finite(dd$Deta.Deta2) w <- dd$Deta2 * .5; wz <- w*(eta-offset) - .5*dd$Deta z <- (eta-offset) - dd$Deta.Deta2 good <- is.finite(z)&is.finite(w) if (control$trace&sum(!good)>0) cat("\n",sum(!good)," not good\n") if (sum(!good)) { use.wy <- TRUE good <- is.finite(w)&is.finite(wz) z[!is.finite(z)] <- 0 ## avoid NaN in .C call - unused anyway } else use.wy <- family$use.wz oo <- .C(C_pls_fit1, y=as.double(z[good]),X=as.double(x[good,]),w=as.double(w[good]),wy = as.double(wz[good]), E=as.double(Sr),Es=as.double(Eb),n=as.integer(sum(good)), q=as.integer(ncol(x)),rE=as.integer(rows.E),eta=as.double(z), penalty=as.double(1),rank.tol=as.double(rank.tol), nt=as.integer(control$nthreads),use.wy=as.integer(use.wy)) if (oo$n<0) { ## then problem is indefinite - switch to +ve weights for this step if (control$trace) cat("**using positive weights\n") # problem is that Fisher can be very poor for zeroes ## index weights that are finite and positive good <- is.finite(dd$Deta2) good[good] <- dd$Deta2[good]>0 w[!good] <- 0 wz <- w*(eta-offset) - .5*dd$Deta z <- (eta-offset) - dd$Deta.Deta2 good <- is.finite(z)&is.finite(w) if (sum(!good)) { use.wy <- TRUE good <- is.finite(w)&is.finite(wz) z[!is.finite(z)] <- 0 ## avoid NaN in .C call - unused anyway } else use.wy <- family$use.wz oo <- .C(C_pls_fit1, ##C_pls_fit1, y=as.double(z[good]),X=as.double(x[good,]),w=as.double(w[good]),wy = as.double(wz[good]), E=as.double(Sr),Es=as.double(Eb),n=as.integer(sum(good)), q=as.integer(ncol(x)),rE=as.integer(rows.E),eta=as.double(z), penalty=as.double(1),rank.tol=as.double(rank.tol), nt=as.integer(control$nthreads),use.wy=as.integer(use.wy)) } start <- oo$y[1:ncol(x)] ## current coefficient estimates penalty <- oo$penalty ## size of penalty eta <- drop(x%*%start) ## the linear predictor (less offset) if (any(!is.finite(start))) { ## test for breakdown conv <- FALSE warning("Non-finite coefficients at iteration ", iter) return(list(REML=NA)) ## return immediately signalling failure } mu <- linkinv(eta <- eta + offset) dev <- sum(dev.resids(y, mu, weights,theta)) ## now step halve under non-finite deviance... if (!is.finite(dev)) { if (is.null(coefold)) { if (is.null(null.coef)) stop("no valid set of coefficients has been found:please supply starting values", call. = FALSE) ## Try to find feasible coefficients from the null.coef and null.eta coefold <- null.coef etaold <- null.eta } #warning("Step size truncated due to divergence", # call. = FALSE) ii <- 1 while (!is.finite(dev)) { if (ii > control$maxit) stop("inner loop 1; can't correct step size") ii <- ii + 1 start <- (start + coefold)/2 eta <- (eta + etaold)/2 mu <- linkinv(eta) dev <- sum(dev.resids(y, mu, weights,theta)) } boundary <- TRUE penalty <- t(start)%*%St%*%start ## reset penalty too if (control$trace) cat("Step halved: new deviance =", dev, "\n") } ## end of infinite deviance correction ## now step halve if mu or eta are out of bounds... if (!(valideta(eta) && validmu(mu))) { #warning("Step size truncated: out of bounds", # call. = FALSE) ii <- 1 while (!(valideta(eta) && validmu(mu))) { if (ii > control$maxit) stop("inner loop 2; can't correct step size") ii <- ii + 1 start <- (start + coefold)/2 eta <- (eta + etaold)/2 mu <- linkinv(eta) } boundary <- TRUE dev <- sum(dev.resids(y, mu, weights)) penalty <- t(start)%*%St%*%start ## need to reset penalty too if (control$trace) cat("Step halved: new deviance =", dev, "\n") } ## end of invalid mu/eta handling ## now check for divergence of penalized deviance.... pdev <- dev + penalty ## the penalized deviance if (control$trace) cat("penalized deviance =", pdev, "\n") div.thresh <- 10*(.1+abs(old.pdev))*.Machine$double.eps^.5 if (pdev-old.pdev>div.thresh) { ## solution diverging ii <- 1 ## step halving counter if (iter==1) { ## immediate divergence, need to shrink towards zero etaold <- null.eta; coefold <- null.coef } while (pdev -old.pdev > div.thresh) { ## step halve until pdev <= old.pdev if (ii > 100) stop("inner loop 3; can't correct step size") ii <- ii + 1 start <- (start + coefold)/2 eta <- (eta + etaold)/2 mu <- linkinv(eta) dev <- sum(dev.resids(y, mu, weights,theta)) pdev <- dev + t(start)%*%St%*%start ## the penalized deviance if (control$trace) cat("Step halved: new penalized deviance =", pdev, "\n") } } ## end of pdev divergence ## convergence testing... if (abs(pdev - old.pdev)/(0.1 + abs(pdev)) < control$epsilon) { ## Need to check coefs converged adequately, to ensure implicit differentiation ## ok. Testing coefs unchanged is problematic under rank deficiency (not guaranteed to ## drop same parameter every iteration!) grad <- 2 * t(x[good,])%*%((w[good]*(x%*%start)[good]-wz[good]))+ 2*St%*%start if (max(abs(grad)) > control$epsilon*max(abs(start+coefold))/2) { old.pdev <- pdev ## not converged quite enough coef <- coefold <- start etaold <- eta ##muold <- mu } else { ## converged conv <- TRUE coef <- start break } } else { ## not converged old.pdev <- pdev coef <- coefold <- start etaold <- eta } } ## end of main loop ## so at this stage the model has been fully estimated coef <- as.numeric(T %*% coef) ## now obtain derivatives, if these are needed... check.derivs <- FALSE while (check.derivs) { ## debugging code to check derivatives eps <- 1e-7 fmud.test(y,mu,weights,theta,family,eps = eps) fetad.test(y,mu,weights,theta,family,eps = eps) } dd <- dDeta(y,mu,weights,theta,family,deriv) w <- dd$Deta2 * .5 z <- (eta-offset) - dd$Deta.Deta2 ## - .5 * dd$Deta[good] / w wf <- pmax(0,dd$EDeta2 * .5) ## Fisher type weights wz <- w*(eta-offset) - 0.5*dd$Deta ## Wz finite when w==0 gdi.type <- if (any(abs(w)<.Machine$double.xmin*1e20)||any(!is.finite(z))) 1 else 0 good <- is.finite(wz)&is.finite(w) residuals <- z - (eta - offset) residuals[!is.finite(residuals)] <- NA z[!is.finite(z)] <- 0 ## avoid passing NA etc to C code ntot <- length(theta) + length(sp) rSncol <- unlist(lapply(UrS,ncol)) ## Now drop any elements of dd that have been dropped in fitting... if (sum(!good)>0) { ## drop !good from fields of dd, weights and pseudodata z <- z[good]; w <- w[good]; wz <- wz[good]; wf <- wf[good] dd$Deta <- dd$Deta[good];dd$Deta2 <- dd$Deta2[good] dd$EDeta2 <- dd$EDeta2[good] if (deriv>0) dd$Deta3 <- dd$Deta3[good] if (deriv>1) dd$Deta4 <- dd$Deta4[good] if (length(theta)>1) { if (deriv>0) { dd$Dth <- dd$Dth[good,]; dd$Detath <- dd$Detath[good,]; dd$Deta2th <- dd$Deta2th[good,] if (deriv>1) { dd$Detath2 <- dd$Detath2[good,]; dd$Deta3th <- dd$Deta3th[good,] dd$Deta2th2 <- dd$Deta2th2[good,];dd$Dth2 <- dd$Dth2[good,] } } } else { if (deriv>0) { dd$Dth <- dd$Dth[good]; dd$Detath <- dd$Detath[good]; dd$Deta2th <- dd$Deta2th[good] if (deriv>1) { dd$Detath2 <- dd$Detath2[good]; dd$Deta3th <- dd$Deta3th[good] dd$Deta2th2 <- dd$Deta2th2[good]; dd$Dth2 <- dd$Dth2[good] } } } } oo <- .C(C_gdi2, X=as.double(x[good,]),E=as.double(Sr),Es=as.double(Eb),rS=as.double(unlist(rS)), U1 = as.double(U1),sp=as.double(exp(sp)),theta=as.double(theta), z=as.double(z),w=as.double(w),wz=as.double(wz),wf=as.double(wf),Dth=as.double(dd$Dth), Det=as.double(dd$Deta), Det2=as.double(dd$Deta2),Dth2=as.double(dd$Dth2),Det.th=as.double(dd$Detath), Det2.th=as.double(dd$Deta2th),Det3=as.double(dd$Deta3),Det.th2 = as.double(dd$Detath2), Det4 = as.double(dd$Deta4),Det3.th=as.double(dd$Deta3th), Deta2.th2=as.double(dd$Deta2th2), beta=as.double(coef),b1=as.double(rep(0,ntot*ncol(x))),w1=as.double(rep(0,ntot*length(z))), D1=as.double(rep(0,ntot)),D2=as.double(rep(0,ntot^2)), P=as.double(0),P1=as.double(rep(0,ntot)),P2 = as.double(rep(0,ntot^2)), ldet=as.double(1-2*(scoreType=="ML")),ldet1 = as.double(rep(0,ntot)), ldet2 = as.double(rep(0,ntot^2)), rV=as.double(rep(0,ncol(x)^2)), rank.tol=as.double(.Machine$double.eps^.75),rank.est=as.integer(0), n=as.integer(sum(good)),q=as.integer(ncol(x)),M=as.integer(nSp), n.theta=as.integer(length(theta)), Mp=as.integer(Mp),Enrow=as.integer(rows.E), rSncol=as.integer(rSncol),deriv=as.integer(deriv), fixed.penalty = as.integer(rp$fixed.penalty),nt=as.integer(control$nthreads), type=as.integer(gdi.type),dVkk=as.double(rep(0,nSp^2))) ## test code used to ensure type 0 and type 1 produce identical results, when both should work. # oot <- .C(C_gdi2, # X=as.double(x[good,]),E=as.double(Sr),Es=as.double(Eb),rS=as.double(unlist(rS)), # U1 = as.double(U1),sp=as.double(exp(sp)),theta=as.double(theta), # z=as.double(z),w=as.double(w),wz=as.double(wz),wf=as.double(wf),Dth=as.double(dd$Dth), # Det=as.double(dd$Deta), # Det2=as.double(dd$Deta2),Dth2=as.double(dd$Dth2),Det.th=as.double(dd$Detath), # Det2.th=as.double(dd$Deta2th),Det3=as.double(dd$Deta3),Det.th2 = as.double(dd$Detath2), # Det4 = as.double(dd$Deta4),Det3.th=as.double(dd$Deta3th), Deta2.th2=as.double(dd$Deta2th2), # beta=as.double(coef),b1=as.double(rep(0,ntot*ncol(x))),w1=rep(0,ntot*length(z)), # D1=as.double(rep(0,ntot)),D2=as.double(rep(0,ntot^2)), # P=as.double(0),P1=as.double(rep(0,ntot)),P2 = as.double(rep(0,ntot^2)), # ldet=as.double(1-2*(scoreType=="ML")),ldet1 = as.double(rep(0,ntot)), # ldet2 = as.double(rep(0,ntot^2)), # rV=as.double(rep(0,ncol(x)^2)), # rank.tol=as.double(.Machine$double.eps^.75),rank.est=as.integer(0), # n=as.integer(sum(good)),q=as.integer(ncol(x)),M=as.integer(nSp), # n.theta=as.integer(length(theta)), Mp=as.integer(Mp),Enrow=as.integer(rows.E), # rSncol=as.integer(rSncol),deriv=as.integer(deriv), # fixed.penalty = as.integer(rp$fixed.penalty),nt=as.integer(control$nthreads), # type=as.integer(1)) rV <- matrix(oo$rV,ncol(x),ncol(x)) ## rV%*%t(rV)*scale gives covariance matrix rV <- T %*% rV ## derivatives of coefs w.r.t. sps etc... db.drho <- if (deriv) T %*% matrix(oo$b1,ncol(x),ntot) else NULL dw.drho <- if (deriv) matrix(oo$w1,length(z),ntot) else NULL Kmat <- matrix(0,nrow(x),ncol(x)) Kmat[good,] <- oo$X ## rV%*%t(K)%*%(sqrt(wf)*X) = F; diag(F) is edf array D2 <- matrix(oo$D2,ntot,ntot); ldet2 <- matrix(oo$ldet2,ntot,ntot) bSb2 <- matrix(oo$P2,ntot,ntot) ## compute the REML score... ls <- family$ls(y,weights,n,theta,scale) nt <- length(theta) lsth1 <- ls$lsth1[1:nt]; lsth2 <- as.matrix(ls$lsth2)[1:nt,1:nt] ## exclude any derivs w.r.t log scale here REML <- (dev+oo$P)/(2*scale) - ls$ls + (oo$ldet - rp$det)/2 - as.numeric(scoreType=="REML") * Mp * log(2*pi*scale)/2 REML1 <- REML2 <- NULL if (deriv) { det1 <- oo$ldet1 if (nSp) { ind <- 1:nSp + length(theta) det1[ind] <- det1[ind] - rp$det1 } REML1 <- (oo$D1+oo$P1)/(2*scale) - c(lsth1,rep(0,length(sp))) + (det1)/2 if (deriv>1) { ls2 <- D2*0;ls2[1:nt,1:nt] <- lsth2 if (nSp) ldet2[ind,ind] <- ldet2[ind,ind] - rp$det2 REML2 <- (D2+bSb2)/(2*scale) - ls2 + ldet2/2 } } if (!scale.known&&deriv) { ## need derivatives wrt log scale, too Dp <- dev + oo$P dlr.dlphi <- -Dp/(2 *scale) - ls$lsth1[nt+1] - Mp/2 d2lr.d2lphi <- Dp/(2*scale) - ls$lsth2[nt+1,nt+1] d2lr.dspphi <- -(oo$D1+oo$P1)/(2*scale) d2lr.dspphi[1:nt] <- d2lr.dspphi[1:nt] - ls$lsth2[nt+1,1:nt] REML1 <- c(REML1,dlr.dlphi) if (deriv==2) { REML2 <- rbind(REML2,as.numeric(d2lr.dspphi)) REML2 <- cbind(REML2,c(as.numeric(d2lr.dspphi),d2lr.d2lphi)) } } nth <- length(theta) if (deriv>0&&family$n.theta==0&&nth>0) { ## need to drop derivs for fixed theta REML1 <- REML1[-(1:nth)] if (deriv>1) REML2 <- REML2[-(1:nth),-(1:nth)] db.drho <- db.drho[,-(1:nth),drop=FALSE] } names(coef) <- xnames names(residuals) <- ynames wtdmu <- sum(weights * mu)/sum(weights) ## changed from y nulldev <- sum(dev.resids(y, rep(wtdmu,length(y)), weights)) n.ok <- nobs - sum(weights == 0) nulldf <- n.ok ww <- wt <- rep.int(0, nobs) wt[good] <- wf ww[good] <- w if (deriv && nrow(dw.drho)!=nrow(x)) { w1 <- dw.drho dw.drho <- matrix(0,nrow(x),ncol(w1)) dw.drho[good,] <- w1 } aic.model <- family$aic(y, mu, theta, weights, dev) # note: incomplete 2*edf needs to be added list(coefficients = coef,residuals=residuals,fitted.values = mu, family=family, linear.predictors = eta,deviance=dev, null.deviance=nulldev,iter=iter, weights=wt, ## note that these are Fisher type weights prior.weights=weights, working.weights = ww, ## working weights df.null = nulldf, y = y, converged = conv, boundary = boundary, REML=REML,REML1=REML1,REML2=REML2, rV=rV,db.drho=db.drho,dw.drho=dw.drho, scale.est=scale,reml.scale=scale, aic=aic.model, rank=oo$rank.est, K=Kmat,control=control, dVkk = matrix(oo$dVkk,nSp,nSp) #,D1=oo$D1,D2=D2, #ldet=oo$ldet,ldet1=oo$ldet1,ldet2=ldet2, #bSb=oo$P,bSb1=oo$P1,bSb2=bSb2, #ls=ls$ls,ls1=ls$lsth1,ls2=ls$lsth2 ) } ## gam.fit4 gam.fit5 <- function(x,y,lsp,Sl,weights=NULL,offset=NULL,deriv=2,family, control=gam.control(),Mp=-1,start=NULL){ ## NOTE: offset handling - needs to be passed to ll code ## fit models by general penalized likelihood method, ## given doubly extended family in family. lsp is log smoothing parameters ## Stabilization strategy: ## 1. Sl.repara ## 2. Hessian diagonally pre-conditioned if +ve diagonal elements ## (otherwise indefinite anyway) ## 3. Newton fit with perturbation of any indefinite hessian ## 4. At convergence test fundamental rank on balanced version of ## penalized Hessian. Drop unidentifiable parameters and ## continue iteration to adjust others. ## 5. All remaining computations in reduced space. ## ## Idea is that rank detection takes care of structural co-linearity, ## while preconditioning and step 1 take care of extreme smoothing parameters ## related problems. penalized <- if (length(Sl)>0) TRUE else FALSE nSp <- length(lsp) q <- ncol(x) nobs <- length(y) if (penalized) { Eb <- attr(Sl,"E") ## balanced penalty sqrt ## the stability reparameterization + log|S|_+ and derivs... rp <- ldetS(Sl,rho=lsp,fixed=rep(FALSE,length(lsp)),np=q,root=TRUE) x <- Sl.repara(rp$rp,x) ## apply re-parameterization to x Eb <- Sl.repara(rp$rp,Eb) ## root balanced penalty St <- crossprod(rp$E) ## total penalty matrix E <- rp$E ## root total penalty attr(E,"use.unscaled") <- TRUE ## signal initialization code that E not to be further scaled if (!is.null(start)) start <- Sl.repara(rp$rp,start) ## re-para start ## NOTE: it can be that other attributes need re-parameterization here ## this should be done in 'family$initialize' - see mvn for an example. } else { ## unpenalized so no derivatives required deriv <- 0 rp <- list(ldetS=0,rp=list()) St <- matrix(0,q,q) E <- matrix(0,0,q) ## can be needed by initialization code } ## now call initialization code, but make sure that any ## supplied 'start' vector is not overwritten... start0 <- start ## Assumption here is that the initialization code is fine with ## re-parameterized x... eval(family$initialize) if (!is.null(start0)) start <- start0 coef <- as.numeric(start) if (is.null(weights)) weights <- rep.int(1, nobs) if (is.null(offset)) offset <- rep.int(0, nobs) ## get log likelihood, grad and Hessian (w.r.t. coefs - not s.p.s) ... llf <- family$ll ll <- llf(y,x,coef,weights,family,offset=offset,deriv=1) ll0 <- ll$l - (t(coef)%*%St%*%coef)/2 rank.checked <- FALSE ## not yet checked the intrinsic rank of problem rank <- q;drop <- NULL eigen.fix <- FALSE converged <- FALSE check.deriv <- FALSE; eps <- 1e-5 drop <- NULL;bdrop <- rep(FALSE,q) ## by default nothing dropped perturbed <- 0 ## counter for number of times perturbation tried on possible saddle for (iter in 1:(2*control$maxit)) { ## main iteration ## get Newton step... if (check.deriv) { fdg <- ll$lb*0; fdh <- ll$lbb*0 for (k in 1:length(coef)) { coef1 <- coef;coef1[k] <- coef[k] + eps ll.fd <- llf(y,x,coef1,weights,family,offset=offset,deriv=1) fdg[k] <- (ll.fd$l-ll$l)/eps fdh[,k] <- (ll.fd$lb-ll$lb)/eps } } grad <- ll$lb - St%*%coef Hp <- -ll$lbb+St D <- diag(Hp) indefinite <- FALSE if (sum(D <= 0)) { ## Hessian indefinite, for sure D <- rep(1,ncol(Hp)) if (eigen.fix) { eh <- eigen(Hp,symmetric=TRUE); ev <- abs(eh$values) Hp <- eh$vectors%*%(ev*t(eh$vectors)) } else { Ib <- diag(rank)*abs(min(D)) Ip <- diag(rank)*abs(max(D)*.Machine$double.eps^.5) Hp <- Hp + Ip + Ib } indefinite <- TRUE } else { ## Hessian could be +ve def in which case Choleski is cheap! D <- D^-.5 ## diagonal pre-conditioner Hp <- D*t(D*Hp) ## pre-condition Hp Ip <- diag(rank)*.Machine$double.eps^.5 } L <- suppressWarnings(chol(Hp,pivot=TRUE)) mult <- 1 while (attr(L,"rank") < rank) { ## rank deficient - add ridge penalty if (eigen.fix) { eh <- eigen(Hp,symmetric=TRUE);ev <- eh$values thresh <- max(min(ev[ev>0]),max(ev)*1e-6)*mult mult <- mult*10 ev[ev0) { ## limit step length to .1 of coef length s.norm <- sqrt(sum(step^2)) c.norm <- sqrt(c.norm) if (s.norm > .1*c.norm) step <- step*0.1*c.norm/s.norm } ## try the Newton step... coef1 <- coef + step ll <- llf(y,x,coef1,weights,family,offset=offset,deriv=1) ll1 <- ll$l - (t(coef1)%*%St%*%coef1)/2 khalf <- 0;fac <- 2 while ((!is.finite(ll1)||ll1 < ll0) && khalf < 25) { ## step halve until it succeeds... step <- step/fac;coef1 <- coef + step ll <- llf(y,x,coef1,weights,family,offset=offset,deriv=0) ll1 <- ll$l - (t(coef1)%*%St%*%coef1)/2 if (ll1>=ll0) { ll <- llf(y,x,coef1,weights,family,offset=offset,deriv=1) } else { ## abort if step has made no difference if (max(abs(coef1-coef))==0) khalf <- 100 } khalf <- khalf + 1 if (khalf>5) fac <- 5 } ## end step halve if (!is.finite(ll1) || ll1 < ll0) { ## switch to steepest descent... step <- -.5*drop(grad)*mean(abs(coef))/mean(abs(grad)) khalf <- 0 } while ((!is.finite(ll1)||ll1 < ll0) && khalf < 25) { ## step cut until it succeeds... step <- step/10;coef1 <- coef + step ll <- llf(y,x,coef1,weights,family,offset=offset,deriv=0) ll1 <- ll$l - (t(coef1)%*%St%*%coef1)/2 if (ll1>=ll0) { ll <- llf(y,x,coef1,weights,family,offset=offset,deriv=1) } else { ## abort if step has made no difference if (max(abs(coef1-coef))==0) khalf <- 100 } khalf <- khalf + 1 } if ((is.finite(ll1)&&ll1 >= ll0)||iter==control$maxit) { ## step ok. Accept and test coef <- coef + step ## convergence test... ok <- (iter==control$maxit||(abs(ll1-ll0) < control$epsilon*abs(ll0) && max(abs(grad)) < .Machine$double.eps^.5*abs(ll0))) if (ok) { ## appears to have converged if (indefinite) { ## not a well defined maximum if (perturbed==5) stop("indefinite penalized likelihood in gam.fit5 ") if (iter<4||rank.checked) { perturbed <- perturbed + 1 coef <- coef*(1+(runif(length(coef))*.02-.01)*perturbed) + (runif(length(coef)) - 0.5 ) * mean(abs(coef))*1e-5*perturbed ll <- llf(y,x,coef,weights,family,offset=offset,deriv=1) ll0 <- ll$l - (t(coef)%*%St%*%coef)/2 } else { rank.checked <- TRUE if (penalized) { Sb <- crossprod(Eb) ## balanced penalty Hb <- -ll$lbb/norm(ll$lbb,"F")+Sb/norm(Sb,"F") ## balanced penalized hessian } else Hb <- -ll$lbb/norm(ll$lbb,"F") ## apply pre-conditioning, otherwise badly scaled problems can result in ## wrong coefs being dropped... D <- abs(diag(Hb)) D[D<1e-50] <- 1;D <- D^-.5 Hb <- t(D*Hb)*D qrh <- qr(Hb,LAPACK=TRUE) rank <- Rrank(qr.R(qrh)) if (rank < q) { ## rank deficient. need to drop and continue to adjust other params drop <- sort(qrh$pivot[(rank+1):q]) ## set these params to zero bdrop <- 1:q %in% drop ## TRUE FALSE version ## now drop the parameters and recompute ll0... lpi <- attr(x,"lpi") xat <- attributes(x) xat$dim <- xat$dimnames <- NULL coef <- coef[-drop] St <- St[-drop,-drop] x <- x[,-drop] ## dropping columns from model matrix if (!is.null(lpi)) { ## need to adjust column indexes as well ii <- (1:q)[!bdrop];ij <- rep(NA,q) ij[ii] <- 1:length(ii) ## col i of old model matrix is col ij[i] of new for (i in 1:length(lpi)) { lpi[[i]] <- ij[lpi[[i]][!(lpi[[i]]%in%drop)]] # drop and shuffle up } } ## lpi adjustment done for (i in 1:length(xat)) attr(x,names(xat)[i]) <- xat[[i]] attr(x,"lpi") <- lpi attr(x,"drop") <- drop ## useful if family has precomputed something from x ll <- llf(y,x,coef,weights,family,offset=offset,deriv=1) ll0 <- ll$l - (t(coef)%*%St%*%coef)/2 } } } else { ## not indefinite really converged converged <- TRUE break } } else ll0 <- ll1 ## step ok but not converged yet } else { ## step failed. converged <- FALSE if (is.null(drop)) bdrop <- rep(FALSE,q) warning(paste("step failed: max abs grad =",max(abs(grad)))) break } } ## end of main fitting iteration ## at this stage the Hessian (of pen lik. w.r.t. coefs) should be +ve definite, ## so that the pivoted Choleski factor should exist... if (iter == 2*control$maxit&&converged==FALSE) warning(gettextf("iteration limit reached: max abs grad = %g",max(abs(grad)))) ldetHp <- 2*sum(log(diag(L))) - 2 * sum(log(D)) ## log |Hp| if (!is.null(drop)) { ## create full version of coef with zeros for unidentifiable fcoef <- rep(0,length(bdrop));fcoef[!bdrop] <- coef } else fcoef <- coef dVkk <- d1l <- d2l <- d1bSb <- d2bSb <- d1b <- d2b <- d1ldetH <- d2ldetH <- d1b <- d2b <- NULL if (deriv>0) { ## Implicit differentiation for derivs... m <- nSp d1b <- matrix(0,rank,m) Sib <- Sl.termMult(rp$Sl,fcoef,full=TRUE) ## list of penalties times coefs if (nSp) for (i in 1:m) d1b[,i] <- -D*(backsolve(L,forwardsolve(t(L),(D*Sib[[i]][!bdrop])[piv]))[ipiv]) ## obtain the curvature check matrix... dVkk <- crossprod(L[,ipiv]%*%(d1b/D)) if (!is.null(drop)) { ## create full version of d1b with zeros for unidentifiable fd1b <- matrix(0,q,m) fd1b[!bdrop,] <- d1b } else fd1b <- d1b ## Now call the family again to get first derivative of Hessian w.r.t ## smoothing parameters, in list d1H... ll <- llf(y,x,coef,weights,family,offset=offset,deriv=3,d1b=d1b) # d1l <- colSums(ll$lb*d1b) # cancels if (deriv>1) { ## Implicit differentiation for the second derivatives is now possible... d2b <- matrix(0,rank,m*(m+1)/2) k <- 0 for (i in 1:m) for (j in i:m) { k <- k + 1 v <- -ll$d1H[[i]]%*%d1b[,j] + Sl.mult(rp$Sl,fd1b[,j],i)[!bdrop] + Sl.mult(rp$Sl,fd1b[,i],j)[!bdrop] d2b[,k] <- -D*(backsolve(L,forwardsolve(t(L),(D*v)[piv]))[ipiv]) if (i==j) d2b[,k] <- d2b[,k] + d1b[,i] } ## Now call family for last time to get trHid2H the tr(H^{-1} d^2 H / drho_i drho_j)... llr <- llf(y,x,coef,weights,family,offset=offset,deriv=4,d1b=d1b,d2b=d2b, Hp=Hp,rank=rank,fh = L,D=D) ## Now compute Hessian of log lik w.r.t. log sps using chain rule # d2la <- colSums(ll$lb*d2b) # cancels # k <- 0 d2l <- matrix(0,m,m) for (i in 1:m) for (j in i:m) { # k <- k + 1 d2l[j,i] <- d2l[i,j] <- # d2la[k] + # cancels t(d1b[,i])%*%ll$lbb%*%d1b[,j] } } ## if (deriv > 1) } ## if (deriv > 0) ## Compute the derivatives of log|H+S|... if (deriv > 0) { d1ldetH <- rep(0,m) d1Hp <- list() for (i in 1:m) { A <- -ll$d1H[[i]] + Sl.mult(rp$Sl,diag(q),i)[!bdrop,!bdrop] d1Hp[[i]] <- D*(backsolve(L,forwardsolve(t(L),(D*A)[piv,]))[ipiv,]) d1ldetH[i] <- sum(diag(d1Hp[[i]])) } } ## if (deriv > 0) if (deriv > 1) { d2ldetH <- matrix(0,m,m) k <- 0 for (i in 1:m) for (j in i:m) { k <- k + 1 d2ldetH[i,j] <- -sum(d1Hp[[i]]*t(d1Hp[[j]])) - llr$trHid2H[k] if (i==j) { ## need to add term relating to smoothing penalty #A <- t(Sl.mult(rp$Sl,diag(q),i,full=FALSE)) #bind <- rowSums(abs(A))!=0 ## FIX: abs 3/3/16 #ind <- which(bind) #bind <- bind[!bdrop] #A <- A[!bdrop,!bdrop[ind]] A <- Sl.mult(rp$Sl,diag(q),i,full=TRUE)[!bdrop,!bdrop] bind <- rowSums(abs(A))!=0 ## row/cols of non-zero block A <- A[,bind] ## drop the zero columns A <- D*(backsolve(L,forwardsolve(t(L),(D*A)[piv,]))[ipiv,]) d2ldetH[i,j] <- d2ldetH[i,j] + sum(diag(A[bind,])) } else d2ldetH[j,i] <- d2ldetH[i,j] } } ## if (deriv > 1) ## Compute derivs of b'Sb... if (deriv>0) { # Sb <- St%*%coef Skb <- Sl.termMult(rp$Sl,fcoef,full=TRUE) d1bSb <- rep(0,m) for (i in 1:m) { Skb[[i]] <- Skb[[i]][!bdrop] d1bSb[i] <- # 2*sum(d1b[,i]*Sb) + # cancels sum(coef*Skb[[i]]) } } if (deriv>1) { d2bSb <- matrix(0,m,m) # k <- 0 for (i in 1:m) { Sd1b <- St%*%d1b[,i] for (j in i:m) { k <- k + 1 d2bSb[j,i] <- d2bSb[i,j] <- 2*sum( # d2b[,k]*Sb + # cancels d1b[,i]*Skb[[j]] + d1b[,j]*Skb[[i]] + d1b[,j]*Sd1b) } d2bSb[i,i] <- d2bSb[i,i] + sum(coef*Skb[[i]]) } } ## get grad and Hessian of REML score... REML <- -as.numeric(ll$l - t(coef)%*%St%*%coef/2 + rp$ldetS/2 - ldetHp/2 + Mp*log(2*pi)/2) REML1 <- if (deriv<1) NULL else -as.numeric( # d1l # cancels - d1bSb/2 + rp$ldet1/2 - d1ldetH/2 ) if (control$trace) { cat("\niter =",iter," ll =",ll$l," REML =",REML," bSb =",t(coef)%*%St%*%coef/2,"\n") cat("log|S| =",rp$ldetS," log|H+S| =",ldetHp," n.drop =",length(drop),"\n") if (!is.null(REML1)) cat("REML1 =",REML1,"\n") } REML2 <- if (deriv<2) NULL else -( d2l - d2bSb/2 + rp$ldet2/2 - d2ldetH/2 ) ## bSb <- t(coef)%*%St%*%coef lpi <- attr(x,"lpi") if (is.null(lpi)) { linear.predictors <- if (is.null(offset)) as.numeric(x%*%coef) else as.numeric(x%*%coef+offset) fitted.values <- family$linkinv(linear.predictors) } else { fitted.values <- linear.predictors <- matrix(0,nrow(x),length(lpi)) if (!is.null(offset)) offset[[length(lpi)+1]] <- 0 for (j in 1:length(lpi)) { linear.predictors[,j] <- as.numeric(x[,lpi[[j]],drop=FALSE] %*% coef[lpi[[j]]]) if (!is.null(offset[[j]])) linear.predictors[,j] <- linear.predictors[,j] + offset[[j]] fitted.values[,j] <- family$linfo[[j]]$linkinv( linear.predictors[,j]) } } coef <- Sl.repara(rp$rp,fcoef,inverse=TRUE) ## undo re-parameterization of coef if (!is.null(drop)&&!is.null(d1b)) { ## create full version of d1b with zeros for unidentifiable db.drho <- matrix(0,length(bdrop),ncol(d1b));db.drho[!bdrop,] <- d1b } else db.drho <- d1b ## and undo re-para... if (!is.null(d1b)) db.drho <- t(Sl.repara(rp$rp,t(db.drho),inverse=TRUE,both.sides=FALSE)) ret <- list(coefficients=coef,family=family,y=y,prior.weights=weights, fitted.values=fitted.values, linear.predictors=linear.predictors, scale.est=1, ### NOTE: needed by newton, but what is sensible here? REML= REML,REML1= REML1,REML2=REML2, rank=rank,aic = -2*ll$l, ## 2*edf needs to be added ##deviance = -2*ll$l, l= ll$l,## l1 =d1l,l2 =d2l, lbb = ll$lbb, ## Hessian of log likelihood L=L, ## chol factor of pre-conditioned penalized hessian bdrop=bdrop, ## logical index of dropped parameters D=D, ## diagonal preconditioning matrix St=St, ## total penalty matrix rp = rp$rp, db.drho = db.drho, ## derivative of penalty coefs w.r.t. log sps. #bSb = bSb, bSb1 = d1bSb,bSb2 = d2bSb, S1=rp$ldet1, #S=rp$ldetS,S1=rp$ldet1,S2=rp$ldet2, #Hp=ldetHp,Hp1=d1ldetH,Hp2=d2ldetH, #b2 = d2b) niter=iter,H = ll$lbb,dH = ll$d1H,dVkk=dVkk)#,d2H=llr$d2H) ## debugging code to allow components of 2nd deriv of hessian w.r.t. sp.s ## to be passed to deriv.check.... #if (!is.null(ll$ghost1)&&!is.null(ll$ghost2)) { # ret$ghost1 <- ll$ghost1; ret$ghost2 <- ret$ghost2 #} ret } ## end of gam.fit5 efsud <- function(x,y,lsp,Sl,weights=NULL,offset=NULL,family, control=gam.control(),Mp=-1,start=NULL) { ## Extended Fellner-Schall method ## tr(S^-S_j) is returned by ldetS as ldet1 - S1 from gam.fit5 ## b'S_jb is computed as d1bSb in gam.fit5 ## tr(V S_j) will need to be computed using Sl.termMult ## Sl returned by ldetS and Vb computed as in gam.fit5.postproc. tol <- 1e-6 lsp <- lsp + 2.5 mult <- 1 fit <- gam.fit5(x=x,y=y,lsp=lsp,Sl=Sl,weights=weights,offset=offset,deriv=0,family=family, control=control,Mp=Mp,start=start) score.hist <- rep(0,200) for (iter in 1:200) { start <- fit$coefficients ## obtain Vb... ipiv <- piv <- attr(fit$L,"pivot") p <- length(piv) ipiv[piv] <- 1:p Vb <- crossprod(forwardsolve(t(fit$L),diag(fit$D,nrow=p)[piv,,drop=FALSE])[ipiv,,drop=FALSE]) if (sum(fit$bdrop)) { ## some coefficients were dropped... q <- length(fit$bdrop) ibd <- !fit$bdrop Vtemp <- Vb; Vb <- matrix(0,q,q) Vb[ibd,ibd] <- Vtemp } Vb <- Sl.repara(fit$rp,Vb,inverse=TRUE) SVb <- Sl.termMult(Sl,Vb) ## this could be made more efficient trVS <- rep(0,length(SVb)) for (i in 1:length(SVb)) { ind <- attr(SVb[[i]],"ind") trVS[i] <- sum(diag(SVb[[i]][,ind])) } Sb <- Sl.termMult(Sl,start,full=TRUE) bSb <- rep(0,length(Sb)) for (i in 1:length(Sb)) { bSb[i] <- sum(start*Sb[[i]]) } a <- pmax(0,fit$S1*exp(-lsp) - trVS) r <- a/pmax(0,bSb) r[a==0&bSb==0] <- 1 r[!is.finite(r)] <- 1e6 lsp1 <- pmin(lsp + log(r)*mult,12) old.reml <- fit$REML fit <- gam.fit5(x=x,y=y,lsp=lsp1,Sl=Sl,weights=weights,offset=offset,deriv=0, family=family,control=control,Mp=Mp,start=start) ## some step length control... if (fit$REML<=old.reml) { ## improvement if (max(abs(log(r))<.05)) { ## consider step extension lsp2 <- pmin(lsp + log(r)*mult*2,12) ## try extending step... fit2 <- gam.fit5(x=x,y=y,lsp=lsp2,Sl=Sl,weights=weights,offset=offset,deriv=0,family=family, control=control,Mp=Mp,start=start) if (fit2$REML < fit$REML) { ## improvement - accept extension fit <- fit2;lsp <- lsp2 mult <- mult * 2 } else { ## accept old step lsp <- lsp1 } } else lsp <- lsp1 } else { ## no improvement while (fit$REML > old.reml&&mult>1) { ## don't contract below 1 as update doesn't have to improve REML mult <- mult/2 ## contract step lsp1 <- pmin(lsp + log(r)*mult,12) fit <- gam.fit5(x=x,y=y,lsp=lsp1,Sl=Sl,weights=weights,offset=offset,deriv=0,family=family, control=control,Mp=Mp,start=start) } lsp <- lsp1 if (mult<1) mult <- 1 } score.hist[iter] <- fit$REML if (iter==1) old.ll <- fit$l else { if (abs(old.ll-fit$l)sum(edf1)) edf2 <- edf1 ## note hat not possible here... list(Vc=Vc,Vb=Vb,Ve=Ve,edf=edf,edf1=edf1,edf2=edf2,F=F,R=R) } ## gam.fit5.post.proc deriv.check5 <- function(x, y, sp, weights = rep(1, length(y)), start = NULL, offset = rep(0, length(y)),Mp,family = gaussian(), control = gam.control(),deriv=2,eps=1e-7,spe=1e-3, Sl,...) ## FD checking of derivatives for gam.fit5: a debugging routine { if (!deriv%in%c(1,2)) stop("deriv should be 1 or 2") if (control$epsilon>1e-9) control$epsilon <- 1e-9 ## first obtain the fit corresponding to sp... b <- gam.fit5(x=x,y=y,lsp=sp,Sl=Sl,weights=weights,offset=offset,deriv=deriv, family=family,control=control,Mp=Mp,start=start) ## now get the derivatives of the likelihood w.r.t. coefs... ll <- family$ll(y=y,X=x,coef=b$coefficients,wt=weights,family=family, deriv=1,d1b=0,d2b=0,Hp=NULL,rank=0,fh=NULL,D=NULL) ## and finite difference versions of these... p <- length(b$coefficients) fdg <- rep(0,p) fdh <- matrix(0,p,p) for (i in 1:p) { coef1 <- b$coefficients;coef1[i] <- coef1[i] + eps ll1 <- family$ll(y=y,X=x,coef=coef1,wt=weights,family=family, deriv=1,d1b=0,d2b=0,Hp=NULL,rank=0,fh=NULL,D=NULL) fdg[i] <- (ll1$l - ll$l)/eps fdh[,i] <- (ll1$lb - ll$lb)/eps } ## display them... oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) plot(ll$lb,fdg,xlab="computed",ylab="FD",main="grad of log lik");abline(0,1) cat("log lik grad cor. =",cor(ll$lb,fdg),"\n") plot(ll$lbb,fdh,xlab="computed",ylab="FD",main="hess of log lik");abline(0,1) cat("log lik hess cor. =",cor(as.numeric(ll$lbb),as.numeric(fdh)),"\n") ## now we need to investigate the derivatives w.r.t. the log smoothing parameters. M <- length(sp) ## number of smoothing parameters fd.br <- matrix(0,p,M) REML1 <- rep(0,M) fd.dH <- list() for (i in 1:M) { ## the smoothing parameter loop sp0 <- sp1 <- sp;sp1[i] <- sp[i] + spe/2;sp0[i] <- sp[i] - spe/2 b0 <- gam.fit5(x=x,y=y,lsp=sp0,Sl=Sl,weights=weights,offset=offset,deriv=0, family=family,control=control,Mp=Mp,start=start) b1 <- gam.fit5(x=x,y=y,lsp=sp1,Sl=Sl,weights=weights,offset=offset,deriv=0, family=family,control=control,Mp=Mp,start=start) fd.br[,i] <- (b1$coefficients - b0$coefficients)/spe REML1[i] <- (b1$REML-b0$REML)/spe fd.dH[[i]] <- (b1$lbb - b0$lbb)/spe } ## plot db.drho against fd versions... for (i in 1:M) { plot(b$db.drho[,i],fd.br[,i],xlab="computed",ylab="FD",main="db/drho");abline(0,1) cat("cor db/drho[",i,"] = ",cor(b$db.drho[,i],fd.br[,i]),"\n") } ## plot first deriv Hessian against FD version for (i in 1:M) { plot(b$dH[[i]],fd.dH[[i]],xlab="computed",ylab="FD",main="dH/drho");abline(0,1) cat("cor dH/drho[",i,"] = ",cor(as.numeric(b$dH[[i]]),as.numeric(fd.dH[[i]])),"\n") } list(fd=list(lb=fdg,lbb=fdh,REML1=REML1,db.drho=fd.br,dH=fd.dH), lb=ll$lb,lbb=ll$lbb,REML1=b$REML1,db.drho=b$db.drho,dH=b$dH) } ## deriv.check5mgcv/R/gamlss.r0000644000177400001440000021307613037404750013266 0ustar murdochusers## (c) Simon N. Wood (2013-2016) distributed under GPL2 ## Code for the gamlss families. ## idea is that there are standard functions converting ## derivatives w.r.t. mu to derivatives w.r.t. eta, given ## given the links and derivatives. ## Then there are standard routines to take the family ## specific derivatives and the model matrices, and convert ## these to the required gradient, hessian, etc... ## Storage convections: ## 1. A single model matrix is stored, along with a single param vector. ## an index object associates columns with particular gamlss predictors. ## 2. Distribution specific derivatives are stored in d1l-d4l. ## Need to somehow record block starts... ## idea is that if n blocks are stored using loops with the ## given l >= k >= j >= i structure then the block for index ## i,j,k,l starts at i4[i,j,k,l]*n+1, given symmetry over the indices. trind.generator <- function(K=2) { ## Generates index arrays for 'upper triangular' storage up to order 4 ## Suppose you fill an array using code like... ## m = 1 ## for (i in 1:K) for (j in i:K) for (k in j:K) for (l in k:K) { ## a[,m] <- something; m <- m+1 } ## ... and do this because actually the same 'something' would ## be stored for any permutation of the indices i,j,k,l. ## Clearly in storage we have the restriction l>=k>=j>=i, ## but for access we want no restriction on the indices. ## i4[i,j,k,l] produces the appropriate m for unrestricted ## indices. i3 and i2 do the same for 3d and 2d arrays. i4 <- array(0,dim=c(K,K,K,K)) m.start <- 1 m <- m.start for (i in 1:K) for (j in i:K) for (k in j:K) for (l in k:K) { i4[i,j,k,l] <- i4[i,j,l,k] <- i4[i,k,l,j] <- i4[i,k,j,l] <- i4[i,l,j,k] <- i4[i,l,k,j] <- i4[j,i,k,l] <- i4[j,i,l,k] <- i4[j,k,l,i] <- i4[j,k,i,l] <- i4[j,l,i,k] <- i4[j,l,k,i] <- i4[k,j,i,l] <- i4[k,j,l,i] <- i4[k,i,l,j] <- i4[k,i,j,l] <- i4[k,l,j,i] <- i4[k,l,i,j] <- i4[l,j,k,i] <- i4[l,j,i,k] <- i4[l,k,i,j] <- i4[l,k,j,i] <- i4[l,i,j,k] <- i4[l,i,k,j] <- m m <- m + 1 } i3 <- array(0,dim=c(K,K,K)) m <- m.start for (j in 1:K) for (k in j:K) for (l in k:K) { i3[j,k,l] <- i3[j,l,k] <- i3[k,l,j] <- i3[k,j,l] <- i3[l,j,k] <- i3[l,k,j] <- m m <- m + 1 } i2 <- array(0,dim=c(K,K)) m <- m.start for (k in 1:K) for (l in k:K) { i2[k,l] <- i2[l,k] <- m m <- m + 1 } list(i2=i2,i3=i3,i4=i4) } ## trind.generator gamlss.etamu <- function(l1,l2,l3=NULL,l4=NULL,ig1,g2,g3=NULL,g4=NULL,i2,i3=NULL,i4=NULL,deriv=0) { ## lj is the array of jth order derivatives of l ## gj[,k] contains the jth derivatives for the link of the kth lp ## ig1 is one over first deriv of link ## kth parameter. This routine transforms derivatives ## w.r.t. the parameters (mu_1..mu_K) to derivatives ## w.r.t. the linear predictors (eta_1.. eta_K) ## i2, i3 and i4 are the upper triangular indexing arrays ## e.g. l4[,i4[i,j,l,m]] contains the partial w.r.t. ## params indexed by i,j,l,m with no restriction on ## the index values except that they are in 1..K K <- ncol(l1) ## number of parameters of distribution d1 <- l1 for (i in 1:K) { ## first derivative loop d1[,i] <- l1[,i]*ig1[,i] } ##n <- length(ig1[,1]) k <- 0 d2 <- l2 for (i in 1:K) for (j in i:K) { ## obtain the order of differentiation associated ## with the i,j derivatives... ord <- rep(1,2);k <- k+1 if (i==j) {ord[1] <- ord[1] + 1; ord[2] <- 0 } ## l2[,k] is derivative to transform mo <- max(ord) if (mo==2) { ## pure 2nd derivative transform d2[,k] <- (l2[,k] - l1[,i]*g2[,i]*ig1[,i])*ig1[,i]^2 } else { ## all first derivative d2[,k] <- l2[,k]*ig1[,i]*ig1[,j] } } ## 2nd order transform done k <- 0 d3 <- l3 if (deriv>0) for (i in 1:K) for (j in i:K) for (l in j:K) { ## obtain the order of differentiation associated ## with the i,j,l derivatives... ord <- rep(1,3);k <- k+1 if (i==j) {ord[1] <- ord[1] + 1; ord[2] <- 0 } if (i==l) {ord[1] <- ord[1] + 1; ord[3] <- 0 } if (ord[2]) { if (j==l) {ord[2] <- ord[2] + 1; ord[3] <- 0 } } ii <- c(i,j,l) ## l3[,k] is derivative to transform mo <- max(ord) if (mo==3) { ## pure 3rd derivative transform d3[,k] <- (l3[,k] - 3*l2[,i2[i,i]]*g2[,i]*ig1[,i] + l1[,i]*(3*g2[,i]^2*ig1[,i]^2 - g3[,i]*ig1[,i]))*ig1[,i]^3 } else if (mo==1) { ## all first derivative d3[,k] <- l3[,k]*ig1[,i]*ig1[,j]*ig1[,l] } else { ## 2,1 deriv k1 <- ii[ord==1] ## index of order 1 deriv k2 <- ii[ord==2] ## index of order 2 part d3[,k] <- (l3[,k] - l2[,i2[k2,k1]]*g2[,k2]*ig1[,k2])* ig1[,k1]*ig1[,k2]^2 } } ## 3rd order transform done k <- 0 d4 <- l4 if (deriv>2) for (i in 1:K) for (j in i:K) for (l in j:K) for (m in l:K) { ## obtain the order of differentiation associated ## with the i,j,l & m derivatives... ord <- rep(1,4);k <- k+1 if (i==j) {ord[1] <- ord[1] + 1; ord[2] <- 0 } if (i==l) {ord[1] <- ord[1] + 1; ord[3] <- 0 } if (i==m) {ord[1] <- ord[1] + 1; ord[4] <- 0 } if (ord[2]) { if (j==l) {ord[2] <- ord[2] + 1; ord[3] <- 0 } if (j==m) {ord[2] <- ord[2] + 1; ord[4] <- 0 } } if (ord[3]&&l==m) { ord[3] <- ord[3] + 1; ord[4] <- 0 } ii <- c(i,j,l,m) ## l4[,k] is derivative to transform mo <- max(ord) if (mo==4) { ## pure 4th derivative transform d4[,k] <- (l4[,k] - 6*l3[,i3[i,i,i]]*g2[,i]*ig1[,i] + l2[,i2[i,i]]*(15*g2[,i]^2*ig1[,i]^2 - 4*g3[,i]*ig1[,i]) - l1[,i]*(15*g2[,i]^3*ig1[,i]^3 - 10*g2[,i]*g3[,i]*ig1[,i]^2 + g4[,i]*ig1[,i]))*ig1[,i]^4 } else if (mo==1) { ## all first derivative d4[,k] <- l4[,k]*ig1[,i]*ig1[,j]*ig1[,l]*ig1[,m] } else if (mo==3) { ## 3,1 deriv k1 <- ii[ord==1] ## index of order 1 deriv k3 <- ii[ord==3] ## index of order 3 part d4[,k] <- (l4[,k] - 3*l3[,i3[k3,k3,k1]]*g2[,k3]*ig1[,k3] + l2[,i2[k3,k1]]*(3*g2[,k3]^2*ig1[,k3]^2 - g3[,k3]*ig1[,k3]) )*ig1[,k1]*ig1[,k3]^3 } else { if (sum(ord==2)==2) { ## 2,2 k2a <- (ii[ord==2])[1];k2b <- (ii[ord==2])[2] d4[,k] <- (l4[,k] - l3[,i3[k2a,k2b,k2b]]*g2[,k2a]*ig1[,k2a] -l3[,i3[k2a,k2a,k2b]]*g2[,k2b]*ig1[,k2b] + l2[,i2[k2a,k2b]]*g2[,k2a]*g2[,k2b]*ig1[,k2a]*ig1[,k2b] )*ig1[,k2a]^2*ig1[,k2b]^2 } else { ## 2,1,1 k2 <- ii[ord==2] ## index of order 2 derivative k1a <- (ii[ord==1])[1];k1b <- (ii[ord==1])[2] d4[,k] <- (l4[,k] - l3[,i3[k2,k1a,k1b]]*g2[,k2]*ig1[,k2] )*ig1[,k1a]*ig1[,k1b]*ig1[,k2]^2 } } } ## 4th order transform done list(l1=d1,l2=d2,l3=d3,l4=d4) } # gamlss.etamu gamlss.gH0 <- function(X,jj,l1,l2,i2,l3=0,i3=0,l4=0,i4=0,d1b=0,d2b=0,deriv=0,fh=NULL,D=NULL) { ## X[,jj[[i]]] is the ith model matrix. ## lj contains jth derivatives of the likelihood for each datum, ## columns are w.r.t. different combinations of parameters. ## ij is the symmetric array indexer for the jth order derivs... ## e.g. l4[,i4[i,j,l,m]] contains derivatives with ## respect to parameters indexed by i,j,l,m ## d1b and d2b are first and second derivatives of beta w.r.t. sps. ## fh is a factorization of the penalized hessian, while D contains the corresponding ## Diagonal pre-conditioning weights. ## deriv: 0 - just grad and Hess ## 1 - diagonal of first deriv of Hess wrt sps ## 2 - first deriv of Hess wrt sps ## 3 - everything. K <- length(jj) p <- ncol(X);n <- nrow(X) trHid2H <- d1H <- d2H <- NULL ## defaults ## the gradient... lb <- rep(0,p) for (i in 1:K) { ## first derivative loop lb[jj[[i]]] <- colSums(l1[,i]*X[,jj[[i]],drop=FALSE]) } ## the Hessian... lbb <- matrix(0,p,p) for (i in 1:K) for (j in i:K) { lbb[jj[[i]],jj[[j]]] <- t(X[,jj[[i]],drop=FALSE])%*%(l2[,i2[i,j]]*X[,jj[[j]],drop=FALSE]) lbb[jj[[j]],jj[[i]]] <- t(lbb[jj[[i]],jj[[j]]]) } if (deriv>0) { ## the first derivative of the Hessian, using d1b ## the first derivates of the coefficients wrt the sps m <- ncol(d1b) ## number of smoothing parameters ## stack the derivatives of the various linear predictors on top ## of each other... d1eta <- matrix(0,n*K,m) ind <- 1:n for (i in 1:K) { d1eta[ind,] <- X[,jj[[i]],drop=FALSE]%*%d1b[jj[[i]],] ind <- ind + n } } if (deriv==1) { d1H <- matrix(0,p,m) ## only store diagonals of d1H for (l in 1:m) { for (i in 1:K) { v <- rep(0,n);ind <- 1:n for (q in 1:K) { v <- v + l3[,i3[i,i,q]] * d1eta[ind,l] ind <- ind + n } d1H[jj[[i]],l] <- colSums(X[,jj[[i]],drop=FALSE]*(v*X[,jj[[i]],drop=FALSE])) } } } ## if deriv==1 if (deriv>1) { d1H <- list() for (l in 1:m) { d1H[[l]] <- matrix(0,p,p) for (i in 1:K) for (j in i:K) { v <- rep(0,n);ind <- 1:n for (q in 1:K) { v <- v + l3[,i3[i,j,q]] * d1eta[ind,l] ind <- ind + n } ## d1H[[l]][jj[[j]],jj[[i]]] <- d1H[[l]][jj[[i]],jj[[j]]] <- t(X[,jj[[i]],drop=FALSE])%*%(v*X[,jj[[j]],drop=FALSE]) d1H[[l]][jj[[j]],jj[[i]]] <- t(d1H[[l]][jj[[i]],jj[[j]]]) } } } ## if deriv>1 if (deriv>2) { ## need tr(Hp^{-1} d^2H/drho_k drho_j) ## First form the expanded model matrix... VX <- Xe <- matrix(0,K*n,ncol(X)) ind <- 1:n for (i in 1:K) { Xe[ind,jj[[i]]] <- X[,jj[[i]]] ind <- ind + n } ## Now form Hp^{-1} Xe'... if (is.list(fh)) { ## then the supplied factor is an eigen-decomposition d <- fh$values;d[d>0] <- 1/d[d>0];d[d<=0] <- 0 Xe <- t(D*((fh$vectors%*%(d*t(fh$vectors)))%*%(D*t(Xe)))) } else { ## the supplied factor is a choleski factor ipiv <- piv <- attr(fh,"pivot");ipiv[piv] <- 1:p Xe <- t(D*(backsolve(fh,forwardsolve(t(fh),(D*t(Xe))[piv,]))[ipiv,])) } ## now compute the required trace terms d2eta <- matrix(0,n*K,ncol(d2b)) ind <- 1:n for (i in 1:K) { d2eta[ind,] <- X[,jj[[i]],drop=FALSE]%*%d2b[jj[[i]],] ind <- ind + n } trHid2H <- rep(0,ncol(d2b)) kk <- 0 ## counter for second derivatives for (k in 1:m) for (l in k:m) { ## looping over smoothing parameters... kk <- kk + 1 for (i in 1:K) for (j in 1:K) { v <- rep(0,n);ind <- 1:n for (q in 1:K) { ## accumulate the diagonal matrix for X_i'diag(v)X_j v <- v + d2eta[ind,kk]*l3[,i3[i,j,q]] ins <- 1:n for (s in 1:K) { v <- v + d1eta[ind,k]*d1eta[ins,l]*l4[,i4[i,j,q,s]] ins <- ins + n } ind <- ind + n } if (i==j) { rind <- 1:n + (i-1)*n VX[rind,jj[[i]]] <- v * X[,jj[[i]]] } else { rind1 <- 1:n + (i-1)*n rind2 <- 1:n + (j-1)*n VX[rind2,jj[[i]]] <- v * X[,jj[[i]]] VX[rind1,jj[[j]]] <- v * X[,jj[[j]]] } } trHid2H[kk] <- sum(Xe*VX) } } ## if deriv>2 list(lb=lb, ## grad w.r.t. coefs lbb=lbb, ## hess w.r.t. coefs, H d1H=d1H, ## grad of H wrt sps ## d2H=d2H, trHid2H=trHid2H) ## tr(H^{-1}d^2H/dspsp) } ## end of gamlss.gH0 gamlss.gH <- function(X,jj,l1,l2,i2,l3=0,i3=0,l4=0,i4=0,d1b=0,d2b=0,deriv=0,fh=NULL,D=NULL) { ## X[,jj[[i]]] is the ith model matrix. ## lj contains jth derivatives of the likelihood for each datum, ## columns are w.r.t. different combinations of parameters. ## ij is the symmetric array indexer for the jth order derivs... ## e.g. l4[,i4[i,j,l,m]] contains derivatives with ## respect to parameters indexed by i,j,l,m ## d1b and d2b are first and second derivatives of beta w.r.t. sps. ## fh is a factorization of the penalized hessian, while D contains the corresponding ## Diagonal pre-conditioning weights. ## deriv: 0 - just grad and Hess ## 1 - diagonal of first deriv of Hess ## 2 - first deriv of Hess ## 3 - everything. K <- length(jj) p <- ncol(X);n <- nrow(X) trHid2H <- d1H <- d2H <- NULL ## defaults ## the gradient... lb <- rep(0,p) for (i in 1:K) { ## first derivative loop lb[jj[[i]]] <- lb[jj[[i]]] + colSums(l1[,i]*X[,jj[[i]],drop=FALSE]) ## ! } ## the Hessian... lbb <- matrix(0,p,p) for (i in 1:K) for (j in i:K) { ## A <- t(X[,jj[[i]],drop=FALSE])%*%(l2[,i2[i,j]]*X[,jj[[j]],drop=FALSE]) A <- crossprod(X[,jj[[i]],drop=FALSE],l2[,i2[i,j]]*X[,jj[[j]],drop=FALSE]) lbb[jj[[i]],jj[[j]]] <- lbb[jj[[i]],jj[[j]]] + A if (j>i) lbb[jj[[j]],jj[[i]]] <- lbb[jj[[j]],jj[[i]]] + t(A) } if (deriv>0) { ## the first derivative of the Hessian, using d1b ## the first derivates of the coefficients wrt the sps m <- ncol(d1b) ## number of smoothing parameters ## stack the derivatives of the various linear predictors on top ## of each other... d1eta <- matrix(0,n*K,m) ind <- 1:n for (i in 1:K) { d1eta[ind,] <- X[,jj[[i]],drop=FALSE]%*%d1b[jj[[i]],] ind <- ind + n } } if (deriv==1) { d1H <- matrix(0,p,m) ## only store diagonals of d1H for (l in 1:m) { for (i in 1:K) { v <- rep(0,n);ind <- 1:n for (q in 1:K) { v <- v + l3[,i3[i,i,q]] * d1eta[ind,l] ind <- ind + n } d1H[jj[[i]],l] <- d1H[jj[[i]],l] + colSums(X[,jj[[i]],drop=FALSE]*(v*X[,jj[[i]],drop=FALSE])) } } } ## if deriv==1 if (deriv>1) { d1H <- list() for (l in 1:m) { d1H[[l]] <- matrix(0,p,p) for (i in 1:K) for (j in i:K) { v <- rep(0,n);ind <- 1:n for (q in 1:K) { v <- v + l3[,i3[i,j,q]] * d1eta[ind,l] ind <- ind + n } ## d1H[[l]][jj[[j]],jj[[i]]] <- ## A <- t(X[,jj[[i]],drop=FALSE])%*%(v*X[,jj[[j]],drop=FALSE]) A <- crossprod(X[,jj[[i]],drop=FALSE],v*X[,jj[[j]],drop=FALSE]) d1H[[l]][jj[[i]],jj[[j]]] <- d1H[[l]][jj[[i]],jj[[j]]] + A if (j>i) d1H[[l]][jj[[j]],jj[[i]]] <- d1H[[l]][jj[[j]],jj[[i]]] + t(A) } } } ## if deriv>1 if (deriv>2) { ## need tr(Hp^{-1} d^2H/drho_k drho_j) ## First form the expanded model matrix... VX <- Xe <- matrix(0,K*n,ncol(X)) ind <- 1:n for (i in 1:K) { Xe[ind,jj[[i]]] <- X[,jj[[i]]] ind <- ind + n } ## Now form Hp^{-1} Xe'... if (is.list(fh)) { ## then the supplied factor is an eigen-decomposition d <- fh$values;d[d>0] <- 1/d[d>0];d[d<=0] <- 0 Xe <- t(D*((fh$vectors%*%(d*t(fh$vectors)))%*%(D*t(Xe)))) } else { ## the supplied factor is a choleski factor ipiv <- piv <- attr(fh,"pivot");ipiv[piv] <- 1:p Xe <- t(D*(backsolve(fh,forwardsolve(t(fh),(D*t(Xe))[piv,]))[ipiv,])) } ## now compute the required trace terms d2eta <- matrix(0,n*K,ncol(d2b)) ind <- 1:n for (i in 1:K) { d2eta[ind,] <- X[,jj[[i]],drop=FALSE]%*%d2b[jj[[i]],] ind <- ind + n } trHid2H <- rep(0,ncol(d2b)) kk <- 0 ## counter for second derivatives for (k in 1:m) for (l in k:m) { ## looping over smoothing parameters... kk <- kk + 1 for (i in 1:K) for (j in 1:K) { v <- rep(0,n);ind <- 1:n for (q in 1:K) { ## accumulate the diagonal matrix for X_i'diag(v)X_j v <- v + d2eta[ind,kk]*l3[,i3[i,j,q]] ins <- 1:n for (s in 1:K) { v <- v + d1eta[ind,k]*d1eta[ins,l]*l4[,i4[i,j,q,s]] ins <- ins + n } ind <- ind + n } if (i==j) { rind <- 1:n + (i-1)*n VX[rind,jj[[i]]] <- v * X[,jj[[i]]] } else { rind1 <- 1:n + (i-1)*n rind2 <- 1:n + (j-1)*n VX[rind2,jj[[i]]] <- v * X[,jj[[i]]] VX[rind1,jj[[j]]] <- v * X[,jj[[j]]] } } trHid2H[kk] <- sum(Xe*VX) } } ## if deriv>2 list(lb=lb,lbb=lbb,d1H=d1H,d2H=d2H,trHid2H=trHid2H) } ## end of gamlss.gH fitNull <- function(y,family,wt,offset,nlp=1,tol=1e-7) { ## fit the null model to the data in y for a general family ## model has one constant per predictor - initially indended ## to provide null deviance, but really that makes no sense ## since different scale parameters lead to deviances that ## can not really be compared. X <- matrix(1,length(y),nlp) lpi <- list(); for (i in 1:nlp) lpi[[i]] <- i attr(X,"lpi") <- lpi coef <- rep(0,nlp) ok <- FALSE while (!ok) { b <- family$ll(y,X,coef,wt,family,offset,deriv=1) eb <- eigen(-b$lbb) eb$values <- abs(eb$values) ind <- eb$values>0 eb$values[ind] <- 1/eb$values[ind] d <- as.numeric(eb$vectors %*% (eb$values*(t(eb$vectors) %*% b$lb))) step.ok <- FALSE; k <- 0 while (!step.ok&&k<20) { k <- k + 1 b1 <- family$ll(y,X,coef+d,wt,family,offset,deriv=0) if (b1$l>=b$l) { step.ok <- TRUE coef <- coef + d } else d <- d/2 } if (!step.ok) ok <- TRUE ## stop on step failure if (abs(b1$l-b$l)0) { l1[,1] <- tau2*ymu l1[,2] <- 1/tau - tau*ymu2 ## the second derivatives l2 <- matrix(0,n,3) ## order mm,ms,ss l2[,1] <- -tau2 l2[,2] <- 2*l1[,1]/tau l2[,3] <- -ymu2 - 1/tau2 ## need some link derivatives for derivative transform ig1 <- cbind(family$linfo[[1]]$mu.eta(eta),family$linfo[[2]]$mu.eta(eta1)) g2 <- cbind(family$linfo[[1]]$d2link(mu),family$linfo[[2]]$d2link(tau)) } l3 <- l4 <- g3 <- g4 <- 0 ## defaults if (deriv>1) { ## the third derivatives ## order mmm,mms,mss,sss l3 <- matrix(0,n,4) ## l3[,1] <- 0 l3[,2] <- -2*tau l3[,3] <- 2*ymu l3[,4] <- 2/tau^3 g3 <- cbind(family$linfo[[1]]$d3link(mu),family$linfo[[2]]$d3link(tau)) } if (deriv>3) { ## the fourth derivatives ## order mmmm,mmms,mmss,msss,ssss l4 <- matrix(0,n,5) ## l4[,1] <- 0 ## l4[,2] <- 0 l4[,3] <- -2 #l4[,4] <- 0 l4[,5] <- -6/tau2^2 g4 <- cbind(family$linfo[[1]]$d4link(mu),family$linfo[[2]]$d4link(tau)) } if (deriv) { i2 <- family$tri$i2; i3 <- family$tri$i3 i4 <- family$tri$i4 ## transform derivates w.r.t. mu to derivatives w.r.t. eta... de <- gamlss.etamu(l1,l2,l3,l4,ig1,g2,g3,g4,i2,i3,i4,deriv-1) ## get the gradient and Hessian... ret <- gamlss.gH(X,jj,de$l1,de$l2,i2,l3=de$l3,i3=i3,l4=de$l4,i4=i4, d1b=d1b,d2b=d2b,deriv=deriv-1,fh=fh,D=D) } else ret <- list() ret$l <- l; ret } ## end ll gaulss initialize <- expression({ ## idea is to regress g(y) on model matrix for mean, and then ## to regress the corresponding log absolute residuals on ## the model matrix for log(sigma) - may be called in both ## gam.fit5 and initial.spg... note that appropriate E scaling ## for full calculation may be inappropriate for initialization ## which is basically penalizing something different here. ## best we can do here is to use E only as a regularizer. n <- rep(1, nobs) ## should E be used unscaled or not?.. use.unscaled <- if (!is.null(attr(E,"use.unscaled"))) TRUE else FALSE if (is.null(start)) { jj <- attr(x,"lpi") #offs <- attr(x,"offset") if (!is.null(offset)) offset[[3]] <- 0 start <- rep(0,ncol(x)) yt1 <- if (family$link[[1]]=="identity") y else family$linfo[[1]]$linkfun(abs(y)+max(y)*1e-7) if (!is.null(offset[[1]])) yt1 <- yt1 - offset[[1]] x1 <- x[,jj[[1]],drop=FALSE] e1 <- E[,jj[[1]],drop=FALSE] ## square root of total penalty #ne1 <- norm(e1); if (ne1==0) ne1 <- 1 if (use.unscaled) { qrx <- qr(rbind(x1,e1)) x1 <- rbind(x1,e1) startji <- qr.coef(qr(x1),c(yt1,rep(0,nrow(E)))) startji[!is.finite(startji)] <- 0 } else startji <- pen.reg(x1,e1,yt1) start[jj[[1]]] <- startji lres1 <- log(abs(y-family$linfo[[1]]$linkinv(x[,jj[[1]],drop=FALSE]%*%start[jj[[1]]]))) if (!is.null(offset[[2]])) lres1 <- lres1 - offset[[2]] x1 <- x[,jj[[2]],drop=FALSE];e1 <- E[,jj[[2]],drop=FALSE] #ne1 <- norm(e1); if (ne1==0) ne1 <- 1 if (use.unscaled) { x1 <- rbind(x1,e1) startji <- qr.coef(qr(x1),c(lres1,rep(0,nrow(E)))) startji[!is.finite(startji)] <- 0 } else startji <- pen.reg(x1,e1,lres1) start[jj[[2]]] <- startji } }) ## initialize gaulss structure(list(family="gaulss",ll=ll,link=paste(link),nlp=2, tri = trind.generator(2), ## symmetric indices for accessing derivative arrays initialize=initialize,postproc=postproc,residuals=residuals, linfo = stats, ## link information list d2link=1,d3link=1,d4link=1, ## signals to fix.family.link that all done ls=1, ## signals that ls not needed here available.derivs = 2 ## can use full Newton here ),class = c("general.family","extended.family","family")) } ## end gaulss multinom <- function(K=1) { ## general family for multinomial logistic regression model... ## accepts no links as parameterization directly in terms of ## linear predictor. ## 1. get derivatives wrt mu, tau ## 2. get required link derivatives and tri indices. ## 3. transform derivs to derivs wrt eta (gamlss.etamu). ## 4. get the grad and Hessian etc for the model ## via a call to gamlss.gH ## the first derivatives of the log likelihood w.r.t ## the first and second parameters... if (K<1) stop("number of categories must be at least 2") stats <- list() for (i in 1:K) { stats[[i]] <- make.link("identity") fam <- structure(list(link="identity",canonical="none",linkfun=stats[[i]]$linkfun, mu.eta=stats[[i]]$mu.eta), class="family") fam <- fix.family.link(fam) stats[[i]]$d2link <- fam$d2link stats[[i]]$d3link <- fam$d3link stats[[i]]$d4link <- fam$d4link } residuals <- function(object,type=c("deviance")) { ## Deviance residuals where sign depends on whether classification correct (+ve) ## or not (-ve)... type <- match.arg(type) ## get category probabilities... p <- object$family$predict(object$family,eta=object$linear.predictors)[[1]] ## now get most probable category for each observation pc <- apply(p,1,function(x) which(max(x)==x)[1])-1 n <- length(pc) ## +ve sign if class correct, -ve otherwise sgn <- rep(-1,n); sgn[pc==object$y] <- 1 ## now get the deviance... sgn*sqrt(-2*log(pmax(.Machine$double.eps,p[1:n + object$y*n]))) } ## residuals predict <- function(family,se=FALSE,eta=NULL,y=NULL,X=NULL, beta=NULL,off=NULL,Vb=NULL) { ## optional function to give predicted values - idea is that ## predict.gam(...,type="response") will use this, and that ## either eta will be provided, or {X, beta, off, Vb}. family$data ## contains any family specific extra information. ## if se = FALSE returns one item list containing matrix otherwise ## list of two matrices "fit" and "se.fit"... if (is.null(eta)) { lpi <- attr(X,"lpi") if (is.null(lpi)) { lpi <- list(1:ncol(X)) } K <- length(lpi) ## number of linear predictors eta <- matrix(0,nrow(X),K) if (se) { ve <- matrix(0,nrow(X),K) ## variance of eta ce <- matrix(0,nrow(X),K*(K-1)/2) ## covariance of eta_i eta_j } for (i in 1:K) { Xi <- X[,lpi[[i]],drop=FALSE] eta[,i] <- Xi%*%beta[lpi[[i]]] ## ith linear predictor if (!is.null(off[[i]])) eta[,i] <- eta[,i] + off[[i]] if (se) { ## variance and covariances for kth l.p. ve[,i] <- drop(pmax(0,rowSums((Xi%*%Vb[lpi[[i]],lpi[[i]]])*Xi))) ii <- 0 if (iK) stop("response not in 0 to number of predictors + 1") ee <- exp(eta[,-1,drop=FALSE]) beta <- 1 + rowSums(ee); alpha <- log(beta) l0 <- eta[1:n+y*n] - alpha ## log likelihood l <- sum(l0) l1 <- matrix(0,n,K) ## first deriv matrix if (deriv>0) { for (i in 1:K) l1[,i] <- ee[,i]/beta ## alpha1 ## the second derivatives... l2 <- matrix(0,n,K*(K+1)/2) ii <- 0; b2 <- beta^2 for (i in 1:K) for (j in i:K) { ii <- ii + 1 ## column index l2[,ii] <- if (i==j) -l1[,i] + ee[,i]^2/b2 else (ee[,i]*ee[,j])/b2 } ## finish first derivatives... for (i in 1:K) l1[,i] <- as.numeric(y==i) - l1[,i] } ## if (deriv>0) l3 <- l4 <- 0 ## defaults tri <- family$tri ## indices to facilitate access to earlier results if (deriv>1) { ## the third derivatives... l3 <- matrix(0,n,(K*(K+3)+2)*K/6) ii <- 0; b3 <- b2 * beta for (i in 1:K) for (j in i:K) for (k in j:K) { ii <- ii + 1 ## column index if (i==j&&j==k) { ## all same l3[,ii] <- l2[,tri$i2[i,i]] + 2*ee[,i]^2/b2 - 2*ee[,i]^3/b3 } else if (i!=j&&j!=k&i!=k) { ## all different l3[,ii] <- -2*(ee[,i]*ee[,j]*ee[,k])/b3 } else { ## two same one different kk <- if (i==j) k else j ## get indices for differing pair l3[,ii] <- l2[,tri$i2[i,kk]] - 2*(ee[,i]*ee[,j]*ee[,k])/b3 } } } ## if (deriv>1) if (deriv>3) { ## the fourth derivatives... l4 <- matrix(0,n,(6+K*11+K^2*6+K^3)*K/24) ii <- 0; b4 <- b3 * beta for (i in 1:K) for (j in i:K) for (k in j:K) for (l in k:K) { ii <- ii + 1 ## column index uni <- unique(c(i,j,k,l)); nun <- length(uni) ## number of unique indices if (nun==1) { ## all equal l4[,ii] <- l3[,tri$i3[i,i,i]] + 4*ee[,i]^2/b2 - 10*ee[,i]^3/b3 + 6*ee[,i]^4/b4 } else if (nun==4) { ## all unequal l4[,ii] <- 6*ee[,i]*ee[,j]*ee[,k]*ee[,l]/b4 } else if (nun==3) { ## 2 same 2 different l4[,ii] <- l3[,tri$i3[uni[1],uni[2],uni[3]]] +6*ee[,i]*ee[,j]*ee[,k]*ee[,l]/b4 } else if (sum(uni[1]==c(i,j,k,l))==2) { ## 2 unique (2 of each) l4[,ii] <- l3[,tri$i3[uni[1],uni[2],uni[2]]] - 2 * ee[,uni[1]]^2*ee[,uni[2]]/b3 + 6*ee[,i]*ee[,j]*ee[,k]*ee[,l]/b4 } else { ## 3 of one 1 of the other if (sum(uni[1]==c(i,j,k,l))==1) uni <- uni[2:1] ## first index is triple repeat index l4[,ii] <- l3[,tri$i3[uni[1],uni[1],uni[2]]] - 4 * ee[,uni[1]]^2*ee[,uni[2]]/b3 + 6*ee[,i]*ee[,j]*ee[,k]*ee[,l]/b4 } } } ## if deriv>3 if (return.l) return(list(l=l0,l1=l1,l2=l2,l3=l3,l4=l4)) ## for testing... if (deriv) { ## get the gradient and Hessian... ret <- gamlss.gH(X,jj,l1,l2,tri$i2,l3=l3,i3=tri$i3,l4=l4,i4=tri$i4, d1b=d1b,d2b=d2b,deriv=deriv-1,fh=fh,D=D) } else ret <- list() ret$l <- l; ret } ## end ll multinom rd <- function(mu,wt,scale) { ## simulate data given fitted linear predictor matrix in mu p <- exp(cbind(0,mu)) p <- p/rowSums(p) cp <- t(apply(p,1,cumsum)) apply(cp,1,function(x) min(which(x>runif(1))))-1 } ## rd initialize <- expression({ ## Binarize each category and lm on 6*y-3 by category. n <- rep(1, nobs) ## should E be used unscaled or not?.. use.unscaled <- if (!is.null(attr(E,"use.unscaled"))) TRUE else FALSE if (is.null(start)) { jj <- attr(x,"lpi") start <- rep(0,ncol(x)) for (k in 1:length(jj)) { ## loop over the linear predictors yt1 <- 6*as.numeric(y==k)-3 x1 <- x[,jj[[k]],drop=FALSE] e1 <- E[,jj[[k]],drop=FALSE] ## square root of total penalty if (use.unscaled) { qrx <- qr(rbind(x1,e1)) x1 <- rbind(x1,e1) startji <- qr.coef(qr(x1),c(yt1,rep(0,nrow(E)))) startji[!is.finite(startji)] <- 0 } else startji <- pen.reg(x1,e1,yt1) start[jj[[k]]] <- startji ## copy coefficients back into overall start coef vector } ## lp loop } }) ## initialize multinom structure(list(family="multinom",ll=ll,link=NULL,#paste(link), nlp=round(K),rd=rd, tri = trind.generator(K), ## symmetric indices for accessing derivative arrays initialize=initialize,postproc=postproc,residuals=residuals,predict=predict, linfo = stats, ## link information list d2link=1,d3link=1,d4link=1, ## signals to fix.family.link that all done ls=1, ## signals that ls not needed here available.derivs = 2 ## can use full Newton here ),class = c("general.family","extended.family","family")) } ## end multinom pen.reg <- function(x,e,y) { ## get coefficients of penalized regression of y on matrix x ## where e is a square root penalty. Idea is to use e mainly for ## regularization, so that edf is close to rank of x. if (sum(abs(e))==0) { ## no penalization - easy b <- qr.coef(qr(x),y);b[!is.finite(b)] <- 0 return(b) } ## need to adjust degree of penalization, so best to QR ## the x matrix up front... qrx <- qr(x,LAPACK=TRUE) R <- qr.R(qrx) r <- ncol(R) rr <- Rrank(R) ## rank of R/X R[,qrx$pivot] <- R ## unpivot Qy <- qr.qty(qrx,y)[1:ncol(R)] ## now we want estimates with penalty weight low enough ## EDF is k * rr where k is somewhere in e.g. (.7,.9) k <- .01 * norm(R)/norm(e) qrr <- qr(rbind(R,e*k)); edf <- sum(qr.Q(qrr)[1:r,]^2) while (edf > .9*rr) { ## increase penalization k <- k*10 qrr <- qr(rbind(R,e*k)); edf <- sum(qr.Q(qrr)[1:r,]^2) } while (edf<.7*rr) { ## reduce penalization k <- k/20 qrr <- qr(rbind(R,e*k)); edf <- sum(qr.Q(qrr)[1:r,]^2) } b <- qr.coef(qrr,c(Qy,rep(0,nrow(e))));b[!is.finite(b)] <- 0 b } ## pen.reg ## code for zero inflated Poisson models #log1ex <- function(x) { ## evaluate log(1+exp(x)) accurately and avoiding overflow # y <- x # big <- -log(.Machine$double.eps)+5 ## exp(big) overwhelms 1 # ind <- x > big # y[ind] <- x[ind] ## log(1+exp(x)) = x to machine precision # ## compute number below which log(1+exp(x)) = exp(x) to # ## machine precision... # small <- log(sqrt(.Machine$double.eps)) # ind1 <- x < small # y[ind1] <- exp(x[ind1]) # ind <- !ind&!ind1 ## the moderate size elements # y[ind] <- log(1+exp(x[ind])) # y #} #logist <- function(x) { ## overflow proof logistic # ind <- x > 0; y <- x # y[ind] <- 1/(exp(-x[ind])+1) # ex <- exp(x[!ind]) # y[!ind] <- ex/(1+ex) # y #} l1ee <- function(x) { ## log(1-exp(-exp(x)))... ind <- x < log(.Machine$double.eps)/3 ex <- exp(x);exi <- ex[ind] l <- log(1-exp(-ex)) l[ind] <- log(exi-exi^2/2+exi^3/6) ind <- x < -log(.Machine$double.xmax) l[ind] <- x[ind] l } lee1 <- function(x) { ## log(exp(exp(x))-1)... ind <- x < log(.Machine$double.eps)/3 ex <- exp(x);exi <- ex[ind] l <- log(exp(ex)-1) l[ind] <- log(exi+exi^2/2+exi^3/6) ind <- x < -log(.Machine$double.xmax) l[ind] <- x[ind] ind <- x > log(log(.Machine$double.xmax)) l[ind] <- ex[ind] l } ldg <- function(g,deriv=4) { alpha <- function(g) { ind <- g > log(.Machine$double.eps)/3 eg <- exp(g) g[ind] <- eg[ind]/(1-exp(-eg[ind])) g[!ind] <- 1+eg[!ind]/2 + eg[!ind]^2/12 g } ind <- g < log(.Machine$double.eps)/3 ghi <- log(log(.Machine$double.xmax)) + 1 ## ... above ghi alpha(g) is simply exp(g) ii <- g>ghi a <- alpha(g) eg <- exp(g) l2 <- a*(a-eg-1) egi <- eg[ind] ## in the lower tail alpha = 1 + b, where b = eg/2 + eg^2/12 ## so l'' = alpha*(b-eg)... b <- egi*(1+egi/6)/2 l2[ind] <- a[ind]*(b-egi) l2[ii] <- -exp(g[ii]) l3 <- l4 <- NULL ## in a similar vein l3 can be robustified... if (deriv>1) { l3 <- a*(a*(-2*a + 3*(eg+1)) - 3*eg - eg^2 - 1) l3[ind] <- a[ind]*(-b-2*b^2+3*b*egi-egi^2) l3[ii] <- -exp(g[ii]) } ## finally l4, which requires a similar approach... if (deriv>2) { l4 <- a*(6*a^3 - 12*(eg+1)*a^2+4*eg*a+7*(eg+1)^2*a-(4+3*eg)*eg -(eg+1)^3) l4[ind] <- a[ind]*(6*b*(3+3*b+b^2) - 12*egi*(1+2*b+b^2) - 12*b*(2-b) + 4*egi*(1+b)+ 7*(egi^2+2*egi+b*egi^2+2*b*egi+b)-(4+3*egi)*egi-egi*(3+3*egi+egi^2)) l4[ii] <- -exp(g[ii]) } l1=-a ghi <- log(.Machine$double.xmax)/5 ii <- g > ghi if (sum(ii)) { l1[ii] <- l2[ii] <- l3[ii] <- l4[ii] <- -exp(ghi) } list(l1=l1,l2=l2,l3=l3,l4=l4) } ## ldg lde <- function(eta,deriv=4) { ## llog lik derivs w.r.t. eta ind <- eta < log(.Machine$double.eps)/3 ii <- eta > log(.Machine$double.xmax) l1 <- et <- exp(eta);eti <- et[ind] l1[!ind] <- et[!ind]/(exp(et[!ind])-1) b <- -eti*(1+eti/6)/2 l1[ind] <- 1+b l1[ii] <- 0 ## l2 ... l2 <- l1*((1-et)-l1) l2[ind] <- -b*(1+eti+b) - eti l2[ii] <- 0 l3 <- l4 <- NULL ## l3 ... if (deriv>1) { ii <- eta > log(.Machine$double.xmax)/2 l3 <- l1*((1-et)^2-et - 3*(1-et)*l1 + 2*l1^2) l3[ind] <- l1[ind]*(-3*eti+eti^2 -3*(-eti+b-eti*b) + 2*b*(2+b)) l3[ii] <- 0 } ## l4 ... if (deriv>2) { ii <- eta > log(.Machine$double.xmax)/3 l4 <- l1*((3*et-4)*et + 4*et*l1 + (1-et)^3 - 7*(1-et)^2*l1 + 12*(1-et)*l1^2 - 6*l1^3) l4[ii] <- 0 l4[ind] <- l1[ind]*(4*l1[ind]*eti - eti^3 - b -7*b*eti^2 - eti^2 - 5*eti - 10*b*eti - 12*eti*b^2 - 6*b^2 - 6*b^3) } list(l1=l1,l2=l2,l3=l3,l4=l4) } ## lde zipll <- function(y,g,eta,deriv=0) { ## function to evaluate zero inflated Poisson log likelihood ## and its derivatives w.r.t. g/gamma and eta where ## 1-p = exp(-exp(eta)) and lambda = exp(gamma), for each datum in vector y. ## p is probability of potential presence. lambda is Poisson mean ## given potential presence. ## deriv: 0 - eval ## 1 - grad (l,p) and Hess (ll,lp,pp) ## 2 - third derivs lll,llp,lpp,ppp ## 4 - 4th derivs. llll,lllp,llpp,lppp,pppp l1 <- El2 <- l2 <- l3 <- l4 <- NULL zind <- y == 0 ## the index of the zeroes ## yz <- y[zind]; yp <- y[!zind] l <- et <- exp(eta) l[zind] <- -et[zind] # -exp(eta[ind]) l[!zind] <- l1ee(eta[!zind]) + yp*g[!zind] - lee1(g[!zind]) - lgamma(yp+1) p <- 1-exp(-et) ## probablity of non-zero if (deriv>0) { ## get first and second derivs... n <- length(y) l1 <- matrix(0,n,2) le <- lde(eta,deriv) ## derivs of ll wrt eta lg <- ldg(g,deriv) ## derivs of ll wrt gamma l1[!zind,1] <- yp + lg$l1[!zind] ## l_gamma, y>0 l1[zind,2] <- l[zind] ## l_eta, y==0 l1[!zind,2] <- le$l1[!zind] ## l_eta, y>0 El2 <- l2 <- matrix(0,n,3) ## order gg, ge, ee... l2[!zind,1] <- lg$l2[!zind] ## l_gg, y>0 l2[!zind,3] <- le$l2[!zind] ## l_ee, y>0 l2[zind,3] <- l[zind] ## l_ee, y=0 El2[,1] <- p*lg$l2 ## E(l_gg) El2[,3] <- -(1-p)*et + p*le$l2 ## E(l_ee) } if (deriv>1) { ## the third derivatives ## order ggg,gge,gee,eee l3 <- matrix(0,n,4) l3[!zind,1] <- lg$l3[!zind] ## l_ggg, y>0 l3[!zind,4] <- le$l3[!zind] ## l_eee, y>0 l3[zind,4] <- l[zind] ## l_eee, y=0 } if (deriv>3) { ## the fourth derivatives ## order gggg,ggge,ggee,geee,eeee l4 <- matrix(0,n,5) l4[!zind,1] <- lg$l4[!zind] ## l_gggg, y>0 l4[!zind,5] <- le$l4[!zind] ## l_eeee, y>0 l4[zind,5] <- l[zind] ## l_eeee, y=0 } list(l=l,l1=l1,l2=l2,l3=l3,l4=l4,El2=El2) } ## zipll ziplss <- function(link=list("identity","identity")) { ## Extended family for Zero Inflated Poisson fitted as gamlss ## type model. ## mu1 is Poisson mean, while mu2 is zero inflation parameter. ## first deal with links and their derivatives... if (length(link)!=2) stop("ziplss requires 2 links specified as character strings") okLinks <- list(c("identity"),c("identity")) stats <- list() param.names <- c("Poisson mean","binary probability") for (i in 1:2) { if (link[[i]] %in% okLinks[[i]]) stats[[i]] <- make.link(link[[i]]) else stop(link[[i]]," link not available for ",param.names[i]," parameter of ziplss") fam <- structure(list(link=link[[i]],canonical="none",linkfun=stats[[i]]$linkfun, mu.eta=stats[[i]]$mu.eta), class="family") fam <- fix.family.link(fam) stats[[i]]$d2link <- fam$d2link stats[[i]]$d3link <- fam$d3link stats[[i]]$d4link <- fam$d4link } residuals <- function(object,type=c("deviance","response")) { ls <- function(y) { ## compute saturated likelihood for ziplss model l <- y;l[y<2] <- 0 ind <- y > 1 & y < 18 ## lambda maximizing likelihood for y = 2 to 17 glo <- c(1.593624,2.821439,3.920690,4.965114,5.984901,6.993576, 7.997309,8.998888,9.999546,10.999816,11.999926,12.999971, 13.999988,14.999995,15.999998,16.999999) g <- y ## maximizing lambda essentially y above this g[ind] <- glo[y[ind]-1] ind <- y > 1 l[ind] <- zipll(y[ind],log(g[ind]),g[ind]*0+1e10,deriv=0)$l l } ## ls type <- match.arg(type) p <- exp(-exp(object$fitted[,2])); lam <- exp(object$fitted[,1]) ind <- lam > .Machine$double.eps^.5 ## compute E(y) Ey <- p ## very small lambda causes conditional expectation to be 1 Ey[ind] <- p[ind]*lam[ind]/(1-exp(-lam[ind])) rsd <- object$y - Ey ## raw residuals if (type=="response") return(rsd) else { ## compute deviance residuals sgn <- sign(rsd) ind <- object$y == 0 rsd <- pmax(0,2*(ls(object$y) - zipll(object$y,object$fitted[,1],object$fitted[,2],deriv=0)$l)) rsd <- sqrt(rsd)*sgn } rsd } ## residuals predict <- function(family,se=FALSE,eta=NULL,y=NULL,X=NULL, beta=NULL,off=NULL,Vb=NULL) { ## optional function to give predicted values - idea is that ## predict.gam(...,type="response") will use this, and that ## either eta will be provided, or {X, beta, off, Vb}. family$data ## contains any family specific extra information. ## if se = FALSE returns one item list containing matrix otherwise ## list of two matrices "fit" and "se.fit"... if (is.null(eta)) { if (is.null(off)) off <- list(0,0) off[[3]] <- 0 for (i in 1:2) if (is.null(off[[i]])) off[[i]] <- 0 lpi <- attr(X,"lpi") X1 <- X[,lpi[[1]],drop=FALSE] X2 <- X[,lpi[[2]],drop=FALSE] gamma <- drop(X1%*%beta[lpi[[1]]] + off[[1]]) ## linear predictor for poisson parameter eta <- drop(X2%*%beta[lpi[[2]]] + off[[2]]) ## linear predictor for presence parameter if (se) { v.g <- drop(pmax(0,rowSums((X1%*%Vb[lpi[[1]],lpi[[1]]])*X1))) ## var of gamma v.e <- drop(pmax(0,rowSums((X1%*%Vb[lpi[[1]],lpi[[1]]])*X1))) ## var of eta v.eg <- drop(pmax(0,rowSums((X1%*%Vb[lpi[[1]],lpi[[2]]])*X2))) ## cov of eta, gamma } } else { se <- FALSE gamma <- eta[,1] eta <- eta[,2] } et <- exp(eta) mu <- p <- 1 - exp(-et) fv <- lambda <- exp(gamma) ind <- gamma < log(.Machine$double.eps)/2 mu[!ind] <- lambda[!ind]/(1-exp(-lambda[!ind])) mu[ind] <- 1 fv <- list(p*mu) ## E(y) if (!se) return(fv) else { df.de <- p ind <- eta < log(.Machine$double.xmax)/2 df.de[!ind] <- 0 df.de[ind] <- exp(-et[ind])*et[ind] df.de <- df.de * mu df.dg <- ((lambda + 1)*mu - mu^2)*p fv[[2]] <- sqrt(df.dg^2*v.g + df.de^2*v.e + 2 * df.de * df.dg * v.eg) names(fv) <- c("fit","se.fit") return(fv) } } ## predict rd <- function(mu,wt,scale) { ## simulate data given fitted latent variable in mu rzip <- function(gamma,eta) { ## generate ziP deviates according to model and lp gamma y <- gamma; n <- length(y) lambda <- exp(gamma) p <- 1- exp(-exp(eta)) ind <- p > runif(n) y[!ind] <- 0 np <- sum(ind) ## generate from zero truncated Poisson, given presence... y[ind] <- qpois(runif(np,dpois(0,lambda[ind]),1),lambda[ind]) y } rzip(mu[,1],mu[,2]) } ## rd postproc <- expression({ ## code to evaluate in estimate.gam, to evaluate null deviance ## null model really has two parameters... probably need to newton iterate ls <- function(y) { ## compute saturated likelihood for ziplss model l <- y;l[y<2] <- 0 ind <- y > 1 & y < 18 ## lambda maximizing likelihood for y = 2 to 17 glo <- c(1.593624,2.821439,3.920690,4.965114,5.984901,6.993576, 7.997309,8.998888,9.999546,10.999816,11.999926,12.999971, 13.999988,14.999995,15.999998,16.999999) g <- y ## maximizing lambda essentially y above this g[ind] <- glo[y[ind]-1] ind <- y > 1 l[ind] <- zipll(y[ind],log(g[ind]),g[ind]*0+1e10,deriv=0)$l l } ## ls fp <- function(p,y) { ## compute zero related part of log likelihood eps <- .Machine$double.eps^.5 l1p <- if (p>eps) log(1-p) else -p - p^2/2 l1p*sum(y==0) + log(p)*sum(y>0) } ## fp flam <- function(lam,y) { ## compute >0 part of log likelihood y <- y[y>0] sum(y*log(lam) - log(exp(lam)-1) - lgamma(y+1)) } ## flam ## optimize zero repated part of likelihood w.r.t. p... lnull <- optimize(fp,interval=c(1e-60,1-1e-10),y=object$y,maximum=TRUE)$objective ## optimize >0 part for lambda... my <- mean(object$y[object$y>0]) lnull <- lnull + optimize(flam,interval=c(my/2,my*2),y=object$y,maximum=TRUE)$objective object$null.deviance <- 2*(sum(ls(object$y)) - lnull) }) ## postproc ll <- function(y,X,coef,wt,family,offset=NULL,deriv=0,d1b=0,d2b=0,Hp=NULL,rank=0,fh=NULL,D=NULL) { ## function defining the gamlss ZIP model log lik. ## First l.p. defines Poisson mean, given presence (lambda) ## Second l.p. defines probability of presence (p) ## deriv: 0 - eval ## 1 - grad and Hess ## 2 - diagonal of first deriv of Hess ## 3 - first deriv of Hess ## 4 - everything. if (is.null(offset)) offset <- list(0,0) else offset[[3]] <- 0 for (i in 1:2) if (is.null(offset[[i]])) offset[[i]] <- 0 jj <- attr(X,"lpi") ## extract linear predictor index eta <- X[,jj[[1]],drop=FALSE]%*%coef[jj[[1]]] + offset[[1]] lambda <- family$linfo[[1]]$linkinv(eta) eta1 <- X[,jj[[2]],drop=FALSE]%*%coef[jj[[2]]] +offset[[2]] p <- family$linfo[[2]]$linkinv(eta1) ##n <- length(y) ## l1 <- matrix(0,n,2) zl <- zipll(y,lambda,p,deriv) if (deriv>0) { ## need some link derivatives for derivative transform ig1 <- cbind(family$linfo[[1]]$mu.eta(eta),family$linfo[[2]]$mu.eta(eta1)) g2 <- cbind(family$linfo[[1]]$d2link(lambda),family$linfo[[2]]$d2link(p)) } ## l3 <- l4 <- g3 <- g4 <- 0 ## defaults if (deriv>1) { ## the third derivatives ## order lll,llp,lpp,ppp g3 <- cbind(family$linfo[[1]]$d3link(lambda),family$linfo[[2]]$d3link(p)) } if (deriv>3) { ## the fourth derivatives ## order llll,lllp,llpp,lppp,pppp g4 <- cbind(family$linfo[[1]]$d4link(lambda),family$linfo[[2]]$d4link(p)) } if (deriv) { i2 <- family$tri$i2; i3 <- family$tri$i3 i4 <- family$tri$i4 ## transform derivates w.r.t. mu to derivatives w.r.t. eta... de <- gamlss.etamu(zl$l1,zl$l2,zl$l3,zl$l4,ig1,g2,g3,g4,i2,i3,i4,deriv-1) ## get the gradient and Hessian... ret <- gamlss.gH(X,jj,de$l1,de$l2,i2,l3=de$l3,i3=i3,l4=de$l4,i4=i4, d1b=d1b,d2b=d2b,deriv=deriv-1,fh=fh,D=D) } else ret <- list() ret$l <- sum(zl$l); ret } ## end ll for ZIP initialize <- expression({ ## for ZIP ## Idea is to regress binarized y on model matrix for p. ## Then downweight any y=0 with p<0.5 and regress g(y) on ## the model matrix for lambda - don't drop as this may ## induce rank deficiency in model matrix! ## May be called in both gam.fit5 and initial.spg... ## note that appropriate E scaling ## for full calculation may be inappropriate for initialization ## which is basically penalizing something different here. ## best we can do here is to use E only as a regularizer. n <- rep(1, nobs) if (all.equal(y,round(y))!=TRUE) { stop("Non-integer response variables are not allowed with ziplss ") } if ((min(y)==0&&max(y)==1)) stop("Using ziplss for binary data makes no sense") ## should E be used unscaled or not?.. use.unscaled <- if (!is.null(attr(E,"use.unscaled"))) TRUE else FALSE if (is.null(start)) { jj <- attr(x,"lpi") start <- rep(0,ncol(x)) x1 <- x[,jj[[2]],drop=FALSE] e1 <- E[,jj[[2]],drop=FALSE] ## square root of total penalty yt1 <- as.numeric(as.logical(y)) ## binarized response if (use.unscaled) { qrx <- qr(rbind(x1,e1)) x1 <- rbind(x1,e1) startji <- qr.coef(qr(x1),c(yt1,rep(0,nrow(E)))) startji[!is.finite(startji)] <- 0 } else startji <- pen.reg(x1,e1,yt1) start[jj[[2]]] <- startji p <- drop(x1[1:nobs,,drop=FALSE] %*% startji) ## probability of presence ind <- y==0 & p < 0.5 ## downweight these for estimating lambda w <- rep(1,nobs); w[ind] <- .1 ## note assumption that working scale is log... yt1 <- family$linfo[[1]]$linkfun(log(abs(y)+(y==0)*.2)) yt1 <- yt1*w x1 <- w*x[,jj[[1]],drop=FALSE];e1 <- E[,jj[[1]],drop=FALSE] if (use.unscaled) { x1 <- rbind(x1,e1) startji <- qr.coef(qr(x1),c(yt1,rep(0,nrow(E)))) startji[!is.finite(startji)] <- 0 } else startji <- pen.reg(x1,e1,yt1) start[jj[[1]]] <- startji } }) ## initialize ziplss structure(list(family="ziplss",ll=ll,link=paste(link),nlp=2, tri = trind.generator(2), ## symmetric indices for accessing derivative arrays initialize=initialize,postproc=postproc,residuals=residuals,rd=rd,predict=predict, linfo = stats, ## link information list d2link=1,d3link=1,d4link=1, ## signals to fix.family.link that all done ls=1, ## signals that ls not needed here available.derivs = 2 ## can use full Newton here ),class = c("general.family","extended.family","family")) } ## ziplss gevlss <- function(link=list("identity","identity","logit")) { ## General family for GEV location scale model... ## so mu is mu1, rho = log(sigma) is mu2 and xi is mu3 ## 1. get derivatives wrt mu, rho and xi. ## 2. get required link derivatives and tri indices. ## 3. transform derivs to derivs wrt eta (gamlss.etamu). ## 4. get the grad and Hessian etc for the model ## via a call to gamlss.gH ## first deal with links and their derivatives... if (length(link)!=3) stop("gevlss requires 3 links specified as character strings") okLinks <- list(c("log", "identity"),"identity",c("identity","logit")) stats <- list() for (i in 1:3) { if (link[[i]] %in% okLinks[[i]]) stats[[i]] <- make.link(link[[i]]) else stop(link[[i]]," link not available for mu parameter of gaulss") fam <- structure(list(link=link[[i]],canonical="none",linkfun=stats[[i]]$linkfun, mu.eta=stats[[i]]$mu.eta), class="family") fam <- fix.family.link(fam) stats[[i]]$d2link <- fam$d2link stats[[i]]$d3link <- fam$d3link stats[[i]]$d4link <- fam$d4link } if (link[[3]]=="logit") { ## shifted logit link to confine xi to (-1,.5) ## Smith '85 Biometrika shows that -1 limit needed for MLE consistency ## but would need -0.5 for normality... stats[[3]]$linkfun <- function(mu) binomial()$linkfun((mu + 1)/1.5) stats[[3]]$mu.eta <- function(eta) binomial()$mu.eta(eta)*1.5 stats[[3]]$linkinv <- function(eta) 1.5* binomial()$linkinv(eta) - 1 stats[[3]]$d2link <- function(mu) { mu <- (mu+ 1)/1.5; (1/(1 - mu)^2 - 1/mu^2)/1.5^2} stats[[3]]$d3link <- function(mu) { mu <- (mu+ 1)/1.5; (2/(1 - mu)^3 + 2/mu^3)/1.5^3} stats[[3]]$d4link <- function(mu) { mu <- (mu+ 1)/1.5; (6/(1-mu)^4 - 6/mu^4)/1.5^4} } residuals <- function(object,type=c("deviance","pearson","response")) { mu <- object$fitted[,1] rho <- object$fitted[,2] xi <- object$fitted[,3] y <- object$y fv <- mu + exp(rho)*(gamma(1-xi)-1)/xi eps <- 1e-7; xi[xi>=0&xi-eps] <- -eps type <- match.arg(type) if (type=="deviance") { rsd <- (xi+1)/xi * log(1+(y-mu)*exp(-rho)*xi) + (1+(y-mu)*exp(-rho)*xi)^(-1/xi) + (1+xi)*log(1+xi) - (1 + xi) ## saturated part rsd <- sqrt(pmax(0,rsd))*sign(y-fv) } else if (type=="pearson") { sd <- exp(rho)/xi*sqrt(pmax(0,gamma(1-2*xi)-gamma(1-xi)^2)) rsd <- (y-fv)/sd } else { rsd <- y-fv } rsd } postproc <- expression({ ## code to evaluate in estimate.gam, to evaluate null deviance ## It's difficult to define a sensible version of this that ensures ## that the data fall in the support of the null model, whilst being ## somehow equivalent to the full fit object$null.deviance <- NA }) ll <- function(y,X,coef,wt,family,offset=NULL,deriv=0,d1b=0,d2b=0,Hp=NULL,rank=0,fh=NULL,D=NULL) { ## function defining the gamlss GEV model log lik. ## deriv: 0 - eval ## 1 - grad and Hess ## 2 - diagonal of first deriv of Hess ## 3 - first deriv of Hess ## 4 - everything. jj <- attr(X,"lpi") ## extract linear predictor index eta <- X[,jj[[1]],drop=FALSE]%*%coef[jj[[1]]] mu <- family$linfo[[1]]$linkinv(eta) ## mean etar <- X[,jj[[2]],drop=FALSE]%*%coef[jj[[2]]] ## log sigma rho <- family$linfo[[2]]$linkinv(etar) ## log sigma etax <- X[,jj[[3]],drop=FALSE]%*%coef[jj[[3]]] ## shape parameter xi <- family$linfo[[3]]$linkinv(etax) ## shape parameter ## Avoid xi == 0 - using a separate branch for xi==0 requires ## seperate treatment of derivative w.r.t. xi, and statistically ## brings us nothing. eps <- 1e-7 xi[xi>=0&xi-eps] <- -eps n <- length(y) l1 <- matrix(0,n,3) ## note that the derivative code is largely auto-generated, and ## auto-simplified. Optimized Maxima derivs exported as Maxima ## code, translated to R code in R, then processed in R to ## remove redundant auxiliary variables and their definitions. ## Modifications of auto code (but not the consequent substitutions) are ## flagged '## added'. Code post auto and non-auto modification has ## been tested against raw translated code. exp1 <- exp(1); ## facilitates lazy auto-translation aa0 <- (xi*(y-mu))/exp1^rho # added log.aa1 <- log1p(aa0) # added aa1 <- aa0 + 1 # (xi*(y-mu))/exp1^rho+1; aa2 <- 1/xi; l <- sum((-aa2*(1+xi)*log.aa1)-1/aa1^aa2-rho); if (deriv>0) { ## first derivatives m, r, x... bb1 <- 1/exp1^rho; bb2 <- bb1*xi*(y-mu)+1; l1[,1] <- (bb1*(xi+1))/bb2-bb1*bb2^((-1/xi)-1); cc2 <- y-mu; cc0 <- bb1*xi*cc2 ## added log.cc3 <- log1p(cc0) ## added cc3 <- cc0 + 1 ##bb1*xi*cc2+1; l1[,2] <- (-bb1*cc2*cc3^((-1/xi)-1))+(bb1*(xi+1)*cc2)/cc3-1; dd3 <- xi+1; dd6 <- 1/cc3; dd7 <- log.cc3; dd8 <- 1/xi^2; l1[,3] <- (-(dd8*dd7-bb1*aa2*cc2*dd6)/cc3^aa2)+dd8*dd3*dd7- aa2*dd7-bb1*aa2*dd3*cc2*dd6; ## the second derivatives mm mr mx rr rx xx l2 <- matrix(0,n,6) ee1 <- 1/exp1^(2*rho); ee3 <- -1/xi; l2[,1] <- ee1*(ee3-1)*xi*aa1^(ee3-2)+(ee1*xi*(xi+1))/aa1^2; ff7 <- ee3-1; l2[,2] <- bb1*cc3^ff7+ee1*ff7*xi*cc2*cc3^(ee3-2)-(bb1*dd3)/cc3+ (ee1*xi*dd3*cc2)/cc3^2; gg7 <- -aa2; l2[,3] <- (-bb1*cc3^(gg7-1)*(log.cc3/xi^2-bb1*aa2*cc2*dd6))+ ee1*cc2*cc3^(gg7-2)+bb1*dd6-(ee1*(xi+1)*cc2)/cc3^2; hh4 <- cc2^2; l2[,4] <- bb1*cc2*cc3^ff7+ee1*ff7*xi*hh4*cc3^(ee3-2)- (bb1*dd3*cc2)/cc3+(ee1*xi*dd3*hh4)/cc3^2; l2[,5] <- (-bb1*cc2*cc3^(gg7-1)*(log.cc3/xi^2-bb1*aa2*cc2*dd6))+ ee1*hh4*cc3^(gg7-2)+bb1*cc2*dd6-(ee1*(xi+1)*hh4)/cc3^2; jj08 <- 1/cc3^2; jj12 <- 1/xi^3; jj13 <- 1/cc3^aa2; l2[,6] <- (-jj13*(dd8*dd7-bb1*aa2*cc2*dd6)^2)-jj13*(ee1*aa2*hh4*jj08+ 2*bb1*dd8*cc2*dd6-2*jj12*dd7)-2*jj12*dd3*dd7+2*dd8*dd7+ 2*bb1*dd8*dd3*cc2*dd6-2*bb1*aa2*cc2*dd6+ee1*aa2*dd3*hh4*jj08; ## need some link derivatives for derivative transform ig1 <- cbind(family$linfo[[1]]$mu.eta(eta),family$linfo[[2]]$mu.eta(etar), family$linfo[[3]]$mu.eta(etax)) g2 <- cbind(family$linfo[[1]]$d2link(mu),family$linfo[[2]]$d2link(rho), family$linfo[[3]]$d2link(xi)) } l3 <- l4 <- g3 <- g4 <- 0 ## defaults if (deriv>1) { ## the third derivatives ## order mmm mmr mmx mrr mrx mxx rrr rrx rxx xxx l3 <- matrix(0,n,10) kk1 <- 1/exp1^(3*rho); kk2 <- xi^2; l3[,1] <- (2*kk1*kk2*(xi+1))/aa1^3-kk1*(ee3-2)*(ee3-1)*kk2*aa1^(ee3-3); ll5 <- (xi*cc2)/exp1^rho+1; ll8 <- ee3-2; l3[,2] <- (-2*ee1*ff7*xi*ll5^ll8)-kk1*ll8*ff7*kk2*cc2*ll5^(ee3-3)- (2*ee1*xi*dd3)/ll5^2+(2*kk1*kk2*dd3*cc2)/ll5^3; mm10 <- cc3^(gg7-3); mm11 <- gg7-2; mm12 <- cc3^mm11; l3[,3] <- ee1*(gg7-1)*xi*mm12*(log.cc3/xi^2-(bb1*aa2*cc2)/cc3)-ee1*mm12- kk1*mm11*xi*cc2*mm10+kk1*cc2*mm10+ee1*dd3*jj08+ee1*xi*jj08- (2*kk1*xi*dd3*cc2)/cc3^3; l3[,4] <- (-bb1*cc3^ff7)-3*ee1*ff7*xi*cc2*cc3^ll8-kk1*ll8*ff7*kk2*hh4* cc3^(ee3-3)+(bb1*dd3)/cc3-(3*ee1*xi*dd3*cc2)/cc3^2+ (2*kk1*kk2*dd3*hh4)/cc3^3; oo10 <- gg7-1; oo13 <- log.cc3/xi^2; l3[,5] <- bb1*cc3^oo10*(bb1*oo10*cc2*dd6+oo13)+ee1*oo10*xi*cc2*mm12* (bb1*mm11*cc2*dd6+oo13)+ee1*aa2*cc2*mm12+ee1*oo10*cc2*mm12- bb1*dd6+2*ee1*dd3*cc2*jj08+ee1*xi*cc2*jj08- (2*xi*dd3*cc2^2)/(exp1^(3*rho)*cc3^3); pp07 <- (-1/xi)-1; pp08 <- cc3^pp07; l3[,6] <- (-bb1*pp08*(bb1*pp07*cc2*dd6+dd8*dd7)^2)-bb1*pp08* ((-ee1*pp07*hh4*jj08)+2*bb1*dd8*cc2*dd6-(2*dd7)/xi^3)- 2*ee1*cc2*jj08+(2*(xi+1)*hh4)/(exp1^(3*rho)*cc3^3); qq05 <- cc2^3; l3[,7] <- (-bb1*cc2*cc3^ff7)-3*ee1*ff7*xi*hh4*cc3^ll8- kk1*ll8*ff7*kk2*qq05*cc3^(ee3-3)+(bb1*dd3*cc2)/cc3- (3*ee1*xi*dd3*hh4)/cc3^2+(2*kk1*kk2*dd3*qq05)/cc3^3; rr17 <- log.cc3/xi^2-bb1*aa2*cc2*dd6; l3[,8] <- bb1*cc2*cc3^oo10*rr17+ee1*oo10*xi*hh4*mm12*rr17-2*ee1*hh4*mm12- kk1*mm11*xi*qq05*mm10+kk1*qq05*mm10-bb1*cc2*dd6+ 2*ee1*dd3*hh4*jj08+ee1*xi*hh4*jj08-(2*kk1*xi*dd3*qq05)/cc3^3; l3[,9] <- (-bb1*cc2*pp08*(bb1*pp07*cc2*dd6+dd8*dd7)^2)-bb1*cc2*pp08* ((-ee1*pp07*hh4*jj08)+2*bb1*dd8*cc2*dd6-(2*dd7)/xi^3)- 2*ee1*hh4*jj08+(2*(xi+1)*cc2^3)/(exp1^(3*rho)*cc3^3); tt08 <- 1/cc3^3; tt16 <- 1/xi^4; tt18 <- dd8*dd7-bb1*aa2*cc2*dd6; l3[,10] <- (-jj13*tt18^3)-3*jj13*(ee1*aa2*hh4*jj08+2*bb1*dd8*cc2*dd6-2*jj12*dd7)* tt18-jj13*((-2*kk1*aa2*qq05*tt08)-3*ee1*dd8*hh4*jj08-6*bb1*jj12*cc2*dd6+ 6*tt16*dd7)+6*tt16*dd3*dd7-6*jj12*dd7-6*bb1*jj12*dd3*cc2*dd6+ 6*bb1*dd8*cc2*dd6-3*ee1*dd8*dd3*hh4*jj08+3*ee1*aa2*hh4*jj08- 2*kk1*aa2*dd3*qq05*tt08; g3 <- cbind(family$linfo[[1]]$d3link(mu),family$linfo[[2]]$d3link(rho), family$linfo[[3]]$d3link(xi)) } if (deriv>3) { ## the fourth derivatives ## mmmm mmmr mmmx mmrr mmrx mmxx mrrr mrrx mrxx mxxx ## rrrr rrrx rrxx rxxx xxxx l4 <- matrix(0,n,15) uu1 <- 1/exp1^(4*rho); uu2 <- xi^3; l4[,1] <- uu1*(ee3-3)*(ee3-2)*(ee3-1)*uu2*aa1^(ee3-4)+(6*uu1*uu2*(xi+1))/aa1^4; vv09 <- ee3-3; l4[,2] <- 3*kk1*ll8*ff7*kk2*ll5^vv09+uu1*vv09*ll8*ff7*uu2*cc2*ll5^(ee3-4)- (6*kk1*kk2*dd3)/ll5^3+(6*uu1*uu2*dd3*cc2)/ll5^4; ww11 <- gg7-3; ww12 <- cc3^(gg7-4); ww15 <- cc3^ww11; l4[,3] <- (-kk1*mm11*oo10*kk2*ww15*(log.cc3/kk2-(bb1*aa2*cc2)/cc3))+ 2*kk1*mm11*xi*ww15-kk1*ww15+uu1*ww11*mm11*kk2*cc2*ww12- uu1*oo10*xi*cc2*ww12-uu1*ww11*xi*cc2*ww12+2*kk1*kk2*tt08+ 4*kk1*xi*dd3*tt08-(6*uu1*kk2*dd3*cc2)/cc3^4; l4[,4] <- 4*ee1*ff7*xi*ll5^ll8+5*kk1*ll8*ff7*kk2*cc2*ll5^vv09+ uu1*vv09*ll8*ff7*uu2*hh4*ll5^(ee3-4)+(4*ee1*xi*dd3)/ll5^2- (10*kk1*kk2*dd3*cc2)/ll5^3+(6*uu1*uu2*dd3*hh4)/ll5^4; yy18 <- log.cc3/kk2; l4[,5] <- (-2*ee1*oo10*xi*mm12*(bb1*mm11*cc2*dd6+yy18))- kk1*mm11*oo10*kk2*cc2*ww15*(bb1*ww11*cc2*dd6+yy18)- 2*ee1*aa2*mm12-2*ee1*oo10*mm12-2*kk1*mm11*oo10*xi*cc2*ww15- kk1*oo10*cc2*ww15-kk1*mm11*cc2*ww15-2*ee1*dd3*jj08- 2*ee1*xi*jj08+2*kk1*kk2*cc2*tt08+8*kk1*xi*dd3*cc2*tt08- (6*kk2*dd3*cc2^2)/(exp1^(4*rho)*cc3^4); l4[,6] <- ee1*oo10*xi*mm12*tt18^2-2*ee1*mm12*tt18-2*kk1*mm11*xi*cc2*ww15*tt18+ 2*kk1*cc2*ww15*tt18+ee1*oo10*xi*mm12*(ee1*aa2*hh4*jj08+2*bb1* dd8*cc2*dd6-(2*dd7)/xi^3)+4*kk1*cc2*ww15+2*uu1*ww11*xi*hh4*ww12- 4*uu1*hh4*ww12+2*ee1*jj08-4*kk1*dd3*cc2*tt08-4*kk1*xi*cc2*tt08+ (6*uu1*xi*dd3*hh4)/cc3^4; l4[,7] <- bb1*cc3^ff7+7*ee1*ff7*xi*cc2*cc3^ll8+6*kk1*ll8*ff7*kk2*hh4*cc3^vv09+ uu1*vv09*ll8*ff7*uu2*qq05*cc3^(ee3-4)-(bb1*dd3)/cc3+ (7*ee1*xi*dd3*cc2)/cc3^2-(12*kk1*kk2*dd3*hh4)/cc3^3+ (6*uu1*uu2*dd3*qq05)/cc3^4; l4[,8] <- (-bb1*cc3^oo10*(bb1*oo10*cc2*dd6+yy18))-3*ee1*oo10*xi*cc2*mm12* (bb1*mm11*cc2*dd6+yy18)-kk1*mm11*oo10*kk2*hh4*ww15* (bb1*ww11*cc2*dd6+yy18)-3*ee1*aa2*cc2*mm12-3*ee1*oo10*cc2*mm12- 2*kk1*mm11*oo10*xi*hh4*ww15-kk1*oo10*hh4*ww15-kk1*mm11*hh4*ww15+ bb1*dd6-4*ee1*dd3*cc2*jj08-3*ee1*xi*cc2*jj08+2*kk1*kk2*hh4*tt08+ 10*kk1*xi*dd3*hh4*tt08-(6*kk2*dd3*cc2^3)/(exp1^(4*rho)*cc3^4); ad17 <- 2*bb1*dd8*cc2*dd6; ad19 <- -(2*dd7)/xi^3; ad20 <- cc3^oo10; ad21 <- dd8*dd7; ad22 <- ad21+bb1*mm11*cc2*dd6; l4[,9] <- bb1*ad20*(bb1*oo10*cc2*dd6+ad21)^2+ee1*oo10*xi*cc2*mm12*ad22^2+ 2*ee1*aa2*cc2*mm12*ad22+2*ee1*oo10*cc2*mm12*ad22+ bb1*ad20*((-ee1*oo10*hh4*jj08)+ad17+ad19)+ee1*oo10*xi*cc2*mm12* ((-ee1*mm11*hh4*jj08)+ad17+ad19)+4*ee1*cc2*jj08-6*kk1*dd3*hh4*tt08- 4*kk1*xi*hh4*tt08+(6*xi*dd3*cc2^3)/(exp1^(4*rho)*cc3^4); ae16 <- dd8*dd7+bb1*pp07*cc2*dd6; l4[,10] <- (-bb1*pp08*ae16^3)-3*bb1*pp08*((-ee1*pp07*hh4*jj08)+ 2*bb1*dd8*cc2*dd6-2*jj12*dd7)*ae16-bb1*pp08*(2*kk1*pp07*qq05*tt08- 3*ee1*dd8*hh4*jj08-6*bb1*jj12*cc2*dd6+(6*dd7)/xi^4)+6*kk1*hh4*tt08- (6*(xi+1)*qq05)/(exp1^(4*rho)*cc3^4); af05 <- cc2^4; l4[,11] <- bb1*cc2*cc3^ff7+7*ee1*ff7*xi*hh4*cc3^ll8+6*kk1*ll8*ff7*kk2*qq05* cc3^vv09+uu1*vv09*ll8*ff7*uu2*af05*cc3^(ee3-4)-(bb1*dd3*cc2)/cc3+ (7*ee1*xi*dd3*hh4)/cc3^2-(12*kk1*kk2*dd3*qq05)/cc3^3+ (6*uu1*uu2*dd3*af05)/cc3^4; ag23 <- log.cc3/kk2-bb1*aa2*cc2*dd6; l4[,12] <- (-bb1*cc2*cc3^oo10*ag23)-3*ee1*oo10*xi*hh4*mm12*ag23- kk1*mm11*oo10*kk2*qq05*ww15*ag23+4*ee1*hh4*mm12+ 5*kk1*mm11*xi*qq05*ww15-4*kk1*qq05*ww15+uu1*ww11*mm11*kk2*af05*ww12- uu1*oo10*xi*af05*ww12-uu1*ww11*xi*af05*ww12+bb1*cc2*dd6- 4*ee1*dd3*hh4*jj08-3*ee1*xi*hh4*jj08+2*kk1*kk2*qq05*tt08+ 10*kk1*xi*dd3*qq05*tt08-(6*uu1*kk2*dd3*af05)/cc3^4; ah24 <- (-(2*dd7)/xi^3)+2*bb1*dd8*cc2*dd6+ee1*aa2*hh4*jj08; ah27 <- tt18^2; l4[,13] <- bb1*cc2*ad20*ah27+ee1*oo10*xi*hh4*mm12*ah27-4*ee1*hh4*mm12*tt18- 2*kk1*mm11*xi*qq05*ww15*tt18+2*kk1*qq05*ww15*tt18+bb1*cc2*ad20*ah24+ ee1*oo10*xi*hh4*mm12*ah24+6*kk1*qq05*ww15+2*uu1*ww11*xi*af05*ww12- 4*uu1*af05*ww12+4*ee1*hh4*jj08-6*kk1*dd3*qq05*tt08- 4*kk1*xi*qq05*tt08+(6*uu1*xi*dd3*af05)/cc3^4; l4[,14] <- (-bb1*cc2*pp08*ae16^3)-3*bb1*cc2*pp08*((-ee1*pp07*hh4*jj08)+ 2*bb1*dd8*cc2*dd6-2*jj12*dd7)*ae16-bb1*cc2*pp08*(2*kk1*pp07*qq05* tt08-3*ee1*dd8*hh4*jj08-6*bb1*jj12*cc2*dd6+(6*dd7)/xi^4)+ 6*kk1*qq05*tt08-(6*(xi+1)*cc2^4)/(exp1^(4*rho)*cc3^4); aj08 <- 1/cc3^4; aj20 <- 1/xi^5; aj23 <- (-2*jj12*dd7)+2*bb1*dd8*cc2*dd6+ee1*aa2*hh4*jj08; l4[,15] <- (-jj13*tt18^4)-6*jj13*aj23*tt18^2-3*jj13*aj23^2- 4*jj13*((-2*kk1*aa2*qq05*tt08)-3*ee1*dd8*hh4*jj08-6*bb1*jj12*cc2*dd6+ 6*tt16*dd7)*tt18-jj13*(6*uu1*aa2*af05*aj08+8*kk1*dd8*qq05*tt08+ 12*ee1*jj12*hh4*jj08+24*bb1*tt16*cc2*dd6-24*aj20*dd7)- 24*aj20*dd3*dd7+24*tt16*dd7+24*bb1*tt16*dd3*cc2*dd6- 24*bb1*jj12*cc2*dd6+12*ee1*jj12*dd3*hh4*jj08-12*ee1*dd8*hh4*jj08+ 8*kk1*dd8*dd3*qq05*tt08-8*kk1*aa2*qq05*tt08+6*uu1*aa2*dd3*af05*aj08; g4 <- cbind(family$linfo[[1]]$d4link(mu),family$linfo[[2]]$d4link(rho), family$linfo[[3]]$d4link(xi)) } if (deriv) { i2 <- family$tri$i2; i3 <- family$tri$i3 i4 <- family$tri$i4 ## transform derivates w.r.t. mu to derivatives w.r.t. eta... de <- gamlss.etamu(l1,l2,l3,l4,ig1,g2,g3,g4,i2,i3,i4,deriv-1) ## get the gradient and Hessian... ret <- gamlss.gH(X,jj,de$l1,de$l2,i2,l3=de$l3,i3=i3,l4=de$l4,i4=i4, d1b=d1b,d2b=d2b,deriv=deriv-1,fh=fh,D=D) } else ret <- list() ret$l <- l; ret } ## end ll gevlss initialize <- expression({ ## start out with xi close to zero. If xi==0 then ## mean is mu + sigma*gamma and var is sigma^2*pi^2/6 ## where sigma = exp(rho) and gamma is Euler's constant. ## idea is to regress g(y) on model matrix for mean, and then ## to regress the corresponding log absolute residuals on ## the model matrix for log(sigma) - may be called in both ## gam.fit5 and initial.spg... note that appropriate E scaling ## for full calculation may be inappropriate for initialization ## which is basically penalizing something different here. ## best we can do here is to use E only as a regularizer. .euler <- 0.5772156649015328606065121 ## Euler's constant n <- rep(1, nobs) ## should E be used unscaled or not?.. use.unscaled <- if (!is.null(attr(E,"use.unscaled"))) TRUE else FALSE if (is.null(start)) { jj <- attr(x,"lpi") start <- rep(0,ncol(x)) yt1 <- if (family$link[[1]]=="identity") y else family$linfo[[1]]$linkfun(abs(y)+max(y)*1e-7) x1 <- x[,jj[[1]],drop=FALSE] e1 <- E[,jj[[1]],drop=FALSE] ## square root of total penalty #ne1 <- norm(e1); if (ne1==0) ne1 <- 1 if (use.unscaled) { qrx <- qr(rbind(x1,e1)) x1 <- rbind(x1,e1) startji <- qr.coef(qr(x1),c(yt1,rep(0,nrow(E)))) startji[!is.finite(startji)] <- 0 } else startji <- pen.reg(x1,e1,yt1) start[jj[[1]]] <- startji lres1 <- log(abs(y-family$linfo[[1]]$linkinv(x[,jj[[1]],drop=FALSE]%*%start[jj[[1]]]))) x1 <- x[,jj[[2]],drop=FALSE];e1 <- E[,jj[[2]],drop=FALSE] #ne1 <- norm(e1); if (ne1==0) ne1 <- 1 if (use.unscaled) { x1 <- rbind(x1,e1) startji <- qr.coef(qr(x1),c(lres1,rep(0,nrow(E)))) startji[!is.finite(startji)] <- 0 } else startji <- pen.reg(x1,e1,lres1) start[jj[[2]]] <- startji x1 <- x[,jj[[3]],drop=FALSE] startji <- qr.coef(qr(x1),c(rep(family$linfo[[3]]$linkfun(1e-3),nrow(x1)))) startji[!is.finite(startji)] <- 0 start[jj[[3]]] <- startji } }) ## initialize gevlss structure(list(family="gevlss",ll=ll,link=paste(link),nlp=3, tri = trind.generator(3), ## symmetric indices for accessing derivative arrays initialize=initialize,postproc=postproc,residuals=residuals, linfo = stats, ## link information list d2link=1,d3link=1,d4link=1, ## signals to fix.family.link that all done ls=1, ## signals that ls not needed here available.derivs = 2 ## can use full Newton here ),class = c("general.family","extended.family","family")) } ## end gevlss mgcv/R/gam.sim.r0000744000177400001440000000727612643436060013340 0ustar murdochusers ## Example simulated data for gam.models (c) Simon N. Wood 2008 gamSim <- function(eg=1,n=400,dist="normal",scale=2,verbose=TRUE) { if (eg==1||eg==7) { ## 4 term Gu and Wahba example if (eg==1) { if (verbose) cat("Gu & Wahba 4 term additive model\n") } else { if (verbose) cat("Gu & Wahba 4 term additive model, correlated predictors\n")} x0 <- runif(n, 0, 1) if (eg==7) x1 <- x0*.7 + runif(n, 0, .3) else x1 <- runif(n,0,1) x2 <- runif(n, 0, 1) if (eg==7) x3 <- x2*.9 + runif(n,0,.1) else x3 <- runif(n, 0, 1) f0 <- function(x) 2 * sin(pi * x) f1 <- function(x) exp(2 * x) f2 <- function(x) 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 f3 <- function(x) 0*x f <- f0(x0) + f1(x1) + f2(x2) if (dist=="normal") { e <- rnorm(n, 0, scale) y <- f + e } else if (dist=="poisson") { g<-exp(f*scale) f <- log(g) ## true linear predictor y<-rpois(rep(1,n),g) } else if (dist=="binary") { f <- (f-5)*scale g <- binomial()$linkinv(f) y <- rbinom(g,1,g) } else stop("dist not recognised") data <- data.frame(y=y,x0=x0,x1=x1,x2=x2,x3=x3,f=f,f0=f0(x0),f1=f1(x1),f2=f2(x2),f3=x3*0) return(data) } else if (eg==2) { ## Simple 2D smoothing example if (verbose) cat("Bivariate smoothing example\n") test1<-function(x,z,sx=0.3,sz=0.4) { (pi**sx*sz)*(1.2*exp(-(x-0.2)^2/sx^2-(z-0.3)^2/sz^2)+ 0.8*exp(-(x-0.7)^2/sx^2-(z-0.8)^2/sz^2)) } x <- runif(n);z <- runif(n); xs<-seq(0,1,length=40);zs<-seq(0,1,length=40) pr <- data.frame(x=rep(xs,40),z=rep(zs,rep(40,40))) truth <- matrix(test1(pr$x,pr$z),40,40) f <- test1(x,z) y <- f + rnorm(n)*scale data <- data.frame(y=y,x=x,z=z,f=f) truth <- list(x=xs,z=zs,f=truth) return(list(data=data,truth=truth,pr=pr)) } else if (eg==3) { ## continuous `by' variable if (verbose) cat("Continuous `by' variable example\n") x1 <- runif(n, 0, 1) x2 <- sort(runif(n, 0, 1)) f <- 0.2 * x2^11 * (10 * (1 - x2))^6 + 10 * (10 * x2)^3 * (1 - x2)^10 e <- rnorm(n, 0, scale) # A continuous `by' variable example.... y <- f*x1 + e return(data.frame(y=y,x1=x1,x2=x2,f=f)) } else if (eg==4) { ## factor `by' variable if (verbose) cat("Factor `by' variable example\n") x0 <- runif(n, 0, 1) x1 <- runif(n, 0, 1) x2 <- runif(n, 0, 1) f1 <- 2 * sin(pi * x2) f2 <- exp(2 * x2) - 3.75887 f3 <- 0.2 * x2^11 * (10 * (1 - x2))^6 + 10 * (10 * x2)^3 * (1 - x2)^10 e <- rnorm(n, 0, scale) fac<-as.factor(sample(1:3,n,replace=TRUE)) fac.1<-as.numeric(fac==1);fac.2<-as.numeric(fac==2); fac.3<-as.numeric(fac==3) y<-f1*fac.1+f2*fac.2+f3*fac.3+ e return(data.frame(y=y,x0=x0,x1=x1,x2=x2,fac=fac,f1=f1,f2=f2,f3=f3)) } else if (eg==5) { ## additive + factor if (verbose) cat("Additive model + factor\n") x0 <- rep(1:4,50) x1 <- runif(n, 0, 1) x2 <- runif(n, 0, 1) x3 <- runif(n, 0, 1) y <- 2 * x0 y <- y + exp(2 * x1) y <- y + 0.2 * x2^11 * (10 * (1 - x2))^6 + 10 * (10 * x2)^3 * (1 - x2)^10 e <- rnorm(n, 0, scale) y <- y + e x0<-as.factor(x0) return(data.frame(y=y,x0=x0,x1=x1,x2=x2,x3=x3)) } else if (eg==6) { ## Gu and Wahba + a random factor if (verbose) cat("4 term additive + random effect") dat <- gamSim(1,n=n,scale=0) fac <- rep(1:4,n/4) dat$f <- dat$f + fac*3 dat$fac<-as.factor(fac) if (dist=="normal") { dat$y <- dat$f + rnorm(n)*scale } else if (dist=="poisson") { g <- exp(dat$f*scale) dat$y <- rpois(rep(1,n),g) } else if (dist=="binary") { g <- (dat$f-5)*scale g <- binomial()$linkinv(g) dat$y <- rbinom(g,1,g) } return(dat) } } mgcv/R/sparse.r0000644000177400001440000003534412467135674013311 0ustar murdochusers## (c) Simon N. Wood 2011-2013 ## functions for sparse smoothing. tri2nei <- function(T) { ## Each row of matrix T gives the indices of the points making up ## one triangle in d dimensions. T has d+1 columns. This routine ## finds the neighbours of each point in that triangulation. ## indices start at 1. n <- max(T) oo <- .C(C_tri2nei,T=as.integer(cbind(T-1,T*0)),as.integer(nrow(T)), as.integer(n),as.integer(ncol(T)-1),off=as.integer(rep(0,n))); ## ni[1:off[1]] gives neighbours of point 1. ## ni[(off[i-1]+1):off[i]] give neighbours of point i>1 return(list(ni = oo$T[1:oo$off[n]]+1,off=oo$off)) } tri.pen <- function(X,T) { ## finds a sparse approximate TPS penalty, based on the points in X, ## with triangulation T. Rows of X are points. Rows of T index vertices ## of triangles in X. nn <- tri2nei(T) ## get neighbour list from T ## now obtain generalized FD penalty... n <- nrow(X);d <- ncol(X); D <- rep(0,3*(nn$off[n]+n)) ## storage for oo <- .C(C_nei_penalty,as.double(X),as.integer(n),as.integer(d),D=as.double(D), ni=as.integer(nn$ni-1),ii=as.integer(nn$ni*0),off=as.integer(nn$off), as.integer(2),as.integer(0),kappa=as.double(rep(0,n))); ## unpack into sparse matrices... ni <- oo$off[n] ii <- c(1:n,oo$ii[1:ni]+1) ## row index jj <- c(1:n,oo$ni[1:ni]+1) ## col index ni <- length(ii) Kx <- sparseMatrix(i=ii,j=jj,x=oo$D[1:ni],dims=c(n,n)) Kz <- sparseMatrix(i=ii,j=jj,x=oo$D[1:ni+ni],dims=c(n,n)) Kxz <- sparseMatrix(i=ii,j=jj,x=oo$D[1:ni+2*ni],dims=c(n,n)) list(Kx=Kx,Kz=Kz,Kxz=Kxz) } ## Efficient stable full rank cubic spline routines, based on ## deHoog and Hutchinson, 1987 and Hutchinson and deHoog, ## 1985.... setup.spline <- function(x,w=rep(1,length(x)),lambda=1,tol=1e-9) { ## setup a cubic smoothing spline given data locations in x. ## ties will be treated by removing duplicate x's, and averaging corresponding ## y's. Averaging is \sum_i y_i w_i^2 / \sum_i w_i^2, and the weight ## assigned to this average is then w_a^2 = \sum_i w_i^2... ## spline object has to record duplication information, as well as ## rotations defining spline. n <- length(x) ind <- order(x) x <- x[ind] ## sort x w <- w[ind] U <- V <- rep(0,4*n) diagA <- rep(0,n) lb <- rep(0,2*n) oo <- .C(C_sspl_construct,as.double(lambda),x=as.double(x),w=as.double(w),U=as.double(U),V=as.double(V), diagA=as.double(diagA),lb=as.double(lb),n=as.integer(n),tol=as.double(tol)) list(trA=sum(oo$diagA), ## trace of influence matrix U=oo$U,V=oo$V, ## spline defining Givens rotations lb=oo$lb, ## final lower band x=x, ## original x sequence, ordered ind=ind, ## x0 <- x; x0[ind] <- x, puts original ordering in x0 w=w, ## original weights ns=oo$n, ## number of unique x values (maximum spline rank) tol=tol) ## tolerance used to judge tied x values } apply.spline <- function(spl,y) { ## Use cubic spline object spl, from setup.spline, to smooth data in y. if (is.matrix(y)) { m <- ncol(y) y <- y[spl$ind,] ## order as x } else { m <- 1 y <- y[spl$ind] } n <- length(spl$x) oo <- .C(C_sspl_mapply,f = as.double(y),x=as.double(spl$x),as.double(spl$w), U=as.double(spl$U),as.double(spl$V),n=as.integer(spl$ns), nf=as.integer(n),tol=as.double(spl$tol),m=as.integer(m)) if (is.matrix(y)) { y <- matrix(oo$f,n,m) y[spl$ind,] <- y ## original order } else { y[spl$ind] <- oo$f } y } ## kd tree/k nearest neighbout related routines.... kd.vis <- function(kd,X,cex=.5) { ## code visualizes a kd tree for points in rows of X ## kd <- kd.tree(X) produces correct tree. if (ncol(X)!=2) stop("only deals with 2D case") ##n <- nrow(X) d <- ncol(X) nb <- kd$idat[1] dd <- matrix(kd$ddat[-1],nb,2*d,byrow=TRUE) lo <- dd[,1:d];hi <- dd[,1:d+d] rm(dd) ll <- min(X[,1]); ul<- max(X[,1]) w <- ul-ll ind <- lo[,1] < ll-w/10;lo[ind,1] <- ll-w/10 ind <- hi[,1] > ul+w/10;hi[ind,1] <- ul+w/10 ll <- min(X[,2]);ul <- max(X[,2]) w <- ul-ll ind <- lo[,2] < ll-w/10;lo[ind,2] <- ll-w/10 ind <- hi[,2] > ul+w/10;hi[ind,2] <- ul+w/10 plot(X[,1],X[,2],pch=19,cex=cex,col=2) for (i in 1:nb) { rect(lo[i,1],lo[i,2],hi[i,1],hi[i,2]) } #points(X[,1],X[,2],pch=19,cex=cex,col=2) } nearest <- function(k,X,gt.zero = FALSE,get.a=FALSE) { ## The rows of X contain coordinates of points. ## For each point, this routine finds its k nearest ## neighbours, returning a list of 2, n by k matrices: ## ni - ith row indexes the rows of X containing ## the k nearest neighbours of X[i,] ## dist - ith row is the distances to the k nearest ## neighbours. ## a - area associated with each point, if get.a is TRUE ## ties are broken arbitrarily. ## gt.zero indicates that neighbours must have distances greater ## than zero... if (gt.zero) { Xu <- uniquecombs(X);ind <- attr(Xu,"index") ## Xu[ind,] == X } else { Xu <- X; ind <- 1:nrow(X)} if (k>nrow(Xu)) stop("not enough unique values to find k nearest") nobs <- length(ind) n <- nrow(Xu) d <- ncol(Xu) dist <- matrix(0,n,k) if (get.a) a <- 1:n else a=1 oo <- .C(C_k_nn,Xu=as.double(Xu),dist=as.double(dist),a=as.double(a),ni=as.integer(dist), n=as.integer(n),d=as.integer(d),k=as.integer(k),get.a=as.integer(get.a)) dist <- matrix(oo$dist,n,k)[ind,] rind <- 1:nobs rind[ind] <- 1:nobs ni <- matrix(rind[oo$ni+1],n,k)[ind,] if (get.a) a=oo$a[ind] else a <- NULL list(ni=ni,dist=dist,a=a) } # nearest kd.tree <- function(X) { ## function to obtain kd tree for points in rows of X n <- nrow(X) ## number of points d <- ncol(X) ## dimension of points ## compute the number of boxes in the kd tree, nb m <- 2;while (m < n) m <- m* 2; nb = n * 2 - m %/% 2 - 1; if (nb > m-1) nb = m - 1; ## compute the storage requirements for the tree nd = 1 + d * nb * 2 ## number of doubles ni = 3 + 5 * nb + 2*n ## number of integers oo <- .C(C_Rkdtree,as.double(X),as.integer(n),as.integer(d),idat = as.integer(rep(0,ni)), ddat = as.double(rep(0,nd))) list(idat=oo$idat,ddat=oo$ddat) } kd.nearest <- function(kd,X,x,k) { ## given a set of points in rows of X, and corresponding kd tree, kd ## (produced by a call to kd.tree(X)), then this routine finds the ## k nearest neighbours in X, to the points in the rows of x. ## outputs: ni[i,] lists k nearest neighbours of X[i,]. ## dost[i,] is distance to those neighbours. ## note R indexing of output n <- nrow(X) m <- nrow(x) ni <- matrix(0,m,k) oo <- .C(C_Rkdnearest,as.double(X),as.integer(kd$idat),as.double(kd$ddat),as.integer(n),as.double(x), as.integer(m), ni=as.integer(ni), dist=as.double(ni),as.integer(k)) list(ni=matrix(oo$ni+1,m,k),dist=matrix(oo$dist,m,k)) } kd.radius <- function(kd,X,x,r) { ## find all points in kd tree (kd,X) in radius r of points in x. ## kd should come from kd.tree(X). ## neighbours of x[i,] in X are the rows given by ni[off[i]:(off[i+1]-1)] m <- nrow(x); off <- rep(0,m+1) ## do the work... oo <- .C(C_Rkradius,as.double(r),as.integer(kd$idat),as.double(kd$ddat),as.double(X),as.double(t(x)), as.integer(m),off=as.integer(off),ni=as.integer(0),op=as.integer(0)) off <- oo$off ni <- rep(0,off[m+1]) ## extract to R and clean up... oo <- .C(C_Rkradius,as.double(r),as.integer(kd$idat),as.double(kd$ddat),as.double(X),as.double(t(x)), as.integer(m),off=as.integer(off),ni=as.integer(ni),op=as.integer(1)) list(off=off+1,ni=oo$ni+1) ## note R indexing here. } ## kd.radius tieMatrix <- function(x) { ## takes matrix x, and produces sparse matrix P that maps list of unique ## rows to full set. Matrix of unique rows is returned in xu. ## If a smoothing penalty matrix, S, is set up based on rows of xu, ## then P%*%solve(t(P)%*%P + S,t(P)) is hat matrix. x <- as.matrix(x) n <- nrow(x) xu <- uniquecombs(x) if (nrow(xu)==nrow(x)) return(NULL) ind <- attr(xu,"index") x <- as.matrix(x) n <- nrow(x) P <- sparseMatrix(i=1:n,j=ind,x=rep(1,n),dims=c(n,nrow(xu))) return(list(P=P,xu=xu)) } ## sparse smooths must be initialized with... ## 1. a set of variable names, a blocking factor and a type. ######################################################### # routines for full rank cubic spline smoothers, based on # deHoog and Hutchinson, 1987. ######################################################### spasm.construct.cus <- function(object,data) { ## entry object inherits from "cus" & contains: ## * terms, the name of the argument of the smooth ## * block, the name of a blocking factor. Can be NULL. ## return object also has... ## * nobs - number of observations in total ## * nblock - number of blocks. ## * ind, list where ind[[i]] gives rows to which block i applies. ## * spl, and empty list which will contain intialised cubic ## spline smoothers for each block, once a smoothing parameter ## has been supplied... ##dat <- list() d <- length(object$terms) if (d != 1) stop("cubic spline only deals with 1D data") object$x <- get.var(object$term[1],data) object$nobs <- length(object$x) ind <- list() n <- length(object$x) ## if there is a blocking factor then set up indexes ## indicating which data go with which block... if (!is.null(object$block)) { block <- as.factor(get.var(object$block,data)) nb <- length(levels(block)) edf1 <- 0 for (i in 1:nb) { ind[[i]] <- (1:n)[block==levels(block)[i]] edf1 <- edf1 + length(unique(object$x[ind[[i]]])) ## max edf for this block } } else { ## all one block nb <- 1 ind[[1]] <- 1:n edf1 <- length(unique(object$x)) } object$nblock <- nb object$ind <- ind ## so ind[[i]] indexes the elements operated on by the ith smoother. object$spl <- list() object$edf0 <- 2*nb;object$edf1 <- edf1 class(object) <- "cus" object } spasm.sp.cus <- function(object,sp,w=rep(1,object$nobs),get.trH=FALSE,block=0,centre=FALSE) { ## Set up full cubic spline smooth, given new smoothing parameter and weights. ## In particular, construct the Givens rotations defining the ## smooth and compute the trace of the influence matrix. ## If block is non-zero, then it specifies which block to set up, otherwise ## all are set up. In either case w is assumed to be for the whole smoother, ## although only the values for the specified block(s) are used. ## If centre == TRUE then the spline is set up for centred smoothing, i.e. ## the results sum to zero. ## Note: w propto 1/std.dev(response) if (is.null(object$spl)) stop("object not fully initialized") trH <- 0 if (block==0) block <- 1:object$nblock for (i in block) { ##n <- length(object$ind[[i]]) object$spl[[i]] <- setup.spline(object$x[object$ind[[i]]],w=w[object$ind[[i]]],lambda=sp) trH <- trH + object$spl[[i]]$trA } object$sp=sp if (get.trH) { if (centre) { ## require correction for DoF lost by centring... for (i in block) { one <- rep(1,length(object$ind[[i]])) object$centre <- FALSE trH <- trH - mean(spasm.smooth(object,one,block=i)) } } object$trH <- trH } object$centre <- centre object } spasm.smooth.cus <- function(object,X,residual=FALSE,block=0) { ## apply smooth, or its residual operation to X. ## if block == 0 then apply whole thing, otherwise X must have the correct ## number of rows for the smooth block. if (block>0) { ## n <- length(object$ind[[block]]) if (object$centre) { X0 <- apply.spline(object$spl[[block]],X) if (is.matrix(X0)) { x0 <- colMeans(X0) X0 <- sweep(X0,2,x0) } else X0 <- X0 - mean(X0) if (residual) X <- X - X0 else X <- X0 } else { if (residual) X <- X - apply.spline(object$spl[[block]],X) else X <- apply.spline(object$spl[[block]],X) } } else for (i in 1:object$nblock) { ## work through all blocks ind <- object$ind[[i]] if (is.matrix(X)) { X0 <- apply.spline(object$spl[[i]],X[ind,]) if (object$centre) X0 <- sweep(X0,2,colMeans(X0)) if (residual) X[ind,] <- X[ind,] - X0 else X[ind,] <- X0 } else { X0 <- apply.spline(object$spl[[i]],X[ind]) if (object$centre) X0 <- X0 - mean(X0) if (residual) X[ind] <- X[ind] - X0 else X[ind] <- X0 } } X } ######################################################### ## The default sparse smooth class, which does nothing... ######################################################### spasm.construct.default <- function(object,data) { ## This smooth simply returns 0, under all circumstances. ## object might contain.... ## * block, the name of a blocking factor. Can be NULL. ## return object also has... ## * nblock - number of blocks. ## * ind, list where ind[[i]] gives rows to which block i applies. n <- nrow(data) if (!is.null(object$block)) { block <- as.factor(get.var(object$block,data)) nb <- length(levels(block)) for (i in 1:nb) { ind[[i]] <- (1:n)[block==levels(block)[i]] } } else { ## all one block nb <- 1 ind[[1]] <- 1:n } object$nblock <- nb object$ind <- ind ## so ind[[i]] indexes the elements operated on by the ith smoother. class(object) <- "default" object } spasm.sp.default <- function(object,sp,get.trH=FALSE) { ## Set up default null smoother. i.e. set trH=0, trH <- 0 if (get.trH) object$trH <- trH object$ldetH <- NA object } spasm.smooth.default <- function(object,X,residual=FALSE,block=0) { ## apply smooth, or its residual operation to X. ## if block == 0 then apply whole thing, otherwise X must have the correct ## number of rows for the smooth block. if (residual) return(X) else return(X*0) X } ## generics for sparse smooth classes... spasm.construct <- function(object,data) UseMethod("spasm.construct") spasm.sp <- function(object,sp,w=rep(1,object$nobs),get.trH=TRUE,block=0,centre=FALSE) UseMethod("spasm.sp") ## Note that w is assumed proportional to 1/std.dev(response) spasm.smooth <- function(object,X,residual=FALSE,block=0) UseMethod("spasm.smooth") spasm.range <- function(object,upper.prop=.5,centre=TRUE) { ## get reasonable smoothing parameter range for sparse smooth in object sp <- 1 edf <- spasm.sp(object,sp,get.trH=TRUE,centre=centre)$trH while (edf < object$edf0*1.01+.5) { sp <- sp /100 edf <- spasm.sp(object,sp,get.trH=TRUE,centre=centre)$trH } sp1 <- sp ## store smallest known good while (edf > object$edf0*1.01+.5) { sp <- sp * 100 edf <- spasm.sp(object,sp,get.trH=TRUE,centre=centre)$trH } sp0 <- sp while (edf < object$edf1*upper.prop) { sp1 <- sp1 / 100 edf <- spasm.sp(object,sp1,get.trH=TRUE,centre=centre)$trH } while (edf > object$edf1*upper.prop) { sp1 <- sp1 * 4 edf <- spasm.sp(object,sp1,get.trH=TRUE,centre=centre)$trH } c(sp1,sp0) ## small, large } mgcv/R/mgcv.r0000755000177400001440000055267713044377727012767 0ustar murdochusers## R routines for the package mgcv (c) Simon Wood 2000-2016 ## With contributions from Henric Nilsson Rrank <- function(R,tol=.Machine$double.eps^.9) { ## Finds rank of upper triangular matrix R, by estimating condition ## number of upper rank by rank block, and reducing rank until this is ## acceptably low... assumes R pivoted rank <- m <- ncol(R) ok <- TRUE while (ok) { Rcond <- .C(C_R_cond,R=as.double(R),r=as.integer(m),c=as.integer(rank), work=as.double(rep(0,4*m)),Rcond=as.double(1))$Rcond if (Rcond*tol<1) ok <- FALSE else rank <- rank - 1 } rank } slanczos <- function(A,k=10,kl=-1,tol=.Machine$double.eps^.5,nt=1) { ## Computes truncated eigen decomposition of symmetric A by ## Lanczos iteration. If kl < 0 then k largest magnitude ## eigenvalues returned, otherwise k highest and kl lowest. ## Eigenvectors are always returned too. ## set.seed(1);n <- 1000;A <- matrix(runif(n*n),n,n);A <- A+t(A);er <- slanczos(A,10) ## um <- eigen(A,symmetric=TRUE);ind <- c(1:5,(n-5+1):n) ## range(er$values-um$values[ind]);range(abs(er$vectors)-abs(um$vectors[,ind])) ## It seems that when k (or k+kl) is beyond 10-15% of n ## then you might as well use eigen(A,symmetric=TRUE), but the ## extra cost is the expensive accumulation of eigenvectors. ## Should re-write whole thing using LAPACK routines for eigenvectors. if (tol<=0||tol>.01) stop("silly tolerance supplied") k <- round(k);kl <- round(kl) if (k<0) stop("argument k must be positive.") m <- k + max(0,kl) n <- nrow(A) if (m<1) return(list(values=rep(0,0),vectors=matrix(0,n,0),iter=0)) if (n != ncol(A)) stop("A not square") if (m>n) stop("Can not have more eigenvalues than nrow(A)") oo <- .C(C_Rlanczos,A=as.double(A),U=as.double(rep(0,n*m)),D=as.double(rep(0,m)), n=as.integer(n),m=as.integer(k),ml=as.integer(kl),tol=as.double(tol),nt=as.integer(nt)) list(values = oo$D,vectors = matrix(oo$U,n,m),iter=oo$n) } rig <- function(n,mean,scale) { ## inverse guassian deviates generated by algorithm 5.7 of ## Gentle, 2003. scale = 1/lambda. if (length(n)>1) n <- length(n) x <- y <- rnorm(n)^2 mys <- mean*scale*y mu <- 0*y + mean ## y is there to ensure mu is a vector mu2 <- mu^2; ind <- mys < .Machine$double.eps^-.5 ## cut off for tail computation x[ind] <- mu[ind]*(1 + 0.5*(mys[ind] - sqrt(mys[ind]*4+mys[ind]^2))) x[!ind] <- mu[!ind]/mys[!ind] ## tail term (derived from Taylor of sqrt(1+eps) etc) #my <- mean*y; sc <- 0*y + scale #ind <- my > 1 ## cancellation error can be severe, without splitting #x[!ind] <- mu[!ind]*(1 + 0.5*sc[!ind]*(my[!ind] - sqrt(4*my[!ind]/sc[!ind] + my[!ind]^2))) ## really the sqrt in the next term should be expanded beyond first order and then ## worked on - otherwise too many exact zeros? #x[ind] <- pmax(0,mu[ind]*(1+my[ind]*.5*sc[ind]*(1-sqrt(1+ 4/(sc[ind]*my[ind]))))) ind <- runif(n) > mean/(mean+x) x[ind] <- mu2[ind]/x[ind] x ## E(x) = mean; var(x) = scale*mean^3 } strip.offset <- function(x) # sole purpose is to take a model frame and rename any "offset(a.name)" # columns "a.name" { na <- names(x) for (i in 1:length(na)) { if (substr(na[i],1,7)=="offset(") na[i] <- substr(na[i],8,nchar(na[i])-1) } names(x) <- na x } pcls <- function(M) # Function to perform penalized constrained least squares. # Problem to be solved is: # # minimise ||W^0.5 (y - Xp)||^2 + p'Bp # subject to Ain p >= b & C p = "constant" # # where B = \sum_{i=1}^m \theta_i S_i and W=diag(w) # on entry this routine requires a list M, with the following elements: # M$X - the design matrix for this problem. # M$p - a feasible initial parameter vector - note that this should not be set up to # lie exactly on all the inequality constraints - which can easily happen if M$p=0! # M$y - response variable # M$w - weight vector: W= diag(M$w) # M$Ain - matrix of inequality constraints # M$bin - b above # M$C - fixed constraint matrix # M$S - List of (minimal) penalty matrices # M$off - used for unpacking M$S # M$sp - array of theta_i's # Ain, bin and p are not in the object needed to call mgcv.... # { nar<-c(length(M$y),length(M$p),dim(M$Ain)[1],dim(M$C)[1],0) H<-0 ## sanity checking ... if (nrow(M$X)!=nar[1]) stop("nrow(M$X) != length(M$y)") if (ncol(M$X)!=nar[2]) stop("ncol(M$X) != length(M$p)") if (length(M$w)!=nar[1]) stop("length(M$w) != length(M$y)") if (nar[3]!=length(M$bin)) stop("nrow(M$Ain) != length(M$bin)") if (nrow(M$Ain)>0) { if (ncol(M$Ain)!=nar[2]) stop("nrow(M$Ain) != length(M$p)") res <- as.numeric(M$Ain%*%M$p) - as.numeric(M$bin) if (sum(res<0)>0) stop("initial parameters not feasible") res <- abs(res) if (sum(res<.Machine$double.eps^.5)>0) warning("initial point very close to some inequality constraints") res <- mean(res) if (res<.Machine$double.eps^.5) warning("initial parameters very close to inequality constraints") } if (nrow(M$C)>0) if (ncol(M$C)!=nar[2]) stop("ncol(M$C) != length(M$p)") if (length(M$S)!=length(M$off)) stop("M$S and M$off have different lengths") if (length(M$S)!=length(M$sp)) stop("M$sp has different length to M$S and M$off") # pack the S array for mgcv call m<-length(M$S) Sa<-array(0,0);df<-0 if (m>0) for (i in 1:m) { Sa<-c(Sa,M$S[[i]]) df[i]<-nrow(M$S[[i]]) if (M$off[i]+df[i]-1>nar[2]) stop(gettextf("M$S[%d] is too large given M$off[%d]", i, i)) } qra.exist <- FALSE if (ncol(M$X)>nrow(M$X)) { if (m>0) stop("Penalized model matrix must have no more columns than rows") else { ## absorb M$C constraints qra <- qr(t(M$C)) j <- nrow(M$C);k <- ncol(M$X) M$X <- t(qr.qty(qra,t(M$X))[(j+1):k,]) M$Ain <- t(qr.qty(qra,t(M$Ain))[(j+1):k,]) M$C <- matrix(0,0,0) M$p <- rep(0,ncol(M$X)) nar[2] <- length(M$p) nar[4] <- 0 qra.exist <- TRUE if (ncol(M$X)>nrow(M$X)) stop("Model matrix not full column rank") } } o<-.C(C_RPCLS,as.double(M$X),as.double(M$p),as.double(M$y),as.double(M$w),as.double(M$Ain),as.double(M$bin) ,as.double(M$C),as.double(H),as.double(Sa),as.integer(M$off),as.integer(df),as.double(M$sp), as.integer(length(M$off)),as.integer(nar)) p <- array(o[[2]],length(M$p)) if (qra.exist) p <- qr.qy(qra,c(rep(0,j),p)) p } ## pcls all.vars1 <- function(form) { ## version of all.vars that doesn't split up terms like x$y into x and y vars <- all.vars(form) vn <- all.names(form) vn <- vn[vn%in%c(vars,"$","[[")] ## actual variable related names if ("[["%in%vn) stop("can't handle [[ in formula") ii <- which(vn%in%"$") ## index of '$' if (length(ii)) { ## assemble variable names vn1 <- if (ii[1]>1) vn[1:(ii[1]-1)] go <- TRUE k <- 1 while (go) { n <- 2; while(k 0) { # start the replacement formulae response <- as.character(attr(tf,"variables")[2]) } else { response <- NULL } sp <- attr(tf,"specials")$s # array of indices of smooth terms tp <- attr(tf,"specials")$te # indices of tensor product terms tip <- attr(tf,"specials")$ti # indices of tensor product pure interaction terms t2p <- attr(tf,"specials")$t2 # indices of type 2 tensor product terms off <- attr(tf,"offset") # location of offset in formula ## have to translate sp, tp, tip, t2p so that they relate to terms, ## rather than elements of the formula... vtab <- attr(tf,"factors") # cross tabulation of vars to terms if (length(sp)>0) for (i in 1:length(sp)) { ind <- (1:nt)[as.logical(vtab[sp[i],])] sp[i] <- ind # the term that smooth relates to } if (length(tp)>0) for (i in 1:length(tp)) { ind <- (1:nt)[as.logical(vtab[tp[i],])] tp[i] <- ind # the term that smooth relates to } if (length(tip)>0) for (i in 1:length(tip)) { ind <- (1:nt)[as.logical(vtab[tip[i],])] tip[i] <- ind # the term that smooth relates to } if (length(t2p)>0) for (i in 1:length(t2p)) { ind <- (1:nt)[as.logical(vtab[t2p[i],])] t2p[i] <- ind # the term that smooth relates to } ## re-referencing is complete k <- kt <- kti <- kt2 <- ks <- kp <- 1 # counters for terms in the 2 formulae len.sp <- length(sp) len.tp <- length(tp) len.tip <- length(tip) len.t2p <- length(t2p) ns <- len.sp + len.tp + len.tip + len.t2p # number of smooths pav <- av <- rep("",0) smooth.spec <- list() mgcvat <- "package:mgcv" %in% search() ## is mgcv in search path? if (nt) for (i in 1:nt) { # work through all terms if (k <= ns&&((ks<=len.sp&&sp[ks]==i)||(kt<=len.tp&&tp[kt]==i)|| (kti<=len.tip&&tip[kti]==i)||(kt2<=len.t2p&&t2p[kt2]==i))) { # it's a smooth ## have to evaluate in the environment of the formula or you can't find variables ## supplied as smooth arguments, e.g. k <- 5;gam(y~s(x,k=k)), fails, ## but if you don't specify namespace of mgcv then stuff like ## loadNamespace('mgcv'); k <- 10; mgcv::interpret.gam(y~s(x,k=k)) fails (can't find s) ## eval(parse(text=terms[i]),envir=p.env,enclos=loadNamespace('mgcv')) fails?? ## following may supply namespace of mgcv explicitly if not on search path... if (mgcvat) st <- eval(parse(text=terms[i]),envir=p.env) else { st <- try(eval(parse(text=terms[i]),envir=p.env),silent=TRUE) if (inherits(st,"try-error")) st <- eval(parse(text=terms[i]),enclos=p.env,envir=loadNamespace('mgcv')) } if (!is.null(textra)) { ## modify the labels on smooths with textra pos <- regexpr("(",st$lab,fixed=TRUE)[1] st$label <- paste(substr(st$label,start=1,stop=pos-1),textra, substr(st$label,start=pos,stop=nchar(st$label)),sep="") } smooth.spec[[k]] <- st if (ks<=len.sp&&sp[ks]==i) ks <- ks + 1 else # counts s() terms if (kt<=len.tp&&tp[kt]==i) kt <- kt + 1 else # counts te() terms if (kti<=len.tip&&tip[kti]==i) kti <- kti + 1 else # counts ti() terms kt2 <- kt2 + 1 # counts t2() terms k <- k + 1 # counts smooth terms } else { # parametric av[kp] <- terms[i] ## element kp on rhs of parametric kp <- kp+1 # counts parametric terms } } if (!is.null(off)) { ## deal with offset av[kp] <- as.character(attr(tf,"variables")[1+off]) kp <- kp+1 } pf <- paste(response,"~",paste(av,collapse=" + ")) if (attr(tf,"intercept")==0) { pf <- paste(pf,"-1",sep="") if (kp>1) pfok <- 1 else pfok <- 0 } else { pfok <- 1;if (kp==1) { pf <- paste(pf,"1"); } } fake.formula <- pf if (length(smooth.spec)>0) for (i in 1:length(smooth.spec)) { nt <- length(smooth.spec[[i]]$term) ff1 <- paste(smooth.spec[[i]]$term[1:nt],collapse="+") fake.formula <- paste(fake.formula,"+",ff1) if (smooth.spec[[i]]$by!="NA") { fake.formula <- paste(fake.formula,"+",smooth.spec[[i]]$by) av <- c(av,smooth.spec[[i]]$term,smooth.spec[[i]]$by) } else av <- c(av,smooth.spec[[i]]$term) } fake.formula <- as.formula(fake.formula,p.env) if (length(av)) { pred.formula <- as.formula(paste("~",paste(av,collapse="+"))) pav <- all.vars(pred.formula) ## trick to strip out 'offset(x)' etc... pred.formula <- reformulate(pav) } else pred.formula <- ~1 ret <- list(pf=as.formula(pf,p.env),pfok=pfok,smooth.spec=smooth.spec, fake.formula=fake.formula,response=response,fake.names=av, pred.names=pav,pred.formula=pred.formula) class(ret) <- "split.gam.formula" ret } ## interpret.gam0 interpret.gam <- function(gf) { ## wrapper to allow gf to be a list of formulae or ## a single formula. This facilitates general penalized ## likelihood models in which several linear predictors ## may be involved... ## ## The list syntax is as follows. The first formula must have a response on ## the lhs, rather than labels. For m linear predictors, there ## must be m 'base formulae' in linear predictor order. lhs labels will ## be ignored in a base formula. Empty base formulae have '-1' on rhs. ## Further formulae have labels up to m labels 1,...,m on the lhs, in a ## syntax like this: 3 + 5 ~ s(x), which indicates that the same s(x) ## should be added to both linear predictors 3 and 5. ## e.g. A bivariate normal model with common expected values might be ## list(y1~-1,y2~-1,1+2~s(x)), whereas if the second component was contaminated ## by something else we might have list(y1~-1,y2~s(v)-1,1+2~s(x)) ## ## For a list argument, this routine returns a list of slit.formula objects ## with an extra field "lpi" indicating the linear predictors to which each ## contributes... if (is.list(gf)) { d <- length(gf) ## make sure all formulae have a response, to avoid ## problems with parametric sub formulae of the form ~1 #if (length(gf[[1]])<3) stop("first formula must specify a response") resp <- gf[[1]][2] ret <- list() pav <- av <- rep("",0) nlp <- 0 ## count number of linear predictors (may be different from number of formulae) for (i in 1:d) { textra <- if (i==1) NULL else paste(".",i-1,sep="") ## modify smooth labels to identify to predictor lpi <- getNumericResponse(gf[[i]]) ## get linear predictors to which this applies, if explicit if (length(lpi)==1) warning("single linear predictor indices are ignored") if (length(lpi)>0) gf[[i]][[2]] <- NULL else { ## delete l.p. labels from formula response nlp <- nlp + 1;lpi <- nlp ## this is base formula for l.p. number nlp } ret[[i]] <- interpret.gam0(gf[[i]],textra) ret[[i]]$lpi <- lpi ## record of the linear predictors to which this applies ## make sure all parametric formulae have a response, to avoid ## problems with parametric sub formulae of the form ~1 respi <- rep("",0) ## no extra response terms if (length(ret[[i]]$pf)==2) { ret[[i]]$pf[3] <- ret[[i]]$pf[2];ret[[i]]$pf[2] <- resp respi <- rep("",0) } else if (i>1) respi <- ret[[i]]$response ## extra response terms av <- c(av,ret[[i]]$fake.names,respi) ## accumulate all required variable names pav <- c(pav,ret[[i]]$pred.names) ## predictors only } av <- unique(av) ## strip out duplicate variable names pav <- unique(pav) ret$fake.formula <- if (length(av)>0) reformulate(av,response=ret[[1]]$response) else ret[[1]]$fake.formula ## create fake formula containing all variables ret$pred.formula <- if (length(pav)>0) reformulate(pav) else ~1 ## predictor only formula ret$response <- ret[[1]]$response ret$nlp <- nlp ## number of linear predictors for (i in 1:d) if (max(ret[[i]]$lpi)>nlp||min(ret[[i]]$lpi)<1) stop("linear predictor labels out of range") class(ret) <- "split.gam.formula" return(ret) } else interpret.gam0(gf) } ## interpret.gam fixDependence <- function(X1,X2,tol=.Machine$double.eps^.5,rank.def=0,strict=FALSE) # model matrix X2 may be linearly dependent on X1. This # routine finds which columns of X2 should be zeroed to # fix this. If rank.def>0 then it is taken as the known degree # of dependence of X2 on X1 and tol is ignored. { qr1 <- qr(X1,LAPACK=TRUE) R11 <- abs(qr.R(qr1)[1,1]) r<-ncol(X1);n<-nrow(X1) if (strict) { ## only delete columns of X2 individually dependent on X1 ## Project columns of X2 into space of X1 and look at difference ## to orignal X2 to check for deficiency... QtX2 <- qr.qty(qr1,X2) QtX2[-(1:r),] <- 0 mdiff <- colMeans(abs(X2 - qr.qy(qr1,QtX2))) if (rank.def>0) ind <- (1:ncol(X2))[rank(mdiff) <= rank.def] else ind <- (1:ncol(X2))[mdiff < R11*tol] if (length(ind)<1) ind <- NULL } else { ## make X2 full rank given X1 QtX2 <- qr.qty(qr1,X2)[(r+1):n,] # Q'X2 qr2 <- qr(QtX2,LAPACK=TRUE) R <- qr.R(qr2) # now final diagonal block of R may be zero, indicating rank # deficiency. r0 <- r <- nrow(R) if (rank.def > 0 && rank.def <= nrow(R)) r0 <- r - rank.def else ## degree of rank def known while (r0>0 && mean(abs(R[r0:r,r0:r]))< R11*tol) r0 <- r0 -1 ## compute rank def r0 <- r0 + 1 if (r0>r) return(NULL) else ind <- qr2$pivot[r0:r] # the columns of X2 to zero in order to get independence } ind } ## fixDependence augment.smX <- function(sm,nobs,np) { ## augments a smooth model matrix with a square root penalty matrix for ## identifiability constraint purposes. ns <- length(sm$S) ## number of penalty matrices if (ns==0) { ## nothing to do return(rbind(sm$X,matrix(0,np,ncol(sm$X)))) } ind <- colMeans(abs(sm$S[[1]]))!=0 sqrmaX <- mean(abs(sm$X[,ind]))^2 alpha <- sqrmaX/mean(abs(sm$S[[1]][ind,ind])) St <- sm$S[[1]]*alpha if (ns>1) for (i in 2:ns) { ind <- colMeans(abs(sm$S[[i]]))!=0 alpha <- sqrmaX/mean(abs(sm$S[[i]][ind,ind])) St <- St + sm$S[[i]]*alpha } rS <- mroot(St,rank=ncol(St)) ## get sqrt of penalty X <- rbind(sm$X,matrix(0,np,ncol(sm$X))) ## create augmented model matrix X[nobs+sm$p.ind,] <- t(rS) ## add in X ## scaled augmented model matrix } ## augment.smX gam.side <- function(sm,Xp,tol=.Machine$double.eps^.5,with.pen=FALSE) # works through a list of smooths, sm, aiming to identify nested or partially # nested terms, and impose identifiability constraints on them. # Xp is the parametric model matrix. It is needed in order to check whether # there is a constant (or equivalent) in the model. If there is, then this needs # to be included when working out side constraints, otherwise dependencies can be # missed. # Note that with.pen is quite extreme, since you then pretty much only pick # up dependencies in the null spaces { if (!with.pen) { ## check that's possible and reset if not! with.pen <- nrow(Xp) < ncol(Xp) + sum(unlist(lapply(sm,function(x) ncol(x$X)))) } m <- length(sm) if (m==0) return(sm) v.names<-array("",0);maxDim<-1 for (i in 1:m) { ## collect all term names and max smooth `dim' vn <- sm[[i]]$term ## need to include by variables in names if (sm[[i]]$by!="NA") vn <- paste(vn,sm[[i]]$by,sep="") ## need to distinguish levels of factor by variables... if (!is.null(sm[[i]]$by.level)) vn <- paste(vn,sm[[i]]$by.level,sep="") sm[[i]]$vn <- vn ## use this record to identify variables from now v.names <- c(v.names,vn) if (sm[[i]]$dim > maxDim) maxDim <- sm[[i]]$dim } lv <- length(v.names) v.names <- unique(v.names) if (lv == length(v.names)) return(sm) ## no repeats => no nesting ## Only get this far if there is nesting. ## Need to test for intercept or equivalent in Xp intercept <- FALSE if (ncol(Xp)) { ## first check columns directly... if (sum(apply(Xp,2,sd)<.Machine$double.eps^.75)>0) intercept <- TRUE else { ## no constant column, so need to check span of Xp... f <- rep(1,nrow(Xp)) ff <- qr.fitted(qr(Xp),f) if (max(abs(ff-f))<.Machine$double.eps^.75) intercept <- TRUE } } sm.id <- as.list(v.names) names(sm.id) <- v.names for (i in 1:length(sm.id)) sm.id[[i]]<-array(0,0) sm.dim <- sm.id for (d in 1:maxDim) { for (i in 1:m) { if (sm[[i]]$dim==d&&sm[[i]]$side.constrain) for (j in 1:d) { ## work through terms term<-sm[[i]]$vn[j] a <- sm.id[[term]] la <- length(a)+1 sm.id[[term]][la] <- i ## record smooth i.d. for this variable sm.dim[[term]][la] <- d ## ... and smooth dim. } } } ## so now each unique variable name has an associated array of ## the smooths of which it is an argument, arranged in ascending ## order of dimension. Smooths for which side.constrain==FALSE are excluded. if (maxDim==1) warning("model has repeated 1-d smooths of same variable.") ## Now set things up to enable term specific model matrices to be ## augmented with square root penalties, on the fly... if (with.pen) { k <- 1 for (i in 1:m) { ## create parameter indices for each term k1 <- k + ncol(sm[[i]]$X) - 1 sm[[i]]$p.ind <- k:k1 k <- k1 + 1 } np <- k-1 ## number of penalized parameters } nobs <- nrow(sm[[1]]$X) ## number of observations for (d in 1:maxDim) { ## work up through dimensions for (i in 1:m) { ## work through smooths if (sm[[i]]$dim == d&&sm[[i]]$side.constrain) { ## check for nesting if (with.pen) X1 <- matrix(c(rep(1,nobs),rep(0,np)),nobs+np,as.integer(intercept)) else X1 <- matrix(1,nobs,as.integer(intercept)) X1comp <- rep(0,0) ## list of components of X1 to avoid duplication for (j in 1:d) { ## work through variables b <- sm.id[[sm[[i]]$vn[j]]] # list of smooths dependent on this variable k <- (1:length(b))[b==i] ## locate current smooth in list if (k>1) for (l in 1:(k-1)) if (!b[l] %in% X1comp) { ## collect X columns X1comp <- c(X1comp,b[l]) ## keep track of components to avoid adding same one twice if (with.pen) { ## need to use augmented model matrix in testing if (is.null(sm[[b[l]]]$Xa)) sm[[b[l]]]$Xa <- augment.smX(sm[[b[l]]],nobs,np) X1 <- cbind(X1,sm[[b[l]]]$Xa) } else X1 <- cbind(X1,sm[[b[l]]]$X) ## penalties not considered } } ## Now X1 contains columns for all lower dimensional terms if (ncol(X1)==as.integer(intercept)) ind <- NULL else { if (with.pen) { if (is.null(sm[[i]]$Xa)) sm[[i]]$Xa <- augment.smX(sm[[i]],nobs,np) ind <- fixDependence(X1,sm[[i]]$Xa,tol=tol) } else ind <- fixDependence(X1,sm[[i]]$X,tol=tol) } ## ... the columns to zero to ensure independence if (!is.null(ind)) { sm[[i]]$X <- sm[[i]]$X[,-ind] ## work through list of penalty matrices, applying constraints... nsmS <- length(sm[[i]]$S) if (nsmS>0) for (j in nsmS:1) { ## working down so that dropping is painless sm[[i]]$S[[j]] <- sm[[i]]$S[[j]][-ind,-ind] if (sum(sm[[i]]$S[[j]]!=0)==0) rank <- 0 else rank <- qr(sm[[i]]$S[[j]],tol=tol,LAPACK=FALSE)$rank sm[[i]]$rank[j] <- rank ## replace previous rank with new rank if (rank == 0) { ## drop the penalty sm[[i]]$rank <- sm[[i]]$rank[-j] sm[[i]]$S[[j]] <- NULL sm[[i]]$S.scale <- sm[[i]]$S.scale[-j] if (!is.null(sm[[i]]$L)) sm[[i]]$L <- sm[[i]]$L[-j,,drop=FALSE] } } ## penalty matrices finished ## Now we need to establish null space rank for the term mi <- length(sm[[i]]$S) if (mi>0) { St <- sm[[i]]$S[[1]]/norm(sm[[i]]$S[[1]],type="F") if (mi>1) for (j in 1:mi) St <- St + sm[[i]]$S[[j]]/norm(sm[[i]]$S[[j]],type="F") es <- eigen(St,symmetric=TRUE,only.values=TRUE) sm[[i]]$null.space.dim <- sum(es$values don't clone } specb ## return clone } ## clone.smooth.spec parametricPenalty <- function(pterms,assign,paraPen,sp0) { ## routine to process any penalties on the parametric part of the model. ## paraPen is a list whose items have names corresponding to the ## term.labels in pterms. Each list item may have named elements ## L, rank and sp. All other elements should be penalty coefficient matrices. S <- list() ## penalty matrix list off <- rep(0,0) ## offset array rank <- rep(0,0) ## rank array sp <- rep(0,0) ## smoothing param array full.sp.names <- rep("",0) ## names for sp's multiplying penalties (not underlying) L <- matrix(0,0,0) k <- 0 tind <- unique(assign) ## unique term indices n.t <- length(tind) if (n.t>0) for (j in 1:n.t) if (tind[j]>0) { term.label <- attr(pterms[tind[j]],"term.label") P <- paraPen[[term.label]] ## get any penalty information for this term if (!is.null(P)) { ## then there is information ind <- (1:length(assign))[assign==tind[j]] ## index of coefs involved here Li <- P$L;P$L <- NULL spi <- P$sp;P$sp <- NULL ranki <- P$rank;P$rank <- NULL ## remaining terms should be penalty matrices... np <- length(P) if (!is.null(ranki)&&length(ranki)!=np) stop("`rank' has wrong length in `paraPen'") if (np) for (i in 1:np) { ## unpack penalty matrices, offsets and ranks k <- k + 1 S[[k]] <- P[[i]] off[k] <- min(ind) ## index of first coef penalized by this term if ( ncol(P[[i]])!=nrow(P[[i]])||nrow(P[[i]])!=length(ind)) stop(" a parametric penalty has wrong dimension") if (is.null(ranki)) { ev <- eigen(S[[k]],symmetric=TRUE,only.values=TRUE)$values rank[k] <- sum(ev>max(ev)*.Machine$double.eps*10) ## estimate rank } else rank[k] <- ranki[i] } ## now deal with L matrices if (np) { ## only do this stuff if there are any penalties! if (is.null(Li)) Li <- diag(np) if (nrow(Li)!=np) stop("L has wrong dimension in `paraPen'") L <- rbind(cbind(L,matrix(0,nrow(L),ncol(Li))), cbind(matrix(0,nrow(Li),ncol(L)),Li)) ind <- (length(sp)+1):(length(sp)+ncol(Li)) ind2 <- (length(sp)+1):(length(sp)+nrow(Li)) ## used to produce names for full sp array if (is.null(spi)) { sp[ind] <- -1 ## auto-initialize } else { if (length(spi)!=ncol(Li)) stop("`sp' dimension wrong in `paraPen'") sp[ind] <- spi } ## add smoothing parameter names.... if (length(ind)>1) names(sp)[ind] <- paste(term.label,ind-ind[1]+1,sep="") else names(sp)[ind] <- term.label if (length(ind2)>1) full.sp.names[ind2] <- paste(term.label,ind2-ind2[1]+1,sep="") else full.sp.names[ind2] <- term.label } } ## end !is.null(P) } ## looped through all terms if (k==0) return(NULL) if (!is.null(sp0)) { if (length(sp0)0) return(rep(0,0)) ## deparse turns lhs into a string; strsplit extracts the characters ## corresponding to numbers; unlist deals with the fact that deparse ## will split long lines resulting in multiple list items from ## strsplit; as.numeric converts the numbers; na.omit drops NAs ## resulting from "" elements; unique & round are obvious... round(unique(na.omit(as.numeric(unlist(strsplit(deparse(form[[2]]), "[^0-9]+")))))) } ## getNumericResponse olid <- function(X,nsdf,pstart,flpi,lpi) { ## X is a model matrix, made up of nf=length(nsdf) column blocks. ## The ith block starts at column pstart[i] and its first nsdf[i] ## columns are unpenalized. X is used to define nlp=length(lpi) ## linear predictors. lpi[[i]] gives the columns of X used in the ## ith linear predictor. flpi[j] gives the linear predictor(s) ## to which the jth block of X belongs. The problem is that the ## unpenalized blocks need not be identifiable when used in combination. ## This function returns a vector dind of columns of X to drop for ## identifiability, along with modified lpi, pstart and nsdf vectors. nlp <- length(lpi) ## number of linear predictors n <- nrow(X) nf <- length(nsdf) ## number of formulae blocks Xp <- matrix(0,n*nlp,sum(nsdf)) start <- 1 ii <- 1:n tind <- rep(0,0) ## complete index of all parametric columns in X ## create a block matrix, Xp, with the same identifiability properties as ## unpenalized part of model... for (i in 1:nf) { stop <- start - 1 + nsdf[i] if (stop>=start) { ind <- pstart[i] + 1:nsdf[i] - 1 for (k in flpi[[i]]) { Xp[ii+(k-1)*n,start:stop] <- X[,ind] } tind <- c(tind,ind) start <- start + nsdf[i] } } ## rank deficiency of Xp will reveal number of redundant parametric ## terms, and a pivoted QR will reveal which to drop to restore ## full rank... qrx <- qr(Xp,LAPACK=TRUE,tol=0.0) ## unidentifiable columns get pivoted to final cols r <- Rrank(qr.R(qrx)) ## get rank from R factor of pivoted QR if (r==ncol(Xp)) { ## full rank, all fine, drop nothing dind <- rep(0,0) } else { ## reduced rank, drop some columns dind <- tind[sort(qrx$pivot[(r+1):ncol(X)],decreasing=TRUE)] ## columns to drop ## now we need to adjust nsdf, pstart and lpi for (d in dind) { ## working down through drop indices ## following commented out code is useful should it ever prove necessary to ## adjust pstart and nsdf, but at present these are only used in prediction, ## and it is cleaner to leave them unchanged, and simply drop using dind during prediction. #k <- if (d>=pstart[nf]) nlp else which(d >= pstart[1:(nf-1)] & d < pstart[2:nf]) #nsdf[k] <- nsdf[k] - 1 ## one less unpenalized column in this block #if (k0) lpi[[i]] <- lpi[[i]][-k] ## drop row k <- which(lpi[[i]]>d) if (length(k)>0) lpi[[i]][k] <- lpi[[i]][k] - 1 ## close up } } ## end of drop index loop } list(dind=dind,lpi=lpi) ##,pstart=pstart,nsdf=nsdf) } ## olid gam.setup.list <- function(formula,pterms, data=stop("No data supplied to gam.setup"),knots=NULL,sp=NULL, min.sp=NULL,H=NULL,absorb.cons=TRUE,sparse.cons=0,select=FALSE,idLinksBases=TRUE, scale.penalty=TRUE,paraPen=NULL,gamm.call=FALSE,drop.intercept=NULL) { ## version of gam.setup for when gam is called with a list of formulae, ## specifying several linear predictors... ## key difference to gam.setup is an attribute to the model matrix, "lpi", which is a list ## of column indices for each linear predictor if (!is.null(paraPen)) stop("paraPen not supported for multi-formula models") if (!absorb.cons) stop("absorb.cons must be TRUE for multi-formula models") d <- length(pterms) ## number of formulae if (is.null(drop.intercept)) drop.intercept <- rep(FALSE, d) if (length(drop.intercept) != d) stop("length(drop.intercept) should be equal to number of model formulas") lp.overlap <- if (formula$nlp0) sp <- sp[-(1:used.sp)] ## need to strip off already used sp's if (!is.null(min.sp)&&nrow(G$L)>0) min.sp <- min.sp[-(1:nrow(G$L))] ## formula[[1]] always relates to the base formula of the first linear predictor... flpi <- lpi <- list() for (i in 1:formula$nlp) lpi[[i]] <- rep(0,0) lpi[[1]] <- 1:ncol(G$X) ## lpi[[j]] is index of cols for jth linear predictor flpi[[1]] <- formula[[1]]$lpi ## used in identifiability testing by olid, later pof <- ncol(G$X) ## counts the model matrix columns produced so far pstart <- rep(0,d) ## indexes where parameteric columns start in each formula block of X pstart[1] <- 1 if (d>1) for (i in 2:d) { if (is.null(formula[[i]]$response)) { ## keep gam.setup happy formula[[i]]$response <- formula$response mv.response <- FALSE } else mv.response <- TRUE #spind <- if (is.null(sp)) 1 else (length(G$S)+1):length(sp) formula[[i]]$pfok <- 1 ## empty formulae OK here! um <- gam.setup(formula[[i]],pterms[[i]], data,knots,sp,min.sp,#sp[spind],min.sp[spind], H,absorb.cons,sparse.cons,select, idLinksBases,scale.penalty,paraPen,gamm.call,drop.intercept[i],list.call=TRUE) used.sp <- length(um$lsp0) if (!is.null(sp)&&used.sp>0) sp <- sp[-(1:used.sp)] ## need to strip off already used sp's if (!is.null(min.sp)&&nrow(um$L)>0) min.sp <- min.sp[-(1:nrow(um$L))] flpi[[i]] <- formula[[i]]$lpi for (j in formula[[i]]$lpi) { ## loop through all l.p.s to which this term contributes lpi[[j]] <- c(lpi[[j]],pof + 1:ncol(um$X)) ## add these cols to lpi[[j]] ##lpi[[i]] <- pof + 1:ncol(um$X) ## old code } if (mv.response) G$y <- cbind(G$y,um$y) if (i>formula$nlp&&!is.null(um$offset)) { stop("shared offsets not allowed") } G$offset[[i]] <- um$offset #G$contrasts[[i]] <- um$contrasts if (!is.null(um$contrasts)) G$contrasts <- c(G$contrasts,um$contrasts) G$xlevels[[i]] <- um$xlevels G$assign[[i]] <- um$assign G$rank <- c(G$rank,um$rank) pstart[i] <- pof+1 G$X <- cbind(G$X,um$X) ## extend model matrix ## deal with the smooths... k <- G$m if (um$m) for (j in 1:um$m) { um$smooth[[j]]$first.para <- um$smooth[[j]]$first.para + pof um$smooth[[j]]$last.para <- um$smooth[[j]]$last.para + pof k <- k + 1 G$smooth[[k]] <- um$smooth[[j]] } ## L, S and off... ks <- length(G$S) M <- length(um$S) if (!is.null(um$L)||!is.null(G$L)) { if (is.null(G$L)) G$L <- diag(1,nrow=ks) if (is.null(um$L)) um$L <- diag(1,nrow=M) G$L <- rbind(cbind(G$L,matrix(0,nrow(G$L),ncol(um$L))),cbind(matrix(0,nrow(um$L),ncol(G$L)),um$L)) } G$off <- c(G$off,um$off+pof) if (M) for (j in 1:M) { ks <- ks + 1 G$S[[ks]] <- um$S[[j]] } G$m <- G$m + um$m ## number of smooths ##G$nsdf <- G$nsdf + um$nsdf ## or list?? G$nsdf[i] <- um$nsdf if (!is.null(um$P)||!is.null(G$P)) { if (is.null(G$P)) G$P <- diag(1,nrow=pof) k <- ncol(um$X) if (is.null(um$P)) um$P <- diag(1,nrow=k) G$P <- rbind(cbind(G$P,matrix(0,pof,k)),cbind(matrix(0,k,pof),um$P)) } G$cmX <- c(G$cmX,um$cmX) if (um$nsdf>0) um$term.names[1:um$nsdf] <- paste(um$term.names[1:um$nsdf],i-1,sep=".") G$term.names <- c(G$term.names,um$term.names) G$lsp0 <- c(G$lsp0,um$lsp0) G$sp <- c(G$sp,um$sp) pof <- ncol(G$X) } ## formula loop end ## If there is overlap then there is a danger of lack of identifiability of the ## parameteric terms, especially if there are factors present in shared components. ## The following code deals with this possibility... if (lp.overlap) { rt <- olid(G$X,G$nsdf,pstart,flpi,lpi) if (length(rt$dind)>0) { ## then columns have to be dropped warning("dropping unidentifiable parametric terms from model",call.=FALSE) G$X <- G$X[,-rt$dind] ## drop cols G$cmX <- G$cmX[-rt$dind] G$term.names <- G$term.names[-rt$dind] ## adjust indexing in smooth list, noting that coefs of smooths ## are never dropped by dind for (i in 1:length(G$smooth)) { k <- sum(rt$dind < G$smooth[[i]]$first.para) G$smooth[[i]]$first.para <- G$smooth[[i]]$first.para - k G$smooth[[i]]$last.para <- G$smooth[[i]]$last.para - k } for (i in 1:length(G$off)) G$off[i] <- G$off[i] - sum(rt$dind < G$off[i]) ## replace various indices with updated versions... # pstart <- rt$pstart; G$nsdf <- rt$nsdf ## these two only needed in predict.gam - cleaner to leave unchanged lpi <- rt$lpi attr(G$nsdf,"drop.ind") <- rt$dind ## store drop index } } attr(lpi,"overlap") <- lp.overlap attr(G$X,"lpi") <- lpi attr(G$nsdf,"pstart") <- pstart ##unlist(lapply(lpi,min)) G } ## gam.setup.list gam.setup <- function(formula,pterms, data=stop("No data supplied to gam.setup"),knots=NULL,sp=NULL, min.sp=NULL,H=NULL,absorb.cons=TRUE,sparse.cons=0,select=FALSE,idLinksBases=TRUE, scale.penalty=TRUE,paraPen=NULL,gamm.call=FALSE,drop.intercept=FALSE, diagonal.penalty=FALSE,apply.by=TRUE,list.call=FALSE,modCon=0) ## set up the model matrix, penalty matrices and auxilliary information about the smoothing bases ## needed for a gam fit. ## elements of returned object: ## * m - number of smooths ## * min.sp - minimum smoothing parameters ## * H supplied H matrix ## * pearson.extra, dev.extra, n.true --- entries to hold these quantities ## * pterms - terms object for parametric terms ## * intercept TRUE if intercept present ## * offset - the model offset ## * nsdf - number of strictly parameteric coefs ## * contrasts ## * xlevels - records levels of factors ## * assign - indexes which parametric model matrix columns map to which term in pterms ## * smooth - list of smooths ## * S - penalties (non-zero block only) ## * off - first coef penalized by each element of S ## * cmX - col mean of X ## * P - maps parameters in fit constraint parameterization to those in prediction parameterization ## * X - model matrix ## * sp ## * rank ## * n.paraPen ## * L ## * lsp0 ## * y - response ## * C - constraint matrix - only if absorb.cons==FALSE ## * n - dim(y) ## * w - weights ## * term.names ## * nP { # split the formula if the object being passed is a formula, otherwise it's already split if (inherits(formula,"split.gam.formula")) split <- formula else if (inherits(formula,"formula")) split <- interpret.gam(formula) else stop("First argument is no sort of formula!") if (length(split$smooth.spec)==0) { if (split$pfok==0) stop("You've got no model....") m <- 0 } else m <- length(split$smooth.spec) # number of smooth terms G <- list(m=m,min.sp=min.sp,H=H,pearson.extra=0, dev.extra=0,n.true=-1,pterms=pterms) ## dev.extra gets added to deviance if REML/ML used in gam.fit3 if (is.null(attr(data,"terms"))) # then data is not a model frame mf <- model.frame(split$pf,data,drop.unused.levels=FALSE) # must be false or can end up with wrong prediction matrix! else mf <- data # data is already a model frame G$intercept <- attr(attr(mf,"terms"),"intercept")>0 ## get any model offset. Complicated by possibility of offsets in multiple formulae... if (list.call) { offi <- attr(pterms,"offset") if (!is.null(offi)) { G$offset <- mf[[names(attr(pterms,"dataClasses"))[offi]]] } } else G$offset <- model.offset(mf) # get any model offset including from offset argument if (!is.null(G$offset)) G$offset <- as.numeric(G$offset) # construct strictly parametric model matrix.... if (drop.intercept) attr(pterms,"intercept") <- 1 ## ensure there is an intercept to drop X <- model.matrix(pterms,mf) if (drop.intercept) { ## some extended families require intercept to be dropped xat <- attributes(X);ind <- xat$assign>0 ## index of non intercept columns X <- X[,ind,drop=FALSE] ## some extended families need to drop intercept xat$assign <- xat$assign[ind];xat$dimnames[[2]]<-xat$dimnames[[2]][ind]; xat$dim[2] <- xat$dim[2]-1;attributes(X) <- xat G$intercept <- FALSE } rownames(X) <- NULL ## save memory G$nsdf <- ncol(X) G$contrasts <- attr(X,"contrasts") G$xlevels <- .getXlevels(pterms,mf) G$assign <- attr(X,"assign") # used to tell which coeffs relate to which pterms ## now deal with any user supplied penalties on the parametric part of the model... PP <- parametricPenalty(pterms,G$assign,paraPen,sp) if (!is.null(PP)) { ## strip out supplied sps already used ind <- 1:length(PP$sp) if (!is.null(sp)) sp <- sp[-ind] if (!is.null(min.sp)) { PP$min.sp <- min.sp[ind] min.sp <- min.sp[-ind] } } # next work through smooth terms (if any) extending model matrix..... G$smooth <- list() G$S <- list() if (gamm.call) { ## flag that this is a call from gamm --- some smoothers need to know! if (m>0) for (i in 1:m) attr(split$smooth.spec[[i]],"gamm") <- TRUE } if (m>0 && idLinksBases) { ## search smooth.spec[[]] for terms linked by common id's id.list <- list() ## id information list for (i in 1:m) if (!is.null(split$smooth.spec[[i]]$id)) { id <- as.character(split$smooth.spec[[i]]$id) if (length(id.list)&&id%in%names(id.list)) { ## it's an existing id ni <- length(id.list[[id]]$sm.i) ## number of terms so far with this id id.list[[id]]$sm.i[ni+1] <- i ## adding smooth.spec index to this id's list ## clone smooth.spec from base smooth spec.... base.i <- id.list[[id]]$sm.i[1] split$smooth.spec[[i]] <- clone.smooth.spec(split$smooth.spec[[base.i]], split$smooth.spec[[i]]) ## add data for this term to the data list for basis setup... temp.term <- split$smooth.spec[[i]]$term ## note cbind deliberate in next line, as construction will handle matrix argument ## correctly... for (j in 1:length(temp.term)) id.list[[id]]$data[[j]] <- cbind(id.list[[id]]$data[[j]], get.var(temp.term[j],data,vecMat=FALSE)) } else { ## new id id.list[[id]] <- list(sm.i=i) ## start the array of indices of smooths with this id id.list[[id]]$data <- list() ## need to collect together all data for which this basis will be used, ## for basis setup... term <- split$smooth.spec[[i]]$term for (j in 1:length(term)) id.list[[id]]$data[[j]] <- get.var(term[j],data,vecMat=FALSE) } ## new id finished } } ## id.list complete G$off<-array(0,0) first.para<-G$nsdf+1 sm <- list() newm <- 0 if (m>0) for (i in 1:m) { # idea here is that terms are set up in accordance with information given in split$smooth.spec # appropriate basis constructor is called depending on the class of the smooth # constructor returns penalty matrices model matrix and basis specific information ## sm[[i]] <- smoothCon(split$smooth.spec[[i]],data,knots,absorb.cons,scale.penalty=scale.penalty,sparse.cons=sparse.cons) ## old code id <- split$smooth.spec[[i]]$id if (is.null(id)||!idLinksBases) { ## regular evaluation sml <- smoothCon(split$smooth.spec[[i]],data,knots,absorb.cons,scale.penalty=scale.penalty, null.space.penalty=select,sparse.cons=sparse.cons, diagonal.penalty=diagonal.penalty,apply.by=apply.by,modCon=modCon) } else { ## it's a smooth with an id, so basis setup data differs from model matrix data names(id.list[[id]]$data) <- split$smooth.spec[[i]]$term ## give basis data suitable names sml <- smoothCon(split$smooth.spec[[i]],id.list[[id]]$data,knots, absorb.cons,n=nrow(data),dataX=data,scale.penalty=scale.penalty, null.space.penalty=select,sparse.cons=sparse.cons, diagonal.penalty=diagonal.penalty,apply.by=apply.by,modCon=modCon) } for (j in 1:length(sml)) { newm <- newm + 1 sm[[newm]] <- sml[[j]] } } G$m <- m <- newm ## number of actual smooths ## at this stage, it is neccessary to impose any side conditions required ## for identifiability if (m>0) { sm <- gam.side(sm,X,tol=.Machine$double.eps^.5) if (!apply.by) for (i in 1:length(sm)) { ## restore any by-free model matrices if (!is.null(sm[[i]]$X0)) { ## there is a by-free matrix to restore ind <- attr(sm[[i]],"del.index") ## columns, if any to delete sm[[i]]$X <- if (is.null(ind)) sm[[i]]$X0 else sm[[i]]$X0[,-ind,drop=FALSE] } } } ## The matrix, L, mapping the underlying log smoothing parameters to the ## log of the smoothing parameter multiplying the S[[i]] must be ## worked out... idx <- list() ## idx[[id]]$c contains index of first col in L relating to id L <- matrix(0,0,0) lsp.names <- sp.names <- rep("",0) ## need a list of names to identify sps in global sp array if (m>0) for (i in 1:m) { id <- sm[[i]]$id ## get the L matrix for this smooth... length.S <- length(sm[[i]]$S) if (is.null(sm[[i]]$L)) Li <- diag(length.S) else Li <- sm[[i]]$L if (length.S > 0) { ## there are smoothing parameters to name if (length.S == 1) spn <- sm[[i]]$label else { Sname <- names(sm[[i]]$S) if (is.null(Sname)) spn <- paste(sm[[i]]$label,1:length.S,sep="") else spn <- paste(sm[[i]]$label,Sname,sep="") } } ## extend the global L matrix... if (is.null(id)||is.null(idx[[id]])) { ## new `id' if (!is.null(id)) { ## create record in `idx' idx[[id]]$c <- ncol(L)+1 ## starting column in L for this `id' idx[[id]]$nc <- ncol(Li) ## number of columns relating to this `id' } L <- rbind(cbind(L,matrix(0,nrow(L),ncol(Li))), cbind(matrix(0,nrow(Li),ncol(L)),Li)) if (length.S > 0) { ## there are smoothing parameters to name sp.names <- c(sp.names,spn) ## extend the sp name vector lsp.names <- c(lsp.names,spn) ## extend full.sp name vector } } else { ## it's a repeat id => shares existing sp's L0 <- matrix(0,nrow(Li),ncol(L)) if (ncol(Li)>idx[[id]]$nc) { stop("Later terms sharing an `id' can not have more smoothing parameters than the first such term") } L0[,idx[[id]]$c:(idx[[id]]$c+ncol(Li)-1)] <- Li L <- rbind(L,L0) if (length.S > 0) { ## there are smoothing parameters to name lsp.names <- c(lsp.names,spn) ## extend full.sp name vector } } } ## create the model matrix... Xp <- NULL ## model matrix under prediction constraints, if given if (m>0) for (i in 1:m) { n.para<-ncol(sm[[i]]$X) # define which elements in the parameter vector this smooth relates to.... sm[[i]]$first.para<-first.para first.para<-first.para+n.para sm[[i]]$last.para<-first.para-1 ## termwise offset handling ... Xoff <- attr(sm[[i]]$X,"offset") if (!is.null(Xoff)) { if (is.null(G$offset)) G$offset <- Xoff else G$offset <- G$offset + Xoff } ## model matrix accumulation ... ## alternative version under alternative constraint first (prediction only) if (is.null(sm[[i]]$Xp)) { if (!is.null(Xp)) Xp <- cbind2(Xp,sm[[i]]$X) } else { if (is.null(Xp)) Xp <- X Xp <- cbind2(Xp,sm[[i]]$Xp);sm[[i]]$Xp <- NULL } ## now version to use for fitting ... X <- cbind2(X,sm[[i]]$X);sm[[i]]$X<-NULL G$smooth[[i]] <- sm[[i]] } if (is.null(Xp)) { G$cmX <- colMeans(X) ## useful for componentwise CI construction } else { G$cmX <- colMeans(Xp) ## transform from fit params to prediction params... ## G$P <- qr.coef(qr(Xp),X) ## old code assumes always full rank!! qrx <- qr(Xp,LAPACK=TRUE) R <- qr.R(qrx) p <- ncol(R) rank <- Rrank(R) ## rank of Xp/R QtX <- qr.qty(qrx,X)[1:rank,] if (rank0) G$cmX[-(1:G$nsdf)] <- 0 ## zero the smooth parts here else G$cmX <- G$cmX * 0 G$X <- X;rm(X) n.p <- ncol(G$X) # deal with penalties ## min.sp must be length nrow(L) to make sense ## sp must be length ncol(L) --- need to partition ## L into columns relating to free log smoothing parameters, ## and columns, L0, corresponding to values supplied in sp. ## lsp0 = L0%*%log(sp[sp>=0]) [need to fudge sp==0 case by ## setting log(0) to log(effective zero) computed case-by-case] ## following deals with supplied and estimated smoothing parameters... ## first process the `sp' array supplied to `gam'... if (!is.null(sp)) { # then user has supplied fixed smoothing parameters ok <- TRUE if (length(sp) < ncol(L)) { warning("Supplied smoothing parameter vector is too short - ignored.") ok <- FALSE } if (sum(is.na(sp))) { warning("NA's in supplied smoothing parameter vector - ignoring.") ok <- FALSE } } else ok <- FALSE G$sp <- if (ok) sp[1:ncol(L)] else rep(-1,ncol(L)) names(G$sp) <- sp.names ## now work through the smooths searching for any `sp' elements ## supplied in `s' or `te' terms.... This relies on `idx' created ## above... k <- 1 ## current location in `sp' array if (m>0) for (i in 1:m) { id <- sm[[i]]$id if (is.null(sm[[i]]$L)) Li <- diag(length(sm[[i]]$S)) else Li <- sm[[i]]$L if (is.null(id)) { ## it's a smooth without an id spi <- sm[[i]]$sp if (!is.null(spi)) { ## sp supplied in `s' or `te' if (length(spi)!=ncol(Li)) stop("incorrect number of smoothing parameters supplied for a smooth term") G$sp[k:(k+ncol(Li)-1)] <- spi } k <- k + ncol(Li) } else { ## smooth has an id spi <- sm[[i]]$sp if (is.null(idx[[id]]$sp.done)) { ## not already dealt with these sp's if (!is.null(spi)) { ## sp supplied in `s' or `te' if (length(spi)!=ncol(Li)) stop("incorrect number of smoothing parameters supplied for a smooth term") G$sp[idx[[id]]$c:(idx[[id]]$c+idx[[id]]$nc-1)] <- spi } idx[[id]]$sp.done <- TRUE ## only makes sense to use supplied `sp' from defining term k <- k + idx[[id]]$nc } } } ## finished processing `sp' vectors supplied in `s' or `te' terms ## copy initial sp's back into smooth objects, so there is a record of ## fixed and free... k <- 1 if (length(idx)) for (i in 1:length(idx)) idx[[i]]$sp.done <- FALSE if (m>0) for (i in 1:m) { ## work through all smooths id <- sm[[i]]$id if (!is.null(id)) { ## smooth with id if (idx[[id]]$nc>0) { ## only copy if there are sp's G$smooth[[i]]$sp <- G$sp[idx[[id]]$c:(idx[[id]]$c+idx[[id]]$nc-1)] } if (!idx[[id]]$sp.done) { ## only update k on first encounter with this smooth idx[[id]]$sp.done <- TRUE k <- k + idx[[id]]$nc } } else { ## no id, just work through sp if (is.null(sm[[i]]$L)) nc <- length(sm[[i]]$S) else nc <- ncol(sm[[i]]$L) if (nc>0) G$smooth[[i]]$sp <- G$sp[k:(k+nc-1)] k <- k + nc } } ## now all elements of G$smooth have a record of initial sp. if (!is.null(min.sp)) { # then minimum s.p.'s supplied if (length(min.sp)0) for (i in 1:m) { sm<-G$smooth[[i]] if (length(sm$S)>0) for (j in 1:length(sm$S)) { # work through penalty matrices k.sp <- k.sp+1 G$off[k.sp] <- sm$first.para G$S[[k.sp]] <- sm$S[[j]] G$rank[k.sp]<-sm$rank[j] if (!is.null(min.sp)) { if (is.null(H)) H<-matrix(0,n.p,n.p) H[sm$first.para:sm$last.para,sm$first.para:sm$last.para] <- H[sm$first.para:sm$last.para,sm$first.para:sm$last.para]+min.sp[k.sp]*sm$S[[j]] } } } ## need to modify L, lsp.names, G$S, G$sp, G$rank and G$off to include any penalties ## on parametric stuff, at this point.... if (!is.null(PP)) { ## deal with penalties on parametric terms L <- rbind(cbind(L,matrix(0,nrow(L),ncol(PP$L))), cbind(matrix(0,nrow(PP$L),ncol(L)),PP$L)) G$off <- c(PP$off,G$off) G$S <- c(PP$S,G$S) G$rank <- c(PP$rank,G$rank) G$sp <- c(PP$sp,G$sp) lsp.names <- c(PP$full.sp.names,lsp.names) G$n.paraPen <- length(PP$off) if (!is.null(PP$min.sp)) { ## deal with minimum sps if (is.null(H)) H <- matrix(0,n.p,n.p) for (i in 1:length(PP$S)) { ind <- PP$off[i]:(PP$off[i]+ncol(PP$S[[i]])-1) H[ind,ind] <- H[ind,ind] + PP$min.sp[i] * PP$S[[i]] } } ## min.sp stuff finished } else G$n.paraPen <- 0 ## Now remove columns of L and rows of sp relating to fixed ## smoothing parameters, and use removed elements to create lsp0 fix.ind <- G$sp>=0 if (sum(fix.ind)) { lsp0 <- G$sp[fix.ind] ind <- lsp0==0 ## find the zero s.p.s ef0 <- indi <- (1:length(ind))[ind] if (length(indi)>0) for (i in 1:length(indi)) { ## find "effective zero" to replace each zero s.p. with ii <- G$off[i]:(G$off[i]+ncol(G$S[[i]])-1) ef0[i] <- norm(G$X[,ii],type="F")^2/norm(G$S[[i]],type="F")*.Machine$double.eps*.1 } lsp0[!ind] <- log(lsp0[!ind]) lsp0[ind] <- log(ef0) ##log(.Machine$double.xmin)*1000 ## zero fudge lsp0 <- as.numeric(L[,fix.ind,drop=FALSE]%*%lsp0) L <- L[,!fix.ind,drop=FALSE] G$sp <- G$sp[!fix.ind] } else {lsp0 <- rep(0,nrow(L))} G$H <- H if (ncol(L)==nrow(L)&&!sum(L!=diag(ncol(L)))) L <- NULL ## it's just the identity G$L <- L;G$lsp0 <- lsp0 names(G$lsp0) <- lsp.names ## names of all smoothing parameters (not just underlying) if (absorb.cons==FALSE) { ## need to accumulate constraints G$C <- matrix(0,0,n.p) if (m>0) { for (i in 1:m) { if (is.null(G$smooth[[i]]$C)) n.con<-0 else n.con<- nrow(G$smooth[[i]]$C) C <- matrix(0,n.con,n.p) C[,G$smooth[[i]]$first.para:G$smooth[[i]]$last.para]<-G$smooth[[i]]$C G$C <- rbind(G$C,C) G$smooth[[i]]$C <- NULL } rm(C) } } ## absorb.cons == FALSE G$y <- data[[split$response]] ##data[[deparse(split$full.formula[[2]],backtick=TRUE)]] G$n <- nrow(data) if (is.null(data$"(weights)")) G$w <- rep(1,G$n) else G$w <- data$"(weights)" ## Create names for model coefficients... if (G$nsdf > 0) term.names <- colnames(G$X)[1:G$nsdf] else term.names<-array("",0) n.smooth <- length(G$smooth) if (n.smooth) for (i in 1:n.smooth) { ## create coef names, if smooth has any coefs! k<-1 jj <- G$smooth[[i]]$first.para:G$smooth[[i]]$last.para if (G$smooth[[i]]$df > 0) for (j in jj) { term.names[j] <- paste(G$smooth[[i]]$label,".",as.character(k),sep="") k <- k+1 } } G$term.names <- term.names # now run some checks on the arguments ### Should check that there are enough unique covariate combinations to support model dimension G$pP <- PP ## return paraPen object, if present G } ## gam.setup formula.gam <- function(x, ...) # formula.lm and formula.glm reconstruct the formula from x$terms, this is # problematic because of the way mgcv handles s() and te() terms { x$formula } gam.outer <- function(lsp,fscale,family,control,method,optimizer,criterion,scale,gamma,G,start=NULL,...) # function for smoothing parameter estimation by outer optimization. i.e. # P-IRLS scheme iterated to convergence for each trial set of smoothing # parameters. # MAJOR STEPS: # 1. Call appropriate smoothing parameter optimizer, and extract fitted model # `object' # 2. Call `gam.fit3.post.proc' to get parameter covariance matrices, edf etc to # add to `object' { if (is.na(optimizer[2])) optimizer[2] <- "newton" if (!optimizer[2]%in%c("newton","bfgs","nlm","optim","nlm.fd")) stop("unknown outer optimization method.") # if (!optimizer[2]%in%c("nlm","optim","nlm.fd")) .Deprecated(msg=paste("optimizer",optimizer[2],"is deprecated, please use newton or bfgs")) if (optimizer[1]=="efs" && !inherits(family,"general.family")) { warning("Extended Fellner Schall only implemented for general families") optimizer <- c("outer","newton") } if (length(lsp)==0) { ## no sp estimation to do -- run a fit instead optimizer[2] <- "no.sps" ## will cause gam2objective to be called, below } nbGetTheta <- substr(family$family[1],1,17)=="Negative Binomial" && length(family$getTheta())>1 if (nbGetTheta) stop("Please provide a single value for theta or use nb to estimate it") if (optimizer[2]=="nlm.fd") { #if (nbGetTheta) stop("nlm.fd not available with negative binomial Theta estimation") if (method%in%c("REML","ML","GACV.Cp","P-ML","P-REML")) stop("nlm.fd only available for GCV/UBRE") um<-nlm(full.score,lsp,typsize=lsp,fscale=fscale, stepmax = control$nlm$stepmax, ndigit = control$nlm$ndigit, gradtol = control$nlm$gradtol, steptol = control$nlm$steptol, iterlim = control$nlm$iterlim, G=G,family=family,control=control, gamma=gamma,start=start,...) lsp<-um$estimate object<-attr(full.score(lsp,G,family,control,gamma=gamma,...),"full.gam.object") object$gcv.ubre <- um$minimum object$outer.info <- um object$sp <- exp(lsp) return(object) } ## some preparations for the other methods, which all use gam.fit3... family <- fix.family.link(family) family <- fix.family.var(family) if (method%in%c("REML","ML","P-REML","P-ML")) family <- fix.family.ls(family) if (optimizer[1]=="efs"&& optimizer[2] != "no.sps" ) { ## experimental extended efs ##warning("efs is still experimental!") object <- efsud(x=G$X,y=G$y,lsp=lsp,Sl=G$Sl,weights=G$w,offset=G$offxset,family=family, control=control,Mp=G$Mp,start=start) object$gcv.ubre <- object$REML } else if (optimizer[2]=="newton"||optimizer[2]=="bfgs"){ ## the gam.fit3 method if (optimizer[2]=="bfgs") b <- bfgs(lsp=lsp,X=G$X,y=G$y,Eb=G$Eb,UrS=G$UrS,L=G$L,lsp0=G$lsp0,offset=G$offset,U1=G$U1,Mp = G$Mp, family=family,weights=G$w,control=control,gamma=gamma,scale=scale,conv.tol=control$newton$conv.tol, maxNstep= control$newton$maxNstep,maxSstep=control$newton$maxSstep,maxHalf=control$newton$maxHalf, printWarn=FALSE,scoreType=criterion,null.coef=G$null.coef,start=start, pearson.extra=G$pearson.extra,dev.extra=G$dev.extra,n.true=G$n.true,Sl=G$Sl,...) else b <- newton(lsp=lsp,X=G$X,y=G$y,Eb=G$Eb,UrS=G$UrS,L=G$L,lsp0=G$lsp0,offset=G$offset,U1=G$U1,Mp=G$Mp, family=family,weights=G$w,control=control,gamma=gamma,scale=scale,conv.tol=control$newton$conv.tol, maxNstep= control$newton$maxNstep,maxSstep=control$newton$maxSstep,maxHalf=control$newton$maxHalf, printWarn=FALSE,scoreType=criterion,null.coef=G$null.coef,start=start, pearson.extra=G$pearson.extra,dev.extra=G$dev.extra,n.true=G$n.true,Sl=G$Sl, edge.correct=control$edge.correct,...) object <- b$object object$REML <- object$REML1 <- object$REML2 <- object$GACV <- object$D2 <- object$P2 <- object$UBRE2 <- object$trA2 <- object$GACV1 <- object$GACV2 <- object$GCV2 <- object$D1 <- object$P1 <- NULL object$sp <- as.numeric(exp(b$lsp)) object$gcv.ubre <- b$score b <- list(conv=b$conv,iter=b$iter,grad=b$grad,hess=b$hess,score.hist=b$score.hist) ## return info object$outer.info <- b } else { ## methods calling gam.fit3 args <- list(X=G$X,y=G$y,Eb=G$Eb,UrS=G$UrS,offset=G$offset,U1=G$U1,Mp=G$Mp,family=family, weights=G$w,control=control,scoreType=criterion,gamma=gamma,scale=scale, L=G$L,lsp0=G$lsp0,null.coef=G$null.coef,n.true=G$n.true,Sl=G$Sl,start=start) if (optimizer[2]=="nlm") { b <- nlm(gam4objective, lsp, typsize = lsp, fscale = fscale, stepmax = control$nlm$stepmax, ndigit = control$nlm$ndigit, gradtol = control$nlm$gradtol, steptol = control$nlm$steptol, iterlim = control$nlm$iterlim, check.analyticals=control$nlm$check.analyticals, args=args,...) lsp <- b$estimate } else if (optimizer[2]=="optim") { b<-optim(par=lsp,fn=gam2objective,gr=gam2derivative,method="L-BFGS-B",control= list(fnscale=fscale,factr=control$optim$factr,lmm=min(5,length(lsp))),args=args,...) lsp <- b$par } else b <- NULL obj <- gam2objective(lsp,args,printWarn=TRUE,...) # final model fit, with warnings object <- attr(obj,"full.fit") object$gcv.ubre <- as.numeric(obj) object$outer.info <- b object$sp <- exp(lsp) } # end of methods calling gam.fit2 if (scale>0) { object$scale.estimated <- FALSE; object$scale <- scale} else { object$scale <- object$scale.est;object$scale.estimated <- TRUE } object$control <- control object$method <- method if (inherits(family,"general.family")) { mv <- gam.fit5.post.proc(object,G$Sl,G$L,G$lsp0,G$S,G$off) ## object$coefficients <- Sl.initial.repara(G$Sl,object$coefficients,inverse=TRUE) } else mv <- gam.fit3.post.proc(G$X,G$L,G$lsp0,G$S,G$off,object) ## note: use of the following in place of Vp appears to mess up p-values for smooths, ## but doesn't change r.e. p-values of course. if (!is.null(mv$Vc)) object$Vc <- mv$Vc if (!is.null(mv$edf2)) object$edf2 <- mv$edf2 object$Vp <- mv$Vb object$hat<-mv$hat object$Ve <- mv$Ve object$edf<-mv$edf object$edf1 <- mv$edf1 ##object$F <- mv$F ## DoF matrix --- probably not needed object$R <- mv$R ## qr.R(sqrt(W)X) object$aic <- object$aic + 2*sum(mv$edf) object$nsdf <- G$nsdf object$K <- object$D1 <- object$D2 <- object$P <- object$P1 <- object$P2 <- object$GACV <- object$GACV1 <- object$GACV2 <- object$REML <- object$REML1 <- object$REML2 <- object$GCV<-object$GCV1<- object$GCV2 <- object$UBRE <-object$UBRE1 <- object$UBRE2 <- object$trA <- object$trA1<- object$trA2 <- object$alpha <- object$alpha1 <- object$scale.est <- NULL object$sig2 <- object$scale object } ## gam.outer get.null.coef <- function(G,start=NULL,etastart=NULL,mustart=NULL,...) { ## Get an estimate of the coefs corresponding to maximum reasonable deviance... y <- G$y weights <- G$w nobs <- G$n ## ignore codetools warning!! ##start <- etastart <- mustart <- NULL family <- G$family eval(family$initialize) ## have to do this to ensure y numeric y <- as.numeric(y) mum <- mean(y)+0*y etam <- family$linkfun(mum) null.coef <- qr.coef(qr(G$X),etam) null.coef[is.na(null.coef)] <- 0; ## get a suitable function scale for optimization routines null.scale <- sum(family$dev.resids(y,mum,weights))/nrow(G$X) list(null.coef=null.coef,null.scale=null.scale) } estimate.gam <- function (G,method,optimizer,control,in.out,scale,gamma,start=NULL,...) { ## Do gam estimation and smoothness selection... if (inherits(G$family,"extended.family")) { ## then there are some restrictions... if (!(method%in%c("REML","ML"))) method <- "REML" if (optimizer[1]=="perf") optimizer <- c("outer","newton") if (inherits(G$family,"general.family")) { #if (!is.null(G$offset)) if (is.list(G$offset)) { for (i in 1:length(G$offset)) # if (!is.null(G$offset[[i]])) warning("sorry, general families currently ignore offsets") #} else if (sum(G$offset!=0)>0) warning("sorry, general families currently ignore offsets") method <- "REML" ## any method you like as long as it's REML G$Sl <- Sl.setup(G) ## prepare penalty sequence ## Xorig <- G$X ## store original X incase it is needed by family - poor option pre=proc can manipulate G$X G$X <- Sl.initial.repara(G$Sl,G$X,both.sides=FALSE) ## re-parameterize accordingly if (!is.null(start)) start <- Sl.initial.repara(G$Sl,start,inverse=FALSE,both.sides=FALSE) #if (!is.null(G$offset)) { # ok <- FALSE # if (is.list(G$offset)) { # for (i in 1:length(G$offset)) if (!is.null(G$offset[[i]]) && sum(G$offset[[i]]!=0)) ok <- TRUE # } else if (sum(G$offset!=0)) ok <- TRUE # if (ok) attr(G$X,"offset") <- G$offset ## pass offsets on to family if they are not all null #} ## make sure optimizer appropriate for available derivatives if (!is.null(G$family$available.derivs)) { if (G$family$available.deriv==1 && optimizer[1]!="efs") optimizer <- c("outer","bfgs") if (G$family$available.derivs==0) optimizer <- "efs" } } } if (!optimizer[1]%in%c("perf","outer","efs")) stop("unknown optimizer") if (!method%in%c("GCV.Cp","GACV.Cp","REML","P-REML","ML","P-ML")) stop("unknown smoothness selection criterion") G$family <- fix.family(G$family) G$rS <- mini.roots(G$S,G$off,ncol(G$X),G$rank) if (method%in%c("REML","P-REML","ML","P-ML")) { if (optimizer[1]=="perf") { warning("Reset optimizer to outer/newton") optimizer <- c("outer","newton") } reml <- TRUE } else reml <- FALSE ## experimental insert Ssp <- totalPenaltySpace(G$S,G$H,G$off,ncol(G$X)) G$Eb <- Ssp$E ## balanced penalty square root for rank determination purposes G$U1 <- cbind(Ssp$Y,Ssp$Z) ## eigen space basis G$Mp <- ncol(Ssp$Z) ## null space dimension G$UrS <- list() ## need penalty matrices in overall penalty range space... if (length(G$S)>0) for (i in 1:length(G$S)) G$UrS[[i]] <- t(Ssp$Y)%*%G$rS[[i]] else i <- 0 if (!is.null(G$H)) { ## then the sqrt fixed penalty matrix H is needed for (RE)ML G$UrS[[i+1]] <- t(Ssp$Y)%*%mroot(G$H) } # is outer looping needed ? outer.looping <- ((!G$am && (optimizer[1]!="perf"))||reml||method=="GACV.Cp") ## && length(G$S)>0 && sum(G$sp<0)!=0 ## sort out exact sp selection criterion to use fam.name <- G$family$family[1] if (scale==0) { ## choose criterion for performance iteration if (fam.name == "binomial"||fam.name == "poisson") G$sig2<-1 #ubre else G$sig2 <- -1 #gcv } else {G$sig2 <- scale} if (reml) { ## then RE(ML) selection, but which variant? criterion <- method if (fam.name == "binomial"||fam.name == "poisson") scale <- 1 if (inherits(G$family,"extended.family") && scale <=0) { scale <- if (is.null(G$family$scale)) 1 else G$family$scale } } else { if (scale==0) { if (fam.name=="binomial"||fam.name=="poisson") scale <- 1 #ubre else scale <- -1 #gcv } if (scale > 0) criterion <- "UBRE" else { if (method=="GCV.Cp") criterion <- "GCV" else criterion <- "GACV" } } if (substr(fam.name,1,17)=="Negative Binomial") { scale <- 1; ## no choice if (method%in%c("GCV.Cp","GACV.Cp")) criterion <- "UBRE" } ## Reset P-ML or P-REML in known scale parameter cases if (scale>0) { if (method=="P-ML") criterion <- method <- "ML" else if (method=="P-REML") criterion <- method <- "REML" } # take only a few IRLS steps to get scale estimates for "pure" outer # looping... family <- G$family; nb.fam.reset <- FALSE if (outer.looping) { ## how many performance iteration steps to use for initialization... fixedSteps <- if (inherits(G$family,"extended.family")) 0 else control$outerPIsteps if (substr(G$family$family[1],1,17)=="Negative Binomial") { ## initialize sensibly scale <- G$sig2 <- 1 G$family <- negbin(max(family$getTheta()),link=family$link) nb.fam.reset <- TRUE } } else fixedSteps <- control$maxit+2 ## extended family may need to manipulate G... if (!is.null(G$family$preinitialize)) eval(G$family$preinitialize) if (length(G$sp)>0) lsp2 <- log(initial.spg(G$X,G$y,G$w,G$family,G$S,G$rank,G$off, offset=G$offset,L=G$L,lsp0=G$lsp0,E=G$Eb,...)) else lsp2 <- rep(0,0) if (outer.looping && !is.null(in.out)) { # initial s.p.s and scale provided ok <- TRUE ## run a few basic checks if (is.null(in.out$sp)||is.null(in.out$scale)) ok <- FALSE if (length(in.out$sp)!=length(G$sp)) ok <- FALSE if (!ok) stop("in.out incorrect: see documentation") lsp <- log(in.out$sp) } else {## do performance iteration.... if (fixedSteps>0) { object <- gam.fit(G,family=G$family,control=control,gamma=gamma,fixedSteps=fixedSteps,...) lsp <- log(object$sp) } else { lsp <- lsp2 } } if (nb.fam.reset) G$family <- family ## restore, in case manipulated for negative binomial if (outer.looping) { # don't allow PI initial sp's too far from defaults, otherwise optimizers may # get stuck on flat portions of GCV/UBRE score.... if (is.null(in.out)&&length(lsp)>0) { ## note no checks if supplied ind <- lsp > lsp2+5;lsp[ind] <- lsp2[ind]+5 ind <- lsp < lsp2-5;lsp[ind] <- lsp2[ind]-5 } ## Get an estimate of the coefs corresponding to maximum reasonable deviance, ## and an estimate of the function scale, suitable for optimizers that need this. ## Doesn't make sense for general families that have to initialize coefs directly. null.stuff <- if(inherits(G$family,"general.family")) list() else get.null.coef(G,...) if (fixedSteps>0&&is.null(in.out)) mgcv.conv <- object$mgcv.conv else mgcv.conv <- NULL if (criterion%in%c("REML","ML")&&scale<=0) { ## log(scale) to be estimated as a smoothing parameter if (fixedSteps>0) { log.scale <- log(sum(object$weights*object$residuals^2)/(G$n-sum(object$edf))) } else { if (is.null(in.out)) { log.scale <- log(null.stuff$null.scale/10) } else { log.scale <- log(in.out$scale) } } lsp <- c(lsp,log.scale) ## append log initial scale estimate to lsp ## extend G$L, if present... if (!is.null(G$L)) { G$L <- cbind(rbind(G$L,rep(0,ncol(G$L))),c(rep(0,nrow(G$L)),1)) #attr(G$L,"scale") <- TRUE ## indicates scale estimated as sp } if (!is.null(G$lsp0)) G$lsp0 <- c(G$lsp0,0) } ## check if there are extra parameters to estimate if (inherits(G$family,"extended.family")&&!inherits(G$family,"general.family")&&G$family$n.theta>0) { th0 <- G$family$getTheta() ## additional (initial) parameters of likelihood nth <- length(th0) nlsp <- length(lsp) ind <- 1:nlsp + nth ## only used if nlsp>0 lsp <- c(th0,lsp) ## append to start of lsp ## extend G$L, G$lsp0 if present... if (!is.null(G$L)&&nth>0) { L <- rbind(cbind(diag(nth),matrix(0,nth,ncol(G$L))), cbind(matrix(0,nrow(G$L),nth),G$L)) #sat <- attr(G$L,"scale") G$L <- L #attr(G$L,"scale") <- sat #attr(G$L,"not.sp") <- nth ## first not.sp params are not smoothing params } if (!is.null(G$lsp0)) G$lsp0 <- c(th0*0,G$lsp0) } else nth <- 0 G$null.coef <- null.stuff$null.coef object <- gam.outer(lsp,fscale=null.stuff$null.scale, ##abs(object$gcv.ubre)+object$sig2/length(G$y), family=G$family,control=control,criterion=criterion,method=method, optimizer=optimizer,scale=scale,gamma=gamma,G=G,start=start,...) if (criterion%in%c("REML","ML")&&scale<=0) object$sp <- object$sp[-length(object$sp)] ## drop scale estimate from sp array if (inherits(G$family,"extended.family")&&nth>0) object$sp <- object$sp[-(1:nth)] ## drop theta params object$mgcv.conv <- mgcv.conv } ## finished outer looping ## correct null deviance if there's an offset [Why not correct calc in gam.fit/3???].... if (!inherits(G$family,"extended.family")&&G$intercept&&any(G$offset!=0)) object$null.deviance <- glm(object$y~offset(G$offset),family=object$family,weights=object$prior.weights)$deviance object$method <- criterion object$smooth<-G$smooth names(object$edf) <- G$term.names names(object$edf1) <- G$term.names if (inherits(family,"general.family")) { object$coefficients <- Sl.initial.repara(G$Sl,object$coefficients,inverse=TRUE) } ## extended family may need to manipulate fit object. Code ## will need to include the following line if G$X used... ## G$X <- Sl.initial.repara(G$Sl,G$X,inverse=TRUE,cov=FALSE,both.sides=FALSE) if (!is.null(G$family$postproc)) eval(G$family$postproc) if (!is.null(G$P)) { ## matrix transforming from fit to prediction parameterization object$coefficients <- as.numeric(G$P %*% object$coefficients) object$Vp <- G$P %*% object$Vp %*% t(G$P) object$Ve <- G$P %*% object$Ve %*% t(G$P) rownames(object$Vp) <- colnames(object$Vp) <- G$term.names rownames(object$Ve) <- colnames(object$Ve) <- G$term.names } names(object$coefficients) <- G$term.names object } ## end estimate.gam variable.summary <- function(pf,dl,n) { ## routine to summarize all the variables in dl, which is a list ## containing raw input variables to a model (i.e. no functions applied) ## pf is a formula containing the strictly parametric part of the ## model for the variables in dl. A list is returned, with names given by ## the variables. For variables in the parametric part, then the list elements ## may be: ## * a 1 column matrix with elements set to the column medians, if variable ## is a matrix. ## * a 3 figure summary (min,median,max) for a numeric variable. ## * a factor variable, with the most commonly occuring factor (all levels) ## --- classes are as original data type, but anything not numeric, factor or matrix ## is coerced to numeric. ## For non-parametric variables, any matrices are coerced to numeric, otherwise as ## parametric. ## medians in the above are always observed values (to deal with variables coerced to ## factors in the model formulae in a nice way). ## variables with less than `n' entries are discarded v.n <- length(dl) ## if (v.n) for (i in 1:v.n) if (length(dl[[i]])=n) { k <- k+1 v.name[k] <- v.name1[i] ## save names of variables of correct length } if (k>0) v.name <- v.name[1:k] else v.name <- rep("",k) } ## v.name <- names(dl) ## the variable names p.name <- all.vars(pf[-2]) ## variables in parametric part (not response) vs <- list() v.n <- length(v.name) if (v.n>0) for (i in 1:v.n) { if (v.name[i]%in%p.name) para <- TRUE else para <- FALSE ## is variable in the parametric part? if (para&&is.matrix(dl[[v.name[i]]])&&ncol(dl[[v.name[i]]])>1) { ## parametric matrix --- a special case x <- matrix(apply(dl[[v.name[i]]],2,quantile,probs=0.5,type=3,na.rm=TRUE),1,ncol(dl[[v.name[i]]])) ## nearest to median entries } else { ## anything else x <- dl[[v.name[i]]] if (is.character(x)) x <- as.factor(x) if (is.factor(x)) { x <- x[!is.na(x)] lx <- levels(x) freq <- tabulate(x) ii <- min((1:length(lx))[freq==max(freq)]) x <- factor(lx[ii],levels=lx) } else { x <- as.numeric(x) x <- c(min(x,na.rm=TRUE),as.numeric(quantile(x,probs=.5,type=3,na.rm=TRUE)) ,max(x,na.rm=TRUE)) ## 3 figure summary } } vs[[v.name[i]]] <- x } vs } ## end variable.summary ## don't be tempted to change to control=list(...) --- messes up passing on other stuff via ... gam <- function(formula,family=gaussian(),data=list(),weights=NULL,subset=NULL,na.action,offset=NULL, method="GCV.Cp",optimizer=c("outer","newton"),control=list(),#gam.control(), scale=0,select=FALSE,knots=NULL,sp=NULL,min.sp=NULL,H=NULL,gamma=1,fit=TRUE, paraPen=NULL,G=NULL,in.out=NULL,drop.unused.levels=TRUE,drop.intercept=NULL,...) { ## Routine to fit a GAM to some data. The model is stated in the formula, which is then ## interpreted to figure out which bits relate to smooth terms and which to parametric terms. ## Basic steps: ## 1. Formula is split up into parametric and non-parametric parts, ## and a fake formula constructed to be used to pick up data for ## model frame. pterms "terms" object(s) created for parametric ## components, model frame created along with terms object. ## 2. 'gam.setup' called to do most of basis construction and other ## elements of model setup. ## 3. 'estimate.gam' is called to estimate the model. This performs further ## pre- and post- fitting steps and calls either 'gam.fit' (performance ## iteration) or 'gam.outer' (default method). 'gam.outer' calls the actual ## smoothing parameter optimizer ('newton' by default) and then any post ## processing. The optimizer calls 'gam.fit3/4/5' to estimate the model ## coefficients and obtain derivatives w.r.t. the smoothing parameters. ## 4. Finished 'gam' object assembled. control <- do.call("gam.control",control) if (is.null(G)) { ## create model frame..... gp <- interpret.gam(formula) # interpret the formula cl <- match.call() # call needed in gam object for update to work mf <- match.call(expand.dots=FALSE) mf$formula <- gp$fake.formula mf$family <- mf$control<-mf$scale<-mf$knots<-mf$sp<-mf$min.sp<-mf$H<-mf$select <- mf$drop.intercept <- mf$gamma<-mf$method<-mf$fit<-mf$paraPen<-mf$G<-mf$optimizer <- mf$in.out <- mf$...<-NULL mf$drop.unused.levels <- drop.unused.levels mf[[1]] <- quote(stats::model.frame) ## as.name("model.frame") pmf <- mf mf <- eval(mf, parent.frame()) # the model frame now contains all the data if (nrow(mf)<2) stop("Not enough (non-NA) data to do anything meaningful") terms <- attr(mf,"terms") ## summarize the *raw* input variables ## note can't use get_all_vars here -- buggy with matrices vars <- all.vars1(gp$fake.formula[-2]) ## drop response here inp <- parse(text = paste("list(", paste(vars, collapse = ","),")")) ## allow a bit of extra flexibility in what `data' is allowed to be (as model.frame actually does) if (!is.list(data)&&!is.data.frame(data)) data <- as.data.frame(data) dl <- eval(inp, data, parent.frame()) names(dl) <- vars ## list of all variables needed var.summary <- variable.summary(gp$pf,dl,nrow(mf)) ## summarize the input data rm(dl) ## save space ## pterms are terms objects for the parametric model components used in ## model setup - don't try obtaining by evaluating pf in mf - doesn't ## work in general (e.g. with offset)... if (is.list(formula)) { ## then there are several linear predictors environment(formula) <- environment(formula[[1]]) ## e.g. termplots needs this pterms <- list() tlab <- rep("",0) for (i in 1:length(formula)) { pmf$formula <- gp[[i]]$pf pterms[[i]] <- attr(eval(pmf, parent.frame()),"terms") tlabi <- attr(pterms[[i]],"term.labels") if (i>1&&length(tlabi)>0) tlabi <- paste(tlabi,i-1,sep=".") tlab <- c(tlab,tlabi) } attr(pterms,"term.labels") <- tlab ## labels for all parametric terms, distinguished by predictor } else { ## single linear predictor case pmf$formula <- gp$pf pmf <- eval(pmf, parent.frame()) # pmf contains all data for parametric part pterms <- attr(pmf,"terms") ## pmf only used for this } if (is.character(family)) family <- eval(parse(text=family)) if (is.function(family)) family <- family() if (is.null(family$family)) stop("family not recognized") if (family$family[1]=="gaussian" && family$link=="identity") am <- TRUE else am <- FALSE if (!control$keepData) rm(data) ## save space ## check whether family requires intercept to be dropped... # drop.intercept <- if (is.null(family$drop.intercept) || !family$drop.intercept) FALSE else TRUE # drop.intercept <- as.logical(family$drop.intercept) if (is.null(family$drop.intercept)) { ## family does not provide information lengthf <- if (is.list(formula)) length(formula) else 1 if (is.null(drop.intercept)) drop.intercept <- rep(FALSE, lengthf) else { drop.intercept <- rep(drop.intercept,length=lengthf) ## force drop.intercept to correct length if (sum(drop.intercept)) family$drop.intercept <- drop.intercept ## ensure prediction works } } else drop.intercept <- as.logical(family$drop.intercept) ## family overrides argument if (inherits(family,"general.family")&&!is.null(family$presetup)) eval(family$presetup) gsname <- if (is.list(formula)) "gam.setup.list" else "gam.setup" G <- do.call(gsname,list(formula=gp,pterms=pterms, data=mf,knots=knots,sp=sp,min.sp=min.sp, H=H,absorb.cons=TRUE,sparse.cons=0,select=select, idLinksBases=control$idLinksBases,scale.penalty=control$scalePenalty, paraPen=paraPen,drop.intercept=drop.intercept)) G$var.summary <- var.summary G$family <- family if ((is.list(formula)&&(is.null(family$nlp)||family$nlp!=gp$nlp))|| (!is.list(formula)&&!is.null(family$npl)&&(family$npl>1))) stop("incorrect number of linear predictors for family") if (ncol(G$X)>nrow(G$X)) stop("Model has more coefficients than data") G$terms<-terms; G$mf<-mf;G$cl<-cl; G$am <- am if (is.null(G$offset)) G$offset<-rep(0,G$n) G$min.edf <- G$nsdf ## -dim(G$C)[1] if (G$m) for (i in 1:G$m) G$min.edf<-G$min.edf+G$smooth[[i]]$null.space.dim G$formula <- formula G$pred.formula <- gp$pred.formula environment(G$formula)<-environment(formula) } if (!fit) return(G) G$conv.tol <- control$mgcv.tol # tolerence for mgcv G$max.half <- control$mgcv.half # max step halving in Newton update mgcv object <- estimate.gam(G,method,optimizer,control,in.out,scale,gamma,...) if (!is.null(G$L)) { object$full.sp <- as.numeric(exp(G$L%*%log(object$sp)+G$lsp0)) names(object$full.sp) <- names(G$lsp0) } names(object$sp) <- names(G$sp) object$paraPen <- G$pP object$formula <- G$formula ## store any lpi attribute of G$X for use in predict.gam... if (is.list(object$formula)) attr(object$formula,"lpi") <- attr(G$X,"lpi") object$var.summary <- G$var.summary object$cmX <- G$cmX ## column means of model matrix --- useful for CIs object$model<-G$mf # store the model frame object$na.action <- attr(G$mf,"na.action") # how to deal with NA's object$control <- control object$terms <- G$terms object$pred.formula <- G$pred.formula attr(object$pred.formula,"full") <- reformulate(all.vars(object$terms)) object$pterms <- G$pterms object$assign <- G$assign # applies only to pterms object$contrasts <- G$contrasts object$xlevels <- G$xlevels object$offset <- G$offset if (!is.null(G$Xcentre)) object$Xcentre <- G$Xcentre if (control$keepData) object$data <- data object$df.residual <- nrow(G$X) - sum(object$edf) object$min.edf <- G$min.edf if (G$am&&!(method%in%c("REML","ML","P-ML","P-REML"))) object$optimizer <- "magic" else object$optimizer <- optimizer object$call <- G$cl # needed for update() to work class(object) <- c("gam","glm","lm") if (is.null(object$deviance)) object$deviance <- sum(residuals(object,"deviance")^2) names(object$gcv.ubre) <- method environment(object$formula) <- environment(object$pred.formula) <- environment(object$terms) <- environment(object$pterms) <- .GlobalEnv if (!is.null(object$model)) environment(attr(object$model,"terms")) <- .GlobalEnv if (!is.null(attr(object$pred.formula,"full"))) environment(attr(object$pred.formula,"full")) <- .GlobalEnv object } ## gam print.gam<-function (x,...) # default print function for gam objects { print(x$family) cat("Formula:\n") if (is.list(x$formula)) for (i in 1:length(x$formula)) print(x$formula[[i]]) else print(x$formula) n.smooth<-length(x$smooth) if (n.smooth==0) cat("Total model degrees of freedom",sum(x$edf),"\n") else { edf<-0 cat("\nEstimated degrees of freedom:\n") for (i in 1:n.smooth) edf[i]<-sum(x$edf[x$smooth[[i]]$first.para:x$smooth[[i]]$last.para]) edf.str <- format(round(edf,digits=4),digits=3,scientific=FALSE) for (i in 1:n.smooth) { cat(edf.str[i]," ",sep="") if (i%%7==0) cat("\n") } cat(" total =",round(sum(x$edf),digits=2),"\n") } if (!is.null(x$method)&&!(x$method%in%c("PQL","lme.ML","lme.REML"))) cat("\n",x$method," score: ",x$gcv.ubre," ",sep="") if (!is.null(x$rank) && x$rank< length(x$coefficients)) cat("rank: ",x$rank,"/",length(x$coefficients),sep="") cat("\n") invisible(x) } gam.control <- function (nthreads=1,irls.reg=0.0,epsilon = 1e-7, maxit = 200, mgcv.tol=1e-7,mgcv.half=15,trace =FALSE, rank.tol=.Machine$double.eps^0.5, nlm=list(),optim=list(),newton=list(),outerPIsteps=0, idLinksBases=TRUE,scalePenalty=TRUE, keepData=FALSE,scale.est="fletcher",edge.correct=FALSE) # Control structure for a gam. # irls.reg is the regularization parameter to use in the GAM fitting IRLS loop. # epsilon is the tolerance to use in the IRLS MLE loop. maxit is the number # of IRLS iterations to use. mgcv.tol is the tolerance to use in the mgcv call within each IRLS. mgcv.half is the # number of step halvings to employ in the mgcv search for the optimal GCV score, before giving up # on a search direction. trace turns on or off some de-bugging information. # rank.tol is the tolerance to use for rank determination # outerPIsteps is the number of performance iteration steps used to intialize # outer iteration { scale.est <- match.arg(scale.est,c("fletcher","pearson","deviance")) if (!is.logical(edge.correct)&&(!is.numeric(edge.correct)||edge.correct<0)) stop( "edge.correct must be logical or a positive number") if (!is.numeric(nthreads) || nthreads <1) stop("nthreads must be a positive integer") if (!is.numeric(irls.reg) || irls.reg <0.0) stop("IRLS regularizing parameter must be a non-negative number.") if (!is.numeric(epsilon) || epsilon <= 0) stop("value of epsilon must be > 0") if (!is.numeric(maxit) || maxit <= 0) stop("maximum number of iterations must be > 0") if (rank.tol<0||rank.tol>1) { rank.tol=.Machine$double.eps^0.5 warning("silly value supplied for rank.tol: reset to square root of machine precision.") } # work through nlm defaults if (is.null(nlm$ndigit)||nlm$ndigit<2) nlm$ndigit <- max(2,ceiling(-log10(epsilon))) nlm$ndigit <- round(nlm$ndigit) ndigit <- floor(-log10(.Machine$double.eps)) if (nlm$ndigit>ndigit) nlm$ndigit <- ndigit if (is.null(nlm$gradtol)) nlm$gradtol <- epsilon*10 nlm$gradtol <- abs(nlm$gradtol) ## note that nlm will stop after hitting stepmax 5 consecutive times ## hence should not be set too small ... if (is.null(nlm$stepmax)||nlm$stepmax==0) nlm$stepmax <- 2 nlm$stepmax <- abs(nlm$stepmax) if (is.null(nlm$steptol)) nlm$steptol <- 1e-4 nlm$steptol <- abs(nlm$steptol) if (is.null(nlm$iterlim)) nlm$iterlim <- 200 nlm$iterlim <- abs(nlm$iterlim) ## Should be reset for a while anytime derivative code altered... if (is.null(nlm$check.analyticals)) nlm$check.analyticals <- FALSE nlm$check.analyticals <- as.logical(nlm$check.analyticals) # and newton defaults if (is.null(newton$conv.tol)) newton$conv.tol <- 1e-6 if (is.null(newton$maxNstep)) newton$maxNstep <- 5 if (is.null(newton$maxSstep)) newton$maxSstep <- 2 if (is.null(newton$maxHalf)) newton$maxHalf <- 30 if (is.null(newton$use.svd)) newton$use.svd <- FALSE # and optim defaults if (is.null(optim$factr)) optim$factr <- 1e7 optim$factr <- abs(optim$factr) list(nthreads=round(nthreads),irls.reg=irls.reg,epsilon = epsilon, maxit = maxit, trace = trace, mgcv.tol=mgcv.tol,mgcv.half=mgcv.half, rank.tol=rank.tol,nlm=nlm, optim=optim,newton=newton,outerPIsteps=outerPIsteps, idLinksBases=idLinksBases,scalePenalty=scalePenalty, keepData=as.logical(keepData[1]),scale.est=scale.est,edge.correct=edge.correct) } mgcv.get.scale<-function(Theta,weights,good,mu,mu.eta.val,G) # Get scale implied by current fit and trial -ve binom Theta, I've used # mu and mu.eta.val used in fit rather than implied by it.... { variance<- negbin(Theta)$variance w<-sqrt(weights[good]*mu.eta.val[good]^2/variance(mu)[good]) wres<-w*(G$y-G$X%*%G$p) sum(wres^2)/(G$n-sum(G$edf)) } mgcv.find.theta<-function(Theta,T.max,T.min,weights,good,mu,mu.eta.val,G,tol) # searches for -ve binomial theta between given limits to get scale=1 { scale<-mgcv.get.scale(Theta,weights,good,mu,mu.eta.val,G) T.hi<-T.low<-Theta while (scale<1&&T.hi=1&&T.low>T.min) { T.low<-T.low/2 T.low<-max(T.low,T.min) scale<-mgcv.get.scale(T.low,weights,good,mu,mu.eta.val,G) } if (all.equal(T.low,T.min)==TRUE && scale>1) return(T.low) # (T.low,T.hi) now brackets scale=1. while (abs(scale-1)>tol) { Theta<-(T.low+T.hi)/2 scale<-mgcv.get.scale(Theta,weights,good,mu,mu.eta.val,G) if (scale<1) T.low<-Theta else T.hi<-Theta } Theta } full.score <- function(sp,G,family,control,gamma,...) # function suitable for calling from nlm in order to polish gam fit # so that actual minimum of score is found in generalized cases { if (is.null(G$L)) { G$sp<-exp(sp); } else { G$sp <- as.numeric(exp(G$L%*%sp + G$lsp0)) } # set up single fixed penalty.... q<-NCOL(G$X) if (is.null(G$H)) G$H<-matrix(0,q,q) for (i in 1:length(G$S)) { j<-ncol(G$S[[i]]) off1<-G$off[i];off2<-off1+j-1 G$H[off1:off2,off1:off2]<-G$H[off1:off2,off1:off2]+G$sp[i]*G$S[[i]] } G$S<-list() # have to reset since length of this is used as number of penalties G$L <- NULL xx<-gam.fit(G,family=family,control=control,gamma=gamma,...) res <- xx$gcv.ubre.dev attr(res,"full.gam.object")<-xx res } gam.fit <- function (G, start = NULL, etastart = NULL, mustart = NULL, family = gaussian(), control = gam.control(),gamma=1, fixedSteps=(control$maxit+1),...) # fitting function for a gam, modified from glm.fit. # note that smoothing parameter estimates from one irls iterate are carried over to the next irls iterate # unless the range of s.p.s is large enough that numerical problems might be encountered (want to avoid # completely flat parts of gcv/ubre score). In the latter case autoinitialization is requested. # fixedSteps < its default causes at most fixedSteps iterations to be taken, # without warning if convergence has not been achieved. This is useful for # obtaining starting values for outer iteration. { intercept<-G$intercept conv <- FALSE n <- nobs <- NROW(G$y) ## n just there to keep codetools happy nvars <- NCOL(G$X) # check this needed y<-G$y # original data X<-G$X # original design matrix if (nvars == 0) stop("Model seems to contain no terms") olm <- G$am # only need 1 iteration as it's a pure additive model. find.theta<-FALSE # any supplied -ve binomial theta treated as known, G$sig2 is scale parameter if (substr(family$family[1],1,17)=="Negative Binomial") { Theta <- family$getTheta() if (length(Theta)==1) { ## Theta fixed find.theta <- FALSE G$sig2 <- 1 } else { if (length(Theta)>2) warning("Discrete Theta search not available with performance iteration") Theta <- range(Theta) T.max <- Theta[2] ## upper search limit T.min <- Theta[1] ## lower search limit Theta <- sqrt(T.max*T.min) ## initial value find.theta <- TRUE } nb.link<-family$link # negative.binomial family, there's a choise of links } # obtain average element sizes for the penalties n.S<-length(G$S) if (n.S>0) { S.size<-0 for (i in 1:n.S) S.size[i]<-mean(abs(G$S[[i]])) } weights<-G$w # original weights n.score <- sum(weights!=0) ## n to use in GCV score (i.e. don't count points with no influence) offset<-G$offset variance <- family$variance;dev.resids <- family$dev.resids aic <- family$aic linkinv <- family$linkinv;linkfun <- family$linkfun;mu.eta <- family$mu.eta if (!is.function(variance) || !is.function(linkinv)) stop("illegal `family' argument") valideta <- family$valideta if (is.null(valideta)) valideta <- function(eta) TRUE validmu <- family$validmu if (is.null(validmu)) validmu <- function(mu) TRUE if (is.null(mustart)) # new from version 1.5.0 { eval(family$initialize)} else { mukeep <- mustart eval(family$initialize) mustart <- mukeep } if (NCOL(y) > 1) stop("y must be univariate unless binomial") coefold <- NULL # 1.5.0 eta <- if (!is.null(etastart)) # 1.5.0 etastart else if (!is.null(start)) if (length(start) != nvars) stop(gettextf("Length of start should equal %d and correspond to initial coefs.",nvars)) else { coefold<-start #1.5.0 offset+as.vector(if (NCOL(G$X) == 1) G$X * start else G$X %*% start) } else family$linkfun(mustart) mu <- linkinv(eta) if (!(validmu(mu) && valideta(eta))) stop("Can't find valid starting values: please specify some") devold <- sum(dev.resids(y, mu, weights)) boundary <- FALSE scale <- G$sig2 msp <- G$sp magic.control<-list(tol=G$conv.tol,step.half=G$max.half,#maxit=control$maxit+control$globit, rank.tol=control$rank.tol) for (iter in 1:(control$maxit)) { good <- weights > 0 varmu <- variance(mu)[good] if (any(is.na(varmu))) stop("NAs in V(mu)") if (any(varmu == 0)) stop("0s in V(mu)") mu.eta.val <- mu.eta(eta) if (any(is.na(mu.eta.val[good]))) stop("NAs in d(mu)/d(eta)") good <- (weights > 0) & (mu.eta.val != 0) # note good modified here => must re-calc each iter if (all(!good)) { conv <- FALSE warning(gettextf("No observations informative at iteration %d", iter)) break } mevg <- mu.eta.val[good];mug <- mu[good];yg <- y[good] weg <- weights[good];##etag <- eta[good] var.mug<-variance(mug) G$y <- z <- (eta - offset)[good] + (yg - mug)/mevg w <- sqrt((weg * mevg^2)/var.mug) G$w<-w G$X<-X[good,,drop=FALSE] # truncated design matrix # must set G$sig2 to scale parameter or -1 here.... G$sig2 <- scale if (sum(!is.finite(G$y))+sum(!is.finite(G$w))>0) stop("iterative weights or data non-finite in gam.fit - regularization may help. See ?gam.control.") ## solve the working weighted penalized LS problem ... mr <- magic(G$y,G$X,msp,G$S,G$off,L=G$L,lsp0=G$lsp0,G$rank,G$H,matrix(0,0,ncol(G$X)), #G$C, G$w,gamma=gamma,G$sig2,G$sig2<0, ridge.parameter=control$irls.reg,control=magic.control,n.score=n.score,nthreads=control$nthreads) G$p<-mr$b;msp<-mr$sp;G$sig2<-mr$scale;G$gcv.ubre<-mr$score; if (find.theta) {# then family is negative binomial with unknown theta - estimate it here from G$sig2 ## need to get edf array mv <- magic.post.proc(G$X,mr,w=G$w^2) G$edf <- mv$edf Theta<-mgcv.find.theta(Theta,T.max,T.min,weights,good,mu,mu.eta.val,G,.Machine$double.eps^0.5) family<-do.call("negbin",list(theta=Theta,link=nb.link)) variance <- family$variance;dev.resids <- family$dev.resids aic <- family$aic family$Theta <- Theta ## save Theta estimate in family } if (any(!is.finite(G$p))) { conv <- FALSE warning(gettextf("Non-finite coefficients at iteration %d",iter)) break } start <- G$p eta <- drop(X %*% start) # 1.5.0 mu <- linkinv(eta <- eta + offset) eta <- linkfun(mu) # force eta/mu consistency even if linkinv truncates dev <- sum(dev.resids(y, mu, weights)) if (control$trace) message(gettextf("Deviance = %s Iterations - %d", dev, iter, domain = "R-mgcv")) boundary <- FALSE if (!is.finite(dev)) { if (is.null(coefold)) stop("no valid set of coefficients has been found:please supply starting values", call. = FALSE) warning("Step size truncated due to divergence",call.=FALSE) ii <- 1 while (!is.finite(dev)) { if (ii > control$maxit) stop("inner loop 1; can't correct step size") ii <- ii + 1 start <- (start + coefold)/2 eta<-drop(X %*% start) mu <- linkinv(eta <- eta + offset) eta <- linkfun(mu) dev <- sum(dev.resids(y, mu, weights)) } boundary <- TRUE if (control$trace) cat("Step halved: new deviance =", dev, "\n") } if (!(valideta(eta) && validmu(mu))) { warning("Step size truncated: out of bounds.",call.=FALSE) ii <- 1 while (!(valideta(eta) && validmu(mu))) { if (ii > control$maxit) stop("inner loop 2; can't correct step size") ii <- ii + 1 start <- (start + coefold)/2 eta<-drop(X %*% start) mu <- linkinv(eta <- eta + offset) eta<-linkfun(mu) } boundary <- TRUE dev <- sum(dev.resids(y, mu, weights)) if (control$trace) cat("Step halved: new deviance =", dev, "\n") } ## Test for convergence here ... if (abs(dev - devold)/(0.1 + abs(dev)) < control$epsilon || olm || iter >= fixedSteps) { conv <- TRUE coef <- start #1.5.0 break } else { devold <- dev coefold <- coef<-start } } if (!conv) { warning("Algorithm did not converge") } if (boundary) warning("Algorithm stopped at boundary value") eps <- 10 * .Machine$double.eps if (family$family[1] == "binomial") { if (any(mu > 1 - eps) || any(mu < eps)) warning("fitted probabilities numerically 0 or 1 occurred") } if (family$family[1] == "poisson") { if (any(mu < eps)) warning("fitted rates numerically 0 occurred") } residuals <- rep(NA, nobs) residuals[good] <- z - (eta - offset)[good] wt <- rep(0, nobs) wt[good] <- w^2 wtdmu <- if (intercept) sum(weights * y)/sum(weights) else linkinv(offset) nulldev <- sum(dev.resids(y, wtdmu, weights)) n.ok <- nobs - sum(weights == 0) nulldf <- n.ok - as.integer(intercept) ## Extract a little more information from the fit.... mv <- magic.post.proc(G$X,mr,w=G$w^2) G$Vp<-mv$Vb;G$hat<-mv$hat; G$Ve <- mv$Ve # frequentist cov. matrix G$edf<-mv$edf G$conv<-mr$gcv.info G$sp<-msp rank<-G$conv$rank aic.model <- aic(y, n, mu, weights, dev) + 2 * sum(G$edf) if (scale < 0) { ## deviance based GCV gcv.ubre.dev <- n.score*dev/(n.score-gamma*sum(G$edf))^2 } else { # deviance based UBRE, which is just AIC gcv.ubre.dev <- dev/n.score + 2 * gamma * sum(G$edf)/n.score - G$sig2 } list(coefficients = as.vector(coef), residuals = residuals, fitted.values = mu, family = family,linear.predictors = eta, deviance = dev, null.deviance = nulldev, iter = iter, weights = wt, prior.weights = weights, df.null = nulldf, y = y, converged = conv,sig2=G$sig2,edf=G$edf,edf1=mv$edf1,hat=G$hat, ##F=mv$F, R=mr$R, boundary = boundary,sp = G$sp,nsdf=G$nsdf,Ve=G$Ve,Vp=G$Vp,rV=mr$rV,mgcv.conv=G$conv, gcv.ubre=G$gcv.ubre,aic=aic.model,rank=rank,gcv.ubre.dev=gcv.ubre.dev,scale.estimated = (scale < 0)) } ## gam.fit model.matrix.gam <- function(object,...) { if (!inherits(object,"gam")) stop("`object' is not of class \"gam\"") predict(object,type="lpmatrix",...) } get.na.action <- function(na.action) { ## get the name of the na.action whether function or text string. ## avoids deparse(substitute(na.action)) which is easily broken by ## nested calls. if (is.character(na.action)) { if (na.action%in%c("na.omit","na.exclude","na.pass","na.fail")) return(na.action) else stop("unrecognised na.action") } if (!is.function(na.action)) stop("na.action not character or function") a <- try(na.action(c(0,NA)),silent=TRUE) if (inherits(a,"try-error")) return("na.fail") if (inherits((attr(a,"na.action")),"omit")) return("na.omit") if (inherits((attr(a,"na.action")),"exclude")) return("na.exclude") return("na.pass") } ## get.na.action predict.gam <- function(object,newdata,type="link",se.fit=FALSE,terms=NULL,exclude=NULL, block.size=NULL,newdata.guaranteed=FALSE,na.action=na.pass, unconditional=FALSE,...) { # This function is used for predicting from a GAM. 'object' is a gam object, newdata a dataframe to # be used in prediction...... # # Type == "link" - for linear predictor (may be several for extended case) # == "response" - for fitted values: may be several if several linear predictors, # and may return something other than inverse link of l.p. for some families # == "terms" - for individual terms on scale of linear predictor # == "iterms" - exactly as "terms" except that se's include uncertainty about mean # == "lpmatrix" - for matrix mapping parameters to l.p. - has "lpi" attribute if multiple l.p.s # == "newdata" - returns newdata after pre-processing # Steps are: # 1. Set newdata to object$model if no newdata supplied # 2. split up newdata into manageable blocks if too large # 3. Obtain parametric model matrix (safely!) # 4. Work through smooths calling prediction.matrix constructors for each term # 5. Work out required quantities # # The splitting into blocks enables blocks of compiled code to be called efficiently # using smooth class specific prediction matrix constructors, without having to # build up potentially enormous prediction matrices. # if newdata.guaranteed == TRUE then the data.frame is assumed complete and # ready to go, so that only factor levels are checked for sanity. # # if `terms' is non null then it should be a list of terms to be returned # when type=="terms" or "iterms". # if `object' has an attribute `para.only' then only parametric terms of order # 1 are returned for type=="terms"/"iterms" : i.e. only what termplot can handle. # # if no new data is supplied then na.action does nothing, otherwise # if na.action == "na.pass" then NA predictors result in NA predictions (as lm # or glm) # == "na.omit" or "na.exclude" then NA predictors result in # dropping # if GC is TRUE then gc() is called after each block is processed ## para acts by adding all smooths to the exclude list. ## it also causes any lp matrix to be smaller than it would otherwise have been. #if (para) exclude <- c(exclude,unlist(lapply(object$smooth,function(x) x$label))) if (unconditional) { if (is.null(object$Vc)) warning("Smoothness uncertainty corrected covariance not available") else object$Vp <- object$Vc } if (type!="link"&&type!="terms"&&type!="iterms"&&type!="response"&&type!="lpmatrix"&&type!="newdata") { warning("Unknown type, reset to terms.") type<-"terms" } if (!inherits(object,"gam")) stop("predict.gam can only be used to predict from gam objects") ## to mimic behaviour of predict.lm, some resetting is required ... if (missing(newdata)) na.act <- object$na.action else { if (is.null(na.action)) na.act <- NULL else { na.txt <- if (is.character(na.action)||is.function(na.action)) get.na.action(na.action) else "na.pass" #if (is.character(na.action)) #na.txt <- na.action else ## substitute(na.action) else #if (is.function(na.action)) na.txt <- deparse(substitute(na.action)) if (na.txt=="na.pass") na.act <- "na.exclude" else if (na.txt=="na.exclude") na.act <- "na.omit" else na.act <- na.action } } ## ... done # get data from which to predict..... nd.is.mf <- FALSE # need to flag if supplied newdata is already a model frame ## get name of response... yname <- all.vars(object$terms)[attr(object$terms,"response")] if (newdata.guaranteed==FALSE) { if (missing(newdata)) { # then "fake" an object suitable for prediction newdata <- object$model new.data.ok <- FALSE nd.is.mf <- TRUE response <- newdata[[yname]] } else { # do an R ``standard'' evaluation to pick up data new.data.ok <- TRUE if (is.data.frame(newdata)&&!is.null(attr(newdata,"terms"))) { # it's a model frame if (sum(!(names(object$model)%in%names(newdata)))) stop( "newdata is a model.frame: it should contain all required variables\n") nd.is.mf <- TRUE } else { ## Following is non-standard to allow convenient splitting into blocks ## below, and to allow checking that all variables are in newdata ... ## get names of required variables, less response, but including offset variable ## see ?terms.object and ?terms for more information on terms objects yname <- all.vars(object$terms)[attr(object$terms,"response")] naresp <- FALSE if (!is.null(object$family$predict)&&!is.null(newdata[[yname]])) { ## response provided, and potentially needed for prediction (e.g. Cox PH family) if (!is.null(object$pred.formula)) object$pred.formula <- attr(object$pred.formula,"full") response <- TRUE Terms <- terms(object) resp <- newdata[[yname]] if (sum(is.na(resp))>0) { naresp <- TRUE ## there are NAs in supplied response ## replace them with a numeric code, so that rows are not dropped below rar <- range(resp,na.rm=TRUE) thresh <- rar[1]*1.01-rar[2]*.01 resp[is.na(resp)] <- thresh newdata[[yname]] <- thresh } } else { ## response not provided response <- FALSE Terms <- delete.response(terms(object)) } allNames <- if (is.null(object$pred.formula)) all.vars(Terms) else all.vars(object$pred.formula) if (length(allNames) > 0) { ff <- if (is.null(object$pred.formula)) reformulate(allNames) else object$pred.formula if (sum(!(allNames%in%names(newdata)))) { warning("not all required variables have been supplied in newdata!\n") } ## note that `xlev' argument not used here, otherwise `as.factor' in ## formula can cause a problem ... levels reset later. newdata <- eval(model.frame(ff,data=newdata,na.action=na.act),parent.frame()) if (naresp) newdata[[yname]][newdata[[yname]]<=thresh] <- NA ## reinstate as NA } ## otherwise it's intercept only and newdata can be left alone na.act <- attr(newdata,"na.action") response <- if (response) newdata[[yname]] else NULL } } } else { ## newdata.guaranteed == TRUE na.act <- NULL new.data.ok=TRUE ## it's guaranteed! if (!is.null(attr(newdata,"terms"))) nd.is.mf <- TRUE response <- newdata[[yname]] } ## now check the factor levels and split into blocks... if (new.data.ok) { ## check factor levels are right ... names(newdata)->nn # new data names colnames(object$model)->mn # original names for (i in 1:length(newdata)) if (nn[i]%in%mn && is.factor(object$model[,nn[i]])) { # then so should newdata[[i]] be levm <- levels(object$model[,nn[i]]) ## original levels levn <- levels(factor(newdata[[i]])) ## new levels if (sum(!levn%in%levm)>0) { ## check not trying to sneak in new levels msg <- paste(paste(levn[!levn%in%levm],collapse=", "),"not in original fit",collapse="") stop(msg) } newdata[[i]] <- factor(newdata[[i]],levels=levm) # set prediction levels to fit levels } if (type=="newdata") return(newdata) # split prediction into blocks, to avoid running out of memory if (length(newdata)==1) newdata[[2]] <- newdata[[1]] # avoids data frame losing its labels and dimensions below! if (is.null(dim(newdata[[1]]))) np <- length(newdata[[1]]) else np <- dim(newdata[[1]])[1] nb <- length(object$coefficients) if (is.null(block.size)) block.size <- 1000 if (block.size < 1) block.size <- np } else { # no new data, just use object$model np <- nrow(object$model) nb <- length(object$coefficients) } ## split prediction into blocks, to avoid running out of memory if (is.null(block.size)) { ## use one block as predicting using model frame ## and no block size supplied... n.blocks <- 1 b.size <- array(np,1) } else { n.blocks <- np %/% block.size b.size <- rep(block.size,n.blocks) last.block <- np-sum(b.size) if (last.block>0) { n.blocks <- n.blocks+1 b.size[n.blocks] <- last.block } } # setup prediction arrays... ## in multi-linear predictor models, lpi[[i]][j] is the column of model matrix contributing the jth col to lp i lpi <- if (is.list(object$formula)) attr(object$formula,"lpi") else NULL n.smooth<-length(object$smooth) if (type=="lpmatrix") { H <- matrix(0,np,nb) } else if (type=="terms"||type=="iterms") { term.labels <- attr(object$pterms,"term.labels") if (is.null(attr(object,"para.only"))) para.only <-FALSE else para.only <- TRUE # if true then only return information on parametric part n.pterms <- length(term.labels) fit <- array(0,c(np,n.pterms+as.numeric(!para.only)*n.smooth)) if (se.fit) se <- fit ColNames <- term.labels } else { ## "response" or "link" ## get number of linear predictors, in case it's more than 1... if (is.list(object$formula)) { # nf <- length(object$formula) ## number of model formulae nlp <- length(lpi) ## number of linear predictors } else nlp <- 1 ## nf <- 1 # nlp <- if (is.list(object$formula)) length(object$formula) else 1 fit <- if (nlp>1) matrix(0,np,nlp) else array(0,np) if (se.fit) se <- fit fit1 <- NULL ## "response" returned by fam$fv can be non-vector } stop <- 0 if (is.list(object$pterms)) { ## multiple linear predictors if (type=="iterms") { warning("type iterms not available for multiple predictor cases") type <- "terms" } pstart <- attr(object$nsdf,"pstart") ## starts of parametric blocks in coef vector pind <- rep(0,0) ## index of parametric coefs Terms <- list();pterms <- object$pterms for (i in 1:length(object$nsdf)) { Terms[[i]] <- delete.response(object$pterms[[i]]) if (object$nsdf[i]>0) pind <- c(pind,pstart[i]-1+1:object$nsdf[i]) } } else { ## normal single predictor case Terms <- list(delete.response(object$pterms)) ## make into a list anyway pterms <- list(object$pterms) pstart <- 1 pind <- 1:object$nsdf ## index of parameteric coefficients } ## check if extended family required intercept to be dropped... #drop.intercept <- FALSE #if (!is.null(object$family$drop.intercept)&&object$family$drop.intercept) { # drop.intercept <- TRUE; # ## make sure intercept explicitly included, so it can be cleanly dropped... # for (i in 1:length(Terms)) attr(Terms[[i]],"intercept") <- 1 #} drop.intercept <- object$family$drop.intercept if (is.null(drop.intercept)) { drop.intercept <- rep(FALSE, length(Terms)) } else { ## make sure intercept explicitly included, so it can be cleanly dropped... for (i in 1:length(Terms)) { if (drop.intercept[i] == TRUE) attr(Terms[[i]],"intercept") <- 1 } } ## index of any parametric terms that have to be dropped ## this is used to help with identifiability in multi- ## formula models... drop.ind <- attr(object$nsdf,"drop.ind") #################################### ## Actual prediction starts here... #################################### s.offset <- NULL # to accumulate any smooth term specific offset any.soff <- FALSE # indicator of term specific offset existence if (n.blocks > 0) for (b in 1:n.blocks) { # work through prediction blocks start <- stop+1 stop <- start + b.size[b] - 1 if (n.blocks==1) data <- newdata else data <- newdata[start:stop,] X <- matrix(0,b.size[b],nb+length(drop.ind)) Xoff <- matrix(0,b.size[b],n.smooth) ## term specific offsets offs <- list() for (i in 1:length(Terms)) { ## loop for parametric components (1 per lp) ## implements safe prediction for parametric part as described in ## http://developer.r-project.org/model-fitting-functions.txt if (new.data.ok) { if (nd.is.mf) mf <- model.frame(data,xlev=object$xlevels) else { mf <- model.frame(Terms[[i]],data,xlev=object$xlevels) if (!is.null(cl <- attr(pterms[[i]],"dataClasses"))) .checkMFClasses(cl,mf) } Xp <- model.matrix(Terms[[i]],mf,contrasts=object$contrasts) } else { Xp <- model.matrix(Terms[[i]],object$model) mf <- newdata # needed in case of offset, below } offi <- attr(Terms[[i]],"offset") if (is.null(offi)) offs[[i]] <- 0 else { ## extract offset offs[[i]] <- mf[[names(attr(Terms[[i]],"dataClasses"))[offi+1]]] } if (drop.intercept[i]) { xat <- attributes(Xp);ind <- xat$assign>0 Xp <- Xp[,xat$assign>0,drop=FALSE] ## some extended families need to drop intercept xat$assign <- xat$assign[ind];xat$dimnames[[2]]<-xat$dimnames[[2]][ind]; xat$dim[2] <- xat$dim[2]-1;attributes(Xp) <- xat } if (object$nsdf[i]>0) X[,pstart[i]-1 + 1:object$nsdf[i]] <- Xp } ## end of parametric loop if (length(offs)==1) offs <- offs[[1]] if (!is.null(drop.ind)) X <- X[,-drop.ind] if (n.smooth) for (k in 1:n.smooth) { ## loop through smooths klab <- object$smooth[[k]]$label if ((is.null(terms)||(klab%in%terms))&&(is.null(exclude)||!(klab%in%exclude))) { Xfrag <- PredictMat(object$smooth[[k]],data) X[,object$smooth[[k]]$first.para:object$smooth[[k]]$last.para] <- Xfrag Xfrag.off <- attr(Xfrag,"offset") ## any term specific offsets? if (!is.null(Xfrag.off)) { Xoff[,k] <- Xfrag.off; any.soff <- TRUE } } if (type=="terms"||type=="iterms") ColNames[n.pterms+k] <- klab } ## smooths done if (!is.null(object$Xcentre)) { ## Apply any column centering X <- sweep(X,2,object$Xcentre) } # Now have prediction matrix, X, for this block, need to do something with it... if (type=="lpmatrix") { H[start:stop,] <- X if (any.soff) s.offset <- rbind(s.offset,Xoff) } else if (type=="terms"||type=="iterms") { ## split results into terms lass <- if (is.list(object$assign)) object$assign else list(object$assign) k <- 0 for (j in 1:length(lass)) if (length(lass[[j]])) { ## work through assign list ind <- 1:length(lass[[j]]) ## index vector for coefs involved nptj <- max(lass[[j]]) ## number of terms involved here if (nptj>0) for (i in 1:nptj) { ## work through parametric part k <- k + 1 ## counts total number of parametric terms ii <- ind[lass[[j]]==i] + pstart[j] - 1 fit[start:stop,k] <- X[,ii,drop=FALSE]%*%object$coefficients[ii] if (se.fit) se[start:stop,k] <- sqrt(pmax(0,rowSums((X[,ii,drop=FALSE]%*%object$Vp[ii,ii])*X[,ii,drop=FALSE]))) } } ## assign list done if (n.smooth&&!para.only) { for (k in 1:n.smooth) # work through the smooth terms { first <- object$smooth[[k]]$first.para; last <- object$smooth[[k]]$last.para fit[start:stop,n.pterms+k] <- X[,first:last,drop=FALSE] %*% object$coefficients[first:last] + Xoff[,k] if (se.fit) { # diag(Z%*%V%*%t(Z))^0.5; Z=X[,first:last]; V is sub-matrix of Vp if (type=="iterms"&& attr(object$smooth[[k]],"nCons")>0) { ## termwise se to "carry the intercept ## some general families, add parameters after cmX created, which are irrelevant to cmX... if (length(object$cmX) < ncol(X)) object$cmX <- c(object$cmX,rep(0,ncol(X)-length(object$cmX))) X1 <- matrix(object$cmX,nrow(X),ncol(X),byrow=TRUE) meanL1 <- object$smooth[[k]]$meanL1 if (!is.null(meanL1)) X1 <- X1 / meanL1 X1[,first:last] <- X[,first:last] se[start:stop,n.pterms+k] <- sqrt(pmax(0,rowSums((X1%*%object$Vp)*X1))) } else se[start:stop,n.pterms+k] <- ## terms strictly centred sqrt(pmax(0,rowSums((X[,first:last,drop=FALSE]%*% object$Vp[first:last,first:last,drop=FALSE])*X[,first:last,drop=FALSE]))) } ## end if (se.fit) } colnames(fit) <- ColNames if (se.fit) colnames(se) <- ColNames } else { if (para.only&&is.list(object$pterms)) { ## have to use term labels that match original data, or termplot fails ## to plot. This only applies for 'para.only' calls which are ## designed for use from termplot called from plot.gam term.labels <- unlist(lapply(object$pterms,attr,"term.labels")) } colnames(fit) <- term.labels if (se.fit) colnames(se) <- term.labels # retain only terms of order 1 - this is to make termplot work order <- if (is.list(object$pterms)) unlist(lapply(object$pterms,attr,"order")) else attr(object$pterms,"order") term.labels <- term.labels[order==1] ## fit <- as.matrix(as.matrix(fit)[,order==1]) fit <- fit[,order==1,drop=FALSE] colnames(fit) <- term.labels if (se.fit) { ## se <- as.matrix(as.matrix(se)[,order==1]) se <- se[,order==1,drop=FALSE] colnames(se) <- term.labels } } } else { ## "link" or "response" case fam <- object$family k <- attr(attr(object$model,"terms"),"offset") if (nlp>1) { ## multiple linear predictor case if (is.null(fam$predict)||type=="link") { ##pstart <- c(pstart,ncol(X)+1) ## get index of smooths with an offset... off.ind <- (1:n.smooth)[as.logical(colSums(abs(Xoff)))] for (j in 1:nlp) { ## looping over the model formulae ind <- lpi[[j]] ##pstart[j]:(pstart[j+1]-1) fit[start:stop,j] <- X[,ind,drop=FALSE]%*%object$coefficients[ind] + offs[[j]] if (length(off.ind)) for (i in off.ind) { ## add any term specific offsets if (object$smooth[[i]]$first.para%in%ind) fit[start:stop,j] <- fit[start:stop,j] + Xoff[,i] } if (se.fit) se[start:stop,j] <- sqrt(pmax(0,rowSums((X[,ind,drop=FALSE]%*%object$Vp[ind,ind,drop=FALSE])*X[,ind,drop=FALSE]))) ## model offset only handled for first predictor... fixed ##if (j==1&&!is.null(k)) fit[start:stop,j] <- fit[start:stop,j] + model.offset(mf) if (type=="response") { ## need to transform lp to response scale linfo <- object$family$linfo[[j]] ## link information if (se.fit) se[start:stop,j] <- se[start:stop,j]*abs(linfo$mu.eta(fit[start:stop,j])) fit[start:stop,j] <- linfo$linkinv(fit[start:stop,j]) } } ## end of lp loop } else { ## response case with own predict code #lpi <- list();pst <- c(pstart,ncol(X)+1) #for (i in 1:(length(pst)-1)) lpi[[i]] <- pst[i]:(pst[i+1]-1) attr(X,"lpi") <- lpi ffv <- fam$predict(fam,se.fit,y=response,X=X,beta=object$coefficients, off=offs,Vb=object$Vp) if (is.matrix(fit)&&!is.matrix(ffv[[1]])) { fit <- fit[,1]; if (se.fit) se <- se[,1] } if (is.matrix(ffv[[1]])&&(!is.matrix(fit)||ncol(ffv[[1]])!=ncol(fit))) { fit <- matrix(0,np,ncol(ffv[[1]])); if (se.fit) se <- fit } if (is.matrix(fit)) { fit[start:stop,] <- ffv[[1]] if (se.fit) se[start:stop,] <- ffv[[2]] } else { fit[start:stop] <- ffv[[1]] if (se.fit) se[start:stop] <- ffv[[2]] } } ## end of own response prediction code } else { ## single linear predictor offs <- if (is.null(k)) rowSums(Xoff) else rowSums(Xoff) + model.offset(mf) fit[start:stop] <- X%*%object$coefficients + offs if (se.fit) se[start:stop] <- sqrt(pmax(0,rowSums((X%*%object$Vp)*X))) if (type=="response") { # transform linkinv <- fam$linkinv if (is.null(fam$predict)) { dmu.deta <- fam$mu.eta if (se.fit) se[start:stop]<-se[start:stop]*abs(dmu.deta(fit[start:stop])) fit[start:stop] <- linkinv(fit[start:stop]) } else { ## family has its own prediction code for response case ffv <- fam$predict(fam,se.fit,y=response,X=X,beta=object$coefficients,off=offs,Vb=object$Vp) if (is.null(fit1)&&is.matrix(ffv[[1]])) { fit1 <- matrix(0,np,ncol(ffv[[1]])) if (se.fit) se1 <- fit1 } if (is.null(fit1)) { fit[start:stop] <- ffv[[1]] if (se.fit) se[start:stop] <- ffv[[2]] } else { fit1[start:stop,] <- ffv[[1]] if (se.fit) se1[start:stop,] <- ffv[[2]] } } } } ## single lp done } ## end of link or response case rm(X) } ## end of prediction block loop if ((type=="terms"||type=="iterms")&&(!is.null(terms)||!is.null(exclude))) { # return only terms requested via `terms' cnames <- colnames(fit) if (!is.null(terms)) { if (sum(!(terms %in%cnames))) warning("non-existent terms requested - ignoring") else { fit <- fit[,terms,drop=FALSE] if (se.fit) { se <- se[,terms,drop=FALSE] } } } if (!is.null(exclude)) { if (sum(!(exclude %in%cnames))) warning("non-existent exclude terms requested - ignoring") else { exclude <- which(cnames%in%exclude) ## convert to numeric column index fit <- fit[,-exclude,drop=FALSE] if (se.fit) { se <- se[,-exclude,drop=FALSE] } } } } if (type=="response"&&!is.null(fit1)) { fit <- fit1 if (se.fit) se <- se1 } rn <- rownames(newdata) if (type=="lpmatrix") { colnames(H) <- names(object$coefficients);rownames(H)<-rn if (!is.null(s.offset)) { s.offset <- napredict(na.act,s.offset) attr(H,"offset") <- s.offset ## term specific offsets... } if (!is.null(attr(attr(object$model,"terms"),"offset"))) { attr(H,"model.offset") <- napredict(na.act,model.offset(mf)) } H <- napredict(na.act,H) if (length(object$nsdf)>1) { ## add "lpi" attribute if more than one l.p. #lpi <- list();pst <- c(pstart,ncol(H)+1) #for (i in 1:(length(pst)-1)) lpi[[i]] <- pst[i]:(pst[i+1]-1) attr(H,"lpi") <- lpi } } else { if (se.fit) { if (is.null(nrow(fit))) { names(fit) <- rn names(se) <- rn fit <- napredict(na.act,fit) se <- napredict(na.act,se) } else { rownames(fit)<-rn rownames(se)<-rn fit <- napredict(na.act,fit) se <- napredict(na.act,se) } H<-list(fit=fit,se.fit=se) } else { H <- fit if (is.null(nrow(H))) names(H) <- rn else rownames(H)<-rn H <- napredict(na.act,H) } } if ((type=="terms"||type=="iterms")&&attr(object$terms,"intercept")==1) attr(H,"constant") <- object$coefficients[1] H # ... and return } ## end of predict.gam concurvity <- function(b,full=TRUE) { ## b is a gam object ## full==TRUE means that dependence of each term on rest of model ## is considered. ## full==FALSE => pairwise comparison. if (!inherits(b,"gam")) stop("requires an object of class gam") m <- length(b$smooth) if (m<1) stop("nothing to do for this model") X <- model.matrix(b) X <- X[rowSums(is.na(X))==0,] ## this step speeds up remaining computation... X <- qr.R(qr(X,tol=0,LAPACK=FALSE)) stop <- start <- rep(1,m) lab <- rep("",m) for (i in 1:m) { ## loop through smooths start[i] <- b$smooth[[i]]$first.para stop[i] <- b$smooth[[i]]$last.para lab[i] <- b$smooth[[i]]$label } if (min(start)>1) { ## append parametric terms start <- c(1,start) stop <- c(min(start)-1,stop) lab <- c("para",lab) m <- m + 1 } n.measures <- 3 measure.names <- c("worst","observed","estimate") ##n <- nrow(X) if (full) { ## get dependence of each smooth on all the rest... conc <- matrix(0,n.measures,m) for (i in 1:m) { Xi <- X[,-(start[i]:stop[i]),drop=FALSE] Xj <- X[,start[i]:stop[i],drop=FALSE] r <- ncol(Xi) R <- qr.R(qr(cbind(Xi,Xj),LAPACK=FALSE,tol=0))[,-(1:r),drop=FALSE] ## No pivoting!! ##u worst case... Rt <- qr.R(qr(R)) conc[1,i] <- svd(forwardsolve(t(Rt),t(R[1:r,,drop=FALSE])))$d[1]^2 ## observed... beta <- b$coef[start[i]:stop[i]] conc[2,i] <- sum((R[1:r,,drop=FALSE]%*%beta)^2)/sum((Rt%*%beta)^2) ## less pessimistic... conc[3,i] <- sum(R[1:r,]^2)/sum(R^2) } colnames(conc) <- lab rownames(conc) <- measure.names } else { ## pairwise measures conc <- list() for (i in 1:n.measures) conc[[i]] <- matrix(1,m,m) ## concurvity matrix for (i in 1:m) { ## concurvity calculation loop Xi <- X[,start[i]:stop[i],drop=FALSE] r <- ncol(Xi) for (j in 1:m) if (i!=j) { Xj <- X[,start[j]:stop[j],drop=FALSE] R <- qr.R(qr(cbind(Xi,Xj),LAPACK=FALSE,tol=0))[,-(1:r),drop=FALSE] ## No pivoting!! ## worst case... Rt <- qr.R(qr(R)) conc[[1]][i,j] <- svd(forwardsolve(t(Rt),t(R[1:r,,drop=FALSE])))$d[1]^2 ## observed... beta <- b$coef[start[j]:stop[j]] conc[[2]][i,j] <- sum((R[1:r,,drop=FALSE]%*%beta)^2)/sum((Rt%*%beta)^2) ## less pessimistic... conc[[3]][i,j] <- sum(R[1:r,]^2)/sum(R^2) ## Alternative less pessimistic # log.det.R <- sum(log(abs(diag(R[(r+1):nrow(R),,drop=FALSE])))) # log.det.Rt <- sum(log(abs(diag(Rt)))) # conc[[4]][i,j] <- 1 - exp(log.det.R-log.det.Rt) rm(Xj,R,Rt) } } ## end of conc loop for (i in 1:n.measures) rownames(conc[[i]]) <- colnames(conc[[i]]) <- lab names(conc) <- measure.names } ## end of pairwise conc ## } ## end of concurvity residuals.gam <-function(object, type = "deviance",...) ## calculates residuals for gam object { ## if family has its own residual function, then use that... if (!is.null(object$family$residuals)) { res <- object$family$residuals(object,type,...) res <- naresid(object$na.action,res) return(res) } type <- match.arg(type,c("deviance", "pearson","scaled.pearson", "working", "response")) #if (sum(type %in% c("deviance", "pearson","scaled.pearson", "working", "response") )==0) # stop(paste(type," residuals not available")) ## default computations... y <- object$y mu <- object$fitted.values wts <- object$prior.weights if (type == "working") { res <- object$residuals } else if (type == "response") { res <- y - mu } else if (type == "deviance") { res <- object$family$dev.resids(y,mu,wts) s <- attr(res,"sign") if (is.null(s)) s <- sign(y-mu) res <- sqrt(pmax(res,0)) * s } else { ## some sort of Pearson var <- object$family$variance if (is.null(var)) { warning("Pearson residuals not available for this family - returning deviance residuals") return(residuals.gam(object)) } res <- (y-mu)*sqrt(wts)/sqrt(var(mu)) if (type == "scaled.pearson") res <- res/sqrt(object$sig2) } res <- naresid(object$na.action,res) res } ## Start of anova and summary (with contributions from Henric Nilsson) .... smoothTest <- function(b,X,V,eps=.Machine$double.eps^.5) { ## Forms Cox, Koh, etc type test statistic, and ## obtains null distribution by simulation... ## if b are coefs f=Xb, cov(b) = V. z is a vector of ## i.i.d. N(0,1) deviates qrx <- qr(X) R <- qr.R(qrx) V <- R%*%V[qrx$pivot,qrx$pivot]%*%t(R) V <- (V + t(V))/2 ed <- eigen(V,symmetric=TRUE) k <- length(ed$values) ## could truncate, but it doesn't improve power in correlated case! f <- t(ed$vectors[,1:k])%*%R%*%b t <- sum(f^2) k <- ncol(X) lambda <- as.numeric(ed$values[1:k]) pval <- liu2(t,lambda) ## should really use Davies list(stat=t,pval=pval) } liu2 <- function(x, lambda, h = rep(1,length(lambda)),lower.tail=FALSE) { # Evaluate Pr[sum_i \lambda_i \chi^2_h_i < x] approximately. # Code adapted from CompQuadForm package of Pierre Lafaye de Micheaux # and directly from.... # H. Liu, Y. Tang, H.H. Zhang, A new chi-square approximation to the # distribution of non-negative definite quadratic forms in non-central # normal variables, Computational Statistics and Data Analysis, Volume 53, # (2009), 853-856. Actually, this is just Pearson (1959) given that # the chi^2 variables are central. # Note that this can be rubbish in lower tail (e.g. lambda=c(1.2,.3), x = .15) # if (FALSE) { ## use Davies exact method in place of Liu et al/ Pearson approx. # require(CompQuadForm) # r <- x # for (i in 1:length(x)) r[i] <- davies(x[i],lambda,h)$Qq # return(pmin(r,1)) # } if (length(h) != length(lambda)) stop("lambda and h should have the same length!") lh <- lambda*h muQ <- sum(lh) lh <- lh*lambda c2 <- sum(lh) lh <- lh*lambda c3 <- sum(lh) s1 <- c3/c2^1.5 s2 <- sum(lh*lambda)/c2^2 sigQ <- sqrt(2*c2) t <- (x-muQ)/sigQ if (s1^2>s2) { a <- 1/(s1-sqrt(s1^2-s2)) delta <- s1*a^3-a^2 l <- a^2-2*delta } else { a <- 1/s1 delta <- 0 l <- c2^3/c3^2 } muX <- l+delta sigX <- sqrt(2)*a return(pchisq(t*sigX+muX,df=l,ncp=delta,lower.tail=lower.tail)) } simf <- function(x,a,df,nq=50) { ## suppose T = sum(a_i \chi^2_1)/(chi^2_df/df). We need ## Pr[T>x] = Pr(sum(a_i \chi^2_1) > x *chi^2_df/df). Quadrature ## used here. So, e.g. ## 1-pf(4/3,3,40);simf(4,rep(1,3),40);1-pchisq(4,3) p <- (1:nq-.5)/nq q <- qchisq(p,df) x <- x*q/df pr <- sum(liu2(x,a)) ## Pearson/Liu approx to chi^2 mixture pr/nq } recov <- function(b,re=rep(0,0),m=0) { ## b is a fitted gam object. re is an array of indices of ## smooth terms to be treated as fully random.... ## Returns frequentist Cov matrix based on the given ## mapping from data to params, but with dist of data ## corresponding to that implied by treating terms indexed ## by re as random effects... (would be usual frequentist ## if nothing treated as random) ## if m>0, then this is indexes a term, not in re, whose ## unpenalized cov matrix is required, with the elements of re ## dropped. if (!inherits(b,"gam")) stop("recov works with fitted gam objects only") if (is.null(b$full.sp)) sp <- b$sp else sp <- b$full.sp if (length(re)<1) { if (m>0) { ## annoyingly, need total penalty np <- length(coef(b)) k <- 1;S1 <- matrix(0,np,np) for (i in 1:length(b$smooth)) { ns <- length(b$smooth[[i]]$S) ind <- b$smooth[[i]]$first.para:b$smooth[[i]]$last.para if (ns>0) for (j in 1:ns) { S1[ind,ind] <- S1[ind,ind] + sp[k]*b$smooth[[i]]$S[[j]] k <- k + 1 } } LRB <- rbind(b$R,t(mroot(S1))) ii <- b$smooth[[m]]$first.para:b$smooth[[m]]$last.para ## ii is cols of LRB related to smooth m, which need ## to be moved to the end... LRB <- cbind(LRB[,-ii],LRB[,ii]) ii <- (ncol(LRB)-length(ii)+1):ncol(LRB) Rm <- qr.R(qr(LRB,tol=0,LAPACK=FALSE))[ii,ii] ## unpivoted QR } else Rm <- NULL return(list(Ve=(t(b$Ve)+b$Ve)*.5,Rm=Rm)) } if (m%in%re) stop("m can't be in re") ## partition R into R1 ("fixed") and R2 ("random"), with S1 and S2 p <- length(b$coefficients) rind <- rep(FALSE,p) ## random coefficient index for (i in 1:length(re)) { rind[b$smooth[[re[i]]]$first.para:b$smooth[[re[i]]]$last.para] <- TRUE } p2 <- sum(rind) ## number random p1 <- p - p2 ## number fixed map <- rep(0,p) ## remaps param indices to indices in split version map[rind] <- 1:p2 ## random map[!rind] <- 1:p1 ## fixed ## split R... R1 <- b$R[,!rind] ## fixed effect columns R2 <- b$R[,rind] ## random effect columns ## seitdem ich dich kennen, hab ich ein probleme, ## assemble S1 and S2 S1 <- matrix(0,p1,p1);S2 <- matrix(0,p2,p2) k <- 1 for (i in 1:length(b$smooth)) { ns <- length(b$smooth[[i]]$S) ind <- map[b$smooth[[i]]$first.para:b$smooth[[i]]$last.para] is.random <- i%in%re if (ns>0) for (j in 1:ns) { if (is.random) S2[ind,ind] <- S2[ind,ind] + sp[k]*b$smooth[[i]]$S[[j]] else S1[ind,ind] <- S1[ind,ind] + sp[k]*b$smooth[[i]]$S[[j]] k <- k + 1 } } ## pseudoinvert S2 if (nrow(S2)==1) { S2[1,1] <- 1/sqrt(S2[1,1]) } else if (max(abs(diag(diag(S2))-S2))==0) { ds2 <- diag(S2) ind <- ds2 > max(ds2)*.Machine$double.eps^.8 ds2[ind] <- 1/ds2[ind];ds2[!ind] <- 0 diag(S2) <- sqrt(ds2) } else { ev <- eigen((S2+t(S2))/2,symmetric=TRUE) ind <- ev$values > max(ev$values)*.Machine$double.eps^.8 ev$values[ind] <- 1/ev$values[ind];ev$values[!ind] <- 0 ## S2 <- ev$vectors%*%(ev$values*t(ev$vectors)) S2 <- sqrt(ev$values)*t(ev$vectors) } ## choleski of cov matrix.... ## L <- chol(diag(p)+R2%*%S2%*%t(R2)) ## L'L = I + R2 S2^- R2' L <- chol(diag(p) + crossprod(S2%*%t(R2))) ## now we need the square root of the unpenalized ## cov matrix for m if (m>0) { ## llr version LRB <- rbind(L%*%R1,t(mroot(S1))) ii <- map[b$smooth[[m]]$first.para:b$smooth[[m]]$last.para] ## ii is cols of LRB related to smooth m, which need ## to be moved to the end... LRB <- cbind(LRB[,-ii],LRB[,ii]) ii <- (ncol(LRB)-length(ii)+1):ncol(LRB) ## need to pick up final block Rm <- qr.R(qr(LRB,tol=0,LAPACK=FALSE))[ii,ii,drop=FALSE] ## unpivoted QR } else Rm <- NULL list(Ve= crossprod(L%*%b$R%*%b$Vp)/b$sig2, ## Frequentist cov matrix Rm=Rm) # mapi <- (1:p)[!rind] ## indexes mapi[j] is index of total coef vector to which jth row/col of Vb/e relates } ## end of recov reTest <- function(b,m) { ## Test the mth smooth for equality to zero ## and accounting for all random effects in model ## check that smooth penalty matrices are full size. ## e.g. "fs" type smooths estimated by gamm do not ## have full sized S matrices, and we can't compute ## p=values here.... if (ncol(b$smooth[[m]]$S[[1]]) != b$smooth[[m]]$last.para-b$smooth[[m]]$first.para+1) { return(list(stat=NA,pval=NA,rank=NA)) } ## find indices of random effects other than m rind <- rep(0,0) for (i in 1:length(b$smooth)) if (!is.null(b$smooth[[i]]$random)&&b$smooth[[i]]$random&&i!=m) rind <- c(rind,i) ## get frequentist cov matrix of effects treating smooth terms in rind as random rc <- recov(b,rind,m) Ve <- rc$Ve ind <- b$smooth[[m]]$first.para:b$smooth[[m]]$last.para B <- mroot(Ve[ind,ind,drop=FALSE]) ## BB'=Ve Rm <- rc$Rm b.hat <- coef(b)[ind] d <- Rm%*%b.hat stat <- sum(d^2)/b$sig2 ev <- eigen(crossprod(Rm%*%B)/b$sig2,symmetric=TRUE,only.values=TRUE)$values ev[ev<0] <- 0 rank <- sum(ev>max(ev)*.Machine$double.eps^.8) if (b$scale.estimated) { pval <- simf(stat,ev,b$df.residual) } else { pval <- liu2(stat,ev) } list(stat=stat,pval=pval,rank=rank) } ## end reTest testStat <- function(p,X,V,rank=NULL,type=0,res.df= -1) { ## Implements Wood (2013) Biometrika 100(1), 221-228 ## The type argument specifies the type of truncation to use. ## on entry `rank' should be an edf estimate ## 0. Default using the fractionally truncated pinv. ## 1. Round down to k if k<= rank < k+0.05, otherwise up. ## 2. Naive rounding. ## 3. Round up. ## 4. Numerical rank estimation, tol=1e-3 ## res.df is residual dof used to estimate scale. <=0 implies ## fixed scale. qrx <- qr(X,tol=0) R <- qr.R(qrx) V <- R%*%V[qrx$pivot,qrx$pivot,drop=FALSE]%*%t(R) V <- (V + t(V))/2 ed <- eigen(V,symmetric=TRUE) ## remove possible ambiguity from statistic... siv <- sign(ed$vectors[1,]);siv[siv==0] <- 1 ed$vectors <- sweep(ed$vectors,2,siv,"*") k <- max(0,floor(rank)) nu <- abs(rank - k) ## fractional part of supplied edf if (type < -.5) { ## Crude modification of Cox and Koh res <- smoothTest(p,X,V) res$rank <- rank return(res) } else if (type==1) { ## round up is more than .05 above lower if (rank > k + .05||k==0) k <- k + 1 nu <- 0;rank <- k } else if (type==2) { ## naive round nu <- 0;rank <- k <- max(1,round(rank)) warning("p-values may give low power in some circumstances") } else if (type==3) { ## round up nu <- 0; rank <- k <- max(1,ceiling(rank)) warning("p-values un-reliable") } else if (type==4) { ## rank estimation rank <- k <- max(sum(ed$values>1e-3*max(ed$values)),1) nu <- 0 warning("p-values may give very low power") } if (nu>0) k1 <- k+1 else k1 <- k ## check that actual rank is not below supplied rank+1 r.est <- sum(ed$values > max(ed$values)*.Machine$double.eps^.9) if (r.est0&&k>0) { if (k>1) vec[,1:(k-1)] <- t(t(vec[,1:(k-1)])/sqrt(ed$val[1:(k-1)])) b12 <- .5*nu*(1-nu) if (b12<0) b12 <- 0 b12 <- sqrt(b12) B <- matrix(c(1,b12,b12,nu),2,2) ev <- diag(ed$values[k:k1]^-.5,nrow=k1-k+1) B <- ev%*%B%*%ev eb <- eigen(B,symmetric=TRUE) rB <- eb$vectors%*%diag(sqrt(eb$values))%*%t(eb$vectors) vec1 <- vec vec1[,k:k1] <- t(rB%*%diag(c(-1,1))%*%t(vec[,k:k1])) vec[,k:k1] <- t(rB%*%t(vec[,k:k1])) } else { vec1 <- vec <- if (k==0) t(t(vec)*sqrt(1/ed$val[1])) else t(t(vec)/sqrt(ed$val[1:k])) if (k==1) rank <- 1 } ## there is an ambiguity in the choise of test statistic, leading to slight ## differences in the p-value computation depending on which of 2 alternatives ## is arbitrarily selected. Following allows both to be computed and p-values ## averaged (can't average test stat as dist then unknown) d <- t(vec)%*%(R%*%p) d <- sum(d^2) d1 <- t(vec1)%*%(R%*%p) d1 <- sum(d1^2) ##d <- d1 ## uncomment to avoid averaging rank1 <- rank ## rank for lower tail pval computation below ## note that for <1 edf then d is not weighted by EDF, and instead is ## simply refered to a chi-squared 1 if (nu>0) { ## mixture of chi^2 ref dist if (k1==1) rank1 <- val <- 1 else { val <- rep(1,k1) ##ed$val[1:k1] rp <- nu+1 val[k] <- (rp + sqrt(rp*(2-rp)))/2 val[k1] <- (rp - val[k]) } if (res.df <= 0) pval <- (liu2(d,val) + liu2(d1,val))/2 else ## pval <- davies(d,val)$Qq else pval <- (simf(d,val,res.df) + simf(d1,val,res.df))/2 } else { pval <- 2 } ## integer case still needs computing, also liu/pearson approx only good in ## upper tail. In lower tail, 2 moment approximation is better (Can check this ## by simply plotting the whole interesting range as a contour plot!) if (pval > .5) { if (res.df <= 0) pval <- (pchisq(d,df=rank1,lower.tail=FALSE)+pchisq(d1,df=rank1,lower.tail=FALSE))/2 else pval <- (pf(d/rank1,rank1,res.df,lower.tail=FALSE)+pf(d1/rank1,rank1,res.df,lower.tail=FALSE))/2 } list(stat=d,pval=min(1,pval),rank=rank) } ## end of testStat summary.gam <- function (object, dispersion = NULL, freq = FALSE, p.type=0, ...) { ## summary method for gam object - provides approximate p values ## for terms + other diagnostics ## Improved by Henric Nilsson ## * freq determines whether a frequentist or Bayesian cov matrix is ## used for parametric terms. Usually the default TRUE will result ## in reasonable results with paraPen. ## * p.type determines the type of smooth p-value ## 0 Bayesian default, unless smooth opts out ## 1 Bayesian biased rounding ## 2 Bayesian rounding ## 3 Bayesian round up ## 4 Bayesian numerical rank ## 5 Wood (2006) frequentist ## -1 Modified Cox et al. ## -2 old style p-values based on X not R ## If a smooth has a field 'random' and it is set to TRUE then ## it is treated as a random effect for some p-value dist calcs pinv<-function(V,M,rank.tol=1e-6) { ## a local pseudoinverse function D <- eigen(V,symmetric=TRUE) M1<-length(D$values[D$values>rank.tol*D$values[1]]) if (M>M1) M<-M1 # avoid problems with zero eigen-values if (M+1<=length(D$values)) D$values[(M+1):length(D$values)]<-1 D$values<- 1/D$values if (M+1<=length(D$values)) D$values[(M+1):length(D$values)]<-0 res <- D$vectors%*%(D$values*t(D$vectors)) ##D$u%*%diag(D$d)%*%D$v attr(res,"rank") <- M res } ## end of pinv if (is.null(object$R)) { warning("p-values for any terms that can be penalized to zero will be unreliable: refit model to fix this.") useR <- FALSE } else useR <- TRUE if (p.type < -1) useR <- FALSE if (p.type!=0) warning("p.type!=0 is deprecated, and liable to be removed in future") p.table <- pTerms.table <- s.table <- NULL if (freq) covmat <- object$Ve else covmat <- object$Vp name <- names(object$edf) dimnames(covmat) <- list(name, name) covmat.unscaled <- covmat/object$sig2 est.disp <- object$scale.estimated if (!is.null(dispersion)) { covmat <- dispersion * covmat.unscaled object$Ve <- object$Ve*dispersion/object$sig2 ## freq object$Vp <- object$Vp*dispersion/object$sig2 ## Bayes est.disp <- FALSE } else dispersion <- object$sig2 ## Now the individual parameteric coefficient p-values... se <- diag(covmat)^0.5 residual.df<-length(object$y)-sum(object$edf) if (sum(object$nsdf) > 0) { # individual parameters if (length(object$nsdf)>1) { ## several linear predictors pstart <- attr(object$nsdf,"pstart") ind <- rep(0,0) for (i in 1:length(object$nsdf)) if (object$nsdf[i]>0) ind <- c(ind,pstart[i]:(pstart[i]+object$nsdf[i]-1)) } else { pstart <- 1;ind <- 1:object$nsdf} ## only one lp p.coeff <- object$coefficients[ind] p.se <- se[ind] p.t<-p.coeff/p.se if (!est.disp) { p.pv <- 2*pnorm(abs(p.t),lower.tail=FALSE) p.table <- cbind(p.coeff, p.se, p.t, p.pv) dimnames(p.table) <- list(names(p.coeff), c("Estimate", "Std. Error", "z value", "Pr(>|z|)")) } else { p.pv <- 2*pt(abs(p.t),df=residual.df,lower.tail=FALSE) p.table <- cbind(p.coeff, p.se, p.t, p.pv) dimnames(p.table) <- list(names(p.coeff), c("Estimate", "Std. Error", "t value", "Pr(>|t|)")) } } else {p.coeff <- p.t <- p.pv <- array(0,0)} ## Next the p-values for parametric terms, so that factors are treated whole... pterms <- if (is.list(object$pterms)) object$pterms else list(object$pterms) if (!is.list(object$assign)) object$assign <- list(object$assign) npt <- length(unlist(lapply(pterms,attr,"term.labels"))) if (npt>0) pTerms.df <- pTerms.chi.sq <- pTerms.pv <- array(0,npt) term.labels <- rep("",0) k <- 0 ## total term counter for (j in 1:length(pterms)) { ##term.labels <- attr(object$pterms,"term.labels") tlj <- attr(pterms[[j]],"term.labels") nt <- length(tlj) if (j>1 && nt>0) tlj <- paste(tlj,j-1,sep=".") term.labels <- c(term.labels,tlj) if (nt>0) { # individual parametric terms np <- length(object$assign[[j]]) ind <- pstart[j] - 1 + 1:np Vb <- covmat[ind,ind,drop=FALSE] bp <- array(object$coefficients[ind],np) #pTerms.pv <- if (j==1) array(0,nt) else c(pTerms.pv,array(0,nt)) #attr(pTerms.pv,"names") <- term.labels #pTerms.df <- pTerms.chi.sq <- pTerms.pv for (i in 1:nt) { k <- k + 1 ind <- object$assign[[j]]==i b <- bp[ind];V <- Vb[ind,ind] ## pseudo-inverse needed in case of truncation of parametric space if (length(b)==1) { V <- 1/V pTerms.df[k] <- nb <- 1 pTerms.chi.sq[k] <- V*b*b } else { V <- pinv(V,length(b),rank.tol=.Machine$double.eps^.5) pTerms.df[k] <- nb <- attr(V,"rank") pTerms.chi.sq[k] <- t(b)%*%V%*%b } if (!est.disp) pTerms.pv[k] <- pchisq(pTerms.chi.sq[k],df=nb,lower.tail=FALSE) else pTerms.pv[k] <- pf(pTerms.chi.sq[k]/nb,df1=nb,df2=residual.df,lower.tail=FALSE) } ## for (i in 1:nt) } ## if (nt>0) } if (npt) { attr(pTerms.pv,"names") <- term.labels if (!est.disp) { pTerms.table <- cbind(pTerms.df, pTerms.chi.sq, pTerms.pv) dimnames(pTerms.table) <- list(term.labels, c("df", "Chi.sq", "p-value")) } else { pTerms.table <- cbind(pTerms.df, pTerms.chi.sq/pTerms.df, pTerms.pv) dimnames(pTerms.table) <- list(term.labels, c("df", "F", "p-value")) } } else { pTerms.df<-pTerms.chi.sq<-pTerms.pv<-array(0,0)} ## Now deal with the smooth terms.... m <- length(object$smooth) # number of smooth terms if (p.type < 0 ) { kmax <- 0 for (i in 1:m) { start <- object$smooth[[i]]$first.para stop <- object$smooth[[i]]$last.para k <- stop-start+1 if (k>kmax) kmax <- k } } df <- edf1 <- edf <- s.pv <- chi.sq <- array(0, m) if (m>0) # form test statistics for each smooth { if (p.type < 5) { ## Bayesian p-values required if (useR) X <- object$R else { sub.samp <- max(1000,2*length(object$coefficients)) if (nrow(object$model)>sub.samp) { ## subsample to get X for p-values calc. seed <- try(get(".Random.seed",envir=.GlobalEnv),silent=TRUE) ## store RNG seed if (inherits(seed,"try-error")) { runif(1) seed <- get(".Random.seed",envir=.GlobalEnv) } kind <- RNGkind(NULL) RNGkind("default","default") set.seed(11) ## ensure repeatability ind <- sample(1:nrow(object$model),sub.samp,replace=FALSE) ## sample these rows from X X <- predict(object,object$model[ind,],type="lpmatrix") RNGkind(kind[1],kind[2]) assign(".Random.seed",seed,envir=.GlobalEnv) ## RNG behaves as if it had not been used } else { ## don't need to subsample X <- model.matrix(object) } X <- X[!is.na(rowSums(X)),] ## exclude NA's (possible under na.exclude) } } ## end if (p.type<5) for (i in 1:m) { ## loop through smooths start <- object$smooth[[i]]$first.para;stop <- object$smooth[[i]]$last.para if (p.type==5) { ## use frequentist cov matrix V <- object$Ve[start:stop,start:stop,drop=FALSE] } else V <- object$Vp[start:stop,start:stop,drop=FALSE] ## Bayesian p <- object$coefficients[start:stop] # params for smooth edf1[i] <- edf[i] <- sum(object$edf[start:stop]) # edf for this smooth ## extract alternative edf estimate for this smooth, if possible... if (!is.null(object$edf1)) edf1[i] <- sum(object$edf1[start:stop]) if (p.type==5) { ## old style frequentist M1 <- object$smooth[[i]]$df M <- min(M1,ceiling(2*sum(object$edf[start:stop]))) ## upper limit of 2*edf on rank V <- pinv(V,M) # get rank M pseudoinverse of V chi.sq[i] <- t(p)%*%V%*%p df[i] <- attr(V, "rank") } else { ## Better founded alternatives... Xt <- X[,start:stop,drop=FALSE] fx <- if (inherits(object$smooth[[i]],"tensor.smooth")&& !is.null(object$smooth[[i]]$fx)) all(object$smooth[[i]]$fx) else object$smooth[[i]]$fixed if (!fx&&object$smooth[[i]]$null.space.dim==0&&!is.null(object$R)) { ## random effect or fully penalized term res <- reTest(object,i) } else { ## Inverted Nychka interval statistics df[i] <- min(ncol(Xt),edf1[i]) if (est.disp) rdf <- residual.df else rdf <- -1 res <- testStat(p,Xt,V,df[i],type=p.type,res.df = rdf) } df[i] <- res$rank chi.sq[i] <- res$stat s.pv[i] <- res$pval } names(chi.sq)[i]<- object$smooth[[i]]$label if (p.type == 5) { if (!est.disp) s.pv[i] <- pchisq(chi.sq[i], df = df[i], lower.tail = FALSE) else s.pv[i] <- pf(chi.sq[i]/df[i], df1 = df[i], df2 = residual.df, lower.tail = FALSE) ## p-values are meaningless for very small edf. Need to set to NA if (df[i] < 0.1) s.pv[i] <- NA } } if (!est.disp) { if (p.type==5) { s.table <- cbind(edf, df, chi.sq, s.pv) dimnames(s.table) <- list(names(chi.sq), c("edf", "Est.rank", "Chi.sq", "p-value")) } else { s.table <- cbind(edf, df, chi.sq, s.pv) dimnames(s.table) <- list(names(chi.sq), c("edf", "Ref.df", "Chi.sq", "p-value")) } } else { if (p.type==5) { s.table <- cbind(edf, df, chi.sq/df, s.pv) dimnames(s.table) <- list(names(chi.sq), c("edf", "Est.rank", "F", "p-value")) } else { s.table <- cbind(edf, df, chi.sq/df, s.pv) dimnames(s.table) <- list(names(chi.sq), c("edf", "Ref.df", "F", "p-value")) } } } w <- as.numeric(object$prior.weights) mean.y <- sum(w*object$y)/sum(w) w <- sqrt(w) nobs <- nrow(object$model) r.sq <- if (inherits(object$family,"general.family")||!is.null(object$family$no.r.sq)) NULL else 1 - var(w*(as.numeric(object$y)-object$fitted.values))*(nobs-1)/(var(w*(as.numeric(object$y)-mean.y))*residual.df) dev.expl<-(object$null.deviance-object$deviance)/object$null.deviance if (object$method%in%c("REML","ML")) object$method <- paste("-",object$method,sep="") ret<-list(p.coeff=p.coeff,se=se,p.t=p.t,p.pv=p.pv,residual.df=residual.df,m=m,chi.sq=chi.sq, s.pv=s.pv,scale=dispersion,r.sq=r.sq,family=object$family,formula=object$formula,n=nobs, dev.expl=dev.expl,edf=edf,dispersion=dispersion,pTerms.pv=pTerms.pv,pTerms.chi.sq=pTerms.chi.sq, pTerms.df = pTerms.df, cov.unscaled = covmat.unscaled, cov.scaled = covmat, p.table = p.table, pTerms.table = pTerms.table, s.table = s.table,method=object$method,sp.criterion=object$gcv.ubre, rank=object$rank,np=length(object$coefficients)) class(ret)<-"summary.gam" ret } ## end summary.gam print.summary.gam <- function(x, digits = max(3, getOption("digits") - 3), signif.stars = getOption("show.signif.stars"), ...) # print method for gam summary method. Improved by Henric Nilsson { print(x$family) cat("Formula:\n") if (is.list(x$formula)) for (i in 1:length(x$formula)) print(x$formula[[i]]) else print(x$formula) if (length(x$p.coeff)>0) { cat("\nParametric coefficients:\n") printCoefmat(x$p.table, digits = digits, signif.stars = signif.stars, na.print = "NA", ...) } cat("\n") if(x$m>0) { cat("Approximate significance of smooth terms:\n") printCoefmat(x$s.table, digits = digits, signif.stars = signif.stars, has.Pvalue = TRUE, na.print = "NA",cs.ind=1, ...) } cat("\n") if (!is.null(x$rank) && x$rank< x$np) cat("Rank: ",x$rank,"/",x$np,"\n",sep="") if (!is.null(x$r.sq)) cat("R-sq.(adj) = ",formatC(x$r.sq,digits=3,width=5)," ") if (length(x$dev.expl)>0) cat("Deviance explained = ",formatC(x$dev.expl*100,digits=3,width=4),"%",sep="") cat("\n") if (!is.null(x$method)&&!(x$method%in%c("PQL","lme.ML","lme.REML"))) cat(x$method," = ",formatC(x$sp.criterion,digits=5),sep="") cat(" Scale est. = ",formatC(x$scale,digits=5,width=8,flag="-")," n = ",x$n,"\n",sep="") invisible(x) } ## print.summary.gam anova.gam <- function (object, ..., dispersion = NULL, test = NULL, freq=FALSE,p.type=0) # improved by Henric Nilsson { # adapted from anova.glm: R stats package dotargs <- list(...) named <- if (is.null(names(dotargs))) rep(FALSE, length(dotargs)) else (names(dotargs) != "") if (any(named)) warning("The following arguments to anova.glm(..) are invalid and dropped: ", paste(deparse(dotargs[named]), collapse = ", ")) dotargs <- dotargs[!named] is.glm <- unlist(lapply(dotargs, function(x) inherits(x, "glm"))) dotargs <- dotargs[is.glm] if (length(dotargs) > 0) { if (!is.null(test)&&!test%in%c("Chisq","LRT","F")) stop("un-supported test") ## check for multiple formulae to avoid problems... if (is.list(object$formula)) object$formula <- object$formula[[1]] ## reset df.residual to value appropriate for GLRT... n <- if (is.matrix(object$y)) nrow(object$y) else length(object$y) dfc <- if (is.null(object$edf2)) 0 else sum(object$edf2) - sum(object$edf) object$df.residual <- n - sum(object$edf1) - dfc ## reset the deviance to -2*logLik for general families... if (inherits(object$family,"general.family")) { object$deviance <- -2 * as.numeric(logLik(object)) if (!is.null(test)) test <- "Chisq" } ## repeat above 3 steps for each element of dotargs... for (i in 1:length(dotargs)) { if (is.list(dotargs[[i]]$formula)) dotargs[[i]]$formula <- dotargs[[i]]$formula[[1]] dfc <- if (is.null(dotargs[[i]]$edf2)) 0 else sum(dotargs[[i]]$edf2) - sum(dotargs[[i]]$edf) dotargs[[i]]$df.residual <- n - sum(dotargs[[i]]$edf1) - dfc if (inherits(dotargs[[i]]$family,"general.family")) { dotargs[[i]]$deviance <- -2 * as.numeric(logLik(dotargs[[i]])) } } return(anova(structure(c(list(object), dotargs), class="glmlist"), dispersion = dispersion, test = test)) } if (!is.null(test)) warning("test argument ignored") if (!inherits(object,"gam")) stop("anova.gam called with non gam object") sg <- summary(object, dispersion = dispersion, freq = freq,p.type=p.type) class(sg) <- "anova.gam" sg } ## anova.gam print.anova.gam <- function(x, digits = max(3, getOption("digits") - 3), ...) { # print method for class anova.gam resulting from single # gam model calls to anova. Improved by Henric Nilsson. print(x$family) cat("Formula:\n") if (is.list(x$formula)) for (i in 1:length(x$formula)) print(x$formula[[i]]) else print(x$formula) if (length(x$pTerms.pv)>0) { cat("\nParametric Terms:\n") printCoefmat(x$pTerms.table, digits = digits, signif.stars = FALSE, has.Pvalue = TRUE, na.print = "NA", ...) } cat("\n") if(x$m>0) { cat("Approximate significance of smooth terms:\n") printCoefmat(x$s.table, digits = digits, signif.stars = FALSE, has.Pvalue = TRUE, na.print = "NA", ...) } invisible(x) } ## print.anova.gam ## End of improved anova and summary code. pen.edf <- function(x) { ## obtains the edf associated with each penalty. That is the edf ## of the group of coefficients penalized by each penalty. ## hard to interpret for overlapping penalties. brilliant for t2 ## smooths! if (!inherits(x,"gam")) stop("not a gam object") if (length(x$smooth)==0) return(NULL) k <- 0 ## penalty counter edf <- rep(0,0) edf.name <- rep("",0) for (i in 1:length(x$smooth)) { ## work through smooths if (length(x$smooth[[i]]$S)>0) { pind <- x$smooth[[i]]$first.para:x$smooth[[i]]$last.para ## range of coefs relating to this term Snames <- names(x$smooth[[i]]$S) if (is.null(Snames)) Snames <- as.character(1:length(x$smooth[[i]]$S)) if (length(Snames)==1) Snames <- "" for (j in 1:length(x$smooth[[i]]$S)) { ind <- rowSums(x$smooth[[i]]$S[[j]]!=0)!=0 ## index of penalized coefs (within pind) k <- k+1 edf[k] <- sum(x$edf[pind[ind]]) edf.name[k] <- paste(x$smooth[[i]]$label,Snames[j],sep="") } } } ## finished all penalties names(edf) <- edf.name if (k==0) return(NULL) edf } ## end of pen.edf cooks.distance.gam <- function(model,...) { res <- residuals(model,type="pearson") dispersion <- model$sig2 hat <- model$hat p <- sum(model$edf) (res/(1 - hat))^2 * hat/(dispersion * p) } sp.vcov <- function(x) { ## get cov matrix of smoothing parameters, if available if (!inherits(x,"gam")) stop("argument is not a gam object") if (x$method%in%c("ML","P-ML","REML","P-REML","fREML")&&!is.null(x$outer.info$hess)) { return(solve(x$outer.info$hess)) } else return(NULL) } gam.vcomp <- function(x,rescale=TRUE,conf.lev=.95) { ## Routine to convert smoothing parameters to variance components ## in a fitted `gam' object. if (!inherits(x,"gam")) stop("requires an object of class gam") if (!is.null(x$reml.scale)&&is.finite(x$reml.scale)) scale <- x$reml.scale else scale <- x$sig2 if (length(x$sp)==0) return() if (rescale) { ## undo any rescaling of S[[i]] that may have been done m <- length(x$smooth) if (is.null(x$paraPen)) { k <- 1; if (is.null(x$full.sp)) kf <- -1 else kf <- 1 ## place holder in full sp vector } else { ## don't rescale paraPen related stuff k <- sum(x$paraPen$sp<0)+1 ## count free sp's for paraPen if (is.null(x$full.sp)) kf <- -1 else kf <- length(x$paraPen$full.sp.names)+1 } idx <- rep("",0) ## vector of ids used idxi <- rep(0,0) ## indexes ids in smooth list if (m>0) for (i in 1:m) { ## loop through all smooths if (!is.null(x$smooth[[i]]$id)) { ## smooth has an id if (x$smooth[[i]]$id%in%idx) { ok <- FALSE ## id already dealt with --- ignore smooth } else { idx <- c(idx,x$smooth[[i]]$id) ## add id to id list idxi <- c(idxi,i) ## so smooth[[idxi[k]]] is prototype for idx[k] ok <- TRUE } } else { ok <- TRUE} ## no id so proceed if (ok) { if (length(x$smooth[[i]]$S.scale)!=length(x$smooth[[i]]$S)) warning("S.scale vector doesn't match S list - please report to maintainer") for (j in 1:length(x$smooth[[i]]$S.scale)) { if (x$smooth[[i]]$sp[j]<0) { ## sp not supplied x$sp[k] <- x$sp[k] / x$smooth[[i]]$S.scale[j] k <- k + 1 if (kf>0) { x$full.sp[kf] <- x$full.sp[kf] / x$smooth[[i]]$S.scale[j] kf <- kf + 1 } } else { ## sp supplied x$full.sp[kf] <- x$full.sp[kf] / x$smooth[[i]]$S.scale[j] kf <- kf + 1 } } } else { ## this id already dealt with, but full.sp not scaled yet ii <- idxi[idx%in%x$smooth[[i]]$id] ## smooth prototype for (j in 1:length(x$smooth[[ii]]$S.scale)) { x$full.sp[kf] <- x$full.sp[kf] / x$smooth[[ii]]$S.scale[j] kf <- kf + 1 } } } ## finished rescaling } ## variance components (original scale) vc <- c(scale/x$sp) names(vc) <- names(x$sp) if (is.null(x$full.sp)) vc.full <- NULL else { vc.full <- c(scale/x$full.sp) names(vc.full) <- names(x$full.sp) } ## If a Hessian exists, get CI's for variance components... if (x$method%in%c("ML","P-ML","REML","P-REML","fREML")&&!is.null(x$outer.info$hess)) { if (is.null(x$family$n.theta)||x$family$n.theta<=0) H <- x$outer.info$hess ## the hessian w.r.t. log sps and log scale else { ind <- 1:x$family$n.theta H <- x$outer.info$hess[-ind,-ind,drop=FALSE] } if (ncol(H)>length(x$sp)) scale.est <- TRUE else scale.est <- FALSE ## get derivs of log sqrt var comps wrt log sp and log scale.... J <- matrix(0,nrow(H),ncol(H)) if (scale.est) { diag(J) <- -.5 # -2 J[,ncol(J)] <- .5 # 2 vc <- c(vc,scale);names(vc) <- c(names(x$sp),"scale") } else { diag(J) <- -0.5 #-2 } #H <- t(J)%*%H%*%J ## hessian of log sqrt variances eh <- eigen(H,symmetric=TRUE) ind <- eh$values>max(eh$values)*.Machine$double.eps^75 ## index of non zero eigenvalues rank <- sum(ind) ## rank of hessian iv <- eh$values*0;iv[ind] <- 1/eh$values[ind] V <- eh$vectors%*%(iv*t(eh$vectors)) ## cov matrix for sp's ## log sqrt variances V <- J%*%V%*%t(J) ## cov matrix for log sqrt variance lsd <- log(sqrt(vc)) ## log sqrt variances sd.lsd <- sqrt(diag(V)) if (conf.lev<=0||conf.lev>=1) conf.lev <- 0.95 crit <- qnorm(1-(1-conf.lev)/2) ll <- lsd - crit * sd.lsd ul <- lsd + crit * sd.lsd res <- cbind(exp(lsd),exp(ll),exp(ul)) rownames(res) <- names(vc) colnames(res) <- c("std.dev","lower","upper") cat("\n") cat(paste("Standard deviations and",conf.lev,"confidence intervals:\n\n")) print(res) cat("\nRank: ");cat(rank);cat("/");cat(ncol(H));cat("\n") if (!is.null(vc.full)) { cat("\nAll smooth components:\n") print(sqrt(vc.full)) res <- list(all=sqrt(vc.full),vc=res) } invisible(res) } else { if (is.null(vc.full)) return(sqrt(vc)) else return(list(vc=sqrt(vc),all=sqrt(vc.full))) } } ## end of gam.vcomp vcov.gam <- function(object, freq = FALSE, dispersion = NULL,unconditional=FALSE, ...) ## supplied by Henric Nilsson { if (freq) vc <- object$Ve else { vc <- if (unconditional&&!is.null(object$Vc)) object$Vc else object$Vp } if (!is.null(dispersion)) vc <- dispersion * vc / object$sig2 name <- names(object$edf) dimnames(vc) <- list(name, name) vc } influence.gam <- function(model,...) { model$hat } logLik.gam <- function (object,...) { # based on logLik.glm - is ordering of p correction right??? # if (length(list(...))) # warning("extra arguments discarded") ##fam <- family(object)$family sc.p <- as.numeric(object$scale.estimated) p <- sum(object$edf) + sc.p val <- p - object$aic/2 #if (fam %in% c("gaussian", "Gamma", "inverse.gaussian","Tweedie")) # p <- p + 1 if (!is.null(object$edf2)) p <- sum(object$edf2) + sc.p np <- length(object$coefficients) + sc.p if (p > np) p <- np if (inherits(object$family,"extended.family")&&!is.null(object$family$n.theta)) p <- p + object$family$n.theta attr(val, "df") <- p class(val) <- "logLik" val } ## logLik.gam # From here on is the code for magic..... mroot <- function(A,rank=NULL,method="chol") # finds the smallest square root of A, or the best approximate square root of # given rank. B is returned where BB'=A. A assumed non-negative definite. # Current methods "chol", "svd". "svd" is much slower, but much better at getting the # correct rank if it isn't known in advance. { if (is.null(rank)) rank <- 0 if (!isTRUE(all.equal(A,t(A)))) stop("Supplied matrix not symmetric") if (method=="svd") { um <- La.svd(A) if (sum(um$d!=sort(um$d,decreasing=TRUE))>0) stop("singular values not returned in order") if (rank < 1) # have to work out rank { rank <- dim(A)[1] if (um$d[1]<=0) rank <- 1 else while (rank>0&&(um$d[rank]/um$d[1]<.Machine$double.eps|| all.equal(um$u[,rank],um$vt[rank,])!=TRUE)) rank<-rank-1 if (rank==0) stop("Something wrong - matrix probably not +ve semi definite") } d<-um$d[1:rank]^0.5 return(t(t(um$u[,1:rank])*as.vector(d))) # note recycling rule used for efficiency } else if (method=="chol") { ## don't want to be warned it's not +ve def... L <- suppressWarnings(chol(A,pivot=TRUE,tol=0)) piv <- order(attr(L,"pivot")) ## chol does not work as documented (reported), have to explicitly zero ## the trailing block... r <- attr(L,"rank") p <- ncol(L) if (r < p) L[(r+1):p,(r+1):p] <- 0 if (rank < 1) rank <- r L <- L[,piv,drop=FALSE]; L <- t(L[1:rank,,drop=FALSE]) return(L) } else stop("method not recognised.") } ## mroot magic.post.proc <- function(X,object,w=NULL) # routine to take list returned by magic and extract: # Vb the estimated bayesian parameter covariance matrix. rV%*%t(rV)*scale # Ve the frequentist parameter estimator covariance matrix. # edf the array of estimated degrees of freedom per parameter Vb%*%t(X)%*%W%*%X /scale # hat the leading diagonal of the hat/influence matrix # NOTE: W=diag(w) if w non-matrix, otherwise w is a matrix square root. # flop count is O(nq^2) if X is n by q... this is why routine not part of magic { ## V<-object$rV%*%t(object$rV) V <- tcrossprod(object$rV) if (!is.null(w)) { if (is.matrix(w)) WX <- X <- w%*%X else WX <- as.vector(w)*X # use recycling rule to form diag(w)%*%X cheaply } else {WX <- X} ##if (nthreads <= 1) M <- WX%*%V else M <- pmmult(WX,V,tA=FALSE,tB=FALSE,nt=nthreads) M <- WX%*%V ## O(np^2) part ##Ve <- (V%*%t(X))%*%M*object$scale # frequentist cov. matrix XWX <- crossprod(object$R) #t(X)%*%WX F <- Ve <- V%*%XWX edf1 <- rowSums(t(Ve)*Ve) ## this is diag(FF), where F is edf matrix Ve <- Ve%*%V*object$scale ## frequentist cov matrix B <- X*M rm(M) hat <- rowSums(B) #apply(B,1,sum) # diag(X%*%V%*%t(WX)) edf <- colSums(B) #apply(B,2,sum) # diag(V%*%t(X)%*%WX) Vb <- V*object$scale;rm(V) list(Ve=Ve,Vb=Vb,hat=hat,edf=edf,edf1=2*edf-edf1,F=F) } ## magic.post.proc single.sp <- function(X,S,target=.5,tol=.Machine$double.eps*100) ## function to find smoothing parameter corresponding to particular ## target e.d.f. for a single smoothing parameter problem. ## X is model matrix; S is penalty matrix; target is target ## average e.d.f. per penalized term. { R <- qr.R(qr(X)) ### BUG? pivoting? te <- try(RS <- backsolve(R,S,transpose=TRUE),silent=TRUE) if (inherits(te,"try-error")) return(-1) te <- try(RSR <- backsolve(R,t(RS),transpose=TRUE),silent=TRUE) if (inherits(te,"try-error")) return(-1) RSR <- (RSR+t(RSR))/2 d <- eigen(RSR,symmetric=TRUE)$values d <- d[d>max(d)*tol] ff <- function(lambda,d,target) { mean(1/(1+exp(lambda)*d))-target } lower <- 0 while (ff(lower,d,target) <= 0) lower <- lower - 1 upper <- lower while (ff(upper,d,target) > 0) upper <- upper + 1 exp(uniroot(ff,c(lower,upper),d=d,target=target)$root) } initial.spg <- function(x,y,weights,family,S,rank,off,offset=NULL,L=NULL,lsp0=NULL,type=1, start=NULL,mustart=NULL,etastart=NULL,E=NULL,...) { ## initial smoothing parameter values based on approximate matching ## of Frob norm of XWX and S. If L is non null then it is assumed ## that the sps multiplying S elements are given by L%*%sp+lsp0 and ## an appropriate regression step is used to find `sp' itself. ## This routine evaluates initial guesses at W. ## Get the initial weights... if (length(S)==0) return(rep(0,0)) ## start <- etastart <- mustart <- NULL nobs <- nrow(x) ## ignore codetools warning - required for initialization if (is.null(mustart)) mukeep <- NULL else mukeep <- mustart eval(family$initialize) if (inherits(family,"general.family")) { ## Cox, gamlss etc... lbb <- family$ll(y,x,start,weights,family,offset=offset,deriv=1)$lbb ## initial Hessian ## initially work out the number of times that each coefficient is penalized pcount <- rep(0,ncol(lbb)) for (i in 1:length(S)) { ind <- off[i]:(off[i]+ncol(S[[i]])-1) dlb <- -diag(lbb[ind,ind]) indp <- rowSums(abs(S[[i]]))>max(S[[i]])*.Machine$double.eps^.75 & dlb!=0 ind <- ind[indp] ## drop indices of unpenalized pcount[ind] <- pcount[ind] + 1 ## add up times penalized } lambda <- rep(0,length(S)) ## choose lambda so that corresponding elements of lbb and S[[i]] ## are roughly in balance... for (i in 1:length(S)) { ind <- off[i]:(off[i]+ncol(S[[i]])-1) lami <- 1 dlb <- -diag(lbb[ind,ind]);dS <- diag(S[[i]]) pc <- pcount[ind] ## get index of elements doing any actual penalization... ind <- rowSums(abs(S[[i]]))>max(S[[i]])*.Machine$double.eps^.75 & dlb!=0 ## dlb > 0 ## drop elements that are not penalizing dlb <- dlb[ind]/pc[ind] ## idea is to share out between penalties dS <- dS[ind] rm <- max(length(dS)/rank[i],1) ## rough correction for rank deficiency in penalty #while (mean(dlb/(dlb + lami * dS * rm)) > 0.4) lami <- lami*5 #while (mean(dlb/(dlb + lami * dS * rm )) < 0.4) lami <- lami/5 while (sqrt(mean(dlb/(dlb + lami * dS * rm))*mean(dlb)/mean(dlb+lami*dS*rm)) > 0.4) lami <- lami*5 while (sqrt(mean(dlb/(dlb + lami * dS * rm))*mean(dlb)/mean(dlb+lami*dS*rm)) < 0.4) lami <- lami/5 lambda[i] <- lami ## norm(lbb[ind,ind])/norm(S[[i]]) } } else { ## some sort of conventional regression if (is.null(mukeep)) { if (!is.null(start)) etastart <- drop(x%*%start) if (!is.null(etastart)) mustart <- family$linkinv(etastart) } else mustart <- mukeep if (inherits(family,"extended.family")) { theta <- family$getTheta() ## use 'as.numeric' - 'drop' can leave result as 1D array... w <- .5 * as.numeric(family$Dd(y,mustart,theta,weights)$EDmu2*family$mu.eta(family$linkfun(mustart))^2) } else w <- as.numeric(weights*family$mu.eta(family$linkfun(mustart))^2/family$variance(mustart)) w <- sqrt(w) if (type==1) { ## what PI would have used lambda <- initial.sp(w*x,S,off) } else { ## balance frobenius norms csX <- colSums((w*x)^2) lambda <- rep(0,length(S)) for (i in 1:length(S)) { ind <- off[i]:(off[i]+ncol(S[[i]])-1) lambda[i] <- sum(csX[ind])/sqrt(sum(S[[i]]^2)) } } } if (!is.null(L)) { lsp <- log(lambda) if (is.null(lsp0)) lsp0 <- rep(0,nrow(L)) lsp <- as.numeric(coef(lm(lsp~L-1+offset(lsp0)))) lambda <- exp(lsp) } lambda ## initial values } initial.sp <- function(X,S,off,expensive=FALSE,XX=FALSE) # Find initial smoothing parameter guesstimates based on model matrix X # and penalty list S. off[i] is the index of the first parameter to # which S[[i]] applies, since S[[i]]'s only store non-zero submatrix of # penalty coefficient matrix. # if XX==TRUE then X contains X'X, not X! { n.p <- length(S) if (XX) expensive <- FALSE def.sp <- array(0,n.p) if (n.p) { ldxx <- if (XX) diag(X) else colSums(X*X) # yields diag(t(X)%*%X) ldss <- ldxx*0 # storage for combined penalty l.d. if (expensive) St <- matrix(0,ncol(X),ncol(X)) pen <- rep(FALSE,length(ldxx)) # index of what actually gets penalized for (i in 1:n.p) { # loop over penalties maS <- max(abs(S[[i]])) rsS <- rowMeans(abs(S[[i]])) csS <- colMeans(abs(S[[i]])) dS <- diag(abs(S[[i]])) ## new 1.8-4 thresh <- .Machine$double.eps^.8 * maS ## .Machine$double.eps*maS*10 ind <- rsS > thresh & csS > thresh & dS > thresh # only these columns really penalize ss <- diag(S[[i]])[ind] # non-zero elements of l.d. S[[i]] start <- off[i];finish <- start+ncol(S[[i]])-1 xx <- ldxx[start:finish] xx <- xx[ind] pen[start:finish] <- pen[start:finish]|ind sizeXX <- mean(xx) sizeS <- mean(ss) if (sizeS <= 0) stop(gettextf("S[[%d]] matrix is not +ve definite.", i)) def.sp[i] <- sizeXX/ sizeS # relative s.p. estimate ## accumulate leading diagonal of \sum sp[i]*S[[i]] ldss[start:finish] <- ldss[start:finish] + def.sp[i]*diag(S[[i]]) if (expensive) St[start:finish,start:finish] <- St[start:finish,start:finish] + def.sp[i]*S[[i]] } if (expensive) { ## does full search for overall s.p. msp <- single.sp(X,St) if (msp>0) def.sp <- def.sp*msp } else { ind <- ldss > 0 & pen & ldxx > 0 # base following only on penalized terms ldxx<-ldxx[ind];ldss<-ldss[ind] while (mean(ldxx/(ldxx+ldss))>.4) { def.sp <- def.sp*10;ldss <- ldss*10 } while (mean(ldxx/(ldxx+ldss))<.4) { def.sp <- def.sp/10;ldss <- ldss/10 } } } as.numeric(def.sp) } ## initial.sp magic <- function(y,X,sp,S,off,L=NULL,lsp0=NULL,rank=NULL,H=NULL,C=NULL,w=NULL,gamma=1,scale=1,gcv=TRUE, ridge.parameter=NULL,control=list(tol=1e-6,step.half=25, rank.tol=.Machine$double.eps^0.5),extra.rss=0,n.score=length(y),nthreads=1) # Wrapper for C routine magic. Deals with constraints weights and square roots of # penalties. # y is data vector, X is model matrix, sp is array of smoothing parameters, # S is list of penalty matrices stored as smallest square submatrix excluding no # non-zero entries, off[i] is the location on the leading diagonal of the # total penalty matrix of element (1,1) of S[[i]], rank is an array of penalty # ranks, L is a matrix mapping the log underlying smoothing parameters to the # smoothing parameters that actually multiply the penalties. i.e. the # log smoothing parameters are L%*%sp + lsp0 # H is any fixed penalty, C is a linear constraint matrix and w is the # weight vector. gamma is the dof inflation factor, scale is the scale parameter, only # used with UBRE, gcv TRUE means use GCV, if false, use UBRE. # Return list includes rV such that cov(b)=rV%*%t(rV)*scale and the leading diagonal # of rV%*%t(rV)%*%t(X)%*%X gives the edf for each parameter. # NOTE: W is assumed to be square root of inverse of covariance matrix. i.e. if # W=diag(w) RSS is ||W(y-Xb||^2 # If `ridge.parameter' is a positive number then then it is assumed to be the multiplier # for a ridge penalty to be applied during fitting. # `extra.rss' is an additive constant by which the RSS is modified in the # GCV/UBRE or scale calculations, n.score is the `n' to use in the GCV/UBRE # score calcualtions (Useful for dealing with huge datasets). { if (is.null(control)) control <- list() if (is.null(control$tol)) control$tol <- 1e-6 if (is.null(control$step.half)) control$step.half <- 25 if (is.null(control$rank.tol)) control$rank.tol <- .Machine$double.eps^0.5 n.p<-length(S) n.b<-dim(X)[2] # number of parameters # get initial estimates of smoothing parameters, using better method than is # built in to C code. This must be done before application of general # constraints. if (n.p) def.sp <- initial.sp(X,S,off) else def.sp <- sp if (!is.null(L)) { ## have to estimate appropriate starting coefs if (!inherits(L,"matrix")) stop("L must be a matrix.") if (nrow(L)0) { for (i in 1:n.p) { if (is.null(rank)) B <- mroot(S[[i]],method="svd") else B <- mroot(S[[i]],rank=rank[i],method="chol") m <- dim(B)[2] R<-matrix(0,n.b,m) R[off[i]:(off[i]+dim(B)[1]-1),]<-B S[[i]]<-R } rm(B);rm(R) } # if there are constraints then need to form null space of constraints Z # (from final columns of Q, from QR=C'). Then form XZ and Z'S_i^0.5 for all i # and Z'HZ. # On return from mgcv2 set parameters to Zb (apply Q to [0,b']'). ##Xo<-X if (!is.null(C)) # then impose constraints { n.con<-dim(C)[1] ns.qr<-qr(t(C)) # last n.b-n.con columns of Q are the null space of C X<-t(qr.qty(ns.qr,t(X)))[,(n.con+1):n.b,drop=FALSE] # last n.b-n.con cols of XQ (=(Q'X')') # need to work through penalties forming Z'S_i^0.5 's if (n.p>0) for (i in 1:n.p) { S[[i]]<-qr.qty(ns.qr,S[[i]])[(n.con+1):n.b,,drop=FALSE] ## following essential given assumptions of the C code... if (ncol(S[[i]])>nrow(S[[i]])) { ## no longer have a min col square root. S[[i]] <- t(qr.R(qr(t(S[[i]])))) ## better! } } # and Z'HZ too if (!is.null(H)) { H<-qr.qty(ns.qr,H)[(n.con+1):n.b,,drop=FALSE] # Z'H H<-t(qr.qty(ns.qr,t(H))[(n.con+1):n.b,,drop=FALSE]) # Z'HZ = (Z'[Z'H]')' } full.rank=n.b-n.con } else full.rank=n.b # now deal with weights.... if (!is.null(w)) { if (is.matrix(w)) { if (dim(w)[1]!=dim(w)[2]||dim(w)[2]!=dim(X)[1]) stop("dimensions of supplied w wrong.") y<-w%*%y X<-w%*%X } else { if (length(y)!=length(w)) stop("w different length from y!") y<-y*w X<-as.vector(w)*X # use recycling rule to form diag(w)%*%X cheaply } } if (is.null(dim(X))) { # lost dimensions as result of being single columned! n <- length(y) if (n!=length(X)) stop("X lost dimensions in magic!!") dim(X) <- c(n,1) } # call real mgcv engine... Si<-array(0,0);cS<-0 if (n.p>0) for (i in 1:n.p) { Si <- c(Si,S[[i]]); cS[i] <- dim(S[[i]])[2] } rdef <- ncol(X) - nrow(X) if (rdef>0) { ## need to zero pad model matrix n.score <- n.score ## force evaluation *before* y lengthened X <- rbind(X,matrix(0,rdef,ncol(X))) y <- c(y,rep(0,rdef)) } icontrol<-as.integer(gcv);icontrol[2]<-length(y);q<-icontrol[3]<-dim(X)[2]; if (!is.null(ridge.parameter)&&ridge.parameter>0) { if(is.null(H)) H<-diag(ridge.parameter,q) else H<-H+diag(ridge.parameter,q)} icontrol[4]<-as.integer(!is.null(H));icontrol[5]<- n.p;icontrol[6]<-control$step.half if (is.null(L)) { icontrol[7] <- -1;L <- diag(n.p) } else icontrol[7]<-ncol(L) if (is.null(lsp0)) lsp0 <- rep(0,nrow(L)) b<-array(0,icontrol[3]) # argument names in call refer to returned values. if (nthreads<1) nthreads <- 1 ## can't set up storage without knowing nthreads if (nthreads>1) extra.x <- q^2 * nthreads else extra.x <- 0 um<-.C(C_magic,as.double(y),X=as.double(c(X,rep(0,extra.x))),sp=as.double(sp),as.double(def.sp), as.double(Si),as.double(H),as.double(L), lsp0=as.double(lsp0),score=as.double(gamma),scale=as.double(scale),info=as.integer(icontrol),as.integer(cS), as.double(control$rank.tol),rms.grad=as.double(control$tol),b=as.double(b),rV=double(q*q), as.double(extra.rss),as.integer(n.score),as.integer(nthreads)) res<-list(b=um$b,scale=um$scale,score=um$score,sp=um$sp,sp.full=as.numeric(exp(L%*%log(um$sp)))) res$R <- matrix(um$X[1:q^2],q,q) res$rV<-matrix(um$rV[1:(um$info[1]*q)],q,um$info[1]) gcv.info<-list(full.rank=full.rank,rank=um$info[1],fully.converged=as.logical(um$info[2]), hess.pos.def=as.logical(um$info[3]),iter=um$info[4],score.calls=um$info[5],rms.grad=um$rms.grad) res$gcv.info<-gcv.info if (!is.null(C)) { # need image of constrained parameter vector in full space b <- c(rep(0,n.con),res$b) res$b <- qr.qy(ns.qr,b) # Zb b <- matrix(0,n.b,dim(res$rV)[2]) b[(n.con+1):n.b,] <- res$rV res$rV <- qr.qy(ns.qr,b)# ZrV } res } ## magic print.mgcv.version <- function() { library(help=mgcv)$info[[1]] -> version version <- version[pmatch("Version",version)] um <- strsplit(version," ")[[1]] version <- um[nchar(um)>0][2] hello <- paste("This is mgcv ",version,". For overview type 'help(\"mgcv-package\")'.",sep="") packageStartupMessage(hello) } set.mgcv.options <- function() ## function used to set optional value used in notLog ## and notExp... { ##runif(1) ## ensure there is a seed (can be removed by user!) options(mgcv.vc.logrange=25) } .onLoad <- function(...) { set.mgcv.options() } .onAttach <- function(...) { print.mgcv.version() set.mgcv.options() } .onUnload <- function(libpath) library.dynam.unload("mgcv", libpath) ############################################################################### ### ISSUES..... # #* Could use R_CheckUserInterrupt() to allow user interupt of # mgcv code. (6.12) But then what about memory?# # #* predict.gam and plot.gam "iterms" and `seWithMean' options # don't deal properly with case in which centering constraints # are not conventional sum to zero ones. # # * add randomized residuals (see Mark B email)? # # * sort out all the different scale parameters floating around, and explain the # sp variance link better. mgcv/R/jagam.r0000644000177400001440000004322113002141017013032 0ustar murdochusers## (c) Simon Wood 2014. Released under GPL2. ## jagam code (Just Another Gibbs Additive Model) ## Code offering JAGS/BUGS support for mgcv. ## In particular autogenerates the code and data to fit an mgcv ## style GAM in JAGS, and re-packages the simulation output ## in a form suitable for plotting and prediction. ## Idea is that the code would be modified to add the sort ## of random effects structure most appropriately handled in JAGS. write.jagslp <- function(resp,family,file,use.weights,offset=FALSE) { ## write the JAGS code for the linear predictor ## and response distribution. iltab <- ## table of inverse link functions c("eta[i]","exp(eta[i])","ilogit(eta[i])","phi(eta[i])","1/eta[i]","eta[i]^2") names(iltab) <- c("identity","log","logit","probit","inverse","sqrt") if (!family$link%in%names(iltab)) stop("sorry link not yet handled") ## code linear predictor and expected response... if (family$link=="identity") { if (offset) cat(" mu <- X %*% b + offset ## expected response\n",file=file,append=TRUE) else cat(" mu <- X %*% b ## expected response\n",file=file,append=TRUE) } else { if (offset) cat(" eta <- X %*% b + offset ## linear predictor\n",file=file,append=TRUE) else cat(" eta <- X %*% b ## linear predictor\n",file=file,append=TRUE) cat(" for (i in 1:n) { mu[i] <- ",iltab[family$link],"} ## expected response\n",file=file,append=TRUE) } ## code the response given mu and any scale parameter prior... #scale <- TRUE ## is scale parameter free? cat(" for (i in 1:n) { ",file=file,append=TRUE) if (family$family=="gaussian") { if (use.weights) cat(resp,"[i] ~ dnorm(mu[i],tau*w[i]) } ## response \n",sep="",file=file,append=TRUE) else cat(resp,"[i] ~ dnorm(mu[i],tau) } ## response \n",sep="",file=file,append=TRUE) cat(" scale <- 1/tau ## convert tau to standard GLM scale\n",file=file,append=TRUE) cat(" tau ~ dgamma(.05,.005) ## precision parameter prior \n",file=file,append=TRUE) } else if (family$family=="poisson") { # scale <- FALSE cat(resp,"[i] ~ dpois(mu[i]) } ## response \n",sep="",file=file,append=TRUE) if (use.weights) warning("weights ignored") use.weights <- FALSE } else if (family$family=="binomial") { # scale <- FALSE cat(resp,"[i] ~ dbin(mu[i],w[i]) } ## response \n",sep="",file=file,append=TRUE) use.weights <- TRUE } else if (family$family=="Gamma") { if (use.weights) cat(resp,"[i] ~ dgamma(r*w[i],r*w[i]/mu[i]) } ## response \n",sep="",file=file,append=TRUE) else cat(resp,"[i] ~ dgamma(r,r/mu[i]) } ## response \n",sep="",file=file,append=TRUE) cat(" r ~ dgamma(.05,.005) ## scale parameter prior \n",file=file,append=TRUE) cat(" scale <- 1/r ## convert r to standard GLM scale\n",file=file,append=TRUE) } else stop("family not implemented yet") use.weights } ## write.jagslp jini <- function(G,lambda) { ## get initial coefficients to initialize JAGS, otherwise ## initialization is hit and miss. y <- G$y; nobs <- length(y); p <- ncol(G$X) family <- G$family weights <- G$w start <- mustart <- etastart <- NULL ## ignore codetools warning - needed for eval eval(G$family$initialize) w <- as.numeric(G$w * family$mu.eta(family$linkfun(mustart))^2/family$variance(mustart)) w <- sqrt(w) z <- c(w*family$linkfun(mustart),rep(0,p)) ## residual is zero, so eta is all there is! X <- rbind(w*G$X,matrix(0,p,p)) ## now append square roots of penalties uoff <- unique(G$off) for (i in 1:length(uoff)) { jj <- which(G$off%in%uoff[i]) S <- G$S[[jj[1]]]*lambda[[jj[1]]] m <- length(jj) if (m>1) for (j in jj) S <- S + G$S[[j]]*lambda[j] S <- t(mroot(S)) jj <- nrow(S) X[(nobs+1):(nobs+jj),uoff[i]:(uoff[i]+ncol(S)-1)] <- S nobs <- nobs + jj } ## we need some idea of initial coeffs and some idea of ## associated standard error... qrx <- qr(X,LAPACK=TRUE) rp <- qrx$pivot;rp[rp] <- 1:ncol(X) Ri <- backsolve(qr.R(qrx),diag(1,nrow=ncol(X)))[rp,] beta <- qr.coef(qrx,z) se <- sqrt(rowSums(Ri^2))*sqrt(sum((z-X%*%beta)^2)/nrow(X)) list(beta=beta,se=se) } ## jini jagam <- function(formula,family=gaussian,data=list(),file,weights=NULL,na.action, offset=NULL,knots=NULL,sp=NULL,drop.unused.levels=TRUE,control=gam.control(),centred=TRUE, sp.prior = "gamma",diagonalize=FALSE) { ## rho contains log smoothing params and b the model coefficients, in JAGS ## diagonalize==TRUE actually seems to be faster for high dimensional terms ## in the Gaussian setting (Conjugate updates better than MH), otherwise ## diagonalize==FALSE faster as block MH is highly advantageous ## WARNING: centred=FALSE is usually a very bad idea!! if (is.null(file)) stop("jagam requires a file for the JAGS model specification") cat("model {\n",file=file) ## start the model specification if (!(sp.prior %in% c("gamma","log.uniform"))) { warning("smoothing parameter prior choise not recognised, reset to gamma") } ## takes GAM formula and data and produces JAGS model and corresponding ## data list... if (is.character(family)) family <- eval(parse(text = family)) if (is.function(family)) family <- family() if (is.null(family$family)) stop("family not recognized") gp <- interpret.gam(formula) # interpret the formula cl <- match.call() # call needed in gam object for update to work mf <- match.call(expand.dots=FALSE) mf$formula <- gp$fake.formula mf$family <- mf$knots <- mf$sp <- mf$file <- mf$control <- mf$centred <- mf$sp.prior <- mf$diagonalize <- NULL mf$drop.unused.levels <- drop.unused.levels mf[[1]] <- quote(stats::model.frame) ##as.name("model.frame") pmf <- mf pmf$formula <- gp$pf pmf <- eval(pmf, parent.frame()) # pmf contains all data for parametric part pterms <- attr(pmf,"terms") ## pmf only used for this rm(pmf) mf <- eval(mf, parent.frame()) # the model frame now contains all the data if (nrow(mf)<2) stop("Not enough (non-NA) data to do anything meaningful") terms <- attr(mf,"terms") ## summarize the *raw* input variables ## note can't use get_all_vars here -- buggy with matrices vars <- all.vars(gp$fake.formula[-2]) ## drop response here inp <- parse(text = paste("list(", paste(vars, collapse = ","),")")) ## allow a bit of extra flexibility in what `data' is allowed to be (as model.frame actually does) if (!is.list(data)&&!is.data.frame(data)) data <- as.data.frame(data) dl <- eval(inp, data, parent.frame()) if (!control$keepData) { rm(data)} ## save space names(dl) <- vars ## list of all variables needed var.summary <- variable.summary(gp$pf,dl,nrow(mf)) ## summarize the input data rm(dl) G <- gam.setup(gp,pterms=pterms, data=mf,knots=knots,sp=sp, H=NULL,absorb.cons=centred,sparse.cons=FALSE,select=TRUE, idLinksBases=TRUE,scale.penalty=control$scalePenalty, diagonal.penalty=diagonalize) G$model <- mf;G$terms <- terms;G$family <- family;G$call <- cl G$var.summary <- var.summary ## write JAGS code producing linear predictor and linking linear predictor to ## response.... use.weights <- if (is.null(weights)) FALSE else TRUE use.weights <- write.jagslp("y",family,file,use.weights,!is.null(G$offset)) if (is.null(weights)&&use.weights) weights <- rep(1,nrow(G$X)) ## start the JAGS data list... jags.stuff <- list(y=G$y,n=length(G$y),X=G$X) if (!is.null(G$offset)) jags.stuff$offset <- G$offset if (use.weights) jags.stuff$w <- weights if (family$family == "binomial") jags.stuff$y <- G$y*weights ## JAGS not expecting observed prob!! ## get initial values, for use by JAGS, and to guess suitable values for ## uninformative priors... lambda <- initial.spg(G$X,G$y,G$w,family,G$S,G$rank,G$off,offset=G$offset,L=G$L) ## initial sp values jags.ini <- list() lam <- if (is.null(G$L)) lambda else G$L%*%lambda jin <- jini(G,lam) jags.ini$b <- jin$beta prior.tau <- signif(0.01/(abs(jin$beta) + jin$se)^2,2) ## set the fixed effect priors... if (G$nsdf>0) { ptau <- min(prior.tau[1:G$nsdf]) cat(" ## Parametric effect priors CHECK tau=1/",signif(1/sqrt(ptau),2),"^2 is appropriate!\n",file=file,append=TRUE,sep="") cat(" for (i in 1:",G$nsdf,") { b[i] ~ dnorm(0,",ptau,") }\n",file=file,append=TRUE,sep="") } ## Work through smooths. ## In JAGS terms the penalties should simply define priors. ## Any unpenalized term should be given a diffuse prior. ## For diagonalized terms these should be written directly into the code ## and there is nothing to pass to JAGS. ## For overlapping multi term penalties, a null space penalty needs to ## be added and the components of the penalty have to be passed into ## JAGS in the argument list: cbinding the components into one matrix seems sensible. ## Smoothing parameters should be in a single vector in the code indexed by ## number. n.sp <- 0 ## count the smoothing parameters.... for (i in 1:length(G$smooth)) { ## Are penalties seperable... seperable <- FALSE M <- length(G$smooth[[i]]$S) p <- G$smooth[[i]]$last.para - G$smooth[[i]]$first.para + 1 ## number of params if (M<=1) seperable <- TRUE else { overlap <- rowSums(G$smooth[[i]]$S[[1]]) for (j in 2:M) overlap <- overlap & rowSums(G$smooth[[i]]$S[[j]]) if (!sum(overlap)) seperable <- TRUE } if (seperable) { ## double check that they are diagonal if (M>0) for (j in 1:M) { if (max(abs(G$smooth[[i]]$S[[j]] - diag(diag(G$smooth[[i]]$S[[j]]),nrow=p)))>0) seperable <- FALSE } } cat(" ## prior for ",G$smooth[[i]]$label,"... \n",file=file,append=TRUE,sep="") if (seperable) { b0 <- G$smooth[[i]]$first.para if (M==0) { cat(" ## Note fixed vague prior, CHECK tau = 1/",signif(1/sqrt(ptau),2),"^2...\n",file=file,append=TRUE,sep="") b1 <- G$smooth[[i]]$last.para ptau <- min(prior.tau[b0:b1]) cat(" for (i in ",b0,":",b1,") { b[i] ~ dnorm(0,",ptau,") }\n",file=file,append=TRUE,sep="") } else for (j in 1:M) { D <- diag(G$smooth[[i]]$S[[j]]) > 0 b1 <- sum(as.numeric(D)) + b0 - 1 n.sp <- n.sp + 1 cat(" for (i in ",b0,":",b1,") { b[i] ~ dnorm(0, lambda[",n.sp,"]) }\n",file=file,append=TRUE,sep="") b0 <- b1 + 1 } } else { ## inseperable - requires the penalty matrices to be supplied to JAGS... b0 <- G$smooth[[i]]$first.para; b1 <- G$smooth[[i]]$last.para Kname <- paste("K",i,sep="") ## total penalty matrix in JAGS Sname <- paste("S",i,sep="") ## components of total penalty in R & JAGS cat(" ",Kname," <- ",Sname,"[1:",p,",1:",p,"] * lambda[",n.sp+1,"] ", file=file,append=TRUE,sep="") if (M>1) { ## code to form total precision matrix... for (j in 2:M) cat(" + ",Sname,"[1:",p,",",(j-1)*p+1,":",j*p,"] * lambda[",n.sp+j,"]", file=file,append=TRUE,sep="") } cat("\n b[",b0,":",b1,"] ~ dmnorm(zero[",b0,":",b1,"],",Kname,") \n" ,file=file,append=TRUE,sep="") n.sp <- n.sp + M Sc <- G$smooth[[i]]$S[[1]] if (M>1) for (j in 2:M) Sc <- cbind(Sc,G$smooth[[i]]$S[[j]]) jags.stuff[[Sname]] <- Sc jags.stuff$zero <- rep(0,ncol(G$X)) } } ## smoothing penalties finished ## Write the smoothing parameter prior code, using L if it exists. cat(" ## smoothing parameter priors CHECK...\n",file=file,append=TRUE,sep="") if (is.null(G$L)) { if (sp.prior=="log.uniform") { cat(" for (i in 1:",n.sp,") {\n",file=file,append=TRUE,sep="") cat(" rho[i] ~ dunif(-12,12)\n",file=file,append=TRUE,sep="") cat(" lambda[i] <- exp(rho[i])\n",file=file,append=TRUE,sep="") cat(" }\n",file=file,append=TRUE,sep="") jags.ini$rho <- log(lambda) } else { ## gamma priors cat(" for (i in 1:",n.sp,") {\n",file=file,append=TRUE,sep="") cat(" lambda[i] ~ dgamma(.05,.005)\n",file=file,append=TRUE,sep="") cat(" rho[i] <- log(lambda[i])\n",file=file,append=TRUE,sep="") cat(" }\n",file=file,append=TRUE,sep="") jags.ini$lambda <- lambda } } else { jags.stuff$L <- G$L rho.lo <- FALSE if (any(G$lsp0!=0)) { jags.stuff$rho.lo <- G$lsp0 rho.lo <- TRUE } nr <- ncol(G$L) if (sp.prior=="log.uniform") { cat(" for (i in 1:",nr,") { rho0[i] ~ dunif(-12,12) }\n",file=file,append=TRUE,sep="") if (rho.lo) cat(" rho <- rho.lo + L %*% rho0\n",file=file,append=TRUE,sep="") else cat(" rho <- L %*% rho0\n",file=file,append=TRUE,sep="") cat(" for (i in 1:",n.sp,") { lambda[i] <- exp(rho[i]) }\n",file=file,append=TRUE,sep="") jags.ini$rho0 <- log(lambda) } else { ## gamma prior cat(" for (i in 1:",nr,") {\n",file=file,append=TRUE,sep="") cat(" lambda0[i] ~ dgamma(.05,.005)\n",file=file,append=TRUE,sep="") cat(" rho0[i] <- log(lambda0[i])\n",file=file,append=TRUE,sep="") cat(" }\n",file=file,append=TRUE,sep="") if (rho.lo) cat(" rho <- rho.lo + L %*% rho0\n",file=file,append=TRUE,sep="") else cat(" rho <- L %*% rho0\n",file=file,append=TRUE,sep="") cat(" for (i in 1:",n.sp,") { lambda[i] <- exp(rho[i]) }\n",file=file,append=TRUE,sep="") jags.ini$lambda0 <- lambda } } cat("}",file=file,append=TRUE) G$formula=formula G$rank=ncol(G$X) ## to Gibbs sample we force full rank! list(pregam=G,jags.data=jags.stuff,jags.ini=jags.ini) } ## jagam sim2jam <- function(sam,pregam,edf.type=2,burnin=0) { ## takes jags simulation output with field, b, containing model coefficients ## and a pregam object from jagam, and attempts to create a fake gam object suitable ## for plotting. This is given a class "jam" since only a limited range of gam ## methods are appropriate for such models. Ideally... ## vcov, print, plot, predict, model.matrix, ... if (is.null(sam$b)) stop("coefficient simulation data is missing") if (burnin>0) { nc <- dim(sam$b)[2] ## chain length if (burnin >= nc*.9) { warning("burnin too large, reset") burnin <- min(nc-1,floor(nc * .9)) } ind <- (burnin+1):nc sam$b <- sam$b[,ind,] if (!is.null(sam$mu)) sam$mu <- sam$mu[,ind,] if (!is.null(sam$rho)) sam$rho <- sam$rho[,ind,] if (!is.null(sam$scale)) sam$scale <- sam$scale[,ind,] } pregam$Vp <- cov(t(sam$b[,,1])) pregam$coefficients <- rowMeans(sam$b[,,1]) pregam$sig2 <- if (is.null(sam$scale)) 1 else mean(sam$scale) n.chain <- dim(sam$b)[3] if (n.chain>1) { for (i in 2:n.chain) { pregam$Vp <- pregam$Vp + cov(t(sam$b[,,i])) pregam$coefficients <- pregam$coefficients + rowMeans(sam$b[,,i]) } pregam$Vp <- pregam$Vp/n.chain pregam$coefficients <- pregam$coefficients/n.chain } ## NOTE: 3 edf versions... ## 0. diag((X'X+S)^{-1}X'X) ## 1. diag((X'WX+S)^-1X'WX) ## 2. diag(VbX'WX)/scale Vb by simulation. mu used for W may also be by sim. if (edf.type<2&&is.null(sam$rho)) { edf.type <- 2 warning("rho missing from simulation data edf.type reset to 2") } if (edf.type > 0) { ## use X'WX not X'X if (is.null(sam$mu)) { eta <- pregam$X %*% pregam$coefficients mu <- pregam$family$linkinv(eta) } else { mu <- rowMeans(sam$mu) eta <- pregam$family$linkfun(mu) } w <- as.numeric(pregam$w * pregam$family$mu.eta(eta)^2/pregam$family$variance(mu)) XWX <- t(pregam$X) %*% (w*pregam$X) } else XWX <- t(pregam$X) %*% (pregam$X) if (edf.type < 2) { ## tr((X'WX + S)^{-1}X'WX rho <- rowMeans(sam$rho);lambda <- exp(rho) XWXS <- XWX for (i in 1:length(lambda)) { ind <- pregam$off[i]:(pregam$off[i]+ncol(pregam$S[[i]])-1) XWXS[ind,ind] <- XWXS[ind,ind] + pregam$S[[i]] * lambda[i] } pregam$edf <- diag(solve(XWXS,XWX)) } else pregam$edf <- rowSums(pregam$Vp*t(XWX))/pregam$sig2 ## tr(Vb%*%XWX)/scale class(pregam) <- "jam" pregam } ## sim2jam ## method functions. Simple wrappers for gam methods ## idea is to limit options to those generally computable... print.jam <- function(x,...) print.gam(x,...) vcov.jam <- function(object,...) vcov.gam(object,...) plot.jam <- function(x,rug=TRUE,se=TRUE,pages=0,select=NULL,scale=-1, n=100,n2=40,pers=FALSE,theta=30,phi=30,jit=FALSE,xlab=NULL, ylab=NULL,main=NULL,ylim=NULL,xlim=NULL,too.far=0.1, shade=FALSE,shade.col="gray80", shift=0,trans=I,seWithMean=FALSE, scheme=0,...) { ## residuals, unconditional, by.resids and all.terms not supported... arg.names <- names(list(...)) if (length(arg.names)>0) { if ("residuals"%in% arg.names) stop("residuals argument not supported") if ("unconditional"%in% arg.names) stop("unconditional argument not meaningful here") if ("by.resids"%in% arg.names) stop("by.resids argument not supported") if ("all.terms"%in% arg.names) stop("all.terms argument not supported") } plot.gam(x,residuals=FALSE,rug=rug,se=se,pages=pages,select=select,scale=scale, n=n,n2=n2,pers=pers,theta=theta,phi=phi,jit=jit,xlab=xlab, ylab=ylab,main=main,ylim=ylim,xlim=xlim,too.far=too.far, all.terms=FALSE,shade=shade,shade.col=shade.col, shift=shift,trans=trans,seWithMean=seWithMean, unconditional=FALSE,by.resids=FALSE, scheme=scheme,...) } ## plot.jam predict.jam <- function(object,newdata,type="link",se.fit=FALSE,terms=NULL, block.size=NULL,newdata.guaranteed=FALSE,na.action=na.pass,...) { class(object) <- "gam" ## cheat! arg.names <- names(list(...)) if (length(arg.names)>0) { if ("unconditional"%in% arg.names) warning("unconditional argument not meaningful here") } predict.gam(object,newdata,type=type,se.fit=se.fit,terms=terms, block.size=block.size,newdata.guaranteed=newdata.guaranteed, na.action=na.action,unconditional=FALSE,...) } ## predict.jam mgcv/R/plots.r0000755000177400001440000016364613007044307013146 0ustar murdochusers## R plotting routines for the package mgcv (c) Simon Wood 2000-2010 ## With contributions from Henric Nilsson in.out <- function(bnd,x) { ## tests whether point defined by each row of x is inside ## or outside boundary defined by bnd. bnd my be made up of multiple ## nested loops. if (!is.matrix(x)) x <- matrix(x,1,2) ## replace NA segment separators with a numeric code lowLim <- min(bnd,na.rm=TRUE) - mean(abs(bnd),na.rm=TRUE) ind <- is.na(rowSums(bnd)) bnd[ind,] <- lowLim n <- nrow(bnd) um <-.C(C_in_out,bx=as.double(bnd[,1]),by=as.double(bnd[,2]),break.code=as.double(lowLim), x=as.double(x[,1]),y=as.double(x[,2]),inside=as.integer(x[,2]*0),nb=as.integer(n), n=as.integer(nrow(x))) as.logical(um$inside) } fix.family.qf <- function(fam) { ## add quantile function to family object if (!inherits(fam, "family")) stop("fam not a family object") if (!is.null(fam$qf)) return(fam) ## already exists family <- fam$family if (family=="poisson") { fam$qf <- function(p,mu,wt,scale) { qpois(p,mu) } } else if (family=="binomial") { fam$qf <- function(p,mu,wt,scale) { qbinom(p,wt,mu)/(wt + as.numeric(wt==0)) } } else if (family=="Gamma") { fam$qf <- function(p,mu,wt,scale) { qgamma(p,shape=1/scale,scale=mu*scale) } } else if (family=="gaussian") { fam$qf <- function(p,mu,wt,scale) { qnorm(p,mean=mu,sd=sqrt(scale/wt)) } } fam } fix.family.rd <- function(fam) { ## add random deviate function to family objet if (!inherits(fam, "family")) stop("fam not a family object") if (!is.null(fam$rd)) return(fam) ## already exists family <- fam$family if (family=="poisson") { fam$rd <- function(mu,wt,scale) { rpois(length(mu),mu) } } else if (family=="binomial") { fam$rd <- function(mu,wt,scale) { rbinom(mu,wt,mu)/(wt + as.numeric(wt==0)) } } else if (family=="Gamma") { fam$rd <- function(mu,wt,scale) { rgamma(mu,shape=1/scale,scale=mu*scale) } } else if (family=="gaussian") { fam$rd <- function(mu,wt,scale) { rnorm(mu,mean=mu,sd=sqrt(scale/wt)) } } else if (family=="inverse.gaussian") { fam$rd <- function(mu,wt,scale) { rig(mu,mu,scale) } } fam } qq.gam <- function(object, rep=0, level=.9,s.rep=10, type=c("deviance","pearson","response"), pch=".", rl.col=2, rep.col="gray80",...) { ## get deviance residual quantiles under good fit type <- match.arg(type) ylab <- paste(type,"residuals") if (inherits(object,c("glm","gam"))) { if (is.null(object$sig2)) object$sig2 <- summary(object)$dispersion } else stop("object is not a glm or gam") ## in case of NA & na.action="na.exclude", we need the "short" residuals: object$na.action <- NULL D <- residuals(object,type=type) if (object$method %in% c("PQL","lme.ML","lme.REML","lmer.REML","lmer.ML","glmer.ML")) { ## then it's come out of a gamm fitter and qq.gam can't see the random effects ## that would be necessary to get quantiles. Fall back to normal QQ plot. qqnorm(D,ylab=ylab,pch=pch,...) return() } lim <- Dq <- NULL if (rep==0) { fam <- fix.family.qf(object$family) if (is.null(fam$qf)) rep <- 50 ## try simulation if quantile function not available level <- 0 } n <- length(D) if (rep > 0) { ## simulate quantiles fam <- fix.family.rd(object$family) if (!is.null(fam$rd)) { ##d <- rep(0,0) ## simulate deviates... dm <- matrix(0,n,rep) for (i in 1:rep) { yr <- fam$rd(object$fitted.values, object$prior.weights, object$sig2) #di <- fam$dev.resids(yr,object$fitted.values,object$prior.weights)^.5* # sign(yr-object$fitted.values) object$y <- yr dm[,i] <- sort(residuals(object,type=type)) #d <- c(d,sort(di)) } # n <- length(D) Dq <- quantile(as.numeric(dm),(1:n - .5)/n) ## now get simulation limits on QQ plot #dm <- matrix(d,length(Dq),rep) alpha <- (1-level)/2 if (alpha>.5||alpha<0) alpha <- .05 if (level>0&&level<1) lim <- apply(dm,1,FUN=quantile,p=c(alpha,1-alpha)) else if (level >= 1) lim <- level } } else { ## ix <- sort.int(D,index.return=TRUE)$ix ## messes up under multiple ties! ix <- rank(D) U <- (ix-.5)/length(D) if (!is.null(fam$qf)) { dm <- matrix(0,n,s.rep) for (i in 1:s.rep) { U <- sample(U,n) ## randomize uniform quantiles w.r.t. obs q0 <- fam$qf(U,object$fitted.values,object$prior.weights,object$sig2) object$y <- q0 dm[,i] <- sort(residuals(object,type=type)) ## original proposal } Dq <- sort(rowMeans(dm)) # Dq <- quantile(as.numeric(dm),(1:n - .5)/n) # nd <- length(Dq) # q1 <- fam$qf(1-U,object$fitted.values,object$prior.weights,object$sig2) # object$y <- q1 # Dq <- sort(c(Dq,residuals(object,type=type))) # Dq <- (Dq[(1:nd)*2]+Dq[(1:nd)*2-1])*.5 ## more powerful alternative } } if (!is.null(Dq)) { qqplot(Dq,D,ylab=ylab,xlab="theoretical quantiles",ylim=range(c(lim,D)), pch=pch,...) abline(0,1,col=rl.col) if (!is.null(lim)) { if (level>=1) for (i in 1:rep) lines(Dq,dm[,i],col=rep.col) else { n <- length(Dq) polygon(c(Dq,Dq[n:1],Dq[1]),c(lim[1,],lim[2,n:1],lim[1,1]),col=rep.col,border=NA) } abline(0,1,col=rl.col) } points(Dq,sort(D),pch=pch,...) return(invisible(Dq)) } else qqnorm(D,ylab=ylab,pch=pch,...) } ## qq.gam k.check <- function(b,subsample=5000,n.rep=400) { ## function to check k in a gam fit... ## does a randomization test looking for evidence of residual ## pattern attributable to covariates of each smooth. m <- length(b$smooth) if (m==0) return(NULL) rsd <- residuals(b) ve <- rep(0,n.rep) p.val<-v.obs <- kc <- edf<- rep(0,m) snames <- rep("",m) n <- nrow(b$model) if (n>subsample) { ## subsample to avoid excessive cost ind <- sample(1:n,subsample) modf <- b$model[ind,] rsd <- rsd[ind] } else modf <- b$model nr <- length(rsd) for (k in 1:m) { ## work through smooths ok <- TRUE b$smooth[[k]]$by <- "NA" ## can't deal with by variables dat <- ExtractData(b$smooth[[k]],modf,NULL)$data if (!is.null(attr(dat,"index"))||!is.null(attr(dat[[1]],"matrix"))||is.matrix(dat[[1]])) ok <- FALSE if (ok) dat <- as.data.frame(dat) snames[k] <- b$smooth[[k]]$label ind <- b$smooth[[k]]$first.para:b$smooth[[k]]$last.para kc[k] <- length(ind) edf[k] <- sum(b$edf[ind]) nc <- b$smooth[[k]]$dim if (ok && ncol(dat)>nc) dat <- dat[,1:nc,drop=FALSE] ## drop any by variables for (j in 1:nc) if (is.factor(dat[[j]])) ok <- FALSE if (!ok) { p.val[k] <- v.obs[k] <- NA ## can't do this test with summation convention/factors } else { ## normal term if (nc==1) { ## 1-D term e <- diff(rsd[order(dat[,1])]) v.obs[k] <- mean(e^2)/2 for (i in 1:n.rep) { e <- diff(rsd[sample(1:nr,nr)]) ## shuffle ve[i] <- mean(e^2)/2 } p.val[k] <- mean(ve0) cat("\nHessian positive definite, ") else cat("\n") cat("eigenvalue range [",min(ev),",",max(ev),"].\n",sep="") } else { ## just default print of information .. cat("\n");print(b$outer.info) } } else { ## no sp, perf iter or AM case if (length(b$sp)==0) ## no sp's estimated cat("\nModel required no smoothing parameter selection") else { cat("\nSmoothing parameter selection converged after",b$mgcv.conv$iter,"iteration") if (b$mgcv.conv$iter>1) cat("s") if (!b$mgcv.conv$fully.converged) cat(" by steepest\ndescent step failure.\n") else cat(".\n") cat("The RMS",b$method,"score gradient at convergence was",b$mgcv.conv$rms.grad,".\n") if (b$mgcv.conv$hess.pos.def) cat("The Hessian was positive definite.\n") else cat("The Hessian was not positive definite.\n") #cat("The estimated model rank was ",b$mgcv.conv$rank, # " (maximum possible: ",b$mgcv.conv$full.rank,")\n",sep="") } } if (!is.null(b$rank)) { cat("Model rank = ",b$rank,"/",length(b$coefficients),"\n") } cat("\n") ## now check k kchck <- k.check(b,subsample=k.sample,n.rep=k.rep) if (!is.null(kchck)) { cat("Basis dimension (k) checking results. Low p-value (k-index<1) may\n") cat("indicate that k is too low, especially if edf is close to k\'.\n\n") printCoefmat(kchck,digits=3); } if (is.null(.Platform$GUI) ||.Platform$GUI != "RStudio") par(old.par) ## } else plot(linpred,resid,xlab="linear predictor",ylab="residuals",...) } ## end of gam.check ############################################# ## Start of plot method functions for smooths ############################################# plot.random.effect <- function(x,P=NULL,data=NULL,label="",se1.mult=1,se2.mult=2, partial.resids=FALSE,rug=TRUE,se=TRUE,scale=-1,n=100,n2=40, pers=FALSE,theta=30,phi=30,jit=FALSE,xlab=NULL,ylab=NULL,main=NULL, ylim=NULL,xlim=NULL,too.far=0.1,shade=FALSE,shade.col="gray80", shift=0,trans=I,by.resids=FALSE,scheme=0,...) { ## plot method for a "random.effect" smooth class if (is.null(P)) { ## get plotting information... if (!x$plot.me) return(NULL) else { ## shouldn't or can't plot raw <- data[x$term][[1]] p <- x$last.para - x$first.para + 1 X <- diag(p) # prediction matrix for this term if (is.null(xlab)) xlabel<- "Gaussian quantiles" else xlabel <- xlab if (is.null(ylab)) ylabel <- "effects" else ylabel <- ylab if (!is.null(main)) label <- main return(list(X=X,scale=FALSE,se=FALSE,raw=raw,xlab=xlabel,ylab=ylabel, main=label)) } ## end of basic plot data production } else { ## produce plot qqnorm(P$fit,main=P$main,xlab=P$xlab,ylab=P$ylab,...) qqline(P$fit) } ## end of plot production } ## end of plot.random.effect repole <- function(lo,la,lop,lap) { ## painfully plodding function to get new lo, la relative to pole at ## lap,lop... ## x,y,z location of pole... yp <- sin(lap) xp <- cos(lap)*sin(lop) zp <- cos(lap)*cos(lop) ## x,y,z location of meridian point for pole - i.e. point lat pi/2 ## from pole on pole's lon. ym <- sin(lap-pi/2) xm <- cos(lap-pi/2)*sin(lop) zm <- cos(lap-pi/2)*cos(lop) ## x,y,z locations of points in la, lo y <- sin(la) x <- cos(la)*sin(lo) z <- cos(la)*cos(lo) ## get angle between points and new equatorial plane (i.e. plane orthogonal to pole) d <- sqrt((x-xp)^2+(y-yp)^2+(z-zp)^2) ## distance from points to to pole phi <- pi/2-2*asin(d/2) ## location of images of la,lo on (new) equatorial plane ## sin(phi) gives distance to plane, -(xp, yp, zp) is ## direction... x <- x - xp*sin(phi) y <- y - yp*sin(phi) z <- z - zp*sin(phi) ## get distances to meridian point d <- sqrt((x-xm)^2+(y-ym)^2+(z-zm)^2) ## angles to meridian plane (i.e. plane containing origin, meridian point and pole)... theta <- (1+cos(phi)^2-d^2)/(2*cos(phi)) theta[theta < -1] <- -1; theta[theta > 1] <- 1 theta <- acos(theta) ## now decide which side of meridian plane... ## get points at extremes of hemispheres on either side ## of meridian plane.... y1 <- 0 x1 <- sin(lop+pi/2) z1 <- cos(lop+pi/2) y0 <- 0 x0 <- sin(lop-pi/2) z0 <- cos(lop-pi/2) d1 <- sqrt((x-x1)^2+(y-y1)^2+(z-z1)^2) d0 <- sqrt((x-x0)^2+(y-y0)^2+(z-z0)^2) ii <- d0 < d1 ## index -ve lon hemisphere theta[ii] <- -theta[ii] list(lo=theta,la=phi) } ## end of repole lolaxy <- function(lo,la,theta,phi) { ## takes locations lo,la, relative to a pole at lo=theta, la=phi. ## theta, phi are expressed relative to plotting co-ordinate system ## with pole at top. Convert to x,y in plotting co-ordinates. ## all in radians! er <- repole(-lo,la,-pi,phi) er$lo <- er$lo - theta y <- sin(er$la) x <- cos(er$la)*sin(er$lo) z <- cos(er$la)*cos(er$lo) ind <- z<0 list(x=x[ind],y=y[ind]) } ## end of lolaxy plot.sos.smooth <- function(x,P=NULL,data=NULL,label="",se1.mult=1,se2.mult=2, partial.resids=FALSE,rug=TRUE,se=TRUE,scale=-1,n=100,n2=40, pers=FALSE,theta=30,phi=30,jit=FALSE,xlab=NULL,ylab=NULL,main=NULL, ylim=NULL,xlim=NULL,too.far=0.1,shade=FALSE,shade.col="gray80", shift=0,trans=I,by.resids=FALSE,scheme=0,hcolors=heat.colors(100), contour.col=3,...) { ## plot method function for sos.smooth terms if (scheme>1) return(plot.mgcv.smooth(x,P=P,data=data,label=label,se1.mult=se1.mult,se2.mult=se2.mult, partial.resids=partial.resids,rug=rug,se=se,scale=scale,n=n,n2=n2, pers=pers,theta=theta,phi=phi,jit=jit,xlab=xlab,ylab=ylab,main=main, ylim=ylim,xlim=xlim,too.far=too.far,shade=shade,shade.col=shade.col, shift=shift,trans=trans,by.resids=by.resids,scheme=scheme-2, hcolors=hcolors,contour.col=contour.col,...)) ## convert location of pole in plotting grid to radians phi <- phi*pi/180 theta <- theta*pi/180 ## re-map to sensible values... theta <- theta%%(2*pi) if (theta>pi) theta <- theta - 2*pi phi <- phi%%(2*pi) if (phi > pi) phi <- phi - 2*pi if (phi > pi/2) phi <- pi - phi if (phi < -pi/2 ) phi <- -(phi+pi) if (is.null(P)) { ## get plotting information... if (!x$plot.me) return(NULL) ## shouldn't or can't plot ## get basic plot data raw <- data[x$term] if (rug) { ## need to project data onto plotting grid... raw <- lolaxy(lo=raw[[2]]*pi/180,la=raw[[1]]*pi/180,theta,phi) } m <- round(n2*1.5) ym <- xm <- seq(-1,1,length=m) gr <- expand.grid(x=xm,y=ym) r <- z <- gr$x^2+gr$y^2 z[z>1] <- NA z <- sqrt(1-z) ## generate la, lo in plotting grid co-ordinates... ind <- !is.na(z) r <- r[ind] la <- asin(gr$y[ind]) lo <- cos(la) lo <- asin(gr$x[ind]/lo) um <- repole(lo,la,theta,phi) dat <- data.frame(la=um$la*180/pi,lo=um$lo*180/pi) names(dat) <- x$term if (x$by!="NA") dat[[x$by]] <- la*0+1 X <- PredictMat(x,dat) # prediction matrix for this term ## fix lo for smooth contouring lo <- dat[[2]] ii <- lo <= -177 lo[ii] <- lo[ii] <- 360 + lo[ii] ii <- lo < -165 & lo > -177 ii <- ii | (abs(dat[[1]])>80) lo[ii] <- NA return(list(X=X,scale=FALSE,se=FALSE,raw=raw,xlab="",ylab="",main="", ind=ind,xm=xm,ym=ym,lo=lo,la=dat[[1]])) } else { ## do plot op <- par(pty="s",mar=c(0,0,0,0)) m <- length(P$xm); zz <- rep(NA,m*m) if (scheme == 0) { col <- 1# "lightgrey zz[P$ind] <- P$fit image(P$xm,P$ym,matrix(zz,m,m),col=hcolors,axes=FALSE,xlab="",ylab="",...) if (rug) { if (is.null(list(...)[["pch"]])) points(P$raw$x,P$raw$y,pch=".",...) else points(P$raw$x,P$raw$y,...) } zz[P$ind] <- P$la contour(P$xm,P$ym,matrix(zz,m,m),add=TRUE,levels=c(-8:8*10),col=col,...) zz[P$ind] <- P$lo contour(P$xm,P$ym,matrix(zz,m,m),add=TRUE,levels=c(-8:9*20),col=col,...) zz[P$ind] <- P$fit contour(P$xm,P$ym,matrix(zz,m,m),add=TRUE,col=contour.col,...) } else if (scheme == 1) { col <- 1 zz[P$ind] <- P$fit contour(P$xm,P$ym,matrix(zz,m,m),col=1,axes=FALSE,xlab="",ylab="",...) if (rug) { if (is.null(list(...)[["pch"]])) points(P$raw$x,P$raw$y,pch=".",...) else points(P$raw$x,P$raw$y,...) } zz[P$ind] <- P$la contour(P$xm,P$ym,matrix(zz,m,m),add=TRUE,levels=c(-8:8*10),col=col,lty=2,...) zz[P$ind] <- P$lo contour(P$xm,P$ym,matrix(zz,m,m),add=TRUE,levels=c(-8:9*20),col=col,lty=2,...) theta <- seq(-pi/2,pi/2,length=200) x <- sin(theta);y <- cos(theta) x <- c(x,x[200:1]);y <- c(y,-y[200:1]) lines(x,y) } par(op) } } ## end plot.sos.smooth poly2 <- function(x,col) { ## let x be a 2 col matrix defining some polygons. ## Different closed loop sections are separated by ## NA rows. This routine assumes that loops nested within ## other loops are holes (further nesting gives and island ## in hole, etc). Holes are left unfilled. ## The first polygon should not be a hole. ind <- (1:nrow(x))[is.na(rowSums(x))] ## where are the splits? if (length(ind)==0|| ind[1]==nrow(x)) polygon(x,col=col,border="black") else { base <- x[1,] xf <- x xf[ind,1] <- base[1] xf[ind,2] <- base[2] if (!is.na(col)) polygon(xf,col=col,border=NA,fillOddEven=TRUE) polygon(x,border="black") } } polys.plot <- function(pc,z=NULL,scheme="heat",lab="",...) { ## pc is a list of polygons defining area boundaries ## pc[[i]] is the 2 col matrix of vertex co-ords for polygons defining ## boundary of area i ## z gives the value associated with the area ## first find the axes ranges... for (i in 1:length(pc)) { yr <- range(pc[[i]][,2],na.rm=TRUE) xr <- range(pc[[i]][,1],na.rm=TRUE) if (i==1) { ylim <- yr xlim <- xr } else { if (yr[1]ylim[2]) ylim[2] <- yr[2] if (xr[1]xlim[2]) xlim[2] <- xr[2] } } ## end of axes range loop mar <- par("mar"); oldpar <- par(mar=c(2,mar[2],2,1)) if (is.null(z)) { ## no z value, no shading, no scale, just outlines... plot(0,0,ylim=ylim,xlim=xlim,xaxt="n",yaxt="n",type="n",bty="n",ylab=lab,xlab="",...) for (i in 1:length(pc)) { poly2(pc[[i]],col=NA) } } else { nz <- names(z) npc <- names(pc) if (!is.null(nz)&&!is.null(npc)) { ## may have to re-order z into pc order. if (all.equal(sort(nz),sort(npc))!=TRUE) stop("names of z and pc must match") z <- z[npc] } xmin <- xlim[1] xlim[1] <- xlim[1] - .1 * (xlim[2]-xlim[1]) ## allow space for scale n.col <- 100 if (scheme=="heat") scheme <- heat.colors(n.col+1) else scheme <- gray(0:n.col/n.col) zlim <- range(pretty(z)) ## Now want a grey or color scale up the lhs of plot ## first scale the y range into the z range for plotting for (i in 1:length(pc)) pc[[i]][,2] <- zlim[1] + (zlim[2]-zlim[1])*(pc[[i]][,2]-ylim[1])/(ylim[2]-ylim[1]) ylim <- zlim plot(0,0,ylim=ylim,xlim=xlim,type="n",xaxt="n",bty="n",xlab="",ylab=lab,...) for (i in 1:length(pc)) { coli <- round((z[i] - zlim[1])/(zlim[2]-zlim[1])*n.col)+1 poly2(pc[[i]],col=scheme[coli]) } ## now plot the scale bar... xmin <- min(c(axTicks(1),xlim[1])) dx <- (xlim[2]-xlim[1])*.05 x0 <- xmin-2*dx x1 <- xmin+dx dy <- (ylim[2]-ylim[1])/n.col poly <- matrix(c(x0,x0,x1,x1,ylim[1],ylim[1]+dy,ylim[1]+dy,ylim[1]),4,2) for (i in 1:n.col) { polygon(poly,col=scheme[i],border=NA) poly[,2] <- poly[,2] + dy } poly <- matrix(c(x0,x0,x1,x1,ylim[1],ylim[2],ylim[2],ylim[1]),4,2) polygon(poly,border="black") } par(oldpar) } plot.mrf.smooth <- function(x,P=NULL,data=NULL,label="",se1.mult=1,se2.mult=2, partial.resids=FALSE,rug=TRUE,se=TRUE,scale=-1,n=100,n2=40, pers=FALSE,theta=30,phi=30,jit=FALSE,xlab=NULL,ylab=NULL,main=NULL, ylim=NULL,xlim=NULL,too.far=0.1,shade=FALSE,shade.col="gray80", shift=0,trans=I,by.resids=FALSE,scheme=0,...) { ## plot method function for mrf.smooth terms, depends heavily on polys.plot, above if (is.null(P)) { ## get plotting information... if (!x$plot.me||is.null(x$xt$polys)) return(NULL) ## shouldn't or can't plot ## get basic plot data raw <- data[x$term][[1]] dat <- data.frame(x=factor(names(x$xt$polys),levels=levels(x$knots))) names(dat) <- x$term X <- PredictMat(x,dat) # prediction matrix for this term if (is.null(xlab)) xlabel<- "" else xlabel <- xlab if (is.null(ylab)) ylabel <- "" else ylabel <- ylab return(list(X=X,scale=FALSE,se=FALSE,raw=raw,xlab=xlabel,ylab=ylabel, main=label)) } else { ## do plot if (scheme==0) scheme <- "heat" else scheme <- "grey" polys.plot(x$xt$polys,P$fit,scheme=scheme,lab=P$main,...) } } ## end plot.mrf.smooth plot.fs.interaction <- function(x,P=NULL,data=NULL,label="",se1.mult=1,se2.mult=2, partial.resids=FALSE,rug=TRUE,se=TRUE,scale=-1,n=100,n2=40, pers=FALSE,theta=30,phi=30,jit=FALSE,xlab=NULL,ylab=NULL,main=NULL, ylim=NULL,xlim=NULL,too.far=0.1,shade=FALSE,shade.col="gray80", shift=0,trans=I,by.resids=FALSE,scheme=0,...) { ## plot method for simple smooth factor interactions... if (is.null(P)) { ## get plotting info if (x$dim!=1) return(NULL) ## no method for base smooth dim > 1 raw <- data[x$base$term][[1]] xx <- seq(min(raw),max(raw),length=n) # generate x sequence for prediction nf <- length(x$flev) fac <- rep(x$flev,rep(n,nf)) dat <- data.frame(fac,xx) names(dat) <- c(x$fterm,x$base$term) X <- PredictMat(x,dat) if (is.null(xlab)) xlabel <- x$base$term else xlabel <- xlab if (is.null(ylab)) ylabel <- label else ylabel <- ylab return(list(X=X,scale=TRUE,se=FALSE,raw=raw,xlab=xlabel,ylab=ylabel, main="",x=xx,n=n,nf=nf)) } else { ## produce the plot ind <- 1:P$n if(is.null(ylim)) ylim <- range(P$fit) plot(P$x[ind],P$fit[ind],ylim=ylim,xlab=P$xlab,ylab=P$ylab,type="l",...) if (P$nf>1) for (i in 2:P$nf) { ind <- ind + P$n if (scheme==0) lines(P$x,P$fit[ind],lty=i,col=i) else lines(P$x,P$fit[ind],lty=i) } } } ## end plot.fs.interaction plot.mgcv.smooth <- function(x,P=NULL,data=NULL,label="",se1.mult=1,se2.mult=2, partial.resids=FALSE,rug=TRUE,se=TRUE,scale=-1,n=100,n2=40, pers=FALSE,theta=30,phi=30,jit=FALSE,xlab=NULL,ylab=NULL,main=NULL, ylim=NULL,xlim=NULL,too.far=0.1,shade=FALSE,shade.col="gray80", shift=0,trans=I,by.resids=FALSE,scheme=0,hcolors=heat.colors(50), contour.col=3,...) { ## default plot method for smooth objects `x' inheriting from "mgcv.smooth" ## `x' is a smooth object, usually part of a `gam' fit. It has an attribute ## 'coefficients' containg the coefs for the smooth, but usually these ## are not needed. ## `P' is a list of plot data. ## If `P' is NULL then the routine should compute some of this plot data ## and return without plotting... ## * X the matrix mapping the smooth's coefficients to the values at ## which the smooth must be computed for plotting. ## * The values against which to plot. ## * `exclude' indicates rows of X%*%p to set to NA for plotting -- NULL for none. ## * se TRUE if plotting of the term can use standard error information. ## * scale TRUE if the term should be considered by plot.gam if a common ## y scale is required. ## * any raw data information. ## * axis labels and plot titles ## As an alternative, P may contain a 'fit' field directly, in which case the ## very little processing is done outside the routine, except for partial residual ## computations. ## Alternatively return P as NULL if x should not be plotted. ## If P is not NULL it will contain ## * fit - the values for plotting ## * se.fit - standard errors of fit (can be NULL) ## * the values against which to plot ## * any raw data information ## * any partial.residuals ## `data' is a data frame containing the raw data for the smooth, usually the ## model.frame of the fitted gam. Can be NULL if P is not NULL. ## `label' is the term label, usually something like e.g. `s(x,12.34)'. ############################# sp.contour <- function(x,y,z,zse,xlab="",ylab="",zlab="",titleOnly=FALSE, se.plot=TRUE,se.mult=1,trans=I,shift=0,...) ## function for contouring 2-d smooths with 1 s.e. limits { gap<-median(zse,na.rm=TRUE) zr<-max(trans(z+zse+shift),na.rm=TRUE)-min(trans(z-zse+shift),na.rm=TRUE) # plotting range n<-10 while (n>1 && zr/n<2.5*gap) n<-n-1 zrange<-c(min(trans(z-zse+shift),na.rm=TRUE),max(trans(z+zse+shift),na.rm=TRUE)) zlev<-pretty(zrange,n) ## ignore codetools on this one yrange<-range(y);yr<-yrange[2]-yrange[1] xrange<-range(x);xr<-xrange[2]-xrange[1] ypos<-yrange[2]+yr/10 args <- as.list(substitute(list(...)))[-1] args$x <- substitute(x);args$y <- substitute(y) args$type="n";args$xlab<-args$ylab<-"";args$axes<-FALSE do.call("plot",args) cs<-(yr/10)/strheight(zlab);if (cs>1) cs<-1 # text scaling based on height tl<-strwidth(zlab); if (tl*cs>3*xr/10) cs<-(3*xr/10)/tl args <- as.list(substitute(list(...)))[-1] n.args <- names(args) zz <- trans(z+shift) ## ignore codetools for this args$x<-substitute(x);args$y<-substitute(y);args$z<-substitute(zz) if (!"levels"%in%n.args) args$levels<-substitute(zlev) if (!"lwd"%in%n.args) args$lwd<-2 if (!"labcex"%in%n.args) args$labcex<-cs*.65 if (!"axes"%in%n.args) args$axes <- FALSE if (!"add"%in%n.args) args$add <- TRUE do.call("contour",args) if (is.null(args$cex.main)) cm <- 1 else cm <- args$cex.main if (titleOnly) title(zlab,cex.main=cm) else { xpos<-xrange[1]+3*xr/10 xl<-c(xpos,xpos+xr/10); yl<-c(ypos,ypos) lines(xl,yl,xpd=TRUE,lwd=args$lwd) text(xpos+xr/10,ypos,zlab,xpd=TRUE,pos=4,cex=cs*cm,off=0.5*cs*cm) } if (is.null(args$cex.axis)) cma <- 1 else cma <- args$cex.axis axis(1,cex.axis=cs*cma);axis(2,cex.axis=cs*cma);box(); if (is.null(args$cex.lab)) cma <- 1 else cma <- args$cex.lab mtext(xlab,1,2.5,cex=cs*cma);mtext(ylab,2,2.5,cex=cs*cma) if (!"lwd"%in%n.args) args$lwd<-1 if (!"lty"%in%n.args) args$lty<-2 if (!"col"%in%n.args) args$col<-2 if (!"labcex"%in%n.args) args$labcex<-cs*.5 zz <- trans(z+zse+shift) args$z<-substitute(zz) do.call("contour",args) if (!titleOnly) { xpos<-xrange[1] xl<-c(xpos,xpos+xr/10)#;yl<-c(ypos,ypos) lines(xl,yl,xpd=TRUE,lty=args$lty,col=args$col) text(xpos+xr/10,ypos,paste("-",round(se.mult),"se",sep=""),xpd=TRUE,pos=4,cex=cs*cm,off=0.5*cs*cm) } if (!"lty"%in%n.args) args$lty<-3 if (!"col"%in%n.args) args$col<-3 zz <- trans(z - zse+shift) args$z<-substitute(zz) do.call("contour",args) if (!titleOnly) { xpos<-xrange[2]-xr/5 xl<-c(xpos,xpos+xr/10); lines(xl,yl,xpd=TRUE,lty=args$lty,col=args$col) text(xpos+xr/10,ypos,paste("+",round(se.mult),"se",sep=""),xpd=TRUE,pos=4,cex=cs*cm,off=0.5*cs*cm) } } ## end of sp.contour if (is.null(P)) { ## get plotting information... if (!x$plot.me||x$dim>2) return(NULL) ## shouldn't or can't plot if (x$dim==1) { ## get basic plotting data for 1D terms raw <- data[x$term][[1]] if (is.null(xlim)) xx <- seq(min(raw),max(raw),length=n) else # generate x sequence for prediction xx <- seq(xlim[1],xlim[2],length=n) if (x$by!="NA") # deal with any by variables { by<-rep(1,n);dat<-data.frame(x=xx,by=by) names(dat)<-c(x$term,x$by) } else { dat<-data.frame(x=xx);names(dat) <- x$term } ## prediction data.frame finished X <- PredictMat(x,dat) # prediction matrix for this term if (is.null(xlab)) xlabel<- x$term else xlabel <- xlab if (is.null(ylab)) ylabel <- label else ylabel <- ylab if (is.null(xlim)) xlim <- range(xx) return(list(X=X,x=xx,scale=TRUE,se=TRUE,raw=raw,xlab=xlabel,ylab=ylabel, main=main,se.mult=se1.mult,xlim=xlim)) } else { ## basic plot data for 2D terms xterm <- x$term[1] if (is.null(xlab)) xlabel <- xterm else xlabel <- xlab yterm <- x$term[2] if (is.null(ylab)) ylabel <- yterm else ylabel <- ylab raw <- data.frame(x=as.numeric(data[xterm][[1]]), y=as.numeric(data[yterm][[1]])) n2 <- max(10,n2) if (is.null(xlim)) xm <- seq(min(raw$x),max(raw$x),length=n2) else xm <- seq(xlim[1],xlim[2],length=n2) if (is.null(ylim)) ym <- seq(min(raw$y),max(raw$y),length=n2) else ym <- seq(ylim[1],ylim[2],length=n2) xx <- rep(xm,n2) yy <- rep(ym,rep(n2,n2)) if (too.far>0) exclude <- exclude.too.far(xx,yy,raw$x,raw$y,dist=too.far) else exclude <- rep(FALSE,n2*n2) if (x$by!="NA") # deal with any by variables { by <- rep(1,n2^2);dat <- data.frame(x=xx,y=yy,by=by) names(dat) <- c(xterm,yterm,x$by) } else { dat<-data.frame(x=xx,y=yy);names(dat)<-c(xterm,yterm) } ## prediction data.frame complete X <- PredictMat(x,dat) ## prediction matrix for this term if (is.null(main)) { main <- label } if (is.null(ylim)) ylim <- range(ym) if (is.null(xlim)) xlim <- range(xm) return(list(X=X,x=xm,y=ym,scale=FALSE,se=TRUE,raw=raw,xlab=xlabel,ylab=ylabel, main=main,se.mult=se2.mult,ylim=ylim,xlim=xlim,exclude=exclude)) } ## end of 2D basic plot data production } else { ## produce plot if (se) { ## produce CI's if (x$dim==1) { if (scheme == 1) shade <- TRUE ul <- P$fit + P$se ## upper CL ll <- P$fit - P$se ## lower CL if (scale==0&&is.null(ylim)) { ## get scale ylimit<-c(min(ll),max(ul)) if (partial.resids) { max.r <- max(P$p.resid,na.rm=TRUE) if ( max.r> ylimit[2]) ylimit[2] <- max.r min.r <- min(P$p.resid,na.rm=TRUE) if (min.r < ylimit[1]) ylimit[1] <- min.r } } ylimit <- if (is.null(ylim)) ylimit <- ylimit + shift else ylim ## plot the smooth... if (shade) { plot(P$x,trans(P$fit+shift),type="n",xlab=P$xlab,ylim=trans(ylimit), xlim=P$xlim,ylab=P$ylab,main=P$main,...) polygon(c(P$x,P$x[n:1],P$x[1]), trans(c(ul,ll[n:1],ul[1])+shift),col = shade.col,border = NA) lines(P$x,trans(P$fit+shift),...) } else { ## ordinary plot plot(P$x,trans(P$fit+shift),type="l",xlab=P$xlab,ylim=trans(ylimit),xlim=P$xlim, ylab=P$ylab,main=P$main,...) if (is.null(list(...)[["lty"]])) { lines(P$x,trans(ul+shift),lty=2,...) lines(P$x,trans(ll+shift),lty=2,...) } else { lines(P$x,trans(ul+shift),...) lines(P$x,trans(ll+shift),...) } } ## ... smooth plotted if (partial.resids&&(by.resids||x$by=="NA")) { ## add any partial residuals if (length(P$raw)==length(P$p.resid)) { if (is.null(list(...)[["pch"]])) points(P$raw,trans(P$p.resid+shift),pch=".",...) else points(P$raw,trans(P$p.resid+shift),...) } else { warning("Partial residuals do not have a natural x-axis location for linear functional terms") } } ## partial residuals finished if (rug) { if (jit) rug(jitter(as.numeric(P$raw)),...) else rug(as.numeric(P$raw),...) } ## rug plot done } else if (x$dim==2) { P$fit[P$exclude] <- NA if (pers) scheme <- 1 if (scheme == 1) { ## perspective plot persp(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),xlab=P$xlab,ylab=P$ylab, zlab=P$main,ylim=P$ylim,xlim=P$xlim,theta=theta,phi=phi,...) } else if (scheme==2||scheme==3) { if (scheme==3) hcolors <- grey(0:50/50) image(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),xlab=P$xlab,ylab=P$ylab, main=P$main,xlim=P$xlim,ylim=P$ylim,col=hcolors,...) contour(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),add=TRUE,col=contour.col,...) if (rug) { if (is.null(list(...)[["pch"]])) points(P$raw$x,P$raw$y,pch=".",...) else points(P$raw$x,P$raw$y,...) } } else { ## contour plot with error contours sp.contour(P$x,P$y,matrix(P$fit,n2,n2),matrix(P$se,n2,n2), xlab=P$xlab,ylab=P$ylab,zlab=P$main,titleOnly=!is.null(main), se.mult=1,trans=trans,shift=shift,...) if (rug) { if (is.null(list(...)[["pch"]])) points(P$raw$x,P$raw$y,pch=".",...) else points(P$raw$x,P$raw$y,...) } } ## counter plot done } else { warning("no automatic plotting for smooths of more than two variables") } } else { ## no CI's if (x$dim==1) { if (scale==0&&is.null(ylim)) { if (partial.resids) ylimit <- range(P$p.resid,na.rm=TRUE) else ylimit <-range(P$fit) } ylimit <- if (is.null(ylim)) ylimit <- ylimit + shift else ylim plot(P$x,trans(P$fit+shift),type="l",xlab=P$xlab, ylab=P$ylab,ylim=trans(ylimit),xlim=P$xlim,main=P$main,...) if (rug) { if (jit) rug(jitter(as.numeric(P$raw)),...) else rug(as.numeric(P$raw),...) } if (partial.resids&&(by.resids||x$by=="NA")) { if (is.null(list(...)[["pch"]])) points(P$raw,trans(P$p.resid+shift),pch=".",...) else points(P$raw,trans(P$p.resid+shift),...) } } else if (x$dim==2) { P$fit[P$exclude] <- NA if (!is.null(main)) P$title <- main if (pers) scheme <- 1 if (scheme==1) { persp(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),xlab=P$xlab,ylab=P$ylab, zlab=P$main,theta=theta,phi=phi,xlim=P$xlim,ylim=P$ylim,...) } else if (scheme==2||scheme==3) { if (scheme==3) hcolors <- grey(0:50/50) image(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),xlab=P$xlab,ylab=P$ylab, main=P$main,xlim=P$xlim,ylim=P$ylim,col=hcolors,...) contour(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),add=TRUE,col=contour.col,...) if (rug) { if (is.null(list(...)[["pch"]])) points(P$raw$x,P$raw$y,pch=".",...) else points(P$raw$x,P$raw$y,...) } } else { contour(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),xlab=P$xlab,ylab=P$ylab, main=P$main,xlim=P$xlim,ylim=P$ylim,...) if (rug) { if (is.null(list(...)[["pch"]])) points(P$raw$x,P$raw$y,pch=".",...) else points(P$raw$x,P$raw$y,...) } } } else { warning("no automatic plotting for smooths of more than one variable") } } ## end of no CI code } ## end of plot production } plot.gam <- function(x,residuals=FALSE,rug=TRUE,se=TRUE,pages=0,select=NULL,scale=-1,n=100,n2=40, pers=FALSE,theta=30,phi=30,jit=FALSE,xlab=NULL,ylab=NULL,main=NULL, ylim=NULL,xlim=NULL,too.far=0.1,all.terms=FALSE,shade=FALSE,shade.col="gray80", shift=0,trans=I,seWithMean=FALSE,unconditional=FALSE,by.resids=FALSE,scheme=0,...) # Create an appropriate plot for each smooth term of a GAM..... # x is a gam object # rug determines whether a rug plot should be added to each plot # se determines whether twice standard error bars are to be added # pages is the number of pages over which to split output - 0 implies that # graphic settings should not be changed for plotting # scale -1 for same y scale for each plot # 0 for different y scales for each plot # n - number of x axis points to use for plotting each term # n2 is the square root of the number of grid points to use for contouring # 2-d terms. { ###################################### ## Local function for producing labels ###################################### sub.edf <- function(lab,edf) { ## local function to substitute edf into brackets of label ## labels are e.g. smooth[[1]]$label pos <- regexpr(":",lab)[1] if (pos<0) { ## there is no by variable stuff pos <- nchar(lab) - 1 lab <- paste(substr(lab,start=1,stop=pos),",",round(edf,digits=2),")",sep="") } else { lab1 <- substr(lab,start=1,stop=pos-2) lab2 <- substr(lab,start=pos-1,stop=nchar(lab)) lab <- paste(lab1,",",round(edf,digits=2),lab2,sep="") } lab } ## end of sub.edf ######################### ## start of main function ######################### if (unconditional) { if (is.null(x$Vc)) warning("Smoothness uncertainty corrected covariance not available") else x$Vp <- x$Vc ## cov matrix reset to full Bayesian } w.resid<-NULL if (length(residuals)>1) # residuals supplied { if (length(residuals)==length(x$residuals)) w.resid <- residuals else warning("residuals argument to plot.gam is wrong length: ignored") partial.resids <- TRUE } else partial.resids <- residuals # use working residuals or none m <- length(x$smooth) ## number of smooth terms if (length(scheme)==1) scheme <- rep(scheme,m) if (length(scheme)!=m) { warn <- paste("scheme should be a single number, or a vector with",m,"elements") warning(warn) scheme <- rep(scheme[1],m) } ## array giving order of each parametric term... order <- if (is.list(x$pterms)) unlist(lapply(x$pterms,attr,"order")) else attr(x$pterms,"order") if (all.terms) # plot parametric terms as well n.para <- sum(order==1) # plotable parametric terms else n.para <- 0 if (se) ## sort out CI widths for 1 and 2D { if (is.numeric(se)) se2.mult <- se1.mult <- se else { se1.mult <- 2;se2.mult <- 1} if (se1.mult<0) se1.mult<-0;if (se2.mult < 0) se2.mult <- 0 } else se1.mult <- se2.mult <-1 if (se && x$Vp[1,1] < 0) ## check that variances are actually available { se <- FALSE warning("No variance estimates available") } if (partial.resids) { ## getting information needed for partial residuals... if (is.null(w.resid)) { ## produce working resids if info available if (is.null(x$residuals)||is.null(x$weights)) partial.resids <- FALSE else { wr <- sqrt(x$weights) w.resid <- x$residuals*wr/mean(wr) # weighted working residuals } } if (partial.resids) fv.terms <- predict(x,type="terms") ## get individual smooth effects } pd <- list(); ## plot data list i <- 1 # needs a value if no smooths, but parametric terms ... ################################################## ## First the loop to get the data for the plots... ################################################## if (m>0) for (i in 1:m) { ## work through smooth terms first <- x$smooth[[i]]$first.para last <- x$smooth[[i]]$last.para edf <- sum(x$edf[first:last]) ## Effective DoF for this term term.lab <- sub.edf(x$smooth[[i]]$label,edf) #P <- plot(x$smooth[[i]],P=NULL,data=x$model,n=n,n2=n2,xlab=xlab,ylab=ylab,too.far=too.far,label=term.lab, # se1.mult=se1.mult,se2.mult=se2.mult,xlim=xlim,ylim=ylim,main=main,scheme=scheme[i],...) attr(x$smooth[[i]],"coefficients") <- x$coefficients[first:last] ## relevent coefficients P <- plot(x$smooth[[i]],P=NULL,data=x$model,partial.resids=partial.resids,rug=rug,se=se,scale=scale,n=n,n2=n2, pers=pers,theta=theta,phi=phi,jit=jit,xlab=xlab,ylab=ylab,main=main,label=term.lab, ylim=ylim,xlim=xlim,too.far=too.far,shade=shade,shade.col=shade.col, se1.mult=se1.mult,se2.mult=se2.mult,shift=shift,trans=trans, by.resids=by.resids,scheme=scheme[i],...) if (is.null(P)) pd[[i]] <- list(plot.me=FALSE) else if (is.null(P$fit)) { p <- x$coefficients[first:last] ## relevent coefficients offset <- attr(P$X,"offset") ## any term specific offset ## get fitted values .... if (is.null(offset)) P$fit <- P$X%*%p else P$fit <- P$X%*%p + offset if (!is.null(P$exclude)) P$fit[P$exclude] <- NA if (se && P$se) { ## get standard errors for fit ## test whether mean variability to be added to variability (only for centred terms) if (seWithMean && attr(x$smooth[[i]],"nCons")>0) { if (length(x$cmX) < ncol(x$Vp)) x$cmX <- c(x$cmX,rep(0,ncol(x$Vp)-length(x$cmX))) X1 <- matrix(x$cmX,nrow(P$X),ncol(x$Vp),byrow=TRUE) meanL1 <- x$smooth[[i]]$meanL1 if (!is.null(meanL1)) X1 <- X1 / meanL1 X1[,first:last] <- P$X se.fit <- sqrt(pmax(0,rowSums((X1%*%x$Vp)*X1))) } else se.fit <- ## se in centred (or anyway unconstained) space only sqrt(pmax(0,rowSums((P$X%*%x$Vp[first:last,first:last,drop=FALSE])*P$X))) if (!is.null(P$exclude)) P$se.fit[P$exclude] <- NA } ## standard errors for fit completed if (partial.resids) { P$p.resid <- fv.terms[,length(order)+i] + w.resid } if (se && P$se) P$se <- se.fit*P$se.mult # Note multiplier P$X <- NULL P$plot.me <- TRUE pd[[i]] <- P;rm(P) } else { ## P$fit created directly if (partial.resids) { P$p.resid <- fv.terms[,length(order)+i] + w.resid } P$plot.me <- TRUE pd[[i]] <- P;rm(P) } } ## end of data setup loop through smooths ############################################## ## sort out number of pages and plots per page ############################################## n.plots <- n.para if (m>0) for (i in 1:m) n.plots <- n.plots + as.numeric(pd[[i]]$plot.me) if (n.plots==0) stop("No terms to plot - nothing for plot.gam() to do.") if (pages>n.plots) pages<-n.plots if (pages<0) pages<-0 if (pages!=0) # figure out how to display things { ppp<-n.plots%/%pages if (n.plots%%pages!=0) { ppp<-ppp+1 while (ppp*(pages-1)>=n.plots) pages<-pages-1 } # now figure out number of rows and columns c <- r <- trunc(sqrt(ppp)) if (c<1) r <- c <- 1 if (c*r < ppp) c <- c + 1 if (c*r < ppp) r <- r + 1 oldpar<-par(mfrow=c(r,c)) } else { ppp<-1;oldpar<-par()} if ((pages==0&&prod(par("mfcol"))1&&dev.interactive()) ask <- TRUE else ask <- FALSE if (!is.null(select)) { ask <- FALSE } if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } ##################################### ## get a common scale, if required... ##################################### if (scale==-1&&is.null(ylim)) { k <- 0 if (m>0) for (i in 1:m) if (pd[[i]]$plot.me&&pd[[i]]$scale) { ## loop through plot data if (se&&length(pd[[i]]$se)>1) { ## require CIs on plots ul<-pd[[i]]$fit+pd[[i]]$se ll<-pd[[i]]$fit-pd[[i]]$se if (k==0) { ylim <- c(min(ll,na.rm=TRUE),max(ul,na.rm=TRUE));k <- 1 } else { if (min(ll,na.rm=TRUE)ylim[2]) ylim[2] <- max(ul,na.rm=TRUE) } } else { ## no standard errors if (k==0) { ylim <- range(pd[[i]]$fit,na.rm=TRUE);k <- 1 } else { if (min(pd[[i]]$fit,na.rm=TRUE)ylim[2]) ylim[2] <- max(pd[[i]]$fit,na.rm=TRUE) } } if (partial.resids) { ul <- max(pd[[i]]$p.resid,na.rm=TRUE) if (ul > ylim[2]) ylim[2] <- ul ll <- min(pd[[i]]$p.resid,na.rm=TRUE) if (ll < ylim[1]) ylim[1] <- ll } ## partial resids done } ## loop end ylim <- trans(ylim+shift) } ## end of common scale computation ############################################################## ## now plot smooths, by calling plot methods with plot data... ############################################################## if (m>0) for (i in 1:m) if (pd[[i]]$plot.me&&(is.null(select)||i==select)) { plot(x$smooth[[i]],P=pd[[i]],partial.resids=partial.resids,rug=rug,se=se,scale=scale,n=n,n2=n2, pers=pers,theta=theta,phi=phi,jit=jit,xlab=xlab,ylab=ylab,main=main, ylim=ylim,xlim=xlim,too.far=too.far,shade=shade,shade.col=shade.col, shift=shift,trans=trans,by.resids=by.resids,scheme=scheme[i],...) } ## end of smooth plotting loop #################################################### ## Finally deal with any parametric term plotting... #################################################### if (n.para>0) # plot parameteric terms { class(x) <- c("gam","glm","lm") # needed to get termplot to call model.frame.glm if (is.null(select)) { attr(x,"para.only") <- TRUE termplot(x,se=se,rug=rug,col.se=1,col.term=1,main=attr(x$pterms,"term.labels"),...) } else { # figure out which plot is required if (select > m) { ## can't figure out how to get this to work with more than first linear predictor ## as termplots relies on matching terms to names in original data... select <- select - m # i.e. which parametric term term.labels <- attr(x$pterms,"term.labels") term.labels <- term.labels[order==1] if (select <= length(term.labels)) { # if (interactive() && m &&i%%ppp==0) termplot(x,terms=term.labels[select],se=se,rug=rug,col.se=1,col.term=1,...) } } } } if (pages>0) par(oldpar) invisible(pd) } ## end plot.gam exclude.too.far<-function(g1,g2,d1,d2,dist) # if g1 and g2 are the co-ordinates of grid modes and d1,d2 are co-ordinates of data # then this routine returns a vector with TRUE if the grid node is too far from # any data and FALSE otherwise. Too far is judged using dist: a positive number indicating # distance on the unit square into which the grid is scaled prior to calculation { mig<-min(g1) d1<-d1-mig;g1<-g1-mig mag<-max(g1) d1<-d1/mag;g1<-g1/mag mig<-min(g2) d2<-d2-mig;g2<-g2-mig mag<-max(g2) d2<-d2/mag;g2<-g2/mag # all now in unit square n<-length(g1) m<-length(d1) if (length(g2)!=n) stop("grid vectors are different lengths") if (m!=length(d2)) stop("data vectors are of different lengths") if (dist<0) stop("supplied dist negative") distance<-array(0,n) o<-.C(C_MinimumSeparation,x=as.double(cbind(g1,g2)),n=as.integer(n), d=as.integer(2), t=as.double(cbind(d1,d2)),m=as.integer(m),distance=as.double(distance)) res <- rep(FALSE,n) res[o$distance > dist] <-TRUE res } ## exclude.too.far vis.gam <- function(x,view=NULL,cond=list(),n.grid=30,too.far=0,col=NA,color="heat", contour.col=NULL,se=-1,type="link",plot.type="persp",zlim=NULL,nCol=50,...) # takes a gam object and plots 2D views of it, supply ticktype="detailed" to get proper axis anotation # (c) Simon N. Wood 23/2/03 { fac.seq<-function(fac,n.grid) # generates a sequence of factor variables of length n.grid { fn<-length(levels(fac));gn<-n.grid; if (fn>gn) mf<-factor(levels(fac))[1:gn] else { ln<-floor(gn/fn) # length of runs mf<-rep(levels(fac)[fn],gn) mf[1:(ln*fn)]<-rep(levels(fac),rep(ln,fn)) mf<-factor(mf,levels=levels(fac)) } mf } # end of local functions dnm <- names(list(...)) ## basic issues in the following are that not all objects will have a useful `data' ## component, but they all have a `model' frame. Furthermore, `predict.gam' recognises ## when a model frame has been supplied v.names <- names(x$var.summary) ## names of all variables ## Note that in what follows matrices in the parametric part of the model ## require special handling. Matrices arguments to smooths are different ## as they follow the summation convention. if (is.null(view)) # get default view if none supplied { ## need to find first terms that can be plotted against k <- 0;view <- rep("",2) for (i in 1:length(v.names)) { ok <- TRUE if (is.matrix(x$var.summary[[i]])) ok <- FALSE else if (is.factor(x$var.summary[[i]])) { if (length(levels(x$var.summary[[i]]))<=1) ok <- FALSE } else { if (length(unique(x$var.summary[[i]]))==1) ok <- FALSE } if (ok) { k <- k + 1;view[k] <- v.names[i] } if (k==2) break; } if (k<2) stop("Model does not seem to have enough terms to do anything useful") } else { if (sum(view%in%v.names)!=2) stop(gettextf("view variables must be one of %s", paste(v.names, collapse = ", "))) for (i in 1:2) if (!inherits(x$var.summary[[view[i]]],c("numeric","factor"))) stop("Don't know what to do with parametric terms that are not simple numeric or factor variables") } ok <- TRUE for (i in 1:2) if (is.factor(x$var.summary[[view[i]]])) { if (length(levels(x$var.summary[[view[i]]]))<=1) ok <- FALSE } else { if (length(unique(x$var.summary[[view[i]]]))<=1) ok <- FALSE } if (!ok) stop(gettextf("View variables must contain more than one value. view = c(%s,%s).", view[1], view[2])) # now get the values of the variables which are not the arguments of the plotted surface # Make dataframe.... if (is.factor(x$var.summary[[view[1]]])) m1<-fac.seq(x$var.summary[[view[1]]],n.grid) else { r1<-range(x$var.summary[[view[1]]]);m1<-seq(r1[1],r1[2],length=n.grid)} if (is.factor(x$var.summary[[view[2]]])) m2<-fac.seq(x$var.summary[[view[2]]],n.grid) else { r2<-range(x$var.summary[[view[2]]]);m2<-seq(r2[1],r2[2],length=n.grid)} v1<-rep(m1,n.grid);v2<-rep(m2,rep(n.grid,n.grid)) newd <- data.frame(matrix(0,n.grid*n.grid,0)) ## creating prediction data frame full of conditioning values for (i in 1:length(x$var.summary)) { ma <- cond[[v.names[i]]] if (is.null(ma)) { ma <- x$var.summary[[i]] if (is.numeric(ma)) ma <- ma[2] ## extract median } if (is.matrix(x$var.summary[[i]])) newd[[i]] <- matrix(ma,n.grid*n.grid,ncol(x$var.summary[[i]]),byrow=TRUE) else newd[[i]]<-rep(ma,n.grid*n.grid) } names(newd) <- v.names newd[[view[1]]]<-v1 newd[[view[2]]]<-v2 # call predict.gam to get predictions..... if (type=="link") zlab<-paste("linear predictor") ## ignore codetools else if (type=="response") zlab<-type else stop("type must be \"link\" or \"response\"") fv <- predict.gam(x,newdata=newd,se.fit=TRUE,type=type) z <- fv$fit # store NA free copy now if (too.far>0) # exclude predictions too far from data { ex.tf <- exclude.too.far(v1,v2,x$model[,view[1]],x$model[,view[2]],dist=too.far) fv$se.fit[ex.tf] <- fv$fit[ex.tf]<-NA } # produce a continuous scale in place of any factors if (is.factor(m1)) { m1<-as.numeric(m1);m1<-seq(min(m1)-0.5,max(m1)+0.5,length=n.grid) } if (is.factor(m2)) { m2<-as.numeric(m2);m2<-seq(min(m1)-0.5,max(m2)+0.5,length=n.grid) } if (se<=0) { old.warn<-options(warn=-1) av<-matrix(c(0.5,0.5,rep(0,n.grid-1)),n.grid,n.grid-1) options(old.warn) # z is without any exclusion of gridpoints, so that averaging works nicely max.z <- max(z,na.rm=TRUE) z[is.na(z)] <- max.z*10000 # make sure NA's don't mess it up z<-matrix(z,n.grid,n.grid) # convert to matrix surf.col<-t(av)%*%z%*%av # average over tiles surf.col[surf.col>max.z*2] <- NA # restore NA's # use only non-NA data to set colour limits if (!is.null(zlim)) { if (length(zlim)!=2||zlim[1]>=zlim[2]) stop("Something wrong with zlim") min.z<-zlim[1] max.z<-zlim[2] } else { min.z<-min(fv$fit,na.rm=TRUE) max.z<-max(fv$fit,na.rm=TRUE) } surf.col<-surf.col-min.z surf.col<-surf.col/(max.z-min.z) surf.col<-round(surf.col*nCol) con.col <-1 if (color=="heat") { pal<-heat.colors(nCol);con.col<-3;} else if (color=="topo") { pal<-topo.colors(nCol);con.col<-2;} else if (color=="cm") { pal<-cm.colors(nCol);con.col<-1;} else if (color=="terrain") { pal<-terrain.colors(nCol);con.col<-2;} else if (color=="gray"||color=="bw") {pal <- gray(seq(0.1,0.9,length=nCol));con.col<-1} else stop("color scheme not recognised") if (is.null(contour.col)) contour.col<-con.col # default colour scheme surf.col[surf.col<1]<-1;surf.col[surf.col>nCol]<-nCol # otherwise NA tiles can get e.g. -ve index if (is.na(col)) col<-pal[as.array(surf.col)] z<-matrix(fv$fit,n.grid,n.grid) if (plot.type=="contour") { stub <- paste(ifelse("xlab" %in% dnm, "" , ",xlab=view[1]"), ifelse("ylab" %in% dnm, "" , ",ylab=view[2]"), ifelse("main" %in% dnm, "" , ",main=zlab"),",...)",sep="") if (color!="bw") { txt <- paste("image(m1,m2,z,col=pal,zlim=c(min.z,max.z)",stub,sep="") # assemble image() call eval(parse(text=txt)) txt <- paste("contour(m1,m2,z,col=contour.col,zlim=c(min.z,max.z)", ifelse("add" %in% dnm, "" , ",add=TRUE"),",...)" , sep="") # assemble contour() call eval(parse(text=txt)) } else { txt <- paste("contour(m1,m2,z,col=1,zlim=c(min.z,max.z)",stub,sep="") # assemble contour() call eval(parse(text=txt)) } } else { stub <- paste(ifelse("xlab" %in% dnm, "" , ",xlab=view[1]"), ifelse("ylab" %in% dnm, "" , ",ylab=view[2]"), ifelse("zlab" %in% dnm, "" , ",zlab=zlab"),",...)",sep="") if (color=="bw") { op <- par(bg="white") txt <- paste("persp(m1,m2,z,col=\"white\",zlim=c(min.z,max.z) ",stub,sep="") # assemble persp() call eval(parse(text=txt)) par(op) } else { txt <- paste("persp(m1,m2,z,col=col,zlim=c(min.z,max.z)",stub,sep="") # assemble persp() call eval(parse(text=txt)) } } } else # add standard error surfaces { if (color=="bw"||color=="gray") { subs <- paste("grey are +/-",se,"s.e.") ## ignore codetools lo.col <- "gray" ## ignore codetools claims about this hi.col <- "gray" ## ignore codetools } else { subs <- paste("red/green are +/-",se,"s.e.") lo.col <- "green" hi.col <- "red" } if (!is.null(zlim)) { if (length(zlim)!=2||zlim[1]>=zlim[2]) stop("Something wrong with zlim") min.z<-zlim[1] max.z<-zlim[2] } else { max.z<-max(fv$fit+fv$se.fit*se,na.rm=TRUE) min.z<-min(fv$fit-fv$se.fit*se,na.rm=TRUE) zlim<-c(min.z,max.z) } z<-fv$fit-fv$se.fit*se;z<-matrix(z,n.grid,n.grid) if (plot.type=="contour") warning("sorry no option for contouring with errors: try plot.gam") stub <- paste(ifelse("xlab" %in% dnm, "" , ",xlab=view[1]"), ifelse("ylab" %in% dnm, "" , ",ylab=view[2]"), ifelse("zlab" %in% dnm, "" , ",zlab=zlab"), ifelse("sub" %in% dnm, "" , ",sub=subs"), ",...)",sep="") txt <- paste("persp(m1,m2,z,col=col,zlim=zlim", ifelse("border" %in% dnm, "" ,",border=lo.col"), stub,sep="") # assemble persp() call eval(parse(text=txt)) par(new=TRUE) # don't clean device z<-fv$fit;z<-matrix(z,n.grid,n.grid) txt <- paste("persp(m1,m2,z,col=col,zlim=zlim", ifelse("border" %in% dnm, "" ,",border=\"black\""), stub,sep="") eval(parse(text=txt)) par(new=TRUE) # don't clean device z<-fv$fit+se*fv$se.fit;z<-matrix(z,n.grid,n.grid) txt <- paste("persp(m1,m2,z,col=col,zlim=zlim", ifelse("border" %in% dnm, "" ,",border=hi.col"), stub,sep="") eval(parse(text=txt)) } } ## vis.gam mgcv/MD50000644000177400001440000002365013046677730011733 0ustar murdochusersfdc45fe0bc09d3a9dea994040574ba9d *ChangeLog 1671dbe5a90499d24659b13d04370628 *DESCRIPTION eb723b61539feef013de476e68b5c50a *GPL-2 fe1f2bde9713ba97eeb59d928310f628 *NAMESPACE 1aee82e17a9feb6166dbe107659029c9 *R/bam.r 87933a9e2845f871334d96f537ee11e9 *R/coxph.r 97c5e0261e26e0aedd8127f9ed41f817 *R/efam.r deaf0c6a0e39d42a9bad487772eb5904 *R/fast-REML.r dbf376ceeec4b343d15daa90fe5a81fb *R/gam.fit3.r 9f73b1e3e9781d8ee26a46c1a2127c73 *R/gam.fit4.r 1b620b840ca67c9759639bd6e53824e3 *R/gam.sim.r a6b6a5e70c7889370d33876e08396a09 *R/gamlss.r cceac26b3d01513f8f87eacae91ddae0 *R/gamm.r 10facb791e4cfd123d183f05660119c6 *R/jagam.r 088976e7d2ee3df696d09b3fcdfdd563 *R/mgcv.r 2feca0dc9d354de7bc707c67a5891364 *R/misc.r 03772998ab05887f2eeae10dd6efe983 *R/mvam.r 5d07d6e4f75a64b6d04cda9e23278d70 *R/plots.r 9a4db620ad080f012b56134c1aba10bb *R/smooth.r 666d7fd36fda68b928993d5388b0d7fc *R/soap.r 76cc875719bf0ef9eab45ea5bfeccda6 *R/sparse.r e468195a83fab90da8e760c2c3884bd3 *data/columb.polys.rda 40874e3ced720a596750f499ded8a60a *data/columb.rda e74e6d792e3dc69f7a20c68c16097145 *inst/CITATION 342b1840b6a569b8d8d4a3355a0d2bfa *inst/po/de/LC_MESSAGES/R-mgcv.mo fe9d11e3087789da149e3688309df670 *inst/po/de/LC_MESSAGES/mgcv.mo 72ccd181324c1acd4671f69311ed494a *inst/po/en@quot/LC_MESSAGES/R-mgcv.mo dcb794aad0b69ab80cb6877510c3a925 *inst/po/en@quot/LC_MESSAGES/mgcv.mo 72ffab2a2903e1efa30cc81424bce43d *inst/po/fr/LC_MESSAGES/R-mgcv.mo 418bef2f2c1ed07bff6bbdb6884d2858 *inst/po/fr/LC_MESSAGES/mgcv.mo fbe9f7d7c30fbcebf97c28bf17c2ef50 *inst/po/ko/LC_MESSAGES/R-mgcv.mo e6196a86ad3a8e42df84242a861d362a *inst/po/ko/LC_MESSAGES/mgcv.mo 5c8c8783edc20ee9196bb17bb86c420d *inst/po/pl/LC_MESSAGES/R-mgcv.mo 07e822258166c032ff9f1a4e96025841 *inst/po/pl/LC_MESSAGES/mgcv.mo c574fe1ca9d55a9818d308906f16d16e *man/Beta.Rd 5bf12ddc0dab9daae72271b96a15c539 *man/Predict.matrix.Rd c45c0f78f753461b33a295883461e732 *man/Predict.matrix.cr.smooth.Rd d0fa291cbbcef359c61e426f6ba38fbb *man/Predict.matrix.soap.film.Rd f12468625253dd3603907de233762fd6 *man/Rrank.Rd d3e09165c6ca581db78d820a3c39329c *man/Tweedie.Rd c93cf5b2e0def2e36cced3ee68912958 *man/anova.gam.Rd 871531b320262b21eab35467f334cc6a *man/bam.Rd 8c95ed4822108db4e8bc59d8eac9e77c *man/bam.update.Rd cf5f1ee0aab639c7c4b9b357434f15b2 *man/bandchol.Rd 745cbf31eb14fc1c5916fc634c74d998 *man/bug.reports.mgcv.Rd 530b8b4bacffa9353561f19ecfccfe19 *man/cSplineDes.Rd a72647229fd92763636941e61597995d *man/choose.k.Rd c03748964ef606621418e428ae49b103 *man/columb.Rd 9906a83ce29a3b17044bc2a3c9940cee *man/concurvity.Rd c355ae144e02759a86da79dcfca1a6c1 *man/coxph.Rd 5f4e410d9dbc40e99b723a5caa1d9e01 *man/coxpht.Rd 0a6d4b3858cbb69a5d375ecd09282256 *man/exclude.too.far.Rd 069e7d174bb0d35bf30675e74a47dfd3 *man/extract.lme.cov.Rd 0423770bd423bf3de94a53e7c707678c *man/family.mgcv.Rd 44ad0563add1c560027d502ce41483f5 *man/fix.family.link.Rd 4d4eea9ad2b78e765a96b2a0065725c1 *man/fixDependence.Rd e75719779e18c723ee1fd17e44e7901b *man/formXtViX.Rd 88888e966394c9f9792d9537341d053c *man/formula.gam.Rd 4da4d585b329769eb44f0c7a6e7dd554 *man/fs.test.Rd 6f405acde2d7b6f464cf45f5395113ba *man/full.score.Rd 0c075e9e58df199d59e77d94b712fde6 *man/gam.Rd adaf0bd8e82d9472823cf3f3fa05e111 *man/gam.check.Rd 8931cd75ddec14d91ec94dec6ba69362 *man/gam.control.Rd 44db24b66ce63bc16d2c8bc3f5b42ac5 *man/gam.convergence.Rd 1cf5145859af2263f4e3459f40e1ab23 *man/gam.fit.Rd 4728be401da6eceb8b0c257377dc5d01 *man/gam.fit3.Rd 8ba3991b5932b0775b452d20c9ff4d54 *man/gam.models.Rd c15f647511f54d05d9fc21760cf61d91 *man/gam.outer.Rd c17814cea1b11e5ca374e72d6e1cbd98 *man/gam.scale.Rd d828d474a4b069f9b9e3ebe5f05b70ec *man/gam.selection.Rd 310397e938dae8c6b818d2093e4aa354 *man/gam.side.Rd b2ff252537dd2155524b774b2435e66e *man/gam.vcomp.Rd eb8648cc6b3c9374b899abd2f2b12f7b *man/gam2objective.Rd 717401fd7efa3b39d90418a5d1d0c216 *man/gamObject.Rd a2593990d6a87f7b783d0435062dec02 *man/gamSim.Rd e5d2541f32dab56972f58b0773eba50c *man/gamlss.etamu.Rd c7f140d128d1d1d76909499900faf49e *man/gamlss.gH.Rd 351009f7345aaff40f3377e77f4ce7ad *man/gamm.Rd ec2d1b2aa87cc3f8424e07b6dc0340d5 *man/gaulss.Rd 398a5c12285401c1d37a8edb58780bc3 *man/get.var.Rd faf325db054dce698286f87e09ddc202 *man/gevlss.Rd 39b47f30a7ea45382d62ca1753d876a8 *man/identifiability.Rd 4f96476abbf9692f52030d3859580a31 *man/in.out.Rd 6c33026ebb458483d34a04548c05d664 *man/inSide.Rd 2f222eeeb3d7bc42f93869bf8c2af58a *man/influence.gam.Rd 39b9de9dbac7d9dc5c849e1a37def675 *man/initial.sp.Rd 2a37ae59a9f9f5a0a58af45947eca524 *man/interpret.gam.Rd 29f94d99b9a3decd4d71618eb839a7f7 *man/jagam.Rd 87d942b17bee05bb662270b894b183e6 *man/ldTweedie.Rd 58e73ac26b93dc9d28bb27c8699e12cf *man/linear.functional.terms.Rd 93035193b0faa32700e1421ce8c1e9f6 *man/logLik.gam.Rd b1c95a20afd6eb0825c00b46b8c3cbfa *man/ls.size.Rd 9a2c8f14c7a56eca69f4a59bef27a9bf *man/magic.Rd 5169af4be5fccf9fa79b6de08e9ea035 *man/magic.post.proc.Rd 7f1032c61d424980f4473ac9717dc797 *man/mgcv-FAQ.Rd ba14a20f6fa77f066bac7cdfe88b8fff *man/mgcv-package.Rd 6db1ae82808e56bd44c04066e2ec09aa *man/mgcv-parallel.Rd df702cea24d0f92044a973b66a57e21f *man/missing.data.Rd 00ccf213c31910cd14f1df65a300eb33 *man/model.matrix.gam.Rd 2f2fdc722c5e9e58664da9378451cd4a *man/mono.con.Rd d33914a328f645af13f5a42914ca0f35 *man/mroot.Rd f624f3afcf4e2192e8f724d45257d983 *man/multinom.Rd 8fa6cf27db7192bbad6a2d41d2780937 *man/mvn.Rd 1064099913e539a75bf763c764bc72a1 *man/negbin.Rd 8a6a1926188511235f1e7406120c791e *man/new.name.Rd 00e39f302ab5efbe3b14265fffc16c18 *man/notExp.Rd 7a3280b766cab8424a12d6a8b1d5748e *man/notExp2.Rd e8ecb5f0b5214ef0bae54a645a4d12d6 *man/null.space.dimension.Rd 06910824bd8944cedb790e5787bddff8 *man/ocat.Rd 145a5adf3f90b6f2a9a109a97d9fd8fe *man/one.se.rule.Rd 9f49b00733e6117337f619cebfdfcf00 *man/pcls.Rd ee9352ba4c531a8def16deddcab9a9fd *man/pdIdnot.Rd 8bc429d92aa9f58c4c43f2852e1f8123 *man/pdTens.Rd 1721f1b266d9e14827e8226e2cb74a81 *man/pen.edf.Rd 931c3aefb8b5e42aa230cfedd281bed1 *man/place.knots.Rd b903ebcf31703db156e033fdfa527d73 *man/plot.gam.Rd c27a6b886929b1dc83bf4b90cae848f9 *man/polys.plot.Rd 1a9d83c9fc67e5f0fc85d66d3112f4ef *man/predict.bam.Rd 93f41380f769dff6a21394d80508c565 *man/predict.gam.Rd cf14ce6cf8e4147f0f5c6e5b93b2af73 *man/print.gam.Rd 6d0ce4e574fabceffdbedd46c91364cb *man/qq.gam.Rd 22b7dcbc8ff4096365fa98ce56b957c9 *man/rTweedie.Rd fc1985e7dd5222182c4a8a939963b965 *man/random.effects.Rd c523210ae95cb9aaa0aaa1c37da1a4c5 *man/residuals.gam.Rd 3c747a8066bcc28ae706ccf74f903d3e *man/rig.Rd 9f6f46f5c5da080bc82f9aa4685d364a *man/rmvn.Rd c4be33830dfeb9e0dc766f8e5498931d *man/s.Rd d515e51ec98d73af6166f7b31aeaba9b *man/scat.Rd 898e7cc2def2ee234475e68d0b904b29 *man/sdiag.Rd 8e968226c2b65ee89c8de2fd9869b086 *man/single.index.Rd 6f03e337d54221bc167d531e25af1eea *man/slanczos.Rd 8020154bd5c709d11f0e7cf043df886d *man/smooth.construct.Rd 4a689eba97e4fed138dccb8cad13205e *man/smooth.construct.ad.smooth.spec.Rd 24927a9c5ce97da988ac8ff3299c533a *man/smooth.construct.bs.smooth.spec.Rd 76013feaf70d00976bba0154b6f2c946 *man/smooth.construct.cr.smooth.spec.Rd f5e6d0f5122f61c336827b3615482157 *man/smooth.construct.ds.smooth.spec.Rd db75c958cbfb561914a3291ab58b9786 *man/smooth.construct.fs.smooth.spec.Rd 7eba0bd0ecf412e7db5dab49eba724cd *man/smooth.construct.gp.smooth.spec.Rd 4aaa84b520992fbc32b0c37f7f63c1dd *man/smooth.construct.mrf.smooth.spec.Rd 2523b6cefa306210c00f3477853b7f07 *man/smooth.construct.ps.smooth.spec.Rd b45d8e71bda4ceca8203dffea577e441 *man/smooth.construct.re.smooth.spec.Rd 0607caa694345cef339bc2178674923c *man/smooth.construct.so.smooth.spec.Rd 0bfe981f2c3e6ea5b8d5372076ccde53 *man/smooth.construct.sos.smooth.spec.Rd 3cb4e59f915c8d64b90754eaeeb5a86f *man/smooth.construct.t2.smooth.spec.Rd 8672633a1fad8df3cb1f53d7fa883620 *man/smooth.construct.tensor.smooth.spec.Rd a088e69cf148d07a78ce95a69759c95c *man/smooth.construct.tp.smooth.spec.Rd d4083ff900aa69fa07610e0af2a2987b *man/smooth.terms.Rd ca676e32c30ddaedbce9f706327cc55b *man/smooth2random.Rd 844f9653d74441293d05a24dd3e2876a *man/smoothCon.Rd b55a396da77559dac553613146633f97 *man/sp.vcov.Rd 83bd8e097711bf5bd0fff09822743d43 *man/spasm.construct.Rd b9394812e5398ec95787c65c1325a027 *man/step.gam.Rd f0791d830687d6155efb8a73db787401 *man/summary.gam.Rd a0b0988dba55cca5b4b970e035e3c749 *man/t2.Rd a27690f33b9a7bd56d9c1779c64896cc *man/te.Rd 6eebb6ef90374ee09453d6da6449ed79 *man/tensor.prod.model.matrix.Rd f22f1cee0ff2b70628846d1d0f8e9a66 *man/trichol.Rd 87e6b4437d00fab4fc814f4cefa3795c *man/trind.generator.Rd 96c48dd705710f639d76a0d0cc3fb128 *man/uniquecombs.Rd a16b3a5a4d13c705dcab8d1cd1b3347e *man/vcov.gam.Rd 281e73658c726997196727a99a4a1f9e *man/vis.gam.Rd 07a73758156dfa580c6e92edd34b0654 *man/ziP.Rd 8bc98d4cb86d851ea0970d68799522cb *man/ziplss.Rd f32c7932ef429aa3113007140da82221 *po/R-de.po 0bdfcf98961b0d52b60f806dc1dba77e *po/R-en@quot.po 18713570046eecabea9478b9b864a2cf *po/R-fr.po d24a793282e6f43c9b67235e46102199 *po/R-ko.po 753bc70ea9b8cb7c06f658a1eb81ce36 *po/R-mgcv.pot 1bb61f6df62fc1787864f66933757701 *po/R-pl.po 8c33d89a914170dbc9f7c5fe598d2135 *po/de.po 93f72334356fe6f05a64e567efd35c8e *po/en@quot.po b3dfaf74ca2d76ca26eec986a14f5584 *po/fr.po 9116fc041ab458e49b3e498f8c0ac0d9 *po/ko.po cd15f571b582fdd31e597083a5fe66ff *po/mgcv.pot ed7cb61912e4990cb0076d4cdcf11da8 *po/pl.po 03972284b3400cf82cacd5d2dc4b8cb3 *src/Makevars 342aa30c8f6f1e99ffa2576a6f29d7ce *src/coxph.c 0d723ffa162b4cb0c2c0fa958ccb4edd *src/discrete.c dba99f7d7cc412dd9255f6307c8c7fa7 *src/gdi.c 2436f9b328e80370ce2203dbf1dd813c *src/general.h acf1a2cff05d68856f2b6acee1e63cf7 *src/init.c a9151b5236852eef9e6947590bfcf88a *src/magic.c 16b3a72d8bf608026f45de356cf37e65 *src/mat.c 0545dabf3524a110d616ea5e6373295d *src/matrix.c 6b781cbd5b9cfee68ad30bb7ce31ef3a *src/matrix.h 48cde0e19d5dd54b131ba66c777c0ec2 *src/mgcv.c 473bc0f430ec18b53d4649c7276c2962 *src/mgcv.h 97e3717e95a70b1470b4c3071e144d17 *src/misc.c 465b8790ca2dfb6e8c5635cacabf5460 *src/mvn.c 8f480dc455f9ff011c3e8f059efec2c5 *src/qp.c cd563899be5b09897d1bf36a7889caa0 *src/qp.h d5673b88f6f3d85c62a1337f49abba24 *src/soap.c ce727da695456c5c7118b51751a7054d *src/sparse-smooth.c fe0444bece322bc229e46b3d1c150779 *src/tprs.c 5bd85bf0319a7b7c755cf49c91a7cd94 *src/tprs.h mgcv/DESCRIPTION0000744000177400001440000000147013046677730013126 0ustar murdochusersPackage: mgcv Version: 1.8-17 Author: Simon Wood Maintainer: Simon Wood Title: Mixed GAM Computation Vehicle with GCV/AIC/REML Smoothness Estimation Description: GAMs, GAMMs and other generalized ridge regression with multiple smoothing parameter estimation by GCV, REML or UBRE/AIC. Includes a gam() function, a wide variety of smoothers, JAGS support and distributions beyond the exponential family. Priority: recommended Depends: R (>= 2.14.0), nlme (>= 3.1-64) Imports: methods, stats, graphics, Matrix Suggests: splines, parallel, survival, MASS LazyLoad: yes ByteCompile: yes License: GPL (>= 2) NeedsCompilation: yes Packaged: 2017-02-06 11:03:57 UTC; sw283 Repository: CRAN Date/Publication: 2017-02-08 21:30:16 mgcv/ChangeLog0000755000177400001440000035663613046052674013207 0ustar murdochusers** denotes quite substantial/important changes *** denotes really big changes Currently deprecated and liable to be removed: - single penalty tensor product smooths. - p.type!=0 in summary.gam. 1.8-17 * Export gamlss.etamu, gamlss.gH and trind.generator to facilitate user addition of new location-scale families. * Re-ordering of initialization in gam.fit4 to avoid possible failure of dev.resids call before initialization. * trap in fast.REML.fit for situation in which all smoothing parameters satisfy conditions for indefinite convergence on entry, with an immediate warning that this probably indicates iteration divergence (of bam). * "bs" basis modified to allow easier control of the interval over which the spline penalty applies which in turn allows more sensible control of extrapolation behaviour, when this is unavoidable. * Fix in uniquecombs - revised faster code (from 1.8-13) could occasionally generate false matches between different input combinations for integer variables or factors. Thanks to Rohan Sadler for reporting the issue that uncovered this. * A very bad initial model for uninformative data could lead to a negative fletcher estimate of the scale parameter and optimizer failure - fixed. * "fREML" allowed in sp.vcov so that it works with bam fitted models. * 2 occurances of 'return' replaced by (correct) return(). 1.8-16 * slightly improved intial value heuristics for overlapping penalties in general family case. * 'ocat' checks that response is numeric. * plot.gam(...,scale=-1) now changes scale according to 'trans' and 'shift'. * newton optimizer made slightly more cautious: contracts step if reduction in true objective too far different from reduction predicted by quadratic approximation underlying Newton step. Also leaves parameters unchanged in Newton step while their grad is less than 1% of max grad. * Fix to Fisher weight computation in gam.fit4. Previously a weight could (rarely) evaluate as negative machine prec instead of zero, get passed to gdi2 in C code, generate a NaN when square rooted, resulting in a NaN passed to the LAPACK dgeqp3 routine, which then hung in a non-interuptable way. * Fix of 'sp' argument handling with multiple formulae. Allocation to terms could be incorrect. * Option 'edge.correct' added to 'gam.control' to allow better correction of edge of smoothing parameter space effects with 'gam' when RE/ML used. * Fix to setting of penalty rank in smooth.construct.mrf.smooth.spec. Previously this was wrong, which could cause failure with gamm if the penalty was rank deficient. Thanks Paul Buerkner. * Fix to Vb.corr call from gam.fit3.post.proc to ensure that sp not dropped (wrongly treated as scale estimate) when P-REML or P-ML used. Could cause failure depending on BLAS. Thanks Matteo Fasiolo. * Fix in gam.outer that caused failure with "efs" optimizer and fixed sps. * Fix to `get.var' to drop matrix attributes of 1 column matrix variables. * Extra argument added to `uniquecombs' to allow result to have same row ordering regardless of input data ordering. Now used by smooth constructors that subsample unique covariate values during basis setup to ensure invariance to data re-ordering. * Correction of scaling error in spherical correlation structure GP smooth. * qf and rd functions for binomial family fixed for zero n case. 1.8-15 * Fix of survival function prediction in cox.ph family. Code used expression (8.8.5) in Klein and Moeschberger (2003), which is missing a term. Correct expression is, e.g., (10) from Andersen, Weis Bentzon and Klein (1996) Scandinavian Journal of Statistics. * Added help file 'cox.pht' for Cox PH regression with time dependent covariates. * fix of potential seg fault in gdi.c:get_bSb if single smooth model rank deficient (insufficient workspace allocated). * gam.fit5 modified to step half if trial penalized likelihood is infinite. * Fix so that bam works properly with drop.intercept=TRUE. 1.8-14 * bug fix to smoothCon that could generate NAs in model matrix when using bam with numeric by variables. The problem was introduced as part of the bam(...,discrete=TRUE) coding. 1.8-13 * Added help file ?one.se.rule on the `one standard error rule' for obtaining smoother models. * bam(...,discrete=TRUE) no longer complains about more coefficients than data. * 's', 'te', 'ti' and 't2' modified to allow user to specify that the smooth should pass through zero at a specified point. See ?identifiability. * anova.gam modified to use more appropriate reference degrees of freedom for multiple model call, where possible. Also fixed to allow multiple formulae models and to use -2*logLik in place of `deviance' for general.family models. * offsets allowed with multinomial, ziplss and gaulss families. * gevlss family implementing generalized extreme value location, scale and shape models. * Faster code used in 'uniquecombs'. Speeds up discretization step in 'bam(...,discrete=TRUE)'. Could still be improved for multi-column case. * modification to 'smoothCon' to allow resetting of smooth supplied constraints - enables fix of bug in bam handling of 't2' terms, where parameterization of penalty and model matrix did not previously match properly. * clarification of `exclude' argument to predict.gam in help files. * modification to 'plot.gam' etc, so that 'ylim' is no longer shifted by 'shift'. * ylim and ... handling improved for 'fs' plot method (thanks Dave Miller) * gam.check now recognises RStudio and plots appropriately. * bam(...,sparse=TRUE) removed - not efficient, because of unavoidability of dense off diagonal terms in X'X or equivalent. Deprecated since 1.8-5. * tweak to initial.sp/g to avoid infinite loop in s.p. initialization, in rather unusual circumstances. Thanks to Mark Bravington. * bam and gam have `drop.intercept' argument to force the parametric terms not to include a constant in their span, even when there are factor variables. * Fix in Vb.corr (2nd order edf correction) for fixed smoothing parameter case. * added 'all.vars1' to enable terms like s(x$y) in model formulae. * modification to gam.fit4 to ignore 'start' if it is immediately worse than 'null.coef'. * cSplineDes can now accept a 'derivs' argument. * added drop.intercept handling for multiple formulae (mod by Matteo Fasiolo). * 'gam.side' fix to avoid duplication of smooth model matrices to be tested against, when checking for numerical degeneracy. Problem could occasionally cause a failure (especially with bam), when the total matrix to be tested against ended upo with more columns than rows. * 4 occurances of as.name("model.frame") changed to quote(stats::model.frame) * fix in predict.bamd discrete prediction code to be a bit more relaxed about use of as.factor, etc in formulae. * fix in predict.gam handling of 'na.action' to avoid trying to get type of na.action from name of na.action function - this was fragile to nesting and could cause predict.bam to fail in the presence of NA's. * fix of gam.outer so that general families (e.g. cox.ph) can have all their smoothing parameters supplied without then ignoring the penalties! * fix in multiple formulae handling of fixed smoothing parameters. * Fix of bug in zlim handling in vis.gam perspective plot with standard errors. Thanks Petra Kuhnert. * probit link added to 'jagam' (suggested by Kenneth Knoblauch). * 'Sl.' routines revised to allow operation with non-linearly parameterized smoothers. * bug fix in Hessian computation in gam.fit5 - leading diagonal of Hessian of log|Hp| could be wrong where Hp is penalized Hessian. * better use of crossprod in gamlss.gH 1.8-12 ** "bs" B-spline smoothing basis. B-splines with derivative based penalties of various orders. * 'gamm' now uses a fixed scale parameter in PQL estimation for Poisson and binomial data via the `sigma' option in lmeControl. * bam null deviance computation was wrong with prior weights (including binomial other than binary case), and returned deviance was wrong for non-binary binomial. Fixed (did not affect estimation). * improvements to "bfgs" optimizer to better deal with `infinite' smoothing parameters. * changed scheme=3 in default 2-D plotting to grey scale version of scheme=2. * 'trichol' and 'bandchol' added for banded Cholesky decompositions, plus 'sdiag' functions added for extracting and setting matrix sub- and super- diagonals. * p-spline constructor and Predict.matrix.pspline.smooth now allow set up of SCOP-spline monotonic smoothers, and derivatives of smooths. Not used in modelling functions yet. * s(...,bs="re") now allows known precision matrix structures to be defined using the `xt' argument of 's' see ?smooth.construct.re.smooth.spec for details and example. * negbin() with a grid search for `theta' is no longer supported - use 'nb' instead. * bug fix to bam aic computation with AR rho correction. 1.8-11 * bam(...,discrete=TRUE) can now handle matrix arguments to smooths (and hence linear functional terms). * bam(...,discrete=TRUE) bug fix in fixed sp handling. * bam(...,discrete = TRUE) db.drho reparameterization fix, fixing nonsensical edf2. Also bam edf2 limited to maximum of edf1. * smoothCon rescaling of S changed to use efficient matrix norm in place of relatively slow computation involving model matrix crossproduct. * bam aic corrected for AR model if present. * Added select=TRUE argument to 'bam'. * Several discrete prediction fixes including improved thread safety. * bam/gam name gcv.ubre field by "method". * gam.side modified so that if a smooth has 'side.constrain==FALSE' it is neither constrained, nor used in the computation of constraints for other terms (the latter part being new). Very limited impact! * No longer checks if SUPPORT_OPENMP defined in Rconfig.h, but only if _OPENMP defined. No change in actual behaviour. 1.8-10 ** 'multinom' family implemented for multinomial logistic regression. * predict.bam now defaults to using efficient discrete prediction methods for models fit using discrete covariate methods (bam(...,discrete=TRUE)). * with bam(...,discrete=TRUE) terms like s(a,b,bs="re") had wrong p-value computation applied, as a result of being treated as tensor product terms. Fixed. * minor tweak to soap basis setup to avoid rounding error leading to 'approx' occasionally producing NA's with fixed boundaries. * misc.c:rwMatrix made thread safe (had been using R_chk_calloc, which isn't). * some upgrading for 64bit addressing. * uniquecombs now preserves contrasts on factors. * variable summary tweak so that 1 column matrices in parametric model are treated as regular numeric variables. 1.8-9 * C level fix in bam(...,discrete=TRUE) code. Some memory was mistakenly allocated via 'calloc' rather than 'R_chk_calloc', but was then freed via 'R_chk_free'. This could cause R to halt on some platforms. 1.8-8 ** New "gp" smooth class (see ?gp.smooth) implemeting the Matern covariance based Gaussian process model of Kamman and Wand (2003), and a variety of other simple GP smoothers. * some smooth plot methods now accept 'colors' and 'contour.col' argument to set color palette in image plots and contour line colors. * predict.gam and predict.bam now accept an 'exclude' argument allowing terms (e.g. random effects) to be zeroed for prediction. For efficiency, smooth terms not in 'terms' or in 'exclude' are no longer evaluated, and are instead set to zero or not returned. See ?predict.gam. * ocat saturated likelihood definition changed to zero, leading to better comprability of deviance between model fits (thanks to Herwig Friedl). * null.deviance calculation for extended families modified to make more sense when `mu' is the mean of a latent variable, rather than the response itself. * bam now returns standarized residuals 'std.rsd' if `rho!=0'. * bam(...,discrete=TRUE) can now handle 'fs' terms. * bam(...,discrete=TRUE) now accepts 'by' variables. Thanks to Zheyaun Li for debugging on this. * bam now works with drop.unused.levels == TRUE when random effects should have more levels than those that exist in data. (Thanks Alec Leh) * bam chunk.size logic error fix - error could be triggered if chunk.size reset automaticlly to be larger than data size. * uniqucombs can now accept a data frame with some or all factor columns, as well as purely numeric marices. * discrete.mf modified to avoid discretizing a covariate more than once, and to halt if a model requires the same covariate to be discretized two different ways (e.g. s(x) + s(x,z)). This affects only bam(...,discrete=TRUE). * Some changes to ziP and ziplss families to improve numerical robustness, and to ziP help file to suggest appropriate checking. Thanks to Keren Raiter, for reporting problems. * numerical robustness of extended gam methods (gam.fit4) improved for cases with many zero or near zero iterative weights. Handling of zero weights modified to avoid divide by (near) zero problems. Also tests for poor scaling of sqrt(abs(w))*z and substitutes computations based on w*z if detected. Also 'newton' routine now step halves if REML score not finite! * Sl.setup (used by bam) modification to allow more efficient handling of terms with multiple diagonal penalties with no non-zero elements in common, but possibly with non zero elements `interleaved' between penalties. 1.8-7 ** 'gam' default scale parameter changed to modified Pearson estimator developed by Fletcher 2012 Biometrika 99(1), 230-237. See ?gam.scale. ** 'bam' now has a 'discrete' argument to allow discretization of covariates for more efficient computation, with substantially more parallelization (via 'nthreads'). Still somewhat experimental. * Slightly more accurate smoothing parameter uncertainty correction. Changes edf2 used for AIC (under RE/ML), and hence may change AIC values. * jagam prior variance on fixed effects is now set with reference to data and model during initialization step. * bam could lose offset for small datasets in gaussian additive case. fixed. * gam.side now setup to include penalties in computations if fewer data than coefs (an exceedingly specialist topic). * p-value computation for smooth terms modified to avoid an ambiguity in the choice of test statistic that could lead to p-value changing somewhat between platforms. * gamm now warns if attempt is made to use extended family. * step fail logic improved for "fREML" optimization in 'bam'. * fix of openMP error in mgcv_pbsi, which could cause a problem in multi-threaded bam computation (failure to declare a variable as private). * Smoothing parameter uncertainty corrected AIC calculations had an indexing problem in Sl.postproc, which could result in failure of bam with linked smooths. * mroot patched for fact that chol(...,pivot=TRUE) does not operate as documented on rank deficient matrices: trailing block of triangular factor has to be zeroed for pivoted crossprod of factor to equal original matrix. * bam(...,sparse=TRUE) deprecated as no examples found where it is really worthwhile (but let me know if this is a problem). * marginal model matrices in tensor product smooths now stored in re-parameterized form, if re-parameterization happened (shouldn't change anything!). * initial.spg could fail if response vector had dim attributes and extended family used. fixed. 1.8-6 * Generalization of list formula handling to allow linear predictors to share terms. e.g. gam(list(y1~s(x),y2~s(z),1+2~s(v)+w-1),family=mvn(d=2)) * New German translation thanks to Detlef Steuer. * plot.gam now silently returns a list of plotting data, to help advanced users (Fabian Scheipl) to produce customized plot. * bam can now set up an object suitable for fitting, but not actually do the fit, following a suggestion by Fabian Scheipl. See arguments 'fit' and 'G'. 1.8-5 * Korean translation added thanks to Chel Hee Lee. * scale parameter handling in edf in logLik.gam made consistent with glm (affects AIC). * 'bam', 'gam' and 'gamm' modified to often produce smaller files when models saved (and never to produce absurdly large files). Achieved by setting environment of formula, terms etc to .GlobalEnv. Previously 'save' could save entire contents of environment of formula/terms with fitted model object. Note that change can cause failure in user written functions calling gam/bam and then 'predict' without supplying all prediction variables (fix obvious). * A help file 'single.index' supplied illustrating how single index models can be estimated in mgcv. * predict.gam now only creates a "constant" attribute if the model has one. * gam.fit4 convergence testing of coefs modified to more robust test of gradients of penalized dev w.r.t. params, rather than change in params, which can fail under rank deficiency. * mgcv_qrqy was not thread safe. Not noticeable on many platforms as all threads did exactly the same thing to the same matrix, but very noticeable on Windows. Thread safe mgcv_qrqy0 added and used in any parallel sections. * Allow openMP support if compiler supports it and provides pre-defined macro _OPENMP, even if SUPPORT_OPENMP undefined. (Allows multi-threading on Windows, for example.) * 'eps' is now an argument to 'betar' allowing some control on how to handle response values too close to 0 or 1. Help file expanded to emphasise the problems with using beta regression with 0s and 1s in the data. * fix of bug in multi-formula contrast handling, causing failure of prediction in some cases. * ziP and ziplss now check for non-integer (or binary) responses and produce an error message if these are found. Previously this was not trapped and could lead to a segfault. 1.8-4 ** JAGS/BUGS support added, enabling auto-generation of code and data required to used mgcv type GAMs with JAGS. Useful for complex random effects structures, for example. * smoothCon failed if selection penalties requested, but term was unpenalized. Now fixed (no selection penalties on unpenalized terms.) * gam.check would fail for tensor product smooths with by variables - fixed. * predict.gam would fail when predicting for more data than the blocksize but selecting only some terms. Fixed thanks to Scott Kostyshak. * smoothCon now has an argument `diagonal.penalty' allowing single penalty smooths to be re-parameterized in order to diagonalize the penalty matrix. PredictMat is modified to apply the same reparameterization, making it user transparent. Facilitates the setup of smooths for export to other packages. * predict.bam now exported in response to a request from another package maintainer. * 1.8 allows some prediction tasks for some families (e.g. cox.ph) to require response variables to be supplied. NAs in these then messed up prediction when they were not needed (e.g. if response variables with NAs were provided to predict.gam for a simple exponential family GAM). Response NAs now passed to the family specific prediction code, restoring the previous behaviour for most models. Thanks Casper Wilestofte Berg. * backend parallel QR code used by gam modified to use a pivoted block algorithm. * nthreads argument added to 'bam' to allow for parallel computation for computations in the main process (serial on any cluster nodes). e.g. QR based combination of results from cluster nodes is now parallel. * fREML computation now partly in parallel (controlled by 'nthreads' argument to 'bam') * slanczos now accepts an nt argument allowing parallel computation of main O(n^2) step. * fix to newton logic problem, which could cause an attempt to use 'score2' before definition. * fix to fREML code which could cause matrix square root to lose dimensions and cause an error. * initial.sp could perform very poorly for very low basis dimensions - could set initial sp to effective infinity. 1.8-3 * Fix of two illegal read/write bugs with extended family models with no smooths. (Thanks to Julian Faraway for reporting beta regr problem). * bam now checks that chunk.size > number of parameters and resets the chunk.size if not. * Examples of use of smoothCon and PredictMat for setting up bases for use outside mgcv (and then predicting) added to ?smoothCon. 1.8-2 * For exponential family gams, fitted by outer iteration, a warning is now generated if the Pearson scale parameter estimate is more than 4 times a robust estimate. This may indicate an unstable Pearson estimate. * 'gam.control' now has an option 'scale.est' to allow selection of the estimator to use for the scale parameter in exponential family GAMs. See ?gam.scale. Thanks to Trevor Davies for providing a clear unstable Pearson estimate example. * drop.unused.levels argument added to gam, bam and gamm to allow "mrf" (and "re") terms to have unobserved factor levels. * "mrf" constructor modified to deal properly with regions that contain no observations. * "fs" smooths are no longer eligible to have side conditions set, since they are fully penalized terms and hence always identifiable (in theory). * predict.bam was not declared as a method in NAMESPACE - fixed * predict.bam modified to strip down object to save memory (especially in parallel). * predict.gam now has block.size=NULL as default. This implies a block size of 1000 when newdata supplied, and use of a single block if no new data was supplied. * some messages were not printing correctly after a change in message handling to facilitate easier translation. Now fixed. 1.8-1 * bam modified so that choleski based fitting works properly with rank deficient model matrix (without regularization). * fix of 1.8-0 bug - gam prior weights mishandled in computation of cov matrix, resulting in incorrect variance estimates (even without prior weights specified). Thanks Fabian Scheipl. 1.8-0 *** Cox Proportional Hazard family 'cox.ph' added as example of general penalized likelihood families now useable with 'gam'. *** 'ocat', 'tw', 'nb', 'betar', 'ziP' and 'scat' families added for ordered categorical data, Tweedie with estimation of 'p', negative binomial with (fast) estimation of 'theta', beta regression for proportions, simple zero inflated Poisson regression and heavy tailed regression with scaled t distribution. These are all examples of 'extended families' now useable with 'gam'. *** 'gaulss' and 'ziplss' families, implementing models with multiple linear predictors. For gaulss there is a linear predictor for the Gaussian mean and another for the standard deviation. For ziplss there is a linear predictor controlling `presence' and another controlling the Poisson parameter, given presence. *** 'mvn' family for multivariate normal additive models. ** AIC computation changed for bam and gam models estimated by REML/ML to account for smoothing parameter uncertainty in degrees of freedom term. * With REML/ML smoothness selection in gam/bam an extra covariance matrix 'Vc' is now computed which allows for smoothing parameter uncertainty. See the 'unconditional' arguments to 'predict.gam' and 'plot.gam' to use this. * 'gam.vcomp' bug fix. Computed intervals for families with fixed scale parameter were too wide. * gam now defaults to the Pearson estimator of the scale parameter to avoid poor scale estimates in the quasipoisson case with low counts (and possibly elsewhere). Gaussian, Poisson and binomial inference invariant to change. Thanks to Greg Dropkin, for reporting the issue. * Polish translation added thanks to Lukasz Daniel. * gam.fit3 now forces eta and mu to be consistent with coef and valid on return (previously could happen that if step halving was used in final iteration then eta or mu could be invalid, e.g. when using identity link with non-negative data) * gam.fit3 now bases its convergence criteria on grad deviance w.r.t. model coefs, rather than changes in model coefs. This prevents problems when there is rank deficiency but different coefs get dropped at different iterations. Thanks to Kristynn Sullivan. * If mgcv is not on the search path then interpret.gam now tries to evaluate in namespace of mgcv with environment of formula as enclosing environment, if evaluation in the environment of the formula fails. * bug fix to sos plotting method so that it now works with 'by' variables. * 'plot.gam' now weights partial residuals by *normalized* square root iterative weights so that the average weight is 1 and the residuals should have constant variance if all is ok. * 'pcls' now reports if the initial point is not feasible. * 'print.gam' and 'summary.gam' now report the rank of the model if it is rank deficient. 'gam.check' reports the model rank whenever it is available. * fix of bug in 'k.check' called by 'gam.check' that gave an error for smooths with by variables. * predict.gam now checks that factors in newdata do not contain more levels than those used in fitting. * predict.gam could fail for type "terms" with no intercept - fixed. * 'bfgs' now uses a finite difference approximation for the initial inverse Hessian. 1.7-29 * Single character change to Makevars file so that openMP multi-threading actually works. 1.7-28 * exclude.too.far updated to use kd-tree instead of inefficient search for neighbours. This can make plot.gam *much* faster for large datasets. * Change in smoothCon, so that sweep and drop constraints (default for bam for efficiency reasons) are no longer allowed with by variables and matrix arguments (could lead to confusing results with factor by variables in bam). * 'ti' terms now allow control of which marginals to constrain, via 'mc'. Allows e.g. y ~ ti(x) + ti(x,z,mc=c(0,1)) - for experts only! * tensor.prod.model.matrix re-written to call C code. Around 5-10 times faster than old version for large data sets. * re-write of mini.mf function used by bam to generate a reduced size model frame for model setup. New version ensures that all factor levels are present in reduced frame, and avoids production of unrealistic combinations of variables in multi-dimensional smooths which could occur with old version. * bam models could fail if a penalty matrix was 1 by 1, or if multiple penalties on a smooth were in fact seperable into single penalties. Fixed. Thanks to Martijn weiling for reporting. * Constant in tps basis computation was different to published version for odd dimensions - makes no difference to fit, but annoying if you are trying to test a re-implementation. Thanks to Weijie Cai at SAS. * prediction for "cc" and "cp" classes is now cyclic - values outside the range of knots are wrapped back into the interval. * ldTweedie now returns derivatives w.r.t. a transform of p as well as w.r.t log of scale parameter phi. * gamm can now handle 'varComb' variance functions (thanks Sven Neulinger for reporting that it didn't). * fix of a bug which could cause bam to seg fault for a model with no smooths (insufficient storage allocated in C in this case). Thanks Martijn Weiling. 1.7-27 * Further multi-threading in gam fits - final two leading order matrix operations parallelized using openMP. * Export of smooth.construct.t2.smooth.spec and Predict.matrix.t2.smooth, and Rrank. * Fix of of missing [,,drop=FALSE] in predict.gam that could cause problems with single row prediction when 'terms' supplied (thanks Yang Yang). 1.7-26 * Namespace fixes. 1.7-25 * code added to allow openMP based multi-threading in gam fits (see ?gam.control and ?"mgcv-parallel"). * bam now allows AR1 error model to be split blockwise. See argument 'AR.start'. * magic.post.proc made more efficient (one of two O(np^2) steps removed). * var.summary now coerces character to factor. * bugs fixed whereby etastart etc were not passed to initial.spg and get.null.coefs. Thanks to Gavin Simpson. * reformulate removed from predict.gam to avoid (slow) repeated parser calls. * gaussian(link="log") initialization fixed so that negative data does not make it fail, via fix.family patching function. * bug fix in plot method for "fs" basis - ignored any side conditions. Thanks to Martijn Weiling and Jacolien van Rij. * gamm now checks whether smooths nested in factors have illegal side conditions, and halts if so (re-ordering formula can help). * anova.glmlist no longer called. * Compiled code now uses R_chck_calloc and R_chk_free for memory management to avoid the possibility of unfriendly exit on running out of memory. * fix in gam.side which would fail with unpenalized interactions in the presence of main effects. 1.7-24 * Examples pruned in negbin, smooth.construct.ad.smooth.spec and bam help files to reduce CRAN checking load. * gam.side now warns if only repeated 1-D smooths of the same variable are encountered, but does not halt. * Bug fix in C code for "cr" basis, that could cause a memory violation during prediction, when an extrapolation was immediately followed by a prediction that lay exactly on the upper boundary knot. Thanks to Keith Woolner for reporting this. * Fix for bug in fast REML code that could cause bam to fail with ti/te only models. Thanks to Martijn Wieling. * Fix of bug in extract.lme.cov2, which could cause gamm to fail when a correlation structure was nested inside a grouping factor finer than the finest random effect grouping factor. * Fix for an interesting feature of lme that getGroups applied to the corStruct that is part of the fitted lme object returns groups in sorted order, not data frame order, and without an index from one order to the other. (Oddly, the same corStruct Initialized outside lme has its groups in data frame order.) This feature could cause gamm to fail, complaining that the grouping factors for the correlation did not appear to be nested inside the grouping structure of the random effects. A bunch of ordering sensitivity tests have been added to the mgcv test suite. Thanks to Dave Miller for reporting the bug. 1.7-23 *** Fix of severe bug introduced with R 2.15.2 LAPACK change. The shipped version of dsyevr can fail to produce orthogonal eigenvectors when uplo='U' (upper triangle of symmetric matrix used), as opposed to 'L'. This led to a substantial number of gam smoothing parameter estimation convergence failures, as the key stabilizing re-parameterization was substantially degraded. The issue did not affect gaussian additive models with GCV model selection. Other models could fail to converge any further as soon as any smoothing parameter became `large', as happens when a smooth is estimated as a straight line. check.gam reported the lack of full convergence, but the issue could also generate complete fit failures. Picked up late as full test suite had only been run on R > 2.15.1 with an external LAPACK. ** 'ti' smooth specification introduced, which provides a much better (and very simple) way of allowing nested models based on 'te' type tensor product smooths. 'ti' terms are used to set up smooth interactions excluding main effects (so ti(x,z) is like x:z while te(x,z) is more like x*z, although the analogy is not exact). * summary.gam now uses a more efficient approach to p-value computation for smooths, using the factor R from the QR factorization of the weighted model matrix produced during fitting. This is a weighted version of the Wood (2013) statistic used previously - simulations in that paper essentially unchanged by the change. * summary.gam now deals gracefully with terms such as "fs" smooths estimated using gamm, for which p-values can not be computed. (thanks to Gavin Simpson). * gam.check/qq.gam now uses a normal QQ-plot when the model has been fitted using gamm or gamm4, since qq.gam cannot compute corrext quantiles in the presence of random effects in these cases. * gamm could fail with fixed smooths while assembling total penalty matrix, by attempting to access non-existent penalty matrix. (Thanks Ainars Aunins for reporting this.) * stripped rownames from model matrix, eta, linear predictor etc. Saves memory and time. * plot.soap.film could switch axis ranges. Fixed. * plot.mgcv.smooth now sets smooth plot range on basis of xlim and ylim if present. * formXtViX documentation fixed + return matrix labels. * fixDependence related negative index failures for completely confounded terms - now fixed. * sos smooth model matrix re-scaled for better conditioning. * sos plot method could produce NaNs by a rounding error in argument to acos - fixed. 1.7-22 * Predict.matrix.pspline.smooth now allows prediction outside range of knots, and uses linear extrapolation in this case. * missing drop=FALSE in reTest called by summary.gam caused 1-D random effect p-value computation to fail. Fixed (thanks Silje Skår). 1.7-21 ** soap film smoother class added. See ?soap * Polish translation added thanks to Lukasz Daniel. * mgcv/po/R-mgcv.pot up-dated. * plot methods for smooths modified slightly to allow methods to return plot data directly, without a prediction matrix. 1.7-20 * '...' now passed to termplot by plot.gam (thanks Andreas Eckner). * fix to null deviance computation for binomial when n>1, matrix response used and an offset is present. (Thanks to Tim Miller) * Some pruning of unused code from recov and reTest. * recov modified to stop it returning a numerically non-symmetric Ve, and causing occasional failures of summary.gam with "re" terms. * MRF smooth bug. Region ordering could become confused under some circumstances due to incorrect setting of factor levels. Corrected thanks to detailed bug report from Andreas Bender. * polys.plot colour/grey scale bug. Could ask for colour 0 from colour scheme, and therefore fail. Fixed. 1.7-19 ** summary.gam and anova.gam now use an improved p-value computation for smooth terms with a zero dimensional penalty null space (including random effects). The new scheme has been tested by full replication of the simulation study in Scheipl (2008,CSDA) to compare it to the best method therein. In these tests it is at least as powerful as the best method given there, and usually indistinguishable, but it gives slightly too low null p-values when smoothing parameters are very poorly identified. Note that the new p-values can not be computed from old fitted gam objects. Thanks to Martijn Wieling for pointing out how bad the p-values for regular smooths could be with random effects. * t2 terms now take an argument `ord' that allows orders of interaction to be selected. * "tp" smooths can now drop the null space from their construction via a vector m argument, to allow testing against polynomials in the null space. * Fix of vicious little bug in gamm tensor product handling that could have a te term pick up the wrong model matrix and fail. * bam now resets method="fREML" to "REML" if there are no free smoothing parameters, since there is no advantage to the "fREML" optimizer in this case, and it assumes there is at least one free smoothing parameter. * print.gam modified to print effective degrees of freedom more prettily, * testStat bug fix. qr was called with default arguments, which includes tol=1e-7... * bam now correctly returns fitting weights (rather than prior) in weights field. 1.7-18 * Embarrassingly, the adjusted r^2 computation in summary.gam was wrong for models with prior weights. Now fixed, thanks to Antony Unwin. * bam(...,method="fREML") could give incorrect edfs for "re" terms as a result of a matrix indexing error in Sl.initial.repara. Now fixed. Thanks to Martijn Wieling for reporting this. * summary.gam had freq=TRUE set as default in 1.7-17. This gave better p-values for paraPen terms, but spoiled p-values for fixed effects in the presence of "re" terms (a rather more common setup). Default now reset to freq=FALSE. * bam(...,method="fREML") made fully compatible with gam.vcomp. * bam and negbin examples speeded up * predict.gam could fail for models of the form y~1 when newdata are supplied. (Could make some model averaging methods fail). Fixed. * plot.gam had an overzealous check for availibility of variance estimates, which could make rank deficient models fail to plot CIs. fixed. 1.7-17 ** p-values for terms with no un-penalized components were poor. The theory on which the p-value computation for other terms is based shows why this is, and allows fixes to be made. These are now implemented. * summary p value bug fix --- smooths with no null space had a bug in lower tail of p-value computation, yielding far too low values. Fixed. * bam now outputs frequentist cov matrix Ve and alternative effective degrees of freedom edf1, in all cases. * smoothCon now adjusts null.space.dim on constraint absorption. * Prediction with matrix arguments (i.e. for models using summation convention) could be very memory hungry. This in turn meant that bam could run out of memory when fitting models with such terms. The problem was memory inefficient handling of duplicate evaluations. Now fixed by modification of PredictMat * bam could fail if the response vector was of class matrix. fixed. * reduced rank mrf smooths with supplied penalty could use the incorrect penalty rank when computing the reduced rank basis and fail. fixed thanks to Fabian Scheipl. * a cr basis efficiency change could lead to old fitted model objects causing segfaults when used with current mgcv version. This is now caught. 1.7-16 * There was an unitialized variable bug in the 1.7-14 re-written "cr" basis code for the case k=3. Fixed. * gam.check modified slightly so that k test only applied to smooths of numeric variables, not factors. 1.7-15 * Several packages had documentation linking to the 'mgcv' function help page (now removed), when a link to the package was meant. An alias has been added to mgcv-package.Rd to fix/correct these links. 1.7-14 ** predict.bam now added as a wrapper for predict.gam, allowing parallel computation ** bam now has method="fREML" option which uses faster REML optimizer: can make a big difference on parameter rich models. * bam can now use a cross product and Choleski based method to accumulate the required model matrix factorization. Faster, but less stable than the QR based default. * bam can now obtain starting values using a random sub sample of the data. Useful for seriously large datasets. * check of adequacy of basis dimensions added to gam.check * magic can now deal with model matrices with more columns than rows. * p-value reference distribution approximations improved. * bam returns objects of class "bam" inheriting from "gam" * bam now uses newdata.guaranteed=TRUE option when predicting as part of model matrix decomposition accumulation. Speeds things up. * More efficient `sweep and drop' centering constraints added as default for bam. Constaint null space unchanged, but computation is faster. * Underlying "cr" basis code re-written for greater efficiency. * routine mgcv removed, it now being many years since there has been any reason to use it. C source code heavily pruned as a result. * coefficient name generation moved from estimate.gam to gam.setup. * smooth2random.tensor.smooth had a bug that could produce a nonsensical penalty null space rank and an error, in some cases (e.g. "cc" basis) causing te terms to fail in gamm. Fixed. * minor change to te constructor. Any unpenalized margin now has corresponding penalty rank dropped along with penalty. * Code for handling sp's fixed at exactly zero was badly thought out, and could easily fail. fixed. * TPRS prediction code made more efficient, partly by use of BLAS. Large dataset setup also made more efficient using BLAS. * smooth.construct.tensor.smooth.spec now handles marginals with factor arguments properly (there was a knot generation bug in this case) * bam now uses LAPACK version of qr, for model matrix QR, since it's faster and uses BLAS. 1.7-13 ** The Lanczos routine in mat.c was using a stupidly inefficient check for convergence of the largest magnitude eigenvectors. This resulted in far too many Lanczos steps being used in setting up thin plate regression splines, and a noticeable speed penalty. This is now fixed, with many thanks David Shavlik for reporting the slow down. * Namespace modified to import from methods. Dependency on stats and graphics made explicit. * "re" smooths are no longer subject to side constraint under nesting (since this is almost always un-necessary and undesirable, and often unexpected). * side.con modified to allow smooths to be excluded and to allow side constraint computation to take account of penalties (unused at present). 1.7-12 * bam can now compute the leading order QR decomposition on a cluster set up using the parallel package. * Default k for "tp" and "ds" modified so that it doesn't exceed 100 + the null space dimension (to avoid complaints from users smoothing in quite alot of dimensions). Also default sub-sample size reduced to 2000. * Greater use of BLAS routines in the underlying method code. In particular all leading order operations count steps for gam fitting now use BLAS. You'll need R to be using a rather fancy BLAS to see much difference, however. * Amusingly, some highly tuned blas libraries can result in lapack not always giving identical eigenvalues when called twice with the same matrix. The `newton' optimizer had assumed this wouldn't happen: not any more. * Now byte compiled by default. Turn this off in DESCRIPTION if it interferes with debugging. * summary.gam p-value computation options modified (default remains the same). * summary.gam default p-value computation made more computationally efficient. * gamm and bam could fail under some options for specifying binomial models. Now fixed. 1.7-11 * smoothCon bug fix to avoid NA labels for matrix arguments when no by variable provided. * modification to p-value computation in summary.gam: `alpha' argument removed (was set to zero anyway); computation now deals with possibility of rank deficiency computing psuedo-inverse of cov matrix for statistic. Previously p-value computation could fail for random effect smooths with large datasets, when a random effect has many levels. Also for large data sets test statistic is now based on randomly sampling max(1000,np*2) model matrix rows, where np is number of model coefficients (random number generator state unchanged by this), previous sample size was 3000. * plot.mrf.smooth modified to allow passing '...' argument. * 'negbin' modified to avoid spurious warnings on initialization call. 1.7-10 * fix stupid bug in 1.7-9 that lost term labels in plot.gam. 1.7-9 * rather lovely plot method added for splines on the sphere. * plot.gam modified to allow 'scheme' to be specified for plots, to easily select different plot looks. * schemes added for default smooth plotting method, modified for mrfs and factor-smooth interactions. * mgcv function deprected, since magic and gam are much better (let me know if this is really a problem). 1.7-8 * gamm.setup fix. Bug introduced in 1.7-7 whereby gamm with no smooths would fail. * gamm gives returned object a class "gamm" 1.7-7 * "fs" smooth factor interaction class introduced, for smooth factor interactions where smoothing parameters are same at each factor level. Very efficient with gamm, so good for e.g. individual subject smooths. * qq.gam default method modified for increased power. * "re" terms now allowed as tensor product marginals. * log saturated likelihoods modified w.r.t. weight handling, so that weights are treated as modifying the scale parameter, when scale parameter is free. i.e. obs specific scale parameter is overall scale parameter divided by obs weight. This ensures that when the scale parameter is free, RE/ML based inference is invariant to multiplicative rescaling of weights. * te and t2 now accept lists for 'm'. This allows more flexibility with marginals that can have vector 'm' arguments (Duchon splines, P splines). * minor mroot fix/gam.reparam fix. Could declare symmetric matrix not symmetric and halt gam fit. * argument sparse added to bam to allow exploitation of sparsity in fitting, but results disappointing. * "mrf" now evaluates rank of penalty null space numerically (previously assumed it was always one, which it need not be with e.g. a supplied penalty). * gam.side now corrects the penalty rank in smooth objects that have been constrained, to account for the constraint. Avoids some nested model failures. * gamm and gamm.setup code restructured to allow smooths nested in factors and for cleaner object oriented converion of smooths to random effects. * gam.fit3 bug. Could fail on immediate divergence as null.eta was matrix. * slanczos bug fixes --- could segfault if k negative. Could also fail to return correct values when k small and kl < 0 (due to a convergence testing bug, now fixed) * gamm bug --- could fail if only smooth was a fixed one, by looking for non-existent sp vector. fixed. * 'cc' Predict.matrix bug fix - prediction failed for single points. * summary.gam failed for single coefficient random effects. fixed. * gam returns rV, where t(rV)%*%rV*scale is Bayesian cov matrix. 1.7-6 ** factor `by' variable handling extended: if a by variable is an ordered factor then the first level is treated as a reference level and smooths are only generated for the other levels. This is useful for avoiding identifiability issues in complex models with factor by variables. * bam bug fix. aic was reported incorrectly (too low). 1.7-5 * gam.fit3 modified to converge more reliably with links that don't guarantee feasible mu (e.g poisson(link="identity")). One vulnerability removed + a new approach taken, which restarts the iteration from null model coefficients if the original start values lead to an infinite deviance. * Duchon spline bug fix (could fail to create model matrix if number of data was one greater than number of unique data). * fix so that 'main' is not ignored by plot.gam (got broken in 1.7-0 object orientation of smooth plotting) * Duchon spline constructor now catches k > number of data errors. * fix of a gamm bug whereby a model with no smooths would fail after fitting because of a missing smoothing parameter vector. * fix to bug introduced to gam/bam in 1.7-3, whereby '...' were passed to gam.control, instead of passing on to fitting routines. * fix of some compiler warnings in matrix.c * fix to indexing bug in monotonic additive model example in ?pcls. 1.7-4 * Fix for single letter typo bug in C code called by slanczos, could actually segfault on matrices of less than 10 by 10. * matrix.c:Rlanczos memory error fix in convergence testing of -ve eigenvalues. * Catch for min.sp vector all zeroes, which could cause an ungraceful failure. 1.7-3 ** "ds" (Duchon splines) smooth class added. See ?Duchon.spline ** "sos" (spline on the sphere) smooth class added. See ?Spherical.Spline. * Extended quasi-likelihood used with RE/ML smoothness selection and quasi families. * random subsampling code in bam, sos and tp smooths modified a little, so that .Random.seed is set if it doesn't exist. * `control' argument changed for gam/bam/gamm to a simple list, which is then passed to gam.control (or lmeControl), to match `glm'. * Efficiency of Lanczos iteration code improved, by restructuring, and calling LAPACK for the eigen decompostion of the working tri-diagonal matrix. * Slight modification to `t2' marginal reparameterization, so that `main effects' can be extracted more easily, if required. 1.7-2 * `polys.plot' now exported, to facilitate plotting of results for models involving mrf terms. * bug fix in plot.gam --- too.far had stopped working in 1.7-0. 1.7-1 * post fitting constraint modification would fail if model matrix was rank deficient until penalized. This was an issue when mixing new t2 terms with "re" type random effects. Fixed. * plot.mrf.smooth bug fix. There was an implicit assumption that the `polys' list was ordered in the same way as the levels of the covariate of the smooth. fixed. * gam.side intercept detection could occasionally fail. Improved. * concurvity would fail if model matrix contained NA's. Fixed. 1.7-0 ** `t2' alternative tensor product smooths added. These can be used with gamm4. ** "mrf" smooth class added (at the suggestion of Thomas Kneib). Implements smoothing over discrete geographic districts using a Markov random field penalty. See ?mrf * qq.gam added to allow better checking of distribution of residuals. * gam.check modified to use qq.gam for QQ plots of deviance residuals. Also, it now works with gam(*, na.action = "na.replace") and NAs. * `concurvity' function added to provide simple concurvity measures. * plot.gam automatic layout modified to be a bit more sensible (i.e. to recognise that most screens are landscape, and that usually squarish plots are wanted). * Plot method added for mrf smooths. * in.out function added to test whether points are interior to a region defined by a set of polygons. Useful when working with MRFs. * `plot.gam' restructured so that smooths are plotted by smooth specific plot methods. * Plot method added for "random.effect" smooth class. * `pen.edf' function added to extract EDF associated with each penalty. Useful with t2 smooths. * Facilty provided to allow different identifiability constraints to be used for fitting and prediction. This allows t2 smooths to be fitted with a constraint that allows fitting by gamm4, but still perform inference with the componentwise optimal sum to zero constraints. * mgcv-FAQ.Rd added. * paraPen works properly with `gam.vcomp' and full.sp names returned correctly. * bam (and bam.update) can now employ an AR1 error model in the guassian-identity case. * bam.update modified for faster updates (initial scale parameter estimate now supplied in RE/ML case) * Absorption of identifiability constraints modified to allow constraints that only affect some parameters to leave rest of parameters completely unchanged. * rTweedie added for quick simulation of Tweedie random deviates when 1 pmin) * color example added to plot.gam.Rd * bug fix in `smooth.construct.tensor.smooth.spec' - class "cyclic.smooth" marginals no longer re-parameterized. * `te' documentation modified to mention that marginal reparameterization can destabilize tensor products. 1.3-17 * print.summary.gam prints estimated ranks more prettily (thanks Martin Maechler) ** `fix.family.link' can now handle the `cauchit' link, and also appends a third derivative of link function to the family (not yet used). * `fix.family.var' now adds a second derivative of the link function to the family (not yet used). ** `magic' modified to (i) accept an argument `rss.extra' which is added to the RSS(squared norm) term in the GCV/UBRE or scale calculation; (ii) accept argument `n.score' (defaults to number of data), the number to use in place of the number of data in the GCV/UBRE calculation. These are useful for dealing with very large data sets using pseudo-model approaches. * `trans' and `shift' arguments added to `plot.gam': allows, e.g. single smooth models to be easily plotted on uncentred response scale. * Some .Rd bug fixes. ** Addition of choose.k.Rd helpfile, including example code for diagnosing overly restrictive choice of smoothing basis dimension `k'. 1.3-16 * bug fix in predict.gam documentation + example of how to predict from a `gam' outside `R'. 1.3-15 * chol(A,pivot=TRUE) now (R 2.3.0) generates a warning if `A' is not +ve definite. `mroot' modified to supress this (since it only calls `chol(A,pivot=TRUE)' because `A' is usually +ve semi-definite). 1.3-14 * mat.c:mgcv_symeig modified to allow selection of the LAPACK routine actually used: dsyevd is the routine used previously, and seems very reliable. dsyevr is the faster, smaller more modern version, which it seems possible to break... rest of code still calls dsyevd. * Symbol registration added (thanks largely to Brian Ripley). Version depends on R >= 2.3.0 1.3-13 * some doc changes ** The p-values for smooth terms had too low power sometimes. Modified testing procedure so that testing rank is at most ceiling(2*edf.for.term). This gives quite close to uniform p-value distributions when the null is true, in simulations, without excessive inflation of the p-values, relative to parametetric equivalents when it is not. Still not really satisfactory. 1.3-12 * vis.gam could fail if the original model formula contained functions of covariates, since vis.gam calls predict.gam with a newdata argument based on the *model frame* of the model object. predict.gam now recognises that this has happened and doesn't fail if newdata is a model frame which contains, e.g. log(x) rather than x itself. offset handling simplified as a result. * prediction from te smooths could fail because of a bug in handling the list of re-parameterization matrices for 1-D terms in Predict.matrix.tensor.smooth. Fixed. (tensor product docs also updated) * gamm did not handle s(...,fx=TRUE) terms properly, due to several failures to count s(...,fx=FALSE) terms properly if there were fixed terms present. Now fixed. * In the gaussian additive mixed model case `gamm' now allows "ML" or "REML" to be selected (and is slightly more self consistent in handling the results of the two alternatives). 1.3-11 * added package doc file * added French error message support (thanks to Philippe Grosjean), and error message quotation characters (thanks to Brian Ripley.) 1.3-10 * a `constant' attribute has been added to the object returned by predict.gam(...,type="terms"), although what is returned is still not an exact match to what `predict.lm' would do. ** na.action handling made closer to glm/lm functions. In particular, default for predict.gam is now to pad predictions with NA's as opposed to dropping rows of newdata containing NA's. * interpret.gam had a bug caused by a glitch in the terms.object documentation (R <=2.2.0). Formulae such as y ~ a + b:a + s(x) could cause failure. This was because attr(tf,"specials") is documented as returning indices of specials in `terms'. It doesn't, it indexes specials in the variables dimension of the attr(tf,"factors") table: latter now used to translate. * `by' variable use could fail unreasonably if a `by' variable was not of mode `numeric': now coerced to numeric at appropriate times in smooth constructors. 1.3-9 * constants multiplying TPRS basis functions were `unconventional' for d odd in function eta() in tprs.c. The constants are immaterial if you are using gam, gamm etc, but matter if you are trying to get out the explicit representation of a TPRS term yourself (e.g. to differentiate a smooth exactly). 1.3-8 * get.var() now checks that result is numeric or factor (avoids occasional problems with variable names that are functions - e.g `t') * fix.family.var and fix.family.link now pass through unaltered any family already containing the extra derivative functions. Usually, to make a family work with gam.fit2 it is only necessary to add a dvar function. * defaults modified so that when using outer iteration, several performance iteration steps are now used for initialization of smoothing parameters etc. The number is controlled by gam.control(outerPIsteps). This tends to lead to better starting values, especially with binary data. gam, gam.fit and gam.control are modified. * initial.sp modified to allow a more expensive intialization method, but this is not currently used by gam. * minor documentation changes (e.g. removal of full stops from titles) 1.3-7 * change to `pcls' example to account for model matrix rescaling changing smoothing parameter sizes. * `gamm' `control' argument set to use "L-BFGS-B" method if `lme' is using `optim' (only does this if `nlminb' not present). Consequently `mgcv' now depends on nlme_3.1-64 or above. * improvement of the algorithm in `initial.sp'. Previously it was possible for very low rank smoothers (e.g. k=3) to cause the initialization to fail, because of poor handling of unpenalized parameters. 1.3-6 * pdIdnot class changed so that parameters are variances not standard deviations - this makes for greater consistency with pdTens class, and means that limits on notLog2 parameterization should mean the same thing for both classes. ** niterEM set to 0 in lme calls. This is because EM steps in lme are not set up to deal properly with user defined pdMat classes (latter confirmed by DB). 1.3-5 ** Improvements to anova and summary functions by Henric Nilsson incorporated. Functions are now closer to glm equivalents, and printing is more informative. See ?anova.gam and ?summary.gam. * nlme 3.1-62 changed the optimizer underlying lme, so that indefintie likelihoods cause problems. See ?logExp2 for the workaround. - niterEM now reset to 25, since parameterization prevents parameters wandering to +/- infinity (this is important as starting values for Newton steps are now more critical, since reparameterization introduces new local minima). ** smoothCon modified to rescale penalty coefficient matrices to have similar `size' to X'X for each term. This is to try and ensure that gamm is reasonably scale invariant in its behaviour, given the logExp2 re-parameterization. * magic dropped dimensions of an array inapproporiately - fixed. * gam now checks that model does not have more coefficients than data. 1.3-4 * inst/CITATION file added. Some .Rd fixes 30/6/2005 1.3-3 * te() smooths were not always estimated correctly by gamm(): invariance lost and different results to equivalent s() smooths. The problem seems to lie in a sensitivity of lme() estimation to the absolute size of the `S' attribute matrices of a pdTens class pdMat object: the problem did not occur at the last revision of the pdTens class, and there are no changes logged for nlme that could have caused it, so I guess it's down to a change in something that lme calls in the base distribution. To avoid the problem, smooth.construct.tensor.smooth.spec has been modified to scale all marginal penalty matrices so that they have largest singular value 1. * Changes to GLMs in R 2.1.1 mean that if the response is an array, gam could fail, due to failure of terms like w * X when w is and array rather than a vector. Code modified accordingly. * Outer iteration now suppresses some warnings, until the final fitted model is obtained, in order to avoid printing warnings that actually don't apply to the final fit. * Version number reporting made (hopefully) more robust. * pdconstruct.pdTens removed absolute lower limit on coef - replaced with relative lower limit. * moved tensor product constraint construction to BEFORE by variable stuff in smooth.construct.tensor.smooth.spec. 1.3-1 * vcov had been left out of namespace - fixed. * cr and cc smooths now trap the case in which the incorrect number of knots are supplied to them. * `s(.)' in a formula could cause a segfault, it get's trapped now, hopefully it will be handled nicely at some point in the future. Thanks Martin Maechler. * wrong n reported in summary.gam() in the generalized case - fixed. Thanks YK Chau. 1.3-0 *** The GCV/UBRE score used in the generalized case when fitting by outer iteration (the default) in version 1.2 was based on the Pearson statistic. It is prone to serious undersmoothing, particularly of binary data. The default is now to use a GCV/UBRE score based on the deviance: this performs much better, while still maintaining the enhanced numerical convergence performance of outer iteration. * The Pearson based scores are still available as an option (see ?gam.method) * For the known scale parameter case the default UBRE score is now just a linearly rescaled AIC criterion. 1.2-6 * Two bugs in smooth.sconstruct.tensor.smooth.spec: (i) incorrect testing of class of smooth before re-parameterizing, so that cr smooths were re-parameterized, when there is no need to; (ii) knots used in re-parameterization were based on quantiles of the relevant marginal covariate, which meant that repeated knots could be generated: now uses quantiles of unique covariate values. * Thanks to Henric Nilsson a bug in the documentation of magic.post.proc has been fixed. 1.2-5 ** Bug fix in gam.fit2: prior weights not subsetted for non-informative data in GCV/UBRE calculation. Also plot.gam modified to allow for consequent NA working residuals. Thanks to B. Stollenwerk for reporting this bug. ** vcov.gam written by Henric Nilsson included... see ?vcov.gam * Some minor documentation fixes. * Some tweaking of tolerances for outer iteration (was too lax). ** Modification of the way predict.gam picks up variables. (complication is that it should behave like other predict functions, but warn if an incomplete prediction data frame is supplied -since latter violates what white book says). 1.2-2 *** An alternative approach to GCV/UBRE optimization in the *generalized* additive model case has been implemented. It leads to more reliable convergence for models with concurvity problems, but is slower than the old default `performance iteration'. Basically the GAM IRLS process is iterated to convergence for each trial set of smoothing parameters, and the derivatives of the GCV/UBRE score w.r.t. smoothing parameters are calculated explicitly as part of the IRLS iteration. This means that the GCV/UBRE optimization is now `outer' to the IRLS iteration, rather than being performed on each working model of the IRLS iteration. The faster `performance iteration' is still available as an option. As a side effect, when using outer iteration, it is not possible to find smoothing parameters that marginally improve on the GCV/UBRE scores of the estimated ones by hand tuning: this improves the logical self consistency of using GCV/UBRE scores for model selection purposes. * To facilitate the expanded list of fitting methods, `gam' now has a `method' argument requiring a 3 item list, specifying which method to use for additive models, which for generalized additive models and if using outer iteration, which optimization routine to use. See ?gam.method for details. `gam.control' has also been modified accordingly. *** By default all smoothing bases are now automatically re-parameterized to absorb centering constraints on smooths into the basis. This makes everything more modular, and is usually user transparent. See ?gam.control to get the old behaviour. ** Tensor product smooths (te) now use a reparameterization of the marginal smoothing bases, which ensures that the penalties of a tensor product smooth retain the interpretation, in terms of function shape, of the marginal penalties from which they are induced. In practice this almost always improves MSE performance (at least for smooth underlying functions.) See ?te to turn this off. *** P-values reported by anova.gam and summary.gam are now based on strictly frequentist calculations. This means that they are much better justified theoretically, and are interpretable as ordinary frequentist p-values. They are still conditional on smoothing parameters, however, and are hence underestimates when smoothing parameters have been estimated. ** Identifiability side conditions modified to work with all smooths (including user defined). Now works by identifying possible dependencies symbolically, but dealing with the resulting degeneracies numerically. This allows full ANOVA decompositions of functions using tensor product smooths, for example. * summary.gam modified to deal with prior weights in adjusted r^2 calculation. ** `gam' object now contains `Ve' the frequentist covariance matrix of the paremeter estimators, which is useful for p-value calculation. see ?gamObject and ?magic.post.proc for details. * Now depends on R >=2.0.0 * Default residual plots modified in `gam.check' ** Added `cooks.distance.gam' function. * Bug whereby te smooths ignored `by' variables is now fixed. 1.1-6 * Smoothing parameter initialization method changed in magic, to allow better initialization of te() terms. This affects default gam fits. * gamm and extract.lme.cov2 modified to work correctly when the correlation structure applies to a finer grouping than the random effects. (Example of this added to gamm help file) * modifications of pdTens class. pdFactor.pdTens now returns a vector, not a matrix in accordance with documentation (in nlme 3.1-52). Factors are now always of form A=B'B (previously, could be A=BB') in accordance with documentation (nlme 3.1-52). pdConstruct.pdTens now tests whether initializing matrix is proportional to r.e. cov matrix or its inverse and initializes appropriately. gamm fitting with te() class tested extensively with modifications and nlme 3.1-52, and lme fits with pdTens class tested against equivalent fits made using re-parameterization and pdIdent class. In particular for gamm testing : model fits with single argument te() terms now match their equivalent models using s() terms; models fitted using gam() and gamm() match if gam() is called with the gamm() estimated smoothing parameters. * modifications of gamm() for compatibility with nlme 3.1-52: in particular a work around to allow everything to work correctly with a constructed formula object in lme call. * some modifications of plot.gam to allow greater control of appearance of plots of smooths of 2 variables. * added argument `offset' to gam for further compatibility with glm/lm. * change to safe prediction for parameteric terms had a bug in offset handling (offset not picked up if no newdata supplied, since model frame not created in this case). Fixed. (thanks to Jim Young for this) 1.1-5 * predict.gam had a further bug introduced with parametric safe prediction. Fixed by using a formula only containing the actual variable names when collecting data for prediction (i.e. no terms like `offset(x)') 1.1-5 * partial argument matching made col.shade be matched by col passed in ..in plot.gam, taking away user control of colors. 1.1-5 * 2d smooth plotting in plot.gam modified. * plot.gam could fail with residuals=TRUE due to incorrect counting in the code allowing use of termplot. plot.gam failed to prompt before a newpage if there was only one smooth. gam and gamm .Rd files updated slightly. 1.1-3 * extract.lme.cov2 could fail for random effect group sizes of 1 because submatrices with only a row or column lose their dimensions, and because single number calls to diag() result in an identity matrix. 1.1-2 * Some model formulae constructed in interpret.gam and used in facilitating safe prediction for parametric terms had the wrong environment - this could cause gam to fail to find data when e.g. lm, would find it. (thanks Thomas Maiwald) * Some items were missing from the NAMESPACE file. (thanks Kurt Hornik) * A very simple formula.gam function added, purely to facilitate better printing of anova method results under R 2.0.0. 1.1-1 * Due, no doubt, to gross moral turpitude on the part of the author, gamm() calculated the complete estimated covariance matrix of the response data explicitly, despite the fact that this matrix is usually rather sparse. For large datasets this could easily require more memory than was available, and huge computational expense to find the choleski decomposition of the matrix. This has now been rectified: when the covariance matrix has diagonal or block diagonal structure, then this is exploited. * Better examples have been added to gamm(). * Some documentation bugs were fixed. 1.1-0 Main changes are as follows. Note that `gam' object has been modified, so old objects will not always work with version 1.1 functions. ** Two new smooth classes "cs" and "ts": these are like "cr" and "tp" but can be penalized all the way down to zero degrees of freedom to allow fully automatic model selection (more self consistent than having a step.gam function). * The gam object expanded to allow inheritance from type lm and type glm, although QR related components of glm and lm are not available because of the difference in fitting method between glm/lm and gam. ** An anova method for gam objects has been added, for *approximate* hypothesis testing with GAMs. ** logLik.gam added (logLik.glm with df's fixed): enables AIC() to be used with gam objects. ** plot.gam modified to allow plotting of order 1 parametric terms via call to termplot. * Thanks to Henric Nilsson option `shade' added to plot.gam * predict.gam modified to allow safe prediction of parametric model components (such as poly() terms). * predict.gam type="terms" now works like predict.glm for parametric components. (also some enhancements to facilitate calling from termplot()) * Range of smoothing parameter estimation iteration methods expanded to help with non-convergent cases --- see ?gam.convergence * monotonic smoothing examples modified in light of above changes. * gamm modified to allow offset terms. * gamm bug fixed whereby terms in a model formula could get lost if there were too many of them. * gamm object modified in light of changes to gam object. 1.0-7 * Allows a model frame to be passed as `newdata' to predict.gam: it must contain all the terms in the gam objects model frame, `model'. * vis.gam() now passes a model frame to predict.gam and should be more robust as a result. `view' and `cond' must contain names from `names(x$model)' where x is the gam object. 1.0-6/5/4 * partial residuals modified to be IRLS residuals, weighted by IRLS weights. This is a much better reflecton of the influence of residuals than the raw IRLS residuals used before. * gamm summary sorted out by using NextMethod to get around fact that summary.pdMat can't be called directly (not in nlme namespace exports). * niterPQL and verbosePQL arguments added to gamm to allow more control of PQL iteration. * backquote=TRUE added when deparsing to allow non-standard names. (thanks: Brian Ripley) * bug in gam corrected: now gives correct null deviance when an offset is present. (thanks: Louise Burt) * bug in smooth.construct.tp.smooth.spec corrected: k=2 caused a segfault as the C code was reseting k to 3 (actually null space dimension +1), and not enough space was being allocated in R to handle the resultng returned objects. k reset in R code, with warning. (Thanks: Jari Oksanen) * predict.gam() now has "standard" data searching using a model frame based on a fake formula produced from full.formula in the fitted object. However it also warns if newdata is present but incomplete. This means that if newdata does not meet White book specifications, you get a warning, but the function behaves like predict.lm etc. predict.gam had been segfaulting if variables were missing from newdata (Thanks: Andy Liaw and BR) * contour option added to vis.gam * te smooths can be forced to use only a single penalty (theoretical interest only - not recommended for practical use) 1.0-3 * Fixes bugs in handling graphics parameters in plot.gam() * Adds option of partial residuals to plot.gam() 1.0-2/1 * Fixes a bug in evaluating variables of smooths, knots and by-variables. 1.0-0 *** Tensor product smooths - any bases available via s() terms in a gam formula can be used as the basis for tensor product smooths of multiple covariates. A separate wiggliness penalty and smoothing parameter is associated with each `marginal' basis. ** Cyclic smoothers: penalized cubic regression splines which have the same value and first two derivatives at their first and last knots. *** An object oriented approach to handling smooth terms which allows the user to add their own smooths. Smooth terms are constructed using smooth.construct method functions, while predictions from individual smooth terms are handled by predict.matrix method functions. ** p-splines implemented as the illustrative example for the above in the help files. *** A generalized additive mixed model function gamm() with estimation via lme() in the normal-identity case and glmmPQL() otherwise. The main aim of the function is to allow a defensible way of modelling correlated error structures while using a GAM. * The gam object itself has changed to facilitate the above. Most information pertaining to smooth terms is now stored in a list of smooth objects, whose classes depend on the bases used. The objects are not back compatible, and neither are the new method functions. This has been done in an attempt to minimize the scope for bugs, given the amount of time available for maintenance. ** s() no longer supports old stlye (version <0.6) specification of smooths (e.g. s(x,10|f)). This is in order to reduce the scope for problems with user defined smooth classes. * The mgcv() function now has an argument list more similar to magic(). * Function GAMsetup() has been removed. * I've made a general attempt to make the R code a bit less like a simultaneous translation from C. 0.9-5/4/3/2/1 * Mixtures of fixed degree of freedom and estimated degree of freedom smooths did not work correctly with the perf.iter=FALSE option. Fixed. * fx=TRUE not handled correctly by fit.method="magic": fixed. * some fixes to GAMsetup and gam documentation. * call re-instated to the fitted gam object to allow updating * -Wall and -pedantic removed from Makevars as they are gcc specific. * isolated call to Stop() replaced by call to stop()! 0.9-0 *** There is a new underlying smoothing parameter selection method, based on pivoted QR decomposition and SVD methods implemented in LAPACK. The method is more stable than the Wood (2000) method and allows the user to fix some smoothing parameters while estimating others, regularize the GAM fit in non-convergent cases and put lower bounds on smoothing parameters. The new method can deal with rank deficient problems, for example if there is a lack of identifiability between the parametric and smooth parts of the model. See ?magic for fuller details. The old method is still available, but gam() defaults to the new method. * Note that the new method calls LAPACK routines directly, which means that the package now depends on external linear algebra libraries, rather than relying entirely on my linear algebra routines. This is a good thing in terms of numerical robustness and speed, but does mean that to install the package from source you need a BLAS library installed and accesible to the linker. If you sucessfully installed R by building from source then you should have no problem: you have everything already installed, but occasionally users may have to install ATLAS in order to install from source. * Negative binomial GAMs now use the families supplied by the MASS library and employ a fast integrated GCV based method for estiamting the negative binomial parameter. See ?gam.neg.bin for details. The new method seems to converge slightly more often than the old method, and does so more quickly. * persp.gam() has been replaced by a new routine vis.gam() which is prettier, simpler and deals better with factor covariates and at all with `by' variables. * NA's can now be handled properly in a manner consistent with lm() and glm() [thanks to Brian Ripley for pointing me in the right direction here] and there is some internal tidying of GAM so that it's behavious is more similar to glm() and lm(). * Users can now choose to `polish' gam model fits by adding an nlm() based optimization after the usual Gu (2002) style `power iteration' to find smoothing parameters. This second stage will typically result in a slightly lower final GCV/UBRE score than the defualt method, but is much slower. See ?gam.control for more information. * The option to add a ridge penalty to the GAM fitting objective has been added to help deal with some convergence issues that occur when the linear predictor is essentially un-identifiable. see ?gam.control. 0.8-7 * There was a bug in the calculation of identifiability side conditions that could lead to over constraint of smooths using `by' variables in models with mixtures of smooths of different numbers of variables. This has been fixed. 0.8-6 * Fixes a bug which occured with user supplied smoothing parameters, in which the weight vector was omitted from part of the influence (hat) matrix calculation. This could result in non-sensical variance estimates. * Stronger consistency checks introduced on estimated degrees of freedom. 0.8-5 * mgcv was using Machine() which is deprecated from R 1.6.0, this version uses .Machine instead. 0.8-4 * There was a memory bug which could occur with the "cr" basis, in which un-allocated memory was written to in the tps_g() routine in the compiled C code - this occured when that routine was asked to clean up its memory, when there was nothing to clean up. Thanks to Luke Tierney for finding this problem and locating it to tps_g()! * A very minor memory leak which occured when knots are used to start a tps basis was fixed. 0.8-3 * Elements on leading diagonal of Hat/Influence matrix are now returned in gam object. * Over-zealous error trap introduced at 0.8-2, caused failure with smoothless models. 0.8-2 * User can now supply smoothing parameters for all smooth terms (can't have a mixture of supplied and estimated smoothing parameters). Feature is useful if e.g. GCV/UBRE fails to produce sensible estimates. * svd() replaced by La.svd() in summary.gam(). * a bug in the Lanczos iteration code meant that smooths behaved poorly if the smooth had exactly one less degree of freedom than the number of data (the wrong eigenvectors were retained in this case) - this was a rather rare bug in practice! * pcls() was not using sensible tolerances and svdroot() was using tolerances incorrectly, leading to problems with pcls(), now fixed. * prior weights were missing from the pearson residuals. * Faulty by variable documentation fixed (have lost name of person who let me know this, but thanks!) * Scale factor removed from Pearson residual calculation for consistancy with a higher proportion of authors. * The proportion deviance explained has been added to summary.gam() as a better measure than r-squared in most cases. * Routine SANtest() has been removed (obsolete). * A bug in the select option of plot.gam has been fixed. 0.8-1 * The GCV/UBRE score can develop phantom minima for some models: these are minima in the score for the IRLS problem which suggest large parameter changes, but which disappear if those large changes are actually made. This problem occurs in some logistic regression models. To aid convergence in such cases, gam.fit now switches to a cautious mgcv optimization method if convergence has not been obtained in a user defined number of iterations. The cautious mode selects the local minimum of the GCV/UBRE closest to the previous minimum if multiple minima are present. See gam.control for details about controlling iterations. * Option trace in gam.control now prints and plots more useful information for diagnosing convergence problems. * The one explicit formation of an inverse in the underlying multiple GCV optimization has been replaced with something more stable (and quicker). * A bug in the calculation of side conditions has been fixed - this caused a failure with models having parametric terms and terms like: s(x)+s(z)+s(z,x). * A bug whereby predict.gam simply failed to pick up offset terms has been fixed. * gam() now drops unused levels in factors. * A bug in the conversion of svd convergence criteria between version 0.7-2 and 0.8-0 has been fixed. * Memory leaks have been removed from the C code (thanks to the superb dmalloc library). * A bug that caused an undignified exit when 1-d smoothing with full splines in 0.8-0 has been fixed. 0.8-0 * There was a problem on some platforms resulting from the default compiler optimizations used by R. Specifically: floating point registers can be used to store local variables. If the register is larger than a double (as is the case for Intel 486 and up), this means that: double a,b; a=b; if (a==b) can evaluate as FALSE. The mgcv source code assumed that this could never happen (it wouldn't under strict ieee fp compliance, for example). As a result, for some models using the package compiled using some compiler versions, the one dimensional "overall" smoothing parameter search could fail, resulting in convergence failure, or undersmoothing. The Windows version from CRAN was OK, but versions installed under Linux could have problems. Version 0.8 does not make the problematic assumption. * The search for the optimal overall smoothing parameter has been improved, providing better protection against local minima in the GCV/UBRE score. * Extra GCV/UBRE diagnostics are provided, along with a function gam.check() for checking them. * It is now possible for the user to supply "knots" to be used when producing the t.p.r.s. basis, or for the cubic regression spline basis. This makes it feasible to work with very large datasets using the of the data. It also provides a mechanism for obtaining purely "knot based" thin plate regression splines. * A new mechanism is provided for allowing a smooth term to be multiplied by a covariate within the model. Such "by" variables allow smooths to be conditional on factors, for example. * Formulae such as y~s(x)+s(z)+s(x,z) can now be used. * The package now reports the UBRE score of a fitted model if UBRE was used for smoothing parameter selection, and the GCV score otherwise. * A new help page gam.models has been added. * A bug whereby offsets in model formulae only worked if they were at the end of the formulae has been fixed. * A bug whereby weights could not be supplied in the model data frame has been fixed. * gam.fit has been upgraded using the R 1.5.0 version of glm.fit * An error in the documentaion of xp in the gam object has been fixed, in addition to numerous other changes to the documentation. * The scoping rules employed by gam() have been brought into line with lm() and glm by searching for variables in the environment of the model formula rather than in the environment from which gam() was called - usually these are the same, but not always. * A bug in persp.gam() has been fixed, whereby slice information had to be supplied in a particular order. * All compiled code calls now specify package mgcv to avoid any possibility of calling the wrong function. * All examples now set the random number generator seed to facilitate cross platform comparisons. 0.7-2 * T and F changed to TRUE and FALSE in code and examples. * Minor predict.gam error fixed (didn't get correct fitted values if called without new data and model contained multi-dimensional smooths). 0.7-1 * There was a somewhat over-zealous warning message in the single smoothing parameter selection code - gave a warning everytime that GCV suggested a smoothing parameter at the boundary of the search interval - even if this GCV function was also flat. Fixed. * The search range for 1-d smoothing parameter selection was too wide - it was possible to give so little weight to the data that numerical problems caused all parameters to be estimates as zero (along with the edf for the term!). The range has been narrowed to something more sensible [above warning should still be triggered if it is ever too narrow - but this should not be possible]. * summary.gam() documentation extended a bit. p-values for smooths are slightly improved, and an example included that shows the user how to check them! 0.7-0 * The underlying multiple GCV/UBRE optimization method has been considereably strengthened, as follows: o First and second guess starting values for the relative smoothing parameters have been improved. o Steepest descent is used if either: i) the Hessian of the objective is not positive definite, or (ii) Steps in the Newton direction fails to improve the GCV/UBRE score after 4 step halvings (since in this case the quadratic model is clearly poor). o Newton steps are rescaled so that the largest step component (in log relative smoothing parameters) is of size 5 if any step components are >5. This avoids very large Newton steps that can occur in flat regions of the objective. o All steepest descent steps are initially scaled so that their longest component is 1, this avoids long steps into flat regions of the objective. o MGCV Convergence diagnostics are returned from routines mgcv and gam. o In gam.fit() smoothing parameters are re-auto-initialized during IRLS if they have become so far apart that some are likely to be in flat parts of the GCV/UBRE score. o A bug whereby poor second guesses at relative smoothing parameters could lead to acceptance of the first guess at these parameters has been removed. o The user is warned if the initial smoothing parameter guesses are not improved upon (can happen legitmately if all s.p.s should be very high or very low.) The end result of these changes is to make fits from gam much more reliable (particularly when using the tprs basis available from version 0.6). * A summary.gam and associated print function are provided. These provide approximate p-values for all model terms. * plot.gam now provides a mechanism for selecting single plots, and allows jittering of rug plots. * A bug that prevented models with no smooth terms from being fitted has been removed. * A scoping bug in gam.setup has been fixed. * A bug preventing certain mixtures of the bases to be used has been fixed. * The neg.bin family has been renamed neg.binom to avoid masking a function in the MASS library. 0.6-2 revisions from 0.6.1 * Relatively important fix in low level numerics. Under some circumstances the Lanczos routines used to find the thin plate regression spline basis could fail to converge or give wrong answers (many thanks to Charles Paxton for spotting this). The problem was with an insufficiently stable inverse iteration scheme used to find eigenvectors as part of the Lanczos scheme. The scheme had been used because it was very fast: unfortuantely stabilizing it is as computationally costly as simply accumulating eigen-vectors with the eigen-values - hence the latter has now been done. Some further examples also added. 0.6-1 * Junk files removed from src directory. * 3 C++ style comments removed from tprs.c. 0.6-0 * Multi-dimesional smoothing is now available, using "thin plate regression splines" (MS submitted). These are based on optimal approximations to the thin-plate splines. * gam formula syntax upgraded (see ?s ). Old syntax still works, with the exception that if no df specified then the tprs basis is always used by default. * plot.gam can now deal with two dimensional smooth terms as well as one dimensional smooths. * persp.gam added to allow user to visualize slices through a gam [Mike Lonergan] * negative binomial family added [Mike Lonergan] - not quite as robust as rest of families though [can have convergence problems]. * predict.gam now has an option to return the matrix mapping the parameters to the linear predictor at the supplied covariate values. * Variance calculation has been made more robust. * Routine pcls added, for penalized, linearly constrained optimization (e.g. monotonic splines). * Residual method provided (there was a bug in the default - Thanks Carmen Fernandez). * The cubic regression spline basis behaved wrongly when extrapolating [thanks Sharon Hedley]. This is now fixed. * Tests included to check that there are enough unique covariate combinations to support the users choise of smoothing basis dimension. * Internal storage improved so that large numbers of zeroes are no longer stored in arrays of matrices. * Some method argument lists brought into line with the R default versions. 0.5 * There was a bug in gam.fit(). The square roots of the correct iterative weights were being used in place of the weights: the bug was apparent because the sum of fitted values didn't always equal the sum of the response data when using the canonical link (which it should as a result of X'f=X'y when canonical link used and unpenalized). The bug has been corrected, and the correction tested. This problem did not affect (unweighted) additive models, only generalized additive models. * There was a bug that caused a crash in the compiled code when there were more than 8000 datapoints to fit. This has been fixed. * The package now reports its version number when loaded into R. * predict.gam() now returns predictions for the original covariate values (used to fit the model) when called without new data. * predict.gam() now allows type="response" as an argument - returning predictions on the scale of the response variable. * plot.gam() no-longer defaults to automatic page layout, use argument pages=1 to get the old default behaviour. * A bug that could cause a crash with the model formula y~s(x)-1 has been fixed. * Yet more sloppy practices are now allowed for naming variables in model formulae. e.g. d$y ~ s(d$x) now works, although its not recommended. * The GCV score is now reported by print.gam() (whether or not GCV was actually used - it isn't the default for Poisson or binomial). * plot.gam() modified to avoid prompting for input when not used interactively. 0.4 * Transformations allowed on lhs of gam formulae . * Argument order same as Splus gam. * Search for data now designed to be like lm() , so you can now be quite sloppy about where your data are. * The above mean that Venables and Ripley examples can be run without having to read the documentation for gam() so carefully! * A bug in the standard error calculations for parametric terms in predict.gam() is fixed. * A serious bug in the handling of factors was fixed - it was previously possible to obtain a rank deficient design matrix when using factors, despite having specified an identifiable model. * Some glitches when dealing with formulae containing offset() and/or I() have been fixed. * Fitting defaults can now be altered using gam.control when calling gam() 0.3-3 * Documentation updated, including removal of wrong information about constraints and mgcv . Also some readability changes in code and no smooths are now allowed. 0.3-2/1 * Allows all ways of specifying a family that glm() allows (previously family=poisson or family="poisson" would fail). Some more documentation fixes. * 0.2 lost the end of long formulae (because of a difference in the way that R and Splus deal with formulae). This is now fixed. * A minor error that meant that QT() failed under some versions of Windows is now fixed. * All package functions now have help(). Also the help files have been more carefully checked - version 0.2 actually contained no information on how to write a GAM formula as a result of a single missing '}' in the help file! 0.2 * Fixed d.f. regression splines allowed as part of gam() model specification. * Bug in knot placement algorithm fixed (caused crash with df close to number of data). * Replicate covariate values dealt with properly in gam()! * Data search method in gam() revised - now looks in frame from which gam() called. * plot.gam() can now deal with missing variance estimates gracefully. * Low (1,2) d.f. smooths dealt with gracefully by gam() - no longer cause freeze or crash. * Confidence intervals simulation tested for normal(identity), poisson(log), binomial(logit) and gamma(log) cases. Average coverage probabilities from 0.89 to 0.97 term by term, 0.93 to 0.96 "across the model", for nominal 0.95. * R documentation updated and tidied. mgcv/man/0000755000177400001440000000000013046054035012153 5ustar murdochusersmgcv/man/notExp2.Rd0000744000177400001440000000633012632334033014003 0ustar murdochusers\name{notExp2} \alias{notExp2} \alias{notLog2} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Alternative to log parameterization for variance components} \description{ \code{notLog2} and \code{notExp2} are alternatives to \code{log} and \code{exp} or \code{\link{notLog}} and \code{\link{notExp}} for re-parameterization of variance parameters. They are used by the \code{\link{pdTens}} and \code{\link{pdIdnot}} classes which in turn implement smooths for \code{\link{gamm}}. The functions are typically used to ensure that smoothing parameters are positive, but the \code{notExp2} is not monotonic: rather it cycles between `effective zero' and `effective infinity' as its argument changes. The \code{notLog2} is the inverse function of the \code{notExp2} only over an interval centered on zero. Parameterizations using these functions ensure that estimated smoothing parameters remain positive, but also help to ensure that the likelihood is never indefinite: once a working parameter pushes a smoothing parameter below `effetive zero' or above `effective infinity' the cyclic nature of the \code{notExp2} causes the likelihood to decrease, where otherwise it might simply have flattened. This parameterization is really just a numerical trick, in order to get \code{lme} to fit \code{gamm} models, without failing due to indefiniteness. Note in particular that asymptotic results on the likelihood/REML criterion are not invalidated by the trick, unless parameter estimates end up close to the effective zero or effective infinity: but if this is the case then the asymptotics would also have been invalid for a conventional monotonic parameterization. This reparameterization was made necessary by some modifications to the underlying optimization method in \code{lme} introduced in nlme 3.1-62. It is possible that future releases will return to the \code{\link{notExp}} parameterization. Note that you can reset `effective zero' and `effective infinity': see below. } \usage{ notExp2(x,d=.Options$mgcv.vc.logrange,b=1/d) notLog2(x,d=.Options$mgcv.vc.logrange,b=1/d) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{Argument array of real numbers (\code{notExp}) or positive real numbers (\code{notLog}).} \item{d}{the range of \code{notExp2} runs from \code{exp(-d)} to \code{exp(d)}. To change the range used by \code{gamm} reset \code{mgcv.vc.logrange} using \code{\link{options}}.} \item{b}{determines the period of the cycle of \code{notExp2}.} } \value{ An array of function values evaluated at the supplied argument values.} \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \seealso{ \code{\link{pdTens}}, \code{\link{pdIdnot}}, \code{\link{gamm}}} \examples{ ## Illustrate the notExp2 function: require(mgcv) x <- seq(-50,50,length=1000) op <- par(mfrow=c(2,2)) plot(x,notExp2(x),type="l") lines(x,exp(x),col=2) plot(x,log(notExp2(x)),type="l") lines(x,log(exp(x)),col=2) # redundancy intended x <- x/4 plot(x,notExp2(x),type="l") lines(x,exp(x),col=2) plot(x,log(notExp2(x)),type="l") lines(x,log(exp(x)),col=2) # redundancy intended par(op) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/gamSim.Rd0000744000177400001440000000321012632334033013653 0ustar murdochusers\name{gamSim} \alias{gamSim} %- Also NEED an `\alias' for EACH other topic documented here. \title{Simulate example data for GAMs} \description{ Function used to simulate data sets to illustrate the use of \code{\link{gam}} and \code{\link{gamm}}. Mostly used in help files to keep down the length of the example code sections. } \usage{gamSim(eg=1,n=400,dist="normal",scale=2,verbose=TRUE)} %- maybe also `usage' for other objects documented here. \arguments{ \item{eg}{ numeric value specifying the example required.} \item{n}{ number of data to simulate.} \item{dist}{character string which may be used to spcify the distribution of the response.} \item{scale}{Used to set noise level.} \item{verbose}{Should information about simulation type be printed?} } \details{See the source code for exactly what is simulated in each case. \enumerate{ \item{Gu and Wahba 4 univariate term example.} \item{A smooth function of 2 variables.} \item{Example with continuous by variable.} \item{Example with factor by variable.} \item{An additive example plus a factor variable.} \item{Additive + random effect.} \item{As 1 but with correlated covariates.} } } \value{ Depends on \code{eg}, but usually a dataframe, which may also contain some information on the underlying truth. Sometimes a list with more items, including a data frame for model fitting. See source code or helpfile examples where the function is used for further information.} \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gam}}, \code{\link{gamm}}} \examples{ ## see ?gam } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/ldTweedie.Rd0000744000177400001440000001123012726504232014351 0ustar murdochusers\name{ldTweedie} \alias{ldTweedie} %- Also NEED an `\alias' for EACH other topic documented here. \title{Log Tweedie density evaluation} \description{A function to evaluate the log of the Tweedie density for variance powers between 1 and 2, inclusive. Also evaluates first and second derivatives of log density w.r.t. its scale parameter, \code{phi}, and \code{p}, or w.r.t. \code{rho=log(phi)} and \code{theta} where \code{p = (a+b*exp(theta))/(1+exp(theta))}. } \usage{ ldTweedie(y,mu=y,p=1.5,phi=1,rho=NA,theta=NA,a=1.001,b=1.999,all.derivs=FALSE) } \arguments{ \item{y}{values at which to evaluate density.} \item{mu}{corresponding means (either of same length as \code{y} or a single value).} \item{p}{the variance of \code{y} is proportional to its mean to the power \code{p}. \code{p} must be between 1 and 2. 1 is Poisson like (exactly Poisson if \code{phi=1}), 2 is gamma. } \item{phi}{The scale parameter. Variance of \code{y} is \code{phi*mu^p}.} \item{rho}{optional log scale parameter. Over-rides \code{phi} if \code{theta} also supplied.} \item{theta}{parameter such that \code{p = (a+b*exp(theta))/(1+exp(theta))}. Over-rides \code{p} if \code{rho} also supplied.} \item{a}{lower limit parameter (>1) used in definition of \code{p} from \code{theta}.} \item{b}{upper limit parameter (<2) used in definition of \code{p} from \code{theta}.} \item{all.derivs}{if \code{TRUE} then derivatives w.r.t. \code{mu} are also returned. Only available with \code{rho} and \code{phi} parameterization.} } \value{ A matrix with 6 columns, or 10 if \code{all.derivs=TRUE}. The first is the log density of \code{y} (log probability if \code{p=1}). The second and third are the first and second derivatives of the log density w.r.t. \code{phi}. 4th and 5th columns are first and second derivative w.r.t. \code{p}, final column is second derivative w.r.t. \code{phi} and \code{p}. If \code{rho} and \code{theta} were supplied then derivatives are w.r.t. these. In this case, and if \code{all.derivs=TRUE} then the 7th colmn is the derivative w.r.t. \code{mu}, the 8th is the 2nd derivative w.r.t. \code{mu}, the 9th is the mixed derivative w.r.t. \code{theta} and\code{mu} and the 10th is the mixed derivative w.r.t. \code{rho} and \code{mu}. } \details{ A Tweedie random variable with 11.1 is OK y <- seq(1e-10,10,length=1000) p <- c(1.0001,1.001,1.01,1.1,1.2,1.5,1.8,2) phi <- .5 fy <- exp(ldTweedie(y,mu=2,p=p[1],phi=phi)[,1]) plot(y,fy,type="l",ylim=c(0,3),main="Tweedie density as p changes") for (i in 2:length(p)) { fy <- exp(ldTweedie(y,mu=2,p=p[i],phi=phi)[,1]) lines(y,fy,col=i) } } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/spasm.construct.Rd0000644000177400001440000000217312632334033015612 0ustar murdochusers \name{spasm.construct} \alias{spasm.construct} \alias{spasm.sp} \alias{spasm.smooth} %- Also NEED an `\alias' for EACH other topic documented here. \title{Experimental sparse smoothers} \description{These are experimental sparse smoothing functions, and should be left well alone! } \usage{ spasm.construct(object,data) spasm.sp(object,sp,w=rep(1,object$nobs),get.trH=TRUE,block=0,centre=FALSE) spasm.smooth(object,X,residual=FALSE,block=0) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{sparse smooth object} \item{data}{data frame} \item{sp}{smoothing parameter value} \item{w}{optional weights} \item{get.trH}{Should (estimated) trace of sparse smoother matrix be returned} \item{block}{index of block, 0 for all blocks} \item{centre}{should sparse smooth be centred?} \item{X}{what to smooth} \item{residual}{apply residual operation?} } %\value{} %\details{} %\references{} \author{Simon N. Wood \email{simon.wood@r-project.org}} %\seealso{} \section{WARNING}{It is not recommended to use these yet} %\examples{} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/te.Rd0000744000177400001440000003063412777126036013074 0ustar murdochusers\name{te} \alias{te}\alias{ti} %- Also NEED an `\alias' for EACH other topic documented here. \title{Define tensor product smooths or tensor product interactions in GAM formulae} \description{ Functions used for the definition of tensor product smooths and interactions within \code{gam} model formulae. \code{te} produces a full tensor product smooth, while \code{ti} produces a tensor product interaction, appropriate when the main effects (and any lower interactions) are also present. The functions do not evaluate the smooth - they exists purely to help set up a model using tensor product based smooths. Designed to construct tensor products from any marginal smooths with a basis-penalty representation (with the restriction that each marginal smooth must have only one penalty). } \usage{te(..., k=NA,bs="cr",m=NA,d=NA,by=NA,fx=FALSE, mp=TRUE,np=TRUE,xt=NULL,id=NULL,sp=NULL,pc=NULL) ti(..., k=NA,bs="cr",m=NA,d=NA,by=NA,fx=FALSE, np=TRUE,xt=NULL,id=NULL,sp=NULL,mc=NULL,pc=NULL) } %- maybe also `usage' for other objects documented here. \arguments{ \item{...}{ a list of variables that are the covariates that this smooth is a function of. Transformations whose form depends on the values of the data are best avoided here: e.g. \code{te(log(x),z)} is fine, but \code{te(I(x/sd(x)),z)} is not (see \code{\link{predict.gam}}). } \item{k}{ the dimension(s) of the bases used to represent the smooth term. If not supplied then set to \code{5^d}. If supplied as a single number then this basis dimension is used for each basis. If supplied as an array then the elements are the dimensions of the component (marginal) bases of the tensor product. See \code{\link{choose.k}} for further information.} \item{bs}{array (or single character string) specifying the type for each marginal basis. \code{"cr"} for cubic regression spline; \code{"cs"} for cubic regression spline with shrinkage; \code{"cc"} for periodic/cyclic cubic regression spline; \code{"tp"} for thin plate regression spline; \code{"ts"} for t.p.r.s. with extra shrinkage. See \code{\link{smooth.terms}} for details and full list. User defined bases can also be used here (see \code{\link{smooth.construct}} for an example). If only one basis code is given then this is used for all bases.} \item{m}{The order of the spline and its penalty (for smooth classes that use this) for each term. If a single number is given then it is used for all terms. A vector can be used to supply a different \code{m} for each margin. For marginals that take vector \code{m} (e.g. \code{\link{p.spline}} and \code{\link{Duchon.spline}}), then a list can be supplied, with a vector element for each margin. \code{NA} autoinitializes. \code{m} is ignored by some bases (e.g. \code{"cr"}).} \item{d}{array of marginal basis dimensions. For example if you want a smooth for 3 covariates made up of a tensor product of a 2 dimensional t.p.r.s. basis and a 1-dimensional basis, then set \code{d=c(2,1)}. Incompatibilities between built in basis types and dimension will be resolved by resetting the basis type.} \item{by}{a numeric or factor variable of the same dimension as each covariate. In the numeric vector case the elements multiply the smooth evaluated at the corresponding covariate values (a `varying coefficient model' results). In the factor case causes a replicate of the smooth to be produced for each factor level. See \code{\link{gam.models}} for further details. May also be a matrix if covariates are matrices: in this case implements linear functional of a smooth (see \code{\link{gam.models}} and \code{\link{linear.functional.terms}} for details).} \item{fx}{indicates whether the term is a fixed d.f. regression spline (\code{TRUE}) or a penalized regression spline (\code{FALSE}).} \item{mp}{\code{TRUE} to use multiple penalties for the smooth. \code{FALSE} to use only a single penalty: single penalties are not recommended and are deprecated - they tend to allow only rather wiggly models.} \item{np}{ \code{TRUE} to use the `normal parameterization' for a tensor product smooth. This represents any 1-d marginal smooths via parameters that are function values at `knots', spread evenly through the data. The parameterization makes the penalties easily interpretable, however it can reduce numerical stability in some cases.} \item{xt}{Either a single object, providing any extra information to be passed to each marginal basis constructor, or a list of such objects, one for each marginal basis. } \item{id}{A label or integer identifying this term in order to link its smoothing parameters to others of the same type. If two or more smooth terms have the same \code{id} then they will have the same smoothing paramsters, and, by default, the same bases (first occurance defines basis type, but data from all terms used in basis construction).} \item{sp}{any supplied smoothing parameters for this term. Must be an array of the same length as the number of penalties for this smooth. Positive or zero elements are taken as fixed smoothing parameters. Negative elements signal auto-initialization. Over-rides values supplied in \code{sp} argument to \code{\link{gam}}. Ignored by \code{gamm}.} \item{mc}{For \code{ti} smooths you can specify which marginals should have centering constraints applied, by supplying 0/1 or \code{FALSE}/\code{TRUE} values for each marginal in this vector. By default all marginals are constrained, which is what is appropriate for, e.g., functional ANOVA models. Note that \code{'ti'} only applies constraints to the marginals, so if you turn off all marginal constraints the term will have no identifiability constraints. Only use this if you really understand how marginal constraints work. } \item{pc}{If not \code{NULL}, signals a point constraint: the smooth should pass through zero at the point given here (as a vector or list with names corresponding to the smooth names). Never ignored if supplied. See \code{\link{identifiability}}. } } \details{ Smooths of several covariates can be constructed from tensor products of the bases used to represent smooths of one (or sometimes more) of the covariates. To do this `marginal' bases are produced with associated model matrices and penalty matrices, and these are then combined in the manner described in \code{\link{tensor.prod.model.matrix}} and \code{\link{tensor.prod.penalties}}, to produce a single model matrix for the smooth, but multiple penalties (one for each marginal basis). The basis dimension of the whole smooth is the product of the basis dimensions of the marginal smooths. An option for operating with a single penalty (The Kronecker product of the marginal penalties) is provided, but it is rarely of practical use, and is deprecated: the penalty is typically so rank deficient that even the smoothest resulting model will have rather high estimated degrees of freedom. Tensor product smooths are especially useful for representing functions of covariates measured in different units, although they are typically not quite as nicely behaved as t.p.r.s. smooths for well scaled covariates. It is sometimes useful to investigate smooth models with a main-effects + interactions structure, for example \deqn{f_1(x) + f_2(z) + f_3(x,z)}{f_1(x) + f_2(z) + f_3(x,z)} This functional ANOVA decomposition is supported by \code{ti} terms, which produce tensor product interactions from which the main effects have been excluded, under the assumption that they will be included separately. For example the \code{~ ti(x) + ti(z) + ti(x,z)} would produce the above main effects + interaction structure. This is much better than attempting the same thing with \code{s}or \code{te} terms representing the interactions (although mgcv does not forbid it). Technically \code{ti} terms are very simple: they simply construct tensor product bases from marginal smooths to which identifiability constraints (usually sum-to-zero) have already been applied: correct nesting is then automatic (as with all interactions in a GLM framework). The `normal parameterization' (\code{np=TRUE}) re-parameterizes the marginal smooths of a tensor product smooth so that the parameters are function values at a set of points spread evenly through the range of values of the covariate of the smooth. This means that the penalty of the tensor product associated with any particular covariate direction can be interpreted as the penalty of the appropriate marginal smooth applied in that direction and averaged over the smooth. Currently this is only done for marginals of a single variable. This parameterization can reduce numerical stability when used with marginal smooths other than \code{"cc"}, \code{"cr"} and \code{"cs"}: if this causes problems, set \code{np=FALSE}. Note that tensor product smooths should not be centred (have identifiability constraints imposed) if any marginals would not need centering. The constructor for tensor product smooths ensures that this happens. The function does not evaluate the variable arguments. } \value{ A class \code{tensor.smooth.spec} object defining a tensor product smooth to be turned into a basis and penalties by the \code{smooth.construct.tensor.smooth.spec} function. The returned object contains the following items: \item{margin}{A list of \code{smooth.spec} objects of the type returned by \code{\link{s}}, defining the basis from which the tensor product smooth is constructed.} \item{term}{An array of text strings giving the names of the covariates that the term is a function of.} \item{by}{is the name of any \code{by} variable as text (\code{"NA"} for none).} \item{fx}{ logical array with element for each penalty of the term (tensor product smooths have multiple penalties). \code{TRUE} if the penalty is to be ignored, \code{FALSE}, otherwise. } \item{label}{A suitable text label for this smooth term.} \item{dim}{The dimension of the smoother - i.e. the number of covariates that it is a function of.} \item{mp}{\code{TRUE} is multiple penalties are to be used (default).} \item{np}{\code{TRUE} to re-parameterize 1-D marginal smooths in terms of function values (defualt).} \item{id}{the \code{id} argument supplied to \code{te}.} \item{sp}{the \code{sp} argument supplied to \code{te}.} \item{inter}{\code{TRUE} if the term was generated by \code{ti}, \code{FALSE} otherwise.} \item{mc}{the argument \code{mc} supplied to \code{ti}.} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Wood, S.N. (2006a) Low rank scale invariant tensor product smooths for generalized additive mixed models. Biometrics 62(4):1025-1036 \url{http://www.maths.bris.ac.uk/~sw15190/} } \seealso{ \code{\link{s}},\code{\link{gam}},\code{\link{gamm}}, \code{\link{smooth.construct.tensor.smooth.spec}}} \examples{ # following shows how tensor pruduct deals nicely with # badly scaled covariates (range of x 5\% of range of z ) require(mgcv) test1 <- function(x,z,sx=0.3,sz=0.4) { x <- x*20 (pi**sx*sz)*(1.2*exp(-(x-0.2)^2/sx^2-(z-0.3)^2/sz^2)+ 0.8*exp(-(x-0.7)^2/sx^2-(z-0.8)^2/sz^2)) } n <- 500 old.par <- par(mfrow=c(2,2)) x <- runif(n)/20;z <- runif(n); xs <- seq(0,1,length=30)/20;zs <- seq(0,1,length=30) pr <- data.frame(x=rep(xs,30),z=rep(zs,rep(30,30))) truth <- matrix(test1(pr$x,pr$z),30,30) f <- test1(x,z) y <- f + rnorm(n)*0.2 b1 <- gam(y~s(x,z)) persp(xs,zs,truth);title("truth") vis.gam(b1);title("t.p.r.s") b2 <- gam(y~te(x,z)) vis.gam(b2);title("tensor product") b3 <- gam(y~ ti(x) + ti(z) + ti(x,z)) vis.gam(b3);title("tensor anova") ## now illustrate partial ANOVA decomp... vis.gam(b3);title("full anova") b4 <- gam(y~ ti(x) + ti(x,z,mc=c(0,1))) ## note z constrained! vis.gam(b4);title("partial anova") plot(b4) par(old.par) ## now with a multivariate marginal.... test2<-function(u,v,w,sv=0.3,sw=0.4) { ((pi**sv*sw)*(1.2*exp(-(v-0.2)^2/sv^2-(w-0.3)^2/sw^2)+ 0.8*exp(-(v-0.7)^2/sv^2-(w-0.8)^2/sw^2)))*(u-0.5)^2*20 } n <- 500 v <- runif(n);w<-runif(n);u<-runif(n) f <- test2(u,v,w) y <- f + rnorm(n)*0.2 # tensor product of 2D Duchon spline and 1D cr spline m <- list(c(1,.5),rep(0,0)) ## example of list form of m b <- gam(y~te(v,w,u,k=c(30,5),d=c(2,1),bs=c("ds","cr"),m=m)) op <- par(mfrow=c(2,2)) vis.gam(b,cond=list(u=0),color="heat",zlim=c(-0.2,3.5)) vis.gam(b,cond=list(u=.33),color="heat",zlim=c(-0.2,3.5)) vis.gam(b,cond=list(u=.67),color="heat",zlim=c(-0.2,3.5)) vis.gam(b,cond=list(u=1),color="heat",zlim=c(-0.2,3.5)) par(op) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/gam2objective.Rd0000744000177400001440000000436712632334033015175 0ustar murdochusers\name{gam2objective} \alias{gam2objective} \alias{gam2derivative} %- Also NEED an `\alias' for EACH other topic documented here. \title{Objective functions for GAM smoothing parameter estimation} \description{Estimation of GAM smoothing parameters is most stable if optimization of the UBRE/AIC or GCV score is outer to the penalized iteratively re-weighted least squares scheme used to estimate the model given smoothing parameters. These functions evaluate the GCV/UBRE/AIC score of a GAM model, given smoothing parameters, in a manner suitable for use by \code{\link{optim}} or \code{\link{nlm}}. Not normally called directly, but rather service routines for \code{\link{gam.outer}}. } \usage{ gam2objective(lsp,args,...) gam2derivative(lsp,args,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{lsp}{The log smoothing parameters.} \item{args}{List of arguments required to call \code{\link{gam.fit3}}.} \item{...}{Other arguments for passing to \code{gam.fit3}.} } \details{ \code{gam2objective} and \code{gam2derivative} are functions suitable for calling by \code{\link{optim}}, to evaluate the GCV/UBRE/AIC score and its derivatives w.r.t. log smoothing parameters. \code{gam4objective} is an equivalent to \code{gam2objective}, suitable for optimization by \code{\link{nlm}} - derivatives of the GCV/UBRE/AIC function are calculated and returned as attributes. The basic idea of optimizing smoothing parameters `outer' to the P-IRLS loop was first proposed in O'Sullivan et al. (1986). } \references{ Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 O 'Sullivan, Yandall & Raynor (1986) Automatic smoothing of regression functions in generalized linear models. J. Amer. Statist. Assoc. 81:96-103. Wood, S.N. (2008) Fast stable direct fitting and smoothness selection for generalized additive models. J.R.Statist.Soc.B 70(3):495-518 \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{gam.fit3}}, \code{\link{gam}}, \code{\link{magic}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/step.gam.Rd0000744000177400001440000000642312632334033014165 0ustar murdochusers\name{step.gam} \alias{step.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Alternatives to step.gam} \description{ There is no \code{step.gam} in package \code{mgcv}. The \code{mgcv} default for model selection is to use either prediction error criteria such as GCV, GACV, Mallows' Cp/AIC/UBRE or the likelihood based methods of REML or ML. Since the smoothness estimation part of model selection is done in this way it is logically most consistent to perform the rest of model selection in the same way. i.e. to decide which terms to include or omit by looking at changes in GCV, AIC, REML etc. To facilitate fully automatic model selection the package implements two smooth modification techniques which can be used to allow smooths to be shrunk to zero as part of smoothness selection. \describe{ \item{Shrinkage smoothers}{are smoothers in which a small multiple of the identity matrix is added to the smoothing penalty, so that strong enough penalization will shrink all the coefficients of the smooth to zero. Such smoothers can effectively be penalized out of the model altogether, as part of smoothing parameter estimation. 2 classes of these shrinkage smoothers are implemented: \code{"cs"} and \code{"ts"}, based on cubic regression spline and thin plate regression spline smoothers (see \code{\link{s}}) } \item{Null space penalization}{An alternative is to construct an extra penalty for each smooth which penalizes the space of functions of zero wiggliness according to its existing penalties. If all the smoothing parameters for such a term tend to infinity then the term is penalized to zero, and is effectively dropped from the model. The advantage of this approach is that it can be implemented automatically for any smooth. The \code{select} argument to \code{\link{gam}} causes this latter approach to be used. Unpenalized terms (e.g. \code{s(x,fx=TRUE)}) remain unpenalized. } } REML and ML smoothness selection are equivalent under this approach, and simulation evidence suggests that they tend to perform a little better than prediction error criteria, for model selection. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Marra, G. and S.N. Wood (2011) Practical variable selection for generalized additive models Computational Statistics and Data Analysis 55,2372-2387 } \seealso{\code{\link{gam.selection}}} \examples{ ## an example of GCV based model selection as ## an alternative to stepwise selection, using ## shrinkage smoothers... library(mgcv) set.seed(0);n <- 400 dat <- gamSim(1,n=n,scale=2) dat$x4 <- runif(n, 0, 1) dat$x5 <- runif(n, 0, 1) attach(dat) ## Note the increased gamma parameter below to favour ## slightly smoother models... b<-gam(y~s(x0,bs="ts")+s(x1,bs="ts")+s(x2,bs="ts")+ s(x3,bs="ts")+s(x4,bs="ts")+s(x5,bs="ts"),gamma=1.4) summary(b) plot(b,pages=1) ## Same again using REML/ML b<-gam(y~s(x0,bs="ts")+s(x1,bs="ts")+s(x2,bs="ts")+ s(x3,bs="ts")+s(x4,bs="ts")+s(x5,bs="ts"),method="REML") summary(b) plot(b,pages=1) ## And once more, but using the null space penalization b<-gam(y~s(x0,bs="cr")+s(x1,bs="cr")+s(x2,bs="cr")+ s(x3,bs="cr")+s(x4,bs="cr")+s(x5,bs="cr"), method="REML",select=TRUE) summary(b) plot(b,pages=1) detach(dat);rm(dat) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/inSide.Rd0000744000177400001440000000472312632334033013663 0ustar murdochusers\name{inSide} \alias{inSide} %- Also NEED an `\alias' for EACH other topic documented here. \title{Are points inside boundary?} \description{ Assesses whether points are inside a boundary. The boundary must enclose the domain, but may include islands. } \usage{ inSide(bnd,x,y) } %- maybe also `usage' for other objects documented here. \arguments{ \item{bnd}{This should have two equal length columns with names matching whatever is supplied in \code{x} and \code{y}. This may contain several sections of boundary separated by \code{NA}. Alternatively \code{bnd} may be a list, each element of which contains 2 columns named as above. See below for details.} \item{x}{x co-ordinates of points to be tested.} \item{y}{y co-ordinates of points to be tested.} } \details{ Segments of boundary are separated by \code{NA}s, or are in separate list elements. The boundary co-ordinates are taken to define nodes which are joined by straight line segments in order to create the boundary. Each segment is assumed to define a closed loop, and the last point in a segment will be assumed to be joined to the first. Loops must not intersect (no test is made for this). The method used is to count how many times a line, in the y-direction from a point, crosses a boundary segment. An odd number of crossings defines an interior point. Hence in geographic applications it would be usual to have an outer boundary loop, possibly with some inner `islands' completely enclosed in the outer loop. The routine calls compiled C code and operates by an exhaustive search for each point in \code{x, y}. } \value{ The function returns a logical array of the same dimension as \code{x} and \code{y}. \code{TRUE} indicates that the corresponding \code{x, y} point lies inside the boundary. } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv) m <- 300;n <- 150 xm <- seq(-1,4,length=m);yn<-seq(-1,1,length=n) x <- rep(xm,n);y<-rep(yn,rep(m,n)) er <- matrix(fs.test(x,y),m,n) bnd <- fs.boundary() in.bnd <- inSide(bnd,x,y) plot(x,y,col=as.numeric(in.bnd)+1,pch=".") lines(bnd$x,bnd$y,col=3) points(x,y,col=as.numeric(in.bnd)+1,pch=".") ## check boundary details ... plot(x,y,col=as.numeric(in.bnd)+1,pch=".",ylim=c(-1,0),xlim=c(3,3.5)) lines(bnd$x,bnd$y,col=3) points(x,y,col=as.numeric(in.bnd)+1,pch=".") } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/qq.gam.Rd0000744000177400001440000001323712632334033013634 0ustar murdochusers\name{qq.gam} \alias{qq.gam} \title{QQ plots for gam model residuals} \description{ Takes a fitted \code{gam} object produced by \code{gam()} and produces QQ plots of its residuals (conditional on the fitted model coefficients and scale parameter). If the model distributional assumptions are met then usually these plots should be close to a straight line (although discrete data can yield marked random departures from this line). } \usage{ qq.gam(object, rep=0, level=.9,s.rep=10, type=c("deviance","pearson","response"), pch=".", rl.col=2, rep.col="gray80", \dots) } \arguments{ \item{object}{ a fitted \code{gam} object as produced by \code{gam()} (or a \code{glm} object).} \item{rep}{How many replicate datasets to generate to simulate quantiles of the residual distribution. \code{0} results in an efficient simulation free method for direct calculation, if this is possible for the object family.} \item{level}{If simulation is used for the quantiles, then reference intervals can be provided for the QQ-plot, this specifies the level. 0 or less for no intervals, 1 or more to simply plot the QQ plot for each replicate generated.} \item{s.rep}{how many times to randomize uniform quantiles to data under direct computation.} \item{type}{what sort of residuals should be plotted? See \code{\link{residuals.gam}}.} \item{pch}{plot character to use. 19 is good.} \item{rl.col}{color for the reference line on the plot.} \item{rep.col}{color for reference bands or replicate reference plots.} \item{...}{extra graphics parameters to pass to plotting functions.} } \details{QQ-plots of the the model residuals can be produced in one of two ways. The cheapest method generates reference quantiles by associating a quantile of the uniform distribution with each datum, and feeding these uniform quantiles into the quantile function associated with each datum. The resulting quantiles are then used in place of each datum to generate approximate quantiles of residuals. The residual quantiles are averaged over \code{s.rep} randomizations of the uniform quantiles to data. The second method is to use direct simulatation. For each replicate, data are simulated from the fitted model, and the corresponding residuals computed. This is repeated \code{rep} times. Quantiles are readily obtained from the empirical distribution of residuals so obtained. From this method reference bands are also computable. Even if \code{rep} is set to zero, the routine will attempt to simulate quantiles if no quantile function is available for the family. If no random deviate generating function family is available (e.g. for the quasi families), then a normal QQ-plot is produced. The routine conditions on the fitted model coefficents and the scale parameter estimate. The plots are very similar to those proposed in Ben and Yohai (2004), but are substantially cheaper to produce (the interpretation of residuals for binary data in Ben and Yohai is not recommended). Note that plots for raw residuals from fits to binary data contain almost no useful information about model fit. Whether the residual is negative or positive is decided by whether the response is zero or one. The magnitude of the residual, given its sign, is determined entirely by the fitted values. In consequence only the most gross violations of the model are detectable from QQ-plots of residuals for binary data. To really check distributional assumptions from residuals for binary data you have to be able to group the data somehow. Binomial models other than binary are ok. } \references{ N.H. Augustin, E-A Sauleaub, S.N. Wood (2012) On quantile quantile plots for generalized linear models Computational Statistics & Data Analysis. 56(8), 2404-2409. M.G. Ben and V.J. Yohai (2004) JCGS 13(1), 36-47. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{choose.k}}, \code{\link{gam}}} \examples{ library(mgcv) ## simulate binomial data... set.seed(0) n.samp <- 400 dat <- gamSim(1,n=n.samp,dist="binary",scale=.33) p <- binomial()$linkinv(dat$f) ## binomial p n <- sample(c(1,3),n.samp,replace=TRUE) ## binomial n dat$y <- rbinom(n,n,p) dat$n <- n lr.fit <- gam(y/n~s(x0)+s(x1)+s(x2)+s(x3) ,family=binomial,data=dat,weights=n,method="REML") par(mfrow=c(2,2)) ## normal QQ-plot of deviance residuals qqnorm(residuals(lr.fit),pch=19,cex=.3) ## Quick QQ-plot of deviance residuals qq.gam(lr.fit,pch=19,cex=.3) ## Simulation based QQ-plot with reference bands qq.gam(lr.fit,rep=100,level=.9) ## Simulation based QQ-plot, Pearson resids, all ## simulated reference plots shown... qq.gam(lr.fit,rep=100,level=1,type="pearson",pch=19,cex=.2) ## Now fit the wrong model and check.... pif <- gam(y~s(x0)+s(x1)+s(x2)+s(x3) ,family=poisson,data=dat,method="REML") par(mfrow=c(2,2)) qqnorm(residuals(pif),pch=19,cex=.3) qq.gam(pif,pch=19,cex=.3) qq.gam(pif,rep=100,level=.9) qq.gam(pif,rep=100,level=1,type="pearson",pch=19,cex=.2) ## Example of binary data model violation so gross that you see a problem ## on the QQ plot... y <- c(rep(1,10),rep(0,20),rep(1,40),rep(0,10),rep(1,40),rep(0,40)) x <- 1:160 b <- glm(y~x,family=binomial) par(mfrow=c(2,2)) ## Note that the next two are not necessarily similar under gross ## model violation... qq.gam(b) qq.gam(b,rep=50,level=1) ## and a much better plot for detecting the problem plot(x,residuals(b),pch=19,cex=.3) plot(x,y);lines(x,fitted(b)) ## alternative model b <- gam(y~s(x,k=5),family=binomial,method="ML") qq.gam(b) qq.gam(b,rep=50,level=1) plot(x,residuals(b),pch=19,cex=.3) plot(b,residuals=TRUE,pch=19,cex=.3) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/mgcv-package.Rd0000744000177400001440000001504312632744017015001 0ustar murdochusers\name{mgcv.package} \alias{mgcv.package} \alias{mgcv-package} \alias{mgcv} \docType{package} \title{Mixed GAM Computation Vehicle with GCV/AIC/REML smoothness estimation and GAMMs by REML/PQL } \description{ \code{mgcv} provides functions for generalized additive modelling (\code{\link{gam}} and \code{\link{bam}}) and generalized additive mixed modelling (\code{\link{gamm}}, and \code{\link{random.effects}}). The term GAM is taken to include any model dependent on unknown smooth functions of predictors and estimated by quadratically penalized (possibly quasi-) likelihood maximization. Available distributions are covered in \code{\link{family.mgcv}} and available smooths in \code{\link{smooth.terms}}. Particular features of the package are facilities for automatic smoothness selection (Wood, 2004, 2011), and the provision of a variety of smooths of more than one variable. User defined smooths can be added. A Bayesian approach to confidence/credible interval calculation is provided. Linear functionals of smooths, penalization of parametric model terms and linkage of smoothing parameters are all supported. Lower level routines for generalized ridge regression and penalized linearly constrained least squares are also available. } \details{ \code{mgcv} provides generalized additive modelling functions \code{\link{gam}}, \code{\link{predict.gam}} and \code{\link{plot.gam}}, which are very similar in use to the S functions of the same name designed by Trevor Hastie (with some extensions). However the underlying representation and estimation of the models is based on a penalized regression spline approach, with automatic smoothness selection. A number of other functions such as \code{\link{summary.gam}} and \code{\link{anova.gam}} are also provided, for extracting information from a fitted \code{\link{gamObject}}. Use of \code{\link{gam}} is much like use of \code{\link{glm}}, except that within a \code{gam} model formula, isotropic smooths of any number of predictors can be specified using \code{\link{s}} terms, while scale invariant smooths of any number of predictors can be specified using \code{\link{te}}, \code{\link{ti}} or \code{\link{t2}} terms. \code{\link{smooth.terms}} provides an overview of the built in smooth classes, and \code{\link{random.effects}} should be refered to for an overview of random effects terms (see also \code{\link{mrf}} for Markov random fields). Estimation is by penalized likelihood or quasi-likelihood maximization, with smoothness selection by GCV, GACV, gAIC/UBRE or (RE)ML. See \code{\link{gam}}, \code{\link{gam.models}}, \code{\link{linear.functional.terms}} and \code{\link{gam.selection}} for some discussion of model specification and selection. For detailed control of fitting see \code{\link{gam.convergence}}, \code{\link{gam}} arguments \code{method} and \code{optimizer} and \code{\link{gam.control}}. For checking and visualization see \code{\link{gam.check}}, \code{\link{choose.k}}, \code{\link{vis.gam}} and \code{\link{plot.gam}}. While a number of types of smoother are built into the package, it is also extendable with user defined smooths, see \code{\link{smooth.construct}}, for example. A Bayesian approach to smooth modelling is used to derive standard errors on predictions, and hence credible intervals (see Marra and Wood, 2012). The Bayesian covariance matrix for the model coefficients is returned in \code{Vp} of the \code{\link{gamObject}}. See \code{\link{predict.gam}} for examples of how this can be used to obtain credible regions for any quantity derived from the fitted model, either directly, or by direct simulation from the posterior distribution of the model coefficients. Approximate p-values can also be obtained for testing individual smooth terms for equality to the zero function, using similar ideas (see Wood, 2013a,b). Frequentist approximations can be used for hypothesis testing based model comparison. See \code{\link{anova.gam}} and \code{\link{summary.gam}} for more on hypothesis testing. For large datasets (that is large n) see \code{\link{bam}} which is a version of \code{\link{gam}} with a much reduced memory footprint. The package also provides a generalized additive mixed modelling function, \code{\link{gamm}}, based on a PQL approach and \code{lme} from the \code{nlme} library (for an \code{lme4} based version, see package \code{gamm4}). \code{gamm} is particularly useful for modelling correlated data (i.e. where a simple independence model for the residual variation is inappropriate). In addition, low level routine \code{\link{magic}} can fit models to data with a known correlation structure. Some underlying GAM fitting methods are available as low level fitting functions: see \code{\link{magic}}. But there is little functionality that can not be more conventiently accessed via \code{\link{gam}} . Penalized weighted least squares with linear equality and inequality constraints is provided by \code{\link{pcls}}. For a complete list of functions type \code{library(help=mgcv)}. See also \code{\link{mgcv.FAQ}}. } \author{ Simon Wood with contributions and/or help from Natalya Pya, Thomas Kneib, Kurt Hornik, Mike Lonergan, Henric Nilsson, Fabian Scheipl and Brian Ripley. Polish translation - Lukasz Daniel; German translation - Chris Leick, Detlef Steuer; French Translation - Philippe Grosjean Maintainer: Simon Wood Part funded by EPSRC: EP/K005251/1 } \references{ These provide details for the underlying mgcv methods, and fuller references to the large literature on which the methods are based. Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 Wood, S.N. (2004) Stable and efficient multiple smoothing parameter estimation for generalized additive models. J. Amer. Statist. Ass. 99:673-686. Marra, G and S.N. Wood (2012) Coverage Properties of Confidence Intervals for Generalized Additive Model Components. Scandinavian Journal of Statistics, 39(1), 53-74. Wood, S.N. (2013a) A simple test for random effects in regression models. Biometrika 100:1005-1010 Wood, S.N. (2013b) On p-values for smooth components of an extended generalized additive model. Biometrika 100:221-228 Wood, S.N. (2006) \emph{Generalized Additive Models: an introduction with R}, CRC Development of mgcv version 1.8 was part funded by EPSRC grants EP/K005251/1 and EP/I000917/1. } \keyword{ package } \keyword{models} \keyword{smooth} \keyword{regression} \examples{ ## see examples for gam and gamm } mgcv/man/notExp.Rd0000744000177400001440000000464112632334033013724 0ustar murdochusers\name{notExp} \alias{notExp} \alias{notLog} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Functions for better-than-log positive parameterization} \description{ It is common practice in statistical optimization to use log-parameterizations when a parameter ought to be positive. i.e. if an optimization parameter \code{a} should be non-negative then we use \code{a=exp(b)} and optimize with respect to the unconstrained parameter \code{b}. This often works well, but it does imply a rather limited working range for \code{b}: using 8 byte doubles, for example, if \code{b}'s magnitude gets much above 700 then \code{a} overflows or underflows. This can cause problems for numerical optimization methods. \code{notExp} is a monotonic function for mapping the real line into the positive real line with much less extreme underflow and overflow behaviour than \code{exp}. It is a piece-wise function, but is continuous to second derivative: see the source code for the exact definition, and the example below to see what it looks like. \code{notLog} is the inverse function of \code{notExp}. The major use of these functions was originally to provide more robust \code{pdMat} classes for \code{lme} for use by \code{\link{gamm}}. Currently the \code{\link{notExp2}} and \code{\link{notLog2}} functions are used in their place, as a result of changes to the nlme optimization routines. } \usage{ notExp(x) notLog(x) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{Argument array of real numbers (\code{notExp}) or positive real numbers (\code{notLog}).} } \value{ An array of function values evaluated at the supplied argument values.} \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \seealso{ \code{\link{pdTens}}, \code{\link{pdIdnot}}, \code{\link{gamm}}} \examples{ ## Illustrate the notExp function: ## less steep than exp, but still monotonic. require(mgcv) x <- -100:100/10 op <- par(mfrow=c(2,2)) plot(x,notExp(x),type="l") lines(x,exp(x),col=2) plot(x,log(notExp(x)),type="l") lines(x,log(exp(x)),col=2) # redundancy intended x <- x/4 plot(x,notExp(x),type="l") lines(x,exp(x),col=2) plot(x,log(notExp(x)),type="l") lines(x,log(exp(x)),col=2) # redundancy intended par(op) range(notLog(notExp(x))-x) # show that inverse works! } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/sdiag.Rd0000755000177400001440000000177012667017033013546 0ustar murdochusers\name{sdiag} \alias{sdiag} \alias{sdiag<-} %- Also NEED an `\alias' for EACH other topic documented here. \title{Extract or modify diagonals of a matrix} \description{ Extracts or modifies sub- or super- diagonals of a matrix. } \usage{ sdiag(A,k=0) sdiag(A,k=0) <- value } %- maybe also `usage' for other objects documented here. \arguments{ \item{A}{a matrix} \item{k}{sub- (negative) or super- (positive) diagonal of a matrix. 0 is the leading diagonal.} \item{value}{single value, or vector of the same length as the diagonal.} } \value{A vector containing the requested diagonal, or a matrix with the requested diagonal replaced by \code{value}. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv) A <- matrix(1:35,7,5) A sdiag(A,1) ## first super diagonal sdiag(A,-1) ## first sub diagonal sdiag(A) <- 1 ## leading diagonal set to 1 sdiag(A,3) <- c(-1,-2) ## set 3rd super diagonal } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/fixDependence.Rd0000644000177400001440000000400612632334033015202 0ustar murdochusers\name{fixDependence} \alias{fixDependence} %- Also NEED an `\alias' for EACH other topic documented here. \title{Detect linear dependencies of one matrix on another} \description{Identifies columns of a matrix \code{X2} which are linearly dependent on columns of a matrix \code{X1}. Primarily of use in setting up identifiability constraints for nested GAMs. } \usage{ fixDependence(X1,X2,tol=.Machine$double.eps^.5,rank.def=0,strict=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{X1}{ A matrix.} \item{X2}{ A matrix, the columns of which may be partially linearly dependent on the columns of \code{X1}.} \item{tol}{The tolerance to use when assessing linear dependence.} \item{rank.def}{If the degree of rank deficiency in \code{X2}, given \code{X1}, is known, then it can be supplied here, and \code{tol} is then ignored. Unused unless positive and not greater than the number of columns in \code{X2}.} \item{strict}{if \code{TRUE} then only columns individually dependent on \code{X1} are detected, if \code{FALSE} then enough columns to make the reduced \code{X2} full rank and independent of \code{X1} are detected.} } \details{ The algorithm uses a simple approach based on QR decomposition: see Wood (2006, section 4.10.2) for details. } \value{ A vector of the columns of \code{X2} which are linearly dependent on columns of \code{X1} (or which need to be deleted to acheive independence and full rank if \code{strict==FALSE}). \code{NULL} if the two matrices are independent. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Wood S.N. (2006) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. } \examples{ library(mgcv) n<-20;c1<-4;c2<-7 X1<-matrix(runif(n*c1),n,c1) X2<-matrix(runif(n*c2),n,c2) X2[,3]<-X1[,2]+X2[,4]*.1 X2[,5]<-X1[,1]*.2+X1[,2]*.04 fixDependence(X1,X2) fixDependence(X1,X2,strict=TRUE) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/gam.control.Rd0000744000177400001440000001546513000352400014664 0ustar murdochusers\name{gam.control} \alias{gam.control} %- Also NEED an `\alias' for EACH other topic documented here. \title{Setting GAM fitting defaults} \description{ This is an internal function of package \code{mgcv} which allows control of the numerical options for fitting a GAM. Typically users will want to modify the defaults if model fitting fails to converge, or if the warnings are generated which suggest a loss of numerical stability during fitting. To change the default choise of fitting method, see \code{\link{gam}} arguments \code{method} and \code{optimizer}. } \usage{ gam.control(nthreads=1,irls.reg=0.0,epsilon = 1e-07, maxit = 200, mgcv.tol=1e-7,mgcv.half=15, trace = FALSE, rank.tol=.Machine$double.eps^0.5, nlm=list(),optim=list(),newton=list(), outerPIsteps=0,idLinksBases=TRUE,scalePenalty=TRUE, keepData=FALSE,scale.est="fletcher",edge.correct=FALSE) } \arguments{ \item{nthreads}{Some parts of some smoothing parameter selection methods (e.g. REML) can use some parallelization in the C code if your R installation supports openMP, and \code{nthreads} is set to more than 1. Note that it is usually better to use the number of physical cores here, rather than the number of hyper-threading cores.} \item{irls.reg}{For most models this should be 0. The iteratively re-weighted least squares method by which GAMs are fitted can fail to converge in some circumstances. For example, data with many zeroes can cause problems in a model with a log link, because a mean of zero corresponds to an infinite range of linear predictor values. Such convergence problems are caused by a fundamental lack of identifiability, but do not show up as lack of identifiability in the penalized linear model problems that have to be solved at each stage of iteration. In such circumstances it is possible to apply a ridge regression penalty to the model to impose identifiability, and \code{irls.reg} is the size of the penalty. } \item{epsilon}{This is used for judging conversion of the GLM IRLS loop in \code{\link{gam.fit}} or \code{\link{gam.fit3}}.} \item{maxit}{Maximum number of IRLS iterations to perform.} \item{mgcv.tol}{The convergence tolerance parameter to use in GCV/UBRE optimization.} \item{mgcv.half}{If a step of the GCV/UBRE optimization method leads to a worse GCV/UBRE score, then the step length is halved. This is the number of halvings to try before giving up.} \item{trace}{Set this to \code{TRUE} to turn on diagnostic output.} \item{rank.tol}{The tolerance used to estimate the rank of the fitting problem.} \item{nlm}{list of control parameters to pass to \code{\link{nlm}} if this is used for outer estimation of smoothing parameters (not default). See details.} \item{optim}{list of control parameters to pass to \code{\link{optim}} if this is used for outer estimation of smoothing parameters (not default). See details.} \item{newton}{list of control parameters to pass to default Newton optimizer used for outer estimation of log smoothing parameters. See details.} \item{outerPIsteps}{The number of performance interation steps used to initialize outer iteration.} \item{idLinksBases}{If smooth terms have their smoothing parameters linked via the \code{id} mechanism (see \code{\link{s}}), should they also have the same bases. Set this to \code{FALSE} only if you are sure you know what you are doing (you should almost surely set \code{scalePenalty} to \code{FALSE} as well in this case).} \item{scalePenalty}{\code{\link{gamm}} is somewhat sensitive to the absolute scaling of the penalty matrices of a smooth relative to its model matrix. This option rescales the penalty matrices to accomodate this problem. Probably should be set to \code{FALSE} if you are linking smoothing parameters but have set \code{idLinkBases} to \code{FALSE}.} \item{keepData}{Should a copy of the original \code{data} argument be kept in the \code{gam} object? Strict compatibility with class \code{glm} would keep it, but it wastes space to do so. } \item{scale.est}{How to estimate the scale parameter for exponential family models estimated by outer iteration. See \code{\link{gam.scale}}.} \item{edge.correct}{With RE/ML smoothing parameter selection in \code{gam} using the default Newton RE/ML optimizer, it is possible to improve inference at the `completely smooth' edge of the smoothing parameter space, by decreasing smoothing parameters until there is a small increase in the negative RE/ML (e.g. 0.02). Set to \code{TRUE} or to a number representing the target increase to use. Only changes the corrected smoothing parameter matrix, \code{Vc}.} } \details{ Outer iteration using \code{newton} is controlled by the list \code{newton} with the following elements: \code{conv.tol} (default 1e-6) is the relative convergence tolerance; \code{maxNstep} is the maximum length allowed for an element of the Newton search direction (default 5); \code{maxSstep} is the maximum length allowed for an element of the steepest descent direction (only used if Newton fails - default 2); \code{maxHalf} is the maximum number of step halvings to permit before giving up (default 30). If outer iteration using \code{\link{nlm}} is used for fitting, then the control list \code{nlm} stores control arguments for calls to routine \code{\link{nlm}}. The list has the following named elements: (i) \code{ndigit} is the number of significant digits in the GCV/UBRE score - by default this is worked out from \code{epsilon}; (ii) \code{gradtol} is the tolerance used to judge convergence of the gradient of the GCV/UBRE score to zero - by default set to \code{10*epsilon}; (iii) \code{stepmax} is the maximum allowable log smoothing parameter step - defaults to 2; (iv) \code{steptol} is the minimum allowable step length - defaults to 1e-4; (v) \code{iterlim} is the maximum number of optimization steps allowed - defaults to 200; (vi) \code{check.analyticals} indicates whether the built in exact derivative calculations should be checked numerically - defaults to \code{FALSE}. Any of these which are not supplied and named in the list are set to their default values. Outer iteration using \code{\link{optim}} is controlled using list \code{optim}, which currently has one element: \code{factr} which takes default value 1e7. } \references{ Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 Wood, S.N. (2004) Stable and efficient multiple smoothing parameter estimation for generalized additive models. J. Amer. Statist. Ass.99:673-686. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{gam}}, \code{\link{gam.fit}}, \code{\link{glm.control}} } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/linear.functional.terms.Rd0000644000177400001440000001546012632334033017213 0ustar murdochusers\name{linear.functional.terms} \alias{linear.functional.terms} \alias{function.predictors} \alias{signal.regression} %- Also NEED an `\alias' for EACH other topic documented here. \title{Linear functionals of a smooth in GAMs} \description{\code{\link{gam}} allows the response variable to depend on linear functionals of smooth terms. Specifically dependancies of the form \deqn{g(\mu_i) = \ldots + \sum_j L_{ij} f(x_{ij}) + \ldots }{g(mu_i) = ... + sum_j L_ij f(x_ij) +...} are allowed, where the \eqn{x_{ij}}{x_ij} are covariate values and the \eqn{L_{ij}}{L_ij} are fixed weights. i.e. the response can depend on the weighted sum of the same smooth evaluated at different covariate values. This allows, for example, for the response to depend on the derivatives or integrals of a smooth (approximated by finite differencing or quadrature, respectively). It also allows dependence on predictor functions (sometimes called `signal regression'). The mechanism by which this is achieved is to supply matrices of covariate values to the model smooth terms specified by \code{\link{s}} or \code{\link{te}} terms in the model formula. Each column of the covariate matrix gives rise to a corresponding column of predictions from the smooth. Let the resulting matrix of evaluated smooth values be F (F will have the same dimension as the covariate matrices). In the absense of a \code{by} variable then these columns are simply summed and added to the linear predictor. i.e. the contribution of the term to the linear predictor is \code{rowSums(F)}. If a \code{by} variable is present then it must be a matrix, L,say, of the same dimension as F (and the covariate matrices), and it contains the weights \eqn{L_{ij}}{L_ij} in the summation given above. So in this case the contribution to the linear predictor is \code{rowSums(L*F)}. Note that if a \eqn{{\bf L1}}{L1} (i.e. \code{rowSums(L)}) is a constant vector, or there is no \code{by} variable then the smooth will automatically be centred in order to ensure identifiability. Otherwise it will not be. Note also that for centred smooths it can be worth replacing the constant term in the model with \code{rowSums(L)} in order to ensure that predictions are automatically on the right scale. When predicting from the model it is not necessary to provide matrix covariate and \code{by} variable values. For example to simply examine the underlying smooth function one would use vectors of covariate values and vector \code{by} variables, with the \code{by} variable and equivalent of \code{L1}, above, set to vectors of ones. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ ### matrix argument `linear operator' smoothing library(mgcv) set.seed(0) ############################### ## simple summation example...# ############################### n<-400 sig<-2 x <- runif(n, 0, .9) f2 <- function(x) 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 x1 <- x + .1 f <- f2(x) + f2(x1) ## response is sum of f at two adjacent x values y <- f + rnorm(n)*sig X <- matrix(c(x,x1),n,2) ## matrix covariate contains both x values b <- gam(y~s(X)) plot(b) ## reconstruction of f plot(f,fitted(b)) ###################################################################### ## multivariate integral example. Function `test1' will be integrated# ## (by midpoint quadrature) over 100 equal area sub-squares covering # ## the unit square. Noise is added to the resulting simulated data. # ## `test1' is estimated from the resulting data using two alternative# ## smooths. # ###################################################################### test1 <- function(x,z,sx=0.3,sz=0.4) { (pi**sx*sz)*(1.2*exp(-(x-0.2)^2/sx^2-(z-0.3)^2/sz^2)+ 0.8*exp(-(x-0.7)^2/sx^2-(z-0.8)^2/sz^2)) } ## create quadrature (integration) grid, in useful order ig <- 5 ## integration grid within square mx <- mz <- (1:ig-.5)/ig ix <- rep(mx,ig);iz <- rep(mz,rep(ig,ig)) og <- 10 ## observarion grid mx <- mz <- (1:og-1)/og ox <- rep(mx,og);ox <- rep(ox,rep(ig^2,og^2)) oz <- rep(mz,rep(og,og));oz <- rep(oz,rep(ig^2,og^2)) x <- ox + ix/og;z <- oz + iz/og ## full grid, subsquare by subsquare ## create matrix covariates... X <- matrix(x,og^2,ig^2,byrow=TRUE) Z <- matrix(z,og^2,ig^2,byrow=TRUE) ## create simulated test data... dA <- 1/(og*ig)^2 ## quadrature square area F <- test1(X,Z) ## evaluate on grid f <- rowSums(F)*dA ## integrate by midpoint quadrature y <- f + rnorm(og^2)*5e-4 ## add noise ## ... so each y is a noisy observation of the integral of `test1' ## over a 0.1 by 0.1 sub-square from the unit square ## Now fit model to simulated data... L <- X*0 + dA ## ... let F be the matrix of the smooth evaluated at the x,z values ## in matrices X and Z. rowSums(L*F) gives the model predicted ## integrals of `test1' corresponding to the observed `y' L1 <- rowSums(L) ## smooths are centred --- need to add in L%*%1 ## fit models to reconstruct `test1'.... b <- gam(y~s(X,Z,by=L)+L1-1) ## (L1 and const are confounded here) b1 <- gam(y~te(X,Z,by=L)+L1-1) ## tensor product alternative ## plot results... old.par<-par(mfrow=c(2,2)) x<-runif(n);z<-runif(n); xs<-seq(0,1,length=30);zs<-seq(0,1,length=30) pr<-data.frame(x=rep(xs,30),z=rep(zs,rep(30,30))) truth<-matrix(test1(pr$x,pr$z),30,30) contour(xs,zs,truth) plot(b) vis.gam(b,view=c("X","Z"),cond=list(L1=1,L=1),plot.type="contour") vis.gam(b1,view=c("X","Z"),cond=list(L1=1,L=1),plot.type="contour") #################################### ## A "signal" regression example...# #################################### rf <- function(x=seq(0,1,length=100)) { ## generates random functions... m <- ceiling(runif(1)*5) ## number of components f <- x*0; mu <- runif(m,min(x),max(x));sig <- (runif(m)+.5)*(max(x)-min(x))/10 for (i in 1:m) f <- f+ dnorm(x,mu[i],sig[i]) f } x <- seq(0,1,length=100) ## evaluation points ## example functional predictors... par(mfrow=c(3,3));for (i in 1:9) plot(x,rf(x),type="l",xlab="x") ## simulate 200 functions and store in rows of L... L <- matrix(NA,200,100) for (i in 1:200) L[i,] <- rf() ## simulate the functional predictors f2 <- function(x) { ## the coefficient function (0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10)/10 } f <- f2(x) ## the true coefficient function y <- L\%*\%f + rnorm(200)*20 ## simulated response data ## Now fit the model E(y) = L\%*\%f(x) where f is a smooth function. ## The summation convention is used to evaluate smooth at each value ## in matrix X to get matrix F, say. Then rowSum(L*F) gives E(y). ## create matrix of eval points for each function. Note that ## `smoothCon' is smart and will recognize the duplication... X <- matrix(x,200,100,byrow=TRUE) b <- gam(y~s(X,by=L,k=20)) par(mfrow=c(1,1)) plot(b,shade=TRUE);lines(x,f,col=2) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/cSplineDes.Rd0000744000177400001440000000365412706605150014506 0ustar murdochusers\name{cSplineDes} \alias{cSplineDes} %- Also NEED an `\alias' for EACH other topic documented here. \title{Evaluate cyclic B spline basis} \description{ Uses \code{splineDesign} to set up the model matrix for a cyclic B-spline basis. } \usage{ cSplineDes(x, knots, ord = 4, derivs=0) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{ covariate values for smooth.} \item{knots}{The knot locations: the range of these must include all the data.} \item{ord}{ order of the basis. 4 is a cubic spline basis. Must be >1.} \item{derivs}{ order of derivative of the spline to evaluate, between 0 and \code{ord}-1. Recycled to length of \code{x}. } } \details{ The routine is a wrapper that sets up a B-spline basis, where the basis functions wrap at the first and last knot locations.} \value{ A matrix with \code{length(x)} rows and \code{length(knots)-1} columns. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{cyclic.p.spline}}} \examples{ require(mgcv) ## create some x's and knots... n <- 200 x <- 0:(n-1)/(n-1);k<- 0:5/5 X <- cSplineDes(x,k) ## cyclic spline design matrix ## plot evaluated basis functions... plot(x,X[,1],type="l"); for (i in 2:5) lines(x,X[,i],col=i) ## check that the ends match up.... ee <- X[1,]-X[n,];ee tol <- .Machine$double.eps^.75 if (all.equal(ee,ee*0,tolerance=tol)!=TRUE) stop("cyclic spline ends don't match!") ## similar with uneven data spacing... x <- sort(runif(n)) + 1 ## sorting just makes end checking easy k <- seq(min(x),max(x),length=8) ## create knots X <- cSplineDes(x,k) ## get cyclic spline model matrix plot(x,X[,1],type="l"); for (i in 2:ncol(X)) lines(x,X[,i],col=i) ee <- X[1,]-X[n,];ee ## do ends match?? tol <- .Machine$double.eps^.75 if (all.equal(ee,ee*0,tolerance=tol)!=TRUE) stop("cyclic spline ends don't match!") } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/formXtViX.Rd0000744000177400001440000000350712632334033014355 0ustar murdochusers\name{formXtViX} \alias{formXtViX} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Form component of GAMM covariance matrix} \description{ This is a service routine for \code{\link{gamm}}. Given, \eqn{V}{V}, an estimated covariance matrix obtained using \code{\link{extract.lme.cov2}} this routine forms a matrix square root of \eqn{ X^TV^{-1}X}{X'inv(V)X} as efficiently as possible, given the structure of \eqn{V}{V} (usually sparse). } \usage{ formXtViX(V,X) } %- maybe also `usage' for other objects documented here. \arguments{ \item{V}{ A data covariance matrix list returned from \code{\link{extract.lme.cov2}}} \item{X}{ A model matrix.} } \details{ The covariance matrix returned by \code{\link{extract.lme.cov2}} may be in a packed and re-ordered format, since it is usually sparse. Hence a special service routine is required to form the required products involving this matrix. } \value{ A matrix, R such that \code{crossprod(R)} gives \eqn{ X^TV^{-1}X}{X'inv(V)X}. } \references{ For \code{lme} see: Pinheiro J.C. and Bates, D.M. (2000) Mixed effects Models in S and S-PLUS. Springer For details of how GAMMs are set up for estimation using \code{lme} see: Wood, S.N. (2006) Low rank scale invariant tensor product smooths for Generalized Additive Mixed Models. Biometrics 62(4):1025-1036 \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gamm}}, \code{\link{extract.lme.cov2}} } \examples{ require(mgcv) library(nlme) data(ergoStool) b <- lme(effort ~ Type, data=ergoStool, random=~1|Subject) V1 <- extract.lme.cov(b, ergoStool) V2 <- extract.lme.cov2(b, ergoStool) X <- model.matrix(b, data=ergoStool) crossprod(formXtViX(V2, X)) t(X)%*%solve(V1,X) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/ls.size.Rd0000644000177400001440000000156612632334033014040 0ustar murdochusers\name{ls.size} \alias{ls.size} %- Also NEED an `\alias' for EACH other topic documented here. \title{Size of list elements} \description{Produces a named array giving the size, in bytes, of the elements of a list. } \usage{ ls.size(x) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{ A list.} } \value{ A numeric vector giving the size in bytes of each element of the list \code{x}. The elements of the array have the same names as the elements of the list. If \code{x} is not a list then its size in bytes is returned, un-named. } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \examples{ library(mgcv) b <- list(M=matrix(runif(100),10,10),quote= "The world is ruled by idiots because only an idiot would want to rule the world.", fam=binomial()) ls.size(b) } mgcv/man/trind.generator.Rd0000644000177400001440000000262213037405564015560 0ustar murdochusers\name{trind.generator} \alias{trind.generator} \title{Generates index arrays for upper triangular storage} \usage{ trind.generator(K = 2) } \arguments{ \item{K}{positive integer determining the size of the array.} } \value{ A list where the entries \code{i1} to \code{i4} are arrays in up to four dimensions, containing K indexes along each dimension. } \description{ Generates index arrays for upper triangular storage up to order four. Useful when working with higher order derivatives, which generate symmetric arrays. Mainly intended for internal use. } \details{ Suppose that \code{m=1} and you fill an array using code like \code{for(i in 1:K) for(j in i:K) for(k in j:K) for(l in k:K) {a[,m] <- something; m <- m+1 }} and do this because actually the same "something" would be stored for any permutation of the indices i,j,k,l. Clearly in storage we have the restriction l>=k>=j>=i, but for access we want no restriction on the indices. \code{i4[i,j,k,l]} produces the appropriate \code{m} for unrestricted indices. \code{i3} and {i2} do the same for 3d and 2d arrays. } \examples{ library(mgcv) A <- trind.generator(3) # All permutations of c(1, 2, 3) point to the same index (5) A$i3[1, 2, 3] A$i3[2, 1, 3] A$i3[2, 3, 1] A$i3[3, 1, 2] A$i3[1, 3, 2] } \author{ Simon N. Wood . } mgcv/man/full.score.Rd0000644000177400001440000000262112632334033014516 0ustar murdochusers\name{full.score} \alias{full.score} %- Also NEED an `\alias' for EACH other topic documented here. \title{GCV/UBRE score for use within nlm} \description{ Evaluates GCV/UBRE score for a GAM, given smoothing parameters. The routine calls \code{\link{gam.fit}} to fit the model, and is usually called by \code{\link{nlm}} to optimize the smoothing parameters. This is basically a service routine for \code{\link{gam}}, and is not usually called directly by users. It is only used in this context for GAMs fitted by outer iteration (see \code{\link{gam.outer}}) when the the outer method is \code{"nlm.fd"} (see \code{\link{gam}} argument \code{optimizer}). } \usage{ full.score(sp,G,family,control,gamma,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{sp}{The logs of the smoothing parameters} \item{G}{a list returned by \code{mgcv:::gam.setup}} \item{family}{The family object for the GAM.} \item{control}{a list returned be \code{\link{gam.control}}} \item{gamma}{the degrees of freedom inflation factor (usually 1).} \item{...}{other arguments, typically for passing on to \code{gam.fit}.} } \value{ The value of the GCV/UBRE score, with attribute \code{"full.gam.object"} which is the full object returned by \code{\link{gam.fit}}. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/model.matrix.gam.Rd0000644000177400001440000000216012632334033015606 0ustar murdochusers\name{model.matrix.gam} \alias{model.matrix.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Extract model matrix from GAM fit} \description{Obtains the model matrix from a fitted \code{gam} object. } \usage{ \method{model.matrix}{gam}(object, ...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ fitted model object of class \code{gam} as produced by \code{gam()}.} \item{...}{ other arguments, passed to \code{\link{predict.gam}}.} } \details{Calls \code{\link{predict.gam}} with no \code{newdata} argument and \code{type="lpmatrix"} in order to obtain the model matrix of \code{object}. } \value{ A model matrix. } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \references{ Wood S.N. (2006b) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. } \seealso{ \code{\link{gam}}} \examples{ require(mgcv) n <- 15 x <- runif(n) y <- sin(x*2*pi) + rnorm(n)*.2 mod <- gam(y~s(x,bs="cc",k=6),knots=list(x=seq(0,1,length=6))) model.matrix(mod) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/gam.side.Rd0000744000177400001440000001020712632745100014132 0ustar murdochusers\name{gam.side} \alias{gam.side} %- Also NEED an `\alias' for EACH other topic documented here. \title{Identifiability side conditions for a GAM} \description{ GAM formulae with repeated variables may only correspond to identifiable models given some side conditions. This routine works out appropriate side conditions, based on zeroing redundant parameters. It is called from \code{mgcv:::gam.setup} and is not intended to be called by users. The method identifies nested and repeated variables by their names, but numerically evaluates which constraints need to be imposed. Constraints are always applied to smooths of more variables in preference to smooths of fewer variables. The numerical approach allows appropriate constraints to be applied to models constructed using any smooths, including user defined smooths. } \usage{ gam.side(sm,Xp,tol=.Machine$double.eps^.5,with.pen=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{sm}{ A list of smooth objects as returned by \code{\link{smooth.construct}}.} \item{Xp}{The model matrix for the strictly parametric model components.} \item{tol}{The tolerance to use when assessing linear dependence of smooths.} \item{with.pen}{Should the computation of dependence consider the penalties or not. Doing so will lead to fewer constraints.} } \details{ Models such as \code{y~s(x)+s(z)+s(x,z)} can be estimated by \code{\link{gam}}, but require identifiability constraints to be applied, to make them identifiable. This routine does this, effectively setting redundant parameters to zero. When the redundancy is between smooths of lower and higher numbers of variables, the constraint is always applied to the smooth of the higher number of variables. Dependent smooths are identified symbolically, but which constraints are needed to ensure identifiability of these smooths is determined numerically, using \code{\link{fixDependence}}. This makes the routine rather general, and not dependent on any particular basis. \code{Xp} is used to check whether there is a constant term in the model (or columns that can be linearly combined to give a constant). This is because centred smooths can appear independent, when they would be dependent if there is a constant in the model, so dependence testing needs to take account of this. } \value{ A list of smooths, with model matrices and penalty matrices adjusted to automatically impose the required constraints. Any smooth that has been modified will have an attribute \code{"del.index"}, listing the columns of its model matrix that were deleted. This index is used in the creation of prediction matrices for the term. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \section{WARNINGS }{ Much better statistical stability will be obtained by using models like \code{y~s(x)+s(z)+ti(x,z)} or \code{y~ti(x)+ti(z)+ti(x,z)} rather than \code{y~s(x)+s(z)+s(x,z)}, since the former are designed not to require further constraint. } \seealso{\code{\link{ti}}, \code{\link{gam.models}}} \examples{ ## The first two examples here iluustrate models that cause ## gam.side to impose constraints, but both are a bad way ## of estimating such models. The 3rd example is the right ## way.... set.seed(7) require(mgcv) dat <- gamSim(n=400,scale=2) ## simulate data ## estimate model with redundant smooth interaction (bad idea). b<-gam(y~s(x0)+s(x1)+s(x0,x1)+s(x2),data=dat) plot(b,pages=1) ## Simulate data with real interation... dat <- gamSim(2,n=500,scale=.1) old.par<-par(mfrow=c(2,2)) ## a fully nested tensor product example (bad idea) b <- gam(y~s(x,bs="cr",k=6)+s(z,bs="cr",k=6)+te(x,z,k=6), data=dat$data) plot(b) old.par<-par(mfrow=c(2,2)) ## A fully nested tensor product example, done properly, ## so that gam.side is not needed to ensure identifiability. ## ti terms are designed to produce interaction smooths ## suitable for adding to main effects (we could also have ## used s(x) and s(z) without a problem, but not s(z,x) ## or te(z,x)). b <- gam(y ~ ti(x,k=6) + ti(z,k=6) + ti(x,z,k=6), data=dat$data) plot(b) par(old.par) rm(dat) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.tensor.smooth.spec.Rd0000644000177400001440000000401612632334033021550 0ustar murdochusers\name{smooth.construct.tensor.smooth.spec} \alias{smooth.construct.tensor.smooth.spec} %- Also NEED an `\alias' for EACH other topic documented here. \title{Tensor product smoothing constructor} \description{A special \code{smooth.construct} method function for creating tensor product smooths from any combination of single penalty marginal smooths. } \usage{ \method{smooth.construct}{tensor.smooth.spec}(object, data, knots) } \arguments{ \item{object}{a smooth specification object of class \code{tensor.smooth.spec}, usually generated by a term like \code{te(x,z)} in a \code{\link{gam}} model formula} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}. See details for further information.} } \value{ An object of class \code{"tensor.smooth"}. See \code{\link{smooth.construct}}, for the elements that this object will contain. } \details{Tensor product smooths are smooths of several variables which allow the degree of smoothing to be different with respect to different variables. They are useful as smooth interaction terms, as they are invariant to linear rescaling of the covariates, which means, for example, that they are insensitive to the measurement units of the different covariates. They are also useful whenever isotropic smoothing is inappropriate. See \code{\link{te}}, \code{\link{smooth.construct}} and \code{\link{smooth.terms}}. } \references{ Wood, S.N. (2006) Low rank scale invariant tensor product smooths for generalized additive mixed models. Biometrics 62(4):1025-1036 } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{cSplineDes}}} \examples{ ## see ?gam } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/slanczos.Rd0000744000177400001440000000624412632334033014304 0ustar murdochusers\name{slanczos} \alias{slanczos} %- Also NEED an `\alias' for EACH other topic documented here. \title{Compute truncated eigen decomposition of a symmetric matrix} \description{ Uses Lanczos iteration to find the truncated eigen-decomposition of a symmetric matrix. } \usage{ slanczos(A,k=10,kl=-1,tol=.Machine$double.eps^.5,nt=1) } %- maybe also `usage' for other objects documented here. \arguments{ \item{A}{A symmetric matrix.} \item{k}{Must be non-negative. If \code{kl} is negative, then the \code{k} largest magnitude eigenvalues are found, together with the corresponding eigenvectors. If \code{kl} is non-negative then the \code{k} highest eigenvalues are found together with their eigenvectors and the \code{kl} lowest eigenvalues with eigenvectors are also returned.} \item{kl}{If \code{kl} is non-negative then the \code{kl} lowest eigenvalues are returned together with their corresponding eigenvectors (in addition to the \code{k} highest eignevalues + vectors). negative \code{kl} signals that the \code{k} largest magnitude eigenvalues should be returned, with eigenvectors.} \item{tol}{tolerance to use for convergence testing of eigenvalues. Error in eigenvalues will be less than the magnitude of the dominant eigenvalue multiplied by \code{tol} (or the machine precision!).} \item{nt}{number of threads to use for leading order iterative multiplication of A by vector. May show no speed improvement on two processor machine.} } \details{ If \code{kl} is non-negative, returns the highest \code{k} and lowest \code{kl} eigenvalues, with their corresponding eigenvectors. If \code{kl} is negative, returns the largest magnitude \code{k} eigenvalues, with corresponding eigenvectors. The routine implements Lanczos iteration with full re-orthogonalization as described in Demmel (1997). Lanczos iteraction iteratively constructs a tridiagonal matrix, the eigenvalues of which converge to the eigenvalues of \code{A}, as the iteration proceeds (most extreme first). Eigenvectors can also be computed. For small \code{k} and \code{kl} the approach is faster than computing the full symmetric eigendecompostion. The tridiagonal eigenproblems are handled using LAPACK. The implementation is not optimal: in particular the inner triadiagonal problems could be handled more efficiently, and there would be some savings to be made by not always returning eigenvectors. } \value{ A list with elements \code{values} (array of eigenvalues); \code{vectors} (matrix with eigenvectors in its columns); \code{iter} (number of iterations required). } \references{ Demmel, J. (1997) Applied Numerical Linear Algebra. SIAM } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{cyclic.p.spline}}} \examples{ require(mgcv) ## create some x's and knots... set.seed(1); n <- 700;A <- matrix(runif(n*n),n,n);A <- A+t(A) ## compare timings of slanczos and eigen system.time(er <- slanczos(A,10)) system.time(um <- eigen(A,symmetric=TRUE)) ## confirm values are the same... ind <- c(1:6,(n-3):n) range(er$values-um$values[ind]);range(abs(er$vectors)-abs(um$vectors[,ind])) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/vcov.gam.Rd0000644000177400001440000000367012632334033014167 0ustar murdochusers\name{vcov.gam} \alias{vcov.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Extract parameter (estimator) covariance matrix from GAM fit} \description{ Extracts the Bayesian posterior covariance matrix of the parameters or frequentist covariance matrix of the parameter estimators from a fitted \code{gam} object. } \usage{ \method{vcov}{gam}(object, freq = FALSE, dispersion = NULL,unconditional=FALSE, ...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ fitted model object of class \code{gam} as produced by \code{gam()}.} \item{freq}{ \code{TRUE} to return the frequentist covariance matrix of the parameter estimators, \code{FALSE} to return the Bayesian posterior covariance matrix of the parameters.} \item{dispersion}{ a value for the dispersion parameter: not normally used.} \item{unconditional}{ if \code{TRUE} (and \code{freq==FALSE}) then the Bayesian smoothing parameter uncertainty corrected covariance matrix is returned, if available. } \item{...}{ other arguments, currently ignored.} } \details{ Basically, just extracts \code{object$Ve} or \code{object$Vp} from a \code{\link{gamObject}}. } \value{ A matrix corresponding to the estimated frequentist covariance matrix of the model parameter estimators/coefficients, or the estimated posterior covariance matrix of the parameters, depending on the argument \code{freq}. } \author{ Henric Nilsson. Maintained by Simon N. Wood \email{simon.wood@r-project.org} } \references{ Wood, S.N. (2006) On confidence intervals for generalized additive models based on penalized regression splines. Australian and New Zealand Journal of Statistics. 48(4): 445-464. } \seealso{ \code{\link{gam}}} \examples{ require(mgcv) n <- 100 x <- runif(n) y <- sin(x*2*pi) + rnorm(n)*.2 mod <- gam(y~s(x,bs="cc",k=10),knots=list(x=seq(0,1,length=10))) diag(vcov(mod)) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/magic.post.proc.Rd0000644000177400001440000000462012632334033015451 0ustar murdochusers\name{magic.post.proc} \alias{magic.post.proc} %- Also NEED an `\alias' for EACH other topic documented here. \title{Auxilliary information from magic fit} \description{Obtains Bayesian parameter covariance matrix, frequentist parameter estimator covariance matrix, estimated degrees of freedom for each parameter and leading diagonal of influence/hat matrix, for a penalized regression estimated by \code{magic}. } \usage{ magic.post.proc(X,object,w=NULL) } %- maybe also `usage' for other objects documented here. \arguments{ \item{X}{ is the model matrix.} \item{object}{is the list returned by \code{magic} after fitting the model with model matrix \code{X}.} \item{w}{is the weight vector used in fitting, or the weight matrix used in fitting (i.e. supplied to \code{magic}, if one was.). If \code{w} is a vector then its elements are typically proportional to reciprocal variances (but could even be negative). If \code{w} is a matrix then \code{t(w)\%*\%w} should typically give the inverse of the covariance matrix of the response data supplied to \code{magic}.} } \details{ \code{object} contains \code{rV} (\eqn{ {\bf V}}{V}, say), and \code{scale} (\eqn{ \phi}{s}, say) which can be used to obtain the require quantities as follows. The Bayesian covariance matrix of the parameters is \eqn{ {\bf VV}^\prime \phi}{VV's}. The vector of estimated degrees of freedom for each parameter is the leading diagonal of \eqn{ {\bf VV}^\prime {\bf X}^\prime {\bf W}^\prime {\bf W}{\bf X}}{ VV'X'W'WX} where \eqn{\bf{W}}{W} is either the weight matrix \code{w} or the matrix \code{diag(w)}. The hat/influence matrix is given by \eqn{ {\bf WX}{\bf VV}^\prime {\bf X}^\prime {\bf W}^\prime }{ WXVV'X'W'} . The frequentist parameter estimator covariance matrix is \eqn{ {\bf VV}^\prime {\bf X}^\prime {\bf W}^\prime {\bf WXVV}^\prime \phi}{ VV'X'W'WXVV's}: it is sometimes useful for testing terms for equality to zero. } \value{ A list with three items: \item{Vb}{the Bayesian covariance matrix of the model parameters.} \item{Ve}{the frequentist covariance matrix for the parameter estimators.} \item{hat}{the leading diagonal of the hat (influence) matrix.} \item{edf}{the array giving the estimated degrees of freedom associated with each parameter.} } \seealso{\code{\link{magic}}} \author{ Simon N. Wood \email{simon.wood@r-project.org}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/magic.Rd0000744000177400001440000003130212632334033013521 0ustar murdochusers\name{magic} \alias{magic} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Stable Multiple Smoothing Parameter Estimation by GCV or UBRE} \description{ Function to efficiently estimate smoothing parameters in generalized ridge regression problems with multiple (quadratic) penalties, by GCV or UBRE. The function uses Newton's method in multi-dimensions, backed up by steepest descent to iteratively adjust the smoothing parameters for each penalty (one penalty may have a smoothing parameter fixed at 1). For maximal numerical stability the method is based on orthogonal decomposition methods, and attempts to deal with numerical rank deficiency gracefully using a truncated singular value decomposition approach. } %- end description \usage{ magic(y,X,sp,S,off,L=NULL,lsp0=NULL,rank=NULL,H=NULL,C=NULL, w=NULL,gamma=1,scale=1,gcv=TRUE,ridge.parameter=NULL, control=list(tol=1e-6,step.half=25,rank.tol= .Machine$double.eps^0.5),extra.rss=0,n.score=length(y),nthreads=1) } %- maybe also `usage' for other objects documented here. \arguments{ \item{y}{is the response data vector.} \item{X}{is the model matrix (more columns than rows are allowed).} \item{sp}{is the array of smoothing parameters. The vector \code{L\%*\%log(sp) + lsp0} contains the logs of the smoothing parameters that actually multiply the penalty matrices stored in \code{S} (\code{L} is taken as the identity if \code{NULL}). Any \code{sp} values that are negative are autoinitialized, otherwise they are taken as supplying starting values. A supplied starting value will be reset to a default starting value if the gradient of the GCV/UBRE score is too small at the supplied value. } \item{S}{ is a list of of penalty matrices. \code{S[[i]]} is the ith penalty matrix, but note that it is not stored as a full matrix, but rather as the smallest square matrix including all the non-zero elements of the penalty matrix. Element 1,1 of \code{S[[i]]} occupies element \code{off[i]}, \code{off[i]} of the ith penalty matrix. Each \code{S[[i]]} must be positive semi-definite. Set to \code{list()} if there are no smoothing parameters to be estimated. } \item{off}{is an array indicating the first parameter in the parameter vector that is penalized by the penalty involving \code{S[[i]]}.} \item{L}{is a matrix mapping \code{log(sp)} to the log smoothing parameters that actually multiply the penalties defined by the elemts of \code{S}. Taken as the identity, if \code{NULL}. See above under \code{sp}.} \item{lsp0}{If \code{L} is not \code{NULL} this is a vector of constants in the linear transformation from \code{log(sp)} to the actual log smoothing parameters. So the logs of the smoothing parameters multiplying the \code{S[[i]]} are given by \code{L\%*\%log(sp) + lsp0}. Taken as 0 if \code{NULL}.} \item{rank}{ is an array specifying the ranks of the penalties. This is useful, but not essential, for forming square roots of the penalty matrices.} \item{H}{ is the optional offset penalty - i.e. a penalty with a smoothing parameter fixed at 1. This is useful for allowing regularization of the estimation process, fixed smoothing penalties etc.} \item{C}{ is the optional matrix specifying any linear equality constraints on the fitting problem. If \eqn{\bf b}{b} is the parameter vector then the parameters are forced to satisfy \eqn{ {\bf Cb} = {\bf 0} }{Cb=0}. } \item{w}{ the regression weights. If this is a matrix then it is taken as being the square root of the inverse of the covariance matrix of \code{y}, specifically \eqn{ {\bf V}_y^{-1} = {\bf w}^\prime{\bf w}}{V_y^{-1}=w'w}. If \code{w} is an array then it is taken as the diagonal of this matrix, or simply the weight for each element of \code{y}. See below for an example using this.} \item{gamma}{is an inflation factor for the model degrees of freedom in the GCV or UBRE score.} \item{scale}{ is the scale parameter for use with UBRE.} \item{gcv}{ should be set to \code{TRUE} if GCV is to be used, \code{FALSE} for UBRE.} \item{ridge.parameter}{It is sometimes useful to apply a ridge penalty to the fitting problem, penalizing the parameters in the constrained space directly. Setting this parameter to a value greater than zero will cause such a penalty to be used, with the magnitude given by the parameter value.} \item{control}{ is a list of iteration control constants with the following elements: \describe{ \item{tol}{The tolerance to use in judging convergence.} \item{step.half}{If a trial step fails then the method tries halving it up to a maximum of \code{step.half} times.} \item{rank.tol}{is a constant used to test for numerical rank deficiency of the problem. Basically any singular value less than \code{rank_tol} multiplied by the largest singular value of the problem is set to zero.} } } %- end of control \item{extra.rss}{is a constant to be added to the residual sum of squares (squared norm) term in the calculation of the GCV, UBRE and scale parameter estimate. In conjuction with \code{n.score}, this is useful for certain methods for dealing with very large data sets.} \item{n.score}{number to use as the number of data in GCV/UBRE score calculation: usually the actual number of data, but there are methods for dealing with very large datasets that change this.} \item{nthreads}{\code{magic} can make use of multiple threads if this is set to >1.} } \details{ The method is a computationally efficient means of applying GCV or UBRE (often approximately AIC) to the problem of smoothing parameter selection in generalized ridge regression problems of the form: \deqn{ minimise~ \| { \bf W} ({ \bf Xb - y} ) \|^2 + {\bf b}^\prime {\bf Hb} + \sum_{i=1}^m \theta_i {\bf b^\prime S}_i{\bf b} }{ min ||W(Xb-y)||^2 + b'Hb + theta_1 b'S_1 b + theta_2 b'S_2 b + . . .} possibly subject to constraints \eqn{ {\bf Cb}={\bf 0}}{Cb=0}. \eqn{ {\bf X}}{X} is a design matrix, \eqn{\bf b}{b} a parameter vector, \eqn{\bf y}{y} a data vector, \eqn{\bf W}{W} a weight matrix, \eqn{ {\bf S}_i}{S_i} a positive semi-definite matrix of coefficients defining the ith penalty with associated smoothing parameter \eqn{\theta_i}{theta_i}, \eqn{\bf H}{H} is the positive semi-definite offset penalty matrix and \eqn{\bf C}{C} a matrix of coefficients defining any linear equality constraints on the problem. \eqn{ {\bf X}}{X} need not be of full column rank. The \eqn{\theta_i}{theta_i} are chosen to minimize either the GCV score: \deqn{V_g = \frac{n\|{\bf W}({\bf y} - {\bf Ay})\|^2}{[tr({\bf I} - \gamma {\bf A})]^2}}{V_g = n ||W(y-Ay)||^2/[tr(I - g A)]^2} or the UBRE score: \deqn{V_u=\|{\bf W}({\bf y}-{\bf Ay})\|^2/n-2 \phi tr({\bf I}-\gamma {\bf A})/n + \phi}{ V_u =||W(y-Ay||^2/n - 2 s tr(I - g A)/n + s } where \eqn{\gamma}{g} is \code{gamma} the inflation factor for degrees of freedom (usually set to 1) and \eqn{\phi}{s} is \code{scale}, the scale parameter. \eqn{\bf A}{A} is the hat matrix (influence matrix) for the fitting problem (i.e the matrix mapping data to fitted values). Dependence of the scores on the smoothing parameters is through \eqn{\bf A}{A}. The method operates by Newton or steepest descent updates of the logs of the \eqn{\theta_i}{theta_i}. A key aspect of the method is stable and economical calculation of the first and second derivatives of the scores w.r.t. the log smoothing parameters. Because the GCV/UBRE scores are flat w.r.t. very large or very small \eqn{\theta_i}{theta_i}, it's important to get good starting parameters, and to be careful not to step into a flat region of the smoothing parameter space. For this reason the algorithm rescales any Newton step that would result in a \eqn{log(\theta_i)}{log(theta_i)} change of more than 5. Newton steps are only used if the Hessian of the GCV/UBRE is postive definite, otherwise steepest descent is used. Similarly steepest descent is used if the Newton step has to be contracted too far (indicating that the quadratic model underlying Newton is poor). All initial steepest descent steps are scaled so that their largest component is 1. However a step is calculated, it is never expanded if it is successful (to avoid flat portions of the objective), but steps are successively halved if they do not decrease the GCV/UBRE score, until they do, or the direction is deemed to have failed. (Given the smoothing parameters the optimal \eqn{\bf b}{b} parameters are easily found.) The method is coded in \code{C} with matrix factorizations performed using LINPACK and LAPACK routines. } \value{The function returns a list with the following items: \item{b}{The best fit parameters given the estimated smoothing parameters.} \item{scale}{the estimated (GCV) or supplied (UBRE) scale parameter.} \item{score}{the minimized GCV or UBRE score.} \item{sp}{an array of the estimated smoothing parameters.} \item{sp.full}{an array of the smoothing parameters that actually multiply the elements of \code{S} (same as \code{sp} if \code{L} was \code{NULL}). This is \code{exp(L\%*\%log(sp))}.} \item{rV}{a factored form of the parameter covariance matrix. The (Bayesian) covariance matrix of the parametes \code{b} is given by \code{rV\%*\%t(rV)*scale}. } \item{gcv.info}{is a list of information about the performance of the method with the following elements: \describe{ \item{full.rank}{The apparent rank of the problem: number of parameters less number of equality constraints.} \item{rank}{The estimated actual rank of the problem (at the final iteration of the method).} \item{fully.converged}{is \code{TRUE} if the method converged by satisfying the convergence criteria, and \code{FALSE} if it coverged by failing to decrease the score along the search direction.} \item{hess.pos.def}{is \code{TRUE} if the hessian of the UBRE or GCV score was positive definite at convergence.} \item{iter}{is the number of Newton/Steepest descent iterations taken.} \item{score.calls}{is the number of times that the GCV/UBRE score had to be evaluated.} \item{rms.grad}{is the root mean square of the gradient of the UBRE/GCV score w.r.t. the smoothing parameters.} \item{R}{The factor R from the QR decomposition of the weighted model matrix. This is un-pivoted so that column order corresponds to \code{X}. So it may not be upper triangular.}} } Note that some further useful quantities can be obtained using \code{\link{magic.post.proc}}. } \references{ Wood, S.N. (2004) Stable and efficient multiple smoothing parameter estimation for generalized additive models. J. Amer. Statist. Ass. 99:673-686 \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{magic.post.proc}},\code{\link{gam}} } \examples{ ## Use `magic' for a standard additive model fit ... library(mgcv) set.seed(1);n <- 200;sig <- 1 dat <- gamSim(1,n=n,scale=sig) k <- 30 ## set up additive model G <- gam(y~s(x0,k=k)+s(x1,k=k)+s(x2,k=k)+s(x3,k=k),fit=FALSE,data=dat) ## fit using magic (and gam default tolerance) mgfit <- magic(G$y,G$X,G$sp,G$S,G$off,rank=G$rank, control=list(tol=1e-7,step.half=15)) ## and fit using gam as consistency check b <- gam(G=G) mgfit$sp;b$sp # compare smoothing parameter estimates edf <- magic.post.proc(G$X,mgfit,G$w)$edf # get e.d.f. per param range(edf-b$edf) # compare ## p>n example... fit model to first 100 data only, so more ## params than data... mgfit <- magic(G$y[1:100],G$X[1:100,],G$sp,G$S,G$off,rank=G$rank) edf <- magic.post.proc(G$X[1:100,],mgfit,G$w[1:100])$edf ## constrain first two smooths to have identical smoothing parameters L <- diag(3);L <- rbind(L[1,],L) mgfit <- magic(G$y,G$X,rep(-1,3),G$S,G$off,L=L,rank=G$rank,C=G$C) ## Now a correlated data example ... library(nlme) ## simulate truth set.seed(1);n<-400;sig<-2 x <- 0:(n-1)/(n-1) f <- 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 ## produce scaled covariance matrix for AR1 errors... V <- corMatrix(Initialize(corAR1(.6),data.frame(x=x))) Cv <- chol(V) # t(Cv)%*%Cv=V ## Simulate AR1 errors ... e <- t(Cv)\%*\%rnorm(n,0,sig) # so cov(e) = V * sig^2 ## Observe truth + AR1 errors y <- f + e ## GAM ignoring correlation par(mfrow=c(1,2)) b <- gam(y~s(x,k=20)) plot(b);lines(x,f-mean(f),col=2);title("Ignoring correlation") ## Fit smooth, taking account of *known* correlation... w <- solve(t(Cv)) # V^{-1} = w'w ## Use `gam' to set up model for fitting... G <- gam(y~s(x,k=20),fit=FALSE) ## fit using magic, with weight *matrix* mgfit <- magic(G$y,G$X,G$sp,G$S,G$off,rank=G$rank,C=G$C,w=w) ## Modify previous gam object using new fit, for plotting... mg.stuff <- magic.post.proc(G$X,mgfit,w) b$edf <- mg.stuff$edf;b$Vp <- mg.stuff$Vb b$coefficients <- mgfit$b plot(b);lines(x,f-mean(f),col=2);title("Known correlation") } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/pcls.Rd0000744000177400001440000001734012632334033013410 0ustar murdochusers\name{pcls} \alias{pcls} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Penalized Constrained Least Squares Fitting} \description{ Solves least squares problems with quadratic penalties subject to linear equality and inequality constraints using quadratic programming. } \usage{ pcls(M) } %- maybe also `usage' for other objects documented here. \arguments{ \item{M}{is the single list argument to \code{pcls}. It should have the following elements: \describe{ \item{y}{The response data vector.} \item{w}{A vector of weights for the data (often proportional to the reciprocal of the variance). } \item{X}{The design matrix for the problem, note that \code{ncol(M$X)} must give the number of model parameters, while \code{nrow(M$X)} should give the number of data.} \item{C}{Matrix containing any linear equality constraints on the problem (e.g. \eqn{ \bf C}{C} in \eqn{ {\bf Cp}={\bf c} }{Cp=c}). If you have no equality constraints initialize this to a zero by zero matrix. Note that there is no need to supply the vector \eqn{ \bf c}{c}, it is defined implicitly by the initial parameter estimates \eqn{ \bf p}{p}.} \item{S}{ A list of penalty matrices. \code{S[[i]]} is the smallest contiguous matrix including all the non-zero elements of the ith penalty matrix. The first parameter it penalizes is given by \code{off[i]+1} (starting counting at 1). } \item{off}{ Offset values locating the elements of \code{M$S} in the correct location within each penalty coefficient matrix. (Zero offset implies starting in first location)} \item{sp}{ An array of smoothing parameter estimates.} \item{p}{An array of feasible initial parameter estimates - these must satisfy the constraints, but should avoid satisfying the inequality constraints as equality constraints.} \item{Ain}{Matrix for the inequality constraints \eqn{ {\bf A}_{in} {\bf p} > {\bf b}_{in}}{A_in p > b}. } \item{bin}{vector in the inequality constraints. } } % end describe } % end M } \details{ This solves the problem: \deqn{ minimise~ \| { \bf W}^{1/2} ({ \bf Xp - y} ) \|^2 + \sum_{i=1}^m \lambda_i {\bf p^\prime S}_i{\bf p} }{ min || W^0.5 (Xp-y) ||^2 + lambda_1 p'S_1 p + lambda_1 p'S_2 p + . . .} subject to constraints \eqn{ {\bf Cp}={\bf c}}{Cp=c} and \eqn{ {\bf A}_{in}{\bf p}>{\bf b}_{in}}{A_in p > b_in}, w.r.t. \eqn{\bf p}{p} given the smoothing parameters \eqn{\lambda_i}{lambda_i}. \eqn{ {\bf X}}{X} is a design matrix, \eqn{\bf p}{p} a parameter vector, \eqn{\bf y}{y} a data vector, \eqn{\bf W}{W} a diagonal weight matrix, \eqn{ {\bf S}_i}{S_i} a positive semi-definite matrix of coefficients defining the ith penalty and \eqn{\bf C}{C} a matrix of coefficients defining the linear equality constraints on the problem. The smoothing parameters are the \eqn{\lambda_i}{lambda_i}. Note that \eqn{ {\bf X}}{X} must be of full column rank, at least when projected into the null space of any equality constraints. \eqn{ {\bf A}_{in}}{A_in} is a matrix of coefficients defining the inequality constraints, while \eqn{ {\bf b}_{in}}{b_in} is a vector involved in defining the inequality constraints. Quadratic programming is used to perform the solution. The method used is designed for maximum stability with least squares problems: i.e. \eqn{ {\bf X}^\prime {\bf X}}{X'X} is not formed explicitly. See Gill et al. 1981. } \value{ The function returns an array containing the estimated parameter vector. } \references{ Gill, P.E., Murray, W. and Wright, M.H. (1981) Practical Optimization. Academic Press, London. Wood, S.N. (1994) Monotonic smoothing splines fitted by cross validation SIAM Journal on Scientific Computing 15(5):1126-1133 \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{magic}}, \code{\link{mono.con}} } \examples{ require(mgcv) # first an un-penalized example - fit E(y)=a+bx subject to a>0 set.seed(0) n <- 100 x <- runif(n); y <- x - 0.2 + rnorm(n)*0.1 M <- list(X=matrix(0,n,2),p=c(0.1,0.5),off=array(0,0),S=list(), Ain=matrix(0,1,2),bin=0,C=matrix(0,0,0),sp=array(0,0),y=y,w=y*0+1) M$X[,1] <- 1; M$X[,2] <- x; M$Ain[1,] <- c(1,0) pcls(M) -> M$p plot(x,y); abline(M$p,col=2); abline(coef(lm(y~x)),col=3) # Penalized example: monotonic penalized regression spline ..... # Generate data from a monotonic truth. x <- runif(100)*4-1;x <- sort(x); f <- exp(4*x)/(1+exp(4*x)); y <- f+rnorm(100)*0.1; plot(x,y) dat <- data.frame(x=x,y=y) # Show regular spline fit (and save fitted object) f.ug <- gam(y~s(x,k=10,bs="cr")); lines(x,fitted(f.ug)) # Create Design matrix, constraints etc. for monotonic spline.... sm <- smoothCon(s(x,k=10,bs="cr"),dat,knots=NULL)[[1]] F <- mono.con(sm$xp); # get constraints G <- list(X=sm$X,C=matrix(0,0,0),sp=f.ug$sp,p=sm$xp,y=y,w=y*0+1) G$Ain <- F$A;G$bin <- F$b;G$S <- sm$S;G$off <- 0 p <- pcls(G); # fit spline (using s.p. from unconstrained fit) fv<-Predict.matrix(sm,data.frame(x=x))\%*\%p lines(x,fv,col=2) # now a tprs example of the same thing.... f.ug <- gam(y~s(x,k=10)); lines(x,fitted(f.ug)) # Create Design matrix, constriants etc. for monotonic spline.... sm <- smoothCon(s(x,k=10,bs="tp"),dat,knots=NULL)[[1]] xc <- 0:39/39 # points on [0,1] nc <- length(xc) # number of constraints xc <- xc*4-1 # points at which to impose constraints A0 <- Predict.matrix(sm,data.frame(x=xc)) # ... A0%*%p evaluates spline at xc points A1 <- Predict.matrix(sm,data.frame(x=xc+1e-6)) A <- (A1-A0)/1e-6 ## ... approx. constraint matrix (A\%*\%p is -ve ## spline gradient at points xc) G <- list(X=sm$X,C=matrix(0,0,0),sp=f.ug$sp,y=y,w=y*0+1,S=sm$S,off=0) G$Ain <- A; # constraint matrix G$bin <- rep(0,nc); # constraint vector G$p <- rep(0,10); G$p[10] <- 0.1 # ... monotonic start params, got by setting coefs of polynomial part p <- pcls(G); # fit spline (using s.p. from unconstrained fit) fv2 <- Predict.matrix(sm,data.frame(x=x))\%*\%p lines(x,fv2,col=3) ###################################### ## monotonic additive model example... ###################################### ## First simulate data... set.seed(10) f1 <- function(x) 5*exp(4*x)/(1+exp(4*x)); f2 <- function(x) { ind <- x > .5 f <- x*0 f[ind] <- (x[ind] - .5)^2*10 f } f3 <- function(x) 0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10 n <- 200 x <- runif(n); z <- runif(n); v <- runif(n) mu <- f1(x) + f2(z) + f3(v) y <- mu + rnorm(n) ## Preliminary unconstrained gam fit... G <- gam(y~s(x)+s(z)+s(v,k=20),fit=FALSE) b <- gam(G=G) ## generate constraints, by finite differencing ## using predict.gam .... eps <- 1e-7 pd0 <- data.frame(x=seq(0,1,length=100),z=rep(.5,100), v=rep(.5,100)) pd1 <- data.frame(x=seq(0,1,length=100)+eps,z=rep(.5,100), v=rep(.5,100)) X0 <- predict(b,newdata=pd0,type="lpmatrix") X1 <- predict(b,newdata=pd1,type="lpmatrix") Xx <- (X1 - X0)/eps ## Xx \%*\% coef(b) must be positive pd0 <- data.frame(z=seq(0,1,length=100),x=rep(.5,100), v=rep(.5,100)) pd1 <- data.frame(z=seq(0,1,length=100)+eps,x=rep(.5,100), v=rep(.5,100)) X0 <- predict(b,newdata=pd0,type="lpmatrix") X1 <- predict(b,newdata=pd1,type="lpmatrix") Xz <- (X1-X0)/eps G$Ain <- rbind(Xx,Xz) ## inequality constraint matrix G$bin <- rep(0,nrow(G$Ain)) G$C = matrix(0,0,ncol(G$X)) G$sp <- b$sp G$p <- coef(b) G$off <- G$off-1 ## to match what pcls is expecting ## force inital parameters to meet constraint G$p[11:18] <- G$p[2:9]<- 0 p <- pcls(G) ## constrained fit par(mfrow=c(2,3)) plot(b) ## original fit b$coefficients <- p plot(b) ## constrained fit ## note that standard errors in preceding plot are obtained from ## unconstrained fit } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/residuals.gam.Rd0000644000177400001440000000344112632334033015201 0ustar murdochusers\name{residuals.gam} \alias{residuals.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generalized Additive Model residuals} \description{Returns residuals for a fitted \code{gam} model object. Pearson, deviance, working and response residuals are available. } \usage{ \method{residuals}{gam}(object, type = "deviance",...) } \arguments{ \item{object}{ a \code{gam} fitted model object. } \item{type}{the type of residuals wanted. Usually one of \code{"deviance"}, \code{"pearson"},\code{"scaled.pearson"}, \code{"working"}, or \code{"response"}. } \item{...}{other arguments.} } \details{Response residuals are the raw residuals (data minus fitted values). Scaled Pearson residuals are raw residuals divided by the standard deviation of the data according to the model mean variance relationship and estimated scale parameter. Pearson residuals are the same, but multiplied by the square root of the scale parameter (so they are independent of the scale parameter): (\eqn{(y-\mu)/\sqrt{V(\mu)}}{(y-m)/V(m)^0.5}, where \eqn{y}{y} is data \eqn{\mu}{m} is model fitted value and \eqn{V}{V} is model mean-variance relationship.). Both are provided since not all texts agree on the definition of Pearson residuals. Deviance residuals simply return the deviance residuals defined by the model family. Working residuals are the residuals returned from model fitting at convergence. Families can supply their own residual function, which is used in place of the standard function if present, (e.g. \code{\link{cox.ph}}). } \value{ A vector of residuals. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gam}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/in.out.Rd0000644000177400001440000000261412632334033013660 0ustar murdochusers\name{in.out} \alias{in.out} %- Also NEED an `\alias' for EACH other topic documented here. \title{Which of a set of points lie within a polygon defined region} \description{Tests whether each of a set of points lie within a region defined by one or more (possibly nested) polygons. Points count as `inside' if they are interior to an odd number of polygons. } \usage{ in.out(bnd,x) } %- maybe also `usage' for other objects documented here. \arguments{ \item{bnd}{A two column matrix, the rows of which define the vertices of polygons defining the boundary of a region. Different polygons should be separated by an \code{NA} row, and the polygons are assumed closed.} \item{x}{A two column matrix. Each row is a point to test for inclusion in the region defined by \code{bnd}.} } \value{A logical vector of length \code{nrow(x)}. \code{TRUE} if the corresponding row of \code{x} is inside the boundary and \code{FALSE} otherwise. } \details{ The algorithm works by counting boundary crossings (using compiled C code). } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \examples{ library(mgcv) data(columb.polys) bnd <- columb.polys[[2]] plot(bnd,type="n") polygon(bnd) x <- seq(7.9,8.7,length=20) y <- seq(13.7,14.3,length=20) gr <- as.matrix(expand.grid(x,y)) inside <- in.out(bnd,gr) points(gr,col=as.numeric(inside)+1) } mgcv/man/multinom.Rd0000755000177400001440000000626012770452553014327 0ustar murdochusers\name{multinom} \alias{multinom} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM multinomial logistic regression} \description{Family for use with \code{\link{gam}}, implementing regression for categorical response data. Categories must be coded 0 to K, where K is a positive integer. \code{\link{gam}} should be called with a list of K formulae, one for each category except category zero (extra formulae for shared terms may also be supplied: see \code{\link{formula.gam}}). The first formula also specifies the response variable. } \usage{ multinom(K=1) } \arguments{ \item{K}{There are K+1 categories and K linear predictors. } } \value{ An object of class \code{general.family}. } \details{ The model has K linear predictors, \eqn{\eta_j}{h_j}, each dependent on smooth functions of predictor variables, in the usual way. If response variable, y, contains the class labels 0,...,K then the likelihood for y>0 is \eqn{\exp(\eta_y)/\{1+\sum_j \exp(\eta_j) \}}{exp(h_y)/(1 + sum_j exp(h_j) )}. If y=0 the likelihood is \eqn{1/\{1+\sum_j \exp(\eta_j) \}}{1/(1 + sum_j exp(h_j) )}. In the two class case this is just a binary logistic regression model. The implementation uses the approach to GAMLSS models described in Wood, Pya and Saefken (2016). The residuals returned for this model are simply the square root of -2 times the deviance for each observation, with a positive sign if the observed y is the most probable class for this observation, and a negative sign otherwise. Use \code{predict} with \code{type="response"} to get the predicted probabilities in each category. Note that the model is not completely invariant to category relabelling, even if all linear predictors have the same form. Realistically this model is unlikely to be suitable for problems with large numbers of categories. Missing categories are not supported. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood \email{simon.wood@r-project.org} } \references{ Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association. \url{http://arxiv.org/abs/1511.03864} } \seealso{\code{\link{ocat}}} \examples{ library(mgcv) set.seed(6) ## simulate some data from a three class model n <- 1000 f1 <- function(x) sin(3*pi*x)*exp(-x) f2 <- function(x) x^3 f3 <- function(x) .5*exp(-x^2)-.2 f4 <- function(x) 1 x1 <- runif(n);x2 <- runif(n) eta1 <- 2*(f1(x1) + f2(x2))-.5 eta2 <- 2*(f3(x1) + f4(x2))-1 p <- exp(cbind(0,eta1,eta2)) p <- p/rowSums(p) ## prob. of each category cp <- t(apply(p,1,cumsum)) ## cumulative prob. ## simulate multinomial response with these probabilities ## see also ?rmultinom y <- apply(cp,1,function(x) min(which(x>runif(1))))-1 ## plot simulated data... plot(x1,x2,col=y+3) ## now fit the model... b <- gam(list(y~s(x1)+s(x2),~s(x1)+s(x2)),family=multinom(K=2)) plot(b,pages=1) gam.check(b) ## now a simple classification plot... expand.grid(x1=seq(0,1,length=40),x2=seq(0,1,length=40)) -> gr pp <- predict(b,newdata=gr,type="response") pc <- apply(pp,1,function(x) which(max(x)==x)[1])-1 plot(gr,col=pc+3,pch=19) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.ps.smooth.spec.Rd0000744000177400001440000001520012664150566020672 0ustar murdochusers\name{smooth.construct.ps.smooth.spec} \alias{smooth.construct.ps.smooth.spec} \alias{smooth.construct.cp.smooth.spec} \alias{p.spline} \alias{cyclic.p.spline} %- Also NEED an `\alias' for EACH other topic documented here. \title{P-splines in GAMs} \description{\code{\link{gam}} can use univariate P-splines as proposed by Eilers and Marx (1996), specified via terms like \code{s(x,bs="ps")}. These terms use B-spline bases penalized by discrete penalties applied directly to the basis coefficients. Cyclic P-splines are specified by model terms like \code{s(x,bs="cp",...)}. These bases can be used in tensor product smooths (see \code{\link{te}}). The advantage of P-splines is the flexible way that penalty and basis order can be mixed. This often provides a useful way of `taming' an otherwise poorly behave smooth. However, in regular use, splines with derivative based penalties (e.g. \code{"tp"} or \code{"cr"} bases) tend to result in slightly better MSE performance, presumably because the good approximation theoretic properties of splines are rather closely connected to the use of derivative penalties. } \usage{ \method{smooth.construct}{ps.smooth.spec}(object, data, knots) \method{smooth.construct}{cp.smooth.spec}(object, data, knots) } \arguments{ \item{object}{a smooth specification object, usually generated by a term \code{s(x,bs="ps",...)} or \code{s(x,bs="cp",...)}} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}. See details for further information.} } \value{ An object of class \code{"pspline.smooth"} or \code{"cp.smooth"}. See \code{\link{smooth.construct}}, for the elements that this object will contain. } \details{A smooth term of the form \code{s(x,bs="ps",m=c(2,3))} specifies a 2nd order P-spline basis (cubic spline), with a third order difference penalty (0th order is a ridge penalty) on the coefficients. If \code{m} is a single number then it is taken as the basis order and penalty order. The default is the `cubic spline like' \code{m=c(2,2)}. The default basis dimension, \code{k}, is the larger of 10 and \code{m[1]+1} for a \code{"ps"} terms and the larger of 10 and \code{m[1]} for a \code{"cp"} term. \code{m[1]+1} and \code{m[1]} are the lower limits on basis dimension for the two types. If knots are supplied, then the number of knots should be one more than the basis dimension (i.e. \code{k+1}) for a \code{"cp"}smooth. For the \code{"ps"} basis the number of supplied knots should be \code{k + m[1] + 2}, and the range of the middle \code{k-m[1]} knots should include all the covariate values. See example. Alternatively, for both types of smooth, 2 knots can be supplied, denoting the lower and upper limits between which the spline can be evaluated (Don't make this range too wide, however, or you can end up with no information about some basis coefficients, because the corresponding basis functions have a span that includes no data!). Note that P-splines don't make much sense with uneven knot spacing. Linear extrapolation is used for prediction that requires extrapolation (i.e. prediction outside the range of the interior \code{k-m[1]} knots). Such extrapolation is not allowed in basis construction, but is when predicting. For the \code{"ps"} basis it is possible to set flags in the smooth specification object, requesting setup according to the SCOP-spline monotonic smoother construction of Pya and Wood (2015). As yet this is not supported by any modelling functions in \code{mgcv} (see package \code{scam}). Similarly it is possible to set a \code{deriv} flag in a smooth specification or smooth object, so that a model or prediction matrix produces the requested derivative of the spline, rather than evaluating it. See examples below. } \references{ Eilers, P.H.C. and B.D. Marx (1996) Flexible Smoothing with B-splines and Penalties. Statistical Science, 11(2):89-121 Pya, N., and Wood, S.N. (2015). Shape constrained additive models. Statistics and Computing, 25(3), 543-559. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{cSplineDes}}, \code{\link{adaptive.smooth}}} \examples{ ## see ?gam ## cyclic example ... require(mgcv) set.seed(6) x <- sort(runif(200)*10) z <- runif(200) f <- sin(x*2*pi/10)+.5 y <- rpois(exp(f),exp(f)) ## finished simulating data, now fit model... b <- gam(y ~ s(x,bs="cp") + s(z,bs="ps"),family=poisson) ## example with supplied knot ranges for x and z (can do just one) b <- gam(y ~ s(x,bs="cp") + s(z,bs="ps"),family=poisson, knots=list(x=c(0,10),z=c(0,1))) ## example with supplied knots... bk <- gam(y ~ s(x,bs="cp",k=12) + s(z,bs="ps",k=13),family=poisson, knots=list(x=seq(0,10,length=13),z=(-3):13/10)) ## plot results... par(mfrow=c(2,2)) plot(b,select=1,shade=TRUE);lines(x,f-mean(f),col=2) plot(b,select=2,shade=TRUE);lines(z,0*z,col=2) plot(bk,select=1,shade=TRUE);lines(x,f-mean(f),col=2) plot(bk,select=2,shade=TRUE);lines(z,0*z,col=2) ## Example using montonic constraints via the SCOP-spline ## construction, and of computng derivatives... x <- seq(0,1,length=100); dat <- data.frame(x) sspec <- s(x,bs="ps") sspec$mono <- 1 sm <- smoothCon(sspec,dat)[[1]] sm$deriv <- 1 Xd <- PredictMat(sm,dat) ## generate random coeffients in the unconstrainted ## parameterization... b <- runif(10)*3-2.5 ## exponentiate those parameters indicated by sm$g.index ## to obtain coefficients meeting the constraints... b[sm$g.index] <- exp(b[sm$g.index]) ## plot monotonic spline and its derivative par(mfrow=c(2,2)) plot(x,sm$X\%*\%b,type="l",ylab="f(x)") plot(x,Xd\%*\%b,type="l",ylab="f'(x)") ## repeat for decrease... sspec$mono <- -1 sm1 <- smoothCon(sspec,dat)[[1]] sm1$deriv <- 1 Xd1 <- PredictMat(sm1,dat) plot(x,sm1$X\%*\%b,type="l",ylab="f(x)") plot(x,Xd1\%*\%b,type="l",ylab="f'(x)") ## Now with sum to zero constraints as well... sspec$mono <- 1 sm <- smoothCon(sspec,dat,absorb.cons=TRUE)[[1]] sm$deriv <- 1 Xd <- PredictMat(sm,dat) b <- b[-1] ## dropping first param plot(x,sm$X\%*\%b,type="l",ylab="f(x)") plot(x,Xd\%*\%b,type="l",ylab="f'(x)") sspec$mono <- -1 sm1 <- smoothCon(sspec,dat,absorb.cons=TRUE)[[1]] sm1$deriv <- 1 Xd1 <- PredictMat(sm1,dat) plot(x,sm1$X\%*\%b,type="l",ylab="f(x)") plot(x,Xd1\%*\%b,type="l",ylab="f'(x)") } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/columb.Rd0000644000177400001440000000361012632334033013722 0ustar murdochusers\name{columb} \alias{columb} \alias{columb.polys} \docType{data} %- Also NEED an `\alias' for EACH other topic documented here. \title{Reduced version of Columbus OH crime data} \description{By district crime data from Columbus OH, together with polygons describing district shape. Useful for illustrating use of simple Markov Random Field smoothers. } \usage{ data(columb) data(columb.polys) } %- maybe also `usage' for other objects documented here. \format{ \code{columb} is a 49 row data frame with the following columns \describe{ \item{area}{land area of district} \item{home.value}{housing value in 1000USD.} \item{income}{household income in 1000USD.} \item{crime}{residential burglaries and auto thefts per 1000 households.} \item{open.space}{measure of open space in district.} \item{district}{code identifying district, and matching \code{names(columb.polys)}. } } \code{columb.polys} contains the polygons defining the areas in the format described below. } \details{The data frame \code{columb} relates to the districts whose boundaries are coded in \code{columb.polys}. \code{columb.polys[[i]]} is a 2 column matrix, containing the vertices of the polygons defining the boundary of the ith district. \code{columb.polys[[2]]} has an artificial hole inserted to illustrate how holes in districts can be spefified. Different polygons defining the boundary of a district are separated by NA rows in \code{columb.polys[[1]]}, and a polygon enclosed within another is treated as a hole in that region (a hole should never come first). \code{names(columb.polys)} matches \code{columb$district} (order unimportant). } \source{ The data are adapted from the \code{columbus} example in the \code{spdep} package, where the original source is given as: Anselin, Luc. 1988. Spatial econometrics: methods and models. Dordrecht: Kluwer Academic, Table 12.1 p. 189. } \examples{ ## see ?mrf help files } mgcv/man/smooth.terms.Rd0000744000177400001440000002516312632334033015113 0ustar murdochusers\name{smooth.terms} \alias{smooth.terms} \title{Smooth terms in GAM} \description{ Smooth terms are specified in a \code{\link{gam}} formula using \code{\link{s}}, \code{\link{te}}, \code{\link{ti}} and \code{\link{t2}} terms. Various smooth classes are available, for different modelling tasks, and users can add smooth classes (see \code{\link{user.defined.smooth}}). What defines a smooth class is the basis used to represent the smooth function and quadratic penalty (or multiple penalties) used to penalize the basis coefficients in order to control the degree of smoothness. Smooth classes are invoked directly by \code{s} terms, or as building blocks for tensor product smoothing via \code{te}, \code{ti} or \code{t2} terms (only smooth classes with single penalties can be used in tensor products). The smooths built into the \code{mgcv} package are all based one way or another on low rank versions of splines. For the full rank versions see Wahba (1990). Note that smooths can be used rather flexibly in \code{gam} models. In particular the linear predictor of the GAM can depend on (a discrete approximation to) any linear functional of a smooth term, using \code{by} variables and the `summation convention' explained in \code{\link{linear.functional.terms}}. The single penalty built in smooth classes are summarized as follows \describe{ \item{Thin plate regression splines}{\code{bs="tp"}. These are low rank isotropic smoothers of any number of covariates. By isotropic is meant that rotation of the covariate co-ordinate system will not change the result of smoothing. By low rank is meant that they have far fewer coefficients than there are data to smooth. They are reduced rank versions of the thin plate splines and use the thin plate spline penalty. They are the default smooth for \code{s} terms because there is a defined sense in which they are the optimal smoother of any given basis dimension/rank (Wood, 2003). Thin plate regression splines do not have `knots' (at least not in any conventional sense): a truncated eigen-decomposition is used to achieve the rank reduction. See \code{\link{tprs}} for further details. \code{bs="ts"} is as \code{"tp"} but with a modification to the smoothing penalty, so that the null space is also penalized slightly and the whole term can therefore be shrunk to zero.} \item{Duchon splines}{\code{bs="ds"}. These generalize thin plate splines. In particular, for any given number of covariates they allow lower orders of derivative in the penalty than thin plate splines (and hence a smaller null space). See \code{\link{Duchon.spline}} for further details. } \item{Cubic regression splines}{\code{bs="cr"}. These have a cubic spline basis defined by a modest sized set of knots spread evenly through the covariate values. They are penalized by the conventional intergrated square second derivative cubic spline penalty. For details see \code{\link{cubic.regression.spline}} and e.g. Wood (2006a). \code{bs="cs"} specifies a shrinkage version of \code{"cr"}. \code{bs="cc"} specifies a cyclic cubic regression splines (see \link{cyclic.cubic.spline}). i.e. a penalized cubic regression splines whose ends match, up to second derivative.} \item{Splines on the sphere}{\code{bs="sos"}. These are two dimensional splines on a sphere. Arguments are latitude and longitude, and they are the analogue of thin plate splines for the sphere. Useful for data sampled over a large portion of the globe, when isotropy is appropriate. See \code{\link{Spherical.Spline}} for details.} \item{P-splines}{\code{bs="ps"}. These are P-splines as proposed by Eilers and Marx (1996). They combine a B-spline basis, with a discrete penalty on the basis coefficients, and any sane combination of penalty and basis order is allowed. Although this penalty has no exact interpretation in terms of function shape, in the way that the derivative penalties do, P-splines perform almost as well as conventional splines in many standard applications, and can perform better in particular cases where it is advantageous to mix different orders of basis and penalty. \code{bs="cp"} gives a cyclic version of a P-spline (see \link{cyclic.p.spline}). } \item{Random effects}{\code{bs="re"}. These are parametric terms penalized by a ridge penalty (i.e. the identity matrix). When such a smooth has multiple arguments then it represents the parametric interaction of these arguments, with the coefficients penalized by a ridge penalty. The ridge penalty is equivalent to an assumption that the coefficients are i.i.d. normal random effects. See \code{\link{smooth.construct.re.smooth.spec}}.} \item{Markov Random Fields}{\code{bs="mrf"}. These are popular when space is split up into discrete contiguous geographic units (districts of a town, for example). In this case a simple smoothing penalty is constructed based on the neighbourhood structure of the geographic units. See \code{\link{mrf}} for details and an example.} \item{Gaussian process smooths}{\code{bs="gp"}. Gaussian process models with a variety of simple correlation functions can be represented as smooths. See \code{\link{gp.smooth}} for details.} \item{Soap film smooths}{\code{bs="so"} (actually not single penaltied, but \code{bs="sw"} and \code{bs="sf"} allows splitting into single penalty components for use in tensor product smoothing). These are finite area smoothers designed to smooth within complicated geographical boundaries, where the boundary matters (e.g. you do not want to smooth across boundary features). See \code{\link{soap}} for details.} } Broadly speaking the default penalized thin plate regression splines tend to give the best MSE performance, but they are slower to set up than the other bases. The knot based penalized cubic regression splines (with derivative based penalties) usually come next in MSE performance, with the P-splines doing just a little worse. However the P-splines are useful in non-standard situations. All the preceding classes (and any user defined smooths with single penalties) may be used as marginal bases for tensor product smooths specified via \code{\link{te}}, \code{\link{ti}} or \code{\link{t2}} terms. Tensor product smooths are smooth functions of several variables where the basis is built up from tensor products of bases for smooths of fewer (usually one) variable(s) (marginal bases). The multiple penalties for these smooths are produced automatically from the penalties of the marginal smooths. Wood (2006b) and Wood, Scheipl and Faraway (2012), give the general recipe for these constructions. \describe{ \item{te}{\code{te} smooths have one penalty per marginal basis, each of which is interpretable in a similar way to the marginal penalty from which it is derived. See Wood (2006b).} \item{ti}{\code{ti} smooths exclude the basis functions associated with the `main effects' of the marginal smooths, plus interactions other than the highest order specified. These provide a stable an interpretable way of specifying models with main effects and interactions. For example if we are interested in linear predicto \eqn{f_1(x)+f_2(z)+f_3(x,z)}{f1(x) + f2(z) + f3(x,z)}, we might use model formula \code{y~s(x)+s(z)+ti(x,z)} or \code{y~ti(x)+ti(z)+te(x,z)}. A similar construction involving \code{te} terms instead will be much less statsitically stable.} \item{t2}{\code{t2} uses an alternative tensor product construction that results in more penalties each having a simple non-overlapping structure allowing use with the \code{gamm4} package. It is a natural generalization of the SS-ANOVA construction, but the penalties are a little harder to interpret. See Wood, Scheipl and Faraway (2012/13). } } Tensor product smooths often perform better than isotropic smooths when the covariates of a smooth are not naturally on the same scale, so that their relative scaling is arbitrary. For example, if smoothing with repect to time and distance, an isotropic smoother will give very different results if the units are cm and minutes compared to if the units are metres and seconds: a tensor product smooth will give the same answer in both cases (see \code{\link{te}} for an example of this). Note that \code{te} terms are knot based, and the thin plate splines seem to offer no advantage over cubic or P-splines as marginal bases. Some further specialist smoothers that are not suitable for use in tensor products are also available. \describe{ \item{Adaptive smoothers}{\code{bs="ad"} Univariate and bivariate adaptive smooths are available (see \code{\link{adaptive.smooth}}). These are appropriate when the degree of smoothing should itself vary with the covariates to be smoothed, and the data contain sufficient information to be able to estimate the appropriate variation. Because this flexibility is achieved by splitting the penalty into several `basis penalties' these terms are not suitable as components of tensor product smooths, and are not supported by \code{gamm}.} \item{Factor smooth interactions}{\code{bs="fs"} Smooth factor interactions are often produced using \code{by} variables (see \code{\link{gam.models}}), but a special smoother class (see \code{\link{factor.smooth.interaction}}) is available for the case in which a smooth is required at each of a large number of factor levels (for example a smooth for each patient in a study), and each smooth should have the same smoothing parameter. The \code{"fs"} smoothers are set up to be efficient when used with \code{\link{gamm}}, and have penalties on each null sapce component (i.e. they are fully `random effects'). } } } \seealso{\code{\link{s}}, \code{\link{te}}, \code{\link{t2}} \code{\link{tprs}},\code{\link{Duchon.spline}}, \code{\link{cubic.regression.spline}},\code{\link{p.spline}}, \code{\link{mrf}}, \code{\link{soap}}, \code{\link{Spherical.Spline}}, \code{\link{adaptive.smooth}}, \code{\link{user.defined.smooth}}, \code{\link{smooth.construct.re.smooth.spec}}, \code{\link{smooth.construct.gp.smooth.spec}},\code{\link{factor.smooth.interaction}}} \author{ Simon Wood } \references{ Eilers, P.H.C. and B.D. Marx (1996) Flexible Smoothing with B-splines and Penalties. Statistical Science, 11(2):89-121 Wahba (1990) Spline Models of Observational Data. SIAM Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 Wood, S.N. (2006a) \emph{Generalized Additive Models: an introduction with R}, CRC Wood, S.N. (2006b) Low rank scale invariant tensor product smooths for generalized additive mixed models. Biometrics 62(4):1025-1036 Wood S.N., F. Scheipl and J.J. Faraway (2013) Straightforward intermediate rank tensor product smoothing in mixed models. Statistical Computing. 23(3), 341-360. [online 2012] } \examples{ ## see examples for gam and gamm } \keyword{regression}mgcv/man/gamm.Rd0000755000177400001440000004127612763515204013405 0ustar murdochusers\name{gamm} \alias{gamm} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generalized Additive Mixed Models} \description{ Fits the specified generalized additive mixed model (GAMM) to data, by a call to \code{lme} in the normal errors identity link case, or by a call to \code{gammPQL} (a modification of \code{glmmPQL} from the \code{MASS} library) otherwise. In the latter case estimates are only approximately MLEs. The routine is typically slower than \code{gam}, and not quite as numerically robust. To use \code{lme4} in place of \code{nlme} as the underlying fitting engine, see \code{gamm4} from package \code{gamm4}. Smooths are specified as in a call to \code{\link{gam}} as part of the fixed effects model formula, but the wiggly components of the smooth are treated as random effects. The random effects structures and correlation structures availabale for \code{lme} are used to specify other random effects and correlations. It is assumed that the random effects and correlation structures are employed primarily to model residual correlation in the data and that the prime interest is in inference about the terms in the fixed effects model formula including the smooths. For this reason the routine calculates a posterior covariance matrix for the coefficients of all the terms in the fixed effects formula, including the smooths. To use this function effectively it helps to be quite familiar with the use of \code{\link{gam}} and \code{\link[nlme]{lme}}. } \usage{ gamm(formula,random=NULL,correlation=NULL,family=gaussian(), data=list(),weights=NULL,subset=NULL,na.action,knots=NULL, control=list(niterEM=0,optimMethod="L-BFGS-B"), niterPQL=20,verbosePQL=TRUE,method="ML",drop.unused.levels=TRUE,...) } \arguments{ \item{formula}{ A GAM formula (see also \code{\link{formula.gam}} and \code{\link{gam.models}}). This is like the formula for a \code{glm} except that smooth terms (\code{\link{s}} and \code{\link{te}}) can be added to the right hand side of the formula. Note that \code{id}s for smooths and fixed smoothing parameters are not supported.} \item{random}{The (optional) random effects structure as specified in a call to \code{\link[nlme]{lme}}: only the \code{list} form is allowed, to facilitate manipulation of the random effects structure within \code{gamm} in order to deal with smooth terms. See example below.} \item{correlation}{An optional \code{corStruct} object (see \code{\link[nlme]{corClasses}}) as used to define correlation structures in \code{\link[nlme]{lme}}. Any grouping factors in the formula for this object are assumed to be nested within any random effect grouping factors, without the need to make this explicit in the formula (this is slightly different to the behaviour of \code{lme}). This is a GEE approach to correlation in the generalized case. See examples below.} \item{family}{A \code{family} as used in a call to \code{\link{glm}} or \code{\link{gam}}. The default \code{gaussian} with identity link causes \code{gamm} to fit by a direct call to \code{\link[nlme]{lme}} procided there is no offset term, otherwise \code{gammPQL} is used.} \item{data}{ A data frame or list containing the model response variable and covariates required by the formula. By default the variables are taken from \code{environment(formula)}, typically the environment from which \code{gamm} is called.} \item{weights}{In the generalized case, weights with the same meaning as \code{\link{glm}} weights. An \code{lme} type weights argument may only be used in the identity link gaussian case, with no offset (see documentation for \code{lme} for details of how to use such an argument).} \item{subset}{ an optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{ a function which indicates what should happen when the data contain `NA's. The default is set by the `na.action' setting of `options', and is `na.fail' if that is unset. The ``factory-fresh'' default is `na.omit'.} \item{knots}{this is an optional list containing user specified knot values to be used for basis construction. Different terms can use different numbers of knots, unless they share a covariate. } \item{control}{A list of fit control parameters for \code{\link[nlme]{lme}} to replace the defaults returned by \code{\link[nlme]{lmeControl}}. Note the setting for the number of EM iterations used by \code{lme}: smooths are set up using custom \code{pdMat} classes, which are currently not supported by the EM iteration code. If you supply a list of control values, it is advisable to include \code{niterEM=0}, as well, and only increase from 0 if you want to perturb the starting values used in model fitting (usually to worse values!). The \code{optimMethod} option is only used if your version of R does not have the \code{nlminb} optimizer function.} \item{niterPQL}{Maximum number of PQL iterations (if any).} \item{verbosePQL}{Should PQL report its progress as it goes along?} \item{method}{Which of \code{"ML"} or \code{"REML"} to use in the Gaussian additive mixed model case when \code{lme} is called directly. Ignored in the generalized case (or if the model has an offset), in which case \code{gammPQL} is used.} \item{drop.unused.levels}{by default unused levels are dropped from factors before fitting. For some smooths involving factor variables you might want to turn this off. Only do so if you know what you are doing.} \item{...}{further arguments for passing on e.g. to \code{lme}} } %- maybe also `usage' for other objects documented here. \details{ The Bayesian model of spline smoothing introduced by Wahba (1983) and Silverman (1985) opens up the possibility of estimating the degree of smoothness of terms in a generalized additive model as variances of the wiggly components of the smooth terms treated as random effects. Several authors have recognised this (see Wang 1998; Ruppert, Wand and Carroll, 2003) and in the normal errors, identity link case estimation can be performed using general linear mixed effects modelling software such as \code{lme}. In the generalized case only approximate inference is so far available, for example using the Penalized Quasi-Likelihood approach of Breslow and Clayton (1993) as implemented in \code{glmmPQL} by Venables and Ripley (2002). One advantage of this approach is that it allows correlated errors to be dealt with via random effects or the correlation structures available in the \code{nlme} library (using correlation structures beyond the strictly additive case amounts to using a GEE approach to fitting). Some details of how GAMs are represented as mixed models and estimated using \code{lme} or \code{gammPQL} in \code{gamm} can be found in Wood (2004 ,2006a,b). In addition \code{gamm} obtains a posterior covariance matrix for the parameters of all the fixed effects and the smooth terms. The approach is similar to that described in Lin & Zhang (1999) - the covariance matrix of the data (or pseudodata in the generalized case) implied by the weights, correlation and random effects structure is obtained, based on the estimates of the parameters of these terms and this is used to obtain the posterior covariance matrix of the fixed and smooth effects. The bases used to represent smooth terms are the same as those used in \code{\link{gam}}, although adaptive smoothing bases are not available. Prediction from the returned \code{gam} object is straightforward using \code{\link{predict.gam}}, but this will set the random effects to zero. If you want to predict with random effects set to their predicted values then you can adapt the prediction code given in the examples below. In the event of \code{lme} convergence failures, consider modifying \code{option(mgcv.vc.logrange)}: reducing it helps to remove indefiniteness in the likelihood, if that is the problem, but too large a reduction can force over or undersmoothing. See \code{\link{notExp2}} for more information on this option. Failing that, you can try increasing the \code{niterEM} option in \code{control}: this will perturb the starting values used in fitting, but usually to values with lower likelihood! Note that this version of \code{gamm} works best with R 2.2.0 or above and \code{nlme}, 3.1-62 and above, since these use an improved optimizer. } \value{ Returns a list with two items: \item{gam}{an object of class \code{gam}, less information relating to GCV/UBRE model selection. At present this contains enough information to use \code{predict}, \code{summary} and \code{print} methods and \code{vis.gam}, but not to use e.g. the \code{anova} method function to compare models.} \item{lme}{the fitted model object returned by \code{lme} or \code{gammPQL}. Note that the model formulae and grouping structures may appear to be rather bizarre, because of the manner in which the GAMM is split up and the calls to \code{lme} and \code{gammPQL} are constructed.} } \references{ Breslow, N. E. and Clayton, D. G. (1993) Approximate inference in generalized linear mixed models. Journal of the American Statistical Association 88, 9-25. Lin, X and Zhang, D. (1999) Inference in generalized additive mixed models by using smoothing splines. JRSSB. 55(2):381-400 Pinheiro J.C. and Bates, D.M. (2000) Mixed effects Models in S and S-PLUS. Springer Ruppert, D., Wand, M.P. and Carroll, R.J. (2003) Semiparametric Regression. Cambridge Silverman, B.W. (1985) Some aspects of the spline smoothing approach to nonparametric regression. JRSSB 47:1-52 Venables, W. N. and Ripley, B. D. (2002) Modern Applied Statistics with S. Fourth edition. Springer. Wahba, G. (1983) Bayesian confidence intervals for the cross validated smoothing spline. JRSSB 45:133-150 Wood, S.N. (2004) Stable and efficient multiple smoothing parameter estimation for generalized additive models. Journal of the American Statistical Association. 99:673-686 Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 Wood, S.N. (2006a) Low rank scale invariant tensor product smooths for generalized additive mixed models. Biometrics 62(4):1025-1036 Wood S.N. (2006b) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. Wang, Y. (1998) Mixed effects smoothing spline analysis of variance. J.R. Statist. Soc. B 60, 159-174 \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \section{WARNINGS }{ \code{gamm} was a somewhat different argument list to \code{\link{gam}}, \code{gam} arguments such as \code{gamma} supplied to \code{gamm} will just be ignored. \code{gamm} performs poorly with binary data, since it uses PQL. It is better to use \code{gam} with \code{s(...,bs="re")} terms, or \code{gamm4}. \code{gamm} assumes that you know what you are doing! For example, unlike \code{glmmPQL} from \code{MASS} it will return the complete \code{lme} object from the working model at convergence of the PQL iteration, including the `log likelihood', even though this is not the likelihood of the fitted GAMM. The routine will be very slow and memory intensive if correlation structures are used for the very large groups of data. e.g. attempting to run the spatial example in the examples section with many 1000's of data is definitely not recommended: often the correlations should only apply within clusters that can be defined by a grouping factor, and provided these clusters do not get too huge then fitting is usually possible. Models must contain at least one random effect: either a smooth with non-zero smoothing parameter, or a random effect specified in argument \code{random}. \code{gamm} is not as numerically stable as \code{gam}: an \code{lme} call will occasionally fail. See details section for suggestions, or try the `gamm4' package. \code{gamm} is usually much slower than \code{gam}, and on some platforms you may need to increase the memory available to R in order to use it with large data sets (see \code{\link{memory.limit}}). Note that the weights returned in the fitted GAM object are dummy, and not those used by the PQL iteration: this makes partial residual plots look odd. Note that the \code{gam} object part of the returned object is not complete in the sense of having all the elements defined in \code{\link{gamObject}} and does not inherit from \code{glm}: hence e.g. multi-model \code{anova} calls will not work. The parameterization used for the smoothing parameters in \code{gamm}, bounds them above and below by an effective infinity and effective zero. See \code{\link{notExp2}} for details of how to change this. Linked smoothing parameters and adaptive smoothing are not supported. } \seealso{\code{\link{magic}} for an alternative for correlated data, \code{\link{te}}, \code{\link{s}}, \code{\link{predict.gam}}, \code{\link{plot.gam}}, \code{\link{summary.gam}}, \code{\link{negbin}}, \code{\link{vis.gam}},\code{\link{pdTens}}, \code{gamm4} ( \url{https://cran.r-project.org/package=gamm4}) } \examples{ library(mgcv) ## simple examples using gamm as alternative to gam set.seed(0) dat <- gamSim(1,n=200,scale=2) b <- gamm(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat) plot(b$gam,pages=1) summary(b$lme) # details of underlying lme fit summary(b$gam) # gam style summary of fitted model anova(b$gam) gam.check(b$gam) # simple checking plots b <- gamm(y~te(x0,x1)+s(x2)+s(x3),data=dat) op <- par(mfrow=c(2,2)) plot(b$gam) par(op) rm(dat) ## Add a factor to the linear predictor, to be modelled as random dat <- gamSim(6,n=200,scale=.2,dist="poisson") b2<-gamm(y~s(x0)+s(x1)+s(x2),family=poisson, data=dat,random=list(fac=~1)) plot(b2$gam,pages=1) fac <- dat$fac rm(dat) vis.gam(b2$gam) ## now an example with autocorrelated errors.... n <- 200;sig <- 2 x <- 0:(n-1)/(n-1) f <- 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 e <- rnorm(n,0,sig) for (i in 2:n) e[i] <- 0.6*e[i-1] + e[i] y <- f + e op <- par(mfrow=c(2,2)) ## Fit model with AR1 residuals b <- gamm(y~s(x,k=20),correlation=corAR1()) plot(b$gam);lines(x,f-mean(f),col=2) ## Raw residuals still show correlation, of course... acf(residuals(b$gam),main="raw residual ACF") ## But standardized are now fine... acf(residuals(b$lme,type="normalized"),main="standardized residual ACF") ## compare with model without AR component... b <- gam(y~s(x,k=20)) plot(b);lines(x,f-mean(f),col=2) ## more complicated autocorrelation example - AR errors ## only within groups defined by `fac' e <- rnorm(n,0,sig) for (i in 2:n) e[i] <- 0.6*e[i-1]*(fac[i-1]==fac[i]) + e[i] y <- f + e b <- gamm(y~s(x,k=20),correlation=corAR1(form=~1|fac)) plot(b$gam);lines(x,f-mean(f),col=2) par(op) ## more complex situation with nested random effects and within ## group correlation set.seed(0) n.g <- 10 n<-n.g*10*4 ## simulate smooth part... dat <- gamSim(1,n=n,scale=2) f <- dat$f ## simulate nested random effects.... fa <- as.factor(rep(1:10,rep(4*n.g,10))) ra <- rep(rnorm(10),rep(4*n.g,10)) fb <- as.factor(rep(rep(1:4,rep(n.g,4)),10)) rb <- rep(rnorm(4),rep(n.g,4)) for (i in 1:9) rb <- c(rb,rep(rnorm(4),rep(n.g,4))) ## simulate auto-correlated errors within groups e<-array(0,0) for (i in 1:40) { eg <- rnorm(n.g, 0, sig) for (j in 2:n.g) eg[j] <- eg[j-1]*0.6+ eg[j] e<-c(e,eg) } dat$y <- f + ra + rb + e dat$fa <- fa;dat$fb <- fb ## fit model .... b <- gamm(y~s(x0,bs="cr")+s(x1,bs="cr")+s(x2,bs="cr")+ s(x3,bs="cr"),data=dat,random=list(fa=~1,fb=~1), correlation=corAR1()) plot(b$gam,pages=1) summary(b$gam) vis.gam(b$gam) ## Prediction from gam object, optionally adding ## in random effects. ## Extract random effects and make names more convenient... refa <- ranef(b$lme,level=5) rownames(refa) <- substr(rownames(refa),start=9,stop=20) refb <- ranef(b$lme,level=6) rownames(refb) <- substr(rownames(refb),start=9,stop=20) ## make a prediction, with random effects zero... p0 <- predict(b$gam,data.frame(x0=.3,x1=.6,x2=.98,x3=.77)) ## add in effect for fa = "2" and fb="2/4"... p <- p0 + refa["2",1] + refb["2/4",1] ## and a "spatial" example... library(nlme);set.seed(1);n <- 100 dat <- gamSim(2,n=n,scale=0) ## standard example attach(dat) old.par<-par(mfrow=c(2,2)) contour(truth$x,truth$z,truth$f) ## true function f <- data$f ## true expected response ## Now simulate correlated errors... cstr <- corGaus(.1,form = ~x+z) cstr <- Initialize(cstr,data.frame(x=data$x,z=data$z)) V <- corMatrix(cstr) ## correlation matrix for data Cv <- chol(V) e <- t(Cv) \%*\% rnorm(n)*0.05 # correlated errors ## next add correlated simulated errors to expected values data$y <- f + e ## ... to produce response b<- gamm(y~s(x,z,k=50),correlation=corGaus(.1,form=~x+z), data=data) plot(b$gam) # gamm fit accounting for correlation # overfits when correlation ignored..... b1 <- gamm(y~s(x,z,k=50),data=data);plot(b1$gam) b2 <- gam(y~s(x,z,k=50),data=data);plot(b2) par(old.par) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/smooth2random.Rd0000755000177400001440000000504212723261477015255 0ustar murdochusers\name{smooth2random} \alias{smooth2random} %- Also NEED an `\alias' for EACH other topic documented here. \title{Convert a smooth to a form suitable for estimating as random effect} \description{A generic function for converting \code{mgcv} smooth objects to forms suitable for estimation as random effects by e.g. \code{lme}. Exported mostly for use by other package developers. } \usage{ smooth2random(object,vnames,type=1) %\method{summary}{gam}(object, dispersion=NULL, freq=FALSE, p.type = 0, ...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{an \code{mgcv} smooth object.} \item{vnames}{a vector of names to avoid as dummy variable names in the random effects form.} \item{type}{\code{1} for \code{lme}, otherwise \code{lmer}.} } \details{There is a duality between smooths and random effects which means that smooths can be estimated using mixed modelling software. This function converts standard \code{mgcv} smooth objects to forms suitable for estimation by \code{lme}, for example. A service routine for \code{\link{gamm}} exported for use by package developers. } \value{A list. \item{rand}{ a list of random effects, including grouping factors, and a fixed effects matrix. Grouping factors, model matrix and model matrix name attached as attributes, to each element.} \item{trans.D}{A vector, trans.D, that transforms coefs, in order [rand1, rand2,... fix] back to original parameterization. If null, then taken as vector of ones. \code{b.original = trans.U \%*\% (trans.D*b.fit)}.} \item{trans.U}{A matrix, trans.U, that transforms coefs, in order [rand1, rand2,... fix] back to original parameterization. If null, then not needed. If null then taken as identity.} \item{Xf}{A matrix for the fixed effects, if any.} \item{fixed}{\code{TRUE/FALSE}, indicating if term was unpenalized or not. If unpenalized then other stuff may not be returned (it's not a random effect).} \item{rind}{an index vector such that if br is the vector of random coefficients for the term, br[rind] is the coefs in order for this term. } \item{pen.ind}{index of which penalty penalizes each coefficient: 0 for unpenalized.} } \references{ Wood S.N. (2006) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org}.} \seealso{ \code{\link{gamm}} } \examples{ library(mgcv) x <- runif(30) sm <- smoothCon(s(x),data.frame(x=x))[[1]] smooth2random(sm,"") } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/gam.selection.Rd0000744000177400001440000002173612632334033015203 0ustar murdochusers\name{gam.selection} \alias{gam.selection} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generalized Additive Model Selection} \description{ This page is intended to provide some more information on how to select GAMs. In particular, it gives a brief overview of smoothness selection, and then discusses how this can be extended to select inclusion/exclusion of terms. Hypothesis testing approaches to the latter problem are also discussed. } \section{Smoothness selection criteria}{ Given a model structure specified by a gam model formula, \code{gam()} attempts to find the appropriate smoothness for each applicable model term using prediction error criteria or likelihood based methods. The prediction error criteria used are Generalized (Approximate) Cross Validation (GCV or GACV) when the scale parameter is unknown or an Un-Biased Risk Estimator (UBRE) when it is known. UBRE is essentially scaled AIC (Generalized case) or Mallows' Cp (additive model case). GCV and UBRE are covered in Craven and Wahba (1979) and Wahba (1990). Alternatively REML of maximum likelihood (ML) may be used for smoothness selection, by viewing the smooth components as random effects (in this case the variance component for each smooth random effect will be given by the scale parameter divided by the smoothing parameter --- for smooths with multiple penalties, there will be multiple variance components). The \code{method} argument to \code{\link{gam}} selects the smoothness selection criterion. Automatic smoothness selection is unlikely to be successful with few data, particularly with multiple terms to be selected. In addition GCV and UBRE/AIC score can occasionally display local minima that can trap the minimisation algorithms. GCV/UBRE/AIC scores become constant with changing smoothing parameters at very low or very high smoothing parameters, and on occasion these `flat' regions can be separated from regions of lower score by a small `lip'. This seems to be the most common form of local minimum, but is usually avoidable by avoiding extreme smoothing parameters as starting values in optimization, and by avoiding big jumps in smoothing parameters while optimizing. Never the less, if you are suspicious of smoothing parameter estimates, try changing fit method (see \code{\link{gam}} arguments \code{method} and \code{optimizer}) and see if the estimates change, or try changing some or all of the smoothing parameters `manually' (argument \code{sp} of \code{\link{gam}}, or \code{sp} arguments to \code{\link{s}} or \code{\link{te}}). REML and ML are less prone to local minima than the other criteria, and may therefore be preferable. } \section{Automatic term selection}{ Unmodified smoothness selection by GCV, AIC, REML etc. will not usually remove a smooth from a model. This is because most smoothing penalties view some space of (non-zero) functions as `completely smooth' and once a term is penalized heavily enough that it is in this space, further penalization does not change it. However it is straightforward to modify smooths so that under heavy penalization they are penalized to the zero function and thereby `selected out' of the model. There are two approaches. The first approach is to modify the smoothing penalty with an additional shrinkage term. Smooth classes\code{cs.smooth} and \code{tprs.smooth} (specified by \code{"cs"} and \code{"ts"} respectively) have smoothness penalties which include a small shrinkage component, so that for large enough smoothing parameters the smooth becomes identically zero. This allows automatic smoothing parameter selection methods to effectively remove the term from the model altogether. The shrinkage component of the penalty is set at a level that usually makes negligable contribution to the penalization of the model, only becoming effective when the term is effectively `completely smooth' according to the conventional penalty. The second approach leaves the original smoothing penalty unchanged, but constructs an additional penalty for each smooth, which penalizes only functions in the null space of the original penalty (the `completely smooth' functions). Hence, if all the smoothing parameters for a term tend to infinity, the term will be selected out of the model. This latter approach is more expensive computationally, but has the advantage that it can be applied automatically to any smooth term. The \code{select} argument to \code{\link{gam}} turns on this method. In fact, as implemented, both approaches operate by eigen-decomposiong the original penalty matrix. A new penalty is created on the null space: it is the matrix with the same eigenvectors as the original penalty, but with the originally postive egienvalues set to zero, and the originally zero eigenvalues set to something positive. The first approach just addes a multiple of this penalty to the original penalty, where the multiple is chosen so that the new penalty can not dominate the original. The second approach treats the new penalty as an extra penalty, with its own smoothing parameter. Of course, as with all model selection methods, some care must be take to ensure that the automatic selection is sensible, and a decision about the effective degrees of freedom at which to declare a term `negligible' has to be made. } \section{Interactive term selection}{ In general the most logically consistent method to use for deciding which terms to include in the model is to compare GCV/UBRE/ML scores for models with and without the term (REML scores should not be used to compare models with different fixed effects structures). When UBRE is the smoothness selection method this will give the same result as comparing by \code{\link{AIC}} (the AIC in this case uses the model EDF in place of the usual model DF). Similarly, comparison via GCV score and via AIC seldom yields different answers. Note that the negative binomial with estimated \code{theta} parameter is a special case: the GCV score is not informative, because of the \code{theta} estimation scheme used. More generally the score for the model with a smooth term can be compared to the score for the model with the smooth term replaced by appropriate parametric terms. Candidates for replacement by parametric terms are smooth terms with estimated degrees of freedom close to their minimum possible. Candidates for removal can also be identified by reference to the approximate p-values provided by \code{summary.gam}, and by looking at the extent to which the confidence band for an estimated term includes the zero function. It is perfectly possible to perform backwards selection using p-values in the usual way: that is by sequentially dropping the single term with the highest non-significant p-value from the model and re-fitting, until all terms are significant. This suffers from the same problems as stepwise procedures for any GLM/LM, with the additional caveat that the p-values are only approximate. If adopting this approach, it is probably best to use ML smoothness selection. Note that GCV and UBRE are not appropriate for comparing models using different families: in that case AIC should be used. } \section{Caveats/platitudes}{ Formal model selection methods are only appropriate for selecting between reasonable models. If formal model selection is attempted starting from a model that simply doesn't fit the data, then it is unlikely to provide meaningful results. The more thought is given to appropriate model structure up front, the more successful model selection is likely to be. Simply starting with a hugely flexible model with `everything in' and hoping that automatic selection will find the right structure is not often successful. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Marra, G. and S.N. Wood (2011) Practical variable selection for generalized additive models. Computational Statistics and Data Analysis 55,2372-2387. Craven and Wahba (1979) Smoothing Noisy Data with Spline Functions. Numer. Math. 31:377-403 Venables and Ripley (1999) Modern Applied Statistics with S-PLUS Wahba (1990) Spline Models of Observational Data. SIAM. Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 Wood, S.N. (2008) Fast stable direct fitting and smoothness selection for generalized additive models. J.R.Statist. Soc. B 70(3):495-518 Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 \url{http://www.maths.bris.ac.uk/~sw15190/} } \seealso{\code{\link{gam}}, \code{\link{step.gam}}} \examples{ ## an example of automatic model selection via null space penalization library(mgcv) set.seed(3);n<-200 dat <- gamSim(1,n=n,scale=.15,dist="poisson") ## simulate data dat$x4 <- runif(n, 0, 1);dat$x5 <- runif(n, 0, 1) ## spurious b<-gam(y~s(x0)+s(x1)+s(x2)+s(x3)+s(x4)+s(x5),data=dat, family=poisson,select=TRUE,method="REML") summary(b) plot(b,pages=1) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/mono.con.Rd0000744000177400001440000000360212632334033014171 0ustar murdochusers\name{mono.con} \alias{mono.con} \title{Monotonicity constraints for a cubic regression spline} \description{ Finds linear constraints sufficient for monotonicity (and optionally upper and/or lower boundedness) of a cubic regression spline. The basis representation assumed is that given by the \code{gam}, \code{"cr"} basis: that is the spline has a set of knots, which have fixed x values, but the y values of which constitute the parameters of the spline. } \usage{ mono.con(x,up=TRUE,lower=NA,upper=NA) } \arguments{ \item{x}{The array of knot locations.} \item{up}{If \code{TRUE} then the constraints imply increase, if \code{FALSE} then decrease. } \item{lower}{This specifies the lower bound on the spline unless it is \code{NA} in which case no lower bound is imposed.} \item{upper}{This specifies the upper bound on the spline unless it is \code{NA} in which case no upper bound is imposed.} } \details{ Consider the natural cubic spline passing through the points \eqn{ \{x_i,p_i:i=1 \ldots n \} }{ (x_i,p_i), i=1..n}. Then it is possible to find a relatively small set of linear constraints on \eqn{\mathbf{p}}{p} sufficient to ensure monotonicity (and bounds if required): \eqn{\mathbf{Ap}\ge\mathbf{b}}{Ap >= b}. Details are given in Wood (1994). } \value{ a list containing constraint matrix \code{A} and constraint vector \code{b}. } \references{ Gill, P.E., Murray, W. and Wright, M.H. (1981) \emph{Practical Optimization}. Academic Press, London. Wood, S.N. (1994) Monotonic smoothing splines fitted by cross validation. \emph{SIAM Journal on Scientific Computing} \bold{15}(5), 1126--1133. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \seealso{ \code{\link{magic}}, \code{\link{pcls}} } \examples{ ## see ?pcls } \keyword{models} \keyword{smooth} \keyword{regression} %-- one or more .. mgcv/man/Tweedie.Rd0000744000177400001440000001175112725500726014044 0ustar murdochusers\name{Tweedie} \alias{Tweedie} \alias{tw} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM Tweedie families} \description{Tweedie families, designed for use with \code{\link{gam}} from the \code{mgcv} library. Restricted to variance function powers between 1 and 2. A useful alternative to \code{\link{quasi}} when a full likelihood is desirable. \code{Tweedie} is for use with fixed \code{p}. \code{tw} is for use when \code{p} is to be estimated during fitting. For fixed \code{p} between 1 and 2 the Tweedie is an exponential family distribution with variance given by the mean to the power \code{p}. \code{tw} is only useable with \code{\link{gam}}, not \code{bam} or \code{gamm}. \code{Tweedie} works with all three. } \usage{ Tweedie(p=1, link = power(0)) tw(theta = NULL, link = "log",a=1.01,b=1.99) } \arguments{ \item{p}{the variance of an observation is proportional to its mean to the power \code{p}. \code{p} must be greater than 1 and less than or equal to 2. 1 would be Poisson, 2 is gamma. } \item{link}{The link function: one of \code{"log"}, \code{"identity"}, \code{"inverse"}, \code{"sqrt"}, or a \code{\link{power}} link (\code{Tweedie} only).} \item{theta}{Related to the Tweedie power parameter by \eqn{p=\exp(a+b \exp(\theta))/(1+\exp(\theta))}{p=exp(a+b*exp(theta))/(1+exp(theta))}. If this is supplied as a positive value then it is taken as the fixed value for \code{p}. If it is a negative values then its absolute value is taken as the initial value for \code{p}.} \item{a}{lower limit on \code{p} for optimization.} \item{b}{upper limit on \code{p} for optimization.} } \value{ For \code{Tweedie}, an object inheriting from class \code{family}, with additional elements \item{dvar}{the function giving the first derivative of the variance function w.r.t. \code{mu}.} \item{d2var}{the function giving the second derivative of the variance function w.r.t. \code{mu}.} \item{ls}{A function returning a 3 element array: the saturated log likelihood followed by its first 2 derivatives w.r.t. the scale parameter.} For \code{tw}, an object of class \code{extended.family}. } \details{ A Tweedie random variable with 10}{r>0} be the range parameter, \eqn{0 < \kappa\le 2 }{0 } \examples{ ## The example takes a couple of minutes to run, so is marked ## don't run to save CRAN time. \dontrun{ require(mgcv) par(mfrow=c(4,4),mar=c(4,4,1,1)) for (sim in c(1,7)) { ## cycle over uncorrelated and correlated covariates n <- 350;set.seed(2) ## simulate data but randomly drop 300 covariate measurements ## leaving only 50 complete cases... dat <- gamSim(sim,n=n,scale=3) ## 1 or 7 drop <- sample(1:n,300) ## to for (i in 2:5) dat[drop[1:75+(i-2)*75],i] <- NA ## process data.frame producing binary indicators of missingness, ## mx0, mx1 etc. For each missing value create a level of a factor ## idx0, idx1, etc. So idx0 has as many levels as x0 has missing ## values. Replace the NA's in each variable by the mean of the ## non missing for that variable... dname <- names(dat)[2:5] dat1 <- dat for (i in 1:4) { by.name <- paste("m",dname[i],sep="") dat1[[by.name]] <- is.na(dat1[[dname[i]]]) dat1[[dname[i]]][dat1[[by.name]]] <- mean(dat1[[dname[i]]],na.rm=TRUE) lev <- rep(1,n);lev[dat1[[by.name]]] <- 1:sum(dat1[[by.name]]) id.name <- paste("id",dname[i],sep="") dat1[[id.name]] <- factor(lev) dat1[[by.name]] <- as.numeric(dat1[[by.name]]) } ## Fit a gam, in which any missing value contributes zero ## to the linear predictor from its smooth, but each ## missing has its own random effect, with the random effect ## variances being specific to the variable. e.g. ## for s(x0,by=ordered(!mx0)), declaring the `by' as an ordered ## factor ensures that the smooth is centred, but multiplied ## by zero when mx0 is one (indicating a missing x0). This means ## that any value (within range) can be put in place of the ## NA for x0. s(idx0,bs="re",by=mx0) produces a separate Gaussian ## random effect for each missing value of x0 (in place of s(x0), ## effectively). The `by' variable simply sets the random effect to ## zero when x0 is non-missing, so that we can set idx0 to any ## existing level for these cases. b <- gam(y~s(x0,by=ordered(!mx0))+s(x1,by=ordered(!mx1))+ s(x2,by=ordered(!mx2))+s(x3,by=ordered(!mx3))+ s(idx0,bs="re",by=mx0)+s(idx1,bs="re",by=mx1)+ s(idx2,bs="re",by=mx2)+s(idx3,bs="re",by=mx3) ,data=dat1,method="REML") for (i in 1:4) plot(b,select=i) ## plot the smooth effects from b ## fit the model to the `complete case' data... b2 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat,method="REML") plot(b2) ## plot the complete case results } } } \keyword{regression}mgcv/man/smooth.construct.Rd0000744000177400001440000003462712632334033016012 0ustar murdochusers \name{smooth.construct} \alias{smooth.construct} \alias{smooth.construct2} \alias{user.defined.smooth} %- Also NEED an `\alias' for EACH other topic documented here. \title{Constructor functions for smooth terms in a GAM} \description{Smooth terms in a GAM formula are turned into smooth specification objects of class \code{xx.smooth.spec} during processing of the formula. Each of these objects is converted to a smooth object using an appropriate \code{smooth.construct} function. New smooth classes can be added by writing a new \code{smooth.construct} method function and a corresponding \code{\link{Predict.matrix}} method function (see example code below). In practice, \code{smooth.construct} is usually called via \code{smooth.construct2} and the wrapper function \code{\link{smoothCon}}, in order to handle \code{by} variables and centering constraints (see the \code{\link{smoothCon}} documentation if you need to handle these things directly, for a user defined smooth class). } \usage{ smooth.construct(object,data,knots) smooth.construct2(object,data,knots) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ is a smooth specification object, generated by an \code{\link{s}} or \code{\link{te}} term in a GAM formula. Objects generated by \code{s} terms have class \code{xx.smooth.spec} where \code{xx} is given by the \code{bs} argument of \code{s} (this convention allows the user to add their own smoothers). If \code{object} is not class \code{tensor.smooth.spec} it will have the following elements: \describe{ \item{term}{The names of the covariates for this smooth, in an array.} \item{bs.dim}{ Argument \code{k} of the \code{s} term generating the object. This is the dimension of the basis used to represent the term (or, arguably, 1 greater than the basis dimension for \code{cc} terms). \code{bs.dim<0} indicates that the constructor should set this to the default value.} \item{fixed}{\code{TRUE} if the term is to be unpenalized, otherwise \code{FALSE}.} \item{dim}{the number covariates of which this smooth is a function.} \item{p.order}{the order of the smoothness penalty or \code{NA} for autoselection of this. This is argument \code{m} of the \code{s} term that generated \code{object}.} \item{by}{the name of any \code{by} variable to multiply this term as supplied as an argument to \code{s}. \code{"NA"} if there is no such term.} \item{label}{A suitable label for use with this term.} \item{xt}{An object containing information that may be needed for basis setup (used, e.g. by \code{"tp"} smooths to pass optional information on big dataset handling).} \item{id}{Any identity associated with this term --- used for linking bases and smoothing parameters. \code{NULL} by default, indicating no linkage.} \item{sp}{Smoothing parameters for the term. Any negative are estimated, otherwise they are fixed at the supplied value. Unless \code{NULL} (default), over-rides \code{sp} argument to \code{\link{gam}}.} } If \code{object} is of class \code{tensor.smooth.spec} then it was generated by a \code{te} term in the GAM formula, and specifies a smooth of several variables with a basis generated as a tensor product of lower dimensional bases. In this case the object will be different and will have the following elements: \describe{ \item{margin}{is a list of smooth specification objects of the type listed above, defining the bases which have their tensor product formed in order to construct this term.} \item{term}{is the array of names of the covariates that are arguments of the smooth.} \item{by}{is the name of any \code{by} variable, or \code{"NA"}.} \item{fx}{is an array, the elements of which indicate whether (\code{TRUE}) any of the margins in the tensor product should be unpenalized.} \item{label}{A suitable label for use with this term.} \item{dim}{is the number of covariates of which this smooth is a function.} \item{mp}{\code{TRUE} if multiple penalties are to be used.} \item{np}{\code{TRUE} if 1-D marginal smooths are to be re-parameterized in terms of function values.} \item{id}{Any identity associated with this term --- used for linking bases and smoothing parameters. \code{NULL} by default, indicating no linkage.} \item{sp}{Smoothing parameters for the term. Any negative are estimated, otherwise they are fixed at the supplied value. Unless \code{NULL} (default), over-rides \code{sp} argument to \code{\link{gam}}.} }} \item{data}{For \code{smooth.construct} a data frame or list containing the evaluation of the elements of \code{object$term}, with names given by \code{object$term}. The last entry will be the \code{by} variable, if \code{object$by} is not \code{"NA"}. For \code{smooth.construct2} \code{data} need only be an object within which \code{object$term} can be evaluated, the variables can be in any order, and there can be irrelevant variables present as well. } \item{knots}{an optional data frame or list containing the knots relating to \code{object$term}. If it is \code{NULL} then the knot locations are generated automatically. The structure of \code{knots} should be as for \code{data}, depending on whether \code{smooth.construct} or \code{smooth.construct2} is used.} } \value{ The input argument \code{object}, assigned a new class to indicate what type of smooth it is and with at least the following items added: \item{X}{The model matrix from this term. This may have an \code{"offset"} attribute: a vector of length \code{nrow(X)} containing any contribution of the smooth to the model offset term. \code{by} variables do not need to be dealt with here, but if they are then an item \code{by.done} must be added to the \code{object}.} \item{S}{A list of positive semi-definite penalty matrices that apply to this term. The list will be empty if the term is to be left un-penalized.} \item{rank}{An array giving the ranks of the penalties.} \item{null.space.dim}{The dimension of the penalty null space (before centering).} The following items may be added: \item{C}{The matrix defining any identifiability constraints on the term, for use when fitting. If this is \code{NULL} then \code{smoothCon} will add an identifiability constraint that each term should sum to zero over the covariate values. Set to a zero row matrix if no constraints are required. If a supplied \code{C} has an attribute \code{"always.apply"} then it is never ignored, even if any \code{by} variables of a smooth imply that no constraint is actually needed. Code for creating \code{C} should check whether the specification object already contains a zero row matrix, and leave this unchanged if it is (since this signifies no constraint should be produced). } \item{Cp}{An optional matrix supplying alternative identifiability constraints for use when predicting. By default the fitting constrants are used. This option is useful when some sort of simple sparse constraint is required for fitting, but the usual sum-to-zero constraint is required for prediction so that, e.g. the CIs for model components are as narrow as possible. } \item{no.rescale}{if this is non-NULL then the penalty coefficient matrix of the smooth will not be rescaled for enhaced numerical stability (rescaling is the default, because \code{\link{gamm}} requires it). Turning off rescaling is useful if the values of the smoothing parameters should be interpretable in a model, for example because they are inverse variance components. } \item{df}{the degrees of freedom associated with this term (when unpenalized and unconstrained). If this is null then \code{smoothCon} will set it to the basis dimension. \code{smoothCon} will reduce this by the number of constraints.} \item{te.ok}{\code{0} if this term should not be used as a tensor product marginal, \code{1} if it can be used and plotted, and \code{2} is it can be used but not plotted. Set to \code{1} if \code{NULL}.} \item{plot.me}{Set to \code{FALSE} if this smooth should not be plotted by \code{\link{plot.gam}}. Set to \code{TRUE} if \code{NULL}.} \item{side.constrain}{Set to \code{FALSE} to ensure that the smooth is never subject to side constraints as a result of nesting. } \item{L}{smooths may depend on fewer `underlying' smoothing parameters than there are elements of \code{S}. In this case \code{L} is the matrix mapping the vector of underlying log smoothing parameters to the vector of logs of the smoothing parameters actually multiplying the \code{S[[i]]}. \code{L=NULL} signifies that there is one smoothing parameter per \code{S[[i]]}. } Usually the returned object will also include extra information required to define the basis, and used by \code{\link{Predict.matrix}} methods to make predictions using the basis. See the \code{Details} section for links to the information included for the built in smooth classes. \code{tensor.smooth} returned objects will additionally have each element of the \code{margin} list updated in the same way. \code{tensor.smooths} also have a list, \code{XP}, containing re-parameterization matrices for any 1-D marginal terms re-parameterized in terms of function values. This list will have \code{NULL} entries for marginal smooths that are not re-parameterized, and is only long enough to reach the last re-parameterized marginal in the list. } \details{ There are built in methods for objects with the following classes: \code{tp.smooth.spec} (thin plate regression splines: see \code{\link{tprs}}); \code{ts.smooth.spec} (thin plate regression splines with shrinkage-to-zero); \code{cr.smooth.spec} (cubic regression splines: see \code{\link{cubic.regression.spline}}; \code{cs.smooth.spec} (cubic regression splines with shrinkage-to-zero); \code{cc.smooth.spec} (cyclic cubic regression splines); \code{ps.smooth.spec} (Eilers and Marx (1986) style P-splines: see \code{\link{p.spline}}); \code{cp.smooth.spec} (cyclic P-splines); \code{ad.smooth.spec} (adaptive smooths of 1 or 2 variables: see \code{\link{adaptive.smooth}}); \code{re.smooth.spec} (simple random effect terms); \code{mrf.smooth.spec} (Markov random field smoothers for smoothing over discrete districts); \code{tensor.smooth.spec} (tensor product smooths). There is an implicit assumption that the basis only depends on the knots and/or the set of unique covariate combinations; i.e. that the basis is the same whether generated from the full set of covariates, or just the unique combinations of covariates. Plotting of smooths is handled by plot methods for smooth objects. A default \code{mgcv.smooth} method is used if there is no more specific method available. Plot methods can be added for specific smooth classes, see source code for \code{mgcv:::plot.sos.smooth}, \code{mgcv:::plot.random.effect}, \code{mgcv:::plot.mgcv.smooth} for example code. } \references{ Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 Wood, S.N. (2006) Low rank scale invariant tensor product smooths for generalized additive mixed models. Biometrics 62(4):1025-1036 The code given in the example is based on the smooths advocated in: Ruppert, D., M.P. Wand and R.J. Carroll (2003) Semiparametric Regression. Cambridge University Press. However if you want p-splines, rather than splines with derivative based penalties, then the built in "ps" class is probably a marginally better bet. It's based on Eilers, P.H.C. and B.D. Marx (1996) Flexible Smoothing with B-splines and Penalties. Statistical Science, 11(2):89-121 \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{s}},\code{\link{get.var}}, \code{\link{gamm}}, \code{\link{gam}}, \code{\link{Predict.matrix}}, \code{\link{smoothCon}}, \code{\link{PredictMat}} } \section{WARNING}{User defined smooth objects should avoid having attributes names \code{"qrc"} or \code{"nCons"} as these are used internally to provide constraint free parameterizations.} \examples{ ## Adding a penalized truncated power basis class and methods ## as favoured by Ruppert, Wand and Carroll (2003) ## Semiparametric regression CUP. (No advantage to actually ## using this, since mgcv can happily handle non-identity ## penalties.) smooth.construct.tr.smooth.spec<-function(object,data,knots) ## a truncated power spline constructor method function ## object$p.order = null space dimension { m <- object$p.order[1] if (is.na(m)) m <- 2 ## default if (m<1) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default nk<-object$bs.dim-m-1 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data x.shift <- mean(x) # shift used to enhance stability k <- knots[[object$term]] ## will be NULL if none supplied if (is.null(k)) # space knots through data { n<-length(x) k<-quantile(x[2:(n-1)],seq(0,1,length=nk+2))[2:(nk+1)] } if (length(k)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) x <- x - x.shift # basis stabilizing shift k <- k - x.shift # knots treated the same! X<-matrix(0,length(x),object$bs.dim) for (i in 1:(m+1)) X[,i] <- x^(i-1) for (i in 1:nk) X[,i+m+1]<-(x-k[i])^m*as.numeric(x>k[i]) object$X<-X # the finished model matrix if (!object$fixed) # create the penalty matrix { object$S[[1]]<-diag(c(rep(0,m+1),rep(1,nk))) } object$rank<-nk # penalty rank object$null.space.dim <- m+1 # dim. of unpenalized space ## store "tr" specific stuff ... object$knots<-k;object$m<-m;object$x.shift <- x.shift object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"tr.smooth" # Give object a class object } Predict.matrix.tr.smooth<-function(object,data) ## prediction method function for the `tr' smooth class { x <- data[[object$term]] x <- x - object$x.shift # stabilizing shift m <- object$m; # spline order (3=cubic) k<-object$knots # knot locations nk<-length(k) # number of knots X<-matrix(0,length(x),object$bs.dim) for (i in 1:(m+1)) X[,i] <- x^(i-1) for (i in 1:nk) X[,i+m+1] <- (x-k[i])^m*as.numeric(x>k[i]) X # return the prediction matrix } # an example, using the new class.... require(mgcv) set.seed(100) dat <- gamSim(1,n=400,scale=2) b<-gam(y~s(x0,bs="tr",m=2)+s(x1,bs="ps",m=c(1,3))+ s(x2,bs="tr",m=3)+s(x3,bs="tr",m=2),data=dat) plot(b,pages=1) b<-gamm(y~s(x0,bs="tr",m=2)+s(x1,bs="ps",m=c(1,3))+ s(x2,bs="tr",m=3)+s(x3,bs="tr",m=2),data=dat) plot(b$gam,pages=1) # another example using tensor products of the new class dat <- gamSim(2,n=400,scale=.1)$data b <- gam(y~te(x,z,bs=c("tr","tr"),m=c(2,2)),data=dat) vis.gam(b) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/interpret.gam.Rd0000744000177400001440000000313112632334033015217 0ustar murdochusers\name{interpret.gam} \alias{interpret.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Interpret a GAM formula} \description{ This is an internal function of package \code{mgcv}. It is a service routine for \code{gam} which splits off the strictly parametric part of the model formula, returning it as a formula, and interprets the smooth parts of the model formula. Not normally called directly. } \usage{interpret.gam(gf)} \arguments{\item{gf}{A GAM formula as supplied to \code{\link{gam}} or \code{\link{gamm}}, or a list of such formulae, as supplied for some \code{\link{gam}} families.} } \value{An object of class \code{split.gam.formula} with the following items: \item{pf}{A model formula for the strictly parametric part of the model.} \item{pfok}{TRUE if there is a \code{pf} formula.} \item{smooth.spec}{A list of class \code{xx.smooth.spec} objects where \code{xx} depends on the basis specified for the term. (These can be passed to smooth constructor method functions to actually set up penalties and bases.)} \item{full.formula}{An expanded version of the model formula in which the options are fully expanded, and the options do not depend on variables which might not be available later.} \item{fake.formula}{A formula suitable for use in evaluating a model frame.} \item{response}{Name of the response variable.} } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gam}} \code{\link{gamm}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/null.space.dimension.Rd0000744000177400001440000000364512632334033016502 0ustar murdochusers\name{null.space.dimension} \alias{null.space.dimension} %- Also NEED an `\alias' for EACH other topic documented here. \title{The basis of the space of un-penalized functions for a TPRS} \description{ The thin plate spline penalties give zero penalty to some functions. The space of these functions is spanned by a set of polynomial terms. \code{null.space.dimension} finds the dimension of this space, \eqn{M}{M}, given the number of covariates that the smoother is a function of, \eqn{d}{d}, and the order of the smoothing penalty, \eqn{m}{m}. If \eqn{m}{m} does not satisfy \eqn{2m>d}{2m>d} then the smallest possible dimension for the null space is found given \eqn{d}{d} and the requirement that the smooth should be visually smooth. } \usage{ null.space.dimension(d,m) } %- maybe also `usage' for other objects documented here. \arguments{ \item{d}{ is a positive integer - the number of variables of which the t.p.s. is a function. } \item{m}{ a non-negative integer giving the order of the penalty functional, or signalling that the default order should be used.} } \details{ Thin plate splines are only visually smooth if the order of the wiggliness penalty, \eqn{m}{m}, satisfies \eqn{2m > d+1}{2m > d+1}. If \eqn{2m. } mgcv/man/summary.gam.Rd0000644000177400001440000002643312632334033014711 0ustar murdochusers\name{summary.gam} \alias{summary.gam} \alias{print.summary.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Summary for a GAM fit} \description{ Takes a fitted \code{gam} object produced by \code{gam()} and produces various useful summaries from it. (See \code{\link{sink}} to divert output to a file.) } \usage{ \method{summary}{gam}(object, dispersion=NULL, freq=FALSE, p.type = 0, ...) \method{print}{summary.gam}(x,digits = max(3, getOption("digits") - 3), signif.stars = getOption("show.signif.stars"),...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ a fitted \code{gam} object as produced by \code{gam()}.} \item{x}{a \code{summary.gam} object produced by \code{summary.gam()}.} \item{dispersion}{A known dispersion parameter. \code{NULL} to use estimate or default (e.g. 1 for Poisson).} \item{freq}{By default p-values for parametric terms are calculated using the Bayesian estimated covariance matrix of the parameter estimators. If this is set to \code{TRUE} then the frequentist covariance matrix of the parameters is used instead. } \item{p.type}{determines how p-values are computed for smooth terms. 0 uses a test statistic with distribution determined by the un-rounded edf of the term. 1 uses upwardly biased rounding of the edf and -1 uses a version of the test statistic with a null distribution that has to be simulated. 5 is the approximation in Wood (2006). Other options are poor, generate a warning, and are only of research interest. See details.} \item{digits}{controls number of digits printed in output.} \item{signif.stars}{Should significance stars be printed alongside output.} \item{...}{ other arguments.} } \details{ Model degrees of freedom are taken as the trace of the influence (or hat) matrix \eqn{ {\bf A}}{A} for the model fit. Residual degrees of freedom are taken as number of data minus model degrees of freedom. Let \eqn{ {\bf P}_i}{P_i} be the matrix giving the parameters of the ith smooth when applied to the data (or pseudodata in the generalized case) and let \eqn{ {\bf X}}{X} be the design matrix of the model. Then \eqn{ tr({\bf XP}_i )}{tr(XP_i)} is the edf for the ith term. Clearly this definition causes the edf's to add up properly! An alternative version of EDF is more appropriate for p-value computation, and is based on the trace of \eqn{ 2{\bf A} - {\bf AA}}{2A - AA}. \code{print.summary.gam} tries to print various bits of summary information useful for term selection in a pretty way. P-values for smooth terms are usually based on a test statistic motivated by an extension of Nychka's (1988) analysis of the frequentist properties of Bayesian confidence intervals for smooths (Marra and Wood, 2012). These have better frequentist performance (in terms of power and distribution under the null) than the alternative strictly frequentist approximation. When the Bayesian intervals have good across the function properties then the p-values have close to the correct null distribution and reasonable power (but there are no optimality results for the power). Full details are in Wood (2013b), although what is computed is actually a slight variant in which the components of the test statistic are weighted by the iterative fitting weights. Note that for terms with no unpenalized terms (such as Gaussian random effects) the Nychka (1988) requirement for smoothing bias to be substantially less than variance breaks down (see e.g. appendix of Marra and Wood, 2012), and this results in incorrect null distribution for p-values computed using the above approach. In this case it is necessary to use an alternative approach designed for random effects variance components, and this is done. See Wood (2013a) for details: the test is based on a likelihood ratio statistic (with the reference distribution appropriate for the null hypothesis on the boundary of the parameter space). All p-values are computed without considering uncertainty in the smoothing parameter estimates. In simulations the p-values have best behaviour under ML smoothness selection, with REML coming second. In general the p-values behave well, but neglecting smoothing parameter uncertainty means that they may be somewhat too low when smoothing parameters are highly uncertain. High uncertainty happens in particular when smoothing parameters are poorly identified, which can occur with nested smooths or highly correlated covariates (high concurvity). If \code{p.type=5} then the frequentist approximation for p-values of smooth terms described in section 4.8.5 of Wood (2006) is used. The approximation is not as good as the default, and is no longer recommended. By default the p-values for parametric model terms are also based on Wald tests using the Bayesian covariance matrix for the coefficients. This is appropriate when there are "re" terms present, and is otherwise rather similar to the results using the frequentist covariance matrix (\code{freq=TRUE}), since the parametric terms themselves are usually unpenalized. Default P-values for parameteric terms that are penalized using the \code{paraPen} argument will not be good. However if such terms represent conventional random effects with full rank penalties, then setting \code{freq=TRUE} is appropriate. } \value{\code{summary.gam} produces a list of summary information for a fitted \code{gam} object. \item{p.coeff}{is an array of estimates of the strictly parametric model coefficients.} \item{p.t}{is an array of the \code{p.coeff}'s divided by their standard errors.} \item{p.pv}{is an array of p-values for the null hypothesis that the corresponding parameter is zero. Calculated with reference to the t distribution with the estimated residual degrees of freedom for the model fit if the dispersion parameter has been estimated, and the standard normal if not.} \item{m}{The number of smooth terms in the model.} \item{chi.sq}{An array of test statistics for assessing the significance of model smooth terms. See details.} \item{s.pv}{An array of approximate p-values for the null hypotheses that each smooth term is zero. Be warned, these are only approximate.} \item{se}{array of standard error estimates for all parameter estimates.} \item{r.sq}{The adjusted r-squared for the model. Defined as the proportion of variance explained, where original variance and residual variance are both estimated using unbiased estimators. This quantity can be negative if your model is worse than a one parameter constant model, and can be higher for the smaller of two nested models! The proportion null deviance explained is probably more appropriate for non-normal errors. Note that \code{r.sq} does not include any offset in the one parameter model.} \item{dev.expl}{The proportion of the null deviance explained by the model. The null deviance is computed taking account of any offset, so \code{dev.expl} can be substantially lower than \code{r.sq} when an offset is present.} \item{edf}{array of estimated degrees of freedom for the model terms.} \item{residual.df}{estimated residual degrees of freedom.} \item{n}{number of data.} \item{np}{number of model coefficients (regression coefficients, not smoothing parameters or other parameters of likelihood).} \item{rank}{apparent model rank.} \item{method}{The smoothing selection criterion used.} \item{sp.criterion}{The minimized value of the smoothness selection criterion. Note that for ML and REML methods, what is reported is the negative log marginal likelihood or negative log restricted likelihood. } \item{scale}{estimated (or given) scale parameter.} \item{family}{the family used.} \item{formula}{the original GAM formula.} \item{dispersion}{the scale parameter.} \item{pTerms.df}{the degrees of freedom associated with each parametric term (excluding the constant).} \item{pTerms.chi.sq}{a Wald statistic for testing the null hypothesis that the each parametric term is zero.} \item{pTerms.pv}{p-values associated with the tests that each term is zero. For penalized fits these are approximate. The reference distribution is an appropriate chi-squared when the scale parameter is known, and is based on an F when it is not.} \item{cov.unscaled}{The estimated covariance matrix of the parameters (or estimators if \code{freq=TRUE}), divided by scale parameter.} \item{cov.scaled}{The estimated covariance matrix of the parameters (estimators if \code{freq=TRUE}).} \item{p.table}{significance table for parameters} \item{s.table}{significance table for smooths} \item{p.Terms}{significance table for parametric model terms} } \references{ Marra, G and S.N. Wood (2012) Coverage Properties of Confidence Intervals for Generalized Additive Model Components. Scandinavian Journal of Statistics, 39(1), 53-74. Nychka (1988) Bayesian Confidence Intervals for Smoothing Splines. Journal of the American Statistical Association 83:1134-1143. Wood, S.N. (2013a) A simple test for random effects in regression models. Biometrika 100:1005-1010 Wood, S.N. (2013b) On p-values for smooth components of an extended generalized additive model. Biometrika 100:221-228 Wood S.N. (2006) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org} with substantial improvements by Henric Nilsson.} \section{WARNING }{ The p-values are approximate and neglect smoothing parameter uncertainty. They are likely to be somewhat too low when smoothing parameter estimates are highly uncertain: do read the details section. If the exact values matter, read Wood (2013a or b). P-values for terms penalized via `paraPen' are unlikely to be correct. } \seealso{ \code{\link{gam}}, \code{\link{predict.gam}}, \code{\link{gam.check}}, \code{\link{anova.gam}}, \code{\link{gam.vcomp}}, \code{\link{sp.vcov}} } \examples{ library(mgcv) set.seed(0) dat <- gamSim(1,n=200,scale=2) ## simulate data b <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat) plot(b,pages=1) summary(b) ## now check the p-values by using a pure regression spline..... b.d <- round(summary(b)$edf)+1 ## get edf per smooth b.d <- pmax(b.d,3) # can't have basis dimension less than 3! bc<-gam(y~s(x0,k=b.d[1],fx=TRUE)+s(x1,k=b.d[2],fx=TRUE)+ s(x2,k=b.d[3],fx=TRUE)+s(x3,k=b.d[4],fx=TRUE),data=dat) plot(bc,pages=1) summary(bc) ## Example where some p-values are less reliable... dat <- gamSim(6,n=200,scale=2) b <- gam(y~s(x0,m=1)+s(x1)+s(x2)+s(x3)+s(fac,bs="re"),data=dat) ## Here s(x0,m=1) can be penalized to zero, so p-value approximation ## cruder than usual... summary(b) ## p-value check - increase k to make this useful! k<-20;n <- 200;p <- rep(NA,k) for (i in 1:k) { b<-gam(y~te(x,z),data=data.frame(y=rnorm(n),x=runif(n),z=runif(n)), method="ML") p[i]<-summary(b)$s.p[1] } plot(((1:k)-0.5)/k,sort(p)) abline(0,1,col=2) ks.test(p,"punif") ## how close to uniform are the p-values? ## A Gamma example, by modify `gamSim' output... dat <- gamSim(1,n=400,dist="normal",scale=1) dat$f <- dat$f/4 ## true linear predictor Ey <- exp(dat$f);scale <- .5 ## mean and GLM scale parameter ## Note that `shape' and `scale' in `rgamma' are almost ## opposite terminology to that used with GLM/GAM... dat$y <- rgamma(Ey*0,shape=1/scale,scale=Ey*scale) bg <- gam(y~ s(x0)+ s(x1)+s(x2)+s(x3),family=Gamma(link=log), data=dat,method="REML") summary(bg) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/vis.gam.Rd0000744000177400001440000001312512632334033014010 0ustar murdochusers\name{vis.gam} \alias{vis.gam} \alias{persp.gam} \title{Visualization of GAM objects} \usage{ vis.gam(x,view=NULL,cond=list(),n.grid=30,too.far=0,col=NA, color="heat",contour.col=NULL,se=-1,type="link", plot.type="persp",zlim=NULL,nCol=50,...) } \arguments{ \item{x}{a \code{gam} object, produced by \code{gam()}} \item{view}{an array containing the names of the two main effect terms to be displayed on the x and y dimensions of the plot. If omitted the first two suitable terms will be used. Note that variables coerced to factors in the model formula won't work as view variables, and \code{vis.gam} can not detect that this has happened when setting defaults. } \item{cond}{a named list of the values to use for the other predictor terms (not in \code{view}). Variables omitted from this list will have the closest observed value to the median for continuous variables, or the most commonly occuring level for factors. Parametric matrix variables have all the entries in each column set to the observed column entry closest to the column median. } \item{n.grid}{The number of grid nodes in each direction used for calculating the plotted surface.} \item{too.far}{ plot grid nodes that are too far from the points defined by the variables given in \code{view} can be excluded from the plot. \code{too.far} determines what is too far. The grid is scaled into the unit square along with the \code{view} variables and then grid nodes more than \code{too.far} from the predictor variables are excluded.} \item{col}{The colours for the facets of the plot. If this is \code{NA} then if \code{se}>0 the facets are transparent, otherwise the colour scheme specified in \code{color} is used. If \code{col} is not \code{NA} then it is used as the facet colour.} \item{color}{ the colour scheme to use for plots when \code{se}<=0. One of \code{"topo"}, \code{"heat"}, \code{"cm"}, \code{"terrain"}, \code{"gray"} or \code{"bw"}. Schemes \code{"gray"} and \code{"bw"} also modify the colors used when \code{se}>0.} \item{contour.col}{sets the colour of contours when using \code{plot.type="contour"}. Default scheme used if \code{NULL}.} \item{se}{if less than or equal to zero then only the predicted surface is plotted, but if greater than zero, then 3 surfaces are plotted, one at the predicted values minus \code{se} standard errors, one at the predicted values and one at the predicted values plus \code{se} standard errors.} \item{type}{\code{"link"} to plot on linear predictor scale and \code{"response"} to plot on the response scale.} \item{plot.type}{one of \code{"contour"} or \code{"persp"}.} \item{zlim}{a two item array giving the lower and upper limits for the z-axis scale. \code{NULL} to choose automatically.} \item{nCol}{The number of colors to use in color schemes.} \item{...}{other options to pass on to \code{\link{persp}}, \code{\link{image}} or \code{\link{contour}}. In particular \code{ticktype="detailed"} will add proper axes labelling to the plots. } } \value{Simply produces a plot.} \description{ Produces perspective or contour plot views of \code{gam} model predictions, fixing all but the values in \code{view} to the values supplied in \code{cond}. } \details{ The x and y limits are determined by the ranges of the terms named in \code{view}. If \code{se}<=0 then a single (height colour coded, by default) surface is produced, otherwise three (by default see-through) meshes are produced at mean and +/- \code{se} standard errors. Parts of the x-y plane too far from data can be excluded by setting \code{too.far} All options to the underlying graphics functions can be reset by passing them as extra arguments \code{...}: such supplied values will always over-ride the default values used by \code{vis.gam}. } \author{Simon Wood \email{simon.wood@r-project.org} Based on an original idea and design by Mike Lonergan.} \section{WARNINGS}{ The routine can not detect that a variable has been coerced to factor within a model formula, and will therefore fail if such a variable is used as a \code{view} variable. When setting default \code{view} variables it can not detect this situation either, which can cause failures if the coerced variables are the first, otherwise suitable, variables encountered. } \seealso{ \code{\link{persp}} and \code{\link{gam}}. } \examples{ library(mgcv) set.seed(0) n<-200;sig2<-4 x0 <- runif(n, 0, 1);x1 <- runif(n, 0, 1) x2 <- runif(n, 0, 1) y<-x0^2+x1*x2 +runif(n,-0.3,0.3) g<-gam(y~s(x0,x1,x2)) old.par<-par(mfrow=c(2,2)) # display the prediction surface in x0, x1 .... vis.gam(g,ticktype="detailed",color="heat",theta=-35) vis.gam(g,se=2,theta=-35) # with twice standard error surfaces vis.gam(g, view=c("x1","x2"),cond=list(x0=0.75)) # different view vis.gam(g, view=c("x1","x2"),cond=list(x0=.75),theta=210,phi=40, too.far=.07) # ..... areas where there is no data are not plotted # contour examples.... vis.gam(g, view=c("x1","x2"),plot.type="contour",color="heat") vis.gam(g, view=c("x1","x2"),plot.type="contour",color="terrain") vis.gam(g, view=c("x1","x2"),plot.type="contour",color="topo") vis.gam(g, view=c("x1","x2"),plot.type="contour",color="cm") par(old.par) # Examples with factor and "by" variables fac<-rep(1:4,20) x<-runif(80) y<-fac+2*x^2+rnorm(80)*0.1 fac<-factor(fac) b<-gam(y~fac+s(x)) vis.gam(b,theta=-35,color="heat") # factor example z<-rnorm(80)*0.4 y<-as.numeric(fac)+3*x^2*z+rnorm(80)*0.1 b<-gam(y~fac+s(x,by=z)) vis.gam(b,theta=-35,color="heat",cond=list(z=1)) # by variable example vis.gam(b,view=c("z","x"),theta= -135) # plot against by variable } \keyword{hplot} \keyword{models} \keyword{smooth} \keyword{regression} mgcv/man/predict.bam.Rd0000755000177400001440000001725112756312745014657 0ustar murdochusers\name{predict.bam} \alias{predict.bam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Prediction from fitted Big Additive Model model} \description{ Essentially a wrapper for \code{\link{predict.gam}} for prediction from a model fitted by \code{\link{bam}}. Can compute on a parallel cluster. Takes a fitted \code{bam} object produced by \code{\link{bam}} and produces predictions given a new set of values for the model covariates or the original values used for the model fit. Predictions can be accompanied by standard errors, based on the posterior distribution of the model coefficients. The routine can optionally return the matrix by which the model coefficients must be pre-multiplied in order to yield the values of the linear predictor at the supplied covariate values: this is useful for obtaining credible regions for quantities derived from the model (e.g. derivatives of smooths), and for lookup table prediction outside \code{R} (see example code below).} \usage{ \method{predict}{bam}(object,newdata,type="link",se.fit=FALSE,terms=NULL, exclude=NULL,block.size=50000,newdata.guaranteed=FALSE, na.action=na.pass,cluster=NULL,discrete=TRUE,n.threads=1,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ a fitted \code{bam} object as produced by \code{\link{bam}}. } \item{newdata}{ A data frame or list containing the values of the model covariates at which predictions are required. If this is not provided then predictions corresponding to the original data are returned. If \code{newdata} is provided then it should contain all the variables needed for prediction: a warning is generated if not. } \item{type}{ When this has the value \code{"link"} (default) the linear predictor (possibly with associated standard errors) is returned. When \code{type="terms"} each component of the linear predictor is returned seperately (possibly with standard errors): this includes parametric model components, followed by each smooth component, but excludes any offset and any intercept. \code{type="iterms"} is the same, except that any standard errors returned for smooth components will include the uncertainty about the intercept/overall mean. When \code{type="response"} predictions on the scale of the response are returned (possibly with approximate standard errors). When \code{type="lpmatrix"} then a matrix is returned which yields the values of the linear predictor (minus any offset) when postmultiplied by the parameter vector (in this case \code{se.fit} is ignored). The latter option is most useful for getting variance estimates for quantities derived from the model: for example integrated quantities, or derivatives of smooths. A linear predictor matrix can also be used to implement approximate prediction outside \code{R} (see example code, below). } \item{se.fit}{ when this is TRUE (not default) standard error estimates are returned for each prediction.} \item{terms}{if \code{type=="terms"} or \code{type="iterms"} then only results for the terms (smooth or parametric) named in this array will be returned. Otherwise any smooth terms not named in this array will be set to zero. If \code{NULL} then all terms are included.} \item{exclude}{if \code{type=="terms"} or \code{type="iterms"} then terms (smooth or parametric) named in this array will not be returned. Otherwise any smooth terms named in this array will be set to zero. If \code{NULL} then no terms are excluded.} \item{block.size}{maximum number of predictions to process per call to underlying code: larger is quicker, but more memory intensive.} \item{newdata.guaranteed}{Set to \code{TRUE} to turn off all checking of \code{newdata} except for sanity of factor levels: this can speed things up for large prediction tasks, but \code{newdata} must be complete, with no \code{NA} values for predictors required in the model. } \item{na.action}{what to do about \code{NA} values in \code{newdata}. With the default \code{na.pass}, any row of \code{newdata} containing \code{NA} values for required predictors, gives rise to \code{NA} predictions (even if the term concerned has no \code{NA} predictors). \code{na.exclude} or \code{na.omit} result in the dropping of \code{newdata} rows, if they contain any \code{NA} values for required predictors. If \code{newdata} is missing then \code{NA} handling is determined from \code{object$na.action}.} \item{cluster}{\code{predict.bam} can compute in parallel using \link[parallel]{parLapply} from the \code{parallel} package, if it is supplied with a cluster on which to do this (a cluster here can be some cores of a single machine). See details and example code for \code{\link{bam}}. } \item{discrete}{if \code{TRUE} then discrete prediction methods used with model fitted by discrete methods. \code{FALSE} for regular prediction.} \item{n.threads}{if \code{se.fit=TRUE} and discrete prediction is used then parallel computation can be used to speed up se calcualtion. This specifies number of htreads to use.} \item{...}{ other arguments.} } \value{ If \code{type=="lpmatrix"} then a matrix is returned which will give a vector of linear predictor values (minus any offest) at the supplied covariate values, when applied to the model coefficient vector. Otherwise, if \code{se.fit} is \code{TRUE} then a 2 item list is returned with items (both arrays) \code{fit} and \code{se.fit} containing predictions and associated standard error estimates, otherwise an array of predictions is returned. The dimensions of the returned arrays depends on whether \code{type} is \code{"terms"} or not: if it is then the array is 2 dimensional with each term in the linear predictor separate, otherwise the array is 1 dimensional and contains the linear predictor/predicted values (or corresponding s.e.s). The linear predictor returned termwise will not include the offset or the intercept. \code{newdata} can be a data frame, list or model.frame: if it's a model frame then all variables must be supplied. } \details{The standard errors produced by \code{predict.gam} are based on the Bayesian posterior covariance matrix of the parameters \code{Vp} in the fitted bam object. To facilitate plotting with \code{\link{termplot}}, if \code{object} possesses an attribute \code{"para.only"} and \code{type=="terms"} then only parametric terms of order 1 are returned (i.e. those that \code{termplot} can handle). Note that, in common with other prediction functions, any offset supplied to \code{\link{gam}} as an argument is always ignored when predicting, unlike offsets specified in the gam model formula. See the examples in \code{\link{predict.gam}} for how to use the \code{lpmatrix} for obtaining credible regions for quantities derived from the model. } \references{ Chambers and Hastie (1993) Statistical Models in S. Chapman & Hall. Marra, G and S.N. Wood (2012) Coverage Properties of Confidence Intervals for Generalized Additive Model Components. Scandinavian Journal of Statistics. Wood S.N. (2006b) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org} The design is inspired by the S function of the same name described in Chambers and Hastie (1993) (but is not a clone). } \section{WARNING }{ Predictions are likely to be incorrect if data dependent transformations of the covariates are used within calls to smooths. See examples in \code{\link{predict.gam}}. } \seealso{ \code{\link{bam}}, \code{\link{predict.gam}}} \examples{ ## for parallel computing see examples for ?bam ## for general useage follow examples in ?predict.gam } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/pdTens.Rd0000744000177400001440000000625512632334033013707 0ustar murdochusers\name{pdTens} \alias{pdTens} \alias{pdConstruct.pdTens} \alias{pdFactor.pdTens} \alias{pdMatrix.pdTens} \alias{coef.pdTens} \alias{summary.pdTens} %- Also NEED an `\alias' for EACH other topic documented here. \title{Functions implementing a pdMat class for tensor product smooths} \description{This set of functions implements an \code{nlme} library \code{pdMat} class to allow tensor product smooths to be estimated by \code{lme} as called by \code{gamm}. Tensor product smooths have a penalty matrix made up of a weighted sum of penalty matrices, where the weights are the smoothing parameters. In the mixed model formulation the penalty matrix is the inverse of the covariance matrix for the random effects of a term, and the smoothing parameters (times a half) are variance parameters to be estimated. It's not possible to transform the problem to make the required random effects covariance matrix look like one of the standard \code{pdMat} classes: hence the need for the \code{pdTens} class. A \code{\link{notLog2}} parameterization ensures that the parameters are positive. These functions (\code{pdTens}, \code{pdConstruct.pdTens}, \code{pdFactor.pdTens}, \code{pdMatrix.pdTens}, \code{coef.pdTens} and \code{summary.pdTens}) would not normally be called directly. } \usage{ pdTens(value = numeric(0), form = NULL, nam = NULL, data = sys.frame(sys.parent())) } %- maybe also `usage' for other objects documented here. \arguments{ \item{value}{Initialization values for parameters. Not normally used.} \item{form}{A one sided formula specifying the random effects structure. The formula should have an attribute \code{S} which is a list of the penalty matrices the weighted sum of which gives the inverse of the covariance matrix for these random effects.} \item{nam}{a names argument, not normally used with this class.} \item{data}{data frame in which to evaluate formula.} } \details{ If using this class directly note that it is worthwhile scaling the \code{S} matrices to be of `moderate size', for example by dividing each matrix by its largest singular value: this avoids problems with \code{lme} defaults (\code{\link{smooth.construct.tensor.smooth.spec}} does this automatically). This appears to be the minimum set of functions required to implement a new \code{pdMat} class. Note that while the \code{pdFactor} and \code{pdMatrix} functions return the inverse of the scaled random effect covariance matrix or its factor, the \code{pdConstruct} function is sometimes initialised with estimates of the scaled covariance matrix, and sometimes intialized with its inverse. } \value{ A class \code{pdTens} object, or its coefficients or the matrix it represents or the factor of that matrix. \code{pdFactor} returns the factor as a vector (packed column-wise) (\code{pdMatrix} always returns a matrix). } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Pinheiro J.C. and Bates, D.M. (2000) Mixed effects Models in S and S-PLUS. Springer The \code{nlme} source code. \url{http://www.maths.bris.ac.uk/~sw15190/} } \seealso{ \code{\link{te}} \code{\link{gamm}}} \examples{ # see gamm } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.re.smooth.spec.Rd0000755000177400001440000001202012664101131020635 0ustar murdochusers\name{smooth.construct.re.smooth.spec} \alias{smooth.construct.re.smooth.spec} \alias{Predict.matrix.random.effect} %- Also NEED an `\alias' for EACH other topic documented here. \title{Simple random effects in GAMs} \description{\code{\link{gam}} can deal with simple independent random effects, by exploiting the link between smooths and random effects to treat random effects as smooths. \code{s(x,bs="re")} implements this. Such terms can can have any number of predictors, which can be any mixture of numeric or factor variables. The terms produce a parametric interaction of the predictors, and penalize the corresponding coefficients with a multiple of the identity matrix, corresponding to an assumption of i.i.d. normality. See details. } \usage{ \method{smooth.construct}{re.smooth.spec}(object, data, knots) \method{Predict.matrix}{random.effect}(object, data) } \arguments{ \item{object}{For the \code{smooth.construct} method a smooth specification object, usually generated by a term \code{s(x,...,bs="re",)}. For the \code{predict.Matrix} method an object of class \code{"random.effect"} produced by the \code{smooth.construct} method.} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{generically a list containing any knots supplied for basis setup --- unused at present.} } \value{ An object of class \code{"random.effect"} or a matrix mapping the coefficients of the random effect to the random effects themselves. } \details{Exactly how the random effects are implemented is best seen by example. Consider the model term \code{s(x,z,bs="re")}. This will result in the model matrix component corresponding to \code{~x:z-1} being added to the model matrix for the whole model. The coefficients associated with the model matrix component are assumed i.i.d. normal, with unknown variance (to be estimated). This assumption is equivalent to an identity penalty matrix (i.e. a ridge penalty) on the coefficients. Because such a penalty is full rank, random effects terms do not require centering constraints. If the nature of the random effect specification is not clear, consider a couple more examples: \code{s(x,bs="re")} results in \code{model.matrix(~x-1)} being appended to the overall model matrix, while \code{s(x,v,w,bs="re")} would result in \code{model.matrix(~x:v:w-1)} being appended to the model matrix. In both cases the corresponding model coefficients are assumed i.i.d. normal, and are hence subject to ridge penalties. If the random effect precision matrix is of the form \eqn{\sum_j \lambda_j S_j}{sum_j p_j S_j} for known matrices \eqn{S_j}{S_j} and unknown parameters \eqn{\lambda_j}{p_j}, then a list containing the \eqn{S_j}{S_j} can be supplied in the \code{xt} argument of \code{\link{s}}. In this case an array \code{rank} should also be supplied in \code{xt} giving the ranks of the \eqn{S_j}{S_j} matrices. See simple example below. Note that smooth \code{id}s are not supported for random effect terms. Unlike most smooth terms, side conditions are never applied to random effect terms in the event of nesting (since they are identifiable without side conditions). Random effects implemented in this way do not exploit the sparse structure of many random effects, and may therefore be relatively inefficient for models with large numbers of random effects, when \code{gamm4} or \code{\link{gamm}} may be better alternatives. Note also that \code{\link{gam}} will not support models with more coefficients than data. The situation in which factor variable random effects intentionally have unobserved levels requires special handling. You should set \code{drop.unused.levels=FALSE} in the model fitting function, \code{\link{gam}}, \code{\link{bam}} or \code{\link{gamm}}, having first ensured that any fixed effect factors do not contain unobserved levels. } \references{ Wood, S.N. (2008) Fast stable direct fitting and smoothness selection for generalized additive models. Journal of the Royal Statistical Society (B) 70(3):495-518 } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{gam.vcomp}}, \code{\link{gamm}}} \examples{ ## see ?gam.vcomp require(mgcv) ## simulate simple random effect example set.seed(4) nb <- 50; n <- 400 b <- rnorm(nb)*2 ## random effect r <- sample(1:nb,n,replace=TRUE) ## r.e. levels y <- 2 + b[r] + rnorm(n) r <- factor(r) ## fit model.... b <- gam(y ~ s(r,bs="re"),method="REML") gam.vcomp(b) ## example with supplied precision matrices... b <- c(rnorm(nb/2)*2,rnorm(nb/2)*.5) ## random effect now with 2 variances r <- sample(1:nb,n,replace=TRUE) ## r.e. levels y <- 2 + b[r] + rnorm(n) r <- factor(r) ## known precision matrix components... S <- list(diag(rep(c(1,0),each=nb/2)),diag(rep(c(0,1),each=nb/2))) b <- gam(y ~ s(r,bs="re",xt=list(S=S,rank=c(nb/2,nb/2))),method="REML") gam.vcomp(b) summary(b) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/t2.Rd0000744000177400001440000002775612777126041013020 0ustar murdochusers\name{t2} \alias{t2} %- Also NEED an `\alias' for EACH other topic documented here. \title{Define alternative tensor product smooths in GAM formulae} \description{ Alternative to \code{\link{te}} for defining tensor product smooths in a \code{\link{gam}} formula. Results in a construction in which the penalties are non-overlapping multiples of identity matrices (with some rows and columns zeroed). The construction, which is due to Fabian Scheipl (\code{mgcv} implementation, 2010), is analogous to Smoothing Spline ANOVA (Gu, 2002), but using low rank penalized regression spline marginals. The main advantage of this construction is that it is useable with \code{gamm4} from package \code{gamm4}. } \usage{t2(..., k=NA,bs="cr",m=NA,d=NA,by=NA,xt=NULL, id=NULL,sp=NULL,full=FALSE,ord=NULL,pc=NULL) } %- maybe also `usage' for other objects documented here. \arguments{ \item{...}{ a list of variables that are the covariates that this smooth is a function of. Transformations whose form depends on the values of the data are best avoided here: e.g. \code{t2(log(x),z)} is fine, but \code{t2(I(x/sd(x)),z)} is not (see \code{\link{predict.gam}}).} \item{k}{ the dimension(s) of the bases used to represent the smooth term. If not supplied then set to \code{5^d}. If supplied as a single number then this basis dimension is used for each basis. If supplied as an array then the elements are the dimensions of the component (marginal) bases of the tensor product. See \code{\link{choose.k}} for further information.} \item{bs}{array (or single character string) specifying the type for each marginal basis. \code{"cr"} for cubic regression spline; \code{"cs"} for cubic regression spline with shrinkage; \code{"cc"} for periodic/cyclic cubic regression spline; \code{"tp"} for thin plate regression spline; \code{"ts"} for t.p.r.s. with extra shrinkage. See \code{\link{smooth.terms}} for details and full list. User defined bases can also be used here (see \code{\link{smooth.construct}} for an example). If only one basis code is given then this is used for all bases.} \item{m}{The order of the spline and its penalty (for smooth classes that use this) for each term. If a single number is given then it is used for all terms. A vector can be used to supply a different \code{m} for each margin. For marginals that take vector \code{m} (e.g. \code{\link{p.spline}} and \code{\link{Duchon.spline}}), then a list can be supplied, with a vector element for each margin. \code{NA} autoinitializes. \code{m} is ignored by some bases (e.g. \code{"cr"}).} \item{d}{array of marginal basis dimensions. For example if you want a smooth for 3 covariates made up of a tensor product of a 2 dimensional t.p.r.s. basis and a 1-dimensional basis, then set \code{d=c(2,1)}. Incompatibilities between built in basis types and dimension will be resolved by resetting the basis type.} \item{by}{a numeric or factor variable of the same dimension as each covariate. In the numeric vector case the elements multiply the smooth evaluated at the corresponding covariate values (a `varying coefficient model' results). In the factor case causes a replicate of the smooth to be produced for each factor level. See \code{\link{gam.models}} for further details. May also be a matrix if covariates are matrices: in this case implements linear functional of a smooth (see \code{\link{gam.models}} and \code{\link{linear.functional.terms}} for details).} \item{xt}{Either a single object, providing any extra information to be passed to each marginal basis constructor, or a list of such objects, one for each marginal basis. } \item{id}{A label or integer identifying this term in order to link its smoothing parameters to others of the same type. If two or more smooth terms have the same \code{id} then they will have the same smoothing paramsters, and, by default, the same bases (first occurance defines basis type, but data from all terms used in basis construction).} \item{sp}{any supplied smoothing parameters for this term. Must be an array of the same length as the number of penalties for this smooth. Positive or zero elements are taken as fixed smoothing parameters. Negative elements signal auto-initialization. Over-rides values supplied in \code{sp} argument to \code{\link{gam}}. Ignored by \code{gamm}.} \item{full}{If \code{TRUE} then there is a separate penalty for each combination of null space column and range space. This gives strict invariance. If \code{FALSE} each combination of null space and range space generates one penalty, but the coulmns of each null space basis are treated as one group. The latter is more parsimonious, but does mean that invariance is only achieved by an arbitrary rescaling of null space basis vectors.} \item{ord}{an array giving the orders of terms to retain. Here order means number of marginal range spaces used in the construction of the component. \code{NULL} to retain everything. } \item{pc}{If not \code{NULL}, signals a point constraint: the smooth should pass through zero at the point given here (as a vector or list with names corresponding to the smooth names). Never ignored if supplied. See \code{\link{identifiability}}. } } \details{ Smooths of several covariates can be constructed from tensor products of the bases used to represent smooths of one (or sometimes more) of the covariates. To do this `marginal' bases are produced with associated model matrices and penalty matrices. These are reparameterized so that the penalty is zero everywhere, except for some elements on the leading diagonal, which all have the same non-zero value. This reparameterization results in an unpenalized and a penalized subset of parameters, for each marginal basis (see e.g. appendix of Wood, 2004, for details). The re-parameterized marginal bases are then combined to produce a basis for a single function of all the covariates (dimension given by the product of the dimensions of the marginal bases). In this set up there are multiple penalty matrices --- all zero, but for a mixture of a constant and zeros on the leading diagonal. No two penalties have a non-zero entry in the same place. Essentially the basis for the tensor product can be thought of as being constructed from a set of products of the penalized (range) or unpenalized (null) space bases of the marginal smooths (see Gu, 2002, section 2.4). To construct one of the set, choose either the null space or the range space from each marginal, and from these bases construct a product basis. The result is subject to a ridge penalty (unless it happens to be a product entirely of marginal null spaces). The whole basis for the smooth is constructed from all the different product bases that can be constructed in this way. The separately penalized components of the smooth basis each have an interpretation in terms of the ANOVA - decomposition of the term. See \code{\link{pen.edf}} for some further information. Note that there are two ways to construct the product. When \code{full=FALSE} then the null space bases are treated as a whole in each product, but when \code{full=TRUE} each null space column is treated as a separate null space. The latter results in more penalties, but is the strict analog of the SS-ANOVA approach. Tensor product smooths are especially useful for representing functions of covariates measured in different units, although they are typically not quite as nicely behaved as t.p.r.s. smooths for well scaled covariates. Note also that GAMs constructed from lower rank tensor product smooths are nested within GAMs constructed from higher rank tensor product smooths if the same marginal bases are used in both cases (the marginal smooths themselves are just special cases of tensor product smooths.) Note that tensor product smooths should not be centred (have identifiability constraints imposed) if any marginals would not need centering. The constructor for tensor product smooths ensures that this happens. The function does not evaluate the variable arguments. } \value{ A class \code{t2.smooth.spec} object defining a tensor product smooth to be turned into a basis and penalties by the \code{smooth.construct.tensor.smooth.spec} function. The returned object contains the following items: \item{margin}{A list of \code{smooth.spec} objects of the type returned by \code{\link{s}}, defining the basis from which the tensor product smooth is constructed.} \item{term}{An array of text strings giving the names of the covariates that the term is a function of.} \item{by}{is the name of any \code{by} variable as text (\code{"NA"} for none).} \item{fx}{ logical array with element for each penalty of the term (tensor product smooths have multiple penalties). \code{TRUE} if the penalty is to be ignored, \code{FALSE}, otherwise. } \item{label}{A suitable text label for this smooth term.} \item{dim}{The dimension of the smoother - i.e. the number of covariates that it is a function of.} \item{mp}{\code{TRUE} is multiple penalties are to be used (default).} \item{np}{\code{TRUE} to re-parameterize 1-D marginal smooths in terms of function values (defualt).} \item{id}{the \code{id} argument supplied to \code{te}.} \item{sp}{the \code{sp} argument supplied to \code{te}.} } \author{ Simon N. Wood \email{simon.wood@r-project.org} and Fabian Scheipl} \references{ Wood S.N., F. Scheipl and J.J. Faraway (2013, online Feb 2012) Straightforward intermediate rank tensor product smoothing in mixed models. Statistical Computing. 23(3):341-360 Gu, C. (2002) Smoothing Spline ANOVA, Springer. Alternative approaches to functional ANOVA decompositions, *not* implemented by t2 terms, are discussed in: Belitz and Lang (2008) Simultaneous selection of variables and smoothing parameters in structured additive regression models. Computational Statistics & Data Analysis, 53(1):61-81 Lee, D-J and M. Durban (2011) P-spline ANOVA type interaction models for spatio-temporal smoothing. Statistical Modelling, 11:49-69 Wood, S.N. (2006) Low-Rank Scale-Invariant Tensor Product Smooths for Generalized Additive Mixed Models. Biometrics 62(4): 1025-1036. } \seealso{\code{\link{te}} \code{\link{s}},\code{\link{gam}},\code{\link{gamm}}, } \examples{ # following shows how tensor product deals nicely with # badly scaled covariates (range of x 5\% of range of z ) require(mgcv) test1<-function(x,z,sx=0.3,sz=0.4) { x<-x*20 (pi**sx*sz)*(1.2*exp(-(x-0.2)^2/sx^2-(z-0.3)^2/sz^2)+ 0.8*exp(-(x-0.7)^2/sx^2-(z-0.8)^2/sz^2)) } n<-500 old.par<-par(mfrow=c(2,2)) x<-runif(n)/20;z<-runif(n); xs<-seq(0,1,length=30)/20;zs<-seq(0,1,length=30) pr<-data.frame(x=rep(xs,30),z=rep(zs,rep(30,30))) truth<-matrix(test1(pr$x,pr$z),30,30) f <- test1(x,z) y <- f + rnorm(n)*0.2 b1<-gam(y~s(x,z)) persp(xs,zs,truth);title("truth") vis.gam(b1);title("t.p.r.s") b2<-gam(y~t2(x,z)) vis.gam(b2);title("tensor product") b3<-gam(y~t2(x,z,bs=c("tp","tp"))) vis.gam(b3);title("tensor product") par(old.par) test2<-function(u,v,w,sv=0.3,sw=0.4) { ((pi**sv*sw)*(1.2*exp(-(v-0.2)^2/sv^2-(w-0.3)^2/sw^2)+ 0.8*exp(-(v-0.7)^2/sv^2-(w-0.8)^2/sw^2)))*(u-0.5)^2*20 } n <- 500 v <- runif(n);w<-runif(n);u<-runif(n) f <- test2(u,v,w) y <- f + rnorm(n)*0.2 ## tensor product of 2D Duchon spline and 1D cr spline m <- list(c(1,.5),0) b <- gam(y~t2(v,w,u,k=c(30,5),d=c(2,1),bs=c("ds","cr"),m=m)) ## look at the edf per penalty. "rr" denotes interaction term ## (range space range space). "rn" is interaction of null space ## for u with range space for v,w... pen.edf(b) ## plot results... op <- par(mfrow=c(2,2)) vis.gam(b,cond=list(u=0),color="heat",zlim=c(-0.2,3.5)) vis.gam(b,cond=list(u=.33),color="heat",zlim=c(-0.2,3.5)) vis.gam(b,cond=list(u=.67),color="heat",zlim=c(-0.2,3.5)) vis.gam(b,cond=list(u=1),color="heat",zlim=c(-0.2,3.5)) par(op) b <- gam(y~t2(v,w,u,k=c(25,5),d=c(2,1),bs=c("tp","cr"),full=TRUE), method="ML") ## more penalties now. numbers in labels like "r1" indicate which ## basis function of a null space is involved in the term. pen.edf(b) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.sos.smooth.spec.Rd0000744000177400001440000001322112632334033021041 0ustar murdochusers\name{smooth.construct.sos.smooth.spec} \alias{smooth.construct.sos.smooth.spec} \alias{Predict.matrix.sos.smooth} \alias{Spherical.Spline} %- Also NEED an `\alias' for EACH other topic documented here. \title{Splines on the sphere} \description{\code{\link{gam}} can use isotropic smooths on the sphere, via terms like \code{s(la,lo,bs="sos",m=2,k=100)}. There must be exactly 2 arguments to such a smooth. The first is taken to be latitude (in degrees) and the second longitude (in degrees). \code{m} (default 0) is an integer in the range -1 to 4 determining the order of the penalty used. For \code{m>0}, \code{(m+2)/2} is the penalty order, with \code{m=2} equivalent to the usual second derivative penalty. \code{m=0} signals to use the 2nd order spline on the sphere, computed by Wendelberger's (1981) method. \code{m = -1} results in a \code{\link{Duchon.spline}} being used (with m=2 and s=1/2), following an unpublished suggestion of Jean Duchon. \code{k} (default 50) is the basis dimension. } \usage{ \method{smooth.construct}{sos.smooth.spec}(object, data, knots) \method{Predict.matrix}{sos.smooth}(object, data) } \arguments{ \item{object}{a smooth specification object, usually generated by a term \code{s(...,bs="sos",...)}.} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}} } \value{ An object of class \code{"sos.smooth"}. In addition to the usual elements of a smooth class documented under \code{\link{smooth.construct}}, this object will contain: \item{Xu}{A matrix of the unique covariate combinations for this smooth (the basis is constructed by first stripping out duplicate locations).} \item{UZ}{The matrix mapping the parameters of the reduced rank spline back to the parameters of a full spline.} } \details{ For \code{m>0}, the smooths implemented here are based on the pseudosplines on the sphere of Wahba (1981) (there is a correction of table 1 in 1982, but the correction has a misprint in the definition of A --- the A given in the 1981 paper is correct). For \code{m=0} (default) then a second order spline on the sphere is used which is the analogue of a second order thin plate spline in 2D: the computation is based on Chapter 4 of Wendelberger, 1981. Optimal low rank approximations are obtained using exactly the approach given in Wood (2003). For \code{m = -1} a smooth of the general type discussed in Duchon (1977) is used: the sphere is embedded in a 3D Euclidean space, but smoothing employs a penalty based on second derivatives (so that locally as the smoothing parameter tends to zero we recover a "normal" thin plate spline on the tangent space). This is an unpublished suggestion of Jean Duchon. Note that the null space of the penalty is always the space of constant functions on the sphere, whatever the order of penalty. This class has a plot method, with 3 schemes. \code{scheme==0} plots one hemisphere of the sphere, projected onto a circle. The plotting sphere has the north pole at the top, and the 0 meridian running down the middle of the plot, and towards the viewer. The smoothing sphere is rotated within the plotting sphere, by specifying the location of its pole in the co-ordinates of the viewing sphere. \code{theta}, \code{phi} give the longitude and latitude of the smoothing sphere pole within the plotting sphere (in plotting sphere co-ordinates). (You can visualize the smoothing sphere as a globe, free to rotate within the fixed transparent plotting sphere.) The value of the smooth is shown by a heat map overlaid with a contour plot. lat, lon gridlines are also plotted. \code{scheme==1} is as \code{scheme==0}, but in black and white, without the image plot. \code{scheme>1} calls the default plotting method with \code{scheme} decremented by 2. } \seealso{\code{\link{Duchon.spline}}} \references{ Wahba, G. (1981) Spline interpolation and smoothing on the sphere. SIAM J. Sci. Stat. Comput. 2(1):5-16 Wahba, G. (1982) Erratum. SIAM J. Sci. Stat. Comput. 3(3):385-386. Wendelberger, J. (1981) PhD Thesis, University of Winsconsin. Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 } \author{ Simon Wood \email{simon.wood@r-project.org}, with help from Grace Wahba (m=0 case) and Jean Duchon (m = -1 case).} \examples{ require(mgcv) set.seed(0) n <- 400 f <- function(la,lo) { ## a test function... sin(lo)*cos(la-.3) } ## generate with uniform density on sphere... lo <- runif(n)*2*pi-pi ## longitude la <- runif(3*n)*pi-pi/2 ind <- runif(3*n)<=cos(la) la <- la[ind]; la <- la[1:n] ff <- f(la,lo) y <- ff + rnorm(n)*.2 ## test data ## generate data for plotting truth... lam <- seq(-pi/2,pi/2,length=30) lom <- seq(-pi,pi,length=60) gr <- expand.grid(la=lam,lo=lom) fz <- f(gr$la,gr$lo) zm <- matrix(fz,30,60) require(mgcv) dat <- data.frame(la = la *180/pi,lo = lo *180/pi,y=y) ## fit spline on sphere model... bp <- gam(y~s(la,lo,bs="sos",k=60),data=dat) ## pure knot based alternative... ind <- sample(1:n,100) bk <- gam(y~s(la,lo,bs="sos",k=60), knots=list(la=dat$la[ind],lo=dat$lo[ind]),data=dat) b <- bp cor(fitted(b),ff) ## plot results and truth... pd <- data.frame(la=gr$la*180/pi,lo=gr$lo*180/pi) fv <- matrix(predict(b,pd),30,60) par(mfrow=c(2,2),mar=c(4,4,1,1)) contour(lom,lam,t(zm)) contour(lom,lam,t(fv)) plot(bp,rug=FALSE) plot(bp,scheme=1,theta=-30,phi=20,pch=19,cex=.5) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/pdIdnot.Rd0000744000177400001440000000530212632334033014043 0ustar murdochusers\name{pdIdnot} \alias{pdIdnot} \alias{pdConstruct.pdIdnot} \alias{pdFactor.pdIdnot} \alias{pdMatrix.pdIdnot} \alias{coef.pdIdnot} \alias{corMatrix.pdIdnot} \alias{Dim.pdIdnot} \alias{logDet.pdIdnot} \alias{solve.pdIdnot} \alias{summary.pdIdnot} %- Also NEED an `\alias' for EACH other topic documented here. \title{Overflow proof pdMat class for multiples of the identity matrix} \description{ This set of functions is a modification of the \code{pdMat} class \code{pdIdent} from library \code{nlme}. The modification is to replace the log parameterization used in \code{pdMat} with a \code{\link{notLog2}} parameterization, since the latter avoids indefiniteness in the likelihood and associated convergence problems: the parameters also relate to variances rather than standard deviations, for consistency with the \code{\link{pdTens}} class. The functions are particularly useful for working with Generalized Additive Mixed Models where variance parameters/smoothing parameters can be very large or very small, so that overflow or underflow can be a problem. These functions would not normally be called directly, although unlike the \code{\link{pdTens}} class it is easy to do so. } \usage{ pdIdnot(value = numeric(0), form = NULL, nam = NULL, data = sys.frame(sys.parent())) } %- maybe also `usage' for other objects documented here. \arguments{ \item{value}{Initialization values for parameters. Not normally used.} \item{form}{A one sided formula specifying the random effects structure. } \item{nam}{a names argument, not normally used with this class.} \item{data}{data frame in which to evaluate formula.} } \details{ The following functions are provided: \code{Dim.pdIndot}, \code{coef.pdIdnot}, \code{corMatrix.pdIdnot}, \code{logDet.pdIdnot}, \code{pdConstruct.pdIdnot}, \code{pdFactor.pdIdnot}, \code{pdMatrix.pdIdnot}, \code{solve.pdIdnot}, \code{summary.pdIdnot}. (e.g. \code{mgcv:::coef.pdIdnot} to access.) Note that while the \code{pdFactor} and \code{pdMatrix} functions return the inverse of the scaled random effect covariance matrix or its factor, the \code{pdConstruct} function is initialised with estimates of the scaled covariance matrix itself. } \value{ A class \code{pdIdnot} object, or related quantities. See the \code{nlme} documentation for further details.} \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Pinheiro J.C. and Bates, D.M. (2000) Mixed effects Models in S and S-PLUS. Springer The \code{nlme} source code. \url{http://www.maths.bris.ac.uk/~sw15190/} } \seealso{ \code{\link{te}}, \code{\link{pdTens}}, \code{\link{notLog2}}, \code{\link{gamm}}} \examples{ # see gamm } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.cr.smooth.spec.Rd0000644000177400001440000001176412632334033020652 0ustar murdochusers\name{smooth.construct.cr.smooth.spec} \alias{smooth.construct.cr.smooth.spec} \alias{smooth.construct.cs.smooth.spec} \alias{smooth.construct.cc.smooth.spec} \alias{cubic.regression.spline} \alias{cyclic.cubic.spline} %- Also NEED an `\alias' for EACH other topic documented here. \title{Penalized Cubic regression splines in GAMs} \description{\code{\link{gam}} can use univariate penalized cubic regression spline smooths, specified via terms like \code{s(x,bs="cr")}. \code{s(x,bs="cs")} specifies a penalized cubic regression spline which has had its penalty modified to shrink towards zero at high enough smoothing parameters (as the smoothing parameter goes to infinity a normal cubic spline tends to a straight line.) \code{s(x,bs="cc")} specifies a cyclic penalized cubic regression spline smooth. `Cardinal' spline bases are used: Wood (2006) sections 4.1.2 and 4.1.3 gives full details. These bases have very low setup costs. For a given basis dimension, \code{k}, they typically perform a little less well then thin plate regression splines, but a little better than p-splines. See \code{\link{te}} to use these bases in tensor product smooths of several variables. Default \code{k} is 10. } \usage{ \method{smooth.construct}{cr.smooth.spec}(object, data, knots) \method{smooth.construct}{cs.smooth.spec}(object, data, knots) \method{smooth.construct}{cc.smooth.spec}(object, data, knots) } \arguments{ \item{object}{a smooth specification object, usually generated by a term \code{s(...,bs="cr",...)}, \code{s(...,bs="cs",...)} or \code{s(...,bs="cc",...)}} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}. See details.} } \value{ An object of class \code{"cr.smooth"} \code{"cs.smooth"} or \code{"cyclic.smooth"}. In addition to the usual elements of a smooth class documented under \code{\link{smooth.construct}}, this object will contain: \item{xp}{giving the knot locations used to generate the basis.} \item{BD}{class \code{"cyclic.smooth"} objects include matrix \code{BD} which transforms function values at the knots to second derivatives at the knots.} } \details{ The constructor is not normally called directly, but is rather used internally by \code{\link{gam}}. To use for basis setup it is recommended to use \code{\link{smooth.construct2}}. If they are not supplied then the knots of the spline are placed evenly throughout the covariate values to which the term refers: For example, if fitting 101 data with an 11 knot spline of \code{x} then there would be a knot at every 10th (ordered) \code{x} value. The parameterization used represents the spline in terms of its values at the knots. The values at neighbouring knots are connected by sections of cubic polynomial constrained to be continuous up to and including second derivative at the knots. The resulting curve is a natural cubic spline through the values at the knots (given two extra conditions specifying that the second derivative of the curve should be zero at the two end knots). The shrinkage version of the smooth, eigen-decomposes the wiggliness penalty matrix, and sets its 2 zero eigenvalues to small multiples of the smallest strictly positive eigenvalue. The penalty is then set to the matrix with eigenvectors corresponding to those of the original penalty, but eigenvalues set to the peturbed versions. This penalty matrix has full rank and shrinks the curve to zero at high enough smoothing parameters. Note that the cyclic smoother will wrap at the smallest and largest covariate values, unless knots are supplied. If only two knots are supplied then they are taken as the end points of the smoother (provided all the data lie between them), and the remaining knots are generated automatically. The cyclic smooth is not subject to the condition that second derivatives go to zero at the first and last knots. } \references{ Wood S.N. (2006) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ ## cyclic spline example... require(mgcv) set.seed(6) x <- sort(runif(200)*10) z <- runif(200) f <- sin(x*2*pi/10)+.5 y <- rpois(exp(f),exp(f)) ## finished simulating data, now fit model... b <- gam(y ~ s(x,bs="cc",k=12) + s(z),family=poisson, knots=list(x=seq(0,10,length=12))) ## or more simply b <- gam(y ~ s(x,bs="cc",k=12) + s(z),family=poisson, knots=list(x=c(0,10))) ## plot results... par(mfrow=c(2,2)) plot(x,y);plot(b,select=1,shade=TRUE);lines(x,f-mean(f),col=2) plot(b,select=2,shade=TRUE);plot(fitted(b),residuals(b)) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/identifiability.Rd0000755000177400001440000000444612725477741015646 0ustar murdochusers\name{identifiability} \alias{identifiability} %- Also NEED an `\alias' for EACH other topic documented here. \title{Identifiability constraints} \description{Smooth terms are generally only identifiable up to an additive constant. In consequence sum-to-zero identifiability constraints are imposed on most smooth terms. The exceptions are terms with \code{by} variables which cause the smooth to be identifiable without constraint (that doesn't include factor \code{by} variables), and random effect terms. Alternatively smooths can be set up to pass through zero at a user specified point. } \details{ By default each smooth term is subject to the sum-to-zero constraint \deqn{\sum_i f(x_i) = 0.}{sum_i f(x_i) = 0.} The constraint is imposed by reparameterization. The sum-to-zero constraint causes the term to be orthogonal to the intercept: alternative constraints lead to wider confidence bands for the constrained smooth terms. No constraint is used for random effect terms, since the penalty (random effect covariance matrix) anyway ensures identifiability in this case. Also if a \code{by} variable means that the smooth is anyway identifiable, then no extra constraint is imposed. Constraints are imposed for factor \code{by} variables, so that the main effect of the factor must usually be explicitly added to the model (the example below is an exception). Occasionally it is desirable to substitute the constraint that a particular smooth curve should pass through zero at a particular point: the \code{pc} argument to \code{\link{s}}, \code{\link{te}}, \code{\link{ti}} and \code{\link{t2}} allows this: if specified then such constraints are always applied. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood (s.wood@r-project.org) } \examples{ ## Example of three groups, each with a different smooth dependence on x ## but each starting at the same value... require(mgcv) set.seed(53) n <- 100;x <- runif(3*n);z <- runif(3*n) fac <- factor(rep(c("a","b","c"),each=100)) y <- c(sin(x[1:100]*4),exp(3*x[101:200])/10-.1,exp(-10*(x[201:300]-.5))/ (1+exp(-10*(x[201:300]-.5)))-0.9933071) + z*(1-z)*5 + rnorm(100)*.4 ## 'pc' used to constrain smooths to 0 at x=0... b <- gam(y~s(x,by=fac,pc=0)+s(z)) plot(b,pages=1) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.ds.smooth.spec.Rd0000744000177400001440000001516212632334033020651 0ustar murdochusers\name{smooth.construct.ds.smooth.spec} \alias{smooth.construct.ds.smooth.spec} \alias{Predict.matrix.duchon.spline} \alias{Duchon.spline} %- Also NEED an `\alias' for EACH other topic documented here. \title{Low rank Duchon 1977 splines} \description{Thin plate spline smoothers are a special case of the isotropic splines discussed in Duchon (1977). A subset of this more general class can be invoked by terms like \code{s(x,z,bs="ds",m=c(1,.5)} in a \code{\link{gam}} model formula. In the notation of Duchon (1977) m is given by \code{m[1]} (default value 2), while s is given by \code{m[2]} (default value 0). Duchon's (1977) construction generalizes the usual thin plate spline penalty as follows. The usual TPS penalty is given by the integral of the squared Euclidian norm of a vector of mixed partial mth order derivatives of the function w.r.t. its arguments. Duchon re-expresses this penalty in the Fourier domain, and then weights the squared norm in the integral by the Euclidean norm of the fourier frequencies, raised to the power 2s. s is a user selected constant taking integer values divided by 2. If d is the number of arguments of the smooth, then it is required that -d/2 < s < d/2. To obtain continuous functions we further require that m + s > d/2. If s=0 then the usual thin plate spline is recovered. The construction is amenable to exactly the low rank approximation method given in Wood (2003) to thin plate splines, with similar optimality properties, so this approach to low rank smoothing is used here. For large datasets the same subsampling approach as is used in the \code{\link{tprs}} case is employed here to reduce computational costs. These smoothers allow the use of lower orders of derivative in the penalty than conventional thin plate splines, while still yielding continuous functions. For example, we can set m = 1 and s = d/2 - .5 in order to use first derivative penalization for any d (which has the advantage that the dimension of the null space of unpenalized functions is only d+1). } \usage{ \method{smooth.construct}{ds.smooth.spec}(object, data, knots) \method{Predict.matrix}{duchon.spline}(object, data) } \arguments{ \item{object}{a smooth specification object, usually generated by a term \code{s(...,bs="ds",...)}.} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}} } \value{ An object of class \code{"duchon.spline"}. In addition to the usual elements of a smooth class documented under \code{\link{smooth.construct}}, this object will contain: \item{shift}{A record of the shift applied to each covariate in order to center it around zero and avoid any co-linearity problems that might otehrwise occur in the penalty null space basis of the term. } \item{Xu}{A matrix of the unique covariate combinations for this smooth (the basis is constructed by first stripping out duplicate locations).} \item{UZ}{The matrix mapping the smoother parameters back to the parameters of a full Duchon spline.} \item{null.space.dimension}{The dimension of the space of functions that have zero wiggliness according to the wiggliness penalty for this term.} } \details{ The default basis dimension for this class is \code{k=M+k.def} where \code{M} is the null space dimension (dimension of unpenalized function space) and \code{k.def} is 10 for dimension 1, 30 for dimension 2 and 100 for higher dimensions. This is essentially arbitrary, and should be checked, but as with all penalized regression smoothers, results are statistically insensitive to the exact choise, provided it is not so small that it forces oversmoothing (the smoother's degrees of freedom are controlled primarily by its smoothing parameter). The constructor is not normally called directly, but is rather used internally by \code{\link{gam}}. To use for basis setup it is recommended to use \code{\link{smooth.construct2}}. For these classes the specification \code{object} will contain information on how to handle large datasets in their \code{xt} field. The default is to randomly subsample 2000 `knots' from which to produce a reduced rank eigen approximation to the full basis, if the number of unique predictor variable combinations in excess of 2000. The default can be modified via the \code{xt} argument to \code{\link{s}}. This is supplied as a list with elements \code{max.knots} and \code{seed} containing a number to use in place of 2000, and the random number seed to use (either can be missing). Note that the random sampling will not effect the state of R's RNG. For these bases \code{knots} has two uses. Firstly, as mentioned already, for large datasets the calculation of the \code{tp} basis can be time-consuming. The user can retain most of the advantages of the approach by supplying a reduced set of covariate values from which to obtain the basis - typically the number of covariate values used will be substantially smaller than the number of data, and substantially larger than the basis dimension, \code{k}. This approach is the one taken automatically if the number of unique covariate values (combinations) exceeds \code{max.knots}. The second possibility is to avoid the eigen-decomposition used to find the spline basis altogether and simply use the basis implied by the chosen knots: this will happen if the number of knots supplied matches the basis dimension, \code{k}. For a given basis dimension the second option is faster, but gives poorer results (and the user must be quite careful in choosing knot locations). } \seealso{\code{\link{Spherical.Spline}}} \references{ Duchon, J. (1977) Splines minimizing rotation-invariant semi-norms in Solobev spaces. in W. Shemp and K. Zeller (eds) Construction theory of functions of several variables, 85-100, Springer, Berlin. Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv) eg <- gamSim(2,n=200,scale=.05) attach(eg) op <- par(mfrow=c(2,2),mar=c(4,4,1,1)) b0 <- gam(y~s(x,z,bs="ds",m=c(2,0),k=50),data=data) ## tps b <- gam(y~s(x,z,bs="ds",m=c(1,.5),k=50),data=data) ## first deriv penalty b1 <- gam(y~s(x,z,bs="ds",m=c(2,.5),k=50),data=data) ## modified 2nd deriv persp(truth$x,truth$z,truth$f,theta=30) ## truth vis.gam(b0,theta=30) vis.gam(b,theta=30) vis.gam(b1,theta=30) detach(eg) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/bam.update.Rd0000644000177400001440000000724312742112626014473 0ustar murdochusers\name{bam.update} \alias{bam.update} %- Also NEED an `\alias' for EACH other topic documented here. \title{Update a strictly additive bam model for new data.} \description{ Gaussian with identity link models fitted by \code{\link{bam}} can be efficiently updated as new data becomes available, by simply updating the QR decomposition on which estimation is based, and re-optimizing the smoothing parameters, starting from the previous estimates. This routine implements this. } \usage{ bam.update(b,data,chunk.size=10000) } %- maybe also `usage' for other objects documented here. \arguments{ \item{b}{ A \code{gam} object fitted by \code{\link{bam}} and representing a strictly additive model (i.e. \code{gaussian} errors, \code{identity} link).} \item{data}{Extra data to augment the original data used to obtain \code{b}. Must include a \code{weights} column if the original fit was weighted and a \code{AR.start} column if \code{AR.start} was non \code{NULL} in original fit.} \item{chunk.size}{size of subsets of data to process in one go when getting fitted values.} } \value{ An object of class \code{"gam"} as described in \code{\link{gamObject}}. } \details{ \code{bam.update} updates the QR decomposition of the (weighted) model matrix of the GAM represented by \code{b} to take account of the new data. The orthogonal factor multiplied by the response vector is also updated. Given these updates the model and smoothing parameters can be re-estimated, as if the whole dataset (original and the new data) had been fitted in one go. The function will use the same AR1 model for the residuals as that employed in the original model fit (see \code{rho} parameter of \code{\link{bam}}). Note that there may be small numerical differences in fit between fitting the data all at once, and fitting in stages by updating, if the smoothing bases used have any of their details set with reference to the data (e.g. default knot locations). } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \section{WARNINGS }{ AIC computation does not currently take account of AR model, if used. } \seealso{\code{\link{mgcv-package}}, \code{\link{bam}} } \examples{ library(mgcv) ## following is not *very* large, for obvious reasons... set.seed(8) n <- 5000 dat <- gamSim(1,n=n,dist="normal",scale=5) dat[c(50,13,3000,3005,3100),]<- NA dat1 <- dat[(n-999):n,] dat0 <- dat[1:(n-1000),] bs <- "ps";k <- 20 method <- "GCV.Cp" b <- bam(y ~ s(x0,bs=bs,k=k)+s(x1,bs=bs,k=k)+s(x2,bs=bs,k=k)+ s(x3,bs=bs,k=k),data=dat0,method=method) b1 <- bam.update(b,dat1) b2 <- bam.update(bam.update(b,dat1[1:500,]),dat1[501:1000,]) b3 <- bam(y ~ s(x0,bs=bs,k=k)+s(x1,bs=bs,k=k)+s(x2,bs=bs,k=k)+ s(x3,bs=bs,k=k),data=dat,method=method) b1;b2;b3 ## example with AR1 errors... e <- rnorm(n) for (i in 2:n) e[i] <- e[i-1]*.7 + e[i] dat$y <- dat$f + e*3 dat[c(50,13,3000,3005,3100),]<- NA dat1 <- dat[(n-999):n,] dat0 <- dat[1:(n-1000),] method <- "ML" b <- bam(y ~ s(x0,bs=bs,k=k)+s(x1,bs=bs,k=k)+s(x2,bs=bs,k=k)+ s(x3,bs=bs,k=k),data=dat0,method=method,rho=0.7) b1 <- bam.update(b,dat1) summary(b1);summary(b2);summary(b3) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. \concept{Varying coefficient model} \concept{Functional linear model} \concept{Penalized GLM} \concept{Generalized Additive Model} \concept{Penalized regression} \concept{Spline smoothing} \concept{Penalized regression spline} \concept{Generalized Cross Validation} \concept{Smoothing parameter selection} \concept{tensor product smoothing} \concept{thin plate spline} \concept{P-spline} \concept{Generalized ridge regression} mgcv/man/single.index.Rd0000755000177400001440000000636012764002714015044 0ustar murdochusers\name{single.index} \alias{single.index} %- Also NEED an `\alias' for EACH other topic documented here. \title{Single index models with mgcv} \description{ Single index models contain smooth terms with arguments that are linear combinations of other covariates. e.g. \eqn{s(X\alpha)}{s(Xa)} where \eqn{\alpha}{a} has to be estimated. For identifiability, assume \eqn{\|\alpha\|=1}{||a||=1} with positive first element. One simple way to fit such models is to use \code{\link{gam}} to profile out the smooth model coefficients and smoothing parameters, leaving only the \eqn{\alpha}{a} to be estimated by a general purpose optimizer. Example code is provided below, which can be easily adapted to include multiple single index terms, parametric terms and further smooths. Note the initialization strategy. First estimate \eqn{\alpha}{a} without penalization to get starting values and then do the full fit. Otherwise it is easy to get trapped in a local optimum in which the smooth is linear. An alternative is to initialize using fixed penalization (via the \code{sp} argument to \code{\link{gam}}). } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv) si <- function(theta,y,x,z,opt=TRUE,k=10,fx=FALSE) { ## Fit single index model using gam call, given theta (defines alpha). ## Return ML if opt==TRUE and fitted gam with theta added otherwise. ## Suitable for calling from 'optim' to find optimal theta/alpha. alpha <- c(1,theta) ## constrained alpha defined using free theta kk <- sqrt(sum(alpha^2)) alpha <- alpha/kk ## so now ||alpha||=1 a <- x\%*\%alpha ## argument of smooth b <- gam(y~s(a,fx=fx,k=k)+s(z),family=poisson,method="ML") ## fit model if (opt) return(b$gcv.ubre) else { b$alpha <- alpha ## add alpha J <- outer(alpha,-theta/kk^2) ## compute Jacobian for (j in 1:length(theta)) J[j+1,j] <- J[j+1,j] + 1/kk b$J <- J ## dalpha_i/dtheta_j return(b) } } ## si ## simulate some data from a single index model... set.seed(1) f2 <- function(x) 0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10 n <- 200;m <- 3 x <- matrix(runif(n*m),n,m) ## the covariates for the single index part z <- runif(n) ## another covariate alpha <- c(1,-1,.5); alpha <- alpha/sqrt(sum(alpha^2)) eta <- as.numeric(f2((x\%*\%alpha+.41)/1.4)+1+z^2*2)/4 mu <- exp(eta) y <- rpois(n,mu) ## Poi response ## now fit to the simulated data... th0 <- c(-.8,.4) ## close to truth for speed ## get initial theta, using no penalization... f0 <- nlm(si,th0,y=y,x=x,z=z,fx=TRUE,k=5) ## now get theta/alpha with smoothing parameter selection... f1 <- nlm(si,f0$estimate,y=y,x=x,z=z,hessian=TRUE,k=10) theta.est <-f1$estimate ## Alternative using 'optim' ('Not run' simply to keep ## CRAN check time down)... \dontrun{ th0 <- rep(0,m-1) ## get initial theta, using no penalization... f0 <- optim(th0,si,y=y,x=x,z=z,fx=TRUE,k=5) ## now get theta/alpha with smoothing parameter selection... f1 <- optim(f0$par,si,y=y,x=x,z=z,hessian=TRUE,k=10) theta.est <-f1$par } ## extract and examine fitted model... b <- si(theta.est,y,x,z,opt=FALSE) ## extract best fit model plot(b,pages=1) b b$alpha ## get sd for alpha... Vt <- b$J\%*\%solve(f1$hessian,t(b$J)) diag(Vt)^.5 } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/plot.gam.Rd0000744000177400001440000003127412632334033014172 0ustar murdochusers\name{plot.gam} \alias{plot.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Default GAM plotting} \description{ Takes a fitted \code{gam} object produced by \code{gam()} and plots the component smooth functions that make it up, on the scale of the linear predictor. Optionally produces term plots for parametric model components as well.} \usage{ \method{plot}{gam}(x,residuals=FALSE,rug=TRUE,se=TRUE,pages=0,select=NULL,scale=-1, n=100,n2=40,pers=FALSE,theta=30,phi=30,jit=FALSE,xlab=NULL, ylab=NULL,main=NULL,ylim=NULL,xlim=NULL,too.far=0.1, all.terms=FALSE,shade=FALSE,shade.col="gray80",shift=0, trans=I,seWithMean=FALSE,unconditional=FALSE,by.resids=FALSE, scheme=0,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{ a fitted \code{gam} object as produced by \code{gam()}.} \item{residuals}{If \code{TRUE} then partial residuals are added to plots of 1-D smooths. If \code{FALSE} then no residuals are added. If this is an array of the correct length then it is used as the array of residuals to be used for producing partial residuals. If \code{TRUE} then the residuals are the working residuals from the IRLS iteration weighted by the IRLS weights. Partial residuals for a smooth term are the residuals that would be obtained by dropping the term concerned from the model, while leaving all other estimates fixed (i.e. the estimates for the term plus the residuals).} \item{rug}{ when TRUE (default) then the covariate to which the plot applies is displayed as a rug plot at the foot of each plot of a 1-d smooth, and the locations of the covariates are plotted as points on the contour plot representing a 2-d smooth. Setting to \code{FALSE} will speed up plotting for large datasets.} \item{se}{ when TRUE (default) upper and lower lines are added to the 1-d plots at 2 standard errors above and below the estimate of the smooth being plotted while for 2-d plots, surfaces at +1 and -1 standard errors are contoured and overlayed on the contour plot for the estimate. If a positive number is supplied then this number is multiplied by the standard errors when calculating standard error curves or surfaces. See also \code{shade}, below. } \item{pages}{ (default 0) the number of pages over which to spread the output. For example, if \code{pages=1} then all terms will be plotted on one page with the layout performed automatically. Set to 0 to have the routine leave all graphics settings as they are. } \item{select}{Allows the plot for a single model term to be selected for printing. e.g. if you just want the plot for the second smooth term set \code{select=2}. } \item{scale}{ set to -1 (default) to have the same y-axis scale for each plot, and to 0 for a different y axis for each plot. Ignored if \code{ylim} supplied.} \item{n}{ number of points used for each 1-d plot - for a nice smooth plot this needs to be several times the estimated degrees of freedom for the smooth. Default value 100.} \item{n2}{Square root of number of points used to grid estimates of 2-d functions for contouring.} \item{pers}{Set to \code{TRUE} if you want perspective plots for 2-d terms.} \item{theta}{One of the perspective plot angles.} \item{phi}{The other perspective plot angle.} \item{jit}{Set to TRUE if you want rug plots for 1-d terms to be jittered.} \item{xlab}{If supplied then this will be used as the x label for all plots.} \item{ylab}{If supplied then this will be used as the y label for all plots.} \item{main}{Used as title (or z axis label) for plots if supplied.} \item{ylim}{If supplied then this pair of numbers are used as the y limits for each plot.} \item{xlim}{If supplied then this pair of numbers are used as the x limits for each plot.} \item{too.far}{If greater than 0 then this is used to determine when a location is too far from data to be plotted when plotting 2-D smooths. This is useful since smooths tend to go wild away from data. The data are scaled into the unit square before deciding what to exclude, and \code{too.far} is a distance within the unit square. Setting to zero can make plotting faster for large datasets, but care then needed with interpretation of plots.} \item{all.terms}{if set to \code{TRUE} then the partial effects of parametric model components are also plotted, via a call to \code{\link{termplot}}. Only terms of order 1 can be plotted in this way.} \item{shade}{Set to \code{TRUE} to produce shaded regions as confidence bands for smooths (not avaliable for parametric terms, which are plotted using \code{termplot}).} \item{shade.col}{define the color used for shading confidence bands.} \item{shift}{constant to add to each smooth (on the scale of the linear predictor) before plotting. Can be useful for some diagnostics, or with \code{trans}.} \item{trans}{function to apply to each smooth (after any shift), before plotting. \code{shift} and \code{trans} are occasionally useful as a means for getting plots on the response scale, when the model consists only of a single smooth.} \item{seWithMean}{if \code{TRUE} the component smooths are shown with confidence intervals that include the uncertainty about the overall mean. If \code{FALSE} then the uncertainty relates purely to the centred smooth itself. Marra and Wood (2012) suggests that \code{TRUE} results in better coverage performance, and this is also suggested by simulation.} \item{unconditional}{if \code{TRUE} then the smoothing parameter uncertainty corrected covariance matrix is used to compute uncertainty bands, if available. Otherwise the bands treat the smoothing parameters as fixed.} \item{by.resids}{Should partial residuals be plotted for terms with \code{by} variables? Usually the answer is no, they would be meaningless.} \item{scheme}{Integer or integer vector selecting a plotting scheme for each plot. See details.} \item{...}{ other graphics parameters to pass on to plotting commands. See details for smooth plot specific options.} } \details{ Produces default plot showing the smooth components of a fitted GAM, and optionally parametric terms as well, when these can be handled by \code{\link{termplot}}. For smooth terms \code{plot.gam} actually calls plot method functions depending on the class of the smooth. Currently \code{\link{random.effects}}, Markov random fields (\code{\link{mrf}}), \code{\link{Spherical.Spline}} and \code{\link{factor.smooth.interaction}} terms have special methods (documented in their help files), the rest use the defaults described below. For plots of 1-d smooths, the x axis of each plot is labelled with the covariate name, while the y axis is labelled \code{s(cov,edf) } where \code{cov} is the covariate name, and \code{edf} the estimated (or user defined for regression splines) degrees of freedom of the smooth. \code{scheme == 0} produces a smooth curve with dashed curves indicating 2 standard error bounds. \code{scheme == 1} illustrates the error bounds using a shaded region. For \code{scheme==0}, contour plots are produced for 2-d smooths with the x-axes labelled with the first covariate name and the y axis with the second covariate name. The main title of the plot is something like \code{s(var1,var2,edf)}, indicating the variables of which the term is a function, and the estimated degrees of freedom for the term. When \code{se=TRUE}, estimator variability is shown by overlaying contour plots at plus and minus 1 s.e. relative to the main estimate. If \code{se} is a positive number then contour plots are at plus or minus \code{se} multiplied by the s.e. Contour levels are chosen to try and ensure reasonable separation of the contours of the different plots, but this is not always easy to achieve. Note that these plots can not be modified to the same extent as the other plot. For 2-d smooths \code{scheme==1} produces a perspective plot, while \code{scheme==2} produces a heatmap, with overlaid contours. Smooths of more than 2 variables are not plotted, but see \code{\link{vis.gam}}. Fine control of plots for parametric terms can be obtained by calling \code{\link{termplot}} directly, taking care to use its \code{terms} argument. Note that, if \code{seWithMean=TRUE}, the confidence bands include the uncertainty about the overall mean. In other words although each smooth is shown centred, the confidence bands are obtained as if every other term in the model was constrained to have average 0, (average taken over the covariate values), except for the smooth concerned. This seems to correspond more closely to how most users interpret componentwise intervals in practice, and also results in intervals with close to nominal (frequentist) coverage probabilities by an extension of Nychka's (1988) results presented in Marra and Wood (2012). Several smooth plots methods using \code{\link{image}} will accept a \code{colors} argument, which can be anything documented in \code{\link{heat.colors}} (in which case something like \code{colors=rainbow(50)} is appropriate), or the \code{\link{grey}} function (in which case somthing like \code{colors=grey(0:50/50)} is needed). Another option is \code{contour.col} which will set the contour colour for some plots. These options are useful for producing grey scale pictures instead of colour. Sometimes you may want a small change to a default plot, and the arguments to \code{plot.gam} just won't let you do it. In this case, the quickest option is sometimes to clone the \code{smooth.construct} and \code{Predict.matrix} methods for the smooth concerned, modifying only the returned smoother class (e.g. to \code{foo.smooth}). Then copy the plot method function for the original class (e.g. \code{mgcv:::plot.mgcv.smooth}), modify the source code to plot exactly as you want and rename the plot method function (e.g. \code{plot.foo.smooth}). You can then use the cloned smooth in models (e.g. \code{s(x,bs="foo")}), and it will automatically plot using the modified plotting function. } \value{ The functions main purpose is its side effect of generating plots. It also silently returns a list of the data used to produce the plots, which can be used to generate customized plots. } \references{ Chambers and Hastie (1993) Statistical Models in S. Chapman & Hall. Marra, G and S.N. Wood (2012) Coverage Properties of Confidence Intervals for Generalized Additive Model Components. Scandinavian Journal of Statistics. Nychka (1988) Bayesian Confidence Intervals for Smoothing Splines. Journal of the American Statistical Association 83:1134-1143. Wood S.N. (2006) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org} Henric Nilsson \email{henric.nilsson@statisticon.se} donated the code for the \code{shade} option. The design is inspired by the S function of the same name described in Chambers and Hastie (1993) (but is not a clone). } \section{WARNING }{ Note that the behaviour of this function is not identical to \code{plot.gam()} in S-PLUS. Plotting can be slow for models fitted to large datasets. Set \code{rug=FALSE} to improve matters. If it's still too slow set \code{too.far=0}, but then take care not to overinterpret smooths away from supporting data. Plots of 2-D smooths with standard error contours shown can not easily be customized. The function can not deal with smooths of more than 2 variables! } \seealso{ \code{\link{gam}}, \code{\link{predict.gam}}, \code{\link{vis.gam}}} \examples{ library(mgcv) set.seed(0) ## fake some data... f1 <- function(x) {exp(2 * x)} f2 <- function(x) { 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 } f3 <- function(x) {x*0} n<-200 sig2<-4 x0 <- rep(1:4,50) x1 <- runif(n, 0, 1) x2 <- runif(n, 0, 1) x3 <- runif(n, 0, 1) e <- rnorm(n, 0, sqrt(sig2)) y <- 2*x0 + f1(x1) + f2(x2) + f3(x3) + e x0 <- factor(x0) ## fit and plot... b<-gam(y~x0+s(x1)+s(x2)+s(x3)) plot(b,pages=1,residuals=TRUE,all.terms=TRUE,shade=TRUE,shade.col=2) plot(b,pages=1,seWithMean=TRUE) ## better coverage intervals ## just parametric term alone... termplot(b,terms="x0",se=TRUE) ## more use of color... op <- par(mfrow=c(2,2),bg="blue") x <- 0:1000/1000 for (i in 1:3) { plot(b,select=i,rug=FALSE,col="green", col.axis="white",col.lab="white",all.terms=TRUE) for (j in 1:2) axis(j,col="white",labels=FALSE) box(col="white") eval(parse(text=paste("fx <- f",i,"(x)",sep=""))) fx <- fx-mean(fx) lines(x,fx,col=2) ## overlay `truth' in red } par(op) ## example with 2-d plots, and use of schemes... b1 <- gam(y~x0+s(x1,x2)+s(x3)) op <- par(mfrow=c(2,2)) plot(b1,all.terms=TRUE) par(op) op <- par(mfrow=c(2,2)) plot(b1,all.terms=TRUE,scheme=1) par(op) op <- par(mfrow=c(2,2)) plot(b1,all.terms=TRUE,scheme=c(2,1)) par(op) } \keyword{models} \keyword{smooth} \keyword{regression} \keyword{hplot}%-- one or more ... mgcv/man/one.se.rule.Rd0000755000177400001440000000533712713051460014611 0ustar murdochusers\name{one.se.rule} \alias{one.se.rule} %- Also NEED an `\alias' for EACH other topic documented here. \title{The one standard error rule for smoother models} \description{ The `one standard error rule' (see e.g. Hastie, Tibshirani and Friedman, 2009) is a way of producing smoother models than those directly estimated by automatic smoothing parameter selection methods. In the single smoothing parameter case, we select the largest smoothing parameter within one standard error of the optimum of the smoothing parameter selection criterion. This approach can be generalized to multiple smoothing parameters estimated by REML or ML.} \details{Under REML or ML smoothing parameter selection an asyptotic distributional approximation is available for the log smoothing parameters. Let \eqn{\rho}{r} denote the log smoothing parameters that we want to increase to obtain a smoother model. The large sample distribution of the estimator of \eqn{\rho}{r} is \eqn{N(\rho,V)}{N(r,V)} where \eqn{V}{V} is the matrix returned by \code{\link{sp.vcov}}. Drop any elements of \eqn{\rho}{r} that are already at `effective infinity', along with the corresponding rows and columns of \eqn{V}{V}. The standard errors of the log smoothing parameters can be obtained from the leading diagonal of \eqn{V}{V}. Let the vector of these be \eqn{d}{d}. Now suppose that we want to increase the estimated log smoothing parameters by an amount \eqn{\alpha d}{a*d}. We choose \eqn{\alpha}{a} so that \eqn{\alpha d^T V^{-1}d = \sqrt{2p}}{a d'V^{-1}d = (2p)^0.5}, where p is the dimension of d and 2p the variance of a chi-squared r.v. with p degrees of freedom. The idea is that we increase the log smoothing parameters in proportion to their standard deviation, until the RE/ML is increased by 1 standard deviation according to its asypmtotic distribution. } \author{Simon N. Wood \email{simon.wood@r-project.org} } \references{Hastie, T, R. Tibshirani and J. Friedman (2009) The Elements of Statistical Learning 2nd ed. Springer.} \seealso{ \code{\link{gam}}} \examples{ require(mgcv) set.seed(2) ## simulate some data... dat <- gamSim(1,n=400,dist="normal",scale=2) b <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat,method="REML") b ## only the first 3 smoothing parameters are candidates for ## increasing here... V <- sp.vcov(b)[1:3,1:3] ## the approx cov matrix of sps d <- diag(V)^.5 ## sp se. ## compute the log smoothing parameter step... d <- sqrt(2*length(d))/d%*%solve(V,d)*d sp <- b$sp ## extract original sp estimates sp[1:3] <- sp[1:3]*exp(d) ## apply the step ## refit with the increased smoothing parameters... b1 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat,method="REML",sp=sp) b;b1 ## compare fits } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/place.knots.Rd0000744000177400001440000000252512632334033014667 0ustar murdochusers\name{place.knots} \alias{place.knots} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Automatically place a set of knots evenly through covariate values} \description{ Given a univariate array of covariate values, places a set of knots for a regression spline evenly through the covariate values. } \usage{ place.knots(x,nk) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{array of covariate values (need not be sorted).} \item{nk}{integer indicating the required number of knots.} } \details{ Places knots evenly throughout a set of covariates. For example, if you had 11 covariate values and wanted 6 knots then a knot would be placed at the first (sorted) covariate value and every second (sorted) value thereafter. With less convenient numbers of data and knots the knots are placed within intervals between data in order to achieve even coverage, where even means having approximately the same number of data between each pair of knots.} \value{ An array of knot locations. } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{smooth.construct.cc.smooth.spec}} } \examples{ require(mgcv) x<-runif(30) place.knots(x,7) rm(x) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/bandchol.Rd0000755000177400001440000000372712654463004014234 0ustar murdochusers\name{bandchol} \alias{bandchol} %- Also NEED an `\alias' for EACH other topic documented here. \title{Choleski decomposition of a band diagonal matrix} \description{ Computes Choleski decomposition of a (symmetric positive definite) band-diagonal matrix, \code{A}. } \usage{ bandchol(B) } %- maybe also `usage' for other objects documented here. \arguments{ \item{B}{An n by k matrix containing the diagonals of the matrix \code{A} to be decomposed. First row is leading diagonal, next is first sub-diagonal, etc. sub-diagonals are zero padded at the end. Alternatively gives \code{A} directly, i.e. a square matrix with 2k-1 non zero diagonals (those from the lower triangle are not accessed).} } \value{Let \code{R} be the factor such that \code{t(R)\%*\%R = A}. \code{R} is upper triangular and if the rows of \code{B} contained the diagonals of \code{A} on entry, then what is returned is an n by k matrix containing the diagonals of \code{R}, packed as \code{B} was packed on entry. If \code{B} was square on entry, then \code{R} is returned directly. See examples. } \details{Calls \code{dpbtrf} from \code{LAPACK}. The point of this is that it has \eqn{O(k^2n)}{O(k^2n)} computational cost, rather than the \eqn{O(n^3)}{O(n^3)} required by dense matrix methods. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Anderson, E., Bai, Z., Bischof, C., Blackford, S., Dongarra, J., Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A. and Sorensen, D., 1999. LAPACK Users' guide (Vol. 9). Siam. } \examples{ require(mgcv) ## simulate a banded diagonal matrix n <- 7;set.seed(8) A <- matrix(0,n,n) sdiag(A) <- runif(n);sdiag(A,1) <- runif(n-1) sdiag(A,2) <- runif(n-2) A <- crossprod(A) ## full matrix form... bandchol(A) chol(A) ## for comparison ## compact storage form... B <- matrix(0,3,n) B[1,] <- sdiag(A);B[2,1:(n-1)] <- sdiag(A,1) B[3,1:(n-2)] <- sdiag(A,2) bandchol(B) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/scat.Rd0000744000177400001440000000327712725500675013417 0ustar murdochusers\name{scat} \alias{scat} \alias{t.scaled} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM scaled t family for heavy tailed data} \description{Family for use with \code{\link{gam}}, implementing regression for the heavy tailed response variables, y, using a scaled t model. The idea is that \eqn{(y-\mu)/\sigma \sim t_\nu }{(y - mu)/sig ~ t_nu} where \eqn{mu}{mu} is determined by a linear predictor, while \eqn{\sigma}{sig} and \eqn{\nu}{nu} are parameters to be estimated alongside the smoothing parameters. } \usage{ scat(theta = NULL, link = "identity") } \arguments{ \item{theta}{the parameters to be estimated \eqn{\nu = 2 + \exp(\theta_1)}{nu = 2 + exp(theta_1) } and \eqn{\sigma = \exp(\theta_2)}{sig = exp(theta_2)}. If supplied and positive, then taken to be fixed values of \eqn{\nu}{nu} and \eqn{\sigma}{sig}. If any negative, then absolute values taken as starting values. } \item{link}{The link function: one of \code{"identity"}, \code{"log"} or \code{"inverse"}.} } \value{ An object of class \code{extended.family}. } \details{Useful in place of Gaussian, when data are heavy tailed. } %- maybe also `usage' for other objects documented here. \author{ Natalya Pya (nyp20@bath.ac.uk) } \references{ Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association. \url{http://arxiv.org/abs/1511.03864} } \examples{ library(mgcv) ## Simulate some t data... set.seed(3);n<-400 dat <- gamSim(1,n=n) dat$y <- dat$f + rt(n,df=3)*2 b <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=scat(link="identity"),data=dat) b plot(b,pages=1) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.so.smooth.spec.Rd0000755000177400001440000003050212765741174020700 0ustar murdochusers\name{smooth.construct.so.smooth.spec} \alias{smooth.construct.so.smooth.spec} \alias{smooth.construct.sf.smooth.spec} \alias{smooth.construct.sw.smooth.spec} \alias{soap} %- Also NEED an `\alias' for EACH other topic documented here. \title{Soap film smoother constructer} \description{ Sets up basis functions and wiggliness penalties for soap film smoothers (Wood, Bravington and Hedley, 2008). Soap film smoothers are based on the idea of constructing a 2-D smooth as a film of soap connecting a smoothly varying closed boundary. Unless smoothing very heavily, the film is distorted towards the data. The smooths are designed not to smooth across boundary features (peninsulas, for example). The \code{so} version sets up the full smooth. The \code{sf} version sets up just the boundary interpolating soap film, while the \code{sw} version sets up the wiggly component of a soap film (zero on the boundary). The latter two are useful for forming tensor products with soap films, and can be used with \code{\link{gamm}} and \code{gamm4}. To use these to simply set up a basis, then call via the wrapper \code{\link{smooth.construct2}} or \code{\link{smoothCon}}. } \usage{ \method{smooth.construct}{so.smooth.spec}(object,data,knots) \method{smooth.construct}{sf.smooth.spec}(object,data,knots) \method{smooth.construct}{sw.smooth.spec}(object,data,knots) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{A smooth specification object as produced by a \code{s(...,bs="so",xt=list(bnd=bnd,...))} term in a \code{gam} formula. Note that the \code{xt} argument to \code{s} *must* be supplied, and should be a list, containing at least a boundary specification list (see details). \code{xt} may also contain various options controlling the boundary smooth (see details), and PDE solution grid. The dimension of the bases for boundary loops is specified via the \code{k} argument of \code{s}, either as a single number to be used for each boundary loop, or as a vector of different basis dimensions for the various boundary loops. } \item{data}{A list or data frame containing the arguments of the smooth.} \item{knots}{list or data frame with two named columns specifying the knot locations within the boundary. The column names should match the names of the arguments of the smooth. The number of knots defines the *interior* basis dimension (i.e. it is *not* supplied via argument \code{k} of \code{s}).} } \details{ For soap film smooths the following *must* be supplied: \itemize{ \item{k}{ the basis dimension for each boundary loop smooth.} \item{xt$bnd}{ the boundary specification for the smooth.} \item{knots}{ the locations of the interior knots for the smooth.} } When used in a GAM then \code{k} and \code{xt} are supplied via \code{s} while \code{knots} are supplied in the \code{knots} argument of \code{\link{gam}}. The \code{bnd} element of the \code{xt} list is a list of lists (or data frames), specifying the loops that define the boundary. Each boundary loop list must contain 2 columns giving the co-ordinates of points defining a boundary loop (when joined sequentially by line segments). Loops should not intersect (not checked). A point is deemed to be in the region of interest if it is interior to an odd number of boundary loops. Each boundary loop list may also contain a column \code{f} giving known boundary conditions on a loop. The \code{bndSpec} element of \code{xt}, if non-NULL, should contain \itemize{ \item{bs}{ the type of cyclic smoothing basis to use: one of \code{"cc"} and \code{"cp"}. If not \code{"cc"} then a cyclic p-spline is used, and argument \code{m} must be supplied.} \item{knot.space}{ set to "even" to get even knot spacing with the "cc" basis.} \item{m}{ 1 or 2 element array specifying order of "cp" basis and penalty.} } Currently the code will not deal with more than one level of nesting of loops, or with separate loops without an outer enclosing loop: if there are known boundary conditions (identifiability constraints get awkward). Note that the function \code{\link{locator}} provides a simple means for defining boundaries graphically, using something like \code{bnd <-as.data.frame(locator(type="l"))}, after producing a plot of the domain of interest (right click to stop). If the real boundary is very complicated, it is probably better to use a simpler smooth boundary enclosing the true boundary, which represents the major boundary features that you don't want to smooth across, but doesn't follow every tiny detail. Model set up, and prediction, involves evaluating basis functions which are defined as the solution to PDEs. The PDEs are solved numerically on a grid using sparse matrix methods, with bilinear interpolation used to obtain values at any location within the smoothing domain. The dimension of the PDE solution grid can be controlled via element \code{nmax} (default 200) of the list supplied as argument \code{xt} of \code{s} in a \code{gam} formula: it gives the number of cells to use on the longest grid side. A little theory: the soap film smooth \eqn{f(x,y)}{f(x,y)} is defined as the solution of \deqn{f_{xx} + f_{yy} = g}{f_xx+f_yy = g} subject to the condition that \eqn{f=s}{f=s}, on the boundary curve, where \eqn{s}{s} is a smooth function (usually a cyclic penalized regression spline). The function \eqn{g}{g} is defined as the solution of \deqn{g_{xx}+g_{yy}=0}{g_xx+g_yy=0} where \eqn{g=0}{g=0} on the boundary curve and \eqn{g(x_k,y_k)=c_k}{g(x_k,y_k)=c_k} at the `knots' of the surface; the \eqn{c_k}{c_k} are model coefficients. In the simplest case, estimation of the coefficients of \eqn{f}{f} (boundary coefficients plus \eqn{c_k}{c_k}'s) is by minimization of \deqn{\|z-f\|^2 + \lambda_s J_s(s) + \lambda_f J_f(f)}{||z-f||^2 + l_s J_s(s) + l_f J_f(f)} where \eqn{J_s}{J_s} is usually some cubic spline type wiggliness penalty on the boundary smooth and \eqn{J_f}{J_f} is the integral of \eqn{(f_xx+f_yy)^2}{(f_xx+f_yy)^2} over the interior of the boundary. Both penalties can be expressed as quadratic forms in the model coefficients. The \eqn{\lambda}{l}'s are smoothing parameters, selectable by GCV, REML, AIC, etc. \eqn{z}{z} represents noisy observations of \eqn{f}{f}. } \value{ A list with all the elements of \code{object} plus \item{sd}{ A list defining the PDE solution grid and domain boundary, and including the sparse LU factorization of the PDE coefficient matrix.} \item{X}{ The model matrix: this will have an \code{"offset"} attribute, if there are any known boundary conditions.} \item{S}{ List of smoothing penalty matrices (in smallest non-zero submatrix form).} \item{irng}{ A vector of scaling factors that have been applied to the model matrix, to ensure nice conditioning.} In addition there are all the elements usually added by \code{smooth.construct} methods. } \references{ Wood, S.N., M.V. Bravington and S.L. Hedley (2008) "Soap film smoothing", J.R.Statist.Soc.B 70(5), 931-955. \url{http://www.maths.bris.ac.uk/~sw15190/} } \section{WARNINGS }{ Soap film smooths are quite specialized, and require more setup than most smoothers (e.g. you have to supply the boundary and the interior knots, plus the boundary smooth basis dimension(s)). It is worth looking at the reference. } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \seealso{\code{\link{Predict.matrix.soap.film}}} \examples{ require(mgcv) ########################## ## simple test function... ########################## fsb <- list(fs.boundary()) nmax <- 100 ## create some internal knots... knots <- data.frame(v=rep(seq(-.5,3,by=.5),4), w=rep(c(-.6,-.3,.3,.6),rep(8,4))) ## Simulate some fitting data, inside boundary... set.seed(0) n<-600 v <- runif(n)*5-1;w<-runif(n)*2-1 y <- fs.test(v,w,b=1) names(fsb[[1]]) <- c("v","w") ind <- inSide(fsb,x=v,y=w) ## remove outsiders y <- y + rnorm(n)*.3 ## add noise y <- y[ind];v <- v[ind]; w <- w[ind] n <- length(y) par(mfrow=c(3,2)) ## plot boundary with knot and data locations plot(fsb[[1]]$v,fsb[[1]]$w,type="l");points(knots,pch=20,col=2) points(v,w,pch="."); ## Now fit the soap film smoother. 'k' is dimension of boundary smooth. ## boundary supplied in 'xt', and knots in 'knots'... nmax <- 100 ## reduced from default for speed. b <- gam(y~s(v,w,k=30,bs="so",xt=list(bnd=fsb,nmax=nmax)),knots=knots) plot(b) ## default plot plot(b,scheme=1) plot(b,scheme=2) plot(b,scheme=3) vis.gam(b,plot.type="contour") ################################ # Fit same model in two parts... ################################ par(mfrow=c(2,2)) vis.gam(b,plot.type="contour") b1 <- gam(y~s(v,w,k=30,bs="sf",xt=list(bnd=fsb,nmax=nmax))+ s(v,w,k=30,bs="sw",xt=list(bnd=fsb,nmax=nmax)) ,knots=knots) vis.gam(b,plot.type="contour") plot(b1) ################################################## ## Now an example with known boundary condition... ################################################## ## Evaluate known boundary condition at boundary nodes... fsb[[1]]$f <- fs.test(fsb[[1]]$v,fsb[[1]]$w,b=1,exclude=FALSE) ## Now fit the smooth... bk <- gam(y~s(v,w,bs="so",xt=list(bnd=fsb,nmax=nmax)),knots=knots) plot(bk) ## default plot ########################################## ## tensor product example (marked ## 'Not run' to reduce CRAN checking load) ########################################## \dontrun{ n <- 10000 v <- runif(n)*5-1;w<-runif(n)*2-1 t <- runif(n) y <- fs.test(v,w,b=1) y <- y + 4.2 y <- y^(.5+t) fsb <- list(fs.boundary()) names(fsb[[1]]) <- c("v","w") ind <- inSide(fsb,x=v,y=w) ## remove outsiders y <- y[ind];v <- v[ind]; w <- w[ind]; t <- t[ind] n <- length(y) y <- y + rnorm(n)*.05 ## add noise knots <- data.frame(v=rep(seq(-.5,3,by=.5),4), w=rep(c(-.6,-.3,.3,.6),rep(8,4))) ## notice NULL element in 'xt' list - to indicate no xt object for "cr" basis... bk <- gam(y~ te(v,w,t,bs=c("sf","cr"),k=c(25,4),d=c(2,1), xt=list(list(bnd=fsb,nmax=nmax),NULL))+ te(v,w,t,bs=c("sw","cr"),k=c(25,4),d=c(2,1), xt=list(list(bnd=fsb,nmax=nmax),NULL)),knots=knots) par(mfrow=c(3,2)) m<-100;n<-50 xm <- seq(-1,3.5,length=m);yn<-seq(-1,1,length=n) xx <- rep(xm,n);yy<-rep(yn,rep(m,n)) tru <- matrix(fs.test(xx,yy),m,n)+4.2 ## truth image(xm,yn,tru^.5,col=heat.colors(100),xlab="v",ylab="w", main="truth") lines(fsb[[1]]$v,fsb[[1]]$w,lwd=3) contour(xm,yn,tru^.5,add=TRUE) vis.gam(bk,view=c("v","w"),cond=list(t=0),plot.type="contour") image(xm,yn,tru,col=heat.colors(100),xlab="v",ylab="w", main="truth") lines(fsb[[1]]$v,fsb[[1]]$w,lwd=3) contour(xm,yn,tru,add=TRUE) vis.gam(bk,view=c("v","w"),cond=list(t=.5),plot.type="contour") image(xm,yn,tru^1.5,col=heat.colors(100),xlab="v",ylab="w", main="truth") lines(fsb[[1]]$v,fsb[[1]]$w,lwd=3) contour(xm,yn,tru^1.5,add=TRUE) vis.gam(bk,view=c("v","w"),cond=list(t=1),plot.type="contour") } ############################# # nested boundary example... ############################# bnd <- list(list(x=0,y=0),list(x=0,y=0)) seq(0,2*pi,length=100) -> theta bnd[[1]]$x <- sin(theta);bnd[[1]]$y <- cos(theta) bnd[[2]]$x <- .3 + .3*sin(theta); bnd[[2]]$y <- .3 + .3*cos(theta) plot(bnd[[1]]$x,bnd[[1]]$y,type="l") lines(bnd[[2]]$x,bnd[[2]]$y) ## setup knots k <- 8 xm <- seq(-1,1,length=k);ym <- seq(-1,1,length=k) x=rep(xm,k);y=rep(ym,rep(k,k)) ind <- inSide(bnd,x,y) knots <- data.frame(x=x[ind],y=y[ind]) points(knots$x,knots$y) ## a test function f1 <- function(x,y) { exp(-(x-.3)^2-(y-.3)^2) } ## plot the test function within the domain par(mfrow=c(2,3)) m<-100;n<-100 xm <- seq(-1,1,length=m);yn<-seq(-1,1,length=n) x <- rep(xm,n);y<-rep(yn,rep(m,n)) ff <- f1(x,y) ind <- inSide(bnd,x,y) ff[!ind] <- NA image(xm,yn,matrix(ff,m,n),xlab="x",ylab="y") contour(xm,yn,matrix(ff,m,n),add=TRUE) lines(bnd[[1]]$x,bnd[[1]]$y,lwd=2);lines(bnd[[2]]$x,bnd[[2]]$y,lwd=2) ## Simulate data by noisy sampling from test function... set.seed(1) x <- runif(300)*2-1;y <- runif(300)*2-1 ind <- inSide(bnd,x,y) x <- x[ind];y <- y[ind] n <- length(x) z <- f1(x,y) + rnorm(n)*.1 ## Fit a soap film smooth to the noisy data nmax <- 60 b <- gam(z~s(x,y,k=c(30,15),bs="so",xt=list(bnd=bnd,nmax=nmax)), knots=knots,method="REML") plot(b) ## default plot vis.gam(b,plot.type="contour") ## prettier version ## trying out separated fits.... ba <- gam(z~s(x,y,k=c(30,15),bs="sf",xt=list(bnd=bnd,nmax=nmax))+ s(x,y,k=c(30,15),bs="sw",xt=list(bnd=bnd,nmax=nmax)), knots=knots,method="REML") plot(ba) vis.gam(ba,plot.type="contour") } \keyword{models} \keyword{smooth} \keyword{regression}mgcv/man/extract.lme.cov.Rd0000744000177400001440000000705512632334033015465 0ustar murdochusers\name{extract.lme.cov} \alias{extract.lme.cov} \alias{extract.lme.cov2} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Extract the data covariance matrix from an lme object} \description{ This is a service routine for \code{\link{gamm}}. Extracts the estimated covariance matrix of the data from an \code{lme} object, allowing the user control about which levels of random effects to include in this calculation. \code{extract.lme.cov} forms the full matrix explicitly: \code{extract.lme.cov2} tries to be more economical than this. } \usage{ extract.lme.cov(b,data,start.level=1) extract.lme.cov2(b,data,start.level=1) } %- maybe also `usage' for other objects documented here. \arguments{ \item{b}{ A fitted model object returned by a call to \code{\link[nlme]{lme}}}. \item{data}{ The data frame/ model frame that was supplied to \code{\link[nlme]{lme}}.} \item{start.level}{The level of nesting at which to start including random effects in the calculation. This is used to allow smooth terms to be estimated as random effects, but treated like fixed effects for variance calculations.} } \details{ The random effects, correlation structure and variance structure used for a linear mixed model combine to imply a covariance matrix for the response data being modelled. These routines extracts that covariance matrix. The process is slightly complicated, because different components of the fitted model object are stored in different orders (see function code for details!). The \code{extract.lme.cov} calculation is not optimally efficient, since it forms the full matrix, which may in fact be sparse. \code{extract.lme.cov2} is more efficient. If the covariance matrix is diagonal, then only the leading diagonal is returned; if it can be written as a block diagonal matrix (under some permutation of the original data) then a list of matrices defining the non-zero blocks is returned along with an index indicating which row of the original data each row/column of the block diagonal matrix relates to. The block sizes are defined by the coarsest level of grouping in the random effect structure. \code{\link{gamm}} uses \code{extract.lme.cov2}. \code{extract.lme.cov} does not currently deal with the situation in which the grouping factors for a correlation structure are finer than those for the random effects. \code{extract.lme.cov2} does deal with this situation. } \value{ For \code{extract.lme.cov} an estimated covariance matrix. For \code{extract.lme.cov2} a list containing the estimated covariance matrix and an indexing array. The covariance matrix is stored as the elements on the leading diagonal, a list of the matrices defining a block diagonal matrix, or a full matrix if the previous two options are not possible. } \references{ For \code{lme} see: Pinheiro J.C. and Bates, D.M. (2000) Mixed effects Models in S and S-PLUS. Springer For details of how GAMMs are set up here for estimation using \code{lme} see: Wood, S.N. (2006) Low rank scale invariant tensor product smooths for Generalized Additive Mixed Models. Biometrics 62(4):1025-1036 or Wood S.N. (2006) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gamm}}, \code{\link{formXtViX}} } \examples{ ## see also ?formXtViX for use of extract.lme.cov2 require(mgcv) library(nlme) data(Rail) b <- lme(travel~1,Rail,~1|Rail) extract.lme.cov(b,Rail) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/Predict.matrix.soap.film.Rd0000744000177400001440000000716412632334033017236 0ustar murdochusers\name{Predict.matrix.soap.film} \alias{Predict.matrix.soap.film} \alias{Predict.matrix.sw} \alias{Predict.matrix.sf} %- Also NEED an `\alias' for EACH other topic documented here. \title{Prediction matrix for soap film smooth} \description{ Creates a prediction matrix for a soap film smooth object, mapping the coefficients of the smooth to the linear predictor component for the smooth. This is the \code{\link{Predict.matrix}} method function required by \code{\link{gam}}. } \usage{ \method{Predict.matrix}{soap.film}(object,data) \method{Predict.matrix}{sw}(object,data) \method{Predict.matrix}{sf}(object,data) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{A class \code{"soap.film"}, \code{"sf"} or \code{"sw"} object.} \item{data}{A list list or data frame containing the arguments of the smooth at which predictions are required.} } \details{ The smooth object will be largely what is returned from \code{\link{smooth.construct.so.smooth.spec}}, although elements \code{X} and \code{S} are not needed, and need not be present, of course. } \value{ A matrix. This may have an \code{"offset"} attribute corresponding to the contribution from any known boundary conditions on the smooth. } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{s.wood@bath.ac.uk}} \seealso{\code{\link{smooth.construct.so.smooth.spec}}} \examples{ ## This is a lower level example. The basis and ## penalties are obtained explicitly ## and `magic' is used as the fitting routine... require(mgcv) set.seed(66) ## create a boundary... fsb <- list(fs.boundary()) ## create some internal knots... knots <- data.frame(x=rep(seq(-.5,3,by=.5),4), y=rep(c(-.6,-.3,.3,.6),rep(8,4))) ## Simulate some fitting data, inside boundary... n<-1000 x <- runif(n)*5-1;y<-runif(n)*2-1 z <- fs.test(x,y,b=1) ind <- inSide(fsb,x,y) ## remove outsiders z <- z[ind];x <- x[ind]; y <- y[ind] n <- length(z) z <- z + rnorm(n)*.3 ## add noise ## plot boundary with knot and data locations plot(fsb[[1]]$x,fsb[[1]]$y,type="l");points(knots$x,knots$y,pch=20,col=2) points(x,y,pch=".",col=3); ## set up the basis and penalties... sob <- smooth.construct2(s(x,y,bs="so",k=40,xt=list(bnd=fsb,nmax=100)), data=data.frame(x=x,y=y),knots=knots) ## ... model matrix is element `X' of sob, penalties matrices ## are in list element `S'. ## fit using `magic' um <- magic(z,sob$X,sp=c(-1,-1),sob$S,off=c(1,1)) beta <- um$b ## produce plots... par(mfrow=c(2,2),mar=c(4,4,1,1)) m<-100;n<-50 xm <- seq(-1,3.5,length=m);yn<-seq(-1,1,length=n) xx <- rep(xm,n);yy<-rep(yn,rep(m,n)) ## plot truth... tru <- matrix(fs.test(xx,yy),m,n) ## truth image(xm,yn,tru,col=heat.colors(100),xlab="x",ylab="y") lines(fsb[[1]]$x,fsb[[1]]$y,lwd=3) contour(xm,yn,tru,levels=seq(-5,5,by=.25),add=TRUE) ## Plot soap, by first predicting on a fine grid... ## First get prediction matrix... X <- Predict.matrix2(sob,data=list(x=xx,y=yy)) ## Now the predictions... fv <- X\%*\%beta ## Plot the estimated function... image(xm,yn,matrix(fv,m,n),col=heat.colors(100),xlab="x",ylab="y") lines(fsb[[1]]$x,fsb[[1]]$y,lwd=3) points(x,y,pch=".") contour(xm,yn,matrix(fv,m,n),levels=seq(-5,5,by=.25),add=TRUE) ## Plot TPRS... b <- gam(z~s(x,y,k=100)) fv.gam <- predict(b,newdata=data.frame(x=xx,y=yy)) names(sob$sd$bnd[[1]]) <- c("xx","yy","d") ind <- inSide(sob$sd$bnd,xx,yy) fv.gam[!ind]<-NA image(xm,yn,matrix(fv.gam,m,n),col=heat.colors(100),xlab="x",ylab="y") lines(fsb[[1]]$x,fsb[[1]]$y,lwd=3) points(x,y,pch=".") contour(xm,yn,matrix(fv.gam,m,n),levels=seq(-5,5,by=.25),add=TRUE) } \keyword{models} \keyword{smooth} \keyword{regression}mgcv/man/gam.fit3.Rd0000744000177400001440000001321012632334033014047 0ustar murdochusers\name{gam.fit3} \alias{gam.fit3} %- Also NEED an `\alias' for EACH other topic documented here. \title{P-IRLS GAM estimation with GCV \& UBRE/AIC or RE/ML derivative calculation} \description{Estimation of GAM smoothing parameters is most stable if optimization of the UBRE/AIC, GCV, GACV, REML or ML score is outer to the penalized iteratively re-weighted least squares scheme used to estimate the model given smoothing parameters. This routine estimates a GAM (any quadratically penalized GLM) given log smoothing paramaters, and evaluates derivatives of the smoothness selection scores of the model with respect to the log smoothing parameters. Calculation of exact derivatives is generally faster than approximating them by finite differencing, as well as generally improving the reliability of GCV/UBRE/AIC/REML score minimization. The approach is to run the P-IRLS to convergence, and only then to iterate for first and second derivatives. Not normally called directly, but rather service routines for \code{\link{gam}}. } \usage{ gam.fit3(x, y, sp, Eb ,UrS=list(), weights = rep(1, nobs), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, nobs), U1 = diag(ncol(x)), Mp = -1, family = gaussian(), control = gam.control(), intercept = TRUE,deriv=2,gamma=1,scale=1, printWarn=TRUE,scoreType="REML",null.coef=rep(0,ncol(x)), pearson.extra=0,dev.extra=0,n.true=-1,Sl=NULL,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{The model matrix for the GAM (or any penalized GLM).} \item{y}{The response variable.} \item{sp}{The log smoothing parameters.} \item{Eb}{A balanced version of the total penalty matrix: usd for numerical rank determination.} \item{UrS}{List of square root penalties premultiplied by transpose of orthogonal basis for the total penalty.} \item{weights}{prior weights for fitting.} \item{start}{optional starting parameter guesses.} \item{etastart}{optional starting values for the linear predictor.} \item{mustart}{optional starting values for the mean.} \item{offset}{the model offset} \item{U1}{An orthogonal basis for the range space of the penalty --- required for ML smoothness estimation only.} \item{Mp}{The dimension of the total penalty null space --- required for ML smoothness estimation only.} \item{family}{the family - actually this routine would never be called with \code{gaussian()}} \item{control}{control list as returned from \code{\link{glm.control}}} \item{intercept}{does the model have and intercept, \code{TRUE} or \code{FALSE}} \item{deriv}{ Should derivatives of the GCV and UBRE/AIC scores be calculated? 0, 1 or 2, indicating the maximum order of differentiation to apply.} \item{gamma}{The weight given to each degree of freedom in the GCV and UBRE scores can be varied (usually increased) using this parameter.} \item{scale}{The scale parameter - needed for the UBRE/AIC score.} \item{printWarn}{Set to \code{FALSE} to suppress some warnings. Useful in order to ensure that some warnings are only printed if they apply to the final fitted model, rather than an intermediate used in optimization.} \item{scoreType}{specifies smoothing parameter selection criterion to use.} \item{null.coef}{coefficients for a model which gives some sort of upper bound on deviance. This allows immediate divergence problems to be controlled.} \item{pearson.extra}{Extra component to add to numerator of pearson statistic in P-REML/P-ML smoothness selection criteria.} \item{dev.extra}{Extra component to add to deviance for REML/ML type smoothness selection criteria.} \item{n.true}{Number of data to assume in smoothness selection criteria. <=0 indicates that it should be the number of rows of \code{X}.} \item{Sl}{A smooth list suitable for passing to gam.fit5. } \item{...}{Other arguments: ignored.} } \details{ This routine is basically \code{\link{glm.fit}} with some modifications to allow (i) for quadratic penalties on the log likelihood; (ii) derivatives of the model coefficients with respect to log smoothing parameters to be obtained by use of the implicit function theorem and (iii) derivatives of the GAM GCV, UBRE/AIC, REML or ML scores to be evaluated at convergence. In addition the routines apply step halving to any step that increases the penalized deviance substantially. The most costly parts of the calculations are performed by calls to compiled C code (which in turn calls LAPACK routines) in place of the compiled code that would usually perform least squares estimation on the working model in the IRLS iteration. Estimation of smoothing parameters by optimizing GCV scores obtained at convergence of the P-IRLS iteration was proposed by O'Sullivan et al. (1986), and is here termed `outer' iteration. Note that use of non-standard families with this routine requires modification of the families as described in \code{\link{fix.family.link}}. } \references{ Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 O 'Sullivan, Yandall & Raynor (1986) Automatic smoothing of regression functions in generalized linear models. J. Amer. Statist. Assoc. 81:96-103. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} The routine has been modified from \code{glm.fit} in R 2.0.1, written by the R core (see \code{\link{glm.fit}} for further credits). } \seealso{\code{\link{gam.fit}}, \code{\link{gam}}, \code{\link{magic}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/rTweedie.Rd0000744000177400001440000000370212763531233014222 0ustar murdochusers\name{rTweedie} \alias{rTweedie} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generate Tweedie random deviates} \description{ Generates Tweedie random deviates, for powers between 1 and 2. } \usage{ rTweedie(mu,p=1.5,phi=1) } \arguments{ \item{mu}{vector of expected values for the deviates to be generated. One deviate generated for each element of \code{mu}.} \item{p}{the variance of a deviate is proportional to its mean, \code{mu} to the power \code{p}. \code{p} must be between 1 and 2. 1 is Poisson like (exactly Poisson if \code{phi=1}), 2 is gamma. } \item{phi}{The scale parameter. Variance of the deviates is given by is \code{phi*mu^p}.} } \value{ A vector of random deviates from a Tweedie distribution, expected value vector \code{mu}, variance vector \code{phi*mu^p}. } \details{ A Tweedie random variable with 1tol) warning("mroot (chol) suspect") B <- mroot(A,method="svd") ## svd method svd.err <- max(abs(A-B\%*\%t(B)));svd.err if (svd.err>tol) warning("mroot (svd) suspect") } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/get.var.Rd0000744000177400001440000000313512632334033014012 0ustar murdochusers\name{get.var} \alias{get.var} %- Also NEED an `\alias' for EACH other topic documented here. \title{Get named variable or evaluate expression from list or data.frame} \description{ This routine takes a text string and a data frame or list. It first sees if the string is the name of a variable in the data frame/ list. If it is then the value of this variable is returned. Otherwise the routine tries to evaluate the expression within the data.frame/list (but nowhere else) and if successful returns the result. If neither step works then \code{NULL} is returned. The routine is useful for processing gam formulae. If the variable is a matrix then it is coerced to a numeric vector, by default.} \usage{ get.var(txt,data,vecMat=TRUE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{txt}{a text string which is either the name of a variable in \code{data} or when parsed is an expression that can be evaluated in \code{data}. It can also be neither in which case the function returns \code{NULL}.} \item{data}{A data frame or list.} \item{vecMat}{Should matrices be coerced to numeric vectors?} } \value{The evaluated variable or \code{NULL}. May be coerced to a numeric vector if it's a matrix.} \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \seealso{ \code{\link{gam} } } \examples{ require(mgcv) y <- 1:4;dat<-data.frame(x=5:10) get.var("x",dat) get.var("y",dat) get.var("x==6",dat) dat <- list(X=matrix(1:6,3,2)) get.var("X",dat) } \keyword{models} \keyword{smooth} \keyword{regression} %-- one or more .. mgcv/man/rig.Rd0000644000177400001440000000345712632334033013233 0ustar murdochusers\name{rig} \alias{rig} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generate inverse Gaussian random deviates} \description{Generates inverse Gaussian random deviates. } \usage{ rig(n,mean,scale) } %- maybe also `usage' for other objects documented here. \arguments{ \item{n}{the number of deviates required. If this has length > 1 then the length is taken as the number of deviates required.} \item{mean}{vector of mean values.} \item{scale}{vector of scale parameter values (lambda, see below)} } \value{ A vector of inverse Gaussian random deviates. } \details{ If x if the returned vector, then E(x) = \code{mean} while var(x) = \code{scale*mean^3}. For density and distribution functions see the \code{statmod} package. The algorithm used is Algorithm 5.7 of Gentle (2003), based on Michael et al. (1976). Note that \code{scale} here is the scale parameter in the GLM sense, which is the reciprocal of the usual `lambda' parameter. } \references{ Gentle, J.E. (2003) Random Number Generation and Monte Carlo Methods (2nd ed.) Springer. Michael, J.R., W.R. Schucany & R.W. Hass (1976) Generating random variates using transformations with multiple roots. The American Statistician 30, 88-90. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \examples{ require(mgcv) set.seed(7) ## An inverse.gaussian GAM example, by modify `gamSim' output... dat <- gamSim(1,n=400,dist="normal",scale=1) dat$f <- dat$f/4 ## true linear predictor Ey <- exp(dat$f);scale <- .5 ## mean and GLM scale parameter ## simulate inverse Gaussian response... dat$y <- rig(Ey,mean=Ey,scale=.2) big <- gam(y~ s(x0)+ s(x1)+s(x2)+s(x3),family=inverse.gaussian(link=log), data=dat,method="REML") plot(big,pages=1) gam.check(big) summary(big) } mgcv/man/new.name.Rd0000744000177400001440000000220512632334033014151 0ustar murdochusers\name{new.name} \alias{new.name} %- Also NEED an `\alias' for EACH other topic documented here. \title{Obtain a name for a new variable that is not already in use} \description{ \code{\link{gamm}} works by transforming a GAMM into something that can be estimated by \code{\link[nlme]{lme}}, but this involves creating new variables, the names of which should not clash with the names of other variables on which the model depends. This simple service routine checks a suggested name against a list of those in use, and if neccesary modifies it so that there is no clash.} \usage{ new.name(proposed,old.names) } %- maybe also `usage' for other objects documented here. \arguments{ \item{proposed}{a suggested name} \item{old.names}{ An array of names that must not be duplicated} } \value{A name that is not in \code{old.names}.} \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \seealso{ \code{\link{gamm} } } \examples{ require(mgcv) old <- c("a","tuba","is","tubby") new.name("tubby",old) } \keyword{models} \keyword{smooth} \keyword{regression} %-- one or more .. mgcv/man/predict.gam.Rd0000755000177400001440000003062312777125170014657 0ustar murdochusers\name{predict.gam} \alias{predict.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Prediction from fitted GAM model} \description{ Takes a fitted \code{gam} object produced by \code{gam()} and produces predictions given a new set of values for the model covariates or the original values used for the model fit. Predictions can be accompanied by standard errors, based on the posterior distribution of the model coefficients. The routine can optionally return the matrix by which the model coefficients must be pre-multiplied in order to yield the values of the linear predictor at the supplied covariate values: this is useful for obtaining credible regions for quantities derived from the model (e.g. derivatives of smooths), and for lookup table prediction outside \code{R} (see example code below).} \usage{ \method{predict}{gam}(object,newdata,type="link",se.fit=FALSE,terms=NULL, exclude=NULL,block.size=NULL,newdata.guaranteed=FALSE, na.action=na.pass,unconditional=FALSE,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ a fitted \code{gam} object as produced by \code{gam()}. } \item{newdata}{ A data frame or list containing the values of the model covariates at which predictions are required. If this is not provided then predictions corresponding to the original data are returned. If \code{newdata} is provided then it should contain all the variables needed for prediction: a warning is generated if not. } \item{type}{ When this has the value \code{"link"} (default) the linear predictor (possibly with associated standard errors) is returned. When \code{type="terms"} each component of the linear predictor is returned seperately (possibly with standard errors): this includes parametric model components, followed by each smooth component, but excludes any offset and any intercept. \code{type="iterms"} is the same, except that any standard errors returned for smooth components will include the uncertainty about the intercept/overall mean. When \code{type="response"} predictions on the scale of the response are returned (possibly with approximate standard errors). When \code{type="lpmatrix"} then a matrix is returned which yields the values of the linear predictor (minus any offset) when postmultiplied by the parameter vector (in this case \code{se.fit} is ignored). The latter option is most useful for getting variance estimates for quantities derived from the model: for example integrated quantities, or derivatives of smooths. A linear predictor matrix can also be used to implement approximate prediction outside \code{R} (see example code, below). } \item{se.fit}{ when this is TRUE (not default) standard error estimates are returned for each prediction.} \item{terms}{if \code{type=="terms"} or \code{type="iterms"} then only results for the terms (smooth or parametric) named in this array will be returned. Otherwise any smooth terms not named in this array will be set to zero. If \code{NULL} then all terms are included.} \item{exclude}{if \code{type=="terms"} or \code{type="iterms"} then terms (smooth or parametric) named in this array will not be returned. Otherwise any smooth terms named in this array will be set to zero. If \code{NULL} then no terms are excluded. Note that this is the term names as it appears in the model summary, see example.} \item{block.size}{maximum number of predictions to process per call to underlying code: larger is quicker, but more memory intensive. Set to < 1 to use total number of predictions as this. If \code{NULL} then block size is 1000 if new data supplied, and the number of rows in the model frame otherwise. } \item{newdata.guaranteed}{Set to \code{TRUE} to turn off all checking of \code{newdata} except for sanity of factor levels: this can speed things up for large prediction tasks, but \code{newdata} must be complete, with no \code{NA} values for predictors required in the model. } \item{na.action}{what to do about \code{NA} values in \code{newdata}. With the default \code{na.pass}, any row of \code{newdata} containing \code{NA} values for required predictors, gives rise to \code{NA} predictions (even if the term concerned has no \code{NA} predictors). \code{na.exclude} or \code{na.omit} result in the dropping of \code{newdata} rows, if they contain any \code{NA} values for required predictors. If \code{newdata} is missing then \code{NA} handling is determined from \code{object$na.action}.} \item{unconditional}{if \code{TRUE} then the smoothing parameter uncertainty corrected covariance matrix is used, when available, otherwise the covariance matrix conditional on the estimated smoothing parameters is used. } \item{...}{ other arguments.} } \value{ If \code{type=="lpmatrix"} then a matrix is returned which will give a vector of linear predictor values (minus any offest) at the supplied covariate values, when applied to the model coefficient vector. Otherwise, if \code{se.fit} is \code{TRUE} then a 2 item list is returned with items (both arrays) \code{fit} and \code{se.fit} containing predictions and associated standard error estimates, otherwise an array of predictions is returned. The dimensions of the returned arrays depends on whether \code{type} is \code{"terms"} or not: if it is then the array is 2 dimensional with each term in the linear predictor separate, otherwise the array is 1 dimensional and contains the linear predictor/predicted values (or corresponding s.e.s). The linear predictor returned termwise will not include the offset or the intercept. \code{newdata} can be a data frame, list or model.frame: if it's a model frame then all variables must be supplied. } \details{The standard errors produced by \code{predict.gam} are based on the Bayesian posterior covariance matrix of the parameters \code{Vp} in the fitted gam object. To facilitate plotting with \code{\link{termplot}}, if \code{object} possesses an attribute \code{"para.only"} and \code{type=="terms"} then only parametric terms of order 1 are returned (i.e. those that \code{termplot} can handle). Note that, in common with other prediction functions, any offset supplied to \code{\link{gam}} as an argument is always ignored when predicting, unlike offsets specified in the gam model formula. See the examples for how to use the \code{lpmatrix} for obtaining credible regions for quantities derived from the model. } \references{ Chambers and Hastie (1993) Statistical Models in S. Chapman & Hall. Marra, G and S.N. Wood (2012) Coverage Properties of Confidence Intervals for Generalized Additive Model Components. Scandinavian Journal of Statistics, 39(1), 53-74. Wood S.N. (2006b) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org} The design is inspired by the S function of the same name described in Chambers and Hastie (1993) (but is not a clone). } \section{WARNING }{ Predictions are likely to be incorrect if data dependent transformations of the covariates are used within calls to smooths. See examples. Note that the behaviour of this function is not identical to \code{predict.gam()} in Splus. \code{type=="terms"} does not exactly match what \code{predict.lm} does for parametric model components. } \seealso{ \code{\link{gam}}, \code{\link{gamm}}, \code{\link{plot.gam}}} \examples{ library(mgcv) n<-200 sig <- 2 dat <- gamSim(1,n=n,scale=sig) b<-gam(y~s(x0)+s(I(x1^2))+s(x2)+offset(x3),data=dat) newd <- data.frame(x0=(0:30)/30,x1=(0:30)/30,x2=(0:30)/30,x3=(0:30)/30) pred <- predict.gam(b,newd) pred0 <- predict(b,newd,exclude="s(x0)") ## prediction excluding a term ############################################# ## difference between "terms" and "iterms" ############################################# nd2 <- data.frame(x0=c(.25,.5),x1=c(.25,.5),x2=c(.25,.5),x3=c(.25,.5)) predict(b,nd2,type="terms",se=TRUE) predict(b,nd2,type="iterms",se=TRUE) ######################################################### ## now get variance of sum of predictions using lpmatrix ######################################################### Xp <- predict(b,newd,type="lpmatrix") ## Xp \%*\% coef(b) yields vector of predictions a <- rep(1,31) Xs <- t(a) \%*\% Xp ## Xs \%*\% coef(b) gives sum of predictions var.sum <- Xs \%*\% b$Vp \%*\% t(Xs) ############################################################# ## Now get the variance of non-linear function of predictions ## by simulation from posterior distribution of the params ############################################################# rmvn <- function(n,mu,sig) { ## MVN random deviates L <- mroot(sig);m <- ncol(L); t(mu + L\%*\%matrix(rnorm(m*n),m,n)) } br <- rmvn(1000,coef(b),b$Vp) ## 1000 replicate param. vectors res <- rep(0,1000) for (i in 1:1000) { pr <- Xp \%*\% br[i,] ## replicate predictions res[i] <- sum(log(abs(pr))) ## example non-linear function } mean(res);var(res) ## loop is replace-able by following .... res <- colSums(log(abs(Xp \%*\% t(br)))) ################################################################## # illustration of unsafe scale dependent transforms in smooths.... ################################################################## b0 <- gam(y~s(x0)+s(x1)+s(x2)+x3,data=dat) ## safe b1 <- gam(y~s(x0)+s(I(x1/2))+s(x2)+scale(x3),data=dat) ## safe b2 <- gam(y~s(x0)+s(scale(x1))+s(x2)+scale(x3),data=dat) ## unsafe pd <- dat; pd$x1 <- pd$x1/2; pd$x3 <- pd$x3/2 par(mfrow=c(1,2)) plot(predict(b0,pd),predict(b1,pd),main="b0 and b1 predictions match") abline(0,1,col=2) plot(predict(b0,pd),predict(b2,pd),main="b2 unsafe, doesn't match") abline(0,1,col=2) ################################################################## ## The following shows how to use use an "lpmatrix" as a lookup ## table for approximate prediction. The idea is to create ## approximate prediction matrix rows by appropriate linear ## interpolation of an existing prediction matrix. The additivity ## of a GAM makes this possible. ## There is no reason to ever do this in R, but the following ## code provides a useful template for predicting from a fitted ## gam *outside* R: all that is needed is the coefficient vector ## and the prediction matrix. Use larger `Xp'/ smaller `dx' and/or ## higher order interpolation for higher accuracy. ################################################################### xn <- c(.341,.122,.476,.981) ## want prediction at these values x0 <- 1 ## intercept column dx <- 1/30 ## covariate spacing in `newd' for (j in 0:2) { ## loop through smooth terms cols <- 1+j*9 +1:9 ## relevant cols of Xp i <- floor(xn[j+1]*30) ## find relevant rows of Xp w1 <- (xn[j+1]-i*dx)/dx ## interpolation weights ## find approx. predict matrix row portion, by interpolation x0 <- c(x0,Xp[i+2,cols]*w1 + Xp[i+1,cols]*(1-w1)) } dim(x0)<-c(1,28) fv <- x0\%*\%coef(b) + xn[4];fv ## evaluate and add offset se <- sqrt(x0\%*\%b$Vp\%*\%t(x0));se ## get standard error ## compare to normal prediction predict(b,newdata=data.frame(x0=xn[1],x1=xn[2], x2=xn[3],x3=xn[4]),se=TRUE) #################################################################### ## Differentiating the smooths in a model (with CIs for derivatives) #################################################################### ## simulate data and fit model... dat <- gamSim(1,n=300,scale=sig) b<-gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat) plot(b,pages=1) ## now evaluate derivatives of smooths with associated standard ## errors, by finite differencing... x.mesh <- seq(0,1,length=200) ## where to evaluate derivatives newd <- data.frame(x0 = x.mesh,x1 = x.mesh, x2=x.mesh,x3=x.mesh) X0 <- predict(b,newd,type="lpmatrix") eps <- 1e-7 ## finite difference interval x.mesh <- x.mesh + eps ## shift the evaluation mesh newd <- data.frame(x0 = x.mesh,x1 = x.mesh, x2=x.mesh,x3=x.mesh) X1 <- predict(b,newd,type="lpmatrix") Xp <- (X1-X0)/eps ## maps coefficients to (fd approx.) derivatives colnames(Xp) ## can check which cols relate to which smooth par(mfrow=c(2,2)) for (i in 1:4) { ## plot derivatives and corresponding CIs Xi <- Xp*0 Xi[,(i-1)*9+1:9+1] <- Xp[,(i-1)*9+1:9+1] ## Xi\%*\%coef(b) = smooth deriv i df <- Xi\%*\%coef(b) ## ith smooth derivative df.sd <- rowSums(Xi\%*\%b$Vp*Xi)^.5 ## cheap diag(Xi\%*\%b$Vp\%*\%t(Xi))^.5 plot(x.mesh,df,type="l",ylim=range(c(df+2*df.sd,df-2*df.sd))) lines(x.mesh,df+2*df.sd,lty=2);lines(x.mesh,df-2*df.sd,lty=2) } } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/Predict.matrix.Rd0000644000177400001440000000513712632334033015344 0ustar murdochusers\name{Predict.matrix} \alias{Predict.matrix} \alias{Predict.matrix2} %- Also NEED an `\alias' for EACH other topic documented here. \title{Prediction methods for smooth terms in a GAM} \description{ Takes \code{smooth} objects produced by \code{smooth.construct} methods and obtains the matrix mapping the parameters associated with such a smooth to the predicted values of the smooth at a set of new covariate values. In practice this method is often called via the wrapper function \code{\link{PredictMat}}. } \usage{ Predict.matrix(object,data) Predict.matrix2(object,data) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ is a smooth object produced by a \code{smooth.construct} method function. The object contains all the information required to specify the basis for a term of its class, and this information is used by the appropriate \code{Predict.matrix} function to produce a prediction matrix for new covariate values. Further details are given in \code{\link{smooth.construct}}.} \item{data}{A data frame containing the values of the (named) covariates at which the smooth term is to be evaluated. Exact requirements are as for \code{\link{smooth.construct}} and \code{smooth.construct2}}. } \value{ A matrix which will map the parameters associated with the smooth to the vector of values of the smooth evaluated at the covariate values given in \code{object}. If the smooth class is one which generates offsets the corresponding offset is returned as attribute \code{"offset"} of the matrix.} \details{ Smooth terms in a GAM formula are turned into smooth specification objects of class \code{xx.smooth.spec} during processing of the formula. Each of these objects is converted to a smooth object using an appropriate \code{smooth.construct} function. The \code{Predict.matrix} functions are used to obtain the matrix that will map the parameters associated with a smooth term to the predicted values for the term at new covariate values. Note that new smooth classes can be added by writing a new \code{smooth.construct} method function and a corresponding \code{\link{Predict.matrix}} method function: see the example code provided for \code{\link{smooth.construct}} for details.} \references{ Wood S.N. (2006) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. } \author{Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gam}},\code{\link{gamm}}, \code{\link{smooth.construct}}, \code{\link{PredictMat}} } \examples{# See smooth.construct examples } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/bam.Rd0000744000177400001440000004170512764211311013207 0ustar murdochusers\name{bam} \alias{bam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generalized additive models for very large datasets} \description{ Fits a generalized additive model (GAM) to a very large data set, the term `GAM' being taken to include any quadratically penalized GLM. The degree of smoothness of model terms is estimated as part of fitting. In use the function is much like \code{\link{gam}}, except that the numerical methods are designed for datasets containing upwards of several tens of thousands of data (see Wood, Goude and Shaw, 2015). The advantage of \code{bam} is much lower memory footprint than \code{\link{gam}}, but it can also be much faster, for large datasets. \code{bam} can also compute on a cluster set up by the \link[parallel]{parallel} package. An alternative fitting approach is provided by the \code{discrete==TRUE} method. In this case a method based on discretization of covariate values and C code level parallelization (controlled by the \code{nthreads} argument instead of the \code{cluster} argument) is used. This extends both the data set and model size usable. } \usage{ bam(formula,family=gaussian(),data=list(),weights=NULL,subset=NULL, na.action=na.omit, offset=NULL,method="fREML",control=list(), select=FALSE,scale=0,gamma=1,knots=NULL,sp=NULL,min.sp=NULL, paraPen=NULL,chunk.size=10000,rho=0,AR.start=NULL,discrete=FALSE, cluster=NULL,nthreads=NA,gc.level=1,use.chol=FALSE,samfrac=1, coef=NULL,drop.unused.levels=TRUE,G=NULL,fit=TRUE,drop.intercept=NULL,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{formula}{ A GAM formula (see \code{\link{formula.gam}} and also \code{\link{gam.models}}). This is exactly like the formula for a GLM except that smooth terms, \code{s} and \code{te} can be added to the right hand side to specify that the linear predictor depends on smooth functions of predictors (or linear functionals of these). } \item{family}{ This is a family object specifying the distribution and link to use in fitting etc. See \code{\link{glm}} and \code{\link{family}} for more details. A negative binomial family is provided: see \code{\link{negbin}}, but only the known theta case is supported by \code{bam}. } \item{data}{ A data frame or list containing the model response variable and covariates required by the formula. By default the variables are taken from \code{environment(formula)}: typically the environment from which \code{gam} is called.} \item{weights}{ prior weights on the contribution of the data to the log likelihood. Note that a weight of 2, for example, is equivalent to having made exactly the same observation twice. If you want to reweight the contributions of each datum without changing the overall magnitude of the log likelihood, then you should normalize the weights (e.g. \code{weights <- weights/mean(weights)}).} \item{subset}{ an optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{ a function which indicates what should happen when the data contain `NA's. The default is set by the `na.action' setting of `options', and is `na.fail' if that is unset. The ``factory-fresh'' default is `na.omit'.} \item{offset}{Can be used to supply a model offset for use in fitting. Note that this offset will always be completely ignored when predicting, unlike an offset included in \code{formula} (this used to conform to the behaviour of \code{lm} and \code{glm}).} \item{method}{The smoothing parameter estimation method. \code{"GCV.Cp"} to use GCV for unknown scale parameter and Mallows' Cp/UBRE/AIC for known scale. \code{"GACV.Cp"} is equivalent, but using GACV in place of GCV. \code{"REML"} for REML estimation, including of unknown scale, \code{"P-REML"} for REML estimation, but using a Pearson estimate of the scale. \code{"ML"} and \code{"P-ML"} are similar, but using maximum likelihood in place of REML. Default \code{"fREML"} uses fast REML computation.} \item{control}{A list of fit control parameters to replace defaults returned by \code{\link{gam.control}}. Any control parameters not supplied stay at their default values.} \item{select}{Should selection penalties be added to the smooth effects, so that they can in principle be penalized out of the model? Has the side effect that smooths no longer have a fixed effect component (improper prior from a Bayesian perspective) allowing REML comparison of models with the same fixed effect structure. } \item{scale}{ If this is positive then it is taken as the known scale parameter. Negative signals that the scale paraemter is unknown. 0 signals that the scale parameter is 1 for Poisson and binomial and unknown otherwise. Note that (RE)ML methods can only work with scale parameter 1 for the Poisson and binomial cases. } \item{gamma}{It is sometimes useful to inflate the model degrees of freedom in the GCV or UBRE/AIC score by a constant multiplier. This allows such a multiplier to be supplied. } \item{knots}{this is an optional list containing user specified knot values to be used for basis construction. For most bases the user simply supplies the knots to be used, which must match up with the \code{k} value supplied (note that the number of knots is not always just \code{k}). See \code{\link{tprs}} for what happens in the \code{"tp"/"ts"} case. Different terms can use different numbers of knots, unless they share a covariate. } \item{sp}{A vector of smoothing parameters can be provided here. Smoothing parameters must be supplied in the order that the smooth terms appear in the model formula. Negative elements indicate that the parameter should be estimated, and hence a mixture of fixed and estimated parameters is possible. If smooths share smoothing parameters then \code{length(sp)} must correspond to the number of underlying smoothing parameters.} \item{min.sp}{Lower bounds can be supplied for the smoothing parameters. Note that if this option is used then the smoothing parameters \code{full.sp}, in the returned object, will need to be added to what is supplied here to get the smoothing parameters actually multiplying the penalties. \code{length(min.sp)} should always be the same as the total number of penalties (so it may be longer than \code{sp}, if smooths share smoothing parameters).} \item{paraPen}{optional list specifying any penalties to be applied to parametric model terms. \code{\link{gam.models}} explains more.} \item{chunk.size}{The model matrix is created in chunks of this size, rather than ever being formed whole. Reset to \code{4*p} if \code{chunk.size < 4*p} where \code{p} is the number of coefficients.} \item{rho}{An AR1 error model can be used for the residuals (based on dataframe order), of Gaussian-identity link models. This is the AR1 correlation parameter. Standardized residuals (approximately uncorrelated under correct model) returned in \code{std.rsd} if non zero. } \item{AR.start}{logical variable of same length as data, \code{TRUE} at first observation of an independent section of AR1 correlation. Very first observation in data frame does not need this. If \code{NULL} then there are no breaks in AR1 correlaion.} \item{discrete}{with \code{method="fREML"} it is possible to discretize covariates for storage and efficiency reasons. If \code{discrete} is \code{TRUE}, a number or a vector of numbers for each smoother term, then discretization happens. If numbers are supplied they give the number of discretization bins. Experimental at present. } \item{cluster}{\code{bam} can compute the computationally dominant QR decomposition in parallel using \link[parallel]{parLapply} from the \code{parallel} package, if it is supplied with a cluster on which to do this (a cluster here can be some cores of a single machine). See details and example code. } \item{nthreads}{Number of threads to use for non-cluster computation (e.g. combining results from cluster nodes). if \code{NA} set to \code{max(1,length(cluster))}.} \item{gc.level}{to keep the memory footprint down, it helps to call the garbage collector often, but this takes a substatial amount of time. Setting this to zero means that garbage collection only happens when R decides it should. Setting to 2 gives frequent garbage collection. 1 is in between.} \item{use.chol}{By default \code{bam} uses a very stable QR update approach to obtaining the QR decomposition of the model matrix. For well conditioned models an alternative accumulates the crossproduct of the model matrix and then finds its Choleski decomposition, at the end. This is somewhat more efficient, computationally.} \item{samfrac}{For very large sample size Generalized additive models the number of iterations needed for the model fit can be reduced by first fitting a model to a random sample of the data, and using the results to supply starting values. This initial fit is run with sloppy convergence tolerances, so is typically very low cost. \code{samfrac} is the sampling fraction to use. 0.1 is often reasonable. } \item{coef}{initial values for model coefficients} \item{drop.unused.levels}{by default unused levels are dropped from factors before fitting. For some smooths involving factor variables you might want to turn this off. Only do so if you know what you are doing.} \item{G}{if not \code{NULL} then this should be the object returned by a previous call to \code{bam} with \code{fit=FALSE}. Causes all other arguments to be ignored except \code{chunk.size}, \code{gamma},\code{nthreads}, \code{cluster}, \code{rho}, \code{gc.level}, \code{samfrac}, \code{use.chol} and \code{method}.} \item{fit}{if \code{FALSE} then the model is set up for fitting but not estimated, and an object is returned, suitable for passing as the \code{G} argument to \code{bam}.} \item{drop.intercept}{Set to \code{TRUE} to force the model to really not have the a constant in the parametric model part, even with factor variables present.} \item{...}{further arguments for passing on e.g. to \code{gam.fit} (such as \code{mustart}). } } \value{ An object of class \code{"gam"} as described in \code{\link{gamObject}}. } \details{ When \code{discrete=FALSE}, \code{bam} operates by first setting up the basis characteristics for the smooths, using a representative subsample of the data. Then the model matrix is constructed in blocks using \code{\link{predict.gam}}. For each block the factor R, from the QR decomposition of the whole model matrix is updated, along with Q'y. and the sum of squares of y. At the end of block processing, fitting takes place, without the need to ever form the whole model matrix. In the generalized case, the same trick is used with the weighted model matrix and weighted pseudodata, at each step of the PIRLS. Smoothness selection is performed on the working model at each stage (performance oriented iteration), to maintain the small memory footprint. This is trivial to justify in the case of GCV or Cp/UBRE/AIC based model selection, and for REML/ML is justified via the asymptotic multivariate normality of Q'z where z is the IRLS pseudodata. For full method details see Wood, Goude and Shaw (2015). Note that POI is not as stable as the default nested iteration used with \code{\link{gam}}, but that for very large, information rich, datasets, this is unlikely to matter much. Note also that it is possible to spend most of the computational time on basis evaluation, if an expensive basis is used. In practice this means that the default \code{"tp"} basis should be avoided: almost any other basis (e.g. \code{"cr"} or \code{"ps"}) can be used in the 1D case, and tensor product smooths (\code{te}) are typically much less costly in the multi-dimensional case. If \code{cluster} is provided as a cluster set up using \code{\link[parallel]{makeCluster}} (or \code{\link[parallel]{makeForkCluster}}) from the \code{parallel} package, then the rate limiting QR decomposition of the model matrix is performed in parallel using this cluster. Note that the speed ups are often not that great. On a multi-core machine it is usually best to set the cluster size to the number of physical cores, which is often less than what is reported by \code{\link[parallel]{detectCores}}. Using more than the number of physical cores can result in no speed up at all (or even a slow down). Note that a highly parallel BLAS may negate all advantage from using a cluster of cores. Computing in parallel of course requires more memory than computing in series. See examples. When \code{discrete=TRUE} the covariate data are first discretized. Discretization takes place on a smooth by smooth basis, or in the case of tensor product smooths (or any smooth that can be represented as such, such as random effects), separately for each marginal smooth. The required spline bases are then evaluated at the discrete values, and stored, along with index vectors indicating which original observation they relate to. Fitting is by a version of performance oriented iteration/PQL using REML smoothing parameter selection on each iterative working model (as for the default method). The iteration is based on the derivatives of the REML score, without computing the score itself, allowing the expensive computations to be reduced to one parallel block Cholesky decomposition per iteration (plus two basic operations of equal cost, but easily parallelized). Unlike standard POI/PQL, only one step of the smoothing parameter update for the working model is taken at each step (rather than iterating to the optimal set of smoothing parameters for each working model). At each step a weighted model matrix crossproduct of the model matrix is required - this is efficiently computed from the pre-computed basis functions evaluated at the discretized covariate values. Efficient computation with tensor product terms means that some terms within a tensor product may be re-ordered for maximum efficiency. Parallel computation is controlled using the \code{nthreads} argument. For this method no cluster computation is used, and the \code{parallel} package is not required. } \references{ Wood, S.N., Goude, Y. & Shaw S. (2015) Generalized additive models for large datasets. Journal of the Royal Statistical Society, Series C 64(1): 139-155. Wood, S.N., Li, Z., Shaddick, G. & Augustin N.H. (2016) Generalized additive models for gigadata: modelling the UK black smoke network daily data. Journal of the American Statistical Association. } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \section{WARNINGS }{ The routine will be slow if the default \code{"tp"} basis is used. Unless discrete=TRUE, you must have more unique combinations of covariates than the model has total parameters. (Total parameters is sum of basis dimensions plus sum of non-spline terms less the number of spline terms). This routine is less stable than `gam' for the same dataset. The negbin family is only supported for the *known theta* case. } \seealso{\code{\link{mgcv.parallel}}, \code{\link{mgcv-package}}, \code{\link{gamObject}}, \code{\link{gam.models}}, \code{\link{smooth.terms}}, \code{\link{linear.functional.terms}}, \code{\link{s}}, \code{\link{te}} \code{\link{predict.gam}}, \code{\link{plot.gam}}, \code{\link{summary.gam}}, \code{\link{gam.side}}, \code{\link{gam.selection}}, \code{\link{gam.control}} \code{\link{gam.check}}, \code{\link{linear.functional.terms}} \code{\link{negbin}}, \code{\link{magic}},\code{\link{vis.gam}} } \examples{ library(mgcv) ## See help("mgcv-parallel") for using bam in parallel ## Some examples are marked 'Not run' purely to keep ## checking load on CRAN down. Sample sizes are small for ## the same reason. set.seed(3) dat <- gamSim(1,n=25000,dist="normal",scale=20) bs <- "cr";k <- 12 b <- bam(y ~ s(x0,bs=bs)+s(x1,bs=bs)+s(x2,bs=bs,k=k)+ s(x3,bs=bs),data=dat) summary(b) plot(b,pages=1,rug=FALSE) ## plot smooths, but not rug plot(b,pages=1,rug=FALSE,seWithMean=TRUE) ## `with intercept' CIs \dontrun{ ba <- bam(y ~ s(x0,bs=bs,k=k)+s(x1,bs=bs,k=k)+s(x2,bs=bs,k=k)+ s(x3,bs=bs,k=k),data=dat,method="GCV.Cp") ## use GCV summary(ba)} ## A Poisson example... k <- 15 dat <- gamSim(1,n=21000,dist="poisson",scale=.1) system.time(b1 <- bam(y ~ s(x0,bs=bs)+s(x1,bs=bs)+s(x2,bs=bs,k=k), data=dat,family=poisson())) b1 ## Sparse smoother example (deprecated)... \dontrun{ dat <- gamSim(1,n=10000,dist="poisson",scale=.1) system.time( b3 <- bam(y ~ te(x0,x1,bs="ps",k=10,np=FALSE)+ s(x2,bs="ps",k=30)+s(x3,bs="ps",k=30),data=dat, method="REML",family=poisson(),sparse=TRUE)) b3} } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. \concept{Varying coefficient model} \concept{Functional linear model} \concept{Penalized GLM} \concept{Generalized Additive Model} \concept{Penalized regression} \concept{Spline smoothing} \concept{Penalized regression spline} \concept{Generalized Cross Validation} \concept{Smoothing parameter selection} \concept{tensor product smoothing} \concept{thin plate spline} \concept{P-spline} \concept{Generalized ridge regression} mgcv/man/coxph.Rd0000744000177400001440000001217612760266600013600 0ustar murdochusers\name{cox.ph} \alias{cox.ph} %- Also NEED an `\alias' for EACH other topic documented here. \title{Additive Cox Proportional Hazard Model} \description{The \code{cox.ph} family implements the Cox Proportional Hazards model with Peto's correction for ties, and estimation by penalized partial likelihood maximization, for use with \code{\link{gam}}. In the model formula, event time is the response. The \code{weights} vector provides the censoring information (0 for censoring, 1 for event). Deals with the case in which each subject has one event/censoring time and one row of covariate values. When each subject has several time dependent covariates see \code{\link{cox.pht}}. } \usage{ cox.ph(link="identity") } \arguments{ \item{link}{currently (and possibly for ever) only \code{"identity"} supported.} } \value{ An object inheriting from class \code{general.family}. } \details{Used with \code{\link{gam}} to fit Cox Proportional Hazards models to survival data. The model formula will have event/censoring times on the left hand side and the linear predictor specification on the right hand side. Censoring information is provided by the \code{weights} argument to \code{gam}, with 1 indicating an event and 0 indicating censoring. Prediction from the fitted model object (using the \code{predict} method) with \code{type="response"} will predict on the survivor function scale. See example code below for extracting the cumulative baseline hazard/survival directly. Martingale or deviance residuals can be extracted. The \code{fitted.values} stored in the model object are survival function estimates for each subject at their event/censoring time. Estimation of model coefficients is by maximising the log-partial likelihood penalized by the smoothing penalties. See e.g. Hastie and Tibshirani, 1990, section 8.3. for the partial likelihood used (with Peto's approximation for ties), but note that optimization of the partial likelihood does not follow Hastie and Tibshirani. See Klein amd Moeschberger (2003) for estimation of residuals, the cumulative baseline hazard, survival function and associated standard errors (the survival standard error expression has a typo). The percentage deviance explained reported for Cox PH models is based on the sum of squares of the deviance residuals, as the model deviance, and the sum of squares of the deviance residuals when the covariate effects are set to zero, as the null deviance. The same baseline hazard estimate is used for both. This family deals efficiently with the case in which each subject has one event/censoring time and one row of covariate values. For studies in which there are multiple time varying covariate measures for each subject then the equivalent Poisson model should be fitted to suitable pseudodata using \code{bam(...,discrete=TRUE)}. } \references{ Hastie and Tibshirani (1990) Generalized Additive Models, Chapman and Hall. Klein, J.P and Moeschberger, M.L. (2003) Survival Analysis: Techniques for Censored and Truncated Data (2nd ed.) Springer. Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association. \url{http://arxiv.org/abs/1511.03864} } \examples{ library(mgcv) library(survival) ## for data col1 <- colon[colon$etype==1,] ## concentrate on single event col1$differ <- as.factor(col1$differ) col1$sex <- as.factor(col1$sex) b <- gam(time~s(age,by=sex)+sex+s(nodes)+perfor+rx+obstruct+adhere, family=cox.ph(),data=col1,weights=status) summary(b) plot(b,pages=1,all.terms=TRUE) ## plot effects plot(b$linear.predictors,residuals(b)) ## plot survival function for patient j... np <- 300;j <- 6 newd <- data.frame(time=seq(0,3000,length=np)) dname <- names(col1) for (n in dname) newd[[n]] <- rep(col1[[n]][j],np) newd$time <- seq(0,3000,length=np) fv <- predict(b,newdata=newd,type="response",se=TRUE) plot(newd$time,fv$fit,type="l",ylim=c(0,1),xlab="time",ylab="survival") lines(newd$time,fv$fit+2*fv$se.fit,col=2) lines(newd$time,fv$fit-2*fv$se.fit,col=2) ## crude plot of baseline survival... plot(b$family$data$tr,exp(-b$family$data$h),type="l",ylim=c(0,1), xlab="time",ylab="survival") lines(b$family$data$tr,exp(-b$family$data$h + 2*b$family$data$q^.5),col=2) lines(b$family$data$tr,exp(-b$family$data$h - 2*b$family$data$q^.5),col=2) lines(b$family$data$tr,exp(-b$family$data$km),lty=2) ## Kaplan Meier ## Simple simulated known truth example... ph.weibull.sim <- function(eta,gamma=1,h0=.01,t1=100) { lambda <- h0*exp(eta) n <- length(eta) U <- runif(n) t <- (-log(U)/lambda)^(1/gamma) d <- as.numeric(t <= t1) t[!d] <- t1 list(t=t,d=d) } n <- 500;set.seed(2) x0 <- runif(n, 0, 1);x1 <- runif(n, 0, 1) x2 <- runif(n, 0, 1);x3 <- runif(n, 0, 1) f0 <- function(x) 2 * sin(pi * x) f1 <- function(x) exp(2 * x) f2 <- function(x) 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 f3 <- function(x) 0*x f <- f0(x0) + f1(x1) + f2(x2) g <- (f-mean(f))/5 surv <- ph.weibull.sim(g) surv$x0 <- x0;surv$x1 <- x1;surv$x2 <- x2;surv$x3 <- x3 b <- gam(t~s(x0)+s(x1)+s(x2,k=15)+s(x3),family=cox.ph,weights=d,data=surv) plot(b,pages=1) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/gam.convergence.Rd0000644000177400001440000000762112632334033015510 0ustar murdochusers\name{gam.convergence} \alias{gam.convergence} \alias{gam.performance} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM convergence and performance issues} \description{ When fitting GAMs there is a tradeoff between speed of fitting and probability of fit convergence. The default fitting options, specified by \code{\link{gam}} arguments \code{method} and \code{optimizer}, opt for certainty of convergence over speed of fit. In the Generalized Additive Model case it means using `outer' iteration in preference to `performance iteration': see \code{\link{gam.outer}} for details. It is possible for the default `outer' iteration to fail when finding intial smoothing parameters using a few steps of performance iteration (if you get a convergence failure message from \code{magic} when outer iterating, then this is what has happened): lower \code{outerPIsteps} in \code{\link{gam.control}} to fix this. There are three things that you can try to speed up GAM fitting. (i) if you have large numbers of smoothing parameters in the generalized case, then try the \code{"bfgs"} method option in \code{\link{gam}} argument \code{optimizer}: this can be faster than the default. (ii) Change the \code{optimizer} argument to \code{\link{gam}} so that `performance iteration' is used in place of the default outer iteration. Usually performance iteration converges well and it can sometimes be quicker than the default outer iteration. (iii) For large datasets it may be worth changing the smoothing basis to use \code{bs="cr"} (see \code{\link{s}} for details) for 1-d smooths, and to use \code{\link{te}} smooths in place of \code{\link{s}} smooths for smooths of more than one variable. This is because the default thin plate regression spline basis \code{"tp"} is costly to set up for large datasets (much over 1000 data, say). (iv) consider using \code{\link{bam}}. If the GAM estimation process fails to converge when using performance iteration, then switch to outer iteration via the \code{optimizer} argument of \code{\link{gam}}. If it still fails, try increasing the number of IRLS iterations (see \code{\link{gam.control}}) or perhaps experiment with the convergence tolerance. If you still have problems, it's worth noting that a GAM is just a (penalized) GLM and the IRLS scheme used to estimate GLMs is not guaranteed to converge. Hence non convergence of a GAM may relate to a lack of stability in the basic IRLS scheme. Therefore it is worth trying to establish whether the IRLS iterations are capable of converging. To do this fit the problematic GAM with all smooth terms specified with \code{fx=TRUE} so that the smoothing parameters are all fixed at zero. If this `largest' model can converge then, then the maintainer would quite like to know about your problem! If it doesn't converge, then its likely that your model is just too flexible for the IRLS process itself. Having tried increasing \code{maxit} in \code{gam.control}, there are several other possibilities for stabilizing the iteration. It is possible to try (i) setting lower bounds on the smoothing parameters using the \code{min.sp} argument of \code{gam}: this may or may not change the model being fitted; (ii) reducing the flexibility of the model by reducing the basis dimensions \code{k} in the specification of \code{s} and \code{te} model terms: this obviously changes the model being fitted somewhat; (iii) introduce a small regularization term into the fitting via the \code{irls.reg} argument of \code{gam.control}: this option obviously changes the nature of the fit somewhat, since parameter estimates are pulled towards zero by doing this. Usually, a major contributer to fitting difficulties is that the model is a very poor description of the data. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood \email{simon.wood@r-project.org}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/bug.reports.mgcv.Rd0000755000177400001440000000255412666035464015674 0ustar murdochusers\name{bug.reports.mgcv} \alias{bug.reports.mgcv} %- Also NEED an `\alias' for EACH other topic documented here. \title{Reporting mgcv bugs.} \description{\code{mgcv} works largely because many people have reported bugs over the years. If you find something that looks like a bug, please report it, so that the package can be improved. \code{mgcv} does not have a large development budget, so it is a big help if bug reports follow the following guidelines. The ideal report consists of an email to \email{simon.wood@r-project.org} with a subject line including \code{mgcv} somewhere, containing \enumerate{ \item The results of running \code{\link{sessionInfo}} in the R session where the problem occurs. This provides platform details, R and package version numbers, etc. \item A brief description of the problem. \item Short cut and paste-able code that produces the problem, including the code for loading/generating the data (using standard R functions like \code{load}, \code{read.table} etc). \item Any required data files. If you send real data it will only be used for the purposes of de-bugging. } Of course if you have dug deeper and have an idea of what is causing the problem, that is also helpful to know, as is any suggested code fix. (Don't send a fixed package .tar.gz file, however - I can't use this). } \author{ Simon N. Wood \email{simon.wood@r-project.org}} mgcv/man/gam.fit.Rd0000744000177400001440000000536412632744256014013 0ustar murdochusers\name{gam.fit} \alias{gam.fit} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM P-IRLS estimation with GCV/UBRE smoothness estimation} \description{ This is an internal function of package \code{mgcv}. It is a modification of the function \code{glm.fit}, designed to be called from \code{gam} when perfomance iteration is selected (not the default). The major modification is that rather than solving a weighted least squares problem at each IRLS step, a weighted, penalized least squares problem is solved at each IRLS step with smoothing parameters associated with each penalty chosen by GCV or UBRE, using routine \code{\link{magic}}. For further information on usage see code for \code{gam}. Some regularization of the IRLS weights is also permitted as a way of addressing identifiability related problems (see \code{\link{gam.control}}). Negative binomial parameter estimation is supported. The basic idea of estimating smoothing parameters at each step of the P-IRLS is due to Gu (1992), and is termed `performance iteration' or `performance oriented iteration'. } \usage{ gam.fit(G, start = NULL, etastart = NULL, mustart = NULL, family = gaussian(), control = gam.control(),gamma=1, fixedSteps=(control$maxit+1),...) } \arguments{ \item{G}{An object of the type returned by \code{\link{gam}} when \code{fit=FALSE}.} \item{start}{Initial values for the model coefficients.} \item{etastart}{Initial values for the linear predictor.} \item{mustart}{Initial values for the expected response.} \item{family}{The family object, specifying the distribution and link to use.} \item{control}{Control option list as returned by \code{\link{gam.control}}.} \item{gamma}{Parameter which can be increased to up the cost of each effective degree of freedom in the GCV or AIC/UBRE objective.} \item{fixedSteps}{How many steps to take: useful when only using this routine to get rough starting values for other methods.} \item{...}{Other arguments: ignored.} } \value{A list of fit information.} \references{ Gu (1992) Cross-validating non-Gaussian data. J. Comput. Graph. Statist. 1:169-179 Gu and Wahba (1991) Minimizing GCV/GML scores with multiple smoothing parameters via the Newton method. SIAM J. Sci. Statist. Comput. 12:383-398 Wood, S.N. (2000) Modelling and Smoothing Parameter Estimation with Multiple Quadratic Penalties. J.R.Statist.Soc.B 62(2):413-428 Wood, S.N. (2004) Stable and efficient multiple smoothing parameter estimation for generalized additive models. J. Amer. Statist. Ass. 99:637-686 } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gam.fit3}}, \code{\link{gam}}, \code{\link{magic}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/tensor.prod.model.matrix.Rd0000644000177400001440000000443612632334033017327 0ustar murdochusers\name{tensor.prod.model.matrix} \alias{tensor.prod.model.matrix} \alias{tensor.prod.penalties} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Utility functions for constructing tensor product smooths} \description{ Produce model matrices or penalty matrices for a tensor product smooth from the model matrices or penalty matrices for the marginal bases of the smooth. } \usage{ tensor.prod.model.matrix(X) tensor.prod.penalties(S) } %- maybe also `usage' for other objects documented here. \arguments{ \item{X}{a list of model matrices for the marginal bases of a smooth} \item{S}{a list of penalties for the marginal bases of a smooth.} } \details{ If \code{X[[1]]}, \code{X[[2]]} ... \code{X[[m]]} are the model matrices of the marginal bases of a tensor product smooth then the ith row of the model matrix for the whole tensor product smooth is given by \code{X[[1]][i,]\%x\%X[[2]][i,]\%x\% ... X[[m]][i,]}, where \code{\%x\%} is the Kronecker product. Of course the routine operates column-wise, not row-wise! If \code{S[[1]]}, \code{S[[2]]} ... \code{S[[m]]} are the penalty matrices for the marginal bases, and \code{I[[1]]}, \code{I[[2]]} ... \code{I[[m]]} are corresponding identity matrices, each of the same dimension as its corresponding penalty, then the tensor product smooth has m associate penalties of the form: \code{S[[1]]\%x\%I[[2]]\%x\% ... I[[m]]}, \code{I[[1]]\%x\%S[[2]]\%x\% ... I[[m]]} ... \code{I[[1]]\%x\%I[[2]]\%x\% ... S[[m]]}. Of course it's important that the model matrices and penalty matrices are presented in the same order when constructing tensor product smooths. } \value{ Either a single model matrix for a tensor product smooth, or a list of penalty terms for a tensor product smooth. } \references{ Wood, S.N. (2006) Low rank scale invariant tensor product smooths for Generalized Additive Mixed Models. Biometrics 62(4):1025-1036 } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{te}}, \code{\link{smooth.construct.tensor.smooth.spec}} } \examples{ require(mgcv) X <- list(matrix(1:4,2,2),matrix(5:10,2,3)) tensor.prod.model.matrix(X) S<-list(matrix(c(2,1,1,2),2,2),matrix(c(2,1,0,1,2,1,0,1,2),3,3)) tensor.prod.penalties(S) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/influence.gam.Rd0000644000177400001440000000145712632334033015163 0ustar murdochusers\name{influence.gam} \alias{influence.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Extract the diagonal of the influence/hat matrix for a GAM } \description{ Extracts the leading diagonal of the influence matrix (hat matrix) of a fitted \code{gam} object. } \usage{ \method{influence}{gam}(model,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{model}{ fitted model objects of class \code{gam} as produced by \code{gam()}.} \item{...}{un-used in this case} } \details{ Simply extracts \code{hat} array from fitted model. (More may follow!) } \value{ An array (see above). } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gam}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/gamlss.gH.Rd0000644000177400001440000000564113037406120014267 0ustar murdochusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gamlss.R \name{gamlss.gH} \alias{gamlss.gH} \title{Calculating derivatives of log-likelihood wrt regression coefficients} \usage{ gamlss.gH(X, jj, l1, l2, i2, l3 = 0, i3 = 0, l4 = 0, i4 = 0, d1b = 0, d2b = 0, deriv = 0, fh = NULL, D = NULL) } \arguments{ \item{X}{matrix containing the model matrices of all the linear predictors.} \item{jj}{list of index vectors such that \code{X[,jj[[i]]]} is the model matrix of the i-th linear predictor.} \item{l1}{array of 1st order derivatives of each element of the log-likelihood wrt each parameter.} \item{l2}{array of 2nd order derivatives of each element of the log-likelihood wrt each parameter.} \item{i2}{two-dimensional index array, such that \code{l2[,i2[i,j]]} contains the partial w.r.t. params indexed by i,j with no restriction on the index values (except that they are in 1,...,ncol(l1)).} \item{l3}{array of 3rd order derivatives of each element of the log-likelihood wrt each parameter.} \item{i3}{third-dimensional index array, such that \code{l3[,i3[i,j,k]]} contains the partial w.r.t. params indexed by i,j,k.} \item{l4}{array of 4th order derivatives of each element of the log-likelihood wrt each parameter.} \item{i4}{third-dimensional index array, such that \code{l4[,i4[i,j,k,l]]} contains the partial w.r.t. params indexed by i,j,k,l.} \item{d1b}{first derivatives of the regression coefficients wrt the smoothing parameters.} \item{d2b}{second derivatives of the regression coefficients wrt the smoothing parameters.} \item{deriv}{if \code{deriv==0} only first and second order derivatives will be calculated. If \code{deriv==1} the function return also the diagonal of the first derivative of the Hessian, if \code{deriv==2} it return the full 3rd order derivative and if \code{deriv==3} it provides also 4th order derivatives.} \item{fh}{eigen-decomposition or Cholesky factor of the penalized Hessian.} \item{D}{diagonal matrix, used to provide some scaling.} } \value{ A list containing \code{lb} - the grad vector w.r.t. coefs; \code{lbb} - the Hessian matrix w.r.t. coefs; \code{d1H} - either a list of the derivatives of the Hessian w.r.t. the smoothing parameters, or a single matrix whose columns are the leading diagonals of these dervative matrices; \code{trHid2H} - the trace of the inverse Hessian multiplied by the second derivative of the Hessian w.r.t. all combinations of smoothing parameters. } \description{ Mainly intended for internal use with location scale model families. Given the derivatives of the log-likelihood wrt the linear predictor, this function obtains the derivatives and Hessian wrt the regression coefficients and derivatives of the Hessian w.r.t. the smoothing parameters. For input derivative array packing conventions see \code{\link{trind.generator}}. } \seealso{ \code{\link{trind.generator}}} \author{ Simon N. Wood . } mgcv/man/pen.edf.Rd0000644000177400001440000000454712632334033013772 0ustar murdochusers\name{pen.edf} \alias{pen.edf} %- Also NEED an `\alias' for EACH other topic documented here. \title{Extract the effective degrees of freedom associated with each penalty in a gam fit} \description{Finds the coefficients penalized by each penalty and adds up their effective degrees of freedom. Very useful for \code{\link{t2}} terms, but hard to interpret for terms where the penalties penalize overlapping sets of parameters (e.g. \code{\link{te}} terms). } \usage{ pen.edf(x) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{ an object inheriting from \code{gam}} } \details{Useful for models containing \code{\link{t2}} terms, since it splits the EDF for the term up into parts due to different components of the smooth. This is useful for figuring out which interaction terms are actually needed in a model. } \value{ A vector of EDFs, named with labels identifying which penalty each EDF relates to. } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \seealso{ \code{\link{t2}}} \examples{ require(mgcv) set.seed(20) dat <- gamSim(1,n=400,scale=2) ## simulate data ## following `t2' smooth basically separates smooth ## of x0,x1 into main effects + interaction.... b <- gam(y~t2(x0,x1,bs="tp",m=1,k=7)+s(x2)+s(x3), data=dat,method="ML") pen.edf(b) ## label "rr" indicates interaction edf (range space times range space) ## label "nr" (null space for x0 times range space for x1) is main ## effect for x1. ## label "rn" is main effect for x0 ## clearly interaction is negligible ## second example with higher order marginals. b <- gam(y~t2(x0,x1,bs="tp",m=2,k=7,full=TRUE) +s(x2)+s(x3),data=dat,method="ML") pen.edf(b) ## In this case the EDF is negligible for all terms in the t2 smooth ## apart from the `main effects' (r2 and 2r). To understand the labels ## consider the following 2 examples.... ## "r1" relates to the interaction of the range space of the first ## marginal smooth and the first basis function of the null ## space of the second marginal smooth ## "2r" relates to the interaction of the second basis function of ## the null space of the first marginal smooth with the range ## space of the second marginal smooth. } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/mgcv-parallel.Rd0000744000177400001440000001363612645144575015217 0ustar murdochusers\name{mgcv.parallel} \alias{mgcv.parallel} \title{Parallel computation in mgcv. } \description{ \code{mgcv} can make some use of multiple cores or a cluster. \code{\link{bam}} can use an openMP based parallelization approach alongside discretisation of covariates to achieve substantial speed ups. This is selected using the \code{discrete=TRUE} option to \code{bam}, withthe number of threads controlled via the \code{nthreads} argument. This is the approach that scales best. See example below. Alternatively, function \code{\link{bam}} can use the facilities provided in the \link[parallel]{parallel} package. See examples below. Note that most multi-core machines are memory bandwidth limited, so parallel speed up tends to be rather variable. Function \code{\link{gam}} can use parallel threads on a (shared memory) multi-core machine via \code{openMP} (where this is supported). To do this, set the desired number of threads by setting \code{nthreads} to the number of cores to use, in the \code{control} argument of \code{\link{gam}}. Note that, for the most part, only the dominant \eqn{O(np^2)}{O(np^2)} steps are parallelized (n is number of data, p number of parameters). For additive Gaussian models estimated by GCV, the speed up can be disappointing as these employ an \eqn{O(p^3)}{O(p^3)} SVD step that can also have substantial cost in practice. \code{\link{magic}} can also use multiple cores, but the same comments apply as for the GCV Gaussian additive model. If \code{control$nthreads} is set to more than the number of cores detected, then only the number of detected cores is used. Note that using virtual cores usually gives very little speed up, and can even slow computations slightly. For example, many Intel processors reporting 4 cores actually have 2 physical cores, each with 2 virtual cores, so using 2 threads gives a marked increase in speed, while using 4 threads makes little extra difference. Note that on Intel and similar processors the maximum performance is usually achieved by disabling Hyper-Threading in BIOS, and then setting the number of threads to the number of physical cores used. This prevents the operating system scheduler from sending 2 floating point intensive threads to the same physical core, where they have to share a floating point unit (and cache) and therefore slow each other down. The scheduler tends to do this under the manager - worker multi-threading approach used in mgcv, since the manager thread looks very busy up to the point at which the workers are set to work, and at the point of scheduling the sceduler has no way of knowing that the manager thread actually has nothing more to do until the workers are finished. If you are working on a many cored platform where you can not disable hyper-threading then it may be worth setting the number of threads to one less than the number of physical cores, to reduce the frequency of such scheduling problems. mgcv's work splitting always makes the simple assumption that all your cores are equal, and you are not sharing them with other floating point intensive threads. In addition to hyper-threading several features may lead to apparently poor scaling. The first is that many CPUs have a Turbo mode, whereby a few cores can be run at higher frequency, provided the overall power used by the CPU does not exceed design limits, however it is not possible for all cores on the CPU to run at this frequency. So as you add threads eventually the CPU frequency has to be reduced below the Turbo frequency, with the result that you don't get the expected speed up from adding cores. Secondly, most modern CPUs have their frequency set dynamically according to load. You may need to set the system power management policy to favour high performance in order to maximize the chance that all threads run at the speed you were hoping for (you can turn off dynamic power control in BIOS, but then you turn off the possibility of Turbo also). Because the computational burden in \code{mgcv} is all in the linear algebra, then parallel computation may provide reduced or no benefit with a tuned BLAS. This is particularly the case if you are using a multi threaded BLAS, but a BLAS that is tuned to make efficient use of a particular cache size may also experience loss of performance if threads have to share the cache. } \author{ Simon Wood } \references{ \url{https://computing.llnl.gov/tutorials/openMP/} } \keyword{ package } \keyword{models} \keyword{smooth} \keyword{regression} \examples{ ## illustration of multi-threading with gam... require(mgcv);set.seed(9) dat <- gamSim(1,n=2000,dist="poisson",scale=.1) k <- 12;bs <- "cr";ctrl <- list(nthreads=2) system.time(b1<-gam(y~s(x0,bs=bs)+s(x1,bs=bs)+s(x2,bs=bs,k=k) ,family=poisson,data=dat,method="REML"))[3] system.time(b2<-gam(y~s(x0,bs=bs)+s(x1,bs=bs)+s(x2,bs=bs,k=k), family=poisson,data=dat,method="REML",control=ctrl))[3] ## Poisson example on a cluster with 'bam'. ## Note that there is some overhead in initializing the ## computation on the cluster, associated with loading ## the Matrix package on each node. For this reason the ## sample sizes here are very small to keep CRAN happy, but at ## this low sample size you see little advantage of parallel computation. k <- 13 dat <- gamSim(1,n=6000,dist="poisson",scale=.1) require(parallel) nc <- 2 ## cluster size, set for example portability if (detectCores()>1) { ## no point otherwise cl <- makeCluster(nc) ## could also use makeForkCluster, but read warnings first! } else cl <- NULL system.time(b3 <- bam(y ~ s(x0,bs=bs,k=7)+s(x1,bs=bs,k=7)+s(x2,bs=bs,k=k) ,data=dat,family=poisson(),chunk.size=5000,cluster=cl)) fv <- predict(b3,cluster=cl) ## parallel prediction if (!is.null(cl)) stopCluster(cl) b3 ## Alternative using the discrete option with bam... system.time(b4 <- bam(y ~ s(x0,bs=bs,k=7)+s(x1,bs=bs,k=7)+s(x2,bs=bs,k=k) ,data=dat,family=poisson(),discrete=TRUE,nthreads=2)) } mgcv/man/Beta.Rd0000744000177400001440000000532512632334033013322 0ustar murdochusers\name{betar} \alias{betar} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM beta regression family} \description{Family for use with \code{\link{gam}}, implementing regression for beta distributed data on (0,1). A linear predictor controls the mean, \eqn{\mu}{mu} of the beta distribution, while the variance is then \eqn{\mu(1-\mu)/(1+\phi)}{mu(1-mu)/(1+phi)}, with parameter \eqn{\phi}{phi} being estimated during fitting, alongside the smoothing parameters. } \usage{ betar(theta = NULL, link = "logit",eps=.Machine$double.eps*100) } \arguments{ \item{theta}{the extra parameter (\eqn{\phi}{phi} above). } \item{link}{The link function: one of \code{"logit"}, \code{"probit"}, \code{"cloglog"} and \code{"cauchit"}.} \item{eps}{the response variable will be truncated to the interval \code{[eps,1-eps]} if there are values outside this range. This truncation is not entirely benign, but too small a value of \code{eps} will cause stability problems if there are zeroes or ones in the response.} } \value{ An object of class \code{extended.family}. } \details{These models are useful for proportions data which can not be modelled as binomial. Note the assumption that data are in (0,1), despite the fact that for some parameter values 0 and 1 are perfectly legitimate observations. The restriction is needed to keep the log likelihood bounded for all parameter values. Any data exactly at 0 or 1 are reset to be just above 0 or just below 1 using the \code{eps} argument (in fact any observation \code{1-eps} is reset to \code{1-eps}). Note the effect of this resetting. If \eqn{\mu\phi>1}{mu*phi>1} then impossible 0s are replaced with highly improbable \code{eps} values. If the inequality is reversed then 0s with infinite probability density are replaced with \code{eps} values having high finite probability density. The equivalent condition for 1s is \eqn{(1-\mu)\phi>1}{(1-mu)*phi>1}. Clearly all types of resetting are somewhat unsatisfactory, and care is needed if data contain 0s or 1s (often it makes sense to manually reset the 0s and 1s in a manner that somehow reflects the sampling setup). } %- maybe also `usage' for other objects documented here. \author{ Natalya Pya (nyp20@bath.ac.uk) and Simon Wood (s.wood@r-project.org) } \section{WARNINGS}{ Do read the details section if your data contain 0s and or 1s. } \examples{ library(mgcv) ## Simulate some beta data... set.seed(3);n<-400 dat <- gamSim(1,n=n) mu <- binomial()$linkinv(dat$f/4-2) phi <- .5 a <- mu*phi;b <- phi - a; dat$y <- rbeta(n,a,b) bm <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=betar(link="logit"),data=dat) bm plot(bm,pages=1) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.mrf.smooth.spec.Rd0000744000177400001440000001456412632334033021034 0ustar murdochusers\name{smooth.construct.mrf.smooth.spec} \alias{smooth.construct.mrf.smooth.spec} \alias{Predict.matrix.mrf.smooth} \alias{mrf} %- Also NEED an `\alias' for EACH other topic documented here. \title{Markov Random Field Smooths} \description{For data observed over discrete spatial units, a simple Markov random field smoother is sometimes appropriate. These functions provide such a smoother class for \code{mgcv}. See details for how to deal with regions with missing data. } \usage{ \method{smooth.construct}{mrf.smooth.spec}(object, data, knots) \method{Predict.matrix}{mrf.smooth}(object, data) } \arguments{ \item{object}{For the \code{smooth.construct} method a smooth specification object, usually generated by a term \code{s(x,...,bs="mrf",xt=list(polys=foo))}. \code{x} is a factor variable giving labels for geographic districts, and the \code{xt} argument is obligatory: see details. For the \code{Predict.Matrix} method an object of class \code{"mrf.smooth"} produced by the \code{smooth.construct} method.} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{If there are more geographic areas than data were observed for, then this argument is used to provide the labels for all the areas (observed and unobserved). } } \value{ An object of class \code{"mrf.smooth"} or a matrix mapping the coefficients of the MRF smooth to the predictions for the areas listed in \code{data}. } \details{A Markov random field smooth over a set of discrete areas is defined using a set of area labels, and a neighbourhood structure for the areas. The covariate of the smooth is the vector of area labels corresponding to each obervation. This covariate should be a factor, or capable of being coerced to a factor. The neighbourhood structure is supplied in the \code{xt} argument to \code{s}. This must contain at least one of the elements \code{polys}, \code{nb} or \code{penalty}. \describe{ \item{polys}{contains the polygons defining the geographic areas. It is a list with as many elements as there are geographic areas. \code{names(polys)} must correspond to the levels of the argument of the smooth, in any order (i.e. it gives the area labels). \code{polys[[i]]} is a 2 column matrix the rows of which specify the vertices of the polygon(s) defining the boundary of the ith area. A boundary may be made up of several closed loops: these must be separated by \code{NA} rows. A polygon within another is treated as a hole. The first polygon in any \code{polys[[i]]} should not be a hole. An example of the structure is provided by \code{\link{columb.polys}} (which contains an artificial hole in its second element, for illustration). Any list elements with duplicate names are combined into a single NA separated matrix. Plotting of the smooth is not possible without a \code{polys} object. If \code{polys} is the only element of \code{xt} provided, then the neighbourhood structure is computed from it automatically. To count as neigbours, polygons must exactly share one of more vertices. } \item{nb}{is a named list defining the neighbourhood structure. \code{names(nb)} must correspond to the levels of the covariate of the smooth (i.e. the area labels), but can be in any order. \code{nb[[i]]} is a vector indexing the neighbours of the ith area. All indices are relative to \code{nb} itself, but can be translated using \code{names(nb)}. If no \code{penalty} is provided then it is computed automatically from this list. The ith row of the penalty matrix will be zero everwhere, except in the ith column, which will contain the number of neighbours of the ith geographic area, and the columns corresponding to those geographic neighbours, which will each contain -1. } \item{penalty}{ if this is supplied, then it is used as the penalty matrix. It should be positive semi-definite. Its row and column names should correspond to the levels of the covariate.} } If no basis dimension is supplied then the constructor produces a full rank MRF, with a coefficient for each geographic area. Otherwise a low rank approximation is obtained based on truncation of the parameterization given in Wood (2006) Section 4.10.4. Note that smooths of this class have a built in plot method, and that the utility function \code{\link{in.out}} can be useful for working with discrete area data. The plot method has two schemes, \code{scheme==0} is colour, \code{scheme==1} is grey scale. The situation in which there are areas with no data requires special handling. You should set \code{drop.unused.levels=FALSE} in the model fitting function, \code{\link{gam}}, \code{\link{bam}} or \code{\link{gamm}}, having first ensured that any fixed effect factors do not contain unobserved levels. Also make sure that the basis dimension is set to ensure that the total number of coefficients is less than the number of observations. } \references{ Wood S.N. (2006) Generalized additive models: an introduction with R. CRC. } \author{ Simon N. Wood \email{simon.wood@r-project.org} and Thomas Kneib (Fabian Scheipl prototyped the low rank MRF idea) } \seealso{\code{\link{in.out}}, \code{\link{polys.plot}}} \examples{ library(mgcv) ## Load Columbus Ohio crime data (see ?columbus for details and credits) data(columb) ## data frame data(columb.polys) ## district shapes list xt <- list(polys=columb.polys) ## neighbourhood structure info for MRF par(mfrow=c(2,2)) ## First a full rank MRF... b <- gam(crime ~ s(district,bs="mrf",xt=xt),data=columb,method="REML") plot(b,scheme=1) ## Compare to reduced rank version... b <- gam(crime ~ s(district,bs="mrf",k=20,xt=xt),data=columb,method="REML") plot(b,scheme=1) ## An important covariate added... b <- gam(crime ~ s(district,bs="mrf",k=20,xt=xt)+s(income), data=columb,method="REML") plot(b,scheme=c(0,1)) ## plot fitted values by district par(mfrow=c(1,1)) fv <- fitted(b) names(fv) <- as.character(columb$district) polys.plot(columb.polys,fv) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/gamObject.Rd0000744000177400001440000002250212632334033014336 0ustar murdochusers\name{gamObject} \alias{gamObject} %- Also NEED an `\alias' for EACH other topic documented here. \title{Fitted gam object} \description{A fitted GAM object returned by function \code{gam} and of class \code{"gam"} inheriting from classes \code{"glm"} and \code{"lm"}. Method functions \code{anova}, \code{logLik}, \code{influence}, \code{plot}, \code{predict}, \code{print}, \code{residuals} and \code{summary} exist for this class. All compulsory elements of \code{"glm"} and \code{"lm"} objects are present, but the fitting method for a GAM is different to a linear model or GLM, so that the elements relating to the QR decomposition of the model matrix are absent. } \value{ A \code{gam} object has the following elements: \item{aic}{AIC of the fitted model: bear in mind that the degrees of freedom used to calculate this are the effective degrees of freedom of the model, and the likelihood is evaluated at the maximum of the penalized likelihood in most cases, not at the MLE.} \item{assign}{Array whose elements indicate which model term (listed in \code{pterms}) each parameter relates to: applies only to non-smooth terms.} \item{boundary}{did parameters end up at boundary of parameter space?} \item{call}{the matched call (allows \code{update} to be used with \code{gam} objects, for example). } \item{cmX}{column means of the model matrix (with elements corresponding to smooths set to zero ) --- useful for componentwise CI calculation.} \item{coefficients}{the coefficients of the fitted model. Parametric coefficients are first, followed by coefficients for each spline term in turn.} \item{control}{the \code{gam} control list used in the fit.} \item{converged}{indicates whether or not the iterative fitting method converged.} \item{data}{the original supplied data argument (for class \code{"glm"} compatibility). Only included if \code{\link{gam}} \code{control} argument element \code{keepData} is set to \code{TRUE} (default is \code{FALSE}).} \item{db.drho}{matrix of first derivatives of model coefficients w.r.t. log smoothing parameters.} \item{deviance}{model deviance (not penalized deviance).} \item{df.null}{null degrees of freedom.} \item{df.residual}{effective residual degrees of freedom of the model.} \item{edf}{estimated degrees of freedom for each model parameter. Penalization means that many of these are less than 1.} \item{edf1}{similar, but using alternative estimate of EDF. Useful for testing.} \item{edf2}{if estimation is by ML or REML then an edf that accounts for smoothing parameter uncertainty can be computed, this is it. \code{edf1} is a heuristic upper bound for \code{edf2}.} \item{family}{family object specifying distribution and link used.} \item{fitted.values}{fitted model predictions of expected value for each datum.} \item{formula}{the model formula.} \item{full.sp}{full array of smoothing parameters multiplying penalties (excluding any contribution from \code{min.sp} argument to \code{gam}). May be larger than \code{sp} if some terms share smoothing parameters, and/or some smoothing parameter values were supplied in the \code{sp} argument of \code{\link{gam}}.} \item{F}{Degrees of freedom matrix. This may be removed at some point, and should probably not be used.} \item{gcv.ubre}{The minimized smoothing parameter selection score: GCV, UBRE(AIC), GACV, negative log marginal likelihood or negative log restricted likelihood.} \item{hat}{array of elements from the leading diagonal of the `hat' (or `influence') matrix. Same length as response data vector.} \item{iter}{number of iterations of P-IRLS taken to get convergence.} \item{linear.predictors}{fitted model prediction of link function of expected value for each datum.} \item{method}{One of \code{"GCV"} or \code{"UBRE"}, \code{"REML"}, \code{"P-REML"}, \code{"ML"}, \code{"P-ML"}, \code{"PQL"}, \code{"lme.ML"} or \code{"lme.REML"}, depending on the fitting criterion used.} \item{mgcv.conv}{ A list of convergence diagnostics relating to the \code{"magic"} parts of smoothing parameter estimation - this will not be very meaningful for pure \code{"outer"} estimation of smoothing parameters. The items are: \code{full.rank}, The apparent rank of the problem given the model matrix and constraints; \code{rank}, The numerical rank of the problem; \code{fully.converged}, \code{TRUE} is multiple GCV/UBRE converged by meeting convergence criteria and \code{FALSE} if method stopped with a steepest descent step failure; \code{hess.pos.def}Was the hessian of the GCV/UBRE score positive definite at smoothing parameter estimation convergence?; \code{iter} How many iterations were required to find the smoothing parameters? \code{score.calls}, and how many times did the GCV/UBRE score have to be evaluated?; \code{rms.grad}, root mean square of the gradient of the GCV/UBRE score at convergence. } % end of mgcv.conv listing \item{min.edf}{Minimum possible degrees of freedom for whole model.} \item{model}{model frame containing all variables needed in original model fit.} \item{na.action}{The \code{\link{na.action}} used in fitting.} \item{nsdf}{number of parametric, non-smooth, model terms including the intercept.} \item{null.deviance}{deviance for single parameter model.} \item{offset}{model offset.} \item{optimizer}{\code{optimizer} argument to \code{\link{gam}}, or \code{"magic"} if it's a pure additive model.} \item{outer.info}{If `outer' iteration has been used to fit the model (see \code{\link{gam}} argument \code{optimizer}) then this is present and contains whatever was returned by the optimization routine used (currently \code{\link{nlm}} or \code{\link{optim}}). } \item{paraPen}{If the \code{paraPen} argument to \code{\link{gam}} was used then this provides information on the parametric penalties. \code{NULL} otherwise.} \item{pred.formula}{one sided formula containing variables needed for prediction, used by \code{predict.gam}} \item{prior.weights}{prior weights on observations.} \item{pterms}{\code{terms} object for strictly parametric part of model.} \item{R}{Factor R from QR decomposition of weighted model matrix, unpivoted to be in same column order as model matrix (so need not be upper triangular).} \item{rank}{apparent rank of fitted model.} \item{reml.scale}{The scale (RE)ML scale parameter estimate, if (P-)(RE)ML used for smoothness estimation. } \item{residuals}{the working residuals for the fitted model.} \item{rV}{If present, \code{rV\%*\%t(rV)*sig2} gives the estimated Bayesian covariance matrix.} \item{scale}{when present, the scale (as \code{sig2})} \item{scale.estimated}{ \code{TRUE} if the scale parameter was estimated, \code{FALSE} otherwise.} \item{sig2}{estimated or supplied variance/scale parameter.} \item{smooth}{list of smooth objects, containing the basis information for each term in the model formula in the order in which they appear. These smooth objects are what gets returned by the \code{\link{smooth.construct}} objects.} \item{sp}{estimated smoothing parameters for the model. These are the underlying smoothing parameters, subject to optimization. For the full set of smoothing parameters multiplying the penalties see \code{full.sp}. Divide the scale parameter by the smoothing parameters to get, variance components, but note that this is not valid for smooths that have used rescaling to improve conditioning.} \item{terms}{\code{terms} object of \code{model} model frame.} \item{var.summary}{A named list of summary information on the predictor variables. If a parametric variable is a matrix, then the summary is a one row matrix, containing the observed data value closest to the column median, for each matrix column. If the variable is a factor the then summary is the modal factor level, returned as a factor, with levels corresponding to those of the data. For numerics and matrix arguments of smooths, the summary is the mean, nearest observed value to median and maximum, as a numeric vector. Used by \code{\link{vis.gam}}, in particular. } \item{Ve}{frequentist estimated covariance matrix for the parameter estimators. Particularly useful for testing whether terms are zero. Not so useful for CI's as smooths are usually biased.} \item{Vp}{estimated covariance matrix for the parameters. This is a Bayesian posterior covariance matrix that results from adopting a particular Bayesian model of the smoothing process. Paricularly useful for creating credible/confidence intervals.} \item{Vc}{Under ML or REML smoothing parameter estimation it is possible to correct the covariance matrix \code{Vp} for smoothing parameter uncertainty. This is the corrected version. } \item{weights}{final weights used in IRLS iteration.} \item{y}{response data.} } \references{ A Key Reference on this implementation: Wood, S.N. (2006) Generalized Additive Models: An Introduction with R. Chapman & Hall/ CRC, Boca Raton, Florida Key Reference on GAMs generally: Hastie (1993) in Chambers and Hastie (1993) Statistical Models in S. Chapman and Hall. Hastie and Tibshirani (1990) Generalized Additive Models. Chapman and Hall. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \section{WARNINGS }{ This model object is different to that described in Chambers and Hastie (1993) in order to allow smoothing parameter estimation etc. } \seealso{\code{\link{gam}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/smoothCon.Rd0000744000177400001440000001656612732164566014446 0ustar murdochusers\name{smoothCon} \alias{smoothCon} \alias{PredictMat} %- Also NEED an `\alias' for EACH other topic documented here. \title{Prediction/Construction wrapper functions for GAM smooth terms} \description{ Wrapper functions for construction of and prediction from smooth terms in a GAM. The purpose of the wrappers is to allow user-transparant re-parameterization of smooth terms, in order to allow identifiability constraints to be absorbed into the parameterization of each term, if required. The routine also handles `by' variables and construction of identifiability constraints automatically, although this behaviour can be over-ridden. } \usage{ smoothCon(object,data,knots=NULL,absorb.cons=FALSE, scale.penalty=TRUE,n=nrow(data),dataX=NULL, null.space.penalty=FALSE,sparse.cons=0, diagonal.penalty=FALSE,apply.by=TRUE,modCon=0) PredictMat(object,data,n=nrow(data)) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ is a smooth specification object or a smooth object.} \item{data}{A data frame, model frame or list containing the values of the (named) covariates at which the smooth term is to be evaluated. If it's a list then \code{n} must be supplied.} \item{knots}{An optional data frame supplying any knot locations to be supplied for basis construction.} \item{absorb.cons}{Set to \code{TRUE} in order to have identifiability constraints absorbed into the basis.} \item{scale.penalty}{should the penalty coefficient matrix be scaled to have approximately the same `size' as the inner product of the terms model matrix with itself? This can improve the performance of \code{\link{gamm}} fitting.} \item{n}{number of values for each covariate, or if a covariate is a matrix, the number of rows in that matrix: must be supplied explicitly if \code{data} is a list. } \item{dataX}{Sometimes the basis should be set up using data in \code{data}, but the model matrix should be constructed with another set of data provided in \code{dataX} --- \code{n} is assumed to be the same for both. Facilitates smooth id's.} \item{null.space.penalty}{Should an extra penalty be added to the smooth which will penalize the components of the smooth in the penalty null space: provides a way of penalizing terms out of the model altogether.} \item{apply.by}{set to \code{FALSE} to have basis setup exactly as in default case, but to return add an additional matrix \code{X0} to the return object, containing the model matrix without the \code{by} variable, if a \code{by} variable is present. Useful for \code{bam} discrete method setup.} \item{sparse.cons}{If \code{0} then default sum to zero constraints are used. If \code{-1} then sweep and drop sum to zero constraints are used (default with \code{\link{bam}}). If \code{1} then one coefficient is set to zero as constraint for sparse smooths. If \code{2} then sparse coefficient sum to zero constraints are used for sparse smooths. None of these options has an effect if the smooth supplies its own constraint.} \item{diagonal.penalty}{ If \code{TRUE} then the smooth is reparameterized to turn the penalty into an identity matrix, with the final diagonal elements zeroed (corresponding to the penalty nullspace). May result in a matrix \code{diagRP} in the returned object for use by \code{PredictMat}.} \item{modCon}{force modification of any smooth supplied constraints. 0 - do nothing. 1 - delete supplied constraints, replacing with automatically generated ones. 2 - set fit and predict constraint to predict constraint. 3 - set fit and predict constraint to fit constraint.} } \value{ From \code{smoothCon} a list of \code{smooth} objects returned by the appropriate \code{\link{smooth.construct}} method function. If constraints are to be absorbed then the objects will have attributes \code{"qrc"} and \code{"nCons"}. \code{"nCons"} is the number of constraints. \code{"qrc"} is usually the qr decomposition of the constraint matrix (returned by \code{\link{qr}}), but if it is a single positive integer it is the index of the coefficient to set to zero, and if it is a negative number then this indicates that the parameters are to sum to zero. For \code{predictMat} a matrix which will map the parameters associated with the smooth to the vector of values of the smooth evaluated at the covariate values given in \code{object}. } \details{ These wrapper functions exist to allow smooths specified using \code{\link{smooth.construct}} and \code{\link{Predict.matrix}} method functions to be re-parameterized so that identifiability constraints are no longer required in fitting. This is done in a user transparent manner, but is typically of no importance in use of GAMs. The routine's also handle \code{by} variables and will create default identifiability constraints. If a user defined smooth constructor handles \code{by} variables itself, then its returned smooth object should contain an object \code{by.done}. If this does not exist then \code{smoothCon} will use the default code. Similarly if a user defined \code{Predict.matrix} method handles \code{by} variables internally then the returned matrix should have a \code{"by.done"} attribute. Default centering constraints, that terms should sum to zero over the covariates, are produced unless the smooth constructor includes a matrix \code{C} of constraints. To have no constraints (in which case you had better have a full rank penalty!) the matrix \code{C} should have no rows. There is an option to use centering constraint that generate no, or limited infil, if the smoother has a sparse model matrix. \code{smoothCon} returns a list of smooths because factor \code{by} variables result in multiple copies of a smooth, each multiplied by the dummy variable associated with one factor level. \code{smoothCon} modifies the smooth object labels in the presence of \code{by} variables, to ensure that they are unique, it also stores the level of a by variable factor associated with a smooth, for later use by \code{PredictMat}. The parameterization used by \code{\link{gam}} can be controlled via \code{\link{gam.control}}. } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gam.control}}, \code{\link{smooth.construct}}, \code{\link{Predict.matrix}} } \examples{ ## example of using smoothCon and PredictMat to set up a basis ## to use for regression and make predictions using the result library(MASS) ## load for mcycle data. ## set up a smoother... sm <- smoothCon(s(times,k=10),data=mcycle,knots=NULL)[[1]] ## use it to fit a regression spline model... beta <- coef(lm(mcycle$accel~sm$X-1)) with(mcycle,plot(times,accel)) ## plot data times <- seq(0,60,length=200) ## creat prediction times ## Get matrix mapping beta to spline prediction at 'times' Xp <- PredictMat(sm,data.frame(times=times)) lines(times,Xp\%*\%beta) ## add smooth to plot ## Same again but using a penalized regression spline of ## rank 30.... sm <- smoothCon(s(times,k=30),data=mcycle,knots=NULL)[[1]] E <- t(mroot(sm$S[[1]])) ## square root penalty X <- rbind(sm$X,0.1*E) ## augmented model matrix y <- c(mcycle$accel,rep(0,nrow(E))) ## augmented data beta <- coef(lm(y~X-1)) ## fit penalized regression spline Xp <- PredictMat(sm,data.frame(times=times)) ## prediction matrix with(mcycle,plot(times,accel)) ## plot data lines(times,Xp\%*\%beta) ## overlay smooth } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/uniquecombs.Rd0000744000177400001440000000665613016361533015013 0ustar murdochusers\name{uniquecombs} \alias{uniquecombs} %- Also NEED an `\alias' for EACH other topic documented here. \title{find the unique rows in a matrix } \description{ This routine returns a matrix or data frame containing all the unique rows of the matrix or data frame supplied as its argument. That is, all the duplicate rows are stripped out. Note that the ordering of the rows on exit need not be the same as on entry. It also returns an index attribute for relating the result back to the original matrix. } \usage{ uniquecombs(x,ordered=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{ is an \R matrix (numeric), or data frame. } \item{ordered}{ set to \code{TRUE} to have the rows of the returned object in the same order regardless of input ordering.} } \details{ Models with more parameters than unique combinations of covariates are not identifiable. This routine provides a means of evaluating the number of unique combinations of covariates in a model. When \code{x} has only one column then the routine uses \code{\link{unique}} and \code{\link{match}} to get the index. When there are multiple columns then it uses \code{\link{paste0}} to produce labels for each row, which should be unique if the row is unique. Then \code{unique} and \code{match} can be used as in the single column case. Obviously the pasting is inefficient, but still quicker for large n than the C based code that used to be called by this routine, which had O(nlog(n)) cost. In principle a hash table based solution in C would be only O(n) and much quicker in the multicolumn case. \code{\link{unique}} and \code{\link{duplicated}}, can be used in place of this, if the full index is not needed. Relative performance is variable. If \code{x} is not a matrix or data frame on entry then an attempt is made to coerce it to a data frame. } \value{ A matrix or data frame consisting of the unique rows of \code{x} (in arbitrary order). The matrix or data frame has an \code{"index"} attribute. \code{index[i]} gives the row of the returned matrix that contains row i of the original matrix. } \seealso{\code{\link{unique}}, \code{\link{duplicated}}, \code{\link{match}}.} \author{ Simon N. Wood \email{simon.wood@r-project.org} with thanks to Jonathan Rougier} \section{WARNINGS }{ If a dataframe contains variables of a type other than numeric, logical, factor or character, which either have no \code{as.character} method, or whose \code{as.character} method is a many to one mapping, then the routine is likely to fail. If the character representation of a dataframe variable (other than of class factor of character) contains \code{*} then in priniciple the method could fail (but with a warning). } \examples{ require(mgcv) ## matrix example... X <- matrix(c(1,2,3,1,2,3,4,5,6,1,3,2,4,5,6,1,1,1),6,3,byrow=TRUE) print(X) Xu <- uniquecombs(X);Xu ind <- attr(Xu,"index") ## find the value for row 3 of the original from Xu Xu[ind[3],];X[3,] ## same with fixed output ordering Xu <- uniquecombs(X,TRUE);Xu ind <- attr(Xu,"index") ## find the value for row 3 of the original from Xu Xu[ind[3],];X[3,] ## data frame example... df <- data.frame(f=factor(c("er",3,"b","er",3,3,1,2,"b")), x=c(.5,1,1.4,.5,1,.6,4,3,1.7), bb = c(rep(TRUE,5),rep(FALSE,4)), fred = c("foo","a","b","foo","a","vf","er","r","g"), stringsAsFactors=FALSE) uniquecombs(df) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/print.gam.Rd0000744000177400001440000000323512632334033014344 0ustar murdochusers\name{print.gam} \alias{print.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Print a Generalized Additive Model object.} \description{ The default print method for a \code{gam} object. } \usage{ \method{print}{gam}(x, ...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x, ...}{ fitted model objects of class \code{gam} as produced by \code{gam()}.} } \details{ Prints out the family, model formula, effective degrees of freedom for each smooth term, and optimized value of the smoothness selection criterion used. See \code{\link{gamObject}} (or \code{names(x)}) for a listing of what the object contains. \code{\link{summary.gam}} provides more detail. Note that the optimized smoothing parameter selection criterion reported is one of GCV, UBRE(AIC), GACV, negative log marginal likelihood (ML), or negative log restricted likelihood (REML). If rank deficiency of the model was detected then the apparent rank is reported, along with the length of the cofficient vector (rank in absense of rank deficieny). Rank deficiency occurs when not all coefficients are identifiable given the data. Although the fitting routines (except \code{gamm}) deal gracefully with rank deficiency, interpretation of rank deficient models may be difficult. } \references{ Wood, S.N. (2006) Generalized Additive Models: An Introduction with R. CRC/ Chapmand and Hall, Boca Raton, Florida. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \seealso{ \code{\link{gam}}, \code{\link{summary.gam}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/mvn.Rd0000744000177400001440000000446612770452577013275 0ustar murdochusers\name{mvn} \alias{mvn} %- Also NEED an `\alias' for EACH other topic documented here. \title{Multivariate normal additive models} \description{Family for use with \code{\link{gam}} implementing smooth multivariate Gaussian regression. The means for each dimension are given by a separate linear predictor, which may contain smooth components. Extra linear predictors may also be specified giving terms which are shared between components (see \code{\link{formula.gam}}). The Choleski factor of the response precision matrix is estimated as part of fitting. } \usage{ mvn(d=2) } \arguments{ \item{d}{The dimension of the response (>1).} } \value{ An object of class \code{general.family}. } \details{The response is \code{d} dimensional multivariate normal, where the covariance matrix is estimated, and the means for each dimension have sperate linear predictors. Model sepcification is via a list of gam like formulae - one for each dimension. See example. Currently the family ignores any prior weights, and is implemented using first derivative information sufficient for BFGS estimation of smoothing parameters. \code{"response"} residuals give raw residuals, while \code{"deviance"} residuals are standardized to be approximately independent standard normal if all is well. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood \email{simon.wood@r-project.org} } \references{ Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association. \url{http://arxiv.org/abs/1511.03864} } \seealso{\code{\link{gaussian}}} \examples{ library(mgcv) ## simulate some data... V <- matrix(c(2,1,1,2),2,2) f0 <- function(x) 2 * sin(pi * x) f1 <- function(x) exp(2 * x) f2 <- function(x) 0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10 n <- 300 x0 <- runif(n);x1 <- runif(n); x2 <- runif(n);x3 <- runif(n) y <- matrix(0,n,2) for (i in 1:n) { mu <- c(f0(x0[i])+f1(x1[i]),f2(x2[i])) y[i,] <- rmvn(1,mu,V) } dat <- data.frame(y0=y[,1],y1=y[,2],x0=x0,x1=x1,x2=x2,x3=x3) ## fit model... b <- gam(list(y0~s(x0)+s(x1),y1~s(x2)+s(x3)),family=mvn(d=2),data=dat) b summary(b) plot(b,pages=1) solve(crossprod(b$family$data$R)) ## estimated cov matrix } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/initial.sp.Rd0000744000177400001440000000413112632334033014513 0ustar murdochusers\name{initial.sp} \alias{initial.sp} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Starting values for multiple smoothing parameter estimation} \description{ Finds initial smoothing parameter guesses for multiple smoothing parameter estimation. The idea is to find values such that the estimated degrees of freedom per penalized parameter should be well away from 0 and 1 for each penalized parameter, thus ensuring that the values are in a region of parameter space where the smoothing parameter estimation criterion is varying substantially with smoothing parameter value. } %- end description \usage{ initial.sp(X,S,off,expensive=FALSE,XX=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{X}{is the model matrix.} \item{S}{ is a list of of penalty matrices. \code{S[[i]]} is the ith penalty matrix, but note that it is not stored as a full matrix, but rather as the smallest square matrix including all the non-zero elements of the penalty matrix. Element 1,1 of \code{S[[i]]} occupies element \code{off[i]}, \code{off[i]} of the ith penalty matrix. Each \code{S[[i]]} must be positive semi-definite. } \item{off}{is an array indicating the first parameter in the parameter vector that is penalized by the penalty involving \code{S[[i]]}.} \item{expensive}{if \code{TRUE} then the overall amount of smoothing is adjusted so that the average degrees of freedom per penalized parameter is exactly 0.5: this is numerically costly. } \item{XX}{if \code{TRUE} then \code{X} contains \eqn{X^TX}{X'X}, rather than \eqn{X}{X}.} } \details{ Basically uses a crude approximation to the estimated degrees of freedom per model coefficient, to try and find smoothing parameters which bound these e.d.f.'s away from 0 and 1. Usually only called by \code{\link{magic}} and \code{\link{gam}}. } \value{ An array of initial smoothing parameter estimates. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{magic}}, \code{\link{gam.outer}}, \code{\link{gam}}, } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/exclude.too.far.Rd0000744000177400001440000000426312632334033015447 0ustar murdochusers\name{exclude.too.far} \alias{exclude.too.far} %- Also NEED an `\alias' for EACH other topic documented here. \title{Exclude prediction grid points too far from data} \description{ Takes two arrays defining the nodes of a grid over a 2D covariate space and two arrays defining the location of data in that space, and returns a logical vector with elements \code{TRUE} if the corresponding node is too far from data and \code{FALSE} otherwise. Basically a service routine for \code{vis.gam} and \code{plot.gam}. } \usage{ exclude.too.far(g1,g2,d1,d2,dist) } %- maybe also `usage' for other objects documented here. \arguments{ \item{g1}{co-ordinates of grid relative to first axis.} \item{g2}{co-ordinates of grid relative to second axis.} \item{d1}{co-ordinates of data relative to first axis.} \item{d2}{co-ordinates of data relative to second axis.} \item{dist}{how far away counts as too far. Grid and data are first scaled so that the grid lies exactly in the unit square, and \code{dist} is a distance within this unit square.} } \details{ Linear scalings of the axes are first determined so that the grid defined by the nodes in \code{g1} and \code{g2} lies exactly in the unit square (i.e. on [0,1] by [0,1]). These scalings are applied to \code{g1}, \code{g2}, \code{d1} and \code{d2}. The minimum Euclidean distance from each node to a datum is then determined and if it is greater than \code{dist} the corresponding entry in the returned array is set to \code{TRUE} (otherwise to \code{FALSE}). The distance calculations are performed in compiled code for speed without storage overheads. } \value{A logical array with \code{TRUE} indicating a node in the grid defined by \code{g1}, \code{g2} that is `too far' from any datum. } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{vis.gam}} } \examples{ library(mgcv) x<-rnorm(100);y<-rnorm(100) # some "data" n<-40 # generate a grid.... mx<-seq(min(x),max(x),length=n) my<-seq(min(y),max(y),length=n) gx<-rep(mx,n);gy<-rep(my,rep(n,n)) tf<-exclude.too.far(gx,gy,x,y,0.1) plot(gx[!tf],gy[!tf],pch=".");points(x,y,col=2) } \keyword{hplot}%-- one or more ... mgcv/man/formula.gam.Rd0000744000177400001440000001533212716310470014660 0ustar murdochusers\name{formula.gam} \alias{formula.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM formula} \description{ Description of \code{\link{gam}} formula (see Details), and how to extract it from a fitted \code{gam} object. } \usage{ \method{formula}{gam}(x,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{ fitted model objects of class \code{gam} (see \code{\link{gamObject}}) as produced by \code{gam()}.} \item{...}{un-used in this case} } \value{ Returns the model formula, \code{x$formula}. Provided so that \code{anova} methods print an appropriate description of the model. } \details{ \code{\link{gam}} will accept a formula or, with some families, a list of formulae. Other \code{mgcv} modelling functions will not accept a list. The list form provides a mechanism for specifying several linear predictors, and allows these to share terms: see below. The formulae supplied to \code{\link{gam}} are exactly like those supplied to \code{\link{glm}} except that smooth terms, \code{\link{s}}, \code{\link{te}}, \code{\link{ti}} and \code{\link{t2}} can be added to the right hand side (and \code{.} is not supported in \code{gam} formulae). Smooth terms are specified by expressions of the form: \cr \code{s(x1,x2,...,k=12,fx=FALSE,bs="tp",by=z,id=1)}\cr where \code{x1}, \code{x2}, etc. are the covariates which the smooth is a function of, and \code{k} is the dimension of the basis used to represent the smooth term. If \code{k} is not specified then basis specific defaults are used. Note that these defaults are essentially arbitrary, and it is important to check that they are not so small that they cause oversmoothing (too large just slows down computation). Sometimes the modelling context suggests sensible values for \code{k}, but if not informal checking is easy: see \code{\link{choose.k}} and \code{\link{gam.check}}. \code{fx} is used to indicate whether or not this term should be unpenalized, and therefore have a fixed number of degrees of freedom set by \code{k} (almost always \code{k-1}). \code{bs} indicates the basis to use for the smooth: the built in options are described in \code{\link{smooth.terms}}, and user defined smooths can be added (see \code{\link{user.defined.smooth}}). If \code{bs} is not supplied then the default \code{"tp"} (\code{\link{tprs}}) basis is used. \code{by} can be used to specify a variable by which the smooth should be multiplied. For example \code{gam(y~s(x,by=z))} would specify a model \eqn{ E(y) = f(x)z}{E(y)=f(x)z} where \eqn{f(\cdot)}{f(.)} is a smooth function. The \code{by} option is particularly useful for models in which different functions of the same variable are required for each level of a factor and for `varying coefficient models': see \code{\link{gam.models}}. \code{id} is used to give smooths identities: smooths with the same identity have the same basis, penalty and smoothing parameter (but different coefficients, so they are different functions). An alternative for specifying smooths of more than one covariate is e.g.: \cr \code{te(x,z,bs=c("tp","tp"),m=c(2,3),k=c(5,10))}\cr which would specify a tensor product smooth of the two covariates \code{x} and \code{z} constructed from marginal t.p.r.s. bases of dimension 5 and 10 with marginal penalties of order 2 and 3. Any combination of basis types is possible, as is any number of covariates. \code{\link{te}} provides further information. \code{\link{ti}} terms are a variant designed to be used as interaction terms when the main effects (and any lower order interactions) are present. \code{\link{t2}} produces tensor product smooths that are the natural low rank analogue of smoothing spline anova models. \code{s}, \code{te}, \code{ti} and \code{t2} terms accept an \code{sp} argument of supplied smoothing parameters: positive values are taken as fixed values to be used, negative to indicate that the parameter should be estimated. If \code{sp} is supplied then it over-rides whatever is in the \code{sp} argument to \code{gam}, if it is not supplied then it defaults to all negative, but does not over-ride the \code{sp} argument to \code{gam}. Formulae can involve nested or ``overlapping'' terms such as \cr \code{y~s(x)+s(z)+s(x,z)} or \code{y~s(x,z)+s(z,v)}\cr but nested models should really be set up using \code{\link{ti}} terms: see \code{\link{gam.side}} for further details and examples. Smooth terms in a \code{gam} formula will accept matrix arguments as covariates (and corresponding \code{by} variable), in which case a `summation convention' is invoked. Consider the example of \code{s(X,Z,by=L)} where \code{X}, \code{Z} and \code{L} are n by m matrices. Let \code{F} be the n by m matrix that results from evaluating the smooth at the values in \code{X} and \code{Z}. Then the contribution to the linear predictor from the term will be \code{rowSums(F*L)} (note the element-wise multiplication). This convention allows the linear predictor of the GAM to depend on (a discrete approximation to) any linear functional of a smooth: see \code{\link{linear.functional.terms}} for more information and examples (including functional linear models/signal regression). Note that \code{gam} allows any term in the model formula to be penalized (possibly by multiple penalties), via the \code{paraPen} argument. See \code{\link{gam.models}} for details and example code. When several formulae are provided in a list, then they can be used to specify multiple linear predictors for families for which this makes sense (e.g. \code{\link{mvn}}). The first formula in the list must include a response variable, but later formulae need not (depending on the requirements of the family). Let the linear predictors be indexed, 1 to d where d is the number of linear predictors, and the indexing is in the order in which the formulae appear in the list. It is possible to supply extra formulae specifying that several linear predictors should share some terms. To do this a formula is supplied in which the response is replaced by numbers specifying the indices of the linear predictors which will shre the terms specified on the r.h.s. For example \code{1+3~s(x)+z-1} specifies that linear predictors 1 and 3 will share the terms \code{s(x)} and \code{z} (but we don't want an extra intercept, as this would usually be unidentifiable). Note that it is possible that a linear predictor only includes shared terms: it must still have its own formula, but the r.h.s. would simply be \code{-1} (e.g. \code{y ~ -1} or \code{~ -1}). } \section{WARNING}{ A code{gam} formula should not refer to variables using e.g. \code{dat[["x"]]}. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gam}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/gam.check.Rd0000744000177400001440000001315712632334033014271 0ustar murdochusers\name{gam.check} \alias{gam.check} \title{Some diagnostics for a fitted gam model} \description{ Takes a fitted \code{gam} object produced by \code{gam()} and produces some diagnostic information about the fitting procedure and results. The default is to produce 4 residual plots, some information about the convergence of the smoothness selection optimization, and to run diagnostic tests of whether the basis dimension choises are adequate. } \usage{ gam.check(b, old.style=FALSE, type=c("deviance","pearson","response"), k.sample=5000,k.rep=200, rep=0, level=.9, rl.col=2, rep.col="gray80", \dots) } \arguments{ \item{b}{a fitted \code{gam} object as produced by \code{\link{gam}()}.} \item{old.style}{If you want old fashioned plots, exactly as in Wood, 2006, set to \code{TRUE}.} \item{type}{type of residuals, see \code{\link{residuals.gam}}, used in all plots.} \item{k.sample}{Above this k testing uses a random sub-sample of data.} \item{k.rep}{how many re-shuffles to do to get p-value for k testing.} \item{rep, level, rl.col, rep.col}{ arguments passed to \code{\link{qq.gam}()} when \code{old.style} is false, see there.} \item{\dots}{extra graphics parameters to pass to plotting functions.} } \value{A vector of reference quantiles for the residual distribution, if these can be computed.} \details{ Checking a fitted \code{gam} is like checking a fitted \code{glm}, with two main differences. Firstly, the basis dimensions used for smooth terms need to be checked, to ensure that they are not so small that they force oversmoothing: the defaults are arbitrary. \code{\link{choose.k}} provides more detail, but the diagnostic tests described below and reported by this function may also help. Secondly, fitting may not always be as robust to violation of the distributional assumptions as would be the case for a regular GLM, so slightly more care may be needed here. In particular, the thoery of quasi-likelihood implies that if the mean variance relationship is OK for a GLM, then other departures from the assumed distribution are not problematic: GAMs can sometimes be more sensitive. For example, un-modelled overdispersion will typically lead to overfit, as the smoothness selection criterion tries to reduce the scale parameter to the one specified. Similarly, it is not clear how sensitive REML and ML smoothness selection will be to deviations from the assumed response dsistribution. For these reasons this routine uses an enhanced residual QQ plot. This function plots 4 standard diagnostic plots, some smoothing parameter estimation convergence information and the results of tests which may indicate if the smoothing basis dimension for a term is too low. Usually the 4 plots are various residual plots. For the default optimization methods the convergence information is summarized in a readable way, but for other optimization methods, whatever is returned by way of convergence diagnostics is simply printed. The test of whether the basis dimension for a smooth is adequate is based on computing an estimate of the residual variance based on differencing residuals that are near neighbours according to the (numeric) covariates of the smooth. This estimate divided by the residual variance is the \code{k-index} reported. The further below 1 this is, the more likely it is that there is missed pattern left in the residuals. The \code{p-value} is computed by simulation: the residuals are randomly re-shuffled \code{k.rep} times to obtain the null distribution of the differencing variance estimator, if there is no pattern in the residuals. For models fitted to more than \code{k.sample} data, the tests are based of \code{k.sample} randomly sampled data. Low p-values may indicate that the basis dimension, \code{k}, has been set too low, especially if the reported \code{edf} is close to \code{k\'}, the maximum possible EDF for the term. Note the disconcerting fact that if the test statistic itself is based on random resampling and the null is true, then the associated p-values will of course vary widely from one replicate to the next. Currently smooths of factor variables are not supported and will give an \code{NA} p-value. Doubling a suspect \code{k} and re-fitting is sensible: if the reported \code{edf} increases substantially then you may have been missing something in the first fit. Of course p-values can be low for reasons other than a too low \code{k}. See \code{\link{choose.k}} for fuller discussion. The QQ plot produced is usually created by a call to \code{\link{qq.gam}}, and plots deviance residuals against approximate theoretical quantilies of the deviance residual distribution, according to the fitted model. If this looks odd then investigate further using \code{\link{qq.gam}}. Note that residuals for models fitted to binary data contain very little information useful for model checking (it is necessary to find some way of aggregating them first), so the QQ plot is unlikely to be useful in this case. } \references{ N.H. Augustin, E-A Sauleaub, S.N. Wood (2012) On quantile quantile plots for generalized linear models. Computational Statistics & Data Analysis. 56(8), 2404-3409. Wood S.N. (2006) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{choose.k}}, \code{\link{gam}}, \code{\link{magic}}} \examples{ library(mgcv) set.seed(0) dat <- gamSim(1,n=200) b<-gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat) plot(b,pages=1) gam.check(b,pch=19,cex=.3) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/s.Rd0000744000177400001440000001476012777125710012726 0ustar murdochusers\name{s} \alias{s} %- Also NEED an `\alias' for EACH other topic documented here. \title{Defining smooths in GAM formulae} \description{ Function used in definition of smooth terms within \code{gam} model formulae. The function does not evaluate a (spline) smooth - it exists purely to help set up a model using spline based smooths. } \usage{s(..., k=-1,fx=FALSE,bs="tp",m=NA,by=NA,xt=NULL,id=NULL,sp=NULL,pc=NULL)} %- maybe also `usage' for other objects documented here. \arguments{ \item{...}{ a list of variables that are the covariates that this smooth is a function of. Transformations whose form depends on the values of the data are best avoided here: e.g. \code{s(log(x))} is fine, but \code{s(I(x/sd(x)))} is not (see \code{\link{predict.gam}}).} \item{k}{ the dimension of the basis used to represent the smooth term. The default depends on the number of variables that the smooth is a function of. \code{k} should not be less than the dimension of the null space of the penalty for the term (see \code{\link{null.space.dimension}}), but will be reset if it is. See \code{\link{choose.k}} for further information.} \item{fx}{indicates whether the term is a fixed d.f. regression spline (\code{TRUE}) or a penalized regression spline (\code{FALSE}).} \item{bs}{a two letter character string indicating the (penalized) smoothing basis to use. (eg \code{"tp"} for thin plate regression spline, \code{"cr"} for cubic regression spline). see \code{\link{smooth.terms}} for an over view of what is available. } \item{m}{The order of the penalty for this term (e.g. 2 for normal cubic spline penalty with 2nd derivatives when using default t.p.r.s basis). \code{NA} signals autoinitialization. Only some smooth classes use this. The \code{"ps"} class can use a 2 item array giving the basis and penalty order separately.} \item{by}{a numeric or factor variable of the same dimension as each covariate. In the numeric vector case the elements multiply the smooth, evaluated at the corresponding covariate values (a `varying coefficient model' results). For the numeric \code{by} variable case the resulting smooth is not usually subject to a centering constraint (so the \code{by variable} should not be added as an additional main effect). In the factor \code{by} variable case a replicate of the smooth is produced for each factor level (these smooths will be centered, so the factor usually needs to be added as a main effect as well). See \code{\link{gam.models}} for further details. A \code{by} variable may also be a matrix if covariates are matrices: in this case implements linear functional of a smooth (see \code{\link{gam.models}} and \code{\link{linear.functional.terms}} for details). } \item{xt}{Any extra information required to set up a particular basis. Used e.g. to set large data set handling behaviour for \code{"tp"} basis.} \item{id}{A label or integer identifying this term in order to link its smoothing parameters to others of the same type. If two or more terms have the same \code{id} then they will have the same smoothing paramsters, and, by default, the same bases (first occurance defines basis type, but data from all terms used in basis construction). An \code{id} with a factor \code{by} variable causes the smooths at each factor level to have the same smoothing parameter.} \item{sp}{any supplied smoothing parameters for this term. Must be an array of the same length as the number of penalties for this smooth. Positive or zero elements are taken as fixed smoothing parameters. Negative elements signal auto-initialization. Over-rides values supplied in \code{sp} argument to \code{\link{gam}}. Ignored by \code{gamm}.} \item{pc}{If not \code{NULL}, signals a point constraint: the smooth should pass through zero at the point given here (as a vector or list with names corresponding to the smooth names). Never ignored if supplied. See \code{\link{identifiability}}. } } \details{The function does not evaluate the variable arguments. To use this function to specify use of your own smooths, note the relationships between the inputs and the output object and see the example in \code{\link{smooth.construct}}. } \value{ A class \code{xx.smooth.spec} object, where \code{xx} is a basis identifying code given by the \code{bs} argument of \code{s}. These \code{smooth.spec} objects define smooths and are turned into bases and penalties by \code{smooth.construct} method functions. The returned object contains the following items: \item{term}{An array of text strings giving the names of the covariates that the term is a function of.} \item{bs.dim}{The dimension of the basis used to represent the smooth.} \item{fixed}{TRUE if the term is to be treated as a pure regression spline (with fixed degrees of freedom); FALSE if it is to be treated as a penalized regression spline} \item{dim}{The dimension of the smoother - i.e. the number of covariates that it is a function of.} \item{p.order}{The order of the t.p.r.s. penalty, or 0 for auto-selection of the penalty order.} \item{by}{is the name of any \code{by} variable as text (\code{"NA"} for none).} \item{label}{A suitable text label for this smooth term.} \item{xt}{The object passed in as argument \code{xt}.} \item{id}{An identifying label or number for the smooth, linking it to other smooths. Defaults to \code{NULL} for no linkage. } \item{sp}{array of smoothing parameters for the term (negative for auto-estimation). Defaults to \code{NULL}.} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 Wood S.N. (2006) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. \url{http://www.maths.bris.ac.uk/~sw15190/} } \seealso{ \code{\link{te}}, \code{\link{gam}}, \code{\link{gamm}}} \examples{ # example utilising `by' variables library(mgcv) set.seed(0) n<-200;sig2<-4 x1 <- runif(n, 0, 1);x2 <- runif(n, 0, 1);x3 <- runif(n, 0, 1) fac<-c(rep(1,n/2),rep(2,n/2)) # create factor fac.1<-rep(0,n)+(fac==1);fac.2<-1-fac.1 # and dummy variables fac<-as.factor(fac) f1 <- exp(2 * x1) - 3.75887 f2 <- 0.2 * x1^11 * (10 * (1 - x1))^6 + 10 * (10 * x1)^3 * (1 - x1)^10 f<-f1*fac.1+f2*fac.2+x2 e <- rnorm(n, 0, sqrt(abs(sig2))) y <- f + e # NOTE: smooths will be centered, so need to include fac in model.... b<-gam(y~fac+s(x1,by=fac)+x2) plot(b,pages=1) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/choose.k.Rd0000744000177400001440000001527312632334033014163 0ustar murdochusers\name{choose.k} \alias{choose.k} %- Also NEED an `\alias' for EACH other topic documented here. \title{Basis dimension choice for smooths} \description{Choosing the basis dimension, and checking the choice, when using penalized regression smoothers. Penalized regression smoothers gain computational efficiency by virtue of being defined using a basis of relatively modest size, \code{k}. When setting up models in the \code{mgcv} package, using \code{\link{s}} or \code{\link{te}} terms in a model formula, \code{k} must be chosen: the defaults are essentially arbitrary. In practice \code{k-1} (or \code{k}) sets the upper limit on the degrees of freedom associated with an \code{\link{s}} smooth (1 degree of freedom is usually lost to the identifiability constraint on the smooth). For \code{\link{te}} smooths the upper limit of the degrees of freedom is given by the product of the \code{k} values provided for each marginal smooth less one, for the constraint. However the actual effective degrees of freedom are controlled by the degree of penalization selected during fitting, by GCV, AIC, REML or whatever is specified. The exception to this is if a smooth is specified using the \code{fx=TRUE} option, in which case it is unpenalized. So, exact choice of \code{k} is not generally critical: it should be chosen to be large enough that you are reasonably sure of having enough degrees of freedom to represent the underlying `truth' reasonably well, but small enough to maintain reasonable computational efficiency. Clearly `large' and `small' are dependent on the particular problem being addressed. As with all model assumptions, it is useful to be able to check the choice of \code{k} informally. If the effective degrees of freedom for a model term are estimated to be much less than \code{k-1} then this is unlikely to be very worthwhile, but as the EDF approach \code{k-1}, checking can be important. A useful general purpose approach goes as follows: (i) fit your model and extract the deviance residuals; (ii) for each smooth term in your model, fit an equivalent, single, smooth to the residuals, using a substantially increased \code{k} to see if there is pattern in the residuals that could potentially be explained by increasing \code{k}. Examples are provided below. The obvious, but more costly, alternative is simply to increase the suspect \code{k} and refit the original model. If there are no statistically important changes as a result of doing this, then \code{k} was large enough. (Change in the smoothness selection criterion, and/or the effective degrees of freedom, when \code{k} is increased, provide the obvious numerical measures for whether the fit has changed substantially.) \code{\link{gam.check}} runs a simple simulation based check on the basis dimensions, which can help to flag up terms for which \code{k} is too low. Grossly too small \code{k} will also be visible from partial residuals available with \code{\link{plot.gam}}. One scenario that can cause confusion is this: a model is fitted with \code{k=10} for a smooth term, and the EDF for the term is estimated as 7.6, some way below the maximum of 9. The model is then refitted with \code{k=20} and the EDF increases to 8.7 - what is happening - how come the EDF was not 8.7 the first time around? The explanation is that the function space with \code{k=20} contains a larger subspace of functions with EDF 8.7 than did the function space with \code{k=10}: one of the functions in this larger subspace fits the data a little better than did any function in the smaller subspace. These subtleties seldom have much impact on the statistical conclusions to be drawn from a model fit, however. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Wood, S.N. (2006) Generalized Additive Models: An Introduction with R. CRC. \url{http://www.maths.bris.ac.uk/~sw15190/} } \examples{ ## Simulate some data .... library(mgcv) set.seed(1) dat <- gamSim(1,n=400,scale=2) ## fit a GAM with quite low `k' b<-gam(y~s(x0,k=6)+s(x1,k=6)+s(x2,k=6)+s(x3,k=6),data=dat) plot(b,pages=1,residuals=TRUE) ## hint of a problem in s(x2) ## the following suggests a problem with s(x2) gam.check(b) ## Another approach (see below for more obvious method).... ## check for residual pattern, removeable by increasing `k' ## typically `k', below, chould be substantially larger than ## the original, `k' but certainly less than n/2. ## Note use of cheap "cs" shrinkage smoothers, and gamma=1.4 ## to reduce chance of overfitting... rsd <- residuals(b) gam(rsd~s(x0,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam(rsd~s(x1,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam(rsd~s(x2,k=40,bs="cs"),gamma=1.4,data=dat) ## `k' too low gam(rsd~s(x3,k=40,bs="cs"),gamma=1.4,data=dat) ## fine ## refit... b <- gam(y~s(x0,k=6)+s(x1,k=6)+s(x2,k=20)+s(x3,k=6),data=dat) gam.check(b) ## better ## similar example with multi-dimensional smooth b1 <- gam(y~s(x0)+s(x1,x2,k=15)+s(x3),data=dat) rsd <- residuals(b1) gam(rsd~s(x0,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam(rsd~s(x1,x2,k=100,bs="ts"),gamma=1.4,data=dat) ## `k' too low gam(rsd~s(x3,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam.check(b1) ## shows same problem ## and a `te' example b2 <- gam(y~s(x0)+te(x1,x2,k=4)+s(x3),data=dat) rsd <- residuals(b2) gam(rsd~s(x0,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam(rsd~te(x1,x2,k=10,bs="cs"),gamma=1.4,data=dat) ## `k' too low gam(rsd~s(x3,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam.check(b2) ## shows same problem ## same approach works with other families in the original model dat <- gamSim(1,n=400,scale=.25,dist="poisson") bp<-gam(y~s(x0,k=5)+s(x1,k=5)+s(x2,k=5)+s(x3,k=5), family=poisson,data=dat,method="ML") gam.check(bp) rsd <- residuals(bp) gam(rsd~s(x0,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam(rsd~s(x1,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam(rsd~s(x2,k=40,bs="cs"),gamma=1.4,data=dat) ## `k' too low gam(rsd~s(x3,k=40,bs="cs"),gamma=1.4,data=dat) ## fine rm(dat) ## More obvious, but more expensive tactic... Just increase ## suspicious k until fit is stable. set.seed(0) dat <- gamSim(1,n=400,scale=2) ## fit a GAM with quite low `k' b <- gam(y~s(x0,k=6)+s(x1,k=6)+s(x2,k=6)+s(x3,k=6), data=dat,method="REML") b ## edf for 3rd smooth is highest as proportion of k -- increase k b <- gam(y~s(x0,k=6)+s(x1,k=6)+s(x2,k=12)+s(x3,k=6), data=dat,method="REML") b ## edf substantially up, -ve REML substantially down b <- gam(y~s(x0,k=6)+s(x1,k=6)+s(x2,k=24)+s(x3,k=6), data=dat,method="REML") b ## slight edf increase and -ve REML change b <- gam(y~s(x0,k=6)+s(x1,k=6)+s(x2,k=40)+s(x3,k=6), data=dat,method="REML") b ## defintely stabilized (but really k around 20 would have been fine) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/Predict.matrix.cr.smooth.Rd0000644000177400001440000000421712632334033017255 0ustar murdochusers\name{Predict.matrix.cr.smooth} \alias{Predict.matrix.cr.smooth} \alias{Predict.matrix.cs.smooth} \alias{Predict.matrix.cyclic.smooth} \alias{Predict.matrix.pspline.smooth} \alias{Predict.matrix.tensor.smooth} \alias{Predict.matrix.tprs.smooth} \alias{Predict.matrix.ts.smooth} \alias{Predict.matrix.t2.smooth} %- Also NEED an `\alias' for EACH other topic documented here. \title{Predict matrix method functions} \description{The various built in smooth classes for use with \code{\link{gam}} have associate \code{\link{Predict.matrix}} method functions to enable prediction from the fitted model. } \usage{ \method{Predict.matrix}{cr.smooth}(object, data) \method{Predict.matrix}{cs.smooth}(object, data) \method{Predict.matrix}{cyclic.smooth}(object, data) \method{Predict.matrix}{pspline.smooth}(object, data) \method{Predict.matrix}{tensor.smooth}(object, data) \method{Predict.matrix}{tprs.smooth}(object, data) \method{Predict.matrix}{ts.smooth}(object, data) \method{Predict.matrix}{t2.smooth}(object, data) } \arguments{ \item{object}{a smooth object, usually generated by a \code{\link{smooth.construct}} method having processed a smooth specification object generated by an \code{\link{s}} or \code{\link{te}} term in a \code{\link{gam}} formula.} \item{data}{ A data frame containing the values of the (named) covariates at which the smooth term is to be evaluated. Exact requirements are as for \code{\link{smooth.construct}} and \code{smooth.construct2}}. } \value{ A matrix mapping the coeffients for the smooth term to its values at the supplied data values. } \details{ The Predict matrix function is not normally called directly, but is rather used internally by \code{\link{predict.gam}} etc. to predict from a fitted \code{\link{gam}} model. See \code{\link{Predict.matrix}} for more details, or the specific \code{smooth.construct} pages for details on a particular smooth class. } \references{ Wood S.N. (2006) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ ## see smooth.construct } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.t2.smooth.spec.Rd0000644000177400001440000000433212632334033020564 0ustar murdochusers\name{smooth.construct.t2.smooth.spec} \alias{smooth.construct.t2.smooth.spec} %- Also NEED an `\alias' for EACH other topic documented here. \title{Tensor product smoothing constructor} \description{A special \code{smooth.construct} method function for creating tensor product smooths from any combination of single penalty marginal smooths, using the construction of Wood, Scheipl and Faraway (2013). } \usage{ \method{smooth.construct}{t2.smooth.spec}(object, data, knots) } \arguments{ \item{object}{a smooth specification object of class \code{t2.smooth.spec}, usually generated by a term like \code{t2(x,z)} in a \code{\link{gam}} model formula} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}. See details for further information.} } \value{ An object of class \code{"t2.smooth"}. } \details{Tensor product smooths are smooths of several variables which allow the degree of smoothing to be different with respect to different variables. They are useful as smooth interaction terms, as they are invariant to linear rescaling of the covariates, which means, for example, that they are insensitive to the measurement units of the different covariates. They are also useful whenever isotropic smoothing is inappropriate. See \code{\link{t2}}, \code{\link{te}}, \code{\link{smooth.construct}} and \code{\link{smooth.terms}}. The construction employed here produces tensor smooths for which the smoothing penalties are non-overlapping portions of the identity matrix. This makes their estimation by mixed modelling software rather easy. } \references{ Wood, S.N., F. Scheipl and J.J. Faraway (2013) Straightforward intermediate rank tensor product smoothing in mixed models. Statistics and Computing 23: 341-360. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{t2}}} \examples{ ## see ?t2 } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.fs.smooth.spec.Rd0000644000177400001440000001115112632334033020644 0ustar murdochusers\name{smooth.construct.fs.smooth.spec} \alias{smooth.construct.fs.smooth.spec} \alias{Predict.matrix.fs.interaction} \alias{factor.smooth.interaction} %- Also NEED an `\alias' for EACH other topic documented here. \title{Factor smooth interactions in GAMs} \description{Simple factor smooth interactions, which are efficient when used with \code{\link{gamm}}. This smooth class allows a separate smooth for each level of a factor, with the same smoothing parameter for all smooths. It is an alternative to using factor \code{by} variables. See the discussion of \code{by} variables in \code{\link{gam.models}} for more general alternatives for factor smooth interactions (including interactions of tensor product smooths with factors). } \usage{ \method{smooth.construct}{fs.smooth.spec}(object, data, knots) \method{Predict.matrix}{fs.interaction}(object, data) } \arguments{ \item{object}{For the \code{smooth.construct} method a smooth specification object, usually generated by a term \code{s(x,...,bs="fs",)}. For the \code{predict.Matrix} method an object of class \code{"fs.interaction"} produced by the \code{smooth.construct} method.} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term}.} \item{knots}{ a list containing any knots supplied for smooth basis setup.} } \value{ An object of class \code{"fs.interaction"} or a matrix mapping the coefficients of the factor smooth interaction to the smooths themselves. } \details{This class produces a smooth for each level of a single factor variable. Within a \code{\link{gam}} formula this is done with something like \code{s(x,fac,bs="fs")}, which is almost equivalent to \code{s(x,by=fac,id=1)} (with the \code{gam} argument \code{select=TRUE}). The terms are fully penalized, with separate penalties on each null space component: for this reason they are not centred (no sum-to-zero constraint). The class is particularly useful for use with \code{\link{gamm}}, where estimation efficiently exploits the nesting of the smooth within the factor. Note however that: i) \code{gamm} only allows one conditioning factor for smooths, so \code{s(x)+s(z,fac,bs="fs")+s(v,fac,bs="fs")} is OK, but \code{s(x)+s(z,fac1,bs="fs")+s(v,fac2,bs="fs")} is not; ii) all aditional random effects and correlation structures will be treated as nested within the factor of the smooth factor interaction. Note that \code{gamm4} from the {\code{gamm4}} package suffers from none of the restrictions that apply to \code{gamm}, and \code{"fs"} terms can be used without side-effects. Any singly penalized basis can be used to smooth at each factor level. The default is \code{"tp"}, but alternatives can be supplied in the \code{xt} argument of \code{s} (e.g. \code{s(x,fac,bs="fs",xt="cr")} or \code{s(x,fac,bs="fs",xt=list(bs="cr")}). The \code{k} argument to \code{s(...,bs="fs")} refers to the basis dimension to use for each level of the factor variable. Note one computational bottleneck: currently \code{\link{gamm}} (or \code{gamm4}) will produce the full posterior covariance matrix for the smooths, including the smooths at each level of the factor. This matrix can get large and computationally costly if there are more than a few hundred levels of the factor. Even at one or two hundred levels, care should be taken to keep down \code{k}. The plot method for this class has two schemes. \code{scheme==0} is in colour, while \code{scheme==1} is black and white. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{gam.models}}, \code{\link{gamm}}} \examples{ library(mgcv) set.seed(0) ## simulate data... f0 <- function(x) 2 * sin(pi * x) f1 <- function(x,a=2,b=-1) exp(a * x)+b f2 <- function(x) 0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10 n <- 500;nf <- 25 fac <- sample(1:nf,n,replace=TRUE) x0 <- runif(n);x1 <- runif(n);x2 <- runif(n) a <- rnorm(nf)*.2 + 2;b <- rnorm(nf)*.5 f <- f0(x0) + f1(x1,a[fac],b[fac]) + f2(x2) fac <- factor(fac) y <- f + rnorm(n)*2 ## so response depends on global smooths of x0 and ## x2, and a smooth of x1 for each level of fac. ## fit model (note p-values not available when fit ## using gamm)... bm <- gamm(y~s(x0)+ s(x1,fac,bs="fs",k=5)+s(x2,k=20)) plot(bm$gam,pages=1) summary(bm$gam) ## Could also use... ## b <- gam(y~s(x0)+ s(x1,fac,bs="fs",k=5)+s(x2,k=20),method="ML") ## ... but its slower (increasingly so with increasing nf) ## b <- gam(y~s(x0)+ t2(x1,fac,bs=c("tp","re"),k=5,full=TRUE)+ ## s(x2,k=20),method="ML")) ## ... is exactly equivalent. } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/gam.Rd0000744000177400001440000006670412770447274013242 0ustar murdochusers\name{gam} \alias{gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generalized additive models with integrated smoothness estimation} \description{ Fits a generalized additive model (GAM) to data, the term `GAM' being taken to include any quadratically penalized GLM and a variety of other models estimated by a quadratically penalised likelihood type approach (see \code{\link{family.mgcv}}). The degree of smoothness of model terms is estimated as part of fitting. \code{gam} can also fit any GLM subject to multiple quadratic penalties (including estimation of degree of penalization). Confidence/credible intervals are readily available for any quantity predicted using a fitted model. Smooth terms are represented using penalized regression splines (or similar smoothers) with smoothing parameters selected by GCV/UBRE/AIC/REML or by regression splines with fixed degrees of freedom (mixtures of the two are permitted). Multi-dimensional smooths are available using penalized thin plate regression splines (isotropic) or tensor product splines (when an isotropic smooth is inappropriate), and users can add smooths. Linear functionals of smooths can also be included in models. For an overview of the smooths available see \code{\link{smooth.terms}}. For more on specifying models see \code{\link{gam.models}}, \code{\link{random.effects}} and \code{\link{linear.functional.terms}}. For more on model selection see \code{\link{gam.selection}}. Do read \code{\link{gam.check}} and \code{\link{choose.k}}. See \link[gam]{gam} from package \code{gam}, for GAMs via the original Hastie and Tibshirani approach (see details for differences to this implementation). For very large datasets see \code{\link{bam}}, for mixed GAM see \code{\link{gamm}} and \code{\link{random.effects}}. } \usage{ gam(formula,family=gaussian(),data=list(),weights=NULL,subset=NULL, na.action,offset=NULL,method="GCV.Cp", optimizer=c("outer","newton"),control=list(),scale=0, select=FALSE,knots=NULL,sp=NULL,min.sp=NULL,H=NULL,gamma=1, fit=TRUE,paraPen=NULL,G=NULL,in.out,drop.unused.levels=TRUE, drop.intercept=NULL,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{formula}{ A GAM formula, or a list of formulae (see \code{\link{formula.gam}} and also \code{\link{gam.models}}). These are exactly like the formula for a GLM except that smooth terms, \code{\link{s}}, \code{\link{te}}, \code{\link{ti}} and \code{\link{t2}}, can be added to the right hand side to specify that the linear predictor depends on smooth functions of predictors (or linear functionals of these). } \item{family}{ This is a family object specifying the distribution and link to use in fitting etc (see \code{\link{glm}} and \code{\link{family}}). See \code{\link{family.mgcv}} for a full list of what is available, which goes well beyond exponential family. Note that \code{quasi} families actually result in the use of extended quasi-likelihood if \code{method} is set to a RE/ML method (McCullagh and Nelder, 1989, 9.6). } \item{data}{ A data frame or list containing the model response variable and covariates required by the formula. By default the variables are taken from \code{environment(formula)}: typically the environment from which \code{gam} is called.} \item{weights}{ prior weights on the contribution of the data to the log likelihood. Note that a weight of 2, for example, is equivalent to having made exactly the same observation twice. If you want to reweight the contributions of each datum without changing the overall magnitude of the log likelihood, then you should normalize the weights (e.g. \code{weights <- weights/mean(weights)}). } \item{subset}{ an optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{ a function which indicates what should happen when the data contain `NA's. The default is set by the `na.action' setting of `options', and is `na.fail' if that is unset. The ``factory-fresh'' default is `na.omit'.} \item{offset}{Can be used to supply a model offset for use in fitting. Note that this offset will always be completely ignored when predicting, unlike an offset included in \code{formula} (this used to conform to the behaviour of \code{lm} and \code{glm}).} \item{control}{A list of fit control parameters to replace defaults returned by \code{\link{gam.control}}. Values not set assume default values. } \item{method}{The smoothing parameter estimation method. \code{"GCV.Cp"} to use GCV for unknown scale parameter and Mallows' Cp/UBRE/AIC for known scale. \code{"GACV.Cp"} is equivalent, but using GACV in place of GCV. \code{"REML"} for REML estimation, including of unknown scale, \code{"P-REML"} for REML estimation, but using a Pearson estimate of the scale. \code{"ML"} and \code{"P-ML"} are similar, but using maximum likelihood in place of REML. Beyond the exponential family \code{"REML"} is the default, and the only other option is \code{"ML"}.} \item{optimizer}{An array specifying the numerical optimization method to use to optimize the smoothing parameter estimation criterion (given by \code{method}). \code{"perf"} for performance iteration. \code{"outer"} for the more stable direct approach. \code{"outer"} can use several alternative optimizers, specified in the second element of \code{optimizer}: \code{"newton"} (default), \code{"bfgs"}, \code{"optim"}, \code{"nlm"} and \code{"nlm.fd"} (the latter is based entirely on finite differenced derivatives and is very slow). \code{"efs"} for the extended Fellner Schall method - only currently available for general families.} \item{scale}{ If this is positive then it is taken as the known scale parameter. Negative signals that the scale parameter is unknown. 0 signals that the scale parameter is 1 for Poisson and binomial and unknown otherwise. Note that (RE)ML methods can only work with scale parameter 1 for the Poisson and binomial cases. } \item{select}{ If this is \code{TRUE} then \code{gam} can add an extra penalty to each term so that it can be penalized to zero. This means that the smoothing parameter estimation that is part of fitting can completely remove terms from the model. If the corresponding smoothing parameter is estimated as zero then the extra penalty has no effect. } \item{knots}{this is an optional list containing user specified knot values to be used for basis construction. For most bases the user simply supplies the knots to be used, which must match up with the \code{k} value supplied (note that the number of knots is not always just \code{k}). See \code{\link{tprs}} for what happens in the \code{"tp"/"ts"} case. Different terms can use different numbers of knots, unless they share a covariate. } \item{sp}{A vector of smoothing parameters can be provided here. Smoothing parameters must be supplied in the order that the smooth terms appear in the model formula. Negative elements indicate that the parameter should be estimated, and hence a mixture of fixed and estimated parameters is possible. If smooths share smoothing parameters then \code{length(sp)} must correspond to the number of underlying smoothing parameters.} \item{min.sp}{Lower bounds can be supplied for the smoothing parameters. Note that if this option is used then the smoothing parameters \code{full.sp}, in the returned object, will need to be added to what is supplied here to get the smoothing parameters actually multiplying the penalties. \code{length(min.sp)} should always be the same as the total number of penalties (so it may be longer than \code{sp}, if smooths share smoothing parameters).} \item{H}{A user supplied fixed quadratic penalty on the parameters of the GAM can be supplied, with this as its coefficient matrix. A common use of this term is to add a ridge penalty to the parameters of the GAM in circumstances in which the model is close to un-identifiable on the scale of the linear predictor, but perfectly well defined on the response scale.} \item{gamma}{It is sometimes useful to inflate the model degrees of freedom in the GCV or UBRE/AIC score by a constant multiplier. This allows such a multiplier to be supplied. } \item{fit}{If this argument is \code{TRUE} then \code{gam} sets up the model and fits it, but if it is \code{FALSE} then the model is set up and an object \code{G} containing what would be required to fit is returned is returned. See argument \code{G}.} \item{paraPen}{optional list specifying any penalties to be applied to parametric model terms. \code{\link{gam.models}} explains more.} \item{G}{Usually \code{NULL}, but may contain the object returned by a previous call to \code{gam} with \code{fit=FALSE}, in which case all other arguments are ignored except for \code{gamma}, \code{in.out}, \code{scale}, \code{control}, \code{method} \code{optimizer} and \code{fit}.} \item{in.out}{optional list for initializing outer iteration. If supplied then this must contain two elements: \code{sp} should be an array of initialization values for all smoothing parameters (there must be a value for all smoothing parameters, whether fixed or to be estimated, but those for fixed s.p.s are not used); \code{scale} is the typical scale of the GCV/UBRE function, for passing to the outer optimizer, or the the initial value of the scale parameter, if this is to be estimated by RE/ML.} \item{drop.unused.levels}{by default unused levels are dropped from factors before fitting. For some smooths involving factor variables you might want to turn this off. Only do so if you know what you are doing.} \item{drop.intercept}{Set to \code{TRUE} to force the model to really not have the a constant in the parametric model part, even with factor variables present. Can be vector when \code{formula} is a list.} \item{...}{further arguments for passing on e.g. to \code{gam.fit} (such as \code{mustart}). } } \value{ If \code{fit=FALSE} the function returns a list \code{G} of items needed to fit a GAM, but doesn't actually fit it. Otherwise the function returns an object of class \code{"gam"} as described in \code{\link{gamObject}}. } \details{ A generalized additive model (GAM) is a generalized linear model (GLM) in which the linear predictor is given by a user specified sum of smooth functions of the covariates plus a conventional parametric component of the linear predictor. A simple example is: \deqn{\log(E(y_i)) = \alpha + f_1(x_{1i})+f_2(x_{2i})}{log(E(y_i))= a + f_1(x_1i)+f_2(x_2i)} where the (independent) response variables \eqn{y_i \sim {\rm Poi }}{y_i~Poi}, and \eqn{f_1}{f_1} and \eqn{f_2}{f_2} are smooth functions of covariates \eqn{x_1}{x_1} and \eqn{x_2}{x_2}. The log is an example of a link function. Note that to be identifiable the model requires constraints on the smooth functions. By default these are imposed automatically and require that the function sums to zero over the observed covariate values (the presence of a metric \code{by} variable is the only case which usually suppresses this). If absolutely any smooth functions were allowed in model fitting then maximum likelihood estimation of such models would invariably result in complex overfitting estimates of \eqn{f_1}{f_1} and \eqn{f_2}{f_2}. For this reason the models are usually fit by penalized likelihood maximization, in which the model (negative log) likelihood is modified by the addition of a penalty for each smooth function, penalizing its `wiggliness'. To control the tradeoff between penalizing wiggliness and penalizing badness of fit each penalty is multiplied by an associated smoothing parameter: how to estimate these parameters, and how to practically represent the smooth functions are the main statistical questions introduced by moving from GLMs to GAMs. The \code{mgcv} implementation of \code{gam} represents the smooth functions using penalized regression splines, and by default uses basis functions for these splines that are designed to be optimal, given the number basis functions used. The smooth terms can be functions of any number of covariates and the user has some control over how smoothness of the functions is measured. \code{gam} in \code{mgcv} solves the smoothing parameter estimation problem by using the Generalized Cross Validation (GCV) criterion \deqn{n D / (n - DoF)^2}{n D/(n - DoF)^2} or an Un-Biased Risk Estimator (UBRE )criterion \deqn{D/n + 2 s DoF / n - s }{D/n + 2 s DoF / n -s} where \eqn{D}{D} is the deviance, \eqn{n}{n} the number of data, \eqn{s}{s} the scale parameter and \eqn{DoF}{DoF} the effective degrees of freedom of the model. Notice that UBRE is effectively just AIC rescaled, but is only used when \eqn{s}{s} is known. Alternatives are GACV, or a Laplace approximation to REML. There is some evidence that the latter may actually be the most effective choice. The main computational challenge solved by the \code{mgcv} package is to optimize the smoothness selection criteria efficiently and reliably. Various alternative numerical methods are provided which can be set by argument \code{optimizer}. Broadly \code{gam} works by first constructing basis functions and one or more quadratic penalty coefficient matrices for each smooth term in the model formula, obtaining a model matrix for the strictly parametric part of the model formula, and combining these to obtain a complete model matrix (/design matrix) and a set of penalty matrices for the smooth terms. The linear identifiability constraints are also obtained at this point. The model is fit using \code{\link{gam.fit}}, \code{\link{gam.fit3}} or varaints, which are modifications of \code{\link{glm.fit}}. The GAM penalized likelihood maximization problem is solved by Penalized Iteratively Reweighted Least Squares (P-IRLS) (see e.g. Wood 2000). Smoothing parameter selection is integrated in one of two ways. (i) `Performance iteration' uses the fact that at each P-IRLS iteration a penalized weighted least squares problem is solved, and the smoothing parameters of that problem can estimated by GCV or UBRE. Eventually, in most cases, both model parameter estimates and smoothing parameter estimates converge. (ii) Alternatively the P-IRLS scheme is iterated to convergence for each trial set of smoothing parameters, and GCV, UBRE or REML scores are only evaluated on convergence - optimization is then `outer' to the P-IRLS loop: in this case the P-IRLS iteration has to be differentiated, to facilitate optimization, and \code{\link{gam.fit3}} or one of its variants is used in place of \code{gam.fit}. The default is the second method, outer iteration. Several alternative basis-penalty types are built in for representing model smooths, but alternatives can easily be added (see \code{\link{smooth.terms}} for an overview and \code{\link{smooth.construct}} for how to add smooth classes). The choice of the basis dimension (\code{k} in the \code{s}, \code{te}, \code{ti} and \code{t2} terms) is something that should be considered carefully (the exact value is not critical, but it is important not to make it restrictively small, nor very large and computationally costly). The basis should be chosen to be larger than is believed to be necessary to approximate the smooth function concerned. The effective degrees of freedom for the smooth will then be controlled by the smoothing penalty on the term, and (usually) selected automatically (with an upper limit set by \code{k-1} or occasionally \code{k}). Of course the \code{k} should not be made too large, or computation will be slow (or in extreme cases there will be more coefficients to estimate than there are data). Note that \code{gam} assumes a very inclusive definition of what counts as a GAM: basically any penalized GLM can be used: to this end \code{gam} allows the non smooth model components to be penalized via argument \code{paraPen} and allows the linear predictor to depend on general linear functionals of smooths, via the summation convention mechanism described in \code{\link{linear.functional.terms}}. \code{link{family.mgcv}} details what is available beyond GLMs and the exponential family. Details of the default underlying fitting methods are given in Wood (2011 and 2004). Some alternative methods are discussed in Wood (2000 and 2006). \code{gam()} is not a clone of Trevor Hastie's original (as supplied in S-PLUS or package \link[gam]{gam}). The major differences are (i) that by default estimation of the degree of smoothness of model terms is part of model fitting, (ii) a Bayesian approach to variance estimation is employed that makes for easier confidence interval calculation (with good coverage probabilities), (iii) that the model can depend on any (bounded) linear functional of smooth terms, (iv) the parametric part of the model can be penalized, (v) simple random effects can be incorporated, and (vi) the facilities for incorporating smooths of more than one variable are different: specifically there are no \code{lo} smooths, but instead (a) \code{\link{s}} terms can have more than one argument, implying an isotropic smooth and (b) \code{\link{te}}, \code{\link{ti}} or \code{\link{t2}} smooths are provided as an effective means for modelling smooth interactions of any number of variables via scale invariant tensor product smooths. Splines on the sphere, Duchon splines and Gaussian Markov Random Fields are also available. (vii) Models beyond the exponential family are available. See \link[gam]{gam} from package \code{gam}, for GAMs via the original Hastie and Tibshirani approach. } \references{ Key References on this implementation: Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 Wood, S.N. (2004) Stable and efficient multiple smoothing parameter estimation for generalized additive models. J. Amer. Statist. Ass. 99:673-686. [Default method for additive case by GCV (but no longer for generalized)] Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 Wood, S.N. (2006a) Low rank scale invariant tensor product smooths for generalized additive mixed models. Biometrics 62(4):1025-1036 Wood S.N. (2006b) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. Wood S.N., F. Scheipl and J.J. Faraway (2012) Straightforward intermediate rank tensor product smoothing in mixed models. Statistical Computing. Marra, G and S.N. Wood (2012) Coverage Properties of Confidence Intervals for Generalized Additive Model Components. Scandinavian Journal of Statistics, 39(1), 53-74. Key Reference on GAMs and related models: Hastie (1993) in Chambers and Hastie (1993) Statistical Models in S. Chapman and Hall. Hastie and Tibshirani (1990) Generalized Additive Models. Chapman and Hall. Wahba (1990) Spline Models of Observational Data. SIAM Wood, S.N. (2000) Modelling and Smoothing Parameter Estimation with Multiple Quadratic Penalties. J.R.Statist.Soc.B 62(2):413-428 [The original mgcv paper, but no longer the default methods.] Background References: Green and Silverman (1994) Nonparametric Regression and Generalized Linear Models. Chapman and Hall. Gu and Wahba (1991) Minimizing GCV/GML scores with multiple smoothing parameters via the Newton method. SIAM J. Sci. Statist. Comput. 12:383-398 Gu (2002) Smoothing Spline ANOVA Models, Springer. McCullagh and Nelder (1989) Generalized Linear Models 2nd ed. Chapman & Hall. O'Sullivan, Yandall and Raynor (1986) Automatic smoothing of regression functions in generalized linear models. J. Am. Statist.Ass. 81:96-103 Wood (2001) mgcv:GAMs and Generalized Ridge Regression for R. R News 1(2):20-25 Wood and Augustin (2002) GAMs with integrated model selection using penalized regression splines and applications to environmental modelling. Ecological Modelling 157:157-177 \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} Front end design inspired by the S function of the same name based on the work of Hastie and Tibshirani (1990). Underlying methods owe much to the work of Wahba (e.g. 1990) and Gu (e.g. 2002). } \section{WARNINGS }{ The default basis dimensions used for smooth terms are essentially arbitrary, and it should be checked that they are not too small. See \code{\link{choose.k}} and \code{\link{gam.check}}. You must have more unique combinations of covariates than the model has total parameters. (Total parameters is sum of basis dimensions plus sum of non-spline terms less the number of spline terms). Automatic smoothing parameter selection is not likely to work well when fitting models to very few response data. For data with many zeroes clustered together in the covariate space it is quite easy to set up GAMs which suffer from identifiability problems, particularly when using Poisson or binomial families. The problem is that with e.g. log or logit links, mean value zero corresponds to an infinite range on the linear predictor scale. } \seealso{\code{\link{mgcv-package}}, \code{\link{gamObject}}, \code{\link{gam.models}}, \code{\link{smooth.terms}}, \code{\link{linear.functional.terms}}, \code{\link{s}}, \code{\link{te}} \code{\link{predict.gam}}, \code{\link{plot.gam}}, \code{\link{summary.gam}}, \code{\link{gam.side}}, \code{\link{gam.selection}}, \code{\link{gam.control}} \code{\link{gam.check}}, \code{\link{linear.functional.terms}} \code{\link{negbin}}, \code{\link{magic}},\code{\link{vis.gam}} } \examples{ ## see also examples in ?gam.models (e.g. 'by' variables, ## random effects and tricks for large binary datasets) library(mgcv) set.seed(2) ## simulate some data... dat <- gamSim(1,n=400,dist="normal",scale=2) b <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat) summary(b) plot(b,pages=1,residuals=TRUE) ## show partial residuals plot(b,pages=1,seWithMean=TRUE) ## `with intercept' CIs ## run some basic model checks, including checking ## smoothing basis dimensions... gam.check(b) ## same fit in two parts ..... G <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),fit=FALSE,data=dat) b <- gam(G=G) print(b) ## 2 part fit enabling manipulation of smoothing parameters... G <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),fit=FALSE,data=dat,sp=b$sp) G$lsp0 <- log(b$sp*10) ## provide log of required sp vec gam(G=G) ## it's smoother ## change the smoothness selection method to REML b0 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat,method="REML") ## use alternative plotting scheme, and way intervals include ## smoothing parameter uncertainty... plot(b0,pages=1,scheme=1,unconditional=TRUE) ## Would a smooth interaction of x0 and x1 be better? ## Use tensor product smooth of x0 and x1, basis ## dimension 49 (see ?te for details, also ?t2). bt <- gam(y~te(x0,x1,k=7)+s(x2)+s(x3),data=dat, method="REML") plot(bt,pages=1) plot(bt,pages=1,scheme=2) ## alternative visualization AIC(b0,bt) ## interaction worse than additive ## Alternative: test for interaction with a smooth ANOVA ## decomposition (this time between x2 and x1) bt <- gam(y~s(x0)+s(x1)+s(x2)+s(x3)+ti(x1,x2,k=6), data=dat,method="REML") summary(bt) ## If it is believed that x0 and x1 are naturally on ## the same scale, and should be treated isotropically ## then could try... bs <- gam(y~s(x0,x1,k=40)+s(x2)+s(x3),data=dat, method="REML") plot(bs,pages=1) AIC(b0,bt,bs) ## additive still better. ## Now do automatic terms selection as well b1 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat, method="REML",select=TRUE) plot(b1,pages=1) ## set the smoothing parameter for the first term, estimate rest ... bp <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),sp=c(0.01,-1,-1,-1),data=dat) plot(bp,pages=1,scheme=1) ## alternatively... bp <- gam(y~s(x0,sp=.01)+s(x1)+s(x2)+s(x3),data=dat) # set lower bounds on smoothing parameters .... bp<-gam(y~s(x0)+s(x1)+s(x2)+s(x3), min.sp=c(0.001,0.01,0,10),data=dat) print(b);print(bp) # same with REML bp<-gam(y~s(x0)+s(x1)+s(x2)+s(x3), min.sp=c(0.1,0.1,0,10),data=dat,method="REML") print(b0);print(bp) ## now a GAM with 3df regression spline term & 2 penalized terms b0 <- gam(y~s(x0,k=4,fx=TRUE,bs="tp")+s(x1,k=12)+s(x2,k=15),data=dat) plot(b0,pages=1) ## now simulate poisson data... dat <- gamSim(1,n=2000,dist="poisson",scale=.1) ## use "cr" basis to save time, with 2000 data... b2<-gam(y~s(x0,bs="cr")+s(x1,bs="cr")+s(x2,bs="cr")+ s(x3,bs="cr"),family=poisson,data=dat,method="REML") plot(b2,pages=1) ## drop x3, but initialize sp's from previous fit, to ## save more time... b2a<-gam(y~s(x0,bs="cr")+s(x1,bs="cr")+s(x2,bs="cr"), family=poisson,data=dat,method="REML", in.out=list(sp=b2$sp[1:3],scale=1)) par(mfrow=c(2,2)) plot(b2a) par(mfrow=c(1,1)) ## similar example using performance iteration dat <- gamSim(1,n=400,dist="poisson",scale=.25) b3<-gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=poisson, data=dat,optimizer="perf") plot(b3,pages=1) ## repeat using GACV as in Wood 2008... b4<-gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=poisson, data=dat,method="GACV.Cp",scale=-1) plot(b4,pages=1) ## repeat using REML as in Wood 2011... b5<-gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=poisson, data=dat,method="REML") plot(b5,pages=1) ## a binary example (see ?gam.models for large dataset version)... dat <- gamSim(1,n=400,dist="binary",scale=.33) lr.fit <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=binomial, data=dat,method="REML") ## plot model components with truth overlaid in red op <- par(mfrow=c(2,2)) fn <- c("f0","f1","f2","f3");xn <- c("x0","x1","x2","x3") for (k in 1:4) { plot(lr.fit,residuals=TRUE,select=k) ff <- dat[[fn[k]]];xx <- dat[[xn[k]]] ind <- sort.int(xx,index.return=TRUE)$ix lines(xx[ind],(ff-mean(ff))[ind]*.33,col=2) } par(op) anova(lr.fit) lr.fit1 <- gam(y~s(x0)+s(x1)+s(x2),family=binomial, data=dat,method="REML") lr.fit2 <- gam(y~s(x1)+s(x2),family=binomial, data=dat,method="REML") AIC(lr.fit,lr.fit1,lr.fit2) ## For a Gamma example, see ?summary.gam... ## For inverse Gaussian, see ?rig ## now 2D smoothing... eg <- gamSim(2,n=500,scale=.1) attach(eg) op <- par(mfrow=c(2,2),mar=c(4,4,1,1)) contour(truth$x,truth$z,truth$f) ## contour truth b4 <- gam(y~s(x,z),data=data) ## fit model fit1 <- matrix(predict.gam(b4,pr,se=FALSE),40,40) contour(truth$x,truth$z,fit1) ## contour fit persp(truth$x,truth$z,truth$f) ## persp truth vis.gam(b4) ## persp fit detach(eg) par(op) \dontrun{ ################################################## ## largish dataset example with user defined knots ################################################## par(mfrow=c(2,2)) n <- 5000 eg <- gamSim(2,n=n,scale=.5) attach(eg) ind<-sample(1:n,200,replace=FALSE) b5<-gam(y~s(x,z,k=40),data=data, knots=list(x=data$x[ind],z=data$z[ind])) ## various visualizations vis.gam(b5,theta=30,phi=30) plot(b5) plot(b5,scheme=1,theta=50,phi=20) plot(b5,scheme=2) par(mfrow=c(1,1)) ## and a pure "knot based" spline of the same data b6<-gam(y~s(x,z,k=64),data=data,knots=list(x= rep((1:8-0.5)/8,8), z=rep((1:8-0.5)/8,rep(8,8)))) vis.gam(b6,color="heat",theta=30,phi=30) ## varying the default large dataset behaviour via `xt' b7 <- gam(y~s(x,z,k=40,xt=list(max.knots=500,seed=2)),data=data) vis.gam(b7,theta=30,phi=30) detach(eg) } } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. \concept{Varying coefficient model} \concept{Functional linear model} \concept{Penalized GLM} \concept{Generalized Additive Model} \concept{Penalized regression} \concept{Spline smoothing} \concept{Penalized regression spline} \concept{Generalized Cross Validation} \concept{Smoothing parameter selection} \concept{tensor product smoothing} \concept{thin plate spline} \concept{P-spline} \concept{Generalized ridge regression} mgcv/man/polys.plot.Rd0000644000177400001440000000352312632334033014567 0ustar murdochusers\name{polys.plot} \alias{polys.plot} \title{Plot geographic regions defined as polygons} \usage{ polys.plot(pc,z=NULL,scheme="heat",lab="",...) } \arguments{ \item{pc}{A named list of matrices. Each matrix has two columns. The matrix rows each define the vertex of a boundary polygon. If a boundary is defined by several polygons, then each of these must be separated by an \code{NA} row in the matrix. See \code{\link{mrf}} for an example.} \item{z}{A vector of values associated with each area (item) of \code{pc}. If the vector elements have names then these are used to match elements of \code{z} to areas defined in \code{pc}. Otherwise \code{pc} and \code{z} are assumed to be in the same order. If \code{z} is \code{NULL} then polygons are not filled. } \item{scheme}{One of \code{"heat"} or \code{"grey"}, indicating how to fill the polygons in accordance with the value of \code{z}.} \item{lab}{label for plot.} \item{...}{other arguments to pass to plot (currently only if \code{z} is \code{NULL}).} } \value{Simply produces a plot.} \description{ Produces plots of geographic regions defined by polygons, optionally filling the polygons with a color or grey shade dependent on a covariate. } \details{Any polygon within another polygon counts as a hole in the area. Further nesting is dealt with by treating any point that is interior to an odd number of polygons as being within the area, and all other points as being exterior. The routine is provided to facilitate plotting with models containing \code{\link{mrf}} smooths. } \author{Simon Wood \email{simon.wood@r-project.org} } \seealso{ \code{\link{mrf}} and \code{\link{columb.polys}}. } \examples{ ## see also ?mrf for use of z require(mgcv) data(columb.polys) polys.plot(columb.polys) } \keyword{hplot} \keyword{models} \keyword{smooth} \keyword{regression} mgcv/man/smooth.construct.bs.smooth.spec.Rd0000644000177400001440000002041313036721155020645 0ustar murdochusers\name{smooth.construct.bs.smooth.spec} \alias{smooth.construct.bs.smooth.spec} \alias{Predict.matrix.Bspline.smooth} \alias{b.spline} %- Also NEED an `\alias' for EACH other topic documented here. \title{Penalized B-splines in GAMs} \description{\code{\link{gam}} can use smoothing splines based on univariate B-spline bases with derivative based penalties, specified via terms like \code{s(x,bs="bs",m=c(3,2))}. \code{m[1]} controls the spline order, with \code{m[1]=3} being a cubic spline, \code{m[1]=2} being quadratic, and so on. The integrated square of the \code{m[2]}th derivative is used as the penalty. So \code{m=c(3,2)} is a convetional cubic spline. If \code{m} is supplied as a single number, then it is taken to be \code{m[1]} and \code{m[2]=m[1]-1}, which is only a conventional smoothing spline in the \code{m=3}, cubic spline case. Notice that the definition of the spline order in terms of \code{m[1]} is intuitive, but differs to that used with the \code{\link{tprs}} and \code{\link{p.spline}} bases. See details for options for controlling the interval over which the penalty is evaluated (which can matter if it is necessary to extrapolate). } \usage{ \method{smooth.construct}{bs.smooth.spec}(object, data, knots) \method{Predict.matrix}{Bspline.smooth}(object, data) } \arguments{ \item{object}{a smooth specification object, usually generated by a term \code{s(x,bs="bs",...)}} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}. See details for further information.} } \value{ An object of class \code{"Bspline.smooth"}. See \code{\link{smooth.construct}}, for the elements that this object will contain. } \details{ The basis and penalty are sparse (although sparse matrices are not used to represent them). \code{m[2]>m[1]} will generate an error, since in that case the penalty would be based on an undefined derivative of the basis, which makes no sense. The default basis dimension, \code{k}, is the larger of 10 and \code{m}. \code{m[1]} is the lower limit on basis dimension. If knots are supplied, then the number of supplied knots should be \code{k + m[1] + 1}, and the range of the middle \code{k-m[1]+1} knots should include all the covariate values. Alternatively, 2 knots can be supplied, denoting the lower and upper limits between which the spline can be evaluated (making this range too wide mean that there is no information about some basis coefficients, because the corresponding basis functions have a span that includes no data). Unlike P-splines, splines with derivative based penalties can have uneven knot spacing, without a problem. Another option is to supply 4 knots. Then the outer 2 define the interval over which the penalty is to be evaluated, while the inner 2 define an interval within which all but the outermost 2 knots should lie. Normally the outer 2 knots would be the interval over which predictions might be required, while the inner 2 knots define the interval within which the data lie. This option allows the penalty to apply over a wider interval than the data, while still placing most of the basis functions where the data are. This is useful in situations in which it is necessary to extrapolate slightly with a smooth. Only applying the penalty over the interval containing the data amounts to a model in which the function could be less smooth outside the interval than within it, and leads to very wide extrapolation confidence intervals. However the alternative of evaluating the penalty over the whole real line amounts to asserting certainty that the function has some derivative zeroed away from the data, which is equally unreasonable. It is prefereable to build a model in which the same smoothness assumtions apply over both data and extrapolation intervals, but not over the whole real line. See example code for practical illustration. Linear extrapolation is used for prediction that requires extrapolation (i.e. prediction outside the range of the interior \code{k-m[1]+1} knots --- the interval over which the penalty is evaluated). Such extrapolation is not allowed in basis construction, but is when predicting. It is possible to set a \code{deriv} flag in a smooth specification or smooth object, so that a model or prediction matrix produces the requested derivative of the spline, rather than evaluating it. } \section{WARNING}{\code{m} directly controls the spline order here, which is intuitively sensible, but different to other bases.} \author{ Simon N. Wood \email{simon.wood@r-project.org}. Extrapolation ideas joint with David Miller.} \seealso{\code{\link{p.spline}}} \references{ Wood, S.N. (2016) P-splines with derivative based penalties and tensor product smoothing of unevenly distributed data. Statistics and Computing. \url{http://arxiv.org/abs/1605.02446} } \examples{ require(mgcv) set.seed(5) dat <- gamSim(1,n=400,dist="normal",scale=2) bs <- "bs" b <- gam(y~s(x0,bs=bs,m=c(4,2))+s(x1,bs=bs)+s(x2,k=15,bs=bs,m=c(4,3))+ s(x3,bs=bs,m=c(1,0)),data=dat,method="REML") plot(b,pages=1) ## Extrapolation example, illustrating the importance of considering ## the penalty carefully if extrapolating... f3 <- function(x) 0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10 ## test function n <- 100;x <- runif(n) y <- f3(x) + rnorm(n)*2 ## first a model with first order penalty over whole real line (red) b0 <- gam(y~s(x,m=1,k=20),method="ML") ## now a model with first order penalty evaluated over (-.5,1.5) (black) op <- options(warn=-1) b <- gam(y~s(x,bs="bs",m=c(3,1),k=20),knots=list(x=c(-.5,0,1,1.5)), method="ML") options(op) ## and the equivalent with same penalty over data range only (blue) b1 <- gam(y~s(x,bs="bs",m=c(3,1),k=20),method="ML") pd <- data.frame(x=seq(-.7,1.7,length=200)) fv <- predict(b,pd,se=TRUE) ul <- fv$fit + fv$se.fit*2; ll <- fv$fit - fv$se.fit*2 plot(x,y,xlim=c(-.7,1.7),ylim=range(c(y,ll,ul)),main= "1st order penalties: red tps; blue bs over (0,1); black bs over (-.5,1.5)") ## penalty defined on (-.5,1.5) gives plausible predictions and intervals ## over this range... lines(pd$x,fv$fit);lines(pd$x,ul,lty=2);lines(pd$x,ll,lty=2) fv <- predict(b0,pd,se=TRUE) ul <- fv$fit + fv$se.fit*2; ll <- fv$fit - fv$se.fit*2 ## penalty defined on whole real line gives constant width intervals away ## from data, as slope there must be zero, to avoid infinite penalty: lines(pd$x,fv$fit,col=2) lines(pd$x,ul,lty=2,col=2);lines(pd$x,ll,lty=2,col=2) fv <- predict(b1,pd,se=TRUE) ul <- fv$fit + fv$se.fit*2; ll <- fv$fit - fv$se.fit*2 ## penalty defined only over the data interval (0,1) gives wild and wide ## extrapolation since penalty has been `turned off' outside data range: lines(pd$x,fv$fit,col=4) lines(pd$x,ul,lty=2,col=4);lines(pd$x,ll,lty=2,col=4) ## construct smooth of x. Model matrix sm$X and penalty ## matrix sm$S[[1]] will have many zero entries... x <- seq(0,1,length=100) sm <- smoothCon(s(x,bs="bs"),data.frame(x))[[1]] ## another example checking penalty numerically... m <- c(4,2); k <- 15; b <- runif(k) sm <- smoothCon(s(x,bs="bs",m=m,k=k),data.frame(x), scale.penalty=FALSE)[[1]] sm$deriv <- m[2] h0 <- 1e-3; xk <- sm$knots[(m[1]+1):(k+1)] Xp <- PredictMat(sm,data.frame(x=seq(xk[1]+h0/2,max(xk)-h0/2,h0))) sum((Xp\%*\%b)^2*h0) ## numerical approximation to penalty b\%*\%sm$S[[1]]\%*\%b ## `exact' version ## ...repeated with uneven knot spacing... m <- c(4,2); k <- 15; b <- runif(k) ## produce the required 20 unevenly spaced knots... knots <- data.frame(x=c(-.4,-.3,-.2,-.1,-.001,.05,.15, .21,.3,.32,.4,.6,.65,.75,.9,1.001,1.1,1.2,1.3,1.4)) sm <- smoothCon(s(x,bs="bs",m=m,k=k),data.frame(x), knots=knots,scale.penalty=FALSE)[[1]] sm$deriv <- m[2] h0 <- 1e-3; xk <- sm$knots[(m[1]+1):(k+1)] Xp <- PredictMat(sm,data.frame(x=seq(xk[1]+h0/2,max(xk)-h0/2,h0))) sum((Xp\%*\%b)^2*h0) ## numerical approximation to penalty b\%*\%sm$S[[1]]\%*\%b ## `exact' version } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.tp.smooth.spec.Rd0000744000177400001440000001740313022677337020701 0ustar murdochusers\name{smooth.construct.tp.smooth.spec} \alias{smooth.construct.tp.smooth.spec} \alias{smooth.construct.ts.smooth.spec} \alias{tprs} %- Also NEED an `\alias' for EACH other topic documented here. \title{Penalized thin plate regression splines in GAMs} \description{\code{\link{gam}} can use isotropic smooths of any number of variables, specified via terms like \code{s(x,z,bs="tp",m=3)} (or just \code{s(x,z)} as this is the default basis). These terms are based on thin plate regression splines. \code{m} specifies the order of the derivatives in the thin plate spline penalty. If \code{m} is a vector of length 2 and the second element is zero, then the penalty null space of the smooth is not included in the smooth: this is useful if you need to test whether a smooth could be replaced by a linear term, for example. Thin plate regression splines are constructed by starting with the basis and penalty for a full thin plate spline and then truncating this basis in an optimal manner, to obtain a low rank smoother. Details are given in Wood (2003). One key advantage of the approach is that it avoids the knot placement problems of conventional regression spline modelling, but it also has the advantage that smooths of lower rank are nested within smooths of higher rank, so that it is legitimate to use conventional hypothesis testing methods to compare models based on pure regression splines. Note that the basis truncation does not change the meaning of the thin plate spline penalty (it penalizes exactly what it would have penalized for a full thin plate spline). The t.p.r.s. basis and penalties can become expensive to calculate for large datasets. For this reason the default behaviour is to randomly subsample \code{max.knots} unique data locations if there are more than \code{max.knots} such, and to use the sub-sample for basis construction. The sampling is always done with the same random seed to ensure repeatability (does not reset R RNG). \code{max.knots} is 2000, by default. Both seed and \code{max.knots} can be modified using the \code{xt} argument to \code{s}. Alternatively the user can supply knots from which to construct a basis. The \code{"ts"} smooths are t.p.r.s. with the penalty modified so that the term is shrunk to zero for high enough smoothing parameter, rather than being shrunk towards a function in the penalty null space (see details). } \usage{ \method{smooth.construct}{tp.smooth.spec}(object, data, knots) \method{smooth.construct}{ts.smooth.spec}(object, data, knots) } \arguments{ \item{object}{a smooth specification object, usually generated by a term \code{s(...,bs="tp",...)} or \code{s(...,bs="ts",...)}} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}} } \value{ An object of class \code{"tprs.smooth"} or \code{"ts.smooth"}. In addition to the usual elements of a smooth class documented under \code{\link{smooth.construct}}, this object will contain: \item{shift}{A record of the shift applied to each covariate in order to center it around zero and avoid any co-linearity problems that might otehrwise occur in the penalty null space basis of the term. } \item{Xu}{A matrix of the unique covariate combinations for this smooth (the basis is constructed by first stripping out duplicate locations).} \item{UZ}{The matrix mapping the t.p.r.s. parameters back to the parameters of a full thin plate spline.} \item{null.space.dimension}{The dimension of the space of functions that have zero wiggliness according to the wiggliness penalty for this term.} } \details{ The default basis dimension for this class is \code{k=M+k.def} where \code{M} is the null space dimension (dimension of unpenalized function space) and \code{k.def} is 8 for dimension 1, 27 for dimension 2 and 100 for higher dimensions. This is essentially arbitrary, and should be checked, but as with all penalized regression smoothers, results are statistically insensitive to the exact choise, provided it is not so small that it forces oversmoothing (the smoother's degrees of freedom are controlled primarily by its smoothing parameter). The default is to set \code{m} (the order of derivative in the thin plate spline penalty) to the smallest value satisfying \code{2m > d+1} where \code{d} if the number of covariates of the term: this yields `visually smooth' functions. In any case \code{2m>d} must be satisfied. The constructor is not normally called directly, but is rather used internally by \code{\link{gam}}. To use for basis setup it is recommended to use \code{\link{smooth.construct2}}. For these classes the specification \code{object} will contain information on how to handle large datasets in their \code{xt} field. The default is to randomly subsample 2000 `knots' from which to produce a tprs basis, if the number of unique predictor variable combinations in excess of 2000. The default can be modified via the \code{xt} argument to \code{\link{s}}. This is supplied as a list with elements \code{max.knots} and \code{seed} containing a number to use in place of 2000, and the random number seed to use (either can be missing). For these bases \code{knots} has two uses. Firstly, as mentioned already, for large datasets the calculation of the \code{tp} basis can be time-consuming. The user can retain most of the advantages of the t.p.r.s. approach by supplying a reduced set of covariate values from which to obtain the basis - typically the number of covariate values used will be substantially smaller than the number of data, and substantially larger than the basis dimension, \code{k}. This approach is the one taken automatically if the number of unique covariate values (combinations) exceeds \code{max.knots}. The second possibility is to avoid the eigen-decomposition used to find the t.p.r.s. basis altogether and simply use the basis implied by the chosen knots: this will happen if the number of knots supplied matches the basis dimension, \code{k}. For a given basis dimension the second option is faster, but gives poorer results (and the user must be quite careful in choosing knot locations). The shrinkage version of the smooth, eigen-decomposes the wiggliness penalty matrix, and sets its zero eigenvalues to small multiples of the smallest strictly positive eigenvalue. The penalty is then set to the matrix with eigenvectors corresponding to those of the original penalty, but eigenvalues set to the peturbed versions. This penalty matrix has full rank and shrinks the curve to zero at high enough smoothing parameters. } \references{ Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv); n <- 100; set.seed(2) x <- runif(n); y <- x + x^2*.2 + rnorm(n) *.1 ## is smooth significantly different from straight line? summary(gam(y~s(x,m=c(2,0))+x,method="REML")) ## not quite ## is smooth significatly different from zero? summary(gam(y~s(x),method="REML")) ## yes! ## example of knot based tprs... k <- 10; m <- 2 y <- y[order(x)];x <- x[order(x)] b <- gam(y~s(x,k=k,m=m),method="REML", knots=list(x=seq(0,1,length=k))) X <- model.matrix(b) par(mfrow=c(1,2)) plot(x,X[,1],ylim=range(X),type="l") for (i in 2:ncol(X)) lines(x,X[,i],col=i) ## compare with eigen based (default) b1 <- gam(y~s(x,k=k,m=m),method="REML") X1 <- model.matrix(b1) plot(x,X1[,1],ylim=range(X1),type="l") for (i in 2:ncol(X1)) lines(x,X1[,i],col=i) ## see ?gam } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/rmvn.Rd0000755000177400001440000000236512632334033013434 0ustar murdochusers\name{rmvn} \alias{rmvn} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generate multivariate normal deviates} \description{ Generates multivariate normal random deviates. } \usage{ rmvn(n,mu,V) } \arguments{ \item{n}{number of simulated vectors required.} \item{mu}{the mean of the vectors: either a single vector of length \code{p=ncol(V)} or an \code{n} by \code{p} matrix.} \item{V}{A positive semi definite covariance matrix.} } \value{ An \code{n} row matrix, with each row being a draw from a multivariate normal density with covariance matrix \code{V} and mean vector \code{mu}. Alternatively each row may have a different mean vector if \code{mu} is a vector. } \details{Uses a `square root' of \code{V} to transform stadard normal deviates to multivariate normal with the correct covariance matrix. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood \email{simon.wood@r-project.org} } \seealso{\code{\link{ldTweedie}}, \code{\link{Tweedie}}} \examples{ library(mgcv) V <- matrix(c(2,1,1,2),2,2) mu <- c(1,3) n <- 1000 z <- rmvn(n,mu,V) crossprod(sweep(z,2,colMeans(z)))/n ## observed covariance matrix colMeans(z) ## observed mu } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/ziP.Rd0000744000177400001440000001223512725500761013215 0ustar murdochusers\name{ziP} \alias{ziP} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM zero-inflated Poisson regression family} \description{Family for use with \code{\link{gam}}, implementing regression for zero inflated Poisson data when the complimentary log log of the zero probability is linearly dependent on the log of the Poisson parameter. Use with great care, noting that simply having many zero response observations is not an indication of zero inflation: the question is whether you have too many zeroes given the specified model. This sort of model is really only appropriate when none of your covariates help to explain the zeroes in your data. If your covariates predict which observations are likely to have zero mean then adding a zero inflated model on top of this is likely to lead to identifiability problems. Identifiability problems may lead to fit failures, or absurd values for the linear predictor or predicted values. } \usage{ ziP(theta = NULL, link = "identity",b=0) } \arguments{ \item{theta}{the 2 parameters controlling the slope and intercept of the linear transform of the mean controlling the zero inflation rate. If supplied then treated as fixed parameters (\eqn{\theta_1}{theta_1} and \eqn{\theta_2}{theta_2}), otherwise estimated.} \item{link}{The link function: only the \code{"identity"} is currently supported.} \item{b}{a non-negative constant, specifying the minimum dependence of the zero inflation rate on the linear predictor.} } \value{ An object of class \code{extended.family}. } \details{The probability of a zero count is given by \eqn{1-p}{1- p}, whereas the probability of count \eqn{y>0}{y>0} is given by the truncated Poisson probability function \eqn{p\mu^y/((\exp(\mu)-1)y!)}{(pmu^y/((exp(mu)-1)y!)}. The linear predictor gives \eqn{\log \mu}{log(mu)}, while \eqn{\eta = \log(-\log(1-p)) }{eta=log(-log(1-p))} and \eqn{\eta = \theta_1 + \{b+\exp(\theta_2)\} \log \mu }{eta = theta_1 + (b+exp(theta_2)) log(mu)}. The \code{theta} parameters are estimated alongside the smoothing parameters. Increasing the \code{b} parameter from zero can greatly reduce identifiability problems, particularly when there are very few non-zero data. The fitted values for this model are the log of the Poisson parameter. Use the \code{predict} function with \code{type=="response"} to get the predicted expected response. Note that the theta parameters reported in model summaries are \eqn{\theta_1}{theta_1} and \eqn{b + \exp(\theta_2)}{b + exp(theta_2)}. These models should be subject to very careful checking, especially if fitting has not converged. It is quite easy to set up models with identifiability problems, particularly if the data are not really zero inflated, but simply have many zeroes because the mean is very low in some parts of the covariate space. See example for some obvious checks. Take convergence warnings seriously. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood \email{simon.wood@r-project.org} } \section{WARNINGS }{ Zero inflated models are often over-used. Having lots of zeroes in the data does not in itself imply zero inflation. Having too many zeroes *given the model mean* may imply zero inflation. } \references{ Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association. \url{http://arxiv.org/abs/1511.03864} } \seealso{\code{\link{ziplss}}} \examples{ rzip <- function(gamma,theta= c(-2,.3)) { ## generate zero inflated Poisson random variables, where ## lambda = exp(gamma), eta = theta[1] + exp(theta[2])*gamma ## and 1-p = exp(-exp(eta)). y <- gamma; n <- length(y) lambda <- exp(gamma) eta <- theta[1] + exp(theta[2])*gamma p <- 1- exp(-exp(eta)) ind <- p > runif(n) y[!ind] <- 0 np <- sum(ind) ## generate from zero truncated Poisson, given presence... y[ind] <- qpois(runif(np,dpois(0,lambda[ind]),1),lambda[ind]) y } library(mgcv) ## Simulate some ziP data... set.seed(1);n<-400 dat <- gamSim(1,n=n) dat$y <- rzip(dat$f/4-1) b <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=ziP(),data=dat) b$outer.info ## check convergence!! b plot(b,pages=1) plot(b,pages=1,unconditional=TRUE) ## add s.p. uncertainty gam.check(b) ## more checking... ## 1. If the zero inflation rate becomes decoupled from the linear predictor, ## it is possible for the linear predictor to be almost unbounded in regions ## containing many zeroes. So examine if the range of predicted values ## is sane for the zero cases? range(predict(b,type="response")[b$y==0]) ## 2. Further plots... par(mfrow=c(2,2)) plot(predict(b,type="response"),residuals(b)) plot(predict(b,type="response"),b$y);abline(0,1,col=2) plot(b$linear.predictors,b$y) qq.gam(b,rep=20,level=1) ## 3. Refit fixing the theta parameters at their estimated values, to check we ## get essentially the same fit... thb <- b$family$getTheta() b0 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=ziP(theta=thb),data=dat) b;b0 ## Example fit forcing minimum linkage of prob present and ## linear predictor. Can fix some identifiability problems. b2 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=ziP(b=.3),data=dat) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/gevlss.Rd0000755000177400001440000000655312765741174013777 0ustar murdochusers\name{gevlss} \alias{gevlss} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generalized Extreme Value location-scale model family} \description{The \code{gevlss} family implements Generalized Extreme Value location scale additive models in which the location, scale and shape parameters depend on additive smooth predictors. Usable only with \code{\link{gam}}, the linear predictors are specified via a list of formulae. } \usage{ gevlss(link=list("identity","identity","logit")) } \arguments{ \item{link}{three item list specifying the link for the location scale and shape parameters. See details.} } \value{ An object inheriting from class \code{general.family}. } \details{Used with \code{\link{gam}} to fit Generalized Extreme Value location scale and shape models. \code{gam} is called with a list containing 3 formulae: the first specifies the response on the left hand side and the structure of the linear predictor for the location parameter on the right hand side. The second is one sided, specifying the linear predictor for the log scale parameter on the right hand side. The third is one sided specifying the linear predictor for the shape parameter. Link functions \code{"identity"} and \code{"log"} are available for the location (mu) parameter. There is no choice of link for the log scale parameter (\eqn{\rho = \log \sigma}{rho = log sigma}). The shape parameter (xi) defaults to a modified logit link restricting its range to (-1,.5), the upper limit is required to ensure finite variance, while the lower limit ensures consistency of the MLE (Smith, 1985). The fitted values for this family will be a three column matrix. The first column is the location parameter, the second column is the log scale parameter, the third column is the shape parameter. This family does not produce a null deviance. Note that the distribution for \eqn{\xi=0}{xi=0} is approximated by setting \eqn{\xi}{xi} to a small number. The derivative system code for this family is mostly auto-generated, and the family is still somewhat experimental. } \references{ Smith, R.L. (1985) Maximum likelihood estimation in a class of nonregular cases. Biometrika 72(1):67-90 Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association. \url{http://arxiv.org/abs/1511.03864} } \examples{ library(mgcv) Fi.gev <- function(z,mu,sigma,xi) { ## GEV inverse cdf. xi[abs(xi)<1e-8] <- 1e-8 ## approximate xi=0, by small xi x <- mu + ((-log(z))^-xi-1)*sigma/xi } ## simulate test data... f0 <- function(x) 2 * sin(pi * x) f1 <- function(x) exp(2 * x) f2 <- function(x) 0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10 set.seed(1) n <- 500 x0 <- runif(n);x1 <- runif(n);x2 <- runif(n) mu <- f2(x2) rho <- f0(x0) xi <- (f1(x1)-4)/9 y <- Fi.gev(runif(n),mu,exp(rho),xi) dat <- data.frame(y,x0,x1,x2);pairs(dat) ## fit model.... b <- gam(list(y~s(x2),~s(x0),~s(x1)),family=gevlss,data=dat) ## plot and look at residuals... plot(b,pages=1,scale=0) summary(b) par(mfrow=c(2,2)) mu <- fitted(b)[,1];rho <- fitted(b)[,2] xi <- fitted(b)[,3] ## Get the predicted expected response... fv <- mu + exp(rho)*(gamma(1-xi)-1)/xi rsd <- residuals(b) plot(fv,rsd);qqnorm(rsd) plot(fv,residuals(b,"pearson")) plot(fv,residuals(b,"response")) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/logLik.gam.Rd0000755000177400001440000000357012632334033014435 0ustar murdochusers\name{logLik.gam} \alias{logLik.gam} \alias{AIC.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Log likelihood for a fitted GAM, for AIC} \description{ Function to extract the log-likelihood for a fitted \code{gam} model (note that the models are usually fitted by penalized likelihood maximization). Used by \code{\link{AIC}}. } \usage{ \method{logLik}{gam}(object,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ fitted model objects of class \code{gam} as produced by \code{gam()}.} \item{...}{un-used in this case} } \details{ Modification of \code{logLik.glm} which corrects the degrees of freedom for use with \code{gam} objects. The function is provided so that \code{\link{AIC}} functions correctly with \code{gam} objects, and uses the appropriate degrees of freedom (accounting for penalization). Note, when using \code{AIC} for penalized models, that the degrees of freedom are the effective degrees of freedom and not the number of parameters, and the model maximizes the penalized likelihood, not the actual likelihood. (See e.g. Hastie and Tibshirani, 1990, section 6.8.3 and also Wood 2008), By default this routine uses a definition of the effective degrees of freedom that includes smoothing parameter uncertainty, if this is available (i.e. if smoothing parameter selection is by some variety of marginal likelihood). } \value{ Standard \code{logLik} object: see \code{\link{logLik}}. } \references{Hastie and Tibshirani, 1990, Generalized Additive Models. Wood, S.N. (2008) Fast stable direct fitting and smoothness selection for generalized additive models. J.R.Statist. Soc. B 70(3):495-518 } \author{ Simon N. Wood \email{simon.wood@r-project.org} based directly on \code{logLik.glm}} \seealso{ \code{\link{AIC}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/ocat.Rd0000744000177400001440000000514212725500651013376 0ustar murdochusers\name{ocat} \alias{ocat} \alias{ordered.categorical} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM ordered categorical family} \description{Family for use with \code{\link{gam}}, implementing regression for ordered categorical data. A linear predictor provides the expected value of a latent variable following a logistic distribution. The probability of this latent variable lying between certain cut-points provides the probability of the ordered categorical variable being of the corresponding category. The cut-points are estimated along side the model smoothing parameters (using the same criterion). The observed categories are coded 1, 2, 3, ... up to the number of categories. } \usage{ ocat(theta=NULL,link="identity",R=NULL) } \arguments{ \item{theta}{cut point parameter vector (dimension \code{R-2}). If supplied and all positive, then taken to be the cut point increments (first cut point is fixed at -1). If any are negative then absolute values are taken as starting values for cutpoint increments. } \item{link}{The link function: only \code{"identity"} allowed at present (possibly for ever).} \item{R}{the number of catergories.} } \value{ An object of class \code{extended.family}. } \details{Such cumulative threshold models are only identifiable up to an intercept, or one of the cut points. Rather than remove the intercept, \code{ocat} simply sets the first cut point to -1. Use \code{\link{predict.gam}} with \code{type="response"} to get the predicted probabilities in each category. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood \email{simon.wood@r-project.org} } \references{ Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association. \url{http://arxiv.org/abs/1511.03864} } \examples{ library(mgcv) ## Simulate some ordered categorical data... set.seed(3);n<-400 dat <- gamSim(1,n=n) dat$f <- dat$f - mean(dat$f) alpha <- c(-Inf,-1,0,5,Inf) R <- length(alpha)-1 y <- dat$f u <- runif(n) u <- dat$f + log(u/(1-u)) for (i in 1:R) { y[u > alpha[i]&u <= alpha[i+1]] <- i } dat$y <- y ## plot the data... par(mfrow=c(2,2)) with(dat,plot(x0,y));with(dat,plot(x1,y)) with(dat,plot(x2,y));with(dat,plot(x3,y)) ## fit ocat model to data... b <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=ocat(R=R),data=dat) b plot(b,pages=1) gam.check(b) summary(b) b$family$getTheta(TRUE) ## the estimated cut points ## predict probabilities of being in each category predict(b,dat[1:2,],type="response",se=TRUE) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/ziplss.Rd0000744000177400001440000000667712725501013014003 0ustar murdochusers\name{ziplss} \alias{ziplss} %- Also NEED an `\alias' for EACH other topic documented here. \title{Zero inflated Poisson location-scale model family} \description{The \code{ziplss} family implements a zero inflated Poisson model in which one linear predictor controls the probability of presence and the other controls the mean given presence. Useable only with \code{\link{gam}}, the linear predictors are specified via a list of formulae. Should be used with care: simply having a large number of zeroes is not an indication of zero inflation. Requires integer count data. } \usage{ ziplss(link=list("identity","identity")) } \arguments{ \item{link}{two item list specifying the link - currently only identity links are possible, as parameterization is directly in terms of log of Poisson response and logit of probability of presence.} } \value{ An object inheriting from class \code{general.family}. } \details{Used with \code{\link{gam}} to fit 2 stage zero inflated Poisson models. \code{gam} is called with a list containing 2 formulae, the first specifies the response on the left hand side and the structure of the linear predictor for the Poisson parameter on the right hand side. The second is one sided, specifying the linear predictor for the probability of presence on the right hand side. The fitted values for this family will be a two column matrix. The first column is the log of the Poisson parameter, and the second column is the complimentary log log of probability of presnece.. Predictions using \code{\link{predict.gam}} will also produce 2 column matrices for \code{type} \code{"link"} and \code{"response"}. The null deviance computed for this model assumes that a single probability of presence and a single Poisson parameter are estimated. For data with large areas of covariate space over which the response is zero it may be advisable to use low order penalties to avoid problems. For 1D smooths uses e.g. \code{s(x,m=1)} and for isotropic smooths use \code{\link{Duchon.spline}}s in place of thin plaste terms with order 1 penalties, e.g \code{s(x,z,m=c(1,.5))} --- such smooths penalize towards constants, thereby avoiding extreme estimates when the data are uninformative. } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \references{ Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association. \url{http://arxiv.org/abs/1511.03864} } \section{WARNINGS }{ Zero inflated models are often over-used. Having lots of zeroes in the data does not in itself imply zero inflation. Having too many zeroes *given the model mean* may imply zero inflation. } \examples{ library(mgcv) ## simulate some data... f0 <- function(x) 2 * sin(pi * x); f1 <- function(x) exp(2 * x) f2 <- function(x) 0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10 n <- 500;set.seed(5) x0 <- runif(n); x1 <- runif(n) x2 <- runif(n); x3 <- runif(n) ## Simulate probability of potential presence... eta1 <- f0(x0) + f1(x1) - 3 p <- binomial()$linkinv(eta1) y <- as.numeric(runif(n)0 eta2 <- f2(x2[ind])/3 y[ind] <- rpois(exp(eta2),exp(eta2)) ## Fit ZIP model... b <- gam(list(y~s(x2)+s(x3),~s(x0)+s(x1)),family=ziplss()) b$outer.info ## check convergence summary(b) plot(b,pages=1) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/negbin.Rd0000744000177400001440000001265412725500575013725 0ustar murdochusers\name{negbin} \alias{negbin} \alias{nb} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM negative binomial families} \description{The \code{gam} modelling function is designed to be able to use the \code{\link{negbin}} family (a modification of MASS library \code{negative.binomial} family by Venables and Ripley), or the \code{\link{nb}} function designed for integrated estimation of parameter \code{theta}. \eqn{\theta} is the parameter such that \eqn{var(y) = \mu + \mu^2/\theta}, where \eqn{\mu = E(y)}. Two approaches to estimating \code{theta} are available (with \code{\link{gam}} only): \itemize{ \item With \code{negbin} then if `performance iteration' is used for smoothing parameter estimation (see \code{\link{gam}}), then smoothing parameters are chosen by GCV and \code{theta} is chosen in order to ensure that the Pearson estimate of the scale parameter is as close as possible to 1, the value that the scale parameter should have. \item If `outer iteration' is used for smoothing parameter selection with the \code{nb} family then \code{theta} is estimated alongside the smoothing parameters by ML or REML. } To use the first option, set the \code{optimizer} argument of \code{\link{gam}} to \code{"perf"} (it can sometimes fail to converge). } \usage{ negbin(theta = stop("'theta' must be specified"), link = "log") nb(theta = NULL, link = "log") } \arguments{ \item{theta}{Either i) a single value known value of theta or ii) two values of theta specifying the endpoints of an interval over which to search for theta (this is an option only for \code{negbin}). For \code{nb} then a positive supplied \code{theta} is treated as a fixed known parameter, otherwise it is estimated (the absolute value of a negative \code{theta} is taken as a starting value).} \item{link}{The link function: one of \code{"log"}, \code{"identity"} or \code{"sqrt"}} } \value{ For \code{negbin} an object inheriting from class \code{family}, with additional elements \item{dvar}{the function giving the first derivative of the variance function w.r.t. \code{mu}.} \item{d2var}{the function giving the second derivative of the variance function w.r.t. \code{mu}.} \item{getTheta}{A function for retrieving the value(s) of theta. This also useful for retriving the estimate of \code{theta} after fitting (see example).} For \code{nb} an object inheriting from class \code{extended.family}. } \details{\code{nb} allows estimation of the \code{theta} parameter alongside the model smoothing parameters, but is only useable with \code{\link{gam}} (not \code{bam} or \code{gamm}). For \code{negbin}, if a single value of \code{theta} is supplied then it is always taken as the known fixed value and this is useable with \code{\link{bam}} and \code{\link{gamm}}. If \code{theta} is two numbers (\code{theta[2]>theta[1]}) then they are taken as specifying the range of values over which to search for the optimal theta. This option should only be used with performance iteration estimation (see \code{\link{gam}} argument \code{optimizer}), in which case the method of estimation is to choose \eqn{\hat \theta}{theta} so that the GCV (Pearson) estimate of the scale parameter is one (since the scale parameter is one for the negative binomial). In this case \eqn{\theta}{theta} estimation is nested within the IRLS loop used for GAM fitting. After each call to fit an iteratively weighted additive model to the IRLS pseudodata, the \eqn{\theta}{theta} estimate is updated. This is done by conditioning on all components of the current GCV/Pearson estimator of the scale parameter except \eqn{\theta}{theta} and then searching for the \eqn{\hat \theta}{theta} which equates this conditional estimator to one. The search is a simple bisection search after an initial crude line search to bracket one. The search will terminate at the upper boundary of the search region is a Poisson fit would have yielded an estimated scale parameter <1. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood \email{simon.wood@r-project.org} modified from Venables and Ripley's \code{negative.binomial} family. } \references{ Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association. \url{http://arxiv.org/abs/1511.03864} Venables, B. and B.R. Ripley (2002) Modern Applied Statistics in S, Springer. } \section{WARNINGS}{ \code{\link{gamm}} and \code{\link{bam}} do not support \code{theta} estimation The negative binomial functions from the MASS library are no longer supported. } \examples{ library(mgcv) set.seed(3) n<-400 dat <- gamSim(1,n=n) g <- exp(dat$f/5) ## negative binomial data... dat$y <- rnbinom(g,size=3,mu=g) ## known theta fit ... b0 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=negbin(3),data=dat) plot(b0,pages=1) print(b0) ## same with theta estimation... b <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=nb(),data=dat) plot(b,pages=1) print(b) b$family$getTheta(TRUE) ## extract final theta estimate ## unknown theta via performance iteration... b1 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=negbin(c(1,10)), optimizer="perf",data=dat) plot(b1,pages=1) print(b1) ## another example... set.seed(1) f <- dat$f f <- f - min(f)+5;g <- f^2/10 dat$y <- rnbinom(g,size=3,mu=g) b2 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=nb(link="sqrt"), data=dat,method="REML") plot(b2,pages=1) print(b2) rm(dat) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/mgcv-FAQ.Rd0000744000177400001440000001650712732461421014017 0ustar murdochusers\name{mgcv.FAQ} \alias{mgcv.FAQ} %- Also NEED an `\alias' for EACH other topic documented here. \title{Frequently Asked Questions for package mgcv} \description{ This page provides answers to some of the questions that get asked most often about mgcv} \section{FAQ list}{ \enumerate{ \item \bold{How can I compare gamm models?} In the identity link normal errors case, then AIC and hypotheis testing based methods are fine. Otherwise it is best to work out a strategy based on the \code{\link{summary.gam}} Alternatively, simple random effects can be fitted with \code{\link{gam}}, which makes comparison straightforward. Package \code{gamm4} is an alternative, which allows AIC type model selection for generalized models. \item \bold{How do I get the equation of an estimated smooth?} This slightly misses the point of semi-parametric modelling: the idea is that we estimate the form of the function from data without assuming that it has a particular simple functional form. Of course for practical computation the functions do have underlying mathematical representations, but they are not very helpful, when written down. If you do need the functional forms then see chapter 4 of Wood (2006). However for most purposes it is better to use \code{\link{predict.gam}} to evaluate the function for whatever argument values you need. If derivatives are required then the simplest approach is to use finite differencing (which also allows SEs etc to be calculated). \item \bold{Some of my smooths are estimated to be straight lines and their confidence intervals vanish at some point in the middle. What is wrong?} Nothing. Smooths are subject to sum-to-zero identifiability constraints. If a smooth is estimated to be a straight line then it consequently has one degree of freedom, and there is no choice about where it passes through zero --- so the CI must vanish at that point. \item \bold{How do I test whether a smooth is significantly different from a straight line}. See \code{\link{tprs}} and the example therein. \item \bold{An example from an mgcv helpfile gives an error - is this a bug?} It might be, but first please check that the version of mgcv you have loaded into R corresponds to the version from which the helpfile came. Many such problems are caused by trying to run code only supported in a later mgcv version in an earlier version. Another possibility is that you have an object loaded whose name clashes with an mgcv function (for example you are trying to use the mgcv \code{multinom} function, but have another object called \code{multinom} loaded.) \item \bold{Some code from Wood (2006) causes an error: why?} The book was written using mgcv version 1.3. To allow for REML estimation of smoothing parameters in versions 1.5, some changes had to be made to the syntax. In particular the function \code{gam.method} no longer exists. The smoothness selection method (GCV, REML etc) is now controlled by the \code{method} argument to \code{gam} while the optimizer is selected using the \code{optimizer} argument. See \code{\link{gam}} and \url{http://www.maths.bris.ac.uk/~sw15190/igam/index.html} for details. \item \bold{Why is a model object saved under a previous mgcv version not usable with the current mgcv version?} I'm sorry about this issue, I know it's really annoying. Here's my defence. Each mgcv version is run through an extensive test suite before release, to ensure that it gives the same results as before, unless there are good statistical reasons why not (e.g. improvements to p-value approximation, fixing of an error). However it is sometimes necessary to modify the internal structure of model objects in a way that makes an old style object unusable with a newer version. For example, bug fixes or new R features sometimes require changes in the way that things are computed which in turn require modification of the object structure. Similarly improvements, such as the ability to compute smoothing parameters by RE/ML require object level changes. The only fix to this problem is to access the old object using the original mgcv version (available on CRAN), or to recompute the fit using the current mgcv version. \item \bold{When using \code{gamm} or \code{gamm4}, the reported AIC is different for the \code{gam} object and the \code{lme} or \code{lmer} object. Why is this?} There are several reasons for this. The most important is that the models being used are actually different in the two representations. When treating the GAM as a mixed model, you are implicitly assuming that if you gathered a replicate dataset, the smooths in your model would look completely different to the smooths from the original model, except for having the same degree of smoothness. Technically you would expect the smooths to be drawn afresh from their distribution under the random effects model. When viewing the gam from the usual penalized regression perspective, you would expect smooths to look broadly similar under replication of the data. i.e. you are really using Bayesian model for the smooths, rather than a random effects model (it's just that the frequentist random effects and Bayesian computations happen to coincide for computing the estimates). As a result of the different assumptions about the data generating process, AIC model comparisons can give rather different answers depending on the model adopted. Which you use should depend on which model you really think is appropriate. In addition the computations of the AICs are different. The mixed model AIC uses the marginal liklihood and the corresponding number of model parameters. The gam model uses the penalized likelihood and the effective degrees of freedom. \item \bold{What does 'mgcv' stand for?} '\bold{M}ixed \bold{G}AM \bold{C}omputation \bold{V}ehicle', is my current best effort (let me know if you can do better). Originally it stood for `Multiple GCV', which has long since ceased to be usefully descriptive, (and I can't really change 'mgcv' now without causing disruption). On a bad inbox day '\bold{M}ad \bold{G}AM \bold{C}omputing \bold{V}ulture'. \item \bold{My new method is failing to beat mgcv, what can I do?} If speed is the problem, then make sure that you use the slowest basis possible (\code{"tp"}) with a large sample size, and experiment with different optimizers to find one that is slow for your problem. For prediction error/MSE, then leaving the smoothing basis dimensions at their arbitrary defaults, when these are inappropriate for the problem setting, is a good way of reducing performance. Similarly, using p-splines in place of derivative penalty based splines will often shave a little more from the performance here. Unlike REML/ML, prediction error based smoothness selection criteria such as Mallows Cp and GCV often produce a small proportion of severe overfits, so careful choise of smoothness selection method can help further. In particular GCV etc. usually result in worse confidence interval and p-value performance than ML or REML. If all this fails, try using a really odd simulation setup for which mgcv is clearly not suited: for example poor performance is almost guaranteed for small noisy datasets with large numbers of predictors. } } \references{ Wood S.N. (2006) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/random.effects.Rd0000744000177400001440000001137712743617360015363 0ustar murdochusers\name{random.effects} \alias{random.effects} \title{Random effects in GAMs} \description{ The smooth components of GAMs can be viewed as random effects for estimation purposes. This means that more conventional random effects terms can be incorporated into GAMs in two ways. The first method converts all the smooths into fixed and random components suitable for estimation by standard mixed modelling software. Once the GAM is in this form then conventional random effects are easily added, and the whole model is estimated as a general mixed model. \code{\link{gamm}} and \code{gamm4} from the \code{gamm4} package operate in this way. The second method represents the conventional random effects in a GAM in the same way that the smooths are represented --- as penalized regression terms. This method can be used with \code{\link{gam}} by making use of \code{s(...,bs="re")} terms in a model: see \code{\link{smooth.construct.re.smooth.spec}}, for full details. The basic idea is that, e.g., \code{s(x,z,g,bs="re")} generates an i.i.d. Gaussian random effect with model matrix given by \code{model.matrix(~x:z:g-1)} --- in principle such terms can take any number of arguments. This simple approach is sufficient for implementing a wide range of commonly used random effect structures. For example if \code{g} is a factor then \code{s(g,bs="re")} produces a random coefficient for each level of \code{g}, with the radndom coefficients all modelled as i.i.d. normal. If \code{g} is a factor and \code{x} is numeric, then \code{s(x,g,bs="re")} produces an i.i.d. normal random slope relating the response to \code{x} for each level of \code{g}. If \code{h} is another factor then \code{s(h,g,bs="re")} produces the usual i.i.d. normal \code{g} - \code{h} interaction. Note that a rather useful approximate test for zero random effect is also implemented for tsuch terms based on Wood (2013). If the precision matrix is known to within a multiplicative constant, then this can be supplied via the \code{xt} argument of \code{s}. See \link{smooth.construct.re.smooth.spec} for details and example. Alternatively, but less straightforwardly, the \code{paraPen} argument to \code{\link{gam}} can be used: see \code{\link{gam.models}}. If smoothing parameter estimation is by ML or REML (e.g. \code{gam(...,method="REML")}) then this approach is a completely conventional likelihood based treatment of random effects. \code{gam} can be slow for fitting models with large numbers of random effects, because it does not exploit the sparcity that is often a feature of parametric random effects. It can not be used for models with more coefficients than data. However \code{gam} is often faster and more relaiable than \code{gamm} or \code{gamm4}, when the number of random effects is modest. To facilitate the use of random effects with \code{gam}, \code{\link{gam.vcomp}} is a utility routine for converting smoothing parameters to variance components. It also provides confidence intervals, if smoothness estimation is by ML or REML. Note that treating random effects as smooths does not remove the usual problems associated with testing variance components for equality to zero: see \code{\link{summary.gam}} and \code{\link{anova.gam}}. } \seealso{\code{\link{gam.vcomp}}, \code{\link{gam.models}}, \code{\link{smooth.terms}}, \code{\link{smooth.construct.re.smooth.spec}}, \code{\link{gamm}}} \author{ Simon Wood } \references{ Wood, S.N. (2013) A simple test for random effects in regression models. Biometrika 100:1005-1010 Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 Wood, S.N. (2008) Fast stable direct fitting and smoothness selection for generalized additive models. Journal of the Royal Statistical Society (B) 70(3):495-518 Wood, S.N. (2006) Low rank scale invariant tensor product smooths for generalized additive mixed models. Biometrics 62(4):1025-1036 } \examples{ ## see also examples for gam.models, gam.vcomp, gamm ## and smooth.construct.re.smooth.spec ## simple comparison of lme and gam require(mgcv) require(nlme) b0 <- lme(travel~1,data=Rail,~1|Rail,method="REML") b <- gam(travel~s(Rail,bs="re"),data=Rail,method="REML") intervals(b0) gam.vcomp(b) anova(b) ## simulate example... dat <- gamSim(1,n=400,scale=2) ## simulate 4 term additive truth fac <- as.factor(sample(1:20,400,replace=TRUE)) dat$X <- model.matrix(~fac-1) b <- rnorm(20)*.5 dat$y <- dat$y + dat$X\%*\%b rm1 <- gam(y ~ s(fac,bs="re")+s(x0)+s(x1)+s(x2)+s(x3),data=dat,method="ML") gam.vcomp(rm1) fv0 <- predict(rm1,exclude="s(fac)") ## predictions setting r.e. to 0 fv1 <- predict(rm1) ## predictions setting r.e. to predicted values } \keyword{regression}mgcv/man/smooth.construct.ad.smooth.spec.Rd0000644000177400001440000001260612632334033020626 0ustar murdochusers\name{smooth.construct.ad.smooth.spec} \alias{smooth.construct.ad.smooth.spec} \alias{adaptive.smooth} %- Also NEED an `\alias' for EACH other topic documented here. \title{Adaptive smooths in GAMs} \description{\code{\link{gam}} can use adaptive smooths of one or two variables, specified via terms like \code{s(...,bs="ad",...)}. (\code{\link{gamm}} can not use such terms --- check out package \code{AdaptFit} if this is a problem.) The basis for such a term is a (tensor product of) p-spline(s) or cubic regression spline(s). Discrete P-spline type penalties are applied directly to the coefficients of the basis, but the penalties themselves have a basis representation, allowing the strength of the penalty to vary with the covariates. The coefficients of the penalty basis are the smoothing parameters. When invoking an adaptive smoother the \code{k} argument specifies the dimension of the smoothing basis (default 40 in 1D, 15 in 2D), while the \code{m} argument specifies the dimension of the penalty basis (default 5 in 1D, 3 in 2D). For an adaptive smooth of two variables \code{k} is taken as the dimension of both marginal bases: different marginal basis dimensions can be specified by making \code{k} a two element vector. Similarly, in the two dimensional case \code{m} is the dimension of both marginal bases for the penalties, unless it is a two element vector, which specifies different basis dimensions for each marginal (If the penalty basis is based on a thin plate spline then \code{m} specifies its dimension directly). By default, P-splines are used for the smoothing and penalty bases, but this can be modified by supplying a list as argument \code{xt} with a character vector \code{xt$bs} specifying the smoothing basis type. Only \code{"ps"}, \code{"cp"}, \code{"cc"} and \code{"cr"} may be used for the smoothing basis. The penalty basis is always a B-spline, or a cyclic B-spline for cyclic bases. The total number of smoothing parameters to be estimated for the term will be the dimension of the penalty basis. Bear in mind that adaptive smoothing places quite severe demands on the data. For example, setting \code{m=10} for a univariate smooth of 200 data is rather like estimating 10 smoothing parameters, each from a data series of length 20. The problem is particularly serious for smooths of 2 variables, where the number of smoothing parameters required to get reasonable flexibility in the penalty can grow rather fast, but it often requires a very large smoothing basis dimension to make good use of this flexibility. In short, adaptive smooths should be used sparingly and with care. In practice it is often as effective to simply transform the smoothing covariate as it is to use an adaptive smooth. } \usage{ \method{smooth.construct}{ad.smooth.spec}(object, data, knots) } \arguments{ \item{object}{a smooth specification object, usually generated by a term \code{s(...,bs="ad",...)}} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}} } \value{ An object of class \code{"pspline.smooth"} in the 1D case or \code{"tensor.smooth"} in the 2D case. } \details{ The constructor is not normally called directly, but is rather used internally by \code{\link{gam}}. To use for basis setup it is recommended to use \code{\link{smooth.construct2}}. This class can not be used as a marginal basis in a tensor product smooth, nor by \code{gamm}. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ ## Comparison using an example taken from AdaptFit ## library(AdaptFit) require(mgcv) set.seed(0) x <- 1:1000/1000 mu <- exp(-400*(x-.6)^2)+5*exp(-500*(x-.75)^2)/3+2*exp(-500*(x-.9)^2) y <- mu+0.5*rnorm(1000) ##fit with default knots ## y.fit <- asp(y~f(x)) par(mfrow=c(2,2)) ## plot(y.fit,main=round(cor(fitted(y.fit),mu),digits=4)) ## lines(x,mu,col=2) b <- gam(y~s(x,bs="ad",k=40,m=5)) ## adaptive plot(b,shade=TRUE,main=round(cor(fitted(b),mu),digits=4)) lines(x,mu-mean(mu),col=2) b <- gam(y~s(x,k=40)) ## non-adaptive plot(b,shade=TRUE,main=round(cor(fitted(b),mu),digits=4)) lines(x,mu-mean(mu),col=2) b <- gam(y~s(x,bs="ad",k=40,m=5,xt=list(bs="cr"))) plot(b,shade=TRUE,main=round(cor(fitted(b),mu),digits=4)) lines(x,mu-mean(mu),col=2) ## A 2D example (marked, 'Not run' purely to reduce ## checking load on CRAN). \dontrun{ par(mfrow=c(2,2),mar=c(1,1,1,1)) x <- seq(-.5, 1.5, length= 60) z <- x f3 <- function(x,z,k=15) { r<-sqrt(x^2+z^2);f<-exp(-r^2*k);f} f <- outer(x, z, f3) op <- par(bg = "white") ## Plot truth.... persp(x,z,f,theta=30,phi=30,col="lightblue",ticktype="detailed") n <- 2000 x <- runif(n)*2-.5 z <- runif(n)*2-.5 f <- f3(x,z) y <- f + rnorm(n)*.1 ## Try tprs for comparison... b0 <- gam(y~s(x,z,k=150)) vis.gam(b0,theta=30,phi=30,ticktype="detailed") ## Tensor product with non-adaptive version of adaptive penalty b1 <- gam(y~s(x,z,bs="ad",k=15,m=1),gamma=1.4) vis.gam(b1,theta=30,phi=30,ticktype="detailed") ## Now adaptive... b <- gam(y~s(x,z,bs="ad",k=15,m=3),gamma=1.4) vis.gam(b,theta=30,phi=30,ticktype="detailed") cor(fitted(b0),f);cor(fitted(b),f) } } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/gaulss.Rd0000744000177400001440000000521112755554057013757 0ustar murdochusers\name{gaulss} \alias{gaulss} %- Also NEED an `\alias' for EACH other topic documented here. \title{Gaussian location-scale model family} \description{The \code{gaulss} family implements Gaussian location scale additive models in which the mean and the logb of the standard deviation (see details) can depend on additive smooth predictors. Useable only with \code{\link{gam}}, the linear predictors are specified via a list of formulae. } \usage{ gaulss(link=list("identity","logb"),b=0.01) } \arguments{ \item{link}{two item list specifying the link for the mean and the standard deviation. See details.} \item{b}{The minumum standard deviation, for the \code{"logb"} link.} } \value{ An object inheriting from class \code{general.family}. } \details{Used with \code{\link{gam}} to fit Gaussian location - scale models. \code{gam} is called with a list containing 2 formulae, the first specifies the response on the left hand side and the structure of the linear predictor for the mean on the right hand side. The second is one sided, specifying the linear predictor for the standard deviation on the right hand side. Link functions \code{"identity"}, \code{"inverse"}, \code{"log"} and \code{"sqrt"} are available for the mean. For the standard deviation only the \code{"logb"} link is implemented: \eqn{\eta = \log(\sigma - b)}{eta = log(sigma-b)} and \eqn{\sigma = b + \exp(\eta)}{sigma = b + exp(eta)}. This link is designed to avoid singularities in the likelihood caused by the standard deviation tending to zero. The fitted values for this family will be a two column matrix. The first column is the mean, and the second column is the inverse of the standard deviation. Predictions using \code{\link{predict.gam}} will also produce 2 column matrices for \code{type} \code{"link"} and \code{"response"}. The second column when \code{type="response"} is again on the reciprocal standard deviation scale (i.e. the square root precision scale). The null deviance reported for this family is the sum of squares of the difference between the response and the mean response divided by the standard deviation of the response according to the model. The deviance is the sum of squares of residuals divided by model standard deviations. } \references{ Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association. \url{http://arxiv.org/abs/1511.03864} } \examples{ library(mgcv);library(MASS) b <- gam(list(accel~s(times,k=20,bs="ad"),~s(times)), data=mcycle,family=gaulss()) summary(b) plot(b,pages=1,scale=0) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/coxpht.Rd0000744000177400001440000001221212760313000013736 0ustar murdochusers\name{cox.pht} \alias{cox.pht} %- Also NEED an `\alias' for EACH other topic documented here. \title{Additive Cox proportional hazard models with time varying covariates} \description{The \code{cox.ph} family only allows one set of covariate values per subject. If each subject has several time varying covariate measurements then it is still possible to fit a proportional hazards regression model, via an equivalent Poisson model. The recipe is provided by Whitehead (1980) and is equally valid in the smooth additive case. Its drawback is that the equivalent Poisson dataset can be quite large. The trick is to generate an artificial Poisson observation for each subject in the risk set at each non-censored event time. The corresponding covariate values for each subject are whatever they are at the event time, while the Poisson response is zero for all subjects except those experiencing the event at that time (this corresponds to Peto's correction for ties). The linear predictor for the model must include an intercept for each event time (the cumulative sum of the exponential of these is the Breslow estimate of the baseline hazard). Below is some example code employing this trick for the \code{\link[survival]{pbcseq}} data from the \code{survival} package. It uses \code{\link{bam}} for fitting with the \code{discrete=TRUE} option for efficiency: there is some approximation involved in doing this, and the exact equivalent to what is done in \code{\link{cox.ph}} is rather obtained by using \code{\link{gam}} with \code{method="REML"} (taking some 14 times the computational time for the example below). The function \code{tdpois} in the example code uses crude piecewise constant interpolation for the covariates, in which the covariate value at an event time is taken to be whatever it was the previous time that it was measured. Obviously more sophisticated interpolation schemes might be preferable. } \references{ Whitehead (1980) Fitting Cox's regression model to survival data using GLIM. Applied Statistics 29(3):268-275 } \examples{ require(mgcv);require(survival) ## First define functions for producing Poisson model data frame app <- function(x,t,to) { ## wrapper to approx for calling from apply... y <- if (sum(!is.na(x))<1) rep(NA,length(to)) else approx(t,x,to,method="constant",rule=2)$y if (is.factor(x)) factor(levels(x)[y],levels=levels(x)) else y } ## app tdpois <- function(dat,event="z",et="futime",t="day",status="status1", id="id") { ## dat is data frame. id is patient id; et is event time; t is ## observation time; status is 1 for death 0 otherwise; ## event is name for Poisson response. if (event \%in\% names(dat)) warning("event name in use") require(utils) ## for progress bar te <- sort(unique(dat[[et]][dat[[status]]==1])) ## event times sid <- unique(dat[[id]]) prg <- txtProgressBar(min = 0, max = length(sid), initial = 0, char = "=",width = NA, title="Progress", style = 3) ## create dataframe for poisson model data dat[[event]] <- 0; start <- 1 dap <- dat[rep(1:length(sid),length(te)),] for (i in 1:length(sid)) { ## work through patients di <- dat[dat[[id]]==sid[i],] ## ith patient's data tr <- te[te <= di[[et]][1]] ## times required for this patient ## Now do the interpolation of covariates to event times... um <- data.frame(lapply(X=di,FUN=app,t=di[[t]],to=tr)) ## Mark the actual event... if (um[[et]][1]==max(tr)&&um[[status]]==1) um[[event]][nrow(um)] <- 1 um[[et]] <- tr ## reset time to relevant event times dap[start:(start-1+nrow(um)),] <- um ## copy to dap start <- start + nrow(um) setTxtProgressBar(prg, i) } close(prg) dap[1:(start-1),] } ## tdpois ## The following takes too long for CRAN checking ## (but typically takes a minute or less). \dontrun{ ## Convert pbcseq to equivalent Poisson form... pbcseq$status1 <- as.numeric(pbcseq$status==2) ## death indicator pb <- tdpois(pbcseq) ## conversion pb$tf <- factor(pb$futime) ## add factor for event time ## Fit Poisson model... b <- bam(z ~ tf - 1 + sex + trt + s(sqrt(protime)) + s(platelet)+ s(age)+ s(bili)+s(albumin), family=poisson,data=pb,discrete=TRUE,nthreads=2) par(mfrow=c(2,3)) plot(b,scale=0) ## compute residuals... chaz <- tapply(fitted(b),pb$id,sum) ## cum haz by subject d <- tapply(pb$z,pb$id,sum) ## censoring indicator mrsd <- d - chaz ## Martingale drsd <- sign(mrsd)*sqrt(-2*(mrsd + d*log(chaz))) ## deviance ## plot survivor function and s.e. band for subject 25 te <- sort(unique(pb$futime)) ## event times di <- pbcseq[pbcseq$id==25,] ## data for subject 25 pd <- data.frame(lapply(X=di,FUN=app,t=di$day,to=te)) ## interpolate to te pd$tf <- factor(te) X <- predict(b,newdata=pd,type="lpmatrix") eta <- drop(X\%*\%coef(b)); H <- cumsum(exp(eta)) J <- apply(exp(eta)*X,2,cumsum) se <- diag(J\%*\%vcov(b)\%*\%t(J))^.5 plot(stepfun(te,c(1,exp(-H))),do.points=FALSE,ylim=c(0.7,1), ylab="S(t)",xlab="t (days)",main="",lwd=2) lines(stepfun(te,c(1,exp(-H+se))),do.points=FALSE) lines(stepfun(te,c(1,exp(-H-se))),do.points=FALSE) rug(pbcseq$day[pbcseq$id==25]) ## measurement times } } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/sp.vcov.Rd0000644000177400001440000000327012632334033014041 0ustar murdochusers\name{sp.vcov} \alias{sp.vcov} %- Also NEED an `\alias' for EACH other topic documented here. \title{Extract smoothing parameter estimator covariance matrix from (RE)ML GAM fit} \description{ Extracts the estimated covariance matrix for the log smoothing parameter estimates from a (RE)ML estimated \code{gam} object, provided the fit was with a method that evaluated the required Hessian. } \usage{ sp.vcov(x) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{ a fitted model object of class \code{gam} as produced by \code{gam()}.} } \details{ Just extracts the inverse of the hessian matrix of the negative (restricted) log likelihood w.r.t the log smoothing parameters, if this has been obtained as part of fitting. } \value{ A matrix corresponding to the estimated covariance matrix of the log smoothing parameter estimators, if this can be extracted, otherwise \code{NULL}. If the scale parameter has been (RE)ML estimated (i.e. if the method was \code{"ML"} or \code{"REML"} and the scale parameter was unknown) then the last row and column relate to the log scale parameter. } \author{Simon N. Wood \email{simon.wood@r-project.org} } \references{ Wood, S.N. (2006) On confidence intervals for generalized additive models based on penalized regression splines. Australian and New Zealand Journal of Statistics. 48(4): 445-464. } \seealso{ \code{\link{gam}}, \code{\link{gam.vcomp}}} \examples{ require(mgcv) n <- 100 x <- runif(n);z <- runif(n) y <- sin(x*2*pi) + rnorm(n)*.2 mod <- gam(y~s(x,bs="cc",k=10)+s(z),knots=list(x=seq(0,1,length=10)), method="REML") sp.vcov(mod) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/gam.vcomp.Rd0000644000177400001440000000773712632334033014346 0ustar murdochusers\name{gam.vcomp} \alias{gam.vcomp} %- Also NEED an `\alias' for EACH other topic documented here. \title{Report gam smoothness estimates as variance components} \description{GAMs can be viewed as mixed models, where the smoothing parameters are related to variance components. This routine extracts the estimated variance components associated with each smooth term, and if possible returns confidence intervals on the standard deviation scale. } \usage{ gam.vcomp(x,rescale=TRUE,conf.lev=.95) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{ a fitted model object of class \code{gam} as produced by \code{gam()}.} \item{rescale}{ the penalty matrices for smooths are rescaled before fitting, for numerical stability reasons, if \code{TRUE} this rescaling is reversed, so that the variance components are on the original scale.} \item{conf.lev}{ when the smoothing parameters are estimated by REML or ML, then confidence intervals for the variance components can be obtained from large sample likelihood results. This gives the confidence level to work at.} } \details{The (pseudo) inverse of the penalty matrix penalizing a term is proportional to the covariance matrix of the term's coefficients, when these are viewed as random. For single penalty smooths, it is possible to compute the variance component for the smooth (which multiplies the inverse penalty matrix to obtain the covariance matrix of the smooth's coefficients). This variance component is given by the scale parameter divided by the smoothing parameter. This routine computes such variance components, for \code{gam} models, and associated confidence intervals, if smoothing parameter estimation was likelihood based. Note that variance components are also returned for tensor product smooths, but that their interpretation is not so straightforward. The routine is particularly useful for model fitted by \code{\link{gam}} in which random effects have been incorporated. } \value{ Either a vector of variance components for each smooth term (as standard deviations), or a matrix. The first column of the matrix gives standard deviations for each term, while the subsequent columns give lower and upper confidence bounds, on the same scale. For models in which there are more smoothing parameters than actually estimated (e.g. if some were fixed, or smoothing parameters are linked) then a list is returned. The \code{vc} element is as above, the \code{all} element is a vector of variance components for all the smoothing parameters (estimated + fixed or replicated). The routine prints a table of estimated standard deviations and confidence limits, if these can be computed, and reports the numerical rank of the covariance matrix. } \author{Simon N. Wood \email{simon.wood@r-project.org} } \references{ Wood, S.N. (2008) Fast stable direct fitting and smoothness selection for generalized additive models. Journal of the Royal Statistical Society (B) 70(3):495-518 Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 } \seealso{ \code{\link{smooth.construct.re.smooth.spec}}} \examples{ set.seed(3) require(mgcv) ## simulate some data, consisting of a smooth truth + random effects dat <- gamSim(1,n=400,dist="normal",scale=2) a <- factor(sample(1:10,400,replace=TRUE)) b <- factor(sample(1:7,400,replace=TRUE)) Xa <- model.matrix(~a-1) ## random main effects Xb <- model.matrix(~b-1) Xab <- model.matrix(~a:b-1) ## random interaction dat$y <- dat$y + Xa\%*\%rnorm(10)*.5 + Xb\%*\%rnorm(7)*.3 + Xab\%*\%rnorm(70)*.7 dat$a <- a;dat$b <- b ## Fit the model using "re" terms, and smoother linkage mod <- gam(y~s(a,bs="re")+s(b,bs="re")+s(a,b,bs="re")+s(x0,id=1)+s(x1,id=1)+ s(x2,k=15)+s(x3),data=dat,method="ML") gam.vcomp(mod) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ...