Nothing
#' @md
#' @title Extract
#' @param x chronologies object
#' @param i iteration in chronologies list
#' @description Obtain one of the elements within a `chronologies` list
#' either by element order or by element name.
#' @returns selected `chronology` object
#' @export
setMethod(f = "[[",
signature = signature(x = "chronologies", i = "numeric"),
definition = function(x, i) {
if (length(i) == 1) {
out <- new("chronology", x@chronologies[[i]])
} else {
out <- purrr::map(i, function(z) {
new("chronology", x@chronologies[[z]])
})
out <- new("chronology", chronologies = out)
}
return(out)
})
#' @title Extract
#' @param x chronology object
#' @param name name of the slot
#' @description Extract chronology metadata by slot name.
#' @returns value of the `slot` name
#' @export
setMethod(f = "$",
signature = signature(x = "chronology"),
definition = function(x, name) {
slot(x, name)
})
#' @title Replace part of an object
#' @param x A chronology object
#' @param name The name of the chronology slot.
#' @param value A value to be assigned to the chronology slot.
#' @description Assign values to slots within a chronology object.
#' @returns reassigned `chronology` object
#' @export
setMethod(f = "$<-",
signature = signature(x = "chronology"),
definition = function(x, name, value) {
slot(x, name) <- value
return(x)
})
#' @title Extract
#' @param x chronologies object
#' @param name name of the slot
#' @description Obtain chronology slots across all chronology elements within
#' a chronologies object.
#' @returns A multiple `chronologies`
#' @export
setMethod(f = "$",
signature = signature(x = "chronologies"),
definition = function(x, name) {
x %>%
map(function(y) {
slot(y, name)
}) %>%
unlist()
})
#' @title Create a data.frame from a chronology object.
#' @param x chronology object
#' @description Convert all slots within a chronology to a data.frame.
#' @importFrom lubridate as_date
#' @returns data.frame
#' @export
setMethod(f = "as.data.frame",
signature = signature("chronology"),
definition = function(x) {
data.frame(chronologyid = as.character(x@chronologyid),
notes = x@notes,
agemodel = x@agemodel,
ageboundolder = x@ageboundolder,
ageboundyounger = x@ageboundyounger,
isdefault = x@isdefault,
dateprepared =
lubridate::as_date(ifelse(is.null(x@dateprepared),
NA, x@dateprepared)),
modelagetype = x@modelagetype,
chronologyname = x@chronologyname)
})
#' @title as.data.frame chronologies
#' @param x chronologies object
#' @importFrom purrr map
#' @description Convert all slots within each chronology within a
#' chronologies object to a data.frame.
#' @returns data.frame with chronologies metadata
#' @export
setMethod(f = "as.data.frame",
signature = signature("chronologies"),
definition = function(x) {
x@chronologies %>% map(as.data.frame) %>% bind_rows()
})
#' @title Length Method chronologies
#' @export
#' @returns integer describing length
#' @param x chronologies object
setMethod(f = "length",
signature = signature(x = "chronologies"),
definition = function(x) {
length(x@chronologies)
})
#' @title c Method - Combine chronologies objects
#' @param x chronologies object 1
#' @param y chronologies object 2
#' @returns concatenated `chronologies`
#' @export
setMethod(f = "c",
signature = signature(x = "chronologies"),
definition = function(x, y) {
if ("chronology" %in% class(y)) {
y <- new("chronologies", chronologies = list(y))
}
tryCatch(
expr = {
new("chronologies",
chronologies = unlist(c(x@chronologies,
y@chronologies),
recursive = FALSE))
},
error = function(e) {
stop("Use `get_downloads()` to fill chronologies details.
Current `sites` object comes from `get_sites()` or
`get_datasets()` which does not have chronology
detail")
})
})
#' @title write CSV
#' @param x chronologies object
#' @param ... Additional parameters associated with the call.
#' @returns null, called for side effects
#' @export
setMethod(f = "write.csv",
signature = "chronologies",
definition = function(x, ...) {
df1 <- as.data.frame(x)
write.csv(df1, ...)
})
#' @title Change the default age model for a record.
#' @param x A chronologies object.
#' @param n The particular chronology to be used as the default.
#' @returns `chronologies` object with a new defaulted `chronology`
#' @importFrom purrr map
setMethod(f = "set_default",
signature = signature(x = "chronologies"),
definition = function(x, n) {
assertthat::assert_that(class(x) == "chronologies")
chron_set <- as.data.frame(x)
assertthat::assert_that(n %in% chron_set$chronologyid,
msg = "The new default chronology must be a valid chronologyid
within the chronologies.")
which_replace <- chron_set$chronologyid == n
replacingmodel <- chron_set$modelagetype[which_replace]
chronout <- purrr::map(seq_len(length(x)), function(y) {
if (x@chronologies[[y]]$chronologyid == n) {
x@chronologies[[y]]@isdefault <- 1
}
if (x@chronologies[[y]]$chronologyid != n &
x@chronologies[[y]]$modelagetype == replacingmodel) {
x@chronologies[[y]]@isdefault <- 0
}
return(x@chronologies[[y]])
})
return(new("chronologies", chronologies = chronout))
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.