#
# Rajarshi Guha <rajarshi@presidency.com>
# 02/24/06
#
# 02/25/06 - Cleaned up some code. Also fixed a bug which occured when the class for
#            an object was a character vector rather than a single character. Also
#            added code to make sure that long comments or comments with newlines
#            get displayed properly on multiple lines
# 02/24/06 - Implemented refresh. Also allows the user to change the view on the fly

require(tcltk)
tclRequire("Tktable")


.get.comments <- function(varname) {
    x <- comment(get(varname))
    if (is.null(x)) {
        "None"
    } else {
       x 
    }
}
.make.tclarray <- function(rarray) {
    tclarray <- tclArray()
    for (i in 0:(nrow(rarray)-1)) {
        for (j in 0:(ncol(rarray)-1)) {
            tclarray[[i,j]] <- rarray[i+1, j+1]
        }
    }
    tclarray
}
.get.data <- function(vwhich) {
    if (vwhich == 'funcs') {
        vars <- unlist(lapply( ls(envir=.GlobalEnv), function(x) if (is.function(get(x))) x ))
    } else if (vwhich == 'vars') {
        vars <- unlist(lapply( ls(envir=.GlobalEnv), function(x) if (!is.function(get(x))) x ))
    } else if (vwhich == 'all') {
        vars <- ls(envir=.GlobalEnv)
    } else {
        stop("vwhich must be all, funcs or vars")
    }

    d <- NA
    if (length(vars) != 0) {
        # we do a paste, since sometimes class() can return a vector of classes for an object
        classes <- sapply(vars, function(x) paste(class(get(x)), sep='',collapse=' '))
        comments <- sapply(vars, .get.comments)
        d <- array(c(vars, classes, comments), dim=c(length(vars),3))
        if (vwhich == 'all') {
            d <- d[sort.list(d[,2]),]
        }
        d <- rbind(c('Name', 'Class', 'Comment'), d)
    } else {
        d <- c('Name', 'Class', 'Comment')
        dim(d) <- c(1,3)
    }
    d
}
    

obj.browse <- function(vwhich='vars', height=-1, width=-1) {
    
    commentColSize <- "30"
    localenv <- new.env()

    d <- .get.data(vwhich)    
    tclarray <- .make.tclarray(d)

    # save these in a local env so we can get/set them in callbacks
    assign('d',d,envir=localenv)
    assign('tclarray',tclarray,envir=localenv)
    assign('vwhich',vwhich,envir=localenv)

    # set up features of the top level window
    tt <- tktoplevel()
    tkwm.resizable(tt, FALSE, FALSE)
    if (vwhich == 'funcs') {
        tkwm.title(tt, "Object Browser - Functions")
    } else if (vwhich == 'vars') {
        tkwm.title(tt, "Object Browser - Variables")
    } else {
        tkwm.title(tt, "Object Browser")
    }
    
    # make some buttons and callbacks
    buttonframe <- tkframe(tt)
    refresh <- tkbutton(buttonframe, text='Refresh')
    do.refresh <- function(...) {

        # get latest data
        d <- get('d', env=localenv)
        tclarray <- get('tclarray', env=localenv)
        vwhich <- get('vwhich', env=localenv)

        # delete all rows 
        tkconfigure(mtable,state='normal')   
        tkdelete(mtable, "rows", '--', 0, nrow(d))

        # massage the data
        d <- .get.data(vwhich)
        tclarray <- .make.tclarray(d)

        # set the data
        tkinsert(mtable, "rows", "end", nrow(d)-1)
        tkconfigure(mtable, colstretchmode="unset", colwidth=max(apply(d,2,nchar)))
        tkconfigure(mtable, variable=tclarray, state='disabled')

        for (i in 1:nrow(d)) {
          row <- d[i,]
          if (any(nchar(row) > as.numeric(commentColSize))) {
            nline <- ceiling(max(nchar(row))/as.numeric(commentColSize))
            tkcmd(mtable,"height",as.character(i-1),as.character(nline))
          } else if (length(grep('\n',row)) != 0) {
            nline <- max(sapply(strsplit(row, '\n'),length))
            tkcmd(mtable,"height",as.character(i-1),as.character(nline))
          }
        }

        # set the col widths, since we might have new values in the cells
        tkcmd(mtable,"width","2",commentColSize)
        tkcmd(mtable, "width","0", as.character(max(nchar(d[,1]))))
        tkcmd(mtable, "width","1", as.character(max(nchar(d[,2]))))           

        # save the data for future calls
        assign('d',d,envir=localenv)
        assign('tclarray',tclarray,envir=localenv)

    }
    tkconfigure(refresh, command=do.refresh)
    cview <- tkbutton(buttonframe, text='Change View')
    do.change <- function(...) {
        vwhich <- get('vwhich', env=localenv)
        if (vwhich == 'all') {
            assign('vwhich', 'funcs', env=localenv)
            tkwm.title(tt, "Object Browser - Functions")
            do.refresh()
        } else if (vwhich == 'funcs') {
            assign('vwhich', 'vars', env=localenv)
            tkwm.title(tt, "Object Browser - Variables")
            do.refresh()
        } else if (vwhich == 'vars') {
            assign('vwhich', 'all', env=localenv)
            tkwm.title(tt, "Object Browser")
            do.refresh()
        }
    }
    tkconfigure(cview, command=do.change)
    tkpack(refresh, side='left')
    tkpack(cview, side='left')

    # make the table itself. We want the first row of our array to be used as
    # the column headers and we also want entries to be left aligned.
    # Also we disallow editing
    mtable <- tkwidget(tt, 'table', 
    rows=nrow(d),cols=ncol(d),
    titlerows=1,
    height=height+1, width=width+1,
    anchor="w",
    ipadx=5, ipady=5,
    colstretchmode="unset",
    resizeborders='none',
    background='white',
    xscrollcommand=function(...) tkset(xscr,...),yscrollcommand=function(...) tkset(yscr,...)) 

    xscr <-tkscrollbar(tt,orient="horizontal", command=function(...)tkxview(mtable,...))
    yscr <- tkscrollbar(tt,command=function(...)tkyview(mtable,...))    


    tkgrid(buttonframe, sticky='w')
    tkgrid(mtable,yscr)
    tkgrid.configure(yscr,sticky="nsw")
    tkgrid(xscr,sticky="new")
    tkconfigure(mtable,variable=tclarray, state='disabled')   


    # Set number of lines for rows that have a long comment (> 30 chars)
    # or a newline embedded in the comment
    for (i in 1:nrow(d)) {
        row <- d[i,]
        if (any(nchar(row) > as.numeric(commentColSize))) {
            nline <- ceiling(max(nchar(row))/as.numeric(commentColSize))
            tkcmd(.Tk.ID(mtable),"height",as.character(i-1),as.character(nline))
        } else if (length(grep('\n',row)) != 0) {
            nline <- max(sapply(strsplit(row, '\n'),length))
            tkcmd(.Tk.ID(mtable),"height",as.character(i-1),as.character(nline))
        }
    }

    # set some features of the comment col and fix the first two column widths
    tktag.configure(mtable, "commentcol", "-multiline", "1", "-wrap", "1")
    tkcmd(mtable, "tag", "col", "commentcol", "2")    
    tkcmd(mtable,"width","2",commentColSize)
    tkcmd(mtable, "width","0", as.character(max(nchar(d[,1]))))
    tkcmd(mtable, "width","1", as.character(max(nchar(d[,2]))))    

}