I am ask to sample and then do a marginal distribution $f(x_1,x_5)$ and plot it. I have the following code which works but dnorm is used for one dimension so I was wondering if i need to change it to dmvnorm.
If so, i change mu=mu.marginal, sigma=sigma.marginal, added a y sample, but dmvnorm says error because of non array input. Anye help is appreciated.
Model of multivariable normal:
mu = c(1,2,6,2,-4)
sigma = c(1,2,1,0.5,2)
rho = diag(rep(1,5))
rho[1,2] = rho[2,1] = 0.4
rho[1,3] = rho[3,1] = -0.3
rho[1,4] = rho[4,1] = -0.7
rho[3,5] = rho[5,3] = 0.2
rho[4,5] = rho[5,4] = 0.5
Sigma = rho * (sigma %o% sigma)
my code:
p = c(1,5)
(mu.marginal = mu[p])
(Sigma.marginal = Sigma[p,p])
# p is one-dimensional: use dnorm() to compute marginal pdf
x = seq(-1,6,by=0.01)
fx = dnorm(x,mean=mu.marginal,sd=sqrt(Sigma.marginal))
ggplot(data=data.frame(x=x,y=fx),mapping=aes(x=x,y=y)) + geom_line(col="blue")
It seems to me you were on the right track with mvtnorm and came close to a solution... I'm not sure how you ran into a non-array input error, but here's what I got with using mvtnorm:
set.seed(123)
dat <- mvtnorm::rmvnorm(1e4, mean = mu.marginal, sigma = Sigma.marginal)
dat <- as.data.frame(dat)
ggplot(dat, aes(x = V1, y = V2)) +
geom_bin2d()
You can see it's fairly spherical, which is what you'd expect since the off-diagonal elements of Sigma.marginal are 0 (which means that x_1 and x_5 are marginally independently normally distributed...)
Related
I have the following function which i maximize using optim().
Budget = 2000
X = 4
Y = 5
min_values = c(0.3,0)
start_values = c(0.3,0.5)
max_values = c(1,1)
sample_function <- function(z,Spend){
Output = (z[1]*X*Spend) + (z[2]*Y*Spend)
return(Output)
}
MaxFunction <- optim(par=start_values ,fn= sample_function, method = "L-BFGS-B", lower = min_values , upper= max_values ,control=list(maxit=100000 ,fnscale=-1), Spend= Budget)
However i would like to add some constraints when maximizing such as:
z[1] => 1/3
and
z[1] + z[2] = 1
Any help will much be appreciated since this is linked to a more complicated problem that i'm tackling.
Or if there's a different method for solving the problem without using otpim() please let me know.
optim is not a good option for constrained optimization, but it is still possible for your case as long as you formulate your objective function sample_function in a different way.
Below is an example
min_values = 1/3
start_values = 0.5
max_values = 1
sample_function <- function(z,Spend){
z*X*Spend + (1-z)*Y*Spend
}
MaxFunction <- optim(par=start_values ,
fn= sample_function,
method = "L-BFGS-B",
lower = min_values ,
upper= max_values,
control=list(maxit=100000 ,fnscale=-1),
Spend= Budget)
If you want to see the distribution of elements of z and 1-z, you can use
z1 <- MaxFunction$par
z2 <- 1- z1
Zopt <- c(z1,z2)
such that
> Zopt
[1] 0.3333333 0.6666667
I am working through an example from Aguinis, Gottfredson, & Culpepper (2013). They have provided some R code to perform a bootstrapping procedure in R to estimate confidence intervals for slope variances. This is their original R code:
library(RLRsim)
#STEP 3: Random Intercept and Random Slope model
lmm.fit3=lmer(Y ~ (Xc|l2id) + Xc + I(Wj-mean(Wj)), data=exdata, REML=F)
# Nonparametric Bootstrap Function
REMLVC=VarCorr(lmer(Y ~Xc+(Xc|l2id)+I(Wj-mean(Wj) ),data=exdata,REML=T))$l2id[1:2,1:2]
U.R=chol(REMLVC)
REbootstrap=function(Us,es,X,gs){
nj=nrow(Us)
idk=sample(1:nj,size=nj,replace=T)
Usk=as.matrix(Us[idk,])
esk=sample(es,size=length(es),replace=T)
S=t(Usk)%*%Usk/nj
U.S = chol(S)
A=solve(U.S)%*%U.R
Usk = Usk%*%A
datk=expand.grid(l1id = 1:6,l2id = 1:nj)
colnames(X)=c('one','Xc','Wjc')
datk=cbind(datk,X)
datk$yk = X%*%gs + Usk[datk$l2id,1]+Usk[datk$l2id,2]*X[,2]+esk
lmm.fitk=lmer(yk ~Xc+(Xc|l2id)+Wjc,data=datk,REML=F)
tau11k = VarCorr(lmm.fitk)$l2id[2,2]
tau11k
}
# Implementing Bootstrap
bootks=replicate(1500,REbootstrap(Us=ranef(lmm.fit3)$l2id,es=resid(lmm.fit3),X=model.matrix(lmm.fit3),gs=fixef(lmm.fit3)))
quantile(bootks,probs=c(.025,.975))
I was trying to adapt the code to suit my own data and model. That was unfruitful so far because (a) I do not fully understand all the lines of code and (b) I have missing datapoints in one of my predictors. Here is what I have so far:
#reproducible code
set.seed(855)
exdf <- data.frame(
ID= c(rep(1:105, 28)),
content= sort(c(rep(1:28, 105))),
PrePost= sample(0:1, 105*28, replace=TRUE),
eyeFRF= sort(rep(rnorm(28), 105)),
APMs= sample(0:1, 105*28, replace=TRUE),
Gf= rep(rnorm(105), 28)
)
exdf[which(exdf$ID==62), "eyeFRF"] <- NA
RandomMissing <- sample(rownames(exdf[-which(exdf$ID==62), ]), 17)
exdf[RandomMissing, "eyeFRF"] <- NA
View(exdf)
#model
M03b <- glmer(APMs ~ PrePost + Gf + eyeFRF + (1|content) + (eyeFRF|ID), data=exdf, family=binomial("logit"))
#own adaptation
REMLVC=VarCorr(M03b)$ID[1:2,1:2]
U.R=chol(REMLVC)
REbootstrap=function(Us, es, X, gs){
#Us = random effects
#es = residuals
#X = design matrix
#gs = fixed effects
nj = nrow(Us) #104 in this case, one is excluded (#62) b/c no eye-data
idk = sample(1:nj, size=nj, replace=TRUE) #104 IDs
Usk = as.matrix(Us[idk,]) #104 intercepts and slopes
esk = sample(es, size=length(es), replace=TRUE) #2895 datapoints called 'x' (errors?)
S = t(Usk)%*%Usk/nj #?
U.S = chol(S) #?
A = solve(U.S)%*%U.R #?
Usk = Usk%*%A #?
datk = expand.grid(content=1:28, ID=1:nj)
colnames(X) = c('one', 'PrePost', 'Gf', 'eyeFRF')
datk = cbind(datk, X)
datk$APMsk = X%*%gs + Usk[datk$ID,1] + Usk[datk$ID,2]*X[ ,2] + esk
lmm.fitk = glmer(APMsk ~ PrePost + Gf + eyeFRF + (1|content) + (zb|ID), data=datk, family=binomial("logit"))
tau11k = VarCorr(lmm.fitk)$l2id[2,2]
tau11k
}
# Implementing Bootstrap
bootks <- replicate(1500, REbootstrap(Us=ranef(M03b)$ID, es=resid(M03b), X=model.matrix(M03b), gs=fixef(M03b)))
quantile(bootks, probs=c(.025,.975))
(upgrading comment to an answer)
If you're trying to get confidence intervals via parametric bootstrapping, would confint(M03b,method="boot") work for you? (I think these methods may be new or better developed since that paper was written ...)
I'm trying to fit a bi exponential function:
t = seq(0, 30, by = 0.1)
A = 20 ; B = 10 ; alpha = 0.25 ; beta = 0.01
y = A*exp(-alpha*t) + B*exp(-beta*(t))
df = as.data.frame(cbind(t,y))
ggplot(df, aes(t, y)) + geom_line() + scale_y_continuous(limits=c(0, 50))
This problem can't be solve by a simple transformation like log so I wanted to use the nls2 package:
library(nls2)
fo <- y ~ Ahat*exp(-alphahat*t) + Bhat*exp(-betahat*t)
fit <- nls2(fo,
start = list(Ahat=5, Bhat=5, alphahat=0.5,betahat=0.5),
algorithm = "brute-force",
trace = TRUE,
lower = c(Ahat=0, Bhat=0, alphahat=0, betahat=0),
upper = c(Ahat=50, Bhat=50, alphahat=10,betahat=10))
fit
Here is the result:
Nonlinear regression model
model: y ~ Ahat * exp(-alphahat * t) + Bhat * exp(-betahat * t)
data: NULL
Ahat Bhat alphahat betahat
5.0 5.0 0.5 0.5
residual sum-of-squares: 37910
Number of iterations to convergence: 4
Achieved convergence tolerance: NA
I assume something is wrong in my code because :
data: NULL ?
Why only 4 iterations ?
Hard to think nls2 didn't find a better solution than the starting point.
The result is far from the solution
From the documentation, the start parameter should be a data.frame of two rows that define the grid to search in, or a data.frame with more rows corresponding to parameter combinations to test if you are using brute-force. Also, nls will have trouble with your fit because it is a perfect curve, there is no noise. The brute-force method is slow, so here is an example where the search space is decreased for nls2. The result of the brute-force nls2 is then used as the starting values with nls default algorithm (or you could use nls2), after adding a tiny bit of noise to the data.
## Data
t = seq(0, 30, by = 0.1)
A = 20 ; B = 10 ; alpha = 0.25 ; beta = 0.01
y = A*exp(-alpha*t) + B*exp(-beta*(t))
df = as.data.frame(cbind(t,y))
library(nls2)
fo <- y ~ Ahat*exp(-alphahat*t) + Bhat*exp(-betahat*t)
## Define the grid to search in,
## Note: decreased the grid size
grd <- data.frame(Ahat=c(10,30),
Bhat=c(10, 30),
alphahat=c(0,2),
betahat=c(0,1))
## Do the brute-force
fit <- nls2(fo,
data=df,
start = grd,
algorithm = "brute-force",
control=list(maxiter=100))
coef(fit)
# Ahat Bhat alphahat betahat
# 10.0000000 23.3333333 0.0000000 0.3333333
## Now, run through nls:
## Fails, because there is no noise
final <- nls(fo, data=df, start=as.list(coef(fit)))
## Add a little bit of noise
df$y <- df$y+rnorm(nrow(df),0,0.001)
coef((final <- nls(fo, data=df, start=as.list(coef(fit)))))
# Ahat Bhat alphahat betahat
# 10.00034000 19.99956016 0.01000137 0.25000966
## Plot
plot(df, col="steelblue", pch=16)
points(df$t, predict(final), col="salmon", type="l")
Your data is null because you didn't add in any data into the nls2 statement.
This is how nls2 needs to be set up:
nls2(formula, data = parent.frame(), start, control = nls.control(),
algorithm = c("default", "plinear", "port", "brute-force",
"grid-search", "random-search", "plinear-brute", "plinear-random"),
trace = FALSE, weights, ..., all = FALSE)
Take a look at the official documentation for a full example.
I am new user of R and hope you will bear with me if my question is silly. I want to estimate the following model using the maximum likelihood estimator in R.
y= a+b*(lnx-α)
Where a, b, and α are parameters to be estimated and X and Y are my data set. I tried to use the following code that I get from the web:
library(foreign)
maindata <- read.csv("C:/Users/NUNU/Desktop/maindata/output2.csv")
h <- subset(maindata, cropid==10)
library(likelihood)
modelfun <- function (a, b, x) { b *(x-a)}
par <- list(a = 0, b = 0)
var<-list(x = "x")
par_lo <- list(a = 0, b = 0)
par_hi <- list(a = 50, b = 50)
var$y <- "y"
var$mean <- "predicted"
var$sd <- 0.815585
var$log <- TRUE
results <- anneal(model = modelfun, par = par, var = var,
source_data = h, par_lo = par_lo, par_hi = par_hi,
pdf = dnorm, dep_var = "y", max_iter = 20000)
The result I am getting is similar although the data is different, i.e., even when I change the cropid. Similarly, the predicted value generated is for x rather than y.
I do not know what I missed or went wrong. Your help is highly appreciated.
I am not sure if your model formula will lead to a unique solution, but in general you can find MLE with optim function
Here is a simple example for linear regression with optim:
fn <- function(beta, x, y) {
a = beta[1]
b = beta[2]
sum( (y - (a + b * log(x)))^2 )
}
# generate some data for testing
x = 1:100
# a = 10, b = 3.5
y = 10 + 3.5 * log(x)
optim(c(0,0,0),fn,x=x,y=y,method="BFGS")
you can change the function "fn" to reflect your model formula e.g.
sum( (y - (YOUR MODEL FORMULA) )^2 )
EDIT
I am just giving a simple example of using optim in case you have a custom model formula to optimize. I did not mean using it from simple linear regression, since lm will be sufficient.
I was a bit surprised that iTech used optim for what is a problem that is linear in its parameters. With his data for x and y:
> lm(y ~ log(x) )
Call:
lm(formula = y ~ log(x))
Coefficients:
(Intercept) log(x)
10.0 3.5
For linear problems, the least squares solution is the ML solution.
Assume A follows Exponential distribution; B follows Gamma distribution
How to plot the PDF of 0.5*(A+B)
This is fairly straight forward using the "distr" package:
library(distr)
A <- Exp(rate=3)
B <- Gammad(shape=2, scale=3)
conv <- 0.5*(A+B)
plot(conv)
plot(conv, to.draw.arg=1)
Edit by JD Long
Resulting plot looks like this:
If you're just looking for fast graph I usually do the quick and dirty simulation approach. I do some draws, slam a Gaussian density on the draws and plot that bad boy:
numDraws <- 1e6
gammaDraws <- rgamma(numDraws, 2)
expDraws <- rexp(numDraws)
combined <- .5 * (gammaDraws + expDraws)
plot(density(combined))
output should look a little like this:
Here is an attempt at doing the convolution (which #Jim Lewis refers to) in R. Note that there are probably much more efficient ways of doing this.
lower <- 0
upper <- 20
t <- seq(lower,upper,0.01)
fA <- dexp(t, rate = 0.4)
fB <- dgamma(t,shape = 8, rate = 2)
## C has the same distribution as (A + B)/2
dC <- function(x, lower, upper, exp.rate, gamma.rate, gamma.shape){
integrand <- function(Y, X, exp.rate, gamma.rate, gamma.shape){
dexp(Y, rate = exp.rate)*dgamma(2*X-Y, rate = gamma.rate, shape = gamma.shape)*2
}
out <- NULL
for(ix in seq_along(x)){
out[ix] <-
integrate(integrand, lower = lower, upper = upper,
X = x[ix], exp.rate = exp.rate,
gamma.rate = gamma.rate, gamma.shape = gamma.shape)$value
}
return(out)
}
fC <- dC(t, lower=lower, upper=upper, exp.rate=0.4, gamma.rate=2, gamma.shape=8)
## plot the resulting distribution
plot(t,fA,
ylim = range(fA,fB,na.rm=TRUE,finite = TRUE),
xlab = 'x',ylab = 'f(x)',type = 'l')
lines(t,fB,lty = 2)
lines(t,fC,lty = 3)
legend('topright', c('A ~ exp(0.4)','B ~ gamma(8,2)', 'C ~ (A+B)/2'),lty = 1:3)
I'm not an R programmer, but it might be helpful to know that for independent random variables with PDFs f1(x) and f2(x), the PDF
of the sum of the two variables is given by the convolution f1 * f2 (x) of the two input PDFs.