├── .Rbuildignore ├── .gitignore ├── DESCRIPTION ├── LICENSE ├── LICENSE.md ├── NAMESPACE ├── R ├── construct_pivot_code.R ├── highlight_code.R ├── list_datasets.R ├── mod-codeDisplay.R ├── mod-pivotTable.R ├── mod-selectData.R ├── pivotr-package.R ├── pivotr.R ├── utils-construct_args.R ├── utils-with_corner_buttons.R ├── utils.R └── zzz.R ├── README.md ├── demo.gif ├── inst └── app │ └── www │ ├── custom.css │ ├── prism.css │ └── prism.js ├── man └── pivotr.Rd ├── pivotr.Rproj └── tests ├── testthat.R └── testthat ├── _snaps └── construct_pivot_code.md └── test-construct_pivot_code.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^LICENSE\.md$ 4 | ^demo\.gif$ 5 | ^docs$ 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | .DS_Store 6 | **/.DS_Store 7 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: pivotr 2 | Type: Package 3 | Title: Excel's PivotTables implemented in shiny and dplyr/tidyr 4 | Version: 0.1.0 5 | Authors@R: person("Jacob", "Scott", email = "jscott2718@gmail.com", role = c("aut", "cre")) 6 | Description: Perform data manipulations using a UI heavily inspired by Excel's 7 | PivotTables, then copy the code for those manipulations back into R. 8 | License: MIT + file LICENSE 9 | Encoding: UTF-8 10 | LazyData: true 11 | URL: https://github.com/wurli/pivotr 12 | BugReports: https://github.com/wurli/pivotr/issues 13 | Imports: 14 | bslib (>= 0.5.0), 15 | cli, 16 | dplyr (>= 0.1.0), 17 | glue, 18 | htmltools, 19 | purrr, 20 | rclipboard, 21 | reactable (>= 0.4.4), 22 | readr, 23 | rlang (>= 1.1.0), 24 | shiny (>= 1.7.4), 25 | sortable, 26 | tibble, 27 | tidyr (>= 1.2.0), 28 | vctrs, 29 | zeallot 30 | RoxygenNote: 7.2.3 31 | Suggests: 32 | testthat (>= 3.0.0) 33 | Config/testthat/edition: 3 34 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2023 2 | COPYRIGHT HOLDER: pivotr authors 3 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2023 pivotr authors 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(pivotr) 4 | import(bslib) 5 | import(cli) 6 | import(dplyr) 7 | import(rlang) 8 | import(shiny) 9 | import(tidyr) 10 | importFrom(glue,glue) 11 | importFrom(purrr,imap) 12 | importFrom(purrr,map) 13 | importFrom(purrr,map_chr) 14 | importFrom(purrr,map_dbl) 15 | importFrom(purrr,map_int) 16 | importFrom(purrr,map_lgl) 17 | importFrom(tibble,as_tibble) 18 | importFrom(utils,data) 19 | importFrom(zeallot,"%<-%") 20 | -------------------------------------------------------------------------------- /R/construct_pivot_code.R: -------------------------------------------------------------------------------- 1 | #' Construct the dplyr code used for the PivotTable 2 | #' 3 | #' @param x A dataframe 4 | #' @param x_name The name/code that represents `x` 5 | #' @param filters A list of filter expressions 6 | #' @param columns,rows Column names to use for the rows/columns PivotTable fields 7 | #' @param values A list of values expressions 8 | #' @param code_width Number of characters to display per line 9 | #' @param pipe Either `"base"` or `"magrittr"` 10 | #' @param use_function_names Whether to indicate the summary function in the 11 | #' output column names 12 | #' @param use_across Whether to use `dplyr::across()` 13 | #' 14 | #' @return A string 15 | #' @noRd 16 | construct_pivot_code <- function(x, x_name = NULL, 17 | filters = NULL, 18 | columns = ".measure", 19 | rows = NULL, 20 | values = NULL, 21 | code_width = 40, 22 | pipe = c("base", "magrittr"), 23 | use_function_names = c("sometimes", "never", "always"), 24 | use_across = c("sometimes", "never", "always")) { 25 | 26 | use_across <- match.arg(use_across) 27 | use_function_names <- match.arg(use_function_names) 28 | pipe <- match.arg(pipe) 29 | pipe <- switch(pipe, base = "|>", magrittr = "%>%") 30 | 31 | width <- function(code) code_width - nchar(glue(code, envir = parent.frame())) 32 | 33 | long_format <- ".measure" %in% rows 34 | 35 | columns <- setdiff(columns, ".measure") 36 | grouping_cols <- setdiff(union(rows, columns), ".measure") 37 | 38 | filters <- filters %||% list(list(cols = NULL, values = NULL)) 39 | values <- values %||% list() 40 | 41 | use_dummy_col <- length(values) == 0L && length(columns) > 0L 42 | 43 | df_name <- x_name %||% expr_deparse(enexpr(x)) 44 | 45 | abort_cols_dont_exist(x, x_name, map(filters, 1), map(values, 1), grouping_cols) 46 | 47 | values <- make_summary_exprs(values, code_width, use_function_names, use_across) 48 | summary_exprs <- values$exprs 49 | new_col_names <- if (use_dummy_col) ".dummy" else values$new_col_names 50 | 51 | step_start <- glue("{df_name}") 52 | 53 | step_as_tibble <- if (!all(class(x) %in% c("tbl_df", "tbl", "data.frame"))) " as_tibble()" 54 | 55 | step_summary <- if (length(grouping_cols) == 0L) { 56 | glue( 57 | " 58 | summarise({summary_exprs}) 59 | ", 60 | summary_exprs = construct_args( 61 | summary_exprs, 62 | always_linebreak = TRUE, 63 | backtick = FALSE, 64 | max_width = width(" summarise() {pipe}") 65 | ) 66 | ) 67 | } else { 68 | grouping_expr <- construct_vec(grouping_cols, max_width = width(" .by = c(),"), indent = 2L) 69 | glue( 70 | " 71 | summarise({summary_exprs}) 72 | ", 73 | summary_exprs = construct_args( 74 | c(paste0(".by = ", grouping_expr), summary_exprs), 75 | always_linebreak = TRUE, 76 | backtick = FALSE 77 | ) 78 | ) 79 | } 80 | 81 | step_dummy_col <- if (use_dummy_col) " mutate(.dummy = NA)" 82 | 83 | step_pivot_longer <- if (long_format) { 84 | glue( 85 | ' 86 | pivot_longer( 87 | {new_col_names}, 88 | names_to = ".measure", 89 | values_to = ".value" 90 | ) 91 | ', 92 | new_col_names = construct_vec( 93 | new_col_names, 94 | max_width = width(" ,"), 95 | indent = 6L 96 | ) 97 | ) 98 | } 99 | 100 | step_relocate <- if (length(rows) > 0 && rows[length(rows)] != ".measure") { 101 | if (rows[1] == ".measure") { 102 | " relocate(.measure)" 103 | } else { 104 | glue( 105 | " relocate(.measure, .after = {prev})", 106 | prev = rows[which(rows == ".measure") - 1L], 107 | .trim = FALSE 108 | ) 109 | } 110 | } 111 | 112 | step_arrange <- if (length(setdiff(rows, ".measure")) > 0L) { 113 | glue( 114 | " 115 | arrange({rows}) 116 | ", 117 | rows = construct_args(rows, max_width = width(" arrange() {pipe}")) 118 | ) 119 | } 120 | 121 | step_pivot_wider <- if (length(columns) > 0) { 122 | pivot_wider_vals_from <- if (long_format) ".value" else new_col_names 123 | 124 | glue( 125 | " 126 | pivot_wider( 127 | names_from = {columns}, 128 | values_from = {pivot_wider_vals_from} 129 | ) 130 | ", 131 | columns = construct_vec( 132 | columns, max_width = width(" names_from = ,") 133 | ), 134 | pivot_wider_vals_from = construct_vec( 135 | pivot_wider_vals_from, max_width = width(" values_from = ,") 136 | ) 137 | ) 138 | } 139 | 140 | paste( 141 | c(step_start, 142 | step_as_tibble, 143 | step_summary, 144 | step_pivot_longer, 145 | step_relocate, 146 | step_arrange, 147 | step_dummy_col, 148 | step_pivot_wider), 149 | collapse = paste0(" ", pipe, "\n") 150 | ) 151 | 152 | } 153 | 154 | abort_cols_dont_exist <- function(df, df_name, ...) { 155 | all_cols <- unique(unlist(c(...))) 156 | bad_cols <- setdiff(all_cols, c(colnames(df), ".measure")) 157 | df_name <- gsub(".+\n", "", df_name) 158 | 159 | if (length(bad_cols) > 0) { 160 | cli_abort( 161 | c( 162 | "Columns specified don't exist", 163 | i = "Table is {.val {df_name}}", 164 | i = "Check {.field {bad_cols}}" 165 | ), 166 | call = caller_call() 167 | ) 168 | } 169 | 170 | } 171 | 172 | 173 | 174 | 175 | # Naming rules for summaries: 176 | # 1. If only one function, use x = f(x) naming scheme 177 | # 2. If multiple functions, use x_f = f(x) naming schema 178 | 179 | # Syntax rules for summaries: 180 | # 1. If 1:1 column/function relationship, use `=` 181 | # 2. If 1:many column/function relationship, use `across()` 182 | 183 | # spec <- list( 184 | # list("x1", "f2"), 185 | # list("x2", "f2"), 186 | # list("x1", "f1"), 187 | # list("x2", "f3"), 188 | # list("x2", "f1"), 189 | # list("x3", "f3"), 190 | # list("x4", "f4") 191 | # ) 192 | make_summary_exprs <- function(spec, code_width = 60L, use_function_names = NULL, use_across = "sometimes") { 193 | 194 | width <- function(code) code_width - nchar(code) 195 | 196 | use_function_names <- switch(use_function_names, 197 | always = TRUE, 198 | never = FALSE, 199 | sometimes = length(unique(unlist(map(spec, 2)))) > 1 200 | ) 201 | 202 | use_across <- switch(use_across, 203 | always = TRUE, 204 | never = FALSE, 205 | sometimes = NULL 206 | ) 207 | 208 | new_col_names <- spec |> 209 | map_chr(\(x) { 210 | if (use_function_names) { 211 | paste(x[[1]], x[[2]], sep = "_") 212 | } else { 213 | x[[1]] 214 | } 215 | }) |> 216 | unique() 217 | 218 | exprs <- spec |> 219 | compress_summary_spec() |> 220 | map(function(x) { 221 | 222 | fun <- x[[2]] 223 | col <- x[[1]] 224 | 225 | use_across <- use_across %||% any(lengths(x) > 1L) 226 | 227 | if (!use_across) { 228 | out <- if (use_function_names) { 229 | name <- maybe_backtick(paste0(col, "_", fun)) 230 | col <- maybe_backtick(col) 231 | glue("{name} = {fun}({col})") 232 | } else { 233 | col <- maybe_backtick(col) 234 | glue("{col} = {fun}({col})") 235 | } 236 | return(out) 237 | } 238 | 239 | cols_exprs <- construct_vec(col, indent = 2L, max_width = width(" ,")) 240 | funs_exprs <- if (!use_function_names) { 241 | fun 242 | } else { 243 | glue("list({args})", args = construct_args( 244 | glue("{fun} = {fun}"), 245 | backtick = FALSE, 246 | max_width = width(" ,") 247 | )) 248 | } 249 | 250 | glue( 251 | "across({args})", 252 | args = construct_args( 253 | c(cols_exprs, funs_exprs), 254 | backtick = FALSE, 255 | max_width = width(" across()"), 256 | indent = 2L 257 | ) 258 | ) 259 | }) |> 260 | unlist(use.names = FALSE) 261 | 262 | list(exprs = exprs, new_col_names = new_col_names) 263 | 264 | } 265 | 266 | # @examples 267 | # spec <- list( 268 | # list("x1", "f2"), 269 | # list("x2", "f2"), 270 | # list("x1", "f1"), 271 | # list("x2", "f3"), 272 | # list("x2", "f1"), 273 | # list("x3", "f3") 274 | # ) 275 | # compress_summary_spec(spec) 276 | compress_summary_spec <- function(spec) { 277 | spec_by_fun <- split(spec, map_chr(spec, 2)) |> 278 | map(~ list(map_chr(., 1), .[[1]][[2]])) |> 279 | unname() |> 280 | c() 281 | 282 | spec_by_col <- split(spec_by_fun, map_chr(spec_by_fun, ~ paste(.[[1]], collapse = "."))) |> 283 | map(~ list(.[[1]][[1]], sort(map_chr(., 2)))) |> 284 | unname() |> 285 | c() 286 | 287 | spec_by_col 288 | } 289 | -------------------------------------------------------------------------------- /R/highlight_code.R: -------------------------------------------------------------------------------- 1 | highlight_code <- function(code) { 2 | 3 | code <- paste0( 4 | # Not sure why the -4px indent is needed - first line is out of whack 5 | # otherwise. Maybe a bug in prism? 6 | "
",
 7 |     "",
 8 |     paste(code, collapse = "\n"),
 9 |     "
" 10 | ) 11 | 12 | tagList( 13 | tags$script("Prism.highlightAll()"), 14 | HTML(code) 15 | ) 16 | } 17 | -------------------------------------------------------------------------------- /R/list_datasets.R: -------------------------------------------------------------------------------- 1 | package_datasets <- function(pkg = NULL) { 2 | pkg <- pkg %||% .packages(TRUE) 3 | 4 | pkg |> 5 | set_names() |> 6 | map(function(pkg) { 7 | pkg |> 8 | tibble_data() |> 9 | imap(\(df, name) list(value = df, code = get_dataset_code(pkg, name))) 10 | }) |> 11 | purrr::compact() 12 | 13 | } 14 | 15 | tibble_data <- function(pkg) { 16 | datasets <- data(package = pkg)$results[, "Item"] 17 | datasets <- datasets[!grepl("\\s", datasets)] 18 | 19 | env <- new.env() 20 | data(list = datasets, package = pkg, envir = env) 21 | out <- purrr::keep(as.list(env), can_be_tibble) 22 | if (length(out) == 0L) out else out[order(names(out))] 23 | } 24 | 25 | can_be_tibble <- function(x) { 26 | tryCatch( 27 | { 28 | as_tibble(x) 29 | is.data.frame(x) 30 | }, 31 | error = function(e) FALSE, 32 | warning = function(e) FALSE 33 | ) 34 | } 35 | 36 | get_dataset_code <- function(pkg, dataset) { 37 | purrr::map2_chr(pkg, dataset, function(pkg, dataset) { 38 | if (pkg %in% c("datasets", "dplyr", "tidyr")) { 39 | return(dataset) 40 | } 41 | tryCatch( 42 | { 43 | do.call("::", list(pkg, dataset)) 44 | paste0(pkg, "::", dataset) 45 | }, 46 | error = function(e) { 47 | glue(' 48 | data({dataset}, package = "{pkg}") 49 | 50 | {dataset} 51 | ') 52 | } 53 | ) 54 | }) 55 | } 56 | -------------------------------------------------------------------------------- /R/mod-codeDisplay.R: -------------------------------------------------------------------------------- 1 | codeDisplayUI <- function(id) { 2 | ns <- NS(id) 3 | htmlOutput(ns("code")) 4 | } 5 | 6 | #' Display the code used to generate the PivotTable 7 | #' 8 | #' @param id The `input` slot that will be used to access the value 9 | #' @param dataset A reactive holding the unprocessed data frame 10 | #' @param dataset_code The code used to access the data frame. This may take 11 | #' various forms, e.g. `ggplot2::diamonds`, or a call to `data()` for some 12 | #' packages. 13 | #' @param rows,columns,values Reactives giving the rows, columns, and values as 14 | #' specified in the PivotTable 15 | #' 16 | #' @return A reactive giving code which can be used to produce a 17 | #' transformed/pivoted version of `dataset()` 18 | #' 19 | #' @noRd 20 | codeDisplayServer <- function(id, dataset, dataset_code, rows, columns, values) { 21 | moduleServer(id, function(input, output, session) { 22 | 23 | ns <- NS(id) 24 | 25 | bindEvent(input$code_clipboard, ignoreInit = TRUE, x = observe({ 26 | shiny::showNotification("Code added to clipboard", duration = 3) 27 | })) 28 | 29 | bindEvent(input$code_clipboard_modal, ignoreInit = TRUE, x = observe({ 30 | shiny::showNotification("Code added to clipboard", duration = 3) 31 | })) 32 | 33 | 34 | code <- reactive({ 35 | paste0( 36 | "# library(dplyr)\n", 37 | "# library(tidyr)\n", 38 | "\n", 39 | construct_pivot_code( 40 | dataset(), 41 | dataset_code(), 42 | filters = NULL, 43 | rows = strip_id(rows()), 44 | columns = strip_id(columns()), 45 | values = values(), 46 | code_width = input$code_controls.code_width %||% 80, 47 | pipe = input$code_controls.pipe %||% "base", 48 | use_function_names = input$code_controls.use_function_names %||% "sometimes", 49 | use_across = input$code_controls.use_across %||% "sometimes" 50 | ) 51 | ) 52 | }) 53 | 54 | # Need two code outputs - one for sidebar and one for settings modal 55 | code_ui <- reactive(highlight_code(code())) 56 | output$code <- renderUI( 57 | with_corner_buttons( 58 | code_ui(), 59 | corner_button_clipboard(ns("code_clipboard"), code()), 60 | corner_button(ns("code_settings"), "cog", "Code settings") 61 | ) 62 | ) 63 | 64 | output$modal_code <- renderUI( 65 | with_corner_buttons( 66 | code_ui(), 67 | corner_button_clipboard(ns("code_clipboard_modal"), code(), modal = TRUE) 68 | ) 69 | ) 70 | 71 | bindEvent(input$code_settings, x = observe({ 72 | showModal(modalDialog( 73 | easyClose = TRUE, 74 | title = "PivotTable Code", 75 | size = "xl", 76 | fluidRow( 77 | column(3, sliderInput( 78 | inputId = ns("code_controls.code_width"), 79 | label = "Code width", 80 | value = input$code_controls.code_width %||% 80, 81 | min = 20, 82 | max = 250, 83 | step = 20 84 | )), 85 | column(3, radioButtons( 86 | ns("code_controls.use_across"), 87 | label = span("Use", shiny::code("across()")), 88 | selected = input$code_controls.use_across %||% "sometimes", 89 | choices = c(Never = "never", Sometimes = "sometimes", Always = "always"), 90 | inline = TRUE 91 | )), 92 | column(3, radioButtons( 93 | ns("code_controls.pipe"), 94 | label = "Pipe version", 95 | selected = input$code_controls.pipe %||% "base", 96 | choiceNames = list(HTML("Base |>"), HTML("{magrittr} %>%")), 97 | choiceValues = c("base", "magrittr"), 98 | inline = TRUE 99 | )), 100 | column(3, radioButtons( 101 | ns("code_controls.use_function_names"), 102 | label = "Include summary function in column names", 103 | selected = input$code_controls.use_function_names %||% "sometimes", 104 | choices = c(`When necessary` = "sometimes", Always = "always"), 105 | inline = TRUE 106 | )) 107 | ), 108 | htmlOutput(ns("modal_code")) 109 | )) 110 | })) 111 | 112 | code 113 | }) 114 | } 115 | -------------------------------------------------------------------------------- /R/mod-pivotTable.R: -------------------------------------------------------------------------------- 1 | pivotTableUI <- function(id) { 2 | ns <- NS(id) 3 | fluidRow( 4 | column(7, style = "padding:5px;", 5 | card( 6 | full_screen = TRUE, 7 | reactable::reactableOutput(ns("data")) 8 | ) 9 | ), 10 | column(5, style = "padding:5px;", 11 | h4("PivotTable Fields"), 12 | fluidRow(column(12, 13 | uiOutput(ns("fields_bucket")) 14 | )), 15 | fluidRow( 16 | column(6, style = "padding-right:0px;", uiOutput(ns("filters_ui"))), 17 | column(6, style = "padding-left:0px;", uiOutput(ns("columns_ui"))) 18 | ), 19 | fluidRow( 20 | column(6, style = "padding-right:0px;", uiOutput(ns("rows_ui"))), 21 | column(6, style = "padding-left:0px;", with_corner_buttons( 22 | corner_button(ns("values_settings"), "cog", style = "right:-20px;"), 23 | uiOutput(ns("values_ui")) 24 | )) 25 | ) 26 | ) 27 | ) 28 | } 29 | 30 | #' Generate the PivotTable and fields 31 | #' 32 | #' @param id The `input` slot that will be used to access the value 33 | #' @param dataset A reactive holding the unprocessed data frame 34 | #' @param dataset_name A reactive giving the name of the `dataset()`, e.g. 35 | #' 'diamonds' for `ggplot2::diamonds` 36 | #' @param dataset_pkg A reactive giving the name of the package which provides 37 | #' `dataset()` 38 | #' @param code A reactive giving the code used to perform pivoting operations on 39 | #' `dataset()` 40 | #' @param pkg_data_env The environment in which to evaluate `code()` 41 | #' 42 | #' @return A vector of reactives giving the selected rows, columns, and values 43 | #' @noRd 44 | #' 45 | pivotTableServer <- function(id, dataset, dataset_name, dataset_pkg, code, pkg_data_env) { 46 | moduleServer(id, function(input, output, session) { 47 | 48 | ns <- NS(id) 49 | 50 | .measure_field <- list(.measure = "\U03A3 Value") 51 | 52 | opts_panel <- function(name, id, labels = NULL, class = "pivot-table-options-list") { 53 | sortable::bucket_list(NULL, 54 | group_name = "opts", # Means items can be dragged between buckets 55 | sortable::add_rank_list(name, input_id = id, labels = labels), 56 | class = paste("default-sortable", class) 57 | ) 58 | } 59 | 60 | make_fields <- function(x, preexisting = NULL) { 61 | x |> 62 | imap(function(x, y) { 63 | ptype <- paste0("<", vctrs::vec_ptype_abbr(x), ">") 64 | HTML(glue::glue('{ptype}{y}')) 65 | }) |> 66 | # Long story short, it's hard to track where different cols get 67 | # dragged to without using unique identifiers for each item 68 | set_names(~ paste0(random_id(), "__", .)) 69 | } 70 | 71 | # -- Re-render pivot table opts whenever a new dataset is selected --------- 72 | bindEvent(dataset(), x = observe({ 73 | output$filters_ui <- renderUI(opts_panel("Filters", ns("filters"))) 74 | output$columns_ui <- renderUI(opts_panel("Columns", ns("columns"), labels = .measure_field)) 75 | output$rows_ui <- renderUI(opts_panel("Rows", ns("rows"))) 76 | output$values_ui <- renderUI(opts_panel("Values", ns("values"))) 77 | })) 78 | 79 | # -- 'Pivot Table Fields' bucket ------------------------------------------- 80 | bindEvent(input$fields, ignoreNULL = FALSE, x = observe({ 81 | # 'measure' gets destroyed when dragged into 'Fields', so just put it back 82 | # in 'Columns' 83 | if (".measure" %in% input$fields) { 84 | output$columns_ui <- renderUI(opts_panel( 85 | "Columns", ns("columns"), 86 | labels = c( 87 | .measure_field, 88 | dataset() |> 89 | select(any_of(map_chr(isolate(input$columns), strip_id))) |> 90 | make_fields() 91 | ) 92 | )) 93 | } 94 | 95 | # Whenever a field is dragged to a new panel, re-render so the field 96 | # gets re-added to the 'Pivot Table Fields' bucket 97 | if (length(input$fields) != ncol(dataset())) { 98 | output$fields_bucket <- renderUI(opts_panel( 99 | NULL, ns("fields"), 100 | labels = make_fields(dataset()), 101 | class = "fields-list" 102 | )) 103 | } 104 | })) 105 | 106 | # Used to generate pivottable code 107 | values <- bindEvent(input$values, input$update_functions, x = reactive({ 108 | input$values |> 109 | map(function(id) { 110 | colname <- strip_id(id) 111 | col <- dataset()[[colname]] 112 | fun <- funs()[[id]] %||% (if (is.numeric(col)) "sum" else "length") 113 | list(cols = colname, funs = fun) 114 | }) 115 | })) 116 | 117 | # Summary function used for each column 118 | funs <- reactiveVal(list()) 119 | 120 | # Update summary function used for each column when the user 121 | # specifies by closing the modal 122 | bindEvent(input$update_functions, x = observe({ 123 | removeModal() 124 | 125 | new_funs <- input$values |> 126 | set_names() |> 127 | map(~ input[[.]]) 128 | 129 | funs(new_funs) 130 | })) 131 | 132 | 133 | output$data <- reactable::renderReactable({ 134 | 135 | # Load the data into an app-specific environment to avoid polluting the global envir 136 | data(list = dataset_name(), package = dataset_pkg(), envir = pkg_data_env) 137 | 138 | df <- eval(parse(text = code()), envir = pkg_data_env) 139 | 140 | if (ncol(df) == 0L) { 141 | df <- tibble(`-` = integer()) 142 | } 143 | 144 | reactable::reactable( 145 | df, 146 | bordered = TRUE, 147 | striped = TRUE, 148 | outlined = TRUE, 149 | compact = TRUE, 150 | pagination = FALSE, 151 | sortable = FALSE, 152 | height = 680, 153 | resizable = TRUE 154 | ) 155 | 156 | }) 157 | 158 | bindEvent(input$values_settings, x = observe({ 159 | summary_fns <- list( 160 | continuous = c("sum", "mean", "median", "min", "max", "length", "n_distinct"), 161 | discrete = c("length", "n_distinct", "first", "last") 162 | ) 163 | 164 | showModal(modalDialog( 165 | 166 | title = "Value settings", 167 | size = "xl", 168 | easyClose = length(input$values) == 0L, 169 | 170 | fluidRow(column(12, 171 | if (length(input$values) == 0L) { 172 | span("No summary columns specified") 173 | } else { 174 | map(input$values, function(val) { 175 | val_type <- if (is.numeric(dataset()[[strip_id(val)]])) "continuous" else "discrete" 176 | div( 177 | h4(shiny::code(strip_id(val))), 178 | radioButtons( 179 | inputId = ns(val), 180 | label = "Summary function", 181 | choices = summary_fns[[val_type]], 182 | selected = funs()[[val]], 183 | inline = TRUE 184 | ) 185 | ) 186 | }) 187 | } 188 | )), 189 | 190 | footer = div( 191 | modalButton("Cancel"), 192 | actionButton( 193 | ns("update_functions"), "Apply changes", 194 | style = "padding-left:10px" 195 | ) 196 | ) 197 | )) 198 | })) 199 | 200 | c(reactive(input$rows), reactive(input$columns), values) 201 | 202 | }) 203 | } 204 | 205 | 206 | 207 | 208 | 209 | 210 | -------------------------------------------------------------------------------- /R/mod-selectData.R: -------------------------------------------------------------------------------- 1 | 2 | selectDataUI <- function(id, user_pkg_datasets) { 3 | ns <- NS(id) 4 | navset_card_pill( 5 | title = "Data", 6 | id = ns("data_selection_tabs"), 7 | height = "280px", 8 | nav_panel("Package", value = "panel_package_data", icon = icon("cube"), 9 | selectInput(ns("package"), "Package", names(user_pkg_datasets), selected = "datasets"), 10 | selectInput(ns("dataset"), "Dataset", names(user_pkg_datasets$datasets), selected = "infert") 11 | ), 12 | nav_menu( 13 | title = "Import", 14 | icon = icon("upload"), 15 | nav_panel("From CSV", value = "panel_file_data", icon = icon("upload"), 16 | fileInput(ns("user_data.upload"), NULL, accept = ".csv") 17 | ), 18 | nav_panel("From global environment", value = "panel_env_data", icon = icon("table"), 19 | selectizeInput( 20 | ns("user_data.from_env"), 21 | "Select an object to import", 22 | options = list( 23 | placeholder = 'Select a dataset', 24 | onInitialize = I('function() { this.setValue(""); }') # Set no initial value 25 | ), 26 | # Data frames in the user's workspace 27 | choices = mget(ls(envir = .GlobalEnv), .GlobalEnv) |> 28 | purrr::keep(is.data.frame) |> 29 | names() 30 | ) 31 | ) 32 | ) 33 | ) 34 | } 35 | 36 | #' Select a dataset in the sidebar 37 | #' 38 | #' @param id The `input` slot that will be used to access the value 39 | #' @param pkg_data_env The environment in which to evaluate `code()` 40 | #' @param user_pkg_datasets A list of datasets provided by the user's installed 41 | #' packages 42 | #' @param freeze_pivottable A function which can be used to freeze the 43 | #' pivot table fields if/when the input dataset changes 44 | #' 45 | #' @return A vector of reactives: the dataset itself, the name of the dataset, 46 | #' and the code used to access the dataset 47 | #' 48 | #' @noRd 49 | selectDataServer <- function(id, pkg_data_env, user_pkg_datasets, freeze_pivottable) { 50 | moduleServer(id, function(input, output, session) { 51 | 52 | # Update dataset options depending on selected package 53 | bindEvent(input$package, ignoreInit = TRUE, x = observe({ 54 | freeze_pivottable() 55 | updateSelectInput( 56 | inputId = "dataset", 57 | choices = names(user_pkg_datasets[[input$package]]) 58 | ) 59 | freezeReactiveValue(input, "dataset") 60 | })) 61 | 62 | bindEvent(input$dataset, ignoreInit = TRUE, x = observe({ 63 | freeze_pivottable() 64 | })) 65 | 66 | dataset <- reactiveVal(isolate(user_pkg_datasets[[input$package]][[input$dataset]]$value)) 67 | dataset_code <- reactiveVal(isolate(user_pkg_datasets[[input$package]][[input$dataset]]$code)) 68 | file_dataset <- reactiveVal() 69 | file_dataset_code <- reactiveVal() 70 | env_dataset <- reactiveVal() 71 | env_dataset_code <- reactiveVal() 72 | 73 | bindEvent(input$package, input$dataset, input$data_selection_tabs, ignoreInit = TRUE, x = observe({ 74 | if (input$data_selection_tabs == "panel_package_data") { 75 | freeze_pivottable() 76 | dataset(user_pkg_datasets[[input$package]][[input$dataset]]$value) 77 | dataset_code(user_pkg_datasets[[input$package]][[input$dataset]]$code) 78 | } 79 | 80 | if (input$data_selection_tabs == "panel_file_data" && !is.null(file_dataset())) { 81 | freeze_pivottable() 82 | dataset(file_dataset()) 83 | dataset_code(file_dataset_code()) 84 | } 85 | 86 | if (input$data_selection_tabs == "panel_env_data" && !is.null(env_dataset())) { 87 | freeze_pivottable() 88 | dataset(env_dataset()) 89 | dataset_code(env_dataset_code()) 90 | } 91 | })) 92 | 93 | bindEvent(input$user_data.upload, x = observe({ 94 | freeze_pivottable() 95 | imported_dataset <- readr::read_csv( 96 | input$user_data.upload$datapath, 97 | progress = FALSE, show_col_types = FALSE 98 | ) 99 | assign("dataset", imported_dataset, envir = pkg_data_env) 100 | file_dataset(imported_dataset) 101 | file_dataset_code(glue( 102 | '# dataset <- readr::read_csv("{name}")\n\ndataset', 103 | name = input$user_data.upload$name 104 | )) 105 | dataset(file_dataset()) 106 | dataset_code(file_dataset_code()) 107 | })) 108 | 109 | bindEvent(input$user_data.from_env, ignoreInit = TRUE, x = observe({ 110 | freeze_pivottable() 111 | dataset_name <- input$user_data.from_env 112 | data_from_env <- get(dataset_name, envir = .GlobalEnv) 113 | assign(dataset_name, data_from_env, envir = pkg_data_env) 114 | env_dataset(data_from_env) 115 | env_dataset_code(dataset_name) 116 | dataset(env_dataset()) 117 | dataset_code(env_dataset_code()) 118 | })) 119 | 120 | 121 | c(dataset, reactive(input$dataset), dataset_code, reactive(input$package)) 122 | }) 123 | } 124 | -------------------------------------------------------------------------------- /R/pivotr-package.R: -------------------------------------------------------------------------------- 1 | # The R CMD check linter doesn't pick up that these are assigned by zeallot 2 | utils::globalVariables(c( 3 | "columns", 4 | "dataset", 5 | "dataset_code", 6 | "dataset_name", 7 | "dataset_pkg", 8 | "rows", 9 | "values" 10 | )) 11 | 12 | 13 | #' @import rlang cli shiny dplyr tidyr bslib 14 | #' @importFrom purrr map map_chr map_lgl map_int map_dbl imap 15 | #' @importFrom glue glue 16 | #' @importFrom tibble as_tibble 17 | #' @importFrom utils data 18 | #' @importFrom zeallot "%<-%" 19 | 20 | NULL 21 | -------------------------------------------------------------------------------- /R/pivotr.R: -------------------------------------------------------------------------------- 1 | # TODO: 2 | # * Restrict what you can drag and to where. E.g. can currently remove the 'values' 3 | # item and not get it back 4 | # * More options for summary types 5 | # * Allow abritrary renaming of rows/columns? 6 | # * Allow arbitrary sorting of rows/columns? 7 | # * Filter?? 8 | 9 | #' Run the {pivotr} app 10 | #' 11 | #' This brings up a GUI similar to Excel's PivotTable interface. The 12 | #' dplyr/tidyr code used to achieve the data transformations can be copied 13 | #' for modification/programmatic use. 14 | #' 15 | #' @return An object that represents the app. Printing the object or passing it 16 | #' to [shiny::runApp()] will run the app. 17 | #' @export 18 | pivotr <- function() { 19 | resources <- system.file("app/www", package = "pivotr") 20 | user_pkg_datasets <- package_datasets() 21 | shinyApp( 22 | pivotr_ui(resources, user_pkg_datasets), 23 | pivotr_server(user_pkg_datasets) 24 | ) 25 | } 26 | 27 | 28 | pivotr_server <- function(user_pkg_datasets) { 29 | function(input, output, session) { 30 | # -- Package datasets ------------------------------------------------------ 31 | # Datasets loaded from packages are bound in this environment as the user 32 | # accesses them. This is to avoid polluting the global namespace. 33 | pkg_data_env <- new.env() 34 | 35 | # Initially, start with these datasets loaded 36 | pkg_data <- data(package = c("dplyr", "tidyr"))$results[, 3] 37 | data( 38 | list = pkg_data, 39 | package = c("dplyr", "tidyr", "datasets"), 40 | envir = pkg_data_env 41 | ) 42 | 43 | # User code will use data(), but in the app we'll just load data into 44 | # pkg_data_env. So, overload data() to avoid creating unnecessary objects 45 | assign("data", function(...) NULL, envir = pkg_data_env) 46 | 47 | # -- Modules --------------------------------------------------------------- 48 | # When the dataset changes, need to freeze pivottable controls until they've 49 | # been updated to reflect the new fields. This function provides a way for 50 | # one module to reach into another one and do this. 51 | # TODO: think of a more elegant way of doing this. 52 | freeze_pivottable <- function() { 53 | purrr::walk( 54 | paste0( 55 | "pivot_table-", 56 | c("fields", "filters", "columns", "rows", "values") 57 | ), 58 | ~ freezeReactiveValue(input, .) 59 | ) 60 | } 61 | 62 | c(dataset, dataset_name, dataset_code, dataset_pkg) %<-% selectDataServer("select_data", 63 | pkg_data_env, user_pkg_datasets, freeze_pivottable 64 | ) 65 | 66 | code <- codeDisplayServer("code_display", 67 | dataset, dataset_code, rows, columns, values 68 | ) 69 | 70 | c(rows, columns, values) %<-% pivotTableServer("pivot_table", 71 | dataset, dataset_name, dataset_pkg, code, pkg_data_env 72 | ) 73 | 74 | } 75 | } 76 | 77 | 78 | pivotr_ui <- function(resources, user_pkg_datasets) { 79 | page_sidebar( 80 | theme = bs_theme(5, bootswatch = "cerulean"), 81 | title = "{pivotr} - Excel's PivotTables in R", 82 | 83 | rclipboard::rclipboardSetup(), 84 | 85 | # -- Add resources --------------------------------------------------------- 86 | tags$head( 87 | htmltools::htmlDependency( 88 | name = "resources", 89 | version = "0.0.1", 90 | src = resources, 91 | script = list.files(resources, pattern = "\\.js$", recursive = TRUE), 92 | package = NULL, 93 | all_files = TRUE 94 | ), 95 | map( 96 | list.files(resources, pattern = "\\.css$", recursive = TRUE), 97 | function(x) tags$link(href = file.path("www", x), rel = "stylesheet") 98 | ) 99 | ), 100 | 101 | sidebar = sidebar( 102 | width = 350, 103 | selectDataUI("select_data", user_pkg_datasets), 104 | codeDisplayUI("code_display") 105 | ), 106 | 107 | pivotTableUI("pivot_table") 108 | ) 109 | } 110 | -------------------------------------------------------------------------------- /R/utils-construct_args.R: -------------------------------------------------------------------------------- 1 | construct_args <- function(x, indent = 4L, max_width = 60L, always_linebreak = NULL, backtick = TRUE) { 2 | if (backtick) x <- maybe_backtick(x) 3 | out <- paste(x, collapse = ", ") 4 | always_linebreak <- always_linebreak %||% (nchar(out) > max_width || grepl("\n", out)) 5 | always_linebreak <- always_linebreak && length(x) > 1 6 | if (always_linebreak) { 7 | x <- gsub("\n", paste0("\n", strrep(" ", indent)), x) 8 | out <- paste(x, collapse = paste0(",\n", strrep(" ", indent))) 9 | out <- paste0("\n", strrep(" ", indent), out, "\n", strrep(" ", indent - 2L)) 10 | } 11 | out 12 | } 13 | 14 | construct_vec <- function(x, indent = 4L, max_width = 60L, backtick = TRUE) { 15 | if (length(x) == 1L) { 16 | return(if (backtick) maybe_backtick(x) else x) 17 | } 18 | paste0("c(", construct_args(x, indent, max_width, backtick = backtick), ")") 19 | } 20 | 21 | maybe_backtick <- function(x) { 22 | 23 | ifelse( 24 | grepl("^[_.a-zA-Z][_.a-zA-Z0-9]*$", x) | grepl("^`.+`$", x), 25 | x, paste0("`", x, "`") 26 | ) 27 | 28 | } 29 | -------------------------------------------------------------------------------- /R/utils-with_corner_buttons.R: -------------------------------------------------------------------------------- 1 | with_corner_buttons <- function(...) { 2 | 3 | dots <- list(...) 4 | is_button <- vapply(dots, is_corner_button, logical(1)) 5 | buttons <- dots[is_button] 6 | 7 | buttons <- div( 8 | class = "parent", 9 | 10 | tags$style(HTML(" 11 | .inline-block-child { 12 | display: inline-block; 13 | } 14 | ")), 15 | 16 | !!!map(seq_along(buttons), function(i) { 17 | right <- paste0("right: ", i * 35, "px; ") 18 | div( 19 | class = "corner-button child inline-block-child", 20 | style = paste0(right, "margin: 0px;"), 21 | buttons[[i]] 22 | ) 23 | }) 24 | ) 25 | 26 | div( 27 | class = "corner-buttons-wrapper", 28 | !!!dots[!is_button], 29 | buttons 30 | ) 31 | 32 | } 33 | 34 | corner_button <- function(inputId, icon, tooltip = NULL, ...) { 35 | if (is.character(icon)) { 36 | icon <- shiny::icon(icon) 37 | } 38 | 39 | as_corner_button(tags$button( 40 | class = "btn action-button corner-button", 41 | title = tooltip, 42 | type = "button", 43 | id = inputId, 44 | icon, 45 | ... 46 | )) 47 | } 48 | 49 | corner_button_clipboard <- function(inputId, text, modal = FALSE, 50 | icon = "clipboard", 51 | tooltip = "Copy to clipboard", ...) { 52 | # as_corner_button(rclipboard::rclipButton( 53 | # inputId = inputId, 54 | # label = NULL, 55 | # clipText = text, 56 | # icon = shiny::icon(icon), 57 | # title = tooltip, 58 | # class = "action-button corner-button", 59 | # style = "color:black;", 60 | # modal = modal, 61 | # ... 62 | # )) 63 | as_corner_button(tagList( 64 | corner_button( 65 | title = tooltip, 66 | inputId = inputId, 67 | `data-clipboard-text` = text, 68 | icon = icon, 69 | ... 70 | ), 71 | tags$script(glue(ifelse( 72 | modal, 73 | 'new ClipboardJS(".btn", {{ container: document.getElementById(\"{inputId}\") }});', 74 | 'new ClipboardJS(".btn", document.getElementById("{inputId}"));' 75 | ))) 76 | )) 77 | 78 | } 79 | 80 | as_corner_button <- function(x) { 81 | class(x) <- c("corner_button", class(x)) 82 | x 83 | } 84 | 85 | is_corner_button <- function(x) { 86 | inherits(x, "corner_button") 87 | } 88 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | random_id <- function(length = 16L) { 2 | chars <- sample(c(letters, LETTERS, 0:9), size = length, replace = TRUE) 3 | paste(chars, collapse = "") 4 | } 5 | 6 | strip_id <- function(x) sub(".+__", "", x) 7 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | .onLoad <- function(libname, pkgname) { 2 | addResourcePath("www", system.file("app/www", package = "pivotr")) 3 | } 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # {pivotr} - Excel's PivotTables in R 2 | 3 | A shiny implementation of Excel's PivotTables. Perform your 4 | aggregation/pivoting in the GUI, then copy the dplyr/tidyr code into 5 | your R script 💫 6 | 7 | ## Installation 8 | 9 | {pivotr} can be installed from GitHub using [{pak}](https://pak.r-lib.org): 10 | 11 | ``` r 12 | pak::pak("wurli/pivotr") 13 | ``` 14 | 15 | Once installed, launch the GUI using `pivotr::pivotr()`. 16 | 17 | ## Demo 18 | 19 | ![](demo.gif) 20 | -------------------------------------------------------------------------------- /demo.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/wurli/pivotr/3c5142a9b580fd5b35627c828ce30777a4980d0a/demo.gif -------------------------------------------------------------------------------- /inst/app/www/custom.css: -------------------------------------------------------------------------------- 1 | .bslib-card, .tab-content, .tab-pane, .card-body { 2 | overflow: visible !important; 3 | } 4 | 5 | .bucket-list-container.fields-list { 6 | font-size: 0.95em; 7 | padding: 0px !important; 8 | margin: 0px !important; 9 | } 10 | 11 | .rank-list-container.fields-list { 12 | height: 350px; 13 | overflow-y: auto; 14 | } 15 | 16 | .bucket-list-container.pivot-table-options-list { 17 | font-size:0.95em; 18 | padding: 0px !important; 19 | margin: 0px !important; 20 | } 21 | 22 | .rank-list-container.pivot-table-options-list { 23 | min-height:150px; 24 | } 25 | 26 | .default-sortable .rank-list-item { 27 | padding: 2px 5px !important; 28 | } 29 | 30 | .corner-buttons-wrapper { 31 | position: relative; 32 | } 33 | 34 | .corner-button { 35 | position: absolute; 36 | top: 0px; 37 | right: -20px; 38 | font-size: 1.1em; 39 | margin-top: 10px; 40 | padding: 0; 41 | background-color: transparent; 42 | opacity: .7; 43 | border: none; 44 | cursor: pointer; 45 | caret-color: transparent; 46 | vertical-align: top; 47 | color: black; 48 | } 49 | 50 | .corner-button:hover { 51 | opacity: 1; 52 | } 53 | -------------------------------------------------------------------------------- /inst/app/www/prism.css: -------------------------------------------------------------------------------- 1 | /* PrismJS 1.29.0 2 | https://prismjs.com/download.html#themes=prism&languages=r */ 3 | code[class*=language-],pre[class*=language-]{color:#000;background:0 0;text-shadow:0 1px #fff;font-family:Consolas,Monaco,'Andale Mono','Ubuntu Mono',monospace;font-size:1em;text-align:left;white-space:pre;word-spacing:normal;word-break:normal;word-wrap:normal;line-height:1.5;-moz-tab-size:4;-o-tab-size:4;tab-size:4;-webkit-hyphens:none;-moz-hyphens:none;-ms-hyphens:none;hyphens:none}code[class*=language-] ::-moz-selection,code[class*=language-]::-moz-selection,pre[class*=language-] ::-moz-selection,pre[class*=language-]::-moz-selection{text-shadow:none;background:#b3d4fc}code[class*=language-] ::selection,code[class*=language-]::selection,pre[class*=language-] ::selection,pre[class*=language-]::selection{text-shadow:none;background:#b3d4fc}@media print{code[class*=language-],pre[class*=language-]{text-shadow:none}}pre[class*=language-]{padding:1em;margin:.5em 0;overflow:auto}:not(pre)>code[class*=language-],pre[class*=language-]{background:#f5f2f0}:not(pre)>code[class*=language-]{padding:.1em;border-radius:.3em;white-space:normal}.token.cdata,.token.comment,.token.doctype,.token.prolog{color:#708090}.token.punctuation{color:#999}.token.namespace{opacity:.7}.token.boolean,.token.constant,.token.deleted,.token.number,.token.property,.token.symbol,.token.tag{color:#905}.token.attr-name,.token.builtin,.token.char,.token.inserted,.token.selector,.token.string{color:#690}.language-css .token.string,.style .token.string,.token.entity,.token.operator,.token.url{color:#9a6e3a;background:hsla(0,0%,100%,.5)}.token.atrule,.token.attr-value,.token.keyword{color:#07a}.token.class-name,.token.function{color:#dd4a68}.token.important,.token.regex,.token.variable{color:#e90}.token.bold,.token.important{font-weight:700}.token.italic{font-style:italic}.token.entity{cursor:help} 4 | -------------------------------------------------------------------------------- /inst/app/www/prism.js: -------------------------------------------------------------------------------- 1 | /* PrismJS 1.29.0 2 | https://prismjs.com/download.html#themes=prism&languages=r */ 3 | var _self="undefined"!=typeof window?window:"undefined"!=typeof WorkerGlobalScope&&self instanceof WorkerGlobalScope?self:{},Prism=function(e){var n=/(?:^|\s)lang(?:uage)?-([\w-]+)(?=\s|$)/i,t=0,r={},a={manual:e.Prism&&e.Prism.manual,disableWorkerMessageHandler:e.Prism&&e.Prism.disableWorkerMessageHandler,util:{encode:function e(n){return n instanceof i?new i(n.type,e(n.content),n.alias):Array.isArray(n)?n.map(e):n.replace(/&/g,"&").replace(/=g.reach);A+=w.value.length,w=w.next){var E=w.value;if(n.length>e.length)return;if(!(E instanceof i)){var P,L=1;if(y){if(!(P=l(b,A,e,m))||P.index>=e.length)break;var S=P.index,O=P.index+P[0].length,j=A;for(j+=w.value.length;S>=j;)j+=(w=w.next).value.length;if(A=j-=w.value.length,w.value instanceof i)continue;for(var C=w;C!==n.tail&&(jg.reach&&(g.reach=W);var z=w.prev;if(_&&(z=u(n,z,_),A+=_.length),c(n,z,L),w=u(n,z,new i(f,p?a.tokenize(N,p):N,k,N)),M&&u(n,w,M),L>1){var I={cause:f+","+d,reach:W};o(e,n,t,w.prev,A,I),g&&I.reach>g.reach&&(g.reach=I.reach)}}}}}}function s(){var e={value:null,prev:null,next:null},n={value:null,prev:e,next:null};e.next=n,this.head=e,this.tail=n,this.length=0}function u(e,n,t){var r=n.next,a={value:t,prev:n,next:r};return n.next=a,r.prev=a,e.length++,a}function c(e,n,t){for(var r=n.next,a=0;a"+i.content+""},!e.document)return e.addEventListener?(a.disableWorkerMessageHandler||e.addEventListener("message",(function(n){var t=JSON.parse(n.data),r=t.language,i=t.code,l=t.immediateClose;e.postMessage(a.highlight(i,a.languages[r],r)),l&&e.close()}),!1),a):a;var g=a.util.currentScript();function f(){a.manual||a.highlightAll()}if(g&&(a.filename=g.src,g.hasAttribute("data-manual")&&(a.manual=!0)),!a.manual){var h=document.readyState;"loading"===h||"interactive"===h&&g&&g.defer?document.addEventListener("DOMContentLoaded",f):window.requestAnimationFrame?window.requestAnimationFrame(f):window.setTimeout(f,16)}return a}(_self);"undefined"!=typeof module&&module.exports&&(module.exports=Prism),"undefined"!=typeof global&&(global.Prism=Prism); 4 | Prism.languages.r={comment:/#.*/,string:{pattern:/(['"])(?:\\.|(?!\1)[^\\\r\n])*\1/,greedy:!0},"percent-operator":{pattern:/%[^%\s]*%/,alias:"operator"},boolean:/\b(?:FALSE|TRUE)\b/,ellipsis:/\.\.(?:\.|\d+)/,number:[/\b(?:Inf|NaN)\b/,/(?:\b0x[\dA-Fa-f]+(?:\.\d*)?|\b\d+(?:\.\d*)?|\B\.\d+)(?:[EePp][+-]?\d+)?[iL]?/],keyword:/\b(?:NA|NA_character_|NA_complex_|NA_integer_|NA_real_|NULL|break|else|for|function|if|in|next|repeat|while)\b/,operator:/->?>?|<(?:=|=!]=?|::?|&&?|\|\|?|[+*\/^$@~]/,punctuation:/[(){}\[\],;]/}; 5 | -------------------------------------------------------------------------------- /man/pivotr.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pivotr.R 3 | \name{pivotr} 4 | \alias{pivotr} 5 | \title{Run the {pivotr} app} 6 | \usage{ 7 | pivotr() 8 | } 9 | \value{ 10 | An object that represents the app. Printing the object or passing it 11 | to [shiny::runApp()] will run the app. 12 | } 13 | \description{ 14 | This brings up a GUI similar to Excel's PivotTable interface. The 15 | dplyr/tidyr code used to achieve the data transformations can be copied 16 | for modification/programmatic use. 17 | } 18 | -------------------------------------------------------------------------------- /pivotr.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | 17 | BuildType: Package 18 | PackageUseDevtools: Yes 19 | PackageInstallArgs: --no-multiarch --with-keep.source 20 | 21 | UseNativePipeOperator: Yes 22 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | # This file is part of the standard setup for testthat. 2 | # It is recommended that you do not modify it. 3 | # 4 | # Where should you do additional test configuration? 5 | # Learn more about the roles of various files in: 6 | # * https://r-pkgs.org/tests.html 7 | # * https://testthat.r-lib.org/reference/test_package.html#special-files 8 | 9 | library(testthat) 10 | library(pivotr) 11 | 12 | test_check("pivotr") 13 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/construct_pivot_code.md: -------------------------------------------------------------------------------- 1 | # construct_pivot_code() works 2 | 3 | Code 4 | test <- (function(width) { 5 | construct_pivot_code(x = dplyr::storms, x_name = "dplyr::storms", columns = "status", 6 | rows = ".measure", values = list(list("pressure", "sum"), list("wind", "sum"), 7 | list("tropicalstorm_force_diameter", "sum")), code_width = width) 8 | }) 9 | cat(test(5)) 10 | Output 11 | dplyr::storms |> 12 | summarise( 13 | .by = status, 14 | across( 15 | c( 16 | pressure, 17 | wind, 18 | tropicalstorm_force_diameter 19 | ), 20 | sum 21 | ) 22 | ) |> 23 | pivot_longer( 24 | c( 25 | pressure, 26 | wind, 27 | tropicalstorm_force_diameter 28 | ), 29 | names_to = ".measure", 30 | values_to = ".value" 31 | ) |> 32 | pivot_wider( 33 | names_from = status, 34 | values_from = .value 35 | ) 36 | Code 37 | cat(test(40)) 38 | Output 39 | dplyr::storms |> 40 | summarise( 41 | .by = status, 42 | across( 43 | c( 44 | pressure, 45 | wind, 46 | tropicalstorm_force_diameter 47 | ), 48 | sum 49 | ) 50 | ) |> 51 | pivot_longer( 52 | c( 53 | pressure, 54 | wind, 55 | tropicalstorm_force_diameter 56 | ), 57 | names_to = ".measure", 58 | values_to = ".value" 59 | ) |> 60 | pivot_wider( 61 | names_from = status, 62 | values_from = .value 63 | ) 64 | Code 65 | cat(test(120)) 66 | Output 67 | dplyr::storms |> 68 | summarise( 69 | .by = status, 70 | across(c(pressure, wind, tropicalstorm_force_diameter), sum) 71 | ) |> 72 | pivot_longer( 73 | c(pressure, wind, tropicalstorm_force_diameter), 74 | names_to = ".measure", 75 | values_to = ".value" 76 | ) |> 77 | pivot_wider( 78 | names_from = status, 79 | values_from = .value 80 | ) 81 | 82 | -------------------------------------------------------------------------------- /tests/testthat/test-construct_pivot_code.R: -------------------------------------------------------------------------------- 1 | test_that("construct_pivot_code() works", { 2 | 3 | expect_snapshot({ 4 | test <- function(width) { 5 | construct_pivot_code( 6 | x = dplyr::storms, 7 | x_name = "dplyr::storms", 8 | columns = "status", 9 | rows = ".measure", 10 | values = list( 11 | list("pressure", "sum"), 12 | list("wind", "sum"), 13 | list("tropicalstorm_force_diameter", "sum") 14 | ), 15 | code_width = width 16 | ) 17 | } 18 | 19 | cat(test(5)) 20 | cat(test(40)) 21 | cat(test(120)) 22 | 23 | }) 24 | }) 25 | --------------------------------------------------------------------------------