R/sidekick.R

In SciViews/svTools: Wrappers for Tools in Other Packages for IDE Friendliness

## Translate the tree representation generated by 
## the R parser (parse) into a rectangular representation
sidekick <- function (x, ...)
	UseMethod("sidekick")

sidekick.default <- function (x, ... )
	.NotYetImplemented()

sidekick.function <- function (x, ...)
{
	tf <- tempfile()
	on.exit(unlink(tf))
	dump("x" , file = tf)
	sidekick.character(tf, encoding = getOption("encoding"),
		delete.file = TRUE)
}

sidekick.character <- function (x, encoding = getOption("encoding"),
delete.file = FALSE, ...)
{
	if (isTRUE(delete.file))
		on.exit({unlink(x)})
	
	## Try to parse and return an error if failed
	f <- file(x, open = "r", encoding = encoding)
	p <- try(parse(f, srcfile = srcfile(x, encoding)), silent = TRUE)
	close(f)
	if (inherits(p, "try-error"))
		return(list(type = "error", data = parseError(p)))
	
	## Calls the actual sidekick function
	out <- .sidekickParse(p)
### TODO: replace this in the code so that no conversion is necessary at that point

	out$id <- as.integer(out$id)
	out$srcref1 <- as.integer(out$srcref1)
	out$srcref2 <- as.integer(out$srcref2)
	out$srcref3 <- as.integer(out$srcref3)
	out$srcref4 <- as.integer(out$srcref4)
	out$parent  <- as.integer(out$parent)
	list(type = "ok", data = out)
}

.sidekickParse <- function (p = try(parse(file), silent = TRUE), top = TRUE,
env = new.env(), parent = 0, file)
{
	if (isTRUE(top)) {		
		env[["data"]] <- data.frame( 
			id = integer(0), 
			srcref1 = integer(0), 
			srcref2 = integer(0),
			srcref3 = integer(0),
			srcref4 = integer(0),
			description = character(0), 
			parent = integer(0), 
			mode = character(0), stringsAsFactors = FALSE)
		if (inherits(p, "try-error")) return(env[["data"]])
		maxId <- 0
	} else {
		maxId <- max(env[["data"]][, "id"]) 
	}
	isIf <- .looksLikeAnIf(p)
	atts <- attributes(p)
	descriptions <- as.character(p)
	hasAttrs <- "srcref" %in% names(atts)
	ids <- maxId + 1:length(p)
	if (isTRUE(hasAttrs)) {
		srcrefs <- t(sapply(attr(p, "srcref"), function (y) {
			as.integer(y)[1:4]
			# if (length(positions) == 4) positions else positions[c(1,5,3,6)]
		}))  
		colnames(srcrefs) <- paste("srcref", 1:4, sep = "")
		srcrefs <- as.data.frame(srcrefs) 
		modes <- sapply(p, mode)
		data <- data.frame(id = ids, 
			parent = rep(parent, length(p)), 
			mode = modes, srcrefs, description = descriptions, 
			stringsAsFactors = FALSE)
		env[["data"]] <- rbind(env[["data"]], data)
	} 
	
	calls <- sapply(p, mode) %in% c("call", "function")
  
	if(isTRUE(isIf)) {
		env[["data"]][parent, "mode"] <- "if"
		pa <- try(.addIfNode(TRUE, env = env, parent = parent, p[[3]]),
			silent = TRUE)
		.sidekickParse(p[[3]], top = FALSE, env = env, parent = pa)  
		if (length(p) == 4) {
			pa <- try(.addIfNode(FALSE, env = env, parent = parent, p[[4]]),
				silent = TRUE)
			if (.looksLikeAnIf(p[[4]])) {
				data <- data.frame( 
					id = pa + 1, .getIfSrcRef(p[[4]]),
					description = paste("if(", as.character(p[[4]][[2]]), ")",
					sep = "" ), parent = pa, mode = "if")
				env[["data"]] <- rbind(env[["data"]], data)
				env[["data"]][pa, 2:5] <- data[, 2:5] 
				pa <- pa + 1
			}
			.sidekickParse(p[[4]], top = FALSE, env = env, parent = pa)  
		}
	} else {
		for (i in 1:length(p)) {
			if (!is.null(p) && calls[i]) {
				test <- try(.looksLikeAFunction(p[[i]]), silent = TRUE)
				if (isTRUE(test)) {
					env[["data"]][ids[i], "mode"] <- "function"
					try(.sidekickParse(p[[i]], top = FALSE, env = env,
						parent = if (isTRUE(hasAttrs)) ids[i] else parent),
						silent = TRUE)  
				} else {
					.sidekickParse(p[[i]], top = FALSE, env = env,
						parent = if (isTRUE(hasAttrs)) ids[i] else parent)
				}
			}
		}
	}
	if (isTRUE(top)) return(env[["data"]])
}