unit test read.4d, unselecting freq cols

R/freq.R

@@ -66,7 +66,7 @@
 #' @keywords summary summarise frequency freq
 #' @rdname freq
 #' @name freq
-#' @return A \code{data.frame} with an additional class \code{"frequency_tbl"}
+#' @return A \code{data.frame} (with an additional class \code{"frequency_tbl"}) with five columns: \code{item}, \code{count}, \code{percent}, \code{cum_count} and \code{cum_percent}.
 #' @export
 #' @examples
 #' library(dplyr)
@@ -79,55 +79,66 @@
 #' septic_patients %>% freq("hospital_id")
 #' septic_patients %>% freq(hospital_id)  #<- easiest to remember (tidyverse)
 #'
+#'
 #' # you could also use `select` or `pull` to get your variables
 #' septic_patients %>%
 #'   filter(hospital_id == "A") %>%
 #'   select(mo) %>%
 #'   freq()
 #'
+#'
 #' # multiple selected variables will be pasted together
 #' septic_patients %>%
 #'   left_join_microorganisms %>%
 #'   filter(hospital_id == "A") %>%
 #'   freq(genus, species)
 #'
+#'
 #' # group a variable and analyse another
 #' septic_patients %>%
 #'   group_by(hospital_id) %>%
 #'   freq(gender)
 #'
+#'
 #' # get top 10 bugs of hospital A as a vector
 #' septic_patients %>%
 #'   filter(hospital_id == "A") %>%
 #'   freq(mo) %>%
 #'   top_freq(10)
 #'
+#'
 #' # save frequency table to an object
 #' years <- septic_patients %>%
 #'   mutate(year = format(date, "%Y")) %>%
 #'   freq(year)
 #'
+#'
 #' # show only the top 5
 #' years %>% print(nmax = 5)
 #'
+#'
 #' # save to an object with formatted percentages
 #' years <- format(years)
 #'
+#'
 #' # print a histogram of numeric values
 #' septic_patients %>%
 #'   freq(age) %>%
 #'   hist()
 #'
+#'
 #' # or print all points to a regular plot
 #' septic_patients %>%
 #'   freq(age) %>%
 #'   plot()
 #'
+#'
 #' # transform to a data.frame or tibble
 #' septic_patients %>%
 #'   freq(age) %>%
 #'   as.data.frame()
 #'
+#'
 #' # or transform (back) to a vector
 #' septic_patients %>%
 #'   freq(age) %>%
@@ -139,11 +150,23 @@
 #'             sort(),
 #'           sort(septic_patients$age)) # TRUE
 #'
-#' # it also supports `table` objects:
+#'
+#' # it also supports `table` objects
 #' table(septic_patients$gender,
 #'       septic_patients$age) %>%
 #'   freq(sep = " **sep** ")
 #'
+#'
+#' # only get selected columns
+#' septic_patients %>%
+#'   freq(hospital_id) %>%
+#'   select(item, percent)
+#'
+#' septic_patients %>%
+#'   freq(hospital_id) %>%
+#'   select(-count, -cum_count)
+#'
+#'
 #' # check differences between frequency tables
 #' diff(freq(septic_patients$trim),
 #'      freq(septic_patients$trsu))
@@ -569,6 +592,7 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
       }
       title <- paste(title, group_var)
     }
+    title <- paste("Frequency table of", trimws(title))
   } else {
     title <- opt$title
   }
@@ -592,12 +616,6 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
     opt$header <- header
   }
 
-  if (trimws(title) == "") {
-    title <- "Frequency table"
-  } else {
-    title <- paste("Frequency table of", trimws(title))
-  }
-
   # bold title
   if (opt$tbl_format == "pandoc") {
     title <- bold(title)
@@ -620,10 +638,6 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
     return(invisible())
   }
 
-  if (all(x$count == 1)) {
-    warning('All observations are unique.', call. = FALSE)
-  }
-
   # save old NA setting for kable
   opt.old <- options()$knitr.kable.NA
   if (is.null(opt$na)) {
@@ -668,10 +682,34 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
   if (any(class(x$item) %in% c('double', 'integer', 'numeric', 'raw', 'single'))) {
     x$item <- format(x$item)
   }
-  x$count <- format(x$count)
-  x$percent <- percent(x$percent, force_zero = TRUE)
-  x$cum_count <- format(x$cum_count)
-  x$cum_percent <- percent(x$cum_percent, force_zero = TRUE)
+  if ("item" %in% colnames(x)) {
+    x$item <- format(x$item)
+  } else {
+    opt$column_names <- opt$column_names[!opt$column_names == "Item"]
+  }
+  if ("count" %in% colnames(x)) {
+    if (all(x$count == 1)) {
+      warning('All observations are unique.', call. = FALSE)
+    }
+    x$count <- format(x$count)
+  } else {
+    opt$column_names <- opt$column_names[!opt$column_names == "Count"]
+  }
+  if ("percent" %in% colnames(x)) {
+    x$percent <- percent(x$percent, force_zero = TRUE)
+  } else {
+    opt$column_names <- opt$column_names[!opt$column_names == "Percent"]
+  }
+  if ("cum_count" %in% colnames(x)) {
+    x$cum_count <- format(x$cum_count)
+  } else {
+    opt$column_names <- opt$column_names[!opt$column_names == "Cum. Count"]
+  }
+  if ("cum_percent" %in% colnames(x)) {
+    x$cum_percent <- percent(x$cum_percent, force_zero = TRUE)
+  } else {
+    opt$column_names <- opt$column_names[!opt$column_names == "Cum. Percent"]
+  }
 
   if (opt$tbl_format == "markdown") {
     cat("\n")

R/read.4d.R

@@ -41,7 +41,7 @@ read.4D <- function(file,
                     encoding = "UTF-8") {
 
   if (info == TRUE) {
-    message("Importing data... ", appendLF = FALSE)
+    message("Importing ", file, "... ", appendLF = FALSE)
   }
   data_4D <- utils::read.table(file = file,
                                row.names = row.names,