R/bertin.r

###############################################################################
###  							        BERTIN DISPLAYS 				                          ###
###############################################################################



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         \code{repgrid} object. 
#' @param ratings   Vector. rating scores are printed in the cells
#' @param margins   Vector of length three (default \code{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 \code{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. Wether to add bertin to existent plot (default is 
#'                  \code{FALSE}). If \code{TRUE, plot.new()} will not be called
#'                  \code{par(new=TRUE)}.
#' @return \code{NULL} just for printing.
#'
#' @export
#' @keywords internal
#' @author Mark Heckmann
#' 
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 reordable 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               \code{repgrid} object.
#' @param colors          Vector. Two or more colors defininig the color ramp for 
#'                        the bertin (default \code{c("white", "black")}).
#' @param showvalues      Logical. Wether scores are shown in bertin
#' @param xlim            Vector. Left and right limits inner bertin (default 
#'                        \code{c(.2, .8)}).
#' @param ylim            Vector. Lower and upper limits of inner bertin
#'                        default(\code{c(.0, .6)}).
#' @param margins         Vector of length three (default \code{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 \code{.7}).
#' @param cex.constructs  Numeric. Text size of construct labels (default \code{.7}).
#' @param cex.text        Numeric. Text size of scores in bertin cells (default \code{.7}).
#' @param col.text        Color of scores in bertin (default \code{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 independetn of background.
#' @param border          Border color of the bertin cells (default \code{white}).
#' @param lheight         Line height for constructs.
#' @param id              Logical. Wheteher to print id number for constructs and elements
#'                        respectively (default \code{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 \code{"#FCF5A4"}).
#' @param print           Print whole bertin. If \code{FALSE} only current and old
#'                        row and column are printed.
#' @param ...             Optional arguments to be passed on to \code{bertinBase}.
#'
#' @return \code{NULL} just for the side effects, i.e. printing.
#'
#' @export
#' @references    Bertin, J. (1974). \emph{Graphische Semiologie: Diagramme, Netze, 
#'                  Karten}. Berlin, New York: de Gruyter.
#'
#'                Dick, M. (2000). The Use of Narrative Grid Interviews in 
#'                  Psychological Mobility Research. \emph{Forum Qualitative 
#'                  Sozialforschung / Forum: Qualitative Social Research, 1}(2). 
#'                
#'                Raeithel, A. (1998). Kooperative Modellproduktion von 
#'                  Professionellen und Klienten - erlauetert am Beispiel des 
#'                  Repertory Grid. \emph{Selbstorganisation, Kooperation, Zeichenprozess: 
#'                  Arbeiten zu einer kulturwissenschaftlichen, anwendungsbezogenen 
#'                  Psychologie} (pp. 209-254). Opladen: Westdeutscher Verlag.
#'
#' @examples \dontrun{
#' 
#'    bertin(feixas2004)
#'    bertin(feixas2004, c("white", "darkblue"))
#'    bertin(feixas2004, showvalues=F)
#'    bertin(feixas2004, border="grey")
#'    bertin(feixas2004, cex.text=.9)
#'    bertin(feixas2004, id=c(F, F))
#'    
#'    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=getElementNames(x),
             labels.left=getConstructNames(x)$leftpole, 
             labels.right=getConstructNames(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)
}

#x <- randomGrid(10,20)
#x





#' Bertin display with corresponding cluster anaylsis. Element columns and 
#' constructs rows are ordered according to cluster criterion. Various 
#' distance measures as well as cluster methods are supported.
#'
#' @param x           \code{repgrid} object.
#' @param  dmethod    The distance measure to be used. This must be one of 
#'                    \code{"euclidean"}, \code{"maximum"}, \code{"manhattan"}, 
#'                    \code{"canberra"}, \code{"binary"}, or \code{"minkowski"}.
#'                    Default is \code{"euclidean"}.
#'                    Any unambiguous substring can be given (e.g. \code{"euc"} 
#'                    for \code{"euclidean"}). 
#'                    A vector of length two can be passed if a different dustance measure for
#'                    constructs and elements is wanted (e.g.\code{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
#'                    \code{?dist}. 
#' @param  cmethod    The agglomeration method to be used. This should be (an
#'                    unambiguous abbreviation of) one of \code{"ward"}, 
#'                    \code{"single"}, \code{"complete"}, \code{"average"}, 
#'                    \code{"mcquitty"}, \code{"median"} or \code{"centroid"}.
#'                    Default is \code{"ward"}.
#'                    A vector of length two can be passed if a different cluster method for
#'                    constructs and elements is wanted (e.g.\code{c("ward", "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 \code{NA}
#'                    can be supplied. E.g. to cluster elements only use \code{c(NA, "ward")}.
#' @param  p          The power of the Minkowski distance, in case \code{"minkowski"}
#'                    is used as argument for \code{dmethod}. \code{p} can be a vector
#'                    of length two if different powers are wanted for constructs and
#'                    elements respectively (e.g. \code{c(2,1)}).
#' @param trim        The number of characters a construct is trimmed to (default is
#'                    \code{10}). If \code{NA} no trimming is done. Trimming
#'                    simply saves space when displaying the output.
#' @param type        Type of dendrogram. Either or \code{"triangle"} (default) 
#'                    or \code{"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 \code{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 \code{0.01} in normal device coordinates).
#' @param cex.axis    \code{cex} for axis labels, default is \code{.6}.
#' @param col.axis    Color for axis and axis labels, default is \code{grey(.4)}.
#' @param draw.axis   Whether to draw axis showing the distance metric for the dendrograms 
#'                    (default is \code{TRUE}).
#' @param ...         additional parameters to be passed to function \code{\link{bertin}}.
#'
#' @return            A list of two \code{\link{hclust}} object, for elements and constructs
#'                    respectively.
#'
#' @author        Mark Heckmann
#' @export
#' @seealso  \code{\link{cluster}}
#'
#' @examples \dontrun{
#'
#'    # 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", "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", NA))  
#'    # euclidean distance and single linkage clustering for elements 
#'    # no clustering for constructs            
#'    bertinCluster(bell2010, cm=c(NA, "single"))                 
#'
#'    ### changing the appearance
#'    # different dendrogram type        
#'    bertinCluster(bell2010, type="rectangle")  
#'    # no axis drawn for dendrogram                 
#'    bertinCluster(bell2010, draw.axis=F)                        
#'
#'    ### 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", "ward"), p=c(2,2), 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)
  
  r <- getRatingLayer(x, trim=trim)    # get ratings

  # 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=T)
  #par(fig = c(0, .8, .2, 1), new=T)
  
  bertin(x, xlim=xlim.bertin, ylim=ylim.bertin, add=T, ...)           # 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)              # wether 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)              # wether 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")



# base graphics for quick clustering
# # make dendrogram
#x <- bell2010

# compute new layout of bertin

Try the OpenRepGrid package in your browser

Any scripts or data that you put into this service are public.

OpenRepGrid documentation built on May 2, 2019, 4:54 p.m.