R/DescTools.r

In AndriSignorell/DescTools: Tools for Descriptive Statistics

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



# 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[ x!=0 ]
}



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

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

}




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

  # 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
  if((y <- round(x/100)) %[]% c(1000, 3000) & (x - y*100) %[]% c(1, 12) ) 
    structure(as.integer(x), class = c("ym", "num")) 
  else 
    structure(NA_integer_, class = c("ym", "num")) 
  
}

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


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)

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




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)