Search code examples
rgwidgets

Widget for selecting columns of a dataset with mutual exclusion

My R code below generates the interface you see on the screenshot. The user loads a csv file and he selects four columns of the loaded dataset (an example data file is available here but any csv file with at least four columns can be used). I have implemented "mutual exclusion" for the selected columns: for instance, with the example of the screenshot below, if the user selects the "operator" column as Factor A, then Factor B is automatically switched to the "day" column.

As you see, my code is quite heavy. Imagine a more elaborate widget in which the user preliminary sets the number of colums to be selected. Maybe I could implement the same approach as my code below for an abritrary number of columns using a loop and using lists to store the objects. But isn't there some better/easier ways to do that ?

widget

library(gWidgetsRGtk2)
options("guiToolkit"="RGtk2")

# defines a new environment to store data
myenv.data <- new.env()

# function for storing the data file in myenv.data
RR_data <- function(filename){ 
    path <- dirname(filename)
    setwd(path)
    dat0 <- read.csv(filename,header=TRUE)
    assign("dat0", dat0, envir=myenv.data)
}


### MAIN WIDGET ###
win <- gwindow("R&R")
WIDGET <- ggroup(cont=win)
DataGroup <- gframe("DATA", container = WIDGET, horizontal=FALSE)

## WIDGET: LOAD DATA ## 
grp.file <- ggroup(horizontal=FALSE, container = DataGroup)
lbl.file <- glabel("File: ", container = grp.file)
browse.file <- gfilebrowse(text = "", container = grp.file, quote=FALSE)

## WIDGET: SELECT COLUMNS ##
grp.load.data <- gbutton(text="Load data", container = DataGroup, 
    handler = function(h, ...) {
    enabled(grp.load.data) <- FALSE
    RR_data(svalue(browse.file))
    #
    dat0 <- get("dat0", envir=myenv.data)
    SelectGroup <<- gframe("Select columns ", container = DataGroup, horizontal=FALSE)  
    grp.select <<-  ggroup(horizontal=FALSE, container = SelectGroup)  
    dat.columns <- colnames(dat0)  
    lbl.factor.A <<- glabel("Factor A (fixed)", container = grp.select)  
    insert.factor.A <<- gcombobox(dat.columns, container = grp.select)  
    lbl.factor.B <<- glabel("Factor B ", container = grp.select)  
    insert.factor.B <<- gcombobox(dat.columns, selected=2, container = grp.select)  
    lbl.factor.C <<- glabel("Factor C ", container = grp.select)  
    insert.factor.C <<- gcombobox(dat.columns, selected=3, container = grp.select)  
    lbl.response <<- glabel("Response ", container = grp.select)  
    insert.response <<- gcombobox(dat.columns, selected=4, container = grp.select)  
    myenv.ABC <<- new.env()
    assign("Aold", svalue(insert.factor.A), envir=myenv.ABC)
    assign("Bold", svalue(insert.factor.B), envir=myenv.ABC)
    assign("Cold", svalue(insert.factor.C), envir=myenv.ABC)
    assign("Yold", svalue(insert.response), envir=myenv.ABC)
    addHandlerChanged(insert.factor.A, handler <- function(h,...) {
        Anew <- svalue(h$obj)
        if(Anew==svalue(insert.factor.B)){
            Aold <- get("Aold", envir=myenv.ABC)
            svalue(insert.factor.B) <- Aold
            assign("Bold", Aold, envir=myenv.ABC)
        }
        if(Anew==svalue(insert.factor.C)){
            Aold <- get("Aold", envir=myenv.ABC)
            svalue(insert.factor.C) <- Aold
            assign("Cold", Aold, envir=myenv.ABC)
        }
        if(Anew==svalue(insert.response)){
            Aold <- get("Aold", envir=myenv.ABC)
            svalue(insert.response) <- Aold
            assign("Yold", Aold, envir=myenv.ABC)
        }
        assign("Aold", Anew, envir=myenv.ABC)
       })  
    addHandlerChanged(insert.factor.B, handler <- function(h,...) {
        Bnew <- svalue(h$obj)
        if(Bnew==svalue(insert.factor.A)){
            Bold <- get("Bold", envir=myenv.ABC)
            svalue(insert.factor.A) <- Bold
            assign("Aold", Bold, envir=myenv.ABC)
        }
        if(Bnew==svalue(insert.factor.C)){
            Bold <- get("Bold", envir=myenv.ABC)
            svalue(insert.factor.C) <- Bold
            assign("Cold", Bold, envir=myenv.ABC)
        }
        if(Bnew==svalue(insert.response)){
            Bold <- get("Bold", envir=myenv.ABC)
            svalue(insert.response) <- Bold
            assign("Yold", Bold, envir=myenv.ABC)
        }
        assign("Bold", Bnew, envir=myenv.ABC)
       })  
    addHandlerChanged(insert.factor.C, handler <- function(h,...) {
        Cnew <- svalue(h$obj)
        if(Cnew==svalue(insert.factor.A)){
            Cold <- get("Cold", envir=myenv.ABC)
            svalue(insert.factor.A) <- Cold
            assign("Aold", Cold, envir=myenv.ABC)
        }
        if(Cnew==svalue(insert.factor.B)){
            Cold <- get("Cold", envir=myenv.ABC)
            svalue(insert.factor.B) <- Cold
            assign("Bold", Cold, envir=myenv.ABC)
        }
        if(Cnew==svalue(insert.response)){
            Cold <- get("Cold", envir=myenv.ABC)
            svalue(insert.response) <- Cold
            assign("Yold", Cold, envir=myenv.ABC)
        }
        assign("Cold", Cnew, envir=myenv.ABC)
       })  
    addHandlerChanged(insert.response, handler <- function(h,...) {
        Ynew <- svalue(h$obj)
        if(Ynew==svalue(insert.factor.A)){
            Yold <- get("Yold", envir=myenv.ABC)
            svalue(insert.factor.A) <- Yold
            assign("Aold", Yold, envir=myenv.ABC)
        }
        if(Ynew==svalue(insert.factor.B)){
            Yold <- get("Yold", envir=myenv.ABC)
            svalue(insert.factor.B) <- Yold
            assign("Bold", Yold, envir=myenv.ABC)
        }
        if(Ynew==svalue(insert.factor.C)){
            Yold <- get("Yold", envir=myenv.ABC)
            svalue(insert.factor.C) <- Yold
            assign("Cold", Yold, envir=myenv.ABC)
        }
        assign("Yold", Ynew, envir=myenv.ABC)
       })  
    }
)

Update

@jverzani has given a nice alternative to my code. But in my code, the "Select columns" widget is defined in the handler() function of the gbutton() widget, because I want that the column selection appears only after the "Load data" widget has been clicked, and I also want to desactivate the "Load data" widget once data has been loaded. Thus if I replace my "Select columns" widget with @jverzani's proposal, that does not work without additional modifications (see code below). I have not been able to make it work using global assignments instead of local assignments. Maybe the insertion of a widget in a handler() function of another widget is a bad practice ? But I don't know any other solution yet.

...
## WIDGET: SELECT COLUMNS ##
grp.load.data <- gbutton(text="Load data", container = DataGroup, 
    handler = function(h, ...) {
    enabled(grp.load.data) <- FALSE
    RR_data(svalue(browse.file))
    #
    dat0 <- get("dat0", envir=myenv.data)
    SelectGroup <<- gframe("Select columns ", container = DataGroup, horizontal=FALSE)  
    grp.select <<-  ggroup(horizontal=FALSE, container = SelectGroup)  
    dat.columns <- colnames(dat0)  
  #
    labels <- c("Factor A (fixed)", "Factor B", "Factor C", "Response")
    Insert.columns <- lapply(1:length(labels), function(i) {
      glabel(labels[i], container = grp.select) 
      gcombobox(dat.columns, selected=i, container=grp.select)
    })
    ## make exclusive
    sapply(1:length(Insert.columns), function(i) {
      addHandlerChanged(Insert.columns[[i]], handler=function(h,...) {
        all_selected <- sapply(Insert.columns, svalue)
        selected <- svalue(h$obj)    
        ind <- which(selected == all_selected)      
        if(length(ind) > 1) {
          j <- setdiff(ind, i)
          remaining <- setdiff(fac_levels, all_selected)
          tmp <- Insert.columns[[j]]
          svalue(tmp) <- remaining[1]
        }
      })
    })
    insert.factor.A  <<- Insert.columns[[1]]
    insert.factor.B  <<- Insert.columns[[2]]
    insert.factor.C  <<- Insert.columns[[3]]
    insert.response <<- Insert.columns[[4]]
  }
)
Solution

  • Is something like this what you want?

    library(gWidgets)
options("guiToolkit"="RGtk2")
library(MASS)



x <- Cars93
fac_levels <- levels(x$Type)
n_levels <- length(fac_levels)

## create a GUI with mutually exclusive comboboxes
w <- gwindow()
g <- ggroup(horizontal=FALSE, cont=w)

widgets <- lapply(1:4, function(i) {
  gcombobox(fac_levels, selected=i, cont=g)
})


## make exclusive
sapply(1:length(widgets), function(i) {
  addHandlerChanged(widgets[[i]], handler=function(h,...) {
    all_selected <- sapply(widgets, svalue)
    selected <- svalue(h$obj)

    ind <- which(selected == all_selected)

    if(length(ind) > 1) {
      j <- setdiff(ind, i)
      remaining <- setdiff(fac_levels, all_selected)
      tmp <- widgets[[j]]
      svalue(tmp) <- remaining[1]
    }
  })
})