Fixes issue #27 and adds tests

gvegayon · Nov 10, 2016 · 56b3fd1 · 56b3fd1
1 parent 4871de3
commit 56b3fd1
Show file tree

Hide file tree

Showing 27 changed files with 209 additions and 151 deletions.
diff --git a/.Rbuildignore b/.Rbuildignore
@@ -17,3 +17,4 @@ demo/gexfplot\.R
 ^README-.*\.png$
 ^\.travis\.yml$
 ^appveyor\.yml$
+^codecov\.yml$
diff --git a/ChangeLog b/ChangeLog
@@ -1,3 +1,9 @@
+2016-11-10  George G. Vega Yon <[email protected]>
+	* R/bugs.r: Creating a more generic method for checking viz attrs.
+	* R/rgexf.r: Started moving from write.gexf to gexf. In the 2.0
+	  version write.gexf should be for exporting gexf graphs only.
+	* demo/*.R: Replaced write.gexf with gexf.
+
 2016-11-09  George G. Vega Yon <[email protected]>
 	* Added ChangeLog
 	* Change Depends to Imports and added namespace calls

diff --git a/DESCRIPTION b/DESCRIPTION
@@ -26,5 +26,7 @@ License: MIT + file LICENSE
 LazyLoad: yes
 RoxygenNote: 5.0.1
 Suggests: knitr,
-    rmarkdown
+    rmarkdown,
+    testthat,
+    covr
 VignetteBuilder: knitr
diff --git a/NAMESPACE b/NAMESPACE
@@ -10,6 +10,7 @@ export(add.node.spell)
 export(check.dpl.edges)
 export(checkTimes)
 export(edge.list)
+export(gexf)
 export(gexf.to.igraph)
 export(igraph.to.gexf)
 export(new.gexf.graph)

diff --git a/R/bugs.r b/R/bugs.r
@@ -48,58 +48,49 @@ checkTimes <- function(x, format='date') {
 #checkTimes(test, format='dateTime')
 #checkTimes('2012-02-01T00:00:00', 'dateTime')
 
-.parseNodesVizAtt <- function(nodesVizAtt, nodes) {
-################################################################################
-# Parses nodes viz attributes checking dimentions, classes and names
-################################################################################
-  if (any(lapply(nodesVizAtt, length) > 0)) {
-    supportedNodesVizAtt <- c("color", "position", "size", "shape", "image")
-    if (all(names(nodesVizAtt) %in% supportedNodesVizAtt)) {
-      if (all(lapply(nodesVizAtt, NROW) == NROW(nodes))) {
-        return(length(nodesVizAtt))
-      }
-      else {
-        nodesVizAtt <- lapply(nodesVizAtt, NROW)
-        nodesVizAtt <- nodesVizAtt[nodesVizAtt != NROW(nodes)]
-        stop("Insuficient number of \"nodeVizAtt\" rows: The atts ",
-             paste(names(nodesVizAtt), unlist(nodesVizAtt), sep=" (", collapse=" rows), "),")\n",
-             "Every att should have the same number of rows than nodes there are (",NROW(nodes),")")
-      }
-    }
-    else {
-      noviz <- names(nodesVizAtt)
-      noviz <- noviz[!(noviz %in% supportedNodesVizAtt)]
-      stop("Invalid \"nodeVizAtt\": ",noviz,"\nOnly \"color\", \"position\", \"size\", \"shape\" and \"image\" are supported")
-    }
-  }
-  else return(0)
-}
+vizAttsSpecs <- list(
+  color = function(x) {
+    if (is.vector(x) || ncol(x) == 1) {
+      warning("Trying to coerce colors into RGBA")
+      return( cbind(t(col2rgb(x)), 1) )
+    } else if (ncol(x) != 4) # Must be 4-columns
+      stop("the color attribute must have 4 columns (RGBA).")
+
+    # Must have the right range
+    if (max(x[,-4]) > 255 || min(x[,-4]) < 0) 
+      stop("The RGB colors must be in the range [0,255].")
+
+    if (max(x[,4]) > 1 | min(x[,4]) < 0)
+      stop("The alpha part of the colors (4th column) must be within [0,1].")
+
+    return(x)
+
+  },
+  position = function(x) x,
+  size = function(x) x, 
+  shape = function(x) x,
+  image = function(x) x
+)
 
-.parseEdgesVizAtt <- function(edgesVizAtt, edges) {
-################################################################################
-# Parses edges viz attributes checking dimentions, classes and names
-################################################################################
-  if (any(lapply(edgesVizAtt, length) > 0)) {
-    supportedEdgeVizAtt <- c("color", "size", "shape")
-    if (all(names(edgesVizAtt) %in% supportedEdgeVizAtt)) {
-      if (all(lapply(edgesVizAtt, NROW) == NROW(edges))) {
-        return(length(edgesVizAtt))
-      }
-      else {
-        edgesVizAtt <- lapply(edgesVizAtt, NROW)
-        edgesVizAtt <- edgesVizAtt[edgesVizAtt != NROW(edges)]
-        stop("Insuficient number of \"edgeVizAtt\" rows: The atts ",
-             paste(names(edgesVizAtt), unlist(edgesVizAtt), sep=" (", collapse=" rows), "),")\n",
-             "Every att should have the same number of rows than edges there are (",NROW(edges),")")
-      }
-    }
-    else {
-      noviz <- names(edgesVizAtt)
-      noviz <- noviz[!(noviz %in% supportedEdgeVizAtt)]
-      stop("Invalid \"edgesVizAtt\": ",noviz,"\nOnly \"color\", \"size\" and \"shape\" are supported")
-    }
-  }
-  else return(0)
+parseVizAtt <- function(att, dat, n, type=c("nodes", "edges")) {
+  # Generic checks
+  if (is.vector(dat)) {
+    if (length(dat) < n)
+      stop("The attribute -",att,"- has incorrect length (has ",length(dat),
+           ", and must have ",n,").")
+  } else if (inherits(dat, c("data.frame", "matrix"))) {
+    if (nrow(dat) != n)
+      stop("The attribute -",att,"- has incorrect number of rows (has ",
+           nrow(dat)," and it must have ",n,").")
+  } else stop("The attribute -",att,"- of class -",class(dat),"- is not supported.")
+
+  # What list of attrs
+  checks <- if (type=="nodes") c("color", "position", "size", "shape", "image")
+  else if (type=="edges") c("color", "size", "shape")
+
+  if (att %in% checks) vizAttsSpecs[[att]](dat)
+  else stop("The attribute -", att,"- is not supported for -", type,"-. Only '",
+            paste(checks, collapse="', '"), " are currently supported.") 
 }
 
 .parseEdgesWeight <- function(edgesWeight, edges) {

diff --git a/R/rgexf-package.r b/R/rgexf-package.r
@@ -108,7 +108,7 @@ NULL
 #'                         target=c(4,2,3,3,4,2,4,1,1))
 #'     
 #'     # Building gexf graph
-#'     mygraph <- write.gexf(nodes=people, edges=relations)
+#'     mygraph <- gexf(nodes=people, edges=relations)
 #'     
 #'     # Summary and pring
 #'     summary(mygraph)
@@ -148,7 +148,7 @@ NULL
 #' 
 #' 
 #' @name rgexf-package
-#' @aliases rgexf-package rgexf gexf gephi
+#' @aliases rgexf-package rgexf gephi
 #' @docType package
 #' @note See the GEXF primer for details on the GEXF graph format:
 #' \url{https://gephi.org/gexf/1.2draft/gexf-12draft-primer.pdf}

diff --git a/R/rgexf.r b/R/rgexf.r
@@ -29,26 +29,23 @@ edge.list <- function(x) {
 # Translate a edgelist to two objects list (nodes + edges)
 ################################################################################
   objClass <- class(x)
-  nEdges <- NROW(x)
-  nCols <- NCOL(x) == 2
+  k        <- ncol(x) == 2
 
-  if (objClass %in% c("matrix", "data.frame")) {
+  if (any(c("matrix", "data.frame") %in% objClass)) {
 
-    if (nCols) {
+    if (k == 2) {
       # If it is not a factor
       if (!is.factor(x)) x <- factor(c(x[,1], x[,2]))
       edges <- matrix(unclass(x), byrow=FALSE, ncol=2)
       colnames(edges) <- c("source","target")
-      nodes <- data.frame(id=1:nlevels(x), label=levels(x), stringsAsFactors=F)
+      nodes <- data.frame(id=1:nlevels(x), label=levels(x), stringsAsFactors=FALSE)
 
-      edgelist <- list(nodes=nodes, edges=edges)
-
-      return(edgelist)
+      return(list(nodes=nodes, edges=edges))
     }
-    else stop("Insuficcient number of columns (", nCols,")")
+    else stop("Insufficient number of columns (", k,")")
   }
-  else stop(objClass, 
-                  " class not allowed, try with a \"matrix\" or a \"data.frame\"")
+  else stop("-", objClass, 
+                  "- class not supported, try with a \"matrix\" or a \"data.frame\"")
 }
 
 .defAtt <- function(x, parent) {
@@ -71,7 +68,7 @@ edge.list <- function(x) {
     )
 
   for (i in attvec) 
-    tmpdoc <- c(tmpdoc, .writeXMLLine("attvalue", tmpatt[i, ]) , sep="") 
+    tmpdoc <- c(tmpdoc, .writeXMLLine("attvalue", tmpatt[i,,drop=FALSE ]) , sep="") 
 
   paste(c("<attvalues>", tmpdoc, "</attvalues>"), sep="", collapse="")
 }
@@ -151,7 +148,7 @@ edge.list <- function(x) {
   # Loop if there are not any attributes
   if (!attributes && !vizattributes) {
     for (i in vec) {
-      XML::parseXMLAndAdd(.writeXMLLine(type, datasetnoatt[i,]),parent=PAR)
+      XML::parseXMLAndAdd(.writeXMLLine(type, datasetnoatt[i,,drop=FALSE]),parent=PAR)
     }
     return(NULL)
   }
@@ -162,7 +159,7 @@ edge.list <- function(x) {
     for (i in vec) {      
       # Adding directly
       XML::parseXMLAndAdd(
-        paste(.writeXMLLine(type, datasetnoatt[i,], finalizer=FALSE), 
+        paste(.writeXMLLine(type, datasetnoatt[i,,drop=FALSE], finalizer=FALSE), 
               .addAtts(att[i,], attvec), # Builds atts definition
               "</",type,">",sep=""),
         parent=PAR)
@@ -175,20 +172,20 @@ edge.list <- function(x) {
     # Node/Edge + Atts 
     if (attributes) {
       tempnode0 <- paste(
-        .writeXMLLine(type, datasetnoatt[i,], finalizer=FALSE),
+        .writeXMLLine(type, datasetnoatt[i,,drop=FALSE], finalizer=FALSE),
         .addAtts(att[i,], attvec), sep="")
     }
-    else tempnode0 <- .writeXMLLine(type, datasetnoatt[i,], finalizer=FALSE)
+    else tempnode0 <- .writeXMLLine(type, datasetnoatt[i,,drop=FALSE], finalizer=FALSE)
 
     # Viz Att printing
     # Colors
     if (vizcolors) {
-      tempnode0 <- paste(tempnode0, .writeXMLLine("color", vizcol.df[i,]),
+      tempnode0 <- paste(tempnode0, .writeXMLLine("color", vizcol.df[i,,drop=FALSE]),
                          sep="")
     }
     # Position
     if (vizposition) {
-      tempnode0 <- paste(tempnode0, .writeXMLLine("position", vizpos.df[i,]),
+      tempnode0 <- paste(tempnode0, .writeXMLLine("position", vizpos.df[i,,drop=FALSE]),
                          sep="")
     }
     # Size
@@ -203,7 +200,7 @@ edge.list <- function(x) {
     }
     # Image
     if (vizimage) {
-      tempnode0 <- paste(tempnode0, .writeXMLLine("shape", vizimg.df[i,]),
+      tempnode0 <- paste(tempnode0, .writeXMLLine("shape", vizimg.df[i,,drop=FALSE]),
                          sep="")
     }
     XML::parseXMLAndAdd(sprintf("%s</%s>",tempnode0, type), parent=PAR)
@@ -213,12 +210,13 @@ edge.list <- function(x) {
 
 
 
-#' Builds a graph of \code{gexf} class
+#' Creates an object of class \code{gexf}
 #' 
-#' \code{write.gexf} takes a \code{node} matrix (or dataframe) and an
+#' Takes a \code{node} matrix (or dataframe) and an
 #' \code{edge} matrix (or dataframe) and creates a \code{gexf} object
 #' containing a data-frame representation and a gexf representation of a graph.
 #' 
+#' @details
 #' Just like \code{nodesVizAtt} and \code{edgesVizAtt}, \code{nodesAtt} and
 #' \code{edgesAtt} must have the same number of rows as nodes and edges,
 #' respectively. Using data frames is necessary as in this way data types are
@@ -286,6 +284,7 @@ edge.list <- function(x) {
 #' @param encoding Encoding of the graph.
 #' @param vers Character scalar. Version of the GEXF format to generate.
 #' By default \code{"1.3"}.
+#' @param ... Passed to \code{gexf}.
 #' @return A \code{gexf} class object (list). Contains the following: \itemize{
 #' \item \code{meta} : (list) Meta data describing the graph.  \item
 #' \code{mode} : (list) Sets the default edge type and the graph mode.  \item
@@ -317,8 +316,12 @@ edge.list <- function(x) {
 #'   demo(gexfbuildfromscratch) # Example building a net from scratch.
 #'   }
 #' 
+#' @name gexf-class
+NULL
+
 #' @export
-write.gexf <- function(
+#' @rdname gexf-class
+gexf <- function(
   ################################################################################  
   # Prints the gexf file
   ################################################################################
@@ -346,21 +349,23 @@ write.gexf <- function(
   ##############################################################################
   # CLASS CHECKS AND OTHERS CHECKS
 
-  # version
-  vers <- gexf_version(vers)
-
   # Nodes
-  if (is.data.frame(nodes) | is.matrix(nodes)) {
+  if (inherits(nodes, c("data.frame", "matrix"))) {
     if (NCOL(nodes) != 2) stop("-nodes- should have two columns not ", NCOL(nodes))
   }
   else stop("Invalid object type: -nodes- should be a two column data.frame or a matrix")
 
   # Edges
-  if (is.data.frame(edges) | is.matrix(edges)) {
+  if (inherits(edges, c("data.frame", "matrix"))) {
     if (NCOL(edges) != 2) stop("-edges- should have two columns not ", NCOL(edges))
   }
   else stop("Invalid object type: -edges- should be a two column data.frame or a matrix")
 
+  # version
+  vers <- gexf_version(vers)
+  n <- nrow(nodes)
+  m <- nrow(edges)
+
   # Edges Label
   .parseEdgesLabel(edgesLabel, edges)
 
@@ -374,13 +379,24 @@ write.gexf <- function(
   .parseEdgesWeight(edgesWeight, edges)
 
   # Parsing edges Viz Att
-  nEdgesVizAtt <- .parseEdgesVizAtt(edgesVizAtt, edges)
+  edgesVizAtt  <- if (length(unlist(edgesVizAtt))) {
+    Map(function(a, b) parseVizAtt(a, b, m, "edges"), a=names(edgesVizAtt),
+        b=edgesVizAtt)
+  } else NULL
+
+  nEdgesVizAtt <- length(edgesVizAtt)
+  # nEdgesVizAtt <- .parseEdgesVizAtt(edgesVizAtt, edges)
 
   # Nodes Att
   nNodesAtt <- .parseNodesAtt(nodesAtt, nodes)
 
   # Parsing nodes Viz Atts
-  nNodesVizAtt <- .parseNodesVizAtt(nodesVizAtt, nodes)
+  nodesVizAtt  <- if (length(unlist(nodesVizAtt))) {
+    Map(function(a, b) parseVizAtt(a, b, n, "nodes"), a=names(nodesVizAtt),
+                        b=nodesVizAtt)
+  } else NULL
+
+  nNodesVizAtt <- length(nodesVizAtt)
 
   # Checking the number of digits
   if (!is.integer(digits)) stop("Invalid number of digits ",digits,
@@ -393,14 +409,16 @@ write.gexf <- function(
   if (length(nodeDynamic) > 0) {
     if (is.data.frame(nodeDynamic) | is.matrix(nodeDynamic)) {
       if (NROW(nodeDynamic) == NROW(nodes)) dynamic[1] <- TRUE
-      else stop("Insuficient number of rows: -nodeDynamic- (",NROW(nodeDynamic), " rows) should have the same number of rows than nodes there are (", NROW(nodes),")")
+      else stop("Insufficient number of rows: -nodeDynamic- (",NROW(nodeDynamic), 
+                " rows) should have the same number of rows than nodes there are (",
+                NROW(nodes),")")
     } else stop("Invalid object type: -nodeDynamic- should be a two columns data.frame or a matrix")
   }
 
   if (length(edgeDynamic) > 0) {
     if (is.data.frame(edgeDynamic) | is.matrix(edgeDynamic)) {
       if (NROW(edgeDynamic) == NROW(edges)) dynamic[2] <- TRUE
-      else stop("Insuficient number of rows: -edgeDynamic- (",NROW(edgeDynamic), " rows) should have the same number of rows than edges there are (", NROW(edges),")")
+      else stop("Insufficient number of rows: -edgeDynamic- (",NROW(edgeDynamic), " rows) should have the same number of rows than edges there are (", NROW(edges),")")
     } else stop("Invalid object type: -edgeDynamic- should be a two columns data.frame or a matrix")
   }
 
@@ -702,8 +720,8 @@ write.gexf <- function(
     atts.definitions=list(nodes = nodesAttDf, edges = edgesAttDf),
     nodesVizAtt=nodesVizAtt,
     edgesVizAtt=edgesVizAtt,
-    nodes=nodes,
-    edges=cbind(edges,edgesLabel),
+    nodes=as.data.frame(nodes),
+    edges=as.data.frame(cbind(edges,edgesLabel)),
     graph=XML::saveXML(xmlFile, encoding=encoding)
     )
 
@@ -723,3 +741,12 @@ write.gexf <- function(
     print(results, file=output, replace=TRUE)
   }
 }
+
+
+#' @export
+#' @rdname gexf-class
+write.gexf <- function(...) {
+  warning("In future versions, rgexf 2.0, this function will be",
+          " the equivalent of -print(..., file=)-, and replaced by -gexf-")
+  gexf(...)
+}