I need to calculate the area of the eclipse (a=6 b=3) with the Montecarlo Method.
Also I have to make a plot (a diagram) of the result with the inside points red and the out ones black. At the end I have to compare the "Montecarlo result" with the "Regular Result"
The equation is (x^2)/36+(y^2)/9=1
The method must have 100000 replies.
This is what I do. Obviously it doesn't work.
set.seed(157619)
n <- 100000
xmin <- (-6)
xmax <- (+6)
ymin <- (-3)
ymax <- (+3)
rx <- (xmax-xmin)/2
ry <- (ymax-ymin)/2
outa <- runif(n,min=xmin,max=xmax)
outb <- runif(n,min=ymin,max=ymax)
dx <- outa*2
dy <- outb*2
ly <- dy<=(ry^2); my <- dy>(ry^2)
lx <- dx<=(ry^2); mx <- dx>(rx^2)
This is an example code that work for the circle:
n <- 200
xmin <- -1; xmax <- 1
r <- (xmax-xmin)/2
out <- runif(n,min=xmin,max=xmax)
x <- matrix(out,ncol=2)
d <- x[,1]^2 + x[,2]^2
l <- d<=(r^2); m <- d>(r^2)
win.graph(7,7.8) # così è quadrato
plot(c(xmin,xmax),c(xmin,xmax),type="n")
plot(x[l,1],x[l,2])
points(x[m,1],x[m,2],col="red",pch=19)
(p <- sum(l)/length(l))
p*4
I suspect this is homework, but here we go:
set.seed(42)
n <- 1e5
xmax <- 6
ymax <- 3
x <- runif(n, 0, xmax)
y <- runif(n, 0, ymax)
inside <- (x^2)/36+(y^2)/9 <= 1
plot(x, y, pch=16, cex=0.5, col=inside+1)
mean(inside) * (xmax*ymax) *4
#[1] 56.54376
pi*6*3
#[1] 56.54867
set.seed(1)
n = 1000
a = 6
b = 3
x.samp = runif(n, -a, a)
y.samp = runif(n, -b, b)
p.in = (x.samp/a)^2 + (y.samp/b)^2 <= 1
S = 4*a*b*sum(p.in)/n
print(S)
plot(x.samp, y.samp, col = p.in + 1)
Related
I have always been interested in learning about how computers are able to animate the "Mandelbrot Set" (https://en.wikipedia.org/wiki/Mandelbrot_set).
I found this website (https://www.dandelbrot.com/post/the-mandelbrot-set-in-r/) that shows how to create Mandelbrot Set:
mandelbrot_generator <- function(
p = 2,
q = 1,
xmin = -2.1, # minimum x value
xmax = 0.8, # maximum x value
nx = 500,
ymin = -1.3, # minimum y value
ymax = 1.3, # maximum y value
ny = 500,
n = 100,
showplot = TRUE, # If TRUE then display image,
showvals = FALSE,
cols = colorRampPalette(c("black","cyan","cyan3","black"))(11))
{
# variables
x <- seq(xmin, xmax, length.out=nx)
y <- seq(ymin, ymax, length.out=ny)
c <- outer(x,y*1i,FUN="+")
z <- matrix(0.0, nrow=length(x), ncol=length(y))
k <- matrix(0.0, nrow=length(x), ncol=length(y))
for (rep in 1:n) {
index <- which(Mod(z) < 2)
z[index] <- z[index]^p + c[index]*q
k[index] <- k[index] + 1
}
if (showplot==TRUE) { image(x,y,k,col=cols, xlab="Re(c)", ylab="Im(c)")}
if (showvals==TRUE) {return(k)}
}
Here is the plot:
mandelbrot_generator(p=2, q=1)
Does anyone know how to make an "animation" using the above code, so that it looks like this?
(https://en.wikipedia.org/wiki/Mandelbrot_set#/media/File:Mandelbrot_sequence_new.gif)
I always wondered : how are these animations made? I understand that a single picture of the Mandelbrot Set can be made, but how do these "zooming" animations work? Is this simply done by changing the "axis" (i.e. scale) of the picture?
The above picture is made from x = (-2.1, 0.8) and y = (-1.3, 1.3) - my understanding is that if we wanted to make a "zooming animation", we would "shrink" these ranges at each frame?
For example:
Frame 1: x = (-2.1, 0.8) and y = (-1.3, 1.3)
Frame 2 : x = (-1.9, 0.6) and y = (-1.1, 1.1)
Frame 3 : x = (-1.4, 0.3) and y = (0.7, 0.7)
etc.
Is this correct? Could we use this logic to make a series of "Mandelbrot frames" - and then fade/transition between these frames, giving them the illusion of being animated?
Thank you!
First, you should change a little your code like
mandelbrot_generator <- function(n){
p=2
q=1
xmin = -2.1 # minimum x value
xmax = 0.8 # maximum x value
nx = 500
ymin = -1.3 # minimum y value
ymax = 1.3 # maximum y value
ny = 500
showplot = TRUE # If TRUE then display image,
showvals = FALSE
cols = colorRampPalette(c("black","cyan","cyan3","black"))(11)
# variables
x <- seq(xmin, xmax, length.out=nx)
y <- seq(ymin, ymax, length.out=ny)
c <- outer(x,y*1i,FUN="+")
z <- matrix(0.0, nrow=length(x), ncol=length(y))
k <- matrix(0.0, nrow=length(x), ncol=length(y))
for (rep in 1:n) {
index <- which(Mod(z) < 2)
z[index] <- z[index]^p + c[index]*q
k[index] <- k[index] + 1
}
if (showplot==TRUE) { image(x,y,k,col=cols, xlab="Re(c)", ylab="Im(c)")}
if (showvals==TRUE) {return(k)}}
Then you can use the images to create a gif file, following this this thread, for instance.
To some mathematical aspects of Mandelbrot set, please see this thread, and find more on SearchOnMath.
I am new to R and trying to find the optimal values of 3 parameters via indirect inference from a simulated panel data set, but getting an error "objective function in optim evaluates to length 3 not 1". I tried to check past posts, but the one I found didn't address the problem I am facing.
The code works if I only try for one parameter instead of 3. Here is the code:
#Generating data
modelp <- function(Y,alpha,N,T){
Yt <- Y[,2:T]
Ylag <- Y[,1:(T-1)]
Alpha <- alpha[,2:T]
yt <- matrix(t(Yt), (T-1)*N, 1)
ylag <- matrix(t(Ylag), (T-1)*N, 1)
alph <- matrix(t(Alpha), (T-1)*N, 1)
rho.ind <- rep(NA,N)
sigma_u <- rep(NA,N)
sigma_a <- rep(NA,N)
for(n in 1:N){
sigma_u[n] <- sigma(lm(yt~alph+ylag))
sigma_a[n] <- lm(yt~alph+ylag)$coef[2] #
(diag(vcov((lm(yt~alph+ylag)$coef),complete=TRUE)))[2] #
rho.ind[n] <- lm(yt~alph+ylag)$coef[3]
}
param <- matrix(NA,1,3)
param[1]<- mean(sum(rho.ind))
param[2]<- mean(sum(sigma_u))
param[3]<- mean(sum(sigma_a))
return(param)
}
## Function to estimate parameters
H.theta <- function(param.s){
set.seed(tmp.seed) #set seed
param.s.tmp <- matrix(0,1,3)
for(s in 1:H){
eps.s <- matrix(rnorm(N*T), N, T) #white noise erros
eps0.s <- matrix(rnorm(N*T), N, 1) #error for initial condition
alph.s <- matrix(rnorm(N*T),N,T)
Y.s <- matrix( 0, N, T)
ys.lag <- eps0.s
for(t in 1:T){ #Simulating the AR(1) process data
ys <- alph.s[,t]+param.s[1] * ys.lag + eps.s[,t] # [n,1:t]
Y.s[,t] <- ys
ys.lag <- ys
}
param.s.tmp <- param.s.tmp + modelp(Y.s, alph.s,N, T)
param.s[2] <- param.s.tmp[2]
param.s[3] <- mean(var(alph.s)) #param.s.tmp[3]
}
return( (param.data - param.s.tmp/H)^2 )
#return(param.s[1])
}
#Results for T = 10 & H = 10, N=100
nrep <-10
rho <-0.9
sigma_u <- 1
sigma_a <- 1.5
param <- matrix(NA,1,3)
param[1] <- rho
param[2] <- sigma_u
param[3] <- sigma_u
s.mu <- 0 # Mean
s.ep <- 0.5 #White Noise -initial conditions
Box <- cbind(rep(100,1),c(20),rep(c(5),1))
r.simu.box <- matrix(0,nrep,nrow(Box))
r.data.box <- matrix(0,nrep,nrow(Box))
for(k in 1:nrow(Box)){
N <- Box[k,1] #Number of individuals in panel
T <- Box[k,2] #Length of Panel
H <- Box[k,3] # Number of simulation paths
p.data <-matrix(NA,nrep,3)
p.simu <-matrix(NA,nrep,3)
est <- matrix(NA,1,3)
for(i in 1:nrep){
mu <- matrix(rnorm(N )*s.mu, N, 1)
eps <- matrix(rnorm(N*T)*s.ep, N, T)
eps0 <- matrix(rnorm(N*T)*s.ep, N, 1)
alph <- matrix(rnorm(N ), N, T)
Y <- matrix( 0, N, T)
y.lag <- (1-param[1])*mu + eps0
for(t in 1:T){
y <- alph[,t]+param[1]*y.lag +eps[,t]
Y[,t] <- y
y.lag <- y
}
param.data <- modelp(Y,alph,N,T) #Actual data
p.data[i,1:3] <- param.data
tmp.seed <- 3864+i+100*(k-1) #Simulated data
x0 <- c(0.5, 0,0)
est[i] <- optim(x0, H.theta,method = "BFGS", hessian = TRUE)$par
p.simu[i,1:3] <- est[i]
if(i%%10==0) print(c("Finished the (",i,")-th replication"))
}
}
mean(p.data[,1])- mean(p.simu[,1])
mean(p.data[,2])- mean(p.simu[,2])
sqrt(mean((p.data[1]-p.simu[1])^2))
I expect to get three values. Any help or suggestion will be greatly appreciated.
I need little help. I try to do plot with ggplot package. When I want to make plot, depends of more than 1 factor (for example here: plot changes when średnia1 and odchylenie1 change):
alpha = 0.05
N = 100
sample_l = 10
srednia1 = seq(-7, 7, by = 1)
odchylenie1 = seq(1, 10, by = 1)
srednia2 = 2
odchylenie2 = 2
prob = 0.7
params = expand.grid(sample_l, srednia1, odchylenie1, srednia2, odchylenie2, prob)
str(params)
names(params) = c("dlugość", "średnia1", "odchylenie1", "średnia2", "odchyelnie2", "prawdopodobienstwo")
set.seed(100)
now <- Sys.time()
powers <- sapply(1:nrow(params), function(p){
l <- params[p, 1]
par_1 <- c(params[p, 2],params[p, 3])
par_2 <- c(params[p, 4], params[p, 5])
p <- params[p,6]
p_sim <-sapply(rep(l, N), function(x){
my_sample <- rmix(l,"norm", par_1, "norm", par_2, p)
shapiro.test(my_sample)$p.value
})
mean(p_sim < alpha)
})
Sys.time() - now
power_df <- bind_cols(params, power = powers)
power_df %>% ggplot(aes(x = średnia1,
y = power,
col = factor(odchylenie1))) +
geom_line()
it work perfect, but now, when I want to make plot only depends of 1 factor - prob something goes wrong. I have error : Error: Aesthetics must be either length 1 or the same as the data (150): x, y. Here is a code:
alpha = 0.05
N = 100
sample_l = 10
srednia1 = 2
odchylenie1 = 2
srednia2 = 1
odchylenie2 = 1
prob = seq(0.1,0.9,by=0.1)
set.seed(100)
now <- Sys.time()
powers <- sapply(1:nrow(params), function(p){
l <- params[p, 1]
par_1 <- c(params[p, 2],params[p, 3])
par_2 <- c(params[p, 4], params[p, 5])
p <- params[p,6]
p_sim <-sapply(rep(l, N), function(x){
my_sample <- rmix(l,"norm", par_1, "norm", par_2, p)
shapiro.test(my_sample)$p.value
})
mean(p_sim < alpha)
})
Sys.time() - now
power_df <- bind_cols(params, power = powers)
power_df %>% ggplot(aes(x = prob, y = power)) + geom_line()
PLEASE HELP ME :(
I have a dataframe with three values, x and y are coordinates and z is the value of the indipendent variable:
x.range <- c(1,10)
y.range <- c(20,50)
grid <- expand.grid(x = seq(x.range[1], x.range[2], by=0.5),
y = seq(y.range[1], y.range[2], by=0.5))
grid$z <- runif(nrow(grid),10, 70)
Now i have another dataframe like this with only x and y values:
x1 <- c(3.7,5.4,9.2)
y1 <- c(41.1,30.3,22.9)
df <- data.frame(x=x1,y=y1)
Now i want to associate to the points of dataframe df the z value of the nearest point of dataframe grid (with the shortest distance). Thanks.
This isn't the prettiest, but works
apply(df, 1,
function(x){
pythag <- sqrt((x[1] - grid$x)^2 +
(x[2] - grid$y)^2)
grid[which.min(pythag), "z"]
})
Simply returning the value for the nearest point using Pythagoras.
Edit
Recoding to adhere to coding standards:
pythag <- function(x, y, g){
which.min(((x - g$x)^2 + (y - g$y)^2)^0.5)
}
idx <- mapply(FUN = pythag,
x = df[["x"]],
y = df[["y"]],
MoreArgs = list(g = grid))
grid[idx,]
I have the following data
var.asym <- function(alpha1, alpha2, xi, beta, n){
term11 <- alpha1*(1-alpha1)^(2*xi-1)
term12 <- alpha1*(1-alpha1)^(xi-1)*(1-alpha2)^xi
term22 <- alpha2*(1-alpha2)^(2*xi-1)
Sigma <- matrix(c(term11, term12, term12, term22), nrow=2, byrow=TRUE)
Sigma*beta^2/n
}
mop.jacob.inv <- function(alpha1, alpha2, xi, beta){
term11 <- -qgpd(alpha1, xi, 0, beta)/xi - beta*(1-alpha1)^xi*log(1-alpha1)/xi
term12 <- qgpd(alpha1, xi, 0, beta)/beta
term21 <- -qgpd(alpha2, xi, 0, beta)/xi - beta*(1-alpha2)^xi*log(1-alpha2)/xi
term22 <- qgpd(alpha2, xi, 0, beta)/beta
jacob <- matrix(c(term11, term12, term21, term22), nrow=2, byrow=TRUE)
jacob.inv <- solve(jacob)
jacob.inv
}
var.asym2 <- function(alpha1, alpha2) var.asym(alpha1, alpha2, 0.2, 1, 1000)
mop.jacob.inv2 <- function(alpha1, alpha2) mop.jacob.inv(alpha1, alpha2, 0.2, 1)
object <- function(alpha1, alpha2){
term1 <- mop.jacob.inv2(alpha1, alpha2)%*%var.asym2(alpha1, alpha2)%*%t(mop.jacob.inv2(alpha1, alpha2))
sum(diag(term1))
}
x <- seq(0.01, 0.98, by=0.01)
y <- seq(x[1]+0.01, 0.99, by=0.01)
xy <- cbind(rep(x[1], length(x)), y)
for(i in 2:length(x)){
y <- seq(x[i]+0.01, 0.99, by=0.01)
xy <- rbind(xy, cbind(rep(x[i], length(x)-i+1), y))
}
object.xy <- rep(0, 4851)
for(i in 1:4851){
object.xy[i] <- object(xy[i, 1], xy[i, 2])
}
Now I want to plot a surface of (xy[, 1], xy[, 2], object.xy). Is there a way to do so in R? I tried persp and contour function but it did not seem to be appropriate for this case since they both require increasing sequences x and y. I guess a more general question would be how to make contour plot when we are given a sequence of triplets (x, y, z).
library(dplyr)
library(tidyr)
library(magrittr)
long_data =
data.frame(
x = xy[,1] %>% round(2),
y = xy[,2] %>% round(2),
z = object.xy)
wide_data =
long_data %>%
spread(x, z)
y = wide_data$y
wide_data %<>% select(-y)
x = names(wide_data) %>% as.numeric
z = wide_data %>% as.matrix
persp(x, y, z)
contour(x, y, z)
Dunno why the round helps, but it does. The reshape was necessary to build a matrix from x, y, z data. Note that the contour lines coalesce into a black dot because of the huge narrow peak in the data.