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!
Related
I have this code for n = 4
b_11 <- (1 / 2) * (wi[1] - wi[1] + 1); b_11
b_12 <- (1 / 2) * (wi[1] - wi[2] + 1); b_12
b_13 <- (1 / 2) * (wi[1] - wi[3] + 1); b_13
b_14 <- (1 / 2) * (wi[1] - wi[4] + 1); b_14
b_21 <- (1 / 2) * (wi[2] - wi[1] + 1); b_21
b_22 <- (1 / 2) * (wi[2] - wi[2] + 1); b_22
b_23 <- (1 / 2) * (wi[2] - wi[3] + 1); b_23
b_24 <- (1 / 2) * (wi[2] - wi[4] + 1); b_24
b_31 <- (1 / 2) * (wi[3] - wi[1] + 1); b_31
b_32 <- (1 / 2) * (wi[3] - wi[2] + 1); b_32
b_33 <- (1 / 2) * (wi[3] - wi[3] + 1); b_33
b_34 <- (1 / 2) * (wi[3] - wi[4] + 1); b_34
b_41 <- (1 / 2) * (wi[4] - wi[1] + 1); b_41
b_42 <- (1 / 2) * (wi[4] - wi[2] + 1); b_42
b_43 <- (1 / 2) * (wi[4] - wi[3] + 1); b_43
b_44 <- (1 / 2) * (wi[4] - wi[4] + 1); b_44
trB <- c(b_11, b_12, b_13, b_14,
b_21, b_22, b_23, b_24,
b_31, b_32, b_33, b_34,
b_41, b_42, b_43, b_44)
Is there any way how to simplify (or make cycle) it for other cases, where n could be bigger than 4?
(wi[i] is a vector).
Formulas in case this helps:
This can be vectorised as:
set.seed(0)
wi <- runif(4) #or whatever
0.5* (outer(wi,wi,"-")+1)
to produce a matrix. Now the code is independent of the length of wi. If you prefer the vector that you currently have, the output could be reshaped with:
c(t(0.5* (outer(wi,wi,"-")+1)))
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
I am trying to solve these equations for q1 and q2. However, the output is giving me "NaN". Does anyone have an idea how to avoid those?
k2<-2
k1<-2
a<- 20
b<- -0.03
w <- 1.1
model <- function(q) {
pi1 <- -exp(-a*(w*(100*q[1]-0.5*q[1]^2-0.5*q[1]*q[2])-k1)*(-a*(w*(100-q[1]-0.5*q[2])-k1)))
pi2 <- -exp(-a*(w*(100*q[2]-0.5*q[2]^2-0.5*q[1]*q[2])-k2)*(-a*(w*(100-q[2]-0.5*q[1])-k2)))
c(pi1 = pi1, pi2 = pi2)
}
ss1 <- rootSolve::multiroot(f = model, start = c(1, 1))
ss1
Thanks in advance!!!
I have been able to find the roots with the following code :
model <- function(q, bool_Print = FALSE)
{
k2 <- 2
k1 <- 2
a <- 20
b <- -0.03
w <- 1.1
pi1 <- exp( -a * (w * (100 * q[1] - 0.5 * q[1] ^ 2 - 0.5 * q[1] * q[2]) - k1) * (-a * (w * (100 - q[1] - 0.5 * q[2]) - k1)))
pi2 <- exp( -a * (w * (100 * q[2] - 0.5 *q[2] ^2 - 0.5 * q[1] * q[2]) - k2) * (-a * (w * (100 - q[2] - 0.5 * q[1]) - k2)))
val <- pi1 ^ 2 + pi2 ^ 2
names(val) <- NULL
if(bool_Print == TRUE)
{
print("pi1")
print(pi1)
print("pi2")
print(pi2)
print("Val")
}
if(is.na(val) | is.nan(val) | is.infinite(val))
{
return(10 ^ 30)
}else
{
return(val)
}
}
library(DEoptim)
obj_DEoptim <- DEoptim(fn = model, lower = rep(-1000, 2), upper = rep(1000, 2))
model(q = obj_DEoptim$optim$bestmem, bool_Print = TRUE)
[1] "pi1"
par1
0
[1] "pi2"
par2
0
[1] "Val"
[1] 0
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
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.