###############
## Plot Text 
###############

text.box <- function(tex, x,y,x.padding, y.padding, vertical.stretch,
                        paragraph.break, bkgr.col, justify, slide.quote, after.){

## Version 10-17-2008 ##

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

## Use this function to add text to a plot. ##

#################
## Text set up 
#################
                
        p <- par()
        default <- list(family=p$family,font=p$font,col=p$col,cex=p$cex)

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

        tex2 <- unlist( strsplit(paste(tex, collapse=' '), '') )
        tex2[tex2=='<'] <- ' <' ; tex2[tex2=='>'] <- '> '
        tex3 <- unlist(strsplit(paste(tex2, collapse=''), ' ') )
        w <- tex3[tex3!='']
## <!> (verbatim)  ## verbatim has some issues.
        wow <- which(w=='<!>')
        w[wow+1] <- paste('*@$%@', w[wow+1], sep='') ; w <- w[w!='<!>']
## eval()
        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(NULL),'')[[1]] ; dq <- strsplit(dQuote(NULL),'')[[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){
                                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, '> t </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(F,L)
## family
        fam.pos <- c( 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}

## finish verbatim
        verbatim <- which(substr(w,1,5)=='*@$%@')
                w[verbatim] <- substr(w[verbatim],6,nchar(w[verbatim]))
## 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)))] <- T
## 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)))
}

##################
## Word Postion 
##################

xy.pos <- function(d, x, y, vertical.stretch, paragraph.break, justify, slide.quote, after.){
## 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=F)
        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=F)
        }
        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[nd<-nrow(d)]
                        sq <- strsplit(sQuote(NULL),'')[[1]] ; dq <- strsplit(dQuote(NULL),'')[[1]]
                        if(slide.quote & substr(lw,nchar(lw),nchar(lw)) %in% c('.',',',sq,dq,'?','!')){
                                x2 <- x2+strwidth('.',family=d$family[nd],font=d$font[nd],cex=as.numeric(d$cex)[nd])
                        }
                        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, default, bkgr.col)
        d <- x1$main ; pl <- x1$paraline ; pl <- c(pl, '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)
        }

## 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=.4, ...){
        # 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, ...)
}