I have a Bayesian MCMC in R, and I have the code below:
RWM = function(Niter,Y,X){
p = ncol(X)
alpha = 0.7
beta = matrix(0,ncol=1,nrow=3)
beta = as.matrix(beta)
sig_p = 0
mu_p = beta
C = diag(p)
R = t(chol(C))
lpi = posterior(beta,Y,X)
OUT = matrix(NA, ncol=3, nrow=Niter)
for (j in 1:Niter){
rr = rnorm(p)
beta_p = beta + exp(sig_p) * as.vector(R%*%rr)
lpi_p = posterior(beta_p,Y,X)
A = exp(lpi_p-lpi)
Acc = min(1,A)
if (runif(1)<=Acc){
beta = beta_p
lpi = lpi_p
}
OUT[j,] = beta
sig_p = sig_p + (1/j^alpha)*(Acc -0.3)
mu_p = mu_p + (1/j)*(as.matrix(beta) - mu_p)
bmu = as.matrix(beta - mu_p)
C = C + (1/j)*(as.matrix(t(bmu)%*%bmu) - C)
}
return(OUT)
It looks like the vector beta will update, and the three elements in this vector will be different due to the rnorm function. However, this is not the case. The 3 columns of the output, one for each element, are exactly the same in the row. I have iterated this function out in the console several times, and in no case did the elements in beta appear to be the same.
For example: beta = [1, 2, 3] but the output = [1, 1, 1]
The MCMC iterates and does not get stuck, as the histogram shows a wide range of values in the output. It is just the sampled betas that are giving me the issue.
I'm just not understanding what is wrong with my code that prevents my vector beta from being added directly to the matrix OUT.
Related
I have this code:
k = 20
rho = 0.5
pi_greco = array(rep(1/k, k), c(1,20,50))
pi_greco_x <- function(k, rho, pi_greco){
E = array(diag(k),c(20, 20, 50))
E[k,k,] = 0
prob = (1-rho)*pi_greco + rho*E
return(prob)
}
and in prob I need to sum each matrix of dimension 1x20 of pi_greco (multiplied by 1-rho) with each matrix of dimension 20x20 of E (multiplied by rho) in order to get 50 different matrix in prob. But how can I do it?
It is like saying that I would like to do
prob = (1-rho)*pi_greco[,,1] + rho*E[,,1]
But for all the 50 times without using a for cycle
Thanks in advance.
Consider this:
k = 3
rho = 0.5
pi_greco = array(rep(1/k, k), c(1,20,50))
pi_greco_x <- function(k, rho, pi_greco){
E = array(diag(k),c(k, 20, 50))
E[k,k,] = 0
p_rows <- Reduce(
f=function(a,b){ abind( a, (1-rho)*pi_greco, along=1 ) },
x=1:k,
init=NULL
)
prob <- p_rows + rho*E
return(prob)
}
pi_greco_x( k, rho, pi_greco )
I repeat the 1x20x50 to be 20x20x50 by using abind 20 times
This means they can now safely be added together. Working with more than two dimensions can be problematic. The typical human brain isn't very used to it.
I'm doing Maximum Likelihood Estimation using maxLik, which requires specifying starting values. Instead of specifying a single value, is there any way that allows me to use all the values from a matrix as the start value?
My current code of maxLik is:
f12 <- function(param){
alpha <- param[1]
rho <- param[2]
lambda <- param[3]
u <- 0.5*(p12$v_50_1)^alpha + 0.5*lambda*(p12$v_50_2)^alpha
p <- 1/(1 + exp(-rho*u))
f <- sum(p12$gamble*log(p) + (1-p12$gamble)*log(1-p))}
ml <- maxLik(f12, start = c(alpha = 1, rho=2, lambda = 1), method = "NM")
I create a dataframe with the upper and lower bounds of potential start values:
st <- expand.grid(alpha = seq(0, 2, len = 100),rho = seq(0, 1, len = 100),lambda = seq(0,2, length(100))
There are 3 parameters in my function, and my goal is to loop all the values in the above dataframe st and select the best vector of start values after running the model from a variety of starting parameters.
Thanks!
Consider Map (wrapper to mapply) to pass the st columns elementwise through your methods. Here, Map will return a list of maxLik objects, specifically inherited maxim class objects containing a list of other components. The number of items in this list will be equal to rows of st.
Notice input parameters, a, r, and l being passed into start argument of maxLik() and no longer hard-coded integers. And f12 is left untouched.
maxLik_run <- function(a, r, l) {
tryCatch({
f12 <- function(param){
alpha <- param[1]
rho <- param[2]
lambda <- param[3]
u <- 0.5*(p12$v_50_1)^alpha + 0.5*lambda*(p12$v_50_2)^alpha
p <- 1/(1 + exp(-rho*u))
f <- sum(p12$gamble*log(p) + (1-p12$gamble)*log(1-p))
}
return(maxLik(f12, start = c(alpha = a, rho = r, lambda = l), method = "NM"))
}, error = function(e) return(NA))
}
st <- expand.grid(alpha = seq(0, 2, len = 100),
rho = seq(0, 1, len = 100),
lambda = seq(0, 2, length(100)))
maxLik_list <- Map(maxLik_run, st$alpha, st$rho, st$lambda)
And to answer the question --best vector of start values after running the model from a variety of starting parameters-- requires a particular definition of "best". Once you define this, you can use Filter() on your returned list of objects to select the one or more element that yields this "best".
Below is a demonstration to find the highest value across each maximum likelihood's maximum. Use estimate if needed. Do note, this returned list can have more than one if the highest value is shared by other list items:
highest_value <- max(sapply(maxLik_list, function(item) item$maximum))
maxLik_item_list <- Filter(function(i) i$maximum == highest_value, maxLik_list)
What you are doing in your logLik function is that you are calculating alpha,lambda,rho whereas your data already has them.Those are the lines with u,p and f12(that is also your function name!). Also it is possible to calculate log likelihood for one row as your log likelihood function has single indices. So you run the code using apply like this
#create a function to find mle estimate for first row
maxlike <- function(a) {
f12 <- function(param){
alpha <- param[1]
rho <- param[2]
lambda <- param[3]
#u <- 0.5*(p12$v_50_1)^alpha + 0.5*lambda*(p12$v_50_2)^alpha
#p <- 1/(1 + exp(-rho*u))
#f12 <- sum(p12$gamble*log(p) + (1-p12$gamble)*log(1-p))
}
ml <- maxLik(f12, start = c(alpha = 1, rho=2, lambda = 1), method = "NM")
}
#then using apply with data = st, 2 means rows and your mle function
mle <- apply(st,2,maxlike)
mle
I am trying to produce multiple plots using the split.screen option and I need to have 7 plots on the page. One of them should be plotted on its own and the other 6 plotted repeatedly using a for loop.
This is my code for some simulation I am carrying out. It runs well, but I have two potential problems:
I am not sure which of the plots actually gets plotted because I couldn't get the assigned label to show up on the bigger plot.
The plot showing on screen 1 is not the actual data because I have plotted it separately and know what it should look like.
Simulating the data:
numpop = 2
N = 1250
nSNP = 5000
Fst = 0.001
omega = c(0.5, 0.5)
propnExtreme = 0.1
nsim = 10
Fst.obs = vector(length = nSNP)
pdiffs = vector(length = nSNP)
genomat = matrix(nrow = N, ncol = nSNP)
for (i in 1:nSNP){
p = runif(1, 0.1, 0.9)
alpha = p * (1 - Fst) / Fst
beta = (1 - p) * (1 - Fst) / Fst
ps = rbeta(numpop, shape1 = alpha, shape2 = beta)
vars = var(ps)
pdiffs[i] = max(ps) - min(ps)
Fst.obs[i] = vars / (p * (1 - p))
for (j in 1:numpop){
ind1 = (j-1) * N * omega[j] + 1
ind2 = j * N * omega[j]
freqs = c(ps[j]^2, 2 * ps[j] * (1 - ps[j]), (1 - ps[j])^2)
genomat[ind1:ind2, i] = sample(c(0, 1, 2), size = N*omega[j], replace = TRUE, prob = freqs)
}
}
snpmeans = colMeans(genomat)
pi = (1 + colSums(genomat)) / (2 + 2*nrow(genomat))
stdmat = scale(genomat, center=snpmeans, scale=sqrt(pi*(1-pi)))
pr = prcomp(stdmat, center=F, scale=F)
Plotting:
get( getOption("device" ) )()
png(file="myplot.png", width=2000, height = 1200)
par(oma = c(0,0,3,0))
split.screen(c(1,2)) # split display into two screens
plot(pr$x,
col = c(rep("red", N*omega[1]), rep("blue", N*omega[2])),
main = "Whole genotype data")
split.screen(c(2, 3), screen = 2) # now split the second into 2x3
for(i in 1:8) ## 8=#of screens
{
screen(i) # prepare screen i for output
fA=0.5
fa = 1-fA
combined_SNP <- sample(c(0:2), N, prob=c(fA^2, 2*fA*fa, fa^2), replace=T)
pheno_indep <-c()
##Phenotypes
for (i in 1:length(combined_SNP)){
if (combined_SNP[i] == '0') {
pheno_indep<- c(pheno_indep, rnorm(1, mean = 0.07, sd = 1))
} else if (combined_SNP[i ]== '1') {
pheno_indep <- c(pheno_indep, rnorm(1, mean = 0, sd = 1))
} else {
pheno_indep <- c(pheno_indep, rnorm(1, mean = -0.07, sd = 1))
}
}
l <- 1:N
combined_indep <- cbind(combined_SNP, pheno_indep, l)
sorted_combined <- combined_indep[order(combined_indep[, 2]), ]
##eps data
f = 0.1
Nums = nrow(sorted_combined)
keep <- c(1:(f*Nums), (Nums-(f*Nums)+1):Nums)
epsdat<- c(rep("0", f*Nums), rep("1", f*Nums))
EPS_dat <- as.factor(cbind(sorted_combined[keep, ], epsdat))
dim(EPS_dat) <- c(length(keep), 4)
#colnames(EPS_dat) <- c("Genotypes", "Phenotypes", "ID", "position")
PC_EPS <- prcomp((genomat[EPS_dat[, 3], ]))
plot(PC_EPS$x,
col=c(rep("red", f*Nums), rep("blue", f*Nums)))
}
close.screen(all=TRUE)
dev.off()
Result:
I have spent a lot of time trying to figure this out even with other packages like layout.show. Thanks!
Is the following what you expect to be plotted? (I added screen title to the small plots for illustration)
When you split the screens, you should have gotten the following on your console:
> split.screen(c(1, 2))
[1] 1 2
# (code used to plot first chart on the left)
> split.screen(c(2, 3), screen = 2)
[1] 3 4 5 6 7 8
As described in the help file ?split.screen, this is a a vector of screen numbers for the newly-created screens. So your valid screen numbers are 1 (already plotted), and 3-8 (6 small screens).
As such, the next line doesn't work as expected, since you're now looping through screens 1-8 rather than screens 3-8.
# instead of
for(i in 1:8) ## 8=#of screens
# use this
for(i in 3:8) ## 8=#of screens
As a side note, you should also use different loop counters for nested loops. Your outer loop (for the 6 small plots) used i as the loop counter. Within this loop, you have another loop for phenotypes, which used i as well. Since the screen selection was done at the start of each outer loop iteration, the code still worked in this case, but in general, best to keep the loop counters separate.
I have the following function that I need to (m)apply on a list of more than 1500 large matrices (Z) and a list of vectors (p) of the same length. However, I get the error that some matrices are singular as I already posted here. Here my function:
kastner <- function(item, p) { print(item)
imp <- rowSums(Z[[item]])
exp <- colSums(Z[[item]])
x = p + imp
ac = p + imp - exp
einsdurchx = 1/as.vector(x)
einsdurchx[is.infinite(einsdurchx)] <- 0
A = Z[[item]] %*% diag(einsdurchx)
R = solve(diag(length(p))-A) %*% diag(p)
C = ac * einsdurchx
R_bar = diag(as.vector(C)) %*% R
rR_bar = round(R_bar)
return(rR_bar)
}
and my mapply command that also prints the names of the running matrix:
KASTNER <- mapply(kastner, names(Z), p, SIMPLIFY = FALSE)
In order to overcome the singularity problem, I want to add a small amount of jitter the singular matrices. The problem starts in line 9 of the function R = solve(diag(length(p))-A) %*% diag(p) as this term(diag(length(p))-A) gets singular and can't be solved. I tried to add jitter to all Z matrices in the first line of the function using: Z <- lapply(Z,function(x) jitter(x, factor = 0.0001, amount = NULL)), but this is very very low and produces still errors.
Therefore my idea is to check with if/else or something similar if this matrix diag(length(p))-A is singular (maybe using eigenvectors to check collinearity) and add on those matrices jitter, else (if not) the solve command should performed as it is. Ideas how to implement this on the function? Thanks
Here some example data, although there is no problem with singularity as I was not able to rebuild this error for line 9:
Z <- list("111.2012"= matrix(c(0,0,100,200,0,0,0,0,50,350,0,50,50,200,200,0),
nrow = 4, ncol = 4, byrow = T),
"112.2012"= matrix(c(10,90,0,30,10,90,0,10,200,50,10,350,150,100,200,10),
nrow = 4, ncol = 4, byrow = T))
p <- list("111.2012"=c(200, 1000, 100, 10), "112.2012"=c(300, 900, 50, 100))
Edit: a small amount o jitter shouldn't be problematic in my data as I have probably more than 80% of zeros in my matrices and than large values. And I am only interested in those large values, but the large amount of 0s are probably the reason for the singularity, but needed.
Since you didn't provide a working example I couldn't test this easily, so the burden of proof is on you. :) In any case, it should be a starting point for further tinkering. Comments in the code.
kastner <- function(item, p) { print(item)
imp <- rowSums(Z[[item]])
exp <- colSums(Z[[item]])
x = p + imp
ac = p + imp - exp
einsdurchx = 1/as.vector(x)
einsdurchx[is.infinite(einsdurchx)] <- 0
# start a chunk that repeats until you get a valid result
do.jitter <- TRUE # bureaucracy
while (do.jitter == TRUE) {
# run the code as usual
A = Z[[item]] %*% diag(einsdurchx)
# catch any possible errors, you can even catch "singularity" error here by
# specifying error = function(e) e
R <- tryCatch(solve(diag(length(p))-A) %*% diag(p), error = function(e) "jitterme")
# if you were able to solve(), and the result is a matrix (carefuly if it's a vector!)...
if (is.matrix(R)) {
# ... turn the while loop off
do.jitter <- FALSE
} else {
#... else apply some jitter and repeat by construcing A from a jittered Z[[item]]
Z[[item]] <- jitter(Z[[item]])
}
}
C = ac * einsdurchx
R_bar = diag(as.vector(C)) %*% R
rR_bar = round(R_bar)
return(rR_bar)
}
obj1<-function(monthly.savings,
success,
start.capital,
target.savings,
monthly.mean.return,
monthly.ret.std.dev,
monthly.inflation,
monthly.inf.std.dev,
n.obs,
n.sim=1000){
req = matrix(start.capital, n.obs+1, n.sim) #matrix for storing target weight
monthly.invest.returns = matrix(0, n.obs, n.sim)
monthly.inflation.returns = matrix(0, n.obs, n.sim)
monthly.invest.returns[] = rnorm(n.obs * n.sim, mean = monthly.mean.return, sd = monthly.ret.std.dev)
monthly.inflation.returns[] = rnorm(n.obs * n.sim, mean = monthly.inflation, sd = monthly.inf.std.dev)
#for loop to be
for (a in 1:n.obs){
req[a + 1, ] = req[a, ] * (1 + monthly.invest.returns[a,] - monthly.inflation.returns[a,]) + monthly.savings
}
ending.values=req[nrow(req),]
suc<-sum(ending.values>target.savings)/n.sim
value<-success-suc
return(abs(value))
}
I have the above objective function that I want to minimize for. It tries to solve for the monthly savings required for a given probability of success. Given the following input assumptions
success<-0.9
start.capital<-1000000
target.savings<-1749665
monthly.savings=10000
monthly.mean.return<-(5/100)/12
monthly.ret.std.dev<-(3/100)/sqrt(12)
monthly.inflation<-(5/100)/12
monthly.inf.std.dev<-(1.5/100)/sqrt(12)
monthly.withdrawals<-10000
n.obs<-10*12 #years * 12 months in a year
n.sim=1000
I used the following notation:
optimize(f=obj1,
success=success,
start.capital=start.capital,
target.savings=target.savings,
monthly.mean.return=monthly.mean.return,
monthly.ret.std.dev=monthly.ret.std.dev,
monthly.inflation=monthly.inflation,
monthly.inf.std.dev=monthly.inf.std.dev,
n.obs = n.obs,
n.sim = n.sim,
lower = 0,
upper = 10000,
tol = 0.000000001,maximum=F)
I get 7875.03
Since I am sampling from a normal distribution, the output will be different each time but they should be around the same give or take a few % points. The problem I am having is that I can't specify a upper limit arbitrarily. The above example's upper limit (10000) is cherry picked after numerous trials. If say I put in a upper limit of 100000 (unreasonable I know) it will return that number as oppose to finding the global minimum saving. Any ideas where I am structuring my objective function incorrectly?
thanks,
The fact that your function does not always return the same output for a given input
is likely to pose a few problems (it will create a lot of spurious local minima):
you can avoid them by setting the seed of the random number generator
inside the function (e.g., set.seed(1)),
or by storing the random numbers and reusing them each time,
or by using a low-discrepancy sequence (e.g., randtoolbox::sobol).
Since it is a function of one variable, you can simply plot it to see what happens:
it has a plateau after 10,000 -- optimization algorithms cannot distinguish
between a plateau and a local optimum.
f <- function(x) {
set.seed(1)
obj1(x,
success = success,
start.capital = start.capital,
target.savings = target.savings,
monthly.mean.return = monthly.mean.return,
monthly.ret.std.dev = monthly.ret.std.dev,
monthly.inflation = monthly.inflation,
monthly.inf.std.dev = monthly.inf.std.dev,
n.obs = n.obs,
n.sim = n.sim
)
}
g <- Vectorize(f)
curve(g(x), xlim=c(0, 20000))
Your initial problem is actually not a minimization problem,
but a root finding problem, which is much easier.
obj2 <- function(monthly.savings) {
set.seed(1)
req = matrix(start.capital, n.obs+1, n.sim)
monthly.invest.returns <- matrix(0, n.obs, n.sim)
monthly.inflation.returns <- matrix(0, n.obs, n.sim)
monthly.invest.returns[] <- rnorm(n.obs * n.sim, mean = monthly.mean.return, sd = monthly.ret.std.dev)
monthly.inflation.returns[] <- rnorm(n.obs * n.sim, mean = monthly.inflation, sd = monthly.inf.std.dev)
for (a in 1:n.obs)
req[a + 1, ] <- req[a, ] * (1 + monthly.invest.returns[a,] - monthly.inflation.returns[a,]) + monthly.savings
ending.values <- req[nrow(req),]
suc <- sum(ending.values>target.savings)/n.sim
success - suc
}
uniroot( obj2, c(0, 1e6) )
# [1] 7891.187