Added support and documentation for grouped dataframe highlighting

DESCRIPTION

@@ -10,7 +10,7 @@ BugReports: https://github.com/coolbutuseless/emphatic/issues
 License: MIT + file LICENSE
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 7.1.1
+RoxygenNote: 7.1.1.9000
 Depends: 
     R (>= 2.10)
 Suggests: 

NAMESPACE

@@ -15,5 +15,6 @@ export(is_emphatic)
 export(knit_print.emphatic)
 importFrom(grDevices,col2rgb)
 importFrom(grDevices,convertColor)
+importFrom(grDevices,rainbow)
 importFrom(grDevices,rgb)
 importFrom(utils,modifyList)

R/data.frame.R

@@ -1,5 +1,17 @@
 
 
+#' Check if a data frame is grouped
+#'
+#' Internal replication of dplyr::is.grouped_df()
+#'
+#' @param x An object
+#'
+#' @return Logical: TRUE if dataframe is grouped; false if not.
+#'
+#' @noRd
+is_grouped <- function(x) {
+  inherits(x, "grouped_df")
+}
 
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 #' Highlight elements by location within an \code{emphatic} data.frame or matrix.
@@ -74,6 +86,10 @@ hl_loc <- function(.data, colour, row_ids, col_ids, elem = 'fill', major = 'row'
     }
   }
 
+
+
+
+
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   # Assign colour
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -85,10 +101,6 @@ hl_loc <- function(.data, colour, row_ids, col_ids, elem = 'fill', major = 'row'
   .data
 }
 
-
-
-
-
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 #' Private inner function for highlighting
 #'
@@ -203,6 +215,10 @@ hl_inner <- function(.data, colour, row_ids, column, dest_col_ids, elem, show_le
 #'      in \code{dplyr::filter()}. E.g. \code{cyl == 6 & mpg > 20}}
 #' }
 #'
+#' Grouped data frames are also supported. Colours are not required for grouped
+#' dataframes, but can be supplied. Additional highlighting customization can be
+#' specified with the the `cols` and `elem` arguments. Other arguments are not
+#' supported for grouped data frames.
 #'
 #' @param .data \code{emphatic} data.frame
 #' @param colour colour to use for highlighting.  This may be an R colour,
@@ -234,6 +250,7 @@ hl_inner <- function(.data, colour, row_ids, column, dest_col_ids, elem, show_le
 #'        then a colourbar legend will be added to the bottom of the output.
 #'        Default: FALSE
 #'
+#' @importFrom grDevices rainbow
 #' @examples
 #' \dontrun{
 #' hl(mtcars, ggplot2::scale_colour_viridis_c(), rows = cyl == 6, cols = mpg, dest_cols = c(mpg, cyl))
@@ -245,6 +262,38 @@ hl_inner <- function(.data, colour, row_ids, column, dest_col_ids, elem, show_le
 hl <- function(.data, colour, rows = NULL, cols = NULL, dest_cols, calc_scale = 'first', elem = 'fill',
                show_legend = FALSE) {
 
+  if (is_grouped(.data)) {
+
+    # Grouped data frames can only be created with dplyr, so this is a bit
+    # redundant. Just being careful.
+    if (requireNamespace("dplyr", quietly = TRUE)) {
+      rows <- dplyr::group_rows(.data)
+      colours <- grDevices::rainbow(length(rows))
+
+      # Check if user supplied colours. If they supplied for each group, use
+      # those. Otherwise use default rainbow.
+      if (!missing(colour)) {
+        if (length(colour) == length(rows)) {
+          colours <- colour
+        }
+        else {
+          warning("Number of colours supplied does not match number of groups. Defaulting to rainbow colours.")
+        }
+      }
+
+      .data <- dplyr::ungroup(.data)
+
+      col <- loc_expr_to_ids(.data, expr = substitute(cols), axis = 'column')
+
+      for (i in 1:length(rows)) {
+        .data <- hl_loc(.data, colour = colours[i], row_ids = rows[[i]], col_ids = col, elem = elem)
+      }
+      return(.data)
+    } else {
+      stop("dplyr package is required for highlighting grouped data frames. Please load and retry.")
+    }
+  }
+
   stopifnot(is.data.frame(.data))
   stopifnot(elem %in% c('text', 'fill'))
   stopifnot(calc_scale %in% c('first', 'each'))

vignettes/specify-rows.Rmd

@@ -29,10 +29,7 @@ hl_opt_global(dark_mode = FALSE)
 test_df <- head(mtcars, 10)
 ```
 
-
-
-Select all rows
-------------------------------------------------------------------------------
+## Select all rows
 
 ```{r}
 test_df %>%
@@ -49,50 +46,42 @@ test_df %>%
   hl('skyblue', rows = .all)
 ```
 
-
-Select rows by index
-------------------------------------------------------------------------------
+## Select rows by index
 
 ```{r}
 test_df %>%
   hl('skyblue', rows = 2:5)
 ```
 
-Select rows by name
-------------------------------------------------------------------------------
+## Select rows by name
 
 ```{r}
 test_df %>%
   hl('skyblue', rows = c('Mazda RX4', 'Datsun 710'))
 ```
 
-Select rows by rowname symbol
-------------------------------------------------------------------------------
+## Select rows by rowname symbol
 
 ```{r}
 test_df %>%
   hl('skyblue', rows = Valiant)
 ```
 
-
-Select rows by expression
-------------------------------------------------------------------------------
+## Select rows by expression
 
 ```{r}
 test_df %>%
   hl('skyblue', rows = mpg > 22)
 ```
 
-Select rows using `n()` and `row_number()`
-------------------------------------------------------------------------------
+## Select rows using `n()` and `row_number()`
 
 ```{r}
 test_df %>%
   hl('skyblue', rows = row_number() > n()/2)
 ```
 
-Select rows using selectors like `tidyselect`
-------------------------------------------------------------------------------
+## Select rows using selectors like `tidyselect`
 
 ```{r}
 test_df %>%
@@ -104,9 +93,19 @@ test_df %>%
   hl('skyblue', rows = starts_with('m'))
 ```
 
-
 ```{r}
 test_df %>%
   hl('skyblue', rows = any_of(c('Valiant', 'Herbie', 'Datsun 710')))
 ```
 
+Select rows using grouped data frames
+
+------------------------------------------------------------------------
+
+> Note: For grouped data frames, colours may be supplied for each group but will be chosen automatically if not. Additional customization can be done with the `cols` and `elem` arguments. Other arguments are not supported for grouped data frames.
+
+```{r}
+test_df %>%
+  group_by(cyl) %>%
+  hl()
+```