library(devtools)
library(RJSONIO)
library(knitr)
library(httpuv)
library(shiny)
library(googleVis)
library(graphics)
library(ggplot2)

this_base <- "fig03-02_area-and-volume-judgments"

my_data <- data.frame(
  val1 = c(0.75, 2, 3, 4, 5, 5, 6, 7, 8),
  val2 = c(4, 6, 6, 8, 6, 5, 1, 0.5, 9),
  area = c(5, 8, 0.25, 4, 9, 0.5, 6, 1, 12))

p <- ggplot(my_data, aes(x = val1, y = val2, size = area)) +
  geom_point(shape = 21, show_guide = FALSE) +
  # map z to area and make larger circles
  scale_size_area(max_size = 25) +
  scale_x_continuous(breaks = seq(2, 8, 2), limit = c(0, 9),
                     expand = c(0, 0)) +
  scale_y_continuous(breaks = seq(0, 10, 2), limit = c(0, 10),
                     expand = c(0, 0)) +
  ggtitle("Fig 3.2 Area and Volume Judgments") +
  theme_bw() +
  theme(panel.grid.major = element_blank(),
        plot.title = element_text(size = rel(1.5), face = "bold", vjust = 1.5),
        axis.title = element_blank())

load(url("http://andrewshinsuke.me/cs125/avgGOP.RData"))
load(url("http://andrewshinsuke.me/cs125/avgDEM.RData"))
load(url("http://andrewshinsuke.me/cs125/pres_trendDF.melt.RData"))
head(goppolls)

gopgtrends <- pres_trendDF.melt[pres_trendDF.melt$candidate=='Trump' | pres_trendDF.melt$candidate=='Carson' | pres_trendDF.melt$candidate=='Rand',]
goppolls <- averagedGOPPoll.melt[averagedGOPPoll.melt$candidate=='Trump' | averagedGOPPoll.melt$candidate=='Carson' | averagedGOPPoll.melt$candidate=='Rand.Paul',]
gopbubbleDF <- data.frame(Date=gopgtrends$date, Candidate=gopgtrends$candidate, Searched=gopgtrends$searched, Percentage=goppolls$percentage)
#adding a polling percentage column

gopbubbleDF$Percentage[1] <- 0
#Fixing the Percentage data so that there are no more NA's

for(i in seq_along(gopbubbleDF$Percentage[1:length(gopbubbleDF$Percentage)])){
    if(i > 1){
        if(is.nan(gopbubbleDF$Percentage[i])){
            if(!is.nan(gopbubbleDF$Percentage[i-1])){
                    z <- gopbubbleDF$Percentage[i-1]
            }else{
                for(n in gopbubbleDF$Percentage[i:length(gopbubbleDF$Percentage)]){
                    if(!is.na(n)) {
                        z <- n
                        break
                    }
                }
            }
            gopbubbleDF$Percentage[i] <- z
        }
    }
}

changeInPercentage <- c(0)
for(i in seq_along(gopbubbleDF$Percentage[1:length(gopbubbleDF$Percentage)])){
    if(i > 1){
        z <- gopbubbleDF$Percentage[i] - gopbubbleDF$Percentage[i-1]
        changeInPercentage <- append(changeInPercentage, z)}
}

gopbubbleDF <- cbind(gopbubbleDF, Change.In.Polling.Percentage=changeInPercentage)

ggplot(day1, aes(x = Percentage, y = Change.In.Polling.Percentage, size = Searched)) +
  geom_point(shape = 21, show_guide = FALSE) +
  # map z to area and make larger circles
  scale_size_area(max_size = 25) +
  scale_x_continuous(breaks = c(20, 40, 60, 80), limit = c(-10, 100),
                     expand = c(0, 0)) +
  scale_y_continuous(breaks = c(-40, -20, 0, 20, 40), limit = c(-60, 60),
                     expand = c(0, 0)) +
  ggtitle("Fig 3.2 Area and Volume Judgments") +
  theme_bw() +
  theme(panel.grid.major = element_blank(),
        plot.title = element_text(size = rel(1.5), face = "bold", vjust = 1.5),
        axis.title = element_blank())

day1 <- gopbubbleDF[c(1, 366, 731),]
day2 <- gopbubbleDF[c(2, 367, 732),]
day3 <- gopbubbleDF[c(3, 368, 733),]
day4 <- gopbubbleDF[c(4, 369, 734),]
day5 <- gopbubbleDF[c(5, 370, 735),]
day6 <- gopbubbleDF[c(6, 371, 736),]
day7 <- gopbubbleDF[c(7, 372, 737),]
day8 <- gopbubbleDF[c(8, 373, 738),]
day9 <- gopbubbleDF[c(9, 374, 739),]
day10 <- gopbubbleDF[c(10, 375, 740),]
day11 <- gopbubbleDF[c(11, 376, 741),]
day12 <- gopbubbleDF[c(12, 377, 742),]
day13 <- gopbubbleDF[c(13, 378, 743),]
day14 <- gopbubbleDF[c(14, 379, 744),]
day15 <- gopbubbleDF[c(15, 380, 745),]
day16 <- gopbubbleDF[c(16, 381, 746),]
day17 <- gopbubbleDF[c(17, 382, 747),]
day18 <- gopbubbleDF[c(18, 383, 748),]
day19 <- gopbubbleDF[c(19, 384, 749),]
day20 <- gopbubbleDF[c(20, 385, 750),]
day21 <- gopbubbleDF[c(21, 386, 751),]
day22 <- gopbubbleDF[c(22, 387, 752),]
day23 <- gopbubbleDF[c(23, 388, 753),]
day24 <- gopbubbleDF[c(24, 389, 754),]
day25 <- gopbubbleDF[c(25, 390, 755),]
day26 <- gopbubbleDF[c(26, 391, 756),]
day27 <- gopbubbleDF[c(27, 392, 757),]
day28 <- gopbubbleDF[c(28, 393, 758),]
day29 <- gopbubbleDF[c(29, 394, 759),]
day30 <- gopbubbleDF[c(30, 395, 760),]
day31 <- gopbubbleDF[c(31, 396, 761),]
day32 <- gopbubbleDF[c(32, 397, 762),]
day33 <- gopbubbleDF[c(33, 398, 763),]
day34 <- gopbubbleDF[c(34, 399, 764),]
day35 <- gopbubbleDF[c(35, 400, 765),]
day36 <- gopbubbleDF[c(36, 401, 766),]
day37 <- gopbubbleDF[c(37, 402, 767),]
day38 <- gopbubbleDF[c(38, 403, 768),]
day39 <- gopbubbleDF[c(39, 404, 769),]
day40 <- gopbubbleDF[c(40, 405, 770),]
day41 <- gopbubbleDF[c(41, 406, 771),]
day42 <- gopbubbleDF[c(42, 407, 772),]
day43 <- gopbubbleDF[c(43, 408, 773),]
day44 <- gopbubbleDF[c(44, 409, 774),]
day45 <- gopbubbleDF[c(45, 410, 775),]
day46 <- gopbubbleDF[c(46, 411, 776),]
day47 <- gopbubbleDF[c(47, 412, 777),]
day48 <- gopbubbleDF[c(48, 413, 778),]
day49 <- gopbubbleDF[c(49, 414, 779),]
day50 <- gopbubbleDF[c(50, 415, 780),]
day51 <- gopbubbleDF[c(51, 416, 781),]
day52 <- gopbubbleDF[c(52, 417, 782),]
day53 <- gopbubbleDF[c(53, 418, 783),]
day54 <- gopbubbleDF[c(54, 419, 784),]
day55 <- gopbubbleDF[c(55, 420, 785),]
day56 <- gopbubbleDF[c(56, 421, 786),]
day57 <- gopbubbleDF[c(57, 422, 787),]
day58 <- gopbubbleDF[c(58, 423, 788),]
day59 <- gopbubbleDF[c(59, 424, 789),]
day60 <- gopbubbleDF[c(60, 425, 790),]
day61 <- gopbubbleDF[c(61, 426, 791),]
day62 <- gopbubbleDF[c(62, 427, 792),]
day63 <- gopbubbleDF[c(63, 428, 793),]
day64 <- gopbubbleDF[c(64, 429, 794),]
day65 <- gopbubbleDF[c(65, 430, 795),]
day66 <- gopbubbleDF[c(66, 431, 796),]
day67 <- gopbubbleDF[c(67, 432, 797),]
day68 <- gopbubbleDF[c(68, 433, 798),]
day69 <- gopbubbleDF[c(69, 434, 799),]
day70 <- gopbubbleDF[c(70, 435, 800),]
day71 <- gopbubbleDF[c(71, 436, 801),]
day72 <- gopbubbleDF[c(72, 437, 802),]
day73 <- gopbubbleDF[c(73, 438, 803),]
day74 <- gopbubbleDF[c(74, 439, 804),]
day75 <- gopbubbleDF[c(75, 440, 805),]
day76 <- gopbubbleDF[c(76, 441, 806),]
day77 <- gopbubbleDF[c(77, 442, 807),]
day78 <- gopbubbleDF[c(78, 443, 808),]
day79 <- gopbubbleDF[c(79, 444, 809),]
day80 <- gopbubbleDF[c(80, 445, 810),]
day81 <- gopbubbleDF[c(81, 446, 811),]
day82 <- gopbubbleDF[c(82, 447, 812),]
day83 <- gopbubbleDF[c(83, 448, 813),]
day84 <- gopbubbleDF[c(84, 449, 814),]
day85 <- gopbubbleDF[c(85, 450, 815),]
day86 <- gopbubbleDF[c(86, 451, 816),]
day87 <- gopbubbleDF[c(87, 452, 817),]
day88 <- gopbubbleDF[c(88, 453, 818),]
day89 <- gopbubbleDF[c(89, 454, 819),]
day90 <- gopbubbleDF[c(90, 455, 820),]
day91 <- gopbubbleDF[c(91, 456, 821),]
day92 <- gopbubbleDF[c(92, 457, 822),]
day93 <- gopbubbleDF[c(93, 458, 823),]
day94 <- gopbubbleDF[c(94, 459, 824),]
day95 <- gopbubbleDF[c(95, 460, 825),]
day96 <- gopbubbleDF[c(96, 461, 826),]
day97 <- gopbubbleDF[c(97, 462, 827),]
day98 <- gopbubbleDF[c(98, 463, 828),]
day99 <- gopbubbleDF[c(99, 464, 829),]
day100 <- gopbubbleDF[c(100, 465, 830),]
day101 <- gopbubbleDF[c(101, 466, 831),]
day102 <- gopbubbleDF[c(102, 467, 832),]
day103 <- gopbubbleDF[c(103, 468, 833),]
day104 <- gopbubbleDF[c(104, 469, 834),]
day105 <- gopbubbleDF[c(105, 470, 835),]
day106 <- gopbubbleDF[c(106, 471, 836),]
day107 <- gopbubbleDF[c(107, 472, 837),]
day108 <- gopbubbleDF[c(108, 473, 838),]
day109 <- gopbubbleDF[c(109, 474, 839),]
day110 <- gopbubbleDF[c(110, 475, 840),]
day111 <- gopbubbleDF[c(111, 476, 841),]
day112 <- gopbubbleDF[c(112, 477, 842),]
day113 <- gopbubbleDF[c(113, 478, 843),]
day114 <- gopbubbleDF[c(114, 479, 844),]
day115 <- gopbubbleDF[c(115, 480, 845),]
day116 <- gopbubbleDF[c(116, 481, 846),]
day117 <- gopbubbleDF[c(117, 482, 847),]
day118 <- gopbubbleDF[c(118, 483, 848),]
day119 <- gopbubbleDF[c(119, 484, 849),]
day120 <- gopbubbleDF[c(120, 485, 850),]
day121 <- gopbubbleDF[c(121, 486, 851),]
day122 <- gopbubbleDF[c(122, 487, 852),]
day123 <- gopbubbleDF[c(123, 488, 853),]
day124 <- gopbubbleDF[c(124, 489, 854),]
day125 <- gopbubbleDF[c(125, 490, 855),]
day126 <- gopbubbleDF[c(126, 491, 856),]
day127 <- gopbubbleDF[c(127, 492, 857),]
day128 <- gopbubbleDF[c(128, 493, 858),]
day129 <- gopbubbleDF[c(129, 494, 859),]
day130 <- gopbubbleDF[c(130, 495, 860),]
day131 <- gopbubbleDF[c(131, 496, 861),]
day132 <- gopbubbleDF[c(132, 497, 862),]
day133 <- gopbubbleDF[c(133, 498, 863),]
day134 <- gopbubbleDF[c(134, 499, 864),]
day135 <- gopbubbleDF[c(135, 500, 865),]
day136 <- gopbubbleDF[c(136, 501, 866),]
day137 <- gopbubbleDF[c(137, 502, 867),]
day138 <- gopbubbleDF[c(138, 503, 868),]
day139 <- gopbubbleDF[c(139, 504, 869),]
day140 <- gopbubbleDF[c(140, 505, 870),]
day141 <- gopbubbleDF[c(141, 506, 871),]
day142 <- gopbubbleDF[c(142, 507, 872),]
day143 <- gopbubbleDF[c(143, 508, 873),]
day144 <- gopbubbleDF[c(144, 509, 874),]
day145 <- gopbubbleDF[c(145, 510, 875),]
day146 <- gopbubbleDF[c(146, 511, 876),]
day147 <- gopbubbleDF[c(147, 512, 877),]
day148 <- gopbubbleDF[c(148, 513, 878),]
day149 <- gopbubbleDF[c(149, 514, 879),]
day150 <- gopbubbleDF[c(150, 515, 880),]
day151 <- gopbubbleDF[c(151, 516, 881),]
day152 <- gopbubbleDF[c(152, 517, 882),]
day153 <- gopbubbleDF[c(153, 518, 883),]
day154 <- gopbubbleDF[c(154, 519, 884),]
day155 <- gopbubbleDF[c(155, 520, 885),]
day156 <- gopbubbleDF[c(156, 521, 886),]
day157 <- gopbubbleDF[c(157, 522, 887),]
day158 <- gopbubbleDF[c(158, 523, 888),]
day159 <- gopbubbleDF[c(159, 524, 889),]
day160 <- gopbubbleDF[c(160, 525, 890),]
day161 <- gopbubbleDF[c(161, 526, 891),]
day162 <- gopbubbleDF[c(162, 527, 892),]
day163 <- gopbubbleDF[c(163, 528, 893),]
day164 <- gopbubbleDF[c(164, 529, 894),]
day165 <- gopbubbleDF[c(165, 530, 895),]
day166 <- gopbubbleDF[c(166, 531, 896),]
day167 <- gopbubbleDF[c(167, 532, 897),]
day168 <- gopbubbleDF[c(168, 533, 898),]
day169 <- gopbubbleDF[c(169, 534, 899),]
day170 <- gopbubbleDF[c(170, 535, 900),]
day171 <- gopbubbleDF[c(171, 536, 901),]
day172 <- gopbubbleDF[c(172, 537, 902),]
day173 <- gopbubbleDF[c(173, 538, 903),]
day174 <- gopbubbleDF[c(174, 539, 904),]
day175 <- gopbubbleDF[c(175, 540, 905),]
day176 <- gopbubbleDF[c(176, 541, 906),]
day177 <- gopbubbleDF[c(177, 542, 907),]
day178 <- gopbubbleDF[c(178, 543, 908),]
day179 <- gopbubbleDF[c(179, 544, 909),]
day180 <- gopbubbleDF[c(180, 545, 910),]
day181 <- gopbubbleDF[c(181, 546, 911),]
day182 <- gopbubbleDF[c(182, 547, 912),]
day183 <- gopbubbleDF[c(183, 548, 913),]
day184 <- gopbubbleDF[c(184, 549, 914),]
day185 <- gopbubbleDF[c(185, 550, 915),]
day186 <- gopbubbleDF[c(186, 551, 916),]
day187 <- gopbubbleDF[c(187, 552, 917),]
day188 <- gopbubbleDF[c(188, 553, 918),]
day189 <- gopbubbleDF[c(189, 554, 919),]
day190 <- gopbubbleDF[c(190, 555, 920),]
day191 <- gopbubbleDF[c(191, 556, 921),]
day192 <- gopbubbleDF[c(192, 557, 922),]
day193 <- gopbubbleDF[c(193, 558, 923),]
day194 <- gopbubbleDF[c(194, 559, 924),]
day195 <- gopbubbleDF[c(195, 560, 925),]
day196 <- gopbubbleDF[c(196, 561, 926),]
day197 <- gopbubbleDF[c(197, 562, 927),]
day198 <- gopbubbleDF[c(198, 563, 928),]
day199 <- gopbubbleDF[c(199, 564, 929),]
day200 <- gopbubbleDF[c(200, 565, 930),]
day201 <- gopbubbleDF[c(201, 566, 931),]
day202 <- gopbubbleDF[c(202, 567, 932),]
day203 <- gopbubbleDF[c(203, 568, 933),]
day204 <- gopbubbleDF[c(204, 569, 934),]
day205 <- gopbubbleDF[c(205, 570, 935),]
day206 <- gopbubbleDF[c(206, 571, 936),]
day207 <- gopbubbleDF[c(207, 572, 937),]
day208 <- gopbubbleDF[c(208, 573, 938),]
day209 <- gopbubbleDF[c(209, 574, 939),]
day210 <- gopbubbleDF[c(210, 575, 940),]
day211 <- gopbubbleDF[c(211, 576, 941),]
day212 <- gopbubbleDF[c(212, 577, 942),]
day213 <- gopbubbleDF[c(213, 578, 943),]
day214 <- gopbubbleDF[c(214, 579, 944),]
day215 <- gopbubbleDF[c(215, 580, 945),]
day216 <- gopbubbleDF[c(216, 581, 946),]
day217 <- gopbubbleDF[c(217, 582, 947),]
day218 <- gopbubbleDF[c(218, 583, 948),]
day219 <- gopbubbleDF[c(219, 584, 949),]
day220 <- gopbubbleDF[c(220, 585, 950),]
day221 <- gopbubbleDF[c(221, 586, 951),]
day222 <- gopbubbleDF[c(222, 587, 952),]
day223 <- gopbubbleDF[c(223, 588, 953),]
day224 <- gopbubbleDF[c(224, 589, 954),]
day225 <- gopbubbleDF[c(225, 590, 955),]
day226 <- gopbubbleDF[c(226, 591, 956),]
day227 <- gopbubbleDF[c(227, 592, 957),]
day228 <- gopbubbleDF[c(228, 593, 958),]
day229 <- gopbubbleDF[c(229, 594, 959),]
day230 <- gopbubbleDF[c(230, 595, 960),]
day231 <- gopbubbleDF[c(231, 596, 961),]
day232 <- gopbubbleDF[c(232, 597, 962),]
day233 <- gopbubbleDF[c(233, 598, 963),]
day234 <- gopbubbleDF[c(234, 599, 964),]
day235 <- gopbubbleDF[c(235, 600, 965),]
day236 <- gopbubbleDF[c(236, 601, 966),]
day237 <- gopbubbleDF[c(237, 602, 967),]
day238 <- gopbubbleDF[c(238, 603, 968),]
day239 <- gopbubbleDF[c(239, 604, 969),]
day240 <- gopbubbleDF[c(240, 605, 970),]
day241 <- gopbubbleDF[c(241, 606, 971),]
day242 <- gopbubbleDF[c(242, 607, 972),]
day243 <- gopbubbleDF[c(243, 608, 973),]
day244 <- gopbubbleDF[c(244, 609, 974),]
day245 <- gopbubbleDF[c(245, 610, 975),]
day246 <- gopbubbleDF[c(246, 611, 976),]
day247 <- gopbubbleDF[c(247, 612, 977),]
day248 <- gopbubbleDF[c(248, 613, 978),]
day249 <- gopbubbleDF[c(249, 614, 979),]
day250 <- gopbubbleDF[c(250, 615, 980),]
day251 <- gopbubbleDF[c(251, 616, 981),]
day252 <- gopbubbleDF[c(252, 617, 982),]
day253 <- gopbubbleDF[c(253, 618, 983),]
day254 <- gopbubbleDF[c(254, 619, 984),]
day255 <- gopbubbleDF[c(255, 620, 985),]
day256 <- gopbubbleDF[c(256, 621, 986),]
day257 <- gopbubbleDF[c(257, 622, 987),]
day258 <- gopbubbleDF[c(258, 623, 988),]
day259 <- gopbubbleDF[c(259, 624, 989),]
day260 <- gopbubbleDF[c(260, 625, 990),]
day261 <- gopbubbleDF[c(261, 626, 991),]
day262 <- gopbubbleDF[c(262, 627, 992),]
day263 <- gopbubbleDF[c(263, 628, 993),]
day264 <- gopbubbleDF[c(264, 629, 994),]
day265 <- gopbubbleDF[c(265, 630, 995),]
day266 <- gopbubbleDF[c(266, 631, 996),]
day267 <- gopbubbleDF[c(267, 632, 997),]
day268 <- gopbubbleDF[c(268, 633, 998),]
day269 <- gopbubbleDF[c(269, 634, 999),]
day270 <- gopbubbleDF[c(270, 635, 1000),]
day271 <- gopbubbleDF[c(271, 636, 1001),]
day272 <- gopbubbleDF[c(272, 637, 1002),]
day273 <- gopbubbleDF[c(273, 638, 1003),]
day274 <- gopbubbleDF[c(274, 639, 1004),]
day275 <- gopbubbleDF[c(275, 640, 1005),]
day276 <- gopbubbleDF[c(276, 641, 1006),]
day277 <- gopbubbleDF[c(277, 642, 1007),]
day278 <- gopbubbleDF[c(278, 643, 1008),]
day279 <- gopbubbleDF[c(279, 644, 1009),]
day280 <- gopbubbleDF[c(280, 645, 1010),]
day281 <- gopbubbleDF[c(281, 646, 1011),]
day282 <- gopbubbleDF[c(282, 647, 1012),]
day283 <- gopbubbleDF[c(283, 648, 1013),]
day284 <- gopbubbleDF[c(284, 649, 1014),]
day285 <- gopbubbleDF[c(285, 650, 1015),]
day286 <- gopbubbleDF[c(286, 651, 1016),]
day287 <- gopbubbleDF[c(287, 652, 1017),]
day288 <- gopbubbleDF[c(288, 653, 1018),]
day289 <- gopbubbleDF[c(289, 654, 1019),]
day290 <- gopbubbleDF[c(290, 655, 1020),]
day291 <- gopbubbleDF[c(291, 656, 1021),]
day292 <- gopbubbleDF[c(292, 657, 1022),]
day293 <- gopbubbleDF[c(293, 658, 1023),]
day294 <- gopbubbleDF[c(294, 659, 1024),]
day295 <- gopbubbleDF[c(295, 660, 1025),]
day296 <- gopbubbleDF[c(296, 661, 1026),]
day297 <- gopbubbleDF[c(297, 662, 1027),]
day298 <- gopbubbleDF[c(298, 663, 1028),]
day299 <- gopbubbleDF[c(299, 664, 1029),]
day300 <- gopbubbleDF[c(300, 665, 1030),]
day301 <- gopbubbleDF[c(301, 666, 1031),]
day302 <- gopbubbleDF[c(302, 667, 1032),]
day303 <- gopbubbleDF[c(303, 668, 1033),]
day304 <- gopbubbleDF[c(304, 669, 1034),]
day305 <- gopbubbleDF[c(305, 670, 1035),]
day306 <- gopbubbleDF[c(306, 671, 1036),]
day307 <- gopbubbleDF[c(307, 672, 1037),]
day308 <- gopbubbleDF[c(308, 673, 1038),]
day309 <- gopbubbleDF[c(309, 674, 1039),]
day310 <- gopbubbleDF[c(310, 675, 1040),]
day311 <- gopbubbleDF[c(311, 676, 1041),]
day312 <- gopbubbleDF[c(312, 677, 1042),]
day313 <- gopbubbleDF[c(313, 678, 1043),]
day314 <- gopbubbleDF[c(314, 679, 1044),]
day315 <- gopbubbleDF[c(315, 680, 1045),]
day316 <- gopbubbleDF[c(316, 681, 1046),]
day317 <- gopbubbleDF[c(317, 682, 1047),]
day318 <- gopbubbleDF[c(318, 683, 1048),]
day319 <- gopbubbleDF[c(319, 684, 1049),]
day320 <- gopbubbleDF[c(320, 685, 1050),]
day321 <- gopbubbleDF[c(321, 686, 1051),]
day322 <- gopbubbleDF[c(322, 687, 1052),]
day323 <- gopbubbleDF[c(323, 688, 1053),]
day324 <- gopbubbleDF[c(324, 689, 1054),]
day325 <- gopbubbleDF[c(325, 690, 1055),]
day326 <- gopbubbleDF[c(326, 691, 1056),]
day327 <- gopbubbleDF[c(327, 692, 1057),]
day328 <- gopbubbleDF[c(328, 693, 1058),]
day329 <- gopbubbleDF[c(329, 694, 1059),]
day330 <- gopbubbleDF[c(330, 695, 1060),]
day331 <- gopbubbleDF[c(331, 696, 1061),]
day332 <- gopbubbleDF[c(332, 697, 1062),]
day333 <- gopbubbleDF[c(333, 698, 1063),]
day334 <- gopbubbleDF[c(334, 699, 1064),]
day335 <- gopbubbleDF[c(335, 700, 1065),]
day336 <- gopbubbleDF[c(336, 701, 1066),]
day337 <- gopbubbleDF[c(337, 702, 1067),]
day338 <- gopbubbleDF[c(338, 703, 1068),]
day339 <- gopbubbleDF[c(339, 704, 1069),]
day340 <- gopbubbleDF[c(340, 705, 1070),]
day341 <- gopbubbleDF[c(341, 706, 1071),]
day342 <- gopbubbleDF[c(342, 707, 1072),]
day343 <- gopbubbleDF[c(343, 708, 1073),]
day344 <- gopbubbleDF[c(344, 709, 1074),]
day345 <- gopbubbleDF[c(345, 710, 1075),]
day346 <- gopbubbleDF[c(346, 711, 1076),]
day347 <- gopbubbleDF[c(347, 712, 1077),]
day348 <- gopbubbleDF[c(348, 713, 1078),]
day349 <- gopbubbleDF[c(349, 714, 1079),]
day350 <- gopbubbleDF[c(350, 715, 1080),]
day351 <- gopbubbleDF[c(351, 716, 1081),]
day352 <- gopbubbleDF[c(352, 717, 1082),]
day353 <- gopbubbleDF[c(353, 718, 1083),]
day354 <- gopbubbleDF[c(354, 719, 1084),]
day355 <- gopbubbleDF[c(355, 720, 1085),]
day356 <- gopbubbleDF[c(356, 721, 1086),]
day357 <- gopbubbleDF[c(357, 722, 1087),]
day358 <- gopbubbleDF[c(358, 723, 1088),]
day359 <- gopbubbleDF[c(359, 724, 1089),]
day360 <- gopbubbleDF[c(360, 725, 1090),]
day361 <- gopbubbleDF[c(361, 726, 1091),]
day362 <- gopbubbleDF[c(362, 727, 1092),]
day363 <- gopbubbleDF[c(363, 728, 1093),]
day364 <- gopbubbleDF[c(364, 729, 1094),]
day365 <- gopbubbleDF[c(365, 730, 1095),]


library(rpart)
library(rpart.plot)
library(caret)

mydata <- read.csv("Data_Breast_Cancer.CSV")
head(mydata)

set.seed(1000)
train.idx <- createDataPartition(mydata$Class,p=0.7,list=FALSE)

mod <- rpart(Class~.,data=mydata[train.idx,], method="class", control=rpart.control(minsplit=20,cp=0.01))
mod

prp(mod, type=2, extra=104, nn=TRUE, fallen.leaves=TRUE, faclen=4, varlen=3, shadow.col="gray")
mod$cptable

mod.pruned=prune(mod, mod$captable[5, "CP"])

pred.pruned <- predict (mod, mydata[-train, idx, ], type = "class")
table(mydata[-train.idx,]$Class, pred.pruned, dnn=c("Actualn", "Predicted"))


##
## Fit Bayesian hierarchical models using rstanarm
##
## models including varying intercepts for study site (Pop) and egos nested in sites (Pop:Ego)
## - some models also include varying slopes for sites (but not egos - we're only interested in between-site variation, not between-person)
##
library(rstanarm)
options(mc.cores = parallel::detectCores())

source("init if necessary.r")

##
## intercept-only - nested
## 24246.9 seconds (Total)
##
mlm.null.nested = stan_glmer(GiftGiven ~ 1 + (1 | Pop/Ego.ID),
                             data=d.long, family=binomial,
                             prior_intercept=normal(0, 5),
                             chains=1, cores=1)
save(mlm.null.nested, file=file.path(models.dir, "mlm - varying intercepts only.RData"))

##
## relatedness only - varying slopes
## 86973.1 seconds (Total)
##
mlm.r.re = stan_glmer(GiftGiven ~ r + (r | Pop) + (1 | Pop:Ego.ID),
                      data=d.long, family=binomial,
                      prior_intercept=normal(0, 5), prior=normal(0,2), prior_covariance=decov(regularization=2),
                      chains=1, cores=1)
save(mlm.r.re, file=file.path(models.dir, "mlm - r - varying intercepts and slopes.RData"))

##
## herding group only - varying slopes
## 47142.8 seconds (Total)
##
mlm.siida.re = stan_glmer(GiftGiven ~ SameHerdingGroup + (SameHerdingGroup | Pop) + (1 | Pop:Ego.ID),
                          data=d.long, family=binomial,
                          prior_intercept=normal(0, 5), prior=normal(0,2), prior_covariance=decov(regularization=2),
                          chains=1, cores=1)
save(mlm.siida.re, file=file.path(models.dir, "mlm - siida - varying intercepts and slopes.RData"))

##
## r + herding group - varying intercepts
## 30491.6 seconds (Total)
##
mlm.r_siida.fe = stan_glmer(GiftGiven ~ r + SameHerdingGroup + (1 | Pop/Ego.ID),
                            data=d.long, family=binomial,
                            prior_intercept=normal(0, 5), prior=normal(0,2), prior_covariance=decov(regularization=2),
                            QR=T, chains=1, cores=1)
save(mlm.r_siida.fe, file=file.path(models.dir, "mlm - r plus siida - varying intercepts.RData"))

##
## r + herding group - varying intercepts and slopes
## 112458 seconds (Total)
##
mlm.r_siida.re = stan_glmer(GiftGiven ~ r + SameHerdingGroup + (r + SameHerdingGroup | Pop) + (1 | Pop:Ego.ID),
                            data=d.long, family=binomial,
                            prior_intercept=normal(0, 5), prior=normal(0,2), prior_covariance=decov(regularization=2),
                            QR=T, chains=1, cores=1)
save(mlm.r_siida.re, file=file.path(models.dir, "mlm - r plus siida - varying intercepts and slopes.RData"))

##
## r x herding group - varying intercepts by egos in populations
## 42053.4 seconds (Total)
##
mlm.full.fe = stan_glmer(GiftGiven ~ r * SameHerdingGroup + (1 | Pop/Ego.ID),
                         data=d.long, family=binomial,
                         prior_intercept=normal(0, 5), prior=normal(0,2), prior_covariance=decov(regularization=2),
                         QR=T, chains=1, cores=1)
save(mlm.full.fe, file=file.path(models.dir, "mlm - r x siida - varying intercepts.RData"))

##
## r x herding group - varying intercepts and slopes by egos in populations
## 264341 seconds (Total)
##
mlm.full = stan_glmer(GiftGiven ~ r * SameHerdingGroup + (r * SameHerdingGroup | Pop) + (1 | Pop:Ego.ID),
                      data=d.long, family=binomial,
                      prior_intercept=normal(0, 5), prior=normal(0,2), prior_covariance=decov(regularization=2),
                      QR=T, chains=1, cores=1)
save(mlm.full, file=file.path(models.dir, "mlm - r x siida - varying intercepts and slopes.RData"))

# save everything
save(d.long, mlm.null.nested, mlm.r.re, mlm.siida.re, mlm.r_siida.fe, mlm.r_siida.re, mlm.full.fe, mlm.full,
     file=gift_models_file)


print(factorial(50)) # 3.041409e+64


library(base)
library(caret)
library(cluster)
library(dummies)
library(e1071)
library(factoextra)
library(modules)
library(RSNNS)
library(rstudioapi)
library(stats)
library(tidyverse)
library(utils)

base::setwd(base::dirname(rstudioapi::getActiveDocumentContext()$path))
start <- base::Sys.time()

base::set.seed(0xACDC)

data <- modules::use('data')$get_data$get_data()

target_column <- 47

data_dm <-
  dummies::dummy.data.frame(data = data[, 2:46], sep = '_')

data_norm <-
  base::as.data.frame(RSNNS::normalizeData(data_dm, type = '0_1'))

base::names(data_norm) <- base::names(data)[2:46]

data_norm <- base::t(data_norm)

distance <- stats::dist(data_norm, method = 'euclidean')

base::plot(factoextra::fviz_dist(
  distance,
  gradient = base::list(low = '#00AFBB',
                        mid = 'white', high = '#FC4E07')
))

methods <- base::c('average', 'single', 'complete', 'ward')
base::names(methods) <- methods

hc_methods <-
  purrr::map_dbl(methods, function(x) {
    cluster::agnes(data_norm, method = x)$ac
  })
base::print(hc_methods)

best_ac_method <- base::names(base::which.max(hc_methods))

hc_agl <- cluster::agnes(data_norm, method = best_ac_method)
cluster::pltree(
  hc_agl,
  cex = 0.6,
  hang = -1,
  main = base::paste('Dendrogram of agnes - ', best_ac_method)
)
stats::rect.hclust(hc_agl, k = 2, border = base::c('#00AFBB', '#FC4E07'))

data_norm <- base::t(data_norm)

methods <- base::c('average', 'single', 'complete', 'ward')
base::names(methods) <- methods

hc_methods <-
  purrr::map_dbl(methods, function(x) {
    cluster::agnes(data_norm, method = x)$ac
  })
base::print(hc_methods)

best_ac_method <- base::names(base::which.max(hc_methods))

hc_agl <- cluster::agnes(data_norm, method = best_ac_method)
hc_div <- cluster::diana(data_norm)

base::print(hc_div$dc)

eval_hc <- function(hc) {
  cut <- dendextend::cutree(stats::as.hclust(hc), k = 2)

  assoc <-
    base::as.data.frame(data_norm) %>% dplyr::mutate(cluster = cut)
  cm <-
    caret::confusionMatrix(base::as.factor(labels),
                           base::as.factor(assoc$cluster))
  base::print(cm$table)
  base::print(cm$overall['Accuracy'])

  base::plot(stats::as.hclust(hc), cex = 0.6)
  stats::rect.hclust(stats::as.hclust(hc), k = 3, border = 2:5)
}

labels <-
  base::ifelse(data[, target_column] == 'legitimate', 1, 2)
eval_hc(hc_agl)

labels <-
  base::ifelse(data[, target_column] == 'legitimate', 2, 1)
eval_hc(hc_div)

base::print(base::Sys.time() - start)
base::rm(start)


source('~/project/main.r')
library('highcharter')

######## Zone Analysis
raw_tmp <- select(row_refine,車種意義,死,受傷)
raw_tmp <- raw_tmp %>% drop_na(車種意義)
raw_tmp$count <- 1
raw_tmp[is.na(raw_tmp)] <- 0
raw_tmp_summary <- (raw_tmp %>% group_by(車種意義) %>%
  summarise_all(sum)
)

raw_tmp_summary$死比率 <- raw_tmp_summary$死 / sum(raw_tmp_summary$死) * 100
raw_tmp_summary$受傷比率 <- raw_tmp_summary$受傷 / sum(raw_tmp_summary$受傷) * 100
raw_tmp_summary$意外比率 <- raw_tmp_summary$count / sum(raw_tmp_summary$count) * 100

# highchart() %>%
#   hc_chart(type ="column") %>%
#   hc_xAxis(categories = raw_tmp_summary$車種意義) %>%
#   hc_add_series(data = raw_tmp_summary$死比率, name = "死/總意外比率") %>%
#   hc_add_series(data = raw_tmp_summary$受傷比率, name = "受傷/總意外比率") %>%
#   hc_add_series(data = raw_tmp_summary$意外比率, name = "意外/總意外比率")

# rm(raw_tmp,raw_tmp_summary)
raw_tmp%>%
 count(車種意義)%>%
 arrange(n)%>%
 hchart(type = "treemap", hcaes(x = 車種意義, value = n, color = n))


source("read_data.R")
source("tools.r")
source("sql.r")

popDist <- popDistList$sjOSM
N <- 10000
dfn <- adeba
dat <- sampleFromPopDist(N, popDist, seed=N)
dat <- addRandomNoise(dat,3)
plot(dfn(dat), type ="l")

#
# sdat <- sample(dat, replace = T)
# sdat <- addRandomNoise (sdat, noise=0.1)
# dens <- adeba(sdat)
# score <- sum(-log(fitDistToX (dat, dens)$y)) / length(dat)
# print(score)
# plot(dens)


#' thom
#'
#' Calculate Thom discomfort index by using wet bulb temperature estimation.
#'
#' @param t numeric Air temperature in degC.
#' @param rh numeric Relative humidity in percentage.
#' @param wind numeric Wind speed iq.
#' @param pair numeric Air Pressure in hPa. Default is 1010.
#' @return thom index in degC
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @references Thom, E.C. 1959 The discomfort index. Weatherwise, 12, 57,60
#' @export
#'
#'
#'
#'
thom<-function(t,rh,wind=0.2,pair=1010) {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$assign("t", as.array(wind))
                         ct$assign("pair", as.array(pair))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=thom(t[i],rh[i],wind[0],pair[0])};")
                         res=ct$get("res")
                         return(ifelse(!is.numeric(res),NA,res))
}


# 4. faza: Analiza podatkov
# zemljevid za 3 grupe

tmp_data<-filter(Neudelezevanje_15,Neudelezevanje_15$QUANTILE=="Celotna populacija",Neudelezevanje_15$ACL00=="Športni dogodki")
tmp_data$ACL00= NULL
tmp_data$QUANTILE=NULL
k<-list()
for (i in 1:6){
  k[[i]]<-kmeans(tmp_data$Value,i)
}
betweenss_totss<-list()
for (i in 1:6){
  betweenss_totss[i]<-k[[i]]$betweenss/k[[i]]$totss
}

km3=kmeans(tmp_data$Value,3)
km2=kmeans(tmp_data$Value,2)

zemljevid_sport <- tm_shape(merge(svet, tmp_data, by.x = "NAME", by.y = "GEO"),bbox = bb(c(-11,33,36,68))) +
  tm_fill(col = "Value", contrast = 1, palette = "YlOrRd", title = "Neudelezevanje šport", breaks = c(15,56 ,71.8,97),colorNA = "Grey", textNA = "Manjkajoči podatki") +
  tm_layout(legend.outside = TRUE)
zemljevid_sport

Neudelezevanje_Sport <-filter(Neudelezevanje_15,Neudelezevanje_15$ACL00=="Športni dogodki")
NMn <-filter(Slika,ACL00=="Muzeji in galerije",QUANTILE =="Celotna populacija",REASON=="Ni zanimanja")
NMn <-merge.data.frame(NMn,GDP,by="GEO")
NMn<-NMn[order(NMn$BDP),]
###########################
NMF <-filter(Slika,ACL00=="Muzeji in galerije",QUANTILE =="Celotna populacija",REASON=="Finančni razlogi")
NMF <-merge.data.frame(NMF,GDP,by="GEO")
NMF <-NMF[order(NMF$BDP),]
#poskusil bi razvrstiti u grupe povseh kvintilih

km=kmeans(Neudelezevanje_Sport$Value,2)
k<-list()
for (i in 1:6){
  k[[i]]<-kmeans(Neudelezevanje_Sport$Value,i)
}
betweenss_totss<-list()
for (i in 1:6){
  betweenss_totss[i]<-k[[i]]$betweenss/k[[i]]$totss
}

#3 skupine so ptimalne
Neudelezevanje_Sport$cluster <- kmeans(Neudelezevanje_Sport$Value,3)$cluster
#dobimo meji 56 in 71.8 vstavim ju v shiny sliko

k<-list()
for (i in 1:6){
  k[[i]]<-kmeans(Neudelezevanje_15$Value,i)
}
betweenss_totss<-list()
for (i in 1:6){
  betweenss_totss[i]<-k[[i]]$betweenss/k[[i]]$totss
}
#imamo torej 2-3 skupine
Neudelezevanje_15$cluster_2  <- kmeans(Neudelezevanje_15$Value,2)$cluster
# prelomnica je 58
Neudelezevanje_15$cluster_2  <- NULL

Neudelezevanje_15$cluster_3  <- kmeans(Neudelezevanje_15$Value,3)$cluster
#prelomnici sta 46 in
Neudelezevanje_15$cluster_3 <-NULL

m1n<-lm(NMn$TVALUE ~ NMn$BDP)
m2n<-lm(TVALUE ~ poly(BDP,2),data=NMn)
#m1n razloži večino šuma , je pa pomembno in zanimivo opaziti da m2 predvidi povečanje zanimanja z dovolj niskim BDPjem
razmerje_ned<-ggplot(data=NMn,aes(x=BDP,y=TVALUE))+geom_point()+
  geom_line(aes(x=BDP,y=predict(m1n)),col="red")+ ylab("%") +
  ggtitle("Nezanimanje")
razmerje_ned

NMF$BDP2 <- NMF$BDP^2
NMF$BDP3 <- NMF$BDP2^3

m1<-lm(NMF$TVALUE ~ NMF$BDP)
m2<-lm(TVALUE ~ poly(BDP,2),data=NMF)
#m2 še vedno opčutno poveča kavaliteto modela torej bomo tu izrisali kvadratično
m3<-lm(NMF$TVALUE ~ NMF$BDP + NMF$BDP2 +NMF$BDP3)
razmerje_fin<-ggplot(data=NMF,aes(x=BDP,y=TVALUE))+geom_point()+
geom_line(aes(x=BDP,y=predict(m2)),col="red")+ ylab("%") +
  ggtitle("Finančna nedostopnost")
razmerje_fin


library(data.table)
source('../config.r')
source('../utils.r')
source('../read_data.r')

extra_path <- file.path('inputs')

fname <-
  'post_predictive_analysis_all_models_combined_imaging_non_imaging.csv'

DT_pred <- assemble_inputs(fname, path1 = extra_path)

#' Get point estimates + standard outputs for conditional target model
DT_cond_proxy <- DT_pred[,
  {
    train <- .SD[evaluation == "Validation"]
    test <- .SD[evaluation == "Generalization"]
    deconf <- fit_train_deconfound(
      train = train, test = test, var = "value", confound = "age")
    value_adjusted <- deconf[['pred']]
    # fit association model on test set
    age_delta <- with(test, age_pred - age)  # ... XXX

    mod <- lm(scale(value) ~           # y
              scale(value_adjusted) +  # confound_train XXX
              scale(age_delta) +       # brain age
              scale(FI_pred) +              # Fluid Intelligence
              scale(N_pred), test)     # Neuroticism

    coefs <- coef(summary(mod))
    out <- data.frame(
      coef = coefs[-c(1, 2), 1],  # kick out intercept + confound term
      se = coefs[-c(1, 2), 2],    # ... and get columns for coef and error
      p.val = coefs[-c(1, 2), 4],
      target = c("Brain Age Delta", "Fluid Intelligence", "Neuroticism"))
    out['nobs'] = nobs(mod)
    out['name'] = name[1]
    out
  },
  by = family]

#' get parametric bootstrap for conditional proxy model.
DT_cond_proxy_bs <- DT_pred[,
  {
    train <- .SD[evaluation == "Validation"]
    test <- .SD[evaluation == "Generalization"]
    deconf <- fit_train_deconfound(
      train = train, test = test, var = "value", confound = "age")
    value_adjusted <- deconf[['pred']]

    # fit association model on test set
    age_delta <- with(test, age_pred - age)  # ... XXX

    mod <- lm(scale(value) ~           # y
              scale(value_adjusted) +  # confound_train XXX
              scale(age_delta) +       # brain age delta
              scale(FI_pred) +              # Fluid Intelligence
              scale(N_pred), test)     # Neuroticism
    n.sim <- 10000
    mod.sim <- arm::sim(mod, n.sim = n.sim)
    out <- data.table(mod.sim@coef)
    data.table(
      name = name[1],
      coef = c(out[['scale(age_delta)']],
                out[['scale(FI_pred)']],
                out[['scale(N_pred)']]),
      target = rep(c("Brain Age Delta", "Fluid Intelligence", "Neuroticism"),
        each = n.sim)
    )
  },
  by = family]

# Target models

#' Get point estimates + standard outputs for conditional target model
DT_cond_target <- DT_pred[,
  {
    train <- .SD[evaluation == "Validation"]
    test <- .SD[evaluation == "Generalization"]

    # fit association model on test set
    age_delta <- with(test, age_pred - age)  # ... XXX

    mod <- lm(scale(value) ~           # y
              scale(age) +       # brain age delta
              scale(FI) +              # Fluid Intelligence
              scale(N), test)     # Neuroticism

    coefs <- coef(summary(mod))
    out <- data.frame(
      coef = coefs[-1, 1],  # kick out intercept
      se = coefs[-1, 2],    # ... and get columns for coef and error
      p.val = coefs[-1, 4],
      target = c("Age", "Fluid Intelligence", "Neuroticism"))
    out['nobs'] = nobs(mod)
    out['name'] = name[1]
    out
  },
  by = family]

# get parametric bootstrap for conditional target model
DT_cond_target_bs <- DT_pred[,
  {
    train <- .SD[evaluation == "Validation"]
    test <- .SD[evaluation == "Generalization"]

    # fit association model on test set
    age_delta <- with(test, age_pred - age)  # ... XXX

    mod <- lm(scale(value) ~           # y
              scale(age) +       # brain age delta
              scale(FI) +              # Fluid Intelligence
              scale(N), test)     # Neuroticism
    n.sim <- 10000
    mod.sim <- arm::sim(mod, n.sim = n.sim)
    out <- data.table(mod.sim@coef)
    data.table(
      name = name[1],
      coef = c(out[['scale(age)']],
               out[['scale(FI)']],
               out[['scale(N)']]),
      target = rep(c("Age", "Fluid Intelligence", "Neuroticism"),
        each = n.sim)
    )
  },
  by = family]

###############################################################################
# Marginal models for supplement

DT_margin_proxy <- DT_pred[,
  {
    train <- .SD[evaluation == "Validation"]
    test <- .SD[evaluation == "Generalization"]
    deconf <- fit_train_deconfound(
      train = train, test = test, var = "value", confound = "age")
    value_adjusted <- deconf[['pred']]

    # fit association model on test set
    age_delta <- with(test, age_pred - age)  # ... XXX

    mod1 <- lm(scale(value) ~           # y
               scale(value_adjusted) +  # confound_train XXX
               scale(age_delta), test)     # Age delta

    mod2 <- lm(scale(value) ~           # y
               scale(value_adjusted) +  # confound_train XXX
               scale(FI_pred), test)     # Neuroticism

    mod3 <- lm(scale(value) ~           # y
               scale(value_adjusted) +  # confound_train XXX
               scale(N_pred), test)     # Neuroticism

    coefs1 <- coef(summary(mod1))
    coefs2 <- coef(summary(mod2))
    coefs3 <- coef(summary(mod3))
    sel <- -c(1, 2)
    out <- data.frame(
      coef = c(coefs1[sel, 1],
               coefs2[sel, 1],
               coefs3[sel, 1]),
      se = c(coefs1[sel, 2],
             coefs2[sel, 2],
             coefs3[sel, 2]),
      p.val = c(coefs1[sel, 4],
                coefs2[sel, 4],
                coefs3[sel, 4]),
      target = c("Brain Age Delta", "Fluid Intelligence", "Neuroticism"))
    out['nobs'] = nobs(mod1)
    out['name'] = name[1]
    out
  },
  by = family]

# ... for marginal target model
DT_margin_target <- DT_pred[,
  {
    train <- .SD[evaluation == "Validation"]
    test <- .SD[evaluation == "Generalization"]

    # fit association model on test set
    age_delta <- with(test, age_pred - age)  # ... XXX

    mod1 <- lm(scale(value) ~           # y
               scale(age), test)     # Neuroticism

    mod2 <- lm(scale(value) ~           # y
               scale(FI), test)     # Neuroticism

    mod3 <- lm(scale(value) ~           # y
               scale(N), test)     # Neuroticism

    coefs1 <- coef(summary(mod1))
    coefs2 <- coef(summary(mod2))
    coefs3 <- coef(summary(mod3))
    sel <- -1
    out <- data.frame(
      coef = c(coefs1[sel, 1],
               coefs2[sel, 1],
               coefs3[sel, 1]),
      se = c(coefs1[sel, 2],
             coefs2[sel, 2],
             coefs3[sel, 2]),
      p.val = c(coefs1[sel, 4],
                coefs2[sel, 4],
                coefs3[sel, 4]),
      target = c("Age", "Fluid Intelligence", "Neuroticism"))
    out['nobs'] = nobs(mod1)
    out['name'] = name[1]
    out
  },
  by = family]

# get parametric bootstrap for marginal target model
DT_margin_target_bs <- DT_pred[,
  {
    train <- .SD[evaluation == "Validation"]
    test <- .SD[evaluation == "Generalization"]

    mod1 <- lm(scale(value) ~           # y
               scale(age), test)     # Neuroticism

    mod2 <- lm(scale(value) ~           # y
               scale(FI), test)     # Neuroticism

    mod3 <- lm(scale(value) ~           # y
               scale(N), test)     # Neuroticism

    n.sim <- 10000
    # boots
    mod1.sim <- arm::sim(mod1, n.sim = n.sim)
    out1 <- data.table(mod1.sim@coef)
    mod2.sim <- arm::sim(mod2, n.sim = n.sim)
    out2 <- data.table(mod2.sim@coef)
    mod3.sim <- arm::sim(mod3, n.sim = n.sim)
    out3 <- data.table(mod3.sim@coef)

    data.table(
      name = name[1],
      coef = c(out1[['scale(age)']],
               out2[['scale(FI)']],
               out3[['scale(N)']]),
      target = rep(c("Age", "Fluid Intelligence", "Neuroticism"),
        each = n.sim)
    )
  },
  by = family]

# get parametric bootstrap for marginal proxy model
DT_margin_proxy_bs <- DT_pred[,
  {
    train <- .SD[evaluation == "Validation"]
    test <- .SD[evaluation == "Generalization"]
    deconf <- fit_train_deconfound(
      train = train, test = test, var = "value", confound = "age")
    value_adjusted <- deconf[['pred']]

    age_delta <- with(test, age_pred - age)  # ... XXX

    mod1 <- lm(scale(value) ~           # y
               scale(value_adjusted) +  # confound_train XXX
               scale(age_delta), test)     # Neuroticism

    mod2 <- lm(scale(value) ~           # y
               scale(value_adjusted) +  # confound_train XXX
               scale(FI_pred), test)     # Neuroticism

    mod3 <- lm(scale(value) ~           # y
               scale(value_adjusted) +  # confound_train XXX
               scale(N_pred), test)     # Neuroticism

    n.sim <- 10000
    # boots
    mod1.sim <- arm::sim(mod1, n.sim = n.sim)
    out1 <- data.table(mod1.sim@coef)
    mod2.sim <- arm::sim(mod2, n.sim = n.sim)
    out2 <- data.table(mod2.sim@coef)
    mod3.sim <- arm::sim(mod3, n.sim = n.sim)
    out3 <- data.table(mod3.sim@coef)

    data.table(
      name = name[1],
      coef = c(out1[['scale(age_delta)']],
               out2[['scale(FI_pred)']],
               out3[['scale(N_pred)']]),
      target = rep(c("Brain Age Delta", "Fluid Intelligence", "Neuroticism"),
        each = n.sim)
    )
  },
  by = family]

##############################################################################
# writing it out

fwrite(DT_cond_proxy, 'mod_cond_proxy.csv')
fwrite(DT_cond_proxy_bs, 'mod_cond_proxy_bs.csv')
fwrite(DT_cond_target, 'mod_cond_target.csv')
fwrite(DT_cond_target_bs, 'mod_cond_target_bs.csv')

fwrite(DT_margin_proxy, 'mod_margin_proxy.csv')
fwrite(DT_margin_proxy_bs, 'mod_margin_proxy_bs.csv')
fwrite(DT_margin_target, 'mod_margin_target.csv')
fwrite(DT_margin_target_bs, 'mod_margin_target_bs.csv')


library(contextual)
horizon <- 500
simulations <- 1000
ProbClick <- c(0.8, 0.3, 0.1)
bandit <- BasicBernoulliBandit$new(weights = ProbClick)

agents <- list(Agent$new(OraclePolicy$new(), bandit),
               Agent$new(UCB1Policy$new(), bandit),
               Agent$new(ThompsonSamplingPolicy$new(1.0, 1.0), bandit),
               Agent$new(EpsilonGreedyPolicy$new(0.1), bandit),
               Agent$new(SoftmaxPolicy$new(tau = 0.1),bandit),
               Agent$new(Exp3Policy$new(0.1), bandit))

simulation <- Simulator$new(agents, horizon, simulations)
history <- simulation$run()

plot(history, type = "cumulative", regret = FALSE)


## this file provides helper functions

library(tidyverse)

## ******************************
## set some global variables ----
## ******************************

theta_arg <- 0.85

## ****************************
## load & precprocess data ----
## ****************************

# load data & fix naming error
d = read_csv('../02_data/data_raw.csv') %>%
  # fix typo in column head
  rename(situation_number = sitation_number) %>%
  filter(trial_name != "training_trials")

## ******************************
## all sentences & situation ----
## ******************************

# all relevant sentences
sentences <- expand.grid(
  outer = c("all", "some", "most", "none"),
  inner = c("all", "some", "most", "none"),
  predicate = c("wrong", "right")
) %>%
  mutate(
    compact = str_c(outer, "|", inner, "|", predicate)
  ) %>% pull(compact)

# all relevant situations
situations <- d %>%
  select(situation_number, stimulus) %>%
  unique %>%
  arrange(situation_number)

## ***************
## clean data ----
## ***************

# check for incomplete responses
message(
  "There were ",
  d %>% filter(! response %in% sentences) %>% nrow(),
  " trials which were excluded because they were recorded incompletely (due to a technical issue)."
)

# remove incompletely recorded trials
d = d %>% filter(response %in% sentences)

## *****************************
## semantics of expressions ----
## *****************************

evaluate_quantifier = function(quantifier, bool_vector) {
  case_when(
    quantifier == "all"  ~ sum(bool_vector) == length(bool_vector),
    quantifier == "some" ~ sum(bool_vector) >= 1,
    quantifier == "many" ~ sum(bool_vector) > 0.3 * length(bool_vector),
    quantifier == "most" ~ sum(bool_vector) > 0.5 * length(bool_vector),
    quantifier == "none" ~ sum(bool_vector) == 0,
    quantifier == "few"  ~ sum(bool_vector) <= 0.3 * length(bool_vector)
  )
}

evaluate_predicate = function(resp, stimulus){
  if (resp[3] == "wrong") {
    return(1 - stimulus)
  }
  else {
    return(stimulus)
  }
}

evaluate_truth = function(resp, stimulus) {
  resp = resp %>% str_split("\\|", simplify = F) %>% unlist()
  stimulus = evaluate_predicate(resp, stimulus)
  stimulus = map_dbl(
    1:nrow(stimulus),
    function(i) {
      evaluate_quantifier(resp[2], stimulus[i,])
    }
  )
  evaluate_quantifier(resp[1], stimulus)
}

# all relevant situations
situations <- d %>%
  select(situation_number, stimulus) %>%
  unique %>%
  arrange(situation_number)

# extract the situation (string) that goes with a situation number
get_stimulus_for_situation_number <- function(s_nr) {
  filter(situations, situation_number == s_nr) %>% pull(stimulus)
}

get_truth_value = Vectorize(function(sentence, situation_number) {
  # extract stimulus representation for the situation_numer
  stimulus <- get_stimulus_for_situation_number(situation_number)
  # preprocess stimulus representation
  stimulus = stimulus %>% str_split("\\|", simplify = F) %>% unlist()
  stimulus = stimulus %>% as.numeric() %>% matrix(byrow = T, ncol = 12)
  # stimulus = 1 - stimulus # why do I need this?
  evaluate_truth(sentence, stimulus)
})

## *******************************
## probability of expressions ----
## *******************************

# calculate the probability that a single quantifier
# statement is true for a given bias and number of observations
calculate_probability_quantifier = function(quantifier, bias, n_observations) {
  case_when(
    quantifier == "all"  ~ dbinom(x= n_observations, size = n_observations, prob = bias) %>% sum,
    quantifier == "some" ~ dbinom(x= 1:n_observations, size = n_observations, prob = bias) %>% sum,
    quantifier == "many" ~ dbinom(x= ceiling(0.3*n_observations):n_observations, size = n_observations, prob = bias) %>% sum,
    quantifier == "most" ~ dbinom(x= ceiling(0.5*n_observations):n_observations, size = n_observations, prob = bias) %>% sum,
    quantifier == "none" ~ dbinom(x= 0, size = n_observations, prob = bias) %>% sum,
    quantifier == "few"  ~ dbinom(x= 0:ceiling(0.3*n_observations), size = n_observations, prob = bias) %>% sum
  )
}

# calculate the probability P(sentence|H) analytically
# for a given bias (=hypothesis)
calculate_probability = function(resp, bias) {
  #unpack sentence
  resp = resp %>% str_split("\\|", simplify = F) %>% unlist()
  # reverse success probability if predicate is "wrong"
  bias = ifelse(resp[3] == "wrong", 1-bias, bias)
  # get probability of inner quantifier being true or a single itm
  inner_prob = calculate_probability_quantifier(resp[2], bias, 12)
  # get probability of outer quantifier statement
  calculate_probability_quantifier(resp[1], inner_prob, 5)
}

# testing
calculate_probability("all|all|right", 0.9)
calculate_probability("none|some|wrong", 0.9)

# calculate argumentative strength for a given bias
get_argument_strength = Vectorize(
  function(sentence, bias) {
    log(calculate_probability(sentence, bias) / calculate_probability(sentence, 1-bias))
  }
)

# testing
# get_argument_strength("most|all|right", 0.8)

## *********************************************************
## built a big look-up table & other useful structures  ----
## *********************************************************

# combine all sentences and situation
look_up_table <-
  expand.grid(
    situation_number = 1:20,
    sentence = sentences
  ) %>%
  full_join(situations, by = "situation_number") %>%
  as_tibble() %>%
  # add truth-values
  mutate(
    truth_value = get_truth_value(sentence, situation_number)
  )

# matrix representation of truth values
#   situations in rows, sentences in columns
truth_table <- look_up_table %>%
  mutate(truth_value = as.numeric(truth_value)) %>%
  select(situation_number, sentence, truth_value) %>%
  pivot_wider(
    id_cols = c("situation_number"),
    names_from = sentence,
    values_from = truth_value
  )
truth_table_matrix <- as.matrix(truth_table[,-1])

# vector of arg_strength for each sentence (in correct order)
arg_strength_vector <- get_argument_strength(sentences, bias = theta_arg)

# vector of informativity for each sentence
informativity_vector <- log(1 / colSums(truth_table[,-1]))

look_up_table <-
  look_up_table %>%
  # add arg-str and informativity related info
  mutate(
    arg_strength = get_argument_strength(sentence, bias = theta_arg),
    informativity = informativity_vector[sentence]
  ) %>%
  group_by(situation_number) %>%
  mutate(
    true_best_high = max(arg_strength[truth_value]),
    true_best_low  = max(-arg_strength[truth_value]),
    best_info      = max(informativity[truth_value])
    # best_arg_high_sentence = sentences[truth_value][which.max(arg_strength[truth_value])],
    # best_arg_low_sentence = sentences[truth_value][which.max(-arg_strength[truth_value])],
    # best_info_sentence = sentences[truth_value][which.max(informativity[truth_value])]
  ) %>%
  ungroup()

# # check if entries are in the right order
# names(arg_strength_vector) == colnames(truth_table_matrix)

## *****************************
## add information to data  ----
## *****************************

get_best_high <- Vectorize(
  function(s_nr){
    filter(look_up_table, situation_number == s_nr) %>% pull(true_best_high) %>% .[1] %>% as.numeric()
  }
)

get_best_low <- Vectorize(
  function(s_nr){
    filter(look_up_table, situation_number == s_nr) %>% pull(true_best_low) %>% .[1] %>% as.numeric()
  }
)

get_informativity <- Vectorize(
  function(sentence) {
    informativity_vector[which(names(informativity_vector) == sentence)] %>% as.numeric()
  }
)

get_best_info <- Vectorize(
  function(s_nr) {
    filter(look_up_table, situation_number == s_nr) %>% pull(best_info) %>% .[1] %>% as.numeric()
  }
)

d = d %>%
  mutate(
    # add truth-value
    truth_value = get_truth_value(response, situation_number),
    # add argument strength
    arg_strength_raw = get_argument_strength(response, bias = theta_arg),
    arg_strength = ifelse(condition == "high", arg_strength_raw, - arg_strength_raw),
    true_best_high = get_best_high(situation_number),
    true_best_low  = get_best_low(situation_number),
    true_best = ifelse(condition == "high", true_best_high, true_best_low),
    # deviance from the max. arg_strength among all true statements
    best_arg_deviance = true_best - arg_strength,
    informativity = get_informativity(response) %>% as.numeric(),
    best_info = get_best_info(situation_number),
    best_info_deviance = best_info - informativity
  )

get_best_high(20)

## *****************************
## extract matrix of counts ----
## *****************************

# focus on only true responses

d_true <- filter(d, truth_value == T)

y_counts_high = matrix(0, nrow = 20, ncol = length(sentences))
y_counts_low  = matrix(0, nrow = 20, ncol = length(sentences))

colnames(y_counts_high) <- sentences
colnames(y_counts_low)  <- sentences

rownames(y_counts_high) <- str_c("Situation ", 1:20)
rownames(y_counts_low)  <- str_c("Situation ", 1:20)

for (i in 1:nrow(d_true)) {
  condition_i <- d_true$condition[i]
  response_i  <- d_true$response[i]
  situation_i <- d_true$situation_number[i]
  if (condition_i == "high") {
    y_counts_high[situation_i, which(sentences == response_i)] <-
      y_counts_high[situation_i, which(sentences == response_i)] + 1
  } else {
    y_counts_low[situation_i, which(sentences == response_i)] <-
      y_counts_low[situation_i, which(sentences == response_i)] + 1
  }
}

## *****************************
## plotting theme ----
## *****************************

theme_ida <- function(title.size = 16, text.size = 14,
                      legend.position = "top", show.axis = FALSE,
                      plot.margin = c(.2, .1, .2, .1)){
  # baseline
  layout <- ggplot2::theme_classic()
  layout <- layout + theme(text = element_text(size = text.size),
                           title = element_text(size = title.size,
                                                face = "bold"),
                           line = element_line(size = .5))

  # axes
  if (inherits(show.axis, "character") | show.axis == FALSE){
    if (inherits(show.axis, "character")){
      show.axis <- tolower(show.axis)
      if (show.axis == "x"){
        layout <- layout + theme(axis.line.y = element_blank())
      }
      if (show.axis == "y"){
        layout <- layout + theme(axis.line.x = element_blank())
      }
    } else {
      layout <- layout + theme(axis.line.x = element_blank(),
                               axis.line.y = element_blank())
    }
  }

  # legend
  layout <- layout + theme(legend.position = legend.position,
                           legend.background = element_blank(),
                           legend.key.height = unit(2, "line"))

  # facets
  layout <- layout + theme(strip.background = element_blank(),
                           strip.text = element_text(size = title.size,
                                                     face = "bold"))

  # misc
  layout <- layout + theme(panel.background = element_rect(fill = "transparent"),
                           plot.background = element_rect(fill = "transparent"),
                           plot.margin = unit(plot.margin, "cm"))

  layout
}

project_colors = rcartocolor::carto_pal(11, "Safe")[c(3,4,5,6,7,8,9,10,11,1,2)] # https://github.com/Nowosad/rcartocolor & https://carto.com/carto-colors/
# color blind friendly
# project_colors = c("#000000", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")
# project_colors =RColorBrewer::brewer.pal(8, "Set2")

# setting theme colors globally
## following: https://data-se.netlify.com/2018/12/12/changing-the-default-color-scheme-in-ggplot2/
scale_colour_discrete <- function(...) {
  scale_colour_manual(..., values = project_colors)
}
scale_fill_discrete <- function(...) {
  scale_fill_manual(..., values = project_colors)
}

theme_set(
  theme_ida()
)


#' Random Value Generation: Uniform Distribution Scale-Location Reparametrization
#'
#' A long title for a small function. Helper function for \code{\link{drift_simuls}} which reparametrizes the arguments of
#' the \code{\link{runif}} function as scale and location parameters.
#'
#' @export
#' @param n Amount of values to be generated.
#' @param loc Location parameter.
#' @param scale Scale parameter.
#' @return A vector of doubles of length "n".
runif2 <- function(n, loc, scale){ # wrap runif in location scale variant
    out <- loc + scale * runif(n)
    as.vector(out)
}


options(warn=-1)
omega <- seq(1, 10, 1)
not <- function(x) { setdiff(omega, x)}
symm <- function(x, y) { union(setdiff(x, y),setdiff(y, x))}
cat("Primo esercizio: ")
sort(intersect(not(B),not(intersect(A, C))))
cat(setequal(length(.Last.value),0))
cat("\nSecondo esercizio: TRUE\nTerzo esercizio: ")
temp = sort(symm(union(union(A, B), C), not(omega)))
cat(setequal(length(setdiff(omega, temp)),0))
cat("\nQuarto esercizio: ")
not(symm(symm(A, B), C))
cat(setequal(.Last.value,((intersect(intersect(A, B), C)))))
options(warn=0)


library(pdftools)
library(tidyverse)
library(data.table)
library(readxl)
setwd("C:/Users/Owner/Dropbox/Politics")

imported_calls_for_service = read_excel('police calls for service may 31.xlsx', 'may 31 clean'
                                        # col_types = 'text'
                                        ) %>%
  rename(
    incident_num = `Incident #`,
    type = `Incident Type`
  ) %>%
  mutate(
    received_time_minute = as.numeric(Received) * 24 * 60,
    cleared_minute = as.numeric(Cleared) * 24 * 60,
    received_hour = received_time_minute %/% 60,
    received_minute = floor(received_time_minute %% 60),
    received_datetime = ISOdatetime(2020, 5, 31, received_hour, received_minute, 0)
  ) %>%
  filter(
    received_hour >= 12
  )

calls_for_service_table = table(imported_calls_for_service$type) %>% sort(decreasing = T)

imported_calls_for_service$type_factor = factor(imported_calls_for_service$type, levels = names(calls_for_service_table))

ggplot(imported_calls_for_service %>% filter(type %in% names(calls_for_service_table)[1:12]), aes(received_datetime, fill = type_factor)) +
  geom_histogram(show.legend = F, binwidth = 60*10) +
  facet_wrap(~type_factor)

library(viridisLite)

ggplot(imported_calls_for_service %>% filter(type %in% names(calls_for_service_table)[1:5]), aes(received_datetime, fill = type_factor)) +
  geom_histogram(show.legend = T, binwidth = 60*10) +
  # scale_fill_hue(name = '') +
  scale_fill_viridis_d(name = '') +
  labs(
    x = 'Time Received', y = 'Count',
    title = 'Top 5 Types of Police Calls for Service',
    subtitle = 'Santa Monica: May 31, 2020. 12pm onward in 10 minute intervals.'
  ) +
  scale_x_datetime(date_breaks = '1 hour', date_labels = '%H:%M')
ggsave('sm_police_calls_for_service.png', height = 8, width = 10, units = 'in', dpi = 800)

ggplot(imported_calls_for_service, aes(received_datetime)) +
  geom_histogram(show.legend = T, binwidth = 60*10)

ggplot(imported_calls_for_service %>% filter(type %in% names(calls_for_service_table)[1:10]), aes(type_factor, received_datetime)) +
  geom_point(aes(colour = Disposition)) +
  coord_flip()

ggplot(imported_calls_for_service %>% filter(type %in% names(calls_for_service_table)[1:5]), aes(received_datetime, fill = type_factor)) +
  stat_density(position = 'identity', alpha = 0.3, ncol = 1) +
  facet_wrap(~type_factor)

ggplot(imported_calls_for_service %>% filter(type %in% names(calls_for_service_table)[1:5]), aes(type_factor, received_datetime)) +
  geom_violin() +
  coord_flip()

Projects/Local government elections, finance/scripts/analyze_calls_for_assistance_may_31.r


library(boot)

data <- read.csv("C:/Users/LucasMarquesGasparin/Desktop/Learning/TCC/Data/Processed/1.csv")
data

bootCorTest <- function(data, i){
    d <- data[i, ]
    cor.test(d$RR_A, d$RR_B)$p.value
}

b <- boot(data, bootCorTest, R = 1000)

b$t0


context("Generate Folds")

test_that("Basic generate folds works", {
  folds = generate_folds(num_instances = 20, num_folds = 5)
  expect_equal(dim(folds), c(20, 1))
  expect_equal(max(folds), 5)
  expect_equal(
    array( table(folds[,1]) ),
    array( c(4,4,4,4,4) )
  )

  folds = generate_folds(num_instances = 20, num_folds = 5, num_iter=2)
  expect_equal(dim(folds), c(20, 2))
  expect_equal(max(folds), 5)
})

test_that("Generate folds with strata works", {
  folds = generate_folds(num_instances = 10, num_folds = 5, strata = list(1:5, 6:10))
  expect_equal(dim(folds), c(10, 1))
  expect_equal(max(folds), 5)
})


score <- function(input) {
    if ((input[13]) <= (9.724999904632568)) {
        if ((input[6]) <= (7.437000036239624)) {
            if ((input[8]) <= (1.4849499464035034)) {
                var0 <- 50.0
            } else {
                var0 <- 26.681034482758605
            }
        } else {
            var0 <- 44.96896551724139
        }
    } else {
        if ((input[13]) <= (16.085000038146973)) {
            var0 <- 20.284353741496595
        } else {
            var0 <- 14.187142857142863
        }
    }
    return(var0)
}


library(slimr)
library(dartR)
library(vcfR)
library(parallel)
source("./bernd_Ne/gl2genepop.r")
library(tictoc)
library(future)
tic()
## number of generations to simulate
simngen<-50
## number of snps to simulate
simnsnps <- 5000

#sample GED chromosom
gedchromo <- read.csv("./bernd_Ne/GED_chromosomes.csv") #averaged length of sex chromosome.

total.chromo <- sum(gedchromo$csize)* 1e6  #length in bases

chromo <- sort(sample(0:(total.chromo-1),simnsnps+1, replace=FALSE))
recrates <- (diff(chromo)/1e6)*0.01 #convert to recombination rate (1 cM=0.01 per 1e6 basis)

chromends <- cumsum(gedchromo$csize)*1e6

for (i in 1:length(chromends))
{
  index <- which(chromo[1:(simnsnps-1)]<chromends[i]  & chromo[2:simnsnps]>chromends[i])

  recrates[index]<- 0.5
}

#plot(chromo, rep(1,length(chromo)), pch=15)
#abline(v=chromends)

snpends <- 0:4999

slim_script(
  slim_block(initialize(),
             {
               defineConstant("alpha1", 0.1);
               defineConstant("alpha2", 1e-8);
               ##defineConstant("Ne",10);
               ## set the overall mutation rate
               #initializeMutationRate(0.05);

               ##defineConstant("test_vector", slimr_inline(recrates[[slimr_template("index", 0)]], delay = TRUE));
               defineConstant("rates", slimr_inline(recrates));
               defineConstant("ends", slimr_inline(snpends));

               ##[[slimr_template("index", 0)]], delay = TRUE));

               ## m1 mutation type: neutral
               defineConstant("L", !!simnsnps);
               defineConstant("simlen", !!simngen);

               #how many outputs (simlen=only once at the end)
               defineConstant("every", simlen);
               initializeSLiMOptions(nucleotideBased=T);
               initializeAncestralNucleotides(randomNucleotides(L));
               initializeMutationTypeNuc("m1", 0.5, "f",0.0 );
               m1.mutationStackPolicy = "l";
               m1.convertToSubstitution=T;
               ## g1 genomic element type: uses m1 for all mutations
               defineConstant("mm", matrix(c(0.0,alpha1,0.0,0.0, alpha1,0.0,0.0,0.0, 0.0,0.0,0.0,alpha1, 0.0,0.0,alpha1,0.0 ),nrow=4, ncol=4));
               defineConstant("mm2", matrix(c(0.0,alpha2,0.0,0.0, alpha2,0.0,0.0,0.0, 0.0,0.0,0.0,alpha2, 0.0,0.0,alpha2,0.0 ),nrow=4, ncol=4));
               initializeGenomicElementType("g1", m1, 1.0, mm);
               #initializeGenomicElementType("g1", m1, 1.0);
               ## uniform chromosome of length 100 kb
               initializeGenomicElement(g1, 0, L-1);
               ## uniform recombination along the chromosome
               #initializeRecombinationRate(slimr_template("RR"));
               #calculated recombination rates

               crates = rates
               if (slimr_template("RR")!=0.99)  crates = rep(slimr_template("RR"),5000); #change to constant or use GED version

               initializeRecombinationRate(rates = crates, ends = ends)

               ##initializeRecombinationRate(slimr_template("RR")));

             }),
  slim_block(1,
             {
               sim.addSubpop("p1",slimr_template("Ne"));
             }),

  slim_block(1,simngen,late(), {

               if (sim.generation / every== round(sim.generation/every)) {
               pre = ""
               if (sim.generation<100) pre="0"
               if (sim.generation<10) pre="00"
               nn = paste0( c("./bernd_Ne/Neest/out","_Ne_",slimr_template("Ne"),"_rep_",slimr_template("rep"),"_RR_",slimr_template("RR"),"_",pre,sim.generation,".vcf")) ;

               p1.individuals.genomes.outputVCF(nn, simplifyNucleotides=T);

               ##c = sim.chromosome;
               ##catn("Ancestral: " + c.ancestralNucleotides());

              ## g = p1.genomes[0];
              ## catn("Derived:   " + g.nucleotides());

              ## catn("SNPs: " + paste(g.mutations.nucleotide));
              } ##end every
             }),

  slim_block(20, early(), {
    g1.setMutationMatrix(mm2);
  }),

  slim_block(simngen, late(), {
    ##sim.outputFull("model_output.txt");
               sim.simulationFinished();
              ## sim.outputFull();
              ## allIndividuals = p1.individuals;

             })
) -> script_temp

##slimr_template_info(script_temp)
##script_dummy <- slimr_script_render(script_temp, template=(data.frame(rep=1, Ne=50)))
##slimr_write(script_dummy[[1]], "script_dummy.txt")
##system("./slim script_dummy.txt")

##slimr::slim_run(script_1)

#df <- expand.grid(rep=1:100,  Ne = c(10,20,30,40,50,100), RR=c(0.0001,0.001,0.005, 0.01,0.1,0.50,0.99))

#df <- expand.grid(rep=1:10,  Ne = c(10,50), RR=c(0.001,0.005, 0.01,0.5,0.99))
#df <- expand.grid(rep=1:15,  Ne = c(10,20,30,40,50,100), RR=round(mean(recrates),4)) #just to have a number
#df <- expand.grid(rep=1:3,  Ne = c(10,20), RR=c(0.0001,0.001))
df <- expand.grid(rep=1:3,  Ne = c(10,20), RR=c(0.5,0.99))
#RR = 0.99 = GED recrates!!!
#df <- expand.grid(rep=1:5,  Ne = c(10,20,30,50), RR=c(0.005,0.99))

script_temp_df <- slimr_script_render(script_temp, template =df)
#slim_run(script_temp_df[[1]])

plan(multisession(workers = 2))
sr <- slim_run(script_temp_df,parallel = TRUE) #based on future plan

#####
#for (i in 1:nrow(df))
#{
#slimr_write(script_temp_df[[i]], "script_dummy.txt")
#system("./slim script_dummy.txt")
#}

files <- list.files(path="./bernd_Ne/Neest/",pattern="out" )
#gls <- list()
#for (i in 1:length(files)){
#  dumvcf<- read.vcfR(file.path("~/slimsim/out",files[i]),verbose=FALSE)
#  gls[[i]]<- vcfR2genlight(dumvcf)
#  names(gls)[i] <- files[i]
#}

#unlist(lapply(gls,nLoc))
#plot(1:length(gls),unlist(lapply(gls, function(x) mean(gl.Ho(x)))))

#snplevels <- c(100,500,1000,2000)
snplevels <- c(100,1000)
#sslevels <- c(10,20,30,40,50,100)
sslevels <- c(5,10)
sim <- function(i)

#for (i in 1:length(gls))
{

  dumvcf<- read.vcfR(file.path("./bernd_Ne/Neest/",files[i]),verbose=FALSE)
  gls<- vcfR2genlight(dumvcf)
  namesgls <- files[i]

res <- data.frame(rep=NA, Nesim=NA, nGen=NA, nSnp=NA, sample=NA,RR=NA, Nee0=NA, Nee0_low=NA, Nee0_up=NA )
cc <-1

Nesim=as.numeric(gsub("out_Ne_([0-9]+).*$", "\\1", namesgls))

nrep <-as.numeric(gsub(".*?rep_([0-9]+).*$", "\\1", namesgls))
nGen <-  as.numeric(gsub(".*_([0-9]+).vcf$", "\\1", namesgls))
nRR <- as.numeric(gsub(".*?RR_(0.[0-9]+).*$", "\\1", namesgls))

glout <- gls
glout <- gl.filter.monomorphs(glout, verbose = 0)
pop(glout)<- rep("A", nInd(glout))

for (ii in 1:length(snplevels))
{

  nSnp=snplevels[ii]
  if(nSnp<=nLoc(glout)) {
for (iii in 1:length(sslevels))
{

  ss = sslevels[iii]
  if (ss<=nInd(glout))
  {

gldummy <- glout[sample(1:nInd(glout), ss,replace = FALSE),sample(1:nLoc(glout), nSnp, replace = FALSE)]

gl2genepop(gldummy,paste0("./bernd_Ne//Neest/slimne",i,".gen"))

inf <- readLines("./bernd_Ne/Neest/info")
inf[3]<-paste0("slimne",i,".gen")

inf[6]<- paste0("slimLD",i,".txt")
con <- file(paste0("./bernd_Ne/Neest/info",i),"w")
writeLines(inf, con)
close(con)

system(paste0("./bernd_Ne/Neest/Ne2-1L i:./bernd_Ne/Neest/info",i))

ll <- readLines(paste0("./bernd_Ne/Neest/slimLD",i,".txt"))
index <- grep("Estimated Ne", ll)
nes <- unlist(strsplit(ll[index],split = "[ ]+"))
index <- grep("JackKnife on Samples", ll)
neslow <- unlist(strsplit(ll[index],split = "[ ]+"))
nesup  <- unlist(strsplit(ll[index+1],split = "[ ]+"))
Nee0 <- as.numeric(nes[length(nes)])
Nee0_low <- as.numeric(neslow[length(neslow)])
Nee0_up <- as.numeric(nesup[length(nesup)])

res[cc,]<- c(nrep, Nesim, nGen, nSnp, ss, nRR, Nee0, Nee0_low, Nee0_up)
cc <- cc+1
#res<- c(nrep, Nesim, nGen, nSnp, ss, Nee0, Nee0_low, Nee0_up)

#cat(paste("run",cc,"\n"))
#flush.console()
} #endif ss<= nInd
} #end iii
  } #if snplevels < nLoc
} #end ii (nSnps)
return(res)
} #gls files

system.time(res <- mclapply(1:length(files), function(x) sim(x), mc.cores = 1))
res<- do.call("rbind",res)

#write.csv(res,"res_all100.csv")

#res <- res[complete.cases(res[,1:7]),]

#res <- res[complete.cases(res),]
ggplot(res, aes(x=factor(Nesim), y=Nee0/Nesim,fill=factor(sample)))+geom_boxplot()+facet_grid(RR~nSnp)+ylim(c(0,1))

#ggplot(resall, aes(x=factor(Nesim), y=Nee0,fill=factor(run)))+geom_boxplot()+facet_wrap(.~nSnp)+ylim(c(0,60))

toc()


# Preamble (options, installs, imports & custom functions) ----

options(warn=1) #really should be default in R
`%!in%` = Negate(`%in%`) #should be in base R!

# specify the packages used:
required_packages = c(
	'github.com/rmcelreath/rethinking' # for rlkjcorr & rmvrnom2
	, 'github.com/stan-dev/cmdstanr' #for Stan stuff
	, 'github.com/mike-lawrence/aria/aria' # for aria
	, 'tidyverse' #for all that is good and holy
)

# load the helper functions:
for(file in fs::dir_ls('r')){
	cat('Loading function: ',fs::path_ext_remove(fs::path_file(file)),'()\n',sep='')
	source(file)
}

#install any required packages not already present
install_if_missing(required_packages)

# load tidyverse & aria
library(tidyverse)
library(aria)

# Simulate data ----
set.seed(1) #change this to make different data

#setting the data simulation parameters

#parameters you can play with
nI_per_group = 3 #number of individuals, must be an integer >1
nG_vars = 3 #number of 2-level variables manipulated as crossed and across individuals, must be an integer >0
num_Y_per_iq = 3 #number of observations per individual/condition combo, must be an integer >1

#the rest of these you shouldn't touch
nX = 2^(nG_vars)
Z = rnorm(nX)
iZ_sd = rweibull(1,2,1)
Y_sd = rweibull(1,2,1)

#compute X
X = sim_contrasts(nG_vars,'G')

# compute gZq
gZq = rep(NA,nX)
for(this_nX in 1:nX){
	gZq[this_nX] = X[this_nX,] %*% Z
}

#compute iZ
(
	1:nX
	%>% map_dfr(
		.f = function(this_nX){(
			tibble(
				value = rnorm(
					n = nI_per_group
					, mean = gZq[this_nX]
					, sd = iZ_sd
				)
			)
			%>% mutate(
				g = this_nX
				, individual = paste(g,1:n(),sep='_') #important that individuals have unique identifiers across groups
			)
		)}
	)
) ->
	iZ

#compute Y
(
	iZ
	%>% group_by(individual,g)
	%>% summarise(
		value = rnorm(num_Y_per_iq,value,Y_sd)
		, .groups = 'keep'
	)
) ->
	Y

#join with group & condition columns
(
	Y
	%>% left_join((
		attr(X,'data')
		%>% mutate(g=1:n())
	))
	%>% ungroup()
	%>% select(everything(),-g,-value,value)
) ->
	dat

#dat is now what one would typically have as collected data
dat

# Compute inputs to Stan model ----

#if there's no missing data (as in this synthetic example), we could proceed with modelling,
#  but to demonstrate how to handle missing data, we'll do a bit of extra work:

#Uncomment next section to induce data-missingness (causes some Ss to be missing whole conditions)
(
	dat
	#first collapse to individual-by-condition stats
	%>% group_by(
		across(-value)
	)
	%>% summarise(.groups='drop')
	%>% slice_sample(prop=.9)
	%>% semi_join(
		x = dat
		, y = .
	)
) ->
	dat

#compute X from distinct combinations of groups
(
	dat
	%>% select(starts_with('G'))
	%>% distinct()
	#add the contrast matrix columns
	%>% mutate(
		contrasts = get_contrast_matrix_rows_as_list(
			data = .
			# the following complicated specification of the formula is a by-product of making this example
			# work for any number of variables =  normally you would do something like this
			# (for 2 variables for example):
			# formula = ~ G1*G2
			, formula = as.formula(paste0('~',paste0('G',1:nG_vars,collapse='*')))
			# half-sum contrasts are nice for 2-level variables bc they yield parameters whose value
			# is the difference between conditions
			, contrast_kind = halfsum_contrasts
		)
	)
) ->
	X_with_vars

#join X with dat to label individuals with corresponding row from X
(
	X_with_vars
	# add row identifier
	%>% mutate(X_row=1:n())
	%>% right_join((
		dat
		%>% select(individual,starts_with('G'))
		%>% distinct()
	))
	%>% arrange(individual)
	%>% pull(X_row)
) ->
	iX

# package for stan & sample ----

data_for_stan = lst( #lst permits later entries to refer to earlier entries

	####
	# Entries we need to specify ourselves
	####

	# X: group-level predictor matrix
	X = (
		X_with_vars
		%>% select(contrasts)
		%>% unnest(contrasts)
		%>% as.matrix()
	)

	# iX: which group each individual is associated with
	, iX = iX

	# Y: observations
	, Y = dat$value

	# iY: which individual is associated with each observation in Y
	, iY = as.numeric(factor(dat$individual))

	####
	# Entries computable from the above
	####

	# nX: number of cols in the group-level predictor matrix
	, nX = ncol(X)

	# rX: number of rows in the group-level predictor matrix
	, rX = nrow(X)

	# nI: number of individuals
	, nI = max(iY)

	# nY: num entries in the observation vectors
	, nY = length(Y)

)

# double-check:
glimpse(data_for_stan)

#set the model and posterior paths
mod_path = 'stan/hbg_c.stan'
post_path = 'nc/hbg_c.nc'

# ensure model is compiled
aria:::check_syntax_and_maybe_compile(mod_path)

# compose
aria::compose(
	data = data_for_stan
	, code_path = mod_path
	, out_path = post_path
	, overwrite = T
)

# check posterior diagnostics ----
post = aria::coda(post_path)

# Check treedepth, divergences, & rebfmi
(
	post$draws(group='sample_stats')
	%>% posterior::as_draws_df()
	%>% group_by(.chain)
	%>% summarise(
		max_treedepth = max(treedepth)
		, num_divergent = sum(divergent)
		, rebfmi = var(energy)/(sum(diff(energy)^2)/n()) #n.b. reciprocal of typical EBFMI, so bigger=bad, like rhat
	)
)

# gather summary for core parameters (inc. r̂ & ess)
(
	post$draws(group='parameters')
	%>% posterior::summarise_draws(.cores=parallel::detectCores())
) ->
	par_summary

# show the ranges of r̂/ess's
(
	par_summary
	%>% select(rhat,contains('ess'))
	%>% summary()
)

#View those with suspect r̂
(
	par_summary
	%>% filter(rhat>1.01)
	%>% View()
)

# Viz recovery of non-correlation parameters ----
(
	post$draws(variables=c('Y_sd','Z','iZ_sd'))
	%>% posterior::as_draws_df()
	%>% select(-.draw)
	%>% pivot_longer(
		cols = -c(.chain,.iteration)
		, names_to = 'variable'
	)
	%>% left_join(
		bind_rows(
			tibble(
				true = Y_sd
				, variable = 'Y_sd'
			)
			, tibble(
				true = as.vector(Z)
				, variable = paste0('Z[',1:length(true),']')
			)
			, tibble(
				true = iZ_sd
				, variable = 'iZ_sd'
			)
		)
	)
	%>% group_by(variable)
	%>% arrange(variable,.chain,.iteration)
	%>% summarise(
		rhat = 1.01<posterior::rhat(matrix(value,ncol=length(unique(.chain))))
		, ess_bulk = 100>posterior::ess_bulk(matrix(value,ncol=length(unique(.chain))))
		, ess_tail = 100>posterior::ess_tail(matrix(value,ncol=length(unique(.chain))))
		, as_tibble(t(posterior::quantile2(value,c(.05,.25,.5,.75,.95))))
		, true = true[1]
	)
	%>% mutate(variable = factor_1d(variable))
	%>% ggplot()
	+ geom_hline(yintercept = 0)
	+ geom_linerange(
		mapping = aes(
			x = variable
			, ymin = q5
			, ymax = q95
			, colour = ess_tail
		)
		, alpha = .5
	)
	+ geom_linerange(
		mapping = aes(
			x = variable
			, ymin = q25
			, ymax = q75
			, colour = ess_bulk
		)
		, size = 3
		, alpha = .5
	)
	+ geom_point(
		mapping = aes(
			x = variable
			, y = q50
			, fill = rhat
		)
		, shape = 21
		, size = 3
	)
	+ geom_point(
		mapping = aes(
			x = variable
			, y = true
		)
		, size = 4
		, shape = 4
		, colour = 'blue'
	)
	+ coord_flip()
	+ scale_color_manual(
		values = lst(`TRUE`='red',`FALSE`='black')
		, labels = lst(`TRUE`='<100',`FALSE`='>=100')
	)
	+ scale_fill_manual(
		values = lst(`TRUE`='red',`FALSE`='white')
		, labels = lst(`TRUE`='>1.01',`FALSE`='<=1.01')
	)
	+ labs(
		y = 'True & Posterior Value'
		, x = 'Variable'
		, colour = 'ESS'
		, fill = 'Rhat'
	)
)


#Setup
cat("\014")
rm(list = ls())
setwd(dirname(sys.frame(1)$ofile))
#setwd("C:/Users/Frederik/Google Drev/01666 - fagprojekt/Code")
par(pty="m", mfrow=c(1,1))

#instal
library(astsa) #nicer time series interface
library(forecast) #nicer forecasting interface

# Load data
interpolated = read.table('ts_greenland.csv',sep=',')

#
# Time Series Analysis Stuff
#

train=ts(head(interpolated,length(interpolated)-12))
plot(train)
test=ts(tail(interpolated,12), start=c(end(train)[1] + 1))
#freq around 36ish=?
differenceTrain=diff(train,1)
plot(differenceTrain)

par(mar=c(3,3,3,1),mgp=c(2,0.7,0))
acf(differenceTrain,36*5)
#non-seasonal ma: 4 (6?)
#seasonal 4-5ish
pacf(differenceTrain,36*5)
#non-seasonal ar: 3
#seasonal 1ish

#inital model
#warning: the sma will make this fit take a long time!
start<-sarima(train,3,1,3,1,1,4,36,no.constant=TRUE);start
#loads of non-significant parameters (statistically)

#iteratively fit and check temp model. remove least signifanct
#until final model is reach
tmp<-sarima(train,3,1,2,0,1,1,36,no.constant=TRUE);tmp

final<-sarima(train,3,1,2,0,1,1,36,no.constant=TRUE);final
#as i evident from the ljung-box statistics something is wrong:
plot(train,type='p')
lines(train+final$fit$residuals,col='red',type='l')
#alot of "spikes" where there is none in data.
#speculation: This could be because of how the GRACE data is constructed
#as a combination of values observed/and/or because of estimation of missing data
#being made with a method that regresses towards the mean where it shouldn't.

#it seems that it's the upturns (Greenland's winter) that the model has the hardest
#time predicting.

#nicer forecasting interface to R's predict.Arima
myPred<-sarima.for(train,length(test),3,1,2,0,1,1,36,no.constant=TRUE)
lines(test,col='green')

#standard auto fitter:
#this fails  -  could be a sign that
#arima without exogen factors can't model the data
stl(interpolated$V1)


# The key to similarity is not that terms happen to occur in the same document:
# it is that the terms happen to occur in the same context - that they have very similar neighbors.

build_tdm<-function(desc_tbl,desc_col,freq_col,vocabulary=NULL,weighted=TRUE){
	# Construct LSA space
	# Arguments
	# desc_tbl - dataframe which data will be used to construct the term document matrix
	# desc_col - a column in the desc_tbl dataframe containing the test used for term document construction
	# freq_col - a column in the desc_tbl dataframe containing the frequencies of the respected rows
	# vocabulary - either null for initial construction or the existing vocabulary for adding documents to the existing matrix
	# weighted - logical value indicating whether tf-idf weighting should be applied
	MINWORDLENGTH<-2
	WORDSTOEXCLUDE<-c("a","the","this","these","their","that","those","then","and","an","as","over","with","within","without","when","why","how","in",
	"on","of","or","to","by","from","for","at","so","then","thus","here","there")
	#library(LSAfun)
	library(text2vec)
	library(data.table)
	library(plyr)
	myList<-list()
	# Construct terms/documents matrix based on a given set of documents or read it from the file
	s<-breakdown(str_replace_all(desc_tbl[[desc_col]],"[^[:graph:]]", " "))
	it <- itoken(s, preprocess_function = tolower,tokenizer = word_tokenizer, chunks_number = 10, progessbar = F)
	if(is.null(vocabulary)){
		vocab<-create_vocabulary(it,stopword=WORDSTOEXCLUDE,ngram=c(ngram_min=1L,ngram_max=1L))
	}else{
		vocab<-vocabulary
	}
	vocab<-vocab[nchar(vocab$term) >= 2,]
	myList[[1]]<-vocab
	vectorizer = vocab_vectorizer(vocab)
	dtm = create_dtm(it, vectorizer)
	myMatrix<-as.textmatrix(t(as.matrix(dtm)))
	colnames(myMatrix)<-paste0("D",seq(1,ncol(myMatrix)))

	# apply tfidf weights to the terms/documents matrix
	if(weighted){
		myMatrix<-apply_tfidf(myMatrix)
		# Adjustment for different descriptions based on frequency
		cmd<-paste0("v<-as.numeric(desc_tbl$",freq_col,")")
		eval(parse( text=cmd ))
		v2 <- rep(v,each=dim(myMatrix)[1])
		myMatrix<-myMatrix*v2
	}

	# aggregate concept descriptions documents for each column into a single document
	# setDT(desc_tbl)[,freq := .N, by = c("Original_Column")]
	# freq<-desc_tbl[!duplicated(desc_tbl$Original_Column),]

	# Aggregate scores and compute count
	freq<-count(desc_tbl$Original_Column)
	names(freq)[1]<-"Original_Column"
	freq1<-aggregate(desc_tbl$score,list(desc_tbl$Original_Column),sum)
	names(freq1)[1]<-"Original_Column"
	freq<-merge(freq,freq1,by.x="Original_Column",by.y="Original_Column")
	names(freq)[3]<-"score"

	m<-nrow(myMatrix)
	tm<-matrix(nrow=m,ncol=0)
	n<-nrow(freq)
	end<-0
	for(i in 1:n){
		start<-as.integer(end+1)
		end<-as.integer(start+freq[i,"freq"]-1)
		if(start == end){
			doc<-myMatrix[,start]
		}else{
			cmd<-paste0("doc<-rowSums(myMatrix[,",start,":",end,"])")
			eval(parse( text=cmd ))
		}
		tm<-cbind(tm,doc)
	}
	colnames(tm)<-paste0("D",seq(1:n))

	myList[[2]]<-tm
	gc()
	return(myList)
}

apply_tfidf<-function(matrix){
	# Compute tfidf weights and apply them to a given terms/documents matrix
	# Arcguments
	# matrix - a term document matrix to which tf-idf weighing should be applied

	totals<-colSums(matrix)
	totals[totals==0]=1
	tfidf_matrix<-matrix/totals*gw_idf(matrix)
	tfidf_matrix[is.nan(tfidf_matrix)]=0

	# Alternative weighting
	# tfidf_matrix<-lw_logtf(matrix)*gw_idf(matrix)

	return(tfidf_matrix)
}

lsi_mgr<-function(lookup_tbl,desc_col,freq_col,share=SHARE,filename_lsa=LSA_filename,weighted=TRUE){
	# build LSA space
	# Arguments
	# lookup_tbl - a dataframe which data will be used to construct the term document matrix
	# desc_col - a column in the desc_tbl dataframe containing the test used for term document construction
	# freq_col - a column in the desc_tbl dataframe containing the frequencies of the respected rows
	# share - share of eigenvalues to retain
	# filename_lsa - the name of the file to save LSA space and its vocabulary
	# weighted - logical value indicating whether tf-idf weighting should be applied

	SHARE<-0.8
	LSA_filename<-"column-desc-set-lsa"
	library(lsa)
	# Construct term document matrix
	myList<-build_tdm(lookup_tbl,desc_col,freq_col,NULL,weighted)
	myVocabulary<-myList[[1]]
	myMatrix<-myList[[2]]
	# Build LSa space
	if(share == 1){
		myLSAspace = lsa(myMatrix, dims=dimcalc_raw())
	}else{
		myLSAspace = lsa(myMatrix, dims=dimcalc_share(share))
	}
	saveRDS(myLSAspace, paste0(filename_lsa,".rds"))
	saveRDS(myVocabulary, paste0(filename_lsa,"-vocab.rds"))
	rm(myLSAspace,myVocabulary,myList)
}

match_desc<-function(terms, desc){
	# mapping query terms to LSI terms
	# Arguments
	# terms - the terms in the vocabulary
	# the existing words that needs to be mapped

	library(stringdist)
	o<-count(desc)
	colnames(o)[1]<-"desc"
	o$desc<-as.character(o$desc)
	v_terms<-terms[terms %in% o$desc]
	r1<-o[o$desc %in% v_terms,]
	gc()
	return(r1)
}

build_query_tdm<-function(lookup_tbl,myLSAspace,myVocabulary,desc_col="Concept_Description",freq_col="Prob",weighted=TRUE){
	# Construct from query concept descriptions a matrix in the LSA space (newer and faster method)
	# Arguments
	# lookup_tbl - a dataframe containing new documents
	# myLSAspace - the existing LSA space
	# myVocabulary - the existing vocabulary
	# desc_col - a column in the desc_tbl dataframe containing the test used for term document construction
	# weighted - logical value indicating whether tf-idf weighting should be applied
	#library(LSAfun)
	library(text2vec)

	tk<-myLSAspace$tk
	sk<-myLSAspace$sk
	dk<-myLSAspace$dk
	n<-nrow(dk)

	# Construct additional docs term document matrix
	s<-breakdown(as.character(lookup_tbl[[desc_col]]))
	it <- itoken(s, preprocess_function = tolower,tokenizer = word_tokenizer, chunks_number = 10, progessbar = F)
	vectorizer = vocab_vectorizer(myVocabulary)
	dtm = create_dtm(it, vectorizer)
	myMatrix<-as.textmatrix(t(as.matrix(dtm)))

	if(weighted){
		myMatrix<-apply_tfidf(myMatrix)
		# Adjustment for different descriptions based on frequency
		cmd<-paste0("v<-as.numeric(lookup_tbl$",freq_col,")")
		eval(parse( text=cmd ))
		v2 <- rep(v,each=dim(myMatrix)[1])
		myMatrix<-myMatrix*v2
	}
	tm<-rowSums(myMatrix)

	# Map new docs into the existing LSa space
	s<-diag(sk)
	q<-t(tm) %*% as.matrix(tk) %*% solve(s)
	# Extend existing LSA space with new docs
	return(q)
}

build_query_doc<-function(df,myLSAspace,descname="Concept_Description",freqname="Prob",weighted=TRUE){
	# Construct from query concept descriptions a matrix in the LSA space (original method)
	# Arguments
	# df - a new column concept description dataframe
	# descname - the name of the column with concept description
	# freqname - the column name with the probability of the respected concept
	# weighted - default the we are using tf-idf weighting (TRUE)
	library(lsa)
	library(plyr)
	tk<-myLSAspace$tk
	dk<-myLSAspace$dk
	sk<-myLSAspace$sk

	terms<-rownames(tk)
	n<-nrow(df)
	m<-length(terms)
	q_matrix<-matrix(0,ncol=m,nrow=0)
	for(i in 1:n){
		# parse a given item
		item<-as.character(df[i,descname])
		desc<-tolower(unlist(strsplit(item," ")))
		# map the item to actual terms in case it is not exact match to terms
		o<-match_desc(terms,desc)
		if(nrow(o) > 0){
			# calculate query terms frequency
			o$tf<-o$freq/sum(o$freq)
			w<-ifelse(terms %in% o$desc, o$tf, 0)
			# query in original coordinates
			q<-ifelse(terms %in% desc, 1, 0)
			# if weighted apply term frequency
			if(weighted) {
				q<-q*w*as.numeric(df[i,freqname])
				q_matrix<-rbind(q_matrix,q)
			}
		}
	}
	# weighted query in old coordinates
	q<-colSums(q_matrix)
	# express query in new coordinates
	# diagonal eigenvalues matrix
	s<-diag(sk)
	q<-t(q) %*% as.matrix(tk) %*% solve(s)
	return(q)
}

get_similar_doc<-function(column,lookup_tbl,q_doc,myLSAspace,margin=0.01,low_limit=0.5,orig_col="Original_Column"){
	# Identify the most similar documents
	# Arguments
	# column - the name of column that matches the original one
	# lookup_tbl - the original lookup table
	# q_doc query document
	# myLSAspace LSI environment
	# margin - the range of similarity to keep documents compare with the best match
	# low_limit - the lowest level for the document similarity
	# orig_column - the name of original column for which we are searching for matches
	library(lsa)
	library(data.table)
	dk<-myLSAspace$dk
	m<-nrow(dk)
	v<-vector()
	for(i in 1:m){
		v[i]<-cosine(as.double(q_doc),as.double(dk[i,]))
	}
	v[is.nan(v)]=0
	r<-max(v)
	row<-which(v>(max(v)-margin) & v>low_limit)

	z<-data.table(Selected_Column=character(),Joined_Column=character(),Similarity=numeric());
	size<-length(row)
	if(size>0){
		for(i in 1:size){
			nbr<-as.integer(substring(rownames(dk)[row[i]],2))
			cmd<-paste0("exist_col<-as.character(lookup_tbl[nbr,\"",orig_col,"\"])")
			eval(parse( text=cmd ))
			z<-rbindlist(list(z,list(column,exist_col,v[row[i]])))
		}
		z<-z[order(-z$Similarity),]
	}
	rm(dk,size,m,v,r,row)
	return(z)

}

breakdown <- function(x){

  x <- tolower(x)

  ## Umlaute

  x <- gsub(x=x,pattern="\xe4",replacement="ae")
  x <- gsub(x=x,pattern="\xf6",replacement="oe")
  x <- gsub(x=x,pattern="\xfc",replacement="ue")

  ## Accents

  x <- gsub(x=x,pattern="\xe0",replacement="a")
  x <- gsub(x=x,pattern="\xe1",replacement="a")
  x <- gsub(x=x,pattern="\xe2",replacement="a")

  x <- gsub(x=x,pattern="\xe8",replacement="e")
  x <- gsub(x=x,pattern="\xe9",replacement="e")
  x <- gsub(x=x,pattern="\xea",replacement="e")

  x <- gsub(x=x,pattern="\xec",replacement="i")
  x <- gsub(x=x,pattern="\xed",replacement="i")
  x <- gsub(x=x,pattern="\xee",replacement="i")

  x <- gsub(x=x,pattern="\xf2",replacement="o")
  x <- gsub(x=x,pattern="\xf3",replacement="o")
  x <- gsub(x=x,pattern="\xf4",replacement="o")

  x <- gsub(x=x,pattern="\xf9",replacement="u")
  x <- gsub(x=x,pattern="\xfa",replacement="u")
  x <- gsub(x=x,pattern="\xfb",replacement="u")

  x <- gsub(x=x,pattern="\xdf",replacement="ss")

  ## Convert to ASCII

  x <- iconv(x,to="ASCII//TRANSLIT")

  ## Punctation, Numbers and Blank lines

  x <- gsub(x=x,pattern="[[:punct:]]", replacement=" ")
  x <- gsub(x=x,pattern="[[:digit:]]", replacement=" ")
  x <- gsub(x=x,pattern="\n", replacement=" ")
  x <- gsub(x=x,pattern="\"", replacement=" ")

  return(x)
}


solve <- function(arr){
    count_unique <- function(arr) length(unique(arr))
    prod( sapply(arr, count_unique) )
}


subroutine dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bpt,nedge)

# Get a point ***inside*** the rectangular window on the ray from
# one circumcentre to the next one.  I.e. if the `next one' is
# inside, then that's it; else find the intersection of this ray with
# the boundary of the rectangle.
# Called by dirseg, dirout.

implicit double precision(a-h,o-z)
dimension rw(4)
logical intfnd, bpt, rwu

# Note that (a,b) is the circumcentre of a Delaunay triangle,
# and that slope is the slope of the ray joining (a,b) to the
# corresponding circumcentre on the opposite side of an edge of that
# triangle.  When `dldins' is called by `dirout' it is possible
# for the ray not to intersect the window at all.  (The Delaunay
# edge between the two circumcentres might be connected to a `fake
# outer corner', added to facilitate constructing a tiling that
# completely covers the actual window.)  The variable `intfnd' acts
# as an indicator as to whether such an intersection has been found.

# The variable `bpt' acts as an indicator as to whether the returned
# point (ai,bi) is a true circumcentre, inside the window (bpt == .false.),
# or is the intersection of a ray with the boundary of the window
# (bpt = .true.).

intfnd = .true.
bpt = .true.

# Dig out the corners of the rectangular window.
xmin = rw(1)
xmax = rw(2)
ymin = rw(3)
ymax = rw(4)

# Check if (a,b) is inside the rectangle.
if(xmin<=a&a<=xmax&ymin<=b&b<=ymax) {
        ai = a
        bi = b
	bpt = .false.
        nedge = 0
        return
}

# Look for appropriate intersections with the four lines forming
# the sides of the rectangular window.

# If not "the right way up" then the line joining the two
# circumcentres is vertical.

if(!rwu) {
    if(b < ymin) {
            ai = a
            bi = ymin
            nedge = 1
            if(xmin<=ai&ai<=xmax) return
    }
    if(b > ymax) {
            ai = a
            bi = ymax
            nedge = 3
            if(xmin<=ai&ai<=xmax) return
    }
    intfnd = .false.
    return
}

# Line 1: x = xmin.
if(a<xmin) {
        ai = xmin
        bi = b + slope*(ai-a)
        nedge = 2
        if(ymin<=bi&bi<=ymax) return
}

# Line 2: y = ymin.
if(b<ymin) {
        bi = ymin
        ai = a + (bi-b)/slope
        nedge = 1
        if(xmin<=ai&ai<=xmax) return
}

# Line 3: x = xmax.
if(a>xmax) {
        ai = xmax
        bi = b + slope*(ai-a)
        nedge = 4
        if(ymin<=bi&bi<=ymax) return
}

# Line 4: y = ymax.
if(b>ymax) {
        bi = ymax
        ai = a + (bi-b)/slope
        nedge = 3
        if(xmin<=ai&ai<=xmax) return
}

intfnd = .false.
return
end


## ----knitr-setup---------------------------------------------------------
# knitr::opts_chunk$set(message = FALSE)

## ----setup, message = FALSE----------------------------------------------
library(plyr)
library(dplyr)
library(magrittr)
library(lubridate)
library(ggplot2)
library(devtools)

load_all()

# source("inst/scripts/1-load-and-clean.R", verbose = TRUE)
data(sos_raw)

sosid <- paste0("SOS", 1:nrow(sos_raw))

date_created <- clean_date_created(sos_raw)
date_terminated <- clean_date_terminated(sos_raw)

## ----create-interval-----------------------------------------------------
sos_dates <- data.frame(date_created, date_terminated)
sos_dates$active_interval <- new_interval(sos_dates$date_created, sos_dates$date_terminated)

## ----create-time-series--------------------------------------------------
sum_active_systems_for_year <- function(year, intervals) {
  sum(year %within% intervals, na.rm = TRUE)
}

time_series <- data.frame(year = parse_date_time(1900:2015, orders = "y"))

time_series$number_active <- sapply(time_series$year,
                                    sum_active_systems_for_year,
                                    intervals = sos_dates$active_interval)

# # We could also run this:
# time_series %>%
#   group_by(year) %>%
#   mutate(number_active = sum(year %within% sos_dates$active_interval, na.rm = TRUE)) %>%
#   ungroup()

## ----initial-plots-------------------------------------------------------
# Quick-and-dirty qplot.
qplot(x = year, y = number_active, data = time_series, geom = "line")

# Cleaner plot using ggplot().
ggplot(time_series, aes(x = year, y = number_active)) + geom_line() + theme_bw() + labs(x = "Year", y = "Count of Active Systems", title = "Number of Active Surveillance Systems over Time")

# With number of systems on a log scale.
ggplot(time_series, aes(x = year, y = number_active)) + geom_line() + theme_bw() + labs(x = "Year", y = "Count of Active Systems (log scale)", title = "Number of Active Surveillance Systems over Time") + scale_y_log10()

## ----entity-type---------------------------------------------------------
sos_dates$entity_type <- clean_entity_type(sos_raw, return_type = "factor")

time_series_entity <- expand.grid(year = time_series$year, entity_type = levels(sos_dates$entity_type))

time_series_entity %<>%
  group_by(entity_type, year) %>%
  mutate(number_active = sum_active_systems_for_year(year,
                                                     sos_dates[sos_dates$entity_type == entity_type,
                                                               "active_interval"])) %>%
  ungroup()

## ----time-series-by-entity-type------------------------------------------
ggplot(time_series_entity, aes(x = year, y = number_active, fill = entity_type, color = entity_type, order = desc(entity_type))) +
  geom_area() +
  theme_bw() +
  labs(x = "Year", y = "Count of Active Systems", title = "Number of Active Surveillance Systems over Time by Entity Type (area)")

ggplot(time_series_entity, aes(x = year, y = number_active, fill = entity_type, color = entity_type, order = desc(entity_type))) +
  geom_area() +
  theme_bw() +
  labs(x = "Year", y = "Count of Active Systems", title = "Number of Active Surveillance Systems over Time by Entity Type (area)")

ggplot(time_series_entity, aes(x = year, y = number_active, fill = entity_type, color = entity_type, order = desc(entity_type))) +
  geom_area(position = "fill") +
  theme_bw() +
  labs(x = "Year", y = "Count of Active Systems", title = "Number of Active Surveillance Systems over Time by Entity Type (area)")

ggplot(time_series_entity, aes(x = year, y = number_active, fill = entity_type, color = entity_type, order = desc(entity_type))) +
  geom_area(position = "identity", alpha = 0.25) +
  theme_bw() +
  labs(x = "Year", y = "Count of Active Systems", title = "Number of Active Surveillance Systems over Time by Entity Type")

ggplot(time_series_entity, aes(x = year, y = number_active, fill = entity_type, color = entity_type, order = desc(entity_type))) +
  geom_area(position = "identity", alpha = 0.25) +
  theme_bw() +
  scale_y_log10() +
  labs(x = "Year", y = "Count of Active Systems", title = "Number of Active Surveillance Systems over Time by Entity Type")

ggplot(time_series_entity, aes(x = year, y = number_active, fill = entity_type, color = entity_type, order = desc(entity_type))) +
  geom_line() +
  theme_bw() +
  labs(x = "Year", y = "Count of Active Systems", title = "Number of Active Surveillance Systems over Time by Entity Type (line)")

ggplot(time_series_entity, aes(x = year, y = number_active, fill = entity_type, color = entity_type, order = desc(entity_type))) +
  geom_line() +
  theme_bw() +
  scale_y_log10() +
  labs(x = "Year", y = "Count of Active Systems (log-transformed)", title = "Number of Active Surveillance Systems over Time by Entity Type (line)")

## ----date-created--------------------------------------------------------
library(reshape2)
qplot(year(sos_dates$date_created), binwidth = 1)
qplot(year(sos_dates$date_terminated), binwidth = 1)

date_hist <- data.frame(sosid, select(sos_dates, date_created, date_terminated)) %>%
  melt(id.vars = "sosid") %>%
  mutate(year = year(value)) %>%
  filter(year != 2015, year >= 1950)

ggplot() +
  geom_histogram(data = filter(date_hist, variable == "date_created"),
                 mapping = aes(x = year, y = ..count.., fill = "Created"), binwidth = 1) +
  geom_histogram(data = filter(date_hist, variable == "date_terminated"),
                 mapping = aes(x = year, y = -..count.., fill = "Terminated"), binwidth = 1) +
  scale_fill_hue("Group") + theme_bw() +
  labs(x = "Year", y = "Number of Surveillance Systems", title = "Number of Surveillance Systems Created and Terminated")
# ggsave(file = "inst/out/Number of Surveillance Systems Created and Terminated.pdf", width = 6.5, height = 4.5)
# ggsave(file = "inst/out/Number of Surveillance Systems Created and Terminated.png", width = 6.5, height = 4.5)

date_hist2 <- date_hist %>%
  group_by(year, variable) %>%
  summarize(count = n()) %>%
  dcast(year ~ variable)

years_not_in_df <- seq(1950, 2014)[!seq(1950, 2014) %in% date_hist2$year]

date_hist2 <- rbind(date_hist2, data.frame(year = years_not_in_df, date_created = NA, date_terminated = NA))

date_hist2[is.na(date_hist2)] <- 0

ggplot(data = date_hist2, aes(x = year)) +
  geom_bar(aes(y = date_created), stat = "identity", fill = "#F8766D") +
  geom_bar(aes(y = -date_terminated), stat = "identity", fill = "#00BFC4") +
  geom_line(aes(y = date_created - date_terminated), size = 0.5) +
  theme_bw() +
  labs(x = "Year", y = "Number of Surveillance Systems", title = "Number of Surveillance Systems Created and Terminated")
# ggsave(file = "inst/out/Number of Surveillance Systems Created and Terminated (with over-under line).pdf", width = 6.5, height = 4.5)
# ggsave(file = "inst/out/Number of Surveillance Systems Created and Terminated (with over-under line).png", width = 6.5, height = 4.5)

ggplot() +
  geom_histogram(data = filter(date_hist, variable == "date_created"),
                 mapping = aes(x = year, y = ..count.., fill = "Created"), binwidth = 1) +
  geom_histogram(data = filter(date_hist, variable == "date_terminated"),
                 mapping = aes(x = year, y = -..count.., fill = "Terminated"), binwidth = 1) +
  geom_line(data = time_series, mapping = aes(x = year(year), y = number_active)) +
  scale_fill_hue("Group") + theme_bw() +
  labs(x = "Year", y = "Number of Surveillance Systems", title = "Number of Surveillance Systems Created and Terminated")


conv <- function(y,m,d,t) {
  date_str <- paste(m,"/", d, "/", y, " ", sep="")
  time_str <- paste(t, ":00", sep="")
  date <- chron(date_str, time_str)
  as.POSIXct(date, tz="GMT")
}

read_bigf <- function(filename) {
 z <- read.zoo(filename, index=2:5, FUN = conv)
 names(z) <- c("station_id", "ztd", "zwd", "iwv")

 # Remove IWVs less than or equal to 0
 z <- z[!z$iwv <= 0]

 # Filter to remove outliers
 # (outliers defined as points outside +- 3 SDs)
 above_low_threshold = z$iwv > mean(z$iwv) - 3*sd(z$iwv)
 above_high_threshold = z$iwv < mean(z$iwv) + 3*sd(z$iwv)

 z <- z[above_low_threshold & above_high_threshold]

 return(z)
}

data_for_time <- function(filename, date_string) {
  z <- read_bigf(filename)
  x <- as.xts(z)
  #val <- c(substr(filename, 0, 4), x["2006-06-17 12:00:00"]$iwv)
  subs <- x[date_string]
  if (length(subs) == 0) {
    val <- NA
  }
  else
  {
    val <- subs$iwv[[1]]
  }
  name <- substr(filename, 0, 4)
  print(paste(name, val, sep=","))
  return(data.frame(station=name, iwv=val))
}