text.box <- function(tex, x, y, x.padding, y.padding, vertical.stretch,
    paragraph.break, bkgr.col, justify, slide.quote, after.){
## 2012/3/2 Versioin 2
##############################################
## Use this function to add text to a plot. ##
##############################################

    # tex is a string of text to be displayed. See below for more details.
    # x specifies the beginning and ending x-coordinate for the text box.
    # y specifies the upper y-coordinate.
    # x.padding and y.padding how much space is left around the text box.
    # vertical.stretch controls vertical space between lines.
    # paragraph.break controls vertical space between paragraphs. 
    # bkgr.col should be the same color as the background.
    # justify specifies if right-justification is desired.
    # slide.quote = TRUE -> when a quotation mark is at the beginning of the
    # ilne, it can be slided to the left a little bit to make look nice.
    # after. controls space after the period.  

    # For 'tex', some mark-up like html mark-up can be used. Examples:
    # <b>bold</b>, <i>italic</i>, <col=blue>blue</col>, 
    # <p> begins a new paragraph; </p> is not needed.
    # <br> line break <dqs> double quotation mark starts <dqs> ends <sqs>
    # single quotation mark starts <sqs> ends <nosp> no space (often needed
    # for <i>italic ends sentence</i> <nosp>.  <nbsp> non-break space.
    # <$3+5$> expression within two $ will be evaluated.  This has some
    # issues. 
    
################# ## Text set up ## ################# p <- par()
   # default <- list(family=p$family,font=p$font,col=p$col,cex=p$cex)

setup.text <- function(tex, bkgr.col){ 

    default <- par()
    
    tex2 <- unlist( strsplit(paste(tex, collapse=' '), '') ) 
    tex2[tex2=='<'] <- ' <' ; tex2[tex2=='>'] <- '> '
    tex3 <- unlist( strsplit(paste(tex2, collapse=''), ' ') )
    w <- tex3[tex3!='']
   
    nev <- which(substr(w,1,2)=='<$') ; L <- length(nev) 
        if( L>0 ){ for(i in nev){ 
            w[i] <- eval(parse(text=substr(w[i], 3, nchar(w[i])-2)))
            } } 
        lonely.bracket <- which(w=='>') ; L <- length(lonely.bracket) 
        if( L>0){ for(i in lonely.bracket){ 
            w[i-2] <- paste(w[i-2], w[i-1], w[i], sep='')
            w[i-1] <- w[i] <- NA }} 
        w <- w[!is.na(w)]

## interpreting newer commands 
    
    w <- replace(w, w %in% c('<p>', '</p>'), '**NewParagraph**') 
    w <- replace(w, w == '<br>', '**NewLine**') 
    w <- replace(w, w == '<nosp>', '**NoSpace**') 
    w <- replace(w, w == '<nbsp>', '**NoBreak**')

## quotation marks 
    sq <- strsplit( sQuote('?'), '')[[1]]
    dq <- strsplit( dQuote('?'), '')[[1]]
        w <- replace(w, w=='<sqs>', paste(sq[1], '**NoSpace**'))
	w <- replace(w, w=='<sqe>', paste('**NoSpace**', sq[2]))
	w <- replace(w, w=='<dqs>', paste(dq[1], '**NoSpace**'))
	w <- replace(w, w=='<dqe>', paste('**NoSpace**', dq[2]))
	w <- replace(w, w=='<*>',   paste('**NoSpace**', sq[2], '**NoSpace**'))

    w <- unlist(strsplit(w, ' '))

## deleting unnecessary commands
    new.range <- which(substr(w,1,2) != '**')
        w <- w[ c(min(new.range) : max(new.range)) ]

    drop.ss <- function(w, nn, side=1){
        ## this will drop '**' when it's not needed.
	po <- which(w %in% nn)
            if( side==1 ){ tbd <- po[substr(w[po+1],1,2)=='**'] }
            if( side==2 ){ tbd <- po[substr(w[po+1],1,2)=='**' | substr(w[po-1],1,2)=='**'] }
	        if( length(tbd) > 0 ){
                    w <- w[-tbd] }
	            w 
            }
    w <- drop.ss(w, '**NoBreak**', side=2)
    w <- drop.ss(w, '**NoSpace**', side=2)
    w <- drop.ss(w, '**NewLine**', side=2)
    w <- drop.ss(w, '**NewParagraph**', side=1)

## NoBreak
    nobr <- which(w=='**NoBreak**')
    w[nobr] <- paste('**NoSpace** <col=', bkgr.col, '> . </col> **NoSpace**', sep='')
    w <- unlist( strsplit(w, ' '))
	L <- length(w)
	    fam <- rep(default$family, L)
            fon <- rep(default$font,   L)
	    col <- rep(default$col,    L)
            cex <- rep(default$cex,    L)
            nonword <- rep(FALSE, L)

## family
    fam.pos  <- which(w %in% c('<sans>', '</sans>', '<serif>', '</serif>', '<mono>', '</mono>'))
    fam.posL <- c(fam.pos, L)
	if( length(fam.posL) > 1 ){
            for(i in 1:length(fam.pos)){ fam[ fam.posL[i]:fam.posL[i+1] ] <- w[fam.posL[i]] }
            }
	fam[substr(fam, 1, 2) == '</'] <- default$family
	fam[fam=='<mono>']  <- 'mono'
        fam[fam=='<sans>']  <- 'sans'
        fam[fam=='<serif>'] <- 'serif'

## font
    fon.pos  <- which(w %in% c('<n>', '</n>', '<b>', '</b>', '<i>', '</i>', '<bi>', '</bi>'))
    fon.posL <- c(fon.pos, L)
        if( length(fon.posL) > 1 ){
            for(i in 1:length(fon.pos)){ fon[fon.posL[i]:fon.posL[i+1]] <- w[fon.posL[i]] }
            }
	fon[substr(fon, 1, 2) == '</'] <- default$font
	fon[fon=='<n>']  <- 1
        fon[fon=='<b>']  <- 2
        fon[fon=='<i>']  <- 3
        fon[fon=='<bi>'] <- 4

## color
    col.pos  <- which(substr(w, 1, 4) %in% c('<col', '</co'))
    col.posL <- c(col.pos, L)
        if( length(col.posL) > 1 ){
            for(i in 1:length(col.pos)){
                this.col <- w[col.posL[i]]
		col[col.posL[i] : col.posL[i+1]] <- substr(this.col, 6, nchar(this.col)-1)
                }
		col[col==''] <- default$col
                }

## cex
    cex.pos  <- which(substr(w, 1, 4) %in% c('<cex','</ce'))
    cex.posL <- c(cex.pos, L)
	if( length(cex.posL) > 1 ){
	    for(i in 1:length(cex.pos)){
                this.cex <- w[cex.posL[i]]
                cex[cex.posL[i] : cex.posL[i+1]] <- substr(this.cex, 6, nchar(this.cex)-1)
                }
		cex[cex==''] <- default$cex
                }

## quotation mark position
    quot <- w %in% c(sq, dq)
## after. position if after. != 0
    aft. <- substr(w, nchar(w), nchar(w)) == '.'
    aft.[length(w)] <- FALSE
    if( sum(aft.) > 0 ){
        for(i in which(aft.)){
            if( w[i+1] == '<~>' ){ 
                w[i+1] <- NA
                aft.[i] <- FALSE
                }
	    }
        }
    nonword[c(fam.pos, fon.pos, col.pos, cex.pos, which(is.na(w)))] <- TRUE

## define each word
    d <- data.frame( words=w, family=fam, font=as.numeric(fon), col=col, cex=cex, nonword, quot, aft., stringsAsFactors=FALSE )[!nonword,]
    w <- d$words
    by.paragraph <- as.list( 1:(1+sum(w %in% c('**NewParagraph**','**NewLine**'))) )
    L <- length(by.paragraph)
        start <- c(0, which(w %in% c('**NewParagraph**','**NewLine**')), length(w)+1)
        for(i in 1:L){ by.paragraph[[i]] <- d[(start[i]+1):(start[i+1]-1) ,] }
	list(main=by.paragraph, paraline=c('P', substr(w[start[-c(1,length(start))]],6,6)))
} ## end of setup.text()

##################
## Word Postion 
##################
xy.pos <- function(d, x, y, vertical.stretch, paragraph.break, justify, slide.quote, after.){
## This function computes where to place each word.
## date object needs special attention.
    x.is.date <- FALSE
    y.original <- y
        if( class(x[1])=='Date' ){
            x <- as.numeric(x)
            x.is.date <- TRUE
            }
   
## computing width and height of each word.
    R <- nrow(d)
    wit <- spc <- hig <- rep(0, R)
    for(i in 1:R){
	wit[i] <- strwidth (d$words[i], family=d$family[i], font=d$font[i], cex=d$cex[i])
	spc[i] <- strwidth (' ',        family=d$family[i], font=d$font[i], cex=d$cex[i])
	hig[i] <- strheight(d$words[i], family=d$family[i], font=d$font[i], cex=d$cex[i])
    }
    spc[which(d$aft.)] <- spc[which(d$aft.)] * after.
    
## NoSpace
    spc <- c(0,spc[-R])
    nsp <- which(d$words=='**NoSpace**')
    wit[nsp] <- 0
    spc[c(nsp,nsp+1)] <- 0
    hig[nsp] <- 0

## group words together based on **NoSpace**
    gr.inc <- rep(1, R)
    gr.inc[c(nsp,nsp+1)] <- 0
    gr <- cumsum(gr.inc)
    tmp1 <- data.frame(d, wit, spc, hig, stringsAsFactors=FALSE)
    gr.len <- line.id <- rep(0, max(gr))
        for(i in gr){
            this <- tmp1[gr==i,]
            gr.len[i] <- sum(this$wit + this$spc)
	}
    x.wit <- diff(x) 
    gl <- gr.len
    L <- 1

## counting number of necessary lines
    if( any(gl > x.wit) ){ stop('X width not wide enough.', '\n') }
    while(prod(line.id)==0){
	temp <- cumsum(gl)
	line.id[temp<x.wit & temp>0] <- L
	gl[line.id==L] <- 0
	L <- L+1
	}
## spliting the data into each line
    li <- rep(0,R)
    for(i in 1:R){ li[i] <- line.id[gr[i]] }
    tmp1$spc[ (which(diff(li)>0))+1 ] <- 0
    tmp2 <- data.frame(tmp1, id=li, stringsAsFactors=F)[tmp1$words != '**NoSpace**',]
    tmp3 <- split(tmp2, tmp2$id)
## compute starting x value for each word
## If the first character of the line is quotation mark, possibly slide the line a little.
    find.x <- function(d, sq){
        cumwit <- cumsum(d$wit)
        cumspc <- cumsum(d$spc)
        cumwit <- c(0, cumwit[-length(cumwit)])
            x.pos <- cumwit + cumspc
            if( slide.quote & d$quot[1] ){ 
                x.pos <- x.pos - 1*strwidth('i', family=d$family[1], font=d$font[1], cex=as.numeric(d$cex[1]))
                }
	data.frame(d, x.pos=x.pos+x[1], stringsAsFactors=FALSE)
	}
    tmp4 <- lapply(tmp3, find.x, sq=slide.quote)

## putting the data.frame back
    tmp5 <- unsplit(tmp4, tmp2$id)

## computing the line height and y value for each line
    l.h <- unique( rep(tmp5$id) )
    lhl <- length(l.h)
    cumy <- rep(0,lhl)
        for(i in 1:length(l.h)){ l.h[i] <- max(tmp5$hig[tmp5$id==i]) }
        y <- cumy[1] <- y - l.h[1] * vertical.stretch
        clh <- cumsum(l.h[-1])
        if( lhl>1 ){ cumy[2:lhl] <- y - clh * vertical.stretch }
    tmp5$y.pos <- rep(cumy, table(tmp5$id))
    next.y <- min(tmp5$y.pos) - c(0,paragraph.break-1) * tmp5$hig[nrow(tmp5)] * vertical.stretch

## right justification
    if( justify & max(tmp5$id)>1 ){
        max.id <- max(tmp5$id)
        tmp5x <- subset(tmp5, id!=max.id)
        tmp5y <- subset(tmp5, id==max.id)
        bL <- split(tmp5x, tmp5x$id)
        
        words.width.n.space <- wwns <- function(d){
            x2 <- x[2]
            lw <- d$words[R]  # R is nrow(d)
            sq <- strsplit(sQuote('W'), '')[[1]]
            dq <- strsplit(dQuote('W'), '')[[1]]
                if( slide.quote & substr(lw,nchar(lw),nchar(lw)) %in% c('.',',',sq,dq,'?','!') ){
                    x2 <- x2+strwidth( '.',family=d$family[R],font=d$font[R],cex=as.numeric(d$cex)[R] )
                    }
	    nspace <- sum(d$spc > 0)
            ww <- sum(d$wit)
            new.space <- (d$spc>0) * (x2-d$x.pos[1] - ww) / nspace
            w.plus.s <- d$wit[-nrow(d)] + new.space[-1]
            new.x.pos <- cumsum( c(d$x.pos[1],w.plus.s) )
            d$spc <- new.space
            d$x.pos <- new.x.pos
            d
            }
        by.Line <- lapply(bL, wwns)
        tmp5x <- unsplit(by.Line, tmp5x$id)
        tmp5 <- rbind(tmp5x, tmp5y)
	}

	tmp5$cex <- as.numeric(tmp5$cex)

## put x in the original scale if it was a Date object
	if( x.is.date ){ tmp5$x.pos <- as.Date(tmp5$x.pos, origin=as.Date('1970-1-1')) }

	list(main=tmp5, next.y=next.y)
	}

###############
## Plot Text 
###############
    if( length(x.padding)==1 ){ x.padding <- rep(x.padding,2) }
    if( length(y.padding)==1 ){ y.padding <- rep(y.padding,2) }

    x1 <- setup.text(tex, bkgr.col)
    d  <- x1$main 
    pl <- c( x1$paraline, 'P' )
        n <- length(x1$paraline)
    out <- as.list(1:n)
        i <- 1
        next.y <- y
	while(i <= n){
            temp <- xy.pos(d[[i]], x, next.y, vertical.stretch, paragraph.break, justify, slide.quote, after.)
            ny <- temp$next.y
            next.y <- ny[(pl[i+1]=='P')+1]
	    out[[i]] <- temp
	    i <- i + 1
            }
    out1 <- out[[1]]$main
    outx <- out[[i-1]]$main
    top.y <- out1$y.pos[1]+out1$hig[1]
    bot.y <- min(outx$y.pos)
    
    rect(x[1]-x.padding[1], top.y+y.padding[1], x[2]+x.padding[2], bot.y-y.padding[2], border=bkgr.col, col=bkgr.col)
        for(i in 1:length(out)){
            dat <- out[[i]]$main 
            dat$cex  <- as.numeric(dat$cex)
            dat$font <- as.numeric(dat$font)
	    datx <- subset(dat, dat$col!=bkgr.col)
                for(j in 1:nrow(datx)){
                    text(datx$x.pos[j], datx$y.pos[j], datx$words[j], family=datx$family[j], font=datx$font[j],
                         col=datx$col[j], cex=datx$cex[j],adj=c(0,0))
			}
	}
	invisible(out)
	} ## End of text.box

## This function is useful when text.box is used in succession.
get.next.y <- function(out){ out[[length(out)]]$next.y }

## This is an extension of text().
## Unlike text.box() this should be used for short phrases.
text.with.bg <- twb <- function(x, y, tex,bkgr, x.adj=0, width.adj=.01, height.adj=.5, ...){
	# Do not use pos and offset with this function.
	# x.adj = 0 (left), .5 (center), or 1 (right)

	xa <- round(x.adj * 2) + 1
	wid <- strwidth(tex, ...)
        hig <- strheight(tex, ...)
	wa <- strwidth ('W', ...) * width.adj
        ha <- strheight('W', ...) * height.adj
	adj <- c(x.adj, .5)

	x1 <- c(x+wa, x-wid/2, x-wid-wa)
	y1 <- y - hig/2
	rect(x1[xa]-wa, y1-ha, x1[xa]+wid+wa, y1+hig+ha, col=bkgr, border=bkgr)
	text(x=x+c(wa,0,-wa)[xa], y=y, labels=tex, pos=NULL, offset=0, adj=adj, ...)
}