Fixes #299

NEWS.md

@@ -4,7 +4,7 @@
 None
 
 ## New Features
-1. Fix #302 - Add function `tidy_bernoulli()`
+1. Fix #302 - Add function `tidy_bernoulli()` 
 2. Fix #304 - Add function `util_bernoulli_param_estimate()`
 3. Fix #305 - Add function `util_bernoulli_stats_tbl()`
 
@@ -13,6 +13,7 @@ None
 passed arguments and fix `data.table` to directly pass ... arguments.
 2. Fix #295 - Drop warning message of not passing arguments when .use_data_table = TRUE
 3. Fix #303 - Add `tidy_bernoulli()` to autoplot.
+4. Fix #299 - Update `tidy_stat_tbl()`
 
 # TidyDensity 1.2.3
 

R/stats-tidy-stat-func-tbl.R

@@ -68,154 +68,179 @@
 
 tidy_stat_tbl <- function(.data, .x = y, .fns, .return_type = "vector",
                           .use_data_table = FALSE, ...) {
-    atb <- attributes(.data)
-
-    # Tidyeval ----
-    value_var_expr <- rlang::enquo(.x)
-    func <- .fns
-    func_chr <- deparse(substitute(.fns))
-    passed_args <- list(...)
-    return_type <- tolower(as.character(.return_type))
-    .datatable.aware <- TRUE
-
-    # Checks ----
-    if (!return_type %in% c("vector", "list", "tibble", "data.frame")) {
-        rlang::abort(
-            message = "'.return_type' must be either 'vector','list', or 'tibble'",
-            use_cli_format = TRUE
-        )
-    }
-
-    if (!"tibble_type" %in% names(atb)) {
-        rlang::abort(
-            message = "'.data' must come from a 'tidy_' distribution function.",
-            use_cli_format = TRUE
-        )
-    }
-
-    if (rlang::quo_is_missing(value_var_expr)) {
-        rlang::abort(
-            message = "'.x' must be a column from the data.frame/tibble passed to '.data'."
-        )
-    }
-
-    # Prep tibble ----
-    # First is .use_data_table TRUE? If so then execute and forget the rest
-    if (.use_data_table) {
-
-        .x <- deparse(substitute(.x))
-
-        # # Benchmark ran 25 at 15.13 seconds
-        # # Thank you Akrun https://stackoverflow.com/questions/73938515/keep-names-from-quantile-function-when-used-in-a-data-table/73938561#73938561
-        dt <- dplyr::as_tibble(.data) %>%
-            dplyr::select(sim_number, {{ value_var_expr }}) %>%
-            data.table::as.data.table()
-
-        # names(dt) <- c("sim_number","y")
-
-        ret <- data.table::melt(
-            dt[, as.list(func(.SD[[1]], ...)), by = sim_number, .SDcols = .x],
-            id.var = "sim_number",
-            value.name = func_chr
-        ) %>%
-            dplyr::as_tibble() %>%
-            dplyr::arrange(sim_number, variable) %>%
-            dplyr::rename(name = variable)
-
-        return(ret)
-    }
-
-    # Check to see if it is a bootstrap tibble first
-    # Is it a Bootstrap Nested tibble?
-    if (atb$tibble_type == "tidy_bootstrap_nested") {
-        df_tbl <- dplyr::as_tibble(.data) %>%
-            TidyDensity::bootstrap_unnest_tbl() %>%
-            split(.$sim_number) %>%
-            purrr::map(.f = ~ .x %>% dplyr::pull(y))
-    }
+  atb <- attributes(.data)
+
+  # Tidyeval ----
+  value_var_expr <- rlang::enquo(.x)
+  func <- .fns
+  func_chr <- deparse(substitute(.fns))
+  passed_args <- list(...)
+  return_type <- tolower(as.character(.return_type))
+  .datatable.aware <- TRUE
+
+  # Checks ----
+  if (!return_type %in% c("vector", "list", "tibble", "data.frame")) {
+    rlang::abort(
+      message = "'.return_type' must be either 'vector','list', or 'tibble'",
+      use_cli_format = TRUE
+    )
+  }
+
+  if (!"tibble_type" %in% names(atb)) {
+    rlang::abort(
+      message = "'.data' must come from a 'tidy_' distribution function.",
+      use_cli_format = TRUE
+    )
+  }
+
+  if (rlang::quo_is_missing(value_var_expr)) {
+    rlang::abort(
+      message = "'.x' must be a column from the data.frame/tibble passed to '.data'."
+    )
+  }
+
+  # Prep tibble ----
+  # First is .use_data_table TRUE? If so then execute and forget the rest
+  if (.use_data_table) {
+    .x <- deparse(substitute(.x))
+
+    # # Benchmark ran 25 at 15.13 seconds
+    # # Thank you Akrun https://stackoverflow.com/questions/73938515/keep-names-from-quantile-function-when-used-in-a-data-table/73938561#73938561
+    dt <- dplyr::as_tibble(.data) %>%
+      dplyr::select(sim_number, {{ value_var_expr }}) %>%
+      data.table::as.data.table()
+
+    # names(dt) <- c("sim_number","y")
+
+    ret <- data.table::melt(
+      dt[, as.list(func(.SD[[1]], ...)), by = sim_number, .SDcols = .x],
+      id.var = "sim_number",
+      value.name = func_chr
+    ) %>%
+      dplyr::as_tibble() %>%
+      dplyr::arrange(sim_number, variable) %>%
+      dplyr::rename(name = variable)
 
-    # Is it an unnested bootstrap tibble?
-    if (atb$tibble_type == "tidy_bootstrap") {
-        df_tbl <- dplyr::as_tibble(.data) %>%
-            split(.$sim_number) %>%
-            purrr::map(.f = ~ .x %>% dplyr::pull(y))
-    }
-
-    # If regular tidy_ dist tibble ----
-    if (!atb$tibble_type %in% c("tidy_bootstrap", "tidy_bootstrap_nested")) {
-        df_tbl <- dplyr::as_tibble(.data) %>%
-            split(.$sim_number) %>%
-            purrr::map(.f = ~ .x %>% dplyr::pull({{ value_var_expr }}))
-    }
-
-    # New Param Args ----
-    if ("na.rm" %in% names(passed_args)) {
-        tmp_args <- passed_args[!names(passed_args) == "na.rm"]
-    }
-
-    if (!exists("tmp_args")) {
-        args <- passed_args
+    return(ret)
+  }
+
+  # Check to see if it is a bootstrap tibble first
+  # Is it a Bootstrap Nested tibble?
+  if (atb$tibble_type == "tidy_bootstrap_nested") {
+    df_tbl <- dplyr::as_tibble(.data) %>%
+      TidyDensity::bootstrap_unnest_tbl() %>%
+      split(.$sim_number) %>%
+      purrr::map(.f = ~ .x %>% dplyr::pull(y))
+  }
+
+  # Is it an unnested bootstrap tibble?
+  if (atb$tibble_type == "tidy_bootstrap") {
+    df_tbl <- dplyr::as_tibble(.data) %>%
+      split(.$sim_number) %>%
+      purrr::map(.f = ~ .x %>% dplyr::pull(y))
+  }
+
+  # If regular tidy_ dist tibble ----
+  if (!atb$tibble_type %in% c("tidy_bootstrap", "tidy_bootstrap_nested")) {
+    df_tbl <- dplyr::as_tibble(.data) %>%
+      split(.$sim_number) %>%
+      purrr::map(.f = ~ .x %>% dplyr::pull({{ value_var_expr }}))
+  }
+
+  # New Param Args ----
+  if ("na.rm" %in% names(passed_args)) {
+    tmp_args <- passed_args[!names(passed_args) == "na.rm"]
+  }
+
+  if (!exists("tmp_args")) {
+    args <- passed_args
+  } else if (exists("tmp_args")) {
+    args <- tmp_args
+  } else {
+    args <- NULL
+  }
+
+  # If length of args = 0 then NULL
+  if (length(args) == 0) args <- NULL
+
+  # Run func ----
+  if (return_type == "vector") {
+    ret <- sapply(df_tbl, func, ...)
+    if (is.null(colnames(ret))) {
+      cn <- names(ret)
     } else {
-        args <- tmp_args
+      cn <- colnames(ret)
     }
+    cn <- stringr::str_c("sim_number_", cn)
 
-    # Run func ----
-    if (return_type == "vector") {
-        ret <- sapply(df_tbl, func, ...)
-        if (is.null(colnames(ret))) {
-            cn <- names(ret)
-        } else {
-            cn <- colnames(ret)
-        }
-        cn <- stringr::str_c("sim_number_", cn)
-
-        if (is.null(colnames(ret))) {
-            names(ret) <- cn
-        } else {
-            colnames(ret) <- cn
-        }
+    if (is.null(colnames(ret))) {
+      names(ret) <- cn
+    } else {
+      colnames(ret) <- cn
     }
-
-    if (return_type == "list") {
-        ret <- lapply(df_tbl, func, ...)
-        ln <- names(ret)
-        cn <- stringr::str_c("sim_number_", ln)
-        names(ret) <- cn
+  }
+
+  if (return_type == "list") {
+    ret <- lapply(df_tbl, func, ...)
+    ln <- names(ret)
+    cn <- stringr::str_c("sim_number_", ln)
+    names(ret) <- cn
+  }
+
+  # Another fix
+  # https://stackoverflow.com/questions/73989631/passing-a-function-and-arguments-to-a-function-and-purrr
+  if (return_type == "tibble") {
+    # Benchmark ran 25 at 73 seconds
+    ret <- purrr::map(
+      df_tbl, ~ if (is.null(args)) func(.x) else func(.x, unlist(args))
+    )
+
+    if (is.null(args)) {
+      ret <- ret %>%
+        purrr::map(~ cbind(.x, name = names(.x))) %>%
+        purrr::imap(~ cbind(.x, sim_number = .y)) %>%
+        purrr::map_df(dplyr::as_tibble) %>%
+        dplyr::select(sim_number, .x, dplyr::everything()) %>%
+        dplyr::mutate(.x = as.numeric(.x)) %>%
+        dplyr::mutate(sim_number = factor(sim_number)) %>%
+        dplyr::rename(value = .x)
+    } else {
+      ret <- ret %>%
+        purrr::map(~ cbind(.x, name = names(.x))) %>%
+        purrr::imap(.f = ~ cbind(.x, sim_number = .y)) %>%
+        purrr::map_df(dplyr::as_tibble) %>%
+        dplyr::select(sim_number, .x, dplyr::everything()) %>%
+        dplyr::mutate(.x = as.numeric(.x)) %>%
+        dplyr::mutate(sim_number = factor(sim_number)) %>%
+        dplyr::rename(value = .x)
     }
 
-    if (return_type == "tibble") {
-        # Benchmark ran 25 at 73 seconds
-        ret <- purrr::map(
-            df_tbl, ~ func(.x, unlist(args)) %>%
-                purrr::imap(.f = ~ cbind(.x, name = .y)) %>%
-                purrr::map_df(dplyr::as_tibble)
-        ) %>%
-            purrr::imap(.f = ~ cbind(.x, sim_number = .y)) %>%
-            purrr::map_df(dplyr::as_tibble) %>%
-            dplyr::select(sim_number, name, .x) %>%
-            dplyr::mutate(.x = as.numeric(.x)) %>%
-            dplyr::mutate(sim_number = factor(sim_number)) %>%
-            dplyr::rename(value = .x)
-
-        cn <- c("sim_number", "name", func_chr)
-        names(ret) <- cn
-    }
+    cn <- c("sim_number", func_chr, "name")
+    if ("name" %in% names(ret)) {
+      names(ret) <- cn
+    } else {
+      ret <- ret %>%
+        dplyr::mutate(name = 1)
 
-    # Return
-    if (inherits(ret, "tibble") | inherits(ret, "data.table")){
-        attr(ret, "tibble_type") <- "tidy_stat_tbl"
-        attr(ret, ".fns") <- deparse(substitute(.fns))
-        attr(ret, "incoming_tibble_type") <- atb$tibble_type
-        attr(ret, ".return_type") <- .return_type
-        attr(ret, ".return_type_function") <- switch(
-            return_type,
-            "vector" = "sapply",
-            "list" ="lapply",
-            "tibble" = "purr_map"
-        )
-        attr(ret, "class") <- "tidy_stat_tbl"
+      names(ret) <- cn
     }
 
-    return(ret)
-
+    ret <- ret %>% dplyr::select(sim_number, name, dplyr::everything())
+  }
+
+  # Return
+  if (inherits(ret, "tibble") | inherits(ret, "data.table")) {
+    attr(ret, "tibble_type") <- "tidy_stat_tbl"
+    attr(ret, ".fns") <- deparse(substitute(.fns))
+    attr(ret, "incoming_tibble_type") <- atb$tibble_type
+    attr(ret, ".return_type") <- .return_type
+    attr(ret, ".return_type_function") <- switch(return_type,
+      "vector" = "sapply",
+      "list" = "lapply",
+      "tibble" = "purr_map"
+    )
+    attr(ret, "class") <- "tidy_stat_tbl"
+  }
+
+  return(ret)
 }

docs/pkgdown.yml

@@ -3,7 +3,7 @@ pkgdown: 2.0.6
 pkgdown_sha: ~
 articles:
   getting-started: getting-started.html
-last_built: 2022-10-10T17:08Z
+last_built: 2022-10-10T17:28Z
 urls:
   reference: https://www.spsanderson.com/TidyDensity/reference
   article: https://www.spsanderson.com/TidyDensity/articles