R/Utils-general.R

Defines functions .createCyVpPorD .mergeAttributesAspect .createAttributeAspect .mergeIdAspect .inferIsList .inferDataType .log .aspectClass .formatO .formatLog .formatData .formatParams .formatComma .formatQuote .pasteC

Documented in .aspectClass .createAttributeAspect .createCyVpPorD .formatComma .formatData .formatLog .formatO .formatParams .formatQuote .inferDataType .inferIsList .log .mergeAttributesAspect .mergeIdAspect .pasteC

################################################################################
## Authors:
##   Florian Auer
##
## Description:
##    Base functions to create, parse, modify CX networks from/to JSON data
################################################################################

#' Concatenate as comma separated character vector
#'
#' @note Internal function only for convenience
#' @keywords internal
#' 
#' @param x character vector.
#'
#' @return character vector of length 1.
#' 
#' @examples
#' \dontrun{
#' a <- c("one", "two", "three")
#' .pasteC(a)
#' #[1] "one, two, three"
#' }
.pasteC = function(x){
    return(paste0(x,collapse = ", "))
}


#' Format objects for error logging
#' 
#' @note Internal function only for convenience
#' @keywords internal
#'
#' @param v character vector; just some strings
#' @param fname character; function name
#' @param .log character; previous called functions
#'
#' @return character
#' 
#' @name .format
#' @examples
#' \dontrun{
#' v <- c("one", "two", "three")
#' fname <- "foo"
#' .log <- c("foo1", "foo2", "foo3")
#' 
#' .formatQuote(v)
#' #[1] "\"one\""   "\"two\""   "\"three\""
#' 
#' .formatComma(v)
#' #[1] "one, two, three"
#' 
#' .formatParams(v)
#' #[1] "\"one\", \"two\" and \"three\""
#' 
#' .formatData(v)
#' #[1] "one$two$three"
#' 
#' .formatLog(v)
#' #[1] "\"one\", \"two\" and \"three\""
#' 
#' .formatLog(v, fname)
#' #[1] "\"one\", \"two\" and \"three\" (in foo)"
#' 
#' .formatO(.formatLog(v), fname)
#' #[1] "\"\"one\", \"two\" and \"three\"\" (foo)"
#' }
NULL

#' @describeIn dot-format add quotes to the vector elements: `"<v[i]>"`
.formatQuote = function(v){
    return(paste0('"',v,'"'))
}

#' @describeIn dot-format add commas between the vector elements: `<v[1]>, <v[2]>, <v[3]>`
.formatComma = function(v){
    return(paste0(v,collapse = ", "))
}

#' @describeIn dot-format format the vector: `"<v[1]>", "<v[2]>" and "<v[3]>"`
.formatParams = function(v, con="and"){
    # add quotes
    v = paste0('"',v,'"')
    # add commas and "and" inbetween
    if(length(v)>1){
        first = v[seq_len(length(v)-1)]
        last = v[length(v)]
        first = .formatComma(first)
        v = paste0(first," ",con," ", last)
    }
    return(v)
}

#' @describeIn dot-format format the vector: `<v[1]>$<v[2]>$<v[3]>`
.formatData = function(v){
    v = paste(v, collapse = "$")
    return(v)
}

#' @describeIn dot-format format the vector: `"<v[1]>", "<v[2]>" and "<v[3]>" (in <fname>)`
.formatLog = function(v,fname=c()){
    v = .formatParams(v)
    if(length(fname)!=0) fname = paste0(" (in ",fname,")")
    v = paste0(v, fname)
    return(v)
}

#' @describeIn dot-format format a object name with its calling function
.formatO = function(v,fname){
    return(paste0('"',v,'" (',fname,')'))
}


#' Add or remove a class name from an object
#' @note Internal function only for convenience
#' @keywords internal
#' 
#' @param x an R object.
#' @param value character vector of lenght 1.
#'
#' @return an R object.
#' 
#' @name .modClass
#' @examples 
#' x = list(a="foo", b="bar")
#' class(x)
#' # [1] "list"
#' \dontrun{
#' .addClass(x) <- "blubb"
#' class(x)
#' # [1] "blubb" "list" 
#' 
#' .addClass(x) <- "blubb"
#' class(x)
#' # [1] "blubb" "list" 
#' 
#' .removeClass(x) <- "blubb"
#' class(x)
#' # [1] "list"
#' }
NULL

#' @rdname dot-modClass 
#' @usage .addClass(x) <- value
#' @aliases .addClass
'.addClass<-' = function(x, value){
    if(! value %in% class(x)) class(x) = c(value, class(x))
    return(x)
}

#' @rdname dot-modClass
#' @usage .removeClass(x) <- value
#' @aliases .removeClass
'.removeClass<-' = function(x, value){
    class(x)=class(x)[! class(x) %in% value]
    return(x)
}


#' Get the class of aspects
#' @note Internal function only for convenience
#' @keywords internal
#' 
#' Only get the class of aspects that are defined in `aspectClasses`
#' 
#' @param x a potential aspect
#'
#' @return The aspect class name or `NA` if it's not an aspect
#'
#' @examples
#' x = list(a="foo", b="bar")
#' class(x)
#' # [1] "list"
#' \dontrun{
#' .addClass(x) <- .CLS$nodes
#' class(x)
#' # [1] "NodesAspect" "list" 
#' 
#' .aspectClass(x)
#' # [1] "NodesAspect"
#' 
#' .removeClass(x) <- "NodesAspect"
#' 
#' .aspectClass(x)
#' # [1] "NA"
#' 
#' }
.aspectClass = function(x){
    cls = NA
    if(any(class(x) %in% aspectClasses)){
        cls = class(x)[class(x) %in% aspectClasses]
    }
    return(cls)
}


#' Logging (printing) the results of test cases
#' @note Internal function only for convenience
#' @keywords internal
#'
#' @param info character; description of the test case.
#' @param pass boolean; was the test passed?
#' @param sep character (default="..."); separates description from result.
#' @param spaceLine boolean (default=FALSE); should a blank line be added after.
#' 
#' @return NULL, only prints the log
#'
#' @examples
#' testPassed <- TRUE
#' testFailed <- FALSE
#' \dontrun{
#' .log('testing something', testPassed)
#' #testing something...OK
#' .log('testing other stuff', testFailed, spaceLine=TRUE)
#' #testing other stuff...FAIL
#' #
#' .log('testing more', testPassed, " ", TRUE)
#' #testing more OK
#' }
.log = function(info, pass, sep="...", spaceLine=FALSE){
    cat(paste0(info,sep))
    if(pass){
        cat("OK\n")
    }else{
        cat("FAIL\n")
    }
    if(spaceLine) cat("\n")
    return(NULL)
}


#' Infer the data type from values and check if the value elements are a list
#' 
#' Each element has an R data type (i.e. class). If more than one element are present in one list element, it is marked as list
#' 
#' `.inferDataType` infers the data type of the elements in the vector or list.
#' `.inferIsList` infers for each element if it is a list. For a vector, the return therefore is `FALSE` for each element!
#'
#' @note Internal function only for convenience
#' @keywords internal
#'
#' @param values vector or list of R data values 
#'
#' @return character vector of data types or logical vector of list status
#' 
#' @name .infer
#'
#' @examples
#' NULL
.inferDataType = function(values){
    if(!is.list(values)) values = as.list(values)
    mapFunction = function(x){
        type = "string"
        if(is.logical(x)) type = "boolean"
        if(is.numeric(x)) type = "double"
        return(type)
    }
    return(vapply(values, mapFunction, character(1)))
}


#' @describeIn dot-infer Infer, if the values are lists
.inferIsList = function(values){
    if(!is.list(values)) values = as.list(values)
    mapFunction = function(x){
        isList = (length(x)>1)
        return(isList)
    }
    return(vapply(values, mapFunction, logical(1)))
}


#TODO: add an example from nodeAspect
#' Merge two aspects (data.frames)
#' 
#' Merges two aspects, that are both data.frames and of the same aspect class.
#' If the `idCol` contains duplicates new ids (for `secondAspect`) are created (ids of `firstAspect` are kept), 
#' unless it is spezified otherwise by `saveOldIds`.
#' 
#' @note The two aspects must be the same type of aspect (same aspect class)!
#' 
#' @note Internal function only for convenience
#' @keywords internal
#' @seealso \code{\link{.mergeAttributesAspect}}, \code{\link{.createAttributeAspect}}
#'
#' @param firstAspect data.frame; first aspect.
#' @param secondAspect data.frame; second aspect.
#' @param idCol character; name of the column to merge on.
#' @param uniqCols character; name of the column to be checked for uniqueness.
#' @param stopOnDuplicates boolean (default=FALSE); whether to stop, if duplicates in `uniqCols` column are found.
#' @param saveOldIds boolean (default=TRUE); whether to keep the IDs from `secondAspect`, if duplicates in `uniqCols` column are found.
#' @param .log character (optional); name of the calling function used in logging
#'
#' @return data.frame of the merged aspects.
#'
#' @examples
#' NULL
.mergeIdAspect = function(firstAspect, secondAspect, idCol, uniqCols, stopOnDuplicates=FALSE, saveOldIds=TRUE, .log=c()){
    newAspCls = .aspectClass(secondAspect)
    .checkClass(firstAspect, newAspCls, "aspects", .log)
    
    # ## if firstAspect has already oldId column, then keep it
    # removeOldIdCol = (! "oldId" %in% colnames(firstAspect))
    firstAspect$oldId = NA

    ## remember the ids in secondAspect
    if(saveOldIds) secondAspect$oldId = secondAspect[,idCol]

    ## fills missing columns with NAs
    mergedAsp = plyr::rbind.fill(firstAspect, secondAspect)

    ## create new ids (for secondAspect) if id already in use (in firstAspect)
    if(! .elementsUniqueDF(mergedAsp, uniqCols)){
        if(stopOnDuplicates) .stop("paramNotUnique",.formatLog(uniqCols, .log))
        firstId = maxId(firstAspect) + 1
        lastId = firstId + length(secondAspect[,idCol]) - 1
        secondAspect[,idCol] = firstId:lastId
        ## oldId column necessary for duplicated ids, so don't remove it
        removeOldIdCol = FALSE
        ## redo with new ids
        mergedAsp = plyr::rbind.fill(firstAspect, secondAspect)
    }

    if(!saveOldIds) mergedAsp$oldId = NULL

    return(mergedAsp)
}


#' Create a default *AttributeAspect
#' 
#' Some aspects like *`r .CLS$nodeAttributes`* or *`r .CLS$edgeAttributes`* use a key-value scheme. 
#' This function helps in constructing while avoiding repetition.
#' 
#' @note Internal function only for convenience
#' @keywords internal
#' @seealso \code{\link{.mergeIdAspect}}, \code{\link{.mergeAttributesAspect}}, \code{\link{CySubNetworks}}
#'
#' @param propertyOf integer; refers to the IDs of an other aspect
#' @param name character; key of the attribute
#' @param value character; value of the attribute
#' @param dataType character (optional); 
#' @param isList logical (optional); 
#' @param subnetworkId integer (optional); CySubNetworks
#'
#' @return *AttributeAspect prototype object
#'
#' @examples
#' NULL
.createAttributeAspect = function(propertyOf, name, value, dataType, isList, subnetworkId=NULL, .log=""){
    if(missing(propertyOf) || missing(name) || missing(value)) .stop("paramMissing", "propertyOf, name and value are required!")
    
    ## value can be string or a list of strings
    if(!is.list(value)) value = as.list(value)
    
    .checkSameLength(.log,
                     propertyOf, name, value, dataType, isList, subnetworkId)
    
    .checkIsId(propertyOf, "propertyOf", .log)
    .checkNoNa(name, "name", .log)
    
    attributesAspect = data.frame(propertyOf=propertyOf,
                                  name=name,
                                  stringsAsFactors = FALSE,
                                  check.names = FALSE)

    ## with characters and numbers mixed
    attributesAspect$value = value
    
    if(is.null(dataType)) dataType = .inferDataType(value)
    attributesAspect$dataType = dataType
    
    if(is.null(isList)) isList = .inferIsList(value)
    attributesAspect$isList = isList
    
    if(is.null(subnetworkId)) {
        .checkUniqueDF(attributesAspect,c("propertyOf","name"), .log)
    }else{
        .checkNumeric(subnetworkId, "subnetworkId", .log)
        attributesAspect$subnetworkId = subnetworkId
        
        .checkUniqueDF(attributesAspect,c("propertyOf","name","subnetworkId"), .log)
    }
    
    return(attributesAspect)
}


#' Merge two *AttributeAspects
#'
#' Some aspects like *`r .CLS$nodeAttributes`* or *`r .CLS$edgeAttributes`* use a key-value scheme. 
#' This function helps in merging while avoiding repetition.
#' 
#' @note Internal function only for convenience
#' @keywords internal
#' @seealso \code{\link{.mergeIdAspect}}, \code{\link{.createAttributeAspect}}
#' 
#' @param firstAspect *AttributeAspect object; first aspect.
#' @param secondAspect *AttributeAspect object; second aspect.
#' @param replace logical (default: TRUE); should duplicate keys be replaced with values of the secondAspect
#' @param stopOnDuplicates logical (default: FALSE); whether to stop, if duplicate keys are found
#' @param required character (optional); names of required column names
#' @param optional character (optional); names of optional column names
#' @param .log character (optional); origin of the data used for error logging
#'
#' @return *AttributeAspect object
#'
#' @examples
#' NULL
.mergeAttributesAspect = function(firstAspect, secondAspect, 
                                  replace=TRUE, stopOnDuplicates=FALSE, 
                                  required=c("propertyOf","name"), 
                                  optional="subnetworkId",
                                  .log=c()){
    firstAspect$markObjectSource = "old"
    secondAspect$markObjectSource = "new"
    keepElements = ifelse(replace,"new","old")
    
    ## fills missing columns with NAs
    secondAspect = plyr::rbind.fill(firstAspect, secondAspect)
    
    ## if subnetworkId is in
    containOpt = optional %in% colnames(secondAspect)
    cols = c(required, optional[containOpt])
    
    if(! .elementsUniqueDF(secondAspect, cols)) {
        if(stopOnDuplicates) .checkUniqueDF(secondAspect, cols, .log)
        
        mapFunction = function(x){
            if(nrow(x)>1) x = x[x$markObjectSource==keepElements,]
            return(x)
        }
        secondAspect = plyr::ddply(secondAspect,
                                   cols,
                                   mapFunction)
    }
    secondAspect$markObjectSource = NULL
    
    return(secondAspect)
}


#' Helper to create structure for classes `r .CLSvp$properties` and `r .CLSvp$dependencies`
#' 
#' @note Internal function only for convenience
#' @keywords internal
#'
#' @param name character, optional; name of the properties
#' @param value character or named character; value of the properties
#' @param .log character (optional); name of the calling function used in logging
#'
#' @return data.frame
#' @seealso Used in \code{\link{CyVisualPropertyProperties}}, \code{\link{CyVisualPropertyDependencies}} and \code{\link{CyVisualPropertyMappings}}
#'
#' @examples
#' \dontrun{
#' data1 = c(NODE_BORDER_STROKE="SOLID", NODE_BORDER_WIDTH="1.5")
#' .createCyVpPorD(value=data1)
#' 
#' key1 = c("NODE_BORDER_STROKE", "NODE_BORDER_WIDTH")
#' value1 = c("SOLID", "1.5")
#' .createCyVpPorD(key1, value1)
#' 
#' # Result for either:
#' #                 name value
#' # 1 NODE_BORDER_STROKE SOLID
#' # 2  NODE_BORDER_WIDTH   1.5
#' }
.createCyVpPorD = function(name=NULL, value, .log=""){
    if(missing(value) || is.null(value)) .stop("paramMissing", "value is required!")
    if(is.null(name)) {
        if(is.null(names(value))) .stop("paramMissing", "value with names is required!")
        name = names(value)
    }
    value = unname(value)
    
    .checkCharacter(name, "name", .log)
    .checkCharacter(value, "value", .log)
    
    pod  = data.frame(name=name,
                      value=value,
                      stringsAsFactors = FALSE,
                      check.names = FALSE)
    
    idCols = "name"
    .checkUniqueDF(pod, idCols, .log)
    
    return(pod)
}
frankkramer-lab/RCX documentation built on Feb. 4, 2023, 5:12 p.m.