Add new shinyInput

app/pipeline/R/chooser.R

+chooserInput <- function(inputId, leftLabel, rightLabel, leftChoices, rightChoices,
+                         size = 5, multiple = FALSE) {
+  
+  leftChoices <- lapply(leftChoices, tags$option)
+  rightChoices <- lapply(rightChoices, tags$option)
+  
+  if (multiple)
+    multiple <- "multiple"
+  else
+    multiple <- NULL
+  
+  tagList(
+    singleton(tags$head(
+      tags$script(src="chooser-binding.js"),
+      tags$style(type="text/css",
+                 HTML(".chooser-container { display: inline-block; }")
+      )
+    )),
+    div(id=inputId, class="chooser",
+        div(class="chooser-container chooser-left-container",
+            tags$select(class="left", size=size, multiple=multiple, leftChoices)
+        ),
+        div(class="chooser-container chooser-center-container",
+            icon("arrow-circle-o-right", "right-arrow fa-3x text-primary"),
+            tags$br(),
+            icon("arrow-circle-o-left", "left-arrow fa-3x text-primary")
+        ),
+        div(class="chooser-container chooser-right-container",
+            tags$select(class="right", size=size, multiple=multiple, rightChoices)
+        )
+    )
+  )
+}
+
+registerInputHandler("shinyjsexamples.chooser", function(data, ...) {
+  if (is.null(data))
+    NULL
+  else
+    list(left=as.character(data$left), right=as.character(data$right))
+}, force = TRUE)
\ No newline at end of file

app/pipeline/app.R

@@ -13,6 +13,8 @@ library(knitr)
 library(DT)
 
 
+source("./R/chooser.R", local=T)
+
 source("./pages/pages_def_inputs.R", local=T)
 source("./pages/pages_def_input2.R", local=T)
 source("./R/menugauche.R", local=T)

app/pipeline/pages/pages_def_inputs.R

@@ -19,7 +19,9 @@ tabPanel("Param panel 1", height = "300px", style = "overflow: hidden; overflow-
 
 		checkboxInput("param9", label = "Checkbox 2", value = FALSE),
 
-		actionButton("testButton", "Test", class="btn btn-success")
+		actionButton("testButton", "Test", class="btn btn-success"),
+
+		chooserInput("mychoose2", "Available", "Selected", c("A", "B", "C"), c(), size = 10, multiple = TRUE)
 
 	)),
 

app/pipeline/params/params_inputs.yml

+ param1: "" 
+ param2: 50 
+ param3_min: 11.8 
+ param3_max: 19.6 
+ param3_step: 0.1 
+ param8: true 
+ param9: false 
+ mychoose2_left: ["A", "B"]
+ mychoose2_right: ["C"]
+ param10: "" 
+ param7: "" 
+ inputs_param1: "" 
+ inputs_param2: 50 
+ inputs_param3_min: 11.8 
+ inputs_param3_max: 19.6 
+ inputs_param3_step: 0.1 
+ inputs_param8: true 
+ inputs_param9: false 
+

app/pipeline/server/opt_inputs.R

@@ -56,6 +56,24 @@ observeEvent(input$runP, {
 			res <- paste(res, "param9:", "false", "\n", sep = " ")
 		}	
 
+		res <- paste0(res, " mychoose2" + "_left: [")
+		for(x in 1:length(input$mychoose2$left)) {
+			res <- paste0(res, '"', input$mychoose2$left[[x]], '"')
+			if(x < length(input$mychoose2$left)) {
+				res <- paste0(res, ", ")
+			}
+		}		
+		res <- paste0(res, "]", "\n")
+
+		res <- paste0(res, " mychoose2" + "_right: [")
+		for(x in 1:length(input$mychoose2$right)) {
+			res <- paste0(res, '"', input$mychoose2$right[[x]], '"')
+			if(x < length(input$mychoose2$right)) {
+				res <- paste0(res, ", ")
+			}
+		}		
+		res <- paste0(res, "]", "\n")
+
 	}
 
 

app/pipeline/www/chooser-binding.js

+(function() {
+
+function updateChooser(chooser) {
+    chooser = $(chooser);
+    var left = chooser.find("select.left");
+    var right = chooser.find("select.right");
+    var leftArrow = chooser.find(".left-arrow");
+    var rightArrow = chooser.find(".right-arrow");
+    
+    var canMoveTo = (left.val() || []).length > 0;
+    var canMoveFrom = (right.val() || []).length > 0;
+    
+    leftArrow.toggleClass("muted", !canMoveFrom);
+    rightArrow.toggleClass("muted", !canMoveTo);
+}
+
+function move(chooser, source, dest) {
+    chooser = $(chooser);
+    var selected = chooser.find(source).children("option:selected");
+    var dest = chooser.find(dest);
+    dest.children("option:selected").each(function(i, e) {e.selected = false;});
+    dest.append(selected);
+    updateChooser(chooser);
+    chooser.trigger("change");
+}
+
+$(document).on("change", ".chooser select", function() {
+    updateChooser($(this).parents(".chooser"));
+});
+
+$(document).on("click", ".chooser .right-arrow", function() {
+    move($(this).parents(".chooser"), ".left", ".right");
+});
+
+$(document).on("click", ".chooser .left-arrow", function() {
+    move($(this).parents(".chooser"), ".right", ".left");
+});
+
+$(document).on("dblclick", ".chooser select.left", function() {
+    move($(this).parents(".chooser"), ".left", ".right");
+});
+
+$(document).on("dblclick", ".chooser select.right", function() {
+    move($(this).parents(".chooser"), ".right", ".left");
+});
+
+var binding = new Shiny.InputBinding();
+
+binding.find = function(scope) {
+  return $(scope).find(".chooser");
+};
+
+binding.initialize = function(el) {
+  updateChooser(el);
+};
+
+binding.getValue = function(el) {
+  return {
+    left: $.makeArray($(el).find("select.left option").map(function(i, e) { return e.value; })),
+    right: $.makeArray($(el).find("select.right option").map(function(i, e) { return e.value; }))
+  }
+};
+
+binding.setValue = function(el, value) {
+  // TODO: implement
+};
+
+binding.subscribe = function(el, callback) {
+  $(el).on("change.chooserBinding", function(e) {
+    callback();
+  });
+};
+
+binding.unsubscribe = function(el) {
+  $(el).off(".chooserBinding");
+};
+
+binding.getType = function() {
+  return "shinyjsexamples.chooser";
+};
+
+Shiny.inputBindings.register(binding, "shinyjsexamples.chooser");
+
+})();
\ No newline at end of file

app/pipelineR.yml

@@ -28,7 +28,7 @@ App:
               {name: "param8", type: "checkbox", value: TRUE, label: "Checkbox 1"},
               {name: "param9", type: "checkbox", value: FALSE, label: "Checkbox 2"},
               {name: "testButton", type: "button", icon: "", class: "btn btn-success", label: "Test"}, # class : primary, success, danger, warning, info
-
+              {name: "mychoose2", type: "chooser", size: 10, multiple: TRUE, value_left: ["A", "B", "C"], value_right: []}
               ]
           }, 
           {

main.R

@@ -9,29 +9,33 @@ APP <<- yaml.load_file(path_yml)$App
 
 files_tools <- paste0(path_tools, list.files(path_tools))
 
-all <- list()
-
-index <- 1
-for(f in files_tools) {
-  yml <- yaml.load_file(f)
-  if(length(yml) ==  0) {
-    all <- list(yaml.load_file(f))
-  } else {
-    all[[index]] <- yaml.load_file(f)
+YML_TOOLS <<- get_predefined_tool(files_tools)
+
+#============================================================
+
+get_predefined_tool <- function(path) {
+  all <- list()
+  
+  index <- 1
+  for(f in files_tools) {
+    yml <- yaml.load_file(f)
+    if(length(yml) ==  0) {
+      all <- list(yaml.load_file(f))
+    } else {
+      all[[index]] <- yaml.load_file(f)
+    }
+    index <- index + 1
   }
   
-  index <- index + 1
+  return(all)
 }
 
-YML_TOOLS <<- all
-YML_TOOLS
 #============================================================
 
 generate_added_styles <- function () {
   path_css = APP$project + "/www/added_styles.css"
 
   file.replace(path_css)
-  
 }
 
 #============================================================
@@ -146,7 +150,36 @@ generate_page_input <- function(res, cnt) {
     
     res <- res + '\t\tcheckboxInput("'+ cnt$name +'", label = "'+ cnt$label +'", value = ' + cnt$value + ')'  
     
+  } else if(cnt$type == "chooser") {
+    
+    vl <- 'c('
+    vr <- 'c('
+    
+    if(length(cnt$value_left) > 0) {
+      for(x in 1:length(cnt$value_left)) {
+        vl <- vl + '"' + cnt$value_left[[x]] + '"'
+        if(x < length(cnt$value_left)) {
+          vl <- vl + ', '
+        }
+      }
+    }
     
+    vl <- vl + ')'
+    
+    if(length(cnt$value_right) > 0) {
+      vr <- "c("
+      for(x in 1:length(cnt$value_right)) {
+        vr <- vr + '"' + cnt$value_right[[x]] + '"'
+        if(x < length(cnt$value_right)) {
+          vr <- vr + ', '
+        }
+      }
+    }
+    
+    vr <- vr + ')'
+  
+    res <- res + '\t\tchooserInput("' + cnt$name + '", "Available", "Selected", ' + vl + ', ' + vr + ', size = ' + cnt$size + ', multiple = ' + cnt$multiple + ')'
+
   } else if(cnt$type == "checkboxGroupInput") {
     
     res <- res + '\t\tcheckboxGroupInput("'+ cnt$name +'",label = "'+ cnt$label +'", choices = list('
@@ -205,6 +238,59 @@ generate_page_input <- function(res, cnt) {
 
 #============================================================
 
+get_predefined_box <- function(box, page_name) {
+  new_box <- NULL
+  for(t in YML_TOOLS) {
+    if(t$name == box$name) {
+      new_box <- t
+      
+      if(box$concat_name_param == TRUE) {
+        for(z in 1:length(new_box$content)) {
+          new_box$content[[z]]$name <- page_name + "_" + new_box$content[[z]]$name
+        }
+      }
+      
+      break
+    }
+  }
+  
+  return(new_box)
+}
+
+#============================================================
+
+generate_page_box <- function(panel, box, res) {
+  
+  res <- res + '\tconditionalPanel(\n'
+  res <- res + '\tcondition = "input.select' + panel$name + ' == \'' + box$name + '\'",\n'
+  
+  res <- res + '\tbox(title = "' + box$title + '", width = 12, status = "' + box$status + '", collapsible = TRUE, solidHeader = TRUE'
+  
+  panel_content = box$content
+  
+  if(length(panel_content) > 0) {
+    
+    res <- res + ',\n'
+    
+    for(z in 1:length(panel_content)) {
+      res <- generate_page_input(res, panel_content[[z]])
+      
+      if(z < length(panel_content)) {
+        res <- res + ','
+      }
+  
+      res <- res + '\n\n'
+    }
+  }
+  
+  res <- res + '\t))'
+  
+  return(res)
+  
+}
+
+#============================================================
+
 generate_pages_server <- function() {
   for(x in 1:length(APP$pages)) {
     name <- APP$pages[[x]]$name
@@ -252,58 +338,17 @@ generate_pages_server <- function() {
             box <- panel_boxes[[b]]
             
             if(box$defined == TRUE) {
-                for(t in YML_TOOLS) {
-                  if(t$name == box$name) {
-                    box <- t
-                    
-                    if(panel_boxes[[b]]$concat_name_param == TRUE) {
-                      for(z in 1:length(box$content)) {
-                        box$content[[z]]$name <- APP$pages[[x]]$name + "_" + box$content[[z]]$name
-                        
-                      }
-                    }
-                    
-                    break
-                  }
-                }
+              box <- get_predefined_box(box, APP$pages[[x]]$name)
             } 
             
-            
-            res <- res + '\tconditionalPanel(\n'
-            res <- res + '\tcondition = "input.select' + panel$name + ' == \'' + box$name + '\'",\n'
-            
-            res <- res + '\tbox(title = "' + box$title + '", width = 12, status = "' + box$status + '", collapsible = TRUE, solidHeader = TRUE'
-            
-            panel_content = box$content
-        
-            if(length(panel_content) > 0) {
-              
-              res <- res + ',\n'
-  
-              for(z in 1:length(panel_content)) {
-  
-                cnt <- panel_content[[z]]
-  
-                res <- generate_page_input(res, cnt)
-  
-                if(z < length(panel_content)) {
-                  res <- res + ',\n\n'
-                } else {
-                  res <- res + '\n\n'
-                }
-  
-              }
-  
-            }
+            res <- generate_page_box(panel, box, res)
             
             if(b < length(panel_boxes)) {
-              res <- res + '\t)),\n\n'
+              res <- res + ',\n\n'
             } else {
-              res <- res + '\t))\n\n'
+              res <- res + '\n\n'
             }
-          
           }
-          
         }
         
         if(y < length(content)) {
@@ -320,10 +365,8 @@ generate_pages_server <- function() {
     
     res <- res + '),\n\n'
     
-    
     res <- res + 'box(title = "Results :", width = 7, status = "primary", collapsible = TRUE, solidHeader = TRUE, style = "overflow: hidden; overflow-x:scroll"'
     
-    
     cnt <- APP$pages[[x]]$pipeline$shiny_button
     
     if(!is.null(cnt)) {
@@ -378,20 +421,7 @@ generate_pages_server <- function() {
             box <- panel_boxes[[b]]
             
             if(box$defined == TRUE) {
-              for(t in YML_TOOLS) {
-                if(t$name == box$name) {
-                  box <- t
-                  
-                  if(panel_boxes[[b]]$concat_name_param == TRUE) {
-                    for(z in 1:length(box$content)) {
-                      box$content[[z]]$name <- APP$pages[[x]]$name + "_" + box$content[[z]]$name
-                      
-                    }
-                  }
-                  
-                  break
-                }
-              }
+              box <- get_predefined_box(box, APP$pages[[x]]$name)
             } 
             
             
@@ -464,23 +494,9 @@ generate_pages_server <- function() {
             box <- panel_boxes[[b]]
             
             if(box$defined == TRUE) {
-              for(t in YML_TOOLS) {
-                if(t$name == box$name) {
-                  box <- t
-                  
-                  if(panel_boxes[[b]]$concat_name_param == TRUE) {
-                    for(z in 1:length(box$content)) {
-                      box$content[[z]]$name <- APP$pages[[x]]$name + "_" + box$content[[z]]$name
-                      
-                    }
-                  }
-                  
-                  break
-                }
-              }
+              box <- get_predefined_box(box, APP$pages[[x]]$name)
             } 
             
-            
             res <- res + '\n\t# Tool : ' + box$name+ '\n'
             
             res <- res + '\n\tif(input$select' + panel$name + ' == "' + box$name + '") {\n'
@@ -530,7 +546,31 @@ generate_pages_server <- function() {
                   res <- res + '\t\t\tres <- paste(res, "' + id + ':", "false", "\\n", sep = " ")\n'
                   res <- res + '\t\t}'
                   res <- res + '\t\n\n'
-                } 
+                } else if(cnt$type == "chooser") {
+                  
+                  
+                  res <- res + '\t\tres <- paste0(res, " ' + id + '" + "_left: [")\n'
+                  res <- res + '\t\tfor(x in 1:length(input$'+ id +'$left)) {\n'
+                  res <- res + '\t\t\tres <- paste0(res, \'"\', input$'+ id +'$left[[x]], \'"\')\n'
+                  res <- res + '\t\t\tif(x < length(input$'+ id +'$left)) {\n'
+                  res <- res + '\t\t\t\tres <- paste0(res, ", ")\n'
+                  res <- res + '\t\t\t}\n'
+                  res <- res + '\t\t}		\n'
+                  res <- res + '\t\tres <- paste0(res, "]", "\\n")\n\n'
+                  
+                  res <- res + '\t\tres <- paste0(res, " ' + id + '" + "_right: [")\n'
+                  res <- res + '\t\tfor(x in 1:length(input$'+ id +'$right)) {\n'
+                  res <- res + '\t\t\tres <- paste0(res, \'"\', input$'+ id +'$right[[x]], \'"\')\n'
+                  res <- res + '\t\t\tif(x < length(input$'+ id +'$right)) {\n'
+                  res <- res + '\t\t\t\tres <- paste0(res, ", ")\n'
+                  res <- res + '\t\t\t}\n'
+                  res <- res + '\t\t}		\n'
+                  res <- res + '\t\tres <- paste0(res, "]", "\\n")\n\n'
+                  
+                  
+                } else {
+                  #TODO
+                }
        
               }
             
@@ -548,7 +588,6 @@ generate_pages_server <- function() {
       
       res <- res + '\twrite(res, file=path_param)'
       
-      
       res <- res + '\n\n'
       
       res <- res + '\tsystem(paste(" ' 
@@ -637,6 +676,30 @@ dir.create.not.exist <- function(path) {
   }
 }
 
+#============================================================
+
+generate_rproj <- function(path) {
+  file.replace(path)
+  res <- ""
+  res <- res + "Version: 1.0\n"
+  res <- res + " \n"
+  res <- res + "RestoreWorkspace: Default\n"
+  res <- res + "SaveWorkspace: Default\n"
+  res <- res + "AlwaysSaveHistory: Default\n"
+  res <- res + " \n"
+  res <- res + "EnableCodeIndexing: Yes\n"
+  res <- res + "UseSpacesForTab: Yes\n"
+  res <- res + "NumSpacesForTab: 2\n"
+  res <- res + "Encoding: UTF-8\n"
+  res <- res + " \n"
+  res <- res + "RnwWeave: Sweave\n"
+  res <- res + "LaTeX: pdfLaTeX\n"
+  res <- res + " \n"
+  write(res, path)
+}
+
+#============================================================
+
 generate <- function() {
   
   print("Generate Start")
@@ -660,30 +723,15 @@ generate <- function() {
   
   dir.create.not.exist(APP$project + "/params")
   
-  file.replace(APP$project + "/" + basename(APP$project) + ".Rproj")
-  
   path_rproj = APP$project + "/" + basename(APP$project) + ".Rproj"
   
-  res <- ""
-  res <- res + "Version: 1.0\n"
-  res <- res + " \n"
-  res <- res + "RestoreWorkspace: Default\n"
-  res <- res + "SaveWorkspace: Default\n"
-  res <- res + "AlwaysSaveHistory: Default\n"
-  res <- res + " \n"
-  res <- res + "EnableCodeIndexing: Yes\n"
-  res <- res + "UseSpacesForTab: Yes\n"
-  res <- res + "NumSpacesForTab: 2\n"
-  res <- res + "Encoding: UTF-8\n"
-  res <- res + " \n"
-  res <- res + "RnwWeave: Sweave\n"
-  res <- res + "LaTeX: pdfLaTeX\n"
-  res <- res + " \n"
-  
-  write(res, path_rproj)
+  generate_rproj(path_rproj)
   
   generate_added_styles()
   
+  file.copy("./tools/chooser.R", APP$project + "/R/")
+  file.copy("./tools/chooser-binding.js", APP$project + "/www/")
+  
   print("Generate End")
 }
 
@@ -720,6 +768,8 @@ generate_app <- function() {
   
   res <- res + '\n\n'
   
+  res <- res + 'source("./R/chooser.R", local=T)\n\n'
+  
   for(x in 1:length(APP$pages)) {
     name <- APP$pages[[x]]$name
     res <- res + 'source("./pages/pages_def_'+tolower(name)+'.R", local=T)\n'
@@ -727,6 +777,10 @@ generate_app <- function() {
   
   res <- res + 'source("./R/menugauche.R", local=T)\n\n'
   
+  
+  
+  
+  
   res <- res + '\n\n'
   
   res <- res + 'style <- tags$style(HTML(readLines("www/added_styles.css")))\n\n'
@@ -785,5 +839,3 @@ generate_app <- function() {
 #============================================================
 
 generate()
-
-

tools.R

@@ -5,3 +5,7 @@
     base::`+`(e1, e2)
   }
 }
+
+`%+=%` = function(e1,e2) {
+  eval.parent(substitute(e1 <- e1 + e2))
+}
\ No newline at end of file