I'm not quite sure of the terminology here. I'm doing a code parsing project to visualize the relationships between objects of an R script. Almost everyting works except for parsing and evaluating functions and loops. I don't think I have a good enough handle on regex to find the beginning/end of nested curly braces.
In the script, it might look like this:
something_above <- "above"
my_function <- function(x){
x2 <- x^2
if(x2 >= 200){
res <- "200+"
} else {
res <- "<200"
}
return(res)
}
something_below <- "below"
When I read it in, it looks like this
string <- '\r\nsometing_above <- \"above\"\r\n\r\nmy_function <- function(x){\r\n x2 <- x^2\r\n if(x2 >= 200){\r\n res <- \"200+\"\r\n } else {\r\n res <- \"<200\"\r\n}\r\n return(res)\r\n }\r\nsomething_below <- \"below\"\r\n'
I would like to be able to collapse the function into a single line like this
... <- function(x){x2 <- x^2 ; if(x2 >= 200){res <- "200+" ; ...}; return(res)}\r\n ...
so that each step within the function is separated by a ; instead of a new line. I would, however, like to keep the new line \r\n pattern at the beginning of the assignment\r\nmy_function and once the function assignment is over };return(res)}\r\n.
The final result would be three lines:
[1] something_above <- "above"
[2] my_function <- function(x){x2 <- x^2; if(x2 >= 200 ...}
[3] something_below <- "below"
Thank you.
Related
I am writing a function that will go through a list of files in a directory, count number of complete cases, and if the sum of complete cases is above a given threshhold, a correlation should be calculated. The output must be a numeric vector of correlations for all files that meet the threshhold requirement. This is what I have so far (and it gives me an Error: unexpected '}' in "}" Full disclosure - I am a complete newbie, as in wrote my first code 2 weeks ago. What am I doing wrong?
correlation <- function (directory, threshhold = 0) {
all_files <- list.files(path = getwd())
correlations_list <- numeric()
for (i in seq_along(all_files)) {
dataFR2 <- read.csv(all_files[i])
c <- c(sum(complete.cases(dataFR2)))
if c >= threshhold {
d <- cor(dataFR2$sulfate, dataFR2$nitrate, use = "complete.obs", method = c("pearson"))
correlations_list <- c(correlations_list, d)
}
}
correlations_list
}
"Unexpected *" errors are a syntax error. Often a missing parenthesis, comma, or curly bracket. In this case, you need to change if c >= threshhold { to if (c >= threshhold) {. if() is a function and it requires parentheses.
I'd also strongly recommend that you not use c as a variable name. c() is the most commonly used R function, and giving an object the same name will make your code look very strange to anyone else reading it.
Lastly, I'd recommend that you make your output the same length as the the number of files. As you have it, there won't be any way to know which files met the threshold to have their correlations calculated. I'd make correlations_list have the same length as the number of files, and add names to it so you know which correlation belongs to which file. This has the side benefit of not "growing an object in a loop", which is an anti-pattern known for its inefficiency. A rewritten function would look something like this:
correlation <- function (directory, threshhold = 0) {
all_files <- list.files(path = getwd())
correlations_list <- numeric(length(all_files)) ## initialize to full length
for (i in seq_along(all_files)) {
dataFR2 <- read.csv(all_files[i])
n_complete <- sum(complete.cases(dataFR2))
if(n_complete >= threshhold) {
d <- cor(dataFR2$sulfate, dataFR2$nitrate, use = "complete.obs", method = c("pearson"))
} else {
d <- NA
}
correlations_list[i] <- d
}
names(correlations_list) <- all_files
correlations_list
}
I wish to "copy and modify" a function at a specific point in its body. Currently, what I have is
nearest_psd <- function(mat) {
ed <- eigen(mat)
eigvecs <- ed$vectors
eigvals <- ed$values
eigvals[eigvals<0] <- 0
eigvecs %*% diag(eigvals) %*% t(eigvecs)
}
nearest_pd <- nearest_psd
formals(nearest_pd)$pdeps <- 1e-08
body(nearest_pd)[[c(7,3)]] <- quote(pdeps)
, so that nearest_pd is a copy of nearest_psd, except for the line eigvals[eigvals<0] <- pdeps.
However, the line number (7, in this case) is hard-coded, and I would prefer to have a robust way to determine this line number. How can I search for the line that contains the expression eigvals[eigvals<0] <- 0?
You can use identical to compare two expressions; that way, you can identify and replace the expression in question:
to_replace = vapply(body(nearest_pd), function (e) identical(e, quote(eigvals[eigvals < 0] <- 0)), logical(1L))
body(nearest_pd)[to_replace] = list(quote(eigvals[eigvals < pdeps] <- pdeps))
However, this is no more readable, nor more robust, than your code: in both cases you’re forced to hard-code the relevant information; in your code, the indices. In mine, the expression. For that reason I wouldn’t recommend using this.
… of course you could instead use an AST walker to replace all occurrences of 0 in the function’s body with pdeps. But is that better? No, since 0 could be used for other purposes. It currently isn’t, but who knows, once the original function changes. And if the original function can’t be assumed to change, why not hard-code the new function entirely? That is, write this:
nearest_pd <- function (mat, pdeps = 1e-08) {
ed <- eigen(mat)
eigvecs <- ed$vectors
eigvals <- ed$values
eigvals[eigvals < pdeps] <- pdeps
eigvecs %*% diag(eigvals) %*% t(eigvecs)
}
… no need to use metaprogramming just for the sake of it.
The following might do what you want.
nearest_psd <- function(mat) {
ed <- eigen(mat)
eigvecs <- ed$vectors
eigvals <- ed$values
eigvals[eigvals<0] <- 0
eigvecs %*% diag(eigvals) %*% t(eigvecs)
}
nearest_pd <- nearest_psd
formals(nearest_pd)$pdeps <- 1e-08
nearest_psd_body <- body(nearest_psd)
# Find the string we a re looking for and replace it ...
new.code <- gsub("eigvals[eigvals < 0] <- 0",
"MY_NEW_CODE",
nearest_psd_body, fixed = TRUE)
# Buidling the function body as a string.
new.code <- new.code[-1] # delete first { such that ...
new.code <- paste(new.code, collapse = ";") # we can collapse the remaining here ....
new.code <- paste("{", new.code, "}", sep = "", collapse = "") # and then wrap the remaining in { }
# parse returns an expression.
body(nearest_pd) <- parse(text = new.code)
See At a basic level, what does eval-parse do in R? for an explantion of parse. Or In programming, what is an expression? what an expression is.
I'm relatively new to R programming, but have a specific problem concerning the extraction of text from a syntactically parsed historical language corpus. The problem should be easy to solve, but I just can't get my head around it. My question is basically a more specific variation of this one: R: parse nested parentheses
I would like to parse nested parentheses in R. Here is an example of some data:
(sometext(NP-SBJ(D+N_THYSTORYE)(PP(P_OF)(NP(NPR_REYNARD)(NP-PRN(D_THE)(N_FOXE)))))sometext)
From this string I would like to extract all (potentially nested) substrings that begin with "NP", so the result should be
(NP-SBJ(D+N_THYSTORYE)(PP(P_OF)(NP(NPR_REYNARD)(NP-PRN(D_THE)(N_FOXE)))))
(NP(NPR_REYNARD)(NP-PRN(D_THE)(N_FOXE)))
(NPR_REYNARD)
(NP-PRN(D_THE)(N_FOXE))
Any help would be much appreciated!
This probably isn't the most efficient, but here's a function which can extract the "tokens" or strings between matched parentheis.
find_tokens <- function(s) {
stopifnot(length(s)==1)
mm <- gregexpr("[)()]", s)
stack <- numeric()
starts <- numeric()
stops <- numeric()
Map(function(i, v) {
if(v=="(") {
stack <<- c(stack, i)
} else if (v==")") {
starts <<- c(starts, tail(stack, 1))
stops <<- c(stops, i)
stack <<- stack[-length(stack)]
}
}, mm[[1]], regmatches(s, mm)[[1]])
rev(substring(s, starts, stops))
}
This will extract everything. If you want to keep just the values that start with "(NP" you can just grep this list
grep("^\\(NP", find_tokens(s), value=TRUE)
# [1] "(NP-SBJ(D+N_THYSTORYE)(PP(P_OF)(NP(NPR_REYNARD)(NP-PRN(D_THE)(N_FOXE)))))"
# [2] "(NP(NPR_REYNARD)(NP-PRN(D_THE)(N_FOXE)))"
# [3] "(NP-PRN(D_THE)(N_FOXE))"
# [4] "(NPR_REYNARD)"
Here's another possible implementation of find_tokens that might be more efficient that will better support multiple strings as a list.
find_tokens <- function(s) {
mm <- gregexpr("[)()]", s)
vv <- regmatches(s, mm)
extr <- function(x, mm, vv) {
open_i <- 0
shut_i <- 0
open <- numeric(length(vv)/2)
shut <- numeric(length(vv)/2)
close <- numeric(length(vv)/2)
for(i in seq_along(mm)) {
if (vv[i]=="(") {
open_i <- open_i + 1
shut_i <- shut_i + 1
open[open_i] <- mm[i]
shut[shut_i] <- open_i
} else if (vv[i]==")") {
close[shut[shut_i]] <- mm[i]
shut_i <- shut_i - 1
}
}
substring(x, open, close)
}
unname(Map(extr, s, mm, vv))
}
and then you would use
lapply(find_tokens(s), function(x) grep("^\\(NP", x, value=TRUE))
I just read that vectorization increases performance and lowers significantly computation time, and in the case of if() else , best choice is ifelse().
My problem is I got some if statements inside a for loop, and each if statement contains multiple assignments, like the following:
x <- matrix(1:10,10,3)
criteria <- matrix(c(1,1,1,0,1,0,0,1,0,0,
1,1,1,1,1,0,0,1,1,0,
1,1,1,1,1,1,1,1,1,1),10,3) #criteria for the ifs
output1 <- rep(list(NA),10) #storage list for output
for (i in 1:10) {
if (criteria[i,1]>=1) {
output1[[i]] <- colMeans(x)
output1[[i]] <- output1[[i]][1] #part of the somefunction output
} else {
if(criteria[i,2]>=1) {
output1[[i]] <- colSums(x)
output1[[i]] <- output1[[i]][1] #the same
} else {
output1[[i]] <- colSums(x+1)
output1[[i]] <- output1[[i]][1] #the same
}}}
How can I translate this into ifelse?
Thanks in advance!
Note that you don't need a for loop as all operations used are vectorized:
output2 <- ifelse(criteria[, 1] >= 1,
colMeans(x)[1],
ifelse(criteria[, 2] >= 1,
colSums(x)[1],
colSums(x+1)[1]))
identical(output1, as.list(output2))
## [1] TRUE
At least you can convert two assignments into one. So instead of
output[[i]] <- somefunction(arg1,arg2,...)
output[[i]] <- output[[i]]$thing #part of the somefunction output
you can refer directly to the only part you are interested in.
output[[i]] <- somefunction(arg1,arg2,...)$thing #part of the somefunction output
Hope that it helps!
It seems I found the answer trying to build the example:
output2 <- rep(list(NA),10) #storage list for output
for (i in 1:10) {
output2[[i]] <- ifelse(criteria[i,1]>=1,
yes=colMeans(x)[1],
no=ifelse(criteria[i,2]>=1,
yes=colSums(x)[1],
no=colSums(x+1)[1]))}
I need a function created by a list of commands to fully evaluate so that it is identical to the "manual" version of the function.
Background: I am using ScaleR functions in Microsoft R Server and need to apply a set of transformations as a function. ScaleR is very picky about needing to be passed a function that is phrased exactly as specified below:
functionThatWorks <- function(data) {
data$marital_status_p1_ismarried <- impute(data$marital_status_p1_ismarried)
return(data)
}
I have a function that creates this list of transformations (and hundreds more, hence the need to functionalize its writing).
transformList <- list ("data$ismarried <- impute(data$ismarried)",
"data$issingle <- impute(data$issingle)")
This line outputs the evaluated string that I want to the console, but I am unaware of a way to move it from console output to being used in a function:
cat(noquote(unlist(bquote( .(noquote(transformList[1]))))))
I need to evaluate functionIWant so that it is identical to functionThatWorks.
functionIWant <- function(data){
eval( cat(noquote(unlist(bquote( .(noquote(transformList[1])))))) )
return(data)
}
identical(functionThatWorks, functionIWant)
EDIT: Adding in the answer based on #dww 's code. It works well in ScaleR. It is identical, minus meaningless spacing.
functionIWant <- function(){}
formals(functionIWant) <- alist(data=NULL)
functionIWant.text <- parse(text = c(
paste( bquote( .(noquote(transformList[1]))), ";", "return(data)\n")
))
body(functionIWant) <- as.call(c(as.name("{"), functionIWant.text))
Maybe something like this?
# 1st define a 'hard-coded' function
f1 <- function (x = 2)
{
y <- x + 1
y^2
}
f1(3)
# [1] 16
# now create a similar function from a character vector
f2 <- function(){}
formals(f2) <- alist(x=2)
f2.text <- parse(text = c('y <- x + 1', 'y^2'))
body(f2) <- as.call(c(as.name("{"), f2.text))
f2(3)
# [1] 16