R/proximity.h.R

In sjentsch/clusterParty: Partial correlation and proximity measures

# This file is automatically generated, you probably don't want to edit this

proximityOptions <- if (requireNamespace('jmvcore')) R6::R6Class(
    "proximityOptions",
    inherit = jmvcore::Options,
    public = list(
        initialize = function(
            vars = NULL,
            label = NULL,
            disSim = "clcDis",
            lvlMsr = "lvlInt",
            btwDir = "btwSbj",
            intDis = "intEuc",
            intSim = "intCrr",
            intPwr = 2,
            intRot = 2,
            cntDis = "cntChi",
            binDis = "binEuc",
            binSim = "binRnR",
            binPrs = 1,
            binAbs = 0,
            xfmMth = "xfmNon",
            xfmDir = "xfmVar",
            xfmAbs = FALSE,
            xfmInv = FALSE,
            xfmRsc = FALSE, ...) {

            super$initialize(
                package='PartialProximity',
                name='proximity',
                requiresData=TRUE,
                ...)

            private$..vars <- jmvcore::OptionVariables$new(
                "vars",
                vars,
                suggested=list(
                    "continuous"),
                permitted=list(
                    "numeric"))
            private$..label <- jmvcore::OptionVariable$new(
                "label",
                label,
                suggested=list(
                    "nominal",
                    "id"),
                permitted=list(
                    "factor",
                    "id"))
            private$..disSim <- jmvcore::OptionList$new(
                "disSim",
                disSim,
                options=list(
                    "clcDis",
                    "clcSim"),
                default="clcDis")
            private$..lvlMsr <- jmvcore::OptionList$new(
                "lvlMsr",
                lvlMsr,
                options=list(
                    "lvlInt",
                    "lvlCnt",
                    "lvlBin"),
                default="lvlInt")
            private$..btwDir <- jmvcore::OptionList$new(
                "btwDir",
                btwDir,
                options=list(
                    "btwSbj",
                    "btwVar"),
                default="btwSbj")
            private$..intDis <- jmvcore::OptionList$new(
                "intDis",
                intDis,
                options=list(
                    "intEuc",
                    "intSqE",
                    "intChb",
                    "intBlk",
                    "intMnk",
                    "intCst"),
                default="intEuc")
            private$..intSim <- jmvcore::OptionList$new(
                "intSim",
                intSim,
                options=list(
                    "intCrr",
                    "intCos"),
                default="intCrr")
            private$..intPwr <- jmvcore::OptionInteger$new(
                "intPwr",
                intPwr,
                default=2,
                min=1,
                max=4)
            private$..intRot <- jmvcore::OptionInteger$new(
                "intRot",
                intRot,
                default=2,
                min=1,
                max=4)
            private$..cntDis <- jmvcore::OptionList$new(
                "cntDis",
                cntDis,
                options=list(
                    "cntChi",
                    "cntPhi"),
                default="cntChi")
            private$..binDis <- jmvcore::OptionList$new(
                "binDis",
                binDis,
                options=list(
                    "binEuc",
                    "binSqE",
                    "binSzD",
                    "binPtD",
                    "binVar",
                    "binShp",
                    "binLnW"),
                default="binEuc")
            private$..binSim <- jmvcore::OptionList$new(
                "binSim",
                binSim,
                options=list(
                    "binRnR",
                    "binSmM",
                    "binJcc",
                    "binDic",
                    "binRnT",
                    "binSk1",
                    "binSk2",
                    "binSk3",
                    "binKc1",
                    "binKc2",
                    "binSk4",
                    "binHmn",
                    "binLmb",
                    "binAnD",
                    "binYlY",
                    "binYlQ",
                    "binOch",
                    "binSk5",
                    "binPh4",
                    "binDsp"),
                default="binRnR")
            private$..binPrs <- jmvcore::OptionNumber$new(
                "binPrs",
                binPrs,
                default=1)
            private$..binAbs <- jmvcore::OptionNumber$new(
                "binAbs",
                binAbs,
                default=0)
            private$..xfmMth <- jmvcore::OptionList$new(
                "xfmMth",
                xfmMth,
                options=list(
                    "xfmNon",
                    "xfmZsc",
                    "xfmRNP",
                    "xfmRZP",
                    "xfmMag",
                    "xfmAvr",
                    "xfmStd"),
                default="xfmNon")
            private$..xfmDir <- jmvcore::OptionList$new(
                "xfmDir",
                xfmDir,
                options=list(
                    "xfmVar",
                    "xfmSbj"),
                default="xfmVar")
            private$..xfmAbs <- jmvcore::OptionBool$new(
                "xfmAbs",
                xfmAbs,
                default=FALSE)
            private$..xfmInv <- jmvcore::OptionBool$new(
                "xfmInv",
                xfmInv,
                default=FALSE)
            private$..xfmRsc <- jmvcore::OptionBool$new(
                "xfmRsc",
                xfmRsc,
                default=FALSE)

            self$.addOption(private$..vars)
            self$.addOption(private$..label)
            self$.addOption(private$..disSim)
            self$.addOption(private$..lvlMsr)
            self$.addOption(private$..btwDir)
            self$.addOption(private$..intDis)
            self$.addOption(private$..intSim)
            self$.addOption(private$..intPwr)
            self$.addOption(private$..intRot)
            self$.addOption(private$..cntDis)
            self$.addOption(private$..binDis)
            self$.addOption(private$..binSim)
            self$.addOption(private$..binPrs)
            self$.addOption(private$..binAbs)
            self$.addOption(private$..xfmMth)
            self$.addOption(private$..xfmDir)
            self$.addOption(private$..xfmAbs)
            self$.addOption(private$..xfmInv)
            self$.addOption(private$..xfmRsc)
        }),
    active = list(
        vars = function() private$..vars$value,
        label = function() private$..label$value,
        disSim = function() private$..disSim$value,
        lvlMsr = function() private$..lvlMsr$value,
        btwDir = function() private$..btwDir$value,
        intDis = function() private$..intDis$value,
        intSim = function() private$..intSim$value,
        intPwr = function() private$..intPwr$value,
        intRot = function() private$..intRot$value,
        cntDis = function() private$..cntDis$value,
        binDis = function() private$..binDis$value,
        binSim = function() private$..binSim$value,
        binPrs = function() private$..binPrs$value,
        binAbs = function() private$..binAbs$value,
        xfmMth = function() private$..xfmMth$value,
        xfmDir = function() private$..xfmDir$value,
        xfmAbs = function() private$..xfmAbs$value,
        xfmInv = function() private$..xfmInv$value,
        xfmRsc = function() private$..xfmRsc$value),
    private = list(
        ..vars = NA,
        ..label = NA,
        ..disSim = NA,
        ..lvlMsr = NA,
        ..btwDir = NA,
        ..intDis = NA,
        ..intSim = NA,
        ..intPwr = NA,
        ..intRot = NA,
        ..cntDis = NA,
        ..binDis = NA,
        ..binSim = NA,
        ..binPrs = NA,
        ..binAbs = NA,
        ..xfmMth = NA,
        ..xfmDir = NA,
        ..xfmAbs = NA,
        ..xfmInv = NA,
        ..xfmRsc = NA)
)

proximityResults <- if (requireNamespace('jmvcore')) R6::R6Class(
    inherit = jmvcore::Group,
    active = list(
        txtPfm = function() private$.items[["txtPfm"]],
        mtxSbj = function() private$.items[["mtxSbj"]],
        mtxVar = function() private$.items[["mtxVar"]]),
    private = list(),
    public=list(
        initialize=function(options) {
            super$initialize(
                options=options,
                name="",
                title="Distances")
            self$add(jmvcore::Preformatted$new(
                options=options,
                name="txtPfm",
                title="Proximity Measures"))
            self$add(jmvcore::Table$new(
                options=options,
                name="mtxSbj",
                title="Proximity Measures",
                rows=0,
                clearWith=list(
                    "shwSig",
                    "sidSig"),
                columns=list(
                    list(
                        `name`=".name", 
                        `title`="", 
                        `type`="text"))))
            self$add(jmvcore::Table$new(
                options=options,
                name="mtxVar",
                title="Proximity Measures",
                rows="(vars)",
                clearWith=list(
                    "shwSig",
                    "sidSig"),
                columns=list(
                    list(
                        `name`=".name", 
                        `title`="", 
                        `type`="text", 
                        `content`="($key)"))))}))

proximityBase <- if (requireNamespace('jmvcore')) R6::R6Class(
    "proximityBase",
    inherit = jmvcore::Analysis,
    public = list(
        initialize = function(options, data=NULL, datasetId="", analysisId="", revision=0) {
            super$initialize(
                package = 'PartialProximity',
                name = 'proximity',
                version = c(1,0,0),
                options = options,
                results = proximityResults$new(options=options),
                data = data,
                datasetId = datasetId,
                analysisId = analysisId,
                revision = revision,
                pause = NULL,
                completeWhenFilled = FALSE)
        }))

#' Distances
#'
#' 
#' @param data .
#' @param vars .
#' @param label .
#' @param disSim .
#' @param lvlMsr .
#' @param btwDir .
#' @param intDis .
#' @param intSim .
#' @param intPwr .
#' @param intRot .
#' @param cntDis .
#' @param binDis .
#' @param binSim .
#' @param binPrs .
#' @param binAbs .
#' @param xfmMth .
#' @param xfmDir .
#' @param xfmAbs .
#' @param xfmInv .
#' @param xfmRsc .
#' @return A results object containing:
#' \tabular{llllll}{
#'   \code{results$txtPfm} \tab \tab \tab \tab \tab a preformatted \cr
#'   \code{results$mtxSbj} \tab \tab \tab \tab \tab Matrix table with proximity measures \cr
#'   \code{results$mtxVar} \tab \tab \tab \tab \tab Matrix table with proximity measures \cr
#' }
#'
#' Tables can be converted to data frames with \code{asDF} or \code{\link{as.data.frame}}. For example:
#'
#' \code{results$mtxSbj$asDF}
#'
#' \code{as.data.frame(results$mtxSbj)}
#'
#' @export
proximity <- function(
    data,
    vars,
    label,
    disSim = "clcDis",
    lvlMsr = "lvlInt",
    btwDir = "btwSbj",
    intDis = "intEuc",
    intSim = "intCrr",
    intPwr = 2,
    intRot = 2,
    cntDis = "cntChi",
    binDis = "binEuc",
    binSim = "binRnR",
    binPrs = 1,
    binAbs = 0,
    xfmMth = "xfmNon",
    xfmDir = "xfmVar",
    xfmAbs = FALSE,
    xfmInv = FALSE,
    xfmRsc = FALSE) {

    if ( ! requireNamespace('jmvcore'))
        stop('proximity requires jmvcore to be installed (restart may be required)')

    if ( ! missing(vars)) vars <- jmvcore::resolveQuo(jmvcore::enquo(vars))
    if ( ! missing(label)) label <- jmvcore::resolveQuo(jmvcore::enquo(label))
    if (missing(data))
        data <- jmvcore::marshalData(
            parent.frame(),
            `if`( ! missing(vars), vars, NULL),
            `if`( ! missing(label), label, NULL))


    options <- proximityOptions$new(
        vars = vars,
        label = label,
        disSim = disSim,
        lvlMsr = lvlMsr,
        btwDir = btwDir,
        intDis = intDis,
        intSim = intSim,
        intPwr = intPwr,
        intRot = intRot,
        cntDis = cntDis,
        binDis = binDis,
        binSim = binSim,
        binPrs = binPrs,
        binAbs = binAbs,
        xfmMth = xfmMth,
        xfmDir = xfmDir,
        xfmAbs = xfmAbs,
        xfmInv = xfmInv,
        xfmRsc = xfmRsc)

    analysis <- proximityClass$new(
        options = options,
        data = data)

    analysis$run()

    analysis$results
}