#
# Project: DescTools
#
# Purpose: Tools for descriptive statistics, the missing link...
# Univariat, pairwise bivariate, groupwise und multivariate
#
# Author: Andri Signorell
# Version: 0.99.19 (under construction)
#
# Depends: tcltk
# Imports: boot
# Suggests: RDCOMClient
#
# Datum:
# 31.07.2013 version 0.99.4 almost releaseable
# 06.05.2011 created
#
# ****************************************************************************
# ********** DescTools' design goals, Dos and Donts
# Some thoughts about coding:
# 1. Use recycling rules as often and wherever possible.
# 2. Handle NAs by adding an na.rm option (default FALSE) where it makes sense.
# 3. Use Google Naming StyleGuide
# 4. no data.frame or matrix interfaces for functions, the user is supposed to use
# sapply and apply.
# Interfaces for data.frames are widely deprecated nowadays and so we abstained to implement one.
# Use do.call (do.call), rbind and lapply for getting a matrix with estimates and confidence
# intervals for more than 1 column.
# 5. A pairwise apply construction is implemented PwApply
# 6. Use formula interfaces wherever possible.
# 7. use test results format class "htest"
# 8. deliver confidence intervals wherever possible, rather than tests (use ci for that)
# 9. always define appropriate default values for function arguments
# 10. provide an inverse function whenever possible (ex.: BoxCox - BoxCoxInv)
# 11. auxiliary functions, which don't have to be defined globally are put in the function's body
# (and not made invisible to the user by using .funname)
# 12. restrict the use of other libraries to the minimum (possibly only core),
# avoid hierarchical dependencies of packages over more than say 2 steps
# 13. do not create wrappers, which basically only define specific arguments and
# call an existing function (we would run into a forest of functions, loosing overview)
# 14. make functions as flexible as possible but do not define more than say
# a maximum of 12 arguments for a function (can hardly be controlled by the user)
# 15. define reasonable default values for possibly all used arguments
# (besides x), the user should get some result when typing fun(x)!
# 16. do not reinvent the wheel
# 17. do not write a function for a problem already solved(!), unless you think
# it is NOT (from your point of view) and you are pretty sure you can do better..
# 18. take the most flexible function on the market, if there are several
# take the most efficient function on the market, if there are differences in speed
# 19. make it work - make it safe - make it fast (in this very order...)
# 20. possibly publish all functions, if internal functions are used, define it within
# the functions body, this will ensure a quick source lookup.
# ********** Similar packages:
# - descr, UsingR
# - prettyR
# - reporttools
# - lessR (full)
# - Hmisc (describe)
# - psych
# check:
# library(pwr) # Power-Analyse
# http://www.ats.ucla.edu/stat/r/dae/t_test_power2.htm
# Data in packages
# http://www.hep.by/gnu/r-patched/r-exts/R-exts_8.html
# library(gtools): odd zu IsOdd, vgl: stars.pval
# library(e1071): hamming.distance, hamming.window, hsv_palette, matchControls (SampleTwins)
# library(plotrix): color.id (RgbToCol), color.scale (FindColor)
# vgl: PlotCI (plotCI), plot_bg
# ********** Know issues:
# bug: Desc( driver + temperature ~ operator + interaction(city, driver, sep=":") , data=d.pizza)
# works: Desc( driver + temperature ~ operator + interaction(city, driver, sep=".") , data=d.pizza)
# works: Desc( driver + temperature ~ operator + city:driver, data=d.pizza)
# - bei der Anwendung von tapply wird die Bezeichnung des Levels nicht verwendet
# Beispiel:
# tapply( d.pizza$delivery_min, d.pizza$driver, Desc )
# Problem: Titel und level kommt nicht mit ***CLEARME***CLEARME***CLEARME***CLEARME***CLEARME***
# - DescWrd.factor.factor gibt die Argumente an WrdText nicht weiter? fontsize, etc. (17.4.2012)
# - ein langer label fuehrt dazu, dass die Tabellenausgabe umgebrochen wird und die Grafik unter dem Text plaziert wird.
# this error arises when no plot windows exists, but is the same for boxplot, so we leave it here
# PlotViolin(temperature ~ driver, d.pizza, col="steelblue", panel.first=grid())
# Error in int_abline(a = a, b = b, h = h, v = v, untf = untf, ...) :
# plot.new has not been called yet
# Shooting list .....
# importFrom("manipulate", "manipulate", "picker","button","checkbox","slider")
# importFrom("foreign", "read.spss", "read.dta") SPSS is not needed anymore, but Systat is
# ********** Open implementations:
# functions:
# polychor, tetrachor
# Cohen's effect fformat(ISOdate(2000, 1:12, 1), "%B")ct
# Cohen's effect hlp
# eta fct lines
# eta hlp
# eta2 <- function(x,y) {
# return(summary(lm(as.formula(x~y)))$r.squared)
# }
# open multiple comparisons:
# ScottKnott test (scottknott),
# Waller-Duncan test (agricolae), Gabriel test (not found)
# flag ~ flag mit mosaicplot und allgemein bivariate darstellung
# ConDisPairs als O(n log(n)) AVL-Tree implementation
# PlotMultiDens stack and 100% (cdplot)
#
# PlotCirc for symmetric tables
# Konsequente ueberpruefung der uebergabe und weiterreichung der parameter
# z.B. was ist mit Boxplot las?
# uebersicht, was wird wo vewendet, z.b. kommt rfrq ueberhaupt an bei Desc(data.frame)
# Was ist die maximale Menge an parameter?
# - Tabellen factor ~ factor nebeneinander wenn Platz
# PercTable tasks:
# Sum, perc, usw. Texte parametrisieren
# 0 values als '-' optional anzeigen
# Format perc stimmt im ersten Fall nicht, parametrisieren?
# Reihenfolge Zuerich, perc vs. perc , Zuerich wechselbar machen. Ist das schon?
# faqNC <- function() browseURL("http://www.ncfaculty.net/dogle/R/FAQ/FAQ_R_NC.html")
# Formula-Interface fuer PlotBag
# - replace .fmt by Format
# - DescDlg
# - Object Browser a la RevoR
# - Fixierung Nachkommastellen pro Variable - geloest, aber unbefriedigend
# sollte unterscheiden zwischen kleinen (1.22e-22), mittleren (100.33) und
# grossen Zahlen (1.334e5)
# grosse Zahlen mit Tausendertrennzeichen ausgegeben: 13'899
# - Alle PlotDesc sollten so funktionieren wie Desc, also mit data, ohne data etc.
# wenn mal viel Zeit: test routinen mit htest result fuer
# SomersDelta, GoodmanKruskal etc.
# separate Data ========
# Creation of the Page distribution function for the Page TrendTest
#
# .PageDF <- list(
# NA, NA
# , k3 = c(1, 3, 3, 5, 6)
# , k4 = c(1, 4, 5, 9, 11, 13, 15, 19, 20, 23, 24)
# , k5 = c(1, 5, 8, 14, 21, 27, 31, 41, 47, 57, 63, 73, 79, 89, 93, 99, 106, 112, 115, 119, 120)
# , k6 = c(1, 6, 12, 21, 37, 49, 63, 87, 107, 128, 151, 179, 203, 237,
# 257, 289, 331, 360, 389, 431, 463, 483, 517, 541, 569, 592, 613,
# 633, 657, 671, 683, 699, 708, 714, 719, 720)
# , k7 = c(1, 7, 17, 31, 60, 86, 121, 167, 222, 276, 350, 420, 504, 594,
# 672, 762, 891, 997, 1120, 1254, 1401, 1499, 1667, 1797, 1972,
# 2116, 2284, 2428, 2612, 2756, 2924, 3068, 3243, 3373, 3541, 3639,
# 3786, 3920, 4043, 4149, 4278, 4368, 4446, 4536, 4620, 4690, 4764,
# 4818, 4873, 4919, 4954, 4980, 5009, 5023, 5033, 5039, 5040)
# , k8 = c(1, 8, 23, 45, 92, 146, 216, 310, 439, 563, 741, 924, 1161,
# 1399, 1675, 1939, 2318, 2667, 3047, 3447, 3964, 4358, 4900, 5392,
# 6032, 6589, 7255, 7850, 8626, 9310, 10096, 10814, 11736, 12481,
# 13398, 14179, 15161, 15987, 16937, 17781, 18847, 19692, 20628,
# 21473, 22539, 23383, 24333, 25159, 26141, 26922, 27839, 28584,
# 29506, 30224, 31010, 31694, 32470, 33065, 33731, 34288, 34928,
# 35420, 35962, 36356, 36873, 37273, 37653, 38002, 38381, 38645,
# 38921, 39159, 39396, 39579, 39757, 39881, 40010, 40104, 40174,
# 40228, 40275, 40297, 40312, 40319, 40320)
# , k9 = c(1, 9, 30, 64, 136, 238, 368, 558, 818, 1102, 1500, 1954, 2509,
# 3125, 3881, 4625, 5647, 6689, 7848, 9130, 10685, 12077, 13796,
# 15554, 17563, 19595, 21877, 24091, 26767, 29357, 32235, 35163,
# 38560, 41698, 45345, 48913, 52834, 56700, 61011, 65061, 69913,
# 74405, 79221, 84005, 89510, 94464, 100102, 105406, 111296, 116782,
# 122970, 128472, 134908, 140730, 146963, 152987, 159684, 165404,
# 172076, 178096, 184784, 190804, 197476, 203196, 209893, 215917,
# 222150, 227972, 234408, 239910, 246098, 251584, 257474, 262778,
# 268416, 273370, 278875, 283659, 288475, 292967, 297819, 301869,
# 306180, 310046, 313967, 317535, 321182, 324320, 327717, 330645,
# 333523, 336113, 338789, 341003, 343285, 345317, 347326, 349084,
# 350803, 352195, 353750, 355032, 356191, 357233, 358255, 358999,
# 359755, 360371, 360926, 361380, 361778, 362062, 362322, 362512,
# 362642, 362744, 362816, 362850, 362871, 362879, 362880)
# , k10 = c(1, 10, 38, 89, 196, 373, 607, 967, 1465, 2084, 2903, 3943, 5195, 6723, 8547, 10557, 13090, 15927, 19107, 22783, 27088, 31581, 36711, 42383, 48539, 55448, 62872, 70702, 79475, 88867, 98759, 109437, 121084, 133225, 146251, 160169, 174688, 190299, 206577, 223357, 242043, 261323, 280909, 301704, 324089, 346985, 370933, 395903, 421915, 449011, 477478, 505905, 536445, 567717, 599491, 632755, 667503, 702002, 738301, 774897, 813353, 852279, 892263, 931649, 973717, 1016565, 1058989, 1101914, 1146958, 1191542, 1237582, 1283078, 1329968, 1377004, 1424345, 1471991, 1520878, 1569718, 1617762, 1666302, 1716368, 1765338, 1814400, 1863462, 1912432, 1962498, 2011038, 2059082, 2107922, 2156809, 2204455, 2251796, 2298832, 2345722, 2391218, 2437258, 2481842, 2526886, 2569811, 2612235, 2655083, 2697151, 2736537, 2776521, 2815447, 2853903, 2890499, 2926798, 2961297, 2996045, 3029309, 3061083, 3092355, 3122895, 3151322, 3179789, 3206885, 3232897, 3257867, 3281815, 3304711, 3327096, 3347891, 3367477, 3386757, 3405443, 3422223, 3438501, 3454112, 3468631, 3482549, 3495575, 3507716, 3519363, 3530041, 3539933, 3549325, 3558098, 3565928, 3573352, 3580261, 3586417, 3592089, 3597219, 3601712, 3606017, 3609693, 3612873, 3615710, 3618243, 3620253, 3622077, 3623605, 3624857, 3625897, 3626716, 3627335, 3627833, 3628193, 3628427, 3628604, 3628711, 3628762, 3628790, 3628799, 3628800)
#
# , k11 = c(1, 11, 47, 121, 277, 565, 974, 1618, 2548, 3794, 5430, 7668, 10382, 13858, 18056, 23108, 29135, 36441, 44648, 54464, 65848, 78652, 92845, 109597, 127676, 148544, 171124, 196510, 223843, 254955, 287403, 323995, 363135, 406241, 451019, 501547, 553511, 610953, 670301, 735429, 803299, 877897, 953161, 1036105, 1122228, 1215286, 1309506, 1413368, 1518681, 1632877, 1749090, 1874422, 2002045, 2140515, 2278832, 2429566, 2581919, 2744859, 2908190, 3085090, 3263110, 3453608, 3643760, 3847514, 4052381, 4272633, 4489678, 4722594, 4956028, 5204156, 5449644, 5712530, 5973493, 6250695, 6523539, 6816137, 7104526, 7411262, 7710668, 8030252, 8345178, 8678412, 9002769, 9348585, 9686880, 10046970, 10393880, 10763840, 11125055, 11506717, 11876164, 12267556, 12646883, 13049009, 13434313, 13845399, 14241951, 14660041, 15058960, 15484804, 15894731, 16324563, 16734970, 17170868, 17587363, 18027449, 18444344, 18884724, 19305912, 19748160, 20168640, 20610888, 21032076, 21472456, 21889351, 22329437, 22745932, 23181830, 23592237, 24022069, 24431996, 24857840, 25256759, 25674849, 26071401, 26482487, 26867791, 27269917, 27649244, 28040636, 28410083, 28791745, 29152960, 29522920, 29869830, 30229920, 30568215, 30914031, 31238388, 31571622, 31886548, 32206132, 32505538, 32812274, 33100663, 33393261, 33666105, 33943307, 34204270, 34467156, 34712644, 34960772, 35194206, 35427122, 35644167, 35864419, 36069286, 36273040, 36463192, 36653690, 36831710, 37008610, 37171941, 37334881, 37487234, 37637968, 37776285, 37914755, 38042378, 38167710, 38283923, 38398119, 38503432, 38607294, 38701514, 38794572, 38880695, 38963639, 39038903, 39113501, 39181371, 39246499, 39305847, 39363289, 39415253, 39465781, 39510559, 39553665, 39592805, 39629397, 39661845, 39692957, 39720290, 39745676, 39768256, 39789124, 39807203, 39823955, 39838148, 39850952, 39862336, 39872152, 39880359, 39887665, 39893692, 39898744, 39902942, 39906418, 39909132, 39911370, 39913006, 39914252, 39915182, 39915826, 39916235, 39916523, 39916679, 39916753, 39916789, 39916799, 39916800)
#
# , k12 = c(1, 12, 57, 161, 385, 832, 1523, 2629, 4314, 6678, 9882, 14397, 20093, 27582, 36931, 48605, 62595, 80232, 100456, 125210, 154227, 188169, 226295, 272179, 322514, 381283, 446640, 521578, 602955, 697449, 798012, 913234, 1037354, 1177139, 1325067, 1493942, 1670184, 1867627, 2075703, 2306597, 2547605, 2817918, 3095107, 3402876, 3723206, 4075092, 4436130, 4836594, 5245232, 5694249, 6155263, 6658390, 7171170, 7734985, 8304533, 8927791, 9562307, 10250749, 10946272, 11707175, 12472247, 13304674, 14143124, 15051520, 15964324, 16958207, 17951038, 19024576, 20103385, 21266520, 22428668, 23688490, 24941145, 26293113, 27640685, 29092979, 30538037, 32094364, 33635325, 35292663, 36939122, 38705429, 40450799, 42327667, 44179645, 46167953, 48128734, 50226064, 52293360, 54508939, 56686818, 59015668, 61303483, 63746140, 66141668, 68703444, 71211606, 73883239, 76497639, 79284492, 82008603, 84912335, 87739711, 90750133, 93683865, 96803338, 99840816, 103063901, 106199027, 109522404, 112757434, 116187490, 119511072, 123034744, 126446666, 130064197, 133565830, 137269085, 140848253, 144633119, 148294783, 152161902, 155889546, 159821171, 163617371, 167622510, 171480066, 175541648, 179449088, 183562195, 187525039, 191692873, 195691020, 199891634, 203924412, 208164174, 212229695, 216488881, 220574078, 224852631, 228953203, 233247651, 237351468, 241650132, 245753949, 250048397, 254148969, 258427522, 262512719, 266771905, 270837426, 275077188, 279109966, 283310580, 287308727, 291476561, 295439405, 299552512, 303459952, 307521534, 311379090, 315384229, 319180429, 323112054, 326839698, 330706817, 334368481, 338153347, 341732515, 345435770, 348937403, 352554934, 355966856, 359490528, 362814110, 366244166, 369479196, 372802573, 375937699, 379160784, 382198262, 385317735, 388251467, 391261889, 394089265, 396992997, 399717108, 402503961, 405118361, 407789994, 410298156, 412859932, 415255460, 417698117, 419985932, 422314782, 424492661, 426708240, 428775536, 430872866, 432833647, 434821955, 436673933, 438550801, 440296171, 442062478, 443708937,
# 445366275, 446907236, 448463563, 449908621, 451360915, 452708487, 454060455, 455313110, 456572932, 457735080, 458898215, 459977024, 461050562, 462043393, 463037276, 463950080, 464858476, 465696926, 466529353, 467294425, 468055328, 468750851, 469439293, 470073809, 470697067, 471266615, 471830430, 472343210, 472846337, 473307351, 473756368, 474165006, 474565470, 474926508, 475278394, 475598724, 475906493, 476183682, 476453995, 476695003, 476925897, 477133973, 477331416, 477507658, 477676533, 477824461, 477964246, 478088366, 478203588, 478304151, 478398645, 478480022, 478554960, 478620317, 478679086, 478729421, 478775305, 478813431, 478847373, 478876390, 478901144, 478921368, 478939005, 478952995, 478964669, 478974018, 478981507, 478987203, 478991718, 478994922, 478997286, 478998971, 479000077, 479000768, 479001215, 479001439, 479001543, 479001588, 479001599, 479001600 )
#
# , k13 = c(1, 13, 68, 210, 527, 1197, 2324, 4168, 7119, 11429, 17517, 26225, 37812, 53230, 73246, 98816, 130483, 170725, 218750, 278034, 349136, 434162, 532482, 651024, 785982, 944022, 1124332, 1332640, 1565876, 1835792, 2132840, 2472812, 2848749, 3273357, 3735585, 4260527, 4827506, 5461252, 6147299, 6908609, 7725716, 8635460, 9600260, 10666252, 11804773, 13050503, 14365677, 15812701, 17335403, 18994955, 20742001, 22638493, 24624900, 26787112, 29032733, 31464927, 34008755, 36743621, 39579021, 42647201, 45817786, 49226378, 52752239, 56535435, 60435209, 64628147, 68927405, 73528499, 78274283, 83329815, 88504447, 94050417, 99720505, 105759011, 111937321, 118508917, 125224959, 132372517, 139644194, 147366078, 155251313, 163598355, 172068955, 181074075, 190212385, 199875487, 209687980, 220053214, 230566521, 241680167, 252905559, 264763303, 276775771, 289421809, 302176267, 315640063, 329231261, 343509837, 357915454, 373057790, 388317114, 404365328, 420470916, 437394874, 454438992, 472280042, 490183678, 508970736, 527836540, 547557794, 567333404, 588036304, 608771329, 630463117, 652127890, 674778950, 697468748, 721126694, 744732766, 769392312, 794014392, 819670692, 845236737, 871892593, 898464180, 926132356, 953650676, 982290898, 1010834369, 1040477655, 1069921254, 1100563830, 1131007339, 1162609975, 1193943276, 1226507722, 1258827639, 1292328257, 1325502938, 1359918362, 1394027869, 1429370035, 1464279071, 1500517059, 1536339992, 1573396522, 1609980791, 1647854021, 1685286706, 1723967698, 1762082365, 1801533261, 1840420643, 1880601675, 1920106583, 1960960701, 2001224218, 2042719638, 2083488859, 2125600829, 2167005742, 2209678334, 2251531986, 2294726538, 2337123023, 2380790291, 2423568572, 2467632034, 2510865295, 2555331665, 2598793469, 2643582407, 2687416596, 2732465154, 2776464125, 2821723625, 2865981806, 2911394478, 2955721182, 3001237104, 3045709215, 3091307829, 3135712971, 3181311585, 3225783696, 3271299618, 3315626322, 3361038994, 3405297175, 3450556675, 3494555646, 3539604204, 3583438393, 3628227331, 3671689135, 3716155505,
# 3759388766, 3803452228, 3846230509, 3889897777, 3932294262, 3975488814, 4017342466, 4060015058, 4101419971, 4143531941, 4184301162, 4225796582, 4266060099, 4306914217, 4346419125, 4386600157, 4425487539, 4464938435, 4503053102, 4541734094, 4579166779, 4617040009, 4653624278, 4690680808, 4726503741, 4762741729, 4797650765, 4832992931, 4867102438, 4901517862, 4934692543, 4968193161, 5000513078, 5033077524, 5064410825, 5096013461, 5126456970, 5157099546, 5186543145, 5216186431, 5244729902, 5273370124, 5300888444, 5328556620, 5355128207, 5381784063, 5407350108, 5433006408, 5457628488, 5482288034, 5505894106, 5529552052, 5552241850, 5574892910, 5596557683, 5618249471, 5638984496, 5659687396, 5679463006, 5699184260, 5718050064, 5736837122, 5754740758, 5772581808, 5789625926, 5806549884, 5822655472, 5838703686, 5853963010, 5869105346, 5883510963, 5897789539, 5911380737, 5924844533, 5937598991, 5950245029, 5962257497, 5974115241, 5985340633, 5996454279, 6006967586, 6017332820, 6027145313, 6036808415, 6045946725, 6054951845, 6063422445, 6071769487, 6079654722, 6087376606, 6094648283, 6101795841, 6108511883, 6115083479, 6121261789, 6127300295, 6132970383, 6138516353, 6143690985, 6148746517, 6153492301, 6158093395, 6162392653, 6166585591, 6170485365, 6174268561, 6177794422, 6181203014, 6184373599, 6187441779, 6190277179, 6193012045, 6195555873, 6197988067, 6200233688, 6202395900, 6204382307, 6206278799, 6208025845, 6209685397, 6211208099, 6212655123, 6213970297, 6215216027, 6216354548, 6217420540, 6218385340, 6219295084, 6220112191, 6220873501, 6221559548, 6222193294, 6222760273, 6223285215, 6223747443, 6224172051, 6224547988, 6224887960, 6225185008, 6225454924, 6225688160, 6225896468, 6226076778, 6226234818, 6226369776, 6226488318, 6226586638, 6226671664, 6226742766, 6226802050, 6226850075, 6226890317, 6226921984, 6226947554, 6226967570, 6226982988, 6226994575, 6227003283, 6227009371, 6227013681, 6227016632, 6227018476, 6227019603, 6227020273, 6227020590, 6227020732, 6227020787, 6227020799, 6227020800)
#
# , k14 = c(1, 14, 80, 269, 711, 1689, 3467, 6468, 11472, 19093, 30278, 46574, 69288, 99975, 141304, 195194, 264194, 352506, 462442, 598724, 766789, 970781, 1213870, 1507510, 1853680, 2260125, 2736501, 3291591, 3930026, 4668007, 5508108, 6466862, 7556159, 8787659, 10165645, 11724144, 13460539, 15392221, 17539134, 19922717, 22546063, 25447736, 28627069, 32116076, 35937108, 40106433, 44631074, 49573596, 54926631, 60716114, 66974508, 73740246, 81009240, 88845749, 97239223, 106246902, 115900686, 126216169, 137197091, 148953202, 161446731, 174730758, 188835459, 203837905, 219695178, 236524328, 254283795, 273083666, 292923813, 313860397, 335854799, 359112526, 383528656, 409202706, 436135896, 464473466, 494134210, 525276498, 557815202, 591946436, 627603800, 664907029, 703773267, 744486823, 786877234, 831103465, 877129675, 925182097, 975110533, 1027121161, 1081080881, 1137323422, 1195661689, 1256271970, 1319049120, 1384348268, 1451952010, 1522055063, 1594541080, 1669783989, 1747541228, 1828055758, 1911151548, 1997286462, 2086139682, 2177925841, 2272580839, 2370486063, 2471328513, 2575410222, 2682471831, 2793082385, 2906881741, 3024092956, 3144510886, 3268758800, 3396339981, 3527578003, 3662304885, 3800998837, 3943227695, 4089440734, 4239185132, 4393196954, 4551031331, 4712856765, 4878478438, 5048720892, 5222754969, 5401045094, 5583410846, 5770395123, 5961416258, 6157027619, 6356554732, 6561015163, 6769843465, 6983093805, 7200534248, 7423263710, 7650023569, 7881592853, 8117625307, 8358760439, 8604199870, 8854704639, 9109316970, 9369314835, 9633980748, 9903337745, 10177004917, 10456529218, 10740122230, 11028754748, 11321981370, 11620526571, 11923494567, 12231834199, 12544092637, 12862071155, 13184668352, 13511964024, 13843525611, 14181198310, 14522618329, 14869105782, 15220174133, 15576509168, 15936926462, 16302784406, 16672089744, 17047134658, 17426587171, 17810429228, 18198087372, 18591770156, 18988751460, 19390461912, 19796344325, 20207120401, 20621426516, 21040873172, 21463087253, 21890649743, 22322106033, 22757217771, 23195600046,
# 23639594170, 24086026475, 24536477172, 24990465186, 25448639418, 25909641657, 26374985116, 26842266606, 27314012018, 27788960817, 28266602799, 28746609271, 29231436410, 29717689954, 30206932003, 30698971843, 31193949888, 31690902354, 32191012868, 32692174745, 33196629733, 33703478249, 34211544046, 34720969890, 35234031737, 35747617060, 36262719119, 36779697578, 37298186864, 37817722298, 38338904825, 38860175016, 39383211341, 39907644570, 40431821887, 40956454566, 41483109694, 42009225414, 42535209127, 43062242912, 43589145600, 44116048288, 44643082073, 45169065786, 45695181506, 46221836634, 46746469313, 47270646630, 47795079859, 48318116184, 48839386375, 49360568902, 49880104336, 50398593622, 50915572081, 51430674140, 51944259463, 52457321310, 52966747154, 53474812951, 53981661467, 54486116455, 54987278332, 55487388846, 55984341312, 56479319357, 56971359197, 57460601246, 57946854790, 58431681929, 58911688401, 59389330383, 59864279182, 60336024594, 60803306084, 61268649543, 61729651782, 62187826014, 62641814028, 63092264725, 63538697030, 63982691154, 64421073429, 64856185167, 65287641457, 65715203947, 66137418028, 66556864684, 66971170799, 67381946875, 67787829288, 68189539740, 68586521044, 68980203828, 69367861972, 69751704029, 70131156542, 70506201456, 70875506794, 71241364738, 71601782032, 71958117067, 72309185418, 72655672871, 72997092890, 73334765589, 73666327176, 73993622848, 74316220045, 74634198563, 74946457001, 75254796633, 75557764629, 75856309830, 76149536452, 76438168970, 76721761982, 77001286283, 77274953455, 77544310452, 77808976365, 78068974230, 78323586561, 78574091330, 78819530761, 79060665893, 79296698347, 79528267631, 79755027490, 79977756952, 80195197395, 80408447735, 80617276037, 80821736468, 81021263581, 81216874942, 81407896077, 81594880354, 81777246106, 81955536231, 82129570308, 82299812762, 82465434435, 82627259869, 82785094246, 82939106068, 83088850466, 83235063505, 83377292363, 83515986315, 83650713197, 83781951219, 83909532400, 84033780314, 84154198244, 84271409459, 84385208815, 84495819369,
# 84602880978, 84706962687, 84807805137, 84905710361, 85000365359, 85092151518, 85181004738, 85267139652, 85350235442, 85430749972, 85508507211, 85583750120, 85656236137, 85726339190, 85793942932, 85859242080, 85922019230, 85982629511, 86040967778, 86097210319, 86151170039, 86203180667, 86253109103, 86301161525, 86347187735, 86391413966, 86433804377, 86474517933, 86513384171, 86550687400, 86586344764, 86620475998, 86653014702, 86684156990, 86713817734, 86742155304, 86769088494, 86794762544, 86819178674, 86842436401, 86864430803, 86885367387, 86905207534, 86924007405, 86941766872, 86958596022, 86974453295, 86989455741, 87003560442, 87016844469, 87029337998, 87041094109, 87052075031, 87062390514, 87072044298, 87081051977, 87089445451, 87097281960, 87104550954, 87111316692, 87117575086, 87123364569, 87128717604, 87133660126, 87138184767, 87142354092, 87146175124, 87149664131, 87152843464, 87155745137, 87158368483, 87160752066, 87162898979, 87164830661, 87166567056, 87168125555, 87169503541, 87170735041, 87171824338, 87172783092, 87173623193, 87174361174, 87174999609, 87175554699, 87176031075, 87176437520, 87176783690, 87177077330, 87177320419, 87177524411, 87177692476, 87177828758, 87177938694, 87178027006, 87178096006, 87178149896, 87178191225, 87178221912, 87178244626, 87178260922, 87178272107, 87178279728, 87178284732, 87178287733, 87178289511, 87178290489, 87178290931, 87178291120, 87178291186, 87178291199, 87178291200 )
#
# , k15 = c(1, 15, 93, 339, 946, 2344, 5067, 9845, 18094, 31210, 51135, 80879, 123856, 183350, 265744, 375782, 520770, 709108, 950935, 1254359, 1637783, 2110255, 2688261, 3392105, 4243753, 5253985, 6463435, 7887051, 9559689, 11508657, 13779635, 16385319, 19406949, 22847453, 26778757, 31237429, 36312890, 41988174, 48415169, 55581133, 63617482, 72531890, 82493993, 93449491, 105663309, 119038213, 133821033, 149981059, 167810258, 187138620, 208394580, 231407260, 256572630, 283728734, 313349422, 345140612, 379784963, 416871267, 457037763, 499992359, 546463298, 595886554, 649243982, 705940396, 766920856, 831552862, 900947933, 974276983, 1052930913, 1135866291, 1224452526, 1317816142, 1417501545, 1522137313, 1633652530, 1750626806, 1875052020, 2005336686, 2143665106, 2288248572, 2441639216, 2601691186, 2771087853, 2947714613, 3134569070, 3328885582, 3534148307, 3747528715, 3972688056, 4206327920, 4452435789, 4707707507, 4976502908, 5254730366, 5547265512, 5849894908, 6167966973, 6496524245, 6841251954, 7197208516, 7570606695, 7955492307, 8358702869, 8774325693, 9209487348, 9657140024, 10125565750, 10607269130, 11110947428, 11628498256, 12168723926, 12723609294, 13303228032, 13897378066, 14517038181, 15152582797, 15815095216, 16493452984, 17200382721, 17923779849, 18677052770, 19447720986, 20249039825, 21068309835, 21920989644, 22790961184, 23695090223, 24618800757, 25577947305, 26555930925, 27571664648, 28606831690, 29681188983, 30776084989, 31910591023, 33065874467, 34264718158, 35483254398, 36745418556, 38030320602, 39360005810, 40711195500, 42110524356, 43531199878, 45001319765, 46494257553, 48036654343, 49602075643, 51221875032, 52862604614, 54557065970, 56276716608, 58051331346, 59848489468, 61704800734, 63582981112, 65521450173, 67484389131, 69506528883, 71552497079, 73663855894, 75795896650, 77992481274, 80214974822, 82502403057, 84811883255, 87191972089, 89593082611, 92064881373, 94560883919, 97125402107, 99713005329, 102377610307, 105060302611, 107817686686, 110599694856, 113456740182, 116333639168, 119291579167, 122267356121,
# 125323501236, 128401997238, 131558157109, 134734085833, 137997611218, 141274089126, 144635051739, 148017803651, 151483637626, 154964665476, 158536414603, 162120609581, 165794608949, 169485898871, 173262539499, 177052751993, 180940334728, 184834047000, 188819766650, 192821736664, 196913537154, 201013587060, 205213037672, 209416246916, 213716661616, 218026615728, 222428224181, 226835589231, 231347734832, 235855804736, 240461451056, 245075672864, 249785350011, 254493014069, 259306386598, 264111876662, 269020469253, 273929072733, 278932752466, 283931152738, 289039128373, 294131477475, 299325743006, 304517112400, 309806619906, 315081186550, 320465864608, 325829963244, 331299254515, 336756611895, 342309552544, 347844707934, 353492785526, 359109888388, 364830049809, 370533853771, 376336452468, 382110605480, 387994926455, 393843943991, 399797486177, 405725583879, 411748092537, 417737799943, 423839699258, 429894358406, 436050852136, 442177460900, 448399401827, 454577618889, 460862851875, 467097523711, 473433714049, 479729592211, 486115143213, 492451898587, 498897897209, 505281471971, 511760849379, 518195355931, 524718405991, 531183425467, 537750411835, 544250726707, 550846203604, 557385785810, 564007939322, 570567450178, 577227764133, 583810787025, 590480506935, 597092270467, 603784200787, 610403013525, 617114828578, 623745063632, 630461354816, 637109043600, 643828046362, 650470873262, 657203494738, 663846321638, 670565324400, 677213013184, 683929304368, 690559539422, 697271354475, 703890167213, 710582097533, 717193861065, 723863580975, 730446603867, 737106917822, 743666428678, 750288582190, 756828164396, 763423641293, 769923956165, 776490942533, 782955962009, 789479012069, 795913518621, 802392896029, 808776470791, 815222469413, 821559224787, 827944775789, 834240653951, 840576844289, 846811516125, 853096749111, 859274966173, 865496907100, 871623515864, 877780009594, 883834668742, 889936568057, 895926275463, 901948784121, 907876881823, 913830424009, 919679441545, 925563762520, 931337915532, 937140514229, 942844318191, 948564479612,
# 954181582474, 959829660066, 965364815456, 970917756105, 976375113485, 981844404756, 987208503392, 992593181450, 997867748094, 1003157255600, 1008348624994, 1013542890525, 1018635239627, 1023743215262, 1028741615534, 1033745295267, 1038653898747, 1043562491338, 1048367981402, 1053181353931, 1057889017989, 1062598695136, 1067212916944, 1071818563264, 1076326633168, 1080838778769, 1085246143819, 1089647752272, 1093957706384, 1098258121084, 1102461330328, 1106660780940, 1110760830846, 1114852631336, 1118854601350, 1122840321000, 1126734033272, 1130621616007, 1134411828501, 1138188469129, 1141879759051, 1145553758419, 1149137953397, 1152709702524, 1156190730374, 1159656564349, 1163039316261, 1166400278874, 1169676756782, 1172940282167, 1176116210891, 1179272370762, 1182350866764, 1185407011879, 1188382788833, 1191340728832, 1194217627818, 1197074673144, 1199856681314, 1202614065389, 1205296757693, 1207961362671, 1210548965893, 1213113484081, 1215609486627, 1218081285389, 1220482395911, 1222862484745, 1225171964943, 1227459393178, 1229681886726, 1231878471350, 1234010512106, 1236121870921, 1238167839117, 1240189978869, 1242152917827, 1244091386888, 1245969567266, 1247825878532, 1249623036654, 1251397651392, 1253117302030, 1254811763386, 1256452492968, 1258072292357, 1259637713657, 1261180110447, 1262673048235, 1264143168122, 1265563843644, 1266963172500, 1268314362190, 1269644047398, 1270928949444, 1272191113602, 1273409649842, 1274608493533, 1275763776977, 1276898283011, 1277993179017, 1279067536310, 1280102703352, 1281118437075, 1282096420695, 1283055567243, 1283979277777, 1284883406816, 1285753378356, 1286606058165, 1287425328175, 1288226647014, 1288997315230, 1289750588151, 1290473985279, 1291180915016, 1291859272784, 1292521785203, 1293157329819, 1293776989934, 1294371139968, 1294950758706, 1295505644074, 1296045869744, 1296563420572, 1297067098870, 1297548802250, 1298017227976, 1298464880652, 1298900042307, 1299315665131, 1299718875693, 1300103761305, 1300477159484, 1300833116046, 1301177843755, 1301506401027, 1301824473092,
# 1302127102488, 1302419637634, 1302697865092, 1302966660493, 1303221932211, 1303468040080, 1303701679944, 1303926839285, 1304140219693, 1304345482418, 1304539798930, 1304726653387, 1304903280147, 1305072676814, 1305232728784, 1305386119428, 1305530702894, 1305669031314, 1305799315980, 1305923741194, 1306040715470, 1306152230687, 1306256866455, 1306356551858, 1306449915474, 1306538501709, 1306621437087, 1306700091017, 1306773420067, 1306842815138, 1306907447144, 1306968427604, 1307025124018, 1307078481446, 1307127904702, 1307174375641, 1307217330237, 1307257496733, 1307294583037, 1307329227388, 1307361018578, 1307390639266, 1307417795370, 1307442960740, 1307465973420, 1307487229380, 1307506557742, 1307524386941, 1307540546967, 1307555329787, 1307568704691, 1307580918509, 1307591874007, 1307601836110, 1307610750518, 1307618786867, 1307625952831, 1307632379826, 1307638055110, 1307643130571, 1307647589243, 1307651520547, 1307654961051, 1307657982681, 1307660588365, 1307662859343, 1307664808311, 1307666480949, 1307667904565, 1307669114015, 1307670124247, 1307670975895, 1307671679739, 1307672257745, 1307672730217, 1307673113641, 1307673417065, 1307673658892, 1307673847230, 1307673992218, 1307674102256, 1307674184650, 1307674244144, 1307674287121, 1307674316865, 1307674336790, 1307674349906, 1307674358155, 1307674362933, 1307674365656, 1307674367054, 1307674367661, 1307674367907, 1307674367985, 1307674367999, 1307674368000 )
# )
#
# .PageDF <- lapply(.PageDF, function(x) c(x[1], diff(x)) / tail(x,1))
# save(.PageDF, file="C:/Users/Andri/Documents/R/sources/DescTools/MakeDescToolsBase/PageDF.rda")
# load(file="C:/Users/Andri/Documents/R/Projects/load/PageDF.rda")
# load(file="C:/Users/Andri/Documents/R/Projects/DescTools/load/wdConst.rda")
# load(file="C:/Users/Andri/Documents/R/sources/DescTools/periodic.rda")
# just for check not to bark!
utils::globalVariables(c("d.units","d.periodic","d.prefix",
"day.name","day.abb","wdConst","xlConst",
"fmt", "pal",
"hred","hblue","horange","hyellow","hecru","hgreen",
"tarot","cards","roulette", "ind"))
# hred <- unname(Pal("Helsana")[1])
# horange <- unname(Pal("Helsana")[2])
# hyellow <- unname(Pal("Helsana")[3])
# hecru <- unname(Pal("Helsana")[4])
# hblue <- unname(Pal("Helsana")[6])
# hgreen <- unname(Pal("Helsana")[7])
#
# save(x=hred, file='C:/Users/andri/Documents/R/Projects/DescTools/data/hred.rda')
# save(x=horange, file='C:/Users/andri/Documents/R/Projects/DescTools/data/horange.rda')
# save(x=hyellow, file='C:/Users/andri/Documents/R/Projects/DescTools/data/hyellow.rda')
# save(x=hecru, file='C:/Users/andri/Documents/R/Projects/DescTools/data/hecru.rda')
# save(x=hblue, file='C:/Users/andri/Documents/R/Projects/DescTools/data/hblue.rda')
# save(x=hgreen, file='C:/Users/andri/Documents/R/Projects/DescTools/data/hgreen.rda')
# source( "C:/Users/Andri/Documents/R/sources/DescTools/wdConst.r" )
# Base functions ====
## base: calculus
# we have month.name and month.abb in base R, but nothing similar for day names
# in english (use format(ISOdate(2000, 1:12, 1), "%B") for months in current locale)
# day.name <- c("Monday","Tuesday","Wednesday","Thursday","Friday","Saturday","Sunday")
# day.abb <- c("Mon","Tue","Wed","Thu","Fri","Sat","Sun")
# internal: golden section constant
gold_sec_c <- (1+sqrt(5)) / 2
# tarot <- structure(list(rank = c("1", "2", "3", "4", "5", "6", "7", "8",
# "9", "10", "page", "knight", "queen", "king", "1", "2", "3",
# "4", "5", "6", "7", "8", "9", "10", "page", "knight", "queen",
# "king", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "page",
# "knight", "queen", "king", "1", "2", "3", "4", "5", "6", "7",
# "8", "9", "10", "page", "knight", "queen", "king", "0", "1",
# "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13",
# "14", "15", "16", "17", "18", "19", "20", "21"), suit = c("wands",
# "wands", "wands", "wands", "wands", "wands", "wands", "wands",
# "wands", "wands", "wands", "wands", "wands", "wands", "coins",
# "coins", "coins", "coins", "coins", "coins", "coins", "coins",
# "coins", "coins", "coins", "coins", "coins", "coins", "cups",
# "cups", "cups", "cups", "cups", "cups", "cups", "cups", "cups",
# "cups", "cups", "cups", "cups", "cups", "swords", "swords", "swords",
# "swords", "swords", "swords", "swords", "swords", "swords", "swords",
# "swords", "swords", "swords", "swords", "trumps", "trumps", "trumps",
# "trumps", "trumps", "trumps", "trumps", "trumps", "trumps", "trumps",
# "trumps", "trumps", "trumps", "trumps", "trumps", "trumps", "trumps",
# "trumps", "trumps", "trumps", "trumps", "trumps"), desc = c(NA,
# NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,
# NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,
# NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,
# NA, NA, NA, NA, NA, NA, NA, "The Fool", "The Magician", "The High Priestess",
# "The Empress", "The Emperor", "The Hierophant", "The Lovers",
# "The Chariot", "Strength", "The Hermit", "Wheel of Fortune",
# "Justice", "The Hanged Man", "Death", "Temperance", "The Devil",
# "The Tower", "The Star", "The Moon", "The Sun", "Judgment", "The World"
# )), .Names = c("rank", "suit", "desc"), out.attrs = structure(list(
# dim = structure(c(14L, 4L), .Names = c("rank", "suit")),
# dimnames = structure(list(rank = c("rank=1", "rank=2", "rank=3",
# "rank=4", "rank=5", "rank=6", "rank=7", "rank=8", "rank=9",
# "rank=10", "rank=page", "rank=knight", "rank=queen", "rank=king"
# ), suit = c("suit=wands", "suit=coins", "suit=cups", "suit=swords"
# )), .Names = c("rank", "suit"))), .Names = c("dim", "dimnames"
# )), row.names = c(NA, 78L), class = "data.frame")
#
#
# cards <- structure(list(rank = structure(c(1L, 2L, 3L, 4L, 5L, 6L, 7L,
# 8L, 9L, 10L, 11L, 12L, 13L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L,
# 10L, 11L, 12L, 13L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L,
# 11L, 12L, 13L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 11L,
# 12L, 13L), .Label = c("2", "3", "4", "5", "6", "7", "8", "9",
# "10", "J", "Q", "K", "A"), class = "factor"), suit = structure(c(1L,
# 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L,
# 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L,
# 3L, 3L, 3L, 3L, 3L, 3L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L,
# 4L, 4L, 4L), .Label = c("club", "diamond", "heart", "spade"), class = "factor")), .Names = c("rank",
# "suit"), out.attrs = structure(list(dim = structure(c(13L, 4L
# ), .Names = c("rank", "suit")), dimnames = structure(list(rank = c("rank=2",
# "rank=3", "rank=4", "rank=5", "rank=6", "rank=7", "rank=8", "rank=9",
# "rank=10", "rank=J", "rank=Q", "rank=K", "rank=A"), suit = c("suit=club",
# "suit=diamond", "suit=heart", "suit=spade")), .Names = c("rank",
# "suit"))), .Names = c("dim", "dimnames")), class = "data.frame", row.names = c(NA, -52L))
#
#
# roulette <- structure(list(num = structure(c(1L, 20L, 24L, 30L, 5L, 22L,
# 35L, 23L, 11L, 16L, 37L, 26L, 7L, 14L, 2L, 28L, 9L, 18L, 33L,
# 3L, 17L, 36L, 25L, 4L, 31L, 6L, 21L, 34L, 29L, 10L, 19L, 13L,
# 15L, 32L, 12L, 8L, 27L), .Label = c("0", "1", "10", "11", "12",
# "13", "14", "15", "16", "17", "18", "19", "2", "20", "21", "22",
# "23", "24", "25", "26", "27", "28", "29", "3", "30", "31", "32",
# "33", "34", "35", "36", "4", "5", "6", "7", "8", "9"), class = "factor"),
# col = structure(c(2L,
# 1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L,
# 3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L, 1L, 3L,
# 1L, 3L, 1L, 3L, 1L, 3L), .Label = c("black", "white", "red"
# ), class = "factor")), .Names = c("num", "col"
# ), row.names = c(NA, -37L), class = "data.frame")
#
# save(tarot, file="tarot.rda")
# save(cards, file="cards.rda")
# save(roulette, file="roulette.rda")
# Define some alias(es)
N <- as.numeric
Nf <- function(x, ...){
as.numeric(factor(x, ...))
}
## This is not exported as it would mask base function and
# but it would be very, very handy if the base function was changed accoringly
as.Date.numeric <- function (x, origin, ...) {
if (missing(origin))
origin <- "1970-01-01"
as.Date(origin, ...) + x
}
Primes <- function (n) {
# Source: sfsmisc
# Bill Venables (<= 2001); Martin Maechler gained another 40% speed, working with logicals and integers.
if ((M2 <- max(n)) <= 1L)
return(integer(0L))
P <- rep.int(TRUE, M2)
P[1] <- FALSE
M <- as.integer(sqrt(M2))
n <- as.integer(M2)
for (p in 1L:M) if (P[p])
P[seq(p * p, n, p)] <- FALSE
(1L:n)[P]
}
Factorize <- function (n) {
# Factorize <- function (n, verbose = FALSE) {
# Source sfsmisc: Martin Maechler, Jan. 1996.
if (all(n < .Machine$integer.max))
n <- as.integer(n)
else {
warning("factorizing large int ( > maximal integer )")
n <- round(n)
}
N <- length(n)
M <- as.integer(sqrt(max(n)))
k <- length(pr <- Primes(M))
nDp <- outer(pr, n, FUN = function(p, n) n %% p == 0L)
res <- vector("list", length = N)
names(res) <- n
for (i in 1L:N) {
nn <- n[i]
if (any(Dp <- nDp[, i])) {
nP <- length(pfac <- pr[Dp])
# if (verbose) cat(nn, " ")
}
else {
res[[i]] <- cbind(p = nn, m = 1L)
# if (verbose) cat("direct prime", nn, "\n")
next
}
m.pr <- rep(1L, nP)
Ppf <- prod(pfac)
while (1 < (nn <- nn %/% Ppf)) {
Dp <- nn %% pfac == 0L
if (any(Dp)) {
m.pr[Dp] <- m.pr[Dp] + 1L
Ppf <- prod(pfac[Dp])
}
else {
pfac <- c(pfac, nn)
m.pr <- c(m.pr, 1L)
break
}
}
res[[i]] <- cbind(p = pfac, m = m.pr)
}
res
}
GCD <- function(..., na.rm = FALSE) {
x <- unlist(list(...), recursive=TRUE)
if(na.rm) x <- x[!is.na(x)]
if(anyNA(x)) return(NA)
stopifnot(is.numeric(x))
if (any(floor(x) != ceiling(x)) || length(x) < 2L)
stop("Argument 'x' must be an integer vector of length >= 2.")
x <- x[x != 0]
n <- length(x)
if (n == 0L) {
g <- 0
} else if (n == 1L) {
g <- x
} else if (n == 2L) {
g <- .Call("_DescTools_compute_GCD", PACKAGE = "DescTools", x[1L], x[2L])
} else {
# g <- .GCD(x[1], x[2])
g <- .Call("_DescTools_compute_GCD", PACKAGE = "DescTools", x[1L], x[2L])
for (i in 3L:n) {
g <- .Call("_DescTools_compute_GCD", PACKAGE = "DescTools", g, x[i])
if (g == 1) break
}
}
return(g)
}
LCM <- function(..., na.rm = FALSE) {
# .LCM <- function(n, m) {
# stopifnot(is.numeric(n), is.numeric(m))
# if (length(n) != 1 || floor(n) != ceiling(n) ||
# length(m) != 1 || floor(m) != ceiling(m))
# stop("Arguments 'n', 'm' must be integer scalars.")
# if (n == 0 && m == 0) return(0)
#
# return(n / GCD(c(n, m)) * m)
# }
x <- unlist(list(...), recursive=TRUE)
if(na.rm) x <- x[!is.na(x)]
if(anyNA(x)) return(NA)
stopifnot(is.numeric(x))
if (any(floor(x) != ceiling(x)) || length(x) < 2L)
stop("Argument 'x' must be an integer vector of length >= 2.")
x <- x[x != 0]
n <- length(x)
if (n == 0L) {
l <- 0
} else if (n == 1L) {
l <- x
} else if (n == 2L) {
# l <- .LCM(x[1], x[2])
l <- .Call("_DescTools_compute_LCM", PACKAGE = "DescTools", x[1], x[2])
} else {
# l <- .LCM(x[1], x[2])
l <- .Call("_DescTools_compute_LCM", PACKAGE = "DescTools", x[1], x[2])
for (i in 3L:n) {
# l <- .LCM(l, x[i])
l <- .Call("_DescTools_compute_LCM", PACKAGE = "DescTools", l, x[i])
}
}
return(l)
}
rSum21 <- function(size, digits=NULL){
rnd <- (p <- runif(n = size))/sum(p)
if(!is.null(digits)){
rnd <- round(rnd, digits = digits)
rnd[1] <- rnd[1] + (1-sum(rnd))
}
rnd
}
DigitSum <- function(x)
# calculates the digit sum of a number: DigitSum(124) = 7
sapply(x, function(z)
sum(floor(z / 10^(0L:(nchar(z) - 1L))) %% 10L))
Divisors <- function(x) {
res <- lapply(
Factorize(x),
function(prim) {
prim <- lapply(seq_len(nrow(prim)), function(i) prim[i,])
powers <- lapply(prim, function(row) row[1L] ^ seq.int(0L, row[2L]))
power_grid <- do.call(expand.grid, powers)
head(sort(unique(apply(power_grid, 1L, prod))), -1L)
})
# res <- .Call("_DescTools_divs", PACKAGE = "DescTools", x)
return(res)
}
# sample interface for data.frames
Sample <- function (x, size, replace = FALSE, prob = NULL) {
UseMethod("Sample")
}
Sample.data.frame <- function (x, size, replace = FALSE, prob = NULL) {
x[sample(nrow(x), size, replace = replace, prob=prob), ]
}
Sample.default <- function (x, size, replace = FALSE, prob = NULL)
base::sample(x, size, replace, prob)
CombN <- function(n, m, repl=FALSE, ord=FALSE){
# return the number for the 4 combinatoric cases
# n <- length(x)
if(repl){
res <- n^m
if(!ord){
res <- choose(n+m-1, m)
}
} else {
if(ord){
# res <- choose(n, m) * factorial(m)
# res <- gamma(n+1) / gamma(m+1)
# avoid numeric overflow
res <- exp(lgamma(n + 1L) - lgamma(n - m + 1L))
} else {
res <- choose(n, m)
}
}
return(res)
}
Permn <- function(x, sort = FALSE) {
# by F. Leisch
n <- length(x)
if (n == 1L)
return(matrix(x))
# Andri: why should we need that??? ...
# else if (n < 2)
# stop("n must be a positive integer")
z <- matrix(1L)
for (i in 2L:n) {
y <- cbind(z, i)
a <- c(1L:i, 1:(i - 1L))
z <- matrix(0L, ncol = ncol(y), nrow = i * nrow(y))
z[1L:nrow(y), ] <- y
for (j in 2L:i - 1L) {
z[j * nrow(y) + 1L:nrow(y), ] <- y[, a[1L:i + j]]
}
}
dimnames(z) <- NULL
m <- apply(z, 2L, function(i) x[i])
if(any(duplicated(x)))
m <- unique(m)
if(sort) m <- Sort(m)
return(m)
}
CombSet <- function(x, m, repl=FALSE, ord=FALSE, as.list=FALSE) {
if(length(m)>1){
res <- lapply(m, function(i) CombSet(x=x, m=i, repl=repl, ord=ord))
} else {
# generate the samples for the 4 combinatoric cases
if(repl){
res <- as.matrix(do.call(expand.grid, as.list(as.data.frame(replicate(m, x)))))
dimnames(res) <- NULL
if(!ord){
res <- unique(t(apply(res, 1L, sort)))
}
} else {
if(ord){
res <- do.call(rbind, combn(x, m=m, FUN=Permn, simplify = FALSE))
} else {
res <- t(combn(x, m))
}
}
}
if(as.list){
# Alternative: we could flatten the whole list
# and now flatten the list of lists into one list
# lst <- split(unlist(lst), rep(1:length(idx <- rapply(lst, length)), idx))
if(is.list(res)){
res <- do.call(c, lapply(res,
function(x){ as.list(as.data.frame(t(x), stringsAsFactors = FALSE))}))
} else {
res <- as.list(as.data.frame(t(res), stringsAsFactors = FALSE))
}
names(res) <- NULL
}
return(res)
}
# CombSet(x, m, repl=TRUE, ord=FALSE)
# CombSet(x, m, repl=TRUE, ord=TRUE)
# CombSet(x, m, repl=FALSE, ord=TRUE)
# CombSet(x, m, repl=FALSE, ord=FALSE)
CombPairs <- function(x, y = NULL) {
# returns a data.frame with all pairwise combinations of two variables
if( missing(y)) { # kein y vorhanden, use x only
data.frame( t(combn(x, 2L)), stringsAsFactors=FALSE )
} else {
# if y is defined, all.x to all.y will be returned
expand.grid(x, y, stringsAsFactors=FALSE )
}
}
GenRandGroups <- function(x, grp_n){
(grp <- sample(rep(j <- seq_along(grp_n), grp_n)))
idx <- sapply(j, function(x) which(grp==x))
lapply(idx, function(ii) x[ii])
}
###
### DOT.R Scalar product
###
Dot <- function(x, y) {
if (length(x) == 0 && length(y) == 0) return(0)
if (!(is.numeric(x) || is.complex(x)) ||
!(is.numeric(y) || is.complex(y)))
stop("Arguments 'x' and 'y' must be real or complex.")
x <- drop(x); y <- drop(y)
if (any(dim(x) != dim(y)))
stop("Matrices 'x' and 'y' must be of same size")
if (is.vector(x) && is.vector(y)) {
dim(x) <- c(length(x), 1)
dim(y) <- c(length(y), 1)
}
x.y <- apply(Conj(x) * y, 2, sum)
return(x.y)
}
CrossN <- function(A) {
if (!is.numeric(A))
stop("Argument 'A' must be numeric.")
if (is.vector(A) && length(A) == 2) {
crossA <- c(A[2], -A[1])
} else {
if (is.matrix(A) && nrow(A) >= 2 && ncol(A) == nrow(A) + 1) {
m <- ncol(A)
crossA <- numeric(m)
for (i in 1:m)
crossA[i] <- (-1)^(i+1) * det(A[, -i])
} else {
stop("Matrix 'A' must be of size n x (n+1) with n >= 1.")
}
}
return(crossA)
}
###
### CROSS.R Vector product
###
Cross <- function(x, y) {
if (!is.numeric(x) || !is.numeric(y))
stop("Arguments 'x' and 'y' must be numeric vectors or matrices.")
if (is.vector(x) && is.vector(y)) {
if (length(x) == length(y) && length(x) == 3L) {
xxy <- c(x[2L]*y[3L] - x[3L]*y[2L],
x[3L]*y[1L] - x[1L]*y[3L],
x[1L]*y[2L] - x[2L]*y[1L])
} else {
stop("Vectors 'x' and 'y' must be both of length 3.")
}
} else {
if (is.matrix(x) && is.matrix(y)) {
if (all(dim(x) == dim(y))) {
if (ncol(x) == 3L) {
xxy <- cbind(x[, 2L]*y[, 3L] - x[, 3L]*y[, 2L],
x[, 3L]*y[, 1L] - x[, 1L]*y[, 3L],
x[, 1L]*y[, 2L] - x[, 2L]*y[, 1L])
} else {
if (nrow(x) == 3L) {
xxy <- rbind(x[2L, ]*y[3L, ] - x[3L, ]*y[2L, ],
x[3L, ]*y[1L, ] - x[1L, ]*y[3L, ],
x[1L, ]*y[2L, ] - x[2L, ]*y[1L, ])
} else {
stop("'x', 'y' must have one dimension of length 3.")
}
}
} else {
stop("Matrices 'x' and 'y' must be of same size.")
}
} else {
if (is.vector(x) && is.matrix(y) ||
is.matrix(x) && is.vector(y)) {
stop("Arguments 'x', 'y' must be vectors/matrices of same size.")
}
}
}
return(xxy)
}
Fibonacci <- function(n) {
# if (!is.numeric(n) || !IsWhole(n) || n < 0)
if(any(sapply(n, function(i) !is.numeric(i) || !IsWhole(i) || i < 0L)))
stop("Argument 'n' must be an integer >= 0.")
maxn <- max(n)
if (maxn == 0L) return(0L)
if (maxn == 1L) return(c(0L, 1)[n+1L])
if (maxn == 2L) return(c(0L, 1L, 1L)[n+1L])
z <- c(0L, 1L, 1L, rep(NA, maxn - 3L))
for (i in 4L:(maxn + 1L)) {
z[i] <- z[i-1L] + z[i-2L]
}
z[n+1L]
}
GeomSn <- function(a1, q, n){
a1 * (q^(n+1)-1)/(q-1)
}
### M^k for a matrix M and non-negative integer 'k'
## Matrixpower
"%^%" <- expm::"%^%"
Vigenere <- function(x, key = NULL, decrypt = FALSE) {
# hold that constant, as it makes the function too flexible else
# in cases you maybe remind your password, but lost the charlist definition....
charlist <- c(LETTERS, letters, 0:9)
if(is.null(key)) key <- PasswordDlg()
.mod1 <- function(v, n) {
# mod1(1:20, 6) => 1 2 3 4 5 6 1 2 3 4 5 6 1 2 3 4 5 6 1 2
((v - 1) %% n) + 1
}
.str2ints <- function(s) {
as.integer(Filter(Negate(is.na),
factor(levels = charlist, strsplit(s, "")[[1]])))
}
x <- .str2ints(x)
key <- rep(.str2ints(key), len = length(x)) - 1
paste(collapse = "", charlist[
.mod1(x + (if (decrypt) -1 else 1)*key, length(charlist))])
}
## =============================================================================
## uniroot.all: multiple roots of one nonlinear equation
## =============================================================================
UnirootAll <- function (f, interval, lower= min(interval),
upper= max(interval), tol= .Machine$double.eps^0.5,
maxiter= 1000, n = 100, ... ) {
# this is a copy of rootSolve::uniroot.all v. 1.8.2.1
# author: Karline Soetaert
## error checking as in uniroot...
if (!missing(interval) && length(interval) != 2)
stop("'interval' must be a vector of length 2")
if (!is.numeric(lower) || !is.numeric(upper) || lower >=
upper)
stop("lower < upper is not fulfilled")
## subdivide interval in n subintervals and estimate the function values
xseq <- seq(lower, upper, len=n+1)
# changed in 0.99.36 5.5.2020
# but we should maybe vectorize the functions in order to allow the user not to
# bother about internal applies
# ... not sure about the impact..
# Original: mod <- f(xseq, ...)
mod <- Vectorize(f)(xseq, ...)
## some function values may already be 0
Equi <- xseq[which(mod==0)]
ss <- mod[1:n]*mod[2:(n+1)] # interval where function values change sign
ii <- which(ss<0)
for (i in ii)
Equi <- c(Equi, uniroot(f, lower=xseq[i], upper=xseq[i+1],
maxiter = maxiter, tol = tol, ...)$root)
return(Equi)
}
#
# Winsorize <- function(x, minval = NULL, maxval = NULL,
# probs=c(0.05, 0.95), na.rm = FALSE, type=7) {
#
# # following an idea from Gabor Grothendieck
# # http://r.789695.n4.nabble.com/how-to-winsorize-data-td930227.html
#
# # in HuberM things are implemented the same way
#
# # don't eliminate NAs in x, moreover leave them untouched,
# # just calc quantile without them...
#
# # pmax(pmin(x, maxval), minval)
#
# # the pmax(pmin()-version is slower than the following
#
# if(is.null(minval) || is.null(maxval)){
# xq <- quantile(x=x, probs=probs, na.rm=na.rm, type=type)
# if(is.null(minval)) minval <- xq[1L]
# if(is.null(maxval)) maxval <- xq[2L]
# }
#
# x[x<minval] <- minval
# x[x>maxval] <- maxval
#
# return(x)
#
# # see also Andreas Alfons, KU Leuven
# # roubustHD, Winsorize
#
# # Jim Lemon's rather clumsy implementation:
#
# # #added winsor.var and winsor.sd and winsor.mean (to supplement winsor.means)
# # #August 28, 2009 following a suggestion by Jim Lemon
# # #corrected January 15, 2009 to use the quantile function rather than sorting.
# # #suggested by Michael Conklin in correspondence with Karl Healey
# # #this preserves the order of the data
# # "wins" <- function(x,trim=.2, na.rm=TRUE) {
# # if ((trim < 0) | (trim>0.5) )
# # stop("trimming must be reasonable")
# # qtrim <- quantile(x,c(trim,.5, 1-trim),na.rm = na.rm)
# # xbot <- qtrim[1]
# # xtop <- qtrim[3]
# # if(trim<.5) {
# # x[x < xbot] <- xbot
# # x[x > xtop] <- xtop} else {x[!is.na(x)] <- qtrim[2]}
# # return(x) }
#
# }
#
Trim <- function(x, trim = 0.1, na.rm = FALSE){
if (na.rm) x <- x[!is.na(x)]
if (!is.numeric(trim) || length(trim) != 1L)
stop("'trim' must be numeric of length one")
n <- length(x)
if (trim > 0 && n) {
if (is.complex(x))
stop("trim is not defined for complex data")
if (anyNA(x))
return(NA_real_)
if (trim >= 0.5 && trim < 1)
return(NA_real_)
if(trim < 1)
lo <- floor(n * trim) + 1
else{
lo <- trim + 1
if (trim >= (n/2))
return(NA_real_)
}
hi <- n + 1 - lo
# x <- sort.int(x, partial = unique(c(lo, hi)))[lo:hi]
res <- sort.int(x, index.return = TRUE)
trimi <- res[["ix"]][c(1:(lo-1), (hi+1):length(x))]
# x <- res[["x"]][order(res[["ix"]])[lo:hi]]
x <- res[["x"]][lo:hi][order(res[["ix"]][lo:hi])]
attr(x, "trim") <- trimi
}
return(x)
}
RobScale <- function(x, center = TRUE, scale = TRUE){
x <- as.matrix(x)
if(center) {
x <- scale(x, center = apply(x, 2, median, na.rm=TRUE), scale = FALSE)
}
if(scale) {
x <- scale(x, center = FALSE, scale = apply(x, 2, mad, na.rm=TRUE))
}
return(x)
}
MoveAvg <- function(x, order, align = c("center","left","right"),
endrule = c("NA", "keep", "constant")){
n <- length(x)
align = match.arg(align)
switch(align,
"center" = {
idx <- c(1:(order %/% 2), (n-order %/% 2+1):n)
idx_const <- c(rep((order %/% 2)+1, order %/% 2),
rep(n-(order %/% 2), order %/% 2))
if(order %% 2 == 1){ # order is odd
z <- filter(x, rep(1/order, order), sides=2)
} else { # order is even
z <- filter(x, c(1/(2*order), rep(1/order, order-1), 1/(2*order)), sides=2)
} }
, "right" = {
idx <- 1:(order-1)
idx_const <- order
z <- filter(x, rep(1/order, order), sides=1)
}
, "left" = {
idx <- (n-order+2):n
idx_const <- n-order+1
z <- rev(filter(rev(x), rep(1/order, order), sides=1))
}
)
endrule <- match.arg(endrule)
switch(endrule,
"NA" = {},
keep = {z[idx] <- x[idx]},
constant = {z[idx] <- z[idx_const]})
if(!is.ts(x)) attr(z, "tsp") <- NULL
class(z) <- class(x)
return(z)
}
LinScale <- function (x, low = NULL, high = NULL, newlow = 0, newhigh = 1) {
x <- as.matrix(x)
if(is.null(low)) {
low <- apply(x, 2, min, na.rm=TRUE)
} else {
low <- rep(low, length.out=ncol(x))
}
if(is.null(high)) {
high <- apply(x, 2, max, na.rm=TRUE)
} else {
high <- rep(high, length.out=ncol(x))
}
# do the recycling job
newlow <- rep(newlow, length.out=ncol(x))
newhigh <- rep(newhigh, length.out=ncol(x))
xcntr <- (low * newhigh - high * newlow) / (newhigh - newlow)
xscale <- (high - low) / (newhigh - newlow)
return( scale(x, center = xcntr, scale = xscale))
}
Large <- function (x, k = 5L, unique = FALSE, na.last = NA) {
n <- length(x)
x <- x[!is.na(x)]
na_n <- n - length(x)
# na.last
# for controlling the treatment of NAs. If TRUE, missing values in the data are put last;
# if FALSE, they are put first;
# if NA, they are removed.
if (unique==TRUE) {
res <- .Call("_DescTools_top_n", PACKAGE = "DescTools", x, k)
if(na_n > 0){
if(!is.na(na.last)){
if(na.last==FALSE) {
res$value <- tail(c(NA, res$value), k)
res$frequency <- tail(c(na_n, res$frequency), k)
}
if(na.last==TRUE){
res$value <- tail(c(res$value, NA), k)
res$frequency <- tail(c(res$frequency, na_n), k)
}
}
}
if(is.factor(x))
res$value <- levels(x)[res$value]
else
class(res$value) <- class(x)
} else {
# do not allow k be bigger than n
k <- min(k, n)
res <- x[.Call("_DescTools_top_i", PACKAGE = "DescTools", x, k)]
if(!is.na(na.last)){
if(na.last==FALSE)
res <- tail(c(rep(NA, na_n), res), k)
if(na.last==TRUE)
res <- tail(c(res, rep(NA, na_n)), k)
}
}
return(res)
}
# old version, replaced 0.99.17/13.5.2016
#
# Large <- function (x, k = 5, unique = FALSE, na.rm = FALSE) {
#
# if (na.rm)
# x <- x[!is.na(x)]
#
# if (unique==TRUE) {
# ux <- unique(x)
# # un <- length(ux)
# un <- sum(!is.na(ux))
# minval <- sort(ux, partial=max((un-k+1), 1):un, na.last = TRUE)[max((un-k+1),1)]
#
# # we are using the rationale of rle here, as it turned out to be the fastest approach
# x <- sort(x[x>=minval])
# n <- length(x)
# if (n == 0L)
# res <- list(lengths = integer(), values = x)
#
# y <- x[-1L] != x[-n]
# i <- c(which(y | is.na(y)), n)
# res <- list(lengths = diff(c(0L, i)), values = x[i])
#
# # res <- unclass(rle(sort(x[x>=minval])))
# }
# else {
# # n <- length(x)
# n <- sum(!is.na(x))
# res <- sort(x, partial=max((n-k+1),1):n, na.last = TRUE)[max((n-k+1),1):n]
# # lst <- as.vector(unlist(lapply(lst, "[", "val")))
# # http://stackoverflow.com/questions/15659783/why-does-unlist-kill-dates-in-r
#
# # faster alternative (but check NA-handling first):
# # res <- x[.Call("_DescTools_top_index", PACKAGE = "DescTools", x, k)]
#
# }
# return(res)
# }
Small <- function (x, k = 5L, unique = FALSE, na.last = NA) {
n <- length(x)
x <- x[!is.na(x)]
na_n <- n - length(x)
# na.last
# for controlling the treatment of NAs. If TRUE, missing values in the data are put last;
# if FALSE, they are put first;
# if NA, they are removed.
if (unique==TRUE) {
res <- .Call("_DescTools_bottom_n", PACKAGE = "DescTools", x, k)
if(na_n > 0L){
if(!is.na(na.last)){
if(na.last==FALSE) {
k <- min(length(res$value) + 1L, k)
res$value <- c(NA, res$value)[1L:k]
res$frequency <- c(na_n, res$frequency)[1L:k]
}
if(na.last==TRUE){
k <- min(length(res$value) + 1L, k)
res$value <- c(res$value, NA)[1L:k]
res$frequency <- c(res$frequency, na_n)[1L:k]
}
}
}
if(is.factor(x))
res$value <- levels(x)[res$value]
else
class(res$value) <- class(x)
} else {
# do not allow k be bigger than n
k <- min(k, n)
res <- rev(x[.Call("_DescTools_bottom_i", PACKAGE = "DescTools", x, k)])
if(!is.na(na.last)){
if(na.last==FALSE)
res <- c(rep(NA, na_n), res)[1L:k]
if(na.last==TRUE)
res <- c(res, rep(NA, na_n))[1L:k]
}
}
return(res)
}
# Small <- function (x, k = 5, unique = FALSE, na.rm = FALSE) {
#
# if (na.rm)
# x <- x[!is.na(x)]
#
# if (unique==TRUE) {
# ux <- unique(x)
# un <- length(ux)
# maxval <- sort(ux, partial = min(k, un))[min(k, un)]
#
# # we are using the rationale of rle here, as it turned out to be the fastest approach
# x <- sort(x[x<=maxval])
# n <- length(x)
# if (n == 0L)
# res <- list(lengths = integer(), values = x)
#
# y <- x[-1L] != x[-n]
# i <- c(which(y | is.na(y)), n)
# res <- list(lengths = diff(c(0L, i)), values = x[i])
#
# # res <- unclass(rle(sort(x[x<=maxval])))
# }
# else {
# n <- length(x)
# res <- sort(x, partial = 1:min(k, n))[1:min(k, n)]
# # lst <- as.vector(unlist(lapply(lst, "[", "val")))
# # http://stackoverflow.com/questions/15659783/why-does-unlist-kill-dates-in-r
# }
# return(res)
# }
HighLow <- function (x, nlow = 5L, nhigh = nlow, na.last = NA) {
# updated 1.2.2014 / Andri
# using table() was unbearable slow and inefficient for big vectors!!
# sort(partial) is the way to go..
# http://r.789695.n4.nabble.com/Fast-way-of-finding-top-n-values-of-a-long-vector-td892565.html
# updated 1.5.2016 / Andri
# ... seemed the way to go so far, but now outperformed by nathan russell's C++ solution
if ((nlow + nhigh) != 0L) {
frqs <- Small(x, k=nlow, unique=TRUE, na.last=na.last)
frql <- Large(x, k=nhigh, unique=TRUE, na.last=na.last)
frq <- c(frqs$frequency, frql$frequency)
vals <- c(frqs$value, frql$value)
if (is.numeric(x)) {
vals <- prettyNum(vals, big.mark = "'")
}
else {
vals <- vals
}
frqtxt <- paste(" (", frq, ")", sep = "")
frqtxt[frq < 2L] <- ""
txt <- StrTrim(paste(vals, frqtxt, sep = ""))
lowtxt <- paste(head(txt, min(length(frqs$frequency), nlow)), collapse = ", ")
hightxt <- paste(tail(txt, min(length(frql$frequency), nhigh)), collapse = ", ")
}
else {
lowtxt <- ""
hightxt <- ""
}
return(paste("lowest : ", lowtxt, "\n",
"highest: ", hightxt, "\n", sep = ""))
}
# Closest <- Vectorize( function(x, a, which = FALSE, na.rm = FALSE){
#
# # # example: Closest(a=67.5, x=d.pizza$temperature)
# #
# if(na.rm) x <- x[!is.na(x)]
#
# mdist <- min(abs(x-a))
# if(is.na(mdist))
# res <- NA
#
# else {
# idx <- DescTools::IsZero(abs(x-a) - mdist) # beware of floating-point-gods
# if(which == TRUE )
# res <- which(idx)
# else
# res <- x[idx]
# }
#
# # Frank's Hmisc solution is faster
# # but does not handle ties satisfactorily
#
# # res <- .Fortran("wclosest", as.double(a), as.double(x), length(a),
# # length(x), j = integer(length(a)), PACKAGE = "DescTools")$j
# # if(!which) res <- x[res]
# return(res)
#
# }, vectorize.args="a")
#
Closest <- function(x, a, which = FALSE, na.rm = FALSE){
# example: Closest(a=67.5, x=d.pizza$temperature, na.rm=TRUE)
FUN <- function(x, a, which = FALSE, na.rm = FALSE){
if(na.rm) x <- x[!is.na(x)]
mdist <- min(abs(x-a))
if(is.na(mdist))
res <- NA
else {
idx <- DescTools::IsZero(abs(x-a) - mdist) # beware of floating-point-gods
if(which == TRUE )
res <- which(idx)
else
res <- x[idx]
}
# Frank's Hmisc solution is faster
# but does not handle ties satisfactorily
# res <- .Fortran("wclosest", as.double(a), as.double(x), length(a),
# length(x), j = integer(length(a)), PACKAGE = "DescTools")$j
# if(!which) res <- x[res]
return(res)
}
# vectorize arguments a and which
res <- mapply(FUN=FUN, a=a, which=which,
MoreArgs = list(x=x, na.rm=na.rm), SIMPLIFY=FALSE)
# simplify: if res is a list with 1 element only, reduce to vector
if(length(res)==1)
res <- res[[1]]
return(res)
}
# DenseRank <- function(x, na.last = TRUE) {
# as.numeric(as.factor(rank(x, na.last)))
# }
Rank <- function(..., decreasing = FALSE, na.last = TRUE,
ties.method = c("average", "first", "last",
"random", "max", "min", "dense")){
ord <- replace(z <- as.numeric(!decreasing), list = z==0, values = -1)
x <- list(...)
if(length(x)==1){
x <- x[[1]]
}
if(!is.vector(x))
ord <- rep_len(ord, length(x))
data.table::frankv(x=x, order=ord, na.last=na.last, ties.method=ties.method)
}
PercentRank <- function(x)
trunc(rank(x, na.last="keep"))/sum(!is.na(x))
Unwhich <- function(idx, n = max(idx), useNames=TRUE){
# Author: Nick Sabbe
# http://stackoverflow.com/questions/7659833/inverse-of-which
# less performant, but oneliner:
# is.element(seq_len(n), i)
if(n < max(idx)){
warning(gettextf("n=%s must not be less than max(idx)=%s, which currently is the case", n, max(idx)))
return(NA)
}
res <- logical(n)
if(length(idx) > 0L) {
res[idx] <- TRUE
if(useNames) names(res)[idx] <- names(idx)
}
return(res)
}
CombLevels <- function(...){
dots <- list( ... )
unique(unlist(lapply(dots, function(x) {
if(!inherits(x, "factor")) x <- factor(x)
levels(x)
}
)))
}
WithOptions <- function(optlist, expr) {
# in an R-devel thread started by Charles Geyer, Thomas Lumley offered the following function:
# example:
# WithOptions(list(digits=3), print((1:10)^-1))
# WithOptions(list(digits=3), print(Desc(d.pizza$temperature))
oldopt <- options(optlist)
on.exit(options(oldopt))
expr <- substitute(expr)
eval.parent(expr)
}
###
## base: string functions ====
# Missing string functions for newbies, but not only..
StrTrim <- function(x, pattern=" \t\n", method="both") {
switch(match.arg(arg = method, choices = c("both", "left", "right")),
both = { gsub( pattern=gettextf("^[%s]+|[%s]+$", pattern, pattern), replacement="", x=x) },
left = { gsub( pattern=gettextf("^[%s]+",pattern), replacement="", x=x) },
right = { gsub( pattern=gettextf("[%s]+$",pattern), replacement="", x=x) }
)
}
StrRight <- function(x, n) {
n <- rep(n, length.out=length(x))
sapply(seq_along(x), function(i) {
if(n[i] >= 0)
substr(x[i], (nchar(x[i]) - n[i]+1L), nchar(x[i]))
else
substr(x[i], - n[i]+1L, nchar(x[i]))
} )
}
StrLeft <- function(x, n) {
n <- rep(n, length.out=length(x))
sapply(seq_along(x), function(i) {
if(n[i] >= 0)
substr(x[i], 0, n[i])
else
substr(x[i], 0, nchar(x[i]) + n[i])
} )
}
StrExtract <- function(x, pattern, ...){
# example regmatches
## Match data from regexpr()
m <- regexpr(pattern, x, ...)
regmatches(x, m)
res <- rep(NA_character_, length(m))
res[ZeroIfNA(m)>0] <- regmatches(x, m)
res
}
StrExtractBetween <- function(x, left, right, greedy=FALSE) {
res <- rep(NA_character_, length(x))
# check that left and right exist, take care for NAs
# valid <- sapply(StrPos(x, left) <= StrPos(x, right), isTRUE)
valid <- !sapply(StrPos(StrRight(x, -ZeroIfNA(StrPos(x, left))), right), is.na)
if(greedy)
res[valid] <- gsub(gettextf("[^%s]*%s(.*)%s.*", left, left, right), "\\1", x[valid])
else
res[valid] <- gsub(gettextf("[^%s]*%s(.*?)%s.*", left, left, right), "\\1", x[valid])
return(res)
}
# StrTrunc <- function(x, maxlen = 20) {
#
# # original truncString from prettyR
# # author: Jim Lemon
#
# # toolong <- nchar(x) > maxlen
# # maxwidth <- ifelse(toolong, maxlen - 3, maxlen)
# # chopx <- substr(x, 1, maxwidth)
# #
# # for(i in 1:length(x)) if(toolong[i]) chopx[i] <- paste(chopx[i], "...", sep="")
# #
# # return(formatC(chopx, width = maxlen, flag = ifelse(justify == "left", "-", " ")) )
#
# # ... but this is all a bit clumsy, let's have it shorter - and much faster! ;-)
#
# paste(substr(x, 0L, maxlen), ifelse(nchar(x) > maxlen, "...", ""), sep="")
# }
StrTrunc <- function (x, maxlen = 20, ellipsis="...", wbound=FALSE) {
# replace NAs with blanks, and store the indices
x[!(valid <- !is.na(x))] <- ""
# recycle max length
maxlen <- rep(maxlen, length.out = length(x))
# correct for word boundaries
if (wbound) {
for(i in seq_along(x)){
# only change maxlen for overlong strings
if(nchar(x[i]) > maxlen[i]){
# get all word boundaries
ll <- gregexpr("\\b\\W+\\b", x[i], perl = TRUE)[[1]]
j <- ll <= maxlen[i]
# use minimum of original maxlen and closest smaller maxlen respecting word boundaries
maxlen[i] <-
if(all(!j)) {
# length of first word is > maxlen, so return maxlen
maxlen[i]
} else {
max(ll[ll <= maxlen[i]])
}
}
}
}
res <- paste0(substr(x, 0L, maxlen), ifelse(nchar(x) > maxlen, ellipsis, ""))
# restore NAs
res[!valid] <- NA_character_
return(res)
}
StrAbbr <- function(x, minchar=1, method=c("left","fix")){
switch(match.arg(arg = method, choices = c("left", "fix")),
"left"={
idx <- rep(minchar, length(x))-1
for(i in minchar:max(nchar(x))){
adup <- AllDuplicated(substr(x, 1, i))
idx[adup] <- i
}
res <- substr(x, 1, idx+1)
},
"fix"={
i <- 1
while(sum(duplicated(substr(x, 1, i))) > 0) { i <- i+1 }
res <- substr(x, 1, pmax(minchar, i))
}
)
return(res)
}
StrCap <- function(x, method=c("first", "word", "title")) {
.cap <- function(x){
# Source: Hmisc
# Author: Charles Dupont
capped <- grep('^[^A-Z]*', x, perl=TRUE)
substr(x[capped], 1,1) <- toupper(substr(x[capped], 1,1))
return(x)
}
na <- is.na(x)
switch(match.arg(method),
first = {
res <- .cap(x)
},
word = {
res <- unlist(lapply(lapply(strsplit(x, split="\\b\\W+\\b"), .cap), paste, collapse=" "))
},
title={
z <- strsplit(tolower(x), split="\\b\\W+\\b")
low <- c("a","an","the","at","by","for","in","of","on","to","up","and","as","but","or","nor","s")
z <- lapply(z, function(y) {
y[y %nin% low] <- StrCap(y[y %nin% low])
y[y %in% low] <- tolower(y[y %in% low])
y}
)
nn <- strsplit(x, split="\\w+")
res <- unlist(lapply(1:length(z), function(i) {
if(length(nn[[i]]) != length(z[[i]])){
if(z[[i]][1] == "" ){
z[[i]] <- z[[i]][-1]
} else {
z[[i]] <- c(z[[i]], "")
}
} else {
if(z[[i]][1] == "" & length(z[[i]])>1)
z[[i]] <- VecRot(z[[i]], -1)
}
do.call(paste, list(nn[[i]], z[[i]], sep="", collapse=""))
}
))
}
)
res[na] <- NA
return(res)
}
StrDist <- function (x, y, method = "levenshtein", mismatch = 1, gap = 1, ignore.case = FALSE){
# source MKmisc, Author: Matthias Kohl
if(ignore.case){
x <- tolower(x)
y <- tolower(y)
}
if (!is.na(pmatch(method, "levenshtein")))
method <- "levenshtein"
METHODS <- c("levenshtein", "normlevenshtein", "hamming")
method <- pmatch(method, METHODS)
if (is.na(method))
stop("invalid distance method")
if (method == -1)
stop("ambiguous distance method")
stopifnot(is.character(x), is.character(y))
if (length(x) == 1 & nchar(x[1]) > 1)
x1 <- strsplit(x, split = "")[[1]]
else
x1 <- x
if (length(y) == 1 & nchar(y[1]) > 1)
y1 <- strsplit(y, split = "")[[1]]
else
y1 <- y
if (method %in% c(1,2)){ ## Levenshtein
m <- length(x1)
n <- length(y1)
D <- matrix(NA, nrow = m+1, ncol = n+1)
M <- matrix("", nrow = m+1, ncol = n+1)
D[,1] <- seq_len(m+1)*gap-1
D[1,] <- seq_len(n+1)*gap-1
D[1,1] <- 0
M[,1] <- "d"
M[1,] <- "i"
M[1,1] <- "start"
text <- c("d", "m", "i")
for(i in c(2:(m+1))){
for(j in c(2:(n+1))){
m1 <- D[i-1,j] + gap
m2 <- D[i-1,j-1] + (x1[i-1] != y1[j-1])*mismatch
m3 <- D[i,j-1] + gap
D[i,j] <- min(m1, m2, m3)
wmin <- text[which(c(m1, m2, m3) == D[i,j])]
if("m" %in% wmin & x1[i-1] != y1[j-1])
wmin[wmin == "m"] <- "mm"
M[i,j] <- paste(wmin, collapse = "/")
}
}
rownames(M) <- rownames(D) <- c("gap", x1)
colnames(M) <- colnames(D) <- c("gap", y1)
d <- D[m+1, n+1]
if(method == 2){ ## normalized levenshtein
d <- 1-d / (max(m, n))
}
}
if(method == 3){ ## Hamming
if(length(x1) != length(y1))
stop("Hamming distance is only defined for equal length strings")
d <- sum(x1 != y1)
D <- NULL
M <- NULL
}
attr(d, "Size") <- 2
attr(d, "Diag") <- FALSE
if(length(x) > 1) x <- paste0("", x, collapse = "")
if(length(y) > 1) y <- paste0("", y, collapse = "")
attr(d, "Labels") <- c(x,y)
attr(d, "Upper") <- FALSE
attr(d, "method") <- METHODS[method]
attr(d, "call") <- match.call()
attr(d, "ScoringMatrix") <- D
attr(d, "TraceBackMatrix") <- M
class(d) <- c("stringDist", "dist")
return(d)
}
StrRev <- function(x) {
# reverses a string
sapply(lapply(strsplit(x, NULL), rev), paste, collapse="")
}
# useless because we have base::strwrap but interesting as regexp example
#
# StrWordWrap <- function(x, n, sep = "\n") {
#
# res <- gsub(gettextf("(.{1,%s})(\\s|$)", n), gettextf("\\1%s", sep), x)
# res <- gsub(gettextf("[%s]$", sep), "", res)
#
# return(res)
#
# }
#
StrPad <- function(x, width = NULL, pad = " ", adj = "left") {
.pad <- function(x, width, pad=" ", adj="left"){
if(is.na(x)) return(NA)
mto <- match.arg(adj, c("left", "right", "center"))
free <- max(0, width - nchar(x))
fill <- substring(paste(rep(pad, ceiling(free / nchar(pad))), collapse = ""), 1, free)
#### cat(" free=",free,", fill=",fill,", mto=",mto,"\n")
# old, but chop is not a good idea: if(free <= 0) substr(x, 1, len)
if(free <= 0) x
else if (mto == "left") paste(x, fill, sep = "")
else if (mto == "right") paste(fill, x, sep = "")
else paste(substring(fill, 1, free %/% 2), x, substring(fill, 1 + free %/% 2, free), sep = "")
}
# adj <- sapply(adj, match.arg, choices=c("left", "right", "center"))
if(is.null(width)) width <- max(nchar(x), na.rm=TRUE)
lgp <- DescTools::Recycle(x=x, width=width, pad=pad, adj=adj)
sapply( 1:attr(lgp, "maxdim"), function(i) .pad(lgp$x[i], lgp$width[i], lgp$pad[i], lgp$adj[i]) )
}
StrAlign <- function(x, sep = "\\r"){
# replace \l by \\^, \r by \\$ and \c means centered
# check for NA only and combined
# return x if sep is not found in x
id.na <- is.na(x)
# what should be done, if x does not contain sep??
# we could return unchanged, but this is often not adaquate
# we align right to the separator
if(length(grep("\\", sep, fixed=TRUE)) == 0) {
idx <- !grepl(x=x, pattern=sep, fixed = TRUE)
x[idx] <- paste(x[idx], sep, sep="")
}
# center alignment
# keep this here, as we may NOT pad x for centered text!!
# example?? don't see why anymore... check!
if (sep == "\\c")
return(StrPad(x, width = max(nchar(x), na.rm=TRUE), pad = " ", adj = "center"))
# Pad to same maximal length, for right alignment this is mandatory
# for left alignment not, but again for any character
x <- StrPad(x, max(nchar(x), na.rm=TRUE))
# left alignment
if(sep == "\\l")
return( sub("(^ +)(.+)", "\\2\\1", x) )
# right alignment
if(sep == "\\r")
return( sub("(.+?)( +$)", "\\2\\1", x) )
# alignment by a special character
bef <- substr(x, 1, StrPos(x, sep, fix=TRUE)) # use fix = TRUE as otherwise the decimal would be to have entered as \\.
aft <- substr(x, StrPos(x, sep, fix=TRUE) + 1, nchar(x))
# chop white space on the right
aft <- substr(aft, 1, max(nchar(StrTrim(aft, method="right"))))
res <- paste(replace(StrPad(bef, max(nchar(bef), na.rm=TRUE),
" ", adj = "right"), is.na(bef), ""),
replace(StrPad(aft, max(nchar(aft), na.rm=TRUE), " ", adj = "left"), is.na(aft),
""), sep = "")
# restore orignal NAs
res[id.na] <- NA
# overwrite the separator
if(length(grep("\\", sep, fixed=TRUE)) == 0)
res[idx] <- gsub(sep, " ", res[idx], fixed = TRUE)
# return unchanged values not containing sep
return(res)
}
StrChop <- function(x, len, pos) {
.chop <- function(x, len, pos) {
# Splits a string into a number of pieces of fixed length
# example: StrChop(x=paste(letters, collapse=""), len = c(3,5,0))
if(!missing(len)){
if(!missing(pos))
stop("too many arguments")
} else {
len <- c(pos[1], diff(pos), nchar(x))
}
xsplit <- character(0)
for(i in 1:length(len)){
xsplit <- append(xsplit, substr(x, 1, len[i]))
x <- substr(x, len[i]+1, nchar(x))
}
return(xsplit)
}
res <- lapply(x, .chop, len=len, pos=pos)
if(length(x)==1)
res <- res[[1]]
return(res)
}
StrCountW <- function(x){
# old: does not work for one single word!!
# return(sapply(gregexpr("\\b\\W+\\b", x, perl=TRUE), length) + 1)
return(sapply(gregexpr("\\b\\W+\\b", x, perl = TRUE), function(x) sum(x>0)) + 1)
}
StrVal <- function(x, paste = FALSE, as.numeric = FALSE, dec=getOption("OutDec")){
# Problem 20.2.2015: - will not be accepted, when a space is between sign and number
# not sure if this is really a problem: -> oberserve...
# StrVal(x="- 2.5", paste = FALSE, as.numeric = FALSE)
# pat <- paste("[-+", dec, "e0-9]*\\d", sep="")
# new pattern by markus
pat <- gettextf("([+-]\\s?)?\\d+(%s\\d+)?([eE][+-]?\\d+)?", ifelse(dec==".", "\\.", dec))
gfound <- gregexpr(pattern=pat, text=x)
vals <- lapply(seq_along(x), function(i){
found <- gfound[[i]]
ml <- attr(found, which="match.length")
res <- sapply(seq_along(found), function(j) substr(x[i], start=found[j], stop=found[j]+ml[j]-1) )
res <- sapply(res, gsub, pattern=" ", replacement="")
return(res)
})
if(paste==TRUE) {
vals <- sapply(vals, paste, collapse="")
if(as.numeric==TRUE){
# we should change a given dec to the system decimal point befor casting to numeric
if(dec != getOption("OutDec"))
vals <- sapply(vals, gsub, pattern=dec, replacement=getOption("OutDec"))
vals <- as.numeric(vals)
}
} else {
if(as.numeric==TRUE){
# we should change a given dec to the system decimal point befor casting to numeric
if(dec != getOption("OutDec"))
vals <- sapply(vals, gsub, pattern=dec, replacement=getOption("OutDec"))
vals <- sapply(vals, as.numeric)
} else
vals <- sapply(vals, as.character)
}
return(vals)
}
StrPos <- function(x, pattern, pos=1, ... ){
# example:
# StrPos(x=levels(d.pizza$driver), "t", pos=4)
pos <- rep(pos, length.out=length(x))
x <- substr(x, start=pos, stop=nchar(x))
i <- as.vector(regexpr(pattern = pattern, text = x, ...))
i[i<0] <- NA
return(i)
}
SplitPath <- function(path, last.is.file=NULL) {
if(is.null(last.is.file)){
# if last sign is delimiter / or \ read path as dirname
last.is.file <- (length(grep(pattern="[/\\]$", path)) == 0)
}
path <- normalizePath(path, mustWork = FALSE)
lst <- list()
lst$normpath <- path
if (.Platform$OS.type == "windows") {
lst$drive <- regmatches(path, regexpr("^([[:alpha:]]:)|(\\\\[[:alnum:]]+)", path))
lst$dirname <- gsub(pattern=lst$drive, x=dirname(path), replacement="")
} else {
lst$drive <- NA
lst$dirname <- dirname(path)
}
lst$dirname <- paste(lst$dirname, "/", sep="")
lst$fullfilename <- basename(path)
lst$fullpath <- paste0(BlankIfNA(lst$drive), lst$dirname)
# lst$filename <- strsplit(lst$fullfilename, "\\.")[[1]][1]
# lst$extension <- strsplit(lst$fullfilename, "\\.")[[1]][2]
lst$filename <- gsub(pattern="(.*)\\.(.*)$", "\\1",lst$fullfilename)
# use the positive lookbehind here
lst$extension <- StrExtract(pattern = "(?<=\\.)[^\\.]+$", lst$fullfilename, perl=TRUE)
# see also tools::file_path_sans_ext() and tools::file_ext()
# but has a less general regex
if(!last.is.file){
lst$dirname <- paste(lst$dirname, lst$fullfilename, "/",
sep="")
lst$extension <- lst$filename <- lst$fullfilename <- NA
}
return(lst)
}
StrSpell <- function(x, upr="CAP", type = c("NATO", "Morse")){
# example: Spell("Yailov9teb6i")
type <- match.arg(type)
upr <- BlankIfNA(upr)
y <- factor(strsplit(x, "")[[1]], levels = c(LETTERS, letters, 0:9))
if(type=="NATO"){
phon <- c("Alfa", "Bravo", "Charlie",
"Delta", "Echo", "Foxtrot", "Golf", "Hotel", "India", "Juliett",
"Kilo", "Lima", "Mike", "November", "Oscar", "Papa", "Quebec",
"Romeo", "Sierra", "Tango", "Uniform", "Victor", "Whiskey", "Xray",
"Yankee", "Zulu")
levels(y) <- c(paste(upr, phon), phon, c("Zero", "One", "Two", "Three", "Four", "Five","Six","Seven","Eight","Nine"))
} else if(type=="Morse"){
phon <- c(".-", "-...", "-.-.",
"-..", ".", "..-.", "--.", "....", "..", ".---",
"-.-", ".-..", "--", "-.", "---", ".--.", "--.-",
".-.", "...", "-", "..-", "...-", ".--", "-..-",
"-.--", "--..")
levels(y) <- c(phon, phon, c("-----", ".----", "..---", "...--", "....-", ".....","-....","--...","---..","----."))
}
return(StrTrim(as.character(y)))
}
StrSplit <- function (x, split="", fixed = FALSE, perl = FALSE, useBytes = FALSE) {
# same as strsplit, but nicer defaults
res <- strsplit(x=x, split=split, fixed=fixed, perl=perl, useBytes=useBytes)
if(length(res)==1)
res <- res[[1]]
return(res)
}
SplitToCol <- function(x, split=" ", fixed = TRUE, na.form="", colnames=NULL){
lst <- lapply(x, function(z)
strsplit(z, split = split, fixed = fixed))
# we don't want to have values recycled here, but need same number
# of elements to afterwards be able to use rbind()
for(i in seq_along(lst)){
# find the maximal length of the splits in the column
maxlen <- max(sapply(lst[[i]], length))
# set all character vectors to same length
for(j in seq_along(lst[[i]])){
length(lst[[i]][[j]]) <- maxlen
# set na.form for missings
lst[[i]][[j]][is.na(lst[[i]][[j]])] <- na.form
}
}
# rbind all the columns
lst <- lapply(lst, function(z) do.call(rbind, z))
res <- do.call(data.frame, list(lst, stringsAsFactors=FALSE))
if(!is.null(colnames))
colnames(res) <- rep(colnames, length.out=ncol(res))
# communicate the number of columns found
attr(res, "cols") <- sapply(lst, ncol)
return(res)
}
SplitToDummy <- function(x, split=",", ...){
# found values
lvl <- sort(unique(unlist(strsplit(x = x, split=split, ...))))
d.frm <- data.frame(x,
sapply(lvl, function(y) grepl(y, x) * 1))
return(d.frm)
}
###
## base: conversion functions ====
CharToAsc <- function(x) {
# Original from Henrik Bengtsson R.oo:
# char2asc <- function (ch, ...) { match(ch, ASCII) - 1 }
# example: x.char <- char2asc(x="Andri")
if(length(x) == 1)
strtoi(charToRaw(x), 16L)
else
sapply(x, function(x) strtoi(charToRaw(x), 16L))
}
AscToChar <- function(i) {
# old version:
# example: AscToChar(x.char)
# ASCII <- intToUtf8(1:256, multiple=TRUE)
# new and far more elegant
# ref: http://datadebrief.blogspot.ch/search/label/R
rawToChar(as.raw(i))
}
HexToDec <- function(x)
# strip potential # from a string x
strtoi(gsub("^#", "", x), 16L)
# example: strtoi(c("9A", "3B"), 16L)
DecToHex <- function(x) as.hexmode(as.numeric(x))
OctToDec <- function(x) strtoi(x, 8L)
# example: strtoi(c("12", "24"), 8L)
DecToOct <- function(x) as.numeric(as.character(as.octmode(as.numeric(x))))
# Alternative: as.numeric(sprintf(242, fmt="%o"))
BinToDec <- function(x) {
# Alternative: bin2dec <- function(x) { sum(2^.subset((length(x)-1):0, x)) }
# example: bin2dec(x=as.numeric(unlist(strsplit("1001", split=NULL)))==1)
strtoi(x, 2L)
}
# example: strtoi(c("100001", "101"), 2L)
# DecToBin <- function (x) {
# # This would be nice, but does not work: (intToBin from R.utils)
# # y <- as.integer(x)
# # class(y) <- "binmode"
# # y <- as.character(y)
# # dim(y) <- dim(x)
# # y
# as.vector(sapply(x, function(x) as.integer(paste(rev(as.integer(intToBits(x))), collapse=""))))
# }
DecToBin <- function (x) {
z <- .Call("_DescTools_conv_DecToBin", PACKAGE = "DescTools", x)
z[x > 536870911] <- NA
return(sub("^0+", "", z))
}
# void dec_to_bin(int number) {
# int remainder;
#
# if(number <= 1) {
# cout << number;
# return;
# }
#
# remainder = number%2;
# dec_to_bin(number >> 1);
# cout << remainder;
# }
# DecToBinC <- function(x){
# z <- .C("dec_to_bin", x = as.integer(x))
# return(z)
# }
RomanToInt <- function (x) {
# opposite to as.roman
roman2int.inner <- function (roman) {
results <- .C("roman2int", roman = as.character(roman), nchar = as.integer(nchar(roman)),
value = integer(1), PACKAGE = "DescTools")
return(results$value)
}
roman <- trimws(toupper(as.character(x)))
tryIt <- function(x) {
retval <- try(roman2int.inner(x), silent = TRUE)
if (is.numeric(retval))
retval
else NA
}
retval <- sapply(roman, tryIt)
retval
}
DegToRad <- function(deg) deg * pi /180
RadToDeg <- function(rad) rad * 180 / pi
ConvUnit <- function(x, from, to){
splitunit <- function(x){
# # split the prefix from the unit for SI units and prefixes
# # prefix pattern, note that da is the only prefix with two characters
# prefpat <- "^([YZEPTGMkhcmunpfazy]|(da|d))"
# # check prefix in combination with SI-unit first
# prefix <- StrExtract(x, pattern=paste0(prefpat, "(m|g|s|A|K|mol|cd|Hz|rad|sr|N|Pa|J|W|C|V|F|Ohm|S|Wb|T|H|lm|lx|Bq|Gy|Sv|kat|l)$"))
# # ... and the extract it from the found valid combination
# prefix <- ifelse(is.na(prefix), NA, StrExtract(prefix, pattern=prefpat))
# fact <- ifelse(is.na(prefix), 1, d.prefix$mult[match(prefix, d.prefix$abbr)])
# unit <- ifelse(is.na(prefix), x, gsub(pattern = gettextf("^%s", prefix), "", x))
#
# list(prefix=prefix, fact=fact, unit=unit)
m <- regexpr(pattern="^([YZEPTGMkhcmunpfazy]|(da|d))", x)
prefix <- ifelse(m == -1, NA, StrLeft(x, attr(m, "match.length")))
fact <- ifelse(is.na(prefix), 1, d.prefix$mult[match(prefix, d.prefix$abbr)])
unit <- ifelse(is.na(prefix), x, StrRight(x, -attr(m, "match.length")))
if(length(grep("^(m|g|s|A|K|mol|cd|Hz|rad|sr|N|Pa|J|W|C|V|F|Ohm|S|Wb|T|H|lm|lx|Bq|Gy|Sv|kat|l)$", unit))==0){
prefix <- NA
fact <- 1
unit <- x
}
list(prefix=prefix, fact=fact, unit=unit)
}
# split prefix and unit
u_from <- splitunit(from)
u_to <- splitunit(to)
convertible <- u_from$unit == u_to$unit
# Check for plausible temperatures first
# Note: C stands for Celsius and Coulomb, F for Fahrenheit and Farad
# Prefixes are only allowed for Kelvin (although, not sure...)
# if(to == "\u00B0C")
if(from == "C") {
if(to == "F")
return(x * 1.8 + 32)
else if(u_to$unit == "K")
return(u_to$fact * x + 273.15)
}
if(from == "F") {
if(to == "C")
return((x - 32) * 5/9)
else if(u_to$unit == "K")
return(u_to$fact * x - 273.15)
}
if(u_from$unit == "K") {
x <- u_from$fact * x
if(to == "C")
return(x + 273.15)
else if(to == "F")
return((x + 273.15) * 1.8 + 32)
}
# then others
# create units as JOIN
# d.u <- merge(d.units[, 1:3], d.units[, 1:3], by.x="to", by.y="to")
# d.u <- d.u[d.u$from.x!=d.u$from.y,]
# d.u <- rbind(d.units[, 1:3],
# data.frame(from=d.u$from.x, to=d.u$from.y, fact=d.u$fact.x/d.u$fact.y))
# d.u$pair <- paste(d.u$from, d.u$to, sep="-")
if(u_from$unit != u_to$unit) {
# lookup conversion factor between units
z <- match(paste(u_from$unit, u_to$unit, sep="-"), d.units$uid)
# units are not convertible if they're not found
if(is.na(z)) {
# no match from-to, look for match to-from
z <- match(paste(u_to$unit, u_from$unit, sep="-"), d.units$uid)
# get the factor if it has been found or set 1 else
if(is.na(z)) {
u_fact <- 1
convertible <- FALSE
} else {
u_fact <- 1/d.units$fact[z]
convertible <- TRUE
}
} else {
# match from-to has been found, get the according factor
u_fact <- d.units$fact[z]
convertible <- TRUE
}
} else {
# same units, set factor 1
u_fact <- 1
}
if(!convertible)
res <- NA
else
res <- x * u_from$fact/u_to$fact * u_fact
# return(list(u_from, u_to, res, u_fact ))
return(res)
}
DoCall <- function (what, args, quote = FALSE, envir = parent.frame()) {
# source: Gmisc
# author: Max Gordon <max@gforge.se>
if (quote)
args <- lapply(args, enquote)
if (is.null(names(args)) ||
is.data.frame(args)){
argn <- args
args <- list()
}else{
# Add all the named arguments
argn <- lapply(names(args)[names(args) != ""], as.name)
names(argn) <- names(args)[names(args) != ""]
# Add the unnamed arguments
argn <- c(argn, args[names(args) == ""])
args <- args[names(args) != ""]
}
if (inherits(x = what, what = "character")){
if(is.character(what)){
fn <- strsplit(what, "[:]{2,3}")[[1]]
what <- if(length(fn)==1) {
get(fn[[1]], envir=envir, mode="function")
} else {
get(fn[[2]], envir=asNamespace(fn[[1]]), mode="function")
}
}
call <- as.call(c(list(what), argn))
}else if (inherits(x = what, "function")){
f_name <- deparse(substitute(what))
call <- as.call(c(list(as.name(f_name)), argn))
args[[f_name]] <- what
}else if (inherits(x = what, what="name")){
call <- as.call(c(list(what, argn)))
}
eval(call,
envir = args,
enclos = envir)
}
MultMerge <- function(..., all.x=TRUE, all.y=TRUE, by=NULL) {
lst <- list(...)
# if just one object, there's nothing to merge
if(length(lst)==1) return(lst[[1]])
if(!is.null(by)){
# merge column is given and must exist in all the data.frames
# we overwrite the row.names and remove the merge column
for(i in seq_along(lst)){
rownames(lst[[i]]) <- lst[[i]][[by]]
lst[[i]][by] <- NULL
}
}
# the columnnames must be unique within the resulting data.frame
unames <- SplitAt(make.unique(unlist(lapply(lst, colnames)), sep = "."),
cumsum(sapply(head(lst, -1), ncol))+1)
for(i in seq_along(unames))
colnames(lst[[i]]) <- unames[[i]]
# works perfectly, but sadly does not pass CRAN check :-(
#
# transform(Reduce(function(y, z)
# merge(y, z, all.x=all.x, all.y=all.x),
# lapply(lst, function(x)
# data.frame(x, rn=row.names(x))
# ))
# , row.names=rn, rn=NULL)
res <- Reduce(function(y, z)
merge(y, z, all.x=all.x, all.y=all.x),
lapply(lst, function(x)
data.frame(x, rn=row.names(x))
))
rownames(res) <- res$rn
res$rn <- NULL
# define a better order than merge is returning, rownames from left to right
seq_ord <- function(xlst){
jj <- character(0)
for(i in seq_along(xlst)){
jj <- c(jj, setdiff(xlst[[i]], jj))
}
return(jj)
}
# the coefficients should be ordered such, that the coeffs of the first model
# come first, then the coeffs from the second model which were not included
# in the model one, then the coeffs from mod3 not present in mod1 and mod2
# and so forth...
ord <- seq_ord(lapply(lst, rownames))
res[ord, ]
if(!is.null(by)){
# restore key and remove rownames if there was one
res <- data.frame(row.names(res), res)
colnames(res)[1] <- by
rownames(res) <- c()
}
return(res)
}
###
## base: transformation functions ====
as.matrix.xtabs <- function(x, ...){
# xtabs would not be converted by as.matrix.default...
attr(x, "class") <- NULL
attr(x, "call") <- NULL
return(x)
}
TextToTable <- function(x, dimnames = NULL, check.names=FALSE, ...){
d.frm <- read.table(text=x, check.names=check.names, ...)
tab <- as.table(as.matrix(d.frm))
if(!is.null(dimnames)) names(dimnames(tab)) <- dimnames
return(tab)
}
NALevel <- function(x, level){
# replaces NAs by the defined level in a factor x
x <- factor(x, exclude=NULL)
levels(x)[is.na(levels(x))] <- level
return(x)
}
Recode <- function(x, ..., elselevel=NA, use.empty=FALSE, num=FALSE){
# if x is character, turn it to factor and reconvert it when finished
if(xchar <- is.character(x)){
x <- factor(x)
}
newlevels <- list(...)
if( sum(duplicated(unlist(newlevels))) > 0) stop ("newlevels contain non unique values!")
# convert numeric values to according levels if all arguments are passed as numerics
if(all(is.numeric(unlist(newlevels))))
newlevels <- lapply(newlevels, function(i) levels(x)[i])
if(is.null(elselevel)) { # leave elselevels as they are
elselevels <- setdiff(levels(x), unlist(newlevels))
names(elselevels) <- elselevels
newlevels <- c(newlevels, elselevels)
} else {
if(!is.na(elselevel)){
newlevels[[length(newlevels)+1]] <- setdiff(levels(x), unlist(newlevels))
names(newlevels)[[length(newlevels)]] <- elselevel
}
}
levels(x) <- newlevels
if(!use.empty) x <- factor(x) # delete potentially empty levels
# handle NA levels
if(any(i <- sapply(lapply(newlevels, is.na), any)))
x[is.na(x)] <- names(newlevels)[i]
# x was character, convert to original then
if(xchar)
x <- as.character
if(num)
x <- as.numeric(as.character(x))
return(x)
}
# RevCode <- function(x, lbound=min(x, na.rm=TRUE), ubound=max(x, na.rm=TRUE)) {
#
# x <- as.numeric(x)
#
# x[x %)(% c(lbound, ubound)] <- NA
#
# return(lbound + ubound - x)
#
# }
RevCode <- function (x, ...) {
if(is.factor(x)) {
levels(x) <- rev(levels(x))
res <- factor(x, levels=rev(levels(x)))
} else if(is.numeric(x)){
res <- (min(x, ...) + max(x, ...) - x)
} else if(is.logical(x)) {
res <- as.logical(1 - x)
} else {
res <- NA
}
return(res)
}
NAIf <- function (x, what) {
x[!is.na(match(x, what))] <- NA
return(x)
}
ZeroIfNA <- function(x) {
# same as zeroifnull in SQL
replace(x, is.na(x), 0L)
}
NAIfZero <- function(x)
replace(x, IsZero(x), NA)
BlankIfNA <- function(x, blank="") {
# same as zeroifnull but with characters
replace(x, is.na(x), blank)
}
NAIfBlank <- function(x)
replace(x, x=="", NA)
NZ <- function(x){
# return non-zero elements of x
x[ !IsZero(x) ]
}
Impute <- function(x, FUN = function(x) median(x, na.rm=TRUE)) {
if(is.function(FUN)) {
# if FUN is a function, then save it under new name and
# overwrite function name in FUN, which has to be character
fct <- FUN
FUN <- "fct"
FUN <- gettextf("%s(x)", FUN)
}
# Calculates the mean absolute deviation from the sample mean.
return(eval(parse(text = gettextf("replace(x, is.na(x), %s)", FUN))))
}
reorder.factor <- function(x, X, FUN, ..., order=is.ordered(x), new.order,
sort=SortMixed) {
# 25.11.2017 verbatim from gdata, Greg Warnes
constructor <- if (order) ordered else factor
if(!missing(X) || !missing(FUN)){
if(missing(FUN)) FUN <- 'mean'
## I would prefer to call stats::reorder.default directly,
## but it exported from stats, so the relevant code is
## replicated here:
## -->
scores <- tapply(X = X, INDEX = x, FUN = FUN, ...)
levels <- names(base::sort(scores, na.last = TRUE))
if(order)
ans <- ordered(x, levels=levels)
else
ans <- factor(x, levels=levels)
attr(ans, "scores") <- scores
## <--
return(ans)
} else if (!missing(new.order)) {
if (is.numeric(new.order))
new.order <- levels(x)[new.order]
else
new.order <- new.order
} else
new.order <- sort(levels(x))
constructor(x, levels=new.order)
}
SortMixed <- function(x,
decreasing=FALSE,
na.last=TRUE,
blank.last=FALSE,
numeric.type=c("decimal", "roman"),
roman.case=c("upper","lower","both") ) {
ord <- OrderMixed(x,
decreasing=decreasing,
na.last=na.last,
blank.last=blank.last,
numeric.type=numeric.type,
roman.case=roman.case
)
x[ord]
}
OrderMixed <- function(x,
decreasing=FALSE,
na.last=TRUE,
blank.last=FALSE,
numeric.type=c("decimal", "roman"),
roman.case=c("upper","lower","both") ) {
# 25.11.2017 verbatim from gtools, Greg Warnes
# - Split each each character string into an vector of strings and
# numbers
# - Separately rank numbers and strings
# - Combine orders so that strings follow numbers
numeric.type <- match.arg(numeric.type)
roman.case <- match.arg(roman.case)
if(length(x)<1)
return(NULL)
else if(length(x)==1)
return(1)
if( !is.character(x) )
return( order(x, decreasing=decreasing, na.last=na.last) )
delim="\\$\\@\\$"
if(numeric.type=="decimal")
{
regex <- "((?:(?i)(?:[-+]?)(?:(?=[.]?[0123456789])(?:[0123456789]*)(?:(?:[.])(?:[0123456789]{0,}))?)(?:(?:[eE])(?:(?:[-+]?)(?:[0123456789]+))|)))" # uses PERL syntax
numeric <- function(x) as.numeric(x)
}
else if (numeric.type=="roman")
{
regex <- switch(roman.case,
"both" = "([IVXCLDMivxcldm]+)",
"upper" = "([IVXCLDM]+)",
"lower" = "([ivxcldm]+)"
)
numeric <- function(x) RomanToInt(x)
}
else
stop("Unknown value for numeric.type: ", numeric.type)
nonnumeric <- function(x)
{
ifelse(is.na(numeric(x)), toupper(x), NA)
}
x <- as.character(x)
which.nas <- which(is.na(x))
which.blanks <- which(x=="")
####
# - Convert each character string into an vector containing single
# character and numeric values.
####
# find and mark numbers in the form of +1.23e+45.67
delimited <- gsub(regex,
paste(delim,"\\1",delim,sep=""),
x,
perl=TRUE)
# separate out numbers
step1 <- strsplit(delimited, delim)
# remove empty elements
step1 <- lapply( step1, function(x) x[x>""] )
# create numeric version of data
suppressWarnings( step1.numeric <- lapply( step1, numeric ) )
# create non-numeric version of data
suppressWarnings( step1.character <- lapply( step1, nonnumeric ) )
# now transpose so that 1st vector contains 1st element from each
# original string
maxelem <- max(sapply(step1, length))
step1.numeric.t <- lapply(1:maxelem,
function(i)
sapply(step1.numeric,
function(x)x[i])
)
step1.character.t <- lapply(1:maxelem,
function(i)
sapply(step1.character,
function(x)x[i])
)
# now order them
rank.numeric <- sapply(step1.numeric.t, rank)
rank.character <- sapply(step1.character.t,
function(x) as.numeric(factor(x)))
# and merge
rank.numeric[!is.na(rank.character)] <- 0 # mask off string values
rank.character <- t(
t(rank.character) +
apply(matrix(rank.numeric),2,max,na.rm=TRUE)
)
rank.overall <- ifelse(is.na(rank.character),rank.numeric,rank.character)
order.frame <- as.data.frame(rank.overall)
if(length(which.nas) > 0)
if(is.na(na.last))
order.frame[which.nas,] <- NA
else if(na.last)
order.frame[which.nas,] <- Inf
else
order.frame[which.nas,] <- -Inf
if(length(which.blanks) > 0)
if(is.na(blank.last))
order.frame[which.blanks,] <- NA
else if(blank.last)
order.frame[which.blanks,] <- 1e99
else
order.frame[which.blanks,] <- -1e99
order.frame <- as.list(order.frame)
order.frame$decreasing <- decreasing
order.frame$na.last <- NA
retval <- do.call("order", order.frame)
return(retval)
}
#
#
# Lookup <- function(x, ref, val){
# val[match(x, ref)]
# }
# StahelLogC <- function(x, na.rm=FALSE) {
# if(na.rm) x <- na.omit(x)
# ### muessen die 0-Werte hier weggelassen werden??
# x <- x[x>0]
# ### additive Konstante fuer die Logarithmierung nach Stahel "...es hat sich gezeigt, dass..."
# return(as.vector(median(x) / (median(x)/quantile(x, 0.25))^2.9))
# }
# http://support.sas.com/documentation/cdl/en/statugfreq/63124/PDF/default/statugfreq.pdf
LogSt <- function(x, base = 10, calib = x, threshold = NULL, mult = 1) {
# original function logst in source regr
#
# # Purpose: logs of x, zeros and small values treated well
# # *********************************************************************
# # Author: Werner Stahel, Date: 3 Nov 2001, 08:22
# x <- cbind(x)
# calib <- cbind(calib)
# lncol <- ncol(calib)
# ljthr <- length(threshold) > 0
# if (ljthr) {
# if (!length(threshold) %in% c(1, lncol))
# stop("!LogSt! length of argument 'threshold' is inadequate")
# lthr <- rep(threshold, length=lncol)
# ljdt <- !is.na(lthr)
# } else {
# ljdt <- rep(TRUE, lncol)
# lthr <- rep(NA, lncol)
# for (lj in 1:lncol) {
# lcal <- calib[, lj]
# ldp <- lcal[lcal > 0 & !is.na(lcal)]
# if(length(ldp) == 0) ljdt[lj] <- FALSE else {
# lq <- quantile(ldp,probs = c(0.25,0.75), na.rm = TRUE)
# if(lq[1] == lq[2]) lq[1] <- lq[2]/2
# lthr[lj] <- lc <- lq[1]^(1 + mult) / lq[2]^mult
# }
# }
# }
# # transform x
# for (lj in 1:lncol) {
# ldt <- x[,lj]
# lc <- lthr[lj]
# li <- which(ldt < lc)
# if (length(li))
# ldt[li] <- lc * 10^((ldt[li] - lc) / (lc * log(10)))
# x[,lj] <- log10(ldt)
# }
# if (length(colnames(x)))
# lnmpd <- names(ljdt) <- names(lthr) <- colnames(x) else
# lnmpd <- as.character(1:lncol)
#
# attr(x,"threshold") <- c(lthr)
#
# if (any(!ljdt)) {
# warning(':LogSt: no positive x for variables',lnmpd[!ljdt],
# '. These are not transformed')
# attr(x,"untransformed") <- c(ljdt)
# }
# x
if(is.null(threshold)){
lq <- quantile(calib[calib > 0], probs = c(0.25, 0.75), na.rm = TRUE)
if (lq[1] == lq[2]) lq[1] <- lq[2]/2
threshold <- lq[1]^(1 + mult)/lq[2]^mult
}
res <- rep(NA, length(x))
idx <- (x < threshold)
idx.na <- is.na(idx)
res[idx & !idx.na] <- log(x = threshold, base=base) + ((x[idx & !idx.na] - threshold)/(threshold * log(base)))
res[!idx & !idx.na] <- log(x = x[!idx & !idx.na], base=base)
attr(res, "threshold") <- threshold
attr(res, "base") <- base
return(res)
}
LogStInv <- function (x, base=NULL, threshold = NULL) {
if(is.null(threshold)) threshold <- attr(x, "threshold")
if(is.null(base)) base <- attr(x, "base")
res <- rep(NA, length(x))
idx <- (x < (lgth <- log(threshold, base)))
idx.na <- is.na(idx)
res[ idx & !idx.na] <- threshold - (threshold * log(base)) * (lgth - x[idx & !idx.na])
res[!idx & !idx.na] <- base^(x[!idx & !idx.na])
return(res)
}
# Variance stabilizing functions
# log(x+a)
# log(x+a, base=10)
# sqrt(x+a)
# 1/x
# arcsinh(x)
# LogGen <- function(x, a) { return( log((x + sqrt(x^2 + a^2)) / 2)) }
#
#
# LogLin <- function(x, a) {
# # log-linear hybrid transformation
# # introduced by Rocke and Durbin (2003)
# x[x<=a] <- x[x<=a] / a + log(a) - 1
# x[x>a] <- log(x[x>a])
#
# return(x)
# }
Logit <- function(x, min=0, max=1) {
# variant in boot:::logit - CHECKME if better ********
p <- (x-min)/(max-min)
log(p/(1-p))
}
LogitInv <- function(x, min=0, max=1) {
p <- exp(x)/(1+exp(x))
p <- ifelse( is.na(p) & !is.na(x), 1, p ) # fix problems with +Inf
p * (max-min) + min
}
# from library(forecast)
BoxCox <- function (x, lambda) {
# Author: Rob J Hyndman
# origin: library(forecast)
if (lambda < 0)
x[x < 0] <- NA
if (lambda == 0)
out <- log(x)
else out <- (sign(x) * abs(x)^lambda - 1)/lambda
if (!is.null(colnames(x)))
colnames(out) <- colnames(x)
return(out)
# Greg Snow's Variant
# BoxCox <- function (x, lambda)
# {
# ### Author: Greg Snow
# ### Source: Teaching Demos
# xx <- exp(mean(log(x)))
# if (lambda == 0)
# return(log(x) * xx)
# res <- (x^lambda - 1)/(lambda * xx^(lambda - 1))
# return(res)
# }
}
BoxCoxInv <- function(x, lambda){
if (lambda < 0)
x[x > -1/lambda] <- NA
if (lambda == 0)
out <- exp(x)
else {
xx <- x * lambda + 1
out <- sign(xx) * abs(xx)^(1/lambda)
}
if (!is.null(colnames(x)))
colnames(out) <- colnames(x)
return(out)
}
# This R script contains code for extracting the Box-Cox
# parameter, lambda, using Guerrero's method (1993).
# Written by Leanne Chhay
BoxCoxLambda <- function(x, method=c("guerrero","loglik"), lower=-1, upper=2) {
# Guerrero extracts the required lambda
# Input: x = original time series as a time series object
# Output: lambda that minimises the coefficient of variation
Guerrero <- function(x, lower=-1, upper=2, nonseasonal.length=2) {
# guer.cv computes the coefficient of variation
# Input:
# lam = lambda
# x = original time series as a time series object
# Output: coefficient of variation
guer.cv <- function(lam, x, nonseasonal.length=2) {
period <- max(nonseasonal.length, frequency(x))
nobsf <- length(x)
nyr <- floor(nobsf / period)
nobst <- nyr * period
x.mat <- matrix(x[(nobsf-nobst+1):nobsf], period, nyr)
x.mean <- apply(x.mat, 2, mean, na.rm=TRUE)
x.sd <- apply(x.mat, 2, sd, na.rm=TRUE)
x.rat <- x.sd / x.mean^(1-lam)
return(sd(x.rat, na.rm=TRUE)/mean(x.rat, na.rm=TRUE))
}
return(optimize(guer.cv, c(lower,upper), x=x,
nonseasonal.length=nonseasonal.length)$minimum)
}
# Modified version of boxcox from MASS package
BCLogLik <- function(x, lower=-1, upper=2) {
n <- length(x)
if (any(x <= 0))
stop("x must be positive")
logx <- log(x)
xdot <- exp(mean(logx))
# if(all(class(x)!="ts"))
fit <- lm(x ~ 1, data=data.frame(x=x))
# else if(frequency(x)>1)
# fit <- tslm(x ~ trend + season, data=data.frame(x=x))
# else
# fit <- tslm(x ~ trend, data=data.frame(x=x))
xqr <- fit$qr
lambda <- seq(lower,upper,by=.05)
xl <- loglik <- as.vector(lambda)
m <- length(xl)
for (i in 1L:m)
{
if (abs(la <- xl[i]) > 0.02)
xt <- (x^la - 1)/la
else
xt <- logx * (1 + (la*logx)/2 * (1+(la*logx)/3*(1+(la*logx)/4)))
loglik[i] <- -n/2 * log(sum(qr.resid(xqr, xt/xdot^(la-1))^2))
}
return(xl[which.max(loglik)])
}
if(any(x <= 0))
lower <- 0
# stop("All values must be positive")
method <- match.arg(method)
if(method=="loglik")
return(BCLogLik(x,lower,upper))
else
return(Guerrero(x,lower,upper))
}
LOCF <- function(x) UseMethod("LOCF")
LOCF.default <- function(x) {
# last observation carried forward
# replaces NAs by the last observed value
# while(any(is.na(x))) {
# x[is.na(x)] <- x[which(is.na(x))-1]
# }
# return(x)
# faster solution from Daniel Wollschlaeger:
# corrected by 0.99.19, as this didn't handle c(NA, 3.0, NA, 5,5) correctly
# rep(x[!is.na(x)], diff(c(which(!is.na(x)), length(x)+1)))
l <- !is.na(x)
rep(c(NA, x[l]), diff(c(1L, which(l), length(x) + 1L)))
}
LOCF.data.frame <- function(x){
as.data.frame(lapply(x, LOCF))
}
LOCF.matrix <- function(x){
apply(x, 2L, LOCF)
}
# Alternative names: PairApply, PwApply, pwapply, papply, ...
PairApply <- function(x, FUN = NULL, ..., symmetric = FALSE){
if(is.function(FUN)) {
# if FUN is a function, then save it under new name and
# overwrite function name in FUN, which has to be character
fct <- FUN
FUN <- "fct"
}
if(is.matrix(x)) x <- as.data.frame(x)
x <- as.list(x)
ix <- 1:length(x)
# pairwise logic from pairwise.table
pp <- outer(ix, ix, function(ivec, jvec) sapply(seq_along(ivec),
function(k) {
i <- ivec[[k]]
j <- jvec[[k]]
if (i >= j)
eval(parse(text = gettextf("%s(x[[i]], x[[j]], ...)", FUN)))
else NA
}))
# why did we need that? in any case it's wrong, if no symmetric calcs are done
# diag(pp) <- 1
if(symmetric){
pp[upper.tri(pp)] <- t(pp)[upper.tri(t(pp))]
} else {
pp.upr <- outer(ix, ix, function(ivec, jvec) sapply(seq_along(ivec),
function(k) {
i <- ivec[[k]]
j <- jvec[[k]]
if (i >= j)
eval(parse(text = gettextf("%s(x[[j]], x[[i]], ...)", FUN)))
else NA
}))
pp[upper.tri(pp)] <- t(pp.upr)[upper.tri(pp.upr)]
}
dimnames(pp) <- list(names(x),names(x))
return(pp)
}
###
## base: date functions ====
# fastPOSIXct <- function(x, tz=NULL, required.components = 3L)
# .POSIXct(if (is.character(x)) .Call("parse_ts", x, required.components) else .Call("parse_ts", as.character(x), required.components), tz)
HmsToMinute <- function(x){
Hour(x)*60 + Minute(x) + Second(x)/60
}
HmsToSec <- function(x) {
hms <- as.character(x)
z <- sapply(data.frame(do.call(rbind, strsplit(hms, ":"))),
function(x) { as.numeric(as.character(x)) })
z[,1] * 3600 + z[,2] * 60 + z[,3]
}
SecToHms <- function(x, digits=NULL) {
x <- as.numeric(x)
h <- floor(x/3600)
m <- floor((x-h*3600)/60)
s <- floor(x-(m*60 + h*3600))
b <- x-(s + m*60 + h*3600)
if(is.null(digits)) digits <- ifelse(all(b < sqrt(.Machine$double.eps)),0, 2)
if(digits==0) f <- "" else f <- gettextf(paste(".%0", digits, "d", sep=""), round(b*10^digits, 0))
gettextf("%02d:%02d:%02d%s", h, m, s, f)
}
IsDate <- function(x, what=c('either','both','timeVaries')) {
what <- match.arg(what)
cl <- class(x) # was oldClass 22jun03
if(!length(cl)) return(FALSE)
dc <- c('POSIXt','POSIXct','dates','times','chron','Date')
dtc <- c('POSIXt','POSIXct','chron')
switch(what,
either = any(cl %in% dc),
both = any(cl %in% dtc),
timeVaries = {
# original: if('chron' %in% cl || !.R.) { ### chron or S+ timeDate
if('chron' %in% cl) { # chron ok, but who cares about S+?
y <- as.numeric(x)
length(unique(round(y - floor(y), 13L))) > 1
} else {
length(unique(format(x, '%H%M%S'))) > 1
}
}
)
}
IsWeekend <- function(x) {
x <- as.POSIXlt(x)
x$wday > 5L | x$wday < 1L
}
# This is not useful anymore. Use: as.Date(ISODate())
# Date <- function(year, month = NA, day = NA) {
# if(is.na(month) && is.na(day)) {
# # try to interpret year as yearmonthday yyyymmdd
# res <- as.Date(ISOdate(year %/% 10000, (year %% 10000) %/% 100, (year %% 100)))
# } else {
# res <- as.Date(ISOdate(year, month, day))
# }
# return(res)
# }
# Year <- function(x){ as.integer( format(as.Date(x), "%Y") ) }
Year <- function(x){
UseMethod("Year")
}
Year.default <- function(x){ as.POSIXlt(x)$year + 1900L }
IsLeapYear <- function(x){
if(!IsWhole(x))
x <- Year(as.Date(x))
ifelse(x %% 100L == 0L, x %% 400L == 0L, x %% 4L == 0L)
}
Month <- function(x, fmt = c("m", "mm", "mmm"),
lang = DescToolsOptions("lang"), stringsAsFactors = TRUE) {
UseMethod("Month")
}
Month.ym <- function(x, fmt = c("m", "mm", "mmm"),
lang = DescToolsOptions("lang"), stringsAsFactors = TRUE) {
# unclass(x - Year(x) * 100)
x <- as.Date(x)
NextMethod()
}
Month.default <- function(x, fmt = c("m", "mm", "mmm"),
lang = DescToolsOptions("lang"), stringsAsFactors = TRUE) {
res <- as.POSIXlt(x)$mon + 1L
switch(match.arg(arg = fmt, choices = c("m", "mm", "mmm")),
m = { res },
mm = {
# res <- as.integer(format(x, "%m"))
switch(match.arg(arg = lang, choices = c("local", "engl")),
local = {
# months in current locale: format(ISOdate(2000, 1:12, 1), "%b")
res <- ordered(res, levels=1L:12L, labels=format(ISOdate(2000L, 1L:12L, 1L), "%b"))
},
engl = {
res <- ordered(res, levels=1L:12L, labels=month.abb)
})
if(!stringsAsFactors) res <- as.character(res)
},
mmm = {
# res <- as.integer(format(x, "%m"))
switch(match.arg(arg = lang, choices = c("local", "engl")),
local = {
# months in current locale: format(ISOdate(2000, 1:12, 1), "%b")
res <- ordered(res, levels=1L:12L, labels=format(ISOdate(2000L, 1L:12L, 1L), "%B"))
},
engl = {
res <- ordered(res, levels=1L:12L, labels=month.name)
})
if(!stringsAsFactors) res <- as.character(res)
})
return(res)
}
Week <- function(x, method = c("iso", "us")){
# cast x to date, such as being able to handle POSIX-Dates automatically
x <- as.Date(x)
method <- match.arg(method, c("iso", "us"))
switch(method,
"iso" = {
#??? fast implementation in lubridate:
# xday <- ISOdate(year(x), month(x), day(x), tz = tz(x))
# dn <- 1 + (wday(x) + 5)%%7
# nth <- xday + ddays(4 - dn)
# jan1 <- ISOdate(year(nth), 1, 1, tz = tz(x))
# 1 + (nth - jan1)%/%ddays(7)
# The weeknumber is the number of weeks between the
# first thursday of the year and the thursday in the target week
# der Donnerstag in der Zielwoche
# x.y <- Year(x)
# x.weekday <- Weekday(x)
#
# x.thursday <- (x - x.weekday + 4)
# # der erste Donnerstag des Jahres
# jan1.weekday <- Weekday(as.Date(paste(x.y, "01-01", sep="-")))
# first.thursday <- as.Date(paste(x.y, "01", (5 + 7*(jan1.weekday > 4) - jan1.weekday), sep="-"))
#
# wn <- (as.integer(x.thursday - first.thursday) %/% 7) + 1 - ((x.weekday < 4) & (Year(x.thursday) != Year(first.thursday)))*52
# wn <- ifelse(wn == 0, Week(as.Date(paste(x.y-1, "12-31", sep="-"))), wn)
z <- x + (3 - (as.POSIXlt(x)$wday + 6) %% 7)
jan1 <- as.Date(paste(Year(z), "-01-01", sep=""))
wn <- 1 + as.integer(z - jan1) %/% 7
},
"us"={
wn <- as.numeric(strftime(as.POSIXlt(x), format="%W"))
}
)
return(wn)
}
# Day <- function(x){ as.integer(format(as.Date(x), "%d") ) }
Day <- function(x){ as.POSIXlt(x)$mday }
# Accessor for Day, as defined by library(lubridate)
"Day<-" <- function(x, value) { x <- x + (value - Day(x)) }
Weekday <- function (x, fmt = c("d", "dd", "ddd"), lang = DescToolsOptions("lang"), stringsAsFactors = TRUE) {
# x <- as.Date(x)
res <- as.POSIXlt(x)$wday
res <- replace(res, res==0, 7)
switch(match.arg(arg = fmt, choices = c("d", "dd", "ddd")),
d = { res },
dd = {
# weekdays in current locale, Sunday : Saturday, format(ISOdate(2000, 1, 2:8), "%A")
switch(match.arg(arg = lang, choices = c("local", "engl")),
local = {
# months in current locale: format(ISOdate(2000, 1:12, 1), "%b")
res <- ordered(res, levels=1:7, labels=format(ISOdate(2000, 1, 3:9), "%a"))
},
engl = {
res <- ordered(res, levels=1:7, labels=day.abb)
})
if(!stringsAsFactors) res <- as.character(res)
},
ddd = {
# weekdays in current locale, Sunday : Saturday, format(ISOdate(2000, 1, 2:8), "%A")
switch(match.arg(arg = lang, choices = c("local", "engl")),
local = {
# months in current locale: format(ISOdate(2000, 1:12, 1), "%b")
res <- ordered(res, levels=1:7, labels=format(ISOdate(2000, 1, 3:9), "%A"))
},
engl = {
res <- ordered(res, levels=1:7, labels=day.name)
})
if(!stringsAsFactors) res <- as.character(res)
})
return(res)
}
CountWorkDays <- function(from, to,
holiday=NULL, nonworkdays=c("Sat","Sun")) {
.workDays <- function(from, to,
holiday=NULL, nonworkdays=c("Sat","Sun")) {
d <- as.integer(to - from)
w <- (d %/% 7)
res <- w * (7-length(nonworkdays)) +
sum(Weekday(seq(from + w*7, to, 1), fmt="dd", lang="engl") %nin% nonworkdays)
if(!is.null(holiday)){
# count holidays in period
h <- holiday[holiday %[]% c(from, to)]
res <- res - sum(Weekday(h, fmt="dd", lang="engl") %nin% nonworkdays)
}
return(res)
}
ll <- Recycle(from=from, to=to)
res <- integer(attr(ll, "maxdim"))
for(i in 1:attr(ll, "maxdim"))
res[i] <- .workDays(ll$from[i], ll$to[i], holiday=holiday, nonworkdays=nonworkdays)
return(res)
}
Quarter <- function (x) {
# Berechnet das Quartal eines Datums
# y <- as.numeric( format( x, "%Y") )
# paste(y, "Q", (as.POSIXlt(x)$mon)%/%3 + 1, sep = "")
# old definition is counterintuitive...
return((as.POSIXlt(x)$mon) %/% 3L + 1L)
}
YearDay <- function(x) {
# return(as.integer(format(as.Date(x), "%j")))
# As ?POSIXlt reveals, a $yday suffix to a POSIXlt date (or even a vector of such)
# will convert to day of year.
# Beware that POSIX counts Jan 1 as day 0, so you might want to add 1 to the result.
return(as.POSIXlt(x)$yday + 1L)
}
Today <- function() Sys.Date()
Now <- function() Sys.time()
Hour <- function(x) {
# strptime(x, "%H")
as.POSIXlt(x)$hour
}
Minute <- function(x) {
# strptime(x, "%M")
as.POSIXlt(x)$min
}
Second <- function(x) {
# strptime(x, "%S")
as.POSIXlt(x)$sec
}
Timezone <- function(x) {
as.POSIXlt(x)$zone
}
YearMonth <- function(x){
# returns the yearmonth representation of a date x
x <- as.POSIXlt(x)
return(as.ym((x$year + 1900L)*100L + x$mon + 1L))
}
Year.ym <- function(x){ unclass(round((x/100))) }
# define a new class ym ("yearmonth")
as.ym <- function(x){
# expects a YYYYMM format
res <- structure(as.integer(x), class = c("ym", "num"))
res[!((y <- round(x/100)) %[]% c(1000, 3000) &
(x - y * 100) %[]% c(1, 12))] <- NA_integer_
return(res)
}
print.ym <- function(x, ...) {
# do not print the class attributes
print(unclass(x), ...)
}
as.Date.ym <- function(x, d=1, ...){
as.Date(gsub("([0-9]{4})([0-9]{2})([0-9]{2})", "\\1-\\2-\\3",
x*100 + d))
}
DiffDays360 <- function(start_d, end_d, method=c("eu","us")){
# source: http://en.wikipedia.org/wiki/360-day_calendar
start_d <- as.Date(start_d)
end_d <- as.Date(end_d)
d1 <- Day(start_d)
m1 <- Month(start_d)
y1 <- Year(start_d)
d2 <- Day(end_d)
m2 <- Month(end_d)
y2 <- Year(end_d)
method = match.arg(method)
switch(method,
"eu" = {
if(Day(start_d)==31L) start_d <- start_d-1L
if(Day(end_d)==31L) end_d <- end_d-1L
}
, "us" ={
if( (Day(start_d+1L)==1L & Month(start_d+1L)==3L) &
(Day(end_d+1L)==1L & Month(end_d+1L)==3L)) d2 <- 30L
if( d1==31L ||
(Day(start_d+1L)==1L & Month(start_d+1L)==3L)) {
d1 <- 30L
if(d2==31L) d2 <- 30L
}
}
)
return( (y2-y1)*360L + (m2-m1)*30L + d2-d1)
}
LastDayOfMonth <- function(x){
z <- AddMonths(x, 1L)
Day(z) <- 1L
return(z - 1L)
}
YearDays <- function (x) {
x <- as.POSIXlt(x)
x$mon[] <- x$mday[] <- x$sec[] <- x$min <- x$hour <- 0
x$year <- x$year + 1
return(as.POSIXlt(as.POSIXct(x))$yday + 1)
}
MonthDays <- function (x) {
x <- as.POSIXlt(x)
x$mday[] <- x$sec[] <- x$min <- x$hour <- 0
x$mon <- x$mon + 1
return(as.POSIXlt(as.POSIXct(x))$mday)
}
AddMonths <- function (x, n, ...) {
UseMethod("AddMonths")
}
AddMonths.default <- function (x, n, ...) {
.addMonths <- function (x, n) {
# ref: http://stackoverflow.com/questions/14169620/add-a-month-to-a-date
# Author: Antonio
# no ceiling
res <- sapply(x, seq, by = paste(n, "months"), length = 2L)[2L,]
# sapply kills the Date class, so recreate down the road
# ceiling
DescTools::Day(x) <- 1L
res_c <- sapply(x, seq, by = paste(n + 1L, "months"), length = 2L)[2L,] - 1L
# use ceiling in case of overlapping
res <- pmin(res, res_c)
return(res)
}
x <- as.Date(x, ...)
res <- mapply(.addMonths, x, n)
# mapply (as sapply above) kills the Date class, so recreate here
# and return res in the same class as x
class(res) <- "Date"
return(res)
}
AddMonths.ym <- function (x, n, ...) {
.addMonths <- function (x, n) {
if (x %[]% c(100001L, 999912L)) {
# Author: Roland Rapold
# YYYYMM
y <- x %/% 100L
m <- x - y * 100L
res <- (y - 10L + ((m + n + 120L - 1L) %/% 12L)) * 100L +
((m + n + 120L - 1L) %% 12L) + 1L
} else if (x %[]% c(10000101L, 99991231L)) {
# YYYYMMDD
res <- DescTools::AddMonths(x = as.Date(as.character(x), "%Y%m%d"), n = n)
res <- DescTools::Year(res)*10000L + DescTools::Month(res)*100L + Day(res)
}
return(res)
}
res <- mapply(.addMonths, x, n)
return(res)
}
Zodiac <- function(x, lang = c("engl","deu"), stringsAsFactors = TRUE) {
switch(match.arg(lang, choices=c("engl","deu"))
, engl = {z <- c("Capricorn","Aquarius","Pisces","Aries","Taurus","Gemini","Cancer","Leo","Virgo","Libra","Scorpio","Sagittarius","Capricorn") }
, deu = {z <- c("Steinbock","Wassermann","Fische","Widder","Stier","Zwillinge","Krebs","Loewe","Jungfrau","Waage","Skorpion","Schuetze","Steinbock") }
)
# i <- cut(DescTools::Month(x)*100 + DescTools::Day(x),
# breaks=c(0,120,218,320,420,520,621,722,822,923,1023,1122,1221,1231))
i <- cut(DescTools::Month(x) * 100 + DescTools::Day(x),
breaks = c(0,120,218,320,420,520,621,722,823,922,1023,1122,1222,1231),
right=FALSE, include.lowest = TRUE)
if(stringsAsFactors){
res <- i
levels(res) <- z
} else {
res <- z[i]
}
return(res)
}
axTicks.POSIXct <- function (side, x, at, format, labels = TRUE, ...) {
# This is completely original R-code with one exception:
# Not an axis is drawn but z are returned.
mat <- missing(at) || is.null(at)
if (!mat)
x <- as.POSIXct(at)
else x <- as.POSIXct(x)
range <- par("usr")[if (side %% 2L)
1L:2L
else 3L:4L]
d <- range[2L] - range[1L]
z <- c(range, x[is.finite(x)])
attr(z, "tzone") <- attr(x, "tzone")
if (d < 1.1 * 60) {
sc <- 1
if (missing(format))
format <- "%S"
}
else if (d < 1.1 * 60 * 60) {
sc <- 60
if (missing(format))
format <- "%M:%S"
}
else if (d < 1.1 * 60 * 60 * 24) {
sc <- 60 * 60
if (missing(format))
format <- "%H:%M"
}
else if (d < 2 * 60 * 60 * 24) {
sc <- 60 * 60
if (missing(format))
format <- "%a %H:%M"
}
else if (d < 7 * 60 * 60 * 24) {
sc <- 60 * 60 * 24
if (missing(format))
format <- "%a"
}
else {
sc <- 60 * 60 * 24
}
if (d < 60 * 60 * 24 * 50) {
zz <- pretty(z/sc)
z <- zz * sc
z <- .POSIXct(z, attr(x, "tzone"))
if (sc == 60 * 60 * 24)
z <- as.POSIXct(round(z, "days"))
if (missing(format))
format <- "%b %d"
}
else if (d < 1.1 * 60 * 60 * 24 * 365) {
z <- .POSIXct(z, attr(x, "tzone"))
zz <- as.POSIXlt(z)
zz$mday <- zz$wday <- zz$yday <- 1
zz$isdst <- -1
zz$hour <- zz$min <- zz$sec <- 0
zz$mon <- pretty(zz$mon)
m <- length(zz$mon)
M <- 2 * m
m <- rep.int(zz$year[1L], m)
zz$year <- c(m, m + 1)
zz <- lapply(zz, function(x) rep(x, length.out = M))
zz <- .POSIXlt(zz, attr(x, "tzone"))
z <- as.POSIXct(zz)
if (missing(format))
format <- "%b"
}
else {
z <- .POSIXct(z, attr(x, "tzone"))
zz <- as.POSIXlt(z)
zz$mday <- zz$wday <- zz$yday <- 1
zz$isdst <- -1
zz$mon <- zz$hour <- zz$min <- zz$sec <- 0
zz$year <- pretty(zz$year)
M <- length(zz$year)
zz <- lapply(zz, function(x) rep(x, length.out = M))
z <- as.POSIXct(.POSIXlt(zz))
if (missing(format))
format <- "%Y"
}
if (!mat)
z <- x[is.finite(x)]
keep <- z >= range[1L] & z <= range[2L]
z <- z[keep]
if (!is.logical(labels))
labels <- labels[keep]
else if (identical(labels, TRUE))
labels <- format(z, format = format)
else if (identical(labels, FALSE))
labels <- rep("", length(z))
# axis(side, at = z, labels = labels, ...)
# return(list(at=z, labels=labels))
return(z)
}
axTicks.Date <- function(side = 1, x, ...) {
## This functions is almost a copy of axis.Date
x <- as.Date(x)
range <- par("usr")[if (side%%2)
1L:2L
else 3:4L]
range[1L] <- ceiling(range[1L])
range[2L] <- floor(range[2L])
d <- range[2L] - range[1L]
z <- c(range, x[is.finite(x)])
class(z) <- "Date"
if (d < 7)
format <- "%a"
if (d < 100) {
z <- structure(pretty(z), class = "Date")
format <- "%b %d"
}
else if (d < 1.1 * 365) {
zz <- as.POSIXlt(z)
zz$mday <- 1
zz$mon <- pretty(zz$mon)
m <- length(zz$mon)
m <- rep.int(zz$year[1L], m)
zz$year <- c(m, m + 1)
z <- as.Date(zz)
format <- "%b"
}
else {
zz <- as.POSIXlt(z)
zz$mday <- 1
zz$mon <- 0
zz$year <- pretty(zz$year)
z <- as.Date(zz)
format <- "%Y"
}
keep <- z >= range[1L] & z <= range[2L]
z <- z[keep]
z <- sort(unique(z))
class(z) <- "Date"
z
}
###
## base: information functions ====
# Between operators
`%[]%` <- function(x, rng) {
if(is.matrix(rng)){
# recycle things
# which parameter has the highest dimension
maxdim <- max(length(x), nrow(rng))
# recycle all params to maxdim
x <- rep(x, length.out = maxdim)
# the rows of the matrix rng
rng <- rng[rep(1:nrow(rng), length.out = maxdim),]
res <- .Call("between_num_lrm", as.numeric(x),
as.numeric(rng[, 1L]), as.numeric(rng[, 2L]), PACKAGE="DescTools")
res[is.na(x)] <- NA
return( res )
}
if(is.numeric(x) || IsDate(x)) {
# as.numeric still needed for casting integer to numeric!!
res <- .Call("between_num_lr", as.numeric(x), as.numeric(rng[1]), as.numeric(rng[2]), PACKAGE="DescTools")
res[is.na(x)] <- NA
} else if(is.ordered(x)) {
res <- .Call("between_num_lr", as.numeric(x),
as.numeric(match(rng[1L], levels(x))),
as.numeric(match(rng[2L], levels(x))), PACKAGE="DescTools")
res[is.na(x)] <- NA
} else if(inherits(x = x, what = "character")) {
res <- ifelse ( x >= rng[1L] & x <= rng[2L], TRUE, FALSE )
} else {
res <- rep(NA, length(x))
}
return(res)
}
`%(]%` <- function(x, rng) {
if(is.matrix(rng)){
# recycle things
# which parameter has the highest dimension
maxdim <- max(length(x), nrow(rng))
# recycle all params to maxdim
x <- rep(x, length.out = maxdim)
# the rows of the matrix rng
rng <- rng[rep(1L:nrow(rng), length.out = maxdim),]
res <- .Call("between_num_rm", as.numeric(x),
as.numeric(rng[, 1L]), as.numeric(rng[, 2L]), PACKAGE="DescTools")
res[is.na(x)] <- NA
return( res)
}
if(is.numeric(x) || IsDate(x)) {
# as.numeric still needed for casting integer to numeric!!
res <- .Call("between_num_r", as.numeric(x), as.numeric(rng[1L]), as.numeric(rng[2L]), PACKAGE="DescTools")
res[is.na(x)] <- NA
} else if(is.ordered(x)) {
res <- .Call("between_num_r", as.numeric(x),
as.numeric(match(rng[1L], levels(x))),
as.numeric(match(rng[2L], levels(x))), PACKAGE="DescTools")
res[is.na(x)] <- NA
} else if(inherits(x=x, what="character")) {
res <- ifelse ( x > rng[1L] & x <= rng[2L], TRUE, FALSE )
} else {
res <- rep(NA, length(x))
}
return(res)
}
`%[)%` <- function(x, rng) {
if(is.matrix(rng)){
# recycle things
# which parameter has the highest dimension
maxdim <- max(length(x), nrow(rng))
# recycle all params to maxdim
x <- rep(x, length.out = maxdim)
# the rows of the matrix rng
rng <- rng[rep(1L:nrow(rng), length.out = maxdim),]
res <- .Call("between_num_lm", as.numeric(x),
as.numeric(rng[,1L]), as.numeric(rng[,2L]), PACKAGE="DescTools")
res[is.na(x)] <- NA
return( res)
}
if(is.numeric(x) || IsDate(x)) {
# as.numeric still needed for casting integer to numeric!!
res <- .Call("between_num_l", as.numeric(x),
as.numeric(rng[1L]), as.numeric(rng[2L]), PACKAGE="DescTools")
res[is.na(x)] <- NA
} else if(is.ordered(x)) {
res <- .Call("between_num_l", as.numeric(x),
as.numeric(match(rng[1L], levels(x))),
as.numeric(match(rng[2L], levels(x))), PACKAGE="DescTools")
res[is.na(x)] <- NA
} else if(inherits(x=x, what="character")) {
res <- ifelse ( x >= rng[1L] & x < rng[2L], TRUE, FALSE )
} else {
res <- rep(NA, length(x))
}
return(res)
}
`%()%` <- function(x, rng) {
if(is.matrix(rng)){
# recycle things
# which parameter has the highest dimension
maxdim <- max(length(x), nrow(rng))
# recycle all params to maxdim
x <- rep(x, length.out = maxdim)
# the rows of the matrix rng
rng <- rng[rep(1L:nrow(rng), length.out = maxdim),]
res <- .Call("between_num_m", as.numeric(x),
as.numeric(rng[,1L]), as.numeric(rng[,2L]), PACKAGE="DescTools")
res[is.na(x)] <- NA
return( res)
}
if(is.numeric(x) || IsDate(x)) {
# as.numeric still needed for casting integer to numeric!!
res <- .Call("between_num_", as.numeric(x),
as.numeric(rng[1L]), as.numeric(rng[2L]), PACKAGE="DescTools")
res[is.na(x)] <- NA
} else if(is.ordered(x)) {
res <- .Call("between_num_", as.numeric(x),
as.numeric(match(rng[1L], levels(x))),
as.numeric(match(rng[2L], levels(x))), PACKAGE="DescTools")
res[is.na(x)] <- NA
} else if(inherits(x=x, what="character")) {
res <- ifelse ( x > rng[1L] & x < rng[2L], TRUE, FALSE )
} else {
res <- rep(NA, length(x))
}
return(res)
}
# outside operators