Виджет для выбора столбцов набора данных с обоюдным исключением

Question

Мой R-код ниже создает интерфейс, который вы видите на скриншоте. Пользователь загружает csv-файл, и он выбирает четыре столбца загруженного набора данных (example data file is available here, но может использоваться любой файл csv с по меньшей мере четырьмя столбцами). Я применил «взаимное исключение» для выбранных столбцов: например, на примере скриншота ниже, если пользователь выбирает столбец «operator» в качестве фактора 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) 
     }) 
    } 
) 

Update

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

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

Answer 2

Вместо редактирования предыдущего, я добавлю новый ответ, который интегрирует его в ссылочный класс. Надеюсь, это даст вам достаточно возможностей для работы. Он в основном обертывает один ответ в ссылочный класс, а затем показывает, как с этим работать.

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