Commit e6c8c47e authored by Gilles Kratzer's avatar Gilles Kratzer
Browse files

update CRAN

parent 09427d79
Pipeline #2071 passed with stage
in 4 seconds
......@@ -252,27 +252,32 @@ MBR <- function(n.var, dag.tmp, max.parents, sc, score.cache, score, verbose) {
############################## Acceptance probability
score.MBR <- score.dag(dag = dag.MBR,bsc.score = score.cache,sc = sc)
#score.A <- exp(z.i.G.0 - z.star.i.G.prime.0 + sum(score.G) - sum(score.G.prime))
score.A <- exp(- score + score.MBR)
print(score);print(score.MBR)
score.A <- exp(z.i.G.0 - z.star.i.G.prime.0 + sum(score.G) - sum(score.G.prime))
A <- min(1, score.A)
if (rbinom(n = 1, size = 1, prob = A) == 1) {
rejection <- 1
rejection <- 0
dag.tmp <- dag.MBR
score.MBR <- 0
for (a in 1:n.var) {
sc.tmp <- sc[score.cache$children == a, ]
score.MBR <- sum(min(sc.tmp[(apply(sc.tmp, 1, function(x) identical(unname(x[1:n.var]), unname(dag.tmp[a,
])))), n.var + 1]), score.MBR)
}
#score.MBR <- 0
# for (a in 1:n.var) {
# sc.tmp <- sc[score.cache$children == a, ]
# score.MBR <- sum(min(sc.tmp[(apply(sc.tmp, 1, function(x) identical(unname(x[1:n.var]), unname(dag.tmp[a,
# ])))), n.var + 1]), score.MBR)
# }
score <- score.MBR
print(score.MBR)
}
}
} #EOIF
if (is.null(A)) {
A <- 0
}
############################## Return
############################## Return ##score.MBR <- score
return(list(dag.tmp = dag.tmp, score = score, alpha = A, rejection = rejection))
} #EOF
......@@ -178,7 +178,7 @@ REV <- function(n.var, dag.tmp, max.parents, sc, score.cache, score, verbose) {
############################## Acceptance probability
score.A <- n.edges/n.edges.tilde * exp(z.star.x.i.M.dot - z.star.x.j.M.dot + z.x.j.M.cross - z.x.j.M.cross)
score.A <- n.edges/n.edges.tilde * exp(z.star.x.i.M.dot - z.star.x.j.M.dot + z.x.j.M.cross - z.x.i.M.tilde.cross)
A <- min(1, score.A)
if (rbinom(n = 1, size = 1, prob = A) == 1) {
......
......@@ -148,7 +148,7 @@ mcmcabn <- function(score.cache = NULL, score = "mlik", data.dists = NULL, max.p
if (verbose) {
print("MBR move")
}
out <- MBR(n.var, (dag.tmp), max.parents, sc, score.cache, score, verbose)
out <- MBR(n.var, dag.tmp, max.parents, sc, score.cache, score, verbose)
dag.tmp <- out$dag.tmp
score <- out$score
})
......
......@@ -10,7 +10,7 @@
if (is.null(score.cache))
stop("A cache of score should be provided. You can produce it using the R package abn.")
if (max(rowSums(score.cache$node.defn)) < max.parents)
if (max(rowSums(score.cache$node.defn)) > (max.parents+1))
stop("Check max.parents. It should be the same as the one used in abn::buildscorecache() R function")
if (length(mcmc.scheme) != 3)
......@@ -225,3 +225,17 @@ range01 <- function(x) {
is.integer0 <- function(x) {
is.integer(x) && length(x) == 0L
}
##-------------------------------------------------------------------------
## scoring DAGs
##-------------------------------------------------------------------------
score.dag <- function(dag,bsc.score,sc){
n.var <- dim(dag)[1]
score <- 0
for (a in 1:n.var) {
sc.tmp <- sc[bsc.score$children == a, ]
score <- sum(min(sc.tmp[(apply(sc.tmp, 1, function(x) identical(unname(x[1:n.var]), unname(dag[a,])))), n.var + 1]), score)
}
return(score)
}
model{
###-----------------------
###Binomial nodes
###-----------------------
A ~ dbern(p.A); #Binary response
logit(p.A) <- 0 + 0.45*C; #Logistic regression
###-----------------------
###Binomial nodes
###-----------------------
B ~ dbern(p.B); #Binary response
logit(p.B) <- 0.45 + 0.45*A + 0.45*E; #Logistic regression
###-----------------------
###Binomial nodes
###-----------------------
C ~ dbern(p.C); #Binary response
logit(p.C) <- 0; #Logistic regression
###-----------------------
###Binomial nodes
###-----------------------
D ~ dbern(p.D); #Binary response
logit(p.D) <- 0 + 0.45*E; #Logistic regression
###-----------------------
###Binomial nodes
###-----------------------
E ~ dbern(p.E); #Binary response
logit(p.E) <- 0.45 + 0.45*C; #Logistic regression
}
\ No newline at end of file
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment