R/test-correlationTest.R

In fBasics: Rmetrics - Markets and Basic Statistics

# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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. See the
# GNU Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA  02111-1307  USA


################################################################################
# FUNCTION:             DESCRIPTION:
#  correlationTest       Performs correlation tests on two samples
#  pearsonTest           Pearson product moment correlation coefficient
#  kendallTest           Kendall's tau correlation test
#  spearmanTest          Spearman's rho correlation test
################################################################################

## GNB: changed the default 'description = date()' to 'description = ""', to
##      avoid getting different objects in repeated calls.

correlationTest <-
function(x, y, method = c("pearson", "kendall", "spearman"),
    title = NULL, description = NULL)
{
    # A function implemented by Diethelm Wuertz

    # Description:
    #   Performs Correlation Tests

    # FUNCTION:

    # Test:
    method = match.arg(method)
    if (method[1] == "pearson") {
        ans = pearsonTest(x, y, title = title, description = description)
    }
    if (method[1] == "kendall") {
        ans = kendallTest(x, y, title = title, description = description)
    }
    if (method[1] == "spearman") {
       ans = spearmanTest(x, y, title = title, description = description)
    }

    # Return Value:
    ans
}


# ------------------------------------------------------------------------------


pearsonTest <-
function(x, y, title = NULL, description = NULL)
{
    # A function implemented by Diethelm Wuertz

    # Description:
    #   A test for association between paired samples

    # Arguments:
    #   x - a numeric vector of data values.
    #   description - a brief description of the project of type
    #       character.
    #   title - a character string which allows for a project title.

    # Note:
    #   A function linked to "stats"

    # FUNCTION:

    # Call:
    call = match.call()

    # Test:
    test = list()

    # Data Set Name:
    DNAME = paste(deparse(substitute(x)), "and", deparse(substitute(y)))
    test$data.name = DNAME

    # Convert Type:
    x = as.vector(x)
    y = as.vector(y)
    stopifnot(length(x) == length(y))

    # Test:
    two.sided = cor.test(x = x, y = y, alternative = "two.sided",
        method = "pearson")
    less = cor.test(x = x, y = y, alternative = "less",
        method = "pearson")
    greater = cor.test(x = x, y = y, alternative = "greater",
        method = "pearson")

    # Sample Estimates:
    ESTIMATE = two.sided$estimate
    names(ESTIMATE) = "Correlation"
    test$estimate = ESTIMATE

    # Parameter
    DF = two.sided$parameter
    names(DF) = "Degrees of Freedom"
    test$parameter = DF

    # P Values:
    PVAL = c(
        two.sided$p.value,
        less$p.value,
        greater$p.value)
    names(PVAL) = c(
        "Alternative Two-Sided",
        "Alternative      Less",
        "Alternative   Greater")
    test$p.value = PVAL

    # Confidences Levels:
    if (!is.null(two.sided$conf.int)) {
        CONF.INT = cbind(
            a = two.sided$conf.int,
            b = less$conf.int,
            c = greater$conf.int)
        dimnames(CONF.INT)[[2]] = c(
            "Two-Sided",
            "     Less",
            "  Greater")
        test$conf.int = CONF.INT
    }

    # Statistic:
    STATISTIC = two.sided$statistic
    names(STATISTIC) = "t"
    test$statistic = STATISTIC

    # Add:
    if (is.null(title)) title = "Pearson's Correlation Test"
    if (is.null(description)) description = ""

    # Return Value:
    new("fHTEST",
        call = call,
        data = list(x = x, y = y),
        test = test,
        title = as.character(title),
        description = as.character(description) )
}


# ------------------------------------------------------------------------------


kendallTest <-
function(x, y, title = NULL, description = NULL)
{
    # A function implemented by Diethelm Wuertz

    # Description:
    #   A test for association between paired samples

    # Arguments:
    #   x - a numeric vector of data values.
    #   description - a brief description of the project of type
    #       character.
    #   title - a character string which allows for a project title.

    # Note:
    #   A function linked to "stats"

    # FUNCTION:

    # Call:
    call = match.call()

    # Test:
    test = list()

    # Data Set Name:
    DNAME = paste(deparse(substitute(x)), "and", deparse(substitute(y)))
    test$data.name = DNAME

    # Convert Type:
    x = as.vector(x)
    y = as.vector(y)
    stopifnot(length(x) == length(y))

    # Test:
    two.sided = cor.test(x = x, y = y, alternative = "two.sided",
        method = "kendall")
    less = cor.test(x = x, y = y, alternative = "less",
        method = "kendall")
    greater = cor.test(x = x, y = y, alternative = "greater",
        method = "kendall")

    # Exact Test:
    if (!inherits(version, "Sversion")) {
        two.sided.exact = cor.test(x = x, y = y, exact = TRUE,
            alternative = "two.sided",  method = "kendall")
        less.exact = cor.test(x = x, y = y, exact = TRUE,
            alternative = "less", method = "kendall")
        greater.exact = cor.test(x = x, y = y, exact = TRUE,
            alternative = "greater",  method = "kendall")
    } else {
        two.sided.exact = list()
        two.sided.exact$p.value = two.sided.exact$statistic = NA
        less.exact = list()
        less.exact$p.value = less.exact$statistic = NA
        greater.exact = list()
        greater.exact$p.value = greater.exact$statistic = NA
    }

    # Sample Estimates:
    ESTIMATE = two.sided$estimate
    names(ESTIMATE) = "tau"
    test$estimate = ESTIMATE

    # P Values:
    PVAL = c(
        two.sided$p.value,
        two.sided.exact$p.value,
        less$p.value,
        less.exact$p.value,
        greater$p.value,
        greater.exact$p.value)
    if (is.na(two.sided.exact$p.value)) {
        names(PVAL) = c(
            "Alternative Two-Sided",
            "Alternative Two-Sided | Exact",
            "Alternative      Less",
            "Alternative      Less | Exact",
            "Alternative   Greater",
            "Alternative   Greater | Exact")
    } else {
        names(PVAL) = c(
            "Alternative         Two-Sided",
            "Alternative Two-Sided | Exact",
            "Alternative              Less",
            "Alternative      Less | Exact",
            "Alternative           Greater",
            "Alternative   Greater | Exact")
    }
    test$p.value = PVAL

    # Statistic:
    # STATISTIC = c(
    #   two.sided$statistic, two.sided.exact$statistic,
    #   less$statistic, less.exact$statistic,
    #   greater$statistic, greater.exact$statistic)
    STATISTIC = c(
        two.sided$statistic,
        two.sided.exact$statistic)
    # names(STATISTIC) = c(
    #   "z | Two-Sided", "T | Two-Sided | Exact",
    #   "z | Less", "T | Less | Exact",
    #   "z | Greater", "T | Greater | Exact")
    names(STATISTIC) = c(
        "z",
        "T | Exact")
    test$statistic = STATISTIC

    # Add:
    if (is.null(title)) title = "Kendall's tau Correlation Test"
    if (is.null(description)) description = ""

    # Return Value:
    new("fHTEST",
        call = call,
        data = list(x = x, y = y),
        test = test,
        title = as.character(title),
        description = as.character(description) )
}


# ------------------------------------------------------------------------------


spearmanTest <-
function(x, y, title = NULL, description = NULL)
{
    # A function implemented by Diethelm Wuertz

    # Description:
    #   A test for association between paired samples

    # Arguments:
    #   x - a numeric vector of data values.
    #   description - a brief description of the project of type
    #       character.
    #   title - a character string which allows for a project title.

    # Note:
    #   # A function linked to "stats"

    # FUNCTION:

    # Call:
    call = match.call()

    # Test:
    test = list()

    # Data Set Name:
    DNAME = paste(deparse(substitute(x)), "and", deparse(substitute(y)))
    test$data.name = DNAME

    # Convert Type:
    x = as.vector(x)
    y = as.vector(y)
    stopifnot(length(x) == length(y))

    # Test:
    two.sided = cor.test(x = x, y = y, alternative = "two.sided",
        method = "spearman")
    less = cor.test(x = x, y = y, alternative = "less",
        method = "spearman")
    greater = cor.test(x = x, y = y, alternative = "greater",
        method = "spearman")

    # Sample Estimates:
    ESTIMATE = two.sided$estimate
    names(ESTIMATE) = "rho"
    test$estimate = ESTIMATE

    # P Values:
    PVAL = c(
        two.sided$p.value,
        less$p.value,
        greater$p.value)
    names(PVAL) = c(
        "Alternative Two-Sided",
        "Alternative      Less",
        "Alternative   Greater")
    test$p.value = PVAL

    # Statistic:
    STATISTIC = two.sided$statistic
    names(STATISTIC) = "S"
    test$statistic = STATISTIC

    # Add:
    if (is.null(title)) title = "Spearman's rho Correlation Test"
    if (is.null(description)) description = ""

    # Return Value:
    new("fHTEST",
        call = call,
        data = list(x = x, y = y),
        test = test,
        title = as.character(title),
        description = as.character(description) )
}


################################################################################