├── .Rbuildignore ├── .gitignore ├── .travis.yml ├── DESCRIPTION ├── LICENCE.note ├── NAMESPACE ├── NEWS ├── R ├── AO.R ├── clm.R ├── clm.Thetamat.R ├── clm.anova.R ├── clm.fit.R ├── clm.fitter.R ├── clm.frames.R ├── clm.methods.R ├── clm.nominal_test.R ├── clm.predict.R ├── clm.profile.R ├── clm.simple.R ├── clm.slice.R ├── clm.slice2D.R ├── clm.start.R ├── clm2.R ├── clmm.R ├── clmm.formula.R ├── clmm.methods.R ├── clmm.ranef.R ├── clmm.ssr.R ├── clmm.start.R ├── clmm2.R ├── clmm2.utils.R ├── contrast_utils.R ├── control.R ├── convergence.R ├── derivatives.R ├── drop.coef.R ├── gdist.R ├── gumbel.R ├── lgamma.R ├── terms_utils.R ├── utils.R └── warning_functions.R ├── README.md ├── data ├── income.rda ├── soup.rda └── wine.rda ├── inst └── CITATION ├── man ├── VarCorr.Rd ├── addtermOld.Rd ├── anovaOld.Rd ├── clm.Rd ├── clm.anova.Rd ├── clm.control.Rd ├── clm.controlOld.Rd ├── clm.fit.Rd ├── clmOld.Rd ├── clmm.Rd ├── clmm.control.Rd ├── clmm.controlOld.Rd ├── clmmOld.Rd ├── confint.clm.Rd ├── confint.clmmOld.Rd ├── confintOld.Rd ├── convergence.clm.Rd ├── dropCoef.Rd ├── gfun.Rd ├── gumbel.Rd ├── income.Rd ├── lgamma.Rd ├── nominal.test.Rd ├── ordinal-package.Rd ├── predict.Rd ├── predictOld.Rd ├── ranef.Rd ├── slice.clm.Rd ├── soup.Rd ├── updateOld.Rd └── wine.Rd ├── misc ├── copyright_header.txt └── modify_copyright_header.R ├── old_vignettes ├── clm_intro.Rnw ├── clm_intro.pdf ├── clm_tutorial.Rnw ├── clm_tutorial.pdf └── ordinal.bib ├── ordinal.Rproj ├── src ├── get_fitted.c ├── init.c ├── links.c ├── links.h └── utilityFuns.c ├── tests ├── anova.R ├── clm.fit.R ├── clm.formula.R ├── clmm.R ├── clmm.control.R ├── clmm.formula.R ├── clmm.methods.R ├── confint.R ├── nominal.test.R ├── ranef.loading.R ├── test-all.R ├── test.clm.Theta.R ├── test.clm.convergence.R ├── test.clm.flex.link.R ├── test.clm.model.matrix.R ├── test.clm.predict.R ├── test.clm.profile.R ├── test.clm.single.anova.R ├── test.general.R ├── test.makeThresholds.R ├── test.sign.R ├── test0weights.R ├── testAnova.clm2.R ├── testCLM.R └── testthat │ ├── test-clm-formula.R │ ├── test-clm-predict.R │ ├── test-clm-profile.R │ ├── test-clm.R │ ├── test-clmm-checkRanef.R │ ├── test-contrasts.R │ ├── test-misc.R │ └── test-utils.R └── vignettes ├── clm_article.Rnw ├── clm_article_refs.bib ├── clmm2_tutorial.Rnw ├── ordinal.bib └── static_figs ├── fig-fig2.pdf ├── fig-figEqui.pdf ├── fig-figFlex.pdf ├── fig-figNom2.pdf └── fig-figSca.pdf /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^\.gitignore 4 | ^\.git$ 5 | .*~$ 6 | README.md 7 | NEWS.html 8 | .Rhistory 9 | ^\.travis.yml$ 10 | \.o$ 11 | \.so$ 12 | \.dll$ 13 | ^revdep$ 14 | ^revdep_archive 15 | ^misc$ 16 | ^old_vignettes$ 17 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | src/*.o 6 | src/*.so 7 | src/*.dll 8 | *~ 9 | revdep 10 | revdep_archive* 11 | .DS_store 12 | misc/misc.R 13 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # .travis.yml for Travis CI 2 | # https://docs.travis-ci.com/user/languages/r 3 | # https://github.com/craigcitro/r-travis/wiki/Porting-to-native-R-support-in-Travis 4 | 5 | language: r 6 | r: 7 | - oldrel 8 | - release 9 | - devel 10 | cache: packages 11 | # helpful when preparing your package for submission to CRAN 12 | warnings_are_errors: true 13 | # No need for sudo as R is natively supported now. 14 | sudo: false 15 | # r_build_args: --no-build-vignettes 16 | # r_check_args: --as-cran --no-build-vignettes 17 | 18 | # Need chicago.bst for the vignette bibliographi: 19 | before_install: 20 | - tlmgr install chicago 21 | 22 | # need to add nloptr this way to make it build in 'oldrel': 23 | addons: 24 | apt: 25 | packages: 26 | - libnlopt-dev 27 | 28 | env: 29 | global: 30 | - CRAN: http://cran.rstudio.com 31 | 32 | notifications: 33 | email: 34 | on_success: change 35 | on_failure: change 36 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: ordinal 2 | Type: Package 3 | Title: Regression Models for Ordinal Data 4 | Version: 2024.12-13 5 | Date: 2024-12-13 6 | Authors@R: person(given="Rune Haubo Bojesen", family="Christensen", 7 | email="rune.haubo@gmail.com", role=c("aut", "cre")) 8 | LazyData: true 9 | ByteCompile: yes 10 | Depends: R (>= 2.13.0), stats, methods 11 | Imports: ucminf, MASS, Matrix, numDeriv, nlme 12 | Suggests: lme4, nnet, xtable, testthat (>= 0.8), tools 13 | Description: Implementation of cumulative link (mixed) models also known 14 | as ordered regression models, proportional odds models, proportional 15 | hazards models for grouped survival times and ordered logit/probit/... 16 | models. Estimation is via maximum likelihood and mixed models are fitted 17 | with the Laplace approximation and adaptive Gauss-Hermite quadrature. 18 | Multiple random effect terms are allowed and they may be nested, crossed or 19 | partially nested/crossed. Restrictions of symmetry and equidistance can be 20 | imposed on the thresholds (cut-points/intercepts). Standard model 21 | methods are available (summary, anova, drop-methods, step, 22 | confint, predict etc.) in addition to profile methods and slice 23 | methods for visualizing the likelihood function and checking 24 | convergence. 25 | License: GPL (>= 2) 26 | NeedsCompilation: yes 27 | URL: https://github.com/runehaubo/ordinal 28 | BugReports: https://github.com/runehaubo/ordinal/issues 29 | -------------------------------------------------------------------------------- /LICENCE.note: -------------------------------------------------------------------------------- 1 | Copyrights 2 | ========== 3 | 4 | All files are copyright (C) 2011 R. H. B. Christensen with all rights 5 | assigned to R. H. B. Christensen 6 | 7 | 8 | Licence 9 | ======= 10 | 11 | This is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 or 3 of the License 14 | (at your option). 15 | 16 | This program is distributed in the hope that it will be useful, 17 | but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | GNU General Public License for more details. 20 | 21 | Files share/licenses/GPL-2 and share/licenses/GPL-3 in the R 22 | (source or binary) distribution are copies of versions 2 and 3 23 | of the 'GNU General Public License'. 24 | These can also be viewed at http://www.r-project.org/licenses/ 25 | 26 | Rune.Haubo@gmail.com 27 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | useDynLib("ordinal", .registration = TRUE) 2 | 3 | importFrom(graphics, 4 | plot, 5 | par, 6 | abline, 7 | lines, 8 | points, 9 | contour) 10 | importFrom(grDevices, 11 | dev.interactive, 12 | devAskNewPage) 13 | importFrom(utils, 14 | "combn", "packageDescription", "as.roman") 15 | importFrom(ucminf, 16 | ucminf) 17 | importFrom(numDeriv, 18 | grad, hessian) 19 | importFrom("stats", 20 | ".checkMFClasses", ".getXlevels", "AIC", 21 | "add.scope", "approx", "as.formula", "binomial", "coef", 22 | "confint", "dcauchy", "dlogis", "dnorm", "drop.scope", 23 | "drop.terms", "extractAIC", "fitted", "formula", "glm.fit", 24 | "is.empty.model", "logLik", "model.frame", "model.matrix", 25 | "model.offset", "model.response", "model.weights", 26 | "na.pass", "napredict", "naprint", "nlminb", "optim", 27 | "pcauchy", "pchisq", "pgamma", "plogis", "pnorm", 28 | "printCoefmat", "profile", "qchisq", "qlogis", "qnorm", 29 | "runif", "setNames", "spline", "terms", "update.formula", 30 | "vcov", "nobs", "delete.response", "lm.fit", "resid", "reformulate") 31 | 32 | ## importFrom(stats, 33 | ## nobs) 34 | import(methods) 35 | ## import(stats) 36 | 37 | ## importFrom(methods, 38 | ## as, 39 | ## checkAtAssignment, 40 | ## loadMethod) 41 | import(Matrix) 42 | importFrom(nlme, 43 | ranef, # also exported 44 | VarCorr) # also exported 45 | ## importFrom(numDeriv, 46 | ## hessian, 47 | ## grad) 48 | importFrom(MASS, 49 | ginv, 50 | addterm, 51 | dropterm) 52 | ## importFrom(stats, 53 | ## coef, 54 | ## confint, 55 | ## nobs, 56 | ## logLik, 57 | ## profile, 58 | ## vcov, 59 | ## extractAIC, 60 | ## anova, 61 | ## fitted## , 62 | ## ## terms 63 | ## ## update 64 | ## ) 65 | 66 | # Functions: 67 | export(clm) 68 | export(clm.fit) 69 | export(clmm) 70 | export(clm.control) 71 | export(clmm.control) 72 | export(slice) 73 | export(convergence) 74 | export(drop.coef) 75 | export(nominal_test) 76 | export(scale_test) 77 | export(condVar) 78 | export(ranef) 79 | export(VarCorr) 80 | 81 | export(gnorm, glogis, gcauchy, 82 | pgumbel, dgumbel, ggumbel, qgumbel, rgumbel, 83 | plgamma, dlgamma, glgamma ## , 84 | ## pAO, dAO, gAO, 85 | ) 86 | 87 | ## Methods: 88 | S3method(clm.fit, default) 89 | S3method(clm.fit, factor) 90 | 91 | S3method(print, clm) 92 | S3method(vcov, clm) 93 | S3method(summary, clm) 94 | S3method(print, summary.clm) 95 | 96 | S3method(convergence, clm) 97 | S3method(print, convergence.clm) 98 | 99 | S3method(slice, clm) 100 | S3method(plot, slice.clm) 101 | 102 | S3method(anova, clm) 103 | S3method(print, anova.clm) 104 | S3method(predict, clm) 105 | S3method(coef, clm) 106 | S3method(nobs, clm) 107 | S3method(coef, summary.clm) 108 | 109 | S3method(scale_test, clm) 110 | S3method(nominal_test, clm) 111 | 112 | S3method(profile, clm) 113 | S3method(confint, clm) 114 | S3method(confint, profile.clm) 115 | S3method(plot, profile.clm) 116 | 117 | S3method(logLik, clm) 118 | S3method(extractAIC, clm) 119 | S3method(model.matrix, clm) 120 | S3method(model.frame, clm) 121 | S3method(terms, clm) 122 | 123 | S3method(print, clmm) 124 | S3method(vcov, clmm) 125 | S3method(summary, clmm) 126 | S3method(print, summary.clmm) 127 | S3method(logLik, clmm) 128 | S3method(extractAIC, clmm) 129 | S3method(anova, clmm) 130 | S3method(nobs, clmm) 131 | ## S3method(profile, clmm) 132 | ## S3method(confint, profile.clmm) 133 | ## S3method(plot, profile.clmm) 134 | ## S3method(update, clmm) 135 | ## S3method(fixef, clmm) 136 | S3method(ranef, clmm) 137 | S3method(condVar, clmm) 138 | S3method(VarCorr, clmm) 139 | S3method(model.matrix, clmm) 140 | 141 | 142 | ################################################################## 143 | ### clm2 stuff: 144 | 145 | ## Functions: 146 | export(clm2) 147 | export(clmm2) 148 | export(clm2.control) 149 | export(clmm2.control) 150 | 151 | 152 | ## Methods: 153 | S3method(print, clm2) 154 | S3method(vcov, clm2) 155 | S3method(summary, clm2) 156 | S3method(print, summary.clm2) 157 | S3method(anova, clm2) 158 | S3method(predict, clm2) 159 | S3method(profile, clm2) 160 | S3method(confint, clm2) 161 | S3method(confint, profile.clm2) 162 | S3method(plot, profile.clm2) 163 | S3method(logLik, clm2) 164 | S3method(extractAIC, clm2) 165 | S3method(update, clm2) 166 | S3method(dropterm, clm2) 167 | S3method(addterm, clm2) 168 | 169 | S3method(print, clmm2) 170 | S3method(vcov, clmm2) 171 | S3method(summary, clmm2) 172 | S3method(print, summary.clmm2) 173 | S3method(anova, clmm2) 174 | S3method(profile, clmm2) 175 | S3method(confint, profile.clmm2) 176 | S3method(plot, profile.clmm2) 177 | S3method(update, clmm2) 178 | -------------------------------------------------------------------------------- /R/AO.R: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | ## 4 | ## This file is part of the ordinal package for R (*ordinal*) 5 | ## 6 | ## *ordinal* is free software: you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation, either version 2 of the License, or 9 | ## (at your option) any later version. 10 | ## 11 | ## *ordinal* is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | ## 16 | ## A copy of the GNU General Public License is available at 17 | ## and/or 18 | ## . 19 | ############################################################################# 20 | ## This file contains: 21 | ## [pdg]AO functions for the Aranda-Ordaz distribution. Here gAO is 22 | ## the gradient of the density function, dAO. The AO distribution is 23 | ## used as a flexible link function in clm2() and clmm2(). 24 | 25 | pAOR <- function(q, lambda, lower.tail = TRUE) { 26 | if(lambda < 1e-6) 27 | stop("'lambda' has to be positive. lambda = ", lambda, " was supplied") 28 | p <- 1 - (lambda * exp(q) + 1)^(-1/lambda) 29 | if(!lower.tail) 1 - p else p 30 | } 31 | 32 | pAO <- function(q, lambda, lower.tail = TRUE) 33 | .C("pAO_C", 34 | q = as.double(q), 35 | length(q), 36 | as.double(lambda[1]), 37 | as.integer(lower.tail), 38 | NAOK = TRUE)$q 39 | 40 | dAOR <- function(eta, lambda, log = FALSE) { 41 | ### exp(eta) * (lambda * exp(eta) + 1)^(-1-1/lambda) 42 | stopifnot(length(lambda) == 1 && 43 | length(log) == 1) 44 | if(lambda < 1e-6) 45 | stop("'lambda' has to be positive. lambda = ", lambda, 46 | " was supplied") 47 | log.d <- eta - (1 + 1/lambda) * log(lambda * exp(eta) + 1) 48 | if(!log) exp(log.d) else log.d 49 | } 50 | 51 | dAO <- function(eta, lambda, log = FALSE) { 52 | stopifnot(length(lambda) == 1 && 53 | length(log) == 1) 54 | .C("dAO_C", 55 | eta = as.double(eta), 56 | length(eta), 57 | as.double(lambda), 58 | as.integer(log), 59 | NAOK = TRUE)$eta 60 | } 61 | 62 | gAOR <- function(eta, lambda) { 63 | stopifnot(length(lambda) == 1) 64 | lex <- lambda * exp(eta) 65 | dAO(eta, lambda) * (1 - (1 + 1/lambda) * lex/(1 + lex)) 66 | } 67 | 68 | gAO <- function(eta, lambda) { 69 | stopifnot(length(lambda) == 1) 70 | .C("gAO_C", 71 | eta = as.double(eta), 72 | length(eta), 73 | as.double(lambda[1]), 74 | NAOK = TRUE)$eta 75 | } 76 | 77 | -------------------------------------------------------------------------------- /R/clm.Thetamat.R: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | ## 4 | ## This file is part of the ordinal package for R (*ordinal*) 5 | ## 6 | ## *ordinal* is free software: you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation, either version 2 of the License, or 9 | ## (at your option) any later version. 10 | ## 11 | ## *ordinal* is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | ## 16 | ## A copy of the GNU General Public License is available at 17 | ## and/or 18 | ## . 19 | ############################################################################# 20 | ## This file contains: 21 | ## Functions (getThetamat) to compute a table of threshold 22 | ## coefficients from model fits (clm()s) with nominal effects. 23 | 24 | getThetamat <- 25 | function(terms, alpha, assign, contrasts, tJac, xlevels, sign.nominal) 26 | ### Compute matrix of thresholds for all combinations of levels of 27 | ### factors in the nominal formula. 28 | ### 29 | ### Input: 30 | ### terms: nominal terms object 31 | ### alpha: vector of threshold parameters 32 | ### assign: attr(NOM, "assign"), where NOM is the design matrix for 33 | ### the nominal effects 34 | ### contrasts: list of contrasts for the nominal effects 35 | ### tJac: threshold Jacobian with appropriate dimnames. 36 | ### xlevels: names of levels of factors among the nominal effects. 37 | ### sign.nominal: "positive" or "negative" 38 | ### 39 | ### Output: 40 | ### Theta: data.frame of thresholds 41 | ### mf.basic: if nrow(Theta) > 1 a data.frame with factors in columns 42 | ### and all combinations of the factor levels in rows. 43 | { 44 | ## Make matrix of thresholds; Theta: 45 | Theta <- matrix(alpha, ncol=ncol(tJac), byrow=TRUE) 46 | ## Matrix with variables-by-terms: 47 | factor.table <- attr(terms, "factors") 48 | all.varnm <- rownames(factor.table) 49 | ### NOTE: need to index with all.varnm not to include (weights) and 50 | ### possibly other stuff. 51 | var.classes <- attr(terms, "dataClasses")[all.varnm] 52 | numeric.var <- which(var.classes != "factor") 53 | ### NOTE: Logical variables are treated as numeric variables. 54 | numeric.terms <- factor.terms <- numeric(0) 55 | if(length(factor.table)) { 56 | ## Terms associated with numerical variables: 57 | numeric.terms <- 58 | which(colSums(factor.table[numeric.var, , drop=FALSE]) > 0) 59 | ## Terms only involving factor variables: 60 | factor.terms <- 61 | which(colSums(factor.table[numeric.var, , drop=FALSE]) == 0) 62 | } 63 | ## Remove rows in Theta for numeric variables: 64 | if(length(numeric.terms)) { 65 | ### NOTE: ncol(NOM) == length(asgn) == nrow(Theta) 66 | ### length(attr(terms, "term.labels")) == ncol(factor.table) 67 | ### NOTE: length(var.classes) == nrow(factor.table) 68 | numeric.rows <- which(assign %in% numeric.terms) 69 | Theta <- Theta[-numeric.rows, , drop=FALSE] 70 | ## Drop terms so the design matrix, X for the factors does not 71 | ## include numeric variables: 72 | if(length(factor.terms)) 73 | terms <- drop.terms(terms, dropx=numeric.terms, 74 | keep.response=FALSE) 75 | } 76 | ## if some nominal effects are factors: 77 | if(length(factor.terms)) { 78 | ## get xlevels for factors, not ordered (factors) 79 | factor.var <- which(var.classes == "factor") 80 | factor.varnm <- names(var.classes)[factor.var] 81 | xlev <- xlevels[factor.varnm] 82 | ## minimal complete model frame: 83 | mf.basic <- do.call(expand.grid, xlev) 84 | ## minimal complete design matrix: 85 | X <- model.matrix(terms, data=mf.basic, 86 | contrasts=contrasts[factor.varnm]) 87 | ### NOTE: get_clmDesign adds an intercept if its not there, so we need 88 | ### to do that as well here. Otherwise 'X[, keep, drop=FALSE]' will 89 | ### fail: 90 | if(!"(Intercept)" %in% colnames(X)) 91 | X <- cbind("(Intercept)" = rep(1, nrow(X)), X) 92 | if(sign.nominal == "negative") X[, -1] <- -X[, -1] 93 | ### NOTE: There are no contrasts for numerical variables, but there 94 | ### may be for ordered factors. 95 | ## From threshold parameters to thresholds: 96 | ### NOTE: some rows of Theta may contain NAs due to rank deficiency of 97 | ### the NOM design matrix. 98 | keep <- apply(Theta, 1, function(x) sum(is.na(x)) == 0) 99 | ## Theta <- apply(Theta, 2, function(th) X %*% th) 100 | tmp <- lapply(1:ncol(Theta), function(i) { 101 | X[, keep, drop=FALSE] %*% Theta[keep, i] 102 | }) 103 | Theta <- do.call(cbind, tmp) 104 | } 105 | ## Adjust each row in Theta for threshold functions: 106 | tmp <- lapply(seq_len(nrow(Theta)), function(i) 107 | c(tJac %*% Theta[i, ])) 108 | Theta <- do.call(rbind, tmp) 109 | ### NOTE: apply returns a vector and not a matrix when ncol(Theta) == 110 | ### 1, so we need to avoid it here. 111 | ## Theta <- t(apply(Theta, 1, function(th) tJac %*% th)) 112 | colnames(Theta) <- rownames(tJac) 113 | res <- list(Theta = as.data.frame(Theta)) 114 | ## add factor information if any: 115 | if(NROW(Theta) > 1) res$mf.basic <- mf.basic 116 | ## return: 117 | res 118 | } 119 | -------------------------------------------------------------------------------- /R/clm.simple.R: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | ## 4 | ## This file is part of the ordinal package for R (*ordinal*) 5 | ## 6 | ## *ordinal* is free software: you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation, either version 2 of the License, or 9 | ## (at your option) any later version. 10 | ## 11 | ## *ordinal* is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | ## 16 | ## A copy of the GNU General Public License is available at 17 | ## and/or 18 | ## . 19 | ############################################################################# 20 | ## This file contains: 21 | ## A implementation of simple CLMs (simple_clm), i.e., CLMs without 22 | ## scale and nominal effects. 23 | 24 | simple_clm <- 25 | function(formula, data, weights, start, subset, offset, 26 | doFit = TRUE, na.action, contrasts, model = TRUE, 27 | control = list(), 28 | link = c("logit", "probit", "cloglog", "loglog"), 29 | threshold = c("flexible", "symmetric", "symmetric2", "equidistant"), ...) 30 | { 31 | ## Initial argument matching and testing: 32 | mc <- match.call(expand.dots = FALSE) 33 | link <- match.arg(link) 34 | threshold <- match.arg(threshold) 35 | ## check for presence of formula: 36 | if(missing(formula)) stop("Model needs a formula") 37 | if(missing(contrasts)) contrasts <- NULL 38 | ## set control parameters: 39 | control <- do.call(clm.control, c(control, list(...))) 40 | 41 | ## Compute: y, X, wts, off, mf: 42 | if (missing(data)) 43 | data <- environment(formula) 44 | mf <- match.call(expand.dots = FALSE) 45 | m <- match(c("formula", "data", "subset", "weights", "na.action", 46 | "offset"), names(mf), 0L) 47 | mf <- mf[c(1L, m)] 48 | mf$drop.unused.levels <- TRUE 49 | mf[[1L]] <- as.name("model.frame") 50 | mf <- eval(mf, parent.frame()) 51 | ## Return model.frame? 52 | if(control$method == "model.frame") return(mf) 53 | y <- model.response(mf, "any") ## any storage mode 54 | if(!is.factor(y)) stop("response needs to be a factor", call.=FALSE) 55 | ## design matrix: 56 | mt <- attr(mf, "terms") 57 | X <- if (!is.empty.model(mt)) 58 | model.matrix(mt, mf, contrasts) 59 | else cbind("(Intercept)" = rep(1, NROW(y))) 60 | ## Test for intercept in X: 61 | Xint <- match("(Intercept)", colnames(X), nomatch = 0) 62 | if(Xint <= 0) { 63 | X <- cbind("(Intercept)" = rep(1, NROW(y)), X) 64 | warning("an intercept is needed and assumed in 'formula'", 65 | call.=FALSE) 66 | } ## intercept in X is guaranteed. 67 | wts <- getWeights(mf) 68 | off <- getOffsetStd(mf) 69 | ylevels <- levels(droplevels(y[wts > 0])) 70 | frames <- list(y=y, ylevels=ylevels, X=X) 71 | 72 | ## Compute the transpose of the Jacobian for the threshold function, 73 | ## tJac and the names of the threshold parameters, alpha.names: 74 | frames <- c(frames, makeThresholds(ylevels, threshold)) 75 | ## test for column rank deficiency in design matrices: 76 | frames <- drop.cols(frames, silent=TRUE) 77 | 78 | ## Set envir rho with variables: B1, B2, o1, o2, wts, fitted: 79 | rho <- clm.newRho(parent.frame(), y=frames$y, X=frames$X, 80 | NOM=NULL, S=NULL, 81 | weights=wts, offset=off, S.offset=NULL, 82 | tJac=frames$tJac, control=control) 83 | 84 | ## Set starting values for the parameters: 85 | start <- set.start(rho, start=start, get.start=missing(start), 86 | threshold=threshold, link=link, frames=frames) 87 | rho$par <- as.vector(start) ## remove attributes 88 | 89 | ## Set pfun, dfun and gfun in rho: 90 | setLinks(rho, link) 91 | 92 | ## Possibly return the environment rho without fitting: 93 | if(!doFit) return(rho) 94 | 95 | ## Fit the clm: 96 | if(control$method == "Newton") 97 | fit <- clm_fit_NR(rho, control) 98 | else 99 | fit <- clm_fit_optim(rho, control$method, control$ctrl) 100 | ### NOTE: we could add arg non.conv = c("error", "warn", "message") to 101 | ### allow non-converged fits to be returned. 102 | 103 | ## Modify and return results: 104 | res <- clm.finalize(fit, weights=wts, 105 | coef.names=frames$coef.names, 106 | aliased=frames$aliased) 107 | res$control <- control 108 | res$link <- link 109 | res$start <- start 110 | if(control$method == "Newton" && 111 | !is.null(start.iter <- attr(start, "start.iter"))) 112 | res$niter <- res$niter + start.iter 113 | res$threshold <- threshold 114 | res$call <- match.call() 115 | res$contrasts <- attr(frames$X, "contrasts") 116 | res$na.action <- attr(mf, "na.action") 117 | res$terms <- mt 118 | res$xlevels <- .getXlevels(mt, mf) 119 | res$tJac <- frames$tJac 120 | res$y.levels <- frames$ylevels 121 | ## Check convergence: 122 | conv <- conv.check(res, Theta.ok=TRUE, tol=control$tol) 123 | print.conv.check(conv, action=control$convergence) ## print convergence message 124 | res$vcov <- conv$vcov 125 | res$cond.H <- conv$cond.H 126 | res$convergence <- conv[!names(conv) %in% c("vcov", "cond.H")] 127 | res$info <- with(res, { 128 | data.frame("link" = link, 129 | "threshold" = threshold, 130 | "nobs" = nobs, 131 | "logLik" = formatC(logLik, digits=2, format="f"), 132 | "AIC" = formatC(-2*logLik + 2*edf, digits=2, 133 | format="f"), 134 | "niter" = paste(niter[1], "(", niter[2], ")", sep=""), 135 | ### NOTE: iterations to get starting values for scale models *are* 136 | ### included here. 137 | "max.grad" = formatC(maxGradient, digits=2, 138 | format="e") 139 | ## BIC is not part of output since it is not clear what 140 | ## the no. observations are. 141 | ) 142 | }) 143 | class(res) <- "clm" 144 | ## add model.frame to results list? 145 | if(model) res$model <- mf 146 | 147 | return(res) 148 | } 149 | -------------------------------------------------------------------------------- /R/clm.start.R: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | ## 4 | ## This file is part of the ordinal package for R (*ordinal*) 5 | ## 6 | ## *ordinal* is free software: you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation, either version 2 of the License, or 9 | ## (at your option) any later version. 10 | ## 11 | ## *ordinal* is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | ## 16 | ## A copy of the GNU General Public License is available at 17 | ## and/or 18 | ## . 19 | ############################################################################# 20 | ## This file contains: 21 | ## Functions to compute starting values for CLMs in clm(). 22 | 23 | set.start <- 24 | function(rho, start=NULL, get.start=TRUE, threshold, link, frames) 25 | { 26 | ## set starting values for the parameters: 27 | nScol <- if(is.null(frames[["S"]])) 0 else ncol(frames[["S"]]) # no cols in S 28 | nSpar <- pmax(0, nScol - 1) # no Scale parameters 29 | if(get.start) { 30 | start <- ## not 'starting' scale effects: 31 | clm.start(y.levels=frames$y.levels, threshold=threshold, X=frames$X, 32 | NOM=frames$NOM, has.intercept=TRUE) 33 | if(nSpar > 0 || # NCOL(frames[["S"]]) > 1 34 | link == "cauchit" || length(rho$lambda)) { 35 | ### NOTE: only special start if nSpar > 0 (no reason for 36 | ### special start if scale is only offset and no predictors). 37 | ### NOTE: start cauchit models at the probit estimates if start is not 38 | ### supplied: 39 | ### NOTE: start models with lambda at model with probit link 40 | rho$par <- start 41 | if(link %in% c("Aranda-Ordaz", "log-gamma", "cauchit")) { 42 | setLinks(rho, link="probit") 43 | } else { 44 | setLinks(rho, link) 45 | } 46 | tempk <- rho$k 47 | rho$k <- 0 48 | ## increased gradTol and relTol: 49 | fit <- try(clm_fit_NR(rho, control=list(gradTol=1e-3, relTol=1e-3)), 50 | silent=TRUE) 51 | if(inherits(fit, "try-error")) 52 | stop("Failed to find suitable starting values: please supply some", 53 | call.=FALSE) 54 | start <- c(fit$par, rep(0, nSpar)) 55 | if(length(rho$lambda) > 0) start <- c(start, rho$lambda) 56 | attr(start, "start.iter") <- fit$niter 57 | rho$k <- tempk 58 | setLinks(rho, link) # reset link in rho 59 | } 60 | } 61 | ## test start: 62 | stopifnot(is.numeric(start)) 63 | length.start <- ncol(rho$B1) + nSpar + length(rho$lambda) 64 | if(length(start) != length.start) 65 | stop(gettextf("length of start is %d should equal %d", 66 | length(start), length.start), call.=FALSE) 67 | 68 | return(start) 69 | } 70 | 71 | start.threshold <- 72 | function(y.levels, threshold = c("flexible", "symmetric", "symmetric2", "equidistant")) 73 | ### args: 74 | ### y.levels - levels of the model response, at least of length two 75 | ### threshold - threshold structure, character. 76 | { 77 | ## match and test arguments: 78 | threshold <- match.arg(threshold) 79 | ny.levels <- length(y.levels) 80 | ntheta <- ny.levels - 1L 81 | if(threshold %in% c("symmetric", "symmetric2", "equidistant") && ny.levels < 3) 82 | stop(gettextf("symmetric and equidistant thresholds are only 83 | meaningful for responses with 3 or more levels")) 84 | 85 | ## default starting values: 86 | start <- qlogis((1:ntheta) / (ntheta + 1) ) # just a guess 87 | 88 | ## adjusting for threshold functions: 89 | if(threshold == "symmetric" && ntheta %% 2) { ## ntheta odd >= 3 90 | nalpha <- (ntheta + 1) / 2 91 | start <- c(start[nalpha], diff(start[nalpha:ntheta])) ## works for 92 | ## ntheta >= 1 93 | } 94 | if(threshold == "symmetric" && !ntheta %% 2) {## ntheta even >= 4 95 | nalpha <- (ntheta + 2) / 2 96 | start <- c(start[c(nalpha - 1, nalpha)], 97 | diff(start[nalpha:ntheta])) ## works for ntheta >= 2 98 | } 99 | if(threshold == "symmetric2" && ntheta %% 2) { ## ntheta odd >= 3 100 | nalpha <- (ntheta + 3) / 2 101 | start <- start[nalpha:ntheta] ## works for ntheta >= 3 102 | } 103 | if(threshold == "symmetric2" && !ntheta %% 2) {## ntheta even >= 4 104 | nalpha <- (ntheta + 2) / 2 105 | start <- start[nalpha:ntheta] ## works for ntheta >= 2 106 | } 107 | if(threshold == "equidistant") 108 | start <- c(start[1], mean(diff(start))) 109 | 110 | ## return starting values for the threshold parameters: 111 | return(as.vector(start)) 112 | } 113 | 114 | start.beta <- function(X, has.intercept = TRUE) 115 | return(rep(0, ncol(X) - has.intercept)) 116 | 117 | ## clm.start <- function(y.levels, threshold, X, has.intercept = TRUE) 118 | ## return(c(start.threshold(y.levels, threshold), 119 | ## start.beta(X, has.intercept))) 120 | 121 | clm.start <- function(y.levels, threshold, X, NOM=NULL, S=NULL, 122 | has.intercept=TRUE) 123 | { 124 | st <- start.threshold(y.levels, threshold) 125 | if(!is.null(NOM) && ncol(NOM) > 1) 126 | st <- c(st, rep(rep(0, length(st)), ncol(NOM)-1)) 127 | start <- c(st, start.beta(X, has.intercept)) 128 | if(!is.null(S) && ncol(S) > 1) 129 | start <- c(start, rep(0, ncol(S) - 1)) 130 | start 131 | } 132 | 133 | -------------------------------------------------------------------------------- /R/clmm.formula.R: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | ## 4 | ## This file is part of the ordinal package for R (*ordinal*) 5 | ## 6 | ## *ordinal* is free software: you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation, either version 2 of the License, or 9 | ## (at your option) any later version. 10 | ## 11 | ## *ordinal* is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | ## 16 | ## A copy of the GNU General Public License is available at 17 | ## and/or 18 | ## . 19 | ############################################################################# 20 | ## This file contains: 21 | ## Functions to process lmer-style mixed-model formulae. These 22 | ## functions are borrowed from the lme4 package but have later been 23 | ## modified. 24 | 25 | findbars <- function(term) 26 | ### Return the pairs of expressions that separated by vertical bars 27 | { 28 | if (is.name(term) || !is.language(term)) return(NULL) 29 | if (term[[1]] == as.name("(")) return(findbars(term[[2]])) 30 | if (!is.call(term)) stop("term must be of class call") 31 | if (term[[1]] == as.name('|')) return(term) 32 | if (length(term) == 2) return(findbars(term[[2]])) 33 | c(findbars(term[[2]]), findbars(term[[3]])) 34 | } 35 | 36 | nobars <- function(term) 37 | ### term - usually the third element of a formula object: formula[[3]] 38 | ### returns a list of terms 39 | 40 | ### Return the formula omitting the pairs of expressions that are 41 | ### separated by vertical bars 42 | { 43 | if (!('|' %in% all.names(term))) return(term) 44 | if (is.call(term) && term[[1]] == as.name('|')) return(NULL) 45 | if (length(term) == 2) { 46 | nb <- nobars(term[[2]]) 47 | if (is.null(nb)) return(NULL) 48 | term[[2]] <- nb 49 | return(term) 50 | } 51 | nb2 <- nobars(term[[2]]) 52 | nb3 <- nobars(term[[3]]) 53 | if (is.null(nb2)) return(nb3) 54 | if (is.null(nb3)) return(nb2) 55 | term[[2]] <- nb2 56 | term[[3]] <- nb3 57 | term 58 | } 59 | 60 | subbars <- function(term) 61 | ### Substitute the '+' function for the '|' function 62 | { 63 | if (is.name(term) || !is.language(term)) return(term) 64 | if (length(term) == 2) { 65 | term[[2]] <- subbars(term[[2]]) 66 | return(term) 67 | } 68 | stopifnot(length(term) >= 3) 69 | if (is.call(term) && term[[1]] == as.name('|')) 70 | term[[1]] <- as.name('+') 71 | for (j in 2:length(term)) term[[j]] <- subbars(term[[j]]) 72 | term 73 | } 74 | 75 | subnms <- function(term, nlist) 76 | ### Substitute any names from nlist in term with 1 77 | { 78 | if (!is.language(term)) return(term) 79 | if (is.name(term)) { 80 | if (any(unlist(lapply(nlist, get("=="), term)))) return(1) 81 | return(term) 82 | } 83 | stopifnot(length(term) >= 2) 84 | for (j in 2:length(term)) term[[j]] <- subnms(term[[j]], nlist) 85 | term 86 | } 87 | 88 | slashTerms <- function(x) 89 | ### Return the list of '/'-separated terms in an expression that 90 | ### contains slashes 91 | { 92 | if (!("/" %in% all.names(x))) return(x) 93 | if (x[[1]] != as.name("/")) 94 | stop("unparseable formula for grouping factor") 95 | list(slashTerms(x[[2]]), slashTerms(x[[3]])) 96 | } 97 | 98 | makeInteraction <- function(x) 99 | ### from a list of length 2 return recursive interaction terms 100 | { 101 | if (length(x) < 2) return(x) 102 | trm1 <- makeInteraction(x[[1]]) 103 | trm11 <- if(is.list(trm1)) trm1[[1]] else trm1 104 | list(substitute(foo:bar, list(foo=x[[2]], bar = trm11)), trm1) 105 | } 106 | 107 | expandSlash <- function(bb) 108 | ### expand any slashes in the grouping factors returned by findbars 109 | { 110 | if (!is.list(bb)) return(expandSlash(list(bb))) 111 | ## I really do mean lapply(unlist(... - unlist returns a 112 | ## flattened list in this case 113 | unlist(lapply(bb, function(x) { 114 | if (length(x) > 2 && is.list(trms <- slashTerms(x[[3]]))) 115 | return(lapply(unlist(makeInteraction(trms)), 116 | function(trm) substitute(foo|bar, 117 | list(foo = x[[2]], 118 | bar = trm)))) 119 | x 120 | })) 121 | } 122 | -------------------------------------------------------------------------------- /R/clmm.ranef.R: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | ## 4 | ## This file is part of the ordinal package for R (*ordinal*) 5 | ## 6 | ## *ordinal* is free software: you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation, either version 2 of the License, or 9 | ## (at your option) any later version. 10 | ## 11 | ## *ordinal* is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | ## 16 | ## A copy of the GNU General Public License is available at 17 | ## and/or 18 | ## . 19 | ############################################################################# 20 | ## This file contains: 21 | ## Implementation of ranef and condVar methods for clmm objects to 22 | ## extract the conditional model of the random-effects and their 23 | ## conditional variances. 24 | 25 | ## fixef.clmm <- function(object, ...) coef(object, ...) 26 | ## object$coefficients 27 | ### NOTE: Should return a *named* vector 28 | 29 | # ranef <- function(object, ...) UseMethod("ranef") 30 | ## fixef <- function(object, ...) UseMethod("fixef") 31 | 32 | ranef.clmm <- function(object, condVar=FALSE, ...) 33 | ### This function... 34 | ### args... 35 | ### Returns.... 36 | { 37 | formatRanef <- function(relist, ST, gf.levels, assign, qi) { 38 | asgn <- split(seq_along(assign), assign) 39 | ## colnames of random effects: 40 | cn <- lapply(ST, colnames) 41 | cn <- lapply(asgn, function(ii) unlist(cn[ii])) 42 | ranefList <- lapply(seq_along(relist), function(i) { 43 | matrix(relist[[i]], ncol=qi[i]) 44 | }) 45 | ## Combine r.e. terms associated with the same grouping factors, 46 | ## set dimnames and coerce to data.frame: 47 | ranefList <- lapply(seq_along(asgn), function(i) { 48 | mat <- do.call(cbind, ranefList[ asgn[[i]] ]) 49 | dimnames(mat) <- list(gf.levels[[i]], cn[[i]]) 50 | as.data.frame(mat) 51 | }) 52 | ## list of r.e. by grouping factors: 53 | names(ranefList) <- names(gflevs) 54 | ranefList 55 | } 56 | ## which r.e. terms are associated with which grouping factors: 57 | asgn <- attributes(object$gfList)$assign 58 | ## names of levels of grouping factors: 59 | gflevs <- lapply(object$gfList, levels) 60 | ## random effects indicator factor: 61 | reind <- with(object$dims, factor(rep.int(seq_len(nretrms), 62 | nlev.re * qi))) 63 | ## list of random effects by r.e. term: 64 | relist <- split(object$ranef, reind) 65 | ranefList <- formatRanef(relist, object$ST, gflevs, asgn, 66 | object$dims$qi) 67 | if(condVar) { 68 | ### OPTION: Should we return matrices for vector-valued random effects 69 | ### as lmer does? 70 | ## Add conditional variances of the random effects: 71 | cond.var <- object$condVar 72 | if(NCOL(cond.var) > 1) cond.var <- diag(cond.var) 73 | cvlist <- split(cond.var, reind) 74 | cond.var <- formatRanef(cvlist, object$ST, gflevs, asgn, 75 | object$dims$qi) 76 | for(i in seq_along(ranefList)) 77 | attr(ranefList[[i]], "condVar") <- cond.var[[i]] 78 | } 79 | ranefList 80 | } 81 | 82 | condVar <- function(object, ...) UseMethod("condVar") 83 | condVar.clmm <- function(object, ...) 84 | lapply(ranef.clmm(object, condVar=TRUE), 85 | function(y) attr(y, "condVar")) 86 | -------------------------------------------------------------------------------- /R/clmm.start.R: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | ## 4 | ## This file is part of the ordinal package for R (*ordinal*) 5 | ## 6 | ## *ordinal* is free software: you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation, either version 2 of the License, or 9 | ## (at your option) any later version. 10 | ## 11 | ## *ordinal* is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | ## 16 | ## A copy of the GNU General Public License is available at 17 | ## and/or 18 | ## . 19 | ############################################################################# 20 | ## This file contains: 21 | ## Functions to compute starting values for clmm()s. 22 | 23 | clmm.start <- function(frames, link, threshold) { 24 | ## get starting values from clm: 25 | fit <- with(frames, 26 | clm.fit(y=y, X=X, weights=wts, offset=off, link=link, 27 | threshold=threshold)) 28 | 29 | ## initialize variance parameters to zero: 30 | start <- c(fit$par, rep(0, length(frames$grList))) 31 | return(start) 32 | } 33 | 34 | -------------------------------------------------------------------------------- /R/control.R: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | ## 4 | ## This file is part of the ordinal package for R (*ordinal*) 5 | ## 6 | ## *ordinal* is free software: you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation, either version 2 of the License, or 9 | ## (at your option) any later version. 10 | ## 11 | ## *ordinal* is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | ## 16 | ## A copy of the GNU General Public License is available at 17 | ## and/or 18 | ## . 19 | ############################################################################# 20 | ## This file contains: 21 | ## Functions that set control parameters for clm() and clmm(). 22 | 23 | clm.control <- 24 | function(method = c("Newton", "model.frame", "design", "ucminf", "nlminb", 25 | "optim"), 26 | sign.location = c("negative", "positive"), 27 | sign.nominal = c("positive", "negative"), 28 | ..., trace = 0L, maxIter = 100L, gradTol = 1e-6, 29 | maxLineIter = 15L, relTol = 1e-6, tol = sqrt(.Machine$double.eps), 30 | maxModIter = 5L, 31 | convergence=c("warn", "silent", "stop", "message")) 32 | { 33 | method <- match.arg(method) 34 | convergence <- match.arg(convergence) 35 | sign.location <- match.arg(sign.location) 36 | sign.nominal <- match.arg(sign.nominal) 37 | 38 | if(!all(is.numeric(c(maxIter, gradTol, maxLineIter, relTol, tol, 39 | maxModIter)))) 40 | stop("maxIter, gradTol, relTol, tol, maxModIter and maxLineIter should all be numeric") 41 | 42 | ctrl <- list(method = method, 43 | sign.location = sign.location, 44 | sign.nominal = sign.nominal, 45 | convergence = convergence, 46 | trace = as.integer(trace), 47 | maxIter = as.integer(maxIter), 48 | gradTol = as.numeric(gradTol), 49 | relTol = as.numeric(relTol), 50 | tol = as.numeric(tol), 51 | maxLineIter = as.integer(maxLineIter), 52 | maxModIter = as.integer(maxModIter)) 53 | if(method %in% c("ucminf", "nlminb", "optim")) 54 | ctrl$ctrl <- list(trace = as.integer(abs(trace)), ...) 55 | 56 | return(ctrl) 57 | } 58 | 59 | clmm.control <- 60 | function(method = c("nlminb", "ucminf", "model.frame"), 61 | ..., trace = 0, maxIter = 50, gradTol = 1e-4, 62 | maxLineIter = 50, useMatrix = FALSE, 63 | innerCtrl = c("warnOnly", "noWarn", "giveError"), 64 | checkRanef = c("warn", "error", "message")) 65 | { 66 | method <- match.arg(method) 67 | innerCtrl <- match.arg(innerCtrl) 68 | checkRanef <- match.arg(checkRanef) 69 | useMatrix <- as.logical(useMatrix) 70 | stopifnot(is.logical(useMatrix)) 71 | ctrl <- list(trace=if(trace < 0) 1 else 0, 72 | maxIter=maxIter, 73 | gradTol=gradTol, 74 | maxLineIter=maxLineIter, 75 | innerCtrl=innerCtrl) 76 | optCtrl <- list(trace = abs(trace), ...) 77 | 78 | if(!is.numeric(unlist(ctrl[-5]))) 79 | stop("maxIter, gradTol, maxLineIter and trace should all be numeric") 80 | if(any(ctrl[-c(1, 5)] <= 0)) 81 | stop("maxIter, gradTol and maxLineIter have to be > 0") 82 | if(method == "ucminf" && !"grtol" %in% names(optCtrl)) 83 | optCtrl$grtol <- 1e-5 84 | if(method == "ucminf" && !"grad" %in% names(optCtrl)) 85 | optCtrl$grad <- "central" 86 | 87 | namedList(method, useMatrix, ctrl, optCtrl, checkRanef) 88 | } 89 | 90 | -------------------------------------------------------------------------------- /R/derivatives.R: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | ## 4 | ## This file is part of the ordinal package for R (*ordinal*) 5 | ## 6 | ## *ordinal* is free software: you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation, either version 2 of the License, or 9 | ## (at your option) any later version. 10 | ## 11 | ## *ordinal* is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | ## 16 | ## A copy of the GNU General Public License is available at 17 | ## and/or 18 | ## . 19 | ############################################################################# 20 | ## This file contains: 21 | ## Functions for finite difference computations of derivatives 22 | ## (gradient and Hessian) of user-specified functions. 23 | 24 | deriv12 <- function(fun, x, delta=1e-4, fx=NULL, ...) { 25 | ### Compute gradient and Hessian at the same time (to save computing 26 | ### time) 27 | nx <- length(x) 28 | fx <- if(!is.null(fx)) fx else fun(x, ...) 29 | stopifnot(length(fx) == 1) 30 | H <- array(NA, dim=c(nx, nx)) 31 | g <- numeric(nx) 32 | for(j in 1:nx) { 33 | ## Diagonal elements: 34 | xadd <- xsub <- x 35 | xadd[j] <- x[j] + delta 36 | xsub[j] <- x[j] - delta 37 | fadd <- fun(xadd, ...) 38 | fsub <- fun(xsub, ...) 39 | H[j, j] <- (fadd - 2 * fx + fsub) / delta^2 40 | g[j] <- (fadd - fsub) / (2 * delta) 41 | ## Off diagonal elements: 42 | for(i in 1:nx) { 43 | if(i >= j) break 44 | ## Compute upper triangular elements: 45 | xaa <- xas <- xsa <- xss <- x 46 | xaa[c(i, j)] <- x[c(i, j)] + c(delta, delta) 47 | xas[c(i, j)] <- x[c(i, j)] + c(delta, -delta) 48 | xsa[c(i, j)] <- x[c(i, j)] + c(-delta, delta) 49 | xss[c(i, j)] <- x[c(i, j)] - c(delta, delta) 50 | H[i, j] <- H[j, i] <- 51 | (fun(xaa, ...) - fun(xas, ...) - 52 | fun(xsa, ...) + fun(xss, ...)) / 53 | (4 * delta^2) 54 | } 55 | } 56 | list(gradient = g, Hessian = H) 57 | } 58 | 59 | myhess <- function(fun, x, fx=NULL, delta=1e-4, ...) { 60 | nx <- length(x) 61 | fx <- if(!is.null(fx)) fx else fun(x, ...) 62 | stopifnot(length(fx) == 1) 63 | H <- array(NA, dim=c(nx, nx)) 64 | for(j in 1:nx) { 65 | ## Diagonal elements: 66 | xadd <- xsub <- x 67 | xadd[j] <- x[j] + delta 68 | xsub[j] <- x[j] - delta 69 | H[j, j] <- (fun(xadd, ...) - 2 * fx + 70 | fun(xsub, ...)) / delta^2 71 | ## Upper triangular (off diagonal) elements: 72 | for(i in 1:nx) { 73 | if(i >= j) break 74 | xaa <- xas <- xsa <- xss <- x 75 | xaa[c(i, j)] <- x[c(i, j)] + c(delta, delta) 76 | xas[c(i, j)] <- x[c(i, j)] + c(delta, -delta) 77 | xsa[c(i, j)] <- x[c(i, j)] + c(-delta, delta) 78 | xss[c(i, j)] <- x[c(i, j)] - c(delta, delta) 79 | H[j, i] <- H[i, j] <- 80 | (fun(xaa, ...) - fun(xas, ...) - 81 | fun(xsa, ...) + fun(xss, ...)) / 82 | (4 * delta^2) 83 | } 84 | } 85 | H 86 | } 87 | 88 | mygrad <- 89 | function(fun, x, delta = 1e-4, 90 | method = c("central", "forward", "backward"), ...) 91 | { 92 | method <- match.arg(method) 93 | nx <- length(x) 94 | if(method %in% c("central", "forward")) { 95 | Xadd <- matrix(rep(x, nx), nrow=nx, byrow=TRUE) + diag(delta, nx) 96 | fadd <- apply(Xadd, 1, fun, ...) 97 | } 98 | if(method %in% c("central", "backward")) { 99 | Xsub <- matrix(rep(x, nx), nrow=nx, byrow=TRUE) - diag(delta, nx) 100 | fsub <- apply(Xsub, 1, fun, ...) ## eval.parent perhaps? 101 | } 102 | res <- switch(method, 103 | "forward" = (fadd - fun(x, ...)) / delta, 104 | "backward" = (fun(x, ...) - fsub) / delta, 105 | "central" = (fadd - fsub) / (2 * delta) 106 | ) 107 | res 108 | } 109 | 110 | grad.ctr3 <- function(fun, x, delta=1e-4, ...) { 111 | nx <- length(x) 112 | Xadd <- matrix(rep(x, nx), nrow=nx, byrow=TRUE) + diag(delta, nx) 113 | Xsub <- matrix(rep(x, nx), nrow=nx, byrow=TRUE) - diag(delta, nx) 114 | fadd <- apply(Xadd, 1, fun, ...) 115 | fsub <- apply(Xsub, 1, fun, ...) ## eval.parent perhaps? 116 | (fadd - fsub) / (2 * delta) 117 | } 118 | 119 | grad.ctr2 <- function(fun, x, delta=1e-4, ...) { 120 | ans <- x 121 | for(i in seq_along(x)) { 122 | xadd <- xsub <- x 123 | xadd[i] <- x[i] + delta 124 | xsub[i] <- x[i] - delta 125 | ans[i] <- (fun(xadd, ...) - fun(xsub, ...)) / (2 * delta) 126 | } 127 | ans 128 | } 129 | 130 | grad.ctr <- function(fun, x, delta=1e-4, ...) { 131 | sapply(seq_along(x), function(i) { 132 | xadd <- xsub <- x 133 | xadd[i] <- x[i] + delta 134 | xsub[i] <- x[i] - delta 135 | (fun(xadd, ...) - fun(xsub, ...)) / (2 * delta) 136 | }) 137 | } 138 | 139 | grad <- grad.ctr 140 | 141 | grad.ctr4 <- function(fun, x, delta=1e-4, ...) { 142 | ### - checking finiteness of x and fun-values 143 | ### - taking care to avoid floating point errors 144 | ### - not using h=x*delta rather than h=delta (important for small or 145 | ### large x?) 146 | if(!all(is.finite(x))) 147 | stop("Cannot compute gradient: non-finite argument") 148 | ans <- x ## return values 149 | for(i in seq_along(x)) { 150 | xadd <- xsub <- x ## reset fun arguments 151 | xadd[i] <- x[i] + delta 152 | xsub[i] <- x[i] - delta 153 | ans[i] <- (fun(xadd, ...) - fun(xsub, ...)) / (xadd[i] - xsub[i]) 154 | ### NOTE: xadd[i] - xsub[i] != 2*delta with floating point arithmetic. 155 | } 156 | if(!all(is.finite(ans))) { 157 | warning("cannot compute gradient: non-finite function values occured") 158 | ans[!is.finite(ans)] <- Inf 159 | } 160 | ans 161 | } 162 | 163 | 164 | -------------------------------------------------------------------------------- /R/gdist.R: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | ## 4 | ## This file is part of the ordinal package for R (*ordinal*) 5 | ## 6 | ## *ordinal* is free software: you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation, either version 2 of the License, or 9 | ## (at your option) any later version. 10 | ## 11 | ## *ordinal* is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | ## 16 | ## A copy of the GNU General Public License is available at 17 | ## and/or 18 | ## . 19 | ############################################################################# 20 | ## This file contains: 21 | ## Gradients of densities of common distribution functions on the form 22 | ## g[dist], where "dist" can be one of "logis", "norm", and 23 | ## "cauchy". These functions are used in Newton-Raphson algorithms 24 | ## when fitting CLMs and CLMMs in clm(), clm2(), clmm() and 25 | ## clmm2(). Similar gradients are implemented for the gumbel, 26 | ## log-gamma, and Aranda-Ordaz distributions. 27 | 28 | glogis <- function(x) 29 | ### gradient of dlogis 30 | .C("glogis_C", 31 | x = as.double(x), 32 | length(x), 33 | NAOK = TRUE)$x 34 | 35 | gnorm <- function(x) 36 | ### gradient of dnorm(x) wrt. x 37 | .C("gnorm_C", 38 | x = as.double(x), 39 | length(x), 40 | NAOK = TRUE)$x 41 | 42 | gcauchy <- function(x) 43 | ### gradient of dcauchy(x) wrt. x 44 | .C("gcauchy_C", 45 | x = as.double(x), 46 | length(x), 47 | NAOK = TRUE)$x 48 | 49 | glogisR <- function(x) { 50 | ### glogis in R 51 | res <- rep(0, length(x)) 52 | isFinite <- !is.infinite(x) 53 | 54 | x <- x[isFinite] 55 | isNegative <- x < 0 56 | q <- exp(-abs(x)) 57 | q <- 2*q^2*(1 + q)^-3 - q*(1 + q)^-2 58 | q[isNegative] <- -q[isNegative] 59 | res[isFinite] <- q 60 | res 61 | } 62 | 63 | gnormR <- function(x) 64 | ### gnorm in R 65 | -x * dnorm(x) 66 | 67 | gcauchyR <- function(x) 68 | ### gcauchy(x) in R 69 | -2*x/pi*(1+x^2)^-2 70 | -------------------------------------------------------------------------------- /R/gumbel.R: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | ## 4 | ## This file is part of the ordinal package for R (*ordinal*) 5 | ## 6 | ## *ordinal* is free software: you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation, either version 2 of the License, or 9 | ## (at your option) any later version. 10 | ## 11 | ## *ordinal* is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | ## 16 | ## A copy of the GNU General Public License is available at 17 | ## and/or 18 | ## . 19 | ############################################################################# 20 | ## This file contains: 21 | ## [pdqrg]gumbel functions for the gumbel distribution. 22 | ## Here ggumbel is the gradient of the density function, dgumbel. 23 | 24 | pgumbel <- 25 | function(q, location = 0, scale = 1, lower.tail = TRUE, max = TRUE) 26 | ### CDF for Gumbel max and min distributions 27 | ### Currently only unit length location and scale are supported. 28 | { 29 | if(max) ## right skew, loglog link 30 | .C("pgumbel_C", 31 | q = as.double(q), 32 | length(q), 33 | as.double(location)[1], 34 | as.double(scale)[1], 35 | as.integer(lower.tail), 36 | NAOK = TRUE)$q 37 | else ## left skew, cloglog link 38 | .C("pgumbel2_C", 39 | q = as.double(q), 40 | length(q), 41 | as.double(location)[1], 42 | as.double(scale)[1], 43 | as.integer(lower.tail), 44 | NAOK = TRUE)$q 45 | } 46 | 47 | pgumbelR <- function(q, location = 0, scale = 1, lower.tail = TRUE) 48 | ### R equivalent of pgumbel() 49 | { 50 | q <- (q - location)/scale 51 | p <- exp(-exp(-q)) 52 | if (!lower.tail) 1 - p else p 53 | } 54 | 55 | pgumbel2R <- function(q, location = 0, scale = 1, lower.tail = TRUE) 56 | { 57 | q <- (-q - location)/scale 58 | p <- exp(-exp(-q)) 59 | if (!lower.tail) p else 1 - p 60 | } 61 | 62 | dgumbel <- 63 | function(x, location = 0, scale = 1, log = FALSE, max = TRUE) 64 | ### PDF for the Gumbel max and mon distributions 65 | { 66 | if(max) ## right skew, loglog link 67 | .C("dgumbel_C", 68 | x = as.double(x), 69 | length(x), 70 | as.double(location)[1], 71 | as.double(scale)[1], 72 | as.integer(log), 73 | NAOK = TRUE)$x 74 | else ## left skew, cloglog link 75 | .C("dgumbel2_C", 76 | x = as.double(x), 77 | length(x), 78 | as.double(location)[1], 79 | as.double(scale)[1], 80 | as.integer(log), 81 | NAOK = TRUE)$x 82 | } 83 | 84 | dgumbelR <- function(x, location = 0, scale = 1, log = FALSE) 85 | ### dgumbel in R 86 | { 87 | q <- (x - location)/scale 88 | log.d <- -exp(-q) - q - log(scale) 89 | if (!log) exp(log.d) else log.d 90 | } 91 | 92 | dgumbel2R <- function(x, location = 0, scale = 1, log = FALSE) 93 | { 94 | q <- (-x - location)/scale 95 | log.d <- -exp(-q) - q - log(scale) 96 | if (!log) exp(log.d) else log.d 97 | } 98 | 99 | ggumbel <- function(x, max = TRUE) { 100 | ### gradient of dgumbel(x) wrt. x 101 | if(max) ## right skew, loglog link 102 | .C("ggumbel_C", 103 | x = as.double(x), 104 | length(x), 105 | NAOK = TRUE)$x 106 | else ## left skew, cloglog link 107 | .C("ggumbel2_C", 108 | x = as.double(x), 109 | length(x), 110 | NAOK = TRUE)$x 111 | } 112 | 113 | ggumbelR <- function(x){ 114 | ### ggumbel in R 115 | q <- exp(-x) 116 | ifelse(q == Inf, 0, { 117 | eq <- exp(-q) 118 | -eq*q + eq*q*q 119 | }) 120 | } 121 | 122 | ggumbel2R <- function(x) -ggumbelR(-x) 123 | 124 | 125 | rgumbel <- function(n, location = 0, scale = 1, max = TRUE) { 126 | if(max) 127 | location - scale * log(-log(runif(n))) 128 | else 129 | location + scale * log(-log(runif(n))) 130 | } 131 | 132 | qgumbel <- function(p, location = 0, scale = 1, lower.tail = TRUE, max = TRUE) { 133 | if(!lower.tail) p <- 1 - p 134 | if(max) ## right skew, loglog link 135 | location - scale * log(-log(p)) 136 | else ## left skew, cloglog link 137 | location + scale * log(-log(1 - p)) 138 | } 139 | -------------------------------------------------------------------------------- /R/lgamma.R: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | ## 4 | ## This file is part of the ordinal package for R (*ordinal*) 5 | ## 6 | ## *ordinal* is free software: you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation, either version 2 of the License, or 9 | ## (at your option) any later version. 10 | ## 11 | ## *ordinal* is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | ## 16 | ## A copy of the GNU General Public License is available at 17 | ## and/or 18 | ## . 19 | ############################################################################# 20 | ## This file contains: 21 | ## [pdg]lgamma functions for the log-gamma distribution [lgamma]. 22 | ## Here glgamma is the gradient of the density function, dlgamma. 23 | ## The log-gamma distribution is 24 | ## used as a flexible link function in clm2() and clmm2(). 25 | 26 | plgamma <- function(q, lambda, lower.tail = TRUE) 27 | .C("plgamma_C", 28 | q = as.double(q), 29 | length(q), 30 | as.double(lambda[1]), 31 | as.integer(lower.tail[1]), 32 | NAOK = TRUE)$q 33 | 34 | plgammaR <- function(eta, lambda, lower.tail = TRUE) { 35 | q <- lambda 36 | v <- q^(-2) * exp(q * eta) 37 | if(q < 0) 38 | p <- 1 - pgamma(v, q^(-2)) 39 | if(q > 0) 40 | p <- pgamma(v, q^(-2)) 41 | if(isTRUE(all.equal(0, q, tolerance = 1e-6))) 42 | p <- pnorm(eta) 43 | if(!lower.tail) 1 - p else p 44 | } 45 | 46 | dlgamma <- function(x, lambda, log = FALSE) { 47 | stopifnot(length(lambda) == 1 && 48 | length(log) == 1) 49 | .C("dlgamma_C", 50 | x = as.double(x), 51 | length(x), 52 | as.double(lambda), 53 | as.integer(log), 54 | NAOK = TRUE)$x 55 | } 56 | 57 | dlgammaR <- function(x, lambda, log = FALSE) { 58 | q <- lambda 59 | q.2 <- q^(-2) 60 | qx <- q * x 61 | log.d <- log(abs(q)) + q.2 * log(q.2) - 62 | lgamma(q.2) + q.2 * (qx - exp(qx)) 63 | if (!log) exp(log.d) else log.d 64 | } 65 | 66 | glgamma <- function(x, lambda) { 67 | stopifnot(length(lambda) == 1) 68 | .C("glgamma_C", 69 | x = as.double(x), 70 | length(x), 71 | as.double(lambda[1]), 72 | NAOK = TRUE)$x 73 | } 74 | 75 | glgammaR <- function(x, lambda) { 76 | stopifnot(length(lambda) == 1) 77 | (1 - exp(lambda * x))/lambda * dlgamma(x, lambda) 78 | } 79 | 80 | glgammaR2 <- function(x, lambda) { 81 | stopifnot(length(lambda == 1)) 82 | if(lambda == 0) 83 | return(gnorm(x)) 84 | y <- dlgamma(x, lambda) 85 | y[!is.na(y) && y > 0] <- y * (1 - exp(lambda * x)) 86 | return(y) 87 | } 88 | 89 | -------------------------------------------------------------------------------- /R/warning_functions.R: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | ## 4 | ## This file is part of the ordinal package for R (*ordinal*) 5 | ## 6 | ## *ordinal* is free software: you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation, either version 2 of the License, or 9 | ## (at your option) any later version. 10 | ## 11 | ## *ordinal* is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | ## 16 | ## A copy of the GNU General Public License is available at 17 | ## and/or 18 | ## . 19 | ############################################################################# 20 | givesWarnings <- function(expr) countWarnings(expr) > 0L 21 | 22 | countWarnings <- function(expr) 23 | { 24 | .number_of_warnings <- 0L 25 | frame_number <- sys.nframe() 26 | ans <- withCallingHandlers(expr, warning = function(w) { 27 | assign(".number_of_warnings", .number_of_warnings + 1L, 28 | envir = sys.frame(frame_number)) 29 | invokeRestart("muffleWarning") 30 | }) 31 | .number_of_warnings 32 | } 33 | 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ordinal 2 | R package ordinal: Regression Models for Ordinal Data 3 | 4 | [![Build Status](https://travis-ci.org/runehaubo/ordinal.svg?branch=master)](https://travis-ci.org/runehaubo/ordinal) 5 | [![cran version](http://www.r-pkg.org/badges/version/ordinal)](https://cran.r-project.org/package=ordinal) 6 | [![downloads](https://cranlogs.r-pkg.org/badges/ordinal)](https://cran.r-project.org/package=ordinal) 7 | [![total downloads](http://cranlogs.r-pkg.org/badges/grand-total/ordinal)](http://cranlogs.r-pkg.org/badges/grand-total/ordinal) 8 | [![Research software impact](http://depsy.org/api/package/cran/ordinal/badge.svg)](http://depsy.org/package/r/ordinal) 9 | -------------------------------------------------------------------------------- /data/income.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/runehaubo/ordinal/59ba5b54bff3418aafcbb2ba251fff0041d888fa/data/income.rda -------------------------------------------------------------------------------- /data/soup.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/runehaubo/ordinal/59ba5b54bff3418aafcbb2ba251fff0041d888fa/data/soup.rda -------------------------------------------------------------------------------- /data/wine.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/runehaubo/ordinal/59ba5b54bff3418aafcbb2ba251fff0041d888fa/data/wine.rda -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | year <- sub(".*(2[[:digit:]]{3})-.*", "\\1", meta$Date) 2 | vers <- paste0("R package version ", meta$Version) 3 | 4 | bibentry( 5 | 'Manual', 6 | title = 'ordinal---Regression Models for Ordinal Data', 7 | author = person("Rune H. B.", "Christensen", 8 | comment = c(ORCID = "0000-0002-4494-3399")), 9 | header = "To cite 'ordinal' in publications use:", 10 | year = year, 11 | note = vers, 12 | url = "https://CRAN.R-project.org/package=ordinal" 13 | ) 14 | 15 | 16 | -------------------------------------------------------------------------------- /man/VarCorr.Rd: -------------------------------------------------------------------------------- 1 | \name{VarCorr} 2 | \alias{VarCorr} 3 | \alias{VarCorr.clmm} 4 | %- Also NEED an '\alias' for EACH other topic documented here. 5 | \title{ 6 | Extract variance and correlation parameters 7 | } 8 | \description{ 9 | The VarCorr function extracts the variance and (if present) 10 | correlation parameters for random effect terms in a 11 | cumulative link mixed model (CLMM) fitted with \code{clmm}. 12 | } 13 | \usage{ 14 | 15 | \method{VarCorr}{clmm}(x, ...) 16 | 17 | } 18 | %- maybe also 'usage' for other objects documented here. 19 | \arguments{ 20 | \item{x}{a \code{\link{clmm}} object. 21 | } 22 | \item{\dots}{ 23 | currently not used by the \code{clmm} method. 24 | } 25 | } 26 | \details{ 27 | The \code{VarCorr} method returns a list of \code{data.frame}s; one for 28 | each distinct grouping factor. Each \code{data.frame} has as many rows 29 | as there are levels for that grouping factor and as many columns as 30 | there are random effects for each level. For example a model can 31 | contain a random intercept (one column) or a random 32 | intercept and a random slope (two columns) for the same grouping 33 | factor. 34 | 35 | If conditional variances are requested, they are returned in the same 36 | structure as the conditional modes (random effect 37 | estimates/predictions). 38 | } 39 | \value{ 40 | 41 | A list of matrices with variances in the diagonal and correlation 42 | parameters in the off-diagonal --- one matrix for each random effects term 43 | in the model. Standard deviations are provided as attributes to the 44 | matrices. 45 | 46 | } 47 | \author{ 48 | Rune Haubo B Christensen 49 | } 50 | \examples{ 51 | 52 | fm1 <- clmm(rating ~ contact + temp + (1|judge), data=wine) 53 | VarCorr(fm1) 54 | 55 | } 56 | % Add one or more standard keywords, see file 'KEYWORDS' in the 57 | % R documentation directory. 58 | \keyword{models} 59 | 60 | -------------------------------------------------------------------------------- /man/addtermOld.Rd: -------------------------------------------------------------------------------- 1 | \name{addterm.clm2} 2 | \alias{addterm.clm2} 3 | \alias{dropterm.clm2} 4 | \title{ 5 | Try all one-term additions to and deletions from a model 6 | } 7 | \description{ 8 | Try fitting all models that differ from the current model by adding or 9 | deleting a single term from those supplied while maintaining 10 | marginality. 11 | } 12 | \usage{ 13 | \method{addterm}{clm2}(object, scope, scale = 0, test = c("none", "Chisq"), 14 | k = 2, sorted = FALSE, trace = FALSE, 15 | which = c("location", "scale"), \dots) 16 | \method{dropterm}{clm2}(object, scope, scale = 0, test = c("none", "Chisq"), 17 | k = 2, sorted = FALSE, trace = FALSE, 18 | which = c("location", "scale"), \dots) 19 | } 20 | \arguments{ 21 | \item{object}{ 22 | A \code{\link{clm2}} object. 23 | } 24 | \item{scope}{ 25 | for \code{addterm}: 26 | a formula specifying a maximal model which should include the current 27 | one. All additional terms in the maximal model with all marginal terms 28 | in the original model are tried. 29 | For \code{dropterm}: 30 | a formula giving terms which might be dropped. By default, the model 31 | formula. Only terms that can be dropped and maintain marginality are 32 | actually tried. 33 | } 34 | \item{scale}{ 35 | used in the definition of the AIC statistic for selecting the 36 | models. Specifying \code{scale} asserts that the dispersion is known. 37 | } 38 | \item{test}{ 39 | should the results include a test statistic relative to the original 40 | model? The Chisq test is a likelihood-ratio test. 41 | } 42 | \item{k}{ 43 | the multiple of the number of degrees of freedom used for the penalty. 44 | Only \code{k=2} gives the genuine AIC: \code{k = log(n)} is sometimes referred 45 | to as BIC or SBC. 46 | } 47 | \item{sorted}{ 48 | should the results be sorted on the value of AIC? 49 | } 50 | \item{trace}{ 51 | if \code{TRUE} additional information may be given on the fits as they are tried. 52 | } 53 | \item{which}{should additions or deletions occur in location or scale 54 | models? 55 | } 56 | \item{\dots}{ 57 | arguments passed to or from other methods. 58 | }} 59 | \value{ 60 | A table of class \code{"anova"} containing columns for the change 61 | in degrees of freedom, AIC and the likelihood ratio statistic. If 62 | \code{test = "Chisq"} a column also contains the 63 | p-value from the Chisq test. 64 | } 65 | \details{ 66 | The definition of AIC is only up to an additive constant because the 67 | likelihood function is only defined up to an additive constant. 68 | } 69 | \author{Rune Haubo B Christensen} 70 | \seealso{ 71 | \code{\link[ordinal]{clm2}}, \code{\link[=anova.clm2]{anova}}, 72 | \code{\link[MASS]{addterm.default}} and \code{\link[MASS]{dropterm.default}} 73 | } 74 | \examples{ 75 | 76 | options(contrasts = c("contr.treatment", "contr.poly")) 77 | 78 | if(require(MASS)) { ## dropterm, addterm, housing 79 | mB1 <- clm2(SURENESS ~ PROD + GENDER + SOUPTYPE, 80 | scale = ~ COLD, data = soup, link = "probit", 81 | Hess = FALSE) 82 | dropterm(mB1, test = "Chi") # or 83 | dropterm(mB1, which = "location", test = "Chi") 84 | dropterm(mB1, which = "scale", test = "Chi") 85 | addterm(mB1, scope = ~.^2, test = "Chi", which = "location") 86 | addterm(mB1, scope = ~ . + GENDER + SOUPTYPE, 87 | test = "Chi", which = "scale") 88 | addterm(mB1, scope = ~ . + AGEGROUP + SOUPFREQ, 89 | test = "Chi", which = "location") 90 | 91 | ## Fit model from polr example: 92 | fm1 <- clm2(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) 93 | addterm(fm1, ~ Infl + Type + Cont, test= "Chisq", which = "scale") 94 | dropterm(fm1, test = "Chisq") 95 | } 96 | 97 | } 98 | \keyword{internal} 99 | -------------------------------------------------------------------------------- /man/anovaOld.Rd: -------------------------------------------------------------------------------- 1 | \name{anova.clm2} 2 | %%\alias{anova} 3 | \alias{anova.clm2} 4 | \alias{anova.clmm2} 5 | \title{Likelihood ratio test of cumulative link models} 6 | \description{ 7 | Comparison of cumulative link models in likelihood ratio tests. 8 | The models may differ by terms in location, scale and nominal 9 | formulae, in link, threshold function and random effect structure. 10 | } 11 | \usage{ 12 | \method{anova}{clm2}(object, ..., test = c("Chisq", "none")) 13 | \method{anova}{clmm2}(object, ..., test = c("Chisq", "none")) 14 | } 15 | \arguments{ 16 | \item{object}{a \code{\link{clm2}} object. 17 | } 18 | \item{\dots}{one or more additional \code{\link{clm2}} objects. 19 | } 20 | \item{test}{if \code{test = "none"} the p-value for the likelihood 21 | ratio test is suppressed. 22 | } 23 | } 24 | \value{ 25 | The method returns an object of class \code{Anova} (for printing) and 26 | \code{data.frame} with the following elements 27 | \item{Model}{character description of the cumulative link models being 28 | compared. Location, scale and nominal formulae are separated by 29 | "|"s in this order. 30 | } 31 | \item{Resid.df}{the residual degrees of freedom 32 | } 33 | \item{-2logLik}{twice the negative log likelihood (proportional to the 34 | deviance)} 35 | \item{Test}{indication of which models are being compared. 36 | } 37 | \item{DF}{the difference in the degrees of freedom in the models being 38 | compared, i.e. the degrees of freedom for the chi-squared test. 39 | } 40 | \item{LR stat.}{the likelihood ratio statistic. 41 | } 42 | \item{Pr(Chi)}{the p-value from the likelihood ratio test. Absent if 43 | \code{test = "none"}. 44 | } 45 | } 46 | \author{Rune Haubo B Christensen} 47 | \seealso{ 48 | \code{\link[ordinal]{clm2}}, \code{\link[=addterm.clm2]{addterm}}, 49 | \code{\link[ordinal:addtermOld]{dropterm}} and 50 | \code{\link[=anova]{anova.default}} 51 | } 52 | \examples{ 53 | options(contrasts = c("contr.treatment", "contr.poly")) 54 | m1 <- clm2(SURENESS ~ PROD, scale = ~PROD, data = soup, 55 | link = "logistic") 56 | 57 | ## anova 58 | anova(m1, update(m1, scale = ~.-PROD)) 59 | mN1 <- clm2(SURENESS ~ 1, nominal = ~PROD, data = soup, 60 | link = "logistic") 61 | anova(m1, mN1) 62 | anova(m1, update(m1, scale = ~.-PROD), mN1) 63 | 64 | ## Fit model from polr example: 65 | if(require(MASS)) { 66 | fm1 <- clm2(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) 67 | anova(fm1, update(fm1, scale =~ Cont)) 68 | } 69 | 70 | } 71 | \keyword{internal} 72 | -------------------------------------------------------------------------------- /man/clm.anova.Rd: -------------------------------------------------------------------------------- 1 | \name{anova.clm} 2 | %%\alias{anova} 3 | \alias{anova.clm} 4 | \title{ANODE Tables and Likelihood ratio test of cumulative link models} 5 | \description{ 6 | Type I, II, and III analysis of deviance (ANODE) tables for 7 | cumulative link models and 8 | comparison of cumulative link models with likelihood ratio tests. 9 | Models may differ by terms in location, scale and nominal 10 | formulae, in link, threshold function. 11 | } 12 | \usage{ 13 | \method{anova}{clm}(object, ..., type = c("I", "II", "III", "1", "2", "3")) 14 | } 15 | \arguments{ 16 | \item{object}{a \code{\link{clm}} object. 17 | } 18 | \item{\dots}{optionally one or more additional \code{\link{clm}} objects. 19 | } 20 | \item{type}{the type of hypothesis test if \code{anova} is called with a 21 | single model; ignored if more than one model is passed to the method. 22 | } 23 | } 24 | \details{ 25 | The ANODE table returned when \code{anova} is called with a single model apply only to 26 | terms in \code{formula}, that is, terms in \code{nominal} and \code{scale} are 27 | ignored. 28 | } 29 | \value{ 30 | An analysis of deviance table based on Wald chi-square test if called with a 31 | single model and a comparison of 32 | models with likelihood ratio tests if called with more than one model. 33 | } 34 | \author{Rune Haubo B Christensen} 35 | \seealso{ 36 | \code{\link[ordinal]{clm}} 37 | } 38 | \examples{ 39 | 40 | ## Analysis of deviance tables with Wald chi-square tests: 41 | fm <- clm(rating ~ temp * contact, scale=~contact, data=wine) 42 | anova(fm, type="I") 43 | anova(fm, type="II") 44 | anova(fm, type="III") 45 | 46 | options(contrasts = c("contr.treatment", "contr.poly")) 47 | m1 <- clm2(SURENESS ~ PROD, scale = ~PROD, data = soup, 48 | link = "logistic") 49 | 50 | ## anova 51 | anova(m1, update(m1, scale = ~.-PROD)) 52 | mN1 <- clm2(SURENESS ~ 1, nominal = ~PROD, data = soup, 53 | link = "logistic") 54 | anova(m1, mN1) 55 | anova(m1, update(m1, scale = ~.-PROD), mN1) 56 | 57 | ## Fit model from polr example: 58 | if(require(MASS)) { 59 | fm1 <- clm2(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) 60 | anova(fm1, update(fm1, scale =~ Cont)) 61 | } 62 | 63 | } 64 | \keyword{models} 65 | -------------------------------------------------------------------------------- /man/clm.control.Rd: -------------------------------------------------------------------------------- 1 | \name{clm.control} 2 | \alias{clm.control} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{Set control parameters for cumulative link models} 5 | \description{ 6 | Set control parameters for cumulative link models 7 | } 8 | \usage{ 9 | clm.control(method = c("Newton", "model.frame", "design", "ucminf", "nlminb", 10 | "optim"), 11 | sign.location = c("negative", "positive"), 12 | sign.nominal = c("positive", "negative"), 13 | ..., trace = 0L, 14 | maxIter = 100L, gradTol = 1e-06, maxLineIter = 15L, relTol = 1e-6, 15 | tol = sqrt(.Machine$double.eps), maxModIter = 5L, 16 | convergence = c("warn", "silent", "stop", "message")) 17 | } 18 | %- maybe also 'usage' for other objects documented here. 19 | \arguments{ 20 | \item{method}{\code{"Newton"} fits the model by maximum likelihood and 21 | \code{"model.frame"} cause \code{\link{clm}} to return the 22 | \code{model.frame}, \code{"design"} causes \code{\link{clm}} to 23 | return a list of design matrices etc. that can be used with 24 | \code{\link{clm.fit}}. \code{ucminf}, \code{nlminb} and \code{optim} refer 25 | to general purpose optimizers. 26 | } 27 | \item{sign.location}{change sign of the location part of the model. 28 | } 29 | \item{sign.nominal}{change sign of the nominal part of the model. 30 | } 31 | \item{trace}{numerical, if \code{> 0} information is printed about and during 32 | the optimization process. Defaults to \code{0}. 33 | } 34 | \item{maxIter}{the maximum number of Newton-Raphson iterations. 35 | Defaults to \code{100}. 36 | } 37 | \item{gradTol}{the maximum absolute gradient; defaults to \code{1e-6}. 38 | } 39 | \item{maxLineIter}{the maximum number of step halfings allowed if 40 | a Newton(-Raphson) step over shoots. Defaults to \code{15}. 41 | } 42 | \item{relTol}{relative convergence tolerence: relative change in the 43 | parameter estimates between Newton iterations. Defaults to \code{1e-6}. 44 | } 45 | \item{tol}{numerical tolerence on eigenvalues to determine 46 | negative-definiteness of Hessian. If the Hessian of a model fit is 47 | negative definite, the fitting algorithm did not converge. If the 48 | Hessian is singular, the fitting algorithm did converge albeit not 49 | to a \emph{unique} optimum, so one or more parameters are not 50 | uniquely determined even though the log-likelihood value is. 51 | } 52 | \item{maxModIter}{the maximum allowable number of consecutive 53 | iterations where the Newton step needs to be modified to be a decent 54 | direction. Defaults to \code{5}. 55 | } 56 | \item{convergence}{action to take if the fitting algorithm did not 57 | converge. 58 | } 59 | \item{\dots}{control arguments parsed on to \code{\link[ucminf]{ucminf}}, 60 | \code{\link{nlminb}} or \code{\link{optim}}. 61 | } 62 | } 63 | \value{ 64 | a list of control parameters. 65 | } 66 | \author{Rune Haubo B Christensen} 67 | \seealso{ 68 | \code{\link{clm}} 69 | } 70 | \keyword{models} 71 | -------------------------------------------------------------------------------- /man/clm.controlOld.Rd: -------------------------------------------------------------------------------- 1 | \name{clm2.control} 2 | \alias{clm2.control} 3 | \title{Set control parameters for cumulative link models} 4 | \description{ 5 | Set control parameters for cumulative link models 6 | } 7 | \usage{ 8 | clm2.control(method = c("ucminf", "Newton", "nlminb", "optim", 9 | "model.frame"), ..., convTol = 1e-4, 10 | trace = 0, maxIter = 100, gradTol = 1e-5, 11 | maxLineIter = 10) 12 | } 13 | \arguments{ 14 | \item{method}{ 15 | the optimizer used to maximize the likelihood 16 | function. \code{"Newton"} only works for models without \code{scale}, 17 | structured thresholds and flexible link functions, 18 | but is considerably faster than the other 19 | optimizers when applicable. \code{model.frame} simply returns a list 20 | of model frames with the location, scale and nominal model 21 | frames. \code{"optim"} uses the \code{"BFGS"} method. 22 | } 23 | \item{\dots}{control arguments passed on to the chosen optimizer; see 24 | \code{\link[ucminf]{ucminf}}, \code{\link{optim}}, and 25 | \code{\link{nlminb}} for details. 26 | } 27 | \item{convTol}{convergence criterion on the size of the maximum 28 | absolute gradient. 29 | } 30 | \item{trace}{numerical, if > 0 information is printed about and during 31 | the optimization process. Defaults to \code{0}. 32 | } 33 | \item{maxIter}{the maximum number of Newton-Raphson iterations. 34 | Defaults to \code{100}. 35 | } 36 | \item{gradTol}{the maximum absolute gradient. This is the termination 37 | criterion and defaults to \code{1e-5}. 38 | } 39 | \item{maxLineIter}{the maximum number of step halfings allowed if 40 | a Newton(-Raphson) step over shoots. Defaults to \code{10}. 41 | } 42 | } 43 | \value{ 44 | a list of control parameters. 45 | } 46 | \author{Rune Haubo B Christensen} 47 | \seealso{ 48 | \code{\link{clm2}} 49 | } 50 | \keyword{models} 51 | -------------------------------------------------------------------------------- /man/clm.fit.Rd: -------------------------------------------------------------------------------- 1 | \name{clm.fit} 2 | \alias{clm.fit} 3 | \alias{clm.fit.default} 4 | \alias{clm.fit.factor} 5 | %- Also NEED an '\alias' for EACH other topic documented here. 6 | \title{ 7 | Fit Cumulative Link Models 8 | %% ~~function to do ... ~~ 9 | } 10 | \description{ 11 | A direct fitter of cumulative link models. 12 | } 13 | \usage{ 14 | 15 | clm.fit(y, ...) 16 | 17 | \method{clm.fit}{default}(y, ...) 18 | 19 | \method{clm.fit}{factor}(y, X, S, N, weights = rep(1, nrow(X)), 20 | offset = rep(0, nrow(X)), S.offset = rep(0, nrow(X)), 21 | control = list(), start, doFit=TRUE, 22 | link = c("logit", "probit", "cloglog", "loglog", "cauchit", 23 | "Aranda-Ordaz", "log-gamma"), 24 | threshold = c("flexible", "symmetric", "symmetric2", "equidistant"), 25 | ...) 26 | 27 | } 28 | %- maybe also 'usage' for other objects documented here. 29 | \arguments{ 30 | \item{y}{for the default method a list of model components. For the 31 | factor method the response variable; a factor, preferably and ordered 32 | factor. 33 | } 34 | \item{X, S, N}{optional design matrices for the regression parameters, 35 | scale parameters and nominal parameters respectively. 36 | } 37 | \item{weights}{optional case weights. 38 | } 39 | \item{offset}{an optional offset. 40 | } 41 | \item{S.offset}{an optional offset for the scale part of the model. 42 | } 43 | \item{control}{a list of control parameters, optionally a call to 44 | \code{\link{clm.control}}. 45 | } 46 | \item{start}{an optional list of starting values of the form 47 | \code{c(alpha, beta, zeta)} for the thresholds and nominal effects 48 | (\code{alpha}), regression parameters (\code{beta}) and scale 49 | parameters (\code{zeta}). 50 | } 51 | \item{doFit}{logical for whether the model should be fit or the model 52 | environment should be returned. 53 | } 54 | \item{link}{the link function. 55 | } 56 | \item{threshold}{the threshold structure, see further at 57 | \code{\link{clm}}. 58 | } 59 | \item{\dots}{currently not used.} 60 | } 61 | \details{ 62 | This function does almost the same thing that \code{\link{clm}} does: 63 | it fits a cumulative link model. The main differences are that 64 | \code{clm.fit} does not setup design matrices from formulae and only 65 | does minimal post processing after parameter estimation. 66 | 67 | Compared to \code{\link{clm}}, \code{clm.fit} does little to warn the 68 | user of any problems with data or model. However, \code{clm.fit} will 69 | attempt to identify column rank defecient designs. Any unidentified 70 | parameters are indicated in the \code{aliased} component of the fit. 71 | 72 | \code{clm.fit.factor} is not able to check if all thresholds are 73 | increasing when nominal effects are specified since it needs access to 74 | the terms object for the nominal model. If the terms object for the 75 | nominal model (\code{nom.terms}) is included in \code{y}, the default 76 | method is able to chech if all thresholds are increasing. 77 | 78 | %% In contrast to \code{\link{clm}}, \code{clm.fit} allows non-positive 79 | %% weights. 80 | } 81 | 82 | \value{ 83 | A list with the following components: 84 | \code{aliased, alpha, coefficients, cond.H, convergence, df.residual, 85 | edf, fitted.values, gradient, Hessian, logLik, maxGradient, message, 86 | n, niter, nobs, tJac, vcov} 87 | and optionally 88 | \code{beta, zeta} 89 | These components are documented in \code{\link{clm}}. 90 | } 91 | %% \references{ bla 92 | %% %% ~put references to the literature/web site here ~ 93 | %% } 94 | \author{ 95 | Rune Haubo B Christensen 96 | } 97 | %% \note{ bla 98 | %% %% ~~further notes~~ 99 | %% } 100 | %% 101 | %% %% ~Make other sections like Warning with \section{Warning }{....} ~ 102 | %% 103 | \seealso{ 104 | \code{\link{clm}} 105 | } 106 | \examples{ 107 | 108 | ## A simple example: 109 | fm1 <- clm(rating ~ contact + temp, data=wine) 110 | summary(fm1) 111 | ## get the model frame containing y and X: 112 | mf1 <- update(fm1, method="design") 113 | names(mf1) 114 | res <- clm.fit(mf1$y, mf1$X) ## invoking the factor method 115 | stopifnot(all.equal(coef(res), coef(fm1))) 116 | names(res) 117 | 118 | ## Fitting with the default method: 119 | mf1$control$method <- "Newton" 120 | res2 <- clm.fit(mf1) 121 | stopifnot(all.equal(coef(res2), coef(fm1))) 122 | 123 | } 124 | % Add one or more standard keywords, see file 'KEYWORDS' in the 125 | % R documentation directory. 126 | \keyword{models} 127 | -------------------------------------------------------------------------------- /man/clmm.control.Rd: -------------------------------------------------------------------------------- 1 | \name{clmm.control} 2 | \alias{clmm.control} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Set control parameters for cumulative link mixed models 6 | } 7 | \description{ 8 | Set control parameters for cumulative link mixed models 9 | } 10 | \usage{ 11 | clmm.control(method = c("nlminb", "ucminf", "model.frame"), ..., trace = 0, 12 | maxIter = 50, gradTol = 1e-4, maxLineIter = 50, useMatrix = FALSE, 13 | innerCtrl = c("warnOnly", "noWarn", "giveError"), 14 | checkRanef = c("warn", "error", "message")) 15 | } 16 | %- maybe also 'usage' for other objects documented here. 17 | \arguments{ 18 | \item{method}{ 19 | the optimizer used to maximize the marginal likelihood function. 20 | } 21 | \item{\dots}{control arguments passed on to the optimizer; see 22 | \code{\link[ucminf]{ucminf}} for details. 23 | \code{ucminf} for details. 24 | } 25 | \item{trace}{numerical, if > 0 information is printed about and during 26 | the outer optimization process, if < 0 information is also printed 27 | about the inner optimization process. Defaults to \code{0}. 28 | } 29 | \item{maxIter}{the maximum number of Newton updates of the inner 30 | optimization. \code{50}. 31 | } 32 | \item{gradTol}{the maximum absolute gradient of the inner 33 | optimization. 34 | } 35 | \item{maxLineIter}{the maximum number of step halfings allowed if 36 | a Newton(-Raphson) step over shoots during the inner optimization. 37 | } 38 | \item{useMatrix}{if \code{TRUE}, a general implementation of the 39 | Laplace approximation using the Matrix package is used, while if 40 | \code{FALSE} (default), a C implementation of the Laplace 41 | approximation valid only for models with a single random effects 42 | term is used when possible. 43 | \code{TRUE} is not valid for models fitted with quadrature methods. 44 | } 45 | \item{innerCtrl}{the use of warnings/errors if the inner optimization 46 | fails to converge. 47 | } 48 | \item{checkRanef}{the use of message/warning/error if there are more random 49 | effects than observations. 50 | } 51 | } 52 | \value{ 53 | a list of control parameters 54 | } 55 | \author{ 56 | Rune Haubo B Christensen 57 | } 58 | \seealso{ 59 | \code{\link{clmm}} 60 | } 61 | \keyword{models} 62 | 63 | -------------------------------------------------------------------------------- /man/clmm.controlOld.Rd: -------------------------------------------------------------------------------- 1 | \name{clmm2.control} 2 | \alias{clmm2.control} 3 | \title{Set control parameters for cumulative link mixed models} 4 | \description{ 5 | Set control parameters for cumulative link mixed models 6 | } 7 | \usage{ 8 | clmm2.control(method = c("ucminf", "nlminb", "model.frame"), ..., 9 | trace = 0, maxIter = 50, gradTol = 1e-4, 10 | maxLineIter = 50, 11 | innerCtrl = c("warnOnly", "noWarn", "giveError")) 12 | } 13 | \arguments{ 14 | \item{method}{ 15 | the optimizer used to maximize the marginal likelihood function. 16 | } 17 | \item{\dots}{control arguments passed on to the chosen optimizer; see 18 | \code{\link[ucminf]{ucminf}}, \code{\link{optim}}, and 19 | \code{\link{nlminb}} for details. 20 | } 21 | \item{trace}{numerical, if > 0 information is printed about and during 22 | the outer optimization process, if < 0 information is also printed 23 | about the inner optimization process. Defaults to \code{0}. 24 | } 25 | \item{maxIter}{the maximum number of Newton updates of the inner 26 | optimization. \code{50}. 27 | } 28 | \item{gradTol}{the maximum absolute gradient of the inner 29 | optimization. 30 | } 31 | \item{maxLineIter}{the maximum number of step halfings allowed if 32 | a Newton(-Raphson) step over shoots during the inner optimization. 33 | } 34 | \item{innerCtrl}{the use of warnings/errors if the inner optimization 35 | fails to converge. 36 | } 37 | } 38 | \details{ 39 | When the default optimizer, \code{ucminf} is used, the default values 40 | of that optimizers control options are changed to \code{grtol = 1e-5} 41 | and \code{grad = "central"}. 42 | } 43 | \value{ 44 | a list of control parameters. 45 | } 46 | \author{Rune Haubo B Christensen} 47 | \seealso{ 48 | \code{\link{clmm2}} 49 | } 50 | \keyword{models} 51 | -------------------------------------------------------------------------------- /man/confint.clm.Rd: -------------------------------------------------------------------------------- 1 | \name{confint} 2 | \alias{confint.clm} 3 | \alias{confint.profile.clm} 4 | \alias{profile.clm} 5 | \alias{plot.profile.clm} 6 | \title{ 7 | Confidence intervals and profile likelihoods for parameters in 8 | cumulative link models 9 | } 10 | \description{ 11 | Computes confidence intervals from the profiled likelihood for one or 12 | more parameters in a cumulative link model, or plots the 13 | profile likelihood. 14 | } 15 | \usage{ 16 | 17 | \method{confint}{clm}(object, parm, level = 0.95, 18 | type = c("profile", "Wald"), trace = FALSE, ...) 19 | 20 | \method{confint}{profile.clm}(object, parm = seq_len(nprofiles), 21 | level = 0.95, ...) 22 | 23 | \method{profile}{clm}(fitted, which.beta = seq_len(nbeta), 24 | which.zeta = seq_len(nzeta), alpha = 0.001, 25 | max.steps = 50, nsteps = 8, trace = FALSE, step.warn = 5, 26 | control = list(), ...) 27 | 28 | \method{plot}{profile.clm}(x, which.par = seq_len(nprofiles), 29 | level = c(0.95, 0.99), Log = FALSE, relative = TRUE, root = 30 | FALSE, fig = TRUE, approx = root, n = 1e3, 31 | ask = prod(par("mfcol")) < length(which.par) && dev.interactive(), 32 | ..., ylim = NULL) 33 | } 34 | \arguments{ 35 | \item{object, fitted, x}{ 36 | a fitted \code{\link{clm}} object or a \code{profile.clm} object. 37 | } 38 | \item{parm, which.par, which.beta, which.zeta}{ 39 | a numeric or character vector indicating which regression 40 | coefficients should be profiled. By default all coefficients are 41 | profiled. Ignored for \code{confint.clm} where all parameters are 42 | considered. 43 | } 44 | \item{level}{ 45 | the confidence level. For the \code{plot} method a vector of levels 46 | for which horizontal lines should be drawn. 47 | } 48 | \item{type}{ 49 | the type of confidence interval. 50 | } 51 | \item{trace}{ 52 | if \code{trace} is \code{TRUE} or positive, information about 53 | progress is printed. 54 | } 55 | \item{Log}{ 56 | should the profile likelihood be plotted on the log-scale? 57 | } 58 | \item{relative}{ 59 | should the relative or the absolute likelihood be plotted? 60 | } 61 | \item{root}{ 62 | should the (approximately linear) likelihood root statistic be 63 | plotted? 64 | } 65 | \item{approx}{ 66 | should the Gaussian or quadratic approximation to the (log) 67 | likelihood be included? 68 | } 69 | \item{fig}{ 70 | should the profile likelihood be plotted? 71 | } 72 | \item{ask}{ 73 | logical; if \code{TRUE}, the user is asked before each plot, see 74 | \code{\link{par}}\code{(ask=.)}. 75 | } 76 | \item{n}{ 77 | the no. points used in the spline interpolation of the profile 78 | likelihood. 79 | } 80 | \item{ylim}{overrules default y-limits on the plot of the profile 81 | likelihood. 82 | } 83 | \item{alpha}{ 84 | the likelihood is profiled in the 100*(1-alpha)\% confidence region 85 | as determined by the profile likelihood. 86 | } 87 | \item{control}{ 88 | a list of control parameters for \code{\link{clm}}. Possibly use 89 | \code{\link{clm.control}} to set these. 90 | } 91 | %%\item{lambda}{ 92 | %% logical. Should profile or confidence intervals be computed for the 93 | %% link function parameter? Only used when one of the flexible link 94 | %% functions are used; see the \code{link}-argument in 95 | %% \code{\link{clm}}. 96 | %%} 97 | \item{max.steps}{ 98 | the maximum number of profiling steps in each direction for each 99 | parameter. 100 | } 101 | \item{nsteps}{ 102 | the (approximate) number of steps to take in each direction of the 103 | profile for each parameter. 104 | The step length is determined accordingly assuming a quadratic 105 | approximation to the log-likelihood function. 106 | The actual number of steps will often be close to \code{nsteps}, but 107 | will deviate when the log-likelihood functions is irregular. 108 | } 109 | \item{step.warn}{ 110 | a warning is issued if the number of steps in each 111 | direction (up or down) for a parameter is less than 112 | \code{step.warn}. If few steps are taken, the profile will be 113 | unreliable and derived confidence intervals will be inaccurate. 114 | } 115 | \item{\dots}{ 116 | additional arguments to be parsed on to methods. 117 | } 118 | 119 | } 120 | \value{ 121 | \code{confint}: 122 | A matrix with columns giving lower and upper confidence 123 | limits for each parameter. These will be labelled as (1-level)/2 and 124 | 1 - (1-level)/2 in \% (by default 2.5\% and 97.5\%). 125 | 126 | \code{plot.profile.clm} invisibly returns the profile object, i.e., a 127 | list of \code{\link{data.frame}}s with an \code{lroot} component for 128 | the likelihood root statistic and a matrix \code{par.vals} with 129 | values of the parameters. 130 | } 131 | \details{ 132 | These \code{confint} methods call 133 | the appropriate profile method, then finds the 134 | confidence intervals by interpolation of the profile traces. 135 | If the profile object is already available, this should be used as the 136 | main argument rather than the fitted model object itself. 137 | } 138 | \author{Rune Haubo B Christensen} 139 | \seealso{ 140 | \code{\link{profile}} and \code{\link{confint}} 141 | } 142 | \examples{ 143 | 144 | ## Accurate profile likelihood confidence intervals compared to the 145 | ## conventional Wald intervals: 146 | fm1 <- clm(rating ~ temp * contact, data = wine) 147 | confint(fm1) ## type = "profile" 148 | confint(fm1, type = "Wald") 149 | pr1 <- profile(fm1) 150 | confint(pr1) 151 | 152 | ## plotting the profiles: 153 | par(mfrow = c(2, 2)) 154 | plot(pr1, root = TRUE) ## check for linearity 155 | par(mfrow = c(2, 2)) 156 | plot(pr1) 157 | par(mfrow = c(2, 2)) 158 | plot(pr1, approx = TRUE) 159 | par(mfrow = c(2, 2)) 160 | plot(pr1, Log = TRUE) 161 | par(mfrow = c(2, 2)) 162 | plot(pr1, Log = TRUE, relative = FALSE) 163 | ## Not likely to be useful but allowed for completeness: 164 | par(mfrow = c(2, 2)) 165 | plot(pr1, Log = FALSE, relative = FALSE) 166 | 167 | ## Example from polr in package MASS: 168 | ## Fit model from polr example: 169 | if(require(MASS)) { 170 | fm1 <- clm(Sat ~ Infl + Type + Cont, weights = Freq, 171 | data = housing) 172 | pr1 <- profile(fm1) 173 | confint(pr1) 174 | par(mfrow=c(2,2)) 175 | plot(pr1) 176 | } 177 | 178 | } 179 | \keyword{models} 180 | -------------------------------------------------------------------------------- /man/confint.clmmOld.Rd: -------------------------------------------------------------------------------- 1 | \name{profile.clmm2} 2 | \alias{profile.clmm2} 3 | \alias{confint.clmm2} 4 | \alias{confint.profile.clmm2} 5 | \alias{profile.clmm2} 6 | \alias{plot.profile.clmm2} 7 | \title{ 8 | Confidence intervals and profile likelihoods for the standard 9 | deviation for the random term in cumulative link mixed models 10 | } 11 | \description{ 12 | Computes confidence intervals from the profiled likelihood for 13 | the standard devation for the random term in a fitted cumulative link 14 | mixed model, or plots the associated profile likelihood function. 15 | } 16 | \usage{ 17 | \method{confint}{profile.clmm2}(object, parm = seq_along(Pnames), level = 0.95, \dots) 18 | 19 | \method{profile}{clmm2}(fitted, alpha = 0.01, range, nSteps = 20, trace = 1, \dots) 20 | 21 | \method{plot}{profile.clmm2}(x, parm = seq_along(Pnames), level = c(0.95, 0.99), 22 | Log = FALSE, relative = TRUE, fig = TRUE, n = 1e3, ..., ylim = NULL) 23 | } 24 | \arguments{ 25 | \item{object}{ 26 | a fitted \code{profile.clmm2} object. 27 | } 28 | \item{fitted}{ 29 | a fitted \code{\link{clmm2}} object. 30 | } 31 | \item{x}{a \code{profile.clmm2} object. 32 | } 33 | \item{parm}{ 34 | For \code{confint.profile.clmm2}: 35 | a specification of which parameters are to be given confidence 36 | intervals, either a vector of numbers or a vector of names. If 37 | missing, all parameters are considered. 38 | Currently only \code{"stDev"} or \code{1} are supported. 39 | 40 | For \code{plot.profile.clmm2}: 41 | a specification of which parameters the profile likelihood are to be 42 | plotted for, either a vector of numbers or a vector of names. If 43 | missing, all parameters are considered. 44 | Currently only \code{"stDev"} or \code{1} are supported. 45 | } 46 | \item{level}{ 47 | the confidence level required. Observe that the model has to be 48 | profiled in the appropriate region; otherwise the limits are 49 | \code{NA}. 50 | } 51 | \item{trace}{ 52 | logical. Should profiling be traced? Defaults to \code{TRUE} due to 53 | the time consuming nature of the computation. 54 | } 55 | \item{alpha}{Determines the range of profiling. By default the 56 | likelihood is profiled approximately in the 99\% confidence interval 57 | region as determined by the Wald approximation. This is usually 58 | sufficient for 95\% profile likelihood confidence limits. 59 | } 60 | \item{range}{if range is specified, this overrules the range 61 | computation based on \code{alpha}. \code{range} should be all 62 | positive and \code{stDev} is profiled in \code{range(range)}. 63 | } 64 | \item{nSteps}{the number of points at which to profile the likelihood 65 | function. This determines the resolution and accuracy of the profile 66 | likelihood function; higher values gives a higher resolution, but 67 | also longer computation times. 68 | } 69 | \item{Log}{should the profile likelihood be plotted on the log-scale? 70 | } 71 | \item{relative}{should the relative or the absolute likelihood be 72 | plotted? 73 | } 74 | \item{fig}{should the profile likelihood be plotted? 75 | } 76 | \item{n}{the no. points used in the spline interpolation of the 77 | profile likelihood for plotting. 78 | } 79 | \item{ylim}{overrules default y-limits on the plot of the profile 80 | likelihood. 81 | } 82 | \item{\dots}{ 83 | additional argument(s), e.g. graphical parameters for the 84 | \code{plot} method. 85 | } 86 | 87 | } 88 | \details{ 89 | A \code{confint.clmm2} method deliberately does not exist due to the 90 | time consuming nature of the computations. The user is required to 91 | compute the profile object first and then call \code{confint} on the 92 | profile object to obtain profile likelihood confidence intervals. 93 | 94 | In \code{plot.profile.clm2}: at least one of \code{Log} and 95 | \code{relative} arguments have to be \code{TRUE}. 96 | } 97 | \value{ 98 | \code{confint}: 99 | A matrix with columns giving lower and upper confidence 100 | limits. These will be labelled as (1-level)/2 and 101 | 1 - (1-level)/2 in \% (by default 2.5\% and 97.5\%). 102 | 103 | \code{plot.profile.clm2} invisibly returns the profile object. 104 | } 105 | \author{Rune Haubo B Christensen} 106 | \seealso{ 107 | \code{\link{profile}} and \code{\link{confint}} 108 | } 109 | \examples{ 110 | options(contrasts = c("contr.treatment", "contr.poly")) 111 | 112 | if(require(lme4)) { ## access cbpp data 113 | cbpp2 <- rbind(cbpp[,-(2:3)], cbpp[,-(2:3)]) 114 | cbpp2 <- within(cbpp2, { 115 | incidence <- as.factor(rep(0:1, each=nrow(cbpp))) 116 | freq <- with(cbpp, c(incidence, size - incidence)) 117 | }) 118 | 119 | ## Fit with Laplace approximation: 120 | fm1 <- clmm2(incidence ~ period, random = herd, weights = freq, 121 | data = cbpp2, Hess = 1) 122 | 123 | pr.fm1 <- profile(fm1) 124 | confint(pr.fm1) 125 | 126 | par(mfrow = c(2,2)) 127 | plot(pr.fm1) 128 | plot(pr.fm1, Log=TRUE, relative = TRUE) 129 | plot(pr.fm1, Log=TRUE, relative = FALSE) 130 | } 131 | 132 | } 133 | \keyword{models} 134 | -------------------------------------------------------------------------------- /man/convergence.clm.Rd: -------------------------------------------------------------------------------- 1 | \name{convergence} 2 | \alias{convergence} 3 | \alias{convergence.clm} 4 | \alias{print.convergence.clm} 5 | \title{Check convergence of cumulative link models} 6 | \description{ 7 | Check the accuracy of the parameter estimates of cumulative link 8 | models. The number of correct decimals and number of significant 9 | digits is given for the maximum likelihood estimates of the parameters 10 | in a cumulative link model fitted with \code{\link{clm}}. 11 | } 12 | \usage{ 13 | 14 | convergence(object, ...) 15 | 16 | \method{convergence}{clm}(object, digits = max(3, getOption("digits") - 3), 17 | tol = sqrt(.Machine$double.eps), ...) 18 | 19 | } 20 | \arguments{ 21 | \item{object}{for the \code{clm} method an object of class 22 | \code{"clm"}, i.e., the result of a call to \code{clm}. 23 | } 24 | \item{digits}{the number of digits in the printed table. 25 | } 26 | \item{tol}{numerical tolerence to judge if the Hessian is positive 27 | definite from its smallest eigenvalue. 28 | } 29 | \item{...}{arguments to a from methods. Not used by the \code{clm} method. 30 | } 31 | } 32 | \value{ 33 | Convergence information. In particular a table where the \code{Error} 34 | column gives the numerical error in the parameter estimates. These 35 | numbers express how far the parameter estimates in the fitted model 36 | are from the true maximum likelihood estimates for this 37 | model. The \code{Cor.Dec} gives the number of correct decimals with 38 | which the the parameters are determined and the \code{Sig.Dig} gives 39 | the number of significant digits with which the parameters are 40 | determined. 41 | 42 | The number denoted \code{logLik.error} is the error in the value of 43 | log-likelihood in the fitted model at the parameter values of that 44 | fit. An accurate determination of the log-likelihood is essential for 45 | accurate likelihood ratio tests in model comparison. 46 | } 47 | \details{ 48 | The number of correct decimals is defined as... 49 | 50 | The number of significant digits is defined as ... 51 | 52 | The number of correct decimals and the number of significant digits 53 | are determined from the numerical errors in the parameter 54 | estimates. The numerical errors are determined from the Method 55 | Independent Error Theorem (Elden et al, 2004) and is based on the 56 | Newton step evaluated at convergence. 57 | 58 | } 59 | \references{ 60 | Elden, L., Wittmeyer-Koch, L. and Nielsen, H. B. (2004) \emph{Introduction 61 | to Numerical Computation --- analysis and Matlab illustrations.} 62 | Studentliteratur. 63 | } 64 | %% \seealso{ 65 | %% } 66 | \examples{ 67 | 68 | ## Simple model: 69 | fm1 <- clm(rating ~ contact + temp, data=wine) 70 | summary(fm1) 71 | convergence(fm1) 72 | 73 | } 74 | \author{Rune Haubo B Christensen} 75 | \keyword{models} 76 | -------------------------------------------------------------------------------- /man/dropCoef.Rd: -------------------------------------------------------------------------------- 1 | \name{drop.coef} 2 | \alias{drop.coef} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Ensure Full Rank Design Matrix 6 | } 7 | \description{ 8 | Coefficients (columns) are dropped from a design matrix to ensure that 9 | it has full rank. 10 | } 11 | \usage{ 12 | drop.coef(X, silent = FALSE) 13 | } 14 | %- maybe also 'usage' for other objects documented here. 15 | \arguments{ 16 | \item{X}{ 17 | a design matrix, e.g., the result of \code{\link{model.matrix}} 18 | possibly of less than full column rank, i.e., with redundant 19 | parameters. Works for \code{ncol(X) >= 0} and \code{nrow(X) >= 0}. 20 | } 21 | \item{silent}{ 22 | should a message not be issued if X is column rank deficient? 23 | } 24 | } 25 | \details{ 26 | Redundant columns of the design matrix are identified with the 27 | LINPACK implementation of the \code{\link{qr}} decomposition and 28 | removed. The returned design matrix will have \code{qr(X)$rank} 29 | columns. 30 | } 31 | \value{ 32 | The design matrix \code{X} without redundant columns. 33 | } 34 | \author{ 35 | Rune Haubo B Christensen 36 | } 37 | \seealso{ 38 | \code{\link{qr}} and \code{\link{lm}} 39 | } 40 | \examples{ 41 | 42 | X <- model.matrix( ~ PRODID * DAY, data = soup) 43 | ncol(X) 44 | newX <- drop.coef(X) 45 | ncol(newX) 46 | 47 | ## Essentially this is being computed: 48 | qr.X <- qr(X, tol = 1e-7, LAPACK = FALSE) 49 | newX <- X[, qr.X$pivot[1:qr.X$rank], drop = FALSE] 50 | ## is newX of full column rank? 51 | ncol(newX) == qr(newX)$rank 52 | ## the number of columns being dropped: 53 | ncol(X) - ncol(newX) 54 | 55 | } 56 | % Add one or more standard keywords, see file 'KEYWORDS' in the 57 | % R documentation directory. 58 | \keyword{models} 59 | 60 | -------------------------------------------------------------------------------- /man/gfun.Rd: -------------------------------------------------------------------------------- 1 | \name{gfun} 2 | \alias{gnorm} 3 | \alias{glogis} 4 | \alias{gcauchy} 5 | %- Also NEED an '\alias' for EACH other topic documented here. 6 | \title{ 7 | Gradients of common densities 8 | %% ~~function to do ... ~~ 9 | } 10 | \description{ 11 | Gradients of common density functions in their standard forms, i.e., 12 | with zero location (mean) and unit scale. These are implemented in C 13 | for speed and care is taken that the correct results are provided for 14 | the argument being \code{NA}, \code{NaN}, \code{Inf}, \code{-Inf} or 15 | just extremely small or large. 16 | %% ~~ A concise (1-5 lines) description of what the function does. ~~ 17 | } 18 | \usage{ 19 | 20 | gnorm(x) 21 | 22 | glogis(x) 23 | 24 | gcauchy(x) 25 | 26 | } 27 | %- maybe also 'usage' for other objects documented here. 28 | \arguments{ 29 | \item{x}{ 30 | numeric vector of quantiles. 31 | } 32 | } 33 | \details{ 34 | The gradients are given by: 35 | \itemize{ 36 | \item{gnorm: If \eqn{f(x)} is the normal density with mean 0 and 37 | spread 1, then the gradient is \deqn{f'(x) = -x f(x)} 38 | } 39 | \item{glogis: If \eqn{f(x)} is the logistic density with mean 0 and 40 | scale 1, then the gradient is 41 | \deqn{f'(x) = 2 \exp(-x)^2 (1 + \exp(-x))^{-3} - 42 | \exp(-x)(1+\exp(-x))^{-2}} 43 | } 44 | \item{pcauchy: If 45 | \eqn{f(x) = [\pi(1 + x^2)^2]^{-1}}{f(x) =1 / [pi (1 + x^2)^2]} 46 | is the cauchy density with mean 0 and scale 1, then the gradient 47 | is 48 | \deqn{f'(x) = -2x [\pi(1 + x^2)^2]^{-1}}{f'(x) = -2x / [pi (1 + 49 | x^2)^2]} 50 | } 51 | } 52 | 53 | These gradients are used in the Newton-Raphson algorithms in fitting 54 | cumulative link models with \code{\link{clm}} and cumulative link 55 | mixed models with \code{\link{clmm}}. 56 | } 57 | \value{ 58 | a numeric vector of gradients. 59 | } 60 | \seealso{ 61 | Gradients of densities are also implemented for the extreme value 62 | distribtion (\code{\link[=dgumbel]{gumbel}}) and the the log-gamma distribution 63 | (\code{\link[=lgamma]{log-gamma}}). 64 | } 65 | \author{ 66 | Rune Haubo B Christensen 67 | } 68 | \examples{ 69 | 70 | x <- -5:5 71 | gnorm(x) 72 | glogis(x) 73 | gcauchy(x) 74 | 75 | } 76 | \keyword{distribution} 77 | 78 | -------------------------------------------------------------------------------- /man/gumbel.Rd: -------------------------------------------------------------------------------- 1 | \name{gumbel} 2 | \alias{dgumbel} 3 | \alias{pgumbel} 4 | \alias{qgumbel} 5 | \alias{rgumbel} 6 | \alias{ggumbel} 7 | \title{ 8 | The Gumbel Distribution 9 | %% ~~function to do ... ~~ 10 | } 11 | \description{ 12 | Density, distribution function, quantile function, random generation, 13 | and gradient of density of the extreme 14 | value (maximum and minimum) distributions. The Gumbel distribution is 15 | also known as the extreme value maximum distribution, the 16 | double-exponential distribution and the log-Weibull distribution. 17 | %% ~~ A concise (1-5 lines) description of what the function does. ~~ 18 | } 19 | \usage{ 20 | 21 | dgumbel(x, location = 0, scale = 1, log = FALSE, max = TRUE) 22 | 23 | pgumbel(q, location = 0, scale = 1, lower.tail = TRUE, max = TRUE) 24 | 25 | qgumbel(p, location = 0, scale = 1, lower.tail = TRUE, max = TRUE) 26 | 27 | rgumbel(n, location = 0, scale = 1, max = TRUE) 28 | 29 | ggumbel(x, max = TRUE) 30 | 31 | } 32 | %- maybe also 'usage' for other objects documented here. 33 | \arguments{ 34 | \item{x,q}{ 35 | numeric vector of quantiles. 36 | } 37 | \item{p}{ 38 | vector of probabilities. 39 | } 40 | \item{n}{ 41 | number of observations. 42 | } 43 | \item{location}{ 44 | numeric scalar. 45 | } 46 | \item{scale}{ 47 | numeric scalar. 48 | } 49 | \item{lower.tail}{ 50 | logical; if \code{TRUE} (default), probabilities are 51 | \eqn{P[X \leq x]}{P[X <= x]} otherwise, \eqn{P[X > x]}. 52 | } 53 | \item{log}{ 54 | logical; if \code{TRUE}, probabilities p are given as log(p). 55 | } 56 | \item{max}{ 57 | distribution for extreme maxima (default) or minima? The default 58 | corresponds to the standard right-skew Gumbel distribution. 59 | } 60 | } 61 | \details{ 62 | 63 | \code{dgumbel}, \code{pgumbel} and \code{ggumbel} are implemented in C 64 | for speed and care is taken that 'correct' results are provided for 65 | values of \code{NA}, \code{NaN}, \code{Inf}, \code{-Inf} or just 66 | extremely small or large. 67 | 68 | The distribution functions, densities and gradients are used in the 69 | Newton-Raphson algorithms in fitting cumulative link models with 70 | \code{\link{clm}} and cumulative link mixed models with 71 | \code{\link{clmm}}. 72 | } 73 | \value{ 74 | \code{pgumbel} gives the distribution function, \code{dgumbel} 75 | gives the density, \code{ggumbel} gives the gradient of the 76 | density, \code{qgumbel} is the quantile function, and 77 | \code{rgumbel} generates random deviates. 78 | } 79 | \references{ 80 | \url{https://en.wikipedia.org/wiki/Gumbel_distribution} 81 | } 82 | \seealso{ 83 | Gradients of densities are also implemented for the normal, logistic, 84 | cauchy, cf. \code{\link[=gnorm]{gfun}} and the log-gamma distribution, 85 | cf. \code{\link{lgamma}}. 86 | } 87 | \author{ 88 | Rune Haubo B Christensen 89 | } 90 | \examples{ 91 | 92 | ## Illustrating the symmetry of the distribution functions: 93 | pgumbel(5) == 1 - pgumbel(-5, max=FALSE) ## TRUE 94 | dgumbel(5) == dgumbel(-5, max=FALSE) ## TRUE 95 | ggumbel(5) == -ggumbel(-5, max=FALSE) ## TRUE 96 | 97 | ## More examples: 98 | x <- -5:5 99 | 100 | (pp <- pgumbel(x)) 101 | qgumbel(pp) 102 | dgumbel(x) 103 | ggumbel(x) 104 | 105 | (ppp <- pgumbel(x, max=FALSE)) 106 | ## Observe that probabilities close to 0 are more accurately determined than 107 | ## probabilities close to 1: 108 | qgumbel(ppp, max=FALSE) 109 | dgumbel(x, max=FALSE) 110 | ggumbel(x, max=FALSE) 111 | 112 | ## random deviates: 113 | set.seed(1) 114 | (r1 <- rgumbel(10)) 115 | set.seed(1) 116 | r2 <- -rgumbel(10, max = FALSE) 117 | all(r1 == r2) ## TRUE 118 | 119 | } 120 | \keyword{distribution} 121 | 122 | -------------------------------------------------------------------------------- /man/income.Rd: -------------------------------------------------------------------------------- 1 | \name{income} 2 | \alias{income} 3 | \title{ 4 | Income distribution (percentages) in the Northeast US 5 | } 6 | \description{ 7 | Income distribution (percentages) in the Northeast US in 1960 and 1970 8 | adopted from McCullagh (1980). 9 | } 10 | \usage{ 11 | income 12 | } 13 | \format{ 14 | \describe{ 15 | \item{\code{year}}{ 16 | year. 17 | } 18 | \item{\code{pct}}{ 19 | percentage of population in income class per year. 20 | } 21 | \item{\code{income}}{ 22 | income groups. The unit is thousands of constant (1973) US dollars. 23 | } 24 | } 25 | } 26 | \source{ 27 | Data are adopted from McCullagh (1980). 28 | } 29 | \references{ 30 | McCullagh, P. (1980) Regression Models for Ordinal Data. \emph{Journal 31 | of the Royal Statistical Society. Series B (Methodological)}, 32 | Vol. 42, No. 2., pp. 109-142. 33 | } 34 | \examples{ 35 | 36 | print(income) 37 | 38 | ## Convenient table: 39 | (tab <- xtabs(pct ~ year + income, income)) 40 | 41 | ## small rounding error in 1970: 42 | rowSums(tab) 43 | 44 | ## compare link functions via the log-likelihood: 45 | links <- c("logit", "probit", "cloglog", "loglog", "cauchit") 46 | sapply(links, function(link) { 47 | clm(income ~ year, data=income, weights=pct, link=link)$logLik }) 48 | ## a heavy tailed (cauchy) or left skew (cloglog) latent distribution 49 | ## is fitting best. 50 | 51 | ## The data are defined as: 52 | income.levels <- c(0, 3, 5, 7, 10, 12, 15) 53 | income <- paste(income.levels, c(rep("-", 6), "+"), 54 | c(income.levels[-1], ""), sep = "") 55 | income <- 56 | data.frame(year=factor(rep(c("1960", "1970"), each = 7)), 57 | pct = c(6.5, 8.2, 11.3, 23.5, 15.6, 12.7, 22.2, 58 | 4.3, 6, 7.7, 13.2, 10.5, 16.3, 42.1), 59 | income=factor(rep(income, 2), ordered=TRUE, 60 | levels=income)) 61 | 62 | } 63 | 64 | \keyword{datasets} 65 | -------------------------------------------------------------------------------- /man/lgamma.Rd: -------------------------------------------------------------------------------- 1 | \name{lgamma} 2 | \alias{plgamma} 3 | \alias{dlgamma} 4 | \alias{glgamma} 5 | %- Also NEED an '\alias' for EACH other topic documented here. 6 | \title{ 7 | The log-gamma distribution 8 | %% ~~function to do ... ~~ 9 | } 10 | \description{ 11 | Density, distribution function and gradient of density for the 12 | log-gamma distribution. 13 | These are implemented in C 14 | for speed and care is taken that the correct results are provided for 15 | values of \code{NA}, \code{NaN}, \code{Inf}, \code{-Inf} or just 16 | extremely small or large values. 17 | 18 | The log-gamma is a flexible location-scale distribution on the real 19 | line with an extra parameter, \eqn{\lambda}. For \eqn{\lambda = 0} the 20 | distribution equals the normal or Gaussian distribution, and for 21 | \eqn{\lambda} equal to 1 and -1, the Gumbel minimum and maximum 22 | distributions are obtained. 23 | %% ~~ A concise (1-5 lines) description of what the function does. ~~ 24 | } 25 | \usage{ 26 | 27 | plgamma(q, lambda, lower.tail = TRUE) 28 | 29 | dlgamma(x, lambda, log = FALSE) 30 | 31 | glgamma(x, lambda) 32 | 33 | } 34 | %- maybe also 'usage' for other objects documented here. 35 | \arguments{ 36 | \item{x,q}{ 37 | numeric vector of quantiles. 38 | } 39 | \item{lambda}{ 40 | numerical scalar 41 | } 42 | %% \item{location}{ 43 | %% numeric scalar. 44 | %% } 45 | %% \item{scale}{ 46 | %% numeric scalar. 47 | %% } 48 | \item{lower.tail}{ 49 | logical; if \code{TRUE} (default), probabilities are 50 | \eqn{P[X \leq x]}{P[X <= x]} otherwise, \eqn{P[X > x]}. 51 | } 52 | \item{log}{ 53 | logical; if \code{TRUE}, probabilities p are given as log(p). 54 | } 55 | } 56 | \details{ 57 | If \eqn{\lambda < 0} the distribution is right skew, if 58 | \eqn{\lambda = 0} the distribution is symmetric (and equals the normal 59 | distribution), and if \eqn{\lambda > 0} the distribution is left 60 | skew. 61 | % 62 | % The log-gamma distribution function is defined as \ldots pending. 63 | % 64 | % The density and gradient of the density are defined as\ldots pending. 65 | 66 | These distribution functions, densities and gradients are used in the 67 | Newton-Raphson algorithms in fitting cumulative link models with 68 | \code{\link{clm2}} and cumulative link mixed models with 69 | \code{\link{clmm2}} using the log-gamma link. 70 | } 71 | \value{ 72 | \code{plgamma} gives the distribution function, \code{dlgamma} 73 | gives the density and \code{glgamma} gives the gradient of the 74 | density. 75 | } 76 | \references{ 77 | Genter, F. C. and Farewell, V. T. (1985) Goodness-of-link testing in 78 | ordinal regression models. \emph{The Canadian Journal of Statistics}, 79 | 13(1), 37-44. 80 | } 81 | \seealso{ 82 | Gradients of densities are also implemented for the normal, logistic, 83 | cauchy, cf. \code{\link[=gnorm]{gfun}} and the Gumbel distribution, 84 | cf. \code{\link[=dgumbel]{gumbel}}. 85 | } 86 | \author{ 87 | Rune Haubo B Christensen 88 | } 89 | \examples{ 90 | 91 | ## Illustrating the link to other distribution functions: 92 | x <- -5:5 93 | plgamma(x, lambda = 0) == pnorm(x) 94 | all.equal(plgamma(x, lambda = -1), pgumbel(x)) ## TRUE, but: 95 | plgamma(x, lambda = -1) == pgumbel(x) 96 | plgamma(x, lambda = 1) == pgumbel(x, max = FALSE) 97 | 98 | dlgamma(x, lambda = 0) == dnorm(x) 99 | dlgamma(x, lambda = -1) == dgumbel(x) 100 | dlgamma(x, lambda = 1) == dgumbel(x, max = FALSE) 101 | 102 | glgamma(x, lambda = 0) == gnorm(x) 103 | all.equal(glgamma(x, lambda = -1), ggumbel(x)) ## TRUE, but: 104 | glgamma(x, lambda = -1) == ggumbel(x) 105 | all.equal(glgamma(x, lambda = 1), ggumbel(x, max = FALSE)) ## TRUE, but: 106 | glgamma(x, lambda = 1) == ggumbel(x, max = FALSE) 107 | ## There is a loss of accuracy, but the difference is very small: 108 | glgamma(x, lambda = 1) - ggumbel(x, max = FALSE) 109 | 110 | ## More examples: 111 | x <- -5:5 112 | plgamma(x, lambda = .5) 113 | dlgamma(x, lambda = .5) 114 | glgamma(x, lambda = .5) 115 | 116 | } 117 | \keyword{distribution} 118 | 119 | -------------------------------------------------------------------------------- /man/nominal.test.Rd: -------------------------------------------------------------------------------- 1 | \name{nominal_test} 2 | \alias{nominal_test} 3 | \alias{scale_test} 4 | \alias{nominal_test.clm} 5 | \alias{scale_test.clm} 6 | \title{ 7 | Likelihood ratio tests of model terms in scale and nominal formulae 8 | } 9 | \description{ 10 | Add all model terms to scale and nominal formulae and perform 11 | likelihood ratio tests. These tests can be viewed as goodness-of-fit 12 | tests. With the logit link, \code{nominal_test} provides likelihood 13 | ratio tests of the proportional odds assumption. The \code{scale_test} 14 | tests can be given a similar interpretation. 15 | } 16 | \usage{ 17 | nominal_test(object, ...) 18 | 19 | \method{nominal_test}{clm}(object, scope, trace=FALSE, ...) 20 | 21 | scale_test(object, ...) 22 | 23 | \method{scale_test}{clm}(object, scope, trace=FALSE, ...) 24 | 25 | } 26 | \arguments{ 27 | \item{object}{for the \code{clm} method an object of class 28 | \code{"clm"}, i.e., the result of a call to \code{clm}. 29 | } 30 | \item{scope}{ 31 | a formula or character vector specifying the terms to add to scale 32 | or nominal. In \code{nominal_test} terms in scope already in 33 | \code{nominal} are ignored. In \code{scale_test} terms in scope 34 | already in \code{scale} are ignored. 35 | 36 | In \code{nominal_test} the default is to add all terms 37 | from \code{formula} (location part) and \code{scale} that are not 38 | also in \code{nominal}. 39 | 40 | In \code{scale_test} the default is to add 41 | all terms from \code{formula} (location part) that are not also in 42 | \code{scale}. 43 | } 44 | \item{trace}{ 45 | if \code{TRUE} additional information may be given on the fits as 46 | they are tried. 47 | } 48 | \item{\dots}{ 49 | arguments passed to or from other methods. 50 | } 51 | } 52 | \value{ 53 | A table of class \code{"anova"} containing columns for the change 54 | in degrees of freedom, AIC, the likelihood ratio statistic and a 55 | p-value based on the asymptotic chi-square distribtion of the 56 | likelihood ratio statistic under the null hypothesis. 57 | } 58 | \details{ 59 | The definition of AIC is only up to an additive constant because the 60 | likelihood function is only defined up to an additive constant. 61 | } 62 | \author{Rune Haubo B Christensen} 63 | \examples{ 64 | 65 | ## Fit cumulative link model: 66 | fm <- clm(rating ~ temp + contact, data=wine) 67 | summary(fm) 68 | ## test partial proportional odds assumption for temp and contact: 69 | nominal_test(fm) 70 | ## no evidence of non-proportional odds. 71 | ## test if there are signs of scale effects: 72 | scale_test(fm) 73 | ## no evidence of scale effects. 74 | 75 | ## tests of scale and nominal effects for the housing data from MASS: 76 | if(require(MASS)) { 77 | fm1 <- clm(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) 78 | scale_test(fm1) 79 | nominal_test(fm1) 80 | ## Evidence of multiplicative/scale effect of 'Cont'. This is a breach 81 | ## of the proportional odds assumption. 82 | } 83 | 84 | } 85 | \keyword{models} 86 | -------------------------------------------------------------------------------- /man/ordinal-package.Rd: -------------------------------------------------------------------------------- 1 | \name{ordinal-package} 2 | \alias{ordinal-package} 3 | \alias{ordinal} 4 | \docType{package} 5 | \title{ 6 | Regression Models for Ordinal Data via Cumulative Link (Mixed) Models 7 | } 8 | \description{ 9 | This package facilitates analysis of ordinal (ordered categorical 10 | data) via cumulative link models (CLMs) and cumulative link mixed 11 | models (CLMMs). Robust and efficient computational methods gives 12 | speedy and accurate estimation. A wide range of methods for model fits 13 | aids the data analysis. 14 | } 15 | \details{ 16 | \tabular{ll}{ 17 | Package: \tab ordinal\cr 18 | Type: \tab Package\cr 19 | License: \tab GPL (>= 2)\cr 20 | LazyLoad: \tab yes\cr 21 | } 22 | 23 | This package implements cumualtive link models and cumulative link 24 | models with normally distributed random effects, denoted cumulative link 25 | mixed (effects) models. Cumulative link models are also known as ordered 26 | regression models, proportional odds models, proportional hazards models 27 | for grouped survival times and ordered logit/probit/... models. 28 | 29 | Cumulative link models are fitted with \code{\link{clm}} and the main 30 | features are: 31 | \itemize{ 32 | \item{A range of standard link functions are available.} 33 | \item{In addition to the standard location (additive) effects, scale 34 | (multiplicative) effects are also allowed.} 35 | \item{nominal effects are allowed for any subset of the predictors --- 36 | these effects are also known as partial proportional odds effects 37 | when using the logit link.} 38 | \item{Restrictions can be imposed on the thresholds/cut-points, e.g., 39 | symmetry or equidistance.} 40 | \item{A (modified) Newton-Raphson algorithm provides the maximum 41 | likelihood estimates of the parameters. The estimation scheme is robust, 42 | fast and accurate.} 43 | \item{Rank-deficient designs are identified and unidentified 44 | coefficients exposed in \code{print} and \code{summary} methods as 45 | with \code{\link{glm}}.} 46 | \item{A suite of standard methods are available including \code{anova}, 47 | \code{add}/\code{drop}-methods, \code{step}, \code{profile}, 48 | \code{confint}.} 49 | \item{A \code{slice} method facilitates illustration of 50 | the likelihood function and a \code{convergence} method summarizes 51 | the accuracy of the model estimation.} 52 | \item{The \code{predict} method can predict probabilities, response 53 | class-predictions and cumulative probabilities, and it provides 54 | standard errors and confidence intervals for the predictions.} 55 | } 56 | 57 | Cumulative link mixed models are fitted with \code{\link{clmm}} and the 58 | main features are: 59 | \itemize{ 60 | \item{Any number of random effect terms can be included.} 61 | \item{The syntax for the model formula resembles that of \code{\link[lme4]{lmer}} from the \code{lme4} package.} 62 | \item{Nested random effects, crossed random effects and partially 63 | nested/crossed random effects are allowed.} 64 | \item{Estimation is via maximum likelihood using the Laplace 65 | approximation or adaptive Gauss-Hermite quadrature (one random 66 | effect).} 67 | \item{Vector-valued and correlated random effects such as random 68 | slopes (random coefficient models) are fitted with the Laplace 69 | approximation.} 70 | \item{Estimation employs sparse matrix methods from the 71 | \code{\link[Matrix]{Matrix}} package. } 72 | \item{During model fitting a Newton-Raphson algorithm updates the 73 | conditional modes of the random effects a large number of times. The 74 | likelihood function is optimized with a general purpose optimizer.} 75 | } 76 | 77 | A major update of the package in August 2011 introduced new and improved 78 | implementations of \code{\link{clm}} and \code{\link{clmm}}. The old 79 | implementations are available with \code{\link{clm2}} and 80 | \code{\link{clmm2}}. At the time of writing there is functionality in 81 | \code{clm2} and \code{clmm2} not yet available in \code{clm} and 82 | \code{clmm}. This includes flexible link functions (log-gamma and 83 | Aranda-Ordaz links) and a profile method for random effect variance 84 | parameters in CLMMs. The new implementations are expected to take over 85 | the old implementations at some point, hence the latter will eventually 86 | be \code{\link[=.Deprecated]{deprecated}} and 87 | \code{\link[=.Defunct]{defunct}}. 88 | 89 | } 90 | \author{ 91 | Rune Haubo B Christensen 92 | 93 | Maintainer: Rune Haubo B Christensen 94 | } 95 | %% \references{ 96 | %% ~~ Literature or other references for background information ~~ 97 | %% } 98 | \keyword{ package } 99 | %% \seealso{ 100 | %% ~~ Optional links to other man pages, e.g. ~~ 101 | %% %% ~~ \code{\link[:-package]{}} ~~ 102 | %% } 103 | \examples{ 104 | 105 | ## A simple cumulative link model: 106 | fm1 <- clm(rating ~ contact + temp, data=wine) 107 | summary(fm1) 108 | 109 | ## A simple cumulative link mixed model: 110 | fmm1 <- clmm(rating ~ contact + temp + (1|judge), data=wine) 111 | summary(fmm1) 112 | 113 | } 114 | -------------------------------------------------------------------------------- /man/predict.Rd: -------------------------------------------------------------------------------- 1 | \name{predict.clm} 2 | \alias{predict.clm} 3 | \title{Predict Method for CLM fits} 4 | \description{ 5 | Obtains predictions from a cumulative link model. 6 | } 7 | \usage{ 8 | 9 | \method{predict}{clm}(object, newdata, se.fit = FALSE, interval = FALSE, 10 | level = 0.95, 11 | type = c("prob", "class", "cum.prob", "linear.predictor"), 12 | na.action = na.pass, ...) 13 | 14 | } 15 | \arguments{ 16 | \item{object}{a fitted object of class inheriting from 17 | \code{clm}.} 18 | \item{newdata}{optionally, a data frame in which to look for variables 19 | with which to predict. Note that all predictor variables should be 20 | present having the same names as the variables used to fit the 21 | model. If the response variable is present in \code{newdata} 22 | predictions are obtained for the levels of the response as given by 23 | \code{newdata}. If the response variable is omitted from 24 | \code{newdata} predictions are obtained for all levels of the 25 | response variable for each of the rows of \code{newdata}. 26 | } 27 | \item{se.fit}{should standard errors of the predictions be provided? 28 | Not applicable and ignored when \code{type = "class"}. 29 | } 30 | \item{interval}{should confidence intervals for the predictions be 31 | provided? Not applicable and ignored when \code{type = "class"}. 32 | } 33 | \item{level}{the confidence level. 34 | } 35 | \item{type}{the type of predictions. \code{"prob"} gives 36 | probabilities, \code{"class"} gives predicted response class 37 | membership defined as highest probability prediction, 38 | \code{"cum.prob"} gives cumulative probabilities (see details) 39 | and \code{"linear.predictor"} gives predictions on the scale of the 40 | linear predictor including the boundary categories. 41 | } 42 | \item{na.action}{function determining what should be done with missing 43 | values in \code{newdata}. The default is to predict \code{NA}. 44 | } 45 | \item{\dots}{further arguments passed to or from other methods. 46 | } 47 | } 48 | \details{ 49 | 50 | If \code{newdata} is omitted and \code{type = "prob"} a vector of 51 | fitted probabilities are returned identical to the result from 52 | \code{fitted}. 53 | 54 | If \code{newdata} is supplied and the response 55 | variable is omitted, then predictions, standard errors and intervals 56 | are matrices rather than vectors with the same number of rows as 57 | \code{newdata} and with one column for each response class. If 58 | \code{type = "class"} predictions are always a vector. 59 | 60 | If \code{newdata} is omitted, the way missing values in the original fit are handled 61 | is determined by the \code{na.action} argument of that fit. If 62 | \code{na.action = na.omit} omitted cases will not appear in the 63 | residuals, whereas if \code{na.action = na.exclude} 64 | they will appear (in predictions, standard 65 | errors or interval limits), with residual value \code{NA}. See also 66 | \code{\link{napredict}}. 67 | 68 | If \code{type = "cum.prob"} or \code{type = "linear.predictor"} there 69 | will be two sets of predictions, standard errors and intervals; one 70 | for j and one for j-1 (in the usual notation) where j = 1, ..., J index 71 | the response classes. 72 | 73 | If newdata is supplied and the response variable is omitted, then 74 | \code{predict.clm} returns much the same thing as \code{predict.polr} 75 | (matrices of predictions). Similarly, if \code{type = "class"}. 76 | 77 | If the fit is rank-deficient, some of the columns of the design matrix 78 | will have been dropped. Prediction from such a fit only makes sense if 79 | newdata is contained in the same subspace as the original data. That 80 | cannot be checked accurately, so a warning is issued 81 | (cf. \code{\link{predict.lm}}). 82 | 83 | If a flexible link function is used (\code{Aranda-Ordaz} or \code{log-gamma}) 84 | standard errors and confidence intervals of predictions do not take the 85 | uncertainty in the link-parameter into account. 86 | } 87 | \value{ 88 | A list containing the following components 89 | \item{fit}{predictions or fitted values if \code{newdata} is not 90 | supplied. 91 | } 92 | \item{se.fit}{if \code{se.fit=TRUE} standard errors of the predictions 93 | otherwise \code{NULL}. 94 | } 95 | \item{upr, lwr}{if \code{interval=TRUE} lower and upper confidence 96 | limits.} 97 | 98 | } 99 | \author{Rune Haubo B Christensen} 100 | \seealso{ 101 | \code{\link[ordinal]{clm}}, \code{\link[ordinal]{clmm}}. 102 | } 103 | \examples{ 104 | 105 | ## simple model: 106 | fm1 <- clm(rating ~ contact + temp, data=wine) 107 | summary(fm1) 108 | 109 | ## Fitted values with standard errors and confidence intervals: 110 | predict(fm1, se.fit=TRUE, interval=TRUE) # type="prob" 111 | ## class predictions for the observations: 112 | predict(fm1, type="class") 113 | 114 | newData <- expand.grid(temp = c("cold", "warm"), 115 | contact = c("no", "yes")) 116 | 117 | ## Predicted probabilities in all five response categories for each of 118 | ## the four cases in newData: 119 | predict(fm1, newdata=newData, type="prob") 120 | ## now include standard errors and intervals: 121 | predict(fm1, newdata=newData, se.fit=TRUE, interval=TRUE, type="prob") 122 | 123 | 124 | } 125 | \keyword{models} 126 | -------------------------------------------------------------------------------- /man/predictOld.Rd: -------------------------------------------------------------------------------- 1 | \name{predict.clm2} 2 | \alias{predict.clm2} 3 | \alias{predict.clmm2} 4 | \title{Predict Method for CLM fits} 5 | \description{ 6 | Obtains predictions from a cumulative link (mixed) model. 7 | } 8 | \usage{ 9 | \method{predict}{clm2}(object, newdata, ...) 10 | 11 | %% \method{predict}{clmm}(object, newdata, ...) 12 | } 13 | \arguments{ 14 | \item{object}{a fitted object of class inheriting from 15 | \code{clm2} including \code{clmm2} objects.} 16 | \item{newdata}{optionally, a data frame in which to look for variables 17 | with which to predict. Observe that the response variable should 18 | also be present.} 19 | \item{\dots}{further arguments passed to or from other methods.} 20 | } 21 | \details{ 22 | This method does not duplicate the behavior of 23 | \code{predict.polr} in package \code{MASS} which produces a 24 | matrix instead of a vector of predictions. The behavior of 25 | \code{predict.polr} can be mimiced as shown in the examples. 26 | 27 | If \code{newdata} is not supplied, the fitted values are obtained. For 28 | \code{clmm2} fits this means predictions that are controlled for the 29 | observed value of the random effects. If the predictions for a 30 | random effect of zero, i.e. an average 'subject', are wanted, the same 31 | data used to fit the model should be supplied in the \code{newdata} 32 | argument. For \code{clm2} fits those two sets of predictions are 33 | identical. 34 | } 35 | \value{ 36 | A vector of predicted probabilities. 37 | } 38 | \author{Rune Haubo B Christensen} 39 | \seealso{ 40 | \code{\link[ordinal]{clm2}}, \code{\link[ordinal]{clmm2}}. 41 | } 42 | \examples{ 43 | options(contrasts = c("contr.treatment", "contr.poly")) 44 | 45 | ## More manageable data set for less voluminous printing: 46 | (tab26 <- with(soup, table("Product" = PROD, "Response" = SURENESS))) 47 | dimnames(tab26)[[2]] <- c("Sure", "Not Sure", "Guess", "Guess", "Not Sure", "Sure") 48 | dat26 <- expand.grid(sureness = as.factor(1:6), prod = c("Ref", "Test")) 49 | dat26$wghts <- c(t(tab26)) 50 | dat26 51 | 52 | m1 <- clm2(sureness ~ prod, scale = ~prod, data = dat26, 53 | weights = wghts, link = "logistic") 54 | predict(m1) 55 | 56 | mN1 <- clm2(sureness ~ 1, nominal = ~prod, data = dat26, 57 | weights = wghts) 58 | predict(mN1) 59 | 60 | predict(update(m1, scale = ~.-prod)) 61 | 62 | 63 | ################################# 64 | ## Mimicing the behavior of predict.polr: 65 | if(require(MASS)) { 66 | ## Fit model from polr example: 67 | fm1 <- clm2(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) 68 | predict(fm1) 69 | 70 | set.seed(123) 71 | nlev <- 3 72 | y <- gl(nlev, 5) 73 | x <- as.numeric(y) + rnorm(15) 74 | fm.clm <- clm2(y ~ x) 75 | fm.polr <- polr(y ~ x) 76 | 77 | ## The equivalent of predict.polr(object, type = "probs"): 78 | (pmat.polr <- predict(fm.polr, type = "probs")) 79 | ndat <- expand.grid(y = gl(nlev,1), x = x) 80 | (pmat.clm <- matrix(predict(fm.clm, newdata = ndat), ncol=nlev, 81 | byrow = TRUE)) 82 | all.equal(c(pmat.clm), c(pmat.polr), tol = 1e-5) # TRUE 83 | 84 | ## The equivalent of predict.polr(object, type = "class"): 85 | (class.polr <- predict(fm.polr)) 86 | (class.clm <- factor(apply(pmat.clm, 1, which.max))) 87 | all.equal(class.clm, class.polr) ## TRUE 88 | } 89 | 90 | } 91 | \keyword{internal} 92 | -------------------------------------------------------------------------------- /man/ranef.Rd: -------------------------------------------------------------------------------- 1 | \name{condVar} 2 | \alias{ranef} 3 | \alias{condVar} 4 | \alias{ranef.clmm} 5 | \alias{condVar.clmm} 6 | %- Also NEED an '\alias' for EACH other topic documented here. 7 | \title{ 8 | Extract conditional modes and conditional variances from clmm objects 9 | } 10 | \description{ 11 | The ranef function extracts the conditional modes of the random 12 | effects from a clmm object. That is, the modes of the distributions 13 | for the random effects given the observed data and estimated model 14 | parameters. In a Bayesian language they are posterior modes. 15 | 16 | The conditional variances are computed from the second order 17 | derivatives of the conditional distribution of the random 18 | effects. Note that these variances are computed at a fixed value of 19 | the model parameters and thus do not take the uncertainty of the 20 | latter into account. 21 | } 22 | \usage{ 23 | 24 | condVar(object, ...) 25 | 26 | \method{ranef}{clmm}(object, condVar=FALSE, ...) 27 | 28 | \method{condVar}{clmm}(object, ...) 29 | 30 | } 31 | %- maybe also 'usage' for other objects documented here. 32 | \arguments{ 33 | \item{object}{a \code{\link{clmm}} object. 34 | } 35 | \item{condVar}{ 36 | an optional logical argument indicating of conditional variances 37 | should be added as attributes to the conditional modes. 38 | } 39 | \item{\dots}{ 40 | currently not used by the \code{clmm} methods. 41 | } 42 | } 43 | \details{ 44 | The \code{ranef} method returns a list of \code{data.frame}s; one for 45 | each distinct grouping factor. Each \code{data.frame} has as many rows 46 | as there are levels for that grouping factor and as many columns as 47 | there are random effects for each level. For example a model can 48 | contain a random intercept (one column) or a random 49 | intercept and a random slope (two columns) for the same grouping 50 | factor. 51 | 52 | If conditional variances are requested, they are returned in the same 53 | structure as the conditional modes (random effect 54 | estimates/predictions). 55 | } 56 | \value{ 57 | The \code{ranef} method returns a list of \code{data.frame}s with the 58 | random effects predictions/estimates computed as conditional 59 | modes. If \code{condVar = TRUE} a \code{data.frame} with the 60 | conditional variances is stored as an attribute on each 61 | \code{data.frame} with conditional modes. 62 | 63 | The \code{condVar} method returns a list of \code{data.frame}s with 64 | the conditional variances. It is a convenience function that simply 65 | computes the conditional modes and variances, then extracts and 66 | returns only the latter. 67 | } 68 | \author{ 69 | Rune Haubo B Christensen 70 | } 71 | \examples{ 72 | 73 | fm1 <- clmm(rating ~ contact + temp + (1|judge), data=wine) 74 | 75 | ## Extract random effect estimates/conditional modes: 76 | re <- ranef(fm1, condVar=TRUE) 77 | 78 | ## Get conditional variances: 79 | attr(re$judge, "condVar") 80 | ## Alternatively: 81 | condVar(fm1) 82 | 83 | } 84 | % Add one or more standard keywords, see file 'KEYWORDS' in the 85 | % R documentation directory. 86 | \keyword{models} 87 | 88 | -------------------------------------------------------------------------------- /man/slice.clm.Rd: -------------------------------------------------------------------------------- 1 | \name{slice} 2 | \alias{slice} 3 | \alias{slice.clm} 4 | \alias{plot.slice.clm} 5 | %- Also NEED an '\alias' for EACH other topic documented here. 6 | \title{ 7 | Slice the likelihood of a clm 8 | } 9 | \description{ 10 | Slice likelihood and plot the slice. This is usefull for illustrating 11 | the likelihood surface around the MLE (maximum likelihood estimate) 12 | and provides graphics to substantiate (non-)convergence of a model 13 | fit. Also, the closeness of a quadratic approximation to the 14 | log-likelihood function can be inspected for relevant parameters. A 15 | slice is considerably less computationally demanding than a profile. 16 | } 17 | \usage{ 18 | slice(object, ...) 19 | 20 | \method{slice}{clm}(object, parm = seq_along(par), lambda = 3, 21 | grid = 100, quad.approx = TRUE, ...) 22 | 23 | \method{plot}{slice.clm}(x, parm = seq_along(x), 24 | type = c("quadratic", "linear"), plot.mle = TRUE, 25 | ask = prod(par("mfcol")) < length(parm) && dev.interactive(), ...) 26 | 27 | } 28 | %- maybe also 'usage' for other objects documented here. 29 | \arguments{ 30 | \item{object}{for the \code{clm} method an object of class 31 | \code{"clm"}, i.e., the result of a call to \code{clm}. 32 | } 33 | \item{x}{ 34 | a \code{slice.clm} object, i.e., the result of 35 | \code{slice(clm.object)}. 36 | } 37 | \item{parm}{ 38 | for \code{slice.clm} a numeric or character vector indexing 39 | parameters, for \code{plot.slice.clm} only a numeric vector is 40 | accepted. By default all parameters are selected. 41 | } 42 | \item{lambda}{ 43 | the number of curvature units on each side of the MLE the slice 44 | should cover. 45 | } 46 | \item{grid}{ 47 | the number of values at which to compute the log-likelihood for each 48 | parameter. 49 | } 50 | \item{quad.approx}{ 51 | compute and include the quadratic approximation to the 52 | log-likelihood function? 53 | } 54 | \item{type}{ 55 | \code{"quadratic"} plots the log-likelihood function which is 56 | approximately quadratic, and \code{"linear"} plots the 57 | signed square root of the log-likelihood function which is 58 | approximately linear. 59 | } 60 | \item{plot.mle}{ 61 | include a vertical line at the MLE (maximum likelihood estimate) 62 | when \code{type = "quadratic"}? Ignored for \code{type = "linear"}. 63 | } 64 | \item{ask}{ 65 | logical; if \code{TRUE}, the user is asked before each plot, see 66 | \code{\link{par}}\code{(ask=.)}. 67 | } 68 | \item{\dots}{ 69 | further arguments to \code{plot.default} for the plot method. Not 70 | used in the slice method. 71 | } 72 | } 73 | %% \details{ bla 74 | %% %% ~~ If necessary, more details than the description above ~~ 75 | %% } 76 | \value{ 77 | The \code{slice} method returns a list of \code{data.frame}s with one 78 | \code{data.frame} for each parameter slice. Each \code{data.frame} 79 | contains in the first column the values of the parameter and in the 80 | second column the values of the (positive) log-likelihood 81 | \code{"logLik"}. A third column is present if \code{quad.approx = TRUE} 82 | and contains the corresponding quadratic approximation to the 83 | log-likelihood. The original model fit is included as the attribute 84 | \code{"original.fit"}. 85 | 86 | The \code{plot} method produces a plot of the likelihood slice for 87 | each parameter. 88 | 89 | } 90 | \author{ 91 | Rune Haubo B Christensen 92 | } 93 | \examples{ 94 | 95 | ## fit model: 96 | fm1 <- clm(rating ~ contact + temp, data = wine) 97 | ## slice the likelihood: 98 | sl1 <- slice(fm1) 99 | 100 | ## three different ways to plot the slices: 101 | par(mfrow = c(2,3)) 102 | plot(sl1) 103 | plot(sl1, type = "quadratic", plot.mle = FALSE) 104 | plot(sl1, type = "linear") 105 | 106 | ## Verify convergence to the optimum: 107 | sl2 <- slice(fm1, lambda = 1e-5, quad.approx = FALSE) 108 | plot(sl2) 109 | 110 | } 111 | % Add one or more standard keywords, see file 'KEYWORDS' in the 112 | % R documentation directory. 113 | \keyword{models} 114 | 115 | -------------------------------------------------------------------------------- /man/soup.Rd: -------------------------------------------------------------------------------- 1 | \name{soup} 2 | \alias{soup} 3 | \title{ 4 | Discrimination study of packet soup 5 | } 6 | \description{ 7 | The \code{soup} data frame has 1847 rows and 13 variables. 185 8 | respondents participated in an A-not A discrimination test with 9 | sureness. Before experimentation the respondents were familiarized 10 | with the reference product and during experimentation, the respondents 11 | were asked to rate samples on an ordered scale with six categories 12 | given by combinations of (reference, not reference) and (sure, not 13 | sure, guess) from 'referene, sure' = 1 to 'not reference, sure' = 6. 14 | %given by the levels of the \code{SURENESS} variable. 15 | } 16 | \usage{ 17 | soup 18 | } 19 | \format{ 20 | \describe{ 21 | \item{\code{RESP}}{ 22 | factor with 185 levels: the respondents in the study. 23 | } 24 | \item{\code{PROD}}{ 25 | factor with 2 levels: index reference and test products. 26 | } 27 | \item{\code{PRODID}}{ 28 | factor with 6 levels: index reference and the five test product 29 | variants. 30 | } 31 | \item{\code{SURENESS}}{ 32 | ordered factor with 6 levels: the respondents ratings of soup 33 | samples. 34 | } 35 | \item{\code{DAY}}{ 36 | factor with two levels: experimentation was split over two days. 37 | } 38 | \item{\code{SOUPTYPE}}{ 39 | factor with three levels: the type of soup regularly consumed by the 40 | respondent. 41 | } 42 | \item{\code{SOUPFREQ}}{ 43 | factor with 3 levels: the frequency with which the respondent 44 | consumes soup. 45 | } 46 | \item{\code{COLD}}{ 47 | factor with two levels: does the respondent have a cold? 48 | } 49 | \item{\code{EASY}}{ 50 | factor with ten levels: How easy did the respondent find the 51 | discrimation test? 1 = difficult, 10 = easy. 52 | } 53 | \item{\code{GENDER}}{ 54 | factor with two levels: gender of the respondent. 55 | } 56 | \item{\code{AGEGROUP}}{ 57 | factor with four levels: the age of the respondent. 58 | } 59 | \item{\code{LOCATION}}{ 60 | factor with three levels: three different locations where 61 | experimentation took place. 62 | } 63 | %% \item{\code{SEQ}}{ 64 | %% integer vector: the sequence at which experimentation took 65 | %% place. Numbering restarted at the second day of experimentation. 66 | %% } 67 | }} 68 | \source{ 69 | Data are produced by Unilever Research. Permission to publish 70 | the data is granted. 71 | } 72 | \references{ 73 | Christensen, R. H. B., Cleaver, G. and Brockhoff, P. B.(2011) 74 | Statistical and Thurstonian models for the A-not A protocol with and 75 | without sureness. \emph{Food Quality and Preference, 22}, 76 | pp. 542-549. 77 | } 78 | 79 | \keyword{datasets} 80 | -------------------------------------------------------------------------------- /man/updateOld.Rd: -------------------------------------------------------------------------------- 1 | \name{update.clm2} 2 | \alias{update.clm2} 3 | \alias{update.clmm2} 4 | \title{Update method for cumulative link models} 5 | \description{ 6 | Update method for cumulative link models fitted with \code{clm2}. 7 | This makes it possible to use e.g. 8 | \code{update(obj, location = ~ . - var1, scale = ~ . + var2)} 9 | } 10 | \usage{ 11 | \method{update}{clm2}(object, formula., location, scale, nominal,..., 12 | evaluate = TRUE) 13 | \method{update}{clmm2}(object, formula., location, scale, nominal,..., 14 | evaluate = TRUE) 15 | } 16 | \arguments{ 17 | \item{object}{a \code{\link{clm2}} object. 18 | } 19 | \item{formula.}{not used---unfortunately this argument is part of the 20 | default method. 21 | } 22 | \item{location}{an optional new formula for the location; see 23 | \code{\link{update.formula}} for details. 24 | } 25 | \item{scale}{an optional new formula for the scale; see 26 | \code{\link{update.formula}} for details. 27 | } 28 | \item{nominal}{an optional new formula for nominal effects; see 29 | \code{\link{update.formula}} for details. 30 | } 31 | \item{\dots}{additional arguments to the call, or arguments with 32 | changed values. 33 | } 34 | \item{evaluate}{if true evaluate the new call else return the call. 35 | } 36 | } 37 | \value{ 38 | If \code{evaluate = TRUE} the fitted object is returned, 39 | otherwise the updated call. 40 | } 41 | \author{Rune Haubo B Christensen} 42 | \examples{ 43 | options(contrasts = c("contr.treatment", "contr.poly")) 44 | 45 | m1 <- clm2(SURENESS ~ PROD, scale = ~PROD, data = soup, 46 | link = "logistic") 47 | 48 | m2 <- update(m1, link = "probit") 49 | m3 <- update(m1, link = "cloglog") 50 | m4 <- update(m1, link = "loglog") 51 | anova(m1, update(m1, scale = ~.-PROD)) 52 | mT1 <- update(m1, threshold = "symmetric") 53 | 54 | } 55 | \keyword{internal} 56 | -------------------------------------------------------------------------------- /man/wine.Rd: -------------------------------------------------------------------------------- 1 | \name{wine} 2 | \alias{wine} 3 | \title{ 4 | Bitterness of wine 5 | } 6 | \description{ 7 | The \code{wine} data set is adopted from Randall(1989) and from a 8 | factorial experiment on factors determining the bitterness of 9 | wine. Two treatment factors (temperature and contact) each have two 10 | levels. Temperature and contact between juice and skins can be 11 | controlled when cruching grapes during wine production. Nine judges 12 | each assessed wine from two bottles from each of the four treatment 13 | conditions, hence there are 72 observations in all. 14 | } 15 | \usage{ 16 | wine 17 | } 18 | \format{ 19 | \describe{ 20 | \item{\code{response}}{ 21 | scorings of wine bitterness on a 0---100 continuous scale. 22 | } 23 | \item{\code{rating}}{ 24 | ordered factor with 5 levels; a grouped version of \code{response}. 25 | } 26 | \item{\code{temp}}{ 27 | temperature: factor with two levels. 28 | } 29 | \item{\code{contact}}{ 30 | factor with two levels (\code{"no"} and \code{"yes"}). 31 | } 32 | \item{\code{bottle}}{ 33 | factor with eight levels. 34 | } 35 | \item{\code{judge}}{ 36 | factor with nine levels. 37 | } 38 | }} 39 | \source{ 40 | Data are adopted from Randall (1989). 41 | } 42 | \references{ 43 | Randall, J (1989). The analysis of sensory data by generalised linear 44 | model. \emph{Biometrical journal 7}, pp. 781--793. 45 | 46 | Tutz, G. and W. Hennevogl (1996). Random effects in ordinal regression 47 | models. \emph{Computational Statistics & Data Analysis 22}, 48 | pp. 537--557. 49 | } 50 | \examples{ 51 | 52 | head(wine) 53 | str(wine) 54 | 55 | ## Variables 'rating' and 'response' are related in the following way: 56 | (intervals <- seq(0,100, by = 20)) 57 | all(wine$rating == findInterval(wine$response, intervals)) ## ok 58 | 59 | ## A few illustrative tabulations: 60 | ## Table matching Table 5 in Randall (1989): 61 | temp.contact.bottle <- with(wine, temp:contact:bottle)[drop=TRUE] 62 | xtabs(response ~ temp.contact.bottle + judge, data = wine) 63 | 64 | ## Table matching Table 6 in Randall (1989): 65 | with(wine, { 66 | tcb <- temp:contact:bottle 67 | tcb <- tcb[drop=TRUE] 68 | table(tcb, rating) 69 | }) 70 | ## or simply: with(wine, table(bottle, rating)) 71 | 72 | ## Table matching Table 1 in Tutz & Hennevogl (1996): 73 | tab <- xtabs(as.numeric(rating) ~ judge + temp.contact.bottle, 74 | data = wine) 75 | colnames(tab) <- 76 | paste(rep(c("c","w"), each = 4), rep(c("n", "n", "y", "y"), 2), 77 | 1:8, sep=".") 78 | tab 79 | 80 | 81 | ## A simple model: 82 | m1 <- clm(rating ~ temp * contact, data = wine) 83 | summary(m1) 84 | 85 | } 86 | 87 | \keyword{datasets} 88 | -------------------------------------------------------------------------------- /misc/copyright_header.txt: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | ## 4 | ## This file is part of the ordinal package for R (*ordinal*) 5 | ## 6 | ## *ordinal* is free software: you can redistribute it and/or modify 7 | ## it under the terms of the GNU General Public License as published by 8 | ## the Free Software Foundation, either version 2 of the License, or 9 | ## (at your option) any later version. 10 | ## 11 | ## *ordinal* is distributed in the hope that it will be useful, 12 | ## but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ## GNU General Public License for more details. 15 | ## 16 | ## A copy of the GNU General Public License is available at 17 | ## and/or 18 | ## . 19 | ############################################################################# 20 | -------------------------------------------------------------------------------- /misc/modify_copyright_header.R: -------------------------------------------------------------------------------- 1 | 2 | ######################################################## 3 | ## Change or modify copyright header in R-files: 4 | 5 | cp_header <- readLines("~/GitHub/ordinal/ordinal/misc/copyright_header.txt") 6 | cp_src_header <- gsub("#", "/", cp_header) 7 | 8 | folder <- "~/GitHub/ordinal/ordinal/R" 9 | # folder <- "~/GitHub/ordinal/ordinal/src" 10 | filenames <- list.files(folder) 11 | # Get *.c and *.h files from /src: 12 | # keep <- sapply(strsplit(filenames, ".", fixed = TRUE), 13 | # function(s) s[2] %in% c("c", "h")) 14 | # filenames <- filenames[keep] 15 | 16 | # fn <- filenames[1] # for tests 17 | for(fn in filenames) { 18 | filepath <- paste(folder, fn, sep="/") 19 | txt <- readLines(filepath) 20 | # Get index of copyright header first and last line: 21 | ind <- grep("^########################################", txt) 22 | # Check if copyright header exists in file: 23 | if(grepl("Copyright (c)", txt[ind[1]+1], fixed=TRUE)) { 24 | txt <- txt[-seq_len(ind[2])] # remove copyright header 25 | txt <- c(cp_header, txt) # add new copyright header 26 | writeLines(txt, con=filepath) # write to file 27 | } else { 28 | warning(sprintf("No copyright header found in file: %s.", fn)) 29 | } 30 | } 31 | ######################################################## 32 | ## Update header for c-files: 33 | 34 | folder <- "~/GitHub/ordinal/ordinal/src" 35 | filenames <- list.files(folder) 36 | # Get *.c and *.h files from /src: 37 | keep <- sapply(strsplit(filenames, ".", fixed = TRUE), 38 | function(s) s[2] %in% c("c", "h")) 39 | filenames <- filenames[keep] 40 | 41 | 42 | for(fn in filenames) { # fn <- filenames[1] # for tests 43 | filepath <- paste(folder, fn, sep="/") 44 | txt <- readLines(filepath) 45 | # Get index of copyright header first and last line: 46 | ind <- grep("^########################################", txt) 47 | # ind <- grep("^/////////////////////////////////////////", txt) 48 | # Check if copyright header exists in file: 49 | if(grepl("Copyright (c)", txt[ind[1]+1], fixed=TRUE)) { 50 | txt <- txt[-seq_len(ind[2])] # remove copyright header 51 | txt <- c(cp_src_header, txt) # add new copyright header 52 | writeLines(txt, con=filepath) # write to file 53 | } else { 54 | warning(sprintf("No copyright header found in file: %s.", fn)) 55 | } 56 | } 57 | 58 | ######################################################## 59 | # Write copyright header to new file: 60 | # 61 | # fn <- filenames[1] 62 | for(fn in filenames) { 63 | filepath <- paste(folder, fn, sep="/") 64 | txt <- readLines(filepath) 65 | writeLines(c(cp_header, txt), con=filepath) 66 | # writeLines(c(cp_src_header, txt), con=filepath) 67 | } 68 | 69 | ######################################################## 70 | -------------------------------------------------------------------------------- /old_vignettes/clm_intro.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/runehaubo/ordinal/59ba5b54bff3418aafcbb2ba251fff0041d888fa/old_vignettes/clm_intro.pdf -------------------------------------------------------------------------------- /old_vignettes/clm_tutorial.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/runehaubo/ordinal/59ba5b54bff3418aafcbb2ba251fff0041d888fa/old_vignettes/clm_tutorial.pdf -------------------------------------------------------------------------------- /ordinal.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: knitr 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source 18 | -------------------------------------------------------------------------------- /src/get_fitted.c: -------------------------------------------------------------------------------- 1 | ///////////////////////////////////////////////////////////////////////////// 2 | // Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | // 4 | // This file is part of the ordinal package for R (*ordinal*) 5 | // 6 | // *ordinal* is free software: you can redistribute it and/or modify 7 | // it under the terms of the GNU General Public License as published by 8 | // the Free Software Foundation, either version 2 of the License, or 9 | // (at your option) any later version. 10 | // 11 | // *ordinal* is distributed in the hope that it will be useful, 12 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | // GNU General Public License for more details. 15 | // 16 | // A copy of the GNU General Public License is available at 17 | // and/or 18 | // . 19 | ///////////////////////////////////////////////////////////////////////////// 20 | #include 21 | #include 22 | #include 23 | #include "links.h" 24 | 25 | SEXP get_fitted(SEXP, SEXP, SEXP, SEXP); 26 | 27 | // ------------------------------------------------------- 28 | 29 | 30 | SEXP get_fitted(SEXP eta1p, SEXP eta2p, SEXP linkp, SEXP lambdap) { 31 | /* Compute fitted values (probabilities) from vectors of linear 32 | predictors (eta1 and eta2) given the link function (linkp) and an 33 | optional lambda parameter. 34 | 35 | eta1 and eta2 are required to be equal length numeric vectors, 36 | linkp a character vector and lambdap a numeric scalar. 37 | 38 | return: vector of fittec values of same length as eta1 and eta2. 39 | */ 40 | SEXP ans = PROTECT(duplicate(coerceVector(eta1p, REALSXP))); 41 | eta2p = PROTECT(coerceVector(eta2p, REALSXP)); 42 | linkp = PROTECT(coerceVector(linkp, STRSXP)); 43 | const char *linkc = CHAR(asChar(linkp)); 44 | double *eta1 = REAL(ans), *eta2 = REAL(eta2p), 45 | lambda = asReal(lambdap); 46 | int i, nans = LENGTH(ans); 47 | 48 | if(LENGTH(eta2p) != nans) { 49 | // ".. don't have to UNPROTECT before calling into "error"; it is not a bug to do so, but it is not needed either, error will result in a long jump that will UNPROTECT automatically." Email from Tomas Kalibra 19Apr2018. ; 50 | UNPROTECT(3); 51 | error("'eta1' and 'eta2' should have the same length"); 52 | } 53 | 54 | if(strcmp(linkc, "probit") == 0) { 55 | for(i = 0; i < nans; i++) { 56 | if(eta2[i] <= 0) 57 | // pnorm(x, mu, sigma, lower_tail, give_log); 58 | eta1[i] = pnorm(eta1[i], 0.0, 1.0, 1, 0) - 59 | pnorm(eta2[i], 0.0, 1.0, 1, 0); 60 | else 61 | eta1[i] = pnorm(eta2[i], 0.0, 1.0, 0, 0) - 62 | pnorm(eta1[i], 0.0, 1.0, 0, 0); 63 | } 64 | } 65 | else if(strcmp(linkc, "logit") == 0) { 66 | for(i = 0; i < nans; i++) { 67 | if(eta2[i] <= 0) 68 | // plogis(x, mu, sigma, lower_tail, give_log); 69 | eta1[i] = plogis(eta1[i], 0.0, 1.0, 1, 0) - 70 | plogis(eta2[i], 0.0, 1.0, 1, 0); 71 | else 72 | eta1[i] = plogis(eta2[i], 0.0, 1.0, 0, 0) - 73 | plogis(eta1[i], 0.0, 1.0, 0, 0); 74 | } 75 | } 76 | else if(strcmp(linkc, "loglog") == 0) { 77 | for(i = 0; i < nans; i++) { 78 | if(eta2[i] <= 0) 79 | // d_pgumbel(double q, double loc, double scale, int lower_tail) 80 | eta1[i] = d_pgumbel(eta1[i], 0., 1., 1) - 81 | d_pgumbel(eta2[i], 0., 1., 1); 82 | else 83 | eta1[i] = d_pgumbel(eta2[i], 0., 1., 0) - 84 | d_pgumbel(eta1[i], 0., 1., 0); 85 | } 86 | } 87 | else if(strcmp(linkc, "cloglog") == 0) { 88 | for(i = 0; i < nans; i++) { 89 | if(eta2[i] <= 0) 90 | // d_pgumbel2(double q, double loc, double scale, int lower_tail) 91 | eta1[i] = d_pgumbel2(eta1[i], 0., 1., 1) - 92 | d_pgumbel2(eta2[i], 0., 1., 1); 93 | else 94 | eta1[i] = d_pgumbel2(eta2[i], 0., 1., 0) - 95 | d_pgumbel2(eta1[i], 0., 1., 0); 96 | } 97 | } 98 | else if(strcmp(linkc, "cauchit") == 0) { 99 | for(i = 0; i < nans; i++) { 100 | if(eta2[i] <= 0) 101 | // pcauchy(q, loc, scale, lower_tail, give_log) 102 | eta1[i] = pcauchy(eta1[i], 0., 1., 1, 0) - 103 | pcauchy(eta2[i], 0., 1., 1, 0); 104 | else 105 | eta1[i] = pcauchy(eta2[i], 0., 1., 0, 0) - 106 | pcauchy(eta1[i], 0., 1., 0, 0); 107 | } 108 | } 109 | else if(strcmp(linkc, "Aranda-Ordaz") == 0) { 110 | for(i = 0; i < nans; i++) { 111 | if(eta2[i] <= 0) 112 | // d_pAO(q, lambda, lower_tail) 113 | eta1[i] = d_pAO(eta1[i], lambda, 1) - 114 | d_pAO(eta2[i], lambda, 1); 115 | else 116 | eta1[i] = d_pAO(eta2[i], lambda, 0) - 117 | d_pAO(eta1[i], lambda, 0); 118 | } 119 | } 120 | else if(strcmp(linkc, "log-gamma") == 0) { 121 | for(i = 0; i < nans; i++) { 122 | if(eta2[i] <= 0) 123 | // d_plgamma(double eta, double lambda, int lower_tail) 124 | eta1[i] = d_plgamma(eta1[i], lambda, 1) - 125 | d_plgamma(eta2[i], lambda, 1); 126 | else 127 | eta1[i] = d_plgamma(eta2[i], lambda, 0) - 128 | d_plgamma(eta1[i], lambda, 0); 129 | } 130 | } 131 | else { 132 | // ".. don't have to UNPROTECT before calling into "error"; it is not a bug to do so, but it is not needed either, error will result in a long jump that will UNPROTECT automatically." Email from Tomas Kalibra 19Apr2018. ; 133 | UNPROTECT(3); // unprotecting before exiting with an error 134 | error("link not recognized"); 135 | } 136 | UNPROTECT(3); 137 | return ans; 138 | } 139 | -------------------------------------------------------------------------------- /src/init.c: -------------------------------------------------------------------------------- 1 | ///////////////////////////////////////////////////////////////////////////// 2 | // Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | // 4 | // This file is part of the ordinal package for R (*ordinal*) 5 | // 6 | // *ordinal* is free software: you can redistribute it and/or modify 7 | // it under the terms of the GNU General Public License as published by 8 | // the Free Software Foundation, either version 2 of the License, or 9 | // (at your option) any later version. 10 | // 11 | // *ordinal* is distributed in the hope that it will be useful, 12 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | // GNU General Public License for more details. 15 | // 16 | // A copy of the GNU General Public License is available at 17 | // and/or 18 | // . 19 | ///////////////////////////////////////////////////////////////////////////// 20 | #include 21 | #include 22 | #include // for NULL 23 | #include 24 | 25 | /* .C calls */ 26 | extern void dAO_C(void *, void *, void *, void *); 27 | extern void dgumbel_C(void *, void *, void *, void *, void *); 28 | extern void dgumbel2_C(void *, void *, void *, void *, void *); 29 | extern void dlgamma_C(void *, void *, void *, void *); 30 | extern void gAO_C(void *, void *, void *); 31 | extern void gcauchy_C(void *, void *); 32 | extern void getNAGQ(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); 33 | extern void getNGHQ_C(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); 34 | extern void ggumbel_C(void *, void *); 35 | extern void ggumbel2_C(void *, void *); 36 | extern void glgamma_C(void *, void *, void *); 37 | extern void glogis_C(void *, void *); 38 | extern void gnorm_C(void *, void *); 39 | extern void grad_C(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); 40 | extern void gradC(void *, void *, void *, void *, void *, void *, void *, void *); 41 | extern void grFacSum_C(void *, void *, void *, void *, void *); 42 | extern void hess(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); 43 | extern void hessC(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); 44 | extern void nll(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); 45 | extern void NRalg(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); 46 | extern void NRalgv3(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); 47 | extern void pAO_C(void *, void *, void *, void *); 48 | extern void pgumbel_C(void *, void *, void *, void *, void *); 49 | extern void pgumbel2_C(void *, void *, void *, void *, void *); 50 | extern void plgamma_C(void *, void *, void *, void *); 51 | 52 | /* .Call calls */ 53 | extern SEXP get_fitted(SEXP, SEXP, SEXP, SEXP); 54 | 55 | static const R_CMethodDef CEntries[] = { 56 | {"dAO_C", (DL_FUNC) &dAO_C, 4}, 57 | {"dgumbel_C", (DL_FUNC) &dgumbel_C, 5}, 58 | {"dgumbel2_C", (DL_FUNC) &dgumbel2_C, 5}, 59 | {"dlgamma_C", (DL_FUNC) &dlgamma_C, 4}, 60 | {"gAO_C", (DL_FUNC) &gAO_C, 3}, 61 | {"gcauchy_C", (DL_FUNC) &gcauchy_C, 2}, 62 | {"getNAGQ", (DL_FUNC) &getNAGQ, 19}, 63 | {"getNGHQ_C", (DL_FUNC) &getNGHQ_C, 17}, 64 | {"ggumbel_C", (DL_FUNC) &ggumbel_C, 2}, 65 | {"ggumbel2_C", (DL_FUNC) &ggumbel2_C, 2}, 66 | {"glgamma_C", (DL_FUNC) &glgamma_C, 3}, 67 | {"glogis_C", (DL_FUNC) &glogis_C, 2}, 68 | {"gnorm_C", (DL_FUNC) &gnorm_C, 2}, 69 | {"grad_C", (DL_FUNC) &grad_C, 16}, 70 | {"gradC", (DL_FUNC) &gradC, 8}, 71 | {"grFacSum_C", (DL_FUNC) &grFacSum_C, 5}, 72 | {"hess", (DL_FUNC) &hess, 13}, 73 | {"hessC", (DL_FUNC) &hessC, 11}, 74 | {"nll", (DL_FUNC) &nll, 17}, 75 | {"NRalg", (DL_FUNC) &NRalg, 29}, 76 | {"NRalgv3", (DL_FUNC) &NRalgv3, 24}, 77 | {"pAO_C", (DL_FUNC) &pAO_C, 4}, 78 | {"pgumbel_C", (DL_FUNC) &pgumbel_C, 5}, 79 | {"pgumbel2_C", (DL_FUNC) &pgumbel2_C, 5}, 80 | {"plgamma_C", (DL_FUNC) &plgamma_C, 4}, 81 | {NULL, NULL, 0} 82 | }; 83 | 84 | static const R_CallMethodDef CallEntries[] = { 85 | {"get_fitted", (DL_FUNC) &get_fitted, 4}, 86 | {NULL, NULL, 0} 87 | }; 88 | 89 | void R_init_ordinal(DllInfo *dll) 90 | { 91 | R_registerRoutines(dll, CEntries, CallEntries, NULL, NULL); 92 | R_useDynamicSymbols(dll, FALSE); 93 | } 94 | -------------------------------------------------------------------------------- /src/links.h: -------------------------------------------------------------------------------- 1 | ///////////////////////////////////////////////////////////////////////////// 2 | // Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen 3 | // 4 | // This file is part of the ordinal package for R (*ordinal*) 5 | // 6 | // *ordinal* is free software: you can redistribute it and/or modify 7 | // it under the terms of the GNU General Public License as published by 8 | // the Free Software Foundation, either version 2 of the License, or 9 | // (at your option) any later version. 10 | // 11 | // *ordinal* is distributed in the hope that it will be useful, 12 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | // GNU General Public License for more details. 15 | // 16 | // A copy of the GNU General Public License is available at 17 | // and/or 18 | // . 19 | ///////////////////////////////////////////////////////////////////////////// 20 | #ifndef _ORDINAL_LINKS_H_ 21 | #define _ORDINAL_LINKS_H_ 22 | /* That ifndef, etc. is an idiom to prevent the body of the header 23 | * being read more than once. 24 | */ 25 | 26 | #include 27 | #include 28 | 29 | #ifdef __cplusplus 30 | extern "C" { 31 | #endif 32 | /* That stanza allows the same header file to be used by C and C++ 33 | * programs. There is a matching stanza at the end of this header 34 | * file. 35 | */ 36 | 37 | /* Additional scalar cumulative probability functions */ 38 | double d_pgumbel (double,double,double,int); 39 | double d_pgumbel2 (double,double,double,int); 40 | double d_pAO (double,double,int); 41 | double d_plgamma (double,double,int); 42 | 43 | /* Additional scalar density functions */ 44 | double d_dgumbel (double,double,double,int); 45 | double d_dgumbel2 (double,double,double,int); 46 | double d_dAO (double,double,int); 47 | double d_dlgamma (double,double,int); 48 | 49 | /* Scalar density gradients */ 50 | double d_glogis (double); 51 | double d_gnorm (double); 52 | double d_gcauchy (double); 53 | double d_ggumbel (double); 54 | double d_ggumbel2 (double); 55 | double d_gAO (double,double); 56 | double d_glgamma (double,double); 57 | 58 | #ifdef __cplusplus 59 | } 60 | #endif 61 | 62 | #endif 63 | -------------------------------------------------------------------------------- /tests/anova.R: -------------------------------------------------------------------------------- 1 | library(ordinal) 2 | data(wine) 3 | 4 | fm1 <- clm(rating ~ temp, data=wine) 5 | fmm1 <- clmm(rating ~ temp + (1|judge), data=wine) 6 | 7 | ## These now give identical printed results: 8 | ## Previously the printed model names were messed up when anova.clmm 9 | ## were called. 10 | anova(fm1, fmm1) 11 | anova(fmm1, fm1) 12 | 13 | ## Testing if 'test' and 'type' arguments are ignored properly: 14 | fm1 <- clm(rating ~ temp + contact, data=wine) 15 | fm2 <- clm(rating ~ temp, data=wine) 16 | anova(fm1, fm2, test="Chi") 17 | anova(fm1, fm2, type="Chi") 18 | anova(fm1, fm2) 19 | ## calling anova.clmm 20 | anova(fmm1, fm1, test="Chi") 21 | anova(fmm1, fm1, type="Chi") 22 | 23 | -------------------------------------------------------------------------------- /tests/clm.fit.R: -------------------------------------------------------------------------------- 1 | library(ordinal) 2 | data(wine) 3 | 4 | ## clm.fit with nominal and scale effects: 5 | 6 | ## get simple model: 7 | fm1 <- clm(rating ~ temp, scale=~temp, nominal=~ contact, 8 | data=wine, method="design") 9 | str(fm1, give.attr=FALSE) 10 | fm1$control$method <- "Newton" 11 | res <- clm.fit(fm1) 12 | names(res) 13 | res$Theta 14 | 15 | ## construct some weights and offsets: 16 | set.seed(1) 17 | off1 <- runif(length(fm1$y)) 18 | set.seed(1) 19 | off2 <- rnorm(length(fm1$y)) 20 | set.seed(1) 21 | wet <- runif(length(fm1$y)) 22 | 23 | ## Fit various models: 24 | fit <- clm.fit(fm1$y, fm1$X, fm1$S, fm1$NOM, weights=wet) 25 | Coef <- 26 | c(-0.905224120279548, 1.31043498891987, 3.34235590523008, 27 | 4.52389661722693, -3.03954652971192, -1.56922389038976, 28 | -1.75662549320839, -1.16845464236365, 2.52988580848393, 29 | -0.0261457032829033) 30 | stopifnot(all.equal(coef(fit), Coef, check.attributes=FALSE, tol=1e-6)) 31 | str(fit) 32 | 33 | fit <- clm.fit(fm1$y, fm1$X, fm1$S, fm1$NOM, offset=off1) 34 | str(fit) 35 | 36 | fit <- clm.fit(fm1$y, fm1$X, fm1$S, fm1$NOM, offset=off1, 37 | S.offset=off2) 38 | str(fit) 39 | 40 | fit <- clm.fit(fm1$y, fm1$X, fm1$S) 41 | str(fit) 42 | 43 | fit <- clm.fit(fm1$y, fm1$X) 44 | str(fit) 45 | 46 | fit <- clm.fit(fm1$y) 47 | coef(fit) 48 | str(fit) 49 | 50 | ## Remember: compare with corresponding .Rout file 51 | -------------------------------------------------------------------------------- /tests/clm.formula.R: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/runehaubo/ordinal/59ba5b54bff3418aafcbb2ba251fff0041d888fa/tests/clm.formula.R -------------------------------------------------------------------------------- /tests/clmm.R: -------------------------------------------------------------------------------- 1 | library(ordinal) 2 | data(wine) 3 | 4 | ################################# 5 | ## Estimation with a single simple RE term: 6 | ## Laplace: 7 | fmm1 <- clmm(rating ~ contact + temp + (1|judge), data=wine) 8 | summary(fmm1) 9 | ## GHQ: 10 | fmm.ghq <- clmm(rating ~ contact + temp + (1|judge), data=wine, 11 | nAGQ=-10) 12 | summary(fmm.ghq) 13 | ## AGQ: 14 | fmm.agq <- clmm(rating ~ contact + temp + (1|judge), data=wine, 15 | nAGQ=10) 16 | summary(fmm.agq) 17 | ## tests: 18 | ## Notice warning about Laplace with multiple REs when nAGQ != 1: 19 | fmm1 <- try(clmm(rating ~ contact + temp + (1|judge) + (1|bottle), 20 | data=wine, nAGQ=10)) 21 | stopifnot(inherits(fmm1, "try-error")) 22 | 23 | ################################# 24 | ## Estimation with several RE terms: 25 | data(soup, package="ordinal") 26 | fmm <- clmm(SURENESS ~ PROD + (1|RESP) + (1|PROD:RESP), data=soup, 27 | threshold="equidistant") 28 | summary(fmm) 29 | 30 | ################################# 31 | 32 | ## Estimation with implicit intercept: 33 | fm1 <- clmm(rating ~ 1 + (1|judge), data = wine) 34 | fm2 <- clmm(rating ~ (1|judge), data = wine) 35 | fm3 <- clmm(rating ~ 0 + (1|judge), data = wine) 36 | stopifnot(isTRUE(all.equal(coef(fm1), coef(fm2), tolerance=1e-5)), 37 | isTRUE(all.equal(coef(fm1), coef(fm3), tolerance=1e-5))) 38 | -------------------------------------------------------------------------------- /tests/clmm.control.R: -------------------------------------------------------------------------------- 1 | library(ordinal) 2 | data(wine) 3 | 4 | 5 | ### 3 options for specifying control arguments: 6 | ## 1) control is a simple list, e.g. list(trace=-1) 7 | ## 2) control is a call to clmm.control 8 | ## 3) control is an empty list; list() 9 | ## all in combination with extra control arguments. 10 | 11 | ordinal:::getCtrlArgs(clmm.control(), list(maxIter=200)) 12 | ordinal:::getCtrlArgs(list(), list(maxIter=200)) 13 | ordinal:::getCtrlArgs(list(), list(trace=-1)) 14 | ordinal:::getCtrlArgs(list(), list(trace=1)) 15 | ordinal:::getCtrlArgs(list(), list()) 16 | ordinal:::getCtrlArgs(list(maxIter=2), list()) 17 | 18 | ordinal:::getCtrlArgs(clmm.control(), list()) 19 | ordinal:::getCtrlArgs(clmm.control(maxIter=100), list(maxIter=200)) 20 | ordinal:::getCtrlArgs(clmm.control(maxIter=100), list(maxIter=200)) 21 | ordinal:::getCtrlArgs(clmm.control(), list(trace=1)) 22 | ordinal:::getCtrlArgs(clmm.control(), list(trace=-1)) 23 | ordinal:::getCtrlArgs(clmm.control(trace=1), list()) 24 | ordinal:::getCtrlArgs(clmm.control(trace=-1), list()) 25 | ordinal:::getCtrlArgs(clmm.control(trace=0), list()) 26 | ## Don't specify trace twice - surprising behavior might occur: 27 | ordinal:::getCtrlArgs(clmm.control(trace=1), list(trace=-1)) 28 | ordinal:::getCtrlArgs(clmm.control(trace=-1), list(trace=1)) 29 | -------------------------------------------------------------------------------- /tests/clmm.formula.R: -------------------------------------------------------------------------------- 1 | library(ordinal) 2 | data(wine) 3 | 4 | ################################# 5 | ## Appropriate evaluation of formulas: 6 | 7 | ## These all work as intended with no warnings or errors: 8 | fm1 <- clmm(rating ~ contact + (1|judge), data=wine) 9 | fm1 10 | fm1 <- clmm("rating ~ contact + (1|judge)", data=wine) 11 | fm1 12 | fm1 <- clmm(as.formula("rating ~ contact + (1|judge)"), data=wine) 13 | fm1 14 | fm1 <- clmm(as.formula(rating ~ contact + (1|judge)), data=wine) 15 | fm1 16 | 17 | ################################# 18 | 19 | ### finding variables in the environment of the formula: 20 | makeform <- function() { 21 | f1 <- as.formula(rating ~ temp + contact + (1|judge)) 22 | rating <- wine$rating 23 | temp <- wine$temp 24 | contact <- wine$contact 25 | judge <- wine$judge 26 | f1 27 | } 28 | ## 'makeform' makes are formula object in the environment of the 29 | ## function makeform: 30 | f1 <- makeform() 31 | f1 # print 32 | class(f1) 33 | ## If we give the data, we can evaluate the model: 34 | fm1 <- clmm(f1, data=wine) 35 | ## We can also evaluate the model because the data are available in 36 | ## the environment associated with the formula: 37 | fm1 <- clmm(f1) 38 | ## For instance, the 'rating' variable is not found in the Global 39 | ## environment; we have to evaluate the 'name' of 'rating' in the 40 | ## appropriate environment: 41 | (try(rating, silent=TRUE)) 42 | eval(as.name("rating"), envir=environment(f1)) 43 | ## If instead we generate the formula in the Global environment where 44 | ## the variables are not found, we cannot evaluate the model: 45 | f2 <- as.formula(rating ~ temp + contact + (1|judge)) 46 | (try(fm2 <- clmm(f2), silent=TRUE)) 47 | environment(f2) <- environment(f1) 48 | fm2 <- clmm(f2) 49 | 50 | ################################# 51 | ## Use of formula-objects 52 | f <- formula(rating ~ temp + contact + (1|judge)) 53 | m2 <- clmm(f, data = wine) 54 | summary(m2) 55 | 56 | ################################# 57 | ## Other ways to construct formulas: 58 | set.seed(12345) 59 | y <- factor(sample(1:4,20,replace=TRUE)) 60 | x <- rnorm(20) 61 | b <- gl(5, 4, labels=letters[1:5]) 62 | data <- data.frame(y=y, x=x, b=b) 63 | rm(x, y, b) 64 | clmm(y ~ x + (1|b), data=data) 65 | fit <- clmm(data$y ~ data$x + (1|data$b)) 66 | fit 67 | fit <- clmm(data[, 1] ~ data[, 2] + (1|data[, 3])) 68 | fit 69 | 70 | ################################# 71 | ## Evaluation within other functions: 72 | ## date: January 18th 2012. 73 | ## 74 | ## The problem was raised by Stefan Herzog (stefan.herzog@unibas.ch) 75 | ## January 12th 2012 in trying to make clmm work with glmulti. 76 | 77 | fun.clmm <- function(formula, data) 78 | ### This only works because clmm via eclmm.model.frame is careful to 79 | ### evaluate the 'formula' in the parent environment such it is not the 80 | ### character "formula" that is attempted evaluated. 81 | clmm(formula, data = data) 82 | 83 | fun2.clmm <- function(formula, data, weights, subset) { 84 | ### This should be the safe way to ensure evaluation of clmm in the 85 | ### right environment. 86 | mc <- match.call() 87 | mc[[1]] <- as.name("clmm") 88 | eval.parent(mc) 89 | } 90 | 91 | fun.clmm(rating ~ temp + contact + (1|judge), data=wine) ## works 92 | fun2.clmm(rating ~ temp + contact + (1|judge), data=wine) ## works 93 | 94 | form1 <- "rating ~ temp + contact + (1|judge)" 95 | fun.clmm(form1, data=wine) ## works 96 | fun2.clmm(form1, data=wine) ## works 97 | 98 | form2 <- formula(rating ~ temp + contact + (1|judge)) 99 | fun.clmm(form2, data=wine) ## works 100 | fun2.clmm(form2, data=wine) ## works 101 | ## Notice that clmm is not able to get the name of the data (wine) 102 | ## correct when using fun.clmm. 103 | 104 | ################################# 105 | 106 | ## ## Example 2: using clmm function 107 | ## # 108 | ## ## Now I want to consider judge as a random effect to account for 109 | ## ## grouping structure of data 110 | ## mod2 <- clmm(rating ~ temp + contact + (1|judge), data=wine) 111 | ## 112 | ## ##Again, I started by using my own code to run all potential models: 113 | ## ## put names of all your variables in this vector: 114 | ## vl2 <- c("temp", "contact") 115 | ## ## generate list of possible combinations of variables: 116 | ## combos2 <- NULL 117 | ## for(i in 1:length(vl2)) { 118 | ## combos2 <- c(combos2, combn(vl2, i, simplify = F)) 119 | ## } 120 | ## ## create formulae and run models one by one, saving them as model1, 121 | ## ## model2 etc... 122 | ## for (i in 1:length(combos2)) { 123 | ## vs2 <- paste(combos2[[i]], collapse=" + ") 124 | ## f2 <- formula(paste("rating ~ ", vs2, "+(1|judge)", sep="")) 125 | ## print(f2) 126 | ## assign(paste("model", i, sep=""), clmm(f2, data=wine)) 127 | ## } 128 | ## summary(model1) # etc 129 | ## summary(model2) # etc 130 | ## summary(model3) # etc 131 | ## 132 | ## models <- vector("list", length(combos2)) 133 | ## for(i in 1:length(combos2)) { 134 | ## vs2 <- paste(combos2[[i]], collapse=" + ") 135 | ## f2 <- formula(paste("rating ~ ", vs2, "+(1|judge)", sep="")) 136 | ## print(f2) 137 | ## models[[i]] <- clmm(f2, data=wine) 138 | ## ## assign(paste("model", i, sep=""), clmm(f2, data=wine)) 139 | ## } 140 | ## 141 | ## ## Coefficients, AIC and BIC: 142 | ## lapply(models, function(m) coef(summary(m))) 143 | ## lapply(models, AIC) 144 | ## lapply(models, BIC) 145 | ## 146 | ## ## library(MuMIn) 147 | ## ## dd2 <- dredge(mod2) ## does not work 148 | ## ## ?dredge 149 | ## ## traceback() 150 | ## ## mod2$formula 151 | ## ## terms(as.formula(formula(mod2))) 152 | ## ## 153 | ## ## library(lme4) 154 | ## ## fmm1 <- lmer(response ~ temp + contact + (1|judge), data=wine) 155 | ## ## fmm1 156 | ## ## terms(as.formula(lme4:::formula(fmm1))) 157 | ## ## terms(as.formula(formula(fmm1))) 158 | -------------------------------------------------------------------------------- /tests/clmm.methods.R: -------------------------------------------------------------------------------- 1 | library(ordinal) 2 | data(wine) 3 | 4 | ################################# 5 | ## model.matrix method for clmm-objects: 6 | fmm1 <- clmm(rating ~ contact + temp + (1|judge), data=wine) 7 | mm <- model.matrix(fmm1) 8 | stopifnot(inherits(mm, "matrix"), 9 | dim(mm) == c(72, 3)) 10 | 11 | ################################# 12 | ## anova.clmm works even if formula does not have an environment: 13 | fmm1 <- clmm(rating ~ temp * contact + (1|judge), data = wine) 14 | fmm2 <- clmm(rating ~ temp + contact + (1|judge), data = wine) 15 | environment(fmm1$formula) <- NULL 16 | environment(fmm2$formula) <- NULL 17 | anova(fmm1, fmm2) 18 | 19 | 20 | ################################# 21 | ## Test that ranef, condVar and VarCorr work as they are supposed to whether or 22 | ## not nlme and lme4 are loaded: 23 | 24 | fm <- clmm(rating ~ temp + contact + (1|judge), data = wine) 25 | fm 26 | ranef(fm) 27 | VarCorr(fm) 28 | condVar(fm) 29 | summary(fm) 30 | 31 | library(nlme) 32 | ranef(fm) 33 | VarCorr(fm) 34 | condVar(fm) 35 | library(lme4) 36 | ranef(fm) 37 | VarCorr(fm) 38 | condVar(fm) 39 | fm1 <- lmer(Reaction ~ Days + (Days | Subject), data=sleepstudy) 40 | ranef(fm1) 41 | VarCorr(fm1) 42 | 43 | ranef(fm) 44 | VarCorr(fm) 45 | condVar(fm) 46 | summary(fm) 47 | -------------------------------------------------------------------------------- /tests/confint.R: -------------------------------------------------------------------------------- 1 | ################################# 2 | ## test profile and confint methods: 3 | library(ordinal) 4 | data(wine) 5 | fm1 <- clm(rating ~ contact + temp, data = wine) 6 | summary(fm1) 7 | 8 | ## profile.clm and confint.clm: 9 | pr1 <- profile(fm1) 10 | confint(pr1) 11 | pr1 <- profile(fm1, which.beta = 1:2) 12 | confint(pr1) 13 | pr1 <- profile(fm1, which.beta = 2:1) 14 | confint(pr1) 15 | pr1 <- profile(fm1, which.beta = 1) 16 | confint(pr1) 17 | pr1 <- profile(fm1, which.beta = 2) 18 | confint(pr1) 19 | pr1 <- try(profile(fm1, which.beta = 0), silent = TRUE) ## error 20 | pr1 <- try(profile(fm1, which.beta = "no.par"), silent = TRUE) ## error 21 | pr1 <- try(profile(fm1, which.beta = -1), silent = TRUE) ## error 22 | pr1 <- profile(fm1, which.beta = "tempwarm") 23 | confint(pr1) 24 | pr1 <- profile(fm1, alpha = 0.1) 25 | confint(pr1) ## should give NA in this case? 26 | pr1 <- profile(fm1, max.steps = 9) 27 | pr1 <- profile(fm1, step.warn = 7) 28 | pr1 <- profile(fm1, nsteps = 6) 29 | pr1 <- profile(fm1, trace = 1) 30 | pr1 <- profile(fm1, control = list(gradTol = .1)) 31 | confint(pr1) ## not at all unreliable... 32 | 33 | ## single regression coef setting: 34 | fm2 <- clm(rating ~ contact, data = wine) 35 | summary(fm2) 36 | pr2 <- profile(fm2) 37 | confint(pr2) 38 | 39 | ## confint.clm: 40 | confint(fm1) 41 | confint(fm1, 2) 42 | confint(fm1, 1) 43 | confint(fm1, "tempwarm") 44 | confint(fm1, type = "profile") 45 | confint(fm1, type = "Wald") 46 | confint(fm1, 2, type = "Wald") 47 | confint(fm1, level = 0.5) 48 | confint(fm1, level = 1 - 1e-6) 49 | confint(fm1, level = 1 - 1e-10) ## extreme, but it works 50 | confint(fm1, trace = 1) 51 | 52 | ## plot.profile: 53 | pr1 <- profile(fm1, which.beta=1:2, alpha = 1e-3) 54 | par(mfrow = c(1,2)) 55 | plot(pr1) 56 | plot(pr1, 1) 57 | plot(pr1, "contactyes") 58 | plot(pr1, level = .97) 59 | plot(pr1, Log = TRUE) 60 | plot(pr1, relative = FALSE) 61 | plot(pr1, root = TRUE) 62 | plot(pr1, approx = TRUE) 63 | plot(pr1, n=10) 64 | plot(pr1, ylim = c(0,2)) 65 | plot(pr1, las = 1) 66 | plot(pr2) 67 | 68 | -------------------------------------------------------------------------------- /tests/nominal.test.R: -------------------------------------------------------------------------------- 1 | library(ordinal) 2 | 3 | if(require(MASS)) { 4 | fm1 <- clm(Sat ~ Infl + Type + Cont, data=housing, weights=Freq) 5 | scale_test(fm1) 6 | nominal_test(fm1) 7 | 8 | fm2 <- update(fm1, scale=~Cont) 9 | scale_test(fm2) 10 | nominal_test(fm2) 11 | fm3 <- update(fm1, nominal=~ Cont) 12 | fm3$Theta 13 | anova(fm2, fm3) 14 | fm3$alpha.mat 15 | summary(fm3) 16 | } 17 | 18 | ################################# 19 | ### Testing nominal_test and scale_test: 20 | fm1 <- clm(rating ~ temp * contact, data=wine) 21 | ## names(fm1) 22 | fm2 <- clm(rating ~ temp * contact, data=wine, nominal=~contact) 23 | (an <- anova(fm1, fm2)) 24 | (nm <- nominal_test(fm1)) 25 | stopifnot(isTRUE(all.equal(an[2, 6], nm["contact", 5]))) 26 | 27 | fm2 <- clm(rating ~ temp * contact, data=wine, scale=~contact) 28 | (an <- anova(fm1, fm2)) 29 | (sc <- scale_test(fm1)) 30 | stopifnot(isTRUE(all.equal(an[2, 6], sc["contact", "Pr(>Chi)"]))) 31 | 32 | fm1 <- clm(rating ~ temp + contact, 33 | nominal=~temp + contact, data=wine) 34 | fm1 35 | try(nominal_test(fm1), silent=TRUE)[1] ## gives error OK 36 | scale_test(fm1) 37 | fm1 <- clm(rating ~ temp + contact, 38 | scale=~temp + contact, data=wine) 39 | fm1 40 | try(scale_test(fm1), silent=TRUE)[1] ## gives error OK 41 | nominal_test(fm1) 42 | 43 | 44 | ## Using weights: 45 | set.seed(123454321) 46 | wt <- runif(nrow(wine)) 47 | fm1 <- clm(rating ~ temp * contact, data=wine, weigths=wt) 48 | nominal_test(fm1) 49 | scale_test(fm1) 50 | 51 | ## No nominal test for judge since that model is not identifiable: 52 | fm1 <- clm(rating ~ judge + temp + contact, data=wine) 53 | nominal_test(fm1) 54 | scale_test(fm1) 55 | fm1 <- clm(rating ~ judge + temp, nominal=~contact, data=wine) 56 | nominal_test(fm1) 57 | summary(fm1) 58 | 59 | ## A continuous variable: 60 | set.seed(123454321) 61 | x <- rnorm(nrow(wine), sd=1) 62 | fm <- clm(rating ~ temp, nominal=~contact * x, data=wine) 63 | nominal_test(fm) 64 | scale_test(fm) 65 | fm <- clm(rating ~ temp + x, nominal=~contact, data=wine) 66 | nominal_test(fm) 67 | scale_test(fm) 68 | ## poly: 69 | fm <- clm(rating ~ temp + poly(x, 2), nominal=~contact, data=wine) 70 | nominal_test(fm) 71 | scale_test(fm) 72 | ## another combination: 73 | fm1 <- clm(SURENESS ~ PRODID + DAY + SOUPTYPE + SOUPFREQ, 74 | scale=~PROD, 75 | nominal=~ DAY*GENDER, data=soup) 76 | fm1 77 | nominal_test(fm1) 78 | scale_test(fm1) 79 | 80 | ################################# 81 | 82 | -------------------------------------------------------------------------------- /tests/ranef.loading.R: -------------------------------------------------------------------------------- 1 | # check that ranef and VarCorr work even after loading ordinal: 2 | library(lme4) 3 | fm1 <- lmer(Reaction ~ Days + (Days | Subject), data=sleepstudy) 4 | ranef(fm1) 5 | VarCorr(fm1) 6 | library(ordinal) 7 | ranef(fm1) 8 | VarCorr(fm1) 9 | -------------------------------------------------------------------------------- /tests/test-all.R: -------------------------------------------------------------------------------- 1 | 2 | if(require(testthat) && require(ordinal)) { 3 | test_check("ordinal") 4 | } 5 | -------------------------------------------------------------------------------- /tests/test.clm.Theta.R: -------------------------------------------------------------------------------- 1 | library(ordinal) 2 | 3 | ################################# 4 | ## 1 categorical variable in nominal: 5 | fm <- clm(rating ~ temp, nominal=~contact, data=wine) 6 | fm$Theta 7 | fm$alpha.mat 8 | ## Threshold effects: 9 | fm <- clm(rating ~ temp, nominal=~contact, data=wine, 10 | threshold="symmetric") 11 | fm$Theta 12 | fm$alpha.mat 13 | fm <- clm(rating ~ temp, nominal=~contact, data=wine, 14 | threshold="equidistant") 15 | fm$Theta 16 | fm$alpha.mat 17 | ## Singular fit is still ok (with a warning, though) 18 | fm <- clm(rating ~ contact, nominal=~temp, data=wine) 19 | fm$alpha.mat 20 | fm$Theta 21 | 22 | ################################# 23 | ## 1 continuous variable: 24 | set.seed(123) 25 | x <- rnorm(nrow(wine), sd=1) 26 | fm <- clm(rating ~ temp, nominal=~ x, data=wine) 27 | fm$alpha.mat 28 | fm$Theta 29 | fm <- clm(rating ~ temp, nominal=~ poly(x, 2), data=wine) 30 | fm$alpha.mat 31 | fm$Theta 32 | 33 | ################################# 34 | ## 1 categorical + 1 continuous variable: 35 | set.seed(123) 36 | x <- rnorm(nrow(wine), sd=1) 37 | fm <- clm(rating ~ temp, nominal=~contact + x, data=wine) 38 | fm$alpha.mat 39 | fm$Theta 40 | fm <- clm(rating ~ temp, nominal=~contact + x, data=wine, 41 | threshold="symmetric") 42 | fm$alpha.mat 43 | fm$Theta 44 | ################################# 45 | ### NOTE: To get the by-threshold nominal effects of continuous terms 46 | ## use: 47 | with(fm, t(apply(alpha.mat, 1, function(th) tJac %*% th))) 48 | ################################# 49 | ## Interactions: 50 | fm <- clm(rating ~ temp, nominal=~contact:x, data=wine) 51 | fm$alpha.mat 52 | fm$Theta 53 | fm <- clm(rating ~ temp, nominal=~contact+x+contact:x, data=wine) 54 | fm$alpha.mat 55 | fm$Theta 56 | fm <- clm(rating ~ temp, nominal=~contact*x, data=wine) 57 | fm$alpha.mat 58 | fm$Theta 59 | ## polynomial terms: 60 | fm <- clm(rating ~ temp, nominal=~contact + poly(x, 2), data=wine) 61 | fm$alpha.mat 62 | fm$Theta 63 | ## logical variables: (treated like numeric variables) 64 | wine$Con <- as.character(wine$contact) == "yes" 65 | fm <- clm(rating ~ temp, nominal=~Con, data=wine) 66 | fm$Theta 67 | fm$alpha.mat 68 | wine$Con.num <- 1 * wine$Con 69 | fm <- clm(rating ~ temp, nominal=~Con.num, data=wine) 70 | fm$Theta 71 | fm$alpha.mat 72 | ################################# 73 | ## Two continuous variables: 74 | set.seed(321) 75 | y <- rnorm(nrow(wine), sd=1) 76 | fm1 <- clm(rating ~ temp, nominal=~y + x, data=wine) 77 | fm1$alpha.mat 78 | fm1$Theta 79 | ## summary(fm1) 80 | 81 | ################################# 82 | ## 1 categorical + 2 continuous variables: 83 | fm1 <- clm(rating ~ temp, nominal=~y + contact + x, data=wine) 84 | fm1$alpha.mat 85 | fm1$Theta 86 | 87 | fm1 <- clm(rating ~ temp, nominal=~contact + x + contact:x + y, 88 | data=wine) 89 | summary(fm1) 90 | fm1$Theta 91 | fm1$alpha.mat 92 | fm1 <- clm(rating ~ temp, nominal=~contact*x + y, data=wine) 93 | fm1$Theta 94 | fm1$alpha.mat 95 | t(fm1$alpha.mat) 96 | fm1 97 | 98 | ################################# 99 | ## ordered factors (behaves like numerical variables): 100 | data(soup, package="ordinal") 101 | fm2 <- clm(SURENESS ~ 1, nominal=~PRODID + DAY, data=soup) 102 | fm2$Theta 103 | fm2$alpha.mat 104 | prodid <- factor(soup$PRODID, ordered=TRUE) 105 | fm2 <- clm(SURENESS ~ 1, nominal=~prodid + DAY, data=soup) 106 | fm2$alpha.mat 107 | fm2$Theta 108 | fm2 <- clm(SURENESS ~ 1, nominal=~prodid, data=soup) 109 | fm2$alpha.mat 110 | fm2$Theta 111 | ################################# 112 | ## Aliased Coefficients: 113 | ## 114 | ## Example where the interaction in the nominal effects is aliased (by 115 | ## design). Here the two Theta matrices coincide. The alpha.mat 116 | ## matrices are similar except one has an extra row with NAs: 117 | soup2 <- soup 118 | levels(soup2$DAY) 119 | levels(soup2$GENDER) 120 | xx <- with(soup2, DAY == "2" & GENDER == "Female") 121 | ## Model with additive nominal effects: 122 | fm8 <- clm(SURENESS ~ PRODID, nominal= ~ DAY + GENDER, data=soup2, subset=!xx) 123 | fm8$alpha.mat 124 | fm8$Theta 125 | ## Model with non-additive, but aliased nominal effects: 126 | fm9 <- clm(SURENESS ~ PRODID, nominal= ~ DAY * GENDER, data=soup2, subset=!xx) 127 | fm9$alpha.mat 128 | fm9$Theta 129 | 130 | stopEqual <- function(x, y, ca=FALSE) 131 | stopifnot(isTRUE(all.equal(x, y, check.attributes=ca))) 132 | 133 | stopEqual(fm8$alpha.mat, fm9$alpha.mat[1:3, ]) 134 | stopEqual(fm8$Theta, fm9$Theta) 135 | stopEqual(logLik(fm8), logLik(fm9)) 136 | 137 | ################################# 138 | ## Weights: 139 | set.seed(12345) 140 | wts <- runif(nrow(soup)) 141 | fm2 <- clm(SURENESS ~ 1, nominal=~SOUPTYPE + DAY, data=soup, weights=wts) 142 | fm2$Theta 143 | 144 | ## Offset (correctly gives and error) 145 | fm2 <- try(clm(SURENESS ~ 1, nominal=~SOUPTYPE + DAY + offset(wts), 146 | data=soup), silent=TRUE) 147 | stopifnot(inherits(fm2, "try-error")) 148 | 149 | ################################# 150 | ### Other (misc) examples: 151 | fm2 <- clm(SURENESS ~ 1, nominal=~SOUPTYPE + DAY, data=soup) 152 | fm2$Theta 153 | fm2 154 | fm2 <- clm(SURENESS ~ 1, nominal=~SOUPTYPE * DAY, data=soup) 155 | fm2$Theta 156 | fm2 157 | fm2$alpha.mat 158 | fm2 <- clm(SURENESS ~ 1, nominal=~SOUPTYPE * DAY, data=soup, 159 | threshold="symmetric") 160 | fm2$Theta 161 | fm2$alpha.mat 162 | 163 | ################################# 164 | ### Check correctness of Theta matrix when intercept is removed in 165 | ### nominal formula: 166 | ### December 25th 2014, RHBC 167 | fm1 <- clm(rating ~ temp, nominal=~contact-1, data=wine) 168 | fm2 <- clm(rating ~ temp, nominal=~contact, data=wine) 169 | stopifnot(isTRUE(all.equal(fm1$Theta, fm2$Theta))) 170 | stopifnot(isTRUE(all.equal(fm1$logLik, fm2$logLik))) 171 | wine2 <- wine 172 | wine2$contact <- relevel(wine2$contact, "yes") 173 | fm3 <- clm(rating ~ temp, nominal=~contact, data=wine2) 174 | stopifnot(isTRUE(all.equal(coef(fm1, na.rm=TRUE), coef(fm3)))) 175 | ################################# 176 | 177 | -------------------------------------------------------------------------------- /tests/test.clm.convergence.R: -------------------------------------------------------------------------------- 1 | library(ordinal) 2 | 3 | 4 | ## Testing that errors in chol() are caught soon enough: 5 | cy <- with(wine, which(temp == "cold" & contact == "yes")) 6 | wine2 <- subset(wine, subset=(!1:nrow(wine) %in% cy)) 7 | wine2[c(9, 15, 46), "rating"] <- NA 8 | fm1 <- clm(rating ~ temp, scale=~contact, nominal=~contact, 9 | data=wine2) 10 | fm1 <- try(clm(rating ~ temp, scale=~contact, nominal=~contact, 11 | data=wine2, control=list(gradTol=1e-12)), silent=TRUE) 12 | fm2 <- try(clm(rating ~ temp, scale=~contact, nominal=~contact, 13 | data=wine2, control=list(gradTol=1e-15)), silent=TRUE) 14 | ## These gave errors in version 2014.11-12. 15 | stopifnot(!inherits(fm1, "try-error")) 16 | stopifnot(!inherits(fm2, "try-error")) 17 | summary(fm1) 18 | summary(fm2) 19 | 20 | ## Error in convergence.clm() due to bad evaluation of model 21 | ## environment with update(object, doFit=FALSE): 22 | wine3 <- wine 23 | set.seed(1234) 24 | wts <- runif(nrow(wine3), 0, 2) 25 | fm3 <- clm(rating ~ temp + contact, data=wine3, 26 | weights=wts) 27 | c0 <- convergence(fm3) 28 | set.seed(1234) 29 | fm3 <- clm(rating ~ temp + contact, data=wine3, 30 | weights=runif(nrow(wine3), 0, 2)) 31 | c1 <- convergence(fm3) 32 | c0$info$logLik.Error 33 | c1$info$logLik.Error 34 | all.equal(c0$info$logLik.Error, c1$info$logLik.Error) 35 | ## In version 2014.11-14: 36 | ## > wine3 <- wine 37 | ## > set.seed(1234) 38 | ## > wts <- runif(nrow(wine3), 0, 2) 39 | ## > fm3 <- clm(rating ~ temp + contact, data=wine3, 40 | ## + weights=wts) 41 | ## > c0 <- convergence(fm3) 42 | ## > set.seed(1234) 43 | ## > fm3 <- clm(rating ~ temp + contact, data=wine3, 44 | ## + weights=runif(nrow(wine3), 0, 2)) 45 | ## > c1 <- convergence(fm3) 46 | ## > c0$info$logLik.Error 47 | ## [1] "<1e-10" 48 | ## > c1$info$logLik.Error 49 | ## [1] "4.80e+00" 50 | ## > all.equal(c0$info$logLik.Error, c1$info$logLik.Error) 51 | ## [1] "1 string mismatch" 52 | stopifnot(c0$info$logLik.Error == 53 | c1$info$logLik.Error) 54 | -------------------------------------------------------------------------------- /tests/test.clm.flex.link.R: -------------------------------------------------------------------------------- 1 | # test.clm.flex.link.R 2 | 3 | library(ordinal) 4 | 5 | fm <- clm(rating ~ contact + temp, data=wine, link="log-gamma") 6 | fm 7 | summary(fm) 8 | vcov(fm) 9 | logLik(fm) 10 | extractAIC(fm) 11 | fm2 <- update(fm, link="probit") 12 | anova(fm, fm2) 13 | head(model.matrix(fm)$X) 14 | head(model.frame(fm)) 15 | coef(fm) 16 | coef(summary(fm)) 17 | nobs(fm) 18 | terms(fm) 19 | # profile(fm) # not implemented 20 | confint(fm) 21 | 22 | predict(fm, se=TRUE, interval = TRUE) 23 | predict(fm, type="class") 24 | newData <- expand.grid(temp = c("cold", "warm"), 25 | contact = c("no", "yes")) 26 | 27 | ## Predicted probabilities in all five response categories for each of 28 | ## the four cases in newData: 29 | predict(fm, newdata=newData, type="prob") 30 | predict(fm, newdata=newData, type="class") 31 | 32 | predict(fm, newdata=newData, type="prob", se.fit = TRUE, interval = TRUE) 33 | 34 | 35 | ## Aranda-Ordaz link: 36 | fm <- clm(rating ~ contact + temp, data=wine, link="Aranda-Ordaz") 37 | fm 38 | summary(fm) 39 | vcov(fm) 40 | logLik(fm) 41 | extractAIC(fm) 42 | fm2 <- update(fm, link="logit") 43 | anova(fm, fm2) 44 | head(model.matrix(fm)$X) 45 | head(model.frame(fm)) 46 | coef(fm) 47 | coef(summary(fm)) 48 | nobs(fm) 49 | terms(fm) 50 | # profile(fm) # not implemented 51 | confint(fm) 52 | 53 | predict(fm, se=TRUE, interval = TRUE) 54 | predict(fm, type="class") 55 | newData <- expand.grid(temp = c("cold", "warm"), 56 | contact = c("no", "yes")) 57 | 58 | ## Predicted probabilities in all five response categories for each of 59 | ## the four cases in newData: 60 | predict(fm, newdata=newData, type="prob") 61 | predict(fm, newdata=newData, type="class") 62 | 63 | predict(fm, newdata=newData, type="prob", se.fit = TRUE, interval = TRUE) 64 | 65 | ######################################################################## 66 | ### Models with scale + flex link (or cauchit link) 67 | ######################################################################## 68 | 69 | fm <- clm(SURENESS ~ PRODID, scale=~PROD, data = soup, link="Aranda-Ordaz") 70 | summary(fm) 71 | 72 | fm <- clm(SURENESS ~ PRODID, scale=~PROD, data = soup, link="log-gamma") 73 | summary(fm) 74 | 75 | fm <- clm(SURENESS ~ PRODID, scale=~PROD, data = soup, link="cauchit") 76 | summary(fm) 77 | 78 | ######################################################################## 79 | ### clm.fit 80 | ######################################################################## 81 | 82 | ## Example with log-gamma: 83 | fm1 <- clm(rating ~ contact + temp, data=wine, link="log-gamma") 84 | summary(fm1) 85 | ## get the model frame containing y and X: 86 | mf1 <- update(fm1, method="design") 87 | names(mf1) 88 | res <- clm.fit(mf1$y, mf1$X, link="log-gamma") ## invoking the factor method 89 | coef(res) 90 | stopifnot(all.equal(coef(res), coef(fm1))) 91 | 92 | ## Example with Aranda-Ordaz: 93 | fm1 <- clm(rating ~ contact + temp, data=wine, link="Aranda-Ordaz") 94 | mf1 <- update(fm1, method="design") 95 | res <- clm.fit(mf1$y, mf1$X, link="Aranda") ## invoking the factor method 96 | stopifnot(all.equal(coef(res), coef(fm1))) 97 | 98 | -------------------------------------------------------------------------------- /tests/test.clm.model.matrix.R: -------------------------------------------------------------------------------- 1 | library(ordinal) 2 | ## source("test.clm.model.matrix.R") 3 | 4 | ## library(devtools) 5 | ## r2path <- "/Users/rhbc/Documents/Rpackages/ordinal/pkg/ordinal" 6 | ## clean_dll(pkg = r2path) 7 | ## load_all(r2path) 8 | 9 | ## Check that get_clmDesign works in standard setting: 10 | fm1 <- clm(rating ~ temp, scale=~contact, nominal=~contact, data=wine) 11 | contr <- c(fm1$contrasts, fm1$S.contrasts, fm1$nom.contrasts) 12 | XX <- ordinal:::get_clmDesign(fm1$model, terms(fm1, "all"), contrasts=contr) 13 | XX2 <- update(fm1, method="design") 14 | (keep <- intersect(names(XX), names(XX2))) 15 | (test <- mapply(function(x, y) isTRUE(all.equal(x, y)), 16 | XX[keep], XX2[keep])) 17 | stopifnot(all(test)) 18 | 19 | ## Check that get_clmDesign works with singular fit and NAs: 20 | cy <- with(wine, which(temp == "cold" & contact == "yes")) 21 | wine2 <- subset(wine, subset=(!1:nrow(wine) %in% cy)) 22 | wine2[c(9, 15, 46), "rating"] <- NA 23 | fm1 <- clm(rating ~ temp, scale=~contact, nominal=~contact, 24 | data=wine2) 25 | contr <- c(fm1$contrasts, fm1$S.contrasts, fm1$nom.contrasts) 26 | XX <- ordinal:::get_clmDesign(fm1$model, terms(fm1, "all"), contrasts=contr) 27 | XX2 <- update(fm1, method="design") 28 | (keep <- intersect(names(XX), names(XX2))) 29 | (test <- mapply(function(x, y) isTRUE(all.equal(x, y)), 30 | XX[keep], XX2[keep])) 31 | stopifnot(all(test)) 32 | 33 | ## In this situation update and get_clmRho give the same results: 34 | wine2 <- wine 35 | fm1 <- clm(rating ~ temp + contact, data=wine2) ## OK 36 | rho1 <- ordinal:::get_clmRho.clm(fm1) 37 | l1 <- as.list(rho1) 38 | l2 <- as.list(update(fm1, doFit=FALSE)) 39 | (test <- mapply(function(x, y) isTRUE(all.equal(x, y)), 40 | l1, l2[names(l1)])) 41 | stopifnot(all(test)) 42 | ## If we modify the data (or other subset, weights, formulae, etc.) 43 | ## used in the model call, the results from update no longer correspond 44 | ## to the elements of the fitted model object. get_clmRho gets it 45 | ## right on the other hand: 46 | wine2[10:13, "rating"] <- NA 47 | l3 <- as.list(ordinal:::get_clmRho.clm(fm1)) 48 | l4 <- as.list(update(fm1, doFit=FALSE)) 49 | (test <- mapply(function(x, y) isTRUE(all.equal(x, y)), 50 | l1, l3)) 51 | stopifnot(all(test)) ## same 52 | (test <- mapply(function(x, y) isTRUE(all.equal(x, y)), 53 | l3, l4[names(l3)])) 54 | stopifnot(sum(!test) == 8) ## not all the same anymore! 55 | ## In conclusion l1, l2, and l3 are identical. l4 is different. 56 | 57 | ################################# 58 | ## Test that checkContrasts give appropriate warnings: 59 | contr <- c(temp="contr.sum", contact="contr.sum") 60 | fm1 <- clm(rating ~ temp + contact, scale=~contact, data=wine) ## OK 61 | fm1 <- clm(rating ~ temp + contact, scale=~contact, data=wine, 62 | contrasts=contr) ## OK 63 | fm1 <- clm(rating ~ temp, scale=~contact, data=wine, 64 | contrasts=contr) ## OK 65 | ## These should give warnings: 66 | fm1 <- clm(rating ~ temp, contrasts=c(contact="contr.sum"), data=wine) 67 | fm1 <- clm(rating ~ temp, contrasts=contr, data=wine) 68 | fm1 <- clm(rating ~ 1, scale=~contact, contrasts=c(temp="contr.sum"), 69 | data=wine) 70 | fm1 <- clm(rating ~ 1, scale=~contact, contrasts=list(temp="contr.sum"), 71 | data=wine) 72 | 73 | fm0 <- clm(rating ~ temp + contact, scale=~contact, data=wine) 74 | ordinal:::checkContrasts(fm0$S.terms, fm0$contrasts) 75 | ordinal:::checkContrasts(fm0$S.terms, fm0$S.contrasts) 76 | ordinal:::checkContrasts(fm0$terms, fm0$contrasts) 77 | ordinal:::checkContrasts(fm0$terms, fm0$S.contrasts) 78 | 79 | ################################# 80 | ## Check that clm and model.matrix respects contrast settings: 81 | options("contrasts" = c("contr.treatment", "contr.poly")) 82 | fm0 <- clm(rating ~ temp + contact, data=wine) 83 | options("contrasts" = c("contr.sum", "contr.poly")) 84 | fm1 <- clm(rating ~ temp + contact, data=wine) 85 | stopifnot(all(model.matrix(fm0)$X[, 2] %in% c(0, 1))) 86 | stopifnot(all(model.matrix(fm1)$X[, 2] %in% c(1, -1))) 87 | 88 | ################################# 89 | ## Check that model.matrix results do not depend on global contrast 90 | ## setting: 91 | options("contrasts" = c("contr.sum", "contr.poly")) 92 | fm0 <- clm(rating ~ temp + contact, scale=~contact, data=wine) 93 | MM <- model.matrix(fm0) 94 | options("contrasts" = c("contr.treatment", "contr.poly")) 95 | MM2 <- model.matrix(fm0) 96 | for(x in MM) print(head(x)) 97 | for(x in MM2) print(head(x)) 98 | stopifnot(all(mapply(all.equal, MM, MM2))) 99 | 100 | ################################# 101 | ## This gave a warning before getContrasts was implemented: 102 | fm0 <- clm(rating ~ temp + contact, scale=~contact, data=wine) 103 | MM <- model.matrix(fm0) 104 | ## > fm0 <- clm(rating ~ temp + contact, scale=~contact, data=wine) 105 | ## > MM <- model.matrix(fm0) 106 | ## Warning message: 107 | ## In model.matrix.default(res$S.terms, data = fullmf, contrasts.arg = getContrasts(res$S.terms, : 108 | ## variable 'temp' is absent, its contrast will be ignored 109 | for(x in MM) print(head(x)) 110 | 111 | -------------------------------------------------------------------------------- /tests/test.clm.profile.R: -------------------------------------------------------------------------------- 1 | library(ordinal) 2 | 3 | ## Testing that the profile remains the same - that the model object 4 | ## is not 'distorted' by update(object/fitted, doFit=FALSE) 5 | set.seed(1234) 6 | wts <- runif(nrow(wine), 0, 2) 7 | fm3 <- clm(rating ~ temp + contact, data=wine, 8 | weights=wts) 9 | pr <- profile(fm3) 10 | 11 | set.seed(1234) 12 | fm3 <- clm(rating ~ temp + contact, data=wine, 13 | weights=runif(nrow(wine), 0, 2)) 14 | pr3 <- profile(fm3) 15 | ## > set.seed(1234) 16 | ## > fm3 <- clm(rating ~ temp + contact, data=wine, 17 | ## + weights=runif(nrow(wine), 0, 2)) 18 | ## > pr3 <- profile(fm3) 19 | ## Warning messages: 20 | ## 1: In profile.clm.beta(fitted, which.beta, alpha, max.steps, nsteps, : 21 | ## profile may be unreliable for tempwarm because only 1 22 | ## steps were taken down 23 | ## 2: In profile.clm.beta(fitted, which.beta, alpha, max.steps, nsteps, : 24 | ## profile may be unreliable for tempwarm because only 1 25 | ## steps were taken up 26 | ## 3: In profile.clm.beta(fitted, which.beta, alpha, max.steps, nsteps, : 27 | ## profile may be unreliable for contactyes because only 1 28 | ## steps were taken down 29 | ## 4: In profile.clm.beta(fitted, which.beta, alpha, max.steps, nsteps, : 30 | ## profile may be unreliable for contactyes because only 1 31 | ## steps were taken up 32 | ## 33 | stopifnot(isTRUE(all.equal(pr, pr3, check.attributes=FALSE))) 34 | stopifnot( 35 | isTRUE(all.equal(pr$tempwarm[, "lroot"], pr3$tempwarm[, "lroot"])), 36 | isTRUE(all.equal(pr$contactyes[, "lroot"], pr3$contactyes[, "lroot"]))) 37 | -------------------------------------------------------------------------------- /tests/test.clm.single.anova.R: -------------------------------------------------------------------------------- 1 | # test.clm.single.anova.R 2 | 3 | library(ordinal) 4 | 5 | # WRE says "using if(requireNamespace("pkgname")) is preferred, if possible." 6 | # even in tests: 7 | assertError <- function(expr, ...) 8 | if(requireNamespace("tools")) tools::assertError(expr, ...) else invisible() 9 | assertWarning <- function(expr, ...) 10 | if(requireNamespace("tools")) tools::assertWarning(expr, ...) else invisible() 11 | 12 | fm <- clm(rating ~ temp * contact, scale=~contact, data=wine) 13 | 14 | anova(fm, type="I") 15 | anova(fm, type="II") 16 | anova(fm, type="III") 17 | anova(fm, type=1) 18 | anova(fm, type=2) 19 | anova(fm, type=3) 20 | anova(fm, type="1") 21 | anova(fm, type="2") 22 | anova(fm, type="3") 23 | anova(fm, type="marginal") 24 | 25 | # Nominal effects: 26 | fm <- clm(rating ~ temp, nominal=~contact, data=wine) 27 | anova(fm) 28 | 29 | # Flexible links: 30 | fm1 <- clm(rating ~ temp + contact, link="log-gamma", data=wine) 31 | anova(fm1, type=1) 32 | anova(fm1, type=2) 33 | anova(fm1, type=3) 34 | 35 | # Equivalence of tests irrespective of contrasts: 36 | fm1 <- clm(SURENESS ~ PRODID * SOUPFREQ, data=soup) 37 | # summary(fm1) 38 | (an1 <- anova(fm1, type=3)) 39 | fm2 <- clm(SURENESS ~ PRODID * SOUPFREQ, data=soup, 40 | contrasts = list(SOUPFREQ = "contr.sum", PRODID = "contr.SAS")) 41 | # summary(fm2) 42 | anova(fm1, fm2) 43 | (an2 <- anova(fm2, type=3)) 44 | stopifnot( 45 | isTRUE(all.equal(an1, an2, check.attributes=FALSE)) 46 | ) 47 | 48 | 49 | # Aliased coefficients: 50 | fm1 <- clm(SURENESS ~ PRODID * DAY, data=soup) 51 | anova(fm1, type=1) 52 | anova(fm1, type=2) 53 | anova(fm1, type=3) 54 | 55 | # Aliased term (due to nominal effects): 56 | fm <- clm(rating ~ temp * contact, nominal=~contact, data=wine) 57 | anova(fm, type=1) 58 | anova(fm, type=2) 59 | anova(fm, type=3) 60 | 61 | # model with all NA in vcov(object): 62 | fm <- clm(rating ~ temp * contact, nominal=~contact, scale=~contact, data=wine) 63 | assertError(anova(fm, type=1)) # error 64 | assertError(anova(fm, type=2)) # error 65 | assertError(anova(fm, type=3)) # error 66 | all(is.na(vcov(fm))) 67 | -------------------------------------------------------------------------------- /tests/test.general.R: -------------------------------------------------------------------------------- 1 | 2 | txt <- citation("ordinal") 3 | stopifnot(as.logical(grep("year", txt))) 4 | -------------------------------------------------------------------------------- /tests/test.makeThresholds.R: -------------------------------------------------------------------------------- 1 | # test.makeThresholds.R 2 | 3 | library(ordinal) 4 | 5 | # Prvious bug which is now fixed: 6 | res <- ordinal:::makeThresholds(letters[1:3], "symmetric") 7 | stopifnot(length(res$alpha.names) == res$nalpha) 8 | # length(res$alpha.names) used to be 4 9 | 10 | # Real data example: 11 | wine <- within(wine, { 12 | rating_comb3b <- rating 13 | levels(rating_comb3b) <- c("1-2", "1-2", "3", "4-5", "4-5") 14 | }) 15 | wine$rating_comb3b[1] <- "4-5" # Need to remove the zero here to avoid inf MLE 16 | ftable(rating_comb3b ~ temp + contact, data=wine) 17 | 18 | fm.comb3_c <- clm(rating_comb3b ~ contact, #scale=~contact, 19 | threshold = "symmetric", data=wine) # no error 20 | -------------------------------------------------------------------------------- /tests/test.sign.R: -------------------------------------------------------------------------------- 1 | # test.sign.R 2 | 3 | # Test the use of sign.location and sign.nominal in clm.control(): 4 | 5 | library(ordinal) 6 | 7 | fm1 <- clm(rating ~ temp + contact, data=wine) 8 | fm2 <- clm(rating ~ temp + contact, data=wine, 9 | sign.location="positive") 10 | # dput(names(fm1)) 11 | keep <- c("aliased", "alpha", "cond.H", 12 | "contrasts", "convergence", "df.residual", "edf", 13 | "fitted.values", "formula", "formulas", "gradient", 14 | "info", "link", "logLik", "maxGradient", "message", "model", 15 | "n", "niter", "nobs", "start", "terms", "Theta", "threshold", 16 | "tJac", "xlevels", "y", "y.levels") 17 | check <- mapply(function(x, y) isTRUE(all.equal(x, y)), fm1[keep], fm2[keep]) 18 | stopifnot(all(check)) 19 | stopifnot(isTRUE(all.equal( 20 | fm1$beta, - fm2$beta 21 | ))) 22 | 23 | fm1 <- clm(rating ~ temp, nominal=~ contact, data=wine) 24 | fm2 <- clm(rating ~ temp, nominal=~ contact, data=wine, 25 | sign.nominal="negative") 26 | keep <- c("aliased", "beta", "cond.H", 27 | "contrasts", "convergence", "df.residual", "edf", 28 | "fitted.values", "formula", "formulas", "gradient", 29 | "info", "link", "logLik", "maxGradient", "message", "model", 30 | "n", "niter", "nobs", "start", "terms", "Theta", "threshold", 31 | "tJac", "xlevels", "y", "y.levels") 32 | # check <- mapply(function(x, y) isTRUE(all.equal(x, y)), fm1, fm2) 33 | check <- mapply(function(x, y) isTRUE(all.equal(x, y)), fm1[keep], fm2[keep]) 34 | stopifnot(all(check)) 35 | stopifnot(isTRUE(all.equal( 36 | fm1$alpha[5:8], -fm2$alpha[5:8] 37 | ))) 38 | 39 | 40 | fm1 <- clm(rating ~ temp, nominal=~ contact, data=wine) 41 | fm2 <- clm(rating ~ temp, nominal=~ contact, data=wine, 42 | sign.nominal="negative", sign.location="positive") 43 | keep <- c("aliased", "cond.H", 44 | "contrasts", "convergence", "df.residual", "edf", 45 | "fitted.values", "formula", "formulas", "gradient", 46 | "info", "link", "logLik", "maxGradient", "message", "model", 47 | "n", "niter", "nobs", "start", "terms", "Theta", "threshold", 48 | "tJac", "xlevels", "y", "y.levels") 49 | # check <- mapply(function(x, y) isTRUE(all.equal(x, y)), fm1, fm2) 50 | check <- mapply(function(x, y) isTRUE(all.equal(x, y)), fm1[keep], fm2[keep]) 51 | stopifnot(all(check)) 52 | stopifnot( 53 | isTRUE(all.equal(fm1$alpha[5:8], -fm2$alpha[5:8])), 54 | isTRUE(all.equal(fm1$beta, -fm2$beta)) 55 | ) 56 | 57 | # Check predict method: 58 | newData <- with(wine, expand.grid(temp=levels(temp), contact=levels(contact))) 59 | (p1 <- predict(fm1, newdata=newData)) 60 | (p2 <- predict(fm2, newdata=newData)) 61 | stopifnot(isTRUE(all.equal(p1, p2))) 62 | 63 | stopifnot(isTRUE( 64 | all.equal(predict(fm1, newdata=wine, se=TRUE, interval=TRUE), 65 | predict(fm2, newdata=wine, se=TRUE, interval=TRUE)) 66 | )) 67 | 68 | # Check profile and confint methods: 69 | confint.default(fm1) 70 | confint.default(fm2) 71 | 72 | stopifnot( 73 | isTRUE(all.equal(confint(fm1), -confint(fm2)[, 2:1, drop=FALSE], 74 | check.attributes=FALSE)) 75 | ) 76 | 77 | fm1 <- clm(rating ~ temp + contact, data=wine) 78 | fm2 <- clm(rating ~ temp + contact, data=wine, 79 | sign.location="positive") 80 | pr1 <- profile(fm1) 81 | pr2 <- profile(fm2) 82 | stopifnot( 83 | isTRUE(all.equal(confint(fm1), - confint(fm2)[, 2:1], check.attributes=FALSE)) 84 | ) 85 | 86 | -------------------------------------------------------------------------------- /tests/test0weights.R: -------------------------------------------------------------------------------- 1 | library(ordinal) 2 | options(contrasts = c("contr.treatment", "contr.poly")) 3 | ## library(devtools) 4 | ## r2path <- "/Users/rhbc/Documents/Rpackages/ordinal/pkg/ordinal" 5 | ## clean_dll(pkg = r2path) 6 | ## load_all(r2path) 7 | 8 | ## one zero weight: 9 | data(wine, package="ordinal") 10 | wts <- rep(1, nrow(wine)) 11 | wine$rating 12 | wts[1] <- 0 13 | fm1 <- clm(rating ~ contact + temp, data=wine, weights=wts) 14 | fm1 15 | fm1$n ## 72 16 | fm1$nobs ## 71 17 | confint(fm1) 18 | plot(profile(fm1)) 19 | plot(slice(fm1), 5) 20 | convergence(fm1) 21 | drop1(fm1, test="Chi") 22 | add1(fm1, scope=~.^2, test="Chi") 23 | ## clm_anova(fm1) 24 | pred <- predict(fm1, newdata=wine) ## OK 25 | step.fm1 <- step(fm1, trace=0) 26 | fitted(fm1) 27 | dim(model.matrix(fm1)$X) 28 | dim(model.matrix(fm1, "B")$B1) 29 | mf <- update(fm1, method="model.frame") 30 | str(mf) 31 | wts <- mf$wts 32 | dim(model.matrix(fm1)$X[wts > 0, , drop=FALSE]) 33 | 34 | fm1b <- clm(rating ~ temp, scale=~contact, data=wine, weights=wts) 35 | summary(fm1b) 36 | pr <- profile(fm1b) 37 | confint(pr) 38 | plot(pr, 1) 39 | fm1c <- clm(rating ~ temp, nominal=~contact, data=wine, weights=wts) 40 | summary(fm1c) 41 | pr <- profile(fm1c) 42 | confint(pr) 43 | plot(pr, 1) 44 | 45 | ## nominal.test(fm1) 46 | ## scale.test(fm1) 47 | 48 | ## zero out an entire response category: 49 | wts2 <- 1 * with(wine, rating != "2") 50 | fm2 <- clm(rating ~ contact + temp, data=wine, weights=wts2) 51 | fm2 52 | fm2$n ## 72 53 | fm2$nobs ## 50 54 | ## Dimension of X and B1, B2 differ: 55 | dim(model.matrix(fm2)$X) 56 | dim(model.matrix(fm2, "B")$B1) 57 | ## Cannot directly evaluate predictions on the original data: 58 | try(predict(fm2, newdata=wine), silent=TRUE)[1] 59 | confint(fm2) 60 | profile(fm2) 61 | plot(slice(fm2), 5) 62 | step.fm2 <- step(fm2, trace=0) 63 | fitted(fm2) 64 | ## Scale and nominal effects: 65 | fm2b <- clm(rating ~ temp, scale=~contact, data=wine, weights=wts2) 66 | summary(fm2b) 67 | pr <- profile(fm2b) 68 | confint(pr) 69 | plot(pr, 1) 70 | fm2c <- clm(rating ~ temp, nominal=~contact, data=wine, weights=wts2) 71 | summary(fm2c) 72 | pr <- profile(fm2c) 73 | confint(pr) 74 | plot(pr, 1) 75 | pred <- predict(fm2c, newdata=wine[!names(wine) %in% "rating"]) 76 | pred <- predict(fm2b, newdata=wine[!names(wine) %in% "rating"]) 77 | 78 | ## nominal.test(fm2) 79 | ## scale.test(fm2) 80 | 81 | ## Different data sets (error): 82 | try(anova(fm1, fm2), silent=TRUE)[1] ## OK 83 | 84 | ## Test clm.fit: 85 | wts2 <- 1 * with(wine, rating != "2") 86 | mf2 <- update(fm2, method="design") 87 | fm3 <- with(mf2, clm.fit(y, X, weights=wts)) 88 | 89 | ################################# 90 | -------------------------------------------------------------------------------- /tests/testAnova.clm2.R: -------------------------------------------------------------------------------- 1 | library(ordinal) 2 | options(contrasts = c("contr.treatment", "contr.poly")) 3 | 4 | ## More manageable data set: 5 | (tab26 <- with(soup, table("Product" = PROD, "Response" = SURENESS))) 6 | dimnames(tab26)[[2]] <- c("Sure", "Not Sure", "Guess", "Guess", "Not Sure", "Sure") 7 | dat26 <- expand.grid(sureness = as.factor(1:6), prod = c("Ref", "Test")) 8 | dat26$wghts <- c(t(tab26)) 9 | m1 <- clm(sureness ~ prod, scale = ~prod, data = dat26, 10 | weights = wghts, link = "logit") 11 | 12 | ## anova 13 | m2 <- update(m1, scale = ~1) 14 | anova(m1, m2) 15 | mN1 <- clm(sureness ~ 1, nominal = ~prod, data = dat26, 16 | link = "logit") 17 | anova(m1, mN1) 18 | anova(m1, m2, mN1) 19 | 20 | ## dropterm 21 | if(require(MASS)) { 22 | dropterm(m1, test = "Chi") 23 | mB1 <- clm(SURENESS ~ PROD + GENDER + SOUPTYPE, 24 | scale = ~ COLD, data = soup, link = "probit") 25 | dropterm(mB1, test = "Chi") # or 26 | 27 | ## addterm 28 | addterm(mB1, scope = ~.^2, test = "Chi") 29 | ## addterm(mB1, scope = ~ . + AGEGROUP + SOUPFREQ, 30 | ## test = "Chi", which = "location") 31 | ## addterm(mB1, scope = ~ . + GENDER + SOUPTYPE, 32 | ## test = "Chi", which = "scale") 33 | 34 | ## Fit model from polr example: 35 | ## data(housing, package = "MASS") 36 | 37 | fm1 <- clm(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) 38 | ## addterm(fm1, ~ Infl + Type + Cont, test= "Chisq", which = "scale") 39 | dropterm(fm1, test = "Chisq") 40 | fm2 <- update(fm1, scale =~ Cont) 41 | fm3 <- update(fm1, formula =~.-Cont, nominal =~ Cont) 42 | anova(fm1, fm2, fm3) 43 | } 44 | 45 | -------------------------------------------------------------------------------- /tests/testthat/test-clm-predict.R: -------------------------------------------------------------------------------- 1 | context("Test that clm.predict gives warnings if prevars is absent") 2 | 3 | fm1 <- clm(rating ~ temp + contact, data=wine) 4 | newData <- expand.grid(temp=levels(wine$temp), 5 | contact=levels(wine$contact)) 6 | expect_false(givesWarnings( 7 | predict(fm1, newdata=newData) 8 | )) 9 | attr(fm1$terms, "predvars") <- NULL 10 | expect_warning( 11 | predict(fm1, newdata=newData) 12 | , "terms object does not have a predvars attribute") 13 | 14 | -------------------------------------------------------------------------------- /tests/testthat/test-clm-profile.R: -------------------------------------------------------------------------------- 1 | context("Testing error message from profile.clm") 2 | 3 | expect_warning( 4 | fm2 <- clm(rating ~ contact, scale=~contact, nominal=~contact, 5 | data=wine) 6 | , "\\(1\\) Hessian is numerically singular") 7 | 8 | expect_error(profile(fm2) 9 | , "Cannot get profile when vcov\\(fitted\\) contains NAs") 10 | 11 | -------------------------------------------------------------------------------- /tests/testthat/test-clm.R: -------------------------------------------------------------------------------- 1 | 2 | context("Appropriate error and warning messages from clm()") 3 | 4 | test_that("formula is specified in clm", { 5 | expect_error(clm(nominal=~contact, data=wine), 6 | "Model needs a formula") 7 | expect_error(clm(scale=~contact, data=wine), 8 | "Model needs a formula") 9 | expect_error(clm(), 10 | "Model needs a formula") 11 | }) 12 | 13 | test_that("response is not in scale or nominal", { 14 | ## No response in formula: 15 | expect_error( 16 | fm <- clm(~ temp + contact, data=wine) 17 | , "'formula' needs a response") 18 | ## response in scale: 19 | expect_error( 20 | fm <- clm(rating ~ temp, scale=rating ~ contact, data=wine) 21 | , "response not allowed in 'scale'") 22 | expect_error( 23 | fm <- clm(rating ~ temp, nominal=rating ~ contact, data=wine) 24 | , "response not allowed in 'nominal'") 25 | wine2 <- wine 26 | wine2$rate <- as.numeric(as.character(wine2$rating)) 27 | expect_error( 28 | fm <- clm(rate ~ temp + contact, data=wine2) 29 | , "response in 'formula' needs to be a factor") 30 | }) 31 | 32 | test_that("offset is allowed in formula, but not in scale and nominal", 33 | { 34 | wine2 <- wine 35 | set.seed(1) 36 | wine2$off <- runif(nrow(wine)) 37 | ## offset in formula is fine: 38 | expect_is( 39 | clm(rating ~ temp + contact + offset(off), data=wine2) 40 | , "clm") 41 | expect_is( 42 | clm(rating ~ offset(off), nominal=~contact, data=wine2) 43 | , "clm") ## no other terms in formula. 44 | ## offset in scale is also fine: 45 | expect_is( 46 | clm(rating ~ temp, scale=~contact + offset(off), data=wine2) 47 | , "clm") 48 | expect_is( 49 | clm(rating ~ contact + temp, scale=~offset(off), data=wine2) 50 | , "clm") ## no other terms in scale. 51 | ## offset as argument is not allowed: 52 | expect_error( 53 | clm(rating ~ temp + contact, offset=off, data=wine2) 54 | , "offset argument not allowed: specify 'offset' in formula or scale arguments instead") 55 | ## offset in nominal is not allowed: 56 | expect_error( 57 | clm(rating ~ temp, nominal=~contact + offset(off), data=wine2) 58 | , "offset not allowed in 'nominal'") 59 | expect_error( 60 | clm(rating ~ temp, nominal=~1 + offset(off), data=wine2) 61 | , "offset not allowed in 'nominal'") 62 | }) 63 | 64 | 65 | test_that("Intercept is needed and assumed", { 66 | expect_is( 67 | fm <- clm(rating ~ 1, data=wine) 68 | , "clm") 69 | expect_warning( 70 | fm <- clm(rating ~ -1 + temp, data=wine) 71 | , "an intercept is needed and assumed in 'formula'") 72 | expect_warning( 73 | fm <- clm(rating ~ 0 + temp, data=wine) 74 | , "an intercept is needed and assumed in 'formula'") 75 | expect_warning( 76 | fm <- clm(rating ~ 0, data=wine) 77 | , "an intercept is needed and assumed in 'formula'") 78 | ## and similar with scale (+nominal) 79 | }) 80 | 81 | 82 | 83 | wine4 <- wine 84 | wine4 <- within(wine4, temp2 <- 1e4*as.integer(temp)) 85 | 86 | test_that("convergence messsages are printed when there are >1 codes", { 87 | expect_warning( 88 | fm1 <- clm(rating ~ temp2 + contact, data=wine4) 89 | , "very large eigenvalue") 90 | }) 91 | 92 | ## test_that("", { 93 | ## 94 | ## }) 95 | -------------------------------------------------------------------------------- /tests/testthat/test-clmm-checkRanef.R: -------------------------------------------------------------------------------- 1 | context("Testing error-warning-message from clmm via checkRanef") 2 | 3 | ## Make example with more random effects than observations: 4 | wine$fake <- factor(c(1:65, 1:65)[1:nrow(wine)]) 5 | wine$fakeToo <- factor(1:nrow(wine)) 6 | 7 | ## Check warning, error and 'message' messages: 8 | expect_warning( 9 | fmm2 <- clmm(rating ~ temp + contact + (1|judge) + (1|fake), data=wine) 10 | , "no. random effects") 11 | 12 | expect_warning( 13 | fmm2 <- clmm(rating ~ temp + contact + (1|judge) + (1|fake), data=wine, 14 | checkRanef="warn") 15 | , "no. random effects") 16 | 17 | expect_error( 18 | fmm2 <- clmm(rating ~ temp + contact + (1|judge) + (1|fake), data=wine, 19 | checkRanef="error") 20 | , "no. random effects") 21 | 22 | expect_message( 23 | fmm2 <- clmm(rating ~ temp + contact + (1|judge) + (1|fake), data=wine, 24 | checkRanef="message") 25 | , "no. random effects") 26 | 27 | expect_error( 28 | fmm2 <- clmm(rating ~ temp + contact + (1|fakeToo), data=wine, 29 | checkRanef="error") 30 | , "no. random effects") 31 | 32 | expect_error( 33 | fmm2 <- clmm(rating ~ temp + contact + (1|judge) + (1|fakeToo), data=wine, 34 | checkRanef="error") 35 | , "no. random effects") 36 | -------------------------------------------------------------------------------- /tests/testthat/test-contrasts.R: -------------------------------------------------------------------------------- 1 | context("Contrast specification") 2 | 3 | test_that("clm gives contrast warnings when it should", { 4 | ## No warnings: 5 | ## Different combinations of terms i various formulae. Note that the 6 | ## contrasts apply to e.g. 'contact' in both 'formula' and 'scale': 7 | contr <- c(temp="contr.sum", contact="contr.sum") 8 | expect_false(givesWarnings( 9 | fm1 <- clm(rating ~ temp + contact, scale=~contact, data=wine) ## OK 10 | )) 11 | # expect_false(givesWarnings( 12 | # fm1 <- clm(rating ~ temp + contact, scale=~contact, data=wine, 13 | # contrasts=contr) ## OK 14 | # )) 15 | # expect_false(givesWarnings( 16 | # fm1 <- clm(rating ~ temp, scale=~contact, data=wine, 17 | # contrasts=contr) ## OK 18 | # )) 19 | # expect_false(givesWarnings( 20 | # fm1 <- clm(rating ~ temp, nominal=~contact, data=wine, 21 | # contrasts=contr) ## OK 22 | # )) 23 | # expect_false(givesWarnings( 24 | # fm1 <- clm(rating~1, scale=~temp, nominal=~contact, data=wine, 25 | # contrasts=contr) ## OK 26 | # )) 27 | 28 | ## These should give warnings: 29 | ## A warning is given if a variable is not present in any of the 30 | ## formulae: 31 | expect_warning( 32 | fm <- clm(rating ~ temp, contrasts=c(contact="contr.sum"), data=wine) 33 | , "variable 'contact' is absent: its contrasts will be ignored") 34 | expect_warning( 35 | fm <- clm(rating ~ temp, contrasts=contr, data=wine) 36 | , "variable 'contact' is absent: its contrasts will be ignored") 37 | expect_warning( 38 | fm <- clm(rating ~ 1, scale=~contact, contrasts=c(temp="contr.sum"), 39 | data=wine) 40 | , "variable 'temp' is absent: its contrasts will be ignored") 41 | expect_warning( 42 | fm <- clm(rating ~ 1, scale=~contact, contrasts=list(temp="contr.sum"), 43 | data=wine) 44 | , "variable 'temp' is absent: its contrasts will be ignored") 45 | 46 | }) 47 | 48 | test_that("checkContrasts gives when it should", { 49 | ## No warnings: 50 | fm0 <- clm(rating ~ temp + contact, scale=~contact, data=wine) 51 | expect_false( 52 | givesWarnings(checkContrasts(fm0$S.terms, fm0$S.contrasts)) 53 | ) 54 | expect_false( 55 | givesWarnings(checkContrasts(fm0$terms, fm0$contrasts)) 56 | ) 57 | expect_false( 58 | givesWarnings(checkContrasts(fm0$terms, fm0$S.contrasts)) 59 | ) 60 | expect_false( 61 | givesWarnings(checkContrasts(fm0$terms, fm0$S.contrasts)) 62 | ) 63 | ## Warning: 64 | expect_warning( 65 | checkContrasts(fm0$S.terms, fm0$contrasts) 66 | , "variable 'temp' is absent: its contrasts will be ignored") 67 | }) 68 | 69 | 70 | -------------------------------------------------------------------------------- /tests/testthat/test-misc.R: -------------------------------------------------------------------------------- 1 | context("Test of general functionality") 2 | 3 | test_that("citation reports year", { 4 | txt <- citation("ordinal") 5 | expect_true(as.logical(grep("year", txt))) 6 | }) 7 | 8 | -------------------------------------------------------------------------------- /tests/testthat/test-utils.R: -------------------------------------------------------------------------------- 1 | 2 | context("testing namedList") 3 | 4 | a <- 1 5 | b <- 2 6 | c <- 3 7 | d <- list(e=2, f=factor(letters[rep(1:2, 2)])) 8 | g <- matrix(runif(9), 3) 9 | h <- NULL 10 | 11 | test_that("namedList returns a named list", { 12 | 13 | res <- namedList(a, b, c) 14 | expect_equal(names(res), c("a", "b", "c")) 15 | expect_equivalent(res, list(a, b, c)) 16 | 17 | res <- namedList(a, b, c, d, g) 18 | expect_equal(names(res), c("a", "b", "c", "d", "g")) 19 | expect_equivalent(res, list(a, b, c, d, g)) 20 | 21 | res <- namedList(a, h) 22 | expect_equal(names(res), c("a", "h")) 23 | expect_equivalent(res, list(a, h)) 24 | }) 25 | -------------------------------------------------------------------------------- /vignettes/static_figs/fig-fig2.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/runehaubo/ordinal/59ba5b54bff3418aafcbb2ba251fff0041d888fa/vignettes/static_figs/fig-fig2.pdf -------------------------------------------------------------------------------- /vignettes/static_figs/fig-figEqui.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/runehaubo/ordinal/59ba5b54bff3418aafcbb2ba251fff0041d888fa/vignettes/static_figs/fig-figEqui.pdf -------------------------------------------------------------------------------- /vignettes/static_figs/fig-figFlex.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/runehaubo/ordinal/59ba5b54bff3418aafcbb2ba251fff0041d888fa/vignettes/static_figs/fig-figFlex.pdf -------------------------------------------------------------------------------- /vignettes/static_figs/fig-figNom2.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/runehaubo/ordinal/59ba5b54bff3418aafcbb2ba251fff0041d888fa/vignettes/static_figs/fig-figNom2.pdf -------------------------------------------------------------------------------- /vignettes/static_figs/fig-figSca.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/runehaubo/ordinal/59ba5b54bff3418aafcbb2ba251fff0041d888fa/vignettes/static_figs/fig-figSca.pdf --------------------------------------------------------------------------------