attachment:as.object.R of R Coding/local-package

   1 #' Assign Objects from Named Variables
   2 #'
   3 #' \code{as.object} can be used to assign (create) objects based on the names and values in named vectors or lists, or from column names and column values in data frames. If the source object is unnamed, names can be supplied as aruguments or as a character vector using the argument \code{to}. If names are supplied, they are used to replace (fully or partially) those in the source object.
   4 #'
   5 #' See \code{\link[base:assign]{assign}} for for futher details.
   6 #' @param x an object with with names, such as vector, list or data frame, or an object to which the \code{names} attribute can be applied.
   7 #' @param ... names to be applied to \code{x}, if unnamed, or to replace existing names.
   8 #' @param to a character vector of names to be applied to \code{x}, if unnamed, or to replace existing names.
   9 #' @param replace a logical value indicating whether existing objects should be replaced without warning.
  10 #' @param return a logical value indicating whether to return a character vector containing the names of the objects assigned.
  11 #' @param pos where to assign the objects. By default, uses the current environment. See \code{\link[base:assign]{assign}} for other possibilities.
  12 #' @param envir	the environment to use. See \code{\link[base:assign]{assign}} for details.
  13 #' @param inherits should the enclosing frames of the environment be inspected?
  14 #' @return This function is largely invoked for its side effect, that is, assigning values to objects created from the names and values from \code{x}. However, by default it returns a character vector of the names of objects assigned, as this might differ from the original name of the souce object if alternative names supplied by arguments \code{...} and \code{to}. The vector might be useful for subsequent operations on these object using \code{eval(as.name())}.
  15 #'
  16 #'If alternative object names are given by arguments \code{...} and \code{to}, those given by \code{...} are used first. If there are more names provided than elements in the source object, the extras will be ignored and a warning given.
  17 #'
  18 #' If there are blank names or insufficent names, the elements in the source object that correspond to the postion of these will not be assigned and a warning given.
  19 #'
  20 #'If numerical values are provided via \code{...}, these will be converted to integers and prefixed by 'x' to created new object names.
  21 #'
  22 #'If \code{replace} is FALSE and an attempt assignment would fail, then no assignments are made and an error message returned.
  23 #' @examples
  24 #' as.object(c(v1 = 1, v2 = 2)) # creates two objects, "v1" and "v2"
  25 #' v1; v2
  26 #' as.object(list(v1 = 1:2, v2 = 1:3, v3 = 1:4, 1:5)) # last item in list ignored with warning
  27 #' v1; v2; v3
  28 #' as.object(data.frame(v1 = 1:3, v2 = 4:6, v3 = 7:9)) 
  29 #' v1; v2; v3
  30 #' as.object(c(1,2), c("v1", "v2")) # provide names to unnamed structure
  31 #' v1; v2
  32 #' as.object(c(v1 = 1, v2 = 2), v3, v4) # replace names in named structure
  33 #' v3; v4
  34 #' as.object(c(1, 2), 5:6) # apply numbered names, "x5" and "x6" here
  35 #' x5; x6
  36 #' @export
  37 as.object <- function(x, ..., to = character(), replace = TRUE, return = TRUE, pos = 1, envir = as.environment(pos), inherits = FALSE)
  38 {
  39 	.addnames <- function(x, n) { # add from 'to' or 'dots'
  40 		if (length(x) < length(n)) {
  41 			names(x) <- n[1:length(x)]
  42 			msg <- .smsg(n[(length(x)+1):length(n)])
  43 			warning(deparse(sys.calls()[[sys.nframe()-1]]), " : extra names not assigned (", msg, ")", call. = FALSE)
  44 		} else {	
  45 			names(x)[1:length(n)] <- n # if shorter, some originals retained
  46 			names(x)[is.na(names(x))] <- ""
  47 		}
  48 		return(x)
  49 	}
  50 
  51 	.shorten <- function(x, n)
  52 		if (length(x) < 3) x else x <- c(x[1:n], '...')
  53 		
  54 	.smsg <- function(x, n = 3)
  55 		toString(.shorten(x, 3))
  56 		
  57 	dots <- match.call(expand.dots = FALSE)$...
  58 	if (length(dots)) { # 'dots' will be appended to 'to'
  59 		.call <- vapply(dots, is.call, logical(1))
  60 		dots[.call] <- lapply(dots[.call], eval)
  61 		dots <- unlist(dots)
  62 		.numeric <- is.numeric(dots)
  63 		dots[.numeric] <- vapply(as.integer(dots[.numeric]), sprintf, fmt = "x%i", "")
  64 		dots <- as.character(dots)
  65 		x = .addnames(x, dots)
  66 	} 
  67 
  68 	if (! missing(to) && length(to))
  69 		x <- .addnames(x, c(to, dots))
  70 	unnamed <- ! nzchar(names(x))
  71 	if (length(names(x)) && any(unnamed)) {
  72 		msg <- .smsg((1:length(x))[unnamed])
  73 		warning("unnamed element(s) of 'x' argument not assigned (x[", msg, "])")
  74 		x <- x[! unnamed] # remove unnamed elements
  75 	}
  76 
  77 	if (! length(names(x)))
  78 		stop("unnamed 'x' argument, no assignments possible")
  79 	.exists <- vapply(names(x), exists, logical(1))
  80 	msg <- .smsg(names(x)[.exists])
  81 	if (! replace && any(.exists))
  82 		stop("cannot replace (", msg, ")")
  83 
  84 	assign.byNames(x, pos = pos, envir = envir, inherits = inherits)
  85 
  86 	if (return)
  87 		return(names(x))
  88 }
  89 
  90 #' Assign objects from named variables (no checking)
  91 #'
  92 #' @keywords internal
  93 #' @return Nothing returned
  94 assign.byNames <- function(x, pos = 1, ...)
  95 {
  96 	.assign <- function(x, pos = pos, ... )
  97 		assign(names(x), value = x[[1]], pos = pos, ...)
  98 		
  99 	for (i in 1:length(x)) # for() loop because lapply() eats names
 100 		.assign(x[i], pos = pos, ...)
 101 }