Commit 74528799 authored by jlopez's avatar jlopez
Browse files

Add new shinyInput

parent 30c3872f
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
......@@ -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)
......
......@@ -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)
)),
......
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
......@@ -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")
}
......
(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
......@@ -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: []}
]
},
{
......
......@@ -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()
......@@ -5,3 +5,7 @@
base::`+`(e1, e2)
}
}
`%+=%` = function(e1,e2) {
eval.parent(substitute(e1 <- e1 + e2))
}
\ No newline at end of file