R/DescTools.r

Defines functions PlotACF PlotMatrix PlotCandlestick PlotWeb PlotCirc PlotTreemap PlotMiss PlotVenn PlotTernary PolarGrid PlotPolar PlotViolin.formula PlotViolin.default PlotViolin PlotCorr PlotPyramid Shade PlotFun PlotLog PlotLinesA PlotFacet TitleRect PlotDot PlotArea.formula PlotArea.default PlotArea PlotMarDens PlotMultiDens.default PlotMultiDens.formula PlotMultiDens PlotECDF PlotFdist PlotBubble.formula PlotBubble.default PlotBubble PlotDev SetAlpha FindColor MixColor TextContrastColor ColToGray ColToGrey ColToHsv ColToRgb LongToRgb RgbToLong RgbToCol HexToCol HexToRgb ColToHex SphToCart CartToSph CartToPol PolToCart AxisBreak ConnLines BarText SpreadOut Arrow LineToUser Asp GeomTrans Rotate Clockwise DrawBand DrawArc DrawEllipse DrawCircle DrawRegPolygon DrawBezier BoxedText Stamp plot.palette print.palette Pal Midx Canvas BubbleLegend ColorLegend ErrBars SmoothSpline.formula SmoothSpline.default SmoothSpline lines.lm lines.smooth.spline lines.SmoothSpline lines.loess Xplore Mar PlotMar ColPicker PlotPch PlotPar split.formula identify.formula PtInPoly IdentifyA.default IdentifyA.formula IdentifyA ChooseColorDlg PasswordDlg ImportFileDlg ImportStataDlg ImportSYSTAT ImportSPSS InitDlg FileOpenCmd SelectVarDlg.data.frame SelectVarDlg.factor SelectVarDlg.numeric SelectVarDlg.default ToClipboard SelectVarDlg SaveAsDlg FixToTab Untable.default Untable.data.frame Untable Rev.data.frame Rev.matrix Rev.table Rev.default Rev Sort.table Sort.matrix Sort.data.frame Sort.default Sort Unit Label Rename InsCol InsRow SetNames ParseSASDatalines as.fmt fmt DescToolsOptions FindRProfile SysInfo Keywords FctArgs InDots YTM NPVFixBond OPR IRR NPV RndWord RndPairs rRevGumbel qRevGumbelExp qRevGumbel pRevGumbel dRevGumbel qBenf pBenf rBenf dBenf SampleTwins Strata Recycle MaxDigits Frac print.fmt Fmt print.Format Format.default as.CDateFmt Format.table Format.matrix Format.data.frame Format Prec Ndec CaptOut CatTable ToWide ToLong Abind PDFManual LsObj LsFct Some.default Some.matrix Some.data.frame Some Str RoundTo VecShift VecRot IsPrime StrIsNumeric IsDichotomous IsOdd IsNumeric IsZero IsWhole PartitionBy Coalesce Dummy AllDuplicated Overlap Interval axTicks.Date axTicks.POSIXct Zodiac AddMonthsYM AddMonths LastDayOfMonth DiffDays360 Timezone Second Minute Hour Now Today YearMonth YearDay Quarter Weekday Day Week Month IsLeapYear Year IsWeekend IsDate SecToHms HmsToSec PairApply LOCF.matrix LOCF.data.frame LOCF.default LOCF BoxCoxLambda BoxCoxInv BoxCox LogitInv Logit LogStInv LogSt Lookup OrderMixed SortMixed reorder.factor Impute ZeroIfNA Recode TextToTable as.matrix.xtabs DoCall UnitConv RadToDeg DegToRad RomanToInt DecToBin BinToDec DecToOct OctToDec DecToHex HexToDec HWZdata PpPlot PpText PpAddSlide GetCurrPP GetNewPP XLDateToPOSIXct XLKill XLGetWorkbook XLGetRange XLView GetCurrXL GetNewXL Phrase WrdTable WrdPlot PointsToCentimeters CentimetersToPoints WrdUpdateBookmark WrdInsertBookmark WrdGoto IsValidWrd WrdStyle WrdParagraphFormat WrdFont WrdFormatCells WrdMergeCells WrdCellRange WrdTableBorders ToWrd.table ToWrd.ftable ToWrd.Freq ToWrd.matrix ToWrd.data.frame ToWrd.PercTable WrdCaption ToWrd.character ToWrd.lm ToWrd.abstract ToWrd.TOne ToWrd.default ToWrd WrdPrepRep WrdKill GetNewWrd GetCurrWrd createCOMReference ParseFormula PlotMosaic Flags print.TOne FootNote TOne PlotQQ PlotMonth PlotGACF AscToChar CharToAsc SplitPath StrPos StrVal StrCountW StrChop StrAlign StrPad StrRev StrDist StrCap StrAbbr StrTrunc StrExtract StrLeft StrRight StrTrim CombLevels Unwhich PercentRank DenseRank Closest HighLow Small Large LinScale MoveAvg RobScale Trim Winsorize Vigenere Fibonacci CombPairs CombSet Permn CombN DigitSum LCM GCD Factorize Primes

Documented in Abind AddMonths AddMonthsYM AllDuplicated Arrow as.CDateFmt AscToChar as.fmt as.matrix.xtabs Asp AxisBreak axTicks.Date axTicks.POSIXct BarText BinToDec BoxCox BoxCoxInv BoxCoxLambda BoxedText BubbleLegend Canvas CartToPol CartToSph CatTable CharToAsc ChooseColorDlg Clockwise Closest Coalesce ColorLegend ColPicker ColToGray ColToGrey ColToHex ColToHsv ColToRgb CombN CombPairs CombSet ConnLines createCOMReference Day dBenf DecToBin DecToHex DecToOct DegToRad DenseRank DescToolsOptions DiffDays360 DigitSum DoCall DrawArc DrawBand DrawBezier DrawCircle DrawEllipse DrawRegPolygon dRevGumbel Dummy ErrBars Factorize FctArgs Fibonacci FileOpenCmd FindColor FindRProfile FixToTab Flags Fmt Format Format.default Format.matrix Format.table Frac GCD GeomTrans GetCurrPP GetCurrWrd GetCurrXL GetNewPP GetNewWrd GetNewXL HexToCol HexToDec HexToRgb HighLow HmsToSec Hour HWZdata IdentifyA IdentifyA.default IdentifyA.formula identify.formula ImportFileDlg Impute InDots InsCol InsRow Interval IRR IsDate IsDichotomous IsLeapYear IsNumeric IsOdd IsPrime IsValidWrd IsWeekend IsWhole IsZero Keywords Label Large LastDayOfMonth LCM lines.lm lines.loess lines.smooth.spline lines.SmoothSpline LineToUser LinScale LOCF LOCF.data.frame LOCF.default LOCF.matrix Logit LogitInv LogSt LogStInv LongToRgb Lookup LsFct LsObj Mar MaxDigits Midx Minute MixColor Month MoveAvg Ndec Now NPV NPVFixBond OctToDec OPR OrderMixed Overlap PairApply Pal ParseFormula ParseSASDatalines PartitionBy PasswordDlg pBenf PDFManual PercentRank Permn Phrase PlotACF PlotArea PlotArea.default PlotArea.formula PlotBubble PlotBubble.default PlotBubble.formula PlotCandlestick PlotCirc PlotCorr PlotDev PlotDot PlotECDF PlotFdist PlotFun PlotGACF PlotLinesA PlotLog PlotMar PlotMarDens PlotMatrix PlotMiss PlotMonth PlotMosaic PlotMultiDens PlotMultiDens.default PlotMultiDens.formula plot.palette PlotPar PlotPch PlotPolar PlotPyramid PlotQQ PlotTernary PlotTreemap PlotVenn PlotViolin PlotViolin.default PlotViolin.formula PlotWeb PolarGrid PolToCart PpAddSlide PpPlot PpText Prec pRevGumbel Primes PtInPoly qBenf qRevGumbel qRevGumbelExp Quarter RadToDeg rBenf Recode Recycle Rename reorder.factor Rev Rev.data.frame Rev.default Rev.matrix Rev.table RgbToCol RgbToLong RndPairs RndWord RobScale RomanToInt Rotate RoundTo rRevGumbel SampleTwins SaveAsDlg Second SecToHms SelectVarDlg SelectVarDlg.data.frame SelectVarDlg.default SelectVarDlg.factor SetAlpha SetNames Shade Small SmoothSpline SmoothSpline.default SmoothSpline.formula Some Some.data.frame Some.default Some.matrix Sort Sort.data.frame Sort.default Sort.matrix SortMixed Sort.table SphToCart split.formula SplitPath SpreadOut Stamp Str StrAbbr StrAlign Strata StrCap StrChop StrCountW StrDist StrExtract StrIsNumeric StrLeft StrPad StrPos StrRev StrRight StrTrim StrTrunc StrVal SysInfo TextContrastColor TextToTable Timezone TitleRect Today ToLong TOne ToWide ToWrd ToWrd.character ToWrd.data.frame ToWrd.default ToWrd.Freq ToWrd.ftable ToWrd.lm ToWrd.table ToWrd.TOne Trim Unit UnitConv Untable Untable.data.frame Untable.default Unwhich VecRot VecShift Vigenere Week Weekday Winsorize WrdCaption WrdCellRange WrdFont WrdFormatCells WrdGoto WrdInsertBookmark WrdKill WrdMergeCells WrdParagraphFormat WrdPlot WrdStyle WrdTable WrdTableBorders WrdUpdateBookmark XLDateToPOSIXct XLGetRange XLGetWorkbook XLKill XLView Xplore 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



# **********  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",
                         "hblue","hred","hgreen", "fmt", "pal",
                         "tarot","cards","roulette"))



# 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


Primes <- function (n) {
# Source: sfsmisc
# Bill Venables (<= 2001); Martin Maechler gained another 40% speed, working with logicals and integers.
    if ((M2 <- max(n)) <= 1)
        return(integer(0))
    P <- rep.int(TRUE, M2)
    P[1] <- FALSE
    M <- as.integer(sqrt(M2))
    n <- as.integer(M2)
    for (p in 1:M) if (P[p])
        P[seq(p * p, n, p)] <- FALSE
    (1: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 == 0)
    res <- vector("list", length = N)
    names(res) <- n
    for (i in 1: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 = 1)
#            if (verbose) cat("direct prime", nn, "\n")
            next
        }
        m.pr <- rep(1, nP)
        Ppf <- prod(pfac)
        while (1 < (nn <- nn%/%Ppf)) {
            Dp <- nn%%pfac == 0
            if (any(Dp)) {
                m.pr[Dp] <- m.pr[Dp] + 1
                Ppf <- prod(pfac[Dp])
            }
            else {
                pfac <- c(pfac, nn)
                m.pr <- c(m.pr, 1)
                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 (floor(x) != ceiling(x) || length(x) < 2)
    stop("Argument 'x' must be an integer vector of length >= 2.")

  x <- x[x != 0]
  n <- length(x)
  if (n == 0) {
    g <- 0
  } else if (n == 1) {
    g <- x
  } else if (n == 2) {
    g <- .Call("_DescTools_compute_GCD", PACKAGE = "DescTools", x[1], x[2])
  } else {
    # g <- .GCD(x[1], x[2])
    g <- .Call("_DescTools_compute_GCD", PACKAGE = "DescTools", x[1], x[2])
    for (i in 3: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 (floor(x) != ceiling(x) || length(x) < 2)
    stop("Argument 'x' must be an integer vector of length >= 2.")

  x <- x[x != 0]
  n <- length(x)
  if (n == 0) {
    l <- 0
  } else if (n == 1) {
    l <- x
  } else if (n == 2) {
    # 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 3: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^(0:(nchar(z) - 1))) %% 10))



CombN <- function(x, 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+1)-lgamma(n-m+1))
    } else {
      res <- choose(n, m)
    }
  }

  return(res)

}



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

  # by F. Leisch

  n <- length(x)

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

  m <- apply(z, 2, 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, 1, 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) {
  # liefert einen data.frame mit allen paarweisen Kombinationen der Variablen
  if( missing(y)) {  # kein y vorhanden, use x only
    data.frame( t(combn(x, 2)), stringsAsFactors=F )
  } else {
    # wenn y definiert ist, wird all.x zu all.y zurueckgegeben
    expand.grid(x, y, stringsAsFactors=F )
  }
}



Fibonacci <- function(n) {

  if (!is.numeric(n) || !IsWhole(n) || n < 0)
    stop("Argument 'n' must be integer >= 0.")

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

  z[n+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))])
}




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

  # 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)
    if(is.null(minval)) minval <- xq[1]
    if(is.null(maxval)) maxval <- xq[2]
  }

  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"]][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 = 5, 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 = 5, 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 > 0){
      if(!is.na(na.last)){
        if(na.last==FALSE) {
          k <- min(length(res$value) + 1, k)
          res$value <- c(NA, res$value)[1:k]
          res$frequency <- c(na_n, res$frequency)[1:k]
        }
        if(na.last==TRUE){
          k <- min(length(res$value) + 1, k)
          res$value <- c(res$value, NA)[1:k]
          res$frequency <- c(res$frequency, na_n)[1: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)[1:k]
      if(na.last==TRUE)
        res <- c(res, rep(NA, na_n))[1: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 = 5, 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) != 0) {
    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 < 2] <- ""

    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)))
}


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) > 0) {
    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)
  }
  )))

}



###

## 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]+1), nchar(x[i]))
    else
      substr(x[i], - n[i]+1, 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[m>0] <- regmatches(x, m)
  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, 0, maxlen), ifelse(nchar(x) > maxlen, "...", ""), sep="")
}


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)
}


# replaced by 0.99.19 with method by word and title
# StrCap <- 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)
#
# }



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="")
}


# defunct by 0.99.21
# StrRep <- function(x, times, sep=""){
#   # same as strrep which seems to be new in 3.4.0
#   z <- Recycle(x=x, times=times, sep=sep)
#   sapply(1:attr(z, "maxdim"), function(i) paste(rep(z$x[i], times=z$times[i]), collapse=z$sep[i]))
# }



# 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)

}



# replaced by 0.99.19: new argument pos for cutting positions and vector support
# StrChop <- function(x, len) {
#   # Splits a string into a number of pieces of fixed length
#   # example: StrChop(x=paste(letters, collapse=""), len = c(3,5,0))
#   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)
# }


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){

  # 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 <- "[-+.e0-9]*\\d"
  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) )
    return(res)
  })

  if(paste==TRUE) {
    vals <- sapply(vals, paste, collapse="")
    if(as.numeric==TRUE)
      vals <- as.numeric(vals)
  } else {
    if(as.numeric==TRUE)
      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$filename <- strsplit(lst$fullfilename, "\\.")[[1]][1]
  lst$extension <- strsplit(lst$fullfilename, "\\.")[[1]][2]

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

}




###

## 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) strtoi(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



UnitConv <- function(x, from_unit, to_unit){

  if(from_unit == "C") {
    if(to_unit=="F") return(x *1.8+32)
  }
  if(from_unit == "F") {
    if(to_unit=="C") return((x -32) *5/9)
  }

  fact <- d.units[d.units$from == from_unit & d.units$to==to_unit, "fact"]
  if(length(fact)==0) fact <- NA

  return(x * fact)

}


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

  # source: Gmisc
  # author: Max Gordon <[email protected]>

  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)

}

###

## 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, ...){

  d.frm <- read.table(text=x, ...)
  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){

  newlevels <- list(...)

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

  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
  return(x)
}



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


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) {

  # $Id: reorder.R 988 2006-10-29 12:55:08Z ggorjan $
  # Reorder the levels of a factor.

  constructor <- if (order) ordered else factor

  if (!missing(new.order))  {

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

  } else if (!missing(FUN))
    new.order <- names(sort(tapply(X, x, FUN, ...)))

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

  constructor(x, levels=new.order)

}



SortMixed <- function(x) x[OrderMixed(x)]

OrderMixed <- function(x) {
# $Id: SortMixed.R 1774 2014-03-01 20:02:08Z 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

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

  if( is.numeric(x) )
    return( order(x) )


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

  numeric <- function(x) {
    suppressWarnings( as.numeric(x) )
  }

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

  x <- as.character(x)

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

  if(length(which.blanks) >0)
    x[ which.blanks ] <- -Inf

  if(length(which.nas) >0)
    x[ which.nas ] <- Inf

  ####
  # - 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("([+-]{0,1}[0-9]+\\.{0,1}[0-9]*([eE][\\+\\-]{0,1}[0-9]+\\.{0,1}[0-9]*){0,1})",
                    paste(delim,"\\1",delim,sep=""), x)

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

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

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

  # create non-numeric version of data
  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)
    order.frame[which.nas,] <- Inf
  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(1, which(l), length(x) + 1)))

}

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

LOCF.matrix <- function(x){
  apply(x, 2, 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),13))) > 1
      } else {
        length(unique(format(x, '%H%M%S'))) > 1
      }
    }
  )

}


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


# 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 + 1900 }


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


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

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

  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=1:12, labels=format(ISOdate(2000, 1:12, 1), "%b"))
               },
             engl = {
               res <- factor(res, levels=1:12, 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=1:12, labels=format(ISOdate(2000, 1:12, 1), "%B"))
                  },
                  engl = {
                    res <- factor(res, levels=1:12, 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)
}


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) %/% 3 + 1)
}

YearDay <- function(x) {
  # return(as.integer(format(as.Date(x), "%j")))
  return(as.POSIXlt(x)$yday)
}


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


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)==31) start_d <- start_d-1
      if(Day(end_d)==31) end_d <- end_d-1
    }
    , "us" ={
      if( (Day(start_d+1)==1 & Month(start_d+1)==3) &
            (Day(end_d+1)==1 & Month(end_d+1)==3)) d2 <- 30
      if( d1==31 ||
            (Day(start_d+1)==1 & Month(start_d+1)==3)) {
          d1 <- 30
          if(d2==31) d2 <- 30
      }

    }
  )

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

}


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



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 = 2)[2,]
    # sapply kills the Date class, so recreate down the road

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

    # 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(100001, 999912)) {

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

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

      # YYYYMMDD
      res <- DescTools::AddMonths(x = as.Date(as.character(x), "%Y%m%d"), n = n)
      res <- DescTools::Year(res)*10000 + DescTools::Month(res)*100 + 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))
  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%%2)
    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[,1]), as.numeric(rng[,2]), PACKAGE="DescTools")
    res[is.na(x)] <- NA

    return( res)

  }

  if(is.numeric(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[1], levels(x))), as.numeric(match(rng[2], levels(x))), PACKAGE="DescTools")
    res[is.na(x)] <- NA
  }  else if(class(x) == "character")  {
    res <- ifelse ( x >= rng[1] & x <= rng[2], 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(1:nrow(rng), length.out = maxdim),]

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

    return( res)

  }

  if(is.numeric(x)) {
    # as.numeric still needed for casting integer to numeric!!
    res <- .Call("between_num_r", 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_r", as.numeric(x), as.numeric(match(rng[1], levels(x))), as.numeric(match(rng[2], levels(x))), PACKAGE="DescTools")
    res[is.na(x)] <- NA
  }  else if(class(x) == "character")  {
    res <- ifelse ( x > rng[1] & x <= rng[2], 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(1:nrow(rng), length.out = maxdim),]

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

    return( res)

  }

  if(is.numeric(x)) {
    # as.numeric still needed for casting integer to numeric!!
    res <- .Call("between_num_l", 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_l", as.numeric(x), as.numeric(match(rng[1], levels(x))), as.numeric(match(rng[2], levels(x))), PACKAGE="DescTools")
    res[is.na(x)] <- NA
  }  else if(class(x) == "character")  {
    res <- ifelse ( x >= rng[1] & x < rng[2], 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(1:nrow(rng), length.out = maxdim),]

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

    return( res)

  }


  if(is.numeric(x)) {
    # as.numeric still needed for casting integer to numeric!!
    res <- .Call("between_num_", 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_", as.numeric(x), as.numeric(match(rng[1], levels(x))), as.numeric(match(rng[2], levels(x))), PACKAGE="DescTools")
    res[is.na(x)] <- NA
  }  else if(class(x) == "character")  {
    res <- ifelse ( x > rng[1] & x < rng[2], 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))
}



# 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, 1, 1) == "%") {
      z <- paste("^", z, sep="")
    } else {
      z <- substr(z, 2, nchar(z) )
    }
    if (!substr(z, nchar(z), nchar(z)) == "%") {
      z <- paste(z, "$", sep="")
    } else {
      z <- substr(z, 1, nchar(z)-1 )
    }
    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), 1, min), apply(rbind(x), 1, max))
  y <- cbind(apply(rbind(y), 1, min), apply(rbind(y), 1, max))

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

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

  unname(d)
}


`%overlaps%` <- function(x, y) {
  if(length(x) < 2) x <- rep(x, 2)
  if(length(y) < 2) y <- rep(y, 2)
  return(!(max(x) < min(y) | min(x) > max(y)) )
}

Overlap <- function(x, y){

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

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

  # old: replaced in 0.99.17 as it did not what it was expected to
  #
  # d <- (apply(x, 1, diff) + apply(y, 1, diff)) - pmin(x[,2] - y[,1], y[,2]- x[,1])
  # d[x[,1] > y[,2] | y[,1] > x[,2]] <- 0

  d1 <- x[, 2]
  idx <- x[, 2] > y[, 2]
  d1[idx] <- y[idx, 2]

  d2 <- y[, 1]
  idx <- x[, 1] > y[, 1]
  d2[idx] <- x[idx, 1]

  d <- d1 - d2

  d[d <=0 ] <- 0

  unname(d)

}




AllDuplicated <- function(x){
  # returns an index vector of all values involved in ties
  # so !AllDuplicated determines all values in x just appearing once
  duplicated(x, fromLast=FALSE) | duplicated(x, fromLast=TRUE)
}


# dummy codierung als Funktion aus:   library(nnet)
# see also model.frame(...)

# ClassInd <- function(cl) {
  # n <- length(cl)
  # cl <- as.factor(cl)
  # x <- matrix(0, n, length(levels(cl)))
  # x[(1L:n) + n * (unclass(cl) - 1L)] <- 1
  # dimnames(x) <- list(names(cl), levels(cl))
  # x
# }


Dummy <- function (x, method = c("treatment", "sum", "helmert", "poly", "full"),  base = 1, levels=NULL) {

  # Alternatives:
  # options(contrasts = c("contr.sum", "contr.poly"))
  # model.matrix(~x.)[, -1]               ### und die dummy-codes
  # or Ripley's brilliant shorty-function:
  #   diag(nlevels(x))[x,]

  if(is.null(levels))
    x <- factor(x)
  else
    x <- factor(x, levels=levels)

  if(!is.numeric(base)) base <- match(base, levels(x))

  method <- match.arg( arg = method, choices = c("treatment", "sum", "helmert", "poly", "full") )

  switch( method
    , "treatment" = { res <- contr.treatment(n = nlevels(x), base = base)[x,] }
    , "sum" = { res <- contr.sum(n = nlevels(x))[x,] }
    , "helmert" = { res <- contr.helmert(n = nlevels(x))[x,] }
    , "poly" = { res <- contr.poly(n = nlevels(x))[x,] }
    , "full" = { res <- diag(nlevels(x))[x,] }
  )
  res <- as.matrix(res) # force res to be matrix, avoiding res being a vector if nlevels(x) = 2

  if(method=="full") {
    dimnames(res) <- list(if(is.null(names(x))) 1:length(x) else names(x), levels(x))
    attr(res, "base") <- NA
  } else {
    dimnames(res) <- list(if(is.null(names(x))) 1:length(x) else names(x), levels(x)[-base])
    attr(res, "base") <- levels(x)[base]
  }
  return(res)
}


# would not return characters correctly
#
Coalesce <- function(..., method = c("is.na", "is.finite")) {
  # Returns the first element in x which is not NA

  if(length(list(...)) > 1) {
    if(all(lapply(list(...), length) > 1)){
      x <- data.frame(..., stringsAsFactors = FALSE)
    } else {
      x <- unlist(list(...))
    }
  } else {
    if(is.matrix(...)) {
      x <- data.frame(..., stringsAsFactors = FALSE)
    } else {
      x <- (...)
    }
  }
  switch(match.arg(method, choices=c("is.na", "is.finite")),
    "is.na" = res <- Reduce(function (x,y) ifelse(!is.na(x), x, y), x),
    "is.finite" = res <- Reduce(function (x,y) ifelse(is.finite(x), x, y), x)
  )
  return(res)
}





PartitionBy <- function(x, by, FUN, ...){

  # SQL-OLAP: sum() over (partition by g)
  # (more than 1 grouping variables are enumerated like by=list(g1,g2,g3),
  # as it is defined in tapply

  # see also ave, which only handles arguments otherwise..

  if (missing(by))
    x[] <- FUN(x, ...)
  else {
    g <- interaction(by)
    split(x, g) <- lapply(split(x, g), FUN, ...)
  }
  x

}




IsWhole <- function (x, all=FALSE, tol = sqrt(.Machine$double.eps), na.rm=FALSE) {

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

  if(all){

    if (is.integer(x)) {
      TRUE

    } else if (is.numeric(x)) {
      isTRUE(all.equal(x, round(x), tol))

    } else if (is.complex(x)) {
      isTRUE(all.equal(Re(x), round(Re(x)), tol)) && isTRUE(all.equal(Im(x), round(Im(x)), tol))

    } else FALSE


  } else {
    if (is.integer(x)) {
      rep(TRUE, length(x))

    } else if (is.numeric(x)) {
      abs(x - round(x)) < tol

    } else if (is.complex(x)) {
      abs(Re(x) - round(Re(x))) < tol && abs(Im(x) - round(Im(x))) < tol

    } else rep(FALSE, length(x))

  }

}



IsZero <-function(x, tol = sqrt(.Machine$double.eps), na.rm=FALSE) {
  # Define check if a numeric is 0

  if (na.rm)
    x <- x[!is.na(x)]
  if(is.numeric(x))
    x < tol
  else
    FALSE

}


IsNumeric <- function (x, length.arg = Inf, integer.valued = FALSE, positive = FALSE, na.rm = FALSE){

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

  if (all(is.numeric(x)) && all(is.finite(x)) && (if (is.finite(length.arg)) length(x) ==
                                                    length.arg else TRUE) && (if (integer.valued) all(x == round(x)) else TRUE) &&
        (if (positive) all(x > 0) else TRUE)) TRUE else FALSE
}

IsOdd <- function(x) x %% 2 == 1


IsDichotomous <- function(x, strict=FALSE, na.rm=FALSE) {
  if(na.rm)
    x <- x[!is.na(x)]

  if(strict)
    length(unique(x)) == 2
  else
    length(unique(x)) <= 2
}

StrIsNumeric <- function(x){
  # example:
  # x <- c("123", "-3.141", "foobar123")
  # StrIsNUmeric(x)
  suppressWarnings(!is.na(as.numeric(x)))
}


IsPrime <- function(x) {
  if (is.null(x) || length(x) == 0)
    stop("Argument 'x' must be a nonempty vector or matrix.")
  if (!is.numeric(x) || any(x < 0) || any(x != round(x)))
    stop("All entries of 'x' must be nonnegative integers.")

  n <- length(x)
  X <- x[1:n]
  L <- logical(n)
  p <- DescTools::Primes(ceiling(sqrt(max(x))))
  for (i in 1:n) {
    L[i] <- all(X[i] %% p[p < X[i]] != 0)
  }
  L[X == 1 | X == 0] <- FALSE
  dim(L) <- dim(x)
  return(L)
}


VecRot <- function(x, k = 1)  {

  if (k != round(k)) {
    k <- round(k)
    warning("'k' is not an integer")
  }

  # just one shift:    (1:x %% x) + 1
  k <- k %% length(x)
  rep(x, times=2)[(length(x) - k+1):(2*length(x)-k)]
}



VecShift <- function(x, k = 1){

  if (k != round(k)) {
    k <- round(k)
    warning("'k' is not an integer")
  }

  if(k < 0){
    c(x[-k:length(x)], rep(NA, -k))
  } else {
    c(rep(NA, k), x[1:(length(x)-k)])
  }
}



RoundTo <- function(x, multiple = 1, FUN = round) {

  # check for functions: round, ceiling, floor, but how????
  # FUN <- match.arg(FUN, c(round, ceiling, floor))

  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", FUN)
  }

  # round will set digits to 0 by default, which is exactly what we need here
  return(eval(parse(text = gettextf("%s(x/multiple) * multiple", FUN))))
}


# Alternative Idee mit up and down:

# Round <- function(x, digits = 0, direction=c("both", "down", "up"), multiple = NA) {
#
#   direction <- match.arg(direction)
#
#   switch(direction
#          , both={
#            if(is.na(multiple)){
#              res <- round(x, digits = digits)
#            } else {
#              res <- round(x/multiple) * multiple
#            }
#          }
#          , down={
#            if(is.na(multiple)){
#              res <- floor(x, digits = digits)
#            } else {
#              res <- floor(x/multiple) * multiple
#            }
#          }
#          , up={
#            if(is.na(multiple)){
#              res <- ceiling(x, digits = digits)
#            } else {
#              res <- ceiling(x/multiple) * multiple
#            }
#          }
#   )
#   return(res)
# }




Str <- function(x, ...){
  if(identical(class(x), "data.frame")) {

    args <- list(...)
    if(is.null(args["strict.width"])) args["strict.width"] <- "cut"

    out <- .CaptOut(do.call(str, c(list(object=x), args)))
    idx <- format(1:length(grep(pattern="^ \\$", out)))
    i <- 1
    j <- 1
    while(i <= length(out)) {
      if( length(grep(pattern="^ \\$", out[i])) > 0 ) {
        out[i] <- gsub(pattern="^ \\$", replacement= paste(" ", idx[j], " \\$", sep=""), out[i])
        j <- j + 1
      }
      i <- i + 1
    }
    res <- out
  } else {
    res <- str(x)
  }
  cat(res, sep="\n")
  invisible(res)
}


Some <- function(x, n = 6L, ...){
  UseMethod("Some")
}


Some.data.frame <- function (x, n = 6L, ...) {
  stopifnot(length(n) == 1L)
  n <- if (n < 0L)
    max(nrow(x) + n, 0L)
  else min(n, nrow(x))
  x[sort(sample(nrow(x), n)), , drop = FALSE]
}


Some.matrix <- function (x, n = 6L, addrownums = TRUE, ...) {

  stopifnot(length(n) == 1L)
  nrx <- nrow(x)
  n <- if (n < 0L)
    max(nrx + n, 0L)
  else min(n, nrx)
  sel <- sort(sample(nrow(x)))
  ans <- x[sel, , drop = FALSE]
  if (addrownums && is.null(rownames(x)))
    rownames(ans) <- format(sprintf("[%d,]", sel), justify = "right")
  ans
}

Some.default <- function (x, n = 6L, ...) {
  stopifnot(length(n) == 1L)
  n <- if (n < 0L)
    max(length(x) + n, 0L)
  else min(n, length(x))
  x[sort(sample(length(x), n))]
}


LsFct <- function(package){
  as.vector(unclass(lsf.str(pos = gettextf("package:%s", package) )))

}

# LsData <- function(package){
#   # example  lsf("DescTools")
#   ls(pos = gettextf("package:%s", package))
#   as.vector(unclass(ls.str(gettextf("package:%s", package), mode="list")))
#
# }

LsObj <- function(package){
  # example  lsf("DescTools")
  ls(pos = gettextf("package:%s", package))
}


PDFManual <- function(package){
  package <- as.character(substitute(package))
  browseURL(paste("http://cran.r-project.org/web/packages/", package,"/", package, ".pdf", sep = ""))
}


# showPDFmanual <- function(package, lib.loc=NULL)
# {
#   path <- find.package(package, lib.loc)
#   system(paste(shQuote(file.path(R.home("bin"), "R")),
#                "CMD", "Rd2pdf",
#                shQuote(path)))
# }


###

## base: organisation, format, report and printing routines ====


# Mbind <- function(...){
#   # matrix bind
#   # function um n nxm-matrizen zu einem 3d-array zusammenzufassen
#
#   arg.list <- list(...)
#   # check dimensions, by compare the dimension of each matrix to the first
#   if( !all( unlist(lapply(arg.list, function(m) all(unlist(dim(arg.list[[1]])) == unlist(dim(m)))) )))
#      stop("Not all matrices have the same dimension!")
#
#   ma <- array(unlist(arg.list), dim=c(nrow(arg.list[[1]]), ncol(arg.list[[2]]), length(arg.list)) )
#   dimnames(ma) <- dimnames(arg.list[[1]])
#   dimnames(ma)[[3]] <- if(is.null(names(arg.list))){1:length(arg.list)} else {names(arg.list)}
#
#   return(ma)
# }


Abind <- function(..., along=N, rev.along=NULL, new.names=NULL,
                  force.array=TRUE, make.names=FALSE,
                  use.first.dimnames=FALSE, hier.names=FALSE, use.dnns=FALSE) {

  if (is.character(hier.names))
    hier.names <- match.arg(hier.names, c('before', 'after', 'none'))
  else
    hier.names <- if (hier.names) 'before' else 'no'
  arg.list <- list(...)
  if (is.list(arg.list[[1]]) && !is.data.frame(arg.list[[1]])) {
    if (length(arg.list)!=1)
      stop("can only supply one list-valued argument for ...")
    if (make.names)
      stop("cannot have make.names=TRUE with a list argument")
    arg.list <- arg.list[[1]]
    have.list.arg <- TRUE
  } else {
    N <- max(1, sapply(list(...), function(x) length(dim(x))))
    have.list.arg <- FALSE
  }
  if (any(discard <- sapply(arg.list, is.null)))
    arg.list <- arg.list[!discard]
  if (length(arg.list)==0)
    return(NULL)
  N <- max(1, sapply(arg.list, function(x) length(dim(x))))

  ## N will eventually be length(dim(return.value))
  if (!is.null(rev.along))
    along <- N + 1 - rev.along

  if (along < 1 || along > N || (along > floor(along) && along < ceiling(along))) {
    N <- N + 1
    along <- max(1, min(N+1, ceiling(along)))
  }

  ## this next check should be redundant, but keep it here for safety...
  if (length(along) > 1 || along < 1 || along > N + 1)
    stop(paste("\"along\" must specify one dimension of the array,",
               "or interpolate between two dimensions of the array",
               sep="\n"))

  if (!force.array && N==2) {
    if (!have.list.arg) {
      if (along==2)
        return(cbind(...))
      if (along==1)
        return(rbind(...))
    } else {
      if (along==2)
        return(do.call("cbind", arg.list))
      if (along==1)
        return(do.call("rbind", arg.list))
    }
  }

  if (along>N || along<0)
    stop("along must be between 0 and ", N)

  pre <- seq(from=1, len=along-1)
  post <- seq(to=N-1, len=N-along)
  ## "perm" specifies permutation to put join dimension (along) last
  perm <- c(seq(len=N)[-along], along)

  arg.names <- names(arg.list)
  if (is.null(arg.names)) arg.names <- rep("", length(arg.list))
  ## if new.names is a character vector, treat it as argument names
  if (is.character(new.names)) {
    arg.names[seq(along=new.names)[nchar(new.names)>0]] <-
      new.names[nchar(new.names)>0]
    new.names <- NULL
  }

  ## Be careful with dot.args, because if Abind was called
  ## using do.call(), and had anonymous arguments, the expressions
  ## returned by match.call() are for the entire structure.
  ## This can be a problem in S-PLUS, not sure about R.
  ## E.g., in this one match.call() returns compact results:
  ## > (function(...)browser())(1:10,letters)
  ## Called from: (function(...)  browser())....
  ## b()> match.call(expand.dots=FALSE)$...
  ## list(1:10, letters)
  ## But in this one, match.call() returns evaluated results:
  ## > test <- function(...) browser()
  ## > do.call("test", list(1:3,letters[1:4]))
  ## Called from: test(c(1, 2, 3), c("a", "b....
  ## b(test)> match.call(expand.dots=FALSE)$...
  ## list(c(1, 2, 3), c("a", "b", "c", "d")
  ## The problem here was largely mitigated by making Abind()
  ## accept a single list argument, which removes most of the
  ## need for the use of do.call("Abind", ...)

  ## Create deparsed versions of actual arguments in arg.alt.names
  ## These are used for error messages
  if (any(arg.names=="")) {
    if (make.names) {
      ## Create dot.args to be a list of calling expressions for the objects to be bound.
      ## Be careful here with translation to R --
      ## dot.args does not have the "list" functor with R
      ## (and dot.args is not a call object), whereas with S-PLUS, dot.args
      ## must have the list functor removed
      dot.args <- match.call(expand.dots=FALSE)$... ## [[2]]
      if (is.call(dot.args) && identical(dot.args[[1]], as.name("list")))
        dot.args <- dot.args[-1]
      arg.alt.names <- arg.names
      for (i in seq(along=arg.names)) {
        if (arg.alt.names[i]=="") {
          if (object.size(dot.args[[i]])<1000) {
            arg.alt.names[i] <- paste(deparse(dot.args[[i]], 40), collapse=";")
          } else {
            arg.alt.names[i] <- paste("X", i, sep="")
          }
          arg.names[i] <- arg.alt.names[i]
        }
      }
      ## unset(dot.args) don't need dot.args any more, but R doesn't have unset()
    } else {
      arg.alt.names <- arg.names
      arg.alt.names[arg.names==""] <- paste("X", seq(along=arg.names), sep="")[arg.names==""]
    }
  } else {
    arg.alt.names <- arg.names
  }

  use.along.names <- any(arg.names!="")

  ## need to have here: arg.names, arg.alt.names, don't need dot.args

  names(arg.list) <- arg.names
  ## arg.dimnames is a matrix of dimension names, each element of the
  ## the matrix is a character vector, e.g., arg.dimnames[j,i] is
  ## the vector of names for dimension j of arg i
  arg.dimnames <- matrix(vector("list", N*length(arg.names)), nrow=N, ncol=length(arg.names))
  dimnames(arg.dimnames) <- list(NULL, arg.names)
  ## arg.dnns is a matrix of names of dimensions, each element is a
  ## character vector len 1, or NULL
  arg.dnns <- matrix(vector("list", N*length(arg.names)), nrow=N, ncol=length(arg.names))
  dimnames(arg.dnns) <- list(NULL, arg.names)
  dimnames.new <- vector("list", N)

  ## Coerce all arguments to have the same number of dimensions
  ## (by adding one, if necessary) and permute them to put the
  ## join dimension last.

  ## Create arg.dim as a matrix with length(dim) rows and
  ## length(arg.list) columns: arg.dim[j,i]==dim(arg.list[[i]])[j],
  ## The dimension order of arg.dim is original
  arg.dim <- matrix(integer(1), nrow=N, ncol=length(arg.names))

  for (i in seq(len=length(arg.list))) {
    m <- arg.list[[i]]
    m.changed <- FALSE

    ## be careful with conversion to array: as.array converts data frames badly
    if (is.data.frame(m)) {
      ## use as.matrix() in preference to data.matrix() because
      ## data.matrix() uses the unintuitive codes() function on factors
      m <- as.matrix(m)
      m.changed <- TRUE
    } else if (!is.array(m) && !is.null(m)) {
      if (!is.atomic(m))
        stop("arg '", arg.alt.names[i], "' is non-atomic")
      ## make sure to get the names of a vector and attach them to the array
      dn <- names(m)
      m <- as.array(m)
      if (length(dim(m))==1 && !is.null(dn))
        dimnames(m) <- list(dn)
      m.changed <- TRUE
    }
    new.dim <- dim(m)
    if (length(new.dim)==N) {
      ## Assign the dimnames of this argument to the i'th column of arg.dimnames.
      ## If dimnames(m) is NULL, would need to do arg.dimnames[,i] <- list(NULL)
      ## to set all elts to NULL, as arg.dimnames[,i] <- NULL does not actually
      ## change anything in S-PLUS (leaves whatever is there) and illegal in R.
      ## Since arg.dimnames has NULL entries to begin with, don't need to do
      ## anything when dimnames(m) is NULL
      if (!is.null(dimnames(m))) {
        arg.dimnames[,i] <- dimnames(m)
        if (use.dnns && !is.null(names(dimnames(m))))
          arg.dnns[,i] <- as.list(names(dimnames(m)))
      }
      arg.dim[,i] <- new.dim
    } else if (length(new.dim)==N-1) {
      ## add another dimension (first set dimnames to NULL to prevent errors)
      if (!is.null(dimnames(m))) {
        ## arg.dimnames[,i] <- c(dimnames(m)[pre], list(NULL), dimnames(m))[post]
        ## is equivalent to arg.dimnames[-N,i] <- dimnames(m)
        arg.dimnames[-along,i] <- dimnames(m)
        if (use.dnns && !is.null(names(dimnames(m))))
          arg.dnns[-along,i] <- as.list(names(dimnames(m)))
        ## remove the dimnames so that we can assign a dim of an extra length
        dimnames(m) <- NULL
      }
      arg.dim[,i] <- c(new.dim[pre], 1, new.dim[post])
      if (any(perm!=seq(along=perm))) {
        dim(m) <- c(new.dim[pre], 1, new.dim[post])
        m.changed <- TRUE
      }
    } else {
      stop("'", arg.alt.names[i], "' does not fit: should have `length(dim())'=",
           N, " or ", N-1)
    }

    if (any(perm!=seq(along=perm)))
      arg.list[[i]] <- aperm(m, perm)
    else if (m.changed)
      arg.list[[i]] <- m
  }

  ## Make sure all arguments conform
  conform.dim <- arg.dim[,1]
  for (i in seq(len=ncol(arg.dim))) {
    if (any((conform.dim!=arg.dim[,i])[-along])) {
      stop("arg '", arg.alt.names[i], "' has dims=", paste(arg.dim[,i], collapse=", "),
           "; but need dims=", paste(replace(conform.dim, along, "X"), collapse=", "))
    }
  }

  ## find the last (or first) names for each dimensions except the join dimension
  if (N>1)
    for (dd in seq(len=N)[-along]) {
      for (i in (if (use.first.dimnames) seq(along=arg.names) else rev(seq(along=arg.names)))) {
        if (length(arg.dimnames[[dd,i]]) > 0) {
          dimnames.new[[dd]] <- arg.dimnames[[dd,i]]
          if (use.dnns && !is.null(arg.dnns[[dd,i]]))
            names(dimnames.new)[dd] <- arg.dnns[[dd,i]]
          break
        }
      }
    }

  ## find or create names for the join dimension
  for (i in seq(len=length(arg.names))) {
    ## only use names if arg i contributes some elements
    if (arg.dim[along,i] > 0) {
      dnm.along <- arg.dimnames[[along,i]]
      if (length(dnm.along)==arg.dim[along,i]) {
        use.along.names <- TRUE
        if (hier.names=='before' && arg.names[i]!="")
          dnm.along <- paste(arg.names[i], dnm.along, sep=".")
        else if (hier.names=='after' && arg.names[i]!="")
          dnm.along <- paste(dnm.along, arg.names[i], sep=".")
      } else {
        ## make up names for the along dimension
        if (arg.dim[along,i]==1)
          dnm.along <- arg.names[i]
        else if (arg.names[i]=="")
          dnm.along <- rep("", arg.dim[along,i])
        else
          dnm.along <- paste(arg.names[i], seq(length=arg.dim[along,i]), sep="")
      }
      dimnames.new[[along]] <- c(dimnames.new[[along]], dnm.along)
    }
    if (use.dnns) {
      dnn <- unlist(arg.dnns[along,])
      if (length(dnn)) {
        if (!use.first.dimnames)
          dnn <- rev(dnn)
        names(dimnames.new)[along] <- dnn[1]
      }
    }
  }
  ## if no names at all were given for the along dimension, use none
  if (!use.along.names)
    dimnames.new[along] <- list(NULL)

  ## Construct the output array from the pieces.
  ## Could experiment here with more efficient ways of constructing the
  ## result than using unlist(), e.g.
  ##    out <- numeric(prod(c( arg.dim[-along,1], sum(arg.dim[along,]))))
  ## Don't use names in unlist because this can quickly exhaust memory when
  ## Abind is called with "do.call" (which creates horrendous names in S-PLUS).
  out <- array(unlist(arg.list, use.names=FALSE),
               dim=c( arg.dim[-along,1], sum(arg.dim[along,])),
               dimnames=dimnames.new[perm])
  ## permute the output array to put the join dimension back in the right place
  if (any(order(perm)!=seq(along=perm)))
    out <- aperm(out, order(perm))

  ## if new.names is list of character vectors, use whichever are non-null
  ## for dimension names, checking that they are the right length
  if (!is.null(new.names) && is.list(new.names)) {
    for (dd in seq(len=N)) {
      if (!is.null(new.names[[dd]])) {
        if (length(new.names[[dd]])==dim(out)[dd])
          dimnames(out)[[dd]] <- new.names[[dd]]
        else if (length(new.names[[dd]]))
          warning(paste("Component ", dd,
                        " of new.names ignored: has length ",
                        length(new.names[[dd]]), ", should be ",
                        dim(out)[dd], sep=""))
      }
      if (use.dnns && !is.null(names(new.names)) && names(new.names)[dd]!='')
        names(dimnames(out))[dd] <- names(new.names)[dd]
    }
  }
  if (use.dnns && !is.null(names(dimnames(out))) && any(i <- is.na(names(dimnames(out)))))
    names(dimnames(out))[i] <- ''
  out
}




# *********************************** 12.12.2014
# stack/unstack does exactly that

# ToLong <- function(x, varnames=NULL){
#   lst <- as.list(x)
#   res <- data.frame(rep(names(lst), lapply(lst, length)), unlist(lst))
#   rownames(res) <- NULL
#   if(is.null(varnames)) varnames <- c("grp","x")
#   colnames(res) <- varnames
#   return(res)
# }

ToLong <- function (x, varnames = NULL) {

  if(!is.list(x)) {
    if(is.matrix(x) || is.table(x))
      x <- as.data.frame(x)
    lst <- as.list(x)
  } else {
    lst <- x
  }
  grpnames <- names(lst)
  if(is.null(grpnames)) grpnames <- paste("X", 1:length(lst), sep="")
  res <- data.frame(rep(grpnames, lapply(lst, length)), unlist(lst))
  rownames(res) <- NULL
  if (is.null(varnames))
    varnames <- c("grp", "x")

  colnames(res) <- varnames
  rownames(res) <- do.call(paste, c(expand.grid(rownames(x), grpnames), sep="."))

  return(res)
}



ToWide <- function(x, g, by=NULL, varnames=NULL){

  if(is.null(varnames))
    varnames <- levels(g)

  if(is.null(by)){
    by <- "row.names"

  }  else {
    x <- data.frame(x, idx=by)
    by <- "idx"
    varnames <- c("by", varnames)
  }

  g <- factor(g)
  s <- split(x, g)

  res <- Reduce(function(x, y) {
    z <- merge(x, y, by=by, all.x=TRUE, all.y=TRUE)
    # kill the rownames
    if(by=="row.names") z <- z[, -grep("Row.names", names(z))]
    return(z)
  }, s)

  colnames(res) <- varnames
  return(res)

}


# ToWide <- function(x, g, varnames=NULL){
#   g <- factor(g)
#   res <- do.call("cbind", split(x, g))
#   if(is.null(varnames)) varnames <- levels(g)
#   colnames(res) <- varnames
#   return(res)
# }



CatTable <- function( tab, wcol, nrepchars, width=getOption("width") ) {

  # Wie viele Datenspalten haben vollstaendig Platz auf einer Linie?
  ncols <- ( width - nrepchars ) %/% wcol
  # Wieviele Zeilen ergeben sich?
  nrows <- ((nchar(tab[1]) - nrepchars) %/% wcol) / ncols +
    (((nchar(tab[1]) - nrepchars) %% wcol ) > 0) *1  # Rest Linie
  for( i in 1:nrows ) {
    for( j in 1:length(tab) ){
  #    cat( i, nrepchars + 1 + (i-1)*(ncols*wcol-4), nrepchars + i*ncols*wcol-5, "\n")
      cat( substr(tab[j],1,nrepchars)
	       , substr(tab[j], nrepchars + 1 + (i-1)*(ncols*wcol), nrepchars + 1 + i*ncols*wcol-1 )
	       , "\n", sep="" )
    }
	cat( "\n" )
	}
}



.CaptOut <- function(..., file = NULL, append = FALSE, width=150) {

  opt <- options(width=width)

  args <- substitute(list(...))[-1L]
  rval <- NULL
  closeit <- TRUE
  if (is.null(file))
    file <- textConnection("rval", "w", local = TRUE)
  else if (is.character(file))
    file <- file(file, if (append)
      "a"
      else "w")
  else if (inherits(file, "connection")) {
    if (!isOpen(file))
      open(file, if (append)
        "a"
        else "w")
    else closeit <- FALSE
  }
  else stop("'file' must be NULL, a character string or a connection")
  sink(file)
  on.exit({
    sink()
    if (closeit) close(file)
    options(opt)
  })
  pf <- parent.frame()
  evalVis <- function(expr) withVisible(eval(expr, pf))
  for (i in seq_along(args)) {
    expr <- args[[i]]
    tmp <- switch(mode(expr), expression = lapply(expr, evalVis),
                  call = , name = list(evalVis(expr)), stop("bad argument"))
    for (item in tmp) if (item$visible)
      print(item$value)
  }
  on.exit(