Merge pull request #11 from rpahl/fix_dep

Fix dep

.github/workflows/check-standard.yaml

@@ -0,0 +1,49 @@
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
+# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
+on:
+  push:
+    branches: [main, master]
+  pull_request:
+    branches: [main, master]
+
+name: R-CMD-check
+
+jobs:
+  R-CMD-check:
+    runs-on: ${{ matrix.config.os }}
+
+    name: ${{ matrix.config.os }} (${{ matrix.config.r }})
+
+    strategy:
+      fail-fast: false
+      matrix:
+        config:
+          - {os: macos-latest,   r: 'release'}
+          - {os: windows-latest, r: 'release'}
+          - {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
+          - {os: ubuntu-latest,   r: 'release'}
+          - {os: ubuntu-latest,   r: 'oldrel-1'}
+
+    env:
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+      R_KEEP_PKG_SOURCE: yes
+
+    steps:
+      - uses: actions/checkout@v3
+
+      - uses: r-lib/actions/setup-pandoc@v2
+
+      - uses: r-lib/actions/setup-r@v2
+        with:
+          r-version: ${{ matrix.config.r }}
+          http-user-agent: ${{ matrix.config.http-user-agent }}
+          use-public-rspm: true
+
+      - uses: r-lib/actions/setup-r-dependencies@v2
+        with:
+          extra-packages: any::rcmdcheck
+          needs: check
+
+      - uses: r-lib/actions/check-r-package@v2
+        with:
+          upload-snapshots: true

.github/workflows/test-coverage.yaml

@@ -1,4 +1,4 @@
-# Workflow derived from https://github.com/r-lib/actions/tree/master/examples
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
 # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
 on:
   push:
@@ -15,16 +15,36 @@ jobs:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
 
     steps:
-      - uses: actions/checkout@v2
+      - uses: actions/checkout@v3
 
-      - uses: r-lib/actions/setup-r@v1
+      - uses: r-lib/actions/setup-r@v2
         with:
           use-public-rspm: true
 
-      - uses: r-lib/actions/setup-r-dependencies@v1
+      - uses: r-lib/actions/setup-r-dependencies@v2
         with:
-          extra-packages: covr
+          extra-packages: any::covr
+          needs: coverage
 
       - name: Test coverage
-        run: covr::codecov()
+        run: |
+          covr::codecov(
+            quiet = FALSE,
+            clean = FALSE,
+            install_path = file.path(Sys.getenv("RUNNER_TEMP"), "package")
+          )
         shell: Rscript {0}
+
+      - name: Show testthat output
+        if: always()
+        run: |
+          ## --------------------------------------------------------------------
+          find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true
+        shell: bash
+
+      - name: Upload test results
+        if: failure()
+        uses: actions/upload-artifact@v3
+        with:
+          name: coverage-test-failures
+          path: ${{ runner.temp }}/package

DESCRIPTION

@@ -1,18 +1,18 @@
 Package: GroupSeq
 Title: Group Sequential Design Probabilities - With Graphical User Interface
-Version: 1.4.0
+Version: 1.4.2
 Authors@R:
     person("Roman", "Pahl",
     email = "[email protected]", role = c("aut", "cre"))
 Description: Computes probabilities related to group sequential designs for
     normally distributed test statistics. Enables to derive critical
     boundaries, power, drift, and confidence intervals of such designs.
-    Supports the alpha spending approach by Lan-DeMets.
+    Supports the alpha spending approach by Lan-DeMets (1994)
+    <doi:10.1002/sim.4780131308>
 Imports:
     tcltk,
     tcltk2,
-    mvtnorm,
-    container (>= 1.0.0)
+    mvtnorm
 Suggests: knitr, tinytest, rmarkdown, ggplot2, gridExtra
 VignetteBuilder: knitr
 License: GPL-3
@@ -22,6 +22,6 @@ NeedsCompilation: no
 Author: Roman Pahl [aut, cre]
 Maintainer: Roman Pahl <[email protected]>
 Repository: CRAN
-RoxygenNote: 7.1.2
+RoxygenNote: 7.2.1
 Roxygen: list(markdown = TRUE)
 Encoding: UTF-8

R/groupseq.R

@@ -8,22 +8,22 @@ init_env <- function(legacy = FALSE)
 {
     if (legacy) {
         pkg.env$taskWindow <- NULL
-        pkg.env$scipen.old <- options(scipen=10)[[1]]
+        pkg.env$scipen.old <- options(scipen = 10)[[1]]
         pkg.env
     } else {
-        .env$add("par", container::dict())
-        .env$add("par.last", container::dict())
-        .env$add("name", "")
-        .env$add("root", tcltk::tktoplevel())
+        .env[["par"]] <- new.env()
+        .env[["par.last"]] <- new.env()
+        .env[["name"]] <- ""
+        .env[["root"]] <- tcltk::tktoplevel()
         .env
     }
 }
 
 
-get.par <- function() .env$at2("par")
+get.par <- function() .env[["par"]]
 
 
-get.par.last <- function() .env$at2("par.last")
+get.par.last <- function() .env[["par.last"]]
 
 
 add.par <- function(key, value) {
@@ -35,7 +35,7 @@ add.par <- function(key, value) {
 has_changed_parameters <- function()
 {
     param_list <- as.list(get.par())
-    current <- lapply(as.list(param_list), tclvalue)
+    current <- lapply(as.list(param_list), tcltk::tclvalue)
     last <- as.list(get.par.last())
     if (length(last) != length(current)) stop("length mismatch")
     last <- last[names(current)]
@@ -44,29 +44,36 @@ has_changed_parameters <- function()
 }
 
 
-isNew <- function() nchar(.env$at2("name")) == 0
+isNew <- function() nchar(.env[["name"]]) == 0
 
 
 update_title <- function()
 {
-    name <- if (isNew()) "[New]" else .env$at2("name")
+    name <- if (isNew()) "[New]" else .env[["name"]]
     plus <- if (has_changed_parameters()) " + " else ""
     title <- paste0(name, plus, " - GroupSeq")
-    tkwm.title(.env$at2("root"), title)
+    tcltk::tkwm.title(.env[["root"]], title)
 }
 
 
 update_changed_parameters <- function()
 {
-    param_list <- lapply(as.list(.env$at2("par")), FUN = tclvalue)
-    .env$replace_at("par.last", container::as.dict(param_list))
+    param_list <- lapply(
+        as.list(.env[["par"]]),
+        FUN = tcltk::tclvalue
+    )
+
+    .env[["par.last"]] <- list2env(param_list)
     update_title()
 }
 
 
 #' @title Start GroupSeq
 #' @description Starts the graphical user interface.
+#' @return No return value, called for side effects.
 #' @export
+#' @examples
+#' start_gui()
 start_gui <- function()
 {
     legacy = TRUE
@@ -75,15 +82,15 @@ start_gui <- function()
     if (legacy) {
         guiMode()
     } else {
-        gui(.env$at2("root"))
+        gui(.env[["root"]])
     }
     invisible()
 }
 
 
 .onLoad <- function(libname, pkgname)
 {
-    .env <<- container::dict()
+    .env <<- new.env()
 
     doStart <- getOption("AutostartGroupSeq", default = TRUE)
     if (interactive() && doStart) {
@@ -95,16 +102,17 @@ start_gui <- function()
 
 
 onQuit <- function() {
-    isLegacy <- .env$is_empty()
+    #isLegacy <- .env$is_empty()
+    isLegacy <- TRUE
     if (isLegacy) {
         if (!is.null(pkg.env$taskWindow)) {
-            tkdestroy(pkg.env$taskWindow)
+            tcltk::tkdestroy(pkg.env$taskWindow)
             pkg.env$taskWindow <- NULL
             options(scipen = pkg.env$scipen.old)
         }
     } else {
-        tkdestroy(.env$at2("root"))
-        .env$clear()
+        tcltk::tkdestroy(.env[["root"]])
+        #.env$clear()
     }
     invisible()
 }

R/zzz-groupseq-legacy.R

@@ -129,7 +129,7 @@ function(targetAlpha, provisionallyBounds, n, t2)
     for (j in 1:20) {
         xkPlusOne <- xk - ( (xk - xkMinusOne)/(fxk - fxkMinusOne) * fxk )
         if(is.nan(xkPlusOne) || is.infinite(xkPlusOne)) {
-            cat(error.msg)
+            message(error.msg)
             return(FALSE)
         }
 
@@ -155,7 +155,7 @@ function(targetAlpha, provisionallyBounds, n, t2)
     }
 
     # If we end up here, iteration did not converge
-    cat(error.msg)
+    message(error.msg)
     return(FALSE)
 }
 
@@ -738,22 +738,19 @@ function(n,drift,alpha,phi,t,t2,OneOrTwoSidedBounds,whatSpendingFunctionIsUsed,b
     {
       probDifference[i]<-min(1,probDifference[i])
       probDifference[i]<-max(0,probDifference[i])
-      cat("\n")
-      cat(" Error in spending function at interim time:",i,"\n")
-      cat(" Calculated probabilites are:",probExit,"\n")
-      cat(" Calculated function is not increasing strictly or out of range!","\n")
-      cat(" the differences intype I error spent between analyses","\n")
-      cat(" at this point will be set to:",probDifference[i],"\n")
+      message(" Error in spending function at interim time:",i)
+      message(" Calculated probabilites are:",probExit)
+      message(" Calculated function is not increasing strictly or out of range!")
+      message(" the differences intype I error spent between analyses")
+      message(" at this point will be set to:",probDifference[i])
 
     }
 
     if (probDifference[i]<toleranceProbDiff)
     {
-      cat("\n")
-      cat(" Type I error spent too small at interim time:",i,"\n")
-      cat(" Zero used as approximation for:","\n")
+      message(" Type I error spent too small at interim time:",i)
+      message(" Zero used as approximation for:")
       print(probDifference[i],digits=22)
-      cat("\n")
     }
    }#end <--*for*
 
@@ -823,8 +820,8 @@ function(n,drift,alpha,phi,t,t2,OneOrTwoSidedBounds,whatSpendingFunctionIsUsed,b
            if (n > 1)
            {
              probDifference[2] <- probExit[2] - probExit[1]
-             cat("probExit: ",probExit,"\n")
-             cat("probDifference: ",probDifference[2],"\n")
+             message("probExit: ",probExit)
+             message("probDifference: ",probDifference[2])
            }
          }
          upperIntegrationLimit[1] <- upperBounds[1]*stdDev.inc[1]
@@ -1246,8 +1243,8 @@ function(n, t, t2, lowerBounds, upperBounds, target, drift, nMax)
       else if( abs(drift-prev) <= tol/10 )
            {
              ##drift changes by less than tol/10, stop calculating
-             cat(" Convergence problem in function 'computeDrift' during computing the drift.","\n")
-             cat(" !!!Calculation stopped now!!!","\n")
+             message(" Convergence problem in function 'computeDrift' during computing the drift.")
+             message(" !!!Calculation stopped now!!!")
              break
            }