[Rqda-commits] r16 - in pkg: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Nov 20 07:53:24 CET 2008
Author: wincent
Date: 2008-11-20 07:53:23 +0100 (Thu, 20 Nov 2008)
New Revision: 16
Added:
pkg/R/CaseButton.R
pkg/R/CodesFun.R
pkg/R/Coding_Buttons.R
pkg/R/FileButton.R
pkg/R/FilesFun.R
pkg/R/GUIHandler.R
pkg/R/ProjectButton.R
pkg/R/ProjectFun.R
pkg/R/Rename.R
Removed:
pkg/R/codes.R
pkg/R/files.R
pkg/R/project.R
Modified:
pkg/ChangeLog
pkg/DESCRIPTION
pkg/R/root_gui.R
pkg/R/sysdata.rda
pkg/R/zzz.R
pkg/TODO
pkg/man/RQDA-internal.rd
Log:
Make major revision to the dataset structure; handle encoding issue better(now use UTF-8 in dataset); add rename buttons; add case categry etc. see changelog for more.
Modified: pkg/ChangeLog
===================================================================
--- pkg/ChangeLog 2008-11-04 12:48:34 UTC (rev 15)
+++ pkg/ChangeLog 2008-11-20 06:53:23 UTC (rev 16)
@@ -1,3 +1,10 @@
+2008-11-19 (as verion 0.1.4)
+ * Add project memo
+ * rename of file/free code names
+ * reorganize the code for memo(s)
+ * Handle Encoding better (use UTF-8 for storage in date base)
+ * Add cases category
+
2008-11-01
* Add functionality of file/code/coding memo.
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2008-11-04 12:48:34 UTC (rev 15)
+++ pkg/DESCRIPTION 2008-11-20 06:53:23 UTC (rev 16)
@@ -1,11 +1,11 @@
Package: RQDA
Type: Package
Title: Qualitative data analysis
-Version: 0.1.3
+Version: 0.1.4
Date: 2008-11-01
Author: Huang Ronggui
Maintainer: Huang <ronggui.huang at gmail.com>
Depends: DBI, RSQLite, RGtk2, gWidgets, gWidgetsRGtk2
Description: Qualitative Data Analysis based on R language. Current version only supports plain text.
-License: Non-commercial use only.
+License: FreeBSD
LazyLoad: yes
Added: pkg/R/CaseButton.R
===================================================================
--- pkg/R/CaseButton.R (rev 0)
+++ pkg/R/CaseButton.R 2008-11-20 06:53:23 UTC (rev 16)
@@ -0,0 +1,152 @@
+AddCaseButton <- function(label="ADD"){
+ gbutton(label,handler=function(h,...) {
+ if (is_projOpen(env=.rqda,conName="qdacon")) {
+ CaseName <- ginput("Enter new Case Name. ", icon="info")
+ Encoding(CaseName) <- "UTF-8"
+ AddCase(CaseName)
+ CaseNamesUpdate()
+ }
+ }
+ )
+}
+
+DeleteCaseButton <- function(label="Delete"){
+ gbutton(label,
+ handler=function(h,...)
+ {
+ if (is_projOpen(env=.rqda,conName="qdacon") &
+ length(svalue(.rqda$.CasesNamesWidget))!=0) {
+ del <- gconfirm("Really delete the Case?",icon="question")
+ if (isTRUE(del)){
+ SelectedCase <- svalue(.rqda$.CasesNamesWidget)
+ Encoding(SelectedCase) <- "UTF-8"
+ dbGetQuery(.rqda$qdacon,sprintf("update cases set status=0 where name=='%s'",SelectedCase))
+ ## set status in table freecode to 0
+ CaseNamesUpdate()
+ }
+ }
+ }
+ )
+}
+
+Case_RenameButton <- function(label="Rename",CaseNamesWidget=.rqda$.CasesNamesWidget,...)
+{
+ ## rename of selected case.
+ gbutton(label,handler=function(h,...) {
+ if (is_projOpen(env=.rqda,"qdacon")) {
+ ## if project is open, then continue
+ selectedCaseName <- svalue(CaseNamesWidget)
+ if (length(selectedCaseName)==0){
+ gmessage("Select a Case first.",icon="error",con=TRUE)
+ }
+ else {
+ ## get the new file names
+ NewName <- ginput("Enter new Case name. ", icon="info")
+ Encoding(NewName) <- "UTF-8"
+ rename(selectedCaseName,NewName,"cases")
+ }
+ }
+ }
+ )
+}
+
+
+###############
+AddCase <- function(name,conName="qdacon",assignenv=.rqda,...) {
+ if (name != ""){
+ con <- get(conName,assignenv)
+ maxid <- dbGetQuery(con,"select max(id) from cases")[[1]]
+ nextid <- ifelse(is.na(maxid),0+1, maxid+1)
+ write <- FALSE
+ if (nextid==1){
+ write <- TRUE
+ } else {
+ dup <- dbGetQuery(con,sprintf("select name from cases where name=='%s'",name))
+ if (nrow(dup)==0) write <- TRUE
+ }
+ if (write ) {
+ dbGetQuery(con,sprintf("insert into cases (name, id, status,date,owner)
+ values ('%s', %i, %i,%s, %s)",
+ name,nextid, 1, shQuote(date()),shQuote(.rqda$owner)))
+ }
+ }
+}
+
+CaseNamesUpdate <- function(CaseNamesWidget=.rqda$.CasesNamesWidget,...)
+{
+ CaseName <- dbGetQuery(.rqda$qdacon, "select name, id from cases where status=1")
+ if (nrow(CaseName)!=0) {
+ Encoding(CaseName[['name']]) <- "UTF-8"
+ tryCatch(CaseNamesWidget[] <- CaseName[['name']], error=function(e){})
+ }
+}
+
+
+
+CaseMark_Button<-function(){
+ gbutton("Mark",
+ handler=function(h,...) {
+ if (is_projOpen(env=.rqda,conName="qdacon")) {
+ con <- .rqda$qdacon
+ tryCatch({
+ ans <- mark(get(h$action$widget,env=.rqda)) ## can change the color
+ if (ans$start != ans$end){
+ ## when selected no text, makes on sense to do anything.
+ SelectedCase <- svalue(.rqda$.CasesNamesWidget)
+ Encoding(SelectedCase) <- "UTF-8"
+ currentCid <- dbGetQuery(con,sprintf("select id from cases where name=='%s'",
+ SelectedCase))[,1]
+ SelectedFile <- svalue(.rqda$.root_edit)
+ Encoding(SelectedFile) <- "UTF-8"
+ currentFid <- dbGetQuery(con,sprintf("select id from source where name=='%s'",
+ SelectedFile))[,1]
+ DAT <- data.frame(cid=currentCid,fid=currentFid,
+ selfirst=ans$start,selend=ans$end,status=1,
+ owner=.rqda$owner,date=date(),memo="")
+ success <- dbWriteTable(.rqda$qdacon,"caselinkage",DAT,row.name=FALSE,append=TRUE)
+ if (!success) gmessage("Fail to write to database.")
+ }
+ },error=function(e){}
+ )
+ }
+ },
+ action=list(widget=".openfile_gui")
+ )
+}
+
+
+CaseMemoButton <- function(label="Memo",...){
+ gbutton(label, handler=function(h,...) {
+ ## code memo: such as meaning of code etc.
+ if (is_projOpen(env=.rqda,"qdacon")) {
+ currentCase <- svalue(.rqda$.CasesNamesWidget)
+ if (length(currentCase)==0){
+ gmessage("Select a Case first.",icon="error",con=TRUE)
+ }
+ else {
+ tryCatch(dispose(.rqda$.casememo),error=function(e) {})
+ assign(".casememo",gwindow(title=paste("Case Memo",.rqda$currentCase,sep=":"),
+ parent=c(370,10),width=600,height=400),env=.rqda)
+ .casememo <- .rqda$.casememo
+ .casememo2 <- gpanedgroup(horizontal = FALSE, con=.casememo)
+ gbutton("Save Case Memo",con=.casememo2,handler=function(h,...){
+ newcontent <- svalue(W)
+ Encoding(newcontent) <- "UTF-8"
+ newcontent <- enc(newcontent) ## take care of double quote.
+ Encoding(currentCase) <- "UTF-8"
+ dbGetQuery(.rqda$qdacon,sprintf("update cases set memo='%s' where name='%s'",newcontent,currentCase))
+ }
+ )## end of save memo button
+ assign(".casememoW",gtext(container=.casememo2,font.attr=c(sizes="large")),env=.rqda)
+ prvcontent <- dbGetQuery(.rqda$qdacon, sprintf("select memo from cases where name='%s'",currentCase))[1,1]
+ if (is.na(prvcontent)) prvcontent <- ""
+ Encoding(prvcontent) <- "UTF-8"
+ W <- .rqda$.casememoW
+ add(W,prvcontent,font.attr=c(sizes="large"),do.newline=FALSE)
+ }
+ }
+ }
+ )
+}
+
+
Added: pkg/R/CodesFun.R
===================================================================
--- pkg/R/CodesFun.R (rev 0)
+++ pkg/R/CodesFun.R 2008-11-20 06:53:23 UTC (rev 16)
@@ -0,0 +1,120 @@
+addcode <- function(name,conName="qdacon",assignenv=.rqda,...) {
+ if (name != ""){
+ con <- get(conName,assignenv)
+ maxid <- dbGetQuery(con,"select max(id) from freecode")[[1]]
+ nextid <- ifelse(is.na(maxid),0+1, maxid+1)
+ write <- FALSE
+ if (nextid==1){
+ write <- TRUE
+ } else {
+ dup <- dbGetQuery(con,sprintf("select name from freecode where name=='%s'",name))
+ if (nrow(dup)==0) write <- TRUE
+ }
+ if (write ) {
+ dbGetQuery(con,sprintf("insert into freecode (name, id, status,date,owner)
+ values ('%s', %i, %i,%s, %s)",
+ name,nextid, 1, shQuote(date()),shQuote(.rqda$owner)))
+ }
+ }
+}
+
+
+
+CodeNamesUpdate <- function(CodeNamesWidget=.rqda$.codes_rqda,...)
+{
+ if (isIdCurrent(.rqda$qdacon)){
+ codesName <- dbGetQuery(.rqda$qdacon, "select name, id from freecode where status=1")
+ if (nrow(codesName)!=0) {
+ Encoding(codesName[['name']]) <- "UTF-8"
+ tryCatch(CodeNamesWidget[] <- codesName[['name']], error=function(e){})
+ } else cat("Project is closed already.\n")
+}
+}
+
+
+mark <- function(widget){
+ index <- sindex(widget)
+ startI <- index$startI ## start and end iter
+ endI <- index$endI
+ selected <- index$seltext
+ Encoding(selected) <- "UTF-8"
+ startN <- index$startN # translate iter pointer to number
+ endN <- index$endN
+ if (startN != endN){
+ buffer <- slot(widget,"widget")@widget$GetBuffer()
+ buffer$createTag("red.foreground",foreground = "red")
+ buffer$ApplyTagByName("red.foreground",startI,endI); ## change colors
+ }
+ ## only when selected text chunk is not "", apply the color scheme.
+ return(list(start=startN,end=endN,text=selected))
+}
+
+
+
+ClearMark <- function(widget,min=0, max){
+ ## max position of marked text.
+ tryCatch({
+ buffer <- slot(widget,"widget")@widget$GetBuffer()
+ startI <-gtkTextBufferGetIterAtOffset(buffer,min)$iter # translate number back to iter
+ endI <-gtkTextBufferGetIterAtOffset(buffer,max)$iter
+ gtkTextBufferRemoveTagByName(buffer,"red.foreground",startI,endI)},
+ error=function(e){})
+}
+
+
+HL <- function(W,index){
+ ## W is the gtext widget of the text.
+ ## highlight text chuck according to index
+ ## index is a data frame, each row == one text chuck.
+ tryCatch(
+ apply(index,1, function(x){
+ buffer <- slot(W,"widget")@widget$GetBuffer()
+ start <-gtkTextBufferGetIterAtOffset(buffer,x[1])$iter # translate number back to iter
+ end <-gtkTextBufferGetIterAtOffset(buffer,x[2])$iter
+ buffer$createTag("red.foreground",foreground = "red")
+ buffer$ApplyTagByName("red.foreground",start,end)}),
+ error=function(e){})
+}
+
+
+
+sindex <- function(widget){
+ buffer <- slot(widget,"widget")@widget$GetBuffer()
+ bounds = buffer$GetSelectionBounds()
+ startI = bounds$start ## start and end iter
+ endI = bounds$end
+ selected <- buffer$GetText(startI,endI)
+ startN <- gtkTextIterGetOffset(startI) # translate iter pointer to number
+ endN <- gtkTextIterGetOffset(endI)
+ return(list(startI=startI,endI=endI,
+ startN=startN,endN=endN,seltext=selected))
+}
+
+
+
+retrieval <- function(){
+ currentCode <- svalue(.rqda$.codes_rqda)
+ Encoding(currentCode) <- "UTF-8"
+ currentCid <- dbGetQuery(.rqda$qdacon,sprintf("select id from freecode where name== '%s' ",currentCode))[1,1]
+ ## reliable is more important
+ retrieval <- dbGetQuery(.rqda$qdacon,sprintf("select cid,fid, selfirst, selend,seltext from coding where status==1 and cid=%i",currentCid))
+ fid <- unique(retrieval$fid)
+ .gw <- gwindow(title=sprintf("Retrieved text: %s",currentCode),parent=c(370,10),width=600,height=600)
+ .retreivalgui <- gtext(con=.gw)
+ for (i in fid){
+ FileNames <- dbGetQuery(.rqda$qdacon,sprintf("select name from source where status==1 and id==%i",i))[['name']]
+ tryCatch(Encoding(FileNames) <- "UTF-8",error=function(e){})
+ fname <- paste("Source: ", FileNames, sep="")
+ seltext <- retrieval$seltext[retrieval$fid==i]
+ seltext <- paste(seltext,collapse="\n\n")
+ CodingIndex <- retrieval[retrieval$fid==i,c("selfirst","selend")]
+ CodingIndex <- apply(CodingIndex,1,FUN=function(x) paste(x,sep="",collapse=":"))
+ Encoding(seltext) <- "UTF-8"
+ add(.retreivalgui,fname,font.attr=c(style="italic",size="x-large"))
+ add(.retreivalgui,CodingIndex,font.attr=c(style="italic",size="x-large"))
+ add(.retreivalgui,"\n",font.attr=c(style="italic"))
+ add(.retreivalgui,seltext,font.attr=c(style="normal",size="large"))
+ add(.retreivalgui,"\n",font.attr=c(style="italic"))
+ }
+}
+
Added: pkg/R/Coding_Buttons.R
===================================================================
--- pkg/R/Coding_Buttons.R (rev 0)
+++ pkg/R/Coding_Buttons.R 2008-11-20 06:53:23 UTC (rev 16)
@@ -0,0 +1,267 @@
+AddCodeButton <- function(){
+ gbutton(" ADD ",
+ handler=function(h,...) {
+ if (is_projOpen(env=.rqda,conName="qdacon")) {
+ codename <- ginput("Enter new code. ", icon="info")
+ Encoding(codename) <- "UTF-8"
+ addcode(codename)
+ CodeNamesUpdate()
+ }
+ }
+ )
+}
+
+
+DeleteCodeButton <- function(){
+ gbutton(" Delete ",
+ handler=function(h,...)
+ {
+ if (is_projOpen(env=.rqda,conName="qdacon") &
+ length(svalue(.rqda$.codes_rqda))!=0) {
+ ## if project is open and one code is selected,then continue
+ del <- gconfirm("Really delete the code?",icon="question")
+ if (isTRUE(del)){
+ SelectedCode <- svalue(.rqda$.codes_rqda)
+ Encoding(SelectedCode) <- "UTF-8"
+ dbGetQuery(.rqda$qdacon,sprintf("update freecode set status=0 where name=='%s'",SelectedCode))
+ ## set status in table freecode to 0
+ CodeNamesUpdate()
+ }
+ }
+ }
+ )
+}
+
+RetrievalButton <- function(label){
+ gbutton(label,
+ handler=function(h,...) {
+ if (is_projOpen(env=.rqda,conName="qdacon")) {
+ retrieval()
+ }
+ }
+ )
+}
+
+
+HL_ALLButton <- function(){
+ gbutton("HL ALL",
+ handler=function(h,...) {
+ if (is_projOpen(env=.rqda,conName="qdacon")) {
+ con <- .rqda$qdacon
+ SelectedFile <- svalue(.rqda$.root_edit)
+ Encoding(SelectedFile) <- "UTF-8"
+ currentFid <- dbGetQuery(con,sprintf("select id from source where name=='%s'",SelectedFile))[,1]
+ W <- tryCatch( get(h$action$widget,.rqda),
+ error=function(e) {}
+ )
+ if (length(currentFid)!=0 & !is.null(W)) {
+ ## if fid is integer(0), then there is no file selected and open
+ ## if W is null, then there is no valid widget. No need to HL.
+ ## Though W may be expired, but ClearMark and HL will take care of the issue.
+ mark_index <-
+ dbGetQuery(con,sprintf("select selfirst,selend,status from coding where fid=%i",currentFid))
+ ## only select thoses with the open_file and not deleted (status=1).
+ ClearMark(W ,0 , max(mark_index$selend))
+ HL(W,index=mark_index[mark_index$status==1,1:2])
+ }
+ }
+ },
+ action=list(widget=".openfile_gui")
+ )
+}
+
+
+
+Mark_Button<-function(){
+ gbutton("Mark",
+ handler=function(h,...) {
+ if (is_projOpen(env=.rqda,conName="qdacon")) {
+ con <- .rqda$qdacon
+ tryCatch({
+ ans <- mark(get(h$action$widget,env=.rqda)) ## can change the color
+ if (ans$start != ans$end){
+ ## when selected no text, makes on sense to do anything.
+ SelectedCode <- svalue(.rqda$.codes_rqda)
+ Encoding(SelectedCode) <- "UTF-8"
+ currentCid <- dbGetQuery(con,sprintf("select id from freecode where name=='%s'",
+ SelectedCode))[,1]
+ SelectedFile <- svalue(.rqda$.root_edit)
+ Encoding(SelectedFile) <- "UTF-8"
+ currentFid <- dbGetQuery(con,sprintf("select id from source where name=='%s'",
+ SelectedFile))[,1]
+ DAT <- data.frame(cid=currentCid,fid=currentFid,seltext=ans$text,
+ selfirst=ans$start,selend=ans$end,status=1,
+ owner=.rqda$owner,date=date(),memo="")
+ success <- dbWriteTable(.rqda$qdacon,"coding",DAT,row.name=FALSE,append=TRUE)
+ if (!success) gmessage("Fail to write to database.")
+ }
+ },error=function(e){}
+ )
+ }
+ },
+ action=list(widget=".openfile_gui")
+ )
+}
+
+
+Unmark_Button <- function(){
+ gbutton("Unmark",
+ handler=function(h,...) {
+ if (is_projOpen(env=.rqda,conName="qdacon")) {
+ con <- .rqda$qdacon
+ W <- tryCatch( get(h$action$widget,env=.rqda),
+ error=function(e){}
+ )
+ ## get the widget for file display. If it does not exist, then return NULL.
+ sel_index <- tryCatch(sindex(W),error=function(e) {})
+ ## if the not file is open, unmark doesn't work.
+ if (!is.null(sel_index)) {
+ SelectedCode <- svalue(.rqda$.codes_rqda)
+ Encoding(SelectedCode) <- "UTF-8"
+ currentCid <- dbGetQuery(.rqda$qdacon,
+ sprintf("select id from freecode where name=='%s'",
+ SelectedCode))[,1]
+ SelectedFile <- svalue(.rqda$.root_edit)
+ Encoding(SelectedFile) <- "UTF-8"
+ currentFid <- dbGetQuery(con,sprintf("select id from source where name=='%s'",
+ SelectedFile))[,1]
+codings_index <- dbGetQuery(con,sprintf("select rowid, cid, fid, selfirst, selend from coding where cid==%i and fid==%i",
+ currentCid, currentFid))
+ ## should only work with those related to current code and current file.
+ rowid <- codings_index$rowid[(codings_index$selfirst >= sel_index$startN) &
+ (codings_index$selend <= sel_index$endN)]
+ if (is.numeric(rowid)) for (j in rowid) {
+ dbGetQuery(con,sprintf("update coding set status=0 where rowid=%i", j)) }
+ ## better to get around the loop by sqlite condition expression.
+ ClearMark(W,min=sel_index$startN,max=sel_index$endN)
+ ## This clear all the marks in the gtext window,
+ ## even for the non-current code. can improve.
+ }
+ }
+ },
+ action=list(widget=".openfile_gui")
+ )
+}
+
+
+
+
+CodeMemoButton <- function(label="C-Memo",...){
+ gbutton(label, handler=function(h,...) {
+ ## code memo: such as meaning of code etc.
+ if (is_projOpen(env=.rqda,"qdacon")) {
+ currentCode <- svalue(.rqda$.codes_rqda)
+ if (length(currentCode)==0){
+ gmessage("Select a code first.",icon="error",con=TRUE)
+ }
+ else {
+ tryCatch(dispose(.rqda$.codememo),error=function(e) {})
+ assign(".codememo",gwindow(title=paste("Code Memo",.rqda$currentCode,sep=":"),
+ parent=c(370,10),width=600,height=400),env=.rqda)
+ .codememo <- .rqda$.codememo
+ .codememo2 <- gpanedgroup(horizontal = FALSE, con=.codememo)
+ gbutton("Save Code Memo",con=.codememo2,handler=function(h,...){
+ newcontent <- svalue(W)
+ Encoding(newcontent) <- "UTF-8"
+ newcontent <- enc(newcontent) ## take care of double quote.
+ Encoding(currentCode) <- "UTF-8"
+ dbGetQuery(.rqda$qdacon,sprintf("update freecode set memo='%s' where name='%s'",newcontent,currentCode))
+ }
+ )## end of save memo button
+ assign(".cmemocontent",gtext(container=.codememo2,font.attr=c(sizes="large")),env=.rqda)
+ prvcontent <- dbGetQuery(.rqda$qdacon, sprintf("select memo from freecode where name='%s'",currentCode))[1,1]
+ if (is.na(prvcontent)) prvcontent <- ""
+ Encoding(prvcontent) <- "UTF-8"
+ W <- .rqda$.cmemocontent
+ add(W,prvcontent,font.attr=c(sizes="large"),do.newline=FALSE)
+ }
+ }
+ }
+ )
+}
+
+
+
+
+
+
+CodingMemoButton <- function(label="C2Memo")
+{
+ gbutton(label, handler= function(h,...){
+ con <- .rqda$qdacon
+ if (is_projOpen(env=.rqda,conName="qdacon")) {
+ W <- tryCatch( get(".openfile_gui",env=.rqda), error=function(e){})
+ ## get the widget for file display. If it does not exist, then return NULL.
+ sel_index <- tryCatch(sindex(W),error=function(e) {}) ## if the not file is open, it doesn't work.
+ if (is.null(sel_index)) {gmessage("Open a file first!",con=TRUE)}
+ else {
+ SelectedCode <- svalue(.rqda$.codes_rqda); Encoding(SelectedCode) <- "UTF-8"
+ if (length(SelectedCode)==0) gmessage("Select a code first!") else {
+ currentCid <- dbGetQuery(con,sprintf("select id from freecode where name=='%s'",SelectedCode))[,1]
+ SelectedFile <- svalue(.rqda$.fnames_rqda); Encoding(SelectedFile) <- "UTF-8"
+ currentFid <- dbGetQuery(con,sprintf("select id from source where name=='%s'",SelectedFile))[,1]
+ codings_index <- dbGetQuery(con,sprintf("select rowid, cid, fid, selfirst, selend from coding where
+ cid==%i and fid==%i ",currentCid, currentFid))
+ ## should only work with those related to current code and current file.
+ rowid <- codings_index$rowid[(codings_index$selfirst >= sel_index$startN) &
+ (codings_index$selfirst <= sel_index$startN + 4) &
+ (codings_index$selend <= sel_index$endN)&
+ (codings_index$selend >= sel_index$endN - 4)
+ ] ## determine which one is the current text chunk?
+ if (length(rowid)!= 1) {gmessage("Select the exact coding first!", con=TRUE)}
+ else {
+ ## open a widget for memo, and take care of the save memo function
+ tryCatch(dispose(.rqda$.codingmemo),error=function(e) {})
+ ## Close the coding memo first, then open a new one
+ assign(".codingmemo",gwindow(title=paste("Coding Memo for",SelectedCode,sep=":"),
+ parent=c(370,10),width=600,height=400
+ ), env=.rqda
+ )
+ .codingmemo <- get(".codingmemo",env=.rqda)
+ .codingmemo2 <- gpanedgroup(horizontal = FALSE, con=.codingmemo)
+ gbutton("Save Coding Memo",con=.codingmemo2,handler=function(h,...){
+ newcontent <- svalue(W)
+ Encoding(newcontent) <- "UTF-8"
+ newcontent <- enc(newcontent) ## take care of double quote.
+ dbGetQuery(con,sprintf("update coding set memo='%s' where rowid=%i",newcontent,rowid))
+ }
+ )## end of save memo button
+ assign(".cdmemocontent",gtext(container=.codingmemo2,font.attr=c(sizes="large")),env=.rqda)
+ prvcontent <- dbGetQuery(con, sprintf("select memo from coding where rowid=%i",rowid))[1,1]
+ if (is.na(prvcontent)) prvcontent <- ""
+ Encoding(prvcontent) <- "UTF-8"
+ W <- get(".cdmemocontent",env=.rqda)
+ add(W,prvcontent,font.attr=c(sizes="large"),do.newline=FALSE)
+ }
+ }
+ }
+ }
+ }
+ )
+}
+
+
+
+FreeCode_RenameButton <- function(label="Rename",CodeNamesWidget=.codes_rqda,...)
+{
+ ## rename of selected file.
+ gbutton(label,handler=function(h,...) {
+ if (is_projOpen(env=.rqda,"qdacon")) {
+ ## if project is open, then continue
+ selectedCodeName <- svalue(CodeNamesWidget)
+ if (length(selectedCodeName)==0){
+ gmessage("Select a code first.",icon="error",con=TRUE)
+ }
+ else {
+ ## get the new file names
+ NewCodeName <- ginput("Enter new code name. ", icon="info")
+ Encoding(NewCodeName) <- "UTF-8"
+ ## update the name in source table by a function
+ rename(selectedCodeName,NewCodeName,"freecode")
+ ## (name is the only field should be modifed, as other table use ID rather than name)
+ }
+ }
+ }
+ )
+}
+
Added: pkg/R/FileButton.R
===================================================================
--- pkg/R/FileButton.R (rev 0)
+++ pkg/R/FileButton.R 2008-11-20 06:53:23 UTC (rev 16)
@@ -0,0 +1,129 @@
+ImportFileButton <- function(label="Import", container,...)
+{
+ gbutton(label, contain=container, handler=function(h,...){
+ if (is_projOpen(env=.rqda,conName="qdacon")) {
+ path <- gfile(type="open",filter=list("text files" = list(mime.types = c("text/plain"))))
+ if (path!=""){
+ Encoding(path) <- "UTF-8" ## have to convert, otherwise, can not find the file.
+ ImportFile(path,con=.rqda$qdacon)
+ }
+ }
+ }
+ )
+}
+
+
+DeleteFileButton <- function(label="Delete", container,...){
+ gbutton(label,contain=container,handler=function(h,...)
+ {
+ if (is_projOpen(env=.rqda,conName="qdacon") & length(svalue(.rqda$.fnames_rqda))!=0) {
+ ## if the project open and a file is selected, then continue the action
+ del <- gconfirm("Really delete the file?",icon="question")
+ if (isTRUE(del)) {
+ con <- .rqda$qdacon
+ SelectedFile <- svalue(.rqda$.fnames_rqda)
+ Encoding(SelectedFile) <- "UTF-8"
+ dbGetQuery(.rqda$qdacon, sprintf("update source set status=0 where name='%s'",SelectedFile))
+ ## set the status of the selected file to 0
+ FileNamesUpdate()
+ }
+ }
+ },
+ action=list(env=.rqda,conName="qdacon")
+ )
+}
+
+ViewFileButton <- function(label="Open", container,...){
+ gbutton(label,contain=container,h=function(h,...){
+ if (is_projOpen(env=.rqda,conName="qdacon")) {
+ if (length(svalue(.rqda$.fnames_rqda))==0){gmessage("Select a file first.",icon="error",con=TRUE)}
+ else {
+ tryCatch(dispose(.rqda$.root_edit),error=function(e) {})
+ ## notice the error handler
+ assign(".root_edit",gwindow(title=svalue(.rqda$.fnames_rqda), parent=c(370,10),width=600,height=600),env=.rqda)
+ .root_edit <- get(".root_edit",.rqda)
+ assign(".openfile_gui",gtext(container=.root_edit,font.attr=c(sizes="large")),env=.rqda)
+ content <- dbGetQuery(.rqda$qdacon, sprintf("select file from source where name='%s'",svalue(.rqda$.fnames_rqda)))[1,1]
+ Encoding(content) <- "UTF-8" ## so it display correct in the gtext widget
+ ## turn data.frame to 1-length character.
+ W <- get(".openfile_gui",.rqda)
+ add(W,content,font.attr=c(sizes="large"))
+ slot(W,"widget")@widget$SetEditable(FALSE)
+ ## make sure it is read only file in the text window.
+ }
+ }
+ }
+ )
+}
+
+
+File_MemoButton <- function(label="F-Memo", container=.files_button,FileWidget=.fnames_rqda,...){
+ ## memo of selected file.
+ gbutton(label, contain=container, handler=function(h,...) {
+ if (is_projOpen(env=.rqda,"qdacon")) {
+ ## if project is open, then continue
+ selectedFN <- svalue(FileWidget) ## svalue(.fnames_rqda) is the name of selected file.
+ if (length(selectedFN)==0){
+ ## if no file is selected, then no need to memo.
+ gmessage("Select a file first.",icon="error",con=TRUE)
+ }
+ else {
+ tryCatch(dispose(.rqda$.filememo),error=function(e) {})
+ ## Close the open file memo first, then open a new one
+ ## .filememo is the container of .fmemocontent,widget for the content of memo
+ assign(".filememo",gwindow(title=paste("File Memo",selectedFN,sep=":"),
+ parent=c(370,10),width=600,height=400),env=.rqda)
+ .filememo <- .rqda$.filememo
+ .filememo2 <- gpanedgroup(horizontal = FALSE, con=.filememo)
+ ## use .filememo2, so can add a save button to it.
+ gbutton("Save memo",con=.filememo2,handler=function(h,...){
+ ## send the new content of memo back to database
+ newcontent <- svalue(W)
+ Encoding(newcontent) <- "UTF-8"
+ newcontent <- enc(newcontent) ## take care of double quote.
+ dbGetQuery(.rqda$qdacon,sprintf("update source set memo='%s' where name='%s'",newcontent,selectedFN))
+ ## have to quote the character in the sql expression
+ }
+ )
+ assign(".fmemocontent",gtext(container=.filememo2,font.attr=c(sizes="large")),env=.rqda)
+ prvcontent <- dbGetQuery(.rqda$qdacon, sprintf("select memo from source where name='%s'",svalue(FileWidget)))[1,1]
+ ## [1,1]turn data.frame to 1-length character. Existing content of memo
+ if (is.na(prvcontent)) prvcontent <- ""
+ Encoding(prvcontent) <- "UTF-8" ## important
+ W <- .rqda$.fmemocontent
+ add(W,prvcontent,font.attr=c(sizes="large"),do.newline=FALSE)
+ ## push the previous content to the widget.
+ }
+ }
+ }
+ )
+}
+
+
+
+File_RenameButton <- function(label="Rename", container=.files_button,FileWidget=.fnames_rqda,...)
+{
+ ## rename of selected file.
+ gbutton(label, contain=container, handler=function(h,...) {
+ if (is_projOpen(env=.rqda,"qdacon")) {
+ ## if project is open, then continue
+ selectedFN <- svalue(FileWidget)
+ if (length(selectedFN)==0){
+ gmessage("Select a file first.",icon="error",con=TRUE)
+ }
+ else {
+ ## get the new file names
+ NewFileName <- ginput("Enter new file name. ", icon="info")
+ Encoding(NewFileName) <- "UTF-8"
+ ## otherwise, R transform it into local Encoding rather than keep it as UTF-8
+ ## Newfilename <- iconv(codename,from="UTF-8") ## now use UTF-8 for SQLite data set.
+ ## update the name in source table by a function
+ rename(selectedFN,NewFileName,"source")
+ ## (name is the only field should be modifed, as other table use fid rather than name)
+ }
+ }
+ }
+ )
+}
+
+
Added: pkg/R/FilesFun.R
===================================================================
--- pkg/R/FilesFun.R (rev 0)
+++ pkg/R/FilesFun.R 2008-11-20 06:53:23 UTC (rev 16)
@@ -0,0 +1,58 @@
+ImportFile <- function(path,encoding=.rqda$encoding,con=.rqda$qdacon,...){
+ ## import a file into a DBI connection _con_.
+ Fname <- gsub("\\.[[:alpha:]]*$","",basename(path))## Fname is in locale Encoding Now.
+ FnameUTF8 <- iconv(Fname,to="UTF-8")
+ ## remove the suffix such as .txt
+ if ( Fname!="" ) {
+ file_con <- file(path,open="r")
+ if (isTRUE(.rqda$BOM)) seek(file_con,3)
+ content <- readLines(file_con,warn=FALSE,encoding=encoding)
+ close(file_con)
+ content <- paste(content,collapse="\n")
+ content <- enc(content)
+ if (Encoding(content)!="UTF-8"){
+ content <- iconv(content,to="UTF-8") ## UTF-8 file content
+ }
+ maxid <- dbGetQuery(con,"select max(id) from source")[[1]]
+ nextid <- ifelse(is.na(maxid),0+1, maxid+1)
+ write <- FALSE
+ ## check if the content should be written into con.
+ if (nextid==1) {
+ write <- TRUE
+ ## if this is the first file, no need to worry about the duplication issue.
+ } else {
+ if (nrow(dbGetQuery(con,sprintf("select name from source where name=='%s'",FnameUTF8)))==0) {
+ ## no duplication file exists, then write.
+ write <- TRUE
+ } else {
+ gmessage("A file withe the same name exists in the database!")
+ }
+ }
+ if (write ) {
+ dbGetQuery(con,sprintf("insert into source (name, file, id, status,date,owner )
+ values ('%s', '%s',%i, %i, '%s', '%s')",
+ Fname,content, nextid, 1,date(),.rqda$owner))
+ }
+ }
+}
+
+
+
+FileNamesUpdate <- function(FileNamesWidget=.rqda$.fnames_rqda,...){
+ ##update file names list in the FileNamesWidget
+ wopt <- options(warn=-2)
+ on.exit(options(wopt))
+ fnames <- dbGetQuery(.rqda$qdacon, "select name, id from source where status=1")
+ if (nrow(fnames)!=0) Encoding(fnames[['name']]) <- "UTF-8"
+ tryCatch(FileNamesWidget[] <- fnames[['name']],error=function(e){})
+}
+
+
+
+setEncoding <- function(encoding="unknown"){
+ ## specify what encoding is used in the imported files.
+ .rqda$encoding <- encoding
+}
+
+enc <- function(x) gsub("'", "''", x)
+## replace " with two '. to make insert smoothly.
Added: pkg/R/GUIHandler.R
===================================================================
--- pkg/R/GUIHandler.R (rev 0)
+++ pkg/R/GUIHandler.R 2008-11-20 06:53:23 UTC (rev 16)
@@ -0,0 +1,112 @@
+Handler <- function(){
+### add handler function for GUIs
+
+ ## handler for Root
+ addHandlerUnrealize(.rqda$.root_rqdagui, handler = function(h,...) {
+ ## make sure is the project should be closed by issuing a confirm window.
+ val <- gconfirm("Really EXIST?\n\nYou can use RQDA() to start this program again.", parent=h$obj)
+ if(as.logical(val))
+ return(FALSE) # destroy
+ else
+ return(TRUE) # don't destroy
+ }
+ )
+
+ ## handler for .fnames_rqda (gtable holding the file names)
+
+ addHandlerClicked(.rqda$.fnames_rqda, handler <- function(h, ...) {
+ ## updating the file name list, and update the status of curent selected file.
+ if (is_projOpen(env = .rqda, conName = "qdacon", message = FALSE)) {
+ FileNamesUpdate(FileNamesWidget=.rqda$.fnames_rqda)
+ }
+ }
+ )
+
+ addHandlerMouseMotion(.rqda$.fnames_rqda, handler <- function(h,...) {
+ if (is_projOpen(env = .rqda, conName = "qdacon", message = FALSE)) {
+ FileNamesUpdate(FileNamesWidget=.rqda$.fnames_rqda)
+ }
+ }
+ )
+
+
+ ## handler for .codes_rqda
+
+ addHandlerMouseMotion(.rqda$.codes_rqda, handler <- function(h, ...) {
+ if (is_projOpen(env = .rqda, conName ="qdacon",message = FALSE)) {
+ CodeNamesUpdate(CodeNamesWidget=.rqda$.codes_rqda)
+ }
+ }
+ )
+
+
+
+ addHandlerClicked(.rqda$.codes_rqda,handler <- function(h,...){
+ CodeNamesUpdate(CodeNamesWidget=.rqda$.codes_rqda)
+ con <- .rqda$qdacon
+ SelectedCode <- currentCode <- svalue(.rqda$.codes_rqda)
+ if (length(SelectedCode)!=0) {
+ Encoding(SelectedCode) <- Encoding(currentCode) <- "UTF-8"
+ currentCid <- dbGetQuery(con,sprintf("select id from freecode where name=='%s'",SelectedCode))[,1]
+ SelectedFile <- tryCatch(svalue(.rqda$.root_edit) ## use root_edit is more reliable
+ ,error=function(e){})
+ if (!is.null(SelectedFile)) {
+ Encoding(SelectedFile) <- "UTF-8"
+ currentFid <- dbGetQuery(con,sprintf("select id from source where name=='%s'",SelectedFile))[,1]
+ ## following code: Only mark the text chuck according to the current code.
+ tryCatch({
+ widget <- get(h$action$marktxtwidget,.rqda)
+ ## if widget is not open, then error;which means no need to highlight anything.
+ sel_index <- dbGetQuery(con,sprintf("select selfirst, selend from coding where
+ cid==%i and fid==%i and status==1",currentCid, currentFid))
+ Maxindex <- dbGetQuery(con, sprintf("select max(selend) from coding where fid==%i", currentFid))[1,1]
+ ClearMark(widget,min=0,max=Maxindex)
+ if (nrow(sel_index)>0){
+ HL(widget,index=sel_index)}
+ },error=function(e){}) # end of mark text chuck
+ }
+ }
+ },action=list(marktxtwidget=".openfile_gui")
+ )
+
+
+ addHandlerMouseMotion(.rqda$.CasesNamesWidget, handler <- function(h, ...) {
+ if (is_projOpen(env = .rqda, conName ="qdacon",message = FALSE)) {
+ CaseNamesUpdate(.rqda$.CasesNamesWidget)
+ }
+ }
+ )
+
+
+
+ addHandlerClicked(.rqda$.CasesNamesWidget,handler <- function(h,...){
+ CaseNamesUpdate(.rqda$.CasesNamesWidget)
+ con <- .rqda$qdacon
+ SelectedCase <- currentCase <- svalue(.rqda$.CasesNamesWidget)
+ if (length(SelectedCase)!=0) {
+ Encoding(SelectedCase) <- Encoding(currentCase) <- "UTF-8"
+ currentCid <- dbGetQuery(con,sprintf("select id from cases where name=='%s'",SelectedCase))[,1]
+ SelectedFile <- tryCatch(svalue(.rqda$.root_edit) ## use root_edit is more reliable
+ ,error=function(e){})
+ if (!is.null(SelectedFile)) {
+ Encoding(SelectedFile) <- "UTF-8"
+ currentFid <- dbGetQuery(con,sprintf("select id from source where name=='%s'",SelectedFile))[,1]
+ ## following code: Only mark the text chuck according to the current code.
+ tryCatch({
+ widget <- get(h$action$marktxtwidget,.rqda)
+ ## if widget is not open, then error;which means no need to highlight anything.
+ sel_index <- dbGetQuery(con,sprintf("select selfirst, selend from caselinkage where
+ caseid==%i and fid==%i and status==1",currentCid, currentFid))
+ Maxindex <- dbGetQuery(con, sprintf("select max(selend) from caselinkage where fid==%i", currentFid))[1,1]
+ ClearMark(widget,min=0,max=Maxindex)
+ if (nrow(sel_index)>0){
+ HL(widget,index=sel_index)}
+ },error=function(e){}) # end of mark text chuck
+ }
+ }
+ },action=list(marktxtwidget=".openfile_gui")
+ )
+
+
+}
+
Added: pkg/R/ProjectButton.R
===================================================================
--- pkg/R/ProjectButton.R (rev 0)
+++ pkg/R/ProjectButton.R 2008-11-20 06:53:23 UTC (rev 16)
@@ -0,0 +1,46 @@
+Proj_MemoButton <- function(label="Porject Memo",container=.proj_gui,...){
+#### Each button a separate function -> more easy to debug, and the main function root_gui is shorter.
+### The memo in dataset is UTF-8
+ ## label of button
+ ## name of contaianer or TRUE
+ proj_memo <- gbutton(label, contain=container, handler=function(h,...) {
+ if (is_projOpen(env=.rqda,"qdacon")) {
+ ## use enviroment, so you can refer to the same object easily, this is the beauty of environment
+ ## if project is open, then continue
+ tryCatch(dispose(.rqda$.projmemo),error=function(e) {})
+ ## Close the open project memo first, then open a new one
+ ## .projmemo is the container of .projmemocontent,widget for the content of memo
+ assign(".projmemo",gwindow(title="Project Memo", parent=c(370,10),width=600,height=400),env=.rqda)
+ .projmemo <- get(".projmemo",.rqda)
+ .projmemo2 <- gpanedgroup(horizontal = FALSE, con=.projmemo)
+ ## use .projmemo2, so can add a save button to it.
+ gbutton("Save memo",con=.projmemo2,handler=function(h,...){
+ ## send the new content of memo back to database
+ newcontent <- svalue(W)
+ Encoding(newcontent) <- "UTF-8"
+ newcontent <- enc(newcontent) ## take care of double quote.
+ dbGetQuery(.rqda$qdacon,sprintf("update project set memo='%s' where rowid==1", ## only one row is needed
+ newcontent)
+ ## have to quote the character in the sql expression
+ )
+ }
+ )## end of save memo button
+ assign(".projmemocontent",gtext(container=.projmemo2,font.attr=c(sizes="large")),env=.rqda)
+ prvcontent <- dbGetQuery(.rqda$qdacon, "select memo from project")[1,1]
+ ## [1,1]turn data.frame to 1-length character. Existing content of memo
+ if (length(prvcontent)==0) {
+ dbGetQuery(.rqda$qdacon,"replace into project (memo) values('')")
+ prvcontent <- ""
+ ## if there is no record in project table, it fails to save memo, so insert sth into it
+ }
+ W <- .rqda$.projmemocontent
+ Encoding(prvcontent) <- "UTF-8"
+ add(W,prvcontent,font.attr=c(sizes="large"),do.newline=FALSE)
+ ## do.newline:do not add a \n (new line) at the beginning
+ ## push the previous content to the widget.
+ }
+ }
+ )
+}
+
+
Added: pkg/R/ProjectFun.R
===================================================================
--- pkg/R/ProjectFun.R (rev 0)
+++ pkg/R/ProjectFun.R 2008-11-20 06:53:23 UTC (rev 16)
@@ -0,0 +1,101 @@
+new_proj <- function(path, conName="qdacon",assignenv=.rqda,...){
+ sucess <- file.create(tmpNamme <- tempfile(pattern = "file", tmpdir = dirname(path)))
+ if (!sucess) {
+ gmessage("No write permission.",icon="error",container=TRUE)
+ }
+ else{
+ unlink(tmpNamme)
+ path <- paste(gsub("\\.rqda$","",path),"rqda",sep=".") ## deal with the ".rqda"
+ override <- FALSE
+ if (fexist <- file.exists(path)) override <- gconfirm("Over write existing project?",icon="warning")
+ if (!fexist | override ){
+ ## close con in assignmenv first.
+ tryCatch(close_proj(conName=conName,assignenv=assignenv),error=function(e){})
+ assign(conName,dbConnect(drv=dbDriver("SQLite"),dbname=path),envir=assignenv)
+ con <- get(conName,assignenv)
+
+ if (dbExistsTable(con,"source")) dbRemoveTable(con, "source")
+ ## interview record
+ dbGetQuery(con,"create table source (name text, id integer,
+ file text, memo text,
+ owner text, date text, dateM text, status integer)")
+ ## dateM means modified date
+ if (dbExistsTable(con,"freecode")) dbRemoveTable(con, "freecode")
+ ## list of free codes
+ dbGetQuery(con,"create table freecode (name text, memo text,
+ owner text,date text,dateM text,
+ id integer, status integer)")
+ if (dbExistsTable(con,"treecode")) dbRemoveTable(con, "treecode")
+ ## tree-like strcuture of code (relationship between code and code-category[codecat])
+ dbGetQuery(con,"create table treecode (cid integer, catid integer
+ owner text, date text, dateM text,
+ memo text, status integer)")
+ if (dbExistsTable(con,"treefile")) dbRemoveTable(con, "treefile")
+ ## tree-like structure of interview record (relationship between file and file category [filecat])
+ dbGetQuery(con,"create table treefile (fid integer, catid integer
+ owner text, date text,dateM text,
+ memo text, status integer)")
+ if (dbExistsTable(con,"filecat")) dbRemoveTable(con, "filecat")
+ ## file category
+ dbGetQuery(con,"create table filecat (name text,fid integer, catid integer, owner text,
+ date text, dateM text,memo text, status integer)")
+ if (dbExistsTable(con,"codecat")) dbRemoveTable(con, "codecat")
+ ## code category
+ dbGetQuery(con,"create table codecat (name text, cid integer, catid integer, owner text, date text,
+ dateM text,memo text, status integer)")
+ if (dbExistsTable(con,"coding")) dbRemoveTable(con, "coding")
+ ## coding: code and its coded text chunks
+ dbGetQuery(con,"create table coding (cid integer, fid integer,seltext text,
+ selfirst real, selend real, status integer,
+ owner text, date text, memo text)")
+ if (dbExistsTable(con,"project")) dbRemoveTable(con, "project")
+ ## coding: information about the project
+ dbGetQuery(con,"create table project (encoding text, date text, memo text)")
+ if (dbExistsTable(con,"cases")) dbRemoveTable(con, "cases")
+ dbGetQuery(con,"create table cases (name text, memo text,
+ owner text,date text,dateM text,
+ id integer, status integer)")
+ if (dbExistsTable(con,"caselinkage")) dbRemoveTable(con, "caselinkage")
+ dbGetQuery(con,"create table caselinkage (caseid integer, fid integer,
+ selfirst real, selend real, status integer,
+ owner text, date text, memo text)")
+ }
+ }
+}
+
+
+
+open_proj <- function(path,conName="qdacon",assignenv=.rqda,...){
+ tryCatch({ con <- get(conName,assignenv)
+ if (isIdCurrent(con)) dbDisconnect(con)
+ },
+ error=function(e){})
+ ## Fist close the con if it exist, then open a new con.
+ assign(conName, dbConnect(drv=dbDriver("SQLite"),dbname=path),envi=assignenv)
+}
+
+
+
+close_proj <- function(conName="qdacon",assignenv=.rqda,...){
+ tryCatch({
+ con <- get(conName,assignenv)
+ if (isIdCurrent(con)) {
+ if (!dbDisconnect(con)) {
+ gmessage("Closing project failed.",icon="waring",con=TRUE)
+ }
+ }
+ } ,error=function(e){})
+}
+
+
+
+is_projOpen <- function(env=.rqda,conName="qdacon",message=TRUE){
+ ## test if any project is open.
+ open <- FALSE
+ tryCatch({
+ con <- get(conName,env)
+ open <- open + isIdCurrent(con)
+ } ,error=function(e){})
+ if (!open & message) gmessage("No Project is Open.",icon="warning",con=TRUE)
+ return(open)
+}
Added: pkg/R/Rename.R
===================================================================
--- pkg/R/Rename.R (rev 0)
+++ pkg/R/Rename.R 2008-11-20 06:53:23 UTC (rev 16)
@@ -0,0 +1,14 @@
+rename <- function(from,to,table=c("source","freecode","cases")){
+ ## rename name field in table source and freecode (other tables can be added futher)
+ ## source is the file name, freecode is the free code name
+ ## should check it there is any dupliation in the table????????????????????????????????
+ table <- match.arg(table)
+ if (to!=""){## if to is "", makes no sense to rename
+ dbGetQuery(.rqda$qdacon, sprintf("update %s set name = %s where name == %s ",
+ table,
+ paste("'",to,"'",collapse="",sep=""),
+ paste("'",from,"'",collapse="",sep="")
+ )
+ )
+ }
+}
Deleted: pkg/R/codes.R
===================================================================
--- pkg/R/codes.R 2008-11-04 12:48:34 UTC (rev 15)
+++ pkg/R/codes.R 2008-11-20 06:53:23 UTC (rev 16)
@@ -1,115 +0,0 @@
-addcode <- function(name,conName="qdacon",assignenv=.rqda,assigname="codes_index",...) {
- if (name != ""){
- con <- get(conName,assignenv)
- maxid <- dbGetQuery(con,"select max(id) from freecode")[[1]]
- nextid <- ifelse(is.na(maxid),0+1, maxid+1)
- write <- FALSE
- if (nextid==1){
- write <- TRUE
- } else {
- allnames <- RSQLite:::sqliteQuickColumn(con,"freecode","name")
- if (!any(name==allnames)) {
- write <- TRUE
- }
- }
- if (write ) {
- dbGetQuery(con,sprintf("insert into freecode (name, id, status) values ('%s', %i, %i)",name,nextid, 1))
- }
- assign(assigname, dbGetQuery(con,"select name,id from freecode"),env=assignenv)
- }
-}
-
-
-
-codesupdate <- function(conName="qdacon",assignenv=.rqda,
- assignfileName="codes_index",
- widget,...){
- ## the widget should be get(".codes_rqda",env=.rqda)
- con <- get(conName,assignenv)
- codesName <- dbGetQuery(con, "select name, id from freecode where status=1")
- assign(assignfileName, codesName ,env=assignenv)
- tryCatch(widget[] <- codesName[['name']],error=function(e){})
-}
-
-
-
-mark <- function(widget){
- index <- sindex(widget)
- startI <- index$startI ## start and end iter
- endI <- index$endI
- selected <- index$seltext
- startN <- index$startN # translate iter pointer to number
- endN <- index$endN
- if (startN != endN){
- buffer <- slot(widget,"widget")@widget$GetBuffer()
- buffer$createTag("red.foreground",foreground = "red");
- buffer$ApplyTagByName("red.foreground",startI,endI); ## change colors
- }
- ## only when selected text chunk is not "", apply the color scheme.
- return(list(start=startN,end=endN,text=selected))
-}
-
-
-
-ClearMark <- function(widget,min=0, max){
- ## max position of marked text.
- tryCatch({
- buffer <- slot(widget,"widget")@widget$GetBuffer()
- startI <-gtkTextBufferGetIterAtOffset(buffer,min)$iter # translate number back to iter
- endI <-gtkTextBufferGetIterAtOffset(buffer,max)$iter
- gtkTextBufferRemoveTagByName(buffer,"red.foreground",startI,endI)},
- error=function(e){})
-}
-
-
-HL <- function(W,index){
- ## W is the gtext widget of the text.
- ## highlight text chuck according to index
- ## index is a data frame, each row == one text chuck.
- tryCatch(
- apply(index,1, function(x){
- buffer <- slot(W,"widget")@widget$GetBuffer()
- start <-gtkTextBufferGetIterAtOffset(buffer,x[1])$iter # translate number back to iter
- end <-gtkTextBufferGetIterAtOffset(buffer,x[2])$iter
- buffer$createTag("red.foreground",foreground = "red")
- buffer$ApplyTagByName("red.foreground",start,end)}),
- error=function(e){})
-}
-
-
-
-sindex <- function(widget){
- buffer <- slot(widget,"widget")@widget$GetBuffer()
- bounds = buffer$GetSelectionBounds()
- startI = bounds$start ## start and end iter
- endI = bounds$end
- selected <- buffer$GetText(startI,endI)
- startN <- gtkTextIterGetOffset(startI) # translate iter pointer to number
- endN <- gtkTextIterGetOffset(endI)
- return(list(startI=startI,endI=endI,
- startN=startN,endN=endN,seltext=selected))
-}
-
-
-
-retrieval <- function(currentCid,conName,env,currentCode="currentCode",assignenv=.rqda){
- currentCid <- get(currentCid,env)
- currentCode <- get(currentCode,env)
- con <- get(conName,env)
- retrieval <- dbGetQuery(con,sprintf("select cid,fid, seltext from coding where status==1 and cid=%i",currentCid))
- fid <- unique(retrieval$fid)
- .gw <- gwindow(title=sprintf("Retrieved text: %s",currentCode),parent=c(270,10),width=600,height=600)
- .retreivalgui <- gtext(con=.gw)
- for (i in fid){
- fname <- paste("Source: ", .rqda$files_index$name[.rqda$files_index$id==i], sep="")
- seltext <- retrieval$seltext[retrieval$fid==i]
- ##seltext <- gsub("\n","", seltext,fixed=TRUE)
- seltext <- paste(seltext,collapse="\n\n")
- Encoding(seltext) <- "UTF-8"
- add(.retreivalgui,fname,font.attr=c(style="italic",size="x-large"))
- add(.retreivalgui,"\n",font.attr=c(style="italic"))
- add(.retreivalgui,seltext,font.attr=c(style="normal",size="large"))
- add(.retreivalgui,"\n",font.attr=c(style="italic"))
- }
-}
-
Deleted: pkg/R/files.R
===================================================================
--- pkg/R/files.R 2008-11-04 12:48:34 UTC (rev 15)
+++ pkg/R/files.R 2008-11-20 06:53:23 UTC (rev 16)
@@ -1,63 +0,0 @@
-importfile <- function(path,encoding=.rqda$encoding,con="qdacon",assignenv=NULL,assigname="files_index", ...){
- ## import a file into a DBI connection _con_.
- # readTXT <- function(path){
- # ## read txt file into a one-length character vector.
- # if (.Platform$OS.type=="windows"){
- # readChar(path,file.info(path)[,'size']+1000,TRUE)
- # } else readChar(path,file.info(path)[,'size']+1000)
- # }
- #
- Fname <- gsub("\\.[[:alpha:]]*$","",basename(path))
- ## remove the suffix such as .txt
- if ( Fname!="" ) {
- content <- readLines(path,warn=FALSE,encoding=encoding)
- content <- paste(content,collapse="\n")
- content <- enc(content)
- maxid <- dbGetQuery(con,"select max(id) from source")[[1]]
- nextid <- ifelse(is.na(maxid),0+1, maxid+1)
- write <- FALSE
- ## check if the content should be written into con.
- if (nextid==1) {
- write <- TRUE
- ## if this is the first file, no need to worry about the duplication issue.
- } else {
- allFnames <- RSQLite:::sqliteQuickColumn(con,"source","name")
- if (!any(Fname==allFnames)) {
- ## no duplication file exists, then write.
- write <- TRUE
- } else {
- gmessage("A file withe the same name exists in the database!")
- }
- }
- if (write ) {
- dbGetQuery(con,sprintf("insert into source (name, file, id, status ) values ('%s', '%s',%i, %i)",
- Fname,content, nextid, 1))
- }
- if (!is.null(assignenv)) {
- assign(assigname, dbGetQuery(con,"select name,id from source"), env=assignenv)
- }
- }
-}
-
-
-
-fnamesupdate <- function(conName="qdacon",assignenv=.rqda,assignfileName="files_index",widget=".fnames_rqda",...){
- ##update file names list.
- ## should have widget argument, or the ".fnames_rqda" cannot be found.
- wopt <- options(warn=-2)
- on.exit(options(wopt))
- con <- get(conName,assignenv)
- fnames <- dbGetQuery(con, "select name, id from source where status=1")
- assign(assignfileName, fnames ,env=assignenv)
- tryCatch(widget[] <- fnames[['name']],error=function(e){})
-}
-
-
-
-setEncoding <- function(encoding="unknown"){
- ## specify what encoding is used in the imported files.
- .rqda$encoding <- encoding
-}
-
-enc <- function(x) gsub("'", "''", x)
-## replace " with two '. to make insert smoothly.
Deleted: pkg/R/project.R
===================================================================
--- pkg/R/project.R 2008-11-04 12:48:34 UTC (rev 15)
+++ pkg/R/project.R 2008-11-20 06:53:23 UTC (rev 16)
@@ -1,88 +0,0 @@
-new_proj <- function(path, conName="qdacon",assignenv=.rqda,...){
- sucess <- file.create(tmpNamme <- tempfile(pattern = "file", tmpdir = dirname(path)))
- if (!sucess) {
- gmessage("No write permission.",icon="error",container=TRUE)
- }
- else{
- unlink(tmpNamme)
- path <- paste(gsub("\\.rqda$","",path),"rqda",sep=".") ## deal with the ".rqda"
- override <- FALSE
- if (fexist <- file.exists(path)) override <- gconfirm("Over write existing project?",icon="warning")
- if (!fexist | override ){
- ## close con in assignmenv first.
- tryCatch(close_proj(conName=conName,assignenv=assignenv),error=function(e){})
- assign(conName,dbConnect(drv=dbDriver("SQLite"),dbname=path),envir=assignenv)
- con <- get(conName,assignenv)
- if (dbExistsTable(con,"source")) dbRemoveTable(con, "source")
- ## interview record
- dbGetQuery(con,"create table source (name text, id integer,
- file text, memo text,
- owner text, date text, status integer)")
- if (dbExistsTable(con,"freecode")) dbRemoveTable(con, "freecode")
- ## list of codes
- dbGetQuery(con,"create table freecode (name text, memo text,
- owner text,date text,
- id integer, status integer)")
- if (dbExistsTable(con,"treecode")) dbRemoveTable(con, "treecode")
- ## tree-like strcuture of code (relationship between code and code-category[codecat])
- dbGetQuery(con,"create table treecode (cid integer, catid integer
- owner text, date text,
- memo text, status integer)")
- if (dbExistsTable(con,"treefile")) dbRemoveTable(con, "treefile")
- ## tree-like structure of interview record (relationship between file and file category [filecat])
- dbGetQuery(con,"create table treefile (fid integer, catid integer
- owner text, date text,
- memo text, status integer)")
- if (dbExistsTable(con,"filecat")) dbRemoveTable(con, "filecat")
- ## file category
- dbGetQuery(con,"create table filecat (fid integer, catid integer, owner text,
- date text, memo text, status integer)")
- if (dbExistsTable(con,"codecat")) dbRemoveTable(con, "codecat")
- ## code category
- dbGetQuery(con,"create table codecat (cid integer, catid integer, owner text, date text,
- memo text, status integer)")
- if (dbExistsTable(con,"coding")) dbRemoveTable(con, "coding")
- ## coding: code and its coded text chunks
- dbGetQuery(con,"create table coding (cid integer, fid integer,seltext text,
- selfirst real, selend real, status integer,
- owner text, date text, memo text)")
- }
- }
-}
-
-
-
-open_proj <- function(path,conName="qdacon",assignenv=.rqda,...){
- tryCatch({ con <- get(conName,assignenv)
- if (isIdCurrent(con)) dbDisconnect(con)
- },
- error=function(e){})
- ## Fist close the con if it exist, then open a new con.
- assign(conName, dbConnect(drv=dbDriver("SQLite"),dbname=path),envi=assignenv)
-}
-
-
-
-close_proj <- function(conName="qdacon",assignenv=.rqda,...){
- tryCatch({
- con <- get(conName,assignenv)
- if (isIdCurrent(con)) {
- if (!dbDisconnect(con)) {
- gmessage("Closing project failed.",icon="waring",con=TRUE)
- }
- }
- } ,error=function(e){})
-}
-
-
-
-is_projOpen <- function(env=.rqda,conName="qdacon",message=TRUE){
- ## test if any project is open.
- open <- FALSE
- tryCatch({
- con <- get(conName,env)
- open <- open + isIdCurrent(con)
- } ,error=function(e){})
- if (!open & message) gmessage("No Project is Open.",icon="warning",con=TRUE)
- return(open)
-}
Modified: pkg/R/root_gui.R
===================================================================
--- pkg/R/root_gui.R 2008-11-04 12:48:34 UTC (rev 15)
+++ pkg/R/root_gui.R 2008-11-20 06:53:23 UTC (rev 16)
@@ -10,64 +10,58 @@
########################### GUI FOR ROOT
###########################
".root_rqdagui" <- gwindow(title = "RQDA: Qualitative Data Analysis.",parent=c(10,10),
- width=250,height=600,visible=FALSE,handler=function(h,...){
+ width=300,height=600,visible=FALSE,handler=function(h,...){
tryCatch(dispose(.rqda$.root_edit),error=function(e){})
- close_proj(assignenv=h$action$env)
- },
- action=list(env=.rqda)
+ close_proj(assignenv=.rqda)
+ }
)
- addHandlerUnrealize(.root_rqdagui, handler = function(h,...) {
- ## make sure is the project should be closed by issuing a confirm window.
- val <- gconfirm("Really EXIST?\n\nYou can use RQDA() to start this program again.", parent=h$obj)
- if(as.logical(val))
- return(FALSE) # destroy
- else
- return(TRUE) # don't destroy
- }
- )
-
+ ".nb_rqdagui" <- gnotebook(4,container=.root_rqdagui,closebuttons=FALSE)
- ".nb_rqdagui" <- gnotebook(3,container=.root_rqdagui,closebuttons=FALSE)
-
########################### GUI FOR PROJECT
###########################
".proj_gui" <- ggroup(container=.nb_rqdagui,horizontal=FALSE,label="Project")
+
".newproj_gui" <- gbutton("New Project",container=.proj_gui,handler=function(h,...){
path=gfile(type="save")
if (path!=""){
## if path="", then click "cancel".
Encoding(path) <- "UTF-8"
- new_proj(path,assignenv=h$action$env)}
- },
- action=list(env=.rqda)
+ new_proj(path,assignenv=.rqda)}
+ }
)
".open.proj_gui" <- gbutton("Open Project",container=.proj_gui,handler=function(h,...){
- path <- gfile(type="open",filter=list("rqda"=list(patterns = c("*.rqda"))))
+ path <- gfile(type="open",filter=list("rqda"=list(patterns = c("*.rqda","*.*"))))
if (path!=""){
Encoding(path) <- "UTF-8"
- open_proj(path,assignenv=h$action$env)
+ open_proj(path,assignenv=.rqda)
+ tryCatch(CodeNamesUpdate(),error=function(e){})
+ tryCatch(FileNamesUpdate(),error=function(e){})
+ tryCatch(CaseNamesUpdate(),error=function(e){})
}
- },
- action=list(env=.rqda)
+ }
)
+ ".project_memo" <- Proj_MemoButton(label = "Porject Memo", container = .proj_gui)
+ ## project memo button
".close.proj_gui" <- gbutton("Close Project",container=.proj_gui,handler=function(h,...){
- status <- close_proj(assignenv=h$action$env)
- },
- action=list(env=.rqda)
+ close_proj(assignenv=.rqda)
+ tryCatch(.rqda$.codes_rqda[]<-NULL,error=function(e){})
+ tryCatch(.rqda$.fnames_rqda[]<-NULL,error=function(e){})
+ tryCatch(.rqda$.CasesNamesWidget[]<-NULL,error=function(e){})
+ }
)
".projinfo_gui" <- gbutton("Current Project",container=.proj_gui,handler=function(h,...){
- if (is_projOpen(env=h$action$env,conName=h$action$conName)) {
- con <- get(h$action$conName,h$action$env)
+ if (is_projOpen(env=.rqda,conName="qdacon")) {
+ con <- .rqda$qdacon
dbname <- dbGetInfo(.rqda$qdacon)$dbname
##substr(dbname, nchar(dbname)-15,nchar(dbname))
gmessage(dbname,title="Info about current project.",con=TRUE)
@@ -79,8 +73,8 @@
glabel("Basic Usage of RQDA:\n
1. New Project or Open project.\n
-2. Update file list or Import files.\n
-3. Update code list or Add codes.\n
+2. Import files.\n
+3. Add codes.\n
4. Open a file and begin coding.\n
Author: <ronggui.huang at gmail.com>\n
This software is part of my PhD research.\n",
@@ -92,463 +86,75 @@
###########################
".files_pan" <- gpanedgroup(container=.nb_rqdagui,horizontal=FALSE,label="Files")
".files_button" <- ggroup(container=.files_pan,horizontal=TRUE)
-
-
- .importfilebutton <-gbutton("Import",container=.files_button,handler=function(h,...){
- if (is_projOpen(env=h$action$env,conName=h$action$conName)) {
- path <- gfile(type="open",filter=list("text files" = list(mime.types = c("text/plain"))))
- if (path!=""){
- Encoding(path) <- "UTF-8"
- importfile(path,encoding=get("encoding",envir=h$action$env),con=h$action$env$qdacon,assignenv=h$action$env)
- ## updatefilelist()
- }
- }
- },
- action=list(env=.rqda,conName="qdacon"))
-
-
-
- gbutton(" View ",contain=.files_button,handler=function(h,...){
- if (is_projOpen(env=h$action$env,conName=h$action$conName)) {
- if (length(svalue(.fnames_rqda))==0){gmessage("Select a file first.",icon="error",con=TRUE)}
- else {
- tryCatch(dispose(h$action$env$.root_edit),error=function(e) {})
- ## notice the error handler
- assign(".root_edit",gwindow(title=svalue(.fnames_rqda), parent=c(270,10),width=600,height=600),env=h$action$env)
- .root_edit <- get(".root_edit",h$action$env)
- assign(".openfile_gui",gtext(container=.root_edit,font.attr=c(sizes="large")),env=h$action$env)
- con <- get(h$action$conName,h$action$env)
- content <- dbGetQuery(con, sprintf("select file from source where name='%s'",svalue(.fnames_rqda)))[1,1]
- ## turn data.frame to 1-length character.
- W <- get(".openfile_gui",h$action$env)
- add(W,content,font.attr=c(sizes="large"))
- slot(W,"widget")@widget$SetEditable(FALSE)
- ## make sure it is read only file in the text window.
- codings_index <- dbGetQuery(con,"select rowid, cid, fid, selfirst, selend, status from coding where status=1")
- assign("codings_index", codings_index, h$action$env)
- }
- }
- },
- action=list(env=.rqda,conName="qdacon")
- )
-
-
- gbutton(" Delete ",contain=.files_button,handler=function(h,...)
- {
- if (is_projOpen(env=h$action$env,conName=h$action$conName) & length(svalue(.fnames_rqda))!=0) {
- ## if the project open and a file is selected, then continue the action
- del <- gconfirm("Really delete the file?",icon="question")
- if (isTRUE(del)) {
- con <- get(h$action$conName,h$action$env)
- dbGetQuery(con, sprintf("update source set status=0 where id=%s",h$action$env$currentFid))
- ## set the status of the selected file to 0
- assign("currentFid",integer(0),envir=h$action$env)
- assign("currentFile",character(0),envir=h$action$env)
- ## set "currentFid" and "currentFile" in .rqda to integer(0) and character(0)
- fnamesupdate(assignenv=h$action$env)
- ## reset files_index in .rqda by updatefilelist()
- }
- }
- },
- action=list(env=.rqda,conName="qdacon")
- )
-
-
- gbutton(" Memo ", contain=.files_button, handler=function(h,...) {
- if (is_projOpen(env=h$action$env,"qdacon")) {
- ## if project is open, then continue
- selectedFN <- svalue(.fnames_rqda)
- if (length(selectedFN)==0){
- ## if no file is selected, then no need to memo.
- ## svalue(.fnames_rqda) is the name of selected file.
- gmessage("Select a file first.",icon="error",con=TRUE)
- }
- else {
- tryCatch(dispose(h$action$env$.filememo),error=function(e) {})
- ## Close the open file memo first, then open a new one
- ## .filememo is the container of .fmemocontent,widget for the content of memo
- assign(".filememo",gwindow(title=paste("File Memo",selectedFN,sep=":"), parent=c(270,10),width=400,height=400),env=h$action$env)
- .filememo <- get(".filememo",h$action$env)
- .filememo2 <- gpanedgroup(horizontal = FALSE, con=.filememo)
- ## use .filememo2, so can add a save button to it.
- gbutton("Save memo",con=.filememo2,handler=function(h,...){
- ## send the new content of memo back to database
- newcontent <- svalue(W); newcontent <- iconv(newcontent, from="UTF-8")
- newcontent <- enc(newcontent) ## take care of double quote.
- dbGetQuery(con,sprintf("update source set memo=%s where name=%s",
- paste("'",newcontent,"'",sep=""),
- paste("'",selectedFN,"'",sep="")
- ## have to quote the character in the sql expression
- )
- )
- }
- )
- assign(".fmemocontent",gtext(container=.filememo2,font.attr=c(sizes="large")),env=h$action$env)
- con <- get("qdacon",h$action$env)
- prvcontent <- dbGetQuery(con, sprintf("select memo from source where name='%s'",svalue(.fnames_rqda)))[1,1]
- ## [1,1]turn data.frame to 1-length character. Existing content of memo
- if (is.na(prvcontent)) prvcontent <- ""
- W <- get(".fmemocontent",h$action$env)
- add(W,prvcontent,font.attr=c(sizes="large"))
- ## push the previous content to the widget.
- }
- }
- },
- action=list(env=.rqda)
- )
-
-
".fnames_rqda" <- gtable("Click Here to see the File list.",container=.files_pan)
.fnames_rqda[] <-NULL # get around of the text argument.
-
-
- addHandlerMouseMotion(.fnames_rqda, handler <- function(h,
- ## updating the file name list.
- ...) {
- if (is_projOpen(env = h$action$env, conName = h$action$conName,
- message = FALSE)) {
- ## cat("Mouse Motion updated.", fill = TRUE)
- fnamesupdate(assignenv = h$action$env, conName = h$action$conName,
- assignfileName = h$action$assignfileName,widget=h$action$widget)
- }
- },
- action = list(env = .rqda, conName = "qdacon", assignfileName = "files_index",widget=.fnames_rqda))
-
-
- addHandlerClicked(.fnames_rqda, handler <- function(h, ...) {
- ## updating the file name list, and update the status of curent selected file.
- if (is_projOpen(env = h$action$env, conName = h$action$conName, message = FALSE)) {
- fnamesupdate(assignenv = h$action$env, conName = h$action$conName,
- assignfileName = h$action$assignfileName,h$action$widget)
- files_index <- get(h$action$assignfileName, h$action$env)
- assign("currentFile", svalue(.fnames_rqda), env = h$action$env)
- currentFile <- get("currentFile", h$action$env)
- currentFid <- files_index[files_index[["name"]] ==
- currentFile, "id", drop = TRUE]
- if (is.null(currentFid))
- currentFid <- integer(0)
- assign("currentFid", currentFid, env = h$action$env)
- }
- },action = list(env = .rqda, conName = "qdacon", assignfileName = "files_index",widget=.fnames_rqda)
- )
+ ImportFileButton("Import",con=.files_button)
+ DeleteFileButton("Delete",con=.files_button)
+ ViewFileButton("Open",con=.files_button)
+ File_MemoButton(label="F-Memo", container=.files_button,FileWidget=.fnames_rqda)
+ ## memo button of selected file. The code of File_Memo buttion has been moved into memo.R
+ File_RenameButton(label="Rename", container=.files_button,FileWidget=.fnames_rqda)
+ ## rename a selected file.
-
-
+
########################### GUI for CODES
###########################
".codes_pan" <- gpanedgroup(container=.nb_rqdagui,horizontal=FALSE,label="Codes")
".codes_button" <- glayout(container=.codes_pan)
-
+ ".codes_rqda" <- gtable("Please click Update",container=.codes_pan)
+ .codes_rqda[] <- NULL
+ .codes_button[1,1]<- AddCodeButton()
+ .codes_button[1,2]<- DeleteCodeButton()
+ .codes_button[1,3] <- FreeCode_RenameButton(label="Rename",CodeNamesWidget=.codes_rqda)
+ .codes_button[1,4] <- CodeMemoButton(label="C-Memo")
+ .codes_button[1,5]<- CodingMemoButton(label="C2Memo")
+ .codes_button[2,1]<- HL_ALLButton()
+ .codes_button[2,2]<- RetrievalButton("Retrieval")
+ .codes_button[2,3]<- RetrievalButton(label="Extend")
+ .codes_button[2,4]<- Unmark_Button()
+ .codes_button[2,5]<- Mark_Button()
- .codes_button[1,1]<- gbutton(" ADD ",
- handler=function(h,...) {
- if (is_projOpen(env=h$action$env,conName=h$action$conName)) {
- codename <- ginput("Enter new code. ", icon="info")
- codename <- iconv(codename,from="UTF-8")
- addcode(codename,conName=h$action$conName,assignenv=h$action$env,
- assigname=h$action$assignname)
- codesupdate(conName = h$action$conName, assignenv = h$action$env,
- assignfileName =h$action$assignfileName,
- widget=get(h$action$widget)
- )
- }
- },
- action=list(env=.rqda,name="codename",conName="qdacon",assignname="codes_index",
- assignfileName="codes_index",widget=".codes_rqda")
- ##widget should be character, and in the codesupdate() call, use get() to access the widget.
- )
-
- .codes_button[1,2]<- gbutton(" Delete ",
- handler=function(h,...)
- {
- if (is_projOpen(env=h$action$env,conName=h$action$conName) &
- length(svalue(.codes_rqda))!=0) {
- ## if project is open and one code is selected,then continue
- del <- gconfirm("Really delete the code?",icon="question")
- if (isTRUE(del)){
- dbGetQuery(get(h$action$conName,h$action$env),
- sprintf("update freecode set status=0 where id=%s",
- h$action$env$currentCid)
- )
- ## set status in table freecode to 0
- dbGetQuery(get(h$action$conName,h$action$env),
- sprintf("update coding set status=0 where cid=%s",
- h$action$env$currentCid)
- )
- ## set status in table coding to 0, so when press "HL ALL",
- ## the text chunk associated with deleted code will be ignored.
- assign("currentCid",integer(0),envir=h$action$env)
- assign("currentCode",character(0),envir=h$action$env)
- ## set "currentCid" and "currentCode" to integer(0) and character(0)
- codesupdate(assignenv=h$action$env)
- ## update "codes_index" in .rqda by codesupdate
- }
- }
- },action=list(env=.rqda,conName="qdacon")
- )
+
+######################### GUI for cases
+#########################
+ ".case_pan" <- gpanedgroup(container=.nb_rqdagui,horizontal=FALSE,label="Case")
+ ".case_buttons" <- glayout(container=.case_pan)
+ ".CasesNamesWidget" <- gtable("Please click Update",container=.case_pan)
+ .CasesNamesWidget[] <- NULL
+ .case_buttons[1,1] <- AddCaseButton()
+ .case_buttons[1,2] <- DeleteCaseButton()
+ .case_buttons[1,3] <- Case_RenameButton()
+ .case_buttons[1,4] <- CaseMark_Button()
+ .case_buttons[1,5] <- CaseMemoButton()
-
- .codes_button[1,3] <- gbutton("CodeMemo", handler=function(h,...) {
- ## code memo: such as meaning of code etc.
- if (is_projOpen(env=.rqda,"qdacon")) {
- if (length(.rqda$currentCode)==0){
- gmessage("Select a code first.",icon="error",con=TRUE)
- }
- else {
- tryCatch(dispose(h$action$env$.codememo),error=function(e) {})
- assign(".codememo",gwindow(title=paste("Code Memo",.rqda$currentCode,sep=":"),
- parent=c(270,10),width=400,height=400),env=.rqda)
- .codememo <- get(".codememo",env=h$action$env)
- .codememo2 <- gpanedgroup(horizontal = FALSE, con=.codememo)
- gbutton("Save Code Memo",con=.codememo2,handler=function(h,...){
- newcontent <- svalue(W); newcontent <- iconv(newcontent, from="UTF-8")
- newcontent <- enc(newcontent) ## take care of double quote.
- dbGetQuery(con,sprintf("update freecode set memo=%s where name=%s",
- paste("'",newcontent,"'",sep=""),
- paste("'",.rqda$currentCode,"'",sep="")
- )
- )
- }
- )
- assign(".cmemocontent",gtext(container=.codememo2,font.attr=c(sizes="large")),env=h$action$env)
- con <- get("qdacon",h$action$env)
- prvcontent <- dbGetQuery(con, sprintf("select memo from freecode where name='%s'",.rqda$currentCode))[1,1]
- if (is.na(prvcontent)) prvcontent <- ""
- W <- get(".cmemocontent",h$action$env)
- add(W,prvcontent,font.attr=c(sizes="large"))
- }
- }
- },
- action=list(env=.rqda)
- )
+######################### GUI for F-cat
+#########################
+ ".fcat_gui" <- ggroup(container=.nb_rqdagui,horizontal=FALSE,label="F-Cat")
-
- .codes_button[1,4]<- gbutton("HL ALL",
- handler=function(h,...) {
- if (is_projOpen(env=h$action$env,conName=h$action$conName)) {
- con <- get(h$action$conName,h$action$env)
- fid <- get(h$action$currentFid,h$action$env)
- W <- tryCatch( get(h$action$widget,h$action$env),
- error=function(e) {}
- )
- if (length(fid)!=0 & !is.null(W)) {
- ## if fid is integer(0), then there is no file selected and open
- ## if W is null, then there is no valid widget. No need to HL.
- ## Though W may be expired, but ClearMark and HL will take care of the issue.
- mark_index <-
- dbGetQuery(con,sprintf("select selfirst,selend,status from coding where fid=%i",fid))
- ## only select thoses with the open_file and not deleted (status=1).
- ClearMark(W ,0 , max(mark_index$selend))
- HL(W,index=mark_index[mark_index$status==1,1:2])
- }
- }
- },
- action=list(env=.rqda,conName="qdacon",widget=".openfile_gui",currentFid="currentFid")
- )
+######################### GUI for C-cat
+#########################
+ ".codecat_gui" <- ggroup(container=.nb_rqdagui,horizontal=FALSE,label="C-Cat")
-
- .codes_button[2,1]<- gbutton("Mark",
- handler=function(h,...) {
- if (is_projOpen(env=h$action$env,conName=h$action$conName)) {
- tryCatch({
- ans <- mark(get(h$action$widget,env=h$action$env))
- if (ans$start != ans$end){
- ## when selected no text, makes on sense to do anything.
- currentCid <- get("currentCid",h$action$env)
- currentFid <- get("currentFid",h$action$env)
- DAT <- data.frame(cid=currentCid,fid=currentFid,seltext=ans$text,
- selfirst=ans$start,selend=ans$end,status=1,
- owner=.rqda$owner,date=date(),memo="")
- con <- get(h$action$conName,h$action$env)
- success <- dbWriteTable(con,"coding",DAT,row.name=FALSE,append=TRUE)
- if (!success) gmessage("Fail to write to database.")
- ## further testing: update codings_index in .rqda env.
- codings_index <- dbGetQuery(con,"select rowid, cid, fid, selfirst, selend, status from coding where status=1")
- assign("codings_index", codings_index, h$action$env)
- ## end furthing testing
- }
- },error=function(e){}
- )
- }
- },
- action=list(env=.rqda,conName="qdacon",widget=".openfile_gui")
- )
-
-
- .codes_button[2,2]<- gbutton("Unmark",
- handler=function(h,...) {
- if (is_projOpen(env=h$action$env,conName=h$action$conName)) {
- con <- get(h$action$conName,h$action$env)
- W <- tryCatch( get(h$action$widget,env=h$action$env),
- error=function(e){}
- )
- ## get the widget for file display. If it does not exist, then return NULL.
- sel_index <- tryCatch(sindex(W),error=function(e) {})
- ## if the not file is open, unmark doesn't work.
- if (!is.null(sel_index)) {
- codings_index <- get(h$action$codings_index,h$action$env)
- currentCid <- get("currentCid",h$action$env)
- currentFid <- get("currentFid",h$action$env)
- codings_index_current <- codings_index[(codings_index$cid==currentCid & codings_index$fid==currentFid),]
- ## should only work with those related to current code and current file.
- rowid <- codings_index_current$rowid[(codings_index_current$selfirst >= sel_index$startN) & (codings_index_current$selend <= sel_index$endN)]
- if (is.numeric(rowid)) for (j in rowid) {
- dbGetQuery(con,sprintf("update coding set status=0 where rowid=%i", j)) }
- ## better to get around the loop by sqlite condition expression.
- codings_index$status[codings_index$rowid==rowid] <- 0
- assign("codings_index",h$action$env)
- ClearMark(W,min=sel_index$startN,max=sel_index$endN)
- ## This clear all the marks in the gtext window,
- ## even for the non-current code. can improve.
- }
- }
- },
- action=list(env=.rqda,conName="qdacon",widget=".openfile_gui",codings_index="codings_index")
- )
+######################### GUI for settings
+#########################
+ ".settings_gui" <- ggroup(container=.nb_rqdagui,horizontal=FALSE,label="Settings")
- .codes_button[2,3]<- gbutton("CodingMemo", handler= function(h,...){
- if (is_projOpen(env=.rqda,conName="qdacon")) {
- con <- get("qdacon",env=.rqda)
- W <- tryCatch( get(".openfile_gui",env=.rqda), error=function(e){})
- ## get the widget for file display. If it does not exist, then return NULL.
- sel_index <- tryCatch(sindex(W),error=function(e) {}) ## if the not file is open, it doesn't work.
- if (is.null(sel_index)) {gmessage("Open a file first!",con=TRUE)}
- else {
- codings_index <- get("codings_index",env=.rqda)
- currentCid <- get("currentCid",env=.rqda)
- if (length(currentCid)==0) gmessage("Select a code first!") else {
- currentFid <- get("currentFid",env=.rqda)
- codings_index_current <- codings_index[(codings_index$cid==currentCid & codings_index$fid==currentFid),]
- ## should only work with those related to current code and current file.
- rowid <- codings_index_current$rowid[(codings_index_current$selfirst >= sel_index$startN) &
- (codings_index_current$selfirst <= sel_index$startN + 4) &
- (codings_index_current$selend <= sel_index$endN)&
- (codings_index_current$selend >= sel_index$endN - 4)
- ] ## determine which one is the current text chunk?
- if (length(rowid)!= 1) {gmessage("Select the exact coding first!", con=TRUE) } else {
- ## open a widget for memo, and take care of the save memo function
- tryCatch(dispose(h$action$env$.codingmemo),error=function(e) {})
- ## Close the coding memo first, then open a new one
- assign(".codingmemo",gwindow(title=paste("Coding Memo for",.rqda$currentCode,sep=":"),
- parent=c(270,10),width=400,height=400
- ), env=.rqda
- )
- .codingmemo <- get(".codingmemo",env=.rqda)
- .codingmemo2 <- gpanedgroup(horizontal = FALSE, con=.codingmemo)
- gbutton("Save Coding Memo",con=.codingmemo2,handler=function(h,...){
- newcontent <- svalue(W); newcontent <- iconv(newcontent, from="UTF-8")
- newcontent <- enc(newcontent) ## take care of double quote.
- dbGetQuery(con,sprintf("update coding set memo=%s where rowid=%i",
- paste("'",newcontent,"'",sep=""),
- rowid
- )
- )
- }
- )
- assign(".cdmemocontent",gtext(container=.codingmemo2,font.attr=c(sizes="large")),env=.rqda)
- con <- get("qdacon",env=.rqda)
- prvcontent <- dbGetQuery(con, sprintf("select memo from coding where rowid=%i",rowid))[1,1]
- if (is.na(prvcontent)) prvcontent <- ""
- W <- get(".cdmemocontent",env=.rqda)
- add(W,prvcontent,font.attr=c(sizes="large"))
- }
- }
- }
- }
- }
- )
-
- .codes_button[2,4]<- gbutton("Retrieval",
- handler=function(h,...) {
- if (is_projOpen(env=h$action$env,conName=h$action$conName)) {
- retrieval(h$action$cid,h$action$conName,h$action$env,h$action$Code)
- }
- },
- action=list(cid="currentCid",conName="qdacon",env=.rqda,Code="currentCode")
- )
-
-
- ".codes_rqda" <- gtable("Please click Update",container=.codes_pan)
- .codes_rqda[] <- NULL
-
-
- addHandlerClicked(.codes_rqda,handler <- function(h,...){
- ## without it, button mark doesn't work due to lack of currentCid.
- ## BUG: only clear the mark but not highlight the selected text chunk.
- codes_index <- get(h$action$fileName, h$action$env)
- assign("currentCode",svalue(.codes_rqda),env=h$action$env) ## current code
- currentCode <- get("currentCode", h$action$env)
- currentCid <- codes_index[codes_index[["name"]] == currentCode, "id", drop = TRUE]
- if (is.null(currentCid)) currentCid <- integer(0)
- assign("currentCid", currentCid, env = h$action$env)
- ## above code: update the meta data -- CurrentCode and Current code id.
- ## following code: Only mark the text chuck according to the current code.
- currentFid <- get("currentFid", h$action$env)
- tryCatch({
- widget <- get(h$action$marktxtwidget,h$action$env)
- ## if widget is not open, then error;which means no need to highlight anything.
- con <- get(h$action$conName,h$action$env)
- sel_index <- dbGetQuery(con, sprintf("select selfirst, selend, cid, status from coding where fid=%i",currentFid))
- Maxindex <- max(sel_index["selend"],na.rm=TRUE)
- sel_index <- sel_index[(sel_index$cid==currentCid & sel_index$status==1),c("selfirst","selend")]
- ClearMark(widget,min=0,max=Maxindex)
- if (nrow(sel_index)>0){
- HL(widget,index=sel_index)
- }
- },error=function(e){}
- )
- },
- action=list(env=.rqda,fileName="codes_index",conName="qdacon",marktxtwidget=".openfile_gui"
- )
- )
-
-
- addHandlerMouseMotion(.codes_rqda, handler <- function(h,
- ## updating the codes name list.
- ...) {
- if (is_projOpen(env = h$action$env, conName = h$action$conName,message = FALSE)) {
- codesupdate(conName = h$action$conName, assignenv = h$action$env,
- assignfileName = h$action$assignfileName,widget=h$action$widget)
- }
- },
- action = list(env = .rqda, conName = "qdacon", assignfileName = "codes_index",widget=.codes_rqda)
- )
-
-
- addhandlerdoubleclick(.codes_rqda,handler <- function(h,...){
- codes_index <- get(h$action$fileName, h$action$env)
- assign("currentCode",svalue(.codes_rqda),env=h$action$env) ## current code
- currentCode <- get("currentCode", h$action$env)
- currentFid <- get("currentFid", h$action$env)
- currentCid <- codes_index[codes_index[["name"]] == currentCode, "id", drop = TRUE]
- if (is.null(currentCid)) currentCid <- integer(0)
- assign("currentCid", currentCid, env = h$action$env)
- ## above code: update the meta data -- CurrentCode and Current code id.
- ## following code: Only mark the text chuck according to the current code.
- tryCatch({
- widget <- get(h$action$marktxtwidget,h$action$env)
- ## if widget is not open, then error;which means no need to highlight anything.
- con <- get(h$action$conName,h$action$env)
- sel_index <- dbGetQuery(con, sprintf("select selfirst, selend, cid, status from coding where fid=%i",currentFid))
- Maxindex <- max(sel_index["selend"],na.rm=TRUE)
- sel_index <- sel_index[(sel_index$cid==currentCid & sel_index$status==1),c("selfirst","selend")]
- ClearMark(widget,min=0,max=Maxindex)
- if (nrow(sel_index)>0){
- HL(widget,index=sel_index)}
- },error=function(e){})
- },action=list(env=.rqda,fileName="codes_index",conName="qdacon",marktxtwidget=".openfile_gui"
- )
- )
-
-
-
######################### Put them together
#########################
visible(.root_rqdagui) <- TRUE
- svalue(.nb_rqdagui) <- 1
- ## make sure the project tab gain the focus.
- ## make it a function RQDA().
+ svalue(.nb_rqdagui) <- 1 ## make sure the project tab gain the focus.
+
+##########################
+## add documentation here
+assign(".root_rqdagui",.root_rqdagui,env=.rqda)
+assign(".files_button",.files_button,env=.rqda)
+assign(".codes_rqda",.codes_rqda,env=.rqda)
+assign(".fnames_rqda",.fnames_rqda,env=.rqda)
+assign(".CasesNamesWidget",.CasesNamesWidget,env=.rqda)
+
+##########################
+Handler()
}
## end of function RQDA
Modified: pkg/R/sysdata.rda
===================================================================
(Binary files differ)
Modified: pkg/R/zzz.R
===================================================================
--- pkg/R/zzz.R 2008-11-04 12:48:34 UTC (rev 15)
+++ pkg/R/zzz.R 2008-11-20 06:53:23 UTC (rev 16)
@@ -1,5 +1,8 @@
.First.lib <- function(...) {
+ .rqda <- new.env()
.rqda$owner <- "default"
+ .rqda$BOM <- FALSE
+ .rqda$encoding <- "unknown"
cat("\nUse RQDA() to start the programe.\n",fill=TRUE)
- RQDA()
+ ## RQDA()
}
Modified: pkg/TODO
===================================================================
--- pkg/TODO 2008-11-04 12:48:34 UTC (rev 15)
+++ pkg/TODO 2008-11-20 06:53:23 UTC (rev 16)
@@ -1,7 +1,11 @@
-set info about owner and date
+tree-like structure of files/ codes.
+get back to orginal files from coding(extend button)
+
summary functions for review of coding.
+
+### less important
should add document on the table structure.
-tree-like structure of files/ codes.
\ No newline at end of file
+set info about owner and date (basically done)
\ No newline at end of file
Modified: pkg/man/RQDA-internal.rd
===================================================================
--- pkg/man/RQDA-internal.rd 2008-11-04 12:48:34 UTC (rev 15)
+++ pkg/man/RQDA-internal.rd 2008-11-20 06:53:23 UTC (rev 16)
@@ -9,7 +9,15 @@
\alias{is_projOpen}
\alias{mark}
\alias{new_proj}
-\alias{setEncoding} %% to be documented independently.
+\alias{Proj_MemoButton}
+\alias{File_MemoButton}
+\alias{CodeMemoButton}
+\alias{CodingMemoButton}
+\alias{File_RenameButton}
+%% to be documented independently.
+\alias{setEncoding}
+\alias{rename}
+%% to be documented independently.
\alias{open_proj}
\alias{rqdameta}
\alias{retrieval}
More information about the Rqda-commits
mailing list