R: Run a function until conditional test on the previous output of function is True for all rows

user_15390074 0
Viewed 89

I'm trying to write a script in R that repeats a conditional test or function until all values meet that condition. I can accomplish this by copying and pasting, but as we know this will get cumbersome. update I posted this earlier with made up data and a made up condition, but alas, I can't figure it out - here's the real thing: I'm trying to adjust the slope between multiple points in a row to create smooth row that meets the condition of less than 0.02

# initial info:

NS_max_slope <- 0.02
#NS = North-South slope. These values are positive. South-North slopes are negative. We're only checking NS slopes with this.

#the data
        Z   LF_IN_1 old_z_1 NS_slope    include
1   285.2573    NA  NA  NA  NA
2   285.2283    16.4147 285.2573    -0.001766709    -0.001766709
3   285.154 24.3543 285.2283    -0.003050796    -0.003050796
4   285.0791    24.3543 285.154 -0.003075432    -0.003075432
5   283 24.3544 285.0791    -0.085368558    -0.085368558
6   284.8716    19.0761 283 0.098112298 0.098112298
7   284.8364    19.0761 284.8716    -0.001845241    -0.001845241
8   284.788 24.3543 284.8364    -0.001987329    -0.001987329
9   284.7599    24.3544 284.788 -0.001153796    -0.001153796
10  284.9187    24.3543 284.7599    0.006520409 0.006520409
11  285 16.4147 284.9187    0.004952878 0.004952878
12  280 215.3846194 285 -0.023214285    NA

Function #1 - Check if the slope between the 2 points is failing. A failing slope is a slope greater than the NS_max_slope of 0.02


fail_slope <- c()
fail_slope_na <- c()
fail_slope_no <- c()
fail_slope_yes <- c()

slope_check <- function(slope){
    for (s in slope) {
        if (is.na(s)) {
            fail_slope_na <- NA
            fail_slope <- c(fail_slope, fail_slope_na)
        } else if (s <= NS_max_slope) {
            fail_slope_no <- "NO"
            fail_slope <- c(fail_slope, fail_slope_no)
        } else {
            fail_slope_yes <- "YES"
            fail_slope <- c(fail_slope, fail_slope_yes)
        }
    }
    return(fail_slope)
}

Function #2 - Adjust the elevation of the points if the slope (function #1) is failing.

new_slope <- c()
new_slope_na <- c()
new_slope_no <- c()
new_slope_yes <- c()
new_slope_counter <- 1

elev_adj <- function(data) {
    for (sf in data$slope_fail) {
        if (is.na(sf)) {
            new_slope_na <- data$Z[new_slope_counter]
            new_slope <- c(new_slope, new_slope_na)
            new_slope_counter <- new_slope_counter + 1
        } else if (sf == "NO") {
            new_slope_no <- data$Z[new_slope_counter]
            new_slope <- c(new_slope, new_slope_no)
            new_slope_counter <- new_slope_counter + 1
        } else {
            new_slope_yes <- lag_z[new_slope_counter] + data$LF_IN_1[new_slope_counter] * NS_max_slope
            new_slope <- c(new_slope, new_slope_yes)
            new_slope_counter <- new_slope_counter + 1
        }
    }
    return(new_slope)
}

Function #3 - apply the slope_check() and elev_adj() functions until the conditional tests of these functions are all satisfied. For example, the slope in row 6 is 0.098, this is much larger than the max NS slope of 0.02 so the elevation point Z, needs to be put in the elev_adj() function (the function will adjust it to 280.3283 the first time through). Once this elevation is adjusted, the slope in row 7 will now be failing from the slope_check() function, so it needs to be adjusted in the elev_adj() function, etc... until all the conditions are met.

elev_adjust <- function(data) {
    
    ## slope check for fail
    
    slope_check_df <- data %>% 
        mutate(slope_fail = slope_check(slope = include))
    
    # slope adjust

    iteration_1 <- slope_check_df %>% mutate(elev_adjust_1 = elev_adj(data = slope_check_df),
                                             elev_adjust_lag_1 = lag(elev_adjust_1),
                                             slope_adj_1 = (elev_adjust_1 - elev_adjust_lag_1) / LF_IN_1, 
                                             slope_check_1 = slope_check(slope_adj_1))
    
    iteration_1
}

I think the trick with this is that the functions rely on the previous row's data, which makes it difficult to calc in a straight-forward way. Thanks for your help on this and let me know if I'm not explaining it clearly.

Thanks!

tidyverse r
2 Answers

Recursion rowwise could work:

recursive_if <- function(x) {
  if (x<0) {
    cat(x,' ')
    recursive_if(x+0.25)
  } else {
    cat('done \n')
    NA
 }
}


df_1 <- df %>% rowwise() %>% mutate(test_1 = recursive_if(x))

#done 
#-1.324969  -1.074969  -0.8249694  -0.5749694  -0.3249694  -0.07496937  done 
#done 
#-0.2456965  done 
#-1.611627  -1.361627  -1.111627  -0.8616274  -0.6116274  -0.3616274  -0.1116274  done 
#-0.6212984  -0.3712984  -0.1212984  done 
#-0.7625072  -0.5125072  -0.2625072  -0.01250716  done 
#-1.480466  -1.230466  -0.9804658  -0.7304658  -0.4804658  -0.2304658  done 
#done 
#-0.8605357  -0.6105357  -0.3605357  -0.1105357  done
#...

df_1

       x test_1
    <dbl> <lgl> 
 1  0.777 NA    
 2 -1.32  NA    
 3  1.05  NA    
 4 -0.246 NA    
 5 -1.61  NA    
 6 -0.621 NA    
 7 -0.763 NA    
 8 -1.48  NA    
 9  0.815 NA    
10 -0.861 NA 
...
user_135133280

Why not just:

df <- data.frame(x = rnorm(20))

while(any(df < 0)) {
  cond <- df < 0
  df[cond] <- df[cond] + 0.25
  df[!cond] <- 1
}
df[df > 0] <- NA
user_139303890
Related