R/standardization.R

In SWS-Methodology/faoswsAupus: Package to perform the AUPUS calculation.

##' Standardization
##'
##' Standardization is simply a weighted aggregation, but with
##' multiple hierachical levels.  This function contains the logic for
##' iterating over the different hierarchical levels, but it passes the
##' actual computation of the aggregations on to the standardizeNode
##' function.
##'
##' @param graph The igraph object containing the node and edge information,
##' typically as generated by suaToNetworkRepresentation.
##' @param standardizeElement A character vector of the column names of the
##' node object that should be processed.  This should correspond to the
##' elements of the FBS that need to be standardized.
##' @param plot Whether the network should be plotted as it is processed.  
##' Several plots will be generated with prompts between, so only use this
##' option if running this function in interactive mode.
##' @param aupusParam A list of running parameters to be used in pulling the
##' data. Typically, this is generated from getAupusParameter (see that
##' function for a description of the required elements).
##' @param productionElement The column name of the production element in the
##'   nodes of the graph.  Important if standardizeProduction = FALSE.
##' @param ... Additional arguments to be passed to the plotting function.
##' 
##' @return A data.table object with one column for the item key and one
##' column for each element of standardizeElement (containing the value
##' after standardization has been performed).
##' 
##' @export
##' 

standardization = function(graph, standardizeElement, plot, aupusParam,
                           productionElement = paste0(aupusParam$keyNames$valuePrefix,
                                                      aupusParam$keyNames$elementName,
                                                      "_51"), ...){
    ## Set up an object to hold the standardized values as they are processed.
    intermediateStandardization = NULL
    edgeDT = data.table(get.data.frame(graph)[, 1:2])
    processingLevelData = findProcessingLevel(edgeDT, from = "from", to = "to",
                                              aupusParam = aupusParam)
    totalLevels = max(processingLevelData$processingLevel) + 1
    
    ## totalLevels - 2 because we don't want to process the final level and
    ## because the first level starts at 0.
    for(level in 0:(totalLevels - 2)){
        ## Which nodes currently have no inputs but do have outputs?
        workingNode = processingLevelData[processingLevel == level,
                                          measuredItemFS]
        if(plot){
            pathDistance = shortest.paths(graph, mode = "in")
            maxDistance = max(pathDistance[pathDistance < Inf])
            childNode = degree(graph, mode = "in") == 0 &
                        degree(graph, mode = "out") > 0
            emptyNode = get.vertex.attribute(graph,
                            names(vertex.attributes(graph))[2])
            emptyNode = is.na(emptyNode) | emptyNode == 0
            V(graph)$color = ifelse(childNode, 3, ifelse(emptyNode, 0,
                                                         "orange"))
            subGraph = graph - vertices(emptyNode)
            
            ## Update plotting arguments
            suppliedArgs = list(...)
            if(!"vertex.size" %in% names(suppliedArgs))
                suppliedArgs[["vertex.size"]] = 3
            if(!"edge.arrow.size" %in% names(suppliedArgs))
                suppliedArgs[["edge.arrow.size"]] = .1
            if(!"vertex.label.cex" %in% names(suppliedArgs))
                suppliedArgs[["vertex.label.cex"]] = .5
            suppliedArgs[["x"]] = subGraph

            do.call(plot.igraph, suppliedArgs)
            legend(x = 1, y = -1, col = c(3, 0, "orange"),
                   legend = c("Processing", "Empty", "Parent/Finished"),
                   pch = 16, border = 1)
            readline("Continue processing?")
        }
        standardizedObject = standardizeNode(graph = graph,
                                             workingNode = workingNode,
                                             standardizeElement = standardizeElement,
                                             productionElement = productionElement)
        graph = standardizedObject$standardizedGraph
        intermediateStandardization = rbind(intermediateStandardization, 
            standardizedObject$intermediateValues)
    }
    terminalValueMatrix =
        do.call("cbind", lapply(X = standardizeElement,
                                FUN = function(x){
                                    get.vertex.attribute(graph = graph,
                                                         name = x)
                             }))
    terminalValueMatrix = data.frame(terminalValueMatrix)
    colnames(terminalValueMatrix) = standardizeElement
    terminalValueMatrix$measuredItem = V(graph)$name

    fullStandardization =
        rbind(terminalValueMatrix,
              intermediateStandardization)
    fullStandardization = data.table(fullStandardization)
    setcolorder(fullStandardization, neworder = c("measuredItem",
                                                  standardizeElement))
    setnames(fullStandardization, old = "measuredItem",
             new = aupusParam$keyNames$itemName)
    fullStandardization
}