Add 1 to the first even digit in a srting

user_5821742 0
Viewed 136

I have a vector of numeric values in R

x <- c(4320, 5400, 6786)

For each of this values I want to get a new value, where I sum 1 to the first non 0 even digit (starting from the right). The resulting vector should be:

[1] 4330  5500  6787

I haven't made any progresses so far. For numbers with only four digits, as in the example, I guess this could be accomplished with stringr and ifelse statements, iterating through each digit. But I was looking for a more general solution.

EDIT
Additionally I also want to convert all the digits to the right of the focal number to 0. So I build on one of the solutions by @onyambu to get a slightly modified version.

x <- c(432095, 540100, 678507)

fun <- function(x){
  y <- max(which(as.numeric(x) %%2 == 0 & x!='0'))
  x[y]<- as.numeric(x[y]) + 1
  x[(y+1):length(x)] <- 0 # line added to convert digits to the right to 0
  as.numeric(paste0(x, collapse=''))
}

y = sapply(strsplit(as.character(x), ''), fun)
print(y)
[1] 433000 550000 679000
r
5 Answers

Using Recursion and only numerical operations:

fun <- function(x, ten_times = 0, rem=0 ){
  if(floor(x/10) == x/10) # is divisible by 10? remove the zero
      Recall(x/10, ten_times + 1, rem)
  else if (x%%2 == 1) # is odd remove the odd and store it go to next digit
      Recall(x%/%10, ten_times+1, rem + (x%%10)*10^ten_times)
  else  # add one to the even and also add back the remainder to the number
     (x + 1) * 10^ten_times + rem
}

sapply(x, fun)
[1] 4330 5500 6787

Note that we could use vectorized ifelse with the same logic above to carry out the operation in a vectorized manner. Though you might want to increase the recursion depth. Probably stick with the non-vectorized version above and the use sapply

fun <- function(x, ten_times = 0, rem=0 ){
  ifelse(floor(x/10) == x/10, Recall(x/10, ten_times + 1, rem),
    ifelse(x%%2 == 1, Recall(x%/%10, ten_times+1, rem + (x%%10)*10^ten_times),
         (x+1)*10^ten_times + rem))
}

fun(x)
[1] 4330 5500 6787

Note that this will throw an error if the number is purely made up of non-even numbers. eg fun(1111) will throw an error.

EDIT:

If you need all the values after the even number to be zero, change this into:

fun <- function(x, ten_times = 0){
  if(floor(x/10) == x/10) Recall(x/10, ten_times + 1)
  else if (x%%2 == 1)Recall(x%/%10, ten_times+1)
  else (x + 1) * 10^ten_times
}

sapply(x, fun)
[1] 433000 550000 679000

Also seems like a ceiling problem:

y <- sapply(strsplit(as.character(x),''), 
         \(x)max(which(!as.numeric(x) %% 2 & x!='0'))) - nchar(x)

ceiling(x * 10^y)/10^y
[1] 433000 550000 679000
user_83802720 
fun <- function(x){
    y <- max(which(as.numeric(x) %%2 == 0 &x!='0'))
    x[y]<- as.numeric(x[y]) + 1
    as.numeric(paste0(x, collapse=''))
}

 sapply(strsplit(as.character(x), ''), fun)
[1] 4330 5500 6787
user_83802720

Try this function

fn <- function(x) {
    y <- x ; add <- 1
    while(x != 0){
        if(x %% 10 != 0 & x %% 2 == 0 ) {
            y <- y + add
            break
        }
        x <- floor(x/10)
        add <- add * 10
    }
    y
}
fn <- Vectorize(fn)
fn(x)

#> [1] 4330 5500 6787
user_191983370

Another possible solution:

library(tidyverse)

str_split(x, "", simplify = T) %>% 
  type.convert(as.is = T) %>% 
  apply(1, \(x) {which.max(cumsum(x %% 2 == 0 & x != 0)) %>%
      {x[.] <<- x[.] + 1}; x %>% str_c(collapse = "") %>% parse_integer}) 

#> [1] 4330 5500 6787
user_115644870

1) gsubfn Using gsubfn we can get a 2 line solution. gsubfn is like gsub except the second argument can be a function, possibly expressed in formula notation instead of a replacement string. The match to each capture group (portion in parenthesis) in the regular expression is passed as a separate argument to the function and the result is the output of the function.

In this case there are 3 capture groups which represent the prefix (p), the digit (d) and the suffix (s). The formula representation of the function is the body and the arguments are the free variables in the body in the order encountered.

library(gsubfn)

x1 <- c(4320, 5400, 6786)

f1 <- ~ paste0(p, as.numeric(d) + 1, s)
gsubfn("(.*)([2468])(.*)", f1, as.character(x1)) |> as.numeric()
## [1] 4330 5500 6787

To do that plus replace remaining characters after the transformed one to zero

x2 <- c(432095, 540100, 678507)

f2 <- ~ paste0(p, as.numeric(d) + 1, gsub(".", 0, s))
gsubfn("(.*)([2468])(.*)", f2, as.character(x2)) |> as.numeric()
## [1] 433000 550000 679000

2) Base R This base R solution extracts the prefix, digit and suffix using sub and then transforms the digit and pastes them back together.

pat <- "(.*)([2468])(.*)"
as.numeric(paste0(
  sub(pat, "\\1", x1), 
  as.numeric(sub(pat, "\\2", x1)) + 1, 
  sub(pat, "\\3", x1)
))
## [1] 4330 5500 6787

or performing the same operation and zeroing out the suffix:

pat <- "(.*)([2468])(.*)"
as.numeric(paste0(
  sub(pat, "\\1", x2), 
  as.numeric(sub(pat, "\\2", x2)) + 1, 
  gsub(".", 0, sub(pat, "\\3", x2))
))
## [1] 433000 550000 679000
user_5165480
Related