removed ratio, better rsi_calc, update for freq

R/classes.R

@@ -240,10 +240,13 @@ as.mic <- function(x, na.rm = FALSE) {
     # remove all after last digit
     x <- gsub('[^0-9]+$', '', x)
     # remove last zeroes
-    x <- gsub('[.]?0+$', '', x)
+    x <- gsub('([.].?)0+$', '\\1', x)
     # force to be character
     x <- as.character(x)
 
+    # previously unempty values now empty - should return a warning later on
+    x[x.bak != "" & x == ""] <- "invalid"
+
     # these are alllowed MIC values and will become factor levels
     lvls <- c("<0.002", "<=0.002", "0.002", ">=0.002", ">0.002",
               "<0.003", "<=0.003", "0.003", ">=0.003", ">0.003",
@@ -275,7 +278,7 @@ as.mic <- function(x, na.rm = FALSE) {
               "<0.25", "<=0.25", "0.25", ">=0.25", ">0.25",
               "<0.256", "<=0.256", "0.256", ">=0.256", ">0.256",
               "<0.28", "<=0.28", "0.28", ">=0.28", ">0.28",
-              "<0.30", "<=0.30", "0.30", ">=0.30", ">0.30",
+              "<0.3", "<=0.3", "0.3", ">=0.3", ">0.3",
               "<0.32", "<=0.32", "0.32", ">=0.32", ">0.32",
               "<0.36", "<=0.36", "0.36", ">=0.36", ">0.36",
               "<0.38", "<=0.38", "0.38", ">=0.38", ">0.38",

R/freq.R

@@ -152,22 +152,39 @@ frequency_tbl <- function(x,
 
   mult.columns <- 0
 
+  x.name <- NULL
+  cols <- NULL
+  if (any(class(x) == 'list')) {
+    cols <- names(x)
+    x <- as.data.frame(x, stringsAsFactors = FALSE)
+    x.name <- "a list"
+  } else if (any(class(x) == 'matrix')) {
+    x <- as.data.frame(x, stringsAsFactors = FALSE)
+    x.name <- "a matrix"
+    cols <- colnames(x)
+    if (all(cols %like% 'V[0-9]')) {
+      cols <- NULL
+    }
+  }
+
   if (any(class(x) == 'data.frame')) {
-    x.name <- deparse(substitute(x))
+    if (is.null(x.name)) {
+      x.name <- deparse(substitute(x))
+    }
     if (x.name == ".") {
       x.name <- NULL
     }
     dots <- base::eval(base::substitute(base::alist(...)))
     ndots <- length(dots)
 
-    if (NROW(x) == 0) {
-      x <- NA
-    } else if (ndots > 0 & ndots < 10) {
+    if (ndots < 10) {
       cols <- as.character(dots)
       if (!all(cols %in% colnames(x))) {
         stop("one or more columns not found: `", paste(cols, collapse = "`, `"), '`', call. = FALSE)
       }
-      x <- x[, cols]
+      if (length(cols) > 0) {
+        x <- x[, cols]
+      }
     } else if (ndots >= 10) {
       stop('A maximum of 9 columns can be analysed at the same time.', call. = FALSE)
     } else {
@@ -298,10 +315,6 @@ frequency_tbl <- function(x,
     header <- header %>% paste0(markdown_line, 'Class:     ', class(x) %>% rev() %>% paste(collapse = " > "))
   }
 
-  if (is.list(x) | is.matrix(x) | is.environment(x) | is.function(x)) {
-    stop('frequency tables do not support lists, matrices, environments and functions.', call. = FALSE)
-  }
-
   header <- header %>% paste0(markdown_line, '\nLength:    ', (NAs %>% length() + x %>% length()) %>% format(),
                               ' (of which NA: ', NAs %>% length() %>% format(),
                               ' = ', (NAs %>% length() / (NAs %>% length() + x %>% length())) %>% percent(force_zero = TRUE, round = digits) %>% sub('NaN', '0', ., fixed = TRUE), ')')
@@ -485,6 +498,10 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
 
   opt <- attr(x, 'opt')
 
+  if (length(opt$vars) == 0) {
+    opt$vars <- NULL
+  }
+
   if (!is.null(opt$data) & !is.null(opt$vars)) {
     title <- paste0("of `", paste0(opt$vars, collapse = "` and `"), "` from ", opt$data)
   } else if (!is.null(opt$data) & is.null(opt$vars)) {

R/g.test.R

@@ -79,11 +79,7 @@
 #' # by a single gene with two co-dominant alleles, you would expect a 1:2:1
 #' # ratio.
 #'
-#' x <- c(772, 1611, 737)
-#' E <- ratio(x, "1:2:1")
-#' E
-#' # 780 1560 780
-#'
+#' x <- c(772, 1611, 737)#'
 #' G <- g.test(x, p = c(1, 2, 1) / 4)
 #' # G$p.value = 0.12574.
 #'
@@ -228,30 +224,3 @@ g.test <- function(x,
                  observed = x, expected = E, residuals = (x - E)/sqrt(E),
                  stdres = (x - E)/sqrt(V)), class = "htest")
 }
-
-#' Transform vector to ratio
-#' @param x vector of values
-#' @param ratio vector with ratios of \code{x} and with same length (like \code{ratio = c(1, 2, 1)}) or a text with characters \code{":"}, \code{"-"} or \code{","} (like \code{ratio = "1:2:1"} or even \code{ratio = "1:2:1.25"})
-#' @export
-#' @seealso \code{\link{g.test}}
-#' @references McDonald, J.H. 2014. \strong{Handbook of Biological Statistics (3rd ed.)}. Sparky House Publishing, Baltimore, Maryland.
-#' @importFrom dplyr %>%
-#' @inherit g.test examples
-ratio <- function(x, ratio) {
-  if (!all(is.numeric(x))) {
-    stop('`x` must be a vector of numeric values.')
-  }
-  if (length(ratio) == 1) {
-    if (ratio %like% '^([0-9]+([.][0-9]+)?[-,:])+[0-9]+([.][0-9]+)?$') {
-      # support for "1:2:1", "1-2-1", "1,2,1" and even "1.75:2:1.5"
-      ratio <- ratio %>% base::strsplit("[-,:]") %>% base::unlist() %>% base::as.double()
-    } else {
-      stop('Invalid `ratio`: ', ratio, '.')
-    }
-  }
-  if (length(x) != length(ratio)) {
-    stop('`x` and `ratio` must be of same size.')
-  }
-  base::sum(x, na.rm = TRUE) * (ratio / base::sum(ratio, na.rm = TRUE))
-}
-

R/rsi_calc.R

@@ -16,7 +16,7 @@
 # GNU General Public License for more details.                         #
 # ==================================================================== #
 
-#' @importFrom dplyr %>% bind_cols pull
+#' @importFrom dplyr %>% pull
 rsi_calc <- function(...,
                      type,
                      include_I,
@@ -34,33 +34,36 @@ rsi_calc <- function(...,
     stop('`as_percent` must be logical', call. = FALSE)
   }
 
-  dots_length <- ...length()
-  dots <- ...elt(1) # it needs this evaluation
-  dots <- rlang::exprs(...) # or this will be a list without actual values
+  dots_df <- ...elt(1) # it needs this evaluation
+  dots <- base::eval(base::substitute(base::alist(...)))
+  ndots <- length(dots)
 
-  if ("data.frame" %in% class(dots[[1]]) & dots_length > 1) {
-    # data.frame passed with other columns, like:
-    #   septic_patients %>% portion_S(amcl, gent)
-    df <- dots[[1]]
-    dots_df <- data.frame(col1 = df[,1])
-    for (i in 2:dots_length) {
-      dots_col <- as.character(dots[[i]])
-      if (!dots_col %in% colnames(df)) {
-        stop("variable not found: ", dots_col)
-      }
-      dots_df <- dots_df %>% bind_cols(data.frame(df %>% pull(dots_col)))
+ if ("data.frame" %in% class(dots_df)) {
+   # data.frame passed with other columns, like:
+   #   septic_patients %>% portion_S(amcl, gent)
+   dots <- as.character(dots)
+   dots <- dots[dots != "."]
+    if (length(dots) == 0 | all(dots == "df")) {
+      # for complete data.frames, like septic_patients %>% select(amcl, gent) %>% portion_S()
+      # and the old rsi function, that has "df" as name of the first parameter
+      x <- dots_df
+    } else {
+      x <- dots_df[, dots]
     }
-    x <- dots_df[, -1]
-  } else if (dots_length == 1) {
-    # only 1 variable passed (count also be data.frame), like:
+  } else if (ndots == 1) {
+    # only 1 variable passed (can also be data.frame), like:
     #   portion_S(septic_patients$amcl)
     #   septic_patients$amcl %>% portion_S()
-    x <- dots[[1]]
+    x <- dots_df
   } else {
     # multiple variables passed without pipe, like:
     #   portion_S(septic_patients$amcl, septic_patients$gent)
-    #   with(septic_patients, portion_S(amcl, gent))
-    x <- as.data.frame(rlang::list2(...))
+    x <- NULL
+    try(x <- as.data.frame(dots), silent = TRUE)
+    if (is.null(x)) {
+      # support for: with(septic_patients, portion_S(amcl, gent))
+      x <- as.data.frame(rlang::list2(...))
+    }
   }
 
   print_warning <- FALSE