From 05f2c9379e534589d13b677fab1d47d7a3feaec0 Mon Sep 17 00:00:00 2001 From: "Pavel N. Krivitsky" Date: Thu, 14 Nov 2024 14:13:46 +1000 Subject: [PATCH] Replaced the validLHS()-based pattern with the tryCatch()-based pattern. fixes statnet/network#88 --- DESCRIPTION | 3 +- R/access.R | 64 +++++++++++------------------------------ R/assignment.R | 63 ---------------------------------------- R/constructors.R | 16 +++-------- man/network-internal.Rd | 1 + 5 files changed, 22 insertions(+), 125 deletions(-) delete mode 100644 R/assignment.R diff --git a/DESCRIPTION b/DESCRIPTION index 2263a84..5a8ae3b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,12 +23,11 @@ Suggests: Description: Tools to create and modify network objects. The network class can represent a range of relational data types, and supports arbitrary vertex/edge/graph attributes. License: GPL (>=2) URL: https://statnet.org/ -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.2 Roxygen: list(markdown = TRUE) Collate: 'access.R' 'as.edgelist.R' - 'assignment.R' 'coercion.R' 'constructors.R' 'dataframe.R' diff --git a/R/access.R b/R/access.R index 237d805..f211d91 100644 --- a/R/access.R +++ b/R/access.R @@ -146,9 +146,7 @@ add.edge<-function(x, tail, head, names.eval=NULL, vals.eval=NULL, edge.check=FALSE, ...){ xn<-substitute(x) UseMethod("add.edge") - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) invisible(x) } @@ -156,9 +154,7 @@ add.edge<-function(x, tail, head, names.eval=NULL, vals.eval=NULL, edge.check=FA #' @export add.edge.network<-function(x, tail, head, names.eval=NULL, vals.eval=NULL, edge.check=FALSE, ...){ xn<-substitute(x) - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) x<-.Call(addEdge_R,x,tail,head,names.eval,vals.eval,edge.check) invisible(x) } @@ -170,9 +166,7 @@ add.edge.network<-function(x, tail, head, names.eval=NULL, vals.eval=NULL, edge. add.edges<-function(x, tail, head, names.eval=NULL, vals.eval=NULL, ...){ xn<-substitute(x) UseMethod("add.edges") - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) invisible(x) } @@ -204,9 +198,7 @@ add.edges.network<-function(x, tail, head, names.eval=NULL, vals.eval=NULL, ...) #Pass the inputs to the C side xn<-substitute(x) x<-.Call(addEdges_R,x,tail,head,names.eval,vals.eval,edge.check) - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) invisible(x) } @@ -281,9 +273,7 @@ add.edges.network<-function(x, tail, head, names.eval=NULL, vals.eval=NULL, ...) add.vertices<-function(x, nv, vattr=NULL, last.mode=TRUE, ...){ xn<-substitute(x) UseMethod("add.vertices") - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) invisible(x) } @@ -306,9 +296,7 @@ add.vertices.network<-function(x, nv, vattr=NULL, last.mode=TRUE, ...){ #Perform the addition xn<-substitute(x) if(nv>0){ - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) if(last.mode||(!is.bipartite(x))){ x<-.Call(addVertices_R,x,nv,vattr) }else{ @@ -495,9 +483,7 @@ delete.edge.attribute.network <- function(x, attrname, ...) { #Remove the edges xn<-substitute(x) x<-.Call(deleteEdgeAttribute_R,x,attrname) - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) invisible(x) } @@ -578,9 +564,7 @@ delete.edges.network <- function(x, eid, ...) { stop("Illegal edge in delete.edges.\n") #Remove the edges x<-.Call(deleteEdges_R,x,eid) - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) } invisible(x) } @@ -599,9 +583,7 @@ delete.network.attribute.network <- function(x, attrname, ...){ #Remove the edges xn<-substitute(x) x<-.Call(deleteNetworkAttribute_R,x,attrname) - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) invisible(x) } @@ -621,9 +603,7 @@ delete.vertex.attribute.network <- function(x, attrname, ...) { if(network.size(x)>0){ xn<-substitute(x) x<-.Call(deleteVertexAttribute_R,x,attrname) - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) } invisible(x) } @@ -650,9 +630,7 @@ delete.vertices.network <- function(x, vid, ...) { set.network.attribute(x,"bipartite",m1v-sum(vid<=m1v)) } x<-.Call(deleteVertices_R,x,vid) - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) } invisible(x) } @@ -1873,9 +1851,7 @@ permute.vertexIDs<-function(x,vids){ #Return the permuted graph xn<-substitute(x) x<-.Call(permuteVertexIDs_R,x,vids) - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) invisible(x) } @@ -1971,9 +1947,7 @@ set.edge.attribute.network <- function(x, attrname, value, e=seq_along(x$mel), . #Do the deed, call the set multiple version x<-.Call(setEdgeAttributes_R,x,attrname,value,e) } - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) } invisible(x) } @@ -2010,9 +1984,7 @@ set.edge.value.network <- function(x, attrname, value, e = seq_along(x$mel), ... #Do the deed xn<-substitute(x) x<-.Call(setEdgeValue_R,x,attrname,value,e) - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) invisible(x) } @@ -2042,9 +2014,7 @@ set.network.attribute.network <- function(x, attrname, value, ...) { #Do the deed xn<-substitute(x) x<-.Call(setNetworkAttribute_R,x,attrname,value) - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) invisible(x) } @@ -2180,8 +2150,6 @@ set.vertex.attribute.network <- function(x, attrname, value, v = seq_len(network } # end setting multiple values #Do the deed - if(.validLHS(xn,parent.frame())){ #If x not anonymous, set in calling env - on.exit(eval.parent(call('<-',xn,x))) - } + on.exit(tryCatch(eval.parent(call('<-',xn,x)),error=identity)) invisible(x) } diff --git a/R/assignment.R b/R/assignment.R deleted file mode 100644 index 4019beb..0000000 --- a/R/assignment.R +++ /dev/null @@ -1,63 +0,0 @@ -###################################################################### -# -# assignment.R -# -# Written by Carter T. Butts ; portions contributed by -# David Hunter and Mark S. Handcock -# . -# -# Last Modified 11/26/19 -# Licensed under the GNU General Public License version 2 (June, 1991) -# or greater -# -# Part of the R/network package -# -# This file contains various routines for the assignment of network objects -# into calling environments. These are internal functions and not to be used -# by the package users. -# -# Contents: -# -# .findNameInSubsetExpr -# .validLHS -# -###################################################################### - - -# Recursively traverse the parse tree of the expression x, ensuring that it is -# a valid subset expresssion, and return the name associated with the expression. -# -.findNameInSubsetExpr <- function(x){ - if (inherits(x,'call')){ - # Ensure call is a subset function, one of $, [, or [[ - if(!(deparse(x[[1]]) %in% c('$','[','[['))) return(NA) - - # Make sure arguments are clean - xns <- lapply(x[2:length(x)],.findNameInSubsetExpr) - if (any(is.na(xns))) return(NA) - - # Possible name found - return(xns[[1]]) - } - else if (inherits(x,'name')) - return(deparse(x)) - - NULL -} - -# Return TRUE if x is a valid left-hand-side object that can take a value - -.validLHS <- function(x,ev){ - xn <- .findNameInSubsetExpr(x) - # There are valid expressions for which we don't want to assign into the caller's env. - # For instance, when a user executes z<-add.edges(x+y), then the user obviously - # doesn't want x+y to be assigned. Rather he's using them as temporaries to obtain - # z. OTOH we don't want someone doing something obtuse like add.edges(x[sample(...)]) - # In the first case, it's not wrong to end up here, but in the second case we would - # like to warn the user. But we're not going to at this point. - #warning('Cannot make assignment into ',deparse(x)) - if (!is.null(xn) && !is.na(xn) && exists(xn,envir=ev)) - return(TRUE) - else - return(FALSE) -} diff --git a/R/constructors.R b/R/constructors.R index a633d1f..3a8f8d2 100644 --- a/R/constructors.R +++ b/R/constructors.R @@ -203,9 +203,7 @@ network.bipartite<-function(x, g, ignore.eval=TRUE, names.eval=NULL, ...){ add.edges(g, as.list(1+e%%n), as.list(1+e%/%n), names.eval=en, vals.eval=ev, ...) #Patch up g on exit for in-place modification - if(.validLHS(gn,parent.frame())){ - on.exit(eval.parent(call('<-',gn,g))) - } + on.exit(tryCatch(eval.parent(call('<-',gn,g)),error=identity)) invisible(g) } @@ -276,9 +274,7 @@ network.adjacency<-function(x, g, ignore.eval=TRUE, names.eval=NULL, ...){ add.edges(g, as.list(1+e%%n), as.list(1+e%/%n), names.eval=en, vals.eval=ev, ...) #Patch up g on exit for in-place modification - if(.validLHS(gn,parent.frame())){ - on.exit(eval.parent(call('<-',gn,g))) - } + on.exit(tryCatch(eval.parent(call('<-',gn,g)),error=identity)) invisible(g) } @@ -342,9 +338,7 @@ network.edgelist<-function(x, g, ignore.eval=TRUE, names.eval=NULL, ...){ g<-add.edges(g,as.list(x[,1]),as.list(x[,2]),edge.check=edge.check) } #Patch up g on exit for in-place modification - if(.validLHS(gn,parent.frame())){ - on.exit(eval.parent(call('<-',gn,g))) - } + on.exit(tryCatch(eval.parent(call('<-',gn,g)),error=identity)) invisible(g) } @@ -398,9 +392,7 @@ network.incidence<-function(x, g, ignore.eval=TRUE, names.eval=NULL, ...){ g<-add.edge(g,tail,head,names.eval=en,vals.eval=ev,edge.check=edge.check) } #Patch up g on exit for in-place modification - if(.validLHS(gn,parent.frame())){ - on.exit(eval.parent(call('<-',gn,g))) - } + on.exit(tryCatch(eval.parent(call('<-',gn,g)),error=identity)) invisible(g) } diff --git a/man/network-internal.Rd b/man/network-internal.Rd index 7ccc140..252237f 100644 --- a/man/network-internal.Rd +++ b/man/network-internal.Rd @@ -22,6 +22,7 @@ network.} \item{y}{a network or something coercible to one.} +\item{\dots}{further arguments passed to or used by methods.} } \description{ Internal network functions.