R/field.R

In signaux-faibles/MLlogr:

#' Create a field
#'
#' Creates a new field with several possible parameters.
#'
#' @param name `character(1)` \cr Field name
#' @param output_name `character(1)` \cr Name of the field in the database, by
#'   default same as name.
#' @param is_compulsary `logical(1)` \cr Is the field compulsary to be able to
#'   log ?
#' @param transform `function: any -> any` \cr A transformation function that
#'   is applied on the value each time the field is set.
#' @param validate `function: any -> logical(1)` \cr A validation function
#'   that checks that input value is valid each time the field is set.
#' @param warn_on_overwrite `logical(1)` \cr Should the function issue a
#'   warning when a value is overwritten with a different one ? Put to FALSE
#'   if values cannot be compared with `identical` function.
#'
#' @return A list of class `field`
#' @family fields
#' @export
#'
#' @examples
#' foo <- field("foo")
#' bar <- field(name = "foo", output_name = "bar", is_compulsary = TRUE)
field <- function(
  name,
  output_name = name,
  is_compulsary = FALSE,
  validate = NULL,
  warn_on_overwrite = TRUE,
  transform = NULL,
  additional_transform_params = NULL
  ){

  f <- list(
    name = name,
    output_name = output_name,
    is_compulsary = is_compulsary,
    transform = transform,
    validate = validate,
    warn_on_overwrite = warn_on_overwrite,
    additional_transform_params = additional_transform_params
  )
  class(f) <- "field"
  return(f)
}


#' Set a value to a field
#'
#' @param field `field` \cr A list of class `field`
#' @param value `any` \cr A value to set to the field
#'
#' @return The field, to which "value" has been added.
#' @export
#'
#' @examples
#' my_field <- field("foo", validate = is.character, warn_on_overwrite = TRUE)
#' my_field <- set_field(my_field, "Hello")
#' \dontrun{
#' # Warning: value overwritten
#' my_field <- set_field(my_field, "Goodbye")
#' # Error: value not validated
#' my_field <- set_field(my_field, 3)
#' }
set_field <- function(
  field,
  value,
  control = list()
  ){

  assertthat::assert_that(inherits(field, "field"))

  # Validation
  if (!is.null(field[["validate"]])){
    valid_field <- if ("control" %in% names(formals(field[["validate"]]))){
      field[["validate"]](value, control)
    } else {
      field[["validate"]](value)
    }
    assertthat::assert_that(
      valid_field,
      msg = paste0(
        "Field ",
        field[["name"]],
        " is not fullfilling the requirements of the 'validate' function"
        )
      )
  }
  # Transformation
  if (is.null(field[["transform"]])){
    transformed_value <- value
  } else {
    if ("control" %in% names(formals(field[["transform"]]))){
      transformed_value <- field[["transform"]](value, control = control)
    } else {
      transformed_value <- field[["transform"]](value)
    }
  }

  if (field[["warn_on_overwrite"]] &&
    !is.null(field[["value"]]) &&
    !identical(transformed_value, field[["value"]])
    ){
    warning(paste0("Overwriting field :", field[["name"]]))
  }
  field[["value"]] <- transformed_value
  return(field)
}

#' Creates a field with a timestamp of the log
#'
#' This field writes date and time when the tracker is logged. By default, the
#' field is named "timestamp".
#'
#' @param name `character(1)` \cr Name of the field.
#'
#' @return An object of class `field`
#' @family fields
#' @export
field_timestamp <- function(name = "timestamp"){
  res <- field(
    name,
    transform = function(x) expression(Sys.time())
    )
  res <- set_field(res, NA)
  return(res)
}


#' Creates a field with a unique identifier
#'
#' This enables to have a unique identifier attached to the logger. If the
#' logger logs several times, the identifier will stay the same. By default,
#' the field is named "uuid"
#'
#' @inheritParams field_timestamp
#'
#' @inherit field_timestamp return
#' @family fields
#' @export
field_uuid <- function(name = "uuid"){
  res <- field(
    name,
    transform = function(x) {
      if (require(uuid)){
        return(uuid::UUIDgenerate())
      } else {
        warning("No uuid can be generated as uuid package is missing")
        return(0)
      }
    }
    )
  res <- set_field(res, NA)
  return(res)
}