View source: R/bin_true_initial.R
1 | bin_true_initial(variable, testdata, top_pm = 50, method = "kruskal", goodtype = "goodpvname")
|
variable |
|
testdata |
|
top_pm |
|
method |
|
goodtype |
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 | ##---- 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 (variable, testdata, top_pm = 50, method = "kruskal",
goodtype = "goodpvname")
{
response <- testdata[[variable]]
levs <- unique(response)
if (length(levs) != 2) {
stop("The variable does not have two levels.")
}
else {
position0 <- grep(levs[1], response)
position1 <- grep(levs[2], response)
fliplen <- min(length(position0), length(position1))
N <- fliplen + 1
n1 <- length(position0)
n2 <- length(position1)
testlevel <- testdata
testlevel[[variable]] <- NULL
n <- round((N + 1)/2)
group <- factor(response)
if (method == "kruskal") {
otu.test <- apply(testlevel, 2, function(x) {
kt <- kruskal.test(x = x, g = group)
return(data.frame(pv = kt$p.value, es = kt$statistic/sqrt(n1^2 +
n2^2)))
})
otu.test <- do.call(rbind, otu.test)
}
else if (method == "wilcox") {
otu.test <- apply(testlevel, 2, function(x) {
options(warn = -1)
wt <- wilcox.test(x ~ group)
return(data.frame(pv = wt$p.value, es = wt$statistic/sqrt(n1^2 +
n2^2)))
})
otu.test <- do.call(rbind, otu.test)
}
else {
stop("Set up method either as 'kruskal' or 'wilcox'!")
}
select <- switch(goodtype, goodpvname = order(otu.test$pv)[1:top_pm],
goodesname = order(abs(otu.test$es))[1:top_pm], stop("goodtype must be one of the follows: 'goodpvname' and 'goodesname'. "))
selname <- row.names(otu.test)[select]
}
return(list(select = select, selname = selname, position0 = position0,
position1 = position1, levs = levs, testlevel = testlevel,
n = n, N = N, otu.test = otu.test))
}
|
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.