Commit 5be1ab87 authored by Gilles Kratzer's avatar Gilles Kratzer
Browse files

update tests

parent 3448384c
Pipeline #1580 passed with stage
in 1 second
......@@ -28,26 +28,46 @@ mcmcabn <- function(score.cache = NULL,
##Tests
####################################################
if(is.null(score.cache))stop("A cache of score should be provided. YOu can produce it using the R package abn.")
.tests.mcmcabn(score.cache,
data.dists,
max.parents,
mcmc.scheme,
seed,
verbose,
start.dag,
prior.dag,
prior.lambda,
prob.rev,
prob.mbr,
prior.choice)
# if(is.null(score.cache))stop("A cache of score should be provided. YOu can produce it using the R package abn.")
# if(is.character(score)) score <- tolower(score)
# score <- c("bic", "aic", "mdl", "mlik")[pmatch(score,c("bic", "aic", "mdl", "mlik"))]
# if(score %!in% c("bic", "aic", "mdl", "mlik"))stop("A method should be provided and be one of: bic, aic, mdl or mlik.")
# if(max(rowSums(score.cache$node.defn))<max.parents)stop("Check max.parents. It should be the same as the one used in abn::buildscorecache() R function")
# if(length(mcmc.scheme)!=3)stop("An MCMC scheme have to be provided. It should be such that c(returned,thinned,burned) made of non negative integers.")
# if(!is.numeric(mcmc.scheme[1]) | !is.numeric(mcmc.scheme[2]) | !is.numeric(mcmc.scheme[3]) | mcmc.scheme[1]<0 | mcmc.scheme[2]<0 | mcmc.scheme[3]<0){stop("An MCMC scheme have to be provided. It should be such that c(returned,thinned,burned) made of non negative integers.")}
# if(max.parents<1 || max.parents>length(data.dists))stop("max.parents makes no sense.")
# if(is.numeric(prob.rev) && prob.rev>1 && prob.rev<0)stop("prob.rev should be a probability.")
# if(is.numeric(prob.mbr) && prob.mbr>1 && prob.mbr<0)stop("prob.mbr should be a probability.")
# if(is.matrix(start.dag) && dim(start.dag)!=c(length(data.dists),length(data.dists)))stop("start.dag should be a squared matrix with dimension equal to the number of variables.")
# if(is.matrix(start.dag) && is.null(topoSortMAT((start.dag)))){stop("start.dag should be a named DAG.")}
# if(length(data.dists)!=max(score.cache$children))stop("data.dists should be a named list of all variables used to build the cache of precomputed score.")
# if(length(data.dists)==0 || is.null(names(data.dists))){stop("data.dists should be a named list of all variables used to build the cache of precomputed score.")}
# if(is.matrix(prior.dag)){prior.choice <- 3}
# if(prior.choice %!in% 1:3){stop("prior.choice should be either 1,2 or 3.")}
# if(is.matrix(prior.dag) && is.null(prior.lambda)){prior.lambda <- 1}
# if(is.matrix(prior.dag) && dim(prior.dag)!=c(length(data.dists),length(data.dists)))stop("prior.dag should be a squared matrix with dimension equal to the number of variables.")
##end of tests
##format
if(is.character(score)) score <- tolower(score)
score <- c("bic", "aic", "mdl", "mlik")[pmatch(score,c("bic", "aic", "mdl", "mlik"))]
if(score %!in% c("bic", "aic", "mdl", "mlik"))stop("A method should be provided and be one of: bic, aic, mdl or mlik.")
if(max(rowSums(score.cache$node.defn))<max.parents)stop("Check max.parents. It should be the same as the one used in abn::buildscorecache() R function")
if(length(mcmc.scheme)!=3)stop("An MCMC scheme have to be provided. It should be such that c(returned,thinned,burned) made of non negative integers.")
if(!is.numeric(mcmc.scheme[1]) | !is.numeric(mcmc.scheme[2]) | !is.numeric(mcmc.scheme[3]) | mcmc.scheme[1]<0 | mcmc.scheme[2]<0 | mcmc.scheme[3]<0){stop("An MCMC scheme have to be provided. It should be such that c(returned,thinned,burned) made of non negative integers.")}
if(max.parents<1 || max.parents>length(data.dists))stop("max.parents makes no sense.")
if(is.numeric(prob.rev) && prob.rev>1 && prob.rev<0)stop("prob.rev should be a probability.")
if(is.numeric(prob.mbr) && prob.mbr>1 && prob.mbr<0)stop("prob.mbr should be a probability.")
if(is.matrix(start.dag) && dim(start.dag)!=c(length(data.dists),length(data.dists)))stop("start.dag should be a squared matrix with dimension equal to the number of variables.")
if(is.matrix(start.dag) && is.null(topoSortMAT((start.dag)))){stop("start.dag should be a named DAG.")}
if(length(data.dists)!=max(score.cache$children))stop("data.dists should be a named list of all variables used to build the cache of precomputed score.")
if(length(data.dists)==0 || is.null(names(data.dists))){stop("data.dists should be a named list of all variables used to build the cache of precomputed score.")}
if(is.matrix(prior.dag)){prior.choice <- 3}
if(prior.choice %!in% 1:3){stop("prior.choice should be either 1,2 or 3.")}
if(is.matrix(prior.dag) && is.null(prior.lambda)){prior.lambda <- 1}
if(is.matrix(prior.dag) && dim(prior.dag)!=c(length(data.dists),length(data.dists)))stop("prior.dag should be a squared matrix with dimension equal to the number of variables.")
##end of tests
n.var <- length(data.dists)
......
......@@ -5,6 +5,50 @@
## Last modification :
###############################################################################
##-------------------------------------------------------------------------
##Internal function to test input of mcmcabn()
##-------------------------------------------------------------------------
.tests.mcmcabn <- function(score.cache,
data.dists,
max.parents,
mcmc.scheme,
seed,
verbose,
start.dag,
prior.dag,
prior.lambda,
prob.rev,
prob.mbr,
prior.choice){
#start tests
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)stop("Check max.parents. It should be the same as the one used in abn::buildscorecache() R function")
if(length(mcmc.scheme)!=3)stop("An MCMC scheme have to be provided. It should be such that c(returned,thinned,burned) made of non negative integers.")
if(!is.numeric(mcmc.scheme[1]) | !is.numeric(mcmc.scheme[2]) | !is.numeric(mcmc.scheme[3]) | mcmc.scheme[1]<0 | mcmc.scheme[2]<0 | mcmc.scheme[3]<0){stop("An MCMC scheme have to be provided. It should be such that c(returned,thinned,burned) made of non negative integers.")}
if(max.parents<1 || max.parents>length(data.dists))stop("max.parents makes no sense.")
if(is.numeric(prob.rev) && prob.rev>1 && prob.rev<0)stop("prob.rev should be a probability.")
if(is.numeric(prob.mbr) && prob.mbr>1 && prob.mbr<0)stop("prob.mbr should be a probability.")
if(is.matrix(start.dag) && dim(start.dag)!=c(length(data.dists),length(data.dists)))stop("start.dag should be a squared matrix with dimension equal to the number of variables.")
if(is.matrix(start.dag) && is.null(topoSortMAT((start.dag)))){stop("start.dag should be a named DAG.")}
if(length(data.dists)!=max(score.cache$children))stop("data.dists should be a named list of all variables used to build the cache of precomputed score.")
if(length(data.dists)==0 || is.null(names(data.dists))){stop("data.dists should be a named list of all variables used to build the cache of precomputed score.")}
if(prior.choice %!in% 1:3){stop("prior.choice should be either 1,2 or 3.")}
if(is.matrix(prior.dag) && dim(prior.dag)!=c(length(data.dists),length(data.dists)))stop("prior.dag should be a squared matrix with dimension equal to the number of variables.")
}
##-------------------------------------------------------------------------
##Internal function that call multiple times strsplit() and remove space
##-------------------------------------------------------------------------
......@@ -130,18 +174,6 @@ formula.mcmcabn<-function(f, name){
##Ancestor function
##-------------------------------------------------------------------------
#
# ancestors<-function(nodes, dag){
# diag(dag)<-0
# if(!is.integer0(which(x = dag[nodes,]==1,arr.ind = TRUE))){
# tmp <- which(x = dag[nodes,]==1,arr.ind = TRUE)
# return(unname(c(tmp,ancestors(nodes = tmp,dag = dag))))
# }else{
# return(NULL)
# }
# }
##-------------------------------------------------------------------------
##descendent function
##-------------------------------------------------------------------------
......
......@@ -18,7 +18,7 @@ query <- function(mcmcabn = NULL,
if(is.matrix(formula)){
n <- length(mcmcabn$scores)
n.var <- length(mcmcabn$dist)
n.var <- length(mcmcabn$data.dist)
m.array <- array(data = 0,dim = c(n.var,n.var,n))
for(i in 1:n.var){
for(j in 1:n.var){
......@@ -39,14 +39,14 @@ query <- function(mcmcabn = NULL,
if(is.null(formula)){
out <- apply(mcmcabn$dags,1:2, mean)
colnames(out)<-rownames(out)<-names(mcmcabn$dist)
colnames(out)<-rownames(out)<-names(mcmcabn$data.dist)
return(out)
}
if(class(formula)=="formula"){
f<-as.character(formula)
f <- as.character(formula)
if(!grepl('~',f[1],fixed = TRUE)){stop("Formula specifications should start with a ~")}
......@@ -59,11 +59,11 @@ query <- function(mcmcabn = NULL,
f.1<-paste0("~",f[[1]][1])
f.2<-paste0("~",f[[1]][2])
m.1 <- formula.mcmcabn(f = as.formula(gsub(" ", "", unlist(f.1), fixed = TRUE)),name = names(mcmcabn$dist))
m.2 <- formula.mcmcabn(f = as.formula(gsub(" ", "", unlist(f.2), fixed = TRUE)),name = names(mcmcabn$dist))
m.1 <- formula.mcmcabn(f = as.formula(gsub(" ", "", unlist(f.1), fixed = TRUE)),name = names(mcmcabn$data.dist))
m.2 <- formula.mcmcabn(f = as.formula(gsub(" ", "", unlist(f.2), fixed = TRUE)),name = names(mcmcabn$data.dist))
n <- length(mcmcabn$scores)
n.var <- length(mcmcabn$dist)
n.var <- length(mcmcabn$data.dist)
m.array <- array(data = 0,dim = c(n.var,n.var,n))
for(i in 1:n.var){
for(j in 1:n.var){
......@@ -84,11 +84,11 @@ query <- function(mcmcabn = NULL,
}else{
m <- formula.mcmcabn(f = formula,name = names(mcmcabn$dist))
m <- formula.mcmcabn(f = formula,name = names(mcmcabn$data.dist))
#creat array
n <- length(mcmcabn$scores)
n.var <- length(mcmcabn$dist)
n.var <- length(mcmcabn$data.dist)
m.array <- array(data = 0,dim = c(n.var,n.var,n))
for(i in 1:n.var){
for(j in 1:n.var){
......
......@@ -31,7 +31,7 @@ test_that("mc3",{
diag(data.param)<-0.5
colnames(data.param) <- rownames(data.param) <- names(dist)
out.sim.0 <- invisible(simulateabn(data.dists = dist,n.chains = 1,n.adapt = 1000,n.thin = 1,n.iter = 1000,data.param = 0.4*data.param, simulate = TRUE,seed = 132))
out.sim.0 <- simulateabn(data.dists = dist,n.chains = 1,n.adapt = 1000,n.thin = 1,n.iter = 1000,data.param = 0.4*data.param, simulate = TRUE,seed = 132,verbose = FALSE)
bsc.compute.0 <- buildscorecache(data.df = out.sim.0, data.dists = dist, max.parents = 3)
......@@ -183,7 +183,7 @@ test_that("MBR",{
score = "mlik",
data.dists = dist,
max.parents = 3,
mcmc.scheme = c(1000,0,0),
mcmc.scheme = c(100,0,0),
seed = 32132,
verbose = FALSE,
start.dag = "random",
......@@ -294,6 +294,7 @@ test_that("mcmcabn",{
prior.choice = 1))
##asia
data(asia)
dist.asia <- list(Asia = "binomial",
Smoking = "binomial",
......@@ -317,46 +318,129 @@ test_that("mcmcabn",{
data.dists = dist.asia,
max.parents = 2,
mcmc.scheme = c(1000,0,0),
seed = 42,
seed = 456,
verbose = FALSE,
start.dag = "random",
prob.rev = 0.1,
prob.mbr = 0.1,
prior.choice = 2)
#maximum scoring network using exact search (not MCMC based)
dag <- mostprobable(score.cache = bsc.compute.asia)
expect_equal(max(mcmc.out.asia$scores),fitabn(dag.m = dag,data.df = asia,data.dists = dist.asia)$mlik)
## marks datasets
data(marks)
dist.marks <- list(MECH = "gaussian",
VECT = "gaussian",
ALG = "gaussian",
ANL = "gaussian",
STAT = "gaussian")
#colnames(asia) <- c("Asia","Smoking", "Tuberculosis", "LungCancer", "Bronchitis", "Either", "XRay", "Dyspnea")
bsc.compute.marks <- buildscorecache(data.df = marks,
data.dists = dist.marks,
max.parents = 2)
mcmc.out.marks <- mcmcabn(score.cache = bsc.compute.marks,
score = "mlik",
data.dists = dist.marks,
max.parents = 2,
mcmc.scheme = c(250,0,0),
seed = 789,
verbose = FALSE,
start.dag = "random",
prob.rev = 0.03,
prob.mbr = 0.03,
prior.choice = 2)
max(mcmc.out.asia$scores)
#maximum scoring network using exact search (not MCMC based)
dag <- mostprobable(score.cache = bsc.compute.asia)
fitabn(dag.m = dag,data.df = asia,data.dists = dist.asia)$mlik
dag <- mostprobable(score.cache = bsc.compute.marks)
expect_equal(max(mcmc.out.marks$scores),fitabn(dag.m = dag,data.df = marks,data.dists = dist.marks)$mlik)
data.param.var.0 <- matrix(data = 0,nrow = 5L,ncol = 5L,byrow = T)
diag(data.param.var.0)<-0.1
dag<-plotabn(dag.m = data.param.0,data.dists = dist,plot = FALSE)
colnames(dag)<-rownames(dag)<-1:5
##tests
data(gaussian.test)
out.sim.0 <- simulateabn(data.dists = dist,n.chains = 1,n.adapt = 20,n.thin = 1,n.iter = 100,data.param = data.param.0, simulate = TRUE,seed = 132)
dist.gaussian.test <- list(A = "gaussian",
B = "gaussian",
C = "gaussian",
D = "gaussian",
E = "gaussian",
G = "gaussian",
H ="gaussian")
bsc.compute.0 <- buildscorecache(data.df = out.sim.0, data.dists = dist, max.parents = 2)
colnames(gaussian.test) <- c("A","B","C","D","E","G","H")
mc3.out.0<-mcmcabn(score.cache = bsc.compute.0,
score = "mlik",
data.dists = dist,
max.parents = 2,
mcmc.scheme = c(1000,1,1000),
seed = 2343,
verbose = TRUE,
start.dag = "random",
#algo = "mc3",
prob.rev = 0,
prob.mbr = 0,
prior = 2)
bsc.compute.gaussian.test <- buildscorecache(data.df = gaussian.test,
data.dists = dist.gaussian.test,
max.parents = 2)
mcmc.out.gaussian.test <- mcmcabn(score.cache = bsc.compute.gaussian.test,
score = "mlik",
data.dists = dist.gaussian.test,
max.parents = 2,
mcmc.scheme = c(250,0,0),
seed = 678,
verbose = FALSE,
start.dag = "random",
prob.rev = 0.1,
prob.mbr = 0.1,
prior.choice = 2)
#maximum scoring network using exact search (not MCMC based)
dag <- mostprobable(score.cache = bsc.compute.gaussian.test)
expect_equal(max(mcmc.out.gaussian.test$scores),fitabn(dag.m = dag,data.df = gaussian.test,data.dists = dist.gaussian.test)$mlik)
})
test_that("query",{
data(gaussian.test)
dist.gaussian.test <- list(A = "gaussian",
B = "gaussian",
C = "gaussian",
D = "gaussian",
E = "gaussian",
G = "gaussian",
H ="gaussian")
colnames(gaussian.test) <- c("A","B","C","D","E","G","H")
bsc.compute.gaussian.test <- buildscorecache(data.df = gaussian.test,
data.dists = dist.gaussian.test,
max.parents = 2)
mcmc.out.gaussian.test <- mcmcabn(score.cache = bsc.compute.gaussian.test,
score = "mlik",
data.dists = dist.gaussian.test,
max.parents = 2,
mcmc.scheme = c(100,0,0),
seed = 623178,
verbose = FALSE,
start.dag = "random",
prob.rev = 0.1,
prob.mbr = 0.1,
prior.choice = 2)
expect_true(is.matrix(query(mcmcabn = mcmc.out.gaussian.test)))
expect_equal(query(mcmcabn = mcmc.out.gaussian.test)[1,2],query(mcmcabn = mcmc.out.gaussian.test,formula = ~A|B))
expect_equal(query(mcmcabn = mcmc.out.gaussian.test)[2,3],query(mcmcabn = mcmc.out.gaussian.test,formula = ~B|C))
expect_equal(query(mcmcabn = mcmc.out.gaussian.test)[6,1],query(mcmcabn = mcmc.out.gaussian.test,formula = ~G|A))
})
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