Summarising tables

Library

Load the packages used in the demonstration.

package_list <- c("tidyverse", "lubridate", "knitr")
invisible(suppressPackageStartupMessages(lapply(package_list, library, character.only = TRUE)))
rm(package_list)
options(digits=9)

Functions

The functions instantiated in following code block addresses the scenarios listed above. The inline comments below describe the working and sequence of each function.

func_rename <-
  function(x) {
    
    # sequence is important here
    # regex removing all chars not alpha-numeric, underscore or period
    gsub("[^[:alnum:] \\_\\.]", "", x) %>%
      
      # replace any space or period with underscore
      str_replace_all(pattern = " |\\.", replacement = "\\_") %>%
      
      # replace multiple underscores with one
      str_replace_all(pattern = "\\_+", replacement = "\\_") %>%
      
      # remove trailing underscores and period
      str_remove(pattern = "\\_$|\\.$")
  }

func_legible_boolean <-
  
  # returns `feature name` when TRUE and "Not_" + `feature name` otherwise
  function(df) {
    
    # only exec if there is a logical field in the df
    if (df %>%
            select_if(is.logical) %>%
            ncol() > 0) {
    # add row numbers to input dataframe
    df <-
      df %>%
      ungroup() %>%
      mutate(row_id = row_number())
    
    # select row_id and other logical fields
    tmp <-
      df %>%
      select(row_id, select_if(., is.logical) %>% names(.)) %>%
      
      # gather all logical fields and keep row_id to retain identity
      gather(key, value,-row_id) %>%
      
      # when value is TRUE then return the feature name else "Not_" pasted in
      # front of it
      mutate(value = case_when(
        value ~ key,
        TRUE ~ paste("Not", key, sep = "_")
      )) %>%
      
      # return the feature names back to header positions
      spread(key, value)
    
    vars <- 
      df %>%
      select_if(is.logical) %>%
      names()
    
    df %>% 
      
      # return all values from the table after excluding the original logical
      # fields and join the newly adjuted features back into the table using the
      # row_id
      select(-(!!vars)) %>%
      inner_join(tmp,
                 by = "row_id") %>%
      
      # remove the row_id as the join is complete
      select(-row_id)
    } else {
      df %>% 
        return()
    }
  }

func_create_summary <-
  
  # group by factors, summarising numeric fields to sum total
  function(df) {
    
    # create a list of factors from the input dataframe
    tmp_factors <- df %>% select_if(is.factor) %>% names()
    
    # mutate all factors in the dataframe to characters
    df <- df %>% ungroup() %>% mutate_if(is.factor, as.character)
    
    
    # list original dataframe with a newly created summary row
    list(
      
      # original input dataframe
      df,
      
      # summary row, replaceing each factor value to "Total"
      df %>%
        mutate_at(tmp_factors, ~"Total") %>%
        
        # group by for each of the original factor features
        group_by_at(tmp_factors) %>%
        
        # summarise all numeric values to sum total, ignoring NULL values
        summarise_if(is.numeric, sum, na.rm = TRUE)
    ) %>% 
      
      # union all tables contained in the list, including original dataframe and
      # newly created summary row
      reduce(union_all) %>%
      
      # change factors back into factors
      mutate_at(tmp_factors, factor) %>% 
      return()
  }


func_present_headers <-
  function(.) {
    
    # replace all `spaceholder underscores` with spaces
    str_replace_all(., pattern = "_", replacement = " ") %>%
      
      # change all words in string to title text
      str_to_title() %>%
      return()
  }

Parameters and Configuration

I am using the Brazilian E-Commerce Public Dataset by Olist from kaggle Datasets in this demonstration. The var_path parameter stores the location of the source data within my environment.

var_path <- "~/Documents/Training/datasets/brazilian-ecommerce/"

Import

Please note that, parsing in this case, the messages upon readr::read_csv are disabled to make the article more legible.

The code sequence below is written to import a nominated subset of files into a single dataframe (datablock), nesting each file as a tibble.

df_files <-
  
  # traverse the specified directory and add list of files to a table and rename
  # the tibble's default column value to file_name_ext, representing the name of
  # the file and its extention
  list.files(path = var_path,
             pattern = ".",
             recursive = TRUE) %>%
  enframe(name = NULL) %>%
  rename(file_name_ext = value) %>%
  
  # remove the file extention to isolate the file name as a separate variable
  mutate_at("file_name_ext", list(file_name = str_remove), pattern = "\\.csv") %>% 
  
  # build a file path input for each file as used by the file parameter in the
  # read_csv function
  mutate(file_path = paste0(var_path, file_name_ext)) %>%
  
  # map the file_path to readr::read_csv to iteratively upload each file listed in the
  # table
  mutate(file = map(file_path, function(param_file_path) {
    read_csv(file = param_file_path) %>%
      return()
  })) %>%
  
  # standardise the naming of each file in situ
  mutate_at("file", map, function(df) {
    df %>% 
      rename_all(func_rename) %>% 
      return()
  }) %>% 
  
  # remove redundant variables to tidy up the datablock
  select(-file_path, -file_name_ext)

# print new table to glance the imported product
df_files

## # A tibble: 9 x 2
##   file_name                         file                    
##   <chr>                             <list>                  
## 1 olist_customers_dataset           <tibble [99,441 × 5]>   
## 2 olist_geolocation_dataset         <tibble [1,000,163 × 5]>
## 3 olist_order_items_dataset         <tibble [112,650 × 6]>  
## 4 olist_order_payments_dataset      <tibble [103,886 × 5]>  
## 5 olist_order_reviews_dataset       <tibble [100,000 × 7]>  
## 6 olist_orders_dataset              <tibble [99,441 × 8]>   
## 7 olist_products_dataset            <tibble [32,951 × 9]>   
## 8 olist_sellers_dataset             <tibble [3,095 × 4]>    
## 9 product_category_name_translation <tibble [71 × 2]>

This confirms 9 files imported, specifying the rows nrow and columns ncol of each nested tibble.

Inspect Data

The function func_inspect_file helps to extract and print the structure of nested tibbles, including olist_order_payments_dataset, olist_orders_dataset and olist_customers_dataset contained within df_files.

Changing the character fields to factors better structures and provides additional information about the features.

func_inspect_file <-
  function(param_file_name) {
    
    # create *** separators to pad tibble names followed by printed structure
    rep("*", 30) %>% paste(collapse = "") %>% print()
    print(param_file_name)
    rep("*", 30) %>% paste(collapse = "") %>% print()
    
    df_files %>%
      filter(file_name == param_file_name) %>%
      select(-file_name) %>%
      unnest() %>%
      mutate_if(is.character, factor) %>%
      head() %>%
      str() %>%
      print()
  }

tibble(
  
  # list tibble names to inspect
  param_file = c(
    "olist_order_payments_dataset",
    "olist_orders_dataset",
    "olist_customers_dataset"
  )
) %>%
  mutate_at("param_file", walk, func_inspect_file)

## [1] "******************************"
## [1] "olist_order_payments_dataset"
## [1] "******************************"
## Classes 'tbl_df', 'tbl' and 'data.frame':    6 obs. of  5 variables:
##  $ order_id            : Factor w/ 99440 levels "00010242fe8c5a6d1ba2dd792cb16214",..: 71446 65633 14657 72396 25967 16046
##  $ payment_sequential  : num  1 1 1 1 1 1
##  $ payment_type        : Factor w/ 5 levels "boleto","credit_card",..: 2 2 2 2 2 2
##  $ payment_installments: num  8 1 1 8 2 2
##  $ payment_value       : num  99.3 24.4 65.7 107.8 128.4 ...
## NULL
## [1] "******************************"
## [1] "olist_orders_dataset"
## [1] "******************************"
## Classes 'tbl_df', 'tbl' and 'data.frame':    6 obs. of  8 variables:
##  $ order_id                     : Factor w/ 99441 levels "00010242fe8c5a6d1ba2dd792cb16214",..: 88951 32546 27770 57386 67044 63543
##  $ customer_id                  : Factor w/ 99441 levels "00012a2ce6f8dcda20d059ce98491703",..: 61761 68730 25514 96584 53774 31118
##  $ order_status                 : Factor w/ 8 levels "approved","canceled",..: 4 4 4 4 4 4
##  $ order_purchase_timestamp     : POSIXct, format: "2017-10-02 10:56:33" "2018-07-24 20:41:37" ...
##  $ order_approved_at            : POSIXct, format: "2017-10-02 11:07:15" "2018-07-26 03:24:27" ...
##  $ order_delivered_carrier_date : POSIXct, format: "2017-10-04 19:55:00" "2018-07-26 14:31:00" ...
##  $ order_delivered_customer_date: POSIXct, format: "2017-10-10 21:25:13" "2018-08-07 15:27:45" ...
##  $ order_estimated_delivery_date: POSIXct, format: "2017-10-18" "2018-08-13" ...
## NULL
## [1] "******************************"
## [1] "olist_customers_dataset"
## [1] "******************************"
## Classes 'tbl_df', 'tbl' and 'data.frame':    6 obs. of  5 variables:
##  $ customer_id             : Factor w/ 99441 levels "00012a2ce6f8dcda20d059ce98491703",..: 2611 9562 30461 69606 30708 52562
##  $ customer_unique_id      : Factor w/ 96096 levels "0000366f3b9a7992bf8c76cfdf3221e2",..: 50397 15434 2273 14193 19734 28806
##  $ customer_zip_code_prefix: Factor w/ 14994 levels "01003","01004",..: 4774 3802 68 3586 4307 13965
##  $ customer_city           : Factor w/ 4119 levels "abadia dos dourados",..: 1383 3429 3598 2342 708 1937
##  $ customer_state          : Factor w/ 27 levels "AC","AL","AM",..: 26 26 26 26 26 24
## NULL

## # A tibble: 3 x 1
##   param_file                  
##   <chr>                       
## 1 olist_order_payments_dataset
## 2 olist_orders_dataset        
## 3 olist_customers_dataset

Join

Iterating through a list of tibbles with matching primary and foreign keys will result in a joined dataframe.

Primary and foreign keys on each of the tibbles results in an automatic join for each iteration, using a feature of the dplyr::full_join function to guess joins (column names shared in both tibbles) if none are explicitly provided.

Let’s run the sequence and inspect the head of the resulting datafame.

df_customer_order_payment <-
  
  # a list of tibbles to join
  tibble(
  param_file = c(
    "olist_order_payments_dataset",
    "olist_orders_dataset",
    "olist_customers_dataset"
  )
) %>%
  
  # unnest each tibble listed above, joining it with the result of the previous
  # mapping sequence
  mutate_at("param_file", map, function(param_file) {
    df_files %>%
      filter(file_name == param_file) %>%
      select(-"file_name") %>%
      unnest()
  }) %>%
  reduce(unnest) %>%
  reduce(full_join)

## Joining, by = "order_id"

## Joining, by = "customer_id"

# return head of the joined tibbles
df_customer_order_payment %>% 
  head() %>% 
  
  # specify styling options
  kable(format = "html") %>% 
  kableExtra::kable_styling(full_width = FALSE, font_size = 11) %>% 
  kableExtra::scroll_box(width = "100%", height = "200px")

The head of the dataframe confirms the result of the join.

Grouping Parameter

The configurable param_vars_grouping parameter is populated with variables to be used to group the content of the df_customer_order_payment dataframe.

param_vars_grouping <- vars(customer_state, Purchase_year, Credit_Card)

Output

This is where we implement the functions previously described to create a presentation-ready summary table of the payment data contained in the df_customer_order_payment dataframe.

df_customer_order_payment_data <-
  df_customer_order_payment %>%
  
  # create a new boolean feature Credit_Card, defaulting all NULL values to
  # FALSE and make it `legible` using the func_legible_boolean function
  mutate(Credit_Card = coalesce(payment_type == "credit_card", FALSE)) %>%
  func_legible_boolean() %>%
  
  # simplify the order_purchase_timestamp to keep year only and store in a newly
  # created `Purchase_year` feature
  mutate_at("order_purchase_timestamp", list(Purchase_year = year)) %>%
  
  # change all grouping variables to factor, grouping by all factors and
  # summarising payment_value for each combination of grouping variables
  mutate_at(param_vars_grouping, factor) %>%
  group_by_if(is.factor) %>%
  summarise_at("payment_value", sum, na.rm = TRUE) %>%
  ungroup() %>%
  
  # keep the top 3 customer_states ordered by desc payment_value total and lump
  # the other states into `Other`
  mutate(customer_state = fct_lump(f = customer_state, w = payment_value, n = 3)) %>%
  
  # regroup all factors based on the revised customer_state, and recalculate the
  # sum total for combinations
  group_by_if(is.factor) %>%
  summarise_if(is.numeric, sum, na.rm = TRUE) %>%
  
  # spread the payment values for each grouping combination by year
  spread(Purchase_year, payment_value) %>%
  ungroup() %>%
  
  # regroup and nest the summary content for each grouping combination
  group_by_if(is.factor) %>%
  nest() %>%
  
  # map each nested summary, gather the values and elongate the summary, summing
  # the content of the numeric field only
  mutate_at("data", list(total = map), function(df) {
    df %>%
      gather() %>%
      summarise_if(is.numeric, sum, na.rm = TRUE) %>%
      
      # rename to Total as it will be added back into the grouping tibble when
      # unnested
      rename(Total = value) %>%
      
      # return the result
      return()
  }) %>%
  # unnest the newly created 'Total' feature
  unnest()

df_customer_order_payment_data %>% 
  
  # summarise each numeric column into sum totals
  func_create_summary() %>%
  
  # rename all headers by replacing placeholder underscores with spaces
  rename_all(func_present_headers) %>%
  
  # round all numeric values up to the nearest dollar and format value as
  # currency
  mutate_if(is.numeric, ~round(.) %>% scales::dollar(.)) %>%
  mutate_if(is.character, str_remove, pattern = "\\$NA") %>%
  
  # rename all factor values by replacing placeholder underscores with spaces
  mutate_if(is.factor, str_replace_all, pattern = "_", replacement = " ") %>%
  
  # align tabular values right and output as html
  kable(align = "r", format = "html") %>% 
  kableExtra::kable_styling(full_width = FALSE, 
                            font_size = 12) %>% 
  
  # merge duplicate rows into single cells (matplotlib style) to improve clarity
  kableExtra::collapse_rows(columns = 1, 
                            valign = "top") %>% 
  
  # add additional header categories
  kableExtra::add_header_above(c(
    "Dimension" = 2,
    "Year" = 3,
    " " = 1
  ))

Another approach to output

This following section is a stylised alternative to the previous, creating separate summary tables for the boolean Credit Card payments options. The intention, in line with the theme of this article, is to improve clarity by breaking data into smaller, bite-size chunks.

The approach is instantiating the func_output_group_item_table function that takes as input a grouping parameter, and output the filtered results for distinct and consecutive categories within it.

func_output_group_item_table <-
  function(param_group, param_group_selector) {
    # print the distinct grouping category as header
    cat(paste0(
      "<h4>",
      str_replace_all(param_group, pattern = "_", replacement = " "),
      "</h4>"
    ))
    
    df_customer_order_payment_data %>%
      
      # filter the master data by the grouping category parameter
      filter(!!param_group_selector == param_group) %>%
      ungroup() %>%
      
      #  remove the grouping category from it
      select(-!!param_group_selector) %>%
      
      # create a row with a sum total for each numeric column
      func_create_summary() %>%
      
      # styling and presentation options executed next, as described in the
      # previous code block
      rename_all(func_present_headers) %>%
      mutate_if(is.numeric, ~ round(.) %>% scales::dollar(.)) %>%
      mutate_if(is.character, str_remove, pattern = "\\$NA") %>%
      mutate_if(is.factor,
                str_replace_all,
                pattern = "_",
                replacement = " ") %>%
      kable(align = "r", format = "html") %>%
      kableExtra::kable_styling(full_width = FALSE,
                                font_size = 12) %>%
      kableExtra::collapse_rows(columns = 1:4, valign = "middle") %>%
      return()
  }

func_output_group_item_table_iterator <-
  function(param_group_selector) {
    for (param_group in (df_customer_order_payment_data %>%
                         distinct(!!param_group_selector) %>%
                         pull()))  {
      func_output_group_item_table(param_group, param_group_selector) %>% print()
    }
  }

# input the grouping parameter to output sectioned item tables
func_output_group_item_table_iterator(quo(Credit_Card))

# input the grouping parameter to output sectioned item tables
func_output_group_item_table_iterator(quo(customer_state))