RLumShiny/0000755000176200001440000000000013416077073012154 5ustar liggesusersRLumShiny/inst/0000755000176200001440000000000013142322743013122 5ustar liggesusersRLumShiny/inst/www/0000755000176200001440000000000013142322714013744 5ustar liggesusersRLumShiny/inst/www/jscolor_inputBinding.js0000644000176200001440000000070513020024066020463 0ustar liggesusers// 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/0000755000176200001440000000000013020024066015411 5ustar liggesusersRLumShiny/inst/www/jscolor/demo.html0000644000176200001440000000030613020024066017222 0ustar liggesusers jscolor demo Click here: RLumShiny/inst/www/jscolor/arrow.gif0000644000176200001440000000010213020024066017223 0ustar liggesusersGIF89a  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.png0000644000176200001440000000517413020024066016540 0ustar liggesusersPNG  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.gif0000644000176200001440000000012313020024066017225 0ustar liggesusersGIF89a! ,$ǝRQg/,@))qڤp http://api.jquery.com/clone/ states: > As shown in the discussion for .append(), normally when an element is inserted somewhere in the DOM, > it is moved from its old location. However, this is not what we want ... not really, thus we modify the functions and now we have a clone() for left to right and a remove() for right to left. */ (function() { function updateChooser(chooser) { chooser = $(chooser); var left = chooser.find("select.left"); var right = chooser.find("select.right"); var leftArrow = chooser.find(".left-arrow"); var rightArrow = chooser.find(".right-arrow"); var canMoveTo = (left.val() || []).length > 0; //returns only true or false var canMoveFrom = (right.val() || []).length > 0; //returns only true or false //this mutes the arrow, if nothing is left on one or the other side leftArrow.toggleClass("muted", !canMoveFrom); rightArrow.toggleClass("muted", !canMoveTo); } function remove(chooser, source, dest) { chooser = $(chooser); var selected = chooser.find(source).children("option:selected"); selected.remove(); updateChooser(chooser); chooser.trigger("change"); } function copy(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;}); selected.clone().appendTo(dest); updateChooser(chooser); chooser.trigger("change"); } $(document).on("change", ".chooser select", function() { updateChooser($(this).parents(".chooser")); }); $(document).on("click", ".chooser .right-arrow", function() { copy($(this).parents(".chooser"), ".left", ".right"); }); $(document).on("click", ".chooser .left-arrow", function() { remove($(this).parents(".chooser"), ".right", ".left"); }); $(document).on("dblclick", ".chooser select.left", function() { copy($(this).parents(".chooser"), ".left", ".right"); }); $(document).on("dblclick", ".chooser select.right", function() { remove($(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/0000755000176200001440000000000013413154613014254 5ustar liggesusersRLumShiny/inst/shiny/radialplot/0000755000176200001440000000000013142565127016414 5ustar liggesusersRLumShiny/inst/shiny/radialplot/ui.R0000644000176200001440000012077513142551661017166 0ustar liggesusers## 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 RLumShiny:::exportTab("export", filename = "radial plot"), RLumShiny:::aboutTab("about", "radialplot") )##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.R0000644000176200001440000003023313155476671020057 0ustar liggesusers## Server.R ## MAIN FUNCTION function(input, output, session) { # input data (with default) values <- reactiveValues(data_primary = if ("startData" %in% names(.GlobalEnv)) startData else ExampleData.DeValues$CA1, data_secondary = setNames(as.data.frame(matrix(NA_real_, nrow = 5, ncol = 2)), c("x", "y")), data = NULL, args = NULL) session$onSessionEnded(function() { stopApp() }) # 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 observe({ ### 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"))) values$data <- 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, values$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, values$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, values$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() observe({ # refresh plot on button press input$refresh # 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) # if custom datapoint color get RGB code from separate input panel color <- ifelse(input$color == "custom", input$rgb, 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 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) # workaround to initialize plotting after app startup centValue <- ifelse(is.null(input$centValue), 3000, input$centValue) # create numeric vector of lines line <- sapply(1:8, function(x) input[[paste0("line", x)]]) # create char vector of line colors line.col <- sapply(1:8, function(x) input[[paste0("colline", x)]]) # create char vector of line labels line.label <- sapply(1:8, function(x) input[[paste0("labline", x)]]) # if custom bar color get RGB from separate input panel or "none" bar.col <- ifelse(input$bar == "custom", adjustcolor(col = input$rgbBar, alpha.f = input$alpha.bar/100), 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 bar.col2 <- ifelse(input$bar2 == "custom", adjustcolor(col = input$rgbBar2, alpha.f = input$alpha.bar/100), 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" grid.col <- ifelse(input$grid == "custom", adjustcolor(col = input$rgbGrid, alpha.f = input$alpha.grid/100), ifelse(input$grid == "none", input$grid, adjustcolor(col = input$grid, alpha.f = input$alpha.grid/100))) # 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 } } # plot radial Plot values$args <- list( data = values$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 = if (input$summary) input$stats else NA, 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))) }) # render Radial Plot output$main_plot <- renderPlot({ # 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!') ) do.call(plot_RadialPlot, args = values$args) })##EndOf::renderPlot({}) observe({ # nested renderText({}) for code output on "R plot code" tab code.output <- callModule(RLumShiny:::printCode, "printCode", n_input = 2, fun = "plot_RadialPlot(data,", args = values$args) output$plotCode<- renderText({ code.output })##EndOf::renderText({}) callModule(RLumShiny:::exportCodeHandler, "export", code = code.output) callModule(RLumShiny:::exportPlotHandler, "export", fun = "plot_RadialPlot", args = values$args) }) # 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').values$data.toArray()); }); }", { data<- values$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').values$data.toArray()); }); }", { if(!all(is.na(unlist(values$data_secondary)))) { data<- values$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 <- values$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/0000755000176200001440000000000013055562161017236 5ustar liggesusersRLumShiny/inst/shiny/radialplot/www/GitHub-Mark-32px.png0000644000176200001440000000326213020024066022600 0ustar liggesusersPNG  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.css0000644000176200001440000000242713055561001021105 0ustar liggesusers.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/0000755000176200001440000000000012772146744021626 5ustar liggesusersRLumShiny/inst/shiny/radialplot/shiny_bookmarks/1e0f5bee0eebca8d/0000755000176200001440000000000012772146744024416 5ustar liggesusersRLumShiny/inst/shiny/radialplot/shiny_bookmarks/1e0f5bee0eebca8d/input.rds0000644000176200001440000000145412765756674026306 0ustar liggesusersV=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.R0000644000176200001440000000032013053274161017766 0ustar liggesusers## 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/0000755000176200001440000000000013142565071016770 5ustar liggesusersRLumShiny/inst/shiny/doserecovery/ui.R0000644000176200001440000006007313142547570017542 0ustar liggesusersfunction(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 RLumShiny:::exportTab("export", filename = "dose recovery"), RLumShiny:::aboutTab("about", "doserecovery") ) ), # 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.R0000644000176200001440000001734513155476757020453 0ustar liggesusers############################################################################## ### MAIN PROGRAM ### ############################################################################## function(input, output, session) { # input data (with default) values <- reactiveValues(data_primary = if ("startData" %in% names(.GlobalEnv)) startData else ExampleData.DeValues$BT998[7:11,], data_secondary = setNames(as.data.frame(matrix(NA_real_, nrow = 5, ncol = 2)), c("x", "y")), data = NULL, args = NULL) session$onSessionEnded(function() { stopApp() }) # 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 observe({ 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"))) values$data <- 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 <- values$data n <- max(sapply(data, nrow)) sliderInput(inputId = "xlim", label = "Range x-axi s", 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"}) }) observe({ input$refresh outputOptions(x = output, name = "xlim", suspendWhenHidden = FALSE) # if custom datapoint style get char from separate input panel pch <- ifelse(input$pch == "custom", input$custompch, as.integer(input$pch) - 1) pch2 <- ifelse(input$pch2 == "custom", input$custompch2, as.integer(input$pch2) - 1) # if custom datapoint color get RGB code from separate input panel color <- ifelse(input$color == "custom", input$rgb, color<- input$color) # if custom datapoint color get RGB code from separate input panel if(length(values$data) > 1) { color2 <- ifelse(input$color2 == "custom", input$rgb2, input$color2) } else { color2 <- ifelse(input$preheat, color, "white") } if (length(values$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 values$args<- list( values = 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) { n<- length(values$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] isolate({ values$args<- c(values$args, "preheat" = NA) values$args$preheat<- ph values$args$pch<- rep(values$args$pch, n) values$args$col<- rep(values$args$col, n) }) } }) #### PLOT #### output$main_plot <- renderPlot({ validate( need(expr = input$xlim, message = 'Waiting for data... Please wait!') ) # plot DRT Results do.call(what = plot_DRTResults, args = values$args) }) observe({ # nested renderText({}) for code output on "R plot code" tab code.output <- callModule(RLumShiny:::printCode, "printCode", n_input = 2, fun = "plot_DRTResults(data,", args = values$args) output$plotCode<- renderText({ code.output })##EndOf::renderText({}) callModule(RLumShiny:::exportCodeHandler, "export", code = code.output) callModule(RLumShiny:::exportPlotHandler, "export", fun = "plot_DRTResults", args = values$args) }) # 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').values$data.toArray()); });}", { data<- values$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').values$data.toArray()); });}", { data<- values$data if(length(data)>1) { colnames(data[[2]])<- c("De", "De error") data[[2]] } })##EndOf::renterTable() } RLumShiny/inst/shiny/doserecovery/www/0000755000176200001440000000000013055562161017614 5ustar liggesusersRLumShiny/inst/shiny/doserecovery/www/GitHub-Mark-32px.png0000644000176200001440000000326213020024066023156 0ustar liggesusersPNG  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.css0000644000176200001440000000242713055560666021503 0ustar liggesusers.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.R0000644000176200001440000000042113053262365020351 0ustar liggesusers## 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/0000755000176200001440000000000013137601433015541 5ustar liggesusersRLumShiny/inst/shiny/filter/ui.R0000644000176200001440000002116213137601433016303 0ustar liggesusers## +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ## 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", "Custom wavelength" = "custom" ) ), fluidRow( column(width = 10, inputPanel( numericInput("stimulationInput_custom_centre", label = "Centre", value = 470, width = 150, min = 2, max = 1000), numericInput("stimulationInput_custom_width", label = "Width", value = 20, width = 150, min = 1, max = 1000), RLumShiny:::jscolorInput("rec_colour", label = "Colour"))) ) ), # 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.R0000644000176200001440000002160213155476400017177 0ustar liggesusers## +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ## 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) { session$onSessionEnded(function() { stopApp() }) #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)} if(input$stimulationInput == "custom"){ rect(input$stimulationInput_custom_centre - input$stimulationInput_custom_width/2, 0, input$stimulationInput_custom_centre + input$stimulationInput_custom_width/2, 1, col = input$rec_colour, 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/0000755000176200001440000000000013122176270017354 5ustar liggesusersRLumShiny/inst/shiny/filter/template/template.xlsx0000644000176200001440000014250613122176270022117 0ustar liggesusersPK!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.R0000644000176200001440000000220613124170541017121 0ustar liggesusers## +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ## 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/surfaceexposure/0000755000176200001440000000000013171655061017503 5ustar liggesusersRLumShiny/inst/shiny/surfaceexposure/ui.R0000644000176200001440000004612413173575711020257 0ustar liggesusers## UI.R function(request) { fluidPage( titlePanel(NULL, windowTitle = "RLumShiny - surfaceexposure"), 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 rHandsontableOutput(outputId = "table_in_primary"), helpText(HTML(paste0( tags$b("NOTE: "), "The uploaded file must have at least two columns (Depth, Signal). ", "If the file contains three columns, it is automatically assumed that the third column ", "is the error on the signal. The fourth column (Group) is only required for global fitting ", "of multiple data sets.") )) ),##EndOf::Tab_1 tabPanel("Parameters", checkboxInput(inputId = "global_fit", "Global fit", TRUE), conditionalPanel(condition = "input.global_fit == true", helpText(HTML(paste(tags$b("NOTE:"), "Weighting is not available for global fitting."))) ), uiOutput("global_fit_ages"), conditionalPanel(condition = "input.global_fit == false", checkboxInput(inputId = "weights", HTML("Error weighted fitting (1/σ2)"), FALSE) ), hr(), conditionalPanel( condition = "input.global_fit == false", fluidRow( column(1, checkboxInput(inputId = "override_age", "", value = FALSE)), column(10, numericInput(inputId = "age", "Age (a)", value = 1000, min = 0) ) ) ), fluidRow( column(1, checkboxInput(inputId = "override_sigmaphi", "", value = TRUE)), column(10, fluidRow( column(width = 6, numericInput(inputId = "sigmaphi_base", "\\( \\overline{\\sigma\\varphi_0} \\) (base)", value = 5.0, step = 0.1) ), column(width = 6, numericInput(inputId = "sigmaphi_exp", "\\( \\overline{\\sigma\\varphi_0} \\) (exponent)", value = 10, step = 1) ) ) ) ), fluidRow( column(1, checkboxInput(inputId = "override_mu", "", value = TRUE)), column(10, numericInput(inputId = "mu", "\\( \\mu \\)", value = 0.90, step = 0.01) ) ) ), tabPanel("Dose rate", checkboxInput("doserate", "Consider dose rate", FALSE), helpText(HTML(paste( "This will fit eq. 12 in Sohbati et al. (2012b) to the data. Note, however,", "that here the dose rate is assumed constant, i.e., it is independent of sample depth." ))), withMathJax(), helpText("$$L(x) = \\frac{\\overline{\\sigma\\varphi _0}e^{-\\mu x}e^{-t[\\overline{\\sigma\\varphi _0}e^{-\\mu x} + \\frac{\\dot{D}}{D_0}]}+ \\frac{\\dot{D}}{D_0}} {\\overline{\\sigma\\varphi _0}e^{-\\mu x} + \\frac{\\dot{D}}{D_0}}$$"), numericInput("ddot", "Dose rate, \\(\\dot{D} (Gy/ka)\\)", value = 1.5, min = 0, step = 0.01), numericInput("d0", "Characteristic saturation dose, \\(D_0\\) (Gy)", value = 40, min = 0, step = 1), hr(), helpText(HTML(paste(tags$b("Reference:"), "Sohbati, R., Jain, M., Murray, A.S., 2012b. Surface exposure dating of non-terrestial bodies using optically stimulated luminescence: A new method. Icarus 221, 160-166."))) ), tabPanel("Plot", div(align = "center", h5("Title")), textInput(inputId = "main", label = "Title", value = "OSL Surface Exposure Dating"), fluidRow( column(width = 6, selectInput(inputId = "pch", label = "Datapoint style", selected = "22", 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", "filled Circle w/ outline" = "22", "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", selected = "red", choices = list("Black" = "black", "Grey" = "grey50", "Red" = "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")) ) ), fluidRow( column(width = 6, selectInput(inputId = "lty", "Fitting line style", selected = 1, choices = list("Blank" = 0, "Solid" = 1, "Dashed" = 2, "Dotted" = 3, "Dot dash" = 4, "Long dash" = 5, "Two dash" = 6)) ), column(width = 6, numericInput(inputId = "lwd", label = "Line width", min = 0, max = 5, value = 1) ) ), fluidRow( column(width = 6, selectInput(inputId = "line_col", label = "Fitting line color", selected = "default", choices = list("Default" = "default", "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.line_col == 'custom'", HTML("Choose a color
"), jscolorInput(inputId = "jscol2")) ) ), br(), fluidRow( column(width = 4, checkboxInput(inputId = "legend", label = "Show legend", value = TRUE) ), column(width = 4, checkboxInput(inputId = "coord_flip", label = "Flip coordinate system", value = FALSE) ), column(width = 4, checkboxInput(inputId = "error_bars", label = "Show error bars", value = TRUE) ) ), div(align = "center", h5("Scaling")), sliderInput(inputId = "cex", label = "Scaling factor", min = 0.5, max = 2, value = 1.1, 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 = FALSE), textInput(inputId = "xlab", label = "Label x-axis", value = "Depth (mm)"), # inject sliderInput from Server.R sliderInput(inputId = "xlim", "X-axis limits", min = -15, max = 20, value = c(-0, 10), step = 0.1), br(), div(align = "center", h5("Y-axis")), checkboxInput(inputId = "logy", label = "Logarithmic y-axis", value = FALSE), textInput(inputId = "ylab", label = "Label y-axis (left)", value = "OSL intensity (Ln/Tn)"), sliderInput(inputId = "ylim", "Y-axis limits", min = -1, max = 2, value = c(-0.1, 1.1), step = 0.1) ),##EndOf::Tab_4 RLumShiny:::exportTab("export", filename = "surfaceexposure"), RLumShiny:::aboutTab("about", "surfaceExposure") )##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"), htmlOutput(outputId = "console")), tabPanel("R code", verbatimTextOutput("plotCode")) )###EndOf::tabsetPanel )##EndOf::mainPanel ),##EndOf::sideBarLayout bookmarkButton() )##EndOf::fluidPage } RLumShiny/inst/shiny/surfaceexposure/server.R0000644000176200001440000001755113173360316021143 0ustar liggesusers## Server.R ## MAIN FUNCTION function(input, output, session) { # input data (with default) values <- reactiveValues(data = example_data, data_used = NULL, args = NULL, results = NULL) observe({ # 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 = "global_fit_ages", suspendWhenHidden = FALSE) }) session$onSessionEnded(function() { stopApp() }) # check and read in file (DATA SET 1) observeEvent(input$file, { inFile<- input$file if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL data <- fread(file = inFile$datapath, data.table = FALSE) # inFile[1] contains filepath if (ncol(data) == 2) { data$error <- 0.0001 data$group <- "A" } else if (ncol(data) == 3) { data$group <- "A" } colnames(data) <- c("x", "y", "error", "group") updateCheckboxInput(session, "global_fit", value = FALSE) values$data <- data }) output$table_in_primary <- renderRHandsontable({ rhandsontable(values$data, height = 300, colHeaders = c("Depth", "Signal", "Error", "Group"), 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$global_fit_ages <- renderUI({ if (input$global_fit && inherits(values$data_used, "list")) { lapply(1:length(values$data_used), function(i) { numericInput(paste0("age_", i), paste("Age", i), value = 10^(2+i)) }) } }) observeEvent(input$coord_flip, { tmp <- isolate(input$xlab) updateTextInput(session, "xlab", value = isolate(input$ylab)) updateTextInput(session, "ylab", value = tmp) }, ignoreInit = TRUE) # update for log values observe({ if (input$logy) updateSliderInput(session, "ylim", value = c(0.1, isolate(input$ylim[2])), min = 0.1) else updateSliderInput(session, "ylim", min = min(values$data[ ,2]) - diff(range(values$data[ ,2])) / 2, max = max(values$data[ ,2]) + diff(range(values$data[ ,2])) / 2, value = range(pretty(values$data[ ,2]))) }) # update for log values observe({ if (input$logx) updateSliderInput(session, "xlim", value = c(0.1, isolate(input$xlim[2])), min = 0.1) else updateSliderInput(session, "xlim", min = min(values$data[ ,1]) - diff(range(values$data[ ,1])) / 2, max = max(values$data[ ,1]) + diff(range(values$data[ ,1])) / 2, value = range(pretty(values$data[ ,1]))) }) observe({ if (input$global_fit) { # split data frame to list if (!all(is.na(values$data$group))) { data <- values$data[complete.cases(values$data), ] NA_index <- which(data$group == "") if (length(NA_index) > 0) data <- data[-NA_index, ] if (is.factor(data$group)) data$group <- droplevels(data$group) data <- split(data, data$group) # remove any list element with data.frames with 0 rows data <- lapply(data, function(x) if (nrow(x) != 0) x else NULL ) data[sapply(data, is.null)] <- NULL values$data_used <- lapply(data, function(x) x[ ,1:2]) } } else { values$data_used <- values$data } # Age if (input$global_fit) { age <- sapply(1:length(values$data_used), function(i) as.numeric(input[[paste0("age_", i)]])) } else { if (input$override_age) age <- input$age else age <- NULL } # fitting line color if (input$line_col == "custom") line_col <- input$jscol else if (input$line_col == "default") line_col <- NULL else line_col <- input$line_col args <- list( data = values$data_used, age = age, weights = if (input$global_fit) FALSE else input$weights, sigmaphi = if (input$override_sigmaphi) input$sigmaphi_base * 10^-(abs(input$sigmaphi_exp)) else NULL, mu = if (input$override_mu) input$mu else NULL, Ddot = if (input$doserate) input$ddot else NULL, D0 = if (input$doserate) input$d0 else NULL, verbose = FALSE, pch = ifelse(input$pch == "custom", input$custompch, as.numeric(input$pch) - 1), bg = ifelse(input$color == "custom", input$jscol1, input$color), cex = input$cex, legend = input$legend, main = input$main, line_col = line_col, line_lty = as.numeric(input$lty), line_lwd = as.numeric(input$lwd), xlab = input$xlab, ylab = input$ylab, log = paste0("", ifelse(input$logx, "x", ""), ifelse(input$logy, "y", "")), coord_flip = input$coord_flip, error_bars = input$error_bars, xlim = if (!input$coord_flip) input$xlim else input$ylim, ylim = if (!input$coord_flip) input$ylim else rev(input$xlim)) # sanitise final list by removing all NULL elements args[sapply(args, is.null)] <- NULL # return values$args <- args }) observe({ # nested renderText({}) for code output on "R plot code" tab code.output <- callModule(RLumShiny:::printCode, "printCode", n_input = 1, fun = paste0("fit_SurfaceExposure(data,"), args = values$args) output$plotCode<- renderText({ code.output })##EndOf::renderText({}) callModule(RLumShiny:::exportCodeHandler, "export", code = code.output) callModule(RLumShiny:::exportPlotHandler, "export", fun = "fit_SurfaceExposure", args = values$args) }) ## MAIN ---- output$main_plot <- renderPlot({ tryCatch({ values$results <- do.call(fit_SurfaceExposure, values$args) }, error = function(e) print(e)) }) output$console <- renderText({ if (is.null(values$results)) return(NULL) if (!input$global_fit) { res <- as.data.frame(t(signif(unlist(get_RLum(values$results)), 3))) HTML(paste0( tags$b("Age (a): "), res$age, " ± ", res$age_error, tags$em(ifelse(input$override_age, "(fixed)", "")), tags$br(), tags$b("sigmaPhi: "), res$sigmaphi, " ± ", res$sigmaphi_error, tags$em(ifelse(input$override_sigmaphi, "(fixed)", "")), tags$br(), tags$b("mu: "), res$mu, " ± ", res$mu_error, tags$em(ifelse(input$override_mu, "\t(fixed)", "")), tags$br() )) } else { res <- as.data.frame(get_RLum(values$results)) HTML(paste0( tags$b("Ages (a): "), paste(res$age, collapse = ", "), tags$em(" (fixed)"), tags$br(), tags$b("sigmaPhi: "), signif(unique(res$sigmaphi), 3), " ± ", signif(unique(res$sigmaphi_error), 3), tags$em(ifelse(input$override_sigmaphi, "(fixed)", "")), tags$br(), tags$b("mu: "), signif(unique(res$mu), 3), " ± ", signif(unique(res$mu_error), 3), tags$em(ifelse(input$override_mu, "\t(fixed)", "")), tags$br() )) } }) }##EndOf::function(input, output)RLumShiny/inst/shiny/surfaceexposure/www/0000755000176200001440000000000013171655041020325 5ustar liggesusersRLumShiny/inst/shiny/surfaceexposure/www/GitHub-Mark-32px.png0000644000176200001440000000326213020024066023670 0ustar liggesusersPNG  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/surfaceexposure/www/style.css0000644000176200001440000000242713055560666022215 0ustar liggesusers.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/surfaceexposure/global.R0000644000176200001440000000056713173320270021067 0ustar liggesusers## global.R ## library(Luminescence) library(RLumShiny) library(shiny) library(data.table) library(rhandsontable) data("ExampleData.SurfaceExposure") tmp <- Map(function(x, i) { x$error <- 0.001 x$group <- i return(x) }, ExampleData.SurfaceExposure$set_1, LETTERS[1:4]) example_data <- do.call(rbind, tmp) rm(tmp) enableBookmarking(store = "server")RLumShiny/inst/shiny/RCarb/0000755000176200001440000000000013413154613015245 5ustar liggesusersRLumShiny/inst/shiny/RCarb/ui.R0000644000176200001440000001007113413154613016004 0ustar liggesusers## +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ## Title: RCarb Shiny App -ui.R ## Authors: Sebastian Kreutzer, IRAMAT-CRP2A, Université Bordeaux Montaigne (France) ## Contact: sebastian.kreutzer@u-bordeaux-montainge.fr ## Initial date: 2018-10-14 ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ shinyUI( navbarPage( title = HTML(paste0("RCarb App")), windowTitle = "RCarb App", footer = HTML( "
This software comes WITHOUT ANY WARRANTY.
"), # # # PANEL - Analysis----------------------------------------------------------------------------- tabPanel(title = "Import - Analysis", sidebarLayout( sidebarPanel( tabsetPanel( tabPanel(title = "Import data", br(), fileInput("file", accept = "*.csv", label = "Select CSV-file with your data ...", multiple = FALSE), div( radioButtons("import_header", label = "1st row is column header?", choiceNames = c("yes", "no"), choiceValues = list(TRUE, FALSE), inline = TRUE), selectInput("import_sep", label = "Column separator", choices = c(",",";","&","$")), actionButton("load_file", label = "Load from file ...", icon("import", lib = "glyphicon"), style="color: #fff; background-color: #337ab7; border-color: #2e6da4"), actionButton("load_example", label = "Load example data"), align = 'center') ), tabPanel(title = "Run calculation", fluidRow( column(6, numericInput( inputId = "length_step", label = "Step length", value = 1, min = 1, max = 100, width = "100%"), numericInput( inputId = "max_time", label = "Max. time", value = 500, min = 1, max = 500, width = "100%") ), column(6, numericInput( inputId = "n.MC", label = "MC runs", value = 100, min = 1, max = 10000, width = "100%") ) ), div( actionButton("run_calculation", label = "Run calculation", icon = icon("play-circle"), style="color: #fff; background-color: #337ab7; border-color: #2e6da4" ), align = "center") ),##tabPanel tabPanel( title = "Input template", br(), div( downloadButton("download_template",label = "Download input CSV-file template", icon = "download"), align = "center" ) ) )##end TabsetPanel ),##end sidebarPanel mainPanel( rHandsontableOutput("df", height = "250px"), div(align = "center", plotOutput(outputId = "plot") ) )##mainPanel ),##sidebarLayout icon = icon("dashboard", lib = "glyphicon") ),##tabPanel # # # PANEL - News ------------------------------------------------------------------------------ tabPanel("News", fluidRow( column(10, offset = 1, uiOutput('news') ) ),icon = icon("list-alt", lib = "glyphicon") ),#news # PANEL - About ------------------------------------------------------------------------------ tabPanel("About", fluidRow( column(10, offset = 1, uiOutput('about') ) ),icon = icon("info-sign", lib = "glyphicon") )#About )##navbarPage )##EOF RLumShiny/inst/shiny/RCarb/server.R0000644000176200001440000001575013413154613016706 0ustar liggesusers## +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ## Title: RCarb Shiny App ## Authors: Sebastian Kreutzer, IRAMAT-CRP2A, Université Bordeaux Montaigne (France) ## Contact: sebastian.kreutzer@u-bordeaux-montainge.fr ## Initial date: 2018-10-14 ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ shinyServer(function(input, output, session) { # Initialisation ------------------------------------------------------------------------------ ##we run RCarb one time and create the table we need df <- RCarb::model_DoseRate(data = Example_Data[1,], n.MC = NULL, plot = FALSE, verbose = FALSE) df <- df[-1,] ##make table reactive values <- reactiveValues( df = df ) ##render table output$df <- renderRHandsontable({ rhandsontable( data = values$df,debug = TRUE, selectCallback = TRUE, readOnly = FALSE, customOpts = list( csv = list(name = "Download to CSV", callback = htmlwidgets::JS( "function (key, options) { var csv = csvString(this, sep=',', dec='.'); var link = document.createElement('a'); link.setAttribute('href', 'data:text/plain;charset=utf-8,' + encodeURIComponent(csv)); link.setAttribute('download', 'data.csv'); document.body.appendChild(link); link.click(); document.body.removeChild(link); }")))) %>% hot_table(highlightCol = TRUE, highlightRow = TRUE, allowRowEdit = TRUE) }) #feedback changes in the table observe({ if(!is.null(input$df)){ values$df <- hot_to_r(input$df) } }) # Load example data --------------------------------------------------------------------------- observeEvent(input$load_example, { m <- matrix(NA, nrow = 2, ncol = length(colnames(values$df)) - ncol(Example_Data)) temp <- cbind(Example_Data[c(1,14),], as.data.frame(m, stringsAsFactors = FALSE)) colnames(temp) <- colnames(values$df) values$df <- temp }) # # # File import --------------------------------------------------------------------------------- observeEvent(input$load_file, { ##check whether this is empty if(is.null(input$file$datapath)){ return(NULL) } ##import temp <- read.table( file = input$file$datapath, header = as.logical(input$import_header), sep = input$import_sep) ##check input if (ncol(Example_Data) != ncol(temp) && !all(colnames(Example_Data) == colnames(temp))) { showModal(modalDialog( title = "Important message", "Your input CSV-file does not appear to be correctly formated! Please try again or use the input template!", easyClose = TRUE )) return(NULL) } ##limit to the first columns m <- matrix(NA, nrow = nrow(temp), ncol = length(colnames(values$df)) - ncol(Example_Data)) temp <- cbind(temp[,1:29], as.data.frame(m, stringsAsFactors = FALSE)) colnames(temp) <- colnames(values$df) ##write into table values$df <- temp }) # Calculation --------------------------------------------------------------------------------- observeEvent(input$run_calculation, { ##check input and return null if needed if(nrow(values$df) == 0){ message("Input data has 0 rows, nothing was done!") return(NULL) } ##get temp dir temp_dir <- tempdir() ##run with progressbar withProgress( message = "Running calculations ...", min = 0, max = nrow(values$df), { ##run calculation and create plots for(i in 1:nrow(values$df)){ incProgress(i) temp_files[[i]] <<- paste0(temp_dir,"/SAMPLE_",i,".png") png(file = temp_files[[i]], bg = "transparent", width = 800, height = 400, res = 100) values$df[i,] <- RCarb::model_DoseRate( data = values$df[i,1:29], length_step = input$length_step, max_time = input$max_time, n.MC = input$n.MC, verbose = TRUE, plot = TRUE, mfrow = c(1,2) ) dev.off() } })#end progressbar ##show first plot output$plot <- renderImage({ ##grep correct aliquot temp_aliquot <- paste0("SAMPLE_1.png") ##set filename filename <- temp_files[[grep(pattern = temp_aliquot, x = temp_files,fixed = TRUE)]] #Return a list containing the filename and alt text list(src = filename, alt = paste("Image number", temp_aliquot)) }, deleteFile = FALSE) }) # Graphical output ---------------------------------------------------------------------------- observeEvent(input$df_select, { if(is.null(temp_files)) return(NULL) ##grep correct aliquot temp_aliquot <- paste0("SAMPLE_",input$df_select$select$r,".png") ##return NULL if it does not exist if(length(grep(pattern = temp_aliquot, x = temp_files,fixed = TRUE)) == 0) return(NULL) ##render image output$plot <- renderImage({ ##set filename filename <- temp_files[[grep(pattern = temp_aliquot, x = temp_files, fixed = TRUE)]] #Return a list containing the filename and alt text list(src = filename, alt = paste("Image number", temp_aliquot)) }, deleteFile = FALSE) }) # Download for template ----------------------------------------------------------------------- output$download_template <- downloadHandler( filename = "RCarb_InputTemplate.csv", content = function(file){ ##use the internal function from RCarb RCarb::write_InputTemplate(file = file) }, contentType = "text/csv" ) # Render static pages ------------------------------------------------------------------------- output$about <- renderUI({ HTML(markdown::markdownToHTML(knit('static/about.Rmd', quiet = TRUE, output = tempfile()), fragment.only = TRUE)) }) output$news <- renderUI({ HTML(markdown::markdownToHTML(knit('static/news.Rmd', quiet = TRUE, output = tempfile()), fragment.only = TRUE)) }) })#EOF RLumShiny/inst/shiny/RCarb/global.R0000644000176200001440000000135313413154613016632 0ustar liggesusers## +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ## Title: RCarb Shiny App - global.R ## Authors: Sebastian Kreutzer, IRAMAT-CRP2A, Université Bordeaux Montaigne (France) ## Contact: sebastian.kreutzer@u-bordeaux-montainge.fr ## Initial date: 2018-10-14 ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ##load needed packages require(shiny) require(RCarb) require(shinyjs) require(rmarkdown) require(rhandsontable) require(knitr) ##Shiny settings ## ##increase upload size options(shiny.maxRequestSize = 30 * 1024 ^ 2) ##RCarb ## ##load reference and example data data("Example_Data") data("Reference_Data") temp_files <<- NULL RLumShiny/inst/shiny/RCarb/static/0000755000176200001440000000000013413154613016534 5ustar liggesusersRLumShiny/inst/shiny/RCarb/static/news.Rmd0000644000176200001440000000010013413154613020143 0ustar liggesusers## News and changes ### Version 0.1.0 * Initial version RLumShiny/inst/shiny/RCarb/static/about.Rmd0000644000176200001440000000300713413154613020312 0ustar liggesusers## About this app This software provides a graphical user interface to the R package 'RCarb'. **Version**: 0.1.0 [2018-10-14] **Author**: Sebastian Kreutzer, IRAMAT-CRP2A, UMR 5060, CNRS - Université Bordeaux Montaigne (France) **Contact**: sebastian.kreutzer@u-bordeaux-montaigne.fr ## References to cite ### Underlying R package Kreutzer, S., Nathan, R.P., Mauz, B., 2018. RCarb: Dose Rate Modelling of Carbonate-Rich Samples. R package version 0.1.2. https://CRAN.R-project.org/package=RCarb ### Background modelling Mauz, B., Hoffmann, D., 2014. What to do when carbonate replaced water: Carb, the model for estimating the dose rate of carbonate-rich samples. Ancient TL 32, 24–32. http://ancienttl.org/ATL_32-2_2014/ATL_32-2_Mauz_p24-32.pdf Nathan, R.P., Mauz, B., 2008. On the dose-rate estimate of carbonate-rich sediments for trapped charge dating. Radiation Measurements 43, 14–25. doi: [10.1016/j.radmeas.2007.12.012](https://dx.doi.org/10.1016/j.radmeas.2007.12.012) ## Licence 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. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU [General Public License](https://www.gnu.org/licenses/gpl-3.0.en.html) for more details RLumShiny/inst/shiny/convert/0000755000176200001440000000000013312135106015726 5ustar liggesusersRLumShiny/inst/shiny/convert/ui.R0000644000176200001440000000663613144314151016503 0ustar liggesusers## UI.R function(request) { fluidPage( titlePanel(NULL, windowTitle = "RLumShiny - Fast Ratio"), 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("Measurement file"), accept="application/octet-stream, .bin, .binx"), # import actionButton(inputId = "import", label = "Import", class = "btn btn-success"), tags$hr(), # dynamic elements depending on input file fluidRow( column(width = 6, uiOutput("positions") ), column(width = 6, uiOutput("curveTypes") ) ) ),##EndOf::Tab_1 tabPanel("Curves", div(align = "center", h5("(De)select individual curves")), checkboxGroupInput("curves", "Curves") ),##EndOf::Tab_4 tabPanel("Export", selectInput("targetFile", label = "Export to...", choices = list(".bin(x)" = "write_R2BIN", ".csv" = "write_RLum2CSV")), actionButton("export", "Download file", class = "btn btn-success") ) )##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 fluidRow( uiOutput("positionTabs") ) )##EndOf::mainPanel ),##EndOf::sideBarLayout bookmarkButton() )##EndOf::fluidPage }RLumShiny/inst/shiny/convert/server.R0000644000176200001440000000762013155476737017413 0ustar liggesusers## Server.R ## MAIN FUNCTION function(input, output, session) { # input data (with default) values <- reactiveValues(data = NULL, data_filtered = NULL, positions = NULL, types = NULL) session$onSessionEnded(function() { stopApp() }) # check and read in file (DATA SET 1) observeEvent(input$import, { inFile<- input$file if(is.null(inFile)) return(NULL) # 1. Risoe .bin(x) if (tools::file_ext(inFile$name) == "bin" || tools::file_ext(inFile$name) == "binx") { # rename temp file file <- paste0(inFile$datapath, ".", tools::file_ext(inFile$name)) file.rename(inFile$datapath, file) # import the file values$data <- read_BIN2R(file, fastForward = TRUE, verbose = FALSE) values$data_filtered <- values$data # set some diagnostic values values$positions <- unique(sapply(values$data, function(x) { x@records[[1]]@info$POSITION })) values$types <- unique(sapply(values$data[[1]]@records, function(x) { x@recordType })) } }) output$positions <- renderUI({ if (!is.null(values$positions)) checkboxGroupInput("positions", "Positions", choiceNames = as.character(values$positions), choiceValues = 1:length(values$positions), selected = 1:length(values$positions), inline = TRUE) }) output$curveTypes <- renderUI({ if (!is.null(values$types)) checkboxGroupInput("curveTypes", "Curve types", choices = values$types, selected = values$types) }) ## FILTER ---- observe({ if (is.null(values$data)) return(NULL) data_filtered <- values$data[as.numeric(input$positions)] values$data_filtered <- lapply(data_filtered, function(x) { subset(x, recordType %in% input$curveTypes) }) }) ## --------------------- OUTPUT ------------------------------------------- ## output$positionTabs <- renderUI({ if (is.null(values$data_filtered)) return(NULL) tabs <- lapply(values$positions[as.numeric(input$positions)], function(pos) { tabPanel(pos, plotOutput(paste0("pos", pos))) }) do.call(tabsetPanel, c(id = "tab", tabs)) }) observe({ input$tab values$data values$data_filtered input$curveTypes if (is.null(values$data_filtered) || length(values$data_filtered) == 0) return(NULL) pos <- which(unique(sapply(values$data_filtered, function(x) { x@records[[1]]@info$POSITION })) == input$tab) print(pos) if (length(pos) > 0) updateCheckboxGroupInput(session, "curves", choices = 1:length(values$data_filtered[[pos]]), selected = 1:length(values$data_filtered[[pos]]), inline = TRUE) }) observeEvent(input$export, { if (is.null(values$data_filtered)) return(NULL) do.call(input$targetFile, values$data_filtered) }) observe({ pos_sel <- values$positions[as.numeric(input$positions)] pos_sel_index <- which(values$positions %in% pos_sel) for (i in 1:length(pos_sel)) # Explanation on local({}): # https://gist.github.com/wch/5436415/ local({ local_i <- i output[[paste0("pos", pos_sel[local_i])]] <- renderPlot({ if (is.null(values$data_filtered[[local_i]])) { plot(0, type = "n", axes = FALSE, ann = FALSE) return(NULL) } else { plot(values$data_filtered[[local_i]], combine = TRUE) } }) }) }) }##EndOf::function(input, output)RLumShiny/inst/shiny/convert/select.R0000644000176200001440000000305713145006513017340 0ustar liggesusers## set_selected <- function(x, pos = NULL, curve = NULL) { if (!is.list(x)) stop("\n[set_selected] 'x' must be a list.", call. = FALSE) if (is.list(curve)) if (length(pos) != length(curve)) stop("\n[set_selected] 'x' and 'curve' must be of same length.", call. = FALSE) # Set everything to false for (i in 1:length(x)) { x[[i]]@info$selected <- FALSE for (j in 1:length(x[[i]]@records)) x[[i]]@records[[j]]@info$selected <- FALSE } # Case 3: set selected curves if (!is.null(pos)) { for (i in 1:length(pos)) { x[[pos[i]]]@info$selected <- TRUE if (!is.null(curve)) { for (j in curve[[i]]) { if (is.na(j)) next if (j == 0) next x[[pos[i]]]@records[[j]]@info$selected <- TRUE } } else { for (j in 1:length(x[[pos[i]]]@records)) x[[pos[i]]]@records[[j]]@info$selected <- TRUE } } } return(x) } get_selected <- function(x) { # selected aliquots sel_al <- sapply(x, function(x) x@info$selected) is_null <- which(sapply(sel_al, is.null)) if (length(is_null) != 0) sel_al[is_null] <- FALSE if (is.list(sel_al)) sel_al <- unlist(sel_al) x <- x[sel_al] # selected curves for (i in 1:length(x)) { is_selected <- sapply(x[[i]], function(y) y@info$selected) x[[i]]@records <- x[[i]]@records[is_selected] if (length(x[[i]]@records) == 0) x[[i]] <- NULL } return(x) } RLumShiny/inst/shiny/convert/www/0000755000176200001440000000000013142571357016567 5ustar liggesusersRLumShiny/inst/shiny/convert/www/GitHub-Mark-32px.png0000644000176200001440000000326213020024066022125 0ustar liggesusersPNG  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/convert/www/style.css0000644000176200001440000000242713055560666020452 0ustar liggesusers.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/convert/global.R0000644000176200001440000000026113145006537017321 0ustar liggesusers## global.R ## library(Luminescence) library(RLumShiny) library(shiny) library(data.table) library(rhandsontable) source("select.R") enableBookmarking(store = "server")RLumShiny/inst/shiny/cosmicdose/0000755000176200001440000000000013142565063016410 5ustar liggesusersRLumShiny/inst/shiny/cosmicdose/ui.R0000644000176200001440000001742513020024066017145 0ustar liggesusersfunction(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.R0000644000176200001440000001072713155476400020050 0ustar liggesusers## Server.R ## MAIN FUNCTION function(input, output, session) { session$onSessionEnded(function() { stopApp() }) # 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/0000755000176200001440000000000013055562161017233 5ustar liggesusersRLumShiny/inst/shiny/cosmicdose/www/style.css0000644000176200001440000000277713055560641021123 0ustar liggesusers.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/0000755000176200001440000000000012772146744021623 5ustar liggesusersRLumShiny/inst/shiny/cosmicdose/shiny_bookmarks/5a258b62777fa1b7/0000755000176200001440000000000012772146744023767 5ustar liggesusersRLumShiny/inst/shiny/cosmicdose/shiny_bookmarks/5a258b62777fa1b7/input.rds0000644000176200001440000000057712765763523025653 0ustar liggesusersb```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/0000755000176200001440000000000012772146744023767 5ustar liggesusersRLumShiny/inst/shiny/cosmicdose/shiny_bookmarks/6584528eb04ada68/input.rds0000644000176200001440000000057712765763027025652 0ustar liggesusersb```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\ 0){ colnames(df) <- c("FILE","ALQ", "POSITION", "ID AFFECTED CURVE(S)") rownames(df) <- NULL output$df <- renderDataTable(df) output$text <- renderText({"Stimulation power mismatch detected!"}) }else{ output$text <- renderText({"Everything looks OK"}) } }) ##modify curves observeEvent(input$Display, { if(input$SelectedCurves != "none"){ ##grep wanted curves curves <- get_RLum(file_data, recordType = input$SelectedCurves, curveType = "measured", drop = FALSE) ##sort out all heating curves curves <- lapply(curves, function(c){ if(length(c@records) == 0) return(NULL) records <- lapply(c@records, function(r){ if(r@info$stimulator == "heating element"){ return(NULL) }else{ r } }) ##remove NULL data records <- records[!sapply(records, is.null)] ##construct new RLum.Analysis object set_RLum(class = "RLum.Analysis", records = records) }) ##remove NULL from list curves_rm <- !sapply(curves, is.null) file_info <- file_info[curves_rm,] curves <- curves[curves_rm] ##update slider xrange <- range(structure_RLum(merge_RLum(curves))[,c("x.min", "x.max")]) yrange <- range(structure_RLum(merge_RLum(curves))[,c("y.min", "y.max")]) updateSliderInput(session, inputId = "xrange", value = xrange, min = min(xrange), max = max(xrange)) updateSliderInput(session, inputId = "yrange", value = yrange, min = min(yrange), max = max(yrange)) ##create plot output$curves <- renderPlot({ records <- Luminescence:::.unlist_RLum(get_RLum(curves)) plot_RLum( set_RLum("RLum.Analysis", records = records), xlab = "Stimulation time [s]", ylab = "Stimulation power [mW/cm^2]", main = "Control Plot", xlim = input$xrange, ylim = input$yrange, log = paste0(input$xaxislog, input$yaxislog), legend = FALSE, col = rgb(0,0,0,.8), mtext = paste(length(records), "curves are displayed"), combine = TRUE) }) ##create table with affected values df <- as.data.frame(t(vapply(1:length(curves), function(x){ y_values <- structure_RLum(curves[[x]])[["y.max"]] test <- which(y_values < max(y_values) * 0.95) if(length(test) == 0){ return(c(NA_character_,NA_character_,NA_character_)) }else{ return(c("",x,paste(test, collapse = ","))) } }, character(3)))) ##remove NA df[,1] <- file_info$name df <- na.exclude(df) if(nrow(df) > 0){ colnames(df) <- c("FILE","ALQ", "ID AFFECTED CURVE(S)") rownames(df) <- NULL output$df <- renderDataTable(df) output$text <- renderText({"Stimulation power mismatch detected!"}) }else{ output$text <- renderText({"Everything looks OK"}) } } }) # Static pages -------------------------------------------------------------------------------- output$about <- renderUI({ HTML(markdown::markdownToHTML(knit('static/about.Rmd', quiet = TRUE, output = tempfile()), fragment.only = TRUE)) }) }) RLumShiny/inst/shiny/teststimulationpower/global.R0000644000176200001440000000125113310716135022162 0ustar liggesusers## +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ## Title: Test Stimulation Power App ## Authors: Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) ## Contact: sebastian.kreutzer@u-bordeaux-montainge.fr ## Date: 2017-11-22 ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ##load needed packages library(shiny) library(Luminescence) library(DT) library(knitr) ##Shiny settings options(shiny.maxRequestSize=100*1024^2) enableBookmarking(store = "server") ##initialise data file_data <- NULL file_info <- NULL xrange <- c(0,0) yrange <- c(0,0) RLumShiny/inst/shiny/teststimulationpower/static/0000755000176200001440000000000013310727316022072 5ustar liggesusersRLumShiny/inst/shiny/teststimulationpower/static/about.Rmd0000644000176200001440000000267413310727316023661 0ustar liggesusers### About this app This software was developed for the IRAMAT-CRP2A, Université Bordeaux Montaigne (France) to test the stimulation power of the Freiberg Instruments *lexsyg research* and *lexsyg SMART* readers used in the laboratory. This application only works with XSYG-filesand the shown output is based on results returned by the photodiodes of the OSL unit. The application assumes that the simulation power output does not change from curve to curve during SAR CW-OSL measurements. Any variation beyond a specific threshold is detected as 'mismatch'. *Please note that if a mismatch was detected, the results can only give you an indication of where to look for and does not free you from checking your measurement results.* **Version**: 0.2.3 [2018-06-15] **Author**: Sebastian Kreutzer, IRAMAT-CRP2A, UMR 5060, CNRS - Université Bordeaux Montaigne (France) **Contact**: sebastian.kreutzer@u-bordeaux-montaigne.fr ### Licence 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. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU [General Public License](https://www.gnu.org/licenses/gpl-3.0.en.html) for more details RLumShiny/inst/shiny/scalegamma/0000755000176200001440000000000013334545575016363 5ustar liggesusersRLumShiny/inst/shiny/scalegamma/ui.R0000644000176200001440000001041413415600416017105 0ustar liggesusers## UI.R function(request) { fluidPage( titlePanel(NULL, windowTitle = "RLumShiny - Scale Gamma Dose"), 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 rHandsontableOutput(outputId = "table_in_primary"), helpText(HTML(paste0( tags$b("NOTE: "), "The uploaded file must have exactly 12 columns (see pre-loaded data set above). ", "Only one value in 'Sample offset (cm)' allowed, which indicates the position of the sample in a layer, measured from the bottom of respective layer.", "
Right-click on the table to add or remove rows. Copy-paste is supported.") )) ),##EndOf::Tab_1 tabPanel("Settings", tags$br(), selectInput(inputId = "frac_dose", "Fractional gamma dose table", choices = c("Aitken 1985" = "Aitken1985") ), selectInput(inputId = "conv_fac", "Conversion Factors", choices = c( "Cresswell et al. 2019" = "Cresswelletal2019", "Liritzis et al. 2013" = "Liritzisetal2013", "Guerin et al. 2011" = "Guerinetal2011", "Adamiec & Aitken 1998" = "AdamiecAitken1998" ) ) ), RLumShiny:::exportTab("export", filename = "scalegammadose"), RLumShiny:::aboutTab("about", "scalegammadose") )##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", htmlOutput("error"), plotOutput(outputId = "main_plot", height = "500px"), htmlOutput(outputId = "console")), tabPanel("Infinite matrix \u1E0A\u03B3", dataTableOutput("df_inf")), tabPanel("Scaled \u1E0A\u03B3", dataTableOutput("df_scaled")), tabPanel("R code", verbatimTextOutput("plotCode")) )###EndOf::tabsetPanel )##EndOf::mainPanel ),##EndOf::sideBarLayout bookmarkButton() )##EndOf::fluidPage } RLumShiny/inst/shiny/scalegamma/server.R0000644000176200001440000001400513335247542020006 0ustar liggesusers## Server.R ## MAIN FUNCTION function(input, output, session) { # input data (with default) values <- reactiveValues(data = example_data, data_used = NULL, args = NULL, results = NULL, error = NULL) session$onSessionEnded(function() { stopApp() }) observe({ # 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 = "df_inf", suspendWhenHidden = FALSE) outputOptions(x = output, name = "df_scaled", suspendWhenHidden = FALSE) outputOptions(x = output, name = "main_plot", suspendWhenHidden = FALSE) }) ## FILE INPUT ---- observeEvent(input$file, { inFile<- input$file if(is.null(inFile)) return(NULL) # if no file was uploaded return NULL data <- fread(file = inFile$datapath, data.table = FALSE) # inFile[1] contains filepath ## add or crop columns if (ncol(data) > 12) data <- data[ ,1:12] else if (ncol(data) < 12) { ncol <- 12 - ncol(data) data <- cbind(data, matrix(NA, ncol = ncol)) } values$data <- data }) ## R_HANDSONTABLE ---- output$table_in_primary <- renderRHandsontable({ rh <- rhandsontable(values$data, height = 300, colHeaders = c("Layer ID", "Thickness (cm)", "Sample offset (cm)", "K (%)", "error", "Th (ppm)", "error", "U (ppm)", "error", "Water content (%)", "error", "Density (g/cm3)"), rowHeaders = NULL) rh <- hot_cols(rh, renderer = " function(instance, td, row, col, prop, value, cellProperties) { Handsontable.renderers.NumericRenderer.apply(this, arguments); if (col != 2 && !value) { td.style.background = 'crimson'; td.style.textDecoration = 'line-through'; } else if (col == 2 && !value) { td.style.background = 'darkgrey'; } }") invalid_rows <- which(!complete.cases(values$data[ ,-3])) if (length(invalid_rows) > 0) { for (i in 1:length(invalid_rows)) rh <- hot_cell(rh, row = invalid_rows[i], col = 1, comment = paste("Layer removed due to incomplete layer information.", "Please check all values and fill in missing information", "if applicable.")) } rh }) observeEvent(input$table_in_primary, { if (!is.null(hot_to_r(input$table_in_primary))) values$data <- hot_to_r(input$table_in_primary) }) ## INPUT DATA CHECK ---- observe({ ## remove incomplete rows # note that we have to remove the third column (sample_offset), which # explicitly requires NA values for all non-target layers tmp <- values$data[complete.cases(values$data[ ,-3]), ] values$data_used <- tmp }) ## ARGUMENTS ---- observe({ # compile args args <- list( data = values$data_used, conversion_factors = input$conv_fac, fractional_gamma_dose = input$frac_dose, plot = TRUE, plot_single = TRUE, verbose = FALSE ) # sanitise final list by removing all NULL elements args[sapply(args, is.null)] <- NULL # return values$args <- args }) ## SHINY MODULES ---- observe({ # nested renderText({}) for code output on "R plot code" tab code.output <- callModule(RLumShiny:::printCode, "printCode", n_input = 1, fun = paste0("scale_GammaDose(data,"), args = values$args) output$plotCode<- renderText({ code.output })##EndOf::renderText({}) callModule(RLumShiny:::exportCodeHandler, "export", code = code.output) callModule(RLumShiny:::exportPlotHandler, "export", fun = "scale_GammaDose", args = values$args) }) ## MAIN ---- ## Calculate results # observe({ # tryCatch({ # values$results <- do.call(scale_GammaDose, values$args) # }, error = function(e) { # values$error <- e # values$results <- NULL # }) # }) ## PLOT ---- output$main_plot <- renderPlot({ tryCatch({ values$results <- do.call(scale_GammaDose, values$args) }, error = function(e) { values$error <- e values$results <- NULL }) }) ## ERROR HANDLING ---- output$error <- renderText({ # invalidate all reactive values if (!is.null(values$error)) { values$results <- NULL HTML(paste0( tags$br(), tags$p("ERROR!", style = "color:red; font-size:20px;"), values$error$message )) } }) ## NUMERIC RESULTS ---- output$console <- renderText({ if (is.null(values$results)) return(NULL) values$error <- NULL res <- as.data.frame(get_RLum(values$results)) inf_table <- get_RLum(values$results, "dose_rates")$infinite_matrix HTML(paste0( tags$br(), tags$p("RESULTS", style = "color:#008000; font-size:20px;"), tags$p( tags$b("Target layer: "), res$id, tags$br(), tags$b("Scaled gamma dose rate (Gy/ka): "), f(res$dose_rate_total), "\u00b1", f(res$dose_rate_total_err), tags$br(), style = "font-size:15px" ) )) }) ## TABLE 1: Infinite matrix dose rate ---- output$df_inf <- renderDataTable({ if (is.null(values$results)) return(NULL) df <- get_RLum(values$results, "dose_rates")$`infinite_matrix` for (i in 2:ncol(df)) df[,i] <- f(df[,i]) df }, options = list(ordering = FALSE, searching = FALSE, paging = FALSE)) ## TABLE 2: Scaled gamma dose rate ---- output$df_scaled <- renderDataTable({ if (is.null(values$results)) return(NULL) df <- get_RLum(values$results, "dose_rates")$scaled_dose_rate for (i in 2:ncol(df)) df[,i] <- f(df[,i]) df }, options = list(ordering = FALSE, searching = FALSE, paging = FALSE)) }##EndOf::function(input, output)RLumShiny/inst/shiny/scalegamma/www/0000755000176200001440000000000013334545575017207 5ustar liggesusersRLumShiny/inst/shiny/scalegamma/www/GitHub-Mark-32px.png0000644000176200001440000000326213020024066022537 0ustar liggesusersPNG  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/scalegamma/www/style.css0000644000176200001440000000242713055560666021064 0ustar liggesusers.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/scalegamma/global.R0000644000176200001440000000116713415600222017730 0ustar liggesusers## global.R ## library(Luminescence) library(RLumShiny) library(shiny) library(data.table) library(rhandsontable) if (utils::packageVersion("Luminescence") < "0.9.0") stop( "\n\n", rep("#", 30), "\n", "This application requires 'Luminescence' version >=0.9.0.\n", "See ?Luminescence::install_DevelopmentVersion() to get the ", "latest version of the package.", "\n", rep("#", 30), "\n\n", call. = FALSE) data("ExampleData.ScaleGammaDose") example_data <- ExampleData.ScaleGammaDose f <- function(x, d = 3) formatC(x, digits = d, format = "f") enableBookmarking(store = "server")RLumShiny/inst/shiny/fading/0000755000176200001440000000000013146762022015506 5ustar liggesusersRLumShiny/inst/shiny/fading/ui.R0000644000176200001440000001650713147010460016250 0ustar liggesusers## UI.R function(request) { fluidPage( titlePanel(NULL, windowTitle = "RLumShiny - Fading"), 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 rHandsontableOutput(outputId = "table_in_primary"), hr(), helpText(HTML(paste( tags$b("PLEASE NOTE:"), "Estimation of the g-value and correcting for fading using the approach after Huntley & Lamothe (2001) is computationally expensive, which is why the number of Monte Carlo simulations is fixed to 100 and 1000, respectively. Consider running the code given in the R code panels with a higher number of MC iterations in a local R environment." ))) ),##EndOf::Tab_1 # Tab 2: Fading correction tabPanel("Age correction", div(align = "center", h5("Fading correction after Huntley & Lamothe (2001)")), hr(), fluidRow( column(width = 6, numericInput(inputId = "age_faded", HTML("Age (ka)", "(faded)"), min = 0, step = 1, value = 10)), column(width = 6, numericInput(inputId = "age_error_faded", "Age error", min = 0, step = 1, value = 1)) ), checkboxInput(inputId = "override_gval", "Manual g-value", FALSE), conditionalPanel("input.override_gval == true", fluidRow( column(width = 6, numericInput(inputId = "g_value", "g-value (%/decade)", min = 0, step = 0.01, value = 5.18)), column(width = 6, numericInput(inputId = "g_value_error", "g-value error", min = 0, step = 0.01, value = 0.75)) ), helpText(HTML( "Tc = time in seconds between irradiation and the prompt measurement (cf. Huntley & Lamothe 2001).

", "Tc, g-value = the time in seconds between irradiation and the prompt measurement used for estimating the g-value. If the g-value was normalised to, e.g., 2 days, this time in seconds (i.e., 172800) should be given here. This time should be identical to tc, which is usually case for g-values obtained using the SAR method and g-values that had been not normalised to 2 days.")), fluidRow( column(width = 6, numericInput(inputId = "tc", HTML("Tc"), min = 0, step = 1, value = 378)), column(width = 6, numericInput(inputId = "tc_gval", HTML("Tc, g-value"), min = 0, step = 1, value = 172800)) ) ) ), # Tab 4: modify axis parameters RLumShiny:::exportTab("export", filename = "analyseFading"), RLumShiny:::aboutTab("about", "fading") )##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 = "450px"), fluidRow( column(6, htmlOutput(outputId = "results")), column(6, htmlOutput(outputId = "results_corr")) )), tabPanel("R code (g-value)", verbatimTextOutput("plotCode")), tabPanel("R code (age correction)", verbatimTextOutput("corrCode")) )###EndOf::tabsetPanel )##EndOf::mainPanel ),##EndOf::sideBarLayout bookmarkButton() )##EndOf::fluidPage }RLumShiny/inst/shiny/fading/server.R0000644000176200001440000001330613155477007017150 0ustar liggesusers## Server.R ## MAIN FUNCTION function(input, output, session) { # input data (with default) values <- reactiveValues(data_primary = if ("startData" %in% names(.GlobalEnv)) startData else ExampleData.Fading$fading.data$IR50, data = NULL, args = NULL, args_corr = NULL, results = NULL, results_corr = NULL) session$onSessionEnded(function() { stopApp() }) # check and read in file (DATA SET 1) observeEvent(input$file, { inFile<- input$file 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 }) output$table_in_primary <- renderRHandsontable({ rhandsontable(values$data_primary, height = 300, colHeaders = c("LxTx", "LxTx error", "Time since irradiation"), 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_primary <- hot_to_r(df_tmp) }) # Arguments observe({ values$data <- values$data_primary values$args <- list( object = values$data, structure = c("Lx", "Tx"), t_star = "half", n.MC = 100, verbose = FALSE, plot = TRUE, plot.single = 3 ) }) # MAIN (analyse_FadingMeasurement) ---- output$main_plot <- renderPlot({ values$results <- try(do.call(analyse_FadingMeasurement, values$args)) }) # MAIN (calc_FadingCorr) ---- observe({ if (!input$override_gval) if (is.null(values$results)) return(NULL) if (inherits(values$results, "try-error")) return(NULL) values$results@originator <- "analyse_FadingMeasurement" values$args_corr <- list( age.faded = c(input$age_faded, input$age_error_faded), g_value = if (input$override_gval) c(input$g_value, input$g_value_error) else values$results, tc = input$tc, tc.g_value = input$tc_gval, verbose = FALSE, txtProgressBar = FALSE, n.MC = 1000 ) values$results_corr <- try(do.call(calc_FadingCorr, values$args_corr)) }) observe({ # nested renderText({}) for code output on "R plot code" tab code.output <- callModule(RLumShiny:::printCode, "printCode", n_input = 1, fun = "analyse_FadingMeasurement(data,", args = values$args) output$plotCode<- renderText({ code.output })##EndOf::renderText({}) callModule(RLumShiny:::exportCodeHandler, "export", code = code.output) callModule(RLumShiny:::exportPlotHandler, "export", fun = "analyse_FadingMeasurement", args = values$args) }) output$corrCode <- renderText({ if (input$override_gval) { gval <- values$args_corr$g_value tc <- input$tc } else { gval <- c(values$results@data$fading_results$FIT, values$results@data$fading_results$SD) tc <- values$results@data$fading_results$TC } paste( "# To reproduce the plot in your local R environment", "# copy and run the following code to your R console.", "library(Luminescence)", "\n", "calc_FadingCorr(", paste0("age.faded = c(", values$args_corr$age.faded[1], ", ", values$args_corr$age.faded[2], "),"), paste0("g_value = c(", gval[1], ", ", gval[2], "),"), paste0("tc = ", tc, ", "), paste0("tc.g_value = ", input$tc_gval, ","), paste0("n.MC = 1000)"), sep = "\n") }) output$results <- renderText({ if (is.null(values$results)) return(NULL) if (inherits(values$results, "try-error")) return(NULL) gval <- get_RLum(values$results) rho <- get_RLum(values$results, "rho_prime") HTML(paste0( tags$hr(), tags$b("g-value: "), signif(gval$FIT, 3), " ± ", signif(gval$SD, 3), " %/decade", tags$br(), tags$b("g-value"), tags$sub("2days"), ": ", signif(gval$G_VALUE_2DAYS, 3), " ± ", signif(gval$G_VALUE_2DAYS.ERROR, 3), " %/decade", tags$br(), tags$b("t"), tags$sub("c"), ": ", gval$TC, tags$br(), " ρ': ", signif(rho$MEAN, 3), " ± ", signif(rho$SD, 3), tags$br(), " » log10(ρ'): ", signif(log10(rho$MEAN), 3), " ± ", signif(rho$SD / (rho$MEAN * log(10, base = exp(1))), 3) )) }) output$results_corr <- renderText({ if (is.null(values$results_corr) || inherits(values$results_corr, "try-error")) res <- data.frame(AGE = NA, AGE.ERROR = NA) else res <- get_RLum(values$results_corr) HTML(paste0( tags$hr(), tags$b("Age "), tags$em("(faded): "), input$age_faded, " ± ", input$age_error_faded, " ka", tags$br(), tags$b("Age "), tags$em("(corrected): "), signif(res$AGE, 3), " ± ", signif(res$AGE.ERROR, 3), " ka" )) }) }##EndOf::function(input, output)RLumShiny/inst/shiny/fading/www/0000755000176200001440000000000013146762022016332 5ustar liggesusersRLumShiny/inst/shiny/fading/www/GitHub-Mark-32px.png0000644000176200001440000000326213020024066021675 0ustar liggesusersPNG  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/fading/www/style.css0000644000176200001440000000242713055561031020205 0ustar liggesusers.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/fading/global.R0000644000176200001440000000032213146762123017070 0ustar liggesusers## global.R ## library(Luminescence) library(RLumShiny) library(shiny) library(data.table) library(rhandsontable) data("ExampleData.Fading", envir = environment()) enableBookmarking(store = "server")RLumShiny/inst/shiny/KDE/0000755000176200001440000000000013142565123014660 5ustar liggesusersRLumShiny/inst/shiny/KDE/ui.R0000644000176200001440000003707713142551431015433 0ustar liggesusers## UI.R function(request) { fluidPage( titlePanel(NULL, windowTitle = "RLumShiny - KDE"), 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.") ) ), 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 RLumShiny:::exportTab("export", filename = "KDE"), RLumShiny:::aboutTab("about", "KDE") )##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.R0000644000176200001440000002047113155476400016320 0ustar liggesusers## MAIN FUNCTION function(input, output, session) { # input data (with default) values <- reactiveValues(data_primary = if ("startData" %in% names(.GlobalEnv)) startData else ExampleData.DeValues$CA1, data_secondary = setNames(as.data.frame(matrix(NA_real_, nrow = 5, ncol = 2)), c("x", "y")), data = NULL, args = NULL) session$onSessionEnded(function() { stopApp() }) # 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 observe({ ### 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"))) values$data <- 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, values$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, values$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() observe({ # 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) # refresh plot on button press input$refresh # check if any summary stats are activated, else NA summary <- if (input$summary) input$stats else "" logx <- ifelse(input$logx, "x", "") # if custom datapoint color get RGB code from separate input panel color <- ifelse(input$color == "custom", input$rgb, input$color) # if custom datapoint color get RGB code from separate input panel if(!all(is.na(unlist(values$data_secondary)))) { color2 <- ifelse(input$color2 == "custom", input$rgb2, input$color2) } else { color2<- adjustcolor("white", alpha.f = 0) } values$args <- list( data = values$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)) }) output$main_plot <- renderPlot({ # validate(need()) makes sure that all data are available to # renderUI({}) before plotting and will wait until there validate( need(expr = input$xlim, message = ''), need(expr = input$bw, message = 'Waiting for data... Please wait!') ) do.call(plot_KDE, args = values$args) })##EndOf::renderPlot({}) observe({ # nested renderText({}) for code output on "R plot code" tab code.output <- callModule(RLumShiny:::printCode, "printCode", n_input = 2, fun = "plot_KDE(data,", args = values$args) output$plotCode<- renderText({ code.output })##EndOf::renderText({}) callModule(RLumShiny:::exportCodeHandler, "export", code = code.output) callModule(RLumShiny:::exportPlotHandler, "export", fun = "plot_KDE", args = values$args) }) # 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').values$data.toArray()); }); }", { data <- values$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').values$data.toArray()); }); }", { if(!all(is.na(unlist(values$data_secondary)))) { data <- values$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 <- values$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/0000755000176200001440000000000013055562161015506 5ustar liggesusersRLumShiny/inst/shiny/KDE/www/GitHub-Mark-32px.png0000644000176200001440000000326213020024066021050 0ustar liggesusersPNG  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.css0000644000176200001440000000242713055560756017375 0ustar liggesusers.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/0000755000176200001440000000000012772146744020076 5ustar liggesusersRLumShiny/inst/shiny/KDE/shiny_bookmarks/62408c76eac4976d/0000755000176200001440000000000012772146744022250 5ustar liggesusersRLumShiny/inst/shiny/KDE/shiny_bookmarks/62408c76eac4976d/input.rds0000644000176200001440000000074012765761574024130 0ustar liggesusers}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.R0000644000176200001440000000031513053273270016242 0ustar liggesusers## 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/fastratio/0000755000176200001440000000000013312134514016244 5ustar liggesusersRLumShiny/inst/shiny/fastratio/ui.R0000644000176200001440000004360213142346225017016 0ustar liggesusers## UI.R function(request) { fluidPage( titlePanel(NULL, windowTitle = "RLumShiny - Fast Ratio"), 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", div(align = "center", h5("Input data preprocessing")), sliderInput(inputId = "deadchannels", "Dead channels", value = c(1, 1000), min = 1, max = 1000, step = 1, dragRange = TRUE), div(align = "center", h5("Simulation source")), # Stimulation power and wavelength fluidRow( column(width = 6, numericInput(inputId = "stimpow", label = "Irradiance (W/cm^2)", value = 30.6, min = 0.1, step = 0.1) ), column(width = 6, numericInput(inputId = "wavelength", label = "Wavelength (nm)", value = 470, min = 1, step = 1) ) ), div(align = "center", h5("Photoionisation cross-sections (cm^2)")), # Photoionisation cross-sections fluidRow( column(width = 6, HTML("Fast component"), fluidRow( column(width = 6, numericInput(inputId = "cs1base", label = "Base value", value = 2.60, min = 0.01, step = 0.1) ), column(width = 6, numericInput(inputId = "cs1exp", label = "Exponent", value = 17, min = 1, step = 1) ) ) ), column(width = 6, HTML("Medium component"), fluidRow( column(width = 6, numericInput(inputId = "cs2base", label = "Base value", value = 4.28, min = 0.01, step = 0.01) ), column(width = 6, numericInput(inputId = "cs2exp", label = "Exponent", value = 18, min = 1, step = 1) ) ) ) ), div(align = "center", h5("Channels")), # L1 checkboxInput(inputId = "overrideL1", "Override channel for L1", value = FALSE), conditionalPanel("input.overrideL1 == true", # TODO: call updateSlider in Server.R to update max range sliderInput(inputId = "L1", "Channel L1", value = 1, min = 1, max = 1000, step = 1)), # L2 checkboxInput(inputId = "overrideL2", "Override channel for L2", value = FALSE), conditionalPanel("input.overrideL2 == true", # TODO: call updateSlider in Server.R to update max range sliderInput(inputId = "L2", "Channel L2", value = 50, min = 1, max = 1000, step = 1)), # L3 checkboxInput(inputId = "overrideL3", "Override channels for L3", value = FALSE), conditionalPanel("input.overrideL3 == true", # TODO: call updateSlider in Server.R to update max range sliderInput(inputId = "L3", "Channel L3", value = c(400, 600), min = 1, max = 1000, step = 1, dragRange = TRUE)), div(align = "center", h5("% of signal remaining")), fluidRow( column(width = 6, numericInput(inputId = "x", label = "...from the fast component", value = 1, min = 0.1, max = 100, step = 0.1) ), column(width = 6, numericInput(inputId = "x1", label = "...from the medium component", value = 0.1, min = 0.1, max = 100, step = 0.1) ) ) ), tabPanel("Experimental", div(align = "center", h5("Curve fitting")), checkboxInput(inputId = "fitCWsigma", label = "Calculate and use photoionisaton cross-sections", value = FALSE), checkboxInput(inputId = "fitCWcurve", label = "Derive fast ratio from fitted OSL curve", value = FALSE) ), tabPanel("Plot", div(align = "center", h5("Title")), textInput(inputId = "main", label = "Title", value = "Fast Ratio"), radioButtons("type", "Type", selected = "b", inline = TRUE, choices = c("Line" = "l", "Points" = "p", "Line+Points" = "b")), fluidRow( column(width = 6, selectInput(inputId = "pch", label = "Style", selected = "1", 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("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 = FALSE), textInput(inputId = "xlab", label = "Label x-axis", value = "t (s)"), # inject sliderInput from Server.R br(), div(align = "center", h5("Y-axis")), checkboxInput(inputId = "logy", label = "Logarithmic y-axis", value = FALSE), textInput(inputId = "ylab", label = "Label y-axis (left)", value = "Signal (cts)") ),##EndOf::Tab_4 RLumShiny:::exportTab("export", filename = "fast ratio"), RLumShiny:::aboutTab("about", "fastratio") )##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 fluidRow( tabsetPanel( tabPanel("Results", plotOutput(outputId = "main_plot", height = "500px"), htmlOutput(outputId = "results") ), tabPanel("R code", verbatimTextOutput("plotCode")) ) ) )##EndOf::mainPanel ),##EndOf::sideBarLayout bookmarkButton() )##EndOf::fluidPage }RLumShiny/inst/shiny/fastratio/server.R0000644000176200001440000001336613155477055017725 0ustar liggesusers## Server.R ## MAIN FUNCTION function(input, output, session) { # input data (with default) values <- reactiveValues(data_primary = if ("startData" %in% names(.GlobalEnv)) startData else ExampleData.CW_OSL_Curve, args = NULL, results = NULL) session$onSessionEnded(function() { stopApp() }) # check and read in file (DATA SET 1) observeEvent(input$file, { inFile<- input$file 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 updateSliderInput(session, "deadchannels", value = c(1, nrow(values$data_primary)), max = nrow(values$data_primary)) }) output$table_in_primary <- renderRHandsontable({ rhandsontable(values$data_primary, height = 300, colHeaders = c("Time", "Signal"), rowHeaders = NULL) }) observeEvent(input$fitCWsigma, { # restore default values (Durcan and Duller, 2011) Map(function(id, val) { updateNumericInput(session, id, value = val) }, c("cs1base", "cs1exp", "cs2base", "cs2exp"), c(2.60, 17, 4.28, 18)) }) 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_primary <- hot_to_r(df_tmp) }) observeEvent(input$overrideL1, { updateSliderInput(session, "L1", max = nrow(values$data_primary)) }) observeEvent(input$overrideL2, { updateSliderInput(session, "L2", max = nrow(values$data_primary)) }) observeEvent(input$overrideL1, { updateSliderInput(session, "L3", max = nrow(values$data_primary)) }) observe({ values$args <- list( # calc_FastRatio arguments object = values$data_primary[input$deadchannels[1]:input$deadchannels[2], ], stimulation.power = input$stimpow, wavelength = input$wavelength, sigmaF = input$cs1base * 10^-input$cs1exp, sigmaM = input$cs2base * 10^-input$cs2exp, Ch_L1 = ifelse(input$overrideL1, input$L1, 1), x = input$x, x2 = input$x1, fitCW.sigma = input$fitCWsigma, fitCW.curve = input$fitCWcurve, verbose = FALSE, # generic plot arguments main = input$main, type = input$type, pch = ifelse(input$pch == "custom", input$custompch, as.numeric(input$pch)), col = ifelse(input$color == "custom", input$jscol1, input$color), cex = input$cex, xlab = input$xlab, ylab = input$ylab, log = paste0("", ifelse(input$logx, "x", ""), ifelse(input$logy, "y", "")) ) if (input$overrideL2) values$args <- modifyList(isolate(values$args), list(Ch_L2 = input$L2)) if (input$overrideL3) values$args <- modifyList(isolate(values$args), list(Ch_L3 = range(as.numeric(input$L3)))) }) output$main_plot <- renderPlot({ values$results <- do.call(calc_FastRatio, values$args) }) # update numeric input with photoionisation cross-sections calculated # by fit_CWCurve() observeEvent(values$results, { if (input$fitCWsigma) { updateNumericInput(session, "cs1base", value = as.numeric(strsplit(as.character(values$results@data$summary$sigmaF), "e-")[[1]][1])) updateNumericInput(session, "cs1exp", value = as.numeric(strsplit(as.character(values$results@data$summary$sigmaF), "e-")[[1]][2])) updateNumericInput(session, "cs2base", value = as.numeric(strsplit(as.character(values$results@data$summary$sigmaM), "e-")[[1]][1])) updateNumericInput(session, "cs2exp", value = as.numeric(strsplit(as.character(values$results@data$summary$sigmaM), "e-")[[1]][2])) } }) # Render numeric results in a data table output$results <- renderUI({ res <- get_RLum(values$results) HTML(paste0( tags$b("Fast ratio: "), signif(res$fast.ratio, 2), " ± ", signif(res$fast.ratio.se, 2), tags$i("(", signif(res$fast.ratio.rse, 2), "% rel. error)"), tags$br(), tags$br(), tags$b(" Time (s) | Channel | Counts:"), tags$br(), tags$b("L1: "), signif(res$t_L1, 2), " / ", res$Ch_L1, " / ", signif(res$Cts_L1, 2), tags$br(), tags$b("L2: "), signif(res$t_L2, 2), " / ", res$Ch_L2, " / ", signif(res$Cts_L2, 2), tags$br(), tags$b("L3 start: "), signif(res$t_L3_start, 2), " / ", res$Ch_L3_start, " /", tags$br(), tags$b("L3 end: "), signif(res$t_L3_end, 2), " / ", res$Ch_L3_end, " / ", signif(res$Cts_L3, 2) )) }) observe({ # nested renderText({}) for code output on "R plot code" tab code.output <- callModule(RLumShiny:::printCode, "printCode", n_input = 1, fun = "calc_FastRatio(data,", args = values$args) output$plotCode<- renderText({ code.output })##EndOf::renderText({}) callModule(RLumShiny:::exportCodeHandler, "export", code = code.output) callModule(RLumShiny:::exportPlotHandler, "export", fun = "calc_FastRatio", args = values$args) }) }##EndOf::function(input, output)RLumShiny/inst/shiny/fastratio/www/0000755000176200001440000000000013142322475017076 5ustar liggesusersRLumShiny/inst/shiny/fastratio/www/GitHub-Mark-32px.png0000644000176200001440000000326213020024066022441 0ustar liggesusersPNG  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/fastratio/www/style.css0000644000176200001440000000242713055561031020751 0ustar liggesusers.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/fastratio/global.R0000644000176200001440000000033013142322651017625 0ustar liggesusers## 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/shiny/abanico/0000755000176200001440000000000013151303641015644 5ustar liggesusersRLumShiny/inst/shiny/abanico/ui.R0000644000176200001440000017574413151303641016426 0ustar liggesusers## 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.") ), RLumShiny:::exportTab("export", filename = "abanico plot"), RLumShiny:::aboutTab("about", "abanico") )##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.R0000644000176200001440000004166513151303641017311 0ustar liggesusers## 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")), data = NULL, args = NULL) ### GET DATA SETS observe({ ### 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) } values$data <- sub }) 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<- values$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(values$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(values$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(values$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() output$centralityNumeric<- renderUI({ data <- values$data numericInput(inputId = "centralityNumeric", label = "Value", value = round(mean(data[[1]][,1]), 2), step = 0.01) }) observe({ # refresh plot on button press input$refresh # 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) # if custom datapoint color get RGB code from separate input panel color <- ifelse(input$color == "custom", input$jscol1, 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) # create numeric vector of lines line <- sapply(1:8, function(x) input[[paste0("line", x)]]) # create char vector of line colors line.col <- sapply(1:8, function(x) input[[paste0("colline", x)]]) # create char vector of line labels line.label <- sapply(1:8, function(x) input[[paste0("labline", x)]]) # create integer vector of line types line.lty <- sapply(1:8, function(x) as.numeric(input[[paste0("linelty", x)]])) # if custom polygon color get RGB from separate input panel or "none" polygon.col <- ifelse(input$polygon == "custom", adjustcolor(col = input$rgbPolygon, alpha.f = input$alpha.polygon/100), 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) polygon.col2 <- ifelse(input$polygon2 == "custom", adjustcolor(col = input$rgbPolygon2, alpha.f = input$alpha.polygon/100), 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" bar.col <- ifelse(input$bar == "custom", adjustcolor(col = input$rgbBar, alpha.f = input$alpha.bar/100), 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 bar.col2 <- ifelse(input$bar2 == "custom", adjustcolor(col = input$rgbBar2, alpha.f = input$alpha.bar/100), 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" grid.col <- ifelse(input$grid == "custom", adjustcolor(col = input$rgbGrid, alpha.f = input$alpha.grid/100), ifelse(input$grid == "none", input$grid, adjustcolor(col = input$grid, alpha.f = input$alpha.grid/100))) # 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 centrality <- ifelse(input$centrality == "custom", input$centralityNumeric, input$centrality) # check wether predefined or custom dispersion dispersion<- ifelse(input$dispersion == "custom", paste("p", input$cinn, sep=""), input$dispersion) # save all arguments in a list values$args<- list(data = values$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 = if (input$summary) input$stats else NA, 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) }) # render Abanico Plot output$main_plot <- renderPlot({ # 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!')) # plot Abanico Plot do.call(what = plot_AbanicoPlot, args = values$args) })##EndOf::renderPlot({}) observe({ # nested renderText({}) for code output on "R plot code" tab code.output <- callModule(RLumShiny:::printCode, "printCode", n_input = ifelse(!all(is.na(unlist(values$data_secondary))), 2, 1), fun = "plot_AbanicoPlot(data,", args = values$args) output$plotCode<- renderText({ code.output })##EndOf::renderText({}) callModule(RLumShiny:::exportCodeHandler, "export", code = code.output) callModule(RLumShiny:::exportPlotHandler, "export", fun = "plot_AbanicoPlot", args = values$args) }) 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').values$data.toArray()); }); }", { data <- values$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').values$data.toArray()); }); }", { if(!all(is.na(unlist(values$data_secondary)))) { data <- values$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<- values$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/0000755000176200001440000000000013055562161016477 5ustar liggesusersRLumShiny/inst/shiny/abanico/www/GitHub-Mark-32px.png0000644000176200001440000000326213020024066022041 0ustar liggesusersPNG  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.css0000644000176200001440000000242713055560617020362 0ustar liggesusers.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/0000755000176200001440000000000012772146744021067 5ustar liggesusersRLumShiny/inst/shiny/abanico/shiny_bookmarks/8027aaa9b994c7bd/0000755000176200001440000000000012772146744023373 5ustar liggesusersRLumShiny/inst/shiny/abanico/shiny_bookmarks/8027aaa9b994c7bd/input.rds0000644000176200001440000000211212765763305025240 0ustar liggesusersVEǮ}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.R0000644000176200001440000000034713053072440017234 0ustar liggesusers## 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/0000755000176200001440000000000013146535602016255 5ustar liggesusersRLumShiny/inst/shiny/histogram/ui.R0000644000176200001440000005242613142550750017023 0ustar liggesusersfunction(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 RLumShiny:::exportTab("export", filename = "histogram"), RLumShiny:::aboutTab("about", "histogram") )##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.R0000644000176200001440000001323013155477076017717 0ustar liggesusers## Server.R ## MAIN FUNCTION function(input, output, session) { # input data (with default) values <- reactiveValues(data = if ("startData" %in% names(.GlobalEnv)) startData else ExampleData.DeValues$CA1, args = NULL) session$onSessionEnded(function() { stopApp() }) # 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) }) observe({ # 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) # color of plor elements pch.color <- ifelse(input$pchColor == "custom", input$pchRgb, input$pchColor) bars.color <- ifelse(input$barsColor == "custom", adjustcolor(col = input$barsRgb, alpha.f = input$alpha.bars/100), adjustcolor(col = input$barsColor, alpha.f = input$alpha.bars/100)) rugs.color <- ifelse(input$rugsColor == "custom", input$rugsRgb, input$rugsColor) normal.color <- ifelse(input$normalColor == "custom", input$normalRgb, input$normalColor) colors<- c(bars.color, rugs.color, normal.color, pch.color) values$args <- list( data = values$data, na.rm = TRUE, cex.global = input$cex, pch = ifelse(input$pch == "custom", input$custompch, as.integer(input$pch) - 1), xlim = input$xlim, summary.pos = input$sumpos, mtext = input$mtext, main = input$main, rug = input$rugs, se = input$errorBars, normal_curve = input$norm, summary = if (input$summary) input$stats else NA, xlab = input$xlab, ylab = c(input$ylab1, input$ylab2), colour = colors) }) output$main_plot <- renderPlot({ validate(need(input$xlim, "Just wait a second...")) do.call(plot_Histogram, args = values$args) })##EndOf::renderPlot({}) observe({ # nested renderText({}) for code output on "R plot code" tab code.output <- callModule(RLumShiny:::printCode, "printCode", n_input = 1, fun = "plot_Histogram(data,", args = values$args) output$plotCode<- renderText({ code.output })##EndOf::renderText({}) callModule(RLumShiny:::exportCodeHandler, "export", code = code.output) callModule(RLumShiny:::exportPlotHandler, "export", fun = "plot_Histogram", args = values$args) }) # 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/0000755000176200001440000000000013055562161017100 5ustar liggesusersRLumShiny/inst/shiny/histogram/www/GitHub-Mark-32px.png0000644000176200001440000000326213020024066022442 0ustar liggesusersPNG  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.css0000644000176200001440000000242713055560564020764 0ustar liggesusers.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/0000755000176200001440000000000013052620605021451 5ustar liggesusersRLumShiny/inst/shiny/histogram/shiny_bookmarks/1c021999f0efd158/0000755000176200001440000000000013052620605023615 5ustar liggesusersRLumShiny/inst/shiny/histogram/shiny_bookmarks/1c021999f0efd158/input.rds0000644000176200001440000000346113052620605025472 0ustar liggesusersZKEyE^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.R0000644000176200001440000000036213052617417017642 0ustar liggesusers## 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/0000755000176200001440000000000013142565137016527 5ustar liggesusersRLumShiny/inst/shiny/transformCW/ui.R0000644000176200001440000002676613142563212017300 0ustar liggesusers## 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 RLumShiny:::exportTab("export", filename = "transformCW"), RLumShiny:::aboutTab("about", "transformCW") )##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")))), tabPanel("R code", verbatimTextOutput("plotCode")) )###EndOf::tabsetPanel )##EndOf::mainPanel ),##EndOf::sideBarLayout bookmarkButton(), downloadButton("exportScript", "Download transformed data", class="btn btn-success") )##EndOf::fluidPage }RLumShiny/inst/shiny/transformCW/server.R0000644000176200001440000001163213155476700020164 0ustar liggesusers## Server.R ## MAIN FUNCTION function(input, output, session) { # input data (with default) values <- reactiveValues(data_primary = if ("startData" %in% names(.GlobalEnv)) startData else ExampleData.CW_OSL_Curve, tdata = NULL, args = NULL, pargs = NULL) session$onSessionEnded(function() { stopApp() }) # check and read in file (DATA SET 1) observeEvent(input$file, { inFile<- input$file 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 }) output$table_in_primary <- renderRHandsontable({ rhandsontable(values$data_primary, height = 300, colHeaders = c("Time", "Signal"), 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_primary <- hot_to_r(df_tmp) }) # TRANSFORM DATA observe({ P <- input$p delta <- input$delta # validate method parameters if (is.na(input$delta)) { updateNumericInput(session, "delta", value = 1) delta <- 1 } else if (input$delta < 1) { updateNumericInput(session, "delta", value = 1) delta <- 1 } # validate method parameters if (is.na(input$p)) { updateNumericInput(session, "p", value = 1) P <- 1 } else if (input$p < 1) { updateNumericInput(session, "p", value = 1) P <- 1 } args <- list(values$data_primary) if (input$method == "CW2pHMi") if (delta >= 1) args <- append(args, delta) if (input$method == "CW2pLMi" || input$method == "CW2pPMi") if (P >= 1) args <- append(args, P) values$args <- args # values$export_args <- args 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() } values$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, values$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() { "transformedCW.txt" }, content = function(file) { write.table(values$tdata, file, sep = ",", quote = FALSE, row.names = FALSE) },#EO content =, contentType = "text" )#EndOf::dowmloadHandler() }) observe({ # nested renderText({}) for code output on "R plot code" tab code.output <- callModule(RLumShiny:::printCode, "printCode", n_input = 1, fun = paste0(input$method, "(data,"), args = values$args) output$plotCode<- renderText({ code.output })##EndOf::renderText({}) callModule(RLumShiny:::exportCodeHandler, "export", code = code.output) callModule(RLumShiny:::exportPlotHandler, "export", fun = "plot", args = values$pargs) }) output$dataset <- renderDataTable({ if (!is.null(values$tdata)) values$tdata }) }##EndOf::function(input, output)RLumShiny/inst/shiny/transformCW/www/0000755000176200001440000000000013055562161017350 5ustar liggesusersRLumShiny/inst/shiny/transformCW/www/GitHub-Mark-32px.png0000644000176200001440000000326213020024066022712 0ustar liggesusersPNG  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.css0000644000176200001440000000242713055561031021222 0ustar liggesusers.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/shiny_bookmarks/0000755000176200001440000000000012772146744021740 5ustar liggesusersRLumShiny/inst/shiny/transformCW/shiny_bookmarks/cad3028cccb4abdb/0000755000176200001440000000000012772146744024514 5ustar liggesusersRLumShiny/inst/shiny/transformCW/shiny_bookmarks/cad3028cccb4abdb/input.rds0000644000176200001440000000054212765615524026365 0ustar liggesusersuRQK0n@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/0000755000176200001440000000000012772146744024026 5ustar liggesusersRLumShiny/inst/shiny/transformCW/shiny_bookmarks/383978aa9a560a09/input.rds0000644000176200001440000000054212765755551025704 0ustar liggesusersuRQK0n@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/0000755000176200001440000000000012772146744024010 5ustar liggesusersRLumShiny/inst/shiny/transformCW/shiny_bookmarks/211d00e884a92c90/input.rds0000644000176200001440000000054212765755566025674 0ustar liggesusersuRQK0n@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/0000755000176200001440000000000012772146744024237 5ustar liggesusersRLumShiny/inst/shiny/transformCW/shiny_bookmarks/0bba99060aa8d69f/input.rds0000644000176200001440000000054412765754030026106 0ustar liggesusersuRQK0n׺" ǂ?@狏>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/0000755000176200001440000000000012772146744024200 5ustar liggesusersRLumShiny/inst/shiny/transformCW/shiny_bookmarks/99c9d1b8f309e36d/input.rds0000644000176200001440000000054212765615424026050 0ustar liggesusersuRQK0n@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/0000755000176200001440000000000012772146744024075 5ustar liggesusersRLumShiny/inst/shiny/transformCW/shiny_bookmarks/f0d30b74a68561f3/input.rds0000644000176200001440000000054512765753536025757 0ustar liggesusers]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,=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 release RLumShiny/R/0000755000176200001440000000000013413154613012346 5ustar liggesusersRLumShiny/R/module_printCode.R0000644000176200001440000000254613142557677016014 0ustar liggesusersprintCode <- function(input, output, session, n_input, fun, args) { # prepare code as text output str1 <- "data <- data.table::fread(file, data.table = FALSE)" if (n_input == 2) { 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) if (is.null(names)) names <- rep(NA, length(args)) names[which(names == "")] <- NA 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" if (!is.na(name)) paste(name, "=", arg) else arg }, names[-1], args[-1]), collapse = ",\n") funCall <- paste0(fun, "\n", verb.arg, ")") code.output <- paste0(header, funCall, collapse = "\n") return(code.output) }RLumShiny/R/popover.R0000644000176200001440000000473713124163245014176 0ustar liggesusers#' 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.R0000644000176200001440000000546313124201151014141 0ustar liggesusers#' 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.R0000644000176200001440000000701113413154613014207 0ustar liggesusers#' 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`] \cr #' Fast Ratio \tab *fastratio* \tab [`calc_FastRatio`] \cr #' Fading Correction \tab *fading* \tab [`analyse_FadingMeasurement`], [`calc_FadingCorr`] \cr #' Test Stimulation Power \tab *teststimulationpower* \tab [`plot_RLum`] \cr #' Scale Gamma Dose Rate \tab *scalegamma* \tab `scale_GammaDose` \cr #' RCarb app \tab *RCarb* \tab [RCarb::model_DoseRate] #' } #' #' 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") #' app_RLum("fastratio") #' app_RLum("fading") #' app_RLum("surfaceexposure") #' app_RLum("teststimulationpower") #' app_RLum("scalegamma") #' app_RLum("RCarb") #' } #' #' @md #' @export app_RLum app_RLum <- function(app = NULL, ...) { valid_apps <- c("abanico", "cosmicdose", "doserecovery", "histogram", "KDE", "radialplot", "transformCW", "filter", "fastratio", "fading", "surfaceexposure", "teststimulationpower", "scalegamma", "RCarb" ) 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.R0000644000176200001440000000632713124162760014174 0ustar liggesusers#' 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/module_aboutTab.R0000644000176200001440000000176013335253224015604 0ustar liggesusersaboutTab <- function(id, subdir) { # Create a namespace function using the provided id ns <- NS(id) 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 = "http://rlum.geographie.uni-koeln.de/", "Online application", target="_blank"), br(),hr(), img(src='GitHub-Mark-32px.png', width='32px', height='32px'), br(), a(href = paste0("https://github.com/tzerk/RLumShiny/tree/master/inst/shiny/", subdir), "See the code at GitHub!", target="_blank") )#/div ) } RLumShiny/R/chooser.R0000644000176200001440000000323713122201770014132 0ustar liggesusers## +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ## '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/module_exportTab.R0000644000176200001440000000704613142346074016020 0ustar liggesusersexportCodeHandler <- function(input, output, session, code) { output$exportScript <- downloadHandler( filename = function() { paste(input$filename, ".", "R", sep="") }, content = function(file) { write(code, file) },#EO content =, contentType = "text" )#EndOf::dowmloadHandler() } exportPlotHandler <- function(input, output, session, fun, args) { 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 do.call(fun, args) dev.off() },#EO content =, contentType = "image" )#EndOf::dowmloadHandler() } exportTab <- function(id, filename) { # Create a namespace function using the provided id ns <- NS(id) tabPanel("Export", radioButtons(inputId = ns("fileformat"), label = "Fileformat", selected = "pdf", choices = c("PDF (Portable Document Format)" = "pdf", "SVG (Scalable Vector Graphics)" = "svg", "EPS (Encapsulated Postscript)" = "eps")), textInput(inputId = ns("filename"), label = "Filename", value = filename), fluidRow( column(width = 6, numericInput(inputId = ns("imgheight"), label = "Image height", value = 7) ), column(width = 6, numericInput(inputId = ns("imgwidth"), label = "Image width", value = 7) ) ), selectInput(inputId = ns("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 = ns("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 = ns("exportScript"), label = "Download R script") ) }RLumShiny/R/zzz.R0000644000176200001440000000067513312134036013331 0ustar liggesusers# 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() tmp <- DT::datatable(data.frame(1)) knitr::normal_print("") rm(tmp) }RLumShiny/R/RLumShiny.R0000644000176200001440000000253013142343434014363 0ustar liggesusers#' 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 #' @importFrom grDevices dev.off pdf postscript svg #' #' @md NULLRLumShiny/R/addin.R0000644000176200001440000002542213413155250013553 0ustar liggesusers#' 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."), "fastratio" = list(title = "Calculate Fast Ratio", keyword = "fastratio", category = "calc", description = "Calculate the fast ratio of quartz CW-OSL single grain or single aliquot curves after Durcan & Duller (2011)."), "fading" = list(title = "Estimate g-value and Fading Correction", keyword = "fading", category = "calc", description = "Estimate the g-value from a table of Lx/Tx values with corresponding times since irradiation and apply a fading correction after Huntley & Lamothe (2001)."), "surfaceexposure" = list(title = "Fit model to OSL surface exposure data", keyword = "surfaceexposure", category = "calc", description = "Determine the (weighted) least-squares estimates of the parameters of eq. 1 in Sohbati et al. (2012a) or eq. 12 in Sohbati et al. (2012b) for a given OSL surface exposure data set."), "teststimulationpower" = list(title = "Test OSL/IRSL Stimulation Power", keyword = "teststimulationpower", category = "misc", description = "Compares the OSL/IRSL stimulation power of measurements performed on Freiberg Instruments lexsyg devices and returns a message if a mismatch is detected, i.e. the stimulation power was not stable of the sequence.RLum"), "scalegamma" = list(title = "Gamma Dose Rate Scaling", keyword = "scalegamma", category = "calc", description = "Scale the gamma dose rate considering variations in soil radioactivity."), "rcarb" = list(title = "Dose Rate Modelling of Carbonate-Rich Samples", keyword = "rcarb", category = "calc", description = "This app models the dose rate evolution in carbonate enrich environments.") ) # 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/MD50000644000176200001440000002120113416077073012460 0ustar liggesusers921832492c8ba4d5d14dbe68ed93399b *DESCRIPTION 6fbb53acfc07165c6ece0db954f33d0a *LICENSE.note 538bd63fd2ebf2a68fb360be30ac1c1a *NAMESPACE 40ccc7431bc7f4d732b87749bd027d35 *NEWS 047309e1e4ebfcb72f484175d327c9b1 *R/RLumShiny.R f63b0c8b824028754ac6873613feea5e *R/addin.R b13c0ce786c30ccf854d1d1f521aebc2 *R/app_RLum.R c311aadc456bd03bc1719726f2dd9921 *R/chooser.R 52bc4bd492b595207b563160448d2518 *R/jscolor.R 9c181e65a61d5310ebc219b090fa0f16 *R/module_aboutTab.R 1a913c121888da7d0646676d3b846dc9 *R/module_exportTab.R dc17222138e029e6a854bc7671332755 *R/module_printCode.R 6deddc9fe3b00c150c36478be370a273 *R/popover.R 4efb87fd14c30714a3f1c187c0aa7dcf *R/tooltip.R f58f09d6ca2aee6e054bbf8404385991 *R/zzz.R 706e85a626487748a7799a5055502ec3 *inst/rstudio/addins.dcf 31c93652e3ad30cdcd044b066429efdc *inst/shiny/KDE/global.R 55e476100960bf1b9e45669d30a5bc24 *inst/shiny/KDE/server.R 13ecd7b5173d2d7af24e48d42ef5ea34 *inst/shiny/KDE/shiny_bookmarks/62408c76eac4976d/input.rds 47b0313c05902c9749fe3d1e528dd5aa *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 ab9f151698cbc72f0ca72eb74feedb6c *inst/shiny/RCarb/global.R 5e0692f979ee8655527fff796d87152f *inst/shiny/RCarb/server.R 138bceaca79ad165c2471dd6e50b456a *inst/shiny/RCarb/static/about.Rmd 5cb7939a2c8adc612c93771d7d543424 *inst/shiny/RCarb/static/news.Rmd 26e04a0c6b79dbb29877c0b9ee27d3c2 *inst/shiny/RCarb/ui.R d124472141f34b394b08d16ca9a592f5 *inst/shiny/abanico/global.R f0b8e588f987c25c4ba9dbfea75eb086 *inst/shiny/abanico/server.R 904d4bdf9df182f1784a0fb1757c70d2 *inst/shiny/abanico/shiny_bookmarks/8027aaa9b994c7bd/input.rds def5e2dad2147fcec2b7bca195331bdd *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 aea961c57ebd9d6c99c5e1574e45d45d *inst/shiny/convert/global.R c6c5aa6e316b1be324828ed179ee0de0 *inst/shiny/convert/select.R e2dcf14c86c53edafd503cf91fa37775 *inst/shiny/convert/server.R 5296993938a7d55eb911b741297062a1 *inst/shiny/convert/ui.R f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/convert/www/GitHub-Mark-32px.png 8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/convert/www/RL_Logo.png e3a2deb2d5f93d6c5339bd7f8a018ccd *inst/shiny/convert/www/style.css 23b741f412b9a2fd64a0db52464f16f6 *inst/shiny/cosmicdose/global.R 88b82404211d8ae2c83175c4e2744059 *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 5e9a2e3a7eb1938fca35628e71a5ea34 *inst/shiny/doserecovery/server.R 33b934f1927d0bad23a5f0b2f528649c *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 31ebafee7e828c2e3405e66418b87ec9 *inst/shiny/fading/global.R 12fe291bb3b368558bffaf87bc728182 *inst/shiny/fading/server.R 1e7d9636c61f3a77ddc520928cde8eb9 *inst/shiny/fading/ui.R f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/fading/www/GitHub-Mark-32px.png 8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/fading/www/RL_Logo.png e3a2deb2d5f93d6c5339bd7f8a018ccd *inst/shiny/fading/www/style.css 47262ad26d07ca7ea00a03fa28096ab6 *inst/shiny/fastratio/global.R 95de2728e8d03d0a1f5e155ad1992655 *inst/shiny/fastratio/server.R 2e59934d7607d98aa1707463b7f98727 *inst/shiny/fastratio/ui.R f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/fastratio/www/GitHub-Mark-32px.png 8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/fastratio/www/RL_Logo.png e3a2deb2d5f93d6c5339bd7f8a018ccd *inst/shiny/fastratio/www/style.css 7226cd5d011c60becebf27ece419a455 *inst/shiny/filter/global.R 48158872ce5bf185a8f68dce24a18bcc *inst/shiny/filter/server.R 1beaf2182b1cb5f9d28d95c2b989f5b2 *inst/shiny/filter/template/template.xlsx 4e12b9e8b5607135671deb19f95f0fed *inst/shiny/filter/ui.R 9df65bd1b3068d93f2646edfc40d8d22 *inst/shiny/histogram/global.R 3e35d0d511892df8bc1266ec89ceeb70 *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 060e30867839d1e8d02688119b0b297f *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 d9fbe9cdaf6953fa487426c6dd43f565 *inst/shiny/radialplot/server.R 4e7245255842778ae433cfaf21303aee *inst/shiny/radialplot/shiny_bookmarks/1e0f5bee0eebca8d/input.rds 7ca5740f9d0f3e560273f7856651b94c *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 aa5b9b93ac1e44dc0547e14d33aea068 *inst/shiny/scalegamma/global.R 7660f75e9ff9e7eae4ce5fba38aa72ed *inst/shiny/scalegamma/server.R c664c01dd130cc9e8a49668696e41eb1 *inst/shiny/scalegamma/ui.R f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/scalegamma/www/GitHub-Mark-32px.png 8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/scalegamma/www/RL_Logo.png e3a2deb2d5f93d6c5339bd7f8a018ccd *inst/shiny/scalegamma/www/style.css d32a3c7a63fb1e902d77e100b629697c *inst/shiny/surfaceexposure/global.R 0910fea475c2d1be6fb5557b943ba6a8 *inst/shiny/surfaceexposure/server.R 1170406c4958592b8e2b1f47b385d224 *inst/shiny/surfaceexposure/ui.R f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/surfaceexposure/www/GitHub-Mark-32px.png 8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/surfaceexposure/www/RL_Logo.png e3a2deb2d5f93d6c5339bd7f8a018ccd *inst/shiny/surfaceexposure/www/style.css 6e556e416411f4c94d5eb9c2e2a4cc29 *inst/shiny/teststimulationpower/global.R abea4878d802bd8631be2a39caf6c22d *inst/shiny/teststimulationpower/server.R 529b70cf255aaa6b0ef19457def7fca9 *inst/shiny/teststimulationpower/static/about.Rmd a7ca5e8d532e4065a6a83c23570ce2d7 *inst/shiny/teststimulationpower/ui.R 47262ad26d07ca7ea00a03fa28096ab6 *inst/shiny/transformCW/global.R e2eec4c848d268f32b82687ceb155c48 *inst/shiny/transformCW/server.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 bfea3e59d4f5f784fb8bc4713400cc2b *inst/shiny/transformCW/ui.R f87561b8bb354ef83b09a66e54f70e08 *inst/shiny/transformCW/www/GitHub-Mark-32px.png 8e0ac7aba1d56a2372306a20f4ae37c2 *inst/shiny/transformCW/www/RL_Logo.png e3a2deb2d5f93d6c5339bd7f8a018ccd *inst/shiny/transformCW/www/style.css 003266e63930139ada48e32243a63b38 *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 0342e59699c72b83c1ff6afb0945d364 *man/app_RLum.Rd 54f14df85c9a6b18d4255c3b9bf12a19 *man/jscolorInput.Rd 547122d77a3889430f3b656e502494c7 *man/popover.Rd 194e1423d5256f59909c0966e7662cb4 *man/tooltip.Rd RLumShiny/DESCRIPTION0000644000176200001440000000443713416077073013672 0ustar liggesusersPackage: RLumShiny Type: Package Title: 'Shiny' Applications for the R Package 'Luminescence' Version: 0.2.2 Date: 2019-01-11 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", comment = c(ORCID = "0000-0002-5023-4046")), person("Urs Tilmann", "Wolpert", role = "aut"), person("Sebastian", "Kreutzer", role = "aut", comment = c(ORCID = "0000-0002-0734-2199")), 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.4.0) Imports: Luminescence (>= 0.8.5), shiny (>= 1.1.0), rhandsontable (>= 0.3.4), data.table (>= 1.10.4), googleVis (>= 0.6.2), shinydashboard (>= 0.7.0), shinyjs (>= 1.0), RCarb (>= 0.1.0), rmarkdown (>= 1.11), readxl (>= 1.1.0), DT (>= 0.4), knitr (>= 1.20) 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' 'module_aboutTab.R' 'module_exportTab.R' 'module_printCode.R' 'zzz.R' RoxygenNote: 6.1.1 NeedsCompilation: no Packaged: 2019-01-11 10:56:17 UTC; BUROW-PC Repository: CRAN Date/Publication: 2019-01-11 11:30:03 UTC RLumShiny/LICENSE.note0000644000176200001440000000106213122205727014115 0ustar liggesusersThe 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/0000755000176200001440000000000013413154613012720 5ustar liggesusersRLumShiny/man/popover.Rd0000644000176200001440000000354613124163465014715 0ustar liggesusers% 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.Rd0000644000176200001440000000562313413154613014734 0ustar liggesusers% 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}} \cr Fast Ratio \tab \emph{fastratio} \tab \code{\link{calc_FastRatio}} \cr Fading Correction \tab \emph{fading} \tab \code{\link{analyse_FadingMeasurement}}, \code{\link{calc_FadingCorr}} \cr Test Stimulation Power \tab \emph{teststimulationpower} \tab \code{\link{plot_RLum}} \cr Scale Gamma Dose Rate \tab \emph{scalegamma} \tab \code{scale_GammaDose} \cr RCarb app \tab \emph{RCarb} \tab \link[RCarb:model_DoseRate]{RCarb::model_DoseRate} } 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") app_RLum("fastratio") app_RLum("fading") app_RLum("surfaceexposure") app_RLum("teststimulationpower") app_RLum("scalegamma") app_RLum("RCarb") } } \seealso{ \code{\link{runApp}} } \author{ Christoph Burow, University of Cologne (Germany) } RLumShiny/man/RLumShinyAddin.Rd0000644000176200001440000000035713142306176016050 0ustar liggesusers% 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.Rd0000644000176200001440000000244613124161664016503 0ustar liggesusers% 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.Rd0000644000176200001440000000442213415133525015705 0ustar liggesusers% 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.Rd0000644000176200001440000000536313124162776014720 0ustar liggesusers% 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) }) }) } }