inst/qt/browseQtFiles.R

In jverzani/ProgGUIinR: support package for "Programming Graphical User Interfaces in R"

  ## three classes
  ## a main class to hold everything
  ## a class fto list the files
  ## a class for dispalying the files

  ## ChunkEditor class implements a simple editor for R code. The main widget comes
  ## from qtbase's qeditor, which has syntax highlighting. To this we add actions to
  ## evaluate a selection, the current line, the current chunk -- as defined by being within
  ## ### blocks (as generated by sweave, say), or the buffer
  ## The format button also formats R text, as there is no automatic indenting the way
  ## emacs does.
  ## @param parent -- not sure what this does, but super might
  ## @return a QWidget instance. Call its show method to create the GUI
  qsetClass("ChunkEditor", Qt$QWidget, function(parent=NULL) {
    super(parent)


    ## editor
                                        #    this$displayFile <- qeditor(tempfile(), rsyntax=TRUE)
    this$displayFile <- Qt$QTextEdit()

    
    ## actions
    this$closeGUIAction <- Qt$QAction("close", this)
    this$sourceLineAction <- Qt$QAction("line", this)
    this$sourceChunkAction <- Qt$QAction("chunk ", this)
    this$sourceBufferAction <- Qt$QAction("buffer", this)
    this$sourceSelectionAction <- Qt$QAction("selection", this)
    this$formatBufferAction <- Qt$QAction("Format buffer", this)
    this$helpAction <- Qt$QAction("Help", this)
    this$actionNames <- c("sourceLine","sourceChunk","sourceBuffer",
                          "sourceSelection", "formatBuffer") ## not needed? , "closeGUI", "help")



    
    ## Emacs shortcuts -- not working
    this$sourceLineAction$setShortcut(Qt$QKeySequence("Ctrl+C, Ctrl+J"))
    this$sourceChunkAction$setShortcut(Qt$QKeySequence("Ctrl+C, Ctrl+C"))
    this$sourceBufferAction$setShortcut(Qt$QKeySequence("Ctrl+C, Ctrl+B"))
    this$sourceSelectionAction$setShortcut(Qt$QKeySequence("Ctrl+C, Ctrl+S")) # not sure of this binding
    this$formatBufferAction$setShortcut(Qt$QKeySequence("Esc-Q"))
    
    ## triggered is key
    ## sapply(actionNames,
    ##        function(i) {
    ##          act <- get(sprintf("%sAction",i), envir=this)
    ##          qconnect(act, "triggered", function(d) {
    ##            get(d$methname, d$this)()
    ##          })
    ##        },
    ##        user.data=list(this=this, methname=i))

    qconnect(closeGUIAction, "triggered", closeGUI)
    qconnect(sourceLineAction, "triggered", sourceLine)
    qconnect(sourceChunkAction, "triggered", sourceChunk)
    qconnect(sourceBufferAction, "triggered", sourceBuffer)
    qconnect(sourceSelectionAction, "triggered", sourceSelection)
    qconnect(formatBufferAction, "triggered", formatBuffer)
    qconnect(helpAction, "triggered", Help)
    



  })

  
  ## Make the GUI that contains the ChunkEditor. Has buttons on top
  ## @return widget to place into GUI
  qsetMethod("makeGUI", ChunkEditor, function() {
    widget <- this
    lyt <- Qt$QVBoxLayout()
    widget$setLayout(lyt)

    blyt <- Qt$QHBoxLayout()
    lyt$addLayout(blyt)
    lyt$addWidget(this$displayFile, 10L)  # stretch

    this$displayFile$setSizePolicy(Qt$QSizePolicy$Expanding,
                                   Qt$QSizePolicy$Expanding)
    
    ## add buttons
    l <- Qt$QLabel(); l$text <- "Evaluate:"
    blyt$addWidget(l)
    sapply(this$actionNames, function(i) {
      a <- get(sprintf("%sAction",i), envir=this)
      b <- Qt$QPushButton()
      assign(sprintf("%sButton",i), this)
      b$addAction(a)
      b$setText(a$text)
      qconnect(b, "clicked", function(bool, a) a$trigger(), user.data=a)
      qconnect(a, "changed", function(l) {
        a <- l$a; b <- l$b
        b$setText(a$text)
        b$setEnabled(a$enabled)
      }, user.data=list(a=a,b=b))

      if(i %in% this$actionNames[1:4]) {
        blyt$addWidget(b)
      } else if(i == this$actionNames[5]) {
        l <- Qt$QLabel(); l$text <- "|"
        blyt$addWidget(l)
        blyt$addWidget(b)
      } else {
        blyt$addWidget(b)
      }
    })
    blyt$addStretch()

    widget
  })

  ## provide a simple help message
  ## @return NULL
  qsetMethod("Help", ChunkEditor, function() {
    mb <- Qt$QMessageBox(this)
    mb$setWindowTitle("ChunkEditor")
    mb$setText("A file editor with highlighting")
    mb$setInformativeText(paste("You can source the file,",
                                "a chunk (between ### comments),",
                                "or the current line", sep="\n"))
    mb$exec()
  })

  ## function to update interface
  ## @return NULL
  qsetMethod("updateInterface", ChunkEditor, function() {

  })


  ## close GUI
  ## @return NULL
  qsetMethod("closeGUI", ChunkEditor, function() {
    this$close()
  })

  ## load file into editor
  ## @param fname File name
  ## @return NULL
  qsetMethod("loadFile", ChunkEditor, function(fname, fsource) {
    if(!missing(fname) && nchar(fname) > 0)                    # XXX do a better check here
      tmp <- readLines(fname)
    else if(!missing(fsource))
      tmp <- fsource
    else
      return()

    edit <- this$displayFile

    
    edit$clear()
    sapply(tmp, function(i) {
      edit$textCursor()$insertText(i)
      edit$textCursor()$insertText("\n")
    })

    ## move to front
    cursor <- edit$textCursor()
    cursor$setPosition(0)
    edit$setTextCursor(cursor)
    edit$ensureCursorVisible()
  })


  ## Method to get various pieces of the buffer
  ##
  ## @param type what piece to get: entire buffer, the block as defined by three comment symbols, the current line, or the current selection
  ## @param return.text logical. If \code{TRUE} returns text, otherwise the selection anchor and position values.
  ## @return Either the text as a character vector or the selection bounds
  qsetMethod("getText", ChunkEditor, function(type=c("buffer","block","line","selection"),
                                              return.text=TRUE) {
    cursor <- this$displayFile$textCursor()

    ## constants
    QtMoveOperation <- c(Start=1, End=11, StartOfLine=3, EndOfLine=13,  Up=2, Down=12)

    blockRegexp <- "^\\s*[#]{3,}"
  mc <- function(dir="Up", keep=0L) {
    cursor$movePosition(QtMoveOperation[dir], keep)
  }
  grabLine <- function() {
    mc("StartOfLine")
    mc("EndOfLine", 1L)
    a <- cursor$selectedText()
    mc("StartOfLine")
    a
  }

  type <- match.arg(type)
  if(type == "line") {
    mc("StartOfLine")
    anchor <- cursor$anchor()
    mc("EndOfLine", 1L)
    position <- cursor$position()
  }   else if(type == "selection") {
    anchor <- cursor$anchor()
    position <- cursor$position()
  } else if(type == "buffer") {
    mc("End")
    anchor=0L
    position <- cursor$position()
  } else {
    ## three steps:
    ## first get out of ### if in it
    ## then go back to first ###, mark anchor
    ## then go down to first ###, this is position
    ## select from anchor to position
    

    ## break out of ### if in one -- go down
    a <- grabLine()
    if(!is.null(a) && grepl(blockRegexp, a)) {
      while(grepl(blockRegexp, a)) {
        if(!mc("Down"))
          break
        a <- grabLine()
      }
    } else {
      ## Else move back until we get to ### or false
      while(is.null(a) || !grepl(blockRegexp, a)) {
        if(!mc("Up")) { # false if can't
          mc("StartOfLine")
          break
        }
        a <- grabLine()
      }
    }
    ## at beginning of block
    a <- grabLine()
    if(!is.null(a) && grepl(blockRegexp, a))
      mc("Down")
    anchor <- cursor$anchor()
    
    ## now move down until we hit a ### block
    a <- grabLine()
    while(!is.null(a) && !grepl(blockRegexp, a)) {
      if(!mc("Down")) { # false if can't
        mc("End")
        break
      }
      a <- grabLine()
    }
    
    position <- cursor$position()
  }

  if(as.logical(return.text)) {
    ## now grab text
    cursor$setPosition(anchor, 0L)
    cursor$setPosition(position, 1L)
    txt <- cursor$selectedText()
    if(!is.null(txt))
      txt <- unlist(strsplit(txt, "\u2029"))
    return(txt)
  } else {
    return(c(anchor=anchor, position=position))
  }
  })

  ## Run a command
  ## @return runs the command, may print, ...
  ## @note can aoverride in subclass to make more interesting things
  qsetMethod("runCommand", ChunkEditor, function(txt=character(0)) {
    ##' run the command, catch errors
    if(is.null(txt) || !length(txt))
      return()
    out <- try(eval(parse(text=txt), envir=.GlobalEnv), silent=TRUE)
    ## CAREFUL, can't use "inherits" here -- it gets picked up as a method for ChunkEditor
                                        #  if(get("inherits")(out, "try-error"))
                                        #    cat("Error")
  })


  ## source current line (through runCommand)
  ## @return calls runCommand
  qsetMethod("sourceLine", ChunkEditor, function() {
    txt <- this$getText(type="line")
    this$runCommand(txt)
  })
  
  ## source the current chunk
  ## @note a chunk is defined by being within blocks marked by ###. These are generated by
  ## Sweave, or can be typed in. The first block need not be demarked this way, nor need the
  ## last block.
  ## @return void
  qsetMethod("sourceChunk", ChunkEditor, function() {
    txt <- this$getText(type="block")
    this$runCommand(txt)
    
  })
  
  ## Source the buffer
  ## @return void
  qsetMethod("sourceBuffer", ChunkEditor, function() {
    txt <- this$getText(type="buffer")
    this$runCommand(txt)
  })
  
  ## Source the current selection, if set
  ## @return void
  qsetMethod("sourceSelection", ChunkEditor, function() {
    txt <- this$getText(type="selection")
    this$runCommand(txt)
  })

  ## format the buffer
  ## @return void
  ## @note Uses code from the formatR package and the animation package.
  qsetMethod("formatBuffer", ChunkEditor, function() {
    txt <- this$getText("buffer")
    con = tempfile()
    enc = getOption("encoding")
    options(encoding = "native.enc")
    on.exit(options(encoding = enc))
    writeLines(txt, con)
    tidy.opt =  list(keep.comment = TRUE, keep.blank.line = TRUE, 
      width.cutoff = 60)
    text.tidy = tidy.source(con, keep.comment = tidy.opt$keep.comment, 
      keep.blank.line = tidy.opt$keep.blank.line, width.cutoff = tidy.opt$width.cutoff, 
      output = FALSE)$text.tidy
    ## Encoding works on some platforms for multi-byte characters...
    Encoding(text.tidy) = "UTF-8"
    this$loadFile(fname="", fsource=unlist(strsplit(text.tidy,"\n")))
    
    
  })


  

####################################################
  ## file selector class

  ## A simple file selector class for selection a file from the given directory
  ## @param dir the current direction to choose the file from
  ## @return sets the file into the ChunkEditor instance
  qsetClass("FileSelector", Qt$QTableWidget, function(dir) {
    if(missing(dir))
      dir <- system.file("Examples","ch-Qt", package="ProgGUIinR")
    
    this$dir <- dir                       # directory
    
    ## table widget to select file
    this$setHorizontalHeaderItem(0, Qt$QTableWidgetItem("Files"))
    this$verticalHeader()$setVisible(FALSE) # no rows
    this$setAlternatingRowColors(TRUE) # alternate shade
    header <- this$horizontalHeader() # stretch column
    header$setStretchLastSection(TRUE)

    ## handler for loading file into buffer
    qconnect(this, "cellClicked", function(row, column, this) {
      item <- this$item(row, 0)
      newFile <-item$text()
      if(!is.null(this$editor)) {
        file <- paste(dir, newFile, sep=.Platform$file.sep)
        ce <- this$chunkEditor()
        ce$loadFile(file)
      }
    }, user.data=this)



  })

  ## Method to make GUI object
  ## @return widget containing object
  qsetMethod("makeGUI", FileSelector, function() {
    widget <- this
    widget$setSizePolicy(Qt$QSizePolicy$Expanding,
                         Qt$QSizePolicy$Expanding)
    widget
  })

  ## method to call to update interface
  ## @return NULL
  qsetMethod("updateInterface", FileSelector, function() {

  })

  ## add a chunk editor instance
  ## @param ed a ChunkEditor instance
  qsetMethod("setChunkEditor", FileSelector, function(ed) {
    this$editor <- ed
  })



  ## get the ChunkEditor. Is this needed? (Better to have accessor methods)
  ## @return returns the associated ChunkEditor for this instance
  qsetMethod("chunkEditor", FileSelector, function() {
    this$editor 
  })

  ## populate list
  ## @note list the available files for browsing. Not heirarchical, but should be.
  ## @return void
  qsetMethod("findFiles", FileSelector, function() {
    QtTableItemFlags <- c(selectable=1, editable=2, dragEnabled=4,dropEnabled=8, userCheckable=16,enabled=32,tristate=64)

    x <- list.files(path=this$dir, pattern="\\.R$")
    this$setColumnCount(1)
    this$setRowCount(length(x))
    for(i in seq_along(x)) {
      item <- Qt$QTableWidgetItem(x[i])
      item$setFlags(as.integer(1 + 32))                   
      this$setItem(i-1, 0, item)
    }
    ## set header name
    item <- Qt$QTableWidgetItem("Files")
    this$setHorizontalHeaderItem(0, item)

  })


##################################################
  ## Main window
  ## Main class to make GUI
  ## @return Returns widget
  qsetClass("browseFiles", Qt$QSplitter, function() {

    this$.chunkEditor <- ChunkEditor()
    this$.fileSelector <- FileSelector()

    this$setWindowTitle("Browse files")
    this$setOrientation(1L)

    ## populate files
    this$fileSelector$setChunkEditor(this$chunkEditor)
    this$fileSelector$findFiles()

    this$makeGUI()
  })

  ## make these accessible to other components
  qsetProperty("chunkEditor", browseFiles)
  qsetProperty("fileSelector", browseFiles)

  ## Make the GUI
  ## @return widget containing GUI
  qsetMethod("makeGUI", browseFiles, function() {
    ## Layout GUI
    this$addWidget(this$fileSelector$makeGUI())
    this$addWidget(this$chunkEditor$makeGUI())
  })

  

  ## tidy source from the animation package
  ## @param source what to tidy
  ## @param keep.comment leave comments
  ## @param keep.blank.line by name
  ## @param begin.comment ??
  ## @param end.comment ??
  ## @param output TRUE
  ## @param width.cutoff specified cutoff
  ## @note just uses the tidy.source function from animation. Idea borrowed
  ## err "lifted" from the formatR package
  `tidy.source` <- function(source = "clipboard", keep.comment = TRUE, 
                            keep.blank.line = TRUE, begin.comment, end.comment, output = TRUE, 
                            width.cutoff = 60L, ...) {
    if (source == "clipboard" && Sys.info()["sysname"] == "Darwin") {
      source = pipe("pbpaste")
    }
    tidy.block = function(block.text) {
      exprs = base::parse(text = block.text)
      n = length(exprs)
      res = character(n)
      for (i in 1:n) {
        dep = paste(base::deparse(exprs[i], width.cutoff), collapse = "\n")
        res[i] = substring(dep, 12, nchar(dep) - 1)
      }
      return(res)
    }
    text.lines = readLines(source, warn = FALSE)
    if (keep.comment) {
      identifier = function() paste(sample(LETTERS), collapse = "")
      if (missing(begin.comment)) 
        begin.comment = identifier()
      if (missing(end.comment)) 
        end.comment = identifier()
      text.lines = gsub("^[[:space:]]+|[[:space:]]+$", "", 
        text.lines)
      while (length(grep(sprintf("%s|%s", begin.comment, end.comment), 
                         text.lines))) {
        begin.comment = identifier()
        end.comment = identifier()
      }
      head.comment = substring(text.lines, 1, 1) == "#"
      if (any(head.comment)) {
        text.lines[head.comment] = gsub("\"", "'", text.lines[head.comment])
        text.lines[head.comment] = sprintf("%s=\"%s%s\"", 
                    begin.comment, text.lines[head.comment], end.comment)
      }
      blank.line = text.lines == ""
      if (any(blank.line) & keep.blank.line) 
        text.lines[blank.line] = sprintf("%s=\"%s\"", begin.comment, 
                    end.comment)
      text.mask = tidy.block(text.lines)
      text.tidy = gsub(sprintf("%s = \"|%s\"", begin.comment, 
        end.comment), "", text.mask)
    }
    else {
      text.tidy = text.mask = tidy.block(text.lines)
      begin.comment = end.comment = ""
    }
    if (output) cat(paste(text.tidy, collapse = "\n"), "\n", ...)
    invisible(list(
                   text.tidy = text.tidy,
                   text.mask = text.mask, 
                   begin.comment = begin.comment,
                   end.comment = end.comment
                   )
              )
  }