[R] New unique name and fixing getAnywhere()

["Jens Oehlschlägel"]

# what about

gensym <- function(root="GeneratedSymbolname", pool=c(letters, LETTERS,
0:1), n=16, sep="_")
{
  todo <- TRUE
  while (todo){
    symbolname <- paste(root, paste(sample(pool, n, TRUE), collapse=""),
sep=sep)
    todo <- length(getAnywhere(symbolname)$objs)
  }
  symbolname
}

# but this requires a slightly changed version of getAnywhere()
# which currently finds: getAnywhere("find")
# but does not find: symbolname <- "find"; getAnywhere(symbolname)
# (BTW current getAnywhere() has returnvalue$objs whereas the documentation
says returnvalue$funs)
# the following patch avoids this problem and is more aligned with get()

getAnywhere <- function(x)
{
    stopifnot(is.character(x))
    objs <- list()
    where <- character(0)
    visible <- logical(0)
    if (length(pos <- find(x, numeric = TRUE))) {
        objs <- lapply(pos, function(pos, x) get(x, pos = pos),
            x = x)
        where <- names(pos)
        visible <- rep.int(TRUE, length(pos))
    }
    if (length(grep(".", x, fixed = TRUE))) {
        np <- length(parts <- strsplit(x, ".", fixed = TRUE)[[1]])
        for (i in 2:np) {
            gen <- paste(parts[1:(i - 1)], collapse = ".")
            cl <- paste(parts[i:np], collapse = ".")
            if (!is.null(f <- getS3method(gen, cl, TRUE))) {
                ev <- topenv(environment(f), NULL)
                nmev <- if (isNamespace(ev))
                  getNamespaceName(ev)
                else NULL
                objs <- c(objs, f)
                msg <- paste("registered S3 method for", gen)
                if (!is.null(nmev))
                  msg <- paste(msg, "from namespace", nmev)
                where <- c(where, msg)
                visible <- c(visible, FALSE)
            }
        }
    }
    for (i in loadedNamespaces()) {
        ns <- asNamespace(i)
        if (exists(x, envir = ns, inherits = FALSE)) {
            f <- get(x, envir = ns, inherits = FALSE)
            objs <- c(objs, f)
            where <- c(where, paste("namespace", i, sep = ":"))
            visible <- c(visible, FALSE)
        }
    }
    ln <- length(objs)
    dups <- rep.int(FALSE, ln)
    objs2 <- lapply(objs, function(x) {
        if (is.function(x))
            environment(x) <- NULL
        x
    })
    if (ln > 1)
        for (i in 2:ln) for (j in 1:(i - 1)) if (identical(objs2[[i]],
            objs2[[j]])) {
            dups[i] <- TRUE
            break
        }
    res <- list(name = x, objs = objs, where = where, visible = visible,
        dups = dups)
    class(res) <- "getAnywhere"
    res
}



-- 

Ab sofort DSL-Tarif ohne Grundgebühr: http://www.gmx.net/info