# //////////////////////////////////////////////////////////////////////////////
#
# BERTIN DISPLAYS a.k.a. HEATMAPS
#
# //////////////////////////////////////////////////////////////////////////////
constructCellGrob <- function(text, gp = gpar(), horiz = TRUE) {
gp <- modifyList(gpar(fill = grey(.95)), gp)
col <- gmSelectTextColorByLuminance(gp$fill)
gTree(children = gList(
rectGrob(
width = 1, height = 1,
gp = gpar(fill = gp$fill, col = "white")
),
gmSplitTextGrob(text = text, horiz = horiz, gp = modifyList(gp, gpar(col = col)))
))
}
bertin1 <- function(x, draw = TRUE) {
if (!inherits(x, "repgrid")) {
stop("Object must be of class 'repgrid'")
}
# determine color range (shades of grey)
nrow <- nrow(x@ratings)
ncol <- ncol(x@ratings)
# settings
height.element.label <- 5
height.cell <- unit(3, "mm")
height.fg.top <- unit(ncol * height.element.label, "mm")
bertinCell <- function(label, fill) {
textColor <- gmSelectTextColorByLuminance(fill)
gTree(children = gList(
rectGrob(
width = 1, height = 1,
gp = gpar(fill = fill, col = "white")
),
textGrob(label = label, gp = gpar(lineheight = .7, cex = .6, col = textColor))
))
}
# rating framegrob
dp.fg <- frameGrob(grid.layout(nrow = nrow, ncol = ncol, respect = F))
scale.range <- x@scale$max - x@scale$min
for (row in seq_len(nrow)) {
for (col in seq_len(ncol)) {
score <- x@ratings[row, col, 1]
rg <- bertinCell(label = score, fill = grey((score - x@scale$min) / scale.range))
dp.fg <- placeGrob(dp.fg, rg, row = row, col = col)
}
}
# left framegrob (initial pole)
left.c.fg <- frameGrob(grid.layout(nrow = nrow, ncol = 1))
for (row in seq_len(nrow)) {
label <- x@constructs[[row]]$leftpole$name
tg <- textGrob(label = label, gp = gpar(cex = .6))
left.c.fg <- placeGrob(left.c.fg, tg, row = row)
}
# top framegrob (elements)
top.e.fg <- frameGrob(grid.layout(ncol = ncol, nrow = ncol + 1, respect = F))
rg <- rectGrob(
gp = gpar(fill = "black", col = "white"),
vp = viewport(width = unit(1, "points"))
)
for (row in seq_len(ncol)) {
label <- x@elements[[row]]$name
tg <- textGrob(label = label, x = .4, just = "left", gp = gpar(cex = .6))
top.e.fg <- placeGrob(top.e.fg, tg, row = row, col = row)
top.e.fg <- placeGrob(top.e.fg, rg, row = row:ncol + 1, col = row)
}
# combine framegrobs
main.fg <- frameGrob(grid.layout(nrow = 4, ncol = 3, heights = c(.1, 2, 2, .2), widths = c(1, 2, 1)))
main.fg <- placeGrob(main.fg, top.e.fg, row = 2, col = 2)
main.fg <- placeGrob(main.fg, left.c.fg, row = 3, col = 1)
main.fg <- placeGrob(main.fg, dp.fg, row = 3, col = 2)
main.fg <- placeGrob(main.fg, left.c.fg, row = 3, col = 3)
if (draw) grid.draw(main.fg) else main.fg
}
bertin2 <- function(x, ratings = TRUE, top = unit(40, "mm"), sides = unit(40, "mm"),
left = sides, right = sides,
cell = unit(6, "mm"), cell.height = cell, cell.width = cell,
gp.cells = gpar(), gp.constructs = gpar(), gp.elements = gpar(),
bg.col = grey(.95), colors = c("white", "black"), draw = TRUE) {
if (!inherits(x, "repgrid")) {
stop("Object must be of class 'repgrid'")
}
gp.cells <- modifyList(gpar(lineheight = .7, cex = .6, fill = bg.col), gp.cells)
gp.constructs <- modifyList(gpar(lineheight = .7, cex = .8, fill = bg.col), gp.constructs)
gp.elements <- modifyList(gpar(lineheight = .7, cex = .8, fill = bg.col), gp.elements)
# determine color range (shades of grey)
nrow <- nrow(x@ratings)
ncol <- ncol(x@ratings)
height.top <- top
width.left <- left
width.right <- right
height.cell <- cell.height
width.cell <- cell.width
height.body <- nrow * height.cell
width.body <- ncol * width.cell
bertinCell <- function(label, fill, gp = gpar(), ratings = TRUE) {
textColor <- gmSelectTextColorByLuminance(fill)
gp <- modifyList(gp, gpar(col = textColor))
if (ratings) tg <- textGrob(label = label, gp = gp) else tg <- nullGrob()
gTree(children = gList(
rectGrob(
width = 1, height = 1,
gp = gpar(fill = fill, col = "white")
),
tg
))
}
# rating framegrob
colorFun <- makeStandardRangeColorRamp(colors)
dp.fg <- frameGrob(grid.layout(nrow = nrow, ncol = ncol, respect = F))
scale.range <- x@scale$max - x@scale$min
scale.min <- x@scale$min
for (row in seq_len(nrow)) {
for (col in seq_len(ncol)) {
score <- x@ratings[row, col, 1]
rg <- bertinCell(label = score, fill = colorFun((score - scale.min) / scale.range), gp = gp.cells, ratings = ratings)
dp.fg <- placeGrob(dp.fg, rg, row = row, col = col)
}
}
# left framegrob (initial pole)
left.c.fg <- frameGrob(grid.layout(nrow = nrow, ncol = 1))
for (row in seq_len(nrow)) {
text <- x@constructs[[row]]$leftpole$name
tg <- constructCellGrob(text = text, gp = gp.constructs)
left.c.fg <- placeGrob(left.c.fg, tg, row = row)
}
# right framegrob (contrast pole)
right.c.fg <- frameGrob(grid.layout(nrow = nrow, ncol = 1))
for (row in seq_len(nrow)) {
text <- x@constructs[[row]]$rightpole$name
tg <- constructCellGrob(text = text, gp = gp.constructs)
right.c.fg <- placeGrob(right.c.fg, tg, row = row)
}
# top framegrob (elements)
top.e.fg <- frameGrob(grid.layout(ncol = ncol, nrow = 1))
for (col in seq_len(ncol)) {
text <- x@elements[[col]]$name
tg <- constructCellGrob(text = text, horiz = FALSE, gp = gp.elements)
top.e.fg <- placeGrob(top.e.fg, tg, row = NULL, col = col)
}
# combine framegrobs
main.fg <- frameGrob(grid.layout(nrow = 2, ncol = 3, heights = unit.c(height.top, height.body), widths = unit.c(width.left, width.body, width.right)))
main.fg <- placeGrob(main.fg, top.e.fg, row = 1, col = 2)
main.fg <- placeGrob(main.fg, left.c.fg, row = 2, col = 1)
main.fg <- placeGrob(main.fg, dp.fg, row = 2, col = 2)
main.fg <- placeGrob(main.fg, right.c.fg, row = 2, col = 3)
if (draw) grid.draw(main.fg) else main.fg
}
bertin2PlusLegend <- function(x, ratings = TRUE, top = unit(40, "mm"),
sides = unit(40, "mm"), left = sides, right = sides,
cell = unit(6, "mm"), cell.height = cell, cell.width = cell,
gp.cells = gpar(), gp.constructs = gpar(), gp.elements = gpar(),
bg.col = grey(.95), colors = c("white", "black"), draw = TRUE,
vspace = unit(2, "mm"), legend.just = "left", legend.height = unit(10, "mm"),
legend.width = unit(40, "mm")) {
fg.bertin <- bertin2(
x = x, ratings = ratings, top = top,
sides = sides, left = left, right = right,
cell = cell, cell.height = cell.height, cell.width = cell.width,
gp.cells = gp.cells, gp.constructs = gp.constructs, gp.elements = gp.elements,
bg.col = bg.col, colors = colors, draw = FALSE
)
widths <- fg.bertin$framevp$layout$widths
heights <- fg.bertin$framevp$layout$heights
nrow <- fg.bertin$framevp$layout$nrow
ncol <- fg.bertin$framevp$layout$ncol
colorFun <- makeStandardRangeColorRamp(colors)
lg <- gmLegend2(colorFun(c(0, 1)), c("left pole", "right pole"), ncol = 2, byrow = F)
fg.legend <- frameGrob(grid.layout(widths = legend.width, just = legend.just))
fg.legend <- placeGrob(fg.legend, lg)
fg.main <- frameGrob(grid.layout(
nrow = nrow + 2, heights = unit.c(heights, vspace, legend.height),
ncol = ncol, widths = widths
))
fg.main <- placeGrob(fg.main, fg.bertin, row = 1:nrow)
fg.main <- placeGrob(fg.main, fg.legend, row = nrow + 2)
if (draw) grid.draw(fg.main) else fg.main
}
# bertin2PlusLegend(rg2, colors=c("darkred", "white"))
# bertin2PlusLegend(rg2, colors=c("darkred", "white"), top=unit(4, "cm"), sides=unit(4, "cm"))
# TODO: -may work with closures here to store old row and column when marking
# rows and columns?
# -splitString has a bug, breaks too late
# -trimming of elements and constructs
#
# Workhorse for the biplot printing.
#
# Prints a bertin to the output
# device. It uses the R base graphics system and
# this is very fast. This is useful for working with grids. Not so much for
# producing high-quality output.
#
# @param x `repgrid` object.
# @param ratings Vector. rating scores are printed in the cells
# @param margins Vector of length three (default `margins=c(0,1,1)`).
# 1st element denotes the left, 2nd the upper and 3rd the
# right margin in npc coordinates (i.e. 0 to zero).
# @param trim Vector (default `trim=c(F,F)`).If a number the string
# is trimmed to the given number of characters. If set
# to TRUE the labels are trimmed to the available space
# @param add Logical. Whether to add bertin to existent plot (default is
# `FALSE`). If `TRUE, plot.new()` will not be called
# `par(new=TRUE)`.
# @return `NULL` just for printing.
#
# @export
# @keywords internal
#
bertinBase <- function(nrow, ncol, labels = "", labels.elements = "",
labels.left = "", labels.right = "",
col.text = NA, cex.text = .6, cex.elements = .7,
cex.constructs = .7, col.fill = grey(.8), border = "white",
xlim = c(0, 1), ylim = c(0, 1), margins = c(0, 1, 1), lheight = .75,
text.margin = 0.005, elements.offset = c(0.002, 0.002),
id = c(T, T), cc = 0, cr = 0, cc.old = 0, cr.old = 0,
col.mark.fill = "#FCF5A4", print = TRUE, byrow = FALSE, add = FALSE) {
if (byrow) {
labels <- as.vector(matrix(labels, nrow = nrow, ncol = ncol, byrow = TRUE))
}
col.fill <- recycle(col.fill, nrow * ncol) # recycle col.fill if too short e.g. one color
if (identical(col.text, NA)) { # if not explicitly defined replace col.text according to bg color
col.text <- gmSelectTextColorByLuminance(col.fill)
} else {
recycle(col.text, nrow * ncol)
}
# if (length(trim) == 1) # if only one parameter given, extend to the other
# trim <- recycle(trim, 2)
if (length(id) == 1) {
id <- recycle(id, 2)
}
makeMain <- function() {
rect(x1, y1, x2, y2, col = col.fill, border = border)
text(x1 + cell.width / 2, y1 + cell.height / 2, labels = labels, col = col.text, cex = cex.text)
}
makeElements <- function() { #### elements
index <- cascade(ncol, type = 2)
if (id[2]) {
labels.elements[index$left] <- paste(
labels.elements[index$left],
"-", index$left
)
labels.elements[index$right] <- paste(
index$right, "-",
labels.elements[index$right]
)
}
height.strokes <- (margins[2] - ylim[2]) / (max(cascade(ncol) + 1))
x.lines <- xlim[1] + x1.o * diff(xlim) + cell.width / 2
y1.lines <- ylim[2]
y2.lines <- y1.lines + cascade(ncol) * height.strokes # upper end of bertin main plus offset
segments(x.lines, y1.lines, x.lines, y2.lines)
text(x.lines[index$left] + elements.offset[1],
y2.lines[index$left] + elements.offset[2],
labels = labels.elements[index$left], adj = c(1, 0), cex = cex.elements, xpd = T
)
text(x.lines[index$right] - elements.offset[1],
y2.lines[index$right] + elements.offset[2],
labels = labels.elements[index$right], adj = c(0, 0), cex = cex.elements, xpd = T
)
}
makeConstructs <- function() { ### constructs
if (id[1]) {
labels.left <- paste(labels.left, " (", 1:nrow, ")", sep = "")
labels.right <- paste("(", 1:nrow, ") ", labels.right, sep = "")
}
labels.left <- baseSplitString(labels.left, availwidth = (xlim[1] - margins[1]) * .95, cex = cex.text)
labels.right <- baseSplitString(labels.right, availwidth = (margins[3] - xlim[2]) * .95, cex = cex.text)
par(lheight = lheight) # set lineheight
text(xlim[1] - text.margin, y1[1:nrow] + cell.height / 2,
labels = labels.left,
cex = cex.constructs, adj = 1, xpd = T
)
text(xlim[2] + text.margin, y1[1:nrow] + cell.height / 2,
labels = labels.right,
cex = cex.constructs, adj = 0, xpd = T
)
}
colorRow <- function(cr) {
par(new = TRUE) # next plot will overplot not earse the old one, necessary for setting the same regions
plot.new()
# plot.window(xlim=0:1, ylim=0:1) #, xaxs="i", yaxs="i")#, asp =nrow/ncol)
if (cr >= 1 & cr <= nrow) { # color current row cr
labels.rows <- labels[(1:ncol - 1) * nrow + cr]
col.mark.text <- gmSelectTextColorByLuminance(col.mark.fill)
rect(x1.rc, y1.rc[cr], x2.rc, y2.rc[cr],
col = col.mark.fill, border = border
)
text(x1.rc + cell.width / 2, y1.rc[cr] + cell.height / 2,
labels = labels.rows, col = col.mark.text, cex = cex.text
)
}
}
colorColumn <- function(cc) {
par(new = TRUE) # next plot will overplot not earse the old one, necessary for setting the same regions
plot.new()
# plot.window(xlim=0:1, ylim=0:1) #, xaxs="i", yaxs="i")#, asp =nrow/ncol)
if (cc >= 1 & cc <= ncol) { # color current column cc
labels.cols <- labels[1:nrow + (cc - 1) * nrow]
# col.fill <- col.fill[1:nrow + (cc-1)*nrow]
# col.text=gmSelectTextColorByLuminance(col.fill)
col.mark.text <- gmSelectTextColorByLuminance(col.mark.fill)
rect(x1.rc[cc], y1.rc, x2.rc[cc], y2.rc,
col = col.mark.fill, border = border
)
text(x1.rc[cc] + cell.width / 2, y1.rc + cell.height / 2,
labels = labels.cols, col = col.mark.text, cex = cex.text
)
# color vertical stroke
height.strokes <- (1 - ylim[2]) / (max(cascade(ncol) + 1))
x.lines <- xlim[1] + x1.o * diff(xlim) + cell.width / 2
y1.lines <- ylim[2]
y2.lines <- y1.lines + cascade(ncol) * height.strokes
segments(x.lines[cc], y1.lines, x.lines[cc], y2.lines[cc], lwd = 3, col = "white") # overplot old stroke in white
segments(x.lines[cc], y1.lines, x.lines[cc], y2.lines[cc], col = col.mark.fill)
}
}
renewColumn <- function(cc) {
if (cc >= 1 & cc <= ncol) {
# vertical stroke
height.strokes <- (1 - ylim[2]) / (max(cascade(ncol) + 1))
x.lines <- xlim[1] + x1.o * diff(xlim) + cell.width / 2
y1.lines <- ylim[2]
y2.lines <- y1.lines + cascade(ncol) * height.strokes
segments(x.lines[cc], y1.lines, x.lines[cc], y2.lines[cc], lwd = 3, col = "white") # overplot old stroke in white
segments(x.lines[cc], y1.lines, x.lines[cc], y2.lines[cc], col = "black")
# plot rects and text
labels.cols <- labels[1:nrow + (cc - 1) * nrow]
col.fill <- col.fill[1:nrow + (cc - 1) * nrow]
col.text <- gmSelectTextColorByLuminance(col.fill)
rect(x1.rc[cc], y1.rc, x2.rc[cc], y2.rc,
col = col.fill, border = border
)
text(x1.rc[cc] + cell.width / 2, y1.rc + cell.height / 2,
labels = labels.cols, col = col.text, cex = cex.text
)
}
}
renewRow <- function(cr) {
if (cr >= 1 & cr <= nrow) {
# plot rects and text
labels.rows <- labels[(1:ncol - 1) * nrow + cr]
col.fill <- col.fill[(1:ncol - 1) * nrow + cr]
col.text <- gmSelectTextColorByLuminance(col.fill)
rect(x1.rc, y1.rc[cr], x2.rc, y2.rc[cr],
col = col.fill, border = border
)
text(x1.rc + cell.width / 2, y1.rc[cr] + cell.height / 2,
labels = labels.rows, col = col.text, cex = cex.text
)
}
}
# make basic calculations
x1.o <- 0:(ncol - 1) / ncol
x2.o <- 1:ncol / ncol
y1.o <- rev(0:(nrow - 1) / nrow)
y2.o <- rev(1:nrow / nrow)
x1 <- rep(x1.o, each = nrow)
x2 <- rep(x2.o, each = nrow)
y1 <- rep(y1.o, ncol)
y2 <- rep(y2.o, ncol)
x1 <- xlim[1] + x1 * diff(xlim) # rescale coordinates according to given limits
x2 <- xlim[1] + x2 * diff(xlim)
y1 <- ylim[1] + y1 * diff(ylim)
y2 <- ylim[1] + y2 * diff(ylim)
cell.width <- diff(xlim) / ncol
cell.height <- diff(ylim) / nrow
x1.rc <- x1[(1:ncol) * nrow] # calc coords for row and col starts and ends
x2.rc <- x2[(1:ncol) * nrow]
y1.rc <- y1[1:nrow]
y2.rc <- y2[(1:nrow)]
# set plotting parameters
# old.par <- par(no.readonly = TRUE) # save parameters
# on.exit(par(old.par)) # reset old par when done
op <- par(oma = rep(0, 4), mar = rep(0, 4), xaxs = "i", yaxs = "i")
if (print) { # in case no new printing should occur
par(new = FALSE)
} else {
par(new = TRUE)
}
if (add) { # will bertin be added to existent plot?
par(new = TRUE)
}
plot.new()
# plot.window(xlim=0:1, ylim=0:1) #, xaxs="i", yaxs="i")#, asp =nrow/ncol)
# plotting
if (print) {
makeMain()
makeElements()
makeConstructs()
colorRow(cr) # color current row or column
colorColumn(cc)
} else {
renewColumn(cc.old)
renewRow(cr.old)
colorRow(cr)
colorColumn(cc)
}
# par(op)
invisible(NULL)
}
# bertinBase(20, 70, xlim=c(.2,.8), ylim=c(0,.4))
# bertinBase(10,20)
# bertinBase(10,20, xlim=c(0.1, .9), ylim=c(.2, .8), cex.text=.8)
# bertinBase(20, 30, grey(runif(13)), cex.text=.6)
# labels <- randomSentences(20, 6)
# bertinBase(20, 70, xlim=c(.25,.75), ylim=c(.1,.4), margins=c(.03,.9,.97), id=F,
# labels.l=labels, labels.ri=labels, labels.el=rep(labels, 4))
# x <- randomGrid(20, 40)
# nc <- length(x@constructs)
# ne <- length(x@elements)
# color <- c("darkred", "white", "darkgreen")
# colorFun <- makeStandardRangeColorRamp(color)
# scale.min <- x@scale$min
# scale.max <- x@scale$max
# scores <- as.vector(x@ratings[,,1])
# col.fill <- colorFun((scores-scale.min)/(scale.max-scale.min))
# bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, border="white")
# bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, border="white", cc=10, cr=10, pri=F)
# bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, border="white", cc.old=10, pri=F)
# bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, border="white", cr.old=10, pri=F)
# bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, border="white")
# for (row in 1:10){
# for (col in 1:15) {
# bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6,
# border="white", cc=col, cr=row, cc.old=col -1, cr.old=row-1, pri=F)
# Sys.sleep(.2)
# }
# }
#' Make Bertin display of grid data.
#'
#' One of the most popular ways of displaying grid data has been adopted from Bertin's (1974) graphical proposals,
#' which have had an immense influence onto data visualization. One of the most appealing ideas presented by Bertin is
#' the concept of the reorderable matrix. It is comprised of graphical displays for each cell, allowing to identify
#' structures by eye-balling reordered versions of the data matrix (see Bertin, 1974). In the context of repertory
#' grids, the display is made up of a simple colored rectangle where the color denotes the corresponding score. Bright
#' values correspond to low, dark to high scores. For an example of how to analyze a Bertin display see e.g. Dick
#' (2000) and Raeithel (1998).
#'
#' @param x `repgrid` object.
#' @param colors Vector. Two or more colors defining the color ramp for
#' the bertin (default `c("white", "black")`).
#' @param showvalues Logical. Whether scores are shown in bertin
#' @param xlim Vector. Left and right limits inner bertin (default
#' `c(.2, .8)`).
#' @param ylim Vector. Lower and upper limits of inner bertin
#' default(`c(.0, .6)`).
#' @param margins Vector of length three (default `margins=c(0,1,1)`).
#' 1st element denotes the left, 2nd the upper and 3rd the
#' right margin in npc coordinates (i.e. 0 to zero).
#' @param cex.elements Numeric. Text size of element labels (default `.7`).
#' @param cex.constructs Numeric. Text size of construct labels (default `.7`).
#' @param cex.text Numeric. Text size of scores in bertin cells (default `.7`).
#' @param col.text Color of scores in bertin (default `NA`). By default
#' the color of the text is chosen according to the
#' background color. If the background ist bright the text
#' will be black and vice versa. When a color is specified
#' the color is set independent of background.
#' @param border Border color of the bertin cells (default `white`).
#' @param lheight Line height for constructs.
#' @param id Logical. Whether to print id number for constructs and elements
#' respectively (default `c(T,T)`).
#' @param cc Numeric. Current column to mark.
#' @param cr Numeric. Current row to mark.
#' @param cc.old Numeric. Column to unmark.
#' @param cr.old Numeric. Row to unmark.
#' @param col.mark.fill Color of marked row or column (default `"#FCF5A4"`).
#' @param print Print whole bertin. If `FALSE` only current and old
#' row and column are printed.
#' @param ... Optional arguments to be passed on to `bertinBase`.
#'
#' @return `NULL` just for the side effects, i.e. printing.
#'
#' @export
#' @references Bertin, J. (1974). *Graphische Semiologie: Diagramme, Netze, Karten*. Berlin, New York: de Gruyter.
#'
#' Dick, M. (2000). The Use of Narrative Grid Interviews in Psychological Mobility Research. *Forum Qualitative
#' Sozialforschung / Forum: Qualitative Social Research, 1*(2).
#'
#' Raeithel, A. (1998). Kooperative Modellproduktion von Professionellen und Klienten - erlauetert am Beispiel des
#' Repertory Grid. *Selbstorganisation, Kooperation, Zeichenprozess: Arbeiten zu einer kulturwissenschaftlichen,
#' anwendungsbezogenen Psychologie* (pp. 209-254). Opladen: Westdeutscher Verlag.
#'
#' @examples
#'
#' bertin(feixas2004)
#' bertin(feixas2004, c("white", "darkblue"))
#' bertin(feixas2004, showvalues = FALSE)
#' bertin(feixas2004, border = "grey")
#' bertin(feixas2004, cex.text = .9)
#' bertin(feixas2004, id = c(FALSE, FALSE))
#'
#' bertin(feixas2004, cc = 3, cr = 4)
#' bertin(feixas2004, cc = 3, cr = 4, col.mark.fill = "#e6e6e6")
#'
bertin <- function(x, colors = c("white", "black"), showvalues = TRUE,
xlim = c(.2, .8), ylim = c(0, .6), margins = c(0, 1, 1),
cex.elements = .7, cex.constructs = .7, cex.text = .6, col.text = NA,
border = "white", lheight = .75, id = c(T, T),
cc = 0, cr = 0, cc.old = 0, cr.old = 0, col.mark.fill = "#FCF5A4", print = TRUE,
...) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'")
}
nc <- length(x@constructs)
ne <- length(x@elements)
colorFun <- makeStandardRangeColorRamp(colors)
scale.min <- x@scale$min
scale.max <- x@scale$max
scores <- as.vector(x@ratings[, , 1])
scores.standardized <- (scores - scale.min) / (scale.max - scale.min)
col.fill <- colorFun(scores.standardized)
if (!showvalues) {
scores <- recycle("", nc * ne)
}
bertinBase(
nrow = nc, ncol = ne, labels = scores, labels.elements = elements(x),
labels.left = constructs(x)$leftpole,
labels.right = constructs(x)$rightpole,
col.fill = col.fill,
xlim = xlim, ylim = ylim, margins = margins,
cex.elements = cex.elements, cex.constructs = cex.elements,
cex.text = cex.text, col.text = col.text,
border = border, lheight = lheight, id = id, cc = cc, cr = cr, cc.old = cc.old, cr.old = cr.old,
col.mark.fill = col.mark.fill, print = print, ...
)
invisible(NULL)
}
#' Bertin display with corresponding cluster analysis.
#'
#' Element columns and constructs rows are ordered according to cluster criterion. Various distance measures as well as
#' cluster methods are supported.
#'
#' @param x `repgrid` object.
#' @param dmethod The distance measure to be used. This must be one of
#' `"euclidean"`, `"maximum"`, `"manhattan"`,
#' `"canberra"`, `"binary"`, or `"minkowski"`.
#' Default is `"euclidean"`.
#' Any unambiguous substring can be given (e.g. `"euc"`
#' for `"euclidean"`).
#' A vector of length two can be passed if a different distance measure for
#' constructs and elements is wanted (e.g.`c("euclidean", "manhattan")`).
#' This will apply euclidean distance to the constructs and
#' manhattan distance to the elements.
#' For additional information on the different types see
#' `?dist`.
#' @param cmethod The agglomeration method to be used. This should be (an
#' unambiguous abbreviation of) one of `"ward.D"`, `"ward.D2"`,
#' `"single"`, `"complete"`, `"average"`, `"mcquitty"`, `"median"` or `"centroid"`.
#' Default is `"ward.D"`.
#' A vector of length two can be passed if a different cluster method for
#' constructs and elements is wanted (e.g.`c("ward.D", "euclidean")`).
#' This will apply ward clustering to the constructs and
#' single linkage clustering to the elements. If only one of either
#' constructs or elements is to be clustered the value `NA`
#' can be supplied. E.g. to cluster elements only use `c(NA, "ward.D")`.
#' @param p The power of the Minkowski distance, in case `"minkowski"`
#' is used as argument for `dmethod`. `p` can be a vector
#' of length two if different powers are wanted for constructs and
#' elements respectively (e.g. `c(2,1)`).
#' @param align Whether the constructs should be aligned before clustering
#' (default is `TRUE`). If not, the grid matrix is clustered
#' as is. See Details section in function [cluster()] for more information.
#' @param trim The number of characters a construct is trimmed to (default is
#' `10`). If `NA` no trimming is done. Trimming
#' simply saves space when displaying the output.
#' @param type Type of dendrogram. Either or `"triangle"` (default)
#' or `"rectangle"` form.
#' @param xsegs Numeric vector of normal device coordinates (ndc i.e. 0 to 1) to mark
#' the widths of the regions for the left labels, for the
#' bertin display, for the right labels and for the
#' vertical dendrogram (i.e. for the constructs).
#' @param ysegs Numeric vector of normal device coordinates (ndc i.e. 0 to 1) to mark
#' the heights of the regions for the horizontal dendrogram
#' (i.e. for the elements), for the bertin display and for
#' the element names.
#' @param x.off Horizontal offset between construct labels and construct dendrogram and
# between the outer right margin and the dendrogram
#' (default is `0.01` in normal device coordinates).
#' @param y.off Vertical offset between bertin display and element dendrogram and
# between the lower margin and the dendrogram
#' (default is `0.01` in normal device coordinates).
#' @param cex.axis `cex` for axis labels, default is `.6`.
#' @param col.axis Color for axis and axis labels, default is `grey(.4)`.
#' @param draw.axis Whether to draw axis showing the distance metric for the dendrograms
#' (default is `TRUE`).
#' @param ... additional parameters to be passed to function [bertin()].
#'
#' @return A list of two [hclust()] object, for elements and constructs
#' respectively.
#' @export
#' @seealso [cluster()]
#' @examples
#'
#' # default is euclidean distance and ward clustering
#' bertinCluster(bell2010)
#'
#' ### applying different distance measures and cluster methods
#'
#' # euclidean distance and single linkage clustering
#' bertinCluster(bell2010, cmethod = "single")
#' # manhattan distance and single linkage clustering
#' bertinCluster(bell2010, dmethod = "manhattan", cm = "single")
#' # minkowksi distance with power of 2 = euclidean distance
#' bertinCluster(bell2010, dm = "mink", p = 2)
#'
#' ### using different methods for constructs and elements
#'
#' # ward clustering for constructs, single linkage for elements
#' bertinCluster(bell2010, cmethod = c("ward.D", "single"))
#' # euclidean distance measure for constructs, manhatten
#' # distance for elements
#' bertinCluster(bell2010, dmethod = c("euclidean", "man"))
#' # minkowski metric with different powers for constructs and elements
#' bertinCluster(bell2010, dmethod = "mink", p = c(2, 1))
#'
#' ### clustering either constructs or elements only
#' # euclidean distance and ward clustering for constructs no
#' # clustering for elements
#' bertinCluster(bell2010, cmethod = c("ward.D", NA))
#' # euclidean distance and single linkage clustering for elements
#' # no clustering for constructs
#' bertinCluster(bell2010, cm = c(NA, "single"), align = FALSE)
#'
#' ### changing the appearance
#' # different dendrogram type
#' bertinCluster(bell2010, type = "rectangle")
#' # no axis drawn for dendrogram
#' bertinCluster(bell2010, draw.axis = FALSE)
#'
#' ### passing on arguments to bertin function via ...
#' # grey cell borders in bertin display
#' bertinCluster(bell2010, border = "grey")
#' # omit printing of grid scores, i.e. colors only
#' bertinCluster(bell2010, showvalues = FALSE)
#'
#' ### changing the layout
#' # making the vertical dendrogram bigger
#' bertinCluster(bell2010, xsegs = c(0, .2, .5, .7, 1))
#' # making the horizontal dendrogram bigger
#' bertinCluster(bell2010, ysegs = c(0, .3, .8, 1))
#'
bertinCluster <- function(x, dmethod = c("euclidean", "euclidean"),
cmethod = c("ward.D", "ward.D"), p = c(2, 2), align = TRUE,
trim = NA, type = c("triangle"),
xsegs = c(0, .2, .7, .9, 1), ysegs = c(0, .1, .7, 1),
x.off = 0.01, y.off = 0.01,
cex.axis = .6, col.axis = grey(.4), draw.axis = TRUE, ...) {
if (length(dmethod) == 1) { # if only one value is passed
dmethod <- rep(dmethod, 2)
}
if (length(cmethod) == 1) { # if only one value is passed
cmethod <- rep(cmethod, 2)
}
if (length(p) == 1) { # if only one value is passed
p <- rep(p, 2)
}
cex.dend <- 0.001 # size text dendrogram, only needed for sanity
# check purposes, otherwise 0.001 so no dend labels are drawn
inr.x <- xsegs[4] # inner figure region (bertin) ndc x coordinate range
# range goes from left side to y dendrogram region
inr.y <- 1 - ysegs[2] # bertin fig region range as ndc coords
# range goes from end of x dendrogram region to end of device (i.e. 1)
# transform xsegs and ysegs coordinates (ndc) into
# ndc coordinates for inner figure region used by bertin plot
xlim.bertin <- xsegs[2:3] / inr.x
ylim.bertin <- c(0, (ysegs[3] - ysegs[2]) / inr.y)
# align grid if promoted, uses dmethod etc. for constructs, i.e. [1]
if (align) {
x <- align(x,
along = 0, dmethod = dmethod[1],
cmethod = cmethod[1], p = p[1]
)
}
r <- getRatingLayer(x, trim = trim)
# dendrogram for constructs
if (is.na(cmethod[1])) {
con.ord <- seq_len(getNoOfConstructs(x)) # no change in order
fit.constructs <- NULL
} else {
dc <- dist(r, method = dmethod[1], p = p[1]) # make distance matrix for constructs
fit.constructs <- hclust(dc, method = cmethod[1]) # hclust object for constructs
dend.con <- as.dendrogram(fit.constructs)
con.ord <- order.dendrogram(rev(dend.con))
}
# dendrogram for elements
if (is.na(cmethod[2])) {
el.ord <- seq_len(getNoOfConstructs(x)) # no change in order
fit.elements <- NULL
} else {
de <- dist(t(r), method = dmethod[2], p = p[2]) # make distance matrix for elements
fit.elements <- hclust(de, method = cmethod[2]) # hclust object for elements
dend.el <- as.dendrogram(fit.elements)
el.ord <- order.dendrogram(dend.el)
}
x <- x[con.ord, el.ord] # reorder repgrid object
plot.new()
par(fig = c(xsegs[c(1, 4)], ysegs[c(2, 4)]), new = TRUE)
# par(fig = c(0, .8, .2, 1), new=T)
bertin(x, xlim = xlim.bertin, ylim = ylim.bertin, add = TRUE, ...) # print reordered bertin
# x dendrogram (horizontal) elements
if (!is.na(cmethod[2])) {
dend.x.fig <- c(xsegs[2:3], ysegs[1:2]) + c(0, 0, y.off, -y.off) # adjust for offsets
par(fig = dend.x.fig, new = T, mar = c(0, 0, 0, 0))
ymax.el <- attr(dend.el, "height")
plot(dend.el,
horiz = F, xlab = "", xaxs = "i", yaxs = "i", yaxt = "n",
nodePar = list(cex = 0, lab.cex = cex.dend), ylim = c(ymax.el, 0), type = type
)
if (draw.axis) { # whether to draw axis
axis(2, las = 1, cex.axis = cex.axis, col = col.axis, col.axis = col.axis)
}
}
# y dendrogram (vertical) constructs
if (!is.na(cmethod[1])) {
dend.y.fig <- c(xsegs[4:5], ysegs[2:3]) + c(x.off, -x.off, 0, 0) # adjust for offsets
par(fig = dend.y.fig, new = T, mar = c(0, 0, 0, 0))
xmax.con <- attr(dend.con, "height")
plot(dend.con,
horiz = T, xlab = "", xaxs = "i", yaxs = "i", yaxt = "n",
nodePar = list(cex = 0, lab.cex = cex.dend), xlim = c(0, xmax.con), type = type
)
if (draw.axis) { # whether to draw axis
axis(1, las = 1, cex.axis = cex.axis, col = col.axis, col.axis = col.axis)
}
}
# return hclust objects for elements and constructs
invisible(list(constructs = fit.constructs, elements = fit.elements))
}
# TODO: use of layout does not work with bertinCluster
# a future version could use layout
# layout (matrix(1:4), 2)
# bertinCluster(bell2010)
# bertinCluster(bell2010, type="t", bor=grey(.5))
# dev.new()
# bertinCluster(bell2010, type="t", dm="manhattan", cm="single")
# dev.new()
# bertinCluster(bell2010, type="t", dm="manhattan", cm="centroid")
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.