R/DescTools.r
In DescTools: Tools for Descriptive Statistics

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

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


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

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


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

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

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


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


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


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

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

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

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

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


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


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

# functions:
# polychor, tetrachor

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

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

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


# flag ~ flag  mit mosaicplot und allgemein bivariate darstellung

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

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


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

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

# - Tabellen factor ~ factor nebeneinander wenn Platz


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


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

# Formula-Interface fuer PlotBag

# - replace .fmt by Format

# - DescDlg

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

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


# separate Data ========

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

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


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



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



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

# Base functions  ====

## base: calculus

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

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

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


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

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




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


Nf <- function(x, ...){
  as.numeric(factor(x, ...))
}  


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

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



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


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



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

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

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


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

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


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


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

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

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


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

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



rSum21 <- function(size, digits=NULL){
  
  rnd <- (p <- runif(n = size))/sum(p)
  
  if(!is.null(digits)){
    rnd <- round(rnd, digits = digits)
    rnd[1] <- rnd[1] + (1-sum(rnd))
  }
  
  rnd
  
}


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



Divisors <- function(x) {

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

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



# sample interface for data.frames

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

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

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

}


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




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

  return(res)

}



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

  # by F. Leisch

  n <- length(x)

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

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

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

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

}



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

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

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

  if(as.list){

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

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

}


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


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



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



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

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

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


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

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

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

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

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



Fibonacci <- function(n) {

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

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

  z[n+1L]

}


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


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

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




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

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

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

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

  .str2ints <- function(s) {

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

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




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

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

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


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





# 
# Winsorize <- function(x, minval = NULL, maxval = NULL,
#                       probs=c(0.05, 0.95), na.rm = FALSE, type=7) {
# 
#   # following an idea from Gabor Grothendieck
#   # http://r.789695.n4.nabble.com/how-to-winsorize-data-td930227.html
# 
#   # in HuberM things are implemented the same way
# 
#   # don't eliminate NAs in x, moreover leave them untouched,
#   # just calc quantile without them...
# 
#   # pmax(pmin(x, maxval), minval)
# 
#   # the pmax(pmin()-version is slower than the following
# 
#   if(is.null(minval) || is.null(maxval)){
#     xq <- quantile(x=x, probs=probs, na.rm=na.rm, type=type)
#     if(is.null(minval)) minval <- xq[1L]
#     if(is.null(maxval)) maxval <- xq[2L]
#   }
# 
#   x[x<minval] <- minval
#   x[x>maxval] <- maxval
# 
#   return(x)
# 
#   # see also Andreas Alfons, KU Leuven
#   # roubustHD, Winsorize
# 
#   # Jim Lemon's rather clumsy implementation:
# 
#   # #added winsor.var and winsor.sd and winsor.mean (to supplement winsor.means)
#   # #August 28, 2009 following a suggestion by Jim Lemon
#   # #corrected January 15, 2009 to use the quantile function rather than sorting.
#   # #suggested by Michael Conklin in correspondence with Karl Healey
#   # #this preserves the order of the data
#   # "wins" <- function(x,trim=.2, na.rm=TRUE) {
#     # if ((trim < 0) | (trim>0.5) )
#         # stop("trimming must be reasonable")
#       # qtrim <- quantile(x,c(trim,.5, 1-trim),na.rm = na.rm)
#       # xbot <- qtrim[1]
#       # xtop <- qtrim[3]
#        # if(trim<.5) {
#       # x[x < xbot]  <- xbot
#       # x[x > xtop] <- xtop} else {x[!is.na(x)] <- qtrim[2]}
#      # return(x) }
# 
# }
# 

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

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

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

  n <- length(x)

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

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

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

  }
  return(x)
}



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

  x <- as.matrix(x)

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



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

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

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

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

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

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




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

    x <- as.matrix(x)

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

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

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

}



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

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

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

  if (unique==TRUE) {

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

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

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

  } else {

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

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

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

  }

  return(res)

}




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



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

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

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

  if (unique==TRUE) {

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

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

  } else {

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

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

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

  }

  return(res)

}


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




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

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

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

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

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

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



# Closest <- Vectorize( 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)
# 
# }, vectorize.args="a")
# 


Closest <- function(x, a, which = FALSE, na.rm = FALSE){
  
  # example: Closest(a=67.5, x=d.pizza$temperature, na.rm=TRUE)
  
  FUN <- function(x, a, which = FALSE, na.rm = FALSE){
    
    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)
    
  }
  
  # vectorize arguments a and which
  res <- mapply(FUN=FUN, a=a, which=which, 
                MoreArgs = list(x=x, na.rm=na.rm), SIMPLIFY=FALSE)
  
  # simplify: if res is a list with 1 element only, reduce to vector
  if(length(res)==1)
    res <- res[[1]] 
  
  return(res)
  
}





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



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

}


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



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

  # Author: Nick Sabbe

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

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

  if(n < max(idx)){
    warning(gettextf("n=%s must not be less than max(idx)=%s, which currently is the case", n, max(idx)))
    return(NA)
  }
  
  res <- logical(n)
  
  if(length(idx) > 0L) {
    res[idx] <- TRUE
    if(useNames) names(res)[idx] <- names(idx)
  }

  return(res)

}



CombLevels <- function(...){

  dots <- list( ... )

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

}


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



###

## base: string functions ====


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

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

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

}


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

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



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

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

}


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



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


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




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

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



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

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

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

  na <- is.na(x)

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

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

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

         }
  )

  res[na] <- NA
  return(res)

}






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

    # source MKmisc, Author: Matthias Kohl

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

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

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

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

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

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

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

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

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

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


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

    return(d)
}


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



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


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

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

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

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

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

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

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

}



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

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

  id.na <- is.na(x)

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

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

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

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

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

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

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

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

  # return unchanged values not containing sep
  return(res)

}



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

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

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

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

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

  return(res)

}



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


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

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

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

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

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

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

  return(vals)

}


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

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

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

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



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

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

  path <- normalizePath(path, mustWork = FALSE)

  lst <- list()

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

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

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

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

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

}


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

  # example:    Spell("Yailov9teb6i")

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

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

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

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

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

  }

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

}



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



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

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


SplitToDummy <- function(x, split=",", ...){
  
  # found values
  lvl <- sort(unique(unlist(strsplit(x = x, split=split, ...))))
  
  d.frm <- data.frame(x,
                      sapply(lvl, function(y) grepl(y, x) * 1))
  
  return(d.frm)
  
}




###

## base: conversion functions ====


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


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

}


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

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

}


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

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

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


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

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

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


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

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


RomanToInt <- function (x) {

  # opposite to as.roman

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

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

}



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

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



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

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

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

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

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

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

  }


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

  convertible <- u_from$unit == u_to$unit

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

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


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


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

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

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

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

}


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

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

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

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

  if (inherits(x = what, 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 (inherits(x = what, "function")){
    f_name <- deparse(substitute(what))
    call <- as.call(c(list(as.name(f_name)), argn))
    args[[f_name]] <- what
  }else if (inherits(x = what, what="name")){
    call <- as.call(c(list(what, argn)))
  }

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

}


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





###

## base: transformation functions ====

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

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

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

  return(x)

}


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

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

  return(tab)

}


NALevel <- function(x, level){
  # replaces NAs by the defined level in a factor x
  x <- factor(x, exclude=NULL)
  levels(x)[is.na(levels(x))] <- level
  return(x)
}


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

  # if x is character, turn it to factor and reconvert it when finished
  if(xchar <- is.character(x)){
    x <- factor(x)
  }
  
  newlevels <- list(...)

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

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

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

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

  # handle NA levels
  if(any(i <- sapply(lapply(newlevels, is.na), any)))
    x[is.na(x)] <- names(newlevels)[i]
  
  # x was character, convert to original then
  if(xchar)
    x <- as.character
  
  if(num)
    x <- as.numeric(as.character(x))

  return(x)
  
}


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



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


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


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

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


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


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





NZ <- function(x){
  # return non-zero elements of x
  x[ !IsZero(x) ]
}



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

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

}




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

  # 25.11.2017 verbatim from gdata, Greg Warnes

  constructor <- if (order) ordered else factor

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

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

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

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

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

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

  constructor(x, levels=new.order)
}




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

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



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

  # 25.11.2017 verbatim from gtools, Greg Warnes


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

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

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

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

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

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

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

  x <- as.character(x)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  return(retval)
}



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



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

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




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

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


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

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

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

}


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

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

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

  return(res)
}



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

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


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

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


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

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



# from library(forecast)

BoxCox <- function (x, lambda) {

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

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

}


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


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

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

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

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

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

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

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


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

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


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




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


LOCF.default <- function(x) {

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

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

  # faster solution from Daniel Wollschlaeger:

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

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

}

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

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


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

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

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

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

  }

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

  return(pp)
}




###

## base: date functions  ====

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


HmsToMinute <- function(x){
  Hour(x)*60 + Minute(x) + Second(x)/60
}


HmsToSec <- function(x) {

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



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

  x <- as.numeric(x)

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

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

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

}



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

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

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

}


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


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


# Year <- function(x){ as.integer( format(as.Date(x), "%Y") ) }
Year <-  function(x){
  UseMethod("Year")
}

Year.default <- function(x){ as.POSIXlt(x)$year + 1900L }


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


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


Month.ym <- function(x, fmt = c("m", "mm", "mmm"), 
                     lang = DescToolsOptions("lang"), stringsAsFactors = TRUE) {
  # unclass(x - Year(x) * 100)   
  x <- as.Date(x)
  NextMethod()
}


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

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

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


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

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

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

#??? fast implementation in lubridate:

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


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

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

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

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

}


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


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

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

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

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



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



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

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



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
}


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


Year.ym  <- function(x){  unclass(round((x/100)))   }



# define a new class ym ("yearmonth")
as.ym <- function(x){
  
  # expects a YYYYMM format
    res <- structure(as.integer(x), class = c("ym", "num"))
    res[!((y <- round(x/100)) %[]% c(1000, 3000) & 
            (x - y * 100) %[]% c(1, 12))]   <- NA_integer_
    return(res)
}

print.ym <- function(x, ...) {
  # do not print the class attributes
  print(unclass(x), ...)
}


as.Date.ym <- function(x, d=1, ...){
  as.Date(gsub("([0-9]{4})([0-9]{2})([0-9]{2})", "\\1-\\2-\\3", 
               x*100 + d))
}




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

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

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

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

    }
  )

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

}


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



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


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



AddMonths <- function (x, n, ...) {
  UseMethod("AddMonths")
}
  

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

  .addMonths <- function (x, n) {

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

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

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

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

    return(res)

  }

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

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

  return(res)

}



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

  .addMonths <- function (x, n) {

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

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

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

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

    return(res)

  }

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

  return(res)

}



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

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

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


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

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

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

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



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



###

## base: information functions ====


# Between operators

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

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

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

    return( res )

  }

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


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

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

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

    return( res)

  }

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

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

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

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

    return( res)

  }

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


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

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

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

    return( res)

  }


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


# outside operators (not exactly the negations)

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

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

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

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




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

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


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





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


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

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



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


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

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

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

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

  # rolled back 26.4.2016: did not really prove successful

}





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


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


Interval <- function(x, y){

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

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

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

  unname(d)
}


`%overlaps%` <- function(x, y) {
  if(length(x) < 2L) x <- rep(x, 2L)
  if(length(y) < 2L) y <- rep(y, 2L)
  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), 1L, min), apply(rbind(x), 1L, max))
  y <- cbind(apply(rbind(y), 1L, min), apply(rbind(y), 1L, max))

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

  # 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[, 2L]
  idx <- x[, 2L] > y[, 2L]
  d1[idx] <- y[idx, 2L]

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

  d <- d1 - d2

  d[d <= 0L ] <- 0L

  unname(d)

}


AllIdentical <- function(...){
  lst <- list(...)
  # identical ought to be transitive, so if A is identical to C and to D, then C should be identical to D
  
  # all(sapply(lst[-1], identical, lst[[1]]))
  
  # we might not need to compare all elements
  for(i in seq_along(lst)[-1]){
    
    if(!identical(lst[[i]], lst[[1]])){
      # we can stop after the first inequality
      return(FALSE)
    }
  }
  return(TRUE)
  
  # 3 times faster than original
  
  # library(microbenchmark)
  # microbenchmark(
  #   orig = AllIdentical(A, B, C, D, E),
  #   A = AllIdenticalA(A, B, C, D, E), 
  #   times  = 2000L
  # )
  
  
}




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



Bun <- function(..., na.rm=FALSE){
  # unites a list of binary vectors elementwise using max
  lst <- list(...)
  (apply(do.call(cbind, lst), 1, sum, na.rm=na.rm) > 0)*1
}



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,, drop=FALSE] }
    , "sum" = { res <- contr.sum(n = nlevels(x))[x,, drop=FALSE] }
    , "helmert" = { res <- contr.helmert(n = nlevels(x))[x,, drop=FALSE] }
    , "poly" = { res <- contr.poly(n = nlevels(x))[x,, drop=FALSE] }
    , "full" = { res <- diag(nlevels(x))[x,, drop=FALSE] }
  )
  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))) 1L:length(x) else names(x), levels(x))
    attr(res, "base") <- NA
  } else {
    dimnames(res) <- list(if(is.null(names(x))) 1L: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.null","is.finite"), flatten=TRUE) {
  # Returns the first element in x which is not NA

  # problem: if we want the first list element of ... which is not NULL
  # the function fails and returns the first element of this list element
  # by using unlist().
  # An alternative would be: Filter(Negate(is.null), list(...))
  
  if(...length() > 1L) {
    if(all(lapply(list(...), length) > 1L)){
      lst <- data.frame(..., stringsAsFactors = FALSE)
    } else {
        lst <- list(...)
        if(flatten) lst <- unlist(lst)
    }
  } else {
    if(is.matrix(...)) {
      lst <- data.frame(..., stringsAsFactors = FALSE)
    } else {
      lst <- (...)
    }
  }
  
  switch(match.arg(method, choices=c("is.na", "is.null", "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), lst)
      
      "is.na"     = res <- 
        Reduce(function (x, y){ 
              i <- which(is.na(x))
              x[i] <- y[i]
              return(x)
            }, lst) ,

      "is.null"     = res <- 
        Reduce(function (x, y){ 
          i <- which(is.null(x))
          x[i] <- y[i]
          return(x)
        }, lst) ,
      
      "is.finite"     = res <- 
        Reduce(function (x, y){ 
          i <- which(is.finite(x))
          x[i] <- y[i]
          return(x)
        }, lst) 
  )
  
  return(res)
}


# lightning fast:
#
# coalesce2 <- function(...) {
#   Reduce(function(x, y) {
#     i <- which(is.na(x))
#     x[i] <- y[i]
#     return(x)
#   },
#   list(...))
# }




# defunct by 0.99.26
# 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))
    abs(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 %% 2L == 1L


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

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

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) == 0L)
    stop("Argument 'x' must be a nonempty vector or matrix.")
  if (!is.numeric(x) || any(x < 0L) || any(x != round(x)))
    stop("All entries of 'x' must be nonnegative integers.")

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


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

  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=2L)[(length(x) - k+1L):(2L*length(x)-k)]
}



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

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

  if(k < 0L){
    c(x[-k:length(x)], rep(NA, -k))
  } else {
    c(rep(NA, k), x[1L:(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") || identical(class(x), "list") ) {

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



GetCalls <- function (fun, alphabetic = TRUE, package=NULL) {
  
  tmp <- utils::getParseData(parse(text = getAnywhere(fun), keep.source = TRUE))
  nms <- tmp$text[which(tmp$token == "SYMBOL_FUNCTION_CALL")]
  funs <- unique(if (alphabetic) {
    sort(nms)
  } else {
    nms
  })
  
  src <- paste(as.vector(sapply(funs, find)))
  outlist <- tapply(funs, factor(src), c)
  
  if(!is.null(package))
    outlist <- outlist[grep(package, names(outlist))]
  return(outlist)
}



What <- function(x){

  list(mode=mode(x), typeof=typeof(x), storage.mode=storage.mode(x),
       dim=dim(x), length=length(x),class=class(x))
}



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)
  
  if(by != "row.names"){
    # set the columnname for the value according to the group level
    # in order to avoid duplicate names in Reduce() down the road ...
    for(i in seq(s)){
      colnames(s[[i]])[1] <- names(s)[i]
    }
  }
  
  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(options(opt))
  sink()
  if (closeit)
    close(file)
  if (is.null(rval))
    invisible(NULL)
  else rval

}



# Maybe an alternative later down the road...

# https://www.r-bloggers.com/performance-captureoutput-is-much-faster-than-capture-output/
# R.Utils::captureOutput() is much faster than utils::capture.output()
# 
# function (expr, file = NULL, append = FALSE, collapse = NULL, 
#           envir = parent.frame()) 
# {
#   if (is.null(file)) 
#     file <- raw(0L)
#   if (identical(file, character(0L))) 
#     file <- NULL
#   if (is.raw(file)) {
#     res <- eval({
#       file <- rawConnection(raw(0L), open = "w")
#       on.exit({
#         if (!is.null(file)) close(file)
#       })
#       capture.output(expr, file = file)
#       res <- rawConnectionValue(file)
#       close(file)
#       file <- NULL
#       res <- rawToChar(res)
#       res
#     }, envir = envir, enclos = envir)
#   }
#   else {
#     res <- eval({
#       capture.output(expr, file = file, append = append)
#     }, envir = envir, enclos = envir)
#     return(invisible(res))
#   }
#   res <- unlist(strsplit(res, split = "\n", fixed = TRUE), 
#                 use.names = FALSE)
#   if (!is.null(collapse)) 
#     res <- paste(res, collapse = collapse)
#   res
# }




Ndec <- function(x) {
  # liefert die Anzahl der Nachkommastellen einer Zahl x
  # Alternative auch format.info [1]... Breite, [2]...Anzahl Nachkommastellen, [3]...Exponential ja/nein
  stopifnot(class(x)=="character")

  res <- rep(0, length(x))
  # remove evtl. exponents
  x <- gsub(pattern="[eE].+$", replacement="", x=x)
  res[grep("\\.",x)] <- nchar( sub("^.+[.]","",x) )[grep("\\.",x)]

  return(res)

}


Prec <- function (x) {

  # Function to return the most precise
  # digit from a vector of real numbers
  # Keep dividing by powers of 10 (pos and neg from trunc(log(max(x)) down)
  # until the fractional portion is zero, then we have the highest precision
  # digit in terms of a integer power of 10.

  # Thanks to Thomas Lumley for help with machine precision

  # Note:  Turn this into a standalone function for "regularizing" a
  #        time-activity object with irregular time breaks.

  init <- trunc(log10(max(x))) + 1
  zero <- 0
  y <- 1
  while (any(y > zero)) {
    init <- init - 1
    x1 <- x*10^(-init)
    y <- x1 - trunc(x1)
    zero <- max(x1)*.Machine$double.eps
  }
  10^init

  # sapply(c(1.235, 125.3, 1245), prec)

}

# other idea:
# precision <- function(x) {
#   rng <- range(x, na.rm = TRUE)
#
#   span <- if (zero_range(rng)) rng[1] else diff(rng)
#   10 ^ floor(log10(span))
# }






# References:
# http://stackoverflow.com/questions/3443687/formatting-decimal-places-in-r
# http://my.ilstu.edu/~jhkahn/apastats.html
# https://en.wikipedia.org/wiki/Significant_figures
# http://www.originlab.com/doc/Origin-Help/Options-Dialog-NumFormat-Tab

Format <- function(x, digits = NULL, sci = NULL
                   , big.mark=NULL, ldigits = NULL
                   , zero.form = NULL, na.form = NULL
                   , fmt = NULL, align = NULL, width = NULL
                   , lang = NULL,  eps = NULL, ...){
  UseMethod("Format")
}


# replaced by 0.99.26
# Format.data.frame <- function(x, digits = NULL, sci = NULL
#                           , big.mark=NULL, leading = NULL
#                           , zero.form = NULL, na.form = NULL
#                           , fmt = NULL, align = NULL, width = NULL, lang = NULL, ...){
#
#   x[] <- lapply(x, Format, digits = digits,
#                 sci = sci, big.mark = big.mark, leading = leading, zero.form = zero.form,
#                 na.form = na.form, fmt = fmt, align = align, width = width,
#                 lang = lang, ...)
#
#   class(x) <- c("Format", class(x))
#   return(x)
#
# }


Format.data.frame <- function(x, digits = NULL, sci = NULL
                              , big.mark=NULL, ldigits = NULL
                              , zero.form = NULL, na.form = NULL
                              , fmt = NULL, align = NULL, width = NULL, lang = NULL, eps = NULL, ...){

  # organise arguments as list ...
  lst <- list(digits=digits, sci=sci, big.mark=big.mark, ldigits=ldigits,
              zero.form=zero.form, na.form=na.form, fmt=fmt, align=align,
              width=width, lang=lang, eps=eps)
  # ... in order to be able to filter NULLs
  lst <- lst[!sapply(lst, is.null)]
  # and recyle them to the number of columns
  arg <- do.call(Recycle, c(lst, list(rep(1, ncol(x)))))

  for(i in seq(attr(arg, "maxdim")))
    x[,i] <- Format(x[,i], digits = arg$digits[i],
                    sci = arg$sci[i], big.mark = arg$big.mark[i], ldigits = arg$ldigits[i],
                    zero.form = arg$zero.form[i],
                    na.form = arg$na.form[i], fmt = arg$fmt[i], align = arg$align[i],
                    width = arg$width[i], lang = arg$lang[i], eps= arg$eps[i])

  class(x) <- c("Format", class(x))
  return(x)

}


Format.matrix <- function(x, digits = NULL, sci = NULL
                           , big.mark=NULL, ldigits = NULL
                           , zero.form = NULL, na.form = NULL
                           , fmt = NULL, align = NULL, width = NULL, lang = NULL,  eps = NULL, ...){

  x[,] <- Format.default(x=x, digits=digits, sci=sci, big.mark=big.mark,
                         ldigits=ldigits, zero.form=zero.form, na.form=na.form,
                         fmt=fmt, align=align, width=width, lang=lang, eps=eps,...)

  class(x) <- c("Format", class(x))
  return(x)
}


Format.table <- function(x, digits = NULL, sci = NULL
                          , big.mark = NULL, ldigits = NULL
                          , zero.form = NULL, na.form = NULL
                          , fmt = NULL, align = NULL, width = NULL, lang = NULL,  eps = NULL, ...){
  x[] <- Format.default(x=x, digits=digits, sci=sci, big.mark=big.mark,
                        ldigits=ldigits, zero.form=zero.form, na.form=na.form,
                         fmt=fmt, align=align, width=width, lang=lang, eps=eps, ...)

  class(x) <- c("Format", class(x))
  return(x)
}


Format.ftable <- function(x, digits = NULL, sci = NULL, big.mark = NULL,
                          ldigits = NULL, zero.form = NULL, na.form = NULL,
                          fmt = NULL, align = NULL, width = NULL, lang = NULL, 
                          eps = NULL, ...){
  
  # convert ftable first to matrix, then to data.frame in order to 
  # apply recycled arguments columnwise, which is a common need
  res <- Format(as.data.frame(as.matrix(x)), digits = digits, sci = sci, big.mark = big.mark,
                ldigits = ldigits, zero.form = zero.form, na.form = na.form,
                fmt = fmt, align = align, width = width, lang = lang, 
                eps = eps, ...)
  
  x[] <- as.matrix(res)
  
  return(x)
  
}


as.CDateFmt <- function(fmt) {

  # fine format codes
  # http://www.autohotkey.com/docs/commands/FormatTime.htm

  pat <- ""
  fpat <- ""

  i <- 1
  # we used here:
  #       if(length(grep("\\bd{4}\\b", fmt)) > 0)
  # which found dddd only as separated string from others (\b ... blank)
  # this is not suitable for formats like yyyymmdd
  # hence this was changed to d{4}

  #      if(length(grep("\\bd{4}\\b", fmt)) > 0) {
  if(length(grep("d{4}", fmt)) > 0) {
    fmt <- gsub(pattern = "dddd", replacement = paste("\\\\", i, sep=""), x = fmt)
    pat <- paste(pat, "(.+)-", sep="")
    fpat <- paste(fpat, "%A-", sep="")
    i <- i+1
  }
  #      if(length(grep("\\bd{3}\\b", fmt)) > 0) {
  if(length(grep("d{3}", fmt)) > 0) {
    fmt <- gsub(pattern = "ddd", replacement = paste("\\\\", i, sep=""), x = fmt)
    pat <- paste(pat, "(.+)-", sep="")
    fpat <- paste(fpat, "%a-", sep="")
    i <- i+1
  }
  if(length(grep("d{2}", fmt)) > 0) {
    fmt <- gsub(pattern = "dd", replacement = paste("\\\\", i, sep=""), x = fmt)
    pat <- paste(pat, "(.+)-", sep="")
    fpat <- paste(fpat, "%d-", sep="")
    i <- i+1
  }
  if(length(grep("d{1}", fmt)) > 0) {
    fmt <- gsub(pattern = "d", replacement = paste("\\\\", i, sep=""), x = fmt)
    pat <- paste(pat, "0?(.+)-", sep="")
    fpat <- paste(fpat, "%e-", sep="")
    i <- i+1
  }
  if(length(grep("m{4}", fmt)) > 0) {
    fmt <- gsub(pattern = "mmmm", replacement = paste("\\\\", i, sep=""), x = fmt)
    pat <- paste(pat, "(.+)-", sep="")
    fpat <- paste(fpat, "%B-", sep="")
    i <- i+1
  }
  if(length(grep("m{3}", fmt)) > 0) {
    fmt <- gsub(pattern = "mmm", replacement = paste("\\\\", i, sep=""), x = fmt)
    pat <- paste(pat, "(.+)-", sep="")
    fpat <- paste(fpat, "%b-", sep="")
    i <- i+1
  }
  if(length(grep("m{2}", fmt)) > 0) {
    fmt <- gsub(pattern = "mm", replacement = paste("\\\\", i, sep=""), x = fmt)
    pat <- paste(pat, "(.+)-", sep="")
    fpat <- paste(fpat, "%m-", sep="")
    i <- i+1
  }
  if(length(grep("m{1}", fmt)) > 0) {
    fmt <- gsub(pattern = "m", replacement = paste("\\\\", i, sep=""), x = fmt)
    pat <- paste(pat, "0?(.+)-", sep="")
    fpat <- paste(fpat, "%m-", sep="")
    i <- i+1
  }
  if(length(grep("y{4}", fmt)) > 0) {
    fmt <- gsub(pattern = "yyyy", replacement = paste("\\\\", i, sep=""), x = fmt)
    pat <- paste(pat, "(.+)-", sep="")
    fpat <- paste(fpat, "%Y-", sep="")
    i <- i+1
  }
  if(length(grep("y{2}", fmt)) > 0) {
    fmt <- gsub(pattern = "yy", replacement = paste("\\\\", i, sep=""), x = fmt)
    pat <- paste(pat, "(.+)-", sep="")
    fpat <- paste(fpat, "%y-", sep="")
    i <- i+1
  }
  if(length(grep("y{1}", fmt)) > 0) {
    fmt <- gsub(pattern = "y", replacement = paste("\\\\", i, sep=""), x = fmt)
    pat <- paste(pat, "0?(.+)-", sep="")
    fpat <- paste(fpat, "%y-", sep="")
    i <- i+1
  }

  sub(pat, fmt, fpat)


}




Format.default <- function(x, digits = NULL, sci = NULL
                           , big.mark = NULL, ldigits = NULL
                           , zero.form = NULL, na.form = NULL
                           , fmt = NULL, align = NULL, width = NULL
                           , lang = NULL
                           , eps = NULL, ...){
  
  
  .format.pval <- function(x, eps, digits=NULL){
    # format p-values  *********************************************************
    # this is based on original code from format.pval
    
    if(is.null(digits))
      digits <- NA
    digits <- rep(digits, length.out=3)
    
    r <- character(length(is0 <- x < eps))
    if (any(!is0)) {
      rr <- x <- x[!is0]
      expo <- floor(log10(ifelse(x > 0, x, 1e-50)))
      fixp <- (expo >= -3)
      
      if (any(fixp))
        rr[fixp] <- Format(x[fixp], digits=Coalesce(digits[1], 4))
      
      if (any(!fixp))
        rr[!fixp] <- format(x[!fixp], digits=Coalesce(digits[2], 3), scientific=TRUE)
      
      r[!is0] <- rr
    }
    if (any(is0)) {
      r[is0] <- gettextf("< %s", format(eps, digits = Coalesce(digits[3], 2)))
    }
    
    return(r)
    
  }
  
  .format.stars <- function(x){
    # format significance stars  ***************************************************
    # example: Format(c(0.3, 0.08, 0.042, 0.001), fmt="*")
    
    breaks <- c(0,0.001,0.01,0.05,0.1,1)
    labels <- c("***","** ","*  ",".  ","   ")
    res <- as.character(sapply(x, cut, breaks=breaks, labels=labels, include.lowest=TRUE))
    
    return(res)
    
  }
  
  .format.pstars <- function(x, eps, digits)
    paste(.format.pval(x, eps, digits), .format.stars(x))
  
  # .leading.zero <- function(x, n, big.mark=NULL){
  #   # just add a given number of leading zeros
  #   # split at the decimal separator
  #   outdec <- getOption("OutDec")
  #   z <- strsplit(as.character(x), split=outdec, fixed = TRUE)
  #   # left side
  #   zl <- lapply(z, "[", 1)
  #   zl <- sapply(zl, function(x) sprintf(paste0("%0", n + (x<0)*1, "i"), as.numeric(x)))
  #   # right side
  #   zr <- sapply(z, "[", 2)
  #   zr <- ifelse(is.na(zr), "", paste(outdec, zr, sep=""))
  #   
  #   paste(zl, zr, sep="")
  #   
  # }
  
  .leading.zero <- function(x, n, big.mark=NULL){
    # just add a given number of leading zeros
    # split at the decimal separator
    outdec <- getOption("OutDec")
    z <- strsplit(as.character(x), split=outdec, fixed = TRUE)
    # left side
    zl <- lapply(z, "[", 1)
    zl <- sapply(zl, 
                 function(x) {
                   # remove big.marks
                   if(!is.null(big.mark))
                     x <- gsub(big.mark, "", x)
                   # append leading 0s
                   res <- sprintf(paste0("%0", n + (x<0)*1, "i"), 
                                  as.numeric(x))
                   if(!is.null(big.mark))
                     # restore big.marks
                     res <- StrRev(paste(StrChop(StrRev(res), 
                                                 len = rep(3, times=nchar(res) %/% 3 + ((nchar(res) %% 3)!=0)*1L)), collapse=big.mark))
                   return(res)
                 })
    # right side
    zr <- sapply(z, "[", 2)
    zr <- ifelse(is.na(zr), "", paste(outdec, zr, sep=""))
    
    paste(zl, zr, sep="")
    
  }
  
  
  .format.eng <- function(x, digits = NULL, ldigits = 1
                          , zero.form = NULL, na.form = NULL){
    
    s <- lapply(strsplit(format(x, scientific=TRUE), "e"), as.numeric)
    y <- unlist(lapply(s, "[[", 1))
    pwr <- unlist(lapply(s, "[", 2))
    
    return(paste(Format(y * 10^(pwr %% 3), digits=digits, ldigits=ldigits,
                        zero.form = zero.form, na.form=na.form)
                 , "e"
                 , c("-","+")[(pwr >= 0) + 1]
                 , Format(abs((pwr - (pwr %% 3))), ldigits = 2, digits=0)
                 , sep="")
    )
    
  }
  
  .format.engabb <- function(x, digits = NULL, ldigits = 1
                             , zero.form = NULL, na.form = NULL){
    
    s <- lapply(strsplit(format(x, scientific=TRUE), "e"), as.numeric)
    y <- unlist(lapply(s, "[[", 1))
    pwr <- unlist(lapply(s, "[", 2))
    
    a <- paste("1e"
               , c("-","+")[(pwr >= 0) + 1]
               , Format(abs((pwr - (pwr %% 3))), ldigits=2, digits=0)
               , sep="")
    am <- d.prefix$abbr[match(as.numeric(a), d.prefix$mult)]
    
    a[!is.na(am)] <- am[!is.na(am)]
    a[a == "1e+00"] <- ""
    
    return(paste(Format(y * 10^(pwr %% 3), digits=digits, ldigits=ldigits,
                        zero.form = zero.form, na.form=na.form)
                 , " " , a
                 , sep="")
    )
    
  }
  
  #   We accept here a fmt class to be used as user templates
  #   example:
  #
  #   fmt.int <- structure(list(
  #     digits = 5, sci = getOption("scipen"), big.mark = "",
  #     leading = NULL, zero.form = NULL, na.form = NULL,
  #     align = "left", width = NULL, txt="(%s), %s - CHF"), class="fmt"
  #   )
  #
  #   Format(7845, fmt=fmt.int)
  
  if(!is.null(InDots(..., arg = "leading", default=NULL)))
    warning("Argument 'leading' is not supported anymore, use 'ldigits' (see help)!")
  
  if(is.null(fmt)) fmt <- ""
  
  if (length(fmt) == 1) 
    if(is.character(fmt) && (fmt %in% names(DescToolsOptions("fmt")))) {
      fmt <- Fmt(fmt)
    }  
  
  if(inherits(x=fmt, what="fmt")) {
    
    # we want to offer the user the option to overrun format definitions
    # consequence is, that all defaults of the function must be set to NULL
    # as we cannot distinguish between defaults and user sets else
    
    if(!is.null(digits))    fmt$digits <- digits
    if(!is.null(sci))       fmt$sci <- sci
    if(!is.null(big.mark))  fmt$big.mark <- big.mark
    if(!is.null(ldigits))   fmt$ldigits <- ldigits
    if(!is.null(zero.form)) fmt$zero.form <- zero.form
    if(!is.null(na.form))   fmt$na.form <- na.form
    if(!is.null(align))     fmt$align <- align
    if(!is.null(width))     fmt$sci <- width
    if(!is.null(lang))      fmt$lang <- lang
    if(!is.null(eps))       fmt$eps <- eps
    
    return(do.call(Format, c(fmt, x=list(x))))
  }
  
  # The defined decimal character:
  # getOption("OutDec")
  
  # replaced by 0.99.26: this was not a good default, sci is easy to set
  
  # # set the defaults, if user says nothing
  # if(is.null(sci))
  #   if(is.null(digits)){
  #     # if given digits and sci NULL set sci to Inf
  #     sci <- getOption("scipen", default = 7)
  #   } else {
  #     sci <- Inf
  #   }
  
  # if sci is not set at all, the default will be 0, which leads to all numbers being
  # presented as scientific - this is definitely nonsense...
  if(is.null(sci))
    sci <- Coalesce(NAIfZero(getOption("scipen")), 7) # default
  
  sci <- rep(sci, length.out=2)
  
  if(is.null(eps))
    eps <- .Machine$double.eps
  
  if(is.null(big.mark)) big.mark <- ""
  
  
  if(is.null(na.form)) na.form <- NA_real_
  
  # store index of missing values in ina
  if ((has.na <- any(ina <- is.na(x))))
    x <- x[!ina]
  
  
  if(is.function(fmt)){
    
    r <- fmt(x)
    
  } else if(all(inherits(x=x, what="Date"))) {
    
    # the language is only needed for date formats, so avoid looking up the option
    # for other types
    if(is.null(lang)) lang <- DescToolsOptions("lang")
    
    if(lang=="engl"){
      loc <- Sys.getlocale("LC_TIME")
      Sys.setlocale("LC_TIME", "C")
      on.exit(Sys.setlocale("LC_TIME", loc))
    }
    
    r <- format(x, as.CDateFmt(fmt=fmt))
    
  } else if(all(class(x) %in% c("character","factor","ordered"))) {
    r <- format(x)
    
  } else if(fmt=="*"){
    r <- .format.stars(x)
    
  } else if(fmt=="p"){
    r <- .format.pval(x, eps, digits)
    
  } else if(fmt=="p*"){
    r <- .format.pstars(x, eps, digits)
    
  } else if(fmt=="eng"){
    r <- .format.eng(x, digits=digits, ldigits=ldigits, zero.form=zero.form, na.form=na.form)
    
  } else if(fmt=="engabb"){
    r <- .format.engabb(x, digits=digits, ldigits=ldigits, zero.form=zero.form, na.form=na.form)
    
  } else if(fmt=="e"){
    r <- formatC(x, digits = digits, width = width, format = "e",
                 big.mark=big.mark, zero.print = zero.form)
    
  } else if(fmt=="%"){
    # we use 1 digit as default here
    r <- paste(suppressWarnings(formatC(x * 100,
                                        digits = ifelse(is.null(digits), 1, digits),
                                        width = width, format = "f",
                                        big.mark=big.mark, drop0trailing = FALSE)),
               "%", sep="")
    
  } else if(fmt=="frac"){
    
    r <- as.character(MASS::fractions(x))
    
  } else {  # format else   ********************************************
    
    if(fmt != "")
      warning(gettextf("Non interpretable fmt code will be ignored.", fmt))
    
    if(identical(sci, NA)) {
      # use is.na(sci) to inhibit scientific notation
      r <- formatC(x, digits = digits, width = width, format = "f",
                   big.mark=big.mark)
    } else {
      
      # so far a numeric value, interpret negative digits
      if(!is.null(digits) && digits < 0){
        x <- round(x, digits=digits)
        digits <- 0
      }
      
      idx <- (((abs(x) > .Machine$double.eps) & (abs(x) <= 10^-sci[2])) | (abs(x) >= 10^sci[1]))
      r <- as.character(rep(NA, length(x)))
      
      # use which here instead of res[idx], because of NAs
      #   formatC is barking, classes are of no interess here, so suppress warning...
      #   what's that exactly??
      r[which(idx)] <- suppressWarnings(formatC(x[which(idx)], digits = digits, width = width, format = "e",
                                                big.mark=big.mark, drop0trailing = FALSE))
      
      #     Warning messages:
      #     1: In formatC(x[which(!idx)], digits = digits, width = width, format = "f",  :
      #                       class of 'x' was discarded
      #     formatC is barking, classes are of no interess here, so suppress warning...
      r[which(!idx)] <- suppressWarnings(formatC(x[which(!idx)], digits = digits, width = width, format = "f",
                                                 big.mark=big.mark, drop0trailing = FALSE))
    }
    
    if(!is.null(ldigits)){
      # handle leading zeros ------------------------------
      if(ldigits == 0) {
        # drop leading zeros
        r <- gsub("(?<![0-9])0+\\.", "\\.", r, perl = TRUE)
        
        # alternative:
        # res <- gsub("(-?)[^[:digit:]]0+\\.", "\\.", res)
        
        # old: mind the minus
        # res <- gsub("[^[:digit:]]0+\\.","\\.", res)
        
      } else {
        r <- .leading.zero(r, ldigits, big.mark = big.mark)
      }
    }
    
  }
  
  if(!is.null(zero.form))
    r[abs(x) < eps] <- zero.form
  
  
  if (has.na) {
    rok <- r
    r <- character(length(ina))
    r[!ina] <- rok
    r[ina] <- na.form
  }
  
  
  if(!is.null(align)){
    r <- StrAlign(r, sep = align)
  }
  
  
  class(r) <- c("Format", class(r))
  return(r)
  
}



print.Format <- function (x, quote=FALSE, ...) {

  class(x) <- class(x)[class(x)!="Format"]
  # print(x, quote=FALSE, right=TRUE, ...)
  NextMethod("print", quote = quote, right=TRUE, ...)
}



Fmt <- function(...){

  # get format templates and modify on the fly, e.g. other digits
  # x is the name of the template

  def <- structure(
    list(
      abs=structure(list(digits = 0, big.mark = "'"),
                    label = "Number format for counts",
                    name="abs",
                    default=TRUE, class = "fmt"),
      per=structure(list(digits = 1, fmt = "%"),
                    label = "Percentage number format",
                    name="per",
                    default=TRUE, class = "fmt"),
      num=structure(list(digits = 0, big.mark = "'"),
                    label = "Number format for floating points",
                    name="num",
                    default=TRUE, class = "fmt")
    ), name="fmt")

  # get a format from the fmt templates options
  res <- DescToolsOptions("fmt")

  # find other defined fmt in .GlobalEnv and append to list
  # found <- ls(parent.frame())[ lapply(lapply(ls(parent.frame()), function(x) gettextf("class(%s)", x)),
  #                     function(x) eval(parse(text=x))) == "fmt" ]
  # if(length(found)>0){
  #   udf <- lapply(found, function(x) eval(parse(text=x)))
  #   names(udf) <- found
  # }

  # collect all found formats, defaults included if not set as option
  # abs, per and num must always be available, even if not explicitly defined
  res <- c(res, def[names(def) %nin% names(res)]) #, udf)


  # get additional arguments
  dots <- list(...)
  # leave away all NULL values, these should not overwrite the defaults below
  #dots <- dots[!is.null(dots)]


  # functionality:
  # Fmt()                 return all from options
  # Fmt("abs")            return abs
  # Fmt("abs", digits=3)  return abs with updated digits
  # Fmt(c("abs","per"))   return abs and per

  # Fmt(nob=as.Fmt(digits=10, na.form="nodat"))  set nob


  if(length(dots)==0){
    # no arguments supplied
    # return list of defined formats

    # just return(res)

  } else {
    # some dots supplied
    # if first unnamed and the rest named, take as format name and overwrite other

    if(is.null(names(dots))){
      # if not names at all
      # select the requested ones by name, the unnamed ones
      fnames <- unlist(dots[is.null(names(dots))])
      res <- res[fnames]

      # return(res)

    } else {

      if(all(names(dots)!="")){
        # if only names (no unnamed), take name as format name and define format

        old <- options("DescTools")[[1]]
        opt <- old

        for(i in seq_along(dots))
          attr(dots[[i]], "name") <- names(dots)[[i]]

        opt$fmt[[names(dots)]] <- dots[[names(dots)]]
        options(DescTools=opt)

        # same behaviour as options
        invisible(old)

      } else {

        # select the requested ones by name, the unnamed ones
        fnames <- unlist(dots[names(dots)==""])
        res <- res[fnames]

        # modify additional arguments in the template definition
        for(z in names(res)){
          if(!is.null(res[[z]])){
            # use named dots, but only those which are not NULL
            idx <- names(dots) != "" & !sapply(dots[names(dots)], is.null)
#           res[[z]][names(dots[names(dots)!=""])] <- dots[names(dots)!=""]
            res[[z]][names(dots[idx])] <- dots[idx]
          }
        }

        # return(res)
      }
    }

  }

  # simplify list
  if(length(res)==1) res <- res[[1]]

  return(res)


}


# this does not work...

# `Fmt<-` <- function (name, value){
#   opt <- options("DescTools")
#   opt$fmt[[name]] <- value
#   DescToolsOptions(opt)
# }




#
#
# # define some format templates
# .fmt_abs <- function()
#     getOption("fmt.abs", structure(list(digits=0,
#                                         big.mark="'"), class="fmt"))
# # there is an option Sys.localeconv()["thousands_sep"], but we can't change it
#

# .fmt_per <- function(digits=NULL){
#
#   # we could use getOption("digits") as default here, but this is normally not a good choice
#   # as numeric digits and percentage digits usually differ
#   res <- getOption("fmt.per", structure(list(digits=1,
#                                       fmt="%"), class="fmt"))
#   # overwrite digits if given
#   if(!is.null(digits))
#      res["digits"] <- digits
#   return(res)
# }
#

# .fmt_num <- function(digits = NULL){
#   # check if fmt is defined
#   res <- getOption("fmt.num")
#
#   # if not: use a default, based on digfix
#   if(is.null(res))
#     res <- structure(list(digits=Coalesce(digits, DescToolsOptions("digits"), 3),
#                           big.mark=Sys.localeconv()["thousands_sep"]),
#                      class="fmt")
#   else
#   # if exists overwrite digits
#     if(!is.null(digits)) res$digits <- digits
#   # what should we do, when digits are neither defined in fmt.num nor given
#   # in case the fmt.num exists?
#
#   return(res)
# }



# .fmt <- function()
#   getOption("fmt", default = list(
#     per=structure(list(digits=1, fmt="%"), name="per", label="Percentage number format", class="fmt")
#     ,	num=structure(list(digits=getOption("digfix", default=3), big.mark=Sys.localeconv()["thousands_sep"]), name="num", label="Number format for floating points", class="fmt")
#     , abs=structure(list(digits=0, big.mark=Sys.localeconv()["thousands_sep"]), name="abs", label="Number format for counts", class="fmt")
# ) )
#




print.fmt <- function(x, ...){

  CollapseList <- function(x){
    z <- x
    # opt <- options(useFancyQuotes=FALSE); on.exit(options(opt))
    z[unlist(lapply(z, inherits, "character"))] <- shQuote(z[unlist(lapply(z, inherits, "character"))])
    z <- paste(names(z), "=", z, sep="", collapse = ", ")

    return(z)
  }

  cat(gettextf("Format name:    %s%s\n", attr(x, "fmt_name"), 
               ifelse(identical(attr(x, "default"), TRUE), " (default)", "")),  
      gettextf("Description:   %s\n", Label(x)),
      gettextf("Definition:    %s\n", CollapseList(x)),
      gettextf("Example:       %s\n", Format(pi * 1e5, fmt=x))
  )
}




Frac <- function(x, dpwr = NA) {  # fractional part
  res <- abs(x) %% 1
  # Alternative: res <- abs(x-trunc(x))
  if (!missing(dpwr)) res <- round(10^dpwr * res)
  res
}


MaxDigits <- function(x){
  # How to find the significant digits of a number?
  z <- na.omit(unlist(
    lapply(strsplit(as.character(x),
                    split = getOption("OutDec"), fixed = TRUE),
           "[", 2)))
  if(length(z)==0)
    res <- 0
  else
    res <- max(nchar(z))

  return(res)

  # Alternative: Sys.localeconv()["decimal_point"]
}




Recycle <- function(...){
  lst <- list(...)

  # optimization suggestion by moodymudskipper 20.11.2019  
  maxdim <- max(lengths(lst)) # instead of max(unlist(lapply(lst, length)))
  # recycle all params to maxdim
  # res <- lapply(lst, rep_len, length.out=maxdim)
  
  # rep_len would not work for Dates
  res <- lapply(lst, rep, length.out=maxdim)
  
  attr(res, "maxdim") <- maxdim

  return(res)
}



###


## stats: strata sampling ----------------

Strata <- function (x, stratanames = NULL, size = 1,
                    method = c("srswor", "srswr", "poisson", "systematic"),
                    pik, description = FALSE) {

  method <- match.arg(method, c("srswor", "srswr", "poisson", "systematic"))

  # find non factors in stratanames
  factor_fg <- unlist(lapply(x[, stratanames, drop=FALSE], is.factor))
  # factorize nonfactors, get their levels and combine with levels of existing factors
  lvl <- c(lapply(lapply(x[,names(which(!factor_fg)), drop=FALSE], factor), levels)
           , lapply(x[,names(which(factor_fg)), drop=FALSE], levels))

  # get the stratanames in the given order
  strat <- expand.grid(lvl[stratanames])
  strat$stratum <- factor(1:nrow(strat))

  # set the size for the strata to sample
  strat$size <- rep(size, length.out=nrow(strat))

  # prepare the sample
  x <- merge(x, strat)
  x$id <- 1:nrow(x)
  n <- table(x$stratum)

  if(method %in% c("srswor", "srswr")) {
    res <- do.call(rbind,
                   lapply(split(x, x$stratum),
                          function(z){
                            if(nrow(z)>0){
                              idx <- sample(x=nrow(z), size=z$size[1], replace=(method=="srswr"))
                              z[idx,]
                            } else {
                              z
                            }
                          }
                   )
    )
  } else if(method == "poisson") {

    # still to implement!!!  *********************
    res <- do.call(rbind,
                   lapply(split(x, x$stratum),
                          function(z){
                            if(nrow(z)>0){
                              idx <- sample(x=nrow(z), size=z$size[1], replace=(method=="srswr"))
                              z[idx,]
                            } else {
                              z
                            }
                          }
                   )
    )
  } else if(method == "systematic") {

    # still to implement!!!  *********************
    res <- do.call(rbind,
                   lapply(split(x, x$stratum),
                          function(z){
                            if(nrow(z)>0){
                              idx <- sample(x=nrow(z), size=z$size[1], replace=(method=="srswr"))
                              z[idx,]
                            } else {
                              z
                            }
                          }
                   )
    )
  }

  return(res)

}



# Strata <- function (data, stratanames = NULL, size,
#                     method = c("srswor", "srswr", "poisson", "systematic"),
#                     pik, description = FALSE)
# {
#
# #  Author: Yves Tille <yves.tille@unine.ch>, Alina Matei <alina.matei@unine.ch>
# #  source: library(sampling)
#
#   inclusionprobabilities <- function (a, n)
#   {
#     nnull = length(a[a == 0])
#     nneg = length(a[a < 0])
#     if (nnull > 0)
#       warning("there are zero values in the initial vector a\n")
#     if (nneg > 0) {
#       warning("there are ", nneg, " negative value(s) shifted to zero\n")
#       a[(a < 0)] = 0
#     }
#     if (identical(a, rep(0, length(a))))
#       pik1 = a
#     else {
#       pik1 = n * a/sum(a)
#       pik = pik1[pik1 > 0]
#       list1 = pik1 > 0
#       list = pik >= 1
#       l = length(list[list == TRUE])
#       if (l > 0) {
#         l1 = 0
#         while (l != l1) {
#           x = pik[!list]
#           x = x/sum(x)
#           pik[!list] = (n - l) * x
#           pik[list] = 1
#           l1 = l
#           list = (pik >= 1)
#           l = length(list[list == TRUE])
#         }
#         pik1[list1] = pik
#       }
#     }
#     pik1
#   }
#
#   srswor <- function (n, N)
#   {
#     s <- rep(0, times = N)
#     s[sample(N, n)] <- 1
#     s
#   }
#
#   srswr <-  function (n, N)
# #    as.vector(rmultinom(1, n, rep(n/N, times = N)))
#     if(n==0) rep(0, N) else as.vector(rmultinom(1, n, rep(n/N, times = N)))
#
#
#   UPsystematic <- function (pik, eps = 1e-06)
#   {
#     if (any(is.na(pik)))
#       stop("there are missing values in the pik vector")
#     list = pik > eps & pik < 1 - eps
#     pik1 = pik[list]
#     N = length(pik1)
#     a = (c(0, cumsum(pik1)) - runif(1, 0, 1))%%1
#     s1 = as.integer(a[1:N] > a[2:(N + 1)])
#     s = pik
#     s[list] = s1
#     s
#   }
#
#   UPpoisson <- function (pik)
#   {
#     if (any(is.na(pik)))
#       stop("there are missing values in the pik vector")
#     as.numeric(runif(length(pik)) < pik)
#   }
#
#
#
#   if (missing(method)) {
#     warning("the method is not specified; by default, the method is srswor")
#     method = "srswor"
#   }
#   if (!(method %in% c("srswor", "srswr", "poisson", "systematic")))
#     stop("the name of the method is wrong")
#   if (method %in% c("poisson", "systematic") & missing(pik))
#     stop("the vector of probabilities is missing")
#   if (missing(stratanames) | is.null(stratanames)) {
#     if (method == "srswor")
#       result = data.frame((1:nrow(data))[srswor(size, nrow(data)) ==
#                                            1], rep(size/nrow(data), size))
#     if (method == "srswr") {
#       s = srswr(size, nrow(data))
#       st = s[s != 0]
#       l = length(st)
#       result = data.frame((1:nrow(data))[s != 0])
#       if (size <= nrow(data))
#         result = cbind.data.frame(result, st, prob = rep(size/nrow(data),
#                                                          l))
#       else {
#         prob = rep(size/nrow(data), l)/sum(rep(size/nrow(data),
#                                                l))
#         result = cbind.data.frame(result, st, prob)
#       }
#       colnames(result) = c("id", "replicates", "prob")
#     }
#     if (method == "poisson") {
#       pikk = inclusionprobabilities(pik, size)
#       s = (UPpoisson(pikk) == 1)
#       if (length(s) > 0)
#         result = data.frame((1:nrow(data))[s], pikk[s])
#       if (description)
#         cat("\nPopulation total and number of selected units:",
#             nrow(data), sum(s), "\n")
#     }
#     if (method == "systematic") {
#       pikk = inclusionprobabilities(pik, size)
#       s = (UPsystematic(pikk) == 1)
#       result = data.frame((1:nrow(data))[s], pikk[s])
#     }
#     if (method != "srswr")
#       colnames(result) = c("id", "prob")
#     if (description & method != "poisson")
#       cat("\nPopulation total and number of selected units:",
#           nrow(data), sum(size), "\n")
#   }
#   else {
#     data = data.frame(data)
#     index = 1:nrow(data)
#     m = match(stratanames, colnames(data))
#     if (any(is.na(m)))
#       stop("the names of the strata are wrong")
#     data2 = cbind.data.frame(data[, m], index)
#     colnames(data2) = c(stratanames, "index")
#     x1 = data.frame(unique(data[, m]))
#     colnames(x1) = stratanames
#     result = NULL
#     for (i in 1:nrow(x1)) {
#       if (is.vector(x1[i, ]))
#         data3 = data2[data2[, 1] == x1[i, ], ]
#       else {
#         as = data.frame(x1[i, ])
#         names(as) = names(x1)
#         data3 = merge(data2, as, by = intersect(names(data2),
#                                                 names(as)))
#       }
#       y = sort(data3$index)
#       if (description & method != "poisson") {
#         cat("Stratum", i, "\n")
#         cat("\nPopulation total and number of selected units:",
#             length(y), size[i], "\n")
#       }
#       if (method != "srswr" & length(y) < size[i]) {
#         stop("not enough obervations in the stratum ",
#              i, "\n")
#         st = c(st, NULL)
#       }
#       else {
#         if (method == "srswor") {
#           st = y[srswor(size[i], length(y)) == 1]
#           r = cbind.data.frame(data2[st, ], rep(size[i]/length(y),
#                                                 size[i]))
#         }
#         if (method == "systematic") {
#           pikk = inclusionprobabilities(pik[y], size[i])
#           s = (UPsystematic(pikk) == 1)
#           st = y[s]
#           r = cbind.data.frame(data2[st, ], pikk[s])
#         }
#         if (method == "srswr") {
#           s = srswr(size[i], length(y))
#           st = rep(y[s != 0], s[s != 0])
#           l = length(st)
#           if (size[i] <= length(y))
#             r = cbind.data.frame(data2[st, ], prob = rep(size[i]/length(y),
#                                                          l))
#           else {
#             prob = rep(size[i]/length(y), l)/sum(rep(size[i]/length(y),
#                                                      l))
#             r = cbind.data.frame(data2[st, ], prob)
#           }
#         }
#         if (method == "poisson") {
#           pikk = inclusionprobabilities(pik[y], size[i])
#           s = (UPpoisson(pikk) == 1)
#           if (any(s)) {
#             st = y[s]
#             r = cbind.data.frame(data2[st, ], pikk[s])
#             if (description) {
#               cat("Stratum", i, "\n")
#               cat("\nPopulation total and number of selected units:",
#                   length(y), length(st), "\n")
#             }
#           }
#           else {
#             if (description) {
#               cat("Stratum", i, "\n")
#               cat("\nPopulation total and number of selected units:",
#                   length(y), 0, "\n")
#             }
#             r = NULL
#           }
#         }
#       }
#       # corrected 7.4.2014 for allowing size=0 for a stratum:
#       # if (!is.null(r)) {
#       if (!is.null(r) & nrow(r)>0) {
#         r = cbind(r, i)
#         result = rbind.data.frame(result, r)
#       }
#     }
#
# # original, seems a bit "over-ifed"
# #     if (method == "srswr")
# #          colnames(result) = c(stratanames, "ID_unit", "Prob", "Stratum")
# #     else colnames(result) = c(stratanames, "ID_unit", "Prob", "Stratum")
#
#     colnames(result) <- c(stratanames, "id", "prob", "stratum")
#
#     if (description) {
#       cat("Number of strata ", nrow(x1), "\n")
#       if (method == "poisson")
#         cat("Total number of selected units", nrow(result),
#             "\n")
#       else cat("Total number of selected units", sum(size),
#                "\n")
#     }
#   }
#   result
# }


SampleTwins <- function (x, stratanames = NULL, twins,
                         method = c("srswor", "srswr", "poisson", "systematic"),
                         pik, description = FALSE) {

  # sort data first
  x <- x[do.call("order", lapply(x[,stratanames], order)),]

  # define the frequencies
  twinsize <- as.data.frame.table(xtabs( as.formula(gettextf("~ %s", paste(stratanames, collapse="+"))), twins))

  size <- merge(x=expand.grid(lapply(x[stratanames], unique)),
                y=twinsize, all.x=TRUE, all.y=TRUE)
  size$Freq[is.na(size$Freq)] <- 0

  s <- Strata(x = x, stratanames = stratanames, size=size$Freq, method=method,
              pik=pik, description=description)

  if(!identical(table(s[,stratanames]), table(twins[,stratanames]))) {
    warning("Could not find a twin for all records. Enlighten the restrictions!")
  }
  return(s)

}



# RndPairs <- function(n, r, rdist1 = rnorm(n=n, mean = 0, sd = 1), rdist2 = rnorm(n=n, mean = 0, sd = 1)){
# 
#   # create correlated random pairs
#   data.frame(matrix(nrow=n, ncol=2, data=cbind(rdist1, rdist2)) %*%
#                 chol(matrix(nrow=2, ncol=2, data=c(1, r, r, 1))))
# }


RndPairs <- function(n, r, rdist1 = rnorm(n=n, mean = 0, sd = 1), 
                     rdist2 = rnorm(n=n, mean = 0, sd = 1), prop=NULL) {
  
  # create correlated random pairs
  res <- data.frame(matrix(nrow=n, ncol=2, data=cbind(rdist1, rdist2)) %*%
                      chol(matrix(nrow=2, ncol=2, data=c(1, r, r, 1))))
  colnames(res) <- c("x","y")
  
  if(!is.null(prop)){
    
    if(is.list(prop)){
      propx <- cumsum(c(0, prop[[1]])) 
      propy <- cumsum(c(0, prop[[2]]))
      
    } else {
      propx <- propy <- cumsum(c(0, prop))
    }
    
    
    res$x <- CutQ(res$x, breaks = quantile(res$x, probs = propx))
    res$y <- CutQ(res$y, breaks = quantile(res$y, probs = propy))
    
    
  }
  
  return(res)  
  
}



RndWord <- function(size, length, x = LETTERS, replace = TRUE, prob = NULL){
  sapply(1:size, function(i) paste(sample(x=x, size=length, replace=replace, prob=prob), collapse=""))
}





## basic finance functions  ---------------

NPV <- function(i, cf, t=seq(along=cf)-1) {
  # Net present value
  sapply(i, function(ii) sum(cf/(1 + ii)^t))
}


IRR <- function(cf, t=seq(along=cf)-1, interval=c(-1.5, 1.5), ...) {
  # internal rate of return
  UnirootAll(f=function(i) NPV(i, cf=cf, t=t), interval=interval, ...)
}



OPR <- function (K, D = NULL, log = FALSE) {

  # Einperiodenrenditen One-period-returns
  if (is.null(D))
    D <- rep(0, length(K))
  if (!log){
    res <- (D[-1] + K[-1] - K[-length(K)])/K[-length(K)]
  } else {
    res <- log((D[-1] + K[-1])/K[-length(K)])
  }

  return(res)

}

NPVFixBond <- function(i, Co, RV, n){
  # net present value for fixed bonds
  sum(Co / (1+i)^(1:n), RV / (1+i)^n)
}

YTM <- function(Co, PP, RV, n){
  # yield to maturity (irr)
  uniroot(function(i) -PP + sum(Co / (1+i)^(1:n), RV / (1+i)^n)
          , c(0,1))$root
}


# Returns the periodic payment for an annuity
# calculates the payment for a loan based on constant payments and a constant interest rate.
# Rate    Required. The interest rate for the loan.
# Nper    Required. The total number of payments for the loan.
# Pv    Required. The present value, or the total amount that a series of future payments is worth now; also known as the principal.
# Fv    Optional. The future value, or a cash balance you want to attain after the last payment is made. If fv is omitted, it is assumed to be 0 (zero), that is, the future value of a loan is 0.

# match.arg( arg=ord, choices=c("hsv","default")

# Berechnung einer Annuitaet, XL: RMZ()
PMT <- function(rate, nper, pv, fv=0, type=0) {
  if(type %nin% c(0, 1))
    stop("type must be 0 or 1")
  -((pv * (1+rate)^nper + fv) * rate/((1+rate)^nper-1) * (1+type*rate)^-1)
}

# Zins fuer die Annuitaetentilgung, XL: ZINSZ()
IPMT <- function(rate, per, nper, pv, fv=0, type=0){
  A <- -PMT(rate, nper, pv, fv, type)
  (A - pv * rate) * (1+rate)^(per-1) - A
}

# Tilgungsanteil fuer die Annuitaetentilgung: XL: KAPZ()
PPMT <- function(rate, per, nper, pv, fv=0, type=0){
  PMT(rate, nper, pv, fv, type) - IPMT(rate, per, nper, pv, fv, type)
}


# Kapitalverlauf der Annuitaetentilgung: KUMKAPITAL()
RBAL <- function(rate, per, nper, pv, fv=0, type=0){
  A <- -PMT(rate, nper, pv, fv, type)
  P <- (A - pv * rate) * (1+rate)^(per-1)
  pv - cumsum(P[1:nper])
  res <- pv * (1+rate)^per - A * ((1+rate)^per-1) / rate
  res
  # diff(c(pv, res))
}


# Returns the sum-of-years' digits depreciation of an asset for a specified period
# Cost    Required. The initial cost of the asset.
# Salvage    Required. The value at the end of the depreciation (sometimes called the salvage value of the asset).
# Life    Required. The number of periods over which the asset is depreciated (sometimes called the useful life of the asset).
# Per    Required. The period and must use the same units as life.

# digitale Abschreibungsbetraege
# SYD(50000, Rn = 10000, 5,k = 1:5)
# Wert
# 50000 - cumsum(SYD(50000, Rn = 10000, 5,k = 1:5))
# Sum of Years Digits method of depreciation
SYD <- function(cost, salvage, life, period=1:life){
  (cost - salvage)*(life - period+1)*2/(life*(life+1))
}

# Returns the depreciation for each accounting period by using a depreciation coefficient
SLN <- function(cost, salvage, life){
  (cost-salvage)/life
}

DB <- function(cost, salvage, life, period = 1:life){
  q <- (salvage/cost)^(1/life)
  cost * (1-q) * (q^(period-1))
}



## utils: manipulation, utilities ====


InDots <- function(..., arg, default){

  # was arg in the dots-args? parse dots.arguments
  arg <- unlist(match.call(expand.dots=FALSE)$...[arg])

  # if arg was not in ... then return default
  if(is.null(arg)) arg <- default

  return(arg)

}



FctArgs <- function(name, sort=FALSE) {

  # got that somewhere, but don't know from where...

  if(is.function(name)) name <- as.character(substitute(name))
  a <- formals(get(name, pos=1))
  if(is.null(a))
    return(NULL)
  arg.labels <- names(a)
  arg.values <- as.character(a)
  char <- sapply(a, is.character)
  arg.values[char] <- paste("\"", arg.values[char], "\"", sep="")

  if(sort)
  {
    ord <- order(arg.labels)
    if(any(arg.labels == "..."))
      ord <- c(ord[-which(arg.labels[ord]=="...")],
               which(arg.labels=="..."))
    arg.labels <- arg.labels[ord]
    arg.values <- arg.values[ord]
  }

  output <- data.frame(value=I(arg.values), row.names=arg.labels)
  print(output, right=FALSE)

  invisible(output)
}


# GetArgs <- function(FUN) {
#   
#   a <- formals(getAnywhere(FUN)$objs[[1]])
#   arg.labels <- names(a)
#   arg.values <- as.character(a)
#   char <- sapply(a, is.character)
#   arg.values[char] <- paste("\"", arg.values[char], "\"", sep="")
#   
#   c(fname=FUN, args=paste(StrTrim(gsub("= $", "", paste(arg.labels, arg.values, sep=" = "))), collapse=", "))
#   
# }
# 
# fcts <- grep("plot.Desc", unclass(lsf.str(envir = asNamespace("DescTools"), all.names = T)), v=T)
# fargs <- t(unname(sapply(fcts, GetArgs)))
# 








Keywords <- function( topic ) {

  # verbatim from library(gtools)

  file <- file.path(R.home("doc"),"KEYWORDS")
  if(missing(topic))
  {
    file.show(file)
  } else {

#     ## Local copy of trim.character to avoid cyclic dependency with gdata ##
#     trim <-  function(s) {
#
#       s <- sub(pattern="^[[:blank:]]+", replacement="", x=s)
#       s <- sub(pattern="[[:blank:]]+$", replacement="", x=s)
#       s
#     }

    kw <- scan(file=file, what=character(), sep="\n", quiet=TRUE)
    kw <- grep("&", kw, value=TRUE)
    kw <- gsub("&[^&]*$","", kw)
    kw <- gsub("&+"," ", kw)
    kw <- na.omit(StrTrim(kw))

    ischar <- tryCatch(is.character(topic) && length(topic) ==
                         1L, error = identity)
    if (inherits(ischar, "error"))
      ischar <- FALSE
    if (!ischar)
      topic <- deparse(substitute(topic))

    item <- paste("^",topic,"$", sep="")

    # old, replaced by suggestion of K. Hornik 23.2.2015
    # topics <- function(k) help.search(keyword=k)$matches[,"topic"]

    topics <- function(k) {
      matches <- help.search(keyword=k)$matches
      matches[ , match("topic", tolower(colnames(matches)))]
    }

    matches <- lapply(kw, topics)
    names(matches) <- kw

    tmp <- unlist(lapply( matches, function(m) grep(item, m, value=TRUE) ))
    names(tmp)
  }
}


SysInfo <- function() {

  ## description <<  getSysinfo is a convenience function to compile some information about the
  ##                 computing system and environment used.

  package.names <- sapply(sessionInfo()[['otherPkgs']],'[[','Package')
  package.versions <- sapply(sessionInfo()[['otherPkgs']],'[[','Version')
  packages.all <- paste(gettextf("%s (%s)", package.names, package.versions), collapse=", ")

  pars.sys <- c('user', 'nodename', 'sysname', 'release')
  R.system <- paste(sessionInfo()[[1]]$version.string)

  sys.info <- paste(pars.sys, Sys.info()[pars.sys], collapse=', ', sep=': ')
  all.info <- paste(c(sys.info,', ', R.system,', installed Packages: ', packages.all),
                    sep='', collapse='')

  cat(gettextf("\nSystem: %s\nNodename: %s, User: %s",
               paste(Sys.info()[c("sysname","release","version")], collapse=" ")
               , Sys.info()["nodename"], Sys.info()["user"], "\n\n"))
  cat(gettextf("\nTotal Memory: %s MB\n\n", memory.limit()))
  cat(StrTrim(sessionInfo()$R.version$version.string), "\n")
  cat(sessionInfo()$platform, "\n")
  cat("\nLoaded Packages: \n", packages.all, "\n")

  DescToolsOptions()

  invisible(all.info)

}

FindRProfile <- function(){
  candidates <- c( Sys.getenv("R_PROFILE"),
                   file.path(Sys.getenv("R_HOME"), "etc", "Rprofile.site"),
                   Sys.getenv("R_PROFILE_USER"),
                   file.path(getwd(), ".Rprofile") )

  Filter(file.exists, candidates)
}




DescToolsOptions <- function (..., default = NULL, reset = FALSE) {

  .Simplify <- function(x)
    if(is.list(x) && length(x)==1L)
      x[[1L]]
  else
    x

  # all system defaults
  def <- list(
    col       = c(DescTools::hblue, DescTools::hred,  DescTools::horange),
    digits    = 3,
    fixedfont = structure(list(name = "Consolas", size = 7), class = "font"),
    fmt       = structure(list(
      abs = structure(list(digits = 0, big.mark = "'"), .Names = c("digits", "big.mark"),
                      name = "abs", label = "Number format for counts",
                      default = TRUE, class = "fmt"),
      per = structure(list(digits = 1, fmt = "%"), .Names = c("digits", "fmt"),
                      name = "per", label = "Percentage number format",
                      default = TRUE, class = "fmt"),
      num = structure(list(digits = 3, big.mark = "'"), .Names = c("digits", "big.mark"),
                      name = "num", label = "Number format for floats",
                      default = TRUE, class = "fmt")), name = "fmt"),
    footnote  = c("'", "\"", "\"\""),
    lang      = "engl",
    plotit    = TRUE,
    stamp     = expression(gettextf("%s/%s", Sys.getenv("USERNAME"),
                                    Format(Today(), fmt = "yyyy-mm-dd"))),
    lastWrd=NULL,
    lastXL=NULL,
    lastPP=NULL
  )


  # potentionally evaluate dots
  dots <- lapply(list(...), function(x) {
    if (is.symbol(x))
      eval(substitute(x, env = parent.frame()))
    else
      x
  })
  # reduce length[[1]] list to a list n (exclude single named argument)
  if(length(dots)==1L && is.list(dots) &&
     !(length(dots)==1 && !is.null(names(dots))))
    dots <- dots[[1]]

  # refuse to work with several options and defaults
  if (length(dots) > 1L && !is.null(default))
    stop("defaults can only be used with single options")

  # ignore anything else, set the defaults and return old values
  if (reset == TRUE)
    invisible(options(DescTools = def))

  # flag these values as defaults, not before they are potentially reset
  # do not set on lastXYZ options (can't set attribute on NULL values)
  for(i in seq_along(def)[-c(9:11)])
    attr(def[[i]], "default") <- TRUE


  opt <- getOption("DescTools")
  # store such as to return as result
  old <- opt
  # take defaults and overwrite found entries in options
  def[names(opt)] <- opt
  opt <- def

  # no names were given, so just return all options
  if (length(dots) == 0) {
    return(opt)

  } else {
    # entries were supplied, now check if there were named entries
    # dots is then a list with length 1
    if (is.null(names(dots))) {
      # if no names, check default and return either the value
      # or if this does not exist, the default
      if (!is.null(default))
        # a default is given, so get old option value and replace with user default
        # when it's NULL
        # note: in old are the original option values (no system defaults)
        return(.Simplify(ifelse(is.null(old[[dots]]), default, old[[dots]])))

      else
        # no defaults given, so return options, evt. sys defaults
        # reduce list to value, if length 1
        return(.Simplify(opt[unlist(dots)]))

    } else {
      # there are named values, so these are to be stored
      # restore old options in opt (no defaults should be stored)
      opt <- old
      if (is.null(opt))
        opt <- list()

      opt[names(dots)] <- dots
      # store full option set
      options(DescTools = opt)
      # return only the new set variables
      old <- old[names(dots)]

    }
  }

  invisible(old)

}






# DescToolsOptions <- function(..., default=NULL, reset=FALSE){
#
#   .Simplify <- function(x)
#     # return first element of a list, if it's the only one
#     if(is.list(x) && length(x)==1)
#       x[[1]]
#     else
#       x
#
#
#   def <- list(
#     col=c(hred, hblue, hgreen),
#     digits=3,
#     fixedfont=structure(list(name="Consolas", size=7), class="font"),
#     fmt=structure(
#       list(
#         abs=structure(list(digits = 0, big.mark = "'"),
#                       .Names = c("digits","big.mark"),
#                       name = "abs", label = "Number format for counts",
#                       default=TRUE, class = "fmt"),
#         per=structure(list(digits = 1, fmt = "%"),
#                       .Names = c("digits","big.mark"), name = "per",
#                       label = "Percentage number format",
#                       default=TRUE, class = "fmt"),
#         num=structure(list(digits = 3, big.mark = "'"),
#                       .Names = c("digits","big.mark"), name = "num",
#                       label = "Number format for floats",
#                       default=TRUE, class = "fmt")
#       ), name="fmt"),
#
#     footnote=c("'", '"', '""'),
#     lang="engl",
#     plotit=TRUE,
#     stamp=expression(gettextf("%s/%s", Sys.getenv("USERNAME"), Format(Today(), fmt = "yyyy-mm-dd"))),
#     lastWrd=NULL,
#     lastXL=NULL,
#     lastPP=NULL
#   )
#
#
#   # potentionally evaluate dots
#   dots <- lapply(list(...), function(x){
#     if(is.symbol(x))
#       eval(substitute(x, env = parent.frame()))
#     else
#       x
#   })
#
#   # refuse to work with several options and defaults
#   if(length(dots)>1 && !is.null(default))
#     stop("defaults can only be used with single options")
#
#   opt <- getOption("DescTools")
#
#   old <- opt
#
#   if(reset==TRUE)
#     # reset the options and return old values invisible
#     options(DescTools=def)
#
#   if(length(dots)==0) {
#     # no arguments, just return the options
#     return(.Simplify(opt))
#
#   } else {
#     if(is.null(names(dots))){
#       # get the option and return either value or the default
#       if(!is.null(default))
#       # just one allowed here, can we do better?? **********
#         return(.Simplify(Coalesce(opt[dots[[1]]], default)))
#
#       else
#         # more values allowed
#         return(.Simplify(opt[unlist(dots)]))
#
#     } else {
#       #set the options
#       if(is.null(opt))
#         opt <- list()
#
#       opt[names(dots)[[1]]] <- dots[[1]]
#
#       # let default options return the result
#       .Simplify(options(DescTools=opt))
#     }
#   }
#
#   invisible(old)
#
# }


fmt <- function(...){

  # get format templates and modify on the fly, e.g. other digits
  # x is the name of the template

  def <- structure(
    list(
      abs=structure(list(digits = 0, big.mark = "'"),
                    label = "Number format for counts",
                    default=TRUE, class = "fmt"),
      per=structure(list(digits = 1, fmt = "%"),
                    label = "Percentage number format",
                    default=TRUE, class = "fmt"),
      num=structure(list(digits = 0, big.mark = "'"),
                    label = "Number format for floating points",
                    default=TRUE, class = "fmt")
    ), name="fmt")

  # get a format from the fmt templates options
  res <- DescToolsOptions("fmt")[[1]]

  # find other defined fmt in .GlobalEnv and append to list
  # found <- ls(parent.frame())[ lapply(lapply(ls(parent.frame()), function(x) gettextf("class(%s)", x)),
  #                     function(x) eval(parse(text=x))) == "fmt" ]
  # if(length(found)>0){
  #   udf <- lapply(found, function(x) eval(parse(text=x)))
  #   names(udf) <- found
  # }

  # collect all found formats, defaults included if not set as option
  # abs, per and num must always be available, even if not explicitly defined
  res <- c(res, def[names(def) %nin% names(res)]) #, udf)


  # get additional arguments
  dots <- match.call(expand.dots=FALSE)$...
  # leave away all NULL values, these should not overwrite the defaults below
  dots <- dots[is.null(dots)]


  # functionality:
  # Fmt()                 return all from options
  # Fmt("abs")            return abs
  # Fmt("abs", digits=3)  return abs with updated digits
  # Fmt(c("abs","per"))   return abs and per

  # Fmt(nob=as.Fmt(digits=10, na.form="nodat"))  set nob



  if(all(!is.null(names(dots)))){

    # set value
    old <- options("DescTools")
    opt <- old
    opt$fmt[[names(dots)]] <- dots
    options(DescTools=opt)

    # same behaviour as options
    invisible(old)

  } else {

    if(!length(dots))
      return(res)

    # select the requested ones by name
    fnames <- unlist(dots[is.null(names(dots))])
    res <- res[fnames]

    # modify additional arguments in the template definition
    for(z in names(res)){
      if(!is.null(res[[z]]))
        # use named dots
        res[[z]][names(dots[!is.null(names(dots))])] <- dots[!is.null(names(dots))]
    }

    # set names as given, especially for returning the ones not found
    # ???? names(res) <- fnames

    # reduce list, this should not be necessary, but to make sure
    # if(length(res)==1)
    #   res <- res[[1]]

    return(res)


  }

}



as.fmt <- function(...){

  dots <- list(...)
  
  # extract special argument "label" from dots arguments
  if(!is.null(lbl <- dots[["label"]])){
    dots[["label"]] <- NULL
  } else {
    # the default label
    lbl <- "Number format"
  }

  structure(dots,
            .Names = names(dots),
            label = lbl,
            class = "fmt")

}



ParseSASDatalines <- function(x, env = .GlobalEnv, overwrite = FALSE) {

  # see: http://www.psychstatistics.com/2012/12/07/using-datalines-in-sas/
  # or:  http://www.ats.ucla.edu/stat/sas/library/SASRead_os.htm

  # split command to list by means of ;
  lst <- StrTrim(strsplit(x, ";")[[1]])
  dsname <- lst[grep(pattern = "^[Dd][Aa][Tt][Aa] ", StrTrim(lst))]   # this would be the dataname
  dsname <- gsub(pattern = "^[Dd][Aa][Tt][Aa] +", "", dsname)

  # get the columnnames from the input line
  input <- lst[grep(pattern = "^[Ii][Nn][Pp][Uu][Tt]", StrTrim(lst))]
  # get rid of potential single @
  input <- gsub("[ \n\t]@+[ \n\t]*", "", input)
  input <- gsub(pattern=" +\\$", "$", input)
  input <- gsub(" +", " ", input)
  cnames <- strsplit(input, " ")[[1]][-1]

  # the default values for the variables
  def <- rep(0, length(cnames))
  def[grep("\\$$", cnames)] <- "''"
  vars <- paste(gsub("\\$$","",cnames), def, sep="=", collapse=",")

  datalines <- lst[grep("datalines|cards|cards4", tolower(lst))+1]

  fn <- textConnection(datalines)
  res <- eval(parse(text=gettextf(
    "data.frame(scan(file=(fn),
    what=list(%s), quiet=TRUE))", vars)))

  close(fn)

  if(length(dsname) > 0){ # check if a dataname could be found
    if( overwrite | ! exists(dsname, envir=env) ) {
      assign(dsname, res, envir=env)
      
      note <- col_cyan(gettextf("\nThe object %s has been added to %s.\n" 
                       , dsname, deparse(substitute(env)))) 
      cat(note)
      
    } else {
      cat(gettextf("The object %s already exists in %s. Should it be overwritten? (y/n)\n"
                   , dsname, deparse(substitute(env))))
      ans <- readline()
      if(ans == "y"){
        assign(dsname, res, envir = env)
        
        note <- col_cyan(gettextf("\nThe object %s has been overwritten in %s.\n" 
                         , dsname, deparse(substitute(env)))) 
        cat(note)
      }
      
      # stop(gettextf("%s already exists in %s. Use overwrite = TRUE to overwrite it.", dsname, deparse(substitute(env))))
    }
  }

  return(res)

}




SetNames <- function (x, ...) {
  
  # see also setNames()
  # args <- match.call(expand.dots = FALSE)$...
  args <- list(...)
  
  # the default when no information is provided
  if (is.null(names(args)))
    names(args) <- "names"
  
  names(args) <- lapply(names(args), match.arg, c("names", "rownames", "colnames", "dimnames"))
  
  if ("dimnames" %in% names(args)) {
    if(is.null(args[["dimnames"]]))
      dimnames(x) <-NULL
    else
      dimnames(x) <- args[["dimnames"]]
  }
  
  if ("rownames" %in% names(args)) {
    if(is.null(args[["rownames"]]))
      rownames(x) <- NULL
    else
      rownames(x) <- rep_len(args[["rownames"]], dim(x)[1])
  }
  
  if ("colnames" %in% names(args)) {
    if(is.null(args[["colnames"]]))
      colnames(x) <- NULL
    else
      colnames(x) <- rep_len(args[["colnames"]], dim(x)[2])
  }
  
  if ("names" %in% names(args)) {
    if(is.null(args[["names"]]))
      names(x) <-NULL
    else
      names(x) <- rep_len(args[["names"]], length(x))
  }
  
  x
  
}


SetAttr <- function(x, attr, attr_val){
  for(i in seq_along(attr))
    attr(x, which = attr[i]) <- attr_val[i]
  return(x)
}



StripAttr <- function(x, attr_names=NULL) {
  
  if(is.null(attr_names))
    attributes(x) <- NULL
  else
    for(a in attr_names) 
      attr(x, which = a) <- NULL

  return(x)
}



Append <- function(x, values, after = NULL, ... ){
  UseMethod("Append")
}


Append.default <- function(x, values, after = NULL, ...){
  if(is.null(after))
    after <- length(x)
  append(x, values, after)
}


Append.matrix <- function(x, values, after = NULL, rows=FALSE, names=NULL, ...){

  if(rows){
    nr <- dim(x)[1]
    if(missing(after) | is.null(after)) after <- nr

    values <- matrix(values, ncol=ncol(x))
    if(!is.null(names)){
      err <- try(row.names(x) <- names, silent = TRUE)
      if(inherits(err, "try-error"))
        warning("Could not set rownames.")
    }
    
    if(!after)
      res <- rbind(values, x)
    
    else if(after >= nr)
      res <- rbind(x, values)
    
    else
      res <- rbind(x[1L:after,, drop=FALSE], values, x[(after+1L):nr,, drop=FALSE])
    
    colnames(res) <- colnames(x)

  } else {

    nc <- dim(x)[2]
    if(missing(after) | is.null(after)) after <- nc

    values <- matrix(values, nrow=nrow(x))
    
    if(!is.null(names))
      colnames(values) <- names
    
    if(!after)
      res <- cbind(values, x)
    
    else if(after >= nc)
      res <- cbind(x, values)
    
    else
      res <- cbind(x[, 1L:after, drop=FALSE], values, x[, (after+1L):nc, drop=FALSE])
    
    rownames(res) <- rownames(x)

  }

  return(res)

}


Append.data.frame <- function(x, values, after = NULL, rows=FALSE, names=NULL, ...){

  # appending to a data.frame is by nature append columns, as it is 
  # intrinsically a list. 
  # Inserting rows is however clumsy by hand and so we offer an argument to
  # do that as well
  
  .InsertRow <- function(x, val, after=nrow(x)) {
    
    # insert a row in a data.frame
    # note: we should not use rbind here, as it is not general enough in cases,
    # when not only numeric values are present in the data.frame
    
    x[seq(after+1, nrow(x)+1), ] <- x[seq(after, nrow(x)), ]
    x[after, ] <- val
    
    x
    
  }
  
  if(rows)
    .InsertRow(x, values, after=after)
  
  else 
    as.data.frame(append(x, SetNames(list(values), names=names), after = after))
  
}



Append.TOne <-  function(x, values, after = NULL, rows=TRUE, names=NULL, ...) {
  
  # appending to a TOne object means appending to a matrix while preserving the class
  # (which is lost, when using rbind)
  
  res <- Append.matrix(x, values, after=after, rows=rows, names=names, ...)
  attr(res, "legend") <- attr(x, "legend")
  class(res) <- "TOne"
  
  return(res)
  
}




# InsRow <- function(m, x, i, row.names=NULL){
#
#   nr <- dim(m)[1]
#   if(missing(i)) i <- nr+1
#
#   x <- matrix(x, ncol=ncol(m))
#   if(!is.null(row.names))
#     row.names(x) <- row.names
#   if(i==1)
#     res <- rbind(x, m)
#   else if(i>nr)
#     res <- rbind(m, x)
#   else
#     res <- rbind(m[1:(i-1),, drop=FALSE], x, m[i:nr,, drop=FALSE])
#   colnames(res) <- colnames(m)
#   res
# }
#
#
#
#
# InsCol <- function(x, values, i, names=NULL, ...) {
#   UseMethod("InsCol")
# }
#
#
# InsCol.data.frame <- function(x, values, i, names=NULL, ...) {
#   as.data.frame(append(x, SetNames(list(values), names=names), after = i+1))
# }
#
#
# InsCol.default <- function(x, values, i, names=NULL, ...){
#
#   nc <- dim(x)[2]
#   if(missing(i)) i <- nc+1
#
#   values <- matrix(values, nrow=nrow(x))
#   if(!is.null(names))
#     colnames(values) <- names
#   if(i==1)
#     res <- cbind(values, x)
#   else if(i > nc)
#     res <- cbind(x, values)
#   else
#     res <- cbind(x[,1:(i-1), drop=FALSE], values, x[,i:nc, drop=FALSE])
#   rownames(res) <- rownames(x)
#   res
# }
#



Rename <- function(x, ..., gsub=FALSE, fixed=TRUE, warn=TRUE){

  subst <- c(...)

  # Original, will not work if neither ... nor x has names
  # replaced by 0.99.24

  # # if ... do not have names use those from x, assigned by sequence
  # if(is.null(names(subst)))
  #   names(subst) <- names(x)[1:length(subst)]

  # if ... do not have names use the sequence
  if(is.null(names(subst)))
    names(x)[1:length(subst)] <- subst


  if(gsub){
    names.x <- names(x)
    for(i in 1:length(subst)){
      names.x <- gsub(names(subst[i]), subst[i], names.x, fixed=fixed)
    }
    names(x) <- names.x

  } else {
    i <- match(names(subst), names(x))

    if(any(is.na(i))) {
      if(warn) warning("unused name(s) selected")

      if(any(!is.na(i)))
        subst <- subst[!is.na(i)]

      i <- i[!is.na(i)]
    }
    if(length(i))
      names(x)[i] <- subst
  }

  return(x)
}


# This does not work, because x does not come as a reference

# AddLabel <- function(x, text = ""){
  # ### add an attribute named "label" to a variable in a data.frame
  # attr(x, "label") <- text
# }

# attr(d.pizza$driver, "label") <- "The driver delivering the pizza"
# AddLabel(d.pizza$driver, "lkj?lkjlkjlk?lkj lkj lkj lkadflkj alskd lkas")



# simplified from Hmisc

Label <- function(x) {
  attributes(x)$label
}


"Label<-" <- function(x, value) {
  if(is.list(value))  stop("cannot assign a list to be an object label")
  if((length(value) != 1L) & !is.null(value)) stop("value must be character vector of length 1")

  attr(x, "label") <- value
  return(x)
}



`Labels<-` <- function(x, value) {
  if(is.list(value))  stop("cannot assign a list to be an object label")
  # if((length(value) != 1L) & !is.null(value)) stop("value must be character vector of length 1")
  
  
  if(is.atomic(x)) {
    DescTools::Label(x) <- value
    
  } else {
    
    value <- rep(value, times=length(x))
    
    for(i in seq(x))
      DescTools::Label(x[, i]) <- value[i]
  }
  
  return(x)
  
}

Labels <- function(x) {
  if(is.atomic(x))
    Label(x)
  else 
    sapply(x, DescTools::Label)
}



# "Label<-.data.frame" <- function(x, self=(length(value)==1), ..., value) {
#
#   if(!is.data.frame(x))  stop("x must be a data.frame")
#
#   if(self){
#     attr(x, "label") <- value
#   } else {
#     for (i in seq(along.with=x)) {
#       Label(x[[i]]) <- value[[i]]
#     }
#   }
#   return(x)
# }

# Label.data.frame <- function(x, ...) {
#   labels <- mapply(FUN=Label, x=x)
#   return(labels[unlist(lapply(labels, function(x) !is.null(x) ))])
# }


# SetLabel <- function (object = nm, nm) {
#   Label(object) <- nm
#   object
# }


`Unit<-` <- function (x, value) {

  if (is.list(value))
    stop("cannot assign a list to be an object label")
  if ((length(value) != 1L) & !is.null(value))
    stop("value must be character vector of length 1")
  attr(x, "unit") <- value
  return(x)

}

Unit <- function (x)  attributes(x)$unit




#
# To Sort(., mixed=TRUE) for vectors
#
#
# SortMixed Order or Sort Strings With Embedded Numbers So That The Numbers
# Are In The Correct Order
# Description
# These functions sort or order character strings containing numbers so that the numbers are numerically
# sorted rather than sorted by character value. I.e. "Asprin 50mg" will come before "Asprin
# 100mg". In addition
#



Sort <- function(x, ...) {
  UseMethod("Sort")
}

Sort.default <- function(x, ...) {
  sort(x = x, ...)
}

Sort.data.frame <- function(x, ord = NULL, decreasing = FALSE, factorsAsCharacter = TRUE,
                            na.last = TRUE, ...) {

  # why not using ord argument as in matrix and table instead of ord?

  if(is.null(ord)) { ord <- 1:ncol(x) }

  if(is.character(ord)) {
    ord <- match(ord, c("row.names", names(x)))
  } else if(is.numeric(ord)) {
    ord <- as.integer(ord) + 1
  }

  # recycle decreasing and by
  lgp <- list(decreasing = decreasing, ord = ord)
  # recycle all params to maxdim = max(unlist(lapply(lgp, length)))
  lgp <- lapply(lgp, rep, length.out = max(unlist(lapply(lgp, length))))
  # decreasing is not recycled in order, so we use rev to change the sorting direction
  # old: d.ord <- x[,lgp$ord, drop=FALSE]  # preserve data.frame with drop = FALSE
  d.ord <- data.frame(rn=rownames(x),x)[, lgp$ord, drop = FALSE] # preserve data.frame with drop = FALSE
  if(factorsAsCharacter){
    for( xn in which(sapply(d.ord, is.factor)) ){ d.ord[,xn] <- factor(d.ord[,xn], levels=sort(levels(d.ord[,xn]))) }
  }

  d.ord[, which(sapply(d.ord, is.character))] <- lapply(d.ord[,which(sapply(d.ord, is.character)), drop=FALSE], factor)
  d.ord <- data.frame(lapply(d.ord, as.numeric))
  d.ord[lgp$decreasing] <- lapply(d.ord[lgp$decreasing], "-")

  x[ do.call("order", c(as.list(d.ord), na.last=na.last)), , drop = FALSE]
}



Sort.matrix <- function (x, ord = NULL, decreasing = FALSE, na.last = TRUE, ...) {

  if (length(dim(x)) == 1 ){
    # do not specially handle 1-dimensional matrices
    res <- sort(x=x, decreasing=decreasing)

  } else {
    if (is.null(ord)) {
      # default order by sequence of columns
      ord <- 1:ncol(x)
    }

    # replace keyword by code
    ord[ord=="row_names"] <- 0
    # we have to coerce, as ord will be character if row_names is used
    ord <- as.numeric(ord)

    lgp <- list(decreasing = decreasing, ord = ord)
    lgp <- lapply(lgp, rep, length.out = max(unlist(lapply(lgp, length))))

    if( is.null(row.names(x))) {
      d.x <- data.frame(cbind(rownr=1:nrow(x)), x)
    } else {
      d.x <- data.frame(cbind( rownr=as.numeric(factor(row.names(x))), x))
    }
    d.ord <- d.x[, lgp$ord + 1, drop = FALSE]
    d.ord[lgp$decreasing] <- lapply(d.ord[lgp$decreasing], "-")

    res <- x[do.call("order", c(as.list(d.ord), na.last=na.last)), , drop=FALSE]
    # old version cannot be used for [n,1]-matrices, we switch to reset dim
    # class(res) <- "matrix"
    # 19.9.2013: dim kills rownames, so stick to drop = FALSE
    # dim(res) <- dim(x)
  }

  return(res)

}


Sort.table <- function (x, ord = NULL, decreasing = FALSE, na.last = TRUE, ...) {

  if (length(dim(x)) == 1 ){
    # do not specially handle 1-dimensional tables
    res <- sort(x=x, decreasing=decreasing)

  } else {
    if (is.null(ord)) {
      ord <- 1:ncol(x)
    }
    lgp <- list(decreasing = decreasing, ord = ord)
    lgp <- lapply(lgp, rep, length.out = max(unlist(lapply(lgp, length))))

    d.x <- data.frame(cbind( rownr=as.numeric(factor(row.names(x))), x, mar=apply(x, 1, sum)))
    d.ord <- d.x[, lgp$ord + 1, drop = FALSE]
    d.ord[lgp$decreasing] <- lapply(d.ord[lgp$decreasing], "-")

    res <- x[do.call("order", c(as.list(d.ord), na.last=na.last)), , drop=FALSE]
    class(res) <- "table"
  }

  return(res)

}



Rev <- function(x, ...) {
  # additional interface for rev...
  UseMethod("Rev")
}

Rev.default <- function(x, ...){
  # refuse accepting margins here
  if(length(list(...)) > 0 && length(dim(x)) == 1 && !identical(list(...), 1))
    warning("margin has been supplied and will be discarded.")
  rev(x)
}


Rev.array <- function(x, margin, ...) {

  if (!is.array(x))
    stop("'x' is not an array")

  newdim <- rep("", length(dim(x)))
  newdim[margin] <- paste(dim(x), ":1", sep="")[margin]
  z <- eval(parse(text=gettextf("x[%s, drop = FALSE]", paste(newdim, sep="", collapse=","))))
  class(z) <- oldClass(x)
  return(z)

}

Rev.matrix <- Rev.array
Rev.table <- Rev.array

# Rev.matrix <- function(x, margin, ...) {
#   Rev.table(x, margin, ...)
# }


Rev.data.frame <- function(x, margin, ...) {

    if(1 %in% margin) x <- x[nrow(x):1L,]
    if(2 %in% margin) x <- x[, ncol(x):1L]
    
    return(x)
}




Untable <- function(x, ...){
  UseMethod("Untable")
}


Untable.data.frame <- function(x, freq = "Freq", rownames = NULL, ...){

  if(all(is.na(match(freq, names(x)))))
    stop(gettextf("Frequency column %s does not exist!", freq))

  res <- x[Untable(x[,freq], type="as.numeric")[,], -match(freq, names(x)), drop=FALSE]
  rownames(res) <- rownames

  return(res)
}



Untable.default <- function(x, dimnames=NULL, type = NULL, rownames = NULL, colnames = NULL, ...) {

  # recreates the data.frame out of a contingency table
  # check fo NAs
  if(anyNA(x))
    warning("Provided object to untable contains NAs.")
  
  # coerce to table, such as also be able to handle vectors
  x <- as.table(ZeroIfNA(x))
  
  if(!is.null(dimnames)) dimnames(x) <- dimnames
  if(is.null(dimnames) && identical(type, "as.numeric")) dimnames(x) <- list(seq_along(x))
  # set a title for the table if it does not have one

  # if(is.null(names(dimnames(x)))) names(dimnames(x)) <- ""
  # if(length(dim(x))==1 && names(dimnames(x))=="") names(dimnames(x)) <- "Var1"
  # replaced 26.3.2013
  for( i in 1:length(dimnames(x)) )
    if (is.null(names(dimnames(x)[i])) || names(dimnames(x)[i]) == "")
      if (length(dimnames(x)) == 1) names(dimnames(x)) <- gettextf("Var%s", i)
      else names(dimnames(x)[i]) <- gettextf("Var%s", i)

  res <- as.data.frame(expand.grid(dimnames(x))[rep(1:prod(dim(x)), as.vector(x)),])
  rownames(res) <- NULL
  if(!all(names(dimnames(x))=="")) colnames(res) <- names(dimnames(x))

  # return ordered factors, if wanted...
  if(is.null(type)) type <- "as.factor"
  # recycle type:
  if(length(type) < ncol(res)) type <- rep(type, length.out=ncol(res))

  for(i in 1:ncol(res)){
    if(type[i]=="as.numeric"){
      res[,i] <- as.numeric(as.character(res[,i]))
    } else {
      res[,i] <- eval(parse(text = gettextf("%s(res[,i])", type[i])))
    }
  }

  # overwrite the dimnames, if requested
  if(!is.null(rownames)) rownames(res) <- rownames
  if(!is.null(colnames)) colnames(res) <- colnames

  return(res)
  
}




# AddClass  <- function(x, class, after=0) {
#   class(x) <- append(class(x), class, after = after)
#   x
# }
#
#
# RemoveClass  <- function(x, class) {
#   class(x) <- class(x)[class(x) %nin% class]
#   x
# }


Quot <- function (x, lag = 1L, quotients = 1L, ...) {
  
  ismat <- is.matrix(x)
  xlen <- if (ismat) 
    dim(x)[1L]
  else length(x)
  if (length(lag) != 1L || length(quotients) > 1L || lag < 
      1L || quotients < 1L) 
    stop("'lag' and 'quotients' must be integers >= 1")
  if (lag * quotients >= xlen) 
    return(x[0L])
  r <- unclass(x)
  i1 <- -seq_len(lag)
  if (ismat) 
    for (i in seq_len(quotients)) 
      r <- r[i1, , drop = FALSE] / r[-nrow(r):-(nrow(r) - lag + 1L), , drop = FALSE]
  else 
    for (i in seq_len(quotients)) 
      r <- r[i1] / r[-length(r):-(length(r) - lag + 1L)]
  
  class(r) <- oldClass(x)
  r
  
}



FixToTable <- function(txt, sep = " ", delim = "\t", trim = TRUE, header = TRUE){

  # converts a fixed text to a delim separated table

  # make all lines same width first
  txt <- StrPad(txt, width=max(nchar(txt)))

  m <- do.call("rbind", strsplit(txt, ""))

  idx <- apply( m, 2, function(x) all(x == sep))
  # replace all multiple delims by just one
  idx[-1][(apply(cbind(idx[-1], idx[-length(idx)]), 1, sum) == 2)] <- FALSE
  m[,idx] <- delim
  tab <- apply( m, 1, paste, collapse="")

  # trim the columns
  if(trim) {
    tab <- do.call("rbind", lapply(strsplit(tab, delim), StrTrim))
  } else {
    tab <- do.call("rbind", strsplit(tab, delim))
  }

  if(header) {
    colnames(tab) <- tab[1,]
    tab <- tab[-1,]
  }

  return(tab)

}




# Identify points in a plot using a formula.
# http://www.rforge.net/NCStats/files/
# Author: Derek Ogle <dogle@northland.edu>

identify.formula <- function(formula, data, subset, na.action, ...) {
  #   mf <- model.frame(x, data)
  #   x <- mf[,2]
  #   y <- mf[,1]
  #   identify(x, y, ...)

  if (missing(formula) || (length(formula) != 3L) || (length(attr(terms(formula[-2L]),
                                                                  "term.labels")) != 1L))
    stop("'formula' missing or incorrect")

  # if na.action is set to na.omit in the global options we would omit NAs
  # when building the model.frame and thus return a wrong index on a
  # data.frame containing NAs.
  # Therefore we overwrite the default value to in general return
  # plausible values for a plot environment.
  if(missing(na.action)){
    opt <- options(na.action="na.pass")
    on.exit(options(opt))
  }

  m <- match.call(expand.dots = FALSE)
  if (is.matrix(eval(m$data, parent.frame())))
    m$data <- as.data.frame(data)
  m[[1L]] <- quote(stats::model.frame)
  m$... <- NULL
  mf <- eval(m, parent.frame())
  response <- attr(attr(mf, "terms"), "response")

  identify(x=mf[[-response]], y=mf[[response]], ...)

}



IdentifyA <- function(x, ...){
  UseMethod("IdentifyA")
}


IdentifyA.formula <- function(formula, data, subset, poly = FALSE, ...){

  opt <- options(na.action=na.pass); on.exit(options(opt))

  # identifies points in a plot, lying in a rectangle, spanned by upleft, botright
  mf <- match.call(expand.dots = FALSE)
  m <- match(c("formula", "data", "na.action", "subset"), names(mf), 0L)
  mf <- mf[c(1L, m)]
  mf$drop.unused.levels <- TRUE
  mf[[1L]] <- as.name("model.frame")
  mf <- eval(mf, parent.frame())
  response <- attr(attr(mf, "terms"), "response")

  vname <- attr(attr(attr(mf, "terms"), "dataClasses"), "names")
  x <- setNames(mf[[-response]], vname[2])
  y <- setNames(mf[[response]], vname[1])


  IdentifyA(x=x, y=y, poly=poly, ...)

}



IdentifyA.default <- function(x, y=NULL, poly = FALSE, ...){

  xlabel <- if (!missing(x))
    deparse(substitute(x))
  ylabel <- if (!missing(y))
    deparse(substitute(y))

  pxy <- xy.coords(x, y, xlabel, ylabel)
  xlabel <- pxy$xlab
  ylabel <- pxy$ylab

  if(poly){
    cat("Select polygon points and click on finish when done!\n")
    xy <- locator(type="n")
    polygon(xy, border="grey", lty="dotted")
    idx <- PtInPoly(data.frame(pxy$x, pxy$y), do.call("data.frame", xy))$pip == 1
    code <- paste("x %in% c(", paste(which(idx), collapse=","), ")", sep="")
  } else {
    cat("Select upper-left and bottom-right point!\n")
    xy <- locator(n=2, type="n")[1:2]
    rect(xy$x[1], xy$y[1], xy$x[2], xy$y[2], border="grey", lty="dotted")

    idx <- (pxy$x %[]% sort(range(xy$x)) & pxy$y %[]% sort(range(xy$y)))
    # code <- paste(xlabel, " %[]% c(", xy$x[1], ", ", xy$x[2], ") & ", ylabel ," %[]% c(",  xy$y[1], ", ", xy$y[2], "))", sep="")
    # the new coordinates entsure we find the points...
    code <- paste(xlabel, " %[]% c(", min(xy$x), ", ", max(xy$x), ") & ", 
                  ylabel ," %[]% c(",  min(xy$y), ", ", max(xy$y), "))", sep="")
    
  }

  res <- which(idx)
  xy <- lapply(lapply(xy, range), signif, digits=4)
  attr(x=res, which="cond") <- code

  return(res)

}




PtInPoly <- function(pnts, poly.pnts)  {

  #check if pnts & poly is 2 column matrix or dataframe
  pnts = as.matrix(pnts); poly.pnts = as.matrix(poly.pnts)
  if (!(is.matrix(pnts) & is.matrix(poly.pnts))) stop('pnts & poly.pnts must be a 2 column dataframe or matrix')
  if (!(dim(pnts)[2] == 2 & dim(poly.pnts)[2] == 2)) stop('pnts & poly.pnts must be a 2 column dataframe or matrix')

  #ensure first and last polygon points are NOT the same
  if (poly.pnts[1,1] == poly.pnts[nrow(poly.pnts),1] & poly.pnts[1,2] == poly.pnts[nrow(poly.pnts),2]) poly.pnts = poly.pnts[-1,]

  #run the point in polygon code
  out = .Call('pip', PACKAGE="DescTools", pnts[,1], pnts[,2], nrow(pnts), poly.pnts[,1], poly.pnts[,2], nrow(poly.pnts))

  #return the value
  return(data.frame(pnts,pip=out))
}




# experimental: formula interface for split

split.formula <- function(x, f, drop = FALSE, data = NULL, ...) {
  mf <- model.frame(x, data)
  f <- mf[,2]
  x <- mf[,1]
  split(x, f, drop=drop, ...)
}



SplitAt <- function(x, pos) {
  # splits a vector at given positions

  # source: https://stackoverflow.com/questions/16357962/r-split-numeric-vector-at-position
  # author: Joshua Ulrich
  # unname(split(x, findInterval(x, pos)))

  # better from flodel
  pos <- c(1L, pos, length(x) + 1L)
  Map(function(x, i, j) x[i:j], list(x), head(pos, -1L), tail(pos, -1L) - 1L)

}



###

Mar <- function(bottom=NULL, left=NULL, top=NULL, right=NULL, outer=FALSE, reset=FALSE){

  if(reset){
    if(outer){
        par("oma" = .pardefault$oma)
      
    } else {
        par("mar" = .pardefault$mar)
    }
  } else {
    
    if(is.null(c(bottom, left, top, right)))
      if(outer)
        return(par("oma"))
      else 
        return(par("mar"))
    
    if(outer){
      if(is.null(bottom)) bottom <- par("oma")[1]
      if(is.null(left)) left <- par("oma")[2]
      if(is.null(top)) top <- par("oma")[3]
      if(is.null(right)) right <- par("oma")[4]
      res <- par(oma=c(bottom, left, top, right))
  
    } else {
      if(is.null(bottom)) bottom <- par("mar")[1]
      if(is.null(left)) left <- par("mar")[2]
      if(is.null(top)) top <- par("mar")[3]
      if(is.null(right)) right <- par("mar")[4]
      res <- par(mar=c(bottom, left, top, right))
  
    }
    
    invisible(res)
    
  }
  
}


Mgp <- function (title = NULL, labels = NULL, line = NULL, reset=FALSE) {
  
  if(reset){
      par("mgp" = .pardefault$mgp)
    
  } else {
    
    if(is.null(c(title, labels, line)))
      return(par("mgp"))
    
    if (is.null(title)) 
      title <- par("mgp")[1]
    if (is.null(labels)) 
      labels <- par("mgp")[2]
    if (is.null(line)) 
      line <- par("mgp")[3]
    res <- par(mgp = c(title, labels, line))
    
    invisible(res)
  }
}





###


# PlotTools *************************************


## graphics: base  ====

lines.loess <- function(x, col = Pal()[1], lwd = 2, lty = "solid", type = "l",  n = 100
                             , conf.level = 0.95, args.band = NULL, ...){

  newx <- seq(from = min(x$x, na.rm=TRUE), to = max(x$x, na.rm=TRUE), length = n)
  fit <- predict(x, newdata=newx, se = !is.na(conf.level) )

  if (!is.na(conf.level)) {

    # define default arguments for ci.band
    args.band1 <- list(col = SetAlpha(col, 0.30), border = NA)
    # override default arguments with user defined ones
    if (!is.null(args.band)) args.band1[names(args.band)] <- args.band

    # add a confidence band before plotting the smoother
    lwr.ci <- fit$fit + fit$se.fit * qnorm((1 - conf.level)/2)
    upr.ci <- fit$fit - fit$se.fit * qnorm((1 - conf.level)/2)
    do.call("DrawBand", c(args.band1, list(x=c(newx, rev(newx))), list(y=c(lwr.ci, rev(upr.ci)))) )
    # reset fit for plotting line afterwards
    fit <- fit$fit
  }

  lines( y = fit, x = newx, col = col, lwd = lwd, lty = lty, type = type)

}


lines.SmoothSpline <- function (x, col = Pal()[1], lwd = 2, lty = "solid",
                                 type = "l", conf.level = 0.95, args.band = NULL,
                                 ...) {
  # just pass on to lines
  lines.smooth.spline(x, col, lwd, lty,
                                   type, conf.level, args.band,  ...)
}


lines.smooth.spline <- function (x, col = Pal()[1], lwd = 2, lty = "solid",
                                 type = "l", conf.level = 0.95, args.band = NULL,
                                 ...) {

  # newx <- seq(from = min(x$x, na.rm = TRUE), to = max(x$x, na.rm = TRUE), length = n)
  newx <- x$x

  fit <- predict(x, newdata = newx)

  if (!is.na(conf.level)) {
    args.band1 <- list(col = SetAlpha(col, 0.3), border = NA)
    if (!is.null(args.band))
      args.band1[names(args.band)] <- args.band

    res <- (x$yin - x$y)/(1-x$lev)      # jackknife residuals
    sigma <- sqrt(var(res))                     # estimate sd
    upr.ci <- fit$y + qnorm((1 - conf.level)/2) * sigma * sqrt(x$lev)   # upper 95% conf. band
    lwr.ci <- fit$y - qnorm((1 - conf.level)/2) * sigma * sqrt(x$lev)   # lower 95% conf. band

    do.call("DrawBand", c(args.band1, list(x = c(newx, rev(newx))),
                          list(y = c(lwr.ci, rev(upr.ci)))))

  }

  lines(y = fit$y, x = fit$x, col = col, lwd = lwd, lty = lty, type = type)
}



# lines.lm <- function (x, col = Pal()[1], lwd = 2, lty = "solid",
#                       type = "l", n = 100, conf.level = 0.95, args.cband = NULL,
#                       pred.level = NA, args.pband = NULL, ...) {
# 
#   # ** BUG ** BUG ** BUG ** BUG **BUG ** BUG **BUG ** BUG **BUG ** BUG **
#   #  \__/  \__/  \__/  \__/  \__/  \__/  \__/  \__/  \__/  \__/  \__/  \__/
#   #  (oo)  (oo)  (oo)  (oo)  (oo)  (oo)  (oo)  (oo)  (oo)  (oo)  (oo)  (oo)
#   # //||\\//||\\//||\\//||\\//||\\//||\\//||\\//||\\//||\\//||\\//||\\//||\\
#   # ** BUG ** BUG ** BUG ** BUG **BUG ** BUG **BUG ** BUG **BUG ** BUG **
# 
#   # # does not work with all transformations!!!!!!!!!!
#   # plot(log(Fertility) ~ log(Examination), data=swiss)
#   # r.lm <- lm(log(Fertility) ~ log(Examination), data=swiss)
#   # lines(r.lm)
#   #
#   # swiss$lEx <- log(swiss$Examination)
#   # r.lm <- lm(log(Fertility) ~ lEx, data=swiss)
#   # lines(r.lm)
# 
# 
#   mod <- x$model
# 
#   # we take simply the second column of the model data.frame to identify the x variable
#   # this will crash, if there are several resps and yield nonsense if there is
#   # more than one pred,
#   # so check for a simple regression model y ~ x (just one resp, just one pred)
# 
#   # Note:
#   # The following will not work, because predict does not correctly recognise the newdata data.frame:
#   # lines(lm(d.pizza$temperature ~ d.pizza$delivery_min), col=hred, lwd=3)
#   # see what happens to the data.frame colnames in: predict(x, newdata=data.frame("d.pizza$delivery_min"=1:20))
#   # this predict won't work.
#   # always provide data:    y ~ x, data
# 
#   # this is not a really new problem:
#   # http://faustusnotes.wordpress.com/2012/02/16/problems-with-out-of-sample-prediction-using-r/
# 
#   # we would only plot lines if there's only one predictor
# 
#   pred <- all.vars(formula(x)[[3]])
#   if(length(pred) > 1) {
#     stop("Can't plot a linear model with more than 1 predictor.")
#   }
# 
#   # the values of the predictor
#   xpred <- eval(x$call$data)[, pred]
# 
#   newx <- data.frame(seq(from = min(xpred, na.rm = TRUE),
#                          to = max(xpred, na.rm = TRUE), length = n))
# 
#   colnames(newx) <- pred
#   fit <- predict(x, newdata = newx)
# 
#   if (!(is.na(pred.level) || identical(args.pband, NA)) ) {
#     args.pband1 <- list(col = SetAlpha(col, 0.12), border = NA)
#     if (!is.null(args.pband))
#       args.pband1[names(args.pband)] <- args.pband
# 
#     ci <- predict(x, interval="prediction", newdata=newx, level=pred.level) # Vorhersageband
#     do.call("DrawBand", c(args.pband1, list(x = c(unlist(newx), rev(unlist(newx)))),
#                           list(y = c(ci[,2], rev(ci[,3])))))
#   }
# 
#   if (!(is.na(conf.level) || identical(args.cband, NA)) ) {
#     args.cband1 <- list(col = SetAlpha(col, 0.12), border = NA)
#     if (!is.null(args.cband))
#       args.cband1[names(args.cband)] <- args.cband
# 
#     ci <- predict(x, interval="confidence", newdata=newx, level=conf.level) # Vertrauensband
#     do.call("DrawBand", c(args.cband1, list(x = c(unlist(newx), rev(unlist(newx)))),
#                           list(y = c(ci[,2], rev(ci[,3])))))
#   }
# 
#   lines(y = fit, x = unlist(newx), col = col, lwd = lwd, lty = lty,
#         type = type)
# }




.CalcTrendline <- function (x, n = 100, conf.level = 0.95, pred.level = 0.95, xpred=NULL, ...) {
 
  # this takes the model x and calculates a set of n points
  # including the function, confidence band for E[X] and for the prediction
   
  mod <- x$model
  
  # all.vars returns all used variables in the model, even when poly models are used
  # the result will be the name of the predictor
  pred <- all.vars(formula(x)[[3]])
  if (length(pred) > 1) {
    stop("Can't plot a linear model with more than 1 predictor.")
  }
  
  # xpred <- model.frame(x)[, pred]
  # we cannot simply take the model frame here as we would miss poly(..) models
  # which could well be plotted as well   
  
  # we can't access the raw data for the plot from the model frame, so
  # we try to reevaluate in parent.frame
  # this will fail if we are called from a function, where the parent.frame
  # does not contain the data
  if(is.null(xpred))
    xpred <- eval(x$call$data, parent.frame(n=2))[, pred]
  
  if(!is.numeric(xpred)){
    # predictor might be a factor
    xpred <- as.numeric(xpred)
    warning("Nonnumerc predictor has been casted as numeric.")
  }
    
  
  if(is.null(xpred))
    stop("Data can't be accessed in parent.frame. Provide x-range for prediction (xpred=c(from, to)).")

  rawx <- data.frame(seq(from = min(xpred, na.rm = TRUE), 
                         to = max(xpred, na.rm = TRUE), length = n))
  colnames(rawx) <- pred
  
  fit <- predict(x, newdata = rawx)
  
  # check if polynomial model, for then we need the rawx to calculate xy.coord
  isPolyMod <- grepl("poly,", toString(formula(x)[[3]]))
  if(isPolyMod)
    newx <- rawx
  else 
    newx <- eval(formula(x)[[3]], rawx)
  
  if (!(is.na(conf.level))) {
    ci <- predict(x, interval = "confidence", newdata = rawx, 
                   level = conf.level)[, -1]
  } else ci <- NULL
  
  if (!(is.na(pred.level))) {
    pci <- predict(x, interval = "prediction", newdata = rawx, 
                   level = pred.level)[, -1]
  } else pci <- NULL
  
  return(list(x=newx, y=fit, ci=ci, pci=pci))
  
}


.DrawTrendLine <- function(z, col = Pal()[1], lwd = 2, lty = "solid", type = "l", 
                        args.cband = NULL,  args.pband = NULL) {
  
  # this draws a trendline in an existing plot
  
  args.pband1 <- list(col = SetAlpha(col, 0.12), border = NA)
  if (!identical(args.pband, NA) && !is.null(z$pci)) {
    if (!is.null(args.pband))
      args.pband1[names(args.pband)] <- args.pband
    do.call("DrawBand", c(args.pband1, list(x = c(unlist(z$x), rev(unlist(z$x)))), 
                        list(y = c(z$pci[, 1], rev(z$pci[, 2])))))
  }
  
  args.cband1 <- list(col = SetAlpha(col, 0.12), border = NA)
  if (!identical(args.cband, NA) && !is.null(z$ci)) {
    if (!is.null(args.cband))
      args.cband1[names(args.cband)] <- args.cband
    do.call("DrawBand", c(args.cband1, list(x = c(unlist(z$x), rev(unlist(z$x)))), 
                        list(y = c(z$ci[, 1], rev(z$ci[, 2])))))
  }
  
  lines(y = z$y, x = unlist(z$x), col = col, lwd = lwd, lty = lty,
        type = type)
  
}



lines.lm <- function (x, col = Pal()[1], lwd = 2, lty = "solid",
                      type = "l", n = 100, conf.level = 0.95, args.cband = NULL,
                      pred.level = NA, args.pband = NULL, xpred=NULL, ...) {
  
  z <- .CalcTrendline(x, n=n, conf.level=conf.level, pred.level=pred.level, xpred=xpred)  
  .DrawTrendLine(z, col=col, lwd=lwd, lty=lty, args.cband=args.cband, args.pband=args.pband)

}


lines.lmlog <- function (x, col = Pal()[1], lwd = 2, lty = "solid",
                      type = "l", n = 100, conf.level = 0.95, args.cband = NULL,
                      pred.level = NA, args.pband = NULL, ...) {
  
  # expects a model of the form log(y) ~ x
  
  z <- .CalcTrendline(x, n=n, conf.level=conf.level, pred.level=pred.level)
  # exponentiate y and all ci results, but not x (,1)
  i <- which(!sapply(z[2:4], is.null)) + 1
  z[i] <- lapply(z[i], exp)

  .DrawTrendLine(z, col=col, lwd=lwd, lty=lty, args.cband=args.cband, args.pband=args.pband)
  
}





SmoothSpline <- function(x, ...){
  UseMethod("SmoothSpline")
}


SmoothSpline.default <- function (x, y = NULL, w = NULL, df, spar = NULL, cv = FALSE,
          all.knots = FALSE, nknots = .nknots.smspl, keep.data = TRUE,
          df.offset = 0, penalty = 1, control.spar = list(), tol = 0.000001 *
            IQR(x), ...){
  # just pass everything to smooth.spline
  smooth.spline(x=x, y=y, w=w, df=df, spar=spar, cv=cv,
            all.knots=all.knots, nknots=nknots, keep.data=keep.data,
            df.offset=df.offset, penalty=penalty, control.spar=control.spar, tol=tol)
}


SmoothSpline.formula <- function(formula, data, subset, na.action, ...) {
  #   mf <- model.frame(x, data)
  #   x <- mf[,2]
  #   y <- mf[,1]
  #   identify(x, y, ...)

  if (missing(formula) || (length(formula) != 3L) || (length(attr(terms(formula[-2L]),
                                                                  "term.labels")) != 1L))
    stop("'formula' missing or incorrect")
  m <- match.call(expand.dots = FALSE)
  if (is.matrix(eval(m$data, parent.frame())))
    m$data <- as.data.frame(data)
  m[[1L]] <- quote(stats::model.frame)
  m$... <- NULL
  mf <- eval(m, parent.frame())
  response <- attr(attr(mf, "terms"), "response")

  SmoothSpline(x=mf[[-response]], y=mf[[response]], ...)

}




ErrBars <- function(from, to = NULL, pos = NULL, mid = NULL, horiz = FALSE, col = par("fg"), lty = par("lty"),
                       lwd = par("lwd"), code = 3, length=0.05,
                       pch = NA, cex.pch = par("cex"), col.pch = par("fg"), bg.pch = par("bg"), ... ) {

  if(is.null(to)) {
    if(dim(from)[2] %nin% c(2,3)) stop("'from' must be a kx2 or a kx3 matrix, when 'to' is not provided.")
    if(dim(from)[2] == 2) {
      to <- from[,2]
      from <- from[,1]
    } else {
      mid <- from[,1]
      to <- from[,3]
      from <- from[,2]
    }

  }
  if(is.null(pos)) pos <- 1:length(from)
  if(horiz){
    arrows( x0=from, x1=to, y0=pos, col=col, lty=lty, lwd=lwd, angle=90, code=code, length=length, ... )
  } else {
    arrows( x0=pos, y0=from, y1=to, col=col, lty=lty, lwd=lwd, angle=90, code=code, length=length, ... )
  }
  if(!is.na(pch) && !is.na(col.pch)){
    if(is.null(mid)) mid <- (from + to)/2
    # plot points
    if(horiz){
      points(x=mid, y=pos, pch = pch, cex = cex.pch, col = col.pch, bg=bg.pch)
    } else {
      points(x=pos, y=mid, pch = pch, cex = cex.pch, col = col.pch, bg=bg.pch)
    }
  }
}


ColorLegend <- function( x, y=NULL, cols=rev(heat.colors(100)), labels=NULL
                          , width=NULL, height=NULL, horiz=FALSE
                          , xjust=0, yjust=1, inset=0, border=NA, frame=NA
                          , cntrlbl = FALSE
                          , adj=ifelse(horiz,c(0.5,1), c(1,0.5)), cex=1.0
                          , title = NULL, title.adj=0.5, ...) {
  
  # positionierungscode aus legend
  auto <- if (is.character(x))
    match.arg(x, c("bottomright", "bottom", "bottomleft",
                   "left", "topleft", "top", "topright", "right", "center"))
  else NA
  
  usr <- par("usr")
  if( is.null(width) ) width <- strwidth("mn") # (usr[2L] - usr[1L]) * ifelse(horiz, 0.92, 0.08)
  if( is.null(height) ) height <- (usr[4L] - usr[3L]) * ifelse(horiz, 0.08, 0.92)
  
  if (is.na(auto)) {
    left <- x - xjust * width
    top <- y + (1 - yjust) * height
    
  } else {
    inset <- rep(inset, length.out = 2)
    insetx <- inset[1L] * (usr[2L] - usr[1L])
    left <- switch(auto, bottomright = , topright = ,
                   right = usr[2L] - width - insetx, bottomleft = ,
                   left = , topleft = usr[1L] + insetx, bottom = ,
                   top = , center = (usr[1L] + usr[2L] - width)/2)
    insety <- inset[2L] * (usr[4L] - usr[3L])
    top <- switch(auto, bottomright = , bottom = , bottomleft = usr[3L] +
                    height + insety, topleft = , top = , topright = usr[4L] -
                    insety, left = , right = , center = (usr[3L] +
                                                           usr[4L] + height)/2)
  }
  
  xpd <- par(xpd=TRUE); on.exit(par(xpd))
  
  ncols <- length(cols)
  nlbls <- length(labels)
  if(horiz) {
    rect( xleft=left, xright=left+width/ncols*seq(ncols,0,-1), ytop=top, ybottom=top-height,
          col=rev(cols), border=border)
    if(!is.null(labels)){
      if(cntrlbl) xlbl <- left + width/(2*ncols)+(width-width/ncols)/(nlbls-1) * seq(0,nlbls-1,1)
      else xlbl <- left + width/(nlbls-1) * seq(0,nlbls-1,1)
      ylbl <- top - (height + max(strheight(labels, cex=cex)) * 1.2) 
      text(y=ylbl
           # Gleiche Korrektur wie im vertikalen Fall
           # , x=x+width/(2*ncols)+(width-width/ncols)/(nlbls-1) * seq(0,nlbls-1,1)
           , x=xlbl, labels=labels, adj=adj, cex=cex, ...)
    }
  } else {
    rect( xleft=left, ybottom=top-height, xright=left+width, ytop=top-height/ncols*seq(0,ncols,1),
          col=rev(cols), border=border)
    if(!is.null(labels)){
      # Korrektur am 13.6:
      # die groesste und kleinste Beschriftung sollen nicht in der Mitte der Randfarbkaestchen liegen,
      # sondern wirklich am Rand des strips
      # alt: , y=y-height/(2*ncols)- (height- height/ncols)/(nlbls-1)  * seq(0,nlbls-1,1)
      #, y=y-height/(2*ncols)- (height- height/ncols)/(nlbls-1)  * seq(0,nlbls-1,1)
      
      # 18.4.2015: reverse labels, as the logic below would misplace...
      labels <- rev(labels)
      
      if(cntrlbl) ylbl <- top - height/(2*ncols) - (height- height/ncols)/(nlbls-1)  * seq(0, nlbls-1,1)
      else ylbl <- top - height/(nlbls-1) * seq(0, nlbls-1, 1)
      xlbl <- left + width + strwidth("0", cex=cex) + max(strwidth(labels, cex=cex)) * adj[1]
      text(x=xlbl
           , y=ylbl, labels=labels, adj=adj, cex=cex, ... )
    }
  }
  if(!is.na(frame)) rect( xleft=left, xright=left+width, ytop=top, ybottom=top-height, border=frame)
  
  if (!is.null(title)) 
    text(left + width * title.adj, top + strheight("M")*1.4, labels = title, 
         adj = c(title.adj, 0), cex=cex)
  
  invisible(list(rect=list(w=width, h=height, left=left, top=top), 
                 text=list(x=if(is.null(labels)) NULL else xlbl, 
                           y=if(is.null(labels)) NULL else ylbl)))
  
}





BoxLegend <- function( x, y=NULL, cols=NULL, labels=NULL
                         , width=NULL, height=NULL, horiz=FALSE
                         , xjust=0, yjust=1, inset=0, border=NA, frame=NA
                         , cntrlbl = FALSE
                         , adj=ifelse(horiz,c(0.5,1), c(1,0.5)), cex=1.0, ...){
  
  # ********************************
  # in development  *************
  # ********************************
  
  
  # positionierungscode aus legend
  auto <- if (is.character(x))
    match.arg(x, c("bottomright", "bottom", "bottomleft",
                   "left", "topleft", "top", "topright", "right", "center"))
  else NA
  
  usr <- par("usr")
  if( is.null(width) ) width <- strwidth("mn") # (usr[2L] - usr[1L]) * ifelse(horiz, 0.92, 0.08)
  if( is.null(height) ) height <- (usr[4L] - usr[3L]) * ifelse(horiz, 0.08, 0.92)
  
  if (is.na(auto)) {
    left <- x - xjust * width
    top <- y + (1 - yjust) * height
    
  } else {
    inset <- rep(inset, length.out = 2)
    insetx <- inset[1L] * (usr[2L] - usr[1L])
    left <- switch(auto, bottomright = , topright = ,
                   right = usr[2L] - width - insetx, bottomleft = ,
                   left = , topleft = usr[1L] + insetx, bottom = ,
                   top = , center = (usr[1L] + usr[2L] - width)/2)
    insety <- inset[2L] * (usr[4L] - usr[3L])
    top <- switch(auto, bottomright = , bottom = , bottomleft = usr[3L] +
                    height + insety, topleft = , top = , topright = usr[4L] -
                    insety, left = , right = , center = (usr[3L] + usr[4L] + height)/2)
  }
  
  xpd <- par(xpd=TRUE); on.exit(par(xpd))
  
  # xleft=left, ybottom=top-height, xright=left+width, ytop=top-height
  
  # Mar(right=15)
  # boxplot(temperature ~ area, d.pizza)
  # BoxLegend()
  
  arrows(x0 = 4.25, y0 = 25, y1=55, angle = 90, code = 3)
  rect(xleft = 4, ybottom = 30, xright = 4.5, ytop = 45, col="grey")
  segments(x0 = 4, y0 = 35, x1 = 4.5, lwd=3)
  points(x = 4.25, y = 38, pch=3, cex=3)
  
  segments(x0 = 4.6, x1 = 4.8, y0 = c(25,30,35,38,45,55), col="darkgrey")
  text(x = 4.9, y = c(25,30,35,38,45,55), adj=0,
       labels = c("10%", "25%", "median", "mean", "75%", "90%"))
  
}



BubbleLegend <- function(x, y=NULL, area, cols
                         , labels=NULL, cols.lbl = "black"
                         , width = NULL, xjust = 0, yjust = 1, inset=0, border="black", frame=TRUE
                         , adj=c(0.5,0.5), cex=1.0, cex.names=1, bg = NULL, ...){

  # positionierungscode aus legend
  auto <- if(is.character(x))
    match.arg(x, c("bottomright", "bottom", "bottomleft",
                   "left", "topleft", "top", "topright", "right", "center"))
  else NA

  radius <- sqrt((area * cex)/pi)

  usr <- par("usr")
  if(is.null(width))
    width <- 2*max(radius) * 1.1 / Asp()

  # if(is.null(asp)) # get aspect ratio from plot  w/h
  #   asp <- par("pin")[1]/diff(par("usr")[1:2]) / par("pin")[2]/diff(par("usr")[3:4])

  height <- width * Asp()

  if (is.na(auto)) {
    left <- x - xjust * width
    top <- y + (1 - yjust) * height

  } else {
    inset <- rep(inset, length.out = 2)
    insetx <- inset[1L] * (usr[2L] - usr[1L])
    left <- switch(auto, bottomright = , topright = , right = usr[2L] -
                     width - insetx, bottomleft = , left = , topleft = usr[1L] +
                     insetx, bottom = , top = , center = (usr[1L] + usr[2L] -
                                                            width)/2)
    insety <- inset[2L] * (usr[4L] - usr[3L])
    top <- switch(auto, bottomright = , bottom = , bottomleft = usr[3L] +
                    height + insety, topleft = , top = , topright = usr[4L] -
                    insety, left = , right = , center = (usr[3L] + usr[4L] +
                                                           height)/2)
  }

  xpd <- par(xpd=TRUE); on.exit(par(xpd))

  if(!is.na(frame))
    rect( xleft=left, ybottom=top-height, xright=left+width, ytop=top,
          col=bg, border=frame)

  # DrawCircle(x = left + width/2, y = (top - height/2) + max(radius) - radius,
  #            r.out = radius, col=cols, border=border)

  DrawEllipse(x = left + width/2, y = top-height/2 + max(radius) - radius,
              radius.x = radius / Asp(), radius.y = radius,
              col = cols, border=border)

  if(!is.null(labels)){
    d <- c(0, 2*radius)
    # ylbl <- (top - height/2) + max(radius) - diff(d) /2 + d[-length(d)]
    ylbl <- rev((top - height/2) + max(radius) - Midx(rev(2*radius), incl.zero = TRUE))
    text(x=left + width/2, y=ylbl, labels=labels, adj=adj, cex=cex.names, col=cols.lbl, ... )
  }

}





Canvas <- function(xlim=NULL, ylim=xlim, main=NULL, xpd=par("xpd"), mar=c(5.1,5.1,5.1,5.1),
                   asp=1, bg=par("bg"), usrbg="white", ...){

  SetPars <- function(...){

    # expand dots
    arg <- unlist(match.call(expand.dots=FALSE)$...)
    # match par arguments
    par.args <- as.list(arg[names(par(no.readonly = TRUE)[names(arg)])])
    # store old values
    old <- par(no.readonly = TRUE)[names(par.args)]

    # set new values
    do.call(par, par.args)

    # return old ones
    invisible(old)

  }


  if(is.null(xlim)){
    xlim <- c(-1,1)
    ylim <- xlim
  }
  if(length(xlim)==1) {
    xlim <- c(-xlim,xlim)
    ylim <- xlim
  }

  oldpar <- par("xpd"=xpd, "mar"=mar, "bg"=bg) # ;  on.exit(par(usr))

  SetPars(...)

  plot( NA, NA, xlim=xlim, ylim=ylim, main=main, asp=asp, type="n", xaxt="n", yaxt="n",
        xlab="", ylab="", frame.plot = FALSE, ...)

  if(usrbg != "white"){
    usr <- par("usr")
    rect(xleft=usr[1], ybottom=usr[3], xright=usr[2], ytop=usr[4], col=usrbg, border=NA)
  }

  # we might want to reset parameters afterwards
  invisible(oldpar)

}


Midx <- function(x, incl.zero = FALSE, cumulate = FALSE){
  if(incl.zero) x <- c(0, x)
  res <- filter(x, rep(1/2,2))
  res <-  res[-length(res)]
  if(cumulate) res <- cumsum(res)
  return(res)
}


###

## graphics: colors ----

Pal <- function(pal, n=100, alpha=1) {

  if(missing(pal)) {
    res <- getOption("palette", default = structure(Pal("Helsana")[c(6,1:5,7:10)] ,
                     name = "Helsana", class = c("palette", "character")) )

  } else {

    palnames <- c("RedToBlack","RedBlackGreen","SteeblueWhite","RedWhiteGreen",
                  "RedWhiteBlue0","RedWhiteBlue1","RedWhiteBlue2","RedWhiteBlue3","Helsana","Helsana1","Tibco","RedGreen1",
                  "Spring","Soap","Maiden","Dark","Accent","Pastel","Fragile","Big","Long","Night","Dawn","Noon","Light",
                  "GrandBudapest","Moonrise1","Royal1","Moonrise2","Cavalcanti","Royal2","GrandBudapest2","Moonrise3",
                  "Chevalier","Zissou","FantasticFox","Darjeeling","Rushmore","BottleRocket","Darjeeling2","Helsana2",
                  "Tequila")


    if(is.numeric(pal)){
      pal <- palnames[pal]
    } else {
      # allow partial matching
      pal <- palnames[pmatch(pal, palnames)]
    }

    big <- c("#800000", "#C00000", "#FF0000", "#FFC0C0",
            "#008000","#00C000","#00FF00","#C0FFC0",
            "#000080","#0000C0", "#0000FF","#C0C0FF",
            "#808000","#C0C000","#FFFF00","#FFFFC0",
            "#008080","#00C0C0","#00FFFF","#C0FFFF",
            "#800080","#C000C0","#FF00FF","#FFC0FF",
            "#C39004","#FF8000","#FFA858","#FFDCA8")

    switch(pal
           , RedToBlack    = res <- colorRampPalette(c("red","yellow","green","blue","black"), space = "rgb")(n)
           , RedBlackGreen = res <- colorRampPalette(c("red", "black", "green"), space = "rgb")(n)
           , SteeblueWhite = res <- colorRampPalette(c("steelblue","white"), space = "rgb")(n)
           , RedWhiteGreen = res <- colorRampPalette(c("red", "white", "green"), space = "rgb")(n)
           , RedWhiteBlue0 = res <- colorRampPalette(c("red", "white", "blue"))(n)
           , RedWhiteBlue1 = res <- colorRampPalette(c("#67001F", "#B2182B", "#D6604D", "#F4A582", "#FDDBC7",
                                              "#FFFFFF", "#D1E5F0", "#92C5DE", "#4393C3", "#2166AC", "#053061"))(n)
           , RedWhiteBlue2 = res <- colorRampPalette(c("#BB4444", "#EE9988", "#FFFFFF", "#77AADD", "#4477AA"))(n)
           , RedWhiteBlue3 = res <- colorRampPalette(c(DescTools::hred, "white", DescTools::hblue))(n)
           , Helsana       = res <- c("rot"="#9A0941", "orange"="#F08100", "gelb"="#FED037"
                                       , "ecru"="#CAB790", "hellrot"="#D35186", "hellblau"="#8296C4", "hellgruen"="#B3BA12"
                                       , "hellgrau"="#CCCCCC", "dunkelgrau"="#666666", "weiss"="#FFFFFF")
           , Helsana1      = res <- c("black"="#000000", "hellblau"="#8296C4", "rot"="#9A0941", "orange"="#F08100", "gelb"="#FED037"
                                      , "ecru"="#CAB790", "hellgruen"="#B3BA12", "hellrot"="#D35186"
                                      , "hellgrau"="#CCCCCC", "dunkelgrau"="#666666")
           , Helsana2      = res <- c("#9a0941","#62aedf","#9181c6", "#e55086","#f2f2f2","#b6ca2f","#fec600","#bea786")
           , Tibco         = res <- apply( mcol <- matrix(c(
                                       0,91,0, 0,157,69, 253,1,97, 60,120,177,
                           156,205,36, 244,198,7, 254,130,1,
                           96,138,138, 178,113,60
                            ), ncol=3, byrow=TRUE), 1, function(x) rgb(x[1], x[2], x[3], maxColorValue=255))
           , RedGreen1 =  res <- c(rgb(227,0,11, maxColorValue=255), rgb(227,0,11, maxColorValue=255),
                       rgb(230,56,8, maxColorValue=255), rgb(234,89,1, maxColorValue=255),
                       rgb(236,103,0, maxColorValue=255), rgb(241,132,0, maxColorValue=255),
                       rgb(245,158,0, maxColorValue=255), rgb(251,184,0, maxColorValue=255),
                       rgb(253,195,0, maxColorValue=255), rgb(255,217,0, maxColorValue=255),
                       rgb(203,198,57, maxColorValue=255), rgb(150,172,98, maxColorValue=255),
                       rgb(118,147,108, maxColorValue=255))

           , Spring =  res <- c("#E41A1C", "#377EB8", "#4DAF4A", "#984EA3","#FF7F00", "#FFFF33", "#A65628", "#F781BF", "#999999")
           , Soap =  res <- c("#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3","#A6D854", "#FFD92F", "#E5C494", "#B3B3B3")
           , Maiden =  res <- c("#8DD3C7", "#FFFFB3", "#BEBADA", "#FB8072","#80B1D3", "#FDB462", "#B3DE69", "#FCCDE5", "#D9D9D9","#BC80BD","#CCEBC5")
           , Dark =  res <- c("#1B9E77", "#D95F02", "#7570B3", "#E7298A","#66A61E", "#E6AB02", "#A6761D", "#666666")
           , Accent =  res <- c("#7FC97F", "#BEAED4", "#FDC086", "#FFFF99","#386CB0", "#F0027F", "#BF5B17", "#666666")
           , Pastel =  res <- c("#FBB4AE", "#B3CDE3", "#CCEBC5", "#DECBE4","#FED9A6", "#FFFFCC", "#E5D8BD", "#FDDAEC", "#F2F2F2")
           , Fragile =  res <- c("#B3E2CD", "#FDCDAC", "#CBD5E8", "#F4CAE4","#E6F5C9", "#FFF2AE", "#F1E2CC", "#CCCCCC")
           , Big =  res <- big
           , Long =  res <- big[c(12,16,25,24,
                         2,11,6,15,18,26,23,
                         3,10,7,14,19,27,22,
                         4,8,20,28)]
           , Night =  res <- big[seq(1, 28, by=4)]
           , Dawn =  res <- big[seq(2, 28, by=4)]
           , Noon =  res <- big[seq(3, 28, by=4)]
           , Light = res <- big[seq(4, 28, by=4)]

           , GrandBudapest = res < c("#F1BB7B", "#FD6467", "#5B1A18", "#D67236")
           , Moonrise1 = res <- c("#F3DF6C", "#CEAB07", "#D5D5D3", "#24281A")
           , Royal1 = res <- c("#899DA4", "#C93312", "#FAEFD1", "#DC863B")
           , Moonrise2 = res <- c("#798E87","#C27D38", "#CCC591", "#29211F")
           , Cavalcanti = res <- c("#D8B70A", "#02401B","#A2A475", "#81A88D", "#972D15")
           , Royal2 = res <- c("#9A8822", "#F5CDB4", "#F8AFA8", "#FDDDA0", "#74A089")
           , GrandBudapest2 = res <- c("#E6A0C4", "#C6CDF7", "#D8A499", "#7294D4")
           , Moonrise3 = res <- c("#85D4E3", "#F4B5BD", "#9C964A", "#CDC08C", "#FAD77B")
           , Chevalier = res <- c("#446455", "#FDD262", "#D3DDDC", "#C7B19C")
           , Zissou = res <- c("#3B9AB2", "#78B7C5", "#EBCC2A", "#E1AF00", "#F21A00")
           , FantasticFox = res <- c("#DD8D29", "#E2D200", "#46ACC8", "#E58601", "#B40F20")
           , Darjeeling = res <- c("#FF0000", "#00A08A", "#F2AD00", "#F98400", "#5BBCD6")
           , Rushmore = res <- c("#E1BD6D", "#EABE94", "#0B775E", "#35274A", "#F2300F")
           , BottleRocket = res <- c("#A42820", "#5F5647", "#9B110E", "#3F5151", "#4E2A1E", "#550307", "#0C1707")
           , Darjeeling2 = res <- c("#ECCBAE", "#046C9A", "#D69C4E", "#ABDDDE",  "#000000")
           , Tequila = res <- c("#642580", "#853b88","#ab4189","#c52966","#d34376","#d55586","#d55586","#ba3723","#cc6101","#c6904a","#eebd00","#f7d501","#060c18","#00323b","#00484f")

    )

    attr(res, "name") <- pal
    class(res) <- append(class(res), "palette")

  }

  if(alpha != 1)
    res <- SetAlpha(res, alpha = alpha)

  return(res)

}



print.palette <- function(x, ...){
  cat(attr(x, "name"), "\n")
  cat(x, "\n")
}




plot.palette <- function(x, cex = 3, ...) {

  # # use new window, but store active device if already existing
  # if( ! is.null(dev.list()) ){
  #   curwin <- dev.cur()
  #   on.exit( {
  #     dev.set(curwin)
  #     par(oldpar)
  #   }
  #   )
  # }
  # windows(width=3, height=2.5, xpos=100, ypos=600)

  oldpar <- par(mar=c(0,0,0,0), mex=0.001, xaxt="n", yaxt="n", ann=FALSE, xpd=NA)
  on.exit(par(oldpar))

  palname <- Coalesce(attr(x, "name"), "no name")

  n <- length(x)

  x <- rev(x)
  plot( x=rep(1, n), y=1:n, pch=22, cex=cex, col="grey60", bg=x, xlab="", ylab="", axes=FALSE,
        frame.plot=FALSE, ylim=c(0, n + 2), xlim=c(0.8, n))

  text( x=4.5, y=n + 1.2, labels="alpha", adj=c(0,0.5), cex=0.8)
  text( x=0.8, y=n + 2.0, labels=gettextf("\"%s\" Palette colors", palname), adj=c(0,0.5), cex=1.2)
  text( x=c(1,2.75,3.25,3.75,4.25), y= n +1.2, adj=c(0.5,0.5), labels=c("1.0", 0.8, 0.6, 0.4, 0.2), cex=0.8 )
  abline(h=n+0.9, col="grey")

  palnames <- paste(n:1, names(x))

  sapply(1:n, function(i){
    xx <- c(2.75, 3.25, 3.75, 4.25)
    yy <- rep(i, 4)
    points(x=xx, y=yy, pch=22, cex=cex, col="grey60", bg=SetAlpha(x[i], alpha=c(0.8, 0.6, 0.4, 0.2)))
    text(x=1.25, y=i, adj=c(0,0.5), cex=0.8, labels=palnames[i])

  })

  invisible()

  # points( x=rep(2.75,7), y=1:7, pch=15, cex=2, col=hc(7:1, alpha=0.8) )
  # points( x=rep(3.25,7), y=1:7, pch=15, cex=2, col=hc(7:1, alpha=0.6) )
  # points( x=rep(3.75,7), y=1:7, pch=15, cex=2, col=hc(7:1, alpha=0.4) )
  # points( x=rep(4.25,7), y=1:7, pch=15, cex=2, col=hc(7:1, alpha=0.2) )


}




# example:
# barplot(1:7, col=SetAlpha(PalHelsana[c("ecru","hellgruen","hellblau")], 1) )

###


## geometric primitives ====

Stamp <- function(txt=NULL, las=par("las"), cex=0.6) {

  # set an option like:
  # options(stamp=expression("gettextf('%s/%s', Sys.getenv('USERNAME'), Format(Today(), fmt='yyyy-mm-dd')))")
  # if stamp is an expression, it will be evaluated

  stamp <- function(x) {

#    opar <- par(yaxt='s', xaxt='s', xpd=TRUE)
    opar <- par(yaxt='s', xaxt='s', xpd=NA)
    on.exit(par(opar))
    plt <- par('plt')
    usr <- par('usr')

    ## when a logrithmic scale is in use (i.e. par('xlog') is true),
    ## then the x-limits would be 10^par('usr')[1:2].  Similarly for
    ## the y axis
    xcoord <- usr[2] + (usr[2] - usr[1])/(plt[2] - plt[1]) *
      (1-plt[2]) - cex*strwidth('m')
    ycoord <- usr[3] - diff(usr[3:4])/diff(plt[3:4])*(plt[3]) +
      cex*strheight('m')

    if(par('xlog')) xcoord <- 10^(xcoord)
    if(par('ylog')) ycoord <- 10^(ycoord)

    if(las==3){
      srt <- 90
      adj <- 0
    } else {
      srt <- 0
      adj <- 1
    }
    ## Print the text on the current plot
    text(xcoord, ycoord, x, adj=adj, srt=srt, cex=cex)
    invisible(x)
  }

  if(is.null(txt)) {
    # get the option
    txt <- DescToolsOptions("stamp")
    if(is.null(txt)){
      txt <- format(Sys.time(), '%Y-%m-%d')
      } else {
      if(is.expression(txt)){
        txt <- eval(parse(text = txt))
      }
    }
  }

  invisible(stamp(txt))

}



BoxedText <- function(x, ...) 
  UseMethod("BoxedText")


  
BoxedText.default <- function(x, y = NULL, labels = seq_along(x), adj = NULL,
     pos = NULL, offset = 0.5, vfont = NULL,
     cex = 1, col = NULL, font = NULL, srt = 0, xpad = 0.2, ypad=0.2,
     density = NULL, angle = 45,
     bg = NA, border = par("fg"), lty = par("lty"), lwd = par("lwd"), ...) {


  .BoxedText <- function(x, y = NULL, labels = seq_along(x), adj = NULL,
       pos = NA, offset = 0.5, vfont = NULL,
       cex = 1, col = NULL, font = NULL, srt = 0, xpad = 0.2, ypad=0.2,
       density = NULL, angle = 45,
       bg = NA, border = NULL, lty = par("lty"), lwd = par("lwd"), ...) {
    
    # we don't manage to remove the color otherwise
    if(is.na(bg)) density <- 0

    if(is.na(pos)) pos <- NULL   # we have to change default NULL to NA to be able to repeat it
    if(is.na(vfont)) vfont <- NULL

    w <- strwidth(labels, cex=cex, font=font, vfont=vfont)
    h <- strheight(labels, cex=cex, font=font, vfont=vfont)

    if(length(adj) == 1) adj <- c(adj, 0.5)

    xl <- x - adj[1] * w - strwidth("M", cex=cex, font=font, vfont=vfont) * xpad
    xr <- xl + w + 2*strwidth("M", cex=cex, font=font, vfont=vfont) * xpad

    yb <- y - adj[2] * h - strheight("M", cex=cex, font=font, vfont=vfont) * ypad
    yt <- yb + h + 2*strheight("M", cex=cex, font=font, vfont=vfont) * ypad

    xy <- Rotate(x=c(xl,xl,xr,xr), y=c(yb,yt,yt,yb), mx=x, my=y, theta=DegToRad(srt))
    polygon(x=xy$x, y=xy$y, col=bg, density=density, angle=angle, border=border, lty=lty, lwd=lwd, ...)

    text(x=x, y=y, labels=labels, adj=adj, pos=pos, offset=offset, vfont=vfont, cex=cex, col=col, font=font, srt=srt)
  }

  x <- xy.coords(x, y, recycle = TRUE, setLab = FALSE)
  
  if(is.null(adj))
    adj <- c(0.5, 0.5)
  else
    adj <- rep(adj, length.out=2)
  if (is.null(pos)) pos <- NA
  if (is.null(vfont)) vfont <- NA
  if (is.null(col)) col <- par("fg")
  if (is.null(font)) font <- 1
  if (is.null(density)) density <- NA

  # recyle arguments:
  #   which parameter has the highest dimension
  # attention: we cannot repeat NULLs but we can repeat NAs, so we swap NULLs to NAs and
  #            reset them to NULL above
  lst <- list(x=x$x, y=x$y, labels=labels, pos=pos, offset=offset, vfont=vfont,
     cex=cex, col=col, font=font, srt=srt, xpad=xpad, ypad=ypad,
     density=density, angle=angle, bg=bg, border=border, lty=lty, lwd=lwd)
  maxdim <- max(unlist(lapply(lst, length)))

  # recycle all params to maxdim
  lgp <- lapply(lst, rep, length.out=maxdim )
  lgp$adj <- as.list(data.frame(replicate(adj, n=maxdim)))

  for( i in 1:maxdim){
    .BoxedText(
      x=lgp$x[i], y=lgp$y[i], labels=lgp$labels[i], adj=lgp$adj[[i]], pos=lgp$pos[i], offset=lgp$offset[i]
      , vfont=lgp$vfont[i], cex=lgp$cex[i], col=lgp$col[i], font=lgp$font[i]
      , srt=lgp$srt[i], xpad=lgp$xpad[i], ypad=lgp$ypad[i], density=lgp$density[i]
      , angle=lgp$angle[i], bg=lgp$bg[i], border=lgp$border[i], lty=lgp$lty[i], lwd=lgp$lwd[i] )
  }
}


BoxedText.formula <- function (formula, data = parent.frame(), ..., subset) {
  
  m <- match.call(expand.dots = FALSE)
  eframe <- parent.frame()
  md <- eval(m$data, eframe)
  if (is.matrix(md)) 
    m$data <- md <- as.data.frame(data)
  dots <- lapply(m$..., eval, md, eframe)
  m$... <- NULL
  m <- as.list(m)
  m[[1L]] <- stats::model.frame.default
  m <- as.call(c(m, list(na.action = NULL)))
  mf <- eval(m, eframe)
  
  if (!missing(subset)) {
    s <- eval(m$subset, data, eframe)
    if (!missing(data)) {
      l <- nrow(data)
    } else {
      mtmp <- m
      mtmp$subset <- NULL
      l <- nrow(eval(mtmp, eframe))
    }
    
    dosub <- function(x) if (length(x) == l) 
      x[s]
    else x
    
    dots <- lapply(dots, dosub)
  }
  
  response <- attr(attr(mf, "terms"), "response")
  
  if (response) {
    varnames <- names(mf)
    y <- mf[[response]]
    if (length(varnames) > 2L) 
      stop("cannot handle more than one 'x' coordinate")
    xn <- varnames[-response]
    if (length(xn) == 0L) 
      do.call("BoxedText", c(list(y), dots))
    else do.call("BoxedText", c(list(mf[[xn]], y), dots))
    
  } else stop("must have a response variable")
  
}





DrawBezier <- function (x = 0, y = x, nv = 100,  col = par("col"), lty = par("lty")
  , lwd = par("lwd"), plot = TRUE ) {

    if (missing(y)) {
        y <- x[[2]]
        x <- x[[1]]
    }
    n <- length(x)
    X <- Y <- single(nv)
    Z <- seq(0, 1, length = nv)
    X[1] <- x[1]
    X[nv] <- x[n]
    Y[1] <- y[1]
    Y[nv] <- y[n]
    for (i in 2:(nv - 1)) {
        z <- Z[i]
        xz <- yz <- 0
        const <- (1 - z)^(n - 1)
        for (j in 0:(n - 1)) {
            xz <- xz + const * x[j + 1]
            yz <- yz + const * y[j + 1]
            const <- const * (n - 1 - j)/(j + 1) * z/(1 - z)
# debugging only:
#            if (is.na(const)) print(c(i, j, z))
        }
        X[i] <- xz
        Y[i] <- yz
    }
    if(plot) lines(x = as.single(X), y = as.single(Y), col=col, lty=lty, lwd=lwd )
    invisible(list(x = as.single(X), y = as.single(Y)))
}



DrawRegPolygon <- function( x = 0, y = x, radius.x = 1, radius.y = radius.x, rot = 0, nv = 3,
      border = par("fg"), col = par("bg"), lty = par("lty"), lwd = par("lwd"), plot = TRUE ) {

    # The workhorse for the geom stuff

    # example:
    # plot(c(0,1),c(0,1), asp=1, type="n")
    # DrawRegPolygon( x=0.5, y=0.5, radius.x=seq(0.5,0.1,-0.1), rot=0, nv=3:10, col=2)
    # DrawRegPolygon( x=0.5+1:5*0.05, y=0.5, radius.x=seq(0.5,0.1,-0.1), rot=0, nv=100, col=1:5)

    # which geom parameter has the highest dimension
    lgp <- list(x=x, y=y, radius.x=radius.x, radius.y=radius.y, rot=rot, nv=nv)
    maxdim <- max(unlist(lapply(lgp, length)))
    # recycle all params to maxdim
    lgp <- lapply( lgp, rep, length.out=maxdim )

    # recycle shape properties
    if (length(col) < maxdim)    { col <- rep(col, length.out = maxdim) }
    if (length(border) < maxdim) { border <- rep(border, length.out = maxdim) }
    if (length(lwd) < maxdim)    { lwd <- rep(lwd, length.out = maxdim) }
    if (length(lty) < maxdim)    { lty <- rep(lty, length.out = maxdim) }

    lst <- list()   # prepare result
    for (i in 1:maxdim) {
        theta.inc <- 2 * pi / lgp$nv[i]
        theta <- seq(0, 2 * pi - theta.inc, by = theta.inc)
        ptx <- cos(theta) * lgp$radius.x[i] + lgp$x[i]
        pty <- sin(theta) * lgp$radius.y[i] + lgp$y[i]
        if(lgp$rot[i] > 0){
          # rotate the structure if the angle is > 0
          dx <- ptx - lgp$x[i]
          dy <- pty - lgp$y[i]
          ptx <- lgp$x[i] + cos(lgp$rot[i]) * dx - sin(lgp$rot[i]) * dy
          pty <- lgp$y[i] + sin(lgp$rot[i]) * dx + cos(lgp$rot[i]) * dy
        }
        if( plot )
          polygon(ptx, pty, border = border[i], col = col[i], lty = lty[i],
              lwd = lwd[i])
        lst[[i]] <- list(x = ptx, y = pty)
    }

    lst <- lapply(lst, xy.coords)
    if(length(lst)==1)
      lst <- lst[[1]]

    invisible(lst)
}




DrawCircle <- function (x = 0, y = x, r.out = 1, r.in = 0, theta.1 = 0,
                        theta.2 = 2 * pi, border = par("fg"), col = NA, lty = par("lty"),
                        lwd = par("lwd"), nv = 100, plot = TRUE) {

  DrawSector <- function(x, y, r.in, r.out, theta.1,
                         theta.2, nv, border, col, lty, lwd, plot) {

    # get arc coordinates
    pts <- DrawArc(x = x, y = y, rx = c(r.out, r.in), ry = c(r.out, r.in),
                   theta.1 = theta.1, theta.2 = theta.2, nv = nv,
                   col = border, lty = lty, lwd = lwd, plot = FALSE)

    is.ring <- (r.in != 0)
    is.sector <- any( ((theta.1-theta.2) %% (2*pi)) != 0)

    if(is.ring || is.sector) {
      # we have an inner and an outer circle
      ptx <- c(pts[[1]]$x, rev(pts[[2]]$x))
      pty <- c(pts[[1]]$y, rev(pts[[2]]$y))

    } else {
      # no inner circle
      ptx <- pts[[1]]$x
      pty <- pts[[1]]$y
    }

    if (plot) {
      if (is.ring & !is.sector) {
        # we have angles, so plot polygon for the area and lines for borders
        polygon(x = ptx, y = pty, col = col, border = NA,
                lty = lty, lwd = lwd)

        lines(x = pts[[1]]$x, y = pts[[1]]$y, col = border, lty = lty, lwd = lwd)
        lines(x = pts[[2]]$x, y = pts[[2]]$y, col = border, lty = lty, lwd = lwd)

      }
      else {
        polygon(x = ptx, y = pty, col = col, border = border,
                lty = lty, lwd = lwd)
      }
    }
    invisible(list(x = ptx, y = pty))
  }

  lgp <- DescTools::Recycle(x=x, y=y, r.in = r.in, r.out = r.out,
                            theta.1 = theta.1, theta.2 = theta.2, border = border,
                            col = col, lty = lty, lwd = lwd, nv = nv)
  lst <- list()
  for (i in 1L:attr(lgp, "maxdim")) {
    pts <- with(lgp, DrawSector(x=x[i], y=y[i], r.in=r.in[i],
                                r.out=r.out[i], theta.1=theta.1[i],
                                theta.2=theta.2[i], nv=nv[i], border=border[i],
                                col=col[i], lty=lty[i], lwd=lwd[i],
                                plot = plot))
    lst[[i]] <- pts
  }
  invisible(lst)
}





#
# DrawCircle <- function( x = 0, y = x, radius = 1, rot = 0, nv = 100, border = par("fg"), col = par("bg")
#   , lty = par("lty"), lwd = par("lwd"), plot = TRUE ) {
#   invisible( DrawRegPolygon(  x = x, y = y, radius.x=radius, nv=nv, border=border, col=col, lty=lty, lwd=lwd, plot = plot ) )
# }


DrawEllipse <- function( x = 0, y = x, radius.x = 1, radius.y = 0.5, rot = 0, nv = 100, border = par("fg"), col = par("bg")
  , lty = par("lty"), lwd = par("lwd"), plot = TRUE ) {
  invisible( DrawRegPolygon(  x = x, y = y, radius.x = radius.x, radius.y = radius.y, nv = nv, rot = rot
    , border = border, col = col, lty = lty, lwd = lwd, plot = plot ) )
}




DrawArc <- function (x = 0, y = x, rx = 1, ry = rx, theta.1 = 0,
                     theta.2 = 2*pi, nv = 100, col = par("col"), lty = par("lty"),
                     lwd = par("lwd"), plot = TRUE) {

  # recycle all params to maxdim
  lgp <- DescTools::Recycle(x=x, y=y, rx = rx, ry = ry,
                            theta.1 = theta.1, theta.2 = theta.2, nv = nv,
                            col=col, lty=lty, lwd=lwd)

  lst <- list()
  for (i in 1L:attr(lgp, "maxdim")) {
    dthetha <- lgp$theta.2[i] - lgp$theta.1[i]

    theta <- seq(from = 0,
                 to = ifelse(dthetha < 0, dthetha + 2 * pi, dthetha),
                 length.out = lgp$nv[i]) + lgp$theta.1[i]

    ptx <- (cos(theta) * lgp$rx[i] + lgp$x[i])
    pty <- (sin(theta) * lgp$ry[i] + lgp$y[i])
    if (plot) {
      lines(ptx, pty, col = lgp$col[i], lty = lgp$lty[i], lwd = lgp$lwd[i])
    }
    lst[[i]] <- list(x = ptx, y = pty)
  }

  invisible(lst)

}



DrawBand <- function(x, y, col = SetAlpha("grey", 0.5), border = NA) {

  # accept matrices but then only n x y
  if(!identical(dim(y), dim(x))){
    x <- as.matrix(x)
    y <- as.matrix(y)

    if(dim(x)[2] == 1 && dim(y)[2] == 2)
      x <- x[, c(1,1)]
    else if(dim(x)[2] == 2 && dim(y)[2] == 1)
      y <- y[, c(1,1)]
    else
      stop("incompatible dimensions for matrices x and y")

    x <- c(x[,1], rev(x[,2]))
    y <- c(y[,1], rev(y[,2]))

  }

  # adds a band to a plot, normally used for plotting confidence bands
  polygon(x=x, y=y, col = col, border = border)
}



Clockwise <- function(x, start=0){
  # Calculates begin and end angles from a list of given angles
  angles <- c(0, cumsum(x), 2*pi)
  revang <- 2*pi - angles + start
  return(data.frame( from=revang[-1], to=revang[-length(revang)]))
}


Rotate <- function( x, y=NULL, mx = NULL, my = NULL, theta=pi/3, asp=1 ) {

  # # which geom parameter has the highest dimension
  # lgp <- list(x=x, y=y)
  # maxdim <- max(unlist(lapply(lgp, length)))
  # # recycle all params to maxdim
  # lgp <- lapply( lgp, rep, length.out=maxdim )

  # polygon doesn't do that either!!

  xy <- xy.coords(x, y)

  if(is.null(mx))
    mx <- mean(xy$x)

  if(is.null(my))
    my <- mean(xy$y)

  # rotate the structure
  dx <- xy$x - mx
  dy <- xy$y - my
  ptx <- mx + cos(theta) * dx - sin(theta) * dy / asp
  pty <- my + sin(theta) * dx * asp + cos(theta) * dy

  return(xy.coords(x=ptx, y=pty))

}


GeomTrans <- function(x, y=NULL, trans=0, scale=1, theta=0) {

  # https://reference.wolfram.com/language/ref/ScalingTransform.html

  xy <- xy.coords(x, y)
  trans <- rep_len(trans, length.out=2)
  scale <- rep_len(trans, length.out=2)

  xy$x <- (xy$x * scale[1]) + trans[1]
  xy$y <- (xy$y * scale[2]) + trans[2]

  xy <- Rotate(xy, theta = theta)

  return(xy)
}



Asp <- function(){

  w <- par("pin")[1]/diff(par("usr")[1:2])
  h <- par("pin")[2]/diff(par("usr")[3:4])
  asp <- w/h

  return(asp)

}




LineToUser <- function(line, side) {

  # http://stackoverflow.com/questions/29125019/get-margin-line-locations-mgp-in-user-coordinates
  # jbaums

  # Converts line dimensions to user coordinates

  lh <- par('cin')[2] * par('cex') * par('lheight')

  x_off <- diff(grconvertX(0:1, 'inches', 'user'))
  y_off <- diff(grconvertY(0:1, 'inches', 'user'))

  switch(side,
         `1` = par('usr')[3] - line * y_off * lh,
         `2` = par('usr')[1] - line * x_off * lh,
         `3` = par('usr')[4] + line * y_off * lh,
         `4` = par('usr')[2] + line * x_off * lh,
         stop("side must be 1, 2, 3, or 4", call.=FALSE))

}



# Transferred to DescToolsAddIns 2024-03-02
# 
# Arrow <- function(x0, y0, x1, y1, col=par("bg"), border = par("fg"), head=1, cex=1, lwd=1, lty=1){
# 
#   ArrowHead <- function(x=0, y=0, type=2, cex=1, theta=0){
# 
#     # choose a default
#     rx <- par("pin")[1] / 100  * cex
# 
#     # get aspect ratio for not allowing the arrowhead to lose form
#     asp <- Asp()
# 
#     head <- DrawRegPolygon(x, y, radius.x = rx, radius.y = rx * asp, plot=FALSE)
# 
#     if(type==3){
#       head$x <- append(head$x, head$x[1] - rx, 2)
#       head$y <- append(head$y, y, 2)
#     }
# 
#     # Rotate the head
#     head <- Rotate(head, theta=theta, mx=x, my=y, asp = asp)
# 
#     head$x <- head$x - rx * cos(theta)
#     head$y <- head$y - rx * sin(theta)
# 
#     return(head)
# 
#   }
# 
# 
#   if(head > 1){
#     segments(x0 = x0, y0 = y0, x1 = x1, y1 = y1, lty=lty, lwd=lwd)
#     head <- ArrowHead(x=x1, y=y1, type=head, cex=cex,
#                       theta= (atan((y0-y1) / Asp() /(x0-x1)) + (x0 > x1) * pi))
# 
#     polygon(head, col=col, border=border)
# 
#   } else {
#     arrows(x0 = x0, y0 = y0, x1 = x1, y1 = y1, lty=lty, lwd=lwd)
#   }
# 
#   invisible()
# 
# }
# 


SpreadOut <- function(x, mindist = NULL, cex = 1.0) {

  if(is.null(mindist))
    mindist <- 0.9 * max(strheight(x, "inch", cex = cex))

  if(sum(!is.na(x)) < 2) return(x)
  xorder <- order(x)
  goodx <- x[xorder][!is.na(x[xorder])]
  gxlen <- length(goodx)
  start <- end <- gxlen%/%2

  # nicely spread groups of short intervals apart from their mean
  while(start > 0) {
    while(end < gxlen && goodx[end+1] - goodx[end] < mindist) end <- end+1
    while(start > 1 && goodx[start] - goodx[start-1] < mindist) start <- start-1
    if(start < end) {
      nsqueezed <- 1+end-start
      newx <- sum(goodx[start:end]) / nsqueezed - mindist * (nsqueezed %/% 2 - (nsqueezed / 2 == nsqueezed %/% 2) * 0.5)
      for(stretch in start:end) {
        goodx[stretch] <- newx
        newx <- newx+mindist
      }
    }
    start <- end <- start-1
  }

  start <- end <- length(goodx) %/% 2 + 1
  while(start < gxlen) {
    while(start > 1 && goodx[start] - goodx[start-1] < mindist) start <- start-1
    while(end < gxlen && goodx[end+1] - goodx[end] < mindist) end <- end+1
    if(start < end) {
      nsqueezed <- 1 + end - start
      newx <- sum(goodx[start:end]) / nsqueezed - mindist * (nsqueezed %/% 2 - (nsqueezed / 2 == nsqueezed %/% 2) * 0.5)
      for(stretch in start:end) {
        goodx[stretch] <- newx
        newx <- newx+mindist
      }
    }
    start <- end <- end+1
  }

  # force any remaining short intervals apart
  if(any(diff(goodx) < mindist)) {
    start <- gxlen %/% 2
    while(start > 1) {
      if(goodx[start] - goodx[start-1] < mindist)
        goodx[start-1] <- goodx[start] - mindist
      start <- start-1
    }
    end <- gxlen %/% 2
    while(end < gxlen) {
      if(goodx[end+1] - goodx[end] < mindist)
        goodx[end+1] <- goodx[end]+mindist
      end <- end+1
    }
  }

  x[xorder][!is.na(x[xorder])] <- goodx
  return(x)

}



# BarText <- function(height, b, labels=height, beside = FALSE, horiz = FALSE,
#                     cex=par("cex"), 
#                     adj=NULL, 
#                     pos=c("topout", "topin", "mid", "bottomin", "bottomout"), 
#                     offset=0, ...) {
# 
#   if (is.vector(height) || (is.array(height) && (length(dim(height)) == 1))) {
#     height <- cbind(height)
#     beside <- TRUE
#   }
# 
#   offset <- rep_len(as.vector(offset), length(height))
#   
#   pos <- match.arg(pos)
#   
#   
#   if(beside){
#     if(horiz){
#       if(is.null(adj)) adj <- 0
#       adjy <- 0.5
#       
#       if(pos=="topout"){
#         x <- height + offset + 1.2 * sign(height) * par("cxy")[1] * cex
#         adjx <- Recode(x = factor(sign(x+offset)), "0"=1, "1"=-1, num = TRUE)
#       }
#       else if(pos=="topin") {
#         x <- height + offset - 1.2 * sign(height) * par("cxy")[1] * cex
#         adjx <- Recode(x = factor(sign(x+offset)), "1"=1, "0"=-1, num = TRUE)
#       }
#       else if(pos=="mid"){
#         x <- offset + height / 2
#         adjx <- 0.5
#       }
#       else if(pos=="bottomout") {
#         x <- offset - 1.2 * sign(height) * par("cxy")[1] * cex
#         adjx <- Recode(x = factor(sign(x+offset)), "1"=1, "0"=-1, num = TRUE)
#       }
#       else if(pos=="bottomin") {
#         x <- offset + 1.2 * sign(height) * par("cxy")[1] * cex
#         adjx <- Recode(x = factor(sign(x+offset)), "0"=1, "1"=-1, num = TRUE)
#       }
# 
#       pp <- Recycle(b=b, x=x, labels=labels, adjx=adjx, adjy=adjy)
#       
#       for(i in seq(attr(pp, "maxdim"))){
#         with(pp, text(y=b[i], x=x[i], labels=labels[i], 
#                       adj=c(adjx[i], adjy[i]), 
#                       cex=cex, xpd=TRUE, ...))    
#       } 
#       
#       res <- pp$x
#       
# 
#     } else {
#       
#       if(is.null(adj)) adjx <- 0.5
#       
#       if(pos=="topout")
#         y <- height + offset + sign(height) * par("cxy")[2] * cex
#       else if(pos=="topin")
#         y <- height + offset - sign(height) * par("cxy")[2] * cex
#       else if(pos=="mid")
#         y <- offset + height/2
#       if(pos=="bottomin")
#         y <- offset + sign(height) * par("cxy")[2] * cex
#       if(pos=="bottomout")
#         y <- offset - sign(height) * par("cxy")[2] * cex
# 
#       text(x=b, y=y, labels=labels, xpd=TRUE, cex=cex, adj=adj, ...) # 
#       
#       res <- y
#       
#     }
# 
#     # The xpd=TRUE means to not plot the text even if it is outside
#     # of the plot area and par("cxy") gives the size of a typical
#     # character in the current user coordinate system.
# 
#     
#     
# 
#   } else {
#     if(horiz){
#       if(is.null(adj)) adj <- 0.5
#       x <- t(apply(offset + height, 2, Midx, incl.zero=TRUE, cumulate=TRUE))
#       text(labels=t(labels), x=x, y=b, cex=cex, adj=adj, ...) 
#     } else {
#       if(is.null(adj)) adj <- 0.5
#       x <- t(apply(offset + height, 2, Midx, incl.zero=TRUE, cumulate=TRUE))
#       text(labels=t(labels), x=b, y=x, cex=cex, adj=adj, ...) 
#     }
#     res <- x
#     
#   }
# 
#   invisible(res)
# 
# }




BarText <- function(height, b, labels=height, beside = FALSE, horiz = FALSE,
                     cex=par("cex"), 
                     adj=NULL, 
                     pos=c("topout", "topin", "mid", "bottomin", "bottomout"), 
                     offset=0, ...) {

  # allow to use the more flexible BoxedText instead of text here  
  # redirection to be able to change defaults of BoxedText
  .btext <- function (x, y = NULL, labels = seq_along(x), adj = NULL, pos = NULL, 
                      offset = 0.5, vfont = NULL, cex = 1, font = NULL, col=NULL,
                      srt = 0, xpad = 0.2, ypad = 0.2, density = NULL, angle = 45, 
                      border = NA, lty = par("lty"), 
                      lwd = par("lwd"), ...) {
    
    BoxedText(x=x, y=y, labels = labels, adj = adj, pos = pos, 
              offset = offset, vfont = vfont, cex = cex, col=col,
              font = font, 
              srt = srt, xpad = xpad, ypad = ypad, density = density, angle = angle, 
              border = border, lty = lty, 
              lwd = lwd, ...) 
    
  }
  
  
  if (is.vector(height) || (is.array(height) && (length(dim(height)) == 1))) {
    height <- cbind(height)
    beside <- TRUE
  }
  
  offset <- rep_len(as.vector(offset), length(height))
  
  pos <- match.arg(pos)
  
  
  if(beside){
    if(horiz){
      if(is.null(adj)) adj <- 0
      adjy <- 0.5
      
      if(pos=="topout"){
        x <- height + offset + 1.2 * sign(height) * par("cxy")[1] * cex
        adjx <- Recode(x = factor(sign(x+offset)), "0"=1, "1"=-1, num = TRUE)
      }
      else if(pos=="topin") {
        x <- height + offset - 1.2 * sign(height) * par("cxy")[1] * cex
        adjx <- Recode(x = factor(sign(x+offset)), "1"=1, "0"=-1, num = TRUE)
      }
      else if(pos=="mid"){
        x <- offset + height / 2
        adjx <- 0.5
      }
      else if(pos=="bottomout") {
        x <- offset - 1.2 * sign(height) * par("cxy")[1] * cex
        adjx <- Recode(x = factor(sign(x+offset)), "1"=1, "0"=-1, num = TRUE)
      }
      else if(pos=="bottomin") {
        x <- offset + 1.2 * sign(height) * par("cxy")[1] * cex
        adjx <- Recode(x = factor(sign(x+offset)), "0"=1, "1"=-1, num = TRUE)
      }
      
      pp <- Recycle(b=b, x=x, labels=labels, adjx=adjx, adjy=adjy)
      
      for(i in seq(attr(pp, "maxdim"))){
        with(pp, .btext(y=b[i], x=x[i], labels=labels[i], 
                      adj=c(adjx[i], adjy[i]), 
                      cex=cex, xpd=TRUE, ...))    
      } 
      
      res <- pp$x
      
      
    } else {
      
      if(is.null(adj)) adjx <- 0.5
      
      if(pos=="topout")
        y <- height + offset + sign(height) * par("cxy")[2] * cex
      else if(pos=="topin")
        y <- height + offset - sign(height) * par("cxy")[2] * cex
      else if(pos=="mid")
        y <- offset + height/2
      if(pos=="bottomin")
        y <- offset + sign(height) * par("cxy")[2] * cex
      if(pos=="bottomout")
        y <- offset - sign(height) * par("cxy")[2] * cex
      
      .btext(x=b, y=y, labels=labels, xpd=TRUE, cex=cex, adj=adj, ...) # 
      
      res <- y
      
    }
    
    # The xpd=TRUE means to not plot the text even if it is outside
    # of the plot area and par("cxy") gives the size of a typical
    # character in the current user coordinate system.
    
    
    
    
  } else {
    
    if(horiz)
      shift <- par("cxy")[1] * cex * .5
    else 
      shift <- par("cxy")[2] * cex * .25
    
    
    if(pos=="topout"){
      x <- t(apply(offset + height, 2, cumsum) + sign(height) * shift)
      adjx <- 0
      
    } else if(pos=="topin") {
      x <- t(apply(offset + height, 2, cumsum) - sign(height) * shift)
      adjx <- 1
      
    } else if(pos=="mid"){
      x <- t(apply(offset + height, 2, Midx, incl.zero=TRUE, cumulate=TRUE))
      adjx <- 0.5
      
    } else if(pos=="bottomin"){
      x <- t(head(rbind(0, apply(offset + height, 2, cumsum)), -1) + sign(height) * shift)
      adjx <- 0
      
    } else if(pos=="bottomout"){
      x <- t(head(rbind(0, apply(offset + height, 2, cumsum)), -1) - sign(height) * shift)
      adjx <- 1
      
    }
    
    if(horiz){
      
      if(is.null(adj)) adj <- 0.5
      adjy <- 0.5
      
      .btext(labels=t(labels), x=x, y=b, cex=cex, adj=c(adjx, adjy), ...)
      
    } else {
      if(is.null(adj)) adj <- 0.5
      adjy <- adjx
      adjx <- 0.5
      
      .btext(labels=t(labels), x=b, y=x, cex=cex, adj=c(adjx, adjy), ...)
      
    }
    
    res <- x
    
  }
  
  invisible(res)
  
}





ConnLines <- function(..., col = 1, lwd = 1, lty = "solid", xalign = c("mar","mid") ) {

  # add connection lines to a barplot
  # ... are the arguments, passed to barplot

  b <- barplot(..., plot = FALSE)

  arg <- unlist(match.call(expand.dots = FALSE)$...)
  if(is.null(arg$horiz)) horiz <- FALSE else horiz <- eval(arg$horiz, parent.frame())
  # debug: print(horiz)

  nr <- nrow(eval(arg[[1]], parent.frame())) # nrow(height)
  nc <- length(b)

  if(!is.null(nr)) {
    tmpcum <- apply(eval(arg[[1]], parent.frame()), 2, cumsum)
    ypos1 <- tmpcum[, -nc]
    ypos2 <- tmpcum[, -1]

  } else {
    tmpcum <- eval(arg[[1]], parent.frame())
    ypos1 <- tmpcum[-nc]
    ypos2 <- tmpcum[-1]
    nr <- 1
  }

  xalign <- match.arg(xalign)
  if(xalign=="mar"){

    # the midpoints of the bars
    mx <- (b[-1] + b[-length(b)]) / 2

    if(is.null(arg$space)) space <- 0.2
    else space <- eval(arg$space, parent.frame())

    lx <- mx - space/2
    rx <- mx + space/2

    xpos1 <- rep(lx, rep(nr, length(lx)))
    xpos2 <- rep(rx, rep(nr, length(rx)))

    if(horiz == FALSE)
      segments(xpos1, ypos1, xpos2, ypos2, col=col, lwd=lwd, lty=lty)
    else
      segments(ypos1, xpos1, ypos2, xpos2, col=col, lwd=lwd, lty=lty)

  } else if(xalign=="mid") {
    if(horiz == FALSE) {
      if(nr > 1)
        matlines(x=replicate(nr, b), y=t(tmpcum), lty=lty, lwd=lwd, col=col)
      else
        lines(x=b, y=tmpcum, lty=lty, lwd=lwd, col=col)
    } else {
      if(nr > 1)
        matlines(y=replicate(nr, b), x=t(tmpcum), lty=lty, lwd=lwd, col=col)
      else
        lines(y=b, x=tmpcum, lty=lty, lwd=lwd, col=col)

    }
  }

  invisible()

}


AxisBreak <- function (axis = 1, breakpos = NULL, pos = NA, bgcol = "white",
          breakcol = "black", style = "slash", brw = 0.02) {

  figxy <- par("usr")
  xaxl <- par("xlog")
  yaxl <- par("ylog")
  xw <- (figxy[2] - figxy[1]) * brw
  yw <- (figxy[4] - figxy[3]) * brw
  if (!is.na(pos))
    figxy <- rep(pos, 4)
  if (is.null(breakpos))
    breakpos <- ifelse(axis%%2, figxy[1] + xw * 2, figxy[3] +
                         yw * 2)
  if (xaxl && (axis == 1 || axis == 3))
    breakpos <- log10(breakpos)
  if (yaxl && (axis == 2 || axis == 4))
    breakpos <- log10(breakpos)
  switch(axis, br <- c(breakpos - xw/2, figxy[3] - yw/2, breakpos +
                         xw/2, figxy[3] + yw/2), br <- c(figxy[1] - xw/2, breakpos -
                                                           yw/2, figxy[1] + xw/2, breakpos + yw/2), br <- c(breakpos -
                                                                                                              xw/2, figxy[4] - yw/2, breakpos + xw/2, figxy[4] + yw/2),
         br <- c(figxy[2] - xw/2, breakpos - yw/2, figxy[2] +
                   xw/2, breakpos + yw/2), stop("Improper axis specification."))
  old.xpd <- par("xpd")
  par(xpd = TRUE)
  if (xaxl)
    br[c(1, 3)] <- 10^br[c(1, 3)]
  if (yaxl)
    br[c(2, 4)] <- 10^br[c(2, 4)]
  if (style == "gap") {
    if (xaxl) {
      figxy[1] <- 10^figxy[1]
      figxy[2] <- 10^figxy[2]
    }
    if (yaxl) {
      figxy[3] <- 10^figxy[3]
      figxy[4] <- 10^figxy[4]
    }
    if (axis == 1 || axis == 3) {
      rect(breakpos, figxy[3], breakpos + xw, figxy[4],
           col = bgcol, border = bgcol)
      xbegin <- c(breakpos, breakpos + xw)
      ybegin <- c(figxy[3], figxy[3])
      xend <- c(breakpos, breakpos + xw)
      yend <- c(figxy[4], figxy[4])
      if (xaxl) {
        xbegin <- 10^xbegin
        xend <- 10^xend
      }
    }
    else {
      rect(figxy[1], breakpos, figxy[2], breakpos + yw,
           col = bgcol, border = bgcol)
      xbegin <- c(figxy[1], figxy[1])
      ybegin <- c(breakpos, breakpos + yw)
      xend <- c(figxy[2], figxy[2])
      yend <- c(breakpos, breakpos + yw)
      if (xaxl) {
        xbegin <- 10^xbegin
        xend <- 10^xend
      }
    }
    par(xpd = TRUE)
  }
  else {
    rect(br[1], br[2], br[3], br[4], col = bgcol, border = bgcol)
    if (style == "slash") {
      if (axis == 1 || axis == 3) {
        xbegin <- c(breakpos - xw, breakpos)
        xend <- c(breakpos, breakpos + xw)
        ybegin <- c(br[2], br[2])
        yend <- c(br[4], br[4])
        if (xaxl) {
          xbegin <- 10^xbegin
          xend <- 10^xend
        }
      }
      else {
        xbegin <- c(br[1], br[1])
        xend <- c(br[3], br[3])
        ybegin <- c(breakpos - yw, breakpos)
        yend <- c(breakpos, breakpos + yw)
        if (yaxl) {
          ybegin <- 10^ybegin
          yend <- 10^yend
        }
      }
    }
    else {
      if (axis == 1 || axis == 3) {
        xbegin <- c(breakpos - xw/2, breakpos - xw/4,
                    breakpos + xw/4)
        xend <- c(breakpos - xw/4, breakpos + xw/4, breakpos +
                    xw/2)
        ybegin <- c(ifelse(yaxl, 10^figxy[3 + (axis ==
                                                 3)], figxy[3 + (axis == 3)]), br[4], br[2])
        yend <- c(br[4], br[2], ifelse(yaxl, 10^figxy[3 +
                                                        (axis == 3)], figxy[3 + (axis == 3)]))
        if (xaxl) {
          xbegin <- 10^xbegin
          xend <- 10^xend
        }
      }
      else {
        xbegin <- c(ifelse(xaxl, 10^figxy[1 + (axis ==
                                                 4)], figxy[1 + (axis == 4)]), br[1], br[3])
        xend <- c(br[1], br[3], ifelse(xaxl, 10^figxy[1 +
                                                        (axis == 4)], figxy[1 + (axis == 4)]))
        ybegin <- c(breakpos - yw/2, breakpos - yw/4,
                    breakpos + yw/4)
        yend <- c(breakpos - yw/4, breakpos + yw/4, breakpos +
                    yw/2)
        if (yaxl) {
          ybegin <- 10^ybegin
          yend <- 10^yend
        }
      }
    }
  }
  segments(xbegin, ybegin, xend, yend, col = breakcol, lty = 1)
  par(xpd = FALSE)
}





ABCCoords <- function(x="topleft", region="figure", 
                      cex=NULL, linset=0, ...) {
  
  region <- match.arg(region, c("figure", "plot", "device"))
  
  auto <- match.arg(x, c("bottomright", "bottom", "bottomleft",
                         "left", "topleft", "top", "topright", "right", "center"))
  
  
  # positioning code from legend()
  
  if(region %in% c("figure", "device")) {
    
    ds <- dev.size("in")
    # xy coordinates of device corners in user coordinates
    x <- grconvertX(c(0, ds[1]), from="in", to="user")
    y <- grconvertY(c(0, ds[2]), from="in", to="user")
    # fragment of the device we use to plot
    
    if(region == "figure") {
      fig <- par("fig")
      dx <- (x[2] - x[1])
      dy <- (y[2] - y[1])
      x <- x[1] + dx * fig[1:2]
      y <- y[1] + dy * fig[3:4]
    } 
  } else if(region == "plot"){
    
    usr <- par("usr")
    x <- usr[1:2]
    y <- usr[3:4]
    
  }
  
  
  linset <- rep(linset, length.out = 2)
  linsetx <- linset[1L] * strwidth("M", cex=1, units = "user", ...)
  x1 <- switch(auto, 
               bottomright = x[2] - linsetx, 
               topright = x[2] - linsetx,
               right = x[2] - linsetx, 
               bottomleft = x[1] + linsetx,
               left = x[1] + linsetx, 
               topleft = x[1] + linsetx, 
               bottom = (x[1] + x[2])/2,
               top = (x[1] + x[2])/2, 
               center = (x[1] + x[2])/2)
  
  linsety <- linset[2L] * strheight("M", cex=1, units = "user", ...)
  y1 <- switch(auto, 
               bottomright = y[1] + linsety, 
               bottom = y[1] + linsety, 
               bottomleft = y[1] + linsety, 
               topleft = y[2] - linsety, 
               top = y[2] - linsety, 
               topright = y[2] - linsety, 
               left = (y[1] + y[2])/2, 
               right = (y[1] + y[2])/2, 
               center = (y[1] + y[2])/2)
  
  adj <- switch(auto,
                topleft     =c(0,1),
                top         =c(0.5, 1),
                topright    =c(1,1),
                left        =c(0, 0.5),
                center      =c(0.5,0.5),
                right       =c(1, 0.5),
                bottomleft  =c(0,0),
                bottom      =c(0.5,0),
                bottomright =c(1,0))
  
  
  return(list(xy=xy.coords(x1, y1), adj=adj))
  
}



Bg <- function(col="grey", region=c("plot", "figure"), border=NA) {
  
  .Bg <- function(col="grey", region="plot", border=NA) {
    
    if(region=="plot")
      rect(par("usr")[1], par("usr")[3], par("usr")[2], par("usr")[4], 
           col = col, border=border)
    
    else if(region == "figure"){
      ds <- dev.size("in")
      # xy coordinates of device corners in user coordinates
      x <- grconvertX(c(0, ds[1]), from="in", to="user")
      y <- grconvertY(c(0, ds[2]), from="in", to="user")
      
      rect(x[1], y[2], x[2], y[1], 
           col = col, border=border, xpd=NA)
    }
  }
  
  if(length(col)==1){
    region <- match.arg(region)
    .Bg(col=col, region=region, border=border)
    
  } else {
    arg <- Recycle(col=col, region=region, border=border)
    for(i in attr(arg, "maxdim"):1){
      .Bg(col=arg$col[i], region=arg$region[i], border=arg$border[i])
    }
    
  }
  
  
}






###

## graphics: conversions ====


PolToCart <- function(r, theta) list(x=r*cos(theta), y=r*sin(theta))

CartToPol <- function(x, y) {
  theta <- atan(y/x)
  theta[x<0] <- theta[x<0] + pi    # atan can't find the correct square (quadrant)
  list(r = sqrt(x^2 + y^2), theta=theta)
}


CartToSph <- function (x, y, z, up = TRUE ) {

  vphi <- CartToPol(x, y)          # x, y -> c( w, phi )
  R <- if (up) {
    CartToPol(vphi$r, z)          # ( w, z,  -> r, theta )
  } else {
    CartToPol(z, vphi$r)          # ( z, w,  -> r, theta )
  }
  res <- c(R[1], R[2], vphi[2])
  names(res) <- c("r", "theta", "phi")

  return (res)
}


SphToCart <- function (r, theta, phi, up = TRUE) {

  if (up) theta <- pi/2 - theta

  vz <- PolToCart(r, theta)
  xy <- PolToCart(vz$y, phi)

  res <- list(x=xy$x, y=xy$x, z=vz$x)

  return (res)
}



ColToHex <- function(col, alpha=1) {
  col.rgb <- col2rgb(col)
  col <- apply( col.rgb, 2, function(x) sprintf("#%02X%02X%02X", x[1], x[2], x[3]) )
  if(alpha != 1 ) col <- paste( col, DecToHex( round( alpha * 255, 0)), sep="")
  return(col)
  # old: sprintf("#%02X%02X%02X", col.rgb[1], col.rgb[2], col.rgb[3])
}


HexToRgb <- function(hex) {
  # converts a hexstring color to matrix with 3 red/green/blue rows
  # example: HexToRgb(c("#A52A2A","#A52A3B"))

  # replaced by 0.99.27
  # c2 <- do.call("cbind", lapply(hex, function(x) c(strtoi(substr(x,1,2), 16L),
  #                                                  strtoi(substr(x,3,4), 16L),
  #                                                  strtoi(substr(x,5,6), 16L)
  # )))

  hex <- gsub("^#", "", hex)
  if(all(is.na(hex)))
    return(matrix(NA, nrow=3, ncol=length(hex)))
  
  # if there are any RRGGBBAA values mixed with RRGGBB then pad FF (for opaque) on RGBs
  if(any(nchar(hex)==8)){
    hex <- DescTools::StrPad(x = hex, width = 8, pad = "FF")
    i <- 4
  } else {
    i <- 3
  }
  c2 <- sapply(hex, function(x) c(red=   strtoi(substr(x,1,2), 16L),
                                  green= strtoi(substr(x,3,4), 16L),
                                  blue=  strtoi(substr(x,5,6), 16L),
                                  alpha= strtoi(substr(x,7,8), 16L))
               )
  
  res <- cbind(c2[1:i,])
  if(dim(res)[2]==1)
    colnames(res) <- hex
  
  return(res)

}


RgbToHex <- function(col){
  paste0("#", paste0(DecToHex(round(col)), collapse=""))
}



CmykToRgb <- function(cyan, magenta, yellow, black, maxColorValue=1){
  
  if (missing(black)) {
    res <- rgb(red= maxColorValue- cyan,
               green= maxColorValue - magenta,
               blue = maxColorValue - yellow, 
               maxColorValue = maxColorValue)
    
  } else {
    
    res <-  rgb(
      red= ((maxColorValue-cyan) * (maxColorValue-black)) / maxColorValue,
      green= ((maxColorValue-magenta) * (maxColorValue-black)) / maxColorValue,
      blue = ((maxColorValue-yellow) * (maxColorValue-black)) / maxColorValue,
      maxColorValue = maxColorValue)
    
  }
  
  return(res)
  
}


RgbToCmy <- function(col, maxColorValue=1) {
  
  if(!is.matrix(col)) {
    col <- lapply(col, function(x) c(strtoi(substr(x,2,3), 16L), strtoi(substr(x,4,5), 16L), strtoi(substr(x,6,7), 16L)))
    col <- do.call("cbind", col)
  }
  
  cbind(
    C = 1 - ( col[,1] / maxColorValue ),
    M = 1 - ( col[,2] / maxColorValue ),
    Y = 1 - ( col[,3] / maxColorValue )
  )   
  
}


CmyToCmyk <- function(col){
  # CMY values <- From 0 to 1
  
  if (is.null(dim(col))) 
    if (length(col) > 2) 
      col <- matrix(col, ncol=3, byrow=TRUE)
    
    var.K <- rep(1, dim(col)[1])
    
    CC <- which(col[,1] < var.K)
    if (length(CC)>0) var.K[CC] <- col[CC,1]
    
    CM <- which(col[,2] < var.K)
    if (length(CM)>0) var.K[CM] <- col[CM,2]
    
    CY <- which(col[,3] < var.K)
    if (length(CY)>0) var.K[CY] <- col[CY,3]
    
    cbind(
      C = ( col[,1] - var.K ) / ( 1 - var.K ),
      M = ( col[,2] - var.K ) / ( 1 - var.K ), 
      Y = ( col[,3] - var.K ) / ( 1 - var.K ), 
      K = var.K )
}


CmykToCmy <- function(col){
  
  #CMYK values <- From 0 to 1
  
  if (is.null(dim(col))) 
    if (length(col)>2) 
      col <- matrix(col, ncol=4,byrow=TRUE)
    cbind(
      C = ( col[,1] * ( 1 - col[,4] ) + col[,4] ),
      M = ( col[,2] * ( 1 - col[,4] ) + col[,4] ),
      Y = ( col[,3] * ( 1 - col[,4] ) + col[,4] )
    )
    
}




ColToOpaque <- function(col, alpha=NULL, bg=NULL){
  
  # col is Hex color, alpha is numeric from 0..1
  
  # https://graphicdesign.stackexchange.com/questions/113007/how-to-determine-the-equivalent-opaque-rgb-color-for-a-given-partially-transpare
  # round(255 - alpha * (255-ColToRgb(col)))
  if(is.null(bg))
    bg <- ColToRgb("white")
  
  if(is.null(alpha)){
    # try to get the alpha channel from the color
    # this generates an incomprehensible error message, if there's no 4th dim:
    # Error in sapply(col, HexToRgb)[4, ] : subscript out of bounds
    alpha <- sapply(col, HexToRgb)[4,] / 255
    
  } else {
    alpha[na <- alpha %][% c(0, 1)] <- NA
  }
  
  # recycle col and alpha
  lst <- Recycle(rgb=lapply(col, HexToRgb), alpha=alpha)
  
  
  # algorithm:    res <- round(bg - alpha * (bg - col))
  
  res <- SetNames(
    sapply(1:attr(lst, "maxdim"), function(i)
      # discard any alpha channel by only using rows 1:3
      round(bg - lst[["alpha"]][[i]] * (bg - lst[["rgb"]][[i]][1:3, ]))),
    colnames = paste0(lapply(lst[["rgb"]], function(z) RgbToHex(z[1:3, ])), 
                      DecToHex(round(lst[["alpha"]] * 255))) 
  )
  
  res <- apply(res, 2, RgbToHex)
  
  return(res)
  
}




HexToCol <- function(hexstr, method="rgb", metric="euclidean")
  RgbToCol(hexstr, method=method, metric=metric)



RgbToCol <- function(col, method="rgb", metric="euclidean") {

  switch( match.arg( arg=method, choices=c("rgb","hsv") )
     , "rgb" = {
            # accepts either a matrix with 3 columns RGB or a hexstr

          if(!is.matrix(col)) {
            col <- lapply(col, function(x) c(strtoi(substr(x,2,3), 16L), strtoi(substr(x,4,5), 16L), strtoi(substr(x,6,7), 16L)))
            col <- do.call("cbind", col)
          }
          coltab <- col2rgb(colors())

          switch( match.arg( arg=metric, choices=c("euclidean","manhattan") )
                  , "euclidean" = {
                    colors()[apply(col, 2, function(x) which.min(apply(apply(coltab, 2, "-", x)^2, 2, sum)))]
                  }
                  , "manhattan" = {
                    colors()[apply(col, 2, function(x) which.min(apply(abs(apply(coltab, 2, "-", x)), 2, sum)))]
                  }
          )
     }
     , "hsv" ={
            # accepts either a matrix with 3 columns RGB or a hexstr
            col <- ColToHsv(col)
            if(!is.matrix(col)) {
              col <- lapply(col, function(x) c(strtoi(substr(x,2,3), 16L), strtoi(substr(x,4,5), 16L), strtoi(substr(x,6,7), 16L)))
              col <- do.call("cbind", col)
            }
            coltab <- ColToHsv(colors())

            switch( match.arg( arg=metric, choices=c("euclidean","manhattan") )
                    , "euclidean" = {
                      colors()[apply(col, 2, function(x) which.min(apply(apply(coltab, 2, "-", x)^2, 2, sum)))]
                    }
                    , "manhattan" = {
                      colors()[apply(col, 2, function(x) which.min(apply(abs(apply(coltab, 2, "-", x)), 2, sum)))]
                    }
            )
     }
  )

  # alternative?
  # Identify closest match to a color:  plotrix::color.id

  # old:
  # coltab <- col2rgb(colors())
  # cdist <- apply(coltab, 2, function(z) sum((z - col)^2))
  # colors()[which(cdist == min(cdist))]
}


RgbToLong <- function(col) (c(1, 256, 256^2) %*% col)[1,]


# example:  RgbToLong(ColToRgb(c("green", "limegreen")))

LongToRgb <- function(col)
  sapply(col, function(x) c(red=x %% 256, green=(x %/% 256) %% 256, blue=(x %/% 256^2) %% 256))


# if ever needed...
# '~~> LONG To RGB
    # R = Col Mod 256
    # G = (Col \ 256) Mod 256
    # B = (Col \ 256 \ 256) Mod 256



# ColToDec is col2rgb??
ColToRgb <- function(col, alpha = FALSE) col2rgb(col, alpha)

ColToHsv <- function(col, alpha = FALSE) rgb2hsv(ColToRgb(col, alpha))


ColToGrey <- function(col){
  rgb <- col2rgb(col)
  g <- rbind( c(0.3, 0.59, 0.11) ) %*% rgb
  rgb(g, g, g, maxColorValue=255)
}


ColToGray <- function(col){
  ColToGrey(col)
}

# Add alpha channel to a HexCol
# paste("#00FF00", round(0.3 * 255,0), sep="" )


TextContrastColor <- function(col, white="white", black="black", method=c("glynn","sonego")) {

  switch( match.arg( arg=method, choices=c("glynn","sonego") )
          , "glynn" = {
            # efg, Stowers Institute for Medical Research
            # efg's Research Notes:
            #   http://research.stowers-institute.org/efg/R/Color/Chart
            #
            # 6 July 2004.  Modified 23 May 2005.

            # For a given col, define a text col that will have good contrast.
            #   Examples:
            #     > GetTextContrastcol("white")
            #     [1] "black"
            #     > GetTextContrastcol("black")
            #     [1] "white"
            #     > GetTextContrastcol("red")
            #     [1] "white"
            #     > GetTextContrastcol("yellow")
            #     [1] "black"
            vx <- rep(white, length(col))
            vx[ apply(col2rgb(col), 2, mean) > 127 ] <- black

          }
          , "sonego" = {
            # another idea from Paolo Sonego in OneRTipaDay:
            L <- c(0.2, 0.6, 0) %*% col2rgb(col) / 255
            vx <- ifelse(L >= 0.2, black, white)
          }
  )

  return(vx)

}



MixColor <- function (col1, col2, amount1=0.5) {

  .mix <- function(col1, col2, amount1=0.5) {
    # calculate mix
    mix <- apply(col2rgb(c(col1, col2), alpha=TRUE), 1, function(x) amount1 * x[1] + (1-amount1) * x[2])
    do.call("rgb", c(as.list(mix), maxColorValue=255))
  }

  m <- suppressWarnings(cbind(col1, col2, amount1))
  apply(m, 1, function(x) .mix(col1=x[1], col2=x[2], amount1=as.numeric(x[3])))

}



FindColor <- function(x, cols=rev(heat.colors(100)), min.x=NULL, max.x=NULL,
                      all.inside = FALSE){

  if(is.null(min.x)) min.x <- min(pretty(x))
  if(is.null(max.x)) max.x <- max(pretty(x))

	# Korrektur von min und max, wenn nicht standardmaessig
	colrange <- range(c(min.x, max.x))

	# Berechnung des entsprechenden Farb-Index
  col.idx <- findInterval(x, seq(colrange[1], colrange[2], length = length(cols) + 1)
                          , rightmost.closed=TRUE, all.inside=all.inside)
  col.idx[col.idx==0] <- NA  # den Index 0 gibt es nicht im Farbenvektor
  cols[col.idx]

  # alt:
	# cols[ findInterval( x, seq(colrange[1], colrange[2], length=length(cols)+1 ) ) ]
}


SetAlpha <- function(col, alpha=0.5) {

  # by 0.99.37.001
  # this is redundant (since when actually??), as adjustcolor() does the same job
  # ???
  # should we deprecate?
  
  # if (length(alpha) < length(col)) alpha <- rep(alpha, length.out = length(col))
  # alpha[na <- alpha %)(% c(0, 1)] <- NA
  # if (length(col) < length(alpha)) col <- rep(col, length.out = length(alpha))
  # col[na] <- NA
  # 
  # acol <- substr(ColToHex(col), 1, 7)
  # acol[!is.na(alpha)] <- paste(acol[!is.na(alpha)], DecToHex(round(alpha[!is.na(alpha)]*255,0)), sep="")
  # acol[is.na(col)] <- NA
  # return(acol)
  
  
  Vectorize(adjustcolor)(col= col, alpha.f = alpha)
  
}


Fade <- function(col, ...){
  ColToOpaque(SetAlpha(col, ...))
}




###



# PlotDev <- function(fn, type=c("tif", "pdf", "eps", "bmp", "png", "jpg"),
#                     width=NULL, height=NULL, units="cm", res=300, open=TRUE,
#                     compression="lzw",
#                     expr, ...) {
# 
#   # PlotDev(fn="bar", type="tiff", expr=
#   #  barplot(1:5, col=Pal("Helsana"))
#   # )
# 
#   type <- match.arg(type)
# 
#   # golden ratio
#   golden <- (1+sqrt(5))/2
# 
#   if(is.null(width))
#     width <- 8
# 
#   if(is.null(height))
#     height <- width/golden
# 
# 
#   # check if filename fn contains a path, if not appende getwd()
#   if(!grepl("/", fn))
#     fn <- paste(getwd(), fn, sep="/")
# 
#   switch(type,
#          "tif" = { fn <- paste(fn, ".tif", sep="")
#          tiff(filename = fn, width = width, height = height, units=units, res=res,
#               compression=compression, ...)
#          }
#          , "pdf" = { fn <- paste(fn, ".pdf", sep="")
#          pdf(file=fn, width = width, height = height)
#          }
#          , "eps" = { fn <- paste(fn, ".eps", sep="")
#          postscript(file=fn, width = width, height = height)
#          }
#          , "bmp" = { fn <- paste(fn, ".bmp", sep="")
#          bitmap(file=fn, width = width, height = height, units=units, res=res, ...)
#          }
#          , "png" = { fn <- paste(fn, ".png", sep="")
#          png(filename=fn, width = width, height = height, units=units, res=res, ...)
#          }
#          , "jpg" = { fn <- paste(fn, ".jpg", sep="")
#          jpeg(filename=fn, width = width, height = height, units=units, res=res, ...)
#          }
# 
#   )
# 
#   # http://stackoverflow.com/questions/4692231/r-passing-expression-to-an-inner-function
#   expr <- deparse(substitute(expr))
# 
#   eval(parse(text=expr))
# 
#   dev.off()
#   cat(gettextf("plot produced:\n  %s\n", fn))
# 
#   if(open)
#     shell(gettextf("\"%s\"", fn))
# 
# }
# 


## plots: PlotBubble ====

PlotBubble <-function(x, ...)
  UseMethod("PlotBubble")


PlotBubble.default <- function(x, y, area, col=NA, cex=1, border=par("fg"), xlim = NULL, ylim=NULL,
                               na.rm = FALSE, ...) {

  # http://blog.revolutionanalytics.com/2010/11/how-to-make-beautiful-bubble-charts-with-r.html


  d.frm <- Sort(as.data.frame(Recycle(x=x, y=y, area=area, col=col, border=border,
                                      ry = sqrt((area * cex)/pi)),
                              stringsAsFactors=FALSE), ord=3, decreasing=TRUE)
  if(na.rm) d.frm <- d.frm[complete.cases(d.frm),]


  if(is.null(xlim))
    xlim <- range(pretty( sqrt((area * cex / pi)[c(which.min(d.frm$x), which.max(d.frm$x))] / pi) * c(-1,1) + c(min(d.frm$x),max(d.frm$x)) ))
  if(is.null(ylim))
    ylim <- range(pretty( sqrt((area * cex / pi)[c(which.min(d.frm$y), which.max(d.frm$y))] / pi) * c(-1,1) + c(min(d.frm$y),max(d.frm$y)) ))

  # make sure we see all the bubbles
  plot(x = x, y = y, xlim=xlim, ylim=ylim, type="n", ...)
  # symbols(x=x, y=y, circles=sqrt(area / pi), fg=border, bg=col, inches=inches, add=TRUE)

  rx <- d.frm$ry / Asp()

  DrawEllipse(x = d.frm$x, y = d.frm$y, radius.x = rx, radius.y = d.frm$ry,
              col = d.frm$col, border=d.frm$border)

  # if(!identical(args.legend, NA)){
  #
  #   rx <- d.l$ry / Asp()
  #   DrawEllipse(x = d.l$x, y = d.l$y, radius.x = rx, radius.y = d.frm$ry,
  #               col = d.l$col, border=d.l$border)
  # }


}





PlotBubble.formula <- function (formula, data = parent.frame(), ..., subset, ylab = varnames[response]) {

  m <- match.call(expand.dots = FALSE)
  eframe <- parent.frame()
  md <- eval(m$data, eframe)
  if (is.matrix(md))
    m$data <- md <- as.data.frame(data)
  dots <- lapply(m$..., eval, md, eframe)
  nmdots <- names(dots)
  if ("main" %in% nmdots)
    dots[["main"]] <- enquote(dots[["main"]])
  if ("sub" %in% nmdots)
    dots[["sub"]] <- enquote(dots[["sub"]])
  if ("xlab" %in% nmdots)
    dots[["xlab"]] <- enquote(dots[["xlab"]])
#   if ("panel.first" %in% nmdots)
#     dots[["panel.first"]] <- match.fun(dots[["panel.first"]])
# http://r.789695.n4.nabble.com/panel-first-problem-when-plotting-with-formula-td3546110.html

  m$ylab <- m$... <- NULL
  subset.expr <- m$subset
  m$subset <- NULL
  m <- as.list(m)
  m[[1L]] <- stats::model.frame.default
  m <- as.call(c(m, list(na.action = NULL)))
  mf <- eval(m, eframe)
  if (!missing(subset)) {
    s <- eval(subset.expr, data, eframe)
    l <- nrow(mf)
    dosub <- function(x) if (length(x) == l)
      x[s]
    else x
    dots <- lapply(dots, dosub)
    mf <- mf[s, ]
  }

#   horizontal <- FALSE
#   if ("horizontal" %in% names(dots))
#     horizontal <- dots[["horizontal"]]

  response <- attr(attr(mf, "terms"), "response")

  if (response) {
    varnames <- names(mf)
    y <- mf[[response]]
    funname <- NULL
    xn <- varnames[-response]
    if (is.object(y)) {
      found <- FALSE
      for (j in class(y)) {
        funname <- paste0("plot.", j)
        if (exists(funname)) {
          found <- TRUE
          break
        }
      }
      if (!found)
        funname <- NULL
    }
    if (is.null(funname))
      funname <- "PlotBubble"

    if (length(xn)) {
      if (!is.null(xlab <- dots[["xlab"]]))
        dots <- dots[-match("xlab", names(dots))]
      for (i in xn) {
        xl <- if (is.null(xlab))
          i
        else xlab
        yl <- ylab
#         if (horizontal && is.factor(mf[[i]])) {
#           yl <- xl
#           xl <- ylab
#         }
        do.call(funname, c(list(mf[[i]], y, ylab = yl,
                                xlab = xl), dots))
      }
    }
    else do.call(funname, c(list(y, ylab = ylab), dots))
  }

  print(c(list(y, ylab = ylab), dots))

  invisible()
}


###

## plots: PlotFdist ====


PlotFdist <- function (x, main = deparse(substitute(x)), xlab = ""
                       , xlim = NULL
                       # , do.hist =NULL # !(all(IsWhole(x,na.rm=TRUE)) & length(unique(na.omit(x))) < 13)
                       # do.hist overrides args.hist, add.dens and rug
                       , args.hist = NULL          # list( breaks = "Sturges", ...)
                       , args.rug = NA             # list( ticksize = 0.03, side = 1, ...), pass NA if no rug
                       , args.dens = NULL          # list( bw = "nrd0", col="#9A0941FF", lwd=2, ...), NA for no dens
                       , args.curve = NA           # list( ...), NA for no dcurve
                       , args.boxplot = NULL       # list( pars=list(boxwex=0.5), ...), NA for no boxplot
                       , args.ecdf = NULL          # list( col="#8296C4FF", ...), NA for no ecdf
                       , args.curve.ecdf = NA      # list( ...), NA for no dcurve
                       , heights = NULL            # heights (hist, boxplot, ecdf) used by layout
                       , pdist = NULL              # distances of the plots, default = 0
                       , na.rm = FALSE, cex.axis = NULL, cex.main = NULL, mar = NULL, las=1) {



  .PlotMass <- function(x = x, xlab = "", ylab = "",
                        xaxt = ifelse(add.boxplot || add.ecdf, "n", "s"), xlim = xlim, ylim = NULL, main = NA, las = 1,
                        yaxt="n", col=1, lwd=3, pch=NA, col.pch=1, cex.pch=1, bg.pch=0, cex.axis=cex.axis, ...)   {

    pp <- prop.table(table(x))

    if(is.null(ylim))
      ylim <- c(0, max(pretty(pp)))

    plot(pp, type = "h", lwd=lwd, col=col,
         xlab = "", ylab = "", cex.axis=cex.axis, xlim=xlim, ylim=ylim,
         xaxt = xaxt, main = NA, frame.plot = FALSE,
         las = las, panel.first = {
           abline(h = axTicks(2), col = "grey", lty = "dotted")
           abline(h = 0, col = "black")
         })

    if(!identical(pch, NA))
      points(pp, type="p", pch=pch, col=col.pch, bg=bg.pch, cex=cex.pch)

  }



  # Plot function to display the distribution of a cardinal variable
  # combines a histogram with a density curve, a boxplot and an ecdf
  # rug can be added by using add.rug = TRUE

  # default colors are Helsana CI-colors

  # dev question: should dots be passed somewhere??

  usr <- par(no.readonly=TRUE);  on.exit(par(usr))
  if(!is.null(cex.axis)) par(cex.axis=cex.axis)
  if(!is.null(cex.main)) par(cex.axis=cex.main)
  
  opt <- DescToolsOptions(stamp=NULL)

  add.boxplot <- !identical(args.boxplot, NA)
  add.rug <- !identical(args.rug, NA)
  add.dens <- !identical(args.dens, NA)
  add.ecdf <- !identical(args.ecdf, NA)
  add.dcurve <- !identical(args.curve, NA)
  add.pcurve <- !identical(args.curve.ecdf, NA)

  # preset heights
  if(is.null(heights)){
    if(add.boxplot) {
      if(add.ecdf) heights <- c(1.8, 0.5, 1.6)
      else heights <- c(2, 1.4)
    } else {
      if(add.ecdf) heights <- c(2, 1.4)
    }
  }

  if(is.null(pdist)) {
    if(add.boxplot) pdist <- c(0, 0)
    else pdist <- c(0, 1)
  }

  # layout changes par settings arbitrarily, especially cex in the first case
  # so store here and reset
  ppp <- par()[grep("cex", names(par()))]
  if (add.ecdf && add.boxplot) {
    layout(matrix(c(1, 2, 3), nrow = 3, byrow = TRUE), heights = heights, TRUE)
    # if(is.null(cex.axis)) cex.axis <- 1.3
    # if(is.null(cex.main)) cex.main <- 1.7
  } else {
    if((add.ecdf || add.boxplot)) {
      layout(matrix(c(1, 2), nrow = 2, byrow = TRUE), heights = heights[1:2], TRUE)
#      if(is.null(cex.axis)) cex.axis <- 0.9
    # } else {
    #   if(is.null(cex.axis)) cex.axis <- 0.95
    }
  }
  par(ppp)  # reset unwanted layout changes
  
  # plot histogram, change margin if no main title
  par(mar = c(ifelse(add.boxplot || add.ecdf, 0, 5.1), 4.1, 2.1, 2.1))

  if(!is.null(mar)) {
    par(oma=mar)
  } else {
    if(!is.na(main)) { par(oma=c(0,0,2,0)) }
  }

  # wait for omitting NAs until all arguments are evaluated, e.g. main...
  if(na.rm) x <- x[!is.na(x)]


  if(!is.null(args.hist[["panel.last"]])) {
    panel.last <- args.hist[["panel.last"]]
    args.hist[["panel.last"]] <- NULL

  } else {
    panel.last <- NULL
  }

  if(is.null(args.hist$type)){
    do.hist <- !(isTRUE(all.equal(x, round(x), tol = sqrt(.Machine$double.eps))) && length(unique(x)) < 13)
  } else {
    do.hist <- (args.hist$type == "hist")
    args.hist$type <- NULL
  }

  # handle open list of arguments: args.legend in barplot is implemented this way...
  # we need histogram anyway to define xlim
  args.hist1 <- list(x = x, xlab = "", ylab = "", freq = FALSE,
                     xaxt = ifelse(add.boxplot || add.ecdf, "n", "s"), xlim = xlim, ylim = NULL, main = NA, las = 1,
                     col = "white", border = "grey70", yaxt="n")
  if (!is.null(args.hist)) {
    args.hist1[names(args.hist)] <- args.hist
  }


  x.hist <- DoCall("hist", c(args.hist1[names(args.hist1) %in%
                                           c("x", "breaks", "include.lowest", "right", "nclass")], plot = FALSE))
  x.hist$xname <- deparse(substitute(x))
  if (is.null(xlim))    args.hist1$xlim <- range(pretty(x.hist$breaks))
  args.histplot <- args.hist1[!names(args.hist1) %in% c("x", "breaks", "include.lowest", "right", "nclass")]


  if (do.hist) {
    # calculate max ylim for density curve, provided there should be one...
    # what's the maximal value in density or in histogramm$densities?

    # plot density
    if (add.dens) {
      # preset default values
      args.dens1 <- list(x = x, bw = (if(length(x) > 1000){"nrd0"} else {"SJ"}),
                         col = Pal()[2], lwd = 2, lty = "solid")
      if (!is.null(args.dens)) {
        args.dens1[names(args.dens)] <- args.dens
      }

      # x.dens <- DoCall("density", args.dens1[-match(c("col",
      #                                                  "lwd", "lty"), names(args.dens1))])
      #
      # # overwrite the ylim if there's a larger density-curve
      # args.histplot[["ylim"]] <- range(pretty(c(0, max(c(x.dens$y, x.hist$density)))))

      x.dens <- try( DoCall("density", 
                            args.dens1[-match(c("col", "lwd", "lty"), names(args.dens1))])
                     , silent=TRUE)

      if(inherits(x.dens, "try-error")) {
        warning(gettextf("density curve could not be added\n%s", x.dens))
        add.dens <- FALSE

      } else {
        # overwrite the ylim if there's a larger density-curve
        # but only if the user has not set an ylim value by himself, 
        # ... we should not disobey or overrun user instructions 
        if(is.null(args.histplot[["ylim"]]))
          args.histplot[["ylim"]] <- range(pretty(c(0, max(c(x.dens$y, x.hist$density)))))

      }

    }

    # plot histogram
    DoCall("plot", append(list(x.hist), args.histplot))

    # draw axis
    ticks <- axTicks(2)
    n <- max(floor(log(ticks, base = 10)))    # highest power of ten
    if(abs(n)>2) {
      lab <- Format(ticks * 10^(-n), digits=max(Ndec(as.character(zapsmall(ticks*10^(-n))))))
      axis(side=2, at=ticks, labels=lab, las=las, cex.axis=par("cex.axis"))

      text(x=par("usr")[1], y=par("usr")[4], bquote(~~~x~10^.(n)), xpd=NA, 
           pos = 3, cex=par("cex.axis") * 0.8)

    } else {
      axis(side=2, cex.axis=par("cex.axis"), las=las)

    }

    if(!is.null(panel.last)){
      eval(parse(text=panel.last))
    }

    if (add.dens) {
      lines(x.dens, col = args.dens1$col, lwd = args.dens1$lwd, lty = args.dens1$lty)
    }


    # plot special distribution curve
    if (add.dcurve) {
      # preset default values
      args.curve1 <- list(expr = parse(text = gettextf("dnorm(x, %s, %s)", mean(x), sd(x))),
                          add = TRUE,
                          n = 500, col = Pal()[3], lwd = 2, lty = "solid")
      if (!is.null(args.curve)) {
        args.curve1[names(args.curve)] <- args.curve
      }

      if (is.character(args.curve1$expr)) args.curve1$expr <- parse(text=args.curve1$expr)

      # do.call("curve", args.curve1)
      # this throws an error heere:
      # Error in eval(expr, envir, enclos) : could not find function "expr"
      # so we roll back to do.call
      do.call("curve", args.curve1)

    }


    if (add.rug) {
      args.rug1 <- list(x = x, col = "grey")
      if (!is.null(args.rug)) {
        args.rug1[names(args.rug)] <- args.rug
      }
      DoCall("rug", args.rug1)
    }


  } else {
    # do not draw a histogram, but a line bar chart
    # PlotMass
    args.hist1 <- list(x = x, xlab = "", ylab = "", xlim = xlim,
                       xaxt = ifelse(add.boxplot || add.ecdf, "n", "s"), 
                       ylim = NULL, main = NA, las = 1,
                       yaxt="n", col=1, lwd=3, pch=NA, col.pch=1, 
                       cex.pch=2, bg.pch=0, cex.axis=cex.axis)
    if (is.null(xlim))    args.hist1$xlim <- range(pretty(x.hist$breaks))

    if (!is.null(args.hist)) {
      args.hist1[names(args.hist)] <- args.hist
      if(is.null(args.hist$col.pch))   # use the same color for pch as for the line, when not defined
        args.hist1$col.pch <- args.hist1$col
    }

    DoCall(.PlotMass, args.hist1)


    # plot(prop.table(table(x)), type = "h", xlab = "", ylab = "",
    #      xaxt = "n", xlim = args.hist1$xlim, main = NA,
    #      frame.plot = FALSE, las = 1, cex.axis = cex.axis, panel.first = {
    #        abline(h = axTicks(2), col = "grey", lty = "dotted")
    #        abline(h = 0, col = "black")
    #      })
  }

  # boxplot
  if(add.boxplot){
    par(mar = c(ifelse(add.ecdf, 0, 5.1), 4.1, pdist[1], 2.1))
    args.boxplot1 <- list(x = x, frame.plot = FALSE, main = NA, boxwex = 1,
                          horizontal = TRUE, ylim = args.hist1$xlim, col="grey95",
                          at = 1, xaxt = ifelse(add.ecdf, "n", "s"),
                          outcex = 1.3, outcol = rgb(0,0,0,0.5), cex.axis=cex.axis,
                          pch.mean=3, col.meanci="grey85")
    if (!is.null(args.boxplot)) {
      args.boxplot1[names(args.boxplot)] <- args.boxplot
    }
    plot(1, type="n", xlim=args.hist1$xlim, ylim=c(0,1)+.5, xlab="", ylab="", axes=FALSE)
    grid(ny=NA)
    if(length(x)>1){
      ci <- MeanCI(x, na.rm=TRUE)
      rect(xleft = ci[2], ybottom = 0.62, xright = ci[3], ytop = 1.35,
           col=args.boxplot1$col.meanci, border=NA)
    } else {
      ci <- mean(x)
    }
    args.boxplot1$add = TRUE
    DoCall("boxplot", args.boxplot1)
    points(x=ci[1], y=1, cex=1.5, col="grey65", pch=args.boxplot1$pch.mean, bg="white")

  }

  # plot ecdf
  if (add.ecdf) {
    par(mar = c(5.1, 4.1, pdist[2], 2.1))
#     args.ecdf1 <- list(x = x, frame.plot = FALSE, main = NA,
#                        xlim = args.hist1$xlim, col = getOption("col1", hblue), lwd = 2,
#                        xlab = xlab, yaxt = "n", ylab = "", verticals = TRUE,
#                        do.points = FALSE, cex.axis = cex.axis)

    # 13.1.2018 Andri:
    # if there are many datapoints (n > 1e5) well distributed over the x range, a histogram is significantly
    # faster, than plot.ecdf, which will break down in performance
    # however, if there are only few unique values, the histogram will not be correct and might result in
    # gross deviations.
    # example: PlotECDF(rep(-40, 2001), breaks = 1000)

    # we provisionally use the number of classes length(x.hist$mids) as proxy for good distribution
    # not sure, how robust this is...

    args.ecdf1 <- list(x = x, main = NA, 
                       breaks={if(length(x)>1000 & length(x.hist$mids) > 10) 1000 else NULL}, 
                       ylim=c(0,1),
                       xlim = args.hist1$xlim, col = Pal()[1], lwd = 2,
                       xlab = "", ylab = "", 
                       frame.plot = FALSE, cex.axis=cex.axis)
    if (!is.null(args.ecdf)) {
      args.ecdf1[names(args.ecdf)] <- args.ecdf
    }

    DoCall("PlotECDF", args.ecdf1)

    # plot special distribution ecdf curve
    if (add.pcurve) {
      # preset default values
      args.curve.ecdf1 <- list(expr = parse(text = gettextf("pnorm(x, %s, %s)", mean(x), sd(x))),
                               add = TRUE,
                               n = 500, col = Pal()[3], lwd = 2, lty = "solid")
      if (!is.null(args.curve.ecdf)) {
        args.curve.ecdf1[names(args.curve.ecdf)] <- args.curve.ecdf
      }

      if (is.character(args.curve.ecdf1$expr))
        args.curve.ecdf1$expr <- parse(text=args.curve.ecdf1$expr)

      # do.call("curve", args.curve1)
      # this throws an error here:
      # Error in eval(expr, envir, enclos) : could not find function "expr"
      # so we roll back to do.call
      do.call("curve", args.curve.ecdf1)

    }

  }

  if(!is.na(main)) {
    title(main=main, outer = TRUE)
  }

  if(!identical(xlab, "")) {
    title(xlab=xlab)
  }
  
  DescToolsOptions(opt)
  
  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

  layout(matrix(1))           # reset layout on exit

}





ClearArgs <- function(provided, valid, default) {
  
  # we might want to use dots in a function for multiple functions
  # and extract only those arguments, which are accepted by a specific function
  # further we might have some defaults already defined
  # this function returns all valid provided arguments, extended by set defaults
  
  provided <- provided[names(provided) %in% valid]
  
  # the defaults
  args1 <- default
  
  # overwrite defaults with potentially provided values 
  args1[names(provided) %in% names(args1)] <- provided[names(provided) %in% names(args1)]
  
  # append all provided, already validated args, which were not defined as default
  args1 <- c(args1, provided[names(provided) %in% setdiff(provided, names(args1))])               
  
  # supply only the valid provided or default arguments to axis function 
  args1[names(provided)] <- provided
  
  # the cleared arguments
  return(args1)
  
}




PlotECDF <- function(x, breaks=NULL, col=Pal()[1],
                     ylab="", lwd = 2, xlab = NULL, ...){

  if(is.null(breaks)){
    tab <- table(x)
    xp <-  as.numeric(names(tab))
    xp  <- c(head(xp,1), xp)
    yp <- c(0, cumsum(tab))
  } else {
    xh <- hist(x, breaks=breaks, plot=FALSE)
    xp <- xh$mids
    xp  <- c(head(xp,1), xp)
    yp <- c(0, cumsum(xh$density))
  }
  yp <- yp * 1/tail(yp, 1)

  if(is.null(xlab)) 
    xlab <- deparse(substitute(x))

  plot(yp ~ xp, lwd=lwd, type = "s", col=col, xlab= xlab, yaxt="n",
       ylab = "", panel.first=quote(grid(ny = NA)), ...)

  # we must not pass all dot arguments to axis and plot, as plot accepts arguments
  # which axis does not (e.g. frame.plot) and consequently barks
  # so we select all arguments from axis, combine them with par (which will presumably be ok -- really all par???)
  # and filter them from the whole args list

  # ... nice try, but far too many non valid args:  
  # validargs <- names(subset(validargs <- c(as.list(args(axis)), 
  #                                          par(no.readonly = TRUE)), 
  #                           subset = names(validargs) %nin% c("...","")))      # omit ... and empty
  
  validargs <- subset(validargs <- c(names(as.list(args(axis))),
                                           c("cex", "cex.axis", "col.axis", "family", "fg", "font", "font.axis", "las", "mgp", "srt", "tck", "tcl", "yaxp", "yaxs", "yaxt")),
                            subset = validargs %nin% c("...","","col"))      # omit ... and empty

  # the defaults
  axargs1 <- list(side = 2, at = seq(0, 1, 0.25),
                  labels = Format(seq(0, 1, 0.25), ldigits = 0, digits=2),
                  las = 1, xaxs = "e", lwd.axis=1) 
  
  axargs1 <- ClearArgs(provided = c(as.list(environment()), list(...)),  # all provided arguments and their values 
                      valid=validargs,                                  # vector or names with all validargs
                      default = axargs1)
  axargs1[["lwd"]] <- axargs1[["lwd.axis"]]
  axargs1[["lwd.axis"]] <- NULL                                     # rename lwd, so we can use ... to supply a lwd for axis
  do.call(axis, axargs1)

  abline(h = c(0, 0.25, 0.5, 0.75, 1), 
         col = "grey", lty = c("dashed","dotted","dotted","dotted","dashed"))
  
  # mark min-max value
  points(x=range(x), y=c(0, 1), col=col,  pch=3, cex=2)

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

}


###

## plots: PlotMultiDens ====

PlotMultiDens <- function (x, ...)
UseMethod("PlotMultiDens")


PlotMultiDens.formula <- function (formula, data, subset, na.action, ...) {

    if (missing(formula) || (length(formula) != 3))
        stop("formula missing or incorrect")

    m <- match.call(expand.dots = FALSE)
    if (is.matrix(eval(m$data, parent.frame())))
        m$data <- as.data.frame(data)
    m$... <- NULL
    m[[1]] <- as.name("model.frame")
    mf <- eval(m, parent.frame())

    response <- attr(attr(mf, "terms"), "response")

    PlotMultiDens(split(mf[[response]], mf[-response]), ...)


}



PlotMultiDens.default <- function( x, xlim = NULL, ylim = NULL
                                   , col = Pal(), lty = "solid", lwd = 2
                                   , fill = NA
                                   , xlab = "x", ylab = "density"
                                   # , type = c("line", "stack", "cond")
                                   , args.dens = NULL
                                   , args.legend = NULL
                                   , na.rm = FALSE, flipxy=FALSE, ...) {

  # the input MUST be a numeric list, use split if there's no list:
  #   PlotMultiDens(list(x,y,z))

  # Alternative:
  # library(lattice)
  # densityplot(  ~ vl|  vjdeck + region_x, data=d.set )

  FlipDensXY <- function(x){
    # flips x and y values of a density-object
    tmp <- x$x
    x$x <- x$y
    x$y <- tmp
    return(x)
  }

  # na.omit if wished
  if(na.rm) x <- lapply(x, na.omit)

  args.dens1 <- list(n = 2^12, kernel="epanechnikov")     # default values
  if (!is.null(args.dens)) {
    args.dens1[names(args.dens)] <- args.dens
  }

  # recycle density arguments
  maxdim <- max(length(x), unlist(lapply(args.dens1, length)))
  args.dens1 <- lapply( args.dens1, rep, length.out=maxdim )

  # recycle x
  x <- rep(x, length.out=maxdim )

  # let's calculate the densities
  l.dens <- list()
  for(i in 1:maxdim)  {
    if(length(x[[i]]) > 2)
      l.dens[[i]] <- if(flipxy) {
        FlipDensXY(do.call("density", append(list(x[[i]]), lapply(args.dens1,"[", i)) ))
      } else {
        do.call("density", append(list(x[[i]]), lapply(args.dens1,"[", i)) )
      }
  }


  # recycle line attributes
  # which geom parameter has the highest dimension
  l.par <- list(lty=lty, lwd=lwd, col=col, fill=fill)
  l.par <- lapply( l.par, rep, length.out = maxdim )

  if( is.null(xlim) ) xlim <- range(pretty( unlist(lapply(l.dens, "[", "x")) ) )
  if( is.null(ylim) ) ylim <- range(pretty( unlist(lapply(l.dens, "[", "y")) ))

  dev.hold()
  on.exit(dev.flush())

  plot( x=1, y=1, xlim = xlim, ylim = ylim, type="n", xlab=xlab, ylab=ylab, ... )

#   switch(match.arg(type,choices=c("line","stack","cond"))
#     overlay = {
   if(identical(fill, NA)){
      for(i in 1:length(l.dens))  {
        lines( l.dens[[i]], col=l.par$col[i], lty=l.par$lty[i], lwd=l.par$lwd[i] )
      }
   } else {
     for(i in 1:length(l.dens))  {
       polygon(x = l.dens[[i]]$x, y=l.dens[[i]]$y,
               col = l.par$fill[i], border=l.par$col[i], lty=l.par$lty[i], lwd=l.par$lwd[i])
     }
   }
# },
#     stack =   { },
#     cond =    {
#               }
#   )

  args.legend1 <- list( x="topright", inset=0, legend=if(is.null(names(x))){1:length(x)} else {names(x)}
                        , fill=col, bg="white", cex=0.8 )
  if( length(unique(lwd))>1 || length(unique(lty))>1 ) {
    args.legend1[["fill"]] <-  NULL
    args.legend1[["col"]] <- col
    args.legend1[["lwd"]] <- lwd
    args.legend1[["lty"]] <- lty
  }
  if ( !is.null(args.legend) ) { args.legend1[names(args.legend)] <- args.legend }
  add.legend <- TRUE
  if(!is.null(args.legend)) if(all(is.na(args.legend))) {add.legend <- FALSE}

  if(add.legend) DoCall("legend", args.legend1)

  res <- DoCall(rbind, lapply((lapply(l.dens, "[", c("bw","n"))), data.frame))
  res$kernel <- unlist(args.dens1["kernel"])

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

  invisible(list(dens=res, xlim=xlim, ylim=ylim))

}

## plots: PlotMarDens ====


PlotMarDens <- function( x, y, grp=1, xlim = NULL, ylim = NULL
  , col = rainbow(nlevels(factor(grp)))
  , mardens = c("all","x","y"), pch=1, pch.cex=1.0, main=""
  , na.rm = FALSE, args.legend = NULL
  , args.dens = NULL, ...){

  usr <- par("usr");  on.exit( par(usr) )

  opt <- DescToolsOptions(stamp=NULL)

  mardens <- match.arg(arg = mardens, choices = c("all", "x", "y"))

  par(oma=c(0,0,3,0))

  d.frm <- data.frame(x=x, y=y, grp=grp)
  pch=rep(pch, length.out=nlevels(factor(grp)))    # recycle pch

  # this is plot.default defaults
  xlim <- if (is.null(xlim)) range(x[is.finite(x)]) else xlim
  ylim <- if (is.null(ylim)) range(y[is.finite(y)]) else ylim

  switch( mardens
    , "all" = { nf <- layout(matrix(c(2,0,1,3),2,2, byrow=TRUE), widths=c(9,1.5), heights=c(0.8,4), TRUE) }
    , "x" = { nf <- layout(matrix(c(2,1), 2,1, byrow=TRUE), c(9), c(0.8,4), TRUE) }
    , "y" =  { nf <- layout(matrix(c(1,2),1,2, byrow=TRUE), c(9,1.5), c(4), TRUE) }
  )

  par(mar=c(5,5,1,1))
  plot(x=d.frm$x, y=d.frm$y, xlim=xlim, ylim=ylim, type="n", ... )

  s <- split(d.frm[,1:2], d.frm$grp)
  for( i in seq_along(s)  ){
    points( x=s[[i]]$x, y=s[[i]]$y, col=col[i], pch=pch[i], cex=pch.cex)
  }


  args.legend1 <- list( x = "topright", inset = 0.02, legend = levels(factor(grp))
    , col = col, pch = pch, bg = "white", cex = 0.8 )
  if ( !is.null(args.legend) ) {
    if(!all(is.na(args.legend))){
      args.legend1[names(args.legend)] <- args.legend
    } else {
      args.legend1 <- NA
    }
  }

  if(!all(is.na(args.legend1))) do.call("legend", args.legend1)

  if(mardens %in% c("all","x")){
    par(mar=c(0,5,0,1))

    args.plotdens1 <- list(x = split(d.frm$x, d.frm$grp), na.rm = TRUE,
                       col = col, xlim = xlim, axes=FALSE,
                       args.legend = NA, xlab="", ylab="")
    if (!is.null(args.dens)) {
      args.plotdens1[names(args.dens)] <- args.dens
    }
    args.dens1 <- list(n = 4096, bw = "nrd0", kernel = "epanechnikov")
    if (!is.null(args.dens)) {
      ovr <- names(args.dens)[names(args.dens) %in% names(args.dens1)]
      args.dens1[ovr] <- args.dens[ovr]
    }
    args.plotdens1$args.dens <- args.dens1
    args.plotdens1 <- args.plotdens1[names(args.plotdens1) %nin% names(args.dens1)]

    do.call("PlotMultiDens", args.plotdens1)

#    PlotMultiDens( split(d.frm$x, d.frm$grp), col=col, na.rm=TRUE, xlim=xlim
#      , axes=FALSE, args.legend = NA, xlab="", ylab="" )
  }

  if(mardens %in% c("all","y")){
    par(mar=c(5,0,1,1))
    args.plotdens1 <- list(x = split(d.frm$y, d.frm$grp), na.rm = TRUE,
                           col = col, ylim = ylim, axes=FALSE, flipxy=TRUE,
                           args.legend = NA, xlab="", ylab="")
    if (!is.null(args.dens)) {
      args.plotdens1[names(args.dens)] <- args.dens
    }
    args.dens1 <- list(n = 4096, bw = "nrd0", kernel = "epanechnikov")
    if (!is.null(args.dens)) {
      ovr <- names(args.dens)[names(args.dens) %in% names(args.dens1)]
      args.dens1[ovr] <- args.dens[ovr]
    }
    args.plotdens1$args.dens <- args.dens1
    args.plotdens1 <- args.plotdens1[names(args.plotdens1) %nin% names(args.dens1)]

    do.call("PlotMultiDens", args.plotdens1)
#     PlotMultiDens( split(d.frm$y, d.frm$grp), col=col, na.rm=TRUE, ylim=ylim
#       , axes = FALSE, args.legend = NA, flipxy=TRUE, xlab="", ylab="" )

  }
  title(main=main, outer=TRUE)

  options(opt)
  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

}


PlotConDens <- function(formula, data, col=NULL, lwd=2, lty=1, xlim=NULL, rev=TRUE, args.dens=NULL, ...) { 
  
  deparen <- function(expr) {
    while (is.language(expr) && !is.name(expr) && deparse(expr[[1L]])[1L] == 
           "(") expr <- expr[[2L]]
    expr
  }
  bad.formula <- function() stop("invalid conditioning formula")
  bad.lengths <- function() stop("incompatible variable lengths")
  getOp <- function(call) deparse(call[[1L]], backtick = FALSE)[[1L]]
  formula <- deparen(formula)
  if (!inherits(formula, "formula")) 
    bad.formula()
  y <- deparen(formula[[2L]])
  rhs <- deparen(formula[[3L]])
  if (getOp(rhs) != "|") 
    bad.formula()
  x <- deparen(rhs[[2L]])
  rhs <- deparen(rhs[[3L]])
  if (is.language(rhs) && !is.name(rhs) && getOp(rhs) %in% 
      c("*", "+")) {
    have.b <- TRUE
    a <- deparen(rhs[[2L]])
    b <- deparen(rhs[[3L]])
  }
  else {
    have.b <- FALSE
    a <- rhs
  }
  if (missing(data)) 
    data <- parent.frame()
  x.name <- deparse(x)
  x <- eval(x, data, parent.frame())
  nobs <- length(x)
  y.name <- deparse(y)
  y <- eval(y, data, parent.frame())
  if (length(y) != nobs) 
    bad.lengths()
  a.name <- deparse(a)
  a <- eval(a, data, parent.frame())
  if (length(a) != nobs) 
    bad.lengths()
  if (is.character(a)) 
    a <- as.factor(a)
  a.is.fac <- is.factor(a)
  if (have.b) {
    b.name <- deparse(b)
    b <- eval(b, data, parent.frame())
    if (length(b) != nobs) 
      bad.lengths()
    if (is.character(b)) 
      b <- as.factor(b)
    b.is.fac <- is.factor(b)
    missingrows <- which(is.na(x) | is.na(y) | is.na(a) | 
                           is.na(b))
  }
  else {
    missingrows <- which(is.na(x) | is.na(y) | is.na(a))
    b <- NULL
    b.name <- ""
  }
  
  args.dens <- c(args.dens, bw = "nrd0")
  args.dens <- args.dens[!duplicated(names(args.dens))]
  
  if(is.null(xlim))
    ptx <- pretty(range(x), n = 1000)
  else
    ptx <- pretty(xlim, n = 1000)
  
  args.plot <- c(list(y=c(0,1), x=range(pretty(ptx)), type="n"), ..., las=1, xlab=x.name, ylab="density")
  args.plot <- args.plot[!duplicated(names(args.plot))]
  do.call(plot, args.plot)
  
  if(is.null(col))
    col <- Pal("Helsana")
  
  a <- factor(a)
  largs <- Recycle(col=col, lty=lty, lwd=lwd, lvl=levels(a))
  
  for(i in seq_along(levels(a))) {
    
    ll <- with(data.frame(x,y)[a==levels(a)[i],], 
               do.call(cdplot, c(formula=as.formula(y~x), plot=FALSE, args.dens)))
    
    if(rev)
      lines(x=ptx, 1-ll[[1]](ptx), col=largs$col[i], lwd=largs$lwd[i], lty=largs$lty[i])
    else
      lines(x=ptx, ll[[1]](ptx), col=largs$col[i], lwd=largs$lwd[i], lty=largs$lty[i])
    
    
  }
  
  invisible(list(x=x, y=y, a=a))   
  
}






###

## plots: PlotArea ====


PlotArea <- function(x, ...) {
# PlotArea - mehrere Flaechen uebereinander
# source: http://r.789695.n4.nabble.com/PlotArea-td2255121.html
# arni...
  UseMethod("PlotArea")
}

PlotArea.default <- function(x, y=NULL, prop=FALSE, add=FALSE, xlab=NULL, ylab=NULL,
                             col=NULL, frame.plot=FALSE, ...) {

  if(is.ts(x)) {  # ts/mts
    if(is.null(ylab)) ylab <- deparse(substitute(x))
    x <- data.frame(Time=time(x), x)
  }

  if(is.table(x)) { # table
    if(is.null(ylab)) ylab <- deparse(substitute(x))
    if(length(dim(x)) == 1)
      x <- t(t(unclass(x)))
    else
      x <- unclass(x)
  }

  if(is.matrix(x)) { # matrix
    if(!is.null(rownames(x)) && !any(is.na(suppressWarnings(as.numeric(rownames(x)))))) {
      x <- data.frame(as.numeric(rownames(x)), x)
      names(x)[1] <- ""
    } else {
      x <- data.frame(Index=seq_len(nrow(x)), x)
    }
  }

  if(is.list(x)) { # data.frame or list
    if(is.null(xlab))  xlab <- names(x)[1]
    if(is.null(ylab)) {
      if(length(x) == 2)
        ylab <- names(x)[2]
      else
        ylab <- ""
    }

    y <- x[-1]
    x <- x[[1]]
  }

  if(is.null(y)) { # one numeric vector passed, plot it on 1:n
    if(is.null(xlab))  xlab <- "Index"
    if(is.null(ylab))  ylab <- deparse(substitute(x))

    y <- x
    x <- seq_along(x)
  }

  if(is.null(xlab))  xlab <- deparse(substitute(x))
  if(is.null(ylab))  ylab <- deparse(substitute(y))

  y <- as.matrix(y)

  if(is.null(col))  col <- gray.colors(ncol(y))
  col <- rep(col, length.out=ncol(y))

  if(prop)  y <- prop.table(y, 1)

  y <- t(rbind(0, apply(y, 1, cumsum)))
  na <- is.na(x) | apply(is.na(y),1,any)
  x <- x[!na][order(x[!na])]
  y <- y[!na,][order(x[!na]),]

  if(!add)  suppressWarnings(matplot(x, y, type="n", xlab=xlab, ylab=ylab, frame.plot=frame.plot, ...))
  xx <- c(x, rev(x))

  for(i in 1:(ncol(y)-1)) {
    yy <- c(y[,i+1], rev(y[,i]))
    # suppressWarnings(polygon(xx, yy, col=col[i], ...))
    # think we don't need dots here, but can allow warnings, why not??
    # me: 2020-03-11
    polygon(xx, yy, col=col[i])
  }

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

  invisible(y[,-1])
}


PlotArea.formula <- function (formula, data, subset, na.action, ...) {

  m <- match.call(expand.dots=FALSE)
  if(is.matrix(eval(m$data,parent.frame())))   m$data <- as.data.frame(data)

  m$... <- NULL
  m[[1]] <- as.name("model.frame")

  if(as.character(formula[[2]]==".")) {
    rhs <- unlist(strsplit(deparse(formula[[3]])," *[:+] *"))
    lhs <- sprintf("cbind(%s)", paste(setdiff(names(data), rhs),collapse=","))
    m[[2]][[2]] <- parse(text=lhs)[[1]]
  }

  mf <- eval(m, parent.frame())
  if(is.matrix(mf[[1]])) {
    lhs <- as.data.frame(mf[[1]])
    names(lhs) <- as.character(m[[2]][[2]])[-1]
    PlotArea.default(cbind(mf[-1],lhs), ...)
  } else {
    PlotArea.default(mf[2:1], ...)
  }

}

###

## plots: PlotDotCI ====

PlotDot <- function (x, labels = NULL, groups = NULL, gdata = NULL, cex = par("cex"),
                     pch = 21, gpch = 21, bg = par("bg"), color = par("fg"), gcolor = par("fg"),
                     lcolor = "gray", lblcolor = par("fg"), xlim = NULL, main = NULL, xlab = NULL, ylab = NULL, xaxt=NULL, yaxt=NULL,
                     add = FALSE, args.errbars = NULL, cex.axis=par("cex.axis"), cex.pch=1.2, 
                     cex.gpch=1.2, gshift=2, automar=TRUE, ...) {

  ErrBarArgs <- function(from, to = NULL, pos = NULL, mid = NULL,
                         horiz = FALSE, col = par("fg"), lty = par("lty"), lwd = par("lwd"),
                         code = 3, length = 0.05, pch = NA, cex.pch = par("cex"),
                         col.pch = par("fg"), bg.pch = par("bg"), ...) {

    if (is.null(to)) {
      if (length(dim(x) != 1))
        stop("'to' must be be provided, if x is a matrix.")

      if (dim(from)[2] %nin% c(2, 3))
        stop("'from' must be a kx2 or a kx3 matrix, when 'to' is not provided.")
      if (dim(from)[2] == 2) {
        to <- from[, 2]
        from <- from[, 1]
      }
      else {
        mid <- from[, 1]
        to <- from[, 3]
        from <- from[, 2]
      }
    }

    if (length(dim(from)) ==2 )
      from <- Rev(from, 2)
    if (length(dim(to)) ==2 )
      to <- Rev(to, 2)
    if (length(dim(mid)) ==2 )
      mid <- Rev(mid, 2)

    return(list(from = from, to = to, mid = mid, col = col,
                col.axis = 1, lty = lty, lwd = lwd, angle = 90, code = code,
                length = length, pch = pch, cex.pch = cex.pch, col.pch = col.pch,
                bg.pch = bg.pch))
  }

  # if(!is.null(args.errbars)){
  #   # switch pch and col to errorbars
  #   if(!is.null(pch)){
  #     args.errbars$pch <- pch
  #     args.errbars$col.pch <- color
  #     args.errbars$bg.pch <- bg
  #     bg <- color <- pch <- NA
  #   }
  # }

  x <- Rev(x, 1)

  labels <- rev(labels)
  groups <- rev(groups)
  # gdata <- rev(gdata)
  # gcolor <- Rev(gcolor)
  lcolor <- Rev(lcolor)
  lblcolor <- Rev(lblcolor)
  color <- Rev(color)
  pch <- Rev(pch)
  bg <- Rev(bg)

  # cex <- rep(cex, length.out = 3)
  cex.axis <- rep(cex.axis, length.out = 3)
  
  if (!is.null(args.errbars))
    errb <- do.call(ErrBarArgs, args.errbars)
  if (!add && is.null(xlim)) {
    if (is.null(args.errbars)) {
      xlim <- range(x[is.finite(x)])
    }
    else {
      rng <- c(errb$from, errb$to)
      xlim <- range(pretty(rng[is.finite(rng)]))
    }
  }
  opar <- par("mai", "mar", "cex", "cex.axis", "yaxs")
  on.exit(par(opar))
  par(cex = cex, cex.axis=cex.axis[1], yaxs = "i")

  lheight <- strheight("M", units="inches", cex=max(cex.axis[c(2, 3)])*cex)
  
  if (!is.numeric(x))
    stop("'x' must be a numeric vector or matrix")
  n <- length(x)
  if (is.matrix(x)) {
    if (is.null(labels))
      labels <- rownames(x)
    if (is.null(labels))
      labels <- as.character(1L:nrow(x))
    labels <- rep_len(labels, n)
    if (is.null(groups))
      groups <- col(x, as.factor = TRUE)
    glabels <- levels(groups)
    
  } else {
    if (is.null(labels))
      labels <- names(x)
    glabels <- if (!is.null(groups))
      levels(groups)
    if (!is.vector(x)) {
      warning("'x' is neither a vector nor a matrix: using as.numeric(x)")
      x <- as.numeric(x)
    }
  }
  
  if (!add)
    plot.new()
  # we must use cex*cex.axis here
  linch <- if (!is.null(labels))
             max(strwidth(labels, "inch", cex=max(cex.axis[2])* cex), na.rm = TRUE)
           else 0
  
  if (is.null(glabels)) {
    goffset <- ginch <- 0
    
  } else {
    ginch <- max(strwidth(glabels, "inch", cex=max(cex.axis[3]) * cex), na.rm = TRUE)
    goffset <- lheight  
  }
  if (!(is.null(labels) && is.null(glabels) || identical(yaxt, "n") || !automar)) {
    nmai <- par("mai")
    # nmai[2L] <- nmai[4L] + max(linch + goffset, ginch) + lheight
    # warum sollte der linke Rand so sein wie der rechte??
    nmai[2L] <- lheight + max(linch + goffset, ginch) + gshift * lheight
    par(mai = nmai)
  }
  if (is.null(groups)) {
    o <- 1L:n
    y <- o
    ylim <- c(0, n + 1)
    
  } else {
    o <- sort.list(as.numeric(groups), decreasing = TRUE)
    x <- x[o]
    groups <- groups[o]
    # color <- rep_len(color, length(groups))[o]
    # lcolor <- rep_len(lcolor, length(groups))[o]
    offset <- cumsum(c(0, diff(as.numeric(groups)) != 0))
    y <- 1L:n + 2 * offset
    ylim <- range(0, y + 2)
  }
  
  if (!add)
    plot.window(xlim = xlim, ylim = ylim, log = "")
  
  # lheight <- par("csi")
  # much more precise:
  if (!is.null(labels)) {
    linch <- max(strwidth(labels, "inch", cex = cex.axis[2])*cex, na.rm = TRUE)
#    loffset <- (linch + 0.1)/lheight
    loffset <- grconvertX(linch + 0.1, from="inch", to="lines")
    labs <- labels[o]
    if (!identical(yaxt, "n") && !add)
      mtext(labs, side = 2, line = loffset, at = y, adj = 0,
          col = lblcolor, las = 2, cex = cex.axis[2]*cex, ...)
  }
  
  if (!add)
    abline(h = y, lty = "dotted", col = lcolor)
  
  if (!is.null(args.errbars)) {
    arrows(x0 = rev(errb$from)[o], x1 = rev(errb$to)[o],
           y0 = y, col = rev(errb$col), angle = 90, code = rev(errb$code),
           lty = rev(errb$lty), lwd = rev(errb$lwd), length = rev(errb$length))
    # if (!is.null(errb$mid))
    #   points(rev(errb$mid)[o], y = y, pch = rev(errb$pch), col = rev(errb$col.pch),
    #          cex = rev(errb$cex.pch), bg = rev(errb$bg.pch))
  }

  points(x, y, pch = pch, col = color, bg = bg, cex=cex * cex.pch)
  if (!is.null(groups)) {
    gpos <- rev(cumsum(rev(tapply(groups, groups, length)) +
                         2) - 1)
    
    # ginch <- max(strwidth(glabels, "inch", cex=cex.axis[3]*cex), na.rm = TRUE)
    # goffset <- (max(linch + 0.2, ginch, na.rm = TRUE) + 0.1)/lheight
    
#    lgoffset <- (max(linch + goffset, ginch) + lheight)/lheight
    lgoffset <- grconvertX(max(linch + goffset, ginch) + gshift * lheight, 
                           from="inch", to="lines")
    
    if (!identical(yaxt, "n") && !add)
      mtext(glabels, side = 2, line = lgoffset, at = gpos, adj = 0,
            col = gcolor, las = 2, cex = cex.axis[3]*cex, ...)
    if (!is.null(gdata)) {
      abline(h = gpos, lty = "dotted")
      points(gdata, gpos, pch = gpch, cex=cex*cex.gpch, col = gcolor, bg = bg, ...)
    }
  }
  if (!(add || identical(xaxt, "n") ))
    axis(1)

  if (!add)
    box()

  if (!add)
    title(main = main, xlab = xlab, ylab = ylab, ...)


  if (!is.null(DescToolsOptions("stamp")) && !add)
    Stamp()

  # invisible(y[order(o, decreasing = TRUE)])
  # replaced by 0.99.18:
  invisible(y[order(y, decreasing = TRUE)])

}




PlotDotCI <- function(..., grp=1, cex = par("cex"),
                      pch = 21, gpch = 21, bg = par("bg"), color = par("fg"), gcolor = par("fg"),
                      lcolor = "gray", lblcolor = par("fg"), xlim = NULL, main = NULL, xlab = NULL, ylab = NULL, xaxt=NULL, yaxt=NULL,
                      cex.axis=par("cex.axis"), cex.pch=1.2,
                      cex.gpch=1.2, gshift=2, automar=TRUE){
  
  lst <- list(...)
  
  if(grp==1)
    z <- aperm(do.call(Abind, list(lst, along = 3)), c(1,3,2))
  else
    z <- aperm(do.call(Abind, list(lst, along = 3)), c(3,1,2))
  
  # ... are matrices with n rows and 3 columns, est, lci, uci
  PlotDot(z[,,1],
          args.errbars = list(from=z[,,2], to=z[,,3]),
          cex = cex,
          pch = pch, gpch = gpch, bg = bg, color = color, gcolor = gcolor,
          lcolor = lcolor, lblcolor = lblcolor, xlim = xlim, main = main,
          xlab = xlab, ylab = ylab, xaxt=xaxt, yaxt=yaxt,
          cex.axis=cex.axis, cex.pch=cex.pch,
          cex.gpch=cex.gpch, gshift=gshift, automar=automar)
  
  
}



TitleRect <- function(label, bg = "grey", border=1, col="black", xjust=0.5, line=2, ...){

  xpd <- par(xpd=TRUE); on.exit(par(xpd))

  usr <- par("usr")
  rect(xleft = usr[1], ybottom = usr[4], xright = usr[2], ytop = LineToUser(line,3),
       col="white", border = border)
  rect(xleft = usr[1], ybottom = usr[4], xright = usr[2], ytop = LineToUser(line,3),
       col=bg, border = border)

  if(xjust==0) {
    x <- usr[1]
  } else if(xjust==0.5) {
    x <- mean(usr[c(1,2)])
  } else {
    x <- usr[2]
  }

  text(x = x, y = mean(c(usr[4], LineToUser(line,3))), labels=label,
       adj = c(xjust, 0.5), col=col, ...)
}



# not yet exported

PlotFacet <- function(x, FUN, mfrow, titles, main="", oma=NULL,
                      args.titles = NULL, ...){


  par(mfrow=mfrow, xpd=TRUE)
  nr <- mfrow[1]
  nc <- mfrow[2]

  if(is.null(oma))
    oma <- c(5,5,5,2)

  par(mar=c(0,0,2.0,0), oma=oma, las=par("las"))

  args.titles1 <- list(col=1, bg="grey", border=1)
  if(!is.null(args.titles))
    args.titles1[names(args.titles)] <- args.titles

  for(i in 1:length(x)){

    # nur unterste Zeile, und auch da nur Beschriftung in jedem 2. Plot
    xaxt <- c("s","n")[((i <= (max(nr)-1)*nc) || IsOdd(i)) + 1]
    # nur unterste Zeile, und auch da nur Beschriftung in jedem 2. Plot
    yaxt <- c("s","n")[((i %% nc) != 1) + 1]

    # the plot function
    FUN(x[[i]], xaxt, yaxt)


    do.call(TitleRect, c(args.titles1, label=titles[i]))

  }

  title(main, outer=TRUE, xpd=NA)

}




PlotLinesA <- function(x, y, col=1:5, lty=1, lwd=1, lend = par("lend"), xlab = NULL,
                       ylab = NULL, xlim = NULL, ylim = NULL, xaxt=NULL, yaxt=NULL, cex = 1, args.legend = NULL,
                       main=NULL, grid=TRUE, mar=NULL, pch=NA, pch.col=par("fg"), pch.bg=par("bg"), pch.cex=1, ...){

  # example:
  #
  # m <- matrix(c(3,4,5,1,5,4,2,6,2), nrow = 3,
  #             dimnames = list(dose = c("A","B","C"),
  #                             age = c("2000","2001","2002")))
  # PlotLinesA(m, col=rev(c(PalHelsana(), "grey")), main="Dosw ~ age", lwd=3, ylim=c(1,10))


  .legend <- function(line, y, width, labels, lty, lwd, col, cex, main=NULL){

    line <- rep(line, length.out=2)

    txtline <- line[1] + ZeroIfNA(width + (!is.na(width)) * line[2])
    mtext(side = 4, las=1, cex=cex, text = labels,
          line = txtline,
          at = y
          )

    if(!is.na(width)){
      x0 <- LineToUser(line[1], 4)
      segments(x0 = x0, x1 = LineToUser(line[1] + width, 4), y0 = y,
               lwd = lwd, lty=lty, lend = 1, col = col)
    }

    if(!is.null(main))
      mtext(side=4, text = main, las=1, line=line[1], at=par("usr")[4], padj=c(0))
  }

  if(missing(y))
    z <- as.matrix(x)
  else
    z <- as.matrix(y)


  add.legend <- !identical(args.legend, NA)


  last <- Sort(data.frame(t(tail(apply(as.matrix(z), 2, LOCF), 1))))
  last <- setNames(last[,], nm = rownames(last))

  if(is.null(mar)){
    if(!identical(args.legend, NA))
      # no convincing solution before plot.new is called
      # http://stackoverflow.com/questions/16452368/calculate-strwidth-without-calling-plot-new
      Mar(right = 10)  # this would be nice, but there's no plot so far... max(strwidth(names(last))) * 1.2

  } else {
    do.call(Mar, as.list(mar))
  }

  if(!InDots(..., arg = "add", default=FALSE)){
    # do not draw axes, labels and grid when only lines have to be added
    matplot(x, y, type="n", las=1, xlim=xlim, ylim=ylim, xaxt="n", yaxt=yaxt, main=main, xlab=xlab, ylab=ylab, cex = cex, ...)
    if(!identical(xaxt, "n"))
      # use rownames for x-axis if available, but only if either x or y is missing
      if(!is.null(rownames(z)) && (missing(x) || missing(y)))
        axis(side = 1, at=c(1:nrow(z)), rownames(z))
      else
        axis(side=1)
  
    if(grid) grid()
  }
  
  matplot(x, y, type="l", lty=lty, col=col, lwd=lwd, lend=lend, xaxt="n", yaxt="n", add=TRUE)

  if(!is.na(pch))
    matplot(x, y, type="p", pch=pch, col=pch.col, bg=pch.bg, cex=pch.cex, xaxt="n", yaxt="n", add=TRUE)

  oldpar <- par(xpd=TRUE); on.exit(par(oldpar))

  if (add.legend) {

    if(is.null(colnames(z)))
      colnames(z) <- 1:ncol(z)

    ord <- match(names(last), colnames(z))
    lwd <- rep(lwd, length.out=ncol(z))
    lty <- rep(lty, length.out=ncol(z))
    col <- rep(col, length.out=ncol(z))


    # default legend values
    args.legend1 <- list(
      line = c(1, 1) ,   # par("usr")[2] + diff(par("usr")[1:2]) * 0.02,
      width = 1,         # (par("usr")[2] + diff(par("usr")[1:2]) * 0.02 * 2) - (par("usr")[2] + diff(par("usr")[1:2]) * 0.02),
      y = SpreadOut(unlist(last), mindist = 1.2 * strheight("M") * par("cex")),
      labels=names(last), cex=par("cex"),
      col = col[ord], lwd = lwd[ord], lty = lty[ord])

    if (!is.null(args.legend)) {
      args.legend1[names(args.legend)] <- args.legend
      # default distance y is dependent from cex setting ...
      if(any(names(args.legend)=="cex") & !any(names(args.legend)=="y"))
        args.legend1["y"] <- SpreadOut(unlist(last), mindist = 1.2 * strheight("M") * args.legend1[["cex"]])
    }

    DoCall(".legend", args.legend1)

  }


  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

  invisible(list(x=x, y= if (!missing(y)) y else NULL, 
                 args.legend = if(add.legend) args.legend1 else NULL))
  
}



PlotLog <- function(x, ..., args.grid=NULL, log="xy"){

  add.grid <- !identical(args.grid, NA)

  # default grid arguments
  args.grid1 <- list(
    lwd = 1,
    lty = 3, #"dotted",
    col = "grey85",
    lwd.min = 1,
    lty.min = 3,
    col.min = "grey60"
  )

  if (!is.null(args.grid)) {
    args.grid1[names(args.grid)] <- args.grid
  }


  plot(x, ..., type="n", log=log, xaxt="n", yaxt="n", xaxs="i", yaxs="i")

  if(grepl("x", log)){

    # ticks <- do.call(seq, as.list(range(log(axTicks(1), 10))))
    ticks <- do.call(seq, as.list(range(ceiling(log(10^par("usr")[1:2], 10)))))


    # need a x log axis
    sapply(ticks,
           function(n) mtext(side=1, line=1, at = 10^n, text = bquote(~10^.(n))))

    if(add.grid){
      abline(v=unique(as.vector(sapply(c(ticks, tail(ticks, 1)+1), function(n) seq(0, 0.1, 0.01)*10^n))),
             col=args.grid1$col, lty=args.grid1$lty, lwd=args.grid1$lwd)
      abline(v=10^(ticks), col=args.grid1$col.min, lty=args.grid1$lty.min, lwd=args.grid1$lwd.min)
    }

    axis(1, at=c(0, 10^(ticks)), labels=NA)

  }

  if(grepl("y", log)){

    # ticks <- do.call(seq, as.list(range(log(axTicks(1), 10))))
    ticks <- do.call(seq, as.list(range(ceiling(log(10^par("usr")[3:4], 10)))))


    # need a x log axis
    sapply(ticks,
           function(n) mtext(side=2, line=1, at = 10^n, text = bquote(~10^.(n)), las=1))

    if(add.grid){
      abline(h=unique(as.vector(sapply(c(ticks, tail(ticks, 1)+1), function(n) seq(0, 0.1, 0.01)*10^n))),
             col=args.grid1$col, lty=args.grid1$lty, lwd=args.grid1$lwd)
      abline(h=10^(ticks), col=args.grid1$col.min, lty=args.grid1$lty.min, lwd=args.grid1$lwd.min)
    }

    axis(2, at=c(0, 10^(ticks)), labels=NA)

  }

  box()

  points(x, ...)

}




###

## plots: PlotFun ====

PlotFun <- function(FUN, args=NULL, from=NULL, to=NULL, by=NULL, xlim=NULL,
                    ylim = NULL, polar = FALSE, type="l",
                    col = par("col"), lwd= par("lwd"), lty=par("lty"), pch=NA, mar=NULL,
                    add = FALSE, ...){

#   # all dot arguments
#   dot.args <- match.call(expand.dots=FALSE)$...
#   # the dot arguments which match PercTable.table
#   # pt.args <- dot.args[names(dot.args) %in% names(formals(PercTable.table))]
#   # the dot arguments which DO NOT match PercTable.table
#   par.args <- dot.args[names(dot.args) %nin% names(formals(PlotFun))]

  # see also Hmisc::minor.tick

  if(is.null(mar))
    Mar(3,3,3,3)
  else
    par(mar=mar)

  vars <- all.vars(FUN)
  vars <- vars[vars %nin% names(args)]

  # this is not really smart ....
  if(is.null(from)) from <- -5
  if(is.null(to)) to <- 5
  if(is.null(by)) by <- (to - from) / 500


  # the independent variable
  assign(vars, seq(from = from, to = to, by=by))

  # define the parameters
  for(i in seq_along(args)) {
    assign(names(args)[i], unlist(args[i]))

    # this does not work:
    if(length(get(names(args)[i])) > 1) {
      assign(names(args)[i], get(names(args)[i])[1])
      warning(gettextf("first element used of '%s' argument", names(args)[i]))
    }
  }

  # Inhibit model interpretation for function plot
  FUN[[2]] <-   as.formula("~" %c% gettextf("I(%s)", deparse(FUN[[2]])) )[[2]]
  FUN[[3]] <-   as.formula("~" %c% gettextf("I(%s)", deparse(FUN[[3]])) )[[2]]

  # this will evaluate in parent.frame(), so in function's env
  p <- ParseFormula(FUN)

  y <- p$lhs$mf.eval[,1]
  x <- p$rhs$mf.eval[,1]

  if(polar){
    cord <- PolToCart(r = y, theta = x)
    y <- cord$y
    x <- cord$x
  }

  if(is.null(xlim)){
    xlim <- range(pretty(range(x[is.finite(x)])))
  }
  if(is.null(ylim)){
    ylim <- range(pretty(range(y[is.finite(y)])))
  }

  # define plot parameters
  m <- match.call(expand.dots = FALSE)
  m$...$frame.plot <- InDots(..., arg="frame.plot", default = FALSE)
  m$...$axes <- InDots(..., arg="axes", default = NULL)
  m$...$asp <- InDots(..., arg="asp", default = 1)
  m$...$xlab <- InDots(..., arg="xlab", default = "")
  m$...$ylab <- InDots(..., arg="ylab", default = "")
  if(is.null(m$...$axes)) {
    add.axes <- TRUE
    m$...$axes <- FALSE
  } else {
    add.axes <- FALSE
  }

  if(!add){
    do.call(plot, c(list(y=1, x=1, xlim=xlim, ylim=ylim, type="n", mar=mar), m$...))
  }

  if(add.axes && !add) {
    tck <- axTicks(side=1)
    if(sign(min(tck)) != sign(max(tck)))
      tck <- tck[tck!=0]
    axis(1, pos = 0, col="darkgrey", at=tck)
    # we set minor ticks for the axes, 4 ticks between 2 major ticks
    axp <- par("xaxp")
    axp[3] <- 5 * axp[3]
    axis(1, pos = 0, TRUE, at=axTicks(side=1, axp=axp), labels = NA, tck=-0.01, col="darkgrey")

    tck <- axTicks(side=2)
    if(sign(min(tck)) != sign(max(tck)))
      tck <- tck[tck!=0]
    axis(2, pos = 0, las=1, col="darkgrey", at=tck)
    axp <- par("yaxp")
    axp[3] <- 5 * axp[3]
    axis(2, pos = 0, TRUE, at=axTicks(side=1, axp=axp), labels=NA, tck=-0.01, col="darkgrey")
  }

  lines(y=y, x=x, type=type, col=col, lty=lty, lwd=lwd, pch=pch)

  invisible(list(x=x, y=y))

}



# New version DescTools 0.99.24
# using the same logic for the function as curve()

Shade <- function(expr, col=par("fg"), breaks, density=10, n=101, xname = "x", ...) {

  sexpr <- substitute(expr)

  if (is.name(sexpr)) {
    expr <- call(as.character(sexpr), as.name(xname))
  } else {
    if (!((is.call(sexpr) || is.expression(sexpr)) && xname %in%
          all.vars(sexpr)))
      stop(gettextf("'expr' must be a function, or a call or an expression containing '%s'",
                    xname), domain = NA)
    expr <- sexpr
  }


  .Shade <- function (col, from = NULL, to = NULL, density, n = 101, ...) {

    x <- seq(from, to, length.out=n)
    xval <- c(from, x, to)

    ll <- list(x = x)
    names(ll) <- xname
    # Calculates the function for given xval
    yval <- c(0, eval(expr, envir = ll, enclos = parent.frame(n=2)), 0)
    if (length(yval) != length(xval))
      stop("'expr' did not evaluate to an object of length 'n'")

    polygon(xval, yval, col=col, density=density, ...)

    invisible(list(x = xval, y = yval))

  }

  pars <- Recycle(from=head(breaks, -1), to=tail(breaks, -1), col=col, density=density)

  lst <- list()
  for(i in 1:attr(pars, "maxdim"))
    lst[[i]] <- .Shade(pars$col[i], pars$from[i], pars$to[i], density=pars$density[i], n=n, ...)

  invisible(lst)

}



PlotProbDist <- function(breaks, FUN, blab=NULL, main="", xlim=NULL, 
                         col=NULL, density=7, 
                         alab = LETTERS[1:(length(breaks)-1)], 
                         alab_x=NULL, alab_y = NULL, ylab="density", ...){
  
  fct <- FUN
  FUN <- "fct"
  FUN <- eval(parse(text = FUN))
  
  
  if(is.null(col))
    col <- Pal("Helsana")[1:length(breaks)]
  
  curve(FUN, xlim=xlim,
        main=main,
        type="n", las=1, ylab=ylab, ...)

  Shade(FUN, breaks=breaks,
        col=col, density=density)
  
  if(is.null(alab_x))
    alab_x <- DescTools::MoveAvg(c(xlim[1], head(breaks, -1)[-1], xlim[2]), order=2, align="left")
  
  if(is.null(alab_y))
    alab_y <- ABCCoords("left")$xy$y
  
  if(!identical(alab, NA))
    BoxedText(labels = alab,
              x=alab_x, y=alab_y, cex=2, border=NA)
  
  if(!is.null(blab)){
    mtext(blab, side=1, line=2.5, at=head(breaks, -1)[-1], font=2, cex=1.4)
  }
  
}




## plots: PlotPyramid ====



PlotPyramid <- function(lx, rx = NA, ylab = "",
            ylab.x = 0, col = c("red", "blue"), border = par("fg"),
            main = "", lxlab = "", rxlab = "", xlim = NULL,
            gapwidth = NULL, xaxt = TRUE,
            args.grid = NULL,
            cex.axis = par("cex.axis"), cex.lab = par("cex.axis"), cex.names = par("cex.axis"),
            adj = 0.5, rev = FALSE, ...) {

  if (missing(rx) && length(dim(lx)) > 0) {
    rx <- lx[, 2]
    lx <- lx[, 1]
  }

  if(rev==TRUE){
    lx <- Rev(lx, margin=1)
    rx <- Rev(rx, margin=1)
    ylab <- Rev(ylab)
  }

  b <- barplot(-lx, horiz=TRUE, plot=FALSE, ...)

  ylim <- c(0, max(b))
  if(is.null(xlim)) xlim <- c(-max(lx), max(rx))
  plot( 1, type="n", xlim=xlim, ylim=ylim, frame.plot=FALSE
        , xlab="", ylab="", axes=FALSE, main=main)
  if(is.null(gapwidth)) gapwidth <- max(strwidth(ylab, cex=cex.names)) + 3*strwidth("M", cex=cex.names)

  at.left <- axTicks(1)[axTicks(1)<=0] - gapwidth/2
  at.right <- axTicks(1)[axTicks(1)>=0] + gapwidth/2

  # grid: define default arguments
  if(!identical(args.grid, NA)){    # add grid
    args.grid1 <- list(col="grey", lty="dotted")
    # override default arguments with user defined ones
    if (!is.null(args.grid)) {
      args.grid1[names(args.grid)] <- args.grid
    }
    abline(v=c(at.left, at.right), col=args.grid1$col, lty=args.grid1$lty )
  }

  if(length(col) == 1) border <- rep(col, 2)
  lcol <- rep(col[seq_along(col) %% 2 == 1], times=length(lx))
  rcol <- rep(col[seq_along(col) %% 2 == 0], times=length(rx))

  if(length(border) == 1) border <- rep(border, 2)
  lborder <- rep(border[seq_along(border) %% 2 == 1], times=length(lx))
  rborder <- rep(border[seq_along(border) %% 2 == 0], times=length(rx))

  barplot(-lx, horiz=TRUE, col=lcol, add=TRUE, axes=FALSE, names.arg="",
          offset=-gapwidth/2, border=lborder, ...)
  barplot(rx, horiz=TRUE, col=rcol, add=TRUE, axes=FALSE, names.arg="",
          offset=gapwidth/2, border=rborder, ...)

  oldpar <- par(xpd=TRUE); on.exit(par(oldpar))

  ylab.x <- ylab.x + sign(ylab.x) * gapwidth/2
  text(ylab, x=ylab.x, y=b, cex=cex.names, adj = adj)

  if(!xaxt == "n"){
    axis(side=1, at=at.right, labels=axTicks(1)[axTicks(1)>=0], cex.axis=cex.axis)
    axis(side=1, at=at.left, labels=-axTicks(1)[axTicks(1)<=0], cex.axis=cex.axis)
  }

  mtext(text=rxlab, side=1, at=mean(at.right), padj=0.5, line=2.5, cex=cex.lab)
  mtext(text=lxlab, side=1, at=mean(at.left), padj=0.5, line=2.5, cex=cex.lab)

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

  invisible(b)   # return the same result as barplot
}


###

## plots: PlotCorr ====

PlotCorr <- function(x, cols = colorRampPalette(c(Pal()[2], "white", Pal()[1]), space = "rgb")(20)
  , breaks = seq(-1, 1, length = length(cols)+1), border="grey", lwd=1
  , args.colorlegend = NULL, xaxt = par("xaxt"), yaxt = par("yaxt"), cex.axis = 0.8, las = 2
  , mar = c(3,8,8,8), mincor=0, main="", clust=FALSE, ...){

  # example:
  # m <- cor(d.pizza[,WhichNumerics(d.pizza)][,1:5], use="pairwise.complete.obs")
  # PlotCorr(m)
  # PlotCorr(m, args.colorlegend="n", las=1)
  # PlotCorr(m, cols=colorRampPalette(c("red", "white", "blue"), space = "rgb")(4), args.colorlegend=list(xlab=sprintf("%.1f", seq(1,-1, length=5))) )
  # PlotCorr(m, cols=colorRampPalette(c("red", "black", "green"), space = "rgb")(10))

  # PlotCorr(round(CramerV(d.pizza[,c("driver","operator","city", "quality")]),3))

  pars <- par(mar=mar); on.exit(par(pars))
  
  # matrix should be transposed to allow upper.tri with the corresponding representation
  x <- t(x)
  
  if(clust==TRUE) {
    # cluster correlations in order to put similar values together
    idx <- order.dendrogram(as.dendrogram(
      hclust(dist(x), method = "mcquitty")
    ))

    x <- x[idx, idx]
  }

  # if mincor is set delete all correlations with abs. val. < mincor
  if(mincor!=0)
    x[abs(x) < abs(mincor)] <- NA

  x <- x[,ncol(x):1]
  image(x=1:nrow(x), y=1:ncol(x), xaxt="n", yaxt="n", z=x, frame.plot=FALSE, xlab="", ylab=""
    , col=cols, breaks=breaks, ... )
  if(xaxt!="n") axis(side=3, at=1:nrow(x), labels=rownames(x), cex.axis=cex.axis, las=las, lwd=-1)
  if(yaxt!="n") axis(side=2, at=1:ncol(x), labels=colnames(x), cex.axis=cex.axis, las=las, lwd=-1)

  if((is.list(args.colorlegend) || is.null(args.colorlegend))){

    # bugfix dmurdoch 7.2.2022
    digits <- round(1 - log10(diff(range(breaks))))
    args.colorlegend1 <- list( labels=sprintf("%.*f", digits,
                                              breaks[seq(1,length(breaks), by = 2)])
    # args.colorlegend1 <- list( labels=sprintf("%.1f", seq(-1,1, length=length(cols)/2+1))
      , x=nrow(x)+0.5 + nrow(x)/20, y=ncol(x)+0.5
      , width=nrow(x)/20, height=ncol(x), cols=cols, cex=0.8 )
    if ( !is.null(args.colorlegend) ) { args.colorlegend1[names(args.colorlegend)] <- args.colorlegend }

    do.call("ColorLegend", args.colorlegend1)
  }

  if(!is.na(border)) {
    usr <- par("usr")
    rect(xleft=0.5, xright=nrow(x)+0.5, ybottom=0.5, ytop=nrow(x)+0.5,
         lwd=lwd, border=border)
    usr <- par("usr")
    clip(0.5, nrow(x)+0.5, 0.5, nrow(x)+0.5)
    abline(h=seq(-2, nrow(x)+1,1)-0.5, v=seq(1,nrow(x)+1,1)-0.5, col=border,lwd=lwd)
    do.call("clip", as.list(usr))
  }

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

  if(main!="") title(main=main)

}

###

## plots: PlotViolin ====


PlotViolin <- function(x, ...) {
  UseMethod("PlotViolin")
}



PlotViolin.default <- function (x, ..., horizontal = FALSE, bw = "SJ", na.rm = FALSE
                                , names = NULL, args.boxplot = NULL)  {

  # Make a simple violin plot call from violinplot. values are x,y to plot
  vlnplt <-  function(x, y, center, horizontal = FALSE,
                      col = NA , border = par("fg"), lty = 1, lwd = 1,
                      density = NULL, angle = 45, fillOddEven = FALSE, ...) {
      # double up first
      x <- c(x, rev(x))
      y <- c(y, -rev(y))
      y <- y + center

      # swap x and y if horizontal
      if (horizontal == FALSE) { tmp=x; x=y; y=tmp }

      polygon(x=x, y=y, border=border, col=col, lty=lty, lwd=lwd,
              density=density, angle=angle, fillOddEven=fillOddEven, ...)
    }


  # main *****************

  m <- match.call(expand.dots = FALSE)
  pars <- m$...[ names(m$...)[!is.na(match(names(m$...), c(
    "cex","cex.axis","cex.lab","cex.main","cex.sub","col.axis","col.lab","col.main","col.sub","family",
    "font","font.axis","font.lab","font.main","font.sub","las","tck","tcl","xaxt","xpd","yaxt"
  )))]]
  oldpar <- par(pars); on.exit(par(oldpar))

  args <- list(x, ...)
 #  args <- list(x, m$`...`)
  
  namedargs <- if (!is.null(attributes(args)$names))
                 attributes(args)$names != ""
               else
                 rep(FALSE, length = length(args))

  groups <- if(is.list(x)) x else args[!namedargs]

  if (0 == (n <- length(groups)))
      stop("invalid first argument")
  if (length(class(groups)))
      groups <- unclass(groups)
  if (!missing(names))
      attr(groups, "names") <- names
  else {
      if (is.null(attr(groups, "names")))
          attr(groups, "names") <- 1:n
      names <- attr(groups, "names")
  }

  xvals <- matrix(0, nrow = 512, ncol = n)
  yvals <- matrix(0, nrow = 512, ncol = n)
  center <- 1:n
  for (i in 1:n) {
      if(na.rm) xi <- na.omit(groups[[i]])
        else xi <- groups[[i]]
      tmp.dens <- density(xi, bw = bw)
      xvals[, i] <- tmp.dens$x
      yvals.needtoscale <- tmp.dens$y
      yvals.scaled <- 7/16 * yvals.needtoscale / max(yvals.needtoscale)
      yvals[, i] <- yvals.scaled
  }
  if (horizontal == FALSE) {
      xrange <- c(1/2, n + 1/2)
      yrange <- range(xvals)
  }
  else {
      xrange <- range(xvals)
#      yrange <- c(min(yvals), max(yvals))
      yrange <- c(1/2, n + 1/2)
  }


  plot.args <- m$...[names(m$...)[!is.na(match(names(m$...),
     c("xlim","ylim","main","xlab","ylab","panel.first","panel.last","frame.plot","add")))]]
  if(! "xlim" %in% names(plot.args)) plot.args <- c(plot.args, list(xlim=xrange))
  if(! "ylim" %in% names(plot.args)) plot.args <- c(plot.args, list(ylim=yrange))
  if(! "xlab" %in% names(plot.args)) plot.args <- c(plot.args, list(xlab=""))
  if(! "ylab" %in% names(plot.args)) plot.args <- c(plot.args, list(ylab=""))
  if(! "frame.plot" %in% names(plot.args)) plot.args <- c(plot.args, list(frame.plot=TRUE))

  # plot only if add is not TRUE
  if(! "add" %in% names(plot.args)) add <- FALSE else add <- plot.args$add
  if(!add) do.call(plot, c(plot.args, list(x=0, y=0, type="n", axes=FALSE)))

  # poly.args <- m$...[names(m$...)[!is.na(match(names(m$...), c("border","col","lty","density","angle","fillOddEven")))]]
  # neu:
  poly.args <- args[names(args)[!is.na(match(names(args), c("border","col","lty","lwd","density","angle","fillOddEven")))]]
  poly.args <- lapply( poly.args, rep, length.out=n )

  for (i in 1:n)
#      do.call(vlnplt, c(poly.args[i], list(x=xvals[, i]), list(y=yvals[, i]),
#                        list(center=center[i]), list(horizontal = horizontal)))
      do.call(vlnplt, c(lapply(poly.args, "[", i), list(x=xvals[, i]), list(y=yvals[, i]),
                        list(center=center[i]), list(horizontal = horizontal)))

  axes <- Coalesce(unlist(m$...[names(m$...)[!is.na(match(names(m$...), c("axes")))]]), TRUE)
  if(axes){
    xaxt <- Coalesce(unlist(m$...[names(m$...)[!is.na(match(names(m$...), c("xaxt")))]]), TRUE)
    if(xaxt!="n") if(horizontal == TRUE) axis(1) else axis(1, at = 1:n, labels = names)

    yaxt <- Coalesce(unlist(m$...[names(m$...)[!is.na(match(names(m$...), c("yaxt")))]]), TRUE)
    if(yaxt!="n") if(horizontal == TRUE)  axis(2, at = 1:n, labels = names) else axis(2)
  }

  if(!identical(args.boxplot, NA)){

    args1.boxplot <- list(col="black", add=TRUE, boxwex=0.05, axes=FALSE,
       outline=FALSE, whisklty=1, staplelty=0, medcol="white")
    args1.boxplot[names(args.boxplot)] <- args.boxplot

    do.call(boxplot, c(list(x, horizontal = horizontal), args1.boxplot))

  }

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

}


# PlotViolin.formula <- function (formula, data = NULL, ..., subset) {
PlotViolin.formula <- function (formula, data, subset, na.action, ...) {

    if (missing(formula) || (length(formula) != 3))
        stop("formula missing or incorrect")
    m <- match.call(expand.dots = FALSE)
    if (is.matrix(eval(m$data, parent.frame())))
        m$data <- as.data.frame(data)
    m$... <- NULL

    m[[1]] <- as.name("model.frame")
    mf <- eval(m, parent.frame())
    response <- attr(attr(mf, "terms"), "response")

    PlotViolin(split(mf[[response]], mf[-response]), ...)
}


###

## plots: PlotPolar ====


PlotPolar <- function(r, theta = NULL, type="p"
  , rlim = NULL, main="", lwd = par("lwd"), lty = par("lty"), col = par("col")
  , pch = par("pch"), fill = NA, cex = par("cex")
  , mar = c(2, 2, 5, 2), add = FALSE, ...) {


  if( ncol(r <- as.matrix(r)) == 1) r <- t(r)
  k <- nrow(r)

  if(is.null(theta)) {
    theta <- seq(0, 2*pi, length=ncol(r)+1)[-(ncol(r)+1)]
    if( nrow(r) > 1 ){
      theta <- matrix( rep(theta, times=nrow(r)), ncol=ncol(r), byrow = TRUE )
    }  else {
      theta <- t(as.matrix(theta))
    }
  } else {
    if( ncol(theta <- as.matrix(theta)) == 1) theta <- t(theta)
  }


  if (length(type) < k) type <- rep(type, length.out = k)
  if (length(lty) < k)  lty <- rep(lty, length.out = k)
  if (length(lwd) < k)  lwd <- rep(lwd, length.out = k)
  if (length(pch) < k)  pch <- rep(pch, length.out = k)
  if (length(col) < k)  col <- rep(col, length.out = k)
  if (length(fill) < k) fill <- rep(fill, length.out = k)
  if (length(cex) < k)  cex <- rep(cex, length.out = k)

  dev.hold()
  on.exit(dev.flush())

  # definition follows plot.default()
  if (is.null(rlim))
    rlim <- max(abs(r[is.finite(r)]))*1.12

  if(!add){
    par(mar = mar, pty = "s", xpd=TRUE)
    plot(x=c(-rlim, rlim), y=c(-rlim, rlim),
      type = "n", axes = FALSE, main = main, xlab = "", ylab = "", ...)
  }

  for (i in seq_len(k)) {
    xy <- xy.coords( x=cos(theta[i,]) * r[i,], y=sin(theta[i,])*r[i,])
    if(type[i] == "p"){
      points( xy, pch = pch[i], col = col[i], cex = cex[i] )
    } else if( type[i]=="l") {
      polygon(xy, lwd = lwd[i], lty = lty[i], border = col[i], col = fill[i])
    } else if( type[i]=="h") {
      segments(x0=0, y0=0, x1=xy$x, y1=xy$y, lwd = lwd[i], lty = lty[i], col = col[i])
    }
  }

  if(!add && !is.null(DescToolsOptions("stamp")))
    Stamp()

}



PolarGrid <- function(nr = NULL, ntheta = NULL, col = "lightgray",
  lty = "dotted", lwd = par("lwd"), rlabels = NULL, alabels = NULL,
  lblradians = FALSE, cex.lab = 1, las = 1, adj = NULL, dist = NULL) {

  if (is.null(nr)) {             # use standard values with pretty axis values
      # at <- seq.int(0, par("xaxp")[2L], length.out = 1L + abs(par("xaxp")[3L]))
      at <- axTicks(1)[axTicks(1)>=0]
  } else if (!all(is.na(nr))) {  # use NA for suppress radial gridlines
    if (length(nr) > 1) {        # use nr as radius
      at <- nr
    } else {
      at <- seq.int(0, par("xaxp")[2L], length.out = nr + 1)#[-c(1, nr + 1)]
    }
  } else {at <- NULL}
  if(!is.null(at))
    DrawCircle(x = 0, y = 0, r.out = at, border = col, lty = lty, col = NA)

  if (is.null(ntheta)) {             # use standard values with pretty axis values
      at.ang <- seq(0, 2*pi, by=2*pi/12)
  } else if (!all(is.na(ntheta))) {  # use NA for suppress radial gridlines
    if (length(ntheta) > 1) {        # use ntheta as angles
      at.ang <- ntheta
    } else {
      at.ang <- seq(0, 2*pi, by=2*pi/ntheta)
    }
  } else {at.ang <- NULL}
  if(!is.null(at.ang)) segments(x0=0, y0=0, x1=max(par("usr"))*cos(at.ang)
    , y1=max(par("usr"))*sin(at.ang), col = col, lty = lty, lwd = lwd)

  # plot radius labels
  if(!is.null(at)){
    if(is.null(rlabels)) rlabels <- signif(at[-1], 3)   # standard values
    if(!all(is.na(rlabels)))
      BoxedText(x=at[-1], y=0, labels=rlabels, border=FALSE, bg="white", cex=cex.lab)
  }


  # # plot angle labels
  # if(!is.null(at.ang)){
  #   if(is.null(alabels))
  #     if( lblradians == FALSE ){
  #       alabels <- RadToDeg(at.ang[-length(at.ang)])   # standard values in degrees
  #     } else {
  #       alabels <- Format(at.ang[-length(at.ang)], digits=2)   # standard values in radians
  #     }
  #   if(!all(is.na(alabels)))
  #     BoxedText( x=par("usr")[2]*1.07*cos(at.ang)[-length(at.ang)], y=par("usr")[2]*1.07*sin(at.ang)[-length(at.ang)]
  #                , labels=alabels, border=FALSE, col="white")
  # }


  # plot angle labels
  if(!is.null(at.ang)){

    if(is.null(alabels))
      if(lblradians == FALSE){
        alabels <- RadToDeg(at.ang[-length(at.ang)])   # standard values in degrees
      } else {
        alabels <- Format(at.ang[-length(at.ang)], digits=2)   # standard values in radians
      }

    if(is.null(dist))
      dist <- par("usr")[2]*1.07

    out <- DescTools::PolToCart(r = dist, theta=at.ang)

    if(!all(is.na(alabels)))

      #     BoxedText(x=par("usr")[2]*1.07*cos(at.ang)[-length(at.ang)],
      #               y=par("usr")[2]*1.07*sin(at.ang)[-length(at.ang)]
      #       , labels=alabels, border=FALSE, col="white")

      if(is.null(adj)) {
        adj <- ifelse(at.ang %(]% c(pi/2, 3*pi/2), 1, 0)
        adj[at.ang %in% c(pi/2, 3*pi/2)] <- 0.5
      }
      adj <- rep(adj, length_out=length(alabels))

      if(las == 2){
        sapply(seq_along(alabels),
               function(i) text(out$x[i], out$y[i], labels=alabels[i], cex=cex.lab,
                                srt=DescTools::RadToDeg(atan(out$y[i]/out$x[i])), adj=adj[i]))
      } else {
        sapply(seq_along(alabels),
               function(i) BoxedText(x=out$x[i], y=out$y[i], labels=alabels[i], cex=cex.lab,
                                     srt=ifelse(las==3, 90, 0), adj=adj[i],
                                     border=NA, col="white"))
        # text(out, labels=alabels, cex=cex.lab, srt=ifelse(las==3, 90, 0), adj=adj)
        # BoxedText(x=out$x, y=out$y, labels=alabels, cex=cex.lab,
        #           srt=ifelse(las==3, 90, 0), adj=adj, border=FALSE, col="white")

      }
  }

  invisible()

}




###


## plots: PlotTernary =====

# clumsy *****************
# PlotTernary <- function(a, f, m, symb = 2, grid = FALSE, ...) {
#   # source: cwhmisc:::triplot
#   # author: Christian Hoffmann



PlotTernary <- function(x, y = NULL, z = NULL, args.grid=NULL, lbl = NULL, main = "", ...){


  if(!(is.null(y) && is.null(z))){
    if(is.null(lbl)) lbl <- c(names(x), names(y), names(z))
    x <- cbind(x, y, z)
  } else {
    if(is.null(lbl)) lbl <- colnames(x)
    x <- as.matrix(x)
  }

  if(any(x < 0)) stop("X must be non-negative")
  s <- drop(x %*% rep(1, ncol(x)))
  if(any(s<=0)) stop("each row of X must have a positive sum")
  if(max(abs(s-1)) > 1e-6) {
    warning("row(s) of X will be rescaled")
    x <- x / s
  }

  oldpar <- par(xpd=TRUE)
  on.exit(par(oldpar))
  Canvas(mar=c(1,3,4,1) + .1, main=main)

  sq3 <- sqrt(3)/2

  # grid: define default arguments
  if(!identical(args.grid, NA)){
    args.grid1 <- list(col="grey", lty="dotted", nx=5)
    # override default arguments with user defined ones
    if (!is.null(args.grid)) {
      args.grid1[names(args.grid)] <- args.grid
    }

    d <- seq(0, 2*sq3, sq3*2/(args.grid1$nx))
    x0 <- -sq3 + (1) * d
    segments(x0 = x0, y0 = -0.5, x1 = x0 + sq3 - d*.5, y1 = 1- d * sq3, col=args.grid1$col, lty=args.grid1$lty)
    segments(x0 = x0, y0 = -0.5, x1 = -rev(x0 + sq3 - d*.5), y1 = rev(1- d * sq3), col=args.grid1$col, lty=args.grid1$lty)
    segments(x0 = x0 + sq3 - d*.5, y0 = 1- d * sq3, x1 = rev(x0 -d*.5), y1 = 1- d * sq3, col=args.grid1$col, lty=args.grid1$lty)
  }

  DrawRegPolygon(nv = 3, rot = pi/2, radius.x = 1, col=NA)

  eps <- 0.15
  pts <- DrawRegPolygon(nv = 3, rot = pi/2, radius.x = 1+eps, plot=FALSE)

  text(pts, labels = lbl[c(1,3,2)])

  points((x[,2] - x[,3]) * sq3, x[,1] * 1.5 - 0.5, ...)

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

}




## plots: PlotVenn ====


PlotVenn <- function (x, col = "transparent", plotit = TRUE, labels = NULL) {

  n <- length(x)

  if (n > 5)
    stop("Can't plot a Venn diagram with more than 5 sets...")

  xnames <- if(is.null(names(x))) LETTERS[1:n] else names(x)
  if(is.null(labels)) labels <- xnames

  tab <- table(unlist(x), unlist(lapply(1:length(x), function(i) rep(LETTERS[i], length(x[[i]])))))
  venntab <- table(apply(tab, 1, function(x) paste(LETTERS[1:n][as.logical(x)], collapse = "")))

  if (plotit) {

    plot(x = c(-7, 7), y = c(-7, 7), asp = 1, type = "n",
         xaxt = "n", yaxt = "n", xlab = "", ylab = "", frame.plot = FALSE)

    if (n == 2) {
      DrawCircle(x = c(2, -2), y = c(0, 0), r.out = 3, col = col)
      xy <- data.frame(x = c(-3, 3, 0), y = c(0, 0, 0),
                       set = c("A", "B", "AB")
                       , frq=NA)
      xy[match(rownames(venntab), xy$set),"frq"] <- venntab
      text(xy$x, xy$y, labels=xy$frq) # labels=xy$set)

      lbl <- data.frame(x = c(-6, 6), y = c(2.5, 2.5))
      text(lbl$x, lbl$y, label = labels, cex = 2)

    }
    else if (n == 3) {
      DrawCircle(x = c(2, -1, -1), y = c(0, 1.73, -1.73),
                 r.out = 3, col = col)
      xy <- data.frame(x = c(3.5, -1.75, -1.75, 1, -2, 1, 0),
                       y = c(0, 3, -3, 1.75, 0, -1.75, 0),
                       set = c("A", "B", "C", "AB", "BC", "AC", "ABC")
                      , frq=NA)

      xy[match(rownames(venntab), xy$set),"frq"] <- venntab
      text(xy$x, xy$y, labels=xy$frq) # labels=xy$set)

      lbl <- data.frame(x = c(6.5, -4.5, -4.5), y = c(0,4.8,-4.8))
      text(lbl$x, lbl$y, label = labels, cex = 2)

    }
    else if (n == 4) {
      DrawEllipse(x = c(0, 0, 2, -2), y = c(0, 0, -2, -2),
                  radius.x = 6, radius.y = 4, rot = c(1, 3) * pi/4,
                  col = col)
      xy <- data.frame(x=c(-6.0,-4.0,-2.2,0.0,2.2,3.9,5.9,4.3,2.7,-3.1,-4.3,-2.6,-0.1,2.7,0.0)
                       , y=c(0.3,-2.9,-4.2,-5.7,-4.2,-2.9,0.2,2.3,4.2,4.0,2.3,0.9,-1.6,0.8,3.4)
                       , set=c("A","AC","ACD","AD","ABD","BD","D","CD","C","B","AB","ABC","ABCD","BCD","BC")
                       , frq=NA  )
      xy[match(rownames(venntab), xy$set),"frq"] <- venntab
      text(xy$x, xy$y, labels=xy$frq) # labels=xy$set)

      lbl <- data.frame(x = c(-8, -4.4, 4.5, 7.7), y = c(1.9, 5.4, 5.5, 2.5))
      text(lbl$x, lbl$y, label = labels, cex = 2)

    }
    else if (n == 5) {
      DrawEllipse(x=c(0,-1.5,-2,0,1), y=c(0,0,-2,-2.5,-1), radius.x=6, radius.y=3, rot=c(1.7,2.8,4.1,5.4,6.6), col=col)
      xy <- data.frame(x=c(4.9,-0.7,-5.9,-4.3,3.1, 3.6,2.4,0.9,-2.3,-3.8,-4.7,-3.9,-1.5,1.2,3.3,  2.6,1.8,1.2,-0.5,-2.7,-3.7,-4.3,-2.6,-0.9,0.9,3.4,  2.1,-2.1,-3.4,-0.9,-0.5   )
                       , y=c(0.5,4.5,1.7,-5.5,-6.1,  -1.1,1.8,2.7,2.9,1.5,-1.1,-3.1,-5,-4.7,-3.1,  0.1,2,1.4,2.4,2.2,0.2,-1.6,-3.3,-4.7,-3.8,-2.5,  -2.1,1.5,-1.3,-3.8,-0.8 )
                       , set=c("B","A","E","D","C",  "BE","AB","AD","AE","CE","DE","BD","CD","AC","BC"
                               ,"ABE","ABD", "ABDE","ADE","ACE","CDE","BDE","BCD","ACD","ABC","BCE", "ABCE","ACDE","BCDE","ABCD","ABCDE" )
                       , frq=NA  )
      xy[match(rownames(venntab), xy$set),"frq"] <- venntab
      text(xy$x, xy$y, labels=xy$frq) # labels=xy$set)

      lbl <- data.frame(x=c(1.8,7.6,5.8,-7.5,-7.9), y=c(6.3,-0.8,-7.1,-6.8,3.9))
      text( lbl$x, lbl$y, label=labels, cex=2)

    }

    xy$setx <- xy$set

    # replace AB.. by names of the list
    code <- data.frame(id=LETTERS[1:n], x=xnames)
    levels(xy$setx) <- sapply(levels(xy$setx), function(x) paste(code$x[match(unlist(strsplit(x, split="")), code$id)], collapse=""))
    names(venntab) <- sapply(names(venntab), function(x) paste(code$x[match(unlist(strsplit(x, split="")), code$id)], collapse=""))

  }
  else {
    xy <- NA
  }

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

  return(list(venntab, xy))
}


###



CompleteColumns <- function(x, which=TRUE){
  if(which)
    names(Filter(IsZero, sapply(x, function(z) sum(is.na(z)))))
  else 
    sapply(x, function(z) sum(is.na(z)))==FALSE
}



CountCompCases <- function(x){

  # x is a data.frame

  n <- nrow(x)
  cc <- sum(complete.cases(x))

  z <- numeric(ncol(x))
  m <- numeric(ncol(x))
  for(i in 1:ncol(x)){
    z[i] <- sum(complete.cases(x[,-i]))
    m[i] <- sum(is.na(x[,i]))
  }

  res <- list(
    n=n, cc=cc, tab=data.frame(vname=colnames(x), nas=m, nas_p=m/n, cifnot=z, cifnot_p=z/n)
  )

  class(res) <- "CountCompCases"
  res

}


print.CountCompCases <- function(x, digits=1, ...){

  cat(gettextf("\nTotal rows:      %s\nComplete Cases:  %s (%s)\n\n", x$n, x$cc,
               Format(x$cc/x$n, fmt="%", digits=digits)))
  x$tab$nas_p <- Format(x$tab$nas_p, fmt="%", digits=digits)
  x$tab$cifnot_p <- Format(x$tab$cifnot_p, fmt="%", digits=digits)

  print(x$tab, print.gap = 2)
  cat("\n")
}



PlotMiss <- function(x, col = DescTools::hred, bg=SetAlpha(DescTools::hecru, 0.3), clust=FALSE,
                     main = NULL, ...){

  x <- as.data.frame(x)
  if(ncol(x) > 1)
    x <- Rev(x, 2)
  n <- ncol(x)

  inches_to_lines <- (par("mar") / par("mai") )[1]  # 5
  lab.width <- max(strwidth(colnames(x), units="inches")) * inches_to_lines
  ymar <- lab.width + 3

  Canvas(xlim=c(0, nrow(x)+1), ylim=c(0, n), asp=NA, xpd=TRUE, mar = c(5.1, ymar, 5.1, 5.1)
         , main=main, ...)

  usr <- par("usr") # set background color lightgrey
  rect(xleft=0, ybottom=usr[3], xright=nrow(x)+1, ytop=usr[4], col=bg, border=NA)
  axis(side = 1)

  missingIndex <- as.matrix(is.na(x))
  miss <- apply(missingIndex, 2, sum)

  if(clust){
    orderIndex <- order.dendrogram(as.dendrogram(hclust(dist(missingIndex * 1), method = "mcquitty")))
    missingIndex <- missingIndex[orderIndex, ]
    res <- orderIndex
  } else {
    res <- NULL
  }

  sapply(1:ncol(missingIndex), function(i){
    xl <- which(missingIndex[,i])
    if(length(xl) > 0)
      rect(xleft=xl, xright=xl+1, ybottom=i-1, ytop=i, col=col, border=NA)
  })

  abline(h=1:ncol(x), col="white")
  mtext(side = 2, text = colnames(x), at = (1:n)-0.5, las=1, adj = 1)
  mtext(side = 4, text = gettextf("%s (%s)", miss, Format(miss/nrow(missingIndex), fmt="%", digits=1)),
        at = (1:n)-0.5, las=1, adj = 0)

  # text(x = -0.03 * nrow(x), y = (1:n)-0.5, labels = colnames(x), las=1, adj = 1)
  # text(x = nrow(x) * 1.04, y = (1:n)-0.5, labels = gettextf("%s (%s)", miss, Format(miss/nrow(missingIndex), fmt="%", digits=1)), las=1, adj=0)

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

  invisible(res)
}




###

## plots: PlotTreemap ====

# the code is strongly based on Jeff Enos' treemap in library(portfolio), jeff@kanecap.com,

# potential improvements:
#   * make the position of the text more flexible (top-left, bottom-right etc.)
#   * clip text to the specific rectangles and don't allow to write over the rect.
#   * see examples at http://www.hiveondemand.com/portal/treemap_basics.jsp


PlotTreemap <- function(x, grp=NULL, labels=NULL, cex=1.0, text.col="black", col=rainbow(length(x)),
                        labels.grp=NULL, cex.grp=3, text.col.grp="black", border.grp="grey50",
                        lwd.grp=5, main="") {

  SqMap <- function(x) {

    .sqmap <- function(z, x0 = 0, y0 = 0, x1 = 1, y1 = 1, lst=list()) {

      cz <- cumsum(z$area)/sum(z$area)
      n <- which.min(abs(log(max(x1/y1, y1/x1) * sum(z$area) * ((cz^2)/z$area))))
      more <- n < length(z$area)
      a <- c(0, cz[1:n])/cz[n]
      if (y1 > x1) {
        lst <- list( data.frame(idx=z$idx[1:n],
                                x0=x0 + x1 * a[1:(length(a) - 1)],
                                y0=rep(y0, n), x1=x0 + x1 * a[-1], y1=rep(y0 + y1 * cz[n], n)))
        if (more) {
          lst <- append(lst, Recall(z[-(1:n), ], x0, y0 + y1 * cz[n], x1, y1 * (1 - cz[n]), lst))
        }
      } else {
        lst <- list( data.frame(idx=z$idx[1:n],
                                x0=rep(x0, n), y0=y0 + y1 * a[1:(length(a) - 1)],
                                x1=rep(x0 + x1 * cz[n], n), y1=y0 + y1 * a[-1]))
        if (more) {
          lst <- append(lst, Recall(z[-(1:n), ], x0 + x1 * cz[n], y0, x1 * (1 - cz[n]), y1, lst))
        }
      }
      lst
    }

    # z <- data.frame(idx=seq_along(z), area=z)
    if(is.null(names(x))) names(x) <- seq_along(x)
    x <- data.frame(idx=names(x), area=x)
    res <- do.call(rbind, .sqmap(x))
    rownames(res) <- x$idx
    return(res[,-1])

  }


  PlotSqMap <- function(z, col = NULL, border=NULL, lwd=par("lwd"), add=FALSE){
    if(is.null(col)) col <- as.character(z$col)
    # plot squarified treemap
    if(!add) Canvas(c(0,1), xpd=TRUE)
    for(i in 1:nrow(z)){
      rect(xleft=z[i,]$x0, ybottom=z[i,]$y0, xright=z[i,]$x1, ytop=z[i,]$y1,
           col=col[i], border=border, lwd=lwd)
    }
  }


  if(is.null(grp)) grp <- rep(1, length(x))
  if(is.null(labels)) labels <- names(x)

  # we need to sort the stuff
  ord <- order(grp, -x)
  x <- x[ord]
  grp <- grp[ord]
  labels <- labels[ord]
  col <- col[ord]


  # get the groups rects first
  zg <- SqMap(Sort(tapply(x, grp, sum), decreasing=TRUE))
  # the transformation information: x0 translation, xs stretching
  tm <- cbind(zg[,1:2], xs=zg$x1 - zg$x0, ys=zg$y1 - zg$y0)
  gmidpt <- data.frame(x=apply(zg[,c("x0","x1")], 1, mean),
                       y=apply(zg[,c("y0","y1")], 1, mean))

  if(is.null(labels.grp))
    if(nrow(zg)>1) {
      labels.grp <- rownames(zg)
    } else {
      labels.grp <- NA
    }

  Canvas(c(0,1), xpd=TRUE, asp=NA, main=main)

  res <- list()

  for( i in 1:nrow(zg)){

    # get the group index
    idx <- grp == rownames(zg)[i]
    xg.rect <- SqMap(Sort(x[idx], decreasing=TRUE))

    # transform
    xg.rect[,c(1,3)] <- xg.rect[,c(1,3)] * tm[i,"xs"] + tm[i,"x0"]
    xg.rect[,c(2,4)] <- xg.rect[,c(2,4)] * tm[i,"ys"] + tm[i,"y0"]

    PlotSqMap(xg.rect, col=col[idx], add=TRUE)

    res[[i]] <- list(grp=gmidpt[i,],
                     child= cbind(x=apply(xg.rect[,c("x0","x1")], 1, mean),
                                  y=apply(xg.rect[,c("y0","y1")], 1, mean)))

    text( x=apply(xg.rect[,c("x0","x1")], 1, mean),
          y=apply(xg.rect[,c("y0","y1")], 1, mean),
          labels=labels[idx], cex=cex, col=text.col )
  }

  names(res) <- rownames(zg)

  PlotSqMap(zg, col=NA, add=TRUE, border=border.grp, lwd=lwd.grp)

  text( x=apply(zg[,c("x0","x1")], 1, mean),
        y=apply(zg[,c("y0","y1")], 1, mean),
        labels=labels.grp, cex=cex.grp, col=text.col.grp)

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

  invisible(res)

}




###

## plots: PlotCirc ====


PlotCirc <- function(tab, acol = rainbow(sum(dim(tab))), aborder = "darkgrey",
                     rcol = SetAlpha(acol[1:nrow(tab)], 0.5), rborder = "darkgrey",
                     gap = 5, main = "", labels = NULL, cex.lab = 1.0,
                     las = 1, adj = NULL, dist = 2){

  ribbon <- function( angle1.beg, angle1.end, angle2.beg, angle2.end,
                      radius1 = 1, radius2 = radius1, col = "blue",
                      border ="darkgrey" ){
    xy1 <- DescTools::PolToCart( radius1, angle1.beg )
    xy2 <- DescTools::PolToCart( radius2, angle1.end )
    xy3 <- DescTools::PolToCart( radius1, angle2.beg )
    xy4 <- DescTools::PolToCart( radius2, angle2.end )

    bez1 <- DescTools::DrawArc(rx = radius2, theta.1 = DescTools::CartToPol(xy2$x, xy2$y)$theta, theta.2 = DescTools::CartToPol(xy4$x, xy4$y)$theta, plot=FALSE)[[1]]
    bez2 <- DescTools::DrawBezier( x = c(xy4$x, 0, xy3$x), y = c(xy4$y, 0, xy3$y), plot=FALSE )
    bez3 <- DescTools::DrawArc(rx = radius1, theta.1=DescTools::CartToPol(xy3$x, xy3$y)$theta, theta.2 =DescTools::CartToPol(xy1$x, xy1$y)$theta, plot=FALSE )[[1]]
    bez4 <- DescTools::DrawBezier(x = c(xy1$x, 0, xy2$x), y = c(xy1$y, 0, xy2$y), plot=FALSE )

    polygon( x=c(bez1$x, bez2$x, bez3$x, bez4$x),
             y=c(bez1$y, bez2$y, bez3$y, bez4$y), col=col, border=border)
  }

  n <- sum(tab)
  ncol <- ncol(tab)
  nrow <- nrow(tab)
  d <- DegToRad(gap)    # the gap between the sectors in radiant

  acol <- rep(acol, length.out = ncol+nrow)
  rcol <- rep(rcol, length.out = nrow)
  aborder <- rep(aborder, length.out = ncol+nrow)
  rborder <- rep(rborder, length.out = nrow)

  mpts.left <- c(0, cumsum(as.vector(rbind(rev(apply(tab, 2, sum))/ n * (pi - ncol * d), d))))
  mpts.right <- cumsum(as.vector(rbind(rev(apply(tab, 1, sum))/ n * (pi - nrow * d), d)))
  mpts <- c(mpts.left, mpts.right + pi) + pi/2 + d/2

  DescTools::Canvas(10, main=main, xpd=TRUE)
  DescTools::DrawCircle(x=0, y=0, r.in=9.5, r.out=10,
                    theta.1=mpts[seq_along(mpts) %% 2 == 1],
                    theta.2=mpts[seq_along(mpts) %% 2 == 0],
                    col=acol, border=aborder)

  if(is.null(labels)) labels <- rev(c(rownames(tab), colnames(tab)))

  ttab <- rbind(DescTools::Rev(tab, margin=2) / n * (pi - ncol * d), d)
  pts.left <- (c(0, cumsum(as.vector(ttab))))

  ttab <- rbind(DescTools::Rev(t(tab), margin=2)/ n * (pi - nrow * d), d)
  pts.right <- (c( cumsum(as.vector(ttab)))) + pi

  pts <- c(pts.left, pts.right) + pi/2 + d/2
  dpt <- data.frame(from=pts[-length(pts)], to=pts[-1])

  for( i in 1:ncol) {
    for( j in 1:nrow) {
      lang <- dpt[(i-1)*(nrow+1)+j,]
      rang <- DescTools::Rev(dpt[-nrow(dpt),], margin=1)[(j-1)*(ncol+1) + i,]
      ribbon( angle1.beg=rang[,2], angle1.end=lang[,1], angle2.beg=rang[,1], angle2.end=lang[,2],
              radius1 = 10, radius2 = 9, col = rcol[j], border = rborder[j])
    }}

  out <- DescTools::PolToCart(r = 10 + dist, theta=filter(mpts, rep(1/2,2))[seq(1,(nrow+ncol)*2, by=2)])

  if(las == 2){
    if(is.null(adj)) adj <- c(rep(1, nrow), rep(0,ncol))
    adj <- rep(adj, length_out=length(labels))
    sapply(seq_along(labels),
           function(i) text(out$x[i], out$y[i], labels=labels[i], cex=cex.lab,
                            srt=DescTools::RadToDeg(atan(out$y[i]/out$x[i])), adj=adj[i]))
  } else {
    text(out, labels=labels, cex=cex.lab, srt=ifelse(las==3, 90, 0), adj=adj)
  }

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

    invisible(out)

}



###

## plots: PlotWeb ====


PlotWeb <- function(m, col=c(DescTools::hred, DescTools::hblue), lty=NULL, 
                    lwd = NULL, args.legend=NULL, pch=21, pt.cex=2,
                    pt.col="black", pt.bg="darkgrey", cex.lab = 1.0,
                    las = 1, adj = NULL, dist = 0.5, ... ){

# following an idee from library(LIM)
# example(plotweb)

  oldpar <- par(c("lend","xpd"))
  on.exit(par(oldpar))

  w <- 4
  par("xpd"=TRUE, lend="butt")

  DescTools::Canvas(w, ...)
  angles <- seq(0, 2*pi, length=nrow(m)+1)[-1]
  xy <- DescTools::PolToCart(r=3, theta=angles)
  xylab <- DescTools::PolToCart(r=3 + dist, theta=angles)

  labels <- colnames(m)

    if(las == 2){
    if(is.null(adj)) adj <- (angles %[]% c(pi/2, 3*pi/2))*1
    adj <- rep(adj, length_out=length(labels))
    sapply(seq_along(labels),
           function(i) text(xylab$x[i], xylab$y[i], labels=labels[i], cex=cex.lab,
                            srt=DescTools::RadToDeg(atan(xy$y[i]/xy$x[i])), adj=adj[i]))
  } else {
    if(is.null(adj)){
      if(las==1)
        adj <- (angles %[]% c(pi/2, 3*pi/2))*1
      if(las==3)
        adj <- (angles %[]% c(3*pi/4, 7*pi/4))*1
    }
    adj <- rep(adj, length_out=length(labels))
    sapply(seq_along(labels),
           function(i) text(xylab$x[i], xylab$y[i], labels=labels[i], cex=cex.lab,
                            srt=ifelse(las==3, 90, 0), adj=adj[i]))

  }

  # d.m <- data.frame( from=rep(colnames(m), nrow(m)), to=rep(colnames(m), each=nrow(m))
  #   , d=as.vector(m)
  #   , from.x=rep(xy$x, nrow(m)), from.y=rep(xy$y, nrow(m)), to.x=rep(xy$x, each=nrow(m)), to.y=rep(xy$y, each=nrow(m)) )
  # d.m <- d.m[d.m$d > 0,]
  # lineare transformation of linewidth
  a <- 0.5
  b <- 10
  # d.m$d.sc <- (b-a) * (min(d.m$d)-a) + (b-a) /diff(range(d.m$d)) * d.m$d

  i <- DescTools::CombPairs(1:dim(m)[1])
  d.m <- data.frame(from=colnames(m)[i[,1]], from=colnames(m)[i[, 2]], d=m[lower.tri(m)],
                    from.x=xy[[1]][i[,2]], to.x=xy[[1]][i[,1]],
                    from.y=xy[[2]][i[,2]], to.y=xy[[2]][i[,1]])

  if(is.null(lwd))
    d.m$d.sc <- DescTools::LinScale(abs(d.m$d), newlow=a, newhigh=b )
  else
    d.m$d.sc <- lwd

  if(is.null(lwd))
    d.m$lty <- par("lty")
  else
    d.m$lty <- lty


  col <- rep(col, length.out=2)

  segments( x0=d.m$from.x, y0=d.m$from.y, x1 = d.m$to.x, y1 = d.m$to.y,
         col = col[((sign(d.m$d)+1)/2)+1], lty = d.m$lty, lwd=d.m$d.sc, lend= 1)
  points( xy, cex=pt.cex, pch=pch, col=pt.col, bg=pt.bg )

  # find min/max negative value and min/max positive value
  i <- c(which.min(d.m$d), which.max(ifelse(d.m$d<=0, d.m$d, NA)), which.min(ifelse(d.m$d>0, d.m$d, NA)), which.max(d.m$d))

  args.legend1 <- list( x="bottomright",
                        legend=Format(d.m$d[i], digits=3, ldigits=0), lwd = d.m$d.sc[i],
                        col=rep(col, each=2), bg="white", cex=0.8)
  if ( !is.null(args.legend) ) { args.legend1[names(args.legend)] <- args.legend }
  add.legend <- TRUE
  if(!is.null(args.legend)) if(all(is.na(args.legend))) {add.legend <- FALSE}

  if(add.legend) do.call("legend", args.legend1)

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

  invisible(xy)

}


###

## plots: PlotCandlestick ====

PlotCandlestick <- function (x, y, vol=NA, xlim = NULL, ylim = NULL, 
                             col = c("springgreen4", "firebrick"), 
                             border = NA, 
                             args.bar=NULL, args.grid = NULL, ...) {
  
  
  pp <- par(no.readonly = TRUE)
  on.exit(par(pp))
  
  add.bar <- !(identical(args.bar, NA) | identical(vol, NA))
  
  if (add.bar) {
    layout(matrix(c(1, 2), nrow = 2, byrow = TRUE), 
           heights = c(1.5, 1), TRUE)
    Mar(bottom=0, right=5)
    
  }
  
  xlim <- if (is.null(xlim)) 
    range(x[is.finite(x)])
  else 
    xlim
  
  ylim <- if (is.null(ylim)) 
    range(y[is.finite(y)])
  else 
    ylim
  
  plot(x = 1, y = 1, xlim = xlim, ylim = ylim, type = "n", 
       xaxt = "n", xlab = "", ...)
  
  add.grid <- TRUE
  if (!is.null(args.grid)) 
    if (all(is.na(args.grid))) {
      add.grid <- FALSE
    }
  
  if (add.grid) {
    args.grid1 <- list(nx=NA, ny=NULL, lty = "solid", col = "grey83")
    if (!is.null(args.grid)) {
      args.grid1[names(args.grid)] <- args.grid
    }
    do.call("grid", args.grid1)
  }
  
  
  # open low high close
  segments(x0 = x, y0 = y[, 2], y1 = y[, 3], col = col[(y[, 1] > y[, 4]) * 1 + 1])
  
  rect(xleft = x - 0.3, ybottom = y[, 1], xright = x + 0.3, 
       ytop = y[, 4], col = col[(y[, 1] > y[, 4]) * 1 + 1], 
       border = border)
  
  if(add.bar){
    
    Mar(top=0, bottom=pp$mar[1])
    
    args.bar1 <- list(col = col[(y[, 1] > y[, 4]) * 1 + 1], 
                      x=1, y=1, ylab="", border=border,
                      xlim = xlim, type="n", xaxt="n", yaxt="n", xlab="",
                      ylim = range(0, vol[is.finite(vol)] ))
    if (!is.null(args.bar)) {
      args.bar1[names(args.bar)] <- args.bar
    }
    
    DoCall("plot", args.bar1[names(args.bar1) %nin% c("border")])
    
    axis(4, las=1)
    rect(xleft = x - 0.3, ybottom = 0, xright = x + 0.3, 
         ytop = vol, col = args.bar1$col, 
         border = args.bar1$border)
    
  }
  
  if (is.null(list(...)[["xaxt"]])) {
    if (IsDate(x)) {
      j <- Year(x)
      j[!c(1, diff(j))] <- NA
      mtext(side = 1, at = x, text = j, cex = par("cex.axis"), line = 1)
      j <- Month(x)
      j[!c(1, diff(j))] <- NA
      mtext(side = 1, at = x, text = month.name[j], cex = par("cex.axis"), 
            line = 2)
      mtext(side = 1, at = x, text = Day(x), cex = par("cex.axis"), line = 3)
    }
    else {
      axis(side = 1, at = x, labels = x)
    }
  }
  
  
  if (!is.null(DescToolsOptions("stamp"))) 
    Stamp()
}




PlotCashFlow <- function(x, y, xlim=NULL, labels=y, mar=NULL, cex.per=par("cex"), 
                         cex.tck=par("cex") * 0.8, cex.cash=par("cex")){

  if(is.null(xlim))
    xlim <- if (is.null(xlim))
      range(x[is.finite(x)])

  x0 <- do.call(seq, as.list(xlim))

  yf <- max(abs(range(c(0, y[is.finite(y)]))))

  if(is.null(mar))  mar <- c(5.1,5.1,5.1,5.1)
  
  Canvas(xlim=xlim, ylim=c(-1,1), xpd=TRUE, asp=NULL, mar=mar)
  arrows(xlim[1], 0, xlim[2]+1, code=0)
  DrawRegPolygon(x=xlim[2]+1, y=0, rot=2*pi/3, radius.x = .09, col=1)

  segments(x0 = x0, y0 = -.1, y1=0.1)

  arrows(x0=x, y0=0, y1=y/yf, angle = 20, code=0)
  #  points(x=x, y=y/30, pch=17, cex=1.2)
  DrawRegPolygon(x=x, y=y/yf, rot=pi/6 + (y>0) * pi, radius.x = .1, col=1)

  # periods
  BoxedText(x0, -.3, Format(x0, ldigits=2, digits=0), border = NA, cex=cex.per)
  # ticks
  BoxedText(x0 + 0.5, .2, Format(seq_along(x0), ldigits=2, digits=0), 
            border = NA, cex=cex.tck)
  # cashflows
  BoxedText(x=x, y=sign(y) *(abs(y/yf)+.3), labels = labels, border = NA, cex=cex.cash)

}



SaveAs <- function(x, objectname, file, ...){

  local({ assign(x = objectname, value = x)
    save(list=objectname, file=file, ...)
  })

}




###

## plots: PlotSuperbar

# ueberlagerte Barplots
# Superbarplot in UsingR


###

## plots: PlotMatrix ====
# old function not worth havin here

#
# PlotMatrix <- function(x, y=NULL, data=NULL, panel=l.panel,
#          nrows=0, ncols=nrows, save=TRUE, robrange.=FALSE, range.=NULL,
#          pch=NULL, col=1, reference=0, ltyref=3,
#          log="", xaxs="r", yaxs="r", xaxmar=NULL, yaxmar=NULL,
#          vnames=NULL, main='', cex.points=NA, cex.lab=0.7, cex.text=1.3,
#          cex.title=1,
#          bty="o", oma=NULL, ...) {
#
# # Purpose:    pairs  with different plotting characters, marks and/or colors
# #             showing submatrices of the full scatterplot matrix
# #             possibly on several pages
# # ******************************************************************************
# # Author: Werner Stahel, Date: 23 Jul 93; minor bug-fix+comments:
#   # M.Maechler
#
#   is.formula <- function(object) length(class(object))>0 && class(object)=="formula"
#
#
#   l.panel <- function(x,y,indx,indy,pch=1,col=1,cex=cex.points,...) {
#     if (is.character(pch)) text(x,y,pch,col=col,cex=cex) else
#     points(x,y,pch=pch,col=col,cex=cex,...)
#   }
#   oldpar <- par(c("mfrow","mar","cex","oma","mgp"))
#   on.exit(par(oldpar))
# # **************** preparations **************
# # data
#   if (is.formula(x))  {
#     if (length(x)==2)
#     x <- model.frame(x,data, na.action=NULL)  else {
#       ld <- model.frame(x[c(1,3)],data, na.action=NULL)
#       ld <- cbind(ld, model.frame(x[1:2],data, na.action=NULL))
#       x <- ld
#     }
#   }
#   if (is.data.frame(x)) {
#     for (jj in 1:length(x)) x[[jj]] <- as.numeric(x[[jj]])
#     x <- as.matrix(x)
#   } else x <- cbind(x)
# #  stop("!PlotMatrix! first argument must either be a formula or a data.frame or matrix")
#   nv1 <- dim(x)[2]
#   lv1 <- lv2 <- 0
#   if (is.null(y)) {
#     ldata <- x
#     if (save) { nv1 <- nv1-1; lv2 <- 1 }
#     nv2 <- nv1
#   } else { # cbind y to data for easier preparations
#     save <- FALSE
#     if (is.formula(y))  {
#       ld <- model.frame(x[c(1,3)],data, na.action=NULL)
#     if (length(x)>2)
#       ld <- cbind(ld, model.frame(x[1:2],data, na.action=NULL))
#     x <- ld
#   }
#     if (is.formula(y)) {
#       if (length(y)==2)
#         y <- model.frame(y,data, na.action=NULL)  else {
#           ld <- model.frame(y[c(1,3)],data, na.action=NULL)
#           ld <- cbind(ld, model.frame(y[1:2],data, na.action=NULL))
#           y <- ld
#         }
#     }
#     if (is.data.frame(y)) {
#       for (jj in 1:length(y)) y[[jj]] <- as.numeric(y[[jj]])
#       y <- as.matrix(y)
#     }
#     ldata <- cbind(x, as.matrix(y))
#     nv2 <- ncol(ldata)-nv1 ; lv2 <- nv1 }
#   nvv <- ncol(ldata)
#   tnr <- nrow(ldata)
# # variable labels
#   if (missing(vnames)) vnames <- dimnames(ldata)[[2]]
#   if (is.null(vnames)) vnames <- paste("V",1:nvv)
# # plotting characters
#   if (length(pch)==0) pch <- 1
# # range
#   rg <- matrix(nrow=2,ncol=nvv,dimnames=list(c("min","max"),vnames))
#   if(is.matrix(range.)) {
#     if (is.null(colnames(range.))) {
#       if (ncol(range)==ncol(rg)) rg[,] <- range.  else
#       warning('argument  range.  not suitable. ignored')
#     } else {
#       lj <- match(colnames(range.),vnames)
#       if (any(is.na(lj))) {
#         warning('variables', colnames(range.)[is.na(lj)],'not found')
#         if (any(!is.na(lj))) rg[,lj[!is.na(lj)]] <- range.[,!is.na(lj)]
#       }
#     }
#   }
#   else
#     if (length(range.)==2&&is.numeric(range.)) rg[,] <- matrix(range.,2,nvv)
#
#   lna <- apply(is.na(rg),2, any)
#   if (any(lna))
#     rg[,lna] <- apply(ldata[,lna,drop=FALSE],2,
#       Range, robust=robrange., na.rm=TRUE, finite=TRUE)
#   colnames(rg) <- vnames
# # reference lines
#   tjref <- (length(reference)>0)&&!(is.logical(reference)&&!reference)
#   if (tjref) {
#     if(length(reference)==1) lref <- rep(reference,length=nvv) else {
#       lref <- rep(NA,nvv)
#       lref[match(names(reference),vnames)] <- reference
#     }
#     names(lref) <- vnames
#   }
# # plot
#   jmain <- !is.null(main)&&main!=""
#   lpin <- par("pin")
#   lnm <- if (lpin[1]>lpin[2]) {
#     if (nv1==6 && nv2==6) c(6,6) else c(5,6) } else c(8,5)
#   if (is.na(nrows)||nrows<1) nrows <- ceiling(nv1/((nv1-1)%/%lnm[1]+1))
#   if (is.na(ncols)||ncols<1) ncols <- ceiling(nv2/((nv2-1)%/%lnm[2]+1))
#   if (is.null(xaxmar)) xaxmar <- 1+(nv1*nv2>1)
#   if (any(is.na(xaxmar))) xaxmar <- 1+(nv1*nv2>1)
#   xaxmar <- ifelse(xaxmar>1,3,1)
#   if (is.null(yaxmar)) yaxmar <- 2+(nv1*nv2>1)
#   if (any(is.na(yaxmar))) yaxmar <- 2+(nv1*nv2>1)
#   yaxmar <- ifelse(yaxmar>2,4,2)
#   if (length(oma)!=4)
#     oma <- c(2+(xaxmar==1), 2+(yaxmar==2),
#              1.5+(xaxmar==3)+cex.title*2*jmain,
#              2+(yaxmar==4))
# #    oma <- 2 + c(0,0,!is.null(main)&&main!="",1)
#   par(mfrow=c(nrows,ncols))
# ##-   if (!is.na(cex)) par(cex=cex)
# ##-   cex <- par("cex")
# ##-   cexl <- cex*cexlab
# ##-   cext <- cex*cextext
#   par(oma=oma*cex.lab, mar=rep(0.2,4), mgp=cex.lab*c(1,0.5,0))
#   if (is.na(cex.points)) cex.points <- max(0.2,min(1,1.5-0.2*log(tnr)))
# #
#   # log
#   if (length(grep("x",log))>0) ldata[ldata[,1:nv1]<=0,1:nv1] <- NA
#   if (length(grep("y",log))>0) ldata[ldata[,lv2+1:nv2]<=0,lv2+1:nv2] <- NA
#   npgr <- ceiling(nv2/nrows)
#   npgc <- ceiling(nv1/ncols)
# # ******************** plots **********************
#   for (ipgr in 1:npgr) {
#     lr <- (ipgr-1)*nrows
#   for (ipgc in 1:npgc) {
#     lc <- (ipgc-1)*ncols
#     if (save&&((lr+nrows)<=lc)) break
#   for (jr in 1:nrows) { #-- plot row [j]
#     jd2 <- lr+jr
#     j2 <- lv2 + jd2
#     if (jd2<=nv2)  v2 <- ldata[,j2]
#     for (jc in 1:ncols) { #-- plot column  [j2-lv2] = 1:nv2
#       jd1 <- lc+jc
#       j1 <- lv1 + jd1
#     if (jd2<=nv2 & jd1<=nv1) {
#       v1 <- ldata[,j1]
#       plot(v1,v2, type="n", xlab="", ylab="", axes=FALSE,
#            xlim <- rg[,j1], ylim <- rg[,j2],
#            xaxs=xaxs, yaxs=yaxs, log=log, cex=cex.points)
#       usr <- par("usr")
#       if (jr==nrows||jd2==nv2) {
#         if (xaxmar==1) axis(1)
#         mtext(vnames[j1], side=1, line=(0.5+1.2*(xaxmar==1))*cex.lab,
#               cex=cex.lab, at=mean(usr[1:2]))
#       }
#       if (jc==1) {
#         if (yaxmar==2) axis(2)
#         mtext(vnames[j2], side=2, line=(0.5+1.2*(yaxmar==2))*cex.lab,
#               cex=cex.lab, at=mean(usr[3:4]))
#       }
#       if (jr==1&&xaxmar==3) axis(3,xpd=TRUE)
#       if (jc==ncols||jd1==nv1) if (yaxmar==4) axis(4,xpd=TRUE)
#       box(bty=bty)
#       if (any(v1!=v2,na.rm=TRUE)) { # not diagonal
#         panel(v1,v2,jd1,jd2, pch, col, ...)
#         if (tjref) abline(h=lref[j1],v=lref[j2],lty=ltyref)
#       }
#       else { uu <- par("usr") # diagonal: print variable name
#              text(mean(uu[1:2]),mean(uu[3:4]), vnames[j1], cex=cex.text) }
#     }
#       else frame()
#     }
#   }
#   if (jmain) mtext(main,3,oma[3]*0.9-2*cex.title,outer=TRUE,cex=cex.title)
# ##-   stamp(sure=FALSE,line=par("mgp")[1]+0.5)
# #  stamp(sure=FALSE,line=oma[4]-1.8) ### ??? why does it need so much space?
#   }}
#   on.exit(par(oldpar))
#   "PlotMatrix: done"
# }
#
# ###
#


## plots: ACF, GACF and other TimeSeries plots ----------

# PlotACF <- function(series, lag.max = 10*log10(length(series)), ...)  {
# 
#   ## Purpose:  time series plot with correlograms
#   #  Original name: f.acf
# 
#   ## ---
#   ## Arguments: series : time series
#   ##           lag.max : the maximum number of lags for the correlograms
# 
# 
#   ## ---
#   ## Author: Markus Huerzeler, Date: 15 Jun 94
#   ## Revision: Christian Keller, 5 May 98
#   ## Revision: Markus Huerzeler, 11. Maerz 04
# 
#   # the stamp option should only be active for the third plot, so deactivate it here
#   opt <- DescToolsOptions(stamp=NULL)
# 
#   if (!is.null(dim(series)))
#     stop("f.acf is only implemented for univariate time series")
# 
#   par(mfrow=c(1,1))
#   old.par <- par(mar=c(3,3,1,1), mgp=c(1.5,0.5,0))
#   on.exit(par(old.par))
# 
#   split.screen(figs=matrix(c(0,1,0.33,1, 0,0.5,0,0.33, 0.5,1,0,0.33),
#                            ncol=4, byrow=TRUE), erase=TRUE)
# 
#   ## screen(1)
#   plot.ts(series, cex=0.7, ylab=deparse(substitute(series)), ...)
#   screen(2)
#   PlotGACF(series, lag.max=lag.max, cex=0.7)
# 
#   screen(3)
#   # Stamp only the last plot
#   options(opt)
#   PlotGACF(series, lag.max=lag.max, type="part", cex=0.7)
#   close.screen(all.screens=TRUE)
# 
#   invisible(par(old.par))
# 
# }


PlotACF <- function (series, lag.max = 10 * log10(length(series)), main=NULL, 
                     cex=NULL, ...) {
  
  ## Purpose:  time series plot with correlograms
  #  Original name: f.acf
  
  ## ---
  ## Arguments: series : time series
  ##           lag.max : the maximum number of lags for the correlograms
  
  
  ## ---
  ## Author: Markus Huerzeler, Date: 15 Jun 94
  ## Revision: Christian Keller, 5 May 98
  ## Revision: Markus Huerzeler, 11. Maerz 04
  
  if(is.null(main)) 
    main <- deparse(substitute(series))
  
  if(main != "")
    par(oma=c(0,0,3,0))
  
  if(is.null(cex))
    cex <- par("cex")
  
  # the stamp option should only be active for the third plot, so deactivate it here
  opt <- DescToolsOptions(stamp = NULL)
  
  if (!is.null(dim(series))) 
    stop("f.acf is only implemented for univariate time series")
  
  par(mfrow = c(1, 1))
  
  old.par <- par(mar = c(3, 4, 1+2*(main != ""), 1), mgp = c(2.5, 1, 0), 
                 cex=cex)
  on.exit(par(old.par))
  
  split.screen(figs = matrix(c(0, 1, 0.33, 1, 0, 0.5, 0, 0.33, 
                               0.5, 1, 0, 0.33), ncol = 4, byrow = TRUE), erase = TRUE)
  
  plot.ts(series, cex = cex, ylab="", xlab="", main=main, ...)
  
  
  screen(2)
  par(mar = c(4, 4, 0, 1), mgp = c(2.5, 1, 0))
  PlotGACF(series, lag.max = lag.max, cex = cex, ...)
  
  screen(3)
  par(mar = c(4, 4, 0, 1), mgp = c(2.5, 1, 0))
  options(opt)
  PlotGACF(series, lag.max = lag.max, type = "part", 
           cex = cex, ...)
  close.screen(all.screens = TRUE)
  
  invisible(par(old.par))
  
}



PlotGACF <- function(series, lag.max=10*log10(length(series)), type="cor", ylab=NULL, ...) {

  ## Author: Markus Huerzeler, Date:  6 Jun 94
  ## Revision: Christian Keller, 27 Nov 98
  ## Revision: Markus Huerzeler, 11 Mar 02
  ## Correction for axis labels with ts-objects and deletion of ACF(0), Andri/10.01.2014

  # original name g.plot.acf
  # erg <- acf(series, type=type, plot=FALSE, lag.max=lag.max, na.action=na.omit)

  # debug:  series <- AirPassengers
  type <- match.arg(type, c("cor","cov","part"))

  erg <- acf(na.omit(series), type=type, plot=FALSE, lag.max=lag.max)

  erg.acf <- erg$acf
  # set the first acf(0) = 1 to 0
  if(type=="cor") {
    erg.acf[1] <- 0
    if(is.null(ylab)) ylab <- "ACF"
  }
  if(type=="part") {
    # add a 0-value to the partial corr. fct.
    erg.acf <- c(0, erg.acf)
    if(is.null(ylab)) ylab <- "PACF"
  }

  erg.konf <- 2/sqrt(erg$n.used)
  yli <- range(c(erg.acf, erg.konf, -erg.konf))*c(1.1, 1.1)
  # old: erg.lag <- as.vector(erg$lag)
  # new: get rid of the phases and use lags even with timeseries
  erg.lag <- seq_along(erg.acf)-1

  ## Labels fuer x-Achse definieren:
  ## 1. Label ist immer erg.lag[1]
  pos <- pretty(c(0, erg.lag))
  n <- length(pos)
  d <- pos[2] - pos[1] ; f <- pos[1]-erg.lag[1]
  pos <- c(erg.lag[1], pos[1][f > d/2], pos[2:n])

  plot(erg.lag, erg.acf, type="h", ylim=yli, xlab="Lag k", ylab=ylab,
       xaxt="n", xlim=c(0,length(erg.acf)), ...)
  axis(1, at=pos, ...)
  abline(0,0)
  abline(h=c(erg.konf, - erg.konf), lty=2, col="blue")

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

  invisible()
}


PlotMonth <- function(x, type = "l", labels, xlab = "", ylab = deparse(substitute(x)), ...)
#--
# Funktion fuer univariate Zeitreihen, zeichnet die Monats- oder Saisoneffekte
#
# von S+5 uebernommen und an R angepasst
#
# x muss eine univariate Zeitreihe sein
#--

{
  if(length(dim(x)))
    stop("This implementation is only for univariate time series")
  old.opts <- options(warn = -1)

  on.exit(options(old.opts))

  if(!(type == "l" || type == "h"))
    stop(paste("type is \"", type, "\", it must be \"l\" or \"h\"",
               sep = ""))

  f <- frequency(x)
  cx <- cycle(x)
  m <- tapply(x, cx, mean)
  if(cx[1] != 1 || cx[length(x)] != f) {
    x <- ts(c(rep(NA, cx[1] - 1), x, rep(NA, f - cx[length(x)])),
            start = start(x, format = TRUE)[1], end = c(end(x, format
                                                         = TRUE)[1], f), frequency = f)
    cx <- cycle(x)
  }
  i <- order(cx)
  n <- length(x)
  if(missing(labels))
    labels <- if(f == 12) c("Jan", "Feb", "Mar", "Apr", "May",
                            "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"
    ) else if(f == 4)
      c("First", "Second", "Third", "Fourth")
  else 1:f
  if(length(labels) != f)
    stop(paste("There must be", f, "labels"))
  p <- n/f
  hx <- seq(1, n, by = p) + (0:(f - 1))
  hy <- rep(m, rep(2, length(m)))
  X <- as.vector(outer(0:(p - 1), hx, "+"))
  plot(c(1, n + f), range(x[!is.na(x)]), type = "n", axes = F, xlab =
         xlab, ylab = ylab, ...)
  dotdot <- list(...)
  ddttl <- match(c("main", "sub", "axes", "ylim"), names(dotdot), nomatch
                 = 0)
  ddttl <- ddttl[ddttl != 0]
  add.axes <- TRUE
  if(length(ddttl)) {
    if(any(names(dotdot) == "axes"))
      add.axes <- dotdot$axes
    dotdot <- dotdot[ - ddttl]
  }
  if(type == "l")
    for(j in 1:f)
      do.call("lines", c(list(hx[j]:(hx[j] + p - 1), x[i][
        ((j - 1) * p + 1):(j * p)]), dotdot))
  else if(type == "h")
    do.call("segments", c(list(X, x[i], X, m[cx][i]), dotdot))
  do.call("segments", c(list(hx, m, hx + p, m), dotdot))
  if(add.axes) {
    box()
    axis(2)
    axis(1, at = hx + p/2, labels = labels)
  }

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

  invisible()
}



PlotQQ <- function(x, qdist=qnorm, main=NULL, xlab=NULL, ylab=NULL, datax=FALSE, add=FALSE,
                   args.qqline=NULL, conf.level=0.95, args.cband = NULL, ...) {

  # qqplot for an optional distribution

  # example:
  # y <- rexp(100, 1/10)
  # PlotQQ(y, function(p) qexp(p, rate=1/10))

  y <- sort(x)
  p <- ppoints(y)
  x <- qdist(p)

  if(datax){
    xy <- x
    x <- y
    y <- xy
    rm(xy)
  }

  if(is.null(main)) main <- gettextf("Q-Q-Plot (%s)", deparse(substitute(qdist)))
  if(is.null(xlab)) xlab <- "Theoretical Quantiles"
  if(is.null(ylab)) ylab <- "Sample Quantiles"

  if(!add)
     plot(x=x, y, main=main, xlab=xlab, ylab=ylab, type="n", ...)

  # add confidence band if desired
  if (!(is.na(conf.level) || identical(args.cband, NA)) ) {

    # cix <- qdist(ppoints(x))
    # ciy <- replicate(1000, sort(qdist(runif(length(x)))))
    # ci <- apply(ciy, 1, quantile, c(-1, 1) * conf.level/2 + 0.5)

    args.cband1 <- list(col = SetAlpha(Pal()[1], 0.25), border = NA)
    if (!is.null(args.cband))
      args.cband1[names(args.cband)] <- args.cband

    # (x, distribution = qnorm,
    #  conf = 0.95, conf.method = "both",
    #  reference.line.method = "quartiles") {

    # ci <- DescTools:::create.qqplot.fit.confidence.interval(
    #   x, distribution =  function(p) qexp(p, rate=1/10));

    ci <- create.qqplot.fit.confidence.interval(y,
              distribution = qdist, conf=conf.level, conf.method = "pointwise");

    do.call("DrawBand", c(args.cband1,
                          list(x = c(ci$z, rev(ci$z))),
                          list(y = c(ci$upper.pw, rev(ci$lower.pw)) )
                          ))

  }

  points(x=x, y=y, ...)

# John Fox implements an envelope option in car::qqplot, in the sense of:
#   (unfortunately using ddist...)
#
#   # add qqline if desired
#   if(!identical(args.band, NA)) {
#     n <- length(x)
#     zz <- qnorm(1 - (1 - args.band$conf.level) / 2)
#     SE <- (slope / d.function(z, ...)) * sqrt(p * (1 - p) / n)
#     fit.value <- int + slope * z
#
#     upper <- fit.value + zz * SE
#     lower <- fit.value - zz * SE
#
#     lines(z, upper, lty = 2, lwd = lwd, col = col.lines)
#     lines(z, lower, lty = 2, lwd = lwd, col = col.lines)
#   }

  # example in qqplot
  #
  # ## "QQ-Chisquare" : --------------------------
  # y <- rchisq(500, df = 3)
  # ## Q-Q plot for Chi^2 data against true theoretical distribution:
  # qqplot(qchisq(ppoints(500), df = 3), y,
  #        main = expression("Q-Q plot for" ~~ {chi^2}[nu == 3]))
  # qqline(y, distribution = function(p) qchisq(p, df = 3),
  #        prob = c(0.1, 0.6), col = 2)
  # mtext("qqline(*, dist = qchisq(., df=3), prob = c(0.1, 0.6))")


  # add qqline if desired
  if(!identical(args.qqline, NA)) {

    # define default arguments for ci.band
    args.qqline1 <- list(probs = c(0.25, 0.75), qtype=7, col=par("fg"), lwd=par("lwd"), lty=par("lty"))
    # override default arguments with user defined ones
    if (!is.null(args.qqline)) args.qqline1[names(args.qqline)] <- args.qqline

    # estimate qqline, instead of set it to abline(a = 0, b = 1)
    # plot qqline through the 25% and 75% quantiles (same as qqline does for normal dist)
    ly <- quantile(y, prob=args.qqline1[["probs"]], type=args.qqline1[["qtype"]], na.rm = TRUE)
    lx <- qdist(args.qqline1[["probs"]])

    slope <- diff(ly) / diff(lx)
    int <- ly[1L] - slope * lx[1L]
    do.call("abline", c(args.qqline1[c("col","lwd","lty")], list(a=int, b=slope)) )

  }

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

}



PlotPairs <- function(x, g=NULL, col=1, pch=19, col.smooth=1, main="", 
                      upper=FALSE, ...){
  

  # PlotPairs(x=ModTools::d.pima2[, -9], g=ModTools::d.pima2$diabetes, col=DescTools::SetAlpha(c(hred, hblue), 0.5), 
  #           col.smooth=c("black", hred, hblue),
  #           main="Relationships between potential diabetes predictors")
  
  
  panel.cor <- function(x, y, ...) {
    
    par(usr = c(0, 1, 0, 1)) 
    txt <- as.character(format(cor(x, y, use = "p"), digits=2)) 
    cc <- seq(0.8, 2.8, 0.2)[cut(abs(cor(x, y, use = "p")), seq(0,1,0.1))]
    text(0.5, 0.5, txt, cex = cc) 
  }
  
  
  panel.hist <- function(x, ...) { 
    b <- hist(x, plot=FALSE) 
    par(usr = c(par("usr")[1:2], 0, max(pretty(b$density))*1.3)) 
    hist(x, prob=TRUE, add=TRUE, col=SetAlpha(DescTools::hecru, 0.6), border=hecru) 
  }
  
  
  panel.smooth <- function (x, y, g=NULL, col = par("col"), bg = NA, pch = par("pch"), 
                            cex = 1, col.smooth = "red", span = 2/3, iter = 3, 
                            ...) {
    
    points(x, y, pch = pch, col = col, bg = bg, cex = cex)
    ok <- is.finite(x) & is.finite(y)
    if (any(ok)) {
      lines(stats::lowess(x[ok], y[ok], f = span, iter = iter), 
            col = col.smooth, ...)
      if(!is.null(g)){
        g <- factor(g)
        col.smooth <- rep(col.smooth, length_out=nlevels(g) + 1)[-1]
        for(l in levels(g)){
          lines(stats::lowess(x[ok][g[ok]==l], y[ok][g[ok]==l], f = span, iter = iter), 
                col = col.smooth[match(l, levels(g))], ...)
        }
      }
    }
  }
  
  
  if(upper){
    
    pairs(x, upper.panel=panel.cor,
          main=main, 
          pch=pch, col=col[g], cex=0.9, 
          diag.panel=panel.hist,
          panel = function(...) 
            panel.smooth(col.smooth=col.smooth, g=g, lwd=2, ...) )
  } else {
    pairs(x, lower.panel=panel.cor,
          main=main, 
          pch=pch, col=col[g], cex=0.9, 
          diag.panel=panel.hist,
          panel = function(...) 
            panel.smooth(col.smooth=col.smooth, g=g, lwd=2, ...) )
    
  }
  

}




## Describe  ====




Flags <- function(x, na.rm=FALSE){
  res <- x[, sapply(x, IsDichotomous, na.rm=TRUE)]
  class(res) <- "flags"
  return(res)
}




PlotMosaic <- function (x, main = deparse(substitute(x)), horiz = TRUE, cols = NULL,
                        off = 0.02, mar = NULL, xlab = NULL, ylab = NULL, cex=par("cex"), las=2, ...) {

  if(length(dim(x))>2){
    warning("PlotMosaic is restricted to max. 2 dimensions")
    invisible()
  }


  if (is.null(xlab))
    xlab <- Coalesce(names(dimnames(x)[2]), "x")
  if (is.null(ylab))
    ylab <- Coalesce(names(dimnames(x)[1]), "y")
  if (is.null(mar)){
    # ymar <- 5.1
    # xmar <- 6.1

    inches_to_lines <- (par("mar") / par("mai") )[1]  # 5
    lab.width <- max(strwidth(colnames(x), units="inches")) * inches_to_lines
    xmar <- lab.width + 1
    lab.width <- max(strwidth(rownames(x), units="inches")) * inches_to_lines
    ymar <- lab.width + 1

    mar <- c(ifelse(is.na(xlab), 2.1, 5.1), ifelse(is.na(ylab), ymar, ymar+2),
             ifelse(is.na(main), xmar, xmar+4), 1.6)

    # par(mai = c(par("mai")[1], max(par("mai")[2], strwidth(levels(grp), "inch")) +
    #               0.5, par("mai")[3], par("mai")[4]))

  }

  Canvas(xlim = c(0, 1), ylim = c(0, 1), asp = NA, mar = mar)

  col1 <- Pal()[1]
  col2 <- Pal()[2]

  oldpar <- par(xpd = TRUE)
  on.exit(par(oldpar))


  if(any(dim(x)==1)) {

    if (is.null(cols))
      cols <- colorRampPalette(c(col1, "white", col2), space = "rgb")(length(x))


    if(horiz){

      ptab <- prop.table(as.vector(x))
      pxt <- ptab * (1 - (length(ptab) - 1) * off)

      y_from <- c(0, cumsum(pxt) + (1:(length(ptab))) * off)[-length(ptab) - 1]
      y_to <- cumsum(pxt) + (0:(length(ptab) - 1)) * off

      if(nrow(x) > ncol(x))
        x <- t(x)

      x_from <- y_from
      x_to <- y_to

      y_from <- 0
      y_to <- 1


    } else {

      ptab <- rev(prop.table(as.vector(x)))
      pxt <- ptab * (1 - (length(ptab) - 1) * off)

      y_from <- c(0, cumsum(pxt) + (1:(length(ptab))) * off)[-length(ptab) - 1]
      y_to <- cumsum(pxt) + (0:(length(ptab) - 1)) * off


      x_from <- 0
      x_to <- 1

      if(ncol(x) > nrow(x))
        x <- t(x)

    }

    rect(xleft = x_from, ybottom = y_from, xright = x_to, ytop = y_to, col = cols)

    txt_y <- apply(cbind(y_from, y_to), 1, mean)
    txt_x <-  Midx(c(x_from, 1))

  } else {

    if (horiz) {

      if (is.null(cols))
        cols <- colorRampPalette(c(col1, "white", col2), space = "rgb")(ncol(x))

      ptab <- Rev(prop.table(x, 1), margin = 1)
      ptab <- ptab * (1 - (ncol(ptab) - 1) * off)
      pxt <- Rev(prop.table(margin.table(x, 1)) * (1 - (nrow(x) - 1) * off))

      y_from <- c(0, cumsum(pxt) + (1:(nrow(x))) * off)[-nrow(x) - 1]
      y_to <- cumsum(pxt) + (0:(nrow(x) - 1)) * off

      x_from <- t((apply(cbind(0, ptab), 1, cumsum) + (0:ncol(ptab)) * off)[-(ncol(ptab) + 1), ])
      x_to <- t((apply(ptab, 1, cumsum) + (0:(ncol(ptab) - 1) * off))[-(ncol(ptab) + 1), ])

      for (j in 1:nrow(ptab)) {
        rect(xleft = x_from[j,], ybottom = y_from[j],
             xright = x_to[j,], ytop = y_to[j], col = cols)
      }

      txt_y <- apply(cbind(y_from, y_to), 1, mean)
      txt_x <- apply(cbind(x_from[nrow(x_from),], x_to[nrow(x_from),]), 1, mean)

      # srt.x <- if (las > 1) 90  else 0
      # srt.y <- if (las == 0 || las == 3) 90 else 0
      #
      # text(labels = Rev(rownames(x)), y = txt_y, x = -0.04, adj = ifelse(srt.y==90, 0.5, 1), cex=cex, srt=srt.y)
      # text(labels = colnames(x), x = txt_x, y = 1.04, adj = ifelse(srt.x==90, 0, 0.5), cex=cex, srt=srt.x)

    } else {

      if (is.null(cols))
        cols <- colorRampPalette(c(col1, "white", col2), space = "rgb")(nrow(x))

      ptab <- Rev(prop.table(x, 2), margin = 1)
      ptab <- ptab * (1 - (nrow(ptab) - 1) * off)
      pxt <- (prop.table(margin.table(x, 2)) * (1 - (ncol(x) - 1) * off))

      x_from <- c(0, cumsum(pxt) + (1:(ncol(x))) * off)[-ncol(x) - 1]
      x_to <- cumsum(pxt) + (0:(ncol(x) - 1)) * off

      y_from <- (apply(rbind(0, ptab), 2, cumsum) + (0:nrow(ptab)) *
                 off)[-(nrow(ptab) + 1), ]
      y_to <- (apply(ptab, 2, cumsum) + (0:(nrow(ptab) - 1) *
                                         off))[-(nrow(ptab) + 1), ]

      for (j in 1:ncol(ptab)) {
        rect(xleft = x_from[j], ybottom = y_from[, j], xright = x_to[j],
             ytop = y_to[, j], col = cols)
      }

      txt_y <- apply(cbind(y_from[, 1], y_to[, 1]), 1, mean)
      txt_x <- apply(cbind(x_from, x_to), 1, mean)

      # srt.x <- if (las > 1) 90  else 0
      # srt.y <- if (las == 0 || las == 3) 90 else 0
      #
      # text(labels = Rev(rownames(x)), y = txt_y, x = -0.04, adj = ifelse(srt.y==90, 0.5, 1), cex=cex, srt=srt.y)
      # text(labels = colnames(x), x = txt_x, y = 1.04, adj = ifelse(srt.x==90, 0, 0.5), cex=cex, srt=srt.x)

    }
  }

  srt.x <- if (las > 1) 90  else 0
  srt.y <- if (las == 0 || las == 3) 90 else 0

  text(labels = Rev(rownames(x)), y = txt_y, x = -0.04, adj = ifelse(srt.y==90, 0.5, 1), cex=cex, srt=srt.y)
  text(labels = colnames(x), x = txt_x, y = 1.04, adj = ifelse(srt.x==90, 0, 0.5), cex=cex, srt=srt.x)


  if (!is.na(main)) {
    usr <- par("usr")
    plt <- par("plt")
    ym <- usr[4] + diff(usr[3:4])/diff(plt[3:4])*(plt[3]) + (1.2 + is.na(xlab)*4) * strheight('m', cex=1.2, font=2)

    text(x=0.5, y=ym, labels = main, cex=1.2, font=2)
  }


  if (!is.na(xlab)) title(xlab = xlab, line = 1)
  if (!is.na(ylab)) title(ylab = ylab)

  if(!is.null(DescToolsOptions("stamp")))
    Stamp()

  invisible(list(x = txt_x, y = txt_y))

}




###

# see also package Mosaic
# modelVars extract predictor variables from a model


ParseFormula <- function(formula, data=parent.frame(), drop = TRUE) {

  xhs <- function(formula, data = parent.frame(), na.action=na.pass){

    # get all variables out of the formula
    vars <- attr(terms(formula, data=data), "term.labels")

    # evaluate model.frame
    mf <- match.call(expand.dots = FALSE)
    m <- match(c("formula", "data", "na.action"), names(mf), 0)
    mf <- mf[c(1, m)]
    mf$na.action <- na.action
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")

    mf.rhs <- eval.parent(mf)

    # model frame does not evaluate interaction, so let's do that here
    d.tmp <- mf.rhs[,FALSE] # create a new data.frame
    for(x in vars){
      if( length(grep(":", x))>0 )      # there's a : in the variable
        d.tmp <- data.frame(d.tmp,
                            interaction( mf.rhs[, names(mf.rhs)[names(mf.rhs) %in% unlist(strsplit(x, ":"))]],
                                         sep=":", drop = drop)      # set drop unused levels to TRUE here by default
        )
      else
        d.tmp <- data.frame(d.tmp, mf.rhs[,x])
    }
    names(d.tmp) <- vars

    return(list(formula=formula, mf=mf.rhs, mf.eval=d.tmp, vars=vars))
  }

  f1 <- formula

  # evaluate subset
  m <- match.call(expand.dots = FALSE)


  if(length(f1)==2L){
    rhs <- xhs(formula(paste("~", deparse(f1[[2]])), data=data), data=data)
    lhs <- list(mf=NA, mf.eval=NA, vars=NA)
    
  } else {
    
    # do not support . on both sides of the formula
    if( (length(grep("^\\.$", all.vars(f1[[2]])))>0) && (length(grep("^\\.$", all.vars(f1[[3]])))>0) )
      stop("dot argument on both sides of the formula are not supported")
    
    # swap left and right hand side and take just the right side
    # so both sides are evaluated with right side logic, but independently
    lhs <- xhs(formula(paste("~", deparse(f1[[2]])), data=data), data=data)
    rhs <- xhs(formula(paste("~", deparse(f1[[3]])), data=data), data=data)
  
    # now handle the dot argument
    if(any(all.vars(f1[[2]]) == ".")){   # dot on the left side
      lhs$vars <- lhs$vars[!lhs$vars %in% rhs$vars]
      lhs$mf <- lhs$mf[lhs$vars]
      lhs$mf.eval <- lhs$mf.eval[lhs$vars]
    } else if(any(all.vars(f1[[3]]) == ".")){     # dot on the right side
      rhs$vars <- rhs$vars[!rhs$vars %in% lhs$vars]
      rhs$mf <- rhs$mf[rhs$vars]
      rhs$mf.eval <- rhs$mf.eval[rhs$vars]
    } else {    # no dot: do nothing
    }
    
  }

  list(formula=formula, lhs=list(mf=lhs$mf, mf.eval=lhs$mf.eval, vars=lhs$vars),
       rhs=list(mf=rhs$mf, mf.eval=rhs$mf.eval, vars=rhs$vars))

}




###


## Word fundamentals  ====



.WrdPrepRep <- function(wrd, main="Bericht" ){

  # only internal user out from GetNewWrd()
  # creates new word instance and prepares document for report

  # constants
  # wdPageBreak <- 7
  # wdSeekCurrentPageHeader <- 9  ### Kopfzeile
  # wdSeekCurrentPageFooter <- 10	### Fusszeile
  # wdSeekMainDocument <- 0
  # wdPageFitBestFit <- 2
  # wdFieldEmpty <- -1

  # Show DocumentMap
  wrd[["ActiveWindow"]][["DocumentMap"]] <- TRUE
  wrdWind <- wrd[["ActiveWindow"]][["ActivePane"]][["View"]][["Zoom"]]
  wrdWind[["PageFit"]] <- wdConst$wdPageFitBestFit

  wrd[["Selection"]]$TypeParagraph()
  wrd[["Selection"]]$TypeParagraph()

  wrd[["Selection"]]$WholeStory()
  # 15.1.2012 auskommentiert: WrdSetFont(wrd=wrd)

  # Idee: ueberschrift definieren (geht aber nicht!)
  #wrd[["ActiveDocument"]][["Styles"]]$Item("ueberschrift 2")[["Font"]][["Name"]] <- "Consolas"
  #wrd[["ActiveDocument"]][["Styles"]]$Item("ueberschrift 2")[["Font"]][["Size"]] <- 10
  #wrd[["ActiveDocument"]][["Styles"]]$Item("ueberschrift 2")[["Font"]][["Bold"]] <- TRUE

  #wrd[["ActiveDocument"]][["Styles"]]$Item("ueberschrift 2")[["ParagraphFormat"]]["Borders"]]$Item(wdBorderTop)[["LineStyle"]] <- wdConst$wdLineStyleSingle

  WrdCaption( main, wrd=wrd)
  wrd[["Selection"]]$TypeText(gettextf("%s/%s\n",format(Sys.time(), "%d.%m.%Y"), Sys.getenv("username")))
  wrd[["Selection"]]$InsertBreak( wdConst$wdPageBreak)

  # Inhaltsverzeichnis einfuegen ***************
  wrd[["ActiveDocument"]][["TablesOfContents"]]$Add( wrd[["Selection"]][["Range"]] )
  # Original VB-Code:
  # With ActiveDocument
  # .TablesOfContents.Add Range:=Selection.Range, RightAlignPageNumbers:= _
  # True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _
  # LowerHeadingLevel:=2, IncludePageNumbers:=True, AddedStyles:="", _
  # UseHyperlinks:=True, HidePageNumbersInWeb:=True, UseOutlineLevels:= _
  # True
  # .TablesOfContents(1).TabLeader = wdTabLeaderDots
  # .TablesOfContents.Format = wdIndexIndent
  # End With

  # Fusszeile	***************
  wrdView <- wrd[["ActiveWindow"]][["ActivePane"]][["View"]]
  wrdView[["SeekView"]] <- wdConst$wdSeekCurrentPageFooter
  wrd[["Selection"]]$TypeText( gettextf("%s/%s\t\t",format(Sys.time(), "%d.%m.%Y"), Sys.getenv("username")) )
  wrd[["Selection"]][["Fields"]]$Add( wrd[["Selection"]][["Range"]], wdConst$wdFieldEmpty, "PAGE" )
  # Roland wollte das nicht (23.11.2014):
  # wrd[["Selection"]]$TypeText("\n\n")
  wrdView[["SeekView"]] <- wdConst$wdSeekMainDocument

  wrd[["Selection"]]$InsertBreak( wdConst$wdPageBreak)
  invisible()

}




# put that to an example...
# WrdPageBreak <- function( wrd = .lastWord ) {
#   wrd[["Selection"]]$InsertBreak(wdConst$wdPageBreak)
# }


ToWrd <- function(x, font=NULL, ..., wrd=DescToolsOptions("lastWord")){
    UseMethod("ToWrd")
}


# ToWrdB <- function(x, font = NULL, ..., wrd = DescToolsOptions("lastWord"), 
#                     bookmark=gettextf("b%s", sample(1e9, 1))){
#   
#   bm <- WrdInsertBookmark(name = bookmark, wrd=wrd)
#   ToWrd(x, font=font, ..., wrd=wrd)
#   
#   d <- wrd$Selection()$range()$start() - bm$range()$start()
#   wrd$Selection()$MoveLeft(Unit=wdConst$wdCharacter, Count=d, Extend=wdConst$wdExtend)
#   
#   bm <- WrdInsertBookmark(name = bookmark, wrd=wrd)
#   
#   wrd[["Selection"]]$Collapse(Direction=wdConst$wdCollapseEnd)
#   
#   invisible(bm)
#   
# }


# function to generate random bookmark names 
# (ensure we'll always get 9 digits with min=0.1)
.randbm <- function() paste("bm", round(runif(1, min=0.1)*1e9), sep="")



ToWrdB <- function(x, font = NULL, ..., wrd = DescToolsOptions("lastWord"), 
                   bookmark=gettextf("bmt%s", round(runif(1, min=0.1)*1e9))){
  
  # Sends the output of an object x to word and places a bookmark bm on it
  
  # place the temporary bookmark on cursor
  bm_start <- WrdInsertBookmark(.randbm())
  
  # send stuff to Word (it's generic ...)
  ToWrd(x, font=font, ..., wrd=wrd)
  
  # place end bookmark
  bm_end <- WrdInsertBookmark(.randbm())
  
  # select all the inserted text between the two bookmarks
  wrd[["ActiveDocument"]]$Range(bm_start$range()$start(), bm_end$range()$end())$select()
  
  # place the required bookmark over the whole inserted story
  res <- WrdInsertBookmark(bookmark)
  
  # collapse selection to the end position
  wrd$selection()$collapse(wdConst$wdCollapseEnd)
  
  # delete the two temporary bookmarks start/end
  bm_start$delete()
  bm_end$delete()
  
  # return the bookmark with inserted story
  invisible(res)
  
}


ToWrdPlot <- function(plotcode,  
                      width=NULL, height=NULL, scale=100, pointsize=12, res=300, crop=0, title=NULL, 
                      wrd = DescToolsOptions("lastWord"), 
                      bookmark=gettextf("bmp%s", round(runif(1, min=0.1)*1e9))
                      ){
  
  if(is.null(width)) width <- 15
  if(is.null(height)) height <- width / gold_sec_c 

  crop <- rep(crop, length.out=4)
    
  if(is.null(bookmark)) bookmark <- .randbm()
  
  
  # open device
  tiff(filename = (fn <- paste(tempfile(), ".tif", sep = "")), 
       width = width, height = height, units = "cm", pointsize = pointsize,
       res = res, compression = "lzw")
  
  # do plot
  if(!is.null(plotcode ))
    eval(parse(text = plotcode))
  
  # close device
  dev.off()
  
  
  # import in word ***********
  # place the temporary bookmark on cursor
  bm_start <- WrdInsertBookmark(.randbm(), wrd=wrd)
  
  # send stuff to Word (it's generic ...)
  hwnd <- wrd$selection()$InlineShapes()$AddPicture(FileName=fn, LinkToFile=FALSE, SaveWithDocument=TRUE)
  hwnd[["LockAspectRatio"]] <- 1
  hwnd[["ScaleWidth"]] <- hwnd[["ScaleHeight"]] <- scale
  pic <- hwnd$PictureFormat()
  pic[["CropBottom"]] <- CmToPts(crop[1])
  pic[["CropLeft"]] <- CmToPts(crop[2])
  pic[["CropTop"]] <- CmToPts(crop[3])
  pic[["CropRight"]] <- CmToPts(crop[4])
  
  if(!is.null(title)){
    hwnd$select()
    wrd[["Selection"]]$InsertCaption(Label="Figure", Title=gettextf(" - %s", title), 
                       Position=wdConst$wdCaptionPositionBelow, ExcludeLabel=0)
    wrd[["Selection"]]$MoveRight(wdConst$wdCharacter, 1, 0)
    
  }
  
  
  ToWrd(x="\n", wrd=wrd)
  
  # place end bookmark
  bm_end <- WrdInsertBookmark(.randbm(), wrd=wrd)
  
  # select all the inserted text between the two bookmarks
  wrd[["ActiveDocument"]]$Range(bm_start$range()$start(), bm_end$range()$end())$select()
  
  # place the required bookmark over the whole inserted story
  res <- WrdInsertBookmark(bookmark, wrd=wrd)
  
  # collapse selection to the end position
  wrd$selection()$collapse(wdConst$wdCollapseEnd)
  
  # delete the two temporary bookmarks start/end
  bm_start$delete()
  bm_end$delete()
  
  # return the bookmark with inserted story
  invisible(list(plot_hwnd=hwnd, bookmark=res))
  
}







ToWrd.default <- function(x, font=NULL, ..., wrd=DescToolsOptions("lastWord")){

  ToWrd.character(x=.CaptOut(x), font=font, ..., wrd=wrd)
  invisible()

}



ToWrd.Desc <- function(x, font=NULL, ..., wrd=DescToolsOptions("lastWord")){
  
  printWrd(x, ..., wrd=wrd)
  invisible()
  
}




ToWrd.TOne <- function(x, font=NULL, para=NULL, main=NULL, align=NULL,
                       autofit=TRUE, ..., wrd=DescToolsOptions("lastWord")){

  wTab <- ToWrd.table(x, main=NULL, font=font, align=align, autofit=autofit, wrd=wrd, ...)

  if(!is.null(para)){
    wTab$Select()
    WrdParagraphFormat(wrd) <- para

    # move out of table
    wrd[["Selection"]]$EndOf(wdConst$wdTable)
    wrd[["Selection"]]$MoveRight(wdConst$wdCharacter, 2, 0)
  }

  if(is.null(font)) font <- list()
  if(is.null(font$size))
    font$size <- WrdFont(wrd)$size - 2
  else
    font$size <- font$size - 2

  wrd[["Selection"]]$TypeBackspace()
  ToWrd.character(paste("\n", attr(x, "legend"), "\n\n", sep=""),
        font=font, wrd=wrd)


  if(!is.null(main)){
    sel <- wrd$Selection()  # "Abbildung"
    sel$InsertCaption(Label=wdConst$wdCaptionTable, Title=paste(" - ", main, sep=""))
    sel$TypeParagraph()

  }

  invisible(wTab)

}



ToWrd.abstract <- function(x, font=NULL, autofit=TRUE, ..., wrd=DescToolsOptions("lastWord")){

  WrdCaption(x=attr(x, "main"), wrd=wrd)

  if(!is.null(attr(x, "label"))){

    if(is.null(font)){
      lblfont <- list(fontsize=8)
    } else {
      lblfont <- font
      lblfont$fontsize <- 8
    }

    ToWrd.character(paste("\n", attr(x, "label"), "\n", sep=""),
                    font = lblfont, wrd=wrd)
  }

  ToWrd.character(gettextf("\ndata.frame:	%s obs. of  %s variables (complete cases: %s / %s)\n\n",
                           attr(x, "nrow"), attr(x, "ncol"), attr(x, "complete"), Format(attr(x, "complete")/attr(x, "nrow"), fmt="%", digits=1))
                  , font=font, wrd=wrd)

  wTab <- ToWrd.data.frame(x, wrd=wrd, autofit=autofit, font=font, align="l", ...)

  invisible(wTab)

}



ToWrd.lm <- function(x, font=NULL, ..., wrd=DescToolsOptions("lastWord")){

  invisible()
}




ToWrd.character <- function (x, font = NULL, para = NULL, style = NULL, bullet=FALSE,  ..., wrd = DescToolsOptions("lastWord")) {

  # we will convert UTF-8 strings to Latin-1, if the local info is Latin-1
  if (any(l10n_info()[["Latin-1"]] & Encoding(x) == "UTF-8"))
    x[Encoding(x) == "UTF-8"] <- iconv(x[Encoding(x) == "UTF-8"], from = "UTF-8", to = "latin1")

  wrd[["Selection"]]$InsertAfter(paste(x, collapse = "\n"))

  if (!is.null(style))
    WrdStyle(wrd) <- style

  if (!is.null(para))
    WrdParagraphFormat(wrd) <- para


  if(identical(font, "fix")){
    font <- DescToolsOptions("fixedfont")
    if(is.null(font))
      font <- structure(list(name="Courier New", size=8), class="font")
  }

  if(!is.null(font)){
      currfont <- WrdFont(wrd)
      WrdFont(wrd) <- font
      on.exit(WrdFont(wrd) <- currfont)
    }

  if(bullet)
    wrd[["Selection"]]$Range()$ListFormat()$ApplyBulletDefault()

  wrd[["Selection"]]$Collapse(Direction=wdConst$wdCollapseEnd)

  invisible()

}


WrdCaption <- function(x, index = 1, wrd = DescToolsOptions("lastWord")){

  lst <- Recycle(x=x, index=index)
  x <-
    index <- lst[["index"]]
  for(i in seq(attr(lst, "maxdim")))
    ToWrd.character(paste(lst[["x"]][i], "\n", sep = ""),
                    style = eval(parse(text = gettextf("wdConst$wdStyleHeading%s", lst[["index"]][i]))))
  invisible()

}


ToWrd.PercTable <- function(x, font=NULL, main = NULL, ..., wrd = DescToolsOptions("lastWord")){
  ToWrd.ftable(x$ftab, font=font, main=main, ..., wrd=wrd)
}



ToWrd.data.frame <- function(x, font=NULL, main = NULL, row.names=NULL, ..., wrd = DescToolsOptions("lastWord")){

  # drops dimension names!! don't use here
  # x <- apply(x, 2, as.character)

  x[] <- lapply(x, as.character)
  x <- as.matrix(x)

  if(is.null(row.names))
    if(identical(row.names(x), as.character(1:nrow(x))))
      row.names <- FALSE
    else
      row.names <- TRUE

  ToWrd.table(x=x, font=font, main=main, row.names=row.names, ..., wrd=wrd)
}


# ToWrd.data.frame <- function(x, font=NULL, main = NULL, row.names=NULL, as.is=FALSE, ..., wrd = DescToolsOptions("lastWord")){
#
#   if(as.is)
#     x <- apply(x, 2, as.character)
#   else
#     x <- FixToTable(capture.output(x))
#
#   if(is.null(row.names))
#     if(identical(row.names, seq_along(1:nrow(x))))
#       row.names <- FALSE
#     else
#       row.names <- TRUE
#
#     if(row.names==TRUE)
#       x <- cbind(row.names(x), x)
#
#     ToWrd.table(x=x, font=font, main=main, ..., wrd=wrd)
# }


ToWrd.matrix <- function(x, font=NULL, main = NULL, ..., wrd = DescToolsOptions("lastWord")){
  ToWrd.table(x=x, font=font, main=main, ..., wrd=wrd)
}


ToWrd.Freq <- function(x, font=NULL, main = NULL, ..., wrd = DescToolsOptions("lastWord")){

  x[,c(3,5)] <- sapply(round(x[,c(3,5)], 3), Format, digits=3)

  res <- ToWrd.data.frame(x=x, main=main, font=font, wrd=wrd)

  invisible(res)

}




ToWrd.ftable <- function (x, font = NULL, main = NULL, align=NULL, method = "compact", ..., wrd = DescToolsOptions("lastWord")) {

  # simple version:
  #   x <- FixToTable(capture.output(x))
  #   ToWrd.character(x, font=font, main=main, ..., wrd=wrd)

  # let R do all the complicated formatting stuff
  # but we can't import a not exported function, so we provide an own copy of it

  # so this is a verbatim copy of it
  .format.ftable <- function (x, quote = TRUE, digits = getOption("digits"), method = c("non.compact",
                                                                      "row.compact", "col.compact", "compact"), lsep = " | ", ...)
  {
    if (!inherits(x, "ftable"))
      stop("'x' must be an \"ftable\" object")
    charQuote <- function(s) if (quote && length(s))
      paste0("\"", s, "\"")
    else s
    makeLabels <- function(lst) {
      lens <- lengths(lst)
      cplensU <- c(1, cumprod(lens))
      cplensD <- rev(c(1, cumprod(rev(lens))))
      y <- NULL
      for (i in rev(seq_along(lst))) {
        ind <- 1 + seq.int(from = 0, to = lens[i] - 1) *
          cplensD[i + 1L]
        tmp <- character(length = cplensD[i])
        tmp[ind] <- charQuote(lst[[i]])
        y <- cbind(rep(tmp, times = cplensU[i]), y)
      }
      y
    }
    makeNames <- function(x) {
      nmx <- names(x)
      if (is.null(nmx))
        rep_len("", length(x))
      else nmx
    }
    l.xrv <- length(xrv <- attr(x, "row.vars"))
    l.xcv <- length(xcv <- attr(x, "col.vars"))
    method <- match.arg(method)
    if (l.xrv == 0) {
      if (method == "col.compact")
        method <- "non.compact"
      else if (method == "compact")
        method <- "row.compact"
    }
    if (l.xcv == 0) {
      if (method == "row.compact")
        method <- "non.compact"
      else if (method == "compact")
        method <- "col.compact"
    }
    LABS <- switch(method, non.compact = {
      cbind(rbind(matrix("", nrow = length(xcv), ncol = length(xrv)),
                  charQuote(makeNames(xrv)), makeLabels(xrv)), c(charQuote(makeNames(xcv)),
                                                                 rep("", times = nrow(x) + 1)))
    }, row.compact = {
      cbind(rbind(matrix("", nrow = length(xcv) - 1, ncol = length(xrv)),
                  charQuote(makeNames(xrv)), makeLabels(xrv)), c(charQuote(makeNames(xcv)),
                                                                 rep("", times = nrow(x))))
    }, col.compact = {
      cbind(rbind(cbind(matrix("", nrow = length(xcv), ncol = length(xrv) -
                                 1), charQuote(makeNames(xcv))), charQuote(makeNames(xrv)),
                  makeLabels(xrv)))
    }, compact = {
      xrv.nms <- makeNames(xrv)
      xcv.nms <- makeNames(xcv)
      mat <- cbind(rbind(cbind(matrix("", nrow = l.xcv - 1,
                                      ncol = l.xrv - 1), charQuote(makeNames(xcv[-l.xcv]))),
                         charQuote(xrv.nms), makeLabels(xrv)))
      mat[l.xcv, l.xrv] <- paste(tail(xrv.nms, 1), tail(xcv.nms,
                                                        1), sep = lsep)
      mat
    }, stop("wrong method"))
    DATA <- rbind(if (length(xcv))
      t(makeLabels(xcv)), if (method %in% c("non.compact",
                                            "col.compact"))
        rep("", times = ncol(x)), format(unclass(x), digits = digits,
                                         ...))
    cbind(apply(LABS, 2L, format, justify = "left"), apply(DATA,
                                                           2L, format, justify = "right"))
  }


  tab <- .format.ftable(x, quote=FALSE, method=method, lsep="")
  tab <- StrTrim(tab)

  if(is.null(align))
    align <- c(rep("l", length(attr(x, "row.vars"))), rep("r", ncol(x)))

  wtab <- ToWrd.table(tab, font=font, main=main, align=align, ..., wrd=wrd)

  invisible(wtab)

}




ToWrd.table <- function (x, font = NULL, main = NULL, align=NULL, tablestyle=NULL, autofit = TRUE,
                              row.names=TRUE, col.names=TRUE, ..., wrd = DescToolsOptions("lastWord")) {


  x[] <- as.character(x)
  if (any(l10n_info()[["Latin-1"]] & Encoding(x) == "UTF-8"))
    x[Encoding(x) == "UTF-8"] <- iconv(x[Encoding(x) == "UTF-8"], from = "UTF-8", to = "latin1")

  # add column names to character table
  if(col.names)
    x <- rbind(colnames(x), x)
  if(row.names){
    rown <- rownames(x)
    # if(col.names)
    #   rown <- c("", rown)
    x <- cbind(rown, x)
  }
  # replace potential \n in table with /cr, as convertToTable would make a new cell for them
  x <- gsub(pattern= "\n", replacement = "/cr", x = x)
  # paste the cells and separate by \t
  txt <- paste(apply(x, 1, paste, collapse="\t"), collapse="\n")

  nc <- ncol(x)
  nr <- nrow(x)

  # insert and convert
  wrd[["Selection"]]$InsertAfter(txt)
  wrdTable <- wrd[["Selection"]]$ConvertToTable(Separator = wdConst$wdSeparateByTabs,
                                            NumColumns = nc,  NumRows = nr,
                                            AutoFitBehavior = wdConst$wdAutoFitFixed)

  wrdTable[["ApplyStyleHeadingRows"]] <- col.names

  # replace /cr by \n again in word
  wrd[["Selection"]][["Find"]]$ClearFormatting()
  wsel <- wrd[["Selection"]][["Find"]]
  wsel[["Text"]] <- "/cr"
  wrep <- wsel[["Replacement"]]
  wrep[["Text"]] <- "^l"
  wsel$Execute(Replace=wdConst$wdReplaceAll)


  # http://www.thedoctools.com/downloads/DocTools_List_Of_Built-in_Style_English_Danish_German_French.pdf
  if(is.null(tablestyle)){
    WrdTableBorders(wrdTable, from=c(1,1), to=c(1, nc),
                    border = wdConst$wdBorderTop)
    if(col.names)
      WrdTableBorders(wrdTable, from=c(1,1), to=c(1, nc),
                    border = wdConst$wdBorderBottom)

    WrdTableBorders(wrdTable, from=c(nr, 1), to=c(nr, nc),
                    border = wdConst$wdBorderBottom)

    space <- RoundTo((if(is.null(font$size)) WrdFont(wrd)$size else font$size) * .2, multiple = .5)
    wrdTable$Rows(1)$Select()
    WrdParagraphFormat(wrd) <- list(SpaceBefore=space, SpaceAfter=space)

    if(col.names){
      wrdTable$Rows(2)$Select()
      WrdParagraphFormat(wrd) <- list(SpaceBefore=space)
    }

    wrdTable$Rows(nr)$Select()
    WrdParagraphFormat(wrd) <- list(SpaceAfter=space)

    # wrdTable[["Style"]] <- -115 # code for "Tabelle Klassisch 1"
  } else
    if(!is.na(tablestyle))
      wrdTable[["Style"]] <- tablestyle


  # align the columns
  if(is.null(align))
    align <- c(rep("l", row.names), rep(x = "r", nc-row.names))
  else
    align <- rep(align, length.out=nc)

  align[align=="l"] <- wdConst$wdAlignParagraphLeft
  align[align=="c"] <- wdConst$wdAlignParagraphCenter
  align[align=="r"] <- wdConst$wdAlignParagraphRight

  for(i in seq_along(align)){
    wrdTable$Columns(i)$Select()
    wrdSel <- wrd[["Selection"]]
    wrdSel[["ParagraphFormat"]][["Alignment"]] <- align[i]
  }

  if(!is.null(font)){
    wrdTable$Select()
    WrdFont(wrd) <- font
  }

  if(autofit)
    wrdTable$Columns()$AutoFit()


  # this will get us out of the table and put the text cursor directly behind it
  wrdTable$Select()
  wrd[["Selection"]]$Collapse(wdConst$wdCollapseEnd)

  # instead of coarsely moving to the end of the document ...
  # Selection.GoTo What:=wdGoToPercent, Which:=wdGoToLast
  # wrd[["Selection"]]$GoTo(What = wdConst$wdGoToPercent, Which= wdConst$wdGoToLast)

  if(!is.null(main)){
    # insert caption
    sel <- wrd$Selection()  
    sel$InsertCaption(Label=wdConst$wdCaptionTable, Title=paste(" - ", main, sep=""))
    sel$TypeParagraph()

  }

  wrd[["Selection"]]$TypeParagraph()

  invisible(wrdTable)

}




WrdTableBorders <- function (wtab, from = NULL, to = NULL, border = NULL,
                              lty = wdConst$wdLineStyleSingle, col=wdConst$wdColorBlack,
                              lwd = wdConst$wdLineWidth050pt) {
  # paint borders of a table

  if(is.null(from))
    from <- c(1,1)

  if(is.null(to))
    to <- c(wtab[["Rows"]]$Count(), wtab[["Columns"]]$Count())

  wrd <- wtab[["Application"]]
  rng <- wrd[["ActiveDocument"]]$Range(start=wtab$Cell(from[1], from[2])[["Range"]][["Start"]],
                                       end=wtab$Cell(to[1], to[2])[["Range"]][["End"]])

  rng$Select()

  if(is.null(border))
    # use all borders by default
    border <- wdConst[c("wdBorderTop","wdBorderBottom","wdBorderLeft","wdBorderRight",
                        "wdBorderHorizontal","wdBorderVertical")]

  for(b in border){
    wborder <- wrd[["Selection"]]$Borders(b)
    wborder[["LineStyle"]] <- lty
    wborder[["Color"]] <- col
    wborder[["LineWidth"]] <- lwd
  }

  invisible()
}






WrdCellRange <- function(wtab, from, to) {
  # returns a handle for the table range
  wtrange <- wtab[["Parent"]]$Range(
    wtab$Cell(from[1], from[2])[["Range"]][["Start"]],
    wtab$Cell(to[1], to[2])[["Range"]][["End"]]
  )

  return(wtrange)
}


WrdMergeCells <- function(wtab, rstart, rend) {

  rng <- WrdCellRange(wtab, rstart, rend)
  rng[["Cells"]]$Merge()

}

WrdFormatCells <- function(wtab, rstart, rend, col=NULL, bg=NULL, font=NULL,
                           border=NULL, align=NULL){


  rng <- WrdCellRange(wtab, rstart, rend)
  shad <- rng[["Shading"]]

  if (!is.null(col))
    shad[["ForegroundPatternColor"]] <- col

  if (!is.null(bg))
    shad[["BackgroundPatternColor"]] <- bg

  wrdFont <- rng[["Font"]]
  if (!is.null(font$name))
    wrdFont[["Name"]] <- font$name
  if (!is.null(font$size))
    wrdFont[["Size"]] <- font$size
  if (!is.null(font$bold))
    wrdFont[["Bold"]] <- font$bold
  if (!is.null(font$italic))
    wrdFont[["Italic"]] <- font$italic
  if (!is.null(font$color))
    wrdFont[["Color"]] <- font$color

  if (!is.null(align)) {
    align <- match.arg(align, choices = c("l", "c", "r"))
    align <- unlist(wdConst[c("wdAlignParagraphLeft",
                              "wdAlignParagraphCenter",
                              "wdAlignParagraphRight")])[match(x=align, table= c("l", "c", "r"))]

    rng[["ParagraphFormat"]][["Alignment"]] <- align
  }

  if(!is.null(border)) {
    if(identical(border, TRUE))
      # set default values
      border <- list(border=c(wdConst$wdBorderBottom,
                              wdConst$wdBorderLeft,
                              wdConst$wdBorderTop,
                              wdConst$wdBorderRight),
                     linestyle=wdConst$wdLineStyleSingle,
                     linewidth=wdConst$wdLineWidth025pt,
                     color=wdConst$wdColorBlack)

    if(is.null(border$border))
      border$border <- c(wdConst$wdBorderBottom,
                         wdConst$wdBorderLeft,
                         wdConst$wdBorderTop,
                         wdConst$wdBorderRight)

    if(is.null(border$linestyle))
      border$linestyle <- wdConst$wdLineStyleSingle

    border <- do.call(Recycle, border)

    for(i in 1:attr(border, which = "maxdim")) {
      b <- rng[["Borders"]]$Item(border$border[i])

      if(!is.null(border$linestyle[i]))
        b[["LineStyle"]] <- border$linestyle[i]

      if(!is.null(border$linewidth[i]))
        b[["LineWidth"]] <- border$linewidth[i]

      if(!is.null(border$color))
        b[["Color"]] <- border$color[i]
    }
  }

}





# Get and set font

WrdFont <- function(wrd = DescToolsOptions("lastWord") ) {
  # returns the font object list: list(name, size, bold, italic) on the current position

  wrdSel <- wrd[["Selection"]]
  wrdFont <- wrdSel[["Font"]]

  currfont <- list(
    name = wrdFont[["Name"]] ,
    size = wrdFont[["Size"]] ,
    bold = wrdFont[["Bold"]] ,
    italic = wrdFont[["Italic"]],
    color = setNames(wrdFont[["Color"]], names(which(
      wdConst==wrdFont[["Color"]] & grepl("wdColor", names(wdConst)))))
  )

  class(currfont) <- "font"
  return(currfont)
}


`WrdFont<-` <- function(wrd, value){

  wrdSel <- wrd[["Selection"]]
  wrdFont <- wrdSel[["Font"]]

  # set the new font
  if(!is.null(value$name)) wrdFont[["Name"]] <- value$name
  if(!is.null(value$size)) wrdFont[["Size"]] <- value$size
  if(!is.null(value$bold)) wrdFont[["Bold"]] <- value$bold
  if(!is.null(value$italic)) wrdFont[["Italic"]] <- value$italic
  if(!is.null(value$color)) wrdFont[["Color"]] <- value$color

  return(wrd)
}



# Get and set ParagraphFormat

WrdParagraphFormat <- function(wrd = DescToolsOptions("lastWord") ) {

  wrdPar <- wrd[["Selection"]][["ParagraphFormat"]]

  currpar <- list(
    LeftIndent               =wrdPar[["LeftIndent"]] ,
    RightIndent              =wrdPar[["RightIndent"]] ,
    SpaceBefore              =wrdPar[["SpaceBefore"]] ,
    SpaceBeforeAuto          =wrdPar[["SpaceBeforeAuto"]] ,
    SpaceAfter               =wrdPar[["SpaceAfter"]] ,
    SpaceAfterAuto           =wrdPar[["SpaceAfterAuto"]] ,
    LineSpacingRule          =wrdPar[["LineSpacingRule"]],
    Alignment                =wrdPar[["Alignment"]],
    WidowControl             =wrdPar[["WidowControl"]],
    KeepWithNext             =wrdPar[["KeepWithNext"]],
    KeepTogether             =wrdPar[["KeepTogether"]],
    PageBreakBefore          =wrdPar[["PageBreakBefore"]],
    NoLineNumber             =wrdPar[["NoLineNumber"]],
    Hyphenation              =wrdPar[["Hyphenation"]],
    FirstLineIndent          =wrdPar[["FirstLineIndent"]],
    OutlineLevel             =wrdPar[["OutlineLevel"]],
    CharacterUnitLeftIndent  =wrdPar[["CharacterUnitLeftIndent"]],
    CharacterUnitRightIndent =wrdPar[["CharacterUnitRightIndent"]],
    CharacterUnitFirstLineIndent=wrdPar[["CharacterUnitFirstLineIndent"]],
    LineUnitBefore           =wrdPar[["LineUnitBefore"]],
    LineUnitAfter            =wrdPar[["LineUnitAfter"]],
    MirrorIndents            =wrdPar[["MirrorIndents"]]
    # wrdPar[["TextboxTightWrap"]] <- TextboxTightWrap
  )

  class(currpar) <- "paragraph"
  return(currpar)
}



`WrdParagraphFormat<-` <- function(wrd, value){

  wrdPar <- wrd[["Selection"]][["ParagraphFormat"]]

  # set the new font
  if(!is.null(value$LeftIndent)) wrdPar[["LeftIndent"]] <- value$LeftIndent
  if(!is.null(value$RightIndent)) wrdPar[["RightIndent"]] <- value$RightIndent
  if(!is.null(value$SpaceBefore)) wrdPar[["SpaceBefore"]] <- value$SpaceBefore
  if(!is.null(value$SpaceBeforeAuto)) wrdPar[["SpaceBeforeAuto"]] <- value$SpaceBeforeAuto
  if(!is.null(value$SpaceAfter)) wrdPar[["SpaceAfter"]] <- value$SpaceAfter
  if(!is.null(value$SpaceAfterAuto)) wrdPar[["SpaceAfterAuto"]] <- value$SpaceAfterAuto
  if(!is.null(value$LineSpacingRule)) wrdPar[["LineSpacingRule"]] <- value$LineSpacingRule
  if(!is.null(value$Alignment)) {
    if(is.character(value$Alignment))
      switch(match.arg(value$Alignment, choices = c("left","center","right"))
             , left=value$Alignment <- wdConst$wdAlignParagraphLeft
             , center=value$Alignment <- wdConst$wdAlignParagraphCenter
             , right=value$Alignment <- wdConst$wdAlignParagraphRight
      )
    wrdPar[["Alignment"]] <- value$Alignment
    }
  if(!is.null(value$WidowControl)) wrdPar[["WidowControl"]] <- value$WidowControl
  if(!is.null(value$KeepWithNext)) wrdPar[["KeepWithNext"]] <- value$KeepWithNext
  if(!is.null(value$KeepTogether)) wrdPar[["KeepTogether"]] <- value$KeepTogether
  if(!is.null(value$PageBreakBefore)) wrdPar[["PageBreakBefore"]] <- value$PageBreakBefore
  if(!is.null(value$NoLineNumber)) wrdPar[["NoLineNumber"]] <- value$NoLineNumber
  if(!is.null(value$Hyphenation)) wrdPar[["Hyphenation"]] <- value$Hyphenation
  if(!is.null(value$FirstLineIndent)) wrdPar[["FirstLineIndent"]] <- value$FirstLineIndent
  if(!is.null(value$OutlineLevel)) wrdPar[["OutlineLevel"]] <- value$OutlineLevel
  if(!is.null(value$CharacterUnitLeftIndent)) wrdPar[["CharacterUnitLeftIndent"]] <- value$CharacterUnitLeftIndent
  if(!is.null(value$CharacterUnitRightIndent)) wrdPar[["CharacterUnitRightIndent"]] <- value$CharacterUnitRightIndent
  if(!is.null(value$CharacterUnitFirstLineIndent)) wrdPar[["CharacterUnitFirstLineIndent"]] <- value$CharacterUnitFirstLineIndent
  if(!is.null(value$LineUnitBefore)) wrdPar[["LineUnitBefore"]] <- value$LineUnitBefore
  if(!is.null(value$LineUnitAfter)) wrdPar[["LineUnitAfter"]] <- value$LineUnitAfter
  if(!is.null(value$MirrorIndents)) wrdPar[["MirrorIndents"]] <- value$MirrorIndents

  return(wrd)

}


WrdStyle <- function (wrd = DescToolsOptions("lastWord")) {
  wrdSel <- wrd[["Selection"]]
  wrdStyle <- wrdSel[["Style"]][["NameLocal"]]
  return(wrdStyle)
}


`WrdStyle<-` <- function (wrd, value) {
  wrdSel <- wrd[["Selection"]][["Paragraphs"]]
  wrdSel[["Style"]] <- value
  return(wrd)
}




WrdGoto <- function (name, what = wdConst$wdGoToBookmark, wrd = DescToolsOptions("lastWord")) {
  wrdSel <- wrd[["Selection"]]
  
  if(what == wdConst$wdGoToBookmark){
    wrdBookmarks <- wrd[["ActiveDocument"]][["Bookmarks"]]
    if(wrdBookmarks$exists(name)){
      wrdSel$GoTo(what=what, Name=name)
      res <- TRUE
    } else {
      warning(gettextf("Bookmark %s does not exist, so there's nothing to select", name))
      res <- FALSE
    }
  } else {
    wrdSel$GoTo(what=what, Name=name)
    
  }
  
  invisible()
}






WrdPageBreak <- function(wrd = DescToolsOptions("lastWord")) {
  wrd[["Selection"]]$InsertBreak(wdConst$wdSectionBreakNextPage)
  invisible()
}



WrdBookmark <- function(name, wrd = DescToolsOptions("lastWord")){
  
  wbms <- wrd[["ActiveDocument"]][["Bookmarks"]]
  
  if(wbms$count()>0){
    # get bookmark names
    bmnames <- sapply(seq(wbms$count()), function(i) wbms[[i]]$name())
    
    id <- which(name == bmnames)
    
    if(length(id)==0)   # name found?
      res <- NULL 
    
    else
      res <- wbms[[id]]
    # no attributes for S4 objects... :-(
    #  res@idx <- which(name == bmnames)
    
  } else {
    # warning(gettextf("bookmark %s not found", bookmark))
    res <- NULL
  }
  
  return(res)  
  
}


# WrdGetBookmarkID <- function(name, wrd = DescToolsOptions("lastWord")){
#   
#   wrdBookmarks <- wrd[["ActiveDocument"]][["Bookmarks"]]
#   
#   if(wrdBookmarks$exists(name)){
#     if((n <- wrdBookmarks$count()) > 0) {
#       for(i in 1:n){
#         if(name == wrdBookmarks[[i]]$name())
#           return(i)
#       }
#     }
#   } else {
#     warning(gettextf("Bookmark %s does not exist.", name))
#     return(NA_integer_)
#   }
#   
# }




WrdInsertBookmark <- function (name, wrd = DescToolsOptions("lastWord")) {

  #   With ActiveDocument.Bookmarks
  #   .Add Range:=Selection.Range, Name:="entb"
  #   .DefaultSorting = wdSortByName
  #   .ShowHidden = False
  #   End With

  wrdBookmarks <- wrd[["ActiveDocument"]][["Bookmarks"]]
  bookmark <- wrdBookmarks$Add(name)
  invisible(bookmark)
}


WrdUpdateBookmark <- function (name, text, what = wdConst$wdGoToBookmark, wrd = DescToolsOptions("lastWord")) {

  #   With ActiveDocument.Bookmarks
  #   .Add Range:=Selection.Range, Name:="entb"
  #   .DefaultSorting = wdSortByName
  #   .ShowHidden = False
  #   End With

  wrdSel <- wrd[["Selection"]]
  wrdSel$GoTo(What=what, Name=name)
  wrdSel[["Text"]] <- text
  # the bookmark will be deleted, how can we avoid that?
  wrdBookmarks <- wrd[["ActiveDocument"]][["Bookmarks"]]
  wrdBookmarks$Add(name)
  invisible()
}




WrdDeleteBookmark <- function(name, wrd = DescToolsOptions("lastWord")){
  
  wrdBookmarks <- wrd[["ActiveDocument"]][["Bookmarks"]]
  if(wrdBookmarks$exists(name)){
    WrdBookmark(name)$Delete()
    res <- TRUE
  } else {
    warning(gettextf("Bookmark %s does not exist, so there's nothing to delete", name))
    res <- FALSE
  }
  
  return(res)
  # TRUE for success / FALSE for fail
}  





WrdUpdateFields <- function(where = "wholestory", wrd = DescToolsOptions("lastWord")) {
  
  ii <- if( identical(where, "wholestory") )
    list(
      wdCommentsStory = 4,
      wdEndnoteContinuationNoticeStory = 17,
      wdEndnoteContinuationSeparatorStory = 16,
      wdEndnoteSeparatorStory = 15,
      wdEndnotesStory = 3,
      wdEvenPagesFooterStory = 8,
      wdEvenPagesHeaderStory = 6,
      wdFirstPageFooterStory = 11,
      wdFirstPageHeaderStory = 10,
      wdFootnoteContinuationNoticeStory = 14,
      wdFootnoteContinuationSeparatorStory = 13,
      wdFootnoteSeparatorStory = 12,
      wdFootnotesStory = 2,
      wdMainTextStory = 1,
      wdPrimaryFooterStory = 9,
      wdPrimaryHeaderStory = 7,
      wdTextFrameStory = 5)
  
  else
    where
  
  doc <- wrd$activedocument()
  for(i in ii) {
    
    # we cannot simply loop over a sequence 1:count() as indexing a nonexisting story raises a COMError
    # and the index of the story is not an ascending integer, but a wdStory constant
    # not found a handle to get a list of existing storyranges
    StoryRange <- tryCatch(doc$StoryRanges()[[i]], error = function(e) NULL)
    if(!is.null(StoryRange)) {
      if(StoryRange$Fields()$Count() > 0) {
        for(j in seq(StoryRange$Fields()$Count())){
          StoryRange$Fields(j)$Update()
        }
      }
    }
  }
}





WrdOpenFile <- function(fn, wrd = DescToolsOptions("lastWord")){
  
  if(!IsValidHwnd(wrd)){
    wrd <- GetNewWrd()
    wrd[["ActiveDocument"]]$Close()
  }
  
  # ChangeFileOpenDirectory "C:\Users\HK1S0\Desktop\"
  # 
  # Documents.Open FileName:="DynWord.docx", ConfirmConversions:=False, _
  #         ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
  #         PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
  #         WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""
  
  res <- wrd[["Documents"]]$Open(FileName=fn)
  
  # return document
  invisible(res)
}



WrdSaveAs <- function(fn, fileformat="docx", wrd = DescToolsOptions("lastWord")) {

  wdConst$wdExportFormatPDF <- 17

  if(fileformat %in% c("doc","docx"))
    wrd$ActiveDocument()$SaveAs(FileName=fn, FileFormat=wdConst$wdFormatDocument)
  else if(fileformat %in% c("htm", "html"))
    wrd$ActiveDocument()$SaveAs2(FileName=fn, FileFormat=wdConst$wdFormatHTML)
  else if(fileformat == "pdf")
    wrd$ActiveDocument()$ExportAsFixedFormat(OutputFileName="Einkommen2.pdf",
                             ExportFormat=wdConst$wdExportFormatPDF)

  # ChangeFileOpenDirectory "C:\Users\HK1S0\Desktop\"
  # ActiveDocument.SaveAs2 FileName:="Einkommen.htm", FileFormat:=wdFormatHTML _
  #     , LockComments:=False, Password:="", AddToRecentFiles:=True, _
  #     WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
  #      SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
  #     False, CompatibilityMode:=0
  # ActiveWindow.View.Type = wdWebView
  #
  # ActiveDocument.ExportAsFixedFormat OutputFileName:= _
  #     "C:\Users\HK1S0\Desktop\Einkommen.pdf", ExportFormat:=wdExportFormatPDF, _
  #     OpenAfterExport:=True, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
  #     wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, _
  #     IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
  #     wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
  #     True, UseISO19005_1:=False

  invisible()

}


# Example: WrdPlot(picscale=30)
#          WrdPlot(width=8)


CmToPts <- function(x) x * 28.35
PtsToCm <- function(x) x / 28.35
# http://msdn.microsoft.com/en-us/library/bb214076(v=office.12).aspx


WrdPlot <- function( type="png", append.cr=TRUE, crop=c(0,0,0,0), main = NULL,
                     picscale=100, height=NA, width=NA, res=300, dfact=1.6, wrd = DescToolsOptions("lastWord") ){

  # png is considered a good default choice for export to word (Smith)
  # http://blog.revolutionanalytics.com/2009/01/10-tips-for-making-your-r-graphics-look-their-best.html

  # height, width in cm!
  # scale will be overidden, if height/width defined



  # handle missing height or width values
  if (is.na(width) ){
    if (is.na(height)) {
      width <- 14
      height <- par("pin")[2] / par("pin")[1] * width
    } else {
      width <- par("pin")[1] / par("pin")[2] * height
    }
  } else {
    if (is.na(height) ){
      height <- par("pin")[2] / par("pin")[1] * width
    }
  }


  # get a [type] tempfilename:
  fn <- paste( tempfile(pattern = "file", tmpdir = tempdir()), ".", type, sep="" )
  # this is a problem for RStudio....
  # savePlot( fn, type=type )
  # png(fn, width=width, height=height, units="cm", res=300 )
  dev.copy(eval(parse(text=type)), fn, width=width*dfact, height=height*dfact, res=res, units="cm")
  d <- dev.off()

  # add it to our word report
  res <- wrd[["Selection"]][["InlineShapes"]]$AddPicture( fn, FALSE, TRUE )
  wrdDoc <- wrd[["ActiveDocument"]]
  pic <- wrdDoc[["InlineShapes"]]$Item( wrdDoc[["InlineShapes"]][["Count"]] )

  pic[["LockAspectRatio"]] <- -1  # = msoTrue
  picfrmt <- pic[["PictureFormat"]]
  picfrmt[["CropBottom"]] <- CmToPts(crop[1])
  picfrmt[["CropLeft"]] <- CmToPts(crop[2])
  picfrmt[["CropTop"]] <- CmToPts(crop[3])
  picfrmt[["CropRight"]] <- CmToPts(crop[4])

  if( is.na(height) & is.na(width) ){
    # or use the ScaleHeight/ScaleWidth attributes:
    pic[["ScaleHeight"]] <- picscale
    pic[["ScaleWidth"]] <- picscale
  } else {
    # Set new height:
    if( is.na(width) ) width <- height / PtsToCm( pic[["Height"]] ) * PtsToCm( pic[["Width"]] )
    if( is.na(height) ) height <- width / PtsToCm( pic[["Width"]] ) * PtsToCm( pic[["Height"]] )
    pic[["Height"]] <- CmToPts(height)
    pic[["Width"]] <- CmToPts(width)
  }

  if( append.cr == TRUE ) { wrd[["Selection"]]$TypeText("\n")
  } else {
    wrd[["Selection"]]$MoveRight(wdConst$wdCharacter, 1, 0)
  }

  if( file.exists(fn) ) { file.remove(fn) }

  if(!is.null(main)){
    # insert caption
    sel <- wrd$Selection()  # "Abbildung"
    sel$InsertCaption(Label=wdConst$wdCaptionFigure, Title=main)
    sel$TypeParagraph()
  }

  invisible(pic)

}



WrdTable <- function(nrow = 1, ncol = 1, heights = NULL, widths = NULL, 
                     main = NULL, wrd = DescToolsOptions("lastWord")){

  res <- wrd[["ActiveDocument"]][["Tables"]]$Add(wrd[["Selection"]][["Range"]],
                                                 NumRows = nrow, NumColumns = ncol)
  if(!is.null(widths)) {
    widths <- rep(widths, length.out=ncol)
    for(i in 1:ncol){
      # set column-widths
      tcol <- res$Columns(i)
      tcol[["Width"]] <- CmToPts(widths[i])
    }
  }
  if(!is.null(heights)) {
    heights <- rep(heights, length.out=nrow)
    for(i in 1:nrow){
      # set row heights
      tcol <- res$Rows(i)
      tcol[["Height"]] <- CmToPts(heights[i])
    }
  }

  if(!is.null(main)){
    # insert caption
    sel <- wrd$Selection()  # "Abbildung"
    sel$InsertCaption(Label=wdConst$wdCaptionTable, Title=main)
    sel$TypeParagraph()
  }

  invisible(res)
}



WrdTableHeading <- function(wtab, text, bold=TRUE, 
                            alignment=wdConst$wdAlignParagraphCenter,
                            merge_cols = NULL,
                            wrd = DescToolsOptions("lastWord")){
  
  # inserts a first row in a word table and allows to merge cells
  
  # example:
  # WrdTableHeading(wtab, text=c("Coefficients","Death\n(n=45)", 
  #                              "Nurs", "Restroke", "MACE"),
  #                  alignment=c(wdConst$wdAlignParagraphLeft, 
  #                              rep(wdConst$wdAlignParagraphCenter, 4)), 
  #                  merge_cols = c("2:4", "5:7", "8:10", "11:13"))
  
  
  WrdTableDuplicateFirstRow <- function(wtab){
    
    wtab$Rows(1)$Range()$Copy()
    wtab$Rows(1)$Select()
    # wrd[["Selection"]]$InsertRowsBelow()
    wtab$Rows(2)$Range()$Paste()
    
  }
  
  # Prepare the first row for the heading  
  WrdTableDuplicateFirstRow(wtab)
  wtab$Rows(1)$Select()
  wsel <- wrd$Selection()
  wsel$delete()
  
  if(!is.null(merge_cols)){
    lost_cols <- 0
    # start merging columns
    for(i in seq(merge_cols)){
      i_rng <- as.numeric(strsplit(merge_cols[i], split=":")[[1]]) - lost_cols
      WrdMergeCells(wtab, rstart=c(1, i_rng[1]), rend=c(1, i_rng[2]))
      lost_cols <- lost_cols + diff(i_rng)
    }
  }
  
  # get final cell count
  cells_n <- wtab$Rows(1)$cells()$Count()
  alignment <- rep(alignment, length.out=cells_n)
  bold <- rep(bold, length.out=cells_n)
  
  # place the text in all columns
  for( i in seq(cells_n)){
    rng <- wtab$Cell(1, i)$Range()
    rng[["text"]] <- text[i]
    hwnd <- rng$paragraphFormat()
    hwnd[["Alignment"]] <- alignment[i]
    hwnd <- rng$font()
    hwnd[["bold"]] <- bold[i]
  }  
  
}





Phrase <- function(x, g, glabels=NULL, xname=NULL, unit=NULL, lang="engl", na.rm=FALSE) {

  if(is.null(xname))
    if(is.null(names(x)))
      xname <- deparse(substitute(x))
    else
      xname <- names(x)

  if(is.null(glabels))
    glabels <- levels(factor(g))

  if(is.null(unit))
    unit <- ""

  if(lang=="engl"){
    txt1 <- "The entire group consists of a total of %s elements. Of these, %s are %s (%s, mean %s %s %s) and %s %s (%s, mean %s %s %s).\n"
    txt2 <- "The difference is significant (t-test, p = %s) and is %s %s [%s, %s] (95%s CI)."
    txt3 <- "The difference is not significant.\n"

  } else {
    txt1 <- "Das Kollektiv besteht aus insgesamt %s Elementen. Davon sind %s %s (%s, mittleres %s %s %s) und %s %s (%s, mittleres %s %s %s).\n"
    txt2 <- "Der Unterschied ist signifikant (t-test, p = %s) und betraegt %s %s [%s, %s] (95%s-CI).\n"
    txt3 <- "Der Unterschied ist nicht signifikant.\n"
  }


  lst <- split(x, g)
  if(na.rm)
    lst <- lapply(lst, na.omit)
  names(lst) <- c("x","y")

  n <- sapply(lst, length)
  mx <- format(sapply(lst, mean), digits=3)

  txt <- gettextf(txt1
                  , Format(sum(n), digits=0, big.mark="'")
                  , Format(n[1], digits=0, big.mark="'")
                  , glabels[1]
                  , Format(n[1]/sum(n), digits=1, fmt="%")
                  , xname
                  , mx[1]
                  , unit
                  , Format(n[2], digits=0, big.mark="'")
                  , glabels[2]
                  , Format(n[2]/sum(n), digits=1, fmt="%")
                  , xname
                  , mx[2]
                  , unit
  )

  r.t <- t.test(lst$x, lst$y)

  if(r.t$p.value < 0.05){
    md <- format(MeanDiffCI(lst$x, lst$y), digits=3)
    txt <- paste(txt, gettextf(txt2, Format(r.t$p.value, fmt="p"), md[1], unit, md[2], md[3], "%"), sep="" )
  } else {
    txt <- paste(txt, txt3, sep="")
  }

  # pasting "" uses collapse character, so get rid of multiple spaces here
  gsub(" )", ")", gsub(" +", " ", txt))

}


###

# ## Word Table - experimental code
#
# WrdTable <- function(tab, main = NULL, wrd = DescToolsOptions("lastWord"), row.names = FALSE, ...){
#   UseMethod("WrdTable")
#
# }
#
#
# WrdTable.Freq <- function(tab, main = NULL, wrd = DescToolsOptions("lastWord"), row.names = FALSE, ...){
#
#   tab[,c(3,5)] <- sapply(round(tab[,c(3,5)], 3), Format, digits=3)
#   res <- WrdTable.default(tab=tab, wrd=wrd)
#
#   if(!is.null(main)){
#     # insert caption
#     sel <- wrd$Selection()  # "Abbildung"
#     sel$InsertCaption(Label=wdConst$wdCaptionTable, Title=main)
#     sel$TypeParagraph()
#   }
#
#   invisible(res)
#
# }
#
# WrdTable.ftable <- function(tab, main = NULL, wrd = DescToolsOptions("lastWord"), row.names = FALSE, ...) {
#   tab <- FixToTable(capture.output(tab))
#   NextMethod()
# }
#
#
# WrdTable.default <- function (tab, font = NULL, align=NULL, autofit = TRUE, main = NULL,
#                               wrd = DescToolsOptions("lastWord"), row.names=FALSE,
#                               ...) {
#
#   dim1 <- ncol(tab)
#   dim2 <- nrow(tab)
#   if(row.names) dim1 <- dim1 + 1
#
#   # wdConst ist ein R-Objekt (Liste mit 2755 Objekten!!!)
#
#   write.table(tab, file = "clipboard", sep = "\t", quote = FALSE, row.names=row.names)
#
#   myRange <- wrd[["Selection"]][["Range"]]
#   bm      <- wrd[["ActiveDocument"]][["Bookmarks"]]$Add("PasteHere", myRange)
#   myRange$Paste()
#
#   if(row.names) wrd[["Selection"]]$TypeText("\t")
#
#   myRange[["Start"]] <- bm[["Range"]][["Start"]]
#   myRange$Select()
#   bm$Delete()
#   wrd[["Selection"]]$ConvertToTable(Separator       = wdConst$wdSeparateByTabs,
#                                     NumColumns      = dim1,
#                                     NumRows         = dim2,
#                                     AutoFitBehavior = wdConst$wdAutoFitFixed)
#
#   wrdTable <- wrd[["Selection"]][["Tables"]]$Item(1)
#   # http://www.thedoctools.com/downloads/DocTools_List_Of_Built-in_Style_English_Danish_German_French.pdf
#   wrdTable[["Style"]] <- -115 # "Tabelle Klassisch 1"
#   wrdSel <- wrd[["Selection"]]
#
#
#   # align the columns
#   if(is.null(align))
#     align <- c("l", rep(x = "r", ncol(tab)-1))
#   else
#     align <- rep(align, length.out=ncol(tab))
#
#   align[align=="l"] <- wdConst$wdAlignParagraphLeft
#   align[align=="c"] <- wdConst$wdAlignParagraphCenter
#   align[align=="r"] <- wdConst$wdAlignParagraphRight
#
#   for(i in seq_along(align)){
#     wrdTable$Columns(i)$Select()
#     wrd[["Selection"]][["ParagraphFormat"]][["Alignment"]] <- align[i]
#   }
#
#   if(!is.null(font)){
#     wrdTable$Select()
#     WrdFont(wrd) <- font
#   }
#
#   if(autofit)
#     wrdTable$Columns()$AutoFit()
#
#   # Cursor aus der Tabelle auf die letzte Postition im Dokument setzten
#   # Selection.GoTo What:=wdGoToPercent, Which:=wdGoToLast
#   wrd[["Selection"]]$GoTo(What = wdConst$wdGoToPercent, Which= wdConst$wdGoToLast)
#
#   if(!is.null(main)){
#     # insert caption
#     sel <- wrd$Selection()  # "Abbildung"
#     sel$InsertCaption(Label=wdConst$wdCaptionTable, Title=main)
#     sel$TypeParagraph()
#
#   }
#
#   invisible(wrdTable)
#
# }
#

# WrdTable <- function(tab, wrd){

# ###  http://home.wanadoo.nl/john.hendrickx/statres/other/PasteAsTable.html

# write.table(tab, file="clipboard", sep="\t", quote=FALSE)

# myRange <- wrd[["Selection"]][["Range"]]

# bm <- wrd[["ActiveDocument"]][["Bookmarks"]]$Add("PasteHere", myRange)

# myRange$Paste()
# wrd[["Selection"]]$TypeText("\t")

# myRange[["Start"]] <- bm[["Range"]][["Start"]]
# myRange$Select()

# bm$Delete()

# wrd[["Selection"]]$ConvertToTable(Separator=wdConst$wdSeparateByTabs, NumColumns=4,
# NumRows=9, AutoFitBehavior=wdConst$wdAutoFitFixed)

# wrdTable <- wrd[["Selection"]][["Tables"]]$Item(1)
# wrdTable[["Style"]] <- "Tabelle Klassisch 1"

# wrdSel <- wrd[["Selection"]]
# wrdSel[["ParagraphFormat"]][["Alignment"]] <- wdConst$wdAlignParagraphRight

# #left align the first column
# wrdTable[["Columns"]]$Item(1)$Select()
# wrd[["Selection"]][["ParagraphFormat"]][["Alignment"]] <- wdConst$wdAlignParagraphLeft

# ### wtab[["ApplyStyleHeadingRows"]] <- TRUE
# ### wtab[["ApplyStyleLastRow"]] <- FALSE
# ### wtab[["ApplyStyleFirstColumn"]] <- TRUE
# ### wtab[["ApplyStyleLastColumn"]] <- FALSE
# ### wtab[["ApplyStyleRowBands"]] <- TRUE
# ### wtab[["ApplyStyleColumnBands"]] <- FALSE

# ### With Selection.Tables(1)
# #### If .Style <> "Tabellenraster" Then
# ### .Style = "Tabellenraster"
# ### End If

# ### wrd[["Selection"]]$ConvertToTable( Separator=wdConst$wdSeparateByTabs, AutoFit=TRUE, Format=wdConst$wdTableFormatSimple1,
# ### ApplyBorders=TRUE, ApplyShading=TRUE, ApplyFont=TRUE,
# ### ApplyColor=TRUE, ApplyHeadingRows=TRUE, ApplyLastRow=FALSE,
# ### ApplyFirstColumn=TRUE, ApplyLastColumn=FALSE)

# ###  wrd[["Selection"]][["Tables"]]$Item(1)$Select()
# #wrd[["Selection"]][["ParagraphFormat"]][["Alignment"]] <- wdConst$wdAlignParagraphRight
# ### ### left align the first column
# ### wrd[["Selection"]][["Columns"]]$Item(1)$Select()
# ### wrd[["Selection"]][["ParagraphFormat"]][["Alignment"]] <- wdConst$wdAlignParagraphLeft
# ### wrd[["Selection"]][["ParagraphFormat"]][["Alignment"]] <- wdConst$wdAlignParagraphRight



# }




# require ( xtable )
# data ( tli )
# fm1 <- aov ( tlimth ~ sex + ethnicty + grade + disadvg , data = tli )
# fm1.table <- print ( xtable (fm1), type ="html")

# Tabellen-Studie via HTML FileExport


# WrdInsTable <- function( tab, wrd ){
# htmtab <- print(xtable(tab), type ="html")

# ### Let's create a summary file and insert it
# ### get a tempfile:
# fn <- paste(tempfile(pattern = "file", tmpdir = tempdir()), ".txt", sep="")

# write(htmtab, file=fn)
# wrd[["Selection"]]$InsertFile(fn)
# wrd[["ActiveDocument"]][["Tables"]]$Item(
# wrd[["ActiveDocument"]][["Tables"]][["Count"]] )[["Style"]] <- "Tabelle Klassisch 1"

# }

# WrdInsTable( fm1, wrd=wrd )

# data(d.pizza)
# txt <- Desc( temperature ~ driver, data=d.pizza )
# WrdInsTable( txt, wrd=wrd )

# WrdPlot(PlotDescNumFact( temperature ~ driver, data=d.pizza, newwin=TRUE )
# , wrd=wrd, width=17, crop=c(0,0,60,0))



###

## Excel functions   ====



XLView <- function (x, col.names = TRUE, row.names = FALSE, na = "", preserveStrings=FALSE, sep=";") {

  # # define some XL constants
  # xlToRight <- -4161

  fn <- paste(tempfile(pattern = "file", tmpdir = tempdir()),
              ".csv", sep = "")
  xl <- GetNewXL(newdoc=FALSE)
  owb <- xl[["Workbooks"]]

  if(!missing(x)){

    if(inherits(x, what = "ftable")){
      x <- FixToTable(capture.output(x), sep = " ", header = FALSE)
      col.names <- FALSE
    }

    if(preserveStrings){
      # embed all characters or factors in ="xyz"
      for(z in which(sapply(x, function(y) is.character(y) | is.factor(y)))){
        x[, z] <- gettextf('="%s', x[,z])
      }
    }

    write.table(x, file = fn, sep = sep, col.names = col.names,
                qmethod = "double", row.names = row.names, na=na)
    ob <- owb$Open(fn)
    # if row.names are saved there's the first cell in the first line missing
    # I don't actually see, how to correct this besides inserting a cell in XL
    if(row.names) xl$Cells(1, 1)$Insert(Shift=xlConst$xlToRight)
    xl[["Cells"]][["EntireColumn"]]$AutoFit()

  } else {
    owb$Add()
    awb <- xl[["ActiveWorkbook"]]
    # delete sheets(2,3) without asking, if it's ok
    xl[["DisplayAlerts"]] <- FALSE
    xl$Sheets(c(2,3))$Delete()
    xl[["DisplayAlerts"]] <- TRUE
    awb$SaveAs( Filename=fn, FileFormat=6 )
  }
  invisible(fn)
}


XLSaveAs <- function(fn, file_format=xlConst$XlFileFormat$xlWorkbookNormal, xl=DescToolsOptions("lastXL")){
  xl[["ActiveWorkbook"]]$SaveAs(FileName=fn, FileFormat=file_format)
}
  


ToXL <- function (x, at, ..., xl=DescToolsOptions("lastXL")) {
  stopifnot(IsValidHwnd(xl))   # "xl is not a valid Excel handle, use GetNewXL() or GetCurrXL().")
  UseMethod("ToXL")
}



ToXL.data.frame <- function(x, at, ..., xl=DescToolsOptions("lastXL"))
  ## export the data.frame "x" into the location "at" (top,left cell)
  ## output the occupying range.
  ## TODO: row.names, more error checking
{
  if(is.character(at)){
    # address of the left upper cell
    at <- do.call(xl$Cells, as.list(A1ToZ1S1(at)[[1]]))

  } else if(is.vector(at)) {
    # get a handle of the cell range
    at <- do.call(xl$Cells, as.list(at))
  }

  nc <- dim(x)[2]
  if(nc < 1) stop("data.frame must have at least one column")
  r1 <- at$Row()                   ## 1st row in range
  c1 <- at$Column()                ## 1st col in range
  c2 <- c1 + nc - 1                ## last col (*not* num of col)
  ws <- at[["Worksheet"]]

  ## headers
  if(!is.null(names(x))) {
    hdrRng <- ws$Range(ws$Cells(r1, c1), ws$Cells(r1, c2))
    hdrRng[["Value"]] <- names(x)
    rng <- ws$Cells(r1 + 1, c1)
  } else {
    rng <- ws$Cells(r1, c1)
  }

  ## data
  for(j in seq(from = 1, to = nc)){
    # debug only:
    # cat("Column", j, "\n")
    ToXL(x[, j], at = rng, xl=xl)   ## no byrow for data.frames!
    rng <- rng$Next()               ## next cell to the right
  }
  invisible(ws$Range(ws$Cells(r1, c1), ws$Cells(r1 + nrow(x), c2)))
}



ToXL.matrix <- function (x, at, ..., xl = DescToolsOptions("lastXL")) {
  ## export the matrix "x" into the location "at" (top,left cell)
  
  if(is.character(at)){
    # address of the left upper cell
    at <- do.call(xl$Cells, as.list(A1ToZ1S1(at)[[1]]))
    
  } else if(is.vector(at)) {
    # get a handle of the cell range
    at <- do.call(xl$Cells, as.list(at))
  }
  
  nc <- dim(x)[2]
  if (nc < 1) 
    stop("matrix must have at least one column")
  
  if(!is.null(names(dimnames(x)))) {
    ToXL(names(dimnames(x))[1], at=at$offset(1, 0)$address())
    fnt <- at$offset(1, 0)$Font()
    fnt[["Bold"]] <- TRUE
    ToXL(dimnames(x)[[1]], at=at$offset(2, 0)$address())
    at_rn <- at$offset(2, 0)$resize(length(dimnames(x)[[1]]), 1)
    at_rn[["IndentLevel"]] <- 1
    ToXL(names(dimnames(x))[2], at=at$offset(0, 1)$address())
    fnt <- at$offset(0, 1)$Font()
    fnt[["Bold"]] <- TRUE
    ToXL(rbind(dimnames(x)[[2]]), at=at$offset(1, 1)$address())
    at <- at$offset(2, 1)
  }
  
  xref <- RDCOMClient::asCOMArray(x)
  rng <- at$resize(dim(x)[1], dim(x)[2])
  rng[["Value"]] <- xref
  
  invisible(rng)

}


ToXL.array <- function (x, at, ..., xl = DescToolsOptions("lastXL")) {

  if(is.character(at)){
    # address of the left upper cell
    at <- do.call(xl$Cells, as.list(A1ToZ1S1(at)[[1]]))
    
  } else if(is.vector(at)) {
    # get a handle of the cell range
    at <- do.call(xl$Cells, as.list(at))
  }
    
  lst <- lapply(asplit(x, seq_along(dim(x))[-c(1:2)]), "[")
  
  g <- expand.grid(dimnames(x)[-c(1:2)])
  names(lst) <- paste0(", , ", apply(sapply(colnames(g), function(x) paste(x, "=", g[, x])), 1, paste, collapse=", "))
    
  for(i in seq_along(lst)){
    ToXL(names(lst)[i], at=at)
    at <- at$offset(2, 0)
    ToXL(lst[[i]], at=at)
    at <- at$offset(dim(lst[[i]])[1] + 3, 0)
  }
  

}



ToXL.table <- function (x, at, ..., xl = DescToolsOptions("lastXL")) {
  ToXL.array(x, at=at, ..., xl=xl)
}


ToXL.default <- function(x, at, byrow = FALSE, ..., xl=DescToolsOptions("lastXL")) {

  #  function(x, at = NULL, byrow = FALSE, ...)
  ## coerce x to a simple (no attributes) vector and export to
  ## the range specified at "at" (can refer to a single starting cell);
  ## byrow = TRUE puts x in one row, otherwise in one column.
  ## How should we deal with unequal of ranges and vectors?  Currently
  ## we stop, modulo the special case when at refers to the starting cell.
  ## TODO: converters (currency, dates, etc.)

  if(is.character(at)){
    # address of the left upper cell
    at <- do.call(xl$Cells, as.list(A1ToZ1S1(at)[[1]]))

  } else if(is.vector(at)) {
    # get a handle of the cell range
    at <- do.call(xl$Cells, as.list(at))
  }

  n <- length(x)
  if(n < 1) return(at)
  d <- c(at$Rows()$Count(), at$Columns()$Count())
  N <- prod(d)

  xl <- at$Application()

  if(N == 1 && n > 1){     ## at refers to the starting cell
    r1c1 <- c(at$Row(), at$Column())
    r2c2 <- r1c1 + if(byrow) c(0, n-1) else c(n-1, 0)
    ws <- at[["Worksheet"]]
    at <- ws$Range(ws$Cells(r1c1[1], r1c1[2]),
                   ws$Cells(r2c2[1], r2c2[2]))
  } else if(n != N)
    stop("range and length(x) differ")

  ## currently we can only export primitives...

  if(any(class(x) %in% c("logical", "integer", "numeric", "character")))
    x <- as.vector(x)     ## clobber attributes

  else
    x <- as.character(x)  ## give up -- coerce to chars

  ## here we create a C-level COM safearray
  d <- if(byrow) c(1, n) else c(n, 1)
  # is this an alternative??
  # RDCOMClient::asCOMArray(matrix(x, nrow=d[1], ncol=d[2]))
#  xref <- .Call("R_create2DArray", PACKAGE="RDCOMClient", matrix(x, nrow=d[1], ncol=d[2]))
  xref <- RDCOMClient::asCOMArray(matrix(x, nrow=d[1], ncol=d[2]))
  at[["Value"]] <- xref

  # workaround for missing values, simply delete the transferred bullshit
  na <- which(is.na(x))
  if(length(na) > 0) {
    if(byrow){
      arow <- gsub("[A-Z]","", at$cells(1,1)$address(rowabsolute=FALSE, columnabsolute=FALSE))

      # xlcol <- c( LETTERS
      #             , sort(c(outer(LETTERS, LETTERS, paste, sep="" )))
      #             , sort(c(outer(LETTERS, c(outer(LETTERS, LETTERS, paste, sep="" )), paste, sep="")))
      # )[1:16384]
      # xlcol <- XLColNames
      rngA1 <- paste(XLColNames()[na], arow, sep="", collapse = ";")
      rng <- xl$range(rngA1)$offset(ColumnOffset=xl$Range(at$Address())$Column()-1)

    } else {
      # find the column
      acol <- gsub("[0-9]","", at$cells(1,1)$address(rowabsolute=FALSE, columnabsolute=FALSE))
      # build range adress for the NAs
      rngA1 <- paste(acol, na, sep="", collapse = ";")
      # offset, if there's a name
      rng <- xl$range(rngA1)$offset(xl$Range(at$Address())$Row()-1)
    }
    rng[["FormulaR1C1"]] <- ""
  }

  invisible(at)
}




XLCurrReg <- function(cell){
  structure(cell, class="XLCurrReg")
}


XLNamedReg <- function (x) {
  structure(x, class = "XLNamedReg")
}



XLColNames <- function() {
  c(LETTERS, out2 <- c(t(outer(LETTERS, LETTERS, paste, sep = ""))), 
    t(outer(LETTERS, out2, paste, sep = "")))[1:16384]
}



A1ToZ1S1 <- function(x){
  
  # was so slooow, we don't have to sort, if we do it a little more cleverly...
  # xlcol <- c( LETTERS
  #             , sort(c(outer(LETTERS, LETTERS, paste, sep="" )))
  #             , sort(c(outer(LETTERS, c(outer(LETTERS, LETTERS, paste, sep="" )), paste, sep="")))
  # )[1:16384]

  z1s1 <- function(x) {
    # remove all potential $ from a range first
    x <- gsub("\\$", "", x)
    colnr <- match( regmatches(x, regexec("^[[:alpha:]]+", x)), XLColNames())
    rownr <- as.numeric(regmatches(x, regexec("[[:digit:]]+$", x)))
    return(c(rownr, colnr))
  }

  lapply(unlist(strsplit(toupper(x),":")), z1s1)
}




XLGetRange <- function (file = NULL, sheet = NULL, range = NULL, as.data.frame = TRUE,
                        header = FALSE, stringsAsFactors = FALSE, echo = FALSE, 
                        na.strings = NULL, skip = 0) {

    # main function  *******************************

  # to do: 30.8.2015
  # we could / should check for a running XL instance here...
  # ans <- RDCOMClient::getCOMInstance("Excel.Application", force = FALSE, silent = TRUE)
  # if (is.null(ans) || is.character(ans)) print("not there")

  
  # https://stackoverflow.com/questions/38950005/how-to-manipulate-null-elements-in-a-nested-list/
  simple_rapply <- function(x, fn) {
    if(is.list(x)) {
      lapply(x, simple_rapply, fn)
    } else {
      fn(x)
    }
  }
  
  if(is.null(file)){
    xl <- GetCurrXL()
    ws <- xl$ActiveSheet()
    if(is.null(range)) {
      # if there is a selection in XL then use it, if only one cell selected use currentregion
      sel <- xl$Selection()
      if(sel$Cells()$Count() == 1 ){
        range <- xl$ActiveCell()$CurrentRegion()$Address(FALSE, FALSE)
      } else {
        range <- sapply(1:sel$Areas()$Count(), function(i) sel$Areas()[[i]]$Address(FALSE, FALSE) )
  
        # old: this did not work on some XL versions with more than 28 selected areas
        # range <- xl$Selection()$Address(FALSE, FALSE)
        # range <- unlist(strsplit(range, ";"))
        # there might be more than 1 single region, split by ;
        # (this might be a problem for other locales)
      }
    }
  
  } else {
    xl <- GetNewXL()
    wb <- xl[["Workbooks"]]$Open(file)
  
    # set defaults for sheet and range here
    if(is.null(sheet))
      sheet <- 1
  
    if(is.null(range))
      range <- xl$Cells(1,1)$CurrentRegion()$Address(FALSE, FALSE)
  
    ws <- wb$Sheets(sheet)$select()
  }
  
  if(inherits(x=range, what="XLCurrReg")){
    # take only the first cell of a given range
    zs <- A1ToZ1S1(range)[[1]]
    range <- xl$Cells(zs[1], zs[2])$CurrentRegion()$Address(FALSE, FALSE)
  } else if(inherits(x=range, what="XLNamedReg")){
    # get the address of the named region
    sel <- xl$ActiveWorkbook()$Names(as.character(range))$RefersToRange()
    range <- sapply(1:sel$Areas()$Count(), function(i) sel$Areas()[[i]]$Address(FALSE, FALSE) )
  
  }
  
  # recycle skip
  skip <- rep(skip, length.out=length(range))
  
  lst <- list()
  for (i in seq_along(range)) {
    zs <- A1ToZ1S1(range[i])
    if(length(zs)==1){
      rr <- xl$Cells(zs[[1]][1], zs[[1]][2])
    } else {
      rr <- xl$Range(xl$Cells(zs[[1]][1], zs[[1]][2]), xl$Cells(zs[[2]][1], 
                                                                zs[[2]][2]))
    }
    
    # resize and offset range, if skip != 0
    if (skip[i] != 0) 
      rr <- rr$Resize(rr$Rows()$Count() - skip[i])$Offset(skip[i], 0)
    
    # Get the values
    if(is.null(rr[["Value"]]))
      # this is the case when we have multiple ranges selected an one of them 
      # is a single empty cell
      lst[[i]] <- NA
    else 
      lst[[i]] <- rr[["Value"]]
    # this produces a non trappable warning "Unhandled conversion type 10"
    # no further problem, but document in help!
    
    if(!is.list(lst[[i]]))
      lst[[i]] <- list(as.list(lst[[i]]))
    
    # replace NULLs by NAs (rather complicated job...)
    lst[[i]] <- simple_rapply(lst[[i]], 
                              function(x) if(is.null(x)) NA else x)
    
    # # address of errors: rr$SpecialCells(xlConst$xlFormulas, xlConst$xlErrors)$address()
    lst[[i]] <- rapply(lst[[i]],
                       function(x) {
                         
                         if(inherits(x=x, what="VARIANT")){
                           # if there are errors replace them by NA
                           NA
                           
                         } else if(inherits(x=x, what="COMDate")) {
                           # if there are XL dates, replace them by their date value
                           if(IsWhole(x))
                             as.Date(XLDateToPOSIXct(x))
                           else
                             XLDateToPOSIXct(x)
                           
                         } else if(x %in% na.strings) {
                           # if x in na.strings' list replace it by NA
                           NA
                           
                         } else {  
                           x
                         }
                       }, how = "replace")
    
    names(lst)[i] <- range[i]
  }
  
  if (as.data.frame) {
    for (i in seq_along(lst)) {
      
      if (header) {
        xnames <- unlist(lapply(lst[[i]], "[", 1))
        lst[[i]] <- lapply(lst[[i]], "[", -1)
      }
      
      # This was old: not fall back to it!!
      # lst[[i]] <- do.call(data.frame, c(lapply(lst[[i]][], 
      #                                          unlist), stringsAsFactors = stringsAsFactors))
      
      # don't use lapply and unlist as it's killing the classes for dates
      # https://stackoverflow.com/questions/15659783/why-does-unlist-kill-dates-in-r
      lst[[i]] <- do.call(data.frame, c(
        lapply(lst[[i]], function(x) do.call(c, x)), 
        stringsAsFactors = stringsAsFactors))
      
      if (header) {
        names(lst[[i]]) <- xnames
        
      } else {
        names(lst[[i]]) <- paste("X", 1:ncol(lst[[i]]), sep = "")
      }
    }
  }
  
  # just return a single object (for instance data.frame) if only one range was supplied
  if (length(lst) == 1)   lst <- lst[[1]]
  
  attr(lst, "call") <- gettextf("XLGetRange(file = %s, sheet = %s,\n     range = c(%s),\n     as.data.frame = %s, header = %s, stringsAsFactors = %s)", 
                                gsub("\\\\", "\\\\\\\\", shQuote(paste(xl$ActiveWorkbook()$Path(), 
                                                                       xl$ActiveWorkbook()$Name(), sep = "\\"))), shQuote(xl$ActiveSheet()$Name()), 
                                gettextf(paste(shQuote(range), collapse = ",")), as.data.frame, 
                                header, stringsAsFactors)
  
  if (!is.null(file)) {
    xl$ActiveWorkbook()$Close(savechanges = FALSE)
    xl$Quit()                  # only quit, if a new XL-instance was created before
  }
  
  if (echo) 
    cat(attr(lst, "call"))

  class(lst) <- c("xlrange", class(lst))
  return(lst)
  
}



as.matrix.xlrange <- function(x, ...){
  SetNames(as.matrix(x[[1]]), rownames=x[[2]][,1], colnames=x[[3]][1,])
}



XLGetWorkbook <- function (file, compactareas = TRUE) {


  IsEmptySheet <- function(sheet)
    sheet$UsedRange()$Rows()$Count() == 1 &
    sheet$UsedRange()$columns()$Count() == 1 &
    is.null(sheet$cells(1,1)$Value())

  CompactArea <- function(lst)
    do.call(cbind, lapply(lst, cbind))


  # xlCellTypeConstants <- 2
  # xlCellTypeFormulas <- -4123

  xl <- GetNewXL()
  wb <- xl[["Workbooks"]]$Open(file)

  lst <- list()
  for (i in 1:wb$Sheets()$Count()) {

    if(!IsEmptySheet(sheet=xl$Sheets(i))) {

      # has.formula is TRUE, when all cells contain formula, FALSE when no cell contains a formula
      # and NULL else, thus: !identical(FALSE) for having some or all
      if(!identical(xl$Sheets(i)$UsedRange()$HasFormula(), FALSE))
        areas <- xl$union(
          xl$Sheets(i)$UsedRange()$SpecialCells(xlConst$xlCellTypeConstants),
          xl$Sheets(i)$UsedRange()$SpecialCells(xlConst$xlCellTypeFormulas))$areas()
      else
        areas <- xl$Sheets(i)$UsedRange()$SpecialCells(xlConst$xlCellTypeConstants)$areas()

      alst <- list()
      for ( j in 1:areas$count())
        alst[[j]] <- areas[[j]]$Value2()

      lst[[xl$Sheets(i)$name()]] <- alst

    }
  }

  if(compactareas)
    lst <- lapply(lst, function(x) lapply(x, CompactArea))

  # close without saving
  wb$Close(FALSE)

  xl$Quit()
  return(lst)

}



XLKill <- function(){
  # Excel would only quit, when all workbooks are closed before, someone said.
  # http://stackoverflow.com/questions/15697282/excel-application-not-quitting-after-calling-quit

  # We experience, that it would not even then quit, when there's no workbook loaded at all.
  # maybe gc() would help ??
  # so killing the task is "ultima ratio"...

  shell('taskkill /F /IM EXCEL.EXE')
}



XLDateToPOSIXct <- function (x, tz = "GMT", xl1904 = FALSE) {
  # https://support.microsoft.com/en-us/kb/214330
  if(xl1904)
    origin <- "1904-01-01"
  else
    origin <- "1899-12-30"

  as.POSIXct(x * (60 * 60 * 24), origin = origin, tz = tz)
}


###

## PowerPoint functions ====





PpAddSlide <- function(pos = NULL, pp = DescToolsOptions("lastPP")){

  slides <- pp[["ActivePresentation"]][["Slides"]]
  if(is.null(pos)) pos <- slides$Count()+1
  slides$AddSlide(pos, slides$Item(1)[["CustomLayout"]])$Select()

  invisible()
}



PpText <- function (txt, x=1, y=1, height=50, width=100, fontname = "Calibri", fontsize = 18, bold = FALSE,
                    italic = FALSE, col = "black", bg = "white", hasFrame = TRUE, pp = DescToolsOptions("lastPP")) {

  msoShapeRectangle <- 1

  if (!inherits(x=txt, what="character"))
    txt <- .CaptOut(txt)
#  slide <- pp[["ActivePresentation"]][["Slides"]]$Item(1)
  slide <- pp$ActiveWindow()$View()$Slide()
  shape <- slide[["Shapes"]]$AddShape(msoShapeRectangle, x, y, x + width, y+height)
  textbox <- shape[["TextFrame"]]
  textbox[["TextRange"]][["Text"]] <- txt

  tbfont <- textbox[["TextRange"]][["Font"]]
  tbfont[["Name"]] <- fontname
  tbfont[["Size"]] <- fontsize
  tbfont[["Bold"]] <- bold
  tbfont[["Italic"]] <- italic
  tbfont[["Color"]] <- RgbToLong(ColToRgb(col))

  textbox[["MarginBottom"]] <- 10
  textbox[["MarginLeft"]] <- 10
  textbox[["MarginRight"]] <- 10
  textbox[["MarginTop"]] <- 10

  shp <- shape[["Fill"]][["ForeColor"]]
  shp[["RGB"]] <- RgbToLong(ColToRgb(bg))
  shp <- shape[["Line"]]
  shp[["Visible"]] <- hasFrame

  invisible(shape)

}





PpPlot <- function( type="png", crop=c(0,0,0,0),
                     picscale=100, x=1, y=1, height=NA, width=NA, res=200, dfact=1.6, pp = DescToolsOptions("lastPP") ){

  # height, width in cm!
  # scale will be overidden, if height/width defined

  # Example: PpPlot(picscale=30)
  #          PpPlot(width=8)

  CmToPts <- function(x) x * 28.35
  PtsToCm <- function(x) x / 28.35
  # http://msdn.microsoft.com/en-us/library/bb214076(v=office.12).aspx

  # handle missing height or width values
  if (is.na(width) ){
    if (is.na(height)) {
      width <- 14
      height <- par("pin")[2] / par("pin")[1] * width
    } else {
      width <- par("pin")[1] / par("pin")[2] * height
    }
  } else {
    if (is.na(height) ){
      height <- par("pin")[2] / par("pin")[1] * width
    }
  }


  # get a [type] tempfilename:
  fn <- paste( tempfile(pattern = "file", tmpdir = tempdir()), ".", type, sep="" )
  # this is a problem for RStudio....
  # savePlot( fn, type=type )
  # png(fn, width=width, height=height, units="cm", res=300 )
  dev.copy(eval(parse(text=type)), fn, width=width*dfact, height=height*dfact, res=res, units="cm")
  d <- dev.off()


  # slide <- pp[["ActivePresentation"]][["Slides"]]$Item(1)
  slide <- pp$ActiveWindow()$View()$Slide()
  pic <- slide[["Shapes"]]$AddPicture(fn, FALSE, TRUE, x, y)

  picfrmt <- pic[["PictureFormat"]]
  picfrmt[["CropBottom"]] <- CmToPts(crop[1])
  picfrmt[["CropLeft"]] <- CmToPts(crop[2])
  picfrmt[["CropTop"]] <- CmToPts(crop[3])
  picfrmt[["CropRight"]] <- CmToPts(crop[4])

  if( is.na(height) & is.na(width) ){
    # or use the ScaleHeight/ScaleWidth attributes:
    msoTrue <- -1
    msoFalse <- 0
    pic$ScaleHeight(picscale/100, msoTrue)
    pic$ScaleWidth(picscale/100, msoTrue)

  } else {
    # Set new height:
    if( is.na(width) ) width <- height / PtsToCm( pic[["Height"]] ) * PtsToCm( pic[["Width"]] )
    if( is.na(height) ) height <- width / PtsToCm( pic[["Width"]] ) * PtsToCm( pic[["Height"]] )
    pic[["Height"]] <- CmToPts(height)
    pic[["Width"]] <- CmToPts(width)
  }

  if( file.exists(fn) ) { file.remove(fn) }

  invisible( pic )

}



SendOutlookMail <- function(to, cc=NULL, bcc=NULL, subject, body, attachment=NULL){
  
  out <- GetCOMAppHandle("Outlook.Application", existing=TRUE)
  
  mail <- out$CreateItem(0)
  mail[["to"]] <- to
  if(!is.null(cc)) mail[["cc"]] <- cc
  if(!is.null(bcc)) mail[["bcc"]] <- bcc
  mail[["subject"]] <- subject
  mail[["body"]] <- body
  
  ## Add attachments
  if(!is.null(attachment)) 
    sapply(attachment, function(x) mail[["Attachments"]]$Add(x))
  
  ## senden                  
  mail$Send()
  
  rm(out, mail)
  gc() 
  
  invisible()
  
}



createCOMReference <- function(ref, className) {
  RDCOMClient::createCOMReference(ref, className)
}



IsValidPtr <- function(pointer) {
  if(is(pointer, "externalptr") | is(pointer, "COMIDispatch"))
    !.Call("isnil", pointer)
  else 
    FALSE
}


IsValidHwnd <- function(hwnd){
  # returns TRUE if the selection of the pointer can be evaluated
  # meaning the pointer points to a running word/excel/powerpoint instance and so far valid
  if(!is.null(hwnd) && IsValidPtr(hwnd) )
    res <- !inherits(tryCatch(hwnd[["Selection"]], error=function(e) {e}), 
                     "simpleError")   # Error in
  else 
    res <- FALSE
  
  return(res)
  
}




GetCOMAppHandle <- function(app, option=NULL, existing=FALSE, visible=NULL){
  
  if (requireNamespace("RDCOMClient", quietly = FALSE)) {
    
    if(!existing)
      # there's no "get"-function in RDCOMClient, so just create a new here..
      hwnd <- RDCOMClient::COMCreate(app, existing=existing)
    else
      hwnd <- RDCOMClient::getCOMInstance(app)

    if(is.null(hwnd)) 
      warning(gettext("No running %s application found!", app))
    else
      if(!is.null(visible))     hwnd[["Visible"]] <- visible
    
    
    # set the DescTools option, if required
    if(!is.null(option))
      eval(parse(text=gettextf("DescToolsOptions(%s = hwnd)", option)))
    
  } else {
    
    # no RDCOMClient present or not Windows system
    if(Sys.info()["sysname"] == "Windows")
      warning("RDCOMClient is not available. To install it use: install.packages('RDCOMClient', repos = 'http://www.stats.ox.ac.uk/pub/RWin/')")
    else
      warning(gettextf("RDCOMClient is unfortunately not available for %s systems (Windows-only).", Sys.info()["sysname"]))
    
    hwnd <- NULL
  }
  
  return(hwnd)
  
}



GetCurrWrd <- function() {
  hwnd <- GetCOMAppHandle("Word.Application", option="lastWord", existing=TRUE)
}



GetNewWrd <- function (visible = TRUE, template = "Normal", header = FALSE, 
                       main = "Descriptive report") {
  
  hwnd <- GetCOMAppHandle("Word.Application", option = "lastWord", 
                                      existing = FALSE, visible = TRUE)
  
  if (!is.null(hwnd)) {
    newdoc <- hwnd[["Documents"]]$Add(template, FALSE, 0)
    
    if (template=="Normal" && header) 
      .WrdPrepRep(wrd = hwnd, main = main)
    
    # Check for existance of bookmark Main and update if found
    if(!is.null(WrdBookmark(name = "Main", wrd = hwnd))){
      WrdUpdateBookmark(name="Main", text = main, wrd=hwnd)
      WrdUpdateFields(wrd=hwnd, where = c(1,7))
    }
  }
  
  invisible(hwnd)
}



# wdCommentsStory = 4,
# wdEndnoteContinuationNoticeStory = 17,
# wdEndnoteContinuationSeparatorStory = 16,
# wdEndnoteSeparatorStory = 15,
# wdEndnotesStory = 3,
# wdEvenPagesFooterStory = 8,
# wdEvenPagesHeaderStory = 6,
# wdFirstPageFooterStory = 11,
# wdFirstPageHeaderStory = 10,
# wdFootnoteContinuationNoticeStory = 14,
# wdFootnoteContinuationSeparatorStory = 13,
# wdFootnoteSeparatorStory = 12,
# wdFootnotesStory = 2,
# wdMainTextStory = 1,
# wdPrimaryFooterStory = 9,
# wdPrimaryHeaderStory = 7,
# wdTextFrameStory = 5)




GetNewXL <- function(visible = TRUE, newdoc = TRUE) {
  
  hwnd <- GetCOMAppHandle("Excel.Application", option="lastXL", existing=FALSE, visible=TRUE)
  
  if(!is.null(hwnd)){
    
    # Create a new workbook
    # react the same as GetNewWrd(), Word is also starting with a new document
    # whereas XL would not
    if(newdoc)      hwnd[["Workbooks"]]$Add()
    
  }
  
  invisible(hwnd)
  
}


GetCurrXL <- function() {

  hwnd <- GetCOMAppHandle("Excel.Application", option="lastXL", existing=TRUE)
  invisible(hwnd)
}



GetNewPP <- function (visible = TRUE, template = "Normal") {

  hwnd <- GetCOMAppHandle("PowerPoint.Application", option="lastPP", existing=FALSE, visible=TRUE)
  
  if(!is.null(hwnd)){
    
    newpres <- hwnd[["Presentations"]]$Add(TRUE)
    ppLayoutBlank <- 12
    newpres[["Slides"]]$Add(1, ppLayoutBlank)
    
  }
  
  invisible(hwnd)  
  
}


GetCurrPP <- function() {
  
  hwnd <- GetCOMAppHandle("PowerPoint.Application", option="lastPP", existing=TRUE)
  invisible(hwnd)
}




WrdKill <- function(){
  # Word might not always quit and end the task
  # so killing the task is "ultima ratio"...
  
  shell('taskkill /F /IM WINWORD.EXE')
}




CourseData <- function(name, url=NULL, header=TRUE, sep=";", ...){

  if(grepl("xls", tools::file_ext(name))) {
    res <- OpenDataObject(name=name, url=url, ...)
    
  } else {
  
    if(length(grep(pattern = "\\..{3}", x = name))==0)
      name <- paste(name, ".txt", sep="")
    if(is.null(url))
      url <- "http://www.signorell.net/hwz/datasets/"
    url <- gettextf(paste(url, "%s", sep=""), name)
    res <- read.table(file = url, header = header, sep = sep, ...)
  }
  
  return(res)
     
}




OpenDataObject <- function(name, url=NULL, 
                           doc=list(Description=c("Variable", "Beschreibung", "Codes", "Skala")), 
                           ...){


  if(is.null(url))
    url <- "http://www.signorell.net/hwz/datasets/"
  url <- gettextf(paste(url, "%s", sep=""), name)
  
  resp <- httr::GET(url = url, httr::write_disk(tf <- tempfile()))
  if(http_status(resp)$category != "Success") 
    stop(resp)
  
  z <- as.data.frame(read_excel(tf))
  
  if(!is.na(doc)) {

    # the documentation sheet must contain the following columns
    doc_sheet <- names(doc)    # default is Description
    col_var <- doc[[1]][1]
    col_lbl <- doc[[1]][2]
    col_code <- doc[[1]][3]
    col_scale <- doc[[1]][4]
    
    code <- as.data.frame(read_excel(tf, sheet = doc_sheet))
    # use only currentrange("A1"), say: clip on the first completely empty row
    code <- code[1:(min(which(apply(code, 1, 
                                    function(x) sum(is.na(x)) == ncol(code))))-1),]
    
    # Define factors
    id <- which(code[[col_scale]] %in% c("nominal", "ordinal"))
    codes <- lapply(strsplit(code[[col_code]][id], "\\r\\n"), strsplit, split="=")
    names(codes) <- code[[col_var]][id]
    
    for(x in code[[col_var]][id]){
      z[, x] <- factor(z[, x], 
                       ordered = (code[[col_scale]][code[[col_var]] == x]) == "ordinal")
      
      # could also not be defined, e.g. patient id (nominal, but no codes)
      if(!identical(codes[[x]], NA)){
        levels(z[, x]) <- StrTrim(sapply(codes[[x]], "[", 2))[
                      match(levels(z[, x]), StrTrim(sapply(codes[[x]], "[", 1)))]
      }
    }
  
    # Labels:
    for(x in code[[col_var]])
      Label(z[, x]) <- na.omit(code[[col_lbl]][code[[col_var]] == x])
    
  }
  
  return(z)
  
}




as.statafactor <- function(x){
  res <- factor(x, levels=attr(x, "labels"), labels=names(attr(x, "labels")))
  attr(res, "label") <- attr(x, "label")
  res
}





###


## Entwicklungs-Ideen ====


# With ActiveDocument.Bookmarks
# .Add Range:=Selection.Range, Name:="start"
# .DefaultSorting = wdSortByName
# .ShowHidden = False
# End With
# Selection.TypeText Text:="Hier kommt mein Text"
# Selection.TypeParagraph
# Selection.TypeText Text:="und auf weiteren Zeilen"
# Selection.TypeParagraph
# With ActiveDocument.Bookmarks
# .Add Range:=Selection.Range, Name:="stop"
# .DefaultSorting = wdSortByName
# .ShowHidden = False
# End With
# Selection.GoTo What:=wdGoToBookmark, Name:="start"
# Selection.GoTo What:=wdGoToBookmark, Name:="stop"
# With ActiveDocument.Bookmarks
# .DefaultSorting = wdSortByName
# .ShowHidden = False
# End With
# Selection.MoveLeft Unit:=wdWord, Count:=2, Extend:=wdExtend
# Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
# Selection.Font.Name = "Arial Black"
# Selection.EndKey Unit:=wdStory
# Selection.GoTo What:=wdGoToBookmark, Name:="stop"
# Selection.Find.ClearFormatting
# With Selection.Find
# .Text = "0."
# .Replacement.Text = " ."
# .Forward = True
# .Wrap = wdFindContinue
# .Format = False
# .MatchCase = False
# .MatchWholeWord = False
# .MatchWildcards = False
# .MatchSoundsLike = False
# .MatchAllWordForms = False
# End With
# ActiveDocument.Bookmarks("start").Delete
# With ActiveDocument.Bookmarks
# .DefaultSorting = wdSortByName
# .ShowHidden = False
# End With
# End Sub
# wdSortByName =0
# wdGoToBookmark = -1
# wdFindContinue = 1
# wdStory = 6



# Bivariate Darstellungen gute uebersicht
# pairs( lapply( lapply( c( d.set[,-1], list()), "as.numeric" ), "jitter" ), col=rgb(0,0,0,0.2) )


# Gruppenweise Mittelwerte fuer den ganzen Recordset
# wrdInsertText( "Mittelwerte zusammengefasst\n\n" )
# wrdInsertSummary(
# signif( cbind(
# t(as.data.frame( lapply( d.frm, tapply, grp, "mean", na.rm=TRUE )))
# , tot=mean(d.frm, na.rm=TRUE)
# ), 3)