1 |
graph |
|
y |
|
x |
|
corr |
|
family |
|
na.action |
|
upper |
|
alternative |
|
keep |
|
weight |
|
workspace |
|
formula |
|
data |
|
... |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 | ##---- Should be DIRECTLY executable !! ----
##-- ==> Define data, use random,
##-- or do help(data=index) for the standard data sets.
## The function is currently defined as
function (graph, y = NULL, x = NULL, corr = FALSE, family = NULL,
na.action = NULL, upper = FALSE, alternative = "two.sided",
keep = 0.1, weight = FALSE, workspace = 4e+05, formula = NULL,
data = NULL, ...)
{
checkPckg("MASS")
checkPckg("gamlss.dist")
checkPckg("nnet")
print(alternative)
adj <- sort(unique(c(graph)))
nadj <- length(unique(c(graph)))
if (nadj > 10 & !weight) {
cat("Over 10 labels - running weighted version?\n")
weight <- TRUE
}
if (nadj == 2 & weight) {
cat("Only two labels - using binary classifier\n")
weight <- FALSE
family <- binomial()
}
if ((min(graph) < -1 | max(graph) > 1) && corr) {
corr <- FALSE
cat("corr specified as TRUE, but outside {-1, 1}, not transforming (corr+1)/2\n")
}
if (is.null(family) & !corr) {
cat("No Family Specified, assuming Multinomial\n")
family <- list(family = "multinom")
}
if (weight) {
if (is.character(family)) {
if (!(family %in% c("multinom", "beta"))) {
family <- get(family, mode = "function", envir = parent.frame())
}
else {
family <- list(family = family)
}
}
if (is.function(family))
family <- family()
if (is.null(family$family) & corr) {
cat("No Family Specified and Corr=TRUE, binomial chosen")
family <- binomial()
}
if (is.null(family$family)) {
stop(paste("'family'", "family", "not recognized"))
}
}
print(family)
alternative <- char.expand(alternative, c("two.sided", "less",
"greater"))
if (length(alternative) > 1L || is.na(alternative))
stop("alternative must be \"two.sided\", \"less\" or \"greater\"")
dag <- dim(graph)
cg <- class(graph)
if (cg == "data.frame" & ("y" %in% colnames(graph) & is.null(y))) {
y <- graph$y
which.y <- which(colnames(graph) == "y")
graph <- graph[, -which.y]
}
if (cg == "matrix" && ("y" %in% colnames(graph) & is.null(y))) {
y <- graph[, "y"]
which.y <- which(colnames(graph) == "y")
graph <- graph[, -which.y]
}
graph <- convert.graph(graph, upper = upper)
nullx <- FALSE
form <- !is.null(formula)
if (is.null(y))
stop("No Y input")
if (is.null(x)) {
x <- matrix(rep(1, length(y)), ncol = 1)
nullx <- TRUE
if (form)
stop("No X specified or only intercept")
}
if (any(is.na(x)))
stop("NA not permitted in predictors")
if (any(is.na(graph)))
stop("NA not permitted in graph")
if (any(is.na(y)))
stop("NA not permitted in response")
if (is.null(dim(x)))
dim(x) <- c(length(x), 1)
if (nrow(graph) != nrow(x) | nrow(x) != length(y)) {
stop("Number of graphs does not match N Subjects from X or Y")
}
dy <- dim(y)
cy <- class(y)
if (cy == "matrix")
y <- c(y)
if (!(cy %in% c("matrix", "numeric", "character", "factor",
"integer", "logical")))
stop("Class of Y unrecognized/too big - array")
ngroups <- length(unique(y))
if (ngroups < 2)
stop("Need at least 2 groups")
if (alternative != "two.sided" & ngroups > 2) {
cat("For groups/labels > 2, alternative is two sided\n")
alternative <- "two.sided"
}
if (class(y) != "factor")
y <- factor(y)
levs <- levels(y)
if (ngroups == 2) {
if (class(levs) == "character")
y <- as.numeric(factor(y, levels = levs)) - 1
if (class(levs) == "factor")
y <- as.numeric(y, levels = levs) - 1
if (!all(as.numeric(levs) == c(0, 1)))
stop("Label problems")
}
dg <- dim(graph)
nvert <- dg[2]
nsubj <- dg[1]
if (length(dg) > 2)
stop("Problem with dimensions")
print("in getpvals")
pvals <- apply(graph, 2, function(edge) getpvals(edge, y = y,
workspace = workspace, weight = weight, alternative = alternative))
if (is.function(keep)) {
nkeep <- nvert
pvals <- keep(pvals)/sum(keep(pvals))
}
else nkeep <- floor(nvert * keep)
ssgraph <- graph.ind <- sort(order(pvals)[1:nkeep])
if (cg == "array") {
sig.graph <- matrix(0, nrow = dag[1], ncol = dag[2])
if (upper) {
up.tri <- upper.tri(sig.graph, diag = TRUE)
sig.graph[up.tri][ssgraph] <- 1
}
else sig.graph[ssgraph] <- 1
}
else {
sig.graph <- rep(0, nvert)
sig.graph[ssgraph] <- 1
}
tgraph <- graph
graph <- graph[, ssgraph]
if (corr) {
graph <- (graph + 1)/2
}
print("at get.probs.formula")
print(list(family = family, weight = weight, ngroups = ngroups,
levs = levs, nkeep = nkeep, nsubj = nsubj, corr = corr,
nadj = nadj))
res <- get.probs.formula(graph = graph, x = x, y = y, family = family,
weight = weight, ngroups = ngroups, levs = levs, nkeep = nkeep,
nsubj = nsubj, corr = corr, nadj = nadj, usepvals = is.function(keep),
pvals = pvals)
probs <- res$probs
priors <- res$priors
colnames(probs) <- levs
preds <- apply(probs, 1, function(x) which(x == max(x)))
if (class(preds) != "integer")
stop("Problem with Prediction")
preds <- factor(colnames(probs)[preds], levels = levs)
print(table(preds))
print(table(preds, y))
accuracy <- mean(preds == y)
cat(sprintf("Accuracy is %3.2f%% \n", accuracy * 100))
xlevels <- apply(x, 2, levels)
ret <- list(ssgraph = sig.graph, priors = priors, prob = probs,
predicted = preds, y = y, accuracy = accuracy, pvals = pvals,
usepvals = is.function(keep), graph.models = res$mods,
graph.class = cg, graph.indices = graph.ind, formula = formula,
has.formula = form, xlevels = xlevels, terms = NULL,
x = x, family = family, dens = res$dens, upper = upper,
dg = dg)
class(ret) <- c("sig.sgraph", class(ret))
return(ret)
}
|
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.