r - 用于选择具有互斥的数据集列的小部件

Question

下面我的 R 代码会生成您在屏幕截图中看到的界面。用户加载一个 csv 文件并选择加载数据集的四列（此处提供了示例数据文件，但可以使用任何具有至少四列的 csv 文件）。我已经为选定的列实现了“互斥”：例如，在下面的屏幕截图示例中，如果用户选择“运算符”列作为因子 A，那么因子 B 会自动切换到“天”列。

如您所见，我的代码非常繁重。想象一个更精细的小部件，用户在其中预先设置要选择的列数。也许我可以实现与下面的代码相同的方法，使用循环和使用列表来存储对象的列数。但是有没有更好/更简单的方法来做到这一点？

小部件

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

score 1 · Accepted Answer

你想要这样的东西吗？

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

score 1 · Accepted Answer

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

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

r - 用于选择具有互斥的数据集列的小部件

更新

2 回答 2

Related

Reference