is.tt <- function(x) {
inherits(x, "tt")
}
is.qca <- function(x) {
inherits(x, "qca")
}
is.pof <- function(x) {
inherits(x, "pof")
}
is.DeMorgan <- function(x) {
inherits(x, "DeMorgan")
}
print.tt <- function(x, ...) {
other.args <- list(...)
PRI <- x$PRI
if ("PRI" %in% names(other.args)) {
if (is.logical(other.args$PRI)) {
PRI <- other.args$PRI[1] # [1] just to make sure only the first value is taken, should someone by mistake provide a vector
}
}
if (nrow(x$tt) > 1024) {
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))), "")
nofexo.facs <- length(x$noflevels)
names.mydata <- colnames(x$recoded.data)[seq(nofexo.facs + 1)]
cat("\n", sep="")
if (!all(names(x$tt)[seq(nofexo.facs)] %in% names(x$recoded.data)[seq(nofexo.facs)])) {
for (i in seq(nofexo.facs)) {
cat(" ", paste(names(x$tt)[i], ": ", sep=""), names.mydata[i], "\n", sep="")
}
}
inclusion <- x$tt[, "incl"]
missincl <- x$tt[, "incl"] == "-"
x$tt[!missincl, "incl"] <- formatC(as.numeric(inclusion[!missincl]), digits=3, format="f")
if (PRI) {
pri <- x$tt[, "PRI"]
misspri <- x$tt[, "PRI"] == "-"
x$tt[!misspri, "PRI"] <- formatC(as.numeric(pri[!misspri]), digits=3, format="f")
}
else {
x$tt$PRI <- NULL # get rid of the PRI column
}
if (any(names(x$tt) == "pval1")) {
pvalues1 <- x$tt[, "pval1"]
pvalues0 <- x$tt[, "pval0"]
miss.pvalues1 <- x$tt[, "pval1"] == "-"
miss.pvalues0 <- x$tt[, "pval0"] == "-"
x$tt[!miss.pvalues1, "pval1"] <- formatC(as.numeric(pvalues1[!miss.pvalues1]), digits=3, format="f")
x$tt[!miss.pvalues0, "pval0"] <- formatC(as.numeric(pvalues0[!miss.pvalues0]), digits=3, format="f")
}
if (any(missincl)) {
x$tt[missincl, "incl"] <- " -"
}
if (PRI) {
if (any(misspri)) {
x$tt[misspri, "PRI"] <- " -"
}
}
cat(" OUT: output function value\n")
cat(" n: number of cases in minterm\n")
cat(" incl: sufficiency inclusion score\n")
if (any(names(x$tt) == "pval1")) {
cat(paste("pval1: p-value inclusion < ", x$incl.cut1, "\n", sep=""))
cat(paste("pval0: p-value inclusion > ", x$incl.cut0, "\n", sep=""))
}
print(prettyTable(x$tt))
if (all(x$tt$OUT == 0)) {
cat("\n")
cat("All output function values are negative.")
}
cat("\n")
}
}
print.pic <- function(x, ...) {
mtrx2 <- x[[1]]
rownames(mtrx2) <- paste(rownames(mtrx2), "")
colnames(mtrx2) <- format(colnames(mtrx2), width=2)
mtrx2[x[[1]]] <- "x"
mtrx2[!x[[1]]] <- "-"
print(prettyTable(mtrx2))
cat("\n")
}
print.qca <- function(x, ...) {
other.args <- list(...)
details <- x$opts$details
if (grepl("[{]", x$tt$outcome)) {
outcome <- unlist(strsplit(x$tt$outcome, split = ""))
outcome.value <- as.numeric(outcome[which(outcome == "{") + 1])
outcome <- paste(outcome[seq(1, which(outcome == "{") - 1)], collapse="")
if (x$opts$neg.out) {
noflevels <- seq(max(x$tt$initial.data[, outcome]) + 1) - 1
noflevels <- paste(noflevels[-which(noflevels == outcome.value)], collapse = ",")
outcome <- paste0(outcome, "{", noflevels, "}")
}
else {
outcome <- x$tt$outcome
}
if (any(x$opts$minimize != 1)) {
outcome <- ""
}
}
else {
outcome <- ifelse(any(x$opts$minimize == 1), ifelse(x$opts$neg.out, tolower(x$tt$outcome), toupper(x$tt$outcome)), "")
}
if ("show.cases" %in% names(other.args)) {
if (is.logical(other.args$show.cases)) {
x$opts$show.cases <- other.args$show.cases
}
}
mqca <- FALSE
if ("mqca" %in% names(other.args)) {
if (is.logical(other.args$mqca)) {
mqca <- other.args$mqca
}
}
if (!x$opts$show.cases) {
if ("cases" %in% names(x$IC$incl.cov)) {
x$IC$incl.cov$cases <- NULL
}
}
PRI <- FALSE
if ("PRI" %in% names(other.args)) {
if (is.logical(other.args$PRI)) {
PRI <- other.args$PRI[1] # [1] just to make sure only the first value is taken, should someone by mistake provide a vector
}
}
if ("PRI" %in% names(x$opts)) {
if (is.logical(x$opts$PRI)) {
PRI <- x$opts$PRI[1]
}
}
if ("details" %in% names(other.args)) {
if (is.logical(other.args$details)) {
details <- other.args$details
x$opts$details <- details
}
}
else {
nofexo.facs <- length(x$tt$noflevels)
if (!all(names(x$tt$tt)[seq(nofexo.facs)] %in% names(x$tt$recoded.data)[seq(nofexo.facs)]) & x$opts$use.letters) {
cat("\n")
names.mydata <- colnames(x$tt$recoded.data)[seq(nofexo.facs + 1)]
for (i in seq(nofexo.facs)) {
cat(paste(names(x$tt$tt)[i], ": ", sep=""), names.mydata[i], "\n", sep="")
}
}
}
if (details) {
cat("\n")
cat("n OUT = 1/0/C:", paste(x$numbers[1:3], collapse="/"), "\n")
cat(" Total :", x$numbers[4], "\n")
}
if (!mqca) {
cat("\n")
}
if ("i.sol" %in% names(x)) {
sufnec <- valid.solution <- vector(length = length(x$i.sol))
for (i in seq(length(x$i.sol))) {
if ("overall" %in% names(x$i.sol[[i]]$IC)) {
sufnec[i] <- all(x$i.sol[[i]]$IC$overall$sol.incl.cov[c(1, 3)] >= x$tt$incl.cut1)
}
else {
sufnec[i] <- all(x$i.sol[[i]]$IC$sol.incl.cov[c(1, 3)] >= x$tt$incl.cut1)
}
valid.solution[i] <- x$relation == "suf"
if (x$relation == "sufnec" & sufnec[i]) {
valid.solution[i] <- TRUE
}
}
if (any(valid.solution)) {
x$i.sol <- x$i.sol[valid.solution]
sufnec <- sufnec[valid.solution]
sufnec.char <- rep("", length(sufnec))
for (i in seq(length(x$i.sol))) {
cat(paste(ifelse(i > 1, "\n", ""), "p.sol: ", sep=""))
cat(prettyString(x$i.sol[[i]]$p.sol, getOption("width") - 7, 7, "+"))
cat("\n")
if (x$opts$show.cases & x$opts$details) {
PIchart <- x$i.sol[[i]]$PIchart[[1]]
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) {
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(sortVector(x$i.sol[[i]]$essential), collapse="#"), ifelse(length(xsol) > 0, paste("#(", paste(xsol, collapse="#"), ")", sep=""), ""), sep="")
cat(prettyString(unlist(strsplit(xsol, split="#")), getOption("width") - 7, 7, "+", sufnec.char[i], outcome), "\n")
}
else {
cat(prettyString(x$i.sol[[i]]$solution[[sol]], getOption("width") - 7, 7, "+", sufnec.char[i], outcome), "\n")
}
}
if (x$opts$details) {
print.pof(x$i.sol[[i]]$IC, PRI = PRI, show.cases = x$opts$show.cases)
}
else {
cat("\n")
}
}
}
else {
cat(paste("No single intermediate solution is both sufficient and necessary.\n\n", sep=""))
}
}
else { # no intermediate solutions, just regular ones
if (x$opts$show.cases & !mqca & x$opts$details) {
PIchart <- x$PIchart[[1]]
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 <- all(x$IC$sol.incl.cov[c(1, 3)] >= x$tt$incl.cut1)
valid.solution <- x$relation == "suf"
if (x$relation == "sufnec" & sufnec) {
valid.solution <- TRUE
}
if (valid.solution) {
sufnec <- paste0(ifelse(sufnec, "<", ""), "=>")
cat(paste("M1: ", prettyString(x$solution[[1]], getOption("width") - 4, 4, "+", sufnec, outcome), sep=""))
if (x$opts$details) {
cat("\n")
}
}
else {
cat(paste("There is no solution for outcome \"", ifelse(x$opts$neg.out, tolower(x$tt$outcome), toupper(x$tt$outcome)), "\".", sep=""))
}
}
else {
# there is an "overall" and an "individual" component to IC
prettyNums <- formatC(seq(length(x$solution)), digits = nchar(length(x$solution)) - 1, flag = 0)
sufnec <- valid.solution <- vector(length = length(x$solution))
for (i in seq(length(x$solution))) {
sufnec[i] <- all(x$IC$individual[[i]]$sol.incl.cov[c(1, 3)] >= x$tt$incl.cut1)
valid.solution[i] <- x$relation == "suf"
if (x$relation == "sufnec" & sufnec[i]) {
valid.solution[i] <- TRUE
}
}
index <- which(valid.solution == TRUE)
if (any(valid.solution)) {
x$solution <- x$solution[valid.solution]
sufnec <- sufnec[valid.solution]
sufnec.char <- rep("", length(sufnec))
for (i in seq_along(index)) {
cat(paste0("M", prettyNums[index[i]], ": "))
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(sortVector(x$essential), collapse="#"), ifelse(length(xsol) > 0, paste("#(", paste(xsol, collapse="#"), ")", sep=""), ""), sep="")
cat(prettyString(unlist(strsplit(xsol, split="#")), getOption("width") - nchar(prettyNums[i]) - 3, nchar(prettyNums[i]) + 3, "+", sufnec.char[i], outcome), "\n")
}
else {
cat(prettyString(x$solution[[i]], getOption("width") - nchar(prettyNums[i]) - 3, nchar(prettyNums[i]) + 3, "+", sufnec.char[i], outcome), "\n")
}
}
}
else {
cat(paste("There is no solution for outcome \"", ifelse(x$opts$neg.out, tolower(x$tt$outcome), toupper(x$tt$outcome)), "\".\n", sep=""))
}
if (!mqca) {
cat("\n")
}
}
if (x$opts$details) {
print.pof(x$IC, PRI = PRI, show.cases = x$opts$show.cases)
}
}
if (!x$opts$details) {
cat("\n\n")
}
}
print.pof <- function(x, ...) {
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
max.nchar.cases <- 0
line.length <- getOption("width")
valid.cov.u <- TRUE
other.args <- list(...)
PRI <- FALSE
if ("PRI" %in% names(other.args)) {
if (is.logical(other.args$PRI)) {
PRI <- other.args$PRI[1] # [1] just to make sure only the first value is taken, should someone by mistake provide a vector
}
}
if ("PRI" %in% names(x)) {
if (is.logical(x$PRI)) {
PRI <- other.args$PRI[1]
}
}
if ("show.cases" %in% names(other.args)) {
if (is.logical(other.args$show.cases)) {
x$opts$show.cases <- other.args$show.cases
}
}
if (overall) {
incl.cov <- x$overall$incl.cov
if (!PRI) {
# get rid of the PRI column, not print it on the screen
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$opts$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$cov.u[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$cov.u) > 0) {
incl.cov[rownames(x$individual[[i]]$incl.cov), ncol(incl.cov)] <- formatC(x$individual[[i]]$incl.cov$cov.u, 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
if (!PRI) {
# get rid of the PRI column, not print it on the screen
incl.cov <- incl.cov[, -grep("PRI", colnames(incl.cov)), drop=FALSE]
}
#if (x$relation %in% c("sufficiency", "suf")) {
# if (sum(as.numeric(incl.cov[, "cov.u"])) == 0) {
# valid.cov.u <- FALSE
# incl.cov <- incl.cov[, -which(colnames(incl.cov) == "cov.u")]
# }
#}
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$opts$show.cases) {
max.nchar.cases <- max(5, max(nchar(incl.cov$cases))) # 5 is the number of chars from column name "cases"
cases.column <- TRUE
incl.cov.cases <- incl.cov$cases
incl.cov$cases <- NULL
}
else {
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] <- " - "
}
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 (!PRI) {
sol.incl.cov <- sol.incl.cov[ , -grep("PRI", colnames(sol.incl.cov)), drop=FALSE]
}
}
}
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 (x$relation %in% c("necessity", "nec")) {
# incl.cov <- incl.cov[, seq(1, 2 + any(grepl("PRI", colnames(incl.cov)))), drop = FALSE]
incl.cov <- incl.cov[, -which(colnames(incl.cov) == "cov.u"), 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", colnames(incl.cov))))) {
first.printed.row <- paste(c(rep(" ", nchar.rownames + nchar.nrow + 25 - 7 * !PRI), rep("-", 7 * (ncol(incl.cov) - (2 + valid.cov.u) + !PRI) - 2)), collapse="")
max.chars <- nchar(first.printed.row)
}
}
if (max.chars < line.length) {
if (cases.column) {
# calculate the number of characters including the 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="")
# then compare again the max.chars with a "normal" length of a line
if (nchar(sep.row) < line.length) {
if (ncol(incl.cov) > (3 + any(grepl("PRI", colnames(incl.cov)))) & length(intersect(colnames(incl.cov), "pval1")) == 0) {
cat(first.printed.row, "\n")
}
else {
cat("\n")
}
colnames.row <- cat(paste(c(paste(rep(" ", nchar.rownames + nchar.nrow + 2), collapse=""), format(colnames(incl.cov))), 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))) {
i.row <- paste(prettyNums[i], paste(c(rownames(incl.cov)[i], incl.cov[i, ]), 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 {
# the number of characters including the cases exceeds a normal length line
# therefore the cases will be printed separately
if (ncol(incl.cov) > (3 + any(grepl("PRI", colnames(incl.cov))))) {
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 {
# the number of characters from all columns exceed a normal length line
# therefore the entire matrix will be printed on chunks of columns
ncols <- floor((line.length - nchar.rownames)/7)
chunks <- ceiling(ncol(incl.cov)/ncols)
colsplits <- seq(1, ncol(incl.cov), by=ncols)
#if (essentials) {
# incl.cov.e <- incl.cov.e[, seq(1, 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) { # quick'n'dirty hack to solve Mattia's printing error
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=" ")
#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))) {
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.fctr <- function(x, ...) {
xprint <- function(fx, i.sol.name="", num="") {
# fx is a list of length 1
# its name is the name of the solution, collapsed with " + "
cat(paste(i.sol.name, num, ": ", names(fx), sep=""), "\n\n")
fx <- fx[[1]]
if (is.null(fx)) {
cat("No factorization possible.\n")
}
else {
for (i in seq(length(fx))) {
prettyNumsFact <- formatC(seq(length(fx)), digits = nchar(length(fx)) - 1, flag = 0)
cat(paste("F", prettyNumsFact[i], ": ", sep=""))
flength <- nchar(prettyNumsFact[i]) + 3
strvctr <- unlist(strsplit(fx[i], split=" + "))
cat(prettyString(strvctr, getOption("width") - flength, flength, "+"), "\n")
}
cat("\n")
}
cat("\n")
}
cat("\n")
if (names(x)[1] == "i.sol") {
for (isol in seq(length(x$i.sol))) {
prettyNumsSol <- formatC(seq(length(x$i.sol[[isol]])), digits = nchar(length(x$i.sol[[isol]])) - 1, flag = 0)
for (xf in seq(length(x$i.sol[[isol]]))) {
xprint(x$i.sol[[isol]][xf], i.sol.name=names(x$i.sol)[isol], num=prettyNumsSol[xf])
}
}
}
else {
prettyNumsSol <- paste("M", formatC(seq(length(x)), digits = nchar(length(x)) - 1, flag = 0), sep="")
for (i in seq(length(x))) {
xprint(x[i], num=prettyNumsSol[i])
}
}
}
print.aE <- function(x, ...) {
aE <- x$aE
rownames(aE) <- format(seq.nrow <- seq(nrow(aE)))
if (x$raw) {
aE[aE >= 0] <- paste("", aE[aE >= 0])
}
else {
aE[aE < 0] <- " "
}
cat("\n")
for (i in seq.nrow) {
cat(paste(c(rownames(aE)[i], aE[i, ]), collapse=ifelse(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, ...) {
other.args <- list(...)
if ("or.split" %in% names(other.args)) {
or.split <- other.args$or.split
}
else {
or.split <- "+"
}
if (names(x)[1] == "S1") {
prettyNums <- formatC(seq(length(x)), digits = nchar(length(x)) - 1, flag = 0)
cat("\n")
for (i in seq(length(x))) {
preamble <- paste("S", prettyNums[i], ": ", sep="")
cat(preamble)
cat(prettyString(paste(x[[i]][[1]], collapse = paste(" ", or.split, " ", sep="")), getOption("width") - nchar(preamble), nchar(preamble), or.split), "\n")
cat(paste("N", prettyNums[i], ": ", sep=""))
cat(prettyString(paste(x[[i]][[2]], collapse = paste(" ", or.split, " ", sep="")), getOption("width") - nchar(preamble), nchar(preamble), or.split), "\n\n")
}
}
else {
cat("\n")
for (i in seq(length(x))) {
prettyNums <- formatC(seq(length(x[[i]])), digits = nchar(length(x[[i]])) - 1, flag = 0)
for (j in seq(length(x[[i]]))) {
preamble <- paste(names(x)[i], "S", prettyNums[j], ": ", sep="")
cat(preamble)
cat(prettyString(paste(x[[i]][[j]][[1]], collapse = paste(" ", or.split, " ", sep="")), getOption("width") - nchar(preamble), nchar(preamble), or.split), "\n")
cat(paste(names(x)[i], "N", prettyNums[j], ": ", sep=""))
cat(prettyString(paste(x[[i]][[j]][[2]], collapse = paste(" ", or.split, " ", sep="")), getOption("width") - nchar(preamble), nchar(preamble), or.split), "\n\n")
}
}
}
}
#`print.pims` <-
#function(x, ...) {
#line.length <- floor(getOption("width")*0.95)
#rownames(x) <- format(rownames(x))
#x <- apply(x, 2, formatC, digits=3, format="f")
#nchar.rownames <- nchar(rownames(x)[1])
#for (i in seq(ncol(x))) {
# colnames(x)[i] <- format(colnames(x)[i], width=max(5, nchar(colnames(x)[i])))
#}
#sep.row <- paste(rep("-", nchar.rownames + ifelse(ncol(x) > 1, sum(nchar(colnames(x)[-ncol(x)])) + 2*(ncol(x) - 1), 0) + max(nchar(colnames(x)[ncol(x)]), 5) + 2), collapse="")
#nchar.sep.row <- nchar(sep.row)
#if (nchar.sep.row < line.length) {
# columns <- paste(colnames(x), collapse=" ")
# cat(paste(paste(rep(" ", nchar.rownames), collapse=""), columns, sep=" "), "\n")
# cat(sep.row, "\n")
# for (i in seq(nrow(x))) {
# catrow <- paste(rownames(x)[i], x[i, 1], sep=" ")
# if (ncol(x) > 1) {
# for (colno in seq(2, ncol(x))) {
# ncharcol <- nchar(colnames(x)[colno - 1])
# catrow <- paste(catrow, x[i, colno], sep=paste(rep(" ", max(2, ifelse(ncharcol > 5, ncharcol - 3, 0))), collapse=""))
# }
# }
# cat(catrow, "\n")
# }
# cat(sep.row, "\n")
#}
#else {
#
#}
#print(unclass(x))
#}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.