R/bertin.r

In markheckmann/OpenRepGrid: Tools to Analyze Repertory Grid Data

# //////////////////////////////////////////////////////////////////////////////
#
#    							     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")