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