[feat] Formatting for numeric columns (vctrs)

NAMESPACE

@@ -6,6 +6,7 @@ S3method(as_CellData,POSIXct)
 S3method(as_CellData,character)
 S3method(as_CellData,default)
 S3method(as_CellData,factor)
+S3method(as_CellData,googlesheets4_format_number)
 S3method(as_CellData,googlesheets4_formula)
 S3method(as_CellData,googlesheets4_schema_CellData)
 S3method(as_CellData,list)
@@ -51,16 +52,27 @@ S3method(patch,googlesheets4_schema)
 S3method(print,googlesheets4_spreadsheet)
 S3method(print,range_spec)
 S3method(print,sheets_id)
+S3method(vec_cast,googlesheets4_format_number)
 S3method(vec_cast,googlesheets4_formula)
 S3method(vec_cast.character,googlesheets4_formula)
+S3method(vec_cast.double,googlesheets4_format_number)
+S3method(vec_cast.googlesheets4_format_number,default)
+S3method(vec_cast.googlesheets4_format_number,double)
+S3method(vec_cast.googlesheets4_format_number,googlesheets4_format_number)
 S3method(vec_cast.googlesheets4_formula,character)
 S3method(vec_cast.googlesheets4_formula,default)
 S3method(vec_cast.googlesheets4_formula,googlesheets4_formula)
+S3method(vec_ptype2,googlesheets4_format_number)
 S3method(vec_ptype2,googlesheets4_formula)
 S3method(vec_ptype2.character,googlesheets4_formula)
+S3method(vec_ptype2.double,googlesheets4_format_number)
+S3method(vec_ptype2.googlesheets4_format_number,default)
+S3method(vec_ptype2.googlesheets4_format_number,double)
+S3method(vec_ptype2.googlesheets4_format_number,googlesheets4_format_number)
 S3method(vec_ptype2.googlesheets4_formula,character)
 S3method(vec_ptype2.googlesheets4_formula,default)
 S3method(vec_ptype2.googlesheets4_formula,googlesheets4_formula)
+S3method(vec_ptype_abbr,googlesheets4_format_number)
 S3method(vec_ptype_abbr,googlesheets4_formula)
 export("%>%")
 export(anchored)
@@ -79,6 +91,7 @@ export(gs4_example)
 export(gs4_examples)
 export(gs4_find)
 export(gs4_fodder)
+export(gs4_format_number)
 export(gs4_formula)
 export(gs4_get)
 export(gs4_has_token)
@@ -125,7 +138,9 @@ export(sheets_sheets)
 export(sheets_token)
 export(sheets_user)
 export(spread_sheet)
+export(vec_cast.googlesheets4_format_number)
 export(vec_cast.googlesheets4_formula)
+export(vec_ptype2.googlesheets4_format_number)
 export(vec_ptype2.googlesheets4_formula)
 export(write_sheet)
 import(rlang)

R/gs4_format.R

@@ -0,0 +1,116 @@
+new_gs4_format_number <- function(x = double(), pattern = "0.00") {
+  vec_assert(x, double())
+  vec_assert(pattern, ptype = character(), size = 1)
+  new_vctr(x, pattern = pattern, class = "googlesheets4_format_number")
+}
+
+#' Class for Google Sheets number formats
+#'
+#' Often, we want to see our Google Sheets data in a "pretty" format, for
+#' example 0.45 as 45%, without changing the underlying data. In order to format
+#' numbers into Google Sheets, you need to store it as an object of class
+#' `googlesheets4_format_number`. This is how we know how to format a given
+#' numeric vector. `googlesheets4_format_number` is an S3 class implemented
+#' using the [vctrs package](https://vctrs.r-lib.org/articles/s3-vector.html).
+#'
+#' @param x Double.
+#' @param pattern Character. Defaults to "0.00", ie round with two significant
+#'   digits. For options see the [Google
+#'   Documentation](https://developers.google.com/sheets/api/guides/formats).
+#'
+#' @return An S3 vector of class `googlesheets4_format_number`.
+#' @export
+#' @family write functions
+#'
+#' @examples
+#' if (gs4_has_token()) {
+#'   dat <- data.frame(small_number = runif(10), big_number = runif(10) * 1e6)
+#'   # explicitly declare columns as `googlesheets4_format_number`
+#'   dat$small_number <- gs4_format_number(dat$small_number, "0.0%")
+#'   # from https://webapps.stackexchange.com/questions/77974
+#'   dat$big_number <- gs4_format_number(dat$big_number, "[>999999]0.0,,\\M;[>999]0.0,\\K;0")
+#'
+#'   # make the sheet
+#'   ss <- gs4_create("gs4-number-formats-demo", sheets = dat)
+#'   ss
+#'
+#'   # clean up
+#'   gs4_find("gs4-formula-demo") %>%
+#'     googledrive::drive_trash()
+#' }
+gs4_format_number <- function(x = double(), pattern = "0.00") {
+  x <- vec_cast(x, double())
+  pattern <- vec_recycle(vec_cast(pattern, character()), 1)
+
+  new_gs4_format_number(x, pattern = pattern)
+}
+
+#' @importFrom methods setOldClass
+setOldClass(c("googlesheets4_format_number", "vctrs_vctr"))
+
+#' @export
+vec_ptype_abbr.googlesheets4_format_number <- function(x, ...) {
+  "fmt_num"
+}
+
+#' @method vec_ptype2 googlesheets4_format_number
+#' @export vec_ptype2.googlesheets4_format_number
+#' @export
+#' @rdname googlesheets4-vctrs
+vec_ptype2.googlesheets4_format_number <- function(x, y, ...) {
+  UseMethod("vec_ptype2.googlesheets4_format_number", y)
+}
+
+#' @method vec_ptype2.googlesheets4_format_number default
+#' @export
+vec_ptype2.googlesheets4_format_number.default <- function(x, y,
+                                                     ...,
+                                                     x_arg = "x", y_arg = "y") {
+  vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg)
+}
+
+#' @method vec_ptype2.googlesheets4_format_number googlesheets4_format_number
+#' @export
+vec_ptype2.googlesheets4_format_number.googlesheets4_format_number <- function(x, y, ...) new_gs4_format_number()
+
+#' @method vec_ptype2.googlesheets4_format_number double
+#' @export
+vec_ptype2.googlesheets4_format_number.double <- function(x, y, ...) double()
+
+#' @method vec_ptype2.double googlesheets4_format_number
+#' @export
+vec_ptype2.double.googlesheets4_format_number <- function(x, y, ...) double()
+
+# casting
+
+#' @method vec_cast googlesheets4_format_number
+#' @export vec_cast.googlesheets4_format_number
+#' @export
+#' @rdname googlesheets4-vctrs
+vec_cast.googlesheets4_format_number<- function(x, to, ...) {
+  UseMethod("vec_cast.googlesheets4_format_number")
+}
+
+#' @method vec_cast.googlesheets4_format_number default
+#' @export
+vec_cast.googlesheets4_format_number.default <- function(x, to, ...) {
+  vec_default_cast(x, to)
+}
+
+#' @method vec_cast.googlesheets4_format_number googlesheets4_format_number
+#' @export
+vec_cast.googlesheets4_format_number.googlesheets4_format_number <- function(x, to, ...) {
+  x
+}
+
+#' @method vec_cast.googlesheets4_format_number double
+#' @export
+vec_cast.googlesheets4_format_number.double <- function(x, to, ...) {
+  gs4_format_number(x)
+}
+
+#' @method vec_cast.double googlesheets4_format_number
+#' @export
+vec_cast.double.googlesheets4_format_number <- function(x, to, ...) {
+  vec_data(x)
+}

R/schema_CellData.R

@@ -130,6 +130,13 @@ as_CellData.POSIXct <- function(x, .na = NULL) {
   )
 }
 
+#' @export
+as_CellData.googlesheets4_format_number <- function(x, .na = NULL) {
+  pattern <- attr(x, "pattern")
+  x <- cell_data(unclass(x), val_type = "numberValue", .na = .na)
+  map(x, add_format, fmt = list(type = "NUMBER", pattern = pattern))
+}
+
 # Currently (overly) focused on userEnteredValue, because I am thinking about
 # writing. But with a reading focus, one would want to see effectiveValue.
 format.googlesheets4_schema_CellData <- function(x, ...) {

tests/testthat/test-gs4_format.R

@@ -0,0 +1,55 @@
+test_that("gs4_format_number constructors return length-0 vector when called with no arguments", {
+  expect_length(new_gs4_format_number(), 0)
+  expect_length(gs4_format_number(), 0)
+})
+
+test_that("gs4_format_number low-level constructor errors for non-double input", {
+  expect_error(new_gs4_format_number(letters[1:3]), class = "vctrs_error_assert_ptype")
+})
+
+test_that("common type of googlesheets4_format_number and double is double", {
+  expect_identical(
+    vctrs::vec_ptype2(double(), gs4_format_number()),
+    double()
+  )
+  expect_identical(
+    vctrs::vec_ptype2(gs4_format_number(), double()),
+    double()
+  )
+})
+
+test_that("googlesheets4_format_number and double are coercible", {
+  expect_identical(
+    vctrs::vec_cast(1, gs4_format_number()),
+    gs4_format_number(1)
+  )
+  expect_identical(
+    vctrs::vec_cast(gs4_format_number(1), double()),
+    1
+  )
+  expect_identical(
+    vctrs::vec_cast(gs4_format_number(1), gs4_format_number()),
+    gs4_format_number(1)
+  )
+})
+
+test_that("can concatenate googlesheets4_format_number", {
+  expect_identical(
+    vctrs::vec_c(
+      gs4_format_number(1),
+      gs4_format_number(2)
+    ),
+    gs4_format_number(c(1, 2))
+  )
+})
+
+test_that("googlesheets4_format_number can have missing elements", {
+  out <- vctrs::vec_c(
+    gs4_format_number(1),
+    NA,
+    gs4_format_number(2),
+    NA
+  )
+  expect_s3_class(out, "googlesheets4_format_number")
+  expect_true(all(is.na(out[c(2, 4)])))
+})