Nothing
R/pcalg.R
In pcalg: Methods for Graphical Models and Causal Inference
Defines functions
skeleton
reach
pcAlgo.Perfect
has.new.coll
causalEffect
udag2pdagRelaxed
udag2pdagSpecial
pdag2dag
flipEdges
ci.test
shd
udag2pdag
amat2dag
adj.check
find.sink
dag2cpdag
corGraph
pcSelect.presel
mcor
getNextSet
compareGraphs
pcorOrder
condIndFisherZ
zStat
pcSelect
rmvDAG
wgtMatrix
wgtMatrix.0
trueCov
Documented in
adj.check
amat2dag
causalEffect
ci.test
compareGraphs
condIndFisherZ
corGraph
dag2cpdag
find.sink
flipEdges
getNextSet
has.new.coll
mcor
pcAlgo.Perfect
pcorOrder
pcSelect
pcSelect.presel
pdag2dag
reach
rmvDAG
shd
skeleton
trueCov
udag2pdag
udag2pdagRelaxed
udag2pdagSpecial
wgtMatrix
zStat
#### Main functions pc(), fci(), fciPlus(), ...
#### ---- -----
### Auxiliaries --> ./Aaux.R
### Classes & Methods --> ./AllClasses.R
trueCov <- function(dag, back.compatible = FALSE)
{
## as(.,"matrix") now {for some versions of 'graph' pkg} is 0/1
## weightMatrix <- t(as(dag,"matrix"))
wm <- if(back.compatible) wgtMatrix.0(dag) else wgtMatrix(dag)
p <- length(dag@nodes)
## SS' where S = (I - W)^{-1} :
tcrossprod(solve(diag(p) - wm))
}
## buggy randomDAG:
## randomDAG <- function (n, prob, lB = 0.1, uB = 1, V = as.character(1:n))
## {
## stopifnot(n >= 2, is.numeric(prob), length(prob) == 1,
## 0 <= prob, prob <= 1,
## is.numeric(lB), is.numeric(uB), lB <= uB)
## edL <- vector("list", n)
## nmbEdges <- 0L
## for (i in seq_len(n - 2)) {
## listSize <- rbinom(1, n - i, prob)
## nmbEdges <- nmbEdges + listSize
## edgeList <- sample(seq(i + 1, n), size = listSize)
## weightList <- runif(length(edgeList), min = lB, max = uB)
## edL[[i]] <- list(edges = edgeList, weights = weightList)
## }
## if (nmbEdges > 0) {
## edL[[n-1]] <-
## if (rbinom(1, 1, prob) == 1)
## list(edges = n,
## weights = runif(1, min = lB, max = uB))
## else
## list(edges = integer(0), weights = numeric(0))
## edL[[n]] <- list(edges = integer(0), weights = numeric(0))
## names(edL) <- V
## new("graphNEL", nodes = V, edgeL = edL, edgemode = "directed")
## }
## else
## new("graphNEL", nodes = V, edgemode = "directed")
## }
randomDAG <- function (n, prob, lB = 0.1, uB = 1, V = as.character(1:n))
{
stopifnot(n >= 2, is.numeric(prob), length(prob) == 1,
0 <= prob, prob <= 1,
is.numeric(lB), is.numeric(uB), lB <= uB)
edL <- vector("list", n)
nmbEdges <- 0L
for (i in seq_len(n - 2)) {
listSize <- rbinom(1, n - i, prob)
nmbEdges <- nmbEdges + listSize
edgeList <- sample(seq(i + 1, n), size = listSize)
weightList <- runif(length(edgeList), min = lB, max = uB)
edL[[i]] <- list(edges = edgeList, weights = weightList)
}
## i=n-1 separately
## (because of sample(7,1) is actually sample(1:7,1) and not 7)
listSize <- rbinom(1, 1, prob)
if (listSize > 0) {
nmbEdges <- nmbEdges + 1
edgeList <- n
weightList <- runif(1, min = lB, max = uB)
} else {
edgeList <- integer(0)
weightList <- numeric(0)
}
edL[[n-1]] <- list(edges = edgeList, weights = weightList)
if (nmbEdges > 0) {
edL[[n]] <- list(edges = integer(0), weights = numeric(0))
names(edL) <- V
new("graphNEL", nodes = V, edgeL = edL, edgemode = "directed")
}
else
new("graphNEL", nodes = V, edgemode = "directed")
}
## A version of this is also in /u/maechler/R/MM/Pkg-ex/graph/weightmatrix.R
## another on in Matrix/R/sparseMatrix.R function graph.wgtMatrix() :
## No longer in use __apart__ for rmvDAG(..., back.compatible=TRUE)
wgtMatrix.0 <- function(g, transpose = TRUE)
{
## Purpose: work around "graph" package's as(g, "matrix") bug
## ----------------------------------------------------------------------
## ACHTUNG: mat_[i,j]==1 iff j->i,
## whereas with as(g,"matrix") mat_[i,j]==1 iff i->j
## ----------------------------------------------------------------------
## Arguments: g: an object inheriting from (S4) class "graph"
## ----------------------------------------------------------------------
## Author: Martin Maechler, based on Seth Falcon's code; Date: 12 May 2006
## MM: another buglet for the case of "no edges":
if(numEdges(g) == 0) {
p <- length(nd <- nodes(g))
return( matrix(0, p,p, dimnames = list(nd, nd)) )
}
## Usual case, when there are edges:
if(!("weight" %in% names(edgeDataDefaults(g))))
edgeDataDefaults(g, "weight") <- 1L
w <- unlist(edgeData(g, attr = "weight"))
## we need the *transposed* matrix typically:
tm <- if(transpose) t(as(g, "matrix")) else as(g, "matrix")
## now is a 0/1 - matrix (instead of 0/wgts) with the 'graph' bug
if(any(w != 1)) ## fix it
tm[tm != 0] <- w
## tm_[i,j]==1 iff i->j
tm
}
wgtMatrix <- function(g, transpose = TRUE) {
res <- as(g, "matrix") # from 'graph' package, now reliable (we hope)
if (transpose) ## default!
t(res) else res
}
rmvDAG <-
function(n, dag,
errDist = c("normal", "cauchy", "t4", "mix", "mixt3", "mixN100"),
mix = 0.1, errMat = NULL, back.compatible = FALSE,
use.node.names = !back.compatible)
{
## Purpose: Generate data according to a given DAG (with weights) and
## given node distribution (rows: number of samples; cols: node values in
## topological order)
## ----------------------------------------------------------------------
## Arguments:
## - n : Number of samples
## - dag : Graph object containing the DAG and weights
## - errDist: "normal" or "mix" for pure standard normal node distribution
## or mixing with standard cauchy
## - mix : Percentage of points sampled from standard cauchy
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 26 Jan 2006; Martin Maechler
## check input & initialize variables
stopifnot(is(dag, "graph"),
(p <- length(nodes(dag))) >= 2)
## as(.,"matrix") now {for some versions of 'graph' pkg} is 0/1
## weightMatrix <- t(as(dag,"matrix"))
weightMatrix <- if(back.compatible) wgtMatrix.0(dag) else wgtMatrix(dag)
## check if top. sorted
nonZeros <- which(weightMatrix != 0, arr.ind = TRUE)
if (nrow(nonZeros) > 0) {
if (any(nonZeros[,1] - nonZeros[,2] < 0) || any(diag(weightMatrix) != 0))
stop("Input DAG must be topologically ordered!")
}
errDist <- match.arg(errDist)
if(grepl("^mix", errDist))
eMat <- function(outs) { # (n,p)
X <- c(rnorm(n*p - length(outs)), outs)
matrix(sample(X), nrow = n)
}
if(is.null(errMat)) {
## generate errors e_i
errMat <-
switch(errDist,
"normal" = matrix(rnorm (n*p), nrow = n),
"cauchy" = matrix(rcauchy(n*p), nrow = n),
"t4" = matrix(rt(n*p, df = 4), nrow = n),
"mix" = eMat(rcauchy(round(mix*n*p))),
"mixt3" = eMat( rt(round(mix*n*p), df = 3)),
"mixN100"= eMat( rnorm(round(mix*n*p), sd = 10)))
}
else { ## check & use 'errMat' argument:
stopifnot(!is.null(dim.eM <- dim(errMat)),
dim.eM == c(n,p), is.numeric(errMat))
}
if(use.node.names)
colnames(errMat) <- nodes(dag) # == colnames(weightMatrix)
## compute X matrix X_i
if (sum(weightMatrix != 0) > 0) {
X <- errMat
for (j in 2:p) { ## uses X[*, 1:(j-1)] -- "recursively" !
ij <- 1:(j-1)
X[,j] <- X[,j] + X[, ij, drop = FALSE] %*% weightMatrix[j, ij]
}
X
}
else
errMat
}
pcSelect <- function(y, dm, alpha, corMethod = "standard",
verbose = FALSE, directed = FALSE)
{
## Purpose: Find columns in dm, that have nonzero parcor with y given
## any other set of columns in dm
## ----------------------------------------------------------------------
## Arguments:
## - y: Response Vector (length(y)=nrow(dm))
## - dm: Data matrix (rows: samples, cols: nodes)
## - alpha: Significance level of individual partial correlation tests
## - corMethod: "standard" or "Qn" for standard or robust correlation
## estimation
## - verbose: 0-no output, 1-small output, 2-details
## ----------------------------------------------------------------------
## Value: List
## - G: boolean vector with connected nodes
## - zMin: Minimal z values
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 27.4.07
stopifnot((n <- nrow(dm)) >= 1,
(p <- ncol(dm)) >= 1)
vNms <- colnames(dm)
## cl <- match.call()
zMin <- c(0,rep.int(Inf,p))
C <- mcor(cbind(y,dm), method = corMethod)
cutoff <- qnorm(1 - alpha/2)
n.edgetests <- numeric(1)# final length = max { ord}
## G := complete graph :
G <- c(FALSE,rep.int(TRUE,p))
seq_p <- seq_len(p+1L) # = 1:(p+1)
done <- FALSE
ord <- 0
while (!done && any(G)) {
n.edgetests[ord+1] <- 0
done <- TRUE
ind <- which(G)
remEdges <- length(ind)
if(verbose >= 1)
cat("Order=",ord,"; remaining edges:",remEdges,"\n", sep = '')
for (i in 1:remEdges) {
if(verbose && (verbose >= 2 || i%%100 == 0)) cat("|i=",i,"|iMax=",remEdges,"\n")
y <- 1
x <- ind[i]
if (G[x]) {
nbrsBool <- G
nbrsBool[x] <- FALSE
nbrs <- seq_p[nbrsBool]
## neighbors of y without itself and x
length_nbrs <- length(nbrs)
if (length_nbrs >= ord) {
if (length_nbrs > ord) done <- FALSE
S <- seq_len(ord)
## now includes special cases (ord == 0) or (length_nbrs == 1):
repeat {
n.edgetests[ord+1] <- n.edgetests[ord+1]+1
z <- zStat(x,y, nbrs[S], C,n)
if(abs(z) < zMin[x]) zMin[x] <- abs(z)
if (verbose >= 2)
cat(paste("x:",vNms[x-1],"y:",(ytmp <- round((p+1)/2)),"S:"),
c(ytmp,vNms)[nbrs[S]], paste("z:",z,"\n"))
if (abs(z) <= cutoff) {
G[x] <- FALSE
break
}
else {
nextSet <- getNextSet(length_nbrs, ord, S)
if(nextSet$wasLast)
break
S <- nextSet$nextSet
}
} ## {repeat}
}
} ## end if( G )
} ## end for(i ..)
ord <- ord+1
} ## end while
## return
list(G = setNames(G[-1L], vNms),
zMin = zMin[-1])
}## pcSelect
zStat <- function(x,y, S, C, n)
{
## Purpose: Fisher's z-transform statistic of partial corr.(x,y | S)
## ----------------------------------------------------------------------
## Arguments:
## - x,y,S: Are x,y cond. indep. given S?
## - C: Correlation matrix among nodes
## - n: Samples used to estimate correlation matrix
## ----------------------------------------------------------------------
## Author: Martin Maechler, 22 May 2006; Markus Kalisch
## for C use:
## dyn.load("/u/kalisch/cCode/pcAlgo/parcorC.so")
## res <- 0
## if (length(S) < 4) {
r <- pcorOrder(x,y, S, C)
## } else {
## k <- solve(C[c(x,y,S),c(x,y,S)])
## r <- -k[1,2]/sqrt(k[1,1]*k[2,2])
## r <- .C("parcorC",as.double(res),as.integer(x-1),as.integer(y-1),as.integer(S-1),as.integer(length(S)),as.integer(dim(C)[1]),as.double(as.vector(C)))[[1]]
## }
res <- sqrt(n- length(S) - 3) * 0.5*logQ1pm(r)
if (is.na(res)) 0 else res
}
condIndFisherZ <- function(x,y,S,C,n, cutoff,
verbose = isTRUE(getOption("verbose.pcalg.condIFz")))
{
## Purpose: Return boolean result on conditional independence using
## Fisher's z-transform
## ----------------------------------------------------------------------
## Arguments:
## - x,y,S: Are x,y cond. indep. given S?
## - C: Correlation matrix among nodes
## - n: Samples used to estimate correlation matrix
## - cutoff: Cutoff for significance level for individual
## partial correlation tests
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 26 Jan 2006, 17:32
## R Variante
r <- pcorOrder(x,y, S, C)
## C Variante
## C res <- 0
## C p <- dim(C)[1]
## C r <- .C("parcor",as.double(res),as.integer(x-1),as.integer(y-1),as.integer(S-1),as.integer(length(S)),as.integer(p),as.double(C))[[1]]
T <- sqrt(n-length(S)-3)* 0.5*logQ1pm(r)
## cat(" (",x,",",y,") | ",S," : T = ",T,"\n", sep='')
## MM: T is only NA when 'r' already is (r = +- 1 <==> T = +- Inf) -- better check there (FIXME?)
## is.na(T) <==> T <- 0 # if problem, delete edge: be conservative
is.na(T) || abs(T) <= cutoff
}
pcorOrder <- function(i,j, k, C, cut.at = 0.9999999) {
## Purpose: Compute partial correlation
## ----------------------------------------------------------------------
## Arguments:
## - i,j,k: Partial correlation of i and j given k
## - C: Correlation matrix among nodes
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 26 Jan 2006; Martin Maechler
if (length(k) == 0) {
r <- C[i,j]
} else if (length(k) == 1) {
r <- (C[i, j] - C[i, k] * C[j, k])/sqrt((1 - C[j, k]^2) * (1 - C[i, k]^2))
} else { ## length(k) >= 2
PM <- pseudoinverse(C[c(i,j,k), c(i,j,k)])
r <- -PM[1, 2]/sqrt(PM[1, 1] * PM[2, 2])
}
if(is.na(r)) 0 else min(cut.at, max(-cut.at, r))
}
compareGraphs <- function(gl,gt) {
## Purpose: Return TPR, FPR and TDR of comparison of two undirected graphs
## ----------------------------------------------------------------------
## Arguments:
## - gl: Estimated graph (may be directed, but the direction will
## be dropped internally)
## - gt: True graph (may be directed, but the direction will
## be dropped internally)
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 26 Jan 2006, 17:35
## When 'graph' returns the 'weight matrix' again:
## ml <- as(ugraph(gl), "matrix")
## mt <- as(ugraph(gt), "matrix")
## p <- dim(ml)[1]
ml <- wgtMatrix(ugraph(gl))
mt <- wgtMatrix(ugraph(gt))
p <- dim(ml)[2]
mt[mt != 0] <- rep(1,sum(mt != 0))
ml[ml != 0] <- rep(1,sum(ml != 0)) ## inserted to fix bug
## FPR := #{misplaced edges} / #{true gaps}
diffm <- ml-mt
nmbTrueGaps <- (sum(mt == 0)-p)/2
## print(list(p=p,sum=sum(mt==0),mt=mt,ml=ml,nmbTrueGaps=nmbTrueGaps,diffm=diffm))
fpr <- if (nmbTrueGaps == 0) 1 else (sum(diffm > 0)/2)/nmbTrueGaps
## TPR := #{correctly found edges} / #{true edges}
diffm2 <- mt-ml
nmbTrueEdges <- (sum(mt == 1)/2)
tpr <- if (nmbTrueEdges == 0) 0 else 1 - (sum(diffm2 > 0)/2)/nmbTrueEdges
## TDR := #{correctly found edges} / #{found edges}
trueEstEdges <- (nmbTrueEdges-sum(diffm2 > 0)/2) ## #{true edges} - #{not detected}
tdr <-
if (sum(ml == 1) == 0) { ## no edges detected
if (trueEstEdges == 0) 1 ## no edges in true graph
else 0
} else trueEstEdges/(sum(ml == 1)/2)
## return named vector:
c(tpr = tpr, fpr = fpr, tdr = tdr)
}
getNextSet <- function(n,k,set) {
## Purpose: Generate the next set in a list of all possible sets of size
## k out of 1:n;
## Also returns a boolean whether this set was the last in the list.
## ----------------------------------------------------------------------
## Arguments:
## - n,k: Choose a set of size k out of numbers 1:n
## - set: previous set in list
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 26 Jan 2006, 17:37
## chInd := changing Index
chInd <- k - (zeros <- sum((seq(n-k+1,n)-set) == 0))
wasLast <- (chInd == 0)
if (!wasLast) {
set[chInd] <- s.ch <- set[chInd] + 1
if (chInd < k)
set[(chInd+1):k] <- seq(s.ch +1L, s.ch +zeros)
}
list(nextSet = set, wasLast = wasLast)
}
mcor <- function(dm, method = c("standard", "Qn", "QnStable",
"ogkScaleTau2", "ogkQn", "shrink"))
{
## Purpose: Compute correlation matrix (perhaps elementwise)
## ----------------------------------------------------------------------
## Arguments:
## - dm: Data matrix; rows: samples, cols: variables
## - method: "Qn" or "standard" (default) envokes robust (based on Qn
## scale estimator) or standard correlation estimator, respectively.
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 27 Jan 2006
p <- ncol(dm)
method <- match.arg(method)
switch(method,
"Qn" = {
res <- diag(nrow = p)
Qn. <- apply(dm, 2L, Qn)
for (i in seq_len(p-1)) {
for (j in i:p) {
qnSum <- Qn(dm[,i] + dm[,j])
qnDiff <- Qn(dm[,i] - dm[,j])
res[j,i] <- res[i,j] <-
max(-1,
min(1, (qnSum^2 - qnDiff^2) / (4*Qn.[i]*Qn.[j])))
}
}
res
},
"QnStable" = {
res <- diag(nrow = p)
Qn. <- apply(dm, 2L, Qn) # Qn(.) for all columns
## xQn := each column divided by its Qn(.)
xQn <- dm / rep(Qn., each=nrow(dm))
for (i in seq_len(p-1)) {
xQn.i <- xQn[,i]
for (j in i:p) {
qnSum <- Qn(xQn.i + xQn[,j])
qnDiff <- Qn(xQn.i - xQn[,j])
res[j,i] <- res[i,j] <-
max(-1,
min(1, (qnSum^2 - qnDiff^2) / (qnSum^2 + qnDiff^2)))
}
}
res
},
"ogkScaleTau2" = {
cov2cor(covOGK(dm, n.iter = 2, sigmamu = scaleTau2,
weight.fn = hard.rejection)$cov)
},
"ogkQn" = {
cov2cor(covOGK(dm, n.iter = 2, sigmamu = s_Qn,
weight.fn = hard.rejection)$cov)
},
"standard" = cor(dm),
"shrink" = {
CM <- cor(dm)
n <- nrow(dm)
p <- ncol(dm)
S1 <- sum(CM[1,-1]^2)
S2 <- sum((1-CM[1,-1]^2)^2)
g <- S1 / (S1 + S2/n) # is in [0,1]
scor3 <- CM
for(i in 2:p) {
scor3[1,i] <- g*CM[1,i]
scor3[i,1] <- g*CM[i,1]
}
scor3
}
)# {switch}
}
pcSelect.presel <- function(y, dm, alpha, alphapre, corMethod = "standard",
verbose = 0, directed = FALSE)
{
## Purpose: Find columns in dm, that have nonzero parcor with y given
## any other set of columns in dm with use of some kind of preselection
## ----------------------------------------------------------------------
## Arguments:
## - y: Response Vector (length(y)=nrow(dm))
## - dm: Data matrix (rows: samples, cols: nodes)
## - alpha : Significance level of individual partial correlation tests
## - alphapre: Significance level in preselective use of pcSelect
## - corMethod: "standard" or "Qn" for standard or robust correlation
## estimation
## ----------------------------------------------------------------------
## Author: Philipp Ruetimann, Date: 5 Mar 2008
tmp <- pcSelect(y, dm, alpha=alphapre,
corMethod=corMethod, verbose=verbose, directed=directed)
pcs <- tmp$G
zmi <- tmp$zMin
ppcs <- which(pcs == 1L)
Xnew <- dm[, ppcs, drop=FALSE]
lang <- length(pcs)
tmp2 <- pcSelect(y, dm=Xnew, alpha=alpha,
corMethod=corMethod, verbose=verbose, directed=directed)
pcSnew <- tmp2$G
zminew <- tmp2$zMin
zmi[ppcs] <- zminew
## MM FIXME -- do without for() :
k <- 1
for (i in 1:lang) {
if(pcs[i] == 1) {
pcs[i] <- pcSnew[k]
k <- k+1
}
}
list(pcs = pcs, Xnew = Xnew, zMin = zmi)
}
corGraph <- function(dm, alpha = 0.05, Cmethod = "pearson")
{
## Purpose: Computes a correlation graph. Significant correlations are
## shown using the given correlation method.
## ----------------------------------------------------------------------
## Arguments:
## - dm: Data matrix with rows as samples and cols as variables
## - alpha: Significance level for correlation test
## - Cmethod: a character string indicating which correlation coefficient
## is to be used for the test. One of '"pearson"',
## '"kendall"', or '"spearman"', can be abbreviated.
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 30 Jan 2006; Martin Maechler (preserve cns)
stopifnot(is.numeric(p <- ncol(dm)), p >= 2)
if(is.null(cns <- colnames(dm))) cns <- as.character(1:p)
mat <- matrix(0, p,p)
for (i in 1:(p-1)) {
for (j in (i+1):p) {
mat[i,j] <- cor.test(dm[,i], dm[,j], alternative = "two.sided",
method = Cmethod)$p.value < alpha
}
}
mat <- mat + t(mat)
dimnames(mat) <- list(cns,cns)
as(mat, "graphNEL")
}
##################################################
## CPDAG
##################################################
##################################################
## dag2cpdag
##################################################
dag2cpdag <- function(g)
{
## Purpose: Compute the (unique) completed partially directed graph (CPDAG)
## that corresponds to the input DAG; result is a graph object
## In the current implementation, this function is just a wrapper
## function for 'dag2essgraph'
## ----------------------------------------------------------------------
## Arguments:
## - dag: input DAG (graph object)
## ----------------------------------------------------------------------
## Author: Alain Hauser, Date: 14 Mar 2015
dag2essgraph(g)
}
#dag2cpdag <- function(g)
#{
# ## Purpose: Compute the (unique) completed partially directed graph (CPDAG)
# ## that corresponds to the input DAG; result is a graph object
# ## ----------------------------------------------------------------------
# ## Arguments:
# ## - dag: input DAG (graph object)
# ## ----------------------------------------------------------------------
# ## Author: Diego Colombo, Date: 10 Jun 2013, 11:06
#
# amat <- as(g, "matrix")
# amat[amat != 0] <- 1
# skel.amat <- amat + t(amat)
# skel.amat[skel.amat == 2] <- 1
# cpdag <- skel.amat
#
# ## search the v-structures in the DAG
# ind <- which((amat == 1 & t(amat) == 0), arr.ind = TRUE)
# tripleMatrix <- matrix(,0,3)
# ## Go through all edges
# for (i in seq_len(nrow(ind))) { ## MM(FIXME): growth of tripleMatrix
# x <- ind[i,1]
# y <- ind[i,2]
# indY <- setdiff(which((amat[,y] == 1 & amat[y,] == 0), arr.ind = TRUE),x) ## x-> y <- z
# if(length(newZ <- indY[amat[x,indY] == 0])) ## deparse.l.=0: no colnames
# tripleMatrix <- rbind(tripleMatrix, cbind(x, y, newZ, deparse.level=0),
# deparse.level=0)
# }
# if ((m <- nrow(tripleMatrix)) > 0) {
# deleteDupl <- logical(m)# all FALSE
# for (i in seq_len(m))
# if (tripleMatrix[i,1] > tripleMatrix[i,3])
# deleteDupl[i] <- TRUE
# if(any(deleteDupl))
# tripleMatrix <- tripleMatrix[!deleteDupl,, drop=FALSE]
#
# ## orient the v-structures in the CPDAG
# for (i in seq_len(nrow(tripleMatrix))) {
# x <- tripleMatrix[i,1]
# y <- tripleMatrix[i,2]
# z <- tripleMatrix[i,3]
# cpdag[x,y] <- cpdag[z,y] <- 1
# cpdag[y,x] <- cpdag[y,z] <- 0
# }
# }
#
# ## orient the edges with the 3 orientation rules
# repeat {
# old_cpdag <- cpdag
# ## Rule 1
# ind <- which((cpdag == 1 & t(cpdag) == 0), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# a <- ind[i, 1]
# b <- ind[i, 2]
# isC <- ((cpdag[b, ] == 1 & cpdag[, b] == 1) &
# (cpdag[a, ] == 0 & cpdag[, a] == 0))
# if (any(isC)) {
# indC <- which(isC)
# cpdag[b, indC] <- 1
# cpdag[indC, b] <- 0
# }
# }
# ## Rule 2
# ind <- which((cpdag == 1 & t(cpdag) == 1), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# a <- ind[i, 1]
# b <- ind[i, 2]
# isC <- ((cpdag[a, ] == 1 & cpdag[, a] == 0) &
# (cpdag[, b] == 1 & cpdag[b, ] == 0))
# if (any(isC)) {
# cpdag[a, b] <- 1
# cpdag[b, a] <- 0
# }
# }
# ## Rule 3
# ind <- which((cpdag == 1 & t(cpdag) == 1), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# a <- ind[i, 1]
# b <- ind[i, 2]
# indC <- which((cpdag[a, ] == 1 & cpdag[, a] == 1) &
# (cpdag[, b] == 1 & cpdag[b, ] == 0))
# if (length(indC) >= 2) {
# cmb.C <- combn(indC, 2)
# cC1 <- cmb.C[1, ]
# cC2 <- cmb.C[2, ]
# for (j in seq_along(cC1)) {
# c1 <- cC1[j]
# c2 <- cC2[j]
# if (c1 != c2 && cpdag[c1, c2] == 0 && cpdag[c2,c1] == 0) {
# cpdag[a, b] <- 1
# cpdag[b, a] <- 0
# break
# }
# }
# }
# }
# if (all(cpdag == old_cpdag))
# break
# }
# as(cpdag,"graphNEL")
#}
## dag2cpdag <- function(dag) {
## Purpose: Compute the (unique) completed partially directed graph (CPDAG)
## that corresponds to the input DAG; result is a graph object
## ----------------------------------------------------------------------
## Arguments:
## - dag: input DAG (graph object)
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 31 Oct 2006, 15:30
## p <- numNodes(dag)
## ## transform DAG to adjacency matrix if any edges are present
## if (numEdges(dag)==0) {
## cpdag.res <- dag
## } else {
## dag <- as(dag,"matrix")
## dag[dag!=0] <- 1
## ## dag is adjacency matrix
## e.df <- labelEdges(dag)
## cpdag <- matrix(0, p,p)
## for (i in seq_len(nrow(e.df))) {
## if (e.df$label[i]) {
## cpdag[e.df$tail[i],e.df$head[i]] <- 1
## } else {
## cpdag[e.df$tail[i],e.df$head[i]] <- cpdag[e.df$head[i],e.df$tail[i]] <- 1
## }
## }
## rownames(cpdag) <- colnames(cpdag) <- as.character(seq(1,p))
## cpdag.res <- as(cpdag,"graphNEL")
## }
## cpdag.res
##}
## make.edge.df <- function(amat) {
## Purpose: Generate a data frame describing some properties of a DAG
## (for extending to a CPDAG)
## The output contains xmin,xmax,head,tail,order (NA or number),
## type (1="d",0="u") in lexikographic order
## ----------------------------------------------------------------------
## Arguments:
## - amat: Adjacency matrix of DAG [x_ij=1 means i->j]
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 31 Oct 2006, 15:43
## INPUT: Adjacency matrix
## stopifnot(sum(amat)>0)
## e <- which(amat==1,arr.ind=TRUE)
## e.dup <- duplicated(t(apply(e,1,sort)))
## nmb.edges <- sum(!e.dup)
## res <- data.frame(xmin=rep(NA,nmb.edges),xmax=rep(NA,nmb.edges),
## tail=rep(NA,nmb.edges),head=rep(NA,nmb.edges),
## order=rep(NA,nmb.edges),type=rep(1,nmb.edges))
## pure.edges <- e[!e.dup,]
## if(length(pure.edges)==2) dim(pure.edges) <- c(1,2)
## for (i in seq_len(nrow(pure.edges))) {
## if (all(amat[pure.edges[i,1],pure.edges[i,2]]==
## amat[pure.edges[i,2],pure.edges[i,1]])) {
## res$type[i] <- 0
## res$head[i] <- NA
## res$tail[i] <- NA
## } else {
## res$head[i] <- pure.edges[i,2]
## res$tail[i] <- pure.edges[i,1]
## }
## }
## s.pure.edges <- t(apply(pure.edges,1,sort))
## ii <- order(s.pure.edges[,1],s.pure.edges[,2])
## res <- res[ii,]
## res$xmin <- s.pure.edges[ii,1]
## res$xmax <- s.pure.edges[ii,2]
## res
##}
## orderEdges <- function(amat) {
## Purpose: Order the edges of a DAG according to Chickering
## (for extension to CPDAG)
## ----------------------------------------------------------------------
## Arguments:
## - amat: Adjacency matrix of DAG
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 31 Oct 2006, 15:42
## stopifnot(isAcyclic(amat))
## ordered.nodes <- topOrder(amat) ## parents before children
## edge.df <- make.edge.df(amat)
## eOrder <- 0
## while(any(unOrdered <- is.na(edge.df$order))) {
## counter <- 0
## find y
## y <- NA
## found <- FALSE
## while(!found) {
## counter <- counter+1
## node <- ordered.nodes[counter]
## which edges are incident to node?
## nbr.nodes <- which(amat[,node]==1)
## if(length(nbr.nodes)>0) {
## unlabeled <- rep.int(FALSE, length(nbr.nodes))
## for(i in seq_along(nbr.nodes)) {
## x <- nbr.nodes[i]
## is edge edge x-y unlabeled?
## unlabeled[i] <- length(intersect(which(edge.df$xmin==min(node,x) &
## edge.df$xmax==max(node,x)),
## which(unOrdered))) > 0
## }
## choose unlabeled edge with highest order node
## if(any(unlabeled)) {
## nbr.unlab <- nbr.nodes[unlabeled] # nbrnodes w. unlabeled edges
## tmp <- ordered.nodes[ordered.nodes %in% nbr.unlab]
## y <- tmp[length(tmp)]
## y <- last(ordered.nodes[which(ordered.nodes %in% nbr.unlab)])
## edge.df$order[edge.df$xmin==min(node,y) &
## edge.df$xmax==max(node,y)] <- eOrder
## eOrder <- eOrder+1
## found <- TRUE
## }
## }
## } ## while !found
## } ## while any(unOrdered)
## edge.df
##}
## labelEdges <- function(amat) {
## Purpose: Label the edges in a DAG with "compelled" and "reversible"
## (for extension to a CPDAG)
## ----------------------------------------------------------------------
## Arguments:
## - amat: Adjacency matrix of DAG
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 31 Oct 2006; prettified: MMaechler
## label=TRUE -> compelled
## label=FALSE -> reversible
## edge.df <- orderEdges(amat)
## lab <- rep(NA,dim(edge.df)[1])
## edge.df <- edge.df[order(edge.df$order),]
## Head <- edge.df$head
## Tail <- edge.df$tail
## while(any(ina <- is.na(lab))) {
## x.y <- which(ina)[1]
## x <- Tail[x.y]
## y <- Head[x.y]
## y.is.head <- Head == y
## e1 <- which(Head == x & lab)
## for(ee in e1) {
## w <- Tail[ee]
## if (any(wt.yh <- w == Tail & y.is.head))
## lab[wt.yh] <- TRUE
## else {
## lab[y.is.head] <- TRUE
## break
## }
## }
## edges going to y not starting from x
## cand <- which(y.is.head & Tail != x)
## if (length(cand) > 0) {
## valid.cand <- rep(FALSE,length(cand))
## for (iz in seq_along(cand)) {
## z <- Tail[cand[iz]]
## if (!any(Tail==z & Head==x)) ## NOT.parent.of.x :
## valid.cand[iz] <- TRUE
## }
## cand <- cand[valid.cand]
## }
## lab[which(y.is.head & is.na(lab))] <- (length(cand) > 0)
## }
## edge.df$label <- lab
## edge.df
##}
##################################################
## pdag2dag
##################################################
find.sink <- function(gm) {
## Purpose: Find sink of an adj matrix; return numeric(0) if there is none;
## a sink may have incident undirected edges, but no directed ones
## ----------------------------------------------------------------------
## Arguments:
## - gm: Adjacency matrix (gm_i_j is edge from j to i)
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 31 Oct 2006; speedup: Martin Maechler, Dec.2013
## treat undirected edges
gm[gm == t(gm) & gm == 1] <- 0
## treat directed edges
which(colSums(gm) == 0)
}
adj.check <- function(gm,x) {
## Purpose: Return "TRUE", if:
## For every vertex y, adj to x, with (x,y) undirected, y is adjacent to
## all the other vertices which are adjacent to x
## ----------------------------------------------------------------------
## Arguments:
## - gm: adjacency matrix of graph
## - x: node number (number)
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 31 Oct 2006;
## several smart speedups: Martin Maechler, Dec.2013
gm.1 <- (gm == 1)
xr <- gm.1[x,]
xc <- gm.1[,x]
nx <- which(xr | xc)
## undirected neighbors of x
un <- which(xr & xc)
for(y in un) {
adj.x <- setdiff(nx, y)
adj.y <- setdiff(which(gm.1[y,] | gm.1[,y]), x)
if(!all(adj.x %in% adj.y))
return(FALSE)
}
TRUE
}
amat2dag <- function(amat) {
## Purpose: Transform the adjacency matrix of an PDAG to the adjacency
## matrix of a SOME DAG in the equiv. class
## Used in pdag2dag if extension is not possible
## ----------------------------------------------------------------------
## Arguments:
## - amat: adjacency matrix; x -> y if amat[x,y]=1,amat[y,x]=0
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 31 Oct 2006, 15:23
p <- dim(amat)[1]
## amat to skel
skel <- amat+t(amat)
skel[which(skel > 1)] <- 1
## permute skel
ord <- sample.int(p)
skel <- skel[ord,ord]
## skel to dag
for (i in 2:p) {
for (j in 1:(i-1)) {
if(skel[i,j] == 1) skel[i,j] <- 0
}
}
## inverse permutation
i.ord <- order(ord)
skel[i.ord,i.ord]
}
##################################################
## udag2pdag
##################################################
udag2pdag <- function(gInput, verbose = FALSE) {
## Purpose: Transform the Skeleton of a pcAlgo-object to a PDAG using
## the rules of Pearl. The output is again a pcAlgo-object.
## ----------------------------------------------------------------------
## Arguments:
## - gInput: pcAlgo object
## - verbose: 0 - no output, 1 - detailed output
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: Sep 2006, 15:03
res <- gInput
if (numEdges(gInput@graph) > 0) {
g <- as(gInput@graph,"matrix") ## g_ij if i->j
p <- as.numeric(dim(g)[1])
pdag <- g
ind <- which(g == 1,arr.ind = TRUE)
## Create minimal pattern
for (i in seq_len(nrow(ind))) {
x <- ind[i,1]
y <- ind[i,2]
allZ <- setdiff(which(g[y,] == 1),x) ## x-y-z
for (z in allZ) {
if (g[x,z] == 0 &&
!(y %in% gInput@sepset[[x]][[z]] ||
y %in% gInput@sepset[[z]][[x]])) {
if (verbose) {
cat("\n",x,"->",y,"<-",z,"\n")
cat("Sxz=",gInput@sepset[[z]][[x]],"Szx=",gInput@sepset[[x]][[z]])
}
pdag[x,y] <- pdag[z,y] <- 1
pdag[y,x] <- pdag[y,z] <- 0
}
}
}
## Test whether this pdag allows a consistent extension
res2 <- pdag2dag(as(pdag,"graphNEL"))
if (res2$success) {
## Convert to complete pattern: use rules by Pearl
old_pdag <- matrix(0, p,p)
while (!all(old_pdag == pdag)) {
old_pdag <- pdag
## rule 1
ind <- which((pdag == 1 & t(pdag) == 0), arr.ind = TRUE) ## a -> b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[b,] == 1 & pdag[,b] == 1) & (pdag[a,] == 0 & pdag[,a] == 0))
if (length(indC) > 0) {
pdag[b,indC] <- 1
pdag[indC,b] <- 0
if (verbose)
cat("\nRule 1:",a,"->",b," and ",b,"-",indC,
" where ",a," and ",indC," not connected: ",b,"->",indC,"\n")
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule1")
## rule 2
ind <- which((pdag == 1 & t(pdag) == 1), arr.ind = TRUE) ## a -> b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[a,] == 1 & pdag[,a] == 0) & (pdag[,b] == 1 & pdag[b,] == 0))
if (length(indC) > 0) {
pdag[a,b] <- 1
pdag[b,a] <- 0
if (verbose) cat("\nRule 2: Kette ",a,"->",indC,"->",
b,":",a,"->",b,"\n")
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule2")
## rule 3
ind <- which((pdag == 1 & t(pdag) == 1), arr.ind = TRUE) ## a - b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[a,] == 1 & pdag[,a] == 1) & (pdag[,b] == 1 & pdag[b,] == 0))
if (length(indC) >= 2) {
## cat("R3: indC = ",indC,"\n")
g2 <- pdag[indC,indC]
## print(g2)
if (length(g2) <= 1) {
g2 <- 0
} else {
diag(g2) <- rep(1,length(indC)) ## no self reference
}
if (any(g2 == 0)) { ## if two nodes in g2 are not connected
pdag[a,b] <- 1
pdag[b,a] <- 0
if (verbose) cat("\nRule 3:",a,"->",b,"\n")
}
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule3")
## rule 4
##- ind <- which((pdag==1 & t(pdag)==1), arr.ind=TRUE) ## a - b
##- if (length(ind)>0) {
##- for (i in seq_len(nrow(ind))) {
##- a <- ind[i,1]
##- b <- ind[i,2]
##- indC <- which( (pdag[a,]==1 & pdag[,a]==1) & (pdag[,b]==0 & pdag[b,]==0))
##- l.indC <- length(indC)
##- if (l.indC>0) {
##- found <- FALSE
##- ic <- 0
##- while(!found & (ic < l.indC)) {
##- ic <- ic + 1
##- c <- indC[ic]
##- indD <- which( (pdag[c,]==1 & pdag[,c]==0) & (pdag[,b]==1 & pdag[b,]==0))
##- if (length(indD)>0) {
##- found <- TRUE
##- pdag[b,a] = 0
##- if (verbose) cat("Rule 4 applied \n")
##- }
##- }
##- }
##- }
##- }
}
res@graph <- as(pdag,"graphNEL")
} else {
## was not extendable; random DAG chosen
res@graph <- res2$graph
## convert to CPDAG
res@graph <- dag2cpdag(res@graph)
}
}
return(res)
} ## udag2pdag
shd <- function(g1,g2)
{
## Purpose: Compute Structural Hamming Distance between graphs g1 and g2
## ----------------------------------------------------------------------
## Arguments:
## - g1, g2: Input graphs
## (graph objects;connectivity matrix where m[x,y]=1 iff x->1
## and m[x,y]=m[y,x]=1 iff x-y; pcAlgo-objects)
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 1 Dec 2006, 17:21
## Idea: Transform g1 into g2
## Transform g1 and g2 into adjacency matrices
if (is(g1, "pcAlgo")) g1 <- g1@graph
if (is(g2, "pcAlgo")) g2 <- g2@graph
if (is(g1, "graphNEL")) {
m1 <- wgtMatrix(g1, transpose = FALSE)
m1[m1 != 0] <- 1
}
if (is(g2, "graphNEL")) {
m2 <- wgtMatrix(g2, transpose = FALSE)
m2[m2 != 0] <- 1
}
shd <- 0
## Remove superfluous edges from g1
s1 <- m1 + t(m1)
s2 <- m2 + t(m2)
s1[s1 == 2] <- 1
s2[s2 == 2] <- 1
ds <- s1 - s2
ind <- which(ds > 0)
m1[ind] <- 0
shd <- shd + length(ind)/2
## Add missing edges to g1
ind <- which(ds < 0)
m1[ind] <- m2[ind]
shd <- shd + length(ind)/2
## Compare Orientation
d <- abs(m1-m2)
## return
shd + sum((d + t(d)) > 0)/2
}
################################################################################
## New in V8 ; uses vcd package
################################################################################
ci.test <- function(x,y, S = NULL, dm.df) {
stopifnot(is.data.frame(dm.df), ncol(dm.df) > 1)
tab <- table(dm.df[,c(x,y,S)])
if (any(dim(tab) < 2))
1
else if (length(S) == 0)
fisher.test(tab, simulate.p.value = TRUE)$p.value
else
vcd::coindep_test(tab,3:(length(S)+2))$p.value
}
flipEdges <- function(amat,ind) {
res <- amat
for (i in seq_len(nrow(ind))) {
x <- ind[i,]
res[x[1],x[2]] <- amat[x[2],x[1]]
res[x[2],x[1]] <- amat[x[1],x[2]]
}
res
}
pdag2dag <- function(g, keepVstruct = TRUE) {
## Purpose: Generate a consistent extension of a PDAG to a DAG; if this
## is not possible, a random extension of the skeleton is returned and
## a warning is issued.
## ----------------------------------------------------------------------
## Arguments:
## - g: PDAG (graph object)
## - keepVstruct: TRUE - vStructures are kept
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: Sep 2006; tweaks: Martin M
not.yet <- FALSE
if (numEdges(g) == 0) {
graph <- g
} else {
gm <- wgtMatrix(g) ## gm_i_j is edge from j to i
storage.mode(gm) <- "integer"
gm[which(gm > 0 & gm != 1)] <- 1L
a <- gm2 <- gm
cn2 <- colnames(gm2)
go.on <- TRUE
while(go.on && length(a) > 1 && sum(a) > 0) {
not.yet <- TRUE
sinks <- find.sink(a)
if (length(sinks) > 0) {
counter <- 1L
while(not.yet && counter <= length(sinks)) {
x <- sinks[counter]
if (!keepVstruct || adj.check(a,x)) {
not.yet <- FALSE
## orient edges
inc.to.x <- which(a[,x] == 1L & a[x,] == 1L) ## undirected
if (length(inc.to.x) > 0) {
## map var.names to col pos in orig adj matrix
## bug: real.inc.to.x <- as.numeric(rownames(a)[inc.to.x])
real.inc.to.x <- which(cn2 %in% rownames(a)[inc.to.x])
real.x <- which(cn2 %in% rownames(a)[x])
gm2[real.x, real.inc.to.x] <- 1L
gm2[real.inc.to.x, real.x] <- 0L
}
## remove x and all edges connected to it
a <- a[-x,-x]
}
counter <- counter + 1L
}
}
go.on <- !not.yet
}## { while }
graph <- if (not.yet) {
## warning("PDAG not extendible: Random DAG on skeleton drawn")
as(amat2dag(gm), "graphNEL")
} else ## success :
as(t(gm2), "graphNEL")
}
list(graph = graph, success = !not.yet)
}
udag2pdagSpecial <- function(gInput, verbose = FALSE, n.max = 100) {
## Purpose: Transform the Skeleton of a pcAlgo-object to a PDAG using
## the rules of Pearl. The output is again a pcAlgo-object. Ambiguous
## v-structures are reoriented until extendable or max number of tries
## is reached. If still not extendable, a DAG is produced starting from the
## current PDAG even if introducing new v-structures.
##
## ----------------------------------------------------------------------
## Arguments:
## - gInput: pcAlgo object
## - verbose: 0 - no output, 1 - detailed output
## - n.max: Maximal number of tries to reorient v-strucutres
## ----------------------------------------------------------------------
## Values:
## - pcObj: Oriented pc-Object
## - evisit: Matrix counting the number of orientation attemps per edge
## - xtbl.orig: Is original graph with v-structure extendable
## - xtbl: Is final graph with v-structure extendable
## - amat0: Adj.matrix of original graph with v-structures
## - amat1: Adj.matrix of graph with v-structures after reorienting
## edges from double edge visits
## - status:
## 0: original try is extendable
## 1: reorienting double edge visits helps
## 2: orig. try is not extendable; reorienting double visits don't help;
## result is acyclic, has orig. v-structures, but perhaps
## additional v-structures
## - counter: Number of reorientation tries until success or max.tries
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: Sep 2006, 15:03
counter <- 0
res <- gInput
status <- 0
p <- length(nodes(res@graph))
evisit <- amat0 <- amat1 <- matrix(0,p,p)
xtbl <- xtbl.orig <- TRUE
if (numEdges(gInput@graph) > 0) {
g <- as(gInput@graph,"matrix") ## g_ij if i->j
p <- dim(g)[1]
pdag <- g
ind <- which(g == 1,arr.ind = TRUE)
## ind <- unique(t(apply(ind,1,sort)))
## Create minimal pattern
for (i in seq_len(nrow(ind))) {
x <- ind[i,1]
y <- ind[i,2]
allZ <- setdiff(which(g[y,] == 1),x) ## x-y-z
for(z in allZ) {
if ((g[x,z] == 0) &&
!(y %in% gInput@sepset[[x]][[z]] ||
y %in% gInput@sepset[[z]][[x]])) {
if (verbose) {
cat("\n",x,"->",y,"<-",z,"\n")
cat("Sxz=",gInput@sepset[[z]][[x]],"Szx=",gInput@sepset[[x]][[z]])
}
## check if already in other direction directed
if (pdag[x,y] == 0 && pdag[y,x] == 1) {
evisit[x,y] <- evisit[x,y] + 1
evisit[y,x] <- evisit[y,x] + 1
}
if (pdag[z,y] == 0 && pdag[y,z] == 1) {
evisit[z,y] <- evisit[z,y] + 1
evisit[y,z] <- evisit[y,z] + 1
}
pdag[x,y] <- pdag[z,y] <- 1
pdag[y,x] <- pdag[y,z] <- 0
} ## if
} ## for
} ## for ( i )
amat0 <- pdag
## Test whether this pdag allows a consistent extension
res2 <- pdag2dag(as(pdag,"graphNEL"))
xtbl <- res2$success
xtbl.orig <- xtbl
if (!xtbl && (max(evisit) > 0)) {
tmp.ind2 <- unique(which(evisit > 0,arr.ind = TRUE))
ind2 <- unique(t(apply(tmp.ind2,1,sort)))
## print(ind2)
n <- nrow(ind2)
n.max <- min(2^n-1,n.max)
counter <- 0
## xtbl is FALSE because of if condition
while((counter < n.max) & !xtbl) {
## if (counter%%100 == 0) cat("\n counter=",counter,"\n")
counter <- counter + 1
dgBase <- digitsBase(counter)
dgBase <- dgBase[length(dgBase):1]
## print(dgBase)
indBase <- matrix(0,1,n)
indBase[1,seq_along(dgBase)] <- dgBase
## indTmp <- ind2[ss[[counter]],,drop=FALSE]
indTmp <- ind2[(indBase == 1),,drop = FALSE]
## print(indTmp)
pdagTmp <- flipEdges(pdag,indTmp)
resTmp <- pdag2dag(as(pdagTmp,"graphNEL"))
xtbl <- resTmp$success
}
pdag <- pdagTmp
status <- 1
}
amat1 <- pdag
if (xtbl) {
## Convert to complete pattern: use rules by Pearl
old_pdag <- matrix(0, p,p)
while (any(old_pdag != pdag)) {
old_pdag <- pdag
## rule 1
ind <- which((pdag == 1 & t(pdag) == 0), arr.ind = TRUE) ## a -> b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[b,] == 1 & pdag[,b] == 1) & (pdag[a,] == 0 & pdag[,a] == 0))
if (length(indC) > 0) {
pdag[b,indC] <- 1
pdag[indC,b] <- 0
if (verbose)
cat("\nRule 1:",a,"->",b," and ",b,"-",indC,
" where ",a," and ",indC," not connected: ",b,"->",indC,"\n")
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule1")
## rule 2
ind <- which((pdag == 1 & t(pdag) == 1), arr.ind = TRUE) ## a -> b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[a,] == 1 & pdag[,a] == 0) & (pdag[,b] == 1 & pdag[b,] == 0))
if (length(indC) > 0) {
pdag[a,b] <- 1
pdag[b,a] <- 0
if (verbose) cat("\nRule 2: Kette ",a,"->",indC,"->",
b,":",a,"->",b,"\n")
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule2")
## rule 3
ind <- which((pdag == 1 & t(pdag) == 1), arr.ind = TRUE) ## a - b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[a,] == 1 & pdag[,a] == 1) & (pdag[,b] == 1 & pdag[b,] == 0))
if (length(indC) >= 2) {
## cat("R3: indC = ",indC,"\n")
g2 <- pdag[indC,indC]
## print(g2)
if (length(g2) <= 1) {
g2 <- 0
} else {
diag(g2) <- rep(1,length(indC)) ## no self reference
}
if (any(g2 == 0)) { ## if two nodes in g2 are not connected
pdag[a,b] <- 1
pdag[b,a] <- 0
if (verbose) cat("\nRule 3:",a,"->",b,"\n")
}
}
}
}
res@graph <- as(pdag,"graphNEL")
} else {
res@graph <- dag2cpdag(pdag2dag(as(pdag,"graphNEL"),keepVstruct = FALSE)$graph)
status <- 2
## res@graph <- res2$graph
}
}
list(pcObj = res, evisit = evisit, xtbl = xtbl, xtbl.orig = xtbl.orig,
amat0 = amat0, amat1 = amat1, status = status, counter = counter)
}
udag2pdagRelaxed <- function(gInput, verbose = FALSE, unfVect = NULL, solve.confl = FALSE, orientCollider = TRUE, rules = rep(TRUE, 3))
{
##################################################
## Internal functions
##################################################
## replace 'else if' branch in 'if( !solve.confl )' statement
orientConflictCollider <- function(pdag, x, y, z) { ## x - y - z
## pdag: amat, pdag[x,y] = 1 and pdag[y,x] = 0 means x -> y
## x,y,z: colnumber of nodes in pdag
## only used if conflicts should be solved
## orient x - y
if (pdag[x,y] == 1) {
## x --- y, x --> y => x --> y
pdag[y,x] <- 0
} else {
## x <-- y, x <-> y => x <-> y
pdag[x,y] <- pdag[y,x] <- 2
}
## orient z - y
if (pdag[z,y] == 1) {
## z --- y, z --> y => z --> y
pdag[y,z] <- 0
} else {
## z <-- y, z <-> y => z <-> y
pdag[z,y] <- pdag[y,z] <- 2
}
pdag
}
## TODO: include correct VERBOSE statements
rule1 <- function(pdag, solve.confl = FALSE, unfVect = NULL) {
## Rule 1: a -> b - c goes to a -> b -> c
## Interpretation: No new collider is introduced
## Out: Updated pdag
search.pdag <- pdag
ind <- which(pdag == 1 & t(pdag) == 0, arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
a <- ind[i, 1]
b <- ind[i, 2]
## find all undirected neighbours of b not adjacent to a
isC <- which(search.pdag[b, ] == 1 & search.pdag[, b] == 1 &
search.pdag[a, ] == 0 & search.pdag[, a] == 0)
if (length(isC) > 0) {
for (ii in seq_along(isC)) {
c <- isC[ii]
## if the edge between b and c has not been oriented previously,
## orient it using normal R1
if (!solve.confl | (pdag[b,c] == 1 & pdag[c,b] == 1) ) { ## no conflict
## !! before, we checked search.pdag, not pdag !!
if (!is.null(unfVect)) { ## deal with unfaithful triples
if (!any(unfVect == triple2numb(p, a, b, c), na.rm = TRUE) &&
!any(unfVect == triple2numb(p, c, b, a), na.rm = TRUE)) {
## if unfaithful triple, don't orient
pdag[b, c] <- 1
pdag[c, b] <- 0
}
} else {
## don't care about unfaithful triples -> just orient
pdag[b, c] <- 1
pdag[c, b] <- 0
## cat("Rule 1\n")
}
if (verbose)
cat("\nRule 1':", a, "->", b, " and ",
b, "-", c, " where ", a, " and ", c,
" not connected and ", a, b, c, " faithful triple: ",
b, "->", c, "\n")
} else if (pdag[b,c] == 0 & pdag[c,b] == 1) {
## conflict that must be solved
## solve conflict: if the edge is b <- c because of a previous
## orientation within for loop then output <->
if (!is.null(unfVect)) { ## deal with unfaithful triples
if (!any(unfVect == triple2numb(p, a, b, c), na.rm = TRUE) &&
!any(unfVect == triple2numb(p, c, b, a), na.rm = TRUE)) {
pdag[b, c] <- 2
pdag[c, b] <- 2
if (verbose)
cat("\nRule 1':", a, "->", b, "<-",
c, " but ", b, "->", c, "also possible and",
a, b, c, " faithful triple: ", a,"->", b, "<->", c,"\n")
}
} else {
## don't care about unfaithful triples -> just orient
pdag[b, c] <- 2
pdag[c, b] <- 2
if (verbose)
cat("\nRule 1':", a, "->", b, "<-",
c, " but ", b, "->", c, "also possible and",
a, b, c, " faithful triple: ", a,"->", b, "<->", c,"\n")
} ## unfVect: if else
} ## conflict: if else
} ## for c
} ## if length(isC)
if (!solve.confl) search.pdag <- pdag
} ## for ind
pdag
}
rule2 <- function(pdag, solve.confl = FALSE) {
## Rule 2: a -> c -> b with a - b: a -> b
## Interpretation: Avoid cycle
## normal version = conservative version
search.pdag <- pdag
ind <- which(search.pdag == 1 & t(search.pdag) == 1, arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
a <- ind[i, 1]
b <- ind[i, 2]
isC <- which(search.pdag[a, ] == 1 & search.pdag[, a] == 0 &
search.pdag[, b] == 1 & search.pdag[b, ] == 0)
for (ii in seq_along(isC)) {
c <- isC[ii]
## if the edge has not been oriented yet, orient it with R2
## always do this if you don't care about conflicts
if (!solve.confl | (pdag[a, b] == 1 & pdag[b, a] == 1) ) {
pdag[a, b] <- 1
pdag[b, a] <- 0
if (verbose)
cat("\nRule 2: Chain ", a, "->", c,
"->", b, ":", a, "->", b, "\n")
}
## else if the edge has been oriented as a <- b by a previous R2
else if (pdag[a, b] == 0 & pdag[b, a] == 1) {
pdag[a, b] <- 2
pdag[b, a] <- 2
if (verbose)
cat("\nRule 2: Chain ", a, "->", c,
"->", b, ":", a, "<->", b, "\n")
}
}
if (!solve.confl) search.pdag <- pdag
}
pdag
}
rule3 <- function(pdag, solve.confl = FALSE, unfVect = NULL) {
## Rule 3: a-b, a-c1, a-c2, c1->b, c2->b but c1 and c2 not connected;
## then a-b => a -> b
search.pdag <- pdag
ind <- which(search.pdag == 1 & t(search.pdag) == 1, arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
a <- ind[i, 1]
b <- ind[i, 2]
c <- which(search.pdag[a, ] == 1 & search.pdag[, a] == 1 &
search.pdag[, b] == 1 & search.pdag[b, ] == 0)
if (length(c) >= 2) {
cmb.C <- combn(c, 2)
cC1 <- cmb.C[1, ]
cC2 <- cmb.C[2, ]
for (j in seq_along(cC1)) {
c1 <- cC1[j]
c2 <- cC2[j]
if (search.pdag[c1, c2] == 0 && search.pdag[c2,c1] == 0) {
if (!is.null(unfVect)) {
if (!any(unfVect == triple2numb(p, c1, a, c2), na.rm = TRUE) &&
!any(unfVect == triple2numb(p, c2, a, c1), na.rm = TRUE)) {
## if the edge has not been oriented yet, orient it with R3
if (!solve.confl | (pdag[a, b] == 1 & pdag[b, a] == 1) ) {
pdag[a, b] <- 1
pdag[b, a] <- 0
if (!solve.confl) search.pdag <- pdag
if (verbose)
cat("\nRule 3':", a, c1, c2, "faithful triple: ",
a, "->", b, "\n")
break
}
## else if: we care about conflicts and the edge has been oriented as a <- b by a previous R3
else if (pdag[a, b] == 0 & pdag[b, a] == 1) {
pdag[a, b] <- pdag[b, a] <- 2
if (verbose)
cat("\nRule 3':", a, c1, c2, "faithful triple: ",
a, "<->", b, "\n")
break
} ## if solve conflict
} ## if unf. triple found
} else { ## if care about unf. triples; else don't care
if (!solve.confl | (pdag[a, b] == 1 & pdag[b, a] == 1) ) {
pdag[a, b] <- 1
pdag[b, a] <- 0
if (!solve.confl) search.pdag <- pdag
if (verbose)
cat("\nRule 3':", a, c1, c2, "faithful triple: ",
a, "->", b, "\n")
break
}
## else if: we care about conflicts and the edge has been oriented as a <- b by a previous R3
else if (pdag[a, b] == 0 & pdag[b, a] == 1) {
pdag[a, b] <- pdag[b, a] <- 2
if (verbose)
cat("\nRule 3':", a, c1, c2, "faithful triple: ",
a, "<->", b, "\n")
break
} ## if solve conflict
} ## if care about unf. triples
} ## if c1 and c2 are not adjecent
} ## for all pairs of c's
} ## if at least two c's are found
} ## for all undirected edges
pdag
}
##################################################
## Main
##################################################
## prepare adjacency matrix of skeleton
if (numEdges(gInput@graph) == 0)
return(gInput)
g <- as(gInput@graph, "matrix")
p <- nrow(g)
pdag <- g
## orient collider
if (orientCollider) {
ind <- which(g == 1, arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
x <- ind[i, 1]
y <- ind[i, 2]
allZ <- setdiff(which(g[y, ] == 1), x) ## x - y - z
for (z in allZ) {
## check collider condition
if (g[x, z] == 0 &&
!((y %in% gInput@sepset[[x]][[z]]) ||
(y %in% gInput@sepset[[z]][[x]]))) {
if (length(unfVect) == 0) { ## no unfaithful triples
if (!solve.confl) { ## don't solve conflicts
pdag[x, y] <- pdag[z, y] <- 1
pdag[y, x] <- pdag[y, z] <- 0
} else { ## solve conflicts
pdag <- orientConflictCollider(pdag, x, y, z)
}
} else { ## unfaithful triples are present
if (!any(unfVect == triple2numb(p, x, y, z), na.rm = TRUE) &&
!any(unfVect == triple2numb(p, z, y, x), na.rm = TRUE)) {
if (!solve.confl) { ## don't solve conflicts
pdag[x, y] <- pdag[z, y] <- 1
pdag[y, x] <- pdag[y, z] <- 0
} else { ## solve conflicts
pdag <- orientConflictCollider(pdag, x, y, z)
}
}
}
}
} ## for z
} ## for i
} ## end: Orient collider
## Rules 1 - 3
repeat {
old_pdag <- pdag
if (rules[1]) {
pdag <- rule1(pdag, solve.confl = solve.confl, unfVect = unfVect)
}
if (rules[2]) {
pdag <- rule2(pdag, solve.confl = solve.confl)
}
if (rules[3]) {
pdag <- rule3(pdag, solve.confl = solve.confl, unfVect = unfVect)
}
if (all(pdag == old_pdag))
break
} ## repeat
gInput@graph <- as(pdag, "graphNEL")
gInput
}
##' @title
##' @param C covariance matrix
##' @param y column of response
##' @param x columns of expl. vars
##' @return
lm.cov <- function (C, y, x) {
solve(C[x, x], C[x, y, drop = FALSE])[1, ]
}
causalEffect <- function(g,y,x) {
## Compute true causal effect of x on y in g
wmat <- wgtMatrix(g)
p <- ncol(wmat)
vec <- matrix(0,p,1)
vec[x] <- 1
## compute and return beta_{true} :
if(y-x > 1) {
for (i in (x+1):y) vec[i] <- wmat[i,]%*%vec
vec[y]
} else {
wmat[y,x]
}
}
has.new.coll <- function(amat,amatSkel, x, pa1, pa2.t, pa2.f) {
## Check if undirected edges that are pointed to x create a new v-structure
## Additionally check, if edges that are pointed away from x create
## new v-structure; i.e. x -> pa <- papa would be problematic
## pa1 are definit parents of x
## pa2 are undirected "parents" of x
## pa2.t are the nodes in pa2 that are directed towards pa2
## pa2.f are the nodes in pa2 that are directed away from pa2
## Value is TRUE, if new collider is introduced
res <- FALSE
if (length(pa2.t) > 0 && !all(is.na(pa2.t))) {
## check whether all pa1 and all pa2.t are connected;
## if no, there is a new collider
if (length(pa1) > 0 && !all(is.na(pa1))) {
res <- min(amatSkel[pa1, pa2.t]) == 0 ## TRUE if new collider
}
## in addition, all pa2.t have to be connected
if (!res && length(pa2.t) > 1) {
A2 <- amatSkel[pa2.t,pa2.t]
diag(A2) <- 1
res <- min(A2) == 0 ## TRUE if new collider
}
}
if (!res && length(pa2.f) > 0 && !all(is.na(pa2.f))) {
## consider here only the DIRECTED Parents of pa2.f
## remove undirected edges
A <- amat-t(amat)
A[A < 0] <- 0
## find parents of pa2.f
cA <- colSums(A[pa2.f,,drop = FALSE])
papa <- setdiff(which(cA != 0), x)
## if any node in papa is not directly connected to x, there is a new
## collider
if (length(papa) > 0)
res <- min(amatSkel[x,papa]) == 0 ## TRUE if new collider
}
res
}
pcAlgo.Perfect <- function(C, cutoff = 1e-8, corMethod = "standard", verbose = 0,
directed = FALSE, u2pd = "rand", psepset = FALSE) {
## Purpose: Perform PC-Algorithm, i.e., estimate skeleton of DAG given data
## Output is an unoriented graph object
## ----------------------------------------------------------------------
## Arguments:
## - C: True Correlation matrix
## - alpha: Significance level of individual partial correlation tests
## - corMethod: "standard" or "Qn" for standard or robust correlation
## estimation
## - verbose: 0-no output, 1-small output, 2-details
## - u2pd: Function for converting udag to pdag
## "rand": udag2pdag
## "relaxed": udag2pdagRelaxed
## "retry": udag2pdagSpecial
## - psepset: Also check possible sep sets.
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 26 Jan 2006; Martin Maechler
## Modification: Diego Colombo, Sept 2009
## backward compatibility
stopifnot((p <- nrow(C)) >= 2)
cl <- match.call()
seq_p <- seq_len(p)# 1:p
pcMin <- matrix(Inf, p,p)
diag(pcMin) <- 0
sepset <- pl <- vector("list",p)
for (i in seq_p) sepset[[i]] <- pl
n.edgetests <- numeric(1)# final length = max { ord}
## G := complete graph :
G <- matrix(TRUE, p,p)
diag(G) <- FALSE
done <- FALSE
ord <- 0L
while (!done && any(G)) {
n.edgetests[ord+1] <- 0
done <- TRUE
ind <- which(G, arr.ind = TRUE)
## For comparison with C++ sort according to first row
ind <- ind[order(ind[,1]), ]
remEdges <- nrow(ind)
if(verbose >= 1)
cat("Order=",ord,"; remaining edges:",remEdges,"\n", sep = '')
for (i in 1:remEdges) {
if(verbose && (verbose >= 2 || i%%100 == 0)) cat("|i=",i,"|iMax=",remEdges,"\n")
x <- ind[i,1]
y <- ind[i,2]
## done <- !G[y,x] # i.e. (x,y) was not already deleted in its (y,x) "version"
## if(!done) {
if (G[y,x]) {
nbrsBool <- G[,x]
nbrsBool[y] <- FALSE
nbrs <- seq_p[nbrsBool]
length_nbrs <- length(nbrs)
## if(verbose)
## done <- length_nbrs < ord
## if (!done) {
if (length_nbrs >= ord) {
if (length_nbrs > ord) done <- FALSE
S <- seq_len(ord)
## now includes special cases (ord == 0) or (length_nbrs == 1):
repeat { ## condition w.r.to all nbrs[S] of size 'ord' :
## if (condIndFisherZ(x,y, nbrs[S], C,n, cutoff,verbose)) {
## MM: want to use this: --- but it changes the result in some cases!!
## cat("X=",x,"|Y=",y,"|ord=",ord,"|nbrs=",nbrs[S],"|iMax=",remEdges,"\n")
n.edgetests[ord+1] <- n.edgetests[ord+1]+1
pc.val <- pcorOrder(x,y,nbrs[S],C)
if (abs(pc.val) < pcMin[x,y]) pcMin[x,y] <- abs(pc.val)
if (verbose >= 2) cat(paste("x:",x,"y:",y,"S:"),nbrs[S],paste("pc:",pc.val,"\n"))
if (abs(pc.val) <= cutoff) {
## ## pnorm(abs(z), lower.tail = FALSE) is the p-value
G[x,y] <- G[y,x] <- FALSE
sepset[[x]][[y]] <- nbrs[S]
break
}
else {
nextSet <- getNextSet(length_nbrs, ord, S)
if(nextSet$wasLast)
break
S <- nextSet$nextSet
}
}
} } ## end if(!done)
} ## end for(i ..)
ord <- ord+1L
## n.edgetests[ord] <- remEdges
}
if (psepset) {
amat <- G
ind <- which(G, arr.ind = TRUE)
storage.mode(amat) <- "integer" # (TRUE, FALSE) --> (1, 0)
## Orient colliders
for (i in seq_len(nrow(ind))) {
x <- ind[i,1]
y <- ind[i,2]
allZ <- setdiff(which(amat[y,] == 1L),x) ## x-y-z
if (length(allZ) > 0) {
for (j in seq_along(allZ)) {
z <- allZ[j]
if ((amat[x,z] == 0L) && !((y %in% sepset[[x]][[z]]) | (y %in% sepset[[z]][[x]]))) {
if (verbose == 2) {
cat("\n",x,"*->",y,"<-*",z,"\n")
cat("Sxz=",sepset[[z]][[x]],"and","Szx=",sepset[[x]][[z]],"\n")
}
## x o-> y <-o z
amat[x,y] <- amat[z,y] <- 2L
} ## if
} ## for
} ## if
} ## for
## Compute poss. sepsets
for (x in 1:p) {
attr(x,'class') <- 'possibledsep'
if (any(amat[x,] != 0L)) {
tf1 <- setdiff(reach(x,-1,-1,amat),x)
for (y in seq_p[amat[x,] != 0L]) {
## tf = possible_d_sep(amat,x,y)
tf <- setdiff(tf1,y)
## test
if (length(tf) > 0) {
pc.val <- pcorOrder(x,y,tf,C)
if (abs(pc.val) < pcMin[x,y]) {
pcMin[x,y] <- abs(pc.val)
}
if (abs(pc.val) <= cutoff) {
## delete x-y
amat[x,y] <- amat[y,x] <- 0L
## save pos d-sepset in sepset
sepset[[x]][[y]] <- tf
if (verbose == 2) {
cat("Delete edge",x,"-",y,"\n")
}
}
if (verbose == 2) {
cat("Possible-D-Sep of", x, "and", y, "is", tf, " - pc = ",pc.val,"\n")
}
}
}
}
}
G[amat == 0L] <- FALSE
G[amat == 1L] <- TRUE
} ## end if(psepset)
if(verbose >= 1) { cat("Final graph adjacency matrix:\n"); print(symnum(G)) }
## transform matrix to graph object :
if (sum(G) == 0) {
Gobject <- new("graphNEL", nodes = as.character(seq_p))
}
else {
colnames(G) <- rownames(G) <- as.character(seq_p)
Gobject <- as(G,"graphNEL")
}
for (i in 1:(p-1)) {
for (j in 2:p) {
pcMin[i,j] <- pcMin[j,i] <- min(pcMin[i,j],pcMin[j,i])
}
}
res <- new("pcAlgo",
graph = Gobject,
call = cl, n = as.integer(1), max.ord = as.integer(ord-1),
n.edgetests = n.edgetests, sepset = sepset,
zMin = pcMin)
if (directed)
switch(u2pd,
"rand" = udag2pdag(res),
"retry" = udag2pdagSpecial(res)$pcObj,
"relaxed" = udag2pdagRelaxed(res))
else
res
}## pcAlgo.Perfect
### reach(): currently only called from pcAlgo() and pcAlgo.Perfect()
### ------- and only in "possibledsep" version
## Function that computes the Possible d-sepset, done by Spirtes
reach <- function(a,b,c,adjacency)
{
## reachable set of vertices;
## edgeslist array[1..maxvertex] of list of edges
## numvertex integer
## labeled array (by depth) of list of edges that have been labeled
makeedge <- function(x,y) list(list(x,y))
legal.pdsep <- function(r,s) {
## Modifying global 'edgeslist'
if ((adjacency[r[[1]],r[[2]]] == 2 &&
adjacency[s, r[[2]]] == 2 && r[[1]] != s) ||
(adjacency[r[[1]],s] != 0 && r[[1]] != s)) {
edgeslist[[r[[2]]]] <<- setdiff(edgeslist[[r[[2]]]],s)
makeedge(r[[2]],s)
}
}
initialize.pdsep <- function(x,y) mapply(makeedge, x = x, y = y)
labeled <- list()
numvertex <- dim(adjacency)[1]
edgeslist <- list()
for (i in 1:numvertex)
edgeslist <- c(edgeslist,list(which(adjacency[,i] != 0)))
labeled[[1]] <- initialize.pdsep(a, edgeslist[[a]])
edgeslist[[a]] <- list()
depth <- 2
repeat {
labeled[[depth]] <- list()
for (i in seq_along(labeled[[depth-1]])) {
lab.i <- labeled[[depth-1]][[i]]
edgestemp <- edgeslist[[lab.i[[2]]]]
if (length(edgestemp) == 0) break
for (j in seq_along(edgestemp))
labeled[[depth]] <- union(legal.pdsep(lab.i, edgestemp[[j]]),
labeled[[depth]])
}
if (length(labeled[[depth]]) == 0)
break
## else :
depth <- depth + 1
}
unique(unlist(labeled))
}
skeleton <- function(suffStat, indepTest, alpha, labels, p,
method = c("stable", "original", "stable.fast"), m.max = Inf,
fixedGaps = NULL, fixedEdges = NULL,
NAdelete = TRUE, numCores = 1, verbose = FALSE)
{
## Purpose: Perform undirected part of PC-Algorithm, i.e.,
## estimate skeleton of DAG given data
## Order-independent version! NEU
## ----------------------------------------------------------------------
## Arguments:
## - suffStat: List containing all necessary elements for the conditional
## independence decisions in the function "indepTest".
## - indepTest: predefined function for testing conditional independence
## - alpha: Significance level of individual partial correlation tests
## - fixedGaps: the adjacency matrix of the graph from which the algorithm
## should start (logical); gaps fixed here are not changed
## - fixedEdges: Edges marked here are not changed (logical)
## - NAdelete: delete edge if pval=NA (for discrete data)
## - m.max: maximal size of conditioning set
## - numCores: number of cores to be used for calculation if
## method = "stable.fast"
## ----------------------------------------------------------------------
## Value:
## - G, sepset, pMax, ord, n.edgetests
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 09.12.2009
## Modification: Diego Colombo; Martin Maechler; Alain Hauser
## x,y,S konstruieren
##- tst <- try(indepTest(x,y,S, obj))
##- if(inherits(tst, "try-error"))
##- stop("the 'indepTest' function does not work correctly with 'obj'")
cl <- match.call()
if(!missing(p)) stopifnot(is.numeric(p), length(p <- as.integer(p)) == 1, p >= 2)
if(missing(labels)) {
if(missing(p)) stop("need to specify 'labels' or 'p'")
labels <- as.character(seq_len(p))
} else { ## use labels ==> p from it
stopifnot(is.character(labels))
if(missing(p))
p <- length(labels)
else if(p != length(labels))
stop("'p' is not needed when 'labels' is specified, and must match length(labels)")
## Don't want message, in case this is called e.g. from fciPlus():
## else
## message("No need to specify 'p', when 'labels' is given")
}
seq_p <- seq_len(p)
method <- match.arg(method)
## C++ version still has problems under Windows; will have to check why
## if (method == "stable.fast" && .Platform$OS.type == "windows") {
## method <- "stable"
## warning("Method 'stable.fast' is not available under Windows; using 'stable' instead.")
## }
## G := !fixedGaps, i.e. G[i,j] is true iff i--j will be investigated
if (is.null(fixedGaps)) {
G <- matrix(TRUE, nrow = p, ncol = p)
}
else if (!identical(dim(fixedGaps), c(p, p)))
stop("Dimensions of the dataset and fixedGaps do not agree.")
else if (!identical(fixedGaps, t(fixedGaps)) )
stop("fixedGaps must be symmetric")
else
G <- !fixedGaps
diag(G) <- FALSE
if (any(is.null(fixedEdges))) { ## MM: could be sparse
fixedEdges <- matrix(rep(FALSE, p * p), nrow = p, ncol = p)
}
else if (!identical(dim(fixedEdges), c(p, p)))
stop("Dimensions of the dataset and fixedEdges do not agree.")
else if (!identical(fixedEdges, t(fixedEdges)) )
stop("fixedEdges must be symmetric")
## Check number of cores
stopifnot((is.integer(numCores) || is.numeric(numCores)) && numCores > 0)
if (numCores > 1 && method != "stable.fast") {
warning("Argument numCores ignored: parallelization only available for method = 'stable.fast'")
}
if (method == "stable.fast") {
## Do calculation in C++...
if (identical(indepTest, gaussCItest))
indepTestName <- "gauss"
else
indepTestName <- "rfun"
options <- list(
verbose = as.integer(verbose),
m.max = as.integer(ifelse(is.infinite(m.max), p, m.max)),
NAdelete = NAdelete,
numCores = numCores)
res <- .Call(estimateSkeleton,
G, suffStat, indepTestName, indepTest, alpha, fixedEdges, options)
G <- res$amat
## sepset <- res$sepset
sepset <- lapply(seq_p, function(i) c(
lapply(res$sepset[[i]], function(v) if(identical(v, as.integer(-1))) NULL else v),
vector("list", p - length(res$sepset[[i]])))) # TODO change convention: make sepset triangular
pMax <- res$pMax
n.edgetests <- res$n.edgetests
ord <- length(n.edgetests) - 1L
}
else {
## Original R version
pval <- NULL
sepset <- lapply(seq_p, function(.) vector("list",p))# a list of lists [p x p]
## save maximal p value
pMax <- matrix(-Inf, nrow = p, ncol = p)
diag(pMax) <- 1
done <- FALSE
ord <- 0L
n.edgetests <- numeric(1)# final length = max { ord}
while (!done && any(G) && ord <= m.max) {
n.edgetests[ord1 <- ord+1L] <- 0
done <- TRUE
ind <- which(G, arr.ind = TRUE)
## For comparison with C++ sort according to first row
ind <- ind[order(ind[, 1]), ]
remEdges <- nrow(ind)
if (verbose)
cat("Order=", ord, "; remaining edges:", remEdges,"\n",sep = "")
if(method == "stable") {
## Order-independent version: Compute the adjacency sets for any vertex
## Then don't update when edges are deleted
G.l <- split(G, gl(p,p))
}
for (i in 1:remEdges) {
if(verbose && (verbose >= 2 || i%%100 == 0)) cat("|i=", i, "|iMax=", remEdges, "\n")
x <- ind[i, 1]
y <- ind[i, 2]
if (G[y, x] && !fixedEdges[y, x]) {
nbrsBool <- if(method == "stable") G.l[[x]] else G[,x]
nbrsBool[y] <- FALSE
nbrs <- seq_p[nbrsBool]
length_nbrs <- length(nbrs)
if (length_nbrs >= ord) {
if (length_nbrs > ord)
done <- FALSE
S <- seq_len(ord)
repeat { ## condition w.r.to all nbrs[S] of size 'ord'
n.edgetests[ord1] <- n.edgetests[ord1] + 1
pval <- indepTest(x, y, nbrs[S], suffStat)
if (verbose)
cat("x=", x, " y=", y, " S=", nbrs[S], ": pval =", pval, "\n")
if(is.na(pval))
pval <- as.numeric(NAdelete) ## = if(NAdelete) 1 else 0
if (pMax[x, y] < pval)
pMax[x, y] <- pval
if(pval >= alpha) { # independent
G[x, y] <- G[y, x] <- FALSE
sepset[[x]][[y]] <- nbrs[S]
break
}
else {
nextSet <- getNextSet(length_nbrs, ord, S)
if (nextSet$wasLast)
break
S <- nextSet$nextSet
}
} ## repeat
}
}
}# for( i )
ord <- ord + 1L
} ## while()
for (i in 1:(p - 1)) {
for (j in 2:p)
pMax[i, j] <- pMax[j, i] <- max(pMax[i, j], pMax[j,i])
}
}
## transform matrix to graph object :
Gobject <-
if (sum(G) == 0) {
new("graphNEL", nodes = labels)
} else {
colnames(G) <- rownames(G) <- labels
as(G,"graphNEL")
}
## final object
new("pcAlgo", graph = Gobject, call = cl, n = integer(0),
max.ord = as.integer(ord - 1), n.edgetests = n.edgetests,
sepset = sepset, pMax = pMax, zMin = matrix(NA, 1, 1))
}## end{ skeleton }
pc <- function(suffStat, indepTest, alpha, labels, p,
fixedGaps = NULL, fixedEdges = NULL, NAdelete = TRUE, m.max = Inf,
u2pd = c("relaxed", "rand", "retry"),
skel.method = c("stable", "original", "stable.fast"),
conservative = FALSE, maj.rule = FALSE,
solve.confl = FALSE, numCores = 1, verbose = FALSE)
{
## Purpose: Perform PC-Algorithm, i.e., estimate skeleton of DAG given data
## ----------------------------------------------------------------------
## Arguments:
## - dm: Data matrix (rows: samples, cols: nodes)
## - C: correlation matrix (only for continuous)
## - n: sample size
## - alpha: Significance level of individual partial correlation tests
## - corMethod: "standard" or "Qn" for standard or robust correlation
## estimation
## - G: the adjacency matrix of the graph from which the algorithm
## should start (logical)
## - datatype: distinguish between discrete and continuous data
## - NAdelete: delete edge if pval=NA (for discrete data)
## - m.max: maximal size of conditioning set
## - u2pd: Function for converting udag to pdag
## "rand": udag2pdag
## "relaxed": udag2pdagRelaxed
## "retry": udag2pdagSpecial
## - gTrue: Graph suffStatect of true DAG
## - conservative: If TRUE, conservative PC is done
## - numCores: handed to skeleton(), used for parallelization
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 26 Jan 2006; Martin Maechler
## Modifications: Sarah Gerster, Diego Colombo, Markus Kalisch
## Initial Checks
cl <- match.call()
if(!missing(p)) stopifnot(is.numeric(p), length(p <- as.integer(p)) == 1, p >= 2)
if(missing(labels)) {
if(missing(p)) stop("need to specify 'labels' or 'p'")
labels <- as.character(seq_len(p))
} else { ## use labels ==> p from it
stopifnot(is.character(labels))
if(missing(p)) {
p <- length(labels)
} else if(p != length(labels))
stop("'p' is not needed when 'labels' is specified, and must match length(labels)")
else
message("No need to specify 'p', when 'labels' is given")
}
u2pd <- match.arg(u2pd)
skel.method <- match.arg(skel.method)
if(u2pd != "relaxed") {
if (conservative || maj.rule)
stop("Conservative PC and majority rule PC can only be run with 'u2pd = relaxed'")
if (solve.confl)
stop("Versions of PC using lists for the orientation rules (and possibly bi-directed edges)\n can only be run with 'u2pd = relaxed'")
}
if (conservative && maj.rule) stop("Choose either conservative PC or majority rule PC!")
## Skeleton
skel <- skeleton(suffStat, indepTest, alpha, labels = labels, method = skel.method,
fixedGaps = fixedGaps, fixedEdges = fixedEdges,
NAdelete=NAdelete, m.max=m.max, numCores=numCores, verbose=verbose)
skel@call <- cl # so that makes it into result
## Orient edges
if (!conservative && !maj.rule) {
switch (u2pd,
"rand" = udag2pdag(skel),
"retry" = udag2pdagSpecial(skel)$pcObj,
"relaxed" = udag2pdagRelaxed(skel, verbose = verbose, solve.confl = solve.confl))
}
else { ## u2pd "relaxed" : conservative _or_ maj.rule
## version.unf defined per default
## Tetrad CPC works with version.unf=c(2,1)
## see comment on pc.cons.intern for description of version.unf
pc. <- pc.cons.intern(skel, suffStat, indepTest, alpha,
version.unf = c(2,1), maj.rule = maj.rule, verbose = verbose)
udag2pdagRelaxed(pc.$sk, verbose = verbose,
unfVect = pc.$unfTripl, solve.confl = solve.confl)
}
} ## {pc}
gSquareBin <- function(x, y, S, dm, adaptDF = FALSE, n.min = 10*df,
verbose = FALSE)
{
## Purpose: G^2 statistic to test for (conditional) independence
## of *binary* variables X and Y given S --> ../man/binCItest.Rd
## -------------------------------------------------------------------------
## Arguments:
## - x,y,S: Are x,y conditionally independent given S (S can be NULL)?
## - dm: data matrix (rows: samples, columns: variables) with binary entries
## - verbose: if TRUE, some additional info is outputted during the
## computations
## - adaptDF: lower the degrees of freedom by one for each zero count.
## The value for the DF cannot go below 1.
## -------------------------------------------------------------------------
stopifnot((n <- nrow(dm)) >= 1) # nr of samples
if(!all(as.logical(dm) == dm))
stop("'dm' must be binary, i.e. with values in {0,1}")
if(verbose) cat('Edge ',x,'--',y, ' with subset S =', S,'\n')
lenS <- length(S)
## degrees of freedom assuming no structural zeros
df <- 2^lenS
if (n < n.min) { ## not enough samples to perform the test:
warning(gettextf(
"n=%d is too small (n < n.min = %d ) for G^2 test (=> treated as independence)",
n, n.min), domain = NA)
return( 1 )
}
## else -- enough data to perform the test
d.x1 <- dm[,x] + 1L
d.y1 <- dm[,y] + 1L
if(lenS <= 5) { # bei gSquareDis lenS <= 4
n12 <- 1:2
switch(lenS+1L, {
## lenS == 0 ----------------------------------
nijk <- array(0L, c(2,2)) # really 'nij', but 'nijk' is "global" name
for (i in n12) {
d.x.i <- d.x1 == i
for (j in n12)
nijk[i,j] <- sum(d.x.i & d.y1 == j)
}
## marginal counts
## compute G^2
t.log <- n*(nijk / tcrossprod(rowSums(nijk), colSums(nijk)))
} ,
{ ## lenS == 1 ----------------------------------
## a.pos <- sort(c(x,y,S))
dmS.1 <- dm[,S] + 1L
nijk <- array(0L, c(2,2,2))
for(i in n12) {
d.x.i <- d.x1 == i
for(j in n12) {
d.x.i.y.j <- d.x.i & d.y1 == j
for(k in n12)
nijk[i,j,k] <- sum(d.x.i.y.j & dmS.1 == k)
}
}
alt <- c(x,y,S)
c <- which(alt == S)
nik <- apply(nijk,c,rowSums)
njk <- apply(nijk,c,colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0,c(2,2,2))
if(c == 3) {
for (k in n12)
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k], njk[,k]))
} else if(c == 1) {
for (k in n12)
t.log[k,,] <- nijk[k,,]*(nk[k] / tcrossprod(nik[,k], njk[,k]))
} else { ## c == 2 (?)
for (k in n12)
t.log[,k,] <- nijk[,k,]*(nk[k] / tcrossprod(nik[,k], njk[,k]))
}
} ,
{ ## lenS == 2 ----------------------------------
## a.pos <- sort(c(x,y,S))
dmS1.1 <- dm[,S[1]] + 1L
dmS2.1 <- dm[,S[2]] + 1L
nijk2 <- array(0L, c(2,2,2,2))
for(i in n12) {
d.x.i <- d.x1 == i
for(j in n12) {
d.x.i.y.j <- d.x.i & d.y1 == j
for(k in n12) {
d.x.y.S1 <- d.x.i.y.j & dmS1.1 == k
for(l in n12)
nijk2[i,j,k,l] <- sum(d.x.y.S1 & dmS2.1 == l)
}
}
}
nijk <- array(0L, c(2,2,4))
for(i in n12) {
for(j in n12)
nijk[,,2*(i-1)+j] <- nijk2[,,i,j]
}
nik <- apply(nijk,3,rowSums)
njk <- apply(nijk,3,colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0,c(2,2,4))
for (k in 1:4)
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k], njk[,k]))
} ,
{ ## lenS == 3 ----------------------------------
dmS1.1 <- dm[,S[1]] + 1L
dmS2.1 <- dm[,S[2]] + 1L
dmS3.1 <- dm[,S[3]] + 1L
nijk <- array(0L, c(2,2,8))
for(i1 in n12) {
d.x.i <- d.x1 == i1
for(i2 in n12) {
d.x.y.i12 <- d.x.i & d.y1 == i2
for(i3 in n12) {
d.x.y.S1 <- d.x.y.i12 & dmS1.1 == i3
for(i4 in n12) {
d.xy.S1S2 <- d.x.y.S1 & dmS2.1 == i4
for(i5 in n12)
nijk[i1,i2,4*(i3-1)+2*(i4-1)+i5] <-
sum(d.xy.S1S2 & dmS3.1 == i5)
}
}
}
}
nik <- apply(nijk, 3, rowSums)
njk <- apply(nijk, 3, colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0,c(2,2,8))
for (k in 1:8)
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k], njk[,k]))
} ,
{ ## lenS == 4 ----------------------------------
dmS1.1 <- dm[,S[1]] + 1L
dmS2.1 <- dm[,S[2]] + 1L
dmS3.1 <- dm[,S[3]] + 1L
dmS4.1 <- dm[,S[4]] + 1L
nijk <- array(0L, c(2,2,16))
for(i1 in n12) {
d.x.i <- d.x1 == i1
for(i2 in n12) {
d.x.y.i12 <- d.x.i & d.y1 == i2
for(i3 in n12) {
d.x.y.S1 <- d.x.y.i12 & dmS1.1 == i3
for(i4 in n12) {
d.xy.S1S2 <- d.x.y.S1 & dmS2.1 == i4
for(i5 in n12) {
d.xy.S1S2S3 <- d.xy.S1S2 & dmS3.1 == i5
for(i6 in n12)
nijk[i1,i2,8*(i3-1)+4*(i4-1)+2*(i5-1)+i6] <-
sum(d.xy.S1S2S3 & dmS4.1 == i6)
}
}
}
}
}
nik <- apply(nijk,3,rowSums)
njk <- apply(nijk,3,colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0, c(2,2,16))
for (k in 1:16)
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k], njk[,k]))
} ,
{ ## lenS == 5 ----------------------------------
dmS1.1 <- dm[,S[1]] + 1L
dmS2.1 <- dm[,S[2]] + 1L
dmS3.1 <- dm[,S[3]] + 1L
dmS4.1 <- dm[,S[4]] + 1L
dmS5.1 <- dm[,S[5]] + 1L
nijk <- array(0L, c(2,2,32))
for(i1 in n12) {
d.x.i <- d.x1 == i1
for(i2 in n12) {
d.x.y.i12 <- d.x.i & d.y1 == i2
for(i3 in n12) {
d.x.y.S1 <- d.x.y.i12 & dmS1.1 == i3
for(i4 in n12) {
d.xy.S1S2 <- d.x.y.S1 & dmS2.1 == i4
for(i5 in n12) {
d.xy.S1S2S3 <- d.xy.S1S2 & dmS3.1 == i5
for(i6 in n12) {
d.xy.S1S2S3S4 <- d.xy.S1S2S3 & dmS4.1 == i6
for(i7 in n12)
nijk[i1,i2,16*(i3-1)+8*(i4-1)+4*(i5-1)+2*(i6-1)+i7] <-
sum(d.xy.S1S2S3S4 & dmS5.1 == i7)
}
}
}
}
}
}
nik <- apply(nijk,3,rowSums)
njk <- apply(nijk,3,colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0,c(2,2,32))
for (k in 1:32)
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k], njk[,k]))
})# end {lenS = 5}, end{switch}
}
else { # --- |S| >= 6 -------------------------------------------------
nijk <- array(0L, c(2,2,1))
## first sample 'by hand' to avoid if/else in the for-loop
i <- d.x1[1]
j <- d.y1[1]
## create directly a list of all k's -- MM{FIXME}: there must be a better way
k <- NULL
lapply(as.list(S), function(x) { k <<- cbind(k,dm[,x]+1); NULL })
## first set of subset values
parents.count <- 1L ## counter variable corresponding to the number
## of value combinations for the subset varibales
## observed in the data
parents.val <- t(k[1,])
nijk[i,j,parents.count] <- 1L # cell counts
## Do the same for all other samples. If there is already a table
## for the subset values of the sample, increase the corresponding
## cell count. If not, create a new table and set the corresponding
## cell count to 1.
for (it.sample in 2:n) {
new.p <- TRUE
i <- d.x1[it.sample]
j <- d.y1[it.sample]
## comparing the current values of the subset variables to all
## already existing combinations of subset variables values
t.comp <- t(parents.val[1:parents.count,]) == k[it.sample,]
## Have to be careful here. When giving dimension to a list,
## R fills column after column, and NOT row after row.
dim(t.comp) <- c(lenS,parents.count)
for (it.parents in 1:parents.count) {
## check if the present combination of value alreay exists
if(all(t.comp[,it.parents])) {
## if yes, increase the corresponding cell count
nijk[i,j,it.parents] <- nijk[i,j,it.parents] + 1L
new.p <- FALSE
break
}
}
## if the combination of subset values is new...
if (new.p) {
## ...increase the number of subset 'types'
parents.count <- parents.count + 1L
if (verbose >= 2)
cat(sprintf(' adding new parents (count = %d) at sample %d\n',
parents.count, it.sample))
## ...add the new subset to the others
parents.val <- rbind(parents.val, k[it.sample,])
## ...update the cell counts (add new array)
nijk <- abind(nijk, array(0,c(2,2,1)))
nijk[i,j,parents.count] <- 1L
}## if(new.p)
}## end for(it.sample ..)
nik <- apply(nijk,3,rowSums)
njk <- apply(nijk,3,colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0, c(2,2,parents.count))
for (k in 1:parents.count)
t.log[,,k] <- nijk[,,k] * (nk[k] / tcrossprod(nik[,k],njk[,k]))
} ## |S| >= 6
G2 <- sum(2 * nijk * log(t.log), na.rm = TRUE)
if (adaptDF && lenS > 0) {
## lower the degrees of freedom according to the amount of zero
## counts; add zero counts corresponding to the number of parents
## combinations that are missing
zero.counts <- sum(nijk == 0L) + 4*(2^lenS-dim(nijk)[3])
ndf <- max(1, df-zero.counts)
if(verbose) cat("adaptDF: (df=",df,", zero.counts=",zero.counts,
") ==> new df = ", ndf, "\n", sep = "")
df <- ndf
}
pchisq(G2, df, lower.tail = FALSE)# i.e. == 1 - P(..)
}## gSquareBin()
gSquareDis <- function(x, y, S, dm, nlev, adaptDF = FALSE, n.min = 10*df,
verbose = FALSE) {
## Purpose: G^2 statistic to test for (conditional) independence of
## __discrete__ X and Y given S --> ../man/disCItest.Rd
## -------------------------------------------------------------------
## Arguments:
## - x,y,S: Are x,y conditionally independent given S (S can be NULL)?
## - dm: data matrix (rows: samples, columns: variables) with
## discrete entries
## - nlev: vector with numbers of levels for each variable
## - verbose: if TRUE, some additional info is outputted during the
## computations
## - adaptDF: lower the degrees of freedom by one for each zero count.
## The value for the DF cannot go below 1.
## -------------------------------------------------------------------
stopifnot((n <- nrow(dm)) >= 1, # nr of samples
(p <- ncol(dm)) >= 2) # nr of variables or nodes
if(!all(1 <= c(x,y,S) & c(x,y,S) <= p))
stop("x, y, and S must all be in {1,..,p}, p=",p)
if(any(as.integer(dm) != dm))
stop("'dm' must be discrete, with values in {0,1,..}")
if(!any(dm == 0))
stop("'dm' must have values in {0,1,..} with at least one '0' value")
if(verbose) cat('Edge ', x,'--',y, ' with subset S =', S,'\n')
lenS <- length(S)
if(missing(nlev) || is.null(nlev))
nlev <- vapply(seq_len(p),
function(j) length(levels(factor(dm[,j]))), 1L)
else
stopifnot(is.numeric(nlev), length(nlev) == p, !is.na(nlev))
if(!all(nlev >= 2))
stop("Each variable, i.e., column of 'dm', must have at least two different values")
nl.x <- nlev[x]
nl.y <- nlev[y]
nl.S <- nlev[S]
## degrees of freedom assuming no structural zeros
df <- (nl.x-1)*(nl.y-1)*prod(nl.S)
if (n < n.min) { ## not enough samples to perform the test:
warning(gettextf(
"n=%d is too small (n < n.min = %d ) for G^2 test (=> treated as independence)",
n, n.min), domain = NA)
return( 1 ) ## gerster prob=0
}
## else -- enough data to perform the test
i.ny <- seq_len(nl.y) # = 1:nl.y
lenS <- length(S)
d.x1 <- dm[,x] + 1L
d.y1 <- dm[,y] + 1L
if(lenS <= 4) { # bei gSquareBin lenS <= 5
switch(lenS+1L, { ## lenS == 0 -------------------
nij <- array(0L, c(nl.x,nl.y))
for (i in 1:nl.x) {
d.x.i <- d.x1 == i
for (j in i.ny)
nij[i,j] <- sum(d.x.i & d.y1 == j)
}
## marginal counts
t.X <- rowSums(nij)
t.Y <- colSums(nij)
## compute G^2
t.log <- n*(nij/ tcrossprod(t.X, t.Y))
t.G2 <- 2*nij * log(t.log)
t.G2[is.nan(t.G2)] <- 0
G2 <- sum(t.G2)
} ,
{ ## lenS == 1 ----------------------------------
in.S <- seq_len(nl.S)
dmS.1 <- dm[,S] + 1L
nijk <- array(0L, c(nl.x,nl.y,nl.S))
for(i in 1:nl.x) {
d.x.i <- d.x1 == i
for(j in i.ny) {
d.x.i.y.j <- d.x.i & d.y1 == j
for(k in in.S)
nijk[i,j,k] <- sum(d.x.i.y.j & dmS.1 == k)
}
}
nik <- apply(nijk, 3, rowSums)
njk <- apply(nijk, 3, colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0, c(nl.x,nl.y,prod(nl.S)))
for (k in 1:prod(nl.S))
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k],njk[,k]))
t.G2 <- 2 * nijk * log(t.log)
t.G2[is.nan(t.G2)] <- 0
G2 <- sum(t.G2)
} ,
{ ## lenS == 2 ----------------------------------
in.S1 <- seq_len(nl.S1 <- nl.S[1])
in.S2 <- seq_len(nl.S2 <- nl.S[2])
dmS1.1 <- dm[,S[1]] + 1L
dmS2.1 <- dm[,S[2]] + 1L
nijk <- array(0L, c(nl.x,nl.y,nl.S1*nl.S2))
for(i in 1:nl.x) {
d.x.i <- d.x1 == i
for(j in i.ny) {
d.x.i.y.j <- d.x.i & d.y1 == j
for(k in in.S1) {
d.x.y.S1 <- d.x.i.y.j & dmS1.1 == k
for(l in in.S2)
nijk[i,j,nl.S2*(k-1)+l] <- sum(d.x.y.S1 & dmS2.1 == l)
}
}
}
nik <- apply(nijk, 3, rowSums)
njk <- apply(nijk, 3, colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0, c(nl.x,nl.y,prod(nl.S)))
for (k in 1:prod(nl.S))
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k],njk[,k]))
t.G2 <- 2 * nijk * log(t.log)
t.G2[is.nan(t.G2)] <- 0
G2 <- sum(t.G2)
} ,
{ ## lenS == 3 ----------------------------------
in.S1 <- seq_len(nl.S1 <- nl.S[1])
in.S2 <- seq_len(nl.S2 <- nl.S[2])
in.S3 <- seq_len(nl.S3 <- nl.S[3])
dmS1.1 <- dm[,S[1]] + 1L
dmS2.1 <- dm[,S[2]] + 1L
dmS3.1 <- dm[,S[3]] + 1L
nijk <- array(0L, c(nl.x,nl.y,prod(nl.S)))
for(i1 in 1:nl.x) {
d.x.i1 <- d.x1 == i1
for(i2 in i.ny) {
d.x.i1.y.i2 <- d.x.i1 & d.y1 == i2
for(i3 in in.S1) {
d.x.y.S1 <- d.x.i1.y.i2 & dmS1.1 == i3
for(i4 in in.S2) {
d.x.y.S1.2 <- d.x.y.S1 & dmS2.1 == i4
for(i5 in in.S3)
nijk[i1,i2, nl.S3*nl.S2*(i3-1)+nl.S3*(i4-1)+i5] <-
sum(d.x.y.S1.2 & dmS3.1 == i5)
}
}
}
}
nik <- apply(nijk, 3, rowSums)
njk <- apply(nijk, 3, colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0, c(nl.x,nl.y,prod(nl.S)))
for (k in 1:prod(nl.S))
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k],njk[,k]))
t.G2 <- 2 * nijk * log(t.log)
t.G2[which(is.nan(t.G2),arr.ind = TRUE)] <- 0
G2 <- sum(t.G2)
} ,
{ ## lenS == 4 ----------------------------------
in.S1 <- seq_len(nl.S1 <- nl.S[1])
in.S2 <- seq_len(nl.S2 <- nl.S[2])
in.S3 <- seq_len(nl.S3 <- nl.S[3])
in.S4 <- seq_len(nl.S4 <- nl.S[4])
dmS1.1 <- dm[,S[1]] + 1L
dmS2.1 <- dm[,S[2]] + 1L
dmS3.1 <- dm[,S[3]] + 1L
dmS4.1 <- dm[,S[4]] + 1L
nijk <- array(0L, c(nl.x, nl.y, prod(nl.S)))
for(i1 in 1:nl.x) {
d.x.i1 <- d.x1 == i1
for(i2 in i.ny) {
d.x.i1.y.i2 <- d.x.i1 & d.y1 == i2
for(i3 in in.S1) {
d.x.y.S1 <- d.x.i1.y.i2 & dmS1.1 == i3
for(i4 in in.S2) {
d.x.y.S1.2 <- d.x.y.S1 & dmS2.1 == i4
for(i5 in in.S3) {
d.x.y.S1.2.3 <- d.x.y.S1.2 & dmS3.1 == i5
for(i6 in in.S4)
nijk[i1,i2, nl.S4*nl.S3*nl.S2*(i3-1) +
nl.S4*nl.S3*(i4-1)+
nl.S4*(i5-1)+i6] <- sum(d.x.y.S1.2.3 & dmS4.1 == i6)
}
}
}
}
}
nik <- apply(nijk, 3, rowSums)
njk <- apply(nijk, 3, colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0, c(nl.x,nl.y,prod(nl.S)))
for (k in 1:prod(nl.S))
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k],njk[,k]))
t.G2 <- 2 * nijk * log(t.log)
t.G2[is.nan(t.G2)] <- 0
G2 <- sum(t.G2)
}) # end lens == 4, end{switch}
}
else { # |S| = lenS >= 5 (gSquareBin: lenS >= 6)
nijk <- array(0L, c(nl.x, nl.y, 1L))
## first sample 'by hand' to avoid if/else in the for-loop
i <- d.x1[1]
j <- d.y1[1]
## create directly a list of all k's -- MM{FIXME}: there must be a better way
k <- NULL
lapply(as.list(S), function(x) { k <<- cbind(k,d.x1); NULL })
## first set of subset values
parents.count <- 1L ## counter variable corresponding to the number
## of value combinations for the subset varibales
## observed in the data
parents.val <- t(k[1,])
nijk[i,j,parents.count] <- 1L # cell counts
## Do the same for all other samples. If there is already a table
## for the subset values of the sample, increase the corresponding
## cell count. If not, create a new table and set the corresponding
## cell count to 1.
for (it.sample in 2:n) {
flag <- 0
i <- d.x1[it.sample]
j <- d.y1[it.sample]
## comparing the current values of the subset variables to all
## already existing combinations of subset variables values
t.comp <- t(parents.val[1:parents.count,]) == k[it.sample,]
## Have to be careful here. When giving dimension to a list,
## R fills column after column, and NOT row after row.
dim(t.comp) <- c(lenS,parents.count)
for (it.parents in 1:parents.count) {
## check if the present combination of value alreay exists
if(all(t.comp[,it.parents])) {
## if yes, increase the corresponding cell count
nijk[i,j,it.parents] <- nijk[i,j,it.parents] + 1L
flag <- 1
break
}
}# end for(it.parents...)
## if the combination of subset values is new...
if (flag == 0) {
## ...increase the number of subset 'types'
parents.count <- parents.count + 1L
if (verbose >= 2)
cat(sprintf(' adding new parents (count = %d) at sample %d\n',
parents.count, it.sample))
## ...add the new subset to the others
parents.val <- rbind(parents.val,k[it.sample,])
## ...update the cell counts (add new array)
nijk <- abind(nijk, array(0L, c(nl.x,nl.y,1)))
nijk[i,j,parents.count] <- 1L
} # end if(flag==0)
} ## for(it in 2:n)
if (verbose && verbose < 2)
cat(sprintf(" added a total of %d new parents\n", parents.count))
nik <- apply(nijk,3,rowSums)
njk <- apply(nijk,3,colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0,c(nl.x,nl.y,parents.count))
for (k in 1:parents.count)
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k],njk[,k]))
t.G2 <- 2 * nijk * log(t.log)
t.G2[which(is.nan(t.G2),arr.ind = TRUE)] <- 0
G2 <- sum(t.G2)
}
if (adaptDF && lenS > 0) {
## lower the degrees of freedom according to the amount of
## zero counts
zero.counts <-
if(lenS == 0)
length(which(nij == 0))
else
length(which(nijk == 0)) + 4*(2^lenS - dim(nijk)[3])
## add zero counts corresponding to the number of parents
## combinations that are missing
df <- max((df-zero.counts),1)
} # end adaptDF
pchisq(G2, df, lower.tail = FALSE)# i.e. == 1 - P(..)
}## gSquareDis()
gaussCItest <- function(x,y,S,suffStat) {
## suffStat$C: correlation matrix
## suffStat$n: sample size
z <- zStat(x,y,S, C = suffStat$C, n = suffStat$n)
2*pnorm(abs(z), lower.tail = FALSE)
}
dsep <- function(a,b, S = NULL, g, john.pairs = NULL)
{
## Purpose: Are the set a and the set b d-separeted given the set S?
## ----------------------------------------------------------------------
## Arguments:
## - a,b,S: vectors of node names
## - g: graphNEL object
## - john.pairs: matrix from johnson.all.pairs.sp
## ----------------------------------------------------------------------
## Value:
## Boolean decision
## ----------------------------------------------------------------------
## Author: Markus Kalisch
## Check that g is a DAG
amatTmp <- wgtMatrix(g) ## i->j if amatTmp[j,i]!=0
amatTmp[amatTmp != 0] <- 1
if (max(amatTmp+t(amatTmp)) > 1) stop("dsep: Undirected edge in input graph!")
p <- numNodes(g)
## build node union of a,b,S
if(is.null(john.pairs)) john.pairs <- johnson.all.pairs.sp(g)
nodeUnion <- if(length(S) > 0) c(a,b,S) else c(a,b)
my.nodes <- nodes(g)
## find ancestor graph of nodeUnion
anc.set <- NULL
for (i in seq_len(p)) {
desc.nodes <- my.nodes[which(john.pairs[i,] < Inf)]
if (any(desc.nodes %in% nodeUnion)) anc.set <- c(anc.set,my.nodes[i])
} ## for (i in 1:p)
gS <- subGraph(anc.set,g)
## Moralize in amatM
## !!! in the following line:
## i->j if amat[i,j], i.e. different than default coding !!!
## (*)
amat <- wgtMatrix(gS, transpose = FALSE)
if(all(a0 <- amat == 0))
## if no edge in graph, nodes are d-separated
return( TRUE )
## else :
amat[!a0] <- 1
amatM <- amat
ind <- which(amat == 1,arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
## input is guaranteed to be directed
x <- ind[i,1]
y <- ind[i,2] ## x -> y
## using different coding, see (*) -> OK
allZ <- setdiff(which(amat[y,] == 0 & amat[,y] == 1), x) ## x -> y <- z
for (z in allZ)
if (amat[x,z] == 0 && amat[z,x] == 0)
amatM[x,z] <- 1 ## moralize
} ## for (i in seq_len(nrow(ind)))
## make undirected graph
## (up to now, there is NO undirected edge -> just add t(amat))
gSM <- as(amatM+t(amatM),"graphNEL")
if (length(S) > 0) { ## check separation
separates(a,b,S,gSM)
} else {
b %nin% (if(is.list(bfs. <- bfs(gSM,a))) bfs.[[1]] else bfs.)
}
} ## {dsep}
## Orakel:
dsepTest <- function(x,y, S = NULL, suffStat) {
## suffStat$ g: True graph (graphNEL suffStatect)
## suffStat$jp: johnson all pairs
## Returns "p-value" P =
## 0: keep edge / d-connected
## 1: drop edge / d-separated
if( x == y || x %in% S || y %in% S) {
0
} else {
stopifnot(is(g <- suffStat$g, "graph"))
jp <- suffStat$jp
V <- nodes(g)
## return 0 / 1
as.numeric(dsep(a = V[x], b = V[y], S = V[S], g = g, john.pairs = jp))
}
} ## {dsepTest}
disCItest <- function(x,y,S,suffStat) {
if(is.data.frame(dm <- suffStat$dm)) dm <- data.matrix(dm)
else stopifnot(is.matrix(dm))
nlev <- suffStat$nlev
adaptDF <- suffStat$adaptDF
## p-value:
gSquareDis(x = x, y = y, S = S, dm = dm, nlev = nlev, adaptDF = adaptDF,
verbose = FALSE)
}
binCItest <- function(x,y,S,suffStat) {
if(is.data.frame(dm <- suffStat$dm)) dm <- data.matrix(dm)
else stopifnot(is.matrix(dm))
adaptDF <- suffStat$adaptDF
## p-value:
gSquareBin(x = x, y = y, S = S, dm = dm, adaptDF = adaptDF, verbose = FALSE)
}
hasExtension <- function(amat, amatSkel, x, pa1, pa2.t, pa2.f, type, nl) {
## nl are colnames of amat
## x, pa1, pa2.x: col positions (NULL if not existing)
## type is in c("pdag", "cpdag")
## VALUE: TRUE if amat has extension
if (type == "pdag") {
xNL <- nl[x]
fromXNL <- rep(xNL, length(pa2.f))
toXNL <- rep(xNL, length(pa2.t))
pa2.fNL <- nl[pa2.f]
pa2.tNL <- nl[pa2.t]
tmp <- addBgKnowledge(gInput = amat, x = c(fromXNL, pa2.tNL),
y = c(pa2.fNL, toXNL))
res <- !is.null(tmp) ## TRUE if amat is extendable
} else {
res <- !has.new.coll(amat, amatSkel, x, pa1, pa2.t, pa2.f)
}
res
}
revealEdge <- function(c,d,s) { ## cpdag, dag, selected edges to reveal
if (all(!is.na(s))) { ## something to reveal
for (i in 1:nrow(s)) {
c[s[i,1], s[i,2]] <- d[s[i,1], s[i,2]]
c[s[i,2], s[i,1]] <- d[s[i,2], s[i,1]]
}
}
c
}
ida <- function (x.pos, y.pos, mcov, graphEst, method = c("local", "optimal","global"),
y.notparent = FALSE, verbose = FALSE, all.dags = NA,
type = c("cpdag", "pdag"))
{
method <- match.arg(method)
if(method!="optimal"){
x <- as.integer(x.pos)
y <- as.integer(y.pos)
if(length(x) >= 2){
cat("The methods \"global\" and \"local\" are only implemented for singleton X.")
}
stopifnot(x.pos == x,
y.pos == y,
length(x) == 1,
# length(y) == 1,
type %in% c("pdag", "cpdag"))
} else{
if(y.notparent) {cat("The option y.notparent is not implemented for the optimal method.")}
stopifnot(x.pos == (x <- as.vector(x.pos)),
y.pos == (y <- as.vector(y.pos)),
type %in% c("pdag", "cpdag"),
!(y.notparent))
}
nx <- length(x.pos)
ny <- length(y.pos)
type <- match.arg(type)
amat <- ad.g <- wgtMatrix(graphEst)
amat[which(amat != 0)] <- 1 ## coding: amat.cpdag
## test if valid input amat
if (!isValidGraph(amat = amat, type = type)) {
message("The input graph is not a valid ",type,". See function isValidGraph() for details.\n")
}
if (length(y.pos) > 1 && method!="optimal") { ## call myself for each y in y.pos :
beta.hat <- lapply(y.pos, function(y) ida(x.pos, y, mcov=mcov,
graphEst, method=method, type=type,verbose=verbose))
return(beta.hat)
}
if(method=="optimal"){
if(y.notparent) amat[x, y] <- FALSE
# if (is.element(y.pos, x.pos)) matrix(0, nrow = nx, ncol = length(all.pasets))
## return joint.effects
if(ny==1) {beta.hat <- matrix(unlist(optimal.est(x.pos,y.pos,amat,mcov,verbose)),nrow=nx)}
else{
results <- list()
beta.hat <- list()
result <- optimal.est(x.pos,y.pos,amat,mcov,verbose)
if(is.matrix(result)) {
nsibs <- 1
if(nx==1 && nrow(result)==1){
result <- t(result)
}
for(i in 1:ny){
beta.hat[[i]] <- matrix(unname(result[i,]))
}
} else{
nsibs <- length(lengths(result))
if(nx==1){
for(k in 1:nsibs){
if(nrow(result[[k]])==1){
result[[k]] <- t(result[[k]])}
}
}
for(i in 1:ny){
beta.hat[[i]] <- matrix(,nrow=nx,ncol=nsibs)
for(j in 1:nsibs){
beta.hat[[i]][,j] <- result[[j]][i,]
}
}
}
}
return(beta.hat)
}
nl <- colnames(amat)
stopifnot(!is.null(nl))
amatSkel <- amat + t(amat)
amatSkel[amatSkel != 0] <- 1
if (method == "local") {
wgt.est <- (ad.g != 0)
if (y.notparent) {
wgt.est[x, y] <- FALSE
}
tmp <- wgt.est - t(wgt.est)
tmp[which(tmp < 0)] <- 0
wgt.unique <- tmp
pa1 <- which(wgt.unique[x, ] != 0)
if (y %in% pa1) {
beta.hat <- 0
}
else {
wgt.ambig <- wgt.est - wgt.unique
pa2 <- which(wgt.ambig[x, ] != 0)
if (verbose)
cat("\n\nx=", x, "y=", y, "\npa1=", pa1, "\npa2=",
pa2, "\n")
if (length(pa2) == 0) {
beta.hat <- lm.cov(mcov, y, c(x, pa1))
if (verbose)
cat("Fit - y:", y, "x:", c(x, pa1), "|b.hat=",
beta.hat, "\n")
}
else {
beta.hat <- NA
ii <- 0
pa2.f <- pa2
pa2.t <- NULL
if (hasExtension(amat, amatSkel, x, pa1, pa2.t,
pa2.f, type, nl)) {
ii <- ii + 1
beta.hat[ii] <- lm.cov(mcov, y, c(x, pa1))
if (verbose)
cat("Fit - y:", y, "x:", c(x, pa1), "|b.hat=",
beta.hat[ii], "\n")
}
for (i2 in seq_along(pa2)) {
pa2.f <- pa2[-i2]
pa2.t <- pa2[i2]
if (hasExtension(amat, amatSkel, x, pa1, pa2.t,
pa2.f, type, nl)) {
ii <- ii + 1
if (y %in% pa2.t) {
beta.hat[ii] <- 0
}
else {
beta.hat[ii] <- lm.cov(mcov, y, c(x, pa1,
pa2[i2]))
if (verbose)
cat("Fit - y:", y, "x:", c(x, pa1, pa2[i2]),
"|b.hat=", beta.hat[ii], "\n")
}
}
}
if (length(pa2) > 1)
for (i in 2:length(pa2)) {
pa.tmp <- combn(pa2, i, simplify = TRUE)
for (j in seq_len(ncol(pa.tmp))) {
pa2.t <- pa.tmp[, j]
pa2.f <- setdiff(pa2, pa2.t)
if (hasExtension(amat, amatSkel, x, pa1,
pa2.t, pa2.f, type, nl)) {
ii <- ii + 1
if (y %in% pa2.t) {
beta.hat[ii] <- 0
}
else {
beta.hat[ii] <- lm.cov(mcov, y, c(x,
pa1, pa2.t))
if (verbose)
cat("Fit - y:", y, "x:", c(x, pa1,
pa2.t), "|b.hat=", beta.hat[ii],
"\n")
}
}
}
}
}
}
}
##method global
##should stay the same for pdags
if (method=="global") {
p <- numNodes(graphEst)
am.pdag <- ad.g
am.pdag[am.pdag != 0] <- 1
if (y.notparent) {
am.pdag[x, y] <- 0
}
if (is.na(all.dags)) {
ad <- pdag2allDags(am.pdag)$dags
}
else {
ad <- all.dags
}
n.dags <- nrow(ad)
beta.hat <- rep(NA, n.dags)
for (i in 1:n.dags) {
wgt.unique <- t(matrix(ad[i, ], p, p))
pa1 <- which(wgt.unique[x, ] != 0)
if (y %in% pa1) {
beta.hat[i] <- 0
}
else {
beta.hat[i] <- lm.cov(mcov, y, c(x, pa1))
if (verbose)
cat("Fit - y:", y, "x:", c(x, pa1), "|b.hat=",
beta.hat[i], "\n")
}
}
}
unname(beta.hat)
}
optimal.est <- function (x.pos,y.pos, amat.cpdag, mcov,verbose)
{
## if not working with amat.cpdag type then:
## amat.cpdag <- t(amat.cpdag)
nx <- length(x.pos)
ny <- length(y.pos)
amat.cpdag[which(amat.cpdag != 0)] <- 1 ##just in case make all the non-zero's 1
amat.undir <- amat.cpdag * t(amat.cpdag) ## amat.undir - all undirected edges
## the undirected edge i - j has amat[i,j] = amat[j,i] =1
amat.dir <- amat.cpdag - amat.undir ## amat.dir - all directed edges
pasets.dir <- lapply(x.pos, function(x) which(amat.dir[x,] != 0)) ## find all parents of x.pos in the PDAG
## sibs will be a vector containing all undirected edges connected with x.pos
## if for example: i is in x.pos and i-j is in G
## then add j;i to sibs
sibs <- c()
for (i in 1:nx)
{
tmp.sib <- which(amat.undir[x.pos[i],]!=0) ## tmp.sib contains all siblings of x.pos[i]
if (length(tmp.sib)!=0){ ## if x.pos[i] has a sibling, then add all those sibling edges to sibs
for (j in 1:length(tmp.sib))
{
sibs <- c(sibs,paste(tmp.sib[j],x.pos[i], sep = ";")) ## sibs is a vector of type a;b c;d
## where b and d are in x.pos and b-a d-c are in G
## note that if a,b are in x.pos and a-b is in G
## then both a;b and b;a are in sibs
}
}
}
## if there are no undirected edges connected to x.pos, that is
## if sibs is empty, so return pasets.dir as the only parent set
if (length(sibs)==0){
check <- checkVAS(amat.cpdag,x.pos,y.pos)
beta.hat <- matrix(numeric(ny*nx),nrow=ny)
rownames(beta.hat) <- y.pos
colnames(beta.hat) <- x.pos
if(ny==1 && nx==1){
beta.hat[check[[2]]] <- NA
} else{beta.hat[check[[2]],] <- NA}
if(length(check[[1]])!=0 && verbose){
cat("\n\nWith no added edge orientations:")
cat("\ny =",y.pos[check[[1]]], "is not a descendant of x =",
x.pos,"and hence the partial total effects estimates are",0,"\nWe continue with y =",y.pos[-check[[1]]],".\n")
}
if(length(check[[2]])!=0 && verbose){
cat("\n\nWith no added edge orientations:")
cat("\nNo valid adjustment set exists relative to x =", x.pos," and y =",
y.pos[check[[2]]], " and we continue with y =",y.pos[-check[[3]]], "\n")
}
if(length(check[[3]]) < ny){
if(length(check[[3]])>0){
y.pruned <- y.pos[-check[[3]]]
opt.set <- optAdjSet(amat.cpdag,x.pos,y.pruned)
if(ny==1 && nx==1){
beta.hat[-check[[3]]] <- t(gen.lm.cov(mcov,y.pruned,x.pos,opt.set))
} else{beta.hat[-check[[3]],] <- t(gen.lm.cov(mcov,y.pruned,x.pos,opt.set))}
} else{
opt.set <- optAdjSet(amat.cpdag,x.pos,y.pos)
beta.hat <- t(gen.lm.cov(mcov,y.pos,x.pos,opt.set))
}
}
if (verbose){
if(length(check[[3]]) == ny){opt.set <- numeric()}
cat("\n\nWith no added edge orientations:")
cat("\nThe estimated total effect of y=", y.pos, "on x=",
x.pos,"is thus beta=",beta.hat, "\n")
cat("\n with O=", opt.set,"\n")
}
return(beta.hat)
} else { ## if sibs is not empty, find all possible joint parent sets
beta.hat <- list() ## this is the object we return, containing a list of all possible total effect estimates
count <- 1 ## this counter will contain the current number (+1) of valid joint parent sets
## first check the no additional parents option
## meaning that it is possible to orient all sibling edges out of x.pos
toAdd <- makeBgKnowledge(sibs)
## require that no two nodes in x.pos are siblings
if (length(intersect(x.pos,toAdd$x))==0){
## try to orient everything out of x.pos
amat.amenable <- addBgKnowledge(amat.cpdag,x=toAdd$y,y=toAdd$x,checkInput = FALSE)
if (!is.null(amat.amenable)){
## if it is possible to orient everyting out of x.pos add the corresponding optimal set to valid optimal sets
check <- checkVAS(amat.amenable,x.pos,y.pos)
beta.hat[[count]] <- matrix(numeric(ny*nx),nrow=ny)
rownames(beta.hat[[count]]) <- y.pos
colnames(beta.hat[[count]]) <- x.pos
if(ny==1 && nx==1){
beta.hat[[count]][check[[2]]] <- NA
} else{beta.hat[[count]][check[[2]],] <- NA}
if(length(check[[1]])!=0 && verbose){
cat("\n\n With added edge orientations: \n")
print(rbind(addFromThis=toAdd$y,addToThis=toAdd$x))
cat("\ny =",y.pos[check[[1]]], "is not a descendant of x =",
x.pos,"and hence the respective partial joint total effect estimates are",0,".\n")
}
if(length(check[[2]])!=0 && verbose){
cat("\n\n With added edge orientations: \n")
print(rbind(addFromThis=toAdd$y,addToThis=toAdd$x))
cat("\nNo valid adjustment set exists relative to x =", x.pos," and y =",
y.pos[check[[2]]],".\n")
}
if(length(check[[3]]) < ny){
if(length(check[[3]])>0){
y.pruned <- y.pos[-check[[3]]]
opt.set <- optAdjSet(amat.amenable,x.pos,y.pruned)
if(ny==1 && nx==1){
beta.hat[[count]][-check[[3]]] <- t(gen.lm.cov(mcov,y.pruned,x.pos,opt.set))
} else{beta.hat[[count]][-check[[3]],] <- t(gen.lm.cov(mcov,y.pruned,x.pos,opt.set))}
} else{
opt.set <- optAdjSet(amat.amenable,x.pos,y.pos)
beta.hat[[count]] <- t(gen.lm.cov(mcov,y.pos,x.pos,opt.set))
}
}
if (verbose){
if(length(check[[3]]) == ny){opt.set <- numeric()}
cat("\n\nWith added edge orientations: \n")
print(rbind(addFromThis=toAdd$y,addToThis=toAdd$x))
cat("\nThe estimated total effect of y=", y.pos, "on x=",
x.pos,"is beta=",beta.hat[[count]], "\n")
cat("\n with O=", opt.set,"\n")
}
count <- count + 1
}
}
}
## now for all subsets of possible parents hat is
## all possible subsets of sibs union pasets.dir
## check if they work
size <- length(sibs)
for (k in 1:size)
{
possPa <- combn(sibs,k) ## form all combinations of sibs of size k
for (r in 1:length(possPa[1,]))
{
s <- possPa[,r] ## get one subset of sibs which we will try to orient into x.pos
toAdd1 <- makeBgKnowledge(s) ## transform it from sibs format: a;b c;d into bgKnowledge format that is
## into a data.frame with x=c(a,c) y=c(b,d) so that a -> b, c-> d is bgKnowledge
sbar <- setdiff(sibs,s) ## the complement of our subset s should be oriented out of x.pos
toAdd2 <- makeBgKnowledge(sbar)
## the following 2 lines define the bg Knowledge that we try to add
addFromThis <- c(toAdd1$x,toAdd2$y)
addToThis <- c(toAdd1$y,toAdd2$x)
## only try to add this bg knowledge if its consistent within itself
## meaning if it does not contain contradictory edges
## for example addFromThis =c(1,2) addToThis = c(2,1)
check2 <- FALSE ## if check is true it will indicate that the background knowledge contradicts itself
for (i in 1: length(addFromThis)){
if (addToThis[i] %in% addFromThis[which(addToThis == addFromThis[i])]){# %in% addToThis)]){
check2 <- TRUE
}
}
if (!check2){ ##only try to add background knowledge that does not contradict itself
amat.amenable <- addBgKnowledge(amat.cpdag,x=addFromThis,y=addToThis)
if (!is.null(amat.amenable)){
check <- checkVAS(amat.amenable,x.pos,y.pos)
beta.hat[[count]] <- matrix(numeric(ny*nx),nrow=ny)
rownames(beta.hat[[count]]) <- y.pos
colnames(beta.hat[[count]]) <- x.pos
if(ny==1 && nx==1){
beta.hat[[count]][check[[2]]] <- NA
} else{beta.hat[[count]][check[[2]],] <- NA}
if(length(check[[1]])!=0 && verbose){
cat("\n\n With added edge orientations: \n")
print(rbind(addFromThis,addToThis))
cat("\ny =",y.pos[check[[1]]], "is not a descendant of x =",
x.pos,"and hence the partial total effects estimates are",0,".\n")
}
if(length(check[[2]])!=0 && verbose){
cat("\n\n With added edge orientations: \n")
print(rbind(addFromThis,addToThis))
cat("\nNo valid adjustment set exists relative to x =", x.pos," and y =",
y.pos[check[[2]]], ".\n")
}
if(length(check[[3]]) < ny){
if(length(check[[3]])>0){
y.pruned <- y.pos[-check[[3]]]
opt.set <- optAdjSet(amat.amenable,x.pos,y.pruned)
if(ny==1 && nx==1){
beta.hat[[count]][-check[[3]]] <- t(gen.lm.cov(mcov,y.pruned,x.pos,opt.set))
} else{beta.hat[[count]][-check[[3]],] <- t(gen.lm.cov(mcov,y.pruned,x.pos,opt.set))}
} else{
opt.set <- optAdjSet(amat.amenable,x.pos,y.pos)
beta.hat[[count]] <- t(gen.lm.cov(mcov,y.pos,x.pos,opt.set))
}
}
if (verbose){
if(length(check[[3]]) == ny){opt.set <- numeric()}
cat("\n\nWith added edge orientations: \n")
print(rbind(addFromThis,addToThis))
cat("\nThe estimated total effect of x=", x.pos, "on y=",
y.pos,"is beta=",beta.hat[[count]], "\n")
cat("with O=", opt.set,"\n")
}
count <- count + 1
}
}
}
}
return(beta.hat)
}
## the following functions takes character vector s of type s=c("1;2","3;4")
## and transforms it into a data frame containing vectors x=c(1,3) and y=c(2,4)
## so that one can add x -> y (that is 1 -> 2, 3 -> 4) as bg knowledge easier
makeBgKnowledge <- function(s)
{
x <- y <- c()
if (length(s)==0){ ## if s is empty, return empty vectors
df.final <- data.frame(x=x, y=y)
return(df.final)
} else { ## otherwise transform the charactor vector s into a
## bg knowledge data frame
for (i in 1:length(s))
{
addFromTo <- as.numeric(unlist(strsplit(x = s[i],split = ";")))
x <- c(x,addFromTo[1])
y <- c(y,addFromTo[2])
}
df.final <- data.frame(x=x, y=y)
return(df.final)
}
}
checkVAS <- function(m,x.pos,y.pos){
possDeX <- unlist(lapply(x.pos,possDe,m=m,y=c(),type="pdag"))
noDescY <- unlist(lapply(y.pos, function(y) length(intersect(y,possDeX))))
a <- which(noDescY==0)
if(length(a)>0){
y.pruned <- y.pos[-a]
} else{y.pruned <- y.pos}
noVAS <- unlist(lapply(y.pruned, function(y) length(intersect(x.pos,forb(m,x.pos,y)))))
b <- which(noDescY!=0)[which(noVAS!=0)]
c <- union(a,b)
return(list(a,b,c))
}
forb <- function(m, x, y){
possDeX <- unlist(lapply(x,possDe,m=m,y=c(),type="pdag"))
possAnY <- unlist(lapply(y,possAn,m=m,
y=x,type="pdag"))
cn <- intersect(possAnY,possDeX)
forb <- unlist(lapply(cn,possDe,m=m,y=c(),type="pdag"))
return(forb)
}
# generalization of lmvoc to make usable for non-singleton X
gen.lm.cov <- function(C,y,x,z=NULL){
w <- union(x,z)
solve(C[w, w], C[w, y, drop = FALSE])[1:length(x), ]
}
idaFast <- function(x.pos, y.pos.set, mcov, graphEst)
{
## Purpose: Estimate the causal effect of x on each element in the
## set y using the local method; graphEst and correlation matrix
## have to be precomputed; orient
## undirected edges at x in a way so that no new collider is
## introduced; if there is an undirected edge between x and y, both directions are considered;
## i.e., y might be partent of x in which case the effect is 0.
## ----------------------------------------------------------------------
## Arguments:
## - x.pos, y.pos: Column of x and y in d.mat
## - mcov: Covariance matrix that was used to estimate graphEst
## - graphEst: Fit of PC Algorithm (semidirected)
## ----------------------------------------------------------------------
## Value: list of causal values; one list element for each element of
## y.pos.set
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 7 Jan 2010, 11:18
## prepare adjMatrix and skeleton
amat <- ad.g <- wgtMatrix(graphEst)
amat[which(amat != 0)] <- 1 ## i->j if amat[j,i]==1
amatSkel <- amat + t(amat)
amatSkel[amatSkel != 0] <- 1
## find unique and ambiguous parents of x
wgt.est <- (ad.g != 0)
tmp <- wgt.est-t(wgt.est)
tmp[which(tmp < 0)] <- 0
wgt.unique <- tmp
wgt.ambig <- wgt.est-wgt.unique
pa1 <- which(wgt.unique[x.pos,] != 0)
pa2 <- which(wgt.ambig[x.pos,] != 0)
## estimate beta
if (length(pa2) == 0) {
beta.tmp <- lm.cov(mcov,y.pos.set,c(x.pos,pa1)) ####
beta.tmp[y.pos.set %in% pa1] <- 0
beta.hat <- cbind(beta.tmp)
} else { ## at least one undirected parent
## no member of pa2
pa2.f <- pa2
pa2.t <- NA
beta.hat <-
if (!has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) {
beta.tmp <- lm.cov(mcov,y.pos.set,c(x.pos,pa1)) ####
beta.tmp[y.pos.set %in% pa1] <- 0
cbind(beta.tmp)
} # else NULL
## exactly one member of pa2
for (i2 in seq_along(pa2)) {
pa2.f <- pa2[-i2]
pa2.t <- pa2[i2]
if (!has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) {
beta.tmp <- lm.cov(mcov,y.pos.set,c(x.pos,pa1,pa2.t)) ####
beta.tmp[y.pos.set %in% c(pa1,pa2.t)] <- 0
beta.hat <- cbind(beta.hat, beta.tmp)
}
} ## for (i2 in seq_along(pa2))
## higher order subsets of pa2
if (length(pa2) > 1)
for (i in 2:length(pa2)) {
pa.tmp <- combn(pa2,i,simplify = TRUE)
for (j in seq_len(ncol(pa.tmp))) {
pa2.t <- pa.tmp[,j]
pa2.f <- setdiff(pa2, pa2.t)
if (!has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) {
beta.tmp <- lm.cov(mcov,y.pos.set,c(x.pos,pa1,pa2.t)) ####
beta.tmp[y.pos.set %in% c(pa1,pa2.t)] <- 0
beta.hat <- cbind(beta.hat, beta.tmp)
}
} ## for (j )
} ## for (i )
} ## if .. else length(pa2) > 0)
## MM: for now, maybe in the future get sensible column names:
colnames(beta.hat) <- NULL
if (nrow(beta.hat) > 0) rownames(beta.hat) <- as.character(y.pos.set)
beta.hat
}
## -> ../man/legal.path.Rd
## only called in qreach() with only 'c' varying
legal.path <- function(a,b,c, amat)
{
## Purpose: Is path a-b-c legal (either collider in b or a,b,c is triangle)
## !! a-b-c must be in a path !! this is not checked !!
## ----------------------------------------------------------------------
## Arguments:
## - a, b, c: nodes
## - amat: adj matrix (coding 0,1,2 for no edge, circle, arrowhead)
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 29 Oct 2009; Martin Maechler
if(a == c || (a.b <- amat[a,b]) == 0 || amat[b,c] == 0)
return(FALSE)
## else a != c and amat[a,b] != 0 and amat[b,c] != 0
## return TRUE iff
(amat[a,c] != 0 || ## triangle
## need not check [c,a], since there must be SOME edgemark !=0 at [a,c], if
## edge is present
(a.b == 2 && amat[c,b] == 2)) ## a collider
}
##' Plot a subgraph for a specified starting node and a given graph
##' @param graphObj Graph object
##' @param y Starting node
##' @param dist Distance of nodes included in subgraph from starting node y
##' @param amat Adjacency matrix of skeleton graph (optional)
##' @param directed should the plotted subgraph be directed?
##' @param main
##' --------------- see ../man/plotSG.Rd
plotSG <- function(graphObj, y, dist, amat = NA, directed = TRUE,
plot = requireNamespace("Rgraphviz"),
main = paste("Subgraph of", deparse(substitute(graphObj)),
"from ", y, " with dist <=", dist),
cex.main = 1.25, font.main = par("font.main"), col.main=par("col.main"),
...)
{
## Author: Daniel Stekhoven, Date: 26 Jan 2010; MM: tweaks
stopifnot(dist >= 1)
## Extract adjacency matrix (if necessary)
if (any( is.na(amat)))
amat <- wgtMatrix(graphObj)
## Diagonalise (has no effect if already diagonal)
amat[amat != 0] <- 1
amat <- amat + t(amat)
diag(amat) <- 0 # can that happen anyway??
amat[amat == 2] <- 1
## Find connected nodes hierarchically
nh <- which( amat[y,] == 1 )
rel.nodes <- c( y, nh )
for (i in seq_len(dist-1L)) {
nh <-
if ( length(nh) == 1 )
which( amat[nh,] == 1 )
else if (length(nh) != 0)
which(amat[nh,] == 1, arr.ind = TRUE)[,"col"]
## else NULL
rel.nodes <- unique( c( rel.nodes, nh ) )
}
## Name nodes
if(is(graphObj, "graphNEL"))
names(rel.nodes) <- graphObj@nodes[rel.nodes]
## subgraph - distinguish between directed edges or not
sg <- if (directed)
subGraph(as.character(rel.nodes), graphObj)
else
as(amat[rel.nodes, rel.nodes], "graphNEL")
## Plot subgraph
if(plot) {
if(requireNamespace("Rgraphviz")) {
## FIXME: use "new Rgraphvis interface: layoutGraph(), renderGraph() [includes title!]
Rgraphviz::plot(sg, ...) ## TODO: leave room for title
if(!is.null(main))
title(main = main, cex.main=cex.main, font.main=font.main, col.main=col.main)
} else check.Rgraphviz() # error!
invisible(sg)
}
else sg
}
##########################################################################
##
## Functions for the conservative versions (PC, FCI (all), and RFCI)
##
#########################################################################
## Functions used by all algorithms
##########################################################
pc.cons.intern <- function(sk, suffStat, indepTest, alpha,
version.unf = c(NA,NA), maj.rule = FALSE, verbose = FALSE)
{
## Purpose: For any unshielded triple A-B-C, consider all subsets D of
## the neighbors of A and of the neighbors of C, and record the sets
## D for which A and C are conditionally independent given D. If B
## is in none of these sets, do nothing (it is a
## v-structure) and also delete B from sepset(A,C) if present (so we are
## sure that a v-structure will be created). If B is in all sets, do nothing
## (it is not a v-structure) and also add B to sepset(A,C) if not present
## (so we are sure that a v-structure will not be created). If maj.rule=FALSE
## the normal conservative version is applied, hence if B is in
## some but not all sets, mark the triple as "ambiguous". If maj.rule=TRUE
## we mark the triple as "ambiguous" if B is in exactly 50% of the cases,
## if less than 50% define it as a v-structure, and if in more than 50%
## no v-structure.
## ----------------------------------------------------------------------
## Arguments: - sk: output returned by function "skeleton"
## - suffStat: Sufficient statistics for independent tests
## - indepTest: Function for independence test
## - alpha: Significance level of test
## - version.unf[1]: 1 it checks if b is in some sepsets,
## 2 it also checks if there exists a sepset
## which is a subset of the neighbours.
## - version.unf[2]: 1 same as in Tetrad (do not consider
## the initial sepset), 2 it also considers
## the initial sepset
## - maj.rule: FALSE/TRUE if the majority rule idea is applied
## ----------------------------------------------------------------------
## Value: - unfTripl: Triple that were marked as unfaithful
## - vers: vector containing the version (1 or 2) of the
## corresponding triple saved in unfTripl (1=normal
## unfaithful triple that is B is in some sepsets;
## 2=triple coming from version.unf[1]==2
## that is a and c are indep given the initial sepset
## but there doesn't exist a subset of the neighbours
## that d-separates them)
## - sk: updated skelet object, sepsets might have been updated
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 12 Feb 2010, 10:43
## Modifications: Diego Colombo
g <- as(sk@graph,"matrix")
stopifnot(all(g == t(g))) ## g is guaranteed to be symmetric
p <- as.numeric(dim(g)[1])
unfTripl <- vers <- rep(NA,min(p*p,100000))
counter <- 0
if (sum(g) > 0) {
ind <- which(g == 1, arr.ind = TRUE)
tripleMatrix <- NULL
## Go through all edges
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
allC <- setdiff(which(g[b,] == 1),a) ## a-b-c
newC <- allC[g[a,allC] == 0]
tmpMatrix <- cbind(rep(a,length(newC)),rep(b,length(newC)),newC)
tripleMatrix <- rbind(tripleMatrix,tmpMatrix)
colnames(tripleMatrix) <- c("","","")
}
if ((m <- nrow(tripleMatrix)) > 0) {
deleteDupl <- logical(m)# all FALSE
for (i in seq_len(m))
if (tripleMatrix[i,1] > tripleMatrix[i,3])
deleteDupl[i] <- TRUE
if(any(deleteDupl))
tripleMatrix <- tripleMatrix[!deleteDupl,, drop = FALSE]
for (i in seq_len(nrow(tripleMatrix))) {
## pay attention to the size of counter
if (counter+1L == length(unfTripl)) {
n.xtra <- min(p*p, 100000)
new.len <- counter+1L + n.xtra
length(unfTripl) <- new.len
length(vers) <- new.len
}
a <- tripleMatrix[i,1]
b <- tripleMatrix[i,2]
c <- tripleMatrix[i,3]
nbrsA <- which(g[,a] != 0) ## G symm; c no nbr of a
nbrsC <- which(g[,c] != 0)
if (verbose) {
cat("\nTriple:", a,b,c,"and sepset by skelet:",
unique(sk@sepset[[a]][[c]],sk@sepset[[c]][[a]]),"\n")
}
r.abc <- checkTriple(a, b, c, nbrsA, nbrsC,
sk@sepset[[a]][[c]], sk@sepset[[c]][[a]],
suffStat = suffStat, indepTest = indepTest, alpha = alpha,
version.unf = version.unf, maj.rule = maj.rule, verbose = verbose)
## 1: in NO set; 2: in ALL sets; 3: in SOME but not all
## Take action only if case "3"
if (r.abc$decision == 3) {
## record ambiguous triple
counter <- counter + 1
unfTripl[counter] <- triple2numb(p,a,b,c)
vers[counter] <- r.abc$version
}
## can happen the case in Tetrad, so we must save the triple
## as ambiguous:
## a and c independent given S but not given subsets of the
## adj(a) or adj(c)
if ((version.unf[1] == 2) && (r.abc$version == 2) && (r.abc$decision != 3)) {
counter <- counter + 1
unfTripl[counter] <- triple2numb(p,a,b,c)
vers[counter] <- r.abc$version
}
sk@sepset[[a]][[c]] <- r.abc$SepsetA
sk@sepset[[c]][[a]] <- r.abc$SepsetC
}
}
}
length(unfTripl) <- length(vers) <- counter
list(unfTripl = unfTripl, vers = vers, sk = sk)
}
## Called both from pc.cons.intern() and rfci.vStruc() :
checkTriple <- function(a, b, c, nbrsA, nbrsC, sepsetA, sepsetC,
suffStat, indepTest, alpha, version.unf = c(NA,NA),
maj.rule = FALSE, verbose = FALSE)
{
## Purpose: For each subset of nbrsA and nbrsC where a and c are cond.
## independent, it is checked if b is in the conditioning set.
## ----------------------------------------------------------------------
## Arguments: - a,b,c: Nodes (positions in adjacency matrix)
## - nbrsA: Neighbors of a
## - nbrsC: Neighbors of c
## - sepsetA: sepset(a,c)
## - sepsetC: sepset(c,a)
## - suffStat: Sufficient statistics for independent tests
## - indepTest: Function for independence test
## - alpha: Significance level of test
## - version.unf[1]: 1 it checks if b is in some sepsets,
## 2 it also checks if there exists a sepset
## which is a subset of the neighbours.
## - version.unf[2]: 1 same as Tetrad (do not consider the initial
## sepset), 2 consider if b is in sepsetA
## or sepsetC
## - maj.rule: FALSE/TRUE if the majority rule idea is applied
## ----------------------------------------------------------------------
## Value: - decision: res
## res = 1: b is in NO sepset (-> v-structure)
## res = 2: b is in ALL sepsets (-> no v-structure)
## res = 3: b is in SOME but not all sepsets (-> ambiguous triple)
## - version: version (1 or 2) of the ambiguous triple
## (1=normal ambiguous triple that is b is in some sepsets;
## 2=triple coming from version.unf[1]==2 that is a and c are
## indep given the initial sepset but there doesn't exist a
## subset of the neighbours that d-separates them)
## - sepsetA and sepsetC: updated separation sets
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 12 Feb 2010, 12:13
## Modifications: Diego Colombo, Martin Maechler
## loop through all subsets of parents
nr.indep <- 0
stopifnot(length(version.unf) == 2, version.unf %in% 1:2)
## Tetrad
tmp <- if (version.unf[2] == 2) ## our version
(b %in% sepsetA || b %in% sepsetC) ## else NULL = Tetrad version
version <- 0
## start with the neighbours of a
if ((nn <- length(nbrsA)) > 0) {
allComb <- expand.grid(lapply(integer(nn), function(.) 0:1))
## loop through all subsets of neighbours
for (i in 1:nrow(allComb)) { ## == 1:(2^nn)
S <- nbrsA[which(allComb[i,] != 0)]
pval <- indepTest(a, c, S, suffStat)
## save the pval and the set that produced this pval
if (verbose) cat("a: S =",S," - pval =",pval,"\n")
if (pval >= alpha) {
nr.indep <- nr.indep + 1
## is b in set?
tmp <- c(tmp, b %in% S)
version <- 1
}
}
}
## now with the neighbours of c
if ((nn <- length(nbrsC)) > 0) {
allComb <- expand.grid(lapply(integer(nn), function(.) 0:1))
## loop through all subsets of neighbours
for (i in 1:nrow(allComb)) { ## == 1:(2^nn)
S <- nbrsC[which(allComb[i,] != 0)]
pval <- indepTest(a, c, S, suffStat)
## save the pval and the set that produced this pval
if (verbose) cat("c: S =",S," - pval =",pval,"\n")
if (pval >= alpha) {
nr.indep <- nr.indep + 1
## is b in set?
tmp <- c(tmp, b %in% S)
version <- 1
}
}
}
if (version.unf[1] == 2 && nr.indep == 0) {
version <- 2
}
if (is.null(tmp)) tmp <- FALSE
if (all(tmp)) {
res <- 2 ## in ALL sets
## therefore a - b - c is not a v-structure, hence add b to sepset(a,c)
## and sepset(c,a)
## for example it can happen that b is not in sepset(a,c) or sepset(c,a)
## but now it is in each set that separates a and c given the neighbours
if (b %nin% sepsetA) sepsetA <- c(sepsetA, b)
if (b %nin% sepsetC) sepsetC <- c(sepsetC, b)
} else {
if (all(!tmp)) {
res <- 1 ## in NO set
## therefore a - b - c is a v-structure, hence delete b from
## sepset(a,c) and sepset(c,a)
## for example it can happen that b is in sepset(a,c) or sepset(c,a)
## but now it is in no set that separates a and c given the neighbours
sepsetA <- setdiff(sepsetA,b)
sepsetC <- setdiff(sepsetC,b)
} else {
## normal conservative PC, b is in some sets hence the triple
## is unfaithful
if (!maj.rule) {
res <- 3 ## in SOME sets
} else {
## use the majority rule to test if the triple is faithful
## or not and then decide if it is a v-structure or not accordigly
## NEW check the percentage of b in the conditioning sets that
## make a and c independent
if (sum(tmp)/length(tmp) < 0.5) {
## we accept that b is in NO set
res <- 1 ## in NO set
## therefore a - b - c is a v-structure, hence delete b
## from sepset(a,c) and sepset(c,a)
## for example it can happen that b is in sepset(a,c) or
## sepset(c,a) but now it is in no set that
## separates a and c given the neighbours
sepsetA <- setdiff(sepsetA,b)
sepsetC <- setdiff(sepsetC,b)
} else if (sum(tmp)/length(tmp) > 0.5) {
## we accept that b is in ALL set
res <- 2 ## in ALL sets
## therefore a - b - c is not a v-structure, hence add b
## to sepset(a,c) and sepset(c,a)
## for example it can happen that b is not in sepset(a,c)
## or sepset(c,a) but now it is in each set that
## separates a and c given the neighbours
if (b %nin% sepsetA) sepsetA <- c(sepsetA,b)
if (b %nin% sepsetC) sepsetC <- c(sepsetC,b)
} else if (sum(tmp)/length(tmp) == 0.5) {
## define the triple as unfaithful, because half of the
## times b is in the set and half of them in not in
res <- 3 ## in SOME sets
}
}
}
}
if (verbose && res == 3) cat("Triple ambiguous\n")
## if you save a variable <- NULL into a list it will delete this element!
## The following also transforms NULL sepset* to integer(0):
lapply(list(decision = res, version = version, SepsetA = sepsetA, SepsetC = sepsetC),
as.integer)
} ## {checkTriple}
## For R5 and R9-R10
######################################################
faith.check <- function(cp, unfVect, p, boolean = TRUE)
{
## Purpose: check if every triple on the circle path cp is unambiguous
## ----------------------------------------------------------------------
## Arguments: cp: circle path to check for unambiguity
## boolean: if TRUE, return TRUE iff there is no ambiguity, i.e. "faithful"
## if FALSE, return the number of ambiguities.
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 25 May 2010; 'boolean' etc by Martin Maechler
if(!boolean) res <- 0L
n <- length(cp)
## MM: FIXME speedup by precomputing (l%%n)+1, ((l+1)%%n)+1, and ((l+2)%%n)+1 as *integers*
## ok, in steps: first "slowly" but surely correct
ii <- 0:(n-1L)
i1 <- (ii %% n)+1L
i2 <- ((ii+1L) %% n)+1L
i3 <- ((ii+2L) %% n)+1L
for (l in ii) {
if (any(unfVect == triple2numb(p,cp[i1[l]],cp[i2[l]],cp[i3[l]]), na.rm = TRUE) ||
any(unfVect == triple2numb(p,cp[i3[l]],cp[i2[l]],cp[i1[l]]), na.rm = TRUE)) {
if(boolean) return(FALSE) # the first time we found one: not faithful
## else count
res <- res + 1L
}
}
if(boolean) TRUE else res
}
###############################################################################
##
## FCI, RFCI, and fast FCI-oracle
##
###############################################################################
## Internal function used by FCI and RFCI
##############################################################################
triple2numb <- function(p,i,j,k)
{
## Purpose: transform a triple i-j-k into a unique number
## ----------------------------------------------------------------------
## Arguments:-p:number of nodes;-triple: i-j-k
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 11 May 2010; Martin Maechler
## as.numeric(.): not integer arithmetic which easily overflows
k + (p. <- as.numeric(p)) * (j + p.*i)
}
## Functions for R4, R5, and R9-R10 for FCI(all) and RFCI
############################################################################
updateList <- function(path, set, old.list)
{
## Purpose: update the list of all paths in the iterative functions
## minDiscrPath, minUncovCircPath and minUncovPdPath
## ----------------------------------------------------------------------
## Arguments: - path: the path under investigation
## - set: (integer) index set of variables to be added to path
## - old.list: the list to update
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 21 Oct 2011; Without for() by Martin Maechler
c(old.list, lapply(set, function(s) c(path,s)))
}
## R9-R10
minUncovPdPath <- function(p, pag, a,b,c, unfVect, verbose = FALSE)
{
## Purpose: find a minimal uncovered pd path for a,b,c saved in path.
## Check also for the conservative case that it is unambiguous
## If a path exists this is the output, otherwise NA
## ----------------------------------------------------------------------
## Arguments: - p: number of nodes in the graph
## - pag: adjacency matrix
## - a,b,c : nodes under interest
## - unfVect: vector containing the ambiguous triples
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 19 Oct 2011; small changes: Martin Maechler, Joris Mooij
## first check whether a,b,c is already a upd path
stopifnot( (pag[a,b] == 1 | pag[a,b] == 2) &
(pag[b,a] == 1 | pag[b,a] == 3) )
min.upd.path <- NA
done <- FALSE
if( (pag[b,c] == 1 | pag[b,c] == 2) &
(pag[c,b] == 1 | pag[c,b] == 3) &
(pag[c,a] == 0) ) {
mpath = c(a,b,c)
if (length(unfVect) == 0 || ## <<- normal version: just save
## conservative version, check the path to be faithful:
faith.check(mpath, unfVect, p)) {
## save the path to be returned
min.upd.path <- mpath
if( verbose )
cat(' minUncovPdPath: path found: ',mpath,', uncovered: ',TRUE,'\n')
done <- TRUE
}
}
## now check paths of 4 or more nodes of the form <a,b,...,c>
if( !done ) {
visited <- rep(FALSE, p)
visited[c(a,b,c)] <- TRUE
min.upd.path <- NA
## find all neighbours of b not visited yet
indD <- which((pag[b,] == 1 | pag[b,] == 2) &
(pag[,b] == 1 | pag[,b] == 3) &
(pag[,a] == 0) & !visited)
if (length(indD) > 0) {
path.list <- updateList(b, indD, NULL)
done <- FALSE
while ((length(path.list) > 0) && (!done)) {
## next element in the queue
mpath <- path.list[[1]]
m <- length(mpath)
d <- mpath[m]
path.list[[1]] <- NULL
visited[d] <- TRUE
if (any(pag[d,c] == 1:2) && any(pag[c,d] == c(1,3))) {
## pd path found
mpath <- c(a, mpath, c)
n <- length(mpath)
## check the path to be uncovered
uncov <- TRUE
for (l in seq_len(n - 2)) {
if (!(pag[mpath[l], mpath[l + 2]] == 0 &&
pag[mpath[l + 2], mpath[l]] == 0)) {
uncov <- FALSE
break ## speed up!
}
}
if( verbose )
cat(' minUncovPdPath: path found: ',mpath,', uncovered: ',uncov,'\n')
## if it is uncovered
if (uncov)
if (length(unfVect) == 0 || ## <<- normal version: just save
## conservative version, check the path to be faithful:
faith.check(mpath, unfVect, p)) {
## save the path to be returned
min.upd.path <- mpath
done <- TRUE
}
}
else {
## d and c are either not connected or connected with a "wrong" edge -----> search iteratively
## find all neighbours of d not visited yet
indR <- which((pag[d,] == 1 | pag[d,] == 2) &
(pag[,d] == 1 | pag[,d] == 3) & !visited)
if (length(indR) > 0) {
## update the queues
path.list <- updateList(mpath, indR, path.list)
}
}
} ## {while}
}
}
min.upd.path
} ## {minUncovPdPath}
## R5
minUncovCircPath <- function(p, pag, path, unfVect, verbose = FALSE)
{
## Purpose: find a minimal uncovered circle path for a,c,d,b saved in path.
## Check also for the conservative case that it is unambiguous
## If a path exists this is the output, otherwise NA
## ----------------------------------------------------------------------
## Arguments: - p: number of nodes in the graph
## - pag: adjacency matrix
## - path: a,c,d,b under interest
## - unfVect: vector containing the unfaithful triples
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 19 Oct 2011, 13:11
visited <- rep(FALSE, p)
visited[path] <- TRUE # (a,b,c,d) all 'visited'
a <- path[1]
c <- path[2]
d <- path[3]
b <- path[4]
min.ucp.path <- NA
## find all neighbours of c not visited yet
indX <- which(pag[c,] == 1 & pag[,c] == 1 & !visited) ## c o-o x
if (length(indX) > 0) {
path.list <- updateList(c, indX, NULL)
done <- FALSE
while (!done && length(path.list) > 0) {
## next element in the queue
mpath <- path.list[[1]]
x <- mpath[length(mpath)]
path.list[[1]] <- NULL
visited[x] <- TRUE
if (pag[x,d] == 1 && pag[d,x] == 1) {
## circle path found
mpath <- c(a, mpath, d, b)
n <- length(mpath)
## check the path to be uncovered
uncov <- TRUE
for (l in seq_len(n - 2)) {
if (!(pag[mpath[l], mpath[l + 2]] == 0 &&
pag[mpath[l + 2], mpath[l]] == 0)) {
uncov <- FALSE
break ## speed up!
}
}
## if it is uncovered
if (uncov)
if (length(unfVect) == 0 || ## <<- normal version: just save
## conservative version, check the path to be faithful:
faith.check(mpath, unfVect, p)) {
## save the path to be returned
min.ucp.path <- mpath
done <- TRUE
}
}
else {
## x and d are either not connected or connected with an edge which is not o--o -----> search iteratively
## find all neighbours of x not visited yet
indR <- which(pag[x,] == 1 & pag[,x] == 1 & !visited) ## x o--o r
if (length(indR) > 0) {
## update the queues
path.list <- updateList(mpath, indR, path.list)
}
}
}## {while}
}
return(min.ucp.path)
}
## R4
minDiscrPath <- function(pag, a,b,c, verbose = FALSE)
{
## Purpose: find a minimal discriminating path for a,b,c.
## If a path exists this is the output, otherwise NA
## ----------------------------------------------------------------------
## Arguments: - pag: adjacency matrix
## - a,b,c: node positions under interest
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 25 Jan 2011; speedup: Martin Maechler
p <- as.numeric(dim(pag)[1])
visited <- rep(FALSE, p)
visited[c(a,b,c)] <- TRUE # {a,b,c} "visited"
## find all neighbours of a not visited yet
indD <- which(pag[a,] != 0 & pag[,a] == 2 & !visited) ## d *-> a
if (length(indD) > 0) {
path.list <- updateList(a, indD, NULL)
while (length(path.list) > 0) {
## next element in the queue
mpath <- path.list[[1]]
m <- length(mpath)
d <- mpath[m]
if (pag[c,d] == 0 & pag[d,c] == 0)
## minimal discriminating path found :
return( c(rev(mpath), b,c) )
## else :
pred <- mpath[m-1]
path.list[[1]] <- NULL
## d is connected to c -----> search iteratively
if (pag[d,c] == 2 && pag[c,d] == 3 && pag[pred,d] == 2) {
visited[d] <- TRUE
## find all neighbours of d not visited yet
indR <- which(pag[d,] != 0 & pag[,d] == 2 & !visited) ## r *-> d
if (length(indR) > 0)
## update the queues
path.list <- updateList(mpath[-1], indR, path.list)
}
} ## {while}
}
## nothing found: return
NA
} ## {minDiscrPath}
###############################################################################
## FCI
###############################################################################
# fci <- function(suffStat, indepTest, alpha, labels, p,
# skel.method = c("stable", "original", "stable.fast"),
# type = c("normal", "anytime", "adaptive"),
# fixedGaps = NULL, fixedEdges = NULL, NAdelete = TRUE,
# m.max = Inf, pdsep.max = Inf, rules = rep(TRUE, 10),
# doPdsep = TRUE, biCC = FALSE, conservative = FALSE,
# maj.rule = FALSE, numCores = 1, verbose = FALSE)
# {
# ## Purpose: Perform FCI-Algorithm, i.e., estimate PAG
# ## ----------------------------------------------------------------------
# ## Arguments:
# ## - suffStat, indepTest: info for the tests
# ## - p: number of nodes in the graph
# ## - alpha: Significance level of individual partial correlation tests
# ## - verbose: 0 - no output, 1 - detailed output
# ## - fixedGaps: the adjacency matrix of the graph from which the algorithm
# ## should start (logical); gaps fixed here are not changed
# ## - fixedEdges: Edges marked here are not changed (logical)
# ## - NAdelete: delete edge if pval=NA (for discrete data)
# ## - m.max: maximum size of conditioning set
# ## - pdsep.max: maximaum size of conditioning set for Possible-D-SEP
# ## - rules: array of length 10 wich contains TRUE or FALSE corresponding
# ## to each rule. TRUE means the rule will be applied.
# ## If rules==FALSE only R0 (minimal pattern) will be used
# ## - doPdsep: compute possible dsep
# ## - biCC: TRUE or FALSE variable containing if biconnected components are
# ## used to compute pdsep
# ## - conservative: TRUE or FALSE defining if
# ## the v-structures after the pdsep
# ## have to be oriented conservatively or nor
# ## - maj.rule: TRUE or FALSE variable containing if the majority rule is
# ## used instead of the normal conservative
# ## - labels: names of the variables or nodes
# ## - type: it specifies the version of the FCI that has to be used.
# ## Per default it is normal, the normal FCI algorithm. It can also be
# ## anytime for the Anytime FCI and in this cas m.max must be specified;
# ## or it can be adaptive for Adaptive Anytime FCI and in this case
# ## m.max must not be specified.
# ## - numCores: handed to skeleton(), used for parallelization
#
# ## ----------------------------------------------------------------------
# ## Author: Markus Kalisch, Date: Dec 2009; update: Diego Colombo, 2012; Martin Maechler, 2013
#
# cl <- match.call()
# if(!missing(p)) stopifnot(is.numeric(p), length(p <- as.integer(p)) == 1, p >= 2)
# if(missing(labels)) {
# if(missing(p)) stop("need to specify 'labels' or 'p'")
# labels <- as.character(seq_len(p))
# } else { ## use labels ==> p from it
# stopifnot(is.character(labels))
# if(missing(p)) {
# p <- length(labels)
# } else if(p != length(labels))
# stop("'p' is not needed when 'labels' is specified, and must match length(labels)")
# else
# message("No need to specify 'p', when 'labels' is given")
# }
#
# ## Check that the type is a valid one
# type <- match.arg(type)
# if (type == "anytime" && m.max == Inf)
# stop("To use the Anytime FCI you must specify a finite 'm.max'.")
# if (type == "adaptive" && m.max != Inf)
# stop("To use the Adaptive Anytime FCI you must not specify 'm.max'.")
#
# if (conservative && maj.rule)
# stop("Choose either conservative FCI or majority rule FCI")
#
# cl <- match.call()
# if (verbose) cat("Compute Skeleton\n================\n")
#
# skel <- skeleton(suffStat, indepTest, alpha, labels = labels, method = skel.method,
# fixedGaps = fixedGaps, fixedEdges = fixedEdges,
# NAdelete=NAdelete, m.max=m.max, numCores=numCores, verbose=verbose)
# skel@call <- cl # so that makes it into result
# G <- as(skel@graph, "matrix")
# sepset <- skel@sepset
# pMax <- skel@pMax
# n.edgetestsSKEL <- skel@n.edgetests
# max.ordSKEL <- skel@max.ord
# allPdsep <- NA
# tripleList <- NULL
#
# if (doPdsep) {
# if (verbose) cat("\nCompute PDSEP\n=============\n")
# pc.ci <- pc.cons.intern(skel, suffStat, indepTest,
# alpha = alpha, version.unf = c(1,1),
# maj.rule = FALSE, verbose = verbose)
# ## Recompute (sepsets, G, ...):
# pdsepRes <- pdsep(skel@graph, suffStat, indepTest = indepTest, p = p,
# sepset = pc.ci$sk@sepset, alpha = alpha, pMax = pMax,
# m.max = if (type == "adaptive") max.ordSKEL else m.max,
# pdsep.max = pdsep.max, NAdelete = NAdelete,
# unfVect = pc.ci$unfTripl, # "tripleList.pdsep"
# biCC = biCC, verbose = verbose)
#
# ## update the graph & sepset :
# G <- pdsepRes$G
# sepset <- pdsepRes$sepset
# pMax <- pdsepRes$pMax
# allPdsep <- pdsepRes$allPdsep
# n.edgetestsPD <- pdsepRes$n.edgetests
# max.ordPD <- pdsepRes$max.ord
# if (conservative || maj.rule) {
# if (verbose)
# cat("\nCheck v-structures conservatively\n=================================\n")
# tmp.pdsep <- new("pcAlgo", graph = as(G, "graphNEL"), call = cl,
# n = integer(0), max.ord = as.integer(max.ordSKEL),
# n.edgetests = n.edgetestsSKEL, sepset = sepset,
# pMax = pMax, zMin = matrix(NA, 1, 1))
# sk. <- pc.cons.intern(tmp.pdsep, suffStat, indepTest, alpha,
# verbose = verbose, version.unf = c(1, 1),
# maj.rule = maj.rule)
# tripleList <- sk.$unfTripl
# ## update the sepsets
# sepset <- sk.$sk@sepset
# }
# }
# else {## !doPdsep : "do not Pdsep"
# n.edgetestsPD <- 0
# max.ordPD <- 0
# allPdsep <- vector("list", p)
# if (conservative || maj.rule) {
# if (verbose)
# cat("\nCheck v-structures conservatively\n=================================\n")
# nopdsep <- pc.cons.intern(skel, suffStat, indepTest, alpha,
# verbose = verbose, version.unf = c(2, 1),
# maj.rule = maj.rule)
# tripleList <- nopdsep$unfTripl
# ## update the sepsets
# sepset <- nopdsep$sk@sepset
# }
# }
# if (verbose)
# cat("\nDirect egdes:\n=============\nUsing rules:", which(rules),
# "\nCompute collider:\n")
# res <- udag2pag(pag = G, sepset, rules = rules, unfVect = tripleList,
# verbose = verbose)
# colnames(res) <- rownames(res) <- labels
# new("fciAlgo", amat = res, call = cl, n = integer(0),
# max.ord = as.integer(max.ordSKEL),
# max.ordPDSEP = as.integer(max.ordPD),
# n.edgetests = n.edgetestsSKEL, n.edgetestsPDSEP = n.edgetestsPD,
# sepset = sepset, pMax = pMax, allPdsep = allPdsep)
# } ## {fci}
## only called in pdsep()
qreach <- function(x,amat,verbose = FALSE)
{
## Purpose: Compute possible-d-sep(x) ("psep")
## !! The non-zero entries in amat must be symmetric !!
## ----------------------------------------------------------------------
## Arguments:
## - x: node of which psep berechnet werden soll
## - amat: adjacency matrix
## amat[i,j] = 0 iff no edge btw i,j
## amat[i,j] = 1 iff i *-o j
## amat[i,j] = 2 iff i *-> j
## - verbose: Show checked node sequence
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 29 Oct 2009, 11:54
## Stopping:
## =========
## At every iteration, Q get's reduced by one. It is only increased by
## at least one, if there are edges in A. and then, at least one
## edge in A. is removed. Edges are never inserted into A..
## Thus, either Q or A. becomes empty and the loop stops.
## Runtime:
## ========
## At least O(|V|), since look up in adjacency matrix is made. Assume O(|E|)>O
## Every edge can be visited at most twice. At each visit, there are no
## more than max(deg(V_i)) neighboring edges to look at. Thus, the runtime is
## O(2*|E| * max(deg(V_i))) = O(|E|^2) [worst case]; O(|E|) if sparse in the
## sense that max(deg(V_i)) is constant.
## Correctness:
## ============
## (A) All nodes in PSEP have a path of legal triples from x.
## (B) If there is a legal path from x to y in amat, at least one of them
## is found and y is recorded in PSEP:
## Suppose there is a node y != x that has a legal path from x, but is not in
## PSEP. y cannot be in nbrs(x), because they are added and nothing is
## deleted from PSEP. Hence, there must be a node z which
## is in PSEP but has a neighbor w in amat that has a legal path from
## x but is not in PSEP.
## Assuming that the function legal is correct, and noting that at (*) all
## neighbors of z in A. (tmp!) are analyzed, it follows that w is not
## in adj(z) in A. (but in amat). Thus, w must have been removed
## before from adj(z). Because of (+), it could only have been removed if
## u-z-w was found legal at some point. But then, w would have been added
## to PSEP. This is a contradiction to the assumption that w is not in PSEP.
## check: quadratic; x in V; edgemarks ok; non-zeroes symmetric
stopifnot((ncol(amat) == nrow(amat)),x <= ncol(amat),all(amat %in% c(0,1,2)),
all((amat != 0) == (t(amat != 0))))
A. <- (amat != 0) ## A.[i,j] is true <===> edge i--j
PSEP <- Q <- nb <- which(A.[x,])
P <- rep.int(x, length(Q))
A.[x,nb] <- FALSE ## delete edge to nbrs
while(length(Q) > 0) {
## Invariants:
## ===========
## (A1) length(Q) == length(P) > 0
## (A2) non-zero in A. -> non-zero in amat [no non-zero added]
## (A3) Q[i] and P[i] are adjacent in amat [using (A2)]
if (verbose) {
cat("\n-------------","\n")
cat("Queue Q:",Q,"\n")
cat("Queue P:",P,"\n")
}
a <- Q[1]
Q <- Q[-1]
pred <- P[1] ## not empty because of (A1)
P <- P[-1]
if (verbose) cat("Select",pred,"towards",a,"\n")
nb <- which(A.[a,]) ## (*)
if (verbose) cat("Check nbrs",nb,"\nLegal:")
for (b in nb) {
## Guaranteed: pred-a-b are a path because of (A3)
if (lres <- legal.path(pred,a,b,amat)) {
A.[a,b] <- FALSE ## remove b out of adj(a) in A. (+)
Q <- c(Q,b)
P <- c(P,a)
PSEP <- c(PSEP,b)
}
if (verbose) cat(if(lres)"T" else ".", "")
}
}
sort(setdiff(PSEP,x))
} ## {qreach}
## only called in fci() [by default: doPdsep=TRUE]
# pdsep <- function (skel, suffStat, indepTest, p, sepset, alpha, pMax, m.max = Inf,
# pdsep.max = Inf, NAdelete = TRUE, unfVect = NULL,
# biCC = FALSE, verbose = FALSE) ## FIXME: verbose : 2 --> qreach(verbose)
# {
# ## Purpose: Compute Possible-D-SEP for each node, perform the condittional
# ## independent tests and adapt graph accordingly
# ## ----------------------------------------------------------------------
# ## Arguments:
# ## - skel: Graph object returned by function skeleton
# ## - suffStat, indepTest: infofor the independence tests
# ## - p: number of nodes in the graph
# ## - sepset: Sepset that was used for finding the skeleton
# ## - alpha: niveau for the tests
# ## - pMax: Maximal p-values during estimation of skeleton
# ## - m.max: maximal size of the conditioning sets
# ## - pdsep.max: maximaum size of conditioning set for Possible-D-SEP
# ## - unfVect: vector containing the unfaithful triples, used for the
# ## conservative orientation of the v-structures
# ## - biCC: if the biconnected components have to be used
# ## ----------------------------------------------------------------------
# ## Value:
# ## - G: Updated boolean adjacency matrix
# ## - sepset: Updated sepsets
# ## - pMax: Updated pMax
# ## - allPdsep: Possible d-sep for each node [list]
# ## ----------------------------------------------------------------------
# ## Author: Markus Kalisch, Date: 9 Dec 2009
# ## Modification: Diego Colombo; Martin Maechler
#
# G <- (as(skel, "matrix") != 0)
# n.edgetests <- rep(0, 1000)
# ord <- 0L
# allPdsep.tmp <- vector("list", p)
# if(biCC)
# conn.comp <- lapply(biConnComp(skel), as.numeric)
# if (any(G)) {
# amat <- G
# ind <- which(G, arr.ind = TRUE)
# storage.mode(amat) <- "integer" # (TRUE, FALSE) --> (1, 0)
# ## Orient colliders
# if (verbose) cat("\nCompute collider:\n")
# for (i in seq_len(nrow(ind))) {
# x <- ind[i, 1]
# y <- ind[i, 2]
# allZ <- setdiff(which(amat[y, ] != 0), x)
# for (z in allZ) {
# if (amat[x, z] == 0 &&
# !(y %in% sepset[[x]][[z]] ||
# y %in% sepset[[z]][[x]])) {
#
# if (length(unfVect) == 0) { ## normal version -------------------
# amat[x, y] <- amat[z, y] <- 2
# if (verbose) cat("\n",x,"*->", y, "<-*", z, "\n")
# }
# else { ## conservative version : check if x-y-z is faithful
# if (!any(unfVect == triple2numb(p,x,y,z), na.rm = TRUE) &&
# !any(unfVect == triple2numb(p,z,y,x), na.rm = TRUE)) {
# amat[x, y] <- amat[z, y] <- 2
# if (verbose)
# cat("\n",x,"*->", y, "<-*", z, "\n")
# }
# }
# }
# } ## for( z )
# } ## for( i )
# allPdsep <- lapply(1:p, qreach, amat = amat)# verbose = (verbose >= 2)
# allPdsep.tmp <- vector("list", p)
# for(x in 1:p) {
# if(verbose) cat("\nPossible D-Sep of", x, "is:", allPdsep[[x]], "\n")
# if (any(an0 <- amat[x, ] != 0)) {
# tf1 <- setdiff(allPdsep[[x]], x)
# adj.x <- which(an0)
# for (y in adj.x) {
# if(verbose) cat(sprintf("\ny = %3d\n.........\n", y))
# tf <- setdiff(tf1, y)
# diff.set <- setdiff(tf, adj.x)
# ## bi-connected components
# if (biCC) {
# for(cci in conn.comp) {
# if (x %in% cci && y %in% cci)
# break ## found it
# }
# bi.conn.comp <- setdiff(cci, c(x,y))
# tf <- intersect(tf, bi.conn.comp)
# if (verbose) {
# cat("There is an edge between",x,"and",y,"\n")
# cat("Possible D-Sep of", x,
# "intersected with the biconnected component of",x,"and",y,
# "is:", tf, "\n")
# }
# } ## if(biCC)
# allPdsep.tmp[[x]] <- c(tf,y) ## you must add y to the set
# ## for the large scale simulations, we need to stop the algorithm if
# ## it takes to much time, i.e. sepset>25
# if (length(tf) > pdsep.max) {
# if(verbose)
# cat("Size of Possible-D-SEP bigger than",pdsep.max,
# ". Break the search for the edge between", x,"and",y,"\n")
# } else if (length(diff.set) > 0) {
# done <- FALSE
# ord <- 0L
# while (!done && ord < min(length(tf), m.max)) {
# ord <- ord + 1L
# if(verbose) cat("ord = ", ord, "\n")
# if (ord == 1) {
# for (S in diff.set) {
# pval <- indepTest(x, y, S, suffStat)
# n.edgetests[ord + 1] <- n.edgetests[ord + 1] + 1
# if (is.na(pval))
# pval <- as.numeric(NAdelete) ## = if(NAdelete) 1 else 0
# if (pval > pMax[x, y])
# pMax[x, y] <- pval
# if (pval >= alpha) {
# amat[x, y] <- amat[y, x] <- 0
# sepset[[x]][[y]] <- sepset[[y]][[x]] <- S
# done <- TRUE
# if (verbose)
# cat("x=", x, " y=", y, " S=", S, ": pval =", pval, "\n")
# break
# }
# }
# }
# else { ## ord > 1
# tmp.combn <- combn(tf, ord) ## has choose( |tf|, ord ) columns
# if (ord <= length(adj.x)) {
# for (k in seq_len(ncol(tmp.combn))) {
# S <- tmp.combn[, k]
# if (!all(S %in% adj.x)) {
# n.edgetests[ord + 1] <- n.edgetests[ord + 1] + 1
# pval <- indepTest(x, y, S, suffStat)
# if (is.na(pval))
# pval <- as.numeric(NAdelete) ## = if(NAdelete) 1 else 0
# if(pMax[x, y] < pval)
# pMax[x, y] <- pval
# if (pval >= alpha) {
# amat[x, y] <- amat[y, x] <- 0
# sepset[[x]][[y]] <- sepset[[y]][[x]] <- S
# done <- TRUE
# if (verbose)
# cat("x=", x, " y=", y, " S=", S, ": pval =", pval, "\n")
# break
# }
# }
# } ## for(k ..)
# }
# else { ## ord > |adj.x| :
# ## check all combinations; no combination has been tested before
# for (k in seq_len(ncol(tmp.combn))) {
# S <- tmp.combn[, k]
# n.edgetests[ord + 1] <- n.edgetests[ord + 1] + 1
# pval <- indepTest(x, y, S, suffStat)
# if (is.na(pval))
# pval <- as.numeric(NAdelete) ## = if(NAdelete) 1 else 0
# if(pMax[x, y] < pval)
# pMax[x, y] <- pval
# if (pval >= alpha) {
# amat[x, y] <- amat[y, x] <- 0
# sepset[[x]][[y]] <- sepset[[y]][[x]] <- S
# done <- TRUE
# if (verbose)
# cat("x=", x, " y=", y, " S=", S, ": pval =", pval, "\n")
# break
# }
# } ## for(k ..)
# } ## else: { ord > |adj.x| }
# } ## else
#
# } ## while(!done ..)
# }
#
# } ## for(y ..)
#
# } ## if(any( . ))
#
# } ## for(x ..)
# G[amat == 0] <- FALSE
# G[amat == 1] <- TRUE
# G[amat == 2] <- TRUE
#
# } ## if(any(G))
#
# list(G = G, sepset = sepset, pMax = pMax, allPdsep = allPdsep.tmp,
# max.ord = ord, n.edgetests = n.edgetests[1:(ord + 1)])
# } ## {pdsep}
# udag2pag <- function(pag, sepset, rules = rep(TRUE,10), unfVect = NULL, verbose = FALSE, orientCollider = TRUE)
# {
# ## Purpose: Transform the Skeleton of a pcAlgo-object to a PAG using
# ## the rules of Zhang. The output is an adjacency matrix.
# ## ----------------------------------------------------------------------
# ## Arguments:
# ## - pag: adjacency matrix of size pxp
# ## - sepset: list of all separation sets
# ## - rules: array of length 10 wich contains TRUE or FALSE corrsponding
# ## to each rule. TRUE means the rule will be applied.
# ## If rules==FALSE only R0 (minimal pattern) will be used
# ## - unfVect: Vector with ambiguous triples (coded as number using triple2numb)
# ## - verbose: 0 - no output, 1 - detailed output
# ## ----------------------------------------------------------------------
# ## Author: Diego Colombo, Date: 6 Mar 2009; cleanup: Martin Maechler, 2010
# ## update: Diego Colombo, 2012
#
# ## Notation:
# ## ----------------------------------------------------------------------
# ## 0: no edge
# ## 1: -o
# ## 2: -> (arrowhead)
# ## 3: - (tail)
# ## a=alpha
# ## b=beta
# ## c=gamma
# ## d=theta
#
# stopifnot(is.logical(rules), length(rules) == 10)
# if(!is.numeric(pag)) storage.mode(pag) <- "numeric"
#
# if (any(pag != 0)) {
# p <- as.numeric(dim(pag)[1])
#
# ## orient collider
# if (orientCollider) {
# ind <- which(pag == 1, arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# x <- ind[i, 1]
# y <- ind[i, 2]
# allZ <- setdiff(which(pag[y, ] != 0), x)
# for (z in allZ) {
# if (pag[x, z] == 0 && !((y %in% sepset[[x]][[z]]) ||
# (y %in% sepset[[z]][[x]]))) {
# if (length(unfVect) == 0) {
# if (verbose) {
# cat("\n", x, "*->", y, "<-*", z, "\n")
# cat("Sxz=", sepset[[z]][[x]], "and",
# "Szx=", sepset[[x]][[z]], "\n")
# }
# pag[x, y] <- pag[z, y] <- 2
# }
# else {
# if (!any(unfVect == triple2numb(p, x, y, z), na.rm = TRUE) &&
# !any(unfVect == triple2numb(p, z, y, x), na.rm = TRUE)) {
# if (verbose) {
# cat("\n", x, "*->", y, "<-*", z, "\n")
# cat("Sxz=", sepset[[z]][[x]], "and",
# "Szx=", sepset[[x]][[z]], "\n")
# }
# pag[x, y] <- pag[z, y] <- 2
# }
# }
# }
# }
# }
# } ## end: Orient collider
#
# old_pag1 <- matrix(0, p, p)
# while (any(old_pag1 != pag)) {
# old_pag1 <- pag
# ##-- R1 ------------------------------------------------------------------
# if (rules[1]) {
# ind <- which((pag == 2 & t(pag) != 0), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# a <- ind[i, 1]
# b <- ind[i, 2]
# indC <- which((pag[b, ] != 0 & pag[, b] == 1) & (pag[a, ] == 0 & pag[, a] == 0))
# indC <- setdiff(indC, a)
# if (length(indC) > 0) {
# if (length(unfVect) == 0) {
# pag[b, indC] <- 2
# pag[indC, b] <- 3
# if (verbose)
# cat("\nRule 1",
# "\nOrient:", a, "*->", b, "o-*", indC,
# "as:", b, "->", indC, "\n")
# }
# else {
# for (c in indC) {
# if (!any(unfVect == triple2numb(p, a, b, c), na.rm = TRUE) &&
# !any(unfVect == triple2numb(p, c, b, a), na.rm = TRUE)) {
# pag[b, c] <- 2
# pag[c, b] <- 3
# if (verbose)
# cat("\nRule 1",
# "\nConservatively orient:", a, "*->", b, "o-*",
# c, "as:", b, "->", c, "\n")
# }
# } ## for( c )
# }
# }
# } ## for( i )
# }
# ##-- R2 ------------------------------------------------------------------
# if (rules[2]) {
# ind <- which((pag == 1 & t(pag) != 0), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# a <- ind[i, 1]
# c <- ind[i, 2]
# indB <- which((pag[a, ] == 2 & pag[, a] == 3 & pag[c, ] != 0 & pag[, c] == 2) | (pag[a, ] == 2 & pag[, a] != 0 & pag[c, ] == 3 & pag[, c] == 2))
# if (length(indB) > 0) {
# pag[a, c] <- 2
# if (verbose) {
# cat("\nRule 2","\n")
# cat("Orient:", a, "->", indB, "*->", c, "or", a, "*->", indB, "->", c, "with", a, "*-o", c, "as:", a, "*->", c, "\n")
# }
# }
# }
# }
# ##-- R3 ------------------------------------------------------------------
# if (rules[3]) {
# ind <- which((pag != 0 & t(pag) == 1), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# b <- ind[i, 1]
# d <- ind[i, 2]
# indAC <- which((pag[b, ] != 0 & pag[, b] == 2) & (pag[, d] == 1 & pag[d, ] != 0))
# if (length(indAC) >= 2) {
# if (length(unfVect) == 0) {
# counter <- 0
# while ((counter < (length(indAC) - 1)) && (pag[d, b] != 2)) {
# counter <- counter + 1
# ii <- counter
# while (ii < length(indAC) && pag[d, b] != 2) {
# ii <- ii + 1
# if (pag[indAC[counter], indAC[ii]] == 0 && pag[indAC[ii], indAC[counter]] == 0) {
# if (verbose) {
# cat("\nRule 3","\n")
# cat("Orient:", d, "*->", b, "\n")
# }
# pag[d, b] <- 2
# }
# }
# }
# }
# else {
# comb.indAC <- combn(indAC, 2)
# for (j in 1:dim(comb.indAC)[2]) {
# a <- comb.indAC[1, j]
# c <- comb.indAC[2, j]
# if (pag[a, c] == 0 && pag[c, a] == 0 && c != a) {
# if (!any(unfVect == triple2numb(p, a, d, c), na.rm = TRUE) &&
# !any(unfVect == triple2numb(p, c, d, a), na.rm = TRUE)) {
# pag[d, b] <- 2
# if (verbose) {
# cat("\nRule 3","\n")
# cat("Conservatively orient:", d, "*->", b, "\n")
# }
# }
# }
# }
# }
# }
# }
# }
# ##-- R4 ------------------------------------------------------------------
# if (rules[4]) {
# ind <- which((pag != 0 & t(pag) == 1), arr.ind = TRUE)## b o-* c
# while (length(ind) > 0) {
# b <- ind[1, 1]
# c <- ind[1, 2]
# ind <- ind[-1,, drop = FALSE]
# ## find all a s.t. a -> c and a <-* b
# indA <- which((pag[b, ] == 2 & pag[, b] != 0) &
# (pag[c, ] == 3 & pag[, c] == 2))
# ## chose one a s.t. the initial triangle structure exists and the edge hasn't been oriented yet
# while (length(indA) > 0 && pag[c,b] == 1) {
# a <- indA[1]
# indA <- indA[-1]
# ## path is the initial triangle
# ## abc <- c(a, b, c)
# ## Done is TRUE if either we found a minimal path or no path exists for this triangle
# Done <- FALSE
# ### MM: FIXME?? Isn't Done set to TRUE in *any* case inside the following
# ### while(.), the very first time already ??????????
# while (!Done && pag[a,b] != 0 && pag[a,c] != 0 && pag[b,c] != 0) {
# ## find a minimal discriminating path for a,b,c
# md.path <- minDiscrPath(pag, a,b,c, verbose = verbose)
# ## if the path doesn't exists, we are done with this triangle
# if ((N.md <- length(md.path)) == 1) {
# Done <- TRUE
# }
# else {
# ## a path exists
# ## if b is in sepset
# if ((b %in% sepset[[md.path[1]]][[md.path[N.md]]]) ||
# (b %in% sepset[[md.path[N.md]]][[md.path[1]]])) {
# if (verbose)
# cat("\nRule 4",
# "\nThere is a discriminating path between",
# md.path[1], "and", c, "for", b, ",and", b, "is in Sepset of",
# c, "and", md.path[1], ". Orient:", b, "->", c, "\n")
# pag[b, c] <- 2
# pag[c, b] <- 3
# }
# else {
# ## if b is not in sepset
# if (verbose)
# cat("\nRule 4",
# "\nThere is a discriminating path between",
# md.path[1], "and", c, "for", b, ",and", b, "is not in Sepset of",
# c, "and", md.path[1], ". Orient:", a, "<->", b, "<->",
# c, "\n")
# pag[a, b] <- pag[b, c] <- pag[c, b] <- 2
# }
# Done <- TRUE
# }
# }
# }
# }
# }
# ##-- R5 ------------------------------------------------------------------
# if (rules[5]) {
# ind <- which((pag == 1 & t(pag) == 1), arr.ind = TRUE) ## a o-o b
# while (length(ind) > 0) {
# a <- ind[1, 1]
# b <- ind[1, 2]
# ind <- ind[-1,, drop = FALSE]
# ## find all c s.t. a o-o c and c is not connected to b
# indC <- which((pag[a, ] == 1 & pag[, a] == 1) & (pag[b, ] == 0 & pag[, b] == 0))
# ## delete b since it is surely in indC
# indC <- setdiff(indC, b)
# ## find all d s.t. b o-o d and d is not connected to a
# indD <- which((pag[b, ] == 1 & pag[, b] == 1) & (pag[a, ] == 0 & pag[, a] == 0))
# ## delete a since it is surely in indD
# indD <- setdiff(indD, a)
# if (length(indC) > 0 && length(indD) > 0) {
# counterC <- 0
# while ((counterC < length(indC)) && pag[a, b] == 1) {
# counterC <- counterC + 1
# c <- indC[counterC]
# counterD <- 0
# while ((counterD < length(indD)) && pag[a, b] == 1) {
# counterD <- counterD + 1
# d <- indD[counterD]
# ## this is the easiest one
# if (pag[c, d] == 1 && pag[d, c] == 1) {
# if (length(unfVect) == 0) { ## normal version
# pag[a, b] <- pag[b, a] <- 3
# pag[a, c] <- pag[c, a] <- 3
# pag[c, d] <- pag[d, c] <- 3
# pag[d, b] <- pag[b, d] <- 3
# if (verbose)
# cat("\nRule 5",
# "\nThere exists an uncovered circle path between", a, "and", b,
# ". Orient:", a, "-", b, "and", a, "-", c, "-", d, "-", b, "\n")
# }
# else { ## conservative: check that every triple on the circle is faithful
# path2check <- c(a,c,d,b)
# if (faith.check(path2check, unfVect, p)) {
# pag[a, b] <- pag[b, a] <- 3
# pag[a, c] <- pag[c, a] <- 3
# pag[c, d] <- pag[d, c] <- 3
# pag[d, b] <- pag[b, d] <- 3
# if (verbose)
# cat("\nRule 5",
# "\nThere exists a faithful uncovered circle path between",
# a, "and", b, ". Conservatively orient:",
# a, "-", b, "and", a, "-", c, "-", d, "-", b, "\n")
# }
# }
# }
# ## search with a breitensuche a minimal uncovered circle path
# else {
# ## Find a minimal uncovered circle path for these a,b,c, and d.
# ## This path has already been checked to be uncovered and
# ## to be faithful for the conservative case
# ucp <- minUncovCircPath(p, pag = pag, path = c(a,c,d,b),
# unfVect = unfVect, verbose = verbose)
# ## there is a path ---> orient
# if (length(ucp) > 1) {
# ## orient every edge on the path as --
# n <- length(ucp)
# pag[ucp[1], ucp[n]] <- pag[ucp[n], ucp[1]] <- 3 ## a--b
# for (j in 1:(length(ucp)-1)) ## each edge on the path --
# pag[ucp[j], ucp[j + 1]] <- pag[ucp[j + 1], ucp[j]] <- 3
# }
# }
# }
# }
# }
# }
# }
# ##-- R6 ------------------------------------------------------------------
# if (rules[6]) {
# ind <- which((pag != 0 & t(pag) == 1), arr.ind = TRUE)## b o-* c
# for (i in seq_len(nrow(ind))) {
# b <- ind[i, 1]
# c <- ind[i, 2]
# if (any(pag[b, ] == 3 & pag[, b] == 3)) {
# pag[c, b] <- 3
# if (verbose)
# cat("\nRule 6",
# "\nOrient:", b, "o-*", c, "as", b, "-*", c, "\n")
# }
# }
# }
# ##-- R7 ------------------------------------------------------------------
# if (rules[7]) {
# ind <- which((pag != 0 & t(pag) == 1), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# b <- ind[i, 1]
# c <- ind[i, 2]
# indA <- which((pag[b, ] == 3 & pag[, b] == 1) & (pag[c, ] == 0 & pag[, c] == 0))
# indA <- setdiff(indA, c)
# if (length(indA) > 0) {
# if (length(unfVect) == 0) {
# pag[c, b] <- 3
# if (verbose)
# cat("\nRule 7",
# "\nOrient:", indA, "-o", b, "o-*",
# c, "as", b, "-*", c, "\n")
# }
# else for (a in indA)
# if (!any(unfVect == triple2numb(p, a, b, c), na.rm = TRUE) &&
# !any(unfVect == triple2numb(p, c, b, a), na.rm = TRUE)) {
# pag[c, b] <- 3
# if (verbose)
# cat("\nRule 7",
# "\nConservatively orient:", a, "-o", b, "o-*",
# c, "as", b, "-*", c, "\n")
# }
# }
# }
# }
# ##-- R8 ------------------------------------------------------------------
# if (rules[8]) {
# ind <- which((pag == 2 & t(pag) == 1), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# a <- ind[i, 1]
# c <- ind[i, 2]
# indB <- which(pag[, a] == 3 & (pag[a, ] == 2 | pag[a, ] == 1) &
# pag[c, ] == 3 & pag[, c] == 2)
# if (length(indB) > 0) {
# pag[c, a] <- 3
# if (verbose)
# cat("\nRule 8",
# "\nOrient:", a, "->", indB, "->", c,
# "or", a, "-o", indB, "->", c, "with", a,
# "o->", c, "as", a, "->", c, "\n")
# }
# }
# }
# ##-- R9 ------------------------------------------------------------------
# if (rules[9]) {
# ind <- which((pag == 2 & t(pag) == 1), arr.ind = TRUE) ## a o-> c
# while (length(ind) > 0) {
# a <- ind[1, 1]
# c <- ind[1, 2]
# ind <- ind[-1,, drop = FALSE]
# ## find all b s.t. a (o-)--(o>) b and b and c are not connected
# indB <- which((pag[a, ] == 2 | pag[a, ] == 1) &
# (pag[, a] == 1 | pag[, a] == 3) &
# (pag[c, ] == 0 & pag[, c] == 0))
# ## delete c from indB since it is surely inside
# indB <- setdiff(indB, c)
# ## chose one b s.t. the initial structure exists and the edge hasn't been oriented yet
# while ((length(indB) > 0) && (pag[c,a] == 1)) {
# b <- indB[1]
# indB <- indB[-1]
# ## find a minimal uncovered pd path from initial (a,b,c) :
# upd <- minUncovPdPath(p, pag, a,b,c,
# unfVect = unfVect, verbose = verbose)
# ## there is a path ---> orient it
# if (length(upd) > 1) {
# pag[c, a] <- 3
# if (verbose)
# cat("\nRule 9",
# "\nThere exists an uncovered potentially directed path between", a, "and", c,
# ". Orient:", a, " ->",c, "\n")
# }
# }
# }
# }
# ##-- R10 ------------------------------------------------------------------
# if (rules[10]) {
# ind <- which((pag == 2 & t(pag) == 1), arr.ind = TRUE) ## a o-> c
# while (length(ind) > 0) {
# a <- ind[1, 1]
# c <- ind[1, 2]
# ind <- ind[-1,, drop = FALSE]
# ## find all b s.t. b --> c
# indB <- which((pag[c, ] == 3 & pag[, c] == 2))
# if (length(indB) >= 2) {
# counterB <- 0
# while (counterB < length(indB) && (pag[c, a] == 1)) {
# counterB <- counterB + 1
# b <- indB[counterB]
# indD <- setdiff(indB, b)
# counterD <- 0
# while ((counterD < length(indD)) && (pag[c, a] == 1)) {
# counterD <- counterD + 1
# d <- indD[counterD]
# ## this is the easiest one
# if ((pag[a, b] == 1 || pag[a, b] == 2) &&
# (pag[b, a] == 1 || pag[b, a] == 3) &&
# (pag[a, d] == 1 || pag[a, d] == 2) &&
# (pag[d, a] == 1 || pag[d, a] == 3) && pag[d, b] == 0 && pag[b, d] == 0) {
# if (length(unfVect) == 0) { ## normal version
# pag[c, a] <- 3
# if (verbose)
# cat("\nRule 10 [easy]",
# "\nOrient:", a, "->", c, "\n")
# }
# else ## conservative version: check faithfulness of b-a-d
# if (!any(unfVect == triple2numb(p,b,a,d), na.rm = TRUE) &&
# !any(unfVect == triple2numb(p,d,a,b), na.rm = TRUE)) {
# pag[c, a] <- 3
# if (verbose)
# cat("\nRule 10 [easy]",
# "\nConservatively orient:", a, "->", c, "\n")
# }
# }
# ## search with a breitensuche two minimal uncovered circle paths
# else {
# ## find all x s.t. a (o-)--(o>) x
# indX <- which((pag[a, ] == 1 | pag[a, ] == 2) &
# (pag[, a] == 1 | pag[, a] == 3), arr.ind = TRUE)
# indX <- setdiff(indX, c)
# if (length(indX >= 2)) {
# counterX1 <- 0
# while (counterX1 < length(indX) && pag[c, a] == 1) {
# counterX1 <- counterX1 + 1
# first.pos <- indX[counterX1]
# indX2 <- setdiff(indX, first.pos)
# counterX2 <- 0
# while (counterX2 < length(indX2) && pag[c, a] == 1) {
# counterX2 <- counterX2 + 1
# sec.pos <- indX2[counterX2]
# t1 <- minUncovPdPath(p, pag, a, first.pos, b,
# unfVect = unfVect, verbose = verbose)
# if (length(t1) > 1) { # otherwise, can skip next minUnc..()
# t2 <- minUncovPdPath(p, pag, a, sec.pos, d,
# unfVect = unfVect, verbose = verbose)
# if (length(t2) > 1 &&
# first.pos != sec.pos && pag[first.pos, sec.pos] == 0) {
# ## we found 2 uncovered pd paths
# if (length(unfVect) == 0) { ## normal version
# pag[c, a] <- 3
# if (verbose)
# cat("\nRule 10", "\nOrient:", a, "->", c, "\n")
# }
# else if(!any(unfVect == triple2numb(p,first.pos, a, sec.pos), na.rm = TRUE) &&
# !any(unfVect == triple2numb(p,sec.pos, a, first.pos), na.rm = TRUE)) {
# ## conservative version
# pag[c, a] <- 3
# if (verbose)
# cat("\nRule 10",
# "\nConservatively orient:", a, "->", c, "\n")
# }
# }
# }
# } # # while ( counterX2 .. )
# }
# }
# } # else
# } # while ( counterD .. )
# } # while ( counterB .. )
# } # if (length(indB) .)
# }
# } ## if (rules[10] ..)
# }
# }
# pag
# } ## udag2pag()
################################################################################
## RFCI
################################################################################
rfci <- function(suffStat, indepTest, alpha, labels, p,
skel.method = c("stable", "original", "stable.fast"),
fixedGaps = NULL, fixedEdges = NULL,
NAdelete = TRUE, m.max = Inf, rules = rep(TRUE, 10),
conservative = FALSE, maj.rule = FALSE,
numCores = 1, verbose = FALSE)
{
## Purpose: Perform RFCI-Algorithm, i.e., estimate PAG
## ----------------------------------------------------------------------
## Arguments:
## - suffStat, indepTest: info for the tests
## - p: number of nodes in the graph
## - alpha: Significance level of individual partial correlation tests
## - verbose: 0 - no output, 1 - detailed output
## - fixedGaps: the adjacency matrix of the graph from which the algorithm
## should start (logical); gaps fixed here are not changed
## - fixedEdges: Edges marked here are not changed (logical)
## - NAdelete: delete edge if pval=NA (for discrete data)
## - m.max: maximal size of conditioning set
## - rules: array of length 10 wich contains TRUE or FALSE corrsponding
## to each rule. TRUE means the rule will be applied.
## If rules==FALSE only R0 (minimal pattern) will be used
## - conservative: TRUE or FALSE defining if the v-structures after
## the skeleton have to be oriented conservatively or nor
## - maj.rule: TRUE or FALSE variable containing if the majority rule is
## used instead of the normal conservative
## - labels: names of the variables or nodes
## - numCores: handed to skeleton(), used for parallelization
## ----------------------------------------------------------------------
## Author: Diego Colombo, 2011; modifications: Martin Maechler
cl <- match.call()
if(!missing(p)) stopifnot(is.numeric(p), length(p <- as.integer(p)) == 1, p >= 2)
if(missing(labels)) {
if(missing(p)) stop("need to specify 'labels' or 'p'")
labels <- as.character(seq_len(p))
} else { ## use labels ==> p from it
stopifnot(is.character(labels))
if(missing(p)) {
p <- length(labels)
} else if(p != length(labels))
stop("'p' is not needed when 'labels' is specified, and must match length(labels)")
else
message("No need to specify 'p', when 'labels' is given")
}
if (conservative && maj.rule)
stop("Can only choose one of conservative or majority rule RFCI")
if (verbose) cat("Compute Skeleton\n================\n")
skel <- skeleton(suffStat, indepTest, alpha, labels = labels, method = skel.method,
fixedGaps = fixedGaps, fixedEdges = fixedEdges,
NAdelete=NAdelete, m.max=m.max, numCores=numCores, verbose=verbose)
sk.A <- as(skel@graph, "matrix")
sepset <- skel@sepset
## the list of all ordered unshielded triples (the graph g does not change it is just a search!)
u.t <- find.unsh.triple(sk.A, check = FALSE)
## check and orient v-structures recursively
r.v. <- rfci.vStruc(suffStat, indepTest, alpha, sepset, sk.A,
unshTripl = u.t$unshTripl, unshVect = u.t$unshVect,
conservative = (conservative || maj.rule),
version.unf = c(1,1), maj.rule = maj.rule, verbose = verbose)
A <- r.v.$amat
sepset <- r.v.$sepset
## orient as many edge marks as possible
if (verbose)
cat("\nDirect egdes:\n=============\nUsing rules:", which(rules), "\n")
res <- udag2apag(A, suffStat, indepTest, alpha, sepset,
rules = rules, unfVect = r.v.$unfTripl, verbose = verbose)
Amat <- res$graph
colnames(Amat) <- rownames(Amat) <- labels
new("fciAlgo", amat = Amat, call = cl, n = integer(0),
max.ord = as.integer(skel@max.ord), max.ordPDSEP = 0L,
n.edgetests = skel@n.edgetests, n.edgetestsPDSEP = 0,
sepset = res$sepset, pMax = skel@pMax, allPdsep = vector("list", p))
} ## {rfci}
find.unsh.triple <- function(g, check = TRUE)
{
## Purpose: find the ordered (<x,y,z> with x<z) list of all the unshielded
## triples in the graph
## ----------------------------------------------------------------------
## Arguments: g: adjacency matrix
## ----------------------------------------------------------------------
## Values: - unshTripl: matrix with 3 rows containing in each column
## an unshielded triple
## - unshVect: containing the unique number for each column
## in unshTripl
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 21 Oct 2010; clean- and speed-up: Martin Maechler
if(check) stopifnot( all(g == t(g)) )
m <- 0L
unshTripl <- matrix(integer(), 3, m)
if (any(g != 0)) { # if( at least one edge) -- find all unshielded triples in g
p <- nrow(g)
indS <- which(g == 1, arr.ind = TRUE) ## x-y
for (i in seq_len(nrow(indS))) {
xy <- indS[i,]
x <- xy[1]
y <- xy[2]
allZ <- setdiff(which(g[y, ] == 1), x) ## x-y-z
for (z in allZ) {
if (g[x,z] == 0 && g[z,x] == 0) {
## save the matrix
unshTripl <- cbind(unshTripl, c(xy, z))
}
}
}
## delete duplicates in the matrix
if ((m <- ncol(unshTripl)) > 0) {
deleteDupl <- logical(m)# all FALSE
for (i in seq_len(m)) ## FIXME -- make faster!
if (unshTripl[1,i] > unshTripl[3,i])
deleteDupl[i] <- TRUE
if(any(deleteDupl))
m <- ncol(unshTripl <- unshTripl[,!deleteDupl, drop = FALSE])
}
}
## define the vector with the unique number for each triple
unshVect <- vapply(seq_len(m), function(k)
triple2numb(p, unshTripl[1,k], unshTripl[2,k], unshTripl[3,k]),
numeric(1))
list(unshTripl = unshTripl, unshVect = unshVect)
} ## {find.unsh.triple}
##' called only from rfci() and checkEdges()
rfci.vStruc <- function(suffStat, indepTest, alpha, sepset, g.amat,
unshTripl, unshVect, conservative = FALSE,
version.unf = c(2,1), maj.rule = FALSE, verbose = FALSE)
{
## Purpose: check the unshielded triples in unshTripl as v-structures
## recursively check if new unshielded triples have been found
## then save and orient the final ones in finalList and finalVect
## ----------------------------------------------------------------------
## Arguments: - suffStat, indepTest, p,alpha: arguments from the algorithm
## - sepset, g.amat: output of the function skeleton
## - unshTripl, unshVect: list/numbers of the unshielded triples
## in graph
## - conservative: TRUE or FALSE
## - version.unf=c(2,1): conservative version
## - maj.rule: TRUE or FALSE variable containing if the majority
## rule is used instead of the normal conservative
## ----------------------------------------------------------------------
## Values: - updated sepset, graph (g.amat) and list of unfaithful v-structures
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 21 Oct 2010, 14:15
## check every column (unshielded triple) of unshTripl
## NOTE: what's done is done!!!! I don't look back in the matrix
stopifnot(is.matrix(unshTripl), nrow(unshTripl) == 3)
nT <- ncol(unshTripl)
A <- g.amat
## list of all unfaithful v-structures
unfTripl <- NULL
if (nT) {
if (verbose)
cat("\nCheck unshielded triples for conditional dependence
================================================\n")
## check all the columns in unshTripl as v-structure or not
checktmp <- dep.triple(suffStat, indepTest, alpha, sepset = sepset, apag = g.amat,
unshTripl = unshTripl, unshVect = unshVect,
## per default every triple is defined as a v-structure :
trueVstruct = rep(TRUE, nT), verbose = verbose)
## save the updated objects
A <- checktmp$apag
sepset <- checktmp$sepset
## note that no column is deleted from the matrix, we can add new triples instead
unshTripl <- checktmp$triple
unshVect <- checktmp$vect
trueVstruct <- checktmp$trueVstruct
if (verbose) cat(
if (conservative)
"\nOrient the v-structures conservatively
=====================================\n"
else "\nOrient the v-structures\n=======================\n")
## if there is at least one triple with the desired properties
if (any(trueVstruct)) {
for (i in 1:dim(unshTripl)[2]) {
if (trueVstruct[i]) {
x <- unshTripl[1, i]
y <- unshTripl[2, i]
z <- unshTripl[3, i]
if (!conservative) {
if (A[x, z] == 0 && A[x,y] != 0 && A[z,y] != 0 &&
!((y %in% sepset[[x]][[z]]) || (y %in% sepset[[z]][[x]]))) {
## this is to avoid the problem of:
## assume that <a,b,c> was saved in finalList because a "true" unshielded triple
## but after in the matrix appears <b,c,d> and the edge b-c is deleted
## of course the triple <a,b,c> stays in the finalList but we cannot orient the edge
## b-c because it doesn'e exist anymore
if (verbose)
cat("\n", x, "*->", y, "<-*", z,
"\nSxz=", sepset[[z]][[x]], "and",
"Szx=", sepset[[x]][[z]], "\n")
A[c(x,z), y] <- 2
}
} else { ## conservative version
## check if x-y-z is faithful
## find neighbours of x and z
nbrsX <- which(A[,x] != 0) ## G symm; x no nbr of z
nbrsZ <- which(A[,z] != 0)
if (verbose)
cat("\nTriple:",x,y,z,"and sepset by skelet:",
unique(sepset[[x]][[z]],sepset[[z]][[x]]),"\n")
r.abc <- checkTriple(x, y, z, nbrsX, nbrsZ,
sepset[[x]][[z]], sepset[[z]][[x]],
suffStat = suffStat, indepTest = indepTest, alpha = alpha,
version.unf = version.unf, maj.rule = maj.rule,
verbose = verbose)
p <- nrow(A)
## 1: in NO set; 2: in ALL sets; 3: in SOME but not all
if (r.abc$decision == 3 || ## <- take action if case "3", or
## can happen the case in Tetrad, so we must save the triple as unfaithful
## a and c independent given S but not given subsets of the adj(x) or adj(z)
(version.unf[1] == 2 && r.abc$version == 2)) {
## record unfaithful triple
unfTripl <- c(unfTripl, triple2numb(p, x, y, z))
if (verbose >= 2) cat("new unfTriple:", x, y, z, "\n")
}
sepset[[x]][[z]] <- r.abc$SepsetA
sepset[[z]][[x]] <- r.abc$SepsetC
if (A[x,z] == 0 && A[x,y] != 0 && A[z,y] != 0 &&
!((y %in% sepset[[x]][[z]]) ||
(y %in% sepset[[z]][[x]])) &&
!any(unfTripl == triple2numb(p, x, y, z), na.rm = TRUE) &&
!any(unfTripl == triple2numb(p, z, y, x), na.rm = TRUE)) {
if (verbose)
cat("\nOrient:", x, "*->", y, "<-*", z,
"\nSxz=", sepset[[z]][[x]], "and",
"Szx=", sepset[[x]][[z]], "\n")
A[c(x,z), y] <- 2
}
} ## else : conservative
}
} ## for (i ...)
}
}
list(sepset = sepset, amat = A, unfTripl = unfTripl)
} ## {rfci.vStruc}
## only called from rfci.vStruc() - with trueVstruct a vector of TRUE
dep.triple <- function(suffStat, indepTest, alpha, sepset, apag,
unshTripl, unshVect, trueVstruct, verbose = FALSE)
{
## Purpose: test the two edges of any unshielded triple in unshTripl (column)
## for dependence given sepset. If independent find the minimal
## sepset, delete the edge, define the triple as FALSE in
## trueVstruct and search in the graph for new triple or destroyed
## ones. Otherwise do nothing.
## ----------------------------------------------------------------------
## Arguments: - suffStat, indepTest, alpha, sepset, apag: skeleton parameters / result
## - unshTripl: matrix containing the unshielded triples (columns)
## - unshVect: triple2numb of unshTripl
## - trueVstruct: vector containing T/F for the v-structures
## ----------------------------------------------------------------------
## Values: - updated sepset, apag, unshTripl, unshVect, trueVstruct
## Author: Diego Colombo, Date: 16 Aug 2010, 15:07
p <- nrow(apag) ## == length(sepset)
for(k in seq_len(ncol(unshTripl))) {
## Note that trueVstruct[.] is changed *inside* !
if (trueVstruct[k]) { ## triple under inspection x-y-z
x <- unshTripl[1, k]
y <- unshTripl[2, k]
z <- unshTripl[3, k]
SepSet <- setdiff(unique(c(sepset[[x]][[z]],
sepset[[z]][[x]])), y)
nSep <- length(SepSet)
if (verbose)
cat("\nTriple:", x, y, z, "and sepSet (of size", nSep,") ", SepSet,"\n")
if (nSep != 0) {
x. <- min(x,y)
y. <- max(x,y)
y_ <- min(y,z)
z_ <- max(y,z)
## Check x-y ---------------------------------------------------------------
del1 <- FALSE
## check first x and y given the whole sepset(x,z)
if (indepTest(x, y, SepSet, suffStat) >= alpha) {
## afterwards we have to define this triple as FALSE in trueVstruct
del1 <- TRUE
## x and y are independent, then find the minimal sepset
done <- FALSE
ord <- 0L
while (!done && ord < nSep) {
ord <- ord + 1L
## all combinations of SepSet of size ord
S.j <- if (ord == 1 && nSep == 1) matrix(SepSet,1,1) else combn(SepSet, ord)
for (i in seq_len(ncol(S.j))) {
pval <- indepTest(x, y, S.j[,i], suffStat)
if (verbose) cat("x=", x, " y=", y, "S=", S.j[,i], ": pval =", pval, "\n")
if (pval >= alpha) {
## delete edge and save set in sepset
apag[x, y] <- apag[y, x] <- 0
sepset[[x]][[y]] <- sepset[[y]][[x]] <- S.j[,i]
done <- TRUE
break
}
}
}
## case 1: before we had a triangle and now it is an unshielded triple x-m-y
indM <- which((apag[x, ] == 1 & apag[, x] == 1) & (apag[y, ] == 1 & apag[, y] == 1))
indM <- setdiff(indM, c(x,y,z)) ## just to be sure
for (m in indM) {
## in the matrix the first column is always smaller than the third
unshTripl <- cbind(unshTripl, c(x., m, y.))
unshVect <- c(unshVect, triple2numb(p, x., m, y.))
## per default this new triple is set as TRUE in trueVstruct
trueVstruct <- c(trueVstruct, TRUE)
}
## case 2: an existent unshielded triple has been destroyed
## case 2.a): we had q-x-y or y-x-q in the matrix but not anymore
indQ <- which((apag[x, ] == 1 & apag[, x] == 1) & (apag[y, ] == 0 & apag[, y] == 0))
indQ <- setdiff(indQ, c(x,y,z)) ## just to be sure
for (q in indQ) {
## define the triple as FALSE in trueVstruct
delTripl <- unshVect == (
if (q < y) triple2numb(p, q, x, y) else triple2numb(p, y, x, q))
## if we haven't checked the triple yet, define it as FALSE
if (any(delTripl))
trueVstruct[which.max(delTripl)] <- FALSE
}
## case 2.b): we had r-y-x or x-y-r in the matrix but not anymore
indR <- which((apag[x, ] == 0 & apag[, x] == 0) & (apag[y, ] == 1 & apag[, y] == 1))
indR <- setdiff(indR, c(x,y,z)) ## just to be sure
## ^^^ (had typo here: 'indQ' !!)
for (r in indR) {
## define the triple as FALSE in trueVstruct
delTripl <- unshVect == (
if (r < x) triple2numb(p, r, y, x) else triple2numb(p, x, y, r))
if (any(delTripl))
trueVstruct[which.max(delTripl)] <- FALSE
}
} ## if (pv1 .. indepTest(..) )
## Check z-y ---------------------------------------------------------------
del2 <- FALSE
## check first z and y given the whole sepset(x,z)
if (indepTest(z, y, SepSet, suffStat) >= alpha) {
del2 <- TRUE ## will have to set this triple as FALSE in trueVstruct
## z and y are independent, then find the minimal sepset
Done <- FALSE
Ord <- 0L
while (!Done && Ord < nSep) {
Ord <- Ord + 1L
## all combinations of SepSet of size Ord
S.j <- if (Ord == 1 && nSep == 1) matrix(SepSet,1,1) else combn(SepSet, Ord)
for (i in seq_len(ncol(S.j))) {
pval <- indepTest(z, y, S.j[,i], suffStat)
if (verbose) cat("x=", z, " y=", y, " S=", S.j[,i], ": pval =", pval, "\n")
if (pval >= alpha) {
## delete edge and save set in sepset
apag[z, y] <- apag[y, z] <- 0
sepset[[z]][[y]] <- sepset[[y]][[z]] <- S.j[,i]
Done <- TRUE
break
}
}
} ## while( . )
## case 1: before we had a triangle and now it is an unshielded triple z-m-y
indM <- which((apag[z, ] == 1 & apag[, z] == 1) & (apag[y, ] == 1 & apag[, y] == 1))
indM <- setdiff(indM,c(x,y,z)) ## just to be sure
for (m in indM) {
## in the matrix the first column is always smaller than the third
unshTripl <- cbind(unshTripl, c(y_, m, z_))
unshVect <- c(unshVect, triple2numb(p, y_, m, z_))
## per default the triple is defined as TRUE
trueVstruct <- c(trueVstruct,TRUE)
}
## case 2: an existent unshielded triple has been destroyed
## case 2.a): we had q-z-y or y-z-q in the matrix but not anymore
indQ <- which((apag[z, ] == 1 & apag[, z] == 1) & (apag[y, ] == 0 & apag[, y] == 0))
indQ <- setdiff(indQ, c(x,y,z)) ## just to be sure
for (q in indQ) {
## define the triple as FALSE in trueVstruct
delTripl <- unshVect == (if (q < y) triple2numb(p, q, z, y) else triple2numb(p, y, z, q))
## if we haven't checked the triple yet, save it as FALSE
if (any(delTripl))
trueVstruct[which.max(delTripl)] <- FALSE
}
## case 2.b): we had r-y-z or z-y-r in the matrix but not anymore
indR <- which((apag[z, ] == 0 & apag[, z] == 0) & (apag[y, ] == 1 & apag[, y] == 1))
indR <- setdiff(indR, c(x,y,z)) ## just to be sure
## ^^^ (had typo here: 'indQ' !!)
for (r in indR) {
## define the triple as FALSE in trueVstruct
delTripl <- unshVect == (
if (r < z) triple2numb(p, r, y, z) else triple2numb(p, z, y, r))
if (any(delTripl))
trueVstruct[which.max(delTripl)] <- FALSE
}
}
## if at least one edge has been deleted this is not a future v-structure
if (any(del1, del2)) trueVstruct[k] <- FALSE
} ## if (nSep != 0)
##
## ELSE: the sepset is empty
## so surely <x,y,z> is an unshielded triple because they cannot be indep given the empty set
## nothing changed in sepset and in graph
## else{
## sepset <- sepset
## apag <- apag
## }
## recursion on the next column of unshTripl
## rec.res <- dep.triple(suffStat, indepTest, p, alpha, sepset, apag, unshTripl, unshVect, trueVstruct, k, verbose=verbose)
## save the modified objects
## unshTripl <- rec.res$triple
## unshVect <- rec.res$vect
## sepset <- rec.res$sepset
## apag <- rec.res$graph
## trueVstruct <- rec.res$trueVstruct
}
}## for ( k )
list(triple = unshTripl, vect = unshVect, sepset = sepset,
apag = apag, trueVstruct = trueVstruct)
} ## {dep.triple}
##' Check the dependence of the edges for R4
##' only called from udag2apag()
checkEdges <- function(suffStat, indepTest, alpha, apag, sepset, path,
unfVect = NULL, verbose = FALSE)
{
## Purpose: check if every edge on the path should exist in R4
## ----------------------------------------------------------------------
## Values: - updated sepset and apag
## - deleted==FALSE no edge has been deleted on the path
## ==TRUE the discriminating path doesn't exist anymore
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 17 Aug 2010, 16:21
stopifnot((n.path <- length(path)) >= 2)
## did we delete an edge?
found <- FALSE
## conservative v-structures or not?
conservative <- (length(unfVect) > 0)
## set that at the beginning there are no new unfaithful v-structures
unfTripl <- NULL
## define the sepset
SepSet.tot <- unique(c(sepset[[path[1]]][[path[n.path]]],
sepset[[path[n.path]]][[path[1]]]))
if (length(SepSet.tot) != 0) {
if (verbose)
cat("\nCheck discriminating path:", path,
"for dependence of any edge given sepset", SepSet.tot,"\n")
p <- nrow(apag)
## check every edge on the path for independence given every possible subset of SepSet
for (i in seq_len(n.path-1)) {
x <- path[i]
y <- path[i+1]
SepSet <- setdiff(SepSet.tot, c(x,y))
x. <- min(x,y)
y. <- max(x,y)
if (verbose >= 2)
cat("Edge: ",x,"*-*",y, "; Sepset=", SepSet, "; |S|=", length(SepSet),"\n")
if (length(SepSet) != 0) {
j <- 0
while (!found && j < length(SepSet)) {
j <- j + 1
## all combinations of SepSet of size j
S.j <- if (j == 1 && length(SepSet) == 1) matrix(SepSet,1,1) else combn(SepSet, j)
ii <- 0
while (!found && ii < ncol(S.j)) {
ii <- ii + 1
pval <- indepTest(x, y, S.j[,ii], suffStat)
if (verbose)
cat("x=", x, " y=", y, " S=", S.j[,ii], ": pval =", pval,"\n")
if (pval >= alpha) {
if (verbose) cat("Independence found: delete edge between",x,"and",y,"\n")
found <- TRUE
## delete edge and save set in sepset
apag[x, y] <- apag[y, x] <- 0
sepset[[x]][[y]] <- sepset[[y]][[x]] <- S.j[,ii]
## before we had a triangle and now it is an unshielded triple x-m-y
indM <- setdiff(which(apag[x, ] != 0 & apag[, x] != 0 &
apag[y, ] != 0 & apag[, y] != 0),
c(x,y))## just to be sure
## create the list with all the new unshielded triples to be tested
if ((nI <- length(indM)) > 0) {
triplM <- matrix(integer(), 3, nI)
newVect <- numeric(nI)
for (jj in seq_len(nI)) {
m <- indM[jj]
triplM[,jj] <- c(x.,m,y.)
newVect[jj] <- triple2numb(p, x.,m,y.)
}
## new unshielded triple to be tested
r.v <- rfci.vStruc(suffStat, indepTest, alpha, sepset, apag,
unshTripl = triplM, unshVect = newVect,
conservative = conservative, verbose = verbose)
## save the modified graph g in apag
apag <- r.v$amat
## save the new sepset
sepset <- r.v$sepset
## save the new unfTripl, since we tested new v-structures and some can be unfaithful
## for the conservative version
unfTripl <- r.v$unfTripl
}
}
} ## while(!found && i < *)
} ## while(!found && j < *)
}
} ## for(i ....)
}
## if SepSet is the empty set do nothing because surely the vertices are dependent
list(deleted = found, apag = apag, sepset = sepset, unfTripl = unfTripl)
}
##' called only from rfci()
udag2apag <- function (apag, suffStat, indepTest, alpha, sepset,
rules = rep(TRUE, 10), unfVect = NULL,
verbose = FALSE)
### FIXME part of this is cut-n-paste from udag2pag()
{
## Purpose: use the 10 orientation rules to orient the skeleton. R4 about
## discriminating paths also checks every edge for dependence
## given all subsets of the separating set.
## Note that the preliminaries v-structures are already oriented
## in apag
## ----------------------------------------------------------------------
## Arguments:
## - apag: adjacency matrix outputs of the function rfci.vStruc
## - suffStat, indepTest, alpha: arguments required for the tests in R4
## - sepset: list of all separation sets
## - rules: array of length 10 wich contains TRUE or FALSE corrsponding
## to each rule. TRUE means the rule will be applied.
## If rules==FALSE only R0 (minimal pattern) will be used
## - unfVect: Vector with ambiguous triples (coded as number using triple2numb)
## - verbose: 0 - no output, 1 - detailed output
## ----------------------------------------------------------------------
## Values: updated apag (oriented) and sepset
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 21 Oct 2010, 15:13
if (any(apag != 0)) {
p <- ncol(apag)
old_apag1 <- matrix(0, nrow = p, ncol = p)
while (any(old_apag1 != apag)) {
old_apag1 <- apag
##-- R1 ------------------------------------------------------------------
if (rules[1]) {
ind <- which((apag == 2 & t(apag) != 0), arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
a <- ind[i, 1]
b <- ind[i, 2]
indC <- which(apag[b, ] != 0 & apag[, b] == 1 &
apag[a, ] == 0 & apag[, a] == 0)
indC <- setdiff(indC, a)
if (length(indC) > 0) {
## normal version
if (length(unfVect) == 0) {
apag[b, indC] <- 2
apag[indC, b] <- 3
if (verbose) {
cat("\nRule 1","\n")
cat("Orient:", a, "*->", b, "o-*", indC,
"as:", b, "->", indC, "\n")
}
}
## conservative
else
for (j in seq_along(indC)) {
c <- indC[j]
## check that a-b-c faithful
if (!any(unfVect == triple2numb(p,a,b,c), na.rm = TRUE) &&
!any(unfVect == triple2numb(p,c,b,a), na.rm = TRUE)) {
apag[b, c] <- 2
apag[c, b] <- 3
if (verbose) {
cat("\nRule 1","\n")
cat("Conservatively orient:", a, "*->", b, "o-*",
c, "as:", b, "->", c, "\n")
}
}
}
}
}
}
##-- R2 ------------------------------------------------------------------
if (rules[2]) {
ind <- which((apag == 1 & t(apag) != 0), arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
a <- ind[i, 1]
c <- ind[i, 2]
indB <- which(((apag[a, ] == 2 & apag[, a] == 3) &
(apag[c, ] != 0 & apag[, c] == 2)) |
((apag[a, ] == 2 & apag[, a] != 0) &
(apag[c, ] == 3 & apag[, c] == 2)))
if (length(indB) > 0) {
apag[a, c] <- 2
if (verbose) {
cat("\nRule 2","\n")
cat("Orient:", a, "->", indB, "*->",
c, "or", a, "*->", indB, "->", c, "with",
a, "*-o", c, "as:", a, "*->", c, "\n")
}
}
}
}
##-- R3 ------------------------------------------------------------------
if (rules[3]) {
ind <- which(apag != 0 & t(apag) == 1, arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
b <- ind[i, 1]
d <- ind[i, 2]
indAC <- which(apag[b, ] != 0 & apag[, b] == 2 &
apag[, d] == 1 & apag[d, ] != 0)
if (length(indAC) >= 2) {
if (length(unfVect) == 0) { ## normal version
counter <- 0
while ((counter < (length(indAC) - 1)) &&
(apag[d, b] != 2)) {
counter <- counter + 1
ii <- counter
while ((ii < length(indAC)) && (apag[d, b] != 2)) {
ii <- ii + 1
if (apag[indAC[counter], indAC[ii]] == 0 &&
apag[indAC[ii], indAC[counter]] == 0) {
apag[d, b] <- 2
if (verbose)
cat("\nRule 3","\nOrient:", d, "*->", b, "\n")
}
}
}
}
else { ## conservative version
comb.indAC <- combn(indAC,2)
for (j in seq_len(ncol(comb.indAC))) {
a <- comb.indAC[1,j]
c <- comb.indAC[2,j]
if (apag[a,c] == 0 && apag[c,a] == 0 && c != a) {
## check faithfulness a-d-c
if (!any(unfVect == triple2numb(p,a,d,c), na.rm = TRUE) &&
!any(unfVect == triple2numb(p,c,d,a), na.rm = TRUE)) {
apag[d, b] <- 2
if (verbose)
cat("\nRule 3","\nConservatively orient:", d, "*->", b, "\n")
}
}
}
}
}
}
}
##-- R4 ------------------------------------------------------------------
if (rules[4]) {
ind <- which((apag != 0 & t(apag) == 1), arr.ind = TRUE)## b o-* c
while (length(ind) > 0) {
b <- ind[1, 1]
c <- ind[1, 2]
ind <- ind[-1,, drop = FALSE]
## find all a s.t. a -> c and a <-* b
indA <- which((apag[b, ] == 2 & apag[, b] != 0) & (apag[c, ] == 3 & apag[, c] == 2))
## chose one a s.t. the initial triangle structure exists and the edge hasn't been oriented yet
while (length(indA) > 0 && apag[c,b] == 1) {
a <- indA[1]
indA <- indA[-1]
## Done is TRUE if either we found a minimal path or no path exists for this triangle
Done <- FALSE
while (!Done && apag[a,b] != 0 && apag[a,c] != 0 && apag[b,c] != 0) {
## find a minimal disciminating path for a,b,c
md.path <- minDiscrPath(apag, a,b,c, verbose = verbose)
N.md <- length(md.path)
## if the path doesn't exists, we are done with this triangle
if (N.md == 1) {
Done <- TRUE
}
else {
## a path exists and needs to be checked and maybe oriented
## first check every single edge for independence
chkE <- checkEdges(suffStat, indepTest, alpha = alpha,
apag = apag, sepset = sepset, path = md.path,
unfVect = unfVect, verbose = verbose)
## save updated graph, sepset,and UnfVect
sepset <- chkE$sepset
apag <- chkE$apag
unfVect <- c(unfVect, chkE$unfTripl)
## no edge deleted ----> orient the edges
if (!chkE$deleted) {
## if b is in sepset
if (b %in% sepset[[md.path[1]]][[md.path[N.md]]] ||
b %in% sepset[[md.path[N.md]]][[md.path[1]]]) {
if (verbose) {
cat("\nRule 4","\n")
cat("There is a discriminating path between",
md.path[1], "and", c, "for", b, ",and", b, "is in Sepset of",
c, "and", md.path[1], ". Orient:", b, "->", c, "\n")
}
apag[b, c] <- 2
apag[c, b] <- 3
}
else {
## if b is not in sepset
if (verbose) {
cat("\nRule 4","\n")
cat("There is a discriminating path between:",
md.path[1], "and", c, "for", b, ",and", b, "is not in Sepset of",
c, "and", md.path[1], ". Orient", a, "<->", b, "<->",
c, "\n")
}
apag[a, b] <- apag[b, c] <- apag[c, b] <- 2
}
Done <- TRUE
}
}
} ## while(!Done && ...)
}
}
}
##-- R5 ------------------------------------------------------------------
if (rules[5]) {
ind <- which((apag == 1 & t(apag) == 1), arr.ind = TRUE) ## a o-o b
while (length(ind) > 0) {
a <- ind[1, 1]
b <- ind[1, 2]
ind <- ind[-1,, drop = FALSE]
## find all c s.t. a o-o c and c is not connected to b
indC <- which((apag[a, ] == 1 & apag[, a] == 1) & (apag[b, ] == 0 & apag[, b] == 0))
## delete b since it is surely in indC
indC <- setdiff(indC, b)
## find all d s.t. b o-o d and d is not connected to a
indD <- which((apag[b, ] == 1 & apag[, b] == 1) & (apag[a, ] == 0 & apag[, a] == 0))
## delete a since it is surely in indD
indD <- setdiff(indD, a)
if (length(indC) > 0 && length(indD) > 0) {
counterC <- 0
while ((counterC < length(indC)) && apag[a, b] == 1) {
counterC <- counterC + 1
c <- indC[counterC]
counterD <- 0
while ((counterD < length(indD)) && apag[a, b] == 1) {
counterD <- counterD + 1
d <- indD[counterD]
## this is the easiest one
if (apag[c, d] == 1 && apag[d, c] == 1) {
## normal version
if (length(unfVect) == 0) {
apag[a, b] <- apag[b, a] <- 3
apag[a, c] <- apag[c, a] <- 3
apag[c, d] <- apag[d, c] <- 3
apag[d, b] <- apag[b, d] <- 3
if (verbose) {
cat("\nRule 5","\n")
cat("There exists an uncovered circle path between",
a, "and", b, ". Orient", a, "-", b, "and", a, "-", c, "-", d, "-", b, "\n")
}
}
## conservative
else {
## check that every triple on the circle is faithful
path2check <- c(a,c,d,b)
if (faith.check(path2check, unfVect, p)) {
apag[a, b] <- apag[b, a] <- 3
apag[a, c] <- apag[c, a] <- 3
apag[c, d] <- apag[d, c] <- 3
apag[d, b] <- apag[b, d] <- 3
if (verbose) {
cat("\nRule 5","\n")
cat("There exists a faithful uncovered circle path between", a, "and", b,
". Conservatively orient:", a, "-", b, "and", a, "-", c, "-", d, "-", b, "\n")
}
}
}
}
## search with a breitensuche a minimal uncovered circle path
else {
## Find a minimal uncovered circle path for these a,b,c, and d.
## This path has already been checked to be uncovered and
## to be faithful for the conservative case
ucp <- minUncovCircPath(p, pag = apag, path = c(a,c,d,b),
unfVect = unfVect, verbose = verbose)
## there is a path ---> orient
if (length(ucp) > 1) {
## orient every edge on the path as --
n <- length(ucp)
apag[ucp[1], ucp[n]] <- apag[ucp[n], ucp[1]] <- 3 ## a--b
for (j in seq_len(length(ucp)-1)) {
apag[ucp[j], ucp[j + 1]] <- apag[ucp[j + 1], ucp[j]] <- 3 ## each edge on the path --
}
}
}
}
}
}
}
}
##-- R6 ------------------------------------------------------------------
if (rules[6]) {
ind <- which((apag != 0 & t(apag) == 1), arr.ind = TRUE)## b o-* c
for (i in seq_len(nrow(ind))) {
b <- ind[i, 1]
c <- ind[i, 2]
indA <- which(apag[b, ] == 3 & apag[, b] == 3)
if (length(indA) > 0) {
apag[c, b] <- 3
if (verbose)
cat("\nRule 6","\nOrient:", b, "o-*", c, "as", b, "-*", c, "\n")
}
}
}
##-- R7 ------------------------------------------------------------------
if (rules[7]) {
ind <- which((apag != 0 & t(apag) == 1), arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
b <- ind[i, 1]
c <- ind[i, 2]
indA <- which((apag[b, ] == 3 & apag[, b] == 1) &
(apag[c, ] == 0 & apag[, c] == 0))
indA <- setdiff(indA, c)
if (length(indA) > 0) {
if (length(unfVect) == 0) { ## normal version
apag[c, b] <- 3
if (verbose) {
cat("\nRule 7","\n")
cat("Orient", indA, "-o", b, "o-*", c, "as", b, "-*", c, "\n")
}
}
else { ## conservative
for (j in seq_along(indA)) {
a <- indA[j]
## check faithfulness of a-b-c
if (!any(unfVect == triple2numb(p,a,b,c), na.rm = TRUE) &&
!any(unfVect == triple2numb(p,c,b,a), na.rm = TRUE)) {
apag[c, b] <- 3
if (verbose) {
cat("\nRule 7","\n")
cat("Conservatively orient:", a, "-o", b, "o-*",
c, "as", b, "-*", c, "\n")
}
}
}
}
}
}
}
##-- R8 ------------------------------------------------------------------
if (rules[8]) {
ind <- which((apag == 2 & t(apag) == 1), arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
a <- ind[i, 1]
c <- ind[i, 2]
indB <- which(((apag[a, ] == 2 & apag[, a] == 3) |
(apag[a, ] == 1 & apag[, a] == 3)) &
(apag[c, ] == 3 & apag[, c] == 2))
if (length(indB) > 0) {
apag[c, a] <- 3
if (verbose) {
cat("\nRule 8","\n")
cat("Orient:", a, "->", indB, "->", c,
"or", a, "-o", indB, "->", c, "with",
a, "o->", c, "as", a, "->", c, "\n")
}
}
}
}
##-- R9 ------------------------------------------------------------------
if (rules[9]) {
ind <- which((apag == 2 & t(apag) == 1), arr.ind = TRUE) ## a o-> c
while (length(ind) > 0) {
a <- ind[1, 1]
c <- ind[1, 2]
ind <- ind[-1,, drop = FALSE]
## find all b s.t. a (o-)--(o>) b and b and c are not connected
indB <- which((apag[a, ] == 2 | apag[a, ] == 1) & (apag[, a] == 1 | apag[, a] == 3) & (apag[c, ] == 0 & apag[, c] == 0))
## delete c from indB since it is surely inside
indB <- setdiff(indB, c)
## chose one b s.t. the initial structure exists and the edge hasn't been oriented yet
while ((length(indB) > 0) && (apag[c,a] == 1)) {
b <- indB[1]
indB <- indB[-1]
## find a minimal uncovered pd path from initial (a, b, c) :
## cat("R9: a=", a, ", b=", b, ", c=", c,"\n")
upd <- minUncovPdPath(p, apag, a, b, c,
unfVect = unfVect, verbose = verbose)
## there is a path ---> orient it
if (length(upd) > 1) {
apag[c, a] <- 3
if (verbose) {
cat("\nRule 9", "\n")
cat("There exists an uncovered potentially directed path between", a, "and", c, ". Orient:", a, " ->",c, "\n")
}
}
}## while
}
}
##-- R10 ------------------------------------------------------------------
if (rules[10]) {
ind <- which((apag == 2 & t(apag) == 1), arr.ind = TRUE) ## a o-> c
while (length(ind) > 0) {
a <- ind[1, 1]
c <- ind[1, 2]
ind <- ind[-1,, drop = FALSE]
## find all b s.t. b --> c
indB <- which((apag[c, ] == 3 & apag[, c] == 2))
if (length(indB) >= 2) {
counterB <- 0
while (counterB < length(indB) && (apag[c, a] == 1)) {
counterB <- counterB + 1
b <- indB[counterB]
indD <- setdiff(indB, b)
counterD <- 0
while ((counterD < length(indD)) && (apag[c, a] == 1)) {
counterD <- counterD + 1
d <- indD[counterD]
## this is the easiest one
if ((apag[a, b] == 1 || apag[a, b] == 2) &&
(apag[b, a] == 1 || apag[b, a] == 3) &&
(apag[a, d] == 1 || apag[a, d] == 2) &&
(apag[d, a] == 1 || apag[d, a] == 3) &&
(apag[d, b] == 0 && apag[b, d] == 0)) {
if (length(unfVect) == 0) { ## normal version
apag[c, a] <- 3
if (verbose)
cat("\nRule 10","\nOrient:", a, "->", c, "\n")
}
else { ## conservative version
## check faithfulness of b-a-d
if (!any(unfVect == triple2numb(p,b,a,d), na.rm = TRUE) &&
!any(unfVect == triple2numb(p,d,a,b), na.rm = TRUE)) {
apag[c, a] <- 3
if (verbose)
cat("\nRule 10","\nConservatively orient:", a, "->", c, "\n")
}
}
}
## search with a breitensuche two minimal uncovered circle paths
else {
## find all x s.t. a (o-)--(o>) x
indX <- which((apag[a, ] == 1 | apag[a, ] == 2) &
(apag[, a] == 1 | apag[, a] == 3), arr.ind = TRUE)
indX <- setdiff(indX, c)
if (length(indX >= 2)) {
i1 <- 0
while (i1 < length(indX) && apag[c, a] == 1) {
i1 <- i1 + 1
# pos.1 <- indA[i1]
pos.1 <- indX[i1]
indX2 <- setdiff(indX, pos.1)
i2 <- 0
while (i2 < length(indX2) && apag[c, a] == 1) {
i2 <- i2 + 1
pos.2 <- indX2[i2]
## cat("R10.1: a=", a, ", b=", b, ", c=", c,"\n")
tmp1 <- minUncovPdPath(p, apag, a, pos.1, b,
unfVect = unfVect, verbose = verbose)
## cat("R10.2: a=", a, ", b=", b, ", c=", c,"\n")
tmp2 <- minUncovPdPath(p, apag, a, pos.2, d,
unfVect = unfVect, verbose = verbose)
## we found 2 uncovered pd paths
if (length(tmp1) > 1 && length(tmp2) > 1 &&
pos.1 != pos.2 && apag[pos.1, pos.2] == 0) {
if (length(unfVect) == 0) { ## normal version
apag[c, a] <- 3
if (verbose)
cat("\nRule 10","\nOrient:", a, "->", c, "\n")
}
else { ## conservative version
if (!any(unfVect == triple2numb(p,pos.1, a, pos.2), na.rm = TRUE) &&
!any(unfVect == triple2numb(p,pos.2, a, pos.1), na.rm = TRUE)) {
apag[c, a] <- 3
if (verbose)
cat("\nRule 10","\nConservatively orient:", a, "->", c, "\n")
}
}
}
}
}
}
}
}
}
}
}
} ## rules[10]
}
}
list(graph = apag, sepset = sepset)
} ## {udag2apag}
######################################################################
## Oracle FCI (fast)
#######################################################################
ancTS <- function(g) {
## Purpose: compute the ancestors of each node in the graph
## ----------------------------------------------------------------------
## Arguments: - g: graph in topological order (e.g. produced with randomDAG)
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 6 Aug 2012, 10:57
stopifnot((p <- numNodes(g)) >= 2)
m <- as(g, "matrix")
an <- pa <- vector("list", p)
for (i in 2:p) {
pa[[i]] <- pa.i <- which(m[1:(i-1),i] != 0)
if (length(pa.i) > 0) {
tmp <- c(pa.i)
## FIXME: unlist(lapply(pa.i, function(.) an[[.]])) :
for (p.ij in pa.i)
tmp <- c(tmp, an[[p.ij]])
an[[i]] <- sort(unique(tmp))
}
}
an
}
dag2pag <- function(suffStat, indepTest, graph, L, alpha, rules = rep(TRUE,10), verbose = FALSE) {
## Purpose: Perform fat oracle FCI-Algorithm, i.e., estimate PAG from
## the true DAG
## ----------------------------------------------------------------------
## Arguments:
## - suffStat, indepTest: info for the tests
## - graph: the true DAG
## - L: array containing the latent variables (columns in the adjacency matrix)
## - alpha: Significance level of individual partial correlation tests
## - rules: array of length 10 wich contains TRUE or FALSE corrsponding
## to each rule. TRUE means the rule will be applied.
## If rules==FALSE only R0 (minimal pattern) will be used
## - verbose: 0 - no output, 1 - detailed output
## ----------------------------------------------------------------------
## Author: Diego Colombo, 2011
p <- numNodes(graph)
cl <- match.call()
## find the ancestor sets
ancList <- ancTS(graph)
if (verbose) {
cat("Compute Skeleton\n================\n")
}
## find the skeleton
skel <- skeleton.dag2pag(suffStat, indepTest, graph,
ancList, L, alpha, verbose = verbose)
G <- as(skel@graph, "matrix")
sepset <- skel@sepset
pMax <- skel@pMax
n.edgetestsSKEL <- skel@n.edgetests
max.ordSKEL <- skel@max.ord
allPdsep <- NA
## tripleList <- NULL
n.edgetestsPD <- 0
max.ordPD <- 0
allPdsep <- vector("list", p-length(L))
## if (sum(G) == 0) {
## Gobject <- new("graphNEL", nodes = as.character(1:(p-length(L))))
## }
## else {
## colnames(G) <- rownames(G) <- as.character(1:(p-length(L)))
## Gobject <- as(G, "graphNEL")
## }
if (sum(G) != 0)
colnames(G) <- rownames(G) <- as.character(seq_len(p-length(L)))
if (verbose) {
cat("\nDirect egdes:\n=============\nUsing rules:", which(rules),
"\nCompute collider:\n")
}
res <- if (numEdges(skel@graph) > 0)
udag2pag(pag = G, sepset, rules = rules, verbose = verbose)
else G
new("fciAlgo", amat = res, call = cl, n = integer(0),
max.ord = as.integer(max.ordSKEL), max.ordPDSEP = as.integer(max.ordPD),
n.edgetests = n.edgetestsSKEL, n.edgetestsPDSEP = n.edgetestsPD,
sepset = sepset, pMax = pMax, allPdsep = allPdsep)
} # {dag2pag}
##' Perform undirected part of oracle FCI-Algorithm, i.e.,
##' find skeleton of PAG given the true DAG
##'
##' @title
##' @param suffStat info for the tests
##' @param indepTest info for the tests
##' @param graph the true DAG
##' @param ancList list containing the ancestors of each node in the graph
##' @param L array containing the latent variables (columns in the adjacency matrix)
##' @param alpha Significance level of individual partial correlation tests
##' @param NAdelete delete edge if pval=NA (for discrete data)
##' @param verbose 0 - no output, 1 - detailed output
##' @return "pcAlgo" object : (G, sepset, pMax, ord, n.edgetests)
##' @author Diego Colombo, 2011; speedup: Martin Maechler, Nov.2013
skeleton.dag2pag <- function(suffStat, indepTest, graph, ancList, L, alpha,
NAdelete = TRUE, verbose = FALSE)
{
## Currently exported but undocumented, used only in dag2pag()
new.ord <- function(start, old, L) {
seq_start <- 1:start
tmp <- setdiff(seq_start,L) ## <- independent of old -- FIXME speed
new <- rep(0, length(old))
for (i in seq_along(old)) {
new[i] <- which(tmp == old[i])
}
return(new)
}
cl <- match.call()
pval <- NULL
p <- numNodes(graph)
stopifnot(2 <= (new.p <- p-length(L)))
sepset <- vector("list", new.p)
G <- matrix(TRUE, nrow = new.p, ncol = new.p)
diag(G) <- FALSE
for (iList in 1:new.p) sepset[[iList]] <- vector("list", new.p)
pMax <- matrix(-Inf, nrow = new.p, ncol = new.p)
diag(pMax) <- 1
## test independence given the ancestors
for (i in setdiff(1:(p-1), L)) { ## i.e. i is not in L
iL <- new.ord(p,i,L)
for (j in setdiff((i+1):p, L)) { ## i.e. j is not in L
cond.set <- c(ancList[[i]],ancList[[j]])
cond.set <- setdiff(cond.set,c(i,j,L))
pval <- indepTest(i, j, cond.set, suffStat)
jL <- new.ord(p,j,L)
if (verbose) {
cat("x=", iL, " y=", jL,
" S=", new.ord(p,cond.set,L),": pval =", pval, "\n")
}
if(is.na(pval)) pval <- as.numeric(NAdelete) ## == if(NAdelete) 1 else 0
if (pval > pMax[iL, jL]) {
pMax[iL, jL] <- pval
}
if (pval >= alpha) {
G[iL, jL] <- G[jL, iL] <- FALSE
sepset[[iL]][[jL]] <- new.ord(p,cond.set,L)
}
}
}
for (i in 1:(new.p - 1)) {
for (j in 2:new.p) {
pMax[i, j] <- pMax[j, i] <- max(pMax[i, j], pMax[j, i])
}
}
Gobject <- if (sum(G) == 0)
new("graphNEL", nodes = as.character(1:new.p))
else {
colnames(G) <- rownames(G) <- as.character(1:new.p)
as(G, "graphNEL")
}
new("pcAlgo", graph = Gobject, call = cl, n = integer(0),
max.ord = integer(0), n.edgetests = integer(0),
sepset = sepset, pMax = pMax, zMin = matrix(NA, 1, 1))
}
iplotPC <- function(pc.fit, labels = NULL) {
## igraph alternative to Rgraphviz (only for pcAlgo objects)
adjm <- wgtMatrix(getGraph(pc.fit), transpose = FALSE)
if (!is.null(labels)) dimnames(adjm) <- list(labels, labels)
g1 <- graph_from_adjacency_matrix( adjm )
plot.igraph(g1)
}
showEdgeList <- function(object, labels = NULL)
{
cat("\nEdge List: \n")
g <- getGraph(object)
if (is.null(labels)) labels <- nodes(g)
isDir <- isDirected(g)
wm <- wgtMatrix(g)
if(isDir && !is(object,"pcAlgo"))
stop("implementation only for 'pcAlgo', currently ...") ##-> Markus
## MM: in general, maybe rather look at each pair (i,j) in the lower triangular part of [W, t(W)]
wmU <- wm + t(wm) # weights for undirected e.
wmD <- t(wm - t(wm))# weights for directed e.
u <- which(wmU == 2 & upper.tri(wmU), arr.ind = TRUE)
cat("\n", if(isDir) "Undirected Edges" else "Undirected graph with Edges",
":\n", sep = "")
for (i in seq_len(nrow(u)))
cat(" ", paste(labels[u[i,1]], " --- ", labels[u[i,2]], "\n"))
if(isDir) {
d <- which(wmD == 1, arr.ind = TRUE)
d <- d[order(d[,1]),]
cat("\nDirected Edges:\n")
for (i in seq_len(nrow(d)))
cat(" ", paste(labels[d[i,1]], " --> ", labels[d[i,2]], "\n"))
} else {
d <- matrix(0,0,0)
}
invisible(list(undir = u, direct = d))
}
#######################################################################
## Generalized backdoor criterion
#######################################################################
visibleEdge <- function(amat, x, z)
{
## Purpose: check if the directed edge from x to z in a MAG or in a PAG
## is visible or not
## ----------------------------------------------------------------------
## Arguments: amat, x, z
## ----------------------------------------------------------------------
## Value: T/F
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 25 Apr 2012; simplification: Martin Maechler
## 1. scenario: there exists a vertex not adjacent to z with *---> x
## c *-> x --> z and c and z not connected :
hasC1 <- any(amat[x,] != 0 & amat[,x] == 2 & amat[z,] == 0)
## if there is at least one vertex
if (any(hasC1)) ## the edge is visible
return(TRUE)
## Otherwise:
## 2. scenario: there exists a collider path that is into x and
## every vertex on the path is a parent of z
## c <--> x --> z and c is a parent of z :
indC2 <- which(amat[x,] == 2 & amat[,x] == 2 &
amat[z,] == 3 & amat[,z] == 2)
for(c in indC2) {
## find a minimal discriminating path for c,x,z
if (length(minDiscrPath(amat, c,x,z)) > 1)
## a path exists
return(TRUE)
}
## nothing found: return
FALSE
}
possibleDe <- function(amat,x)
{
## Purpose: in a DAG, CPDAG, MAG, or PAG determine which nodes are
## possible descendants of x on definite status paths
## ----------------------------------------------------------------------
## Arguments:
## - amat: adjacency matrix of type amat.pag
## - x: node of interest
## ----------------------------------------------------------------------
## Value:
## - de.list: array containing the possible descendants of x
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 26 Apr 2012, 16:58
stopifnot(is.matrix(amat))
p <- nrow(amat)
is.de <- rep.int(FALSE, p) ##
## 1. case: x is a possible child of itself
is.de[x] <- TRUE
## 2. case: find all the possible children of x
indD <- which(amat[x,] != 0 & amat[,x] != 2 & !is.de) ## x (o,-)-* d
i.pr <- rep(x,length(indD))
while (length(indD) > 0) {
## next element in the queue
d <- indD[1]
indD <- indD[-1]
pred <- i.pr[1]
i.pr <- i.pr[-1]
is.de[d] <- TRUE
a.d <- amat[,d]
a.d.p <- a.d[pred]
## find all possible children of d not visited yet
indR <- which(amat[d,] != 0 & a.d != 2 & !is.de) ## d (o,-)-* r
for(j in seq_along(indR)) {
## check that the triple <pred,d,r> is of a definite status
## 1. d is a collider on this subpath; this is impossible
## because the edge between d and r cannot be into d
## 2. d is a definite non-collider
r <- indR[j]
if (a.d.p == 3 || a.d[r] == 3 ||
(a.d.p == 1 && a.d[r] == 1 && amat[pred,r] == 0)) {
## update the queues
indD <- c(indD, r)
i.pr <- c(i.pr, d)
}
}
}
## return 'de.list' :
which(is.de)
} ## {possibleDe}
dreach <- function(x, y, amat, verbose = FALSE)
{
## Purpose: Compute d-sep(x,y) ("dsep")
## !!!!! WE DO NOT ASSUME SELECTION VARIABLES HENCE NO --- EDGES IN A MAG!!!!
## ----------------------------------------------------------------------
## Arguments:
## - x, y: nodes of which dsep must be computed
## - amat: adjacency matrix of a MAG
## amat[i,j] = 0 iff no edge btw i,j
## amat[i,j] = 3 iff i *-- j
## amat[i,j] = 2 iff i *-> j
## - verbose: Show checked node sequence
## ----------------------------------------------------------------------
## Value:
## - DSEP: set containing the nodes in D-SEP(x,y)
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 31 Jan 2013, 11:04
## check: quadratic; x in V; edgemarks ok; non-zeroes symmetric
stopifnot(is.matrix(amat), (p <- nrow(amat)) == ncol(amat),
x <= p, amat %in% c(0,2,3),
## The non-zero entries in amat must be symmetric:
(aN0 <- amat != 0) == t(aN0))
## compute the ancestors of x and y
amat.an <- amat
amat.t <- amat + t(amat)
## because we have only ---> and <--> edges, in amat.t we have either 5s (--->) or 4s (<-->)
## delete all the bi-directed edges
amat.an[which(amat.t == 4)] <- 0
## transform the directed edges from 3 and 2 in 1 and 0
amat.an[which(amat.an == 3)] <- 0
amat.an[which(amat.an == 2)] <- 1
dir.graph <- as(amat.an, "graphNEL")
john.pairs <- johnson.all.pairs.sp(dir.graph)
anc.y <- anc.x <- rep(FALSE, p)
anc.y[which(john.pairs[,y] < Inf)] <- TRUE
anc.x[which(john.pairs[,x] < Inf)] <- TRUE
## the set containing the ancestors of either x or y
anc <- anc.x | anc.y
anc[x] <- FALSE
## prepare the setting for the search
amat.tmp <- amat
nb <- which(amat[x,] != 0 & anc)
Q <- nb
P <- rep.int(x,length(Q))
DSEP <- nb
amat.tmp[x,nb] <- 0 ## delete edge to nbrs
while(length(Q) > 0) {
## Invariants:
## ===========
## (A1) length(Q) == length(P) > 0
## (A2) non-zero in amat.tmp -> non-zero in amat [no non-zero added]
## (A3) Q[i] and P[i] are adjacent in amat [using (A2)]
if (verbose) {
cat("\n-------------","\n")
cat("Queue Q:",Q,"\n")
cat("Queue P:",P,"\n")
}
a <- Q[1]
Q <- Q[-1]
pred <- P[1] ## not empty because of (A1)
P <- P[-1]
if (verbose) cat("Select",pred,"towards",a,"\n")
nb <- which(amat.tmp[a,] != 0 & anc) ## (*)
for (i in seq_along(nb)) {
b <- nb[i]
## Guaranteed: pred-a-b are a path because of (A3)
## if a is a collider, b is in D-SEP of x
if (amat[pred,a] == 2 && amat[b,a] == 2) {
amat.tmp[a,b] <- 0 ## remove b out of adj(a) in amat.tmp (+)
Q <- c(Q,b)
P <- c(P,a)
DSEP <- c(DSEP,b)
}
}
}
sort(unique(DSEP))
} ## {dreach}
pag2magAM <- function(amat.pag, x, max.chordal = 10, verbose = FALSE)
{
## Purpose: transform a PAG/CPDAG into a valid MAG/DAG using the arrowhead
## augmentation from Zhang, without orienting additional edges
## into x and then orient any chordal component into a DAG
## ----------------------------------------------------------------------
## Arguments:
## - amat.pag: adjacency matrix of the PAG/CPDAG
## - x: node of interest
## ----------------------------------------------------------------------
## Value:
## - valid.DAG.mat: adjacency matrix corresponding to the valid MAG
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 12 Apr 2013, 14:24;
## Tweaks by Martin Maechler, bug fix by Joris Mooij
## deal with indexing issues
rn<-rownames(amat.pag)
cn<-colnames(amat.pag)
rownames(amat.pag)<-c(1:dim(amat.pag)[1])
colnames(amat.pag)<-c(1:dim(amat.pag)[1])
## 1. step: arrowhead augmentation
## find all o-> edges in the PAG
indA <- which((amat.pag == 2 & t(amat.pag) == 1), arr.ind = TRUE)
for (i in seq_len(nrow(indA))) {
a <- indA[i, 1]
b <- indA[i, 2]
amat.pag[b,a] <- 3L
}
## because we don't allow selection variables in the generalized backdoor
## criterion these kind of edges should not be present BUT YOU NEVER KNOW...
## find all o-- edges in the PAG
indB <- which(amat.pag == 3 & t(amat.pag) == 1, arr.ind = TRUE)
for (i in seq_len(nrow(indB))) {
a <- indB[i, 1]
b <- indB[i, 2]
amat.pag[b,a] <- 2L
}
## 2.step: find all the chordal components in the updated graph
## find the adjacency matrix that contains
amat.undir <- amat.dir <- amat.pag
amat.t <- amat.pag + t(amat.pag)
## we are interested only in the o-o edges
## delete all the other edges
amat.undir[amat.t != 2] <- 0L
amat.dir [amat.t == 2] <- 0L
g.undir <- as(amat.undir,"graphNEL")
## Get all connected components [maybe should rather keep labels ??]
conn.comp <- lapply(connectedComp(g.undir), as.numeric)
if(verbose) {
lc <- vapply(conn.comp, length, 1L)
t2 <- if(any(lc == 1)) gettextf(" and %d singletons", sum(lc == 1)) else ""
cat(gettextf("The undirected graph has %d connected components%s",
sum(lc > 1), t2),"\n")
}
valid.DAG.mat <- amat.undir
## get all semilocal extensions of the undirected cpdag
for (cci in conn.comp) if (length(cci) > 1) {
if(length(cci) > max.chordal) return(NULL)
## check whether the component is chordal
am.u.ii <- amat.undir[cci,cci]
if(!is_chordal(graph_from_adjacency_matrix(am.u.ii, "undirected"),
fillin = TRUE)$chordal)
return(NULL)
## else: not extendable or too large to handle
am. <- my.SpecialDag(amat.undir, a=am.u.ii, X=x, verbose=verbose)
valid.DAG.mat <- valid.DAG.mat * am.
} # if() ..end for
## add directed edges and return "valid.DAG.mat":
amat.mag <- valid.DAG.mat + amat.dir
rownames(amat.mag)<-rn
colnames(amat.mag)<-cn
## return mag
amat.mag
} ## {pag2magAM}
##' Auxiliary for pag2magAM()
my.SpecialDag <- function (gm, a, X, verbose = FALSE)
{
while (sum(a) != 0 ) {
sinks <- find.sink(a)
if (verbose) {
cat("Main Call: ################## \n")
print(gm)
print(a)
cat("Sinks: ", sinks, "\n")
}
for (x in sinks) {
if (verbose)
cat("Try removing", x, " in a.\n")
if (adj.check(a, x) & as.numeric(rownames(a)[x]) != X) {
inc.to.x <- a[, x] == 1 & a[x, ] == 1
if (any(inc.to.x)) {
real.inc.to.x <- as.numeric(rownames(a)[inc.to.x])
real.x <- as.numeric(rownames(a)[x])
gm[real.x, real.inc.to.x] <- 3
gm[real.inc.to.x, real.x] <- 2
}
if (verbose) {
cat("Removed sink", as.numeric(rownames(a)[x]),
"in g (", x, "in a).\n")
cat("New graphs: \n")
print(gm)
print(a)
}
a <- a[-x, -x]
break
}
}
}
gm
} ## {my.SpecialDag}
backdoor <- function(amat, x, y, type = "pag", max.chordal = 10, verbose = FALSE)
{
## Purpose: for a given pair of nodes (x,y) and a given graph (DAG, CPDAG,
## MAG, or PAG) estimate if the causal effect of x on y using the
## generalized backdoor criterion is identifiable or not. In a
## first step we check if the effect is identifiable or not. If
## it is identifiable we compute the set W that satisfies the
## generalized backdoor criterion. If it is not identifiable
## the output is NA
## ----------------------------------------------------------------------
## Arguments:
## - amat: adjacency matrix of the corresponding graph
## - x, y: nodes for which we want to estimate the causal effect of x on y
## - type: specifies the type of graph of the adjacency matrix amat. It
## can be a DAG (type="dag"), a CPDAG (type="cpdag"), a MAG
## (type="mag"), or a PAG (type="pag")
## ----------------------------------------------------------------------
## Value:
## - cEffect: causal effect of x on y (either NA not identifiable or a number)
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 12 Apr 2013, 16:06
stopifnot (dim(amat)[1] > 0, x != y, length(type) == 1)
set.w <- NA
if (type == "dag" || type == "cpdag") {
## transfor each directed edge from 0-1 to 2-3 in the adjacency matrix
ind <- which((amat == 1 & t(amat) == 0), arr.ind = TRUE) ## a -> b
for (i in seq_len(nrow(ind))) {
a <- ind[i, 1]
b <- ind[i, 2]
amat[a,b] <- 2
amat[b,a] <- 3
}
}
## check that x and y belong to the same connected component
## compute the connected components of the whole graph
conn.comp <- lapply(connectedComp(as(amat, "graphNEL")),
as.numeric)
found.conncomp <- FALSE
for(ic in seq_along(conn.comp))
if (x %in% conn.comp[[ic]] & y %in% conn.comp[[ic]]) {
found.conncomp <- TRUE
break ## we found one {FIXME: should use info conn.comp[[ic]] ! }
}
## if x and y are not in the same connected component ---> empty set
if (!found.conncomp)
return( NULL )
## else :
## 1. generate a MAG/DAG belonging to the equivalence class of the
## PAG or a CPDAG without orienting additional edges into X
amat.r <- if (type == "cpdag" || type == "pag")
pag2magAM(amat, x, max.chordal = max.chordal, verbose = verbose)
else amat
## 2. compute the truncated corresponding graph
## 2.a) find all the visible edges in the original graph that are out of X
## 2.b) all the definitely visible edges out of X have to be deleted
## in the graph constructed previously
indD <- which(amat[x,] == 2 & amat[,x] == 3) ## x--> d
## CASE A: in a CPDAG or DAG every directed edge out of X is visible
## then delete them all
if (type == "cpdag" || type == "dag") {
for (z in indD)
## delete visible edges out of x edges
amat.r[z,x] <- amat.r[x,z] <- 0
} else {
## CASE B: in a MAG or PAG the directed edges out of X need
## to be checked for visibility
if (length(indD) > 0) {
del.edges <- vapply(indD, function(z) {
## check each directed edge out of X for visibility
visibleEdge(amat, x, z)
}, NA)
## delete visible edges out of x edges
amat.r[indD[del.edges],x] <- amat.r[x,indD[del.edges]] <- 0
## transform invisible edges out of x by bi-directed
## amat.r[indD[!del.edges],x] <- amat.r[x,indD[!del.edges]] <- 2
}
}
## 3. compute possible descendants of x along definite status paths
## list.de <- possibleDe(amat, x)
list.de <- possDe(m = amat, x = x, y = NULL, possible = TRUE,
ds = TRUE, type = "pag") ## sic !!!
## 4. compute D-SEP(x,y)_path in the truncated graph
dsep.set <- dreach(x, y, amat.r)
## 5. check that no possible descendants of x along definite status
## paths are in D-SEP(x,y,amat.r) or y is in adj(x, amat.r)
if (amat.r[x,y] == 0 && !any(list.de %in% dsep.set))
## D-SEP(x,y,amat.r) closes all the paths
set.w <- dsep.set
set.w
} ## {backdoor}
##' Utility that transforms a CPDAG matrix into a FCI matrix
trafoCPDmat <- function(M)
{
n <- ncol(M)
if(n >= 2) for(i in 2:n)
for(j in seq_len(i-1L)) { ## 1 <= j < i <= n
if (M[i,j] == 1L) {
## if the edge is i -> j
if (M[j,i] == 0L) {
M[i,j] <- 2L # arrow head
M[j,i] <- 1L # arrow circle
}
## if the edge is i - j --- nothing to do: M[i,j] = M[j,i] = 1 already
## else if (M[j,i] == 1)
## {
## M[i,j] <- 1 # arrow circle
## M[j,i] <- 1 # arrow circle
## }
}
## if the edge is i <- j
else if (M[i,j] == 0L && M[j,i] == 1L)
{
M[i,j] <- 1L # arrow circle
M[j,i] <- 2L # arrow head
}
}
M
}
## this function finds ancestors of a node x in the subgraph of G+
## when some confounders are removed,
## for i=1..p (p - number of nodes in the full graph)
## vector[i] = position of the node i in the subgraph (if the node is not in
## the subgraph vector[i]=0)
## m is the adjacency matrix of the full graph
###___ CURRENTLY UNUSED ___, instead NAA_ancestors() below
NAAancestors.1 <- function(x, m, vector)
{
## q denotes unvisited nodes/ nodes in queue
## v denotes visited nodes
p <- nrow(m)
q <- v <- integer(p) # all 0
q[1L] <- x
i <- k <- 1L
while(k <= i && q[k] != 0)
{
t <- q[k]
## mark t as visited
v[k] <- t
k <- k+1L
## in this for cycle adds all nodes that have an undirected
## edge with node t and all parents of node t to queue
for(j in 1:p)
if (m[j,t] == 2 && m[t,j] == 3)
## only add nodes that haven't been added
if (vector[j] != 0 && j %nin% q)
{
i <- i+1L
q[i] <- j
}
}
## Not Against Arrow Ancestors
## If node a is in NAAA that means that there is a not against arrowhead path
## from a to x
setdiff(v, c(0L,x))
}
##' Finds the "not against arrowhead ancestors" of the node x in G+
##' using the adjacency matrix m of G+, and breadth first search.
##' "Not Against Arrowhead Ancestors" (NAAA) are all the nodes u in G+ that
##' have a path u.. -> x in G+ which doesn't go against arrowhead
##'
##' Currently only used as auxiliary for PosDsepLinks()
##'
##' @title Find "Not Against Arrowhead" Ancestors (NAAA)
##' @param x scalar integer in 1..p, denoting a node in graph G+
##' @param m p x p adjacency matrix of graph G+
##' @return a (possibly empty) vector of integers, the NAAA nodes of x in G+
NAA_ancestors <- function(x, m)
{
## q denotes unvisited nodes/ nodes in queue
## v denotes visited nodes
p <- ncol(m); i.p <- 1:p
q <- v <- integer(p) # all 0
q[1L] <- x
i <- k <- 1L
while(k <= i && q[k] != 0) {
t <- q[k]
## mark t as visited
v[k] <- t
k <- k+1L
## in this for cycle adds all nodes that have an undirected
## edge with node t and all parents of node t to queue
for(j in i.p)
if ((t == x && m[j,t] == 2 && m[t,j] == 1) ||
(t != x && m[t,j] != 2 && m[t,j] != 0))
## only add nodes that haven't been added
if (j %nin% q) {
i <- i+1L
q[i] <- j
}
}
## return Not Against Arrow Ancestors (NAAA):
## A node a is in NAAA iff there is a "not against arrowhead" path from a to x
setdiff(v, c(0L,x))
}
##' Find possible Dsep links, given the adjacency matrix,
##' as the edges that satisfy the pattern described in Lemma 4.
##'
##' The edge X <-> Y is a PosDsep link in G+ if there exist nodes, U,V such that
##' U <-> X <-> Y <-> V in G+, and U and V are not adjacent and paths V.. -> X
##' U.. -> Y exist in G+ and they do not go against arrowhead
##' @title Find POSsible D-Separation LINKS
##' @param m adjacency matrix
##' @return a (possibly empty) data frame with columns "x" and "y"
##' where \code{x[i] *-* y[i]} is a possible Dsep link for all i.
# PosDsepLinks <- function(m, verbose=TRUE)
# {
# stopifnot(1 <= (p <- ncol(m)))
# i.p <- 1:p
# NAAA <- vector("list", p)
# x <- y <- integer()
# ## for all pairs 1 <= j < i <= p
# for(i in i.p[-1L]) {
# ## nodes that have a "not against arrowhead" path to i :
# NAAA[[i]] <- NAAA_i <- NAA_ancestors(i, m)
# for (j in 1:i)
# ## first find a bidirected i <-> j edge in G+
# if (m[i,j] == 2 && m[j,i] == 2) {
# u <- v <- integer()
# ## Then find bidirected edges u <-> i and j <-> v
# for (k in i.p) if (k != i && k != j)
# {
# if (m[i,k] == 2 && m[k,i] == 2)
# u <- union(u,k)
# if (m[j,k] == 2 && m[k,j] == 2)
# v <- union(v,k)
# }
#
# ## find nodes u (v) that have both a bidirected edge with i (j) and
# ## a not against arrowhead path to j (i)
# u <- intersect(u, NAAA[[j]]) ## as j <= i, this is already computed
# v <- intersect(v, NAAA_i)
#
# ## check if there is a pair of nodes in (u,v) that is not adjacent
# found.i.j <- FALSE
# for(k in seq_along(u)) {
# u.k <- u[k]
# for(r in seq_along(v))
# if (u.k != v[r] && m[u.k,v[r]] == 0) {
# found.i.j <- TRUE
# break
# }
# if(found.i.j)
# break
# }
#
# ## found.i.j is true iff we found a pair of nodes fulfilling all 3 conditions.
# ## In that case, the node pair (i,j) is added to the PosDsepLinks set:
# if (found.i.j) {
# if(verbose) cat(sprintf("Added PosDsepLink %2d *-* %2d\n", i,j))
# x <- c(x, i)
# y <- c(y, j)
# }
# }
# }
#
# ## returns data frame with possible Dsep links x[i] *-* y[i] for all i
# data.frame(x = x, y = y)
# }
## this function finds a minimal Dsep set, given a Dsep set by
## going through all the subsets of the Dsep set, in the same way it is
## done as in the skeleton function
## x and y are the nodes separated by the sepset sep,
## while suffStat is a sufficient statistic, and
## indepTest is an independence test
MinimalDsep <- function(x,y, sep, suffStat,indepTest, alpha = 0.01)
{
stopifnot((n <- length(sep)) >= 1)
for(i in 1:n)
{
S <- seq_len(i)
wasLast <- FALSE
while (!wasLast) {
if (indepTest(x,y,sep[S],suffStat) > alpha) ## had 'alpha= 0.01' hardcoded
return(sep[S])
z <- getNextSet(n,i,S)
S <- z$nextSet
wasLast <- z$wasLast
}
}
}
##' Find the hierarchy HIE(X,I) given a vector of nodes x and a list of
##' sepsets, according to the definition of a hierarchy HIE(X,I).
##'
##' This is a recursive function, so even though vector x represents the
##' original vector given to the function, it also represents the hierarchy
##' we are in the process of constructing
##' @title Find Hierarchy HIE(X,I)
##' @param x a vector of nodes.
##' @param sepset a list of \dQuote{sepsets}, the "independence set".
##' @return
HIE <- function(x, sepset)
{
## flag1 is used to detect wheteher the hierarchy
## is complete or if more nodes should be added
flag1 <- FALSE
## first check if all the nodes have been added
## if there are nodes that still need to be added
## set flag1 to TRUE and exit the loop
i.x <- seq_along(x)
for(i in i.x)
{
if (flag1) break
for(j in seq_along(x)) {
ss.ij <- sepset[[x[i]]][[x[j]]]
if (!is.null(ss.ij) && length(ss.ij) != 0 && length(setdiff(ss.ij, x)) != 0) {
flag1 <- TRUE
break
}
}
}
## if flag1 is still FALSE all nodes have been added
## and we can exit the function
if (!flag1)
return(x)
## else (flag1 is TRUE) there are still nodes to be added
## flag2 is an indicator that prevents the recursion
## from doing some calculations more than once
flag2 <- FALSE
for(i in i.x) {
if (flag2) break
for(j in i.x)
{
if (flag2)
break
## else :
## if there are still nodes in the separating set of two nodes
## from the hierarchy that are not in the hierarchy
## add those nodes to the hierarchy
ss.ij <- sepset[[x[i]]][[x[j]]]
if (!is.null(ss.ij) && length(ss.ij) != 0 && length(setdiff(ss.ij, x)) != 0) {
## recurse
return(HIE(union(x,ss.ij), sepset))
}
}
}
} ## {HIE}
AugmentGraph <- function(M, suffStat, sepsets, indepTest, alpha = 0.01)
{
## first transform matrix so that it differentiates between edge marks
stopifnot((p <- ncol(M)) >= 1)
if(hasNms <- !is.null(dns <- dimnames(M))) dimnames(M) <- NULL # speedup
i.p <- 1:p
for(i in i.p) {
seps.i <- sepsets[[i]]
for(j in i.p) ## go through all the sepsets
## cat("i=",i," - j=",j,"\n")
if (!is.null(sep <- seps.i[[j]])) {
## only check neighbors of i, j and sepset
adjacent <- union(which(M[i,] != 0),
which(M[j,] != 0))
for (r in seq_along(sep))
adjacent <- union(adjacent, which(M[sep[r],] != 0))
## delete i,j, sepset from the set of adjacent nodes
del.nodes <- union(c(i,j), sep)
adjacent <- setdiff(adjacent, del.nodes)
## if adding a node to the sepset breaks the cond. independence
## orient according to lemma 2. (i)
for (adj in adjacent) {
if (indepTest(i, j, union(sep,adj), suffStat) < alpha) {
for(node in del.nodes)
if ((M.k <- M[node,adj]) != 0 && M.k != 2) {
M[node,adj] <- 2
## cat("oriented this node:",node," towards this node:",adj,"\n")
}
}
}
}
}
## return newly oriented matrix
if(hasNms) structure(M, dimnames = dns) else M
}
## The final fciplus function, it uses all other functions and returns
## an adjacency matrix; however, it does not go through the 10 orientation rules.
##
## the input for the function is a pc fitted graph - pc.fit
## as well as a sufficient statistic and an independence test
# fciplus.intern <- function(pc.fit, alpha = 0.01, suffStat, indepTest, verbose=TRUE)
# {
# sepsets <- pc.fit@sepset
# cpdag <- pc.fit@graph
# m <- trafoCPDmat(as(cpdag, "matrix"))
#
# ## first run the augment graph function to orient invariant
# ## arrowheads according to Lemma 2. (1)
# mat <- AugmentGraph(m, suffStat, sepsets, indepTest)
# ## which(mat[,27]==2)
# ## Check if there are any possible Dsep links
# link <- PosDsepLinks(mat)
#
# ## if there are possible Dsep links it should be checked
# ## which of these are actually edges that should be removed
# ## an edge X - Y is a Dsep link if X and Y are Dseparated by the hierarchy
# ## of the parents of the nodes X and Y (excluding X and Y)
#
# ## a counter to help us go through the data frame of all possible Dsep lins
# count <- 1L
# while (count <= length(link$x)) {
#
# x <- link$x[count]
# y <- link$y[count]
#
# ## basex and basey are vectors of the nodes neighboring nodes x,y
# basex <- setdiff(which(mat[x,] != 0), y)
# basey <- setdiff(which(mat[y,] != 0), x)
# all <- union(basex,basey)
#
# ## to determine whether a posDsep link is an actual Dsep link
# ## it is necessarry to go through all the subsets of the sets basex and
# ## basey (since we don't know the parents) and build a hierarchy
# ## for each combination of those subsets
#
# ## since it is complicated to go through all the subets of both basex and basey,
# ## I decided to combine them into one set and go through subsets of that set
# ## but only building a hierarchy using a subset that contatins neighbors of
# ## both x and y
#
# ## bound is the number of neighbors of x and y
# bound <- length(all)
#
# ## flag is an indicator that will be given the value TRUE if
# ## an actual Dsep link is discovered so we can use it to break
# ## from the for cycle and return to the while cycle
# flag <- FALSE
# for(i in seq_len(bound)) {
# if (flag) break
# S <- seq_len(i)
# exit <- FALSE
# while (!exit && !flag)
# {
# a.S <- all[S]
# ## check if there are more than 1 and less than k neighbors of x and y in the subset
# if (1 <= (l.S.bx <- length(intersect(a.S, basex))) && l.S.bx <= i &&
# 1 <= (l.S.by <- length(intersect(a.S, basey))) && l.S.by <= i)
# {
# ## build a hierarchy
# potential <- HIE(union(c(x,y), a.S), sepsets)
# ## remove x and y from the hierarchy
# potential <- setdiff(potential, c(x,y))
#
# ## if this set is actually a separating set it should be added to
# ## the list of sepsets and we should begin the process again (AugmentGraph, PosDsepLink)
# if (indepTest(x,y, potential, suffStat) > alpha)
# {
# ## find the minimal sepset
# mindsep <- MinimalDsep(x,y,potential,suffStat,indepTest)
#
# ## update sepsets
# if (is.null(mindsep)) {
# sepsets[[x]][y] <- list(NULL)
# } else {
# sepsets[[x]][[y]] <- mindsep
# }
#
# ## update matrix by removing the Dsep link
# mat[x,y] <- mat[y,x] <- 0
#
# cat("Found Dsep Link for x=",x,"y=",y,"sepset=",mindsep,"\n")
#
# ## orient invariant arrowheads
# mat <- AugmentGraph(mat,suffStat,sepsets,indepTest)
#
# ## search for new PosDsepLinks
# link <- PosDsepLinks(mat)
#
# ## reset counter and set flag to TRUE
# count <- 1L
# flag <- TRUE
# }
# }
#
# z <- getNextSet(bound, i, S)
# S <- z$nextSet
# exit <- z$wasLast
# } ## while(!exit ..)
# } ## for(i .. )
# ## if we've exited the for cycle and flag is still false it means x-y is not
# ## a Dseplink so we should move on to the next posDseplink
# if (!flag)
# count <- count+1L
# } ## while(count <= ..)
# ## return the adjusted adjacency matrix and sepset
# list(mat = mat, sepset = sepsets)
# } ## {fciplus.intern}
# fciPlus <- function(suffStat, indepTest, alpha, labels, p, verbose=TRUE)
# {
# ## Author: Markus Kalisch, Date: 7 Jul 2014, 12:08
# cl <- match.call()
# if(!missing(p)) stopifnot(is.numeric(p), length(p <- as.integer(p)) == 1, p >= 2)
# if(missing(labels)) {
# ## FIXME ---- make function for this and use in skeleton(), pc(), fci(), ....
# ## if(is.matrix(C <- suffStat[["C"]]) && (d <- dim(C))[1] == d[2]) {
# ## ## we can derive 'p' *and* 'labels' -- in 99% of cases !
# ## p <- d[1]
# ## if(is.null(labels <- colnames(C)))
# ## labels <- as.character(seq_len(p))
# ## } else {
# if(missing(p)) stop("need to specify 'labels' or 'p'")
# labels <- as.character(seq_len(p))
# ## }
# } else { ## use labels ==> p from it
# stopifnot(is.character(labels))
# if(missing(p)) {
# p <- length(labels)
# } else if(p != length(labels))
# stop("'p' is not needed when 'labels' is specified, and must match length(labels)")
# else
# message("No need to specify 'p', when 'labels' is given")
# }
#
# skel <- skeleton(suffStat = suffStat, indepTest = indepTest, alpha = alpha,
# labels = labels, p = p)
# fit1 <- udag2pdagRelaxed(gInput = skel, orientCollider = FALSE)
# fcip <- fciplus.intern(pc.fit = fit1, alpha=alpha, suffStat=suffStat,
# indepTest=indepTest, verbose=verbose)
# fcip$mat <- (fcip$mat != 0) + 0 # forget orientations in augmented graph: FCI orientation rules seem more accurate
# fciplus.amat <- udag2pag(pag = fcip$mat, sepset = fcip$sepset,
# orientCollider = TRUE, verbose = verbose)
# colnames(fciplus.amat) <- rownames(fciplus.amat) <- labels
# new("fciAlgo", amat = fciplus.amat, call = cl, n = integer(0),
# max.ord = integer(0),
# max.ordPDSEP = integer(0),
# n.edgetests = integer(0), n.edgetestsPDSEP = integer(0),
# sepset = list(), pMax = matrix(0,1,1), allPdsep = list())
# } ## {fciPlus}
## MM: Das braucht's ja wirklich nicht; wir haben extra gute summary(.) Methoden,
## wobei ich ja vor allem jene for "fciAlgo" in der (vor)letzten Version schön verbessert habe.
## Ich wollte sowieso vorschlagen, dass pcAlgo für die adj.Matrix "dasselbe" macht wie fciAlgo !
displayAmat <- function(obj) {
## Convert object of class 'fciAlgo' or 'pcAlgo' to
## corresponding adjacency matrix of type 'amat.pag'
## or 'amat.cpdag'
co <- class(obj)
if (co == "fciAlgo") {
amat <- obj@amat
type <- "amat.pag"
} else {
if (co == "pcAlgo") {
type <- "amat.cpdag"
amat <- wgtMatrix(obj@graph)
} else {
stop("showAmat: Class of input is not supported.")
}
}
list(amat = amat, type = type)
}
pdag2allDags <- function(gm, verbose = FALSE) {
nodeNms <- colnames(gm)
p <- ncol(gm)
rownames(gm) <- colnames(gm) <- as.character(1:p)
res <- allDags.internal(gm = gm, a = gm, tmp = NULL, verbose = verbose)
list(dags = res, nodeNms = nodeNms)
}
allDags.internal <- function(gm,a,tmp, verbose = FALSE)
{
## Purpose: Find all DAGs for a given PDAG
## ----------------------------------------------------------------------
## Arguments:
## - gm: Adjacency matrix of initial PDAG of type \code{amat.cpdag}
## - a: copy of gm
## - tmp: "current set of DAGs", initially NULL
## ----------------------------------------------------------------------
## Value:
## - one 0/1 adj.matrix per row
## Reversion to graph: as(matrix(res[i,],p,p),"graphNEL")
## Reversion to wgtMatrix (i->j iff a[j,i]=1): t(matrix(res[i,],p,p))
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 7 Apr 2008, 14:08
if (sum(a) == 0) {
if (verbose) {
cat("Last Call - Final Graph: \n")
print(gm)
cat("#################### \n")
}
tmp2 <- rbind(tmp,c(t(gm)))
if (all(!duplicated(tmp2))) tmp <- tmp2
} else {
sinks <- find.sink(a)
if (verbose) {
cat("Main Call: ################## \n")
print(gm)
print(a)
cat("Sinks: ",sinks,"\n")
}
for(x in sinks) {
if (verbose) cat("Try removing", x," in a.\n")
gm2 <- gm
a2 <- a
if (adj.check(a,x)) {
inc.to.x <- a[, x] == 1 & a[x, ] == 1
if (any(inc.to.x)) {
real.inc.to.x <- as.numeric(rownames(a)[inc.to.x])
real.x <- as.numeric(rownames(a)[x])
gm2[real.x, real.inc.to.x] <- 1
gm2[real.inc.to.x, real.x] <- 0
}
a2 <- a[-x,-x]
if (verbose) {
cat("Removed sink",as.numeric(rownames(a)[x]),
"in g (", x,"in a).\n")
cat("New graphs: \n")
print(gm2)
print(a2)
}
tmp <- allDags.internal(gm2, a2, tmp, verbose)
## ------- *recursively*
}
}
}
tmp
}
## this is taken from the udag2pdag code from pcalg
## since these rules were already implemented there.
## This fucntion, given a graphNEL object, or an adjacency matrix
## just completes orientations under rules R1-R4 from Meek 1995
## note that this function accepts the t(amat.cpdag) encoding that is
## m[i,j]=1,m[j,i]=0 <=> i -> j
## same as udag2pdag
applyOrientationRules <- function(gInput, verbose=FALSE) {
res <- gInput
##new line
if (!is.matrix(gInput))
{
if (numEdges(gInput)>0) {
g <- as(gInput,"matrix") ## g_ij if i->j
p <- as.numeric(dim(g)[1])
pdag <- g
ind <- which(g==1,arr.ind=TRUE)
} else {
cat("Invalid or empty PDAG! This function only accepts graphNEL or adj mat!\n")
return(NULL)
}
} else {
##also new, for me its easier to use an adjacency matrix
if (length(res[1,])>0){
g <- res
p <- length(g[1,])
pdag <- g
ind <- which(g==1,arr.ind=TRUE)
} else {
cat("Invalid or empty PDAG! This function only accepts graphNEL or adj mat!\n")
return(NULL)
}
}
## Convert to complete pattern: use rules by Pearl/Meek also someone else Verma?
old_pdag <- matrix(0, p,p)
while (!all(old_pdag == pdag)) {
old_pdag <- pdag
## rule 1
ind <- which((pdag==1 & t(pdag)==0), arr.ind=TRUE) ## a -> b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[b,]==1 & pdag[,b]==1) & (pdag[a,]==0 & pdag[,a]==0))
if (length(indC)>0) {
pdag[b,indC] <- 1
pdag[indC,b] <- 0
if (verbose)
cat("\nRule 1:",a,"->",b," and ",b,"-",indC,
" where ",a," and ",indC," not connected: ",b,"->",indC,"\n")
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule1")
## rule 2
ind <- which((pdag==1 & t(pdag)==1), arr.ind=TRUE) ## a -> b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[a,]==1 & pdag[,a]==0) & (pdag[,b]==1 & pdag[b,]==0))
if (length(indC)>0) {
pdag[a,b] <- 1
pdag[b,a] <- 0
if (verbose) cat("\nRule 2: Kette ",a,"->",indC,"->",
b,":",a,"->",b,"\n")
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule2")
## rule 3
ind <- which((pdag==1 & t(pdag)==1), arr.ind=TRUE) ## a - b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[a,]==1 & pdag[,a]==1) & (pdag[,b]==1 & pdag[b,]==0))
if (length(indC)>=2) {
## cat("R3: indC = ",indC,"\n")
g2 <- pdag[indC,indC]
## print(g2)
if (length(g2)<=1) {
g2 <- 0
} else {
diag(g2) <- rep(1,length(indC)) ## no self reference
}
##Bugfix: changed #####
## if (any(g2 == 0)) {
g3 <- g2 + t(g2)
if (any(g3 == 0)) {
###### end of change
## if (any(g2==0)) { ## if two nodes in g2 are not connected
pdag[a,b] <- 1
pdag[b,a] <- 0
if (verbose) cat("\nRule 3:",a,"->",b,"\n")
}
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule3")
## rule 4
ind <- which((pdag==1 & t(pdag)==1), arr.ind=TRUE) ## a - b
if (length(ind)>0) {
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[a,]==1 & pdag[,a]==1) & (pdag[,b]==0 & pdag[b,]==0))
l.indC <- length(indC)
if (l.indC>0) {
found <- FALSE
ic <- 0
while(!found & (ic < l.indC)) {
ic <- ic + 1
c <- indC[ic]
indD <- which( (pdag[c,]==1 & pdag[,c]==0) & (pdag[,b]==1 & pdag[b,]==0))
if (length(indD)>0) {
found <- TRUE
pdag[b,a] = 0
if (verbose) cat("Rule 4 applied \n")
}
}
}
}
}
}
if (!is.matrix(res))
{
res <- as(pdag,"graphNEL")
} else {
res <- pdag
}
return(res)
}
## This function is supposed to add the bg knowledge x -> y to the pdag in gInput
## x and y should be vectors of node LABELS
## gInput can be either the graphNEL object or adjacency matrix
## same encoding as in amat.cpdag above m[i,j]=0, m[j,i]=1 <=> i->j
addBgKnowledge <- function(gInput,x=c(),y=c(),verbose=FALSE, checkInput = TRUE)
{
res <- gInput
##new line
if (!is.matrix(gInput)) {
if (numEdges(gInput)>0) {
g <- t(as(gInput,"matrix")) ## g_ji if i->j
p <- as.numeric(dim(g)[1])
} else {
if (verbose) cat("Invalid or empty PDAG! This function only accepts graphNEL or adj mat\n")
return(NULL)
}
} else {
##for me its easier to use an adjacency matrix
if (length(res[1,])>0) {
g <- res
p <- length(g[1,])
} else {
if (verbose) cat("Invalid or empty PDAG! This function only accepts graphNEL or adj mat\n")
return(NULL)
}
}
pdag <- g
lab <- dimnames(g)[[1]]
## check if input is valid pdag
if( checkInput ) {
if ( !isValidGraph(amat = pdag, type = "pdag") ) {
if (verbose) cat("Input to addBgKnowledge() is not a valid PDAG.\n")
return(NULL)
}
}
##CHANGED!
if (length(x)!=length(y)) {
if (verbose) cat("length of\n",x,"and\n",y,"\nshould be the same!\n")
return(NULL)
}
# }
## real code starts from here
## previously was just dealing w gInput type
##how many new orientations -> k
k <- length(x)
i <- 1
## orient edge by edge
## after adding one orientation complete the orientation rules
##NEW if there are no edges to orient!!
if (k ==0){
pdag <- t(applyOrientationRules(t(pdag),verbose))
if (!is.matrix(res)) {
res <- as(t(pdag),"graphNEL")
} else {
res <- pdag
}
return(res)
}
##NEW: check that the pdag is maximal!
tmp.pdag <- t(applyOrientationRules(t(pdag),verbose))
isMaximal <- (sum(tmp.pdag-pdag)==0)
if (!isMaximal){
if (verbose) cat("Your input pdag is not maximal! You can obtain a maximal pdag by calling: addBgKnowledge(gInput)\n")
return(NULL)
}
while (i <=k)
{
## for each new edge
##find the nodes by the labels
from <- which(lab==x[i])
to <- which(lab==y[i])
##add the orientation if the edge in the current pdag to be undirected
##and complete the orientation rules
if ((pdag[from,to] ==1) & (pdag[to,from] ==1)) {
pdag[from,to] <- 0
if (verbose) cat("Added orientation",x[i],"->",y[i],"to the PDAG.\n")
pdag <- t(applyOrientationRules(t(pdag),verbose)) ##uses different matrix encoding
} else {
## the orientation we want to add conflicts with the current pdag
##either the opposite orientation is present in the current pdag
##or there is no edge between these two nodes in the pdag at all
if ((pdag[from,to] ==1) & (pdag[to,from] ==0)){
if (verbose) cat("Invalid bg knowledge! Cannot add orientation ",x[i],"->",y[i]," because",y[i],"->",x[i],"is already in the PDAG. \n")
return(NULL)
}
if ((pdag[from,to] ==0) & (pdag[to,from] ==0)){
if (verbose) cat("Invalid bg knowledge! Cannot add orientation",x[i],"->",y[i]," because there is no edge between",x[i],"and",y[i],"in the PDAG. \n")
return(NULL)
}
}
i <- i+1
}
if (!is.matrix(res))
{
res <- as(t(pdag),"graphNEL")
} else {
res <- pdag
}
return(res)
}
revealEdge <- function(c,d,s) { ## cpdag, dag, selected edges to reveal
if (all(!is.na(s))) { ## something to reveal
for (i in 1:nrow(s)) {
c[s[i,1], s[i,2]] <- d[s[i,1], s[i,2]]
c[s[i,2], s[i,1]] <- d[s[i,2], s[i,1]]
}
}
c
}
connectedNodes <- function(m,x){
#q denotes unvisited nodes/ nodes in queue
#v denotes visited nodes
q <- v <- rep(0,length(m[,1]))
i <- k <- 1
if(length(x)>1){
cat("Need to do this node by node!\n")
return(NULL)
}
q <- sort(x)
tmp <- m
while(q[k]!=0 & k<=i)
{
t <- q[k]
#mark t as visited
v[k] <- t
k <- k+1
#find all neighbors of t
s <- tmp[t,] + tmp[,t]
neighborss <- which(s!=0)
## if there are neighbors of t
## add the ones not already added
if (length(neighborss)>0){
for(j in 1: length(neighborss))
if (!(neighborss[j] %in% q))
{
i <- i+1
q[i] <- neighborss[j]
}
}
}
## remove all leftover zeros from initialization and x
connectt <-setdiff(v,c(0,x))
return(sort(connectt))
}
adjustb <- function(m,x,y)
{
bpossanx <- bpossany <- c()
for(i in 1:length(x))
{
bpossanx <- union(bpossanx,possAn(m,x[i]))
}
for(j in 1:length(y)){
bpossany <- union(bpossany,possAn(m,y[j]))
}
adjustbb <- union(bpossanx,bpossany)
notbb <- bforbiddenNodes(m, x, y)
notbb <- union(notbb,c(x,y))
adjustbb <- setdiff(adjustbb,notbb)
sort(adjustbb)
}
###-- This *MUST* remain at bottom of file !
###-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
### MM: (ess-set-style 'DEFAULT) : we have much nesting ==> only indent by 2
## Local Variables:
## eval: (ess-set-style 'DEFAULT 'quiet)
## delete-old-versions: never
## End:
Try the pcalg package in your browser
Any scripts or data that you put into this service are public.
pcalg documentation built on Feb. 6, 2024, 3 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions skeleton reach pcAlgo.Perfect has.new.coll causalEffect udag2pdagRelaxed udag2pdagSpecial pdag2dag flipEdges ci.test shd udag2pdag amat2dag adj.check find.sink dag2cpdag corGraph pcSelect.presel mcor getNextSet compareGraphs pcorOrder condIndFisherZ zStat pcSelect rmvDAG wgtMatrix wgtMatrix.0 trueCov
Documented in adj.check amat2dag causalEffect ci.test compareGraphs condIndFisherZ corGraph dag2cpdag find.sink flipEdges getNextSet has.new.coll mcor pcAlgo.Perfect pcorOrder pcSelect pcSelect.presel pdag2dag reach rmvDAG shd skeleton trueCov udag2pdag udag2pdagRelaxed udag2pdagSpecial wgtMatrix zStat
#### Main functions pc(), fci(), fciPlus(), ...
#### ---- -----
### Auxiliaries --> ./Aaux.R
### Classes & Methods --> ./AllClasses.R
trueCov <- function(dag, back.compatible = FALSE)
{
## as(.,"matrix") now {for some versions of 'graph' pkg} is 0/1
## weightMatrix <- t(as(dag,"matrix"))
wm <- if(back.compatible) wgtMatrix.0(dag) else wgtMatrix(dag)
p <- length(dag@nodes)
## SS' where S = (I - W)^{-1} :
tcrossprod(solve(diag(p) - wm))
}
## buggy randomDAG:
## randomDAG <- function (n, prob, lB = 0.1, uB = 1, V = as.character(1:n))
## {
## stopifnot(n >= 2, is.numeric(prob), length(prob) == 1,
## 0 <= prob, prob <= 1,
## is.numeric(lB), is.numeric(uB), lB <= uB)
## edL <- vector("list", n)
## nmbEdges <- 0L
## for (i in seq_len(n - 2)) {
## listSize <- rbinom(1, n - i, prob)
## nmbEdges <- nmbEdges + listSize
## edgeList <- sample(seq(i + 1, n), size = listSize)
## weightList <- runif(length(edgeList), min = lB, max = uB)
## edL[[i]] <- list(edges = edgeList, weights = weightList)
## }
## if (nmbEdges > 0) {
## edL[[n-1]] <-
## if (rbinom(1, 1, prob) == 1)
## list(edges = n,
## weights = runif(1, min = lB, max = uB))
## else
## list(edges = integer(0), weights = numeric(0))
## edL[[n]] <- list(edges = integer(0), weights = numeric(0))
## names(edL) <- V
## new("graphNEL", nodes = V, edgeL = edL, edgemode = "directed")
## }
## else
## new("graphNEL", nodes = V, edgemode = "directed")
## }
randomDAG <- function (n, prob, lB = 0.1, uB = 1, V = as.character(1:n))
{
stopifnot(n >= 2, is.numeric(prob), length(prob) == 1,
0 <= prob, prob <= 1,
is.numeric(lB), is.numeric(uB), lB <= uB)
edL <- vector("list", n)
nmbEdges <- 0L
for (i in seq_len(n - 2)) {
listSize <- rbinom(1, n - i, prob)
nmbEdges <- nmbEdges + listSize
edgeList <- sample(seq(i + 1, n), size = listSize)
weightList <- runif(length(edgeList), min = lB, max = uB)
edL[[i]] <- list(edges = edgeList, weights = weightList)
}
## i=n-1 separately
## (because of sample(7,1) is actually sample(1:7,1) and not 7)
listSize <- rbinom(1, 1, prob)
if (listSize > 0) {
nmbEdges <- nmbEdges + 1
edgeList <- n
weightList <- runif(1, min = lB, max = uB)
} else {
edgeList <- integer(0)
weightList <- numeric(0)
}
edL[[n-1]] <- list(edges = edgeList, weights = weightList)
if (nmbEdges > 0) {
edL[[n]] <- list(edges = integer(0), weights = numeric(0))
names(edL) <- V
new("graphNEL", nodes = V, edgeL = edL, edgemode = "directed")
}
else
new("graphNEL", nodes = V, edgemode = "directed")
}
## A version of this is also in /u/maechler/R/MM/Pkg-ex/graph/weightmatrix.R
## another on in Matrix/R/sparseMatrix.R function graph.wgtMatrix() :
## No longer in use __apart__ for rmvDAG(..., back.compatible=TRUE)
wgtMatrix.0 <- function(g, transpose = TRUE)
{
## Purpose: work around "graph" package's as(g, "matrix") bug
## ----------------------------------------------------------------------
## ACHTUNG: mat_[i,j]==1 iff j->i,
## whereas with as(g,"matrix") mat_[i,j]==1 iff i->j
## ----------------------------------------------------------------------
## Arguments: g: an object inheriting from (S4) class "graph"
## ----------------------------------------------------------------------
## Author: Martin Maechler, based on Seth Falcon's code; Date: 12 May 2006
## MM: another buglet for the case of "no edges":
if(numEdges(g) == 0) {
p <- length(nd <- nodes(g))
return( matrix(0, p,p, dimnames = list(nd, nd)) )
}
## Usual case, when there are edges:
if(!("weight" %in% names(edgeDataDefaults(g))))
edgeDataDefaults(g, "weight") <- 1L
w <- unlist(edgeData(g, attr = "weight"))
## we need the *transposed* matrix typically:
tm <- if(transpose) t(as(g, "matrix")) else as(g, "matrix")
## now is a 0/1 - matrix (instead of 0/wgts) with the 'graph' bug
if(any(w != 1)) ## fix it
tm[tm != 0] <- w
## tm_[i,j]==1 iff i->j
tm
}
wgtMatrix <- function(g, transpose = TRUE) {
res <- as(g, "matrix") # from 'graph' package, now reliable (we hope)
if (transpose) ## default!
t(res) else res
}
rmvDAG <-
function(n, dag,
errDist = c("normal", "cauchy", "t4", "mix", "mixt3", "mixN100"),
mix = 0.1, errMat = NULL, back.compatible = FALSE,
use.node.names = !back.compatible)
{
## Purpose: Generate data according to a given DAG (with weights) and
## given node distribution (rows: number of samples; cols: node values in
## topological order)
## ----------------------------------------------------------------------
## Arguments:
## - n : Number of samples
## - dag : Graph object containing the DAG and weights
## - errDist: "normal" or "mix" for pure standard normal node distribution
## or mixing with standard cauchy
## - mix : Percentage of points sampled from standard cauchy
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 26 Jan 2006; Martin Maechler
## check input & initialize variables
stopifnot(is(dag, "graph"),
(p <- length(nodes(dag))) >= 2)
## as(.,"matrix") now {for some versions of 'graph' pkg} is 0/1
## weightMatrix <- t(as(dag,"matrix"))
weightMatrix <- if(back.compatible) wgtMatrix.0(dag) else wgtMatrix(dag)
## check if top. sorted
nonZeros <- which(weightMatrix != 0, arr.ind = TRUE)
if (nrow(nonZeros) > 0) {
if (any(nonZeros[,1] - nonZeros[,2] < 0) || any(diag(weightMatrix) != 0))
stop("Input DAG must be topologically ordered!")
}
errDist <- match.arg(errDist)
if(grepl("^mix", errDist))
eMat <- function(outs) { # (n,p)
X <- c(rnorm(n*p - length(outs)), outs)
matrix(sample(X), nrow = n)
}
if(is.null(errMat)) {
## generate errors e_i
errMat <-
switch(errDist,
"normal" = matrix(rnorm (n*p), nrow = n),
"cauchy" = matrix(rcauchy(n*p), nrow = n),
"t4" = matrix(rt(n*p, df = 4), nrow = n),
"mix" = eMat(rcauchy(round(mix*n*p))),
"mixt3" = eMat( rt(round(mix*n*p), df = 3)),
"mixN100"= eMat( rnorm(round(mix*n*p), sd = 10)))
}
else { ## check & use 'errMat' argument:
stopifnot(!is.null(dim.eM <- dim(errMat)),
dim.eM == c(n,p), is.numeric(errMat))
}
if(use.node.names)
colnames(errMat) <- nodes(dag) # == colnames(weightMatrix)
## compute X matrix X_i
if (sum(weightMatrix != 0) > 0) {
X <- errMat
for (j in 2:p) { ## uses X[*, 1:(j-1)] -- "recursively" !
ij <- 1:(j-1)
X[,j] <- X[,j] + X[, ij, drop = FALSE] %*% weightMatrix[j, ij]
}
X
}
else
errMat
}
pcSelect <- function(y, dm, alpha, corMethod = "standard",
verbose = FALSE, directed = FALSE)
{
## Purpose: Find columns in dm, that have nonzero parcor with y given
## any other set of columns in dm
## ----------------------------------------------------------------------
## Arguments:
## - y: Response Vector (length(y)=nrow(dm))
## - dm: Data matrix (rows: samples, cols: nodes)
## - alpha: Significance level of individual partial correlation tests
## - corMethod: "standard" or "Qn" for standard or robust correlation
## estimation
## - verbose: 0-no output, 1-small output, 2-details
## ----------------------------------------------------------------------
## Value: List
## - G: boolean vector with connected nodes
## - zMin: Minimal z values
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 27.4.07
stopifnot((n <- nrow(dm)) >= 1,
(p <- ncol(dm)) >= 1)
vNms <- colnames(dm)
## cl <- match.call()
zMin <- c(0,rep.int(Inf,p))
C <- mcor(cbind(y,dm), method = corMethod)
cutoff <- qnorm(1 - alpha/2)
n.edgetests <- numeric(1)# final length = max { ord}
## G := complete graph :
G <- c(FALSE,rep.int(TRUE,p))
seq_p <- seq_len(p+1L) # = 1:(p+1)
done <- FALSE
ord <- 0
while (!done && any(G)) {
n.edgetests[ord+1] <- 0
done <- TRUE
ind <- which(G)
remEdges <- length(ind)
if(verbose >= 1)
cat("Order=",ord,"; remaining edges:",remEdges,"\n", sep = '')
for (i in 1:remEdges) {
if(verbose && (verbose >= 2 || i%%100 == 0)) cat("|i=",i,"|iMax=",remEdges,"\n")
y <- 1
x <- ind[i]
if (G[x]) {
nbrsBool <- G
nbrsBool[x] <- FALSE
nbrs <- seq_p[nbrsBool]
## neighbors of y without itself and x
length_nbrs <- length(nbrs)
if (length_nbrs >= ord) {
if (length_nbrs > ord) done <- FALSE
S <- seq_len(ord)
## now includes special cases (ord == 0) or (length_nbrs == 1):
repeat {
n.edgetests[ord+1] <- n.edgetests[ord+1]+1
z <- zStat(x,y, nbrs[S], C,n)
if(abs(z) < zMin[x]) zMin[x] <- abs(z)
if (verbose >= 2)
cat(paste("x:",vNms[x-1],"y:",(ytmp <- round((p+1)/2)),"S:"),
c(ytmp,vNms)[nbrs[S]], paste("z:",z,"\n"))
if (abs(z) <= cutoff) {
G[x] <- FALSE
break
}
else {
nextSet <- getNextSet(length_nbrs, ord, S)
if(nextSet$wasLast)
break
S <- nextSet$nextSet
}
} ## {repeat}
}
} ## end if( G )
} ## end for(i ..)
ord <- ord+1
} ## end while
## return
list(G = setNames(G[-1L], vNms),
zMin = zMin[-1])
}## pcSelect
zStat <- function(x,y, S, C, n)
{
## Purpose: Fisher's z-transform statistic of partial corr.(x,y | S)
## ----------------------------------------------------------------------
## Arguments:
## - x,y,S: Are x,y cond. indep. given S?
## - C: Correlation matrix among nodes
## - n: Samples used to estimate correlation matrix
## ----------------------------------------------------------------------
## Author: Martin Maechler, 22 May 2006; Markus Kalisch
## for C use:
## dyn.load("/u/kalisch/cCode/pcAlgo/parcorC.so")
## res <- 0
## if (length(S) < 4) {
r <- pcorOrder(x,y, S, C)
## } else {
## k <- solve(C[c(x,y,S),c(x,y,S)])
## r <- -k[1,2]/sqrt(k[1,1]*k[2,2])
## r <- .C("parcorC",as.double(res),as.integer(x-1),as.integer(y-1),as.integer(S-1),as.integer(length(S)),as.integer(dim(C)[1]),as.double(as.vector(C)))[[1]]
## }
res <- sqrt(n- length(S) - 3) * 0.5*logQ1pm(r)
if (is.na(res)) 0 else res
}
condIndFisherZ <- function(x,y,S,C,n, cutoff,
verbose = isTRUE(getOption("verbose.pcalg.condIFz")))
{
## Purpose: Return boolean result on conditional independence using
## Fisher's z-transform
## ----------------------------------------------------------------------
## Arguments:
## - x,y,S: Are x,y cond. indep. given S?
## - C: Correlation matrix among nodes
## - n: Samples used to estimate correlation matrix
## - cutoff: Cutoff for significance level for individual
## partial correlation tests
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 26 Jan 2006, 17:32
## R Variante
r <- pcorOrder(x,y, S, C)
## C Variante
## C res <- 0
## C p <- dim(C)[1]
## C r <- .C("parcor",as.double(res),as.integer(x-1),as.integer(y-1),as.integer(S-1),as.integer(length(S)),as.integer(p),as.double(C))[[1]]
T <- sqrt(n-length(S)-3)* 0.5*logQ1pm(r)
## cat(" (",x,",",y,") | ",S," : T = ",T,"\n", sep='')
## MM: T is only NA when 'r' already is (r = +- 1 <==> T = +- Inf) -- better check there (FIXME?)
## is.na(T) <==> T <- 0 # if problem, delete edge: be conservative
is.na(T) || abs(T) <= cutoff
}
pcorOrder <- function(i,j, k, C, cut.at = 0.9999999) {
## Purpose: Compute partial correlation
## ----------------------------------------------------------------------
## Arguments:
## - i,j,k: Partial correlation of i and j given k
## - C: Correlation matrix among nodes
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 26 Jan 2006; Martin Maechler
if (length(k) == 0) {
r <- C[i,j]
} else if (length(k) == 1) {
r <- (C[i, j] - C[i, k] * C[j, k])/sqrt((1 - C[j, k]^2) * (1 - C[i, k]^2))
} else { ## length(k) >= 2
PM <- pseudoinverse(C[c(i,j,k), c(i,j,k)])
r <- -PM[1, 2]/sqrt(PM[1, 1] * PM[2, 2])
}
if(is.na(r)) 0 else min(cut.at, max(-cut.at, r))
}
compareGraphs <- function(gl,gt) {
## Purpose: Return TPR, FPR and TDR of comparison of two undirected graphs
## ----------------------------------------------------------------------
## Arguments:
## - gl: Estimated graph (may be directed, but the direction will
## be dropped internally)
## - gt: True graph (may be directed, but the direction will
## be dropped internally)
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 26 Jan 2006, 17:35
## When 'graph' returns the 'weight matrix' again:
## ml <- as(ugraph(gl), "matrix")
## mt <- as(ugraph(gt), "matrix")
## p <- dim(ml)[1]
ml <- wgtMatrix(ugraph(gl))
mt <- wgtMatrix(ugraph(gt))
p <- dim(ml)[2]
mt[mt != 0] <- rep(1,sum(mt != 0))
ml[ml != 0] <- rep(1,sum(ml != 0)) ## inserted to fix bug
## FPR := #{misplaced edges} / #{true gaps}
diffm <- ml-mt
nmbTrueGaps <- (sum(mt == 0)-p)/2
## print(list(p=p,sum=sum(mt==0),mt=mt,ml=ml,nmbTrueGaps=nmbTrueGaps,diffm=diffm))
fpr <- if (nmbTrueGaps == 0) 1 else (sum(diffm > 0)/2)/nmbTrueGaps
## TPR := #{correctly found edges} / #{true edges}
diffm2 <- mt-ml
nmbTrueEdges <- (sum(mt == 1)/2)
tpr <- if (nmbTrueEdges == 0) 0 else 1 - (sum(diffm2 > 0)/2)/nmbTrueEdges
## TDR := #{correctly found edges} / #{found edges}
trueEstEdges <- (nmbTrueEdges-sum(diffm2 > 0)/2) ## #{true edges} - #{not detected}
tdr <-
if (sum(ml == 1) == 0) { ## no edges detected
if (trueEstEdges == 0) 1 ## no edges in true graph
else 0
} else trueEstEdges/(sum(ml == 1)/2)
## return named vector:
c(tpr = tpr, fpr = fpr, tdr = tdr)
}
getNextSet <- function(n,k,set) {
## Purpose: Generate the next set in a list of all possible sets of size
## k out of 1:n;
## Also returns a boolean whether this set was the last in the list.
## ----------------------------------------------------------------------
## Arguments:
## - n,k: Choose a set of size k out of numbers 1:n
## - set: previous set in list
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 26 Jan 2006, 17:37
## chInd := changing Index
chInd <- k - (zeros <- sum((seq(n-k+1,n)-set) == 0))
wasLast <- (chInd == 0)
if (!wasLast) {
set[chInd] <- s.ch <- set[chInd] + 1
if (chInd < k)
set[(chInd+1):k] <- seq(s.ch +1L, s.ch +zeros)
}
list(nextSet = set, wasLast = wasLast)
}
mcor <- function(dm, method = c("standard", "Qn", "QnStable",
"ogkScaleTau2", "ogkQn", "shrink"))
{
## Purpose: Compute correlation matrix (perhaps elementwise)
## ----------------------------------------------------------------------
## Arguments:
## - dm: Data matrix; rows: samples, cols: variables
## - method: "Qn" or "standard" (default) envokes robust (based on Qn
## scale estimator) or standard correlation estimator, respectively.
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 27 Jan 2006
p <- ncol(dm)
method <- match.arg(method)
switch(method,
"Qn" = {
res <- diag(nrow = p)
Qn. <- apply(dm, 2L, Qn)
for (i in seq_len(p-1)) {
for (j in i:p) {
qnSum <- Qn(dm[,i] + dm[,j])
qnDiff <- Qn(dm[,i] - dm[,j])
res[j,i] <- res[i,j] <-
max(-1,
min(1, (qnSum^2 - qnDiff^2) / (4*Qn.[i]*Qn.[j])))
}
}
res
},
"QnStable" = {
res <- diag(nrow = p)
Qn. <- apply(dm, 2L, Qn) # Qn(.) for all columns
## xQn := each column divided by its Qn(.)
xQn <- dm / rep(Qn., each=nrow(dm))
for (i in seq_len(p-1)) {
xQn.i <- xQn[,i]
for (j in i:p) {
qnSum <- Qn(xQn.i + xQn[,j])
qnDiff <- Qn(xQn.i - xQn[,j])
res[j,i] <- res[i,j] <-
max(-1,
min(1, (qnSum^2 - qnDiff^2) / (qnSum^2 + qnDiff^2)))
}
}
res
},
"ogkScaleTau2" = {
cov2cor(covOGK(dm, n.iter = 2, sigmamu = scaleTau2,
weight.fn = hard.rejection)$cov)
},
"ogkQn" = {
cov2cor(covOGK(dm, n.iter = 2, sigmamu = s_Qn,
weight.fn = hard.rejection)$cov)
},
"standard" = cor(dm),
"shrink" = {
CM <- cor(dm)
n <- nrow(dm)
p <- ncol(dm)
S1 <- sum(CM[1,-1]^2)
S2 <- sum((1-CM[1,-1]^2)^2)
g <- S1 / (S1 + S2/n) # is in [0,1]
scor3 <- CM
for(i in 2:p) {
scor3[1,i] <- g*CM[1,i]
scor3[i,1] <- g*CM[i,1]
}
scor3
}
)# {switch}
}
pcSelect.presel <- function(y, dm, alpha, alphapre, corMethod = "standard",
verbose = 0, directed = FALSE)
{
## Purpose: Find columns in dm, that have nonzero parcor with y given
## any other set of columns in dm with use of some kind of preselection
## ----------------------------------------------------------------------
## Arguments:
## - y: Response Vector (length(y)=nrow(dm))
## - dm: Data matrix (rows: samples, cols: nodes)
## - alpha : Significance level of individual partial correlation tests
## - alphapre: Significance level in preselective use of pcSelect
## - corMethod: "standard" or "Qn" for standard or robust correlation
## estimation
## ----------------------------------------------------------------------
## Author: Philipp Ruetimann, Date: 5 Mar 2008
tmp <- pcSelect(y, dm, alpha=alphapre,
corMethod=corMethod, verbose=verbose, directed=directed)
pcs <- tmp$G
zmi <- tmp$zMin
ppcs <- which(pcs == 1L)
Xnew <- dm[, ppcs, drop=FALSE]
lang <- length(pcs)
tmp2 <- pcSelect(y, dm=Xnew, alpha=alpha,
corMethod=corMethod, verbose=verbose, directed=directed)
pcSnew <- tmp2$G
zminew <- tmp2$zMin
zmi[ppcs] <- zminew
## MM FIXME -- do without for() :
k <- 1
for (i in 1:lang) {
if(pcs[i] == 1) {
pcs[i] <- pcSnew[k]
k <- k+1
}
}
list(pcs = pcs, Xnew = Xnew, zMin = zmi)
}
corGraph <- function(dm, alpha = 0.05, Cmethod = "pearson")
{
## Purpose: Computes a correlation graph. Significant correlations are
## shown using the given correlation method.
## ----------------------------------------------------------------------
## Arguments:
## - dm: Data matrix with rows as samples and cols as variables
## - alpha: Significance level for correlation test
## - Cmethod: a character string indicating which correlation coefficient
## is to be used for the test. One of '"pearson"',
## '"kendall"', or '"spearman"', can be abbreviated.
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 30 Jan 2006; Martin Maechler (preserve cns)
stopifnot(is.numeric(p <- ncol(dm)), p >= 2)
if(is.null(cns <- colnames(dm))) cns <- as.character(1:p)
mat <- matrix(0, p,p)
for (i in 1:(p-1)) {
for (j in (i+1):p) {
mat[i,j] <- cor.test(dm[,i], dm[,j], alternative = "two.sided",
method = Cmethod)$p.value < alpha
}
}
mat <- mat + t(mat)
dimnames(mat) <- list(cns,cns)
as(mat, "graphNEL")
}
##################################################
## CPDAG
##################################################
##################################################
## dag2cpdag
##################################################
dag2cpdag <- function(g)
{
## Purpose: Compute the (unique) completed partially directed graph (CPDAG)
## that corresponds to the input DAG; result is a graph object
## In the current implementation, this function is just a wrapper
## function for 'dag2essgraph'
## ----------------------------------------------------------------------
## Arguments:
## - dag: input DAG (graph object)
## ----------------------------------------------------------------------
## Author: Alain Hauser, Date: 14 Mar 2015
dag2essgraph(g)
}
#dag2cpdag <- function(g)
#{
# ## Purpose: Compute the (unique) completed partially directed graph (CPDAG)
# ## that corresponds to the input DAG; result is a graph object
# ## ----------------------------------------------------------------------
# ## Arguments:
# ## - dag: input DAG (graph object)
# ## ----------------------------------------------------------------------
# ## Author: Diego Colombo, Date: 10 Jun 2013, 11:06
#
# amat <- as(g, "matrix")
# amat[amat != 0] <- 1
# skel.amat <- amat + t(amat)
# skel.amat[skel.amat == 2] <- 1
# cpdag <- skel.amat
#
# ## search the v-structures in the DAG
# ind <- which((amat == 1 & t(amat) == 0), arr.ind = TRUE)
# tripleMatrix <- matrix(,0,3)
# ## Go through all edges
# for (i in seq_len(nrow(ind))) { ## MM(FIXME): growth of tripleMatrix
# x <- ind[i,1]
# y <- ind[i,2]
# indY <- setdiff(which((amat[,y] == 1 & amat[y,] == 0), arr.ind = TRUE),x) ## x-> y <- z
# if(length(newZ <- indY[amat[x,indY] == 0])) ## deparse.l.=0: no colnames
# tripleMatrix <- rbind(tripleMatrix, cbind(x, y, newZ, deparse.level=0),
# deparse.level=0)
# }
# if ((m <- nrow(tripleMatrix)) > 0) {
# deleteDupl <- logical(m)# all FALSE
# for (i in seq_len(m))
# if (tripleMatrix[i,1] > tripleMatrix[i,3])
# deleteDupl[i] <- TRUE
# if(any(deleteDupl))
# tripleMatrix <- tripleMatrix[!deleteDupl,, drop=FALSE]
#
# ## orient the v-structures in the CPDAG
# for (i in seq_len(nrow(tripleMatrix))) {
# x <- tripleMatrix[i,1]
# y <- tripleMatrix[i,2]
# z <- tripleMatrix[i,3]
# cpdag[x,y] <- cpdag[z,y] <- 1
# cpdag[y,x] <- cpdag[y,z] <- 0
# }
# }
#
# ## orient the edges with the 3 orientation rules
# repeat {
# old_cpdag <- cpdag
# ## Rule 1
# ind <- which((cpdag == 1 & t(cpdag) == 0), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# a <- ind[i, 1]
# b <- ind[i, 2]
# isC <- ((cpdag[b, ] == 1 & cpdag[, b] == 1) &
# (cpdag[a, ] == 0 & cpdag[, a] == 0))
# if (any(isC)) {
# indC <- which(isC)
# cpdag[b, indC] <- 1
# cpdag[indC, b] <- 0
# }
# }
# ## Rule 2
# ind <- which((cpdag == 1 & t(cpdag) == 1), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# a <- ind[i, 1]
# b <- ind[i, 2]
# isC <- ((cpdag[a, ] == 1 & cpdag[, a] == 0) &
# (cpdag[, b] == 1 & cpdag[b, ] == 0))
# if (any(isC)) {
# cpdag[a, b] <- 1
# cpdag[b, a] <- 0
# }
# }
# ## Rule 3
# ind <- which((cpdag == 1 & t(cpdag) == 1), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# a <- ind[i, 1]
# b <- ind[i, 2]
# indC <- which((cpdag[a, ] == 1 & cpdag[, a] == 1) &
# (cpdag[, b] == 1 & cpdag[b, ] == 0))
# if (length(indC) >= 2) {
# cmb.C <- combn(indC, 2)
# cC1 <- cmb.C[1, ]
# cC2 <- cmb.C[2, ]
# for (j in seq_along(cC1)) {
# c1 <- cC1[j]
# c2 <- cC2[j]
# if (c1 != c2 && cpdag[c1, c2] == 0 && cpdag[c2,c1] == 0) {
# cpdag[a, b] <- 1
# cpdag[b, a] <- 0
# break
# }
# }
# }
# }
# if (all(cpdag == old_cpdag))
# break
# }
# as(cpdag,"graphNEL")
#}
## dag2cpdag <- function(dag) {
## Purpose: Compute the (unique) completed partially directed graph (CPDAG)
## that corresponds to the input DAG; result is a graph object
## ----------------------------------------------------------------------
## Arguments:
## - dag: input DAG (graph object)
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 31 Oct 2006, 15:30
## p <- numNodes(dag)
## ## transform DAG to adjacency matrix if any edges are present
## if (numEdges(dag)==0) {
## cpdag.res <- dag
## } else {
## dag <- as(dag,"matrix")
## dag[dag!=0] <- 1
## ## dag is adjacency matrix
## e.df <- labelEdges(dag)
## cpdag <- matrix(0, p,p)
## for (i in seq_len(nrow(e.df))) {
## if (e.df$label[i]) {
## cpdag[e.df$tail[i],e.df$head[i]] <- 1
## } else {
## cpdag[e.df$tail[i],e.df$head[i]] <- cpdag[e.df$head[i],e.df$tail[i]] <- 1
## }
## }
## rownames(cpdag) <- colnames(cpdag) <- as.character(seq(1,p))
## cpdag.res <- as(cpdag,"graphNEL")
## }
## cpdag.res
##}
## make.edge.df <- function(amat) {
## Purpose: Generate a data frame describing some properties of a DAG
## (for extending to a CPDAG)
## The output contains xmin,xmax,head,tail,order (NA or number),
## type (1="d",0="u") in lexikographic order
## ----------------------------------------------------------------------
## Arguments:
## - amat: Adjacency matrix of DAG [x_ij=1 means i->j]
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 31 Oct 2006, 15:43
## INPUT: Adjacency matrix
## stopifnot(sum(amat)>0)
## e <- which(amat==1,arr.ind=TRUE)
## e.dup <- duplicated(t(apply(e,1,sort)))
## nmb.edges <- sum(!e.dup)
## res <- data.frame(xmin=rep(NA,nmb.edges),xmax=rep(NA,nmb.edges),
## tail=rep(NA,nmb.edges),head=rep(NA,nmb.edges),
## order=rep(NA,nmb.edges),type=rep(1,nmb.edges))
## pure.edges <- e[!e.dup,]
## if(length(pure.edges)==2) dim(pure.edges) <- c(1,2)
## for (i in seq_len(nrow(pure.edges))) {
## if (all(amat[pure.edges[i,1],pure.edges[i,2]]==
## amat[pure.edges[i,2],pure.edges[i,1]])) {
## res$type[i] <- 0
## res$head[i] <- NA
## res$tail[i] <- NA
## } else {
## res$head[i] <- pure.edges[i,2]
## res$tail[i] <- pure.edges[i,1]
## }
## }
## s.pure.edges <- t(apply(pure.edges,1,sort))
## ii <- order(s.pure.edges[,1],s.pure.edges[,2])
## res <- res[ii,]
## res$xmin <- s.pure.edges[ii,1]
## res$xmax <- s.pure.edges[ii,2]
## res
##}
## orderEdges <- function(amat) {
## Purpose: Order the edges of a DAG according to Chickering
## (for extension to CPDAG)
## ----------------------------------------------------------------------
## Arguments:
## - amat: Adjacency matrix of DAG
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 31 Oct 2006, 15:42
## stopifnot(isAcyclic(amat))
## ordered.nodes <- topOrder(amat) ## parents before children
## edge.df <- make.edge.df(amat)
## eOrder <- 0
## while(any(unOrdered <- is.na(edge.df$order))) {
## counter <- 0
## find y
## y <- NA
## found <- FALSE
## while(!found) {
## counter <- counter+1
## node <- ordered.nodes[counter]
## which edges are incident to node?
## nbr.nodes <- which(amat[,node]==1)
## if(length(nbr.nodes)>0) {
## unlabeled <- rep.int(FALSE, length(nbr.nodes))
## for(i in seq_along(nbr.nodes)) {
## x <- nbr.nodes[i]
## is edge edge x-y unlabeled?
## unlabeled[i] <- length(intersect(which(edge.df$xmin==min(node,x) &
## edge.df$xmax==max(node,x)),
## which(unOrdered))) > 0
## }
## choose unlabeled edge with highest order node
## if(any(unlabeled)) {
## nbr.unlab <- nbr.nodes[unlabeled] # nbrnodes w. unlabeled edges
## tmp <- ordered.nodes[ordered.nodes %in% nbr.unlab]
## y <- tmp[length(tmp)]
## y <- last(ordered.nodes[which(ordered.nodes %in% nbr.unlab)])
## edge.df$order[edge.df$xmin==min(node,y) &
## edge.df$xmax==max(node,y)] <- eOrder
## eOrder <- eOrder+1
## found <- TRUE
## }
## }
## } ## while !found
## } ## while any(unOrdered)
## edge.df
##}
## labelEdges <- function(amat) {
## Purpose: Label the edges in a DAG with "compelled" and "reversible"
## (for extension to a CPDAG)
## ----------------------------------------------------------------------
## Arguments:
## - amat: Adjacency matrix of DAG
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 31 Oct 2006; prettified: MMaechler
## label=TRUE -> compelled
## label=FALSE -> reversible
## edge.df <- orderEdges(amat)
## lab <- rep(NA,dim(edge.df)[1])
## edge.df <- edge.df[order(edge.df$order),]
## Head <- edge.df$head
## Tail <- edge.df$tail
## while(any(ina <- is.na(lab))) {
## x.y <- which(ina)[1]
## x <- Tail[x.y]
## y <- Head[x.y]
## y.is.head <- Head == y
## e1 <- which(Head == x & lab)
## for(ee in e1) {
## w <- Tail[ee]
## if (any(wt.yh <- w == Tail & y.is.head))
## lab[wt.yh] <- TRUE
## else {
## lab[y.is.head] <- TRUE
## break
## }
## }
## edges going to y not starting from x
## cand <- which(y.is.head & Tail != x)
## if (length(cand) > 0) {
## valid.cand <- rep(FALSE,length(cand))
## for (iz in seq_along(cand)) {
## z <- Tail[cand[iz]]
## if (!any(Tail==z & Head==x)) ## NOT.parent.of.x :
## valid.cand[iz] <- TRUE
## }
## cand <- cand[valid.cand]
## }
## lab[which(y.is.head & is.na(lab))] <- (length(cand) > 0)
## }
## edge.df$label <- lab
## edge.df
##}
##################################################
## pdag2dag
##################################################
find.sink <- function(gm) {
## Purpose: Find sink of an adj matrix; return numeric(0) if there is none;
## a sink may have incident undirected edges, but no directed ones
## ----------------------------------------------------------------------
## Arguments:
## - gm: Adjacency matrix (gm_i_j is edge from j to i)
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 31 Oct 2006; speedup: Martin Maechler, Dec.2013
## treat undirected edges
gm[gm == t(gm) & gm == 1] <- 0
## treat directed edges
which(colSums(gm) == 0)
}
adj.check <- function(gm,x) {
## Purpose: Return "TRUE", if:
## For every vertex y, adj to x, with (x,y) undirected, y is adjacent to
## all the other vertices which are adjacent to x
## ----------------------------------------------------------------------
## Arguments:
## - gm: adjacency matrix of graph
## - x: node number (number)
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 31 Oct 2006;
## several smart speedups: Martin Maechler, Dec.2013
gm.1 <- (gm == 1)
xr <- gm.1[x,]
xc <- gm.1[,x]
nx <- which(xr | xc)
## undirected neighbors of x
un <- which(xr & xc)
for(y in un) {
adj.x <- setdiff(nx, y)
adj.y <- setdiff(which(gm.1[y,] | gm.1[,y]), x)
if(!all(adj.x %in% adj.y))
return(FALSE)
}
TRUE
}
amat2dag <- function(amat) {
## Purpose: Transform the adjacency matrix of an PDAG to the adjacency
## matrix of a SOME DAG in the equiv. class
## Used in pdag2dag if extension is not possible
## ----------------------------------------------------------------------
## Arguments:
## - amat: adjacency matrix; x -> y if amat[x,y]=1,amat[y,x]=0
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 31 Oct 2006, 15:23
p <- dim(amat)[1]
## amat to skel
skel <- amat+t(amat)
skel[which(skel > 1)] <- 1
## permute skel
ord <- sample.int(p)
skel <- skel[ord,ord]
## skel to dag
for (i in 2:p) {
for (j in 1:(i-1)) {
if(skel[i,j] == 1) skel[i,j] <- 0
}
}
## inverse permutation
i.ord <- order(ord)
skel[i.ord,i.ord]
}
##################################################
## udag2pdag
##################################################
udag2pdag <- function(gInput, verbose = FALSE) {
## Purpose: Transform the Skeleton of a pcAlgo-object to a PDAG using
## the rules of Pearl. The output is again a pcAlgo-object.
## ----------------------------------------------------------------------
## Arguments:
## - gInput: pcAlgo object
## - verbose: 0 - no output, 1 - detailed output
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: Sep 2006, 15:03
res <- gInput
if (numEdges(gInput@graph) > 0) {
g <- as(gInput@graph,"matrix") ## g_ij if i->j
p <- as.numeric(dim(g)[1])
pdag <- g
ind <- which(g == 1,arr.ind = TRUE)
## Create minimal pattern
for (i in seq_len(nrow(ind))) {
x <- ind[i,1]
y <- ind[i,2]
allZ <- setdiff(which(g[y,] == 1),x) ## x-y-z
for (z in allZ) {
if (g[x,z] == 0 &&
!(y %in% gInput@sepset[[x]][[z]] ||
y %in% gInput@sepset[[z]][[x]])) {
if (verbose) {
cat("\n",x,"->",y,"<-",z,"\n")
cat("Sxz=",gInput@sepset[[z]][[x]],"Szx=",gInput@sepset[[x]][[z]])
}
pdag[x,y] <- pdag[z,y] <- 1
pdag[y,x] <- pdag[y,z] <- 0
}
}
}
## Test whether this pdag allows a consistent extension
res2 <- pdag2dag(as(pdag,"graphNEL"))
if (res2$success) {
## Convert to complete pattern: use rules by Pearl
old_pdag <- matrix(0, p,p)
while (!all(old_pdag == pdag)) {
old_pdag <- pdag
## rule 1
ind <- which((pdag == 1 & t(pdag) == 0), arr.ind = TRUE) ## a -> b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[b,] == 1 & pdag[,b] == 1) & (pdag[a,] == 0 & pdag[,a] == 0))
if (length(indC) > 0) {
pdag[b,indC] <- 1
pdag[indC,b] <- 0
if (verbose)
cat("\nRule 1:",a,"->",b," and ",b,"-",indC,
" where ",a," and ",indC," not connected: ",b,"->",indC,"\n")
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule1")
## rule 2
ind <- which((pdag == 1 & t(pdag) == 1), arr.ind = TRUE) ## a -> b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[a,] == 1 & pdag[,a] == 0) & (pdag[,b] == 1 & pdag[b,] == 0))
if (length(indC) > 0) {
pdag[a,b] <- 1
pdag[b,a] <- 0
if (verbose) cat("\nRule 2: Kette ",a,"->",indC,"->",
b,":",a,"->",b,"\n")
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule2")
## rule 3
ind <- which((pdag == 1 & t(pdag) == 1), arr.ind = TRUE) ## a - b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[a,] == 1 & pdag[,a] == 1) & (pdag[,b] == 1 & pdag[b,] == 0))
if (length(indC) >= 2) {
## cat("R3: indC = ",indC,"\n")
g2 <- pdag[indC,indC]
## print(g2)
if (length(g2) <= 1) {
g2 <- 0
} else {
diag(g2) <- rep(1,length(indC)) ## no self reference
}
if (any(g2 == 0)) { ## if two nodes in g2 are not connected
pdag[a,b] <- 1
pdag[b,a] <- 0
if (verbose) cat("\nRule 3:",a,"->",b,"\n")
}
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule3")
## rule 4
##- ind <- which((pdag==1 & t(pdag)==1), arr.ind=TRUE) ## a - b
##- if (length(ind)>0) {
##- for (i in seq_len(nrow(ind))) {
##- a <- ind[i,1]
##- b <- ind[i,2]
##- indC <- which( (pdag[a,]==1 & pdag[,a]==1) & (pdag[,b]==0 & pdag[b,]==0))
##- l.indC <- length(indC)
##- if (l.indC>0) {
##- found <- FALSE
##- ic <- 0
##- while(!found & (ic < l.indC)) {
##- ic <- ic + 1
##- c <- indC[ic]
##- indD <- which( (pdag[c,]==1 & pdag[,c]==0) & (pdag[,b]==1 & pdag[b,]==0))
##- if (length(indD)>0) {
##- found <- TRUE
##- pdag[b,a] = 0
##- if (verbose) cat("Rule 4 applied \n")
##- }
##- }
##- }
##- }
##- }
}
res@graph <- as(pdag,"graphNEL")
} else {
## was not extendable; random DAG chosen
res@graph <- res2$graph
## convert to CPDAG
res@graph <- dag2cpdag(res@graph)
}
}
return(res)
} ## udag2pdag
shd <- function(g1,g2)
{
## Purpose: Compute Structural Hamming Distance between graphs g1 and g2
## ----------------------------------------------------------------------
## Arguments:
## - g1, g2: Input graphs
## (graph objects;connectivity matrix where m[x,y]=1 iff x->1
## and m[x,y]=m[y,x]=1 iff x-y; pcAlgo-objects)
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 1 Dec 2006, 17:21
## Idea: Transform g1 into g2
## Transform g1 and g2 into adjacency matrices
if (is(g1, "pcAlgo")) g1 <- g1@graph
if (is(g2, "pcAlgo")) g2 <- g2@graph
if (is(g1, "graphNEL")) {
m1 <- wgtMatrix(g1, transpose = FALSE)
m1[m1 != 0] <- 1
}
if (is(g2, "graphNEL")) {
m2 <- wgtMatrix(g2, transpose = FALSE)
m2[m2 != 0] <- 1
}
shd <- 0
## Remove superfluous edges from g1
s1 <- m1 + t(m1)
s2 <- m2 + t(m2)
s1[s1 == 2] <- 1
s2[s2 == 2] <- 1
ds <- s1 - s2
ind <- which(ds > 0)
m1[ind] <- 0
shd <- shd + length(ind)/2
## Add missing edges to g1
ind <- which(ds < 0)
m1[ind] <- m2[ind]
shd <- shd + length(ind)/2
## Compare Orientation
d <- abs(m1-m2)
## return
shd + sum((d + t(d)) > 0)/2
}
################################################################################
## New in V8 ; uses vcd package
################################################################################
ci.test <- function(x,y, S = NULL, dm.df) {
stopifnot(is.data.frame(dm.df), ncol(dm.df) > 1)
tab <- table(dm.df[,c(x,y,S)])
if (any(dim(tab) < 2))
1
else if (length(S) == 0)
fisher.test(tab, simulate.p.value = TRUE)$p.value
else
vcd::coindep_test(tab,3:(length(S)+2))$p.value
}
flipEdges <- function(amat,ind) {
res <- amat
for (i in seq_len(nrow(ind))) {
x <- ind[i,]
res[x[1],x[2]] <- amat[x[2],x[1]]
res[x[2],x[1]] <- amat[x[1],x[2]]
}
res
}
pdag2dag <- function(g, keepVstruct = TRUE) {
## Purpose: Generate a consistent extension of a PDAG to a DAG; if this
## is not possible, a random extension of the skeleton is returned and
## a warning is issued.
## ----------------------------------------------------------------------
## Arguments:
## - g: PDAG (graph object)
## - keepVstruct: TRUE - vStructures are kept
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: Sep 2006; tweaks: Martin M
not.yet <- FALSE
if (numEdges(g) == 0) {
graph <- g
} else {
gm <- wgtMatrix(g) ## gm_i_j is edge from j to i
storage.mode(gm) <- "integer"
gm[which(gm > 0 & gm != 1)] <- 1L
a <- gm2 <- gm
cn2 <- colnames(gm2)
go.on <- TRUE
while(go.on && length(a) > 1 && sum(a) > 0) {
not.yet <- TRUE
sinks <- find.sink(a)
if (length(sinks) > 0) {
counter <- 1L
while(not.yet && counter <= length(sinks)) {
x <- sinks[counter]
if (!keepVstruct || adj.check(a,x)) {
not.yet <- FALSE
## orient edges
inc.to.x <- which(a[,x] == 1L & a[x,] == 1L) ## undirected
if (length(inc.to.x) > 0) {
## map var.names to col pos in orig adj matrix
## bug: real.inc.to.x <- as.numeric(rownames(a)[inc.to.x])
real.inc.to.x <- which(cn2 %in% rownames(a)[inc.to.x])
real.x <- which(cn2 %in% rownames(a)[x])
gm2[real.x, real.inc.to.x] <- 1L
gm2[real.inc.to.x, real.x] <- 0L
}
## remove x and all edges connected to it
a <- a[-x,-x]
}
counter <- counter + 1L
}
}
go.on <- !not.yet
}## { while }
graph <- if (not.yet) {
## warning("PDAG not extendible: Random DAG on skeleton drawn")
as(amat2dag(gm), "graphNEL")
} else ## success :
as(t(gm2), "graphNEL")
}
list(graph = graph, success = !not.yet)
}
udag2pdagSpecial <- function(gInput, verbose = FALSE, n.max = 100) {
## Purpose: Transform the Skeleton of a pcAlgo-object to a PDAG using
## the rules of Pearl. The output is again a pcAlgo-object. Ambiguous
## v-structures are reoriented until extendable or max number of tries
## is reached. If still not extendable, a DAG is produced starting from the
## current PDAG even if introducing new v-structures.
##
## ----------------------------------------------------------------------
## Arguments:
## - gInput: pcAlgo object
## - verbose: 0 - no output, 1 - detailed output
## - n.max: Maximal number of tries to reorient v-strucutres
## ----------------------------------------------------------------------
## Values:
## - pcObj: Oriented pc-Object
## - evisit: Matrix counting the number of orientation attemps per edge
## - xtbl.orig: Is original graph with v-structure extendable
## - xtbl: Is final graph with v-structure extendable
## - amat0: Adj.matrix of original graph with v-structures
## - amat1: Adj.matrix of graph with v-structures after reorienting
## edges from double edge visits
## - status:
## 0: original try is extendable
## 1: reorienting double edge visits helps
## 2: orig. try is not extendable; reorienting double visits don't help;
## result is acyclic, has orig. v-structures, but perhaps
## additional v-structures
## - counter: Number of reorientation tries until success or max.tries
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: Sep 2006, 15:03
counter <- 0
res <- gInput
status <- 0
p <- length(nodes(res@graph))
evisit <- amat0 <- amat1 <- matrix(0,p,p)
xtbl <- xtbl.orig <- TRUE
if (numEdges(gInput@graph) > 0) {
g <- as(gInput@graph,"matrix") ## g_ij if i->j
p <- dim(g)[1]
pdag <- g
ind <- which(g == 1,arr.ind = TRUE)
## ind <- unique(t(apply(ind,1,sort)))
## Create minimal pattern
for (i in seq_len(nrow(ind))) {
x <- ind[i,1]
y <- ind[i,2]
allZ <- setdiff(which(g[y,] == 1),x) ## x-y-z
for(z in allZ) {
if ((g[x,z] == 0) &&
!(y %in% gInput@sepset[[x]][[z]] ||
y %in% gInput@sepset[[z]][[x]])) {
if (verbose) {
cat("\n",x,"->",y,"<-",z,"\n")
cat("Sxz=",gInput@sepset[[z]][[x]],"Szx=",gInput@sepset[[x]][[z]])
}
## check if already in other direction directed
if (pdag[x,y] == 0 && pdag[y,x] == 1) {
evisit[x,y] <- evisit[x,y] + 1
evisit[y,x] <- evisit[y,x] + 1
}
if (pdag[z,y] == 0 && pdag[y,z] == 1) {
evisit[z,y] <- evisit[z,y] + 1
evisit[y,z] <- evisit[y,z] + 1
}
pdag[x,y] <- pdag[z,y] <- 1
pdag[y,x] <- pdag[y,z] <- 0
} ## if
} ## for
} ## for ( i )
amat0 <- pdag
## Test whether this pdag allows a consistent extension
res2 <- pdag2dag(as(pdag,"graphNEL"))
xtbl <- res2$success
xtbl.orig <- xtbl
if (!xtbl && (max(evisit) > 0)) {
tmp.ind2 <- unique(which(evisit > 0,arr.ind = TRUE))
ind2 <- unique(t(apply(tmp.ind2,1,sort)))
## print(ind2)
n <- nrow(ind2)
n.max <- min(2^n-1,n.max)
counter <- 0
## xtbl is FALSE because of if condition
while((counter < n.max) & !xtbl) {
## if (counter%%100 == 0) cat("\n counter=",counter,"\n")
counter <- counter + 1
dgBase <- digitsBase(counter)
dgBase <- dgBase[length(dgBase):1]
## print(dgBase)
indBase <- matrix(0,1,n)
indBase[1,seq_along(dgBase)] <- dgBase
## indTmp <- ind2[ss[[counter]],,drop=FALSE]
indTmp <- ind2[(indBase == 1),,drop = FALSE]
## print(indTmp)
pdagTmp <- flipEdges(pdag,indTmp)
resTmp <- pdag2dag(as(pdagTmp,"graphNEL"))
xtbl <- resTmp$success
}
pdag <- pdagTmp
status <- 1
}
amat1 <- pdag
if (xtbl) {
## Convert to complete pattern: use rules by Pearl
old_pdag <- matrix(0, p,p)
while (any(old_pdag != pdag)) {
old_pdag <- pdag
## rule 1
ind <- which((pdag == 1 & t(pdag) == 0), arr.ind = TRUE) ## a -> b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[b,] == 1 & pdag[,b] == 1) & (pdag[a,] == 0 & pdag[,a] == 0))
if (length(indC) > 0) {
pdag[b,indC] <- 1
pdag[indC,b] <- 0
if (verbose)
cat("\nRule 1:",a,"->",b," and ",b,"-",indC,
" where ",a," and ",indC," not connected: ",b,"->",indC,"\n")
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule1")
## rule 2
ind <- which((pdag == 1 & t(pdag) == 1), arr.ind = TRUE) ## a -> b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[a,] == 1 & pdag[,a] == 0) & (pdag[,b] == 1 & pdag[b,] == 0))
if (length(indC) > 0) {
pdag[a,b] <- 1
pdag[b,a] <- 0
if (verbose) cat("\nRule 2: Kette ",a,"->",indC,"->",
b,":",a,"->",b,"\n")
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule2")
## rule 3
ind <- which((pdag == 1 & t(pdag) == 1), arr.ind = TRUE) ## a - b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[a,] == 1 & pdag[,a] == 1) & (pdag[,b] == 1 & pdag[b,] == 0))
if (length(indC) >= 2) {
## cat("R3: indC = ",indC,"\n")
g2 <- pdag[indC,indC]
## print(g2)
if (length(g2) <= 1) {
g2 <- 0
} else {
diag(g2) <- rep(1,length(indC)) ## no self reference
}
if (any(g2 == 0)) { ## if two nodes in g2 are not connected
pdag[a,b] <- 1
pdag[b,a] <- 0
if (verbose) cat("\nRule 3:",a,"->",b,"\n")
}
}
}
}
res@graph <- as(pdag,"graphNEL")
} else {
res@graph <- dag2cpdag(pdag2dag(as(pdag,"graphNEL"),keepVstruct = FALSE)$graph)
status <- 2
## res@graph <- res2$graph
}
}
list(pcObj = res, evisit = evisit, xtbl = xtbl, xtbl.orig = xtbl.orig,
amat0 = amat0, amat1 = amat1, status = status, counter = counter)
}
udag2pdagRelaxed <- function(gInput, verbose = FALSE, unfVect = NULL, solve.confl = FALSE, orientCollider = TRUE, rules = rep(TRUE, 3))
{
##################################################
## Internal functions
##################################################
## replace 'else if' branch in 'if( !solve.confl )' statement
orientConflictCollider <- function(pdag, x, y, z) { ## x - y - z
## pdag: amat, pdag[x,y] = 1 and pdag[y,x] = 0 means x -> y
## x,y,z: colnumber of nodes in pdag
## only used if conflicts should be solved
## orient x - y
if (pdag[x,y] == 1) {
## x --- y, x --> y => x --> y
pdag[y,x] <- 0
} else {
## x <-- y, x <-> y => x <-> y
pdag[x,y] <- pdag[y,x] <- 2
}
## orient z - y
if (pdag[z,y] == 1) {
## z --- y, z --> y => z --> y
pdag[y,z] <- 0
} else {
## z <-- y, z <-> y => z <-> y
pdag[z,y] <- pdag[y,z] <- 2
}
pdag
}
## TODO: include correct VERBOSE statements
rule1 <- function(pdag, solve.confl = FALSE, unfVect = NULL) {
## Rule 1: a -> b - c goes to a -> b -> c
## Interpretation: No new collider is introduced
## Out: Updated pdag
search.pdag <- pdag
ind <- which(pdag == 1 & t(pdag) == 0, arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
a <- ind[i, 1]
b <- ind[i, 2]
## find all undirected neighbours of b not adjacent to a
isC <- which(search.pdag[b, ] == 1 & search.pdag[, b] == 1 &
search.pdag[a, ] == 0 & search.pdag[, a] == 0)
if (length(isC) > 0) {
for (ii in seq_along(isC)) {
c <- isC[ii]
## if the edge between b and c has not been oriented previously,
## orient it using normal R1
if (!solve.confl | (pdag[b,c] == 1 & pdag[c,b] == 1) ) { ## no conflict
## !! before, we checked search.pdag, not pdag !!
if (!is.null(unfVect)) { ## deal with unfaithful triples
if (!any(unfVect == triple2numb(p, a, b, c), na.rm = TRUE) &&
!any(unfVect == triple2numb(p, c, b, a), na.rm = TRUE)) {
## if unfaithful triple, don't orient
pdag[b, c] <- 1
pdag[c, b] <- 0
}
} else {
## don't care about unfaithful triples -> just orient
pdag[b, c] <- 1
pdag[c, b] <- 0
## cat("Rule 1\n")
}
if (verbose)
cat("\nRule 1':", a, "->", b, " and ",
b, "-", c, " where ", a, " and ", c,
" not connected and ", a, b, c, " faithful triple: ",
b, "->", c, "\n")
} else if (pdag[b,c] == 0 & pdag[c,b] == 1) {
## conflict that must be solved
## solve conflict: if the edge is b <- c because of a previous
## orientation within for loop then output <->
if (!is.null(unfVect)) { ## deal with unfaithful triples
if (!any(unfVect == triple2numb(p, a, b, c), na.rm = TRUE) &&
!any(unfVect == triple2numb(p, c, b, a), na.rm = TRUE)) {
pdag[b, c] <- 2
pdag[c, b] <- 2
if (verbose)
cat("\nRule 1':", a, "->", b, "<-",
c, " but ", b, "->", c, "also possible and",
a, b, c, " faithful triple: ", a,"->", b, "<->", c,"\n")
}
} else {
## don't care about unfaithful triples -> just orient
pdag[b, c] <- 2
pdag[c, b] <- 2
if (verbose)
cat("\nRule 1':", a, "->", b, "<-",
c, " but ", b, "->", c, "also possible and",
a, b, c, " faithful triple: ", a,"->", b, "<->", c,"\n")
} ## unfVect: if else
} ## conflict: if else
} ## for c
} ## if length(isC)
if (!solve.confl) search.pdag <- pdag
} ## for ind
pdag
}
rule2 <- function(pdag, solve.confl = FALSE) {
## Rule 2: a -> c -> b with a - b: a -> b
## Interpretation: Avoid cycle
## normal version = conservative version
search.pdag <- pdag
ind <- which(search.pdag == 1 & t(search.pdag) == 1, arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
a <- ind[i, 1]
b <- ind[i, 2]
isC <- which(search.pdag[a, ] == 1 & search.pdag[, a] == 0 &
search.pdag[, b] == 1 & search.pdag[b, ] == 0)
for (ii in seq_along(isC)) {
c <- isC[ii]
## if the edge has not been oriented yet, orient it with R2
## always do this if you don't care about conflicts
if (!solve.confl | (pdag[a, b] == 1 & pdag[b, a] == 1) ) {
pdag[a, b] <- 1
pdag[b, a] <- 0
if (verbose)
cat("\nRule 2: Chain ", a, "->", c,
"->", b, ":", a, "->", b, "\n")
}
## else if the edge has been oriented as a <- b by a previous R2
else if (pdag[a, b] == 0 & pdag[b, a] == 1) {
pdag[a, b] <- 2
pdag[b, a] <- 2
if (verbose)
cat("\nRule 2: Chain ", a, "->", c,
"->", b, ":", a, "<->", b, "\n")
}
}
if (!solve.confl) search.pdag <- pdag
}
pdag
}
rule3 <- function(pdag, solve.confl = FALSE, unfVect = NULL) {
## Rule 3: a-b, a-c1, a-c2, c1->b, c2->b but c1 and c2 not connected;
## then a-b => a -> b
search.pdag <- pdag
ind <- which(search.pdag == 1 & t(search.pdag) == 1, arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
a <- ind[i, 1]
b <- ind[i, 2]
c <- which(search.pdag[a, ] == 1 & search.pdag[, a] == 1 &
search.pdag[, b] == 1 & search.pdag[b, ] == 0)
if (length(c) >= 2) {
cmb.C <- combn(c, 2)
cC1 <- cmb.C[1, ]
cC2 <- cmb.C[2, ]
for (j in seq_along(cC1)) {
c1 <- cC1[j]
c2 <- cC2[j]
if (search.pdag[c1, c2] == 0 && search.pdag[c2,c1] == 0) {
if (!is.null(unfVect)) {
if (!any(unfVect == triple2numb(p, c1, a, c2), na.rm = TRUE) &&
!any(unfVect == triple2numb(p, c2, a, c1), na.rm = TRUE)) {
## if the edge has not been oriented yet, orient it with R3
if (!solve.confl | (pdag[a, b] == 1 & pdag[b, a] == 1) ) {
pdag[a, b] <- 1
pdag[b, a] <- 0
if (!solve.confl) search.pdag <- pdag
if (verbose)
cat("\nRule 3':", a, c1, c2, "faithful triple: ",
a, "->", b, "\n")
break
}
## else if: we care about conflicts and the edge has been oriented as a <- b by a previous R3
else if (pdag[a, b] == 0 & pdag[b, a] == 1) {
pdag[a, b] <- pdag[b, a] <- 2
if (verbose)
cat("\nRule 3':", a, c1, c2, "faithful triple: ",
a, "<->", b, "\n")
break
} ## if solve conflict
} ## if unf. triple found
} else { ## if care about unf. triples; else don't care
if (!solve.confl | (pdag[a, b] == 1 & pdag[b, a] == 1) ) {
pdag[a, b] <- 1
pdag[b, a] <- 0
if (!solve.confl) search.pdag <- pdag
if (verbose)
cat("\nRule 3':", a, c1, c2, "faithful triple: ",
a, "->", b, "\n")
break
}
## else if: we care about conflicts and the edge has been oriented as a <- b by a previous R3
else if (pdag[a, b] == 0 & pdag[b, a] == 1) {
pdag[a, b] <- pdag[b, a] <- 2
if (verbose)
cat("\nRule 3':", a, c1, c2, "faithful triple: ",
a, "<->", b, "\n")
break
} ## if solve conflict
} ## if care about unf. triples
} ## if c1 and c2 are not adjecent
} ## for all pairs of c's
} ## if at least two c's are found
} ## for all undirected edges
pdag
}
##################################################
## Main
##################################################
## prepare adjacency matrix of skeleton
if (numEdges(gInput@graph) == 0)
return(gInput)
g <- as(gInput@graph, "matrix")
p <- nrow(g)
pdag <- g
## orient collider
if (orientCollider) {
ind <- which(g == 1, arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
x <- ind[i, 1]
y <- ind[i, 2]
allZ <- setdiff(which(g[y, ] == 1), x) ## x - y - z
for (z in allZ) {
## check collider condition
if (g[x, z] == 0 &&
!((y %in% gInput@sepset[[x]][[z]]) ||
(y %in% gInput@sepset[[z]][[x]]))) {
if (length(unfVect) == 0) { ## no unfaithful triples
if (!solve.confl) { ## don't solve conflicts
pdag[x, y] <- pdag[z, y] <- 1
pdag[y, x] <- pdag[y, z] <- 0
} else { ## solve conflicts
pdag <- orientConflictCollider(pdag, x, y, z)
}
} else { ## unfaithful triples are present
if (!any(unfVect == triple2numb(p, x, y, z), na.rm = TRUE) &&
!any(unfVect == triple2numb(p, z, y, x), na.rm = TRUE)) {
if (!solve.confl) { ## don't solve conflicts
pdag[x, y] <- pdag[z, y] <- 1
pdag[y, x] <- pdag[y, z] <- 0
} else { ## solve conflicts
pdag <- orientConflictCollider(pdag, x, y, z)
}
}
}
}
} ## for z
} ## for i
} ## end: Orient collider
## Rules 1 - 3
repeat {
old_pdag <- pdag
if (rules[1]) {
pdag <- rule1(pdag, solve.confl = solve.confl, unfVect = unfVect)
}
if (rules[2]) {
pdag <- rule2(pdag, solve.confl = solve.confl)
}
if (rules[3]) {
pdag <- rule3(pdag, solve.confl = solve.confl, unfVect = unfVect)
}
if (all(pdag == old_pdag))
break
} ## repeat
gInput@graph <- as(pdag, "graphNEL")
gInput
}
##' @title
##' @param C covariance matrix
##' @param y column of response
##' @param x columns of expl. vars
##' @return
lm.cov <- function (C, y, x) {
solve(C[x, x], C[x, y, drop = FALSE])[1, ]
}
causalEffect <- function(g,y,x) {
## Compute true causal effect of x on y in g
wmat <- wgtMatrix(g)
p <- ncol(wmat)
vec <- matrix(0,p,1)
vec[x] <- 1
## compute and return beta_{true} :
if(y-x > 1) {
for (i in (x+1):y) vec[i] <- wmat[i,]%*%vec
vec[y]
} else {
wmat[y,x]
}
}
has.new.coll <- function(amat,amatSkel, x, pa1, pa2.t, pa2.f) {
## Check if undirected edges that are pointed to x create a new v-structure
## Additionally check, if edges that are pointed away from x create
## new v-structure; i.e. x -> pa <- papa would be problematic
## pa1 are definit parents of x
## pa2 are undirected "parents" of x
## pa2.t are the nodes in pa2 that are directed towards pa2
## pa2.f are the nodes in pa2 that are directed away from pa2
## Value is TRUE, if new collider is introduced
res <- FALSE
if (length(pa2.t) > 0 && !all(is.na(pa2.t))) {
## check whether all pa1 and all pa2.t are connected;
## if no, there is a new collider
if (length(pa1) > 0 && !all(is.na(pa1))) {
res <- min(amatSkel[pa1, pa2.t]) == 0 ## TRUE if new collider
}
## in addition, all pa2.t have to be connected
if (!res && length(pa2.t) > 1) {
A2 <- amatSkel[pa2.t,pa2.t]
diag(A2) <- 1
res <- min(A2) == 0 ## TRUE if new collider
}
}
if (!res && length(pa2.f) > 0 && !all(is.na(pa2.f))) {
## consider here only the DIRECTED Parents of pa2.f
## remove undirected edges
A <- amat-t(amat)
A[A < 0] <- 0
## find parents of pa2.f
cA <- colSums(A[pa2.f,,drop = FALSE])
papa <- setdiff(which(cA != 0), x)
## if any node in papa is not directly connected to x, there is a new
## collider
if (length(papa) > 0)
res <- min(amatSkel[x,papa]) == 0 ## TRUE if new collider
}
res
}
pcAlgo.Perfect <- function(C, cutoff = 1e-8, corMethod = "standard", verbose = 0,
directed = FALSE, u2pd = "rand", psepset = FALSE) {
## Purpose: Perform PC-Algorithm, i.e., estimate skeleton of DAG given data
## Output is an unoriented graph object
## ----------------------------------------------------------------------
## Arguments:
## - C: True Correlation matrix
## - alpha: Significance level of individual partial correlation tests
## - corMethod: "standard" or "Qn" for standard or robust correlation
## estimation
## - verbose: 0-no output, 1-small output, 2-details
## - u2pd: Function for converting udag to pdag
## "rand": udag2pdag
## "relaxed": udag2pdagRelaxed
## "retry": udag2pdagSpecial
## - psepset: Also check possible sep sets.
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 26 Jan 2006; Martin Maechler
## Modification: Diego Colombo, Sept 2009
## backward compatibility
stopifnot((p <- nrow(C)) >= 2)
cl <- match.call()
seq_p <- seq_len(p)# 1:p
pcMin <- matrix(Inf, p,p)
diag(pcMin) <- 0
sepset <- pl <- vector("list",p)
for (i in seq_p) sepset[[i]] <- pl
n.edgetests <- numeric(1)# final length = max { ord}
## G := complete graph :
G <- matrix(TRUE, p,p)
diag(G) <- FALSE
done <- FALSE
ord <- 0L
while (!done && any(G)) {
n.edgetests[ord+1] <- 0
done <- TRUE
ind <- which(G, arr.ind = TRUE)
## For comparison with C++ sort according to first row
ind <- ind[order(ind[,1]), ]
remEdges <- nrow(ind)
if(verbose >= 1)
cat("Order=",ord,"; remaining edges:",remEdges,"\n", sep = '')
for (i in 1:remEdges) {
if(verbose && (verbose >= 2 || i%%100 == 0)) cat("|i=",i,"|iMax=",remEdges,"\n")
x <- ind[i,1]
y <- ind[i,2]
## done <- !G[y,x] # i.e. (x,y) was not already deleted in its (y,x) "version"
## if(!done) {
if (G[y,x]) {
nbrsBool <- G[,x]
nbrsBool[y] <- FALSE
nbrs <- seq_p[nbrsBool]
length_nbrs <- length(nbrs)
## if(verbose)
## done <- length_nbrs < ord
## if (!done) {
if (length_nbrs >= ord) {
if (length_nbrs > ord) done <- FALSE
S <- seq_len(ord)
## now includes special cases (ord == 0) or (length_nbrs == 1):
repeat { ## condition w.r.to all nbrs[S] of size 'ord' :
## if (condIndFisherZ(x,y, nbrs[S], C,n, cutoff,verbose)) {
## MM: want to use this: --- but it changes the result in some cases!!
## cat("X=",x,"|Y=",y,"|ord=",ord,"|nbrs=",nbrs[S],"|iMax=",remEdges,"\n")
n.edgetests[ord+1] <- n.edgetests[ord+1]+1
pc.val <- pcorOrder(x,y,nbrs[S],C)
if (abs(pc.val) < pcMin[x,y]) pcMin[x,y] <- abs(pc.val)
if (verbose >= 2) cat(paste("x:",x,"y:",y,"S:"),nbrs[S],paste("pc:",pc.val,"\n"))
if (abs(pc.val) <= cutoff) {
## ## pnorm(abs(z), lower.tail = FALSE) is the p-value
G[x,y] <- G[y,x] <- FALSE
sepset[[x]][[y]] <- nbrs[S]
break
}
else {
nextSet <- getNextSet(length_nbrs, ord, S)
if(nextSet$wasLast)
break
S <- nextSet$nextSet
}
}
} } ## end if(!done)
} ## end for(i ..)
ord <- ord+1L
## n.edgetests[ord] <- remEdges
}
if (psepset) {
amat <- G
ind <- which(G, arr.ind = TRUE)
storage.mode(amat) <- "integer" # (TRUE, FALSE) --> (1, 0)
## Orient colliders
for (i in seq_len(nrow(ind))) {
x <- ind[i,1]
y <- ind[i,2]
allZ <- setdiff(which(amat[y,] == 1L),x) ## x-y-z
if (length(allZ) > 0) {
for (j in seq_along(allZ)) {
z <- allZ[j]
if ((amat[x,z] == 0L) && !((y %in% sepset[[x]][[z]]) | (y %in% sepset[[z]][[x]]))) {
if (verbose == 2) {
cat("\n",x,"*->",y,"<-*",z,"\n")
cat("Sxz=",sepset[[z]][[x]],"and","Szx=",sepset[[x]][[z]],"\n")
}
## x o-> y <-o z
amat[x,y] <- amat[z,y] <- 2L
} ## if
} ## for
} ## if
} ## for
## Compute poss. sepsets
for (x in 1:p) {
attr(x,'class') <- 'possibledsep'
if (any(amat[x,] != 0L)) {
tf1 <- setdiff(reach(x,-1,-1,amat),x)
for (y in seq_p[amat[x,] != 0L]) {
## tf = possible_d_sep(amat,x,y)
tf <- setdiff(tf1,y)
## test
if (length(tf) > 0) {
pc.val <- pcorOrder(x,y,tf,C)
if (abs(pc.val) < pcMin[x,y]) {
pcMin[x,y] <- abs(pc.val)
}
if (abs(pc.val) <= cutoff) {
## delete x-y
amat[x,y] <- amat[y,x] <- 0L
## save pos d-sepset in sepset
sepset[[x]][[y]] <- tf
if (verbose == 2) {
cat("Delete edge",x,"-",y,"\n")
}
}
if (verbose == 2) {
cat("Possible-D-Sep of", x, "and", y, "is", tf, " - pc = ",pc.val,"\n")
}
}
}
}
}
G[amat == 0L] <- FALSE
G[amat == 1L] <- TRUE
} ## end if(psepset)
if(verbose >= 1) { cat("Final graph adjacency matrix:\n"); print(symnum(G)) }
## transform matrix to graph object :
if (sum(G) == 0) {
Gobject <- new("graphNEL", nodes = as.character(seq_p))
}
else {
colnames(G) <- rownames(G) <- as.character(seq_p)
Gobject <- as(G,"graphNEL")
}
for (i in 1:(p-1)) {
for (j in 2:p) {
pcMin[i,j] <- pcMin[j,i] <- min(pcMin[i,j],pcMin[j,i])
}
}
res <- new("pcAlgo",
graph = Gobject,
call = cl, n = as.integer(1), max.ord = as.integer(ord-1),
n.edgetests = n.edgetests, sepset = sepset,
zMin = pcMin)
if (directed)
switch(u2pd,
"rand" = udag2pdag(res),
"retry" = udag2pdagSpecial(res)$pcObj,
"relaxed" = udag2pdagRelaxed(res))
else
res
}## pcAlgo.Perfect
### reach(): currently only called from pcAlgo() and pcAlgo.Perfect()
### ------- and only in "possibledsep" version
## Function that computes the Possible d-sepset, done by Spirtes
reach <- function(a,b,c,adjacency)
{
## reachable set of vertices;
## edgeslist array[1..maxvertex] of list of edges
## numvertex integer
## labeled array (by depth) of list of edges that have been labeled
makeedge <- function(x,y) list(list(x,y))
legal.pdsep <- function(r,s) {
## Modifying global 'edgeslist'
if ((adjacency[r[[1]],r[[2]]] == 2 &&
adjacency[s, r[[2]]] == 2 && r[[1]] != s) ||
(adjacency[r[[1]],s] != 0 && r[[1]] != s)) {
edgeslist[[r[[2]]]] <<- setdiff(edgeslist[[r[[2]]]],s)
makeedge(r[[2]],s)
}
}
initialize.pdsep <- function(x,y) mapply(makeedge, x = x, y = y)
labeled <- list()
numvertex <- dim(adjacency)[1]
edgeslist <- list()
for (i in 1:numvertex)
edgeslist <- c(edgeslist,list(which(adjacency[,i] != 0)))
labeled[[1]] <- initialize.pdsep(a, edgeslist[[a]])
edgeslist[[a]] <- list()
depth <- 2
repeat {
labeled[[depth]] <- list()
for (i in seq_along(labeled[[depth-1]])) {
lab.i <- labeled[[depth-1]][[i]]
edgestemp <- edgeslist[[lab.i[[2]]]]
if (length(edgestemp) == 0) break
for (j in seq_along(edgestemp))
labeled[[depth]] <- union(legal.pdsep(lab.i, edgestemp[[j]]),
labeled[[depth]])
}
if (length(labeled[[depth]]) == 0)
break
## else :
depth <- depth + 1
}
unique(unlist(labeled))
}
skeleton <- function(suffStat, indepTest, alpha, labels, p,
method = c("stable", "original", "stable.fast"), m.max = Inf,
fixedGaps = NULL, fixedEdges = NULL,
NAdelete = TRUE, numCores = 1, verbose = FALSE)
{
## Purpose: Perform undirected part of PC-Algorithm, i.e.,
## estimate skeleton of DAG given data
## Order-independent version! NEU
## ----------------------------------------------------------------------
## Arguments:
## - suffStat: List containing all necessary elements for the conditional
## independence decisions in the function "indepTest".
## - indepTest: predefined function for testing conditional independence
## - alpha: Significance level of individual partial correlation tests
## - fixedGaps: the adjacency matrix of the graph from which the algorithm
## should start (logical); gaps fixed here are not changed
## - fixedEdges: Edges marked here are not changed (logical)
## - NAdelete: delete edge if pval=NA (for discrete data)
## - m.max: maximal size of conditioning set
## - numCores: number of cores to be used for calculation if
## method = "stable.fast"
## ----------------------------------------------------------------------
## Value:
## - G, sepset, pMax, ord, n.edgetests
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 09.12.2009
## Modification: Diego Colombo; Martin Maechler; Alain Hauser
## x,y,S konstruieren
##- tst <- try(indepTest(x,y,S, obj))
##- if(inherits(tst, "try-error"))
##- stop("the 'indepTest' function does not work correctly with 'obj'")
cl <- match.call()
if(!missing(p)) stopifnot(is.numeric(p), length(p <- as.integer(p)) == 1, p >= 2)
if(missing(labels)) {
if(missing(p)) stop("need to specify 'labels' or 'p'")
labels <- as.character(seq_len(p))
} else { ## use labels ==> p from it
stopifnot(is.character(labels))
if(missing(p))
p <- length(labels)
else if(p != length(labels))
stop("'p' is not needed when 'labels' is specified, and must match length(labels)")
## Don't want message, in case this is called e.g. from fciPlus():
## else
## message("No need to specify 'p', when 'labels' is given")
}
seq_p <- seq_len(p)
method <- match.arg(method)
## C++ version still has problems under Windows; will have to check why
## if (method == "stable.fast" && .Platform$OS.type == "windows") {
## method <- "stable"
## warning("Method 'stable.fast' is not available under Windows; using 'stable' instead.")
## }
## G := !fixedGaps, i.e. G[i,j] is true iff i--j will be investigated
if (is.null(fixedGaps)) {
G <- matrix(TRUE, nrow = p, ncol = p)
}
else if (!identical(dim(fixedGaps), c(p, p)))
stop("Dimensions of the dataset and fixedGaps do not agree.")
else if (!identical(fixedGaps, t(fixedGaps)) )
stop("fixedGaps must be symmetric")
else
G <- !fixedGaps
diag(G) <- FALSE
if (any(is.null(fixedEdges))) { ## MM: could be sparse
fixedEdges <- matrix(rep(FALSE, p * p), nrow = p, ncol = p)
}
else if (!identical(dim(fixedEdges), c(p, p)))
stop("Dimensions of the dataset and fixedEdges do not agree.")
else if (!identical(fixedEdges, t(fixedEdges)) )
stop("fixedEdges must be symmetric")
## Check number of cores
stopifnot((is.integer(numCores) || is.numeric(numCores)) && numCores > 0)
if (numCores > 1 && method != "stable.fast") {
warning("Argument numCores ignored: parallelization only available for method = 'stable.fast'")
}
if (method == "stable.fast") {
## Do calculation in C++...
if (identical(indepTest, gaussCItest))
indepTestName <- "gauss"
else
indepTestName <- "rfun"
options <- list(
verbose = as.integer(verbose),
m.max = as.integer(ifelse(is.infinite(m.max), p, m.max)),
NAdelete = NAdelete,
numCores = numCores)
res <- .Call(estimateSkeleton,
G, suffStat, indepTestName, indepTest, alpha, fixedEdges, options)
G <- res$amat
## sepset <- res$sepset
sepset <- lapply(seq_p, function(i) c(
lapply(res$sepset[[i]], function(v) if(identical(v, as.integer(-1))) NULL else v),
vector("list", p - length(res$sepset[[i]])))) # TODO change convention: make sepset triangular
pMax <- res$pMax
n.edgetests <- res$n.edgetests
ord <- length(n.edgetests) - 1L
}
else {
## Original R version
pval <- NULL
sepset <- lapply(seq_p, function(.) vector("list",p))# a list of lists [p x p]
## save maximal p value
pMax <- matrix(-Inf, nrow = p, ncol = p)
diag(pMax) <- 1
done <- FALSE
ord <- 0L
n.edgetests <- numeric(1)# final length = max { ord}
while (!done && any(G) && ord <= m.max) {
n.edgetests[ord1 <- ord+1L] <- 0
done <- TRUE
ind <- which(G, arr.ind = TRUE)
## For comparison with C++ sort according to first row
ind <- ind[order(ind[, 1]), ]
remEdges <- nrow(ind)
if (verbose)
cat("Order=", ord, "; remaining edges:", remEdges,"\n",sep = "")
if(method == "stable") {
## Order-independent version: Compute the adjacency sets for any vertex
## Then don't update when edges are deleted
G.l <- split(G, gl(p,p))
}
for (i in 1:remEdges) {
if(verbose && (verbose >= 2 || i%%100 == 0)) cat("|i=", i, "|iMax=", remEdges, "\n")
x <- ind[i, 1]
y <- ind[i, 2]
if (G[y, x] && !fixedEdges[y, x]) {
nbrsBool <- if(method == "stable") G.l[[x]] else G[,x]
nbrsBool[y] <- FALSE
nbrs <- seq_p[nbrsBool]
length_nbrs <- length(nbrs)
if (length_nbrs >= ord) {
if (length_nbrs > ord)
done <- FALSE
S <- seq_len(ord)
repeat { ## condition w.r.to all nbrs[S] of size 'ord'
n.edgetests[ord1] <- n.edgetests[ord1] + 1
pval <- indepTest(x, y, nbrs[S], suffStat)
if (verbose)
cat("x=", x, " y=", y, " S=", nbrs[S], ": pval =", pval, "\n")
if(is.na(pval))
pval <- as.numeric(NAdelete) ## = if(NAdelete) 1 else 0
if (pMax[x, y] < pval)
pMax[x, y] <- pval
if(pval >= alpha) { # independent
G[x, y] <- G[y, x] <- FALSE
sepset[[x]][[y]] <- nbrs[S]
break
}
else {
nextSet <- getNextSet(length_nbrs, ord, S)
if (nextSet$wasLast)
break
S <- nextSet$nextSet
}
} ## repeat
}
}
}# for( i )
ord <- ord + 1L
} ## while()
for (i in 1:(p - 1)) {
for (j in 2:p)
pMax[i, j] <- pMax[j, i] <- max(pMax[i, j], pMax[j,i])
}
}
## transform matrix to graph object :
Gobject <-
if (sum(G) == 0) {
new("graphNEL", nodes = labels)
} else {
colnames(G) <- rownames(G) <- labels
as(G,"graphNEL")
}
## final object
new("pcAlgo", graph = Gobject, call = cl, n = integer(0),
max.ord = as.integer(ord - 1), n.edgetests = n.edgetests,
sepset = sepset, pMax = pMax, zMin = matrix(NA, 1, 1))
}## end{ skeleton }
pc <- function(suffStat, indepTest, alpha, labels, p,
fixedGaps = NULL, fixedEdges = NULL, NAdelete = TRUE, m.max = Inf,
u2pd = c("relaxed", "rand", "retry"),
skel.method = c("stable", "original", "stable.fast"),
conservative = FALSE, maj.rule = FALSE,
solve.confl = FALSE, numCores = 1, verbose = FALSE)
{
## Purpose: Perform PC-Algorithm, i.e., estimate skeleton of DAG given data
## ----------------------------------------------------------------------
## Arguments:
## - dm: Data matrix (rows: samples, cols: nodes)
## - C: correlation matrix (only for continuous)
## - n: sample size
## - alpha: Significance level of individual partial correlation tests
## - corMethod: "standard" or "Qn" for standard or robust correlation
## estimation
## - G: the adjacency matrix of the graph from which the algorithm
## should start (logical)
## - datatype: distinguish between discrete and continuous data
## - NAdelete: delete edge if pval=NA (for discrete data)
## - m.max: maximal size of conditioning set
## - u2pd: Function for converting udag to pdag
## "rand": udag2pdag
## "relaxed": udag2pdagRelaxed
## "retry": udag2pdagSpecial
## - gTrue: Graph suffStatect of true DAG
## - conservative: If TRUE, conservative PC is done
## - numCores: handed to skeleton(), used for parallelization
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 26 Jan 2006; Martin Maechler
## Modifications: Sarah Gerster, Diego Colombo, Markus Kalisch
## Initial Checks
cl <- match.call()
if(!missing(p)) stopifnot(is.numeric(p), length(p <- as.integer(p)) == 1, p >= 2)
if(missing(labels)) {
if(missing(p)) stop("need to specify 'labels' or 'p'")
labels <- as.character(seq_len(p))
} else { ## use labels ==> p from it
stopifnot(is.character(labels))
if(missing(p)) {
p <- length(labels)
} else if(p != length(labels))
stop("'p' is not needed when 'labels' is specified, and must match length(labels)")
else
message("No need to specify 'p', when 'labels' is given")
}
u2pd <- match.arg(u2pd)
skel.method <- match.arg(skel.method)
if(u2pd != "relaxed") {
if (conservative || maj.rule)
stop("Conservative PC and majority rule PC can only be run with 'u2pd = relaxed'")
if (solve.confl)
stop("Versions of PC using lists for the orientation rules (and possibly bi-directed edges)\n can only be run with 'u2pd = relaxed'")
}
if (conservative && maj.rule) stop("Choose either conservative PC or majority rule PC!")
## Skeleton
skel <- skeleton(suffStat, indepTest, alpha, labels = labels, method = skel.method,
fixedGaps = fixedGaps, fixedEdges = fixedEdges,
NAdelete=NAdelete, m.max=m.max, numCores=numCores, verbose=verbose)
skel@call <- cl # so that makes it into result
## Orient edges
if (!conservative && !maj.rule) {
switch (u2pd,
"rand" = udag2pdag(skel),
"retry" = udag2pdagSpecial(skel)$pcObj,
"relaxed" = udag2pdagRelaxed(skel, verbose = verbose, solve.confl = solve.confl))
}
else { ## u2pd "relaxed" : conservative _or_ maj.rule
## version.unf defined per default
## Tetrad CPC works with version.unf=c(2,1)
## see comment on pc.cons.intern for description of version.unf
pc. <- pc.cons.intern(skel, suffStat, indepTest, alpha,
version.unf = c(2,1), maj.rule = maj.rule, verbose = verbose)
udag2pdagRelaxed(pc.$sk, verbose = verbose,
unfVect = pc.$unfTripl, solve.confl = solve.confl)
}
} ## {pc}
gSquareBin <- function(x, y, S, dm, adaptDF = FALSE, n.min = 10*df,
verbose = FALSE)
{
## Purpose: G^2 statistic to test for (conditional) independence
## of *binary* variables X and Y given S --> ../man/binCItest.Rd
## -------------------------------------------------------------------------
## Arguments:
## - x,y,S: Are x,y conditionally independent given S (S can be NULL)?
## - dm: data matrix (rows: samples, columns: variables) with binary entries
## - verbose: if TRUE, some additional info is outputted during the
## computations
## - adaptDF: lower the degrees of freedom by one for each zero count.
## The value for the DF cannot go below 1.
## -------------------------------------------------------------------------
stopifnot((n <- nrow(dm)) >= 1) # nr of samples
if(!all(as.logical(dm) == dm))
stop("'dm' must be binary, i.e. with values in {0,1}")
if(verbose) cat('Edge ',x,'--',y, ' with subset S =', S,'\n')
lenS <- length(S)
## degrees of freedom assuming no structural zeros
df <- 2^lenS
if (n < n.min) { ## not enough samples to perform the test:
warning(gettextf(
"n=%d is too small (n < n.min = %d ) for G^2 test (=> treated as independence)",
n, n.min), domain = NA)
return( 1 )
}
## else -- enough data to perform the test
d.x1 <- dm[,x] + 1L
d.y1 <- dm[,y] + 1L
if(lenS <= 5) { # bei gSquareDis lenS <= 4
n12 <- 1:2
switch(lenS+1L, {
## lenS == 0 ----------------------------------
nijk <- array(0L, c(2,2)) # really 'nij', but 'nijk' is "global" name
for (i in n12) {
d.x.i <- d.x1 == i
for (j in n12)
nijk[i,j] <- sum(d.x.i & d.y1 == j)
}
## marginal counts
## compute G^2
t.log <- n*(nijk / tcrossprod(rowSums(nijk), colSums(nijk)))
} ,
{ ## lenS == 1 ----------------------------------
## a.pos <- sort(c(x,y,S))
dmS.1 <- dm[,S] + 1L
nijk <- array(0L, c(2,2,2))
for(i in n12) {
d.x.i <- d.x1 == i
for(j in n12) {
d.x.i.y.j <- d.x.i & d.y1 == j
for(k in n12)
nijk[i,j,k] <- sum(d.x.i.y.j & dmS.1 == k)
}
}
alt <- c(x,y,S)
c <- which(alt == S)
nik <- apply(nijk,c,rowSums)
njk <- apply(nijk,c,colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0,c(2,2,2))
if(c == 3) {
for (k in n12)
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k], njk[,k]))
} else if(c == 1) {
for (k in n12)
t.log[k,,] <- nijk[k,,]*(nk[k] / tcrossprod(nik[,k], njk[,k]))
} else { ## c == 2 (?)
for (k in n12)
t.log[,k,] <- nijk[,k,]*(nk[k] / tcrossprod(nik[,k], njk[,k]))
}
} ,
{ ## lenS == 2 ----------------------------------
## a.pos <- sort(c(x,y,S))
dmS1.1 <- dm[,S[1]] + 1L
dmS2.1 <- dm[,S[2]] + 1L
nijk2 <- array(0L, c(2,2,2,2))
for(i in n12) {
d.x.i <- d.x1 == i
for(j in n12) {
d.x.i.y.j <- d.x.i & d.y1 == j
for(k in n12) {
d.x.y.S1 <- d.x.i.y.j & dmS1.1 == k
for(l in n12)
nijk2[i,j,k,l] <- sum(d.x.y.S1 & dmS2.1 == l)
}
}
}
nijk <- array(0L, c(2,2,4))
for(i in n12) {
for(j in n12)
nijk[,,2*(i-1)+j] <- nijk2[,,i,j]
}
nik <- apply(nijk,3,rowSums)
njk <- apply(nijk,3,colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0,c(2,2,4))
for (k in 1:4)
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k], njk[,k]))
} ,
{ ## lenS == 3 ----------------------------------
dmS1.1 <- dm[,S[1]] + 1L
dmS2.1 <- dm[,S[2]] + 1L
dmS3.1 <- dm[,S[3]] + 1L
nijk <- array(0L, c(2,2,8))
for(i1 in n12) {
d.x.i <- d.x1 == i1
for(i2 in n12) {
d.x.y.i12 <- d.x.i & d.y1 == i2
for(i3 in n12) {
d.x.y.S1 <- d.x.y.i12 & dmS1.1 == i3
for(i4 in n12) {
d.xy.S1S2 <- d.x.y.S1 & dmS2.1 == i4
for(i5 in n12)
nijk[i1,i2,4*(i3-1)+2*(i4-1)+i5] <-
sum(d.xy.S1S2 & dmS3.1 == i5)
}
}
}
}
nik <- apply(nijk, 3, rowSums)
njk <- apply(nijk, 3, colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0,c(2,2,8))
for (k in 1:8)
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k], njk[,k]))
} ,
{ ## lenS == 4 ----------------------------------
dmS1.1 <- dm[,S[1]] + 1L
dmS2.1 <- dm[,S[2]] + 1L
dmS3.1 <- dm[,S[3]] + 1L
dmS4.1 <- dm[,S[4]] + 1L
nijk <- array(0L, c(2,2,16))
for(i1 in n12) {
d.x.i <- d.x1 == i1
for(i2 in n12) {
d.x.y.i12 <- d.x.i & d.y1 == i2
for(i3 in n12) {
d.x.y.S1 <- d.x.y.i12 & dmS1.1 == i3
for(i4 in n12) {
d.xy.S1S2 <- d.x.y.S1 & dmS2.1 == i4
for(i5 in n12) {
d.xy.S1S2S3 <- d.xy.S1S2 & dmS3.1 == i5
for(i6 in n12)
nijk[i1,i2,8*(i3-1)+4*(i4-1)+2*(i5-1)+i6] <-
sum(d.xy.S1S2S3 & dmS4.1 == i6)
}
}
}
}
}
nik <- apply(nijk,3,rowSums)
njk <- apply(nijk,3,colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0, c(2,2,16))
for (k in 1:16)
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k], njk[,k]))
} ,
{ ## lenS == 5 ----------------------------------
dmS1.1 <- dm[,S[1]] + 1L
dmS2.1 <- dm[,S[2]] + 1L
dmS3.1 <- dm[,S[3]] + 1L
dmS4.1 <- dm[,S[4]] + 1L
dmS5.1 <- dm[,S[5]] + 1L
nijk <- array(0L, c(2,2,32))
for(i1 in n12) {
d.x.i <- d.x1 == i1
for(i2 in n12) {
d.x.y.i12 <- d.x.i & d.y1 == i2
for(i3 in n12) {
d.x.y.S1 <- d.x.y.i12 & dmS1.1 == i3
for(i4 in n12) {
d.xy.S1S2 <- d.x.y.S1 & dmS2.1 == i4
for(i5 in n12) {
d.xy.S1S2S3 <- d.xy.S1S2 & dmS3.1 == i5
for(i6 in n12) {
d.xy.S1S2S3S4 <- d.xy.S1S2S3 & dmS4.1 == i6
for(i7 in n12)
nijk[i1,i2,16*(i3-1)+8*(i4-1)+4*(i5-1)+2*(i6-1)+i7] <-
sum(d.xy.S1S2S3S4 & dmS5.1 == i7)
}
}
}
}
}
}
nik <- apply(nijk,3,rowSums)
njk <- apply(nijk,3,colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0,c(2,2,32))
for (k in 1:32)
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k], njk[,k]))
})# end {lenS = 5}, end{switch}
}
else { # --- |S| >= 6 -------------------------------------------------
nijk <- array(0L, c(2,2,1))
## first sample 'by hand' to avoid if/else in the for-loop
i <- d.x1[1]
j <- d.y1[1]
## create directly a list of all k's -- MM{FIXME}: there must be a better way
k <- NULL
lapply(as.list(S), function(x) { k <<- cbind(k,dm[,x]+1); NULL })
## first set of subset values
parents.count <- 1L ## counter variable corresponding to the number
## of value combinations for the subset varibales
## observed in the data
parents.val <- t(k[1,])
nijk[i,j,parents.count] <- 1L # cell counts
## Do the same for all other samples. If there is already a table
## for the subset values of the sample, increase the corresponding
## cell count. If not, create a new table and set the corresponding
## cell count to 1.
for (it.sample in 2:n) {
new.p <- TRUE
i <- d.x1[it.sample]
j <- d.y1[it.sample]
## comparing the current values of the subset variables to all
## already existing combinations of subset variables values
t.comp <- t(parents.val[1:parents.count,]) == k[it.sample,]
## Have to be careful here. When giving dimension to a list,
## R fills column after column, and NOT row after row.
dim(t.comp) <- c(lenS,parents.count)
for (it.parents in 1:parents.count) {
## check if the present combination of value alreay exists
if(all(t.comp[,it.parents])) {
## if yes, increase the corresponding cell count
nijk[i,j,it.parents] <- nijk[i,j,it.parents] + 1L
new.p <- FALSE
break
}
}
## if the combination of subset values is new...
if (new.p) {
## ...increase the number of subset 'types'
parents.count <- parents.count + 1L
if (verbose >= 2)
cat(sprintf(' adding new parents (count = %d) at sample %d\n',
parents.count, it.sample))
## ...add the new subset to the others
parents.val <- rbind(parents.val, k[it.sample,])
## ...update the cell counts (add new array)
nijk <- abind(nijk, array(0,c(2,2,1)))
nijk[i,j,parents.count] <- 1L
}## if(new.p)
}## end for(it.sample ..)
nik <- apply(nijk,3,rowSums)
njk <- apply(nijk,3,colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0, c(2,2,parents.count))
for (k in 1:parents.count)
t.log[,,k] <- nijk[,,k] * (nk[k] / tcrossprod(nik[,k],njk[,k]))
} ## |S| >= 6
G2 <- sum(2 * nijk * log(t.log), na.rm = TRUE)
if (adaptDF && lenS > 0) {
## lower the degrees of freedom according to the amount of zero
## counts; add zero counts corresponding to the number of parents
## combinations that are missing
zero.counts <- sum(nijk == 0L) + 4*(2^lenS-dim(nijk)[3])
ndf <- max(1, df-zero.counts)
if(verbose) cat("adaptDF: (df=",df,", zero.counts=",zero.counts,
") ==> new df = ", ndf, "\n", sep = "")
df <- ndf
}
pchisq(G2, df, lower.tail = FALSE)# i.e. == 1 - P(..)
}## gSquareBin()
gSquareDis <- function(x, y, S, dm, nlev, adaptDF = FALSE, n.min = 10*df,
verbose = FALSE) {
## Purpose: G^2 statistic to test for (conditional) independence of
## __discrete__ X and Y given S --> ../man/disCItest.Rd
## -------------------------------------------------------------------
## Arguments:
## - x,y,S: Are x,y conditionally independent given S (S can be NULL)?
## - dm: data matrix (rows: samples, columns: variables) with
## discrete entries
## - nlev: vector with numbers of levels for each variable
## - verbose: if TRUE, some additional info is outputted during the
## computations
## - adaptDF: lower the degrees of freedom by one for each zero count.
## The value for the DF cannot go below 1.
## -------------------------------------------------------------------
stopifnot((n <- nrow(dm)) >= 1, # nr of samples
(p <- ncol(dm)) >= 2) # nr of variables or nodes
if(!all(1 <= c(x,y,S) & c(x,y,S) <= p))
stop("x, y, and S must all be in {1,..,p}, p=",p)
if(any(as.integer(dm) != dm))
stop("'dm' must be discrete, with values in {0,1,..}")
if(!any(dm == 0))
stop("'dm' must have values in {0,1,..} with at least one '0' value")
if(verbose) cat('Edge ', x,'--',y, ' with subset S =', S,'\n')
lenS <- length(S)
if(missing(nlev) || is.null(nlev))
nlev <- vapply(seq_len(p),
function(j) length(levels(factor(dm[,j]))), 1L)
else
stopifnot(is.numeric(nlev), length(nlev) == p, !is.na(nlev))
if(!all(nlev >= 2))
stop("Each variable, i.e., column of 'dm', must have at least two different values")
nl.x <- nlev[x]
nl.y <- nlev[y]
nl.S <- nlev[S]
## degrees of freedom assuming no structural zeros
df <- (nl.x-1)*(nl.y-1)*prod(nl.S)
if (n < n.min) { ## not enough samples to perform the test:
warning(gettextf(
"n=%d is too small (n < n.min = %d ) for G^2 test (=> treated as independence)",
n, n.min), domain = NA)
return( 1 ) ## gerster prob=0
}
## else -- enough data to perform the test
i.ny <- seq_len(nl.y) # = 1:nl.y
lenS <- length(S)
d.x1 <- dm[,x] + 1L
d.y1 <- dm[,y] + 1L
if(lenS <= 4) { # bei gSquareBin lenS <= 5
switch(lenS+1L, { ## lenS == 0 -------------------
nij <- array(0L, c(nl.x,nl.y))
for (i in 1:nl.x) {
d.x.i <- d.x1 == i
for (j in i.ny)
nij[i,j] <- sum(d.x.i & d.y1 == j)
}
## marginal counts
t.X <- rowSums(nij)
t.Y <- colSums(nij)
## compute G^2
t.log <- n*(nij/ tcrossprod(t.X, t.Y))
t.G2 <- 2*nij * log(t.log)
t.G2[is.nan(t.G2)] <- 0
G2 <- sum(t.G2)
} ,
{ ## lenS == 1 ----------------------------------
in.S <- seq_len(nl.S)
dmS.1 <- dm[,S] + 1L
nijk <- array(0L, c(nl.x,nl.y,nl.S))
for(i in 1:nl.x) {
d.x.i <- d.x1 == i
for(j in i.ny) {
d.x.i.y.j <- d.x.i & d.y1 == j
for(k in in.S)
nijk[i,j,k] <- sum(d.x.i.y.j & dmS.1 == k)
}
}
nik <- apply(nijk, 3, rowSums)
njk <- apply(nijk, 3, colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0, c(nl.x,nl.y,prod(nl.S)))
for (k in 1:prod(nl.S))
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k],njk[,k]))
t.G2 <- 2 * nijk * log(t.log)
t.G2[is.nan(t.G2)] <- 0
G2 <- sum(t.G2)
} ,
{ ## lenS == 2 ----------------------------------
in.S1 <- seq_len(nl.S1 <- nl.S[1])
in.S2 <- seq_len(nl.S2 <- nl.S[2])
dmS1.1 <- dm[,S[1]] + 1L
dmS2.1 <- dm[,S[2]] + 1L
nijk <- array(0L, c(nl.x,nl.y,nl.S1*nl.S2))
for(i in 1:nl.x) {
d.x.i <- d.x1 == i
for(j in i.ny) {
d.x.i.y.j <- d.x.i & d.y1 == j
for(k in in.S1) {
d.x.y.S1 <- d.x.i.y.j & dmS1.1 == k
for(l in in.S2)
nijk[i,j,nl.S2*(k-1)+l] <- sum(d.x.y.S1 & dmS2.1 == l)
}
}
}
nik <- apply(nijk, 3, rowSums)
njk <- apply(nijk, 3, colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0, c(nl.x,nl.y,prod(nl.S)))
for (k in 1:prod(nl.S))
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k],njk[,k]))
t.G2 <- 2 * nijk * log(t.log)
t.G2[is.nan(t.G2)] <- 0
G2 <- sum(t.G2)
} ,
{ ## lenS == 3 ----------------------------------
in.S1 <- seq_len(nl.S1 <- nl.S[1])
in.S2 <- seq_len(nl.S2 <- nl.S[2])
in.S3 <- seq_len(nl.S3 <- nl.S[3])
dmS1.1 <- dm[,S[1]] + 1L
dmS2.1 <- dm[,S[2]] + 1L
dmS3.1 <- dm[,S[3]] + 1L
nijk <- array(0L, c(nl.x,nl.y,prod(nl.S)))
for(i1 in 1:nl.x) {
d.x.i1 <- d.x1 == i1
for(i2 in i.ny) {
d.x.i1.y.i2 <- d.x.i1 & d.y1 == i2
for(i3 in in.S1) {
d.x.y.S1 <- d.x.i1.y.i2 & dmS1.1 == i3
for(i4 in in.S2) {
d.x.y.S1.2 <- d.x.y.S1 & dmS2.1 == i4
for(i5 in in.S3)
nijk[i1,i2, nl.S3*nl.S2*(i3-1)+nl.S3*(i4-1)+i5] <-
sum(d.x.y.S1.2 & dmS3.1 == i5)
}
}
}
}
nik <- apply(nijk, 3, rowSums)
njk <- apply(nijk, 3, colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0, c(nl.x,nl.y,prod(nl.S)))
for (k in 1:prod(nl.S))
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k],njk[,k]))
t.G2 <- 2 * nijk * log(t.log)
t.G2[which(is.nan(t.G2),arr.ind = TRUE)] <- 0
G2 <- sum(t.G2)
} ,
{ ## lenS == 4 ----------------------------------
in.S1 <- seq_len(nl.S1 <- nl.S[1])
in.S2 <- seq_len(nl.S2 <- nl.S[2])
in.S3 <- seq_len(nl.S3 <- nl.S[3])
in.S4 <- seq_len(nl.S4 <- nl.S[4])
dmS1.1 <- dm[,S[1]] + 1L
dmS2.1 <- dm[,S[2]] + 1L
dmS3.1 <- dm[,S[3]] + 1L
dmS4.1 <- dm[,S[4]] + 1L
nijk <- array(0L, c(nl.x, nl.y, prod(nl.S)))
for(i1 in 1:nl.x) {
d.x.i1 <- d.x1 == i1
for(i2 in i.ny) {
d.x.i1.y.i2 <- d.x.i1 & d.y1 == i2
for(i3 in in.S1) {
d.x.y.S1 <- d.x.i1.y.i2 & dmS1.1 == i3
for(i4 in in.S2) {
d.x.y.S1.2 <- d.x.y.S1 & dmS2.1 == i4
for(i5 in in.S3) {
d.x.y.S1.2.3 <- d.x.y.S1.2 & dmS3.1 == i5
for(i6 in in.S4)
nijk[i1,i2, nl.S4*nl.S3*nl.S2*(i3-1) +
nl.S4*nl.S3*(i4-1)+
nl.S4*(i5-1)+i6] <- sum(d.x.y.S1.2.3 & dmS4.1 == i6)
}
}
}
}
}
nik <- apply(nijk, 3, rowSums)
njk <- apply(nijk, 3, colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0, c(nl.x,nl.y,prod(nl.S)))
for (k in 1:prod(nl.S))
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k],njk[,k]))
t.G2 <- 2 * nijk * log(t.log)
t.G2[is.nan(t.G2)] <- 0
G2 <- sum(t.G2)
}) # end lens == 4, end{switch}
}
else { # |S| = lenS >= 5 (gSquareBin: lenS >= 6)
nijk <- array(0L, c(nl.x, nl.y, 1L))
## first sample 'by hand' to avoid if/else in the for-loop
i <- d.x1[1]
j <- d.y1[1]
## create directly a list of all k's -- MM{FIXME}: there must be a better way
k <- NULL
lapply(as.list(S), function(x) { k <<- cbind(k,d.x1); NULL })
## first set of subset values
parents.count <- 1L ## counter variable corresponding to the number
## of value combinations for the subset varibales
## observed in the data
parents.val <- t(k[1,])
nijk[i,j,parents.count] <- 1L # cell counts
## Do the same for all other samples. If there is already a table
## for the subset values of the sample, increase the corresponding
## cell count. If not, create a new table and set the corresponding
## cell count to 1.
for (it.sample in 2:n) {
flag <- 0
i <- d.x1[it.sample]
j <- d.y1[it.sample]
## comparing the current values of the subset variables to all
## already existing combinations of subset variables values
t.comp <- t(parents.val[1:parents.count,]) == k[it.sample,]
## Have to be careful here. When giving dimension to a list,
## R fills column after column, and NOT row after row.
dim(t.comp) <- c(lenS,parents.count)
for (it.parents in 1:parents.count) {
## check if the present combination of value alreay exists
if(all(t.comp[,it.parents])) {
## if yes, increase the corresponding cell count
nijk[i,j,it.parents] <- nijk[i,j,it.parents] + 1L
flag <- 1
break
}
}# end for(it.parents...)
## if the combination of subset values is new...
if (flag == 0) {
## ...increase the number of subset 'types'
parents.count <- parents.count + 1L
if (verbose >= 2)
cat(sprintf(' adding new parents (count = %d) at sample %d\n',
parents.count, it.sample))
## ...add the new subset to the others
parents.val <- rbind(parents.val,k[it.sample,])
## ...update the cell counts (add new array)
nijk <- abind(nijk, array(0L, c(nl.x,nl.y,1)))
nijk[i,j,parents.count] <- 1L
} # end if(flag==0)
} ## for(it in 2:n)
if (verbose && verbose < 2)
cat(sprintf(" added a total of %d new parents\n", parents.count))
nik <- apply(nijk,3,rowSums)
njk <- apply(nijk,3,colSums)
nk <- colSums(njk)
## compute G^2
t.log <- array(0,c(nl.x,nl.y,parents.count))
for (k in 1:parents.count)
t.log[,,k] <- nijk[,,k]*(nk[k] / tcrossprod(nik[,k],njk[,k]))
t.G2 <- 2 * nijk * log(t.log)
t.G2[which(is.nan(t.G2),arr.ind = TRUE)] <- 0
G2 <- sum(t.G2)
}
if (adaptDF && lenS > 0) {
## lower the degrees of freedom according to the amount of
## zero counts
zero.counts <-
if(lenS == 0)
length(which(nij == 0))
else
length(which(nijk == 0)) + 4*(2^lenS - dim(nijk)[3])
## add zero counts corresponding to the number of parents
## combinations that are missing
df <- max((df-zero.counts),1)
} # end adaptDF
pchisq(G2, df, lower.tail = FALSE)# i.e. == 1 - P(..)
}## gSquareDis()
gaussCItest <- function(x,y,S,suffStat) {
## suffStat$C: correlation matrix
## suffStat$n: sample size
z <- zStat(x,y,S, C = suffStat$C, n = suffStat$n)
2*pnorm(abs(z), lower.tail = FALSE)
}
dsep <- function(a,b, S = NULL, g, john.pairs = NULL)
{
## Purpose: Are the set a and the set b d-separeted given the set S?
## ----------------------------------------------------------------------
## Arguments:
## - a,b,S: vectors of node names
## - g: graphNEL object
## - john.pairs: matrix from johnson.all.pairs.sp
## ----------------------------------------------------------------------
## Value:
## Boolean decision
## ----------------------------------------------------------------------
## Author: Markus Kalisch
## Check that g is a DAG
amatTmp <- wgtMatrix(g) ## i->j if amatTmp[j,i]!=0
amatTmp[amatTmp != 0] <- 1
if (max(amatTmp+t(amatTmp)) > 1) stop("dsep: Undirected edge in input graph!")
p <- numNodes(g)
## build node union of a,b,S
if(is.null(john.pairs)) john.pairs <- johnson.all.pairs.sp(g)
nodeUnion <- if(length(S) > 0) c(a,b,S) else c(a,b)
my.nodes <- nodes(g)
## find ancestor graph of nodeUnion
anc.set <- NULL
for (i in seq_len(p)) {
desc.nodes <- my.nodes[which(john.pairs[i,] < Inf)]
if (any(desc.nodes %in% nodeUnion)) anc.set <- c(anc.set,my.nodes[i])
} ## for (i in 1:p)
gS <- subGraph(anc.set,g)
## Moralize in amatM
## !!! in the following line:
## i->j if amat[i,j], i.e. different than default coding !!!
## (*)
amat <- wgtMatrix(gS, transpose = FALSE)
if(all(a0 <- amat == 0))
## if no edge in graph, nodes are d-separated
return( TRUE )
## else :
amat[!a0] <- 1
amatM <- amat
ind <- which(amat == 1,arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
## input is guaranteed to be directed
x <- ind[i,1]
y <- ind[i,2] ## x -> y
## using different coding, see (*) -> OK
allZ <- setdiff(which(amat[y,] == 0 & amat[,y] == 1), x) ## x -> y <- z
for (z in allZ)
if (amat[x,z] == 0 && amat[z,x] == 0)
amatM[x,z] <- 1 ## moralize
} ## for (i in seq_len(nrow(ind)))
## make undirected graph
## (up to now, there is NO undirected edge -> just add t(amat))
gSM <- as(amatM+t(amatM),"graphNEL")
if (length(S) > 0) { ## check separation
separates(a,b,S,gSM)
} else {
b %nin% (if(is.list(bfs. <- bfs(gSM,a))) bfs.[[1]] else bfs.)
}
} ## {dsep}
## Orakel:
dsepTest <- function(x,y, S = NULL, suffStat) {
## suffStat$ g: True graph (graphNEL suffStatect)
## suffStat$jp: johnson all pairs
## Returns "p-value" P =
## 0: keep edge / d-connected
## 1: drop edge / d-separated
if( x == y || x %in% S || y %in% S) {
0
} else {
stopifnot(is(g <- suffStat$g, "graph"))
jp <- suffStat$jp
V <- nodes(g)
## return 0 / 1
as.numeric(dsep(a = V[x], b = V[y], S = V[S], g = g, john.pairs = jp))
}
} ## {dsepTest}
disCItest <- function(x,y,S,suffStat) {
if(is.data.frame(dm <- suffStat$dm)) dm <- data.matrix(dm)
else stopifnot(is.matrix(dm))
nlev <- suffStat$nlev
adaptDF <- suffStat$adaptDF
## p-value:
gSquareDis(x = x, y = y, S = S, dm = dm, nlev = nlev, adaptDF = adaptDF,
verbose = FALSE)
}
binCItest <- function(x,y,S,suffStat) {
if(is.data.frame(dm <- suffStat$dm)) dm <- data.matrix(dm)
else stopifnot(is.matrix(dm))
adaptDF <- suffStat$adaptDF
## p-value:
gSquareBin(x = x, y = y, S = S, dm = dm, adaptDF = adaptDF, verbose = FALSE)
}
hasExtension <- function(amat, amatSkel, x, pa1, pa2.t, pa2.f, type, nl) {
## nl are colnames of amat
## x, pa1, pa2.x: col positions (NULL if not existing)
## type is in c("pdag", "cpdag")
## VALUE: TRUE if amat has extension
if (type == "pdag") {
xNL <- nl[x]
fromXNL <- rep(xNL, length(pa2.f))
toXNL <- rep(xNL, length(pa2.t))
pa2.fNL <- nl[pa2.f]
pa2.tNL <- nl[pa2.t]
tmp <- addBgKnowledge(gInput = amat, x = c(fromXNL, pa2.tNL),
y = c(pa2.fNL, toXNL))
res <- !is.null(tmp) ## TRUE if amat is extendable
} else {
res <- !has.new.coll(amat, amatSkel, x, pa1, pa2.t, pa2.f)
}
res
}
revealEdge <- function(c,d,s) { ## cpdag, dag, selected edges to reveal
if (all(!is.na(s))) { ## something to reveal
for (i in 1:nrow(s)) {
c[s[i,1], s[i,2]] <- d[s[i,1], s[i,2]]
c[s[i,2], s[i,1]] <- d[s[i,2], s[i,1]]
}
}
c
}
ida <- function (x.pos, y.pos, mcov, graphEst, method = c("local", "optimal","global"),
y.notparent = FALSE, verbose = FALSE, all.dags = NA,
type = c("cpdag", "pdag"))
{
method <- match.arg(method)
if(method!="optimal"){
x <- as.integer(x.pos)
y <- as.integer(y.pos)
if(length(x) >= 2){
cat("The methods \"global\" and \"local\" are only implemented for singleton X.")
}
stopifnot(x.pos == x,
y.pos == y,
length(x) == 1,
# length(y) == 1,
type %in% c("pdag", "cpdag"))
} else{
if(y.notparent) {cat("The option y.notparent is not implemented for the optimal method.")}
stopifnot(x.pos == (x <- as.vector(x.pos)),
y.pos == (y <- as.vector(y.pos)),
type %in% c("pdag", "cpdag"),
!(y.notparent))
}
nx <- length(x.pos)
ny <- length(y.pos)
type <- match.arg(type)
amat <- ad.g <- wgtMatrix(graphEst)
amat[which(amat != 0)] <- 1 ## coding: amat.cpdag
## test if valid input amat
if (!isValidGraph(amat = amat, type = type)) {
message("The input graph is not a valid ",type,". See function isValidGraph() for details.\n")
}
if (length(y.pos) > 1 && method!="optimal") { ## call myself for each y in y.pos :
beta.hat <- lapply(y.pos, function(y) ida(x.pos, y, mcov=mcov,
graphEst, method=method, type=type,verbose=verbose))
return(beta.hat)
}
if(method=="optimal"){
if(y.notparent) amat[x, y] <- FALSE
# if (is.element(y.pos, x.pos)) matrix(0, nrow = nx, ncol = length(all.pasets))
## return joint.effects
if(ny==1) {beta.hat <- matrix(unlist(optimal.est(x.pos,y.pos,amat,mcov,verbose)),nrow=nx)}
else{
results <- list()
beta.hat <- list()
result <- optimal.est(x.pos,y.pos,amat,mcov,verbose)
if(is.matrix(result)) {
nsibs <- 1
if(nx==1 && nrow(result)==1){
result <- t(result)
}
for(i in 1:ny){
beta.hat[[i]] <- matrix(unname(result[i,]))
}
} else{
nsibs <- length(lengths(result))
if(nx==1){
for(k in 1:nsibs){
if(nrow(result[[k]])==1){
result[[k]] <- t(result[[k]])}
}
}
for(i in 1:ny){
beta.hat[[i]] <- matrix(,nrow=nx,ncol=nsibs)
for(j in 1:nsibs){
beta.hat[[i]][,j] <- result[[j]][i,]
}
}
}
}
return(beta.hat)
}
nl <- colnames(amat)
stopifnot(!is.null(nl))
amatSkel <- amat + t(amat)
amatSkel[amatSkel != 0] <- 1
if (method == "local") {
wgt.est <- (ad.g != 0)
if (y.notparent) {
wgt.est[x, y] <- FALSE
}
tmp <- wgt.est - t(wgt.est)
tmp[which(tmp < 0)] <- 0
wgt.unique <- tmp
pa1 <- which(wgt.unique[x, ] != 0)
if (y %in% pa1) {
beta.hat <- 0
}
else {
wgt.ambig <- wgt.est - wgt.unique
pa2 <- which(wgt.ambig[x, ] != 0)
if (verbose)
cat("\n\nx=", x, "y=", y, "\npa1=", pa1, "\npa2=",
pa2, "\n")
if (length(pa2) == 0) {
beta.hat <- lm.cov(mcov, y, c(x, pa1))
if (verbose)
cat("Fit - y:", y, "x:", c(x, pa1), "|b.hat=",
beta.hat, "\n")
}
else {
beta.hat <- NA
ii <- 0
pa2.f <- pa2
pa2.t <- NULL
if (hasExtension(amat, amatSkel, x, pa1, pa2.t,
pa2.f, type, nl)) {
ii <- ii + 1
beta.hat[ii] <- lm.cov(mcov, y, c(x, pa1))
if (verbose)
cat("Fit - y:", y, "x:", c(x, pa1), "|b.hat=",
beta.hat[ii], "\n")
}
for (i2 in seq_along(pa2)) {
pa2.f <- pa2[-i2]
pa2.t <- pa2[i2]
if (hasExtension(amat, amatSkel, x, pa1, pa2.t,
pa2.f, type, nl)) {
ii <- ii + 1
if (y %in% pa2.t) {
beta.hat[ii] <- 0
}
else {
beta.hat[ii] <- lm.cov(mcov, y, c(x, pa1,
pa2[i2]))
if (verbose)
cat("Fit - y:", y, "x:", c(x, pa1, pa2[i2]),
"|b.hat=", beta.hat[ii], "\n")
}
}
}
if (length(pa2) > 1)
for (i in 2:length(pa2)) {
pa.tmp <- combn(pa2, i, simplify = TRUE)
for (j in seq_len(ncol(pa.tmp))) {
pa2.t <- pa.tmp[, j]
pa2.f <- setdiff(pa2, pa2.t)
if (hasExtension(amat, amatSkel, x, pa1,
pa2.t, pa2.f, type, nl)) {
ii <- ii + 1
if (y %in% pa2.t) {
beta.hat[ii] <- 0
}
else {
beta.hat[ii] <- lm.cov(mcov, y, c(x,
pa1, pa2.t))
if (verbose)
cat("Fit - y:", y, "x:", c(x, pa1,
pa2.t), "|b.hat=", beta.hat[ii],
"\n")
}
}
}
}
}
}
}
##method global
##should stay the same for pdags
if (method=="global") {
p <- numNodes(graphEst)
am.pdag <- ad.g
am.pdag[am.pdag != 0] <- 1
if (y.notparent) {
am.pdag[x, y] <- 0
}
if (is.na(all.dags)) {
ad <- pdag2allDags(am.pdag)$dags
}
else {
ad <- all.dags
}
n.dags <- nrow(ad)
beta.hat <- rep(NA, n.dags)
for (i in 1:n.dags) {
wgt.unique <- t(matrix(ad[i, ], p, p))
pa1 <- which(wgt.unique[x, ] != 0)
if (y %in% pa1) {
beta.hat[i] <- 0
}
else {
beta.hat[i] <- lm.cov(mcov, y, c(x, pa1))
if (verbose)
cat("Fit - y:", y, "x:", c(x, pa1), "|b.hat=",
beta.hat[i], "\n")
}
}
}
unname(beta.hat)
}
optimal.est <- function (x.pos,y.pos, amat.cpdag, mcov,verbose)
{
## if not working with amat.cpdag type then:
## amat.cpdag <- t(amat.cpdag)
nx <- length(x.pos)
ny <- length(y.pos)
amat.cpdag[which(amat.cpdag != 0)] <- 1 ##just in case make all the non-zero's 1
amat.undir <- amat.cpdag * t(amat.cpdag) ## amat.undir - all undirected edges
## the undirected edge i - j has amat[i,j] = amat[j,i] =1
amat.dir <- amat.cpdag - amat.undir ## amat.dir - all directed edges
pasets.dir <- lapply(x.pos, function(x) which(amat.dir[x,] != 0)) ## find all parents of x.pos in the PDAG
## sibs will be a vector containing all undirected edges connected with x.pos
## if for example: i is in x.pos and i-j is in G
## then add j;i to sibs
sibs <- c()
for (i in 1:nx)
{
tmp.sib <- which(amat.undir[x.pos[i],]!=0) ## tmp.sib contains all siblings of x.pos[i]
if (length(tmp.sib)!=0){ ## if x.pos[i] has a sibling, then add all those sibling edges to sibs
for (j in 1:length(tmp.sib))
{
sibs <- c(sibs,paste(tmp.sib[j],x.pos[i], sep = ";")) ## sibs is a vector of type a;b c;d
## where b and d are in x.pos and b-a d-c are in G
## note that if a,b are in x.pos and a-b is in G
## then both a;b and b;a are in sibs
}
}
}
## if there are no undirected edges connected to x.pos, that is
## if sibs is empty, so return pasets.dir as the only parent set
if (length(sibs)==0){
check <- checkVAS(amat.cpdag,x.pos,y.pos)
beta.hat <- matrix(numeric(ny*nx),nrow=ny)
rownames(beta.hat) <- y.pos
colnames(beta.hat) <- x.pos
if(ny==1 && nx==1){
beta.hat[check[[2]]] <- NA
} else{beta.hat[check[[2]],] <- NA}
if(length(check[[1]])!=0 && verbose){
cat("\n\nWith no added edge orientations:")
cat("\ny =",y.pos[check[[1]]], "is not a descendant of x =",
x.pos,"and hence the partial total effects estimates are",0,"\nWe continue with y =",y.pos[-check[[1]]],".\n")
}
if(length(check[[2]])!=0 && verbose){
cat("\n\nWith no added edge orientations:")
cat("\nNo valid adjustment set exists relative to x =", x.pos," and y =",
y.pos[check[[2]]], " and we continue with y =",y.pos[-check[[3]]], "\n")
}
if(length(check[[3]]) < ny){
if(length(check[[3]])>0){
y.pruned <- y.pos[-check[[3]]]
opt.set <- optAdjSet(amat.cpdag,x.pos,y.pruned)
if(ny==1 && nx==1){
beta.hat[-check[[3]]] <- t(gen.lm.cov(mcov,y.pruned,x.pos,opt.set))
} else{beta.hat[-check[[3]],] <- t(gen.lm.cov(mcov,y.pruned,x.pos,opt.set))}
} else{
opt.set <- optAdjSet(amat.cpdag,x.pos,y.pos)
beta.hat <- t(gen.lm.cov(mcov,y.pos,x.pos,opt.set))
}
}
if (verbose){
if(length(check[[3]]) == ny){opt.set <- numeric()}
cat("\n\nWith no added edge orientations:")
cat("\nThe estimated total effect of y=", y.pos, "on x=",
x.pos,"is thus beta=",beta.hat, "\n")
cat("\n with O=", opt.set,"\n")
}
return(beta.hat)
} else { ## if sibs is not empty, find all possible joint parent sets
beta.hat <- list() ## this is the object we return, containing a list of all possible total effect estimates
count <- 1 ## this counter will contain the current number (+1) of valid joint parent sets
## first check the no additional parents option
## meaning that it is possible to orient all sibling edges out of x.pos
toAdd <- makeBgKnowledge(sibs)
## require that no two nodes in x.pos are siblings
if (length(intersect(x.pos,toAdd$x))==0){
## try to orient everything out of x.pos
amat.amenable <- addBgKnowledge(amat.cpdag,x=toAdd$y,y=toAdd$x,checkInput = FALSE)
if (!is.null(amat.amenable)){
## if it is possible to orient everyting out of x.pos add the corresponding optimal set to valid optimal sets
check <- checkVAS(amat.amenable,x.pos,y.pos)
beta.hat[[count]] <- matrix(numeric(ny*nx),nrow=ny)
rownames(beta.hat[[count]]) <- y.pos
colnames(beta.hat[[count]]) <- x.pos
if(ny==1 && nx==1){
beta.hat[[count]][check[[2]]] <- NA
} else{beta.hat[[count]][check[[2]],] <- NA}
if(length(check[[1]])!=0 && verbose){
cat("\n\n With added edge orientations: \n")
print(rbind(addFromThis=toAdd$y,addToThis=toAdd$x))
cat("\ny =",y.pos[check[[1]]], "is not a descendant of x =",
x.pos,"and hence the respective partial joint total effect estimates are",0,".\n")
}
if(length(check[[2]])!=0 && verbose){
cat("\n\n With added edge orientations: \n")
print(rbind(addFromThis=toAdd$y,addToThis=toAdd$x))
cat("\nNo valid adjustment set exists relative to x =", x.pos," and y =",
y.pos[check[[2]]],".\n")
}
if(length(check[[3]]) < ny){
if(length(check[[3]])>0){
y.pruned <- y.pos[-check[[3]]]
opt.set <- optAdjSet(amat.amenable,x.pos,y.pruned)
if(ny==1 && nx==1){
beta.hat[[count]][-check[[3]]] <- t(gen.lm.cov(mcov,y.pruned,x.pos,opt.set))
} else{beta.hat[[count]][-check[[3]],] <- t(gen.lm.cov(mcov,y.pruned,x.pos,opt.set))}
} else{
opt.set <- optAdjSet(amat.amenable,x.pos,y.pos)
beta.hat[[count]] <- t(gen.lm.cov(mcov,y.pos,x.pos,opt.set))
}
}
if (verbose){
if(length(check[[3]]) == ny){opt.set <- numeric()}
cat("\n\nWith added edge orientations: \n")
print(rbind(addFromThis=toAdd$y,addToThis=toAdd$x))
cat("\nThe estimated total effect of y=", y.pos, "on x=",
x.pos,"is beta=",beta.hat[[count]], "\n")
cat("\n with O=", opt.set,"\n")
}
count <- count + 1
}
}
}
## now for all subsets of possible parents hat is
## all possible subsets of sibs union pasets.dir
## check if they work
size <- length(sibs)
for (k in 1:size)
{
possPa <- combn(sibs,k) ## form all combinations of sibs of size k
for (r in 1:length(possPa[1,]))
{
s <- possPa[,r] ## get one subset of sibs which we will try to orient into x.pos
toAdd1 <- makeBgKnowledge(s) ## transform it from sibs format: a;b c;d into bgKnowledge format that is
## into a data.frame with x=c(a,c) y=c(b,d) so that a -> b, c-> d is bgKnowledge
sbar <- setdiff(sibs,s) ## the complement of our subset s should be oriented out of x.pos
toAdd2 <- makeBgKnowledge(sbar)
## the following 2 lines define the bg Knowledge that we try to add
addFromThis <- c(toAdd1$x,toAdd2$y)
addToThis <- c(toAdd1$y,toAdd2$x)
## only try to add this bg knowledge if its consistent within itself
## meaning if it does not contain contradictory edges
## for example addFromThis =c(1,2) addToThis = c(2,1)
check2 <- FALSE ## if check is true it will indicate that the background knowledge contradicts itself
for (i in 1: length(addFromThis)){
if (addToThis[i] %in% addFromThis[which(addToThis == addFromThis[i])]){# %in% addToThis)]){
check2 <- TRUE
}
}
if (!check2){ ##only try to add background knowledge that does not contradict itself
amat.amenable <- addBgKnowledge(amat.cpdag,x=addFromThis,y=addToThis)
if (!is.null(amat.amenable)){
check <- checkVAS(amat.amenable,x.pos,y.pos)
beta.hat[[count]] <- matrix(numeric(ny*nx),nrow=ny)
rownames(beta.hat[[count]]) <- y.pos
colnames(beta.hat[[count]]) <- x.pos
if(ny==1 && nx==1){
beta.hat[[count]][check[[2]]] <- NA
} else{beta.hat[[count]][check[[2]],] <- NA}
if(length(check[[1]])!=0 && verbose){
cat("\n\n With added edge orientations: \n")
print(rbind(addFromThis,addToThis))
cat("\ny =",y.pos[check[[1]]], "is not a descendant of x =",
x.pos,"and hence the partial total effects estimates are",0,".\n")
}
if(length(check[[2]])!=0 && verbose){
cat("\n\n With added edge orientations: \n")
print(rbind(addFromThis,addToThis))
cat("\nNo valid adjustment set exists relative to x =", x.pos," and y =",
y.pos[check[[2]]], ".\n")
}
if(length(check[[3]]) < ny){
if(length(check[[3]])>0){
y.pruned <- y.pos[-check[[3]]]
opt.set <- optAdjSet(amat.amenable,x.pos,y.pruned)
if(ny==1 && nx==1){
beta.hat[[count]][-check[[3]]] <- t(gen.lm.cov(mcov,y.pruned,x.pos,opt.set))
} else{beta.hat[[count]][-check[[3]],] <- t(gen.lm.cov(mcov,y.pruned,x.pos,opt.set))}
} else{
opt.set <- optAdjSet(amat.amenable,x.pos,y.pos)
beta.hat[[count]] <- t(gen.lm.cov(mcov,y.pos,x.pos,opt.set))
}
}
if (verbose){
if(length(check[[3]]) == ny){opt.set <- numeric()}
cat("\n\nWith added edge orientations: \n")
print(rbind(addFromThis,addToThis))
cat("\nThe estimated total effect of x=", x.pos, "on y=",
y.pos,"is beta=",beta.hat[[count]], "\n")
cat("with O=", opt.set,"\n")
}
count <- count + 1
}
}
}
}
return(beta.hat)
}
## the following functions takes character vector s of type s=c("1;2","3;4")
## and transforms it into a data frame containing vectors x=c(1,3) and y=c(2,4)
## so that one can add x -> y (that is 1 -> 2, 3 -> 4) as bg knowledge easier
makeBgKnowledge <- function(s)
{
x <- y <- c()
if (length(s)==0){ ## if s is empty, return empty vectors
df.final <- data.frame(x=x, y=y)
return(df.final)
} else { ## otherwise transform the charactor vector s into a
## bg knowledge data frame
for (i in 1:length(s))
{
addFromTo <- as.numeric(unlist(strsplit(x = s[i],split = ";")))
x <- c(x,addFromTo[1])
y <- c(y,addFromTo[2])
}
df.final <- data.frame(x=x, y=y)
return(df.final)
}
}
checkVAS <- function(m,x.pos,y.pos){
possDeX <- unlist(lapply(x.pos,possDe,m=m,y=c(),type="pdag"))
noDescY <- unlist(lapply(y.pos, function(y) length(intersect(y,possDeX))))
a <- which(noDescY==0)
if(length(a)>0){
y.pruned <- y.pos[-a]
} else{y.pruned <- y.pos}
noVAS <- unlist(lapply(y.pruned, function(y) length(intersect(x.pos,forb(m,x.pos,y)))))
b <- which(noDescY!=0)[which(noVAS!=0)]
c <- union(a,b)
return(list(a,b,c))
}
forb <- function(m, x, y){
possDeX <- unlist(lapply(x,possDe,m=m,y=c(),type="pdag"))
possAnY <- unlist(lapply(y,possAn,m=m,
y=x,type="pdag"))
cn <- intersect(possAnY,possDeX)
forb <- unlist(lapply(cn,possDe,m=m,y=c(),type="pdag"))
return(forb)
}
# generalization of lmvoc to make usable for non-singleton X
gen.lm.cov <- function(C,y,x,z=NULL){
w <- union(x,z)
solve(C[w, w], C[w, y, drop = FALSE])[1:length(x), ]
}
idaFast <- function(x.pos, y.pos.set, mcov, graphEst)
{
## Purpose: Estimate the causal effect of x on each element in the
## set y using the local method; graphEst and correlation matrix
## have to be precomputed; orient
## undirected edges at x in a way so that no new collider is
## introduced; if there is an undirected edge between x and y, both directions are considered;
## i.e., y might be partent of x in which case the effect is 0.
## ----------------------------------------------------------------------
## Arguments:
## - x.pos, y.pos: Column of x and y in d.mat
## - mcov: Covariance matrix that was used to estimate graphEst
## - graphEst: Fit of PC Algorithm (semidirected)
## ----------------------------------------------------------------------
## Value: list of causal values; one list element for each element of
## y.pos.set
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 7 Jan 2010, 11:18
## prepare adjMatrix and skeleton
amat <- ad.g <- wgtMatrix(graphEst)
amat[which(amat != 0)] <- 1 ## i->j if amat[j,i]==1
amatSkel <- amat + t(amat)
amatSkel[amatSkel != 0] <- 1
## find unique and ambiguous parents of x
wgt.est <- (ad.g != 0)
tmp <- wgt.est-t(wgt.est)
tmp[which(tmp < 0)] <- 0
wgt.unique <- tmp
wgt.ambig <- wgt.est-wgt.unique
pa1 <- which(wgt.unique[x.pos,] != 0)
pa2 <- which(wgt.ambig[x.pos,] != 0)
## estimate beta
if (length(pa2) == 0) {
beta.tmp <- lm.cov(mcov,y.pos.set,c(x.pos,pa1)) ####
beta.tmp[y.pos.set %in% pa1] <- 0
beta.hat <- cbind(beta.tmp)
} else { ## at least one undirected parent
## no member of pa2
pa2.f <- pa2
pa2.t <- NA
beta.hat <-
if (!has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) {
beta.tmp <- lm.cov(mcov,y.pos.set,c(x.pos,pa1)) ####
beta.tmp[y.pos.set %in% pa1] <- 0
cbind(beta.tmp)
} # else NULL
## exactly one member of pa2
for (i2 in seq_along(pa2)) {
pa2.f <- pa2[-i2]
pa2.t <- pa2[i2]
if (!has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) {
beta.tmp <- lm.cov(mcov,y.pos.set,c(x.pos,pa1,pa2.t)) ####
beta.tmp[y.pos.set %in% c(pa1,pa2.t)] <- 0
beta.hat <- cbind(beta.hat, beta.tmp)
}
} ## for (i2 in seq_along(pa2))
## higher order subsets of pa2
if (length(pa2) > 1)
for (i in 2:length(pa2)) {
pa.tmp <- combn(pa2,i,simplify = TRUE)
for (j in seq_len(ncol(pa.tmp))) {
pa2.t <- pa.tmp[,j]
pa2.f <- setdiff(pa2, pa2.t)
if (!has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) {
beta.tmp <- lm.cov(mcov,y.pos.set,c(x.pos,pa1,pa2.t)) ####
beta.tmp[y.pos.set %in% c(pa1,pa2.t)] <- 0
beta.hat <- cbind(beta.hat, beta.tmp)
}
} ## for (j )
} ## for (i )
} ## if .. else length(pa2) > 0)
## MM: for now, maybe in the future get sensible column names:
colnames(beta.hat) <- NULL
if (nrow(beta.hat) > 0) rownames(beta.hat) <- as.character(y.pos.set)
beta.hat
}
## -> ../man/legal.path.Rd
## only called in qreach() with only 'c' varying
legal.path <- function(a,b,c, amat)
{
## Purpose: Is path a-b-c legal (either collider in b or a,b,c is triangle)
## !! a-b-c must be in a path !! this is not checked !!
## ----------------------------------------------------------------------
## Arguments:
## - a, b, c: nodes
## - amat: adj matrix (coding 0,1,2 for no edge, circle, arrowhead)
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 29 Oct 2009; Martin Maechler
if(a == c || (a.b <- amat[a,b]) == 0 || amat[b,c] == 0)
return(FALSE)
## else a != c and amat[a,b] != 0 and amat[b,c] != 0
## return TRUE iff
(amat[a,c] != 0 || ## triangle
## need not check [c,a], since there must be SOME edgemark !=0 at [a,c], if
## edge is present
(a.b == 2 && amat[c,b] == 2)) ## a collider
}
##' Plot a subgraph for a specified starting node and a given graph
##' @param graphObj Graph object
##' @param y Starting node
##' @param dist Distance of nodes included in subgraph from starting node y
##' @param amat Adjacency matrix of skeleton graph (optional)
##' @param directed should the plotted subgraph be directed?
##' @param main
##' --------------- see ../man/plotSG.Rd
plotSG <- function(graphObj, y, dist, amat = NA, directed = TRUE,
plot = requireNamespace("Rgraphviz"),
main = paste("Subgraph of", deparse(substitute(graphObj)),
"from ", y, " with dist <=", dist),
cex.main = 1.25, font.main = par("font.main"), col.main=par("col.main"),
...)
{
## Author: Daniel Stekhoven, Date: 26 Jan 2010; MM: tweaks
stopifnot(dist >= 1)
## Extract adjacency matrix (if necessary)
if (any( is.na(amat)))
amat <- wgtMatrix(graphObj)
## Diagonalise (has no effect if already diagonal)
amat[amat != 0] <- 1
amat <- amat + t(amat)
diag(amat) <- 0 # can that happen anyway??
amat[amat == 2] <- 1
## Find connected nodes hierarchically
nh <- which( amat[y,] == 1 )
rel.nodes <- c( y, nh )
for (i in seq_len(dist-1L)) {
nh <-
if ( length(nh) == 1 )
which( amat[nh,] == 1 )
else if (length(nh) != 0)
which(amat[nh,] == 1, arr.ind = TRUE)[,"col"]
## else NULL
rel.nodes <- unique( c( rel.nodes, nh ) )
}
## Name nodes
if(is(graphObj, "graphNEL"))
names(rel.nodes) <- graphObj@nodes[rel.nodes]
## subgraph - distinguish between directed edges or not
sg <- if (directed)
subGraph(as.character(rel.nodes), graphObj)
else
as(amat[rel.nodes, rel.nodes], "graphNEL")
## Plot subgraph
if(plot) {
if(requireNamespace("Rgraphviz")) {
## FIXME: use "new Rgraphvis interface: layoutGraph(), renderGraph() [includes title!]
Rgraphviz::plot(sg, ...) ## TODO: leave room for title
if(!is.null(main))
title(main = main, cex.main=cex.main, font.main=font.main, col.main=col.main)
} else check.Rgraphviz() # error!
invisible(sg)
}
else sg
}
##########################################################################
##
## Functions for the conservative versions (PC, FCI (all), and RFCI)
##
#########################################################################
## Functions used by all algorithms
##########################################################
pc.cons.intern <- function(sk, suffStat, indepTest, alpha,
version.unf = c(NA,NA), maj.rule = FALSE, verbose = FALSE)
{
## Purpose: For any unshielded triple A-B-C, consider all subsets D of
## the neighbors of A and of the neighbors of C, and record the sets
## D for which A and C are conditionally independent given D. If B
## is in none of these sets, do nothing (it is a
## v-structure) and also delete B from sepset(A,C) if present (so we are
## sure that a v-structure will be created). If B is in all sets, do nothing
## (it is not a v-structure) and also add B to sepset(A,C) if not present
## (so we are sure that a v-structure will not be created). If maj.rule=FALSE
## the normal conservative version is applied, hence if B is in
## some but not all sets, mark the triple as "ambiguous". If maj.rule=TRUE
## we mark the triple as "ambiguous" if B is in exactly 50% of the cases,
## if less than 50% define it as a v-structure, and if in more than 50%
## no v-structure.
## ----------------------------------------------------------------------
## Arguments: - sk: output returned by function "skeleton"
## - suffStat: Sufficient statistics for independent tests
## - indepTest: Function for independence test
## - alpha: Significance level of test
## - version.unf[1]: 1 it checks if b is in some sepsets,
## 2 it also checks if there exists a sepset
## which is a subset of the neighbours.
## - version.unf[2]: 1 same as in Tetrad (do not consider
## the initial sepset), 2 it also considers
## the initial sepset
## - maj.rule: FALSE/TRUE if the majority rule idea is applied
## ----------------------------------------------------------------------
## Value: - unfTripl: Triple that were marked as unfaithful
## - vers: vector containing the version (1 or 2) of the
## corresponding triple saved in unfTripl (1=normal
## unfaithful triple that is B is in some sepsets;
## 2=triple coming from version.unf[1]==2
## that is a and c are indep given the initial sepset
## but there doesn't exist a subset of the neighbours
## that d-separates them)
## - sk: updated skelet object, sepsets might have been updated
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 12 Feb 2010, 10:43
## Modifications: Diego Colombo
g <- as(sk@graph,"matrix")
stopifnot(all(g == t(g))) ## g is guaranteed to be symmetric
p <- as.numeric(dim(g)[1])
unfTripl <- vers <- rep(NA,min(p*p,100000))
counter <- 0
if (sum(g) > 0) {
ind <- which(g == 1, arr.ind = TRUE)
tripleMatrix <- NULL
## Go through all edges
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
allC <- setdiff(which(g[b,] == 1),a) ## a-b-c
newC <- allC[g[a,allC] == 0]
tmpMatrix <- cbind(rep(a,length(newC)),rep(b,length(newC)),newC)
tripleMatrix <- rbind(tripleMatrix,tmpMatrix)
colnames(tripleMatrix) <- c("","","")
}
if ((m <- nrow(tripleMatrix)) > 0) {
deleteDupl <- logical(m)# all FALSE
for (i in seq_len(m))
if (tripleMatrix[i,1] > tripleMatrix[i,3])
deleteDupl[i] <- TRUE
if(any(deleteDupl))
tripleMatrix <- tripleMatrix[!deleteDupl,, drop = FALSE]
for (i in seq_len(nrow(tripleMatrix))) {
## pay attention to the size of counter
if (counter+1L == length(unfTripl)) {
n.xtra <- min(p*p, 100000)
new.len <- counter+1L + n.xtra
length(unfTripl) <- new.len
length(vers) <- new.len
}
a <- tripleMatrix[i,1]
b <- tripleMatrix[i,2]
c <- tripleMatrix[i,3]
nbrsA <- which(g[,a] != 0) ## G symm; c no nbr of a
nbrsC <- which(g[,c] != 0)
if (verbose) {
cat("\nTriple:", a,b,c,"and sepset by skelet:",
unique(sk@sepset[[a]][[c]],sk@sepset[[c]][[a]]),"\n")
}
r.abc <- checkTriple(a, b, c, nbrsA, nbrsC,
sk@sepset[[a]][[c]], sk@sepset[[c]][[a]],
suffStat = suffStat, indepTest = indepTest, alpha = alpha,
version.unf = version.unf, maj.rule = maj.rule, verbose = verbose)
## 1: in NO set; 2: in ALL sets; 3: in SOME but not all
## Take action only if case "3"
if (r.abc$decision == 3) {
## record ambiguous triple
counter <- counter + 1
unfTripl[counter] <- triple2numb(p,a,b,c)
vers[counter] <- r.abc$version
}
## can happen the case in Tetrad, so we must save the triple
## as ambiguous:
## a and c independent given S but not given subsets of the
## adj(a) or adj(c)
if ((version.unf[1] == 2) && (r.abc$version == 2) && (r.abc$decision != 3)) {
counter <- counter + 1
unfTripl[counter] <- triple2numb(p,a,b,c)
vers[counter] <- r.abc$version
}
sk@sepset[[a]][[c]] <- r.abc$SepsetA
sk@sepset[[c]][[a]] <- r.abc$SepsetC
}
}
}
length(unfTripl) <- length(vers) <- counter
list(unfTripl = unfTripl, vers = vers, sk = sk)
}
## Called both from pc.cons.intern() and rfci.vStruc() :
checkTriple <- function(a, b, c, nbrsA, nbrsC, sepsetA, sepsetC,
suffStat, indepTest, alpha, version.unf = c(NA,NA),
maj.rule = FALSE, verbose = FALSE)
{
## Purpose: For each subset of nbrsA and nbrsC where a and c are cond.
## independent, it is checked if b is in the conditioning set.
## ----------------------------------------------------------------------
## Arguments: - a,b,c: Nodes (positions in adjacency matrix)
## - nbrsA: Neighbors of a
## - nbrsC: Neighbors of c
## - sepsetA: sepset(a,c)
## - sepsetC: sepset(c,a)
## - suffStat: Sufficient statistics for independent tests
## - indepTest: Function for independence test
## - alpha: Significance level of test
## - version.unf[1]: 1 it checks if b is in some sepsets,
## 2 it also checks if there exists a sepset
## which is a subset of the neighbours.
## - version.unf[2]: 1 same as Tetrad (do not consider the initial
## sepset), 2 consider if b is in sepsetA
## or sepsetC
## - maj.rule: FALSE/TRUE if the majority rule idea is applied
## ----------------------------------------------------------------------
## Value: - decision: res
## res = 1: b is in NO sepset (-> v-structure)
## res = 2: b is in ALL sepsets (-> no v-structure)
## res = 3: b is in SOME but not all sepsets (-> ambiguous triple)
## - version: version (1 or 2) of the ambiguous triple
## (1=normal ambiguous triple that is b is in some sepsets;
## 2=triple coming from version.unf[1]==2 that is a and c are
## indep given the initial sepset but there doesn't exist a
## subset of the neighbours that d-separates them)
## - sepsetA and sepsetC: updated separation sets
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 12 Feb 2010, 12:13
## Modifications: Diego Colombo, Martin Maechler
## loop through all subsets of parents
nr.indep <- 0
stopifnot(length(version.unf) == 2, version.unf %in% 1:2)
## Tetrad
tmp <- if (version.unf[2] == 2) ## our version
(b %in% sepsetA || b %in% sepsetC) ## else NULL = Tetrad version
version <- 0
## start with the neighbours of a
if ((nn <- length(nbrsA)) > 0) {
allComb <- expand.grid(lapply(integer(nn), function(.) 0:1))
## loop through all subsets of neighbours
for (i in 1:nrow(allComb)) { ## == 1:(2^nn)
S <- nbrsA[which(allComb[i,] != 0)]
pval <- indepTest(a, c, S, suffStat)
## save the pval and the set that produced this pval
if (verbose) cat("a: S =",S," - pval =",pval,"\n")
if (pval >= alpha) {
nr.indep <- nr.indep + 1
## is b in set?
tmp <- c(tmp, b %in% S)
version <- 1
}
}
}
## now with the neighbours of c
if ((nn <- length(nbrsC)) > 0) {
allComb <- expand.grid(lapply(integer(nn), function(.) 0:1))
## loop through all subsets of neighbours
for (i in 1:nrow(allComb)) { ## == 1:(2^nn)
S <- nbrsC[which(allComb[i,] != 0)]
pval <- indepTest(a, c, S, suffStat)
## save the pval and the set that produced this pval
if (verbose) cat("c: S =",S," - pval =",pval,"\n")
if (pval >= alpha) {
nr.indep <- nr.indep + 1
## is b in set?
tmp <- c(tmp, b %in% S)
version <- 1
}
}
}
if (version.unf[1] == 2 && nr.indep == 0) {
version <- 2
}
if (is.null(tmp)) tmp <- FALSE
if (all(tmp)) {
res <- 2 ## in ALL sets
## therefore a - b - c is not a v-structure, hence add b to sepset(a,c)
## and sepset(c,a)
## for example it can happen that b is not in sepset(a,c) or sepset(c,a)
## but now it is in each set that separates a and c given the neighbours
if (b %nin% sepsetA) sepsetA <- c(sepsetA, b)
if (b %nin% sepsetC) sepsetC <- c(sepsetC, b)
} else {
if (all(!tmp)) {
res <- 1 ## in NO set
## therefore a - b - c is a v-structure, hence delete b from
## sepset(a,c) and sepset(c,a)
## for example it can happen that b is in sepset(a,c) or sepset(c,a)
## but now it is in no set that separates a and c given the neighbours
sepsetA <- setdiff(sepsetA,b)
sepsetC <- setdiff(sepsetC,b)
} else {
## normal conservative PC, b is in some sets hence the triple
## is unfaithful
if (!maj.rule) {
res <- 3 ## in SOME sets
} else {
## use the majority rule to test if the triple is faithful
## or not and then decide if it is a v-structure or not accordigly
## NEW check the percentage of b in the conditioning sets that
## make a and c independent
if (sum(tmp)/length(tmp) < 0.5) {
## we accept that b is in NO set
res <- 1 ## in NO set
## therefore a - b - c is a v-structure, hence delete b
## from sepset(a,c) and sepset(c,a)
## for example it can happen that b is in sepset(a,c) or
## sepset(c,a) but now it is in no set that
## separates a and c given the neighbours
sepsetA <- setdiff(sepsetA,b)
sepsetC <- setdiff(sepsetC,b)
} else if (sum(tmp)/length(tmp) > 0.5) {
## we accept that b is in ALL set
res <- 2 ## in ALL sets
## therefore a - b - c is not a v-structure, hence add b
## to sepset(a,c) and sepset(c,a)
## for example it can happen that b is not in sepset(a,c)
## or sepset(c,a) but now it is in each set that
## separates a and c given the neighbours
if (b %nin% sepsetA) sepsetA <- c(sepsetA,b)
if (b %nin% sepsetC) sepsetC <- c(sepsetC,b)
} else if (sum(tmp)/length(tmp) == 0.5) {
## define the triple as unfaithful, because half of the
## times b is in the set and half of them in not in
res <- 3 ## in SOME sets
}
}
}
}
if (verbose && res == 3) cat("Triple ambiguous\n")
## if you save a variable <- NULL into a list it will delete this element!
## The following also transforms NULL sepset* to integer(0):
lapply(list(decision = res, version = version, SepsetA = sepsetA, SepsetC = sepsetC),
as.integer)
} ## {checkTriple}
## For R5 and R9-R10
######################################################
faith.check <- function(cp, unfVect, p, boolean = TRUE)
{
## Purpose: check if every triple on the circle path cp is unambiguous
## ----------------------------------------------------------------------
## Arguments: cp: circle path to check for unambiguity
## boolean: if TRUE, return TRUE iff there is no ambiguity, i.e. "faithful"
## if FALSE, return the number of ambiguities.
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 25 May 2010; 'boolean' etc by Martin Maechler
if(!boolean) res <- 0L
n <- length(cp)
## MM: FIXME speedup by precomputing (l%%n)+1, ((l+1)%%n)+1, and ((l+2)%%n)+1 as *integers*
## ok, in steps: first "slowly" but surely correct
ii <- 0:(n-1L)
i1 <- (ii %% n)+1L
i2 <- ((ii+1L) %% n)+1L
i3 <- ((ii+2L) %% n)+1L
for (l in ii) {
if (any(unfVect == triple2numb(p,cp[i1[l]],cp[i2[l]],cp[i3[l]]), na.rm = TRUE) ||
any(unfVect == triple2numb(p,cp[i3[l]],cp[i2[l]],cp[i1[l]]), na.rm = TRUE)) {
if(boolean) return(FALSE) # the first time we found one: not faithful
## else count
res <- res + 1L
}
}
if(boolean) TRUE else res
}
###############################################################################
##
## FCI, RFCI, and fast FCI-oracle
##
###############################################################################
## Internal function used by FCI and RFCI
##############################################################################
triple2numb <- function(p,i,j,k)
{
## Purpose: transform a triple i-j-k into a unique number
## ----------------------------------------------------------------------
## Arguments:-p:number of nodes;-triple: i-j-k
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 11 May 2010; Martin Maechler
## as.numeric(.): not integer arithmetic which easily overflows
k + (p. <- as.numeric(p)) * (j + p.*i)
}
## Functions for R4, R5, and R9-R10 for FCI(all) and RFCI
############################################################################
updateList <- function(path, set, old.list)
{
## Purpose: update the list of all paths in the iterative functions
## minDiscrPath, minUncovCircPath and minUncovPdPath
## ----------------------------------------------------------------------
## Arguments: - path: the path under investigation
## - set: (integer) index set of variables to be added to path
## - old.list: the list to update
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 21 Oct 2011; Without for() by Martin Maechler
c(old.list, lapply(set, function(s) c(path,s)))
}
## R9-R10
minUncovPdPath <- function(p, pag, a,b,c, unfVect, verbose = FALSE)
{
## Purpose: find a minimal uncovered pd path for a,b,c saved in path.
## Check also for the conservative case that it is unambiguous
## If a path exists this is the output, otherwise NA
## ----------------------------------------------------------------------
## Arguments: - p: number of nodes in the graph
## - pag: adjacency matrix
## - a,b,c : nodes under interest
## - unfVect: vector containing the ambiguous triples
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 19 Oct 2011; small changes: Martin Maechler, Joris Mooij
## first check whether a,b,c is already a upd path
stopifnot( (pag[a,b] == 1 | pag[a,b] == 2) &
(pag[b,a] == 1 | pag[b,a] == 3) )
min.upd.path <- NA
done <- FALSE
if( (pag[b,c] == 1 | pag[b,c] == 2) &
(pag[c,b] == 1 | pag[c,b] == 3) &
(pag[c,a] == 0) ) {
mpath = c(a,b,c)
if (length(unfVect) == 0 || ## <<- normal version: just save
## conservative version, check the path to be faithful:
faith.check(mpath, unfVect, p)) {
## save the path to be returned
min.upd.path <- mpath
if( verbose )
cat(' minUncovPdPath: path found: ',mpath,', uncovered: ',TRUE,'\n')
done <- TRUE
}
}
## now check paths of 4 or more nodes of the form <a,b,...,c>
if( !done ) {
visited <- rep(FALSE, p)
visited[c(a,b,c)] <- TRUE
min.upd.path <- NA
## find all neighbours of b not visited yet
indD <- which((pag[b,] == 1 | pag[b,] == 2) &
(pag[,b] == 1 | pag[,b] == 3) &
(pag[,a] == 0) & !visited)
if (length(indD) > 0) {
path.list <- updateList(b, indD, NULL)
done <- FALSE
while ((length(path.list) > 0) && (!done)) {
## next element in the queue
mpath <- path.list[[1]]
m <- length(mpath)
d <- mpath[m]
path.list[[1]] <- NULL
visited[d] <- TRUE
if (any(pag[d,c] == 1:2) && any(pag[c,d] == c(1,3))) {
## pd path found
mpath <- c(a, mpath, c)
n <- length(mpath)
## check the path to be uncovered
uncov <- TRUE
for (l in seq_len(n - 2)) {
if (!(pag[mpath[l], mpath[l + 2]] == 0 &&
pag[mpath[l + 2], mpath[l]] == 0)) {
uncov <- FALSE
break ## speed up!
}
}
if( verbose )
cat(' minUncovPdPath: path found: ',mpath,', uncovered: ',uncov,'\n')
## if it is uncovered
if (uncov)
if (length(unfVect) == 0 || ## <<- normal version: just save
## conservative version, check the path to be faithful:
faith.check(mpath, unfVect, p)) {
## save the path to be returned
min.upd.path <- mpath
done <- TRUE
}
}
else {
## d and c are either not connected or connected with a "wrong" edge -----> search iteratively
## find all neighbours of d not visited yet
indR <- which((pag[d,] == 1 | pag[d,] == 2) &
(pag[,d] == 1 | pag[,d] == 3) & !visited)
if (length(indR) > 0) {
## update the queues
path.list <- updateList(mpath, indR, path.list)
}
}
} ## {while}
}
}
min.upd.path
} ## {minUncovPdPath}
## R5
minUncovCircPath <- function(p, pag, path, unfVect, verbose = FALSE)
{
## Purpose: find a minimal uncovered circle path for a,c,d,b saved in path.
## Check also for the conservative case that it is unambiguous
## If a path exists this is the output, otherwise NA
## ----------------------------------------------------------------------
## Arguments: - p: number of nodes in the graph
## - pag: adjacency matrix
## - path: a,c,d,b under interest
## - unfVect: vector containing the unfaithful triples
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 19 Oct 2011, 13:11
visited <- rep(FALSE, p)
visited[path] <- TRUE # (a,b,c,d) all 'visited'
a <- path[1]
c <- path[2]
d <- path[3]
b <- path[4]
min.ucp.path <- NA
## find all neighbours of c not visited yet
indX <- which(pag[c,] == 1 & pag[,c] == 1 & !visited) ## c o-o x
if (length(indX) > 0) {
path.list <- updateList(c, indX, NULL)
done <- FALSE
while (!done && length(path.list) > 0) {
## next element in the queue
mpath <- path.list[[1]]
x <- mpath[length(mpath)]
path.list[[1]] <- NULL
visited[x] <- TRUE
if (pag[x,d] == 1 && pag[d,x] == 1) {
## circle path found
mpath <- c(a, mpath, d, b)
n <- length(mpath)
## check the path to be uncovered
uncov <- TRUE
for (l in seq_len(n - 2)) {
if (!(pag[mpath[l], mpath[l + 2]] == 0 &&
pag[mpath[l + 2], mpath[l]] == 0)) {
uncov <- FALSE
break ## speed up!
}
}
## if it is uncovered
if (uncov)
if (length(unfVect) == 0 || ## <<- normal version: just save
## conservative version, check the path to be faithful:
faith.check(mpath, unfVect, p)) {
## save the path to be returned
min.ucp.path <- mpath
done <- TRUE
}
}
else {
## x and d are either not connected or connected with an edge which is not o--o -----> search iteratively
## find all neighbours of x not visited yet
indR <- which(pag[x,] == 1 & pag[,x] == 1 & !visited) ## x o--o r
if (length(indR) > 0) {
## update the queues
path.list <- updateList(mpath, indR, path.list)
}
}
}## {while}
}
return(min.ucp.path)
}
## R4
minDiscrPath <- function(pag, a,b,c, verbose = FALSE)
{
## Purpose: find a minimal discriminating path for a,b,c.
## If a path exists this is the output, otherwise NA
## ----------------------------------------------------------------------
## Arguments: - pag: adjacency matrix
## - a,b,c: node positions under interest
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 25 Jan 2011; speedup: Martin Maechler
p <- as.numeric(dim(pag)[1])
visited <- rep(FALSE, p)
visited[c(a,b,c)] <- TRUE # {a,b,c} "visited"
## find all neighbours of a not visited yet
indD <- which(pag[a,] != 0 & pag[,a] == 2 & !visited) ## d *-> a
if (length(indD) > 0) {
path.list <- updateList(a, indD, NULL)
while (length(path.list) > 0) {
## next element in the queue
mpath <- path.list[[1]]
m <- length(mpath)
d <- mpath[m]
if (pag[c,d] == 0 & pag[d,c] == 0)
## minimal discriminating path found :
return( c(rev(mpath), b,c) )
## else :
pred <- mpath[m-1]
path.list[[1]] <- NULL
## d is connected to c -----> search iteratively
if (pag[d,c] == 2 && pag[c,d] == 3 && pag[pred,d] == 2) {
visited[d] <- TRUE
## find all neighbours of d not visited yet
indR <- which(pag[d,] != 0 & pag[,d] == 2 & !visited) ## r *-> d
if (length(indR) > 0)
## update the queues
path.list <- updateList(mpath[-1], indR, path.list)
}
} ## {while}
}
## nothing found: return
NA
} ## {minDiscrPath}
###############################################################################
## FCI
###############################################################################
# fci <- function(suffStat, indepTest, alpha, labels, p,
# skel.method = c("stable", "original", "stable.fast"),
# type = c("normal", "anytime", "adaptive"),
# fixedGaps = NULL, fixedEdges = NULL, NAdelete = TRUE,
# m.max = Inf, pdsep.max = Inf, rules = rep(TRUE, 10),
# doPdsep = TRUE, biCC = FALSE, conservative = FALSE,
# maj.rule = FALSE, numCores = 1, verbose = FALSE)
# {
# ## Purpose: Perform FCI-Algorithm, i.e., estimate PAG
# ## ----------------------------------------------------------------------
# ## Arguments:
# ## - suffStat, indepTest: info for the tests
# ## - p: number of nodes in the graph
# ## - alpha: Significance level of individual partial correlation tests
# ## - verbose: 0 - no output, 1 - detailed output
# ## - fixedGaps: the adjacency matrix of the graph from which the algorithm
# ## should start (logical); gaps fixed here are not changed
# ## - fixedEdges: Edges marked here are not changed (logical)
# ## - NAdelete: delete edge if pval=NA (for discrete data)
# ## - m.max: maximum size of conditioning set
# ## - pdsep.max: maximaum size of conditioning set for Possible-D-SEP
# ## - rules: array of length 10 wich contains TRUE or FALSE corresponding
# ## to each rule. TRUE means the rule will be applied.
# ## If rules==FALSE only R0 (minimal pattern) will be used
# ## - doPdsep: compute possible dsep
# ## - biCC: TRUE or FALSE variable containing if biconnected components are
# ## used to compute pdsep
# ## - conservative: TRUE or FALSE defining if
# ## the v-structures after the pdsep
# ## have to be oriented conservatively or nor
# ## - maj.rule: TRUE or FALSE variable containing if the majority rule is
# ## used instead of the normal conservative
# ## - labels: names of the variables or nodes
# ## - type: it specifies the version of the FCI that has to be used.
# ## Per default it is normal, the normal FCI algorithm. It can also be
# ## anytime for the Anytime FCI and in this cas m.max must be specified;
# ## or it can be adaptive for Adaptive Anytime FCI and in this case
# ## m.max must not be specified.
# ## - numCores: handed to skeleton(), used for parallelization
#
# ## ----------------------------------------------------------------------
# ## Author: Markus Kalisch, Date: Dec 2009; update: Diego Colombo, 2012; Martin Maechler, 2013
#
# cl <- match.call()
# if(!missing(p)) stopifnot(is.numeric(p), length(p <- as.integer(p)) == 1, p >= 2)
# if(missing(labels)) {
# if(missing(p)) stop("need to specify 'labels' or 'p'")
# labels <- as.character(seq_len(p))
# } else { ## use labels ==> p from it
# stopifnot(is.character(labels))
# if(missing(p)) {
# p <- length(labels)
# } else if(p != length(labels))
# stop("'p' is not needed when 'labels' is specified, and must match length(labels)")
# else
# message("No need to specify 'p', when 'labels' is given")
# }
#
# ## Check that the type is a valid one
# type <- match.arg(type)
# if (type == "anytime" && m.max == Inf)
# stop("To use the Anytime FCI you must specify a finite 'm.max'.")
# if (type == "adaptive" && m.max != Inf)
# stop("To use the Adaptive Anytime FCI you must not specify 'm.max'.")
#
# if (conservative && maj.rule)
# stop("Choose either conservative FCI or majority rule FCI")
#
# cl <- match.call()
# if (verbose) cat("Compute Skeleton\n================\n")
#
# skel <- skeleton(suffStat, indepTest, alpha, labels = labels, method = skel.method,
# fixedGaps = fixedGaps, fixedEdges = fixedEdges,
# NAdelete=NAdelete, m.max=m.max, numCores=numCores, verbose=verbose)
# skel@call <- cl # so that makes it into result
# G <- as(skel@graph, "matrix")
# sepset <- skel@sepset
# pMax <- skel@pMax
# n.edgetestsSKEL <- skel@n.edgetests
# max.ordSKEL <- skel@max.ord
# allPdsep <- NA
# tripleList <- NULL
#
# if (doPdsep) {
# if (verbose) cat("\nCompute PDSEP\n=============\n")
# pc.ci <- pc.cons.intern(skel, suffStat, indepTest,
# alpha = alpha, version.unf = c(1,1),
# maj.rule = FALSE, verbose = verbose)
# ## Recompute (sepsets, G, ...):
# pdsepRes <- pdsep(skel@graph, suffStat, indepTest = indepTest, p = p,
# sepset = pc.ci$sk@sepset, alpha = alpha, pMax = pMax,
# m.max = if (type == "adaptive") max.ordSKEL else m.max,
# pdsep.max = pdsep.max, NAdelete = NAdelete,
# unfVect = pc.ci$unfTripl, # "tripleList.pdsep"
# biCC = biCC, verbose = verbose)
#
# ## update the graph & sepset :
# G <- pdsepRes$G
# sepset <- pdsepRes$sepset
# pMax <- pdsepRes$pMax
# allPdsep <- pdsepRes$allPdsep
# n.edgetestsPD <- pdsepRes$n.edgetests
# max.ordPD <- pdsepRes$max.ord
# if (conservative || maj.rule) {
# if (verbose)
# cat("\nCheck v-structures conservatively\n=================================\n")
# tmp.pdsep <- new("pcAlgo", graph = as(G, "graphNEL"), call = cl,
# n = integer(0), max.ord = as.integer(max.ordSKEL),
# n.edgetests = n.edgetestsSKEL, sepset = sepset,
# pMax = pMax, zMin = matrix(NA, 1, 1))
# sk. <- pc.cons.intern(tmp.pdsep, suffStat, indepTest, alpha,
# verbose = verbose, version.unf = c(1, 1),
# maj.rule = maj.rule)
# tripleList <- sk.$unfTripl
# ## update the sepsets
# sepset <- sk.$sk@sepset
# }
# }
# else {## !doPdsep : "do not Pdsep"
# n.edgetestsPD <- 0
# max.ordPD <- 0
# allPdsep <- vector("list", p)
# if (conservative || maj.rule) {
# if (verbose)
# cat("\nCheck v-structures conservatively\n=================================\n")
# nopdsep <- pc.cons.intern(skel, suffStat, indepTest, alpha,
# verbose = verbose, version.unf = c(2, 1),
# maj.rule = maj.rule)
# tripleList <- nopdsep$unfTripl
# ## update the sepsets
# sepset <- nopdsep$sk@sepset
# }
# }
# if (verbose)
# cat("\nDirect egdes:\n=============\nUsing rules:", which(rules),
# "\nCompute collider:\n")
# res <- udag2pag(pag = G, sepset, rules = rules, unfVect = tripleList,
# verbose = verbose)
# colnames(res) <- rownames(res) <- labels
# new("fciAlgo", amat = res, call = cl, n = integer(0),
# max.ord = as.integer(max.ordSKEL),
# max.ordPDSEP = as.integer(max.ordPD),
# n.edgetests = n.edgetestsSKEL, n.edgetestsPDSEP = n.edgetestsPD,
# sepset = sepset, pMax = pMax, allPdsep = allPdsep)
# } ## {fci}
## only called in pdsep()
qreach <- function(x,amat,verbose = FALSE)
{
## Purpose: Compute possible-d-sep(x) ("psep")
## !! The non-zero entries in amat must be symmetric !!
## ----------------------------------------------------------------------
## Arguments:
## - x: node of which psep berechnet werden soll
## - amat: adjacency matrix
## amat[i,j] = 0 iff no edge btw i,j
## amat[i,j] = 1 iff i *-o j
## amat[i,j] = 2 iff i *-> j
## - verbose: Show checked node sequence
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 29 Oct 2009, 11:54
## Stopping:
## =========
## At every iteration, Q get's reduced by one. It is only increased by
## at least one, if there are edges in A. and then, at least one
## edge in A. is removed. Edges are never inserted into A..
## Thus, either Q or A. becomes empty and the loop stops.
## Runtime:
## ========
## At least O(|V|), since look up in adjacency matrix is made. Assume O(|E|)>O
## Every edge can be visited at most twice. At each visit, there are no
## more than max(deg(V_i)) neighboring edges to look at. Thus, the runtime is
## O(2*|E| * max(deg(V_i))) = O(|E|^2) [worst case]; O(|E|) if sparse in the
## sense that max(deg(V_i)) is constant.
## Correctness:
## ============
## (A) All nodes in PSEP have a path of legal triples from x.
## (B) If there is a legal path from x to y in amat, at least one of them
## is found and y is recorded in PSEP:
## Suppose there is a node y != x that has a legal path from x, but is not in
## PSEP. y cannot be in nbrs(x), because they are added and nothing is
## deleted from PSEP. Hence, there must be a node z which
## is in PSEP but has a neighbor w in amat that has a legal path from
## x but is not in PSEP.
## Assuming that the function legal is correct, and noting that at (*) all
## neighbors of z in A. (tmp!) are analyzed, it follows that w is not
## in adj(z) in A. (but in amat). Thus, w must have been removed
## before from adj(z). Because of (+), it could only have been removed if
## u-z-w was found legal at some point. But then, w would have been added
## to PSEP. This is a contradiction to the assumption that w is not in PSEP.
## check: quadratic; x in V; edgemarks ok; non-zeroes symmetric
stopifnot((ncol(amat) == nrow(amat)),x <= ncol(amat),all(amat %in% c(0,1,2)),
all((amat != 0) == (t(amat != 0))))
A. <- (amat != 0) ## A.[i,j] is true <===> edge i--j
PSEP <- Q <- nb <- which(A.[x,])
P <- rep.int(x, length(Q))
A.[x,nb] <- FALSE ## delete edge to nbrs
while(length(Q) > 0) {
## Invariants:
## ===========
## (A1) length(Q) == length(P) > 0
## (A2) non-zero in A. -> non-zero in amat [no non-zero added]
## (A3) Q[i] and P[i] are adjacent in amat [using (A2)]
if (verbose) {
cat("\n-------------","\n")
cat("Queue Q:",Q,"\n")
cat("Queue P:",P,"\n")
}
a <- Q[1]
Q <- Q[-1]
pred <- P[1] ## not empty because of (A1)
P <- P[-1]
if (verbose) cat("Select",pred,"towards",a,"\n")
nb <- which(A.[a,]) ## (*)
if (verbose) cat("Check nbrs",nb,"\nLegal:")
for (b in nb) {
## Guaranteed: pred-a-b are a path because of (A3)
if (lres <- legal.path(pred,a,b,amat)) {
A.[a,b] <- FALSE ## remove b out of adj(a) in A. (+)
Q <- c(Q,b)
P <- c(P,a)
PSEP <- c(PSEP,b)
}
if (verbose) cat(if(lres)"T" else ".", "")
}
}
sort(setdiff(PSEP,x))
} ## {qreach}
## only called in fci() [by default: doPdsep=TRUE]
# pdsep <- function (skel, suffStat, indepTest, p, sepset, alpha, pMax, m.max = Inf,
# pdsep.max = Inf, NAdelete = TRUE, unfVect = NULL,
# biCC = FALSE, verbose = FALSE) ## FIXME: verbose : 2 --> qreach(verbose)
# {
# ## Purpose: Compute Possible-D-SEP for each node, perform the condittional
# ## independent tests and adapt graph accordingly
# ## ----------------------------------------------------------------------
# ## Arguments:
# ## - skel: Graph object returned by function skeleton
# ## - suffStat, indepTest: infofor the independence tests
# ## - p: number of nodes in the graph
# ## - sepset: Sepset that was used for finding the skeleton
# ## - alpha: niveau for the tests
# ## - pMax: Maximal p-values during estimation of skeleton
# ## - m.max: maximal size of the conditioning sets
# ## - pdsep.max: maximaum size of conditioning set for Possible-D-SEP
# ## - unfVect: vector containing the unfaithful triples, used for the
# ## conservative orientation of the v-structures
# ## - biCC: if the biconnected components have to be used
# ## ----------------------------------------------------------------------
# ## Value:
# ## - G: Updated boolean adjacency matrix
# ## - sepset: Updated sepsets
# ## - pMax: Updated pMax
# ## - allPdsep: Possible d-sep for each node [list]
# ## ----------------------------------------------------------------------
# ## Author: Markus Kalisch, Date: 9 Dec 2009
# ## Modification: Diego Colombo; Martin Maechler
#
# G <- (as(skel, "matrix") != 0)
# n.edgetests <- rep(0, 1000)
# ord <- 0L
# allPdsep.tmp <- vector("list", p)
# if(biCC)
# conn.comp <- lapply(biConnComp(skel), as.numeric)
# if (any(G)) {
# amat <- G
# ind <- which(G, arr.ind = TRUE)
# storage.mode(amat) <- "integer" # (TRUE, FALSE) --> (1, 0)
# ## Orient colliders
# if (verbose) cat("\nCompute collider:\n")
# for (i in seq_len(nrow(ind))) {
# x <- ind[i, 1]
# y <- ind[i, 2]
# allZ <- setdiff(which(amat[y, ] != 0), x)
# for (z in allZ) {
# if (amat[x, z] == 0 &&
# !(y %in% sepset[[x]][[z]] ||
# y %in% sepset[[z]][[x]])) {
#
# if (length(unfVect) == 0) { ## normal version -------------------
# amat[x, y] <- amat[z, y] <- 2
# if (verbose) cat("\n",x,"*->", y, "<-*", z, "\n")
# }
# else { ## conservative version : check if x-y-z is faithful
# if (!any(unfVect == triple2numb(p,x,y,z), na.rm = TRUE) &&
# !any(unfVect == triple2numb(p,z,y,x), na.rm = TRUE)) {
# amat[x, y] <- amat[z, y] <- 2
# if (verbose)
# cat("\n",x,"*->", y, "<-*", z, "\n")
# }
# }
# }
# } ## for( z )
# } ## for( i )
# allPdsep <- lapply(1:p, qreach, amat = amat)# verbose = (verbose >= 2)
# allPdsep.tmp <- vector("list", p)
# for(x in 1:p) {
# if(verbose) cat("\nPossible D-Sep of", x, "is:", allPdsep[[x]], "\n")
# if (any(an0 <- amat[x, ] != 0)) {
# tf1 <- setdiff(allPdsep[[x]], x)
# adj.x <- which(an0)
# for (y in adj.x) {
# if(verbose) cat(sprintf("\ny = %3d\n.........\n", y))
# tf <- setdiff(tf1, y)
# diff.set <- setdiff(tf, adj.x)
# ## bi-connected components
# if (biCC) {
# for(cci in conn.comp) {
# if (x %in% cci && y %in% cci)
# break ## found it
# }
# bi.conn.comp <- setdiff(cci, c(x,y))
# tf <- intersect(tf, bi.conn.comp)
# if (verbose) {
# cat("There is an edge between",x,"and",y,"\n")
# cat("Possible D-Sep of", x,
# "intersected with the biconnected component of",x,"and",y,
# "is:", tf, "\n")
# }
# } ## if(biCC)
# allPdsep.tmp[[x]] <- c(tf,y) ## you must add y to the set
# ## for the large scale simulations, we need to stop the algorithm if
# ## it takes to much time, i.e. sepset>25
# if (length(tf) > pdsep.max) {
# if(verbose)
# cat("Size of Possible-D-SEP bigger than",pdsep.max,
# ". Break the search for the edge between", x,"and",y,"\n")
# } else if (length(diff.set) > 0) {
# done <- FALSE
# ord <- 0L
# while (!done && ord < min(length(tf), m.max)) {
# ord <- ord + 1L
# if(verbose) cat("ord = ", ord, "\n")
# if (ord == 1) {
# for (S in diff.set) {
# pval <- indepTest(x, y, S, suffStat)
# n.edgetests[ord + 1] <- n.edgetests[ord + 1] + 1
# if (is.na(pval))
# pval <- as.numeric(NAdelete) ## = if(NAdelete) 1 else 0
# if (pval > pMax[x, y])
# pMax[x, y] <- pval
# if (pval >= alpha) {
# amat[x, y] <- amat[y, x] <- 0
# sepset[[x]][[y]] <- sepset[[y]][[x]] <- S
# done <- TRUE
# if (verbose)
# cat("x=", x, " y=", y, " S=", S, ": pval =", pval, "\n")
# break
# }
# }
# }
# else { ## ord > 1
# tmp.combn <- combn(tf, ord) ## has choose( |tf|, ord ) columns
# if (ord <= length(adj.x)) {
# for (k in seq_len(ncol(tmp.combn))) {
# S <- tmp.combn[, k]
# if (!all(S %in% adj.x)) {
# n.edgetests[ord + 1] <- n.edgetests[ord + 1] + 1
# pval <- indepTest(x, y, S, suffStat)
# if (is.na(pval))
# pval <- as.numeric(NAdelete) ## = if(NAdelete) 1 else 0
# if(pMax[x, y] < pval)
# pMax[x, y] <- pval
# if (pval >= alpha) {
# amat[x, y] <- amat[y, x] <- 0
# sepset[[x]][[y]] <- sepset[[y]][[x]] <- S
# done <- TRUE
# if (verbose)
# cat("x=", x, " y=", y, " S=", S, ": pval =", pval, "\n")
# break
# }
# }
# } ## for(k ..)
# }
# else { ## ord > |adj.x| :
# ## check all combinations; no combination has been tested before
# for (k in seq_len(ncol(tmp.combn))) {
# S <- tmp.combn[, k]
# n.edgetests[ord + 1] <- n.edgetests[ord + 1] + 1
# pval <- indepTest(x, y, S, suffStat)
# if (is.na(pval))
# pval <- as.numeric(NAdelete) ## = if(NAdelete) 1 else 0
# if(pMax[x, y] < pval)
# pMax[x, y] <- pval
# if (pval >= alpha) {
# amat[x, y] <- amat[y, x] <- 0
# sepset[[x]][[y]] <- sepset[[y]][[x]] <- S
# done <- TRUE
# if (verbose)
# cat("x=", x, " y=", y, " S=", S, ": pval =", pval, "\n")
# break
# }
# } ## for(k ..)
# } ## else: { ord > |adj.x| }
# } ## else
#
# } ## while(!done ..)
# }
#
# } ## for(y ..)
#
# } ## if(any( . ))
#
# } ## for(x ..)
# G[amat == 0] <- FALSE
# G[amat == 1] <- TRUE
# G[amat == 2] <- TRUE
#
# } ## if(any(G))
#
# list(G = G, sepset = sepset, pMax = pMax, allPdsep = allPdsep.tmp,
# max.ord = ord, n.edgetests = n.edgetests[1:(ord + 1)])
# } ## {pdsep}
# udag2pag <- function(pag, sepset, rules = rep(TRUE,10), unfVect = NULL, verbose = FALSE, orientCollider = TRUE)
# {
# ## Purpose: Transform the Skeleton of a pcAlgo-object to a PAG using
# ## the rules of Zhang. The output is an adjacency matrix.
# ## ----------------------------------------------------------------------
# ## Arguments:
# ## - pag: adjacency matrix of size pxp
# ## - sepset: list of all separation sets
# ## - rules: array of length 10 wich contains TRUE or FALSE corrsponding
# ## to each rule. TRUE means the rule will be applied.
# ## If rules==FALSE only R0 (minimal pattern) will be used
# ## - unfVect: Vector with ambiguous triples (coded as number using triple2numb)
# ## - verbose: 0 - no output, 1 - detailed output
# ## ----------------------------------------------------------------------
# ## Author: Diego Colombo, Date: 6 Mar 2009; cleanup: Martin Maechler, 2010
# ## update: Diego Colombo, 2012
#
# ## Notation:
# ## ----------------------------------------------------------------------
# ## 0: no edge
# ## 1: -o
# ## 2: -> (arrowhead)
# ## 3: - (tail)
# ## a=alpha
# ## b=beta
# ## c=gamma
# ## d=theta
#
# stopifnot(is.logical(rules), length(rules) == 10)
# if(!is.numeric(pag)) storage.mode(pag) <- "numeric"
#
# if (any(pag != 0)) {
# p <- as.numeric(dim(pag)[1])
#
# ## orient collider
# if (orientCollider) {
# ind <- which(pag == 1, arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# x <- ind[i, 1]
# y <- ind[i, 2]
# allZ <- setdiff(which(pag[y, ] != 0), x)
# for (z in allZ) {
# if (pag[x, z] == 0 && !((y %in% sepset[[x]][[z]]) ||
# (y %in% sepset[[z]][[x]]))) {
# if (length(unfVect) == 0) {
# if (verbose) {
# cat("\n", x, "*->", y, "<-*", z, "\n")
# cat("Sxz=", sepset[[z]][[x]], "and",
# "Szx=", sepset[[x]][[z]], "\n")
# }
# pag[x, y] <- pag[z, y] <- 2
# }
# else {
# if (!any(unfVect == triple2numb(p, x, y, z), na.rm = TRUE) &&
# !any(unfVect == triple2numb(p, z, y, x), na.rm = TRUE)) {
# if (verbose) {
# cat("\n", x, "*->", y, "<-*", z, "\n")
# cat("Sxz=", sepset[[z]][[x]], "and",
# "Szx=", sepset[[x]][[z]], "\n")
# }
# pag[x, y] <- pag[z, y] <- 2
# }
# }
# }
# }
# }
# } ## end: Orient collider
#
# old_pag1 <- matrix(0, p, p)
# while (any(old_pag1 != pag)) {
# old_pag1 <- pag
# ##-- R1 ------------------------------------------------------------------
# if (rules[1]) {
# ind <- which((pag == 2 & t(pag) != 0), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# a <- ind[i, 1]
# b <- ind[i, 2]
# indC <- which((pag[b, ] != 0 & pag[, b] == 1) & (pag[a, ] == 0 & pag[, a] == 0))
# indC <- setdiff(indC, a)
# if (length(indC) > 0) {
# if (length(unfVect) == 0) {
# pag[b, indC] <- 2
# pag[indC, b] <- 3
# if (verbose)
# cat("\nRule 1",
# "\nOrient:", a, "*->", b, "o-*", indC,
# "as:", b, "->", indC, "\n")
# }
# else {
# for (c in indC) {
# if (!any(unfVect == triple2numb(p, a, b, c), na.rm = TRUE) &&
# !any(unfVect == triple2numb(p, c, b, a), na.rm = TRUE)) {
# pag[b, c] <- 2
# pag[c, b] <- 3
# if (verbose)
# cat("\nRule 1",
# "\nConservatively orient:", a, "*->", b, "o-*",
# c, "as:", b, "->", c, "\n")
# }
# } ## for( c )
# }
# }
# } ## for( i )
# }
# ##-- R2 ------------------------------------------------------------------
# if (rules[2]) {
# ind <- which((pag == 1 & t(pag) != 0), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# a <- ind[i, 1]
# c <- ind[i, 2]
# indB <- which((pag[a, ] == 2 & pag[, a] == 3 & pag[c, ] != 0 & pag[, c] == 2) | (pag[a, ] == 2 & pag[, a] != 0 & pag[c, ] == 3 & pag[, c] == 2))
# if (length(indB) > 0) {
# pag[a, c] <- 2
# if (verbose) {
# cat("\nRule 2","\n")
# cat("Orient:", a, "->", indB, "*->", c, "or", a, "*->", indB, "->", c, "with", a, "*-o", c, "as:", a, "*->", c, "\n")
# }
# }
# }
# }
# ##-- R3 ------------------------------------------------------------------
# if (rules[3]) {
# ind <- which((pag != 0 & t(pag) == 1), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# b <- ind[i, 1]
# d <- ind[i, 2]
# indAC <- which((pag[b, ] != 0 & pag[, b] == 2) & (pag[, d] == 1 & pag[d, ] != 0))
# if (length(indAC) >= 2) {
# if (length(unfVect) == 0) {
# counter <- 0
# while ((counter < (length(indAC) - 1)) && (pag[d, b] != 2)) {
# counter <- counter + 1
# ii <- counter
# while (ii < length(indAC) && pag[d, b] != 2) {
# ii <- ii + 1
# if (pag[indAC[counter], indAC[ii]] == 0 && pag[indAC[ii], indAC[counter]] == 0) {
# if (verbose) {
# cat("\nRule 3","\n")
# cat("Orient:", d, "*->", b, "\n")
# }
# pag[d, b] <- 2
# }
# }
# }
# }
# else {
# comb.indAC <- combn(indAC, 2)
# for (j in 1:dim(comb.indAC)[2]) {
# a <- comb.indAC[1, j]
# c <- comb.indAC[2, j]
# if (pag[a, c] == 0 && pag[c, a] == 0 && c != a) {
# if (!any(unfVect == triple2numb(p, a, d, c), na.rm = TRUE) &&
# !any(unfVect == triple2numb(p, c, d, a), na.rm = TRUE)) {
# pag[d, b] <- 2
# if (verbose) {
# cat("\nRule 3","\n")
# cat("Conservatively orient:", d, "*->", b, "\n")
# }
# }
# }
# }
# }
# }
# }
# }
# ##-- R4 ------------------------------------------------------------------
# if (rules[4]) {
# ind <- which((pag != 0 & t(pag) == 1), arr.ind = TRUE)## b o-* c
# while (length(ind) > 0) {
# b <- ind[1, 1]
# c <- ind[1, 2]
# ind <- ind[-1,, drop = FALSE]
# ## find all a s.t. a -> c and a <-* b
# indA <- which((pag[b, ] == 2 & pag[, b] != 0) &
# (pag[c, ] == 3 & pag[, c] == 2))
# ## chose one a s.t. the initial triangle structure exists and the edge hasn't been oriented yet
# while (length(indA) > 0 && pag[c,b] == 1) {
# a <- indA[1]
# indA <- indA[-1]
# ## path is the initial triangle
# ## abc <- c(a, b, c)
# ## Done is TRUE if either we found a minimal path or no path exists for this triangle
# Done <- FALSE
# ### MM: FIXME?? Isn't Done set to TRUE in *any* case inside the following
# ### while(.), the very first time already ??????????
# while (!Done && pag[a,b] != 0 && pag[a,c] != 0 && pag[b,c] != 0) {
# ## find a minimal discriminating path for a,b,c
# md.path <- minDiscrPath(pag, a,b,c, verbose = verbose)
# ## if the path doesn't exists, we are done with this triangle
# if ((N.md <- length(md.path)) == 1) {
# Done <- TRUE
# }
# else {
# ## a path exists
# ## if b is in sepset
# if ((b %in% sepset[[md.path[1]]][[md.path[N.md]]]) ||
# (b %in% sepset[[md.path[N.md]]][[md.path[1]]])) {
# if (verbose)
# cat("\nRule 4",
# "\nThere is a discriminating path between",
# md.path[1], "and", c, "for", b, ",and", b, "is in Sepset of",
# c, "and", md.path[1], ". Orient:", b, "->", c, "\n")
# pag[b, c] <- 2
# pag[c, b] <- 3
# }
# else {
# ## if b is not in sepset
# if (verbose)
# cat("\nRule 4",
# "\nThere is a discriminating path between",
# md.path[1], "and", c, "for", b, ",and", b, "is not in Sepset of",
# c, "and", md.path[1], ". Orient:", a, "<->", b, "<->",
# c, "\n")
# pag[a, b] <- pag[b, c] <- pag[c, b] <- 2
# }
# Done <- TRUE
# }
# }
# }
# }
# }
# ##-- R5 ------------------------------------------------------------------
# if (rules[5]) {
# ind <- which((pag == 1 & t(pag) == 1), arr.ind = TRUE) ## a o-o b
# while (length(ind) > 0) {
# a <- ind[1, 1]
# b <- ind[1, 2]
# ind <- ind[-1,, drop = FALSE]
# ## find all c s.t. a o-o c and c is not connected to b
# indC <- which((pag[a, ] == 1 & pag[, a] == 1) & (pag[b, ] == 0 & pag[, b] == 0))
# ## delete b since it is surely in indC
# indC <- setdiff(indC, b)
# ## find all d s.t. b o-o d and d is not connected to a
# indD <- which((pag[b, ] == 1 & pag[, b] == 1) & (pag[a, ] == 0 & pag[, a] == 0))
# ## delete a since it is surely in indD
# indD <- setdiff(indD, a)
# if (length(indC) > 0 && length(indD) > 0) {
# counterC <- 0
# while ((counterC < length(indC)) && pag[a, b] == 1) {
# counterC <- counterC + 1
# c <- indC[counterC]
# counterD <- 0
# while ((counterD < length(indD)) && pag[a, b] == 1) {
# counterD <- counterD + 1
# d <- indD[counterD]
# ## this is the easiest one
# if (pag[c, d] == 1 && pag[d, c] == 1) {
# if (length(unfVect) == 0) { ## normal version
# pag[a, b] <- pag[b, a] <- 3
# pag[a, c] <- pag[c, a] <- 3
# pag[c, d] <- pag[d, c] <- 3
# pag[d, b] <- pag[b, d] <- 3
# if (verbose)
# cat("\nRule 5",
# "\nThere exists an uncovered circle path between", a, "and", b,
# ". Orient:", a, "-", b, "and", a, "-", c, "-", d, "-", b, "\n")
# }
# else { ## conservative: check that every triple on the circle is faithful
# path2check <- c(a,c,d,b)
# if (faith.check(path2check, unfVect, p)) {
# pag[a, b] <- pag[b, a] <- 3
# pag[a, c] <- pag[c, a] <- 3
# pag[c, d] <- pag[d, c] <- 3
# pag[d, b] <- pag[b, d] <- 3
# if (verbose)
# cat("\nRule 5",
# "\nThere exists a faithful uncovered circle path between",
# a, "and", b, ". Conservatively orient:",
# a, "-", b, "and", a, "-", c, "-", d, "-", b, "\n")
# }
# }
# }
# ## search with a breitensuche a minimal uncovered circle path
# else {
# ## Find a minimal uncovered circle path for these a,b,c, and d.
# ## This path has already been checked to be uncovered and
# ## to be faithful for the conservative case
# ucp <- minUncovCircPath(p, pag = pag, path = c(a,c,d,b),
# unfVect = unfVect, verbose = verbose)
# ## there is a path ---> orient
# if (length(ucp) > 1) {
# ## orient every edge on the path as --
# n <- length(ucp)
# pag[ucp[1], ucp[n]] <- pag[ucp[n], ucp[1]] <- 3 ## a--b
# for (j in 1:(length(ucp)-1)) ## each edge on the path --
# pag[ucp[j], ucp[j + 1]] <- pag[ucp[j + 1], ucp[j]] <- 3
# }
# }
# }
# }
# }
# }
# }
# ##-- R6 ------------------------------------------------------------------
# if (rules[6]) {
# ind <- which((pag != 0 & t(pag) == 1), arr.ind = TRUE)## b o-* c
# for (i in seq_len(nrow(ind))) {
# b <- ind[i, 1]
# c <- ind[i, 2]
# if (any(pag[b, ] == 3 & pag[, b] == 3)) {
# pag[c, b] <- 3
# if (verbose)
# cat("\nRule 6",
# "\nOrient:", b, "o-*", c, "as", b, "-*", c, "\n")
# }
# }
# }
# ##-- R7 ------------------------------------------------------------------
# if (rules[7]) {
# ind <- which((pag != 0 & t(pag) == 1), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# b <- ind[i, 1]
# c <- ind[i, 2]
# indA <- which((pag[b, ] == 3 & pag[, b] == 1) & (pag[c, ] == 0 & pag[, c] == 0))
# indA <- setdiff(indA, c)
# if (length(indA) > 0) {
# if (length(unfVect) == 0) {
# pag[c, b] <- 3
# if (verbose)
# cat("\nRule 7",
# "\nOrient:", indA, "-o", b, "o-*",
# c, "as", b, "-*", c, "\n")
# }
# else for (a in indA)
# if (!any(unfVect == triple2numb(p, a, b, c), na.rm = TRUE) &&
# !any(unfVect == triple2numb(p, c, b, a), na.rm = TRUE)) {
# pag[c, b] <- 3
# if (verbose)
# cat("\nRule 7",
# "\nConservatively orient:", a, "-o", b, "o-*",
# c, "as", b, "-*", c, "\n")
# }
# }
# }
# }
# ##-- R8 ------------------------------------------------------------------
# if (rules[8]) {
# ind <- which((pag == 2 & t(pag) == 1), arr.ind = TRUE)
# for (i in seq_len(nrow(ind))) {
# a <- ind[i, 1]
# c <- ind[i, 2]
# indB <- which(pag[, a] == 3 & (pag[a, ] == 2 | pag[a, ] == 1) &
# pag[c, ] == 3 & pag[, c] == 2)
# if (length(indB) > 0) {
# pag[c, a] <- 3
# if (verbose)
# cat("\nRule 8",
# "\nOrient:", a, "->", indB, "->", c,
# "or", a, "-o", indB, "->", c, "with", a,
# "o->", c, "as", a, "->", c, "\n")
# }
# }
# }
# ##-- R9 ------------------------------------------------------------------
# if (rules[9]) {
# ind <- which((pag == 2 & t(pag) == 1), arr.ind = TRUE) ## a o-> c
# while (length(ind) > 0) {
# a <- ind[1, 1]
# c <- ind[1, 2]
# ind <- ind[-1,, drop = FALSE]
# ## find all b s.t. a (o-)--(o>) b and b and c are not connected
# indB <- which((pag[a, ] == 2 | pag[a, ] == 1) &
# (pag[, a] == 1 | pag[, a] == 3) &
# (pag[c, ] == 0 & pag[, c] == 0))
# ## delete c from indB since it is surely inside
# indB <- setdiff(indB, c)
# ## chose one b s.t. the initial structure exists and the edge hasn't been oriented yet
# while ((length(indB) > 0) && (pag[c,a] == 1)) {
# b <- indB[1]
# indB <- indB[-1]
# ## find a minimal uncovered pd path from initial (a,b,c) :
# upd <- minUncovPdPath(p, pag, a,b,c,
# unfVect = unfVect, verbose = verbose)
# ## there is a path ---> orient it
# if (length(upd) > 1) {
# pag[c, a] <- 3
# if (verbose)
# cat("\nRule 9",
# "\nThere exists an uncovered potentially directed path between", a, "and", c,
# ". Orient:", a, " ->",c, "\n")
# }
# }
# }
# }
# ##-- R10 ------------------------------------------------------------------
# if (rules[10]) {
# ind <- which((pag == 2 & t(pag) == 1), arr.ind = TRUE) ## a o-> c
# while (length(ind) > 0) {
# a <- ind[1, 1]
# c <- ind[1, 2]
# ind <- ind[-1,, drop = FALSE]
# ## find all b s.t. b --> c
# indB <- which((pag[c, ] == 3 & pag[, c] == 2))
# if (length(indB) >= 2) {
# counterB <- 0
# while (counterB < length(indB) && (pag[c, a] == 1)) {
# counterB <- counterB + 1
# b <- indB[counterB]
# indD <- setdiff(indB, b)
# counterD <- 0
# while ((counterD < length(indD)) && (pag[c, a] == 1)) {
# counterD <- counterD + 1
# d <- indD[counterD]
# ## this is the easiest one
# if ((pag[a, b] == 1 || pag[a, b] == 2) &&
# (pag[b, a] == 1 || pag[b, a] == 3) &&
# (pag[a, d] == 1 || pag[a, d] == 2) &&
# (pag[d, a] == 1 || pag[d, a] == 3) && pag[d, b] == 0 && pag[b, d] == 0) {
# if (length(unfVect) == 0) { ## normal version
# pag[c, a] <- 3
# if (verbose)
# cat("\nRule 10 [easy]",
# "\nOrient:", a, "->", c, "\n")
# }
# else ## conservative version: check faithfulness of b-a-d
# if (!any(unfVect == triple2numb(p,b,a,d), na.rm = TRUE) &&
# !any(unfVect == triple2numb(p,d,a,b), na.rm = TRUE)) {
# pag[c, a] <- 3
# if (verbose)
# cat("\nRule 10 [easy]",
# "\nConservatively orient:", a, "->", c, "\n")
# }
# }
# ## search with a breitensuche two minimal uncovered circle paths
# else {
# ## find all x s.t. a (o-)--(o>) x
# indX <- which((pag[a, ] == 1 | pag[a, ] == 2) &
# (pag[, a] == 1 | pag[, a] == 3), arr.ind = TRUE)
# indX <- setdiff(indX, c)
# if (length(indX >= 2)) {
# counterX1 <- 0
# while (counterX1 < length(indX) && pag[c, a] == 1) {
# counterX1 <- counterX1 + 1
# first.pos <- indX[counterX1]
# indX2 <- setdiff(indX, first.pos)
# counterX2 <- 0
# while (counterX2 < length(indX2) && pag[c, a] == 1) {
# counterX2 <- counterX2 + 1
# sec.pos <- indX2[counterX2]
# t1 <- minUncovPdPath(p, pag, a, first.pos, b,
# unfVect = unfVect, verbose = verbose)
# if (length(t1) > 1) { # otherwise, can skip next minUnc..()
# t2 <- minUncovPdPath(p, pag, a, sec.pos, d,
# unfVect = unfVect, verbose = verbose)
# if (length(t2) > 1 &&
# first.pos != sec.pos && pag[first.pos, sec.pos] == 0) {
# ## we found 2 uncovered pd paths
# if (length(unfVect) == 0) { ## normal version
# pag[c, a] <- 3
# if (verbose)
# cat("\nRule 10", "\nOrient:", a, "->", c, "\n")
# }
# else if(!any(unfVect == triple2numb(p,first.pos, a, sec.pos), na.rm = TRUE) &&
# !any(unfVect == triple2numb(p,sec.pos, a, first.pos), na.rm = TRUE)) {
# ## conservative version
# pag[c, a] <- 3
# if (verbose)
# cat("\nRule 10",
# "\nConservatively orient:", a, "->", c, "\n")
# }
# }
# }
# } # # while ( counterX2 .. )
# }
# }
# } # else
# } # while ( counterD .. )
# } # while ( counterB .. )
# } # if (length(indB) .)
# }
# } ## if (rules[10] ..)
# }
# }
# pag
# } ## udag2pag()
################################################################################
## RFCI
################################################################################
rfci <- function(suffStat, indepTest, alpha, labels, p,
skel.method = c("stable", "original", "stable.fast"),
fixedGaps = NULL, fixedEdges = NULL,
NAdelete = TRUE, m.max = Inf, rules = rep(TRUE, 10),
conservative = FALSE, maj.rule = FALSE,
numCores = 1, verbose = FALSE)
{
## Purpose: Perform RFCI-Algorithm, i.e., estimate PAG
## ----------------------------------------------------------------------
## Arguments:
## - suffStat, indepTest: info for the tests
## - p: number of nodes in the graph
## - alpha: Significance level of individual partial correlation tests
## - verbose: 0 - no output, 1 - detailed output
## - fixedGaps: the adjacency matrix of the graph from which the algorithm
## should start (logical); gaps fixed here are not changed
## - fixedEdges: Edges marked here are not changed (logical)
## - NAdelete: delete edge if pval=NA (for discrete data)
## - m.max: maximal size of conditioning set
## - rules: array of length 10 wich contains TRUE or FALSE corrsponding
## to each rule. TRUE means the rule will be applied.
## If rules==FALSE only R0 (minimal pattern) will be used
## - conservative: TRUE or FALSE defining if the v-structures after
## the skeleton have to be oriented conservatively or nor
## - maj.rule: TRUE or FALSE variable containing if the majority rule is
## used instead of the normal conservative
## - labels: names of the variables or nodes
## - numCores: handed to skeleton(), used for parallelization
## ----------------------------------------------------------------------
## Author: Diego Colombo, 2011; modifications: Martin Maechler
cl <- match.call()
if(!missing(p)) stopifnot(is.numeric(p), length(p <- as.integer(p)) == 1, p >= 2)
if(missing(labels)) {
if(missing(p)) stop("need to specify 'labels' or 'p'")
labels <- as.character(seq_len(p))
} else { ## use labels ==> p from it
stopifnot(is.character(labels))
if(missing(p)) {
p <- length(labels)
} else if(p != length(labels))
stop("'p' is not needed when 'labels' is specified, and must match length(labels)")
else
message("No need to specify 'p', when 'labels' is given")
}
if (conservative && maj.rule)
stop("Can only choose one of conservative or majority rule RFCI")
if (verbose) cat("Compute Skeleton\n================\n")
skel <- skeleton(suffStat, indepTest, alpha, labels = labels, method = skel.method,
fixedGaps = fixedGaps, fixedEdges = fixedEdges,
NAdelete=NAdelete, m.max=m.max, numCores=numCores, verbose=verbose)
sk.A <- as(skel@graph, "matrix")
sepset <- skel@sepset
## the list of all ordered unshielded triples (the graph g does not change it is just a search!)
u.t <- find.unsh.triple(sk.A, check = FALSE)
## check and orient v-structures recursively
r.v. <- rfci.vStruc(suffStat, indepTest, alpha, sepset, sk.A,
unshTripl = u.t$unshTripl, unshVect = u.t$unshVect,
conservative = (conservative || maj.rule),
version.unf = c(1,1), maj.rule = maj.rule, verbose = verbose)
A <- r.v.$amat
sepset <- r.v.$sepset
## orient as many edge marks as possible
if (verbose)
cat("\nDirect egdes:\n=============\nUsing rules:", which(rules), "\n")
res <- udag2apag(A, suffStat, indepTest, alpha, sepset,
rules = rules, unfVect = r.v.$unfTripl, verbose = verbose)
Amat <- res$graph
colnames(Amat) <- rownames(Amat) <- labels
new("fciAlgo", amat = Amat, call = cl, n = integer(0),
max.ord = as.integer(skel@max.ord), max.ordPDSEP = 0L,
n.edgetests = skel@n.edgetests, n.edgetestsPDSEP = 0,
sepset = res$sepset, pMax = skel@pMax, allPdsep = vector("list", p))
} ## {rfci}
find.unsh.triple <- function(g, check = TRUE)
{
## Purpose: find the ordered (<x,y,z> with x<z) list of all the unshielded
## triples in the graph
## ----------------------------------------------------------------------
## Arguments: g: adjacency matrix
## ----------------------------------------------------------------------
## Values: - unshTripl: matrix with 3 rows containing in each column
## an unshielded triple
## - unshVect: containing the unique number for each column
## in unshTripl
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 21 Oct 2010; clean- and speed-up: Martin Maechler
if(check) stopifnot( all(g == t(g)) )
m <- 0L
unshTripl <- matrix(integer(), 3, m)
if (any(g != 0)) { # if( at least one edge) -- find all unshielded triples in g
p <- nrow(g)
indS <- which(g == 1, arr.ind = TRUE) ## x-y
for (i in seq_len(nrow(indS))) {
xy <- indS[i,]
x <- xy[1]
y <- xy[2]
allZ <- setdiff(which(g[y, ] == 1), x) ## x-y-z
for (z in allZ) {
if (g[x,z] == 0 && g[z,x] == 0) {
## save the matrix
unshTripl <- cbind(unshTripl, c(xy, z))
}
}
}
## delete duplicates in the matrix
if ((m <- ncol(unshTripl)) > 0) {
deleteDupl <- logical(m)# all FALSE
for (i in seq_len(m)) ## FIXME -- make faster!
if (unshTripl[1,i] > unshTripl[3,i])
deleteDupl[i] <- TRUE
if(any(deleteDupl))
m <- ncol(unshTripl <- unshTripl[,!deleteDupl, drop = FALSE])
}
}
## define the vector with the unique number for each triple
unshVect <- vapply(seq_len(m), function(k)
triple2numb(p, unshTripl[1,k], unshTripl[2,k], unshTripl[3,k]),
numeric(1))
list(unshTripl = unshTripl, unshVect = unshVect)
} ## {find.unsh.triple}
##' called only from rfci() and checkEdges()
rfci.vStruc <- function(suffStat, indepTest, alpha, sepset, g.amat,
unshTripl, unshVect, conservative = FALSE,
version.unf = c(2,1), maj.rule = FALSE, verbose = FALSE)
{
## Purpose: check the unshielded triples in unshTripl as v-structures
## recursively check if new unshielded triples have been found
## then save and orient the final ones in finalList and finalVect
## ----------------------------------------------------------------------
## Arguments: - suffStat, indepTest, p,alpha: arguments from the algorithm
## - sepset, g.amat: output of the function skeleton
## - unshTripl, unshVect: list/numbers of the unshielded triples
## in graph
## - conservative: TRUE or FALSE
## - version.unf=c(2,1): conservative version
## - maj.rule: TRUE or FALSE variable containing if the majority
## rule is used instead of the normal conservative
## ----------------------------------------------------------------------
## Values: - updated sepset, graph (g.amat) and list of unfaithful v-structures
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 21 Oct 2010, 14:15
## check every column (unshielded triple) of unshTripl
## NOTE: what's done is done!!!! I don't look back in the matrix
stopifnot(is.matrix(unshTripl), nrow(unshTripl) == 3)
nT <- ncol(unshTripl)
A <- g.amat
## list of all unfaithful v-structures
unfTripl <- NULL
if (nT) {
if (verbose)
cat("\nCheck unshielded triples for conditional dependence
================================================\n")
## check all the columns in unshTripl as v-structure or not
checktmp <- dep.triple(suffStat, indepTest, alpha, sepset = sepset, apag = g.amat,
unshTripl = unshTripl, unshVect = unshVect,
## per default every triple is defined as a v-structure :
trueVstruct = rep(TRUE, nT), verbose = verbose)
## save the updated objects
A <- checktmp$apag
sepset <- checktmp$sepset
## note that no column is deleted from the matrix, we can add new triples instead
unshTripl <- checktmp$triple
unshVect <- checktmp$vect
trueVstruct <- checktmp$trueVstruct
if (verbose) cat(
if (conservative)
"\nOrient the v-structures conservatively
=====================================\n"
else "\nOrient the v-structures\n=======================\n")
## if there is at least one triple with the desired properties
if (any(trueVstruct)) {
for (i in 1:dim(unshTripl)[2]) {
if (trueVstruct[i]) {
x <- unshTripl[1, i]
y <- unshTripl[2, i]
z <- unshTripl[3, i]
if (!conservative) {
if (A[x, z] == 0 && A[x,y] != 0 && A[z,y] != 0 &&
!((y %in% sepset[[x]][[z]]) || (y %in% sepset[[z]][[x]]))) {
## this is to avoid the problem of:
## assume that <a,b,c> was saved in finalList because a "true" unshielded triple
## but after in the matrix appears <b,c,d> and the edge b-c is deleted
## of course the triple <a,b,c> stays in the finalList but we cannot orient the edge
## b-c because it doesn'e exist anymore
if (verbose)
cat("\n", x, "*->", y, "<-*", z,
"\nSxz=", sepset[[z]][[x]], "and",
"Szx=", sepset[[x]][[z]], "\n")
A[c(x,z), y] <- 2
}
} else { ## conservative version
## check if x-y-z is faithful
## find neighbours of x and z
nbrsX <- which(A[,x] != 0) ## G symm; x no nbr of z
nbrsZ <- which(A[,z] != 0)
if (verbose)
cat("\nTriple:",x,y,z,"and sepset by skelet:",
unique(sepset[[x]][[z]],sepset[[z]][[x]]),"\n")
r.abc <- checkTriple(x, y, z, nbrsX, nbrsZ,
sepset[[x]][[z]], sepset[[z]][[x]],
suffStat = suffStat, indepTest = indepTest, alpha = alpha,
version.unf = version.unf, maj.rule = maj.rule,
verbose = verbose)
p <- nrow(A)
## 1: in NO set; 2: in ALL sets; 3: in SOME but not all
if (r.abc$decision == 3 || ## <- take action if case "3", or
## can happen the case in Tetrad, so we must save the triple as unfaithful
## a and c independent given S but not given subsets of the adj(x) or adj(z)
(version.unf[1] == 2 && r.abc$version == 2)) {
## record unfaithful triple
unfTripl <- c(unfTripl, triple2numb(p, x, y, z))
if (verbose >= 2) cat("new unfTriple:", x, y, z, "\n")
}
sepset[[x]][[z]] <- r.abc$SepsetA
sepset[[z]][[x]] <- r.abc$SepsetC
if (A[x,z] == 0 && A[x,y] != 0 && A[z,y] != 0 &&
!((y %in% sepset[[x]][[z]]) ||
(y %in% sepset[[z]][[x]])) &&
!any(unfTripl == triple2numb(p, x, y, z), na.rm = TRUE) &&
!any(unfTripl == triple2numb(p, z, y, x), na.rm = TRUE)) {
if (verbose)
cat("\nOrient:", x, "*->", y, "<-*", z,
"\nSxz=", sepset[[z]][[x]], "and",
"Szx=", sepset[[x]][[z]], "\n")
A[c(x,z), y] <- 2
}
} ## else : conservative
}
} ## for (i ...)
}
}
list(sepset = sepset, amat = A, unfTripl = unfTripl)
} ## {rfci.vStruc}
## only called from rfci.vStruc() - with trueVstruct a vector of TRUE
dep.triple <- function(suffStat, indepTest, alpha, sepset, apag,
unshTripl, unshVect, trueVstruct, verbose = FALSE)
{
## Purpose: test the two edges of any unshielded triple in unshTripl (column)
## for dependence given sepset. If independent find the minimal
## sepset, delete the edge, define the triple as FALSE in
## trueVstruct and search in the graph for new triple or destroyed
## ones. Otherwise do nothing.
## ----------------------------------------------------------------------
## Arguments: - suffStat, indepTest, alpha, sepset, apag: skeleton parameters / result
## - unshTripl: matrix containing the unshielded triples (columns)
## - unshVect: triple2numb of unshTripl
## - trueVstruct: vector containing T/F for the v-structures
## ----------------------------------------------------------------------
## Values: - updated sepset, apag, unshTripl, unshVect, trueVstruct
## Author: Diego Colombo, Date: 16 Aug 2010, 15:07
p <- nrow(apag) ## == length(sepset)
for(k in seq_len(ncol(unshTripl))) {
## Note that trueVstruct[.] is changed *inside* !
if (trueVstruct[k]) { ## triple under inspection x-y-z
x <- unshTripl[1, k]
y <- unshTripl[2, k]
z <- unshTripl[3, k]
SepSet <- setdiff(unique(c(sepset[[x]][[z]],
sepset[[z]][[x]])), y)
nSep <- length(SepSet)
if (verbose)
cat("\nTriple:", x, y, z, "and sepSet (of size", nSep,") ", SepSet,"\n")
if (nSep != 0) {
x. <- min(x,y)
y. <- max(x,y)
y_ <- min(y,z)
z_ <- max(y,z)
## Check x-y ---------------------------------------------------------------
del1 <- FALSE
## check first x and y given the whole sepset(x,z)
if (indepTest(x, y, SepSet, suffStat) >= alpha) {
## afterwards we have to define this triple as FALSE in trueVstruct
del1 <- TRUE
## x and y are independent, then find the minimal sepset
done <- FALSE
ord <- 0L
while (!done && ord < nSep) {
ord <- ord + 1L
## all combinations of SepSet of size ord
S.j <- if (ord == 1 && nSep == 1) matrix(SepSet,1,1) else combn(SepSet, ord)
for (i in seq_len(ncol(S.j))) {
pval <- indepTest(x, y, S.j[,i], suffStat)
if (verbose) cat("x=", x, " y=", y, "S=", S.j[,i], ": pval =", pval, "\n")
if (pval >= alpha) {
## delete edge and save set in sepset
apag[x, y] <- apag[y, x] <- 0
sepset[[x]][[y]] <- sepset[[y]][[x]] <- S.j[,i]
done <- TRUE
break
}
}
}
## case 1: before we had a triangle and now it is an unshielded triple x-m-y
indM <- which((apag[x, ] == 1 & apag[, x] == 1) & (apag[y, ] == 1 & apag[, y] == 1))
indM <- setdiff(indM, c(x,y,z)) ## just to be sure
for (m in indM) {
## in the matrix the first column is always smaller than the third
unshTripl <- cbind(unshTripl, c(x., m, y.))
unshVect <- c(unshVect, triple2numb(p, x., m, y.))
## per default this new triple is set as TRUE in trueVstruct
trueVstruct <- c(trueVstruct, TRUE)
}
## case 2: an existent unshielded triple has been destroyed
## case 2.a): we had q-x-y or y-x-q in the matrix but not anymore
indQ <- which((apag[x, ] == 1 & apag[, x] == 1) & (apag[y, ] == 0 & apag[, y] == 0))
indQ <- setdiff(indQ, c(x,y,z)) ## just to be sure
for (q in indQ) {
## define the triple as FALSE in trueVstruct
delTripl <- unshVect == (
if (q < y) triple2numb(p, q, x, y) else triple2numb(p, y, x, q))
## if we haven't checked the triple yet, define it as FALSE
if (any(delTripl))
trueVstruct[which.max(delTripl)] <- FALSE
}
## case 2.b): we had r-y-x or x-y-r in the matrix but not anymore
indR <- which((apag[x, ] == 0 & apag[, x] == 0) & (apag[y, ] == 1 & apag[, y] == 1))
indR <- setdiff(indR, c(x,y,z)) ## just to be sure
## ^^^ (had typo here: 'indQ' !!)
for (r in indR) {
## define the triple as FALSE in trueVstruct
delTripl <- unshVect == (
if (r < x) triple2numb(p, r, y, x) else triple2numb(p, x, y, r))
if (any(delTripl))
trueVstruct[which.max(delTripl)] <- FALSE
}
} ## if (pv1 .. indepTest(..) )
## Check z-y ---------------------------------------------------------------
del2 <- FALSE
## check first z and y given the whole sepset(x,z)
if (indepTest(z, y, SepSet, suffStat) >= alpha) {
del2 <- TRUE ## will have to set this triple as FALSE in trueVstruct
## z and y are independent, then find the minimal sepset
Done <- FALSE
Ord <- 0L
while (!Done && Ord < nSep) {
Ord <- Ord + 1L
## all combinations of SepSet of size Ord
S.j <- if (Ord == 1 && nSep == 1) matrix(SepSet,1,1) else combn(SepSet, Ord)
for (i in seq_len(ncol(S.j))) {
pval <- indepTest(z, y, S.j[,i], suffStat)
if (verbose) cat("x=", z, " y=", y, " S=", S.j[,i], ": pval =", pval, "\n")
if (pval >= alpha) {
## delete edge and save set in sepset
apag[z, y] <- apag[y, z] <- 0
sepset[[z]][[y]] <- sepset[[y]][[z]] <- S.j[,i]
Done <- TRUE
break
}
}
} ## while( . )
## case 1: before we had a triangle and now it is an unshielded triple z-m-y
indM <- which((apag[z, ] == 1 & apag[, z] == 1) & (apag[y, ] == 1 & apag[, y] == 1))
indM <- setdiff(indM,c(x,y,z)) ## just to be sure
for (m in indM) {
## in the matrix the first column is always smaller than the third
unshTripl <- cbind(unshTripl, c(y_, m, z_))
unshVect <- c(unshVect, triple2numb(p, y_, m, z_))
## per default the triple is defined as TRUE
trueVstruct <- c(trueVstruct,TRUE)
}
## case 2: an existent unshielded triple has been destroyed
## case 2.a): we had q-z-y or y-z-q in the matrix but not anymore
indQ <- which((apag[z, ] == 1 & apag[, z] == 1) & (apag[y, ] == 0 & apag[, y] == 0))
indQ <- setdiff(indQ, c(x,y,z)) ## just to be sure
for (q in indQ) {
## define the triple as FALSE in trueVstruct
delTripl <- unshVect == (if (q < y) triple2numb(p, q, z, y) else triple2numb(p, y, z, q))
## if we haven't checked the triple yet, save it as FALSE
if (any(delTripl))
trueVstruct[which.max(delTripl)] <- FALSE
}
## case 2.b): we had r-y-z or z-y-r in the matrix but not anymore
indR <- which((apag[z, ] == 0 & apag[, z] == 0) & (apag[y, ] == 1 & apag[, y] == 1))
indR <- setdiff(indR, c(x,y,z)) ## just to be sure
## ^^^ (had typo here: 'indQ' !!)
for (r in indR) {
## define the triple as FALSE in trueVstruct
delTripl <- unshVect == (
if (r < z) triple2numb(p, r, y, z) else triple2numb(p, z, y, r))
if (any(delTripl))
trueVstruct[which.max(delTripl)] <- FALSE
}
}
## if at least one edge has been deleted this is not a future v-structure
if (any(del1, del2)) trueVstruct[k] <- FALSE
} ## if (nSep != 0)
##
## ELSE: the sepset is empty
## so surely <x,y,z> is an unshielded triple because they cannot be indep given the empty set
## nothing changed in sepset and in graph
## else{
## sepset <- sepset
## apag <- apag
## }
## recursion on the next column of unshTripl
## rec.res <- dep.triple(suffStat, indepTest, p, alpha, sepset, apag, unshTripl, unshVect, trueVstruct, k, verbose=verbose)
## save the modified objects
## unshTripl <- rec.res$triple
## unshVect <- rec.res$vect
## sepset <- rec.res$sepset
## apag <- rec.res$graph
## trueVstruct <- rec.res$trueVstruct
}
}## for ( k )
list(triple = unshTripl, vect = unshVect, sepset = sepset,
apag = apag, trueVstruct = trueVstruct)
} ## {dep.triple}
##' Check the dependence of the edges for R4
##' only called from udag2apag()
checkEdges <- function(suffStat, indepTest, alpha, apag, sepset, path,
unfVect = NULL, verbose = FALSE)
{
## Purpose: check if every edge on the path should exist in R4
## ----------------------------------------------------------------------
## Values: - updated sepset and apag
## - deleted==FALSE no edge has been deleted on the path
## ==TRUE the discriminating path doesn't exist anymore
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 17 Aug 2010, 16:21
stopifnot((n.path <- length(path)) >= 2)
## did we delete an edge?
found <- FALSE
## conservative v-structures or not?
conservative <- (length(unfVect) > 0)
## set that at the beginning there are no new unfaithful v-structures
unfTripl <- NULL
## define the sepset
SepSet.tot <- unique(c(sepset[[path[1]]][[path[n.path]]],
sepset[[path[n.path]]][[path[1]]]))
if (length(SepSet.tot) != 0) {
if (verbose)
cat("\nCheck discriminating path:", path,
"for dependence of any edge given sepset", SepSet.tot,"\n")
p <- nrow(apag)
## check every edge on the path for independence given every possible subset of SepSet
for (i in seq_len(n.path-1)) {
x <- path[i]
y <- path[i+1]
SepSet <- setdiff(SepSet.tot, c(x,y))
x. <- min(x,y)
y. <- max(x,y)
if (verbose >= 2)
cat("Edge: ",x,"*-*",y, "; Sepset=", SepSet, "; |S|=", length(SepSet),"\n")
if (length(SepSet) != 0) {
j <- 0
while (!found && j < length(SepSet)) {
j <- j + 1
## all combinations of SepSet of size j
S.j <- if (j == 1 && length(SepSet) == 1) matrix(SepSet,1,1) else combn(SepSet, j)
ii <- 0
while (!found && ii < ncol(S.j)) {
ii <- ii + 1
pval <- indepTest(x, y, S.j[,ii], suffStat)
if (verbose)
cat("x=", x, " y=", y, " S=", S.j[,ii], ": pval =", pval,"\n")
if (pval >= alpha) {
if (verbose) cat("Independence found: delete edge between",x,"and",y,"\n")
found <- TRUE
## delete edge and save set in sepset
apag[x, y] <- apag[y, x] <- 0
sepset[[x]][[y]] <- sepset[[y]][[x]] <- S.j[,ii]
## before we had a triangle and now it is an unshielded triple x-m-y
indM <- setdiff(which(apag[x, ] != 0 & apag[, x] != 0 &
apag[y, ] != 0 & apag[, y] != 0),
c(x,y))## just to be sure
## create the list with all the new unshielded triples to be tested
if ((nI <- length(indM)) > 0) {
triplM <- matrix(integer(), 3, nI)
newVect <- numeric(nI)
for (jj in seq_len(nI)) {
m <- indM[jj]
triplM[,jj] <- c(x.,m,y.)
newVect[jj] <- triple2numb(p, x.,m,y.)
}
## new unshielded triple to be tested
r.v <- rfci.vStruc(suffStat, indepTest, alpha, sepset, apag,
unshTripl = triplM, unshVect = newVect,
conservative = conservative, verbose = verbose)
## save the modified graph g in apag
apag <- r.v$amat
## save the new sepset
sepset <- r.v$sepset
## save the new unfTripl, since we tested new v-structures and some can be unfaithful
## for the conservative version
unfTripl <- r.v$unfTripl
}
}
} ## while(!found && i < *)
} ## while(!found && j < *)
}
} ## for(i ....)
}
## if SepSet is the empty set do nothing because surely the vertices are dependent
list(deleted = found, apag = apag, sepset = sepset, unfTripl = unfTripl)
}
##' called only from rfci()
udag2apag <- function (apag, suffStat, indepTest, alpha, sepset,
rules = rep(TRUE, 10), unfVect = NULL,
verbose = FALSE)
### FIXME part of this is cut-n-paste from udag2pag()
{
## Purpose: use the 10 orientation rules to orient the skeleton. R4 about
## discriminating paths also checks every edge for dependence
## given all subsets of the separating set.
## Note that the preliminaries v-structures are already oriented
## in apag
## ----------------------------------------------------------------------
## Arguments:
## - apag: adjacency matrix outputs of the function rfci.vStruc
## - suffStat, indepTest, alpha: arguments required for the tests in R4
## - sepset: list of all separation sets
## - rules: array of length 10 wich contains TRUE or FALSE corrsponding
## to each rule. TRUE means the rule will be applied.
## If rules==FALSE only R0 (minimal pattern) will be used
## - unfVect: Vector with ambiguous triples (coded as number using triple2numb)
## - verbose: 0 - no output, 1 - detailed output
## ----------------------------------------------------------------------
## Values: updated apag (oriented) and sepset
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 21 Oct 2010, 15:13
if (any(apag != 0)) {
p <- ncol(apag)
old_apag1 <- matrix(0, nrow = p, ncol = p)
while (any(old_apag1 != apag)) {
old_apag1 <- apag
##-- R1 ------------------------------------------------------------------
if (rules[1]) {
ind <- which((apag == 2 & t(apag) != 0), arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
a <- ind[i, 1]
b <- ind[i, 2]
indC <- which(apag[b, ] != 0 & apag[, b] == 1 &
apag[a, ] == 0 & apag[, a] == 0)
indC <- setdiff(indC, a)
if (length(indC) > 0) {
## normal version
if (length(unfVect) == 0) {
apag[b, indC] <- 2
apag[indC, b] <- 3
if (verbose) {
cat("\nRule 1","\n")
cat("Orient:", a, "*->", b, "o-*", indC,
"as:", b, "->", indC, "\n")
}
}
## conservative
else
for (j in seq_along(indC)) {
c <- indC[j]
## check that a-b-c faithful
if (!any(unfVect == triple2numb(p,a,b,c), na.rm = TRUE) &&
!any(unfVect == triple2numb(p,c,b,a), na.rm = TRUE)) {
apag[b, c] <- 2
apag[c, b] <- 3
if (verbose) {
cat("\nRule 1","\n")
cat("Conservatively orient:", a, "*->", b, "o-*",
c, "as:", b, "->", c, "\n")
}
}
}
}
}
}
##-- R2 ------------------------------------------------------------------
if (rules[2]) {
ind <- which((apag == 1 & t(apag) != 0), arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
a <- ind[i, 1]
c <- ind[i, 2]
indB <- which(((apag[a, ] == 2 & apag[, a] == 3) &
(apag[c, ] != 0 & apag[, c] == 2)) |
((apag[a, ] == 2 & apag[, a] != 0) &
(apag[c, ] == 3 & apag[, c] == 2)))
if (length(indB) > 0) {
apag[a, c] <- 2
if (verbose) {
cat("\nRule 2","\n")
cat("Orient:", a, "->", indB, "*->",
c, "or", a, "*->", indB, "->", c, "with",
a, "*-o", c, "as:", a, "*->", c, "\n")
}
}
}
}
##-- R3 ------------------------------------------------------------------
if (rules[3]) {
ind <- which(apag != 0 & t(apag) == 1, arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
b <- ind[i, 1]
d <- ind[i, 2]
indAC <- which(apag[b, ] != 0 & apag[, b] == 2 &
apag[, d] == 1 & apag[d, ] != 0)
if (length(indAC) >= 2) {
if (length(unfVect) == 0) { ## normal version
counter <- 0
while ((counter < (length(indAC) - 1)) &&
(apag[d, b] != 2)) {
counter <- counter + 1
ii <- counter
while ((ii < length(indAC)) && (apag[d, b] != 2)) {
ii <- ii + 1
if (apag[indAC[counter], indAC[ii]] == 0 &&
apag[indAC[ii], indAC[counter]] == 0) {
apag[d, b] <- 2
if (verbose)
cat("\nRule 3","\nOrient:", d, "*->", b, "\n")
}
}
}
}
else { ## conservative version
comb.indAC <- combn(indAC,2)
for (j in seq_len(ncol(comb.indAC))) {
a <- comb.indAC[1,j]
c <- comb.indAC[2,j]
if (apag[a,c] == 0 && apag[c,a] == 0 && c != a) {
## check faithfulness a-d-c
if (!any(unfVect == triple2numb(p,a,d,c), na.rm = TRUE) &&
!any(unfVect == triple2numb(p,c,d,a), na.rm = TRUE)) {
apag[d, b] <- 2
if (verbose)
cat("\nRule 3","\nConservatively orient:", d, "*->", b, "\n")
}
}
}
}
}
}
}
##-- R4 ------------------------------------------------------------------
if (rules[4]) {
ind <- which((apag != 0 & t(apag) == 1), arr.ind = TRUE)## b o-* c
while (length(ind) > 0) {
b <- ind[1, 1]
c <- ind[1, 2]
ind <- ind[-1,, drop = FALSE]
## find all a s.t. a -> c and a <-* b
indA <- which((apag[b, ] == 2 & apag[, b] != 0) & (apag[c, ] == 3 & apag[, c] == 2))
## chose one a s.t. the initial triangle structure exists and the edge hasn't been oriented yet
while (length(indA) > 0 && apag[c,b] == 1) {
a <- indA[1]
indA <- indA[-1]
## Done is TRUE if either we found a minimal path or no path exists for this triangle
Done <- FALSE
while (!Done && apag[a,b] != 0 && apag[a,c] != 0 && apag[b,c] != 0) {
## find a minimal disciminating path for a,b,c
md.path <- minDiscrPath(apag, a,b,c, verbose = verbose)
N.md <- length(md.path)
## if the path doesn't exists, we are done with this triangle
if (N.md == 1) {
Done <- TRUE
}
else {
## a path exists and needs to be checked and maybe oriented
## first check every single edge for independence
chkE <- checkEdges(suffStat, indepTest, alpha = alpha,
apag = apag, sepset = sepset, path = md.path,
unfVect = unfVect, verbose = verbose)
## save updated graph, sepset,and UnfVect
sepset <- chkE$sepset
apag <- chkE$apag
unfVect <- c(unfVect, chkE$unfTripl)
## no edge deleted ----> orient the edges
if (!chkE$deleted) {
## if b is in sepset
if (b %in% sepset[[md.path[1]]][[md.path[N.md]]] ||
b %in% sepset[[md.path[N.md]]][[md.path[1]]]) {
if (verbose) {
cat("\nRule 4","\n")
cat("There is a discriminating path between",
md.path[1], "and", c, "for", b, ",and", b, "is in Sepset of",
c, "and", md.path[1], ". Orient:", b, "->", c, "\n")
}
apag[b, c] <- 2
apag[c, b] <- 3
}
else {
## if b is not in sepset
if (verbose) {
cat("\nRule 4","\n")
cat("There is a discriminating path between:",
md.path[1], "and", c, "for", b, ",and", b, "is not in Sepset of",
c, "and", md.path[1], ". Orient", a, "<->", b, "<->",
c, "\n")
}
apag[a, b] <- apag[b, c] <- apag[c, b] <- 2
}
Done <- TRUE
}
}
} ## while(!Done && ...)
}
}
}
##-- R5 ------------------------------------------------------------------
if (rules[5]) {
ind <- which((apag == 1 & t(apag) == 1), arr.ind = TRUE) ## a o-o b
while (length(ind) > 0) {
a <- ind[1, 1]
b <- ind[1, 2]
ind <- ind[-1,, drop = FALSE]
## find all c s.t. a o-o c and c is not connected to b
indC <- which((apag[a, ] == 1 & apag[, a] == 1) & (apag[b, ] == 0 & apag[, b] == 0))
## delete b since it is surely in indC
indC <- setdiff(indC, b)
## find all d s.t. b o-o d and d is not connected to a
indD <- which((apag[b, ] == 1 & apag[, b] == 1) & (apag[a, ] == 0 & apag[, a] == 0))
## delete a since it is surely in indD
indD <- setdiff(indD, a)
if (length(indC) > 0 && length(indD) > 0) {
counterC <- 0
while ((counterC < length(indC)) && apag[a, b] == 1) {
counterC <- counterC + 1
c <- indC[counterC]
counterD <- 0
while ((counterD < length(indD)) && apag[a, b] == 1) {
counterD <- counterD + 1
d <- indD[counterD]
## this is the easiest one
if (apag[c, d] == 1 && apag[d, c] == 1) {
## normal version
if (length(unfVect) == 0) {
apag[a, b] <- apag[b, a] <- 3
apag[a, c] <- apag[c, a] <- 3
apag[c, d] <- apag[d, c] <- 3
apag[d, b] <- apag[b, d] <- 3
if (verbose) {
cat("\nRule 5","\n")
cat("There exists an uncovered circle path between",
a, "and", b, ". Orient", a, "-", b, "and", a, "-", c, "-", d, "-", b, "\n")
}
}
## conservative
else {
## check that every triple on the circle is faithful
path2check <- c(a,c,d,b)
if (faith.check(path2check, unfVect, p)) {
apag[a, b] <- apag[b, a] <- 3
apag[a, c] <- apag[c, a] <- 3
apag[c, d] <- apag[d, c] <- 3
apag[d, b] <- apag[b, d] <- 3
if (verbose) {
cat("\nRule 5","\n")
cat("There exists a faithful uncovered circle path between", a, "and", b,
". Conservatively orient:", a, "-", b, "and", a, "-", c, "-", d, "-", b, "\n")
}
}
}
}
## search with a breitensuche a minimal uncovered circle path
else {
## Find a minimal uncovered circle path for these a,b,c, and d.
## This path has already been checked to be uncovered and
## to be faithful for the conservative case
ucp <- minUncovCircPath(p, pag = apag, path = c(a,c,d,b),
unfVect = unfVect, verbose = verbose)
## there is a path ---> orient
if (length(ucp) > 1) {
## orient every edge on the path as --
n <- length(ucp)
apag[ucp[1], ucp[n]] <- apag[ucp[n], ucp[1]] <- 3 ## a--b
for (j in seq_len(length(ucp)-1)) {
apag[ucp[j], ucp[j + 1]] <- apag[ucp[j + 1], ucp[j]] <- 3 ## each edge on the path --
}
}
}
}
}
}
}
}
##-- R6 ------------------------------------------------------------------
if (rules[6]) {
ind <- which((apag != 0 & t(apag) == 1), arr.ind = TRUE)## b o-* c
for (i in seq_len(nrow(ind))) {
b <- ind[i, 1]
c <- ind[i, 2]
indA <- which(apag[b, ] == 3 & apag[, b] == 3)
if (length(indA) > 0) {
apag[c, b] <- 3
if (verbose)
cat("\nRule 6","\nOrient:", b, "o-*", c, "as", b, "-*", c, "\n")
}
}
}
##-- R7 ------------------------------------------------------------------
if (rules[7]) {
ind <- which((apag != 0 & t(apag) == 1), arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
b <- ind[i, 1]
c <- ind[i, 2]
indA <- which((apag[b, ] == 3 & apag[, b] == 1) &
(apag[c, ] == 0 & apag[, c] == 0))
indA <- setdiff(indA, c)
if (length(indA) > 0) {
if (length(unfVect) == 0) { ## normal version
apag[c, b] <- 3
if (verbose) {
cat("\nRule 7","\n")
cat("Orient", indA, "-o", b, "o-*", c, "as", b, "-*", c, "\n")
}
}
else { ## conservative
for (j in seq_along(indA)) {
a <- indA[j]
## check faithfulness of a-b-c
if (!any(unfVect == triple2numb(p,a,b,c), na.rm = TRUE) &&
!any(unfVect == triple2numb(p,c,b,a), na.rm = TRUE)) {
apag[c, b] <- 3
if (verbose) {
cat("\nRule 7","\n")
cat("Conservatively orient:", a, "-o", b, "o-*",
c, "as", b, "-*", c, "\n")
}
}
}
}
}
}
}
##-- R8 ------------------------------------------------------------------
if (rules[8]) {
ind <- which((apag == 2 & t(apag) == 1), arr.ind = TRUE)
for (i in seq_len(nrow(ind))) {
a <- ind[i, 1]
c <- ind[i, 2]
indB <- which(((apag[a, ] == 2 & apag[, a] == 3) |
(apag[a, ] == 1 & apag[, a] == 3)) &
(apag[c, ] == 3 & apag[, c] == 2))
if (length(indB) > 0) {
apag[c, a] <- 3
if (verbose) {
cat("\nRule 8","\n")
cat("Orient:", a, "->", indB, "->", c,
"or", a, "-o", indB, "->", c, "with",
a, "o->", c, "as", a, "->", c, "\n")
}
}
}
}
##-- R9 ------------------------------------------------------------------
if (rules[9]) {
ind <- which((apag == 2 & t(apag) == 1), arr.ind = TRUE) ## a o-> c
while (length(ind) > 0) {
a <- ind[1, 1]
c <- ind[1, 2]
ind <- ind[-1,, drop = FALSE]
## find all b s.t. a (o-)--(o>) b and b and c are not connected
indB <- which((apag[a, ] == 2 | apag[a, ] == 1) & (apag[, a] == 1 | apag[, a] == 3) & (apag[c, ] == 0 & apag[, c] == 0))
## delete c from indB since it is surely inside
indB <- setdiff(indB, c)
## chose one b s.t. the initial structure exists and the edge hasn't been oriented yet
while ((length(indB) > 0) && (apag[c,a] == 1)) {
b <- indB[1]
indB <- indB[-1]
## find a minimal uncovered pd path from initial (a, b, c) :
## cat("R9: a=", a, ", b=", b, ", c=", c,"\n")
upd <- minUncovPdPath(p, apag, a, b, c,
unfVect = unfVect, verbose = verbose)
## there is a path ---> orient it
if (length(upd) > 1) {
apag[c, a] <- 3
if (verbose) {
cat("\nRule 9", "\n")
cat("There exists an uncovered potentially directed path between", a, "and", c, ". Orient:", a, " ->",c, "\n")
}
}
}## while
}
}
##-- R10 ------------------------------------------------------------------
if (rules[10]) {
ind <- which((apag == 2 & t(apag) == 1), arr.ind = TRUE) ## a o-> c
while (length(ind) > 0) {
a <- ind[1, 1]
c <- ind[1, 2]
ind <- ind[-1,, drop = FALSE]
## find all b s.t. b --> c
indB <- which((apag[c, ] == 3 & apag[, c] == 2))
if (length(indB) >= 2) {
counterB <- 0
while (counterB < length(indB) && (apag[c, a] == 1)) {
counterB <- counterB + 1
b <- indB[counterB]
indD <- setdiff(indB, b)
counterD <- 0
while ((counterD < length(indD)) && (apag[c, a] == 1)) {
counterD <- counterD + 1
d <- indD[counterD]
## this is the easiest one
if ((apag[a, b] == 1 || apag[a, b] == 2) &&
(apag[b, a] == 1 || apag[b, a] == 3) &&
(apag[a, d] == 1 || apag[a, d] == 2) &&
(apag[d, a] == 1 || apag[d, a] == 3) &&
(apag[d, b] == 0 && apag[b, d] == 0)) {
if (length(unfVect) == 0) { ## normal version
apag[c, a] <- 3
if (verbose)
cat("\nRule 10","\nOrient:", a, "->", c, "\n")
}
else { ## conservative version
## check faithfulness of b-a-d
if (!any(unfVect == triple2numb(p,b,a,d), na.rm = TRUE) &&
!any(unfVect == triple2numb(p,d,a,b), na.rm = TRUE)) {
apag[c, a] <- 3
if (verbose)
cat("\nRule 10","\nConservatively orient:", a, "->", c, "\n")
}
}
}
## search with a breitensuche two minimal uncovered circle paths
else {
## find all x s.t. a (o-)--(o>) x
indX <- which((apag[a, ] == 1 | apag[a, ] == 2) &
(apag[, a] == 1 | apag[, a] == 3), arr.ind = TRUE)
indX <- setdiff(indX, c)
if (length(indX >= 2)) {
i1 <- 0
while (i1 < length(indX) && apag[c, a] == 1) {
i1 <- i1 + 1
# pos.1 <- indA[i1]
pos.1 <- indX[i1]
indX2 <- setdiff(indX, pos.1)
i2 <- 0
while (i2 < length(indX2) && apag[c, a] == 1) {
i2 <- i2 + 1
pos.2 <- indX2[i2]
## cat("R10.1: a=", a, ", b=", b, ", c=", c,"\n")
tmp1 <- minUncovPdPath(p, apag, a, pos.1, b,
unfVect = unfVect, verbose = verbose)
## cat("R10.2: a=", a, ", b=", b, ", c=", c,"\n")
tmp2 <- minUncovPdPath(p, apag, a, pos.2, d,
unfVect = unfVect, verbose = verbose)
## we found 2 uncovered pd paths
if (length(tmp1) > 1 && length(tmp2) > 1 &&
pos.1 != pos.2 && apag[pos.1, pos.2] == 0) {
if (length(unfVect) == 0) { ## normal version
apag[c, a] <- 3
if (verbose)
cat("\nRule 10","\nOrient:", a, "->", c, "\n")
}
else { ## conservative version
if (!any(unfVect == triple2numb(p,pos.1, a, pos.2), na.rm = TRUE) &&
!any(unfVect == triple2numb(p,pos.2, a, pos.1), na.rm = TRUE)) {
apag[c, a] <- 3
if (verbose)
cat("\nRule 10","\nConservatively orient:", a, "->", c, "\n")
}
}
}
}
}
}
}
}
}
}
}
} ## rules[10]
}
}
list(graph = apag, sepset = sepset)
} ## {udag2apag}
######################################################################
## Oracle FCI (fast)
#######################################################################
ancTS <- function(g) {
## Purpose: compute the ancestors of each node in the graph
## ----------------------------------------------------------------------
## Arguments: - g: graph in topological order (e.g. produced with randomDAG)
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 6 Aug 2012, 10:57
stopifnot((p <- numNodes(g)) >= 2)
m <- as(g, "matrix")
an <- pa <- vector("list", p)
for (i in 2:p) {
pa[[i]] <- pa.i <- which(m[1:(i-1),i] != 0)
if (length(pa.i) > 0) {
tmp <- c(pa.i)
## FIXME: unlist(lapply(pa.i, function(.) an[[.]])) :
for (p.ij in pa.i)
tmp <- c(tmp, an[[p.ij]])
an[[i]] <- sort(unique(tmp))
}
}
an
}
dag2pag <- function(suffStat, indepTest, graph, L, alpha, rules = rep(TRUE,10), verbose = FALSE) {
## Purpose: Perform fat oracle FCI-Algorithm, i.e., estimate PAG from
## the true DAG
## ----------------------------------------------------------------------
## Arguments:
## - suffStat, indepTest: info for the tests
## - graph: the true DAG
## - L: array containing the latent variables (columns in the adjacency matrix)
## - alpha: Significance level of individual partial correlation tests
## - rules: array of length 10 wich contains TRUE or FALSE corrsponding
## to each rule. TRUE means the rule will be applied.
## If rules==FALSE only R0 (minimal pattern) will be used
## - verbose: 0 - no output, 1 - detailed output
## ----------------------------------------------------------------------
## Author: Diego Colombo, 2011
p <- numNodes(graph)
cl <- match.call()
## find the ancestor sets
ancList <- ancTS(graph)
if (verbose) {
cat("Compute Skeleton\n================\n")
}
## find the skeleton
skel <- skeleton.dag2pag(suffStat, indepTest, graph,
ancList, L, alpha, verbose = verbose)
G <- as(skel@graph, "matrix")
sepset <- skel@sepset
pMax <- skel@pMax
n.edgetestsSKEL <- skel@n.edgetests
max.ordSKEL <- skel@max.ord
allPdsep <- NA
## tripleList <- NULL
n.edgetestsPD <- 0
max.ordPD <- 0
allPdsep <- vector("list", p-length(L))
## if (sum(G) == 0) {
## Gobject <- new("graphNEL", nodes = as.character(1:(p-length(L))))
## }
## else {
## colnames(G) <- rownames(G) <- as.character(1:(p-length(L)))
## Gobject <- as(G, "graphNEL")
## }
if (sum(G) != 0)
colnames(G) <- rownames(G) <- as.character(seq_len(p-length(L)))
if (verbose) {
cat("\nDirect egdes:\n=============\nUsing rules:", which(rules),
"\nCompute collider:\n")
}
res <- if (numEdges(skel@graph) > 0)
udag2pag(pag = G, sepset, rules = rules, verbose = verbose)
else G
new("fciAlgo", amat = res, call = cl, n = integer(0),
max.ord = as.integer(max.ordSKEL), max.ordPDSEP = as.integer(max.ordPD),
n.edgetests = n.edgetestsSKEL, n.edgetestsPDSEP = n.edgetestsPD,
sepset = sepset, pMax = pMax, allPdsep = allPdsep)
} # {dag2pag}
##' Perform undirected part of oracle FCI-Algorithm, i.e.,
##' find skeleton of PAG given the true DAG
##'
##' @title
##' @param suffStat info for the tests
##' @param indepTest info for the tests
##' @param graph the true DAG
##' @param ancList list containing the ancestors of each node in the graph
##' @param L array containing the latent variables (columns in the adjacency matrix)
##' @param alpha Significance level of individual partial correlation tests
##' @param NAdelete delete edge if pval=NA (for discrete data)
##' @param verbose 0 - no output, 1 - detailed output
##' @return "pcAlgo" object : (G, sepset, pMax, ord, n.edgetests)
##' @author Diego Colombo, 2011; speedup: Martin Maechler, Nov.2013
skeleton.dag2pag <- function(suffStat, indepTest, graph, ancList, L, alpha,
NAdelete = TRUE, verbose = FALSE)
{
## Currently exported but undocumented, used only in dag2pag()
new.ord <- function(start, old, L) {
seq_start <- 1:start
tmp <- setdiff(seq_start,L) ## <- independent of old -- FIXME speed
new <- rep(0, length(old))
for (i in seq_along(old)) {
new[i] <- which(tmp == old[i])
}
return(new)
}
cl <- match.call()
pval <- NULL
p <- numNodes(graph)
stopifnot(2 <= (new.p <- p-length(L)))
sepset <- vector("list", new.p)
G <- matrix(TRUE, nrow = new.p, ncol = new.p)
diag(G) <- FALSE
for (iList in 1:new.p) sepset[[iList]] <- vector("list", new.p)
pMax <- matrix(-Inf, nrow = new.p, ncol = new.p)
diag(pMax) <- 1
## test independence given the ancestors
for (i in setdiff(1:(p-1), L)) { ## i.e. i is not in L
iL <- new.ord(p,i,L)
for (j in setdiff((i+1):p, L)) { ## i.e. j is not in L
cond.set <- c(ancList[[i]],ancList[[j]])
cond.set <- setdiff(cond.set,c(i,j,L))
pval <- indepTest(i, j, cond.set, suffStat)
jL <- new.ord(p,j,L)
if (verbose) {
cat("x=", iL, " y=", jL,
" S=", new.ord(p,cond.set,L),": pval =", pval, "\n")
}
if(is.na(pval)) pval <- as.numeric(NAdelete) ## == if(NAdelete) 1 else 0
if (pval > pMax[iL, jL]) {
pMax[iL, jL] <- pval
}
if (pval >= alpha) {
G[iL, jL] <- G[jL, iL] <- FALSE
sepset[[iL]][[jL]] <- new.ord(p,cond.set,L)
}
}
}
for (i in 1:(new.p - 1)) {
for (j in 2:new.p) {
pMax[i, j] <- pMax[j, i] <- max(pMax[i, j], pMax[j, i])
}
}
Gobject <- if (sum(G) == 0)
new("graphNEL", nodes = as.character(1:new.p))
else {
colnames(G) <- rownames(G) <- as.character(1:new.p)
as(G, "graphNEL")
}
new("pcAlgo", graph = Gobject, call = cl, n = integer(0),
max.ord = integer(0), n.edgetests = integer(0),
sepset = sepset, pMax = pMax, zMin = matrix(NA, 1, 1))
}
iplotPC <- function(pc.fit, labels = NULL) {
## igraph alternative to Rgraphviz (only for pcAlgo objects)
adjm <- wgtMatrix(getGraph(pc.fit), transpose = FALSE)
if (!is.null(labels)) dimnames(adjm) <- list(labels, labels)
g1 <- graph_from_adjacency_matrix( adjm )
plot.igraph(g1)
}
showEdgeList <- function(object, labels = NULL)
{
cat("\nEdge List: \n")
g <- getGraph(object)
if (is.null(labels)) labels <- nodes(g)
isDir <- isDirected(g)
wm <- wgtMatrix(g)
if(isDir && !is(object,"pcAlgo"))
stop("implementation only for 'pcAlgo', currently ...") ##-> Markus
## MM: in general, maybe rather look at each pair (i,j) in the lower triangular part of [W, t(W)]
wmU <- wm + t(wm) # weights for undirected e.
wmD <- t(wm - t(wm))# weights for directed e.
u <- which(wmU == 2 & upper.tri(wmU), arr.ind = TRUE)
cat("\n", if(isDir) "Undirected Edges" else "Undirected graph with Edges",
":\n", sep = "")
for (i in seq_len(nrow(u)))
cat(" ", paste(labels[u[i,1]], " --- ", labels[u[i,2]], "\n"))
if(isDir) {
d <- which(wmD == 1, arr.ind = TRUE)
d <- d[order(d[,1]),]
cat("\nDirected Edges:\n")
for (i in seq_len(nrow(d)))
cat(" ", paste(labels[d[i,1]], " --> ", labels[d[i,2]], "\n"))
} else {
d <- matrix(0,0,0)
}
invisible(list(undir = u, direct = d))
}
#######################################################################
## Generalized backdoor criterion
#######################################################################
visibleEdge <- function(amat, x, z)
{
## Purpose: check if the directed edge from x to z in a MAG or in a PAG
## is visible or not
## ----------------------------------------------------------------------
## Arguments: amat, x, z
## ----------------------------------------------------------------------
## Value: T/F
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 25 Apr 2012; simplification: Martin Maechler
## 1. scenario: there exists a vertex not adjacent to z with *---> x
## c *-> x --> z and c and z not connected :
hasC1 <- any(amat[x,] != 0 & amat[,x] == 2 & amat[z,] == 0)
## if there is at least one vertex
if (any(hasC1)) ## the edge is visible
return(TRUE)
## Otherwise:
## 2. scenario: there exists a collider path that is into x and
## every vertex on the path is a parent of z
## c <--> x --> z and c is a parent of z :
indC2 <- which(amat[x,] == 2 & amat[,x] == 2 &
amat[z,] == 3 & amat[,z] == 2)
for(c in indC2) {
## find a minimal discriminating path for c,x,z
if (length(minDiscrPath(amat, c,x,z)) > 1)
## a path exists
return(TRUE)
}
## nothing found: return
FALSE
}
possibleDe <- function(amat,x)
{
## Purpose: in a DAG, CPDAG, MAG, or PAG determine which nodes are
## possible descendants of x on definite status paths
## ----------------------------------------------------------------------
## Arguments:
## - amat: adjacency matrix of type amat.pag
## - x: node of interest
## ----------------------------------------------------------------------
## Value:
## - de.list: array containing the possible descendants of x
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 26 Apr 2012, 16:58
stopifnot(is.matrix(amat))
p <- nrow(amat)
is.de <- rep.int(FALSE, p) ##
## 1. case: x is a possible child of itself
is.de[x] <- TRUE
## 2. case: find all the possible children of x
indD <- which(amat[x,] != 0 & amat[,x] != 2 & !is.de) ## x (o,-)-* d
i.pr <- rep(x,length(indD))
while (length(indD) > 0) {
## next element in the queue
d <- indD[1]
indD <- indD[-1]
pred <- i.pr[1]
i.pr <- i.pr[-1]
is.de[d] <- TRUE
a.d <- amat[,d]
a.d.p <- a.d[pred]
## find all possible children of d not visited yet
indR <- which(amat[d,] != 0 & a.d != 2 & !is.de) ## d (o,-)-* r
for(j in seq_along(indR)) {
## check that the triple <pred,d,r> is of a definite status
## 1. d is a collider on this subpath; this is impossible
## because the edge between d and r cannot be into d
## 2. d is a definite non-collider
r <- indR[j]
if (a.d.p == 3 || a.d[r] == 3 ||
(a.d.p == 1 && a.d[r] == 1 && amat[pred,r] == 0)) {
## update the queues
indD <- c(indD, r)
i.pr <- c(i.pr, d)
}
}
}
## return 'de.list' :
which(is.de)
} ## {possibleDe}
dreach <- function(x, y, amat, verbose = FALSE)
{
## Purpose: Compute d-sep(x,y) ("dsep")
## !!!!! WE DO NOT ASSUME SELECTION VARIABLES HENCE NO --- EDGES IN A MAG!!!!
## ----------------------------------------------------------------------
## Arguments:
## - x, y: nodes of which dsep must be computed
## - amat: adjacency matrix of a MAG
## amat[i,j] = 0 iff no edge btw i,j
## amat[i,j] = 3 iff i *-- j
## amat[i,j] = 2 iff i *-> j
## - verbose: Show checked node sequence
## ----------------------------------------------------------------------
## Value:
## - DSEP: set containing the nodes in D-SEP(x,y)
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 31 Jan 2013, 11:04
## check: quadratic; x in V; edgemarks ok; non-zeroes symmetric
stopifnot(is.matrix(amat), (p <- nrow(amat)) == ncol(amat),
x <= p, amat %in% c(0,2,3),
## The non-zero entries in amat must be symmetric:
(aN0 <- amat != 0) == t(aN0))
## compute the ancestors of x and y
amat.an <- amat
amat.t <- amat + t(amat)
## because we have only ---> and <--> edges, in amat.t we have either 5s (--->) or 4s (<-->)
## delete all the bi-directed edges
amat.an[which(amat.t == 4)] <- 0
## transform the directed edges from 3 and 2 in 1 and 0
amat.an[which(amat.an == 3)] <- 0
amat.an[which(amat.an == 2)] <- 1
dir.graph <- as(amat.an, "graphNEL")
john.pairs <- johnson.all.pairs.sp(dir.graph)
anc.y <- anc.x <- rep(FALSE, p)
anc.y[which(john.pairs[,y] < Inf)] <- TRUE
anc.x[which(john.pairs[,x] < Inf)] <- TRUE
## the set containing the ancestors of either x or y
anc <- anc.x | anc.y
anc[x] <- FALSE
## prepare the setting for the search
amat.tmp <- amat
nb <- which(amat[x,] != 0 & anc)
Q <- nb
P <- rep.int(x,length(Q))
DSEP <- nb
amat.tmp[x,nb] <- 0 ## delete edge to nbrs
while(length(Q) > 0) {
## Invariants:
## ===========
## (A1) length(Q) == length(P) > 0
## (A2) non-zero in amat.tmp -> non-zero in amat [no non-zero added]
## (A3) Q[i] and P[i] are adjacent in amat [using (A2)]
if (verbose) {
cat("\n-------------","\n")
cat("Queue Q:",Q,"\n")
cat("Queue P:",P,"\n")
}
a <- Q[1]
Q <- Q[-1]
pred <- P[1] ## not empty because of (A1)
P <- P[-1]
if (verbose) cat("Select",pred,"towards",a,"\n")
nb <- which(amat.tmp[a,] != 0 & anc) ## (*)
for (i in seq_along(nb)) {
b <- nb[i]
## Guaranteed: pred-a-b are a path because of (A3)
## if a is a collider, b is in D-SEP of x
if (amat[pred,a] == 2 && amat[b,a] == 2) {
amat.tmp[a,b] <- 0 ## remove b out of adj(a) in amat.tmp (+)
Q <- c(Q,b)
P <- c(P,a)
DSEP <- c(DSEP,b)
}
}
}
sort(unique(DSEP))
} ## {dreach}
pag2magAM <- function(amat.pag, x, max.chordal = 10, verbose = FALSE)
{
## Purpose: transform a PAG/CPDAG into a valid MAG/DAG using the arrowhead
## augmentation from Zhang, without orienting additional edges
## into x and then orient any chordal component into a DAG
## ----------------------------------------------------------------------
## Arguments:
## - amat.pag: adjacency matrix of the PAG/CPDAG
## - x: node of interest
## ----------------------------------------------------------------------
## Value:
## - valid.DAG.mat: adjacency matrix corresponding to the valid MAG
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 12 Apr 2013, 14:24;
## Tweaks by Martin Maechler, bug fix by Joris Mooij
## deal with indexing issues
rn<-rownames(amat.pag)
cn<-colnames(amat.pag)
rownames(amat.pag)<-c(1:dim(amat.pag)[1])
colnames(amat.pag)<-c(1:dim(amat.pag)[1])
## 1. step: arrowhead augmentation
## find all o-> edges in the PAG
indA <- which((amat.pag == 2 & t(amat.pag) == 1), arr.ind = TRUE)
for (i in seq_len(nrow(indA))) {
a <- indA[i, 1]
b <- indA[i, 2]
amat.pag[b,a] <- 3L
}
## because we don't allow selection variables in the generalized backdoor
## criterion these kind of edges should not be present BUT YOU NEVER KNOW...
## find all o-- edges in the PAG
indB <- which(amat.pag == 3 & t(amat.pag) == 1, arr.ind = TRUE)
for (i in seq_len(nrow(indB))) {
a <- indB[i, 1]
b <- indB[i, 2]
amat.pag[b,a] <- 2L
}
## 2.step: find all the chordal components in the updated graph
## find the adjacency matrix that contains
amat.undir <- amat.dir <- amat.pag
amat.t <- amat.pag + t(amat.pag)
## we are interested only in the o-o edges
## delete all the other edges
amat.undir[amat.t != 2] <- 0L
amat.dir [amat.t == 2] <- 0L
g.undir <- as(amat.undir,"graphNEL")
## Get all connected components [maybe should rather keep labels ??]
conn.comp <- lapply(connectedComp(g.undir), as.numeric)
if(verbose) {
lc <- vapply(conn.comp, length, 1L)
t2 <- if(any(lc == 1)) gettextf(" and %d singletons", sum(lc == 1)) else ""
cat(gettextf("The undirected graph has %d connected components%s",
sum(lc > 1), t2),"\n")
}
valid.DAG.mat <- amat.undir
## get all semilocal extensions of the undirected cpdag
for (cci in conn.comp) if (length(cci) > 1) {
if(length(cci) > max.chordal) return(NULL)
## check whether the component is chordal
am.u.ii <- amat.undir[cci,cci]
if(!is_chordal(graph_from_adjacency_matrix(am.u.ii, "undirected"),
fillin = TRUE)$chordal)
return(NULL)
## else: not extendable or too large to handle
am. <- my.SpecialDag(amat.undir, a=am.u.ii, X=x, verbose=verbose)
valid.DAG.mat <- valid.DAG.mat * am.
} # if() ..end for
## add directed edges and return "valid.DAG.mat":
amat.mag <- valid.DAG.mat + amat.dir
rownames(amat.mag)<-rn
colnames(amat.mag)<-cn
## return mag
amat.mag
} ## {pag2magAM}
##' Auxiliary for pag2magAM()
my.SpecialDag <- function (gm, a, X, verbose = FALSE)
{
while (sum(a) != 0 ) {
sinks <- find.sink(a)
if (verbose) {
cat("Main Call: ################## \n")
print(gm)
print(a)
cat("Sinks: ", sinks, "\n")
}
for (x in sinks) {
if (verbose)
cat("Try removing", x, " in a.\n")
if (adj.check(a, x) & as.numeric(rownames(a)[x]) != X) {
inc.to.x <- a[, x] == 1 & a[x, ] == 1
if (any(inc.to.x)) {
real.inc.to.x <- as.numeric(rownames(a)[inc.to.x])
real.x <- as.numeric(rownames(a)[x])
gm[real.x, real.inc.to.x] <- 3
gm[real.inc.to.x, real.x] <- 2
}
if (verbose) {
cat("Removed sink", as.numeric(rownames(a)[x]),
"in g (", x, "in a).\n")
cat("New graphs: \n")
print(gm)
print(a)
}
a <- a[-x, -x]
break
}
}
}
gm
} ## {my.SpecialDag}
backdoor <- function(amat, x, y, type = "pag", max.chordal = 10, verbose = FALSE)
{
## Purpose: for a given pair of nodes (x,y) and a given graph (DAG, CPDAG,
## MAG, or PAG) estimate if the causal effect of x on y using the
## generalized backdoor criterion is identifiable or not. In a
## first step we check if the effect is identifiable or not. If
## it is identifiable we compute the set W that satisfies the
## generalized backdoor criterion. If it is not identifiable
## the output is NA
## ----------------------------------------------------------------------
## Arguments:
## - amat: adjacency matrix of the corresponding graph
## - x, y: nodes for which we want to estimate the causal effect of x on y
## - type: specifies the type of graph of the adjacency matrix amat. It
## can be a DAG (type="dag"), a CPDAG (type="cpdag"), a MAG
## (type="mag"), or a PAG (type="pag")
## ----------------------------------------------------------------------
## Value:
## - cEffect: causal effect of x on y (either NA not identifiable or a number)
## ----------------------------------------------------------------------
## Author: Diego Colombo, Date: 12 Apr 2013, 16:06
stopifnot (dim(amat)[1] > 0, x != y, length(type) == 1)
set.w <- NA
if (type == "dag" || type == "cpdag") {
## transfor each directed edge from 0-1 to 2-3 in the adjacency matrix
ind <- which((amat == 1 & t(amat) == 0), arr.ind = TRUE) ## a -> b
for (i in seq_len(nrow(ind))) {
a <- ind[i, 1]
b <- ind[i, 2]
amat[a,b] <- 2
amat[b,a] <- 3
}
}
## check that x and y belong to the same connected component
## compute the connected components of the whole graph
conn.comp <- lapply(connectedComp(as(amat, "graphNEL")),
as.numeric)
found.conncomp <- FALSE
for(ic in seq_along(conn.comp))
if (x %in% conn.comp[[ic]] & y %in% conn.comp[[ic]]) {
found.conncomp <- TRUE
break ## we found one {FIXME: should use info conn.comp[[ic]] ! }
}
## if x and y are not in the same connected component ---> empty set
if (!found.conncomp)
return( NULL )
## else :
## 1. generate a MAG/DAG belonging to the equivalence class of the
## PAG or a CPDAG without orienting additional edges into X
amat.r <- if (type == "cpdag" || type == "pag")
pag2magAM(amat, x, max.chordal = max.chordal, verbose = verbose)
else amat
## 2. compute the truncated corresponding graph
## 2.a) find all the visible edges in the original graph that are out of X
## 2.b) all the definitely visible edges out of X have to be deleted
## in the graph constructed previously
indD <- which(amat[x,] == 2 & amat[,x] == 3) ## x--> d
## CASE A: in a CPDAG or DAG every directed edge out of X is visible
## then delete them all
if (type == "cpdag" || type == "dag") {
for (z in indD)
## delete visible edges out of x edges
amat.r[z,x] <- amat.r[x,z] <- 0
} else {
## CASE B: in a MAG or PAG the directed edges out of X need
## to be checked for visibility
if (length(indD) > 0) {
del.edges <- vapply(indD, function(z) {
## check each directed edge out of X for visibility
visibleEdge(amat, x, z)
}, NA)
## delete visible edges out of x edges
amat.r[indD[del.edges],x] <- amat.r[x,indD[del.edges]] <- 0
## transform invisible edges out of x by bi-directed
## amat.r[indD[!del.edges],x] <- amat.r[x,indD[!del.edges]] <- 2
}
}
## 3. compute possible descendants of x along definite status paths
## list.de <- possibleDe(amat, x)
list.de <- possDe(m = amat, x = x, y = NULL, possible = TRUE,
ds = TRUE, type = "pag") ## sic !!!
## 4. compute D-SEP(x,y)_path in the truncated graph
dsep.set <- dreach(x, y, amat.r)
## 5. check that no possible descendants of x along definite status
## paths are in D-SEP(x,y,amat.r) or y is in adj(x, amat.r)
if (amat.r[x,y] == 0 && !any(list.de %in% dsep.set))
## D-SEP(x,y,amat.r) closes all the paths
set.w <- dsep.set
set.w
} ## {backdoor}
##' Utility that transforms a CPDAG matrix into a FCI matrix
trafoCPDmat <- function(M)
{
n <- ncol(M)
if(n >= 2) for(i in 2:n)
for(j in seq_len(i-1L)) { ## 1 <= j < i <= n
if (M[i,j] == 1L) {
## if the edge is i -> j
if (M[j,i] == 0L) {
M[i,j] <- 2L # arrow head
M[j,i] <- 1L # arrow circle
}
## if the edge is i - j --- nothing to do: M[i,j] = M[j,i] = 1 already
## else if (M[j,i] == 1)
## {
## M[i,j] <- 1 # arrow circle
## M[j,i] <- 1 # arrow circle
## }
}
## if the edge is i <- j
else if (M[i,j] == 0L && M[j,i] == 1L)
{
M[i,j] <- 1L # arrow circle
M[j,i] <- 2L # arrow head
}
}
M
}
## this function finds ancestors of a node x in the subgraph of G+
## when some confounders are removed,
## for i=1..p (p - number of nodes in the full graph)
## vector[i] = position of the node i in the subgraph (if the node is not in
## the subgraph vector[i]=0)
## m is the adjacency matrix of the full graph
###___ CURRENTLY UNUSED ___, instead NAA_ancestors() below
NAAancestors.1 <- function(x, m, vector)
{
## q denotes unvisited nodes/ nodes in queue
## v denotes visited nodes
p <- nrow(m)
q <- v <- integer(p) # all 0
q[1L] <- x
i <- k <- 1L
while(k <= i && q[k] != 0)
{
t <- q[k]
## mark t as visited
v[k] <- t
k <- k+1L
## in this for cycle adds all nodes that have an undirected
## edge with node t and all parents of node t to queue
for(j in 1:p)
if (m[j,t] == 2 && m[t,j] == 3)
## only add nodes that haven't been added
if (vector[j] != 0 && j %nin% q)
{
i <- i+1L
q[i] <- j
}
}
## Not Against Arrow Ancestors
## If node a is in NAAA that means that there is a not against arrowhead path
## from a to x
setdiff(v, c(0L,x))
}
##' Finds the "not against arrowhead ancestors" of the node x in G+
##' using the adjacency matrix m of G+, and breadth first search.
##' "Not Against Arrowhead Ancestors" (NAAA) are all the nodes u in G+ that
##' have a path u.. -> x in G+ which doesn't go against arrowhead
##'
##' Currently only used as auxiliary for PosDsepLinks()
##'
##' @title Find "Not Against Arrowhead" Ancestors (NAAA)
##' @param x scalar integer in 1..p, denoting a node in graph G+
##' @param m p x p adjacency matrix of graph G+
##' @return a (possibly empty) vector of integers, the NAAA nodes of x in G+
NAA_ancestors <- function(x, m)
{
## q denotes unvisited nodes/ nodes in queue
## v denotes visited nodes
p <- ncol(m); i.p <- 1:p
q <- v <- integer(p) # all 0
q[1L] <- x
i <- k <- 1L
while(k <= i && q[k] != 0) {
t <- q[k]
## mark t as visited
v[k] <- t
k <- k+1L
## in this for cycle adds all nodes that have an undirected
## edge with node t and all parents of node t to queue
for(j in i.p)
if ((t == x && m[j,t] == 2 && m[t,j] == 1) ||
(t != x && m[t,j] != 2 && m[t,j] != 0))
## only add nodes that haven't been added
if (j %nin% q) {
i <- i+1L
q[i] <- j
}
}
## return Not Against Arrow Ancestors (NAAA):
## A node a is in NAAA iff there is a "not against arrowhead" path from a to x
setdiff(v, c(0L,x))
}
##' Find possible Dsep links, given the adjacency matrix,
##' as the edges that satisfy the pattern described in Lemma 4.
##'
##' The edge X <-> Y is a PosDsep link in G+ if there exist nodes, U,V such that
##' U <-> X <-> Y <-> V in G+, and U and V are not adjacent and paths V.. -> X
##' U.. -> Y exist in G+ and they do not go against arrowhead
##' @title Find POSsible D-Separation LINKS
##' @param m adjacency matrix
##' @return a (possibly empty) data frame with columns "x" and "y"
##' where \code{x[i] *-* y[i]} is a possible Dsep link for all i.
# PosDsepLinks <- function(m, verbose=TRUE)
# {
# stopifnot(1 <= (p <- ncol(m)))
# i.p <- 1:p
# NAAA <- vector("list", p)
# x <- y <- integer()
# ## for all pairs 1 <= j < i <= p
# for(i in i.p[-1L]) {
# ## nodes that have a "not against arrowhead" path to i :
# NAAA[[i]] <- NAAA_i <- NAA_ancestors(i, m)
# for (j in 1:i)
# ## first find a bidirected i <-> j edge in G+
# if (m[i,j] == 2 && m[j,i] == 2) {
# u <- v <- integer()
# ## Then find bidirected edges u <-> i and j <-> v
# for (k in i.p) if (k != i && k != j)
# {
# if (m[i,k] == 2 && m[k,i] == 2)
# u <- union(u,k)
# if (m[j,k] == 2 && m[k,j] == 2)
# v <- union(v,k)
# }
#
# ## find nodes u (v) that have both a bidirected edge with i (j) and
# ## a not against arrowhead path to j (i)
# u <- intersect(u, NAAA[[j]]) ## as j <= i, this is already computed
# v <- intersect(v, NAAA_i)
#
# ## check if there is a pair of nodes in (u,v) that is not adjacent
# found.i.j <- FALSE
# for(k in seq_along(u)) {
# u.k <- u[k]
# for(r in seq_along(v))
# if (u.k != v[r] && m[u.k,v[r]] == 0) {
# found.i.j <- TRUE
# break
# }
# if(found.i.j)
# break
# }
#
# ## found.i.j is true iff we found a pair of nodes fulfilling all 3 conditions.
# ## In that case, the node pair (i,j) is added to the PosDsepLinks set:
# if (found.i.j) {
# if(verbose) cat(sprintf("Added PosDsepLink %2d *-* %2d\n", i,j))
# x <- c(x, i)
# y <- c(y, j)
# }
# }
# }
#
# ## returns data frame with possible Dsep links x[i] *-* y[i] for all i
# data.frame(x = x, y = y)
# }
## this function finds a minimal Dsep set, given a Dsep set by
## going through all the subsets of the Dsep set, in the same way it is
## done as in the skeleton function
## x and y are the nodes separated by the sepset sep,
## while suffStat is a sufficient statistic, and
## indepTest is an independence test
MinimalDsep <- function(x,y, sep, suffStat,indepTest, alpha = 0.01)
{
stopifnot((n <- length(sep)) >= 1)
for(i in 1:n)
{
S <- seq_len(i)
wasLast <- FALSE
while (!wasLast) {
if (indepTest(x,y,sep[S],suffStat) > alpha) ## had 'alpha= 0.01' hardcoded
return(sep[S])
z <- getNextSet(n,i,S)
S <- z$nextSet
wasLast <- z$wasLast
}
}
}
##' Find the hierarchy HIE(X,I) given a vector of nodes x and a list of
##' sepsets, according to the definition of a hierarchy HIE(X,I).
##'
##' This is a recursive function, so even though vector x represents the
##' original vector given to the function, it also represents the hierarchy
##' we are in the process of constructing
##' @title Find Hierarchy HIE(X,I)
##' @param x a vector of nodes.
##' @param sepset a list of \dQuote{sepsets}, the "independence set".
##' @return
HIE <- function(x, sepset)
{
## flag1 is used to detect wheteher the hierarchy
## is complete or if more nodes should be added
flag1 <- FALSE
## first check if all the nodes have been added
## if there are nodes that still need to be added
## set flag1 to TRUE and exit the loop
i.x <- seq_along(x)
for(i in i.x)
{
if (flag1) break
for(j in seq_along(x)) {
ss.ij <- sepset[[x[i]]][[x[j]]]
if (!is.null(ss.ij) && length(ss.ij) != 0 && length(setdiff(ss.ij, x)) != 0) {
flag1 <- TRUE
break
}
}
}
## if flag1 is still FALSE all nodes have been added
## and we can exit the function
if (!flag1)
return(x)
## else (flag1 is TRUE) there are still nodes to be added
## flag2 is an indicator that prevents the recursion
## from doing some calculations more than once
flag2 <- FALSE
for(i in i.x) {
if (flag2) break
for(j in i.x)
{
if (flag2)
break
## else :
## if there are still nodes in the separating set of two nodes
## from the hierarchy that are not in the hierarchy
## add those nodes to the hierarchy
ss.ij <- sepset[[x[i]]][[x[j]]]
if (!is.null(ss.ij) && length(ss.ij) != 0 && length(setdiff(ss.ij, x)) != 0) {
## recurse
return(HIE(union(x,ss.ij), sepset))
}
}
}
} ## {HIE}
AugmentGraph <- function(M, suffStat, sepsets, indepTest, alpha = 0.01)
{
## first transform matrix so that it differentiates between edge marks
stopifnot((p <- ncol(M)) >= 1)
if(hasNms <- !is.null(dns <- dimnames(M))) dimnames(M) <- NULL # speedup
i.p <- 1:p
for(i in i.p) {
seps.i <- sepsets[[i]]
for(j in i.p) ## go through all the sepsets
## cat("i=",i," - j=",j,"\n")
if (!is.null(sep <- seps.i[[j]])) {
## only check neighbors of i, j and sepset
adjacent <- union(which(M[i,] != 0),
which(M[j,] != 0))
for (r in seq_along(sep))
adjacent <- union(adjacent, which(M[sep[r],] != 0))
## delete i,j, sepset from the set of adjacent nodes
del.nodes <- union(c(i,j), sep)
adjacent <- setdiff(adjacent, del.nodes)
## if adding a node to the sepset breaks the cond. independence
## orient according to lemma 2. (i)
for (adj in adjacent) {
if (indepTest(i, j, union(sep,adj), suffStat) < alpha) {
for(node in del.nodes)
if ((M.k <- M[node,adj]) != 0 && M.k != 2) {
M[node,adj] <- 2
## cat("oriented this node:",node," towards this node:",adj,"\n")
}
}
}
}
}
## return newly oriented matrix
if(hasNms) structure(M, dimnames = dns) else M
}
## The final fciplus function, it uses all other functions and returns
## an adjacency matrix; however, it does not go through the 10 orientation rules.
##
## the input for the function is a pc fitted graph - pc.fit
## as well as a sufficient statistic and an independence test
# fciplus.intern <- function(pc.fit, alpha = 0.01, suffStat, indepTest, verbose=TRUE)
# {
# sepsets <- pc.fit@sepset
# cpdag <- pc.fit@graph
# m <- trafoCPDmat(as(cpdag, "matrix"))
#
# ## first run the augment graph function to orient invariant
# ## arrowheads according to Lemma 2. (1)
# mat <- AugmentGraph(m, suffStat, sepsets, indepTest)
# ## which(mat[,27]==2)
# ## Check if there are any possible Dsep links
# link <- PosDsepLinks(mat)
#
# ## if there are possible Dsep links it should be checked
# ## which of these are actually edges that should be removed
# ## an edge X - Y is a Dsep link if X and Y are Dseparated by the hierarchy
# ## of the parents of the nodes X and Y (excluding X and Y)
#
# ## a counter to help us go through the data frame of all possible Dsep lins
# count <- 1L
# while (count <= length(link$x)) {
#
# x <- link$x[count]
# y <- link$y[count]
#
# ## basex and basey are vectors of the nodes neighboring nodes x,y
# basex <- setdiff(which(mat[x,] != 0), y)
# basey <- setdiff(which(mat[y,] != 0), x)
# all <- union(basex,basey)
#
# ## to determine whether a posDsep link is an actual Dsep link
# ## it is necessarry to go through all the subsets of the sets basex and
# ## basey (since we don't know the parents) and build a hierarchy
# ## for each combination of those subsets
#
# ## since it is complicated to go through all the subets of both basex and basey,
# ## I decided to combine them into one set and go through subsets of that set
# ## but only building a hierarchy using a subset that contatins neighbors of
# ## both x and y
#
# ## bound is the number of neighbors of x and y
# bound <- length(all)
#
# ## flag is an indicator that will be given the value TRUE if
# ## an actual Dsep link is discovered so we can use it to break
# ## from the for cycle and return to the while cycle
# flag <- FALSE
# for(i in seq_len(bound)) {
# if (flag) break
# S <- seq_len(i)
# exit <- FALSE
# while (!exit && !flag)
# {
# a.S <- all[S]
# ## check if there are more than 1 and less than k neighbors of x and y in the subset
# if (1 <= (l.S.bx <- length(intersect(a.S, basex))) && l.S.bx <= i &&
# 1 <= (l.S.by <- length(intersect(a.S, basey))) && l.S.by <= i)
# {
# ## build a hierarchy
# potential <- HIE(union(c(x,y), a.S), sepsets)
# ## remove x and y from the hierarchy
# potential <- setdiff(potential, c(x,y))
#
# ## if this set is actually a separating set it should be added to
# ## the list of sepsets and we should begin the process again (AugmentGraph, PosDsepLink)
# if (indepTest(x,y, potential, suffStat) > alpha)
# {
# ## find the minimal sepset
# mindsep <- MinimalDsep(x,y,potential,suffStat,indepTest)
#
# ## update sepsets
# if (is.null(mindsep)) {
# sepsets[[x]][y] <- list(NULL)
# } else {
# sepsets[[x]][[y]] <- mindsep
# }
#
# ## update matrix by removing the Dsep link
# mat[x,y] <- mat[y,x] <- 0
#
# cat("Found Dsep Link for x=",x,"y=",y,"sepset=",mindsep,"\n")
#
# ## orient invariant arrowheads
# mat <- AugmentGraph(mat,suffStat,sepsets,indepTest)
#
# ## search for new PosDsepLinks
# link <- PosDsepLinks(mat)
#
# ## reset counter and set flag to TRUE
# count <- 1L
# flag <- TRUE
# }
# }
#
# z <- getNextSet(bound, i, S)
# S <- z$nextSet
# exit <- z$wasLast
# } ## while(!exit ..)
# } ## for(i .. )
# ## if we've exited the for cycle and flag is still false it means x-y is not
# ## a Dseplink so we should move on to the next posDseplink
# if (!flag)
# count <- count+1L
# } ## while(count <= ..)
# ## return the adjusted adjacency matrix and sepset
# list(mat = mat, sepset = sepsets)
# } ## {fciplus.intern}
# fciPlus <- function(suffStat, indepTest, alpha, labels, p, verbose=TRUE)
# {
# ## Author: Markus Kalisch, Date: 7 Jul 2014, 12:08
# cl <- match.call()
# if(!missing(p)) stopifnot(is.numeric(p), length(p <- as.integer(p)) == 1, p >= 2)
# if(missing(labels)) {
# ## FIXME ---- make function for this and use in skeleton(), pc(), fci(), ....
# ## if(is.matrix(C <- suffStat[["C"]]) && (d <- dim(C))[1] == d[2]) {
# ## ## we can derive 'p' *and* 'labels' -- in 99% of cases !
# ## p <- d[1]
# ## if(is.null(labels <- colnames(C)))
# ## labels <- as.character(seq_len(p))
# ## } else {
# if(missing(p)) stop("need to specify 'labels' or 'p'")
# labels <- as.character(seq_len(p))
# ## }
# } else { ## use labels ==> p from it
# stopifnot(is.character(labels))
# if(missing(p)) {
# p <- length(labels)
# } else if(p != length(labels))
# stop("'p' is not needed when 'labels' is specified, and must match length(labels)")
# else
# message("No need to specify 'p', when 'labels' is given")
# }
#
# skel <- skeleton(suffStat = suffStat, indepTest = indepTest, alpha = alpha,
# labels = labels, p = p)
# fit1 <- udag2pdagRelaxed(gInput = skel, orientCollider = FALSE)
# fcip <- fciplus.intern(pc.fit = fit1, alpha=alpha, suffStat=suffStat,
# indepTest=indepTest, verbose=verbose)
# fcip$mat <- (fcip$mat != 0) + 0 # forget orientations in augmented graph: FCI orientation rules seem more accurate
# fciplus.amat <- udag2pag(pag = fcip$mat, sepset = fcip$sepset,
# orientCollider = TRUE, verbose = verbose)
# colnames(fciplus.amat) <- rownames(fciplus.amat) <- labels
# new("fciAlgo", amat = fciplus.amat, call = cl, n = integer(0),
# max.ord = integer(0),
# max.ordPDSEP = integer(0),
# n.edgetests = integer(0), n.edgetestsPDSEP = integer(0),
# sepset = list(), pMax = matrix(0,1,1), allPdsep = list())
# } ## {fciPlus}
## MM: Das braucht's ja wirklich nicht; wir haben extra gute summary(.) Methoden,
## wobei ich ja vor allem jene for "fciAlgo" in der (vor)letzten Version schön verbessert habe.
## Ich wollte sowieso vorschlagen, dass pcAlgo für die adj.Matrix "dasselbe" macht wie fciAlgo !
displayAmat <- function(obj) {
## Convert object of class 'fciAlgo' or 'pcAlgo' to
## corresponding adjacency matrix of type 'amat.pag'
## or 'amat.cpdag'
co <- class(obj)
if (co == "fciAlgo") {
amat <- obj@amat
type <- "amat.pag"
} else {
if (co == "pcAlgo") {
type <- "amat.cpdag"
amat <- wgtMatrix(obj@graph)
} else {
stop("showAmat: Class of input is not supported.")
}
}
list(amat = amat, type = type)
}
pdag2allDags <- function(gm, verbose = FALSE) {
nodeNms <- colnames(gm)
p <- ncol(gm)
rownames(gm) <- colnames(gm) <- as.character(1:p)
res <- allDags.internal(gm = gm, a = gm, tmp = NULL, verbose = verbose)
list(dags = res, nodeNms = nodeNms)
}
allDags.internal <- function(gm,a,tmp, verbose = FALSE)
{
## Purpose: Find all DAGs for a given PDAG
## ----------------------------------------------------------------------
## Arguments:
## - gm: Adjacency matrix of initial PDAG of type \code{amat.cpdag}
## - a: copy of gm
## - tmp: "current set of DAGs", initially NULL
## ----------------------------------------------------------------------
## Value:
## - one 0/1 adj.matrix per row
## Reversion to graph: as(matrix(res[i,],p,p),"graphNEL")
## Reversion to wgtMatrix (i->j iff a[j,i]=1): t(matrix(res[i,],p,p))
## ----------------------------------------------------------------------
## Author: Markus Kalisch, Date: 7 Apr 2008, 14:08
if (sum(a) == 0) {
if (verbose) {
cat("Last Call - Final Graph: \n")
print(gm)
cat("#################### \n")
}
tmp2 <- rbind(tmp,c(t(gm)))
if (all(!duplicated(tmp2))) tmp <- tmp2
} else {
sinks <- find.sink(a)
if (verbose) {
cat("Main Call: ################## \n")
print(gm)
print(a)
cat("Sinks: ",sinks,"\n")
}
for(x in sinks) {
if (verbose) cat("Try removing", x," in a.\n")
gm2 <- gm
a2 <- a
if (adj.check(a,x)) {
inc.to.x <- a[, x] == 1 & a[x, ] == 1
if (any(inc.to.x)) {
real.inc.to.x <- as.numeric(rownames(a)[inc.to.x])
real.x <- as.numeric(rownames(a)[x])
gm2[real.x, real.inc.to.x] <- 1
gm2[real.inc.to.x, real.x] <- 0
}
a2 <- a[-x,-x]
if (verbose) {
cat("Removed sink",as.numeric(rownames(a)[x]),
"in g (", x,"in a).\n")
cat("New graphs: \n")
print(gm2)
print(a2)
}
tmp <- allDags.internal(gm2, a2, tmp, verbose)
## ------- *recursively*
}
}
}
tmp
}
## this is taken from the udag2pdag code from pcalg
## since these rules were already implemented there.
## This fucntion, given a graphNEL object, or an adjacency matrix
## just completes orientations under rules R1-R4 from Meek 1995
## note that this function accepts the t(amat.cpdag) encoding that is
## m[i,j]=1,m[j,i]=0 <=> i -> j
## same as udag2pdag
applyOrientationRules <- function(gInput, verbose=FALSE) {
res <- gInput
##new line
if (!is.matrix(gInput))
{
if (numEdges(gInput)>0) {
g <- as(gInput,"matrix") ## g_ij if i->j
p <- as.numeric(dim(g)[1])
pdag <- g
ind <- which(g==1,arr.ind=TRUE)
} else {
cat("Invalid or empty PDAG! This function only accepts graphNEL or adj mat!\n")
return(NULL)
}
} else {
##also new, for me its easier to use an adjacency matrix
if (length(res[1,])>0){
g <- res
p <- length(g[1,])
pdag <- g
ind <- which(g==1,arr.ind=TRUE)
} else {
cat("Invalid or empty PDAG! This function only accepts graphNEL or adj mat!\n")
return(NULL)
}
}
## Convert to complete pattern: use rules by Pearl/Meek also someone else Verma?
old_pdag <- matrix(0, p,p)
while (!all(old_pdag == pdag)) {
old_pdag <- pdag
## rule 1
ind <- which((pdag==1 & t(pdag)==0), arr.ind=TRUE) ## a -> b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[b,]==1 & pdag[,b]==1) & (pdag[a,]==0 & pdag[,a]==0))
if (length(indC)>0) {
pdag[b,indC] <- 1
pdag[indC,b] <- 0
if (verbose)
cat("\nRule 1:",a,"->",b," and ",b,"-",indC,
" where ",a," and ",indC," not connected: ",b,"->",indC,"\n")
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule1")
## rule 2
ind <- which((pdag==1 & t(pdag)==1), arr.ind=TRUE) ## a -> b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[a,]==1 & pdag[,a]==0) & (pdag[,b]==1 & pdag[b,]==0))
if (length(indC)>0) {
pdag[a,b] <- 1
pdag[b,a] <- 0
if (verbose) cat("\nRule 2: Kette ",a,"->",indC,"->",
b,":",a,"->",b,"\n")
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule2")
## rule 3
ind <- which((pdag==1 & t(pdag)==1), arr.ind=TRUE) ## a - b
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[a,]==1 & pdag[,a]==1) & (pdag[,b]==1 & pdag[b,]==0))
if (length(indC)>=2) {
## cat("R3: indC = ",indC,"\n")
g2 <- pdag[indC,indC]
## print(g2)
if (length(g2)<=1) {
g2 <- 0
} else {
diag(g2) <- rep(1,length(indC)) ## no self reference
}
##Bugfix: changed #####
## if (any(g2 == 0)) {
g3 <- g2 + t(g2)
if (any(g3 == 0)) {
###### end of change
## if (any(g2==0)) { ## if two nodes in g2 are not connected
pdag[a,b] <- 1
pdag[b,a] <- 0
if (verbose) cat("\nRule 3:",a,"->",b,"\n")
}
}
}
## x11()
## plot(as(pdag,"graphNEL"), main="After Rule3")
## rule 4
ind <- which((pdag==1 & t(pdag)==1), arr.ind=TRUE) ## a - b
if (length(ind)>0) {
for (i in seq_len(nrow(ind))) {
a <- ind[i,1]
b <- ind[i,2]
indC <- which( (pdag[a,]==1 & pdag[,a]==1) & (pdag[,b]==0 & pdag[b,]==0))
l.indC <- length(indC)
if (l.indC>0) {
found <- FALSE
ic <- 0
while(!found & (ic < l.indC)) {
ic <- ic + 1
c <- indC[ic]
indD <- which( (pdag[c,]==1 & pdag[,c]==0) & (pdag[,b]==1 & pdag[b,]==0))
if (length(indD)>0) {
found <- TRUE
pdag[b,a] = 0
if (verbose) cat("Rule 4 applied \n")
}
}
}
}
}
}
if (!is.matrix(res))
{
res <- as(pdag,"graphNEL")
} else {
res <- pdag
}
return(res)
}
## This function is supposed to add the bg knowledge x -> y to the pdag in gInput
## x and y should be vectors of node LABELS
## gInput can be either the graphNEL object or adjacency matrix
## same encoding as in amat.cpdag above m[i,j]=0, m[j,i]=1 <=> i->j
addBgKnowledge <- function(gInput,x=c(),y=c(),verbose=FALSE, checkInput = TRUE)
{
res <- gInput
##new line
if (!is.matrix(gInput)) {
if (numEdges(gInput)>0) {
g <- t(as(gInput,"matrix")) ## g_ji if i->j
p <- as.numeric(dim(g)[1])
} else {
if (verbose) cat("Invalid or empty PDAG! This function only accepts graphNEL or adj mat\n")
return(NULL)
}
} else {
##for me its easier to use an adjacency matrix
if (length(res[1,])>0) {
g <- res
p <- length(g[1,])
} else {
if (verbose) cat("Invalid or empty PDAG! This function only accepts graphNEL or adj mat\n")
return(NULL)
}
}
pdag <- g
lab <- dimnames(g)[[1]]
## check if input is valid pdag
if( checkInput ) {
if ( !isValidGraph(amat = pdag, type = "pdag") ) {
if (verbose) cat("Input to addBgKnowledge() is not a valid PDAG.\n")
return(NULL)
}
}
##CHANGED!
if (length(x)!=length(y)) {
if (verbose) cat("length of\n",x,"and\n",y,"\nshould be the same!\n")
return(NULL)
}
# }
## real code starts from here
## previously was just dealing w gInput type
##how many new orientations -> k
k <- length(x)
i <- 1
## orient edge by edge
## after adding one orientation complete the orientation rules
##NEW if there are no edges to orient!!
if (k ==0){
pdag <- t(applyOrientationRules(t(pdag),verbose))
if (!is.matrix(res)) {
res <- as(t(pdag),"graphNEL")
} else {
res <- pdag
}
return(res)
}
##NEW: check that the pdag is maximal!
tmp.pdag <- t(applyOrientationRules(t(pdag),verbose))
isMaximal <- (sum(tmp.pdag-pdag)==0)
if (!isMaximal){
if (verbose) cat("Your input pdag is not maximal! You can obtain a maximal pdag by calling: addBgKnowledge(gInput)\n")
return(NULL)
}
while (i <=k)
{
## for each new edge
##find the nodes by the labels
from <- which(lab==x[i])
to <- which(lab==y[i])
##add the orientation if the edge in the current pdag to be undirected
##and complete the orientation rules
if ((pdag[from,to] ==1) & (pdag[to,from] ==1)) {
pdag[from,to] <- 0
if (verbose) cat("Added orientation",x[i],"->",y[i],"to the PDAG.\n")
pdag <- t(applyOrientationRules(t(pdag),verbose)) ##uses different matrix encoding
} else {
## the orientation we want to add conflicts with the current pdag
##either the opposite orientation is present in the current pdag
##or there is no edge between these two nodes in the pdag at all
if ((pdag[from,to] ==1) & (pdag[to,from] ==0)){
if (verbose) cat("Invalid bg knowledge! Cannot add orientation ",x[i],"->",y[i]," because",y[i],"->",x[i],"is already in the PDAG. \n")
return(NULL)
}
if ((pdag[from,to] ==0) & (pdag[to,from] ==0)){
if (verbose) cat("Invalid bg knowledge! Cannot add orientation",x[i],"->",y[i]," because there is no edge between",x[i],"and",y[i],"in the PDAG. \n")
return(NULL)
}
}
i <- i+1
}
if (!is.matrix(res))
{
res <- as(t(pdag),"graphNEL")
} else {
res <- pdag
}
return(res)
}
revealEdge <- function(c,d,s) { ## cpdag, dag, selected edges to reveal
if (all(!is.na(s))) { ## something to reveal
for (i in 1:nrow(s)) {
c[s[i,1], s[i,2]] <- d[s[i,1], s[i,2]]
c[s[i,2], s[i,1]] <- d[s[i,2], s[i,1]]
}
}
c
}
connectedNodes <- function(m,x){
#q denotes unvisited nodes/ nodes in queue
#v denotes visited nodes
q <- v <- rep(0,length(m[,1]))
i <- k <- 1
if(length(x)>1){
cat("Need to do this node by node!\n")
return(NULL)
}
q <- sort(x)
tmp <- m
while(q[k]!=0 & k<=i)
{
t <- q[k]
#mark t as visited
v[k] <- t
k <- k+1
#find all neighbors of t
s <- tmp[t,] + tmp[,t]
neighborss <- which(s!=0)
## if there are neighbors of t
## add the ones not already added
if (length(neighborss)>0){
for(j in 1: length(neighborss))
if (!(neighborss[j] %in% q))
{
i <- i+1
q[i] <- neighborss[j]
}
}
}
## remove all leftover zeros from initialization and x
connectt <-setdiff(v,c(0,x))
return(sort(connectt))
}
adjustb <- function(m,x,y)
{
bpossanx <- bpossany <- c()
for(i in 1:length(x))
{
bpossanx <- union(bpossanx,possAn(m,x[i]))
}
for(j in 1:length(y)){
bpossany <- union(bpossany,possAn(m,y[j]))
}
adjustbb <- union(bpossanx,bpossany)
notbb <- bforbiddenNodes(m, x, y)
notbb <- union(notbb,c(x,y))
adjustbb <- setdiff(adjustbb,notbb)
sort(adjustbb)
}
###-- This *MUST* remain at bottom of file !
###-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
### MM: (ess-set-style 'DEFAULT) : we have much nesting ==> only indent by 2
## Local Variables:
## eval: (ess-set-style 'DEFAULT 'quiet)
## delete-old-versions: never
## End:
Try the pcalg package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.