R/print.R

Defines functions print.panel print.chain

# Copyright (c) 2018, Adrian Dusa
# All rights reserved.
# 
# Redistribution and use in source and binary forms, with or without
# modification, in whole or in part, are permitted provided that the
# following conditions are met:
#     * Redistributions of source code must retain the above copyright
#       notice, this list of conditions and the following disclaimer.
#     * Redistributions in binary form must reproduce the above copyright
#       notice, this list of conditions and the following disclaimer in the
#       documentation and/or other materials provided with the distribution.
#     * The names of its contributors may NOT be used to endorse or promote products
#       derived from this software without specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
# DISCLAIMED. IN NO EVENT SHALL ADRIAN DUSA BE LIABLE FOR ANY
# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

`print.translate` <-
function(x, ...) {
    other.args <- list(...)
    cat("\n")
    original <- FALSE
    y <- matrix(as.vector(x), nrow=nrow(x))
    if ("original" %in% names(other.args)) {
        if (is.logical(other.args$original)) {
            original <- other.args$original[1]
        }
    }
    cols <- colnames(x)
    colnames(y) <- cols
    if (original) {
        minus <- any(y < 0)
        if (minus) {
            y[y >= 0] <- paste("", y[y >= 0])
            cols[nchar(cols) == 1] <- paste("", cols[nchar(cols) == 1])
            colnames(y) <- cols
        }
    }
    else {
        y[x < 0] <- ""
    }
    rownames(y) <- paste(rownames(x), " ")
    print(prettyTable(y))
    cat("\n")
}
`print.tt` <-
function(x, ...) {
    other.args <- list(...)
    enter <- ifelse (is.element("enter", names(as.list(x$call))), as.list(x$call)$enter, TRUE)
    PRI <- TRUE
    if (!is.null(x$rowsorder)) {
        x$tt <- x$tt[x$rowsorder, ]
    }
    complete <- x$options$complete
    if ("complete" %in% names(other.args)) {
        if (is.logical(other.args$complete)) {
            complete <- other.args$complete[1]
        }
    }
    show.cases <- x$options$show.cases
    if ("show.cases" %in% names(other.args)) {
        if (is.logical(other.args$show.cases)) {
            show.cases <- other.args$show.cases[1]
        }
    }
    if (!complete) {
        if (!is.element("excluded", names(x$options))) {
            x$tt <- x$tt[x$tt$OUT != "?", , drop = FALSE]
        }
    }
    if (show.cases) {
        if (x$options$dcc) {
            x$tt$cases <- ""
            x$tt[names(x$DCC), "cases"] <- x$DCC
            colnames(x$tt)[colnames(x$tt) == "cases"] <- "DCC"
        }
    }
    else {
        x$tt$cases <- NULL
    }
    if (nrow(x$tt) > 1024) {
        if (enter) cat("\n")
        cat(paste("Warning: The truth table is too large (", nrow(x$tt), " rows). ",
                  "Printing it on the screen is impractical.\n         ",
                  "N.B.: You can still use its internal components (see ?str).", "\n\n", sep=""))
    }
    else {
        rownames(x$tt) <- paste(format(as.numeric(rownames(x$tt))), "")
        nofconditions <- length(x$noflevels)
        names.mydata <- colnames(x$recoded.data)[seq(nofconditions + 1)]
        if (!is.element("excluded", names(x$options))) {
            if (enter) cat("\n")
            if (!all(names(x$tt)[seq(nofconditions)] %in% names(x$recoded.data)[seq(nofconditions)])) {
                for (i in seq(nofconditions)) {
                    cat("    ", paste(names(x$tt)[i], ": ", sep=""), names.mydata[i], "\n", sep="")
                }
            }
        }
        x$tt[, "n"] <- paste(" ", x$tt[, "n"], "")
        colnames(x$tt)[colnames(x$tt) == "n"] <- "  n "
        inclusion <- x$tt[, "incl"]
        missincl <- x$tt[, "incl"] == "-"
        x$tt[!missincl, "incl"] <- formatC(as.numeric(inclusion[!missincl]), digits=3, format="f")
        whichpri <- which(colnames(x$tt) == "PRI")
        if (PRI) {
            pri <- x$tt[, whichpri[length(whichpri)]]
            misspri <- x$tt[, whichpri[length(whichpri)]] == "-"
            x$tt[!misspri, whichpri[length(whichpri)]] <- formatC(as.numeric(pri[!misspri]), digits=3, format="f")
        }
        else {
            x$tt[, whichpri[length(whichpri)]] <- NULL 
        }
        if (any(names(x$tt) == "pval1")) {
            x$tt[x$tt[, "pval1"] != "-", "pval1"] <- formatC(as.numeric(x$tt[x$tt[, "pval1"] != "-", "pval1"]), digits=3, format="f")
            if (length(x$options$incl.cut) > 1) {
                x$tt[x$tt[, "pval0"] != "-", "pval0"] <- formatC(as.numeric(x$tt[x$tt[, "pval0"] != "-", "pval0"]), digits=3, format="f")
            }
        }
        if (any(missincl)) {
            x$tt[missincl, "incl"] <- "  -"
        }
        if (PRI) {
            if (any(misspri)) {
                x$tt[misspri, "PRI"] <- "  -"
            }
        }
        if (!is.element("excluded", names(x$options))) {
            cat("  OUT: output value\n")
            cat("    n: number of cases in configuration\n")
            cat(" incl: sufficiency inclusion score\n")
            cat("  PRI: proportional reduction in inconsistency\n")
            if (show.cases & x$options$dcc) {
                cat("  DCC: deviant cases consistency\n")
            }
            if (any(names(x$tt) == "pval1")) {
                cat(paste("pval1: p-value for alternative hypothesis inclusion > ", x$options$incl.cut[1], "\n", sep=""))
                if (length(x$options$incl.cut) > 1) {
                    cat(paste("pval0: p-value for alternative hypothesis inclusion > ", x$options$incl.cut[2], "\n", sep=""))
                }
            }
            cat("\n")
        }
        alloutzero <- all(x$tt$OUT == 0)
        x$tt[, "OUT"] <- paste(" ", x$tt[, "OUT"], "")
        colnames(x$tt)[colnames(x$tt) == "OUT"] <- "  OUT "
        print(prettyTable(x$tt))
        if (alloutzero) {
            if (enter) cat("\n")
            cat(paste("It seems that all outcome values have been coded to zero.",
                      "Suggestion: lower the inclusion score for the presence of the outcome,", 
                      sprintf("the relevant argument is \"incl.cut\" which now has a value of %s.\n", x$options$incl.cut[1]), sep="\n"))
        }
        if (enter) cat("\n")
    }
}
`print.pic` <-
function(x, ...) {
    if (all(dim(x) > 0)) {
        rownms  <- rownames(x)
        colnms  <- colnames(x)
        x2 <- matrix(as.vector(x), nrow = nrow(x))
        rownames(x2) <- paste(rownms, "")
        colnames(x2) <- format(colnms, width = 2)
        x2[as.vector(x)]  <- "x"
        x2[!as.vector(x)] <- "-"
        x <- x2
    }
    cat("\n")
    print(prettyTable(x))
    cat("\n")
}
`print.fuzzy` <-
function(x, ...) {
    attr(x, "name") <- NULL
    print(unclass(x))
    cat("\n")
}
`print.qca` <-                                                      
function(x, ...) {
    enter <- ifelse (is.element("enter", names(as.list(x$call))), as.list(x$call)$enter, TRUE)
    line.length <- getOption("width")
    if (any(names(x) == "via.web")) {
        line.length <- 10000
    }
    other.args <- list(...)
    details <- x$options$details
    mqca <- FALSE
    if ("mqca" %in% names(other.args)) {
        if (is.logical(other.args$mqca)) {
            mqca <- other.args$mqca
        }
    }
    sol.cons <- x$options$sol.cons
    sol.cov  <- x$options$sol.cov
    outcome <- x$tt$options$outcome
    if (grepl("\\{|\\}", outcome)) {
        if (x$options$neg.out) {
            outcome <- paste("~", notilde(toupper(outcome)), sep = "")
        }
        if (any(x$options$explain != 1)) {
            outcome <- ""
        }
    }
    else {
        if (x$options$neg.out) {
            if (x$options$use.tilde) {
                outcome <- paste("~", notilde(toupper(outcome)), sep = "")
            }
            else {
                outcome <- notilde(tolower(outcome))
            }
        }
    }
    if ("show.cases" %in% names(other.args)) {
        if (is.logical(other.args$show.cases)) {
            x$options$show.cases <- other.args$show.cases
        }
    }
    if (!x$options$show.cases) {
        if ("cases" %in% names(x$IC$incl.cov)) {
            x$IC$incl.cov$cases <- NULL
        }
    }
    PRI <- TRUE
    if ("details" %in% names(other.args)) {
        if (is.logical(other.args$details)) {
            details <- other.args$details
            x$options$print.truth.table <- details
            x$options$details <- details
        }
    }
    if (x$options$print.truth.table) {
        print.tt(x$tt, PRI=PRI)
    }
    else {
        nofconditions <- length(x$tt$noflevels)
        if (!all(names(x$tt$tt)[seq(nofconditions)] %in% names(x$tt$recoded.data)[seq(nofconditions)]) & x$options$use.letters) {
            if (enter) cat("\n")
            names.mydata <- colnames(x$tt$recoded.data)[seq(nofconditions + 1)]
            for (i in seq(nofconditions)) {
                cat("    ", paste(names(x$tt$tt)[i], ": ", sep=""), names.mydata[i], "\n", sep="")
            }
        }
    }
    if (details) {
        if (!x$options$print.truth.table & enter) cat("\n")
        cat("n OUT = 1/0/C:", paste(x$numbers[1:3], collapse="/"), "\n")
        cat("  Total      :", x$numbers[4], "\n")
    }
    if (!mqca & enter) {
        cat("\n")
    }
    if (is.element("i.sol", names(x))) {
        sufnec <- logical(length(x$i.sol))
        for (i in seq(length(x$i.sol))) {
            if ("overall" %in% names(x$i.sol[[i]]$IC)) {
                sufnec[i] <- agteb(x$i.sol[[i]]$IC$overall$sol.incl.cov[3], sol.cov)
            }
            else {
                sufnec[i] <- agteb(x$i.sol[[i]]$IC$sol.incl.cov[3], sol.cov)
            }
        }
        sufnec.char <- rep("", length(sufnec))
        uniques <- unique(lapply(x$i.sol, function(x) x$solution))
        for (j in seq(length(uniques))) {
            indices <- unlist(lapply(x$i.sol, function(x) identical(uniques[[j]], x$solution)))
            isols <- names(indices)[indices]
            cat(paste(ifelse(j > 1, "\n", ""), "From ", paste(isols, collapse = ", "), ": ", sep = ""))
            if (enter) cat("\n")
            i <- which(names(x$i.sol) == isols[1])
            if (x$options$show.cases & x$options$details) {
                PIchart <- x$i.sol[[i]]$PIchart
                PIchart <- PIchart[rownames(PIchart) %in% unique(unlist(x$i.sol[[i]]$solution[[1]])), , drop=FALSE]
                mult.cov <- ifelse(any(colSums(PIchart) > 1), length(unlist(lapply(x$inputcases[colSums(PIchart) > 1], strsplit, split=","))), 0)
                cat("\nNumber of multiple-covered cases:", mult.cov, "\n")
            }
            if (!mqca & enter) {
                cat("\n")
            }
            for (sol in seq(length(x$i.sol[[i]]$solution))) {
                prettyNums <- formatC(seq(length(x$i.sol[[i]]$solution)), digits = nchar(length(x$i.sol[[i]]$solution)) - 1, flag = 0)
                preamble <- paste("M", prettyNums[sol], ": ", sep="")
                preamble <- paste(preamble, paste(rep(" ", 7 - nchar(preamble)), collapse=""), sep="")
                cat(preamble)
                xsol <- x$i.sol[[i]]$solution[[sol]]
                sufnec.char[i] <- paste(ifelse(sufnec[i], "<", ""), "=>", sep="")
                if (length(x$i.sol[[i]]$essential) > 0) {
                    xsol <- xsol[!xsol %in% x$i.sol[[i]]$essential]
                    xsol <- paste(paste(x$i.sol[[i]]$essential, collapse="@"), ifelse(length(xsol) > 0, paste("@(", paste(xsol, collapse="@"), ")", sep=""), ""), sep="")
                    cat(prettyString(unlist(strsplit(xsol, split="@")), line.length - 7, 7, "+", sufnec.char[i], outcome), "\n")
                }
                else {
                    cat(prettyString(x$i.sol[[i]]$solution[[sol]], line.length - 7, 7, "+", sufnec.char[i], outcome), "\n")
                }
            }
            if (x$options$details) {
                print.pof(x$i.sol[[i]]$IC, PRI = PRI, show.cases = x$options$show.cases)
            }
        }
    }
    else { 
        if (x$options$show.cases & !mqca & x$options$details) {
            PIchart <- x$PIchart
            PIchart <- PIchart[rownames(PIchart) %in% unique(unlist(x$solution[[1]])), , drop=FALSE]
            mult.cov <- ifelse(any(colSums(PIchart) > 1), length(unlist(lapply(x$inputcases[colSums(PIchart) > 1], strsplit, split=","))), 0)
            cat("Number of multiple-covered cases:", mult.cov, "\n\n")
        }
        if (length(x$solution) == 1) {
            sufnec <- agteb(x$IC$sol.incl.cov[3], sol.cov)
            sufnec <- paste(ifelse(sufnec, "<", ""), "=>", sep="")
            cat(sprintf("M1: %s\n", prettyString(x$solution[[1]], line.length - 4, 4, "+", sufnec, outcome)))
        }
        else {
            prettyNums <- formatC(seq(length(x$solution)), digits = nchar(length(x$solution)) - 1, flag = 0)
            sufnec <- logical(length(x$solution))
            for (i in seq(length(x$solution))) {
                sufnec[i] <- agteb(x$IC$individual[[i]]$sol.incl.cov[3], sol.cov)
            }
            sufnec.char <- rep("", length(sufnec))
            for (i in seq(length(x$solution))) {
                cat(paste("M", prettyNums[i], ": ", sep=""))
                xsol <- x$solution[[i]]
                sufnec.char[i] <- paste(ifelse(sufnec[i], "<", ""), "=>", sep="")
                if (length(x$essential) > 0) {
                    xsol <- xsol[!xsol %in% x$essential]
                    xsol <- paste(paste(x$essential, collapse="@"), ifelse(length(xsol) > 0, paste("@(", paste(xsol, collapse="@"), ")", sep=""), ""), sep="")
                    cat(prettyString(unlist(strsplit(xsol, split="@")), line.length - nchar(prettyNums[i]) - 3, nchar(prettyNums[i]) + 3, "+", sufnec.char[i], outcome), "\n")
                }
                else {
                    cat(prettyString(x$solution[[i]], line.length - nchar(prettyNums[i]) - 3, nchar(prettyNums[i]) + 3, "+", sufnec.char[i], outcome), "\n")
                }
            }
            if (!mqca & x$options$details & enter) {
                cat("\n")
            }
        }
        if (x$options$details) {
            print.pof(x$IC, PRI = PRI, show.cases = x$options$show.cases, line.length=line.length)
        }
    }
    if (!x$options$details & enter) {
        cat("\n")
    }
}
`print.pof` <-
function(x, ...) {
    if (is.element("modelfit", names(x))) {
        cat("\n")
        if (names(x$modelfit$model) != "M") {
            cat(names(x$modelfit$model), "\n", sep = "")
        }
        cat("MODEL:        ", x$modelfit$model, "\n", sep = "")
        cat("THEORY:       ", x$modelfit$theory, "\n", sep = "")
        for (int in seq(4)) {
            cat(names(x$modelfit$intersections)[int], ": ", x$modelfit$intersections[int], "\n", sep = "")
        }
    }
    if ("fuzzyop" %in% names(x$options)) {
        if (x$options$fuzzyop) {
        }
    }
    essential.PIs <- NULL
    if ("essential" %in% names(x)) {
        essential.PIs <- x$essential
    }
    essentials <- length(essential.PIs) > 0
    overall <- FALSE
    if ("overall" %in% names(x)) {
        overall <- TRUE
    }
    cases.column <- sol.exists <- FALSE
    valid.covU <- TRUE
    other.args <- list(...)
    max.nchar.cases <- 0
    line.length <- getOption("width")
    if ("line.length" %in% names(other.args)) {
        line.length <- other.args$line.length
    }
    PRI <- TRUE
    if (!("show.cases" %in% names(x$options))) {
        x$options$show.cases <- FALSE
    }
    if ("show.cases" %in% names(other.args)) {
        if (is.logical(other.args$show.cases)) {
            x$options$show.cases <- other.args$show.cases
        }
    }
    if (overall) {
        incl.cov <- x$overall$incl.cov
        if (!PRI) {
            incl.cov <- incl.cov[, -grep("PRI", colnames(incl.cov))]
        }
        nrow.incl.cov <- nrow(incl.cov)
        nchar.nrow <- nchar(nrow.incl.cov)
        ind.len <- length(x$individual)
        if (essentials) {
            essential.PIs.rows <- rownames(incl.cov) %in% essential.PIs
        }
        if (x$options$show.cases) {
            max.nchar.cases <- max(nchar(incl.cov$cases))
            cases.column <- TRUE
            incl.cov.cases <- incl.cov$cases
            incl.cov$cases <- NULL
            if (essentials) {
                incl.cov.e.cases <- incl.cov.cases[essential.PIs.rows]
                incl.cov.cases <- incl.cov.cases[!essential.PIs.rows]
            }
        }
        else {
            incl.cov$cases <- NULL
        }
        prettyNums <- format(seq(nrow.incl.cov))
        for (i in seq(ncol(incl.cov))) {
            NAs <- is.na(incl.cov[, i])
            incl.cov[!NAs, i] <- formatC(incl.cov[!NAs, i], digits=3, format="f")
            incl.cov[NAs, i] <- "  -  "
        }
        colnames(incl.cov) <- format(colnames(incl.cov))
        if (essentials) {
            which.essential <- seq(length(which(essential.PIs.rows)))
            prettyNums.e <- prettyNums[which.essential]
            prettyNums <- prettyNums[-which.essential]
            incl.cov.e <- incl.cov[essential.PIs.rows, , drop=FALSE]
            incl.cov <- incl.cov[!essential.PIs.rows, , drop=FALSE]
            for (i in seq(ind.len)) {
                unique.coverages <- formatC(x$individual[[i]]$incl.cov$covU[rownames(x$individual[[i]]$incl.cov) %in% essential.PIs], digits=3, format="f")
                incl.cov.e <- cbind(incl.cov.e, S=unique.coverages, stringsAsFactors=FALSE)
                x$individual[[i]]$incl.cov <- x$individual[[i]]$incl.cov[!rownames(x$individual[[i]]$incl.cov) %in% essential.PIs, ]
            }
        }
        for (i in seq(ind.len)) {
            incl.cov <- cbind(incl.cov, "     ", stringsAsFactors=FALSE)
            colnames(incl.cov)[ncol(incl.cov)] <- format(ifelse(ind.len < line.length, paste("(M", i, ")", sep=""), paste("M", i, sep="")), width=5)
            if (length(x$individual[[i]]$incl.cov$covU) > 0) {
                incl.cov[rownames(x$individual[[i]]$incl.cov), ncol(incl.cov)] <- formatC(x$individual[[i]]$incl.cov$covU, digits=3, format="f")
            }
        }
        sol.incl.cov <- matrix(unlist(lapply(x$individual, "[", "sol.incl.cov")),
                               nrow=length(x$individual), ncol=3, byrow=TRUE)
        rownames(sol.incl.cov) <- paste("M", seq(length(x$individual)), sep="")
        if (!PRI) {
            sol.incl.cov <- sol.incl.cov[, -2, drop=FALSE]
        }
        sol.exists <- TRUE
    }
    else {
        incl.cov <- x$incl.cov
        nrow.incl.cov <- nrow(incl.cov)
        nchar.nrow <- nchar(nrow.incl.cov)
        prettyNums <- format(seq(nrow.incl.cov))
        incl.cov[incl.cov == "  NA"] <- "     "
        colnames(incl.cov) <- format(colnames(incl.cov))
        if (x$options$show.cases) {
            max.nchar.cases <- max(5, max(nchar(incl.cov$cases))) 
            cases.column <- TRUE
            incl.cov.cases <- incl.cov$cases
            incl.cov$cases <- NULL
        }
        incl.cov$cases <- NULL
        for (i in seq(ncol(incl.cov))) {
            NAs <- is.na(incl.cov[, i])
            incl.cov[!NAs, i] <- formatC(incl.cov[!NAs, i], digits=3, format="f")
            incl.cov[NAs, i] <- "  -  "
        }
        for (i in seq(ncol(x$optionals))) {
            NAs <- is.na(x$optionals)
            x$optionals[!NAs, i] <- formatC(x$optionals[!NAs, i], digits=3, format="f")
            x$optionals[NAs, i] <- "  -  "
        }
        if ("sol.incl.cov" %in% names(x)) {
            sol.incl.cov <- t(as.matrix(x$sol.incl.cov))
            rownames(sol.incl.cov) <- "M1"
            sol.exists <- TRUE
        }
    }
    if (is.null(rownames(incl.cov))) {
        rownames(incl.cov) <- rep("  ", nrow(incl.cov))
    }
    nchar.rownames <- max(nchar(rownames(incl.cov)))
    if (nchar.rownames == 1) {
        nchar.rownames <- 2
    }
    if (essentials) {
        nchar.rownames <- max(nchar.rownames, max(nchar(rownames(incl.cov.e))))
        rownames(incl.cov.e) <- format(rownames(incl.cov.e), width=max(2, nchar.rownames))
    }
    if (nec(x$relation)) {
        incl.cov <- incl.cov[, !grepl("covU", colnames(incl.cov)), drop = FALSE]
    }
    rownames(incl.cov) <- format(rownames(incl.cov), width=max(2, nchar.rownames))
    if (sol.exists) {
        rownames(sol.incl.cov) <- format(rownames(sol.incl.cov), width=nchar.rownames)
        sol.incl.cov <- formatC(sol.incl.cov, digits=3, format="f")
    }
    incl.cov[incl.cov == "  NA"] <- "  -  "
    max.chars <- 1
    if (x$relation %in% c("sufficiency", "suf")) {
        if (ncol(incl.cov) > (3 + any(grepl("PRI|RoN", colnames(incl.cov)))) & is.null(x$options$add)) {
            first.printed.row <- paste(c(rep(" ", nchar.rownames + nchar.nrow + 25 - 7 * !PRI), rep("-", 7 * (ncol(incl.cov) - (2 + valid.covU) + !PRI) - 2)), collapse="")
            max.chars <- nchar(first.printed.row)
        }
    }
    if (max.chars < line.length) {
        if (cases.column) {
            max.chars <- max.nchar.cases
        }
        sep.row <- paste(rep("-", nchar.rownames + 7 * ncol(incl.cov) + ifelse(cases.column, max.nchar.cases, 0) + nchar.nrow), collapse="")
        if (nchar(sep.row) < line.length) {
            if (ncol(incl.cov) > (3 + any(grepl("PRI|RoN", colnames(incl.cov)))) & length(intersect(colnames(incl.cov), "pval1")) == 0 & is.null(x$options$add)) {
                cat(first.printed.row, "\n")
            }
            else {
                cat("\n")
            }
            colstoprint <- colnames(incl.cov)
            colnames.row <- cat(paste(c(paste(rep(" ", nchar.rownames + nchar.nrow + 2), collapse=""), format(colstoprint)), collapse="  "))
            cat(paste(colnames.row, ifelse(cases.column, "  cases", ""), sep=""), "\n")
            sep.row <- paste(rep("-", nchar.rownames + 7 * ncol(incl.cov) + ifelse(cases.column, max.nchar.cases + 2, 0) + nchar.nrow + 2), collapse="")
            cat(sep.row, "\n")
            if (essentials) {
                for (i in seq(nrow(incl.cov.e))) {
                    i.row <- paste(prettyNums.e[i], paste(c(rownames(incl.cov.e)[i], incl.cov.e[i, ]), collapse="  "), sep="  ")
                    if (cases.column) {
                        i.row <- paste(i.row, incl.cov.e.cases[i], sep="  ")
                    }
                    cat(i.row, "\n")
                }
                cat(sep.row, "\n")
            }
            for (i in seq(nrow(incl.cov))) {
                rowtoprint <- c(rownames(incl.cov)[i], incl.cov[i, ])
                i.row <- paste(prettyNums[i], paste(rowtoprint, collapse="  "), sep="  ")
                if (cases.column) {
                    i.row <- paste(i.row, incl.cov.cases[i], sep="  ")
                }
                cat(i.row, "\n")
            }
            cat(sep.row, "\n")
            if (sol.exists) {
                for (i in seq(nrow(sol.incl.cov))) {
                    cat(paste(paste(rep(" ", nchar.nrow), collapse=""), paste(c(rownames(sol.incl.cov)[i], sol.incl.cov[i, ]), collapse="  "), sep="  "), "\n")
                }
            }
            cat("\n")
        }
        else {
            if (ncol(incl.cov) > (3 + any(grepl("PRI|RoN", colnames(incl.cov)))) & is.null(x$options$add)) {
                cat(first.printed.row, "\n")
            }
            else {
                cat("\n")
            }
            cat(paste(c(paste(rep(" ", nchar.rownames + nchar.nrow + 2), collapse=""), colnames(incl.cov)), collapse="  "), "\n")
            sep.row <- paste(rep("-", nchar.rownames + 7 * ncol(incl.cov) + nchar.nrow + 2), collapse="")
            cat(sep.row, "\n")
            if (essentials) {
                for (i in seq(nrow(incl.cov.e))) {
                    cat(paste(prettyNums.e[i], paste(c(rownames(incl.cov.e)[i], incl.cov.e[i, ]), collapse="  "), "\n"), sep="  ")
                }
                cat(sep.row, "\n")
            }
            for (i in seq(nrow(incl.cov))) {
                cat(paste(prettyNums[i], paste(c(rownames(incl.cov)[i], incl.cov[i, ]), collapse="  "), sep="  "), "\n")
            }
            cat(sep.row, "\n")
            if (sol.exists) {
                for (i in seq(nrow(sol.incl.cov))) {
                    cat(paste(paste(rep(" ", nchar.nrow), collapse = ""), paste(c(rownames(sol.incl.cov)[i], sol.incl.cov[i, ]), collapse="  "), sep="  "), "\n")
                }
            }
            if (cases.column) {
                cat("\n", paste(paste(rep(" ", nchar.rownames + nchar.nrow + 2), collapse=""), "cases"), "\n")
                cat(paste(rep("-", nchar.rownames + 7 + nchar.nrow + 2), collapse=""), "\n")
                if (essentials) {
                    for (i in seq(nrow(incl.cov.e))) {
                        cat(paste(prettyNums.e[i], paste(rownames(incl.cov.e)[i], " "), sep="  "))
                        cases <- unlist(strsplit(incl.cov.e.cases[i], split="; "))
                        cat(prettyString(cases, getOption("width") - nchar.rownames - nchar.nrow - 4, nchar.rownames + nchar.nrow + 4, ";", cases = TRUE))
                        cat("\n")
                    }
                    cat(paste(rep("-", nchar.rownames + nchar.nrow + 9), collapse=""), "\n")
                }
                for (i in seq(nrow(incl.cov))) {
                    cat(paste(prettyNums[i], paste(rownames(incl.cov)[i], " "), sep="  "))
                    cases <- unlist(strsplit(incl.cov.cases[i], split="; "))
                    cat(prettyString(cases, getOption("width") - nchar.rownames - nchar.nrow - 4, nchar.rownames + nchar.nrow + 4, ";", cases = TRUE))
                    cat("\n")
                }
                cat(paste(rep("-", nchar.rownames + nchar.nrow + 9), collapse=""), "\n\n")
            }
        }
    }
    else {
        ncols <- floor((line.length - nchar.rownames)/7)
        chunks <- ceiling(ncol(incl.cov)/ncols)
        colsplits <- seq(1, ncol(incl.cov), by=ncols)
        for (chunk in seq(chunks)) {
            sel.cols <- seq(colsplits[chunk], ifelse(chunk == chunks, ncol(incl.cov), colsplits[chunk + 1] - 1))
            incl.cov.temp <- incl.cov[, sel.cols, drop = FALSE]
            if (essentials) {
                incl.cov.e.temp <- incl.cov.e[, sel.cols, drop = FALSE]
            }
            if (chunk < chunks) {
                if (ncols > 3) { 
                    cat(paste(c("\n", rep(ifelse(chunk == 1, " ", "-"), nchar.rownames + nchar.nrow + 18), rep("-", 7 * (ncols - 2) - 2)), collapse=""), "\n")
                }
                cat(paste(c(paste(rep(" ", nchar.rownames + nchar.nrow + 2), collapse=""), colnames(incl.cov.temp)), collapse="  "), "\n")
                sep.row <- paste(rep("-", nchar.rownames + 7 * ncol(incl.cov.temp) + nchar.nrow + 2), collapse="")
                cat(sep.row, "\n")
                if (essentials) {
                    for (i in seq(nrow(incl.cov.e.temp))) {
                        cat(paste(prettyNums.e[i], paste(c(rownames(incl.cov.e.temp)[i], incl.cov.e.temp[i, ]), collapse="  "), sep="  "), "\n")
                    }
                    cat(sep.row, "\n")
                }
                for (i in seq(nrow(incl.cov.temp))) {
                    cat(paste(prettyNums[i], paste(c(rownames(incl.cov.temp)[i], incl.cov.temp[i, ]), collapse="  "), sep="  "), "\n")
                }
                cat(sep.row, "\n")
                if (chunk == 1 & sol.exists) {
                    for (i in seq(nrow(sol.incl.cov))) {
                        cat(paste(paste(rep(" ", nchar.nrow), collapse = ""), paste(c(rownames(sol.incl.cov)[i], sol.incl.cov[i, ]), collapse="  "), sep="  "), "\n")
                    }
                }
                cat("\n")
            }
            else {
                max.chars <- nchar.rownames + 7 * ncol(incl.cov.temp) + nchar.nrow + 2
                sep.row <- paste(c(rep("-", max.chars)), collapse="")
                if (cases.column) {
                    max.chars <- max.chars + max.nchar.cases
                }
                if (max.chars < line.length) {
                    cat(sep.row, "\n")
                    sep.row <- paste(sep.row, ifelse(cases.column, paste(rep("-", max.nchar.cases + 2), collapse=""), ""), sep="")
                    colnames.row <- paste(c(paste(rep(" ", nchar.rownames + nchar.nrow + 2), collapse=""), colnames(incl.cov.temp)), collapse="  ")
                    cat(paste(colnames.row, ifelse(cases.column, "  cases", ""), sep=""), "\n")
                    cat(sep.row, "\n")
                    if (essentials) {
                        for (i in seq(nrow(incl.cov.e.temp))) {
                            i.row <- paste(prettyNums.e[i], paste(c(rownames(incl.cov.e.temp)[i], incl.cov.e.temp[i, ]), collapse="  "), sep="  ")
                            if (cases.column) {
                                i.row <- paste(i.row, incl.cov.e.cases[i], sep="  ")
                            }
                            cat(i.row, "\n")
                        }
                        cat(sep.row, "\n")
                    }
                    for (i in seq(nrow(incl.cov.temp))) {
                        i.row <- paste(prettyNums[i], paste(c(rownames(incl.cov.temp)[i], incl.cov.temp[i, ]), collapse="  "), sep="  ")
                            if (cases.column) {
                                i.row <- paste(i.row, incl.cov.cases[i], sep="  ")
                            }
                        cat(i.row, "\n")
                    }
                    cat(sep.row, "\n")
                }
                else {
                    cat(sep.row, "\n")
                    cat(paste(c(paste(rep(" ", nchar.rownames + nchar.nrow + 2), collapse=""), colnames(incl.cov.temp)), collapse="  "), "\n")
                    cat(sep.row, "\n")
                    if (essentials) {
                        for (i in seq(nrow(incl.cov.e.temp))) {
                            i.row <- paste(prettyNums.e[i], paste(c(rownames(incl.cov.e.temp)[i], incl.cov.e.temp[i, ]), collapse="  "), sep="  ")
                            cat(i.row, "\n")
                        }
                        cat(sep.row, "\n")
                    }
                    for (i in seq(nrow(incl.cov.temp))) {
                        cat(paste(prettyNums[i], paste(c(rownames(incl.cov.temp)[i], incl.cov.temp[i, ]), collapse="  "), sep="  "), "\n")
                    }
                    cat(sep.row, "\n")
                    if (cases.column) {
                        cat("\n", paste(paste(rep(" ", nchar.rownames + nchar.nrow + 2), collapse=""), "cases"), "\n")
                        sep.row <- paste(rep("-", nchar.rownames + nchar.nrow + 9), collapse="")
                        cat(sep.row, "\n")
                        if (essentials) {
                            for (i in seq(nrow(incl.cov.e.temp))) {
                                cat(paste(prettyNums[i], paste(rownames(incl.cov.e.temp)[i], " "), sep="  "))
                                cases <- unlist(strsplit(incl.cov.e.cases[i], split="; "))
                                cat(prettyString(cases, getOption("width") - nchar.rownames - 2, nchar.rownames + 2, ";", cases = TRUE))
                                cat("\n")
                            }
                            cat(sep.row, "\n")
                        }
                        for (i in seq(nrow(incl.cov.temp))) {
                            cat(paste(prettyNums[i], paste(rownames(incl.cov.temp)[i], " "), sep="  "))
                            cases <- unlist(strsplit(incl.cov.cases[i], split="; "))
                            cat(prettyString(cases, getOption("width") - nchar.rownames - 2, nchar.rownames + 2, ";", cases = TRUE))
                            cat("\n")
                        }
                        cat(sep.row, "\n")
                    }
                }
                cat("\n")
            }
        }
    }
}
`print.sS` <-
function(x, ...) {
    other.args <- list(...)
    if (x$use.letters) {
        conditions <- names(x$letters)
        xletters <- as.vector(x$letters)
        if (!all(conditions %in% xletters)) {
            cat("\n")
            for (i in seq(length(xletters))) {
                cat("    ", paste(xletters[i], ": ", sep=""), conditions[i], "\n", sep="")
            }
        }
    }
    incl.cov <- x$incl.cov
    cat("\n")
    prettyNums <- format(seq(nrow(incl.cov)))
    rownames(incl.cov) <- format(rownames(incl.cov))
    colnames(incl.cov) <- format(colnames(incl.cov), width=5)
    for (i in seq(ncol(incl.cov))) {
        NAs <- is.na(incl.cov[, i])
        incl.cov[!NAs, i] <- formatC(incl.cov[!NAs, i], digits=3, format="f")
        incl.cov[NAs, i] <- "  -  "
    }
    nchar.rownames <- nchar(rownames(incl.cov)[1])
    cat(paste(c(paste(rep(" ", nchar.rownames + nchar(nrow(incl.cov)) + 2), collapse=""), format(colnames(incl.cov))), collapse="  "), "\n")
    sep.row <- paste(rep("-", nchar.rownames + nchar(nrow(incl.cov)) + 7 * ncol(incl.cov) + 2), collapse="")
    cat(sep.row, "\n")
    for (i in seq(nrow(incl.cov))) {
        cat(paste(prettyNums[i], paste(c(rownames(incl.cov)[i], incl.cov[i, ]), collapse="  "), sep="  "), "\n")
    }
    cat(sep.row, "\n")
    cat("\n")
}
`print.aE` <-
function(x, ...) {
    rownames(x) <- format(seq.nrow <- seq(nrow(x)))
    if (attr(x, "raw")) {
        x[x >= 0] <- paste("", x[x >= 0])
    }
    else {
        x[x < 0] <- " "
    }
    cat("\n")
    for (i in seq.nrow) {
        cat(paste(c(rownames(x)[i], x[i, ]), collapse = ifelse(attr(x, "raw"), "   ", "    ")), "\n")
    }
    cat("\n")
}
`print.mqca` <-
function(x, ...) {
    cat("\n")
    for (i in seq(length(x))) {
        print.qca(x[[i]], details = FALSE, mqca = TRUE)
    }
}
`print.deMorgan` <-
function(x, ...) {
    prettyNums <- formatC(seq(length(x)), digits = nchar(length(x)) - 1, flag = 0)
    pI <- paste("S", prettyNums, sep="")
    pO <- paste("  N", prettyNums, sep="")
    if (!is.null(isol <- attr(x, "isol"))) {
        pI <- paste(pI, isol, sep = "-")
        pO <- paste(pO, isol, sep = "-")
    }
    pI <- paste(pI, ": ", sep = "")
    pO <- paste(pO, ": ", sep = "")
    expressions <- attr(x, "expressions")
    ncharSI <- max(nchar(pI))
    for (i in seq(length(x))) {
        cat("\n", pI[i], sep = "")
        cat(prettyString(expressions[i], getOption("width") - ncharSI, ncharSI, "+"))
        cat("\n", pO[i], sep = "")
        cat(prettyString(x[i], getOption("width") - ncharSI, ncharSI, "+"))
        cat("\n")
    }
    cat("\n")
}
`print.factorize` <-
function(x, ...) {
    prettyNums <- formatC(seq(length(x)), digits = nchar(length(x)) - 1, flag = 0)
    pM <- paste("M", prettyNums, sep="")
    if (!is.null(isol <- attr(x, "isol"))) {
        pM <- paste(pM, isol, sep = "-")
    }
    pM <- paste(pM, ": ", sep = "")
    cat("\n")
    for (i in seq(length(x))) {
        cat(paste(pM[i], names(x)[i], sep=""), "\n\n")
        fx <- x[[i]]
        if (is.null(fx)) {
            cat("No factorization possible.\n")
        }
        else {
            for (j in seq(length(fx))) {
                prettyNumsFact <- formatC(seq(length(fx)), digits = nchar(length(fx)) - 1, flag = 0)
                cat(paste("  F", prettyNumsFact[j], ": ", sep=""))
                flength <- nchar(prettyNumsFact[j]) + 3
                strvctr <- unlist(strsplit(fx[j], split=" + "))
                cat(prettyString(strvctr, getOption("width") - flength, flength, "+"), "\n")
            }
            cat("\n")
        }
    }
}
`print.intersection` <-
function(x, ...) {
    prettyNums <- formatC(seq(length(x)), digits = nchar(length(x)) - 1, flag = 0)
    pI <- paste("E", prettyNums, sep="")
    pO <- paste("  I", prettyNums, sep="")
    if (!is.null(isol <- attr(x, "isol"))) {
        pI <- paste(pI, isol, sep = "-")
        pO <- paste(pO, isol, sep = "-")
    }
    pI <- paste(pI, ": ", sep = "")
    pO <- paste(pO, ": ", sep = "")
    expressions <- attr(x, "expressions")
    ncharSI <- max(nchar(pI))
    for (i in seq(length(x))) {
        cat("\n", pI[i], sep = "")
        cat(prettyString(expressions[i], getOption("width") - ncharSI, ncharSI, "+"))
        cat("\n", pO[i], sep = "")
        cat(prettyString(x[i], getOption("width") - ncharSI, ncharSI, "+"))
        cat("\n")
    }
    cat("\n")
}
`print.modelFit` <-
function(x, ...) {
    for (i in seq(length(x))) {
        print(x[[i]])
    }
}
print.chain <- function(x, ...) {
    other.args <- list(...)
    line.length <- getOption("width")
    if (any(names(x) == "via.web")) {
        line.length <- 10000
    }
    cat("\n")
    x <- lapply(x, function(x) {
        toreturn <- FALSE
        if (!identical(x, NA)) {
            sol.cons <- x$options$sol.cons
            sol.cov <- x$options$sol.cov
            if (!identical(x, NULL)) {
                outcome <- x$tt$options$outcome
                if (grepl("\\{|\\}", outcome)) {
                    if (x$options$neg.out) {
                        outcome <- paste("~", notilde(toupper(outcome)), sep = "")
                    }
                }
                else {
                    if (x$options$neg.out) {
                        if (x$options$use.tilde) {
                            outcome <- paste("~", notilde(toupper(outcome)), sep = "")
                        }
                        else {
                            outcome <- notilde(tolower(outcome))
                        }
                    }
                }
                if (is.element("i.sol", names(x))) {
                    sufnec <- logical(length(x$i.sol))
                    for (i in seq(length(x$i.sol))) {
                        if ("overall" %in% names(x$i.sol[[i]]$IC)) {
                            sufnec[i] <- agteb(x$i.sol[[i]]$IC$overall$sol.incl.cov[c(1, 3)], c(sol.cons, sol.cov))
                        }
                        else {
                            sufnec[i] <- agteb(x$i.sol[[i]]$IC$sol.incl.cov[c(1, 3)], c(sol.cons, sol.cov))
                        }
                    }
                    if (any(sufnec)) {
                        for (i in seq(length(x$i.sol))) {
                            if (sufnec[i]) {
                                prettyNums <- formatC(seq(length(x$solution)), digits = nchar(length(x$solution)) - 1, flag = 0)
                                for (sol in seq(length(x$i.sol[[i]]$solution))) {
                                    preamble <- sprintf("M%s-%s:", i, sol)
                                    preamble <- paste(preamble, paste(rep(" ", 7 - nchar(preamble)), collapse=""), sep="")
                                    cat(preamble)
                                    cat(prettyString(x$i.sol[[i]]$solution[[sol]], line.length - 7, 7, "+", "<=>", outcome), "\n")
                                }
                            }
                        }
                        toreturn <- TRUE
                    }
                }
                else {
                    sufnec <- logical(length(x$solution))
                    if (length(x$solution) == 1) {
                        sufnec <- agteb(x$IC$sol.incl.cov[c(1, 3)], c(sol.cons, sol.cov))
                        if (sufnec) {
                            cat(paste("M1: ", prettyString(x$solution[[1]], line.length - 4, 4, "+", "<=>", outcome), "\n", sep=""))
                            toreturn <- TRUE
                        }
                    }
                    else {
                        for (i in seq(length(x$solution))) {
                            sufnec[i] <- agteb(x$IC$individual[[i]]$sol.incl.cov[c(1, 3)], c(sol.cons, sol.cov))
                        }
                        if (any(sufnec)) {
                            prettyNums <- formatC(seq(length(x$solution)), digits = nchar(length(x$solution)) - 1, flag = 0)
                            for (i in seq(length(x$solution))) {
                                if (sufnec[i]) {
                                    cat(paste("M", prettyNums[i], ": ", sep=""))
                                    cat(sprintf("%s <=> %s\n", paste(x$solution[[i]], collapse = " + "), outcome))
                                }
                            }
                            toreturn <- TRUE
                        }
                    }
                }
            }
            if (toreturn) {
                cat("\n")
            }
        }
        return(toreturn)
    })
    if (all(!unlist(x))) {
        cat("There are no causal chains in this data.\n\n")
    }
}
print.panel <- function(x, ...) {
    other.args <- list(...)
    quote <- FALSE
    if (is.element("quote", names(other.args))) {
        if (is.logical(other.args$quote)) {
            quote <- other.args$quote[1]
        }
    }
    right <- TRUE
    if (is.element("right", names(other.args))) {
        if (is.logical(other.args$right)) {
            right <- other.args$right[1]
        }
    }
    n <- length(row.names(x))
    if (length(x) == 0L) {
        cat(sprintf(ngettext(n, "cluster data frame with 0 columns and %d row", 
            "cluster data frame with 0 columns and %d rows"), n), "\n", 
            sep = "")
    }
    else if (n == 0L) {
        print.default(names(x), quote = FALSE)
        cat(gettext("<0 rows> (or 0-length row.names)\n"))
    }
    else {
        x <- as.matrix(x)
        if (is.null(row.names(x))) {
            row.names(x) <- seq(nrow(x))
        }
        print(x, quote = quote, right = right)
    }
}

Try the QCA package in your browser

Any scripts or data that you put into this service are public.

QCA documentation built on April 1, 2018, 12:12 p.m.