Bayesian in R: Dimension mismatch in values supplied for betaA - r
I am working with a matrix that is 35 rows and 16 columns. I am trying to run a Bayesian Multistate Model but something in my model code prevents it from working. When I run the code in R, I get the error message:
`
Error in checkForRemoteErrors(val) :
3 nodes produced errors; first error: RUNTIME ERROR:
Dimension mismatch in values supplied for betaA
`
Any help is appreciated and my code is below:
# psi = movement probability
# phi = apparent survival
# p = detection probability
# o = occurrence probability
# load libraries
library(jagsUI)
library(lattice)
library(coda)
library("R2WinBUGS")
library("R2jags")
library(zoo)
devtools::install_github("bstaton1/postpack")`
# initializing functions####
known.state.ms <- function(ms, notseen){
#notseen: label for 'not seen'
state <- ms
state[state==notseen] <- NA
for (i in 1:dim(ms)[1]){
m <- min(which(!is.na(state[i,])))
state[i,m] <- NA
}
return(state)
`}`
#i = 1
#ch = CHY[i,]
#first = f[i]`
z_inits = function(ch, first) {
nt = length(ch)
to_fill = which(ch == 4 & 1:nt >= first)
to_keep = which(ch != 4 & 1:nt >= first)
known = ch; known[to_fill] = NA
unknown = rep(NA, nt)
known_alive = rep(NA, nt)
unknown[to_fill] = 2
for (t in 1:nt) {
known_alive[t] = ifelse(any(!is.na(known[t:nt])), 1, 0)
}
last_known_alive = max(which(known_alive == 1))
if (last_known_alive < 16) {
dead = rep(0, nt)
for (t in (last_known_alive + 1):nt) {
dead[t] = sample(c(0,1), size = 1, prob = matrix(c(0.9, 0.1, 0, 1), 2,
2, byrow = T)[dead[t-1] + 1,])
}
unknown[dead == 1] = 4
}
unknown
}
`
# import data
dat <- read.csv("bass_encounter_history_0.csv")
covs <- read.csv("depth.csv")
depth = covs[,1]
histories <- unlist(lapply(dat$history, function(x) strsplit(x,split="")))
CH <- t(matrix(histories,nrow=16,ncol=35))
CH <- gsub("0",4,CH)
CH <- gsub("A",1,CH)
CH <- gsub("B",2,CH)
CH <- gsub("C",3,CH)
CH <- matrix(as.numeric(CH),nrow=35,ncol=16)
# Built the model####
nind= nrow(CH)
n.occasions = ncol(CH)
f=c(1,1,1,2,2,2,2,2,3,3,3,4,4,4,4,4,4,1,1,1,3,1,1,1,3,3,3,3,5,3,5,6,6,6,6) # initial tagging week
jags_model = function() {
# -------------------------------------------------
# Parameters:
# phiA: survival probability at site A
# phiB: survival probability at site B
# phiC: survival probability at site C
# psiA[1,t]: probability of staying in site A
# psiA[2,t]: movement probability from site A to site B
# psiB[1,t]: movement probability from site B to site A
# psiB[2,t]: probability of staying in site B
# psiB[3,t]: movement probability from site B to site C
# psiC[1,t]: probability of staying in site C
# psiC[2,t]: movement probability from site C to site B
# betaA[i]: the effect of standardized flow on movement probabilities at site A
# betaB[i]: the effect of standardized flow on movement probabilities at site B
# betaC[i]: the effect of standardized flow on movement probabilities at site C
# wA,B,C: the variable weight of the betas, 1 = essential, 0 = insignificant
# pA: recapture probability at site A
# pB: recapture probability at site B
# pC: recapture probability at site C
# -------------------------------------------------
# States (S):
# 1 alive at A
# 2 alive at B
# 3 alive at C
# 4 dead
# Observations (O):
# 1 seen at A
# 2 seen at B
# 3 seen at C
# 4 not seen
# -------------------------------------------------
# Priors and constraints
# Survival and recapture: uniform
phiA ~ dunif(0, 1)
phiB ~ dunif(0, 1)
phiC ~ dunif(0, 1)
pA ~ dunif(0, 1)
pB ~ dunif(0, 1)
pC ~ dunif(0, 1)
wA ~ dbern(.5)
for(i in 1:3){
wB[i] ~ dbern(.5)
}
wC ~ dbern(.5)
for(t in 1:(n.occasions-1)){
logit(psiA[1,t]) <- muA + wA*betaA*x[t]
psiA[2,t] <- 1 - psiA[1,t]
logit(psiC[1,t]) <- muC + wC*betaC*x[t]
psiC[2,t] <- 1 - psiC[1,t]
for(i in 1:3){
b[i,t] <- exp(muB[i] + wB[i]*betaB[i]*x[t])
psiB[i,t] <- b[i,t]/sum(b[,t])
}
}
muA ~ dt(0, 1/1.566^2, 7.763)
muC ~ dt(0, 1/1.566^2, 7.763)
mean.psiA <- 1/(1+exp(-muA))
#it's not really the mean - it's the probability of staying in A at mean value of x (only b/c x is z- transformed)
mean.psiC <- 1/(1+exp(-muC))
betaA ~ dt(0, 1/1.566^2, 7.763)
betaC ~ dt(0, 1/1.566^2, 7.763)
for(i in 1:2){
muB[i] ~ dt(0, 1/1.566^2, 7.763)
betaB[i] ~ dt(0, 1/1.566^2, 7.763)
}
muB[3] <- 0
betaB[3] <- 0
# PREDICTED TRANSITION PROBS FOR PLOTTING
for(r in 1:n.depth){
for(i in 1:3){
pred.b[i,r] <- exp(muB[i] + wB[i]*betaB[i]*depthseq[r])
pred.psiB[i,r] <- pred.b[i,r]/sum(pred.b[,r])
}
logit(pred.psiA[1,r]) <- muA + wA*betaA*depthseq[r]
pred.psiA[2,r] <- 1 - pred.psiA[1,r]
logit(pred.psiC[1,r]) <- muC + wC*betaC*depthseq[r]
pred.psiC[2,r] <- 1 - pred.psiC[1,r]
}
# Define probabilities of state S(t+1) given S(t)
for (t in 1:(n.occasions-1)){
ps[1,t,1] <- phiA * psiA[1,t]
ps[1,t,2] <- phiA * psiA[2,t]
ps[1,t,3] <- 0
ps[1,t,4] <- 1-phiA
ps[2,t,1] <- phiB * psiB[1,t]
ps[2,t,2] <- phiB * psiB[2,t]
ps[2,t,3] <- phiB * psiB[3,t]
ps[2,t,4] <- 1-phiB
ps[3,t,1] <- 0
ps[3,t,2] <- phiC * psiC[2,t]
ps[3,t,3] <- phiC * psiC[1,t] # switch these so the coefs talk about prob(stay in C)
ps[3,t,4] <- 1-phiC
ps[4,t,1] <- 0
ps[4,t,2] <- 0
ps[4,t,3] <- 0
ps[4,t,4] <- 1
# Define probabilities of O(t) given S(t)
po[1,t,1] <- pA
po[1,t,2] <- 0
po[1,t,3] <- 0
po[1,t,4] <- 1-pA
po[2,t,1] <- 0
po[2,t,2] <- pB
po[2,t,3] <- 0
po[2,t,4] <- 1-pB
po[3,t,1] <- 0
po[3,t,2] <- 0
po[3,t,3] <- pC
po[3,t,4] <- 1-pC
po[4,t,1] <- 0
po[4,t,2] <- 0
po[4,t,3] <- 0
po[4,t,4] <- 1
} #t
# Likelihood
for (i in 1:nind){
# Define latent state at first capture
z[i,f[i]] <- y[i,f[i]]
for (t in (f[i]+1):n.occasions){
# State process: draw S(t) given S(t-1)
z[i,t] ~ dcat(ps[z[i,t-1], t-1,])
# Observation process: draw O(t) given S(t)
y[i,t] ~ dcat(po[z[i,t], t-1,])
} #t
} #i
}
jags_file = "invasiondepthmodel.txt"
postpack::write_model(jags_model, jags_file)
# Configure the model settings and initial values ####
depthseq = seq(min(depth),max(depth),length.out=100)
n.depth=length(depthseq)
#compile jags data object
jags_data <- list(y = CH, x= depth, depthseq=depthseq, n.depth=n.depth, f = f,
n.occasions = n.occasions, nind = nind, z = known.state.ms(CH, 4))
#specify initial values
jags_inits <- function(i){list(
muA = runif(1,-1,1),
muB = c(runif(2,-1,1),NA),
muC = runif(1,-1,1),
wA= rbinom(3, 1, 0.5),
wB= rbinom(3, 1, 0.5),
wC= rbinom(3, 1, 0.5),
betaA = runif(2,-1,1),
betaB = c(runif(2,-1,1),NA),
betaC = runif(2,-1,1),
phiA = runif(1, 0.5, 1),
phiB = runif(1, 0.5, 1),
phiC = runif(1, 0.5, 1),
pA = runif(1, 0.5, 1),
pB = runif(1, 0.5, 1),
pC = runif(1, 0.5, 1),
z = t(sapply(1:nind, function(i) z_inits(CH[i,], f[i])))
)
}
# Parameters monitored
jags_params <- c("phiA","phiB","phiC",
"psiA","psiB","psiC",
"wA","wB","wC",
"muA","muB","muC",
"betaA","betaB","betaC",
"pA","pB","pC",
"pred.psiA","pred.psiB","pred.psiC")
jags_dims = c(
na = 10000, # number of samples in adapting phase
ni = 40000, # number of post-burn-in samples per chain
nb = 40000, # number of burn-in samples
nt = 20, # thinning rate
nc = 3, # number of chains,
parallel = T # run chains in parallel?
); with(as.list(jags_dims), ni/nt * nc)
inits = lapply(1:jags_dims["nc"], jags_inits)
# Run the model in JAGS #####
starttime = Sys.time()
cat("MCMC Started: ", format(starttime), "\n")
post = jagsUI::jags.basic(
data = jags_data,
model.file = jags_file,
inits = inits,
parameters.to.save = jags_params,
n.adapt = jags_dims["na"],
n.iter = sum(jags_dims[c("ni", "nb")]),
n.thin = jags_dims["nt"],
n.burnin = jags_dims["nb"],
n.chains = jags_dims["nc"],
parallel = jags_dims["parallel"],
verbose = F
)
I was expecting the dimensions between the matrix and betaA values to match up. However, it seems like they are not.
In the model, betaA is a scalar. In the model code, you have betaA*x[t] and in the prior: betaA ~ dt(0, 1/1.566^2, 7.763) both indicating a single value. However, in the initial values, it is a vector of length 2: betaA = runif(2,-1,1). You either need to define it as a vector in the model or pass a single value in the inits.
Related
How can I use try catch for nls function in R
I am doing a regression for a Quadric Linear function. I got two option is to use either nlsLM and nls2. However, for some dataset, the use of nlsLM casing some problem such as: singular gradient matrix at initial parameter estimates or they ran in to an infinitie loop. I want to use the try catch to deal with this issue. Can anyone help me out? Thanks everyone in advance. Here is the full code: # Packages needed for estimaton of Ideal trajectory - nonlinear regression #------------------------------------------------------------------------------- library("minpack.lm") library("nlstools") library("nlsMicrobio") library("stats") library("tseries") #runs test for auto correlation #Use NLS2 library(proto) library(nls2) ################################################################ # Set working directory setwd("C:/Users/Kevin Le/PycharmProjects/Pig Data Black Box - Copy") #load dataset load("Data/JRPData_TTC.Rdata") #load dataset created in MissingData.step ID <- 5470 #Create a new dataframe which will store Data after ITC estimation #Dataframe contains ITC parameters ITC.param.pos2 <- data.frame(ANIMAL_ID=factor(), X0=double(), Y1=double(), Y2=double(), Ylast=double(), a=double(), b=double(), c=double(), d=double(), stringsAsFactors=FALSE) #Dataframe contains data points on the ITC Data.remain <- data.frame(ANIMAL_ID=character(), Age=double(), obs.CFI=double(), tt=double(), ttt=double(), stringsAsFactors=FALSE) #=============================================================== # For loop for automatically estimating ITC of all pigs #=============================================================== IDC <- seq_along(ID) # 17, 23, 52, 57, 116 for (idc in IDC){ # idc = 1 i <- ID[idc] Data <- No.NA.Data.1[No.NA.Data.1$ANIMAL_ID == i,] idc1 <- unique(as.numeric(Data$idc.1)) ####### Create data frame of x (Age) and y (CFI) ######## x <- as.numeric(Data$Age.plot) Y <- as.numeric(Data$CFI.plot) Z <- as.numeric(Data$DFI.plot) Data.xy <- as.data.frame(cbind(x,Y)) #Initial parameteres for parameter estimation X0.0 <- x[1] Xlast <- x[length(x)] ################################################################## # 1. reparametrization CFI at X0 = 0 #function used for reparametrization in MAPLE # solve({ # 0=a+b*X_0+c*X_0**2, # DFIs=b+2*c*Xs,CFIs=a+b*Xs+c*Xs**2}, # {a,b,c}); # a = -X0*(2*CFIs*Xs-CFIs*X0-Xs^2*DFIs+Xs*DFIs*X0)/(Xs^2-2*X0*Xs+X0^2) # b = (-Xs^2*DFIs+DFIs*X0^2+2*CFIs*Xs)/(Xs^2-2*X0*Xs+X0^2) # c = -(CFIs-Xs*DFIs+X0*DFIs)/(Xs^2-2*X0*Xs+X0^2) # 2. with the source of the function abcd and pred ################################################################## #Provide set of initial parameters Xs.1 <- round(seq(X0.0 + 1, Xlast - 1, len = 30), digits = 0) X0.1 <- rep(X0.0, length(Xs.1)) DFIs.1 <- NULL CFIs.1 <- NULL for(A in seq_along(Xs.1)){ DFIs2 <- Data[Data$Age.plot == Xs.1[A],]$DFI.plot CFIs2 <- Data[Data$Age.plot == Xs.1[A],]$CFI.plot DFIs.1 <- c(DFIs.1, DFIs2) CFIs.1 <- c(CFIs.1, CFIs2) } st1 <- data.frame(cbind(X0.1, Xs.1, DFIs.1, CFIs.1)) names(st1) <- c("X0","Xs", "DFIs","CFIs") #RUN NLS2 to find optimal initial parameters st2 <- nls2(Y ~ nls.func.2(X0, Xs, DFIs, CFIs), Data.xy, start = st1, # weights = weight, # trace = T, algorithm = "brute-force") par_init <- coef(st2); par_init #-------------------------------------------- # Create empty lists to store data after loop #-------------------------------------------- par <- list() AC.res <- list() AC.pvalue <- NULL data2 <- list() data3 <- list() param <- data.frame(rbind(par_init)) par.abcd <- data.frame(rbind(abcd.2(as.vector(par_init)))) param.2 <- data.frame(X0=double(), Xs=double(), DFIs=double(), CFIs=double(), a=double(), b=double(), c=double(), stringsAsFactors=FALSE) j <- 2 AC_pvalue <- 0 AC.pvalue[1] <- AC_pvalue datapointsleft <- as.numeric(dim(Data)[1]) dpl <- datapointsleft #vector of all dataponitsleft at each step #------------------------------------------------------------------------------- # Start the procedure of Non Linear Regression #------------------------------------------------------------------------------- while ((AC_pvalue<=0.05) && datapointsleft >= 20){ weight <- 1/Y^2 # ---------------- NON linear reg applied to log(Y) --------------------------------- st2 <- nls2(Y ~ nls.func.2(X0, Xs, DFIs, CFIs), Data.xy, start = st1, weights = weight, trace = F, algorithm = "brute-force") par_init <- coef(st2) par_init # st1 <- st1[!(st1$Xs == par_init[2]),] nls.CFI <- nlsLM(Y ~ nls.func.2(X0, Xs, DFIs, CFIs), Data.xy, control = list(tol = 1e-2, printEval = TRUE, maxiter = 1024), start = list(X0 = par_init[1], Xs = par_init[2], DFIs = par_init[3], CFIs = par_init[4]), weights = weight, algorithm = "port", lower = c(-10000,X0.0+1, -10000, -10000), upper = c(10000, Xlast-1, 10000, 10000), trace = F) # nls.CFI <- nls2(Y ~ nls.func.2(X0, Xs, DFIs, CFIs), # Data.xy, # start = list(X0 = par_init[1], Xs = par_init[2], # DFIs = par_init[3], CFIs = par_init[4]), # weights = weight, # control = nls.control(warnOnly = TRUE), # trace = T, # algorithm = "port", # lower = c(-100000000,X0.0+1, -1000000000, -1000000000), # upper = c(1000000000, Xlast-1, 1000000000, 1000000000)) # nls.CFI <- nlsLM(Y ~ nls.func.2(X0, Xs, DFIs, CFIs), # Data.xy, # control = nls.control(warnOnly = TRUE), # start = list(X0 = par_init[1], Xs = par_init[2], # DFIs = par_init[3], CFIs = par_init[4]), # weights = weight, # algorithm = "port", # lower = c(-1000000000,X0.0+1, -1000000000, -1000000000), # upper = c(1000000000, Xlast-1, 1000000000, 1000000000), # trace = F) #--------RESULTS analysis GOODNESS of fit #estimate params par[[j]] <- coef(nls.CFI) par.abcd[j,] <- abcd.2(as.vector(coef(nls.CFI) )) #calculation of a, b, c and d param[j,] <- par[[j]] param.2[j-1,] <- cbind(param[j,], par.abcd[j,]) #summary # summ = overview((nls.CFI)) #summary #residuals res1 <- nlsResiduals(nls.CFI) #residuals res2 <- nlsResiduals(nls.CFI)$resi1 res <- res2[, 2] AC.res <- test.nlsResiduals(res1) AC.pvalue[j] <- AC.res$p.value #---------Check for negative residuals---------- #Add filtration step order to data Step <- rep(j - 1, length(x)) #create a new dataset with predicted CFI included Data.new <- data.frame(cbind(x, Z, Y, pred.func.2(par[[j]],x)[[1]], res, Step)) names(Data.new) <- c("Age", "Observed_DFI","Observed_CFI", "Predicted_CFI", "Residual", "Step") # plot(Data.new$Age, Data.new$Predicted_CFI, type = "l", col = "black",lwd = 2, # ylim = c(0, max(Data.new$Predicted_CFI, Data.new$Observed_CFI))) # lines(Data.new$Age, Data.new$Observed_CFI, type = "p", cex = 1.5) # #remove negative res Data.pos <- Data.new[!Data.new$Residual<0,] # lines(Data.pos$Age, Data.pos$Predicted_CFI, type = "l", col = j-1, lwd = 2) # lines(Data.pos$Age, Data.pos$Observed_CFI, type = "p", col = j, cex = 1.5) #restart #Criteria to stop the loop when the estimated parameters are equal to initial parameters # Crite <- sum(param.2[dim(param.2)[1],c(1:4)] == par_init) datapointsleft <- as.numeric(dim(Data.pos)[1]) par_init <- par[[j]] AC_pvalue <- AC.pvalue[j] j <- j+1 x <- Data.pos$Age Y <- Data.pos$Observed_CFI Z <- Data.pos$Observed_DFI Data.xy <- as.data.frame(cbind(x,Y)) dpl <- c(dpl, datapointsleft) dpl #Create again the grid X0.0 <- x[1] Xlast <- x[length(x)] #Xs if(par_init[2] -15 <= X0.0){ Xs.1 <- round(seq(X0.0 + 5, Xlast - 5, len = 30), digits = 0) } else if(par_init[2] + 5 >= Xlast){ Xs.1 <- round(seq(par_init[2]-10, par_init[2]-1, len = 6), digits = 0) } else{ Xs.1 <- round(seq(par_init[2]-5, par_init[2] + 5, len = 6), digits = 0) } # X0.1 <- rep(X0.0, length(Xs.1)) DFIs.1 <- NULL CFIs.1 <- NULL for(A in seq_along(Xs.1)){ DFIs2 <- Data[Data$Age.plot == Xs.1[A],]$DFI.plot CFIs2 <- Data[Data$Age.plot == Xs.1[A],]$CFI.plot DFIs.1 <- c(DFIs.1, DFIs2) CFIs.1 <- c(CFIs.1, CFIs2) } st1 <- data.frame(cbind(X0.1, Xs.1, DFIs.1, CFIs.1)) if(X0.0 <= par_init[2] && Xlast >=par_init[2]){ st1 <- rbind(st1, par_init) } names(st1) <- c("X0","Xs", "DFIs","CFIs") } } # end FOR loop Here is the data file. I have exported my data into the .Rdata for an easier import.: https://drive.google.com/file/d/1GVMarNKWMEyz-noSp1dhzKQNtu2uPS3R/view?usp=sharing In this file, the set id: 5470 will have this error: singular gradient matrix at initial parameter estimates in this part: nls.CFI <- nlsLM(Y ~ nls.func.2(X0, Xs, DFIs, CFIs), Data.xy, control = list(tol = 1e-2, printEval = TRUE, maxiter = 1024), start = list(X0 = par_init[1], Xs = par_init[2], DFIs = par_init[3], CFIs = par_init[4]), weights = weight, algorithm = "port", lower = c(-10000,X0.0+1, -10000, -10000), upper = c(10000, Xlast-1, 10000, 10000), trace = F) The complementary functions (file Function.R): abcd.2 <- function(P){ X0 <- P[1] Xs <- P[2] DFIs <- P[3] CFIs <- P[4] a <- -X0*(2*CFIs*Xs-CFIs*X0-Xs^2*DFIs+Xs*DFIs*X0)/(Xs^2-2*X0*Xs+X0^2) b <- (-Xs^2*DFIs+DFIs*X0^2+2*CFIs*Xs)/(Xs^2-2*X0*Xs+X0^2) c <- -(CFIs-Xs*DFIs+X0*DFIs)/(Xs^2-2*X0*Xs+X0^2) pp <- as.vector(c(a, b, c)) return(pp) } #-------------------------------------------------------------- # NLS function #-------------------------------------------------------------- nls.func.2 <- function(X0, Xs, DFIs, CFIs){ pp <- c(X0, Xs, DFIs, CFIs) #calculation of a, b and c using these new parameters c <- abcd.2(pp)[3] b <- abcd.2(pp)[2] a <- abcd.2(pp)[1] ind1 <- as.numeric(x < Xs) return (ind1*(a+b*x+c*x^2)+(1-ind1)*((a+b*(Xs)+c*(Xs)^2)+(b+2*c*(Xs))*(x-(Xs)))) } #-------------------------------------------------------------- # Fit new parameters to a quadratic-linear function of CFI #-------------------------------------------------------------- pred.func.2 <- function(pr,age){ # X0 <- pr[1] Xs <- pr[2] DFIs <- pr[3] CFIs <- pr[4] # x <- age #calculation of a, b and c using these new parameters c <- abcd.2(pr)[3] b <- abcd.2(pr)[2] a <- abcd.2(pr)[1] # ind1 <- as.numeric(x < Xs) # results <- list() cfi <- ind1*(a+b*x+c*x^2)+(1-ind1)*((a+b*(Xs)+c*(Xs)^2)+(b+2*c*(Xs))*(x-(Xs))) #CFI dfi <- ind1*(b+2*c*x) + (1 - ind1)*(b+2*c*(Xs)) #DFI results[[1]] <- cfi results[[2]] <- dfi return (results) } #--------------------------------------------------------------------------------------------------------------- # Quadratic-linear function of CFI curve and its 1st derivative (DFI) with original parameters (only a, b and c) #--------------------------------------------------------------------------------------------------------------- pred.abcd.2 <- function(pr,age){ # a <- pr[1] b <- pr[2] c <- pr[3] x <- age #calculation of a, b and c using these new parameters # ind1 <- as.numeric(x < Xs) # results <- list() cfi <- ind1*(a+b*x+c*x^2)+(1-ind1)*((a+b*(Xs)+c*(Xs)^2)+(b+2*c*(Xs))*(x-(Xs))) #CFI dfi <- ind1*(b+2*c*x) + (1 - ind1)*(b+2*c*(Xs)) #DFI results[[1]] <- cfi results[[2]] <- dfi return (results) } Updated: I did review my logic from the previous step and found that my data is a bit messed up because of it. I have fixed it. The case where a set f data ran into an infinite loop has no longer exists, but this error is still there however: singular gradient matrix at initial parameter estimates.
why random effect estiamator are not correct
I'm trying to simulate glmmLasso using a binomial data. but random effect estiamator are not similar 5 that i given. something wrong in my code? if not, why random effect shown like that. makedata <- function(I, J, p, sigmaB){ N <- I*J # fixed effect generation beta0 <- runif(1, 0, 1) beta <- sort(runif(p, 0, 1)) # x generation x <- matrix(runif(N*p, -1, 1), N, p) # random effect generation b0 <- rep(rnorm(I, 0, sigmaB), each=J) # group group <- as.factor(rep(1:I, each = J)) # y generation k <- exp(-(beta0 + x %*% beta + b0)) y <- rbinom(n = length(k), size = 1, prob = (1/(1+k))) #standardization sx <- scale(x, center = TRUE, scale = TRUE) simuldata <- data.frame(y = y, x = sx, group) res <- list(simuldata=simuldata) return(res) } # I : number of groups I <- 20 # J : number of observation in group J <- 10 # p : number of variables p <- 20 # sigmaB : sd of random effect b0 sigmaB <- 5 set.seed(231233) simdata <- makedata(I, J, p, sigmaB) lam <- 10 xnam <- paste("x", 1:p, sep=".") fmla <- as.formula(paste("y ~ ", paste(xnam, collapse= "+"))) glmm <- glmmLasso(fmla, rnd = list(group=~1), data = simdata, lambda = lam, control = list(scale = T, center = T)) summary(glmm)
How could I solve Dimension mismatch in Jags model.?
I'm super new in bayesian analysis and I'm trying to practice with an example for Classic Capture-recapture models: Mh2 This is my code nind <- dim(venados)[1] K <- 43 ntraps <- 13 M <- 150 nz <- M - nind Yaug <- array(0, dim = c(M, ntraps, K)) Yaug[1:nind,,] <- venados y <- apply(Yaug, c(1,3), sum) y[y > 1] <- 1 Bundle data data1 <- list(y = y, nz = nz, nind = nind, K = K, sup = Buffer) # Model JAGS sink("Mh2_jags.txt") cat(" model{ # Priors p0 ~ dunif(0,1) mup <- log(p0/(1-p0)) sigmap ~ dunif(0,10) taup <- 1/(sigmap*sigmap) psi ~ dunif(0,1) # Likelihood for (i in 1:(nind+nz)) { z[i] ~ dbern(psi) lp[i] ~ dnorm(mup,taup) logit(p[i]) <- lp[i] y[i] ~ dbin(mu[i],K) } # i N <- sum(z[1:(nind+nz)]) D <- N/sup*100 } # modelo ",fill = TRUE) sink() # Inicial values inits <- function(){list(z = as.numeric(y >= 1), psi = 0.6, p0 = runif(1), sigmap = runif(1, 0.7, 1.2), lp = rnorm(M, -0.2))} params1 <- c("p0","sigmap","psi","N","D") # MCMC ni <- 10000; nt <- 1; nb <- 1000; nc <- 3 # JAGS and posteriors fM2 <- jags(data1, inits, params1, "Mh2_jags.txt", n.chains = nc, n.thin = nt, n.iter = ni, n.burnin = nb) I received this error message Processing function input....... Done. Compiling model graph Resolving undeclared variables Deleting model Error in jags.model(file = model.file, data = data, inits = inits, n.chains = n.chains, : RUNTIME ERROR: Compilation error on line 16. Dimension mismatch in subset expression of y I have read that some letters as s and n have to be changed. However, I do not know what to do. Please if you could give an advice. Thank you very much
The issue is because y is two dimensional but the model assumes it is one dimensional. If you are assuming that the secondary surveys are i.i.d. Bernoulli trials (and each session had K trials)n then you would just need to take the sum of the rows of the y matrix. Assuming this is the case then you just need to modify a couple lines at the top of this script. nind <- dim(venados)[1] K <- 43 ntraps <- 13 M <- 150 nz <- M - nind Yaug <- array(0, dim = c(M, ntraps, K)) Yaug[1:nind,,] <- venados y <- apply(Yaug, c(1,3), sum) y[y > 1] <- 1 # Take the rowSum y_vector <- rowSums(y) # Use y_vector instead of y data1 <- list(y = y_vector, nz = nz, nind = nind, K = K, sup = Buffer) Conversely, if you wanted to include covariates for the observational process (and those covariates vary by survey) you would use the matrix y and modify the model. sink("Mh2_jags_Kloop.txt") cat(" model{ # Priors p0 ~ dunif(0,1) mup <- log(p0/(1-p0)) sigmap ~ dunif(0,10) taup <- 1/(sigmap*sigmap) psi ~ dunif(0,1) # Likelihood for (i in 1:(nind+nz)) { z[i] ~ dbern(psi) lp[i] ~ dnorm(mup,taup) logit(p[i]) <- lp[i] # Loop over K surveys for(j in 1:K){ y[i,j] ~ dbern(p[i]*z[i]) } } # i N <- sum(z[1:(nind+nz)]) D <- N/sup*100 } # modelo ",fill = TRUE) sink() Finally, you don't specify what mu is within the model. I think you want it to be p, but you also need to link the latent state model to the observational state model (if z=0 then that individual cannot be sampled. In this case you would interpret psi as the probability that nind+nz individuals are at your site. # Model JAGS sink("Mh2_jags.txt") cat(" model{ # Priors p0 ~ dunif(0,1) mup <- log(p0/(1-p0)) sigmap ~ dunif(0,10) taup <- 1/(sigmap*sigmap) psi ~ dunif(0,1) # Likelihood for (i in 1:(nind+nz)) { z[i] ~ dbern(psi) lp[i] ~ dnorm(mup,taup) logit(p[i]) <- lp[i] y[i] ~ dbin(p[i] * z[i],K) } # i N <- sum(z[1:(nind+nz)]) D <- N/sup*100 } # modelo ",fill = TRUE) sink()
Deep NN for multivariate regression
I implemented this simple NN but even when making it do all the interactions it fails to converge and the MSE remains very high I tried to change the number of iterations and the learning rate but it doesn't work rm(list=ls()) data <- read.csv("C:/Users/Mikele/Documents/Uni/IA AI & Machine Learning/R/11_23_2018/wine.csv",sep = ',',header = FALSE) x <- data[,1:11] y <- as.matrix(data[,12]) y_matrix <- matrix(rep(0,length(y)),nrow = length(y), ncol = 6) k <-1 for (w in 1:length(y)) { temp <- y[k] - 2 y_matrix[k,temp] <-1 k <- k + 1 } hl <- c(40, 30, 20) iter <- 1000 lr <- 0.1 ## add in intercept x_1 <- as.matrix(cbind(rep(1, nrow(x)),x)) ## set error array error <- rep(0, iter) ## set up weights ## the +1 is to add in the intercept/bias parameter W1 <- matrix(runif(ncol(x_1)*hl[1], -1, 1), nrow = ncol(x_1)) W2 <- matrix(runif((hl[1]+1)*hl[2], -1, 1), nrow = hl[1]+1) W3 <- matrix(runif((hl[2]+1)*hl[3], -1, 1), nrow = hl[2]+1) W4 <- matrix(runif((hl[3]+1)*ncol(y), -1, 1), nrow = hl[3]+1) for(k in 1:iter) { # calculate the hidden and output layers using X and hidden layer as inputs # hidden layer 1 and 2 have a column of ones appended for the bias term hidden1 <- cbind(matrix(1, nrow = nrow(x_1)), sigm(x_1 %*% W1)) hidden2 <- cbind(matrix(1, nrow = nrow(x_1)), sigm(hidden1 %*% W2)) hidden3 <- cbind(matrix(1, nrow = nrow(x_1)), sigm(hidden2 %*% W3)) y_hat <- sigm(hidden3 %*% W4) # calculate the gradient and back prop the errors # see theory above y_hat_del <- (y-y_hat)*(d.sigm(y_hat)) hidden3_del <- y_hat_del %*% t(W4)*d.sigm(hidden3) hidden2_del <- hidden3_del[,-1] %*% t(W3)*d.sigm(hidden2) hidden1_del <- hidden2_del[,-1] %*% t(W2)*d.sigm(hidden1) # update the weights W4 <- W4 + lr*t(hidden3) %*% y_hat_del W3 <- W3 + lr*t(hidden2) %*% hidden3_del[,-1] W2 <- W2 + lr*t(hidden1) %*% hidden2_del[,-1] W1 <- W1 + lr*t(x_1) %*% hidden1_del[,-1] error[k] <- 1/nrow(y)*sum((y-y_hat)^2) if((k %% (10^4+1)) == 0) cat("mse:", error[k], "\n") } # plot loss xvals <- seq(1, iter, length = 100) print(qplot(xvals, error[xvals], geom = "line", main = "MSE", xlab = "Iteration")) no error message but I can't understand how to make a deep NN for Multivariate Linear Regression in addition I divided the ys into a 6-column matrix (the maximum and minimum of the initial dataset) now there is someone who can help me understand why not cover and in any case the final results are all concentrated on column 4?
append values by dataframe row in a loop
I'm running models with various initial values, and I'm trying to append values (3 estimators) by rows to a dataframe in a loop. I assign values to estimators within the loop, but I can't recall them to produce a dataframe. My code: f is the model for the estimation. Three parameters: alpha, rho, and lambda in the model. I want to output these 3 values. library("maxLik") f <- function(param) { alpha <- param[1] rho <- param[2] lambda <- param[3] u <- 0.5 * (dataset$v_50_1)^alpha - 0.5 * lambda * (dataset$v_50_2)^alpha p <- 1/(1 + exp(-rho * u)) logl <- sum(dataset$gamble * log(p) + (1 - dataset$gamble) * log(1 - p)) } df <- data.frame(alpha = numeric(), rho = numeric(), lambda = numeric()) for (j in 1:20) { tryCatch({ ml <- maxLik(f, start = c(alpha = runif(1, 0, 2), rho = runif(1, 0, 4), lambda = runif(1, 0, 10)), method = "NM") alpha[j] <- ml$estimate[1] rho[j] <- ml$estimate[2] lambda[j] <- ml$estimate[3] }, error = function(e) {NA}) } output <- data.frame(alpha, rho, lambda) error occurs: Error in data.frame(alpha, rho, lambda) : object 'alpha' not found Expected output alpha rho lambda 0.4 1 2 # estimators append by row. 0.6 1.1 3 # each row has estimators that are estimated 0.7 1.5 4 # by one set of initial values, there are 20 # rows, as the estimation loops for 20 times.
I am running an example, by changing the function f library("maxLik") t <- rexp(100, 2) loglik <- function(theta) log(theta) - theta*t df <- data.frame(alpha = numeric(), rho = numeric(), lambda = numeric()) for (j in 1:20){ tryCatch({ ml <- maxLik(loglik, start = c(alpha = runif(1, 0, 2), rho = runif(1, 0, 4), lambda = runif(1, 0, 10)), method = "NM") df <- rbind(df, data.frame(alpha = ml$estimate[1], rho = ml$estimate[2], lambda = ml$estimate[3])) # I tried to append values for each column }, error = function(e) {NA})} > row.names(df) <- NULL > head(df) alpha rho lambda 1 2.368739 2.322220 2.007375 2 2.367607 2.322328 2.007093 3 2.368324 2.322105 2.007597 4 2.368515 2.322072 2.007334 5 2.368269 2.322071 2.007142 6 2.367998 2.322438 2.007391