Merge pull request #167 from atorus-research/gh_issue_155

Code clean-up

.gitignore

@@ -5,3 +5,4 @@
 inst/doc
 Tplyr.Rproj
 docs/
+scratch.R

DESCRIPTION

@@ -26,6 +26,14 @@ Authors@R:
  family = "Mascary",
  email = "sadchla.mascary@atorusresearch.com",
  role = "ctb"),
+ person(given = "Andrew",
+ family = "Bates",
+ email = "andrew.bates@atorusresearch.com",
+ role = "ctb"),
+ person(given = "Shiyu",
+ family = "Chen",
+ email = "shiyu.chen@atorusresearch.com",
+ role = "ctb"),
  person(given = "Atorus Research LLC",
  role = "cph")
  )

R/assertions.R

@@ -42,22 +42,7 @@ assert_has_class <- function(x, should_be) {
 
  # Is the argument the class that it should be?
  if (class(x) != should_be){
- # Grab the trace back into an object
- trc <- trace_back()
- # Look at the length of the traceback
- max_length <- length(trc$calls)
- # If it's >1 we're inside a function, so grab the name
- if (max_length > 1){
- # Pull the name out of the call stack
- cname <- call_name(trc$calls[[max_length - 1]])
- # Make a display string
- func_str <- paste0('` in function `', cname, '`')
- } else {
- # Filler
- func_str <- '`'
- }
- # Abort and show error
- abort(paste0('Argument `', param, func_str, ' must be ',
+ abort(paste0('Argument `', param, '` must be ',
  should_be, '. Instead a class of "', class(x),
  '" was passed.'))
  }
@@ -75,24 +60,9 @@ assert_inherits_class <- function(x, should_have) {
 
  # Is the argument the class that it should be?
  if (!inherits(x, should_have)){
-
- # Grab the trace back into an object
- trc <- trace_back()
- # Look at the length of the traceback
- max_length <- max(trc$indices)
- # If it's >1 we're innside a function, so grab the name
- if (max_length > 1){
- # Pull the name out of the call stack
- cname <- call_name(trc$calls[[max_length - 1]])
- # Make a display string
- func_str <- paste0('` in function `', cname, '`')
- } else {
- # Filler
- func_str <- '`'
- }
  # Abort and show error
- abort(paste0('Argument `', param, func_str,
- ' does not inherit "', should_have,
+ abort(paste0('Argument `', param,
+ '` does not inherit "', should_have,
  '". Classes: ', paste(class(x), collapse=", ")))
  }
 }
@@ -197,15 +167,6 @@ unpack_vars <- function(quo_list, allow_character=TRUE) {
  quo_list
 }
 
-#' Check if a quosure is null or contains a call
-#'
-#' @param quo_var A quosure object to check
-#'
-#' @noRd
-is_null_or_call <- function(quo_var) {
- quo_is_null(quo_var) || inherits(quo_get_expr(quo_var), "call")
-}
-
 #' Check if a quosure is null or contains a logical value
 #'
 #' @param quo_var A quosure object to check
@@ -222,14 +183,6 @@ assert_is_layer <- function(object) {
  assert_inherits_class(object, "tplyr_layer")
 }
 
-#' @param object Object to check if its a layer
-#'
-#' @noRd
-assert_is_table <- function(object) {
- assert_inherits_class(object, "tplyr_table")
-}
-
-
 #' Return the class of the expression inside a quosure
 #'
 #' @param q A quosure

R/layer.R

@@ -101,18 +101,10 @@ as_tplyr_layer.tplyr_layer <- function(parent, target_var, by, where, type, ...)
  layer
 }
 
-#' S3 method for tplyr layer creation of \code{tplyr_subgroup_layer} object as parent
-#' @noRd
-as_tplyr_layer.tplyr_subgroup_layer <- function(parent, target_var, by, where, type, ...) {
- layer <- new_tplyr_layer(parent, target_var, by, where, type, ...)
- class(layer) <- unique(append('tplyr_subgroup_layer', class(layer)))
- layer
-}
-
 #' S3 method to produce error for unsupported objects as parent
 #' @noRd
 as_tplyr_layer.default <- function(parent, target_var, by, where, type, ...) {
- stop('Must provide `tplyr_table`, `tplyr_layer`, or `tplyr_subgroup_layer` object from the `tplyr` package.')
+ stop('Must provide `tplyr_table` object from the `Tplyr` package.', call.=FALSE)
 }
 
 #' Create a new tplyr layer

R/table.R

@@ -41,16 +41,7 @@
 #' tab <- tplyr_table(iris, Species, where = Sepal.Length < 5.8)
 #'
 tplyr_table <- function(target, treat_var, where = TRUE, cols = vars()) {
-
- if(missing(target)){
- # return a blank environment if no table information is passed. This can be
- # used as a placeholder when creating a table if the dataset is not available.
- return(structure(rlang::env(),
- class = c("tplyr_table", "environment")))
- }
-
  target_name <- enexpr(target)
-
  new_tplyr_table(target, enquo(treat_var), enquo(where), enquos(cols), target_name)
 }
 

R/utils.R

@@ -12,7 +12,7 @@
 modify_nested_call <- function(c, examine_only=FALSE, ...) {
 
  # Get exports from Tplyr
- allowable_calls = getNamespaceExports("Tplyr")
+ allowable_calls <- getNamespaceExports("Tplyr")
 
  # Only allow the user to use `Tplyr` functions
  assert_that(
@@ -154,22 +154,6 @@ replace_by_string_names <- function(dat, by, treat_var = NULL) {
  mutate_at(row_labels, ~ as.character(.x)) # Coerce all row labels into character
 }
 
-#' Get the unique levels/factors of a dataset
-#'
-#' @param e An environment, generally a table or a layer object
-#' @param x A target variable to get the levels/unique values of
-#'
-#' @return Unique target values
-#' @noRd
-get_target_levels <- function(e, x) {
- # If its a factor just return the levels
- if(is.factor(env_get(e, "target", inherit = TRUE)[, as_name(x)])) levels(env_get(e, "built_target", inherit = TRUE)[, as_name(x)])
- # Otherwise return the unique values
- else {
- unique(env_get(e, "built_target", inherit = TRUE)[, as_name(x)])
- }
-}
-
 #' Replace repeating row label variables with blanks in preparation for display.
 #'
 #' Depending on the display package being used, row label values may need to be
@@ -267,22 +251,6 @@ extract_character_from_quo <- function(var_list) {
  var_list[!is_symbol_]
 }
 
-#' Get maximum string format recursivly
-#'
-#' @param lay A layer object
-#'
-#' @return Maximum length of sub layers
-#' @noRd
-get_max_length <- function(lay) {
- # Initalize max_ to -1
- max_ <- -1L
- # Get maximum length of all sub layers
- if(length(lay$layers) > 0) max_ <- max(map_int(lay$layers, get_max_length))
-
- # return greatest between sub layers and current layer
- max(max_, lay$format_strings$size)
-}
-
 #' Clean variable attributes
 #'
 #' @param dat Dataframe to strip of variable attributes

README.Rmd

@@ -19,7 +19,7 @@ library(Tplyr)
 library(knitr)
 ```
 
-# *Tplyr* <img src="man/figures/logo.png" align="right" alt="" width="120" />
+# **Tplyr** <img src="man/figures/logo.png" align="right" alt="" width="120" />
 
 <!-- badges: start -->
 [<img src="http://pharmaverse.org/shields/Tplyr.svg">](https://pharmaverse.org)
@@ -48,7 +48,7 @@ install.packages("Tplyr")
 devtools::install_github("https://github.com/atorus-research/Tplyr.git", ref="devel")
 ```
 
-# What is *Tplyr*? 
+# What is **Tplyr**? 
 
 [dplyr](https://dplyr.tidyverse.org/) from tidyverse is a grammar of data manipulation. So what does that allow you to do? It gives you, as a data analyst, the capability to easily and intuitively approach the problem of manipulating your data into an analysis ready form. [dplyr](https://dplyr.tidyverse.org/) conceptually breaks things down into verbs that allow you to focus on _what_ you want to do more than _how_ you have to do it.
 
@@ -88,7 +88,7 @@ tplyr_table(tplyr_adsl, TRT01P, where = SAFFL == "Y") %>%
  kable()
 ```
 
-## *Tplyr* is Qualified
+## **Tplyr** is Qualified
 
 We understand how important documentation and testing is within the pharmaceutical world. This is why outside of unit testing **Tplyr** includes an entire user-acceptance testing document, where requirements were established, test-cases were written, and tests were independently programmed and executed. We do this in the hope that you can leverage our work within a qualified programming environment, and that we save you a substantial amount of trouble in getting it there.
 

README.md

@@ -1,7 +1,7 @@
 
 <!-- README.md is generated from README.Rmd. Please edit that file -->
 
-# *Tplyr* <img src="man/figures/logo.png" align="right" alt="" width="120" />
+# **Tplyr** <img src="man/figures/logo.png" align="right" alt="" width="120" />
 
 <!-- badges: start -->
 
@@ -42,7 +42,7 @@ install.packages("Tplyr")
 devtools::install_github("https://github.com/atorus-research/Tplyr.git", ref="devel")
 ```
 
-# What is *Tplyr*?
+# What is **Tplyr**?
 
 [dplyr](https://dplyr.tidyverse.org/) from tidyverse is a grammar of
 data manipulation. So what does that allow you to do? It gives you, as a
@@ -134,7 +134,7 @@ tplyr_table(tplyr_adsl, TRT01P, where = SAFFL == "Y") %>%
 | Age Categories n (%) | \>80 | 30 ( 34.9%) | 18 ( 21.4%) | 29 ( 34.5%) | 2 | 1 | 2 |
 | Age Categories n (%) | 65-80 | 42 ( 48.8%) | 55 ( 65.5%) | 47 ( 56.0%) | 2 | 1 | 3 |
 
-## *Tplyr* is Qualified
+## **Tplyr** is Qualified
 
 We understand how important documentation and testing is within the
 pharmaceutical world. This is why outside of unit testing **Tplyr**

tests/testthat/_snaps/layer.md

@@ -20,7 +20,7 @@
 
 # Parent must be a `tplyr_table`, `tplyr_layer`, or `tplyr_subgroup_layer`
 
- Must provide `tplyr_table`, `tplyr_layer`, or `tplyr_subgroup_layer` object from the `tplyr` package.
+ Must provide `tplyr_table` object from the `Tplyr` package.
 
 # `by` must me a string, a variable name, or multiple variables submitted using `dplyr::vars`
 

tests/testthat/_snaps/layering.md

@@ -8,7 +8,7 @@
 
 # Parent argument is a valid class (pass through to `tplyr_layer`)
 
- Must provide `tplyr_table`, `tplyr_layer`, or `tplyr_subgroup_layer` object from the `tplyr` package.
+ Must provide `tplyr_table` object from the `Tplyr` package.
 
 # Only `Tplyr` methods are allowed in the `layer` parameter
 

tests/testthat/test-table.R

@@ -1,9 +1,3 @@
-test_that("tplyr_table returns an empty envrionment of class 'tplyr_table' when passed no arguemnts", {
- st <- tplyr_table()
- expect_true(is.environment(st))
- expect_equal(length(rlang::env_names(st)), 0)
-})
-
 test_that("tplyr_table returns a class of tplyr_table and environment", {
  tab <- tplyr_table(data.frame(a = 1:10, b = 11:20), a)
  expect_s3_class(tab, "tplyr_table")