S7 in rvest

DESCRIPTION

@@ -19,6 +19,7 @@ Imports:
     lifecycle (>= 1.0.3),
     magrittr,
     rlang (>= 1.1.0),
+    S7 (>= 0.2.0),
     selectr,
     tibble,
     xml2 (>= 1.3)
@@ -42,4 +43,4 @@ Config/testthat/parallel: true
 Encoding: UTF-8
 Language: en-US
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2

NAMESPACE

@@ -1,32 +1,20 @@
 # Generated by roxygen2: do not edit by hand
 
-S3method(cookies,rvest_session)
-S3method(format,rvest_field)
-S3method(headers,rvest_session)
+S3method(html_element,"rvest::rvest_session")
 S3method(html_element,LiveHTML)
 S3method(html_element,default)
-S3method(html_element,rvest_session)
+S3method(html_elements,"rvest::rvest_session")
 S3method(html_elements,LiveHTML)
 S3method(html_elements,default)
-S3method(html_elements,rvest_session)
-S3method(html_form,rvest_session)
-S3method(html_form,xml_document)
-S3method(html_form,xml_node)
-S3method(html_form,xml_nodeset)
+S3method(html_table,"rvest::rvest_session")
 S3method(html_table,LiveHTML)
-S3method(html_table,rvest_session)
 S3method(html_table,xml_document)
 S3method(html_table,xml_node)
 S3method(html_table,xml_nodeset)
 S3method(html_text2,xml_document)
 S3method(html_text2,xml_missing)
 S3method(html_text2,xml_node)
 S3method(html_text2,xml_nodeset)
-S3method(print,rvest_field)
-S3method(print,rvest_form)
-S3method(print,rvest_session)
-S3method(read_html,rvest_session)
-S3method(status_code,rvest_session)
 export("%>%")
 export(LiveHTML)
 export(back)
@@ -69,6 +57,8 @@ export(url_absolute)
 export(xml_node)
 export(xml_nodes)
 export(xml_tag)
+if (getRversion() < "4.3.0") importFrom("S7", "@")
+import(S7)
 import(rlang)
 importFrom(glue,glue)
 importFrom(httr,cookies)

R/form.R

@@ -33,20 +33,31 @@
 #' resp <- html_form_submit(search)
 #' read_html(resp)
 #' }
-html_form <- function(x, base_url = NULL) UseMethod("html_form")
+html_form <- new_generic("html_form", "x", function(x, base_url = NULL) {
+  S7_dispatch()
+})
 
-#' @export
-html_form.xml_document <- function(x, base_url = NULL) {
+method(html_form, new_S3_class("xml_document")) <- function(x, base_url = NULL) {
   html_form(xml2::xml_find_all(x, ".//form"), base_url = base_url)
 }
 
-#' @export
-html_form.xml_nodeset <- function(x, base_url = NULL) {
+method(html_form, new_S3_class("xml_nodeset")) <- function(x, base_url = NULL) {
   lapply(x, html_form, base_url = base_url)
 }
 
-#' @export
-html_form.xml_node <- function(x, base_url = NULL) {
+rvest_form <- new_class(
+  "rvest_form",
+  package = "rvest",
+  properties = list(
+    name = class_character,
+    method = class_character,
+    action = class_character,
+    enctype = class_character,
+    fields = class_list
+  )
+)
+
+method(html_form, new_S3_class("xml_node")) <- function(x, base_url = NULL) {
   if (xml2::xml_name(x) != "form") {
     cli::cli_abort("{.arg x} must be a <form> element.")
   }
@@ -66,23 +77,21 @@ html_form.xml_node <- function(x, base_url = NULL) {
       button = parse_button(x)
     )
   })
-  names(fields) <- map_chr(fields, function(x) x$name %||% "")
+  names(fields) <- map_chr(fields, function(x) x@name %||% "")
 
-  structure(
-    list(
-      name = name,
-      method = method,
-      action = xml2::url_absolute(attr$action, base_url %||% xml2::xml_url(x)),
-      enctype = enctype,
-      fields = fields
-    ),
-    class = "rvest_form")
+  rvest_form(
+    name = name,
+    method = method,
+    action = xml2::url_absolute(attr$action, base_url %||% xml2::xml_url(x)),
+    enctype = enctype,
+    fields = fields
+  )
 }
 
-#' @export
-print.rvest_form <- function(x, ...) {
-  cat("<form> '", x$name, "' (", x$method, " ", x$action, ")\n", sep = "")
-  cat(format_list(x$fields, indent = 1), "\n", sep = "")
+print <- new_external_generic("base", "print", "x")
+method(print, rvest_form) <- function(x, ...) {
+  cat("<form> '", x@name, "' (", x@method, " ", x@action, ")\n", sep = "")
+  cat(format_list(x@fields, indent = 1), "\n", sep = "")
 }
 
 
@@ -103,14 +112,14 @@ html_form_set <- function(form, ...) {
   check_fields(form, new_values)
 
   for (field in names(new_values)) {
-    type <- form$fields[[field]]$type %||% "non-input"
+    type <- form@fields[[field]]@type %||% "non-input"
     if (type == "hidden") {
       cli::cli_warn("Setting value of hidden field {.str {field}}.")
     } else if (type == "submit") {
       cli::cli_abort("Can't change value of input with type submit: {.str {field}}.")
     }
 
-    form$fields[[field]]$value <- new_values[[field]]
+    form@fields[[field]]@value <- new_values[[field]]
   }
 
   form
@@ -132,20 +141,20 @@ html_form_submit <- function(form, submit = NULL) {
 }
 
 submission_build <- function(form, submit, error_call = caller_env()) {
-  method <- form$method
+  method <- form@method
   if (!(method %in% c("POST", "GET"))) {
     cli::cli_warn("Invalid method ({method}), defaulting to GET.", call = error_call)
     method <- "GET"
   }
 
-  if (length(form$action) == 0) {
+  if (length(form@action) == 0) {
     cli::cli_abort("`form` doesn't contain a `action` attribute.", call = error_call)
   }
 
   list(
     method = method,
-    enctype = form$enctype,
-    action = form$action,
+    enctype = form@enctype,
+    action = form@action,
     values = submission_build_values(form, submit, error_call = error_call)
   )
 }
@@ -159,17 +168,17 @@ submission_submit <- function(x, ...) {
 }
 
 submission_build_values <- function(form, submit = NULL, error_call = caller_env()) {
-  fields <- form$fields
+  fields <- form@fields
   submit <- submission_find_submit(fields, submit, error_call = error_call)
   entry_list <- c(Filter(Negate(is_button), fields), list(submit))
-  entry_list <- Filter(function(x) !is.null(x$name), entry_list)
+  entry_list <- Filter(function(x) S7_inherits(x, rvest_field), entry_list)
 
   if (length(entry_list) == 0) {
     return(list())
   }
 
-  values <- lapply(entry_list, function(x) as.character(x$value))
-  names <- map_chr(entry_list, "[[", "name")
+  values <- lapply(entry_list, function(x) as.character(x@value))
+  names <- map_chr(entry_list, function(x) x@name)
 
   out <- set_names(unlist(values, use.names = FALSE), rep(names, lengths(values)))
   as.list(out)
@@ -183,7 +192,7 @@ submission_find_submit <- function(fields, idx, error_call = caller_env()) {
       list()
     } else {
       if (length(buttons) > 1) {
-        cli::cli_inform("Submitting with button {.str {buttons[[1]]$name}}.")
+        cli::cli_inform("Submitting with button {.str {buttons[[1]]@name}}.")
       }
       buttons[[1]]
     }
@@ -212,38 +221,35 @@ submission_find_submit <- function(fields, idx, error_call = caller_env()) {
 }
 
 is_button <- function(x) {
-  tolower(x$type) %in% c("submit", "image", "button")
+  tolower(x@type) %in% c("submit", "image", "button")
 }
 
 # Field parsing -----------------------------------------------------------
-
-rvest_field <- function(type, name, value, attr, ...) {
-  structure(
-    list(
-      type = type,
-      name = name,
-      value = value,
-      attr = attr,
-      ...
-    ),
-    class = "rvest_field"
+rvest_field <- new_class(
+  "rvest_field",
+  package = "rvest",
+  properties = list(
+    type = class_character,
+    name = class_character | NULL,
+    value = class_character | NULL,
+    attr = class_list,
+    options = NULL | class_character
   )
-}
+)
 
-#' @export
-format.rvest_field <- function(x, ...) {
-  if (x$type == "password") {
-    value <- paste0(rep("*", nchar(x$value %||% "")), collapse = "")
+format <- new_external_generic("base", "format", "x")
+method(format, rvest_field) <- function(x, ...) {
+  if (x@type == "password") {
+    value <- paste0(rep("*", nchar(x@value %||% "")), collapse = "")
   } else {
-    value <- paste(x$value, collapse = ", ")
+    value <- paste(x@value, collapse = ", ")
     value <- str_trunc(encodeString(value), 20)
   }
 
-  paste0("<field> (", x$type, ") ", x$name, ": ", value)
+  paste0("<field> (", x@type, ") ", x@name, ": ", value)
 }
 
-#' @export
-print.rvest_field <- function(x, ...) {
+method(print, rvest_field) <- function(x, ...) {
   cat(format(x, ...), "\n", sep = "")
   invisible(x)
 }
@@ -281,7 +287,7 @@ parse_options <- function(options) {
   }
 
   parsed <- lapply(options, parse_option)
-  value <-  map_chr(parsed, "[[", "value")
+  value <- map_chr(parsed, "[[", "value")
   name <- map_chr(parsed, "[[", "name")
   selected <- map_lgl(parsed, "[[", "selected")
 
@@ -336,7 +342,7 @@ format_list <- function(x, indent = 0) {
 }
 
 check_fields <- function(form, values, error_call = caller_env()) {
-  no_match <- setdiff(names(values), names(form$fields))
+  no_match <- setdiff(names(values), names(form@fields))
   if (length(no_match) > 0) {
     cli::cli_abort(
       "Can't set value of fields that don't exist: {.str {no_match}}.",

R/rvest-package.R

@@ -61,6 +61,7 @@ magrittr::`%>%`
 # roxygen namespace tags. Modify with care!
 ## usethis namespace: start
 #' @importFrom glue glue
+#' @import S7
 ## usethis namespace: end
 NULL