[med-svn] [r-cran-rlumshiny] 09/11: New upstream version 0.1.1
Andreas Tille
tille at debian.org
Tue Oct 10 17:18:41 UTC 2017
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-rlumshiny.
commit 2450be33c40871b488c006d4b577bab23bed0003
Author: Andreas Tille <tille at debian.org>
Date: Tue Oct 10 19:16:35 2017 +0200
New upstream version 0.1.1
---
DESCRIPTION | 33 +
LICENSE.note | 8 +
MD5 | 75 ++
NAMESPACE | 9 +
NEWS | 30 +
R/RLumShiny.R | 21 +
R/app_RLum.R | 59 ++
R/jscolor.R | 52 +
R/popover.R | 57 ++
R/tooltip.R | 63 ++
R/zzz.R | 12 +
debian/changelog | 14 -
debian/compat | 1 -
debian/control | 32 -
debian/copyright | 63 --
debian/rules | 4 -
debian/source/format | 1 -
debian/watch | 2 -
inst/shiny/KDE/server.R | 385 ++++++++
inst/shiny/KDE/ui.R | 300 ++++++
inst/shiny/KDE/www/GitHub-Mark-32px.png | Bin 0 -> 1714 bytes
inst/shiny/KDE/www/RL_Logo.png | Bin 0 -> 29841 bytes
inst/shiny/KDE/www/file_containsHeader.png | Bin 0 -> 41547 bytes
inst/shiny/KDE/www/file_sep.png | Bin 0 -> 46260 bytes
inst/shiny/KDE/www/file_structure.png | Bin 0 -> 42288 bytes
inst/shiny/KDE/www/style.css | 73 ++
inst/shiny/abanico/server.R | 576 +++++++++++
inst/shiny/abanico/ui.R | 869 +++++++++++++++++
inst/shiny/abanico/www/GitHub-Mark-32px.png | Bin 0 -> 1714 bytes
inst/shiny/abanico/www/RL_Logo.png | Bin 0 -> 29841 bytes
inst/shiny/abanico/www/file_containsHeader.png | Bin 0 -> 41547 bytes
inst/shiny/abanico/www/file_sep.png | Bin 0 -> 46260 bytes
inst/shiny/abanico/www/file_structure.png | Bin 0 -> 42288 bytes
inst/shiny/abanico/www/style.css | 73 ++
inst/shiny/cosmicdose/server.R | 124 +++
inst/shiny/cosmicdose/ui.R | 123 +++
inst/shiny/cosmicdose/www/RL_Logo.png | Bin 0 -> 29841 bytes
inst/shiny/cosmicdose/www/RL_Logo_alpha.png | Bin 0 -> 14950 bytes
inst/shiny/cosmicdose/www/style.css | 86 ++
inst/shiny/doserecovery/server.R | 282 ++++++
inst/shiny/doserecovery/ui.R | 380 ++++++++
inst/shiny/doserecovery/www/GitHub-Mark-32px.png | Bin 0 -> 1714 bytes
inst/shiny/doserecovery/www/RL_Logo.png | Bin 0 -> 29841 bytes
.../shiny/doserecovery/www/file_containsHeader.png | Bin 0 -> 41547 bytes
inst/shiny/doserecovery/www/file_sep.png | Bin 0 -> 46260 bytes
inst/shiny/doserecovery/www/file_structure.png | Bin 0 -> 42288 bytes
inst/shiny/doserecovery/www/style.css | 73 ++
inst/shiny/histogram/server.R | 300 ++++++
inst/shiny/histogram/ui.R | 361 +++++++
inst/shiny/histogram/www/GitHub-Mark-32px.png | Bin 0 -> 1714 bytes
inst/shiny/histogram/www/RL_Logo.png | Bin 0 -> 29841 bytes
inst/shiny/histogram/www/file_containsHeader.png | Bin 0 -> 41547 bytes
inst/shiny/histogram/www/file_sep.png | Bin 0 -> 46260 bytes
inst/shiny/histogram/www/file_structure.png | Bin 0 -> 42288 bytes
inst/shiny/histogram/www/style.css | 73 ++
inst/shiny/radialplot/server.R | 540 +++++++++++
inst/shiny/radialplot/ui.R | 606 ++++++++++++
inst/shiny/radialplot/www/GitHub-Mark-32px.png | Bin 0 -> 1714 bytes
inst/shiny/radialplot/www/RL_Logo.png | Bin 0 -> 29841 bytes
inst/shiny/radialplot/www/file_containsHeader.png | Bin 0 -> 41547 bytes
inst/shiny/radialplot/www/file_sep.png | Bin 0 -> 46260 bytes
inst/shiny/radialplot/www/file_structure.png | Bin 0 -> 42288 bytes
inst/shiny/radialplot/www/style.css | 73 ++
inst/shiny/transformCW/Server.R | 154 +++
inst/shiny/transformCW/UI.R | 237 +++++
inst/shiny/transformCW/www/GitHub-Mark-32px.png | Bin 0 -> 1714 bytes
inst/shiny/transformCW/www/RL_Logo.png | Bin 0 -> 29841 bytes
inst/shiny/transformCW/www/file_containsHeader.png | Bin 0 -> 41547 bytes
inst/shiny/transformCW/www/file_sep.png | Bin 0 -> 46260 bytes
inst/shiny/transformCW/www/file_structure.png | Bin 0 -> 42288 bytes
inst/shiny/transformCW/www/style.css | 73 ++
inst/www/jscolor/arrow.gif | Bin 0 -> 66 bytes
inst/www/jscolor/cross.gif | Bin 0 -> 83 bytes
inst/www/jscolor/demo.html | 12 +
inst/www/jscolor/hs.png | Bin 0 -> 2684 bytes
inst/www/jscolor/hv.png | Bin 0 -> 2865 bytes
inst/www/jscolor/jscolor.js | 1010 ++++++++++++++++++++
inst/www/jscolor_inputBinding.js | 19 +
man/RLumShiny-package.Rd | 24 +
man/app_RLum.Rd | 59 ++
man/jscolorInput.Rd | 57 ++
man/popover.Rd | 50 +
man/tooltip.Rd | 68 ++
83 files changed, 7479 insertions(+), 117 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..c7e5f2f
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,33 @@
+Package: RLumShiny
+Type: Package
+Title: 'Shiny' Applications for the R Package 'Luminescence'
+Version: 0.1.1
+Date: 2016-07-20
+Author: Christoph Burow [aut, cre],
+ R Luminescence Package Team [ctb],
+ Jan Odvarko [cph] (jscolor.js in www/jscolor),
+ AnalytixWare [cph] (ShinySky package)
+Authors at R: c(
+ person("Christoph", "Burow", role = c("aut", "cre"), email = "christoph.burow at uni-koeln.de"),
+ person(family = "R Luminescence Package Team", role = "ctb"),
+ person("Jan", "Odvarko", role = "cph", comment = "jscolor.js in www/jscolor"),
+ person(family = "AnalytixWare", role = "cph", comment = "ShinySky package" )
+ )
+Maintainer: Christoph Burow <christoph.burow at uni-koeln.de>
+Description: A collection of 'shiny' applications for the R package
+ 'Luminescence'. These mainly, but not exclusively, include applications for
+ plotting chronometric data from e.g. luminescence or radiocarbon dating. It
+ further provides access to bootstraps tooltip and popover functionality and
+ contains the 'jscolor.js' library with a custom 'shiny' output binding.
+License: GPL-3
+Depends: R (>= 3.3.0)
+Imports: Luminescence (>= 0.6.1), shiny (>= 0.13.0), googleVis
+URL: https://github.com/tzerk/RLumShiny
+BugReports: https://github.com/tzerk/RLumShiny/issues
+Collate: 'app_RLum.R' 'jscolor.R' 'tooltip.R' 'popover.R' 'RLumShiny.R'
+ 'zzz.R'
+RoxygenNote: 5.0.1
+NeedsCompilation: no
+Packaged: 2016-07-20 11:44:33 UTC; C
+Repository: CRAN
+Date/Publication: 2016-07-20 17:49:32
diff --git a/LICENSE.note b/LICENSE.note
new file mode 100644
index 0000000..22c6771
--- /dev/null
+++ b/LICENSE.note
@@ -0,0 +1,8 @@
+The RLumShiny package as a whole is distributed under GPL-3 (GNU GENERAL PUBLIC
+LICENSE version 3).
+
+The RLumShiny package includes other open source software components. The following
+is a list of these components:
+
+- JSColor, https://github.com/odvarko/jscolor, GPLv3 License
+- ShinySky, https://github.com/AnalytixWare/ShinySky, MIT license (YEAR: 2015, COPYRIGHT HOLDER: AnalytixWare)
\ No newline at end of file
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..e77fd4f
--- /dev/null
+++ b/MD5
@@ -0,0 +1,75 @@
+b31dad9d180f358e35c8090fdc67db6f *DESCRIPTION
+169bcfd11b1dec13dd628e79e62246e9 *LICENSE.note
+6e84e2cce040a76763339a1b0cddf348 *NAMESPACE
+85e91fcfd362a884e9fa1d582112165a *NEWS
+3d1bec88a71b4a8a0c4e5d7bd054b502 *R/RLumShiny.R
+21e88311767f846a476095d7b9f009e9 *R/app_RLum.R
+a878807dcc583adb8935a64c3e1d9822 *R/jscolor.R
+0bdb6871c2e699e059468161a966eae5 *R/popover.R
+03b8c4d68b292f24a2e73ef33476d13c *R/tooltip.R
+dba18dc70f5abb65198f35e1796205c8 *R/zzz.R
+426cd9b7a3a4039aa3ee977f155b0b9c *inst/shiny/KDE/server.R
+8412263bf9f1a01a58bce253429407de *inst/shiny/KDE/ui.R
+f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/KDE/www/GitHub-Mark-32px.png
+8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/KDE/www/RL_Logo.png
+8ddc3437553d0ef7626eff7aa244d2ff *inst/shiny/KDE/www/file_containsHeader.png
+a7956fba543bb0eff0b039ab1d47cea9 *inst/shiny/KDE/www/file_sep.png
+c05a4e64db3488e7db6618c89fb1a170 *inst/shiny/KDE/www/file_structure.png
+0484b200c6ca1d347c441a0bc4ec61ae *inst/shiny/KDE/www/style.css
+3571df6af15fe7e06c80a9202cf3d675 *inst/shiny/abanico/server.R
+6a9d977633cb10c48273c019ba4d1a92 *inst/shiny/abanico/ui.R
+f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/abanico/www/GitHub-Mark-32px.png
+8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/abanico/www/RL_Logo.png
+8ddc3437553d0ef7626eff7aa244d2ff *inst/shiny/abanico/www/file_containsHeader.png
+a7956fba543bb0eff0b039ab1d47cea9 *inst/shiny/abanico/www/file_sep.png
+c05a4e64db3488e7db6618c89fb1a170 *inst/shiny/abanico/www/file_structure.png
+0484b200c6ca1d347c441a0bc4ec61ae *inst/shiny/abanico/www/style.css
+0e24f11677db867088c3e9ae3c834668 *inst/shiny/cosmicdose/server.R
+d52414852639bd46140bb66b46ef896d *inst/shiny/cosmicdose/ui.R
+8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/cosmicdose/www/RL_Logo.png
+6b1c92b7ba57d5fc11df0f953708d755 *inst/shiny/cosmicdose/www/RL_Logo_alpha.png
+c436a9168d2cad8d1ebffdb09b1b3cbd *inst/shiny/cosmicdose/www/style.css
+63955dd38d8f52c55ae7485905043652 *inst/shiny/doserecovery/server.R
+8a1e18aa108c10d4706cbfc6fc6b98df *inst/shiny/doserecovery/ui.R
+f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/doserecovery/www/GitHub-Mark-32px.png
+8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/doserecovery/www/RL_Logo.png
+8ddc3437553d0ef7626eff7aa244d2ff *inst/shiny/doserecovery/www/file_containsHeader.png
+a7956fba543bb0eff0b039ab1d47cea9 *inst/shiny/doserecovery/www/file_sep.png
+c05a4e64db3488e7db6618c89fb1a170 *inst/shiny/doserecovery/www/file_structure.png
+0484b200c6ca1d347c441a0bc4ec61ae *inst/shiny/doserecovery/www/style.css
+471df62e0a25e990b91a7f303da800b0 *inst/shiny/histogram/server.R
+40471ccdf272206260a4bd6d8f9c224c *inst/shiny/histogram/ui.R
+f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/histogram/www/GitHub-Mark-32px.png
+8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/histogram/www/RL_Logo.png
+8ddc3437553d0ef7626eff7aa244d2ff *inst/shiny/histogram/www/file_containsHeader.png
+a7956fba543bb0eff0b039ab1d47cea9 *inst/shiny/histogram/www/file_sep.png
+c05a4e64db3488e7db6618c89fb1a170 *inst/shiny/histogram/www/file_structure.png
+4954811f0c422b9f6ad435dc2da40387 *inst/shiny/histogram/www/style.css
+1ce322c54d600b2285cfb1cbb96c3769 *inst/shiny/radialplot/server.R
+04507bc5e4eeeac559c39a6b8a1daf17 *inst/shiny/radialplot/ui.R
+f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/radialplot/www/GitHub-Mark-32px.png
+8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/radialplot/www/RL_Logo.png
+8ddc3437553d0ef7626eff7aa244d2ff *inst/shiny/radialplot/www/file_containsHeader.png
+a7956fba543bb0eff0b039ab1d47cea9 *inst/shiny/radialplot/www/file_sep.png
+c05a4e64db3488e7db6618c89fb1a170 *inst/shiny/radialplot/www/file_structure.png
+0484b200c6ca1d347c441a0bc4ec61ae *inst/shiny/radialplot/www/style.css
+ace6cd681dc2f867c56ed3a2daf40c76 *inst/shiny/transformCW/Server.R
+2db6aa46a78d8476cefd417c321abee5 *inst/shiny/transformCW/UI.R
+f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/transformCW/www/GitHub-Mark-32px.png
+8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/transformCW/www/RL_Logo.png
+8ddc3437553d0ef7626eff7aa244d2ff *inst/shiny/transformCW/www/file_containsHeader.png
+a7956fba543bb0eff0b039ab1d47cea9 *inst/shiny/transformCW/www/file_sep.png
+c05a4e64db3488e7db6618c89fb1a170 *inst/shiny/transformCW/www/file_structure.png
+0484b200c6ca1d347c441a0bc4ec61ae *inst/shiny/transformCW/www/style.css
+5034704a76cd55c1cbcbc58ea6bf523f *inst/www/jscolor/arrow.gif
+ba9a274b9323753cd95bc3b1eb2f4e5f *inst/www/jscolor/cross.gif
+edf71251cb2be20322d2efb00aee86a6 *inst/www/jscolor/demo.html
+fefa1a03d92ebad25c88dca94a0b63db *inst/www/jscolor/hs.png
+990d71cada17da100653636cf8490884 *inst/www/jscolor/hv.png
+a26701f49bf33da8dc48f3431e5f4f42 *inst/www/jscolor/jscolor.js
+c6dfa9f374d4d64208939fcfdd2df004 *inst/www/jscolor_inputBinding.js
+49bda292d3795630535903a90d8e66bc *man/RLumShiny-package.Rd
+7306c9486450b8903d152dc759750ba1 *man/app_RLum.Rd
+faeb4e8e0fc6f9f8c07234c16d375ea3 *man/jscolorInput.Rd
+97df0a79b3b90002315fe6b89a352394 *man/popover.Rd
+835b706498806e9419cdb65830634f77 *man/tooltip.Rd
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..5917f57
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,9 @@
+# Generated by roxygen2: do not edit by hand
+
+export(app_RLum)
+export(jscolorInput)
+export(popover)
+export(tooltip)
+import(Luminescence)
+import(googleVis)
+import(shiny)
diff --git a/NEWS b/NEWS
new file mode 100644
index 0000000..1ff17a4
--- /dev/null
+++ b/NEWS
@@ -0,0 +1,30 @@
+RLumShiny 0.1.1 (Release date: 2016-07-20)
+==============
+
+* New application to transform CW OSL curves (keyword 'transformCW') using the
+ functions 'CW2pHMi', 'CW2pLM', 'CW2pLMi' and 'CW2pPMi' of the R package
+ 'Luminescence'.
+
+* Removed UI elements that used now deprecated function arguments.
+
+* Added new UI elements for arguments added to functions after version 0.4.2 of
+ the 'Luminescence' package.
+
+* Removed the database feature in the abanico plot application.
+
+* Removed dependencies on 'digest' and 'RCurl'.
+
+* Removed all 'Exit' buttons.
+
+* Code output to reproduce the plots is now generated dynamically and should
+ be more reliable.
+
+* R Luminescence Package Team now properly mentioned as contributors.
+
+* Fixed many typos.
+
+
+RLumShiny 0.1.0 (Release date: 2015-03-31)
+==============
+
+* Initial release
\ No newline at end of file
diff --git a/R/RLumShiny.R b/R/RLumShiny.R
new file mode 100644
index 0000000..38db879
--- /dev/null
+++ b/R/RLumShiny.R
@@ -0,0 +1,21 @@
+#' Shiny Applications for the R Package Luminescence
+#'
+#' A collection of shiny applications for the R package Luminescence.
+#' These mainly, but not exclusively, include applications for plotting chronometric
+#' data from e.g. luminescence or radiocarbon dating. It further provides access to
+#' bootstraps tooltip and popover functionality as well as a binding to JSColor.
+#'
+#' In addition to its main purpose of providing convenient access to the Luminescence
+#' shiny applications (see \code{\link{app_RLum}}) this package also provides further functions to extend the
+#' functionality of shiny. From the Bootstrap framework the JavaScript tooltip and popover
+#' components can be added to any shiny application via \code{\link{tooltip}} and \code{\link{popover}}.
+#' It further provides a custom input binding to the JavaScript/HTML color picker JSColor.
+#' Offering access to most options provided by the JSColor API the function \code{\link{jscolorInput}}
+#' is easily implemented in a shiny app. RGB colors are returned as hex values and can be
+#' directly used in R's base plotting functions without the need of any format conversion.
+#'
+#' @name RLumShiny-package
+#' @aliases RLumShiny
+#' @docType package
+#' @import Luminescence shiny googleVis
+NULL
\ No newline at end of file
diff --git a/R/app_RLum.R b/R/app_RLum.R
new file mode 100644
index 0000000..0795529
--- /dev/null
+++ b/R/app_RLum.R
@@ -0,0 +1,59 @@
+#' Run Luminescence shiny apps
+#'
+#' A wrapper for \code{\link{runApp}} to start interactive shiny apps for the R package Luminescence.
+#'
+#' The RLumShiny package provides a single function from which all shiny apps can be started: \code{app_RLum()}.
+#' It essentially only takes one argument, which is a unique keyword specifying which application to start.
+#' See the table below for a list of available shiny apps and which keywords to use.
+#'
+#' \tabular{lcl}{
+#' \bold{Application name:} \tab \bold{Keyword:} \tab \bold{Function:} \cr
+#' Abanico Plot \tab \emph{abanico} \tab \code{\link{plot_AbanicoPlot}} \cr
+#' Histogram \tab \emph{histogram} \tab \code{\link{plot_Histogram}} \cr
+#' Kernel Density Estimate Plot \tab \emph{KDE} \tab \code{\link{plot_KDE}} \cr
+#' Radial Plot \tab \emph{radialplot} \tab \code{\link{plot_RadialPlot}} \cr
+#' Dose Recovery Test \tab \emph{doserecovery} \tab \code{\link{plot_DRTResults}} \cr
+#' Cosmic Dose Rate \tab \emph{cosmicdose} \tab \code{\link{calc_CosmicDoseRate}} \cr
+#' CW Curve Transformation \tab \emph{transformCW} \tab \code{\link{CW2pHMi}, \link{CW2pLM}, \link{CW2pLMi}, \link{CW2pPMi}}
+#' }
+#'
+#' The \code{app_RLum()} function is just a wrapper for \code{\link{runApp}}.
+#' Via the \code{...} argument further arguments can be directly passed to \code{\link{runApp}}.
+#' See \code{?shiny::runApp} for further details on valid arguments.
+#'
+#' @param app \code{\link{character}} (required): name of the application to start. See details for a list
+#' of available apps.
+#' @param ... further arguments to pass to \code{\link{runApp}}
+#' @author Christoph Burow, University of Cologne (Germany)
+#' @seealso \code{\link{runApp}}
+#' @examples
+#'
+#' \dontrun{
+#' # Plotting apps
+#' app_RLum("abanico")
+#' app_RLum("histogram")
+#' app_RLum("KDE")
+#' app_RLum("radialplot")
+#' app_RLum("doserecovery")
+#'
+#' # Further apps
+#' app_RLum("cosmicdose")
+#' }
+#'
+#' @export app_RLum
+app_RLum <- function(app, ...) {
+
+ valid_apps <- c("abanico",
+ "cosmicdose",
+ "doserecovery",
+ "histogram",
+ "KDE",
+ "radialplot",
+ "transformCW")
+
+ if (!app %in% valid_apps)
+ return(message(paste0("Invalid app name: ", app, " \n Valid options are: ", paste(valid_apps, collapse = ", "))))
+
+ app <- shiny::runApp(system.file(paste0("shiny/", app), package = "RLumShiny"), launch.browser = TRUE, ...)
+
+}
\ No newline at end of file
diff --git a/R/jscolor.R b/R/jscolor.R
new file mode 100644
index 0000000..9992b68
--- /dev/null
+++ b/R/jscolor.R
@@ -0,0 +1,52 @@
+#' Create a JSColor picker input widget
+#'
+#' Creates a JSColor (Javascript/HTML Color Picker) widget to be used in shiny applications.
+#'
+#' @param inputId \code{\link{character}} (required): Specifies the input slot that will be used to access the value.
+#' @param label \code{\link{character}}: Display label for the control, or NULL for no label.
+#' @param value \code{\link{character}}: Initial RGB value of the color picker. Default is black ('#000000').
+#' @param position \code{\link{character}}: Position of the picker relative to the text input ('bottom', 'left', 'top', 'right').
+#' @param color \code{\link{character}}: Picker color scheme ('transparent' by default). Use RGB color coding ('000000').
+#' @param mode \code{\link{character}}: Mode of hue, saturation and value. Can either be 'HSV' or 'HVS'.
+#' @param slider \code{\link{logical}}: Show or hide the slider.
+#' @param close \code{\link{logical}}: Show or hide a close button.
+#'
+#' @seealso Other input.elements: \code{\link{animationOptions}}, \code{\link{sliderInput}};
+#' \code{\link{checkboxGroupInput}}; \code{\link{checkboxInput}}; \code{\link{dateInput}};
+#' \code{\link{dateRangeInput}}; \code{\link{fileInput}}; \code{\link{numericInput}};
+#' \code{\link{passwordInput}}; \code{\link{radioButtons}}; \code{\link{selectInput}},
+#' \code{\link{selectizeInput}}; \code{\link{submitButton}}; \code{\link{textInput}}
+#'
+#' @examples
+#' # html code
+#' jscolorInput("col", "Color", "21BF6B", slider = FALSE)
+#'
+#' # example app
+#' \dontrun{
+#' shinyApp(
+#' ui = fluidPage(
+#' jscolorInput(inputId = "col", label = "JSColor Picker",
+#' value = "21BF6B", position = "right",
+#' mode = "HVS", close = TRUE),
+#' plotOutput("plot")
+#' ),
+#' server = function(input, output) {
+#' output$plot <- renderPlot({
+#' plot(cars, col = input$col, cex = 2, pch = 16)
+#' })
+#' })
+#' }
+#' @import shiny
+#' @export
+jscolorInput <- function(inputId, label, value, position = 'bottom', color = 'transparent', mode = 'HSV', slider = TRUE, close = FALSE) {
+ tagList(
+ singleton(tags$head(tags$script(src = "RLumShiny/jscolor_inputBinding.js"))),
+ singleton(tags$head(tags$script(src = "RLumShiny/jscolor/jscolor.js"))),
+ if (missing(label)) { tags$p(" ") } else if (!is.null(label)) { tags$p(label) },
+ tags$input(id = inputId,
+ value = ifelse(!missing(value), value, "#000000"),
+ class = sprintf("color {hash:true, pickerPosition:'%s', pickerBorderColor:'transparent', pickerFaceColor:'%s', pickerMode:'%s', slider:%s, pickerClosable:%s} shiny-bound-input", position, color, mode, tolower(slider), tolower(close)),
+ onchange = sprintf("$('#%s').trigger('afterChange')", inputId)),
+ tags$script(sprintf("$('#%s').trigger('afterChange')", inputId))
+ )
+}
\ No newline at end of file
diff --git a/R/popover.R b/R/popover.R
new file mode 100644
index 0000000..d286194
--- /dev/null
+++ b/R/popover.R
@@ -0,0 +1,57 @@
+#' Create a bootstrap button with popover
+#'
+#' Add small overlays of content for housing secondary information.
+#'
+#' @param title \code{\link{character}} (required): Title of the button.
+#' @param content \code{\link{character}}: Text to be displayed in the popover.
+#' @param header \code{\link{character}}: Optional header in the popover.
+#' @param html \code{\link{logical}} Insert HTML into the popover.
+#' @param class \code{\link{logical}} Bootstrap button class (e.g. "btn btn-danger").
+#' @param placement \code{\link{character}}: How to position the popover - top | bottom | left | right | auto. When "auto" is specified, it will dynamically reorient the popover. For example, if placement is "auto left", the popover will display to the left when possible, otherwise it will display right.
+#' @param trigger \code{\link{character}}: How popover is triggered - click | hover | focus | manual.
+#'
+#' @examples
+#' # html code
+#' popover("title", "Some content")
+#'
+#' # example app
+#' \dontrun{
+#' shinyApp(
+#' ui = fluidPage(
+#' jscolorInput(inputId = "col", label = "JSColor Picker",
+#' value = "21BF6B", position = "right",
+#' mode = "HVS", close = TRUE),
+#' popover(title = "Help!", content = "Call 911"),
+#' plotOutput("plot")
+#' ),
+#' server = function(input, output) {
+#' output$plot <- renderPlot({
+#' plot(cars, col = input$col, cex = 2, pch = 16)
+#' })
+#' })
+#' }
+#' @import shiny
+#' @export
+popover <- function(title, content, header = NULL, html = TRUE,
+ class = "btn btn-default",
+ placement = c('right', 'top', 'left', 'bottom'),
+ trigger = c('click', 'hover', 'focus', 'manual')) {
+
+ tagList(
+ singleton(
+ tags$head(
+ tags$script("$(function() { $(\"[data-toggle='popover']\").popover(); })")
+ )
+ ),
+ tags$a(
+ tabindex = "0", href = NULL, role = "button", class = class, `data-toggle` = "popover",
+ title = header, `data-content` = content, `data-animation` = TRUE, html = html,
+ `data-placement` = match.arg(placement, several.ok=TRUE)[1],
+ `data-trigger` = match.arg(trigger, several.ok=TRUE)[1],
+ title
+ )
+ )
+}
+# helpPopup Button by Winston Chang from RStudio:
+# https://gist.github.com/jcheng5/5913297
+# Documentation: http://getbootstrap.com/javascript/#popovers-usage
\ No newline at end of file
diff --git a/R/tooltip.R b/R/tooltip.R
new file mode 100644
index 0000000..5c5759c
--- /dev/null
+++ b/R/tooltip.R
@@ -0,0 +1,63 @@
+#' Create a bootstrap tooltip
+#'
+#' Create bootstrap tooltips for any HTML element to be used in shiny applications.
+#'
+#' @param refId \code{\link{character}} (required): id of the element the tooltip is to be attached to.
+#' @param text \code{\link{character}}: Text to be displayed in the tooltip.
+#' @param attr \code{\link{character}}: Attach tooltip to all elements with attribute \code{attr='refId'}.
+#' @param animation \code{\link{logical}}: Apply a CSS fade transition to the tooltip.
+#' @param delay \code{\link{numeric}}: Delay showing and hiding the tooltip (ms).
+#' @param html \code{\link{logical}}: Insert HTML into the tooltip.
+#' @param placement \code{\link{character}}: How to position the tooltip - top | bottom | left | right | auto. When 'auto' is specified, it will dynamically reorient the tooltip. For example, if placement is 'auto left', the tooltip will display to the left when possible, otherwise it will display right.
+#' @param trigger \code{\link{character}}: How tooltip is triggered - click | hover | focus | manual. You may pass multiple triggers; separate them with a space.
+#'
+#' @examples
+#' # javascript code
+#' tt <- tooltip("elementId", "This is a tooltip.")
+#' str(tt)
+#'
+#' # example app
+#' \dontrun{
+#' shinyApp(
+#' ui = fluidPage(
+#' jscolorInput(inputId = "col", label = "JSColor Picker",
+#' value = "21BF6B", position = "right",
+#' mode = "HVS", close = TRUE),
+#' tooltip("col", "This is a JScolor widget"),
+#'
+#' checkboxInput("cbox", "Checkbox", FALSE),
+#' tooltip("cbox", "This is a checkbox"),
+#'
+#' checkboxGroupInput("cboxg", "Checkbox group", selected = "a",
+#' choices = c("a" = "a",
+#' "b" = "b",
+#' "c" = "c")),
+#' tooltip("cboxg", "This is a <b>checkbox group</b>", html = TRUE),
+#'
+#' selectInput("select", "Selectinput", selected = "a", choices = c("a"="a", "b"="b")),
+#' tooltip("select", "This is a text input field", attr = "for", placement = "right"),
+#'
+#' passwordInput("pwIn", "Passwordinput"),
+#' tooltip("pwIn", "This is a password input field"),
+#'
+#' plotOutput("plot")
+#' ),
+#' server = function(input, output) {
+#' output$plot <- renderPlot({
+#' plot(cars, col = input$col, cex = 2, pch = 16)
+#' })
+#' })
+#' }
+#' @import shiny
+#' @export
+tooltip <- function(refId, text, attr = NULL, animation = TRUE, delay = 100, html = TRUE, placement = 'auto', trigger = 'hover') {
+ if (is.null(attr))
+ el <- sprintf("'#%s'", refId)
+ else
+ el <- sprintf("\"[%s='%s']\"", attr, refId)
+
+ tagList(
+ tags$head(tags$script(HTML(sprintf("$(window).load(function(){ $(%s).tooltip({ html: %s, trigger: '%s', title: '%s', animation: %s, delay: {'show': %i, 'hide': %i}, placement: '%s' }); })",
+ el, tolower(html), trigger, text, tolower(animation), delay, delay, placement))))
+ )
+}
\ No newline at end of file
diff --git a/R/zzz.R b/R/zzz.R
new file mode 100644
index 0000000..15b7953
--- /dev/null
+++ b/R/zzz.R
@@ -0,0 +1,12 @@
+# add libraries to ressource path
+.onLoad <- function(libname, pkgname) {
+ shiny::addResourcePath("RLumShiny", system.file("www", package = "RLumShiny"))
+}
+
+# Dependencies in the shiny apps are currently not registered by R CMD check --as-cran
+.satisfyCheck <- function() {
+ x <- TRUE
+ if (x) return(x)
+ Luminescence::sTeve()
+ googleVis::renderGvis()
+}
\ No newline at end of file
diff --git a/debian/changelog b/debian/changelog
deleted file mode 100644
index 2259b93..0000000
--- a/debian/changelog
+++ /dev/null
@@ -1,14 +0,0 @@
-r-cran-rlumshiny (0.1.1-1) unstable; urgency=medium
-
- * New upstream version
- * Convert to dh-r
- * Canonical homepage for CRAN
- * d/watch: version=4
-
- -- Andreas Tille <tille at debian.org> Wed, 16 Nov 2016 13:11:31 +0100
-
-r-cran-rlumshiny (0.1.0-1) unstable; urgency=low
-
- * Initial release (closes: #830059)
-
- -- Andreas Tille <tille at debian.org> Wed, 06 Jul 2016 19:11:48 +0200
diff --git a/debian/compat b/debian/compat
deleted file mode 100644
index ec63514..0000000
--- a/debian/compat
+++ /dev/null
@@ -1 +0,0 @@
-9
diff --git a/debian/control b/debian/control
deleted file mode 100644
index 9f2f1c2..0000000
--- a/debian/control
+++ /dev/null
@@ -1,32 +0,0 @@
-Source: r-cran-rlumshiny
-Maintainer: Debian Med Packaging Team <debian-med-packaging at lists.alioth.debian.org>
-Uploaders: Andreas Tille <tille at debian.org>
-Section: gnu-r
-Priority: optional
-Build-Depends: debhelper (>= 9),
- dh-r,
- r-base-dev,
- r-cran-digest,
- r-cran-googlevis,
- r-cran-luminescence,
- r-cran-rcurl,
- r-cran-shiny
-Standards-Version: 3.9.8
-Vcs-Browser: https://anonscm.debian.org/viewvc/debian-med/trunk/packages/R/r-cran-rlumshiny/trunk/
-Vcs-Svn: svn://anonscm.debian.org/debian-med/trunk/packages/R/r-cran-rlumshiny/trunk/
-Homepage: https://cran.r-project.org/package=RLumShiny
-
-Package: r-cran-rlumshiny
-Architecture: any
-Depends: ${shlibs:Depends},
- ${misc:Depends},
- ${R:Depends}
-Recommends: ${R:Recommends}
-Suggests: ${R:Suggests}
-Description: GNU R 'Shiny' Applications for the R Package 'Luminescence'
- A collection of 'shiny' applications for the R package 'Luminescence'.
- These mainly, but not exclusively, include applications for plotting
- chronometric data from e.g. luminescence or radiocarbon dating. It
- further provides access to bootstraps tooltip and popover
- functionality and contains the 'jscolor.js' library with a custom
- 'shiny' output binding.
diff --git a/debian/copyright b/debian/copyright
deleted file mode 100644
index e022f7a..0000000
--- a/debian/copyright
+++ /dev/null
@@ -1,63 +0,0 @@
-Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
-Upstream-Name: RLumShiny
-Upstream-Contact: Christoph Burow <christoph.burow at uni-koeln.de>
-Source: https://cran.r-project.org/package=RLumShiny
-
-Files: *
-Copyright: 2013-2016 Christoph Burow
-License: GPL-3
-
-Files: inst/www/jscolor/jscolor.js
-Copyright: 2008-2014 Jan Odvarko
-License: LGPL-3
- This program is free software: you can redistribute it and/or modify it under
- the terms of the GNU Lesser General Public License as published by the Free
- Software Foundation version 3 of the License. This program is distributed in
- the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
- implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- .
- On Debian systems you can find the full text of the GNU Lesser General
- Public License version 3 license at /usr/share/common-licenses/LGPL-3.
-
-Files: inst/shiny/*
-Copyright: 2013-2016 AnalytixWare
-License: MIT
- Permission is hereby granted, free of charge, to any person obtaining a
- copy of this software and associated documentation files (the
- "Software"), to deal in the Software without restriction, including
- without limitation the rights to use, copy, modify, merge, publish,
- distribute, sublicense, and/or sell copies of the Software, and to
- permit persons to whom the Software is furnished to do so, subject to
- the following conditions:
- .
- The above copyright notice and this permission notice shall be included
- in all copies or substantial portions of the Software.
- .
- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-
-Files: debian/*
-Copyright: 2016 Andreas Tille <tille at debian.org>
-License: GPL-3
-
-License: GPL-3
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 3 of the License.
- .
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- .
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
- .
- On Debian systems, the complete text of the GNU General Public
- License can be found in `/usr/share/common-licenses/GPL-3'.
diff --git a/debian/rules b/debian/rules
deleted file mode 100755
index 68d9a36..0000000
--- a/debian/rules
+++ /dev/null
@@ -1,4 +0,0 @@
-#!/usr/bin/make -f
-
-%:
- dh $@ --buildsystem R
diff --git a/debian/source/format b/debian/source/format
deleted file mode 100644
index 163aaf8..0000000
--- a/debian/source/format
+++ /dev/null
@@ -1 +0,0 @@
-3.0 (quilt)
diff --git a/debian/watch b/debian/watch
deleted file mode 100644
index d27551a..0000000
--- a/debian/watch
+++ /dev/null
@@ -1,2 +0,0 @@
-version=4
-http://cran.r-project.org/src/contrib/RLumShiny_([-\d.]*)\.tar\.gz
diff --git a/inst/shiny/KDE/server.R b/inst/shiny/KDE/server.R
new file mode 100644
index 0000000..f8ee75b
--- /dev/null
+++ b/inst/shiny/KDE/server.R
@@ -0,0 +1,385 @@
+## Server.R
+library(Luminescence)
+library(shiny)
+
+# load example data
+data(ExampleData.DeValues)
+data <- list(ExampleData.DeValues$CA1, ExampleData.DeValues$CA1)
+
+## MAIN FUNCTION
+shinyServer(function(input, output, session) {
+
+ # check and read in file (DATA SET 1)
+ datGet<- reactive({
+ inFile<- input$file1
+ if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL
+ return(read.table(file = inFile$datapath, # inFile[1] contains filepath
+ sep = input$sep,
+ quote = "",
+ header = input$headers)) # else return file
+ })
+
+ # check and read in file (DATA SET 2)
+ datGet2<- reactive({
+ inFile2<- input$file2
+ if(is.null(inFile2)) return(NULL) # if no file was uploaded return NULL
+ return(read.table(file = inFile2$datapath, # inFile[1] contains filepath
+ sep = input$sep,
+ quote = "",
+ header = input$headers)) # else return file
+ })
+
+
+ # dynamically inject sliderInput for x-axis range
+ output$xlim<- renderUI({
+
+ # check if file is loaded
+ # # case 1: yes -> slinderInput with custom values
+ if(!is.null(datGet())) {
+ if(!is.null(datGet2())) {
+
+ data<- rbind(datGet(),datGet2())
+
+ sliderInput(inputId = "xlim",
+ label = "Range x-axis",
+ min = min(data[,1])*0.25,
+ max = max(data[,1])*1.75,
+ value = c(min(data[,1])*0.9, max(data[,1])*1.1))
+
+ } else {
+ data<- datGet()
+
+ sliderInput(inputId = "xlim",
+ label = "Range x-axis",
+ min = min(data[,1])*0.25,
+ max = max(data[,1])*1.75,
+ value = c(min(data[,1])*0.9, max(data[,1])*1.1))
+ }
+ }
+
+ else { #case 2: no -> sliderInput for example data
+
+ sliderInput(inputId = "xlim",
+ label = "Range x-axis",
+ min = min(data[[1]][,1])*0.25,
+ max = max(data[[1]][,1])*1.75,
+ value = c(min(data[[1]][,1])*0.9, max(data[[1]][,1]))*1.05,
+ step = 1, round = 0)
+ }
+ })## EndOf::renderUI()
+
+ # dynamically inject sliderInput for KDE bandwidth
+ output$bw<- renderUI({
+
+ # check if file is loaded
+ # # case 1: yes -> slinderInput with custom values
+ if(!is.null(datGet())) {
+ if(!is.null(datGet2())) {
+ data<- rbind(datGet(),datGet2())
+
+ sliderInput(inputId = "bw",
+ label = "KDE bandwidth",
+ min = bw.nrd0(data[,1])/4,
+ max = bw.nrd0(data[,1])*4,
+ value = bw.nrd0(data[,1]))
+
+ } else {
+
+ data<- datGet()
+
+ sliderInput(inputId = "bw",
+ label = "KDE bandwidth",
+ min = bw.nrd0(data[,1])/4,
+ max = bw.nrd0(data[,1])*4,
+ value = bw.nrd0(data[,1]))
+ }
+ }
+
+ else { #case 2: no -> sliderInput for example data
+ # logged data
+
+ sliderInput(inputId = "bw",
+ label = "KDE bandwidth",
+ min = 1, max = 100,
+ value = 15, step = 1)
+ }
+ })## EndOf::renderUI()
+
+ output$main_plot <- renderPlot({
+
+ # refresh plot on button press
+ input$refresh
+
+ # progress bar
+ progress<- Progress$new(session, min = 0, max = 3)
+ progress$set(message = "Calculation in progress",
+ detail = "Retrieve data")
+ on.exit(progress$close())
+
+ # make sure that input panels are registered on non-active tabs.
+ # by default tabs are suspended and input variables are hence
+ # not available
+ outputOptions(x = output, name = "xlim", suspendWhenHidden = FALSE)
+ outputOptions(x = output, name = "bw", suspendWhenHidden = FALSE)
+
+ # check if file is loaded and overwrite example data
+ if(!is.null(datGet())) {
+ data<- list(datGet(), datGet())
+ }
+ if(!is.null(datGet2())) {
+ data2<- datGet2()
+ }
+
+ if(is.null(datGet()) == FALSE && is.null(datGet2()) == FALSE) {
+ data<- datGet()
+ data2<- datGet2()
+ data<- list(data, data2)
+ }
+
+ progress$set(value = 1)
+ progress$set(message = "Calculation in progress",
+ detail = "Get values")
+
+
+ # check if any summary stats are activated, else NA
+ if (input$summary) {
+ summary<- input$stats
+ } else {
+ summary<- ""
+ }
+
+ if(input$logx == TRUE) {
+ logx<- "x"
+ } else {
+ logx<- ""
+ }
+
+
+ # update progress bar
+ progress$set(value = 2)
+ progress$set(message = "Calculation in progress",
+ detail = "Combine values")
+
+ # if custom datapoint color get RGB code from separate input panel
+ if(input$color == "custom") {
+ color<- input$rgb
+ } else {
+ color<- input$color
+ }
+
+ if(!is.null(datGet2())) {
+ # if custom datapoint color get RGB code from separate input panel
+ if(input$color2 == "custom") {
+ color2<- input$rgb2
+ } else {
+ color2<- input$color2
+ }
+ } else {
+ color2<- adjustcolor("white", alpha.f = 0)
+ }
+
+
+ # validate(need()) makes sure that all data are available to
+ # renderUI({}) before plotting and will wait until there
+ validate(
+ need(expr = input$xlim, message = 'Waiting for data... Please wait!'),
+ need(expr = input$bw, message = 'Waiting for data... Please wait!')
+ )
+
+ progress$set(value = 3)
+ progress$set(message = "Calculation in progress",
+ detail = "Ready to plot")
+
+ args <- list(data = data,
+ cex = input$cex,
+ log = logx,
+ xlab = input$xlab,
+ ylab = c(input$ylab1, input$ylab2),
+ main = input$main,
+ values.cumulative = input$cumulative,
+ na.rm = input$naExclude,
+ rug = input$rug,
+ boxplot = input$boxplot,
+ summary = summary,
+ summary.pos = input$sumpos,
+ summary.method = input$summary.method,
+ bw = input$bw,
+ xlim = input$xlim,
+ col = c(color, color2))
+
+ do.call(plot_KDE, args = args)
+
+
+ # prepare code as text output
+ if (is.null(input$sep))
+ updateRadioButtons(session, "fileformat", selected = "\t")
+
+ if(input$sep == "\t")
+ verb.sep<- "\\t"
+ else
+ verb.sep<- input$sep
+
+ str1 <- paste("data <- read.delim(file, header = ",input$headers, ", sep= '", verb.sep,"')",
+ sep = "")
+
+ if(!is.null(datGet2())) {
+ str2 <- "file2<- file.choose()"
+ str3 <- paste("data2 <- read.delim(file2, header = ",input$headers, ", sep= '", verb.sep,"')",
+ sep= "")
+ str4 <- "data<- list(data, data2)"
+ str1 <- paste(str1, str2, str3, str4, sep = "\n")
+ }
+
+ header <- paste("# To reproduce the plot in your local R environment",
+ "# copy and run the following code to your R console.",
+ "library(Luminescence)",
+ "file<- file.choose()",
+ str1,
+ "\n",
+ sep = "\n")
+
+ names <- names(args)
+
+ verb.arg <- paste(mapply(function(name, arg) {
+ if (all(inherits(arg, "character")))
+ arg <- paste0("'", arg, "'")
+ if (length(arg) > 1)
+ arg <- paste0("c(", paste(arg, collapse = ", "), ")")
+ if (is.null(arg))
+ arg <- "NULL"
+ paste(name, "=", arg)
+ }, names[-1], args[-1]), collapse = ",\n")
+
+ funCall <- paste0("plot_KDE(data = data,\n", verb.arg, ")")
+
+ code.output <- paste0(header, funCall, collapse = "\n")
+
+
+
+ # nested renderText({}) for code output on "R plot code" tab
+ output$plotCode<- renderText({
+
+ code.output
+
+ })##EndOf::renderText({})
+
+ output$exportScript <- downloadHandler(
+ filename = function() { paste(input$filename, ".", "R", sep="") },
+ content = function(file) {
+ write(code.output, file)
+ },#EO content =,
+ contentType = "text"
+ )#EndOf::dowmloadHandler()
+
+
+ # nested downloadHandler() to print plot to file
+ output$exportFile <- downloadHandler(
+ filename = function() { paste(input$filename, ".", input$fileformat, sep="") },
+ content = function(file) {
+
+ if(is.null(input$fileformat))
+ updateRadioButtons(session, inputId = "fileformat", label = "Fileformat", selected = "pdf")
+
+ # determine desired fileformat and set arguments
+ if(input$fileformat == "pdf") {
+ pdf(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ paper = "special",
+ useDingbats = FALSE,
+ family = input$fontfamily)
+ }
+ if(input$fileformat == "svg") {
+ svg(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ family = input$fontfamily)
+ }
+ if(input$fileformat == "eps") {
+ postscript(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ paper = "special",
+ family = input$fontfamily)
+ }
+
+ do.call(plot_KDE, args = args)
+
+ dev.off()
+
+ },#EO content =,
+ contentType = "image"
+ )#EndOf::dowmloadHandler()
+ })##EndOf::renderPlot({})
+
+
+ # renderTable() that prints the data to the second tab
+ output$dataset<- renderDataTable(
+ options = list(pageLength = 10, autoWidth = FALSE),
+ callback = "function(table) {
+ table.on('click.dt', 'tr', function() {
+ $(this).toggleClass('selected');
+ Shiny.onInputChange('rows',
+ table.rows('.selected').data().toArray());
+ });
+}",
+{
+ if(!is.null(datGet())) {
+ data<- datGet()
+ colnames(data)<- c("De","De error")
+ data
+
+ } else {
+ data<- data[[1]]
+ colnames(data)<- c("De","De error")
+ data
+ }
+})##EndOf::renterTable()
+
+# renderTable() that prints the secondary data to the second tab
+output$dataset2<- renderDataTable(
+ options = list(pageLength = 10, autoWidth = FALSE),
+ callback = "function(table) {
+ table.on('click.dt', 'tr', function() {
+ $(this).toggleClass('selected');
+ Shiny.onInputChange('rows',
+ table.rows('.selected').data().toArray());
+ });
+ }",
+{
+ if(!is.null(datGet2())) {
+ data<- datGet2()
+ colnames(data)<- c("De","De error")
+ data
+ } else {
+ }
+})##EndOf::renterTable()
+
+
+# renderTable() to print the results of the
+# central age model (CAM)
+output$CAM<- renderDataTable(
+ options = list(pageLength = 10, autoWidth = FALSE),
+{
+ if(!is.null(datGet())) {
+ if(!is.null(datGet2())) {
+ data<- list(datGet(), datGet2())
+ } else {
+ data<- list(datGet())
+ }
+ } else {
+ data<- list(data[[1]])
+ }
+ t<- as.data.frame(matrix(nrow = length(data), ncol = 7))
+ colnames(t)<- c("Data set","n", "log data", "Central dose", "SE abs.", "OD (%)", "OD error (%)")
+ res<- lapply(data, function(x) { calc_CentralDose(x, verbose = FALSE, plot = FALSE) })
+ for(i in 1:length(res)) {
+ t[i,1]<- ifelse(i==1,"pimary","secondary")
+ t[i,2]<- length(res[[i]]@data$data[,1])
+ t[i,3]<- res[[i]]@data$args$log
+ t[i,4:7]<- round(res[[i]]@data$summary[1:4],2)
+ }
+ t
+})##EndOf::renterTable()
+
+})##EndOf::shinyServer(function(input, output)
\ No newline at end of file
diff --git a/inst/shiny/KDE/ui.R b/inst/shiny/KDE/ui.R
new file mode 100644
index 0000000..0c06e9d
--- /dev/null
+++ b/inst/shiny/KDE/ui.R
@@ -0,0 +1,300 @@
+library(RLumShiny)
+## UI.R
+
+# load example data
+data(ExampleData.DeValues)
+
+# pageWithSidebar contains three panels:
+# 1 - headerPanel: basically just for a header
+# 2 - sidebarPanel: data input
+# 3 - mainPanel: data output
+pageWithSidebar(
+ # 1 - title = NULL -> Panel will not be shown
+ headerPanel(title = NULL),
+ # 2- width = 5 -> refers to twitters bootstrap grid system
+ # where the the maximum width is 12 that is to be shared between all
+ # elements
+ sidebarPanel(width = 5,
+ # include a tabs in the input panel for easier navigation
+ tabsetPanel(id = "tabs", type = "pill", selected = "Data",
+ # Tab 1: Data input
+ tabPanel("Data",
+ # informational text
+ div(align = "center", h5("Data upload")),
+
+ # file upload button (data set 1)
+ fileInput(inputId = "file1",
+ label = strong("Primary data set"),
+ accept="text/plain"),
+ tooltip(refId = "file1", text = tags$img(src='file_structure.png', width='250px')),
+ # file upload button (data set 2)
+ fileInput(inputId = "file2",
+ label = strong("Secondary data set"),
+ accept="text/plain"),
+ tooltip(refId = "file2", text = tags$img(src='file_structure.png', width='250px')),
+ # informational text
+ div(align = "center", h5("Settings")),
+ fluidRow(
+ column(width = 6,
+ # logical: should NA values be excluded?
+ checkboxInput(inputId = "naExclude",
+ label = "Exclude NA values",
+ value = TRUE),
+ tooltip(refId = "naExclude", text = "Exclude NA values from the data set prior to any further operations.")
+ ),
+ column(width = 6,
+ # logical: file contains headers?
+ checkboxInput(inputId = "headers",
+ label = "File contains headers",
+ value = FALSE),
+ tooltip(refId = "headers", text = tags$img(src='file_containsHeader.png', width='250px'))
+ )),
+ # char: columns separated by tab, space, comma
+ radioButtons("sep", "Separator", selected = "\t", inline = TRUE,
+ c("Tab" = "\t",
+ "Space" = " ",
+ "Comma" = ",",
+ "Semicolon" = ";")),
+ tooltip(refId = "sep", text = tags$img(src='file_sep.png', width='400px'), placement = "auto left"),
+ hr(),
+ actionButton(inputId = "refresh", label = "Refresh", icon = icon("refresh")),
+ tooltip(refId = "refresh", text = "Redraw the plot")
+ ),##EndOf::Tab_1
+
+ # Tab 2: Statistical information
+ tabPanel("Statistics",
+ div(align = "center", h5("Summary")),
+ fluidRow(
+ column(width = 6,
+ checkboxInput(inputId = "summary",
+ label = "Show summary",
+ value = FALSE),
+ tooltip(refId = "summary", text = "Adds numerical output to the plot")
+ ),
+ column(width = 6,
+ selectInput(inputId = "sumpos",
+ label = "Summary position",
+ selected = "topleft",
+ choices = list("Subtitle" = "sub",
+ "Center" = "center",
+ Top=c("Top" = "top",
+ "Top left" = "topleft",
+ "Top right"= "topright"),
+ Bottom=c("Bottom" = "bottom",
+ "Bottom left" = "bottomleft",
+ "Bottom right" = "bottomright")
+ )),
+ tooltip(refId = "sumpos", attr = "for", text = "Position of the statistical summary. The keyword \"Subtitle\" will only work if no plot subtitle is used.")
+ )
+ ),
+
+ selectInput(inputId = "summary.method",
+ label = "Summary method",
+ selected = "unweighted",
+ choices = list("Unweighted" = "unweighted",
+ "Weighted" = "weighted",
+ "Monte Carlo" = "MCM")),
+ tooltip(refId = "summary.method", attr = "for", text = "Keyword indicating the method used to calculate the statistic summary. See calc_Statistics for details."),
+
+ checkboxGroupInput(inputId = "stats",
+ label = "Parameters",
+ selected = c("n","mean"),
+ choices = c("n" = "n",
+ "Mean" = "mean",
+ "Median" = "median",
+ "rel. Standard deviation" = "sd.rel",
+ "abs. Standard deviation" = "sd.abs",
+ "rel. Standard error" = "se.rel",
+ "abs. Standard error" = "se.abs",
+ "Skewness" = "skewness",
+ "Kurtosis" = "kurtosis",
+ "% in 2 sigma range" = "in.2s")),
+ tooltip(refId = "stats", text = "Statistical parameters to be shown in the summary"),
+ div(align = "center", h5("Additional options")),
+
+ checkboxInput(inputId = "cumulative",
+ label = "Show individual data",
+ value = TRUE),
+ tooltip(refId = "cumulative", text = "Show cumulative individual data.")
+
+ ),##EndOf::Tab_2
+
+ # Tab 3: input that refer to the plot rather than the data
+ tabPanel("Plot",
+ div(align = "center", h5("Title")),
+
+ textInput(inputId = "main",
+ label = "Title",
+ value = "KDE Plot"),
+
+ # inject sliderInput from Server.R
+ uiOutput(outputId = "bw"),
+ tooltip(refId = "bw", text = "Bin width of the kernel density estimate"),
+ br(),
+ div(align = "center", h5("Scaling")),
+ sliderInput(inputId = "cex",
+ label = "Scaling factor",
+ min = 0.5, max = 2,
+ value = 1.0, step = 0.1),
+
+ div(align = "center", h5("Further options")),
+ fluidRow(
+ column(width = 6,
+ checkboxInput(inputId = "rug",
+ label = "Add rug",
+ value = TRUE)
+ ),
+ column(width = 6,
+ checkboxInput(inputId = "boxplot",
+ label = "Add boxplot",
+ value = TRUE))
+ )
+ ),##EndOf::Tab_3
+
+ # Tab 4: modify axis parameters
+ tabPanel("Axis",
+ div(align = "center", h5("X-axis")),
+ checkboxInput(inputId = "logx",
+ label = "Logarithmic x-axis",
+ value = FALSE),
+ textInput(inputId = "xlab",
+ label = "Label x-axis",
+ value = "Equivalent dose [Gy]"),
+ # inject sliderInput from Server.R
+ uiOutput(outputId = "xlim"),
+ br(),
+ div(align = "center", h5("Y-axis")),
+ fluidRow(
+ column(width = 6,
+ textInput(inputId = "ylab1",
+ label = "Label y-axis (left)",
+ value = "Density")
+ ),
+ column(width = 6,
+ textInput(inputId = "ylab2",
+ label = "Label y-axis (right)",
+ value = "Cumulative frequency")
+ )
+ )
+ ),##EndOf::Tab_4
+
+ # Tab 5: modify data point representation
+ tabPanel("Datapoints",
+ div(align = "center", h5("Primary data set")),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "color", label = "Datapoint color",
+ choices = list("Black" = "black",
+ "Grey" = "grey50",
+ "Red" = "#b22222",
+ "Green" = "#6E8B3D",
+ "Blue" = "#428bca",
+ "Custom" = "custom"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.color == 'custom'",
+ jscolorInput(inputId = "rgb",
+ label = "Choose a color"))
+ )
+ ),
+ div(align = "center", h5("Secondary data set")),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "color2", label = "Datapoint color",
+ selected = "#b22222",
+ choices = list("Black" = "black",
+ "Grey" = "grey50",
+ "Red" = "#b22222",
+ "Green" = "#6E8B3D",
+ "Blue" = "#428bca",
+ "Custom" = "custom"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.color2 == 'custom'",
+ jscolorInput(inputId = "rgb2",
+ label = "Choose a color"))
+ )
+ )
+ ),##EndOf::Tab_5
+
+ # Tab 9: save plot as pdf, wmf or eps
+ tabPanel("Export",
+ radioButtons(inputId = "fileformat",
+ label = "Fileformat",
+ choices = c("PDF (Portable Document Format)" = "pdf",
+ "SVG (Scalable Vector Graphics)" = "svg",
+ "EPS (Encapsulated Postscript)" = "eps")),
+ textInput(inputId = "filename",
+ label = "Filename",
+ value = "KDE Plot"),
+ fluidRow(
+ column(width = 6,
+ numericInput(inputId = "imgheight",
+ label = "Image height",
+ value = 7)
+ ),
+ column(width = 6,
+ numericInput(inputId = "imgwidth",
+ label = "Image width",
+ value = 7)
+ )
+ ),
+ selectInput(inputId = "fontfamily",
+ label = "Font",
+ selected = "Helvetica",
+ choices = c("Helvetica" = "Helvetica",
+ "Helvetica Narrow" = "Helvetica Narrow",
+ "Times" = "Times",
+ "Courier" = "Courier",
+ "Bookman" = "Bookman",
+ "Palatino" = "Palatino")),
+ tags$hr(),
+ downloadButton(outputId = "exportFile",
+ label = "Download plot"),
+ tags$hr(),
+ helpText("Additionally, you can download a corresponding .R file that contains",
+ "a fully functional script to reproduce the plot in your R environment!"),
+ downloadButton(outputId = "exportScript",
+ label = "Download R script")
+ ),##EndOf::Tab_8
+
+ # Tab 10: further information
+ tabPanel("About",
+ hr(),
+ div(align = "center",
+ # HTML code to include a .png file in the tab; the image file must be in
+ # a subfolder called "wwww"
+ img(src="RL_Logo.png", height = 100, width = 100, alt = "R.Lum"),
+ p("Links:"),
+ a(href = "http://www.r-luminescence.de", "R.Luminescence project page", target="_blank"),
+ br(),
+ a(href = "https://forum.r-luminescence.de", "Message board", target="_blank"),
+ br(),
+ a(href = "http://zerk.canopus.uberspace.de/R.Lum", "Online application", target="_blank"),
+ br(),hr(),
+ img(src='GitHub-Mark-32px.png', width='32px', height='32px'),
+ br(),
+ a(href = "https://github.com/tzerk/RLumShiny/tree/master/inst/shiny/KDE", "See the code at GitHub!", target="_blank")
+ )#/div
+ )##EndOf::Tab_9
+ )##EndOf::tabsetPanel
+ ),##EndOf::sidebarPanel
+
+ # 3 - output panel
+ mainPanel(width = 7,
+ # insert css code inside <head></head> of the generated HTML file:
+ # allow open dropdown menus to reach over the container
+ tags$head(tags$style(type="text/css",".tab-content {overflow: visible;}")),
+ tags$head(includeCSS("www/style.css")),
+ # divide output in separate tabs via tabsetPanel
+ tabsetPanel(
+ tabPanel("Plot", plotOutput(outputId = "main_plot", height = "500px")),
+ tabPanel("Primary data set", dataTableOutput("dataset")),
+ tabPanel("Secondary data set", dataTableOutput("dataset2")),
+ tabPanel("Central Age Model", dataTableOutput("CAM")),
+ tabPanel("R plot code", verbatimTextOutput("plotCode"))
+ )###EndOf::tabsetPanel
+ )##EndOf::mainPanel
+)##EndOf::shinyUI(pageWithSidebar)
\ No newline at end of file
diff --git a/inst/shiny/KDE/www/GitHub-Mark-32px.png b/inst/shiny/KDE/www/GitHub-Mark-32px.png
new file mode 100644
index 0000000..8b25551
Binary files /dev/null and b/inst/shiny/KDE/www/GitHub-Mark-32px.png differ
diff --git a/inst/shiny/KDE/www/RL_Logo.png b/inst/shiny/KDE/www/RL_Logo.png
new file mode 100644
index 0000000..ac0551b
Binary files /dev/null and b/inst/shiny/KDE/www/RL_Logo.png differ
diff --git a/inst/shiny/KDE/www/file_containsHeader.png b/inst/shiny/KDE/www/file_containsHeader.png
new file mode 100644
index 0000000..7abe3d2
Binary files /dev/null and b/inst/shiny/KDE/www/file_containsHeader.png differ
diff --git a/inst/shiny/KDE/www/file_sep.png b/inst/shiny/KDE/www/file_sep.png
new file mode 100644
index 0000000..0297e61
Binary files /dev/null and b/inst/shiny/KDE/www/file_sep.png differ
diff --git a/inst/shiny/KDE/www/file_structure.png b/inst/shiny/KDE/www/file_structure.png
new file mode 100644
index 0000000..5e3b50a
Binary files /dev/null and b/inst/shiny/KDE/www/file_structure.png differ
diff --git a/inst/shiny/KDE/www/style.css b/inst/shiny/KDE/www/style.css
new file mode 100644
index 0000000..295b46c
--- /dev/null
+++ b/inst/shiny/KDE/www/style.css
@@ -0,0 +1,73 @@
+.custom-modal {
+ padding-left: 10px;
+ padding-top: 10px;
+ padding-bottom: 10px;
+ padding-right: 10px;
+ line-height: 200%;
+ background-color: #fff;
+ overflow: visible;
+ position: absolute;
+ z-index: 999;
+ border-radius: 10px;
+ border-style: solid;
+ border-color: #428bca;
+}
+
+.h {
+ font-size: 11px;
+ margin: 0 0 0px;
+}
+
+h5, h6 {
+ color: #428bca;
+ font-weight: 700;
+}
+
+.tooltip-inner {
+ max-width: 450px;
+}
+
+.control-label, .selectize-dropdown, .item, .btn, .uneditable-input, .sorting, .odd, .even, .dataTables-info, .fa, .fa-refresh {
+ font-size: 12px;
+}
+
+.selectize-input {
+ padding: 0px 10px;
+ min-height: 20px;
+}
+
+label, body, input {
+ font-size: 12px;
+ font-weight: 100 !important;
+}
+
+.label, .badge {
+ font-size: 12px;
+ padding: 4px 20px;
+ margin: 10px;
+ line-height: 18px;
+ font-weight: 100 !important;
+}
+
+.label-info, .badge-info {
+background-color: #428bca;
+}
+
+input[type="text"],input[type="number"],input[type="email"],input[type="url"],input[type="search"],input[type="tel"],input[type="color"],.uneditable-input{
+ display:inline-block;
+ height:18px;
+ padding:0px 0px 0px 7px;
+ margin-bottom:10px;
+ font-size: 11px;
+ line-height: 1.5;
+ color:#555;
+ vertical-align:middle;
+ -webkit-border-radius:4px;
+ -moz-border-radius:4px;
+ border-radius:4px
+ }
+
+input,textarea,.uneditable-input{
+ width: auto;
+ }
+
diff --git a/inst/shiny/abanico/server.R b/inst/shiny/abanico/server.R
new file mode 100644
index 0000000..a123ff9
--- /dev/null
+++ b/inst/shiny/abanico/server.R
@@ -0,0 +1,576 @@
+## Server.R
+library(Luminescence)
+library(RLumShiny)
+library(shiny)
+
+# load example data
+data(ExampleData.DeValues, envir = environment())
+data <- ExampleData.DeValues$CA1
+
+## MAIN FUNCTION
+shinyServer(function(input, output, session) {
+
+
+ ### GET DATA SETS
+ Data<- reactive({
+
+ ### GET DATA
+ if(!is.null(datGet())) {
+ if(!is.null(datGet2())) {
+ data<- list(datGet(), datGet2())
+ } else {
+ data<- list(datGet())
+ }
+ } else {
+ data<- list(data)
+ }
+
+
+ ### DATA FILTER
+ input$exclude
+
+ sub<- data
+
+ isolate({
+ filter.prim<- input$filter.prim
+ filter.sec<- input$filter.sec
+ })
+
+ if(!is.null(filter.prim)) {
+ index<- grep(paste(filter.prim, collapse = "|"), data[[1]][,1])
+ sub[[1]]<- data[[1]][-index,]
+ }
+ if(length(data) == 2 && !is.null(filter.sec)) {
+ index<- grep(paste(filter.sec, collapse = "|"), data[[2]][,1])
+ sub[[2]]<- data[[2]][-index,]
+ }
+
+ stillSelected.prim<- filter.prim
+ stillSelected.sec<- filter.sec
+
+ updateSelectInput(session, inputId = "filter.prim", choices = sort(data[[1]][,1]), selected = stillSelected.prim)
+ if(length(data) == 2) {
+ updateSelectInput(session, inputId = "filter.sec", choices = sort(data[[2]][,1]), selected = stillSelected.sec)
+ }
+ data<- sub
+
+ return(data)
+ })
+
+ # check and read in file (DATA SET 1)
+ datGet<- reactive({
+ inFile<- input$file1
+ if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL
+ return(read.table(file = inFile$datapath, # inFile[1] contains filepath
+ sep = input$sep,
+ quote = "",
+ header = input$headers)) # else return file
+ })
+
+ # check and read in file (DATA SET 2)
+ datGet2<- reactive({
+ inFile2<- input$file2
+ if(is.null(inFile2)) return(NULL) # if no file was uploaded return NULL
+ return(read.table(file = inFile2$datapath, # inFile[1] contains filepath
+ sep = input$sep,
+ quote = "",
+ header = input$headers)) # else return file
+ })
+
+ # dynamically inject sliderInput for x-axis range
+ output$xlim<- renderUI({
+ data<- Data()
+ if(input$logz == TRUE) {
+ sd<- unlist(lapply(data, function(x) x[,2]/x[,1]))
+ } else {
+ sd<- unlist(lapply(data, function(x) x[,2]))
+ }
+ prec<- 1/sd
+ sliderInput(inputId = "xlim", sep="",
+ label = "Range x-axis",
+ min = 0,
+ max = round(max(prec)*2, 3),
+ value = c(0, max(prec)*1.05))
+ })## EndOf::renderUI()
+
+ # dynamically inject sliderInput for z-axis range
+ output$zlim<- renderUI({
+ data<- unlist(lapply(Data(), function(x) x[,1]))
+ min<- min(data)
+ max<- max(data)
+ sliderInput(inputId = "zlim", sep="",
+ label = "Range z-axis",
+ min = min*0.25,
+ max = round(max*1.75, 3),
+ value = c(min*0.8, max*1.2))
+ })## EndOf::renderUI()
+
+
+ output$ylim<- renderUI({
+ ylim<- plot_AbanicoPlot(Data(), output = TRUE)$ylim
+ sliderInput(inputId = "ylim", sep="",
+ label = "Range y-axis",
+ min = ylim[1]*4,
+ max = round(ylim[2]*4, 3),
+ value = c(ylim[1], ylim[2]))
+ })
+
+
+ # dynamically inject sliderInput for KDE bandwidth
+ output$bw<- renderUI({
+ data<- unlist(lapply(Data(), function(x) x[,1]))
+ if(input$logz == TRUE) {
+ data<- log(data)
+ min<- 0.001
+ value<- bw.nrd0(data)*2
+ max<- value*2
+ } else {
+ value<- bw.nrd0(data)
+ min<- value/4
+ max<- value*4
+ }
+ sliderInput(inputId = "bw", sep="",
+ label = "KDE bandwidth",
+ min = round(min, 3),
+ max = round(max, 3),
+ value = value)
+ })## EndOf::renderUI()
+
+ # observe({
+ # # case: 1 data set, 2 sigma bars --> switch to custom value
+ # if(input$addBar == TRUE && is.null(datGet2())) {
+ # updateSelectInput(session = session, inputId = "centrality",
+ # label = "Centrality",
+ # selected = "custom")
+ # }
+ # # case: 1 data set, 1 sigma bars --> return to mean centrality
+ # if(input$addBar == FALSE && is.null(datGet2())) {
+ # updateSelectInput(session = session, inputId = "centrality",
+ # label = "Centrality",
+ # selected = "mean")
+ # }
+ # })
+
+
+ output$centralityNumeric<- renderUI({
+ #update_centrality()
+ if(!is.null(datGet())){
+ data<- datGet()
+ }
+ numericInput(inputId = "centralityNumeric",
+ label = "Value",
+ value = round(mean(data[,1]), 2),
+ step = 0.01)
+ })
+
+ # render Abanico Plot
+ output$main_plot <- renderPlot({
+
+ # refresh plot on button press
+ input$refresh
+
+ # progress bar
+ progress<- Progress$new(session, min = 0, max = 5)
+ progress$set(message = "Calculation in progress",
+ detail = "Retrieve data")
+ on.exit(progress$close())
+
+ # make sure that input panels are registered on non-active tabs.
+ # by default tabs are suspended and input variables are hence
+ # not available
+ outputOptions(x = output, name = "bw", suspendWhenHidden = FALSE)
+ outputOptions(x = output, name = "zlim", suspendWhenHidden = FALSE)
+ outputOptions(x = output, name = "xlim", suspendWhenHidden = FALSE)
+ outputOptions(x = output, name = "ylim", suspendWhenHidden = FALSE)
+ outputOptions(x = output, name = "centralityNumeric", suspendWhenHidden = FALSE)
+
+ # get data
+ data<- Data()
+
+ # update progress bar
+ progress$set(value = 1)
+ progress$set(message = "Calculation in progress",
+ detail = "Get values")
+
+ # check if any summary stats are activated, else NA
+ ifelse(input$summary, summary<- input$stats, summary<- NA)
+
+ # if custom datapoint color get RGB code from separate input panel
+ if(input$color == "custom") {
+ color<- ifelse(input$jscol1 == "", "black", input$jscol1)
+ } else {
+ color<- input$color
+ }
+
+ if(!is.null(datGet2())) {
+ # if custom datapoint color get RGB code from separate input panel
+ if(input$color2 == "custom") {
+ if(input$jscol2 == "") {
+ color2<- "black"
+ } else {
+ color2<- input$jscol2
+ }
+ } else {
+ color2<- input$color2
+ }
+ } else {
+ color2<- "black" #adjustcolor("white", alpha.f = 0)
+ }
+
+ # if custom datapoint style get char from separate input panel
+ pch<- ifelse(input$pch == "custom", input$custompch, as.integer(input$pch)-1)
+
+ # if custom datapoint style get char from separate input panel
+ pch2<- ifelse(input$pch2 == "custom", input$custompch2, as.integer(input$pch2)-1)
+
+ # update progress bar
+ progress$set(value = 2)
+ progress$set(message = "Calculation in progress",
+ detail = "Combine values")
+
+ # create numeric vector of lines
+ line<- as.numeric(c(input$line1, input$line2,
+ input$line3, input$line4,
+ input$line5, input$line6,
+ input$line7, input$line8))
+
+ # create char vector of line colors
+ line.col<- c(input$colline1, input$colline2,
+ input$colline3, input$colline4,
+ input$colline5, input$colline6,
+ input$colline7, input$colline8)
+
+ line.col[which(line.col=="#")] <- "#FFFFFF"
+
+ # create char vector of line labels
+ line.label<- c(input$labline1, input$labline2,
+ input$labline3, input$labline4,
+ input$labline5, input$labline6,
+ input$labline7, input$labline8)
+
+ # create integer vector of line types
+ line.lty<- as.integer(c(input$linelty1, input$linelty2,
+ input$linelty3, input$linelty4,
+ input$linelty5, input$linelty6,
+ input$linelty7, input$linelty8))
+
+ # update progress bar
+ progress$set(value = 3)
+ progress$set(message = "Calculation in progress",
+ detail = "Get values")
+
+ # if custom polygon color get RGB from separate input panel or "none"
+ if(input$polygon == "custom") {
+ polygon.col<- adjustcolor(col = input$rgbPolygon, alpha.f = input$alpha.polygon/100)
+ } else {
+ polygon.col<- ifelse(input$polygon == "none",
+ input$polygon,
+ adjustcolor(col = input$polygon, alpha.f = input$alpha.polygon/100))
+ }
+
+ # if custom polygon color get RGB from separate input panel or "none"
+ # (secondary data set)
+ if(input$polygon2 == "custom") {
+ polygon.col2<- adjustcolor(col = input$rgbPolygon2, alpha.f = input$alpha.polygon/100)
+ } else {
+ polygon.col2<- ifelse(input$polygon2 == "none",
+ input$polygon2,
+ adjustcolor(col = input$polygon2, alpha.f = input$alpha.polygon/100))
+ }
+
+
+ # if custom bar color get RGB from separate input panel or "none"
+ if(input$bar == "custom") {
+ bar.col<- adjustcolor(col = input$rgbBar, alpha.f = input$alpha.bar/100)
+ } else {
+ bar.col<- ifelse(input$bar == "none",
+ input$bar,
+ adjustcolor(col = input$bar, alpha.f = input$alpha.bar/100))
+ }
+
+ # if custom bar color get RGB from separate input panel or "none"
+ # SECONDARY DATA SET
+ if(input$bar2 == "custom") {
+ bar.col2<- adjustcolor(col = input$rgbBar2, alpha.f = input$alpha.bar/100)
+ } else {
+ bar.col2<- ifelse(input$bar2 == "none",
+ input$bar,
+ adjustcolor(col = input$bar2, alpha.f = input$alpha.bar/100))
+ }
+
+ # if custom grid color get RGB from separate input panel or "none"
+ if(input$grid == "custom") {
+ grid.col<- adjustcolor(col = input$rgbGrid, alpha.f = input$alpha.grid/100)
+ } else {
+ grid.col<- ifelse(input$grid == "none",
+ input$grid,
+ adjustcolor(col = input$grid, alpha.f = input$alpha.grid/100))
+ }
+
+ # update progress bar
+ progress$set(value = 4)
+ progress$set(message = "Calculation in progress",
+ detail = "Almost there...")
+
+ # workaround: if no legend wanted set label to NA and hide
+ # symbol on coordinates -999, -999
+ if(input$showlegend == FALSE) {
+ legend<- c(NA,NA)
+ legend.pos<- c(-999,-999)
+ } else {
+ if(!is.null(datGet2()))
+ {
+ legend<- c(input$legendname, input$legendname2)
+ legend.pos<- input$legend.pos
+ } else {
+ legend<- c(input$legendname, "")
+ legend.pos<- input$legend.pos
+ }
+ }
+
+ # TODO: arg 'bar' handling (custom values, 1 or 2 bars)
+ if (input$customSigBar) {
+ if (!input$addBar)
+ bar <- input$sigmabar1
+ if (input$addBar)
+ bar <- c(input$sigmabar1, input$sigmabar2)
+ } else {
+ bar <- TRUE
+ }
+
+
+ # check wether a keyword or a numeric value is used for
+ # centrality
+ if(input$centrality == "custom") {
+ centrality<- input$centralityNumeric
+ } else {
+ centrality<- input$centrality
+ }
+
+ # check wether predefined or custom dispersion
+ dispersion<- ifelse(input$dispersion == "custom", paste("p", input$cinn, sep=""), input$dispersion)
+
+ # validate(need()) makes sure that all data are available to
+ # renderUI({}) before plotting and will wait until there
+ validate(need(expr = input$bw, message = ''),
+ need(expr = input$zlim, message = ''),
+ need(expr = input$ylim, message = ''),
+ need(expr = input$centralityNumeric, message = 'Waiting for data... Please wait!'))
+
+ # save all arguments in a list
+ args<- list(data = data,
+ y.axis = input$yaxis,
+ bw = input$bw,
+ bar = bar,
+ dispersion = dispersion,
+ plot.ratio = input$p.ratio,
+ z.0 = centrality,
+ log.z = input$logz,
+ summary = summary,
+ summary.pos = input$sumpos,
+ summary.method = input$summary.method,
+ col = c(color,color2),
+ pch = c(pch,pch2),
+ zlab = input$zlab,
+ main = input$main,
+ zlim = input$zlim,
+ cex = input$cex,
+ mtext = input$mtext,
+ stats = input$statlabels,
+ error.bars = input$errorbars,
+ line = line,
+ line.col = line.col,
+ line.label = line.label,
+ line.lty = line.lty,
+ polygon.col = c(polygon.col,polygon.col2),
+ bar.col = c(bar.col, bar.col2),
+ grid.col = grid.col,
+ legend = legend,
+ legend.pos = legend.pos,
+ na.rm = input$naExclude,
+ lwd = c(input$lwd, input$lwd2),
+ xlab = c(input$xlab1, input$xlab2),
+ ylab = input$ylab,
+ lty = c(as.integer(input$lty), as.integer(input$lty2)),
+ xlim = input$xlim,
+ ylim = input$ylim,
+ rug = input$rug,
+ layout = input$layout,
+ rotate = input$rotate,
+ boxplot = input$boxplot,
+ kde = input$kde,
+ hist = input$histogram,
+ dots = input$dots,
+ frame = input$frame)
+
+ progress$set(value = 5)
+ progress$set(message = "Calculation in progress",
+ detail = "Ready to plot")
+
+ # plot Abanico Plot
+ do.call(what = plot_AbanicoPlot, args = args)
+
+ # prepare code as text output
+ if (is.null(input$sep))
+ updateRadioButtons(session, "fileformat", selected = "\t")
+
+ if(input$sep == "\t")
+ verb.sep<- "\\t"
+ else
+ verb.sep<- input$sep
+
+ str1 <- paste("data <- read.delim(file, header = ",input$headers, ", sep= '", verb.sep,"')",
+ sep = "")
+
+ if(!is.null(datGet2())) {
+ str2 <- "file2<- file.choose()"
+ str3 <- paste("data2 <- read.delim(file2, header = ",input$headers, ", sep= '", verb.sep,"')",
+ sep= "")
+ str4 <- "data<- list(data, data2)"
+ str1 <- paste(str1, str2, str3, str4, sep = "\n")
+ }
+
+ header <- paste("# To reproduce the plot in your local R environment",
+ "# copy and run the following code to your R console.",
+ "library(Luminescence)",
+ "file<- file.choose()",
+ str1,
+ "\n",
+ sep = "\n")
+
+ names <- names(args)
+
+ verb.arg <- paste(mapply(function(name, arg) {
+ if (all(inherits(arg, "character")))
+ arg <- paste0("'", arg, "'")
+ if (length(arg) > 1)
+ arg <- paste0("c(", paste(arg, collapse = ", "), ")")
+ if (is.null(arg))
+ arg <- "NULL"
+ paste(name, "=", arg)
+ }, names[-1], args[-1]), collapse = ",\n")
+
+ funCall <- paste0("plot_AbanicoPlot(data = data,\n", verb.arg, ")")
+
+ code.output <- paste0(header, funCall, collapse = "\n")
+
+ # nested renderText({}) for code output on "R plot code" tab
+ output$plotCode<- renderText({
+
+ code.output
+
+ })##EndOf::renderText({})
+
+
+ output$exportScript <- downloadHandler(
+ filename = function() { paste(input$filename, ".", "R", sep="") },
+ content = function(file) {
+ write(code.output, file)
+ },#EO content =,
+ contentType = "text"
+ )#EndOf::dowmloadHandler()
+
+
+ # nested downloadHandler() to print plot to file
+ output$exportFile <- downloadHandler(
+ filename = function() { paste(input$filename, ".", input$fileformat, sep="") },
+ content = function(file) {
+
+ # determine desired fileformat and set arguments
+ if(input$fileformat == "pdf") {
+ pdf(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ paper = "special",
+ useDingbats = FALSE,
+ family = input$fontfamily)
+ }
+ if(input$fileformat == "svg") {
+ svg(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ family = input$fontfamily)
+ }
+ if(input$fileformat == "eps") {
+ postscript(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ paper = "special",
+ family = input$fontfamily)
+ }
+
+ # plot Abanico Plot
+ do.call(what = plot_AbanicoPlot, args = args)
+
+ dev.off()
+ },#EO content =,
+ contentType = "image"
+ )#EndOf::dowmloadHandler()
+ })##EndOf::renderPlot({})
+
+
+ Selected<- reactive({
+ input$refresh
+ })
+
+ # renderTable() that prints the data to the second tab
+ output$dataset<- renderDataTable(
+ options = list(pageLength = 10, autoWidth = FALSE),
+ callback = "function(table) {
+ table.on('click.dt', 'tr', function() {
+ $(this).toggleClass('selected');
+ Shiny.onInputChange('rows',
+ table.rows('.selected').data().toArray());
+ });
+ }",
+{
+ if(!is.null(datGet())) {
+ data<- datGet()
+ colnames(data)<- c("De","De error")
+ data
+
+ } else {
+ colnames(data)<- c("De","De error")
+ Selected()
+ data
+ }
+})##EndOf::renterTable()
+
+ # renderTable() that prints the secondary data to the second tab
+ output$dataset2<- renderDataTable(
+ options = list(pageLength = 10, autoWidth = FALSE),
+ callback = "function(table) {
+ table.on('click.dt', 'tr', function() {
+ $(this).toggleClass('selected');
+ Shiny.onInputChange('rows',
+ table.rows('.selected').data().toArray());
+ });
+ }",
+{
+ if(!is.null(datGet2())) {
+ data<- datGet2()
+ colnames(data)<- c("De","De error")
+ data
+ } else {
+ }
+})##EndOf::renterTable()
+
+ # renderTable() to print the results of the
+ # central age model (CAM)
+ output$CAM<- renderDataTable(
+ options = list(pageLength = 10, autoWidth = FALSE),
+ {
+ data<- Data()
+ t<- as.data.frame(matrix(nrow = length(data), ncol = 7))
+ colnames(t)<- c("Data set","n", "log data", "Central dose", "SE abs.", "OD (%)", "OD error (%)")
+ res<- lapply(data, function(x) { calc_CentralDose(x, verbose = FALSE, plot = FALSE) })
+ for(i in 1:length(res)) {
+ t[i,1]<- ifelse(i==1,"pimary","secondary")
+ t[i,2]<- length(res[[i]]@data$data[,1])
+ t[i,3]<- res[[i]]@data$args$log
+ t[i,4:7]<- round(res[[i]]@data$summary[1:4],2)
+ }
+ t
+ })##EndOf::renterTable()
+
+})##EndOf::shinyServer(function(input, output)
\ No newline at end of file
diff --git a/inst/shiny/abanico/ui.R b/inst/shiny/abanico/ui.R
new file mode 100644
index 0000000..5c37ade
--- /dev/null
+++ b/inst/shiny/abanico/ui.R
@@ -0,0 +1,869 @@
+## UI.R
+library(RLumShiny)
+
+# load example data
+data(ExampleData.DeValues)
+
+# pageWithSidebar contains three panels:
+# 1 - headerPanel: basically just for a header
+# 2 - sidebarPanel: data input
+# 3 - mainPanel: data output
+
+pageWithSidebar(
+ # 1 - title = NULL -> Panel will not be shown
+ headerPanel(title = NULL),
+
+ # 2- width = 5 -> refers to twitters bootstrap grid system
+ # where the the maximum width is 12 that is to be shared between all
+ # elements
+ sidebarPanel(width = 5,
+ # include a tabs in the input panel for easier navigation
+ tabsetPanel(id = "tabs", type = "pill", selected = "Data",
+ # Tab 1: Data input
+ tabPanel("Data",
+ # informational text
+ div(align = "center", h5("Data upload")),
+ # file upload button (data set 1)
+ fileInput(inputId = "file1",
+ label = strong("Primary data set"),
+ accept="text/plain"),
+ tooltip(refId = "file1", text = tags$img(src='file_structure.png', width='250px')),
+ # file upload button (data set 2)
+ fileInput(inputId = "file2",
+ label = strong("Secondary data set"),
+ accept="text/plain"),
+ tooltip(refId = "file2", text = tags$img(src='file_structure.png', width='250px')),
+ # informational text
+ div(align = "center", h5("Settings")),
+ fluidRow(
+ column(width = 6,
+ # logical: should NA values be excluded?
+ checkboxInput(inputId = "naExclude",
+ label = "Exclude NA values",
+ value = TRUE),
+ tooltip(refId = "naExclude", text = "Exclude NA values from the data set prior to any further operations.")
+ ),
+ column(width = 6,
+ # logical: file contains headers?
+ checkboxInput(inputId = "headers",
+ label = "File contains headers",
+ value = FALSE),
+ tooltip(refId = "headers", text = tags$img(src='file_containsHeader.png', width='250px'))
+ )
+ ),
+ # char: columns separated by tab, space, comma
+ radioButtons("sep", "Separator", selected = "\t", inline = TRUE,
+ c("Tab" = "\t",
+ "Space" = " ",
+ "Comma" = ",",
+ "Semicolon" = ";")),
+ tooltip(refId = "sep", text = tags$img(src='file_sep.png', width='400px'), placement = "auto left"),
+ hr(),
+
+ actionButton(inputId = "refresh", label = "Refresh", icon = icon("refresh")),
+ tooltip(refId = "refresh", text = "Redraw the plot")
+
+
+
+ ),##EndOf::Tab_1
+
+
+ # Tab 2: Statistical information
+ tabPanel("Statistics",
+ div(align = "center", h5("Summary")),
+ fluidRow(
+ column(width = 6,
+ checkboxInput(inputId = "summary",
+ label = "Show summary",
+ value = TRUE),
+ tooltip(refId = "summary", text = "Adds numerical output to the plot")
+ ),
+ column(width = 6,
+ selectInput(inputId = "sumpos",
+ label = "Summary position",
+ selected = "topleft",
+ choices = list("Subtitle" = "sub",
+ "Center" = "center",
+ Top=c("Top" = "top",
+ "Top left" = "topleft",
+ "Top right"= "topright"),
+ Bottom=c("Bottom" = "bottom",
+ "Bottom left" = "bottomleft",
+ "Bottom right" = "bottomright"))),
+ tooltip(refId = "sumpos", attr = "for", text = "Position of the statistical summary. The keyword \"Subtitle\" will only work if no plot subtitle is used.")
+ )
+ ),
+ selectInput(inputId = "summary.method",
+ label = "Summary method",
+ selected = "unweighted",
+ choices = list("Unweighted" = "unweighted",
+ "Weighted" = "weighted",
+ "Monte Carlo" = "MCM")),
+ tooltip(refId = "summary.method", attr = "for", text = "Keyword indicating the method used to calculate the statistic summary. See calc_Statistics for details."),
+
+ checkboxGroupInput(inputId = "stats",
+ label = "Parameters",
+ selected = c("n","mean"),
+ choices = c("n" = "n",
+ "Mean" = "mean",
+ "Median" = "median",
+ "rel. Standard deviation" = "sd.rel",
+ "abs. Standard deviation" = "sd.abs",
+ "rel. Standard error" = "se.rel",
+ "abs. Standard error" = "se.abs",
+ "Skewness" = "skewness",
+ "Kurtosis" = "kurtosis",
+ "% in 2 sigma range" = "in.2s")),
+ tooltip(refId = "stats", text = "Statistical parameters to be shown in the summary"),
+ br(),
+ div(align = "center", h5("Datapoint labels")),
+ div(align = "center", checkboxGroupInput(inputId = "statlabels", inline = TRUE,
+ label = NULL,
+ choices = c("Min" = "min",
+ "Max" = "max",
+ "Median" = "median"))),
+ tooltip(refId = "statlabels", text = "Additional labels of statistically important values in the plot."),
+ br(),
+ div(align = "center", h5("Error bars")),
+ checkboxInput(inputId = "errorbars",
+ label = "Show error bars",
+ value = FALSE),
+ tooltip(refId = "errorbars", text = "Option to show D<sub>e</sub>-errors as error bars on D<sub>e</sub>-points. Useful in combination with hidden y-axis and 2σ bar")
+ ),##EndOf::Tab_2
+
+ # Tab 3: input that refer to the plot rather than the data
+ tabPanel("Plot",
+ div(align = "center", h5("Title")),
+ fluidRow(
+ column(width = 6,
+ textInput(inputId = "main",
+ label = "Title",
+ value = "Abanico Plot")
+ ),
+ column(width = 6,
+ textInput(inputId = "mtext",
+ label = "Subtitle",
+ value = "")
+ )
+ ),
+ div(align = "center", h5("Scaling")),
+ # inject sliderInput from Server.R
+ div(id="bwKDE",
+ uiOutput(outputId = "bw")
+ ),
+ tooltip(refId = "bwKDE", text = "Bin width of the kernel density estimate"),
+ fluidRow(
+ column(width = 6,
+ div(id="pratiodiv",
+ sliderInput(inputId = "p.ratio",
+ label = "Plot ratio",
+ min=0.25, max=0.90,
+ value=0.75, step=0.01, round= FALSE)
+ ),
+ tooltip(refId = "pratiodiv", text = "Relative space given to the radial versus the cartesian plot part, default is 0.75.")
+ ),
+ column(width = 6,
+ sliderInput(inputId = "cex",
+ label = "Scaling factor",
+ min = 0.5, max = 2,
+ value = 1.0, step = 0.1)
+ )
+ ),
+ br(),
+ div(align = "center", h5("Centrality")),
+
+ # centrality can either be a keyword or numerical input
+ selectInput(inputId = "centrality",
+ label = "Central Value",
+ list("Mean" = "mean",
+ "Median" = "median",
+ "Weighted mean" = "mean.weighted",
+ "Custom value" = "custom")),
+ tooltip(refId = "centrality", text = "User-defined central value, used for centering of data."),
+
+ conditionalPanel(condition = "input.centrality == 'custom'",
+ uiOutput("centralityNumeric")),
+
+ div(align = "center", h5("Dispersion")),
+
+ selectInput(inputId = "dispersion",
+ label = "Measure of dispersion",
+ list("Quartile range" = "qr",
+ "1 sigma" = "sd",
+ "2 sigma" = "2sd",
+ "Custom percentile range" = "custom")),
+ tooltip(refId = "dispersion", text = "Measure of dispersion, used for drawing the polygon that depicts the spread in the dose distribution."),
+
+ conditionalPanel(condition = "input.dispersion == 'custom'",
+ numericInput(inputId = "cinn",
+ label = "x % percentile",
+ value = 25,
+ min = 0,
+ max = 100,
+ step = 1)),
+
+ div(align = "center", HTML("<h5>2σ bar</h5>")),
+
+ fluidRow(
+ column(width = 6,
+ checkboxInput(inputId = "customSigBar",
+ label = HTML("Customise 2σ bar"),
+ value = FALSE)
+ ),
+ column(width = 6,
+ checkboxInput(inputId = "addBar",
+ label = HTML("Second 2σ bar"),
+ value = FALSE)
+ )
+ ),
+
+
+ fluidRow(
+ column(width = 6,
+ conditionalPanel(condition = "input.customSigBar == true",
+ numericInput(inputId = "sigmabar1",
+ label = HTML("2σ bar 1"),
+ min = 0, max = 100,
+ value = 60)
+ )
+ ),
+ column(width = 6,
+ conditionalPanel(condition = "input.customSigBar == true",
+ numericInput(inputId = "sigmabar2",
+ label = HTML("2σ bar 2"),
+ min = 0, max = 100,
+ value = 100)
+ )
+ )
+ ),
+
+ div(align = "center", h5("Central line")),
+
+ fluidRow(
+ column(width = 6,
+ numericInput(inputId = "lwd",
+ label = "Line width #1",
+ min = 0, max = 5,
+ value = 1)
+ ),
+ column(width = 6,
+ numericInput(inputId = "lwd2",
+ label = "Line width #2",
+ min = 0, max = 5,
+ value = 1)
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "lty",
+ label = "Line type",
+ selected = 2,
+ choices = list("Blank" = 0,
+ "Solid" = 1,
+ "Dashed" = 2,
+ "Dotted" = 3,
+ "Dot dash" = 4,
+ "Long dash" = 5,
+ "Two dash" = 6))
+ ),
+ column(width = 6,
+ selectInput(inputId = "lty2",
+ label = "Line type",
+ selected = 2,
+ choices = list("Blank" = 0,
+ "Solid" = 1,
+ "Dashed" = 2,
+ "Dotted" = 3,
+ "Dot dash" = 4,
+ "Long dash" = 5,
+ "Two dash" = 6))
+
+ )
+ ),
+ div(align = "center", h5("Further options")),
+ fluidRow(
+ column(width = 6,
+ checkboxInput(inputId = "rug",
+ label = "Add rug",
+ value = FALSE),
+ tooltip(refId = "rug", text = "Option to add a rug to the KDE part, to indicate the location of individual values")
+ ),
+ column(width = 6,
+ checkboxInput(inputId = "rotate",
+ label = "Rotate plot",
+ value = FALSE),
+ tooltip(refId = "rotate", text = "Option to rotate the plot by 90°.")
+ )
+ ),
+ checkboxInput(inputId = "boxplot", label = "Boxplot", value = FALSE),
+ tooltip(refId = "boxplot", text = "Option to add a boxplot to the dispersion part."),
+ checkboxInput(inputId = "kde", label = "KDE", value = TRUE),
+ tooltip(refId = "kde", text = "Option to add a KDE plot to the dispersion part."),
+ checkboxInput(inputId = "histogram", label = "Histogram", value = TRUE),
+ tooltip(refId = "histogram", text = "Option to add a histogram to the dispersion part. Only meaningful when not more than one data set is plotted."),
+ checkboxInput(inputId = "dots", label = "Dots", value = TRUE),
+ tooltip(refId = "dots", text = "Option to add a dot plot to the dispersion part. If number of dots exceeds space in the dispersion part, a square indicates this.")
+ ),##EndOf::Tab_3
+
+ # Tab 4: modify axis parameters
+ tabPanel("Axis",
+ div(align = "center", h5("X-axis")),
+ fluidRow(
+ column(width = 6,
+ textInput(inputId = "xlab1",
+ label = "Label x-axis (upper)",
+ value = "Relative error [%]")
+ ),
+ column(width = 6,
+ textInput(inputId = "xlab2",
+ label = "Label x-axis (lower)",
+ value = "Precision")
+ )
+ ),
+ # inject sliderInput from Server.R
+ uiOutput(outputId = "xlim"),
+ br(),
+ div(align = "center", h5("Y-axis")),
+ checkboxInput(inputId = "yaxis",
+ label = "Show y-axis",
+ value = TRUE),
+ tooltip(refId = "yaxis", text = "Option to hide y-axis labels. Useful for data with small scatter."),
+ textInput(inputId = "ylab",
+ label = "Label y-axis",
+ value = "Standardised estimate"),
+ uiOutput("ylim"),
+ br(),
+ div(align = "center", h5("Z-axis")),
+ checkboxInput(inputId = "logz",
+ label = "Logarithmic z-axis",
+ value = TRUE),
+ tooltip(refId = "logz", text = "Option to display the z-axis in logarithmic scale."),
+ textInput(inputId = "zlab",
+ label = "Label z-axis",
+ value = "Equivalent dose [Gy]"),
+ # inject sliderInput from Server.R
+ uiOutput(outputId = "zlim")
+ ),##EndOf::Tab_4
+
+ # Tab 5: modify data point representation
+ tabPanel("Datapoints",
+ div(align = "center", h5("Primary data set")),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "pch",
+ label = "Style",
+ selected = "17",
+ choices = c("Square"= "1",
+ "Circle"="2",
+ "Triangle point up"="3",
+ "Plus"="4",
+ "Cross"="5",
+ "Diamond"="6",
+ "Triangle point down"="7",
+ "Square cross"="8",
+ "Star"="9",
+ "Diamond plus"="10",
+ "Circle plus"="11",
+ "Triangles up and down"="12",
+ "Square plus"="13",
+ "Circle cross"="14",
+ "Square and Triangle down"="15",
+ "filled Square"="16",
+ "filled Circle"="17",
+ "filled Triangle point up"="18",
+ "filled Diamond"="19",
+ "solid Circle"="20",
+ "Bullet (smaller Circle)"="21",
+ "Custom"="custom"))
+ ),
+ column(width = 6,
+ # show only if custom symbol is desired
+ conditionalPanel(condition = "input.pch == 'custom'",
+ textInput(inputId = "custompch",
+ label = "Insert character",
+ value = "?"))
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "color", label = "Datapoint color",
+ choices = list("Black" = "black",
+ "Grey" = "grey50",
+ "Red" = "#b22222",
+ "Green" = "#6E8B3D",
+ "Blue" = "#428bca",
+ "Custom" = "custom"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.color == 'custom'",
+ HTML("Choose a color<br>"),
+ jscolorInput(inputId = "jscol1"))
+ )
+ ),
+ br(),
+ div(align = "center", h5("Secondary data set")),
+ fluidRow(
+ column(width = 6,
+ ## DATA SET 2
+ selectInput(inputId = "pch2",
+ label = "Style",
+ selected = "17",
+ choices = c("Square"= "1",
+ "Circle"="2",
+ "Triangle point up"="3",
+ "Plus"="4",
+ "Cross"="5",
+ "Diamond"="6",
+ "Triangle point down"="7",
+ "Square cross"="8",
+ "Star"="9",
+ "Diamond plus"="10",
+ "Circle plus"="11",
+ "Triangles up and down"="12",
+ "Square plus"="13",
+ "Circle cross"="14",
+ "Square and Triangle down"="15",
+ "filled Square"="16",
+ "filled Circle"="17",
+ "filled Triangle point up"="18",
+ "filled Diamond"="19",
+ "solid Circle"="20",
+ "Bullet (smaller Circle)"="21",
+ "Custom"="custom"))
+ ),
+ column(width = 6,
+ # show only if custom symbol is desired
+ conditionalPanel(condition = "input.pch2 == 'custom'",
+ textInput(inputId = "custompch2",
+ label = "Insert character",
+ value = "?"))
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "color2", label = "Datapoint color",
+ selected = "#b22222",
+ choices = list("Black" = "black",
+ "Grey" = "grey50",
+ "Red" = "#b22222",
+ "Green" = "#6E8B3D",
+ "Blue" = "#428bca",
+ "Custom" = "custom"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.color2 == 'custom'",
+ HTML("Choose a color<br>"),
+ jscolorInput(inputId = "jscol2"))
+ )
+ )
+ ),##EndOf::Tab_5
+
+ # Tab 6: add additional lines to the plot
+ tabPanel("Lines",
+ helpText("Here you can add additional lines."),
+ # options for custom lines:
+ # 1 - z-value, 2 - color, 3 - label, 4 - line type
+ # only the options for the first line are shown
+ fluidRow(
+ column(width = 6,
+ numericInput(inputId = "line1",
+ label = strong("Line #1"),
+ value = NA, min = 0)
+ ),
+ tooltip(refId = "line1", text = "Numeric values of the additional lines to be added."),
+ column(width = 6,
+ selectInput(inputId = "linelty1",
+ label = "Line type",
+ selected = 1,
+ choices = list("Blank" = 0,
+ "Solid" = 1,
+ "Dashed" = 2,
+ "Dotted" = 3,
+ "Dot dash" = 4,
+ "Long dash" = 5,
+ "Two dash" = 6))
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ HTML("Choose a color<br>"),
+ jscolorInput(inputId = "colline1")
+ ),
+ column(width = 6,
+ textInput(inputId = "labline1",
+ label = "Label",
+ value = "")
+ )
+ ),
+ # conditional chain: if valid input (i.e. the z-value is > 0) is provided
+ # for the previous line, show options for a new line (currently up to eight)
+ conditionalPanel(condition = "input.line1 > 0",
+ fluidRow(
+ column(width = 6, numericInput(inputId = "line2", strong("Line #2"), NA, min = 0)),
+ column(width = 6, selectInput(inputId = "linelty2", label = "Line type",selected = 1,
+ choices = list("Blank" = 0,
+ "Solid" = 1,
+ "Dashed" = 2,
+ "Dotted" = 3,
+ "Dot dash" = 4,
+ "Long dash" = 5,
+ "Two dash" = 6)))
+ ),
+ fluidRow(
+ column(width = 6, HTML("Choose a color<br>"),jscolorInput(inputId = "colline2")),
+ column(width = 6, textInput("labline2","Label",value = ""))
+ )
+ ),
+ conditionalPanel(condition = "input.line2 > 0",
+ fluidRow(
+ column(width = 6, numericInput(inputId = "line3", strong("Line #3"), NA, min = 0)),
+ column(width = 6, selectInput(inputId = "linelty3", label = "Line type",selected = 1,
+ choices = list("Blank" = 0,
+ "Solid" = 1,
+ "Dashed" = 2,
+ "Dotted" = 3,
+ "Dot dash" = 4,
+ "Long dash" = 5,
+ "Two dash" = 6)))
+ ),
+ fluidRow(
+ column(width = 6, HTML("Choose a color<br>"),jscolorInput(inputId = "colline3")),
+ column(width = 6, textInput("labline3","Label",value = ""))
+ )
+ ),
+ conditionalPanel(condition = "input.line3 > 0",
+ fluidRow(
+ column(width = 6, numericInput(inputId = "line4", strong("Line #4"), NA, min = 0)),
+ column(width = 6, selectInput(inputId = "linelty4", label = "Line type",selected = 1,
+ choices = list("Blank" = 0,
+ "Solid" = 1,
+ "Dashed" = 2,
+ "Dotted" = 3,
+ "Dot dash" = 4,
+ "Long dash" = 5,
+ "Two dash" = 6)))
+ ),
+ fluidRow(
+ column(width = 6, HTML("Choose a color<br>"),jscolorInput(inputId = "colline4")),
+ column(width = 6, textInput("labline4","Label",value = ""))
+ )
+ ),
+ conditionalPanel(condition = "input.line4 > 0",
+ fluidRow(
+ column(width = 6, numericInput(inputId = "line5", strong("Line #5"), NA, min = 0)),
+ column(width = 6, selectInput(inputId = "linelty5", label = "Line type",selected = 1,
+ choices = list("Blank" = 0,
+ "Solid" = 1,
+ "Dashed" = 2,
+ "Dotted" = 3,
+ "Dot dash" = 4,
+ "Long dash" = 5,
+ "Two dash" = 6)))
+ ),
+ fluidRow(
+ column(width = 6, HTML("Choose a color<br>"),jscolorInput(inputId = "colline5")),
+ column(width = 6, textInput("labline5","Label",value = ""))
+ )
+ ),
+ conditionalPanel(condition = "input.line5 > 0",
+ fluidRow(
+ column(width = 6, numericInput(inputId = "line6", strong("Line #6"), NA, min = 0)),
+ column(width = 6, selectInput(inputId = "linelty6", label = "Line type",selected = 1,
+ choices = list("Blank" = 0,
+ "Solid" = 1,
+ "Dashed" = 2,
+ "Dotted" = 3,
+ "Dot dash" = 4,
+ "Long dash" = 5,
+ "Two dash" = 6)))
+ ),
+ fluidRow(
+ column(width = 6, HTML("Choose a color<br>"),jscolorInput(inputId = "colline6")),
+ column(width = 6, textInput("labline6","Label",value = ""))
+ )
+ ),
+ conditionalPanel(condition = "input.line6 > 0",
+ fluidRow(
+ column(width = 6, numericInput(inputId = "line7", strong("Line #7"), NA, min = 0)),
+ column(width = 6, selectInput(inputId = "linelty7", label = "Line type",selected = 1,
+ choices = list("Blank" = 0,
+ "Solid" = 1,
+ "Dashed" = 2,
+ "Dotted" = 3,
+ "Dot dash" = 4,
+ "Long dash" = 5,
+ "Two dash" = 6)))
+ ),
+ fluidRow(
+ column(width = 6, HTML("Choose a color<br>"),jscolorInput(inputId = "colline7")),
+ column(width = 6, textInput("labline7","Label",value = ""))
+ )
+ ),
+ conditionalPanel(condition = "input.line7 > 0",
+ fluidRow(
+ column(width = 6, numericInput(inputId = "line8", strong("Line #8"), NA, min = 0)),
+ column(width = 6, selectInput(inputId = "linelty8", label = "Line type",selected = 1,
+ choices = list("Blank" = 0,
+ "Solid" = 1,
+ "Dashed" = 2,
+ "Dotted" = 3,
+ "Dot dash" = 4,
+ "Long dash" = 5,
+ "Two dash" = 6)))
+ ),
+ fluidRow(
+ column(width = 6, HTML("Choose a color<br>"),jscolorInput(inputId = "colline8")),
+ column(width = 6, textInput("labline8","Label",value = ""))
+ )
+ )
+ ),##EndOf::Tab_6
+
+ # Tab 7: modify the 2-sigma bar (radial plot), grid (both) and polygon (KDE)
+ tabPanel("Bars & Grid",
+ div(align = "center", h5("Dispersion bar")),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "polygon",
+ label = "Dispersion bar color #1",
+ choices = list("Grey" = "grey80",
+ "Custom" = "custom",
+ "None" = "none")),
+ tooltip(refId = "polygon", attr = "for", text = "Colour of the polygon showing the dose dispersion around the central value.")
+ ),
+ column(width = 6,
+ selectInput(inputId = "polygon2",
+ label = "Dispersion bar color #2",
+ choices = list("Grey" = "grey80",
+ "Custom" = "custom",
+ "None" = "none"))
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.polygon == 'custom'",
+ jscolorInput(inputId = "rgbPolygon",
+ label = "Choose a color"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.polygon2 == 'custom'",
+ jscolorInput(inputId = "rgbPolygon2",
+ label = "Choose a color"))
+ )
+ ),
+ sliderInput(inputId = "alpha.polygon",
+ label = "Transparency",
+ min = 0, max = 100,
+ step = 1, value = 66),
+ br(),
+ div(align = "center", HTML("<h5>2σ bar</h5>")),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "bar", label = HTML("2σ bar color"),
+ choices = list("Grey" = "grey50",
+ "Custom" = "custom",
+ "None" = "none")),
+ tooltip(refId = "bar", attr = "for", text = "Colour of the bar showing the 2-sigma range of the dose error around the central value.")
+ ),
+ column(width = 6,
+ selectInput(inputId = "bar2", label = HTML("2σ bar color #2"),
+ choices = list("Grey" = "grey50",
+ "Custom" = "custom",
+ "None" = "none"))
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.bar == 'custom'",
+ jscolorInput(inputId = "rgbBar",
+ label = "Choose a color"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.bar2 == 'custom'",
+ jscolorInput(inputId = "rgbBar2",
+ label = "Choose a color"))
+ )
+ ),
+ sliderInput(inputId = "alpha.bar",
+ label = "Transparency",
+ min = 0, max = 100,
+ step = 1, value = 66),
+ br(),
+ div(align = "center", h5("Grid")),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "grid", label = "Grid color",
+ selected = "none",
+ list("Grey" = "grey90",
+ "Custom" = "custom",
+ "None" = "none"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.grid == 'custom'",
+ jscolorInput(inputId = "rgbGrid",
+ label = "Choose a color"))
+ )
+ ),
+ sliderInput(inputId = "alpha.grid",
+ label = "Transparency",
+ min = 0, max = 100,
+ step = 1, value = 50),
+
+ br(),
+ div(align = "center", h5("Frame")),
+ selectInput(inputId = "frame", label = "Frame", selected = 1,
+ choices = list("No frame" = 0,
+ "Origin at {0,0}" = 1,
+ "Anchors at {0,-2}, {0,2}" = 2,
+ "Rectangle" = 3))
+ ),##EndOf::Tab_7
+
+ # Tab 8: add and customize legend
+ tabPanel("Legend",
+ div(align = "center", h5("Legend")),
+ fluidRow(
+ column(width = 6,
+ checkboxInput(inputId = "showlegend",
+ label = "Show legend",
+ value = FALSE),
+ tooltip(refId = "showlegend", text = "Legend content to be added to the plot.")
+ ),
+ column(width = 6,
+ selectInput(inputId = "legend.pos",
+ label = "Legend position",
+ selected = "bottomleft",
+ choices = c("Top" = "top",
+ "Top left" = "topleft",
+ "Top right"= "topright",
+ "Center" = "center",
+ "Bottom" = "bottom",
+ "Bottom left" = "bottomleft",
+ "Bottom right" = "bottomright"))
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ textInput(inputId = "legendname",
+ label = "Primary data label",
+ value = "primary data")
+ ),
+ column(width = 6,
+ textInput(inputId = "legendname2",
+ label = "Secondary data label",
+ value = "secondary data")
+ )
+ )
+ ),##EndOf::Tab_8
+
+ # Tab 9: Filter data
+ tabPanel("Filter",
+ div(align = "center", h5("Primary data set")),
+ selectInput(inputId = "filter.prim", label = "Choose values to exclude",
+ choices = "", multiple = TRUE, selected = ""),
+ div(align = "center", h5("Secondary data set")),
+ selectInput(inputId = "filter.sec", label = "Choose values to exclude",
+ choices = "", multiple = TRUE, selected = ""),
+ actionButton(inputId = "exclude", label = "Exclude")
+ ),##EndOf::Tab_9
+
+ # Tab 10: Layout
+ tabPanel("Layout",
+ div(align = "center", h5("Layout")),
+ div(id = "layout",
+ selectInput(inputId = "layout",
+ label = "Choose layout",
+ selected = "default",
+ choices = c("Default"="default",
+ "Journal"="journal"))
+ ),
+ tooltip(refId = "layout", placement = "top",
+ text = "The optional parameter layout allows to modify the entire plot more sophisticated. Each element of the plot can be addressed and its properties can be defined. This includes font type, size and decoration, colours and sizes of all plot items. To infer the definition of a specific layout style cf. get_Layout() or type eg. for the layout type \"journal\" get_Layout(\"journal\"). A layout type can be modified by the user by assigning new v [...]
+ ),
+
+ # Tab 10: save plot as pdf, wmf or eps
+ tabPanel("Export",
+ radioButtons(inputId = "fileformat",
+ label = "Fileformat",
+ selected = "pdf",
+ choices = c("PDF (Portable Document Format)" = "pdf",
+ "SVG (Scalable Vector Graphics)" = "svg",
+ "EPS (Encapsulated Postscript)" = "eps")),
+ textInput(inputId = "filename",
+ label = "Filename",
+ value = "Abanico Plot"),
+ fluidRow(
+ column(width = 6,
+ numericInput(inputId = "imgheight",
+ label = "Image height",
+ value = 7)
+ ),
+ column(width = 6,
+ numericInput(inputId = "imgwidth",
+ label = "Image width",
+ value = 7)
+ )
+ ),
+ selectInput(inputId = "fontfamily",
+ label = "Font",
+ selected = "Helvetica",
+ choices = c("Helvetica" = "Helvetica",
+ "Helvetica Narrow" = "Helvetica Narrow",
+ "Times" = "Times",
+ "Courier" = "Courier",
+ "Bookman" = "Bookman",
+ "Palatino" = "Palatino")),
+ tags$hr(),
+ downloadButton(outputId = "exportFile",
+ label = "Download plot"),
+ tags$hr(),
+ helpText("Additionally, you can download a corresponding .R file that contains",
+ "a fully functional script to reproduce the plot in your R environment!"),
+
+ downloadButton(outputId = "exportScript",
+ label = "Download R script")
+ ),##EndOf::Tab_8
+
+ # Tab 10: further information
+ tabPanel("About",
+ hr(),
+ div(align = "center",
+ # HTML code to include a .png file in the tab; the image file must be in
+ # a subfolder called "wwww"
+ img(src="RL_Logo.png", height = 100, width = 100, alt = "R.Lum"),
+ p("Links:"),
+ a(href = "http://www.r-luminescence.de", "R.Luminescence project page", target="_blank"),
+ br(),
+ a(href = "https://forum.r-luminescence.de", "Message board", target="_blank"),
+ br(),
+ a(href = "http://zerk.canopus.uberspace.de/R.Lum", "Online application", target="_blank"),
+ br(),hr(),
+ img(src='GitHub-Mark-32px.png', width='32px', height='32px'),
+ br(),
+ a(href = "https://github.com/tzerk/RLumShiny/tree/master/inst/shiny/abanico", "See the code at GitHub!", target="_blank")
+ )#/div
+ )##EndOf::Tab_9
+ )##EndOf::tabsetPanel
+ ),##EndOf::sidebarPanel
+
+ # 3 - output panel
+ mainPanel(width = 7,
+ # insert css code inside <head></head> of the generated HTML file:
+ # allow open dropdown menus to reach over the container
+ tags$head(tags$style(type="text/css",".tab-content {overflow: visible;}")),
+ tags$head(includeCSS("www/style.css")),
+ # divide output in separate tabs via tabsetPanel
+ tabsetPanel(
+ tabPanel("Plot", plotOutput(outputId = "main_plot", height = "500px")),
+ tabPanel("Primary data set", fluidRow(column(width = 12, dataTableOutput("dataset")))),
+ tabPanel("Secondary data set", dataTableOutput("dataset2")),
+ tabPanel("Central Age Model", dataTableOutput("CAM")),
+ tabPanel("R plot code", verbatimTextOutput("plotCode"))
+ )###EndOf::tabsetPanel
+ )##EndOf::mainPanel
+)##EndOf::shinyUI(pageWithSidebar)
\ No newline at end of file
diff --git a/inst/shiny/abanico/www/GitHub-Mark-32px.png b/inst/shiny/abanico/www/GitHub-Mark-32px.png
new file mode 100644
index 0000000..8b25551
Binary files /dev/null and b/inst/shiny/abanico/www/GitHub-Mark-32px.png differ
diff --git a/inst/shiny/abanico/www/RL_Logo.png b/inst/shiny/abanico/www/RL_Logo.png
new file mode 100644
index 0000000..ac0551b
Binary files /dev/null and b/inst/shiny/abanico/www/RL_Logo.png differ
diff --git a/inst/shiny/abanico/www/file_containsHeader.png b/inst/shiny/abanico/www/file_containsHeader.png
new file mode 100644
index 0000000..7abe3d2
Binary files /dev/null and b/inst/shiny/abanico/www/file_containsHeader.png differ
diff --git a/inst/shiny/abanico/www/file_sep.png b/inst/shiny/abanico/www/file_sep.png
new file mode 100644
index 0000000..0297e61
Binary files /dev/null and b/inst/shiny/abanico/www/file_sep.png differ
diff --git a/inst/shiny/abanico/www/file_structure.png b/inst/shiny/abanico/www/file_structure.png
new file mode 100644
index 0000000..5e3b50a
Binary files /dev/null and b/inst/shiny/abanico/www/file_structure.png differ
diff --git a/inst/shiny/abanico/www/style.css b/inst/shiny/abanico/www/style.css
new file mode 100644
index 0000000..295b46c
--- /dev/null
+++ b/inst/shiny/abanico/www/style.css
@@ -0,0 +1,73 @@
+.custom-modal {
+ padding-left: 10px;
+ padding-top: 10px;
+ padding-bottom: 10px;
+ padding-right: 10px;
+ line-height: 200%;
+ background-color: #fff;
+ overflow: visible;
+ position: absolute;
+ z-index: 999;
+ border-radius: 10px;
+ border-style: solid;
+ border-color: #428bca;
+}
+
+.h {
+ font-size: 11px;
+ margin: 0 0 0px;
+}
+
+h5, h6 {
+ color: #428bca;
+ font-weight: 700;
+}
+
+.tooltip-inner {
+ max-width: 450px;
+}
+
+.control-label, .selectize-dropdown, .item, .btn, .uneditable-input, .sorting, .odd, .even, .dataTables-info, .fa, .fa-refresh {
+ font-size: 12px;
+}
+
+.selectize-input {
+ padding: 0px 10px;
+ min-height: 20px;
+}
+
+label, body, input {
+ font-size: 12px;
+ font-weight: 100 !important;
+}
+
+.label, .badge {
+ font-size: 12px;
+ padding: 4px 20px;
+ margin: 10px;
+ line-height: 18px;
+ font-weight: 100 !important;
+}
+
+.label-info, .badge-info {
+background-color: #428bca;
+}
+
+input[type="text"],input[type="number"],input[type="email"],input[type="url"],input[type="search"],input[type="tel"],input[type="color"],.uneditable-input{
+ display:inline-block;
+ height:18px;
+ padding:0px 0px 0px 7px;
+ margin-bottom:10px;
+ font-size: 11px;
+ line-height: 1.5;
+ color:#555;
+ vertical-align:middle;
+ -webkit-border-radius:4px;
+ -moz-border-radius:4px;
+ border-radius:4px
+ }
+
+input,textarea,.uneditable-input{
+ width: auto;
+ }
+
diff --git a/inst/shiny/cosmicdose/server.R b/inst/shiny/cosmicdose/server.R
new file mode 100644
index 0000000..72d1661
--- /dev/null
+++ b/inst/shiny/cosmicdose/server.R
@@ -0,0 +1,124 @@
+## Server.R
+library(Luminescence)
+library(shiny)
+library(googleVis)
+
+## MAIN FUNCTION
+shinyServer(function(input, output, session) {
+
+ # function to convert coordinates to degree decimal format
+ coord_conv<- function(x, id) {
+ if(id=="degDecMin") {
+ x<- paste(as.character(sum(input$degN_1, input$decMinN/60)),":",
+ as.character(sum(input$degE_1, input$decMinE/60)), sep = "")
+ }
+ if(id=="degMinSec") {
+ x<- paste(as.character(sum(input$degN_2,input$minN/60,input$secN/3600)),":",
+ as.character(sum(input$degE_2,input$minE/60,input$secE/3600)), sep = "")
+ }
+ return(x)
+ }
+
+
+ # coordinate conversion
+ coords<- reactive({
+ if(input$coords != "decDeg") {
+ LatLong<- ifelse(input$coords=="degDecMin",
+ coord_conv(, id="degDecMin"), # YES
+ coord_conv(, id ="degMinSec")) # NO
+ } else {
+ LatLong<- paste(input$decDegN,":",input$decDegE,sep="")
+ }
+
+ # return data frame
+ d<- data.frame(LatLong = LatLong, tip = "Site")
+ return(d)
+ })
+
+ # googleVis Map options
+ myOptionsMap<- reactive({
+ opt<- list(enableScrollWheel = TRUE,
+ showTip = TRUE,
+ useMapTypeControl = TRUE,
+ mapType = "terrain")
+ return(opt)
+ })
+
+ # render googleVis map
+ output$map<- renderGvis({
+ # refresh plot on button press
+ input$refresh
+
+ gvisMap(data = coords(), locationvar = "LatLong", tipvar = "tip", options = myOptionsMap())
+ })
+
+
+ # get results from calc_CosmicDoseRate() function
+ get_results<- reactive({
+
+ # get coordinates
+ coords<- as.vector(coords()$LatLong)
+ lat<- as.numeric(unlist(strsplit(x = coords, split = ":"))[1])
+ long<- as.numeric(unlist(strsplit(x = coords, split = ":"))[2])
+
+ # get absorber properties
+ depth<- na.omit(c(input$depth_1, input$depth_2, input$depth_3, input$depth_4, input$depth_5))
+ density<- na.omit(c(input$density_1, input$density_2, input$density_3, input$density_4, input$density_5))
+
+ t<- get_RLum(calc_CosmicDoseRate(depth = depth,
+ density = density,
+ latitude = lat,
+ longitude = long,
+ altitude = input$altitude,
+ corr.fieldChanges = input$corr,
+ est.age = input$estage,
+ half.depth = input$half,
+ error = input$error), "summary")
+ return(t)
+ })
+
+
+ # render results for mode 1 and 2
+ output$results<- renderUI({
+
+ # refresh plot on button press
+ input$refresh
+
+ if(input$mode == "sAsS" || input$mode == "xAsS") {
+
+ t<- get_results()
+ HTML(
+ if(input$mode=="xAsS") {
+ paste("Sample depth: ","<font size='3'>", "<code>",
+ sum(na.omit(input$depth_1), na.omit(input$depth_2), na.omit(input$depth_3), na.omit(input$depth_4), na.omit(input$depth_5)),
+ "m", "</code>", "</font>", "<br>")
+ },
+ "Total absorber: ","<font size='3'>", "<code>", t$total_absorber.gcm2, "g/cm\u00b2", "</code>", "</font>", "<br>",
+ "Cosmic dose rate (uncorrected): ","<font size='3'>", "<code>", round(t$d0, 3), "Gy/ka", "</code>", "</font>", "<br>",
+ "Geomagnetic latitude: ","<font size='3'>", "<code>", round(t$geom_lat, 2), "\u00b0", "</code>", "</font>", "<br>",
+ "Cosmic dose rate (corrected): ","<font size='3'>", "<code>", round(t$dc, 3),"\u00b1", round(t$dc/100*input$error, 3), "Gy/ka", "</code>", "<br> ", "</font>"
+
+ )
+ }
+ })
+
+ # render results for mode 3
+ output$resultsTable<- renderDataTable({
+
+ # refresh plot on button press
+ input$refresh
+
+ if(input$mode == "sAxS") {
+
+ t<- get_results()
+
+ table<- as.data.frame(cbind(t$depth, t$total_absorber.gcm2, round(t$d0, 3), round(t$dc,3), round(t$dc/100*input$error, 3)))
+ colnames(table)<- c("Depth (m)",
+ "Absorber (g/cm\u00b2)",
+ "Dc (Gy/ka) [uncorrected]",
+ "Dc (Gy/ka) [corrected]",
+ "Dc error (Gy/ka)")
+ table
+ }
+ }, options=list(autoWidth = FALSE, paging = FALSE, processing = TRUE)) # jQuery DataTables options (http://datatables.net)
+})
\ No newline at end of file
diff --git a/inst/shiny/cosmicdose/ui.R b/inst/shiny/cosmicdose/ui.R
new file mode 100644
index 0000000..4d6f5be
--- /dev/null
+++ b/inst/shiny/cosmicdose/ui.R
@@ -0,0 +1,123 @@
+library(RLumShiny)
+
+shinyUI(fluidPage(
+ includeCSS("./www/style.css"),
+ fluidRow(
+ column(width = 3,
+ div(align = "center", span(class="label label-info", "Site")),
+ wellPanel(
+ numericInput(inputId = "altitude", label = p(class="h","Altitude (m asl)"), value = 124, step = 1),
+ tooltip(refId = "altitude", text = "Altitude (m above sea-level)"),
+ selectInput(inputId = "coords", label = "Coordinates", selected = "decDeg",
+ choices = c("Decimal degrees" = "decDeg",
+ "Degrees decimal minutes" = "degDecMin",
+ "Degrees minutes seconds" = "degMinSec")),
+
+ conditionalPanel(condition = "input.coords == 'decDeg'",
+ numericInput(inputId = "decDegN", label = p(class="h","North"), value = 50.926903, step = 0.000001),
+ numericInput(inputId = "decDegE", label = p(class="h","East"), value = 6.937453, step = 0.000001)
+ ),
+ conditionalPanel(condition = "input.coords == 'degDecMin'",
+ fluidRow(
+ column(width = 4,
+ numericInput(inputId = "degN_1", label = p(class="h","N: \uB0"), value = 50, step = 1),
+ numericInput(inputId = "degE_1", label = p(class="h","E: \uB0"), value = 6, step = 1)
+ ),
+ column(width = 4, offset = 2,
+ numericInput(inputId = "decMinN", label = p(class="h","Decimal \u27"), value = 55.61417, step = 0.000001),
+ numericInput(inputId = "decMinE", label = p(class="h","Decimal \u27"), value = 56.24717, step = 0.000001)
+ )
+ )
+ ),
+ conditionalPanel(condition = "input.coords == 'degMinSec'",
+ fluidRow(
+ column(width = 3, offset = 0,
+ numericInput(inputId = "degN_2", label = p(class="h","N: \uB0"), value = 50, step = 1),
+ numericInput(inputId = "degE_2", label = p(class="h","E: \uB0"), value = 6, step = 1)
+ ),
+ column(width = 3, offset = 1,
+ numericInput(inputId = "minN", label = p(class="h","\u27"), value = 55, step = 1),
+ numericInput(inputId = "minE", label = p(class="h","\u27"), value = 56, step = 1)
+ ),
+ column(width = 3, offset = 1,
+ numericInput(inputId = "secN", label = p(class="h","\u27\u27"), value = 36.85, step = 0.01),
+ numericInput(inputId = "secE", label = p(class="h","\u27\u27"), value = 14.83, step = 0.01)
+ )
+ )
+ )
+ )
+ ),
+ column(width = 3,
+ div(align = "center", span(class="label label-info", "Sediment")),
+
+ wellPanel(
+ numericInput(inputId = "density_1", label = p(class="h","Density (g/cm\uB3)"), value = 2.0, step = 0.1),
+ tooltip(refId = "density_1", text = "Average overburden density (g/cm\uB3)."),
+
+ conditionalPanel(condition = "input.mode == 'xAsS'",
+ numericInput(inputId = "density_2", label = p(class="h","Density (g/cm\uB3)"), value = NULL, step = 0.1),
+ numericInput(inputId = "density_3", label = p(class="h","Density (g/cm\uB3)"), value = NULL, step = 0.1),
+ numericInput(inputId = "density_4", label = p(class="h","Density (g/cm\uB3)"), value = NULL, step = 0.1),
+ numericInput(inputId = "density_5", label = p(class="h","Density (g/cm\uB3)"), value = NULL, step = 0.1)
+ )
+
+ )
+ ),
+ column(width = 3,
+ div(align = "center", span(class="label label-info", "Samples")),
+
+ wellPanel(
+ numericInput(inputId = "depth_1", label = p(class="h","Depth (m)"), value = 1.00, step = 0.01),
+ tooltip("depth_1", text = "Depth of overburden (m)."),
+
+ conditionalPanel(condition = "input.mode == 'sAxS' || input.mode == 'xAsS'",
+ numericInput(inputId = "depth_2", label = p(class="h","Depth (m)"), value = NULL, step = 0.01),
+ numericInput(inputId = "depth_3", label = p(class="h","Depth (m)"), value = NULL, step = 0.01),
+ numericInput(inputId = "depth_4", label = p(class="h","Depth (m)"), value = NULL, step = 0.01),
+ numericInput(inputId = "depth_5", label = p(class="h","Depth (m)"), value = NULL, step = 0.01)
+ )
+ )
+ ),
+ column(width = 3,
+ div(align = "center", span(class="label label-info", "Options")),
+
+ wellPanel(
+ checkboxInput(inputId = "corr", label = p(class="h","Correct for geomagnetic field changes"), value = FALSE),
+ tooltip(refId = "corr", text = "Correct for geomagnetic field changes after Prescott & Hutton (1994). Apply only when justified by the data."),
+ numericInput(inputId = "estage", label = p(class="h","Estimated age"), value = 30, step = 1, min = 0, max = 80),
+ tooltip(refId = "estage", text = "Estimated age range (ka) for geomagnetic field change correction (0-80 ka allowed)."),
+ checkboxInput(inputId = "half", label = p(class="h","Use half the depth"), value = FALSE),
+ tooltip(refId = "half", text = " How to overcome with varying overburden thickness. If TRUE only half the depth is used for calculation. Apply only when justified, i.e. when a constant sedimentation rate can safely be assumed."),
+ numericInput(inputId = "error", label = p(class="h","General error (%)"), value = 10, step = 1),
+ tooltip(refId = "error", text = "General error (percentage) to be implemented on corrected cosmic dose rate estimate"),
+ selectInput(inputId = "mode", label = "Mode", selected = "sAsS",
+ choices = c("1 absorber, 1 sample" = "sAsS",
+ "x absorber, 1 sample" = "xAsS",
+ "1 absorber, x samples" = "sAxS"))
+ ),
+
+ actionButton(inputId = "refresh", label = "", icon = icon("refresh")),
+ tooltip(refId = "refresh", text = "Reload app")
+
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ div(id="gmap",
+ htmlOutput("map")
+ )
+ ),
+ column(width = 6,
+ div(align = "center", h6("Results")),
+ conditionalPanel(condition = "input.mode == 'sAsS' || input.mode == 'xAsS'",
+ wellPanel(
+ htmlOutput("results")
+ )),
+ conditionalPanel(condition = "input.mode == 'sAxS'",
+
+ dataTableOutput("resultsTable")
+ )
+ )
+ ),
+ includeCSS("./www/style.css")
+))
\ No newline at end of file
diff --git a/inst/shiny/cosmicdose/www/RL_Logo.png b/inst/shiny/cosmicdose/www/RL_Logo.png
new file mode 100644
index 0000000..ac0551b
Binary files /dev/null and b/inst/shiny/cosmicdose/www/RL_Logo.png differ
diff --git a/inst/shiny/cosmicdose/www/RL_Logo_alpha.png b/inst/shiny/cosmicdose/www/RL_Logo_alpha.png
new file mode 100644
index 0000000..064777f
Binary files /dev/null and b/inst/shiny/cosmicdose/www/RL_Logo_alpha.png differ
diff --git a/inst/shiny/cosmicdose/www/style.css b/inst/shiny/cosmicdose/www/style.css
new file mode 100644
index 0000000..97ea611
--- /dev/null
+++ b/inst/shiny/cosmicdose/www/style.css
@@ -0,0 +1,86 @@
+.custom-modal {
+ padding-left: 10px;
+ padding-top: 10px;
+ padding-bottom: 10px;
+ padding-right: 10px;
+ line-height: 200%;
+ background-color: #fff;
+ overflow: visible;
+ position: absolute;
+ z-index: 999;
+ border-radius: 10px;
+ border-style: solid;
+ border-color: #428bca;
+}
+
+.h {
+ font-size: 11px;
+ margin: 0 0 0px;
+}
+
+h5 {
+ color: #428bca;
+ font-family:"Lucida Console", Monaco, monospace;
+ font-weight: 700;
+}
+
+h6 {
+ font-size: 16px;
+ color: #428bca;
+ font-family:"Lucida Console", Monaco, monospace;
+}
+
+.tooltip-inner {
+ max-width: 450px;
+}
+
+#gmap {
+ border-style: solid;
+ border-width: 2px;
+ border-color: #428bca;
+ margin-top: 40px;
+}
+
+.control-label, .selectize-dropdown, .item, .uneditable-input, .sorting, .odd, .even, .dataTables-info, .fa, .fa-refresh {
+ font-size: 11px;
+}
+
+.selectize-input {
+ padding: 0px 10px;
+ min-height: 20px;
+}
+
+.label, .badge {
+ font-size: 14px;
+ padding: 4px 20px;
+ margin: 10px;
+ line-height: 36px;
+ font-weight: 100 !important;
+}
+
+.label-info, .badge-info {
+background-color: #428bca;
+}
+
+input[type="text"],input[type="number"],input[type="email"],input[type="url"],input[type="search"],input[type="tel"],input[type="color"],.uneditable-input{
+ display:inline-block;
+ height:18px;
+ padding:0px 0px 0px 7px;
+ margin-bottom:10px;
+ font-size: 11px;
+ line-height: 1.5;
+ color:#555;
+ vertical-align:middle;
+ -webkit-border-radius:4px;
+ -moz-border-radius:4px;
+ border-radius:4px
+ }
+
+input,textarea,.uneditable-input{
+ width: auto;
+ }
+
+.well {
+ padding: 5px 19px;
+}
+
diff --git a/inst/shiny/doserecovery/server.R b/inst/shiny/doserecovery/server.R
new file mode 100644
index 0000000..e02cb18
--- /dev/null
+++ b/inst/shiny/doserecovery/server.R
@@ -0,0 +1,282 @@
+## Server.R
+library(Luminescence)
+library(shiny)
+
+## read example data set and misapply them for this plot type
+data(ExampleData.DeValues, envir = environment())
+ExampleData.DeValues <- ExampleData.DeValues$BT998
+
+##############################################################################
+### MAIN PROGRAM ###
+##############################################################################
+
+shinyServer(function(input, output, session) {
+
+ # check and read in file (DATA SET 1)
+ datGet<- reactive({
+ inFile<- input$file1
+ if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL
+ return(read.table(file = inFile$datapath, # inFile[1] contains filepath
+ sep = input$sep,
+ quote = "",
+ header = input$headers)) # else return file
+ })
+
+ # check and read in file (DATA SET 2)
+ datGet2<- reactive({
+ inFile2<- input$file2
+ if(is.null(inFile2)) return(NULL) # if no file was uploaded return NULL
+ return(read.table(file = inFile2$datapath, # inFile[1] contains filepath
+ sep = input$sep,
+ quote = "",
+ header = input$headers)) # else return file
+ })
+
+ ### GET DATA SETS
+ Data<- reactive({
+ if(!is.null(datGet())) {
+ if(!is.null(datGet2())) {
+ data<- list(datGet(), datGet2())
+ } else {
+ data<- list(datGet())
+ }
+ } else {
+ x.1 <- ExampleData.DeValues[7:11,]
+ x.2 <- ExampleData.DeValues[7:11,] * c(runif(5, 0.9, 1.1), 1)
+ data<- list(x.1, x.2)
+ }
+ })
+
+
+ output$xlim<- renderUI({
+ data<- Data()
+ n<- nrow(data[[1]])
+
+ sliderInput(inputId = "xlim", label = "Range x-axis",
+ min = 0, max = n*2,
+ value = c(1, n+1))
+ })
+
+ observe({
+ updateTextInput(session, inputId = "xlab",
+ value = if(input$preheat==TRUE){"Preheat Temperature [\u00B0C]"}else{"# Aliquot"})
+ })
+
+ #### PLOT ####
+ output$main_plot <- renderPlot({
+ input$refresh
+
+ data<- Data()
+
+
+ outputOptions(x = output, name = "xlim", suspendWhenHidden = FALSE)
+ validate(
+ need(expr = input$xlim, message = 'Waiting for data... Please wait!')
+ )
+
+
+ # if custom datapoint style get char from separate input panel
+ if(input$pch == "custom") {
+ pch<- input$custompch
+ } else {
+ pch<- as.integer(input$pch)-1 #-1 offset in pch values
+ }
+ # if custom datapoint style get char from separate input panel
+ if(input$pch2 == "custom") {
+ pch2<- input$custompch2
+ } else {
+ pch2<- as.integer(input$pch2)-1 #-1 offset in pch values
+ }
+
+
+ # if custom datapoint color get RGB code from separate input panel
+ if(input$color == "custom") {
+ color<- input$rgb
+ } else {
+ color<- input$color
+ }
+
+ if(length(data) > 1) {
+ # if custom datapoint color get RGB code from separate input panel
+ if(input$color2 == "custom") {
+ color2<- input$rgb2
+ } else {
+ color2<- input$color2
+ }
+ } else {
+ if(input$preheat == TRUE) {
+ color2<- color
+ } else {
+ color2<- "white"
+ }
+ }
+
+ if(length(data)==1){
+ given.dose<- input$dose
+ legend<- input$legendname
+ } else {
+ given.dose<- c(input$dose, input$dose2)
+ legend<- c(input$legendname, input$legendname2)
+ }
+
+ # save all arguments in a list
+ args<- list(values = data,
+ error.range = input$error,
+ given.dose = given.dose,
+ summary = input$stats,
+ summary.pos = input$sumpos,
+ boxplot = input$boxplot,
+ legend = legend,
+ legend.pos = input$legend.pos,
+ main = input$main,
+ mtext = input$mtext,
+ col = c(color, color2),
+ pch = c(pch, pch2),
+ xlab = input$xlab,
+ ylab = input$ylab,
+ xlim = input$xlim,
+ ylim = input$ylim,
+ cex = input$cex)
+
+ if(input$preheat == TRUE) {
+
+ n<- length(data[[1]][,1])
+ ph<- c(input$ph1, input$ph2, input$ph3, input$ph4, input$ph5, input$ph6, input$ph7, input$ph8)
+ ph<- ph[1:n]
+
+ args<- c(args, "preheat" = NA)
+ args$preheat<- ph
+
+ args$pch<- rep(args$pch, n)
+ args$col<- rep(args$col, n)
+
+ }
+
+ # plot DRT Results
+ do.call(what = plot_DRTResults, args = args)
+
+
+ # prepare code as text output
+ if (is.null(input$sep))
+ updateRadioButtons(session, "fileformat", selected = "\t")
+
+ if(input$sep == "\t")
+ verb.sep<- "\\t"
+ else
+ verb.sep<- input$sep
+
+ str1 <- paste("data <- read.delim(file, header = ",input$headers, ", sep= '", verb.sep,"')",
+ sep = "")
+
+ if(!is.null(datGet2())) {
+ str2 <- "file2<- file.choose()"
+ str3 <- paste("data2 <- read.delim(file2, header = ",input$headers, ", sep= '", verb.sep,"')",
+ sep= "")
+ str4 <- "data<- list(data, data2)"
+ str1 <- paste(str1, str2, str3, str4, sep = "\n")
+ }
+
+ header <- paste("# To reproduce the plot in your local R environment",
+ "# copy and run the following code to your R console.",
+ "library(Luminescence)",
+ "file<- file.choose()",
+ str1,
+ "\n",
+ sep = "\n")
+
+ names <- names(args)
+
+ verb.arg <- paste(mapply(function(name, arg) {
+ if (all(inherits(arg, "character")))
+ arg <- paste0("'", arg, "'")
+ if (length(arg) > 1)
+ arg <- paste0("c(", paste(arg, collapse = ", "), ")")
+ if (is.null(arg))
+ arg <- "NULL"
+ paste(name, "=", arg)
+ }, names[-1], args[-1]), collapse = ",\n")
+
+ funCall <- paste0("plot_DRTResults(values = data,\n", verb.arg, ")")
+
+ code.output <- paste0(header, funCall, collapse = "\n")
+
+ # nested renderText({}) for code output on "R plot code" tab
+ output$plotCode<- renderText({
+
+ code.output
+
+ })##EndOf::renderText({})
+
+
+ # nested downloadHandler() to print plot to file
+ output$exportFile <- downloadHandler(
+ filename = function() { paste(input$filename, ".", input$fileformat, sep="") },
+ content = function(file) {
+
+ # determine desired fileformat and set arguments
+ if(input$fileformat == "pdf") {
+ pdf(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ paper = "special",
+ useDingbats = FALSE,
+ family = input$fontfamily)
+ }
+ if(input$fileformat == "svg") {
+ svg(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ family = input$fontfamily)
+ }
+ if(input$fileformat == "eps") {
+ postscript(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ paper = "special",
+ family = input$fontfamily)
+ }
+
+ # plot Abanico Plot
+ do.call(what = plot_DRTResults, args = args)
+
+ dev.off()
+ },#EO content =,
+ contentType = "image"
+ )#EndOf::dowmloadHandler()
+
+ })
+
+ # renderTable() that prints the data to the second tab
+ output$dataset<- renderDataTable(
+ options = list(pageLength = 10, autoWidth = FALSE),
+ callback = "function(table) {
+ table.on('click.dt', 'tr', function() {
+ $(this).toggleClass('selected');
+ Shiny.onInputChange('rows',
+ table.rows('.selected').data().toArray());
+ });}",
+{
+ data<- Data()
+ colnames(data[[1]])<- c("De", "De error")
+ data[[1]]
+})##EndOf::renterTable()
+
+
+# renderTable() that prints the data to the second tab
+output$dataset2<- renderDataTable(
+ options = list(pageLength = 10, autoWidth = FALSE),
+ callback = "function(table) {
+ table.on('click.dt', 'tr', function() {
+ $(this).toggleClass('selected');
+ Shiny.onInputChange('rows',
+ table.rows('.selected').data().toArray());
+ });}",
+{
+ data<- Data()
+ if(length(data)>1) {
+ colnames(data[[2]])<- c("De", "De error")
+ data[[2]]
+ }
+})##EndOf::renterTable()
+
+})
diff --git a/inst/shiny/doserecovery/ui.R b/inst/shiny/doserecovery/ui.R
new file mode 100644
index 0000000..76872e8
--- /dev/null
+++ b/inst/shiny/doserecovery/ui.R
@@ -0,0 +1,380 @@
+library(RLumShiny)
+# Define UI
+pageWithSidebar(
+
+ # Application title
+ headerPanel(title = NULL),
+
+ # 2- width = 5 -> refers to twitters bootstrap grid system
+ # where the the maximum width is 12 that is to be shared between all
+ # elements
+ sidebarPanel(width = 5,
+
+ # include a tabs in the input panel for easier navigation
+ tabsetPanel(id = "tabs", type = "pill", selected = "Data",
+ # Tab 1: Data input
+ tabPanel("Data",
+ # informational text
+ div(align = "center", h5("Data upload")),
+ # file upload button (data set 1)
+ fileInput(inputId = "file1",
+ label = strong("Primary data set"),
+ accept="text/plain"),
+ tooltip(refId = "file1", text = tags$img(src='file_structure.png', width='250px')),
+ # file upload button (data set 2)
+ fileInput(inputId = "file2",
+ label = strong("Secondary data set"),
+ accept="text/plain"),
+ tooltip(refId = "file2", text = tags$img(src='file_structure.png', width='250px')),
+ # informational text
+ div(align = "center", h5("Settings")),
+
+ fluidRow(
+ column(width = 6,
+ # logical: should NA values be excluded?
+ checkboxInput(inputId = "naExclude",
+ label = "Exclude NA values",
+ value = TRUE),
+ tooltip(refId = "naExclude", text = "Exclude NA values from the data set prior to any further operations.")
+ ),
+ column(width = 6,
+ # logical: file contains headers?
+ checkboxInput(inputId = "headers",
+ label = "File contains headers",
+ value = FALSE),
+ tooltip(refId = "headers", text = tags$img(src='file_containsHeader.png', width='250px'))
+ )),
+ # char: columns separated by tab, space, comma
+ radioButtons("sep", "Separator", selected = "\t", inline = TRUE,
+ c("Tab" = "\t",
+ "Space" = " ",
+ "Comma" = ",",
+ "Semicolon" = ";")),
+ tooltip(refId = "sep", text = tags$img(src='file_sep.png', width='400px'), placement = "auto left"),
+ hr(),
+ actionButton(inputId = "refresh", label = "Refresh", icon = icon("refresh")),
+ tooltip(refId = "refresh", text = "Redraw the plot")
+ ),##EndOf::Tab_1
+
+ # Tab 2: Statistical information
+ tabPanel("Statistics",
+ div(align = "center", h5("Summary")),
+ selectInput(inputId = "sumpos",
+ label = "Summary position",
+ selected = "topleft",
+ choices = list("Subtitle" = "sub",
+ "Center" = "center",
+ Top=c("Top" = "top",
+ "Top left" = "topleft",
+ "Top right"= "topright"),
+ Bottom=c("Bottom" = "bottom",
+ "Bottom left" = "bottomleft",
+ "Bottom right" = "bottomright"))),
+ tooltip(refId = "sumpos", attr = "for", text = "Position of the statistical summary. The keyword \"Subtitle\" will only work if no plot subtitle is used."),
+ checkboxGroupInput(inputId = "stats",
+ label = "Parameters",
+ selected = c("n","mean"),
+ choices = c("n" = "n",
+ "Mean" = "mean",
+ "weighted Mean" = "mean.weighted",
+ "Median" = "median",
+ #"weighted Median" = "median.weighted",
+ "rel. Standard deviation" = "sdrel",
+ "abs. Standard deviation" = "sdabs",
+ "rel. Standard error" = "serel",
+ "abs. Standard error" = "seabs",
+ #"25 % Quartile" = "q25", #not implemented yet
+ #"75 % Quartile" = "q75", #not implemented yet
+ "Skewness" = "skewness", #not implemented yet
+ "Kurtosis" = "kurtosis", #not implemented yet
+ "Confidence interval" = "in.ci")),
+ tooltip(refId = "stats", text = "Statistical parameters to be shown in the summary"),
+ br(),
+ div(align = "center", h5("Error range")),
+ numericInput(inputId = "error",
+ label = "Symmetric error range (%)",
+ value = 10, min = 0, max = 100, step = 1),
+ tooltip(refId = "error", text = "Symmetric error range in percent will be shown as dashed lines in the plot. Set error.range to 0 to void plotting of error ranges.")
+ ),##EndOf::Tab_2
+
+ # Tab 3: input that refer to the plot rather than the data
+ tabPanel("DRT Details",
+ div(align = "center", h5("Experimental details")),
+ numericInput(inputId = "dose", label = "Given dose (primary data set)", value = 2800),
+ tooltip(refId = "dose", text = "Given dose used for the dose recovery test to normalise data. If only one given dose is provided this given dose is valid for all input data sets (i.e., values is a list). Otherwise a given dose for each input data set has to be provided (e.g., given.dose = c(100,200)). If no given.dose values are plotted without normalisation (might be useful for preheat plateau tests). Note: Unit has to be the same as from the input va [...]
+ numericInput(inputId = "dose2", label = "Given dose (secondary data set)", value = 3000),
+ div(align = "center", h5("Preheat temperatures")),
+ checkboxInput(inputId = "preheat", label = "Group values by preheat temperature", FALSE),
+ tooltip(refId = "preheat", text = "Optional preheat temperatures to be used for grouping the De values. If specified, the temperatures are assigned to the x-axis."),
+ conditionalPanel(condition = 'input.preheat == true',
+ numericInput(inputId = "ph1", "PH Temperature #1", 180, min = 0),
+ numericInput(inputId = "ph2", "PH Temperature #2", 200, min = 0),
+ numericInput(inputId = "ph3", "PH Temperature #3", 220, min = 0),
+ numericInput(inputId = "ph4", "PH Temperature #4", 240, min = 0),
+ numericInput(inputId = "ph5", "PH Temperature #5", 260, min = 0),
+ numericInput(inputId = "ph6", "PH Temperature #6", 280, min = 0),
+ numericInput(inputId = "ph7", "PH Temperature #7", 300, min = 0),
+ numericInput(inputId = "ph8", "PH Temperature #8", 320, min = 0)
+ )
+ ),##EndOf::Tab_3
+
+ # Tab 3: input that refer to the plot rather than the data
+ tabPanel("Plot",
+ div(align = "center", h5("Title")),
+ fluidRow(
+ column(width = 6,
+ textInput(inputId = "main",
+ label = "Title",
+ value = "DRT Plot")
+ ),
+ column(width = 6,
+ textInput(inputId = "mtext",
+ label = "Subtitle",
+ value = "")
+ )
+ ),
+ div(align = "center", h5("Boxplot")),
+ checkboxInput(inputId = "boxplot", label = "Plot as boxplot", value = FALSE),
+ tooltip(refId = "boxplot", text = "Optionally plot values, that are grouped by preheat temperature as boxplots. Only possible when preheat vector is specified."),
+ div(align = "center", h5("Scaling")),
+ sliderInput(inputId = "cex",
+ label = "Scaling factor",
+ min = 0.5, max = 2,
+ value = 1.0, step = 0.1)
+ ),##EndOf::Tab_3
+
+ # Tab 4: modify axis parameters
+ tabPanel("Axis",
+ div(align = "center", h5("X-axis")),
+ textInput(inputId = "xlab",
+ label = "Label x-axis",
+ value = "# Aliquot"),
+ # inject sliderInput from Server.R
+ uiOutput(outputId = "xlim"),
+ br(),
+ div(align = "center", h5("Y-axis")),
+ textInput(inputId = "ylab",
+ label = "Label y-axis",
+ value = "Normalised De"),
+ sliderInput(inputId = "ylim", label = "Range y-axis",
+ min = 0, max = 3,
+ value = c(0.75, 1.25),
+ step = 0.01)
+ ),##EndOf::Tab_4
+
+ tabPanel("Datapoints",
+ div(align = "center", h5("Primary data set")),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "pch",
+ label = "Style",
+ selected = "17",
+ choices = c("Square"= "1",
+ "Circle"="2",
+ "Triangle point up"="3",
+ "Plus"="4",
+ "Cross"="5",
+ "Diamond"="6",
+ "Triangle point down"="7",
+ "Square cross"="8",
+ "Star"="9",
+ "Diamond plus"="10",
+ "Circle plus"="11",
+ "Triangles up and down"="12",
+ "Square plus"="13",
+ "Circle cross"="14",
+ "Square and Triangle down"="15",
+ "filled Square"="16",
+ "filled Circle"="17",
+ "filled Triangle point up"="18",
+ "filled Diamond"="19",
+ "solid Circle"="20",
+ "Bullet (smaller Circle)"="21",
+ "Custom"="custom"))
+ ),
+ column(width = 6,
+ # show only if custom symbol is desired
+ conditionalPanel(condition = "input.pch == 'custom'",
+ textInput(inputId = "custompch",
+ label = "Insert character",
+ value = "?"))
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "color", label = "Datapoint color",
+ choices = list("Black" = "black",
+ "Grey" = "grey50",
+ "Red" = "#b22222",
+ "Green" = "#6E8B3D",
+ "Blue" = "#428bca",
+ "Custom" = "custom"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.color == 'custom'",
+ jscolorInput(inputId = "rgb",
+ label = "Choose a color"))
+ )
+ ),
+ br(),
+ div(align = "center", h5("Secondary data set")),
+ fluidRow(
+ column(width = 6,
+ ## DATA SET 2
+ selectInput(inputId = "pch2",
+ label = "Style",
+ selected = "17",
+ choices = c("Square"= "1",
+ "Circle"="2",
+ "Triangle point up"="3",
+ "Plus"="4",
+ "Cross"="5",
+ "Diamond"="6",
+ "Triangle point down"="7",
+ "Square cross"="8",
+ "Star"="9",
+ "Diamond plus"="10",
+ "Circle plus"="11",
+ "Triangles up and down"="12",
+ "Square plus"="13",
+ "Circle cross"="14",
+ "Square and Triangle down"="15",
+ "filled Square"="16",
+ "filled Circle"="17",
+ "filled Triangle point up"="18",
+ "filled Diamond"="19",
+ "solid Circle"="20",
+ "Bullet (smaller Circle)"="21",
+ "Custom"="custom"))
+ ),
+ column(width = 6,
+ # show only if custom symbol is desired
+ conditionalPanel(condition = "input.pch2 == 'custom'",
+ textInput(inputId = "custompch2",
+ label = "Insert character",
+ value = "?"))
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "color2", label = "Datapoint color",
+ selected = "#b22222",
+ choices = list("Black" = "black",
+ "Grey" = "grey50",
+ "Red" = "#b22222",
+ "Green" = "#6E8B3D",
+ "Blue" = "#428bca",
+ "Custom" = "custom"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.color2 == 'custom'",
+ jscolorInput(inputId = "rgb2",
+ label = "Choose a color"))
+ )
+ )
+ ),##EndOf::Tab_5
+
+ # Tab xy: add and customize legend
+ tabPanel("Legend",
+ div(align = "center", h5("Legend")),
+ fluidRow(
+ column(width = 6,
+ textInput(inputId = "legendname",
+ label = "Primary data label",
+ value = "primary data")
+ ),
+ column(width = 6,
+ textInput(inputId = "legendname2",
+ label = "Secondary data label",
+ value = "secondary data")
+ )
+ ),
+ selectInput(inputId = "legend.pos",
+ label = "Legend position",
+ selected = "bottomleft",
+ choices = c("Top" = "top",
+ "Top left" = "topleft",
+ "Top right"= "topright",
+ "Center" = "center",
+ "Bottom" = "bottom",
+ "Bottom left" = "bottomleft",
+ "Bottom right" = "bottomright"))
+ ),##EndOf::Tab_xy
+
+ # Tab xy: save plot as pdf, wmf or eps
+ tabPanel("Export",
+ radioButtons(inputId = "fileformat",
+ label = "Fileformat",
+ selected = "pdf",
+ choices = c("PDF (Portable Document Format)" = "pdf",
+ "SVG (Scalable Vector Graphics)" = "svg",
+ "EPS (Encapsulated Postscript)" = "eps")),
+ textInput(inputId = "filename",
+ label = "Filename",
+ value = "DRT Plot"),
+ fluidRow(
+ column(width = 6,
+ numericInput(inputId = "imgheight",
+ label = "Image height",
+ value = 7)
+ ),
+ column(width = 6,
+ numericInput(inputId = "imgwidth",
+ label = "Image width",
+ value = 7)
+ )
+ ),
+ selectInput(inputId = "fontfamily",
+ label = "Font",
+ selected = "Helvetica",
+ choices = c("Helvetica" = "Helvetica",
+ "Helvetica Narrow" = "Helvetica Narrow",
+ "Times" = "Times",
+ "Courier" = "Courier",
+ "Bookman" = "Bookman",
+ "Palatino" = "Palatino")),
+ tags$hr(),
+ downloadButton(outputId = "exportFile",
+ label = "Download plot")
+ ),##EndOf::Tab_
+
+ # Tab xy: further information
+ tabPanel("About",
+ hr(),
+ div(align = "center",
+ # HTML code to include a .png file in the tab; the image file must be in
+ # a subfolder called "wwww"
+ img(src="RL_Logo.png", height = 100, width = 100, alt = "R.Lum"),
+ p("Links:"),
+ a(href = "http://www.r-luminescence.de", "R.Luminescence project page", target="_blank"),
+ br(),
+ a(href = "https://forum.r-luminescence.de", "Message board", target="_blank"),
+ br(),
+ a(href = "http://zerk.canopus.uberspace.de/R.Lum", "Online application", target="_blank"),
+ br(),hr(),
+ img(src='GitHub-Mark-32px.png', width='32px', height='32px'),
+ br(),
+ a(href = "https://github.com/tzerk/RLumShiny/tree/master/inst/shiny/doserecovery", "See the code at GitHub!", target="_blank")
+ )#/div
+ )##EndOf::Tab_xy
+ )
+ ),
+
+
+ # Show a plot of the generated distribution
+ mainPanel(width = 7,
+ # insert css code inside <head></head> of the generated HTML file:
+ # allow open dropdown menus to reach over the container
+ tags$head(tags$style(type="text/css",".tab-content {overflow: visible;}")),
+ tags$head(includeCSS("www/style.css")),
+ # divide output in separate tabs via tabsetPanel
+ tabsetPanel(
+ tabPanel("Plot", plotOutput(outputId = "main_plot", height = "400px")),
+ tabPanel("Primary data set", fluidRow(column(width = 12, dataTableOutput("dataset")))),
+ tabPanel("Secondary data set", dataTableOutput("dataset2")),
+ tabPanel("R plot code", verbatimTextOutput("plotCode"))
+ )
+ )
+)
\ No newline at end of file
diff --git a/inst/shiny/doserecovery/www/GitHub-Mark-32px.png b/inst/shiny/doserecovery/www/GitHub-Mark-32px.png
new file mode 100644
index 0000000..8b25551
Binary files /dev/null and b/inst/shiny/doserecovery/www/GitHub-Mark-32px.png differ
diff --git a/inst/shiny/doserecovery/www/RL_Logo.png b/inst/shiny/doserecovery/www/RL_Logo.png
new file mode 100644
index 0000000..ac0551b
Binary files /dev/null and b/inst/shiny/doserecovery/www/RL_Logo.png differ
diff --git a/inst/shiny/doserecovery/www/file_containsHeader.png b/inst/shiny/doserecovery/www/file_containsHeader.png
new file mode 100644
index 0000000..7abe3d2
Binary files /dev/null and b/inst/shiny/doserecovery/www/file_containsHeader.png differ
diff --git a/inst/shiny/doserecovery/www/file_sep.png b/inst/shiny/doserecovery/www/file_sep.png
new file mode 100644
index 0000000..0297e61
Binary files /dev/null and b/inst/shiny/doserecovery/www/file_sep.png differ
diff --git a/inst/shiny/doserecovery/www/file_structure.png b/inst/shiny/doserecovery/www/file_structure.png
new file mode 100644
index 0000000..5e3b50a
Binary files /dev/null and b/inst/shiny/doserecovery/www/file_structure.png differ
diff --git a/inst/shiny/doserecovery/www/style.css b/inst/shiny/doserecovery/www/style.css
new file mode 100644
index 0000000..295b46c
--- /dev/null
+++ b/inst/shiny/doserecovery/www/style.css
@@ -0,0 +1,73 @@
+.custom-modal {
+ padding-left: 10px;
+ padding-top: 10px;
+ padding-bottom: 10px;
+ padding-right: 10px;
+ line-height: 200%;
+ background-color: #fff;
+ overflow: visible;
+ position: absolute;
+ z-index: 999;
+ border-radius: 10px;
+ border-style: solid;
+ border-color: #428bca;
+}
+
+.h {
+ font-size: 11px;
+ margin: 0 0 0px;
+}
+
+h5, h6 {
+ color: #428bca;
+ font-weight: 700;
+}
+
+.tooltip-inner {
+ max-width: 450px;
+}
+
+.control-label, .selectize-dropdown, .item, .btn, .uneditable-input, .sorting, .odd, .even, .dataTables-info, .fa, .fa-refresh {
+ font-size: 12px;
+}
+
+.selectize-input {
+ padding: 0px 10px;
+ min-height: 20px;
+}
+
+label, body, input {
+ font-size: 12px;
+ font-weight: 100 !important;
+}
+
+.label, .badge {
+ font-size: 12px;
+ padding: 4px 20px;
+ margin: 10px;
+ line-height: 18px;
+ font-weight: 100 !important;
+}
+
+.label-info, .badge-info {
+background-color: #428bca;
+}
+
+input[type="text"],input[type="number"],input[type="email"],input[type="url"],input[type="search"],input[type="tel"],input[type="color"],.uneditable-input{
+ display:inline-block;
+ height:18px;
+ padding:0px 0px 0px 7px;
+ margin-bottom:10px;
+ font-size: 11px;
+ line-height: 1.5;
+ color:#555;
+ vertical-align:middle;
+ -webkit-border-radius:4px;
+ -moz-border-radius:4px;
+ border-radius:4px
+ }
+
+input,textarea,.uneditable-input{
+ width: auto;
+ }
+
diff --git a/inst/shiny/histogram/server.R b/inst/shiny/histogram/server.R
new file mode 100644
index 0000000..7664de0
--- /dev/null
+++ b/inst/shiny/histogram/server.R
@@ -0,0 +1,300 @@
+## Server.R
+library(Luminescence)
+library(shiny)
+
+# load example data
+data(ExampleData.DeValues)
+data <- ExampleData.DeValues$CA1
+
+## MAIN FUNCTION
+shinyServer(function(input, output, session) {
+
+ # check and read in file (DATA SET 1)
+ datGet<- reactive({
+ inFile<- input$file1
+ if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL
+ return(read.table(file = inFile$datapath, # inFile[1] contains filepath
+ sep = input$sep,
+ quote = "",
+ header = input$headers)) # else return file
+ })
+
+
+ # dynamically inject sliderInput for x-axis range
+ output$xlim<- renderUI({
+
+ # check if file is loaded
+ # # case 1: yes -> slinderInput with custom values
+ if(!is.null(datGet())) {
+
+ data<- datGet()
+ xlim.plot<- range(hist(data[,1], plot = FALSE)$breaks)
+
+ sliderInput(inputId = "xlim",
+ label = "Range x-axis",
+ min = xlim.plot[1]*0.5,
+ max = xlim.plot[2]*1.5,
+ value = c(xlim.plot[1], xlim.plot[2]), round=FALSE, step=0.0001)
+ }
+
+ else { #case 2: no -> sliderInput for example data
+
+ xlim.plot<- range(hist(data[,1], plot = FALSE)$breaks)
+
+ sliderInput(inputId = "xlim",
+ label = "Range x-axis",
+ min = xlim.plot[1]*0.5,
+ max = xlim.plot[2]*1.5,
+ value = c(xlim.plot[1], xlim.plot[2]), round=FALSE, step=0.0001)
+ }
+ })## EndOf::renderUI()
+
+
+ output$main_plot <- renderPlot({
+
+ # refresh plot on button press
+ input$refresh
+
+ # progress bar
+ progress<- Progress$new(session, min = 0, max = 3)
+ progress$set(message = "Calculation in progress",
+ detail = "Retrieve data")
+ on.exit(progress$close())
+
+ # make sure that input panels are registered on non-active tabs.
+ # by default tabs are suspended and input variables are hence
+ # not available
+ outputOptions(x = output, name = "xlim", suspendWhenHidden = FALSE)
+
+ # check if file is loaded and overwrite example data
+ if(!is.null(datGet())) {
+ data<- datGet()
+ }
+
+ progress$set(value = 1)
+ progress$set(message = "Calculation in progress",
+ detail = "Get values")
+
+ # check if any summary stats are activated, else NA
+ if (input$summary) {
+ summary<- input$stats
+ } else {
+ summary<- NA
+ }
+
+ # if custom datapoint color get RGB code from separate input panel
+ if(input$pchColor == "custom") {
+ pch.color<- input$pchRgb
+ } else {
+ pch.color<- input$pchColor
+ }
+
+ # if custom datapoint color get RGB code from separate input panel
+ if(input$barsColor == "custom") {
+ bars.color<- adjustcolor(col = input$barsRgb,
+ alpha.f = input$alpha.bars/100)
+ } else {
+ bars.color<- adjustcolor(col = input$barsColor,
+ alpha.f = input$alpha.bars/100)
+ }
+
+ # if custom datapoint color get RGB code from separate input panel
+ if(input$rugsColor == "custom") {
+ rugs.color<- input$rugsRgb
+ } else {
+ rugs.color<- input$rugsColor
+ }
+
+ # if custom datapoint color get RGB code from separate input panel
+ if(input$normalColor == "custom") {
+ normal.color<- input$normalRgb
+ } else {
+ normal.color<- input$normalColor
+ }
+
+ # update progress bar
+ progress$set(value = 2)
+ progress$set(message = "Calculation in progress",
+ detail = "Combine values")
+
+ colors<- c(bars.color, rugs.color, normal.color, pch.color)
+
+ # if custom datapoint style get char from separate input panel
+ if(input$pch == "custom") {
+ pch<- input$custompch
+ } else {
+ pch<- as.integer(input$pch)-1 #-1 offset in pch values
+ }
+
+ # validate(need()) makes sure that all data are available to
+ # renderUI({}) before plotting and will wait until there
+ validate(
+ need(expr = input$xlim, message = 'Waiting for data... Please wait!')
+ )
+
+ progress$set(value = 3)
+ progress$set(message = "Calculation in progress",
+ detail = "Ready to plot")
+
+ args <- list(data = data,
+ na.rm = input$naExclude,
+ cex.global = input$cex,
+ pch = pch,
+ xlim = input$xlim,
+ summary.pos = input$sumpos,
+ mtext = input$mtext,
+ main = input$main,
+ rug = input$rugs,
+ se = input$errorBars,
+ normal_curve = input$norm,
+ summary = summary,
+ xlab = input$xlab,
+ ylab = c(input$ylab1, input$ylab2),
+ colour = colors)
+
+ do.call(plot_Histogram, args = args)
+
+ # prepare code as text output
+ if (is.null(input$sep))
+ updateRadioButtons(session, "fileformat", selected = "\t")
+
+ if(input$sep == "\t")
+ verb.sep<- "\\t"
+ else
+ verb.sep<- input$sep
+
+ str1 <- paste("data <- read.delim(file, header = ",input$headers, ", sep= '", verb.sep,"')",
+ sep = "")
+
+ header <- paste("# To reproduce the plot in your local R environment",
+ "# copy and run the following code to your R console.",
+ "library(Luminescence)",
+ "file<- file.choose()",
+ str1,
+ "\n",
+ sep = "\n")
+
+ names <- names(args)
+
+ verb.arg <- paste(mapply(function(name, arg) {
+ if (all(inherits(arg, "character")))
+ arg <- paste0("'", arg, "'")
+ if (length(arg) > 1)
+ arg <- paste0("c(", paste(arg, collapse = ", "), ")")
+ if (is.null(arg))
+ arg <- "NULL"
+ paste(name, "=", arg)
+ }, names[-1], args[-1]), collapse = ",\n")
+
+ funCall <- paste0("plot_Histogram(data = data,\n", verb.arg, ")")
+
+ code.output <- paste0(header, funCall, collapse = "\n")
+
+ # nested renderText({}) for code output on "R plot code" tab
+ output$plotCode<- renderText({
+
+ code.output
+
+ })##EndOf::renderText({})
+
+ output$exportScript <- downloadHandler(
+ filename = function() { paste(input$filename, ".", "R", sep="") },
+ content = function(file) {
+ write(code.output, file)
+ },#EO content =,
+ contentType = "text"
+ )#EndOf::dowmloadHandler()
+
+
+ # nested downloadHandler() to print plot to file
+ output$exportFile <- downloadHandler(
+ filename = function() { paste(input$filename, ".", input$fileformat, sep="") },
+ content = function(file) {
+
+ # determine desired fileformat and set arguments
+ if(input$fileformat == "pdf") {
+ pdf(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ paper = "special",
+ useDingbats = FALSE,
+ family = input$fontfamily)
+ }
+ if(input$fileformat == "svg") {
+ svg(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ family = input$fontfamily)
+ }
+ if(input$fileformat == "eps") {
+ postscript(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ paper = "special",
+ family = input$fontfamily)
+ }
+
+ do.call(plot_Histogram, args = args)
+
+ dev.off()
+
+ },#EO content =,
+ contentType = "image"
+ )#EndOf::dowmloadHandler()
+ })##EndOf::renderPlot({})
+
+
+ # renderTable() that prints the data to the second tab
+ output$dataset<- renderDataTable(
+ options = list(pageLength = 10, autoWidth = FALSE),
+ callback = "function(table) {
+ table.on('click.dt', 'tr', function() {
+ $(this).toggleClass('selected');
+ Shiny.onInputChange('rows',
+ table.rows('.selected').data().toArray());
+ });
+}",
+{
+ if(!is.null(datGet())) {
+ data<- datGet()
+ colnames(data)<- c("De","De error")
+ data
+ } else {
+ colnames(data)<- c("De","De error")
+ data
+ }
+ })##EndOf::renterTable()
+
+
+ # reactive function for gVis plots that allow for dynamic input!
+ myOptionsCAM<- reactive({
+ options<- list(
+ page="enable",
+ width="500px",
+ sort="disable")
+ return(options)
+ })
+
+ # renderTable() to print the results of the
+ # central age model (CAM)
+ output$CAM<- renderDataTable(
+ options = list(pageLength = 10, autoWidth = FALSE),
+{
+ if(!is.null(datGet())) {
+ data<- list(datGet())
+ } else {
+ data<- list(data)
+ }
+ t<- as.data.frame(matrix(nrow = length(data), ncol = 7))
+ colnames(t)<- c("Data set","n", "log data", "Central dose", "SE abs.", "OD (%)", "OD error (%)")
+ res<- lapply(data, function(x) { calc_CentralDose(x, verbose = FALSE, plot = FALSE) })
+ for(i in 1:length(res)) {
+ t[i,1]<- ifelse(i==1,"pimary","secondary")
+ t[i,2]<- length(res[[i]]@data$data[,1])
+ t[i,3]<- res[[i]]@data$args$log
+ t[i,4:7]<- round(res[[i]]@data$summary[1:4],2)
+ }
+ t
+})##EndOf::renterTable()
+
+})##EndOf::shinyServer(function(input, output)
\ No newline at end of file
diff --git a/inst/shiny/histogram/ui.R b/inst/shiny/histogram/ui.R
new file mode 100644
index 0000000..a251bd1
--- /dev/null
+++ b/inst/shiny/histogram/ui.R
@@ -0,0 +1,361 @@
+library(RLumShiny)
+## UI.R
+# load example data
+data(ExampleData.DeValues)
+
+# pageWithSidebar contains three panels:
+# 1 - headerPanel: basically just for a header
+# 2 - sidebarPanel: data input
+# 3 - mainPanel: data output
+pageWithSidebar(
+ # 1 - title = NULL -> Panel will not be shown
+ headerPanel(title = NULL),
+ sidebarPanel(width = 5,
+
+ # include a tabs in the input panel for easier navigation
+ tabsetPanel(id = "tabs", type = "pill", selected = "Data",
+ # Tab 1: Data input
+ tabPanel("Data",
+ # informational text
+ div(align = "center", h5("Data upload")),
+ # file upload button (data set 1)
+ fileInput(inputId = "file1",
+ label = strong("Primary data set"),
+ accept="text/plain"),
+ tooltip(refId = "file1", text = tags$img(src='file_structure.png', width='250px')),
+ # logical: should NA values be excluded?
+ checkboxInput(inputId = "naExclude",
+ label = "Exclude NA values",
+ value = TRUE),
+ tooltip(refId = "naExclude", text = "Exclude NA values from the data set prior to any further operations."),
+ # logical: file contains headers?
+ checkboxInput(inputId = "headers",
+ label = "File contains headers",
+ value = FALSE),
+ tooltip(refId = "headers", text = tags$img(src='file_containsHeader.png', width='250px')),
+ # char: columns separated by tab, space, comma
+ radioButtons("sep", "Separator", selected = "\t", inline = TRUE,
+ c("Tab" = "\t",
+ "Space" = " ",
+ "Comma" = ",",
+ "Semicolon" = ";")),
+ tooltip(refId = "sep", text = tags$img(src='file_sep.png', width='400px'), placement = "auto left"),
+ hr(),
+ actionButton(inputId = "refresh", label = "Refresh", icon = icon("refresh")),
+ tooltip(refId = "refresh", text = "Redraw the plot")
+ ),##EndOf::Tab_1
+
+ # Tab 2: Statistical information
+ tabPanel("Statistics",
+ fluidRow(
+ column(width = 6,
+ checkboxInput(inputId = "summary",
+ label = "Show summary",
+ value = FALSE),
+ tooltip(refId = "summary", text = "Adds numerical output to the plot")
+ ),
+ column(width = 6,
+ selectInput(inputId = "sumpos",
+ label = "Summary position",
+ selected = "topleft",
+ choices = list("Subtitle" = "sub",
+ "Center" = "center",
+ Top=c("Top" = "top",
+ "Top left" = "topleft",
+ "Top right"= "topright"),
+ Bottom=c("Bottom" = "bottom",
+ "Bottom left" = "bottomleft",
+ "Bottom right" = "bottomright")
+ )),
+ tooltip(refId = "sumpos", attr = "for", text = "Position of the statistical summary. The keyword \"Subtitle\" will only work if no plot subtitle is used.")
+ )
+ ),
+
+ ## ARG 'SUMMARY.METHOD' NOT YET IMPLEMENTED
+ ##
+ # selectInput(inputId = "summary.method",
+ # label = "Summary method",
+ # selected = "unweighted",
+ # choices = list("Unweighted" = "unweighted",
+ # "Weighted" = "weighted",
+ # "Monte Carlo" = "MCM")),
+ # tooltip(refId = "summary.method", attr = "for", text = "Keyword indicating the method used to calculate the statistic summary. See calc_Statistics for details."),
+
+ checkboxGroupInput(inputId = "stats",
+ label = "Parameters",
+ selected = c("n","mean"),
+ choices = c("n" = "n",
+ "Mean" = "mean",
+ "Median" = "median",
+ "rel. Standard deviation" = "sdrel",
+ "abs. Standard deviation" = "sdabs",
+ "rel. Standard error" = "serel",
+ "abs. Standard error" = "seabs",
+ "Skewness" = "skewness",
+ "Kurtosis" = "kurtosis"
+ # "% in 2 sigma range" = "in.2s"
+ )
+ ),
+ tooltip(refId = "stats", text = "Statistical parameters to be shown in the summary"),
+ div(align = "center", h5("Error bars")),
+ checkboxInput(inputId = "errorBars",
+ label = "Show standard error points",
+ value = TRUE),
+ tooltip(refId = "errorBars", text = "Plot the standard error points over the histogram.")
+ ),##EndOf::Tab_2
+
+ # Tab 1: Data input
+ tabPanel("Plot",
+ div(align = "center", h5("Title")),
+ fluidRow(
+ column(width = 6,
+ textInput(inputId = "main",
+ label = "Title",
+ value = "Histogram")
+ ),
+ column(width = 6,
+ textInput(inputId = "mtext",
+ label = "Subtitle",
+ value = "")
+ )
+ ),
+ div(align = "center", h5("Histogram bars")),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "barsColor", label = "Bar color",
+ selected = "grey80",
+ choices = list("White" = "white",
+ "Black" = "black",
+ "Grey" = "grey80",
+ "Red" = "#b22222",
+ "Green" = "#6E8B3D",
+ "Blue" = "#428bca",
+ "Custom" = "custom"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.barsColor == 'custom'",
+ jscolorInput(inputId = "barsRgb",
+ label = "Choose a color"))
+ )
+ ),
+ sliderInput(inputId = "alpha.bars",
+ label = "Bar transparency",
+ min = 0, max = 100,
+ step = 1, value = 66),
+ br(),
+ div(align = "center", h5("Normal curve")),
+ checkboxInput(inputId = "norm",
+ label = "Add normal curve",
+ value = FALSE),
+ tooltip(refId = "norm", text = "Add a normal curve to the histogram. Mean and standard deviation are calculated from the input data. If the normal curve is added, the y-axis in the histogram will show the probability density"),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "normalColor", label = "Normal curve color",
+ selected = "red",
+ choices = list("Black" = "black",
+ "Grey" = "grey50",
+ "Red" = "#b22222",
+ "Green" = "#6E8B3D",
+ "Blue" = "#428bca",
+ "Custom" = "custom"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.normalColor == 'custom'",
+ jscolorInput(inputId = "normalRgb",
+ label = "Choose a color"))
+ )
+ ),
+ div(align = "center", h5("Scaling")),
+ sliderInput(inputId = "cex",
+ label = "Scaling factor",
+ min = 0.5, max = 2,
+ value = 1.0, step = 0.1),
+ br(),
+ div(align = "center", h5("Rugs")),
+ checkboxInput(inputId = "rugs",
+ label = "Add rugs",
+ value = TRUE),
+ tooltip(refId = "rugs", text = "Option to add a rug to the KDE part, to indicate the location of individual values"),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "rugsColor", label = "Rugs color",
+ choices = list("Black" = "black",
+ "Grey" = "grey50",
+ "Red" = "#b22222",
+ "Green" = "#6E8B3D",
+ "Blue" = "#428bca",
+ "Custom" = "custom"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.rugsColor == 'custom'",
+ jscolorInput(inputId = "rugsRgb",
+ label = "Choose a color"))
+ )
+ )
+ ),##EndOf::Tab_9
+
+ # Tab 4: modify axis parameters
+ tabPanel("Axis",
+ div(align = "center", h5("X-axis")),
+ textInput(inputId = "xlab",
+ label = "Label x-axis",
+ value = "Equivalent dose [Gy]"),
+ # inject sliderInput from Server.R
+ uiOutput(outputId = "xlim"),
+ div(align = "center", h5("Y-axis")),
+ fluidRow(
+ column(width = 6,
+ textInput(inputId = "ylab1",
+ label = "Label y-axis (left)",
+ value = "Counts")
+ ),
+ column(width = 6,
+ textInput(inputId = "ylab2",
+ label = "Label y-axis (right)",
+ value = "Error")
+ )
+ )
+ ),##EndOf::Tab_4
+
+ # Tab 5: modify data point representation
+ tabPanel("Datapoints",
+ div(align = "center", h5("Primary data set")),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "pch",
+ label = "Style",
+ selected = "17",
+ choices = c("Square"= "1",
+ "Circle"="2",
+ "Triangle point up"="3",
+ "Plus"="4",
+ "Cross"="5",
+ "Diamond"="6",
+ "Triangle point down"="7",
+ "Square cross"="8",
+ "Star"="9",
+ "Diamond plus"="10",
+ "Circle plus"="11",
+ "Triangles up and down"="12",
+ "Square plus"="13",
+ "Circle cross"="14",
+ "Square and Triangle down"="15",
+ "filled Square"="16",
+ "filled Circle"="17",
+ "filled Triangle point up"="18",
+ "filled Diamond"="19",
+ "solid Circle"="20",
+ "Bullet (smaller Circle)"="21",
+ "Custom"="custom"))
+ ),
+ column(width = 6,
+ # show only if custom symbol is desired
+ conditionalPanel(condition = "input.pch == 'custom'",
+ textInput(inputId = "custompch",
+ label = "Insert character",
+ value = "?"))
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "pchColor", label = "Datapoint color",
+ choices = list("Black" = "black",
+ "Grey" = "grey50",
+ "Red" = "#b22222",
+ "Green" = "#6E8B3D",
+ "Blue" = "#428bca",
+ "Custom" = "custom"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.pchColor == 'custom'",
+ jscolorInput(inputId = "pchRgb",
+ label = "Choose a color"))
+ )
+ )
+ ),##EndOf::Tab_5
+
+
+ # Tab 9: save plot as pdf, wmf or eps
+ tabPanel("Export",
+ radioButtons(inputId = "fileformat",
+ label = "Fileformat",
+ selected = "pdf",
+ choices = c("PDF (Portable Document Format)" = "pdf",
+ "SVG (Scalable Vector Graphics)" = "svg",
+ "EPS (Encapsulated Postscript)" = "eps")),
+ textInput(inputId = "filename",
+ label = "Filename",
+ value = "Histogram"),
+ fluidRow(
+ column(width = 6,
+ numericInput(inputId = "imgheight",
+ label = "Image height",
+ value = 7)
+ ),
+ column(width = 6,
+ numericInput(inputId = "imgwidth",
+ label = "Image width",
+ value = 7)
+ )
+ ),
+ selectInput(inputId = "fontfamily",
+ label = "Font",
+ selected = "Helvetica",
+ choices = c("Helvetica" = "Helvetica",
+ "Helvetica Narrow" = "Helvetica Narrow",
+ "Times" = "Times",
+ "Courier" = "Courier",
+ "Bookman" = "Bookman",
+ "Palatino" = "Palatino")),
+ tags$hr(),
+ downloadButton(outputId = "exportFile",
+ label = "Download plot"),
+ tags$hr(),
+ helpText("Additionally, you can download a corresponding .R file that contains",
+ "a fully functional script to reproduce the plot in your R environment!"),
+ downloadButton(outputId = "exportScript",
+ label = "Download R script")
+ ),##EndOf::Tab_8
+
+ # Tab 10: further information
+ tabPanel("About",
+ hr(),
+ div(align = "center",
+ # HTML code to include a .png file in the tab; the image file must be in
+ # a subfolder called "wwww"
+ img(src="RL_Logo.png", height = 100, width = 100, alt = "R.Lum"),
+ p("Links:"),
+ a(href = "http://www.r-luminescence.de", "R.Luminescence project page", target="_blank"),
+ br(),
+ a(href = "https://forum.r-luminescence.de", "Message board", target="_blank"),
+ br(),
+ a(href = "http://zerk.canopus.uberspace.de/R.Lum", "Online application", target="_blank"),
+ br(),hr(),
+ img(src='GitHub-Mark-32px.png', width='32px', height='32px'),
+ br(),
+ a(href = "https://github.com/tzerk/RLumShiny/tree/master/inst/shiny/histogram", "See the code at GitHub!", target="_blank")
+ )#/div
+ )##EndOf::Tab_9
+ )##EndOf::tabsetPanel
+ ),##EndOf::sidebarPanel
+
+
+ # 3 - output panel
+ mainPanel(width = 7,
+ # insert css code inside <head></head> of the generated HTML file:
+ # allow open dropdown menus to reach over the container
+ tags$head(tags$style(type="text/css",".tab-content {overflow: visible;}")),
+ tags$head(includeCSS("www/style.css")),
+ # divide output in separate tabs via tabsetPanel
+ tabsetPanel(
+ tabPanel("Plot", plotOutput(outputId = "main_plot", height = "500px")),
+ tabPanel("Data set", dataTableOutput("dataset")),
+ tabPanel("Central Age Model", dataTableOutput("CAM")),
+ tabPanel("R plot code", verbatimTextOutput("plotCode"))
+ )###EndOf::tabsetPanel
+ )##EndOf::mainPanel
+)##EndOf::shinyUI(pageWithSidebar)
\ No newline at end of file
diff --git a/inst/shiny/histogram/www/GitHub-Mark-32px.png b/inst/shiny/histogram/www/GitHub-Mark-32px.png
new file mode 100644
index 0000000..8b25551
Binary files /dev/null and b/inst/shiny/histogram/www/GitHub-Mark-32px.png differ
diff --git a/inst/shiny/histogram/www/RL_Logo.png b/inst/shiny/histogram/www/RL_Logo.png
new file mode 100644
index 0000000..ac0551b
Binary files /dev/null and b/inst/shiny/histogram/www/RL_Logo.png differ
diff --git a/inst/shiny/histogram/www/file_containsHeader.png b/inst/shiny/histogram/www/file_containsHeader.png
new file mode 100644
index 0000000..7abe3d2
Binary files /dev/null and b/inst/shiny/histogram/www/file_containsHeader.png differ
diff --git a/inst/shiny/histogram/www/file_sep.png b/inst/shiny/histogram/www/file_sep.png
new file mode 100644
index 0000000..0297e61
Binary files /dev/null and b/inst/shiny/histogram/www/file_sep.png differ
diff --git a/inst/shiny/histogram/www/file_structure.png b/inst/shiny/histogram/www/file_structure.png
new file mode 100644
index 0000000..5e3b50a
Binary files /dev/null and b/inst/shiny/histogram/www/file_structure.png differ
diff --git a/inst/shiny/histogram/www/style.css b/inst/shiny/histogram/www/style.css
new file mode 100644
index 0000000..1f85dfc
--- /dev/null
+++ b/inst/shiny/histogram/www/style.css
@@ -0,0 +1,73 @@
+.custom-modal {
+ padding-left: 10px;
+ padding-top: 10px;
+ padding-bottom: 10px;
+ padding-right: 10px;
+ line-height: 200%;
+ background-color: #fff;
+ overflow: visible;
+ position: absolute;
+ z-index: 999;
+ border-radius: 10px;
+ border-style: solid;
+ border-color: #428bca;
+}
+
+.h {
+ font-size: 11px;
+ margin: 0 0 0px;
+}
+
+h5, h6 {
+ color: #428bca;
+ font-weight: 700;
+}
+
+.tooltip-inner {
+ max-width: 450px;
+}
+
+.control-label, .selectize-dropdown, .item, .btn, .uneditable-input, .sorting, .odd, .even, .dataTables-info, .fa, .fa-refresh {
+ font-size: 12px;
+}
+
+.selectize-input {
+ padding: 0px 10px;
+ min-height: 20px;
+}
+
+label, body, input {
+ font-size: 12px;
+ font-weight: 100 !important;
+}
+
+.label, .badge {
+ font-size: 12px;
+ padding: 4px 20px;
+ margin: 10px;
+ line-height: 18px;
+ font-weight: 100 !important;
+}
+
+.label-info, .badge-info {
+background-color: #428bca;
+}
+
+input[type="text"],input[type="number"],input[type="email"],input[type="url"],input[type="search"],input[type="tel"],input[type="color"],.uneditable-input{
+ display:inline-block;
+ height:18px;
+ padding:0px 0px 0px 7px;
+ margin-bottom:10px;
+ font-size: 11px;
+ line-height: 1.5;
+ color:#555;
+ vertical-align:middle;
+ -webkit-border-radius:4px;
+ -moz-border-radius:4px;
+ border-radius:4px
+ }
+
+input,textarea,.uneditable-input{
+ width: auto;
+ }
+
diff --git a/inst/shiny/radialplot/server.R b/inst/shiny/radialplot/server.R
new file mode 100644
index 0000000..be7ba7e
--- /dev/null
+++ b/inst/shiny/radialplot/server.R
@@ -0,0 +1,540 @@
+## Server.R
+library(Luminescence)
+library(shiny)
+
+# load example data
+data(ExampleData.DeValues)
+data <- ExampleData.DeValues$CA1
+
+## MAIN FUNCTION
+shinyServer(function(input, output, session) {
+
+ # check and read in file (DATA SET 1)
+ datGet<- reactive({
+ inFile<- input$file1
+ if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL
+ return(read.table(file = inFile$datapath, # inFile[1] contains filepath
+ sep = input$sep,
+ quote = "",
+ header = input$headers)) # else return file
+ })
+
+ # check and read in file (DATA SET 2)
+ datGet2<- reactive({
+ inFile2<- input$file2
+ if(is.null(inFile2)) return(NULL) # if no file was uploaded return NULL
+ return(read.table(file = inFile2$datapath, # inFile[1] contains filepath
+ sep = input$sep,
+ quote = "",
+ header = input$headers)) # else return file
+ })
+
+
+ # dynamically inject sliderInput for central value
+ output$centValue<- renderUI({
+
+ # check if file is loaded
+ # # case 1: yes -> slinderInput with custom values
+ if(!is.null(datGet())) {
+ if(!is.null(datGet2())) {
+ centValue.data<- rbind(datGet(),datGet2())
+ sliderInput(inputId = "centValue",
+ label = "Central Value",
+ min = min(centValue.data[,1])*0.9,
+ max = max(centValue.data[,1])*1.1,
+ value = mean(centValue.data[,1]))
+ } else {
+ data<- datGet()
+ sliderInput(inputId = "centValue",
+ label = "Central Value",
+ min = min(data[,1])*0.9,
+ max = max(data[,1])*1.1,
+ value = mean(data[,1]))
+ }
+
+ }
+ else { #case 2: no -> sliderInput for example data
+ sliderInput(inputId = "centValue",
+ label = "Central Value",
+ min = min(data[,1])*0.9,
+ max = max(data[,1])*1.1,
+ value = mean(data[,1]),
+ step = 1, round = 0)
+ }
+ })## EndOf::renderUI()
+
+
+ # dynamically inject sliderInput for z-axis range
+ output$xlim<- renderUI({
+
+ # check if file is loaded
+ # # case 1: yes -> slinderInput with custom values
+ if(!is.null(datGet())) {
+ if(!is.null(datGet2())) {
+
+ xlim.data<- rbind(datGet(),datGet2())
+
+ if(input$logz == TRUE) {
+ sd<- xlim.data[,2] / xlim.data[,1]
+ } else {
+ sd<- xlim.data[,2]
+ }
+ prec<- 1/sd
+
+ sliderInput(inputId = "xlim",
+ label = "Range x-axis",
+ min = 0,
+ max = max(prec)*2,
+ value = c(0, max(prec)*1.05), round=FALSE, step=0.0001)
+ } else {
+ data<- datGet()
+
+ if(input$logz == TRUE) {
+ sd<- data[,2] / data[,1]
+ } else {
+ sd<- data[,2]
+ }
+ prec<- 1/sd
+
+ sliderInput(inputId = "xlim",
+ label = "Range x-axis",
+ min = 0,
+ max = max(prec)*2,
+ value = c(0, max(prec)*1.05), round=FALSE, step=0.0001)
+ }
+ }
+ else { #case 2: no -> sliderInput for example data
+ if(input$logz == TRUE) {
+ sd<- data[,2] / data[,1]
+ } else {
+ sd<- data[,2]
+
+ }
+ prec<- 1/sd
+
+ sliderInput(inputId = "xlim",
+ label = "Range x-axis",
+ min = 0,
+ max = max(prec)*2,
+ value = c(0, max(prec)*1.05), round=FALSE, step=0.0001)
+ }
+ })## EndOf::renderUI()
+
+
+ # dynamically inject sliderInput for z-axis range
+ output$zlim<- renderUI({
+
+ # check if file is loaded
+ # # case 1: yes -> slinderInput with custom values
+ if(!is.null(datGet())) {
+ if(!is.null(datGet2())) {
+ zlim.data<- rbind(datGet(),datGet2())
+ sliderInput(inputId = "zlim",
+ label = "Range z-axis",
+ min = min(zlim.data[,1])*0.25,
+ max = max(zlim.data[,1])*1.75,
+ value = c(min(zlim.data[,1])*0.8, max(zlim.data[,1])*1.2))
+ } else {
+ data<- datGet()
+ sliderInput(inputId = "zlim",
+ label = "Range z-axis",
+ min = min(data[,1])*0.25,
+ max = max(data[,1])*1.75,
+ value = c(min(data[,1])*0.8, max(data[,1])*1.2))
+ }
+ }
+ else { #case 2: no -> sliderInput for example data
+ sliderInput(inputId = "zlim",
+ label = "Range z-axis",
+ min = min(data[,1])*0.25,
+ max = max(data[,1])*1.75,
+ value = c(min(data[,1])*0.8, max(data[,1]))*1.2,
+ step = 1, round = 0)
+ }
+ })## EndOf::renderUI()
+
+ # render Radial Plot
+ output$main_plot <- renderPlot({
+
+ # refresh plot on button press
+ input$refresh
+
+ # progress bar
+ progress<- Progress$new(session, min = 0, max = 5)
+ progress$set(message = "Calculation in progress",
+ detail = "Retrieve data")
+ on.exit(progress$close())
+
+ # make sure that input panels are registered on non-active tabs.
+ # by default tabs are suspended and input variables are hence
+ # not available
+ outputOptions(x = output, name = "zlim", suspendWhenHidden = FALSE)
+ outputOptions(x = output, name = "centValue", suspendWhenHidden = FALSE)
+ outputOptions(x = output, name = "xlim", suspendWhenHidden = FALSE)
+
+ # check if file is loaded and overwrite example data
+ if(!is.null(datGet())) {
+ data<- datGet()
+ }
+ if(!is.null(datGet2())) {
+ data2<- datGet2()
+ }
+
+ if(is.null(datGet()) == FALSE && is.null(datGet2()) == FALSE) {
+ data<- datGet()
+ data2<- datGet2()
+ data<- list(data, data2)
+ }
+
+ progress$set(value = 1)
+ progress$set(message = "Calculation in progress",
+ detail = "Get values")
+
+ # check if any summary stats are activated, else NA
+ if (input$summary) {
+ summary<- input$stats
+ } else {
+ summary<- NA
+ }
+
+ # if custom datapoint color get RGB code from separate input panel
+ if(input$color == "custom") {
+ color<- input$rgb
+ } else {
+ color<- input$color
+ }
+
+ if(!is.null(datGet2())) {
+ # if custom datapoint color get RGB code from separate input panel
+ if(input$color2 == "custom") {
+ color2<- input$rgb2
+ } else {
+ color2<- input$color2
+ }
+ } else {
+ color2<- adjustcolor("white", alpha.f = 0)
+ }
+
+ # if custom datapoint style get char from separate input panel
+ if(input$pch == "custom") {
+ pch<- input$custompch
+ } else {
+ pch<- as.integer(input$pch)-1 #-1 offset in pch values
+ }
+
+ # if custom datapoint style get char from separate input panel
+ if(input$pch2 == "custom") {
+ pch2<- input$custompch2
+ } else {
+ pch2<- as.integer(input$pch2)-1 #-1 offset in pch values
+ }
+
+ # workaround to initialize plotting after app startup
+ if(is.null(input$centValue)) {
+ centValue<- 3000
+ } else {
+ centValue<- input$centValue
+ }
+
+ # update progress bar
+ progress$set(value = 2)
+ progress$set(message = "Calculation in progress",
+ detail = "Combine values")
+
+ # create numeric vector of lines
+ line<- as.numeric(c(input$line1, input$line2,
+ input$line3, input$line4,
+ input$line5, input$line6,
+ input$line7, input$line8))
+
+ # create char vector of line colors
+ line.col<- c(input$colline1, input$colline2,
+ input$colline3, input$colline4,
+ input$colline5, input$colline6,
+ input$colline7, input$colline8)
+
+ # create char vector of line labels
+ line.label<- c(input$labline1, input$labline2,
+ input$labline3, input$labline4,
+ input$labline5, input$labline6,
+ input$labline7, input$labline8)
+
+
+ # update progress bar
+ progress$set(value = 3)
+ progress$set(message = "Calculation in progress",
+ detail = "Get values")
+
+ # if custom bar color get RGB from separate input panel or "none"
+ if(input$bar == "custom") {
+ bar.col<- adjustcolor(col = input$rgbBar,
+ alpha.f = input$alpha.bar/100)
+ } else {
+ if(input$bar == "none") {
+ bar.col<- input$bar
+ } else {
+ bar.col<- adjustcolor(col = input$bar,
+ alpha.f = input$alpha.bar/100)
+ }
+ }
+
+ # if custom bar color get RGB from separate input panel or "none"
+ # SECONDARY DATA SET
+ if(input$bar2 == "custom") {
+ bar.col2<- adjustcolor(col = input$rgbBar2,
+ alpha.f = input$alpha.bar/100)
+ } else {
+ if(input$bar2 == "none") {
+ bar.col2<- input$bar
+ } else {
+ bar.col2<- adjustcolor(col = input$bar2,
+ alpha.f = input$alpha.bar/100)
+ }
+ }
+
+ # if custom grid color get RGB from separate input panel or "none"
+ if(input$grid == "custom") {
+ grid.col<- adjustcolor(col = input$rgbGrid,
+ alpha.f = input$alpha.grid/100)
+ } else {
+ if(input$grid == "none") {
+ grid.col<- input$grid
+ } else {
+ grid.col<- adjustcolor(col = input$grid,
+ alpha.f = input$alpha.grid/100)
+ }
+ }
+
+ # update progress bar
+ progress$set(value = 4)
+ progress$set(message = "Calculation in progress",
+ detail = "Almost there...")
+
+ # workaround: if no legend wanted set label to NA and hide
+ # symbol on coordinates -999, -999
+ if(input$showlegend == FALSE) {
+ legend<- c(NA,NA)
+ legend.pos<- c(-999,-999)
+ } else {
+ if(!is.null(datGet2()))
+ {
+ legend<- c(input$legendname, input$legendname2)
+ legend.pos<- input$legend.pos
+ } else {
+ legend<- c(input$legendname, "")
+ legend.pos<- input$legend.pos
+ }
+
+ }
+
+ # validate(need()) makes sure that all data are available to
+ # renderUI({}) before plotting and will wait until there
+ validate(
+ need(expr = input$centValue, message = 'Waiting for data... Please wait!'),
+ need(expr = input$zlim, message = 'Waiting for data... Please wait!')
+ )
+
+ progress$set(value = 5)
+ progress$set(message = "Calculation in progress",
+ detail = "Ready to plot")
+
+ # plot radial Plot
+ args <- list(data = data,
+ xlim = input$xlim,
+ zlim = input$zlim,
+ xlab = c(input$xlab1, input$xlab2),
+ ylab = input$ylab,
+ zlab = input$zlab,
+ y.ticks = input$yticks,
+ grid.col = grid.col,
+ bar.col = c(bar.col, bar.col2),
+ pch = c(pch,pch2),
+ col = c(color,color2),
+ line = line,
+ line.col = line.col,
+ line.label = line.label,
+ main = input$main,
+ cex = input$cex,
+ mtext = input$mtext,
+ log.z = input$logz,
+ stats = input$statlabels,
+ plot.ratio = input$curvature,
+ summary = summary,
+ summary.pos = input$sumpos,
+ legend = legend,
+ legend.pos = legend.pos,
+ na.rm = input$naExclude,
+ central.value = input$centValue,
+ centrality = input$centrality,
+ lwd = c(input$lwd, input$lwd2),
+ lty = c(as.integer(input$lty), as.integer(input$lty2)))
+
+
+ do.call(plot_RadialPlot, args = args)
+
+ # prepare code as text output
+ if (is.null(input$sep))
+ updateRadioButtons(session, "fileformat", selected = "\t")
+
+ if(input$sep == "\t")
+ verb.sep<- "\\t"
+ else
+ verb.sep<- input$sep
+
+ str1 <- paste("data <- read.delim(file, header = ",input$headers, ", sep= '", verb.sep,"')",
+ sep = "")
+
+ if(!is.null(datGet2())) {
+ str2 <- "file2<- file.choose()"
+ str3 <- paste("data2 <- read.delim(file2, header = ",input$headers, ", sep= '", verb.sep,"')",
+ sep= "")
+ str4 <- "data<- list(data, data2)"
+ str1 <- paste(str1, str2, str3, str4, sep = "\n")
+ }
+
+ header <- paste("# To reproduce the plot in your local R environment",
+ "# copy and run the following code to your R console.",
+ "library(Luminescence)",
+ "file<- file.choose()",
+ str1,
+ "\n",
+ sep = "\n")
+
+ names <- names(args)
+
+ verb.arg <- paste(mapply(function(name, arg) {
+ if (all(inherits(arg, "character")))
+ arg <- paste0("'", arg, "'")
+ if (length(arg) > 1)
+ arg <- paste0("c(", paste(arg, collapse = ", "), ")")
+ if (is.null(arg))
+ arg <- "NULL"
+ paste(name, "=", arg)
+ }, names[-1], args[-1]), collapse = ",\n")
+
+ funCall <- paste0("plot_RadialPlot(data = data,\n", verb.arg, ")")
+
+ code.output <- paste0(header, funCall, collapse = "\n")
+
+ # nested renderText({}) for code output on "R plot code" tab
+ output$plotCode<- renderText({
+
+ code.output
+
+ })##EndOf::renderText({})
+
+
+ output$exportScript <- downloadHandler(
+ filename = function() { paste(input$filename, ".", "R", sep="") },
+ content = function(file) {
+ write(code.output, file)
+ },#EO content =,
+ contentType = "text"
+ )#EndOf::dowmloadHandler()
+
+
+ # nested downloadHandler() to print plot to file
+ output$exportFile <- downloadHandler(
+ filename = function() { paste(input$filename, ".", input$fileformat, sep="") },
+ content = function(file) {
+
+ # determine desired fileformat and set arguments
+ if(input$fileformat == "pdf") {
+ pdf(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ paper = "special",
+ useDingbats = FALSE,
+ family = input$fontfamily)
+ }
+ if(input$fileformat == "svg") {
+ svg(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ family = input$fontfamily)
+ }
+ if(input$fileformat == "eps") {
+ postscript(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ paper = "special",
+ family = input$fontfamily)
+ }
+
+ # plot radial Plot
+ do.call(plot_RadialPlot, args = args)
+
+ dev.off()
+ },#EO content =,
+ contentType = "image"
+ )#EndOf::dowmloadHandler()
+ })##EndOf::renderPlot({})
+
+ # renderTable() that prints the data to the second tab
+ output$dataset<- renderDataTable(
+ options = list(pageLength = 10, autoWidth = FALSE),
+ callback = "function(table) {
+ table.on('click.dt', 'tr', function() {
+ $(this).toggleClass('selected');
+ Shiny.onInputChange('rows',
+ table.rows('.selected').data().toArray());
+ });
+}",
+{
+ if(!is.null(datGet())) {
+ data<- datGet()
+ colnames(data)<- c("De","De error")
+ data
+ } else {
+ colnames(data)<- c("De","De error")
+ data
+ }
+ })##EndOf::renterTable()
+
+# renderTable() that prints the secondary data to the second tab
+output$dataset2<- renderDataTable(
+ options = list(pageLength = 10, autoWidth = FALSE),
+ callback = "function(table) {
+ table.on('click.dt', 'tr', function() {
+ $(this).toggleClass('selected');
+ Shiny.onInputChange('rows',
+ table.rows('.selected').data().toArray());
+ });
+ }",
+{
+ if(!is.null(datGet2())) {
+ data<- datGet2()
+ colnames(data)<- c("De","De error")
+ data
+ } else {
+ }
+ })##EndOf::renterTable()
+
+
+ # renderTable() to print the results of the
+ # central age model (CAM)
+ output$CAM<- renderDataTable(
+ options = list(pageLength = 10, autoWidth = FALSE),
+{
+ if(!is.null(datGet())) {
+ if(!is.null(datGet2())) {
+ data<- list(datGet(), datGet2())
+ } else {
+ data<- list(datGet())
+ }
+ } else {
+ data<- list(data)
+ }
+ t<- as.data.frame(matrix(nrow = length(data), ncol = 7))
+ colnames(t)<- c("Data set","n", "log data", "Central dose", "SE abs.", "OD (%)", "OD error (%)")
+ res<- lapply(data, function(x) { calc_CentralDose(x, verbose = FALSE, plot = FALSE) })
+ for(i in 1:length(res)) {
+ t[i,1]<- ifelse(i==1,"pimary","secondary")
+ t[i,2]<- length(res[[i]]@data$data[,1])
+ t[i,3]<- res[[i]]@data$args$log
+ t[i,4:7]<- round(res[[i]]@data$summary[1:4],2)
+ }
+ t
+})##EndOf::renterTable()
+
+})##EndOf::shinyServer(function(input, output)
\ No newline at end of file
diff --git a/inst/shiny/radialplot/ui.R b/inst/shiny/radialplot/ui.R
new file mode 100644
index 0000000..cb005f0
--- /dev/null
+++ b/inst/shiny/radialplot/ui.R
@@ -0,0 +1,606 @@
+library(RLumShiny)
+## UI.R
+
+# load example data
+data(ExampleData.DeValues)
+
+# pageWithSidebar contains three panels:
+# 1 - headerPanel: basically just for a header
+# 2 - sidebarPanel: data input
+# 3 - mainPanel: data output
+pageWithSidebar(
+ # 1 - title = NULL -> Panel will not be shown
+ headerPanel(title = NULL),
+ # 2- width = 5 -> refers to twitters bootstrap grid system
+ # where the the maximum width is 12 that is to be shared between all
+ # elements
+ sidebarPanel(width = 5,
+ # include a tabs in the input panel for easier navigation
+ tabsetPanel(id = "tabs", type = "pill", selected = "Data",
+ # Tab 1: Data input
+ tabPanel("Data",
+ # informational text
+ div(align = "center", h5("Data upload")),
+ # file upload button (data set 1)
+ fileInput(inputId = "file1",
+ label = strong("Primary data set"),
+ accept="text/plain"),
+ tooltip(refId = "file1", text = tags$img(src='file_structure.png', width='250px')),
+ # file upload button (data set 2)
+ fileInput(inputId = "file2",
+ label = strong("Secondary data set"),
+ accept="text/plain"),
+ tooltip(refId = "file2", text = tags$img(src='file_structure.png', width='250px')),
+ # informational text
+ div(align = "center", h5("Settings")),
+ fluidRow(
+ column(width = 6,
+ # logical: should NA values be excluded?
+ checkboxInput(inputId = "naExclude",
+ label = "Exclude NA values",
+ value = TRUE),
+ tooltip(refId = "naExclude", text = "Exclude NA values from the data set prior to any further operations.")
+ ),
+ column(width = 6,
+ # logical: file contains headers?
+ checkboxInput(inputId = "headers",
+ label = "File contains headers",
+ value = FALSE),
+ tooltip(refId = "headers", text = tags$img(src='file_containsHeader.png', width='250px'))
+ )),
+ # char: columns separated by tab, space, comma
+ radioButtons("sep", "Separator", selected = "\t", inline = TRUE,
+ c("Tab" = "\t",
+ "Space" = " ",
+ "Comma" = ",",
+ "Semicolon" = ";")),
+ tooltip(refId = "sep", text = tags$img(src='file_sep.png', width='400px'), placement = "auto left"),
+ hr(),
+ actionButton(inputId = "refresh", label = "Refresh", icon = icon("refresh")),
+ tooltip(refId = "refresh", text = "Redraw the plot")
+ ),##EndOf::Tab_1
+
+ # Tab 2: Statistical information
+ tabPanel("Statistics",
+ div(align = "center", h5("Summary")),
+ fluidRow(
+ column(width = 6,
+ checkboxInput(inputId = "summary",
+ label = "Show summary",
+ value = FALSE),
+ tooltip(refId = "summary", text = "Adds numerical output to the plot")
+ ),
+ column(width = 6,
+ selectInput(inputId = "sumpos",
+ label = "Summary position",
+ selected = "topleft",
+ choices = list("Subtitle" = "sub",
+ "Center" = "center",
+ Top=c("Top" = "top",
+ "Top left" = "topleft",
+ "Top right"= "topright"),
+ Bottom=c("Bottom" = "bottom",
+ "Bottom left" = "bottomleft",
+ "Bottom right" = "bottomright")
+ )),
+ tooltip(refId = "sumpos", attr = "for", text = "Position of the statistical summary. The keyword \"Subtitle\" will only work if no plot subtitle is used.")
+ )
+ ),
+ checkboxGroupInput(inputId = "stats",
+ label = "Parameters",
+ selected = c("n","mean"),
+ choices = c("n" = "n",
+ "Mean" = "mean",
+ "weighted Mean" = "mean.weighted",
+ "Median" = "median",
+ "weighted Median" = "median.weighted",
+ "rel. Standard deviation" = "sdrel",
+ "abs. Standard deviation" = "sdabs",
+ "rel. Standard error" = "serel",
+ "abs. Standard error" = "seabs",
+ #"25 % Quartile" = "q25", #not implemented yet
+ #"75 % Quartile" = "q75", #not implemented yet
+ "KDEmax" = "kdemax",
+ "Skewness" = "skewness",
+ "Kurtosis" = "kurtosis"
+ )),
+ tooltip(refId = "stats", text = "Statistical parameters to be shown in the summary"),
+ br(),
+ div(align = "center", h5("Datapoint labels")),
+ div(align = "center", checkboxGroupInput(inputId = "statlabels", inline = TRUE,
+ label = NULL,
+ choices = c("Min" = "min",
+ "Max" = "max",
+ "Median" = "median"))),
+ tooltip(refId = "statlabels", text = "Additional labels of statistically important values in the plot.")
+ ),##EndOf::Tab_2
+
+ # Tab 3: input that refer to the plot rather than the data
+ tabPanel("Plot",
+ div(align = "center", h5("Title")),
+ fluidRow(
+ column(width = 6,
+ textInput(inputId = "main",
+ label = "Title",
+ value = "Radial Plot")
+ ),
+ column(width = 6,
+ textInput(inputId = "mtext",
+ label = "Subtitle",
+ value = "")
+ )
+ ),
+ div(align = "center", h5("Scaling")),
+ fluidRow(
+ column(width = 6,
+ # inject sliderInput from Server.R
+ uiOutput(outputId = "centValue"),
+ tooltip(refId = "centValue", text = "User-defined central value, primarily used for horizontal centering of the z-axis")
+ ),
+ column(width = 6,
+ sliderInput(inputId = "cex",
+ label = "Scaling factor",
+ min = 0.5, max = 2,
+ value = 1.0, step = 0.1)
+ )
+ ),
+ selectInput(inputId = "centrality",
+ label = "Centrality",
+ list("Mean" = "mean",
+ "Median" = "median",
+ "Weighted mean" = "mean.weighted",
+ "Weighted median" = "median.weighted")),
+ tooltip(refId = "centrality", attr = "for", text = "Measure of centrality, used for the standardisation, centering the plot and drawing the central line.")
+ ),##EndOf::Tab_3
+
+ # Tab 4: modify axis parameters
+ tabPanel("Axis",
+ div(align = "center", h5("X-axis")),
+ fluidRow(
+ column(width = 6,
+ textInput(inputId = "xlab1",
+ label = "Label x-axis (upper)",
+ value = "Relative error [%]")
+ ),
+ column(width = 6,
+ textInput(inputId = "xlab2",
+ label = "Label x-axis (lower)",
+ value = "Precision")
+ )
+ ),
+ # inject sliderInput from Server.R
+ uiOutput(outputId = "xlim"),
+ div(align = "center", h5("Y-axis")),
+ checkboxInput(inputId = "yticks",
+ label = HTML("Show ±2σ label"),
+ value = TRUE),
+ tooltip(refId = "yticks", text = "Option to hide y-axis labels."),
+ textInput(inputId = "ylab",
+ label = "Label y-axis",
+ value = "Standardised estimate"),
+ div(align = "center", h5("Z-axis")),
+ checkboxInput(inputId = "logz",
+ label = "Logarithmic z-axis",
+ value = TRUE),
+ tooltip(refId = "logz", text = "Option to display the z-axis in logarithmic scale."),
+ textInput(inputId = "zlab",
+ label = "Label z-axis",
+ value = "Equivalent dose [Gy]"),
+ # inject sliderInput from Server.R
+ uiOutput(outputId = "zlim"),
+ sliderInput('curvature', 'Z-axis curvature',
+ min=0, max=3,
+ value=4.5/5.5, step=0.01, round=FALSE),
+ tooltip(refId = "curvature", attr = "for", text = "User-defined plot area ratio (i.e. curvature of the z-axis). If omitted, the default value (4.5/5.5) is used and modified automatically to optimise the z-axis curvature. The parameter should be decreased when data points are plotted outside the z-axis or when the z-axis gets too elliptic.")
+ ),##EndOf::Tab_4
+
+ # Tab 5: modify data point representation
+ tabPanel("Datapoints",
+ div(align = "center", h5("Primary data set")),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "pch",
+ label = "Style",
+ selected = "17",
+ choices = c("Square"= "1",
+ "Circle"="2",
+ "Triangle point up"="3",
+ "Plus"="4",
+ "Cross"="5",
+ "Diamond"="6",
+ "Triangle point down"="7",
+ "Square cross"="8",
+ "Star"="9",
+ "Diamond plus"="10",
+ "Circle plus"="11",
+ "Triangles up and down"="12",
+ "Square plus"="13",
+ "Circle cross"="14",
+ "Square and Triangle down"="15",
+ "filled Square"="16",
+ "filled Circle"="17",
+ "filled Triangle point up"="18",
+ "filled Diamond"="19",
+ "solid Circle"="20",
+ "Bullet (smaller Circle)"="21",
+ "Custom"="custom"))
+ ),
+ column(width = 6,
+ # show only if custom symbol is desired
+ conditionalPanel(condition = "input.pch == 'custom'",
+ textInput(inputId = "custompch",
+ label = "Insert character",
+ value = "?"))
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "color", label = "Datapoint color",
+ choices = list("Black" = "black",
+ "Grey" = "grey50",
+ "Red" = "#b22222",
+ "Green" = "#6E8B3D",
+ "Blue" = "#428bca",
+ "Custom" = "custom"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.color == 'custom'",
+ jscolorInput(inputId = "rgb",
+ label = "Choose a color"))
+ )
+ ),
+ div(align = "center", h5("Secondary data set")),
+ fluidRow(
+ column(width = 6,
+ ## DATA SET 2
+ selectInput(inputId = "pch2",
+ label = "Style",
+ selected = "17",
+ choices = c("Square"= "1",
+ "Circle"="2",
+ "Triangle point up"="3",
+ "Plus"="4",
+ "Cross"="5",
+ "Diamond"="6",
+ "Triangle point down"="7",
+ "Square cross"="8",
+ "Star"="9",
+ "Diamond plus"="10",
+ "Circle plus"="11",
+ "Triangles up and down"="12",
+ "Square plus"="13",
+ "Circle cross"="14",
+ "Square and Triangle down"="15",
+ "filled Square"="16",
+ "filled Circle"="17",
+ "filled Triangle point up"="18",
+ "filled Diamond"="19",
+ "solid Circle"="20",
+ "Bullet (smaller Circle)"="21",
+ "Custom"="custom"))
+ ),
+ column(width = 6,
+ # show only if custom symbol is desired
+ conditionalPanel(condition = "input.pch2 == 'custom'",
+ textInput(inputId = "custompch2",
+ label = "Insert character",
+ value = "?"))
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "color2", label = "Datapoint color",
+ selected = "#b22222",
+ choices = list("Black" = "black",
+ "Grey" = "grey50",
+ "Red" = "#b22222",
+ "Green" = "#6E8B3D",
+ "Blue" = "#428bca",
+ "Custom" = "custom"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.color2 == 'custom'",
+ jscolorInput(inputId = "rgb2",
+ label = "Choose a color"))
+ )
+ )
+ ),##EndOf::Tab_5
+
+ # Tab 6: add additional lines to the plot
+ tabPanel("Lines",
+ helpText("Here you can add additional lines."),
+ # options for custom lines:
+ # 1 - z-value, 2 - color, 3 - label
+ # only the options for the first line are shown
+ numericInput(inputId = "line1",
+ label = strong("Line #1"),
+ value = NA, min = 0),
+ tooltip(refId = "line1", text = "Numeric values of the additional lines to be added."),
+ fluidRow(
+ column(width = 6,
+ HTML("Choose a color<br>"),
+ jscolorInput(inputId = "colline1")
+ ),
+ column(width = 6,
+ textInput(inputId = "labline1",
+ label = "Label",
+ value = "")
+ )
+ ),
+ # conditional chain: if valid input (i.e. the z-value is > 0) is provided
+ # for the previous line, show options for a new line (currently up to eight)
+ conditionalPanel(condition = "input.line1 > 0",
+ numericInput(inputId = "line2", strong("Line #2"), NA, min = 0),
+ fluidRow(
+ column(width = 6, HTML("Choose a color<br>"),jscolorInput(inputId = "colline2")),
+ column(width = 6, textInput("labline2","Label",value = ""))
+ )
+ ),
+ conditionalPanel(condition = "input.line2 > 0",
+ numericInput(inputId = "line3", strong("Line #3"), NA, min = 0),
+ fluidRow(
+ column(width = 6, HTML("Choose a color<br>"),jscolorInput(inputId = "colline3")),
+ column(width = 6, textInput("labline3","Label",value = ""))
+ )
+ ),
+
+ conditionalPanel(condition = "input.line3 > 0",
+ numericInput(inputId = "line4", strong("Line #4"), NA, min = 0),
+ fluidRow(
+ column(width = 6, HTML("Choose a color<br>"),jscolorInput(inputId = "colline4")),
+ column(width = 6, textInput("labline4","Label",value = ""))
+ )
+ ),
+
+ conditionalPanel(condition = "input.line4 > 0",
+ numericInput(inputId = "line5", strong("Line #5"), NA, min = 0),
+ fluidRow(
+ column(width = 6, HTML("Choose a color<br>"),jscolorInput(inputId = "colline5")),
+ column(width = 6, textInput("labline5","Label",value = ""))
+ )
+ ),
+
+ conditionalPanel(condition = "input.line5 > 0",
+ numericInput(inputId = "line6", strong("Line #6"), NA, min = 0),
+ fluidRow(
+ column(width = 6, HTML("Choose a color<br>"),jscolorInput(inputId = "colline6")),
+ column(width = 6, textInput("labline6","Label",value = ""))
+ )
+ ),
+
+ conditionalPanel(condition = "input.line6 > 0",
+ numericInput(inputId = "line7", strong("Line #7"), NA, min = 0),
+ fluidRow(
+ column(width = 6, HTML("Choose a color<br>"),jscolorInput(inputId = "colline7")),
+ column(width = 6, textInput("labline7","Label",value = ""))
+ )
+ ),
+
+ conditionalPanel(condition = "input.line7 > 0",
+ numericInput(inputId = "line8", strong("Line #8"), NA, min = 0),
+ fluidRow(
+ column(width = 6, HTML("Choose a color<br>"),jscolorInput(inputId = "colline8")),
+ column(width = 6, textInput("labline8","Label",value = ""))
+ )
+ )
+
+ ),##EndOf::Tab_6
+
+ # Tab 7: modify the 2-sigma bar (radial plot), grid (both) and polygon (KDE)
+ tabPanel("Bars & Grid",
+ div(align = "center", h5("Central line")),
+ fluidRow(
+ column(width = 6,
+ numericInput(inputId = "lwd",
+ label = "Central line width #1",
+ min = 0, max = 5,
+ value = 1)
+ ),
+ column(width = 6,
+ numericInput(inputId = "lwd2",
+ label = "Central line width #2",
+ min = 0, max = 5,
+ value = 1)
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "lty",
+ label = "Line type",
+ selected = 2,
+ choices = list("Blank" = 0,
+ "Solid" = 1,
+ "Dashed" = 2,
+ "Dotted" = 3,
+ "Dot dash" = 4,
+ "Long dash" = 5,
+ "Two dash" = 6))
+ ),
+ column(width = 6,
+ selectInput(inputId = "lty2",
+ label = "Line type",
+ selected = 2,
+ choices = list("Blank" = 0,
+ "Solid" = 1,
+ "Dashed" = 2,
+ "Dotted" = 3,
+ "Dot dash" = 4,
+ "Long dash" = 5,
+ "Two dash" = 6))
+
+ )
+ ),
+ div(align = "center", HTML("<h5>2σ bar</h5>")),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "bar", label = HTML("2σ bar color"),
+ choices = list("Grey" = "grey50",
+ "Custom" = "custom",
+ "None" = "none"))
+ ),
+ column(width = 6,
+ selectInput(inputId = "bar2", label = HTML("2σ bar color #2"),
+ choices = list("Grey" = "grey50",
+ "Custom" = "custom",
+ "None" = "none"))
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.bar == 'custom'",
+ jscolorInput(inputId = "rgbBar",
+ label = "Choose a color"))
+ ),
+ column(width = 6,
+
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.bar2 == 'custom'",
+ jscolorInput(inputId = "rgbBar2",
+ label = "Choose a color"))
+ )
+ ),
+ sliderInput(inputId = "alpha.bar",
+ label = "Transparency",
+ min = 0, max = 100,
+ step = 1, value = 66),
+ div(align = "center", h5("Grid")),
+ fluidRow(
+ column(width = 6,
+ selectInput("grid", "Grid color",
+ list("Grey" = "grey",
+ "Custom" = "custom",
+ "None" = "none")),
+ tooltip(refId = "grid", attr = "for", text = "colour of the grid lines (originating at [0,0] and stretching to the z-scale). To disable grid lines, use \"none\".")
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.grid == 'custom'",
+ jscolorInput(inputId = "rgbGrid",
+ label = "Choose a color"))
+ )
+ ),
+ sliderInput(inputId = "alpha.grid",
+ label = "Transparency",
+ min = 0, max = 100,
+ step = 1, value = 100)
+ ),##EndOf::Tab_7
+
+ tabPanel("Legend",
+ div(align = "center", h5("Legend")),
+ fluidRow(
+ column(width = 6,
+ checkboxInput(inputId = "showlegend",
+ label = "Show legend",
+ value = FALSE),
+ tooltip(refId = "showlegend", text = "Legend content to be added to the plot.")
+ ),
+ column(width = 6,
+ selectInput(inputId = "legend.pos",
+ label = "Legend position",
+ selected = "bottomleft",
+ choices = c("Top" = "top",
+ "Top left" = "topleft",
+ "Top right"= "topright",
+ "Center" = "center",
+ "Bottom" = "bottom",
+ "Bottom left" = "bottomleft",
+ "Bottom right" = "bottomright"))
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ textInput(inputId = "legendname",
+ label = "Primary data label",
+ value = "primary data")
+ ),
+ column(width = 6,
+ textInput(inputId = "legendname2",
+ label = "Secondary data label",
+ value = "secondary data")
+ )
+ )
+ ),##EndOf::Tab_8
+
+ # Tab 9: save plot as pdf, wmf or eps
+ tabPanel("Export",
+ radioButtons(inputId = "fileformat",
+ label = "Fileformat",
+ selected = "pdf",
+ choices = c("PDF (Portable Document Format)" = "pdf",
+ "SVG (Scalable Vector Graphics)" = "svg",
+ "EPS (Encapsulated Postscript)" = "eps")),
+ textInput(inputId = "filename",
+ label = "Filename",
+ value = "Radial Plot"),
+ fluidRow(
+ column(width = 6,
+ numericInput(inputId = "imgheight",
+ label = "Image height",
+ value = 7)
+ ),
+ column(width = 6,
+ numericInput(inputId = "imgwidth",
+ label = "Image width",
+ value = 7)
+ )
+ ),
+ selectInput(inputId = "fontfamily",
+ label = "Font",
+ selected = "Helvetica",
+ choices = c("Helvetica" = "Helvetica",
+ "Helvetica Narrow" = "Helvetica Narrow",
+ "Times" = "Times",
+ "Courier" = "Courier",
+ "Bookman" = "Bookman",
+ "Palatino" = "Palatino")),
+ tags$hr(),
+ downloadButton(outputId = "exportFile",
+ label = "Download plot"),
+ tags$hr(),
+ helpText("Additionally, you can download a corresponding .R file that contains",
+ "a fully functional script to reproduce the plot in your R environment!"),
+ downloadButton(outputId = "exportScript",
+ label = "Download R script")
+ ),##EndOf::Tab_8
+
+ # Tab 10: further information
+ tabPanel("About",
+ hr(),
+ div(align = "center",
+ # HTML code to include a .png file in the tab; the image file must be in
+ # a subfolder called "wwww"
+ img(src="RL_Logo.png", height = 100, width = 100, alt = "R.Lum"),
+ p("Links:"),
+ a(href = "http://www.r-luminescence.de", "R.Luminescence project page", target="_blank"),
+ br(),
+ a(href = "https://forum.r-luminescence.de", "Message board", target="_blank"),
+ br(),
+ a(href = "http://zerk.canopus.uberspace.de/R.Lum", "Online application", target="_blank"),
+ br(),hr(),
+ img(src='GitHub-Mark-32px.png', width='32px', height='32px'),
+ br(),
+ a(href = "https://github.com/tzerk/RLumShiny/tree/master/inst/shiny/radialplot", "See the code at GitHub!", target="_blank")
+ )#/div
+ )##EndOf::Tab_9
+ )##EndOf::tabsetPanel
+ ),##EndOf::sidebarPanel
+
+ # 3 - output panel
+ mainPanel(width = 7,
+ # insert css code inside <head></head> of the generated HTML file:
+ # allow open dropdown menus to reach over the container
+ tags$head(tags$style(type="text/css",".tab-content {overflow: visible;}")),
+ tags$head(includeCSS("www/style.css")),
+ # divide output in separate tabs via tabsetPanel
+ tabsetPanel(
+ tabPanel("Plot", plotOutput(outputId = "main_plot", height = "500px")),
+ tabPanel("Primary data set", dataTableOutput("dataset")),
+ tabPanel("Secondary data set", dataTableOutput("dataset2")),
+ tabPanel("Central Age Model", dataTableOutput("CAM")),
+ tabPanel("R plot code", verbatimTextOutput("plotCode"))
+ )###EndOf::tabsetPanel
+ )##EndOf::mainPanel
+)##EndOf::shinyUI(pageWithSidebar)
\ No newline at end of file
diff --git a/inst/shiny/radialplot/www/GitHub-Mark-32px.png b/inst/shiny/radialplot/www/GitHub-Mark-32px.png
new file mode 100644
index 0000000..8b25551
Binary files /dev/null and b/inst/shiny/radialplot/www/GitHub-Mark-32px.png differ
diff --git a/inst/shiny/radialplot/www/RL_Logo.png b/inst/shiny/radialplot/www/RL_Logo.png
new file mode 100644
index 0000000..ac0551b
Binary files /dev/null and b/inst/shiny/radialplot/www/RL_Logo.png differ
diff --git a/inst/shiny/radialplot/www/file_containsHeader.png b/inst/shiny/radialplot/www/file_containsHeader.png
new file mode 100644
index 0000000..7abe3d2
Binary files /dev/null and b/inst/shiny/radialplot/www/file_containsHeader.png differ
diff --git a/inst/shiny/radialplot/www/file_sep.png b/inst/shiny/radialplot/www/file_sep.png
new file mode 100644
index 0000000..0297e61
Binary files /dev/null and b/inst/shiny/radialplot/www/file_sep.png differ
diff --git a/inst/shiny/radialplot/www/file_structure.png b/inst/shiny/radialplot/www/file_structure.png
new file mode 100644
index 0000000..5e3b50a
Binary files /dev/null and b/inst/shiny/radialplot/www/file_structure.png differ
diff --git a/inst/shiny/radialplot/www/style.css b/inst/shiny/radialplot/www/style.css
new file mode 100644
index 0000000..295b46c
--- /dev/null
+++ b/inst/shiny/radialplot/www/style.css
@@ -0,0 +1,73 @@
+.custom-modal {
+ padding-left: 10px;
+ padding-top: 10px;
+ padding-bottom: 10px;
+ padding-right: 10px;
+ line-height: 200%;
+ background-color: #fff;
+ overflow: visible;
+ position: absolute;
+ z-index: 999;
+ border-radius: 10px;
+ border-style: solid;
+ border-color: #428bca;
+}
+
+.h {
+ font-size: 11px;
+ margin: 0 0 0px;
+}
+
+h5, h6 {
+ color: #428bca;
+ font-weight: 700;
+}
+
+.tooltip-inner {
+ max-width: 450px;
+}
+
+.control-label, .selectize-dropdown, .item, .btn, .uneditable-input, .sorting, .odd, .even, .dataTables-info, .fa, .fa-refresh {
+ font-size: 12px;
+}
+
+.selectize-input {
+ padding: 0px 10px;
+ min-height: 20px;
+}
+
+label, body, input {
+ font-size: 12px;
+ font-weight: 100 !important;
+}
+
+.label, .badge {
+ font-size: 12px;
+ padding: 4px 20px;
+ margin: 10px;
+ line-height: 18px;
+ font-weight: 100 !important;
+}
+
+.label-info, .badge-info {
+background-color: #428bca;
+}
+
+input[type="text"],input[type="number"],input[type="email"],input[type="url"],input[type="search"],input[type="tel"],input[type="color"],.uneditable-input{
+ display:inline-block;
+ height:18px;
+ padding:0px 0px 0px 7px;
+ margin-bottom:10px;
+ font-size: 11px;
+ line-height: 1.5;
+ color:#555;
+ vertical-align:middle;
+ -webkit-border-radius:4px;
+ -moz-border-radius:4px;
+ border-radius:4px
+ }
+
+input,textarea,.uneditable-input{
+ width: auto;
+ }
+
diff --git a/inst/shiny/transformCW/Server.R b/inst/shiny/transformCW/Server.R
new file mode 100644
index 0000000..81bed5a
--- /dev/null
+++ b/inst/shiny/transformCW/Server.R
@@ -0,0 +1,154 @@
+## Server.R
+library(Luminescence)
+library(RLumShiny)
+library(shiny)
+
+data("ExampleData.CW_OSL_Curve", envir = environment())
+data <- ExampleData.CW_OSL_Curve
+
+## MAIN FUNCTION
+shinyServer(function(input, output, session) {
+
+ # RECEIVE USER DATA ----
+ datGet<- reactive({
+ inFile<- input$file
+ if(is.null(inFile))
+ return(NULL)
+
+ t <- tryCatch(read.table(file = inFile$datapath,
+ sep = input$sep,
+ quote = "",
+ header = input$headers),
+ error = function(e) {
+ return(NULL)
+ })
+
+ if (is.null(t))
+ return(NULL)
+
+ if (ncol(t) == 1)
+ return(NULL)
+
+ return(t)
+ })
+
+ # TRANSFORM DATA
+ observe({
+ if (!is.null(datGet()))
+ data <- datGet()
+
+ P <- input$p
+ delta <- input$delta
+
+ # validate method parameters
+ if (is.na(input$delta)) {
+ updateNumericInput(session, "delta", value = 1)
+ delta <- 1
+ }
+ else if (input$delta < 1) {
+ updateNumericInput(session, "delta", value = 1)
+ delta <- 1
+ }
+
+ # validate method parameters
+ if (is.na(input$p)) {
+ updateNumericInput(session, "p", value = 1)
+ P <- 1
+ }
+ else if (input$p < 1) {
+ updateNumericInput(session, "p", value = 1)
+ P <- 1
+ }
+
+
+ args <- list(data)
+ if (input$method == "CW2pHMi")
+ if (delta >= 1)
+ args <- append(args, delta)
+ if (input$method == "CW2pLMi" || input$method == "CW2pPMi")
+ if (P >= 1)
+ args <- append(args, P)
+
+ tdata <<- do.call(input$method, args)
+ })
+
+ output$main_plot <- renderPlot({
+
+ # be reactive on method changes
+ datGet()
+ input$method
+ input$delta
+ input$p
+
+ pargs <- list(tdata[ ,1], tdata[ ,2],
+ log = paste0(ifelse(input$logx, "x", ""), ifelse(input$logy, "y", "")),
+ main = input$main,
+ xlab = input$xlab,
+ ylab = input$ylab,
+ cex = input$cex,
+ type = input$type,
+ pch = ifelse(input$pch != "custom", as.integer(input$pch) - 1, input$custompch),
+ col = ifelse(input$color != "custom", input$color, input$jscol1))
+
+ do.call(plot, pargs)
+
+ output$exportScript <- downloadHandler(
+ filename = function() { paste(input$filename, ".", "txt", sep="") },
+ content = function(file) {
+ write.table(tdata, file, sep = ",", quote = FALSE, row.names = FALSE)
+ },#EO content =,
+ contentType = "text"
+ )#EndOf::dowmloadHandler()
+
+
+ # nested downloadHandler() to print plot to file
+ output$exportFile <- downloadHandler(
+ filename = function() { paste(input$filename, ".", input$fileformat, sep="") },
+ content = function(file) {
+
+ # determine desired fileformat and set arguments
+ if(input$fileformat == "pdf") {
+ pdf(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ paper = "special",
+ useDingbats = FALSE,
+ family = input$fontfamily)
+ }
+ if(input$fileformat == "svg") {
+ svg(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ family = input$fontfamily)
+ }
+ if(input$fileformat == "eps") {
+ postscript(file,
+ width = input$imgwidth,
+ height = input$imgheight,
+ paper = "special",
+ family = input$fontfamily)
+ }
+
+ # plot curve
+ do.call(plot, args = pargs)
+
+ dev.off()
+ },#EO content =,
+ contentType = "image"
+ )#EndOf::dowmloadHandler()
+ })
+
+ output$dataset <- renderDataTable({
+ # be reactive on method changes
+ datGet()
+ input$method
+ input$delta
+ input$p
+
+ if (exists("tdata")){
+ tdata
+ }
+ })
+
+
+})##EndOf::shinyServer(function(input, output)
\ No newline at end of file
diff --git a/inst/shiny/transformCW/UI.R b/inst/shiny/transformCW/UI.R
new file mode 100644
index 0000000..e91006d
--- /dev/null
+++ b/inst/shiny/transformCW/UI.R
@@ -0,0 +1,237 @@
+## UI.R
+library(RLumShiny)
+
+pageWithSidebar(
+ # 1 - title = NULL -> Panel will not be shown
+ headerPanel(title = NULL),
+
+ # 2- width = 5 -> refers to twitters bootstrap grid system
+ # where the the maximum width is 12 that is to be shared between all
+ # elements
+ sidebarPanel(width = 5,
+ # include a tabs in the input panel for easier navigation
+ tabsetPanel(id = "tabs", type = "pill", selected = "Data",
+ # Tab 1: Data input
+ tabPanel("Data",
+ # informational text
+ div(align = "center", h5("Data upload")),
+ # file upload button (data set 1)
+ fileInput(inputId = "file",
+ label = strong("Primary data set"),
+ accept="text/plain"),
+ tooltip(refId = "file1", text = tags$img(src='file_structure.png', width='250px')),
+ # informational text
+ div(align = "center", h5("Settings")),
+ fluidRow(
+ column(width = 6,
+ # logical: should NA values be excluded?
+ checkboxInput(inputId = "naExclude",
+ label = "Exclude NA values",
+ value = TRUE),
+ tooltip(refId = "naExclude", text = "Exclude NA values from the data set prior to any further operations.")
+ ),
+ column(width = 6,
+ # logical: file contains headers?
+ checkboxInput(inputId = "headers",
+ label = "File contains headers",
+ value = FALSE),
+ tooltip(refId = "headers", text = tags$img(src='file_containsHeader.png', width='250px'))
+ )
+ ),
+ # char: columns separated by tab, space, comma
+ radioButtons("sep", "Separator", selected = "\t", inline = TRUE,
+ c("Tab" = "\t",
+ "Space" = " ",
+ "Comma" = ",",
+ "Semicolon" = ";")),
+ tooltip(refId = "sep", text = tags$img(src='file_sep.png', width='400px'), placement = "auto left")
+ ),##EndOf::Tab_1
+
+ tabPanel("Method",
+ hr(),
+ div(align = "center", h5("Transformation settings")),
+ radioButtons("method", "Method", selected = "CW2pHMi",
+ choices = c("Hyperbolic" = "CW2pHMi",
+ "Linear" = "CW2pLM",
+ "Linear (interpolated)" = "CW2pLMi",
+ "Parabolic" = "CW2pPMi")
+ ),
+ conditionalPanel(condition = "input.method == 'CW2pHMi'",
+ numericInput("delta", "Delta", value = 1, min = 0)),
+ conditionalPanel(condition = "input.method == 'CW2pLMi' || input.method == 'CW2pPMi'",
+ numericInput("p", "P", value = 1, min = 0))
+ ),
+
+ tabPanel("Plot",
+ div(align = "center", h5("Title")),
+
+ textInput(inputId = "main",
+ label = "Title",
+ value = "CW Curve Transfomation"),
+
+ radioButtons("type", "Type", selected = "l", inline = TRUE,
+ choices = c("Line" = "l",
+ "Points" = "p")),
+
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "pch",
+ label = "Style",
+ selected = "17",
+ choices = c("Square"= "1",
+ "Circle"="2",
+ "Triangle point up"="3",
+ "Plus"="4",
+ "Cross"="5",
+ "Diamond"="6",
+ "Triangle point down"="7",
+ "Square cross"="8",
+ "Star"="9",
+ "Diamond plus"="10",
+ "Circle plus"="11",
+ "Triangles up and down"="12",
+ "Square plus"="13",
+ "Circle cross"="14",
+ "Square and Triangle down"="15",
+ "filled Square"="16",
+ "filled Circle"="17",
+ "filled Triangle point up"="18",
+ "filled Diamond"="19",
+ "solid Circle"="20",
+ "Bullet (smaller Circle)"="21",
+ "Custom"="custom"))
+ ),
+ column(width = 6,
+ # show only if custom symbol is desired
+ conditionalPanel(condition = "input.pch == 'custom'",
+ textInput(inputId = "custompch",
+ label = "Insert character",
+ value = "?"))
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ selectInput(inputId = "color", label = "Datapoint color",
+ choices = list("Black" = "black",
+ "Grey" = "grey50",
+ "Red" = "#b22222",
+ "Green" = "#6E8B3D",
+ "Blue" = "#428bca",
+ "Custom" = "custom"))
+ ),
+ column(width = 6,
+ # show only if custom color is desired
+ conditionalPanel(condition = "input.color == 'custom'",
+ HTML("Choose a color<br>"),
+ jscolorInput(inputId = "jscol1"))
+ )
+ ),
+
+
+ br(),
+ div(align = "center", h5("Scaling")),
+ sliderInput(inputId = "cex",
+ label = "Scaling factor",
+ min = 0.5, max = 2,
+ value = 1.0, step = 0.1)
+ ),##EndOf::Tab_3
+
+ # Tab 4: modify axis parameters
+ tabPanel("Axis",
+ div(align = "center", h5("X-axis")),
+ checkboxInput(inputId = "logx",
+ label = "Logarithmic x-axis",
+ value = TRUE),
+ textInput(inputId = "xlab",
+ label = "Label x-axis",
+ value = "t [s]"),
+ # inject sliderInput from Server.R
+ br(),
+ div(align = "center", h5("Y-axis")),
+ checkboxInput(inputId = "logy",
+ label = "Logarithmic y-axis",
+ value = FALSE),
+ textInput(inputId = "ylab",
+ label = "Label y-axis (left)",
+ value = "pseudo OSL [cts/s]")
+ ),##EndOf::Tab_4
+
+ # Tab 10: save plot as pdf, wmf or eps
+ tabPanel("Export",
+ radioButtons(inputId = "fileformat",
+ label = "Fileformat",
+ selected = "pdf",
+ choices = c("PDF (Portable Document Format)" = "pdf",
+ "SVG (Scalable Vector Graphics)" = "svg",
+ "EPS (Encapsulated Postscript)" = "eps")),
+ textInput(inputId = "filename",
+ label = "Filename",
+ value = "transformed CW"),
+ fluidRow(
+ column(width = 6,
+ numericInput(inputId = "imgheight",
+ label = "Image height",
+ value = 7)
+ ),
+ column(width = 6,
+ numericInput(inputId = "imgwidth",
+ label = "Image width",
+ value = 7)
+ )
+ ),
+ selectInput(inputId = "fontfamily",
+ label = "Font",
+ selected = "Helvetica",
+ choices = c("Helvetica" = "Helvetica",
+ "Helvetica Narrow" = "Helvetica Narrow",
+ "Times" = "Times",
+ "Courier" = "Courier",
+ "Bookman" = "Bookman",
+ "Palatino" = "Palatino")),
+ tags$hr(),
+ downloadButton(outputId = "exportFile",
+ label = "Download plot"),
+ tags$hr(),
+ helpText("The transformed CW curve data can be downloaded as a comma separated
+ ASCII file."),
+
+ downloadButton(outputId = "exportScript",
+ label = "Download transformed data")
+ ),##EndOf::Tab_8
+
+ # Tab 10: further information
+ tabPanel("About",
+ hr(),
+ div(align = "center",
+ # HTML code to include a .png file in the tab; the image file must be in
+ # a subfolder called "wwww"
+ img(src="RL_Logo.png", height = 100, width = 100, alt = "R.Lum"),
+ p("Links:"),
+ a(href = "http://www.r-luminescence.de", "R.Luminescence project page", target="_blank"),
+ br(),
+ a(href = "https://forum.r-luminescence.de", "Message board", target="_blank"),
+ br(),
+ a(href = "http://zerk.canopus.uberspace.de/R.Lum", "Online application", target="_blank"),
+ br(),hr(),
+ img(src='GitHub-Mark-32px.png', width='32px', height='32px'),
+ br(),
+ a(href = "https://github.com/tzerk/RLumShiny/tree/master/inst/shiny/transformCW", "See the code at GitHub!", target="_blank")
+ )#/div
+ )##EndOf::Tab_9
+ )##EndOf::tabsetPanel
+ ),##EndOf::sidebarPanel
+
+
+ # 3 - output panel
+ mainPanel(width = 7,
+ # insert css code inside <head></head> of the generated HTML file:
+ # allow open dropdown menus to reach over the container
+ tags$head(tags$style(type="text/css",".tab-content {overflow: visible;}")),
+ tags$head(includeCSS("www/style.css")),
+ # divide output in separate tabs via tabsetPanel
+ tabsetPanel(
+ tabPanel("Plot", plotOutput(outputId = "main_plot", height = "500px")),
+ tabPanel("Output table", fluidRow(column(width = 12, dataTableOutput("dataset"))))
+ )###EndOf::tabsetPanel
+ )##EndOf::mainPanel
+)##EndOf::shinyUI(pageWithSidebar)
\ No newline at end of file
diff --git a/inst/shiny/transformCW/www/GitHub-Mark-32px.png b/inst/shiny/transformCW/www/GitHub-Mark-32px.png
new file mode 100644
index 0000000..8b25551
Binary files /dev/null and b/inst/shiny/transformCW/www/GitHub-Mark-32px.png differ
diff --git a/inst/shiny/transformCW/www/RL_Logo.png b/inst/shiny/transformCW/www/RL_Logo.png
new file mode 100644
index 0000000..ac0551b
Binary files /dev/null and b/inst/shiny/transformCW/www/RL_Logo.png differ
diff --git a/inst/shiny/transformCW/www/file_containsHeader.png b/inst/shiny/transformCW/www/file_containsHeader.png
new file mode 100644
index 0000000..7abe3d2
Binary files /dev/null and b/inst/shiny/transformCW/www/file_containsHeader.png differ
diff --git a/inst/shiny/transformCW/www/file_sep.png b/inst/shiny/transformCW/www/file_sep.png
new file mode 100644
index 0000000..0297e61
Binary files /dev/null and b/inst/shiny/transformCW/www/file_sep.png differ
diff --git a/inst/shiny/transformCW/www/file_structure.png b/inst/shiny/transformCW/www/file_structure.png
new file mode 100644
index 0000000..5e3b50a
Binary files /dev/null and b/inst/shiny/transformCW/www/file_structure.png differ
diff --git a/inst/shiny/transformCW/www/style.css b/inst/shiny/transformCW/www/style.css
new file mode 100644
index 0000000..295b46c
--- /dev/null
+++ b/inst/shiny/transformCW/www/style.css
@@ -0,0 +1,73 @@
+.custom-modal {
+ padding-left: 10px;
+ padding-top: 10px;
+ padding-bottom: 10px;
+ padding-right: 10px;
+ line-height: 200%;
+ background-color: #fff;
+ overflow: visible;
+ position: absolute;
+ z-index: 999;
+ border-radius: 10px;
+ border-style: solid;
+ border-color: #428bca;
+}
+
+.h {
+ font-size: 11px;
+ margin: 0 0 0px;
+}
+
+h5, h6 {
+ color: #428bca;
+ font-weight: 700;
+}
+
+.tooltip-inner {
+ max-width: 450px;
+}
+
+.control-label, .selectize-dropdown, .item, .btn, .uneditable-input, .sorting, .odd, .even, .dataTables-info, .fa, .fa-refresh {
+ font-size: 12px;
+}
+
+.selectize-input {
+ padding: 0px 10px;
+ min-height: 20px;
+}
+
+label, body, input {
+ font-size: 12px;
+ font-weight: 100 !important;
+}
+
+.label, .badge {
+ font-size: 12px;
+ padding: 4px 20px;
+ margin: 10px;
+ line-height: 18px;
+ font-weight: 100 !important;
+}
+
+.label-info, .badge-info {
+background-color: #428bca;
+}
+
+input[type="text"],input[type="number"],input[type="email"],input[type="url"],input[type="search"],input[type="tel"],input[type="color"],.uneditable-input{
+ display:inline-block;
+ height:18px;
+ padding:0px 0px 0px 7px;
+ margin-bottom:10px;
+ font-size: 11px;
+ line-height: 1.5;
+ color:#555;
+ vertical-align:middle;
+ -webkit-border-radius:4px;
+ -moz-border-radius:4px;
+ border-radius:4px
+ }
+
+input,textarea,.uneditable-input{
+ width: auto;
+ }
+
diff --git a/inst/www/jscolor/arrow.gif b/inst/www/jscolor/arrow.gif
new file mode 100644
index 0000000..246478a
Binary files /dev/null and b/inst/www/jscolor/arrow.gif differ
diff --git a/inst/www/jscolor/cross.gif b/inst/www/jscolor/cross.gif
new file mode 100644
index 0000000..0ee9c7a
Binary files /dev/null and b/inst/www/jscolor/cross.gif differ
diff --git a/inst/www/jscolor/demo.html b/inst/www/jscolor/demo.html
new file mode 100644
index 0000000..cb86066
--- /dev/null
+++ b/inst/www/jscolor/demo.html
@@ -0,0 +1,12 @@
+<html>
+<head>
+ <title>jscolor demo</title>
+</head>
+<body>
+
+ <script type="text/javascript" src="jscolor.js"></script>
+
+ Click here: <input class="color" value="66ff00">
+
+</body>
+</html>
diff --git a/inst/www/jscolor/hs.png b/inst/www/jscolor/hs.png
new file mode 100644
index 0000000..3d94486
Binary files /dev/null and b/inst/www/jscolor/hs.png differ
diff --git a/inst/www/jscolor/hv.png b/inst/www/jscolor/hv.png
new file mode 100644
index 0000000..1c5e01f
Binary files /dev/null and b/inst/www/jscolor/hv.png differ
diff --git a/inst/www/jscolor/jscolor.js b/inst/www/jscolor/jscolor.js
new file mode 100644
index 0000000..47c8961
--- /dev/null
+++ b/inst/www/jscolor/jscolor.js
@@ -0,0 +1,1010 @@
+/**
+ * jscolor, JavaScript Color Picker
+ *
+ * @version 1.4.4
+ * @license GNU Lesser General Public License, http://www.gnu.org/copyleft/lesser.html
+ * @author Jan Odvarko, http://odvarko.cz
+ * @created 2008-06-15
+ * @updated 2014-12-09
+ * @link http://jscolor.com
+ */
+
+
+var jscolor = {
+
+
+ dir : '', // location of jscolor directory (leave empty to autodetect)
+ bindClass : 'color', // class name
+ binding : true, // automatic binding via <input class="...">
+ preloading : true, // use image preloading?
+
+
+ install : function() {
+ jscolor.addEvent(window, 'load', jscolor.init);
+ },
+
+
+ init : function() {
+ if(jscolor.binding) {
+ jscolor.bind();
+ }
+ if(jscolor.preloading) {
+ jscolor.preload();
+ }
+ },
+
+
+ getDir : function() {
+ if(!jscolor.dir) {
+ var detected = jscolor.detectDir();
+ jscolor.dir = detected!==false ? detected : 'jscolor/';
+ }
+ return jscolor.dir;
+ },
+
+
+ detectDir : function() {
+ var base = location.href;
+
+ var e = document.getElementsByTagName('base');
+ for(var i=0; i<e.length; i+=1) {
+ if(e[i].href) { base = e[i].href; }
+ }
+
+ var e = document.getElementsByTagName('script');
+ for(var i=0; i<e.length; i+=1) {
+ if(e[i].src && /(^|\/)jscolor\.js([?#].*)?$/i.test(e[i].src)) {
+ var src = new jscolor.URI(e[i].src);
+ var srcAbs = src.toAbsolute(base);
+ srcAbs.path = srcAbs.path.replace(/[^\/]+$/, ''); // remove filename
+ srcAbs.query = null;
+ srcAbs.fragment = null;
+ return srcAbs.toString();
+ }
+ }
+ return false;
+ },
+
+
+ bind : function() {
+ var matchClass = new RegExp('(^|\\s)('+jscolor.bindClass+')(\\s*(\\{[^}]*\\})|\\s|$)', 'i');
+ var e = document.getElementsByTagName('input');
+ for(var i=0; i<e.length; i+=1) {
+ if(jscolor.isColorAttrSupported && e[i].type.toLowerCase() == 'color') {
+ // skip inputs of type 'color' if the browser supports this feature
+ continue;
+ }
+ var m;
+ if(!e[i].color && e[i].className && (m = e[i].className.match(matchClass))) {
+ var prop = {};
+ if(m[4]) {
+ try {
+ prop = (new Function ('return (' + m[4] + ')'))();
+ } catch(eInvalidProp) {}
+ }
+ e[i].color = new jscolor.color(e[i], prop);
+ }
+ }
+ },
+
+
+ preload : function() {
+ for(var fn in jscolor.imgRequire) {
+ if(jscolor.imgRequire.hasOwnProperty(fn)) {
+ jscolor.loadImage(fn);
+ }
+ }
+ },
+
+
+ images : {
+ pad : [ 181, 101 ],
+ sld : [ 16, 101 ],
+ cross : [ 15, 15 ],
+ arrow : [ 7, 11 ]
+ },
+
+
+ imgRequire : {},
+ imgLoaded : {},
+
+
+ requireImage : function(filename) {
+ jscolor.imgRequire[filename] = true;
+ },
+
+
+ loadImage : function(filename) {
+ if(!jscolor.imgLoaded[filename]) {
+ jscolor.imgLoaded[filename] = new Image();
+ jscolor.imgLoaded[filename].src = jscolor.getDir()+filename;
+ }
+ },
+
+
+ fetchElement : function(mixed) {
+ return typeof mixed === 'string' ? document.getElementById(mixed) : mixed;
+ },
+
+
+ addEvent : function(el, evnt, func) {
+ if(el.addEventListener) {
+ el.addEventListener(evnt, func, false);
+ } else if(el.attachEvent) {
+ el.attachEvent('on'+evnt, func);
+ }
+ },
+
+
+ fireEvent : function(el, evnt) {
+ if(!el) {
+ return;
+ }
+ if(document.createEvent) {
+ var ev = document.createEvent('HTMLEvents');
+ ev.initEvent(evnt, true, true);
+ el.dispatchEvent(ev);
+ } else if(document.createEventObject) {
+ var ev = document.createEventObject();
+ el.fireEvent('on'+evnt, ev);
+ } else if(el['on'+evnt]) { // alternatively use the traditional event model (IE5)
+ el['on'+evnt]();
+ }
+ },
+
+
+ getElementPos : function(e) {
+ var e1=e, e2=e;
+ var x=0, y=0;
+ if(e1.offsetParent) {
+ do {
+ x += e1.offsetLeft;
+ y += e1.offsetTop;
+ } while(e1 = e1.offsetParent);
+ }
+ while((e2 = e2.parentNode) && e2.nodeName.toUpperCase() !== 'BODY') {
+ x -= e2.scrollLeft;
+ y -= e2.scrollTop;
+ }
+ return [x, y];
+ },
+
+
+ getElementSize : function(e) {
+ return [e.offsetWidth, e.offsetHeight];
+ },
+
+
+ getRelMousePos : function(e) {
+ var x = 0, y = 0;
+ if (!e) { e = window.event; }
+ if (typeof e.offsetX === 'number') {
+ x = e.offsetX;
+ y = e.offsetY;
+ } else if (typeof e.layerX === 'number') {
+ x = e.layerX;
+ y = e.layerY;
+ }
+ return { x: x, y: y };
+ },
+
+
+ getViewPos : function() {
+ if(typeof window.pageYOffset === 'number') {
+ return [window.pageXOffset, window.pageYOffset];
+ } else if(document.body && (document.body.scrollLeft || document.body.scrollTop)) {
+ return [document.body.scrollLeft, document.body.scrollTop];
+ } else if(document.documentElement && (document.documentElement.scrollLeft || document.documentElement.scrollTop)) {
+ return [document.documentElement.scrollLeft, document.documentElement.scrollTop];
+ } else {
+ return [0, 0];
+ }
+ },
+
+
+ getViewSize : function() {
+ if(typeof window.innerWidth === 'number') {
+ return [window.innerWidth, window.innerHeight];
+ } else if(document.body && (document.body.clientWidth || document.body.clientHeight)) {
+ return [document.body.clientWidth, document.body.clientHeight];
+ } else if(document.documentElement && (document.documentElement.clientWidth || document.documentElement.clientHeight)) {
+ return [document.documentElement.clientWidth, document.documentElement.clientHeight];
+ } else {
+ return [0, 0];
+ }
+ },
+
+
+ URI : function(uri) { // See RFC3986
+
+ this.scheme = null;
+ this.authority = null;
+ this.path = '';
+ this.query = null;
+ this.fragment = null;
+
+ this.parse = function(uri) {
+ var m = uri.match(/^(([A-Za-z][0-9A-Za-z+.-]*)(:))?((\/\/)([^\/?#]*))?([^?#]*)((\?)([^#]*))?((#)(.*))?/);
+ this.scheme = m[3] ? m[2] : null;
+ this.authority = m[5] ? m[6] : null;
+ this.path = m[7];
+ this.query = m[9] ? m[10] : null;
+ this.fragment = m[12] ? m[13] : null;
+ return this;
+ };
+
+ this.toString = function() {
+ var result = '';
+ if(this.scheme !== null) { result = result + this.scheme + ':'; }
+ if(this.authority !== null) { result = result + '//' + this.authority; }
+ if(this.path !== null) { result = result + this.path; }
+ if(this.query !== null) { result = result + '?' + this.query; }
+ if(this.fragment !== null) { result = result + '#' + this.fragment; }
+ return result;
+ };
+
+ this.toAbsolute = function(base) {
+ var base = new jscolor.URI(base);
+ var r = this;
+ var t = new jscolor.URI;
+
+ if(base.scheme === null) { return false; }
+
+ if(r.scheme !== null && r.scheme.toLowerCase() === base.scheme.toLowerCase()) {
+ r.scheme = null;
+ }
+
+ if(r.scheme !== null) {
+ t.scheme = r.scheme;
+ t.authority = r.authority;
+ t.path = removeDotSegments(r.path);
+ t.query = r.query;
+ } else {
+ if(r.authority !== null) {
+ t.authority = r.authority;
+ t.path = removeDotSegments(r.path);
+ t.query = r.query;
+ } else {
+ if(r.path === '') {
+ t.path = base.path;
+ if(r.query !== null) {
+ t.query = r.query;
+ } else {
+ t.query = base.query;
+ }
+ } else {
+ if(r.path.substr(0,1) === '/') {
+ t.path = removeDotSegments(r.path);
+ } else {
+ if(base.authority !== null && base.path === '') {
+ t.path = '/'+r.path;
+ } else {
+ t.path = base.path.replace(/[^\/]+$/,'')+r.path;
+ }
+ t.path = removeDotSegments(t.path);
+ }
+ t.query = r.query;
+ }
+ t.authority = base.authority;
+ }
+ t.scheme = base.scheme;
+ }
+ t.fragment = r.fragment;
+
+ return t;
+ };
+
+ function removeDotSegments(path) {
+ var out = '';
+ while(path) {
+ if(path.substr(0,3)==='../' || path.substr(0,2)==='./') {
+ path = path.replace(/^\.+/,'').substr(1);
+ } else if(path.substr(0,3)==='/./' || path==='/.') {
+ path = '/'+path.substr(3);
+ } else if(path.substr(0,4)==='/../' || path==='/..') {
+ path = '/'+path.substr(4);
+ out = out.replace(/\/?[^\/]*$/, '');
+ } else if(path==='.' || path==='..') {
+ path = '';
+ } else {
+ var rm = path.match(/^\/?[^\/]*/)[0];
+ path = path.substr(rm.length);
+ out = out + rm;
+ }
+ }
+ return out;
+ }
+
+ if(uri) {
+ this.parse(uri);
+ }
+
+ },
+
+
+ //
+ // Usage example:
+ // var myColor = new jscolor.color(myInputElement)
+ //
+
+ color : function(target, prop) {
+
+
+ this.required = true; // refuse empty values?
+ this.adjust = true; // adjust value to uniform notation?
+ this.hash = false; // prefix color with # symbol?
+ this.caps = true; // uppercase?
+ this.slider = true; // show the value/saturation slider?
+ this.valueElement = target; // value holder
+ this.styleElement = target; // where to reflect current color
+ this.onImmediateChange = null; // onchange callback (can be either string or function)
+ this.hsv = [0, 0, 1]; // read-only 0-6, 0-1, 0-1
+ this.rgb = [1, 1, 1]; // read-only 0-1, 0-1, 0-1
+ this.minH = 0; // read-only 0-6
+ this.maxH = 6; // read-only 0-6
+ this.minS = 0; // read-only 0-1
+ this.maxS = 1; // read-only 0-1
+ this.minV = 0; // read-only 0-1
+ this.maxV = 1; // read-only 0-1
+
+ this.pickerOnfocus = true; // display picker on focus?
+ this.pickerMode = 'HSV'; // HSV | HVS
+ this.pickerPosition = 'bottom'; // left | right | top | bottom
+ this.pickerSmartPosition = true; // automatically adjust picker position when necessary
+ this.pickerButtonHeight = 20; // px
+ this.pickerClosable = false;
+ this.pickerCloseText = 'Close';
+ this.pickerButtonColor = 'ButtonText'; // px
+ this.pickerFace = 10; // px
+ this.pickerFaceColor = 'ThreeDFace'; // CSS color
+ this.pickerBorder = 1; // px
+ this.pickerBorderColor = 'ThreeDHighlight ThreeDShadow ThreeDShadow ThreeDHighlight'; // CSS color
+ this.pickerInset = 1; // px
+ this.pickerInsetColor = 'ThreeDShadow ThreeDHighlight ThreeDHighlight ThreeDShadow'; // CSS color
+ this.pickerZIndex = 10000;
+
+
+ for(var p in prop) {
+ if(prop.hasOwnProperty(p)) {
+ this[p] = prop[p];
+ }
+ }
+
+
+ this.hidePicker = function() {
+ if(isPickerOwner()) {
+ removePicker();
+ }
+ };
+
+
+ this.showPicker = function() {
+ if(!isPickerOwner()) {
+ var tp = jscolor.getElementPos(target); // target pos
+ var ts = jscolor.getElementSize(target); // target size
+ var vp = jscolor.getViewPos(); // view pos
+ var vs = jscolor.getViewSize(); // view size
+ var ps = getPickerDims(this); // picker size
+ var a, b, c;
+ switch(this.pickerPosition.toLowerCase()) {
+ case 'left': a=1; b=0; c=-1; break;
+ case 'right':a=1; b=0; c=1; break;
+ case 'top': a=0; b=1; c=-1; break;
+ default: a=0; b=1; c=1; break;
+ }
+ var l = (ts[b]+ps[b])/2;
+
+ // picker pos
+ if (!this.pickerSmartPosition) {
+ var pp = [
+ tp[a],
+ tp[b]+ts[b]-l+l*c
+ ];
+ } else {
+ var pp = [
+ -vp[a]+tp[a]+ps[a] > vs[a] ?
+ (-vp[a]+tp[a]+ts[a]/2 > vs[a]/2 && tp[a]+ts[a]-ps[a] >= 0 ? tp[a]+ts[a]-ps[a] : tp[a]) :
+ tp[a],
+ -vp[b]+tp[b]+ts[b]+ps[b]-l+l*c > vs[b] ?
+ (-vp[b]+tp[b]+ts[b]/2 > vs[b]/2 && tp[b]+ts[b]-l-l*c >= 0 ? tp[b]+ts[b]-l-l*c : tp[b]+ts[b]-l+l*c) :
+ (tp[b]+ts[b]-l+l*c >= 0 ? tp[b]+ts[b]-l+l*c : tp[b]+ts[b]-l-l*c)
+ ];
+ }
+ drawPicker(pp[a], pp[b]);
+ }
+ };
+
+
+ this.importColor = function() {
+ if(!valueElement) {
+ this.exportColor();
+ } else {
+ if(!this.adjust) {
+ if(!this.fromString(valueElement.value, leaveValue)) {
+ styleElement.style.backgroundImage = styleElement.jscStyle.backgroundImage;
+ styleElement.style.backgroundColor = styleElement.jscStyle.backgroundColor;
+ styleElement.style.color = styleElement.jscStyle.color;
+ this.exportColor(leaveValue | leaveStyle);
+ }
+ } else if(!this.required && /^\s*$/.test(valueElement.value)) {
+ valueElement.value = '';
+ styleElement.style.backgroundImage = styleElement.jscStyle.backgroundImage;
+ styleElement.style.backgroundColor = styleElement.jscStyle.backgroundColor;
+ styleElement.style.color = styleElement.jscStyle.color;
+ this.exportColor(leaveValue | leaveStyle);
+
+ } else if(this.fromString(valueElement.value)) {
+ // OK
+ } else {
+ this.exportColor();
+ }
+ }
+ };
+
+
+ this.exportColor = function(flags) {
+ if(!(flags & leaveValue) && valueElement) {
+ var value = this.toString();
+ if(this.caps) { value = value.toUpperCase(); }
+ if(this.hash) { value = '#'+value; }
+ valueElement.value = value;
+ }
+ if(!(flags & leaveStyle) && styleElement) {
+ styleElement.style.backgroundImage = "none";
+ styleElement.style.backgroundColor =
+ '#'+this.toString();
+ styleElement.style.color =
+ 0.213 * this.rgb[0] +
+ 0.715 * this.rgb[1] +
+ 0.072 * this.rgb[2]
+ < 0.5 ? '#FFF' : '#000';
+ }
+ if(!(flags & leavePad) && isPickerOwner()) {
+ redrawPad();
+ }
+ if(!(flags & leaveSld) && isPickerOwner()) {
+ redrawSld();
+ }
+ };
+
+
+ this.fromHSV = function(h, s, v, flags) { // null = don't change
+ if(h !== null) { h = Math.max(0.0, this.minH, Math.min(6.0, this.maxH, h)); }
+ if(s !== null) { s = Math.max(0.0, this.minS, Math.min(1.0, this.maxS, s)); }
+ if(v !== null) { v = Math.max(0.0, this.minV, Math.min(1.0, this.maxV, v)); }
+
+ this.rgb = HSV_RGB(
+ h===null ? this.hsv[0] : (this.hsv[0]=h),
+ s===null ? this.hsv[1] : (this.hsv[1]=s),
+ v===null ? this.hsv[2] : (this.hsv[2]=v)
+ );
+
+ this.exportColor(flags);
+ };
+
+
+ this.fromRGB = function(r, g, b, flags) { // null = don't change
+ if(r !== null) { r = Math.max(0.0, Math.min(1.0, r)); }
+ if(g !== null) { g = Math.max(0.0, Math.min(1.0, g)); }
+ if(b !== null) { b = Math.max(0.0, Math.min(1.0, b)); }
+
+ var hsv = RGB_HSV(
+ r===null ? this.rgb[0] : r,
+ g===null ? this.rgb[1] : g,
+ b===null ? this.rgb[2] : b
+ );
+ if(hsv[0] !== null) {
+ this.hsv[0] = Math.max(0.0, this.minH, Math.min(6.0, this.maxH, hsv[0]));
+ }
+ if(hsv[2] !== 0) {
+ this.hsv[1] = hsv[1]===null ? null : Math.max(0.0, this.minS, Math.min(1.0, this.maxS, hsv[1]));
+ }
+ this.hsv[2] = hsv[2]===null ? null : Math.max(0.0, this.minV, Math.min(1.0, this.maxV, hsv[2]));
+
+ // update RGB according to final HSV, as some values might be trimmed
+ var rgb = HSV_RGB(this.hsv[0], this.hsv[1], this.hsv[2]);
+ this.rgb[0] = rgb[0];
+ this.rgb[1] = rgb[1];
+ this.rgb[2] = rgb[2];
+
+ this.exportColor(flags);
+ };
+
+
+ this.fromString = function(hex, flags) {
+ var m = hex.match(/^\W*([0-9A-F]{3}([0-9A-F]{3})?)\W*$/i);
+ if(!m) {
+ return false;
+ } else {
+ if(m[1].length === 6) { // 6-char notation
+ this.fromRGB(
+ parseInt(m[1].substr(0,2),16) / 255,
+ parseInt(m[1].substr(2,2),16) / 255,
+ parseInt(m[1].substr(4,2),16) / 255,
+ flags
+ );
+ } else { // 3-char notation
+ this.fromRGB(
+ parseInt(m[1].charAt(0)+m[1].charAt(0),16) / 255,
+ parseInt(m[1].charAt(1)+m[1].charAt(1),16) / 255,
+ parseInt(m[1].charAt(2)+m[1].charAt(2),16) / 255,
+ flags
+ );
+ }
+ return true;
+ }
+ };
+
+
+ this.toString = function() {
+ return (
+ (0x100 | Math.round(255*this.rgb[0])).toString(16).substr(1) +
+ (0x100 | Math.round(255*this.rgb[1])).toString(16).substr(1) +
+ (0x100 | Math.round(255*this.rgb[2])).toString(16).substr(1)
+ );
+ };
+
+
+ function RGB_HSV(r, g, b) {
+ var n = Math.min(Math.min(r,g),b);
+ var v = Math.max(Math.max(r,g),b);
+ var m = v - n;
+ if(m === 0) { return [ null, 0, v ]; }
+ var h = r===n ? 3+(b-g)/m : (g===n ? 5+(r-b)/m : 1+(g-r)/m);
+ return [ h===6?0:h, m/v, v ];
+ }
+
+
+ function HSV_RGB(h, s, v) {
+ if(h === null) { return [ v, v, v ]; }
+ var i = Math.floor(h);
+ var f = i%2 ? h-i : 1-(h-i);
+ var m = v * (1 - s);
+ var n = v * (1 - s*f);
+ switch(i) {
+ case 6:
+ case 0: return [v,n,m];
+ case 1: return [n,v,m];
+ case 2: return [m,v,n];
+ case 3: return [m,n,v];
+ case 4: return [n,m,v];
+ case 5: return [v,m,n];
+ }
+ }
+
+
+ function removePicker() {
+ delete jscolor.picker.owner;
+ document.getElementsByTagName('body')[0].removeChild(jscolor.picker.boxB);
+ }
+
+
+ function drawPicker(x, y) {
+ if(!jscolor.picker) {
+ jscolor.picker = {
+ box : document.createElement('div'),
+ boxB : document.createElement('div'),
+ pad : document.createElement('div'),
+ padB : document.createElement('div'),
+ padM : document.createElement('div'),
+ sld : document.createElement('div'),
+ sldB : document.createElement('div'),
+ sldM : document.createElement('div'),
+ btn : document.createElement('div'),
+ btnS : document.createElement('span'),
+ btnT : document.createTextNode(THIS.pickerCloseText)
+ };
+ for(var i=0,segSize=4; i<jscolor.images.sld[1]; i+=segSize) {
+ var seg = document.createElement('div');
+ seg.style.height = segSize+'px';
+ seg.style.fontSize = '1px';
+ seg.style.lineHeight = '0';
+ jscolor.picker.sld.appendChild(seg);
+ }
+ jscolor.picker.sldB.appendChild(jscolor.picker.sld);
+ jscolor.picker.box.appendChild(jscolor.picker.sldB);
+ jscolor.picker.box.appendChild(jscolor.picker.sldM);
+ jscolor.picker.padB.appendChild(jscolor.picker.pad);
+ jscolor.picker.box.appendChild(jscolor.picker.padB);
+ jscolor.picker.box.appendChild(jscolor.picker.padM);
+ jscolor.picker.btnS.appendChild(jscolor.picker.btnT);
+ jscolor.picker.btn.appendChild(jscolor.picker.btnS);
+ jscolor.picker.box.appendChild(jscolor.picker.btn);
+ jscolor.picker.boxB.appendChild(jscolor.picker.box);
+ }
+
+ var p = jscolor.picker;
+
+ // controls interaction
+ p.box.onmouseup =
+ p.box.onmouseout = function() { target.focus(); };
+ p.box.onmousedown = function() { abortBlur=true; };
+ p.box.onmousemove = function(e) {
+ if (holdPad || holdSld) {
+ holdPad && setPad(e);
+ holdSld && setSld(e);
+ if (document.selection) {
+ document.selection.empty();
+ } else if (window.getSelection) {
+ window.getSelection().removeAllRanges();
+ }
+ dispatchImmediateChange();
+ }
+ };
+ if('ontouchstart' in window) { // if touch device
+ var handle_touchmove = function(e) {
+ var event={
+ 'offsetX': e.touches[0].pageX-touchOffset.X,
+ 'offsetY': e.touches[0].pageY-touchOffset.Y
+ };
+ if (holdPad || holdSld) {
+ holdPad && setPad(event);
+ holdSld && setSld(event);
+ dispatchImmediateChange();
+ }
+ e.stopPropagation(); // prevent move "view" on broswer
+ e.preventDefault(); // prevent Default - Android Fix (else android generated only 1-2 touchmove events)
+ };
+ p.box.removeEventListener('touchmove', handle_touchmove, false)
+ p.box.addEventListener('touchmove', handle_touchmove, false)
+ }
+ p.padM.onmouseup =
+ p.padM.onmouseout = function() { if(holdPad) { holdPad=false; jscolor.fireEvent(valueElement,'change'); } };
+ p.padM.onmousedown = function(e) {
+ // if the slider is at the bottom, move it up
+ switch(modeID) {
+ case 0: if (THIS.hsv[2] === 0) { THIS.fromHSV(null, null, 1.0); }; break;
+ case 1: if (THIS.hsv[1] === 0) { THIS.fromHSV(null, 1.0, null); }; break;
+ }
+ holdSld=false;
+ holdPad=true;
+ setPad(e);
+ dispatchImmediateChange();
+ };
+ if('ontouchstart' in window) {
+ p.padM.addEventListener('touchstart', function(e) {
+ touchOffset={
+ 'X': e.target.offsetParent.offsetLeft,
+ 'Y': e.target.offsetParent.offsetTop
+ };
+ this.onmousedown({
+ 'offsetX':e.touches[0].pageX-touchOffset.X,
+ 'offsetY':e.touches[0].pageY-touchOffset.Y
+ });
+ });
+ }
+ p.sldM.onmouseup =
+ p.sldM.onmouseout = function() { if(holdSld) { holdSld=false; jscolor.fireEvent(valueElement,'change'); } };
+ p.sldM.onmousedown = function(e) {
+ holdPad=false;
+ holdSld=true;
+ setSld(e);
+ dispatchImmediateChange();
+ };
+ if('ontouchstart' in window) {
+ p.sldM.addEventListener('touchstart', function(e) {
+ touchOffset={
+ 'X': e.target.offsetParent.offsetLeft,
+ 'Y': e.target.offsetParent.offsetTop
+ };
+ this.onmousedown({
+ 'offsetX':e.touches[0].pageX-touchOffset.X,
+ 'offsetY':e.touches[0].pageY-touchOffset.Y
+ });
+ });
+ }
+
+ // picker
+ var dims = getPickerDims(THIS);
+ p.box.style.width = dims[0] + 'px';
+ p.box.style.height = dims[1] + 'px';
+
+ // picker border
+ p.boxB.style.position = 'absolute';
+ p.boxB.style.clear = 'both';
+ p.boxB.style.left = x+'px';
+ p.boxB.style.top = y+'px';
+ p.boxB.style.zIndex = THIS.pickerZIndex;
+ p.boxB.style.border = THIS.pickerBorder+'px solid';
+ p.boxB.style.borderColor = THIS.pickerBorderColor;
+ p.boxB.style.background = THIS.pickerFaceColor;
+
+ // pad image
+ p.pad.style.width = jscolor.images.pad[0]+'px';
+ p.pad.style.height = jscolor.images.pad[1]+'px';
+
+ // pad border
+ p.padB.style.position = 'absolute';
+ p.padB.style.left = THIS.pickerFace+'px';
+ p.padB.style.top = THIS.pickerFace+'px';
+ p.padB.style.border = THIS.pickerInset+'px solid';
+ p.padB.style.borderColor = THIS.pickerInsetColor;
+
+ // pad mouse area
+ p.padM.style.position = 'absolute';
+ p.padM.style.left = '0';
+ p.padM.style.top = '0';
+ p.padM.style.width = THIS.pickerFace + 2*THIS.pickerInset + jscolor.images.pad[0] + jscolor.images.arrow[0] + 'px';
+ p.padM.style.height = p.box.style.height;
+ p.padM.style.cursor = 'crosshair';
+
+ // slider image
+ p.sld.style.overflow = 'hidden';
+ p.sld.style.width = jscolor.images.sld[0]+'px';
+ p.sld.style.height = jscolor.images.sld[1]+'px';
+
+ // slider border
+ p.sldB.style.display = THIS.slider ? 'block' : 'none';
+ p.sldB.style.position = 'absolute';
+ p.sldB.style.right = THIS.pickerFace+'px';
+ p.sldB.style.top = THIS.pickerFace+'px';
+ p.sldB.style.border = THIS.pickerInset+'px solid';
+ p.sldB.style.borderColor = THIS.pickerInsetColor;
+
+ // slider mouse area
+ p.sldM.style.display = THIS.slider ? 'block' : 'none';
+ p.sldM.style.position = 'absolute';
+ p.sldM.style.right = '0';
+ p.sldM.style.top = '0';
+ p.sldM.style.width = jscolor.images.sld[0] + jscolor.images.arrow[0] + THIS.pickerFace + 2*THIS.pickerInset + 'px';
+ p.sldM.style.height = p.box.style.height;
+ try {
+ p.sldM.style.cursor = 'pointer';
+ } catch(eOldIE) {
+ p.sldM.style.cursor = 'hand';
+ }
+
+ // "close" button
+ function setBtnBorder() {
+ var insetColors = THIS.pickerInsetColor.split(/\s+/);
+ var pickerOutsetColor = insetColors.length < 2 ? insetColors[0] : insetColors[1] + ' ' + insetColors[0] + ' ' + insetColors[0] + ' ' + insetColors[1];
+ p.btn.style.borderColor = pickerOutsetColor;
+ }
+ p.btn.style.display = THIS.pickerClosable ? 'block' : 'none';
+ p.btn.style.position = 'absolute';
+ p.btn.style.left = THIS.pickerFace + 'px';
+ p.btn.style.bottom = THIS.pickerFace + 'px';
+ p.btn.style.padding = '0 15px';
+ p.btn.style.height = '18px';
+ p.btn.style.border = THIS.pickerInset + 'px solid';
+ setBtnBorder();
+ p.btn.style.color = THIS.pickerButtonColor;
+ p.btn.style.font = '12px sans-serif';
+ p.btn.style.textAlign = 'center';
+ try {
+ p.btn.style.cursor = 'pointer';
+ } catch(eOldIE) {
+ p.btn.style.cursor = 'hand';
+ }
+ p.btn.onmousedown = function () {
+ THIS.hidePicker();
+ };
+ p.btnS.style.lineHeight = p.btn.style.height;
+
+ // load images in optimal order
+ switch(modeID) {
+ case 0: var padImg = 'hs.png'; break;
+ case 1: var padImg = 'hv.png'; break;
+ }
+ p.padM.style.backgroundImage = "url('"+jscolor.getDir()+"cross.gif')";
+ p.padM.style.backgroundRepeat = "no-repeat";
+ p.sldM.style.backgroundImage = "url('"+jscolor.getDir()+"arrow.gif')";
+ p.sldM.style.backgroundRepeat = "no-repeat";
+ p.pad.style.backgroundImage = "url('"+jscolor.getDir()+padImg+"')";
+ p.pad.style.backgroundRepeat = "no-repeat";
+ p.pad.style.backgroundPosition = "0 0";
+
+ // place pointers
+ redrawPad();
+ redrawSld();
+
+ jscolor.picker.owner = THIS;
+ document.getElementsByTagName('body')[0].appendChild(p.boxB);
+ }
+
+
+ function getPickerDims(o) {
+ var dims = [
+ 2*o.pickerInset + 2*o.pickerFace + jscolor.images.pad[0] +
+ (o.slider ? 2*o.pickerInset + 2*jscolor.images.arrow[0] + jscolor.images.sld[0] : 0),
+ o.pickerClosable ?
+ 4*o.pickerInset + 3*o.pickerFace + jscolor.images.pad[1] + o.pickerButtonHeight :
+ 2*o.pickerInset + 2*o.pickerFace + jscolor.images.pad[1]
+ ];
+ return dims;
+ }
+
+
+ function redrawPad() {
+ // redraw the pad pointer
+ switch(modeID) {
+ case 0: var yComponent = 1; break;
+ case 1: var yComponent = 2; break;
+ }
+ var x = Math.round((THIS.hsv[0]/6) * (jscolor.images.pad[0]-1));
+ var y = Math.round((1-THIS.hsv[yComponent]) * (jscolor.images.pad[1]-1));
+ jscolor.picker.padM.style.backgroundPosition =
+ (THIS.pickerFace+THIS.pickerInset+x - Math.floor(jscolor.images.cross[0]/2)) + 'px ' +
+ (THIS.pickerFace+THIS.pickerInset+y - Math.floor(jscolor.images.cross[1]/2)) + 'px';
+
+ // redraw the slider image
+ var seg = jscolor.picker.sld.childNodes;
+
+ switch(modeID) {
+ case 0:
+ var rgb = HSV_RGB(THIS.hsv[0], THIS.hsv[1], 1);
+ for(var i=0; i<seg.length; i+=1) {
+ seg[i].style.backgroundColor = 'rgb('+
+ (rgb[0]*(1-i/seg.length)*100)+'%,'+
+ (rgb[1]*(1-i/seg.length)*100)+'%,'+
+ (rgb[2]*(1-i/seg.length)*100)+'%)';
+ }
+ break;
+ case 1:
+ var rgb, s, c = [ THIS.hsv[2], 0, 0 ];
+ var i = Math.floor(THIS.hsv[0]);
+ var f = i%2 ? THIS.hsv[0]-i : 1-(THIS.hsv[0]-i);
+ switch(i) {
+ case 6:
+ case 0: rgb=[0,1,2]; break;
+ case 1: rgb=[1,0,2]; break;
+ case 2: rgb=[2,0,1]; break;
+ case 3: rgb=[2,1,0]; break;
+ case 4: rgb=[1,2,0]; break;
+ case 5: rgb=[0,2,1]; break;
+ }
+ for(var i=0; i<seg.length; i+=1) {
+ s = 1 - 1/(seg.length-1)*i;
+ c[1] = c[0] * (1 - s*f);
+ c[2] = c[0] * (1 - s);
+ seg[i].style.backgroundColor = 'rgb('+
+ (c[rgb[0]]*100)+'%,'+
+ (c[rgb[1]]*100)+'%,'+
+ (c[rgb[2]]*100)+'%)';
+ }
+ break;
+ }
+ }
+
+
+ function redrawSld() {
+ // redraw the slider pointer
+ switch(modeID) {
+ case 0: var yComponent = 2; break;
+ case 1: var yComponent = 1; break;
+ }
+ var y = Math.round((1-THIS.hsv[yComponent]) * (jscolor.images.sld[1]-1));
+ jscolor.picker.sldM.style.backgroundPosition =
+ '0 ' + (THIS.pickerFace+THIS.pickerInset+y - Math.floor(jscolor.images.arrow[1]/2)) + 'px';
+ }
+
+
+ function isPickerOwner() {
+ return jscolor.picker && jscolor.picker.owner === THIS;
+ }
+
+
+ function blurTarget() {
+ if(valueElement === target) {
+ THIS.importColor();
+ }
+ if(THIS.pickerOnfocus) {
+ THIS.hidePicker();
+ }
+ }
+
+
+ function blurValue() {
+ if(valueElement !== target) {
+ THIS.importColor();
+ }
+ }
+
+
+ function setPad(e) {
+ var mpos = jscolor.getRelMousePos(e);
+ var x = mpos.x - THIS.pickerFace - THIS.pickerInset;
+ var y = mpos.y - THIS.pickerFace - THIS.pickerInset;
+ switch(modeID) {
+ case 0: THIS.fromHSV(x*(6/(jscolor.images.pad[0]-1)), 1 - y/(jscolor.images.pad[1]-1), null, leaveSld); break;
+ case 1: THIS.fromHSV(x*(6/(jscolor.images.pad[0]-1)), null, 1 - y/(jscolor.images.pad[1]-1), leaveSld); break;
+ }
+ }
+
+
+ function setSld(e) {
+ var mpos = jscolor.getRelMousePos(e);
+ var y = mpos.y - THIS.pickerFace - THIS.pickerInset;
+ switch(modeID) {
+ case 0: THIS.fromHSV(null, null, 1 - y/(jscolor.images.sld[1]-1), leavePad); break;
+ case 1: THIS.fromHSV(null, 1 - y/(jscolor.images.sld[1]-1), null, leavePad); break;
+ }
+ }
+
+
+ function dispatchImmediateChange() {
+ if (THIS.onImmediateChange) {
+ var callback;
+ if (typeof THIS.onImmediateChange === 'string') {
+ callback = new Function (THIS.onImmediateChange);
+ } else {
+ callback = THIS.onImmediateChange;
+ }
+ callback.call(THIS);
+ }
+ }
+
+
+ var THIS = this;
+ var modeID = this.pickerMode.toLowerCase()==='hvs' ? 1 : 0;
+ var abortBlur = false;
+ var
+ valueElement = jscolor.fetchElement(this.valueElement),
+ styleElement = jscolor.fetchElement(this.styleElement);
+ var
+ holdPad = false,
+ holdSld = false,
+ touchOffset = {};
+ var
+ leaveValue = 1<<0,
+ leaveStyle = 1<<1,
+ leavePad = 1<<2,
+ leaveSld = 1<<3;
+
+ jscolor.isColorAttrSupported = false;
+ var el = document.createElement('input');
+ if(el.setAttribute) {
+ el.setAttribute('type', 'color');
+ if(el.type.toLowerCase() == 'color') {
+ jscolor.isColorAttrSupported = true;
+ }
+ }
+
+ // target
+ jscolor.addEvent(target, 'focus', function() {
+ if(THIS.pickerOnfocus) { THIS.showPicker(); }
+ });
+ jscolor.addEvent(target, 'blur', function() {
+ if(!abortBlur) {
+ window.setTimeout(function(){ abortBlur || blurTarget(); abortBlur=false; }, 0);
+ } else {
+ abortBlur = false;
+ }
+ });
+
+ // valueElement
+ if(valueElement) {
+ var updateField = function() {
+ THIS.fromString(valueElement.value, leaveValue);
+ dispatchImmediateChange();
+ };
+ jscolor.addEvent(valueElement, 'keyup', updateField);
+ jscolor.addEvent(valueElement, 'input', updateField);
+ jscolor.addEvent(valueElement, 'blur', blurValue);
+ valueElement.setAttribute('autocomplete', 'off');
+ }
+
+ // styleElement
+ if(styleElement) {
+ styleElement.jscStyle = {
+ backgroundImage : styleElement.style.backgroundImage,
+ backgroundColor : styleElement.style.backgroundColor,
+ color : styleElement.style.color
+ };
+ }
+
+ // require images
+ switch(modeID) {
+ case 0: jscolor.requireImage('hs.png'); break;
+ case 1: jscolor.requireImage('hv.png'); break;
+ }
+ jscolor.requireImage('cross.gif');
+ jscolor.requireImage('arrow.gif');
+
+ this.importColor();
+ }
+
+};
+
+
+jscolor.install();
diff --git a/inst/www/jscolor_inputBinding.js b/inst/www/jscolor_inputBinding.js
new file mode 100644
index 0000000..b90d221
--- /dev/null
+++ b/inst/www/jscolor_inputBinding.js
@@ -0,0 +1,19 @@
+// JSColor shiny input binding
+var jscolor = new Shiny.InputBinding();
+$.extend(jscolor, {
+ find: function(scope) {
+ return $(scope).find("input.color");
+ },
+ getValue: function(el) {
+ return $(el).val()
+ },
+ subscribe: function(el, callback) {
+ $(el).on("afterChange", function(e) {
+ callback();
+ });
+ },
+ unsubscribe: function(el) {
+ $(el).off("input.color");
+ }
+});
+Shiny.inputBindings.register(jscolor);
\ No newline at end of file
diff --git a/man/RLumShiny-package.Rd b/man/RLumShiny-package.Rd
new file mode 100644
index 0000000..d835c6e
--- /dev/null
+++ b/man/RLumShiny-package.Rd
@@ -0,0 +1,24 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/RLumShiny.R
+\docType{package}
+\name{RLumShiny-package}
+\alias{RLumShiny}
+\alias{RLumShiny-package}
+\title{Shiny Applications for the R Package Luminescence}
+\description{
+A collection of shiny applications for the R package Luminescence.
+These mainly, but not exclusively, include applications for plotting chronometric
+data from e.g. luminescence or radiocarbon dating. It further provides access to
+bootstraps tooltip and popover functionality as well as a binding to JSColor.
+}
+\details{
+In addition to its main purpose of providing convenient access to the Luminescence
+shiny applications (see \code{\link{app_RLum}}) this package also provides further functions to extend the
+functionality of shiny. From the Bootstrap framework the JavaScript tooltip and popover
+components can be added to any shiny application via \code{\link{tooltip}} and \code{\link{popover}}.
+It further provides a custom input binding to the JavaScript/HTML color picker JSColor.
+Offering access to most options provided by the JSColor API the function \code{\link{jscolorInput}}
+is easily implemented in a shiny app. RGB colors are returned as hex values and can be
+directly used in R's base plotting functions without the need of any format conversion.
+}
+
diff --git a/man/app_RLum.Rd b/man/app_RLum.Rd
new file mode 100644
index 0000000..9461706
--- /dev/null
+++ b/man/app_RLum.Rd
@@ -0,0 +1,59 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/app_RLum.R
+\name{app_RLum}
+\alias{app_RLum}
+\title{Run Luminescence shiny apps}
+\usage{
+app_RLum(app, ...)
+}
+\arguments{
+\item{app}{\code{\link{character}} (required): name of the application to start. See details for a list
+of available apps.}
+
+\item{...}{further arguments to pass to \code{\link{runApp}}}
+}
+\description{
+A wrapper for \code{\link{runApp}} to start interactive shiny apps for the R package Luminescence.
+}
+\details{
+The RLumShiny package provides a single function from which all shiny apps can be started: \code{app_RLum()}.
+It essentially only takes one argument, which is a unique keyword specifying which application to start.
+See the table below for a list of available shiny apps and which keywords to use.
+
+\tabular{lcl}{
+\bold{Application name:} \tab \bold{Keyword:} \tab \bold{Function:} \cr
+Abanico Plot \tab \emph{abanico} \tab \code{\link{plot_AbanicoPlot}} \cr
+Histogram \tab \emph{histogram} \tab \code{\link{plot_Histogram}} \cr
+Kernel Density Estimate Plot \tab \emph{KDE} \tab \code{\link{plot_KDE}} \cr
+Radial Plot \tab \emph{radialplot} \tab \code{\link{plot_RadialPlot}} \cr
+Dose Recovery Test \tab \emph{doserecovery} \tab \code{\link{plot_DRTResults}} \cr
+Cosmic Dose Rate \tab \emph{cosmicdose} \tab \code{\link{calc_CosmicDoseRate}} \cr
+CW Curve Transformation \tab \emph{transformCW} \tab \code{\link{CW2pHMi}, \link{CW2pLM}, \link{CW2pLMi}, \link{CW2pPMi}}
+}
+
+The \code{app_RLum()} function is just a wrapper for \code{\link{runApp}}.
+Via the \code{...} argument further arguments can be directly passed to \code{\link{runApp}}.
+See \code{?shiny::runApp} for further details on valid arguments.
+}
+\examples{
+
+\dontrun{
+# Plotting apps
+app_RLum("abanico")
+app_RLum("histogram")
+app_RLum("KDE")
+app_RLum("radialplot")
+app_RLum("doserecovery")
+
+# Further apps
+app_RLum("cosmicdose")
+}
+
+}
+\author{
+Christoph Burow, University of Cologne (Germany)
+}
+\seealso{
+\code{\link{runApp}}
+}
+
diff --git a/man/jscolorInput.Rd b/man/jscolorInput.Rd
new file mode 100644
index 0000000..cb9f6b6
--- /dev/null
+++ b/man/jscolorInput.Rd
@@ -0,0 +1,57 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/jscolor.R
+\name{jscolorInput}
+\alias{jscolorInput}
+\title{Create a JSColor picker input widget}
+\usage{
+jscolorInput(inputId, label, value, position = "bottom",
+ color = "transparent", mode = "HSV", slider = TRUE, close = FALSE)
+}
+\arguments{
+\item{inputId}{\code{\link{character}} (required): Specifies the input slot that will be used to access the value.}
+
+\item{label}{\code{\link{character}}: Display label for the control, or NULL for no label.}
+
+\item{value}{\code{\link{character}}: Initial RGB value of the color picker. Default is black ('#000000').}
+
+\item{position}{\code{\link{character}}: Position of the picker relative to the text input ('bottom', 'left', 'top', 'right').}
+
+\item{color}{\code{\link{character}}: Picker color scheme ('transparent' by default). Use RGB color coding ('000000').}
+
+\item{mode}{\code{\link{character}}: Mode of hue, saturation and value. Can either be 'HSV' or 'HVS'.}
+
+\item{slider}{\code{\link{logical}}: Show or hide the slider.}
+
+\item{close}{\code{\link{logical}}: Show or hide a close button.}
+}
+\description{
+Creates a JSColor (Javascript/HTML Color Picker) widget to be used in shiny applications.
+}
+\examples{
+# html code
+jscolorInput("col", "Color", "21BF6B", slider = FALSE)
+
+# example app
+\dontrun{
+shinyApp(
+ui = fluidPage(
+ jscolorInput(inputId = "col", label = "JSColor Picker",
+ value = "21BF6B", position = "right",
+ mode = "HVS", close = TRUE),
+ plotOutput("plot")
+),
+server = function(input, output) {
+ output$plot <- renderPlot({
+ plot(cars, col = input$col, cex = 2, pch = 16)
+ })
+})
+}
+}
+\seealso{
+Other input.elements: \code{\link{animationOptions}}, \code{\link{sliderInput}};
+\code{\link{checkboxGroupInput}}; \code{\link{checkboxInput}}; \code{\link{dateInput}};
+\code{\link{dateRangeInput}}; \code{\link{fileInput}}; \code{\link{numericInput}};
+\code{\link{passwordInput}}; \code{\link{radioButtons}}; \code{\link{selectInput}},
+\code{\link{selectizeInput}}; \code{\link{submitButton}}; \code{\link{textInput}}
+}
+
diff --git a/man/popover.Rd b/man/popover.Rd
new file mode 100644
index 0000000..041c735
--- /dev/null
+++ b/man/popover.Rd
@@ -0,0 +1,50 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/popover.R
+\name{popover}
+\alias{popover}
+\title{Create a bootstrap button with popover}
+\usage{
+popover(title, content, header = NULL, html = TRUE,
+ class = "btn btn-default", placement = c("right", "top", "left",
+ "bottom"), trigger = c("click", "hover", "focus", "manual"))
+}
+\arguments{
+\item{title}{\code{\link{character}} (required): Title of the button.}
+
+\item{content}{\code{\link{character}}: Text to be displayed in the popover.}
+
+\item{header}{\code{\link{character}}: Optional header in the popover.}
+
+\item{html}{\code{\link{logical}} Insert HTML into the popover.}
+
+\item{class}{\code{\link{logical}} Bootstrap button class (e.g. "btn btn-danger").}
+
+\item{placement}{\code{\link{character}}: How to position the popover - top | bottom | left | right | auto. When "auto" is specified, it will dynamically reorient the popover. For example, if placement is "auto left", the popover will display to the left when possible, otherwise it will display right.}
+
+\item{trigger}{\code{\link{character}}: How popover is triggered - click | hover | focus | manual.}
+}
+\description{
+Add small overlays of content for housing secondary information.
+}
+\examples{
+# html code
+popover("title", "Some content")
+
+# example app
+\dontrun{
+shinyApp(
+ui = fluidPage(
+ jscolorInput(inputId = "col", label = "JSColor Picker",
+ value = "21BF6B", position = "right",
+ mode = "HVS", close = TRUE),
+ popover(title = "Help!", content = "Call 911"),
+ plotOutput("plot")
+),
+server = function(input, output) {
+ output$plot <- renderPlot({
+ plot(cars, col = input$col, cex = 2, pch = 16)
+ })
+})
+}
+}
+
diff --git a/man/tooltip.Rd b/man/tooltip.Rd
new file mode 100644
index 0000000..6690d73
--- /dev/null
+++ b/man/tooltip.Rd
@@ -0,0 +1,68 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/tooltip.R
+\name{tooltip}
+\alias{tooltip}
+\title{Create a bootstrap tooltip}
+\usage{
+tooltip(refId, text, attr = NULL, animation = TRUE, delay = 100,
+ html = TRUE, placement = "auto", trigger = "hover")
+}
+\arguments{
+\item{refId}{\code{\link{character}} (required): id of the element the tooltip is to be attached to.}
+
+\item{text}{\code{\link{character}}: Text to be displayed in the tooltip.}
+
+\item{attr}{\code{\link{character}}: Attach tooltip to all elements with attribute \code{attr='refId'}.}
+
+\item{animation}{\code{\link{logical}}: Apply a CSS fade transition to the tooltip.}
+
+\item{delay}{\code{\link{numeric}}: Delay showing and hiding the tooltip (ms).}
+
+\item{html}{\code{\link{logical}}: Insert HTML into the tooltip.}
+
+\item{placement}{\code{\link{character}}: How to position the tooltip - top | bottom | left | right | auto. When 'auto' is specified, it will dynamically reorient the tooltip. For example, if placement is 'auto left', the tooltip will display to the left when possible, otherwise it will display right.}
+
+\item{trigger}{\code{\link{character}}: How tooltip is triggered - click | hover | focus | manual. You may pass multiple triggers; separate them with a space.}
+}
+\description{
+Create bootstrap tooltips for any HTML element to be used in shiny applications.
+}
+\examples{
+# javascript code
+tt <- tooltip("elementId", "This is a tooltip.")
+str(tt)
+
+# example app
+\dontrun{
+shinyApp(
+ui = fluidPage(
+ jscolorInput(inputId = "col", label = "JSColor Picker",
+ value = "21BF6B", position = "right",
+ mode = "HVS", close = TRUE),
+ tooltip("col", "This is a JScolor widget"),
+
+ checkboxInput("cbox", "Checkbox", FALSE),
+ tooltip("cbox", "This is a checkbox"),
+
+ checkboxGroupInput("cboxg", "Checkbox group", selected = "a",
+ choices = c("a" = "a",
+ "b" = "b",
+ "c" = "c")),
+ tooltip("cboxg", "This is a <b>checkbox group</b>", html = TRUE),
+
+ selectInput("select", "Selectinput", selected = "a", choices = c("a"="a", "b"="b")),
+ tooltip("select", "This is a text input field", attr = "for", placement = "right"),
+
+ passwordInput("pwIn", "Passwordinput"),
+ tooltip("pwIn", "This is a password input field"),
+
+ plotOutput("plot")
+),
+server = function(input, output) {
+ output$plot <- renderPlot({
+ plot(cars, col = input$col, cex = 2, pch = 16)
+ })
+})
+}
+}
+
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/r-cran-rlumshiny.git
More information about the debian-med-commit
mailing list