R/as-cff.R

In cffr: Generate Citation File Format ('CFF') Metadata

#' Coerce lists and citation objects to [`cff`]
#'
#' @description
#' `as_cff()` turns an existing list-like \R object into a [`cff`] object,
#' a list with class `cff` and the corresponding [subclass][cff_class] when
#' applicable.
#'
#' `as_cff()` is an S3 generic, with methods for:
#' - `person` objects as produced by [utils::person()].
#' - `bibentry` objects as produced by [utils::bibentry()].
#' - `Bibtex` objects as produced by [utils::toBibtex()].
#' - Default: Other inputs are first coerced with [base::as.list()].
#'
#' @param x A `person`, `bibentry` or other object that can be coerced to a
#'   list.
#' @param ... Additional arguments passed on to other methods.
#'
#' @return
#' - `as_cff.person()` returns an object with classes
#'   [`cff_pers_lst, cff`][cff_pers_lst].
#' - `as_cff.bibentry()` and `as_cff.Bibtex()` return an object with classes
#'   [`cff_ref_lst, cff`][cff_ref_lst].
#' - The remaining methods return an object of class `cff`. However, if
#'   `x` has a structure compatible with `definitions.person`,
#'   `definitions.entity` or `definitions.reference`, the object has the
#'   corresponding subclass.
#'
#' Learn more about the \CRANpkg{cffr} class system in [cff_class].
#'
#' @details
#' For `as_cff.bibentry()` and `as_cff.Bibtex()`, see
#' `vignette("bibtex-cff", package = "cffr")` to understand how the mapping is
#' performed.
#'
#' [as_cff_person()] is preferred over `as_cff.person()` because it can handle
#' `character` inputs such as `"Davis, Jr., Sammy"`. For `person` objects both
#' functions behave similarly.
#'
#' @seealso
#' - [cff()] creates a full `cff` object from scratch.
#' - [cff_modify()] modifies a `cff` object.
#' - [cff_create()] creates a `cff` object for an \R package.
#' - [cff_read()] creates a `cff` object from an external file.
#'
#' @family conversions
#' @rdname as_cff
#' @export
#' @encoding UTF-8
#' @examples
#' # Convert a list to a `cff` object.
#' cffobj <- as_cff(list(
#'   "cff-version" = "1.2.0",
#'   title = "Manipulating files"
#' ))
#'
#' class(cffobj)
#'
#' # Display the YAML representation.
#' cffobj
#'
#' # `bibentry` method.
#' a_cit <- citation("cffr")[[1]]
#'
#' a_cit
#'
#' as_cff(a_cit)
#'
#' # BibTeX method.
#' a_bib <- toBibtex(a_cit)
#'
#' a_bib
#'
#' as_cff(a_cit)
#'
as_cff <- function(x, ...) {
  UseMethod("as_cff")
}

#' @rdname as_cff
#' @export
#' @encoding UTF-8
as_cff.default <- function(x, ...) {
  as_cff(as.list(x), ...)
}

#' @rdname as_cff
#' @export
#' @encoding UTF-8
as_cff.list <- function(x, ...) {
  # Clean up empty top-level values.
  clean_up <- vapply(x, is.null, FUN.VALUE = logical(1))
  x_clean <- x[!clean_up]
  new_cff(x_clean)
}

#' @rdname as_cff
#' @export
#' @encoding UTF-8
as_cff.person <- function(x, ...) {
  as_cff_person(x)
}

#' @rdname as_cff
#' @export
#' @encoding UTF-8
as_cff.bibentry <- function(x, ...) {
  cff_ref <- as_cff_reference(x)
  clean_up <- vapply(cff_ref, is.null, FUN.VALUE = logical(1))
  if (all(clean_up)) {
    return(NULL)
  }

  cff_refs <- as_cff(cff_ref, ...)

  # Add classes.
  cff_refs_class <- lapply(cff_refs, function(x) {
    class(x) <- c("cff_ref", "cff")
    x
  })

  class(cff_refs_class) <- c("cff_ref_lst", "cff")
  cff_refs_class
}

#' @rdname as_cff
#' @export
#' @encoding UTF-8
as_cff.Bibtex <- function(x, ...) {
  tmp <- tempfile(fileext = ".bib")
  writeLines(x, tmp)
  abib <- cff_read_bib(tmp)
  cff_refs <- as_cff(abib, ...)

  # Add classes.
  cff_refs_class <- lapply(cff_refs, function(x) {
    class(x) <- c("cff_ref", "cff")
    x
  })

  class(cff_refs_class) <- c("cff_ref_lst", "cff")
  cff_refs_class
}

# nolint start
#' @rdname as_cff
#' @usage NULL
#' @export
#' @encoding UTF-8
as.cff <- function(x) {
  as_cff(x)
}
# nolint end

# Helper ----

#' Recursively clean lists
#'
#' @noRd
rapply_drop_null <- function(x) {
  if (is.list(x) && length(x) > 0) {
    x <- drop_null(x)
    x <- lapply(x, rapply_drop_null)
    x
  } else {
    x
  }
}

rapply_class <- function(x) {
  if (is_named(x)) {
    x <- x[!duplicated(names(x))]
  }

  xend <- lapply(x, function(el) {
    xelement <- el
    guess <- guess_cff_part(xelement)

    if (guess %in% c("unclear", "cff_full")) {
      return(xelement)
    }

    if (guess == "cff_pers_lst") {
      xelement <- lapply(xelement, function(j) {
        j_in <- j
        class(j_in) <- c("cff_pers", "cff")
        j_in
      })
      class(xelement) <- c("cff_pers_lst", "cff")
    }

    # Handle single-value languages.
    if (
      (all(guess == "cff_ref", "languages" %in% names(xelement))) &&
        (length(xelement$languages) < 2)
    ) {
      xelement$languages <- list(unlist(xelement$languages, use.names = FALSE))
    }

    if (guess == "cff_ref_lst") {
      xelement <- lapply(xelement, function(j) {
        j_in <- rapply_class(j)
        class(j_in) <- c("cff_ref", "cff")
        # Handle single-value languages.
        if (("languages" %in% names(j_in)) && (length(j_in$languages) < 2)) {
          j_in$languages <- list(unlist(j_in$languages, use.names = FALSE))
        }
        j_in
      })
      class(xelement) <- c("cff_ref_lst", "cff")
    }

    if (guess %in% c("cff_ref", "cff_pers")) {
      xin <- rapply_class(xelement)
      class(xin) <- c(guess, "cff")
      xelement <- xin
    }
    xelement
  })
  xend
}

# https://adv-r.hadley.nz/s3.html#s3-constructor
# Constructor.
new_cff <- function(x) {
  # Clean all strings recursively.

  x <- rapply(
    x,
    function(x) {
      if (is.list(x) || length(x) > 1) {
        return(x)
      }
      clean_str(x)
    },
    how = "list"
  )

  # Remove `NULL` values.
  x <- drop_null(x)

  # Remove duplicate names if named.
  if (is_named(x)) {
    x <- x[!duplicated(names(x))]
  }

  # Apply drop null to nested lists.
  x <- lapply(x, rapply_drop_null)

  # Reclass nested values.
  guess_x <- guess_cff_part(x)
  if (guess_x == "cff_ref_lst") {
    x2 <- lapply(x, function(j) {
      j2 <- rapply_class(j)
      class(j2) <- c("cff_ref", "cff")
      j2
    })
    class(x2) <- c(guess_x, "cff")
    return(x2)
  }

  xend <- rapply_class(x)

  final_class <- switch(guess_x,
    "cff_full" = "cff",
    "unclear" = "cff",
    c(guess_x, "cff")
  )

  if (!is.null(final_class)) {
    class(xend) <- final_class
  }

  xend
}