My function foo() below produces 3 types of messages. Two of them are created by message(), and one of them is created by cat().
Suppose I call foo() multiple times by lapply().
I want to know if() we have any error message (the second message that contains the term error) from my lapply() call?
NOTE: I don't want to use stop or warning.
foo <- function(dat_obj) {
v1 <- sapply(names(dat_obj), function(i) length(unique(dat_obj[[i]])))
i1 <- names(which(v1 != 1))
if(length(i1) == 1) {
message(paste("Note: potential problem in",i1))
} else if(length(i1) > 1) {
message(paste("Error: fatal problem in x & y."))
} else {
cat(paste("OK: No issues detected.\n"))
}
}
#----- EXAMPLE OF USE:
INPUT <- list(
A = data.frame(x = c(1,1,1,1), y = c(2,4,3,3)),
B = data.frame(x = c(1,2,1,1), y = c(3,3,3,3)),
C = data.frame(x = c(1,2,1,1), y = c(3,2,3,3)),
D = data.frame(x = c(1,1,1,1), y = c(3,3,3,3)))
invisible(lapply(INPUT, foo))
#----- OUTPUT:
#Note: potential problem in y
#Note: potential problem in x
#Error: fatal problem in x & y.
#OK: No issues detected.
Functions should return something, even if only invisible(NULL). In the case below, I have changed the return value to NA assigned to a variable, y. Then the logical test numbers, 1, 2, or 3 are an attribute of this returned value.
foo <- function(dat_obj) {
v1 <- sapply(names(dat_obj), function(i) length(unique(dat_obj[[i]])))
i1 <- names(which(v1 != 1))
if(length(i1) == 1) {
Attrib <- 1
message(paste("Note: potential problem in",i1))
} else if(length(i1) > 1) {
Attrib <- 2
message(paste("Error: fatal problem in x & y."))
} else {
Attrib <- 3
cat(paste("OK: No issues detected.\n"))
}
y <- NA
attr(y, "message") <- Attrib
y
}
invisible(res <- lapply(INPUT, foo))
sapply(res, attr, "message")
You can use capture.output to capture the output returned from the function.
temp <- capture.output(lapply(INPUT, foo), type = 'message')
temp
#[1] "Note: potential problem in y" "Note: potential problem in x"
# "Error: fatal problem in x & y."
To find output where 'Error' is returned you can use grep.
grep('Error', temp)
#[1] 3
Related
I have the below chunk. It runs fine, gives me output. No errors. (Maybe my logic but nothing that stops the program from running) BUT when I go to knit it I get the following error:
Error in x[[1]] : subscript out of bounds calls: ... knit_print.default ->normal_print -> print.list Execution halted
x <- 0
y <- list()
p <- ncol(data)
for (i in 2:p){
x <- 0
tbl <- table(data[,i])
res <- cbind(tbl,round(prop.table(tbl)*100,2))
colnames(res) <- c('Count','Percentage')
print(res)
g <- length(which(as.character(data[,i])=="Other"))
h <- length(which(as.character(data[,i])=="Don't know"))
j <- length(which(as.character(data[,i])=="Refuse to answer"))
k <- length(which(as.character(data[,i])=="Don't Know/Refuse to answer"))
m <- length(which(as.character(data[,i])=="Don't Know/Refuse to Answer"))
r <- length(which(data[,i]!="NA"))
if (r == 0) {
next
}
x <- g+h+j+k+m+x
if (x == 0) {
next
}
r <- length(which(data[,i]!="NA"))
if ((x/r) >= .1) {
names(data[, i, drop = FALSE])
y <- c(y,names(data)[i])
}
}
z <- length(which(data[,37:41]==1))
t <- length(which(data[,40:41]==1))
#if ((t/z) >= .1) {
#names(data[, 37, drop = FALSE])
# y <- c(y,names(data)[37])
#}
v <- length(which(data[,45:49]==1))
b <- length(which(data[,48:49]==1))
#if ((b/v) >= .1) {
# names(data[, 45, drop = FALSE])
# y <- c(y,names(data)[45])
#}
y
x is a counter I use to count the number of specific replies to questions.
y is an empty list to capture the column names of columns reaching a specific threshold.
So I count the replies in each column and determine which are flagged for further review.
The program runs. But will not knit. I have some lines #commented out on purpose
Any suggestions please?
I'm writing a function that contains some conditions. The returning value of the function will depend on such a condition in a way that the returning value might not even exist within the function based on the condition. In that case, I'd expect the function to throw an error. However, this only works as long as the supposed-to-return value does not also exist in the global environment. If it does, the value from the global environment is returned, which I find confusing.
What am I missing here? What am I doing wrong?
Example:
xyz <- function(x = NULL, y = NULL)
{
if (x+y > 10) {z <- x + y}
return(z)
}
If I now run test <- xyz(20, 30) I get the correct result (test = 50).
If I run test <- xyz(2, 3) I also correctly get an error:
Error in xyz(2, 3) : object 'z' not found
However, now I'm creating a z value in the global environment.
z <- 3.14
When I'm now running my function test <- xyz(2, 3) I get 3.14 as the result.
I was expecting that the function will only return the value of z if it exists inside the function. How can I do that?
Thanks
If a free variable (one referred to but not defined) in a function is accessed then it looks in the environment where the function was defined and then in the parent environment of that and so on.
Use get("z", inherits = FALSE) to look for z only in the current environment or check whether it exists exists("z", inherits = FALSE) in the current environment only.
Another possibility is to always give z a value:
z <- if (length(x) && length(y) && x + y > 10) x + y
In that case z will have the value NULL if the condition is false because the default else leg is NULL. Returning NULL invisibly would be about as close as you can get to not returning a value.
xyz2 <- function(x = NULL, y = NULL) {
z <- if (length(x) && length(y) && x + y > 10) x + y
# other processing can go here
if (is.null(z)) invisible(z) else z
}
xyz2(1, 2)
xyz2(5, 9)
## [1] 14
Why not just throw an informative error, based on the condition rather than z?
xyz <- function(x = NULL, y = NULL)
{
if ( x + y <= 10 ) {
stop("The sum of x and y must be greater than 10.")
}
return(x + y)
}
xyz(20, 30)
# [1] 50
xyz(2, 3)
# Error in xyz(2, 3) : The sum of x and y must be greater than 10.
I like duckmayr's idea, but here's how you can implement while still using z:
xyz <- function(x = NULL, y = NULL) {
z = x + y
if (z <= 10 ) {
stop("The sum of x and y must be greater than 10.")
}
return(z)
}
I tried to create a function f and create the function so when a value x is inserted, it spits out a function f from y.But, when I try to run the code to plot, it gives me an error that says that my y_value has no length.
f <- function(x){
if (x<0){
print(y_values<-x*x*x)
}
if(x>0 & x<=1){
print(y_values<-x*x)
}
if(x>1){
print(y_values<-sqrt(x))
}
}
x_values <- seq(-2, 2, by = 0.1)
y_values <- rep(NA, length(x_values))
for (i in seq_along(x_values)) {
x <- x_values[i]
y_values[i] <- f(x)
}
# output
plot(x_values, y_values, type = "l")
Two issues:
From ?print
‘print’ prints its argument and returns it invisibly (via
‘invisible(x)’)
So all your function f does is print the values to the console (instead of returning them).
As per your definition of f, the function does not know how to deal with x=0; so this will create a problem when you store the output of f(0) later.
We can fix these issues by slightly altering f as
f <- function(x) {
y_values <- NA
if (x<0){
y_values<-x*x*x
}
if(x>0 & x<=1){
y_values<-x*x
}
if(x>1){
y_values<-sqrt(x)
}
return(y_values)
}
Then
x_values <- seq(-2, 2, by = 0.1)
y_values <- rep(NA, length(x_values))
for (i in seq_along(x_values)) {
x <- x_values[i]
y_values[i] <- f(x)
}
plot(x_values, y_values, type = "l")
You could also use Vectorize to obtain a vectorised function f2, which allows you to pass x_values as a vector, thereby avoiding the explicit for loop:
f2 <- Vectorize(f)
x_values <- seq(-2, 2, by = 0.1)
y_values <- f2(x_values)
The resulting plot is the same.
I would recommend you explore other methods for coding something like this:
here is one option that doesn't use a for loop. If you are simply working on using for loops then the fix Mauritus Evers made should work for you.
library(tidyverse)
data.frame(x_values = seq(-2, 2, by = 0.1)) %>%
mutate(y_values = case_when(x_values < 0 ~ x_values^3,
x_values>=0 & x_values<=1 ~ x_values^2,
x_values>1 ~ sqrt(x_values))) %>%
ggplot(aes(x_values, y_values)) + geom_point()
note that I changed your code to produce output when x_value = 0.
my code is like the following:
unemp <- c(1:10)
bsp_li <- list(c(1:10),c(11:20),c(21:30))
var_data_rep <- lapply(bsp_li, function(x) {cbind(as.numeric(x), as.numeric(unemp))} ) # Create VAR data matrices
var_data_rep2 <- lapply(var_data_rep, function(x) {colnames(x) = c("rGDP", "U"); return(x)}) # Name columns
var_data_rep_ts <- lapply(var_data_rep2, function(x) {ts(x, frequency=1, start=c(1977))} ) # Make it ts again
var_data_rep_lag <- lapply(var_data_rep_ts, function(x) {VARselect(x, lag.max = 5, type = "const")} ) # Take lag with lowest SC criteria (VAR.pdf)
VARgdp_rep <- lapply(var_data_rep_ts, function(x) {VAR(x, p = var_data_rep_lag$x$selection[['SC(n)']], type = "const"); return(x)} ) # Lag=lowest SC criteria from var_data_rep_lag
if i run only the last line r always gives me the error:
Error in if ((dimension < 1) | (dimension > n)) stop("wrong embedding dimension") :
argument is of length zero
Called from: embed(y, dimension = p + 1)
But if im running it with Source then it seems to work.. any suggestions?
This seems to work (at least no error is thrown) :
VARgdp_rep <-
lapply(index(var_data_rep_ts),
function(x) {
res <- VAR(var_data_rep_ts[[x]], p =
var_data_rep_lag[[x]]$selection[['SC(n)']], type = "const");
return(res)
}
)
In you code, return(x) is strange because after doing VAR calculations .. you just return the x withc was pass to the function.
And $x seems to have no meaning here.
I am very new to R. I am trying to create a function where the user is able to input expressions into arguments. These inputs are then used in plot3d through the rgl package. The function I have so far is :
flight_sim <- function(xval, yval, zval)
{
# Evaluate arguments and convert them into expressions
eval(parse(text = zval))
z <- data.frame(zval)
eval(parse(text = xval))
x <- data.frame(xval)
eval(parse(text = yval))
y <- data.frame(yval)
flight_path <- as.data.frame(cbind(x,y,z))
}
I have a readline() and switch() command :
cat('Select the flight path you wish to plot from the list below :
1. Helix
2. Conical
3. Spherical
4. Define your own flight path...')
userplot <- readline('Enter number here : ') # Allow user to enter choice from above
switch(userplot,"1"=flight_sim( sin(z), 1-cos(z), seq(0,20, pi/32) ),
"2"=flight_sim( z*cos(6*z), z*sin(6*z), seq(0,10, pi/64) ),
"3"=flight_sim( sin(z)*cos(20*z), sin(z)*sin(20*z), seq(0,pi,pi/399)),
"4"=custom())
Where custom() just prompts the user via readline() to enter x, y and z values, which is then followed by eval() and parse() and it works fine.
The problem I've been having is that x and y need to be functions of z, and this causes an error :
Error in parse(text = xval) : object 'z' not found
I thought by making the flight_sim function evaluate the zval argument first that it would fix it, however as I'm new to R I'm just getting more and more lost.
I hope what I have explained here makes some sense. I appreciate any help that can be provided.
Nothing is being passed as text in your example so using parse() doesn't seem necessary. If you want to delay evaulation, the best way would be to use substitute to grab the parameters as promises and then evaluate them in the context of your fliht_sim function. Here's what that would look like
flight_sim <- function(xval, yval, zval) {
z <- eval(substitute(zval))
x <- eval(substitute(xval))
y <- eval(substitute(yval))
data.frame(x,y,z)
}
userplot="2"
x <- switch(userplot,"1"=flight_sim( sin(z), 1-cos(z), seq(0,20, pi/32) ),
"2"=flight_sim( z*cos(6*z), z*sin(6*z), seq(0,10, pi/64) ),
"3"=flight_sim( sin(z)*cos(20*z), sin(z)*sin(20*z), seq(0,pi,pi/399)),
"4"=custom())
head(x)
# x y z
# 1 0.00000000 0.00000000 0.00000000
# 2 0.04697370 0.01424932 0.04908739
# 3 0.08162934 0.05454298 0.09817477
# 4 0.09342212 0.11383519 0.14726216
# 5 0.07513972 0.18140332 0.19634954
# 6 0.02405703 0.24425508 0.24543693
If I'm interpreting your question correctly, it seems like you'd need to redefine your function. To the best of my knowledge, you can't define an argument in the function definition as a function of another argument. You'd need to do that inside the body of the function. So you'd want something like this:
flight_sim <- function(userplot) {
if (userplot == "1") {
z <- seq(0, 20, pi / 32)
x <- sin(z)
y <- 1 - cos(z)
} else if (userplot == "2") {
z <- seq(0, 10, pi / 64)
x <- z * cos(6 * z)
y <- z * sin(6 * z)
} else if (userplot == "3") {
z <- seq(0, pi, pi / 399)
x <- sin(z) * cos(20 * z)
y <- sin(z) * sin(20 * z)
} else if (userplot == "4") {
x <- readline("Please enter a function for the x-value: ")
y <- readline("Please enter a function for the y-value: ")
z <- readline("Please enter a function for the z-value: ")
eval(parse(text = z)) # have to evaluate z first since x and y are functions of z
eval(parse(text = x))
eval(parse(text = y))
} else {
valid_response <- FALSE
while (!valid_response) {
userplot <- readline("Please enter a valid response (1-4): ")
if (userplot %in% 1:4) {
valid_response <- TRUE
flight_sim(userplot)
}
}
}
dat <- data.frame(x, y, z)
return(dat)
}
cat('Select the flight path you wish to plot from the list below :
1. Helix
2. Conical
3. Spherical
4. Define your own flight path...')
userplot <- readline('Enter number here : ') # Allow user to enter choice from above
dat <- flight_sim(userplot)
head(dat)
x y z
1 0.000000000000000000 0.000000000000000000 0.000000000000000000
2 0.046973698885313400 0.014249315773629733 0.049087385212340517
3 0.081629338302900922 0.054542980081485989 0.098174770424681035
4 0.093422122547587999 0.113835185692147969 0.147262155637021552
5 0.075139716235543288 0.181403322008714424 0.196349540849362070
6 0.024057025623845932 0.244255080177979672 0.245436926061702587
In the code above, I've also included one last else statement to catch inappropriate responses from your users. If they enter a choice that could break your code, it will now catch that and ask them to reenter their response.