R/clan.txtplot.R

In HITXML: Planning tools for ion beam therapy

clan.txtplot <- function(txt, new = T, start.pos = NULL, maintain.start.pos = T, new.line = F, page.size = 20/cex, line.size = 75/cex - 5, line.size.extra = 5 + line.size * 0.03, head = "", foot = "", evaluate = F, adjust.table = T, table.lines = c(1, 2, 999), table.line.pos = list(start = 1, stop = 4, frac = 0.3), col.sign = " ", hyphen.sign = "-", cex = 0.8, col = 1, font = 11, char.width = 0.013 * cex, line.height = 0.05 * cex, box = NULL, char.groupA = list(chars = c("#", "~", "^", "[", "]", "@"), x.right = -0.005 * cex*0, y.lift = -0.015 * cex*0), char.groupB = list(chars = c("-"), x.right = 0., y.lift = 0.001 * cex), char.groupC = NULL, trace = F, x.start.default=0, y.start.default=1, vp = viewport(x=unit(0.025,"npc"),y=unit(0.025,"npc"),width=unit(0.95,"npc"),height=unit(0.95,"npc"),just=c("left","bottom"),name="vp.txtplot"),...){
	# This function can print text or dataframes on a separate graphsheet or on an excisting graph.
	# The main idea behind the function is to add experimental or analytical details (=text) on
	# separate 'graphs' in between the real graphs. When everything is exported to pdf or PowerPoint
	# we both have explanations and graphs in the same document. At the same time, 
	# we can easily read the text in the script. Hence this function should facilitate
	# improved documentation. This is kind of a simple way of literate programming. 

  # Created: July 27, 2006
	# Revised: July 28, 2006
	# Revised: July 29, 2006
	# Revised: July 30, 2006
	# Revised: July 31, 2006
  # Revised: October 30, 2011 (moved to R and updated)
	# Name: Claus E. Andersen
  # Contact : clan@risoe.dtu.dk

  # Arguments.
	#   txt :  the text to be plotted or a data.frame
	#   new: if true, txtplot opens a new graphsheet for graphical output
	#   start.pos: a list with the start (x,y) position and an optional lineno on the page. 
  #              start.pos = list(0.5,0.5, 6) refers to the center of the page and that 
  #              the current line number is 6. The line number is used for keeping track
  #              of when we need a new page. If start.pos==NULL, then we just use the defaults
  #              x.start.default and y.start.default.
	#   maintain.start.pos: If false, then start each new line at x=x.start.default otherwise 
  #                       start each new line at the orginal x-start.pos
	#   new.line: Add a new line after txt. Alternatively, include a \n-in the text.
	#   page.size: number of lines before page break.
	#   line.size: number of characters on a given line before line break (with or without hyphen)
	#   line.size.extra: to promote that lines are broken where there is white space we allow for
	#                     a more relaxed break of lines. txtplot tries to break lines when there are
	#                     more characters than given by line.size. However, it does not break before
	#                     it reached a blank space - in so far that blank space occurs before the
	#                     number of character is in the line is larger than: line.size + line.size.extra.
	#   head: not implemented
	#   foot: not implemented
	#   evaluate: treat txt as commands, and execute these (has never been used).
	#   adjust.table: add leading blanks using create.latex.table which the pretty.func argument
	#   table.lines: a vector with line numbers where horizontal lines should be made. This only
	#                applies to when txt is a data.frame.  999 is the last line.
	#                table.lines = T is equivalent to table.lines =c(1,2,999)
	#                table.lines = F gives no table lines.
	#                Note: The table lines are drawn using the lines-command and is therefore
	#                restricted to the x-y drawing panel (not the full 0-1 by 0-1 coordinate system).
	#                In comparison, the text is drawn using the mtext-command. Set trace=T and
	#                a red box will show where table lines can be drawn. If table lines are requested
	#                then txtplot moves the table into the 'line''-domain automatecially.
	#   table.line.pos: Fine control of where table lines should be placed.
	#   col.sign: the sign between coloumns (used by create.latex.table)
	#   hyphen.sign: the sign used by txtplot when it breaks lines.
	#   cex, col, font: use these values for the printing.
	#   char.width: distance between the start of each character (the size of each character is set by cex)
	#   line.height: height of each line
	#   box: list(coordinates, col, lwd, lty) or logical. The coordinates should be provided
	#        in the same order as usr (i.e. as: c(x1,x2,y1,y2)).
	#   char.groupA/B/C: Some characters do not have the same reference point as others, and we need to move these
	#                    somewhat. Each char.groupX is a list with three elements: a vector of characters, a
	#                    number that specify the movements in the x and y directions (x.right and y.lift, respectively).
	#   trace: debugging information
	#   x.start.default: The default start x-position 
  #   y.start.default: The default start y-position
  #   vp: The viewport that will be created for new pages.
  
  # Output: list of coordinates (can be used by subsequent calls to txtplot - see example below).

  # Side effect: Produces one or more pages of empty graphs with text or adds text to an existing graph.

  # Sample call:
  #    txt <- 
  #      "
  #      Hi there
  #      This is txtplot...
  #      Bye Bye.
  #      "
  #      txtplot(txt)
  # See txtplot.demo() for additionalk examples.

  # Repair any missing line number (= the third element in the start.pos list):
  if(!is.null(start.pos) && length(start.pos)==2) start.pos <- list(start.pos[[1]],start.pos[[2]], 1)
  
  if(new) {
		# Create a new (empty) graphsheet for trellis graphics
    #	Old S-plus:	print.trellis.plots(list(NULL))
    #		          print.trellis(list(NULL))
    grid.newpage()
	}

  # Always make a viewport:
  pushViewport(vp)

  usr <- par("usr")
  if(trace) {
		llines(c(0, 0, 1, 1, 0), c(0, 1, 1, 0, 0), lwd = 2, col = 6)
	llines(c(usr[1], usr[1], usr[2], usr[2], usr[1]), c(usr[3],
		usr[4], usr[4], usr[3], usr[3]), lwd = 2, col = 8)
	}
  if(!is.null(box)) {
		if(!is.list(box))
			box <- list(box)
		bc <- box[[1]]
		if(is.logical(bc)) {
			if(bc)
				bc <- c(usr[1], usr[2], usr[3], usr[4])
			else {
				bc <- c(NA, NA, NA, NA)
			}
		}
    if(is.null(box$col))
			box$col <- 1
		if(is.null(box$lwd))
			box$lwd <- 3
		if(is.null(box$lty))
			box$lty <- 4
		llines(c(bc[1], bc[1], bc[2], bc[2], bc[1]), c(bc[3], bc[4],
			bc[4], bc[3], bc[3]), lwd = box$lwd, col = box$col,
			lty = box$lty)
	}
  if(is.null(table.lines) || is.na(table.lines[1])) {
		table.lines <- c(-999)
	}
	if(is.logical(table.lines)) {
		if(table.lines)
			table.lines <- c(1, 2, 999)
		else table.lines <- c(-99)
	}
	if(is.null(start.pos)) {
		x0 <- x.start.default  #WAS: 0.
		y0 <- y.start.default  #Was: 1.
    line.no <- 0
    tabline.no <- 0
    }
	else {
		x0 <- start.pos[[1]]
		y0 <- start.pos[[2]]
    line.no <- start.pos[[3]]
    tabline.no <- 0
	}
	# remember this (for table with many lines that should start from same x)
	x.start.pos <- x0
	if(!maintain.start.pos)
		x.start.pos <- 0.
	if(new.line) {
		x0 <- x.start.default  #WAS: 0.
		y0 <- y0 - line.height
	}
  dat.frame <- F
	if(trace) {
		ltext(0, 0, "0,0")
		ltext(0, 1, "0,1")
		ltext(1, 0, "1,0")
		ltext(1, 1, "1,1")
	}
  NN <- 0
	line.wanted <- F
	if(class(txt) == "data.frame") {
		dat.frame <- T
		tabline.no <- 0
    if(sum(table.lines) > 0)
			y0 <- min(y0, usr[4] - line.height)
		if(adjust.table) {
			#df  <- create.latex.table(txt,NL="",pretty.func = function(x, col.num = 1){if(is.numeric(x))signif(x,4)else x})
			df <- clan.create.latex.table(txt, NL = "", col.sign = 
				col.sign, ...)
			df <- leading.blanks(df, " ")
		}
		txt <- ""
		for(i in 1:nrow(df)) {
			L <- ""
			for(j in 1:ncol(df)) {
				L <- paste(L, format(df[i, j], digits = 3,
					justify = "left"))
			}
			# cols
			txt <- paste(txt, L, "\n")
		}
		# rows
		#lines(c(0,1),c(0.3,0.3),type="l")
		# Identify first line in table, and find it's length (i.e. the first \n-match)
		NN <- regexpr("[\n]", txt)
	}
  # data.frame
	if(class(txt) == "character") {
    ##line.no <- 0
		char.no <- 0
		for(i in 1:nchar(txt)) {
			ch <- substring(txt, i, i)
			char.no <- char.no + 1
			if(trace)
				print(paste("char no.=", i, ch))
			if((ch == "\n")) {
				char.no <- 1
				x0 <- x.start.pos
				y0 <- y0 - line.height
				ch = ""
				line.no <- line.no + 1
        tabline.no <- tabline.no + 1
				if(is.element(tabline.no, table.lines))
					line.wanted <- T
			}
			if((!(ch == "")) & (((ch == " ") & (char.no > 
				line.size)) | ((char.no > line.size + 
				line.size.extra)))) {
				char.no <- 1
				if(!(ch == " "))
					text(x0, y0, hyphen.sign, adj = 0,
						cex = cex, col = col, font = 
						font)
				if(ch == " ")
					ch <- ""
				x0 <- x.start.pos
				y0 <- y0 - line.height
				line.no <- line.no + 1
        tabline.no <- tabline.no + 1
				if(is.element(tabline.no, table.lines))
					line.wanted <- T
			}
      x.right <- 0.
			y.lift <- 0.
			if(!is.null(char.groupA) && is.element(ch, char.groupA$
				chars)) {
				x.right <- char.groupA$x.right
				y.lift <- char.groupA$y.lift
			}
			if(!is.null(char.groupB) && is.element(ch, char.groupB$
				chars)) {
				x.right <- char.groupB$x.right
				y.lift <- char.groupB$y.lift
			}
			if(!is.null(char.groupC) && is.element(ch, char.groupC$
				chars)) {
				x.right <- char.groupC$x.right
				y.lift <- char.groupC$y.lift
			}
			ltext(x0 + x.right, y0 + y.lift, substring(txt, i,
				i), col = col, font = font, cex = cex)
      if(dat.frame & line.wanted) {
				xL.start <- x.start.pos + table.line.pos$
					start * char.width
				xL.stop <- x.start.pos + (NN - table.line.pos$
					stop) * char.width
				yL <- y0 + line.height * (1 + table.line.pos$
					frac)
        if(trace) {
					print("%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
						)
					print("usr = ")
					print(usr)
					print(paste("x start", xL.start))
					print(paste("x stop", xL.stop))
					print(paste("y ", yL))
				}
				# trace
        xL.start <- max(xL.start, 0)
				xL.stop <- min(xL.stop, 1)
				if(yL < usr[3] | yL > usr[4])
					yL <- NA
				llines(c(xL.start, xL.stop), c(yL, yL), type = 
					"l", col = col)
				line.wanted <- F
			}
			if(!(ch == "")) x0 <- x0 + char.width

      if(line.no > page.size) {
		    grid.newpage()
        pushViewport(vp)
				line.no <- 1
				y0 <- y.start.default # Was: 1.
			}
}
    if(dat.frame & is.element(999, table.lines)) {
			xL.start <- x.start.pos + table.line.pos$start * char.width
			xL.stop <- x.start.pos + (NN - table.line.pos$stop) * char.width
			yL <- y0 + line.height * (0 + table.line.pos$frac)
			xL.start <- max(xL.start, 0)
			xL.stop <- min(xL.stop, 1)
			if(yL < usr[3] | yL > usr[4]) yL <- NA
			llines(c(xL.start, xL.stop), c(yL, yL), type = "l", col = col)
		}
	}
  # character
	if(trace) {
		print("The following text will now be evaluated.")
		print("---- Begin of text to be evaluated ----")
		print(txt)
		print("---- END of text to be evaluated ----")
	}
  if(evaluate) eval(parse(text = txt))
  popViewport()
  invisible(list(x0, y0, line.no))
}# End txtplot

##################################################################################################