[Power-commits] r40 - in pkg/sse: . R inst/slowTests/testthat man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Dec 9 18:00:08 CET 2019
Author: thofab
Date: 2019-12-09 18:00:07 +0100 (Mon, 09 Dec 2019)
New Revision: 40
Modified:
pkg/sse/ChangeLog
pkg/sse/DESCRIPTION
pkg/sse/R/power.R
pkg/sse/inst/slowTests/testthat/test-advanced.R
pkg/sse/inst/slowTests/testthat/test-updateResample.R
pkg/sse/man/refine.Rd
Log:
changes in refine() and update(), see ChangeLog for details
Modified: pkg/sse/ChangeLog
===================================================================
--- pkg/sse/ChangeLog 2019-11-11 14:25:43 UTC (rev 39)
+++ pkg/sse/ChangeLog 2019-12-09 17:00:07 UTC (rev 40)
@@ -1,7 +1,14 @@
-version 0.7-14 2019/0
+version 0.7-15 2019/0
+ change refine() to only refine the theta and xi of the example (so
+ far it was only the theta) and adding a test to
+ inst/slowTests/testthat/test-advanced.R
+
+ change update() to correctly evaluating n.iter also after changes
+ in vector of n, theta or xi and adding several tests to
+ inst/slowTests/testthat/test-updateResample.R
+version 0.7-14 2019/09/23
adding error message in update() if n.iter is smaller than
available (also adding corresponding test)
- improving example on man page of refine()
DESCRIPTION: removing 'lintr' from Suggests
version 0.7-13 2019/08/22
vignette: removing unused options
Modified: pkg/sse/DESCRIPTION
===================================================================
--- pkg/sse/DESCRIPTION 2019-11-11 14:25:43 UTC (rev 39)
+++ pkg/sse/DESCRIPTION 2019-12-09 17:00:07 UTC (rev 40)
@@ -1,7 +1,7 @@
Package: sse
Type: Package
Title: Sample Size Estimation
-Version: 0.7-14
+Version: 0.7-15
Author: Thomas Fabbro [aut, cre]
Maintainer: Thomas Fabbro <thomas.fabbro at unibas.ch>
URL: http://r-forge.r-project.org/projects/power/
Modified: pkg/sse/R/power.R
===================================================================
--- pkg/sse/R/power.R 2019-11-11 14:25:43 UTC (rev 39)
+++ pkg/sse/R/power.R 2019-12-09 17:00:07 UTC (rev 40)
@@ -397,6 +397,7 @@
invisible(sampleSize(x = object, inspect = TRUE))
})
+
setMethod("refine",
signature(object = "power"),
definition = function(object, factor = 10){
@@ -423,10 +424,18 @@
## -----
- refinedObj <- workhorse(
- object,
- theta = object at theta == object at theta.example,
- n.iter = iter.example)
+ if (is.na(object at xi.example)) {
+ refinedObj <- workhorse(
+ object,
+ theta = object at theta == object at theta.example,
+ n.iter = iter.example)
+ } else {
+ refinedObj <- workhorse(
+ object,
+ theta = object at theta == object at theta.example,
+ xi = object at xi == object at xi.example,
+ n.iter = iter.example)
+ }
## Because only the iterations of the example are increased
## during refinement this needs to be handled here correctly
refinedObj at iter.example <- iter.example
@@ -619,7 +628,7 @@
warning("But it is the same -> No changes will be done.")
} else if (!any(slot(newObj, s) %in% slot(object, s))) {
message(strwrap("It is entirly different ->
- All calculations will be done.",
+ All evaluations will be done.",
prefix = " ", initial = ""))
new.calc <- TRUE
any.change <- TRUE
@@ -627,7 +636,7 @@
& any(!(slot(newObj, s) %in% slot(object, s)))) {
message(strwrap(
"It contains some available elements ->
- The new elements will be calculated.",
+ Only the new elements will be evaluated.",
prefix = " ", initial = ""))
## --- increase n
## the increasing itself is posponed because first we
@@ -640,7 +649,7 @@
slot(object, s)))) {
message(strwrap(
"It contains only available elements ->
- No new elements will be calculated.",
+ No new elements will be evaluated.",
prefix = " ", initial = ""))
## --- shrink n
takeElements <-
@@ -667,7 +676,7 @@
warning("But it is the same -> No changes will be done.")
} else if (!any(slot(newObj, s) %in% slot(object, s))) {
message(strwrap("It is entirly different ->
- All calculations will be done.",
+ All evaluations will be done.",
prefix = " ", initial = ""))
new.calc <- TRUE
any.change <- TRUE
@@ -676,7 +685,7 @@
%in% round(slot(object, s), 10)))) {
message(strwrap(
"It contains some available elements ->
- Ony the new elements will be calculated.",
+ Only the new elements will be evaluated.",
prefix = " ", initial = ""))
## --- increase theta
increase.theta <- TRUE
@@ -687,7 +696,7 @@
< length(slot(object, s)))) {
message(strwrap(
"It contains only available elements ->
- No new elements will be calculated.",
+ No new elements will be evaluated.",
prefix = " ", initial = ""))
## --- shrink theta
takeElements <-
@@ -715,7 +724,7 @@
} else if (!any(slot(newObj, s) %in% slot(object, s))) {
message(strwrap(
"It is entirly different ->
- All calculations will be done.",
+ All evaluations will be done.",
prefix = " ", initial = ""))
new.calc <- TRUE
any.change <- TRUE
@@ -723,7 +732,7 @@
& any(!(slot(newObj, s) %in% slot(object, s)))) {
message(strwrap(
"It contains some available elements ->
- The new elements will be evaluated (later).",
+ Only the new elements will be evaluated.",
prefix = " ", initial = ""))
increase.xi <- TRUE
} else if (!new.calc
@@ -850,29 +859,17 @@
## ONLY if it did step over any change
## otherwise there is no takeObj and we do not want to
if (!new.calc & any.change) {
- #print("route A")
+ ## print("route A")
newObj <- takeObj
-
- ## ---
- ## For the "growing" we did not change n.iter but took the
- ## historic number
- ## Now we increase n.iter over the whole object
- if (!is.na(n.iter)) {
- #print("route B")
- newObj <- workhorse(newObj,
- n.iter = n.iter)
- }
}
-
-
+ }
+
### new calc
- }
-
## it is possible to update "n", "theta", "xi" AND do a new.calc
## but if we do a new.calc
## we do not need to do it also for n.iter again.
if (new.calc) {
- #print("route C")
+ ## print("route C, complete new evaluations")
## empty the historic core and fill it again
newObj at core <- array(NA,
dim = c(dim(newObj)[c("n", "theta", "xi")],
@@ -882,10 +879,11 @@
### new n.iter
} else if (!is.na(n.iter)) {
- #print("route D")
- newObj <- workhorse(object,
+ ## print("route D, increasing n.iter")
+ newObj <- workhorse(newObj,
n.iter = n.iter)
}
+
return(newObj)
})
Modified: pkg/sse/inst/slowTests/testthat/test-advanced.R
===================================================================
--- pkg/sse/inst/slowTests/testthat/test-advanced.R 2019-11-11 14:25:43 UTC (rev 39)
+++ pkg/sse/inst/slowTests/testthat/test-advanced.R 2019-12-09 17:00:07 UTC (rev 40)
@@ -48,7 +48,8 @@
b <- rnorm(n(psi), mean = theta(psi), sd = xi(psi))
w <- wilcox.test(a, b)$p.value < 0.05
t <- t.test(a, b)$p.value < 0.05
- return(c(w = w, t = t))
+ ## cat(paste("xi:", xi(psi), "theta:", theta(psi), "\n")) ## UNCOMMENT to see what is done!
+ return(c(w = w, t = t))
}
calc.parametric <- powCalc(psi.parametric,
@@ -61,6 +62,12 @@
drop = 0.1,
endpoint = "t")
+pow.w.parametric <- powEx(calc.parametric,
+ xi = 1,
+ theta = 1,
+ drop = 0.1,
+ endpoint = "w")
+
pow.t.parametric.xi05 <- powEx(calc.parametric,
xi = 0.5,
theta = 1,
@@ -94,6 +101,11 @@
expect_equal(pow.w.rf at iter, pow.w at iter)
expect_equal(pow.w.rf at iter.example, pow.w at iter * 10)
})
+test_that("refine with xi", {
+ pow.w.parametric.rf <- refine(pow.w.parametric) # check the values for xi and theta that are evaluated (cat())
+ expect_equal(pow.w.parametric.rf at iter, pow.w.parametric at iter)
+ expect_equal(pow.w.parametric.rf at iter.example, pow.w.parametric at iter * 10)
+})
test_that("powEx", {
## choosing and endpoint for example that is not part of the calc-object
Modified: pkg/sse/inst/slowTests/testthat/test-updateResample.R
===================================================================
--- pkg/sse/inst/slowTests/testthat/test-updateResample.R 2019-11-11 14:25:43 UTC (rev 39)
+++ pkg/sse/inst/slowTests/testthat/test-updateResample.R 2019-12-09 17:00:07 UTC (rev 40)
@@ -2,146 +2,196 @@
library(sse)
library(testthat)
-psi1 <- powPar(theta = seq(from = 0, to = 1, by = 0.1),
- n = seq(from = 0, to = 100, by = 10))
+
+## n
+n.l <- list(
+ n0 = seq(from = 50, to = 100, by = 10), # ..XXXX.., corse
+ n1 = seq(from = 50, to = 100, by = 5), # ..XXXX.., fine
+ n2 = c(seq(from = 50, to = 80, by = 2), # ..XXXX.., mixed
+ seq(from = 85, to = 100, by = 5)),
+ n3 = seq(from = 70, to = 100, by = 10), # ....XX.., corse subset
+ n4 = seq(from = 70, to = 150, by = 10), # ..XXXXXX, corse extendet
+ n5 = seq(from = 70, to = 150, by = 10), # ....XXXX, corse subset, extended
+ n6 = seq(from = 0, to = 150, by = 10), # XXXXXXXX, corse subset, extended
+ n7 = seq(from = 160, to = 200, by = 10), # ........XX, corse
+ n8.e = c(seq(from = 50, to = 80, by = 2), # mixed with dublicated element
+ seq(from = 80, to = 100, by = 5)),
+ n9 = 80)
+
+## theta
+theta.l <- n.l
+theta.l <- lapply(theta.l, function(x) {
+ x / 100
+})
+names(theta.l) <- sub("n", "theta", names(theta.l))
+
+## xi
+xi.l <- list(
+ xi0 = seq(from = 1, to = 3, by = 1), # ..XXXX.., corse
+ xi1 = seq(from = 1, to = 3, by = 0.5), # ..XXXX.., fixie
+ xi2 = c(seq(from = 1, to = 1, by = 1), # ..XXXX.., mixed
+ seq(from = 1.5, to = 3, by = 0.5)),
+ xi3 = seq(from = 2, to = 3, by = 1), # ....XX.., corse subset
+ xi4 = seq(from = 1, to = 5, by = 1), # ..XXXXXX, corse extendet
+ xi5 = seq(from = 2, to = 5, by = 1), # ....XXXX, corse subset, extended
+ xi6 = seq(from = 0.5, to = 5, by = 0.5), # XXXXXXXX, corse subset, extended
+ xi7 = seq(from = 4, to = 5, by = 1), # ........XX, corse
+ xi8.e = c(seq(from = 1, to = 2, by = 1), # mixed with dublicated element
+ seq(from = 2, to = 5, by = 0.5)),
+ xi9 = 2) # length 1 and existing element
+
+
+attach(n.l)
+attach(theta.l)
+attach(xi.l)
+
+
+
##
-powFun2 <- function(psi) {
+powFun0 <- function(psi) {
n <- n(psi)
theta <- theta(psi)
- return(as.logical( (n * theta) %% 2))
+ xi <- xi(psi)
+ return(as.logical( (n * theta * xi) %% 2))
}
-powFun3 <- function(psi) {
+powFun1 <- function(psi) {
n <- n(psi)
theta <- theta(psi)
- return(as.logical(n %% 2))
+ return(as.logical(n %/% 2))
}
-## correct result for
+psi0 <- powPar(n = n0,
+ theta = theta0,
+ xi = xi0)
-result1.2.x <- array(round(seq(from = 0, to = 1, by = 0.1) %*%
- t(seq(from = 0, to = 100, by = 10)) %% 2, 10),
- dim = c(11, 11, 1, 1))
-result1.2.n2 <- array(as.logical(seq(from = 0, to = 1, by = 0.1) %*%
- t(seq(from = 50, to = 100, by = 5)) %% 2),
- dim = c(11, 11, 1, 1))
-## result1.2.n5 <- array(as.logical(seq(from = 0, to = 1, by = 0.1) %*%
-## t(seq(from = 50, to = 150, by = 5)) %% 2),
-## dim = c(21, 11, 1, 1))
-## # FIXME
-result1.3.x <- array(0, dim = c(11, 11, 1, 1))
+calc0 <- powCalc(psi0, statistic = powFun0, n.iter = 99)
-##
-calc1.2.1 <- powCalc(psi1, statistic = powFun2, n.iter = 99)
+pow0 <- powEx(calc0, theta = 1, power = 0.9)
-calc1.3.1 <- powCalc(psi1, statistic = powFun3, n.iter = 99)
+pow1.2.1.rf <- refine(pow0)
-calc1.2.1.nc <- powCalc(psi1, statistic = powFun2, n.iter = 99, cluster = FALSE)
- # as calc1.2.1 but without cluster
-##
-n.new <- as.integer(seq(from = 0, to = 100, by = 5))
-n.new2 <- as.integer(seq(from = 50, to = 100, by = 5))
-n.new5 <- as.integer(seq(from = 50, to = 150, by = 5))
-theta.new <- seq(from = 0, to = 1, by = 0.05)
-theta.new4 <- 0.51
-##
-pow1.2.1 <- powEx(calc1.2.1, theta = 1, power = 0.9)
-pow1.2.1.rf <- refine(pow1.2.1)
+## correct result (cores) for n, theta, xi with powFun0
+res0 <- function(n, theta, xi){
+ res.array <- array((n %*% t(theta)),
+ ## last dimension 1 because of powfun:
+ dim = c(length(n), length(theta), length(xi), 1))
+ for (i in seq(along.with = xi)) {
+ res.array[, , i, ] <- as.logical((res.array[, , i, ] * xi[i]) %% 2)
+ }
+ return(res.array)
+}
-test_that("update without any changes", {
-#
- calc1.2.2 <- update(calc1.2.1)
- calc1.3.2 <- update(calc1.3.1)
- expect_equal(calc1.2.2 at core, result1.2.x, check.attributes = FALSE)
- expect_equal(calc1.3.2 at core, result1.3.x, check.attributes = FALSE)
-})
-test_that("n.iter", {
- ## increasing
- calc1.2.3 <- update(calc1.2.1, n.iter = 500)
- expect_equal(calc1.2.3 at core, result1.2.x, check.attributes = FALSE)
- expect_equal(calc1.2.3 at iter, 500)
- ## n.iter length > 1
- expect_warning(
- update(calc1.2.1, n.iter = c(500,100))
- )
-## update of n.iter with value < than available
- expect_error(
- update(calc1.2.1, n.iter = 50)
- )
-})
+## ------------------------------------------------------------------
+## auto test
+for (n.i in names(n.l)) {
+ for (theta.i in names(theta.l)) {
+ for (xi.i in names(xi.l)) {
+
+ ## changing all n, theta and xi AND n.iter
+ what <- paste0(
+"update(calc0,
+ n = ", n.i, ",
+ theta = ", theta.i, ",
+ xi = ", xi.i, ")@core")
+
+ ## additionally changing the statistic also
+ what2 <- paste0(
+"update(calc0,
+ n = ", n.i, ",
+ theta = ", theta.i, ",
+ xi = ", xi.i, ", statistic = powFun0)@core")
+
+ ## additionally changing the n.iter also
+ what3 <- paste0(
+"update(calc0,
+ n = ", n.i, ",
+ theta = ", theta.i, ",
+ xi = ", xi.i, ", n.iter = 111)@core")
+ cat("\n---------------------------------\n")
+ cat(what)
+ cat("\n")
+ res <- paste0("res0(", n.i, ", ", theta.i, ", ", xi.i, ")")
+ if (grepl(".e", n.i, fixed = TRUE)
+ | grepl(".e", theta.i, fixed = TRUE)
+ | grepl(".e", xi.i, fixed = TRUE)) {
+ ## expect an error
+ expect_error(eval(parse(text = what)))
+ } else {
+ ## if any n0 theta0 or xi0: expect a warning if not 7
+ if (n.i == "n0" & !(theta.i == "theta7" | xi.i == "xi7")
+ | theta.i == "theta0" & !(n.i == "n7" | xi.i == "xi7")
+ | xi.i == "xi0" & !(n.i == "n7" | theta.i == "theta7")) {
+ expect_warning(eval(parse(text = what)))
+ }
+ ## should work
+ eval(parse(text = paste0("expect_equal(",
+ paste0("suppressWarnings(",
+ what,
+ ")"),
+ ",",
+ res,
+ ", check.attributes = FALSE)")))
-test_that("increasing n within existing range of n", {
-#
- calc1.2.3 <- update(calc1.2.1, n = n.new)
-})
+ ## should work but completely new evaluation
+ cat("\n")
+ cat(what2)
+ cat("\n")
+ eval(parse(text = paste0("expect_equal(",
+ what2,
+ ",",
+ res,
+ ", check.attributes = FALSE)")))
+
+ ## should work but completely new iterations
+ cat("\n")
+ cat(what2)
+ cat("\n")
+ eval(parse(text = paste0("expect_equal(",
+ what2,
+ ",",
+ res,
+ ", check.attributes = FALSE)")))
+ }
+ }
+ }
+}
+### ------------------------------------------------------------------
-test_that("increasing theta within existing range of theta", {
-#
- calc1.2.4 <- update(calc1.2.1, theta = theta.new)
- #expect_equal(calc1.1.4 at core, result1.1.t, check.attributes = FALSE)
-})
-test_that("increasing theta and n within existing range of theta and n", {
-#
- calc1.2.5 <- update(calc1.2.1, n.iter = NA, n = n.new, theta = theta.new)
-# expect_equal(calc1.1.5 at core, result1.1.nt, check.attributes = FALSE)
-})
-
-
-test_that("update statistic only", {
+test_that("update without any changes", {
#
- calc1.2.6 <- update(calc1.2.1, statistic = powFun2)
- expect_equal(calc1.2.6 at core, result1.2.x, check.attributes = FALSE)
+ expect_equal(update(calc0)@core, res0(n0, theta0, xi0), check.attributes = FALSE)
})
-test_that("update statistic and increasing n within existing range of n", {
-#
- calc1.2.7 <- update(calc1.2.1, statistic = powFun2, n = n.new)
- calc1.2.7 <- update(calc1.2.7, n = n.new)
-# expect_equal(calc1.2.7 at core, result1.2.n, check.attributes = FALSE)
+test_that("n.iter", {
+ ## increasing
+ calc0.500 <- update(calc0, n.iter = 500)
+ expect_equal(calc0 at core, res0(n0, theta0, xi0), check.attributes = FALSE)
+ expect_equal(calc0.500 at iter, 500)
+ ## n.iter length > 1
+ expect_warning(
+ update(calc0, n.iter = c(500,100))
+ )
+## update of n.iter with value < than available
+ expect_error(
+ update(calc0, n.iter = 50)
+ )
})
-test_that("updating n within smaller range of n", {
-#
- calc1.2.8 <- update(calc1.2.1, n = n.new2)
- # expect_equal(array(as.logical(calc1.2.8 at core), dim = c(11,11,1,1)),
- # result1.2.n2, check.attributes = FALSE)
-})
+## test_that("update statistic only", {
+## #
+## expect_equal(update(calc0, statistic = powFun2), result1.2.x, check.attributes = FALSE)
+## })
-test_that("updating n with new range of n only partially matching", {
-#
- calc1.2.8 <- update(calc1.2.1, n = n.new5)
- # expect_equal(array(as.logical(calc1.2.8 at core), dim = c(11,11,1,1)),
- # result1.2.n2, check.attributes = FALSE)
-})
-
-test_that("not using cluster", {
-#
- expect_equal(calc1.2.1.nc at core, result1.2.x, check.attributes = FALSE)
- expect_equal(calc1.2.1.nc at core, result1.2.x, check.attributes = FALSE)
-})
-
-
-test_that("new theta of length 1 and increasing n.iter", {
-#
- calc1.2.9 <- update(calc1.2.1.nc, theta = theta.new4, n.iter = 99)
- calc1.2.10 <- update(calc1.2.9, theta = theta.new4, n.iter = 100)
-})
-
-test_that("updating n with new range of n only partially matching", {
-#
- calc1.2.11 <- update(calc1.2.1, n = n.new5)
- #expect_equal(array(as.logical(calc1.2.11 at core), dim = c(21,11,1,1)),
- # result1.2.n5, check.attributes = FALSE)
-})
Modified: pkg/sse/man/refine.Rd
===================================================================
--- pkg/sse/man/refine.Rd 2019-11-11 14:25:43 UTC (rev 39)
+++ pkg/sse/man/refine.Rd 2019-12-09 17:00:07 UTC (rev 40)
@@ -44,7 +44,7 @@
pow <- powEx(calc, theta = 1, power = 0.9)
## another 900 (= 1000 - 100) iterations
-pow.fine <- refine(pow)
+refine(pow)
}
}
More information about the Power-commits
mailing list