# This is a temporary fix
# TODO: remove it when R will solve this problem!
gettextf <- function(fmt, ..., domain = NULL) {
return(sprintf(gettext(fmt, domain = domain), ...))
}
.getPairsIndeces <- function(options) {
pairs <- options[["variablePairs"]]
nPairs <- length(pairs)
allIndeces <- seq_len(nPairs)
for (i in seq_along(pairs)) {
pair <- pairs[[i]]
if ((pair[1] == "" || pair[2] == "") || pair[1] == pair[2]) {
allIndeces <- setdiff(allIndeces, i)
}
}
return(allIndeces)
}
.getCorTableTitle <- function(methodItems, bayes=TRUE) {
if (bayes) {
if (length(methodItems)==1) {
tabTitle <- switch(methodItems,
pearson = gettext("Bayesian Pearson Correlations"),
kendall = gettext("Bayesian Kendall's Tau Correlations"),
spearman = gettext("Bayesian Spearman Correlations")
)
} else {
tabTitle <- gettext("Bayesian Correlation Table")
}
} else {
if (length(methodItems)==1) {
tabTitle <- switch(methodItems,
pearson = gettext("Pearson Correlations"),
kendall = gettext("Kendall's Tau Correlations"),
spearman = gettext("Spearman Correlations")
)
} else {
tabTitle <- gettext("Correlation Table")
}
}
return(tabTitle)
}
.corBayesReadData <- function(dataset, options) {
allVariables <- unlist(options[["variables"]])
if (options[["naAction"]] == "listwise") {
dataset <- .readDataSetToEnd(columns.as.numeric=allVariables, exclude.na.listwise=allVariables)
} else {
dataset <- .readDataSetToEnd(columns.as.numeric=allVariables)
}
return(dataset)
}
# This can be made general for t-tests as well
.getCorPlotItems <- function(options, bayes=TRUE, sumStat=FALSE) {
if (isTRUE(sumStat)) {
plotItems <- c("priorPosteriorPlot", "bfRobustnessPlot")
} else {
plotItems <- c("scatterPlot", "priorPosteriorPlot", "bfSequentialPlot", "bfRobustnessPlot")
if (!options[["scatterPlot"]])
plotItems <- setdiff(plotItems, "scatterPlot")
if (!options[["bfSequentialPlot"]])
plotItems <- setdiff(plotItems, "bfSequentialPlot")
}
if (!options[["priorPosteriorPlot"]])
plotItems <- setdiff(plotItems, "priorPosteriorPlot")
if (!options[["bfRobustnessPlot"]])
plotItems <- setdiff(plotItems, "bfRobustnessPlot")
return(plotItems)
}
.getCorMethods <- function(options) {
methodItems <- c("pearson", "kendall", "spearman")
if (!options[["pearson"]])
methodItems <- setdiff(methodItems, "pearson")
if (!options[["kendall"]])
methodItems <- setdiff(methodItems, "kendall")
if (!options[["spearman"]])
methodItems <- setdiff(methodItems, "spearman")
return(methodItems)
}
.bCorCitationsList <- list("pearson"=c("Ly, A., Verhagen, A. J. & Wagenmakers, E.-J. (2016). Harold Jeffreys's Default Bayes Factor Hypothesis Tests: Explanation, Extension, and Application in Psychology. Journal of Mathematical Psychology, 72, 19-32.",
"Ly, A., Marsman, M., Wagenmakers, E.-J. (2018). Analytic Posteriors for Pearson's Correlation Coefficient. Statistica Neerlandica, 72(1), 4-13."),
"kendall"=c("van Doorn, J.B., Ly, A., Marsman, M. & Wagenmakers, E.-J. (2018). Bayesian Inference for Kendall's Rank Correlation Coefficient. The American Statistician, 72(4), 303-308.",
"van Doorn, J.B., Ly, A., Marsman, M., & Wagenmakers, E.-J. (2019). Bayesian Estimation of Kendall's tau Using a Latent Normal Approach. Statistics and Probability Letters, 145, 268-272."),
"spearman"=c("van Doorn, J.B., Ly, A., Marsman, M. & Wagenmakers, E.-J. (2020). Bayesian Rank-Based Hypothesis Testing for the Rank Sum Test, the Signed Rank Test, and Spearman's rho. Journal of Applied Statistics, 47(16), 2984-3006.")
)
.getCorCitations <- function(methodItems, bayes=TRUE) {
citations <- NULL
if (bayes==TRUE)
citations <- unlist(.bCorCitationsList[methodItems], use.names=FALSE)
if (is.null(citations)){
citations <- ""
}
return(citations)
}
.corMethodNamesList <- list(pearson = gettext("Pearson's r"), spearman = gettext("Spearman's rho"), kendall = gettext("Kendall's tau B"))
.corOverTitlesList <- list(pearson = gettext("Pearson"), spearman = gettext("Spearman"), kendall = gettext("Kendall"))
# TODO(Alexander): ADAPTED from Simon
#
.bCorMarginalDistribution <- function(variable, varName, options, xName = NULL, yName = gettext("Density"),
coord_flip = FALSE, plotRanks=FALSE) {
if (length(variable) < 3)
return(.displayError(errorMessage = gettext("Plotting not possible: Number of observations is < 3")))
if (any(is.infinite(variable)))
return(.displayError(errorMessage = gettext("Plotting not possible: Infinite value(s)")))
if (!options[["pearson"]])
variable <- rank(variable)
p <- .plotMarginalCor(variable = variable, xName = xName, yName = yName)
if(coord_flip){
p <- p + ggplot2::coord_flip() +
ggplot2::theme(axis.ticks.y = ggplot2::element_line(), axis.ticks.x = ggplot2::element_blank(),
axis.text.x = ggplot2::element_blank())
}
return(p)
}
# TODO(Alexander): ADAPTED from Simon
#
.bCorScatter <- function(x, y, xBreaks = NULL, yBreaks = NULL, xName = NULL, yName = NULL,
drawAxes = TRUE, useRanks = FALSE) {
if (useRanks) {
x <- rank(x)
y <- rank(y)
xName <- .addRankToVariableName(xName)
yName <- .addRankToVariableName(yName)
}
# TODO(Alexander): Ask Simon: Why does it return an error if I add drawAxes = drawAxes?
#
.plotScatter(xVar = x, yVar = y, xBreaks = xBreaks, yBreaks = yBreaks, xName = xName, yName = yName)
}
# Stolen from Simon's correlation.R:
#
# - .plotScatter
# .displayError
# .plotMarginalCor
.corGLegendList <- list(pearson = gettext("rho"),
kendall = gettext("tau"),
spearman = gettext("rho[s]")
)
.corXNames <- list(pearson = bquote(paste(.(gettext("Pearson's")), ~rho)),
spearman = bquote(paste(.(gettext("Spearman's")), ~rho[s])),
kendall = bquote(paste(.(gettext("Kendall's")), ~tau))
)
.bCorRowNames <- function(options, itemNames, method=c("pearson", "kendall", "spearman")) {
rowStatName <- list(pearson = gettext("Pearson's r"), kendall = gettext("Kendall's tau"), spearman = gettext("Spearman's rho"))
bfTitle <- .getBfTitle("bfType"=options[["bayesFactorType"]], "alternative"=options[["alternative"]])
allRowNames <- list(n = gettext("n"), bf = bfTitle,
upperCi = gettextf("Upper %s%% CI", options[["ciLevel"]] * 100),
lowerCi = gettextf("Lower %s%% CI", options[["ciLevel"]] * 100))
if (!is.null(method))
allRowNames[["stat"]] <- rowStatName[[method[1]]]
return(allRowNames[itemNames])
}
.addRankToVariableName <- function(name) {
if (is.null(name))
return(NULL)
else
return(gettextf("Ranks of %s", name))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.