Appropriately using go to algorithm in R - r

I have an algorithm written as follows but I need to write that code into R. I have included the algorithm and the R code. I am not sure if that is represented well enough. To write the R code in the sequential order is not straight forward. I am sorry for not providing all the values of the variables here. I am not sure of the output yet which is the reason I am unable to show the required. It is more of a theoretical question.
Algorithm
VBDMAX = (va - VG) * 0.79 * (dep / D) ^ -1.21
VBOWMAX = -0.7 * VBDMAX
VBOWX = 0
' SKIP BOW IF -10D<X<15D OR OUTSIDE EDGE OF BARGES
If Y > B / 2 Then GoTo 200
If X < -10 * D Then GoTo 200
If X >= 15 * D Then GoTo 200
VBOWX = X * VBOWMAX / (10 * D) + VBOWMAX
If X <= 0 Then GoTo 200
VBOWX = X * (VBDMAX - VBOWMAX) / (5 * D) + VBOWMAX
If X <= 5 * D Then GoTo 200
VBOWX = -X * VBDMAX / (10 * D) + 15 * VBDMAX / 10
200 ' end bow
This is the R code that I have written
VBDMAX = (va - VG) * 0.79 * (dep / D) ^ -1.21
VBOWMAX = -0.7 * VBDMAX
VBOWX = 0
# SKIP BOW IF -10D<X<15D OR OUTSIDE EDGE OF BARGES
VBOWX <- ifelse ((Y>B/2 | X < -10*D | X>=15*D), 0,X*VBOWMAX/(10*D)+VBOWMAX)
VBOWX <- ifelse (X<=0 , X * (VBDMAX - VBOWMAX) / (5 * D) + VBOWMAX,
ifelse(x <=5*D, -X * VBDMAX / (10 * D) + 15 * VBDMAX / 10))

You can use ifelse constructs but you will need to nest those:
VBDMAX = (va - VG) * 0.79 * (dep / D) ^ -1.21
VBOWMAX = -0.7 * VBDMAX
VBOWX =
ifelse(Y > B / 2 || X < -10 * D || X >= 15 * D,
0,
ifelse(X <= 0,
X * VBOWX / (10 * D) + VBOWMAX,
ifelse(X <= 5 * D,
X * (VBDMAX - VBOWMAX) / (5 * D) + VBOWMAX,
-X * VBDMAX / (10 * D) + 15 * VBDMAX / 10
)
)
)

Understanding your question as how to translate "goto" statements to R, there are the following posibilities (if really needed) besides or in adjunction to the (often more appropriate) if/ifelse constructions as you already did:
a) entire code (for severe errors or if problem is solved): if (condition) stop("explain why...") or stopifnot(condition)
b) from within loops: see next and break
c) from within function: if (condition) return(), stopping the function here

Related

plotting Hamid Naderi Yeganehs parrot using ggplot

I am a) new to stackoverflow and b) an advanced beginner to R ;-)
i saw some bird artworks of Yeganeh with the associated functions in the web Drawing Birds in Flight With Mathematics and wanted to reproduce them in R to experiment a bit with colouring and so on.
However, while this one yielded a quite good result:
k <- 1:9830
X <- function(k) {
sin(pi * k / 20000) ^ 12 *
(0.5 * cos(31 * pi * k / 10000) ^ 16 *
sin(6 * pi * k / 10000) + (1 / 6 * sin(31 * pi * k / 10000)) ^ 20) +
3 * k / 20000 + cos(31 * pi * k / 10000) ^ 6 *
sin((pi / 2) * ((k - 10000) / 10000) ^ 7 - pi / 5)
}
Y <- function(k) {
-9 / 4 * cos(31 * pi * k / 10000) ^ 6 *
cos(pi / 2 * ((k - 10000) / 10000) ^ 7 - pi / 5) *
(2 / 3 + (sin(pi * k / 20000) * sin(3 * pi * k / 20000)) ^ 6) +
3 / 4 * cos(3 * pi * ((k - 10000) / 100000)) ^ 10 *
cos(9 * pi * ((k - 10000) / 100000)) ^ 10 *
cos(36 * pi * ((k - 10000) / 100000)) ^ 14 +
7 / 10 * ((k - 10000) / 10000) ^ 2
}
R <- function(k) {
sin(pi * k / 20000) ^ 10 *
(1 / 4 * cos(31 * pi * k / 10000 + 25 * pi / 32) ^ 20 +
1 / 20 * cos(31 * pi * k / 10000) ^ 2) +
1 / 30 * (3 / 2 - cos(62 * pi * k / 10000) ^ 2)
}
bird <- data.frame(x = X(k), y = Y(k), r = R(k))
library(tidyverse)
library(ggforce)
q <- ggplot() +
geom_circle(aes(x0 = x, y0 = y, r = r),
data = bird,
n = 30) +
coord_fixed() +
theme_void()
the following code yielded some weird result which should basically be related to the difference in the function. (x-A(k))+(y-B(k))=(R(k)) for the parrot below, whlie the bird above "simply" consisted of the k-th circle (X(k), Y(k)) and the radius of the k-th circle R(k)
k <- -10000:10000
A <- function(k) {
(3*k/20000)+(cos(37*pi*k/10000))*sin((k/10000)*(3*pi/5))+(9/7)*(cos(37*pi*k/10000))*(cos(pi*k/20000))*sin(pi*k/10000)
}
B <- function(k) {
(-5/4)*(cos(37*pi*k/10000))*cos((k/10000)*(3*pi/5))*(1+3*(cos(pi*k/20000)*cos(3*pi*k/20000)))+(2/3)*(cos(3*pi*k/200000)*cos(9*pi*k/200000)*cos(9*pi*k/100000))
}
R <- function(k) {
(1/32)+(1/15)*(sin(37*pi*k/10000))*((sin(pi*k/10000))+(3/2)*(cos(pi*k/20000)))
}
parrot <- data.frame(a = A(k), b = B(k), r = R(k))
q <- ggplot() +
geom_circle(aes(x0 = a, y0 = b, r = r),
data = parrot,
n=30) +
coord_fixed() +
theme_void()
q
Any help would be very much appreciated. Cartesian coords already applied as [explained here] (https://www.wikiwand.com/en/Hamid_Naderi_Yeganeh). From the visual point of view, it seems like the function is plotted properly but the "view" on it needs to be changed...
Thanks in advance!

Find maximum angle of box in slot

How would I find the maximum possible angle (a) which a rectangle of width (W) can be at within a slot of width (w) and depth (h) - see my crude drawing below
Considering w = hh + WW at the picture:
we can write equation
h * tan(a) + W / cos(a) = w
Then, using formulas for half-angles and t = tan(a/2) substitution
h * 2 * t / (1 - t^2) + W * (1 + t^2) / (1 - t^2) = w
h * 2 * t + W * (1 + t^2) = (1 - t^2) * w
t^2 * (W + w) + t * (2*h) + (W - w) = 0
We have quadratic equation, solve it for unknown t, then get critical angle as
a = 2 * atan(t)
Quick check: Python example for picture above gives correct angle value 18.3 degrees
import math
h = 2
W = 4.12
w = 5
t = (math.sqrt(h*h-W*W+w*w) - h) / (W + w)
a = math.degrees(2 * math.atan(t))
print(a)
Just to elaborate on the above answer as it is not necessarly obvious, this is why why you can write equation:
h * tan(a) + W / cos(a) = w
PS: I suppose that the justification for "why a is the maximum angle" is obvious

How to solve following system of equations

I've taken a few measurements of an LC circuit and I need to solve for both L and C based on that. How do I solve this?
2.675e6 = 1 / (2 * pi * sqrt(L * (C + 100e-9))
5.8e6 = 1 / (2 * pi * sqrt(L * C))
You need pencil and paper:
Equation #1
5.8e6 = 1 / (2 * pi * sqrt(L * C))
sqrt(L * C)= 1 / (2 * pi * 5.8e6 )
L*C = 1 / (2 * pi * 5.8e6 )^2
Equation #2
2.675e6 = 1 / (2 * pi * sqrt(L * (C + 100e-9))
sqrt(L * (C + 100e-9))= 1 / ( 2 *pi *2.675e6 )
L * (C + 100e-9) = 1 / ( 2 *pi *2.675e6 )^2
Subtract #1 from #2
L * (C + 100e-9) - L*C = 1 / ( 2 *pi *2.675e6)^2 - 1 / (2 * pi * 5.8e6 )^2
L * 100e-9 = 1 / ( 2 *pi *2.675e6)^2 - 1 / (2 * pi * 5.8e6 )^2
L = 1e7 * (1 / ( 2 *pi *2.675e6)^2 - 1 / (2 * pi * 5.8e6 )^2 )
and than from #1
C = ( 1 / (2 * pi * 5.8e6 )^2 ) / L

How to find where an equation equals zero

Say I have a function and I find the second derivative like so:
xyr <- D(expression(14252/(1+exp((-1/274.5315)*(x-893)))), 'x')
D2 <- D(xyr, 'x')
it gives me back as, typeof 'language':
-(14252 * (exp((-1/274.5315) * (x - 893)) * (-1/274.5315) * (-1/274.5315))/(1 +
exp((-1/274.5315) * (x - 893)))^2 - 14252 * (exp((-1/274.5315) *
(x - 893)) * (-1/274.5315)) * (2 * (exp((-1/274.5315) * (x -
893)) * (-1/274.5315) * (1 + exp((-1/274.5315) * (x - 893)))))/((1 +
exp((-1/274.5315) * (x - 893)))^2)^2)
how do I find where this is equal to 0?
A little bit clumsy to use a graph/solver for this, since your initial function as the form:
f(x) = c / ( 1 + exp(ax+b) )
You derive twice and solve for f''(x) = 0 :
f''(x) = c * a^2 * exp(ax+b) * (1+exp(ax+b)) * [-1 + exp(ax+b)] / ((1+exp(ax+b))^3)
Which is equivalent that the numerator equals 0 - since a, c, exp() and 1+exp() are always positive the only term which can be equal to zero is:
exp(ax+b) - 1 = 0
So:
x = -b/a
Here a =-1/274.5315, b=a*(-893). So x=893.
Just maths ;)
++:
from applied mathematician point of view, it's always better to have closed form/semi-closed form solution than using solver or optimization. You gain in speed and in accuracy.
from pur mathematician point of view, it's more elegant!
You can use uniroot after having created a function from your derivative expression:
f = function(x) eval(D2)
uniroot(f,c(0,1000)) # The second argument is the interval over which you want to search roots.
#Result:
#$root
#[1] 893
#$f.root
#[1] -2.203307e-13
#$iter
#[1] 7
#$init.it
#[1] NA
#$estim.prec
#[1] 6.103516e-05

Using lanczos low pass filter in R program

I am wondering if there is any package which allows us to use the Lanczos filter. I found other filters such as butterworth but I am looking for Lanczos low pass filter.
How different is Lanczos filter from butterworth filter ? Any suggestions or hints is appreciated.
Thanks.
Using the web I find this MATLAB implementation.
If you skipped the first part(arguments check), it looks simple to write its R equivalent.
# Cf - Cut-off frequency (default: half Nyquist)
# M - Number of coefficients (default: 100)
lanczos_filter_coef <- function(Cf,M=100){
lowpass_cosine_filter_coef <- function(Cf,M)
coef <- Cf*c(1,sin(pi*seq(M)*Cf)/(pi*seq(M)*Cf))
hkcs <- lowpass_cosine_filter_coef(Cf,M)
sigma <- c(1,sin(pi*seq(M)/M)/(pi*seq(M)/M))
hkB <- hkcs*sigma
hkA <- -hkB
hkA[1] <- hkA[1]+1
coef <- cbind(hkB, hkA)
coef
}
To test it for example:
dT <- 1
Nf <- 1/(2*dT)
Cf <- Nf/2
Cf <- Cf/Nf
lanczos_filter_coef(Cf,5)
hkB hkA
[1,] 5.000000e-01 5.000000e-01
[2,] 2.977755e-01 -2.977755e-01
[3,] 1.475072e-17 -1.475072e-17
[4,] -5.353454e-02 5.353454e-02
[5,] -4.558222e-18 4.558222e-18
[6,] 2.481571e-18 -2.481571e-18
PS I don't know very well MATLAB(used it many years ago), so I I used this link For the R/MATLAB analogy. I hope that someone with more R/MATLAB/Scilab knowledge can test my code.
I used the method provided in this link https://www.atmos.umd.edu/~ekalnay/syllabi/AOSC630/METO630ClassNotes13.pdf and wrote this function:
`
lanczos_weights<-function(window=101,sampl_rate=1,type="lowpass",low_freq=1/100,high_freq=1/10){
low_freq=sampl_rate*low_freq
high_freq=sampl_rate*high_freq
if (type=="lowpass"){
order = ((window - 1) %/% 2 ) + 1
nwts = 2 * order + 1
fc=low_freq
w = seq(0,0,length=nwts)
n = nwts %/% 2
w[n+1] = 2 * fc
k = seq(1, n-1)
sigma = sin(pi * k / n) * n / (pi * k)
firstfactor = sin(2 *pi * fc * k) / (pi * k)
w[n:2] = firstfactor * sigma
w[(n+2):(length(w)-1)] = firstfactor * sigma
w=w[-c(1,length(w))]}
else if (type=="highpass"){
order = ((window - 1) %/% 2 ) + 1
nwts = 2 * order + 1
fc=high_freq
w = seq(0,0,length=nwts)
n = nwts %/% 2
w[n+1] = 2 * fc
k = seq(1, n-1)
sigma = sin(pi * k / n) * n / (pi * k)
firstfactor = sin(2 *pi * fc * k) / (pi * k)
w[n:2] = firstfactor * sigma
w[(n+2):(length(w)-1)] = firstfactor * sigma
w=w[-c(1,length(w))]
w=-w
w[order]=1-2*fc }
else if (type=="bandpass"){
order = ((window - 1) %/% 2 ) + 1
nwts = 2 * order + 1
fc=low_freq
w = seq(0,0,length=nwts)
n = nwts %/% 2
w[n+1] = 2 * fc
k = seq(1, n-1)
sigma = sin(pi * k / n) * n / (pi * k)
firstfactor = sin(2 *pi * fc * k) / (pi * k)
w[n:2] = firstfactor * sigma
w[(n+2):(length(w)-1)] = firstfactor * sigma
w1=w[-c(1,length(w))]
order = ((window - 1) %/% 2 ) + 1
nwts = 2 * order + 1
fc=high_freq
w = seq(0,0,length=nwts)
n = nwts %/% 2
w[n+1] = 2 * fc
k = seq(1, n-1)
sigma = sin(pi * k / n) * n / (pi * k)
firstfactor = sin(2 *pi * fc * k) / (pi * k)
w[n:2] = firstfactor * sigma
w[(n+2):(length(w)-1)] = firstfactor * sigma
w2=w[-c(1,length(w))]
w=w2-w1}
else {print("Please specify a valid filter type: either 'lowpass', 'highpass' or 'bandpass'")}
return(w)}
`
#### the inputs are:
#### window: Filter length=number of weights. Corresponds to the total number of points to be lost. Should be odd: window=2N-1. The formula for N is taken from Poan et al. (2013)
#### sampl_rate: sampling rate=number of observation per time unit. ( eg: if time unit is one day, hourly data have sampl_rate=1/24)
#### type= one of "lowpass", "highpass" and "bandpass"
#### low_freq: the lowest frequency
#### high_freq: the highest frequency
I have compared my weights to those obtained using NCL filwgts_lanczos and they are exactly the same.

Resources