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.
Related
Model:
X(t) = 4*t + e(t);
t € [0; 1]
e(t) is a Gaussian process with zero mean and covariance function f(s, t) = exp( -|t - s| )
The final result over 100 runs (=100 gray lines) with 50 sampled points each should be like the gray area in the picture.
The green line is what I get from the code below.
library(MASS)
kernel_1 <- function(x, y){
exp(- abs(x - y))
}
cov_matrix <- function(x, kernel_fn, ...) {
outer(x, x, function(a, b) kernel_fn(a, b, ...))
}
draw_samples <- function(x, N=1, kernel_fn, ...) {
set.seed(100)
Y <- matrix(NA, nrow = length(x), ncol = N)
for (n in 1:N) {
K <- cov_matrix(x, kernel_fn, ...)
Y[, n] <- mvrnorm(1, mu = rep(0, times = length(x)), Sigma = K)
}
Y
}
x <- seq(0, 1, length.out = 51) # x-coordinates
model1 <- function(obs, x) {
model1_data <- matrix(NA, nrow = obs, ncol = length(x))
for(i in 1:obs){
e <- draw_samples(x, 1, kernel_fn = kernel_1)
X <- c()
for (p in 1:length(x)){
t <- x[p]
val <- (4*t) + e[p,]
X = c(X, val)
}
model1_data[i,] <- X
}
model1_data
}
# model1(100, x)
Because you have set.seed in draw_samples, you are getting the same random numbers with each draw. If you remove it, then you can do:
a <- model1(100, x)
matplot(t(a), type = "l", col = 'gray')
to get
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 try to create more then three independent contrasts in PERMANOVA with 4 factors without success. I need to use all possible pairwise combinations of factor levels in my contr2df object. There are any way for make this possible?
In my code:
#1st factor
treat <- gl(4, 15, labels = paste("t", 1:4, sep="")); treat
#Variables
set.seed(124)
sp <- cbind(c(rnorm(10, 5, 0.25), rnorm(50, 2.5, 0.25)), rnorm(60, 2.5, 0.25),
c(rnorm(10, 12, 0.25), rnorm(50, 2.5, 0.25)), rnorm(60, 2.5, 0.25))
colnames(sp) <- c("sp1", "sp2", "sp3", "sp4")
head(sp))
#create a design matrix of the contrasts for "treat"
Treat_Imp<-model.matrix(~treat-1)
require(vegan)
fullModel <- adonis(sp ~ treat, method = "euclidean", permutations = 9999)
fullModel
#Comparisons
TI <- model.matrix(~ treat-1)
head(TI)
f <- nlevels(treat)
comb <- t(combn(1:f, 2))
n <- nrow(comb)
contr2 <- NULL
for (x in 1:n) {
i <- comb[x, 1]
j <- comb[x, 2]
tmp <- list(TI[,i] - TI[,j]); names(tmp) <- paste0("TI",i, "_", j)
contr2 <- c(contr2, tmp) }
contr2
contr2df <- as.data.frame(contr2)
adonis(
sp ~ ., data = contr2df,
method = "euclidean",
permutations = 9999)
#
Thanks,
Alexandre
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)
Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 3 years ago.
Improve this question
I have some points, and both of each point's coordinates have variances. It is stored in arrays (just an example):
x <- c(1, 2, 3, 4, 5)
y <- c(1, 2, 3, 4, 5)
dx <- c(0.1, 0.1, 0.1, 0.1, 0.1)
dy <- c(0.1, 0.1, 0.1, 0.1, 0.1)
and each point's coordinates are (x +/- dx, y +/- dy).
I want to fit it with line y=k*x and get result: k +/- dk.
Terry Therneau answered this on rhelp earlier this year, citing a 1987 paper by Prof. Ripley:
Besides "total least squares" it is also call Deming regression and orthogonal regression:
Rhelp text at Baron's R Search page
# Generalized Deming regression, based on Ripley, Analyst, 1987:377-383.
#
deming <- function(x, y, xstd, ystd, jackknife=TRUE, dfbeta=FALSE,
scale=TRUE) {
Call <- match.call()
n <- length(x)
if (length(y) !=n) stop("x and y must be the same length")
if (length(xstd) != length(ystd))
stop("xstd and ystd must be the same length")
# Do missing value processing
nafun <- get(options()$na.action)
if (length(xstd)==n) {
tdata <- nafun(data.frame(x=x, y=y, xstd=xstd, ystd=ystd))
x <- tdata$x
y <- tdata$y
xstd <- tdata$xstd
ystd <- tdata$ystd
}
else {
tdata <- nafun(data.frame(x=x, y=y))
x <- tdata$x
y <- tdata$y
if (length(xstd) !=2) stop("Wrong length for std specification")
xstd <- xstd[1] + xstd[2]*x
ystd <- ystd[1] + ystd[2] * y
}
if (any(xstd <=0) || any(ystd <=0)) stop("Std must be positive")
minfun <- function(beta, x, y, xv, yv) {
w <- 1/(yv + beta^2*xv)
alphahat <- sum(w * (y - beta*x))/ sum(w)
sum(w*(y-(alphahat + beta*x))^2)
}
minfun0 <- function(beta, x, y, xv, yv) {
w <- 1/(yv + beta^2*xv)
alphahat <- 0 #constrain to zero
sum(w*(y-(alphahat + beta*x))^2)
}
afun <-function(beta, x, y, xv, yv) {
w <- 1/(yv + beta^2*xv)
sum(w * (y - beta*x))/ sum(w)
}
fit <- optimize(minfun, c(.1, 10), x=x, y=y, xv=xstd^2, yv=ystd^2)
coef = c(intercept=afun(fit$minimum, x, y, xstd^2, ystd^2),
slope=fit$minimum)
fit0 <- optimize(minfun0, coef[2]*c(.5, 1.5), x=x, y=y,
xv=xstd^2, yv=ystd^2)
w <- 1/(ystd^2 + (coef[2]*xstd)^2) #weights
u <- w*(ystd^2*x + xstd^2*coef[2]*(y-coef[1])) #imputed "true" value
if (is.logical(scale) && scale) {
err1 <- (x-u)/ xstd
err2 <- (y - (coef[1] + coef[2]*u))/ystd
sigma <- sum(err1^2 + err2^2)/(n-2)
# Ripley's paper has err = [y - (a + b*x)] * sqrt(w); gives the same SS
}
else sigma <- scale^2
test1 <- (coef[2] -1)*sqrt(sum(w *(x-u)^2)/sigma) #test for beta=1
test2 <- coef[1]*sqrt(sum(w*x^2)/sum(w*(x-u)^2) /sigma) #test for a=0
rlist <- list(coefficient=coef, test1=test1, test0=test2, scale=sigma,
err1=err1, err2=err2, u=u)
if (jackknife) {
delta <- matrix(0., nrow=n, ncol=2)
for (i in 1:n) {
fit <- optimize(minfun, c(.5, 1.5)*coef[2],
x=x[-i], y=y[-i], xv=xstd[-i]^2, yv=ystd[-i]^2)
ahat <- afun(fit$minimum, x[-i], y[-i], xstd[-i]^2, ystd[-i]^2)
delta[i,] <- coef - c(ahat, fit$minimum)
}
rlist$variance <- t(delta) %*% delta
if (dfbeta) rlist$dfbeta <- delta
}
rlist$call <- Call
class(rlist) <- 'deming'
rlist
}
print.deming <- function(x, ...) {
cat("\nCall:\n", deparse(x$call), "\n\n", sep = "")
if (is.null(x$variance)) {
table <- matrix(0., nrow=2, ncol=3)
table[,1] <- x$coefficient
table[,2] <- c(x$test0, x$test1)
table[,3] <- pnorm(-2*abs(table[,2]))
dimnames(table) <- list(c("Intercept", "Slope"),
c("Coef", "z", "p"))
}
else {
table <- matrix(0., nrow=2, ncol=4)
table[,1] <- x$coefficient
table[,2] <- sqrt(diag(x$variance))
table[,3] <- c(x$test0, x$test1)
table[,4] <- pnorm(-2*abs(table[,3]))
dimnames(table) <- list(c("Intercept", "Slope"),
c("Coef", "se(coef)", "z", "p"))
}
print(table, ...)
cat("\n Scale=", format(x$scale, ...), "\n")
invisible(x)
}
You're looking to perform a total least squares fit. There's a whole book on this, "The total least squares problem: computational aspects and analysis", by Sabine van Huffel, Joos Vandewalle. Wikpedia's article should provide enough for you to code up a solution - it's basically "take the SVD of a slightly augmented system"