SCM Repository
Expires: Thu, 27 Nov 2025 10:10:34 -0000
Cache-Control: max-age=600
ETag: W/"4594"
[rcpp] Contents of /pkg/Rcpp/inst/unitTests/runit.stats.R
Contents of /pkg/Rcpp/inst/unitTests/runit.stats.R
Parent Directory
| 
Revision Log
Revision 4594 -
(show annotations)
Fri Nov 22 17:54:53 2013 UTC (12 years ago) by edd
File size: 11973 byte(s)
Fri Nov 22 17:54:53 2013 UTC (12 years ago) by edd
File size: 11973 byte(s)
expanded pt() unit tests to cover cases with and without ncp argument
| 1 | #!/usr/bin/r -t |
| 2 | # -*- mode: R; tab-width: 4; -*- |
| 3 | # |
| 4 | # Copyright (C) 2010 - 2013 Dirk Eddelbuettel and Romain Francois |
| 5 | # |
| 6 | # This file is part of Rcpp. |
| 7 | # |
| 8 | # Rcpp is free software: you can redistribute it and/or modify it |
| 9 | # under the terms of the GNU General Public License as published by |
| 10 | # the Free Software Foundation, either version 2 of the License, or |
| 11 | # (at your option) any later version. |
| 12 | # |
| 13 | # Rcpp is distributed in the hope that it will be useful, but |
| 14 | # WITHOUT ANY WARRANTY; without even the implied warranty of |
| 15 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 16 | # GNU General Public License for more details. |
| 17 | # |
| 18 | # You should have received a copy of the GNU General Public License |
| 19 | # along with Rcpp. If not, see <http://www.gnu.org/licenses/>. |
| 20 | |
| 21 | .runThisTest <- Sys.getenv("RunAllRcppTests") == "yes" |
| 22 | |
| 23 | if (.runThisTest) { |
| 24 | |
| 25 | .setUp <- Rcpp:::unit_test_setup( "stats.cpp" ) |
| 26 | |
| 27 | test.stats.dbeta <- function() { |
| 28 | vv <- seq(0, 1, by = 0.1) |
| 29 | a <- 0.5; b <- 2.5 |
| 30 | checkEquals(runit_dbeta(vv, a, b), |
| 31 | list( |
| 32 | NoLog = dbeta(vv, a, b), |
| 33 | Log = dbeta(vv, a, b, log=TRUE) |
| 34 | ), |
| 35 | msg = " stats.qbeta") |
| 36 | } |
| 37 | |
| 38 | test.stats.dbinom <- function( ){ |
| 39 | v <- 1:10 |
| 40 | checkEquals(runit_dbinom(v) , |
| 41 | list( |
| 42 | false = dbinom(v, 10, .5), |
| 43 | true = dbinom(v, 10, .5, TRUE ) |
| 44 | ), msg = "stats.dbinom" ) |
| 45 | } |
| 46 | |
| 47 | test.stats.dunif <- function() { |
| 48 | vv <- seq(0, 1, by = 0.1) |
| 49 | checkEquals(runit_dunif(vv), |
| 50 | list( |
| 51 | NoLog_noMin_noMax = dunif(vv), |
| 52 | NoLog_noMax = dunif(vv, 0), |
| 53 | NoLog = dunif(vv, 0, 1), |
| 54 | Log = dunif(vv, 0, 1, log=TRUE), |
| 55 | Log_noMax = dunif(vv, 0, log=TRUE) |
| 56 | #,Log_noMin_noMax = dunif(vv, log=TRUE) ## wrong answer |
| 57 | ), |
| 58 | msg = " stats.dunif") |
| 59 | } |
| 60 | |
| 61 | test.stats.dgamma <- function( ) { |
| 62 | v <- 1:4 |
| 63 | checkEquals(runit_dgamma(v), |
| 64 | list( NoLog = dgamma(v, 1.0, 1.0), |
| 65 | Log = dgamma(v, 1.0, 1.0, log = TRUE ), |
| 66 | Log_noRate = dgamma(v, 1.0, log = TRUE ) |
| 67 | ), msg = "stats.dgamma" ) |
| 68 | } |
| 69 | |
| 70 | |
| 71 | test.stats.dpois <- function( ){ |
| 72 | v <- 0:5 |
| 73 | checkEquals(runit_dpois(v) , |
| 74 | list( false = dpois(v, .5), |
| 75 | true = dpois(v, .5, TRUE ) |
| 76 | ), msg = "stats.dpois" ) |
| 77 | } |
| 78 | |
| 79 | test.stats.dnorm <- function( ) { |
| 80 | v <- seq(0.0, 1.0, by=0.1) |
| 81 | checkEquals(runit_dnorm(v), |
| 82 | list( false_noMean_noSd = dnorm(v), |
| 83 | false_noSd = dnorm(v, 0.0), |
| 84 | false = dnorm(v, 0.0, 1.0), |
| 85 | true = dnorm(v, 0.0, 1.0, log=TRUE ), |
| 86 | true_noSd = dnorm(v, 0.0, log=TRUE ), |
| 87 | true_noMean_noSd = dnorm(v, log=TRUE ) |
| 88 | ), msg = "stats.dnorm" ) |
| 89 | } |
| 90 | |
| 91 | test.stats.dt <- function( ) { |
| 92 | v <- seq(0.0, 1.0, by=0.1) |
| 93 | checkEquals(runit_dt(v), |
| 94 | list( false = dt(v, 5), |
| 95 | true = dt(v, 5, log=TRUE ) # NB: need log=TRUE here |
| 96 | ), msg = "stats.dt" ) |
| 97 | } |
| 98 | |
| 99 | test.stats.pbeta <- function( ) { |
| 100 | a <- 0.5; b <- 2.5 |
| 101 | v <- qbeta(seq(0.0, 1.0, by=0.1), a, b) |
| 102 | checkEquals(runit_pbeta(v, a, b), |
| 103 | list(lowerNoLog = pbeta(v, a, b), |
| 104 | lowerLog = pbeta(v, a, b, log=TRUE), |
| 105 | upperNoLog = pbeta(v, a, b, lower=FALSE), |
| 106 | upperLog = pbeta(v, a, b, lower=FALSE, log=TRUE) |
| 107 | ), |
| 108 | msg = " stats.pbeta" ) |
| 109 | ## Borrowed from R's d-p-q-r-tests.R |
| 110 | x <- c(.01, .10, .25, .40, .55, .71, .98) |
| 111 | pbval <- c(-0.04605755624088, -0.3182809860569, -0.7503593555585, |
| 112 | -1.241555830932, -1.851527837938, -2.76044482378, -8.149862739881) |
| 113 | checkEqualsNumeric(runit_pbeta(x, 0.8, 2)$upperLog, pbval, msg = " stats.pbeta") |
| 114 | checkEqualsNumeric(runit_pbeta(1-x, 2, 0.8)$lowerLog, pbval, msg = " stats.pbeta") |
| 115 | } |
| 116 | |
| 117 | test.stats.pbinom <- function( ) { |
| 118 | n <- 20 |
| 119 | p <- 0.5 |
| 120 | vv <- 0:n |
| 121 | checkEquals(runit_pbinom(vv, n, p), |
| 122 | list(lowerNoLog = pbinom(vv, n, p), |
| 123 | lowerLog = pbinom(vv, n, p, log=TRUE), |
| 124 | upperNoLog = pbinom(vv, n, p, lower=FALSE), |
| 125 | upperLog = pbinom(vv, n, p, lower=FALSE, log=TRUE) |
| 126 | ), |
| 127 | msg = " stats.pbinom") |
| 128 | } |
| 129 | |
| 130 | test.stats.pcauchy <- function( ) { |
| 131 | location <- 0.5 |
| 132 | scale <- 1.5 |
| 133 | vv <- 1:5 |
| 134 | checkEquals(runit_pcauchy(vv, location, scale), |
| 135 | list(lowerNoLog = pcauchy(vv, location, scale), |
| 136 | lowerLog = pcauchy(vv, location, scale, log=TRUE), |
| 137 | upperNoLog = pcauchy(vv, location, scale, lower=FALSE), |
| 138 | upperLog = pcauchy(vv, location, scale, lower=FALSE, log=TRUE) |
| 139 | ), |
| 140 | msg = " stats.pcauchy") |
| 141 | } |
| 142 | |
| 143 | test.stats.punif <- function( ) { |
| 144 | v <- qunif(seq(0.0, 1.0, by=0.1)) |
| 145 | checkEquals(runit_punif(v), |
| 146 | list(lowerNoLog = punif(v), |
| 147 | lowerLog = punif(v, log=TRUE ), |
| 148 | upperNoLog = punif(v, lower=FALSE), |
| 149 | upperLog = punif(v, lower=FALSE, log=TRUE) |
| 150 | ), |
| 151 | msg = "stats.punif" ) |
| 152 | # TODO: also borrow from R's d-p-q-r-tests.R |
| 153 | } |
| 154 | |
| 155 | test.stats.pf <- function( ) { |
| 156 | v <- (1:9)/10 |
| 157 | checkEquals(runit_pf(v), |
| 158 | list(lowerNoLog = pf(v, 6, 8, lower=TRUE, log=FALSE), |
| 159 | lowerLog = pf(v, 6, 8, log=TRUE ), |
| 160 | upperNoLog = pf(v, 6, 8, lower=FALSE), |
| 161 | upperLog = pf(v, 6, 8, lower=FALSE, log=TRUE) |
| 162 | ), |
| 163 | msg = "stats.pf" ) |
| 164 | } |
| 165 | |
| 166 | test.stats.pnf <- function( ) { |
| 167 | v <- (1:9)/10 |
| 168 | checkEquals(runit_pnf(v), |
| 169 | list(lowerNoLog = pf(v, 6, 8, ncp=2.5, lower=TRUE, log=FALSE), |
| 170 | lowerLog = pf(v, 6, 8, ncp=2.5, log=TRUE ), |
| 171 | upperNoLog = pf(v, 6, 8, ncp=2.5, lower=FALSE), |
| 172 | upperLog = pf(v, 6, 8, ncp=2.5, lower=FALSE, log=TRUE) |
| 173 | ), |
| 174 | msg = "stats.pnf" ) |
| 175 | } |
| 176 | |
| 177 | test.stats.pchisq <- function( ) { |
| 178 | v <- (1:9)/10 |
| 179 | checkEquals(runit_pchisq(v), |
| 180 | list(lowerNoLog = pchisq(v, 6, lower=TRUE, log=FALSE), |
| 181 | lowerLog = pchisq(v, 6, log=TRUE ), |
| 182 | upperNoLog = pchisq(v, 6, lower=FALSE), |
| 183 | upperLog = pchisq(v, 6, lower=FALSE, log=TRUE) |
| 184 | ), |
| 185 | msg = "stats.pchisq" ) |
| 186 | } |
| 187 | |
| 188 | test.stats.pnchisq <- function( ) { |
| 189 | v <- (1:9)/10 |
| 190 | checkEquals(runit_pnchisq(v), |
| 191 | list(lowerNoLog = pchisq(v, 6, ncp=2.5, lower=TRUE, log=FALSE), |
| 192 | lowerLog = pchisq(v, 6, ncp=2.5, log=TRUE ), |
| 193 | upperNoLog = pchisq(v, 6, ncp=2.5, lower=FALSE), |
| 194 | upperLog = pchisq(v, 6, ncp=2.5, lower=FALSE, log=TRUE) |
| 195 | ), |
| 196 | msg = "stats.pnchisq" ) |
| 197 | } |
| 198 | |
| 199 | test.stats.pgamma <- function( ) { |
| 200 | v <- (1:9)/10 |
| 201 | checkEquals(runit_pgamma(v), |
| 202 | list(lowerNoLog = pgamma(v, shape = 2.0), |
| 203 | lowerLog = pgamma(v, shape = 2.0, log=TRUE ), |
| 204 | upperNoLog = pgamma(v, shape = 2.0, lower=FALSE), |
| 205 | upperLog = pgamma(v, shape = 2.0, lower=FALSE, log=TRUE) |
| 206 | ), |
| 207 | msg = "stats.pgamma" ) |
| 208 | } |
| 209 | |
| 210 | |
| 211 | test.stats.pnorm <- function( ) { |
| 212 | v <- qnorm(seq(0.0, 1.0, by=0.1)) |
| 213 | checkEquals(runit_pnorm(v), |
| 214 | list(lowerNoLog = pnorm(v), |
| 215 | lowerLog = pnorm(v, log=TRUE ), |
| 216 | upperNoLog = pnorm(v, lower=FALSE), |
| 217 | upperLog = pnorm(v, lower=FALSE, log=TRUE) |
| 218 | ), |
| 219 | msg = "stats.pnorm" ) |
| 220 | ## Borrowed from R's d-p-q-r-tests.R |
| 221 | z <- c(-Inf,Inf,NA,NaN, rt(1000, df=2)) |
| 222 | z.ok <- z > -37.5 | !is.finite(z) |
| 223 | pz <- runit_pnorm(z) |
| 224 | checkEqualsNumeric(pz$lowerNoLog, 1 - pz$upperNoLog, msg = "stats.pnorm") |
| 225 | checkEqualsNumeric(pz$lowerNoLog, runit_pnorm(-z)$upperNoLog, msg = "stats.pnorm") |
| 226 | checkEqualsNumeric(log(pz$lowerNoLog[z.ok]), pz$lowerLog[z.ok], msg = "stats.pnorm") |
| 227 | ## FIXME: Add tests that use non-default mu and sigma |
| 228 | } |
| 229 | |
| 230 | test.stats.ppois <- function( ) { |
| 231 | vv <- 0:20 |
| 232 | checkEquals(runit_ppois(vv), |
| 233 | list(lowerNoLog = ppois(vv, 0.5), |
| 234 | lowerLog = ppois(vv, 0.5, log=TRUE), |
| 235 | upperNoLog = ppois(vv, 0.5, lower=FALSE), |
| 236 | upperLog = ppois(vv, 0.5, lower=FALSE, log=TRUE) |
| 237 | ), |
| 238 | msg = " stats.ppois") |
| 239 | } |
| 240 | |
| 241 | test.stats.pt <- function( ) { |
| 242 | v <- seq(0.0, 1.0, by=0.1) |
| 243 | checkEquals(runit_pt(v), |
| 244 | list(lowerNoLog = pt(v, 5), |
| 245 | lowerLog = pt(v, 5, log=TRUE), |
| 246 | upperNoLog = pt(v, 5, lower=FALSE), |
| 247 | upperLog = pt(v, 5, lower=FALSE, log=TRUE) ), |
| 248 | msg = "stats.pt" ) |
| 249 | } |
| 250 | |
| 251 | test.stats.pnt <- function( ) { |
| 252 | v <- seq(0.0, 1.0, by=0.1) |
| 253 | checkEquals(runit_pnt(v), |
| 254 | list(lowerNoLog = pt(v, 5, ncp=7), |
| 255 | lowerLog = pt(v, 5, ncp=7, log=TRUE), |
| 256 | upperNoLog = pt(v, 5, ncp=7, lower=FALSE), |
| 257 | upperLog = pt(v, 5, ncp=7, lower=FALSE, log=TRUE) ), |
| 258 | msg = "stats.pnt" ) |
| 259 | } |
| 260 | |
| 261 | test.stats.qbinom <- function( ) { |
| 262 | n <- 20 |
| 263 | p <- 0.5 |
| 264 | vv <- seq(0, 1, by = 0.1) |
| 265 | checkEquals(runit_qbinom_prob(vv, n, p), |
| 266 | list(lower = qbinom(vv, n, p), |
| 267 | upper = qbinom(vv, n, p, lower=FALSE) |
| 268 | ), |
| 269 | msg = " stats.qbinom") |
| 270 | } |
| 271 | |
| 272 | test.stats.qunif <- function( ) { |
| 273 | checkEquals(runit_qunif_prob(c(0, 1, 1.1, -.1)), |
| 274 | list(lower = c(0, 1, NaN, NaN), |
| 275 | upper = c(1, 0, NaN, NaN) |
| 276 | ), |
| 277 | msg = "stats.qunif" ) |
| 278 | # TODO: also borrow from R's d-p-q-r-tests.R |
| 279 | } |
| 280 | |
| 281 | test.stats.qnorm <- function( ) { |
| 282 | checkEquals(runit_qnorm_prob(c(0, 1, 1.1, -.1)), |
| 283 | list(lower = c(-Inf, Inf, NaN, NaN), |
| 284 | upper = c(Inf, -Inf, NaN, NaN) |
| 285 | ), |
| 286 | msg = "stats.qnorm" ) |
| 287 | ## Borrowed from R's d-p-q-r-tests.R and Wichura (1988) |
| 288 | checkEqualsNumeric(runit_qnorm_prob(c( 0.25, .001, 1e-20))$lower, |
| 289 | c(-0.6744897501960817, -3.090232306167814, -9.262340089798408), |
| 290 | msg = "stats.qnorm", |
| 291 | tol = 1e-15) |
| 292 | |
| 293 | checkEquals(runit_qnorm_log(c(-Inf, 0, 0.1)), |
| 294 | list(lower = c(-Inf, Inf, NaN), |
| 295 | upper = c(Inf, -Inf, NaN) |
| 296 | ), |
| 297 | msg = "stats.qnorm" ) |
| 298 | checkEqualsNumeric(runit_qnorm_log(-1e5)$lower, -447.1974945) |
| 299 | } |
| 300 | |
| 301 | test.stats.qpois.prob <- function( ) { |
| 302 | vv <- seq(0, 1, by = 0.1) |
| 303 | checkEquals(runit_qpois_prob(vv), |
| 304 | list(lower = qpois(vv, 0.5), |
| 305 | upper = qpois(vv, 0.5, lower=FALSE) |
| 306 | ), |
| 307 | msg = " stats.qpois.prob") |
| 308 | } |
| 309 | |
| 310 | test.stats.qt <- function( ) { |
| 311 | v <- seq(0.05, 0.95, by=0.05) |
| 312 | ( x1 <- runit_qt(v, 5, FALSE, FALSE) ) |
| 313 | ( x2 <- qt(v, df=5, lower=FALSE, log=FALSE) ) |
| 314 | checkEquals(x1, x2, msg="stats.qt.f.f") |
| 315 | |
| 316 | ( x1 <- runit_qt(v, 5, TRUE, FALSE) ) |
| 317 | ( x2 <- qt(v, df=5, lower=TRUE, log=FALSE) ) |
| 318 | checkEquals(x1, x2, msg="stats.qt.t.f") |
| 319 | |
| 320 | ( x1 <- runit_qt(-v, 5, FALSE, TRUE) ) |
| 321 | ( x2 <- qt(-v, df=5, lower=FALSE, log=TRUE) ) |
| 322 | checkEquals(x1, x2, msg="stats.qt.f.t") |
| 323 | |
| 324 | ( x1 <- runit_qt(-v, 5, TRUE, TRUE) ) |
| 325 | ( x2 <- qt(-v, df=5, lower=TRUE, log=TRUE) ) |
| 326 | checkEquals(x1, x2, msg="stats.qt.t.t") |
| 327 | |
| 328 | } |
| 329 | |
| 330 | # TODO: test.stats.qgamma |
| 331 | # TODO: test.stats.(dq)chisq |
| 332 | |
| 333 | } |
| root@r-forge.r-project.org | ViewVC Help |
| Powered by ViewVC 1.3.0-dev |
