R/gspace-validation.R

In RGraphSpace: A Lightweight Interface Between 'igraph' and 'ggplot2' Graphics

################################################################################
### Validate igraph for RGraphSpace
################################################################################
.validate_igraph <- function(g, layout = NULL, verbose = FALSE) {
    if (verbose) message("Validating the 'igraph' object...")
    if (!inherits(g, "igraph")) {
        stop("'g' should be an 'igraph' object.", call. = FALSE)
    }
    if (inherits(g, "tbl_graph")) {
        g <- tidygraph::as.igraph(g)
    }
    if (!is.null(layout)) {
        if (nrow(layout) != vcount(g)) {
            msg <- paste("'layout' must have xy-coordinates",
                "for the exact number of nodes in 'g'")
            stop(msg, call. = FALSE)
        } else {
            igraph::V(g)$x <- layout[, 1]
            igraph::V(g)$y <- layout[, 2]
        }
    } else if (is.null(igraph::V(g)$x) || is.null(igraph::V(g)$y)) {
        layout <- igraph::layout_nicely(g)
        igraph::V(g)$x <- layout[, 1]
        igraph::V(g)$y <- layout[, 2]
        msg <- paste0("Vertex attributes 'x' and 'y' missing; ",
            "computing layout...")
        if (verbose) message(msg)
    }
    if (is.null(igraph::V(g)$name)) {
        msg <- "Vertex attribute 'name' missing; assigning names... "
        if (verbose) message(msg)
        igraph::V(g)$name <- paste0("n", seq_len(igraph::vcount(g)))
    } else {
        if(is.vector(igraph::V(g)$name) || !is.list(igraph::V(g)$name)){
            if(any(is.na(igraph::V(g)$name))){
                msg <- "NA values found in vertex attribute 'name'."
                stop(msg, call. = FALSE)
            }
            if(!.all_characterValues(igraph::V(g)$name)){
                warning("vertex attribute 'name' converted to character.", 
                    call. = FALSE)
                igraph::V(g)$name <- as.character(igraph::V(g)$name)
            }
        } else {
            msg <- "vertex attribute 'name' should be a character vector."
            stop(msg, call. = FALSE) 
        }
        if (anyDuplicated(igraph::V(g)$name) > 0){
            stop("vertex names must be unique.", call. = FALSE)
        }
    }
    if (!igraph::is_simple(g)) {
        if (verbose && igraph::any_loop(g)) 
            message("Removing loops...")
        if (verbose && igraph::any_multiple(g))
            message("Merging duplicated edges...")
        g <- igraph::simplify(g, remove.loops = TRUE, remove.multiple = TRUE,
          edge.attr.comb = list(weight = "max", "first"))
    }
    if (is.null(igraph::V(g)$nodeLabel)){
        igraph::V(g)$nodeLabel <- as.character(igraph::V(g)$name)
    }
    if (is.null(igraph::V(g)$nodeSize)){
        igraph::V(g)$nodeSize <- .get_default_vatt()[["nodeSize"]]
    }
    if (is.null(igraph::E(g)$arrowType)){
        if (is_directed(g)) {
            igraph::E(g)$arrowType <- 1
        } else {
            igraph::E(g)$arrowType <- 0
        }
    }
    if(verbose && any(which_mutual(g))){
        message("Mutual edges detected: Simplified for data frame...")
        message("Arrows recoded to bidirectional display")
        message("Edge attributes retained from the first occurrence")
    }
    g <- .validate_attributes(g)
    return(g)
    
}

################################################################################
### Validate graph attributes
################################################################################
.validate_attributes <- function(g){
    g <- .validate_nodes(g)
    g <- .validate_edges(g)
    g <- .validate_graph(g)
    return(g)
}

#-------------------------------------------------------------------------------
.validate_nodes <- function(g) {
    
    # get default attributes
    atts <- c(.get_required_vatt(), .get_default_vatt())
    a_names <- names(atts)
    # check default attributes
    b_names <- a_names[a_names %in% igraph::vertex_attr_names(g)]
    if(length(b_names)>0){
        if (vcount(g) > 0) {
            .validate_vatt(igraph::vertex_attr(g)[b_names])
        }
    }
    
    # put default attributes 1st
    d_names <- igraph::vertex_attr_names(g)
    a_names <- a_names[a_names %in% d_names]
    a_names <- c(a_names, d_names[ ! d_names %in% a_names ])
    igraph::vertex_attr(g) <- igraph::vertex_attr(g)[a_names]
    
    # attributes that require transformation
    g <- .validate_nodeshape(g)
    
    return(g)
}

#-------------------------------------------------------------------------------
.validate_edges <- function(g) {
    
    g <- .remove_hidden_eatt(g)
    
    # get default attributes
    atts <- .get_default_eatt(igraph::is_directed(g))
    a_names <- names(atts)
    # check default attributes
    b_names <- a_names[a_names %in% igraph::edge_attr_names(g)]
    if(length(b_names)>0){
        if (igraph::ecount(g) > 0) {
            .validate_eatt(igraph::edge_attr(g)[b_names])
        }
    }
    
    # put default attributes 1st
    d_names <- igraph::edge_attr_names(g)
    a_names <- a_names[a_names %in% d_names]
    a_names <- c(a_names, d_names[ ! d_names %in% a_names ])
    igraph::edge_attr(g) <- igraph::edge_attr(g)[a_names]
    
    # attributes that require transformation
    g <- .validate_arrowtype(g)
    g <- .validate_linetype(g)
    return(g)
}

#-------------------------------------------------------------------------------
.validate_graph <- function(g) {
    d_names <- igraph::graph_attr_names(g)
    if (length(d_names) > 0) {
        for (at in d_names) {
            g <- igraph::delete_graph_attr(g, name = at)
        }
    }
    return(g)
}

################################################################################
### Default RGraphSpace attributes
################################################################################
.get_required_vatt <- function() {
    atts <- list("x" = NA, "y" = NA, "name" = NA)
    return(atts)
}
.get_default_vatt <- function() {
    atts <- list(
        "nodeLabel" = NA, "nodeLabelSize" = 8, "nodeLabelColor" = "grey40",
        "nodeShape" = 21, "nodeSize" = 5, "nodeColor" = "grey80",
        "nodeLineWidth" = 0.5, "nodeLineColor" = "grey20")
    return(atts)
}
.get_default_eatt <- function(is.directed = FALSE) {
    atts <- list("edgeLineType" = "solid", "edgeLineColor" = "grey80",
        "edgeLineWidth" = 0.5)
    if (is.directed) {
        atts$arrowType <- 1
    } else {
        atts$arrowType <- 0
    }
    atts$weight <- 1
    return(atts)
}
# remove internally used hidden attributes
.remove_hidden_eatt <- function(g){
    atts <- names(.get_default_eatt(igraph::is_directed(g)))
    hidden <- setdiff(names(.get_empty_edgedf()), atts)
    hidden <- hidden[hidden %in% igraph::edge_attr_names(g)]
    if (length(hidden) > 0) {
        for (at in hidden) {
            g <- igraph::delete_edge_attr(g, name = at)
        }
    }
    g
}

################################################################################
### Validate attribute values
################################################################################
.validate_vatt <- function(atts) {
    if (!is.null(atts$x)) {
        .validate_gs_args("numeric_vec", "x", atts$x)
    }
    if (!is.null(atts$y)) {
        .validate_gs_args("numeric_vec", "y", atts$y)
    }
    if (!is.null(atts$name)) {
        .validate_gs_args("allCharacter", "name", atts$name)
    }
    if (!is.null(atts$nodeLabel)) {
        .validate_gs_args("allCharacterOrNa", "nodeLabel", atts$nodeLabel)
    }
    if (!is.null(atts$nodeLabelSize)) {
        .validate_gs_args("numeric_vec", "nodeLabelSize", atts$nodeLabelSize)
        if (min(atts$nodeLabelSize) <= 0) {
            stop("'nodeLabelSize' should be a vector of numeric values >0", 
              call. = FALSE)
        }
    }
    if (!is.null(atts$nodeLabelColor)) {
        .validate_gs_colors("allColors", "nodeLabelColor", atts$nodeLabelColor)
    }
    if (!is.null(atts$nodeSize)) {
        .validate_gs_args("numeric_vec", "nodeSize", atts$nodeSize)
        if (max(atts$nodeSize) > 100 || min(atts$nodeSize) < 0) {
            stop("'nodeSize' should be a vector of numeric values in [0, 100]", 
              call. = FALSE)
        }
    }
    if (!is.null(atts$nodeShape)) {
        .validate_gs_args("allCharacterOrInteger", "nodeShape", atts$nodeShape)
    }
    if (!is.null(atts$nodeColor)) {
        .validate_gs_colors("allColors", "nodeColor", atts$nodeColor)
    }
    if (!is.null(atts$nodeLineWidth)) {
        .validate_gs_args("numeric_vec", "nodeLineWidth", atts$nodeLineWidth)
        if (min(atts$nodeLineWidth) < 0) {
            stop("'nodeLineWidth' should be a vector of numeric values >=0", 
              call. = FALSE)
        }
    }
    if (!is.null(atts$nodeLineColor)) {
        .validate_gs_colors("allColors", "nodeLineColor", atts$nodeLineColor)
    }
}
#-------------------------------------------------------------------------------
.validate_eatt <- function(atts) {
    if (!is.null(atts$edgeLineType)) {
        .validate_gs_args("allCharacterOrInteger", "edgeLineType",
            atts$edgeLineType)
    }
    if (!is.null(atts$edgeLineWidth)) {
        .validate_gs_args("numeric_vec", "edgeLineWidth", atts$edgeLineWidth)
        if (min(atts$edgeLineWidth) <= 0) {
            stop("'edgeLineWidth' should be a vector of numeric values >0", 
                call. = FALSE)
        }
    }
    if (!is.null(atts$edgeLineColor)) {
        .validate_gs_colors("allColors", "edgeLineColor", atts$edgeLineColor)
    }
    if (!is.null(atts$arrowType)) {
        .validate_gs_args("allCharacterOrInteger", "arrowType", atts$arrowType)
    }
    if (!is.null(atts$weight)) {
        .validate_gs_args("numeric_vec", "weight", atts$weight)
    }
}

################################################################################
### Transform attribute types
################################################################################

#-------------------------------------------------------------------------------
.validate_nodeshape <- function(g) {
    if (vcount(g) > 0 && "nodeShape" %in% names(vertex_attr(g))) {
        V(g)$nodeShape  <- .transform_nodeshape(V(g)$nodeShape)
    }
    return(g)
}
.transform_nodeshape <- function(vshapes) {
    if (.all_integerValues(vshapes)) {
        vshapes[vshapes > 25] <- 21
        vshapes[vshapes < 0] <- 1
    } else {
        vshapes <- tolower(vshapes)
        pch <- rep(21, length(vshapes))
        pch[grep("circle", vshapes)] <- 21
        pch[grep("ellipse", vshapes)] <- 21
        pch[grep("square", vshapes)] <- 22
        pch[grep("diamond", vshapes)] <- 23
        pch[grep("triangle", vshapes)] <- 24
        pch[grep("rectangle", vshapes)] <- 22
        vshapes <- pch
    }
    return(vshapes)
}

#-------------------------------------------------------------------------------
.validate_arrowtype <- function(g) {
    if (ecount(g) > 0 && "arrowType" %in% names(edge_attr(g))) {
        E(g)$arrowType  <- .transform_arrowtype(E(g)$arrowType, is_directed(g))
    }
    return(g)
}
.transform_arrowtype <- function(eatt, is_dir = FALSE) {
        aty <- .arrowtypes(is_dir)
        if (.all_integerValues(eatt)) {
            idx <- !eatt %in% aty
            if (any(idx)) {
                eatt[idx] <- ifelse(is_dir, 1, 0)
                .arrowtypes_warning(is_dir)
            }
        } else {
            idx <- eatt %in% as.character(aty)
            if (any(idx)) {
                eatt[idx] <- names(aty)[match(eatt[idx], as.character(aty))]
            }
            idx <- !eatt %in% names(aty)
            if (any(idx)) {
                eatt[idx] <- "-->"
                .arrowtypes_warning(is_dir)
            }
            eatt <- aty[eatt]
        }
    return(eatt)
}
.arrowtypes <- function(is.dir = FALSE, unique = FALSE) {
    atp1 <- c(
        "---" = 0, "--" = 0, "-" = 0,
        "-->" = 1, "->" = 1, ">" = 1,
        "<--" = 2, "<-" = 2, "<" = 2,
        "<->" = 3, "<>" = 3,
        "|->" = 4, "|>" = 4)
    atp2 <- c(
        "--|" = -1, "-|" = -1, "|" = -1,
        "|--" = -2, "|-" = -2, "|" = -2,
        "|-|" = -3, "||" = -3,
        "<-|" = -4, "<|" = -4)
    atypes <- c(atp1, atp2)
    if (is.dir) {
        atypes <- atypes[atypes %in% c(-1, 0, 1)]
        if(unique){
            atypes <- atypes[match(unique(atypes), atypes)]
        }
    } else {
        if(unique){
            atp1 <- atp1[match(unique(atp1), atp1)]
            atp2 <- atp2[match(unique(atp2), atp2)]
            atypes <- c(atp1, atp2)
        }
    }
    return(atypes)
}
.arrowtypes_warning <- function(is.dir = FALSE){
    
    atypes <- .arrowtypes(is.dir, unique = TRUE)
    
    if (is.dir) {
        msg1 <- paste("'arrow type' for directed graphs must be one of:\n")
        msg2 <- paste(paste0("'", names(atypes), "'"), atypes, sep = " or ")
        msg2 <- paste(msg2, collapse = ", ")
    } else {
        msg1 <- paste("'arrow type' for undirected graphs must be one of:\n")
        idx <- atypes >= 0
        atp1 <- paste(paste0("'", names(atypes)[idx], "'"), atypes[idx], sep = " or ")
        atp2 <- paste(paste0("'", names(atypes)[!idx], "'"), atypes[!idx], sep = " or ")
        atp1 <- paste0(paste(atp1, collapse = ", "), "\n")
        atp2 <- paste(atp2, collapse = ", ")
        msg2 <- paste0(atp1, atp2)
    }
    msg3 <- c("\n...using default values.")
    warning(msg1, msg2, msg3, call. = FALSE)
    
}

#-------------------------------------------------------------------------------
.validate_linetype <- function(g) {
    if (ecount(g) > 0 && "edgeLineType" %in% names(edge_attr(g))) {
        E(g)$edgeLineType  <- .transform_linetype(E(g)$edgeLineType)
    }
    return(g)
}
.transform_linetype <- function(lty) {
    if (.all_integerValues(lty)) {
        ltypes <- .linetypes()
        lty[!lty %in% ltypes] <- 1
        lty <- ltypes[match(lty, ltypes)]
        lty <- names(lty)
    } else {
        lty <- tolower(lty)
        lty[grep("solid", lty)] <- "solid"
        lty[grep("dotted", lty)] <- "dotted"
        lty[grep("dashed", lty)] <- "dashed"
        lty[grep("long", lty)] <- "longdash"
        lty[grep("two", lty)] <- "twodash"
    }
    return(lty)
}
.linetypes <- function() {
    c('blank' = 0, 'solid' = 1, 'dashed' = 2, 'dotted' = 3,
        'dotdash' = 4, 'longdash' = 5, 'twodash' = 6)
}