RLumShiny/0000755000175100001440000000000013124236633012165 5ustar hornikusersRLumShiny/inst/0000755000175100001440000000000013020024066013130 5ustar hornikusersRLumShiny/inst/www/0000755000175100001440000000000013122177024013762 5ustar hornikusersRLumShiny/inst/www/jscolor_inputBinding.js0000644000175100001440000000070513020024066020501 0ustar hornikusers// 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);RLumShiny/inst/www/jscolor/0000755000175100001440000000000013020024066015427 5ustar hornikusersRLumShiny/inst/www/jscolor/demo.html0000644000175100001440000000030613020024066017240 0ustar hornikusers jscolor demo Click here: RLumShiny/inst/www/jscolor/arrow.gif0000644000175100001440000000010213020024066017241 0ustar hornikusersGIF89a  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 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:Q0 ~Ɔ~r0hob z~Hy μ>zkU{C(aȅ^ [hvu c׈G{"?23:R z3 vF AZ~3n=R EZɱI"uXy~@0DMbw5Fw71=?ʦS,:tq03fb޹2jS @aD9&e,1C4$ONttB_lAEQ4Gilt1ڀHvhob>g&_Hen/kSzHK,_frǛ]3$\υIZ _ڀtقR~lB[?AWhh%\Yۓ'/+2΀v% _TQ3ݘ<ڛXYVןvV^g_( 8՟>:ޮ_ΪU)~]ԯ3B8=y#h↵X+9F~^' Ias!]h"č[9kY@0L1Q0?ڛM<*pTB*f$lz3W4[I]OZ'o%co7mhv0)a@eBj]UQ/|4߮CoZv]Ruv]);5,t[Ю'_;' Ў'__O/ .fm.%9b>MzyBꩼ D A/k-;oQubmm,yC A/qNboZI"(F}ef(j*CP^'f\?(eZ_W&{c6 ӡMivBh_6lPebp\VuwrHbU,̹>s]%0muB//ς O{-(Zgqā=:y{.Gia! { 'QBz5Iq's 7 KxV۠G> Q}ͯz?A{BGͽШ΅G*,>{J AKk w0O%PVtMKz@iy7d:4@KjN:SwUml R_T#t1Ewb ҳtGmi Ů]0hWb #G0< j0b T0SG]B5cwn!JV ~#c<isa/Vq>q;PR?g/`ͣXà0h! | QٯRz1_Tmum$s11JҾMv00b_*&sЦ;#Bc>>-M'F7i)dLW m%NqP?6{MGr30{ib=LAw~Lg@GA'w_>Mh Nv"vCuZw|Ho^cg/i9kU"9ڕؑI·hJU׮@'+QQwtjAϾ`x+qtIENDB`RLumShiny/inst/www/jscolor/hs.png0000644000175100001440000000517413020024066016556 0ustar hornikusersPNG  IHDRe5 CIDATxr#+ Ea?%yH.qzj ,=;<*숽"}GԩuwaxkձҏgC2qosEK4 8 ڙ֏˪uu"hb{ŸKlXcU\cwRǟ; z 14QV x=sυKlGY+c$݈=0<= z;4EK 7FFC@"]VݿO aiFG"(€!G48F t@$ Ca_"\_2v&v&^2TaO?z 1tJ7#fʠ|F?$.#6lS`U?zt[:1neh$NWYн.# Z1`=ڟZ8[J`zAA]|t}0Gj{vU=MIsI1Јn{ "-͟v >p[c #`+N SjʕY~(_B~P-н[k_RVܿ}.?=t]*7`13]k_/Ov&vfΡnIdzC#.TX|5V? }4B W%(0-D? #n q8km*&khgb W`d*,-9o 秏HlM2g6|7$fzy [ ,(:DfJ'ҏx4CFF K4uY_?j,y"tRYQ"ÜQ}=*z OhfH=aD.D81Ҵ?ĊBxZYhD#\qtwS4&? ٞ>ϻ/zGthb{hEePZW͎vC]{#c8aEj$-Ь} _Թ8ړ 2J؆4GDi4@ K7iivlk1UgDgl#5t~'Q҄y# tbmUU6>ڟݿR9f܀gtBl FVFI_lW?Hlcn B;BK6wgTPwBGg:U?El =G2b6x?=Tle4ȯ]Q%\z @hrjA< {E_{ `y]^~0hVA6RHxE0-ʠ˚}y.j.nQ 8ڟlEY@σBl q cZ9-a6bwlѽO_w#v4Ƕ=Ԥ/ЏX$Rܭ\{/(,H4ҏC@J¬n22U=6p?=} zV8 I3A[Rяà] s WoxuS @-Ѕ~L 묌L`]Z?N$#(dnyLd .1WZ%z0G֏@}R2:A+_DO.sÇ%҅~P,ٛ+|"us[:ڟbDMez(gٗ |F#W1л-kB 0wB2#9ڍT4跏c7A@Jr5Țĩ̹q Ol }_@x2)Sz|8ڟIk2+|MFp&' tGuj؆oxFb3Z?(s̗{t݂܉Nה[FdꚜLdbӡn.е~0_>ҼȖ d'Jv }?>Ė! -H: KIENDB`RLumShiny/inst/www/jscolor/cross.gif0000644000175100001440000000012313020024066017243 0ustar hornikusersGIF89a! ,$ǝRQg/,@))qڤp 0; var canMoveFrom = (right.val() || []).length > 0; leftArrow.toggleClass("muted", !canMoveFrom); rightArrow.toggleClass("muted", !canMoveTo); } function move(chooser, source, dest) { chooser = $(chooser); var selected = chooser.find(source).children("option:selected"); var dest = chooser.find(dest); dest.children("option:selected").each(function(i, e) {e.selected = false;}); dest.append(selected); updateChooser(chooser); chooser.trigger("change"); } $(document).on("change", ".chooser select", function() { updateChooser($(this).parents(".chooser")); }); $(document).on("click", ".chooser .right-arrow", function() { move($(this).parents(".chooser"), ".left", ".right"); }); $(document).on("click", ".chooser .left-arrow", function() { move($(this).parents(".chooser"), ".right", ".left"); }); $(document).on("dblclick", ".chooser select.left", function() { move($(this).parents(".chooser"), ".left", ".right"); }); $(document).on("dblclick", ".chooser select.right", function() { move($(this).parents(".chooser"), ".right", ".left"); }); var binding = new Shiny.InputBinding(); binding.find = function(scope) { return $(scope).find(".chooser"); }; binding.initialize = function(el) { updateChooser(el); }; binding.getValue = function(el) { return { left: $.makeArray($(el).find("select.left option").map(function(i, e) { return e.value; })), right: $.makeArray($(el).find("select.right option").map(function(i, e) { return e.value; })) } }; binding.setValue = function(el, value) { // TODO: implement }; binding.subscribe = function(el, callback) { $(el).on("change.chooserBinding", function(e) { callback(); }); }; binding.unsubscribe = function(el) { $(el).off(".chooserBinding"); }; binding.getType = function() { return "shinyjsexamples.chooser"; }; Shiny.inputBindings.register(binding, "shinyjsexamples.chooser"); })(); RLumShiny/inst/shiny/0000755000175100001440000000000013122176157014276 5ustar hornikusersRLumShiny/inst/shiny/radialplot/0000755000175100001440000000000013055562161016430 5ustar hornikusersRLumShiny/inst/shiny/radialplot/ui.R0000644000175100001440000013203213055562161017171 0ustar hornikusers## UI.R function(request) { fluidPage( titlePanel(NULL, windowTitle = "RLumShiny - RadialPlot"), sidebarLayout( # 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, .csv, text/csv"), # file upload button (data set 2) fileInput(inputId = "file2", label = strong("Secondary data set"), accept="text/plain, .csv, text/csv"), # rhandsontable input/output fluidRow( column(width = 6, rHandsontableOutput(outputId = "table_in_primary") ), column(width = 6, rHandsontableOutput(outputId = "table_in_secondary")) ), 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
"), 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
"),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
"),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
"),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
"),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
"),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
"),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
"),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("
2σ bar
")), 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 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::sideBarLayout bookmarkButton() )##EndOf::fluidPage }RLumShiny/inst/shiny/radialplot/server.R0000644000175100001440000004005613053275130020061 0ustar hornikusers## Server.R ## MAIN FUNCTION function(input, output, session) { # input data (with default) values <- reactiveValues(data_primary = ExampleData.DeValues$CA1, data_secondary = setNames(as.data.frame(matrix(NA_real_, nrow = 5, ncol = 2)), c("x", "y"))) # check and read in file (DATA SET 1) observeEvent(input$file1, { inFile<- input$file1 if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL values$data_primary <- fread(file = inFile$datapath, data.table = FALSE) # inFile[1] contains filepath }) # check and read in file (DATA SET 2) observeEvent(input$file2, { inFile<- input$file2 if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL values$data_secondary <- fread(file = inFile$datapath, data.table = FALSE) # inFile[1] contains filepath }) ### GET DATA SETS Data<- reactive({ ### GET DATA data <- list(values$data_primary, values$data_secondary) data <- lapply(data, function(x) { x_tmp <- x[complete.cases(x), ] if (nrow(x_tmp) == 0) return(NULL) else return(x_tmp) }) data <- data[!sapply(data, is.null)] data <- lapply(data, function(x) setNames(x, c("Dose", "Error"))) return(data) }) output$table_in_primary <- renderRHandsontable({ rhandsontable(values$data_primary, height = 300, colHeaders = c("Dose", "Error"), rowHeaders = NULL) }) observeEvent(input$table_in_primary, { # Workaround for rhandsontable issue #138 # https://github.com/jrowen/rhandsontable/issues/138 df_tmp <- input$table_in_primary row_names <- as.list(as.character(seq_len(length(df_tmp$data)))) df_tmp$params$rRowHeaders <- row_names df_tmp$params$rowHeaders <- row_names df_tmp$params$rDataDim <- as.list(c(length(row_names), length(df_tmp$params$columns))) if (df_tmp$changes$event == "afterRemoveRow") df_tmp$changes$event <- "afterChange" if (!is.null(hot_to_r(df_tmp))) values$data_primary <- hot_to_r(df_tmp) }) output$table_in_secondary <- renderRHandsontable({ rhandsontable(values$data_secondary, height = 300, colHeaders = c("Dose", "Error"), rowHeaders = NULL) }) observeEvent(input$table_in_secondary, { # Workaround for rhandsontable issue #138 # https://github.com/jrowen/rhandsontable/issues/138 df_tmp <- input$table_in_secondary row_names <- as.list(as.character(seq_len(length(df_tmp$data)))) df_tmp$params$rRowHeaders <- row_names df_tmp$params$rowHeaders <- row_names df_tmp$params$rDataDim <- as.list(c(length(row_names), length(df_tmp$params$columns))) if (df_tmp$changes$event == "afterRemoveRow") df_tmp$changes$event <- "afterChange" if (!is.null(hot_to_r(df_tmp))) values$data_secondary <- hot_to_r(df_tmp) }) # dynamically inject sliderInput for central value output$centValue<- renderUI({ centValue.data <- do.call(rbind, Data()) 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])) })## EndOf::renderUI() # dynamically inject sliderInput for z-axis range output$xlim<- renderUI({ xlim.data<- do.call(rbind, Data()) 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) })## EndOf::renderUI() # dynamically inject sliderInput for z-axis range output$zlim<- renderUI({ zlim.data<- do.call(rbind, Data()) 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)) })## 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 data <- Data() 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(!all(is.na(unlist(values$data_secondary)))) { # 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(!all(is.na(unlist(values$data_secondary)))) { 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 = TRUE, 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 str1 <- "data <- data.table::fread(file, data.table = FALSE)" if(!all(is.na(unlist(values$data_secondary)))) { str2 <- "file2 <- file.choose()" str3 <- "data2 <- data.table::fread(file2, data.table = FALSE)" 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()); }); }", { 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(!all(is.na(unlist(values$data_secondary)))) { data<- Data()[[2]] 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)RLumShiny/inst/shiny/radialplot/www/0000755000175100001440000000000013055562161017254 5ustar hornikusersRLumShiny/inst/shiny/radialplot/www/GitHub-Mark-32px.png0000644000175100001440000000326213020024066022616 0ustar hornikusersPNG  IHDR szztEXtSoftwareAdobe ImageReadyqe<$iTXtXML:com.adobe.xmp $IDATxėmhayL30A+R#f>IHکy(M)_o5 0+0Ėl&o{i^]u<{Yws}=uC>$L, }<w}8^ AO?p! xaяPKI3`'B>0QT1<+`}^nvkp^ƅF|1"Gp.*oO׀Vp ]߅jc8K$q 8jV`#`vmpGѢu!#}#:U_?_yhE $=;c*xNOo+&w)%K-R%6n'o">j/t³qoGW7j%2q GX?woibCÐAzbǰt \14|S.DZ]# b|H$(ʕohmqͱRP셣$,0Z20 tNvRW3K8Xk2 IO6 H3Q5 B.@ $pd!s#~<<+"x M0B\t8K@zB@F&S`cbP-`'{[! eDh;VEX0fK9-0IWfH  0Q){`##xFW<+*x<$9E[-qWW.(I+6aa@.y24x6_-"bbϫp@t~,/;m%h^ uf@Wp~<5j>{-]cK'Xto(hw?G%fIq^D$.Tʳ?D*A, `6B$BB dr`)B(Ͱ*`/@4Qhp.U=pa( Aa!ڈbX#!H$ ɈQ"K5H1RT UH=r9\F;2G1Q= C7F dt1r=6Ыhڏ>C03l0.B8, c˱" VcϱwE 6wB aAHXLXNH $4 7 Q'"K&b21XH,#/{C7$C2'ITFnR#,4H#dk9, +ȅ3![ b@qS(RjJ4e2AURݨT5ZBRQ4u9̓IKhhitݕNWGw Ljg(gwLӋT071oUX**| J&*/Tު UUT^S}FU3S ԖUPSSg;goT?~YYLOCQ_ cx,!k u5&|v*=9C3J3WRf?qtN (~))4L1e\kXHQG6EYAJ'\'GgSSݧ M=:.kDwn^Loy}/TmG X $ <5qo</QC]@Caaᄑ.ȽJtq]zۯ6iܟ4)Y3sCQ? 0k߬~OCOg#/c/Wװwa>>r><72Y_7ȷOo_C#dz%gA[z|!?:eAAA!h쐭!ΑiP~aa~ 'W?pX15wCsDDDޛg1O9-J5*>.j<74?.fYXXIlK9.*6nl {/]py.,:@LN8A*%w% yg"/6шC\*NH*Mz쑼5y$3,幄'L Lݛ:v m2=:1qB!Mggfvˬen/kY- BTZ(*geWf͉9+̳ې7ᒶKW-X潬j9(xoʿܔĹdff-[n ڴ VE/(ۻCɾUUMfeI?m]Nmq#׹=TR+Gw- 6 U#pDy  :v{vg/jBFS[b[O>zG499?rCd&ˮ/~јѡ򗓿m|x31^VwwO| (hSЧc3-gAMA|Q cHRMz%u0`:o_FiIDATx}td%! )+7ږJ["\wKIQl7YWtFuftZǙ]=8n-Ot) q\p7ab SZMM@z K[yӧO?_7n\ pw~ \i$eo .<_: @IpB^D=c,JN+߻jժ8|()ٞ /MMM#g̙d\]w5f߾}}vP2.^zTq㢯ψ˼W馛FGN#P.NȦG"suhll4(E%>F]]Q~o=6mdPcbŊZ|ب˼xaPl."o,۷o7.E˼۷… K;|XRJw}~(T_u^^矏F?mƼ|>{WkΜ9 sl瞲^O$y1qIJƍ>?qZ*/,YR߳?8F-uy۷o VOF8GrWXQIU\VZ~OVײo߾ؾ}>F$yӧW4nܸ2oΜ9U5GN? [/o .گ矏F?Uc^]]]U}G9{`]vEL:)de1!Ҭ!UVǴi?Y>K苧鍈m{N}?SJ_m[2#@%6 qw;4T>u>o_ODPVbcލ7X3_}b5502|eXV"c?9E__H6;OYO?{P+z{{cժU̙30Q>= v@$&-Y$1ߔؾ}{x~BA"1oo߾D}c.\~B^GeqHDļ\.oΊ+S Z~OϸRc^O7gժU>p۾/zNDx0c^>^oЍ7~RDz_ž>`j:s=۷/={VSOHl;|pZ*ߤn)5ɿ "٘w;=c?:tƇO,P^|@ }XpaYO-P5<6 KKf"žhf5Yr\*YsO<~j~VTHż/SZjUٟY o Mg߁}wBy/B{ゥ-Y$%Oxt T̻뮻R ۷o_l߾=nF?@Ѹ 5>ߑ"~. 1ZJjb^.(+V<`('o<{<J*b^(UV?hll4P>ܰ5"ؾϣ1H o։y@<<BБczf@by@ܻ?:7l@y@"?H41i|>6u툮m{<Oj@y@MH31 O["%UMC%U%ǃ_vU<*xT'q"νsֈ!F@G=O5#B;tX^9zNxp~۱G"Z(1( /s̳ŗlr (1|>+ /2xPb0lV>>*Aŗ^U_Gj<`H!gZ>b R KNζ=GE<Rb<\|i;!@ sŮj)5 j)PqEsܰUÑ" <(5m <8G\}'<<8/r7e!(yc-Pnb¡#⾕ y@Yy0B; [<3 T<5m]=BP1b Tmq)7^\|QL0..ln_a$H01Bo1S.yCןuuugZ 'A\}'<EګrlH71`0=?0pN^.0 "57b4B0g qascwZHpw)154qG y._y\Eb%Amk5Gfx, <1T NwY q'A x%OƧ%p[hO|o<(m[ ̾WJ7?54raA8Ẹ:r,qGmkR $QU|ܷ!!Txڣ $QU> yHyT޾ D<FḲ*<@\yT#D<Ẹ|NI%Plbm{|N35.>%raA(1y͏#1D<JṂ"Kk6 y$ָܶh\s|%1Id<*scCP涵FD_{A(91;tX15mK(|>|ԬrP @ىyʯ|Cȣ& ~.GOo*Ḅl~d8xԜm+/f *J̣,|Zj-]:7luGUp@y̓_G ^}}q Q 6WyEQWWg81asGmk2scc*8< Z yP<s25^+E23-yP|bcWw!5!JC5a>Wy#o~% ;7"@y¦o#!qJw#q[\1"sZ!D#""|8x ָܶ+cc@yDD} <m|!//涵nH1/|^^]FFH!Wy\b^8x)*IK_z)*MK'z/RU$PORU$P]!e涵u4$@FH2s`b^?KmNK'2O\p! ļ'"sZchļz$#@ y w)[b^y#ܶhb^>wܛlSq^|)"%sM;:n20ORbn[k̼l! Eļ&|30dfH1/A6=7BJ<H/1/A~p>/MK˼47RLKggxӔ)&Abb^Be^*44RLK5B]>} <ozF\=-Fk#$ <d yP涵F}@کP#)'@ !ᮻ #b^R'O!ZyP+<\|1j yP+<b1j5B!@FyP#<bԀ_7KK9W_ayNbԘ=RHK7Mhرq#@ y R__fN7D WK/RFK:# )#%̕o))#%7]b-0s)Q[H1/a]8)Q[H1/a6])_RBK#ؾm{;RBK٭o1Ba#@ y tٛh! ļ4q`a@:y 42{b~pb^BaFH>t1$P_sRfwwOt}o! ļsF۱u$Po2K0Ru$P FH)y\b^]KB ļ[0wRu$`3/sRu$`Z!\@y !\@y w˂9FHOtl۱Pļ-'63T11/CJD5گ1[({ >7Q-<(xԖsBOb^[!8'AϿ0#R{{;ޮg[?1`<:b/ z0 bg:b z{1`" c\aޥqQA zg;c ΣTvw?x`7Bc|v'/^z PǰΣԺ+>yߚ/g 1"(=Wޛn f[1\1b\Qr//|-e0#{ ( _*>TsǨym۱|m)c?01[[[o!(nz>RvwCϟ#G5 QT3N2 W߉P<06{bՃ#>J&Qt !QuXcjGI_UaYz~z od>}'?yTx\pQzb%3eldo!"BУ*=ӧܒqKfQjb%' AU۱:@U({/-Uo0WqWYuuuy%&xܖ1?wĕO3 UC̣,l<*b-7=?4-#%Qu|~i#0\bUVz[^iNJom}sdo!"|~sz{hweo뮙uuuH91' Aj F=15n̉mPo:Tp̚9/VkOeG26>t;sVA~Ջ{ڷ^\ _?]x]wѱx~\d^'NGpOE㎎˧ A%n-|q*D#xpX|q(#1074?G%rc'GkƧ%&G\2iB|wD熭Pb~UT@w5W˦z+.9H,A*ފ;59=.|#G_Uw!OЃ|+CsZq͑;;̾;V}[qQ5eԘ Ώ?Y\@ XOzUN!߽4> 2cd/*kxAT'18d:r,[PD1[`H3NrGo<`XuŲw(@x]ns-<`zJe0j__;36u툮m{\@y?" b-qQQJMø>OJgEt\%~U1Y-<=(y@Ųc>tLJ!߽4?eQol2g}.fdIH|wMo 0LbP13N6T̡#Ǣ!`D__Ƌ/|*E}@y@xx sLݟ.^"%/uԵCȣ\6 *|u_}'"A-ChinY3gbn+CE߱g#O?/C V~((KHN};o~X?N>q|S&A?547 O^}}7ힾ#ⷱO?k&A]U岙fCT W?ypБc)yRmvGAlԣT1RБcwtblCT1R辕ʣ\6 y2;7Cjok=)ӹa< e37UJ̃ٸQ#PP.E)kWy iFbbĦB岙fCT91Rŗ^m{ AA-͍1cdCT91R`W*rLܾd!j d8x'M0@  WyfFy`޾S&ئ1b$u]QP.yP?yUCjokuPc]e-͍1k C$5fW*rLܾd!J̃d8x'M0@ByPC֮*rLq!L̃q1Wy iꔉq `bԈ6ʣ\6K7@‰yP9}' AAW]1-61@‰yP\1\6 m{ f͜a"B̃ԵU岙x )bTHRKscL4"A]U岙}C bT3>5M2U!A|iFWyfb5<(CGEo CP)clCbu]QP.ws!8#1hR{[k3:7luGAl&2f<({rLܺ`N<(|>*aΕF`HbB岙XnJ̃ѵm!(1f͜aJ̃[oʣ\6/Y`Ẽ?~21C5s( 1F`SWyfw,6%#0?*!47I @Ɉy0LkoqGAl&n_̳ŁG AASLt@ɉy0 _ZU岙Xx!(91Бcw4u4gzfWyf]\hB̃!ܻUCjok_:CPb sVWyf"3o!(1 عw((ĭ D}}1(1 ϻns(+1`S!rLt,j7e'ڶf0e'7\QP.ۗ,0!iZc "<8[\Q<*M̃9t䘫<4uDWyTzfWyfb<^0]uŴ4T*岙6TGܻUCjokzCPqb׹a< e37T1Tζ=F\6]P5<4k #Xb5cS! m{ f͜aRỊl*rLq!H-1<3M6%Q5֮*rLܾd!H51d8x4uĘwY4Z#i<*bS!rLt,j7Gڶf0G=oʣ\6/Y`81?~2vuZc 3(뷸ʣ Wy0419tX8x4uDWy01Yn< e3t|C<Бcw4u401pPrLܙpb%s~Wy 5 g!Qrʣ\6y  QRٶfcQ<&1G]1Y3gỊd6u(h*>1[*FḤ$V~((KFḤZc (뷸ʣ\6wtl1:t䘫<4uĸhQ(6ʣ\6K7G:r,zNZclC(y}+rGAl&2f΁GQܻ 5 @̣(:7luGAl&C98g7?j e3ѱ=HڶUC5s<ɦB岙fC@yZѵm!(1fLl(1Q[~< e3q"'Ƙ:7luǐn5M2UGA_ZU岙Xx!<Бcw4u4PFbgzfWyf-2x{cHmQ__o(31ܰU岙̛m1Wζ=F\6.**D|>o~UCaΕF 8eS!rLt,j7TGD*# 1f͜a 1Xoʣ\6/Y`01?~2 []1_k!b^Bm!QP.E#%P>m{ f͜a1b^=oʣ\6c!y d147I 5HK뷸ʣ\6/Y`Qb^m{\1Y3gR@̫rvyfΎ )!U_z9147ƌi>B̫b-Wyf% )"U'Ƙm{ f͜aH91 |UÑQe3ѱ$aL>=VX/Af0jժhjj5ƨBbB.ۗ,0c}vcT1F1&O`?.\mmmk*  m'N+VD>7Hy0BSLt@*Z*~~/1*D̃e3t|C}?~|<(31F+ئ1 ꫯx R&b S.m ٷo_455Ŋ+Qb S{[k`ժUQWW۷o7F y0 l&2fb…1~8|1J@̃e3ѱU SL>=r+21aFzG)>cCF{<"`-͍c…΁䲙}C@۷/O+Vyz A-͍1yC@ Z*sM1F@̃3e3e %}ypSLMc epdb󴵞qP٪z*Su+4^)RkߥЉtB&!dfD1cV0dd/0ɽM$>>>zm>|36cuu5v\\\h'#7+rt4#<@x ,C3jZk{<֭[1ݻggg0k>|Ƞpj5v ̃xT*idXӉR~{4D^Z'''Z0k>| f<z4HMȨ5ATx"k-M&I^pߏz7w&kMВ$n[[[\0I4cmm-Wrv;...r.atbyy97y>Z~!q܌o.yp8h W0Bt:Q*{05 (ͨjq||Zyxɓ(J3U0>^GVL#KX__v=yz<Nj5^쾘[ <4MG?<$I(AT*!K>ߍhsEj<og%/M8< ]qxx+++~On`a%I^/Aa jnF*̚y,Vxpk73iZa{  Ӓ$n[㴟-UĹx3i4JE3>  3$pXxqLz1y0W;;;1LŻl4Mw v0SIQ A5 nFЌ+ qV+ϣlh7XRDLiK4ceeE3<.Iz1 yS$`vh4-͘2aSj4ok"iښfܰ<`p-IDuvvvvślF{{{QT4cvJ?}'W$ph.ޜ9f /1yqW""ZVL&h41?4~o.^9f @Dwtt@ :E[L>y煋0 L|10?f@|v]k /\9f ōui]ug@nΕ7l`|?\+o+OvVՃ}UV:Ws-7m+Ov}sVJ!cSY+rfjY9@L5/+g@X@7rDypcXyQ  n<,l&4nȉnb[z,D]z,[X{dIXxs{Zf/s6ٙIENDB`RLumShiny/inst/shiny/radialplot/www/style.css0000644000175100001440000000242713055561001021123 0ustar hornikusers.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; } .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; } .label, .badge { font-size: 12px; padding: 4px 20px; margin: 10px; line-height: 18px; } .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; } RLumShiny/inst/shiny/radialplot/shiny_bookmarks/0000755000175100001440000000000012772146744021644 5ustar hornikusersRLumShiny/inst/shiny/radialplot/shiny_bookmarks/1e0f5bee0eebca8d/0000755000175100001440000000000012772146744024434 5ustar hornikusersRLumShiny/inst/shiny/radialplot/shiny_bookmarks/1e0f5bee0eebca8d/input.rds0000644000175100001440000000145412765756674026324 0ustar hornikusersV=o1$wM 9bj_,P*EBHUIvsw~?;+3_r8bA'}~ɳyEw)ׁzصdա{k 2\+OJw)_Zؗo")(8fYį|؊R7jaXq*Ec%+VxVAʎl.W#Oi^i 1ah$y-0M7w!EGO*_aqm{Sm-m3$e>]LSEDpYh:+ݎGaM5Rb'6P= v0hԈ\Ԏo8CAb*uƼUPwŷ+g' e-$FݭCT0v?8ǟ?ѧ/k)JT\FB+WGDSP Xk1X;!jkęK1|)Yspuo8x[v]qcnBvGt2&q˄  X% .t!ro,x( [.DH&͖YM=6P4^w7mCbL_)^is9X/@v8 lWv2= l|ƛgЎ̴=lO[$HC*)ǬM;ŷz,HC hF`E9` -oDIڐdQZ ! d $O'ldB׋dh@+`qj:kg7jf RLumShiny/inst/shiny/radialplot/Global.R0000644000175100001440000000032013053274161017744 0ustar hornikusers## global.R ## library(Luminescence) library(RLumShiny) library(shiny) library(data.table) library(rhandsontable) # load example data data(ExampleData.DeValues) enableBookmarking(store = "server")RLumShiny/inst/shiny/doserecovery/0000755000175100001440000000000013055562161017006 5ustar hornikusersRLumShiny/inst/shiny/doserecovery/ui.R0000644000175100001440000007017713055562161017562 0ustar hornikusersfunction(request) { fluidPage( titlePanel(NULL, windowTitle = "RLumShiny - DRT"), sidebarLayout( 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, .csv, text/csv"), # file upload button (data set 2) fileInput(inputId = "file2", label = strong("Secondary data set"), accept="text/plain, .csv, text/csv"), # rhandsontable input/output fluidRow( column(width = 6, rHandsontableOutput(outputId = "table_in_primary") ), column(width = 6, rHandsontableOutput(outputId = "table_in_secondary")) ), 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 values (e.g., Seconds or Gray)."), 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 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")) ) ) ), bookmarkButton() ) }RLumShiny/inst/shiny/doserecovery/server.R0000644000175100001440000002364713053271172020450 0ustar hornikusers############################################################################## ### MAIN PROGRAM ### ############################################################################## function(input, output, session) { # input data (with default) values <- reactiveValues(data_primary = ExampleData.DeValues$BT998[7:11,], data_secondary = setNames(as.data.frame(matrix(NA_real_, nrow = 5, ncol = 2)), c("x", "y"))) # check and read in file (DATA SET 1) observeEvent(input$file1, { inFile<- input$file1 if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL values$data_primary <- fread(file = inFile$datapath, data.table = FALSE) # inFile[1] contains filepath }) # check and read in file (DATA SET 2) observeEvent(input$file2, { inFile<- input$file2 if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL values$data_secondary <- fread(file = inFile$datapath, data.table = FALSE) # inFile[1] contains filepath }) ### GET DATA SETS Data<- reactive({ data <- list(values$data_primary, values$data_secondary) data <- lapply(data, function(x) { x_tmp <- x[complete.cases(x), ] if (nrow(x_tmp) == 0) return(NULL) else return(x_tmp) }) data <- data[!sapply(data, is.null)] data <- lapply(data, function(x) setNames(x, c("Dose", "Error"))) return(data) }) output$table_in_primary <- renderRHandsontable({ rhandsontable(values$data_primary, height = 300, colHeaders = c("Dose", "Error"), rowHeaders = NULL) }) observeEvent(input$table_in_primary, { # Workaround for rhandsontable issue #138 # https://github.com/jrowen/rhandsontable/issues/138 df_tmp <- input$table_in_primary row_names <- as.list(as.character(seq_len(length(df_tmp$data)))) df_tmp$params$rRowHeaders <- row_names df_tmp$params$rowHeaders <- row_names df_tmp$params$rDataDim <- as.list(c(length(row_names), length(df_tmp$params$columns))) if (df_tmp$changes$event == "afterRemoveRow") df_tmp$changes$event <- "afterChange" if (!is.null(hot_to_r(df_tmp))) values$data_primary <- hot_to_r(df_tmp) }) output$table_in_secondary <- renderRHandsontable({ rhandsontable(values$data_secondary, height = 300, colHeaders = c("Dose", "Error"), rowHeaders = NULL) }) observeEvent(input$table_in_secondary, { # Workaround for rhandsontable issue #138 # https://github.com/jrowen/rhandsontable/issues/138 # See detailed explanation above df_tmp <- input$table_in_secondary row_names <- as.list(as.character(seq_len(length(df_tmp$data)))) df_tmp$params$rRowHeaders <- row_names df_tmp$params$rowHeaders <- row_names df_tmp$params$rDataDim <- as.list(c(length(row_names), length(df_tmp$params$columns))) if (df_tmp$changes$event == "afterRemoveRow") df_tmp$changes$event <- "afterChange" if (!is.null(hot_to_r(df_tmp))) values$data_secondary <- hot_to_r(df_tmp) }) output$xlim<- renderUI({ data<- Data() n <- max(sapply(data, nrow)) 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 str1 <- "data <- data.table::fread(file, data.table = FALSE)" if(!all(is.na(unlist(values$data_secondary)))) { str2 <- "file2 <- file.choose()" str3 <- "data2 <- data.table::fread(file2, data.table = FALSE)" 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() } RLumShiny/inst/shiny/doserecovery/www/0000755000175100001440000000000013055562161017632 5ustar hornikusersRLumShiny/inst/shiny/doserecovery/www/GitHub-Mark-32px.png0000644000175100001440000000326213020024066023174 0ustar hornikusersPNG  IHDR szztEXtSoftwareAdobe ImageReadyqe<$iTXtXML:com.adobe.xmp $IDATxėmhayL30A+R#f>IHکy(M)_o5 0+0Ėl&o{i^]u<{Yws}=uC>$L, }<w}8^ AO?p! xaяPKI3`'B>0QT1<+`}^nvkp^ƅF|1"Gp.*oO׀Vp ]߅jc8K$q 8jV`#`vmpGѢu!#}#:U_?_yhE $=;c*xNOo+&w)%K-R%6n'o">j/t³qoGW7j%2q GX?woibCÐAzbǰt \14|S.DZ]# b|H$(ʕohmqͱRP셣$,0Z20 tNvRW3K8Xk2 IO6 H3Q5 B.@ $pd!s#~<<+"x M0B\t8K@zB@F&S`cbP-`'{[! eDh;VEX0fK9-0IWfH  0Q){`##xFW<+*x<$9E[-qWW.(I+6aa@.y24x6_-"bbϫp@t~,/;m%h^ uf@Wp~<5j>{-]cK'Xto(hw?G%fIq^D$.Tʳ?D*A, `6B$BB dr`)B(Ͱ*`/@4Qhp.U=pa( Aa!ڈbX#!H$ ɈQ"K5H1RT UH=r9\F;2G1Q= C7F dt1r=6Ыhڏ>C03l0.B8, c˱" VcϱwE 6wB aAHXLXNH $4 7 Q'"K&b21XH,#/{C7$C2'ITFnR#,4H#dk9, +ȅ3![ b@qS(RjJ4e2AURݨT5ZBRQ4u9̓IKhhitݕNWGw Ljg(gwLӋT071oUX**| J&*/Tު UUT^S}FU3S ԖUPSSg;goT?~YYLOCQ_ cx,!k u5&|v*=9C3J3WRf?qtN (~))4L1e\kXHQG6EYAJ'\'GgSSݧ M=:.kDwn^Loy}/TmG X $ <5qo</QC]@Caaᄑ.ȽJtq]zۯ6iܟ4)Y3sCQ? 0k߬~OCOg#/c/Wװwa>>r><72Y_7ȷOo_C#dz%gA[z|!?:eAAA!h쐭!ΑiP~aa~ 'W?pX15wCsDDDޛg1O9-J5*>.j<74?.fYXXIlK9.*6nl {/]py.,:@LN8A*%w% yg"/6шC\*NH*Mz쑼5y$3,幄'L Lݛ:v m2=:1qB!Mggfvˬen/kY- BTZ(*geWf͉9+̳ې7ᒶKW-X潬j9(xoʿܔĹdff-[n ڴ VE/(ۻCɾUUMfeI?m]Nmq#׹=TR+Gw- 6 U#pDy  :v{vg/jBFS[b[O>zG499?rCd&ˮ/~јѡ򗓿m|x31^VwwO| (hSЧc3-gAMA|Q cHRMz%u0`:o_FiIDATx}td%! )+7ږJ["\wKIQl7YWtFuftZǙ]=8n-Ot) q\p7ab SZMM@z K[yӧO?_7n\ pw~ \i$eo .<_: @IpB^D=c,JN+߻jժ8|()ٞ /MMM#g̙d\]w5f߾}}vP2.^zTq㢯ψ˼W馛FGN#P.NȦG"suhll4(E%>F]]Q~o=6mdPcbŊZ|ب˼xaPl."o,۷o7.E˼۷… K;|XRJw}~(T_u^^矏F?mƼ|>{WkΜ9 sl瞲^O$y1qIJƍ>?qZ*/,YR߳?8F-uy۷o VOF8GrWXQIU\VZ~OVײo߾ؾ}>F$yӧW4nܸ2oΜ9U5GN? [/o .گ矏F?Uc^]]]U}G9{`]vEL:)de1!Ҭ!UVǴi?Y>K苧鍈m{N}?SJ_m[2#@%6 qw;4T>u>o_ODPVbcލ7X3_}b5502|eXV"c?9E__H6;OYO?{P+z{{cժU̙30Q>= v@$&-Y$1ߔؾ}{x~BA"1oo߾D}c.\~B^GeqHDļ\.oΊ+S Z~OϸRc^O7gժU>p۾/zNDx0c^>^oЍ7~RDz_ž>`j:s=۷/={VSOHl;|pZ*ߤn)5ɿ "٘w;=c?:tƇO,P^|@ }XpaYO-P5<6 KKf"žhf5Yr\*YsO<~j~VTHż/SZjUٟY o Mg߁}wBy/B{ゥ-Y$%Oxt T̻뮻R ۷o_l߾=nF?@Ѹ 5>ߑ"~. 1ZJjb^.(+V<`('o<{<J*b^(UV?hll4P>ܰ5"ؾϣ1H o։y@<<BБczf@by@ܻ?:7l@y@"?H41i|>6u툮m{<Oj@y@MH31 O["%UMC%U%ǃ_vU<*xT'q"νsֈ!F@G=O5#B;tX^9zNxp~۱G"Z(1( /s̳ŗlr (1|>+ /2xPb0lV>>*Aŗ^U_Gj<`H!gZ>b R KNζ=GE<Rb<\|i;!@ sŮj)5 j)PqEsܰUÑ" <(5m <8G\}'<<8/r7e!(yc-Pnb¡#⾕ y@Yy0B; [<3 T<5m]=BP1b Tmq)7^\|QL0..ln_a$H01Bo1S.yCןuuugZ 'A\}'<EګrlH71`0=?0pN^.0 "57b4B0g qascwZHpw)154qG y._y\Eb%Amk5Gfx, <1T NwY q'A x%OƧ%p[hO|o<(m[ ̾WJ7?54raA8Ẹ:r,qGmkR $QU|ܷ!!Txڣ $QU> yHyT޾ D<FḲ*<@\yT#D<Ẹ|NI%Plbm{|N35.>%raA(1y͏#1D<JṂ"Kk6 y$ָܶh\s|%1Id<*scCP涵FD_{A(91;tX15mK(|>|ԬrP @ىyʯ|Cȣ& ~.GOo*Ḅl~d8xԜm+/f *J̣,|Zj-]:7luGUp@y̓_G ^}}q Q 6WyEQWWg81asGmk2scc*8< Z yP<s25^+E23-yP|bcWw!5!JC5a>Wy#o~% ;7"@y¦o#!qJw#q[\1"sZ!D#""|8x ָܶ+cc@yDD} <m|!//涵nH1/|^^]FFH!Wy\b^8x)*IK_z)*MK'z/RU$PORU$P]!e涵u4$@FH2s`b^?KmNK'2O\p! ļ'"sZchļz$#@ y w)[b^y#ܶhb^>wܛlSq^|)"%sM;:n20ORbn[k̼l! Eļ&|30dfH1/A6=7BJ<H/1/A~p>/MK˼47RLKggxӔ)&Abb^Be^*44RLK5B]>} <ozF\=-Fk#$ <d yP涵F}@کP#)'@ !ᮻ #b^R'O!ZyP+<\|1j yP+<b1j5B!@FyP#<bԀ_7KK9W_ayNbԘ=RHK7Mhرq#@ y R__fN7D WK/RFK:# )#%̕o))#%7]b-0s)Q[H1/a]8)Q[H1/a6])_RBK#ؾm{;RBK٭o1Ba#@ y tٛh! ļ4q`a@:y 42{b~pb^BaFH>t1$P_sRfwwOt}o! ļsF۱u$Po2K0Ru$P FH)y\b^]KB ļ[0wRu$`3/sRu$`Z!\@y !\@y w˂9FHOtl۱Pļ-'63T11/CJD5گ1[({ >7Q-<(xԖsBOb^[!8'AϿ0#R{{;ޮg[?1`<:b/ z0 bg:b z{1`" c\aޥqQA zg;c ΣTvw?x`7Bc|v'/^z PǰΣԺ+>yߚ/g 1"(=Wޛn f[1\1b\Qr//|-e0#{ ( _*>TsǨym۱|m)c?01[[[o!(nz>RvwCϟ#G5 QT3N2 W߉P<06{bՃ#>J&Qt !QuXcjGI_UaYz~z od>}'?yTx\pQzb%3eldo!"BУ*=ӧܒqKfQjb%' AU۱:@U({/-Uo0WqWYuuuy%&xܖ1?wĕO3 UC̣,l<*b-7=?4-#%Qu|~i#0\bUVz[^iNJom}sdo!"|~sz{hweo뮙uuuH91' Aj F=15n̉mPo:Tp̚9/VkOeG26>t;sVA~Ջ{ڷ^\ _?]x]wѱx~\d^'NGpOE㎎˧ A%n-|q*D#xpX|q(#1074?G%rc'GkƧ%&G\2iB|wD熭Pb~UT@w5W˦z+.9H,A*ފ;59=.|#G_Uw!OЃ|+CsZq͑;;̾;V}[qQ5eԘ Ώ?Y\@ XOzUN!߽4> 2cd/*kxAT'18d:r,[PD1[`H3NrGo<`XuŲw(@x]ns-<`zJe0j__;36u툮m{\@y?" b-qQQJMø>OJgEt\%~U1Y-<=(y@Ųc>tLJ!߽4?eQol2g}.fdIH|wMo 0LbP13N6T̡#Ǣ!`D__Ƌ/|*E}@y@xx sLݟ.^"%/uԵCȣ\6 *|u_}'"A-ChinY3gbn+CE߱g#O?/C V~((KHN};o~X?N>q|S&A?547 O^}}7ힾ#ⷱO?k&A]U岙fCT W?ypБc)yRmvGAlԣT1RБcwtblCT1R辕ʣ\6 y2;7Cjok=)ӹa< e37UJ̃ٸQ#PP.E)kWy iFbbĦB岙fCT91Rŗ^m{ AA-͍1cdCT91R`W*rLܾd!j d8x'M0@  WyfFy`޾S&ئ1b$u]QP.yP?yUCjokuPc]e-͍1k C$5fW*rLܾd!J̃d8x'M0@ByPC֮*rLq!L̃q1Wy iꔉq `bԈ6ʣ\6K7@‰yP9}' AAW]1-61@‰yP\1\6 m{ f͜a"B̃ԵU岙x )bTHRKscL4"A]U岙}C bT3>5M2U!A|iFWyfb5<(CGEo CP)clCbu]QP.ws!8#1hR{[k3:7luGAl&2f<({rLܺ`N<(|>*aΕF`HbB岙XnJ̃ѵm!(1f͜aJ̃[oʣ\6/Y`Ẽ?~21C5s( 1F`SWyfw,6%#0?*!47I @Ɉy0LkoqGAl&n_̳ŁG AASLt@ɉy0 _ZU岙Xx!(91Бcw4u4gzfWyf]\hB̃!ܻUCjok_:CPb sVWyf"3o!(1 عw((ĭ D}}1(1 ϻns(+1`S!rLt,j7e'ڶf0e'7\QP.ۗ,0!iZc "<8[\Q<*M̃9t䘫<4uDWyTzfWyfb<^0]uŴ4T*岙6TGܻUCjokzCPqb׹a< e37T1Tζ=F\6]P5<4k #Xb5cS! m{ f͜aRỊl*rLq!H-1<3M6%Q5֮*rLܾd!H51d8x4uĘwY4Z#i<*bS!rLt,j7Gڶf0G=oʣ\6/Y`81?~2vuZc 3(뷸ʣ Wy0419tX8x4uDWy01Yn< e3t|C<Бcw4u401pPrLܙpb%s~Wy 5 g!Qrʣ\6y  QRٶfcQ<&1G]1Y3gỊd6u(h*>1[*FḤ$V~((KFḤZc (뷸ʣ\6wtl1:t䘫<4uĸhQ(6ʣ\6K7G:r,zNZclC(y}+rGAl&2f΁GQܻ 5 @̣(:7luGAl&C98g7?j e3ѱ=HڶUC5s<ɦB岙fC@yZѵm!(1fLl(1Q[~< e3q"'Ƙ:7luǐn5M2UGA_ZU岙Xx!<Бcw4u4PFbgzfWyf-2x{cHmQ__o(31ܰU岙̛m1Wζ=F\6.**D|>o~UCaΕF 8eS!rLt,j7TGD*# 1f͜a 1Xoʣ\6/Y`01?~2 []1_k!b^Bm!QP.E#%P>m{ f͜a1b^=oʣ\6c!y d147I 5HK뷸ʣ\6/Y`Qb^m{\1Y3gR@̫rvyfΎ )!U_z9147ƌi>B̫b-Wyf% )"U'Ƙm{ f͜aH91 |UÑQe3ѱ$aL>=VX/Af0jժhjj5ƨBbB.ۗ,0c}vcT1F1&O`?.\mmmk*  m'N+VD>7Hy0BSLt@*Z*~~/1*D̃e3t|C}?~|<(31F+ئ1 ꫯx R&b S.m ٷo_455Ŋ+Qb S{[k`ժUQWW۷o7F y0 l&2fb…1~8|1J@̃e3ѱU SL>=r+21aFzG)>cCF{<"`-͍c…΁䲙}C@۷/O+Vyz A-͍1yC@ Z*sM1F@̃3e3e %}ypSLMc epdb󴵞qP٪z*Su+4^)RkߥЉtB&!dfD1cV0dd/0ɽM$>>>zm>|36cuu5v\\\h'#7+rt4#<@x ,C3jZk{<֭[1ݻggg0k>|Ƞpj5v ̃xT*idXӉR~{4D^Z'''Z0k>| f<z4HMȨ5ATx"k-M&I^pߏz7w&kMВ$n[[[\0I4cmm-Wrv;...r.atbyy97y>Z~!q܌o.yp8h W0Bt:Q*{05 (ͨjq||Zyxɓ(J3U0>^GVL#KX__v=yz<Nj5^쾘[ <4MG?<$I(AT*!K>ߍhsEj<og%/M8< ]qxx+++~On`a%I^/Aa jnF*̚y,Vxpk73iZa{  Ӓ$n[㴟-UĹx3i4JE3>  3$pXxqLz1y0W;;;1LŻl4Mw v0SIQ A5 nFЌ+ qV+ϣlh7XRDLiK4ceeE3<.Iz1 yS$`vh4-͘2aSj4ok"iښfܰ<`p-IDuvvvvślF{{{QT4cvJ?}'W$ph.ޜ9f /1yqW""ZVL&h41?4~o.^9f @Dwtt@ :E[L>y煋0 L|10?f@|v]k /\9f ōui]ug@nΕ7l`|?\+o+OvVՃ}UV:Ws-7m+Ov}sVJ!cSY+rfjY9@L5/+g@X@7rDypcXyQ  n<,l&4nȉnb[z,D]z,[X{dIXxs{Zf/s6ٙIENDB`RLumShiny/inst/shiny/doserecovery/www/style.css0000644000175100001440000000242713055560666021521 0ustar hornikusers.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; } .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; } .label, .badge { font-size: 12px; padding: 4px 20px; margin: 10px; line-height: 18px; } .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; } RLumShiny/inst/shiny/doserecovery/Global.R0000644000175100001440000000042113053262365020327 0ustar hornikusers## global.R ## library(Luminescence) library(shiny) library(RLumShiny) library(data.table) library(rhandsontable) ## read example data set and misapply them for this plot type data(ExampleData.DeValues, envir = environment()) enableBookmarking(store = "server")RLumShiny/inst/shiny/filter/0000755000175100001440000000000013124170541015554 5ustar hornikusersRLumShiny/inst/shiny/filter/ui.R0000644000175100001440000001770313124170541016324 0ustar hornikusers## +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ## Title: Filter_app ## Authors: Urs Tilmann Wolpert, Department of Geography, Justus-Liebig-University Giessen ## Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) ## Contact: urs.t.wolpert@geogr.uni-giessen.de ## Date: Thu June 22 2017 ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ shinyUI( navbarPage("Filter_app", tabPanel("Transmission", sidebarLayout( sidebarPanel( # tabs on sidebar panel tabsetPanel(type = "pills", selected = "Data", # Tab 1: Data Transmission tabPanel("Data", tags$hr(), strong("Select filters"), uiOutput(outputId = "filters"), tags$hr(), radioButtons( "stimulationInput", label = "Show stimulation wavelength", choices = c("None" = "NA", "Violet: 405 \u0394 3 nm " = "violett", "Blue: 458 \u0394 3 nm" = "blue", "Green: 525 \u0394 20 nm" = "green", "Infrared: 850 \u0394 3 nm" = "infrared") ) ), # End Tab 1 # Tab 2: Plot Options Transmission tabPanel("Plot Options", tags$hr(), textInput("main", label = "Plot title", value = "Filter Combinations"), tags$hr(), sliderInput("range", "Wavelength range", min = 200, max = 1000, value = c(200, 1000)), checkboxInput(inputId = "legend", label = "Show legend", value = TRUE) ), # End Tab 2 # Tab 3: Export plots + datatable Transmission tabPanel("Export", tags$hr(), textInput( "filename", label = "Filename", value = "Enter filename..."), tags$hr(), fluidRow( column(6, numericInput( "widthInput", label = "Image width", value = 7 )), column(6, numericInput( "heightInput", label = "Image height", value = 7 ))), downloadButton("exportPlot", label = "Download plot as PDF"), tags$hr(), downloadButton("exportTable", label = "Download raw data as CSV") ) # End Tab 3 )), mainPanel(uiOutput(outputId = "warningtext"), plotOutput("filterPlot"), tableOutput("metadata") ) ) ), tabPanel("Optical Density", sidebarLayout( sidebarPanel( # tabs on sidebar Panel tabsetPanel(type = "pills", selected = "Data & Plot Options", # Tab 1: Data Optical Density tabPanel("Data & Plot Options", tags$hr(), selectInput("opticaldensity", label = "Select filters", choices = filters), tags$hr(), textInput("mainOD", label = "Plot title", value = "Filter"), sliderInput("rangeOD", "Wavelength range", min = 200, max = 1000, value = c(200, 1000)) ), # End Tab 1 # Tab 2: Plot Options Optical Density tabPanel("Export", tags$hr(), textInput( "filenameOD", label = "Filename", value = "Enter filename..."), fluidRow( column(width = 6, numericInput( "widthInputOD", label = "Image width", value = 7) ), column(width = 6, numericInput( "heightInputOD", label = "Image height", value = 7) ) ), downloadButton("exportPlotOD", label = "Download plot as PDF"), tags$hr(), downloadButton("exportTableOD", label = "Download raw data as CSV") ) ) ), mainPanel( uiOutput(outputId = "warningtextOD"), plotOutput("densityPlot") ) ) ), tabPanel("Advanced", fileInput("own_file", accept = "*.xlsx", label = "Upload individual filter data"), helpText("A '.xlsx' file containing one's individual filter data can be temporarily uploaded here."), helpText(strong("Note to keep the exact same data structure as in the template '.xlsx' file, which can be downloaded below.")), tags$hr(), downloadButton("MasterFile",label = "Download Filterdatabase", icon = "download"), br(), br(), helpText("The currently used '.xlsx' file of the app (template or individual) can be downloaded here.") ), tabPanel("About", h5("Authors"), p("Urs Tilmann Wolpert, Department of Geography, Justus-Liebig-University Giessen (Germany)"), p("Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France)"), h5("Contact"), p("urs.t.wolpert@geogr.uni-giessen.de"), tags$hr(), p("This application was developed in framework of an internship at the IRAMAT-CRP2A at the Université Bordeaux Montaigne, France."), p(strong("Due to legal restrictions the app itself comes without any filter data.")), br(), h5("License"), p("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, or any later version."), p("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", a("GNU General Public License", href = "https://github.com/LaikaNo2/Filter_app/blob/master/LICENSE"), "for more details."), p("The 'chooser.R' R-script and 'chooser-binding.js' Java Script used in this program are taken from the", a("shiny-example", href = "https://github.com/rstudio/shiny-examples"), "repository under the", a("MIT License", href = "https://github.com/rstudio/shiny-examples/blob/master/LICENSE"), ".") ) ) ) RLumShiny/inst/shiny/filter/server.R0000644000175100001440000002105113124170541017204 0ustar hornikusers## +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ## Title: Filter_app ## Authors: Urs Tilmann Wolpert, Department of Geography, Justus-Liebig-University Giessen ## Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) ## Contact: urs.t.wolpert@geogr.uni-giessen.de ## Date: Thu June 22 2017 ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ shinyServer(function(input, output, session) { #check for own set filter dataset output$filters <- renderUI({ if(!is.null(input$own_file)){ ##rename file in path file.rename( from = input$own_file$datapath, to = paste0(input$own_file$datapath,input$own_file$name)) ##set new datapath database_path <<- paste0(input$own_file$datapath,input$own_file$name) ##set new filter list ... and do not filter them, we have no idea filters <- readxl::excel_sheets(database_path) ##update input for optical density updateSelectInput(session, "opticaldensity", choices = filters) } ##create chooser output RLumShiny:::chooserInput("filterInput", "Filters available:", "Filters chosen:", filters, c(), multiple = TRUE, size = 5) }) # Transmission: Prepare data + plot output$filterPlot <- renderPlot({ if (length(input$filterInput$right) != 0) { data <- lapply(input$filterInput$right, function(x) { as.matrix(readxl::read_excel( path = database_path, sheet = x, skip = 14 )) }) filter.matrix <- plot_FilterCombinations(filters = data, xlim = input$range, main = input$main, legend = input$legend, legend.text = input$filterInput$right, interactive = FALSE) if(input$stimulationInput == "NA"){ NA} if(input$stimulationInput == "violett"){ rect(402, 0, 408, 1, col = "purple", lty = 0)} if(input$stimulationInput == "green"){ rect(505, 0, 545, 1, col = "green", lty = 0)} if(input$stimulationInput == "blue"){ rect(455, 0, 462, 1, col = "blue", lty = 0)} if(input$stimulationInput == "infrared"){ rect(847, 0, 853, 1, col = "red", lty = 0)} } }) # Optical Density: Prepare data + plot output$densityPlot <- renderPlot({ data <- as.matrix(readxl::read_excel( path = database_path, sheet = input$opticaldensity, skip = 14 )) data[is.na(data[,3]),3] <- max(data[,3],na.rm = TRUE) plot(data[,c(1,3)], type = "l", xlim = input$rangeOD, xlab = "Wavelength [nm]", ylab = "Optical Density [a. u.]", main = input$mainOD) }) # Metadata output$metadata <- renderTable({ if (length(input$filterInput$right) != 0) { data <- lapply(input$filterInput$right, function(x) { data <- as.data.frame(t(readxl::read_excel( path = database_path, sheet = x, col_names = FALSE, n_max = 7)), stringsAsFactors = FALSE) ##change column names & remove unwanted characters colnames(data) <- gsub(pattern = ":", replacement = "", x = as.character(data[1,]), fixed = TRUE) ##remove first row data <- data[-1,] ##remove NA values data <- data[!sapply(data[,1],is.na),] ##remove row with "BACK to Filterlist" data <- data[!grepl(pattern = "Back to Filterlist", x = data[,1]), ] }) data.table::rbindlist(data) } }) # Transmission: plot download output$exportPlot <- downloadHandler( filename = function() { paste(input$filename, ".pdf", sep = "") }, content = function(file) { pdf(file, width = input$widthInput, height = input$heightInput, paper = "special") if (length(input$filterInput$right) != 0) { data <- lapply(input$filterInput$right, function(x) { as.matrix(readxl::read_excel( path = database_path, sheet = x, skip = 14)) }) plot_FilterCombinations(filters = data, d = input$thicknessInput, P = input$reflectionInput, xlim = input$range, main = input$main, legend = input$legend, legend.text = input$filterInput$right, interactive = FALSE) if(input$stimulationInput == "NA"){ NA} if(input$stimulationInput == "violett"){ rect(402, 0, 408, 1, col = "purple", lty = 0)} if(input$stimulationInput == "green"){ rect(505, 0, 545, 1, col = "green", lty = 0)} if(input$stimulationInput == "blue"){ rect(455, 0, 462, 1, col = "blue", lty = 0)} if(input$stimulationInput == "infrared"){ rect(847, 0, 853, 1, col = "red", lty = 0)} } dev.off() } ) # Transmission: data-table download output$exportTable <- downloadHandler( filename = function(){ paste(input$filename, ".csv", sep = "") }, content = function(file) { if (length(input$filterInput$right) != 0) { data <- lapply(input$filterInput$right, function(x) { as.matrix(readxl::read_excel( path = database_path, sheet = x, skip = 14 )) }) filter.matrix <- plot_FilterCombinations(filters = data, xlim = input$range, main = input$main, legend = input$legend, legend.text = input$filterInput$right, interactive = FALSE) write.csv(filter.matrix$filter_matrix, file) } } ) # Optical Density: plot download output$exportPlotOD <- downloadHandler( filename = function() { paste(input$filenameOD, ".pdf", sep = "") }, content = function(file) { pdf(file, width = input$widthInputOD, height = input$heightInputOD, paper = "special") data <- as.matrix(readxl::read_excel( path = database_path, sheet = input$opticaldensity, skip = 14 )) data[is.na(data[,3]),3] <- max(data[,3],na.rm = TRUE) plot(data[,c(1,3)], type = "l", xlim = input$rangeOD, xlab = "Wavelength [nm]", ylab = "Optical Density [a. u.]", main = input$mainOD) dev.off() } ) # Optical Density: data table download output$exportTableOD <- downloadHandler( filename = function(){ paste(input$filenameOD, ".csv", sep = "") }, content = function(file) { data <- as.matrix(readxl::read_excel( path = database_path, sheet = input$opticaldensity, skip = 14 )) write.csv(data, file) } ) # Download Filterdatabase Master File output$MasterFile <- downloadHandler( filename = "Filterdatabase.xlsx", content = function(file){ file.copy(database_path, file) }) ##set warning for template data ##Transmission Tab output$warningtext <- renderUI({ if(is.null(input$own_file)){ if (grepl(pattern = "template", x = database_path, fixed = TRUE)){ div( "Attention: Template data set. No real filter data!", style = "color:red; font-size:15px", align = "center" ) } }else{ div(paste0("Using custom filter database: ", basename(database_path)), align = "center") } }) ##Optical Density Tab output$warningtextOD <- renderUI({ if(is.null(input$own_file)){ if (grepl(pattern = "template", x = database_path, fixed = TRUE)){ div( "Attention: Template data set. No real filter data!", style = "color:red; font-size:15px", align = "center" ) } }else{ div(paste0("Using custom filter database: ", basename(database_path)), align = "center") } }) } ) RLumShiny/inst/shiny/filter/template/0000755000175100001440000000000013122176270017372 5ustar hornikusersRLumShiny/inst/shiny/filter/template/template.xlsx0000644000175100001440000014250613122176270022135 0ustar hornikusersPK!zu [Content_Types].xml (̔]K0Cɭ&Ⱥ]Lԁt-K{} R7 z$}| & ih4hX<{KA#K&ۉW΄s")_%9dT`Y9! [ vu5RL/& ŇH -JrYd<%@u۬s񏓑Ǧ1H(|&pG<~/?(s0l4`0r.<%EߵOpH夤'&t;zjSGBCj{GJËW M*P-< PK!U0#L _rels/.rels (MO0 HݐBKwAH!T~I$ݿ'TG~PK!ࢾxl/workbook.xmlTێ0}@~gBl.mm^+ئi{(lW x93LռQ n\dQAd!A_WY`B 3INʣB'(7;&9XȒ KűP]*3Sjx;3:z  I*N@-:g8y X6+9d>𮀲k/a3{sPNGEx^Wtg}dpY~¼@VYf,A1D}PUy[v0]L/Vl{V6t.~ \֖~{tOLx7V-6}L^ &G|:Us9eB,%hSCy NJiƿF$hwN>~`lB~d"?GPv 8B(wۦCaՅ<m|60{͸ jyMY VAZ]r9p\|=C QVj ȃD R)}6i3%` ,ڷ^8bގ` <9ی#gԏX/3UaqQ ψF~GEK};W~}? Q^'ġ5o3xH^X`Z jN_'PK!xl/theme/theme1.xmlYn6wtZ%l[hnmZbCH'5{a7v؞=)"cO tb 9wӔ:8e=qs؜dq}8:戲 5?DS@< 8o Hk9)7=/d[, ׆8s7G3JبD5h#s9u(>\OÛutPVbO]X j3F}?־PG(S4AO .v3K*-aa5@ x ` i_ |o{6+PBIvmz,mwn+d6d }',@)$szhi!J9qI@-Q8{MoIE`Ֆ )|>R/A#&2+[UFQ5^?}ϯ_|_4zugeojz[/Mu;w9K4J\(VO I$5'˭#<BP;nc=0pqT'g+"-aaPϘc,*V;a|ɶ56/ܓʽ`[{ QvښWX7dw!5fhYH77P=] 4 &[WmT`R~x.Tl+sLg 6PE+]join& - 4ev&nRtf4T4ڝk)"fR̹a+CZ1]BpE4Sȋ>ʲ̹"WSAJJҞ+) QMO\dS#A7 <zص WU&[AO3 9p(9'p*.ML*rD *g] -Vi,'u4ѬLCUiӏ7kI`UH6JDW̺o1!hԪ j K.KMj׸ <vz}g~w9kYWW7> B 79E_q~\ \#“I}}?jQZ'j h5FAabIۖ1Buyw]9ۍKLݫquhZ]Wq,l u[q:nj0j(t]\~+Q6懞~?/1B>J_{PK!P5A^xl/worksheets/sheet2.xmlY\G ;|XwKH ْg`l^_-bHQ&۷d]"2#ɬFb%ndFN~O_>}~wgO~_{?>?o?_<}_ŋo}O7|?7?>_o~ۧ?~|O}7_xϿvov|?-/H7}ۗ>~zn|vw??{珿|pe^_/ ٟ}zܽ_ϻ}>gϯc_˟~SOo>?˯LfO/ݟ¿.ħy?-.GgiN)=m23ٟ>ۿ|m77 ƹA7\n`|܀?2x1IE=ןᓢ˛oXU^v|ek6*ԍ;̼Ѝ߽+/_f.K^3tiQovч<;79}8eG=ǼOc^/J>^iqtz}1jx%F4eynx/DZ][\10B.MOhn̺>nܹ?Ɯ"wk&n֓tu<2WA}ARqtaڴ#Ilp/]?s\j7t0¯w{w/~.p 4,0K$y>8I1nuR L]hD^zZ$PRo>=B^w7fw `/òƱqYVoۮu5ڨmNx"fxw]A7/]D)qm^0,u-4ȴv۵[5|>]2"]LkU6 uv)md!2M"yqzHpFAݮiXV3ꤓŒ]A~ x[Ɠ ⊚LmYi]_L{1Jz2M־1on lx_W|Y}t](+3 <P|^5?44$ ;Ⱥ2nûº=r*Ӹ,V:Dzhi enPǛf;.iu,/˕_YBL]F9^044aP / L5Xt̫\{  FGo _y[a=`2am&q,C,,X4nP' /@+zt}W<|hiIOeiwA3kg`SlA;6v=*wleLq<<Ҍc" YUVbɬ*Za zCaYI(qMaa%"d͖BAeԱ8LSwcsn3@ ,A@x˺^o ;uXkMHC*M!62-#(m@L&0NAV%!uf4Vܙn~PoSTmrEU~A1غ^)qM`a1d :lve 3|qT 8#XNP&02My@Lft`OaB?-%ݍ;1 ,ѧU:d->mMuƵP6zx/5tM(aу(; Iv8Fc*:^ y:BXHAMxaz̙3 W5uíQa؄Ӥ_hs}× n.f\EN/PBm$!my<.qt +f0W:Y&0ٌ:\a/9;&']#⊚="_uj iIK$K&Wʎ[ w8ڍ`4Q4>Mg!6KI @P !Ll6&@0وJ6''Lp[q2mŎe6@Mx`rQ~6 d%&G,;Jx9ЄXM >Rϲ{ji %3gggƘԘ&DFd/$h` Na7zXT{SnniVS6dv83(3 J  \hlnδ&0;0;m[4;mi9,{Ԡ`|Q@F"s Hzn6_idMYؔhAOu4"&bfK'L^'=T쒹f`M=F5_PU杛`@}R9n,^\F eժՑs!Lx4AA ,ރ&bT{=}hO44X.u&>pa?jSOz *éڹ&0;p?~3I,oԃ[S!UDG MQ;b/6s36+>ܷ*J]Al`R&LFdp AS.x9\Qq v[AmCqL c8B\Uad<5kM`q`P2r-77:-7Dt$S:ljy d44 *7one- UWTebc-?; M@^uPxMopb{̺48a8_UDݖ&Fzb\J| v AuxqEUO`uK55v1 f&U"~w` anLTD&F>P~\hRCܹ(*|K:H0#70sDNp<~/Te"79E3V!>DV{7䢙s)!pJz哎+2:=9K6~nMx!62ag 2y3熃LUKY$C {-+ĘWmB+OD(ĭ CFN|:nJ2 *ԋLez E[H$Z<A\u%K8tʂݝzc1ݚD}W]۲#-H%?~o+j(R"9&Qքh#Hy/a9;|-dMzԵ4asX(Xq 9F&hk9XbOj3 RS92)N-@.ݚCmdR/> \+BCq<ք$@+TW@O죍 @,"&*&d IYns?Te¥ VٮMq4Pe'G,QcQʹ* Jls\,}ȮM!> 3DJVe_a] kP]E+YTB)m]HÍ8 r)qqC ;'E F"XEmqbxB˖Q.ġ{s q$2>Mq63e~{#kHy|x@zPkŀ"rϑ1C~L\UfߎفR x 2q;rF6 -l@䠍F_AJj $>j@r-R ќpd|В2nh)`oR)r[fjQÖ Zjq "SMZ@cgDo G@mĪAĂR=T.Sj"G=:Z1n7M3%'ǶuF3Y*®:q_$G>9ͻHǎGTΕShI7L2* N/J A;mgq?4ҨJ ׈@մXE=/>К'@ĩBsKG $%(&]*AN-KR 8EH|uI%p I ,"l4o('vXupEᢺ0n#J'n hI,*(Zj v@=s 冏qd !̆maCrhRSebyeBAQKu0PDjjC M;hAjr-QtX8u82j=4XRFI= rv<'WB$m_}j*掄FDAmbټbP"vQb\ v& zJEnJ Eʑ|t#]++Ti2KgKqfBjT}0M$QRˊEI Y =' #Y6Aڐ" {ysH:3^b-xP:|P%)0Z_cmlެeD,qREXҽzy1 l8J5 feΎ4$)Zʰ4q<lGwYKH]L Z}<@gJ(m؎ bƑ4.8Jit ?|@yN*9JcCp^0 Cthg)@~p>_1fq7UlCaI`Ȉ˽?̮:YBi1EkLE]O6І}~A6C`xҁЅdY2=! &5` T$NʰG":Cۮ5y@B"D+(h,E/3x%-ħ.eM6 cӦk C>B{2qP" !/~ EKBWLHjRbmMX.A%VFܸ$>@`0%8Z` lNj7 3*\)Ct.Hن.=(X cSXAJ)֐8b)"%j-M2aǩ$١FFvK$la#9I(0xv*uJNoj-o 7H!=;^b)!PŮ-ڡ ϑ%ԩQX^gώG,xD{Uk"TS@h) 8GD rFJ[x@񣴇XvQ$ mAUdc, EXIE A4tm?MFE$ rSKUWp6C :EZy>Ն*GeϹ)~YbێWt40$[<FR ! GGZo3U@BJ9TJkyL,Rf71eʓXӉu" U8Jґ)YYB;Єw>|mC*k'TJ$&K+KޛS/sxY"~WT=D8AFH}%vmōBQ&P5z ="6m9t:_$p0$?B #XB- ^ -6ph,{1A x$ eVi,K-F5C@dXr0 ñWUD-3YRGXXRM eIYR"@f  + .sZb-' I*Lm>^oJaGO#0`$vDO9>>Gi78*8#egI. jBt* Zjr@ʆώGYeuIeRCYbߤ΂dˋ@E%;tD%/0;RSxߞTspєBqa1E"l6d+Y7I5V*S[E |biu얈 BEy;mSìT%WG"(eA@pO낺XxS4NbuImڶҁ=D +Hb5imk]P\A$X683G݉|;'$'=C9ec1)M*[8Ӂ:JgYlh{SJ{TՃS4e@&mqf" FkIG%J{4|>T]阎k#ϤlEf,vxLBdL㸲 Ö3Os6@ A\LDy&uvV,hމϟ,Q"oz7Uihe32$H4 "0'"uD:P wEQcEۮkSL>:O!zp:ئ1 2 7L8nF x 䘴A"6U{3i]&&ǨI[$s<~,kfxkg>uGrC{u;m$tymԉxώI܂-[2+aX@`#) ;:DPLfx3i1ib'S0_$4e^z.9z&xuR%E 2=I,\䢍hmdH<=&>8b zyZ)'`"UQcvb ;^ԧ NE2?I,/.׫1$PwP܀MQ T' ESUcRif6Gk-Fx2GN*;_aRXX<0"&GyJän"l0N@küdk"Flᡤ|}NQb!NmZj$+mw} de n^r (e"҂EM*lXmpei$闥8<_&s%g}/$.H֑ƗIOE6T3 3z2ڽS_&|,)(F7M"wYSQ[ɄD k$yxL*ˈp3D12UC0C)M+Y e^]0>Ï5VG&[ݢ OہA`mV&+'ix6RM+YTXx F,6b M5l+V`ljQ,Jhǃ)Ђq=fLkL'IF&ηX]3c"QBLIQNq,}֜8K &@ZS5:J,)SkQMGB|`mPÑkNNG<9䚊~1̚pAfA\VmPk"hP4z^M @d AaTRVS&\/vq'U@5X x:P82*?qFUFְ\9w '% ;&zWa㱸p'`++h4Wkfs@^ʧ+ Ne(PKjDL悵pDSU5 stDfh!Ni!VmL% <&it~>(Pf!T@ uQŊjd/)L<Ŧjx(3L $Q1m$|[/Ԝ~YXޓl I6wƴ,V4p< ڞ\0 ? Ou>тIQXwXC`"i52MuٶTQ}ɗDuWΤm~w. o=& t<~'Y=I) ki8Mҡo8d4ePшU`uȟ`I+ ˞)E)IM5Ӑ< p%iMҡ3d6`6Gf.JxMU^sK#? jP!Y+yJ``p42X0ogYF-Qv㱂to7 ֘(-v,Z(ٷsqJR?e^DGW44"JeB`MTc- ڏn4'P3X)O7<`DF#(e;MSs&/rS3=wﮢk@ZN|gm{W xW>xٶ֬@JPYU( 4P`fE,EƧYE4M\ <&,Pͫ*˥ 5OzT{M$ x F`Gd6v =>`.:'M0}.iP4VL 1[1q~ewYcxdB4^5A%uPIS7&AK=)֘t1 /|D}d@F4+1h0/6> $kNiwP2 @^5C-d6MB7^"23adx9:)2;>^}d }K 5quf|SM0豪9v߂T^{DCS݉.mϬasOb.1<ʸ&k(9gh婍IuYzJN w^l_.Sr!R VJ;[`i,耹dSQ7.xujkX&o_csZ5JAڳt2(dE^Js2B]nUůlk 98>ycEH2Uɖ|#Jaĥ٠"1~YSuLU;[Y߹& 3$@G nE6:{0{WyQQMNv B֐ jq5n*/*a G9ӝr"BO׉D[uEEVӸwo/_toֽ{ٺ?*qC5O31n6LUWxЗ^ГfT! B"[άڎphT4[Y0SzNh s.) a jH=;X3IPJ$Vԓ-3*G^΅<8Zg[QŠдQ;Vυ㉐Sҳz|@Iˬ'D< %"]ۤ!8~s"3# V&U-5f?:Z&͘ B1&?i{R8(xT: L;Gem4$=)'{b@wԈ%o+{e:ϓ<*p (hS0)xx'dyC6|:xxbjR$nƅr*)=;^6|yhIǮ AyD Rn.MHn,ybi;?kw$q\U`(|C$UP0`zXH Avl邔jf'Nf<ɬw .Y Xא xf Ȅd)|Ú'Jl4ꗭ*r DcN̊k RiYk8Sėo+\^/窊{ {_~ƬpIhwȁ}7m m.NSU ѵ.0aWbyn'݄6An<ֹ{NY5?.'"H#,К÷;UtUNOE5sUd@DbPx3;|k037Ux/MSíp|S$ódY#4j&ȜWŸ^3N !\-4'#wX2k--ѩw2+R.Θ^,g:6tF̌T ִ;SF0ԳYgnm)ff@ۛJlm _;;h=;7Mj ='SmZydOs _w+:?!wfza1!nmZz'2@PfVj_>( (ѬsXR)j v ɱMCsu(殃5VY5-fsec. Cl™ th"J™Q7z]N܁=s.9A>cVhiL~뙫s%#ҡN&}E/žNˈѨ\6U q NxaTf]^#ˍPe'RYSDˇh$!0to FtB̒ !f7L!ڵ,АBK VD8=ƅz} AZc.yl_mꢩ|GoMVoUfLn}"1 ?B/"ot_TbMӵݚE^߼V뙕s͸ ;scB!Y&7=YΟPe7Ӧ8|6q ۀZJ LE7m H q-ϩu|4Y-`X,e[ǧW/ޝ4"l: EUOMZfѤCƌ\o0K*#<u5Mlު;%5x^l )x?p*'&i6UzrWImӕ2x- {ޣ iUl:G!Dx5r W&ɦ_^hSY3*C\_8zxs҉~=65k=Mr5q%#z)5yS4QUr~?/^`V"53q]pC_gcӂ1.":i{7h\=JYbFգ0v 5}M0vÃw]Hx` TP)n] f5*>z4yV":UM.vvqt45W] V,ܜKeAa mXsG׭g2RaY7]KgكG[%٭@L=]=^>fIVyCg֥aaj+|kG)Ͽ_[3W5ܮws^[䅦[Ez oe{W0͗v4Y6r 7YrYxjNZ8 mB{*kt mϽ5#S=U7sp x)ha.V#v:L\f5S Gj½ vK &s7֖ΰd喞o m{Rv f{[^E%{7XkYc'mQK߼7,ZoO0vosIZ 7V|q֤7p2o>fIピ\z0+#NXPS~e7#|Ե=5HDv0Q;V#%TfNvYZp'לamN镺9k8dN >`L,]HUO| A0m?Wg"Ykʨ#x=U|3?.dT"u^h3v U7;sG vE- g E'+;(_"9zKNUez5+¶9<șV (1&" .)2k =l:G,j|^AE NdCM>D=URD s/NO󁞻K^^O\Gsߔj y9tVȊQӵt8**84Y.TnMC[R TlB'sN,<#\KOk2ߩXC /sc#"Ã6zny:lQN8F;յGݍ9ZX-kvXk> _nS3'O\\.%Wjt%)ߕ:Lfv' MDZg`\&{ZM˳͝V!J0]pϏf}>H& OC'*Mup(pUVX:{,".PjD5oP;m$f9W f ^g9j=RUt*=L,sxE+X"L.syhWesMRnwJRꉽku+L>n; S6 t+Zej{[Ҏ SW\rM&ݷR5J\ظV†] +T?msp zL]orKt[~5ʇ庽\I>pYTn.Xy=zKu)V~^^U׮OR\Ƒ.\0+ hh ݯ}X-ۛNppub%q3 ҳl0YC S+GN֮<7JȾFܕn .tJ O[":F!DëNGNMۇS?kVyRfSy+UfweCnPy<=<]tPh'c,s] TSv3VN0D~cѱhOkJ S bp_+U┱ ._B@֎U]i[~()zЮ)Z^CgV3d[Gv.ZSTIw9Dv ]8.9!x%&wZFk5zk" !J#x*aG f{KmڕC/䠜*>z#GXaqcQʬ"D/${7Rx^R~k.^ƂnI]ӡp{bN mѳ0!*KWCrd?yNrpnSSQfd<ZӢ4eC(^uZ:c2دBj] EZ2k-jKY@q({s׮G$mtΊt3e 51KXc~UV22{#uFi@BSeMk{ i {?.✝6=xZzF%ѵŵkX0Hꀮ#ZJ78]m˯RF]h3'Mw%v؆X/Sr$7/';KRꅈ@z[vMaWH4}*IJ.Ք1bgOUh+ux@暕]q3#F, PõQs8E ~LOR"e+`QI?IeDz7'[N+\CJ%گ5JR*K <\eѭ]ONO]@C& LgɕMkro4 ؕN-1p=:GѨwaP 6j-ъY 59EҮ2j0)Pj|H2k `1Vv}fM~`hDt]ٵ&kj/b층שÐn=ժ$&b.lyl׽^ GCiZIBdCYkׇ̿\{*Gvp2lTuO5eKj_ ;<^Cm]8;OŎsgncmyNA¬Kj[ZDv5`\0GJ/(+gT5eK(m2I]6Y4BdiwmyolX֤-ޮm6 p]o~ Zgq\rKa,.rDוM#]ږpBE~> 6J5ViMRº߯Np]p8{q.QlT. [W\k*~.BfTnY,Ou3jT!aWHQ!z8nYo̫ʭ][0lD ~]2߯;kɹ g\rHXN93jcٶj+(yfј.dB?6ͅ.wsb;ݥ*[;BUwеhD :~kɋVRQ؞_^-#sPcE'Yfe1phG>XMׄb̎s~Oy%eLX#ab#OCQɈ]t׮ QKd ):~2heԠ0ZҞk$:3 C0NՓk7I-xFg8!ު\OO3vav_!U|`']Gʖ]o{t>pwӞüv:\4LVVZX@FBZX6w/seU8 gRkՁ 2SNPbs%fL >7Pa^пfO"$".Y_>8$(B1f}i0,O\V25: !Wh5S.cV&~:puc|&kvgqӣWttԦMr}4u*إEoW-eW75T<#XAIJv I ("'d\P<޺A#F:[󝮯u=^MIh~ϪB_mڡDyGo:>_zovMSљ] R *aͮf9G4լe4R  )R(st..L6Gz/dkkf\r>'"ieh.'RM7Z?JUD2s]sݬ41N0b)?p*vJ]Q5v=}<^b/iC엫*(KW+`p-OC|O}g~]dMȜd`ThpS\p ܎ñkK ^NO9Psh,yMTkAn@z[;Gޣ5DJXƖ %=fRnvŹ$&B}!(v[zZXɐxt}7tf7sݚD"-˚%^tIŶw$-=B5D uDT5Ktp ׮O1Ua?6%QėAK+Ms׵3ץ(hcґdE;o&]/n0ur*XɾۊTGЀ1gHp x^5Wr_Nqb5Az1{4, "Rbc1k@U1I1 j9D$C#o (zƮRa*]49ң%u@=/_ i>pԮ3HrqT}o?Oo~o|˧?|D>:?~vo?|?~}w?_Փӻͻ_׻~o˻?|͟Ӈ'?{)S;೺?2~y/?~7뛟o?oo~ϟ>\߯7y[W/91᷿mPK!/?-xl/worksheets/sheet3.xml[sIe>a\1d  @wO{A:җ_ݾg/on?^=cw_ۻ_?v'}|x/Vp{/w>ݜgg^v?^i!mnws`?^[tu>]?_~buN>]ϟo.xym퇇綹$ӋS/a?}x/݋uq<~͍=Lv`t{fw7+Ko?oݑNwϻ.wooovz~כu]NϗɆG?~_١15Ϲ?O>]9fC{߿V=iwڷOyzl c؀;oaϏ;viwUf{үEg,IzdkGՎo/%;\v_f'o/^=u}]%ݲOڟoth[z8oƧ~S5d=]\; ږ.OkV%ȵsk?%o7D7'{M;2_l2:#H{mv?xp9y'xLzN8XoqQ.׫Mq[o+m0?䕞i7iGV}IRao}tg;}o_~?NT>8v}gHoیֳ|۽vox_/I/&ߗ~tNIO:O'v[!.hu~Ng䖳(l~MERH]fWWC;H]OR0~S%)n-eW=Ձ"ݖ"}"x>~K kۂ:NbEV<ʒ?@ꂬ%Vi춬@Y1H-+Pت󭗾"zdvRe .ȊAbmY bXak'u4+·:+۲ +v-+P uix4+( +vRe .ȊAbm( +vRe .ȊQbmYVo=rG%VIݖ( +FvRe .ȊQbmY bXak'uD<;#XoY] [{a# .ȊQbmY bXak'u[V@ꂬ%VIݖ( +&vRe [u5;I-+P uAVL+ln H] [;۲Rd$N궬@Y1I: ʷ*$VL`Ÿe 4vAVL+lu-+P uAVk?s-+P uAVL+ln H] [;۲:z䪘%VIݖ( +fvRe .ȊYbmY bXak'u[V@ꂬ%VIݖ( +fnڲRd,N궬@Y1K-+P uAV+ln H] [;۲:z [;۲Rd"N궬@YH-+P uAV,+ln H]>mn H] [{U7oY bXak'uR\%)z"b+-+P bXak۲RdIݖ(l#G\bmYb}Uym>Vl_;z;\"oIiCyIlnKHN"9H2oICI$9I-IP u{Hr:$ ɲ% nIR'$Y$A!A$$˖$(=$9HDsdْR$fzGY$Aaη^#A$\$˖$(=I+-+P uAV\HӑݲRdŅ [;۲RduIݖ( +.$Vګ-+P uAV\H-+P uAV\H-+P uAV\H-+P uAVtg,||l;;'[b + 2;'[j + r;'[r + ;'[z + ;'[ + 2; ⫯ /VHw&WO + ;`'CyҝI@ՓB Lph'TH ĔNcSPaQtSl +2C \SlCFiLSPaQ|8?;g[=)$ L1~Ĕ(SD816S,(pFLA0PPĔጘR3#":L}4ĔQ|A({R0gĔYjLS3b *tB)gĔiAS`Έ)xg˃ y ,1by lǻܗP*>}yPw#/*ԘS*fνf'`8b(OjLu|)SyjL}|)cyB)1>wAC+`#_U <8S`%:bJd޹=v5N>ϼ}yPXʇ)y^jL|iR1wg)ԘkS*=!|iR1' 5b>a]-} zaNfYק&1bZ_wP;OS1a Tc 5> Ĝyso|Hf_`SbN*Ԙ0 Ĝs|Lxڇ1{*¾>}yp y ,yۻݗjL}9y1Va$TL{C 5{;0S*FwDPXڇR1wڇR1w)Ԙk0S*=1S`oFbJ޹>Pc ,HL;jL} {W1B)S*&=1Ԙ0S*F}1S`y&bJ ߹>Pw1bOjL})S|jL})c|B)1b{S16xk6Q1w)Ԙ+0S*&=1S`'U{_}UH>\aAWO bg v%[ a)Փ-SrVOk h7'Z{͇﫧S;'WO 9Bim?\s*>|Dac(cz n􏍡l~ T|Bim?\s*>|DP4ɇ+g76U>{4GΧ8/dix+|}uG2JITBߏ30NR)N#H\)#T;q'{yTJ ڤL}6:ZHHH> R}B$G_SR56?~TCA }6dTV!>; R}VBv_ڈVn?𨮕R5Z!`> 6( ZQB Rc "9 <@ ZQ@B Rʃ ;PڈVhH(2ϑ hTЊPڈVqH(D! h)L)M!W Z?z *FUsZi!URFW77Ҩ6 ( ZQB J˩⭅ߙ{E8r2SW<0AS@3Jds"CO)lLo*R5!ah>G3ivTfHb) E!UF kQ)]vE!UFJmsjCaT4;BF34"tZCrrp!D!UbF tsZi!UFJvsCAjfGF39爇0RC R3"aЇ>>63(R1>?64(R1>@65(R1<>A66(R1`>C6#!b\)jLhQ=!Fȕ[}##eF93ObT5Z!"b>G6"#+b\)hi ''8¨6>(RA+ʕsDAj#Zy">L6A(RA+JsDAj#Zy""ȉ>GNYjȣ\;@֕W #PʏRTVuJiṰO6xRx F -WO++QmC+ܫ*hu5 jچVW ZQbo& &FWjRʚjRAmo& &؆YjRJKpuJ~ k \)Im3ƿ r,|C`UV)Z W6O%: Zd >bT5Z!b k.\F iT&ʺ.Uhe]XSUDYR4ETH4Qօj#ZYx$51i k@\ڈVZօ @f]4XD2H(ZFu e]XoFs+F51i kR\ڈVQ!IM(ºW6[YD$51i k[\ڈVQ!I(W6ETHRA+ʺFUhe]Xt_\)uLF+$ZLuaڈVZօu*ƨP)j9B1hв.|uLu+%VZօ.TzJIj#ZiYRI *%he]X7cH*%he]X[cH'6uxe]JIj#ZiYRI *%D~m[ O4\6_o~8,0|C/kh6ZcM*^I-LeaXd D3T 'H9  YeaXڨ'a]1D3TJZͽx1Q5VjfGH^H( :,WivTm,0rUjfGH^˜( z.WivTm,0rUjquTVH( ú0W!U/&°vUheaXt_,\)WYjYֆRwjFLZYHeaX VZHhċ0esUj#ZiY֡'ͽY3-FU/&°&QmD+- z6Q,\)J°͐JsjFL@/&°, kQ0Y3 FU°ΐJs+T j9 Ca !hUHi1x1QPHR5Z!b, k]J eaXWFs+- Ú@\',ͭx1Qj#ZiY:*eaJfhneaXhHwY3-Nmnċ0th4Ҳ0c4FhJ(gaҲ0u4Y3 Nؗu/ ˫awl}Ξ?_ܽz! $>BF+$^LamkZi!U-&ʺ~Uhee]XFs+bnEYց*,B ZQօJmD+Vua=Rͭ,Be]XsFҲ.uREhUκieAʨ"b kW]rR-&ʺU~ iTe]XFO-B'u1T.RX k\ˊVլR5Z!bu*-jBDYC5"UZHhD.jE e] լTi U˺u1QEhUκe] Ⱥ("WJR !U-&ʺYhD.jE Ye] NFs+-b@DYRhne]XVʺȕFs+-š`C*nUͺHiqjBDY'%p e]X6sϬ|Vʺ>WS%>Zj''RJJG5CokVoڟ''KB>ZClM*^I-ν*gپ+H#JO 6n^RZRNR) #WJR4;B4ِY!UφZRZ|RxTf?RoaJIjfT- gCw\)H-ga!U0 *%ŹR5Z!b, ]C@9 x1Qu֮JmD+- g\%ZU0g| ᡦφTU5 #}TVH) :ko_^~j֗O;ٟ~/3Aj b 56!b ]Qh;)ԐX/}vE P˹ثHs.GwS!3[Xz~FLdW̔ja=+ m1nY1SƮ(js"$U̔aa+ m1\P1St5®(jLA.L0-š[ UmL)5|VeI(_r>1S,5(S4 `1$4Q-WC!MjP;)Ԙ'o9{0-rTc ce4aݩf.9i0-`šRC!MXr)2E˕^I!J (S8 kA 0-IFDXi($Rea pRe a}3! };4(\FLQc Qh #r枘 Ha) !Bc~ QXLL.];<a3;UI) SO6` Y}Cw;S௟/)yOcef&zĔl'Q & _Qh> n| L1{4 짊ޗ)p/䳟*>{_S' }>C~y/\)p/ |)Ԙ7B>{[Qe1LXg?U|{k[9Q=^:i6~}yp y | 쭥ne L|S)f_ۗ泷6PH?Q|kT'헞R'bc' }mfA>\aQh> n| L| sFbyeB>Pc m)n])S_ȇok+ L|֛6]>L| sF-Ɛ )?軍ß_ȇ+0+wO/]˚(L1tߗPc l)nemB>|-[Qe÷ƱZ&~yeß_FbJŇe͇?mOjL~!TB ߗjL~!TBmB>|k[B)p/䳷Q=^ 짊ޗPc 짊ޗjϾ_g?U|{kZQe%:VF-kې>Wne1ij/[F +Ɛ~OA0g?g>WH>AL|| sF*6%WXa)fW[;qYO/(S472o"8S_g?U|{_S' ]|1EO/Veg+0+L~!Ty/ob'/O| sxs.y?Q[STXPc| jk,S1n )jTO/O/)ƤW_ϕ핲 rZcRM!5>*[JƬ)p;=9ZƤ7|Py cS(=>ocd5&L!o|ce ]|m4 B>\a{1)ԘB>o(S*>|DP/*ԘB>|en뗟vw?nnOnloR_>?n?rl퓛۫ˇϯ/?_x_ Ďm]M4;&zΛ˫_NnO]>/ PK!° 9xl/worksheets/sheet1.xml[rH}߈yhB؞h[6`cnl EOVU e6ҍRJCA]}|Ͷ"__uIb|NQ֏eή?u-~.^Puq})͸//jVMwjVҟ~fG7h''l!1@o`؋0$+D=*]7ľWYVqʍ^h7ɬ]_noHb3g4hW&fˎh^uc҉&V̜)7L!%vHSn($ (vEAHSʩʙ|jO Z8g^s Ua٨aN[@Dr`&1{'҅2D].mU,or`DKӯX-j<gn1+~f?d0e.`DG n;ް{ީk{b)ދJZQ23{q?_h~{Jȅk!F KbWUph=!Op|7;A~D'ȿMI=.OX:8AV #qhl;A&x܆@[]x灺-{tc_݄jWm= j= 1V}F6H< H= S`Ȼ[ := :RCXEU jC jC :dL=U[vQT݌I3"jgDHʈ(8SFh>p#oM/Έ뎓0G 9R'Y1aJqpS4Hh{NL؅5@F~#r Hq!gʜZq/@eueN*F?k#I *{ZE2AV|gTϝaD8 si%\}Hq!gʜZu~0"k);$̒cN\#Ry̑c`xl _ԊsQF^}cl`#{@i@]aHE@D3< #E%@i nV`}|&#d? (Zc#`7a`ߏ9R};q+E9Rc {HSaHJƭBEK9R0̑{}( &ֱ `HhA+EQXBH 2G<H>O8x'AKf! #Ȓx SF;#iPBI!IE `9R.Bׁ&d' 8CEo1$E CH`ð -E Cd ͿЫ~N|6.B)BFA'=5{#<BFA:n] p ! 0&gzJ2  k!@)BFA:FX+qPQ |2~5į2 72y7J2 O72G!@FA:-wD@ q=qi "d38''""d3{^1 2 R x@;"B)BFA:#66DtuC<$#~xHG2 "d! `3a3D(H'P7C^8^QN$p_"d[! `';D(H'pT'a'D(E(H%pzT'tl J2  O""d8b'D(E(H'pT'Ys$,RgmQ3ϿSC4 * p⟢1@q'јޯ˽|ɶ3۽p2}Wݟ2vcbOf9A[ a zX46y.:ɝqNz7=t녎=fT;HyPK!Nxl/sharedStrings.xml|ώ0Hȧrئ]UIV,mY u8q-w$މw!x8ps7nz֎ 1O )մ/8BYI j QPϲUVH윷2Oϸ(\!kef&5 ╀Mo(seʥ6=I0?˳PYK 5v:58rRUҎˋ&?~:JkBfTwYX#ͿVoHD Qhq-U8f(ܠ1q#`TͬΥࠛhkjvRƣO7eL#)I_4 R3}["x-켳d_?jnU:hu:px3_|ꓫ/_)X==~{l-PK! C{ xl/styles.xmlY[o8~_ir BFH#ͮFjWWLjN2{lp&mƗϱ_69pYVD}a.bFkGE(+poq۴[o0lQT~jbUrsT].KqKZXSӱ,)zI $Gze$,_!N{ZL- VEQ'ȡg$)Y2~,Hc DIl{NgZNMlWZtD8/"@&z=k6~iˆi(+5Zm1R3.% naNʧe αNy䞗Gg{ֺK :)w <~x/\."=-s:^J;&W̦M8.jMv*6zg/KoQ _^v-1')օac;|RxH :]߁? v~#(}' l $Ϗm~I]=!L9+SH,TpC)'Y .gӔ%+qIHI"=)YpZ!њ&@nCO1Px#b_)$YL+yo`"t&X{ӬVw " Vt:_2IXmǙM81%PwWHI?PK!0$5YrdocProps/core.xml (_O M -!m7'MFv#Kv~W]`*C$Qk!6C/:EuL Vi:E* ',Mv5cwP3ybM͜?-n`[Iq a3 )lc,&?^>蕑NcGqpY9۶I'mW v`N|#V.x,K!S-(&#WъY/%!_Erotߚ9N笼NVILnxyAt6}K|OALt:dL<>/ɿPK!3ՒsdocProps/app.xml (n0 d(@VQ+zhq{Wd:&KɞgomɟͱY 1 6,}eܾ`W%TR;( ?M"HYTbXqf$;Rj=um4yڀCkGWAuFC68Z_/@R-M2 蓯1v`_S1MV+ kM @u(-ZcOe;,XQ k>!aqQp>~0(l .9Kz"{9I=SXJH8W!;or'Ѹ9N!-(] vmg>(] ,_tC&5ϯEPK!zW, Rxl/calcChain.xmlln}A~ɕTE>Al9} ep~tǯ>󧛸\/?﮾^_}|sݯ>D+^&+O+L#a9<<<<<<<<<<<<<<<<<<<<| A2d>| -o|K[2ߒ̷d%-o|G;2ߑwd#|G;2ߓd'=|O{2ߓBv!u].o ۅ".7777777űc Ӈa0}x"Td&M)T6lbԲe&M1d6lTf&M9t6lԳg&MA6 m"Th&MI6-mbԴi&MQ6MmTj&MY6mmԵk&Ma6m"Tl&Mi6}l솴666666666666666666NѳNVTkCkCkCkCk!ڮݾkmڮ]kvZ۵kmڮ]kvZ۵kmڮ]k}mڮ]kvZOnOO.>>>>>ڮ]kvZ۵kmڮ]kvZ۵kmڮ]kvZ۵kmڮ]kvZ۵kmڮ]kvZ۵kmڮ]kvZ۵kmڮ]kvZ۵kmڮ]kvZ;vhڡCkZ;vhڡCkZ;vhڡCkZ;vhڡCkZ;kZ;vh8zg׳~x=zWZ;vhڡCkZ;vhڡCkZ;vhڡCkZ;vhڡCkZ;vhڡCkZ;vhڡCkZ;vjکSkNZ;vjکSkNZ;vjکSkNZ;vjکSkNZ;vjکSkNZ;vjکSk}کSkΓIQYaiq'NN&NFvjکSkNZ;vjکSkNZ;vjکSkNZ;vjکSkNZ;vjکSkNZ;Ck=Ck=Ck=Ck=Nf.z- f׹me1~%W^?+kKW^3+d^5d^n5}KֽսKսum_!"uY+d^5d^5d^5d^n5 }gc1l,DE^ók8VW8e^9/9ypKͭfp΋̽s^`5r{ 缨j 缜k8^9/#y , yp ǽs^45qsfx+ʙQpsfTq93\8\ܫe3oRũbAK2Ty3Ճ%ӯT~"3F̙R哣93\6~-U`qeɳ_=h2AKWZL/93oϜ.U뾷T֮T֮tќ.U>9:3egzRٯTyr3FA͙RٯTy-UA*a͙Rkk AKI/az͙g,~ʳ_=hWZLzЭ*g˒AKAKAK=AKQksfTέTЭR^u҈Re+{K}o2-U_{p:i}r}o蓣93\6~UZ3å93\6^ksfl4]j }oY2-U'Y͙L93oc͙R哳{K-Ͻ}k ͙}p6gFcQksfThm p蓣93oڜ.U>993\6hm 'wx>gʙ5޺-U^RU޺-U^q%ӯRez͙Ბ>gKg93o͙Rez͙93o<=]VFXk-}mڜsy3å93\6{3eO}m ksfT\3gFsfxh_3åʷ־6gFposfx߸%ӯoʳڜ.={͙}p2pkm QksfTjm Z3eɷ'͙mc %psfTp2}m ksfTLksfl4w93oڜ.U<93\L93\6^ksfxߨ93\Lr >9Z3e#om U']Oz<ξz'_^kɷW}m C93\|k3eCΙѷVksfx߸ʒksfl4}m ͙}}m *͙ѷVksfxߨ93\|k6gFZ͙ѷVksfxߨ93\|r6gF͙Ბ''g.K} *.UϙR^93\Lo_3e#ON *.UѾ6gKg93\6|Ww|}r/[%PK-!zu [Content_Types].xmlPK-!U0#L _rels/.relsPK-!;Yxl/_rels/workbook.xml.relsPK-!ࢾ& xl/workbook.xmlPK-! xl/theme/theme1.xmlPK-!P5A^xl/worksheets/sheet2.xmlPK-!/?-?qxl/worksheets/sheet3.xmlPK-!° 9xl/worksheets/sheet1.xmlPK-!Njxl/sharedStrings.xmlPK-! C{ Hxl/styles.xmlPK-!0$5YrqdocProps/core.xmlPK-!3ՒsdocProps/app.xmlPK-!zW, Rxl/calcChain.xmlPK JRLumShiny/inst/shiny/filter/global.R0000644000175100001440000000220613124170541017137 0ustar hornikusers## +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ## Title: Filter_app ## Authors: Urs Tilmann Wolpert, Department of Geography, Justus-Liebig-University Giessen ## Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) ## Contact: urs.t.wolpert@geogr.uni-giessen.de ## Date: Thu June 22 2017 ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ library(shiny) library(Luminescence) library(readxl) library(RLumShiny) ##check whether a real database exists or the template should be loaded if(dir.exists("Data")){ ##set to first file database_path <- list.files("Data/", full.names = TRUE)[1] ##check whether this is a real XLSX file if(rev(strsplit(database_path, split = ".", fixed = TRUE)[[1]])[1] != "xlsx"){ stop("The filter database file needs to be of type 'xlsx'!") } }else{ database_path <- "template/template.xlsx" } # ##load data and cleanup filter list filters <- readxl::excel_sheets(database_path) filters <- filters[!grepl(pattern = "Main List", x = filters, fixed = TRUE)] RLumShiny/inst/shiny/cosmicdose/0000755000175100001440000000000013020024066016412 5ustar hornikusersRLumShiny/inst/shiny/cosmicdose/ui.R0000644000175100001440000001742513020024066017163 0ustar hornikusersfunction(request) { fluidPage( titlePanel(NULL, windowTitle = "RLumShiny - CosmicDose"), 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"), bookmarkButton() ) ), 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") ) }RLumShiny/inst/shiny/cosmicdose/server.R0000644000175100001440000001062713020024066020051 0ustar hornikusers## Server.R ## MAIN FUNCTION 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: ","", "", 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", "", "", "
") }, "Total absorber: ","", "", t$total_absorber.gcm2, "g/cm\u00b2", "", "", "
", "Cosmic dose rate (uncorrected): ","", "", round(t$d0, 3), "Gy/ka", "", "", "
", "Geomagnetic latitude: ","", "", round(t$geom_lat, 2), "\u00b0", "", "", "
", "Cosmic dose rate (corrected): ","", "", round(t$dc, 3),"\u00b1", round(t$dc/100*input$error, 3), "Gy/ka", "", "
", "
" ) } }) # 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) }RLumShiny/inst/shiny/cosmicdose/www/0000755000175100001440000000000013055562161017251 5ustar hornikusersRLumShiny/inst/shiny/cosmicdose/www/style.css0000644000175100001440000000277713055560641021141 0ustar hornikusers.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; } 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; } .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; } RLumShiny/inst/shiny/cosmicdose/shiny_bookmarks/0000755000175100001440000000000012772146744021641 5ustar hornikusersRLumShiny/inst/shiny/cosmicdose/shiny_bookmarks/5a258b62777fa1b7/0000755000175100001440000000000012772146744024005 5ustar hornikusersRLumShiny/inst/shiny/cosmicdose/shiny_bookmarks/5a258b62777fa1b7/input.rds0000644000175100001440000000057712765763523025671 0ustar hornikusersb```b`f 0b^ f Y84[JjKj:U| k=˖|}_b >7W>A|ml8F8L0w4@A \Hl9[ Bر8 I59' *ȞWZgdU:&d9%攦eCXwC1pS 8n[^bn*69 GbNIfIiJ*,RaH/9$\Q~H\R{~[r k8G~&8\p3A`6ؽ `gġ͂C/[-<`Hlsdp,Z 1!ɳ&$C51A3JRS\̼J<ҒĜT?x(z?Fw9gmKM&H),)MIE~r~~QJ1E0C+*뛙C$txCE.ǙWYR `0F0A0E$n$k5F嚠raF-$1,9i0v."d@l?8;EiE0dW$(Ou9RLumShiny/inst/shiny/cosmicdose/shiny_bookmarks/6584528eb04ada68/0000755000175100001440000000000012772146744024005 5ustar hornikusersRLumShiny/inst/shiny/cosmicdose/shiny_bookmarks/6584528eb04ada68/input.rds0000644000175100001440000000057712765763027025670 0ustar hornikusersb```b`f 0b^ f Y84[JjKj:U| k=˖|}_b >7W>A|ml8F8L0w4@A \Hl9[ Bر8 I59' *ȞWZgdU:&d9%攦eCXwC1pS 8n[^bn*69 GbNIfIiJ*,RaH/9$\Q~H\ 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, .csv, text/csv"), # file upload button (data set 2) fileInput(inputId = "file2", label = strong("Secondary data set"), accept="text/plain, .csv, text/csv"), # rhandsontable input/output fluidRow( column(width = 6, rHandsontableOutput(outputId = "table_in_primary") ), column(width = 6, rHandsontableOutput(outputId = "table_in_secondary")) ), 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 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::sideBarLayout bookmarkButton() )#EndOf::fluidPage }RLumShiny/inst/shiny/KDE/server.R0000644000175100001440000002677613053273744016357 0ustar hornikusers## MAIN FUNCTION function(input, output, session) { # input data (with default) values <- reactiveValues(data_primary = ExampleData.DeValues$CA1, data_secondary = setNames(as.data.frame(matrix(NA_real_, nrow = 5, ncol = 2)), c("x", "y"))) # check and read in file (DATA SET 1) observeEvent(input$file1, { inFile<- input$file1 if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL values$data_primary <- fread(file = inFile$datapath, data.table = FALSE) # inFile[1] contains filepath }) # check and read in file (DATA SET 2) observeEvent(input$file2, { inFile<- input$file2 if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL values$data_secondary <- fread(file = inFile$datapath, data.table = FALSE) # inFile[1] contains filepath }) ### GET DATA SETS Data<- reactive({ ### GET DATA data <- list(values$data_primary, values$data_secondary) data <- lapply(data, function(x) { x_tmp <- x[complete.cases(x), ] if (nrow(x_tmp) == 0) return(NULL) else return(x_tmp) }) data <- data[!sapply(data, is.null)] data <- lapply(data, function(x) setNames(x, c("Dose", "Error"))) return(data) }) output$table_in_primary <- renderRHandsontable({ rhandsontable(values$data_primary, height = 300, colHeaders = c("Dose", "Error"), rowHeaders = NULL) }) observeEvent(input$table_in_primary, { # Workaround for rhandsontable issue #138 # https://github.com/jrowen/rhandsontable/issues/138 df_tmp <- input$table_in_primary row_names <- as.list(as.character(seq_len(length(df_tmp$data)))) df_tmp$params$rRowHeaders <- row_names df_tmp$params$rowHeaders <- row_names df_tmp$params$rDataDim <- as.list(c(length(row_names), length(df_tmp$params$columns))) if (df_tmp$changes$event == "afterRemoveRow") df_tmp$changes$event <- "afterChange" if (!is.null(hot_to_r(df_tmp))) values$data_primary <- hot_to_r(df_tmp) }) output$table_in_secondary <- renderRHandsontable({ rhandsontable(values$data_secondary, height = 300, colHeaders = c("Dose", "Error"), rowHeaders = NULL) }) observeEvent(input$table_in_secondary, { # Workaround for rhandsontable issue #138 # https://github.com/jrowen/rhandsontable/issues/138 df_tmp <- input$table_in_secondary row_names <- as.list(as.character(seq_len(length(df_tmp$data)))) df_tmp$params$rRowHeaders <- row_names df_tmp$params$rowHeaders <- row_names df_tmp$params$rDataDim <- as.list(c(length(row_names), length(df_tmp$params$columns))) if (df_tmp$changes$event == "afterRemoveRow") df_tmp$changes$event <- "afterChange" if (!is.null(hot_to_r(df_tmp))) values$data_secondary <- hot_to_r(df_tmp) }) # dynamically inject sliderInput for x-axis range output$xlim<- renderUI({ data <- do.call(rbind, Data()) 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)) })## EndOf::renderUI() # dynamically inject sliderInput for KDE bandwidth output$bw<- renderUI({ data <- do.call(rbind, Data()) sliderInput(inputId = "bw", label = "KDE bandwidth", min = bw.nrd0(data[,1])/4, max = bw.nrd0(data[,1])*4, value = bw.nrd0(data[,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 data <- Data() 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(!all(is.na(unlist(values$data_secondary)))) { # 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 = TRUE, 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 str1 <- "data <- data.table::fread(file, data.table = FALSE)" if(!all(is.na(unlist(values$data_secondary)))) { str2 <- "file2 <- file.choose()" str3 <- "data2 <- data.table::fread(file2, data.table = FALSE)" 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()); }); }", { 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(!all(is.na(unlist(values$data_secondary)))) { data <- Data()[[2]] 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)RLumShiny/inst/shiny/KDE/www/0000755000175100001440000000000013055562161015524 5ustar hornikusersRLumShiny/inst/shiny/KDE/www/GitHub-Mark-32px.png0000644000175100001440000000326213020024066021066 0ustar hornikusersPNG  IHDR szztEXtSoftwareAdobe ImageReadyqe<$iTXtXML:com.adobe.xmp $IDATxėmhayL30A+R#f>IHکy(M)_o5 0+0Ėl&o{i^]u<{Yws}=uC>$L, }<w}8^ AO?p! xaяPKI3`'B>0QT1<+`}^nvkp^ƅF|1"Gp.*oO׀Vp ]߅jc8K$q 8jV`#`vmpGѢu!#}#:U_?_yhE $=;c*xNOo+&w)%K-R%6n'o">j/t³qoGW7j%2q GX?woibCÐAzbǰt \14|S.DZ]# b|H$(ʕohmqͱRP셣$,0Z20 tNvRW3K8Xk2 IO6 H3Q5 B.@ $pd!s#~<<+"x M0B\t8K@zB@F&S`cbP-`'{[! eDh;VEX0fK9-0IWfH  0Q){`##xFW<+*x<$9E[-qWW.(I+6aa@.y24x6_-"bbϫp@t~,/;m%h^ uf@Wp~<5j>{-]cK'Xto(hw?G%fIq^D$.Tʳ?D*A, `6B$BB dr`)B(Ͱ*`/@4Qhp.U=pa( Aa!ڈbX#!H$ ɈQ"K5H1RT UH=r9\F;2G1Q= C7F dt1r=6Ыhڏ>C03l0.B8, c˱" VcϱwE 6wB aAHXLXNH $4 7 Q'"K&b21XH,#/{C7$C2'ITFnR#,4H#dk9, +ȅ3![ b@qS(RjJ4e2AURݨT5ZBRQ4u9̓IKhhitݕNWGw Ljg(gwLӋT071oUX**| J&*/Tު UUT^S}FU3S ԖUPSSg;goT?~YYLOCQ_ cx,!k u5&|v*=9C3J3WRf?qtN (~))4L1e\kXHQG6EYAJ'\'GgSSݧ M=:.kDwn^Loy}/TmG X $ <5qo</QC]@Caaᄑ.ȽJtq]zۯ6iܟ4)Y3sCQ? 0k߬~OCOg#/c/Wװwa>>r><72Y_7ȷOo_C#dz%gA[z|!?:eAAA!h쐭!ΑiP~aa~ 'W?pX15wCsDDDޛg1O9-J5*>.j<74?.fYXXIlK9.*6nl {/]py.,:@LN8A*%w% yg"/6шC\*NH*Mz쑼5y$3,幄'L Lݛ:v m2=:1qB!Mggfvˬen/kY- BTZ(*geWf͉9+̳ې7ᒶKW-X潬j9(xoʿܔĹdff-[n ڴ VE/(ۻCɾUUMfeI?m]Nmq#׹=TR+Gw- 6 U#pDy  :v{vg/jBFS[b[O>zG499?rCd&ˮ/~јѡ򗓿m|x31^VwwO| (hSЧc3-gAMA|Q cHRMz%u0`:o_FiIDATx}td%! )+7ږJ["\wKIQl7YWtFuftZǙ]=8n-Ot) q\p7ab SZMM@z K[yӧO?_7n\ pw~ \i$eo .<_: @IpB^D=c,JN+߻jժ8|()ٞ /MMM#g̙d\]w5f߾}}vP2.^zTq㢯ψ˼W馛FGN#P.NȦG"suhll4(E%>F]]Q~o=6mdPcbŊZ|ب˼xaPl."o,۷o7.E˼۷… K;|XRJw}~(T_u^^矏F?mƼ|>{WkΜ9 sl瞲^O$y1qIJƍ>?qZ*/,YR߳?8F-uy۷o VOF8GrWXQIU\VZ~OVײo߾ؾ}>F$yӧW4nܸ2oΜ9U5GN? [/o .گ矏F?Uc^]]]U}G9{`]vEL:)de1!Ҭ!UVǴi?Y>K苧鍈m{N}?SJ_m[2#@%6 qw;4T>u>o_ODPVbcލ7X3_}b5502|eXV"c?9E__H6;OYO?{P+z{{cժU̙30Q>= v@$&-Y$1ߔؾ}{x~BA"1oo߾D}c.\~B^GeqHDļ\.oΊ+S Z~OϸRc^O7gժU>p۾/zNDx0c^>^oЍ7~RDz_ž>`j:s=۷/={VSOHl;|pZ*ߤn)5ɿ "٘w;=c?:tƇO,P^|@ }XpaYO-P5<6 KKf"žhf5Yr\*YsO<~j~VTHż/SZjUٟY o Mg߁}wBy/B{ゥ-Y$%Oxt T̻뮻R ۷o_l߾=nF?@Ѹ 5>ߑ"~. 1ZJjb^.(+V<`('o<{<J*b^(UV?hll4P>ܰ5"ؾϣ1H o։y@<<BБczf@by@ܻ?:7l@y@"?H41i|>6u툮m{<Oj@y@MH31 O["%UMC%U%ǃ_vU<*xT'q"νsֈ!F@G=O5#B;tX^9zNxp~۱G"Z(1( /s̳ŗlr (1|>+ /2xPb0lV>>*Aŗ^U_Gj<`H!gZ>b R KNζ=GE<Rb<\|i;!@ sŮj)5 j)PqEsܰUÑ" <(5m <8G\}'<<8/r7e!(yc-Pnb¡#⾕ y@Yy0B; [<3 T<5m]=BP1b Tmq)7^\|QL0..ln_a$H01Bo1S.yCןuuugZ 'A\}'<EګrlH71`0=?0pN^.0 "57b4B0g qascwZHpw)154qG y._y\Eb%Amk5Gfx, <1T NwY q'A x%OƧ%p[hO|o<(m[ ̾WJ7?54raA8Ẹ:r,qGmkR $QU|ܷ!!Txڣ $QU> yHyT޾ D<FḲ*<@\yT#D<Ẹ|NI%Plbm{|N35.>%raA(1y͏#1D<JṂ"Kk6 y$ָܶh\s|%1Id<*scCP涵FD_{A(91;tX15mK(|>|ԬrP @ىyʯ|Cȣ& ~.GOo*Ḅl~d8xԜm+/f *J̣,|Zj-]:7luGUp@y̓_G ^}}q Q 6WyEQWWg81asGmk2scc*8< Z yP<s25^+E23-yP|bcWw!5!JC5a>Wy#o~% ;7"@y¦o#!qJw#q[\1"sZ!D#""|8x ָܶ+cc@yDD} <m|!//涵nH1/|^^]FFH!Wy\b^8x)*IK_z)*MK'z/RU$PORU$P]!e涵u4$@FH2s`b^?KmNK'2O\p! ļ'"sZchļz$#@ y w)[b^y#ܶhb^>wܛlSq^|)"%sM;:n20ORbn[k̼l! Eļ&|30dfH1/A6=7BJ<H/1/A~p>/MK˼47RLKggxӔ)&Abb^Be^*44RLK5B]>} <ozF\=-Fk#$ <d yP涵F}@کP#)'@ !ᮻ #b^R'O!ZyP+<\|1j yP+<b1j5B!@FyP#<bԀ_7KK9W_ayNbԘ=RHK7Mhرq#@ y R__fN7D WK/RFK:# )#%̕o))#%7]b-0s)Q[H1/a]8)Q[H1/a6])_RBK#ؾm{;RBK٭o1Ba#@ y tٛh! ļ4q`a@:y 42{b~pb^BaFH>t1$P_sRfwwOt}o! ļsF۱u$Po2K0Ru$P FH)y\b^]KB ļ[0wRu$`3/sRu$`Z!\@y !\@y w˂9FHOtl۱Pļ-'63T11/CJD5گ1[({ >7Q-<(xԖsBOb^[!8'AϿ0#R{{;ޮg[?1`<:b/ z0 bg:b z{1`" c\aޥqQA zg;c ΣTvw?x`7Bc|v'/^z PǰΣԺ+>yߚ/g 1"(=Wޛn f[1\1b\Qr//|-e0#{ ( _*>TsǨym۱|m)c?01[[[o!(nz>RvwCϟ#G5 QT3N2 W߉P<06{bՃ#>J&Qt !QuXcjGI_UaYz~z od>}'?yTx\pQzb%3eldo!"BУ*=ӧܒqKfQjb%' AU۱:@U({/-Uo0WqWYuuuy%&xܖ1?wĕO3 UC̣,l<*b-7=?4-#%Qu|~i#0\bUVz[^iNJom}sdo!"|~sz{hweo뮙uuuH91' Aj F=15n̉mPo:Tp̚9/VkOeG26>t;sVA~Ջ{ڷ^\ _?]x]wѱx~\d^'NGpOE㎎˧ A%n-|q*D#xpX|q(#1074?G%rc'GkƧ%&G\2iB|wD熭Pb~UT@w5W˦z+.9H,A*ފ;59=.|#G_Uw!OЃ|+CsZq͑;;̾;V}[qQ5eԘ Ώ?Y\@ XOzUN!߽4> 2cd/*kxAT'18d:r,[PD1[`H3NrGo<`XuŲw(@x]ns-<`zJe0j__;36u툮m{\@y?" b-qQQJMø>OJgEt\%~U1Y-<=(y@Ųc>tLJ!߽4?eQol2g}.fdIH|wMo 0LbP13N6T̡#Ǣ!`D__Ƌ/|*E}@y@xx sLݟ.^"%/uԵCȣ\6 *|u_}'"A-ChinY3gbn+CE߱g#O?/C V~((KHN};o~X?N>q|S&A?547 O^}}7ힾ#ⷱO?k&A]U岙fCT W?ypБc)yRmvGAlԣT1RБcwtblCT1R辕ʣ\6 y2;7Cjok=)ӹa< e37UJ̃ٸQ#PP.E)kWy iFbbĦB岙fCT91Rŗ^m{ AA-͍1cdCT91R`W*rLܾd!j d8x'M0@  WyfFy`޾S&ئ1b$u]QP.yP?yUCjokuPc]e-͍1k C$5fW*rLܾd!J̃d8x'M0@ByPC֮*rLq!L̃q1Wy iꔉq `bԈ6ʣ\6K7@‰yP9}' AAW]1-61@‰yP\1\6 m{ f͜a"B̃ԵU岙x )bTHRKscL4"A]U岙}C bT3>5M2U!A|iFWyfb5<(CGEo CP)clCbu]QP.ws!8#1hR{[k3:7luGAl&2f<({rLܺ`N<(|>*aΕF`HbB岙XnJ̃ѵm!(1f͜aJ̃[oʣ\6/Y`Ẽ?~21C5s( 1F`SWyfw,6%#0?*!47I @Ɉy0LkoqGAl&n_̳ŁG AASLt@ɉy0 _ZU岙Xx!(91Бcw4u4gzfWyf]\hB̃!ܻUCjok_:CPb sVWyf"3o!(1 عw((ĭ D}}1(1 ϻns(+1`S!rLt,j7e'ڶf0e'7\QP.ۗ,0!iZc "<8[\Q<*M̃9t䘫<4uDWyTzfWyfb<^0]uŴ4T*岙6TGܻUCjokzCPqb׹a< e37T1Tζ=F\6]P5<4k #Xb5cS! m{ f͜aRỊl*rLq!H-1<3M6%Q5֮*rLܾd!H51d8x4uĘwY4Z#i<*bS!rLt,j7Gڶf0G=oʣ\6/Y`81?~2vuZc 3(뷸ʣ Wy0419tX8x4uDWy01Yn< e3t|C<Бcw4u401pPrLܙpb%s~Wy 5 g!Qrʣ\6y  QRٶfcQ<&1G]1Y3gỊd6u(h*>1[*FḤ$V~((KFḤZc (뷸ʣ\6wtl1:t䘫<4uĸhQ(6ʣ\6K7G:r,zNZclC(y}+rGAl&2f΁GQܻ 5 @̣(:7luGAl&C98g7?j e3ѱ=HڶUC5s<ɦB岙fC@yZѵm!(1fLl(1Q[~< e3q"'Ƙ:7luǐn5M2UGA_ZU岙Xx!<Бcw4u4PFbgzfWyf-2x{cHmQ__o(31ܰU岙̛m1Wζ=F\6.**D|>o~UCaΕF 8eS!rLt,j7TGD*# 1f͜a 1Xoʣ\6/Y`01?~2 []1_k!b^Bm!QP.E#%P>m{ f͜a1b^=oʣ\6c!y d147I 5HK뷸ʣ\6/Y`Qb^m{\1Y3gR@̫rvyfΎ )!U_z9147ƌi>B̫b-Wyf% )"U'Ƙm{ f͜aH91 |UÑQe3ѱ$aL>=VX/Af0jժhjj5ƨBbB.ۗ,0c}vcT1F1&O`?.\mmmk*  m'N+VD>7Hy0BSLt@*Z*~~/1*D̃e3t|C}?~|<(31F+ئ1 ꫯx R&b S.m ٷo_455Ŋ+Qb S{[k`ժUQWW۷o7F y0 l&2fb…1~8|1J@̃e3ѱU SL>=r+21aFzG)>cCF{<"`-͍c…΁䲙}C@۷/O+Vyz A-͍1yC@ Z*sM1F@̃3e3e %}ypSLMc epdb󴵞qP٪z*Su+4^)RkߥЉtB&!dfD1cV0dd/0ɽM$>>>zm>|36cuu5v\\\h'#7+rt4#<@x ,C3jZk{<֭[1ݻggg0k>|Ƞpj5v ̃xT*idXӉR~{4D^Z'''Z0k>| f<z4HMȨ5ATx"k-M&I^pߏz7w&kMВ$n[[[\0I4cmm-Wrv;...r.atbyy97y>Z~!q܌o.yp8h W0Bt:Q*{05 (ͨjq||Zyxɓ(J3U0>^GVL#KX__v=yz<Nj5^쾘[ <4MG?<$I(AT*!K>ߍhsEj<og%/M8< ]qxx+++~On`a%I^/Aa jnF*̚y,Vxpk73iZa{  Ӓ$n[㴟-UĹx3i4JE3>  3$pXxqLz1y0W;;;1LŻl4Mw v0SIQ A5 nFЌ+ qV+ϣlh7XRDLiK4ceeE3<.Iz1 yS$`vh4-͘2aSj4ok"iښfܰ<`p-IDuvvvvślF{{{QT4cvJ?}'W$ph.ޜ9f /1yqW""ZVL&h41?4~o.^9f @Dwtt@ :E[L>y煋0 L|10?f@|v]k /\9f ōui]ug@nΕ7l`|?\+o+OvVՃ}UV:Ws-7m+Ov}sVJ!cSY+rfjY9@L5/+g@X@7rDypcXyQ  n<,l&4nȉnb[z,D]z,[X{dIXxs{Zf/s6ٙIENDB`RLumShiny/inst/shiny/KDE/www/style.css0000644000175100001440000000242713055560756017413 0ustar hornikusers.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; } .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; } .label, .badge { font-size: 12px; padding: 4px 20px; margin: 10px; line-height: 18px; } .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; } RLumShiny/inst/shiny/KDE/shiny_bookmarks/0000755000175100001440000000000012772146744020114 5ustar hornikusersRLumShiny/inst/shiny/KDE/shiny_bookmarks/62408c76eac4976d/0000755000175100001440000000000012772146744022266 5ustar hornikusersRLumShiny/inst/shiny/KDE/shiny_bookmarks/62408c76eac4976d/input.rds0000644000175100001440000000074012765761574024146 0ustar hornikusers}T͊@LYUPŝ'ufxAD*I%il{&yAw,6kC>(Q ؙٰ>xl$Z 睌C1lVz~hel2x|}?\e6(53}a;\-^Yy/A F25nyc7MqE{pVG>եq)9jP#8VSxOj[M/>O` S\U4K`4ׅms[PA'M`&Vdjl+mT[!%§XUA hJb Cvc3A5BpoRLumShiny/inst/shiny/KDE/Global.R0000644000175100001440000000031513053273270016220 0ustar hornikusers## Server.R library(Luminescence) library(shiny) library(RLumShiny) library(data.table) library(rhandsontable) # load example data data(ExampleData.DeValues) enableBookmarking(store = "server")RLumShiny/inst/shiny/abanico/0000755000175100001440000000000013055562161015671 5ustar hornikusersRLumShiny/inst/shiny/abanico/ui.R0000644000175100001440000020705413055562161016441 0ustar hornikusers## UI.R function(request) { fluidPage( titlePanel(NULL, windowTitle = "RLumShiny - AbanicoPlot"), sidebarLayout( # 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, .csv, text/csv"), # file upload button (data set 2) fileInput(inputId = "file2", label = strong("Secondary data set"), accept="text/plain, .csv, text/csv"), # rhandsontable input/output fluidRow( column(width = 6, rHandsontableOutput(outputId = "table_in_primary") ), column(width = 6, rHandsontableOutput(outputId = "table_in_secondary")) ), 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 De-errors as error bars on De-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("
2σ bar
")), 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
"), 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
"), 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
"), 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
"),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
"),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
"),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
"),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
"),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
"),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
"),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("
2σ bar
")), 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 values to the list object.") ), # 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 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::sideBarLayout bookmarkButton() )##EndOf::fluidPage }RLumShiny/inst/shiny/abanico/server.R0000644000175100001440000005260013053273643017327 0ustar hornikusers## Server.R ## MAIN FUNCTION function(input, output, session) { # input data (with default) values <- reactiveValues(data_primary = ExampleData.DeValues$CA1, data_secondary = setNames(as.data.frame(matrix(NA_real_, nrow = 5, ncol = 2)), c("x", "y"))) ### GET DATA SETS Data<- reactive({ ### GET DATA data <- list(values$data_primary, values$data_secondary) data <- lapply(data, function(x) { x_tmp <- x[complete.cases(x), ] if (nrow(x_tmp) == 0) return(NULL) else return(x_tmp) }) data <- data[!sapply(data, is.null)] data <- lapply(data, function(x) setNames(x, c("Dose", "Error"))) ### 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) }) output$table_in_primary <- renderRHandsontable({ rhandsontable(values$data_primary, height = 300, colHeaders = c("Dose", "Error"), rowHeaders = NULL) }) observeEvent(input$table_in_primary, { # Workaround for rhandsontable issue #138 # https://github.com/jrowen/rhandsontable/issues/138 # Desc.: the rownames are not updated when copying values in the table # that exceed the current number of rows; hence, we have to manually # update the rownames before running hot_to_r(), which would crash otherwise # to modify the rhandsontable we need to create a local non-reactive variable df_tmp <- input$table_in_primary row_names <- as.list(as.character(seq_len(length(df_tmp$data)))) # now overwrite the erroneous entries in the list: 'rRowHeaders', 'rowHeaders' # and 'rDataDim' df_tmp$params$rRowHeaders <- row_names df_tmp$params$rowHeaders <- row_names df_tmp$params$rDataDim <- as.list(c(length(row_names), length(df_tmp$params$columns))) # With the above workaround we run into the problem that the 'afterRemoveRow' # event checked in rhandsontable:::toR also tries to remove the surplus rowname(s) # For now, we can overwrite the event and handle the 'afterRemoveRow' as a usual # 'afterChange' event if (df_tmp$changes$event == "afterRemoveRow") df_tmp$changes$event <- "afterChange" if (!is.null(hot_to_r(df_tmp))) values$data_primary <- hot_to_r(df_tmp) }) output$table_in_secondary <- renderRHandsontable({ rhandsontable(values$data_secondary, height = 300, colHeaders = c("Dose", "Error"), rowHeaders = NULL) }) observeEvent(input$table_in_secondary, { # Workaround for rhandsontable issue #138 # https://github.com/jrowen/rhandsontable/issues/138 # See detailed explanation above df_tmp <- input$table_in_secondary row_names <- as.list(as.character(seq_len(length(df_tmp$data)))) df_tmp$params$rRowHeaders <- row_names df_tmp$params$rowHeaders <- row_names df_tmp$params$rDataDim <- as.list(c(length(row_names), length(df_tmp$params$columns))) if (df_tmp$changes$event == "afterRemoveRow") df_tmp$changes$event <- "afterChange" if (!is.null(hot_to_r(df_tmp))) values$data_secondary <- hot_to_r(df_tmp) }) # check and read in file (DATA SET 1) observeEvent(input$file1, { inFile<- input$file1 if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL values$data_primary <- fread(file = inFile$datapath, data.table = FALSE) # inFile[1] contains filepath }) # check and read in file (DATA SET 2) observeEvent(input$file2, { inFile<- input$file2 if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL values$data_secondary <- fread(file = inFile$datapath, data.table = FALSE) # inFile[1] contains filepath }) # 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({ data <- Data() numericInput(inputId = "centralityNumeric", label = "Value", value = round(mean(data[[1]][,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(!all(is.na(unlist(values$data_secondary)))) { # 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(!all(is.na(unlist(values$data_secondary)))) { 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 = TRUE, 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 str1 <- "data <- data.table::fread(file, data.table = FALSE)" if(!all(is.na(unlist(values$data_secondary)))) { str2 <- "file2 <- file.choose()" str3 <- "data2 <- data.table::fread(file2, data.table = FALSE)" 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()); }); }", { data <- Data() colnames(data[[1]])<- c("De","De error") data[[1]] })##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(!all(is.na(unlist(values$data_secondary)))) { data <- Data() colnames(data[[2]])<- c("De","De error") data[[2]] } })##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)RLumShiny/inst/shiny/abanico/www/0000755000175100001440000000000013055562161016515 5ustar hornikusersRLumShiny/inst/shiny/abanico/www/GitHub-Mark-32px.png0000644000175100001440000000326213020024066022057 0ustar hornikusersPNG  IHDR szztEXtSoftwareAdobe ImageReadyqe<$iTXtXML:com.adobe.xmp $IDATxėmhayL30A+R#f>IHکy(M)_o5 0+0Ėl&o{i^]u<{Yws}=uC>$L, }<w}8^ AO?p! xaяPKI3`'B>0QT1<+`}^nvkp^ƅF|1"Gp.*oO׀Vp ]߅jc8K$q 8jV`#`vmpGѢu!#}#:U_?_yhE $=;c*xNOo+&w)%K-R%6n'o">j/t³qoGW7j%2q GX?woibCÐAzbǰt \14|S.DZ]# b|H$(ʕohmqͱRP셣$,0Z20 tNvRW3K8Xk2 IO6 H3Q5 B.@ $pd!s#~<<+"x M0B\t8K@zB@F&S`cbP-`'{[! eDh;VEX0fK9-0IWfH  0Q){`##xFW<+*x<$9E[-qWW.(I+6aa@.y24x6_-"bbϫp@t~,/;m%h^ uf@Wp~<5j>{-]cK'Xto(hw?G%fIq^D$.Tʳ?D*A, `6B$BB dr`)B(Ͱ*`/@4Qhp.U=pa( Aa!ڈbX#!H$ ɈQ"K5H1RT UH=r9\F;2G1Q= C7F dt1r=6Ыhڏ>C03l0.B8, c˱" VcϱwE 6wB aAHXLXNH $4 7 Q'"K&b21XH,#/{C7$C2'ITFnR#,4H#dk9, +ȅ3![ b@qS(RjJ4e2AURݨT5ZBRQ4u9̓IKhhitݕNWGw Ljg(gwLӋT071oUX**| J&*/Tު UUT^S}FU3S ԖUPSSg;goT?~YYLOCQ_ cx,!k u5&|v*=9C3J3WRf?qtN (~))4L1e\kXHQG6EYAJ'\'GgSSݧ M=:.kDwn^Loy}/TmG X $ <5qo</QC]@Caaᄑ.ȽJtq]zۯ6iܟ4)Y3sCQ? 0k߬~OCOg#/c/Wװwa>>r><72Y_7ȷOo_C#dz%gA[z|!?:eAAA!h쐭!ΑiP~aa~ 'W?pX15wCsDDDޛg1O9-J5*>.j<74?.fYXXIlK9.*6nl {/]py.,:@LN8A*%w% yg"/6шC\*NH*Mz쑼5y$3,幄'L Lݛ:v m2=:1qB!Mggfvˬen/kY- BTZ(*geWf͉9+̳ې7ᒶKW-X潬j9(xoʿܔĹdff-[n ڴ VE/(ۻCɾUUMfeI?m]Nmq#׹=TR+Gw- 6 U#pDy  :v{vg/jBFS[b[O>zG499?rCd&ˮ/~јѡ򗓿m|x31^VwwO| (hSЧc3-gAMA|Q cHRMz%u0`:o_FiIDATx}td%! )+7ږJ["\wKIQl7YWtFuftZǙ]=8n-Ot) q\p7ab SZMM@z K[yӧO?_7n\ pw~ \i$eo .<_: @IpB^D=c,JN+߻jժ8|()ٞ /MMM#g̙d\]w5f߾}}vP2.^zTq㢯ψ˼W馛FGN#P.NȦG"suhll4(E%>F]]Q~o=6mdPcbŊZ|ب˼xaPl."o,۷o7.E˼۷… K;|XRJw}~(T_u^^矏F?mƼ|>{WkΜ9 sl瞲^O$y1qIJƍ>?qZ*/,YR߳?8F-uy۷o VOF8GrWXQIU\VZ~OVײo߾ؾ}>F$yӧW4nܸ2oΜ9U5GN? [/o .گ矏F?Uc^]]]U}G9{`]vEL:)de1!Ҭ!UVǴi?Y>K苧鍈m{N}?SJ_m[2#@%6 qw;4T>u>o_ODPVbcލ7X3_}b5502|eXV"c?9E__H6;OYO?{P+z{{cժU̙30Q>= v@$&-Y$1ߔؾ}{x~BA"1oo߾D}c.\~B^GeqHDļ\.oΊ+S Z~OϸRc^O7gժU>p۾/zNDx0c^>^oЍ7~RDz_ž>`j:s=۷/={VSOHl;|pZ*ߤn)5ɿ "٘w;=c?:tƇO,P^|@ }XpaYO-P5<6 KKf"žhf5Yr\*YsO<~j~VTHż/SZjUٟY o Mg߁}wBy/B{ゥ-Y$%Oxt T̻뮻R ۷o_l߾=nF?@Ѹ 5>ߑ"~. 1ZJjb^.(+V<`('o<{<J*b^(UV?hll4P>ܰ5"ؾϣ1H o։y@<<BБczf@by@ܻ?:7l@y@"?H41i|>6u툮m{<Oj@y@MH31 O["%UMC%U%ǃ_vU<*xT'q"νsֈ!F@G=O5#B;tX^9zNxp~۱G"Z(1( /s̳ŗlr (1|>+ /2xPb0lV>>*Aŗ^U_Gj<`H!gZ>b R KNζ=GE<Rb<\|i;!@ sŮj)5 j)PqEsܰUÑ" <(5m <8G\}'<<8/r7e!(yc-Pnb¡#⾕ y@Yy0B; [<3 T<5m]=BP1b Tmq)7^\|QL0..ln_a$H01Bo1S.yCןuuugZ 'A\}'<EګrlH71`0=?0pN^.0 "57b4B0g qascwZHpw)154qG y._y\Eb%Amk5Gfx, <1T NwY q'A x%OƧ%p[hO|o<(m[ ̾WJ7?54raA8Ẹ:r,qGmkR $QU|ܷ!!Txڣ $QU> yHyT޾ D<FḲ*<@\yT#D<Ẹ|NI%Plbm{|N35.>%raA(1y͏#1D<JṂ"Kk6 y$ָܶh\s|%1Id<*scCP涵FD_{A(91;tX15mK(|>|ԬrP @ىyʯ|Cȣ& ~.GOo*Ḅl~d8xԜm+/f *J̣,|Zj-]:7luGUp@y̓_G ^}}q Q 6WyEQWWg81asGmk2scc*8< Z yP<s25^+E23-yP|bcWw!5!JC5a>Wy#o~% ;7"@y¦o#!qJw#q[\1"sZ!D#""|8x ָܶ+cc@yDD} <m|!//涵nH1/|^^]FFH!Wy\b^8x)*IK_z)*MK'z/RU$PORU$P]!e涵u4$@FH2s`b^?KmNK'2O\p! ļ'"sZchļz$#@ y w)[b^y#ܶhb^>wܛlSq^|)"%sM;:n20ORbn[k̼l! Eļ&|30dfH1/A6=7BJ<H/1/A~p>/MK˼47RLKggxӔ)&Abb^Be^*44RLK5B]>} <ozF\=-Fk#$ <d yP涵F}@کP#)'@ !ᮻ #b^R'O!ZyP+<\|1j yP+<b1j5B!@FyP#<bԀ_7KK9W_ayNbԘ=RHK7Mhرq#@ y R__fN7D WK/RFK:# )#%̕o))#%7]b-0s)Q[H1/a]8)Q[H1/a6])_RBK#ؾm{;RBK٭o1Ba#@ y tٛh! ļ4q`a@:y 42{b~pb^BaFH>t1$P_sRfwwOt}o! ļsF۱u$Po2K0Ru$P FH)y\b^]KB ļ[0wRu$`3/sRu$`Z!\@y !\@y w˂9FHOtl۱Pļ-'63T11/CJD5گ1[({ >7Q-<(xԖsBOb^[!8'AϿ0#R{{;ޮg[?1`<:b/ z0 bg:b z{1`" c\aޥqQA zg;c ΣTvw?x`7Bc|v'/^z PǰΣԺ+>yߚ/g 1"(=Wޛn f[1\1b\Qr//|-e0#{ ( _*>TsǨym۱|m)c?01[[[o!(nz>RvwCϟ#G5 QT3N2 W߉P<06{bՃ#>J&Qt !QuXcjGI_UaYz~z od>}'?yTx\pQzb%3eldo!"BУ*=ӧܒqKfQjb%' AU۱:@U({/-Uo0WqWYuuuy%&xܖ1?wĕO3 UC̣,l<*b-7=?4-#%Qu|~i#0\bUVz[^iNJom}sdo!"|~sz{hweo뮙uuuH91' Aj F=15n̉mPo:Tp̚9/VkOeG26>t;sVA~Ջ{ڷ^\ _?]x]wѱx~\d^'NGpOE㎎˧ A%n-|q*D#xpX|q(#1074?G%rc'GkƧ%&G\2iB|wD熭Pb~UT@w5W˦z+.9H,A*ފ;59=.|#G_Uw!OЃ|+CsZq͑;;̾;V}[qQ5eԘ Ώ?Y\@ XOzUN!߽4> 2cd/*kxAT'18d:r,[PD1[`H3NrGo<`XuŲw(@x]ns-<`zJe0j__;36u툮m{\@y?" b-qQQJMø>OJgEt\%~U1Y-<=(y@Ųc>tLJ!߽4?eQol2g}.fdIH|wMo 0LbP13N6T̡#Ǣ!`D__Ƌ/|*E}@y@xx sLݟ.^"%/uԵCȣ\6 *|u_}'"A-ChinY3gbn+CE߱g#O?/C V~((KHN};o~X?N>q|S&A?547 O^}}7ힾ#ⷱO?k&A]U岙fCT W?ypБc)yRmvGAlԣT1RБcwtblCT1R辕ʣ\6 y2;7Cjok=)ӹa< e37UJ̃ٸQ#PP.E)kWy iFbbĦB岙fCT91Rŗ^m{ AA-͍1cdCT91R`W*rLܾd!j d8x'M0@  WyfFy`޾S&ئ1b$u]QP.yP?yUCjokuPc]e-͍1k C$5fW*rLܾd!J̃d8x'M0@ByPC֮*rLq!L̃q1Wy iꔉq `bԈ6ʣ\6K7@‰yP9}' AAW]1-61@‰yP\1\6 m{ f͜a"B̃ԵU岙x )bTHRKscL4"A]U岙}C bT3>5M2U!A|iFWyfb5<(CGEo CP)clCbu]QP.ws!8#1hR{[k3:7luGAl&2f<({rLܺ`N<(|>*aΕF`HbB岙XnJ̃ѵm!(1f͜aJ̃[oʣ\6/Y`Ẽ?~21C5s( 1F`SWyfw,6%#0?*!47I @Ɉy0LkoqGAl&n_̳ŁG AASLt@ɉy0 _ZU岙Xx!(91Бcw4u4gzfWyf]\hB̃!ܻUCjok_:CPb sVWyf"3o!(1 عw((ĭ D}}1(1 ϻns(+1`S!rLt,j7e'ڶf0e'7\QP.ۗ,0!iZc "<8[\Q<*M̃9t䘫<4uDWyTzfWyfb<^0]uŴ4T*岙6TGܻUCjokzCPqb׹a< e37T1Tζ=F\6]P5<4k #Xb5cS! m{ f͜aRỊl*rLq!H-1<3M6%Q5֮*rLܾd!H51d8x4uĘwY4Z#i<*bS!rLt,j7Gڶf0G=oʣ\6/Y`81?~2vuZc 3(뷸ʣ Wy0419tX8x4uDWy01Yn< e3t|C<Бcw4u401pPrLܙpb%s~Wy 5 g!Qrʣ\6y  QRٶfcQ<&1G]1Y3gỊd6u(h*>1[*FḤ$V~((KFḤZc (뷸ʣ\6wtl1:t䘫<4uĸhQ(6ʣ\6K7G:r,zNZclC(y}+rGAl&2f΁GQܻ 5 @̣(:7luGAl&C98g7?j e3ѱ=HڶUC5s<ɦB岙fC@yZѵm!(1fLl(1Q[~< e3q"'Ƙ:7luǐn5M2UGA_ZU岙Xx!<Бcw4u4PFbgzfWyf-2x{cHmQ__o(31ܰU岙̛m1Wζ=F\6.**D|>o~UCaΕF 8eS!rLt,j7TGD*# 1f͜a 1Xoʣ\6/Y`01?~2 []1_k!b^Bm!QP.E#%P>m{ f͜a1b^=oʣ\6c!y d147I 5HK뷸ʣ\6/Y`Qb^m{\1Y3gR@̫rvyfΎ )!U_z9147ƌi>B̫b-Wyf% )"U'Ƙm{ f͜aH91 |UÑQe3ѱ$aL>=VX/Af0jժhjj5ƨBbB.ۗ,0c}vcT1F1&O`?.\mmmk*  m'N+VD>7Hy0BSLt@*Z*~~/1*D̃e3t|C}?~|<(31F+ئ1 ꫯx R&b S.m ٷo_455Ŋ+Qb S{[k`ժUQWW۷o7F y0 l&2fb…1~8|1J@̃e3ѱU SL>=r+21aFzG)>cCF{<"`-͍c…΁䲙}C@۷/O+Vyz A-͍1yC@ Z*sM1F@̃3e3e %}ypSLMc epdb󴵞qP٪z*Su+4^)RkߥЉtB&!dfD1cV0dd/0ɽM$>>>zm>|36cuu5v\\\h'#7+rt4#<@x ,C3jZk{<֭[1ݻggg0k>|Ƞpj5v ̃xT*idXӉR~{4D^Z'''Z0k>| f<z4HMȨ5ATx"k-M&I^pߏz7w&kMВ$n[[[\0I4cmm-Wrv;...r.atbyy97y>Z~!q܌o.yp8h W0Bt:Q*{05 (ͨjq||Zyxɓ(J3U0>^GVL#KX__v=yz<Nj5^쾘[ <4MG?<$I(AT*!K>ߍhsEj<og%/M8< ]qxx+++~On`a%I^/Aa jnF*̚y,Vxpk73iZa{  Ӓ$n[㴟-UĹx3i4JE3>  3$pXxqLz1y0W;;;1LŻl4Mw v0SIQ A5 nFЌ+ qV+ϣlh7XRDLiK4ceeE3<.Iz1 yS$`vh4-͘2aSj4ok"iښfܰ<`p-IDuvvvvślF{{{QT4cvJ?}'W$ph.ޜ9f /1yqW""ZVL&h41?4~o.^9f @Dwtt@ :E[L>y煋0 L|10?f@|v]k /\9f ōui]ug@nΕ7l`|?\+o+OvVՃ}UV:Ws-7m+Ov}sVJ!cSY+rfjY9@L5/+g@X@7rDypcXyQ  n<,l&4nȉnb[z,D]z,[X{dIXxs{Zf/s6ٙIENDB`RLumShiny/inst/shiny/abanico/www/style.css0000644000175100001440000000242713055560617020400 0ustar hornikusers.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; } .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; } .label, .badge { font-size: 12px; padding: 4px 20px; margin: 10px; line-height: 18px; } .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; } RLumShiny/inst/shiny/abanico/shiny_bookmarks/0000755000175100001440000000000012772146744021105 5ustar hornikusersRLumShiny/inst/shiny/abanico/shiny_bookmarks/8027aaa9b994c7bd/0000755000175100001440000000000012772146744023411 5ustar hornikusersRLumShiny/inst/shiny/abanico/shiny_bookmarks/8027aaa9b994c7bd/input.rds0000644000175100001440000000211212765763305025256 0ustar hornikusersVEǮ}vN|FA+"΅(TH(Rbvgnvg3;{ IIA HP3J~̼y{oh4ZgR||R||*ؑGi!{DkYWv)lVx1# ٛ_ٷoݷvA sQ y2;zV-{-מP,Th1Uٔ'PsZ#"rfFp^זvJ'ڼrp"^gL`LJ8u0 upwpFw U.e ~ ĂMfxLT1Dng, uFnN uۼPn7l"y%(!;.;/ xܹ?2~{sw+g?uJǩk\~o&Z <1M5T-KJ{b 0<~ ;Q,䙉}-HjR0iS뚁oO7w~zviψ`P{X;Qɿ>~__ \)d @ZHd'DIDӊZ2E$\ ψ#z iY[UU3P\r|LTlC'l=>@#oڛX >wyf{N@%Gu&!RYUK@"Mly(r 6 {K0dR2e2Tqm,#=!1E:<'ESF(8@8. 2ČS |W>>o@G!‡! 998?'TFʸ0w=]}v5w]}^5vBCG!‡! {BFpֽ3jڋ c^BA7QsKW_wwmT+6Q,.xN'+ʯ*l*@t~6ebb [Qk2 ?dlSY LO%1l&57.3ms0jN͍LRLumShiny/inst/shiny/abanico/Global.R0000644000175100001440000000034713053072440017212 0ustar hornikusers## global.R ## library(Luminescence) library(RLumShiny) library(shiny) library(data.table) library(rhandsontable) # load example data data(ExampleData.DeValues, envir = environment()) enableBookmarking(store = "server")RLumShiny/inst/shiny/histogram/0000755000175100001440000000000013122171652016266 5ustar hornikusersRLumShiny/inst/shiny/histogram/ui.R0000644000175100001440000006356513122171652017045 0ustar hornikusersfunction(request) { fluidPage( titlePanel(NULL, windowTitle = "RLumShiny - Histogram"), sidebarLayout( 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, .csv, text/csv"), # rhandsontable input/output fluidRow( column(width = 6, rHandsontableOutput(outputId = "table_in_primary") ), column(width = 6) ), 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 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::sideBarLayout bookmarkButton() )##EndOf::fluidPage }RLumShiny/inst/shiny/histogram/server.R0000644000175100001440000002231013052620504017712 0ustar hornikusers## Server.R ## MAIN FUNCTION function(input, output, session) { # input data (with default) values <- reactiveValues(data = ExampleData.DeValues$CA1) # check and read in file (DATA SET 1) observeEvent(input$file1, { inFile<- input$file1 if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL values$data <- fread(file = inFile$datapath, data.table = FALSE) # inFile[1] contains filepath }) # dynamically inject sliderInput for x-axis range output$xlim<- renderUI({ # check if file is loaded # # case 1: yes -> slinderInput with custom values xlim.plot<- range(hist(values$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$table_in_primary <- renderRHandsontable({ rhandsontable(values$data, height = 300, colHeaders = c("Dose", "Error"), rowHeaders = NULL) }) observeEvent(input$table_in_primary, { # Workaround for rhandsontable issue #138 # https://github.com/jrowen/rhandsontable/issues/138 # See detailed explanation in abanico application df_tmp <- input$table_in_primary row_names <- as.list(as.character(seq_len(length(df_tmp$data)))) df_tmp$params$rRowHeaders <- row_names df_tmp$params$rowHeaders <- row_names df_tmp$params$rDataDim <- as.list(c(length(row_names), length(df_tmp$params$columns))) if (df_tmp$changes$event == "afterRemoveRow") df_tmp$changes$event <- "afterChange" if (!is.null(hot_to_r(df_tmp))) values$data <- hot_to_r(df_tmp) }) 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) 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 = values$data, na.rm = TRUE, 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 header <- paste("# To reproduce the plot in your local R environment", "# copy and run the following code to your R console.", "library(Luminescence)", "library(data.table)", "file<- file.choose()", "data <- data.table::fread(file, data.table = FALSE)", "\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()); }); }", { setNames(values$data, c("De", "De error")) })##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), { t<- as.data.frame(matrix(nrow = length(list(values$data)), ncol = 7)) colnames(t)<- c("Data set","n", "log data", "Central dose", "SE abs.", "OD (%)", "OD error (%)") res<- lapply(list(values$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::function(input, output)RLumShiny/inst/shiny/histogram/www/0000755000175100001440000000000013055562161017116 5ustar hornikusersRLumShiny/inst/shiny/histogram/www/GitHub-Mark-32px.png0000644000175100001440000000326213020024066022460 0ustar hornikusersPNG  IHDR szztEXtSoftwareAdobe ImageReadyqe<$iTXtXML:com.adobe.xmp $IDATxėmhayL30A+R#f>IHکy(M)_o5 0+0Ėl&o{i^]u<{Yws}=uC>$L, }<w}8^ AO?p! xaяPKI3`'B>0QT1<+`}^nvkp^ƅF|1"Gp.*oO׀Vp ]߅jc8K$q 8jV`#`vmpGѢu!#}#:U_?_yhE $=;c*xNOo+&w)%K-R%6n'o">j/t³qoGW7j%2q GX?woibCÐAzbǰt \14|S.DZ]# b|H$(ʕohmqͱRP셣$,0Z20 tNvRW3K8Xk2 IO6 H3Q5 B.@ $pd!s#~<<+"x M0B\t8K@zB@F&S`cbP-`'{[! eDh;VEX0fK9-0IWfH  0Q){`##xFW<+*x<$9E[-qWW.(I+6aa@.y24x6_-"bbϫp@t~,/;m%h^ uf@Wp~<5j>{-]cK'Xto(hw?G%fIq^D$.Tʳ?D*A, `6B$BB dr`)B(Ͱ*`/@4Qhp.U=pa( Aa!ڈbX#!H$ ɈQ"K5H1RT UH=r9\F;2G1Q= C7F dt1r=6Ыhڏ>C03l0.B8, c˱" VcϱwE 6wB aAHXLXNH $4 7 Q'"K&b21XH,#/{C7$C2'ITFnR#,4H#dk9, +ȅ3![ b@qS(RjJ4e2AURݨT5ZBRQ4u9̓IKhhitݕNWGw Ljg(gwLӋT071oUX**| J&*/Tު UUT^S}FU3S ԖUPSSg;goT?~YYLOCQ_ cx,!k u5&|v*=9C3J3WRf?qtN (~))4L1e\kXHQG6EYAJ'\'GgSSݧ M=:.kDwn^Loy}/TmG X $ <5qo</QC]@Caaᄑ.ȽJtq]zۯ6iܟ4)Y3sCQ? 0k߬~OCOg#/c/Wװwa>>r><72Y_7ȷOo_C#dz%gA[z|!?:eAAA!h쐭!ΑiP~aa~ 'W?pX15wCsDDDޛg1O9-J5*>.j<74?.fYXXIlK9.*6nl {/]py.,:@LN8A*%w% yg"/6шC\*NH*Mz쑼5y$3,幄'L Lݛ:v m2=:1qB!Mggfvˬen/kY- BTZ(*geWf͉9+̳ې7ᒶKW-X潬j9(xoʿܔĹdff-[n ڴ VE/(ۻCɾUUMfeI?m]Nmq#׹=TR+Gw- 6 U#pDy  :v{vg/jBFS[b[O>zG499?rCd&ˮ/~јѡ򗓿m|x31^VwwO| (hSЧc3-gAMA|Q cHRMz%u0`:o_FiIDATx}td%! )+7ږJ["\wKIQl7YWtFuftZǙ]=8n-Ot) q\p7ab SZMM@z K[yӧO?_7n\ pw~ \i$eo .<_: @IpB^D=c,JN+߻jժ8|()ٞ /MMM#g̙d\]w5f߾}}vP2.^zTq㢯ψ˼W馛FGN#P.NȦG"suhll4(E%>F]]Q~o=6mdPcbŊZ|ب˼xaPl."o,۷o7.E˼۷… K;|XRJw}~(T_u^^矏F?mƼ|>{WkΜ9 sl瞲^O$y1qIJƍ>?qZ*/,YR߳?8F-uy۷o VOF8GrWXQIU\VZ~OVײo߾ؾ}>F$yӧW4nܸ2oΜ9U5GN? [/o .گ矏F?Uc^]]]U}G9{`]vEL:)de1!Ҭ!UVǴi?Y>K苧鍈m{N}?SJ_m[2#@%6 qw;4T>u>o_ODPVbcލ7X3_}b5502|eXV"c?9E__H6;OYO?{P+z{{cժU̙30Q>= v@$&-Y$1ߔؾ}{x~BA"1oo߾D}c.\~B^GeqHDļ\.oΊ+S Z~OϸRc^O7gժU>p۾/zNDx0c^>^oЍ7~RDz_ž>`j:s=۷/={VSOHl;|pZ*ߤn)5ɿ "٘w;=c?:tƇO,P^|@ }XpaYO-P5<6 KKf"žhf5Yr\*YsO<~j~VTHż/SZjUٟY o Mg߁}wBy/B{ゥ-Y$%Oxt T̻뮻R ۷o_l߾=nF?@Ѹ 5>ߑ"~. 1ZJjb^.(+V<`('o<{<J*b^(UV?hll4P>ܰ5"ؾϣ1H o։y@<<BБczf@by@ܻ?:7l@y@"?H41i|>6u툮m{<Oj@y@MH31 O["%UMC%U%ǃ_vU<*xT'q"νsֈ!F@G=O5#B;tX^9zNxp~۱G"Z(1( /s̳ŗlr (1|>+ /2xPb0lV>>*Aŗ^U_Gj<`H!gZ>b R KNζ=GE<Rb<\|i;!@ sŮj)5 j)PqEsܰUÑ" <(5m <8G\}'<<8/r7e!(yc-Pnb¡#⾕ y@Yy0B; [<3 T<5m]=BP1b Tmq)7^\|QL0..ln_a$H01Bo1S.yCןuuugZ 'A\}'<EګrlH71`0=?0pN^.0 "57b4B0g qascwZHpw)154qG y._y\Eb%Amk5Gfx, <1T NwY q'A x%OƧ%p[hO|o<(m[ ̾WJ7?54raA8Ẹ:r,qGmkR $QU|ܷ!!Txڣ $QU> yHyT޾ D<FḲ*<@\yT#D<Ẹ|NI%Plbm{|N35.>%raA(1y͏#1D<JṂ"Kk6 y$ָܶh\s|%1Id<*scCP涵FD_{A(91;tX15mK(|>|ԬrP @ىyʯ|Cȣ& ~.GOo*Ḅl~d8xԜm+/f *J̣,|Zj-]:7luGUp@y̓_G ^}}q Q 6WyEQWWg81asGmk2scc*8< Z yP<s25^+E23-yP|bcWw!5!JC5a>Wy#o~% ;7"@y¦o#!qJw#q[\1"sZ!D#""|8x ָܶ+cc@yDD} <m|!//涵nH1/|^^]FFH!Wy\b^8x)*IK_z)*MK'z/RU$PORU$P]!e涵u4$@FH2s`b^?KmNK'2O\p! ļ'"sZchļz$#@ y w)[b^y#ܶhb^>wܛlSq^|)"%sM;:n20ORbn[k̼l! Eļ&|30dfH1/A6=7BJ<H/1/A~p>/MK˼47RLKggxӔ)&Abb^Be^*44RLK5B]>} <ozF\=-Fk#$ <d yP涵F}@کP#)'@ !ᮻ #b^R'O!ZyP+<\|1j yP+<b1j5B!@FyP#<bԀ_7KK9W_ayNbԘ=RHK7Mhرq#@ y R__fN7D WK/RFK:# )#%̕o))#%7]b-0s)Q[H1/a]8)Q[H1/a6])_RBK#ؾm{;RBK٭o1Ba#@ y tٛh! ļ4q`a@:y 42{b~pb^BaFH>t1$P_sRfwwOt}o! ļsF۱u$Po2K0Ru$P FH)y\b^]KB ļ[0wRu$`3/sRu$`Z!\@y !\@y w˂9FHOtl۱Pļ-'63T11/CJD5گ1[({ >7Q-<(xԖsBOb^[!8'AϿ0#R{{;ޮg[?1`<:b/ z0 bg:b z{1`" c\aޥqQA zg;c ΣTvw?x`7Bc|v'/^z PǰΣԺ+>yߚ/g 1"(=Wޛn f[1\1b\Qr//|-e0#{ ( _*>TsǨym۱|m)c?01[[[o!(nz>RvwCϟ#G5 QT3N2 W߉P<06{bՃ#>J&Qt !QuXcjGI_UaYz~z od>}'?yTx\pQzb%3eldo!"BУ*=ӧܒqKfQjb%' AU۱:@U({/-Uo0WqWYuuuy%&xܖ1?wĕO3 UC̣,l<*b-7=?4-#%Qu|~i#0\bUVz[^iNJom}sdo!"|~sz{hweo뮙uuuH91' Aj F=15n̉mPo:Tp̚9/VkOeG26>t;sVA~Ջ{ڷ^\ _?]x]wѱx~\d^'NGpOE㎎˧ A%n-|q*D#xpX|q(#1074?G%rc'GkƧ%&G\2iB|wD熭Pb~UT@w5W˦z+.9H,A*ފ;59=.|#G_Uw!OЃ|+CsZq͑;;̾;V}[qQ5eԘ Ώ?Y\@ XOzUN!߽4> 2cd/*kxAT'18d:r,[PD1[`H3NrGo<`XuŲw(@x]ns-<`zJe0j__;36u툮m{\@y?" b-qQQJMø>OJgEt\%~U1Y-<=(y@Ųc>tLJ!߽4?eQol2g}.fdIH|wMo 0LbP13N6T̡#Ǣ!`D__Ƌ/|*E}@y@xx sLݟ.^"%/uԵCȣ\6 *|u_}'"A-ChinY3gbn+CE߱g#O?/C V~((KHN};o~X?N>q|S&A?547 O^}}7ힾ#ⷱO?k&A]U岙fCT W?ypБc)yRmvGAlԣT1RБcwtblCT1R辕ʣ\6 y2;7Cjok=)ӹa< e37UJ̃ٸQ#PP.E)kWy iFbbĦB岙fCT91Rŗ^m{ AA-͍1cdCT91R`W*rLܾd!j d8x'M0@  WyfFy`޾S&ئ1b$u]QP.yP?yUCjokuPc]e-͍1k C$5fW*rLܾd!J̃d8x'M0@ByPC֮*rLq!L̃q1Wy iꔉq `bԈ6ʣ\6K7@‰yP9}' AAW]1-61@‰yP\1\6 m{ f͜a"B̃ԵU岙x )bTHRKscL4"A]U岙}C bT3>5M2U!A|iFWyfb5<(CGEo CP)clCbu]QP.ws!8#1hR{[k3:7luGAl&2f<({rLܺ`N<(|>*aΕF`HbB岙XnJ̃ѵm!(1f͜aJ̃[oʣ\6/Y`Ẽ?~21C5s( 1F`SWyfw,6%#0?*!47I @Ɉy0LkoqGAl&n_̳ŁG AASLt@ɉy0 _ZU岙Xx!(91Бcw4u4gzfWyf]\hB̃!ܻUCjok_:CPb sVWyf"3o!(1 عw((ĭ D}}1(1 ϻns(+1`S!rLt,j7e'ڶf0e'7\QP.ۗ,0!iZc "<8[\Q<*M̃9t䘫<4uDWyTzfWyfb<^0]uŴ4T*岙6TGܻUCjokzCPqb׹a< e37T1Tζ=F\6]P5<4k #Xb5cS! m{ f͜aRỊl*rLq!H-1<3M6%Q5֮*rLܾd!H51d8x4uĘwY4Z#i<*bS!rLt,j7Gڶf0G=oʣ\6/Y`81?~2vuZc 3(뷸ʣ Wy0419tX8x4uDWy01Yn< e3t|C<Бcw4u401pPrLܙpb%s~Wy 5 g!Qrʣ\6y  QRٶfcQ<&1G]1Y3gỊd6u(h*>1[*FḤ$V~((KFḤZc (뷸ʣ\6wtl1:t䘫<4uĸhQ(6ʣ\6K7G:r,zNZclC(y}+rGAl&2f΁GQܻ 5 @̣(:7luGAl&C98g7?j e3ѱ=HڶUC5s<ɦB岙fC@yZѵm!(1fLl(1Q[~< e3q"'Ƙ:7luǐn5M2UGA_ZU岙Xx!<Бcw4u4PFbgzfWyf-2x{cHmQ__o(31ܰU岙̛m1Wζ=F\6.**D|>o~UCaΕF 8eS!rLt,j7TGD*# 1f͜a 1Xoʣ\6/Y`01?~2 []1_k!b^Bm!QP.E#%P>m{ f͜a1b^=oʣ\6c!y d147I 5HK뷸ʣ\6/Y`Qb^m{\1Y3gR@̫rvyfΎ )!U_z9147ƌi>B̫b-Wyf% )"U'Ƙm{ f͜aH91 |UÑQe3ѱ$aL>=VX/Af0jժhjj5ƨBbB.ۗ,0c}vcT1F1&O`?.\mmmk*  m'N+VD>7Hy0BSLt@*Z*~~/1*D̃e3t|C}?~|<(31F+ئ1 ꫯx R&b S.m ٷo_455Ŋ+Qb S{[k`ժUQWW۷o7F y0 l&2fb…1~8|1J@̃e3ѱU SL>=r+21aFzG)>cCF{<"`-͍c…΁䲙}C@۷/O+Vyz A-͍1yC@ Z*sM1F@̃3e3e %}ypSLMc epdb󴵞qP٪z*Su+4^)RkߥЉtB&!dfD1cV0dd/0ɽM$>>>zm>|36cuu5v\\\h'#7+rt4#<@x ,C3jZk{<֭[1ݻggg0k>|Ƞpj5v ̃xT*idXӉR~{4D^Z'''Z0k>| f<z4HMȨ5ATx"k-M&I^pߏz7w&kMВ$n[[[\0I4cmm-Wrv;...r.atbyy97y>Z~!q܌o.yp8h W0Bt:Q*{05 (ͨjq||Zyxɓ(J3U0>^GVL#KX__v=yz<Nj5^쾘[ <4MG?<$I(AT*!K>ߍhsEj<og%/M8< ]qxx+++~On`a%I^/Aa jnF*̚y,Vxpk73iZa{  Ӓ$n[㴟-UĹx3i4JE3>  3$pXxqLz1y0W;;;1LŻl4Mw v0SIQ A5 nFЌ+ qV+ϣlh7XRDLiK4ceeE3<.Iz1 yS$`vh4-͘2aSj4ok"iښfܰ<`p-IDuvvvvślF{{{QT4cvJ?}'W$ph.ޜ9f /1yqW""ZVL&h41?4~o.^9f @Dwtt@ :E[L>y煋0 L|10?f@|v]k /\9f ōui]ug@nΕ7l`|?\+o+OvVՃ}UV:Ws-7m+Ov}sVJ!cSY+rfjY9@L5/+g@X@7rDypcXyQ  n<,l&4nȉnb[z,D]z,[X{dIXxs{Zf/s6ٙIENDB`RLumShiny/inst/shiny/histogram/www/style.css0000644000175100001440000000242713055560564021002 0ustar hornikusers.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; } .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; } .label, .badge { font-size: 12px; padding: 4px 20px; margin: 10px; line-height: 18px; } .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; } RLumShiny/inst/shiny/histogram/shiny_bookmarks/0000755000175100001440000000000013052620605021467 5ustar hornikusersRLumShiny/inst/shiny/histogram/shiny_bookmarks/1c021999f0efd158/0000755000175100001440000000000013052620605023633 5ustar hornikusersRLumShiny/inst/shiny/histogram/shiny_bookmarks/1c021999f0efd158/input.rds0000644000175100001440000000346113052620605025510 0ustar hornikusersZKEyE^1uYXw^+p ۵fˢW4 111b.D!^ xxP&Vz1xt}]_wI$K]IۅkO?:W3Qtz夔EtZćН ؃~reժ9UvRa]tTzLs +iKquG,\j@mXݭj:_.zD"eIJ ضLS 6j,=8ic@soGU77/$uH[5J)6` d]1m~c4Xw|n+H-]/ʉM7Y,8 6ݘp{.wmTox@^ntKgr=|\qA,&j]!G>,:'}U!iDwk񈩼:f+oeccY_YIWA92~w MoĞ. ތi6;4޻%ҳŽg~Xyd߂6xQ ]$o?o˽1~u֯|vYGS}~#_vx&~ޖ7T3Ͷw{c֘y ŪU3 A Zj\dUku2cC *д*DY|Kiqu~]TkNoB$N lǂҜ$bpb<%A( &xx-SŽ5OLs!"}5N[A Sjl\ݽ/K=fb$1'j*V2H|OcLJ^ o-X= qWAc L`MhIuiQTf"y*g` =]\DX)ܳT9Pj5TUEIz\Si=` :Du5%hvP!]2Kt~8UW`<#{&reH6Ou>|Oncߡe{n}u~dư~ɼ_awXᷨ9mFnǫ#knxn߭xY^CĽ;$}-o8ܷl2?G~eI?)~xz&?J,;x:6oD]Yɼ-`鎃eo6I{'γ}DI\l\{ wuvvǷwj/} v_I Wn zЙIS rG LOJ4ʅr$[4 J-杚ɥ%t4#Yt2Ѷv2QdLu2N&t2N&2Q&=VNiiBGפjZ* :=EJ=Sӎc;J4f5ZVc/<y^Ή"(q^T'v UdVtWţu5SVs9/p 9/p 9/p. YxR  p. (p. (p. (p. K$p. K$p. Ky\<.pǜi0{#e~ɉ \)ۅ.c $896bZ1}OzU1A_U4<%|Ā {thd Cl}-^l](H$>:TVd]ꐩC;rEP`TQLw}hȠIMbӲ2!J^L|f$zA04݃XGug8KƜI1TgW 脪y{U8S)$r y0-7-iZTL-Nס^S'OU`Y\ρVfpgͶ<V^K*b+P G \ LoK@+( :J|EQD _moֹYYG?4*8|@5;6}T(-Z I^˞FA~`_O'9_WQPjK[y:§w&:Lw&s1ވkIJ!Ir`;*A*N,TԖV8:i5'sڼ5X ̜YƖ( 0B'Cq-CvKC|'&cG',8Ɗ˕rSɌY Ey}mk^FZ*CooCaWH71{S G 劉k0 W .0RLumShiny/inst/shiny/histogram/Global.R0000644000175100001440000000036213052617417017620 0ustar hornikusers## global.R ## library(Luminescence) library(shiny) library(RLumShiny) library(rhandsontable) library(data.table) # load example data data(ExampleData.DeValues) data <- ExampleData.DeValues$CA1 enableBookmarking(store = "server")RLumShiny/inst/shiny/transformCW/0000755000175100001440000000000013055562161016542 5ustar hornikusersRLumShiny/inst/shiny/transformCW/www/0000755000175100001440000000000013055562161017366 5ustar hornikusersRLumShiny/inst/shiny/transformCW/www/GitHub-Mark-32px.png0000644000175100001440000000326213020024066022730 0ustar hornikusersPNG  IHDR szztEXtSoftwareAdobe ImageReadyqe<$iTXtXML:com.adobe.xmp $IDATxėmhayL30A+R#f>IHکy(M)_o5 0+0Ėl&o{i^]u<{Yws}=uC>$L, }<w}8^ AO?p! xaяPKI3`'B>0QT1<+`}^nvkp^ƅF|1"Gp.*oO׀Vp ]߅jc8K$q 8jV`#`vmpGѢu!#}#:U_?_yhE $=;c*xNOo+&w)%K-R%6n'o">j/t³qoGW7j%2q GX?woibCÐAzbǰt \14|S.DZ]# b|H$(ʕohmqͱRP셣$,0Z20 tNvRW3K8Xk2 IO6 H3Q5 B.@ $pd!s#~<<+"x M0B\t8K@zB@F&S`cbP-`'{[! eDh;VEX0fK9-0IWfH  0Q){`##xFW<+*x<$9E[-qWW.(I+6aa@.y24x6_-"bbϫp@t~,/;m%h^ uf@Wp~<5j>{-]cK'Xto(hw?G%fIq^D$.Tʳ?D*A, `6B$BB dr`)B(Ͱ*`/@4Qhp.U=pa( Aa!ڈbX#!H$ ɈQ"K5H1RT UH=r9\F;2G1Q= C7F dt1r=6Ыhڏ>C03l0.B8, c˱" VcϱwE 6wB aAHXLXNH $4 7 Q'"K&b21XH,#/{C7$C2'ITFnR#,4H#dk9, +ȅ3![ b@qS(RjJ4e2AURݨT5ZBRQ4u9̓IKhhitݕNWGw Ljg(gwLӋT071oUX**| J&*/Tު UUT^S}FU3S ԖUPSSg;goT?~YYLOCQ_ cx,!k u5&|v*=9C3J3WRf?qtN (~))4L1e\kXHQG6EYAJ'\'GgSSݧ M=:.kDwn^Loy}/TmG X $ <5qo</QC]@Caaᄑ.ȽJtq]zۯ6iܟ4)Y3sCQ? 0k߬~OCOg#/c/Wװwa>>r><72Y_7ȷOo_C#dz%gA[z|!?:eAAA!h쐭!ΑiP~aa~ 'W?pX15wCsDDDޛg1O9-J5*>.j<74?.fYXXIlK9.*6nl {/]py.,:@LN8A*%w% yg"/6шC\*NH*Mz쑼5y$3,幄'L Lݛ:v m2=:1qB!Mggfvˬen/kY- BTZ(*geWf͉9+̳ې7ᒶKW-X潬j9(xoʿܔĹdff-[n ڴ VE/(ۻCɾUUMfeI?m]Nmq#׹=TR+Gw- 6 U#pDy  :v{vg/jBFS[b[O>zG499?rCd&ˮ/~јѡ򗓿m|x31^VwwO| (hSЧc3-gAMA|Q cHRMz%u0`:o_FiIDATx}td%! )+7ږJ["\wKIQl7YWtFuftZǙ]=8n-Ot) q\p7ab SZMM@z K[yӧO?_7n\ pw~ \i$eo .<_: @IpB^D=c,JN+߻jժ8|()ٞ /MMM#g̙d\]w5f߾}}vP2.^zTq㢯ψ˼W馛FGN#P.NȦG"suhll4(E%>F]]Q~o=6mdPcbŊZ|ب˼xaPl."o,۷o7.E˼۷… K;|XRJw}~(T_u^^矏F?mƼ|>{WkΜ9 sl瞲^O$y1qIJƍ>?qZ*/,YR߳?8F-uy۷o VOF8GrWXQIU\VZ~OVײo߾ؾ}>F$yӧW4nܸ2oΜ9U5GN? [/o .گ矏F?Uc^]]]U}G9{`]vEL:)de1!Ҭ!UVǴi?Y>K苧鍈m{N}?SJ_m[2#@%6 qw;4T>u>o_ODPVbcލ7X3_}b5502|eXV"c?9E__H6;OYO?{P+z{{cժU̙30Q>= v@$&-Y$1ߔؾ}{x~BA"1oo߾D}c.\~B^GeqHDļ\.oΊ+S Z~OϸRc^O7gժU>p۾/zNDx0c^>^oЍ7~RDz_ž>`j:s=۷/={VSOHl;|pZ*ߤn)5ɿ "٘w;=c?:tƇO,P^|@ }XpaYO-P5<6 KKf"žhf5Yr\*YsO<~j~VTHż/SZjUٟY o Mg߁}wBy/B{ゥ-Y$%Oxt T̻뮻R ۷o_l߾=nF?@Ѹ 5>ߑ"~. 1ZJjb^.(+V<`('o<{<J*b^(UV?hll4P>ܰ5"ؾϣ1H o։y@<<BБczf@by@ܻ?:7l@y@"?H41i|>6u툮m{<Oj@y@MH31 O["%UMC%U%ǃ_vU<*xT'q"νsֈ!F@G=O5#B;tX^9zNxp~۱G"Z(1( /s̳ŗlr (1|>+ /2xPb0lV>>*Aŗ^U_Gj<`H!gZ>b R KNζ=GE<Rb<\|i;!@ sŮj)5 j)PqEsܰUÑ" <(5m <8G\}'<<8/r7e!(yc-Pnb¡#⾕ y@Yy0B; [<3 T<5m]=BP1b Tmq)7^\|QL0..ln_a$H01Bo1S.yCןuuugZ 'A\}'<EګrlH71`0=?0pN^.0 "57b4B0g qascwZHpw)154qG y._y\Eb%Amk5Gfx, <1T NwY q'A x%OƧ%p[hO|o<(m[ ̾WJ7?54raA8Ẹ:r,qGmkR $QU|ܷ!!Txڣ $QU> yHyT޾ D<FḲ*<@\yT#D<Ẹ|NI%Plbm{|N35.>%raA(1y͏#1D<JṂ"Kk6 y$ָܶh\s|%1Id<*scCP涵FD_{A(91;tX15mK(|>|ԬrP @ىyʯ|Cȣ& ~.GOo*Ḅl~d8xԜm+/f *J̣,|Zj-]:7luGUp@y̓_G ^}}q Q 6WyEQWWg81asGmk2scc*8< Z yP<s25^+E23-yP|bcWw!5!JC5a>Wy#o~% ;7"@y¦o#!qJw#q[\1"sZ!D#""|8x ָܶ+cc@yDD} <m|!//涵nH1/|^^]FFH!Wy\b^8x)*IK_z)*MK'z/RU$PORU$P]!e涵u4$@FH2s`b^?KmNK'2O\p! ļ'"sZchļz$#@ y w)[b^y#ܶhb^>wܛlSq^|)"%sM;:n20ORbn[k̼l! Eļ&|30dfH1/A6=7BJ<H/1/A~p>/MK˼47RLKggxӔ)&Abb^Be^*44RLK5B]>} <ozF\=-Fk#$ <d yP涵F}@کP#)'@ !ᮻ #b^R'O!ZyP+<\|1j yP+<b1j5B!@FyP#<bԀ_7KK9W_ayNbԘ=RHK7Mhرq#@ y R__fN7D WK/RFK:# )#%̕o))#%7]b-0s)Q[H1/a]8)Q[H1/a6])_RBK#ؾm{;RBK٭o1Ba#@ y tٛh! ļ4q`a@:y 42{b~pb^BaFH>t1$P_sRfwwOt}o! ļsF۱u$Po2K0Ru$P FH)y\b^]KB ļ[0wRu$`3/sRu$`Z!\@y !\@y w˂9FHOtl۱Pļ-'63T11/CJD5گ1[({ >7Q-<(xԖsBOb^[!8'AϿ0#R{{;ޮg[?1`<:b/ z0 bg:b z{1`" c\aޥqQA zg;c ΣTvw?x`7Bc|v'/^z PǰΣԺ+>yߚ/g 1"(=Wޛn f[1\1b\Qr//|-e0#{ ( _*>TsǨym۱|m)c?01[[[o!(nz>RvwCϟ#G5 QT3N2 W߉P<06{bՃ#>J&Qt !QuXcjGI_UaYz~z od>}'?yTx\pQzb%3eldo!"BУ*=ӧܒqKfQjb%' AU۱:@U({/-Uo0WqWYuuuy%&xܖ1?wĕO3 UC̣,l<*b-7=?4-#%Qu|~i#0\bUVz[^iNJom}sdo!"|~sz{hweo뮙uuuH91' Aj F=15n̉mPo:Tp̚9/VkOeG26>t;sVA~Ջ{ڷ^\ _?]x]wѱx~\d^'NGpOE㎎˧ A%n-|q*D#xpX|q(#1074?G%rc'GkƧ%&G\2iB|wD熭Pb~UT@w5W˦z+.9H,A*ފ;59=.|#G_Uw!OЃ|+CsZq͑;;̾;V}[qQ5eԘ Ώ?Y\@ XOzUN!߽4> 2cd/*kxAT'18d:r,[PD1[`H3NrGo<`XuŲw(@x]ns-<`zJe0j__;36u툮m{\@y?" b-qQQJMø>OJgEt\%~U1Y-<=(y@Ųc>tLJ!߽4?eQol2g}.fdIH|wMo 0LbP13N6T̡#Ǣ!`D__Ƌ/|*E}@y@xx sLݟ.^"%/uԵCȣ\6 *|u_}'"A-ChinY3gbn+CE߱g#O?/C V~((KHN};o~X?N>q|S&A?547 O^}}7ힾ#ⷱO?k&A]U岙fCT W?ypБc)yRmvGAlԣT1RБcwtblCT1R辕ʣ\6 y2;7Cjok=)ӹa< e37UJ̃ٸQ#PP.E)kWy iFbbĦB岙fCT91Rŗ^m{ AA-͍1cdCT91R`W*rLܾd!j d8x'M0@  WyfFy`޾S&ئ1b$u]QP.yP?yUCjokuPc]e-͍1k C$5fW*rLܾd!J̃d8x'M0@ByPC֮*rLq!L̃q1Wy iꔉq `bԈ6ʣ\6K7@‰yP9}' AAW]1-61@‰yP\1\6 m{ f͜a"B̃ԵU岙x )bTHRKscL4"A]U岙}C bT3>5M2U!A|iFWyfb5<(CGEo CP)clCbu]QP.ws!8#1hR{[k3:7luGAl&2f<({rLܺ`N<(|>*aΕF`HbB岙XnJ̃ѵm!(1f͜aJ̃[oʣ\6/Y`Ẽ?~21C5s( 1F`SWyfw,6%#0?*!47I @Ɉy0LkoqGAl&n_̳ŁG AASLt@ɉy0 _ZU岙Xx!(91Бcw4u4gzfWyf]\hB̃!ܻUCjok_:CPb sVWyf"3o!(1 عw((ĭ D}}1(1 ϻns(+1`S!rLt,j7e'ڶf0e'7\QP.ۗ,0!iZc "<8[\Q<*M̃9t䘫<4uDWyTzfWyfb<^0]uŴ4T*岙6TGܻUCjokzCPqb׹a< e37T1Tζ=F\6]P5<4k #Xb5cS! m{ f͜aRỊl*rLq!H-1<3M6%Q5֮*rLܾd!H51d8x4uĘwY4Z#i<*bS!rLt,j7Gڶf0G=oʣ\6/Y`81?~2vuZc 3(뷸ʣ Wy0419tX8x4uDWy01Yn< e3t|C<Бcw4u401pPrLܙpb%s~Wy 5 g!Qrʣ\6y  QRٶfcQ<&1G]1Y3gỊd6u(h*>1[*FḤ$V~((KFḤZc (뷸ʣ\6wtl1:t䘫<4uĸhQ(6ʣ\6K7G:r,zNZclC(y}+rGAl&2f΁GQܻ 5 @̣(:7luGAl&C98g7?j e3ѱ=HڶUC5s<ɦB岙fC@yZѵm!(1fLl(1Q[~< e3q"'Ƙ:7luǐn5M2UGA_ZU岙Xx!<Бcw4u4PFbgzfWyf-2x{cHmQ__o(31ܰU岙̛m1Wζ=F\6.**D|>o~UCaΕF 8eS!rLt,j7TGD*# 1f͜a 1Xoʣ\6/Y`01?~2 []1_k!b^Bm!QP.E#%P>m{ f͜a1b^=oʣ\6c!y d147I 5HK뷸ʣ\6/Y`Qb^m{\1Y3gR@̫rvyfΎ )!U_z9147ƌi>B̫b-Wyf% )"U'Ƙm{ f͜aH91 |UÑQe3ѱ$aL>=VX/Af0jժhjj5ƨBbB.ۗ,0c}vcT1F1&O`?.\mmmk*  m'N+VD>7Hy0BSLt@*Z*~~/1*D̃e3t|C}?~|<(31F+ئ1 ꫯx R&b S.m ٷo_455Ŋ+Qb S{[k`ժUQWW۷o7F y0 l&2fb…1~8|1J@̃e3ѱU SL>=r+21aFzG)>cCF{<"`-͍c…΁䲙}C@۷/O+Vyz A-͍1yC@ Z*sM1F@̃3e3e %}ypSLMc epdb󴵞qP٪z*Su+4^)RkߥЉtB&!dfD1cV0dd/0ɽM$>>>zm>|36cuu5v\\\h'#7+rt4#<@x ,C3jZk{<֭[1ݻggg0k>|Ƞpj5v ̃xT*idXӉR~{4D^Z'''Z0k>| f<z4HMȨ5ATx"k-M&I^pߏz7w&kMВ$n[[[\0I4cmm-Wrv;...r.atbyy97y>Z~!q܌o.yp8h W0Bt:Q*{05 (ͨjq||Zyxɓ(J3U0>^GVL#KX__v=yz<Nj5^쾘[ <4MG?<$I(AT*!K>ߍhsEj<og%/M8< ]qxx+++~On`a%I^/Aa jnF*̚y,Vxpk73iZa{  Ӓ$n[㴟-UĹx3i4JE3>  3$pXxqLz1y0W;;;1LŻl4Mw v0SIQ A5 nFЌ+ qV+ϣlh7XRDLiK4ceeE3<.Iz1 yS$`vh4-͘2aSj4ok"iښfܰ<`p-IDuvvvvślF{{{QT4cvJ?}'W$ph.ޜ9f /1yqW""ZVL&h41?4~o.^9f @Dwtt@ :E[L>y煋0 L|10?f@|v]k /\9f ōui]ug@nΕ7l`|?\+o+OvVՃ}UV:Ws-7m+Ov}sVJ!cSY+rfjY9@L5/+g@X@7rDypcXyQ  n<,l&4nȉnb[z,D]z,[X{dIXxs{Zf/s6ٙIENDB`RLumShiny/inst/shiny/transformCW/www/style.css0000644000175100001440000000242713055561031021240 0ustar hornikusers.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; } .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; } .label, .badge { font-size: 12px; padding: 4px 20px; margin: 10px; line-height: 18px; } .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; } RLumShiny/inst/shiny/transformCW/UI.R0000644000175100001440000003754613055562161017221 0ustar hornikusers## UI.R function(request) { fluidPage( titlePanel(NULL, windowTitle = "RLumShiny - transformCW"), sidebarLayout( # 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, .csv, text/csv"), # rhandsontable input/output fluidRow( column(width = 6, rHandsontableOutput(outputId = "table_in_primary") ), column(width = 6) ) ),##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
"), jscolorInput(inputId = "jscol1")) ) ), br(), checkboxInput(inputId = "showCW", label = "Show CW-OSL curve", value = TRUE), 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 = "ylab1", label = "Label y-axis (left)", value = "pseudo OSL [cts/s]"), textInput(inputId = "ylab2", label = "Label y-axis (right)", value = "CW-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 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::sideBarLayout bookmarkButton() )##EndOf::fluidPage }RLumShiny/inst/shiny/transformCW/shiny_bookmarks/0000755000175100001440000000000012772146744021756 5ustar hornikusersRLumShiny/inst/shiny/transformCW/shiny_bookmarks/cad3028cccb4abdb/0000755000175100001440000000000012772146744024532 5ustar hornikusersRLumShiny/inst/shiny/transformCW/shiny_bookmarks/cad3028cccb4abdb/input.rds0000644000175100001440000000054212765615524026403 0ustar hornikusersuRQK0n@cG YѤ)M:?/&WʁK|wiE(!~M۩Nߏ6/DH:s5-mnj-xwj'd]hPeP<=|i ïU5No-i)qluW-%oN=:K 7sfބ2Jd3&Z3L fuFW/ʷֵK%:< 8usP0˩j+墶PLm!3x[rŏ?onՕٶ Y0 eR\ `}2*ؿ_0RLumShiny/inst/shiny/transformCW/shiny_bookmarks/383978aa9a560a09/0000755000175100001440000000000012772146744024044 5ustar hornikusersRLumShiny/inst/shiny/transformCW/shiny_bookmarks/383978aa9a560a09/input.rds0000644000175100001440000000054212765755551025722 0ustar hornikusersuRQK0n@cG YѤ)M:?/&WʁK|wiE(!~M۩Nߏ6/DH:s5-mnj-xwj'd]hPeP<=|i ïU5No-i)qluW-%oN=:K 7sfބ2Jd3&Z3L fuFW/ʷֵK%:< 8usP0˩j+墶PLm!3x[rŏ?onՕٶ Y0 eR\ `}2*ؿ_0RLumShiny/inst/shiny/transformCW/shiny_bookmarks/211d00e884a92c90/0000755000175100001440000000000012772146744024026 5ustar hornikusersRLumShiny/inst/shiny/transformCW/shiny_bookmarks/211d00e884a92c90/input.rds0000644000175100001440000000054212765755566025712 0ustar hornikusersuRQK0n@cG YѤ)M:?/&WʁK|wiE(!~M۩Nߏ6/DH:s5-mnj-xwj'd]hPeP<=|i ïU5No-i)qluW-%oN=:K 7sfބ2Jd3&Z3L fuFW/ʷֵK%:< 8usP0˩j+墶PLm!3x[rŏ?onՕٶ Y0 eR\ `}2*ؿ_0RLumShiny/inst/shiny/transformCW/shiny_bookmarks/0bba99060aa8d69f/0000755000175100001440000000000012772146744024255 5ustar hornikusersRLumShiny/inst/shiny/transformCW/shiny_bookmarks/0bba99060aa8d69f/input.rds0000644000175100001440000000054412765754030026124 0ustar hornikusersuRQK0n׺" ǂ?@狏>Ta&Yr]IS^) |%o FA5j[N8hRdu+lf* "IמwìS U&&On 5d:Ij_K4/oJzi4!GQ"yi&y~yJ9kF{*ۥ84FkF<'z̤Z^Î9nXa ̘jOˁ ,z潂#@*>UWf 0ƚɂ24`n(cU-abcd}Iiq؆a 1RLumShiny/inst/shiny/transformCW/shiny_bookmarks/99c9d1b8f309e36d/0000755000175100001440000000000012772146744024216 5ustar hornikusersRLumShiny/inst/shiny/transformCW/shiny_bookmarks/99c9d1b8f309e36d/input.rds0000644000175100001440000000054212765615424026066 0ustar hornikusersuRQK0n@cG YѤ)M:?/&WʁK|wiE(!~M۩Nߏ6/DH:s5-mnj-xwj'd]hPeP<=|i ïU5No-i)qluW-%oN=:K 7sfބ2Jd3&Z3L fuFW/ʷֵK%:< 8usP0˩j+墶PLm!3x[rŏ?onՕٶ Y0 eR\ `}2*ؿ_0RLumShiny/inst/shiny/transformCW/shiny_bookmarks/f0d30b74a68561f3/0000755000175100001440000000000012772146744024113 5ustar hornikusersRLumShiny/inst/shiny/transformCW/shiny_bookmarks/f0d30b74a68561f3/input.rds0000644000175100001440000000054512765753536025775 0ustar hornikusers]RQK0@cG„C\hҔ&ݟ٫!K~w!dLԭn;;v69L~}E.PxubZB7 x/#`$2p(\^@:҄2f _KZ8iE4^CFDzO-x6[< \g/OيYs#q(x :3-ufZլD/Z,= 1) args <- append(args, delta) if (input$method == "CW2pLMi" || input$method == "CW2pPMi") if (P >= 1) args <- append(args, P) values$tdata <- try(do.call(input$method, args)) }) output$main_plot <- renderPlot({ # be reactive on method changes input$method input$delta input$p if (inherits(values$tdata, "try-error")) { plot(1, type="n", axes=F, xlab="", ylab="") text(1, labels = paste(values$tdata, collapse = "\n")) return() } pargs <- list(values$tdata[,1], values$tdata[ ,2], log = paste0(ifelse(input$logx, "x", ""), ifelse(input$logy, "y", "")), main = input$main, xlab = input$xlab, ylab = input$ylab1, type = input$type, pch = ifelse(input$pch != "custom", as.integer(input$pch) - 1, input$custompch), col = ifelse(input$color != "custom", input$color, input$jscol1), bty = "n") par(mar=c(5,4,4,5)+.1, cex = input$cex) do.call(plot, pargs) if (input$showCW) { par(new = TRUE) plot(values$data_primary, axes = FALSE, xlab = NA, ylab = NA, col = "red", type = input$type, log = paste0(ifelse(input$logx, "x", ""), ifelse(input$logy, "y", ""))) axis(side = 4, col = "red", col.axis = "red") mtext(input$ylab2, side = 4, line = 3, col = "red") } output$exportScript <- downloadHandler( filename = function() { paste(input$filename, ".", "txt", sep="") }, content = function(file) { write.table(values$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 par(mar=c(5,4,4,5)+.1, cex = input$cex) do.call(plot, args = pargs) if (input$showCW) { par(new = TRUE) plot(values$data_primary, axes = FALSE, xlab = NA, ylab = NA, col = "red", type = input$type, log = paste0(ifelse(input$logx, "x", ""), ifelse(input$logy, "y", ""))) axis(side = 4, col = "red", col.axis = "red") mtext(input$ylab2, side = 4, line = 3, col = "red") } dev.off() },#EO content =, contentType = "image" )#EndOf::dowmloadHandler() }) output$dataset <- renderDataTable({ if (!is.null(values$tdata)) values$tdata }) }##EndOf::function(input, output)RLumShiny/inst/shiny/transformCW/Global.R0000644000175100001440000000033013053275407020063 0ustar hornikusers## global.R ## library(Luminescence) library(RLumShiny) library(shiny) library(data.table) library(rhandsontable) data("ExampleData.CW_OSL_Curve", envir = environment()) enableBookmarking(store = "server")RLumShiny/inst/rstudio/0000755000175100001440000000000013020024066014621 5ustar hornikusersRLumShiny/inst/rstudio/addins.dcf0000644000175100001440000000014713020024066016543 0ustar hornikusersName: RLumShiny dashboard Description: RLumShiny dashboard Binding: RLumShinyAddin Interactive: trueRLumShiny/NAMESPACE0000644000175100001440000000047113122203110013364 0ustar hornikusers# Generated by roxygen2: do not edit by hand export(RLumShinyAddin) export(app_RLum) export(jscolorInput) export(popover) export(tooltip) import(Luminescence) import(data.table) import(googleVis) import(readxl) import(rhandsontable) import(shiny) import(shinydashboard) importFrom(utils,citation) RLumShiny/NEWS0000644000175100001440000000502713124200676012666 0ustar hornikusersRLumShiny 0.2.0 (Release date: 2017-06-26) ============== * Major overhaul of the data input panel for most applications. Uploaded text files are now imported via 'data.table::fread()', which automatically detects the delimiter and potential headers. Hence, all widgets related to data import are no longer required and were removed (#14). * The input data can now be directly manipulated in the newly added spreadsheet(s) in the data input panels. The spreadsheets also allow copy and pasting of data, so uploading a file is no longer the only way to provide user data (#12). * New Dashboard addin added. The dashboard provides access to all available applications in the package and can be accessed either (i) through the addin dropdown menu in the RStudio IDE or (ii) by running 'app_RLum()' without any keyword. * Implemented newest shiny feature (v0.14) to bookmark the current app state. All apps now include a bookmark button, which returns a URL query string that can be used to restore the app's state at any later time. * New application to plot filter combinations along with the optional net transmission. Base function: `Luminescence::plot_FilterCombinations()`. Keyword for `app_RLum()`: 'filter'. External contribution by Urs Tilmann Wolpert (Justus-Liebig-University Giessen) and Sebastian Kreutzer (Universite Bordeaux Montaigne). * New package dependencies: 'shinydashboard', 'rhandsontable', 'data.table', 'readxl' * transformCW-app: + the plot now also shows the CW-OSL data curve + improved error handling * Internal: R dcoumentation re-written in Markdown using 'roxygen2 >=6.0.0' * Several minor bugfixes. 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 releaseRLumShiny/R/0000755000175100001440000000000013122177221012361 5ustar hornikusersRLumShiny/R/popover.R0000644000175100001440000000473713124163245014214 0ustar hornikusers#' Create a bootstrap button with popover #' #' Add small overlays of content for housing secondary information. #' #' @param title [`character`] (**required**): #' Title of the button. #' #' @param content [`character`] (**required**): #' Text to be displayed in the popover. #' #' @param header [`character`] (*optional*): #' Optional header in the popover. #' #' @param html [`logical`] (*with default*): #' Insert HTML into the popover. #' #' @param class [`logical`] (*with default*): #' Bootstrap button class (e.g. "btn btn-danger"). #' #' @param placement [`character`] (*with default*): #' 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 [`character`] (*with default*): #' 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 #' #' @md #' @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-usageRLumShiny/R/jscolor.R0000644000175100001440000000546313124201151014157 0ustar hornikusers#' Create a JSColor picker input widget #' #' Creates a JSColor (Javascript/HTML Color Picker) widget to be used in shiny applications. #' #' @param inputId [`character`] (**required**): #' Specifies the input slot that will be used to access the value. #' #' @param label [`character`] (*optional*): #' Display label for the control, or NULL for no label. #' #' @param value [`character`] (*optional*): #' Initial RGB value of the color picker. Default is black ('#000000'). #' #' @param position [`character`] (*with default*): #' Position of the picker relative to the text input ('bottom', 'left', 'top', 'right'). #' #' @param color [`character`] (*with default*): #' Picker color scheme ('transparent' by default). Use RGB color coding ('000000'). #' #' @param mode [`character`] (*with default*): #' Mode of hue, saturation and value. Can either be 'HSV' or 'HVS'. #' #' @param slider [`logical`] (*with default*): #' Show or hide the slider. #' #' @param close [`logical`] (*with default*): #' Show or hide a close button. #' #' @seealso Other input.elements: [`animationOptions`], [`sliderInput`]; #' [`checkboxGroupInput`]; [`checkboxInput`]; [`dateInput`]; #' [`dateRangeInput`]; [`fileInput`]; [`numericInput`]; #' [`passwordInput`]; [`radioButtons`]; [`selectInput`], #' [`selectizeInput`]; [`submitButton`]; [`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 #' #' @md #' @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)) ) }RLumShiny/R/app_RLum.R0000644000175100001440000000547613124162330014234 0ustar hornikusers#' Run Luminescence shiny apps #' #' A wrapper for [`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: `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. If no keyword is used #' a dashboard will be started instead, from which an application can be started. #' #' \tabular{lcl}{ #' **Application name:** \tab **Keyword:** \tab **Function:** \cr #' Abanico Plot \tab *abanico* \tab [`plot_AbanicoPlot`] \cr #' Histogram \tab *histogram* \tab [`plot_Histogram`] \cr #' Kernel Density Estimate Plot \tab *KDE* \tab [`plot_KDE`] \cr #' Radial Plot \tab *radialplot* \tab [`plot_RadialPlot`] \cr #' Dose Recovery Test \tab *doserecovery* \tab [`plot_DRTResults`] \cr #' Cosmic Dose Rate \tab *cosmicdose* \tab [`calc_CosmicDoseRate`] \cr #' CW Curve Transformation \tab *transformCW* \tab [`CW2pHMi`], [`CW2pLM`], [`CW2pLMi`], [`CW2pPMi`] \cr #' Filter Combinations \tab *filter* \tab [`plot_FilterCombinations`] #' } #' #' The `app_RLum()` function is just a wrapper for [`runApp`]. #' Via the `...` argument further arguments can be directly passed to [`runApp`]. #' See `?shiny::runApp` for further details on valid arguments. #' #' #' @param app [`character`] (**required**): #' name of the application to start. See details for a list of available apps. #' #' @param ... further arguments to pass to [`runApp`] #' #' @author Christoph Burow, University of Cologne (Germany) #' #' @seealso [`runApp`] #' #' @examples #' #' \dontrun{ #' # Dashboard #' app_RLum() #' #' # Plotting apps #' app_RLum("abanico") #' app_RLum("histogram") #' app_RLum("KDE") #' app_RLum("radialplot") #' app_RLum("doserecovery") #' #' # Further apps #' app_RLum("cosmicdose") #' app_RLum("transformCW") #' app_RLum("filter") #' } #' #' @md #' @export app_RLum app_RLum <- function(app = NULL, ...) { valid_apps <- c("abanico", "cosmicdose", "doserecovery", "histogram", "KDE", "radialplot", "transformCW", "filter") if (is.null(app)) { # start the RLumShiny Dashboard Addin RLumShinyAddin() } else { # check if keyword is valid if (!any(grepl(app, valid_apps, ignore.case = TRUE))) return(message(paste0("Invalid app name: ", app, " \n Valid options are: ", paste(valid_apps, collapse = ", ")))) # start application app <- shiny::runApp(system.file(paste0("shiny/", app), package = "RLumShiny"), launch.browser = TRUE, ...) } }RLumShiny/R/tooltip.R0000644000175100001440000000632713124162760014212 0ustar hornikusers#' Create a bootstrap tooltip #' #' Create bootstrap tooltips for any HTML element to be used in shiny applications. #' #' @param refId [`character`] (**required**): #' id of the element the tooltip is to be attached to. #' #' @param text [`character`] (**required**): #' Text to be displayed in the tooltip. #' #' @param attr [`character`] (*optional*): #' Attach tooltip to all elements with attribute `attr='refId'`. #' #' @param animation [`logical`] (*with default*): #' Apply a CSS fade transition to the tooltip. #' #' @param delay [`numeric`] (*with default*): #' Delay showing and hiding the tooltip (ms). #' #' @param html [`logical`] (*with default*): #' Insert HTML into the tooltip. #' #' @param placement [`character`] (*with default*): #' 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 [`character`] (*with default*): #' 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 checkbox group", 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 #' #' @md #' @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) ) ) ) ) }RLumShiny/R/chooser.R0000644000175100001440000000323713122201770014150 0ustar hornikusers## +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ## 'chooser.R' taken from the shiny-examples repository ## (https://github.com/rstudio/shiny-examples) under the MIT License ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ chooserInput <- function(inputId, leftLabel, rightLabel, leftChoices, rightChoices, size = 5, multiple = FALSE) { shiny::registerInputHandler("shinyjsexamples.chooser", function(data, ...) { if (is.null(data)) NULL else list(left=as.character(data$left), right=as.character(data$right)) }, force = TRUE) leftChoices <- lapply(leftChoices, tags$option) rightChoices <- lapply(rightChoices, tags$option) if (multiple) multiple <- "multiple" else multiple <- NULL tagList( singleton(tags$head( tags$head(tags$script(src = "RLumShiny/chooser_inputBinding.js")), tags$style(type="text/css", HTML(".chooser-container { display: inline-block; }") ) )), div(id=inputId, class="chooser", div(class="chooser-container chooser-left-container", tags$select(class="left", size=size, multiple=multiple, leftChoices) ), div(class="chooser-container chooser-center-container", icon("arrow-circle-o-right", "right-arrow fa-3x"), tags$br(), icon("arrow-circle-o-left", "left-arrow fa-3x") ), div(class="chooser-container chooser-right-container", tags$select(class="right", size=size, multiple=multiple, rightChoices) ) ) ) }RLumShiny/R/zzz.R0000644000175100001440000000056013020024066013335 0ustar hornikusers# 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() }RLumShiny/R/RLumShiny.R0000644000175100001440000000244313124161647014410 0ustar hornikusers#' 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 [`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 [`tooltip`] and [`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 [`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 #' @docType package #' @import Luminescence shiny googleVis shinydashboard rhandsontable data.table readxl #' @importFrom utils citation #' #' @md NULLRLumShiny/R/addin.R0000644000175100001440000002170613124161545013575 0ustar hornikusers#' RLumShiny Dashboard Addin #' #' RLumShiny dashboard #' #' @export RLumShinyAddin <- function() { ## GLOBAL -------------------------------------------------------------------- # List of applications available in RLumShiny applications <- list( "abanico" = list(title = "Abanico Plot", keyword = "abanico", category = "plot", description = "A plot which allows comprehensive presentation of data precision and its dispersion around a central value as well as illustration of a kernel density estimate, histogram and/or dot plot of the dose values."), "cosmic" = list(title = "Cosmic Dose Rate", keyword = "cosmicdose", category = "calc", description = "This function calculates the cosmic dose rate taking into account the soft- and hard-component of the cosmic ray flux and allows corrections for geomagnetic latitude, altitude above sea-level and geomagnetic field changes."), "kde" = list(title = "Kernel Density Estimate Plot", keyword = "kde", category = "plot", description = "Plot a kernel density estimate of measurement values in combination with the actual values and associated error bars in ascending order."), "doserecovery" = list(title = "Dose Recovery Test", keyword = "doserecovery", category = "plot", description = "The function provides a standardised plot output for dose recovery test measurements."), "radialplot" = list(title = "Radial Plot", keyword = "radialplot", category = "plot", description = "A Galbraith's radial plot is produced on a logarithmic or a linear scale."), "histogram" = list(title = "Histogram", keyword = "histogram", category = "plot", description = "Function plots a predefined histogram with an accompanying error plot as suggested by Rex Galbraith at the UK LED in Oxford 2010."), "transformCW" = list(title = "Transform CW-OSL curves", keyword = "transformCW", category = "misc", description = "Transform a conventionally measured continuous-wave (CW) OSL-curve to a pseudo parabolic/hyperbolic/linearly modulated curve."), "filter" = list(title = "Filter Combinations", keyword = "filter", category = "misc", description = "Plot filter combinations along with the (optional) net transmission window.") ) # HELPER FUNCTIONS ------------------ split_by_category <- function(x) { # get unique categories categories <- unique(sapply(x, function(el) el$category)) # for each unique category... lst <- lapply(categories, function(cat) { # ...get application lst.sub <- lapply(x, function(el) { if (el$category == cat) return(el) }) # remove NULL objects (ie. apps not within the category) lst.sub[!sapply(lst.sub, is.null)] }) # append category names names(lst) <- categories return(lst) } ## HEADER ---------------------------------------------------------------------- header <- dashboardHeader( title = tags$p(style = "color:white; font-family:verdana;","RLumShiny"), tags$li(class = "dropdown", tags$a(href = "https://github.com/tzerk/RLumShiny", icon("github"))), tags$li(class = "dropdown", tags$a(href = "https://twitter.com/RLuminescence", icon("twitter"))), tags$li(class = "dropdown", tags$a(href = "https://forum.r-luminescence.de/", icon("comments-o"))) )#EndOf:Header ## SIDEBAR --------------------------------------------------------------------- sidebar <- dashboardSidebar( sidebarSearchForm(textId = "searchText", buttonId = "searchButton", label = "Search..."), # tabNames must have the categorial value (see globals.R) sidebarMenu(id = "sidebar", menuItem("Dashboard", icon = icon("dashboard"), tabName = ""), menuItem("Plotting", icon = icon("bar-chart"), tabName = "plot"), menuItem("Calculation", icon = icon("calculator"), tabName = "calc"), menuItem("Miscellaneous", icon = icon("cogs"), tabName = "misc") ), tags$hr(), tags$div(align = "left", tags$p(style = "color: grey; margin-left: 10px; margin-right: 40px; font-size: 80%;", attributes(unclass(citation("RLumShiny"))[[1]])$textVersion) ) )#EndOf:Sidebar ## BODY ------------------------------------------------------------------------ body <- dashboardBody( ## custom CSS for shiny(dashboard) elements # info-box tags$head(tags$style(HTML('.info-box {min-height: 210px;} .info-box-icon {height: 100px; line-height: 100px;}'))), # background of the dashboard body tags$head(tags$style(HTML('.content-wrapper {height: 1400px;}'))), # JavaScript code executed when clicking a href link; it will initialise # the input$linkClicked variable that can be used within the server logic tags$script(HTML(" function clickFunction(link){ alert('The following application will now be started: ' + link + '\\n\\nNote: This window will become unresponsive. \\nDo not close until done with the application!'); Shiny.onInputChange('linkClicked', link); } ")), # The whole dashboard body is generated dynamically in the server logic uiOutput("body") )#EndOf:Body ## RENDER PAGE ----------------------------------------------------------------- ui <- dashboardPage(header, sidebar, body) ## SERVER LOGIC ---------------------------------------------------------------- server <- function(input, output, session) { # FILTER ----------------------------------- get_Items <- reactive({ matches <- sapply(applications, function(el) { # filter by search name & category grepl(input$searchText, el$title, ignore.case = TRUE) & grepl(input$sidebar, el$category) }) # split by category (globals.R) split_by_category(applications[matches]) }) # BODY ------------------------------------- output$body <- renderUI({ # get (filtered) list of available applications items <- get_Items() # create infoBoxes for each application mainbody <- Map(function(apps, cat) { category <- switch(cat, "plot" = "Plotting", "calc" = "Calculation", "misc" = "Miscellaneous", "stat" = "Statistics") color <- switch(cat, "plot" = "red", "calc" = "light-blue", "misc" = "green", "stat" = "black") icon <- switch(cat, "plot" = icon("bar-chart"), "calc" = icon("calculator"), "misc" = icon("cogs"), "stat" = icon("superscript")) # all applications of a particular category are wrapped around with # with collapsible box box(title = category, collapsible = TRUE, width = 12, height = "100%", # embed infoboxes for all applications of a category Map(function(app, id) { div( infoBox(title = HTML("", app$title, "
"), fill = TRUE, subtitle = app$description, color = color, icon = icon, href = "#"), onclick = paste0("clickFunction('", app$keyword,"'); return false;")) }, apps, 1:length(apps))) }, items, names(items)) return(mainbody) }) ## Start application # workaround: clicking on any of the infoboxes causes the gadget to # terminate, which triggers the custom onSessionEnded callback. # We have to terminate the gadget first to make room for starting # another shiny instance, i.e., the chosen app observeEvent(input$linkClicked, { stopApp(NULL) }) session$onSessionEnded(function() { isolate({ if (!is.null(input$linkClicked)) app_RLum(input$linkClicked) }) }) }#EndOf:ServerLogic viewer <- dialogViewer("RLumShiny Dashboard", width = 1400, height = 800) runGadget(ui, server, viewer = viewer) }RLumShiny/MD50000644000175100001440000001346413124236633012505 0ustar hornikusers882e548eabdcc8bec6551b7b384c878f *DESCRIPTION 6fbb53acfc07165c6ece0db954f33d0a *LICENSE.note 3caef365403b885737019fb87dd14c0a *NAMESPACE c961edee54564972a3bd7fac99d2205a *NEWS 914c8c5045956927299ce7f1a49f1c37 *R/RLumShiny.R e0f452661a235ea9878e3429e91c3c5c *R/addin.R 35b8c95c6027fbf8941258ea6d8d9143 *R/app_RLum.R c311aadc456bd03bc1719726f2dd9921 *R/chooser.R 52bc4bd492b595207b563160448d2518 *R/jscolor.R 6deddc9fe3b00c150c36478be370a273 *R/popover.R 4efb87fd14c30714a3f1c187c0aa7dcf *R/tooltip.R dba18dc70f5abb65198f35e1796205c8 *R/zzz.R 706e85a626487748a7799a5055502ec3 *inst/rstudio/addins.dcf 31c93652e3ad30cdcd044b066429efdc *inst/shiny/KDE/Global.R 65fed988f9bca584ff7bc5f25e057063 *inst/shiny/KDE/server.R 13ecd7b5173d2d7af24e48d42ef5ea34 *inst/shiny/KDE/shiny_bookmarks/62408c76eac4976d/input.rds 6787611a59c2f6d585548b7f2cf12f9c *inst/shiny/KDE/ui.R f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/KDE/www/GitHub-Mark-32px.png 8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/KDE/www/RL_Logo.png e3a2deb2d5f93d6c5339bd7f8a018ccd *inst/shiny/KDE/www/style.css d124472141f34b394b08d16ca9a592f5 *inst/shiny/abanico/Global.R 508ae5502f992b311817392f6cf59a5c *inst/shiny/abanico/server.R 904d4bdf9df182f1784a0fb1757c70d2 *inst/shiny/abanico/shiny_bookmarks/8027aaa9b994c7bd/input.rds e48815537a789a2a6ca9404e3be43b49 *inst/shiny/abanico/ui.R f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/abanico/www/GitHub-Mark-32px.png 8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/abanico/www/RL_Logo.png e3a2deb2d5f93d6c5339bd7f8a018ccd *inst/shiny/abanico/www/style.css 23b741f412b9a2fd64a0db52464f16f6 *inst/shiny/cosmicdose/Global.R bac027923b1b5a4345a59456304bbcba *inst/shiny/cosmicdose/server.R aef6bc694aa61d3f3b74f2f6355c1062 *inst/shiny/cosmicdose/shiny_bookmarks/5a258b62777fa1b7/input.rds aef6bc694aa61d3f3b74f2f6355c1062 *inst/shiny/cosmicdose/shiny_bookmarks/6584528eb04ada68/input.rds 8bf851e7038a88de19c04f81d563f58d *inst/shiny/cosmicdose/shiny_bookmarks/8b67ae595d1e31f0/input.rds 0654e662d222d1b517f54059333884ea *inst/shiny/cosmicdose/ui.R c456256ab4f1384440d3fe8f6438d692 *inst/shiny/cosmicdose/www/style.css ddc7f6e07f044fe4699fe89e0a8d418b *inst/shiny/doserecovery/Global.R 01c8eeffc144eb931814244edc02e6dc *inst/shiny/doserecovery/server.R c1cf9e67adb1b710790fc6bfa66fe16e *inst/shiny/doserecovery/ui.R f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/doserecovery/www/GitHub-Mark-32px.png 8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/doserecovery/www/RL_Logo.png e3a2deb2d5f93d6c5339bd7f8a018ccd *inst/shiny/doserecovery/www/style.css 7226cd5d011c60becebf27ece419a455 *inst/shiny/filter/global.R bc9b6cf298d5afad726c586750f9d77f *inst/shiny/filter/server.R 1beaf2182b1cb5f9d28d95c2b989f5b2 *inst/shiny/filter/template/template.xlsx 07b4a2cf19ef69c9e644d4357fd43e3c *inst/shiny/filter/ui.R 9df65bd1b3068d93f2646edfc40d8d22 *inst/shiny/histogram/Global.R 5879c3f68d1f038296ab71a99626ee1e *inst/shiny/histogram/server.R d76855193c964b7bccecbb1d2e7ef65a *inst/shiny/histogram/shiny_bookmarks/0e7f62cc161fbb36/input.rds 8567db0e64ac6b942bf222360ce4109d *inst/shiny/histogram/shiny_bookmarks/1c021999f0efd158/input.rds f561bc0b0902e1ed530da36d1024aa54 *inst/shiny/histogram/shiny_bookmarks/223e820d2f46b516/input.rds bf1e2cf4dcb5be559d25b3dd50163d98 *inst/shiny/histogram/ui.R f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/histogram/www/GitHub-Mark-32px.png 8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/histogram/www/RL_Logo.png e3a2deb2d5f93d6c5339bd7f8a018ccd *inst/shiny/histogram/www/style.css de0745eeb780725a3b3fdf7ab8d06b79 *inst/shiny/radialplot/Global.R e98b28404e169fa6b9bae238f1a00b70 *inst/shiny/radialplot/server.R 4e7245255842778ae433cfaf21303aee *inst/shiny/radialplot/shiny_bookmarks/1e0f5bee0eebca8d/input.rds 6dcd8a126f0c16d954b6e3023b2f3391 *inst/shiny/radialplot/ui.R f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/radialplot/www/GitHub-Mark-32px.png 8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/radialplot/www/RL_Logo.png e3a2deb2d5f93d6c5339bd7f8a018ccd *inst/shiny/radialplot/www/style.css 47262ad26d07ca7ea00a03fa28096ab6 *inst/shiny/transformCW/Global.R 1be50d8a062db0fac1c9ad5ff3b081d7 *inst/shiny/transformCW/Server.R 2efe487ea4540e7de37d9608cef5fcac *inst/shiny/transformCW/UI.R ddb8828f02a95d6aec2c0c1e3567ade1 *inst/shiny/transformCW/shiny_bookmarks/0bba99060aa8d69f/input.rds 5c246bf25960086aec1640b1f5b11f15 *inst/shiny/transformCW/shiny_bookmarks/211d00e884a92c90/input.rds 5c246bf25960086aec1640b1f5b11f15 *inst/shiny/transformCW/shiny_bookmarks/383978aa9a560a09/input.rds 5c246bf25960086aec1640b1f5b11f15 *inst/shiny/transformCW/shiny_bookmarks/99c9d1b8f309e36d/input.rds 5c246bf25960086aec1640b1f5b11f15 *inst/shiny/transformCW/shiny_bookmarks/9d5d05362bf9b198/input.rds 5c246bf25960086aec1640b1f5b11f15 *inst/shiny/transformCW/shiny_bookmarks/cad3028cccb4abdb/input.rds b23354fa46bd504ecaa66e0f87784821 *inst/shiny/transformCW/shiny_bookmarks/f0d30b74a68561f3/input.rds f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/transformCW/www/GitHub-Mark-32px.png 8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/transformCW/www/RL_Logo.png e3a2deb2d5f93d6c5339bd7f8a018ccd *inst/shiny/transformCW/www/style.css 207cae2b4946f89cf59dfe995b0c4b33 *inst/www/chooser_inputBinding.js 5034704a76cd55c1cbcbc58ea6bf523f *inst/www/jscolor/arrow.gif ba9a274b9323753cd95bc3b1eb2f4e5f *inst/www/jscolor/cross.gif 742abe680859d25a2052ac5be6b65203 *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 bb333c898f746ba4168e23959e2d276c *man/RLumShiny-package.Rd c15fb522d378a93f6fb798bee4c4e389 *man/RLumShinyAddin.Rd 1ad3215a6b0c7eaf865d7e253de022fe *man/app_RLum.Rd 6d7c2d22877a4185b63b694d35f0d80d *man/jscolorInput.Rd 547122d77a3889430f3b656e502494c7 *man/popover.Rd 194e1423d5256f59909c0966e7662cb4 *man/tooltip.Rd RLumShiny/DESCRIPTION0000644000175100001440000000372113124236633013676 0ustar hornikusersPackage: RLumShiny Type: Package Title: 'Shiny' Applications for the R Package 'Luminescence' Version: 0.2.0 Date: 2017-06-26 Author: Christoph Burow [aut, cre], Urs Tilmann Wolpert [aut], Sebastian Kreutzer [aut], R Luminescence Package Team [ctb], Jan Odvarko [cph] (jscolor.js in www/jscolor), AnalytixWare [cph] (ShinySky package), RStudio [cph] (chooser_inputBinding.js in www/ and chooser.R in R/) Authors@R: c( person("Christoph", "Burow", role = c("aut", "cre"), email = "christoph.burow@uni-koeln.de"), person("Urs Tilmann", "Wolpert", role = "aut"), person("Sebastian", "Kreutzer", role = "aut"), 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" ), person(family = "RStudio", role = "cph", comment = "chooser_inputBinding.js in www/ and chooser.R in R/") ) Maintainer: Christoph Burow 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.2) Imports: Luminescence (>= 0.7.3), shiny (>= 0.14.0), rhandsontable (>= 0.3.4), data.table (>= 1.10.4), googleVis (>= 0.6.2), shinydashboard (>= 0.5.3), readxl (>= 1.0.0) URL: https://tzerk.github.io/RLumShiny/ BugReports: https://github.com/tzerk/RLumShiny/issues Collate: 'app_RLum.R' 'addin.R' 'chooser.R' 'jscolor.R' 'tooltip.R' 'popover.R' 'RLumShiny.R' 'zzz.R' RoxygenNote: 6.0.1 NeedsCompilation: no Packaged: 2017-06-26 13:03:41 UTC; burowc Repository: CRAN Date/Publication: 2017-06-26 17:00:11 UTC RLumShiny/LICENSE.note0000644000175100001440000000106213122205727014133 0ustar hornikusersThe 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) - chooser-binding.js & chooser.R, https://github.com/rstudio/shiny-examples/tree/master/036-custom-input-control, MIT license (YEAR: 2016, COPYRIGHT HOLDER: RStudio)RLumShiny/man/0000755000175100001440000000000013020024066012726 5ustar hornikusersRLumShiny/man/popover.Rd0000644000175100001440000000354613124163465014733 0ustar hornikusers% 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}} (\strong{required}): Title of the button.} \item{content}{\code{\link{character}} (\strong{required}): Text to be displayed in the popover.} \item{header}{\code{\link{character}} (\emph{optional}): Optional header in the popover.} \item{html}{\code{\link{logical}} (\emph{with default}): Insert HTML into the popover.} \item{class}{\code{\link{logical}} (\emph{with default}): Bootstrap button class (e.g. "btn btn-danger").} \item{placement}{\code{\link{character}} (\emph{with default}): 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}} (\emph{with default}): 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) }) }) } } RLumShiny/man/app_RLum.Rd0000644000175100001440000000447613124162776014767 0ustar hornikusers% 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 = NULL, ...) } \arguments{ \item{app}{\code{\link{character}} (\strong{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. If no keyword is used a dashboard will be started instead, from which an application can be started. \tabular{lcl}{ \strong{Application name:} \tab \strong{Keyword:} \tab \strong{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}}, \code{\link{CW2pLM}}, \code{\link{CW2pLMi}}, \code{\link{CW2pPMi}} \cr Filter Combinations \tab \emph{filter} \tab \code{\link{plot_FilterCombinations}} } 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{ # Dashboard app_RLum() # Plotting apps app_RLum("abanico") app_RLum("histogram") app_RLum("KDE") app_RLum("radialplot") app_RLum("doserecovery") # Further apps app_RLum("cosmicdose") app_RLum("transformCW") app_RLum("filter") } } \seealso{ \code{\link{runApp}} } \author{ Christoph Burow, University of Cologne (Germany) } RLumShiny/man/RLumShinyAddin.Rd0000644000175100001440000000035713051544221016060 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/addin.R \name{RLumShinyAddin} \alias{RLumShinyAddin} \title{RLumShiny Dashboard Addin} \usage{ RLumShinyAddin() } \description{ RLumShiny dashboard } RLumShiny/man/RLumShiny-package.Rd0000644000175100001440000000244613124161664016521 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RLumShiny.R \docType{package} \name{RLumShiny-package} \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. } RLumShiny/man/jscolorInput.Rd0000644000175100001440000000441713124201157015721 0ustar hornikusers% 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}} (\strong{required}): Specifies the input slot that will be used to access the value.} \item{label}{\code{\link{character}} (\emph{optional}): Display label for the control, or NULL for no label.} \item{value}{\code{\link{character}} (\emph{optional}): Initial RGB value of the color picker. Default is black ('#000000').} \item{position}{\code{\link{character}} (\emph{with default}): Position of the picker relative to the text input ('bottom', 'left', 'top', 'right').} \item{color}{\code{\link{character}} (\emph{with default}): Picker color scheme ('transparent' by default). Use RGB color coding ('000000').} \item{mode}{\code{\link{character}} (\emph{with default}): Mode of hue, saturation and value. Can either be 'HSV' or 'HVS'.} \item{slider}{\code{\link{logical}} (\emph{with default}): Show or hide the slider.} \item{close}{\code{\link{logical}} (\emph{with default}): 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}} } RLumShiny/man/tooltip.Rd0000644000175100001440000000536313124162776014736 0ustar hornikusers% 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}} (\strong{required}): id of the element the tooltip is to be attached to.} \item{text}{\code{\link{character}} (\strong{required}): Text to be displayed in the tooltip.} \item{attr}{\code{\link{character}} (\emph{optional}): Attach tooltip to all elements with attribute \code{attr='refId'}.} \item{animation}{\code{\link{logical}} (\emph{with default}): Apply a CSS fade transition to the tooltip.} \item{delay}{\code{\link{numeric}} (\emph{with default}): Delay showing and hiding the tooltip (ms).} \item{html}{\code{\link{logical}} (\emph{with default}): Insert HTML into the tooltip.} \item{placement}{\code{\link{character}} (\emph{with default}): How to position the tooltip - \code{top} | \code{bottom} | \code{left} | \code{right} | \code{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}} (\emph{with default}): How tooltip is triggered - \code{click} | \code{hover} | \code{focus} | \code{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 checkbox group", 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) }) }) } }