R/DescTools.r

Defines functions as.statafactor CourseData WrdKill GetCurrPP GetCurrXL GetNewXL GetCurrWrd GetCOMAppHandle IsValidHwnd IsValidPtr createCOMReference SendOutlookMail PpPlot PpAddSlide XLKill A1ToZ1S1 XLColNames XLCurrReg ToXL.default ToXL.data.frame XLSaveAs Phrase WrdTable WrdPlot PtsToCm CmToPts WrdSaveAs WrdOpenFile WrdUpdateFields WrdDeleteBookmark WrdBookmark WrdPageBreak `WrdParagraphFormat<-` WrdParagraphFormat `WrdFont<-` WrdFont WrdFormatCells WrdMergeCells WrdCellRange ToWrd.Freq ToWrd.matrix ToWrd.data.frame ToWrd.PercTable WrdCaption ToWrd.lm ToWrd.abstract ToWrd.TOne ToWrd.Desc ToWrd.default ToWrdPlot ToWrdB randbm ToWrd .WrdPrepRep ParseFormula Flags print.TOne .FootNote TOne PlotPairs PlotQQ PlotMonth PlotGACF SaveAs PlotCashFlow PlotCandlestick PlotWeb PlotCirc PlotTreemap PlotMiss print.CountCompCases CountCompCases CompleteColumns PlotTernary PolarGrid PlotPolar PlotViolin PlotCorr PlotPyramid Shade PlotFun PlotLog PlotLinesA PlotFacet TitleRect PlotDotCI PlotArea.default PlotArea PlotConDens PlotMarDens PlotMultiDens.default PlotECDF ClearArgs PlotBubble.default PlotBubble SetAlpha FindColor TextContrastColor ColToGray ColToGrey ColToHsv ColToRgb LongToRgb RgbToLong RgbToCol HexToCol ColToOpaque CmykToCmy CmyToCmyk RgbToCmy CmykToRgb RgbToHex HexToRgb ColToHex CartToPol PolToCart Bg ABCCoords ConnLines BarText SpreadOut Arrow LineToUser Asp GeomTrans Rotate Clockwise DrawBand DrawEllipse DrawRegPolygon BoxedText Stamp plot.palette print.palette Pal Midx Canvas BubbleLegend BoxLegend ColorLegend ErrBars SmoothSpline.formula SmoothSpline .DrawTrendLine lines.loess Mar SplitAt split.formula PtInPoly IdentifyA.default IdentifyA.formula IdentifyA identify.formula FixToTable Untable.default Untable.data.frame Untable Rev.data.frame Rev.array Rev.default Rev Sort.data.frame Sort.default Sort Label Rename Append.data.frame Append.matrix Append.default Append StripAttr SetAttr ParseSASDatalines as.fmt fmt FindRProfile SysInfo Keywords FctArgs InDots DB SLN SYD RBAL PPMT IsDichotomous IsOdd IsZero Coalesce AllDuplicated AllIdentical Overlap `%overlaps%` Interval `%like any%` `%like%` `%c%` `%nin%` `%::%` `%:%` `%)(%` `%)[%` `%](%` `%][%` `%()%` `%[)%` `%(]%` `%[]%` axTicks.Date Zodiac LastDayOfMonth DiffDays360 Timezone Second Minute Hour Now Today YearMonth YearDay CountWorkDays Day Week IsLeapYear Year IsWeekend IsDate SecToHms HmsToSec PairApply LOCF.matrix LOCF.data.frame LOCF.default LOCF BoxCoxLambda BoxCoxInv LogitInv Logit LogSt OrderMixed SortMixed reorder.factor Impute NAIfBlank BlankIfNA NAIfZero ZeroIfNA Recode TextToTable as.matrix.xtabs MultMerge ConvUnit RadToDeg DegToRad BinToDec DecToOct OctToDec DecToHex HexToDec AscToChar CharToAsc IPMT PMT YTM NPVFixBond IRR NPV RndWord RndPairs Recycle MaxDigits Frac print.fmt Fmt Format.default as.CDateFmt Format.table Format.matrix Format.data.frame Format Ndec .CaptOut CatTable ToWide Abind PDFManual What LsObj LsFct Some Str RoundTo VecShift VecRot IsPrime StrIsNumeric SplitToCol StrSpell SplitPath StrPos StrVal StrCountW StrChop StrAlign StrPad StrRev StrCap StrAbbr StrExtractBetween StrExtract StrLeft StrRight StrTrim WithOptions CombLevels Unwhich PercentRank Rank Closest MoveAvg RobScale Trim Winsorize Vigenere GeomSn Fibonacci Cross CrossN Dot GenRandGroups CombPairs CombSet Permn CombN Divisors DigitSum LCM GCD

Documented in ABCCoords Abind AllDuplicated AllIdentical Append Append.data.frame Append.default Append.matrix Arrow as.CDateFmt AscToChar as.fmt as.matrix.xtabs Asp axTicks.Date BarText Bg BinToDec BlankIfNA BoxCoxInv BoxCoxLambda BoxedText BubbleLegend Canvas CartToPol CatTable CharToAsc Clockwise Closest CmToPts CmykToCmy CmykToRgb CmyToCmyk Coalesce ColorLegend ColToGray ColToGrey ColToHex ColToHsv ColToOpaque ColToRgb CombN CombPairs CombSet CompleteColumns ConnLines ConvUnit CountCompCases CountWorkDays CourseData createCOMReference Cross CrossN Day DB DecToHex DecToOct DegToRad DiffDays360 DigitSum Divisors Dot DrawBand DrawEllipse DrawRegPolygon ErrBars FctArgs Fibonacci FindColor FindRProfile FixToTable Flags Fmt Format Format.default Format.matrix Format.table Frac GCD GenRandGroups GeomSn GeomTrans GetCurrPP GetCurrWrd GetCurrXL GetNewXL HexToCol HexToDec HexToRgb HmsToSec Hour IdentifyA IdentifyA.default IdentifyA.formula identify.formula Impute InDots Interval IPMT IRR IsDate IsDichotomous IsLeapYear IsOdd IsPrime IsValidHwnd IsWeekend IsZero Keywords Label LastDayOfMonth LCM lines.loess LineToUser LOCF LOCF.data.frame LOCF.default LOCF.matrix Logit LogitInv LogSt LongToRgb LsFct LsObj Mar MaxDigits Midx Minute MoveAvg MultMerge NAIfBlank NAIfZero Ndec Now NPV NPVFixBond OctToDec OrderMixed Overlap PairApply Pal ParseFormula ParseSASDatalines PDFManual PercentRank Permn Phrase PlotArea PlotArea.default PlotBubble PlotBubble.default PlotCandlestick PlotCashFlow PlotCirc PlotConDens PlotCorr PlotDotCI PlotECDF PlotFun PlotGACF PlotLinesA PlotLog PlotMarDens PlotMiss PlotMonth PlotMultiDens.default PlotPairs plot.palette PlotPolar PlotPyramid PlotQQ PlotTernary PlotTreemap PlotViolin PlotWeb PMT PolarGrid PolToCart PpAddSlide PPMT PpPlot print.CountCompCases PtInPoly PtsToCm RadToDeg Rank RBAL Recode Recycle Rename reorder.factor Rev Rev.array Rev.data.frame Rev.data.frame Rev.default RgbToCmy RgbToCmy RgbToCol RgbToHex RgbToLong RndPairs RndWord RobScale Rotate RoundTo SaveAs Second SecToHms SendOutlookMail SetAlpha SetAttr Shade SLN SmoothSpline SmoothSpline.formula Some Sort Sort.data.frame Sort.default SortMixed SplitAt split.formula SplitPath SplitToCol SpreadOut Stamp Str StrAbbr StrAlign StrCap StrChop StrCountW StrExtract StrExtractBetween StripAttr StrIsNumeric StrLeft StrPad StrPos StrRev StrRight StrSpell StrTrim StrVal SYD SysInfo TextContrastColor TextToTable Timezone TitleRect Today TOne ToWide ToWrd ToWrdB ToWrd.data.frame ToWrd.default ToWrd.Freq ToWrd.lm ToWrdPlot ToWrd.TOne ToXL.data.frame ToXL.default Trim Untable Untable.data.frame Untable.default Unwhich VecRot VecShift Vigenere Week Winsorize WithOptions WrdBookmark WrdCaption WrdCellRange WrdDeleteBookmark WrdFont WrdFormatCells WrdKill WrdMergeCells WrdOpenFile WrdPageBreak WrdParagraphFormat WrdPlot WrdSaveAs WrdTable XLCurrReg XLKill XLSaveAs Year YearDay YearMonth YTM ZeroIfNA Zodiac

#
# Project:	DescTools
#
# Purpose:  Tools for descriptive statistics, the missing link...
#	          Univariat, pairwise bivariate, groupwise und multivariate
#
# Author:   Andri Signorell
# Version:	0.99.19 (under construction)
#
# Depends:  tcltk
# Imports:  boot
# Suggests: RDCOMClient
#
# Datum:
#           31.07.2013  version 0.99.4 almost releaseable
#           06.05.2011 	created
#
# ****************************************************************************


# **********  DescTools' design goals, Dos and Donts
# Some thoughts about coding:

# 1.  Use recycling rules as often and wherever possible.
# 2.  Handle NAs by adding an na.rm option (default FALSE) where it makes sense.
# 3.  Use Google Naming StyleGuide
# 4.  no data.frame or matrix interfaces for functions, the user is supposed to use
#     sapply and apply.
#     Interfaces for data.frames are widely deprecated nowadays and so we abstained to implement one.
#     Use do.call (do.call), rbind and lapply for getting a matrix with estimates and confidence
#     intervals for more than 1 column.
# 5.  A pairwise apply construction is implemented PwApply
# 6.  Use formula interfaces wherever possible.
# 7.  use test results format class "htest"
# 8.  deliver confidence intervals wherever possible, rather than tests (use ci for that)
# 9.  always define appropriate default values for function arguments
# 10. provide an inverse function whenever possible (ex.: BoxCox - BoxCoxInv)
# 11. auxiliary functions, which don't have to be defined globally are put in the function's body
#     (and not made invisible to the user by using .funname)
# 12. restrict the use of other libraries to the minimum (possibly only core),
#     avoid hierarchical dependencies of packages over more than say 2 steps
# 13. do not create wrappers, which basically only define specific arguments and
#     call an existing function (we would run into a forest of functions, loosing overview)
# 14. make functions as flexible as possible but do not define more than say
#     a maximum of 12 arguments for a function (can hardly be controlled by the user)
# 15. define reasonable default values for possibly all used arguments
#     (besides x), the user should get some result when typing fun(x)!
# 16. do not reinvent the wheel
# 17. do not write a function for a problem already solved(!), unless you think
#     it is NOT (from your point of view) and you are pretty sure you can do better..
# 18. take the most flexible function on the market, if there are several
#     take the most efficient function on the market, if there are differences in speed
# 19. make it work - make it safe - make it fast (in this very order...)
# 20. possibly publish all functions, if internal functions are used, define it within
#     the functions body, this will ensure a quick source lookup.


# **********  Similar packages:

# - descr, UsingR
# - prettyR
# - reporttools
# - lessR (full)
# - Hmisc (describe)
# - psych

# check:
# library(pwr) # Power-Analyse
# http://www.ats.ucla.edu/stat/r/dae/t_test_power2.htm


# Data in packages
# http://www.hep.by/gnu/r-patched/r-exts/R-exts_8.html


# library(gtools): odd   zu IsOdd, vgl: stars.pval
# library(e1071): hamming.distance, hamming.window, hsv_palette, matchControls (SampleTwins)
# library(plotrix): color.id (RgbToCol), color.scale (FindColor)
# vgl: PlotCI  (plotCI), plot_bg


# **********  Know issues:

# bug:    Desc( driver + temperature ~ operator + interaction(city, driver, sep=":") , data=d.pizza)
# works:  Desc( driver + temperature ~ operator + interaction(city, driver, sep=".") , data=d.pizza)
# works:  Desc( driver + temperature ~ operator + city:driver, data=d.pizza)

# - bei der Anwendung von tapply wird die Bezeichnung des Levels nicht verwendet
#       Beispiel:
        # tapply( d.pizza$delivery_min, d.pizza$driver, Desc )
        # Problem:  Titel und level kommt nicht mit   ***CLEARME***CLEARME***CLEARME***CLEARME***CLEARME***

# - DescWrd.factor.factor gibt die Argumente an WrdText nicht weiter? fontsize, etc. (17.4.2012)
# - ein langer label fuehrt dazu, dass die Tabellenausgabe umgebrochen wird und die Grafik unter dem Text plaziert wird.

# this error arises when no plot windows exists, but is the same for boxplot, so we leave it here
# PlotViolin(temperature ~ driver, d.pizza, col="steelblue", panel.first=grid())
# Error in int_abline(a = a, b = b, h = h, v = v, untf = untf, ...) :
# plot.new has not been called yet


# Shooting list .....
# importFrom("manipulate", "manipulate", "picker","button","checkbox","slider")
# importFrom("foreign", "read.spss", "read.dta") SPSS is not needed anymore, but Systat is


# **********  Open implementations:

# functions:
# polychor, tetrachor

# Cohen's effect fformat(ISOdate(2000, 1:12, 1), "%B")ct
# Cohen's effect hlp

# eta fct lines
# eta hlp
# eta2 <- function(x,y) {
#   return(summary(lm(as.formula(x~y)))$r.squared)
# }

# open multiple comparisons:
# ScottKnott test (scottknott),
#   Waller-Duncan test (agricolae), Gabriel test (not found)


# flag ~ flag  mit mosaicplot und allgemein bivariate darstellung

# ConDisPairs als O(n log(n)) AVL-Tree implementation

# PlotMultiDens stack and 100% (cdplot)
#
# PlotCirc for symmetric tables


# Konsequente ueberpruefung der uebergabe und weiterreichung der parameter
# z.B. was ist mit  Boxplot las?

# uebersicht, was wird wo vewendet, z.b. kommt rfrq ueberhaupt an bei Desc(data.frame)
# Was ist die maximale Menge an parameter?

# - Tabellen factor ~ factor nebeneinander wenn Platz


# PercTable tasks:
#   Sum, perc, usw. Texte parametrisieren
#   0 values als '-' optional anzeigen
#   Format perc stimmt im ersten Fall nicht, parametrisieren?
#   Reihenfolge Zuerich, perc vs. perc , Zuerich wechselbar machen. Ist das schon?


# faqNC <- function() browseURL("http://www.ncfaculty.net/dogle/R/FAQ/FAQ_R_NC.html")

# Formula-Interface fuer PlotBag

# - replace .fmt by Format

# - DescDlg

# - Object Browser a la RevoR
# - Fixierung Nachkommastellen pro Variable - geloest, aber unbefriedigend
#   sollte unterscheiden zwischen kleinen (1.22e-22), mittleren (100.33) und
#   grossen Zahlen (1.334e5)
#   grosse Zahlen mit Tausendertrennzeichen ausgegeben: 13'899
# - Alle PlotDesc sollten so funktionieren wie Desc, also mit data, ohne data etc.

# wenn mal viel Zeit: test routinen mit htest result fuer
# SomersDelta, GoodmanKruskal etc.


# separate Data ========

# Creation of the Page distribution function for the Page TrendTest
#
# .PageDF <- list(
#   NA, NA
#   , k3 = c(1, 3, 3, 5, 6)
#   , k4 = c(1, 4, 5, 9, 11, 13, 15, 19, 20, 23, 24)
#   , k5 = c(1, 5, 8, 14, 21, 27, 31, 41, 47, 57, 63, 73, 79, 89, 93, 99, 106, 112, 115, 119, 120)
#   , k6 = c(1, 6, 12, 21, 37, 49, 63, 87, 107, 128, 151, 179, 203, 237,
#            257, 289, 331, 360, 389, 431, 463, 483, 517, 541, 569, 592, 613,
#            633, 657, 671, 683, 699, 708, 714, 719, 720)
#   , k7 = c(1, 7, 17, 31, 60, 86, 121, 167, 222, 276, 350, 420, 504, 594,
#            672, 762, 891, 997, 1120, 1254, 1401, 1499, 1667, 1797, 1972,
#            2116, 2284, 2428, 2612, 2756, 2924, 3068, 3243, 3373, 3541, 3639,
#            3786, 3920, 4043, 4149, 4278, 4368, 4446, 4536, 4620, 4690, 4764,
#            4818, 4873, 4919, 4954, 4980, 5009, 5023, 5033, 5039, 5040)
#   , k8 = c(1, 8, 23, 45, 92, 146, 216, 310, 439, 563, 741, 924, 1161,
#            1399, 1675, 1939, 2318, 2667, 3047, 3447, 3964, 4358, 4900, 5392,
#            6032, 6589, 7255, 7850, 8626, 9310, 10096, 10814, 11736, 12481,
#            13398, 14179, 15161, 15987, 16937, 17781, 18847, 19692, 20628,
#            21473, 22539, 23383, 24333, 25159, 26141, 26922, 27839, 28584,
#            29506, 30224, 31010, 31694, 32470, 33065, 33731, 34288, 34928,
#            35420, 35962, 36356, 36873, 37273, 37653, 38002, 38381, 38645,
#            38921, 39159, 39396, 39579, 39757, 39881, 40010, 40104, 40174,
#            40228, 40275, 40297, 40312, 40319, 40320)
#   , k9 = c(1, 9, 30, 64, 136, 238, 368, 558, 818, 1102, 1500, 1954, 2509,
#            3125, 3881, 4625, 5647, 6689, 7848, 9130, 10685, 12077, 13796,
#            15554, 17563, 19595, 21877, 24091, 26767, 29357, 32235, 35163,
#            38560, 41698, 45345, 48913, 52834, 56700, 61011, 65061, 69913,
#            74405, 79221, 84005, 89510, 94464, 100102, 105406, 111296, 116782,
#            122970, 128472, 134908, 140730, 146963, 152987, 159684, 165404,
#            172076, 178096, 184784, 190804, 197476, 203196, 209893, 215917,
#            222150, 227972, 234408, 239910, 246098, 251584, 257474, 262778,
#            268416, 273370, 278875, 283659, 288475, 292967, 297819, 301869,
#            306180, 310046, 313967, 317535, 321182, 324320, 327717, 330645,
#            333523, 336113, 338789, 341003, 343285, 345317, 347326, 349084,
#            350803, 352195, 353750, 355032, 356191, 357233, 358255, 358999,
#            359755, 360371, 360926, 361380, 361778, 362062, 362322, 362512,
#            362642, 362744, 362816, 362850, 362871, 362879, 362880)
#   , k10 = c(1, 10, 38, 89, 196, 373, 607, 967, 1465, 2084, 2903, 3943,  5195, 6723, 8547, 10557, 13090, 15927, 19107, 22783, 27088, 31581,  36711, 42383, 48539, 55448, 62872, 70702, 79475, 88867, 98759,  109437, 121084, 133225, 146251, 160169, 174688, 190299, 206577,  223357, 242043, 261323, 280909, 301704, 324089, 346985, 370933,  395903, 421915, 449011, 477478, 505905, 536445, 567717, 599491,  632755, 667503, 702002, 738301, 774897, 813353, 852279, 892263,  931649, 973717, 1016565, 1058989, 1101914, 1146958, 1191542,  1237582, 1283078, 1329968, 1377004, 1424345, 1471991, 1520878,  1569718, 1617762, 1666302, 1716368, 1765338, 1814400, 1863462,  1912432, 1962498, 2011038, 2059082, 2107922, 2156809, 2204455,  2251796, 2298832, 2345722, 2391218, 2437258, 2481842, 2526886,  2569811, 2612235, 2655083, 2697151, 2736537, 2776521, 2815447,  2853903, 2890499, 2926798, 2961297, 2996045, 3029309, 3061083,  3092355, 3122895, 3151322, 3179789, 3206885, 3232897, 3257867,  3281815, 3304711, 3327096, 3347891, 3367477, 3386757, 3405443,  3422223, 3438501, 3454112, 3468631, 3482549, 3495575, 3507716,  3519363, 3530041, 3539933, 3549325, 3558098, 3565928, 3573352,  3580261, 3586417, 3592089, 3597219, 3601712, 3606017, 3609693,  3612873, 3615710, 3618243, 3620253, 3622077, 3623605, 3624857,  3625897, 3626716, 3627335, 3627833, 3628193, 3628427, 3628604,  3628711, 3628762, 3628790, 3628799, 3628800)
#
#   , k11 = c(1, 11, 47, 121, 277, 565, 974, 1618, 2548, 3794, 5430, 7668,  10382, 13858, 18056, 23108, 29135, 36441, 44648, 54464, 65848,  78652, 92845, 109597, 127676, 148544, 171124, 196510, 223843,  254955, 287403, 323995, 363135, 406241, 451019, 501547, 553511,  610953, 670301, 735429, 803299, 877897, 953161, 1036105, 1122228,  1215286, 1309506, 1413368, 1518681, 1632877, 1749090, 1874422,  2002045, 2140515, 2278832, 2429566, 2581919, 2744859, 2908190,  3085090, 3263110, 3453608, 3643760, 3847514, 4052381, 4272633,  4489678, 4722594, 4956028, 5204156, 5449644, 5712530, 5973493,  6250695, 6523539, 6816137, 7104526, 7411262, 7710668, 8030252,  8345178, 8678412, 9002769, 9348585, 9686880, 10046970, 10393880,  10763840, 11125055, 11506717, 11876164, 12267556, 12646883, 13049009,  13434313, 13845399, 14241951, 14660041, 15058960, 15484804, 15894731,  16324563, 16734970, 17170868, 17587363, 18027449, 18444344, 18884724,  19305912, 19748160, 20168640, 20610888, 21032076, 21472456, 21889351,  22329437, 22745932, 23181830, 23592237, 24022069, 24431996, 24857840,  25256759, 25674849, 26071401, 26482487, 26867791, 27269917, 27649244,  28040636, 28410083, 28791745, 29152960, 29522920, 29869830, 30229920,  30568215, 30914031, 31238388, 31571622, 31886548, 32206132, 32505538,  32812274, 33100663, 33393261, 33666105, 33943307, 34204270, 34467156,  34712644, 34960772, 35194206, 35427122, 35644167, 35864419, 36069286,  36273040, 36463192, 36653690, 36831710, 37008610, 37171941, 37334881,  37487234, 37637968, 37776285, 37914755, 38042378, 38167710, 38283923,  38398119, 38503432, 38607294, 38701514, 38794572, 38880695, 38963639,  39038903, 39113501, 39181371, 39246499, 39305847, 39363289, 39415253,  39465781, 39510559, 39553665, 39592805, 39629397, 39661845, 39692957,  39720290, 39745676, 39768256, 39789124, 39807203, 39823955, 39838148,  39850952, 39862336, 39872152, 39880359, 39887665, 39893692, 39898744,  39902942, 39906418, 39909132, 39911370, 39913006, 39914252, 39915182,  39915826, 39916235, 39916523, 39916679, 39916753, 39916789, 39916799,  39916800)
#
#   , k12 = c(1, 12, 57, 161, 385, 832, 1523, 2629, 4314, 6678, 9882, 14397,  20093, 27582, 36931, 48605, 62595, 80232, 100456, 125210, 154227,  188169, 226295, 272179, 322514, 381283, 446640, 521578, 602955,  697449, 798012, 913234, 1037354, 1177139, 1325067, 1493942, 1670184,  1867627, 2075703, 2306597, 2547605, 2817918, 3095107, 3402876,  3723206, 4075092, 4436130, 4836594, 5245232, 5694249, 6155263,  6658390, 7171170, 7734985, 8304533, 8927791, 9562307, 10250749,  10946272, 11707175, 12472247, 13304674, 14143124, 15051520, 15964324,  16958207, 17951038, 19024576, 20103385, 21266520, 22428668, 23688490,  24941145, 26293113, 27640685, 29092979, 30538037, 32094364, 33635325,  35292663, 36939122, 38705429, 40450799, 42327667, 44179645, 46167953,  48128734, 50226064, 52293360, 54508939, 56686818, 59015668, 61303483,  63746140, 66141668, 68703444, 71211606, 73883239, 76497639, 79284492,  82008603, 84912335, 87739711, 90750133, 93683865, 96803338, 99840816,  103063901, 106199027, 109522404, 112757434, 116187490, 119511072,  123034744, 126446666, 130064197, 133565830, 137269085, 140848253,  144633119, 148294783, 152161902, 155889546, 159821171, 163617371,  167622510, 171480066, 175541648, 179449088, 183562195, 187525039,  191692873, 195691020, 199891634, 203924412, 208164174, 212229695,  216488881, 220574078, 224852631, 228953203, 233247651, 237351468,  241650132, 245753949, 250048397, 254148969, 258427522, 262512719,  266771905, 270837426, 275077188, 279109966, 283310580, 287308727,  291476561, 295439405, 299552512, 303459952, 307521534, 311379090,  315384229, 319180429, 323112054, 326839698, 330706817, 334368481,  338153347, 341732515, 345435770, 348937403, 352554934, 355966856,  359490528, 362814110, 366244166, 369479196, 372802573, 375937699,  379160784, 382198262, 385317735, 388251467, 391261889, 394089265,  396992997, 399717108, 402503961, 405118361, 407789994, 410298156,  412859932, 415255460, 417698117, 419985932, 422314782, 424492661,  426708240, 428775536, 430872866, 432833647, 434821955, 436673933,  438550801, 440296171, 442062478, 443708937,
#             445366275, 446907236,  448463563, 449908621, 451360915, 452708487, 454060455, 455313110,  456572932, 457735080, 458898215, 459977024, 461050562, 462043393,  463037276, 463950080, 464858476, 465696926, 466529353, 467294425,  468055328, 468750851, 469439293, 470073809, 470697067, 471266615,  471830430, 472343210, 472846337, 473307351, 473756368, 474165006,  474565470, 474926508, 475278394, 475598724, 475906493, 476183682,  476453995, 476695003, 476925897, 477133973, 477331416, 477507658,  477676533, 477824461, 477964246, 478088366, 478203588, 478304151,  478398645, 478480022, 478554960, 478620317, 478679086, 478729421,  478775305, 478813431, 478847373, 478876390, 478901144, 478921368,  478939005, 478952995, 478964669, 478974018, 478981507, 478987203,  478991718, 478994922, 478997286, 478998971, 479000077, 479000768,  479001215, 479001439, 479001543, 479001588, 479001599, 479001600 )
#
#   , k13 = c(1, 13, 68, 210, 527, 1197, 2324, 4168, 7119, 11429, 17517,  26225, 37812, 53230, 73246, 98816, 130483, 170725, 218750, 278034,  349136, 434162, 532482, 651024, 785982, 944022, 1124332, 1332640,  1565876, 1835792, 2132840, 2472812, 2848749, 3273357, 3735585,  4260527, 4827506, 5461252, 6147299, 6908609, 7725716, 8635460,  9600260, 10666252, 11804773, 13050503, 14365677, 15812701, 17335403,  18994955, 20742001, 22638493, 24624900, 26787112, 29032733, 31464927,  34008755, 36743621, 39579021, 42647201, 45817786, 49226378, 52752239,  56535435, 60435209, 64628147, 68927405, 73528499, 78274283, 83329815,  88504447, 94050417, 99720505, 105759011, 111937321, 118508917,  125224959, 132372517, 139644194, 147366078, 155251313, 163598355,  172068955, 181074075, 190212385, 199875487, 209687980, 220053214,  230566521, 241680167, 252905559, 264763303, 276775771, 289421809,  302176267, 315640063, 329231261, 343509837, 357915454, 373057790,  388317114, 404365328, 420470916, 437394874, 454438992, 472280042,  490183678, 508970736, 527836540, 547557794, 567333404, 588036304,  608771329, 630463117, 652127890, 674778950, 697468748, 721126694,  744732766, 769392312, 794014392, 819670692, 845236737, 871892593,  898464180, 926132356, 953650676, 982290898, 1010834369, 1040477655,  1069921254, 1100563830, 1131007339, 1162609975, 1193943276, 1226507722,  1258827639, 1292328257, 1325502938, 1359918362, 1394027869, 1429370035,  1464279071, 1500517059, 1536339992, 1573396522, 1609980791, 1647854021,  1685286706, 1723967698, 1762082365, 1801533261, 1840420643, 1880601675,  1920106583, 1960960701, 2001224218, 2042719638, 2083488859, 2125600829,  2167005742, 2209678334, 2251531986, 2294726538, 2337123023, 2380790291,  2423568572, 2467632034, 2510865295, 2555331665, 2598793469, 2643582407,  2687416596, 2732465154, 2776464125, 2821723625, 2865981806, 2911394478,  2955721182, 3001237104, 3045709215, 3091307829, 3135712971, 3181311585,  3225783696, 3271299618, 3315626322, 3361038994, 3405297175, 3450556675,  3494555646, 3539604204, 3583438393, 3628227331, 3671689135, 3716155505,
#             3759388766, 3803452228, 3846230509, 3889897777, 3932294262, 3975488814,  4017342466, 4060015058, 4101419971, 4143531941, 4184301162, 4225796582,  4266060099, 4306914217, 4346419125, 4386600157, 4425487539, 4464938435,  4503053102, 4541734094, 4579166779, 4617040009, 4653624278, 4690680808,  4726503741, 4762741729, 4797650765, 4832992931, 4867102438, 4901517862,  4934692543, 4968193161, 5000513078, 5033077524, 5064410825, 5096013461,  5126456970, 5157099546, 5186543145, 5216186431, 5244729902, 5273370124,  5300888444, 5328556620, 5355128207, 5381784063, 5407350108, 5433006408,  5457628488, 5482288034, 5505894106, 5529552052, 5552241850, 5574892910,  5596557683, 5618249471, 5638984496, 5659687396, 5679463006, 5699184260,  5718050064, 5736837122, 5754740758, 5772581808, 5789625926, 5806549884,  5822655472, 5838703686, 5853963010, 5869105346, 5883510963, 5897789539,  5911380737, 5924844533, 5937598991, 5950245029, 5962257497, 5974115241,  5985340633, 5996454279, 6006967586, 6017332820, 6027145313, 6036808415,  6045946725, 6054951845, 6063422445, 6071769487, 6079654722, 6087376606,  6094648283, 6101795841, 6108511883, 6115083479, 6121261789, 6127300295,  6132970383, 6138516353, 6143690985, 6148746517, 6153492301, 6158093395,  6162392653, 6166585591, 6170485365, 6174268561, 6177794422, 6181203014,  6184373599, 6187441779, 6190277179, 6193012045, 6195555873, 6197988067,  6200233688, 6202395900, 6204382307, 6206278799, 6208025845, 6209685397,  6211208099, 6212655123, 6213970297, 6215216027, 6216354548, 6217420540,  6218385340, 6219295084, 6220112191, 6220873501, 6221559548, 6222193294,  6222760273, 6223285215, 6223747443, 6224172051, 6224547988, 6224887960,  6225185008, 6225454924, 6225688160, 6225896468, 6226076778, 6226234818,  6226369776, 6226488318, 6226586638, 6226671664, 6226742766, 6226802050,  6226850075, 6226890317, 6226921984, 6226947554, 6226967570, 6226982988,  6226994575, 6227003283, 6227009371, 6227013681, 6227016632, 6227018476,  6227019603, 6227020273, 6227020590, 6227020732, 6227020787, 6227020799,  6227020800)
#
#   , k14 = c(1, 14, 80, 269, 711, 1689, 3467, 6468, 11472, 19093, 30278,  46574, 69288, 99975, 141304, 195194, 264194, 352506, 462442,  598724, 766789, 970781, 1213870, 1507510, 1853680, 2260125, 2736501,  3291591, 3930026, 4668007, 5508108, 6466862, 7556159, 8787659,  10165645, 11724144, 13460539, 15392221, 17539134, 19922717, 22546063,  25447736, 28627069, 32116076, 35937108, 40106433, 44631074, 49573596,  54926631, 60716114, 66974508, 73740246, 81009240, 88845749, 97239223,  106246902, 115900686, 126216169, 137197091, 148953202, 161446731,  174730758, 188835459, 203837905, 219695178, 236524328, 254283795,  273083666, 292923813, 313860397, 335854799, 359112526, 383528656,  409202706, 436135896, 464473466, 494134210, 525276498, 557815202,  591946436, 627603800, 664907029, 703773267, 744486823, 786877234,  831103465, 877129675, 925182097, 975110533, 1027121161, 1081080881,  1137323422, 1195661689, 1256271970, 1319049120, 1384348268, 1451952010,  1522055063, 1594541080, 1669783989, 1747541228, 1828055758, 1911151548,  1997286462, 2086139682, 2177925841, 2272580839, 2370486063, 2471328513,  2575410222, 2682471831, 2793082385, 2906881741, 3024092956, 3144510886,  3268758800, 3396339981, 3527578003, 3662304885, 3800998837, 3943227695,  4089440734, 4239185132, 4393196954, 4551031331, 4712856765, 4878478438,  5048720892, 5222754969, 5401045094, 5583410846, 5770395123, 5961416258,  6157027619, 6356554732, 6561015163, 6769843465, 6983093805, 7200534248,  7423263710, 7650023569, 7881592853, 8117625307, 8358760439, 8604199870,  8854704639, 9109316970, 9369314835, 9633980748, 9903337745, 10177004917,  10456529218, 10740122230, 11028754748, 11321981370, 11620526571,  11923494567, 12231834199, 12544092637, 12862071155, 13184668352,  13511964024, 13843525611, 14181198310, 14522618329, 14869105782,  15220174133, 15576509168, 15936926462, 16302784406, 16672089744,  17047134658, 17426587171, 17810429228, 18198087372, 18591770156,  18988751460, 19390461912, 19796344325, 20207120401, 20621426516,  21040873172, 21463087253, 21890649743, 22322106033, 22757217771,  23195600046,
#             23639594170, 24086026475, 24536477172, 24990465186,  25448639418, 25909641657, 26374985116, 26842266606, 27314012018,  27788960817, 28266602799, 28746609271, 29231436410, 29717689954,  30206932003, 30698971843, 31193949888, 31690902354, 32191012868,  32692174745, 33196629733, 33703478249, 34211544046, 34720969890,  35234031737, 35747617060, 36262719119, 36779697578, 37298186864,  37817722298, 38338904825, 38860175016, 39383211341, 39907644570,  40431821887, 40956454566, 41483109694, 42009225414, 42535209127,  43062242912, 43589145600, 44116048288, 44643082073, 45169065786,  45695181506, 46221836634, 46746469313, 47270646630, 47795079859,  48318116184, 48839386375, 49360568902, 49880104336, 50398593622,  50915572081, 51430674140, 51944259463, 52457321310, 52966747154,  53474812951, 53981661467, 54486116455, 54987278332, 55487388846,  55984341312, 56479319357, 56971359197, 57460601246, 57946854790,  58431681929, 58911688401, 59389330383, 59864279182, 60336024594,  60803306084, 61268649543, 61729651782, 62187826014, 62641814028,  63092264725, 63538697030, 63982691154, 64421073429, 64856185167,  65287641457, 65715203947, 66137418028, 66556864684, 66971170799,  67381946875, 67787829288, 68189539740, 68586521044, 68980203828,  69367861972, 69751704029, 70131156542, 70506201456, 70875506794,  71241364738, 71601782032, 71958117067, 72309185418, 72655672871,  72997092890, 73334765589, 73666327176, 73993622848, 74316220045,  74634198563, 74946457001, 75254796633, 75557764629, 75856309830,  76149536452, 76438168970, 76721761982, 77001286283, 77274953455,  77544310452, 77808976365, 78068974230, 78323586561, 78574091330,  78819530761, 79060665893, 79296698347, 79528267631, 79755027490,  79977756952, 80195197395, 80408447735, 80617276037, 80821736468,  81021263581, 81216874942, 81407896077, 81594880354, 81777246106,  81955536231, 82129570308, 82299812762, 82465434435, 82627259869,  82785094246, 82939106068, 83088850466, 83235063505, 83377292363,  83515986315, 83650713197, 83781951219, 83909532400, 84033780314,  84154198244, 84271409459, 84385208815, 84495819369,
#             84602880978,  84706962687, 84807805137, 84905710361, 85000365359, 85092151518,  85181004738, 85267139652, 85350235442, 85430749972, 85508507211,  85583750120, 85656236137, 85726339190, 85793942932, 85859242080,  85922019230, 85982629511, 86040967778, 86097210319, 86151170039,  86203180667, 86253109103, 86301161525, 86347187735, 86391413966,  86433804377, 86474517933, 86513384171, 86550687400, 86586344764,  86620475998, 86653014702, 86684156990, 86713817734, 86742155304,  86769088494, 86794762544, 86819178674, 86842436401, 86864430803,  86885367387, 86905207534, 86924007405, 86941766872, 86958596022,  86974453295, 86989455741, 87003560442, 87016844469, 87029337998,  87041094109, 87052075031, 87062390514, 87072044298, 87081051977,  87089445451, 87097281960, 87104550954, 87111316692, 87117575086,  87123364569, 87128717604, 87133660126, 87138184767, 87142354092,  87146175124, 87149664131, 87152843464, 87155745137, 87158368483,  87160752066, 87162898979, 87164830661, 87166567056, 87168125555,  87169503541, 87170735041, 87171824338, 87172783092, 87173623193,  87174361174, 87174999609, 87175554699, 87176031075, 87176437520,  87176783690, 87177077330, 87177320419, 87177524411, 87177692476,  87177828758, 87177938694, 87178027006, 87178096006, 87178149896,  87178191225, 87178221912, 87178244626, 87178260922, 87178272107,  87178279728, 87178284732, 87178287733, 87178289511, 87178290489,  87178290931, 87178291120, 87178291186, 87178291199, 87178291200 )
#
#   , k15 = c(1, 15, 93, 339, 946, 2344, 5067, 9845, 18094, 31210, 51135,  80879, 123856, 183350, 265744, 375782, 520770, 709108, 950935,  1254359, 1637783, 2110255, 2688261, 3392105, 4243753, 5253985,  6463435, 7887051, 9559689, 11508657, 13779635, 16385319, 19406949,  22847453, 26778757, 31237429, 36312890, 41988174, 48415169, 55581133,  63617482, 72531890, 82493993, 93449491, 105663309, 119038213,  133821033, 149981059, 167810258, 187138620, 208394580, 231407260,  256572630, 283728734, 313349422, 345140612, 379784963, 416871267,  457037763, 499992359, 546463298, 595886554, 649243982, 705940396,  766920856, 831552862, 900947933, 974276983, 1052930913, 1135866291,  1224452526, 1317816142, 1417501545, 1522137313, 1633652530, 1750626806,  1875052020, 2005336686, 2143665106, 2288248572, 2441639216, 2601691186,  2771087853, 2947714613, 3134569070, 3328885582, 3534148307, 3747528715,  3972688056, 4206327920, 4452435789, 4707707507, 4976502908, 5254730366,  5547265512, 5849894908, 6167966973, 6496524245, 6841251954, 7197208516,  7570606695, 7955492307, 8358702869, 8774325693, 9209487348, 9657140024,  10125565750, 10607269130, 11110947428, 11628498256, 12168723926,  12723609294, 13303228032, 13897378066, 14517038181, 15152582797,  15815095216, 16493452984, 17200382721, 17923779849, 18677052770,  19447720986, 20249039825, 21068309835, 21920989644, 22790961184,  23695090223, 24618800757, 25577947305, 26555930925, 27571664648,  28606831690, 29681188983, 30776084989, 31910591023, 33065874467,  34264718158, 35483254398, 36745418556, 38030320602, 39360005810,  40711195500, 42110524356, 43531199878, 45001319765, 46494257553,  48036654343, 49602075643, 51221875032, 52862604614, 54557065970,  56276716608, 58051331346, 59848489468, 61704800734, 63582981112,  65521450173, 67484389131, 69506528883, 71552497079, 73663855894,  75795896650, 77992481274, 80214974822, 82502403057, 84811883255,  87191972089, 89593082611, 92064881373, 94560883919, 97125402107,  99713005329, 102377610307, 105060302611, 107817686686, 110599694856,  113456740182, 116333639168, 119291579167, 122267356121,
#             125323501236,  128401997238, 131558157109, 134734085833, 137997611218, 141274089126,  144635051739, 148017803651, 151483637626, 154964665476, 158536414603,  162120609581, 165794608949, 169485898871, 173262539499, 177052751993,  180940334728, 184834047000, 188819766650, 192821736664, 196913537154,  201013587060, 205213037672, 209416246916, 213716661616, 218026615728,  222428224181, 226835589231, 231347734832, 235855804736, 240461451056,  245075672864, 249785350011, 254493014069, 259306386598, 264111876662,  269020469253, 273929072733, 278932752466, 283931152738, 289039128373,  294131477475, 299325743006, 304517112400, 309806619906, 315081186550,  320465864608, 325829963244, 331299254515, 336756611895, 342309552544,  347844707934, 353492785526, 359109888388, 364830049809, 370533853771,  376336452468, 382110605480, 387994926455, 393843943991, 399797486177,  405725583879, 411748092537, 417737799943, 423839699258, 429894358406,  436050852136, 442177460900, 448399401827, 454577618889, 460862851875,  467097523711, 473433714049, 479729592211, 486115143213, 492451898587,  498897897209, 505281471971, 511760849379, 518195355931, 524718405991,  531183425467, 537750411835, 544250726707, 550846203604, 557385785810,  564007939322, 570567450178, 577227764133, 583810787025, 590480506935,  597092270467, 603784200787, 610403013525, 617114828578, 623745063632,  630461354816, 637109043600, 643828046362, 650470873262, 657203494738,  663846321638, 670565324400, 677213013184, 683929304368, 690559539422,  697271354475, 703890167213, 710582097533, 717193861065, 723863580975,  730446603867, 737106917822, 743666428678, 750288582190, 756828164396,  763423641293, 769923956165, 776490942533, 782955962009, 789479012069,  795913518621, 802392896029, 808776470791, 815222469413, 821559224787,  827944775789, 834240653951, 840576844289, 846811516125, 853096749111,  859274966173, 865496907100, 871623515864, 877780009594, 883834668742,  889936568057, 895926275463, 901948784121, 907876881823, 913830424009,  919679441545, 925563762520, 931337915532, 937140514229, 942844318191,  948564479612,
#             954181582474, 959829660066, 965364815456, 970917756105,  976375113485, 981844404756, 987208503392, 992593181450, 997867748094,  1003157255600, 1008348624994, 1013542890525, 1018635239627, 1023743215262,  1028741615534, 1033745295267, 1038653898747, 1043562491338, 1048367981402,  1053181353931, 1057889017989, 1062598695136, 1067212916944, 1071818563264,  1076326633168, 1080838778769, 1085246143819, 1089647752272, 1093957706384,  1098258121084, 1102461330328, 1106660780940, 1110760830846, 1114852631336,  1118854601350, 1122840321000, 1126734033272, 1130621616007, 1134411828501,  1138188469129, 1141879759051, 1145553758419, 1149137953397, 1152709702524,  1156190730374, 1159656564349, 1163039316261, 1166400278874, 1169676756782,  1172940282167, 1176116210891, 1179272370762, 1182350866764, 1185407011879,  1188382788833, 1191340728832, 1194217627818, 1197074673144, 1199856681314,  1202614065389, 1205296757693, 1207961362671, 1210548965893, 1213113484081,  1215609486627, 1218081285389, 1220482395911, 1222862484745, 1225171964943,  1227459393178, 1229681886726, 1231878471350, 1234010512106, 1236121870921,  1238167839117, 1240189978869, 1242152917827, 1244091386888, 1245969567266,  1247825878532, 1249623036654, 1251397651392, 1253117302030, 1254811763386,  1256452492968, 1258072292357, 1259637713657, 1261180110447, 1262673048235,  1264143168122, 1265563843644, 1266963172500, 1268314362190, 1269644047398,  1270928949444, 1272191113602, 1273409649842, 1274608493533, 1275763776977,  1276898283011, 1277993179017, 1279067536310, 1280102703352, 1281118437075,  1282096420695, 1283055567243, 1283979277777, 1284883406816, 1285753378356,  1286606058165, 1287425328175, 1288226647014, 1288997315230, 1289750588151,  1290473985279, 1291180915016, 1291859272784, 1292521785203, 1293157329819,  1293776989934, 1294371139968, 1294950758706, 1295505644074, 1296045869744,  1296563420572, 1297067098870, 1297548802250, 1298017227976, 1298464880652,  1298900042307, 1299315665131, 1299718875693, 1300103761305, 1300477159484,  1300833116046, 1301177843755, 1301506401027, 1301824473092,
#             1302127102488,  1302419637634, 1302697865092, 1302966660493, 1303221932211, 1303468040080,  1303701679944, 1303926839285, 1304140219693, 1304345482418, 1304539798930,  1304726653387, 1304903280147, 1305072676814, 1305232728784, 1305386119428,  1305530702894, 1305669031314, 1305799315980, 1305923741194, 1306040715470,  1306152230687, 1306256866455, 1306356551858, 1306449915474, 1306538501709,  1306621437087, 1306700091017, 1306773420067, 1306842815138, 1306907447144,  1306968427604, 1307025124018, 1307078481446, 1307127904702, 1307174375641,  1307217330237, 1307257496733, 1307294583037, 1307329227388, 1307361018578,  1307390639266, 1307417795370, 1307442960740, 1307465973420, 1307487229380,  1307506557742, 1307524386941, 1307540546967, 1307555329787, 1307568704691,  1307580918509, 1307591874007, 1307601836110, 1307610750518, 1307618786867,  1307625952831, 1307632379826, 1307638055110, 1307643130571, 1307647589243,  1307651520547, 1307654961051, 1307657982681, 1307660588365, 1307662859343,  1307664808311, 1307666480949, 1307667904565, 1307669114015, 1307670124247,  1307670975895, 1307671679739, 1307672257745, 1307672730217, 1307673113641,  1307673417065, 1307673658892, 1307673847230, 1307673992218, 1307674102256,  1307674184650, 1307674244144, 1307674287121, 1307674316865, 1307674336790,  1307674349906, 1307674358155, 1307674362933, 1307674365656, 1307674367054,  1307674367661, 1307674367907, 1307674367985, 1307674367999, 1307674368000 )
# )
#
# .PageDF <- lapply(.PageDF, function(x) c(x[1], diff(x)) / tail(x,1))
# save(.PageDF, file="C:/Users/Andri/Documents/R/sources/DescTools/MakeDescToolsBase/PageDF.rda")

# load(file="C:/Users/Andri/Documents/R/Projects/load/PageDF.rda")
# load(file="C:/Users/Andri/Documents/R/Projects/DescTools/load/wdConst.rda")
# load(file="C:/Users/Andri/Documents/R/sources/DescTools/periodic.rda")


# just for check not to bark!
utils::globalVariables(c("d.units","d.periodic","d.prefix",
                         "day.name","day.abb","wdConst","xlConst",
                         "fmt", "pal",
                         "hred","hblue","horange","hyellow","hecru","hgreen",
                         "tarot","cards","roulette", "ind"))



# hred    <- unname(Pal("Helsana")[1])
# horange <- unname(Pal("Helsana")[2])
# hyellow <- unname(Pal("Helsana")[3])
# hecru   <- unname(Pal("Helsana")[4])
# hblue   <- unname(Pal("Helsana")[6])
# hgreen  <- unname(Pal("Helsana")[7])
#
# save(x=hred, file='C:/Users/andri/Documents/R/Projects/DescTools/data/hred.rda')
# save(x=horange, file='C:/Users/andri/Documents/R/Projects/DescTools/data/horange.rda')
# save(x=hyellow, file='C:/Users/andri/Documents/R/Projects/DescTools/data/hyellow.rda')
# save(x=hecru, file='C:/Users/andri/Documents/R/Projects/DescTools/data/hecru.rda')
# save(x=hblue, file='C:/Users/andri/Documents/R/Projects/DescTools/data/hblue.rda')
# save(x=hgreen, file='C:/Users/andri/Documents/R/Projects/DescTools/data/hgreen.rda')



# source( "C:/Users/Andri/Documents/R/sources/DescTools/wdConst.r" )

# Base functions  ====

## base: calculus

# we have month.name and month.abb in base R, but nothing similar for day names
# in english (use format(ISOdate(2000, 1:12, 1), "%B") for months in current locale)

# day.name <- c("Monday","Tuesday","Wednesday","Thursday","Friday","Saturday","Sunday")
# day.abb <- c("Mon","Tue","Wed","Thu","Fri","Sat","Sun")

# internal: golden section constant
gold_sec_c <- (1+sqrt(5)) / 2


# tarot <- structure(list(rank = c("1", "2", "3", "4", "5", "6", "7", "8",
#     "9", "10", "page", "knight", "queen", "king", "1", "2", "3",
#     "4", "5", "6", "7", "8", "9", "10", "page", "knight", "queen",
#     "king", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "page",
#     "knight", "queen", "king", "1", "2", "3", "4", "5", "6", "7",
#     "8", "9", "10", "page", "knight", "queen", "king", "0", "1",
#     "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13",
#     "14", "15", "16", "17", "18", "19", "20", "21"), suit = c("wands",
#     "wands", "wands", "wands", "wands", "wands", "wands", "wands",
#     "wands", "wands", "wands", "wands", "wands", "wands", "coins",
#     "coins", "coins", "coins", "coins", "coins", "coins", "coins",
#     "coins", "coins", "coins", "coins", "coins", "coins", "cups",
#     "cups", "cups", "cups", "cups", "cups", "cups", "cups", "cups",
#     "cups", "cups", "cups", "cups", "cups", "swords", "swords", "swords",
#     "swords", "swords", "swords", "swords", "swords", "swords", "swords",
#     "swords", "swords", "swords", "swords", "trumps", "trumps", "trumps",
#     "trumps", "trumps", "trumps", "trumps", "trumps", "trumps", "trumps",
#     "trumps", "trumps", "trumps", "trumps", "trumps", "trumps", "trumps",
#     "trumps", "trumps", "trumps", "trumps", "trumps"), desc = c(NA,
#     NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,
#     NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,
#     NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,
#     NA, NA, NA, NA, NA, NA, NA, "The Fool", "The Magician", "The High Priestess",
#     "The Empress", "The Emperor", "The Hierophant", "The Lovers",
#     "The Chariot", "Strength", "The Hermit", "Wheel of Fortune",
#     "Justice", "The Hanged Man", "Death", "Temperance", "The Devil",
#     "The Tower", "The Star", "The Moon", "The Sun", "Judgment", "The World"
#     )), .Names = c("rank", "suit", "desc"), out.attrs = structure(list(
#     dim = structure(c(14L, 4L), .Names = c("rank", "suit")),
#     dimnames = structure(list(rank = c("rank=1", "rank=2", "rank=3",
#                                        "rank=4", "rank=5", "rank=6", "rank=7", "rank=8", "rank=9",
#                                        "rank=10", "rank=page", "rank=knight", "rank=queen", "rank=king"
#     ), suit = c("suit=wands", "suit=coins", "suit=cups", "suit=swords"
#     )), .Names = c("rank", "suit"))), .Names = c("dim", "dimnames"
#     )), row.names = c(NA, 78L), class = "data.frame")
#
#
# cards <- structure(list(rank = structure(c(1L, 2L, 3L, 4L, 5L, 6L, 7L,
#     8L, 9L, 10L, 11L, 12L, 13L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L,
#     10L, 11L, 12L, 13L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L,
#     11L, 12L, 13L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 11L,
#     12L, 13L), .Label = c("2", "3", "4", "5", "6", "7", "8", "9",
#     "10", "J", "Q", "K", "A"), class = "factor"), suit = structure(c(1L,
#     1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L,
#     2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L,
#     3L, 3L, 3L, 3L, 3L, 3L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L,
#     4L, 4L, 4L), .Label = c("club", "diamond", "heart", "spade"), class = "factor")), .Names = c("rank",
#     "suit"), out.attrs = structure(list(dim = structure(c(13L, 4L
#     ), .Names = c("rank", "suit")), dimnames = structure(list(rank = c("rank=2",
#     "rank=3", "rank=4", "rank=5", "rank=6", "rank=7", "rank=8", "rank=9",
#     "rank=10", "rank=J", "rank=Q", "rank=K", "rank=A"), suit = c("suit=club",
#     "suit=diamond", "suit=heart", "suit=spade")), .Names = c("rank",
#     "suit"))), .Names = c("dim", "dimnames")), class = "data.frame", row.names = c(NA, -52L))
#
#
# roulette <- structure(list(num = structure(c(1L, 20L, 24L, 30L, 5L, 22L,
#   35L, 23L, 11L, 16L, 37L, 26L, 7L, 14L, 2L, 28L, 9L, 18L, 33L,
#   3L, 17L, 36L, 25L, 4L, 31L, 6L, 21L, 34L, 29L, 10L, 19L, 13L,
#   15L, 32L, 12L, 8L, 27L), .Label = c("0", "1", "10", "11", "12",
#   "13", "14", "15", "16", "17", "18", "19", "2", "20", "21", "22",
#   "23", "24", "25", "26", "27", "28", "29", "3", "30", "31", "32",
#   "33", "34", "35", "36", "4", "5", "6", "7", "8", "9"), class = "factor"),
#   col = structure(c(2L,
#   1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L,
#   3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L,
#   1L, 3L, 1L, 3L, 1L, 3L), .Label = c("black", "white", "red"
#   ), class = "factor")), .Names = c("num", "col"
#   ), row.names = c(NA, -37L), class = "data.frame")
#

# save(tarot, file="tarot.rda")
# save(cards, file="cards.rda")
# save(roulette, file="roulette.rda")




# Define some alias(es)
N <- as.numeric



## This is not exported as it would mask base function and
# but it would be very, very handy if the base function was changed accoringly
as.Date.numeric <- function (x, origin, ...) {

  if (missing(origin))
    origin <- "1970-01-01"
  as.Date(origin, ...) + x
}



Primes <- function (n) {
# Source: sfsmisc
# Bill Venables (<= 2001); Martin Maechler gained another 40% speed, working with logicals and integers.
    if ((M2 <- max(n)) <= 1L)
        return(integer(0L))
    P <- rep.int(TRUE, M2)
    P[1] <- FALSE
    M <- as.integer(sqrt(M2))
    n <- as.integer(M2)
    for (p in 1L:M) if (P[p])
        P[seq(p * p, n, p)] <- FALSE
    (1L:n)[P]
}


Factorize <- function (n) {
  # Factorize <- function (n, verbose = FALSE) {
  # Source sfsmisc: Martin Maechler, Jan. 1996.
    if (all(n < .Machine$integer.max))
        n <- as.integer(n)
    else {
        warning("factorizing large int ( > maximal integer )")
        n <- round(n)
    }
    N <- length(n)
    M <- as.integer(sqrt(max(n)))
    k <- length(pr <- Primes(M))
    nDp <- outer(pr, n, FUN = function(p, n) n %% p == 0L)
    res <- vector("list", length = N)
    names(res) <- n
    for (i in 1L:N) {
        nn <- n[i]
        if (any(Dp <- nDp[, i])) {
            nP <- length(pfac <- pr[Dp])
#            if (verbose) cat(nn, " ")
        }
        else {
            res[[i]] <- cbind(p = nn, m = 1L)
#            if (verbose) cat("direct prime", nn, "\n")
            next
        }
        m.pr <- rep(1L, nP)
        Ppf <- prod(pfac)
        while (1 < (nn <- nn %/% Ppf)) {
            Dp <- nn %% pfac == 0L
            if (any(Dp)) {
                m.pr[Dp] <- m.pr[Dp] + 1L
                Ppf <- prod(pfac[Dp])
            }
            else {
                pfac <- c(pfac, nn)
                m.pr <- c(m.pr, 1L)
                break
            }
        }
        res[[i]] <- cbind(p = pfac, m = m.pr)
    }
    res
}



GCD <- function(..., na.rm = FALSE) {

  x <- unlist(list(...), recursive=TRUE)

  if(na.rm) x <- x[!is.na(x)]
  if(anyNA(x)) return(NA)


  stopifnot(is.numeric(x))
  if (any(floor(x) != ceiling(x)) || length(x) < 2L)
    stop("Argument 'x' must be an integer vector of length >= 2.")

  x <- x[x != 0]
  n <- length(x)
  if (n == 0L) {
    g <- 0
  } else if (n == 1L) {
    g <- x
  } else if (n == 2L) {
    g <- .Call("_DescTools_compute_GCD", PACKAGE = "DescTools", x[1L], x[2L])
  } else {
    # g <- .GCD(x[1], x[2])
    g <- .Call("_DescTools_compute_GCD", PACKAGE = "DescTools", x[1L], x[2L])
    for (i in 3L:n) {
      g <- .Call("_DescTools_compute_GCD", PACKAGE = "DescTools", g, x[i])
      if (g == 1) break
    }
  }
  return(g)
}


LCM <- function(..., na.rm = FALSE) {


#   .LCM <- function(n, m) {
#     stopifnot(is.numeric(n), is.numeric(m))
#     if (length(n) != 1 || floor(n) != ceiling(n) ||
#           length(m) != 1 || floor(m) != ceiling(m))
#       stop("Arguments 'n', 'm' must be integer scalars.")
#     if (n == 0 && m == 0) return(0)
#
#     return(n / GCD(c(n, m)) * m)
#   }

  x <- unlist(list(...), recursive=TRUE)

  if(na.rm) x <- x[!is.na(x)]
  if(anyNA(x)) return(NA)


  stopifnot(is.numeric(x))
  if (any(floor(x) != ceiling(x)) || length(x) < 2L)
    stop("Argument 'x' must be an integer vector of length >= 2.")

  x <- x[x != 0]
  n <- length(x)
  if (n == 0L) {
    l <- 0
  } else if (n == 1L) {
    l <- x
  } else if (n == 2L) {
    # l <- .LCM(x[1], x[2])
    l <- .Call("_DescTools_compute_LCM", PACKAGE = "DescTools", x[1], x[2])
  } else {
#    l <- .LCM(x[1], x[2])
    l <- .Call("_DescTools_compute_LCM", PACKAGE = "DescTools", x[1], x[2])
    for (i in 3L:n) {
#      l <- .LCM(l, x[i])
      l <- .Call("_DescTools_compute_LCM", PACKAGE = "DescTools", l, x[i])
    }
  }
  return(l)
}



DigitSum <- function(x)
  # calculates the digit sum of a number: DigitSum(124) = 7
  sapply(x, function(z)
    sum(floor(z / 10^(0L:(nchar(z) - 1L))) %% 10L))



Divisors <- function(x) {

  res <- lapply(
    Factorize(x),
    function(prim) {
      prim <- lapply(seq_len(nrow(prim)), function(i) prim[i,])
      powers <- lapply(prim, function(row) row[1L] ^ seq.int(0L, row[2L]))
      power_grid <- do.call(expand.grid, powers)
      head(sort(unique(apply(power_grid, 1L, prod))), -1L)
    })

#  res <- .Call("_DescTools_divs", PACKAGE = "DescTools", x)
  return(res)
}



# sample interface for data.frames

Sample <-  function (x, size, replace = FALSE, prob = NULL) {
  UseMethod("Sample")
}

Sample.data.frame <- function (x, size, replace = FALSE, prob = NULL) {

  x[sample(nrow(x), size, replace = replace, prob=prob), ]

}


Sample.default <- function (x, size, replace = FALSE, prob = NULL)
  base::sample(x, size, replace, prob)




CombN <- function(n, m, repl=FALSE, ord=FALSE){
  # return the number for the 4 combinatoric cases
  # n <- length(x)
  if(repl){
    res <- n^m
    if(!ord){
      res <- choose(n+m-1, m)
    }
  } else {
    if(ord){
      # res <- choose(n, m) * factorial(m)
      # res <- gamma(n+1) / gamma(m+1)
      # avoid numeric overflow
      res <- exp(lgamma(n + 1L) - lgamma(n - m + 1L))
    } else {
      res <- choose(n, m)
    }
  }

  return(res)

}



Permn <- function(x, sort = FALSE) {

  # by F. Leisch

  n <- length(x)

  if (n == 1L)
    return(matrix(x))
# Andri: why should we need that??? ...
#   else if (n < 2)
#     stop("n must be a positive integer")
  
  z <- matrix(1L)
  for (i in 2L:n) {
    y <- cbind(z, i)
    a <- c(1L:i, 1:(i - 1L))
    z <- matrix(0L, ncol = ncol(y), nrow = i * nrow(y))
    z[1L:nrow(y), ] <- y
    for (j in 2L:i - 1L) {
      z[j * nrow(y) + 1L:nrow(y), ] <- y[, a[1L:i + j]]
    }
  }
  dimnames(z) <- NULL

  m <- apply(z, 2L, function(i) x[i])

  if(any(duplicated(x)))
    m <- unique(m)

  if(sort) m <- Sort(m)
  return(m)

}



CombSet <- function(x, m, repl=FALSE, ord=FALSE, as.list=FALSE) {

  if(length(m)>1){
    res <- lapply(m, function(i) CombSet(x=x, m=i, repl=repl, ord=ord))

  } else {
    # generate the samples for the 4 combinatoric cases
    if(repl){
      res <- as.matrix(do.call(expand.grid, as.list(as.data.frame(replicate(m, x)))))
      dimnames(res) <- NULL
      if(!ord){
        res <- unique(t(apply(res, 1L, sort)))
      }
    } else {
      if(ord){
        res <- do.call(rbind, combn(x, m=m, FUN=Permn, simplify = FALSE))
      } else {
        res <- t(combn(x, m))
      }
    }
  }

  if(as.list){

    # Alternative: we could flatten the whole list
    # and now flatten the list of lists into one list
    # lst <- split(unlist(lst), rep(1:length(idx <- rapply(lst, length)), idx))

    if(is.list(res)){
      res <- do.call(c, lapply(res,
                               function(x){ as.list(as.data.frame(t(x), stringsAsFactors = FALSE))}))
    } else {
      res <- as.list(as.data.frame(t(res), stringsAsFactors = FALSE))
    }
    names(res) <- NULL
  }
  return(res)

}


# CombSet(x, m, repl=TRUE, ord=FALSE)
# CombSet(x, m, repl=TRUE, ord=TRUE)
# CombSet(x, m, repl=FALSE, ord=TRUE)
# CombSet(x, m, repl=FALSE, ord=FALSE)


CombPairs <- function(x, y = NULL) {
  # returns a data.frame with all pairwise combinations of two variables
  if( missing(y)) {  # kein y vorhanden, use x only
    data.frame( t(combn(x, 2L)), stringsAsFactors=FALSE )
  
    } else {
    # if y is defined, all.x to all.y will be returned  
    expand.grid(x, y, stringsAsFactors=FALSE )
  }
}



GenRandGroups <- function(x, grp_n){
  (grp <- sample(rep(j <- seq_along(grp_n), grp_n)))
  idx <- sapply(j, function(x) which(grp==x))
  lapply(idx, function(ii) x[ii])
}



###
### DOT.R  Scalar product
###

Dot <- function(x, y) {
  if (length(x) == 0 && length(y) == 0) return(0)
  if (!(is.numeric(x) || is.complex(x)) ||
      !(is.numeric(y) || is.complex(y)))
    stop("Arguments 'x' and 'y' must be real or complex.")
  x <- drop(x); y <- drop(y)
  if (any(dim(x) != dim(y)))
    stop("Matrices 'x' and 'y' must be of same size")

  if (is.vector(x) && is.vector(y)) {
    dim(x) <- c(length(x), 1)
    dim(y) <- c(length(y), 1)
  }
  x.y <- apply(Conj(x) * y, 2, sum)
  return(x.y)
}


CrossN <- function(A) {
  if (!is.numeric(A))
    stop("Argument 'A' must be numeric.")

  if (is.vector(A) && length(A) == 2) {
    crossA <- c(A[2], -A[1])
  } else {
    if (is.matrix(A) && nrow(A) >= 2 && ncol(A) == nrow(A) + 1) {
      m <- ncol(A)
      crossA <- numeric(m)
      for (i in 1:m)
        crossA[i] <- (-1)^(i+1) * det(A[, -i])
    } else {
      stop("Matrix 'A' must be of size n x (n+1) with n >= 1.")
    }
  }
  return(crossA)
}

###
### CROSS.R  Vector product
###

Cross <- function(x, y) {
  if (!is.numeric(x) || !is.numeric(y))
    stop("Arguments 'x' and 'y' must be numeric vectors or matrices.")

  if (is.vector(x) && is.vector(y)) {
    if (length(x) == length(y) && length(x) == 3L) {
      xxy <- c(x[2L]*y[3L] - x[3L]*y[2L],
               x[3L]*y[1L] - x[1L]*y[3L],
               x[1L]*y[2L] - x[2L]*y[1L])
    } else {
      stop("Vectors 'x' and 'y' must be both of length 3.")
    }
  } else {
    if (is.matrix(x) && is.matrix(y)) {
      if (all(dim(x) == dim(y))) {
        if (ncol(x) == 3L) {
          xxy <- cbind(x[, 2L]*y[, 3L] - x[, 3L]*y[, 2L],
                       x[, 3L]*y[, 1L] - x[, 1L]*y[, 3L],
                       x[, 1L]*y[, 2L] - x[, 2L]*y[, 1L])
        } else {
          if (nrow(x) == 3L) {
            xxy <- rbind(x[2L, ]*y[3L, ] - x[3L, ]*y[2L, ],
                         x[3L, ]*y[1L, ] - x[1L, ]*y[3L, ],
                         x[1L, ]*y[2L, ] - x[2L, ]*y[1L, ])
          } else {
            stop("'x', 'y' must have one dimension of length 3.")
          }
        }
      } else {
        stop("Matrices 'x' and 'y' must be of same size.")
      }
    } else {
      if (is.vector(x) && is.matrix(y) ||
          is.matrix(x) && is.vector(y)) {
        stop("Arguments 'x', 'y' must be vectors/matrices of same size.")
      }
    }
  }
  return(xxy)
}



Fibonacci <- function(n) {

  # if (!is.numeric(n) || !IsWhole(n) || n < 0)
  if(any(sapply(n, function(i) !is.numeric(i) || !IsWhole(i) || i < 0L)))
    stop("Argument 'n' must be an integer >= 0.")

  maxn <- max(n)
  if (maxn == 0L) return(0L)
  if (maxn == 1L) return(c(0L, 1)[n+1L])
  if (maxn == 2L) return(c(0L, 1L, 1L)[n+1L])
  z <- c(0L, 1L, 1L, rep(NA, maxn - 3L))
  for (i in 4L:(maxn + 1L)) {
    z[i] <- z[i-1L] + z[i-2L]
  }

  z[n+1L]

}


GeomSn <- function(a1, q, n){
  a1 * (q^(n+1)-1)/(q-1)
}


###  M^k  for a matrix  M and non-negative integer 'k'
## Matrixpower

"%^%" <- expm::"%^%"




Vigenere <- function(x, key = NULL, decrypt = FALSE) {

  # hold that constant, as it makes the function too flexible else
  # in cases you maybe remind your password, but lost the charlist definition....
  charlist <- c(LETTERS, letters, 0:9)

  if(is.null(key)) key <- PasswordDlg()

  .mod1 <- function(v, n) {
    # mod1(1:20, 6)   =>   1 2 3 4 5 6 1 2 3 4 5 6 1 2 3 4 5 6 1 2
    ((v - 1) %% n) + 1
  }

  .str2ints <- function(s) {

    as.integer(Filter(Negate(is.na),
                      factor(levels = charlist, strsplit(s, "")[[1]])))
  }

  x <- .str2ints(x)
  key <- rep(.str2ints(key), len = length(x)) - 1
  paste(collapse = "", charlist[
    .mod1(x + (if (decrypt) -1 else 1)*key, length(charlist))])
}




## =============================================================================
## uniroot.all: multiple roots of one nonlinear equation
## =============================================================================

UnirootAll <- function (f, interval, lower= min(interval),
                         upper= max(interval), tol= .Machine$double.eps^0.5,
                         maxiter= 1000, n = 100, ... ) {

  # this is a copy of rootSolve::uniroot.all v. 1.8.2.1
  # author: Karline Soetaert


  ## error checking as in uniroot...
  if (!missing(interval) && length(interval) != 2)
    stop("'interval' must be a vector of length 2")
  if (!is.numeric(lower) || !is.numeric(upper) || lower >=
      upper)
    stop("lower < upper  is not fulfilled")
  
  ## subdivide interval in n subintervals and estimate the function values
  xseq <- seq(lower, upper, len=n+1)
  #   changed in 0.99.36 5.5.2020
  # but we should maybe vectorize the functions in order to allow the user not to
  # bother about internal applies
  # ... not sure about the impact..
  
  # Original: mod  <- f(xseq, ...)
  mod  <- Vectorize(f)(xseq, ...)
  
  ## some function values may already be 0
  Equi <- xseq[which(mod==0)]
  
  ss   <- mod[1:n]*mod[2:(n+1)]  # interval where function values change sign
  ii   <- which(ss<0)
  
  for (i in ii)
    Equi <- c(Equi, uniroot(f, lower=xseq[i], upper=xseq[i+1], 
                            maxiter = maxiter, tol = tol, ...)$root)
  
  return(Equi)
  
  
}






Winsorize <- function(x, minval = NULL, maxval = NULL,
                      probs=c(0.05, 0.95), na.rm = FALSE, type=7) {

  # following an idea from Gabor Grothendieck
  # http://r.789695.n4.nabble.com/how-to-winsorize-data-td930227.html

  # in HuberM things are implemented the same way

  # don't eliminate NAs in x, moreover leave them untouched,
  # just calc quantile without them...

  # pmax(pmin(x, maxval), minval)

  # the pmax(pmin()-version is slower than the following

  if(is.null(minval) || is.null(maxval)){
    xq <- quantile(x=x, probs=probs, na.rm=na.rm, type=type)
    if(is.null(minval)) minval <- xq[1L]
    if(is.null(maxval)) maxval <- xq[2L]
  }

  x[x<minval] <- minval
  x[x>maxval] <- maxval

  return(x)

  # see also Andreas Alfons, KU Leuven
  # roubustHD, Winsorize

  # Jim Lemon's rather clumsy implementation:

  # #added winsor.var and winsor.sd and winsor.mean (to supplement winsor.means)
  # #August 28, 2009 following a suggestion by Jim Lemon
  # #corrected January 15, 2009 to use the quantile function rather than sorting.
  # #suggested by Michael Conklin in correspondence with Karl Healey
  # #this preserves the order of the data
  # "wins" <- function(x,trim=.2, na.rm=TRUE) {
    # if ((trim < 0) | (trim>0.5) )
        # stop("trimming must be reasonable")
      # qtrim <- quantile(x,c(trim,.5, 1-trim),na.rm = na.rm)
      # xbot <- qtrim[1]
      # xtop <- qtrim[3]
       # if(trim<.5) {
      # x[x < xbot]  <- xbot
      # x[x > xtop] <- xtop} else {x[!is.na(x)] <- qtrim[2]}
     # return(x) }

}


Trim <- function(x, trim = 0.1, na.rm = FALSE){

  if (na.rm) x <- x[!is.na(x)]

  if (!is.numeric(trim) || length(trim) != 1L)
    stop("'trim' must be numeric of length one")

  n <- length(x)

  if (trim > 0 && n) {
    if (is.complex(x))
      stop("trim is not defined for complex data")
    if (anyNA(x))
      return(NA_real_)
    if (trim >= 0.5 && trim < 1)
      return(NA_real_)
    if(trim < 1)
      lo <- floor(n * trim) + 1
    else{
      lo <- trim + 1
      if (trim >= (n/2))
        return(NA_real_)
    }
    hi <- n + 1 - lo

    # x <- sort.int(x, partial = unique(c(lo, hi)))[lo:hi]
    res <- sort.int(x, index.return = TRUE)
    trimi <- res[["ix"]][c(1:(lo-1), (hi+1):length(x))]

    # x <- res[["x"]][order(res[["ix"]])[lo:hi]]
    x <- res[["x"]][lo:hi][order(res[["ix"]][lo:hi])]
    attr(x, "trim") <- trimi

  }
  return(x)
}



RobScale <- function(x, center = TRUE, scale = TRUE){

  x <- as.matrix(x)

  if(center) {
    x <- scale(x, center = apply(x, 2, median, na.rm=TRUE), scale = FALSE)
  }
  if(scale) {
    x <- scale(x, center = FALSE, scale = apply(x, 2, mad, na.rm=TRUE))
  }
  return(x)
}



MoveAvg <- function(x, order, align = c("center","left","right"),
                    endrule = c("NA", "keep", "constant")){

  n <- length(x)
  align   = match.arg(align)

  switch(align,
  "center" = {
      idx <- c(1:(order %/% 2), (n-order %/% 2+1):n)
      idx_const <- c(rep((order %/% 2)+1, order %/% 2),
                     rep(n-(order %/% 2), order %/% 2))

      if(order %% 2 == 1){   # order is odd
        z <- filter(x, rep(1/order, order), sides=2)
      } else {           # order is even
        z <- filter(x, c(1/(2*order), rep(1/order, order-1), 1/(2*order)), sides=2)
      }   }
  , "right" = {
      idx <- 1:(order-1)
      idx_const <- order
      z <- filter(x, rep(1/order, order), sides=1)
    }
  , "left" = {
      idx <- (n-order+2):n
      idx_const <- n-order+1
      z <- rev(filter(rev(x), rep(1/order, order), sides=1))
  }
  )

  endrule <- match.arg(endrule)
  switch(endrule,
         "NA" =     {},
         keep =     {z[idx] <- x[idx]},
         constant = {z[idx] <- z[idx_const]})

  if(!is.ts(x)) attr(z, "tsp") <- NULL
  class(z) <- class(x)
  return(z)
}




LinScale <- function (x, low = NULL, high = NULL, newlow = 0, newhigh = 1)  {

    x <- as.matrix(x)

    if(is.null(low)) {
      low <- apply(x, 2, min, na.rm=TRUE)
    } else {
      low <- rep(low, length.out=ncol(x))
    }
    if(is.null(high)) {
      high <- apply(x, 2, max, na.rm=TRUE)
    } else {
      high <- rep(high, length.out=ncol(x))
    }
    # do the recycling job
    newlow <- rep(newlow, length.out=ncol(x))
    newhigh <- rep(newhigh, length.out=ncol(x))

    xcntr <- (low * newhigh - high * newlow) / (newhigh - newlow)
    xscale <- (high - low) / (newhigh - newlow)

    return( scale(x, center = xcntr, scale = xscale))

}



Large <- function (x, k = 5L, unique = FALSE, na.last = NA) {

  n <- length(x)
  x <- x[!is.na(x)]
  na_n <- n - length(x)

  #  na.last
  #  for controlling the treatment of NAs. If TRUE, missing values in the data are put last;
  #  if FALSE, they are put first;
  #  if NA, they are removed.

  if (unique==TRUE) {

    res <- .Call("_DescTools_top_n", PACKAGE = "DescTools", x, k)

    if(na_n > 0){
      if(!is.na(na.last)){
        if(na.last==FALSE) {
          res$value <- tail(c(NA, res$value), k)
          res$frequency <- tail(c(na_n, res$frequency), k)
        }
        if(na.last==TRUE){
          res$value <- tail(c(res$value, NA), k)
          res$frequency <- tail(c(res$frequency, na_n), k)
        }
      }
    }

    if(is.factor(x))
      res$value <- levels(x)[res$value]
    else
      class(res$value) <- class(x)

  } else {

    # do not allow k be bigger than n
    k <- min(k, n)

    res <- x[.Call("_DescTools_top_i", PACKAGE = "DescTools", x, k)]

    if(!is.na(na.last)){
      if(na.last==FALSE)
        res <- tail(c(rep(NA, na_n), res), k)
      if(na.last==TRUE)
        res <- tail(c(res, rep(NA, na_n)), k)
    }

  }

  return(res)

}




# old version, replaced 0.99.17/13.5.2016
#
# Large <- function (x, k = 5, unique = FALSE, na.rm = FALSE) {
#
#   if (na.rm)
#     x <- x[!is.na(x)]
#
#   if (unique==TRUE) {
#     ux <- unique(x)
# #    un <- length(ux)
#     un <- sum(!is.na(ux))
#     minval <- sort(ux, partial=max((un-k+1), 1):un, na.last = TRUE)[max((un-k+1),1)]
#
#     # we are using the rationale of rle here, as it turned out to be the fastest approach
#     x <- sort(x[x>=minval])
#     n <- length(x)
#     if (n == 0L)
#       res <- list(lengths = integer(), values = x)
#
#     y <- x[-1L] != x[-n]
#     i <- c(which(y | is.na(y)), n)
#     res <- list(lengths = diff(c(0L, i)), values = x[i])
#
#     # res <- unclass(rle(sort(x[x>=minval])))
#   }
#   else {
#     # n <- length(x)
#     n <- sum(!is.na(x))
#     res <- sort(x, partial=max((n-k+1),1):n, na.last = TRUE)[max((n-k+1),1):n]
#     #   lst <- as.vector(unlist(lapply(lst, "[", "val")))
#     #   http://stackoverflow.com/questions/15659783/why-does-unlist-kill-dates-in-r
#
#     # faster alternative (but check NA-handling first):
#     # res <-  x[.Call("_DescTools_top_index", PACKAGE = "DescTools", x, k)]
#
#   }
#   return(res)
# }



Small <- function (x, k = 5L, unique = FALSE, na.last = NA) {

  n <- length(x)
  x <- x[!is.na(x)]
  na_n <- n - length(x)

#  na.last
#  for controlling the treatment of NAs. If TRUE, missing values in the data are put last;
#  if FALSE, they are put first;
#  if NA, they are removed.

  if (unique==TRUE) {

    res <- .Call("_DescTools_bottom_n", PACKAGE = "DescTools", x, k)

    if(na_n > 0L){
      if(!is.na(na.last)){
        if(na.last==FALSE) {
          k <- min(length(res$value) + 1L, k)
          res$value <- c(NA, res$value)[1L:k]
          res$frequency <- c(na_n, res$frequency)[1L:k]
        }
        if(na.last==TRUE){
          k <- min(length(res$value) + 1L, k)
          res$value <- c(res$value, NA)[1L:k]
          res$frequency <- c(res$frequency, na_n)[1L:k]
        }
      }
    }
    if(is.factor(x))
      res$value <- levels(x)[res$value]
    else
      class(res$value) <- class(x)

  } else {

    # do not allow k be bigger than n
    k <- min(k, n)

    res <- rev(x[.Call("_DescTools_bottom_i", PACKAGE = "DescTools", x, k)])

    if(!is.na(na.last)){
      if(na.last==FALSE)
        res <- c(rep(NA, na_n), res)[1L:k]
      if(na.last==TRUE)
        res <- c(res, rep(NA, na_n))[1L:k]
    }

  }

  return(res)

}


# Small <- function (x, k = 5, unique = FALSE, na.rm = FALSE) {
#
#   if (na.rm)
#     x <- x[!is.na(x)]
#
#   if (unique==TRUE) {
#     ux <- unique(x)
#     un <- length(ux)
#     maxval <- sort(ux, partial = min(k, un))[min(k, un)]
#
#     # we are using the rationale of rle here, as it turned out to be the fastest approach
#     x <- sort(x[x<=maxval])
#     n <- length(x)
#     if (n == 0L)
#       res <- list(lengths = integer(), values = x)
#
#     y <- x[-1L] != x[-n]
#     i <- c(which(y | is.na(y)), n)
#     res <- list(lengths = diff(c(0L, i)), values = x[i])
#
#     # res <- unclass(rle(sort(x[x<=maxval])))
#   }
#   else {
#     n <- length(x)
#     res <- sort(x, partial = 1:min(k, n))[1:min(k, n)]
#     #   lst <- as.vector(unlist(lapply(lst, "[", "val")))
#     #   http://stackoverflow.com/questions/15659783/why-does-unlist-kill-dates-in-r
#   }
#   return(res)
# }




HighLow <- function (x, nlow = 5L, nhigh = nlow, na.last = NA) {

  # updated 1.2.2014 / Andri
  # using table() was unbearable slow and inefficient for big vectors!!
  # sort(partial) is the way to go..
  # http://r.789695.n4.nabble.com/Fast-way-of-finding-top-n-values-of-a-long-vector-td892565.html

  # updated 1.5.2016 / Andri
  # ... seemed the way to go so far, but now outperformed by nathan russell's C++ solution

  if ((nlow + nhigh) != 0L) {
    frqs <- Small(x, k=nlow, unique=TRUE, na.last=na.last)
    frql <- Large(x, k=nhigh, unique=TRUE, na.last=na.last)
    frq <- c(frqs$frequency, frql$frequency)

    vals <- c(frqs$value, frql$value)
    if (is.numeric(x)) {
      vals <- prettyNum(vals, big.mark = "'")
    }
    else {
      vals <- vals
    }
    frqtxt <- paste(" (", frq, ")", sep = "")
    frqtxt[frq < 2L] <- ""

    txt <- StrTrim(paste(vals, frqtxt, sep = ""))
    lowtxt <- paste(head(txt, min(length(frqs$frequency), nlow)), collapse = ", ")
    hightxt <- paste(tail(txt, min(length(frql$frequency), nhigh)), collapse = ", ")
  }
  else {
    lowtxt <- ""
    hightxt <- ""
  }
  return(paste("lowest : ", lowtxt, "\n",
               "highest: ", hightxt, "\n", sep = ""))
}



Closest <- function(x, a, which = FALSE, na.rm = FALSE){

#   # example: Closest(a=67.5, x=d.pizza$temperature)
#
  if(na.rm) x <- x[!is.na(x)]

  mdist <- min(abs(x-a))
  if(is.na(mdist))
    res <- NA

  else {
    idx <- DescTools::IsZero(abs(x-a) - mdist)    # beware of floating-point-gods
    if(which == TRUE )
      res <- which(idx)
    else
      res <- x[idx]
  }

# Frank's Hmisc solution is faster
# but does not handle ties satisfactorily

#   res <- .Fortran("wclosest", as.double(a), as.double(x), length(a),
#            length(x), j = integer(length(a)), PACKAGE = "DescTools")$j
#   if(!which) res <- x[res]
  return(res)

}


# DenseRank <- function(x, na.last = TRUE) {
#   as.numeric(as.factor(rank(x, na.last)))
# }



Rank <- function(..., decreasing = FALSE, na.last = TRUE, 
                 ties.method = c("average", "first", "last", 
                                 "random", "max", "min", "dense")){
  
  ord <- replace(z <- as.numeric(!decreasing), list = z==0, values = -1)
  
  x <- list(...)
  
  if(length(x)==1){
    x <- x[[1]]
  } 
  
  if(!is.vector(x))
    ord <- rep_len(ord, length(x))
  
  data.table::frankv(x=x, order=ord, na.last=na.last, ties.method=ties.method)

}


PercentRank <- function(x)
  trunc(rank(x, na.last="keep"))/sum(!is.na(x))



Unwhich <- function(idx, n, useNames=TRUE){

  # Author: Nick Sabbe

  # http://stackoverflow.com/questions/7659833/inverse-of-which

  # less performant, but oneliner:
  #   is.element(seq_len(n), i)

  res <- logical(n)

  if(length(idx) > 0L) {
    res[idx] <- TRUE
    if(useNames) names(res)[idx] <- names(idx)
  }

  return(res)

}



CombLevels <- function(...){

  dots <- list( ... )

  unique(unlist(lapply(dots, function(x) {
    if(!inherits(x, "factor")) x <- factor(x)
    levels(x)
  }
  )))

}


WithOptions <- function(optlist, expr) {
  
  # in an R-devel thread started by Charles Geyer, Thomas Lumley offered the following function:
  
  # example:
  # WithOptions(list(digits=3), print((1:10)^-1))
  # WithOptions(list(digits=3), print(Desc(d.pizza$temperature))
  
  oldopt <- options(optlist)
  on.exit(options(oldopt))
  expr <- substitute(expr)
  
  eval.parent(expr)
}



###

## base: string functions ====


# Missing string functions for newbies, but not only..

StrTrim <- function(x, pattern=" \t\n", method="both") {

  switch(match.arg(arg = method, choices = c("both", "left", "right")),
         both =  { gsub( pattern=gettextf("^[%s]+|[%s]+$", pattern, pattern), replacement="", x=x) },
         left =  { gsub( pattern=gettextf("^[%s]+",pattern), replacement="", x=x)  },
         right = { gsub( pattern=gettextf("[%s]+$",pattern), replacement="", x=x)  }
         )

}


StrRight <- function(x, n) {
  n <- rep(n, length.out=length(x))
  sapply(seq_along(x), function(i) {
    if(n[i] >= 0)
      substr(x[i], (nchar(x[i]) - n[i]+1L), nchar(x[i]))
    else
      substr(x[i], - n[i]+1L, nchar(x[i]))
  }  )
}

StrLeft <- function(x, n) {
  n <- rep(n, length.out=length(x))
  sapply(seq_along(x), function(i) {
    if(n[i] >= 0)
      substr(x[i], 0, n[i])
    else
      substr(x[i], 0, nchar(x[i]) + n[i])
  } )
}



StrExtract <- function(x, pattern, ...){
  # example regmatches
  ## Match data from regexpr()
  m <- regexpr(pattern, x, ...)
  regmatches(x, m)

  res <- rep(NA_character_, length(m))
  res[ZeroIfNA(m)>0] <- regmatches(x, m)
  res

}


StrExtractBetween <- function(x, left, right, greedy=FALSE) {
  
  res <- rep(NA_character_, length(x))
  # check that left and right exist, take care for NAs
  # valid <- sapply(StrPos(x, left) <= StrPos(x, right), isTRUE)
  valid <- !sapply(StrPos(StrRight(x, -ZeroIfNA(StrPos(x, left))), right), is.na)
  
  if(greedy)
    res[valid] <- gsub(gettextf("[^%s]*%s(.*)%s.*", left, left, right), "\\1", x[valid])
  else
    res[valid] <- gsub(gettextf("[^%s]*%s(.*?)%s.*", left, left, right), "\\1", x[valid])
  
  return(res)
  
}



# StrTrunc <- function(x, maxlen = 20) {
# 
#   # original truncString from prettyR
#   # author: Jim Lemon
# 
#   #   toolong <- nchar(x) > maxlen
#   #   maxwidth <- ifelse(toolong, maxlen - 3, maxlen)
#   #   chopx <- substr(x, 1, maxwidth)
#   #
#   #   for(i in 1:length(x)) if(toolong[i]) chopx[i] <- paste(chopx[i], "...", sep="")
#   #
#   #   return(formatC(chopx, width = maxlen, flag = ifelse(justify == "left", "-", " ")) )
# 
#   # ... but this is all a bit clumsy, let's have it shorter - and much faster!  ;-)
# 
#   paste(substr(x, 0L, maxlen), ifelse(nchar(x) > maxlen, "...", ""), sep="")
# }


StrTrunc <- function (x, maxlen = 20, ellipsis="...", wbound=FALSE) {
  
  # replace NAs with blanks, and store the indices
  x[!(valid <- !is.na(x))] <- ""
  
  # recycle max length
  maxlen <- rep(maxlen, length.out = length(x))
  
  # correct for word boundaries
  if (wbound) {
    for(i in seq_along(x)){
      
      # only change maxlen for overlong strings
      if(nchar(x[i]) > maxlen[i]){
        # get all word boundaries
        ll <- gregexpr("\\b\\W+\\b", x[i], perl = TRUE)[[1]]
        j <- ll <= maxlen[i]
        
        # use minimum of original maxlen and closest smaller maxlen respecting word boundaries 
        maxlen[i] <- 
          if(all(!j)) {
            # length of first word is > maxlen, so return maxlen 
            maxlen[i]     
          } else {
            max(ll[ll <= maxlen[i]])
          }
      }
    }
  }
  
  res <- paste0(substr(x, 0L, maxlen), ifelse(nchar(x) > maxlen, ellipsis, ""))
  
  # restore NAs
  res[!valid] <- NA_character_
  return(res)
 
}




StrAbbr <- function(x, minchar=1, method=c("left","fix")){

  switch(match.arg(arg = method, choices = c("left", "fix")),
         "left"={
           idx <- rep(minchar, length(x))-1
           for(i in minchar:max(nchar(x))){
             adup <- AllDuplicated(substr(x, 1, i))
             idx[adup] <- i
           }
           res <- substr(x, 1, idx+1)
         },
         "fix"={
           i <- 1
           while(sum(duplicated(substr(x, 1, i))) > 0) { i <- i+1 }
           res <- substr(x, 1, pmax(minchar, i))
         }
  )
  return(res)
}



StrCap <- function(x, method=c("first", "word", "title")) {

  .cap <- function(x){
    # Source: Hmisc
    # Author: Charles Dupont
    capped <- grep('^[^A-Z]*', x, perl=TRUE)

    substr(x[capped], 1,1) <- toupper(substr(x[capped], 1,1))
    return(x)
  }

  na <- is.na(x)

  switch(match.arg(method),
         first = {
           res <- .cap(x)
         },
         word = {
           res <- unlist(lapply(lapply(strsplit(x, split="\\b\\W+\\b"), .cap), paste, collapse=" "))
         },
         title={
           z <- strsplit(tolower(x), split="\\b\\W+\\b")
           low <- c("a","an","the","at","by","for","in","of","on","to","up","and","as","but","or","nor","s")
           z <- lapply(z, function(y) {
             y[y %nin% low] <- StrCap(y[y %nin% low])
             y[y %in% low] <- tolower(y[y %in% low])
             y}
           )

           nn <- strsplit(x, split="\\w+")

           res <- unlist(lapply(1:length(z), function(i) {
             if(length(nn[[i]]) != length(z[[i]])){
               if(z[[i]][1] == "" ){
                 z[[i]] <- z[[i]][-1]
               } else {
                 z[[i]] <- c(z[[i]], "")
               }
             } else {
               if(z[[i]][1] == "" & length(z[[i]])>1)
                 z[[i]] <- VecRot(z[[i]], -1)
             }
             do.call(paste, list(nn[[i]], z[[i]], sep="", collapse=""))
           }
           ))

         }
  )

  res[na] <- NA
  return(res)

}






StrDist <- function (x, y, method = "levenshtein", mismatch = 1, gap = 1, ignore.case = FALSE){

    # source MKmisc, Author: Matthias Kohl

  if(ignore.case){
    x <- tolower(x)
    y <- tolower(y)
  }

  if (!is.na(pmatch(method, "levenshtein")))
      method <- "levenshtein"

    METHODS <- c("levenshtein", "normlevenshtein", "hamming")
    method <- pmatch(method, METHODS)

    if (is.na(method))
      stop("invalid distance method")

    if (method == -1)
      stop("ambiguous distance method")

    stopifnot(is.character(x), is.character(y))

    if (length(x) == 1 & nchar(x[1]) > 1)
      x1 <- strsplit(x, split = "")[[1]]
    else
      x1 <- x

    if (length(y) == 1 & nchar(y[1]) > 1)
      y1 <- strsplit(y, split = "")[[1]]
    else
      y1 <- y

    if (method %in% c(1,2)){ ## Levenshtein
      m <- length(x1)
      n <- length(y1)
      D <- matrix(NA, nrow = m+1, ncol = n+1)
      M <- matrix("", nrow = m+1, ncol = n+1)
      D[,1] <- seq_len(m+1)*gap-1
      D[1,] <- seq_len(n+1)*gap-1
      D[1,1] <- 0
      M[,1] <- "d"
      M[1,] <- "i"
      M[1,1] <- "start"
      text <- c("d", "m", "i")
      for(i in c(2:(m+1))){
        for(j in c(2:(n+1))){
          m1 <- D[i-1,j] + gap
          m2 <- D[i-1,j-1] + (x1[i-1] != y1[j-1])*mismatch
          m3 <- D[i,j-1] + gap
          D[i,j] <- min(m1, m2, m3)
          wmin <- text[which(c(m1, m2, m3) == D[i,j])]
          if("m" %in% wmin & x1[i-1] != y1[j-1])
            wmin[wmin == "m"] <- "mm"
          M[i,j] <- paste(wmin, collapse = "/")
        }
      }
      rownames(M) <- rownames(D) <- c("gap", x1)
      colnames(M) <- colnames(D) <- c("gap", y1)
      d <- D[m+1, n+1]

      if(method == 2){  ## normalized levenshtein
        d <- 1-d / (max(m, n))
      }
    }


    if(method == 3){ ## Hamming
      if(length(x1) != length(y1))
        stop("Hamming distance is only defined for equal length strings")
      d <- sum(x1 != y1)
      D <- NULL
      M <- NULL
    }
    attr(d, "Size") <- 2
    attr(d, "Diag") <- FALSE
    if(length(x) > 1) x <- paste0("", x, collapse = "")
    if(length(y) > 1) y <- paste0("", y, collapse = "")
    attr(d, "Labels") <- c(x,y)
    attr(d, "Upper") <- FALSE
    attr(d, "method") <- METHODS[method]
    attr(d, "call") <- match.call()
    attr(d, "ScoringMatrix") <- D
    attr(d, "TraceBackMatrix") <- M
    class(d) <- c("stringDist", "dist")

    return(d)
}


StrRev <- function(x) {
  # reverses a string
  sapply(lapply(strsplit(x, NULL), rev), paste, collapse="")
}



# useless because we have base::strwrap but interesting as regexp example
#
# StrWordWrap <- function(x, n, sep = "\n") {
#
#   res <- gsub(gettextf("(.{1,%s})(\\s|$)", n), gettextf("\\1%s", sep), x)
#   res <- gsub(gettextf("[%s]$", sep), "", res)
#
#   return(res)
#
# }
#


StrPad <- function(x, width = NULL, pad = " ", adj = "left") {

  .pad <- function(x, width, pad=" ", adj="left"){

    if(is.na(x)) return(NA)

    mto <- match.arg(adj, c("left", "right", "center"))
    free <- max(0, width - nchar(x))
    fill <- substring(paste(rep(pad, ceiling(free / nchar(pad))), collapse = ""), 1, free)
    #### cat("  free=",free,",  fill=",fill,",  mto=",mto,"\n")
    # old, but chop is not a good idea:  if(free <= 0) substr(x, 1, len)
    if(free <= 0) x
    else if  (mto == "left") paste(x, fill, sep = "")
    else if  (mto == "right") paste(fill, x, sep = "")
    else  paste(substring(fill, 1, free %/% 2), x, substring(fill, 1 + free %/% 2, free), sep = "")
  }

  # adj <- sapply(adj, match.arg, choices=c("left", "right", "center"))

  if(is.null(width)) width <- max(nchar(x), na.rm=TRUE)

  lgp <- DescTools::Recycle(x=x, width=width, pad=pad, adj=adj)
  sapply( 1:attr(lgp, "maxdim"), function(i) .pad(lgp$x[i], lgp$width[i], lgp$pad[i], lgp$adj[i]) )

}



StrAlign <- function(x, sep = "\\r"){

  # replace \l by \\^, \r by \\$ and \c means centered
  # check for NA only and combined
  # return x if sep is not found in x

  id.na <- is.na(x)

  # what should be done, if x does not contain sep??
  # we could return unchanged, but this is often not adaquate
  # we align right to the separator
  if(length(grep("\\", sep, fixed=TRUE)) == 0) {
    idx <- !grepl(x=x, pattern=sep, fixed = TRUE)
    x[idx] <- paste(x[idx], sep, sep="")
  }

  # center alignment
  # keep this here, as we may NOT pad x for centered text!!
  # example?? don't see why anymore... check!
  if (sep == "\\c")
    return(StrPad(x, width = max(nchar(x), na.rm=TRUE), pad = " ", adj = "center"))

  # Pad to same maximal length, for right alignment this is mandatory
  # for left alignment not, but again for any character
  x <- StrPad(x, max(nchar(x), na.rm=TRUE))

  # left alignment
  if(sep == "\\l")
    return( sub("(^ +)(.+)", "\\2\\1", x) )

  # right alignment
  if(sep == "\\r")
    return( sub("(.+?)( +$)", "\\2\\1", x) )

  # alignment by a special character
  bef <- substr(x, 1, StrPos(x, sep, fix=TRUE))  # use fix = TRUE as otherwise the decimal would be to have entered as \\.
  aft <- substr(x, StrPos(x, sep, fix=TRUE) + 1, nchar(x))
  # chop white space on the right
  aft <- substr(aft, 1, max(nchar(StrTrim(aft, method="right"))))
  res <- paste(replace(StrPad(bef, max(nchar(bef), na.rm=TRUE),
                              " ", adj = "right"), is.na(bef), ""),
               replace(StrPad(aft, max(nchar(aft), na.rm=TRUE), " ", adj = "left"), is.na(aft),
                       ""), sep = "")

  # restore orignal NAs
  res[id.na] <- NA

  # overwrite the separator
  if(length(grep("\\", sep, fixed=TRUE)) == 0)
    res[idx] <- gsub(sep, " ", res[idx], fixed = TRUE)

  # return unchanged values not containing sep
  return(res)

}



StrChop <- function(x, len, pos) {

  .chop <- function(x, len, pos) {
    # Splits a string into a number of pieces of fixed length
    # example: StrChop(x=paste(letters, collapse=""), len = c(3,5,0))
    if(!missing(len)){
      if(!missing(pos))
        stop("too many arguments")
    } else {
      len <- c(pos[1], diff(pos), nchar(x))
    }

    xsplit <- character(0)
    for(i in 1:length(len)){
      xsplit <- append(xsplit, substr(x, 1, len[i]))
      x <- substr(x, len[i]+1, nchar(x))
    }
    return(xsplit)
  }

  res <- lapply(x, .chop, len=len, pos=pos)

  if(length(x)==1)
    res <- res[[1]]

  return(res)

}



StrCountW <- function(x){
  # old:    does not work for one single word!!
  # return(sapply(gregexpr("\\b\\W+\\b", x, perl=TRUE), length) + 1)
  return(sapply(gregexpr("\\b\\W+\\b", x, perl = TRUE), function(x) sum(x>0)) + 1)
}


StrVal <- function(x, paste = FALSE, as.numeric = FALSE, dec=getOption("OutDec")){

  # Problem 20.2.2015: - will not be accepted, when a space is between sign and number
  # not sure if this is really a problem: -> oberserve...
  # StrVal(x="- 2.5", paste = FALSE, as.numeric = FALSE)

  # pat <- paste("[-+", dec, "e0-9]*\\d", sep="")
  # new pattern by markus
  pat <- gettextf("([+-]\\s?)?\\d+(%s\\d+)?([eE][+-]?\\d+)?", ifelse(dec==".", "\\.", dec))

  gfound <- gregexpr(pattern=pat, text=x)
  vals <- lapply(seq_along(x), function(i){
    found <- gfound[[i]]
    ml <- attr(found, which="match.length")
    res <- sapply(seq_along(found), function(j) substr(x[i], start=found[j], stop=found[j]+ml[j]-1) )
    res <- sapply(res, gsub, pattern=" ", replacement="")
    return(res)
  })

  if(paste==TRUE) {
    vals <- sapply(vals, paste, collapse="")
    if(as.numeric==TRUE){
      # we should change a given dec to the system decimal point befor casting to numeric
      if(dec != getOption("OutDec"))
        vals <- sapply(vals, gsub, pattern=dec, replacement=getOption("OutDec"))

      vals <- as.numeric(vals)
    }
  } else {
    if(as.numeric==TRUE){
      # we should change a given dec to the system decimal point befor casting to numeric
      if(dec != getOption("OutDec"))
        vals <- sapply(vals, gsub, pattern=dec, replacement=getOption("OutDec"))
      vals <- sapply(vals, as.numeric)
    } else
      vals <- sapply(vals, as.character)
  }

  return(vals)

}


StrPos <- function(x, pattern, pos=1, ... ){

# example:
#    StrPos(x=levels(d.pizza$driver), "t", pos=4)

  pos <- rep(pos, length.out=length(x))
  x <- substr(x, start=pos, stop=nchar(x))

  i <- as.vector(regexpr(pattern = pattern, text = x, ...))
  i[i<0] <- NA
  return(i)
}



SplitPath <- function(path, last.is.file=NULL) {

  if(is.null(last.is.file)){
    # if last sign is delimiter / or \ read path as dirname
    last.is.file <- (length(grep(pattern="[/\\]$", path)) == 0)
  }

  path <- normalizePath(path, mustWork = FALSE)

  lst <- list()

  lst$normpath <- path
  if (.Platform$OS.type == "windows") {
    lst$drive <- regmatches(path, regexpr("^([[:alpha:]]:)|(\\\\[[:alnum:]]+)", path))
    lst$dirname <- gsub(pattern=lst$drive, x=dirname(path), replacement="")
  } else {
    lst$drive <- NA
    lst$dirname <- dirname(path)
  }

  lst$dirname <- paste(lst$dirname, "/", sep="")
  lst$fullfilename <- basename(path)

  lst$fullpath <- paste0(BlankIfNA(lst$drive), lst$dirname)
  
  # lst$filename <- strsplit(lst$fullfilename, "\\.")[[1]][1]
  # lst$extension <- strsplit(lst$fullfilename, "\\.")[[1]][2]

  lst$filename <- gsub(pattern="(.*)\\.(.*)$", "\\1",lst$fullfilename)
  # use the positive lookbehind here
  lst$extension <- StrExtract(pattern = "(?<=\\.)[^\\.]+$", lst$fullfilename, perl=TRUE)
  # see also tools::file_path_sans_ext() and tools::file_ext()
  # but has a less general regex

  if(!last.is.file){
    lst$dirname <- paste(lst$dirname, lst$fullfilename, "/",
                         sep="")
    lst$extension <- lst$filename <- lst$fullfilename <- NA
  }
  return(lst)

}


StrSpell <- function(x, upr="CAP", type = c("NATO", "Morse")){

  # example:    Spell("Yailov9teb6i")

  type <- match.arg(type)
  upr <- BlankIfNA(upr)

  y <- factor(strsplit(x, "")[[1]], levels = c(LETTERS, letters, 0:9))

  if(type=="NATO"){
    phon <- c("Alfa", "Bravo", "Charlie",
              "Delta", "Echo", "Foxtrot", "Golf", "Hotel", "India", "Juliett",
              "Kilo", "Lima", "Mike", "November", "Oscar", "Papa", "Quebec",
              "Romeo", "Sierra", "Tango", "Uniform", "Victor", "Whiskey", "Xray",
              "Yankee", "Zulu")
    levels(y) <- c(paste(upr, phon), phon, c("Zero", "One", "Two", "Three", "Four", "Five","Six","Seven","Eight","Nine"))

  } else if(type=="Morse"){

    phon <- c(".-", "-...", "-.-.",
              "-..", ".", "..-.", "--.", "....", "..", ".---",
              "-.-", ".-..", "--", "-.", "---", ".--.", "--.-",
              ".-.", "...", "-", "..-", "...-", ".--", "-..-",
              "-.--", "--..")
    levels(y) <- c(phon, phon, c("-----", ".----", "..---", "...--", "....-", ".....","-....","--...","---..","----."))

  }

  return(StrTrim(as.character(y)))

}



StrSplit <- function (x, split="", fixed = FALSE, perl = FALSE, useBytes = FALSE) {
  # same as strsplit, but nicer defaults
  res <- strsplit(x=x, split=split, fixed=fixed, perl=perl, useBytes=useBytes)
  if(length(res)==1)
    res <-  res[[1]]
  
  return(res)
}



SplitToCol <- function(x, split=" ", fixed = TRUE, na.form="", colnames=NULL){
  
  lst <- lapply(x, function(z)
    strsplit(z, split = split, fixed = fixed))
  
  # we don't want to have values recycled here, but need same number
  # of elements to afterwards be able to use rbind()
  for(i in seq_along(lst)){
    # find the maximal length of the splits in the column
    maxlen <- max(sapply(lst[[i]], length))
    # set all character vectors to same length
    for(j in seq_along(lst[[i]])){
      length(lst[[i]][[j]]) <- maxlen
      # set na.form for missings
      lst[[i]][[j]][is.na(lst[[i]][[j]])] <- na.form
    }
  }

  # rbind all the columns
  lst <- lapply(lst, function(z) do.call(rbind, z))
  
  res <- do.call(data.frame, list(lst, stringsAsFactors=FALSE))
  
  if(!is.null(colnames))
    colnames(res) <- rep(colnames, length.out=ncol(res))
  
  # communicate the number of columns found 
  attr(res, "cols") <- sapply(lst, ncol)
  
  return(res)
  
}





###

## base: conversion functions ====


CharToAsc <- function(x) {
  # Original from Henrik Bengtsson R.oo:
  # char2asc <- function (ch, ...) { match(ch, ASCII) - 1 }
  # example:  x.char <- char2asc(x="Andri")


  if(length(x) == 1)
    strtoi(charToRaw(x), 16L)
  else
    sapply(x, function(x) strtoi(charToRaw(x), 16L))

}


AscToChar <- function(i) {
# old version:
# example: AscToChar(x.char)
#  ASCII <- intToUtf8(1:256, multiple=TRUE)

  # new and far more elegant
  # ref: http://datadebrief.blogspot.ch/search/label/R
  rawToChar(as.raw(i))

}


HexToDec <- function(x) 
  # strip potential # from a string x
  strtoi(gsub("^#", "", x), 16L)
  # example: strtoi(c("9A", "3B"), 16L)

DecToHex <- function(x) as.hexmode(as.numeric(x))

OctToDec <- function(x) strtoi(x, 8L)
# example: strtoi(c("12", "24"), 8L)
DecToOct <- function(x) as.numeric(as.character(as.octmode(as.numeric(x))))
# Alternative: as.numeric(sprintf(242, fmt="%o"))


BinToDec <- function(x) {
  # Alternative:  bin2dec <- function(x) { sum(2^.subset((length(x)-1):0, x)) }
  # example: bin2dec(x=as.numeric(unlist(strsplit("1001", split=NULL)))==1)
  strtoi(x, 2L)
}
# example: strtoi(c("100001", "101"), 2L)

# DecToBin <- function (x) {
#   # This would be nice, but does not work: (intToBin from R.utils)
#   # y <- as.integer(x)
#   # class(y) <- "binmode"
#   # y <- as.character(y)
#   # dim(y) <- dim(x)
#   # y
#   as.vector(sapply(x, function(x) as.integer(paste(rev(as.integer(intToBits(x))), collapse=""))))
# }

DecToBin <- function (x) {
  z <- .Call("_DescTools_conv_DecToBin", PACKAGE = "DescTools", x)
  z[x > 536870911] <- NA
  return(sub("^0+", "", z))
}


# void dec_to_bin(int number) {
#   int remainder;
#
#   if(number <= 1) {
#     cout << number;
#     return;
#   }
#
#   remainder = number%2;
#   dec_to_bin(number >> 1);
#   cout << remainder;
# }

# DecToBinC <- function(x){
#   z <- .C("dec_to_bin", x = as.integer(x))
#   return(z)
# }


RomanToInt <- function (x) {

  # opposite to as.roman

  roman2int.inner <- function (roman) {
    results <- .C("roman2int", roman = as.character(roman), nchar = as.integer(nchar(roman)),
                  value = integer(1), PACKAGE = "DescTools")
    return(results$value)
  }

  roman <- trimws(toupper(as.character(x)))
  tryIt <- function(x) {
    retval <- try(roman2int.inner(x), silent = TRUE)
    if (is.numeric(retval))
      retval
    else NA
  }
  retval <- sapply(roman, tryIt)
  retval

}



DegToRad <- function(deg) deg * pi /180

RadToDeg <- function(rad) rad * 180 / pi



ConvUnit <- function(x, from, to){

  splitunit <- function(x){
    # # split the prefix from the unit for SI units and prefixes
    # # prefix pattern, note that da is the only prefix with two characters
    # prefpat <- "^([YZEPTGMkhcmunpfazy]|(da|d))"
    # # check prefix in combination with SI-unit first
    # prefix <- StrExtract(x, pattern=paste0(prefpat, "(m|g|s|A|K|mol|cd|Hz|rad|sr|N|Pa|J|W|C|V|F|Ohm|S|Wb|T|H|lm|lx|Bq|Gy|Sv|kat|l)$"))
    # # ... and the extract it from the found valid combination
    # prefix <- ifelse(is.na(prefix), NA, StrExtract(prefix, pattern=prefpat))
    # fact <- ifelse(is.na(prefix), 1, d.prefix$mult[match(prefix, d.prefix$abbr)])
    # unit <- ifelse(is.na(prefix), x, gsub(pattern = gettextf("^%s", prefix), "", x))
    #
    # list(prefix=prefix, fact=fact, unit=unit)

    m <- regexpr(pattern="^([YZEPTGMkhcmunpfazy]|(da|d))", x)

    prefix <- ifelse(m == -1, NA, StrLeft(x, attr(m, "match.length")))
    fact <- ifelse(is.na(prefix), 1, d.prefix$mult[match(prefix, d.prefix$abbr)])
    unit <- ifelse(is.na(prefix), x, StrRight(x, -attr(m, "match.length")))

    if(length(grep("^(m|g|s|A|K|mol|cd|Hz|rad|sr|N|Pa|J|W|C|V|F|Ohm|S|Wb|T|H|lm|lx|Bq|Gy|Sv|kat|l)$", unit))==0){
      prefix <- NA
      fact <- 1
      unit <- x
    }

    list(prefix=prefix, fact=fact, unit=unit)

  }


  # split prefix and unit
  u_from <- splitunit(from)
  u_to <- splitunit(to)

  convertible <- u_from$unit == u_to$unit

  # Check for plausible temperatures first
  # Note: C stands for Celsius and Coulomb, F for Fahrenheit and Farad
  # Prefixes are only allowed for Kelvin (although, not sure...)
  # if(to == "\u00B0C")

  if(from == "C") {
    if(to == "F")
      return(x * 1.8 + 32)
    else if(u_to$unit == "K")
      return(u_to$fact * x + 273.15)
  }
  if(from == "F") {
    if(to == "C")
      return((x - 32) * 5/9)
    else if(u_to$unit == "K")
      return(u_to$fact * x - 273.15)
  }
  if(u_from$unit == "K") {
    x <- u_from$fact * x
    if(to == "C")
      return(x + 273.15)
    else if(to == "F")
      return((x + 273.15) * 1.8 + 32)
  }


  # then others
  # create units as JOIN
  # d.u <- merge(d.units[, 1:3], d.units[, 1:3], by.x="to", by.y="to")
  # d.u <- d.u[d.u$from.x!=d.u$from.y,]
  # d.u <- rbind(d.units[, 1:3],
  #              data.frame(from=d.u$from.x, to=d.u$from.y, fact=d.u$fact.x/d.u$fact.y))
  # d.u$pair <- paste(d.u$from, d.u$to, sep="-")


  if(u_from$unit != u_to$unit) {
    # lookup conversion factor between units
    z <- match(paste(u_from$unit, u_to$unit, sep="-"), d.units$uid)
    # units are not convertible if they're not found
    if(is.na(z)) {
      # no match from-to, look for match to-from
      z <- match(paste(u_to$unit, u_from$unit, sep="-"), d.units$uid)
      # get the factor if it has been found or set 1 else
      if(is.na(z)) {
        u_fact <- 1
        convertible <- FALSE
      } else {
        u_fact <- 1/d.units$fact[z]
        convertible <- TRUE
      }

    } else {
      # match from-to has been found, get the according factor
      u_fact <- d.units$fact[z]
      convertible <- TRUE
    }
  } else {
    # same units, set factor 1
    u_fact <- 1
  }

  if(!convertible)
    res <- NA
  else
    res <- x * u_from$fact/u_to$fact * u_fact

  #   return(list(u_from, u_to, res, u_fact ))
  return(res)

}


DoCall <- function (what, args, quote = FALSE, envir = parent.frame())  {

  # source: Gmisc
  # author: Max Gordon <max@gforge.se>

  if (quote)
    args <- lapply(args, enquote)

  if (is.null(names(args)) ||
      is.data.frame(args)){
    argn <- args
    args <- list()
  }else{
    # Add all the named arguments
    argn <- lapply(names(args)[names(args) != ""], as.name)
    names(argn) <- names(args)[names(args) != ""]
    # Add the unnamed arguments
    argn <- c(argn, args[names(args) == ""])
    args <- args[names(args) != ""]
  }

  if (class(what) == "character"){
    if(is.character(what)){
      fn <- strsplit(what, "[:]{2,3}")[[1]]
      what <- if(length(fn)==1) {
        get(fn[[1]], envir=envir, mode="function")
      } else {
        get(fn[[2]], envir=asNamespace(fn[[1]]), mode="function")
      }
    }
    call <- as.call(c(list(what), argn))
  }else if (class(what) == "function"){
    f_name <- deparse(substitute(what))
    call <- as.call(c(list(as.name(f_name)), argn))
    args[[f_name]] <- what
  }else if (class(what) == "name"){
    call <- as.call(c(list(what, argn)))
  }

  eval(call,
       envir = args,
       enclos = envir)

}


MultMerge <- function(..., all.x=TRUE, all.y=TRUE, by=NULL) {
  
  lst <- list(...)
  
  # if just one object, there's nothing to merge
  if(length(lst)==1)  return(lst[[1]])
  
  if(!is.null(by)){
    # merge column is given and must exist in all the data.frames
    # we overwrite the row.names and remove the merge column
    for(i in seq_along(lst)){
      rownames(lst[[i]]) <- lst[[i]][[by]]
      lst[[i]][by] <- NULL
    }
  }  
  
  # the columnnames must be unique within the resulting data.frame
  unames <- SplitAt(make.unique(unlist(lapply(lst, colnames)), sep = "."), 
                    cumsum(sapply(head(lst, -1), ncol))+1)
  
  for(i in seq_along(unames))
    colnames(lst[[i]]) <- unames[[i]]
  
  # works perfectly, but sadly does not pass CRAN check :-(
  #
  # transform(Reduce(function(y, z)
  #                     merge(y, z, all.x=all.x, all.y=all.x),
  #                  lapply(lst, function(x)
  #                                 data.frame(x, rn=row.names(x))
  #                         ))
  #           , row.names=rn, rn=NULL)
  
  res <- Reduce(function(y, z)
    merge(y, z, all.x=all.x, all.y=all.x),
    lapply(lst, function(x)
      data.frame(x, rn=row.names(x))
    ))
  rownames(res) <- res$rn
  res$rn <- NULL
  
  
  # define a better order than merge is returning, rownames from left to right
  seq_ord <- function(xlst){
    jj <- character(0)
    for(i in seq_along(xlst)){
      jj <- c(jj, setdiff(xlst[[i]], jj))
    }
    return(jj)
  }
  
  # the coefficients should be ordered such, that the coeffs of the first model
  # come first, then the coeffs from the second model which were not included
  # in the model one, then the coeffs from mod3 not present in mod1 and mod2
  # and so forth...
  ord <- seq_ord(lapply(lst, rownames))
  
  res[ord, ]
  
  if(!is.null(by)){
    # restore key and remove rownames if there was one
    res <- data.frame(row.names(res), res)
    colnames(res)[1] <- by
    rownames(res) <- c()
  }
  
  return(res)
  
  
}





###

## base: transformation functions ====

as.matrix.xtabs <- function(x, ...){

  # xtabs would not be converted by as.matrix.default...

  attr(x, "class") <- NULL
  attr(x, "call") <- NULL

  return(x)

}


TextToTable <- function(x, dimnames = NULL, check.names=FALSE, ...){

  d.frm <- read.table(text=x, check.names=check.names, ...)
  tab <- as.table(as.matrix(d.frm))
  if(!is.null(dimnames)) names(dimnames(tab)) <- dimnames

  return(tab)

}


Recode <- function(x, ..., elselevel=NA, use.empty=FALSE, num=FALSE){

  newlevels <- list(...)

  if( sum(duplicated(unlist(newlevels))) > 0) stop ("newlevels contain non unique values!")

  # convert numeric values to according levels if all arguments are passed as numerics
  if(all(is.numeric(unlist(newlevels))))
    newlevels <- lapply(newlevels, function(i) levels(x)[i])

  if(is.null(elselevel)) { # leave elselevels as they are
    elselevels <- setdiff(levels(x), unlist(newlevels))
    names(elselevels) <- elselevels
    newlevels <- c(newlevels, elselevels)

  } else {
    if(!is.na(elselevel)){
      newlevels[[length(newlevels)+1]] <- setdiff(levels(x), unlist(newlevels))
      names(newlevels)[[length(newlevels)]] <- elselevel
    }
  }
  levels(x) <- newlevels
  if(!use.empty) x <- factor(x)  # delete potentially empty levels

  if(num)
    x <- as.numeric(as.character(x))

  return(x)
}


# RevCode <- function(x, lbound=min(x, na.rm=TRUE), ubound=max(x, na.rm=TRUE)) {
#   
#   x <- as.numeric(x)
#   
#   x[x %)(% c(lbound, ubound)] <- NA
#   
#   return(lbound + ubound - x)
#   
# }



RevCode <- function (x) {
  
  if(is.factor(x)) {
    levels(x) <- rev(levels(x))
    res <- factor(x, levels=rev(levels(x)))
    
  } else if(is.numeric(x)){
    res <- (min(x) + max(x) - x)
    
  } else if(is.logical(x)) {
    res <- as.logical(1 - x)
    
  } else {
    res <- NA
  }
  
  return(res)  
  
}




NAIf <- function (x, what) {
  x[!is.na(match(x, what))] <- NA
  return(x)
} 


ZeroIfNA <- function(x) {
#  same as zeroifnull in SQL
  replace(x, is.na(x), 0L)
}

NAIfZero <- function(x)
  replace(x, IsZero(x), NA)


BlankIfNA <- function(x, blank="") {
  #  same as zeroifnull but with characters
  replace(x, is.na(x), blank)
}


NAIfBlank <- function(x)
  replace(x, x=="", NA)




Impute <- function(x, FUN = function(x) median(x, na.rm=TRUE)) {

  if(is.function(FUN)) {
    #  if FUN is a function, then save it under new name and
    # overwrite function name in FUN, which has to be character
    fct <- FUN
    FUN <- "fct"
    FUN <- gettextf("%s(x)", FUN)
  }
  # Calculates the mean absolute deviation from the sample mean.
  return(eval(parse(text = gettextf("replace(x, is.na(x), %s)", FUN))))

}




reorder.factor <- function(x, X, FUN, ..., order=is.ordered(x), new.order,
                           sort=SortMixed) {

  # 25.11.2017 verbatim from gdata, Greg Warnes

  constructor <- if (order) ordered else factor

  if(!missing(X) || !missing(FUN)){

    if(missing(FUN)) FUN <- 'mean'

    ## I would prefer to call stats::reorder.default directly,
    ## but it exported from stats, so the relevant code is
    ## replicated here:
    ## -->
    scores <- tapply(X = X, INDEX = x, FUN = FUN, ...)
    levels <- names(base::sort(scores, na.last = TRUE))
    if(order)
      ans <- ordered(x, levels=levels)
    else
      ans <- factor(x, levels=levels)
    attr(ans, "scores") <- scores
    ## <--
    return(ans)

  } else if (!missing(new.order)) {

    if (is.numeric(new.order))
      new.order <- levels(x)[new.order]
    else
      new.order <- new.order

  } else
    new.order <- sort(levels(x))

  constructor(x, levels=new.order)
}




SortMixed <- function(x,
                      decreasing=FALSE,
                      na.last=TRUE,
                      blank.last=FALSE,
                      numeric.type=c("decimal", "roman"),
                      roman.case=c("upper","lower","both") ) {

  ord <- OrderMixed(x,
                    decreasing=decreasing,
                    na.last=na.last,
                    blank.last=blank.last,
                    numeric.type=numeric.type,
                    roman.case=roman.case
                    )
  x[ord]
}



OrderMixed <- function(x,
                       decreasing=FALSE,
                       na.last=TRUE,
                       blank.last=FALSE,
                       numeric.type=c("decimal", "roman"),
                       roman.case=c("upper","lower","both") ) {

  # 25.11.2017 verbatim from gtools, Greg Warnes


  # - Split each each character string into an vector of strings and
  #   numbers
  # - Separately rank numbers and strings
  # - Combine orders so that strings follow numbers

  numeric.type <- match.arg(numeric.type)
  roman.case   <- match.arg(roman.case)

  if(length(x)<1)
    return(NULL)
  else if(length(x)==1)
    return(1)

  if( !is.character(x) )
    return( order(x, decreasing=decreasing, na.last=na.last) )

  delim="\\$\\@\\$"

  if(numeric.type=="decimal")
  {
    regex <- "((?:(?i)(?:[-+]?)(?:(?=[.]?[0123456789])(?:[0123456789]*)(?:(?:[.])(?:[0123456789]{0,}))?)(?:(?:[eE])(?:(?:[-+]?)(?:[0123456789]+))|)))"  # uses PERL syntax
    numeric <- function(x) as.numeric(x)
  }
  else if (numeric.type=="roman")
  {
    regex <- switch(roman.case,
                    "both"  = "([IVXCLDMivxcldm]+)",
                    "upper" = "([IVXCLDM]+)",
                    "lower" = "([ivxcldm]+)"
    )
    numeric <- function(x) RomanToInt(x)
  }
  else
    stop("Unknown value for numeric.type: ", numeric.type)

  nonnumeric <- function(x)
  {
    ifelse(is.na(numeric(x)), toupper(x), NA)
  }

  x <- as.character(x)

  which.nas <- which(is.na(x))
  which.blanks <- which(x=="")

  ####
  # - Convert each character string into an vector containing single
  #   character and  numeric values.
  ####

  # find and mark numbers in the form of +1.23e+45.67
  delimited <- gsub(regex,
                    paste(delim,"\\1",delim,sep=""),
                    x,
                    perl=TRUE)

  # separate out numbers
  step1 <- strsplit(delimited, delim)

  # remove empty elements
  step1 <- lapply( step1, function(x) x[x>""] )

  # create numeric version of data
  suppressWarnings( step1.numeric <-  lapply( step1, numeric ) )

  # create non-numeric version of data
  suppressWarnings( step1.character <- lapply( step1, nonnumeric ) )

  # now transpose so that 1st vector contains 1st element from each
  # original string
  maxelem <- max(sapply(step1, length))

  step1.numeric.t <- lapply(1:maxelem,
                            function(i)
                              sapply(step1.numeric,
                                     function(x)x[i])
  )

  step1.character.t <- lapply(1:maxelem,
                              function(i)
                                sapply(step1.character,
                                       function(x)x[i])
  )

  # now order them
  rank.numeric   <- sapply(step1.numeric.t, rank)
  rank.character <- sapply(step1.character.t,
                           function(x) as.numeric(factor(x)))

  # and merge
  rank.numeric[!is.na(rank.character)] <- 0  # mask off string values

  rank.character <- t(
    t(rank.character) +
      apply(matrix(rank.numeric),2,max,na.rm=TRUE)
  )

  rank.overall <- ifelse(is.na(rank.character),rank.numeric,rank.character)

  order.frame <- as.data.frame(rank.overall)
  if(length(which.nas) > 0)
    if(is.na(na.last))
      order.frame[which.nas,] <- NA
  else if(na.last)
    order.frame[which.nas,] <- Inf
  else
    order.frame[which.nas,] <- -Inf

  if(length(which.blanks) > 0)
    if(is.na(blank.last))
      order.frame[which.blanks,] <- NA
  else if(blank.last)
    order.frame[which.blanks,] <- 1e99
  else
    order.frame[which.blanks,] <- -1e99

  order.frame <- as.list(order.frame)
  order.frame$decreasing <- decreasing
  order.frame$na.last <- NA

  retval <- do.call("order", order.frame)

  return(retval)
}



#
#
# Lookup <- function(x, ref, val){
#   val[match(x, ref)]
# }



# StahelLogC <- function(x, na.rm=FALSE) {
#   if(na.rm) x <- na.omit(x)
#   ### muessen die 0-Werte hier weggelassen werden??
#   x <- x[x>0]
#   ### additive Konstante fuer die Logarithmierung nach Stahel "...es hat sich gezeigt, dass..."
#   return(as.vector(median(x) / (median(x)/quantile(x, 0.25))^2.9))
# }

# http://support.sas.com/documentation/cdl/en/statugfreq/63124/PDF/default/statugfreq.pdf




LogSt <- function(x, base = 10, calib = x, threshold = NULL, mult = 1) {

# original function logst in source regr
#
#   # Purpose:   logs of x, zeros and small values treated well
#   # *********************************************************************
#   # Author: Werner Stahel, Date:  3 Nov 2001, 08:22
#   x <- cbind(x)
#   calib <- cbind(calib)
#   lncol <- ncol(calib)
#   ljthr <- length(threshold) > 0
#   if (ljthr) {
#     if (!length(threshold) %in% c(1, lncol))
#       stop("!LogSt! length of argument 'threshold' is inadequate")
#     lthr <- rep(threshold, length=lncol)
#     ljdt <- !is.na(lthr)
#   } else {
#     ljdt <- rep(TRUE, lncol)
#     lthr <- rep(NA, lncol)
#     for (lj in 1:lncol) {
#       lcal <- calib[, lj]
#       ldp <- lcal[lcal > 0 & !is.na(lcal)]
#       if(length(ldp) == 0) ljdt[lj] <- FALSE else {
#         lq <- quantile(ldp,probs = c(0.25,0.75), na.rm = TRUE)
#         if(lq[1] == lq[2]) lq[1] <- lq[2]/2
#         lthr[lj] <- lc <- lq[1]^(1 + mult) / lq[2]^mult
#       }
#     }
#   }
#   # transform x
#   for (lj in 1:lncol) {
#     ldt <- x[,lj]
#     lc <- lthr[lj]
#     li <- which(ldt < lc)
#     if (length(li))
#       ldt[li] <- lc * 10^((ldt[li] - lc) / (lc * log(10)))
#     x[,lj] <- log10(ldt)
#   }
#   if (length(colnames(x)))
#     lnmpd <- names(ljdt) <- names(lthr) <- colnames(x)  else
#     lnmpd <- as.character(1:lncol)
#
#   attr(x,"threshold") <- c(lthr)
#
#   if (any(!ljdt)) {
#     warning(':LogSt: no positive x for variables',lnmpd[!ljdt],
#             '. These are not transformed')
#     attr(x,"untransformed") <- c(ljdt)
#   }
#   x


  if(is.null(threshold)){
    lq <- quantile(calib[calib > 0], probs = c(0.25, 0.75), na.rm = TRUE)
    if (lq[1] == lq[2]) lq[1] <- lq[2]/2
    threshold <- lq[1]^(1 + mult)/lq[2]^mult
  }

  res <- rep(NA, length(x))
  idx <- (x < threshold)
  idx.na <- is.na(idx)
  res[idx & !idx.na] <- log(x = threshold, base=base) + ((x[idx & !idx.na] - threshold)/(threshold * log(base)))
  res[!idx & !idx.na] <- log(x = x[!idx & !idx.na], base=base)

  attr(res, "threshold") <- threshold
  attr(res, "base") <- base
  return(res)

}


LogStInv <- function (x, base=NULL, threshold = NULL) {

  if(is.null(threshold)) threshold <- attr(x, "threshold")
  if(is.null(base)) base <- attr(x, "base")

  res <- rep(NA, length(x))
  idx <- (x < log10(threshold))
  idx.na <- is.na(idx)
  res[idx & !idx.na] <- threshold - threshold * log(base) *( log(x = threshold, base=base) - x[idx & !idx.na])
  res[!idx & !idx.na] <- base^(x[!idx & !idx.na])

  return(res)

}



# Variance stabilizing functions
# log(x+a)
# log(x+a, base=10)
# sqrt(x+a)
# 1/x
# arcsinh(x)

# LogGen <- function(x, a) { return( log((x + sqrt(x^2 + a^2)) / 2)) }
#
#
# LogLin <- function(x, a) {
#   # log-linear hybrid transformation
#   # introduced by Rocke and Durbin (2003)
#   x[x<=a] <- x[x<=a] / a + log(a) - 1
#   x[x>a] <- log(x[x>a])
#
#   return(x)
# }


Logit <- function(x, min=0, max=1) {

  # variant in boot:::logit - CHECKME if better ********
  p <- (x-min)/(max-min)
  log(p/(1-p))
}


LogitInv <- function(x, min=0, max=1) {

    p <- exp(x)/(1+exp(x))
    p <- ifelse( is.na(p) & !is.na(x), 1, p ) # fix problems with +Inf
    p * (max-min) + min
}



# from library(forecast)

BoxCox <- function (x, lambda) {

# Author: Rob J Hyndman
# origin: library(forecast)
    if (lambda < 0)
        x[x < 0] <- NA
    if (lambda == 0)
        out <- log(x)
    else out <- (sign(x) * abs(x)^lambda - 1)/lambda
    if (!is.null(colnames(x)))
        colnames(out) <- colnames(x)
    return(out)

# Greg Snow's Variant
# BoxCox <- function (x, lambda)
# {
# ### Author: Greg Snow
# ### Source: Teaching Demos
# xx <- exp(mean(log(x)))
# if (lambda == 0)
# return(log(x) * xx)
# res <- (x^lambda - 1)/(lambda * xx^(lambda - 1))
# return(res)
# }

}


BoxCoxInv <- function(x, lambda){
    if (lambda < 0)
        x[x > -1/lambda] <- NA
    if (lambda == 0)
        out <- exp(x)
    else {
        xx <- x * lambda + 1
        out <- sign(xx) * abs(xx)^(1/lambda)
    }
    if (!is.null(colnames(x)))
        colnames(out) <- colnames(x)
    return(out)
}


# This R script contains code for extracting the Box-Cox
# parameter, lambda, using Guerrero's method (1993).
# Written by Leanne Chhay

BoxCoxLambda <- function(x, method=c("guerrero","loglik"), lower=-1, upper=2) {

  # Guerrero extracts the required lambda
  # Input: x = original time series as a time series object
  # Output: lambda that minimises the coefficient of variation

  Guerrero <- function(x, lower=-1, upper=2, nonseasonal.length=2)  {

    # guer.cv computes the coefficient of variation
    # Input:
    #             lam = lambda
    #             x = original time series as a time series object
    # Output: coefficient of variation
    guer.cv <- function(lam, x, nonseasonal.length=2) {

      period <- max(nonseasonal.length, frequency(x))
      nobsf <- length(x)
      nyr <- floor(nobsf / period)
      nobst <- nyr * period
      x.mat <- matrix(x[(nobsf-nobst+1):nobsf], period, nyr)
      x.mean <- apply(x.mat, 2, mean, na.rm=TRUE)
      x.sd <- apply(x.mat, 2, sd, na.rm=TRUE)
      x.rat <- x.sd / x.mean^(1-lam)
      return(sd(x.rat, na.rm=TRUE)/mean(x.rat, na.rm=TRUE))
    }

    return(optimize(guer.cv, c(lower,upper), x=x,
              nonseasonal.length=nonseasonal.length)$minimum)
  }


  # Modified version of boxcox from MASS package
  BCLogLik <- function(x, lower=-1, upper=2) {

    n <- length(x)
    if (any(x <= 0))
      stop("x must be positive")
    logx <- log(x)
    xdot <- exp(mean(logx))
#    if(all(class(x)!="ts"))
      fit <- lm(x ~ 1, data=data.frame(x=x))
#     else if(frequency(x)>1)
#       fit <- tslm(x ~ trend + season, data=data.frame(x=x))
#     else
#       fit <- tslm(x ~ trend, data=data.frame(x=x))
    xqr <- fit$qr
    lambda <- seq(lower,upper,by=.05)
    xl <- loglik <- as.vector(lambda)
    m <- length(xl)
    for (i in 1L:m)
    {
      if (abs(la <- xl[i]) > 0.02)
        xt <- (x^la - 1)/la
      else
        xt <- logx * (1 + (la*logx)/2 * (1+(la*logx)/3*(1+(la*logx)/4)))
      loglik[i] <- -n/2 * log(sum(qr.resid(xqr, xt/xdot^(la-1))^2))
    }
    return(xl[which.max(loglik)])
  }


  if(any(x <= 0))
                lower <- 0
#   stop("All values must be positive")
  method <- match.arg(method)
  if(method=="loglik")
    return(BCLogLik(x,lower,upper))
  else
    return(Guerrero(x,lower,upper))
}




LOCF <- function(x) UseMethod("LOCF")


LOCF.default <- function(x) {

  # last observation carried forward
  # replaces NAs by the last observed value

#   while(any(is.na(x))) {
#     x[is.na(x)] <- x[which(is.na(x))-1]
#   }
#   return(x)

  # faster solution from Daniel Wollschlaeger:

  # corrected by 0.99.19, as this didn't handle c(NA, 3.0, NA, 5,5) correctly
  # rep(x[!is.na(x)], diff(c(which(!is.na(x)), length(x)+1)))

  l <- !is.na(x)
  rep(c(NA, x[l]), diff(c(1L, which(l), length(x) + 1L)))

}

LOCF.data.frame <- function(x){
  as.data.frame(lapply(x, LOCF))
}

LOCF.matrix <- function(x){
  apply(x, 2L, LOCF)
}


# Alternative names: PairApply, PwApply, pwapply, papply, ...
PairApply <- function(x, FUN = NULL, ..., symmetric = FALSE){

  if(is.function(FUN)) {
    # if FUN is a function, then save it under new name and
    # overwrite function name in FUN, which has to be character
    fct <- FUN
    FUN <- "fct"
  }

  if(is.matrix(x)) x <- as.data.frame(x)
  x <- as.list(x)

  ix <- 1:length(x)
  # pairwise logic from pairwise.table
  pp <- outer(ix, ix, function(ivec, jvec) sapply(seq_along(ivec),
                                                  function(k) {
                                                    i <- ivec[[k]]
                                                    j <- jvec[[k]]
                                                    if (i >= j)
                                                      eval(parse(text = gettextf("%s(x[[i]], x[[j]], ...)", FUN)))
                                                    else NA
                                                  }))
  # why did we need that? in any case it's wrong, if no symmetric calcs are done
  # diag(pp) <- 1
  if(symmetric){
    pp[upper.tri(pp)] <- t(pp)[upper.tri(t(pp))]
  } else {
    pp.upr <- outer(ix, ix, function(ivec, jvec) sapply(seq_along(ivec),
                                                        function(k) {
                                                          i <- ivec[[k]]
                                                          j <- jvec[[k]]
                                                          if (i >= j)
                                                            eval(parse(text = gettextf("%s(x[[j]], x[[i]], ...)", FUN)))
                                                          else NA
                                                        }))
    pp[upper.tri(pp)] <- t(pp.upr)[upper.tri(pp.upr)]

  }

  dimnames(pp) <- list(names(x),names(x))

  return(pp)
}




###

## base: date functions  ====

# fastPOSIXct <- function(x, tz=NULL, required.components = 3L)
#   .POSIXct(if (is.character(x)) .Call("parse_ts", x, required.components) else .Call("parse_ts", as.character(x), required.components), tz)


HmsToSec <- function(x) {

  hms <- as.character(x)
  z <- sapply(data.frame(do.call(rbind, strsplit(hms, ":"))),
              function(x) { as.numeric(as.character(x)) })
  z[,1] * 3600 + z[,2] * 60 + z[,3]
}



SecToHms <- function(x, digits=NULL) {

  x <- as.numeric(x)

  h <- floor(x/3600)
  m <- floor((x-h*3600)/60)
  s <- floor(x-(m*60 + h*3600))
  b <- x-(s + m*60 + h*3600)

  if(is.null(digits)) digits <- ifelse(all(b < sqrt(.Machine$double.eps)),0, 2)
  if(digits==0) f <- "" else f <- gettextf(paste(".%0", digits, "d", sep=""), round(b*10^digits, 0))

  gettextf("%02d:%02d:%02d%s", h, m, s, f)

}



IsDate <- function(x, what=c('either','both','timeVaries')) {

  what <- match.arg(what)
  cl <- class(x) # was oldClass 22jun03
  if(!length(cl)) return(FALSE)

  dc <- c('POSIXt','POSIXct','dates','times','chron','Date')
  dtc <- c('POSIXt','POSIXct','chron')
  switch(what,
    either = any(cl %in% dc),
    both = any(cl %in% dtc),
    timeVaries = {
      # original: if('chron' %in% cl || !.R.) { ### chron or S+ timeDate
      if('chron' %in% cl) { # chron ok, but who cares about S+?
        y <- as.numeric(x)
        length(unique(round(y - floor(y), 13L))) > 1
      } else {
        length(unique(format(x, '%H%M%S'))) > 1
      }
    }
  )

}


IsWeekend <- function(x) {
  x <- as.POSIXlt(x)
  x$wday > 5L | x$wday < 1L
}


# This is not useful anymore. Use: as.Date(ISODate())
# Date <- function(year, month = NA, day = NA) {
#   if(is.na(month) && is.na(day)) {
#     # try to interpret year as yearmonthday yyyymmdd
#     res <- as.Date(ISOdate(year %/% 10000, (year %% 10000) %/% 100, (year %% 100)))
#   } else {
#     res <- as.Date(ISOdate(year, month, day))
#   }
#   return(res)
# }


# Year <- function(x){ as.integer( format(as.Date(x), "%Y") ) }
Year <- function(x){ as.POSIXlt(x)$year + 1900L }


IsLeapYear <- function(x){
  if(!IsWhole(x))
    x <- Year(as.Date(x))
  ifelse(x %% 100L == 0L, x %% 400L == 0L, x %% 4L == 0L)
}


Month <- function (x, fmt = c("m", "mm", "mmm"), lang = DescToolsOptions("lang"), stringsAsFactors = TRUE) {

  res <- as.POSIXlt(x)$mon + 1L

  switch(match.arg(arg = fmt, choices = c("m", "mm", "mmm")),
         m = { res },
         mm = {
           # res <- as.integer(format(x, "%m"))
           switch(match.arg(arg = lang, choices = c("local", "engl")),
             local = {
               # months in current locale:  format(ISOdate(2000, 1:12, 1), "%b")
               res <- factor(res, levels=1L:12L, labels=format(ISOdate(2000L, 1L:12L, 1L), "%b"))
               },
             engl = {
               res <- factor(res, levels=1L:12L, labels=month.abb)
             })
           if(!stringsAsFactors) res <- as.character(res)
         },
         mmm = {
           # res <- as.integer(format(x, "%m"))
           switch(match.arg(arg = lang, choices = c("local", "engl")),
                  local = {
                    # months in current locale:  format(ISOdate(2000, 1:12, 1), "%b")
                    res <- factor(res, levels=1L:12L, labels=format(ISOdate(2000L, 1L:12L, 1L), "%B"))
                  },
                  engl = {
                    res <- factor(res, levels=1L:12L, labels=month.name)
                  })
           if(!stringsAsFactors) res <- as.character(res)
         })
  return(res)
}


Week <- function(x, method = c("iso", "us")){

  # cast x to date, such as being able to handle POSIX-Dates automatically
  x <- as.Date(x)

  method <- match.arg(method, c("iso", "us"))
  switch(method,
    "iso" = {

#??? fast implementation in lubridate:

#       xday <- ISOdate(year(x), month(x), day(x), tz = tz(x))
#       dn <- 1 + (wday(x) + 5)%%7
#       nth <- xday + ddays(4 - dn)
#       jan1 <- ISOdate(year(nth), 1, 1, tz = tz(x))
#       1 + (nth - jan1)%/%ddays(7)


      # The weeknumber is the number of weeks between the
      # first thursday of the year and the thursday in the target week
      # der Donnerstag in der Zielwoche
#       x.y <- Year(x)
#       x.weekday <- Weekday(x)
#
#       x.thursday <- (x - x.weekday + 4)
#       # der erste Donnerstag des Jahres
#       jan1.weekday <- Weekday(as.Date(paste(x.y, "01-01", sep="-")))
#       first.thursday <- as.Date(paste(x.y, "01", (5 + 7*(jan1.weekday > 4) - jan1.weekday), sep="-"))
#
#       wn <- (as.integer(x.thursday - first.thursday) %/% 7) + 1 - ((x.weekday < 4) & (Year(x.thursday) != Year(first.thursday)))*52
#       wn <- ifelse(wn == 0, Week(as.Date(paste(x.y-1, "12-31", sep="-"))), wn)

      z <- x + (3 - (as.POSIXlt(x)$wday + 6) %% 7)
      jan1 <- as.Date(paste(Year(z), "-01-01", sep=""))

      wn <- 1 + as.integer(z - jan1) %/% 7

    },
    "us"={
      wn <- as.numeric(strftime(as.POSIXlt(x), format="%W"))
    }
  )
  return(wn)

}


# Day <- function(x){ as.integer(format(as.Date(x), "%d") ) }
Day <- function(x){ as.POSIXlt(x)$mday }


# Accessor for Day, as defined by library(lubridate)
"Day<-" <- function(x, value) { x <- x + (value - Day(x)) }

Weekday <- function (x, fmt = c("d", "dd", "ddd"), lang = DescToolsOptions("lang"), stringsAsFactors = TRUE) {

  # x <- as.Date(x)
  res <- as.POSIXlt(x)$wday
  res <- replace(res, res==0, 7)

  switch(match.arg(arg = fmt, choices = c("d", "dd", "ddd")),
         d = { res },
         dd = {
           # weekdays in current locale, Sunday : Saturday, format(ISOdate(2000, 1, 2:8), "%A")
           switch(match.arg(arg = lang, choices = c("local", "engl")),
                  local = {
                    # months in current locale:  format(ISOdate(2000, 1:12, 1), "%b")
                    res <- factor(res, levels=1:7, labels=format(ISOdate(2000, 1, 3:9), "%a"))
                  },
                  engl = {
                    res <- factor(res, levels=1:7, labels=day.abb)
                  })
           if(!stringsAsFactors) res <- as.character(res)
         },
         ddd = {
           # weekdays in current locale, Sunday : Saturday, format(ISOdate(2000, 1, 2:8), "%A")
           switch(match.arg(arg = lang, choices = c("local", "engl")),
                  local = {
                    # months in current locale:  format(ISOdate(2000, 1:12, 1), "%b")
                    res <- factor(res, levels=1:7, labels=format(ISOdate(2000, 1, 3:9), "%A"))
                  },
                  engl = {
                    res <- factor(res, levels=1:7, labels=day.name)
                  })
           if(!stringsAsFactors) res <- as.character(res)
         })
  return(res)
}



CountWorkDays <- function(from, to, 
                     holiday=NULL, nonworkdays=c("Sat","Sun")) {
  
  
  .workDays <- function(from, to, 
                        holiday=NULL, nonworkdays=c("Sat","Sun")) {
    d <- as.integer(to - from)
    w <- (d %/% 7)
    
    res <- w * (7-length(nonworkdays)) + 
      sum(Weekday(seq(from + w*7,  to, 1), fmt="dd", lang="engl") %nin% nonworkdays)
    
    if(!is.null(holiday)){
      # count holidays in period
      h <- holiday[holiday %[]% c(from, to)]
      res <- res - sum(Weekday(h, fmt="dd", lang="engl") %nin% nonworkdays)
    }
    
    return(res)
    
  }
  
  
  ll <- Recycle(from=from, to=to)  
  
  res <- integer(attr(ll, "maxdim"))
  for(i in 1:attr(ll, "maxdim"))
    res[i] <- .workDays(ll$from[i], ll$to[i], holiday=holiday, nonworkdays=nonworkdays) 
  
  return(res)
  
}



Quarter <- function (x) {
  # Berechnet das Quartal eines Datums
  # y <- as.numeric( format( x, "%Y") )
  # paste(y, "Q", (as.POSIXlt(x)$mon)%/%3 + 1, sep = "")
  # old definition is counterintuitive...
  return((as.POSIXlt(x)$mon) %/% 3L + 1L)
}

YearDay <- function(x) {
  # return(as.integer(format(as.Date(x), "%j")))
  
  # As ?POSIXlt reveals, a $yday suffix to a POSIXlt date (or even a vector of such) 
  # will convert to day of year. 
  # Beware that POSIX counts Jan 1 as day 0, so you might want to add 1 to the result.
  return(as.POSIXlt(x)$yday + 1L)
}


YearMonth <- function(x){
  # returns the yearmonth representation of a date x
  x <- as.POSIXlt(x)
  return((x$year + 1900L)*100L + x$mon + 1L)
}


Today <- function() Sys.Date()

Now <- function() Sys.time()

Hour <- function(x) {
  # strptime(x, "%H")
  as.POSIXlt(x)$hour
}

Minute <- function(x) {
#  strptime(x, "%M")
  as.POSIXlt(x)$min
}

Second <- function(x) {
#  strptime(x, "%S")
  as.POSIXlt(x)$sec
}

Timezone <- function(x) {
  as.POSIXlt(x)$zone
}


DiffDays360 <- function(start_d, end_d, method=c("eu","us")){

  # source: http://en.wikipedia.org/wiki/360-day_calendar
  start_d <- as.Date(start_d)
  end_d <- as.Date(end_d)

  d1 <- Day(start_d)
  m1 <- Month(start_d)
  y1 <- Year(start_d)
  d2 <- Day(end_d)
  m2 <- Month(end_d)
  y2 <- Year(end_d)

  method = match.arg(method)
  switch(method,
    "eu" = {
      if(Day(start_d)==31L) start_d <- start_d-1L
      if(Day(end_d)==31L) end_d <- end_d-1L
    }
    , "us" ={
      if( (Day(start_d+1L)==1L & Month(start_d+1L)==3L) &
            (Day(end_d+1L)==1L & Month(end_d+1L)==3L)) d2 <- 30L
      if( d1==31L ||
            (Day(start_d+1L)==1L & Month(start_d+1L)==3L)) {
          d1 <- 30L
          if(d2==31L) d2 <- 30L
      }

    }
  )

  return( (y2-y1)*360L + (m2-m1)*30L + d2-d1)

}


LastDayOfMonth <- function(x){
  z <- AddMonths(x, 1L)
  Day(z) <- 1L
  return(z - 1L)
}



YearDays <- function (x) {
  x <- as.POSIXlt(x)
  x$mon[] <- x$mday[] <- x$sec[] <- x$min <- x$hour <- 0
  x$year <- x$year + 1
  return(as.POSIXlt(as.POSIXct(x))$yday + 1)
}


MonthDays <- function (x) {
  x <- as.POSIXlt(x)
  x$mday[] <- x$sec[] <- x$min <- x$hour <- 0
  x$mon <- x$mon + 1
  return(as.POSIXlt(as.POSIXct(x))$mday)
}


AddMonths <- function (x, n, ...) {

  .addMonths <- function (x, n) {

    # ref: http://stackoverflow.com/questions/14169620/add-a-month-to-a-date
    # Author: Antonio

    # no ceiling
    res <- sapply(x, seq, by = paste(n, "months"), length = 2L)[2L,]
    # sapply kills the Date class, so recreate down the road

    # ceiling
    DescTools::Day(x) <- 1L
    res_c <- sapply(x, seq, by = paste(n + 1L, "months"), length = 2L)[2L,] - 1L

    # use ceiling in case of overlapping
    res <- pmin(res, res_c)

    return(res)

  }

  x <- as.Date(x, ...)

  res <- mapply(.addMonths, x, n)
  # mapply (as sapply above) kills the Date class, so recreate here
  # and return res in the same class as x
  class(res) <- "Date"

  return(res)

}



AddMonthsYM <- function (x, n) {

  .addMonths <- function (x, n) {

    if (x %[]% c(100001L, 999912L)) {

      # Author: Roland Rapold
      # YYYYMM
      y <- x %/% 100L
      m <- x - y * 100L
      res <- (y - 10L + ((m + n + 120L - 1L) %/% 12L)) * 100L +
        ((m + n + 120L - 1L) %% 12L) + 1L

    } else if (x %[]% c(10000101L, 99991231L)) {

      # YYYYMMDD
      res <- DescTools::AddMonths(x = as.Date(as.character(x), "%Y%m%d"), n = n)
      res <- DescTools::Year(res)*10000L + DescTools::Month(res)*100L + Day(res)
    }

    return(res)

  }

  res <- mapply(.addMonths, x, n)

  return(res)

}



Zodiac <- function(x, lang = c("engl","deu"), stringsAsFactors = TRUE) {

  switch(match.arg(lang, choices=c("engl","deu"))
    , engl = {z <- c("Capricorn","Aquarius","Pisces","Aries","Taurus","Gemini","Cancer","Leo","Virgo","Libra","Scorpio","Sagittarius","Capricorn") }
    , deu =  {z <- c("Steinbock","Wassermann","Fische","Widder","Stier","Zwillinge","Krebs","Loewe","Jungfrau","Waage","Skorpion","Schuetze","Steinbock") }
  )

  # i <- cut(DescTools::Month(x)*100 + DescTools::Day(x),
  #          breaks=c(0,120,218,320,420,520,621,722,822,923,1023,1122,1221,1231))
  i <- cut(DescTools::Month(x) * 100 + DescTools::Day(x), 
           breaks = c(0,120,218,320,420,520,621,722,823,922,1023,1122,1222,1231), 
           right=FALSE, include.lowest = TRUE)
  
  if(stringsAsFactors){
    res <- i
    levels(res) <- z
  } else {
    res <- z[i]
  }
  return(res)
}


axTicks.POSIXct <- function (side, x, at, format, labels = TRUE, ...) {

  # This is completely original R-code with one exception:
  # Not an axis is drawn but z are returned.

  mat <- missing(at) || is.null(at)
  if (!mat)
    x <- as.POSIXct(at)
  else x <- as.POSIXct(x)
  range <- par("usr")[if (side %% 2L)
    1L:2L
    else 3L:4L]
  d <- range[2L] - range[1L]
  z <- c(range, x[is.finite(x)])
  attr(z, "tzone") <- attr(x, "tzone")
  if (d < 1.1 * 60) {
    sc <- 1
    if (missing(format))
      format <- "%S"
  }
  else if (d < 1.1 * 60 * 60) {
    sc <- 60
    if (missing(format))
      format <- "%M:%S"
  }
  else if (d < 1.1 * 60 * 60 * 24) {
    sc <- 60 * 60
    if (missing(format))
      format <- "%H:%M"
  }
  else if (d < 2 * 60 * 60 * 24) {
    sc <- 60 * 60
    if (missing(format))
      format <- "%a %H:%M"
  }
  else if (d < 7 * 60 * 60 * 24) {
    sc <- 60 * 60 * 24
    if (missing(format))
      format <- "%a"
  }
  else {
    sc <- 60 * 60 * 24
  }
  if (d < 60 * 60 * 24 * 50) {
    zz <- pretty(z/sc)
    z <- zz * sc
    z <- .POSIXct(z, attr(x, "tzone"))
    if (sc == 60 * 60 * 24)
      z <- as.POSIXct(round(z, "days"))
    if (missing(format))
      format <- "%b %d"
  }
  else if (d < 1.1 * 60 * 60 * 24 * 365) {
    z <- .POSIXct(z, attr(x, "tzone"))
    zz <- as.POSIXlt(z)
    zz$mday <- zz$wday <- zz$yday <- 1
    zz$isdst <- -1
    zz$hour <- zz$min <- zz$sec <- 0
    zz$mon <- pretty(zz$mon)
    m <- length(zz$mon)
    M <- 2 * m
    m <- rep.int(zz$year[1L], m)
    zz$year <- c(m, m + 1)
    zz <- lapply(zz, function(x) rep(x, length.out = M))
    zz <- .POSIXlt(zz, attr(x, "tzone"))
    z <- as.POSIXct(zz)
    if (missing(format))
      format <- "%b"
  }
  else {
    z <- .POSIXct(z, attr(x, "tzone"))
    zz <- as.POSIXlt(z)
    zz$mday <- zz$wday <- zz$yday <- 1
    zz$isdst <- -1
    zz$mon <- zz$hour <- zz$min <- zz$sec <- 0
    zz$year <- pretty(zz$year)
    M <- length(zz$year)
    zz <- lapply(zz, function(x) rep(x, length.out = M))
    z <- as.POSIXct(.POSIXlt(zz))
    if (missing(format))
      format <- "%Y"
  }
  if (!mat)
    z <- x[is.finite(x)]
  keep <- z >= range[1L] & z <= range[2L]
  z <- z[keep]
  if (!is.logical(labels))
    labels <- labels[keep]
  else if (identical(labels, TRUE))
    labels <- format(z, format = format)
  else if (identical(labels, FALSE))
    labels <- rep("", length(z))

  # axis(side, at = z, labels = labels, ...)
  # return(list(at=z, labels=labels))
  return(z)
}



axTicks.Date <- function(side = 1, x, ...) {
  ##  This functions is almost a copy of axis.Date
  x <- as.Date(x)
  range <- par("usr")[if (side%%2)
    1L:2L
    else 3:4L]
  range[1L] <- ceiling(range[1L])
  range[2L] <- floor(range[2L])
  d <- range[2L] - range[1L]
  z <- c(range, x[is.finite(x)])
  class(z) <- "Date"
  if (d < 7)
    format <- "%a"
  if (d < 100) {
    z <- structure(pretty(z), class = "Date")
    format <- "%b %d"
  }
  else if (d < 1.1 * 365) {
    zz <- as.POSIXlt(z)
    zz$mday <- 1
    zz$mon <- pretty(zz$mon)
    m <- length(zz$mon)
    m <- rep.int(zz$year[1L], m)
    zz$year <- c(m, m + 1)
    z <- as.Date(zz)
    format <- "%b"
  }
  else {
    zz <- as.POSIXlt(z)
    zz$mday <- 1
    zz$mon <- 0
    zz$year <- pretty(zz$year)
    z <- as.Date(zz)
    format <- "%Y"
  }
  keep <- z >= range[1L] & z <= range[2L]
  z <- z[keep]
  z <- sort(unique(z))
  class(z) <- "Date"
  z
}



###

## base: information functions ====


# Between operators

`%[]%` <- function(x, rng) {

  if(is.matrix(rng)){
    # recycle things
    # which parameter has the highest dimension
    maxdim <- max(length(x), nrow(rng))
    # recycle all params to maxdim
    x <- rep(x, length.out = maxdim)
    # the rows of the matrix rng
    rng <- rng[rep(1:nrow(rng), length.out = maxdim),]

    res <- .Call("between_num_lrm", as.numeric(x), 
                 as.numeric(rng[, 1L]), as.numeric(rng[, 2L]), PACKAGE="DescTools")
    res[is.na(x)] <- NA

    return( res )

  }

  if(is.numeric(x) || IsDate(x)) {
    # as.numeric still needed for casting integer to numeric!!
    res <- .Call("between_num_lr", as.numeric(x), as.numeric(rng[1]), as.numeric(rng[2]), PACKAGE="DescTools")
    res[is.na(x)] <- NA
  } else if(is.ordered(x)) {
    res <- .Call("between_num_lr", as.numeric(x), 
                 as.numeric(match(rng[1L], levels(x))), 
                 as.numeric(match(rng[2L], levels(x))), PACKAGE="DescTools")
    res[is.na(x)] <- NA
  }  else if(class(x) == "character")  {
    res <- ifelse ( x >= rng[1L] & x <= rng[2L], TRUE, FALSE )
  } else {
    res <- rep(NA, length(x))
  }
  return(res)
}


`%(]%` <- function(x, rng) {

  if(is.matrix(rng)){
    # recycle things
    # which parameter has the highest dimension
    maxdim <- max(length(x), nrow(rng))
    # recycle all params to maxdim
    x <- rep(x, length.out = maxdim)
    # the rows of the matrix rng
    rng <- rng[rep(1L:nrow(rng), length.out = maxdim),]

    res <- .Call("between_num_rm", as.numeric(x), 
                 as.numeric(rng[, 1L]), as.numeric(rng[, 2L]), PACKAGE="DescTools")
    res[is.na(x)] <- NA

    return( res)

  }

  if(is.numeric(x) || IsDate(x)) {
    # as.numeric still needed for casting integer to numeric!!
    res <- .Call("between_num_r", as.numeric(x), as.numeric(rng[1L]), as.numeric(rng[2L]), PACKAGE="DescTools")
    res[is.na(x)] <- NA
  } else if(is.ordered(x)) {
    res <- .Call("between_num_r", as.numeric(x), 
                 as.numeric(match(rng[1L], levels(x))), 
                 as.numeric(match(rng[2L], levels(x))), PACKAGE="DescTools")
    res[is.na(x)] <- NA
  }  else if(class(x) == "character")  {
    res <- ifelse ( x > rng[1L] & x <= rng[2L], TRUE, FALSE )
  } else {
    res <- rep(NA, length(x))
  }
  return(res)
}

`%[)%` <- function(x, rng) {

  if(is.matrix(rng)){
    # recycle things
    # which parameter has the highest dimension
    maxdim <- max(length(x), nrow(rng))
    # recycle all params to maxdim
    x <- rep(x, length.out = maxdim)
    # the rows of the matrix rng
    rng <- rng[rep(1L:nrow(rng), length.out = maxdim),]

    res <- .Call("between_num_lm", as.numeric(x), 
                 as.numeric(rng[,1L]), as.numeric(rng[,2L]), PACKAGE="DescTools")
    res[is.na(x)] <- NA

    return( res)

  }

  if(is.numeric(x) || IsDate(x)) {
    # as.numeric still needed for casting integer to numeric!!
    res <- .Call("between_num_l", as.numeric(x), 
                 as.numeric(rng[1L]), as.numeric(rng[2L]), PACKAGE="DescTools")
    res[is.na(x)] <- NA
  } else if(is.ordered(x)) {
    res <- .Call("between_num_l", as.numeric(x), 
                 as.numeric(match(rng[1L], levels(x))), 
                 as.numeric(match(rng[2L], levels(x))), PACKAGE="DescTools")
    res[is.na(x)] <- NA
  }  else if(class(x) == "character")  {
    res <- ifelse ( x >= rng[1L] & x < rng[2L], TRUE, FALSE )
  } else {
    res <- rep(NA, length(x))
  }
  return(res)
}


`%()%` <- function(x, rng) {

  if(is.matrix(rng)){
    # recycle things
    # which parameter has the highest dimension
    maxdim <- max(length(x), nrow(rng))
    # recycle all params to maxdim
    x <- rep(x, length.out = maxdim)
    # the rows of the matrix rng
    rng <- rng[rep(1L:nrow(rng), length.out = maxdim),]

    res <- .Call("between_num_m", as.numeric(x), 
                 as.numeric(rng[,1L]), as.numeric(rng[,2L]), PACKAGE="DescTools")
    res[is.na(x)] <- NA

    return( res)

  }


  if(is.numeric(x) || IsDate(x)) {
    # as.numeric still needed for casting integer to numeric!!
    res <- .Call("between_num_", as.numeric(x), 
                 as.numeric(rng[1L]), as.numeric(rng[2L]), PACKAGE="DescTools")
    res[is.na(x)] <- NA
  } else if(is.ordered(x)) {
    res <- .Call("between_num_", as.numeric(x), 
                 as.numeric(match(rng[1L], levels(x))), 
                 as.numeric(match(rng[2L], levels(x))), PACKAGE="DescTools")
    res[is.na(x)] <- NA
  }  else if(class(x) == "character")  {
    res <- ifelse ( x > rng[1L] & x < rng[2L], TRUE, FALSE )
  } else {
    res <- rep(NA, length(x))
  }
  return(res)
}


# outside operators (not exactly the negations)

`%][%` <- function(x, rng) {
  return(!(x %()% rng))
}

`%](%` <- function(x, rng) {
  return(!(x %(]% rng))
}

`%)[%` <- function(x, rng) {
  return(!(x %[)% rng))
}

`%)(%` <- function(x, rng) {
  return(!(x %[]% rng))
}




# lazy: takes the first matches
`%:%` <- function(x, rng){
  i <- match(x, rng, nomatch = 0)
  from <- ifelse(length(from <- which(i==1))==0, 1, from)[1]
  to <- ifelse(length(to <- which(i==2))==0, length(x), to)[1]

  # why the NA here???  
  # if(from==1 & to==length(x))
  #   NA
  # else
  
  x[from:to]
  
}


# greedy: takes the first and the last
`%::%` <- function(x, rng){
  i <- match(x, rng, nomatch = 0)
  from <- ifelse(length(from <- which(i==1))==0, 1, from)[1]
  to <- ifelse(length(to <- which(i==2))==0, length(x), tail(to, 1))[1]
  
  # why the NA here???  
  # if(from==1 & to==length(x))
  #   NA
  # else
  
  x[from:to]
  
}





# Not %in% operator
`%nin%` <- function(x, table) match(x, table, nomatch = 0) == 0


# quick paste operator
# Core (Chambers) does not recommend + for non commutative operators, but still it's convenient and so we use c
# is it really? I doubt meanwhile...
# https://www.stat.math.ethz.ch/pipermail/r-devel/2006-August/039013.html
# http://stackoverflow.com/questions/1319698/why-doesnt-operate-on-characters-in-r?lq=1

`%c%` <- function(x, y) paste(x, y, sep="")



`%like%` <- function(x, pattern) {
  return(`%like any%`(x, pattern))
}


`%like any%` <- function(x, pattern) {

  pattern <- sapply(pattern, function(z){
    if (!substr(z, 1L, 1L) == "%") {
      z <- paste("^", z, sep="")
    } else {
      z <- substr(z, 2L, nchar(z) )
    }
    if (!substr(z, nchar(z), nchar(z)) == "%") {
      z <- paste(z, "$", sep="")
    } else {
      z <- substr(z, 1L, nchar(z)-1L )
    }
    return(z)
  })

  grepl(pattern=paste(pattern, collapse = "|"), x=x)

  # since 0.99.17: better returning the values, than a logical vector:
  # grep(pattern=paste(pattern, collapse = "|"), x=x, value=TRUE)

  # rolled back 26.4.2016: did not really prove successful

}





# c(Date(2012,1,3), Date(2012,2,3)) %overlaps% c(Date(2012,3,1), Date(2012,3,3))
# c(Date(2012,1,3), Date(2012,2,3)) %overlaps% c(Date(2012,1,15), Date(2012,1,21))
# Date(2012,1,3) %overlaps% c(Date(2012,3,1), Date(2012,3,3))
# c(1, 18) %overlaps% c(10, 45)


# Interval <- function(xp, yp){
#   # calculates the number of days of the overlapping part of two date periods
#   length(intersect(xp[1]:xp[2], yp[1]:yp[2]))
# }


Interval <- function(x, y){

  # make sure that min is left and max right
  x <- cbind(apply(rbind(x), 1L, min), apply(rbind(x), 1L, max))
  y <- cbind(apply(rbind(y), 1L, min), apply(rbind(y), 1L, max))

  # replicate
  maxdim <- max(nrow(x), nrow(y))
  x <- x[rep(1L:nrow(x), length.out=maxdim), , drop=FALSE]
  y <- y[rep(1L:nrow(y), length.out=maxdim), , drop=FALSE]

  d <- numeric(maxdim)
  idx <- y[, 1L] > x[, 2L]
  d[idx] <- (y[idx, 1L] - x[idx, 2L])
  idx <-