R/ListData.R

In DistributionalDDA: Distributional Data Analysis in Bayes Spaces

# the environment storing the weak references
digestEnv=new.env()
#' @export
#' @describeIn ListData the environment in which the digests can be found
ListDataEnv=new.env()
assign("Forgotten",structure(NA,class="Forgotten"),ListDataEnv)

#' Makes a list includable in a data.frame
#'
#' data.frame objects treat lists as variables and not as cases. This
#' functions presents the list as data to a data.frame. For better
#' printing the elements of the list will be represented as a name.
#'
#' The first letter of the name is the first letter of the class, then
#' comes a '_' and then a alphanumerical digest, of the objects. As
#' long as the object is in reach, it can be inspected by this name.
#'
#' Afterwards an NA of class "ForgottenObject" is returned.
#'
#' @param x a list like to be converted to something includable in a
#'     data.frame.
#' @param hash the displayed name of the object as character string
#' @param env the environment keeping the object in the hash, if none
#'     provided, .GlobalEnv is used.
#' @param row.names the row names for the dataset
#' @param optional unused, see [as.data.frame] for details
#' @param ... for generic use
#'
#'
#' @returns the object x with an additional "ListData" class attribute
#' @export
#'
#' @examples
#' FX = ListData(
#'    list(function(x) x,
#'         function(x) x^2,
#'         function(x) x^3))
#' FX
#' D = data.frame(X=FX,Y=FX)
#' D
#' N = format(FX)[[1]]
#' N
#' ListDataRecover(N)
#' attach(ListDataEnv)
#' get(N)
#' N2 = storingDigester(function(x) sin(x))
#' N2
#' ListDataRecover(N2)
#' detach(ListDataEnv)
#'
ListData = function(x) structure(x,class=c(attr(x,"class"),"ListData","list"))


#' @export
#' @describeIn ListData recovers object from the digest
#' @importFrom rlang wref_value
ListDataRecover = function(hash) {
    weak = get(hash,digestEnv)
    value = wref_value(weak)
    if( is.null(value) )
        return(get("Forgotten",ListDataEnv))
    do.call(delayedAssign,list(x=hash,value=call("ListDataRecover",hash),
                               eval.env=globalenv(),assign.env=ListDataEnv))
    value
}

#' @export
#' @importFrom rlang new_weakref
#' @importFrom digest digest
#' @describeIn ListData returns a recoverable digest of the object
storingDigester = function(x,env=environment(x)) {
    if( is.null(x) )
        return("null")
    if( is.null(env) )
        env=globalenv()
    l=substr(paste(class(x),collapse=""),1,1)
    hash = paste(l,digest::digest(x,algo="crc32"),sep="_")
    weak = new_weakref(env,x)
    assign(hash,weak,digestEnv)
    do.call(delayedAssign,list(x=hash,value=call("ListDataRecover",hash),
                               eval.env=globalenv(),assign.env=ListDataEnv))
    hash
}

#' @export
#' @describeIn ListData formats as the digest
#' @method format ListData
format.ListData = function(x,...) {
   structure(sapply(x,storingDigester),class="AsIs")
}

#' @export
#' @describeIn ListData formats as the digest
#' @method format BData
format.BData = function(x,...) {
   structure(sapply(x,storingDigester),class="AsIs")
}


#' @export
#' @describeIn ListData converts to a data.frame
#' @method as.data.frame ListData
as.data.frame.ListData <- function(x, row.names = NULL, optional = FALSE, ...) {
    myNames = names(x)
    if( is.null(row.names) )
        row.names=myNames
    if( duplicated(row.names) || length(row.names)!=length(x))
        row.names=paste(1:length(x))
    structure(list(x),row.names=row.names,class=c("ListData","list","data.frame"))
}

#' @export
#' @describeIn ListData converts to a data.frame
#' @method as.data.frame BData
as.data.frame.BData <- function(x, row.names = NULL, optional = FALSE, ...) {
    myNames = names(x)
    if( is.null(row.names) )
        row.names=myNames
    if( duplicated(row.names) || length(row.names)!=length(x))
        row.names=paste(1:length(x))
    structure(list(x),row.names=row.names,class=c("data.frame"))
}



#' @export
# ' @describeIn ListData a subsetting retaining the class
#' @method '[' ListData
#'
"[.ListData" <- function(x,...,drop=TRUE) {
    xN = unclass(x)[...,drop=FALSE]
    if( drop && length(xN)==1) {
        return(xN[[1]])
    } else {
        class(xN)=class(x)
        xN
    }
}