Add a condition for a function that has vectorized input - r

Question

I have the following function with the variables:
b <- 1 ; d_uhpc <- 4
L_joint <- 8 ; A_bar <- 0.31
A_s <- (A_bar/L_joint)*12
L_unb <- 16 ; f_t <- 1.2
E_s <- 29000 ; E_uhpc <- 8000
ec <- function(x){
theta <- x[3]
eci <- seq(10^-3,1,10^-3)
while (TRUE) {
fc <- eci * E_uhpc
c <- (sqrt(A_s^2 * E_s^2 * eci^2 + fc * A_s * E_s * b * d_uhpc *eci + b^2 * f_t^2 * d_uhpc^2) +
b * f_t * d_uhpc - A_s * E_s *eci)/(b * fc + 2 * b * f_t)
ec <- (-2*theta*c)/L_unb
if (eci > abs(ec)) return("Error") else return(ec)
}
}
# sample rows
strain.analysis <- read.table(text="
L S theta
1 60 6 0.3876484
2 70 6 0.3650651
3 80 6 0.3619457
4 90 6 0.3089947
5 100 6 0.3131211
6 110 6 0.3479024", header=TRUE)
strain.analysis1 <- cbind(strain.analysis, vars = t(apply(strain.analysis,1,ec)))
The function does not understand the conditions correctly and just returns ec for all of the eci values regardless of the condition that it should only return ec when eci < abs(ec)
Below is an example of what I am trying to recreate in R.

Answer 1

Here's what I am thinking: your return statements in the while loop are incorrect as they exit the function ec and not only the while loop. I think your are after break. When I ran your code, with the eci as vector fixed, it only performed one loop for each row in the dataset.
Also, as mentioned before, eci cannot be a vector of length 1000. It has to start at 1E-6 and increment every loop with 1E-6 (per the figure). Your exit criteria are complicated and as we do not know what 0in is it cannot be correctly reconstructed.
Finally, in apply you can call a user-defined function but you have to pass it something.
Having said that, is this what you are after?
b <- 1
d_uhpc <- 4
L_joint <- 8
A_bar <- 0.31
A_s <- (A_bar/L_joint)*12
L_unb <- 16
f_t <- 1.2
E_s <- 29000
E_uhpc <- 8000
eci <- 1E-6
ec <- function(x){
#browser()
theta <- x[3]
while (TRUE) {
fc <- eci * E_uhpc
c <- (sqrt(A_s^2 * E_s^2 * eci^2 + fc * A_s * E_s * b * d_uhpc *eci + b^2 * f_t^2 * d_uhpc^2) +
b * f_t * d_uhpc - A_s * E_s *eci)/(b * fc + 2 * b * f_t)
ec <- (-2*theta*c)/L_unb
if (eci > abs(ec)) break
eci <- eci + 1E-6
}
if (c > d_uhpc | ((max(c(abs(ec), eci), na.rm = TRUE))/(min(c(abs(ec), eci), na.rm = TRUE))) - 1 > 0.05) return(NA_real_) else return(ec)
}
v <- apply(strain.analysis, 1, function(x) ec(x))
strain.analysis1 <- cbind(strain.analysis, v)
The code loops many times for each row of strain,analysis until the break condition is met. Based on the value of ec and eci the function returns either a value of NA_real_.
Here's how my output looks like:
> strain.analysis1
L S theta v
1 60 6 0.3876484 -0.06845568
2 70 6 0.3650651 -0.06447493
3 80 6 0.3619457 -0.06392507
4 90 6 0.3089947 -0.05459143
5 100 6 0.3131211 -0.05531879
6 110 6 0.3479024 -0.06144967

Answer 2

This is a more vectorized approach - it calculates all ec at once and then determines which ec meets the criteria. This means it is fast although it can use up more memory than #Paul van Oppen's solution.
eci <- seq(10^-6,1,10^-6)
fc <- eci * E_uhpc
const <- (sqrt(A_s^2 * E_s^2 * eci^2 + fc * A_s * E_s * b * d_uhpc *eci + b^2 * f_t^2 * d_uhpc^2) +
b * f_t * d_uhpc - A_s * E_s *eci)/(b * fc + 2 * b * f_t)
ec <- function(x){
theta = x[3]
ec = (-2*theta*const)/L_unb
comp = eci > abs(ec)
if (any(comp)) { ## at least one of our eci > abs(ec)
wm = which.max(comp)
if (comp[wm] == FALSE) ##which.max(c(FALSE, FALSE)) will still return something. We need NA_real_ in this case
return (NA_real_)
else
return(ec[wm])
}
else
return(ec[length(x)])
}
cbind(strain.analysis, V = apply(strain.analysis,1,ec))
#> L S theta V
#> 1 60 6 0.3876484 -0.06845568
#> 2 70 6 0.3650651 -0.06447493
#> 3 80 6 0.3619457 -0.06392507
#> 4 90 6 0.3089947 -0.05459143
#> 5 100 6 0.3131211 -0.05531879
#> 6 110 6 0.3479024 -0.06144967