I wish to convert US Treasury Note futures prices to decimals (so 127-01+ = 127 + 1/32 + 1/64, and 127-01 1/4 = 127 + 1/32 + 1/128 etc).
I have had some success with cases where a fraction is present, but i'm failing when a fraction does not follow the big figure.
The source of the failure is that strsplit does not return an NA or empty object - so the order of the bits gets knocked about, and subsequent fractions are all wrong as a result.
Here's my case:
ty1 <- c("127-03", "126-31", "126-31+", "127-04+", "127-02+", "127-00+")
ty2 <- c("127-03", "126-31", "127-04+", "127-02+", "127-00+", "127",
"127-01 1/4", "128-01 3/4")
ty1_dec <- c(127+3/32, 126+31/32, 126+31/32+1/64, 127+4/32+1/64,
127+2/32+1/64, 127+0/32+1/64)
ty2_dec <- c(127+3/32, 126+31/32, 127+04/32+1/64, 127+2/32+1/64,
127+0/32+1/64, 127, 127+1/32+0/64+1/128, 128+1/32+1/64+1/128)
tFrac2Dec <-function(x){
hyphSplit <- strsplit(x, "-")
splitMatx <- matrix(unlist(hyphSplit), ncol=2, byrow=TRUE)
fracs <- t(apply(splitMatx[,2, drop=F], 1, function(X) substring(X, c(1,3), c(2,3))))
splitMatx[,2] <- (as.numeric(fracs[,1]) + ifelse(fracs[,2] == "+", 0.5, 0))/32
fracEval <- function(y){
eval(parse(text=paste(y[1], "+", y[2])))
}
apply(splitMatx,1,fracEval)
}
So things work for ty1 as all prices have - and a following fraction.
R> tFrac2Dec(ty1) == ty1_dec
[1] TRUE TRUE TRUE TRUE TRUE TRUE
R> tFrac2Dec(ty1)
[1] 127.0938 126.9688 126.9844 127.1406 127.0781 127.0156
But when there is a price that is only the big figure it fails.
> tFrac2Dec(ty2) == ty2_dec
Error in parse(text = paste(y[1], "+", y[2])) :
<text>:1:4: unexpected numeric constant
1: 01 1
^
In addition: Warning message:
In matrix(unlist(hyphSplit), ncol = 2, byrow = TRUE) :
data length [15] is not a sub-multiple or multiple of the number of rows [8]
I can see that it's due to the first strsplit step, but i cannot figure the solution. I've fiddled about with some if type solutions but nothing is working.
Is there a simple way to do this?
Something like this?
tFrac2Dec <- function(x) {
hyphSplit <- strsplit(x, "-")
ch1 <- sapply(hyphSplit,`[`, 1)
ch2 <- sapply(hyphSplit,`[`, 2)
x32 <- as.integer(substring(ch2, 1, 2))
x128 <- rep(0, length(ch1))
x128[grep("\\+$", ch2)] <- 2
x128[grep("1/4", ch2, fixed=TRUE)] <- 1
x128[grep("3/4", ch2, fixed=TRUE)] <- 3
dec <- x32/32 + x128/128
dec[is.na(dec)] <- 0
as.integer(ch1) + dec
}
tFrac2Dec(ty1)
## [1] 127.0938 126.9688 126.9844 127.1406 127.0781 127.0156
tFrac2Dec(ty2)
## [1] 127.0938 126.9688 127.1406 127.0781 127.0156 127.0000 127.0312
Related
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
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
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
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
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
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
I have a vector as follows:
playtimes <- c("1H18M20S", "1H27M5S", "18M27S", "56M38S", "21S")
and I want to convert these to playtimes in second. For example, the resulting vector would be something like this:
playtimeInSeconds <- c(4700, 5225, 1107, 3398, 21)
Im having trouble with separating the strings correctly based on the H, M and S. I wrote the following that works for the playtimes under 1 hour
minutes <- gsub("M.*", "", playtime)
seconds <- gsub(".*M", "", playtime) %>%
gsub("S", "", .)
totalPlaytime <- as.numeric(minutes)*60 + as.numeric(seconds)
But Im not sure how to tackle the H portion of some strings.
You could strsplit and adapt the length of the list elements reversely to 3 which allows you to use sapply to get a matrix where you apply the matrix product %*%.
m <- sapply(strsplit(p, 'H|M|S'), \(x) as.double(rev(`length<-`(rev(x), 3))))
res <- as.vector(t(replace(m, is.na(m), 0)) %*% rbind(3600, 60, 1))
res
# [1] 4700 5225 1107 3398 21
interesting problem. here is a solution that potentially could be more efficient but does the job
# function from https://www.statworx.com/de/blog/strsplit-but-keeping-the-delimiter/
strsplit <- function(x,
split,
type = "remove",
perl = FALSE,
...) {
if (type == "remove") {
# use base::strsplit
out <- base::strsplit(x = x, split = split, perl = perl, ...)
} else if (type == "before") {
# split before the delimiter and keep it
out <- base::strsplit(x = x,
split = paste0("(?<=.)(?=", split, ")"),
perl = TRUE,
...)
} else if (type == "after") {
# split after the delimiter and keep it
out <- base::strsplit(x = x,
split = paste0("(?<=", split, ")"),
perl = TRUE,
...)
} else {
# wrong type input
stop("type must be remove, after or before!")
}
return(out)
}
# convert to seconds
to_seconds <- c(H = 60 * 60,
M = 60,
S = 1)
get_seconds <- function(value, unit) {
value * to_seconds[unit]
}
# example vector
playtimes <- c("1H18M20S", "1H27M5S", "18M27S", "56M38S", "21S")
# extract time parts
times <- strsplit(playtimes,
split = "[A-Z]",
type = "after")
times
#> [[1]]
#> [1] "1H" "18M" "20S"
#>
#> [[2]]
#> [1] "1H" "27M" "5S"
#>
#> [[3]]
#> [1] "18M" "27S"
#>
#> [[4]]
#> [1] "56M" "38S"
#>
#> [[5]]
#> [1] "21S"
# calculate each time in seconds
sapply(times,
function(t) {
# split numeric and unit part
t_split <- strsplit(x = t,
split = "[A-Z]",
type = "before")
# calculate seconds for each unit part
times_in_seconds <- get_seconds(value = as.numeric(sapply(t_split, `[`, 1)),
unit = sapply(t_split, `[`, 2))
# sum of all parts
sum(times_in_seconds)
})
#> [1] 4700 5225 1107 3398 21
I followed the example given in the 3rd answer here and made the following
playtime <- sapply(playtime, function(x){paste(paste(rep(0, 3 - str_count(x, '[0-9]+')), collapse = ' '), x)})
totalPlaytime <- time_length(hms(playtime))
Short, sweet, and checks for potential errors where the playtime is less that 1 hr or less than 1 min.
I'm trying to solve this equation: ((2300+1900*1)+(x+2300+1900*1)*0.002)/(600-400) =1
Is there a way to do this with R?
ATTEMPT with incorrect solution:
library(Ryacas)
eq <- "((2300+1900*1)+(x+2300+1900*1)*0.002)/(600-400) ==1 "
# simplify the equation:
library(glue)
yac_str(glue("Simplify({eq})"))
library(evaluate)
evaluate(eq,list(x=c(0,1,10,100,-100)))
evaluate() just returns the equation:
"((2300+1900*1)+(x+2300+1900*1)*0.002)/(600-400) ==1 "
The answer for the equation is −2004200
It sounds like you want to Solve() for x rather than merely simplifying ... ? The following code solves the equation, strips off the x== from the solution, and evaluates the expression:
eq2 <- gsub("x==","",yac_str(glue("Solve({eq},x)")))
[1] "{(-0.80168e6)/0.4}"
eval(parse(text=eq2))
[1] -2004200
1) Ryacas Use the Ryacas package solve as shown below. (Thanks to #mikldk for improvement to last line.)
library(Ryacas)
eq <- "((2300+1900*1)+(x+2300+1900*1)*0.002)/(600-400) ==1 " # from question
res <- solve(ysym(eq), "x")
as_r(y_rmvars(res)) # extract and convert to R
## [1] -2004200
if eq has R variables in it, here h is referenced in eq2, then use eval to evaluate the result.
h <- 2300
eq2 <- "((h+1900*1)+(x+2300+1900*1)*0.002)/(600-400) ==1 " # from question
res2 <- solve(ysym(eq2), "x")
eval(as_r(y_rmvars(res2)))
## [1] -2004200
2) Ryacas0 or using eq from above with the Ryacas0 package:
library(Ryacas0)
res <- Solve(eq, "x")
eval(Expr(res)[[1:3]]) # convert to R
## [1] -2004200
3a) Base R In light of the fact that this is a linear equation and the solution to the following where A is the slope and B is the intercept:
A * x + B = 0
is
x = - B / A
if we replace x with the imaginary 1i and then move the rhs to the lhs we have that B and A are the real and imaginary parts of that expression. No packages are used.
r <- eval(parse(text = sub("==", "-", eq)), list(x = 1i))
-Re(r) / Im(r)
## [1] -2004200
3b) If we move the rhs to lhs then B equals it at x=0 and A equals the derivative wrt x so another base R solution would be:
e <- parse(text = sub("==", "-", eq))
- eval(e, list(x = 0)) / eval(D(e, "x"))
## [1] -200420
Here is a base R solution.
Rewrite the equation in the form of a function, use curve to get two end points where the function has different signs and put uniroot to work.
f <- function(x) ((2300+1900*1)+(x+2300+1900*1)*0.002)/(600-400) - 1
curve(f, -1e7, 1)
uniroot(f, c(-1e7, 1))
#$root
#[1] -2004200
#
#$f.root
#[1] 0
#
#$iter
#[1] 1
#
#$init.it
#[1] NA
#
#$estim.prec
#[1] 7995800
Following the discussion in the comments to the question, here is a general solution. The function whose roots are to be found now accepts an argument params in order to pass the values of rent, salary, number of workers, price, unit cost and capital cost. This argument must be a named list.
f <- function(x, K = 1, params) {
A <- with(params, rent + salary*workers)
with(params, (A + (x + A)*capitalcost)/(price - unitcost) - K)
}
params <- list(
rent = 2300,
salary = 1900,
workers = 1,
price = 600,
unitcost = 400,
capitalcost = 0.002
)
curve(f(x, params = params), -1e7, 1)
uniroot(f, c(-1e7, 1), params = params)
If you want something quick: rootSolve library is your go-to.
library(rootSolve)
func_ <- function(x) ((2300+1900*1)+(x+2300+1900*1)*0.002)/(600-400)-1
uniroot.all(func_, c(-1e9, 1e9))
[1] -2004200
Note that most of the time reducing the interval is better.
If you will maintain the same structure, then in Base R, you could do:
solveX <- function(eq){
U <- function(x)abs(eval(parse(text = sub("=+","-", eq)), list(x=x)))
optim(0, U, method = "L-BFGS-B")$par
}
eq <- "((2300+1900*1)+(x+2300+1900*1)*0.002)/(600-400) ==1 "
solveX(eq)
[1] -2004200
For instance, how to convert the number '10010000110000011000011111011000' in Base2 to number in Base4 ?
Here is one approach that breaks up the string into units of length 2 and then looks up the corresponding base 4 for the pair:
convert <- c("00"="0","01"="1","10"="2","11"="3")
from2to4 <- function(s){
if(nchar(s) %% 2 == 1) s <- paste0('0',s)
n <- nchar(s)
bigrams <- sapply(seq(1,n,2),function(i) substr(s,i,i+1))
digits <- convert[bigrams]
paste0(digits, collapse = "")
}
A one-liner approach:
> paste(as.numeric(factor(substring(a,seq(1,nchar(a),2),seq(2,nchar(a),2))))-1,collapse="")
[1] "2100300120133120"
There are multiple ways to split the string into 2 digits, see Chopping a string into a vector of fixed width character elements
Here are a couple inverses:
bin_to_base4 <- function(x){
x <- strsplit(x, '')
vapply(x, function(bits){
bits <- as.integer(bits)
paste(2 * bits[c(TRUE, FALSE)] + bits[c(FALSE, TRUE)], collapse = '')
}, character(1))
}
base4_to_bin <- function(x){
x <- strsplit(x, '')
vapply(x, function(quats){
quats <- as.integer(quats)
paste0(quats %/% 2, quats %% 2, collapse = '')
}, character(1))
}
x <- '10010000110000011000011111011000'
bin_to_base4(x)
#> [1] "2100300120133120"
base4_to_bin(bin_to_base4(x))
#> [1] "10010000110000011000011111011000"
...and they're vectorized!
base4_to_bin(bin_to_base4(c(x, x)))
#> [1] "10010000110000011000011111011000" "10010000110000011000011111011000"
For actual use, it would be a good idea to put in some sanity checks to ensure the input is actually in the appropriate base.
Convert Base2 to Base10 first, then from Base10 to Base4
I have a dataset with a column composed by numbers
dati$score[10:15]
[1] 7576 6362 764663 676164 764676 6364
I have this function which calculates the sums of the number in a cell which i found here on stackoverflow and works when i apply it singularly
digitsum <- function(x) sum(floor(x / 10^(0:(nchar(x) - 1))) %% 10)
I can't apply this to the column dati$score, i get this error, i've tried using lapply and a for cycle
for (i in 1:lunghscore){
f <- dati[i,"score"]
post <- sum(floor(f / 18^(0:(nchar(f) - 1))) %% 18)
dati[i,"score"] <- post
i <- i + 1
}
lapply
dati[,"score"] <- lapply(X = dati[,"score"],FUN = digitsum)
I get this error
2: In `[<-.data.frame`(`*tmp*`, , "score", value = list(20, 17, 26, :
provided 66121 variables to replace 1 variables
How can i apply the function digitsum to every cell in that column?
The problem is that the output of a list is always a list, and you fill a vector with elements of a list. Your code works if you unlist your lapply function as shown in the pet example below:
> digitsum <- function(x) sum(floor(x / 10^(0:(nchar(x) - 1))) %% 10)
> dati <- data.frame(matrix(250:255, ncol = 2))
> dati
X1 X2
1 250 253
2 251 254
3 252 255
> lapply(dati[, "X2"], digitsum)
[[1]]
[1] 10
[[2]]
[1] 11
[[3]]
[1] 12
> dati[, "X2"]<-lapply(dati[, "X2"], digitsum)
Warning message:
In `[<-.data.frame`(`*tmp*`, , "X2", value = list(10, 11, 12)) :
provided 3 variables to replace 1 variables
And the solution:
> dati[, "X2"]<-unlist(lapply(dati[, "X2"], digitsum))
Best, Thomas