manipulateWidget/ 0000755 0001762 0000144 00000000000 15131451072 013554 5 ustar ligges users manipulateWidget/tests/ 0000755 0001762 0000144 00000000000 15126675445 014736 5 ustar ligges users manipulateWidget/tests/testthat/ 0000755 0001762 0000144 00000000000 15131451072 016556 5 ustar ligges users manipulateWidget/tests/testthat/test-on_done.R 0000644 0001762 0000144 00000002673 15126746410 021316 0 ustar ligges users # context("onDone")
#
# describe("onDone", {
# it ("stops the shiny gadget and returns a htmlwidget", {
# with_mock(
# `shiny::stopApp` = function(x) {
# print("Stop gadget")
# x
# },
# {
# inputs <- initInputEnv(list(x1 = mwText("value1"), x2 = mwSelect(1:3)))
# expr <- expression(combineWidgets(paste(x1, x2)))
# controller <- MWController(expr, inputs)$init()
#
# expect_output(res <- onDone(controller), "Stop gadget")
# expect_is(res, "htmlwidget")
# expect_equal(length(res$widgets), 1)
# expect_equal(res$widgets[[1]], "value1 1")
# }
# )
# })
#
# it ("returns a combined widget if comparison", {
# suppressWarnings({with_mock(
# `shiny::stopApp` = function(x) {
# print("Stop gadget")
# x
# },
# {
# compare <- list(x2 = list(1, 2, 3))
# inputs <- initInputEnv(list(x1 = mwText("value1"), x2 = mwSelect(1:3)),
# compare = compare, ncharts = 3)
# expr <- expression(paste(x1, x2))
# controller <- MWController(expr, inputs)$init()
# expect_output(res <- onDone(controller), "Stop gadget")
# expect_is(res, "combineWidgets")
# expect_equal(length(res$widgets), 3)
# for (i in 1:3) {
# expect_equal(res$widgets[[i]]$widgets[[1]], paste("value1", compare$x2[[i]]))
# }
# }
# )})
# })
#
# })
manipulateWidget/tests/testthat/test-inputs.R 0000644 0001762 0000144 00000004363 15126675445 021226 0 ustar ligges users context("Shiny inputs")
# Slider
test_input(mwSlider(0, 10, 0), c(5, -20, 20), c(5, 0, 10))
# Slider with two values
test_input(
mwSlider(0, 10, 0),
list(c(5, 7), c(-20, 20), c(-20, 5), c(5, 20)),
list(c(5, 7), c(0, 10), c(0, 5), c(5, 10))
)
# Text
test_input(mwText(), list("1", 1, NULL), list("1", "1", ""))
# Numeric
test_input(mwNumeric(0), list(5, -20, 20, NULL, "a"), list(5, -20, 20, NULL, NULL))
test_input(mwNumeric(0, min = 0, max = 10), c(5, -20, 20), c(5, 0, 10))
# Password
test_input(mwPassword(), list("1", 1, NULL), list("1", "1", ""))
# Select
test_input(mwSelect(1:4), list(1, 2, 5, NULL), list(1, 2, 1, 1))
test_input(
mwSelect(1:4, multiple = TRUE),
list(1, 5, 3:5),
list(1, integer(0), 3:4)
)
# Select where choices have distinct label and values
test_input(
mwSelect(list(a = 1, b = 2)),
list(1, 2, 5, NULL),
list(1, 2, 1, 1)
)
test_input(
mwSelect(list(a = 1, b = 2), multiple = TRUE),
list(1, 2, 5, 1:3),
list(1, 2, integer(0), 1:2)
)
# Checkbox
test_input(
mwCheckbox(),
list(TRUE, FALSE, NULL, NA, "test"),
list(TRUE, FALSE, FALSE, FALSE, FALSE)
)
# Radio buttons
test_input(mwRadio(1:4), list(1, 2, 5, NULL), list(1, 2, 1, 1))
test_input(
mwRadio(list(a = 1, b = 2)),
list(1, 2, 5, NULL),
list(1, 2, 1, 1)
)
# Date picker
test_input(
mwDate(),
list(Sys.Date(), "2017-01-01", NULL),
list(Sys.Date(), as.Date("2017-01-01"), Sys.Date())
)
# Date with min and max dates
test_input(
mwDate(min = "2017-01-01", max = "2017-12-31"),
list("2017-06-01", "2016-06-01", "2018-06-01"),
list(as.Date("2017-06-01"), as.Date("2017-01-01"), as.Date("2017-12-31"))
)
# Date range
defaultRange <- c(Sys.Date(), Sys.Date())
test_input(
mwDateRange(),
list(defaultRange, as.character(defaultRange), NULL),
list(defaultRange, defaultRange, defaultRange)
)
# Date range with min and max dates
test_input(
mwDateRange(min = "2017-01-01", max = "2017-12-31"),
list(c("2016-01-01", "2018-01-01")),
list(as.Date(c("2017-01-01", "2017-12-31")))
)
# Checkbox group
test_input(
mwCheckboxGroup(1:4),
list(1, 5, 3:5),
list(1, integer(0), 3:4)
)
test_input(
mwCheckboxGroup(list(a = 1, b = 2)),
list(1, 2, 5, 1:3),
list(1, 2, integer(0), 1:2)
)
# Groups of input
test_input(mwGroup(a = mwText(), b = mwText()))
manipulateWidget/tests/testthat/test-input_list_class.R 0000644 0001762 0000144 00000014263 15126675445 023263 0 ustar ligges users context("InputList class")
describe("InputList", {
it ("correctly updates values when an input value changes", {
inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0))
inputs <- initAllInputs(inputs, initEnv(parent.frame(), 1))
inputList <- InputList(inputs)$init()
expect_equal(inputList$getInputById("output_1_y")$value, 5)
inputList$setValue(inputId = "output_1_x", value = 7)
expect_equal(inputList$getInputById("output_1_x")$value, 7)
})
it("detects dependencies between inputs", {
inputs <- list(
x = mwSlider(0, 10, 5),
y = mwSlider(x, 10, 0, .display = z > 3),
z = mwSlider(0, x, 0)
)
inputs <- initAllInputs(inputs, initEnv(parent.frame(), 1))
inputList <- InputList(inputs)$init()
expect_equal(inputList$getDeps(inputList$getInputById("output_1_x")),
list(params = character(), display = character()))
expect_length(inputList$getInputById("output_1_y")$revDeps, 0)
expect_equal(inputList$getDeps(inputList$getInputById("output_1_y")),
list(params = "output_1_x", display = "output_1_z"))
expect_equal(inputList$getInputById("output_1_x")$revDeps, c("output_1_y", "output_1_z"))
expect_equal(inputList$getInputById("output_1_z")$displayRevDeps, c("output_1_y"))
})
inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(0, 10, 0))
inputs2 <- list(x = mwSlider(0, 10, 6), y = mwSlider(0, 10, 1))
inputs <- c(
initAllInputs(list(shared = mwText("test")), initEnv(parent.frame(), 0)),
initAllInputs(inputs, initEnv(parent.frame(), 1)),
initAllInputs(inputs2, initEnv(parent.frame(), 2))
)
inputList <- InputList(inputs)$init()
it ("gets and updates an input by name and chartId", {
# Get Input
# Individual inputs
expect_equal(inputList$getInput("x", 1)$value, 5)
expect_equal(inputList$getInput("x", 2)$value, 6)
# Shared inputs
expect_equal(inputList$getInput("shared", 1)$value, "test")
expect_equal(inputList$getInput("shared", 2)$value, "test")
# Get input value
# Individual inputs
expect_equal(inputList$getValue("x", 1), 5)
expect_equal(inputList$getValue("x", 2), 6)
# Shared inputs
expect_equal(inputList$getValue("shared", 1), "test")
expect_equal(inputList$getValue("shared", 2), "test")
# Update input value
# Individual inputs
expect_equal(inputList$setValue("x", 4, 1), 4)
expect_equal(inputList$setValue("x", 5, 2), 5)
expect_equal(inputList$getValue("x", 1), 4)
expect_equal(inputList$getValue("x", 2), 5)
# Shared inputs
expect_equal(inputList$setValue("shared", "test1", 1), "test1")
expect_equal(inputList$getValue("shared", 1), "test1")
expect_equal(inputList$setValue("shared", "test2", 1), "test2")
expect_equal(inputList$getValue("shared", 2), "test2")
it ("gets all values for one chart", {
for (i in 1:2) {
values <- inputList$getValues(i)
expect_is(values, "list")
expect_named(values, c("shared", "x", "y"), ignore.order = TRUE)
for (n in c("shared", "x", "y")) {
expect_equal(values[[n]], inputList$getValue(n, i))
}
}
})
it ("indicates if an input is shared or not", {
expect_true(inputList$isShared("shared"))
expect_true(! inputList$isShared("x"))
expect_true(! inputList$isShared("y"))
})
it ("does not modify values until it is initialized", {
inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0))
inputs <- initAllInputs(inputs, initEnv(parent.frame(), 1))
inputList <- InputList(inputs)
expect_equal(inputList$getInputById("output_1_y")$value, 0)
inputList$setValue(inputId = "output_1_x", value = 7)
expect_equal(inputList$getInputById("output_1_y")$value, 0)
inputList$init()
expect_equal(inputList$getInputById("output_1_y")$value, 7)
inputList$setValue(inputId = "output_1_x", value = 8)
expect_equal(inputList$getInputById("output_1_y")$value, 8)
})
it ("can add an input", {
e <- initEnv(parent.frame(), 1)
inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0))
inputs <- initAllInputs(inputs, e)
inputList <- InputList(inputs[1])$init()
inputList$addInputs(inputs[2])
expect_equal(inputList$getInputById("output_1_y")$value, 5)
inputList$setValue(inputId = "output_1_x", value = 7)
expect_equal(inputList$getInputById("output_1_y")$value, 7)
values <- inputList$getValues(1)
expect_is(values, "list")
expect_named(values, c("x", "y"), ignore.order = TRUE)
for (n in c("x", "y")) {
expect_equal(values[[n]], inputList$getValue(n, 1))
}
})
it ("can add a group of inputs", {
e <- initEnv(parent.frame(), 1)
inputs <- list(x = mwSlider(0, 10, 5), grp = mwGroup(y = mwSlider(x, 10, 0)))
initInputEnv(inputs, e)
inputList <- InputList(inputs[1])$init()
inputList$addInputs(inputs[2])
expect_equal(nrow(inputList$inputTable), 3)
expect_equal(sort(inputList$inputTable$name), c("grp", "x", "y"))
})
it ("can remove an input", {
e <- initEnv(parent.frame(), 1)
inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0))
inputs <- initAllInputs(inputs, e)
inputList <- InputList(inputs)$init()
inputList$removeInput("y", 1)
expect_null(inputList$getInputById("output_1_y"))
expect_length(inputList$getInputById("output_1_x")$revDeps, 0)
expect_silent(inputList$setValue(inputId = "output_1_x", value = 7))
values <- inputList$getValues(1)
expect_equal(values, list(x = 7))
})
it ("can remove a group of inputs", {
e <- initEnv(parent.frame(), 1)
inputs <- list(x = mwSlider(0, 10, 5), grp = mwGroup(y = mwSlider(x, 10, 0)))
inputs <- initAllInputs(inputs, e)
inputList <- InputList(inputs)$init()
inputList$removeInput("grp", 1)
expect_null(inputList$getInputById("output_1_y"))
expect_null(inputList$getInputById("output_1_grp"))
expect_length(inputList$getInputById("output_1_x")$revDeps, 0)
expect_silent(inputList$setValue(inputId = "output_1_x", value = 7))
values <- inputList$getValues(1)
expect_equal(values, list(x = 7))
})
})
})
manipulateWidget/tests/testthat/test-mwModuleUI.R 0000644 0001762 0000144 00000001244 15126675445 021726 0 ustar ligges users context("mwModuleUI function")
describe("mwModuleUI function", {
it("Correct mwModuleUI", {
# missing id
expect_error(mwModuleUI())
# default
def_mw_ui <- mwModuleUI(id = "def")
expect_is(def_mw_ui, "shiny.tag.list")
expect_equal(def_mw_ui[[2]]$name, "div")
expect_equal(def_mw_ui[[2]]$attribs$id, "def-ui")
expect_true(grepl("border", def_mw_ui[[2]]$attribs$class))
# parameters
def_mw_ui <- mwModuleUI(id = "def", border = FALSE)
expect_false(grepl("border", def_mw_ui[[2]]$attribs$class))
def_mw_ui <- mwModuleUI(id = "def", height = "100%")
expect_true(grepl("height:100%", def_mw_ui[[2]]$attribs$style))
})
})
manipulateWidget/tests/testthat/test-manipulate_widget.R 0000644 0001762 0000144 00000007517 15126675445 023412 0 ustar ligges users context("manipulateWidget")
describe("manipulateWidget", {
it("returns an uninitialized MWController in a non interactive situation", {
c <- manipulateWidget(
paste(a, b),
a = mwSelect(c("a", "b", "c")),
b = mwText("test"),
.compare = "a", .runApp = FALSE
)
expect_true(!c$initialized)
})
it("creates two charts when .compare is a character vector", {
c <- manipulateWidget(
paste(a, b),
a = mwSelect(c("a", "b", "c")),
b = mwText("test"),
.compare = "a", .runApp = FALSE
)
c$init()
expect_equal(c$ncharts, 2)
expect_equal(c$getValue("a", 1), "a")
expect_equal(c$getValue("a", 2), "a")
})
it("creates two charts when .compare is a named list with null values", {
c <- manipulateWidget(
paste(a, b),
a = mwSelect(c("a", "b", "c")),
b = mwText("test"),
.compare = list(a = NULL), .runApp = FALSE
)
c$init()
expect_equal(c$ncharts, 2)
expect_equal(c$getValue("a", 1), "a")
expect_equal(c$getValue("a", 2), "a")
})
it("sets different values when .compare is a named list with non null values", {
c <- manipulateWidget(
paste(a, b),
a = mwSelect(c("a", "b", "c")),
b = mwText("test"),
.compare = list(a = list("a", "b")), .runApp = FALSE
)
c$init()
expect_equal(c$ncharts, 2)
expect_equal(c$getValue("a", 1), "a")
expect_equal(c$getValue("a", 2), "b")
expect_equal(c$charts[[1]]$widgets[[1]], "a test")
expect_equal(c$charts[[2]]$widgets[[1]], "b test")
})
it ("creates more than two charts", {
c <- manipulateWidget(
paste(a, b),
a = mwSelect(c("a", "b", "c")),
b = mwText("test"),
.compare = list(a = list("a", "b", "c")),
.compareOpts = compareOptions(ncharts = 3), .runApp = FALSE
)
c$init()
expect_equal(c$ncharts, 3)
expect_equal(c$getValue("a", 1), "a")
expect_equal(c$getValue("a", 2), "b")
expect_equal(c$getValue("a", 2), "b")
expect_equal(c$charts[[1]]$widgets[[1]], "a test")
expect_equal(c$charts[[2]]$widgets[[1]], "b test")
expect_equal(c$charts[[3]]$widgets[[1]], "c test")
})
it ("updates dynamic inputs", {
c <- manipulateWidget(
x + y,
x = mwSlider(0, 10, 5),
y = mwSlider(0, x, 4), .runApp = FALSE
)
c$init()
expect_equal(c$getParams("y")$max, 5)
c$setValue("x", 3)
expect_equal(c$getParams("y")$max, 3)
expect_equal(c$getValue("y"), 3)
})
it ("conditionally shows/hides inputs", {
c <- manipulateWidget(
x + y,
x = mwSlider(0, 10, 0),
y = mwSlider(0, 10, 0, .display = x < 5), .runApp = FALSE
)
c$init()
expect_true(c$isVisible("y"))
c$setValue("x", 6)
expect_true(!c$isVisible("y"))
})
it ("shares values between inputs and outputs", {
c <- manipulateWidget(
x2 + y,
x = mwSlider(0, 10, 5),
x2 = mwSharedValue(x * 2),
y = mwSlider(0, x2, 0), .runApp = FALSE
)
c$init()
expect_equal(c$getParams("y")$max, 10)
expect_equal(c$charts[[1]]$widgets[[1]], 10)
c$setValue("x", 8)
expect_equal(c$getValue("x2"), 16)
expect_equal(c$getParams("y")$max, 16)
expect_equal(c$charts[[1]]$widgets[[1]], 16)
})
it ("modifies a sharedInput when it is not dynamic", {
c <- manipulateWidget(
x2 + y,
x = mwSlider(0, 10, 5),
x2 = mwSharedValue(1),
x3 = mwSharedValue(x + x2),
y = mwSlider(0, x2, 0), .runApp = FALSE
)
c$init()
expect_equal(c$getParams("y")$max, 1)
expect_equal(c$charts[[1]]$widgets[[1]], 1)
c$setValue("x2", 8)
expect_equal(c$getValue("x2"), 8)
expect_equal(c$getValue("x3"), 13)
expect_equal(c$getParams("y")$max, 8)
expect_equal(c$charts[[1]]$widgets[[1]], 8)
c$setValue("x3", 10) # Dynamic shared input. Should not have any effect
expect_equal(c$getValue("x3"), 13)
})
})
manipulateWidget/tests/testthat/test-staticPlot.R 0000644 0001762 0000144 00000001202 15126675445 022017 0 ustar ligges users context("Static plot & image")
describe("Static plot & image", {
it("returns a combineWidget with both static plot and image", {
tmp_png <- tempfile(fileext = ".png")
png(file = tmp_png, bg = "transparent")
plot(1:10)
dev.off()
c <- combineWidgets(
staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300),
staticImage(tmp_png)
)
expect_is(c, "combineWidgets")
expect_length(c$widgets, 2)
# # check saveWidget and so preRenderCombinedWidgets
# tmp_html <- tempfile(fileext = ".html")
# htmlwidgets::saveWidget(c, tmp_html)
# expect_true(file.exists(tmp_html))
})
})
manipulateWidget/tests/testthat/test-input_class.R 0000644 0001762 0000144 00000002103 15126675445 022216 0 ustar ligges users context("Input class")
describe("Input", {
inputTPL <- Input(
type = "test",
value = 0,
params = list(
min = expression(0),
max = expression(10)
),
display = expression(TRUE),
validFunc = function(x, params) {
min(max(params$min, x), params$max)
},
htmlFunc = htmlFuncFactory(shiny::numericInput)
)
# Basic check
test_input(inputTPL$copy(), c(5, -20, 20), c(5, 0, 10))
it("correctly updates value when environment changes", {
myInput <- inputTPL$copy()
myInput$params$min <- expression(minx)
env <- initEnv(parent.frame(), 1)
assign("minx", 0, envir = env)
myInput$init("x", env)
expect_equal(myInput$value, 0)
assign("minx", 5, envir = env)
expect_equal(myInput$updateValue(), 5)
expect_equal(myInput$value, 5)
expect_equal(get("x", envir = env), 5)
})
it("returns a valid ID (in a JS point of view)", {
myInput <- inputTPL$copy()
env <- initEnv(parent.frame(), 1)
myInput$init("invalid.name", env)
expect_equal(myInput$getID(), "output_1_invalid_name")
})
})
manipulateWidget/tests/testthat/test-controller.R 0000644 0001762 0000144 00000006717 15126675445 022074 0 ustar ligges users context("MWController class")
describe("MWController", {
it("can be created with the result of initInputEnv()", {
inputs <- initInputEnv(list(a = mwText("a"), b = mwText("b")))
expr <- expression(paste(a, b))
controller <- MWController(expr, inputs)$init()
controller$updateCharts()
expect_is(controller$charts, "list")
expect_length(controller$charts, 1)
expect_equal(controller$charts[[1]]$widgets[[1]], "a b")
})
it("creates multiple charts in comparison mode", {
inputs <- initInputEnv(list(a = mwText("a"), b = mwText("b")), compare = "b",
ncharts = 3)
expr <- expression(paste(a, b))
controller <- MWController(expr, inputs)$init()
controller$updateCharts()
expect_is(controller$charts, "list")
expect_length(controller$charts, 3)
for (o in controller$charts) expect_equal(o$widgets[[1]], "a b")
})
it ("does not update charts if values do not change", {
inputs <- initInputEnv(list(a = mwText("a"), b = mwText("b")))
expr <- expression(print("chart updated"))
expect_output(controller <- MWController(expr, inputs)$init(), "chart updated")
expect_output(controller$updateCharts(), "chart updated")
# Update a with different value
expect_output(controller$setValue("a", "b"), "chart updated")
# Update a with same value
expect_silent(controller$setValue("a", "b"))
})
it("creates a copy that is completely autonomous", {
inputs <- initInputEnv(list(grp = mwGroup(a = mwText("a"), b = mwText("b"))))
expr <- expression(paste(a, b))
controller1 <- MWController(expr, inputs)$init()
controller2 <- controller1$clone()
controller1$setValue("a", "test")
expect_equal(controller1$getValue("a"), "test")
expect_equal(controller2$getValue("a"), "a")
expect_true(controller2$initialized)
expect_true(controller2$inputList$initialized)
})
it("accesses parameters of a given input", {
inputs <- initInputEnv(list(a = mwSelect(c("a", "b", "c")), b = mwText("b")))
expr <- expression(paste(a, b))
controller <- MWController(expr, inputs)$init()
expect_equal(controller$getParams("a")$choices, c("a", "b", "c"))
})
it("does not update values or create charts until it is initialized", {
inputs <- initInputEnv(list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0)))
expr <- expression(paste(x, y))
controller <- MWController(expr, inputs)
expect_length(controller$charts, 0)
expect_equal(controller$getValue("y"), 0)
controller$setValue("x", 3)
expect_length(controller$charts, 0)
expect_equal(controller$getValue("y"), 0)
controller$init()
expect_length(controller$charts, 1)
expect_equal(controller$charts[[1]]$widgets[[1]], "3 3")
expect_equal(controller$getValue("y"), 3)
})
})
describe("summary.MWController", {
it("prints information about controller", {
controller <- manipulateWidget(
d$value,
a = mwSelect(c("a", "b", "c")),
b = mwSelect(c("a", "b", "c"), "b"),
c = mwSelect(c("a", "b", "c"), c("a", "b"), multiple = TRUE),
d = mwSharedValue(data.frame(value = 1)),
.runApp = FALSE
)
expect_output(summary(controller), "List of inputs")
# Indicates NULL values
expect_output(summary(controller), "NULL")
# paste values if multiple values
expect_output(summary(controller), "a, b")
# for complicated objects, indicates the class of object
controller$init()
expect_output(summary(controller), "data.frame")
})
})
manipulateWidget/tests/testthat/test-mwGroup.R 0000644 0001762 0000144 00000003742 15126675445 021344 0 ustar ligges users context("Group of inputs")
describe("mwGroup", {
it("throws an error if an argument is not named", {
expect_error(mwGroup(mwText()), "All arguments need to be named.")
})
it("throws an error if an argument is not an input", {
expect_error(mwGroup(a = 1), "All arguments need to be Input objects.")
})
it("can be cloned", {
env1 <- initEnv(parent.frame(), 1)
env2 <- initEnv(parent.frame(), 2)
a <- mwText()
b <- mwText()
inner_grp = mwGroup(a = a)
grp <- mwGroup(inner_grp = inner_grp, b = b)
a$init("a", env1)
b$init("b", env1)
inner_grp$init("inner_grp", env1)
grp$init("grp", env1)
grp2 <- grp$clone(env2)
expect_equal(c("a", "b"), ls(envir = env2))
grp2$value$b$setValue("test")
expect_equal(grp2$value$b$value, "test")
expect_equal(get("b", envir = env2), "test")
expect_equal(get("b", envir = env1), "")
grp2$value$inner_grp$value$a$setValue("test")
expect_equal(grp2$value$inner_grp$value$a$value, "test")
expect_equal(get("a", envir = env2), "test")
expect_equal(get("a", envir = env1), "")
})
it("removes inner inputs from environment", {
env1 <- initEnv(parent.frame(), 1)
a <- mwText()
b <- mwText()
inner_grp = mwGroup(a = a)
grp <- mwGroup(inner_grp = inner_grp, b = b)
a$init("a", env1)
b$init("b", env1)
inner_grp$init("inner_grp", env1)
grp$init("grp", env1)
grp$destroy()
expect_true(!"a" %in% ls(envir = env1))
expect_true(!"b" %in% ls(envir = env1))
})
it("can return list of inner inputs", {
env1 <- initEnv(parent.frame(), 1)
a <- mwText()
b <- mwText()
inner_grp = mwGroup(a = a)
grp <- mwGroup(inner_grp = inner_grp, b = b)
a$init("a", env1)
b$init("b", env1)
inner_grp$init("inner_grp", env1)
grp$init("grp", env1)
inputs <- grp$getInputs()
expect_equal(sort(names(inputs)), c("a", "b", "grp", "inner_grp"))
expect_identical(inputs$a, a)
expect_identical(inputs$b, b)
})
})
manipulateWidget/tests/testthat/helper-input_class.R 0000644 0001762 0000144 00000002221 15126675445 022517 0 ustar ligges users test_input <- function(input, values = NULL, expectedValues = NULL, name = "myInput") {
describe(paste("input", input$type), {
it ("is correctly initialized", {
env <- initEnv(parent.frame(), 1)
input$init(name, env)
expect_initialized(input)
expect_equal(input$env, env)
expect_equal(input$label, name)
if(!"call" %in% class(input$value)){
expect_equal(input$value, get(name, envir = env))
} else {
expect_equal(evalValue(input$value, parent.frame()), get(name, envir = env))
}
expect_is(input$params, "list")
})
it ("sets valid values", {
for (i in seq_along(values)) {
input$setValue(values[[i]])
expect_equal(input$value, expectedValues[[i]])
expect_equal(get(name, envir = input$env), expectedValues[[i]])
}
})
})
}
expect_initialized <- function(input) {
expect_is(input, "Input")
expect(!emptyField(input$name) & !emptyField(input$env), "Input unitialized")
}
initAllInputs <- function(inputs, env) {
sapply(names(inputs), function(n) {
inputs[[n]]$init(n, env)
inputs[[n]]
}, simplify = FALSE, USE.NAMES = TRUE)
}
manipulateWidget/tests/testthat/test-get_output_and_render_func.R 0000644 0001762 0000144 00000001542 15126675445 025273 0 ustar ligges users context("getOutputAndRenderFunc")
describe("getOutputAndRenderFunc", {
if(require("leaflet")){
it ("returns output and render functions of a widget", {
widget <- leaflet()
res <- getOutputAndRenderFunc(widget)
expect_named(res, c("outputFunc", "renderFunc", "useCombineWidgets"))
expect_equal(res$outputFunc, leaflet::leafletOutput)
expect_equal(res$renderFunc, leaflet::renderLeaflet)
expect_equal(res$useCombineWidgets, FALSE)
})
it ("returns combineWidgets output and render functions if x is not an htmlwidget", {
res <- getOutputAndRenderFunc("test")
expect_named(res, c("outputFunc", "renderFunc", "useCombineWidgets"))
expect_equal(res$outputFunc, combineWidgetsOutput)
expect_equal(res$renderFunc, renderCombineWidgets)
expect_equal(res$useCombineWidgets, TRUE)
})
}
})
manipulateWidget/tests/testthat/test-input_env.R 0000644 0001762 0000144 00000021603 15126740555 021702 0 ustar ligges users context("initInputEnv")
# Helper function that checks the structure of the object returned by initInputEnv
# It returns the said object for further testing
test_structure <- function(inputs, compare = NULL, ncharts = 1) {
res <- initInputEnv(inputs, compare = compare, ncharts = ncharts)
#initAllInputs(inputs, initEnv(parent.frame(), 1))
inputList <- lapply(unname(inputs), function(input) input$getInputs())
inputList <- do.call(c, inputList)
expect_is(res, "InputEnv")
expect_named(res$getRefClass()$fields(), c("envs", "inputList", "ncharts", "hierarchy"))
expect_is(res$envs, "list")
expect_named(res$envs, c("shared", "ind"))
expect_is(res$envs$ind, "list")
expect_length(res$envs$ind, ncharts)
expect_is(res$inputList, "InputList")
expectedLength <- length(inputList) + length(compare) * (ncharts - 1)
# inexact when one tries to compare grouped inputs
expect_equal(nrow(res$inputList$inputTable), expectedLength)
sharedInputs <- setdiff(names(inputList), names(compare))
if (length(sharedInputs) == 0) expected_names <- c()
else expected_names <- paste0("shared_", sharedInputs)
if (length(compare) > 0) {
for (i in seq_len(ncharts)) {
expected_names <- append(
expected_names,
paste0("output_", i, "_", names(compare))
)
}
}
expect_true(all(expected_names %in% row.names(res$inputList$inputTable)))
res
}
describe("initInputEnv", {
it("generates correct structure", {
test_structure(list(a = mwText(), b = mwText()))
})
it("handles grouped inputs", {
test_structure(list(grp = mwGroup(a = mwText(), b = mwText())))
})
it("still works if ncharts > 1", {
test_structure(list(grp = mwGroup(a = mwText(), b = mwText())), ncharts = 2)
})
it("prepares inputs for comparison", {
test_structure(list(a = mwText(), b = mwText()), ncharts = 2,
compare = list(a = NULL))
})
it("prepares inputs for comparison with different initial values", {
res <- test_structure(list(a = mwText(), b = mwText()), ncharts = 2,
compare = list(a = c("a", "b")))
})
it("throws errors if inputs are not inputs or not named", {
expect_error(initInputEnv(list(mwText())), "All arguments need to be named.")
expect_error(initInputEnv(list(a = 1)), "All arguments need to be Input objects.")
})
})
describe("InputEnv Class", {
it ("shares an input", {
model <- test_structure(list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0)),
ncharts = 2, compare = list(x = list(5, 0), y = NULL))
model$inputList$init()
newInput <- model$shareInput("x")
expect_equal(newInput, "shared_x")
expect_silent(model$inputList$getInput("x", 0))
expect_null(model$inputList$getInput("y", 0), "cannot find input")
for (i in 1:2) {
expect_silent(model$inputList$getInput("y", i))
}
expect_equal(model$envs$shared$x, 5)
for (i in 1:2) {
expect_null(model$envs$ind[[i]]$x)
}
})
it ("unshares an input", {
model <- test_structure(list(a = mwText(), b = mwText("test")), ncharts = 2,
compare = list(a = NULL))
newInputs <- model$unshareInput("b")
expect_equal(newInputs, c("output_1_b", "output_2_b"))
expect_null(model$inputList$getInput("b", 0), "cannot find input")
for (i in 1:2) {
expect_silent(model$inputList$getInput("a", i))
expect_silent(model$inputList$getInput("b", i))
}
for (i in 1:2) {
expect_equal(model$envs$ind[[i]]$b, "test")
}
model$inputList$setValue("b", "test2", chartId = 1)
expect_equal(model$envs$ind[[1]]$b, "test2")
expect_equal(model$envs$ind[[2]]$b, "test")
})
it ("shares a group of inputs", {
model <- test_structure(list(grp = mwGroup(a = mwText(), b = mwText())),
ncharts = 2, compare = list(grp = NULL, a = NULL, b = NULL))
model$inputList$init()
newInput <- model$shareInput("grp")
expect_equal(sort(newInput), c("shared_a", "shared_b", "shared_grp"))
expect_silent(model$inputList$getInput("grp", 0))
expect_silent(model$inputList$getInput("a", 0))
expect_silent(model$inputList$getInput("b", 0))
expect_named(model$inputList$getInput("grp", 0)$value, c("a", "b"))
for (i in 1:2) {
expect_null(model$inputList$getInput(inputId = sprintf("output_%s_grp",i)), "cannot find input")
expect_null(model$inputList$getInput(inputId = sprintf("output_%s_grp",i)), "cannot find input")
expect_null(model$inputList$getInput(inputId = sprintf("output_%s_grp",i)), "cannot find input")
}
# Check environments
expect_true(exists("a", envir = model$envs$shared))
expect_true(exists("b", envir = model$envs$shared))
for (i in 1:2){
expect_false(exists("a", envir = model$envs$ind[[i]], inherits = FALSE))
expect_false(exists("b", envir = model$envs$ind[[i]], inherits = FALSE))
}
})
it ("unshares a group of inputs", {
model <- test_structure(list(grp = mwGroup(a = mwText(), b = mwText("test"))),
ncharts = 2)
newInputs <- model$unshareInput("grp")
expect_equal(
sort(newInputs),
c("output_1_a", "output_1_b", "output_1_grp", "output_2_a", "output_2_b", "output_2_grp")
)
expect_null(model$inputList$getInput("a", 0), "cannot find input")
expect_null(model$inputList$getInput("b", 0), "cannot find input")
expect_null(model$inputList$getInput("grp", 0), "cannot find input")
for (i in 1:2) {
expect_silent(model$inputList$getInput("a", i))
expect_silent(model$inputList$getInput("b", i))
expect_silent(model$inputList$getInput("grp", i))
}
expect_null(model$envs$shared$a)
expect_null(model$envs$shared$b)
for (i in 1:2) {
expect_equal(model$envs$ind[[i]]$b, "test")
}
model$inputList$setValue("b", "test2", chartId = 1)
expect_equal(model$envs$ind[[1]]$b, "test2")
expect_equal(model$envs$ind[[2]]$b, "test")
})
it ("ads a chart", {
model <- test_structure(list(a = mwText("test"), b = mwText()), ncharts = 1,
compare = list(a = NULL))
model$addChart()
expect_equal(model$ncharts, 2)
expect_length(model$envs$ind, 2)
for (i in 1:2) {
expect_equal(model$envs$ind[[i]]$a, "test")
expect_null(model$envs$ind[[i]]$b)
}
model$inputList$setValue("a", "test2", chartId = 1)
expect_equal(model$envs$ind[[1]]$a, "test2")
expect_equal(model$envs$ind[[2]]$a, "test")
model$inputList$setValue("b", "test3", chartId = 0)
expect_equal(get("b", envir = model$envs$ind[[1]]), "test3")
expect_equal(get("b", envir = model$envs$ind[[2]]), "test3")
})
it ("removes a chart", {
model <- test_structure(list(a = mwText("test"), b = mwText()), ncharts = 2,
compare = list(a = NULL))
model$removeChart()
expect_equal(model$ncharts, 1)
expect_length(model$envs$ind, 1)
expect_length(model$inputList$inputTable$input, 2)
expect_equal(row.names(model$inputList$inputTable), c("shared_b", "output_1_a"), ignore.order = TRUE)
})
it ("does not remove last chart", {
model <- test_structure(list(a = mwText("test"), b = mwText()), ncharts = 1,
compare = list(a = NULL))
expect_error(model$removeChart(), "at least one chart")
})
it ("ads many charts", {
model <- test_structure(list(a = mwText("test"), b = mwText()), ncharts = 2,
compare = list(a = NULL))
model$setChartNumber(4)
expect_equal(model$ncharts, 4)
expect_length(model$envs$ind, 4)
})
it ("removes many charts", {
model <- test_structure(list(a = mwText("test"), b = mwText()), ncharts = 4,
compare = list(a = NULL))
model$setChartNumber(2)
expect_equal(model$ncharts, 2)
expect_length(model$envs$ind, 2)
})
it ("unshares reverse dependencies", {
model <- test_structure(list(a = mwNumeric(10), b = mwSlider(0, a, 0)), ncharts = 2)
model$inputList$init()
new_inputs <- model$unshareInput("a")
expect_equal(sort(new_inputs), c("output_1_a", "output_1_b", "output_2_a", "output_2_b"))
})
it ("shares dependencies", {
model <- test_structure(list(a = mwNumeric(10), b = mwSlider(0, a, 0)), ncharts = 2,
compare = list(a = NULL, b = NULL))
model$inputList$init()
new_inputs <- model$shareInput("b")
expect_equal(sort(new_inputs), c("shared_a", "shared_b"))
})
it ("shares/unshares the whole group if the input is in a group", {
model <- test_structure(list(grp = mwGroup(a = mwNumeric(10), b = mwNumeric(0))),
ncharts = 2)
model$inputList$init()
new_inputs <- model$unshareInput("b")
expect_equal(sort(new_inputs), c("output_1_a", "output_1_b", "output_1_grp", "output_2_a", "output_2_b", "output_2_grp"))
new_inputs <- model$shareInput("b")
expect_equal(sort(new_inputs), c("shared_a", "shared_b", "shared_grp"))
})
})
manipulateWidget/tests/testthat.R 0000644 0001762 0000144 00000000114 15126675445 016715 0 ustar ligges users library(testthat)
library(manipulateWidget)
test_check("manipulateWidget")
manipulateWidget/MD5 0000644 0001762 0000144 00000012202 15131451072 014061 0 ustar ligges users b3bbdf62ad43c5edd8a375dc1e2cec89 *DESCRIPTION
cf47069209a8ee5e05e334b69c3deb13 *LICENSE
0df673bc2e37e025fef88121e3cc15ab *NAMESPACE
d39c3c9cd22c3f3992e27891b67da71f *NEWS.md
56fa0088906fbe907209475d8297ca14 *R/combine_widgets.R
5ab8cebcc5e8f114858cdf0c76695ab7 *R/compare_options.R
37aa859e9e937a93b12a133dbb8038df *R/controller.R
782063748c15e3b909d7ea6499ed418f *R/debug.R
278d0b07719be6ad62b80e1f2877fe80 *R/get_output_and_render_func.R
85b7d8b48d0f69bf42c85c336a39dd29 *R/get_row_and_cols.R
9433625cb5430524fbd4ba460ac51fbd *R/input_class.R
986e428a3b284ee3c9ee04166cc0e16a *R/input_env.R
ad0b857432c7297154a125b2a5cc18f4 *R/input_list_class.R
e84758e70f0cb952050846c26ced2c48 *R/inputs.R
77d56172c80f054bd45d9b79232f1075 *R/manipulate_widget.R
b114f8581f1bed2562f35397aeaacbb3 *R/module_ui.R
959d2fa8e1279865b7f907c4321e7759 *R/mw_ui.R
f9cd929f1340052a4017bf47bc5a43fb *R/on_done.R
96dd04b78f8b29227342b4444d29c913 *R/shiny_module.R
32e2c87955c0d64c45ca932e4c8fd961 *R/shiny_module_compare_inputs.R
a79fe9397be02b010ce207001c05fd7f *R/shiny_module_grid.R
942db85d21484b4853c8bb5c898bf717 *R/shiny_module_inputarea.R
635afcb1570d30380c487d8a6c6f1807 *R/shiny_module_menu.R
9cfa022f456931768485bd00c6edac01 *R/static_image.R
e45211223f71c0504218fd3204ee4ee8 *R/translations.R
f76be53feeb4b7910727fb10f0fef95a *R/zzz.R
7d21acb5b89f524555b2b53fb4a89449 *build/vignette.rds
bfc28e676131fdd069dbfe1fde2ac518 *data/worldEnergyUse.rda
e0e6cb900a3477e86d216bdf99fbde07 *inst/doc/manipulateWidgets.R
13d1131b8c9592c176c2120805657451 *inst/doc/manipulateWidgets.Rmd
c829e04e44bc56053209dd3fd9cad1a9 *inst/doc/manipulateWidgets.html
58bda3266ee4cb61246228098ec7d96c *inst/htmlwidgets/combineWidgets.css
4ffdfd9ca9f4f3529db7af42e819b189 *inst/htmlwidgets/combineWidgets.js
be45bfac471843443b2e9365edf3996c *inst/htmlwidgets/combineWidgets.yaml
2325e1bd4a8df90a1bd527f2f9434aa9 *inst/lib/export/Blob/Blob.js
9b4cad045b7a15092b9af8e815405679 *inst/lib/export/Blob/LICENSE.md
8514c12a6717d73a9ffac9c2f149cc8d *inst/lib/export/FileSaver/FileSaver.min.js
801a2f4454db848b1f24f8b26d58e0cc *inst/lib/export/FileSaver/LICENSE.md
51fcff22b1e2945995b78e42e4883c96 *inst/lib/export/canvas-toBlob/LICENSE.md
954816afab6c0b9578f067bd58b62cd9 *inst/lib/export/canvas-toBlob/canvas-toBlob.js
c83216a7533fcc62f682f751cfc2dace *inst/lib/export/html2canvas/html2canvas.js
e266af69be7bb2b9076730b797388097 *inst/manipulate_widget/manipulate_widget.css
1c6b17b20e519899af6fd0e887ebbd3f *inst/manipulate_widget/manipulate_widget.js
c6fc47b2ae315b6d8a00b48dfcd72a09 *man/MWController-class.Rd
5e57df157b79eaefb4758e43172864a3 *man/combineWidgets-shiny.Rd
90fe56c14713453416e86432e2158a99 *man/combineWidgets.Rd
5680d25e9718b0eebabe44074e9f9df7 *man/compareOptions.Rd
8e7b11ca3063dd72a1cae5752c291897 *man/knit_print.MWController.Rd
eb377ab8cd3b869aa7e5bc01125835d2 *man/manipulateWidget-package.Rd
b828a2799f8164646e444b8ad1971d80 *man/manipulateWidget.Rd
edd0f8a8975b9dd521118280768b4282 *man/mwCheckbox.Rd
a1e22f4c716bac6548be95ac4e51bb17 *man/mwCheckboxGroup.Rd
09c8cc8ab999f4abedc01bb583f69561 *man/mwDate.Rd
5f30e4e10f0506b472f09e148f978d81 *man/mwDateRange.Rd
433df2a0d7eff2cc2f32bcf335d5af8e *man/mwGroup.Rd
29c7a699e33b26f658002997b2850655 *man/mwModule.Rd
d41f7223ca2ac51965d3860f97f22549 *man/mwNumeric.Rd
463f962761461ba4186fa2a29d401f75 *man/mwPassword.Rd
1eb11a2a77f5f0ccfa8faf527d6c205b *man/mwRadio.Rd
c08d5bf647dbe12d7268ed7ca3a88ffa *man/mwSelect.Rd
5c84262871c85094947ae5bb10c018c2 *man/mwSelectize.Rd
5d36eb6ee7e689b549a2a4e28d1574e0 *man/mwSharedValue.Rd
77e9c018732b8177bced88f370b57886 *man/mwSlider.Rd
330e8fd11934c4c42b4fe46891164840 *man/mwText.Rd
b297a438e1f98aabb7c88ec41b4712d7 *man/mwTranslations.Rd
67c4c7c7ffb9241c814966659cab2af2 *man/staticPlot.Rd
08099b2d81f8c4f6908b4f1bff1f676d *man/summary.MWController.Rd
bcf078ffe3e343c9541499bc65315ead *man/worldEnergyUse.Rd
d5ca5ca5a3a97dbe372f38a7f4e0bdd1 *tests/testthat.R
cede36bc07bea6213decca5a5de99d8f *tests/testthat/helper-input_class.R
8107aace4d48f2451770d6ad1b5d5492 *tests/testthat/test-controller.R
c2e2831f781027f7d23b8bfd798d212b *tests/testthat/test-get_output_and_render_func.R
66c21fd089eae383ac76a4e22faf0acc *tests/testthat/test-input_class.R
f2ca1099eec8790298936ee33bf17ad6 *tests/testthat/test-input_env.R
da91c78c8ed517a3ac9519f953fde1d1 *tests/testthat/test-input_list_class.R
9c54a90ca61e8f8d84f4c092e0c14b85 *tests/testthat/test-inputs.R
3b4f945586bff888b203d2472bb7d980 *tests/testthat/test-manipulate_widget.R
f1b07ab193b58dc3967f14fa946aea69 *tests/testthat/test-mwGroup.R
347a8bba4f92697f370b982177deb2c0 *tests/testthat/test-mwModuleUI.R
a2d4f9a0851d339eaee52a3b8b22da92 *tests/testthat/test-on_done.R
f97ef87c219bed9b7113b605e8df1113 *tests/testthat/test-staticPlot.R
0e97ad53ba1d8d82d88ef7e501c8dbc6 *vignettes/comparison.gif
c2203716201b78320822c99a43f8cad0 *vignettes/conditional-inputs.gif
90573cae35642d3aff4dd8200f51649c *vignettes/dynamic_inputs.gif
e0465f5ea5803e1ad4c3a259af79d3c6 *vignettes/example-kmeans.gif
6699288b15bb11adb60ac07e37f42cf2 *vignettes/fancy-example.gif
34903874a13b53612735085e9b0d8ea5 *vignettes/groups-inputs.gif
13d1131b8c9592c176c2120805657451 *vignettes/manipulateWidgets.Rmd
b4be7112b4046521b3d8f4f21f24c702 *vignettes/update-widget.gif
manipulateWidget/R/ 0000755 0001762 0000144 00000000000 15126746410 013764 5 ustar ligges users manipulateWidget/R/on_done.R 0000644 0001762 0000144 00000001077 15126675445 015546 0 ustar ligges users #' Function called when user clicks on the "Done" button. It stops the shiny
#' gadget and returns the final htmlwidget
#'
#' @param .expr Expression that generates a htmlwidget
#' @param controls Object created with function preprocessControls
#'
#' @return a htmlwidget
#' @noRd
onDone <- function(controller, stopApp = TRUE) {
for (env in controller$envs$ind) {
assign(".initial", TRUE, envir = env)
assign(".session", NULL, envir = env)
}
controller$updateCharts()
res <- controller$returnCharts()
if (stopApp) shiny::stopApp(res)
else return(res)
}
manipulateWidget/R/shiny_module.R 0000644 0001762 0000144 00000002650 15126675445 016622 0 ustar ligges users mwModuleServer <- function(input, output, session, ctrl, ...) {
ns <- session$ns
ctrl <- ctrl$clone()
reactiveValueList <- list(...)
# If no reactive value, start immediately module.
# Else delay start until outer inputs are initialized.
if (length(reactiveValueList) == 0) startModule(ctrl)
else {
moduleStarted <- FALSE
observe({
for (n in names(reactiveValueList)) {
ctrl$setValue(n, reactiveValueList[[n]](), reactive = TRUE)
}
if (!moduleStarted) {
startModule(ctrl)
moduleStarted <<- TRUE
}
})
}
return(ctrl)
}
startModule <- function(ctrl) {
ctrl$init()
dim <- callModule(inputAreaModuleServer, "inputarea", chartId, ctrl)
ncharts <- reactive(dim$n)
nrow <- reactive(dim$nrow)
ncol <- reactive(dim$ncol)
displayIndBtns <- reactive(dim$displayIndBtns)
shinyGridEnv <- callModule(gridModuleServer, "grid", dim = dim, ctrl = ctrl)
ctrl$setShinySession(shinyGridEnv$output, shinyGridEnv$session)
menuState <- callModule(menuModuleServer, "menu", ncharts, nrow, ncol, displayIndBtns, ctrl)
chartId <- reactive(menuState()$chartId)
observe({
req(dim$n)
ctrl$setChartNumber(dim$n, dim$nrow, dim$ncol)
})
observeEvent(
menuState()$done,
onDone(ctrl)
)
observeEvent(
menuState()$update,
{
if(!is.null(menuState()$update) && menuState()$update > 0){
ctrl$updateCharts()
}
}
)
}
manipulateWidget/R/controller.R 0000644 0001762 0000144 00000025244 15126675445 016312 0 ustar ligges users #' Controller object of a manipulateWidget application
#'
#' @description
#' \code{MWController} is a reference class that is used to manage interaction
#' with data and update of the view created by manipulateWidget. Only users who
#' desire to create automatic tests for applications created with
#' \code{\link{manipulateWidget}} should care about this object.
#'
#' @section Testing a manipulateWidget application:
#' When \code{\link{manipulateWidget}} is used in a test script, it returns a
#' \code{MWController} object instead of starting a shiny gadget. This object has
#' methods to modify inputs values and check the state of the application. This
#' can be useful to automatically checks if your application behaves like desired.
#' Here is some sample code that uses package \code{testthat}:
#'
#' \preformatted{
#' library("testthat")
#'
#' controller <- manipulateWidget(
#' x + y,
#' x = mwSlider(0, 10, 5),
#' y = mwSlider(0, x, 0),
#' .compare = "y"
#' )
#'
#' test_that("Two charts are created", {
#' expect_equal(controller$ncharts, 2)
#' })
#'
#' test_that("Parameter 'max' of 'y' is updated when 'x' changes", {
#' expect_equal(controller$getParams("y", 1)$max, 5)
#' expect_equal(controller$getParams("y", 2)$max, 5)
#' controller$setValue("x", 3)
#' expect_equal(controller$getParams("y", 1)$max, 3)
#' expect_equal(controller$getParams("y", 2)$max, 3)
#' })
#'
#' }
#'
#' @field ncharts Number of charts in the application
#' @field nrow Number of rows.
#' @field ncol Number of columns.
#' @field autoUpdate Boolean indicating if charts should be automatically
#' updated when a value changes. list with \code{value} and \code{initBtn} (not autoUpdate, if want first charts on init)
#'
#' @export
MWController <- setRefClass(
"MWController",
fields = c("inputList", "uiSpec", "envs", "session", "shinyOutput", "expr", "ncharts", "charts",
"autoUpdate", "renderFunc", "outputFunc", "useCombineWidgets", "nrow", "ncol",
"returnFunc", "initialized", "listeners", "translations"),
methods = list(
initialize = function(expr, inputs, autoUpdate = list(value = TRUE, initBtn = FALSE,
saveBtn = TRUE, exportBtn = FALSE,
exportType = "html2canvas"),
nrow = NULL, ncol = NULL, returnFunc = function(widget, envs) {widget},
translations = mwTranslations()) {
expr <<- expr
inputList <<- inputs$inputList
uiSpec <<- inputs
ncharts <<- inputs$ncharts
envs <<- inputs$envs
autoUpdate <<- autoUpdate
outputFunc <<- NULL
renderFunc <<- NULL
session <<- NULL
shinyOutput <<- NULL
useCombineWidgets <<- FALSE
nrow <<- nrow
ncol <<- ncol
returnFunc <<- returnFunc
charts <<- list()
initialized <<- FALSE
listeners <<- character()
translations <<- translations
},
init = function() {
catIfDebug("Controller initialization")
if (!initialized) {
inputList$init()
updateCharts()
if (is.null(renderFunc) || is.null(outputFunc) || is.null(useCombineWidgets)) {
outputAndRender <- getOutputAndRenderFunc(charts[[1]])
renderFunc <<- outputAndRender$renderFunc
outputFunc <<- outputAndRender$outputFunc
useCombineWidgets <<- outputAndRender$useCombineWidgets
if (useCombineWidgets) {
charts <<- lapply(charts, combineWidgets)
}
}
initialized <<- TRUE
}
invisible(.self)
},
clear = function(){
rm(list = ls(envir = .self, all.names = TRUE), envir = .self, inherits = TRUE)
},
setShinySession = function(output, session) {
catIfDebug("Set shiny session")
session <<- session
shinyOutput <<- output
for (env in envs$ind) {
assign(".initial", FALSE, envir = env)
assign(".session", session, envir = env)
}
# also on shared env
assign(".initial", FALSE, envir = envs$shared)
assign(".session", session, envir = envs$shared)
for (i in 1:ncharts) {
renderShinyOutput(i)
}
},
setShinyInputSession = function(session) {
inputList$session <<- session
},
getValue = function(name, chartId = 1) {
"Get the value of a variable for a given chart."
inputList$getValue(name, chartId)
},
getValueById = function(id) {
inputList$getValue(inputId = id)
},
setValue = function(name, value, chartId = 1, updateHTML = FALSE, reactive = FALSE) {
"Update the value of a variable for a given chart."
oldValue <- getValue(name, chartId)
newValue <- inputList$setValue(name, value, chartId, reactive = reactive)
if (!initialized) return()
if (updateHTML && !identical(oldValue, newValue)) {
input <- inputList$getInput(name, chartId)
input$valueHasChanged <- TRUE
inputList$updateHTML()
}
if (autoUpdate$value && !identical(oldValue, newValue)) {
if (inputList$isShared(name)) updateCharts()
else updateChart(chartId)
}
},
setValueAll = function(name, value, updateHTML = TRUE) {
"Update the value of an input for all charts"
if (inputList$isShared(name)) {
setValue(name, value, chartId = 0, updateHTML = updateHTML)
} else {
for (i in seq_len(ncharts)) {
setValue(name, value, chartId = i, updateHTML = updateHTML)
}
}
},
setValueById = function(id, value) {
oldValue <- getValueById(id)
newValue <- inputList$setValue(inputId = id, value = value)
if (!initialized) return()
if (autoUpdate$value && !identical(oldValue, newValue)) {
if (grepl("^shared_", id)) updateCharts()
else {
chartId <- get(".id", envir = inputList$getInputById(id)$env)
updateChart(chartId)
}
}
},
getValues = function(chartId = 1) {
"Get all values for a given chart."
inputList$getValues(chartId)
},
getParams = function(name, chartId = 1) {
"Get parameters of an input for a given chart"
inputList$getInput(name, chartId)$getParams()
},
isVisible = function(name, chartId = 1) {
"Indicates if a given input is visible"
inputList$isVisible(name, chartId = chartId)
},
updateChart = function(chartId = 1) {
if(!is.null(envs)){
catIfDebug("Update chart", chartId)
# Create a new environment so that users can set values in expr without
# messing environments
e <- new.env(parent = envs$ind[[chartId]])
charts[[chartId]] <<- eval(expr, envir = e)
if (useCombineWidgets) {
charts[[chartId]] <<- combineWidgets(charts[[chartId]])
}
renderShinyOutput(chartId)
}
},
returnCharts = function() {
"Return all charts."
if (uiSpec$ncharts == 1) {
finalWidget <- charts[[1]]
} else {
finalWidget <- combineWidgets(list = charts[1:uiSpec$ncharts], nrow = nrow, ncol = ncol)
}
returnFunc(finalWidget, envs$ind)
},
show = function() {
if (!initialized) {
message("Nothing to display because controller has not been initialized. Use 'ctrl$init()' where 'ctrl' is the variable created with manipulateWidget()")
}
print(returnCharts())
},
updateCharts = function() {
"Update all charts."
for (i in seq_len(ncharts)) updateChart(i)
},
renderShinyOutput = function(chartId) {
if (!is.null(renderFunc) & !is.null(shinyOutput) &
is(charts[[chartId]], "htmlwidget")) {
catIfDebug("Render shiny output")
outputId <- get(".output", envir = envs$ind[[chartId]])
shinyOutput[[outputId]] <<- renderFunc(charts[[chartId]])
}
},
setChartNumber = function(n, nrow = NULL, ncol = NULL) {
if (n != ncharts) {
uiSpec$setChartNumber(n)
envs <<- uiSpec$envs
inputList <<- uiSpec$inputList
if (n > ncharts) {
for (i in (ncharts + 1):n) {
assign(".initial", TRUE, envir = envs$ind[[i]])
updateChart(i)
if (!is.null(session))
assign(".initial", FALSE, envir = envs$ind[[i]])
}
}
ncharts <<- n
}
nrow <<- nrow
ncol <<- ncol
},
clone = function(env = parent.frame()) {
res <- MWController(
expr,
uiSpec$clone(),
autoUpdate,
translations = translations
)
res$charts <- charts
res$nrow <- nrow
res$ncol <- ncol
res$outputFunc <- outputFunc
res$renderFunc <- renderFunc
res$useCombineWidgets <- useCombineWidgets
res$initialized <- initialized
res$inputList$initialized <- initialized
res
}
)
)
cloneEnv <- function(env, parentEnv = parent.env(env)) {
res <- as.environment(as.list(env, all.names = TRUE))
parent.env(res) <- parentEnv
res
}
#' knit_print method for MWController object
#'
#' @param x MWController object
#' @param ... arguments passed to function knit_print
#'
#' @export
knit_print.MWController <- function(x, ...) {
x$init()
knitr::knit_print(x$returnCharts(), ...)
}
#' summary method for MWController object
#'
#' @param object MWController object
#' @param ... Not use
#'
#' @export
summary.MWController <- function(object, ...) {
cat("Initialized :", object$initialized, "\n")
cat("Number of chart(s) :", object$ncharts, "\n")
cat("Number of row(s) :", object$nrow, "\n")
cat("Number of column(s) :", object$ncol, "\n")
cat("\nList of inputs : \n\n")
infos <- lapply(row.names(object$inputList$inputTable), function(n){
input <- object$inputList$getInputById(n)
if (is.atomic(input$value)) {
if (is.null(input$value)) value <- "NULL"
else if (length(input$value) == 0) value <- ""
else value <- paste(input$value, collapse = ", ")
} else {
if(is.call(input$value) | is.name(input$value)){
value <- evalValue(input$value, parent.frame())
if (is.null(value)) value <- sprintf("<%s>", class(input$value[1]))
else if (length(value) == 0) value <- ""
else value <- paste(value, collapse = ", ")
} else {
value <- sprintf("<%s>", class(input$value[1]))
}
}
chartId <- as.character(get(".id", envir = input$env))
if (chartId == "0") chartId <- "shared"
visible <- object$inputList$isVisible(inputId = n)
data.frame(inputId = n, type = input$type, variable = input$name,
chart = chartId, value = value, visible = visible,
stringsAsFactors = FALSE)
})
infos$stringsAsFactors <- FALSE
infos <- do.call(rbind, infos)
print(infos)
}
manipulateWidget/R/get_row_and_cols.R 0000644 0001762 0000144 00000001257 15126675445 017435 0 ustar ligges users # Copyright © 2016 RTE Réseau de transport d’électricité
# Private function that compute the "ideal" number of rows and columns given the
# number of widgets to display.
.getRowAndCols <- function(n, nrow = NULL, ncol = NULL) {
if (!is.null(nrow) && !is.null(ncol) && nrow * ncol < n) {
stop("There are too much widgets compared to the number of rows and columns")
} else if (is.null(nrow) && !is.null(ncol)) {
nrow <- ceiling(n / ncol)
} else if (!is.null(nrow) && is.null(ncol)) {
ncol <- ceiling(n / nrow)
} else if (is.null(nrow) && is.null(ncol)) {
nrow <- ceiling(sqrt(n))
ncol <- ceiling(n / nrow)
}
list(nrow = nrow, ncol = ncol, n = n)
}
manipulateWidget/R/combine_widgets.R 0000644 0001762 0000144 00000031001 15126675445 017255 0 ustar ligges users #Copyright © 2016 RTE Réseau de transport d’électricité
#' Combine several interactive plots
#'
#' This function combines different htmlwidgets in a unique view.
#'
#' @param ... htmlwidgets to combine. If this list contains objects that are not
#' htmlwidgets, the function tries to convert them into a character string which
#' is interpreted as html content.
#' @param list Instead of directly passing htmlwidgets to the function, one can
#' pass a list of htmlwidgets and objects coercible to character. In particular,
#' it can be usefull if multiple htmlwidgets have been generated using a loop
#' function like \code{\link[base]{lapply}}.
#' @param nrow Number of rows of the layout. If \code{NULL}, the function will
#' automatically take a value such that are at least as many cells in the
#' layout as the number of htmlwidgets.
#' @param ncol Number of columns of the layout.If \code{NULL}, the function will
#' automatically take a value such that are at least as many cells in the
#' layout as the number of htmlwidgets.
#' @param title Title of the view.
#' @param rowsize This argument controls the relative size of each row. For
#' instance, if the layout has two rows and \code{rowsize = c(2,1)}, then the
#' width of the first row will be twice the one of the second one. This
#' argument is recycled to fit the number of rows.
#' @param colsize Same as rowsize but for the height of the columns of the
#' layout.
#' @param byrow If \code{TRUE}, then the layout is filled by row. Else it is
#' filled by column.
#' @param titleCSS A character containing css properties to modify the
#' appearance of the title of the view.
#' @param header Content to display between the title and the combined widgets.
#' It can be a single character string or html tags.
#' @param footer Content to display under the combined widgets. It can be a
#' single character string or html tags.
#' @param leftCol Content to display on the left of the combined widgets. It can
#' be a single character string or html tags.
#' @param rightCol Content to display on the right the combined widgets. It can
#' be a single character string or html tags.
#'
#' @param width Total width of the layout (optional, defaults to automatic
#' sizing).
#' @param height Total height of the layout (optional, defaults to automatic
#' sizing).
#' @return A htmlwidget object of class \code{combineWidget}. Individual widgets
#' are stored in element \code{widgets} and can be extracted or updated. This
#' is useful when a function returns a \code{combineWidgets} object but user
#' wants to keep only one widget or to update one of them (see examples).
#'
#' @details The function only allows table like layout : each row has the same
#' number of columns and reciprocally. But it is possible to create more complex
#' layout by nesting combined htmlwidgets. (see examples)
#'
#' @examples
#' if (require(plotly)) {
#' data(iris)
#'
#' combineWidgets(title = "The Iris dataset",
#' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
#' plot_ly(iris, x = ~Sepal.Width, type = "histogram", nbinsx = 20),
#' plot_ly(iris, x = ~Petal.Length, type = "histogram", nbinsx = 20),
#' plot_ly(iris, x = ~Petal.Width, type = "histogram", nbinsx = 20)
#' )
#'
#' # Create a more complex layout by nesting combinedWidgets
#' combineWidgets(title = "The iris data set: sepals", ncol = 2, colsize = c(2,1),
#' plot_ly(iris, x = ~Sepal.Length, y = ~Sepal.Width, type = "scatter",
#' mode = "markers", color = ~Species),
#' combineWidgets(
#' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
#' plot_ly(iris, x = ~Sepal.Width, type = "histogram", nbinsx = 20)
#' )
#' )
#'
#' # combineWidgets can also be used on a single widget to easily add to it a
#' # title and a footer.
#' require(shiny)
#' comments <- tags$div(
#' "Wow this plot is so ",
#' tags$span("amazing!!", style = "color:red;font-size:36px")
#' )
#'
#' combineWidgets(
#' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
#' title = "Distribution of Sepal Length",
#' footer = comments
#' )
#'
#' # It is also possible to combine htmlwidgets with text or other html elements
#' myComment <- tags$div(
#' style="height:100%;background-color:#eee;padding:10px;box-sizing:border-box",
#' tags$h2("Comment"),
#' tags$hr(),
#' "Here is a very clever comment about the awesome graphics you just saw."
#' )
#' combineWidgets(
#' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
#' plot_ly(iris, x = ~Sepal.Width, type = "histogram", nbinsx = 20),
#' plot_ly(iris, x = ~Petal.Length, type = "histogram", nbinsx = 20),
#' myComment
#' )
#'
#' # Updating individual widgets.
#' myWidget <- combineWidgets(
#' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
#' plot_ly(iris, x = ~Sepal.Width, type = "histogram", nbinsx = 20),
#' ncol = 2
#' )
#' myWidget
#'
#'
#' myWidget$widgets[[1]] <- myWidget$widgets[[1]] %>%
#' layout(title = "Histogram of Sepal Length")
#'
#' myWidget$widgets[[2]] <- myWidget$widgets[[2]] %>%
#' layout(title = "Histogram of Sepal Width")
#'
#' myWidget
#'
#'
#' # Instead of passing directly htmlwidgets to the function, one can pass
#' # a list containing htmlwidgets. This is especially useful when the widgets
#' # are generated using a loop function like "lapply" or "replicate".
#' #
#' # The following code generates a list of 12 histograms and use combineWidgets
#' # to display them.
#' samples <- replicate(12, plot_ly(x = rnorm(100), type = "histogram", nbinsx = 20),
#' simplify = FALSE)
#' combineWidgets(list = samples, title = "12 samples of the same distribution")
#' }
#'
#' @export
#' @importFrom htmltools tagGetAttribute
combineWidgets <- function(..., list = NULL, nrow = NULL, ncol = NULL, title = NULL,
rowsize = 1, colsize = 1, byrow = TRUE,
titleCSS = "",
header = NULL, footer = NULL,
leftCol = NULL, rightCol = NULL,
width = NULL, height = NULL) {
widgets <- c(list(...), list)
if (length(widgets) == 0) return(combineWidgets(""))
# create empty widget
res <- htmlwidgets::createWidget(
name = 'combineWidgets',
x = NULL,
width = width,
height = height,
package = 'manipulateWidget',
sizingPolicy = htmlwidgets::sizingPolicy(
browser.fill = TRUE
),
preRenderHook = preRenderCombinedWidgets
)
# Add dependencies of embedded widgets or shiny tags
# This works through the widgets recursively, in case
# we were passed a shiny.tag.list or other list of
# non-widgets.
getDeps <- function(x) {
if (!is.null(attr(x, "package")))
append(tryCatch(getDependency(class(x)[1], attr(x, "package")),
error = function(e) NULL), x$dependencies)
else if (!is.null(attr(x, "html_dependencies")))
attr(x, "html_dependencies")
else if (is.list(x))
do.call(c, lapply(x, getDeps))
}
deps <- c(getDeps(widgets),
getDeps(header),
getDeps(footer),
getDeps(leftCol),
getDeps(rightCol))
res$dependencies <- deps
# Add widget list and parameters
res$widgets <- widgets
res$params <- list(
nrow = nrow,
ncol = ncol,
title = title,
rowsize = rowsize,
colsize = colsize,
byrow = byrow,
titleCSS = titleCSS,
header = header,
footer = footer,
leftCol = leftCol,
rightCol = rightCol,
width = width,
height = height
)
res
}
#' Shiny bindings for combineWidgets
#'
#' Output and render functions for using combineWidgets within Shiny
#' applications and interactive Rmd documents.
#'
#' @param outputId output variable to read from
#' @param width,height Must be a valid CSS unit (like \code{'100\%'},
#' \code{'400px'}, \code{'auto'}) or a number, which will be coerced to a
#' string and have \code{'px'} appended.
#' @param expr An expression that generates a combineWidgets
#' @param env The environment in which to evaluate \code{expr}.
#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
#' is useful if you want to save an expression in a variable.
#'
#' @name combineWidgets-shiny
#'
#' @export
combineWidgetsOutput <- function(outputId, width = '100%', height = '400px'){
htmlwidgets::shinyWidgetOutput(outputId, 'combineWidgets', width, height, package = 'manipulateWidget')
}
#' @rdname combineWidgets-shiny
#' @export
renderCombineWidgets <- function(expr, env = parent.frame(), quoted = FALSE) {
if (!quoted) { expr <- substitute(expr) } # force quoted
htmlwidgets::shinyRenderWidget(expr, combineWidgetsOutput, env, quoted = TRUE)
}
# Private function used to prerender a combinedWidgets object
preRenderCombinedWidgets <- function(x) {
hasCrosstalkInputs <- any(unlist(lapply(x$widgets, isCrosstalkInput)))
widgets <- lapply(unname(x$widgets), function(w) {
if (is.atomic(w)) return(structure(list(x = as.character(w)), class = "html"))
if (is.null(w$preRenderHook)) {
if (is(w, "htmlwidget")) return(w)
else return(structure(list(x = as.character(w)), class = "html"))
}
w$preRenderHook(w)
})
nwidgets <- length(x$widgets)
# Get number of rows and cols
dims <- .getRowAndCols(nwidgets, x$params$nrow, x$params$ncol)
nrow <- dims$nrow
ncol <- dims$ncol
ncells <- nrow * ncol
# Relative size of rows and cols
rowsize <- rep(x$params$rowsize, length.out = nrow)
colsize <- rep(x$params$colsize, length.out = ncol)
# Get the html ID of each widget
if (!is.null(names(x$widgets))) {
elementId <- names(x$widgets)
elementId[elementId == ""] <- "widget"
elementId <- make.unique(elementId)
} else {
elementId <- sapply(widgets[1:ncells], function(w) {
if (is.null(w)) res <- NULL
else res <- w$elementId
if (is.null(res)) res <- paste0("widget", floor(stats::runif(1, max = 1e9)))
res
})
}
# Get the HTML class for each widget, plus "cw-widget"
elementClass <- sapply(widgets[1:ncells], function(w) {
result <- NULL
if (inherits(w, "htmlwidget"))
result <- class(w)[1]
else if (inherits(w, "shiny.tag"))
result <- tagGetAttribute(w, "class")
paste(result, "cw-widget", "html-widget-static-bound")
})
# Construct the html of the combined widget
dirClass <- ifelse(x$params$byrow, "cw-by-row", "cw-by-col")
widgetEL <- mapply(
function(id, size, class) {
sprintf('
',
size, size, id, class)
},
id = elementId,
size = rep(colsize, length.out = ncells),
class = elementClass
)
rowsEl <- lapply(1:nrow, function(i) {
content <- widgetEL[((i-1) * ncol + 1):(i * ncol)]
sprintf('%s
',
dirClass, rowsize[i], rowsize[i], paste(content, collapse = ""))
})
content <- sprintf('%s
',
dirClass, paste(rowsEl, collapse = ""))
if(!is.null(x$params$title) && !x$params$title == "") {
titleEl <- sprintf('%s
',
x$params$titleCSS, x$params$title)
} else {
titleEl <- ""
}
if (is.null(x$params$footer)) footer <- ""
else footer <- paste0("", x$params$footer, "
")
if (is.null(x$params$header)) header <- ""
else header <- paste0("", x$params$header, "
")
if (is.null(x$params$leftCol)) leftCol <- ""
else leftCol <- paste0("", x$params$leftCol, "
")
if (is.null(x$params$rightCol)) rightCol <- ""
else rightCol <- paste0("", x$params$rightCol, "
")
html <- sprintf('',
titleEl, header, leftCol, content, rightCol, footer)
data <- lapply(widgets, function(w) w$x)
widgetType <- sapply(widgets, function(w) class(w)[1])
x$x <- list(data = data, widgetType = widgetType, elementId = elementId, html = html,
hasCrosstalkInputs = hasCrosstalkInputs);
x
}
# Check whether a widget is a crosstalk-package input, which will need special
# initialization within combineWidgets()
isCrosstalkInput <- function(w) {
inherits(w, "shiny.tag") &&
!is.null(w$attribs) &&
grepl("crosstalk-input", w$attribs$class)
}
manipulateWidget/R/inputs.R 0000644 0001762 0000144 00000053560 15126675445 015453 0 ustar ligges users #' Private function that converts ... in a list of expressions. This is
#' similar to "substitute" but for the dots argument.
#' @noRd
dotsToExpr <- function() {
eval(substitute(alist(...), parent.frame()))
}
#' Private function that generates functions that generate HTML corresponding
#' to a shiny input.
#'
#' @param func shiny function that generate the HTML of an input
#' @param valueArgName name of the parameter of 'func' corresponding to the
#' value of the input.
#'
#' @return
#' A function that takes arguments id, label, value, params and returns
#' shiny tag.
#' @noRd
htmlFuncFactory <- function(func, valueArgName = "value") {
function(id, label, value, params, ns = NULL) {
params$inputId <- id
params$label <- label
params[valueArgName] <- list(value)
do.call(func, params)
}
}
changeValueParam <- function(func, valueArgName) {
function(...) {
params <- list(...)
if ("value" %in% names(params)) {
params[[valueArgName]] <- params$value
params$value <- NULL
}
do.call(func, params)
}
}
#' Add a Slider to a manipulateWidget gadget
#'
#' @param min
#' The minimum value that can be selected.
#' @param max
#' The maximum value that can be selected.
#' @param value
#' Initial value of the slider A numeric vector of length one will create a
#' regular slider; a numeric vector of length two will create a double-ended
#' range slider
#' @param label
#' Display label for the control. If \code{NULL}, the name of the corresponding
#' variable is used.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{sliderInput}}
#' @param .display expression that evaluates to TRUE or FALSE, indicating when
#' the input control should be shown/hidden.
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#'
#' if (require(plotly)) {
#'
#' myWidget <- manipulateWidget(
#' plot_ly(data.frame(x = 1:n, y = rnorm(n)), x=~x, y=~y, type = "scatter", mode = "markers"),
#' n = mwSlider(1, 100, 10, label = "Number of values")
#' )
#'
#' Sys.sleep(0.5)
#'
#' # Create a double ended slider to choose a range instead of a single value
#' mydata <- data.frame(x = 1:100, y = rnorm(100))
#'
#' manipulateWidget(
#' plot_ly(mydata[n[1]:n[2], ], x=~x, y=~y, type = "scatter", mode = "markers"),
#' n = mwSlider(1, 100, c(1, 10), label = "Number of values")
#' )
#'
#' }
#'
#' @export
#' @family controls
mwSlider <- function(min, max, value, label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
params$min <- as.expression(substitute(min))
params$max <- as.expression(substitute(max))
value <- substitute(value)
Input(
type = "slider", value = value, label = label, params = params,
display = as.expression(substitute(.display)),
validFunc = function(x, params) {
if (is.null(x) || all(is.na(x))) return(c(params$min, params$max))
pmin(pmax(params$min, x, na.rm = TRUE), params$max, na.rm = TRUE)
},
htmlFunc = htmlFuncFactory(function(...) {
tags$div(style = "padding:0 5px;", shiny::sliderInput(...))
}),
htmlUpdateFunc = shiny::updateSliderInput
)
}
#' Add a text input to a manipulateWidget gadget
#'
#' @param value
#' Initial value of the text input.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{textInput}}
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#' if (require(plotly)) {
#' mydata <- data.frame(x = 1:100, y = rnorm(100))
#' manipulateWidget({
#' plot_ly(mydata, x=~x, y=~y, type = "scatter", mode = "markers") %>%
#' layout(title = mytitle)
#' },
#' mytitle = mwText("Awesome title !")
#' )
#' }
#'
#' @export
#' @family controls
mwText <- function(value = "", label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
value <- substitute(value)
Input(
type = "text", value = value, label = label, params = params,
display = as.expression(substitute(.display)),
validFunc = function(x, params) {
if(length(x) == 0) return("")
as.character(x)[1]
},
htmlFunc = htmlFuncFactory(shiny::textInput),
htmlUpdateFunc = shiny::updateTextInput
)
}
#' Add a numeric input to a manipulateWidget gadget
#'
#' @param value
#' Initial value of the numeric input.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{numericInput}}
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#'
#' if (require(plotly)) {
#' manipulateWidget({
#' plot_ly(data.frame(x = 1:10, y = rnorm(10, mean, sd)), x=~x, y=~y,
#' type = "scatter", mode = "markers")
#' },
#' mean = mwNumeric(0),
#' sd = mwNumeric(1, min = 0, step = 0.1)
#' )
#' }
#'
#' @export
#' @family controls
mwNumeric <- function(value, label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
value <- substitute(value)
Input(
type = "numeric", value = value, label = label, params = params,
display = as.expression(substitute(.display)),
validFunc = function(x, params) {
if (is.null(x) || !is.numeric(x)) return(NULL)
min(max(params$min, x), params$max)
},
htmlFunc = htmlFuncFactory(shiny::numericInput),
htmlUpdateFunc = shiny::updateNumericInput
)
}
#' Add a password to a manipulateWidget gadget
#'
#' @param value
#' Default value of the input.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{passwordInput}}
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#' if (require(plotly)) {
#' manipulateWidget(
#' {
#' if (passwd != 'abc123') {
#' plot_ly(type = "scatter", mode="markers") %>%
#' layout(title = "Wrong password. True password is 'abc123'")
#' } else {
#' plot_ly(data.frame(x = 1:10, y = rnorm(10)), x=~x, y=~y, type = "scatter", mode = "markers")
#' }
#' },
#' user = mwText(label = "Username"),
#' passwd = mwPassword(label = "Password")
#' )
#' }
#'
#' @export
#' @family controls
mwPassword <- function(value = "", label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
value <- substitute(value)
Input(
type = "password", value = value, label = label, params = params,
display = as.expression(substitute(.display)),
validFunc = function(x, params) {
if(length(x) == 0) return("")
as.character(x)[1]
},
htmlFunc = htmlFuncFactory(shiny::passwordInput),
htmlUpdateFunc = shiny::updateTextInput
)
}
#' Add a Select list input to a manipulateWidget gadget
#'
#' @param choices
#' Vector or list of choices. If it is named, then the names rather than the
#' values are displayed to the user.
#' @param value
#' Initial value of the input. If not specified, the first choice is used.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{selectInput}}.
#' @param multiple
#' Is selection of multiple items allowed?
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#' if (require(plotly)) {
#' mydata <- data.frame(x = 1:100, y = rnorm(100))
#'
#' manipulateWidget(
#' {
#' mode <- switch(type, points = "markers", lines = "lines", both = "markers+lines")
#' plot_ly(mydata, x=~x, y=~y, type = "scatter", mode = mode)
#' },
#' type = mwSelect(c("points", "lines", "both"))
#' )
#'
#' Sys.sleep(0.5)
#'
#' # Select multiple values
#' manipulateWidget(
#' {
#' if (length(species) == 0) mydata <- iris
#' else mydata <- iris[iris$Species %in% species,]
#'
#' plot_ly(mydata, x = ~Sepal.Length, y = ~Sepal.Width,
#' color = ~droplevels(Species), type = "scatter", mode = "markers")
#' },
#' species = mwSelect(levels(iris$Species), multiple = TRUE)
#' )
#' }
#'
#' @export
#' @family controls
mwSelect <- function(choices = value, value = NULL, label = NULL, ...,
multiple = FALSE, .display = TRUE) {
params <- dotsToExpr()
params$choices <- substitute(choices)
params$multiple <- substitute(multiple)
value <- substitute(value)
Input(
type = "select", value = value, label = label, params = params,
display = as.expression(substitute(.display)),
validFunc = function(x, params) {
x <- intersect(x, unlist(params$choices))
if (params$multiple) return(x)
else if (length(x) > 0) return(x[1])
else return(params$choices[[1]])
},
htmlFunc = htmlFuncFactory(shiny::selectInput, "selected"),
htmlUpdateFunc = changeValueParam(shiny::updateSelectInput, "selected")
)
}
#' Add a Select list input to a manipulateWidget gadget
#'
#' @param choices
#' Vector or list of choices. If it is named, then the names rather than the
#' values are displayed to the user.
#' @param value
#' Initial value of the input. If not specified, the first choice is used.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{selectInput}}.
#' @param multiple
#' Is selection of multiple items allowed?
#' @param options
#' A list of options. See the documentation of selectize.js for possible options
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#' if (require(plotly)) {
#' mydata <- data.frame(x = 1:100, y = rnorm(100))
#'
#' # Select multiple values
#' manipulateWidget(
#' {
#' if (length(species) == 0) mydata <- iris
#' else mydata <- iris[iris$Species %in% species,]
#'
#' plot_ly(mydata, x = ~Sepal.Length, y = ~Sepal.Width,
#' color = ~droplevels(Species), type = "scatter", mode = "markers")
#' },
#' species = mwSelectize(c("Select one or two species : " = "", levels(iris$Species)),
#' multiple = TRUE, options = list(maxItems = 2))
#' )
#' }
#'
#' @export
#' @family controls
mwSelectize <- function(choices = value, value = NULL, label = NULL, ...,
multiple = FALSE, options = NULL, .display = TRUE) {
params <- dotsToExpr()
params$choices <- substitute(choices)
params$multiple <- substitute(multiple)
params$options <- substitute(options)
value <- substitute(value)
Input(
type = "select", value = value, label = label, params = params,
display = as.expression(substitute(.display)),
validFunc = function(x, params) {
x <- intersect(x, unlist(params$choices))
if (params$multiple) return(x)
else if (length(x) > 0) return(x[1])
else return(params$choices[[1]])
},
htmlFunc = htmlFuncFactory(shiny::selectizeInput, "selected"),
htmlUpdateFunc = changeValueParam(shiny::updateSelectizeInput, "selected")
)
}
#' Add a checkbox to a manipulateWidget gadget
#'
#' @param value
#' Initial value of the input.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{checkboxInput}}
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#'
#' if(require(plotly)) {
#' manipulateWidget(
#' {
#' plot_ly(iris, x = ~Sepal.Length, y = ~Sepal.Width,
#' color = ~Species, type = "scatter", mode = "markers") %>%
#' layout(showlegend = legend)
#' },
#' legend = mwCheckbox(TRUE, "Show legend")
#' )
#' }
#'
#' @export
#' @family controls
mwCheckbox <- function(value = FALSE, label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
value <- substitute(value)
Input(
type = "checkbox", value = value, label = label, params = params,
display = as.expression(substitute(.display)),
validFunc = function(x, params) {
if (is.null(x)) return(FALSE)
x <- as.logical(x)
if (is.na(x)) x <- FALSE
x
},
htmlFunc = htmlFuncFactory(shiny::checkboxInput),
htmlUpdateFunc = shiny::updateCheckboxInput
)
}
#' Add radio buttons to a manipulateWidget gadget
#'
#' @param choices
#' Vector or list of choices. If it is named, then the names rather than the
#' values are displayed to the user.
#' @param value
#' Initial value of the input. If not specified, the first choice is used.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{radioButtons}}
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#' if (require(plotly)) {
#' mydata <- data.frame(x = 1:100, y = rnorm(100))
#'
#' manipulateWidget(
#' {
#' mode <- switch(type, points = "markers", lines = "lines", both = "markers+lines")
#' plot_ly(mydata, x=~x, y=~y, type = "scatter", mode = mode)
#' },
#' type = mwRadio(c("points", "lines", "both"))
#' )
#' }
#'
#' @export
#' @family controls
mwRadio <- function(choices, value = NULL, label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
params$choices <- substitute(choices)
value <- substitute(value)
Input(
type = "radio", value = value, label = label, params = params,
display = as.expression(substitute(.display)),
validFunc = function(x, params) {
if (length(params$choices) == 0) return(NULL)
if (is.null(x) || !x %in% unlist(params$choices)) return(params$choices[[1]])
x
},
htmlFunc = htmlFuncFactory(shiny::radioButtons, valueArgName = "selected"),
htmlUpdateFunc = changeValueParam(shiny::updateRadioButtons, "selected")
)
}
#' Add a date picker to a manipulateWidget gadget
#'
#' @param value
#' Default value of the input.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{dateInput}}
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#' if (require(dygraphs) && require(xts)) {
#' mydata <- xts(rnorm(365), order.by = as.Date("2017-01-01") + 0:364)
#'
#' manipulateWidget(
#' dygraph(mydata) %>% dyEvent(date, "Your birthday"),
#' date = mwDate("2017-03-27", label = "Your birthday date",
#' min = "2017-01-01", max = "2017-12-31")
#' )
#' }
#'
#' @export
#' @family controls
mwDate <- function(value = NULL, label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
value <- substitute(value)
Input(
type = "date", value = value, label = label, params = params,
display = as.expression(substitute(.display)),
validFunc = function(x, params) {
if (length(x) == 0) x <- Sys.Date()
x <- as.Date(x)
if (!is.null(params$min)) params$min <- as.Date(params$min)
if (!is.null(params$max)) params$max <- as.Date(params$max)
x <- min(max(x, params$min), params$max)
},
htmlFunc = htmlFuncFactory(shiny::dateInput),
htmlUpdateFunc = shiny::updateDateInput
)
}
#' Add a date range picker to a manipulateWidget gadget
#'
#' @param value
#' Vector containing two dates (either Date objects pr a string in yyy-mm-dd
#' format) representing the initial date range selected.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{dateRangeInput}}
#' @inheritParams mwSlider
#'
#' @return
#' An Input object
#'
#' @examples
#' if (require(dygraphs) && require(xts)) {
#' mydata <- xts(rnorm(365), order.by = as.Date("2017-01-01") + 0:364)
#'
#' manipulateWidget(
#' dygraph(mydata) %>% dyShading(from=period[1], to = period[2], color = "#CCEBD6"),
#' period = mwDateRange(c("2017-03-01", "2017-04-01"),
#' min = "2017-01-01", max = "2017-12-31")
#' )
#' }
#'
#' @export
#' @family controls
mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ...,
.display = TRUE) {
params <- dotsToExpr()
value <- substitute(value)
Input(
type = "dateRange", value = value, label = label, params = params,
display = as.expression(substitute(.display)),
validFunc = function(x, params) {
if (length(x) == 0) x <- c(Sys.Date(), Sys.Date())
else if (length(x) == 1) x <- c(x, Sys.Date())
x <- as.Date(x)
x[is.na(x)] <- Sys.Date()
if (!is.null(params$min)) {
params$min <- as.Date(params$min)
if(x[1] == Sys.Date()){
x[1] <- params$min
}
}
if (!is.null(params$max)) {
params$max <- as.Date(params$max)
if(x[2] == Sys.Date()){
x[2] <- params$max
}
}
x <- sapply(x, function(d) min(max(d, params$min), params$max))
as.Date(x, origin = "1970-01-01")
},
htmlFunc = function(id, label, value, params, ns) {
params$inputId <- id
params$label <- label
params$start <- value[[1]]
params$end <- value[[2]]
do.call(shiny::dateRangeInput, params)
},
htmlUpdateFunc = function(...) {
params <- list(...)
if ("value" %in% names(params)) {
params$start <- params$value[[1]]
params$end <- params$value[[2]]
params$value <- NULL
}
do.call(shiny::updateDateRangeInput, params)
}
)
}
#' Add a group of checkboxes to a manipulateWidget gadget
#'
#' @param choices
#' Vector or list of choices. If it is named, then the names rather than the
#' values are displayed to the user.
#' @param value
#' Vector containing the values initially selected
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{checkboxGroupInput}}
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#' if (require(plotly)) {
#' manipulateWidget(
#' {
#' if (length(species) == 0) mydata <- iris
#' else mydata <- iris[iris$Species %in% species,]
#'
#' plot_ly(mydata, x = ~Sepal.Length, y = ~Sepal.Width,
#' color = ~droplevels(Species), type = "scatter", mode = "markers")
#' },
#' species = mwCheckboxGroup(levels(iris$Species))
#' )
#' }
#'
#' @export
#' @family controls
mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
params$choices <- substitute(choices)
value <- substitute(value)
Input(
type = "checkboxGroup", value = value, label = label, params = params,
display = as.expression(substitute(.display)),
validFunc = function(x, params) {
intersect(x, unlist(params$choices))
},
htmlFunc = htmlFuncFactory(shiny::checkboxGroupInput, "selected"),
htmlUpdateFunc = changeValueParam(shiny::updateCheckboxGroupInput, "selected")
)
}
#' Shared Value
#'
#' This function creates a virtual input that can be used to store a dynamic
#' shared variable that is accessible in inputs as well as in output.
#'
#' @param expr Expression used to compute the value of the input.
#'
#' @return An Input object of type "sharedValue".
#'
#' @examples
#'
#' if (require(plotly)) {
#' # Plot the characteristics of a car and compare with the average values for
#' # cars with same number of cylinders.
#' # The shared variable 'subsetCars' is used to avoid subsetting multiple times
#' # the data: this value is updated only when input 'cylinders' changes.
#' colMax <- apply(mtcars, 2, max)
#'
#' plotCar <- function(cardata, carName) {
#' carValues <- unlist(cardata[carName, ])
#' carValuesRel <- carValues / colMax
#'
#' avgValues <- round(colMeans(cardata), 2)
#' avgValuesRel <- avgValues / colMax
#'
#' plot_ly() %>%
#' add_bars(x = names(cardata), y = carValuesRel, text = carValues,
#' hoverinfo = c("x+text"), name = carName) %>%
#' add_bars(x = names(cardata), y = avgValuesRel, text = avgValues,
#' hoverinfo = c("x+text"), name = "average") %>%
#' layout(barmode = 'group')
#' }
#'
#' c <- manipulateWidget(
#' plotCar(subsetCars, car),
#' cylinders = mwSelect(c("4", "6", "8")),
#' subsetCars = mwSharedValue(subset(mtcars, cylinders == cyl)),
#' car = mwSelect(choices = row.names(subsetCars))
#' )
#' }
#'
#' @export
#' @family controls
mwSharedValue <- function(expr = NULL) {
params <- list(expr = substitute(expr))
params$dynamic <- is.language(params$expr)
if (!params$dynamic) value <- params$expr
else value <- NULL
Input(
type = "sharedValue", value = value, label = NULL, params = params,
display = FALSE,
validFunc = function(x, params) {
if(params$dynamic) params$expr
else x
}
)
}
#' Group inputs in a collapsible box
#'
#' This function generates a collapsible box containing inputs. It can be useful
#' when there are a lot of inputs and one wants to group them.
#'
#' @param ... inputs that will be grouped in the box
#' @param .display expression that evaluates to TRUE or FALSE, indicating when
#' the group should be shown/hidden.
#' @param label label of the group inputs
#' @return Input of type "group".
#'
#' @examples
#' if(require(dygraphs)) {
#' mydata <- data.frame(x = 1:100, y = rnorm(100))
#' manipulateWidget(
#' dygraph(mydata[range[1]:range[2], ],
#' main = title, xlab = xlab, ylab = ylab),
#' range = mwSlider(1, 100, c(1, 100)),
#' "Graphical parameters" = mwGroup(
#' title = mwText("Fictive time series"),
#' xlab = mwText("X axis label"),
#' ylab = mwText("Y axis label")
#' )
#' )
#' }
#'
#' @export
#' @family controls
mwGroup <- function(..., label = NULL, .display = TRUE) {
inputs <- list(...)
if (is.null(names(inputs))) stop("All arguments need to be named.")
for (i in inputs) if (!inherits(i, "Input")) stop("All arguments need to be Input objects.")
Input(
type = "group", value = list(...), params = list(),
label = label, display = as.expression(substitute(.display)),
htmlFunc = function(id, label, value, params, ns) {
htmlElements <- lapply(value, function(x) x$getHTML(ns))
tags$div(
class="panel panel-default",
tags$div(
class="panel-heading collapsed",
style = "cursor: pointer;",
"data-toggle"="collapse",
"data-target"=paste0("#panel-body-", id),
tags$table(
tags$tbody(
tags$tr(
tags$td(class = "arrow"),
tags$td(label)
)
)
)
),
tags$div(
class="panel-body collapse",
id=paste0("panel-body-", id),
shiny::tagList(htmlElements)
)
)
}
)
}
manipulateWidget/R/static_image.R 0000644 0001762 0000144 00000003700 15126675445 016551 0 ustar ligges users #' Include a static image in a combinedWidgets
#'
#' \code{staticPlot} is a function that generates a static plot and then return
#' the HTML code needed to include the plot in a combinedWidgets.
#' \code{staticImage} is a more general function that generates the HTML code
#' necessary to include any image file.
#'
#' @param expr Expression that creates a static plot.
#' @param width Width of the image to create.
#' @param height Height of the image to create.
#' @param file path of the image to include.
#' @param style CSS style to apply to the image.
#'
#' @return a \code{shiny.tag} object containing the HTML code required to include
#' the image or the plot in a \code{combinedWidgets} object.
#'
#' @examples
#' staticPlot(hist(rnorm(100)))
#'
#' if (require(plotly)) {
#' data(iris)
#'
#' combineWidgets(
#' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
#' staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300)
#' )
#'
#' # You can also embed static images in the header, footer, left or right
#' # columns of a combinedWidgets. The advantage is that the space allocated
#' # to the static plot will be constant when the window is resized.
#'
#' combineWidgets(
#' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
#' footer = staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300)
#' )
#' }
#'
#' @importFrom grDevices dev.off png
#' @export
staticPlot <- function(expr, width = 600, height = 400) {
expr <- substitute(expr)
file <- tempfile(fileext = ".png")
png(file, width, height)
eval(expr, envir = parent.frame())
dev.off()
staticImage(file)
}
#' @rdname staticPlot
#' @export
#'
staticImage <- function(file, style = "max-width:100%%;max-height:100%%") {
data <- base64enc::base64encode(readBin(file, "raw", file.info(file)[1, "size"]))
ext <- tools::file_ext(file)
tags$img(
src = sprintf("data:image/%s;base64,%s", ext, data),
style = style
)
}
manipulateWidget/R/compare_options.R 0000644 0001762 0000144 00000003471 15126675445 017326 0 ustar ligges users #' Options for comparison mode
#'
#' This function generates a list of options that are used by
#' \code{\link{manipulateWidget}} to compare multiple charts.
#'
#' @param ncharts Number of charts to generate.
#' @param nrow Number of rows. If \code{NULL}, the function tries to pick the
#' best number of rows given the number of charts and columns.
#' @param ncol Number of columns. If \code{NULL}, the function tries to pick the
#' best number of columns given the number of charts and rows.
#' @param allowCompare If \code{TRUE} (the default), then the user can use the
#' UI to add or remove charts and choose which variables to compare
#'
#' @return List of options
#'
#' @examples
#' if (require(dygraphs)) {
#'
#' mydata <- data.frame(
#' year = 2000+1:100,
#' series1 = rnorm(100),
#' series2 = rnorm(100),
#' series3 = rnorm(100)
#' )
#' manipulateWidget(
#' dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title),
#' range = mwSlider(2001, 2100, c(2001, 2100)),
#' series = mwSelect(c("series1", "series2", "series3")),
#' title = mwText("Fictive time series"),
#' .compare = list(title = NULL, series = NULL),
#' .compareOpts = compareOptions(ncharts = 4)
#' )
#'
#' manipulateWidget(
#' dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title),
#' range = mwSlider(2001, 2100, c(2001, 2100)),
#' series = mwSelect(c("series1", "series2", "series3")),
#' title = mwText("Fictive time series"),
#' .compare = list(title = NULL, series = NULL),
#' .compareOpts = compareOptions(ncharts = 3, nrow = 3)
#' )
#' }
#'
#' @export
compareOptions <- function(ncharts = NULL, nrow = NULL, ncol = NULL, allowCompare = TRUE) {
list(
ncharts = ncharts,
nrow = nrow,
ncol = ncol,
allowCompare = allowCompare
)
}
manipulateWidget/R/get_output_and_render_func.R 0000644 0001762 0000144 00000001726 15126675445 021521 0 ustar ligges users #' Private function that gets shiny output and render functions for a given htmlWidget
#'
#' @param x Object, generally a htmlwidget.
#'
#' @return A list with the following elements
#' - outputFunc
#' - renderFunc
#' - useCombineWidgets TRUE only if x is not an htmlwidget
#' @noRd
getOutputAndRenderFunc <- function(x) {
# Get shiny output and render functions
if (inherits(x, "htmlwidget")) {
cl <- class(x)
pkg <- attr(x, "package")
renderFunName <- ls(getNamespace(pkg), pattern = "^render")
renderFunction <- getFromNamespace(renderFunName, pkg)
outputFunName <- ls(getNamespace(pkg), pattern = "Output$")
outputFunction <- getFromNamespace(outputFunName, pkg)
useCombineWidgets <- FALSE
} else {
renderFunction <- renderCombineWidgets
outputFunction <- combineWidgetsOutput
useCombineWidgets <- TRUE
}
list(
outputFunc = outputFunction,
renderFunc = renderFunction,
useCombineWidgets = useCombineWidgets
)
}
manipulateWidget/R/zzz.R 0000644 0001762 0000144 00000012302 15126675445 014753 0 ustar ligges users # Copyright © 2016 RTE Réseau de transport d’électricité
#' @name manipulateWidget-package
#'
#' @title Add even more interactivity to interactive charts
#'
#' @description
#' This package is largely inspired by the \code{manipulate} package from
#' Rstudio. It can be used to easily create graphical interface that let the
#' user modify the data or the parameters of an interactive chart. It also
#' provides the \code{\link{combineWidgets}} function to easily combine multiple
#' interactive charts in a single view.
#'
#' @details
#' \code{\link{manipulateWidget}} is the main function of the package. It
#' accepts an expression that generates an interactive chart (and more precisely
#' an \code{htmlwidget} object. See \url{http://www.htmlwidgets.org/} if you
#' have never heard about it) and a set of controls created with functions
#' \code{mwSlider}, \code{mwCheckbox}... which are used to dynamically change
#' values within the expression. Each time the user modifies the value of a
#' control, the expression is evaluated again and the chart is updated. Consider
#' the following code:
#'
#' \code{manipulateWidget(myPlotFun(country), country = mwSelect(c("BE", "DE", "ES", "FR")))}
#'
#' It will generate a graphical interface with a select input on its left with
#' options "BE", "DE", "ES", "FR". By default, at the beginning the value of the
#' variable \code{country} will be equal to the first choice of the
#' corresponding input. So the function will first execute
#' \code{myPlotFun("BE")} and the result will be displayed in the main panel of
#' the interface. If the user changes the value to "FR", then the expression
#' \code{myPlotFun("FR")} is evaluated and the new result is displayed.
#'
#' The interface also contains a button "Done". When the user clicks on it, the
#' last chart is returned. It can be stored in a variable, be modified by the
#' user, saved as a html file with \code{\link[htmlwidgets]{saveWidget}} from package
#' \code{htmlwidgets} or converted to a static image file with package
#' \code{webshot}.
#'
#' Finally one can easily create complex layouts thanks to function
#' \code{\link{combineWidgets}}. For instance, assume we want to see a map that
#' displays values of some variable for a given year, but on its right side we also
#' want to see the distributions of three variables. Then we could write:
#'
#' \preformatted{
#' myPlotFun <- function(year, variable) {
#' combineWidgets(
#' ncol = 2, colSize = c(3, 1),
#' myMap(year, variable),
#' combineWidgets(
#' ncol = 1,
#' myHist(year, "V1"),
#' myHist(year, "V2"),
#' myHist(year, "V3"),
#' )
#' )
#' }
#'
#' manipulateWidget(
#' myPlotFun(year, variable),
#' year = mwSlider(2000, 2016, value = 2000),
#' variable = mwSelect(c("V1", "V2", "V3"))
#' )
#' }
#'
#' Of course, \code{\link{combineWidgets}} can be used outside of
#' \code{\link{manipulateWidget}}. For instance, it can be used in an
#' Rmarkdown document to easily put together interactive charts.
#'
#' For more concrete examples of usage, you should look at the documentation and
#' especially the examples of \code{\link{manipulateWidget}} and
#' \code{\link{combineWidgets}}.
#'
#' @seealso \code{\link{manipulateWidget}}, \code{\link{combineWidgets}}
#'
#' @rdname manipulateWidget-package
#' @docType package
#' @importFrom shiny tags observe observeEvent reactive isolate icon tagAppendChild
#' @importFrom shiny tagAppendChildren fillPage fillRow NS uiOutput checkboxInput
#' callModule reactiveVal reactiveValues renderUI req updateSelectInput updateTextInput
#' @importFrom miniUI miniContentPanel miniPage miniTabPanel miniTabstripPanel gadgetTitleBar
#' @importFrom htmlwidgets getDependency
#' @importFrom methods is new setRefClass
#' @importFrom utils getFromNamespace
#' @importFrom stats runif
NULL
#' Evolution of energy use per country
#'
#' Data.frame containing energy consumption per country from 1960 to 2014. The
#' data comes from the World Bank website. It contains one line per
#' couple(country, year) and has the following columns:
#'
#' \itemize{
#' \item country Country name
#' \item iso2c Country code in two characters
#' \item year Year
#' \item population Population of the country
#' \item energy_used_per_capita Energy used per capita in kg of oil equivalent (EG.USE.PCAP.KG.OE)
#' \item energy_imported_prop Proportion of energy used that has been imported (EG.IMP.CONS.ZS)
#' \item energy_fossil_prop Fossil fuel energy consumption in proportion of total consumption (EG.USE.COMM.FO.ZS)
#' \item energy_used Energy consumption in kg of oil equivalent
#' \item energy_fossil Fossil fuel energy consumption in kg of oil equivalent
#' \item prop_world_energy_used Share of the country in the world energy consumption
#' \item prop_world_energy_fossil Share of the country in the world fossil energy consumption
#' \item prop_world_population Share of the country in the world population
#' \item long Longitude of the country
#' \item lat Lattitude of the country
#' \item region Region of the country
#' }
#'
#' @author François Guillem \email{guillem.francois@gmail.com}
#' @references \url{https://data.worldbank.org/indicator}
"worldEnergyUse"
globalVariables(c("mod", "multiple", "name", "type"))
manipulateWidget/R/shiny_module_inputarea.R 0000644 0001762 0000144 00000006232 15126675445 020672 0 ustar ligges users inputAreaModuleUI <- function(id, allowCompare = TRUE) {
ns <- NS(id)
shiny::conditionalPanel(
sprintf("input['%s'] != -1", ns("chartid")),
class = "mw-input-container",
tags$div(style = "display:none;",
shiny::textInput(ns("chartid"), label = "chartid")
),
tags$div(
class ="mw-inputs",
style = "display:block;",
tags$div(
shiny::textOutput(ns("input_title")),
class="input-title"
),
tags$div(
class = "mw-inputarea",
shiny::uiOutput(ns("inputarea"))
),
shiny::conditionalPanel(
sprintf("input['%s'] == '0'", ns("chartid")),
class = "mw-inputarea",
compareInputsModuleUI(ns("compare"), allowCompare = allowCompare)
)
)
)
}
inputAreaModuleServer <- function(input, output, session, chartId, ctrl) {
ns <- session$ns
compareMod <- shiny::callModule(compareInputsModuleServer, "compare", ctrl)
listeners <- c()
visible <- reactive(input$visible())
# Controller initialization
ctrl$setShinyInputSession(session)
addListener <- function(i) {
id <- i$getID()
e <- new.env()
e$firstCall <- TRUE
if (!is.character(id)) return()
if (id %in% listeners) return()
if (ctrl$inputList[id]$type != "sharedValue") {
observeEvent(input[[id]], {
if (e$firstCall) {
e$firstCall <- FALSE
} else {
ctrl$setValueById(id, value = input[[id]])
}
}, ignoreNULL = FALSE)
listeners <<- append(listeners, id)
}
}
updateInputs <- function(chartId) {
updateTextInput(session, "chartid", value = chartId)
if (chartId == -1) {
content <- ""
} else {
if (chartId == 0) {
inputs <- ctrl$uiSpec$getInputsForChart(0)
if (compareMod$n == 1 && length(ctrl$uiSpec$inputList$unshared()) > 0) {
inputs <- c(inputs, ctrl$uiSpec$getInputsForChart(1))
}
} else inputs <- ctrl$uiSpec$getInputsForChart(chartId)
content <- shiny::tagList(lapply(inputs, function(x) {x$getHTML(ns)}))
lapply(ctrl$uiSpec$inputList$inputTable$input, addListener)
}
output$inputarea <- shiny::renderUI(content)
# Update visibility of inputs
lapply(ctrl$inputList$inputTable$input, function(input) {
# Update input visibility
if (chartId != get(".id", envir = input$env)) return()
# Hack to fix https://github.com/rstudio/shiny/issues/1490
if (input$type == "select" && identical(input$lastParams$multiple, TRUE)) {
input$valueHasChanged <- TRUE
input$updateHTML(session)
}
})
}
observeEvent(chartId(), {
updateInputs(chartId())
if (chartId() == -1) title <- ""
else if (chartId() == 0) title <- ctrl$translations$settings
else title <- paste(ctrl$translations$chart, chartId())
output$input_title <- shiny::renderText(title)
})
observeEvent(compareMod$.compareVars(), ignoreNULL = FALSE, ignoreInit = TRUE, {
updateInputs(chartId())
})
res <- reactiveValues()
observe(res$n <- compareMod$n)
observe(res$ncol <- compareMod$ncol)
observe(res$nrow <- compareMod$nrow)
observe(res$displayIndBtns <- length(compareMod$.compareVars()) > 0)
res
}
manipulateWidget/R/shiny_module_menu.R 0000644 0001762 0000144 00000012023 15126675445 017641 0 ustar ligges users menuModuleUI <- function(id, okBtn = TRUE, saveBtn = TRUE, updateBtn = FALSE,
exportBtn = TRUE, exportType = "html2canvas") {
ns <- NS(id)
container <- tags$div(
class="mw-menu",
# Main Settings button
tags$div(
style = "padding:0;",
class = "mw-btn mw-btn-settings",
onclick = sprintf("select(this, '%s')", ns("mw-shared-inputs")),
shiny::actionButton(ns(".settings"), "", icon = shiny::icon("gears"), class = "bt1 settings"),
tags$div(class="right-arrow")
),
uiOutput(ns("chart_btns"))
)
if (updateBtn) {
updateBtn <- tags$div(
class = "mw-btn mw-btn-update",
shiny::actionButton(ns(".update"), "", icon = shiny::icon("refresh"), class = "bt1")
)
container <- tagAppendChild(container, updateBtn)
}
actionButtons <- tags$div(class = "action-buttons-container")
if (saveBtn) {
saveBtnInput <- shiny::downloadButton(ns("save"), label = "", class = "mw-btn mw-btn-save")
actionButtons <- tagAppendChild(actionButtons, saveBtnInput)
}
if (exportBtn) {
if(exportType %in% "html2canvas"){
exportBtnInput <- shiny::actionButton(ns("export_html2canvas"), icon = icon("camera"), label = "",
class = "mw-btn mw-btn-export",
onclick = sprintf("saveAsPNG('%s')", "mw-chartarea"))
} else {
# exportBtnInput <- shiny::downloadButton(ns("export"), icon = icon("camera"), label = "",
# class = "mw-btn mw-btn-export")
exportBtnInput <- tags$a(id = ns("export"),
class = paste("btn btn-default shiny-download-link",
"mw-btn mw-btn-export"), href = "", target = "_blank", download = NA,
icon("camera"), "")
}
actionButtons <- tagAppendChild(actionButtons, exportBtnInput)
}
if (okBtn) {
okBtnInput <- shiny::actionButton(ns("done"), "OK", class = "mw-btn mw-btn-ok")
actionButtons <- tagAppendChild(actionButtons, okBtnInput)
}
tagAppendChild(container, actionButtons)
}
menuModuleServer <- function(input, output, session, ncharts, nrow, ncol,
displayIndBtns, ctrl) {
ns <- session$ns
chartId <- shiny::reactiveVal(-1)
state <- reactive({
list(
chartId = chartId(),
done = input$done,
update = input$.update,
save = input$save
)
})
listeners <- character()
# Eventually add listeners
observe({
req(ncharts())
ids <- ns(paste0("mw-ind-inputs-", seq_len(ncharts())))
lapply(seq_along(ids), function(i) {
if (! ids[[i]] %in% listeners) {
observeEvent(input[[ids[i]]], {
if (chartId() == i) chartId(-1)
else chartId(i)
})
}
})
listeners <<- union(listeners, ids)
})
# If user removes current chart, update chartId
observeEvent(ncharts(), {
if (chartId() > ncharts() | (chartId() == 1 & ncharts() == 1)) {
chartId(-1)
}
})
output$chart_btns <- renderUI({
req(ncharts())
if (ncharts() < 2 || !displayIndBtns()) ""
else {
ids <- ns(paste0("mw-ind-inputs-", seq_len(ncharts())))
btns <- lapply(seq_len(ncharts()), function(i) {
if (i == chartId()) active_class <- " active"
else active_class <- ""
tags$div(
class = paste0("mw-btn mw-btn-area", active_class),
style = "padding:0;",
onclick = sprintf("select(this,'%s')", ids[i]),
shiny::actionButton(
ns(ids[i]), class = "bt1 area",
.uiChartIcon(i, nrow(), ncol())
),
tags$div(class="right-arrow")
)
})
btns$class <- "mw-chart-selection"
do.call(tags$div, btns)
}
})
observeEvent(input$.settings, {
if (chartId() == 0) chartId(-1)
else chartId(0)
})
output$save <- shiny::downloadHandler(
filename = function() {
paste('mw-', Sys.Date(), '.html', sep='')
},
content = function(con) {
htmlwidgets::saveWidget(widget = onDone(ctrl$clone(), stopApp = FALSE),
file = con, selfcontained = TRUE)
}
)
output$export <- shiny::downloadHandler(
filename = function() {
paste('mw-', Sys.Date(), '.png', sep='')
},
content = function(con) {
tmp_html <- tempfile(fileext=".html")
htmlwidgets::saveWidget(widget = onDone(ctrl$clone(), stopApp = FALSE),
file = tmp_html, selfcontained = TRUE)
webshot::webshot(url = tmp_html, file = con)
}
)
return(state)
}
.uiChartIcon <- function(i, nrow, ncol) {
WIDTH <- 27
HEIGHT <- 22
PAD <- 2
i <- i - 1
w <- (WIDTH - 2 * PAD) / ncol
h <- (HEIGHT - 2 * PAD) / nrow
chartIconStyle <- sprintf("width:%spx;height:%spx;left:%spx;top:%spx;",
w, h, w * (i%%ncol) + PAD, h * (i %/% ncol) + PAD)
tags$div(
class = "mw-icon-areachart",
tags$div(class="mw-icon-chart", style=chartIconStyle)
)
}
manipulateWidget/R/module_ui.R 0000644 0001762 0000144 00000004101 15126675445 016076 0 ustar ligges users #' Add a manipulateWidget to a shiny application
#'
#' These two functions can be used to include a manipulateWidget object in a shiny application.
#' \code{mwModuleUI} must be used in the UI to generate the required HTML elements and add
#' javascript and css dependencies. \code{mwModule} must be called once in the server function
#' of the application.
#'
#' @param id A unique string that identifies the module
#' @param controller Object of class \code{\link{MWController}} returned by
#' \code{\link{manipulateWidget}} when parameter \code{.runApp} is
#' \code{FALSE}.
#' @param fillPage : \code{logical}. Render in a fillPage or not ? Defaut to FALSE
#' @param ... named arguments containing reactive values. They can be used to send data from
#' the main shiny application to the module.
#'
#' @return \code{mwModuleUI} returns the required HTML elements for the module. mwModule is only
#' used for its side effects.
#'
#' @examples
#' if (interactive() & require("dygraphs")) {
#' require("shiny")
#' ui <- fillPage(
#' fillRow(
#' flex = c(NA, 1),
#' div(
#' textInput("title", label = "Title", value = "glop"),
#' selectInput("series", "series", choices = c("series1", "series2", "series3"))
#' ),
#' mwModuleUI("ui", height = "100%")
#' ))
#'
#' server <- function(input, output, session) {
#' mydata <- data.frame(
#' year = 2000+1:100,
#' series1 = rnorm(100),
#' series2 = rnorm(100),
#' series3 = rnorm(100)
#' )
#'
#' c <- manipulateWidget(
#' {
#' dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title)
#' },
#' range = mwSlider(2001, 2100, c(2001, 2050)),
#' series = mwSharedValue(),
#' title = mwSharedValue(), .runApp = FALSE,
#' .compare = "range"
#' )
#' #
#' mwModule("ui", c, title = reactive(input$title), series = reactive(input$series))
#' }
#'
#' shinyApp(ui, server)
#'
#'
#' }
#'
#' @export
mwModule <- function(id, controller, fillPage = FALSE, ...) {
shiny::callModule(mwModuleServer, id, ctrl = controller, ...)
}
manipulateWidget/R/debug.R 0000644 0001762 0000144 00000000425 15126675445 015207 0 ustar ligges users mwDebug <- function() {
options(mwDebug = TRUE)
}
mwUndebug <- function() {
options(mwDebug = FALSE)
}
mwDebugMode <- function() {
res <- getOption("mwDebug")
if (is.null(res)) res <- FALSE
res
}
catIfDebug <- function(...) {
if (mwDebugMode()) cat(..., "\n")
}
manipulateWidget/R/input_class.R 0000644 0001762 0000144 00000022155 15127701741 016437 0 ustar ligges users controlValueAndParams <- function(value, params, name, env){
# have another variable name in env
if(exists(name, envir = env)){
# get value
value_name <- get(name, envir = env)
control <- function(value, name, env){
# case of value / params of type name
if(is.name(value)){
# change name to new_name and assign current value
new_name <- paste0(".tmp_mw_", name)
assign(new_name, value_name, envir = env)
# modify expr
value <- eval(parse(text = paste0("substitute(", new_name, ")")))
# case of value / params of type call
} else if(is.call(value)){
# change name to new_name and assign current value
new_name <- paste0(".tmp_mw_", name)
assign(new_name, value_name, envir = env)
# modify expr
char_call <- paste0(deparse(value), collapse = "\n")
m <- gregexpr(paste0("((_.)[[:punct:]]|[[:space:]]|^){1}(",
name,
")((_.)[[:punct:]]|[[:space:]]|$){1}"), char_call)
if(m[[1]][1] != -1){
matches_values <- unlist(regmatches(char_call, m))
mlength <- attr(m[[1]], "match.length")
mstart <- m[[1]][1:length(mlength)]
if(mstart[1] != 1){
final_value <- substring(char_call, 1, mstart[1]-1)
} else {
final_value <- ""
}
for(i in 1:length(mlength)){
tmp <- matches_values[i]
if(nchar(tmp) == (nchar(name) + 2)){
final_value <- paste0(final_value, substring(char_call, mstart[i], mstart[i]), new_name,
substring(char_call, mstart[i] + mlength[i] - 1, mstart[i] + mlength[i] - 1))
} else if(nchar(tmp) == nchar(name)){
final_value <- paste0(final_value, new_name)
} else if(nchar(tmp) > (nchar(name) + 2)){
final_value <- paste0(final_value, substring(char_call, mstart[i], mstart[i] + mlength[i] - 1))
} else {
if(substring(tmp, 1, nchar(name)) == name){
final_value <- paste0(final_value, new_name,
substring(char_call, mstart[i] + mlength[i] - 1, mstart[i] + mlength[i] - 1))
} else {
final_value <- paste0(final_value, substring(char_call, mstart[i], mstart[i]), new_name)
}
}
if(i != length(mlength)){
if((mstart[i] + mlength[i]) != mstart[i+1]){
final_value <- paste0(final_value, substring(char_call, mstart[i] + mlength[i], mstart[i+1] - 1))
}
} else if((mstart[i] + mlength[i] - 1) != nchar(char_call)){
final_value <- paste0(final_value, substring(char_call, mstart[i] + mlength[i], nchar(char_call)))
}
}
} else {
final_value <- char_call
}
value <- eval(parse(text = paste0("substitute(", final_value, ")")))
} else {
value
}
return(value)
}
# control value
value <- control(value, name, env)
# control params
params <- lapply(params, function(x){control(x, name, env)})
}
return(list(value = value, params = params))
}
emptyField <- function(x) inherits(x, "uninitializedField")
evalParams <- function(params, env) {
lapply(params, function(x) {
tryCatch(eval(x, envir = env), silent = TRUE, error = function(e) {
if(mwDebugMode()) message(e$message)
NULL
})
})
}
evalValue <- function(value, env) {
tryCatch(eval(value, envir = env), silent = TRUE, error = function(e) {
if(mwDebugMode()) message(e$message);
NULL
})
}
# Private reference class representing an input.
Input <- setRefClass(
"Input",
fields = c("type", "name", "idFunc", "label", "value", "display", "params", "env",
"validFunc", "htmlFunc", "htmlUpdateFunc",
"lastParams", "changedParams", "valueHasChanged",
"revDeps", "displayRevDeps", "value_expr", "group"),
methods = list(
init = function(name, env, group = NULL) {
"Set environment and default values"
name <<- name
env <<- env
group <<- group
valueHasChanged <<- FALSE
changedParams <<- list()
revDeps <<- character()
displayRevDeps <<- character()
if (emptyField(label) || is.null(label)) label <<- name
if (emptyField(idFunc)) {
idFunc <<- function(oid, name) paste(oid, name, sep = "_")
}
ctrl_vp <- controlValueAndParams(value, params, name, env)
value <<- ctrl_vp$value
params <<- ctrl_vp$params
if(is.call(value) | is.name(value)){
assign(name, evalValue(value, parent.frame()), envir = env)
value_expr <<- value
} else {
assign(name, value, envir = env)
value_expr <<- NULL
}
lastParams <<- NULL
if (type == "group") {
lapply(names(value), function(n) {
value[[n]]$init(n, env, name)
})
}
},
getID = function() {
"Get the id of the input for the UI"
gsub("[^a-zA-Z0-9]", "_", idFunc(get(".output", envir = env), name))
},
setValue = function(newValue, reactive = FALSE) {
"Modify value of the input. If newValue is invalid, it sets a valid value"
catIfDebug("Set value of", getID())
if(reactive & type == "sharedValue"){
params$dynamic <<- FALSE
}
if (!emptyField(validFunc)) value <<- validFunc(evalValue(newValue, env), getParams())
assign(name, value, envir = env)
valueHasChanged <<- FALSE
value
},
updateValue = function() {
"Update value after a change in environment"
oldValue <- value
if (!emptyField(validFunc)){
if(is.call(value_expr) | is.name(value_expr)){
tmp_value <- evalValue(value_expr, env)
if(is.null(tmp_value) & !is.call(oldValue) & !is.name(oldValue)) tmp_value <- oldValue
value <<- validFunc(tmp_value, getParams())
} else {
tmp_value <- evalValue(value, env)
if(is.null(tmp_value) & !is.call(oldValue) & !is.name(oldValue)) tmp_value <- oldValue
value <<- validFunc(tmp_value, getParams())
}
}
if (!identical(value, oldValue)) {
catIfDebug("Update value of ", getID())
valueHasChanged <<- TRUE
assign(name, value, envir = env)
}
value
},
getParams = function() {
"Get parameter values"
oldParams <- lastParams
lastParams <<- evalParams(params, env)
for (n in names(lastParams)) {
if (!is.null(oldParams[[n]]) &&
!identical(lastParams[[n]], oldParams[[n]])) {
changedParams[[n]] <<- lastParams[[n]]
}
}
lastParams
},
getHTML = function(ns = NULL) {
"Get the input HTML"
if (emptyField(htmlFunc)) return(NULL)
id <- getID()
if (!is.null(ns)) id <- ns(id)
shiny::conditionalPanel(
condition = sprintf("input['%s_visible']", id),
tags$div(
style="display:none;",
shiny::checkboxInput(paste0(id, "_visible"), "", value = evalValue(display, env))
),
htmlFunc(id, label, value, lastParams, ns)
)
},
updateHTML = function(session) {
"Update the input HTML."
if (emptyField(htmlUpdateFunc)) return()
if (valueHasChanged || length(changedParams) > 0) {
catIfDebug("Update HTML of ", getID(), "\n")
htmlParams <- changedParams
if (valueHasChanged) htmlParams$value <- value
else if(length(changedParams) > 0){
htmlParams$value <- validFunc(value, getParams())
}
htmlParams$session <- session
htmlParams$inputId <- getID()
do.call(htmlUpdateFunc, htmlParams)
valueHasChanged <<- FALSE
changedParams <<- list()
}
},
show = function() {
"print method"
cat("input of class", type, "\n")
if (type == "group") {
for (n in names(value)) {
cat("$", n, ": ", sep = "")
value[[n]]$show()
}
}
},
clone = function(env) {
newInput <- .self$copy()
newInput$env <- env
if (type == "group") {
newInput$value <- lapply(value, function(i) i$clone(env))
} else {
assign(name, newInput$value, envir = env)
newInput$env <- env
}
newInput
},
destroy = function() {
if (type == "group") {
lapply(value, function(i) i$destroy())
} else {
rm(list = name, envir = env)
}
},
getInputs = function() {
if (type == "group") {
res <- do.call(c, unname(lapply(value, function(i) i$getInputs())))
append(structure(list(.self), .Names = name), res)
} else {
structure(list(.self), .Names = name)
}
},
resetDeps = function() {
revDeps <<- character(0)
displayRevDeps <<- character(0)
},
addDeps = function(newRevDeps = character(0), newDisplayRevDeps = character(0)) {
revDeps <<- union(revDeps, newRevDeps)
displayRevDeps <<- union(displayRevDeps, newDisplayRevDeps)
}
)
)
#' @export
as.character.Input <- function(x, ...) {
list(...)
"InputObject"
}
manipulateWidget/R/manipulate_widget.R 0000644 0001762 0000144 00000022700 15126746410 017612 0 ustar ligges users #Copyright © 2016 RTE Réseau de transport d’électricité
#' Add Controls to Interactive Plots
#'
#' @description
#' This function permits to add controls to an interactive plot created with
#' packages like \code{dygraphs}, \code{highcharter} or \code{plotly} in order
#' to change the input data or the parameters of the plot.
#'
#' Technically, the function starts a shiny gadget. The R session is bloqued
#' until the user clicks on "cancel" or "done". If he clicks on "done", then the
#' the function returns the last displayed plot so the user can modify it and/or
#' save it.
#'
#' @param .expr expression to evaluate that returns an interactive plot of class
#' \code{htmlwidget}. This expression is re-evaluated each time a control is
#' modified.
#' @param ... One or more named control arguments created with functions
#' \code{\link{mwSlider}}, \code{\link{mwText}}, etc. The name of each control
#' is the name of the variable the controls modifies in the expression. One
#' can also create a group of inputs by passing a list of such control
#' arguments. for instance \code{mygroup = list(txt = mwText(""), nb =
#' mwNumeric(0))} creates a group of inputs named mygroup with two inputs
#' named "txt" and "nb".
#' @param .updateBtn Should an update button be added to the controls ? If
#' \code{TRUE}, then the graphic is updated only when the user clicks on the
#' update button.
#' @param .saveBtn Should an save button be added to the controls ? For saving output as html. Does not work in RStudio Viewer
#' @param .exportBtn Should an export button be added to the controls ? For saving output as png. Does not work in RStudio Viewer
#' @param .exportType \code{.exportBtn}, using \code{html2canvas} (default) and keeping current zoom, ... or using \code{webshot}
#' @param .viewer Controls where the gadget should be displayed. \code{"pane"}
#' corresponds to the Rstudio viewer, \code{"window"} to a dialog window, and
#' \code{"browser"} to an external web browser.
#' @param .compare Sometimes one wants to compare the same chart but with two
#' different sets of parameters. This is the purpose of this argument. It can
#' be a character vector of input names or a named list whose names are the
#' names of the inputs that should vary between the two charts. Each element
#' of the list must be a vector or a list of length equal to the number of
#' charts with the initial values of the corresponding parameter for each
#' chart. It can also be \code{NULL}. In this case, the parameter is
#' initialized with the default value for the two charts.
#' @param .compareOpts List of options created \code{\link{compareOptions}}.
#' These options indicate the number of charts to create and their disposition.
#' @param .translations List of translation strings created with function
#' \code{\link{mwTranslations}}. Used to translate UI titles and labels.
#' @param .return A function that can be used to modify the output of
#' \code{manipulateWidget}. It must take two parameters: the first one is the
#' final widget, the second one is a list of environments containing the input
#' values of each individual widget. The length of this list is one if .compare
#' is null, two or more if it has been defined.
#' @param .width Width of the UI. Used only on Rmarkdown documents with option
#' \code{runtime: shiny}.
#' @param .height Height of the UI. Used only on Rmarkdown documents with option
#' \code{runtime: shiny}.
#' @param .runApp (advanced usage) If true, a shiny gadget is started. If false,
#' the function returns a \code{\link{MWController}} object. This object can be
#' used to check with command line instructions the behavior of the application.
#' (See help page of \code{\link{MWController}}). Notice that this parameter is
#' always false in a non-interactive session (for instance when running tests of
#' a package).
#'
#'
#' @return
#' The result of the expression evaluated with the last values of the controls.
#' It should be an object of class \code{htmlWidget}.
#'
#' @section Advanced Usage:
#' The "normal" use of the function is to provide an expression that always
#' return an \code{htmlwidget}. In such case, every time the user changes the
#' value of an input, the current widget is destroyed and a new one is created
#' and rendered.
#'
#' Some packages provide functions to update a widget that has already been
#' rendered. This is the case for instance for package \code{leaflet} with the
#' function \code{\link[leaflet]{leafletProxy}}. To use such functions,
#' \code{manipulateWidget} evaluates the parameter \code{.expr} with four extra
#' variables:
#'
#' \describe{
#' \item{\code{.initial}:}{
#' \code{TRUE} if the expression is evaluated for the first time and then
#' the widget has not been rendered yet, \code{FALSE} if the widget has
#' already been rendered.
#' }
#' \item{\code{.session}:}{
#' A shiny session object.
#' }
#' \item{\code{.output}:}{
#' ID of the output in the shiny interface.
#' }
#' \item{\code{.id}:}{
#' Id of the chart. It can be used in comparison mode to make further
#' customization without the need to create additional input controls.
#' }
#' }
#'
#' You can take a look at the last example to see how to use these two
#' variables to update a leaflet widget.
#'
#' @section Modify the returned widget:
#' In some specific situations, a developer may want to use
#' \code{manipulateWidget} in a function that waits the user to click on the
#' "Done" button and modifies the widget returned by \code{manipulateWidget}.
#' In such situation, parameter \code{.return} should be used so that
#' \code{manipulateWidget} is the last function called. Indeed, if other code
#' is present after, the custom function will act very weird in a Rmarkdown
#' document with "runtime: shiny".
#'
#' @example inst/examples/manipulate_widget.R
#' @export
#'
manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE,
.exportBtn = TRUE, .exportType = c("html2canvas", "webshot"),
.viewer = c("pane", "window", "browser"),
.compare = NULL,
.compareOpts = compareOptions(),
.translations = mwTranslations(),
.return = function(widget, envs) {widget},
.width = NULL, .height = NULL, .runApp = TRUE) {
# check if we are in runtime shiny
isRuntimeShiny <- identical(knitr::opts_knit$get("rmarkdown.runtime"), "shiny")
.expr <- substitute(.expr)
.viewer <- match.arg(.viewer)
.env <- parent.frame()
.compareOpts <- do.call(compareOptions, .compareOpts)
.translations <- do.call(mwTranslations, .translations)
.exportType <- match.arg(.exportType)
if (.exportType == "webshot" && !requireNamespace("webshot")) {
stop("Package 'webshot' has not been installed. Install it or use argument .exportType = 'html2canvas'")
}
if (is.null(.compare)) {
.compareOpts$ncharts <- 1
} else {
if (is.character(.compare)) {
.compare <- sapply(.compare, function(x) NULL,
simplify = FALSE, USE.NAMES = TRUE)
}
if (is.null(.compareOpts$ncharts) || .compareOpts$ncharts < 2) {
.compareOpts$ncharts <- 2
}
}
dims <- .getRowAndCols(.compareOpts$ncharts, .compareOpts$nrow, .compareOpts$ncol)
# Initialize inputs
l_inputs <- list(...)
if(".updateBtnInit" %in% names(l_inputs)){
warning(".updateBtnInit is deprecated. Graphics are now always render on init")
l_inputs$.updateBtnInit <- NULL
}
inputs <- initInputEnv(l_inputs, env = .env, compare = .compare,
ncharts = .compareOpts$ncharts)
# Initialize controller
controller <- MWController(.expr, inputs,
autoUpdate = list(value = !.updateBtn, saveBtn = .saveBtn,
exportBtn = .exportBtn, exportType = .exportType),
nrow = dims$nrow, ncol = .compareOpts$ncol,
returnFunc = .return, translations = .translations)
if (.runApp & interactive()) {
# We are in an interactive session so we start a shiny gadget
.viewer <- switch(
.viewer,
pane = shiny::paneViewer(),
window = shiny::dialogViewer("manipulateWidget"),
browser = shiny::browserViewer()
)
ui <- mwUI("mw", border = FALSE, okBtn = TRUE, updateBtn = .updateBtn,
saveBtn = .saveBtn, exportBtn = .exportBtn, exportType = .exportType,
width = "100%", height = "100%", allowCompare = .compareOpts$allowCompare)
server <- function(input, output, session) {
callModule(mwModuleServer, "mw", controller)
}
shiny::runGadget(ui, server, viewer = .viewer)
} else if (.runApp & isRuntimeShiny) {
# We are in Rmarkdown document with shiny runtime. So we start a shiny app
ui <- mwUI("mw", border = TRUE, okBtn = FALSE, updateBtn = .updateBtn,
saveBtn = .saveBtn, exportBtn = .exportBtn, exportType = .exportType,
width = "100%", height = "100%", allowCompare = .compareOpts$allowCompare)
server <- function(input, output, session) {
callModule(mwModuleServer, "mw", controller)
}
shiny::shinyApp(ui = ui, server = server, options = list(width = .width, height = .height))
} else {
# Other cases (Rmarkdown or non interactive execution). We return the controller
# to not block the R execution.
invisible(controller)
}
}
manipulateWidget/R/shiny_module_compare_inputs.R 0000644 0001762 0000144 00000005711 15126675445 021733 0 ustar ligges users compareInputsModuleUI <- function(id, allowCompare = TRUE) {
ns <- NS(id)
if (allowCompare) {
shiny::uiOutput(ns("content"))
} else {
tags$div(
style = "visibility:hidden;",
shiny::uiOutput(ns("content"))
)
}
}
compareInputsModuleServer <- function(input, output, session, ctrl) {
ns <- session$ns
output$content <- shiny::renderUI({
shiny::tagList(
tags$div(class="separator"),
checkboxInput(ns("compare"), ctrl$translations$compare, value = ctrl$ncharts > 1),
shiny::conditionalPanel(
sprintf("input['%s']", ns("compare")),
shiny::selectInput(
ns(".compareVars"), ctrl$translations$compareVars,
choices = ctrl$uiSpec$getShareable(),
selected = intersect(ctrl$uiSpec$getShareable(), ctrl$uiSpec$inputList$unshared()),
multiple = TRUE
),
tags$div(
class = "compare-inputs",
tags$div(
shiny::numericInput(ns("nbCharts"), ctrl$translations$ncharts,
value = max(2, ctrl$ncharts), min = 2, max = 12)
),
tags$div(
shiny::selectInput(ns("ncols"), ctrl$translations$ncol, c("auto", 1:4), selected = ctrl$ncol)
)
)
)
)
})
nbCharts <- reactive({if (is.null(input$compare)) ctrl$ncharts else if (input$compare) input$nbCharts else 1})
observeEvent(input$compare, {
if (!is.null(input$compare) && !input$compare) {
for (n in intersect(ctrl$uiSpec$getShareable(), input$.compareVars)) {
ctrl$uiSpec$shareInput(n)
}
updateSelectInput(session, ".compareVars", selected = list())
}
}, ignoreInit = TRUE, ignoreNULL = FALSE)
res <- reactiveValues()
observe({
req(nbCharts())
i_ncols <- input$ncols
if(is.null(i_ncols)) i_ncols <- ctrl$ncol
if(is.null(i_ncols)) i_ncols <- "auto"
if (nbCharts() == 1) {
ncol <- 1
} else if (i_ncols== "auto") {
ncol <- NULL
} else {
ncol <- as.numeric(i_ncols)
}
dim <- .getRowAndCols(nbCharts(), ncol = ncol)
res$n <- dim$n
res$ncol <- dim$ncol
res$nrow <- dim$nrow
})
observeEvent(ignoreNULL = FALSE, ignoreInit = TRUE, input$.compareVars, {
toUnshare <- setdiff(input$.compareVars, ctrl$uiSpec$inputList$unshared())
toShare <- setdiff(
setdiff(ctrl$uiSpec$getShareable(), input$.compareVars),
ctrl$uiSpec$inputList$shared()
)
for (n in toUnshare) {
ctrl$uiSpec$unshareInput(n)
}
for (n in toShare) {
newSharedInputs <- ctrl$uiSpec$shareInput(n)
if (length(newSharedInputs) > 0 & nbCharts() > 1) {
for (i in 2:nbCharts()) ctrl$updateChart(i)
}
}
unshared <- intersect(ctrl$uiSpec$getShareable(), ctrl$uiSpec$inputList$unshared())
if (!identical(sort(input$.compareVars), sort(unshared))) {
shiny::updateSelectInput(session, ".compareVars", selected = unshared)
}
})
res$.compareVars <- reactive(input$.compareVars)
res
}
manipulateWidget/R/shiny_module_grid.R 0000644 0001762 0000144 00000003617 15126675445 017633 0 ustar ligges users gridModuleUI <- function(id) {
ns <- NS(id)
uiOutput(ns("cells"), container = function(...) {
tags$div(
class = "mw-chartarea",
...
)
})
}
gridModuleServer <- function(input, output, session, dim, ctrl, ...) {
ns <- session$ns
ncells <- reactiveVal(NULL)
observeEvent(dim$n, {
if (is.null(ncells())) {
outputEls <- lapply(seq_len(dim$n), function(i) {
content <- ctrl$outputFunc(ns(paste0("output_", i)), width = "100%", height = "100%")
style <- sprintf("float:left;width:%s%%;height:%s%%;",
floor(100 / dim$ncol), floor(100 / dim$nrow))
tags$div(class="mw-chart", style = style, content)
})
output$cells <- renderUI(shiny::tagList(outputEls))
} else if (ncells() < dim$n) {
outputEls <- lapply((ncells()+1):dim$n, function(i) {
content <- ctrl$outputFunc(ns(paste0("output_", i)), width = "100%", height = "100%")
style <- sprintf("float:left;width:%s%%;height:%s%%;",
floor(100 / dim$ncol), floor(100 / dim$nrow))
tags$div(class="mw-chart", style = style, content)
})
shiny::insertUI(paste0("#",ns("cells")),ui=shiny::tagList(outputEls), session = session)
resetSize(dim$nrow, dim$ncol, ns)
} else if (ncells() > dim$n) {
for (i in ncells():(dim$n+1)) {
shiny::removeUI(sprintf("div:has(> #%s_%s)", ns("output"), i),session = session)
}
}
ncells(dim$n)
}, ignoreNULL = TRUE)
observe({
resetSize(dim$nrow, dim$ncol, ns)
shinyjs::runjs("resizeAllWidgets()")
})
return(list(output = output, session = session))
}
resetSize <- function(nrow, ncol, ns) {
width <- paste0(floor(100 / ncol), "%")
height <- paste0(floor(100 / nrow), "%")
id <- ns("cells")
js <- sprintf(
"$('#%s .mw-chart').css({'float':'left', 'width':'%s', 'height':'%s'})",
id, width, height
)
shinyjs::runjs(js)
}
manipulateWidget/R/translations.R 0000644 0001762 0000144 00000003113 15126675445 016637 0 ustar ligges users #' Translate UI titles and labels
#'
#' Creates a list of translation strings that can be passed to function
#' \code{\link{manipulateWidget}} to translate some UI elements.
#'
#' @param settings Title of the settings panel.
#' @param chart Title of the chart panel.
#' @param compare Label of the checkbox that activate the comparison mode.
#' @param compareVars Label of the input containing the list of variables to compare.
#' @param ncol Label of the input that sets the number of columns.
#' @param ncharts Label of the input that sets the number of charts.
#'
#' @return
#' Named list of translation strings.
#'
#' @examples
#' translations <- mwTranslations(
#' settings = "Parametres", chart = "Graphique", compare = "Comparaison",
#' compareVars = "Variable de comparaison", ncharts = "Nb graph.", ncol = "Nb col."
#' )
#'
#' if (require(dygraphs)) {
#' mydata <- data.frame(year = 2000+1:100, value = rnorm(100))
#' manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], main = title),
#' range = mwSlider(2001, 2100, c(2001, 2100)),
#' title = mwText("Fictive time series"),
#' .translations = translations)
#' }
#'
#' @export
#'
mwTranslations <- function(settings = "Settings", chart = "Chart",
compare = "Compare",
compareVars = "Variables to compare",
ncol = "Nb Columns", ncharts = "Nb Charts") {
list(
settings = settings,
chart = chart,
compare = compare,
compareVars = compareVars,
ncol = ncol,
ncharts = ncharts
)
}
manipulateWidget/R/input_list_class.R 0000644 0001762 0000144 00000015751 15126675445 017510 0 ustar ligges users extractVarsFromExpr <- function(expr) {
f <- function() {}
body(f) <- expr
codetools::findGlobals(f, merge = FALSE)$variables
}
# Private reference class used to update value and params of a set of inputs
# when the value of an input changes.
InputList <- setRefClass(
"InputList",
fields = c("session", "initialized", "inputTable"),
methods = list(
initialize = function(inputs, session = NULL) {
"args:
- inputs: list of initialized inputs
- session: shiny session"
inputList <- lapply(inputs, function(input) input$getInputs())
inputList <- do.call(c, inputList)
if (length(inputs) > 0) {
inputTable <<- data.frame(
row.names = sapply(inputList, function(x) {x$getID()}),
name = sapply(inputList, function(x) x$name),
chartId = sapply(inputList, function(x) get(".id", envir = x$env)),
type = sapply(inputList, function(x) x$type),
input = I(inputList),
stringsAsFactors = FALSE
)
} else {
inputTable <<- data.frame()
}
session <<- session
initialized <<- FALSE
# Set dependencies
setDeps()
},
setDeps = function() {
# Reset all deps
for (id in row.names(inputTable)) {
getInputById(id)$resetDeps()
}
for (input in inputTable$input) {
inputId <- input$getID()
deps <- getDeps(input)
for (d in deps$params) {
getInputById(d)$addDeps(newRevDeps = inputId)
}
for (d in deps$display) {
getInputById(d)$addDeps(newDisplayRevDeps = inputId)
}
}
},
init = function() {
if (!initialized) {
update(forceDeps = TRUE)
initialized <<- TRUE
}
return(.self)
},
isShared = function(name) {
idx <- which(inputTable$name == name)
if (length(idx) == 0) stop("cannot find input ", name)
any(inputTable$chartId[idx] == 0)
},
shared = function() {
inputTable$name[inputTable$chartId == 0]
},
unshared = function() {
unique(inputTable$name[inputTable$chartId != 0])
},
isVisible = function(name, chartId = 1, inputId = NULL) {
i <- getInput(name, chartId, inputId)
eval(i$display, envir = i$env)
},
updateHTMLVisibility = function(name, chartId = 1, inputId = NULL) {
if (!is.null(session)) {
input <- getInput(name, chartId, inputId)
catIfDebug("Update visibility of", input$getID())
shiny::updateCheckboxInput(
session,
paste0(input$getID(), "_visible"),
value = eval(input$display, envir = input$env)
)
}
},
getDeps = function(input) {
chartId <- get(".id", input$env)
deps <- lapply(input$params, extractVarsFromExpr)
deps <- do.call(c, deps)
displayDeps <- extractVarsFromExpr(input$display)
list(
params = row.names(inputTable)[inputTable$name %in% deps & inputTable$chartId %in% c(0, chartId)],
display = row.names(inputTable)[inputTable$name %in% displayDeps & inputTable$chartId %in% c(0, chartId)]
)
},
getInput = function(name, chartId = 1, inputId = NULL) {
if (!is.null(inputId)) {
return(getInputById(inputId))
}
idx <- which(inputTable$name == name & inputTable$chartId %in% c(0, chartId))
if (length(idx) == 0) {
catIfDebug("cannot find input with name ", name)
NULL
} else {
inputTable$input[[idx]]
}
},
getInputById = function(inputId) {
if (!inputId %in% row.names(inputTable)) {
catIfDebug("cannot find input with id ", inputId)
NULL
} else {
inputTable[inputId, "input"][[1]]
}
},
addInputs = function(x) {
if (length(x) == 0) return()
initialInputs <- row.names(inputTable)
for (input in x) {
if (input$type == "group") addInputs(input$value)
}
newInputs <- data.frame(
row.names = sapply(x, function(i) i$getID()),
name = sapply(x, function(i) i$name),
chartId = sapply(x, function(i) get(".id", envir = i$env)),
type = sapply(x, function(i) i$type),
input = I(x),
stringsAsFactors = FALSE
)
inputTable <<- rbind(inputTable, newInputs)
# Reset dependencies
setDeps()
if (initialized) update(forceDeps = TRUE)
setdiff(row.names(inputTable), initialInputs)
},
removeInput = function(name, chartId = 0, inputId = NULL) {
if (!is.null(inputId)) {
if (!inputId %in% row.names(inputTable)){
catIfDebug("cannot find input with id ", inputId)
return(TRUE)
} else {
idx <- which(row.names(inputTable) == inputId)
}
} else {
idx <- which(inputTable$name == name & inputTable$chartId == chartId)
}
if (length(idx) == 0){
catIfDebug("cannot find input with name ", name)
return(TRUE)
}
if (length(idx) > 1){
catIfDebug("Something wrong with input", name)
return(TRUE)
}
inputToRemove <- inputTable[idx, "input"][[1]]
inputTable <<- inputTable[-idx,]
if(inputToRemove$type == "group") {
for (input in inputToRemove$value) removeInput(inputId = input$getID())
}
setDeps()
TRUE
},
getValue = function(name, chartId = 1, inputId = NULL) {
getInput(name, chartId, inputId)$value
},
getValues = function(chartId = 1) {
idx <- which(inputTable$chartId %in% c(0, chartId) & inputTable$type != "group")
res <- lapply(inputTable$input[idx], function(i) i$value)
names(res) <- inputTable$name[idx]
res
},
setValue = function(name, value, chartId = 1, inputId = NULL, reactive = FALSE) {
input <- getInput(name, chartId, inputId)
oldValue <- input$value
res <- input$setValue(value, reactive = reactive)
if (!identical(oldValue, res)) updateRevDeps(input)
res
},
updateRevDeps = function(input, force = FALSE) {
if (!initialized && !force) return()
if (length(input$revDeps) > 0) {
catIfDebug("Update dependencies of variable", input$name)
for (inputId in input$revDeps) {
revDepInput <- getInput(inputId = inputId)
if(!identical(revDepInput$value, revDepInput$updateValue())) {
updateRevDeps(revDepInput)
}
}
}
for (inputId in input$displayRevDeps) {
updateHTMLVisibility(inputId = inputId)
}
updateHTML()
},
update = function(forceDeps = FALSE) {
"Update all inputs"
for (input in inputTable$input) {
if (!identical(input$value, input$updateValue())) updateRevDeps(input, force = forceDeps)
}
},
updateHTML = function() {
if (!is.null(session)) {
for (input in inputTable$input) {
input$updateHTML(session)
}
}
},
show = function() {
print(inputTable)
}
)
)
`[.InputList` <- function(x, i, j, ...) {
x$inputTable[i, j, ...]
}
manipulateWidget/R/mw_ui.R 0000644 0001762 0000144 00000011551 15126675445 015243 0 ustar ligges users #' Private function that generates the general layout of the application
#'
#' @param ns namespace function created with shiny::NS(). Useful to create
#' modules.
#' @param inputs Object returned by preprocessInputs
#' @param ncol Number of columns in the chart area.
#' @param nrow Number of rows in the chart area.
#' @param outputFun Function that generates the html elements that will contain
#' a given widget
#' @param okBtn Should the OK Button be added to the UI ?
#' @param saveBtn Should an save button be added to the controls ? For saving output as html. Does not work in RStudio Viewer
#' @param exportBtn Should an export button be added to the controls ? For saving output as png. Does not work in RStudio Viewer
#' @param exportType \code{.exportBtn}, using \code{html2canvas} (default) and keeping current zoom, ... or using \code{webshot}
#' @param updateBtn Should the updateBtn be added to the UI ?
#' @param width, height Must be a valid CSS unit (like "100%", "400px", "auto") or a number,
#' which will be coerced to a string and have "px" appended. Default to "100%" & "400px"
#'
#' @return shiny tags
#'
#' @noRd
mwUI <- function(id, nrow = 1, ncol = 1, okBtn = TRUE,
saveBtn = TRUE, exportBtn = TRUE, exportType = "html2canvas",
updateBtn = FALSE, areaBtns = TRUE, border = FALSE,
width = "100%", height = "400px",
fillPage = TRUE, allowCompare = TRUE) {
ns <- NS(id)
htmldep <- htmltools::htmlDependency(
"manipulateWidget",
"0.7.0",
system.file("manipulate_widget", package = "manipulateWidget"),
script = "manipulate_widget.js",
style = "manipulate_widget.css"
)
if(exportBtn & (exportType %in% "html2canvas")) {
fileSaver_dep <- htmltools::htmlDependency(
name = "FileSaver",
version = "1.1.20151003",
src = c(file=system.file("lib/export/FileSaver", package="manipulateWidget")),
script = "FileSaver.min.js"
)
Blob_dep <- htmltools::htmlDependency(
name = "Blob",
version = "1.0",
src = c(file=system.file("lib/export/Blob", package="manipulateWidget")),
script = "Blob.js"
)
canvastoBlob_dep <- htmltools::htmlDependency(
name = "canvas-toBlob",
version = "1.0",
src = c(file=system.file("lib/export/canvas-toBlob", package="manipulateWidget")),
script = "canvas-toBlob.js"
)
html2canvas_dep <- htmltools::htmlDependency(
name = "html2canvas",
version = "1.0",
src = c(file=system.file("lib/export/html2canvas", package="manipulateWidget")),
script = "html2canvas.js"
)
htmldep <- list(htmldep, fileSaver_dep, Blob_dep, canvastoBlob_dep, html2canvas_dep)
}
if (border) class <- "mw-container with-border"
else class <- "mw-container"
content <- fillRow(
flex = c(NA, NA, 1),
width = width, height = height,
menuModuleUI(ns("menu"), updateBtn = updateBtn, saveBtn = saveBtn,
okBtn = okBtn, exportBtn = exportBtn, exportType = exportType),
inputAreaModuleUI(ns("inputarea"), allowCompare = allowCompare),
gridModuleUI(ns("grid"))
)
if(fillPage){
container <- fillPage(
shinyjs::useShinyjs(),
tags$div(
id = ns("ui"),
class = class,
style = paste("width:", width, ";height:", height, ";", sep = ""),
content
)
)
} else {
container <- tags$div(
id = ns("ui"),
class = class,
style = paste("width:", width, ";height:", height, ";", sep = ""),
shinyjs::useShinyjs(),
content
)
}
htmltools::attachDependencies(container, htmldep, TRUE)
}
#' @param border Should a border be added to the module ?
#' @param okBtn Should the UI contain the OK button ?
#' @param saveBtn Should the UI contain the save button ? For saving output as html
#' @param exportBtn Should an export button be added to the controls ? For saving output as png
#' @param updateBtn Should the updateBtn be added to the UI ?
#' @param margin Margin to apply around the module UI. Should be one two or four valid css
#' units.
#' @param width Width of the module UI.
#' @param height Height of the module UI.
#' @param header Tag or list of tags to display as a common header above all tabPanels.
#' @param footer Tag or list of tags to display as a common footer below all tabPanels
#' @inheritParams compareOptions
#'
#' @rdname mwModule
#' @export
mwModuleUI <- function(id, border = TRUE, okBtn = FALSE, saveBtn = TRUE,
exportBtn = TRUE, updateBtn = FALSE, allowCompare = TRUE,
margin = 0, width = "100%", height = 400, header = NULL, footer = NULL) {
res <- mwUI(id, border = border, okBtn = okBtn, saveBtn = saveBtn, exportBtn = exportBtn,
allowCompare = allowCompare, updateBtn = updateBtn,
width = width, height = height, fillPage = FALSE)
shiny::tagList(
header,
res,
footer
)
}
manipulateWidget/R/input_env.R 0000644 0001762 0000144 00000016074 15126675445 016137 0 ustar ligges users #' Private function that initialize an environment for a given chart.
#'
#' @param parentEnv an environment to be used as the enclosure of the environment
#' created.
#' @param id index of the chart
#'
#' @return Environment
#' @noRd
initEnv <- function(parentEnv, id) {
res <- new.env(parent = parentEnv)
res$.initial <- TRUE
res$.session <- NULL
res$.id <- id
if (id == 0) res$.output <- "shared"
else res$.output <- paste0("output_", id)
res
}
#' Private function that initializes environments and inputs
#'
#' @param inputs list of uninitialized inputs
#' @param env parent environement
#' @param compare character vector with the name of the inputs to compare
#' @param ncharts number of charts that will be created
#'
#' @return An InputEnv object with the following elements:
#' - envs: list with elements
#' - shared: shared environment
#' - ind: list of individual environments. Length is equal to ncharts
#' - hierarchy: Named list representing the disposition of inputs
#' - inputList: same as inputs but flattened to facilitate looping.
#' - ncharts: number of charts
#' @noRd
initInputEnv <- function(inputs, env = parent.frame(), compare = NULL, ncharts = 1) {
res <- InputEnv()
res$init(inputs = inputs, env = env, compare = compare, ncharts = ncharts)
res
}
InputEnv <- setRefClass(
"InputEnv",
fields = c("envs", "inputList", "ncharts", "hierarchy"),
methods = list(
initialize = function() {},
init = function(inputs, env = parent.frame(), compare = NULL, ncharts = 1) {
if (is.null(names(inputs))) stop("All arguments need to be named.")
for (i in inputs) if (!inherits(i, "Input")) stop("All arguments need to be Input objects.")
ncharts <<- ncharts
# Initialize environments
sharedEnv <- initEnv(env, 0)
indEnvs <- lapply(seq_len(ncharts), function(i) initEnv(sharedEnv, i))
envs <<- list(
shared = sharedEnv,
ind = indEnvs
)
# Get the hierarchy of inputs (used for html generation)
getHierarchyRecursive <- function(inputs) {
res <- sapply(names(inputs), function(n) {
if (inputs[[n]]$type == "group") {
getHierarchyRecursive(inputs[[n]]$value)
} else {
n
}
}, USE.NAMES = TRUE, simplify = FALSE)
}
hierarchy <<- getHierarchyRecursive(inputs)
# Init inputs
lapply(names(inputs), function(n) {inputs[[n]]$init(n, sharedEnv)})
inputList <<- InputList(inputs)
# If compare is not null, unshare inputs and set initial values
lapply(names(compare) , function(n) {
newInputIds <- unshareInput(n)
if (!is.null(compare[[n]])) {
for (i in seq_len(ncharts)) {
inputList$setValue(inputId = newInputIds[i], value = compare[[n]][[i]])
}
}
})
},
shareInput = function(name) {
if (name %in% inputList$shared()) {
return(character())
}
oldInput <- inputList$getInput(name, 1)
if(!is.null(oldInput$group)) {
return(shareInput(oldInput$group))
}
catIfDebug("Share variable", name)
newInputIds <- character()
for (dep in unname(do.call(c, inputList$getDeps(oldInput)))) {
newInputIds <- append(newInputIds, shareInput(inputList$getInput(inputId = dep)$name))
}
newInput <- oldInput$clone(envs$shared)
for (i in seq_len(ncharts)) {
inputList$getInput(name, i)$destroy()
inputList$removeInput(name, chartId = i)
}
append(newInputIds, inputList$addInputs(list(name = newInput)))
},
unshareInput = function(name) {
if (is.null(name) || name %in% "") return(character())
if (name %in% inputList$unshared()) return(character())
oldInput <- inputList$getInput(name, 0)
if(!is.null(oldInput$group)) {
return(unshareInput(oldInput$group))
}
catIfDebug("Unshare variable", name)
newInputIds <- character()
for (id in c(oldInput$revDeps,oldInput$displayRevDeps)) {
newInputIds <- append(newInputIds, unshareInput(inputList$getInput(inputId = id)$name))
}
inputList$removeInput(name, chartId = 0)
for (i in seq_len(ncharts)) {
newInput <- oldInput$clone(envs$ind[[i]])
newInputIds <- append(
newInputIds,
inputList$addInputs(list(name = newInput))
)
}
oldInput$destroy()
newInputIds
},
getInputsForChart = function(chartId) {
if (chartId == 0) {
inputNames <- intersect(names(hierarchy), inputList$shared())
} else {
inputNames <- intersect(names(hierarchy), inputList$unshared())
}
sapply(inputNames, function(n) {
inputList$getInput(n, chartId)
}, simplify = FALSE, USE.NAMES = TRUE)
},
getShareable = function() {
intersect(
names(hierarchy),
inputList$inputTable[inputList$inputTable$type != "sharedValue", "name"]
)
},
addChart = function() {
ncharts <<- ncharts + 1
# Copy environment of last chart
envs$ind <<- append(envs$ind, cloneEnv(envs$ind[[ncharts - 1]], envs$shared))
assign(".id", ncharts, envir = envs$ind[[ncharts]])
assign(".output", paste0("output_", ncharts), envir = envs$ind[[ncharts]])
assign(".initial", TRUE, envir = envs$ind[[ncharts]])
# Get the list of inputs to clone
toClone <- inputList$inputTable$chartId == ncharts - 1 &
inputList$inputTable$name %in% names(hierarchy)
inputsToClone <- inputList$inputTable[toClone, "input"]
# Copy inputs
newInputs <- lapply(inputsToClone, function(input) {
input$clone(envs$ind[[ncharts]])
})
allNewInputs <- lapply(unname(newInputs), function(input) {
input$getInputs()
})
allNewInputs <- do.call(c, allNewInputs)
inputList$addInputs(allNewInputs)
},
removeChart = function() {
if (ncharts == 1) stop("Need at least one chart.")
for (n in inputList$unshared()) {
inputList$removeInput(n, chartId = ncharts)
}
envs$ind[[ncharts]] <<- NULL
ncharts <<- ncharts - 1
},
setChartNumber = function(n) {
if (n < 1) stop("Need at least one chart.")
while (n != ncharts) {
if (n > ncharts) {
addChart()
} else {
removeChart()
}
}
},
clone = function() {
newSharedEnv <- cloneEnv(envs$shared)
newEnvs <- lapply(envs$ind, cloneEnv, parentEnv = newSharedEnv)
newInputList <- InputList(list())
newInputs <- list()
for (n in names(hierarchy)) {
if(inputList$isShared(n)) {
newInputs <- append(newInputs, inputList$getInput(n, 0)$clone(newSharedEnv))
} else {
for (i in seq_len(ncharts)) {
newInputs <- append(newInputs, inputList$getInput(n, i)$clone(newEnvs[[i]]))
}
}
}
newInputList$addInputs(newInputs)
res <- InputEnv()
res$envs <- list(shared = newSharedEnv, ind = newEnvs)
res$inputList <- newInputList
res$hierarchy <- hierarchy
res$ncharts <- ncharts
res
}
)
)
manipulateWidget/vignettes/ 0000755 0001762 0000144 00000000000 15127702746 015600 5 ustar ligges users manipulateWidget/vignettes/update-widget.gif 0000644 0001762 0000144 00001150371 15126675445 021046 0 ustar ligges users GIF89aX ywwwopijee`bX[QN??g48;,05293BEJKLNNOPakv~煸搽߰ԴддеееееддеееҵֵնҷѹѽѼ̶DzªzqlxϗϚΟǤåŧܴ鼸չԶԱմ״ٶڹڼ!NETSCAPE2.0 ! , X H0CȰAR9H1=-j̓li<~1ɒ'RJ.[N3EJ͛8sɳϟ@
JhOF!J4jc<ȢIJիXŴׯ`ÊK@~ V8{$ 5,"-ȋ\
QTO;`%%!qQR`V9Q5.I8 O\ʞM۸8oUYpdȎ;(\q/A^
&LQB,o8#t>E rI`acTVATDShT!JnF(Vhew i7By
0
( A
Y@)RG
,@
PPw '^yG@b ). )J'(WETz TЉv `Yb m"t3U @{"@
`0pc3d9T8hᢌ6;q8VZw92pD
8 >:i*AyPJqC$I@ \(hRK 80y4;
ԶJvtTL%Kx;$By"4kD \(XGTF(lEBv P6G((tPO,@z:"c:a
$F5@N߽.Vb|}9zgJ $4|O6PC& E @
0@B;M3lS5՟