Add support for S7

[hadley]

No description provided.

[natemcintosh]

Documentation of S7 classes seems to mostly work at the moment. The only issue I've encountered is defining a default value for a list field. For example, this works just fine when I run devtools::check():

#' Pet Class
#'
#' Represents a pet, where one field is a list.
#'
#' @param name The pet's name.
#' @param characteristics A list of characteristics to fill in as necessary.
#' @export
Pet <- S7::new_class( # nolint: object_name_linter
  "Pet",
  properties = list(
    name = S7::class_character,
    characteristics = S7::new_property(S7::class_list)
  )
)

But if I want to add a default value of the list:

#' Pet Class
#'
#' Represents a pet, where one field is a list.
#'
#' @param name The pet's name.
#' @param characteristics A list of characteristics to fill in as necessary.
#' @export
Pet <- S7::new_class( # nolint: object_name_linter
  "Pet",
  properties = list(
    name = S7::class_character,
    characteristics = S7::new_property(S7::class_list, default = list(
      field_a = S7::class_numeric,
      field_b = S7::class_character
    ))
  )
)

I get the following warning from devtools::check() (it is entirely a white space difference)

❯ checking for code/documentation mismatches ... WARNING
Codoc mismatches from Rd file 'Pet.Rd':
   Pet
     Code: function(name = character(0), characteristics = list(field_a =
                    structure(list( classes = list(structure(list(class =
                    "integer", constructor_name = "integer", constructor =
                    function (.data = integer(0)) .data, validator =
                    function (object) { if (base_class(object) != name) {
                    sprintf("Underlying data must be <%s> not <%s>", name,
                    base_class(object)) } }), class = "S7_base_class"),
                    structure(list(class = "double", constructor_name =
                    "double", constructor = function (.data = numeric(0))
                    .data, validator = function (object) { if
                    (base_class(object) != name) { sprintf("Underlying
                    data must be <%s> not <%s>", name, base_class(object))
                    } }), class = "S7_base_class"))), class = "S7_union"),
                    field_b = structure(list(class = "character",
                    constructor_name = "character", constructor = function
                    (.data = character(0)) .data, validator = function
                    (object) { if (base_class(object) != name) {
                    sprintf("Underlying data must be <%s> not <%s>", name,
                    base_class(object)) } }), class = "S7_base_class")))
     Docs: function(name = character(0), characteristics = list(field_a =
                    structure(list(classes = list(structure(list(class =
                    "integer", constructor_name = "integer", constructor =
                    function(.data = integer(0)) .data, validator =
                    function(object) { if (base_class(object) != name) {
                    sprintf("Underlying data must be <%s> not <%s>", name,
                    base_class(object)) } }), class = "S7_base_class"),
                    structure(list(class = "double", constructor_name =
                    "double", constructor = function(.data = numeric(0))
                    .data, validator = function(object) { if
                    (base_class(object) != name) { sprintf("Underlying
                    data must be <%s> not <%s>", name, base_class(object))
                    } }), class = "S7_base_class"))), class = "S7_union"),
                    field_b = structure(list(class = "character",
                    constructor_name = "character", constructor =
                    function(.data = character(0)) .data, validator =
                    function(object) { if (base_class(object) != name) {
                    sprintf("Underlying data must be <%s> not <%s>", name,
                    base_class(object)) } }), class = "S7_base_class")))
     Mismatches in argument default values:
       Name: 'characteristics'
       Code: list(field_a = structure(list(classes = list(structure(list(class = "integer", 
             constructor_name = "integer", constructor = function (.data = integer(0)) 
             .data, validator = function (object) 
             {
                 if (base_class(object) != name) {
                     sprintf("Underlying data must be <%s> not <%s>", 
                         name, base_class(object))
                 }
             }), class = "S7_base_class"), structure(list(class = "double", 
             constructor_name = "double", constructor = function (.data = numeric(0)) 
             .data, validator = function (object) 
             {
                 if (base_class(object) != name) {
                     sprintf("Underlying data must be <%s> not <%s>", 
                         name, base_class(object))
                 }
             }), class = "S7_base_class"))), class = "S7_union"), field_b = structure(list(
             class = "character", constructor_name = "character", constructor = function (.data = character(0)) 
             .data, validator = function (object) 
             {
                 if (base_class(object) != name) {
                     sprintf("Underlying data must be <%s> not <%s>", 
                         name, base_class(object))
                 }
             }), class = "S7_base_class"))
       Docs: list(field_a = structure(list(classes = list(structure(list(class = "integer", 
             constructor_name = "integer", constructor = function(.data = integer(0)) .data, 
             validator = function(object) {
                 if (base_class(object) != name) {
                     sprintf("Underlying data must be <%s> not <%s>", 
                         name, base_class(object))
                 }
             }), class = "S7_base_class"), structure(list(class = "double", 
             constructor_name = "double", constructor = function(.data = numeric(0)) .data, 
             validator = function(object) {
                 if (base_class(object) != name) {
                     sprintf("Underlying data must be <%s> not <%s>", 
                         name, base_class(object))
                 }
             }), class = "S7_base_class"))), class = "S7_union"), field_b = structure(list(class = "character", 
             constructor_name = "character", constructor = function(.data = character(0)) .data, 
             validator = function(object) {
                 if (base_class(object) != name) {
                     sprintf("Underlying data must be <%s> not <%s>", 
                         name, base_class(object))
                 }
             }), class = "S7_base_class"))

My particular use case is storing stan sampler options in a list that can be passed directly into stan.

[hadley]

Are you sure you want the default values to be class objects? That seems a bit surprising to me.

[natemcintosh]

Hi! Yes, class objects as the default is a bit strange. The intention is not that the default values will actually be used, but rather will be useful as a simple way of documenting the expected type. (Indeed, using the default values would cause the model to immediately error out). I was opting for "explicit is better".

[hadley]

Yeah, I'd definitely suggest an alternative approach because inlining the class definitions into the function defaults is not a good idea, IMO.

[mjskay]

FWIW (since this problem will presumably come up with any more complex objects as parameters, whether or not it is a good idea to inline class definitions ;)), I think the solution is to quote() the default argument definition:

Pet <- S7::new_class(
  "Pet",
  properties = list(
    name = S7::class_character,
    characteristics = S7::new_property(S7::class_list, default = quote(list(
      field_a = S7::class_numeric,
      field_b = S7::class_character
    )))
  )
)

Which per the docs will cause the unevaluated call to be placed into the function definition and evaluated when the constructor is called.

This means instead of the definition of the constructor being this ugly thing:

> Pet@constructor
function (name = character(0), characteristics = list(field_a = list(
    classes = list(list(class = "integer", constructor_name = "integer", 
        constructor = function (.data = integer(0)) 
        .data, validator = function (object) 
        {
            if (base_class(object) != name) {
                sprintf("Underlying data must be <%s> not <%s>", 
                  name, base_class(object))
            }
        }), list(class = "double", constructor_name = "double", 
        constructor = function (.data = numeric(0)) 
        .data, validator = function (object) 
        {
            if (base_class(object) != name) {
                sprintf("Underlying data must be <%s> not <%s>", 
                  name, base_class(object))
            }
        }))), field_b = list(class = "character", constructor_name = "character", 
    constructor = function (.data = character(0)) 
    .data, validator = function (object) 
    {
        if (base_class(object) != name) {
            sprintf("Underlying data must be <%s> not <%s>", 
                name, base_class(object))
        }
    }))) 
{
    name
    characteristics
    new_object(S7_object(), name = name, characteristics = characteristics)
}
<environment: namespace:gradual>

.... It it will look like this:

> Pet@constructor
function (name = character(0), characteristics = list(field_a = S7::class_numeric, 
    field_b = S7::class_character)) 
{
    name
    characteristics
    new_object(S7_object(), name = name, characteristics = characteristics)
}
<environment: namespace:gradual>

And in my quick test does not cause CMD CHECK issues.

[hadley]

@mjskay I forgot about that, thanks!

[mjskay]

np!