Skip to content

Commit aade0a2

Browse files
dcomtoisdcomtois
committed
Merge branch 'dev-current'
2 parents c663fed + 83e0bf5 commit aade0a2

File tree

5 files changed

+118
-54
lines changed

5 files changed

+118
-54
lines changed

‎R/ctable.R‎

Lines changed: 11 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -130,14 +130,14 @@ ctable <- function(x,
130130
stop("ctable() does not support group_by(); use stby() instead")
131131
}
132132

133-
# Adjustment for by() / syby()
133+
# Adjustment for by() / syby() or when variables are piped into ctable
134134
if (length(dim(x)) == 2) {
135135
x_tmp <- x[[1]]
136136
y <- x[[2]]
137137
x <- x_tmp
138-
flag_by <- TRUE
138+
flag_parse_xy <- TRUE
139139
} else {
140-
flag_by <- FALSE
140+
flag_parse_xy <- FALSE
141141
}
142142

143143
# Convert 1-column data frames into vectors
@@ -190,9 +190,11 @@ ctable <- function(x,
190190
}
191191

192192
# Get x & y metadata from parsing function
193-
if (isTRUE(flag_by)) {
193+
if (isTRUE(flag_by) || isTRUE(flag_parse_xy)) {
194194
parse_info_x <- try(
195-
parse_call(mc = match.call(), var = c("x", "y"), var_label = FALSE,
195+
parse_call(mc = match.call(),
196+
var = c("x", "y"),
197+
var_label = FALSE,
196198
caller = "ctable"),
197199
silent = TRUE)
198200

@@ -239,12 +241,12 @@ ctable <- function(x,
239241
if ("dnn" %in% names(match.call())) {
240242
x_name <- dnn[1]
241243
y_name <- dnn[2]
242-
} else if (!isTRUE(flag_by)) {
243-
x_name <- na.omit(c(parse_info_x$var_name, deparse(dnn[[1]])))[1]
244-
y_name <- na.omit(c(parse_info_y$var_name, deparse(dnn[[2]])))[1]
245-
} else {
244+
} else if (isTRUE(flag_by) || isTRUE(flag_parse_xy)) {
246245
x_name <- na.omit(c(parse_info_x$var_name[1], deparse(dnn[[1]])))[1]
247246
y_name <- na.omit(c(parse_info_x$var_name[2], deparse(dnn[[2]])))[1]
247+
} else {
248+
x_name <- na.omit(c(parse_info_x$var_name, deparse(dnn[[1]])))[1]
249+
y_name <- na.omit(c(parse_info_y$var_name, deparse(dnn[[2]])))[1]
248250
}
249251

250252
# Create xfreq table ---------------------------------------------------------

‎R/descr.R‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -340,14 +340,18 @@ descr.default <- function(x,
340340
names(summar_funs) <- fun_names
341341
summar_funs <- summar_funs[which(fun_names %in% stats)]
342342

343+
# To avoid problems, (see issue #152) use generic colnames
344+
xxnames <- colnames(xx)
345+
colnames(xx) <- paste0("V", seq_along(xx))
343346
if (ncol(xx) > 1) {
344347
results <- suppressWarnings(
345348
xx %>% summarise_all(.funs = summar_funs) %>%
346349
gather("variable", "value") %>%
347350
separate("variable", c("var", "stat"), sep = "_(?=[^_]*$)") %>%
348351
spread("var", "value")
349352
)
350-
353+
colnames(xx) <- xxnames
354+
colnames(results) <- c("stat", xxnames)
351355
if (identical(order, "preserve")) {
352356
results <- results[ ,c("stat", colnames(xx))]
353357
} else if (length(order) > 1) {

‎R/parse_call.R‎

Lines changed: 76 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -145,6 +145,13 @@ parse_fun <- function() {
145145

146146
done <- FALSE
147147
call <- standardize(.p$calls$fun)
148+
149+
if (length(.p$var) > 1) {
150+
#str <- paste0(deparse(.p$calls[[grep(.p$caller, .p$calls)[1]]]), collapse = "")
151+
done <- parse_data_str(deparse(call))
152+
return(done)
153+
}
154+
148155
obj <- .p$sf[[.p$pos$fun]][[.p$var]]
149156

150157
# Extract names from x argument
@@ -390,13 +397,14 @@ parse_pipe <- function() {
390397
envir = .p$sf[[.p$pos$pipe]]$parent)
391398

392399
if (is.data.frame(obj)) {
393-
if ("var_name" %in% names(.p$output) && ncol(obj) == 1) {
394-
done <- upd_output("var_name", names(obj))
395-
done <- upd_output("var_label", label(obj[[1]]))
400+
obj_df <- obj
401+
if ("var_name" %in% names(.p$output) && ncol(obj_df) == 1) {
402+
done <- upd_output("var_name", colnames(obj_df))
403+
done <- upd_output("var_label", label(obj_df[[1]]))
396404
if (done) return(TRUE)
397405
}
398406

399-
done <- upd_output("df_label", as.character(label(obj)))
407+
done <- upd_output("df_label", as.character(label(obj_df)))
400408
if (length(obj_str) == 1) {
401409
done <- upd_output("df_name", obj_name)
402410
if (done) return(TRUE)
@@ -409,23 +417,32 @@ parse_pipe <- function() {
409417
}
410418
} else {
411419
done <- parse_data_str(obj_name)
420+
obj_df <- NULL
412421
}
413422
if (done) return(TRUE)
414423

415424
# Move focus to rhs
416425
if ("var_name" %in% names(.p$output)) {
417426
rhs <- call$rhs
418-
419427
if (is.call(rhs))
420428
rhs <- standardize(rhs)
421429

422430
rhs_nms <- all.names(rhs)
423431
if (.p$caller %in% rhs_nms && length(rhs_nms) > 1) {
424432
rhs_args <- setdiff(rhs_nms, .p$caller)
425-
if (length(rhs_args) == 1 && rhs_args %in% colnames(obj)) {
426-
done <- upd_output("var_name", rhs_args)
427-
done <- upd_output("var_label", label(obj[[rhs_args]]))
428-
if (done) return(TRUE)
433+
if (length(rhs_args) == 1) {
434+
if (rhs_args %in% colnames(obj_df)) {
435+
done <- upd_output("var_name", rhs_args)
436+
done <- upd_output("var_label", label(obj_df[[rhs_args]]))
437+
if (done) return(TRUE)
438+
}
439+
} else {
440+
if (length(var_ind <- which(rhs_args %in% colnames(obj_df))) == 1) {
441+
var_name <- rhs_args[[var_ind]]
442+
done <- upd_output("var_name", var_name)
443+
done <- upd_output("var_label", label(obj_df[[var_name]]))
444+
if (done) return(TRUE)
445+
}
429446
}
430447
}
431448

@@ -478,7 +495,7 @@ parse_piper <- function() {
478495
obj_str <- setdiff(obj_str, c(.p$caller, .st_env$oper, ""))
479496
if (length(obj_str) == 1) {
480497
done <- upd_output("var_name", obj_str)
481-
done <- upd_output("var_label", label(obj))
498+
done <- try(upd_output("var_label", label(obj)), silent = TRUE)
482499
} else if (length(obj_str) == 2) {
483500
obj_df <- try(get_object(obj_str[1], "data.frame"),
484501
silent = TRUE)
@@ -548,8 +565,11 @@ deduce_names <- function() {
548565
# - if there is a df, hope there is only one other object left
549566
nms <- setdiff(all.names(sys.calls()[[1]]), .p$caller)
550567
call <- standardize(sys.calls()[[1]])
551-
nms <- unique(c(nms, as.character(call[[.p$var]])))
552-
568+
569+
if (length(.p$var) == 1) {
570+
nms <- unique(c(nms, as.character(call[[.p$var]])))
571+
}
572+
553573
nnames <- length(nms)
554574
df_found <- !empty_na(.p$output$df_name)
555575

@@ -571,8 +591,6 @@ deduce_names <- function() {
571591
}
572592
} else candidates %+=% c(untested = nm)
573593
} else if (is.data.frame(obj_)) {
574-
cand_class %+=% "data.frame"
575-
names(cand_class)[length(cand_class)] <- nm
576594
if (isFALSE(df_found)) {
577595
df_found <- TRUE
578596
obj_df <- obj_
@@ -581,8 +599,7 @@ deduce_names <- function() {
581599
if (done) return(TRUE)
582600
nnames <- nnames - 1
583601
} else {
584-
# We have a 2nd data frame; we'll simply ignore it, trusting
585-
# previous stages
602+
# We had already found df_name, so we'll simply ignore it
586603
nnames <- nnames - 1
587604
}
588605
} else if (inherits(obj_, "function")) {
@@ -616,17 +633,27 @@ deduce_names <- function() {
616633
}
617634

618635
# If there is only 1 tested, we keep it
619-
if (table(candidates['tested'])[[1]] == 1) {
620-
done <- upd_output("var_name", candidates[['tested']])
621-
if (done) return(TRUE)
622-
if (isTRUE(df_found))
623-
done <- upd_output("var_label", label(obj_df[[candidates[['tested']]]]))
624-
if (done) return(TRUE)
636+
n_tested <- table(names(candidates))[['tested']]
637+
if (n_tested == 1) {
638+
var_name <- candidates[['tested']]
639+
done <- upd_output("var_name", var_name)
640+
done <- upd_output("var_label", label(obj_df[[var_name]]))
641+
return(TRUE)
625642
} else {
626-
# At this stage we can't determine which variable is the right one
627-
message("Unable to determine variable and/or df name")
643+
# More than one variable -- hopefully ctable
644+
if (n_tested == 2 && length(.p$var) == 2) {
645+
done <- upd_output(
646+
"var_name",
647+
unname(candidates[names(candidates) == "tested"]),
648+
force = TRUE
649+
)
650+
}
628651
}
629652
}
653+
if (done) return(TRUE)
654+
655+
# Set .p$do_return to TRUE to avoid warning (although there will be a msg)
656+
.p$do_return <- TRUE
630657
return(FALSE)
631658
}
632659

@@ -759,6 +786,31 @@ parse_data_str <- function(str) {
759786
done <- upd_output("var_name", obj_name)
760787
done <- upd_output("var_label", label(obj))
761788
if (done) return(TRUE)
789+
} else {
790+
if (is.function(obj)) {
791+
# Most probably something like descr(rnorm(10))
792+
# First, confirm that function is a summarytools fn
793+
if (!grepl("summarytools",
794+
capture.output(pryr::where(obj_name))[1])) {
795+
# See if only one of var_name & df_name is required, and
796+
# use that slot and return
797+
name_slots <- grep("_name", names(.p$output), value = TRUE)
798+
if (length(name_slots) == 1) {
799+
upd_output(name_slots, str, force = TRUE)
800+
.p$do_return <- TRUE
801+
return(TRUE)
802+
} else {
803+
# Get first element of evaluated str to determine which
804+
# slot to use
805+
if (is.data.frame(eval(str2expression(str))[1]))
806+
upd_output("df_name", str, force = TRUE)
807+
else
808+
upd_output("var_name", str, force = TRUE)
809+
.p$do_return <- TRUE
810+
return(TRUE)
811+
}
812+
}
813+
}
762814
}
763815
}
764816
}

‎R/print.summarytools.R‎

Lines changed: 18 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -1381,11 +1381,6 @@ print_descr <- function(x, method) {
13811381
x <- round(x, format_info$digits)
13821382
x <- do.call(format, append(format_args, list(x = quote(x))))
13831383

1384-
#if (!"Weights" %in% names(data_info)) {
1385-
# row_ind <- which(trs("n.valid") == rownames(x))
1386-
# x[row_ind, ] <- sub("\\.0+", "", x[row_ind, ])
1387-
#}
1388-
13891384
main_sect %+=%
13901385
paste(
13911386
capture.output(
@@ -1416,27 +1411,36 @@ print_descr <- function(x, method) {
14161411
}
14171412

14181413
table_rows <- list()
1414+
1415+
# Determine which cells are "n" or "n.valid" in order to remove digits
1416+
# This is much easier than editing pairlists after-the-fact
1417+
if ("Weights" %in% names(data_info)) {
1418+
hide_digits <- FALSE
1419+
} else {
1420+
if (isTRUE(data_info$transposed)) {
1421+
co_hide_ind <- which(colnames(x) %in% c(trs("n"), trs("n.valid")))
1422+
hide_digits <- quote(co %in% co_hide_ind)
1423+
} else {
1424+
ro_hide_ind <- which(rownames(x) %in% c(trs("n"), trs("n.valid")))
1425+
hide_digits <- quote(ro %in% ro_hide_ind)
1426+
}
1427+
}
1428+
14191429
for (ro in seq_len(nrow(x))) {
14201430
table_row <- list(tags$td(tags$strong(rownames(x)[ro])))
14211431
for (co in seq_len(ncol(x))) {
1422-
# cell is NA
14231432
if (is.na(x[ro,co])) {
14241433
table_row %+=% list(tags$td(format_info$missing))
14251434
} else {
1426-
# When not NA format cell content
14271435
cell <- do.call(format, append(format_args, x = quote(x[ro,co])))
1428-
if ((rownames(x)[ro] == trs("n.valid") ||
1429-
colnames(x)[co] == trs("n.valid")) &&
1430-
!"Weights" %in% names(data_info)) {
1436+
# check for n and n.valid -- remove digits if applicable
1437+
if (eval(hide_digits)) {
14311438
cell <- sub(paste0(format_info$decimal.mark, "0+$"), "", cell)
14321439
}
14331440
table_row %+=% list(tags$td(tags$span(cell)))
14341441
}
1435-
# On last column, insert row to table_rows list
1436-
if (co == ncol(x)) {
1437-
table_rows %+=% list(tags$tr(table_row))
1438-
}
14391442
}
1443+
table_rows %+=% list(tags$tr(table_row))
14401444
}
14411445

14421446
descr_table_html <-

‎R/stby.R‎

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -121,11 +121,12 @@ stby <- function(data, INDICES, FUN, ..., useNA = FALSE) {
121121
}
122122

123123
# remove NULL elements (has side-effect of removing dim and dimnames)
124-
for (col in seq_along(res)) {
125-
if (is.null(res[[col]])) {
126-
res[[col]] <- NULL
127-
groups <- groups[-col,]
128-
}
124+
non_null_ind <- which(!vapply(res, is.null, logical(1)))
125+
if (length(non_null_ind)) {
126+
atr <- attributes(res)
127+
res <- res[non_null_ind]
128+
attributes(res) <- atr[c("call", "class")]
129+
groups <- groups[non_null_ind,]
129130
}
130131

131132
# Set useNA as attribute; to be used by tb()
@@ -136,7 +137,8 @@ stby <- function(data, INDICES, FUN, ..., useNA = FALSE) {
136137
if (ncol(groups) == 1 && length(res) == length(groups[[1]])) {
137138
names(res) <- groups[[1]]
138139
} else {
139-
names(res) <- sapply(res, function(gr) attr(gr, "data_info")$Group)
140+
names(res) <- vapply(res, function(gr) attr(gr, "data_info")$Group,
141+
character(1))
140142
}
141143
#.e_reset()
142144
return(res)

0 commit comments

Comments
 (0)