plotting Hamid Naderi Yeganehs parrot using ggplot - r

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

Is there the way how to transform this kind of code into cycle for n-dimension?

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)))

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 avoid NaN in an e function?

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

Appropriately using go to algorithm in 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

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