From 659803fc2ce7b36cf6323421ef1a529f78e48ddb 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 | 1 - R/access.R | 53 ++++++++++------------------------------ R/assignment.R | 63 ------------------------------------------------ R/constructors.R | 16 +++--------- 4 files changed, 17 insertions(+), 116 deletions(-) delete mode 100644 R/assignment.R diff --git a/DESCRIPTION b/DESCRIPTION index 2fd4ec4..66f7fad 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -28,7 +28,6 @@ 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 9614225..fdd7795 100644 --- a/R/access.R +++ b/R/access.R @@ -149,9 +149,7 @@ add.edge <- function(x, tail, head, names.eval=NULL, vals.eval=NULL, edge.check= #' @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) } @@ -162,7 +160,6 @@ add.edge.network<-function(x, tail, head, names.eval=NULL, vals.eval=NULL, edge. #' @export add.edges add.edges <- function(x, tail, head, names.eval=NULL, vals.eval=NULL, ...) UseMethod("add.edges") - # Add multiple edges to network x. Tail must be a list, each element of # which is the tail set for a given edge (ditto for head). If edge values # are provided, they must be given similarly as lists of lists. @@ -190,9 +187,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) } @@ -285,9 +280,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{ @@ -472,9 +465,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) } @@ -553,9 +544,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) } @@ -572,9 +561,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) } @@ -592,9 +579,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) } @@ -619,9 +604,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) } @@ -1833,9 +1816,7 @@ permute.vertexIDs.network <- 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) } @@ -1929,9 +1910,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) } @@ -1966,9 +1945,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) } @@ -1996,9 +1973,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) } @@ -2130,8 +2105,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) }