用于选择具有互斥的数据集列的小组件

时间：2013-07-30 20:49:17

标签： r gwidgets

下面的我的R代码生成您在屏幕截图中看到的界面。用户加载csv文件并选择加载数据集的四列（example data file is available here，但可以使用任何至少包含四列的csv文件）。我已经为所选列实现了“互斥”：例如，使用下面的屏幕截图示例，如果用户选择“运算符”列作为因子A，则因子B将自动切换到“日期”列。

如您所见，我的代码非常繁重。想象一个更精细的小部件，其中用户初步设置要选择的列的数量。也许我可以使用循环并使用列表存储对象来实现与下面的代码相同的方法，以获得无数的列。但是，有没有更好/更容易的方法呢？

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)
       })  
    }
)

更新

@jverzani已经为我的代码提供了一个很好的替代方案。但是在我的代码中，“选择列”小部件在handler()小部件的gbutton()函数中定义，因为我希望列选择仅在单击“加载数据”小部件后出现，我还想在加载数据后停用“加载数据”小部件。因此，如果我用@ jverzani的提议替换我的“选择列”小部件，那么没有其他修改就无法工作（请参阅下面的代码）。我无法使用全局分配而不是本地分配来使其工作。也许在另一个小部件的handler()函数中插入一个小部件是一种不好的做法？但我还不知道任何其他解决方案。

...
## 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]]
  }
)

2 个答案:

答案 0 :(得分：1)

这是你想要的吗？

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]
    }
  })
})

答案 1 :(得分：1)

我将添加一个新的答案，将其集成到引用类中，而不是编辑前一个。希望这能让你有足够的合作。它基本上将一个答案包装到引用类中，然后显示如何使用它。 

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





varSelector <- NULL

## create a GUI with mutually exclusive comboboxes
w <- gwindow()
g <- ggroup(horizontal=FALSE, cont=w)
select_file <- gfilebrowse("Select a file", cont=g, quote=FALSE)
g1 <- ggroup(horizontal=FALSE, cont=g)
b <- gbutton("List selected", cont=g, handler=function(h,...) {
  if (!is.null(varSelector))
    print(varSelector$get_values())
})


addHandlerChanged(select_file, handler=function(h,...) {
  csvfile <- svalue(h$obj)
  x <- read.csv(csvfile)
  fac_levels <- Filter(function(nm) is.factor(x[[nm]]), names(x))
  if (length(fac_levels) > 4) {
    varSelector <<- VarSelect$new(fac_levels, g1)
  }
})

##


VarSelect <- setRefClass("VarSelect",
                         fields=list(
                           widgets="list",
                           fac_levels="character",
                           flag="logical"
                           ),
                         methods=list(
                           initialize=function(levels=character(), cont=gwindow(), ...) {
                             g <- ggroup(horizontal=FALSE, cont=cont, ...)
                             initFields(
                               fac_levels=levels,
                               flag=FALSE
                               )
                             widgets <<- lapply(1:4, function(i) {
                               gcombobox(fac_levels, selected=i, cont=g)
                             })
                             if(length(fac_levels) > 4)
                               make_exclusive()
                             .self

                           },
                           set_levels=function(levels) {
                             fac_levels <<- levels
                             lapply(widgets, blockHandler)
                             lapply(widgets, function(widget) widget[] <- fac_levels)
                             if (!flag) {
                               make_exclusive()
                               flag <<- TRUE
                             }
                             lapply(widgets, unblockHandler)
                           },
                           make_exclusive=function() {
                             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]
                                 }
                               })
                             })
                           },
                           get_values = function() lapply(widgets, svalue)
                         ))
相关问题
最新问题