Nothing
##
## clusrank: Wilcoxon Rank Tests for Clustered Data
##
## Copyright (C) 2015-2024 Yujing Jiang, Mei-Ling Ting Lee, and Jun Yan
## Copyright (C) 2022-2024 Wenjie Wang
##
## This file is part of the R package clusrank.
##
## The R package clusrank is free software: You can redistribute it and/or
## modify it under the terms of the GNU General Public License as published by
## the Free Software Foundation, either version 3 of the License, or any later
## version (at your option). See the GNU General Public License at
## <https://www.gnu.org/licenses/> for details.
##
## The R package clusrank is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
##
##' Identify clusters
##'
##' This is a special function used in the context of formula
##' used for Wilcoxon sum rank test for clustered data.
##' It identifies the cluster id of observations, and is used
##' on the right hand side of a formula.
##'
##' @param x A numeric variable of cluster id.
##'
##' @details THe function's only action is semantic, to mark
##' a variable as the cluster indicator. If not supplied,
##' will assume no cluster in the data.
##' @return x
##' @seealso \code{\link{clusWilcox.test.formula}}
##'
##' @keywords internal
##' @export
cluster <- function(x) {x}
##' Identify strata.
##'
##' This is a special function used in the context of formula
##' used for Wilcoxon sum rank test for clustered data.
##' It identifies the stratum id of observations, and is used
##' on the right hand side of a formula.
##'
##' @param x A numeric variable of stratum id.
##'
##' @details THe function's only action is semantic, to mark
##' a variable as the stratum indicator. If not supplied,
##' will assume no stratification in the data.
##' @seealso clusWilcox.test.formula
##'
##' @keywords internal
##' @export
stratum <- function(x) {x}
untangle_specials <- function (tt, special, order = 1)
{
spc <- attr(tt, "specials")[[special]]
if (length(spc) == 0)
return(list(vars = character(0), terms = numeric(0)))
facs <- attr(tt, "factors")
fname <- dimnames(facs)
ff <- apply(facs[spc, , drop = FALSE], 2, sum)
list(vars = (fname[[1]])[spc],
terms = seq(ff)[ff & match(attr(tt, "order"), order, nomatch = 0)])
}
extractTerm <- function(term, mf, nobs, paired) {
if (term == "group") {
term.lab <- attr(terms(mf), "term.labels")
term.mf <- term.lab[!grepl("[\\(\\)]", term.lab)]
} else {
term.mf <- attr(attr(mf, "terms"), "specials")[[term]]
}
if (length(term.mf) == 0) {
if (term == "cluster") var <- c(1 : nobs)
if (term == "stratum") var <- rep(1, nobs)
if (term == "group") {
if (!paired) {
stop("group variable is missing")
} else {
var <- NULL
}
}
name <- NULL
} else {
if (term == "group") {
temp <- name <- term.mf
} else {
temp <- untangle_specials(terms(mf), term, 1)
name <- gsub("[\\(\\)]", "",
regmatches(temp$vars,
gregexpr("\\(.*?\\)", temp$vars))[[1]])
temp <- temp$vars
}
name <- paste0(" ", term, ": ", name, ";")
if (length(temp) == 1) {
keep <- mf[[temp]]
if (is.null(keep)) {
stop(paste(term, "is missing from the data"))
}
} else {
stop(paste("more than one variable are set as the",
term, "id"))
}
uniq <- unique(keep)
uniq.l <- length(uniq)
if ((term == "group") & (uniq.l == 1)) {
stop("group must contain at least two levels")
}
var <- keep
if (is.numeric(uniq) | is.character(uniq)) {
var <- keep
if (is.character(uniq)) var <- recoderFunc(keep, uniq, c(1 : uniq.l))
} else {
stop(paste(term, "id should be numeric or character"))
}
}
return(list(name = name, var = var))
}
extractVar <- function(var, pars, data) {
if (!is.null(pars[[var]])) {
return(data[, as.character(pars[[var]])])
}
}
extractName <- function(var, pars) {
if (!is.null(pars[[var]])) {
if (var == "y") {
return(paste0(" and ", pars[[var]], ";"))
} else {
if (var == "x") return(paste0(pars[[var]], ";"))
return(paste0(" ", var, ": ", pars[[var]], ";"))
}
} else {
return(NULL)
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.