I'm writing some code in R in order to determine an optimal estimator for ai given any tolerance. So far, I've come up with this:
iter<- function (ai, k, tolerance){
at = ai*(1-ai^2*R[k]^ai*(log(R[k]))^2/(1-R[k]^ai)^2)/
(1 - (ai^2*R[k]^ai*(log(R[k]))^2)/(1-R[k]^ai)^2 + ai*(H(k)
- 1/ai - R[k]^ai*log(R[k])/(1-R[k]^ai)))
while((at-ai) > tolerance) {
ai = at
at = ai*(1-ai^2*R[k]^ai*(log(R[k]))^2/(1-R[k]^ai)^2)/
(1 - (ai^2*R[k]^ai*(log(R[k]))^2)/(1-R[k]^ai)^2 + ai*(H(k)
- 1/ai - R[k]^ai*log(R[k])/(1-R[k]^ai)))
a0 = at
}
return(at)
}
x<- iter(ai = H(k), k, tolerance = 0.000001)
where R and H are known variables for every k and also an initial estimator for ai is known, namely H(k). This code works fine for any value of k, for example,
x<- iter(ai = H(k), 21, tolerance = 0.000001)
gives a good result. However, my problem is, that when I try to embed this in a for-loop (I actually want a vector x[k] where every iteration for k is calculated), i.e. :
for (k in seq (along = 1: (n-1)){
x<- iter(ai = H(k), 21, tolerance = 0.000001)
}
this code doesn't give me a vector, but instead it gives one value for x. That doesn't make much sense to me, as I'm trying to assign a value to x for every possible k. What am I missing here?
As always, any help would be dearly appreciated.
Since you want a vector, x should be a vector.
x<-numeric(n-1)
for (k in seq (along = 1: (n-1)){
x[k]<- iter(ai = H(k), 21, tolerance = 0.000001)
}
Related
I am trying to calculate Sigma(n=0 to infinity) (−1)^n/(n + 1) as accurately as possible. But my code takes forever and I am not able to see whether my answer is right. Does anyone know how I can make my code faster? The sum is supposed to converge to log(2). My idea is that f(n) will eventually become a very small number (less than 2^-52) and a time would come when R would consider sum = sum + f(n) and that's when I'd want the code to stop running. But clearly, that doesn't seem to work and my code takes forever to run and at least to me, it doesn't seem to ever stop.
f <- function(n)
return(((-1)^(n))/(n+1))
s <- function(f){
sum <- 0
n <- 0
while(sum != sum + f(n)) {
sum <- sum + f(n)
n <- n + 1
}
return(c(sum, n))
}
s(f)
library(Rcpp)
cppFunction("
List s(int max_iter) {
double sum = 0;
double sum_prec=NA_REAL;
double n = 0;
for (;sum != sum_prec && n < max_iter;n++) {
sum_prec = sum;
sum+=pow(-1,n)/(n+1);
}
return List::create(
_[\"sum\"] = sum,
_[\"iterations\"] = n,
_[\"precision\"] = sum-sum_prec
) ;
}")
test <- s(100000000)
test
When you use a huge number of subsequent iterations you know that R is not appropriated. However C++ functions are very easy to use within R. You can do something like that by example. The function needs a max of iterations and returns a list with your sum, the number of iterations and the precision.
EDIT : By precision I only do sum-sum_prec so this is not the real interval.
EDIT 2 : I let the sum != sum_prec for the example but if you don't have a supercomputer you're not supposed to see the end lol
EDIT 3 :
Typically, a fast R base solution would be something like :
base_sol <- function(n_iter) {
v <- seq_len(n_iter)
v <- (-1L)^(v-1L)/v
list(
sum = sum(v),
iterations = n_iter,
precision = v[length(v)]
)
}
Which is only 1.5 times slower than c++, which is pretty fast for an interpreted language, but has the con of loading every member of the sum in ram (but then, R is made for stats not for calculating things at 2^-52)
I'm having trouble to find the root of a parameterized quintic polynome. Background is: I want to find the parameter s_f such that for any given parameter d_f, the curvature of the polynomial is smaller than a threshold (yeah .. sounds complex, but the math is rather straight);
# define quintic polynomial (jerk-minimized trajectory)
# see http://courses.shadmehrlab.org/Shortcourse/minimumjerk.pdf
s = symbols('s', real=True, positive=True)
s_f = symbols('s_f', real=True, positive=True, nonzero=True)
d_0 = 0
d_f = symbols('d_f', real=True, positive=True, nonzero=True)
d_of_s = d_0 + (d_f - d_0) * ( 10*(s/s_f)**3 - 15*(s/s_f)**4 + 6*(s/s_f)**5 )
display(d_of_s)
# define curvature of d_of_s
# see https://en.wikipedia.org/wiki/Curvature#In_terms_of_a_general_parametrization
y = d_of_s
dy = diff(d_of_s, s)
ddy = diff(dy, s)
x = s
dx = diff(x, s) # evaluates to 1
ddx = diff(dx, s) # evaluates to 0
k = (dx*ddy - dy*ddx) / ((dx*dx + dy*dy)**Rational(3,2))
# the goal is to find s_f for any given d_f, such that k(s) < some_threshold
# strategy: find the roots of the derivative of k in the range of s∈[0, s_f]
dk = diff(k, s)
dk = simplify(dk)
display(dk)
# now solve
res = solveset(dk, s, Interval(0, s_f).intersection(S.Reals))
display(res)
The function dk(s, d_f, s_f) has two root in the interval s∈[0, s_f], however solveset returns this:
ConditionSet(s, Eq(5400*d_f**2*s**4*(-s**2 + 2*s*s_f - s_f**2)*(2*s**2 - 3*s*s_f + s_f**2)**2 + (900*d_f**2*s**4*(s**2 - 2*s*s_f + s_f**2)**2 + s_f**10)*(6*s**2 - 6*s*s_f + s_f**2), 0), Interval(0, s_f))
.. which is afaik equivalent to: I can't solve this, we got infinite number of results. Well, this is true for the function in general. limit(dk, s, -oo) and limit(dk, s, +oo) is zero. But since I stated the domain interval, why am I not getting the two roots I'm expecting? I'd also expect to get a more granular result:
set containing the roots for s < 0;
set containing the roots for s > s_f
the two roots when s∈[0, s_f]
I started with solve() and a lot of different assumptions on my symbols. I get different results for different assumptions, but no combination seems to yield what I need. When I state no assumptions, I get back a set with a huge condition and 8 roots, that don't seem real or correct. In general, the constraints are:
- all symbols are real
- s_f > 0
- d_f > 0
- s ∈ [0, s_f] (domain range .. the polynomial is only evaluated in this interval)
I guess the problem is that I'm not setting up my solveset correctly:
how to specify that s_f and d_f are real? afaik the symbol
assumptions are ignored when using solveset?
how to specify intervals
and assumptions on other multivariate functions, i.e. other symbols
than the domain one?
This is what d_of_s look like for s_f = 1, d_f = 1
And this is what dk(s) looks like (I plotted outside the domain range to visualize the problem).
Substitute in the known values of d_f and s_f and use real_roots to find the real roots of the numerator of dk. Keep the ones that have a value in the range of interest:
>>> s_fi = 3
>>> [i for i in real_roots(dk.subs(d_f,2).subs(s_f, s_fi).as_numer_denom()[0])
... if 0 <= i.n(2) <= s_fi]
[CRootOf(800*s**10 - 12000*s**9 + 74000*s**8 - 240000*s**7 + 432000*s**6 - 410400*s**5
+ 162000*s**4 - 4374*s**2 + 13122*s - 6561, 1), CRootOf(800*s**10 - 12000*s**9 +
74000*s**8 - 240000*s**7 + 432000*s**6 - 410400*s**5 + 162000*s**4 - 4374*s**2 +
13122*s - 6561, 2)]
I kept the CRootOf instances because they can be computed to arbitrary precision, e.g. to 3 digits:
>>> [i.n(3) for i in _]
[0.433, 2.57]
I want to create a polynomial with given coefficients. This seems very simple but what I have found till now did not appear to be the thing I desired.
For example in such an environment;
n = 11
K = GF(4,'a')
R = PolynomialRing(GF(4,'a'),"x")
x = R.gen()
a = K.gen()
v = [1,a,0,0,1,1,1,a,a,0,1]
Given a list/vector v of length n (I will set this n and v at the begining), I want to get the polynomial v(x) as v[i]*x^i.
(Actually after that I am going to build the quotient ring GF(4,'a')[x] /< x^n-v(x) > after getting this v(x) from above) then I will say;
S = R.quotient(x^n-v(x), 'y')
y = S.gen()
But I couldn't write it.
This is a frequently asked question in many places so it is better to leave it here as an answer although the answer I have is so simple:
I just wrote R(v) and it gave me the polynomial:
sage
n = 11
K = GF(4,'a')
R = PolynomialRing(GF(4,'a'),"x")
x = R.gen()
a = K.gen()
v = [1,a,0,0,1,1,1,a,a,0,1]
R(v)
x^10 + a*x^8 + a*x^7 + x^6 + x^5 + x^4 + a*x + 1
Basically (that is, ignoring the specifics of your polynomial ring) you have a list/vector v of length n and you require a polynomial which is the sum of all v[i]*x^i. Note that this sum equals the matrix product V.X where V is a one row matrix (essentially equal to the vector v) and X is a column matrix consisting of powers of x. In Maxima you could write
v: [1,a,0,0,1,1,1,a,a,0,1]$
n: length(v)$
V: matrix(v)$
X: genmatrix(lambda([i,j], x^(i-1)), n, 1)$
V.X;
The output is
x^10+ax^8+ax^7+x^6+x^5+x^4+a*x+1
So, I'm supposed to write the code to execute Newton's Method to calculate the square root of any arbitrary number to a specified precision (tolerance).
Here is my code:
MySqrt <- function(x, eps = 1e-6, itmax = 100, verbose = TRUE) {
GUESS <- 11
myvector <- integer(0)
i <- 1
if (x < 0) {
stop("Square root of negative value")
}
else {
myvector[i] <- GUESS
while (i <= itmax) {
GUESS <- (GUESS + (x/GUESS)) * 0.5
myvector[i+1] <- GUESS
if (abs(GUESS-myvector[i]) < eps) {
break()
}
if (verbose) {
cat("Iteration: ", formatC(i, width = 1), formatC(GUESS, digits = 10, width = 12), "\n")
}
i <- i + 1
}
}
myvector[i]
}
eps is the tolerance. When I use the function to calculate the square root of, say, 21, I got this as an output:
> MySqrt(21, eps = 1e-1, verbose = TRUE)
Iteration: 1 6.454545455
Iteration: 2 4.854033291
Iteration: 3 4.59016621
I'm not sure if the function stops carrying out iterations when it is supposed to, however. Can someone verify if my code is correct? This would be greatly appreciated!
Your code is almost correct. It is iterating the correct number of times. The only bug is that you don't increment i until after the break statement, so you are not returning the most recent approximation. Instead you are returning the previous one.
In order to verify that it is stopping at the right time, you can move the tracing line up above the break. You can also add GUESS-myvector[i] to the trace, so you can watch it halt as soon as the difference gets small enough. If you do this and run the function, the fact that it is stopping at the right time, as well as the fact that it is returning the wrong value, will be obvious:
> MySqrt(21,eps=1e-1)
Iteration: 1 6.454545 -4.545455
Iteration: 2 4.854033 -1.600512
Iteration: 3 4.590166 -0.2638671
Iteration: 4 4.582582 -0.007584239
[1] 4.590166
While your code is (almost) correct, it is not written in very good R style. For example, unless you want to return the entire vector of estimates, there is no reason that you need to keep them all around. Also, rather than using a while loop, here it would make more sense to use a for loop. Here one possible improved version of your function:
MySqrt <- function(x, eps = 1e-6, itmax = 100, verbose = TRUE) {
GUESS <- 11
if (x < 0) {
stop("Square root of negative value")
}
for(i in 1:itmax){
nextGUESS <- (GUESS + (x/GUESS)) * 0.5
if (verbose)
cat("Iteration: ", i, nextGUESS, nextGUESS-GUESS, "\n")
if (abs(GUESS-nextGUESS) < eps)
break
GUESS<- nextGUESS
}
nextGUESS
}
I've just been working though converting some MATLAB scripts to work in R, however having never used MATLAB in my life, and not exactly being an expert on R I'm having some trouble.
Edit: It's a script I was given designed to correct temperature measurements for lag generated by insulation mass effects. My understanding is that It looks at the rate of change of the temperature and attempts to adjust for errors generated by the response time of the sensor. Unfortunately there is no literature available to me to give me an indication of the numbers i am expecting from the function, and the only way to find out will be to experimentally test it at a later date.
the original script:
function [Tc, dT] = CTD_TempTimelagCorrection(T0,Tau,t)
N1 = Tau/t;
Tc = T0;
N = 3;
for j=ceil(N/2):numel(T0)-ceil(N/2)
A = nan(N,1);
# Compute weights
for k=1:N
A(k) = (1/N) + N1 * ((12*k - (6*(N+1))) / (N*(N^2 - 1)));
end
A = A./sum(A);
# Verify unity
if sum(A) ~= 1
disp('Error: Sum of weights is not unity');
end
Comp = nan(N,1);
# Compute components
for k=1:N
Comp(k) = A(k)*T0(j - (ceil(N/2)) + k);
end
Tc(j) = sum(Comp);
dT = Tc - T0;
end
where I've managed to get to:
CTD_TempTimelagCorrection <- function(temp,Tau,t){
## Define which equation to use based on duration of lag and frequency
## With ESM2 profiler sampling # 2hz: N1>tau/t = TRUE
N1 = Tau/t
Tc = temp
N = 3
for(i in ceiling(N/2):length(temp)-ceiling(N/2)){
A = matrix(nrow=N,ncol=1)
# Compute weights
for(k in 1:N){
A[k] = (1/N) + N1 * ((12*k - (6*(N+1))) / (N*(N^2 - 1)))
}
A = A/sum(A)
# Verify unity
if(sum(A) != 1){
print("Error: Sum of weights is not unity")
}
Comp = matrix(nrow=N,ncol=1)
# Compute components
for(k in 1:N){
Comp[k] = A[k]*temp[i - (ceiling(N/2)) + k]
}
Tc[i] = sum(Comp)
dT = Tc - temp
}
return(dT)
}
I think the problem is the Comp[k] line, could someone point out what I've done wrong? I'm not sure I can select the elements of the array in such a way.
by the way, Tau = 1, t = 0.5 and temp (or T0) will be a vector.
Thanks
edit: apparently my description is too brief in explaining my code samples, not really sure what more I could write that would be relevant and not just wasting peoples time. Is this enough Mr Filter?
The error is as follows:
Error in Comp[k] = A[k] * temp[i - (ceiling(N/2)) + k] :
replacement has length zero
In addition: Warning message:
In Comp[k] = A[k] * temp[i - (ceiling(N/2)) + k] :
number of items to replace is not a multiple of replacement length
If you write print(i - (ceiling(N/2)) + k) before that line, you will see that you are using incorrect indices for temp[i - (ceiling(N/2)) + k], which means that nothing is returned to be inserted into Comp[k]. I assume this problem is due to Matlab allowing the use of 0 as an index and not R, and the way negative indices are handled (they don't work the same in both languages). You need to implement a fix to return the correct indices.