R/repgrid-output.r

In markheckmann/OpenRepGrid: Tools to Analyze Repertory Grid Data

# 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