Merge branch 'dev-current'

R/ctable.R

@@ -130,14 +130,14 @@ ctable <- function(x,
      stop("ctable() does not support group_by(); use stby() instead")
   }
 
-  # Adjustment for by() / syby()
+  # Adjustment for by() / syby() or when variables are piped into ctable
   if (length(dim(x)) == 2) {
     x_tmp <- x[[1]]
     y <- x[[2]]
     x <- x_tmp
-    flag_by <- TRUE
+    flag_parse_xy <- TRUE
   } else {
-    flag_by <- FALSE
+    flag_parse_xy <- FALSE
   }
 
   # Convert 1-column data frames into vectors
@@ -190,9 +190,11 @@ ctable <- function(x,
   }
 
   # Get x & y metadata from parsing function
-  if (isTRUE(flag_by)) {
+  if (isTRUE(flag_by) || isTRUE(flag_parse_xy)) {
     parse_info_x <- try(
-      parse_call(mc = match.call(), var = c("x", "y"), var_label = FALSE, 
+      parse_call(mc = match.call(),
+                 var = c("x", "y"),
+                 var_label = FALSE, 
                  caller = "ctable"),
       silent = TRUE)
 
@@ -239,12 +241,12 @@ ctable <- function(x,
   if ("dnn" %in% names(match.call())) {
     x_name <- dnn[1]
     y_name <- dnn[2]
-  } else if (!isTRUE(flag_by)) {
-    x_name <- na.omit(c(parse_info_x$var_name, deparse(dnn[[1]])))[1]
-    y_name <- na.omit(c(parse_info_y$var_name, deparse(dnn[[2]])))[1]
-  } else {
+  } else if (isTRUE(flag_by) || isTRUE(flag_parse_xy)) {
     x_name <- na.omit(c(parse_info_x$var_name[1], deparse(dnn[[1]])))[1]
     y_name <- na.omit(c(parse_info_x$var_name[2], deparse(dnn[[2]])))[1]
+  } else {
+    x_name <- na.omit(c(parse_info_x$var_name, deparse(dnn[[1]])))[1]
+    y_name <- na.omit(c(parse_info_y$var_name, deparse(dnn[[2]])))[1]
   }
 
   # Create xfreq table ---------------------------------------------------------

R/descr.R

@@ -340,14 +340,18 @@ descr.default <- function(x,
     names(summar_funs) <- fun_names
     summar_funs <- summar_funs[which(fun_names %in% stats)]
 
+    # To avoid problems, (see issue #152) use generic colnames
+    xxnames <- colnames(xx)
+    colnames(xx) <- paste0("V", seq_along(xx))
     if (ncol(xx) > 1) {
       results <- suppressWarnings(
         xx %>% summarise_all(.funs = summar_funs) %>%
           gather("variable", "value") %>%
           separate("variable", c("var", "stat"), sep = "_(?=[^_]*$)") %>%
           spread("var", "value")
       )
-
+      colnames(xx) <- xxnames
+      colnames(results) <- c("stat", xxnames)
       if (identical(order, "preserve")) {
         results <- results[ ,c("stat", colnames(xx))]
       } else if (length(order) > 1) {

R/parse_call.R

@@ -145,6 +145,13 @@ parse_fun <- function()  {
 
   done <- FALSE
   call <- standardize(.p$calls$fun)
+
+  if (length(.p$var) > 1) {
+    #str <- paste0(deparse(.p$calls[[grep(.p$caller, .p$calls)[1]]]), collapse = "")
+    done <- parse_data_str(deparse(call))
+    return(done)
+  }
+
   obj <- .p$sf[[.p$pos$fun]][[.p$var]]
 
   # Extract names from x argument
@@ -390,13 +397,14 @@ parse_pipe <- function() {
               envir = .p$sf[[.p$pos$pipe]]$parent)
 
   if (is.data.frame(obj)) {
-    if ("var_name" %in% names(.p$output) && ncol(obj) == 1) {
-      done <- upd_output("var_name", names(obj))
-      done <- upd_output("var_label", label(obj[[1]]))
+    obj_df <- obj
+    if ("var_name" %in% names(.p$output) && ncol(obj_df) == 1) {
+      done <- upd_output("var_name", colnames(obj_df))
+      done <- upd_output("var_label", label(obj_df[[1]]))
       if (done)  return(TRUE)
     }
 
-    done <- upd_output("df_label", as.character(label(obj)))
+    done <- upd_output("df_label", as.character(label(obj_df)))
     if (length(obj_str) == 1) {
       done <- upd_output("df_name", obj_name)
       if (done)  return(TRUE)
@@ -409,23 +417,32 @@ parse_pipe <- function() {
     }
   } else {
     done <- parse_data_str(obj_name)
+    obj_df <- NULL
   }
   if (done)  return(TRUE)
 
   # Move focus to rhs
   if ("var_name" %in% names(.p$output)) {
     rhs <- call$rhs
-
     if (is.call(rhs))  
       rhs <- standardize(rhs)
 
     rhs_nms <- all.names(rhs)
     if (.p$caller %in% rhs_nms && length(rhs_nms) > 1) {
       rhs_args <- setdiff(rhs_nms, .p$caller)
-      if (length(rhs_args) == 1 && rhs_args %in% colnames(obj)) {
-        done <- upd_output("var_name", rhs_args)
-        done <- upd_output("var_label", label(obj[[rhs_args]]))
-        if (done)  return(TRUE)
+      if (length(rhs_args) == 1) {
+        if (rhs_args %in% colnames(obj_df)) {
+          done <- upd_output("var_name", rhs_args)
+          done <- upd_output("var_label", label(obj_df[[rhs_args]]))
+          if (done)  return(TRUE)
+        }
+      } else {
+        if (length(var_ind <- which(rhs_args %in% colnames(obj_df))) == 1) {
+          var_name <- rhs_args[[var_ind]]
+          done <- upd_output("var_name", var_name)
+          done <- upd_output("var_label", label(obj_df[[var_name]]))
+          if (done)  return(TRUE)
+        }
       }
     }
 
@@ -478,7 +495,7 @@ parse_piper <- function() {
     obj_str <- setdiff(obj_str, c(.p$caller, .st_env$oper, ""))
     if (length(obj_str) == 1) {
       done <- upd_output("var_name", obj_str)
-      done <- upd_output("var_label", label(obj))
+      done <- try(upd_output("var_label", label(obj)), silent = TRUE)
     } else if (length(obj_str) == 2) {
       obj_df <- try(get_object(obj_str[1], "data.frame"),
                     silent = TRUE)
@@ -548,8 +565,11 @@ deduce_names <- function() {
   # - if there is a df, hope there is only one other object left
   nms <- setdiff(all.names(sys.calls()[[1]]), .p$caller)
   call <- standardize(sys.calls()[[1]])
-  nms <- unique(c(nms, as.character(call[[.p$var]])))
-
+
+  if (length(.p$var) == 1) {
+    nms <- unique(c(nms, as.character(call[[.p$var]])))
+  }
+
   nnames <- length(nms)
   df_found <- !empty_na(.p$output$df_name)
 
@@ -571,8 +591,6 @@ deduce_names <- function() {
         }
       } else candidates %+=% c(untested = nm)
     } else if (is.data.frame(obj_)) {
-      cand_class %+=% "data.frame"
-      names(cand_class)[length(cand_class)] <- nm
       if (isFALSE(df_found)) {
         df_found <- TRUE
         obj_df <- obj_
@@ -581,8 +599,7 @@ deduce_names <- function() {
         if (done)  return(TRUE)
         nnames <- nnames - 1
       } else {
-        # We have a 2nd data frame; we'll simply ignore it, trusting 
-        # previous stages
+        # We had already found df_name, so we'll simply ignore it
         nnames <- nnames - 1
       }
     } else if (inherits(obj_, "function")) {
@@ -616,17 +633,27 @@ deduce_names <- function() {
     }
 
     # If there is only 1 tested, we keep it
-    if (table(candidates['tested'])[[1]] == 1) {
-      done <- upd_output("var_name", candidates[['tested']])
-      if (done)  return(TRUE)
-      if (isTRUE(df_found))
-        done <- upd_output("var_label", label(obj_df[[candidates[['tested']]]]))
-      if (done)  return(TRUE)
+    n_tested <- table(names(candidates))[['tested']]
+    if (n_tested == 1) {
+      var_name <- candidates[['tested']]
+      done <- upd_output("var_name", var_name)
+      done <- upd_output("var_label", label(obj_df[[var_name]]))
+      return(TRUE)
     } else {
-      # At this stage we can't determine which variable is the right one
-      message("Unable to determine variable and/or df name")
+      # More than one variable -- hopefully ctable
+      if (n_tested == 2 && length(.p$var) == 2) {
+        done <- upd_output(
+          "var_name",
+          unname(candidates[names(candidates) == "tested"]),
+          force = TRUE
+        )
+      }
     }
   }
+  if (done)  return(TRUE)
+
+  # Set .p$do_return to TRUE to avoid warning (although there will be a msg)
+  .p$do_return <- TRUE
   return(FALSE)
 }
 
@@ -759,6 +786,31 @@ parse_data_str <- function(str) {
         done <- upd_output("var_name", obj_name)
         done <- upd_output("var_label", label(obj))
         if (done)  return(TRUE)
+      } else {
+        if (is.function(obj)) {
+          # Most probably something like descr(rnorm(10)) 
+          # First, confirm that function is a summarytools fn
+          if (!grepl("summarytools", 
+                     capture.output(pryr::where(obj_name))[1])) {
+            # See if only one of var_name & df_name is required, and
+            # use that slot and return
+            name_slots <- grep("_name", names(.p$output), value = TRUE)
+            if (length(name_slots) == 1) {
+              upd_output(name_slots, str, force = TRUE)
+              .p$do_return <- TRUE
+              return(TRUE)
+            } else {
+              # Get first element of evaluated str to determine which
+              # slot to use
+              if (is.data.frame(eval(str2expression(str))[1]))
+                upd_output("df_name", str, force = TRUE)
+              else
+                upd_output("var_name", str, force = TRUE)
+              .p$do_return <- TRUE
+              return(TRUE)
+            }
+          }
+        }
       }
     }
   }

R/print.summarytools.R

@@ -1381,11 +1381,6 @@ print_descr <- function(x, method) {
     x <- round(x, format_info$digits)
     x <- do.call(format, append(format_args, list(x = quote(x))))
 
-    #if (!"Weights" %in% names(data_info)) {
-    #  row_ind <- which(trs("n.valid") == rownames(x))
-    #  x[row_ind, ] <- sub("\\.0+", "", x[row_ind, ])
-    #}
-
     main_sect %+=%
       paste(
         capture.output(
@@ -1416,27 +1411,36 @@ print_descr <- function(x, method) {
     }
 
     table_rows <- list()
+
+    # Determine which cells are "n" or "n.valid" in order to remove digits
+    # This is much easier than editing pairlists after-the-fact
+    if ("Weights" %in% names(data_info)) {
+      hide_digits <- FALSE
+    } else {
+      if (isTRUE(data_info$transposed)) {
+        co_hide_ind <- which(colnames(x) %in% c(trs("n"), trs("n.valid")))
+        hide_digits <- quote(co %in% co_hide_ind)
+      } else {
+        ro_hide_ind <- which(rownames(x) %in% c(trs("n"), trs("n.valid")))  
+        hide_digits <- quote(ro %in% ro_hide_ind)
+      }
+    }
+
     for (ro in seq_len(nrow(x))) {
       table_row <- list(tags$td(tags$strong(rownames(x)[ro])))
       for (co in seq_len(ncol(x))) {
-        # cell is NA
         if (is.na(x[ro,co])) {
           table_row %+=% list(tags$td(format_info$missing))
         } else {
-          # When not NA format cell content
           cell <- do.call(format, append(format_args, x = quote(x[ro,co])))
-          if ((rownames(x)[ro] == trs("n.valid") ||
-               colnames(x)[co] == trs("n.valid")) &&
-              !"Weights" %in% names(data_info)) {
+          # check for n and n.valid -- remove digits if applicable
+          if (eval(hide_digits)) {
             cell <- sub(paste0(format_info$decimal.mark, "0+$"), "", cell)
           }
           table_row %+=% list(tags$td(tags$span(cell)))
         }
-        # On last column, insert row to table_rows list
-        if (co == ncol(x)) {
-          table_rows %+=% list(tags$tr(table_row))
-        }
       }
+      table_rows %+=% list(tags$tr(table_row))
     }
 
     descr_table_html <-

R/stby.R

@@ -121,11 +121,12 @@ stby <- function(data, INDICES, FUN, ..., useNA = FALSE) {
   }
 
   # remove NULL elements (has side-effect of removing dim and dimnames)
-  for (col in seq_along(res)) {
-    if (is.null(res[[col]])) {
-      res[[col]]   <- NULL
-      groups <- groups[-col,]
-    }
+  non_null_ind <- which(!vapply(res, is.null, logical(1)))
+  if (length(non_null_ind)) {
+    atr <- attributes(res)
+    res <- res[non_null_ind]
+    attributes(res) <- atr[c("call", "class")]
+    groups <- groups[non_null_ind,]
   }
 
   # Set useNA as attribute; to be used by tb()
@@ -136,7 +137,8 @@ stby <- function(data, INDICES, FUN, ..., useNA = FALSE) {
   if (ncol(groups) == 1 && length(res) == length(groups[[1]])) {
     names(res) <- groups[[1]]
   } else {
-    names(res) <- sapply(res, function(gr) attr(gr, "data_info")$Group)
+    names(res) <- vapply(res, function(gr) attr(gr, "data_info")$Group,
+                         character(1))
   }
   #.e_reset()
   return(res)