Add sheets_create()

NAMESPACE

@@ -1,18 +1,22 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(as_Sheet,data.frame)
 S3method(as_sheets_id,"NULL")
 S3method(as_sheets_id,character)
 S3method(as_sheets_id,default)
 S3method(as_sheets_id,dribble)
 S3method(as_sheets_id,drive_id)
+S3method(as_sheets_id,sheets_Spreadsheet)
 S3method(as_sheets_id,sheets_id)
 S3method(ctype,"NULL")
 S3method(ctype,SHEETS_CELL)
 S3method(ctype,character)
 S3method(ctype,default)
 S3method(ctype,list)
-S3method(format,sheets_meta)
-S3method(print,sheets_meta)
+S3method(format,sheets_Spreadsheet)
+S3method(print,sheets_Spreadsheet)
+S3method(tibblify,googlesheets4_Sheet)
+S3method(tibblify,googlesheets4_SheetProperties)
 export("%>%")
 export(anchored)
 export(as_sheets_id)
@@ -27,6 +31,7 @@ export(sheets_auth)
 export(sheets_auth_configure)
 export(sheets_browse)
 export(sheets_cells)
+export(sheets_create)
 export(sheets_deauth)
 export(sheets_endpoints)
 export(sheets_example)
@@ -52,6 +57,7 @@ importFrom(purrr,"%||%")
 importFrom(purrr,compact)
 importFrom(purrr,discard)
 importFrom(purrr,flatten)
+importFrom(purrr,imap)
 importFrom(purrr,keep)
 importFrom(purrr,map)
 importFrom(purrr,map2)
@@ -63,4 +69,5 @@ importFrom(purrr,modify_if)
 importFrom(purrr,pluck)
 importFrom(purrr,pmap_chr)
 importFrom(purrr,set_names)
+importFrom(purrr,transpose)
 importFrom(purrr,walk)

NEWS.md

@@ -1,5 +1,7 @@
 # googlesheets4 (development version)
 
+* `sheets_create()` is a new function to create a new Sheet and, optionally, write one or more data frames into it (#61). *caution: function still under development*
+
 # googlesheets4 0.1.0
 
 * Added a `NEWS.md` file to track changes to the package.

R/googlesheets4-package.R

@@ -1,4 +1,4 @@
 #' @keywords internal
 #' @importFrom purrr %||% map_lgl map_int map_dbl map_chr map map2 pluck walk
-#'   pmap_chr set_names discard keep flatten modify_if compact
+#'   pmap_chr set_names discard keep flatten modify_if compact transpose imap
 "_PACKAGE"

R/rectangle.R

@@ -0,0 +1,12 @@
+# low-tech typed version of tidyr::hoist() that is "list in, vector out"
+hoist_lgl <- function(.x, ..., .default = NA) {
+  map_lgl(.x, ..., .default = .default)
+}
+
+hoist_chr <- function(.x, ..., .default = NA) {
+  map_chr(.x, ..., .default = .default)
+}
+
+hoist_int <- function(.x, ..., .default = NA) {
+  map_int(.x, ..., .default = .default)
+}

R/schema_Sheet.R

@@ -0,0 +1,65 @@
+#' @export
+tibblify.googlesheets4_Sheet <- function(x, ...) {
+  out <- tibblify(new("SheetProperties", !!!x$properties))
+  # TODO: come back to deal with `data`
+  tibble::add_column(out, data = list(NULL))
+}
+
+as_Sheet <- function(df, name) {
+  UseMethod("as_Sheet")
+}
+
+as_Sheet.default <- function(df, name) {
+  stop_glue(
+    "Don't know how to make an instance of {bt('Sheet')} from something of ",
+    "class {class_collapse(x)}."
+  )
+}
+
+#' @export
+as_Sheet.data.frame <- function(df, name) {
+  check_string(name)
+  x <- new(
+    id = "Sheet",
+    properties = new(
+      id = "SheetProperties",
+      title = name,
+      gridProperties = list(rowCount = nrow(df) + 1, columnCount = ncol(df))
+    ),
+    data = list( # an array of instances of GridData
+      list(
+        rowData = as_RowData(df) # an array of instances of RowData
+      )
+    )
+  )
+}
+
+as_RowData <- function(df) {
+  df_rows <- c(list(names(df)), transpose(df))
+  make_row <- function(x) {
+    map(x, ~ list(userEnteredValue = list(stringValue = as.character(.x))))
+  }
+  map(df_rows, ~ list(values = make_row(unname(.x))))
+  # list(
+  #   list(     # row 1
+  #     values = list(
+  #       list( # row 1 cell 1
+  #         userEnteredValue = list(stringValue = "A1")
+  #       ),
+  #       list( # row 1 cell 2
+  #         userEnteredValue = list(stringValue = "B1")
+  #       )
+  #     )
+  #   ),
+  #   list(   # row 2
+  #     values = list(
+  #       list( # row 2 cell 1
+  #         userEnteredValue = list(stringValue = "A2")
+  #       ),
+  #       list( # row 2 cell 2
+  #         userEnteredValue = list(stringValue = "B2")
+  #       )
+  #     )
+  #   )
+  # )
+}

R/schema_SheetProperties.R

@@ -0,0 +1,16 @@
+#' @export
+tibblify.googlesheets4_SheetProperties <- function(x, ...) {
+  # weird-looking workaround for the (current) lack of typed pluck()
+  # revisit this when I depend on vctrs directly
+  x <- list(x)
+  tibble::tibble(
+    # TODO: open question whether I should explicitly unescape title here
+    name         =  hoist_chr(x, "title"),
+    index        =  hoist_int(x, "index"),
+    id           =  hoist_int(x, "sheetId"),
+    type         =  hoist_chr(x, "sheetType"),
+    visible      = !hoist_lgl(x, "hidden", .default = FALSE),
+    grid_rows    =  hoist_int(x, c("gridProperties", "rowCount")),
+    grid_columns =  hoist_int(x, c("gridProperties", "columnCount"))
+  )
+}

R/schema_Spreadsheet.R

@@ -0,0 +1,105 @@
+#  input: instance of Spreadsheet, in the Sheets API sense, as a named list
+# output: instance of sheets_Spreadsheet, which is how I want to hold this info
+sheets_Spreadsheet <- function(x = list()) {
+  ours_theirs <- list(
+    spreadsheet_id  = "spreadsheetId",
+    spreadsheet_url = "spreadsheetUrl",
+    name            = list("properties", "title"),
+    locale          = list("properties", "locale"),
+    time_zone       = list("properties", "timeZone")
+  )
+  out <- map(ours_theirs, ~ pluck(x, !!!.x))
+
+  if (!is.null(x$sheets)) {
+    sheets <- map(x$sheets, ~ new("Sheet", !!!.x))
+    sheets <- map(sheets, tibblify)
+    out$sheets <- do.call(rbind, sheets)
+  }
+
+  if (!is.null(x$namedRanges)) {
+    # TODO: refactor in terms of a to-be-created sheets_NamedRange()? changes
+    # the angle of attack to NamedRange-wise, whereas here I work column-wise
+    nr <- x$namedRanges
+    out$named_ranges <- tibble::tibble(
+      name         = map_chr(nr, "name"),
+      range        = NA_character_,
+      id           = map_chr(nr, "namedRangeId"),
+      # if there is only 1 sheet, sheetId might not be sent!
+      # https://github.com/tidyverse/googlesheets4/issues/29
+      sheet_id     = map_chr(nr, c("range", "sheetId"), .default = NA),
+      sheet_name   = NA_character_,
+      # TODO: extract into functions re: GridRange?
+      ## API sends zero-based row and column
+      ##   => we add one
+      ## API indices are half-open, i.e. [start, end)
+      ##   => we substract one from end_[row|column]
+      ## net effect
+      ##   => we add one to start_[row|column] but not to end_[row|column]
+      start_row    = map_int(nr, c("range", "startRowIndex"), .default = NA) + 1L,
+      end_row      = map_int(nr, c("range", "endRowIndex"), .default = NA),
+      start_column = map_int(nr, c("range", "startColumnIndex"), .default = NA) + 1L,
+      end_column   = map_int(nr, c("range", "endColumnIndex"), .default = NA)
+    )
+    no_sheet <- is.na(out$named_ranges$sheet_id)
+    if (any(no_sheet)) {
+      # if no associated sheetId, assume it's the first (only?) sheet
+      # https://github.com/tidyverse/googlesheets4/issues/29
+      out$named_ranges$sheet_id[no_sheet] <- out$sheets$id[[1]]
+    }
+    out$named_ranges$sheet_name <- vlookup(
+      out$named_ranges$sheet_id,
+      data = out$sheets,
+      key = "id",
+      value = "name"
+    )
+    out$named_ranges$range <- pmap_chr(out$named_ranges, make_range)
+  }
+
+  structure(out, class = c("sheets_Spreadsheet", "list"))
+}
+
+#' @export
+format.sheets_Spreadsheet <- function(x, ...) {
+
+  meta <- glue_data(
+    x,
+    "
+      Spreadsheet name: {name}
+                    ID: {spreadsheet_id}
+                Locale: {locale}
+             Time zone: {time_zone}
+           # of sheets: {nrow(x$sheets)}
+    ",
+    .sep = "\n"
+  )
+  meta <- strsplit(meta, split = "\n")[[1]]
+
+  col1 <- fr(c("(Sheet name)", x$sheets$name))
+  col2 <- c(
+    "(Nominal extent in rows x columns)",
+    glue_data(x$sheets, "{grid_rows} x {grid_columns}")
+  )
+  meta <- c(
+    meta,
+    "",
+    glue_data(list(col1 = col1, col2 = col2), "{col1}: {col2}")
+  )
+
+  if (!is.null(x$named_ranges)) {
+    col1 <- fr(c("(Named range)", x$named_ranges$name))
+    col2 <- fl(c("(A1 range)", x$named_ranges$range))
+    meta <- c(
+      meta,
+      "",
+      glue_data(list(col1 = col1, col2 = col2), "{col1}: {col2}")
+    )
+  }
+
+  meta
+}
+
+#' @export
+print.sheets_Spreadsheet <- function(x, ...) {
+  cat(format(x), sep = "\n")
+  invisible(x)
+}

R/schemas.R

@@ -0,0 +1,66 @@
+new <- function(id, ...) {
+  schema <- .tidy_schemas[[id]]
+  if (is.null(schema)) {
+    rlang::abort(glue("Can't find a tidy schema with id {sq(id)}"))
+  }
+  dots <- rlang::list2(...)
+
+  check_against_schema(dots, schema = schema)
+
+  structure(
+    dots,
+    # explicit 'list' class is a bit icky but makes jsonlite happy
+    # in various vctrs futures, this could need revisiting
+    class = c(id_as_class(id), "googlesheets4_schema", "list"),
+    schema = schema
+  )
+}
+
+# TODO: if it proves necessary, this could do more meaningful checks
+check_against_schema <- function(x, schema = NULL) {
+  schema <- schema %||% attr(x, "schema")
+  unexpected <- setdiff(names(x), schema$property)
+  if (length(unexpected) > 0) {
+    msg <- glue("
+    Properties not recognized for the {sq(attr(schema, 'id'))} schema:
+      * {glue_collapse(unexpected, sep = ', ')}
+    ")
+    rlang::abort(msg)
+  }
+  invisible(x)
+}
+
+id_as_class <- function(id) glue("googlesheets4_{id}")
+
+id_from_class <- function(x) {
+  m <- grep("^googlesheets4_", class(x), value = TRUE)[[1]]
+  sub("^googlesheets4_", "", m)
+}
+
+# patch ----
+patch <- function(x, ...) {
+  UseMethod("patch")
+}
+
+patch.default <- function(x, ...) {
+  stop_glue("
+  Don't know how to {bt('patch()')} an object of class {class_collapse(x)}
+  ")
+}
+
+patch.googlesheets4_schema <- function(x, ...) {
+  dots <- rlang::list2(...)
+  x[names(dots)] <- dots
+  check_against_schema(x)
+}
+
+# tibblify ----
+tibblify <- function(x, ...) {
+  UseMethod("tibblify")
+}
+
+tibblify.default <- function(x, ...) {
+  stop_glue("
+    Don't know how to {bt('tibblify()')} an object of class {class_collapse(x)}
+  ")
+}

R/sheets_create.R

@@ -0,0 +1,54 @@
+#' Create a new Sheet
+#'
+#' Creates an entirely new Sheet (spreadsheet or workbook). Offers some control
+#' over the initial set of sheets (worksheets or tabs). CAUTION: this function
+#' is still being developed and, for example, currently sends all data as
+#' character.
+#'
+#' @seealso Wraps the `spreadsheets.create` endpoint:
+#'   * <https://developers.google.com/sheets/api/reference/rest/v4/spreadsheets/create>
+#'
+#' @param name The name of the spreadsheet.
+#' @param ... Optional spreadsheet properties that can be set through this API
+#'   endpoint, such as locale and time zone.
+#' @param sheets Optional named list of data frames. One sheet is created for
+#'   each data frame.
+#'
+#' @inherit sheets_get return
+#' @export
+#'
+#' @examples
+#' if (sheets_has_token()) {
+#'   sheets_create("sheets-create-demo-1")
+#'
+#'   sheets_create("sheets-create-demo-2", locale = "en_CA")
+#'
+#'   sheets_create(
+#'     "sheets-create-demo-3",
+#'     locale = "fr_FR",
+#'     timeZone = "Europe/Paris"
+#'   )
+#'
+#'   sheets_create(
+#'     "sheets-create-demo-4",
+#'     sheets = list(iris = head(iris), mtcars = head(mtcars))
+#'   )
+#' }
+sheets_create <- function(name, ..., sheets = NULL) {
+  ss_body <- new("Spreadsheet") %>%
+    patch(properties = new(
+      id = "SpreadsheetProperties",
+      title = name, ...
+    ))
+  if (!is.null(sheets)) {
+    ss_body <- ss_body %>%
+      patch(sheets = unname(imap(sheets, as_Sheet)))
+  }
+  req <- request_generate(
+    "sheets.spreadsheets.create",
+    params = ss_body
+  )
+  raw_resp <- request_make(req)
+  resp <- gargle::response_process(raw_resp)
+  sheets_Spreadsheet(resp)
+}