Nothing
# trim column of a matrix to equal width
# x: matrix
trim_column_width <- function(x, just = "l") {
lengths <- apply(nchar(x), 2, max)
for (j in seq_len(ncol(x))) {
x[, j] <- format(x[, j], just = just, width = lengths[j])
}
x
}
# trim_column_width(x, just="r")
collapse_matrix <- function(x, collapse = "", sep = " ") {
x <- apply(x, 1, paste,
collapse = collapse, sep = sep
) # collapse whole matrix
do.call(rbind, as.list(x)) # bind whole matrix together
}
# x: matrix
matrix_to_single_char_matrix <- function(x, collapse = "", sep = " ") {
x <- collapse_matrix(x, collapse = collapse, sep = sep)
x <- sapply(x, strsplit, split = "") # split to single chars
names(x) <- NULL # for cleaner output
do.call(rbind, x) # single chars matrix
}
# TODO: first line indent wrong
matrix_to_console <- function(x, sep = "") {
# cat(" ") ???
dummy <- apply(x, 1, function(x) {
cat(c(x, "\n"), collapse = "", sep = sep)
})
}
widths_matrix_columns <- function(x) {
apply(x, 2, function(y) max(nchar(y)))
}
random_df <- function(nrow = ncol, ncol = nrow, wrow = 6, wcol = 10) {
x <- data.frame(replicate(ncol, sample(1:5, nrow, replace = TRUE)))
rownames(x) <- replicate(nrow, randomSentence(wrow))
colnames(x) <- replicate(ncol, randomSentence(wcol))
x
}
# @param x a single char matrix
# @param left number of empoty columns added on left side (default 0)
# @param right number of empty columns added at right side (default 0)
# @return matrix
# @keywords internal
add_empty_cols <- function(x, left = 0, right = 0) {
x <- cbind(matrix(" ", nrow = nrow(x), ncol = left), x)
x <- cbind(x, matrix(" ", nrow = nrow(x), ncol = right))
x
}
# Binds two single character matrices of different size horizontally
#
# Two matrices in atomci format are binded horizontally at a specified
# position. The matrices need to be in single char format, i.e. one character per cell
# only. If the dimensions are different, the margins of the matrices are filled up with
# empty cells.
#
# @param um upper matrix (must be single char matrix)
# @param lm lower matrix (must be single char matrix)
# @param anchors two integers specifying at which columns matrices are aligned
# @return matrix
#
# @keywords internal
# @examples \dontrun{
# um <- matrix("u", ncol=10, nrow=5)
# lm <- matrix("l", ncol=8, nrow=3)
# bind_matrices_horizontally(um, lm, anchors=c(3,1))
# }
bind_matrices_horizontally <- function(um, lm, anchors = c(1, 1)) {
diff.left <- diff(anchors) # add columns on left side
if (diff.left <= 0) {
um.ncols.empty.left <- 0
lm.ncols.empty.left <- abs(diff.left)
} else {
um.ncols.empty.left <- abs(diff.left)
lm.ncols.empty.left <- 0
}
um <- add_empty_cols(um, left = um.ncols.empty.left)
lm <- add_empty_cols(lm, left = lm.ncols.empty.left)
diff.right <- diff(c(ncol(um), ncol(lm))) # add columns on right side
if (diff.right <= 0) {
um.ncols.empty.right <- 0
lm.ncols.empty.right <- abs(diff.right)
} else {
um.ncols.empty.right <- abs(diff.right)
lm.ncols.empty.right <- 0
}
um <- add_empty_cols(um, right = um.ncols.empty.right)
lm <- add_empty_cols(lm, right = lm.ncols.empty.right)
rbind(um, lm)
}
# break at any point possible
break_output <- function(mat, ncolkeep = 14, keeprows = TRUE) {
availchar <- options()$width # get console size (problematic update)
# print(availchar)
# if (availchar < ncolkeep) # set FALSE to avoid endless recursion
# keeprows <- FALSE
if (ncol(mat) >= availchar) {
mat.tmp <- mat[, 1:(availchar - 1)]
out.tmp <- collapse_matrix(mat.tmp, collapse = "") # collapse rows
matrix_to_console(out.tmp) # print first part to console
cat("\n") # empty line after print out to separate prints
# if (keeprows) { # rownames after each pagebreak?
# mat.residual <- mat[ , c(1:(ncolkeep), availchar:ncol(mat))]
# } else {
mat.residual <- mat[, c(availchar:ncol(mat)), drop = FALSE]
# }
Recall(mat.residual) # recursive output call
} else {
out <- collapse_matrix(mat, collapse = "") # collapse rows
matrix_to_console(out) # print to console
}
}
trim_string <- function(vec, trim = NA) {
if (!is.na(trim)) {
vec <- substr(vec, 1, trim)
}
vec
}
make_sep_mat_atomic <- function(sep, nr) {
sep.atomic <- strsplit(sep, "")[[1]]
matrix(sep.atomic,
nrow = nr,
ncol = nchar(sep), byrow = TRUE
)
}
#' Colorize matrix cell rows using crayon colors
#'
#' Atomic matrices can be wrapped into crayon color codes without
#' destroying the structure or alignment. Used to indicate
#' preferred poles.
#'
#' @param m A matrix.
#' @param colors crayon colors as a string. One of
#' black, red, green, yellow, blue, magenta, cyan, white,
#' silver.
#' @export
#' @keywords internal
#' @examples
#' m <- as.matrix(mtcars)
#' colorize_matrix_rows(m, "red")
#'
colorize_matrix_rows <- function(m, colors = "white", na.val = "white") {
if (!crayon::has_color()) {
return(m)
}
nr <- nrow(m)
if (length(colors) == 1) {
colors <- rep(colors, nr)
}
if (length(colors) != nr) {
stop("Length of colors must match number of matrix rows", call. = FALSE)
}
# colorize by row
colors[is.na(colors)] <- na.val
cc <- colors %in% c("black", "red", "green", "yellow", "blue", "magenta", "cyan", "white", "silver")
if (!all(cc)) {
stop("Only crayon colors are allowed", call. = FALSE)
}
ii <- seq_len(nr)
for (i in ii) {
color_fun <- match.fun(colors[i])
m[i, ] <- color_fun(m[i, ])
}
m
}
df_out <- function(df, # data frame
left = NA, # rows left
right = NA, # rows right
showopt = 1, # options where to place left and right matrix
# 0=none, 1 = left and right, 2= both left, 3=both right
just.rows = "r", # justification of row names
just.main = "l", # justification of body
max.char.rows = 200, # max no of chars of row names to be printed
sep = " ", # separator symbol between columns
sep2 = " ", # separator between row names and first column
equal = FALSE, # equal width for columns (max column width)
prefix = "", # optional prefix before printed column name
# (e.g. "+---"). characters
keeprows = T, # whether to show rows after each pagebreak
colstart = "l",
margin = 1, # right margin for linebreak
trim = c(NA, NA), # maximum number of character for r/c entry.
cut = c(NA, NA), # maximal number of chars left and right of main matrix
id = c(T, T), # id numbers at beginning/end of each row/column
hatform = FALSE) # column names in hat form
{
# sanity checks
if (length(trim) == 1) { # if only one parameter given, extend to the other
trim <- recycle(trim, 2)
}
if (length(cut) == 1) {
cut <- recycle(cut, 2)
}
if (length(id) == 1) {
id <- recycle(id, 2)
}
if (!identical(left, NA) & !identical(right, NA)) {
if (length(left) != length(right)) {
stop("left and right must have the same length")
}
if (length(left) != nrow(df) | length(right) != nrow(df)) {
stop("left and/or right must equal number of rows in df")
}
}
# main matrix mat.m
make_mat_main <- function(df) {
mat.m <- sapply(df, as.character) # convert to character for type security
rownames(mat.m) <- NULL # unnecessary
colnames(mat.m) <- NULL # unnecessary
mat.m <- as.matrix(mat.m) # convert to matrix,
if (nrow(df) == 1) { # re-transpose in single row case
mat.m <- t(mat.m)
}
nchar.column <- widths_matrix_columns(mat.m) # no of chars per column
if (equal) { # equal or dynamic column width
mat.m <- format(mat.m, justify = just.main, width = max(nchar.column))
} else {
mat.m <- trim_column_width(mat.m, just = just.main)
}
mat.m
}
# vec vector of strings to be made as column matrix
# idside side at which id is attached (1=start, 2=end)
# trim number of chars to trim strings to
# just justification of text (l, c, r)
make_mat_leftright <- function(vec, id = TRUE, idside = 1, trim = NA, just = "r") {
if (!is.na(trim)) { # trim rownames
left <- substr(vec, 1, trim)
}
if (id) { # add id number to each row
ids <- paste("(", seq_along(vec), ")", sep = "")
if (idside == 1) { # ids at start of string (for right side constructs)
vec <- paste(ids, vec)
} else {
vec <- paste(vec, ids)
} # ids at end of string (for left side constructs)
}
vec <- format(vec, justify = just) # justify rownames
as.matrix(vec)
}
# make left and right matrices
mat.left <- matrix("", nrow = nrow(df), ncol = 0) # default void matrix to start from
mat.right <- matrix("", nrow = nrow(df), ncol = 0) # default void matrix to start from
if (!identical(left, NA)) { # trimming occures in all cases if prompted
left <- trim_string(left, trim = trim[1])
}
if (!identical(right, NA)) {
right <- trim_string(right, trim = trim[1])
}
leftright <- paste(left, right, sep = " - ") # join left and right strings
# decision where and how to put left and right vectors
if (showopt == 1) { # #1 left to left, right to right
if (!identical(left, NA)) {
mat.left <- make_mat_leftright(left, id = id[1], idside = 2, just = "r")
}
if (!identical(right, NA)) {
mat.right <- make_mat_leftright(right, id = id[1], idside = 1, just = "l")
}
} else if (showopt == 2) { # #2 left and right on left side
if (!identical(left, NA) & !identical(right, NA)) {
mat.left <- make_mat_leftright(leftright, id = id[1], idside = 2, just = "r")
} else if (identical(left, NA) & !identical(right, NA)) {
mat.left <- make_mat_leftright(right, id = id[1], idside = 2, just = "r")
} else if (!identical(left, NA) & identical(right, NA)) {
mat.left <- make_mat_leftright(left, id = id[1], idside = 2, just = "r")
}
} else if (showopt == 3) { # #3 left and right on right side
if (!identical(left, NA) & !identical(right, NA)) {
mat.right <- make_mat_leftright(leftright, id = id[1], idside = 1, just = "l")
} else if (identical(left, NA) & !identical(right, NA)) {
mat.right <- make_mat_leftright(right, id = id[1], idside = 1, just = "l")
} else if (!identical(left, NA) & identical(right, NA)) {
mat.right <- make_mat_leftright(left, id = id[1], idside = 1, just = "l")
}
} # #0 left and right unused, mat.left and mat.right remain void
mat.m <- make_mat_main(df)
mat.m.atomic <- matrix_to_single_char_matrix(mat.m, collapse = sep)
mat.left.atomic <- matrix_to_single_char_matrix(mat.left)
mat.right.atomic <- matrix_to_single_char_matrix(mat.right)
widths.columns <- widths_matrix_columns(mat.m) # vector column widths
widths.sep1 <- nchar(sep)
widths.sep2 <- nchar(sep2)
# where to place colnames in matrix upper
columns.start.r <- cumsum(widths.columns + widths.sep1) - widths.sep1
columns.start.l <- columns.start.r - widths.columns + 1
columns.start.cl <- columns.start.l + floor((widths.columns + 1) / 2)
columns.start.cr <- columns.start.l + ceiling((widths.columns + 1) / 2)
# select column start vector
if (colstart == "r") {
columns.start <- columns.start.r
} else if (colstart == "cl") {
columns.start <- columns.start.cl
} else if (colstart == "cr") {
columns.start <- columns.start.cr
} else {
columns.start <- columns.start.l
}
# maximal rows of mat.u is length of column name plus starting position (plus prefix)
names.columns <- colnames(df) # extract colnames
if (!is.na(trim[2])) { # trim colnames
names.columns <- substr(names.columns, 1, trim[2])
}
### hat = FALSE (upper matrix u in descending form)
if (!hatform) {
if (id[2]) { # add id number to each col
ids <- paste(seq_along(names.columns), "-", sep = " ")
names.columns <- paste(ids, names.columns)
}
names.columns <- paste(prefix, names.columns, sep = "") # add prefix (default "")
ncol.mat.columns <- max(columns.start +
nchar(names.columns) - 1) # min no columns mat.u
nrow.mat.columns <- length(names.columns) + 1
mat.u.atomic <- matrix(" ",
nrow = nrow.mat.columns, # empty matrix
ncol = ncol.mat.columns
)
# fill matrix upper
names.atomic.list <- strsplit(names.columns, "")
lengths.colnames <- nchar(names.columns)
for (j in seq_along(columns.start)) { # vertical lines ("|") at column starts
mat.u.atomic[(j + 1):nrow(mat.u.atomic), columns.start[j]] <- "|"
mat.u.atomic[j, columns.start[j]:(columns.start[j] +
lengths.colnames[j] - 1)] <- names.atomic.list[[j]]
}
extra.cols.left <- 0 # to suit results of hat=TRUE part
}
### hat = TRUE (upper matrix u in hat form)
if (hatform) {
ncol <- length(names.columns) # no of columns
midcol <- ceiling((ncol + 1) / 2) # determine middle column
index.cols.left <- 1:(midcol - 1) # index of left columns
index.cols.right <- midcol:ncol # index of right columns
colnames.left <- names.columns[index.cols.left] # left hat side
colnames.right <- names.columns[index.cols.right] # right hat side
if (id[2]) { # add id number to each col
ids.left <- seq_along(names.columns)[index.cols.left]
ids.right <- seq_along(names.columns)[index.cols.right]
colnames.left <- paste(colnames.left, ids.left, sep = " - ")
colnames.right <- paste(ids.right, colnames.right, sep = " - ")
}
# add prefix to both sides (default "")
colnames.left <- paste(colnames.left, strReverse(prefix), sep = "") # left side has revesred prefix
colnames.right <- paste(prefix, colnames.right, sep = "")
colnames.leftright <- c(colnames.left, colnames.right)
lengths.colnames <- nchar(colnames.leftright)
minpos <- min(columns.start[index.cols.left] - nchar(colnames.left)) # min pos to left
maxpos <- max(columns.start[index.cols.right] + nchar(colnames.right)) # max pos to right
if (minpos < 0) {
extra.cols.left <- abs(minpos)
} else {
extra.cols.left <- 0
}
ncol.mat.upper <- extra.cols.left + maxpos # ncol of upper matrix
nrow.mat.upper <- max(c(length(colnames.left), length(colnames.right))) + 1 # nrow of upper matrix
mat.u.atomic <- matrix(" ",
nrow = nrow.mat.upper, # empty upper matrix to get filled
ncol = ncol.mat.upper
)
names.atomic.list.left <- strsplit(colnames.left, "")
names.atomic.list.right <- strsplit(colnames.right, "")
names.atomic.list.leftright <- c(
names.atomic.list.left,
names.atomic.list.right
)
# fill matrix u and build vertical lines for left and right side
bottom.row <- nrow(mat.u.atomic)
nc <- length(columns.start)
columns.start.offsetted <- extra.cols.left + columns.start
for (j in seq_along(columns.start)) { # vertical lines ("|") at column starts
if (j < ceiling((nc + 1) / 2)) {
mat.u.atomic[
(bottom.row - j + 1):bottom.row,
columns.start.offsetted[j]
] <- "|"
mat.u.atomic[
(bottom.row - j),
(columns.start.offsetted[j] - lengths.colnames[j] + 1):
columns.start.offsetted[j]
] <-
names.atomic.list.leftright[[j]]
} else {
mat.u.atomic[
(bottom.row - (nc - j) - 1):bottom.row,
columns.start.offsetted[j]
] <- "|"
mat.u.atomic[(bottom.row - (nc - j) - 1), columns.start.offsetted[j]:
(columns.start.offsetted[j] + lengths.colnames[j] - 1)] <-
names.atomic.list.leftright[[j]]
}
} # TODO: right side one row too much, maybe erase
}
# colorize constructs by pole preference
# TODO: Extract pole preferences here
# rows <- nrow(mat.left.atomic)
# colors_ <- sample(c("red", "green", "yellow", "silver", "white"), rows, T)
mat.left.atomic <- colorize_matrix_rows(mat.left.atomic, "white")
mat.right.atomic <- colorize_matrix_rows(mat.right.atomic, "white")
# browser()
# same part for both types
mat.sep2.atomic <- make_sep_mat_atomic(sep2, nr = nrow(df)) # matrix to separate left and main, or main and right
mat.lm.atomic <- cbind(
mat.left.atomic, mat.sep2.atomic, mat.m.atomic, # lower matrix lm
mat.sep2.atomic, mat.right.atomic
)
# join upper and lower matrix
anchor.um <- extra.cols.left + 1
anchor.lm <- ncol(mat.left.atomic) + ncol(mat.sep2.atomic) + 1
mat.out.atomic <- bind_matrices_horizontally(mat.u.atomic, mat.lm.atomic,
anchors = c(anchor.um, anchor.lm)
)
# cut output at sides if prompted
diff.left <- diff(c(anchor.um, anchor.lm))
if (diff.left <= 0) {
lm.empty.cols.left <- abs(diff.left)
} else {
lm.empty.cols.left <- 0
}
start.main.at <- lm.empty.cols.left + ncol(cbind(mat.left.atomic, mat.sep2.atomic))
end.main.at <- start.main.at + ncol(mat.m.atomic)
if (!is.na(cut[1]) | !is.na(cut[2])) {
if (is.na(cut[1])) {
end.left <- 1
} else {
end.left <- trim_val(start.main.at - cut[1], minmax = c(1, 200))
}
if (is.na(cut[2])) {
end.right <- ncol(mat.out.atomic)
} else {
end.right <- trim_val(end.main.at + cut[2],
minmax = c(1, ncol(mat.out.atomic))
)
}
mat.out.atomic <- mat.out.atomic[, end.left:end.right]
}
break_output(mat.out.atomic)
invisible(NULL)
}
# df <- random_df(10, 25, wcol=4)
# left <- randomSentences(10, 5)
# right <- randomSentences(10, 5)
# df_out(df, left, right, h=T, cut=25, id=T, show=1)
# Show method -------------------------------------------------
# repgrid show method
# @usage \S4method{show}{repgrid}(object)
# show method for repgrid class
# org <- list()
# org$show$cut <- 30
# org$show$showopt <- 1
# org$show$verbose <- TRUE
# method depends on the definition of the 'repgrid' object
# hence has to come before this code in COLLATE tag in DESCRIPTION
# @aliases show,repgrid-method
# Show method for repgrid
#
# @param object a `repgrid` object
# @docType methods
# @usage \S4method{show}{repgrid}(object)
# @include repgrid.r
#
#' Show method for repgrid
#'
#' @param object A `repgrid` object.
#' @include repgrid.r
#'
setMethod("show", "repgrid", function(object) {
pars <- settings()
trim <- c(pars$show.trim, pars$show.trim) # trim <- c(30,30)
cut <- c(pars$show.cut, pars$show.cut) # cut <- c(20,20)
verbose <- TRUE # what parts to print TRUE prints all information about the grid
showopt <- 1
id <- c(pars$c.no, pars$e.no) # c(T,T)
hatform <- T
x <- object
do.bertin <- FALSE
# verbose output displays all grid information available
if (verbose) {
# print meta data
if (pars$show.meta) showMeta(x)
if (pars$show.scale) showScale(x) # print scale info
cat("\nRATINGS:\n")
}
# make data frame for left and right constructs
con <- constructs(x)
# make data frame for data
df.ratings <- as.data.frame(x@ratings[, , 1, drop = FALSE]) # extract scores
colnames(df.ratings) <- elements(x) # name columns
left <- con[, 1]
right <- con[, 2]
df_out(df.ratings, left, right,
just.main = "r", hatform = hatform, id = id,
trim = trim, cut = cut, equal = F, showopt = showopt
)
cat("\n")
if (do.bertin) {
bertin(x)
}
})
# # Show method for repgrid
# # @param repgrid object
# setMethod("show", signature= "repgrid", function(object){
# x <- object
# showMeta(x)
# showScale(x) #print scale info
# })
# output version for repertory grids:
# parameters
#
# conside integer to describe side where to print constructs
# 0 no constructs, 1 left side only, 2 both sides, 3 right side only
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.