Creating matrix in loop using a function in R - r

I have a function to use in R
TV <- function(v1,v2) {
write.csv(log(2 ^ (-1 / 2) * exp(-1 / 2) * beta(1 / 2, v1 / 2) / gamma(1 / 2)) - log(2 ^ (-1 / 2) * exp(-1 / 2) * beta(1 / 2, v2 / 2) / gamma(1 / 2)) + (v1 + 1) * digamma(v1 / 2 + 1 / 2) / 2 + (-1 - v2) * digamma(v2 / 2 + 1 / 2) / 2 + (-1 - v1) * digamma(v1 / 2) / 2 + (v2 + 1) * digamma(v2 / 2) / 2 + 0.5e0 * log(v1 / v2),"write.csv")
}
as you can see the input variables are v1 and v2.
if i give v1=1:10 and v2=1
i get single vector like this
result for v1=1:10 and v2=1.
what i need is a matrix output. for v1=1:10 to v2=1:10. i.e as 10x10 matrix.
how can i do it using R

Try this:
write.csv(outer(1:10, 1:10, FUN=function(v1,v2)log(2 ^ (-1 / 2) * exp(-1 / 2) * beta(1 / 2, v1 / 2) / gamma(1 / 2)) -
log(2 ^ (-1 / 2) * exp(-1 / 2) * beta(1 / 2, v2 / 2) / gamma(1 / 2)) + (v1 + 1) * digamma(v1 / 2 + 1 / 2) / 2 +
(-1 - v2) * digamma(v2 / 2 + 1 / 2) / 2 + (-1 - v1) * digamma(v1 / 2) / 2 + (v2 + 1) * digamma(v2 / 2) / 2 + 0.5e0 * log(v1 / v2)), 'write.csv')

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

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!

R: How to plot use function which find a root

I construct a user-function:
find.c <- function(q) { f <- function(c) {
(log(7.2 + 6 * c * q - 6) * q^6 * (1-q)^(6-6) * factorial(6) / factorial(6) / factorial(6-6)
+ log(7.2 + 6 * c * q - 5) * q^5 * (1-q)^(6-5) * factorial(6) / factorial(5) / factorial(6-5)
+ log(7.2 + 6 * c * q - 4) * q^4 * (1-q)^(6-4) * factorial(6) / factorial(4) / factorial(6-4)
+ log(7.2 + 6 * c * q - 3) * q^3 * (1-q)^(6-3) * factorial(6) / factorial(3) / factorial(6-3)
+ log(7.2 + 6 * c * q - 2) * q^2 * (1-q)^(6-2) * factorial(6) / factorial(2) / factorial(6-2)
+ log(7.2 + 6 * c * q - 1) * q^1 * (1-q)^(6-1) * factorial(6) / factorial(1) / factorial(6-1)
+ log(7.2 + 6 * c * q - 0) * q^0 * (1-q)^(6-0) * factorial(6) / factorial(0) / factorial(6-0)
- log(7.2)
)}
g <- uniroot(f, lower=0, upper=100, extendInt = "yes")[1]
g}
And I tried to plot:
plot(x = seq(0, 1 , 0.001), find.c(x))
then it gives me: "Error in uniroot(f, lower = 0, upper = 100, extendInt = "yes") :
f() values at end points not of opposite sign"
Also is ther any way I can use 'for' loop to simplify this function? I tried may way with for but function inside function makes very complicated.
I agree with #r2evans suggestion, but I think you can restructure this to be simpler without the nested function.
First, define f with both c= and q= as arguments:
f <- function(c,q) {
(log(7.2 + 6 * c * q - 6) * q^6 * (1-q)^(6-6) * factorial(6) / factorial(6) / factorial(6-6)
+ log(7.2 + 6 * c * q - 5) * q^5 * (1-q)^(6-5) * factorial(6) / factorial(5) / factorial(6-5)
+ log(7.2 + 6 * c * q - 4) * q^4 * (1-q)^(6-4) * factorial(6) / factorial(4) / factorial(6-4)
+ log(7.2 + 6 * c * q - 3) * q^3 * (1-q)^(6-3) * factorial(6) / factorial(3) / factorial(6-3)
+ log(7.2 + 6 * c * q - 2) * q^2 * (1-q)^(6-2) * factorial(6) / factorial(2) / factorial(6-2)
+ log(7.2 + 6 * c * q - 1) * q^1 * (1-q)^(6-1) * factorial(6) / factorial(1) / factorial(6-1)
+ log(7.2 + 6 * c * q - 0) * q^0 * (1-q)^(6-0) * factorial(6) / factorial(0) / factorial(6-0)
- log(7.2)
)}
Then loop over each of the q= values:
mapply(function(...) uniroot(...)[[1]],
list(f), q=seq(0,1,0.001), lower=0, upper=100, extendInt="yes")
# [1] 0.000000 1.076564 1.076460 1.076375 1.076291 1.076206 1.076122
# [8] 1.076037 1.075953 1.075868 1.075784 1.075699 1.075614 1.075530
# etc

Is there a way to solve an equation without a root?

at the moment I am writing my bachelor thesis and I have to program in R for the first time. I think not the best way to learn R but never mind.
My question is concerning a function that can solve an equation like this:
q <- function(ytc) {
(5 / ((1 + (ytc / 4))^4 * ((1645 * 5 / 1826) - (1640 * 5 / 1826)))) +
(5 / ((1 + (ytc / 4))^4 * ((1736 * 5 / 1826) - (1640 * 5 / 1826)))) +
(5 / ((1 + (ytc / 4))^4 * ((1826 * 5 / 1826) - (1640 * 5 / 1826)))) +
100 / (((1 + (ytc / 4))^4 * ((1826 * 5 / 1826) - (1640 * 5 / 1826)))) - 100
}
My aim is to simply solve for the ytc what should be the yield to call of a bond. But I cannot find any way to figure it out. This should be a simple PV calculation like: PV=c/(1+r/4)^4*t1+c/(1+r/4)^4*t2+.... and hence solve vor r. But don't know how to do that. I tried several functions like uniroot, unroot.all, ... but nothing could figure out the solution. Additionally a real problem is that in the my main equation I am discounting 20 payments and and I was not able to modify it as a linear equation yet due to missing knowledge about what to to with the exponents.
I hope anyone could help me.
Looking forward to hear from anyone.
I do not quite understand why you cannot solve your equation.
Take your function q:
q <- function(ytc) {
(5 / ((1 + (ytc / 4))^4 * ((1645 * 5 / 1826) - (1640 * 5 / 1826)))) +
(5 / ((1 + (ytc / 4))^4 * ((1736 * 5 / 1826) - (1640 * 5 / 1826)))) +
(5 / ((1 + (ytc / 4))^4 * ((1826 * 5 / 1826) - (1640 * 5 / 1826)))) +
100 / (((1 + (ytc / 4))^4 * ((1826 * 5 / 1826) - (1640 * 5 / 1826)))) - 100
}
and assuming you want to find the value of ytc for which function q is zero then you can use uniroot as follows:
uniroot(q, c(0,10))
and if you want a more accurate solution use
uniroot(q, c(0,10),tol = .Machine$double.eps^0.5)
Seems to work nicely.
Your function is buggy, because operator^ (exponentiation) takes a precedence over operator* (multiplication). foo^4*bar means (in virtually any programming language where ^ means exponentiation) "calculate foo^4 and then multiply the result by bar". You need (I removed extra brackets):
q <- function(ytc) {
5 / (1 + ytc / 4) ^ (4 * (1645 * 5 / 1826 - 1640 * 5 / 1826)) +
5 / (1 + ytc / 4) ^ (4 * (1736 * 5 / 1826 - 1640 * 5 / 1826)) +
5 / (1 + ytc / 4) ^ (4 * (1826 * 5 / 1826 - 1640 * 5 / 1826)) +
100 / (1 + ytc / 4) ^ (4 * (1826 * 5 / 1826 - 1640 * 5 / 1826))
- 100
}
or much better:
x1 = 1645 * 5 / 1826 - 1640 * 5 / 1826
x2 = 1736 * 5 / 1826 - 1640 * 5 / 1826
x3 = 1826 * 5 / 1826 - 1640 * 5 / 1826
q <- function(ytc) {
a = 1 + ytc / 4
5 / a ** (4 * x1) + 5 / a ** (4 * x2) + 5 / a ** (4 * x3)
+ 100 / a ** (4 * x3) - 100
}
Remember, as a newbie, if you will write complicated multi-line expression with huge number of nested brackets, you will almost always make a mistake. Avoid them like a plague! Divide them to comprehensible expressions.

How I find the total area of a triangle from the areas of three sections out of six created by concurrent lines one from each vertex?

In this triange:
Given the areas of triangles UPZ ZPW and WPY, how do you calculate the total area?
I've already found the solution from the available submissions at the website. But I want to know how to derive that solution.
cin >> a >> b >> c;
// a is UPZ, b is ZPW, c is WPY
double n = b*(a+b)*(a+b+c);
double d = b*(a+b)-(a*c);
cout << (n / d) ;
Indeed, this question is kind of off topic, it is a geometry problem. The way to find the area of the big triangle UVW is to apply the link between areas and ratioes of lengths of the segments of the triangle UYW and then to apply Menelaus' theorem to derive the ratio
WY/WV which reveals the ratio between the areas of the triangle UYW and UVW.
Let h_p be the length of the height from point P to the edge UW. Then
a = UZ * h_p / 2 and b = ZW * h_p / 2
Thus:
a / b = (UZ * h_p / 2) / (ZW * h_p / 2) = UZ / ZW
Let h_W be the length of the height from point W to the line UY
a + b = Area(WPU) = PU * h_W / 2 and c = YP * h_w / 2
Thus:
c / (a + b) = (YP * h_W / 2) / (PU * h_W / 2) = YP / PU
By Menelaus' theorem for the triangle UWY and the line VZ, with P on VZ, we get:
1 = ( VW / VY ) * ( YP / PU ) * ( UZ / ZW ) = ( VW / WY ) * (c / (a + b)) * (a / b)
so
VY / VW = (c * a) / ( b * (a + b))
and therefore:
WY / VW = 1 - (VY / VW) = 1 - (c*a) / ( b*(a + b)) = (a*b + b^2 - a*c ) / (a*b + b^2)
Let h_U be the length of the height from the point U to the edge VW. Then
Area(UVW) = VW * h_U / 2
and
Area(UYW) = a + b + c = WY * h_U / 2
Hence
Area(UVW) / Area(UYW) = Area(UVW) / (a + b + c) = (VW * h_U / 2) / (WY * h_U / 2) = VW / WY
so
Area(UVW) / Area(UYW) = VW / WY = (a*b + b^2) / (a*b + b^2 - a*c)
Area(UVW) / Area(UYW) = Area(UVW) / (a + b + c) = (a*b + b^2) / (a*b + b^2 - a*c)
Finally, we obtain the formula:
Area(UVW) = (a + b + c) * (a*b + b^2) / (a*b + b^2 - a*c)
Area(UVW) = b * (a + b) * (a + b + c) / (b*(a + b) - a*c)

Resources