#' @title AmObject class
#' @author datastorm-open
#' @description This is a virtual class for representing any Am** class
#'
#' @slot listeners \code{list} containining the listeners to add to the object.
#' The list must be named as in the official API. Each element must be a character string.
#' @slot otherProperties \code{list}
#' containing other avalaible properties not yet implemented in the package.
#' @slot value \code{numeric}.
#'
#' @export
setClass(Class = "AmObject",
representation = representation(
value = "numeric",
listeners = "list",
otherProperties = "list", "VIRTUAL"))
#' @title Visualize with show
#' @description Display the object in the console.
#' @param object \linkS4class{AmObject}.
#' @examples
#' library(pipeR)
#' amPieChart(valueField = "value", titleField = "key", backgroundColor = "#7870E8") %>>%
#' setDataProvider(data.frame(key = c("FR", "US"), value = c(20,10))) %>>%
#' setExport(position = "bottom-left")
#' @export
#'
setMethod(f = "show", signature = "AmObject",
definition = function(object)
{
cat("~", class(object),"~\n")
print(listProperties(object))
})
#' @title Visualize with print
#' @description Display the object in the console.
#' @param x \linkS4class{AmChart}.
#' @param withDetail \code{logical}, TRUE to display details.
#' @param ... Other properties.
#' @examples
#' print(new("AmChart", categoryField = "variables", type = "serial"))
#' print(new("AmChart", categoryField = "variables", type = "serial"), withDetail = FALSE)
#' @details If the object possess a 'dataProvider' property, it will be hidden in the console.
#' To see if it's correctly registered use '@dataProvider'.
#' @export
#'
setMethod(f = "print", signature = "AmObject",
definition = function(x, withDetail = TRUE,...)
{
if (withDetail) {
cat("~ ", class(x)," object (with detail) ~\n\n")
cat("Referenced properties:\n")
ls <- listProperties(x)
cat(paste(grep(pattern = "RType_", x = names(ls), value = TRUE, invert = TRUE), collapse = ", "))
cat("\n- Detail:\n")
if (exists(x = "dataProvider", where = ls))
ls["dataProvider"] <- NULL
print(ls)
} else {
cat("~ ", class(x)," object (without detail)~\n\n")
cat("Referenced properties:\n")
ls <- listProperties(x)
cat(paste(grep(pattern = "RType_", x = names(ls), value = TRUE, invert = TRUE), collapse = ", "))
}
cat("\n")
})
# > @listeners: setters ####
#' @title AmObject methods
#' @description Methods for inherited classes.
#' @param .Object \code{\linkS4class{AmObject}}.
#' @param name \code{character}, name of the listener.
#' @param expression \code{character}, associated function event.
#' @return The updated object.
#' @examples
#' addListener(.Object = amPieChart(),
#' name = "clickSlice" ,
#' expression = "function(event){ alert('ok !'); }")
#'
#' addListener(.Object = amLegend(),
#' name = "select",
#' expression = paste0("function onSelect (properties) {",
#' "alert('selected nodes: ' + properties.nodes);",
#' "}"))
#' @rdname methods-AmObject
#' @export
#'
setGeneric(name = "addListener", def = function(.Object, name, expression) { standardGeneric("addListener")})
#' @rdname methods-AmObject
setMethod(f = "addListener", signature = c("AmObject", "character", "character"),
definition = function(.Object, name, expression)
{
.Object@listeners[[ eval(name) ]] <- htmlwidgets::JS(expression)
validObject(.Object)
return(.Object)
})
# > @otherProperties: resetProperties ####
#' @examples
#' library(pipeR)
#' amPlot(runif(10)) %>>% resetProperties("categoryAxis") %>>% print(withDetail = FALSE)
#' @details Former properties will be overwritten.
#' @rdname methods-AmObject
#' @export
#'
setGeneric(name = "resetProperties", def = function(.Object, ...) {standardGeneric("resetProperties")})
#' @rdname methods-AmObject
setMethod(f = "resetProperties", signature = c(.Object = "AmObject"),
definition = function(.Object, ...)
{
invisible(sapply(X = ..., FUN = function (slot_name) {
new_value <- new(class(slot(object = .Object, name = slot_name)))
slot(object = .Object, name = slot_name, check = TRUE) <<- new_value
}))
validObject(.Object)
return(.Object)
})
# > @otherProperties: setProperties ####
#' @param list_prop (Optional) \code{list} containing properties to set.
#' The former properties will be overwritten.
#' @param ... other properties
#' @examples
#' library(pipeR)
#' # either you can set a list
#' ls <- list(categoryAxis = list(gridPosition = "start"), fontSize = 15)
#' amSerialChart() %>>% setProperties(list = ls) %>>% print()
#'
#' # or you can set one or more properties
#' amPieChart() %>>% setProperties(handDrawn = TRUE, fontSize = 15) %>>% print()
#'
#' # overwrite a property
#' amPieChart() %>>% setProperties(fontSize = 15) %>>% setProperties(fontSize = 12) %>>% print()
#'
#' # Carefull if you try to set a property which is a slot...
#' # in that case, use the setter methods 'setXX' or 'addXX' which check the validity
#' \dontrun{
#' amPieChart() %>>% setProperties(type = "serial") %>>% print()
#' }
#'
#' amPieChart() %>>% setExport()
#' @details Former properties will be overwritten.
#' @rdname methods-AmObject
#' @export
#'
setGeneric(name = "setProperties", def = function(.Object, list_prop, ...){standardGeneric("setProperties")})
#' @rdname methods-AmObject
setMethod(f = "setProperties", signature = c(.Object = "AmObject"),
definition = function(.Object, list_prop, ...)
{
if (missing(list_prop)) {
newProperties <- list(...)
# Different cases have to be considered since the properties
# may be referenced as slots, in that case a warning is sent.
lapply(X = names(newProperties), FUN = function(prop) {
if (prop %in% slotNames(.Object)) {
# if it's a slot and the prop is not "value", a warning is sent
if (prop != "value")
warning("You should use setter for property '", prop, "'")
slot(.Object, prop, check = TRUE) <<- newProperties[[prop]]
} else {
.Object@otherProperties[[prop]] <<- newProperties[[prop]]
}
invisible()
})
} else if (is.list(list_prop))
.Object@otherProperties <- list_prop
validObject(.Object)
return(.Object)
})
# > listProperties ####
#' @title List properties of an S4 object
#' @description Each S4 class implements the method to list its properties
#' (usefull to update complex properties).
#' @param .Object any class object of the package
#' @return A list containing all the chart's properties.
#' @examples
#' amChart(type = "serial")
#' @rdname listProperties-AmObject
#' @export
#'
setGeneric(name = "listProperties", def = function(.Object) {standardGeneric("listProperties")})
#' @rdname listProperties-AmObject
setMethod(f = "listProperties", signature = "AmObject",
definition = function(.Object)
{
if (length(.Object@otherProperties))
properties <- .Object@otherProperties
else
properties <- list()
if (length(.Object@value))
properties[["value"]] <- .Object@value
if (length(.Object@listeners))
properties <- c(properties, listeners = .Object@listeners)
# get all slot declared in the class except the package specific ones
slot_names <- names(getSlots(class(.Object)))
real_slots_i <- grep("properties", slot_names, ignore.case = TRUE, invert = TRUE)
# iterate over all slots which can be passed to htmlwidgets as is
for (i in real_slots_i) {
slot_name_loop <- slot_names[i]
slot_value_loop <- slot(object = .Object, name = slot_name_loop)
if (length(slot_value_loop))
properties[[slot_name_loop]] <- slot_value_loop
}
return(properties)
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.