#' @include internal.R pproto.R Constraint-proto.R Penalty-proto.R
NULL
#' @export
methods::setOldClass("Collection")
#' Collection prototype
#'
#' This prototype represents a collection of
#' \code{\link{ConservationModifier-class}} objects.
#'
#' @section Fields:
#' \describe{
#' \item{$...}{\code{\link{ConservationModifier-class}} objects stored
#' in the collection.}
#' }
#'
#' @section Usage:
#' \code{x$print()}
#'
#' \code{x$show()}
#'
#' \code{x$repr()}
#'
#' \code{x$ids()}
#'
#' \code{x$length()}
#'
#' \code{x$add}
#'
#' \code{x$remove(id)}
#'
#' \code{x$get_parameter(id)}
#'
#' \code{x$set_parameter(id, value)}
#'
#' \code{x$render_parameter(id)}
#'
#' \code{x$render_all_parameters()}
#'
#' @section Arguments:
#' \describe{
#'
#' \item{id}{\code{id} object.}
#'
#' \item{value}{any object.}
#'
#' }
#'
#' @section Details:
#'
#' \describe{
#'
#' \item{print}{print the object.}
#'
#' \item{show}{show the object.}
#'
#' \item{repr}{\code{character} representation of object.}
#'
#' \item{ids}{\code{character} ids for objects inside collection.}
#'
#' \item{length}{\code{integer} number of objects inside collection.}
#'
#' \item{add}{add \code{\link{ConservationModifier-class}} object.}
#'
#' \item{remove}{remove an item from the collection.}
#'
#' \item{get_parameter}{retrieve the value of a parameter in the object
#' using an \code{id} object.}
#'
#' \item{set_parameter}{change the value of a parameter in the object
#' to a new object.}
#'
#' \item{render_parameter}{generate a \emph{shiny} widget to modify the
#' the value of a parameter (specified by argument \code{id}).}
#'
#' \item{render_all_parameters}{generate a \code{\link[shiny]{div}}
#' containing all the parameters" widgets.}
#'
#' }
#'
#' @seealso \code{\link{Constraint-class}}, \code{\link{Penalty-class}}.
#'
#' @name Collection-class
#'
#' @aliases Collection
NULL
#' @export
Collection <- pproto(
"Collection",
repr = function(self) {
if (base::length(self$ids()) > 0)
return(paste0("<", paste(sapply(self$ids(),
function(z) self[[z]]$repr()),
collapse = "\n"), ">"))
return("<none>")
},
find_parameter = function(id) {
n <- self$ids()
r <- sapply(n, function(x) {
id %in% sapply(self[[x]]$parameters, function(z) z$id)
})
s <- sum(r)
if (s == 0) {
stop("no parameter with matching id found")
} else if (s > 1) {
stop("multiple parameters with matching id found")
}
n[r]
},
find = function(self, x) {
assertthat::assert_that(assertthat::is.string(x) || is.id(x))
if (inherits(x, "Id")) {
return(x)
} else {
n <- self$ids()
x <- match(x, sapply(n, function(j) self[[j]]$name))
if (!is.finite(x))
stop("item with matching name not found")
if (base::length(x) > 1)
stop("multiple items with the same name")
return(n[x])
}
},
ids = function(self) {
o <- self$ls()
o[!sapply(o, function(x) inherits(self[[x]], "function"))]
},
length = function(self) {
base::length(self$ids())
},
add = function(self, x) {
assertthat::assert_that(inherits(x, "ConservationModifier"))
self[[new_id()]] <- x
invisible()
},
remove = function(self, x) {
assertthat::assert_that(is.Id(x))
rm(list = as.character(x), envir = self)
invisible(TRUE)
},
get_parameter = function(self, id) {
assertthat::assert_that(inherits(id), "Id")
self[[self$find_parameter(id)]]$get_parameter(id)
},
set_parameter = function(self, id, value) {
assertthat::assert_that(inherits(id), "Id")
self[[self$find_parameter(id)]]$set_parameter(id, value)
},
render_parameter = function(self, id, value) {
assertthat::assert_that(inherits(id), "Id")
self[[self$find_parameter(id)]]$render_parameter(id)
},
render_all_parameters = function(self) {
do.call(shiny::div,
append(list(class = "Collection"),
lapply(self$ids(), function(x) {
self[[x]]$render_all_parameters()
})))
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.