Merge pull request #14 from imbi-heidelberg/dev

Add some unit tests and fix readme highlighting

.Rbuildignore

@@ -12,3 +12,4 @@ index.Rmd
 inst/.lintr$
 ^.lintr$
 ^.vscode$
+^benchmarks$

.github/workflows/pkgdownDeploy.yml

@@ -2,6 +2,9 @@ on:
   push:
     branches: [main, master]
     tags: ['*']
+  pull_request:
+    branches: [main, master]
+    tags: ['*']
 
 name: pkgdown
 

R/loadData.R

@@ -4,6 +4,10 @@
 #' or \code{\link[tibble]{tibble}}, or a vector
 #'
 #' @return list of labels
+#' @examples
+#' a <- c(1, 2)
+#' attr(a, "label") <- "b"
+#' identical(extract_labels(a), list(a = attr(a, "label")))
 #' @export
 #'
 extract_labels <- function(dat) {
@@ -24,12 +28,18 @@ extract_labels <- function(dat) {
 #' @inheritParams extract_labels
 #'
 #' @return data with the labels removed
+#' @examples
+#' a <- c(1, 2)
+#' attr(a, "label") <- "b"
+#' identical(unlabel(a), c(1, 2))
 #' @export
 #'
 unlabel <- function(dat) {
   unlabel_fun <- function(x) {
     if (inherits(x, "labelled")) {
       class(x) <- class(x)[class(x) != "labelled"]
+    }
+    if (!is.null(attr(x, "label") <- NULL)){
       attr(x, "label") <- NULL
     }
     return(x)
@@ -57,6 +67,9 @@ unlabel <- function(dat) {
 #' @param path_to_redcap_script (character) Path to the (automatically generated) redcap script for data import
 #'
 #' @return tibble with data
+#' @examples
+#' path_to_redcap_script <- system.file("examples", "testredcap.r", package = "DescrTab2")
+#' read_redcap_formatted(path_to_redcap_script)
 #' @export
 #' @importFrom Hmisc label label<-
 read_redcap_formatted <- function(path_to_redcap_script = NULL) {
@@ -87,7 +100,11 @@ read_redcap_formatted <- function(path_to_redcap_script = NULL) {
 #'
 #' @return a list of datasets separated into the categories as described
 #' @export
-#'
+#' 
+#' @examples
+#' path_to_redcap_script <- system.file("examples", "testredcap.r", package = "DescrTab2")
+#' dat <- read_redcap_formatted(path_to_redcap_script)
+#' d <- split_redcap_dataset(dat, guess_ID_variable(dat, TRUE))
 split_redcap_dataset <- function(dat, id_name = "patid") {
   missings_everywhere <-
     dat %>% select(!!id_name, where(~ (all(is.na(.x)) | all(.x == ""))))
@@ -122,7 +139,10 @@ split_redcap_dataset <- function(dat, id_name = "patid") {
 #'
 #' @return tibble with data
 #' @export
-#'
+#' @examples
+#' path_to_data <- system.file("examples", "testsas.sas7bdat", package = "DescrTab2")
+#' pat_to_format <- system.file("examples", "formats.sas7bcat", package = "DescrTab2")
+#' haven::read_sas(path_to_data, pat_to_format)
 #' @importFrom haven read_sas
 #'
 read_sas_formatted <- function(path_to_data = NULL, path_to_format = NULL) {
@@ -135,13 +155,16 @@ read_sas_formatted <- function(path_to_data = NULL, path_to_format = NULL) {
   erg
 }
 
-
-
 #' Create a markdown listing from a character dataset
 #'
 #' @param dat a character \code{data.frame} or \code{tibble}.
 #'
 #' @return string containing markdown code listing all nonempty free text in the dataset
+#' @examples
+#' dat  <- data.frame(Freetext = c("Some text", "More text"))
+#' list_freetext_markdown(dat)
+#' # use inside a .Rmd document like this:
+#' # `r list_freetext_markdown(dat)`
 #' @export
 #'
 list_freetext_markdown <- function(dat) {
@@ -155,15 +178,14 @@ list_freetext_markdown <- function(dat) {
     var <- var[!(var %in% c("", NA_character_))]
     if (length(var) > 0) {
       namerow <- paste0("**", print_name, "**\n\n")
-      varrows <- paste0(" * ", var, "\n\n")
+      varrows <- paste0(" * ", var, "\n")
       str <- paste0(str, namerow, paste0(varrows, collapse = ""), collapse = "")
     }
   }
   str
 }
 
 
-
 #' Parse a text file containing format information
 #'
 #' Useful to extract factor formatting information contained in a proc format SAS statement.
@@ -174,6 +196,15 @@ list_freetext_markdown <- function(dat) {
 #' @param encoding Encoding for the text file
 #'
 #' @return A named list with format definitions
+#' @examples
+#' tmpfile <- tempfile()
+#' write(     "proc format;
+#'              value yn  1=\"yes\"
+#'                        0=\"no\";
+#'              value sex 1=\"female\"
+#'                        0=\"male\";
+#'               run;",tmpfile)
+#' parse_formats(tmpfile)
 #' @export
 parse_formats <- function(path_to_format_definition,
                           ignore_keywords = c("value"),
@@ -317,7 +348,6 @@ text file and make sure there are no labels containing strings of the form '/*'
   return(format_list)
 }
 
-
 #' Create code to load all SAS datasets in a folder.
 #'
 #' This is useful if you work with lots of separate SAS datasets spread out in the same folder.
@@ -326,6 +356,8 @@ text file and make sure there are no labels containing strings of the form '/*'
 #' @param format path to format file
 #'
 #' @return NULL. Relevant code is printed to the console.
+#' @examples
+#' codegen_load_all_sas_data(system.file("examples", package = "DescrTab2"))
 #' @export
 codegen_load_all_sas_data <- function(dir, format = NULL) {
   e <- str_subset(list.files(dir), "\\.sas7bdat$")
@@ -348,7 +380,11 @@ codegen_load_all_sas_data <- function(dir, format = NULL) {
 #'
 #' @return if exactly one possible
 #' @export
-#'
+#' 
+#' @examples
+#' dat <- data.frame(ID = c(1,2,3,4,5),
+#'                  other = c(1,2,3,4,5))
+#' guess_ID_variable(dat)
 #' @importFrom stringr str_to_lower
 #' @importFrom magrittr `%>%`
 guess_ID_variable <- function(dat, suppressWarnings = FALSE) {
@@ -383,7 +419,7 @@ guess_ID_variable <- function(dat, suppressWarnings = FALSE) {
     return(NULL)
   }
 }
-
+# nocov start
 # work in progress
 split_data_from_listing <- function(dat, n_split_levels = 10, n_split_characters = 35) {
   dat <- as_tibble(dat)
@@ -408,3 +444,4 @@ split_data_from_listing <- function(dat, n_split_levels = 10, n_split_characters
     list = dat[, unlist(idx_list)]
   ))
 }
+# nocov end

R/prettyDigits.R

@@ -1,3 +1,4 @@
+# nocov start
 #' Formatting function for absolute and relative frequencies
 #'
 #' @param numerator (numeric) numerator for \% calculations
@@ -176,3 +177,4 @@ good_format <- function(x,
     x
   }
 }
+# nocov end

R/summaryStats.R

@@ -25,29 +25,31 @@
 
 .Q1 <- function(var) {
   stats::quantile(var,
-                  probs = 0.25,
-                  na.rm = TRUE,
-                  type = 2
+    probs = 0.25,
+    na.rm = TRUE,
+    type = 2
   )
 }
 
 .Q3 <- function(var) {
   stats::quantile(var,
-                  probs = 0.75,
-                  na.rm = TRUE,
-                  type = 2
+    probs = 0.75,
+    na.rm = TRUE,
+    type = 2
   )
 }
 
 .IQR <- function(var) {
   stats::quantile(var,
-                  probs = 0.75,
-                  na.rm = TRUE,
-                  type = 2) -
+    probs = 0.75,
+    na.rm = TRUE,
+    type = 2
+  ) -
     stats::quantile(var,
-                    probs = 0.25,
-                    na.rm = TRUE,
-                    type = 2)
+      probs = 0.25,
+      na.rm = TRUE,
+      type = 2
+    )
 }
 
 .min <- function(var) {
@@ -72,11 +74,11 @@
 }
 
 .skew <- function(var) {
-  base::mean((var-.mean(var))^(3)) / (stats::sd(var))^(3/2)
+  base::mean((var - .mean(var))^(3)) / (stats::sd(var))^(3 / 2)
 }
 
 .kurtosis <- function(var) {
-  base::mean((var-.mean(var))^(4)) / (stats::sd(var))^(2) -3
+  base::mean((var - .mean(var))^(4)) / (stats::sd(var))^(2) - 3
 }
 
 .factormean <- function(var) {
@@ -200,14 +202,26 @@
   if (any(!is.na(var))) {
     var <- var[!is.na(var)]
     conds <- list()
-    ret <- withCallingHandlers({
-      stats::wilcox.test(var, conf.int=TRUE)$conf.int[1]
-      },
-      condition = function(cond) {
-        conds <<- append(conds, cond)
-      }
-    )
-    for (cond in conds[names(conds)=="message"]) {
+    ret <-
+      tryCatch(
+        {
+          withCallingHandlers(
+            {
+              stats::wilcox.test(var, conf.int = TRUE)$conf.int[1]
+            },
+            condition = function(cond) {
+              conds <<- append(conds, cond)
+              if (inherits(cond, "warning")) {
+                tryInvokeRestart("muffleWarning")
+              }
+            }
+          )
+        },
+        warning = function(cond) {
+          return(NULL)
+        }
+      )
+    for (cond in conds[names(conds) == "message"]) {
       if (cond == "requested conf.level not achievable") {
         warning(cond)
         return(NA_real_)
@@ -223,14 +237,18 @@
   if (any(!is.na(var))) {
     var <- var[!is.na(var)]
     conds <- list()
-    ret <- withCallingHandlers({
-      stats::wilcox.test(var, conf.int=TRUE)$conf.int[1]
+    ret <- withCallingHandlers(
+      {
+        stats::wilcox.test(var, conf.int = TRUE)$conf.int[1]
       },
       condition = function(cond) {
         conds <<- append(conds, cond)
+        if (inherits(cond, "warning")) {
+          tryInvokeRestart("muffleWarning")
+        }
       }
     )
-    for (cond in conds[names(conds)=="message"]) {
+    for (cond in conds[names(conds) == "message"]) {
       if (cond == "requested conf.level not achievable") {
         warning(cond)
         return(NA_real_)

README.md

@@ -19,12 +19,12 @@ Tables generated by DescrTab2 can be integrated in a variety of document formats
 
 
 You can also install the development version of DescrTab2 (recommended) from github by typing:
-```
+```r
 remotes::install_github("https://github.com/imbi-heidelberg/DescrTab2")
 ```
 
 You may also install the stable version of DescrTab2 from cran by typing
-```
+```r
 install.packages("DescrTab2")
 ```
 into your R console.

inst/exact_test_comparison/exact_test_comparison.R → benchmarks/exact_test_comparison/exact_test_comparison.R

@@ -25,7 +25,6 @@ for (nsim in c(100, 200, 300, 400, 500)) {
 }
 
 
-
 for (nsim in c(100, 200, 300, 400, 500)) {
   starttime <- Sys.time()
 

docs/pkgdown.yml

@@ -7,7 +7,7 @@ articles:
   c_other_software_comparison: c_other_software_comparison.html
   d_validation_statement: d_validation_statement.html
   e_maintenance_guide: e_maintenance_guide.html
-last_built: 2021-11-14T16:14Z
+last_built: 2021-11-14T19:53Z
 urls:
   reference: https://imbi-heidelberg.github.io/DescrTab2/reference
   article: https://imbi-heidelberg.github.io/DescrTab2/articles