diff --git a/NAMESPACE b/NAMESPACE index bbad3872..77f1357b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -343,6 +343,7 @@ export(cacheISOClasses) export(convert_metadata) export(geometaLogger) export(geometa_coverage) +export(getClassesInheriting) export(getGeometaOption) export(getIANAMimeTypes) export(getISOClasses) diff --git a/R/ISOAbstractObject.R b/R/ISOAbstractObject.R index 19460dd1..f66c9e3a 100644 --- a/R/ISOAbstractObject.R +++ b/R/ISOAbstractObject.R @@ -1551,6 +1551,80 @@ ISOAbstractObject$compare = function(metadataElement1, metadataElement2){ return(text1 == text2) } +#' @name getClassesInheriting +#' @aliases getClassesInheriting +#' @title getClassesInheriting +#' +#' @param classname the name of the superclass for which inheriting sub-classes have to be listed +#' @param extended whether we want to look at user namespace for third-party sub-classes +#' @param pretty prettify the output as \code{data.frame} + +#' @export +#' @description get the list of classes inheriting a given super class provided by its name +#' +#' @usage getClassesInheriting(classname, extended, pretty) +#' +#' @examples +#' getClassesInheriting("ISAbstractObject") +getClassesInheriting <- function(classname, extended = FALSE, pretty = FALSE){ + list_of_classes <- ls(getNamespaceInfo("geometa", "exports")) + if(extended) { + search_envs <- search() + search_envs <- search_envs[search_envs!="package:geometa"] + list_of_other_classes <- unlist(sapply(search_envs, ls)) + list_of_classes <- c(list_of_classes, list_of_other_classes) + } + + list_of_classes <- list_of_classes[sapply(list_of_classes, function(x){ + clazz <- try(eval(parse(text=x)),silent=TRUE) + if(is(clazz, "try-error")) clazz <- try(eval(parse(text=paste0("geometa::",x))),silent=TRUE) + r6Predicate <- class(clazz)[1]=="R6ClassGenerator" + if(!r6Predicate) return(FALSE) + + geometaObjPredicate <- FALSE + superclazz <- clazz + while(!geometaObjPredicate && !is.null(superclazz)){ + clazz_fields <- names(superclazz) + if(!is.null(clazz_fields)) if(length(clazz_fields)>0){ + if("get_inherit" %in% clazz_fields){ + superclazz <- superclazz$get_inherit() + geometaPredicate <- FALSE + if("parent_env" %in% clazz_fields) geometaPredicate <- environmentName(superclazz$parent_env)=="geometa" + geometaObjPredicate <- superclazz$classname == classname && geometaPredicate + }else{ + break + } + } + } + return(geometaObjPredicate) + })] + + list_of_classes <- as.vector(list_of_classes) + if(pretty){ + std_infos <- do.call("rbind",lapply(list_of_classes, function(x){ + clazz <- try(eval(parse(text=x)),silent=TRUE) + if(is(clazz,"try-error")) clazz <- try(eval(parse(text=paste0("geometa::",x))),silent=TRUE) + print(clazz) + std_info <- data.frame( + environment = environmentName(clazz$parent_env), + ns_prefix = if(!is.null(clazz$private_fields$xmlNamespacePrefix))clazz$private_fields$xmlNamespacePrefix else NA, + ns_uri = if(!is.null(clazz$private_fields$xmlNamespacePrefix)) ISOMetadataNamespace[[clazz$private_fields$xmlNamespacePrefix]]$uri else NA, + element = if(!is.null(clazz$private_fields$xmlElement)) clazz$private_fields$xmlElement else NA, + stringsAsFactors = FALSE + ) + + return(std_info) + })) + + list_of_classes <- cbind( + class = list_of_classes, + std_infos, + stringsAsFactors = FALSE + ) + } + return(list_of_classes) +} + #' @name cacheISOClasses #' @aliases cacheISOClasses #' @title cacheISOClasses @@ -1571,7 +1645,7 @@ ISOAbstractObject$compare = function(metadataElement1, metadataElement2){ #' @author Emmanuel Blondel, \email{emmanuel.blondel1@@gmail.com} # cacheISOClasses <- function(){ - .geometa.iso$classes <- ISOAbstractObject$getISOClasses(extended = TRUE, pretty = FALSE) + .geometa.iso$classes <- getClassesInheriting(classname = "ISOAbstractObject", extended = TRUE, pretty = FALSE) } #' @name getISOClasses diff --git a/man/getClassesInheriting.Rd b/man/getClassesInheriting.Rd new file mode 100644 index 00000000..d03497db --- /dev/null +++ b/man/getClassesInheriting.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ISOAbstractObject.R +\name{getClassesInheriting} +\alias{getClassesInheriting} +\title{getClassesInheriting} +\usage{ +getClassesInheriting(classname, extended, pretty) +} +\arguments{ +\item{classname}{the name of the superclass for which inheriting sub-classes have to be listed} + +\item{extended}{whether we want to look at user namespace for third-party sub-classes} + +\item{pretty}{prettify the output as \code{data.frame}} +} +\description{ +get the list of classes inheriting a given super class provided by its name +} +\examples{ + getClassesInheriting("ISAbstractObject") +}