library(plyr)

spottings <- list.files(path="spottings")

spottings <- strsplit(spottings, "\\.")
spottings <- laply(spottings, function(x) x[1])

get_id <- function(spotting) {
  keys <- strsplit(spotting, '')[[1]]
  # Components
  keysize <- length(keys)
  major <- as.numeric(paste(keys[1:(keysize-6)], collapse=""))
  minor <- as.numeric(paste(keys[(keysize-5):(keysize-4)], collapse=""))
  magic <- as.numeric(paste(keys[(keysize-3):keysize], collapse=""))
  # Wrap things up and return
  data.frame(M = major, m = minor, k = magic)
}

ids <- adply(spottings, 1, get_id)


# average LD within windows and calculate change through time
# for ngsLD output (ANGSD-called loci)
# run after ngsLD_bypop.sh

######################
# calculate LD change
# run on saga
######################
#srun --ntasks=1 --mem-per-cpu=30G --time=00-02:00:00 --qos=devel --account=nn9244k --pty bash -i # need more memory
#module load R/3.6.2-foss-2019b
#R

require(data.table)

width <- 5e4; stp <- 1e4; windsz='5e4'; windnm='50kb' # window parameters. first two are numeric, second two for naming

# read in nodam2 list of loci
nodam2 <- fread('data_2020.05.07/GATK_filtered_SNP_no_dam2.tab') # list of loci that pass nodam2 filter
setnames(nodam2, c('CHROM', 'POS', 'REF', 'ALT'))
nodam2[, posnm := paste0(CHROM, ':', POS), by = 1:nrow(nodam2)]

# read in data (gatk loci only). files from ngsLD_bypop.sh
datCan40 <- fread('analysis/ld.Can_40.gatk.gz')
datCan14 <- fread('analysis/ld.Can_14.gatk.gz')
dat07 <- fread('analysis/ld.Lof_07.gatk.gz')
dat11 <- fread('analysis/ld.Lof_11.gatk.gz')
dat14 <- fread('analysis/ld.Lof_14.gatk.gz')

# add column names
nms <- c('pos1nm', 'pos2nm', 'dist', 'r2', 'D', 'Dprime', 'r2em')
setnames(datCan14, nms)
setnames(datCan40, nms)
setnames(dat14, nms)
setnames(dat11, nms)
setnames(dat07, nms)

# trim to nodam2
nrow(datCan40)
datCan40 <- datCan40[pos1nm %in% nodam2$posnm & pos2nm %in% nodam2$posnm, ]
nrow(datCan40)

nrow(datCan14)
datCan14 <- datCan14[pos1nm %in% nodam2$posnm & pos2nm %in% nodam2$posnm, ]
nrow(datCan14)

nrow(dat07)
dat07 <- dat07[pos1nm %in% nodam2$posnm & pos2nm %in% nodam2$posnm, ]
nrow(dat07)

nrow(dat11)
dat11 <- dat11[pos1nm %in% nodam2$posnm & pos2nm %in% nodam2$posnm, ]
nrow(dat11)

nrow(dat14)
dat14 <- dat14[pos1nm %in% nodam2$posnm & pos2nm %in% nodam2$posnm, ]
nrow(dat14)

# make a chromosome column
datCan40[, chr := vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 1)]
datCan14[, chr := vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 1)]
dat07[, chr := vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 1)]
dat11[, chr := vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 1)]
dat14[, chr := vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 1)]

# make position columns
datCan40[, pos1 := as.numeric(vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 2))]
datCan40[, pos2 := as.numeric(vapply(strsplit(pos2nm, ":", fixed = TRUE), "[", "", 2))]
datCan14[, pos1 := as.numeric(vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 2))]
datCan14[, pos2 := as.numeric(vapply(strsplit(pos2nm, ":", fixed = TRUE), "[", "", 2))]
dat07[, pos1 := as.numeric(vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 2))]
dat07[, pos2 := as.numeric(vapply(strsplit(pos2nm, ":", fixed = TRUE), "[", "", 2))]
dat11[, pos1 := as.numeric(vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 2))]
dat11[, pos2 := as.numeric(vapply(strsplit(pos2nm, ":", fixed = TRUE), "[", "", 2))]
dat14[, pos1 := as.numeric(vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 2))]
dat14[, pos2 := as.numeric(vapply(strsplit(pos2nm, ":", fixed = TRUE), "[", "", 2))]

# round pos1 and pos2 to nearest window midpoint, once for each step in width
chroms <- datCan40[, sort(unique(chr))]
for(j in 1:(width/stp)){
	nm <- paste('pos1mid', j, sep='') # create column name
	dat14[, eval(nm) := floor((pos1 + (j-1)*stp)/width)*width + (j-1)*stp + width/2]
	dat11[, eval(nm) := floor((pos1 + (j-1)*stp)/width)*width + (j-1)*stp + width/2]
	dat07[, eval(nm) := floor((pos1 + (j-1)*stp)/width)*width + (j-1)*stp + width/2]
	datCan40[, eval(nm) := floor((pos1 + (j-1)*stp)/width)*width + (j-1)*stp + width/2]
	datCan14[, eval(nm) := floor((pos1 + (j-1)*stp)/width)*width + (j-1)*stp + width/2]

	nm <- paste('pos2mid', j, sep='') # create column name
	dat14[, eval(nm) := floor((pos2 + (j-1)*stp)/width)*width + (j-1)*stp + width/2]
	dat11[, eval(nm) := floor((pos2 + (j-1)*stp)/width)*width + (j-1)*stp + width/2]
	dat07[, eval(nm) := floor((pos2 + (j-1)*stp)/width)*width + (j-1)*stp + width/2]
	datCan40[, eval(nm) := floor((pos2 + (j-1)*stp)/width)*width + (j-1)*stp + width/2]
	datCan14[, eval(nm) := floor((pos2 + (j-1)*stp)/width)*width + (j-1)*stp + width/2]
}
posnms <- grep('pos[[:digit:]]mid', colnames(dat14), value=TRUE) # get column names created, to check
	posnms

# calculate average LD within regions
bins14 <- dat14[!is.na(r2) & pos1mid1 == pos2mid1, .(r2ave_14 = mean(r2), r2n_14 = .N), by = .(chr, pos1mid1)]
bins11 <- dat11[!is.na(r2) & pos1mid1 == pos2mid1, .(r2ave_11 = mean(r2), r2n_11 = .N), by = .(chr, pos1mid1)]
bins07 <- dat07[!is.na(r2) & pos1mid1 == pos2mid1, .(r2ave_07 = mean(r2), r2n_07 = .N), by = .(chr, pos1mid1)]
binsCan40 <- datCan40[!is.na(r2) & pos1mid1 == pos2mid1, .(r2ave_Can40 = mean(r2), r2n_Can40 = .N), by = .(chr, pos1mid1)]
binsCan14 <- datCan14[!is.na(r2) & pos1mid1 == pos2mid1, .(r2ave_Can14 = mean(r2), r2n_Can14 = .N), by = .(chr, pos1mid1)]

setkey(bins14, chr, pos1mid1)
setkey(bins11, chr, pos1mid1)
setkey(bins07, chr, pos1mid1)
setkey(binsCan40, chr, pos1mid1)
setkey(binsCan14, chr, pos1mid1)

# merge
bins <- merge(bins14, bins11, by=c('chr', 'pos1mid1'), all=TRUE)
bins <- merge(bins, bins07, by=c('chr', 'pos1mid1'), all=TRUE)
bins <- merge(bins, binsCan40, by=c('chr', 'pos1mid1'), all=TRUE)
bins <- merge(bins, binsCan14, by=c('chr', 'pos1mid1'), all=TRUE)

nrow(bins)

# add BIN_START
bins[,BIN_START:=pos1mid1 - width/2]

# calculate change
bins[, ld_diff_Lof0711 := r2ave_11 - r2ave_07]
bins[, ld_diff_Lof0714 := r2ave_14 - r2ave_07]
bins[, ld_diff_Lof1114 := r2ave_14 - r2ave_11]
bins[, ld_diff_Can := r2ave_Can14 - r2ave_Can40]

# save region means data
filenm <- paste('analysis/ld_change_region_', windsz, '_ngsLD.gatk.csv.gz', sep='')
filenm
write.csv(bins, file = gzfile(filenm), row.names = FALSE)

###########################################
# plot LD change from regions
# run on laptop
###########################################
require(data.table)
require(RColorBrewer)
require(ggplot2)

# read in
bins <- fread('analysis/ld_change_region_5e4_ngsLD.gatk.csv.gz'); width='5e4'

# add genome position
chrmax <- fread('data/lg_length.csv')
chrmax[, start := c(0,cumsum(chrmax$len)[1:(nrow(chrmax)-1)])]
bins <- merge(bins, chrmax[, .(chr, start)], by = 'chr')
bins[, POSgen := BIN_START + start + as.numeric(width)/2]

# long format for plotting
binsl <- melt(bins[, .(chr, POSgen, ld_diff_Can, ld_diff_Lof0711, ld_diff_Lof0714, ld_diff_Lof1114)], id.vars = c('chr', 'POSgen'), variable.name = 'pop', value.name = 'ldchange')
binsl[, pop := gsub('ld_diff_', '', pop)]

# plot
cols <- brewer.pal(4, 'Paired')[rep(1:2,12)]
p1 <- ggplot(binsl, aes(POSgen, ldchange, color = chr)) +
  geom_point(size = 0.5, alpha = 0.3) +
  facet_wrap(~pop, ncol = 1, scales = 'free') +
  scale_color_manual(values = cols)
p1
ggsave(plot = p1, device = 'png', filename = paste0('figures/ld_change_vs_pos_NEA_CAN_runmean', width, '_ngsLD.gatk.png'),
       width = 7.5, height = 6, units = 'in', dpi = 300)


require(graphics)
require(Matrix)

pdf(file="plots/Experiment5b.pdf",
  width=3.7, height=4.0, family="serif", pointsize=14)

data = as.matrix(read.table("results/Experiment5b_times.dat", sep=",")[3])/1000

plot_colors <- c("orangered","orange","cornflowerblue")

barplot( data,
         space = c(0.1,0.1),
         xlab = "",
         ylab = "",
         col=plot_colors,
         ylim = c(0,1350),
         log = "",
         axes = FALSE,
         names.arg = c("MT-Ops","","Dist-PFor"),
         args.legend = list(x="topleft", bty="n", bty="n", ncol=1),
         beside = TRUE,
)

axis(2, las=1)
mtext(2,text="Execution Time [s]",line=2.8)
mtext(1,text="MT-PFor",line=0.2)
mtext(1,text="Parallel Configurations",line=2)

text(2.73,800,"scale-out")
text(2.5,1200,"1x USCensus")

box()	              # box around plot
dev.off()


# Extract coordinates from CSV files into tile-based coordinate lists
# Input: training, validation and prediction CSVs
# Output: one CSV file per tile with X and Y coordinates per line in WGS84

library(foreach)
source("pixel-based/utils/ProbaVTileID.r")

# Input
CSVFiles = list.files("../data/pixel-based/raw-points", pattern=glob2rx("*.csv"), full.names = TRUE)
CSVs = lapply(CSVFiles, read.csv)

# Merge all from these columns
colnames_x = c("X", "x", "subpix_mean_x")
colnames_y = c("Y", "y", "subpix_mean_y")

XYDF = foreach(CSV = CSVs, .combine=rbind) %do%
{
    Xs = CSV[[colnames_x[colnames_x %in% names(CSV)]]]
    Ys = CSV[[colnames_y[colnames_y %in% names(CSV)]]]
    XYDF = data.frame(x = Xs, y = Ys)
    XYDF$Tiles = ProbaVTileID(XYDF)
    XYDF
}

# Now split into tiles and save each as a CSV with just the coordinates
# We will match them back also via coordinates (with some let due to loss of precision)

if (!dir.exists("../work/extract-from"))
    dir.create("../work/extract-from", recursive=TRUE)

XYTiles = split(XYDF[,1:2], XYDF$Tiles)

foreach(XYTileIndex = 1:length(XYTiles)) %do%
{
    write.table(XYTiles[[XYTileIndex]],
        paste0("../work/extract-from/", names(XYTiles[XYTileIndex]) , ".csv"),
        row.names = FALSE, col.names = FALSE)
}


./tests.verify: test performed on 2006.01.24

#### Test: ./tests.verify running Grid2D.py

x: [ 0.   0.5  1. ]
y: [ 0.   0.5  1. ] [[ 0.   1.   2. ]
 [ 0.5  1.5  2.5]
 [ 1.   2.   3. ]]

x: [ 0.   0.5  1. ]
y: [ 0.   0.5  1. ] [[ 0.   1.   2. ]
 [ 0.5  1.5  2.5]
 [ 1.   2.   3. ]]
CPU time of Grid2D.py: 0.4 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running Grid2Dit.py _verify1_Grid2Dit
interior point (1,1): (1,1)
boundary point (2,1): (2,1)
boundary point (1,2): (1,2)
boundary point (0,1): (0,1)
boundary point (1,0): (1,0)
corner point (0,0): (0,0)
corner point (2,0): (2,0)
corner point (2,2): (2,2)
corner point (0,2): (0,2)
any grid point (0,0): (0,0)
any grid point (1,0): (1,0)
any grid point (2,0): (2,0)
any grid point (0,1): (0,1)
any grid point (1,1): (1,1)
any grid point (2,1): (2,1)
any grid point (0,2): (0,2)
any grid point (1,2): (1,2)
any grid point (2,2): (2,2)
CPU time of Grid2Dit.py: 0.3 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running Grid2Dit.py _verify1_Grid2Ditv
interior points [1:2,1:2]
boundary points [2:3,1:2]
boundary points [1:2,2:3]
boundary points [0:1,1:2]
boundary points [1:2,0:1]
corners points [0:1,0:1]
corners points [2:3,0:1]
corners points [2:3,2:3]
corners points [0:1,2:3]
all points [0:3,0:3]
CPU time of Grid2Dit.py: 0.3 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running SparseVec.py
v[1]=0 v[7]=2.2
v[200] = 0.1; index (200) out of bounds (0:99)
v[7] = (1,2); only numbers can be assigned
SparseVec(100): {1: 0.15: 2.2}
CPU time of SparseVec.py: 0.1 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running cmlparsing.py -d mydir --confirm file1 file2 f3
options= [('-d', 'mydir'), ('--confirm', '')]
args= ['file1', 'file2', 'f3']
mydir True ['file1', 'file2', 'f3']
CPU time of cmlparsing.py: 0.3 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running copytypes.py
3
a is b: False
3
a.x=9, b_assign.x=9, b_shallow.x=-99, b_deep.x=-99
a.x=[8, 3], b_assign.x=[8, 3], b_shallow.x=[8, 3], b_deep.x=[-2, 3]
b_assign=[4, 3, 5, 999, x=-6]
b_shallow=[4, 3, 5, ['some string', 2], x=-6]
b_deep=[4, 3, 5, ['some string', 2], x=-9]
b_slice=[4, 3, 5, ['some string', 2], x=-6]

b_assign={'key2': ('str', 8, x=3), 'key1': 2}
b_shallow={'key2': ('str', 8, x=3), 'key1': -99}
b_deep={'key2': ('str', 8, x=-9), 'key1': -99}
CPU time of copytypes.py: 0.1 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running exceptions.py
recovered from any error...
recovered from IOError or ValueError
exceptions.ValueError invalid literal for float(): s
xcoor was successfully read from file [1.0, 1.1000000000000001, 1.2, 1.2, 1.3999999999999999, 1.5]
tmp.grid does not contain numbers only
invalid literal for float(): s
CPU time of exceptions.py: 0.1 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running funcwrap_test.py
constant: 2.0 WrapNo2Callable
string formula of x: 2.0 StringFunction
string formula of t: 2.0 StringFunction
string formula with parameters: 2.0 StringFunction
interpolate discrete data (at a grid point): 2.0
interpolate again (not at a grid point): 2.02 2.02
interpolation object type: WrapDiscreteData2Callable
user-defined function 2.0 function
user-defined anynomous lambda function: 2.0 function
user-defined class with __call__ method: 2.0 MyClass
3D string formula: 4.0 StringFunction
This is the formula: 1+2*x+3*y+4*z
Construction of instance: StringFunction('1+2*x+3*y+4*z', independent_variables=('x', 'y', 'z'), )
interpolate 3D discrete data: 4.0 WrapDiscreteData2Callable
CPU time of funcwrap_test.py: 0.3 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running integrate.py Simpson
integral of f(x)=2*x from -1 to 1 (=0): 0.0
f(0)=0
f(0.5)=1
f(1)=2
f(1)=2
f(1.5)=3
f(2)=4
integral of f(x)=2*x from 0 to 2 (=4): 4.0
CPU time of integrate.py: 0.1 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running integrate.py Trapezoidal
integral of f(x)=2*x from -1 to 1 (=0): 0.0
f(0)=0
f(1)=2
f(1)=2
f(2)=4
integral of f(x)=2*x from 0 to 2 (=4): 4.0
CPU time of integrate.py: 0.0 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running integrate.py GaussLegendre2
integral of f(x)=2*x from -1 to 1 (=0): 0.0
f(0.211325)=0.42265
f(0.788675)=1.57735
f(1.21132)=2.42265
f(1.78868)=3.57735
integral of f(x)=2*x from 0 to 2 (=4): 4.0
CPU time of integrate.py: 0.0 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running scope.py
main: globals= {'a': 1, 'f1': <function f1 at 0xb7ced33c>, 'C': <class __main__.C at 0xb7d081ac>, 'B': <class __main__.B at 0xb7d0817c>, 'f4': <function f4 at 0xb7ced454>, 'f': <function f at 0xb7ced224>, '__builtins__': <module '__builtin__' (built-in)>, '__file__': './scope.py', 'sys': <module 'sys' (built-in)>, 'f3': <function f3 at 0xb7ced41c>, '__name__': '__main__', '__doc__': None}
main: locals= {'a': 1, 'f1': <function f1 at 0xb7ced33c>, 'C': <class __main__.C at 0xb7d081ac>, 'B': <class __main__.B at 0xb7d0817c>, 'f4': <function f4 at 0xb7ced454>, 'f': <function f at 0xb7ced224>, '__builtins__': <module '__builtin__' (built-in)>, '__file__': './scope.py', 'sys': <module 'sys' (built-in)>, 'f3': <function f3 at 0xb7ced41c>, '__name__': '__main__', '__doc__': None}
f:  locals: {'a': 2, 'x': 10} local a: 2
global a: 1
None
locals: {'a': 4, 'self': <__main__.C instance at 0xb7cf118c>}
vars(self): {'a': 3}
self.a: 3
local a: 4 global a: 1
-1 1 3
-1 1 3
3 5
Hello, in f2 inside f1
Could not assign b in f2; it made b local to f2
exceptions.UnboundLocalError local variable 'b' referenced before assignment
Error occured at line 48
Hello, in f2 inside f3
4
Hello, in f2 inside f1
b in if b block: 3
b in f2: 3
b in f4 2
CPU time of scope.py: 0.0 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running type.py
removing directory tmp_1
removing directory tmp_0
removing directory tmp_2
removing directory tmp_3
removing directory tmp_4
removing directory tmp_5
removing directory tmp_6
removing directory tmp_7
removing directory tmp_8
removing directory tmp_9
removing file tmp__0
removing file tmp__1
removing file tmp__2
removing file tmp__3
removing file tmp__4
removing file tmp__5
removing file tmp__6
removing file tmp__7
removing file tmp__8
removing file tmp__9
text is <type 'str'> <type 'basestring'>
1.28736 is <type 'float'>
['sub', 'list'] is <type 'list'>
{'heterogeneous': 1, 'sub': 'dictionary'} is <type 'dict'>
('some', 'sub', 'tuple') is <type 'tuple'>
888 is (<type 'int'>, <type 'long'>)
<__main__.MyClass instance at 0xb7db2fec> is __main__.MyClass
text is <type 'str'>
1.28736 is <type 'float'>
['sub', 'list'] is <type 'list'>
{'heterogeneous': 1, 'sub': 'dictionary'} is <type 'dict'>
('some', 'sub', 'tuple') is <type 'tuple'>
888 is <type 'int'>
<__main__.MyClass instance at 0xb7db2fec> is <type 'instance'>
text is <type 'str'>
1.28736 is <type 'float'>
['sub', 'list'] is <type 'list'>
{'heterogeneous': 1, 'sub': 'dictionary'} is <type 'dict'>
('some', 'sub', 'tuple') is <type 'tuple'>
888 is <type 'int'>
<__main__.MyClass instance at 0xb7db2fec> is <type 'instance'>
The next call should raise an exception:
Yes, got an exception:
remove() argument 1 must be a string or a list, not a <type 'module'>
CPU time of type.py: 0.1 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running typedlist.py
detected wrong type; items must be int, not float
detected wrong type; items must be A, not B
[1, 4, 3, 2, 9, 2, 3, 9, 2, 3]
detected wrong type; items must be int, not float
detected wrong type; items must be int, not A
CPU time of typedlist.py: 0.1 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running xdr.py
3.2 5 [1.0, 0.10000000000000001, 0.001]
CPU time of xdr.py: 0.0 seconds on ubuntu i686, Linux


import_package('dplyr', attach=TRUE)

#' Calculate the consensus ploidy state per chromosome across single cell models
#'
#' @param mods  List of AneuFinder models or GRanges objects
#' @return      Data.frame with fields: seqnames (chromosome name),
#'              length (chromosome length, coverage (% of chr covered by bins),
#'              and ploidy (average ploidy along chromosome)
consensus_ploidy = function(mods) {
    if (class(mods) != 'list')
        mods = list(mods)
    if (class(mods[[1]]) == "aneuHMM")
        mods = lapply(mods, function(m) m$segments)

    suppressWarnings(mods %>%
        lapply(as_tibble) %>%
        dplyr::bind_rows() %>%
        group_by(seqnames) %>%
        summarize(ploidy = weighted.mean(copy.number, width),
                  bases_covered = sum(as.numeric(width)) / length(mods)) %>%
        transmute(seqnames = as.character(seqnames),
                  length = unname(GenomeInfoDb::seqlengths(mods[[1]])[seqnames]),
                  coverage = bases_covered / length,
                  ploidy = ploidy))
}


## 9장. 데이터분석 프로젝트
"한국인의 삶을 파악해보자."
#### 09-1 '한국복지패널데이터 ####
# • 한국보건사회연구원 발간
# • 가구의 경제활동을 연구해 정책 지원에 반영할 목적
# • 2006~2015년까지 전국에서 7000여 가구를 선정해 매년 추적 조사
# • 경제활동, 생활실태, 복지욕구 등 수천 개 변수에 대한 정보로 구성

rm(list=ls())
## 09-1. ‘한국복지패널데이터’ 분석 준비하기 ---------------------------- ##
#install.packages("foreign")  # foreign 패키지 설치

library(foreign)             # SPSS 파일 로드
library(dplyr)               # 전처리
library(ggplot2)             # 시각화
library(readxl)              # 엑셀 파일 불러오기

# download : http://bit.ly/Koweps_hpc10_2015_v2

# 데이터 불러오기
raw_welfare <- read.spss(file = "Data/Koweps_hpc10_2015_beta1.sav",
                         to.data.frame = T)
View(raw_welfare[1:3,])
# 복사본 만들기
welfare <- raw_welfare

head(welfare)
tail(welfare)
View(welfare[1:3,])
dim(welfare) # 16664 957
str(welfare)
summary(welfare)

# p211. 직종코드집 참고하기: Data/Koweps_Codebook.xlsx
welfare <- rename(welfare,
                  sex = h10_g3,            # 성별
                  birth = h10_g4,          # 태어난 연도
                  marriage = h10_g10,      # 혼인 상태
                  religion = h10_g11,      # 종교
                  income = p1002_8aq1,     # 월급
                  code_job = h10_eco9,     # 직종 코드
                  code_region = h10_reg7)  # 지역 코드

welfare <- welfare %>% select(sex, birth, marriage,
                              religion, income, code_job,
                              code_region)

# rm(raw_welfare)
save(welfare, file="welfare.rData")
# 데이터 분석 절차 참고 p212

#### 09-2 성별에 따른 월급 차이 ####

## --"성별에 따라 월급이 다를까?"-------------------- ##
class(welfare$sex)
table(welfare$sex)

# 이상치 확인
table(welfare$sex)

# 이상치 결측 처리
welfare$sex <- ifelse(welfare$sex == 9, NA, welfare$sex)

# 결측치 확인
table(is.na(welfare$sex))

# 성별 항목 이름 부여: 코드 표 참조.
welfare$sex <- ifelse(welfare$sex == 1, "male", "female")
table(welfare$sex)
qplot(welfare$sex)

# - Quiz: sex를 factor로 바꾸어라. 이때 male을 1, female은 2로 코딩한다.
welfare$sex <- as.factor(welfare$sex)
welfare$sex <- factor(welfare$sex, levels = c('male','female'))
table(welfare$sex)
str(welfare$sex)

## ----- 월급 변수 검토 및 전처리 ----------------------------- ##
class(welfare$income)
summary(welfare$income)
qplot(welfare$income)
#install.packages("fBasics")
#library(fBasics)

#skewness(welfare$income, na.rm=T) # 보통 3 이내면 그냥 조정 안하고 분석해도 된다

qplot(welfare$income) + xlim(0, 1000)

# 이상치 확인
summary(welfare$income)
prop.table(table(is.na(welfare$income)))
prop.table(table(welfare$income == 0))

# 이상치 결측 처리: 월급이 없는 사람은 평균에서 제외해보자.
welfare$income <- ifelse(welfare$income %in% c(0, 9999), NA, welfare$income)
sum(welfare$income == 9999, na.rm=T) #이상치 잘 처리되었나 확인

# 결측치 확인
table(is.na(welfare$income))

names(welfare)

welfare$income

# 월급이 결측치인 사람들의 성별 비율을 계산해보자.
wf <- welfare %>% filter(is.na(income)) %>%
  group_by(sex) %>%
  summarise(n = n())

wf <- as.data.frame(wf)
wf$n <- wf$n / sum(wf$n)
wf

# 모든 데이터에 대한 성별비율은?
prop.table(table(welfare$sex))

## ---성별 월급 중간값 계산하기 ------------------------------- ##
sex_income <- welfare %>%
  filter(!is.na(income)) %>%
  group_by(sex) %>%
  summarise(mean_income = mean(income))

sex_income_med <- welfare %>%
  filter(!is.na(income)) %>%
  group_by(sex) %>%
  summarise(mean_income = median(income))

sex_income_med
sex_income

ggplot(data = sex_income, aes(x = sex, y = mean_income)) + geom_col()

#### 09-3 나이별 월급 ####

## -------"몇 살 때 월급을 가장 많이 받을까?"------- ##
head(welfare$birth)
class(welfare$birth)
summary(welfare$birth)
qplot(welfare$birth)

# 이상치 확인
summary(welfare$birth)

# 결측치 확인
table(is.na(welfare$birth))

# 이상치 결측 처리
welfare$birth <- ifelse(welfare$birth == 9999, NA, welfare$birth)
table(is.na(welfare$birth))
## birth에는 결측치가 없다.

## ----------- 파생변수 만들기 - 나이 ----------------- ##
welfare$age <- 2015 - welfare$birth + 1
summary(welfare$age)
qplot(welfare$age)

## --- 나이에 따른 월급 평균은? --------------- ##
age_income <- welfare %>% select(age, income) %>%
  filter(!is.na(income)) %>%
  group_by(age) %>%
  summarise(mean_income = mean(income))

head(age_income)

ggplot(data = age_income, aes(x = age, y = mean_income)) + geom_line()

# Quiz: 경제인구의 실업율을 구해보자.
# [20, 60] 응답이 0, 9999나온 데이터의 비율.
# - raw_welfare$p1002_8aq1에서 결측치는 "none"
# - 0은 "no"
# - 나머지는 "yes"로 설정한 후,
# - 20살에서 60살까지의 연령대에 대해 이에 대한 빈도수를 계산해보자.
#경제인구 실업률
unique(welfare$age)
n_datas<-as.numeric(count(work_pop))
n_datas
work_pop <- welfare %>% filter(age >=20 & age< 60)
work_pop %>% mutate(notworking = ifelse(is.na(income)|income ==0, 1,0)) %>%
  group_by(notworking) %>% filter(notworking ==1)%>%
  summarise(notwrk=n()/n_datas)

notwrk <-work_pop %>% mutate(notworking = ifelse(is.na(income)|income ==0, 1,0)) %>%
  group_by(notworking) %>%
  summarise(notwrk=n())
notwrk

ggplot(data = sex_income, aes(x = sex, y = mean_income)) + geom_col()

ggplot(data = notwrk, aes(x = notworking, y=notwrk )) + geom_col()

#성별별 빈도수
work_pop <- welfare %>% filter(age >=20 & age< 60)
head(work_pop)
ggplot(data = work_pop, aes(x = age)) + geom_histogram(bins=5)
ggplot(data = work_pop, aes(x = age)) + geom_bar()

work_pop <- welfare %>% filter(age >=20 & age< 60)
work_pop %>%
  mutate(notworking = ifelse(is.na(income)|income ==0, 1,0), age10 = age %/% 10 * 10) %>%
  select(sex, age10,notworking ) %>%
  group_by(sex, age10,notworking) %>%
  summarise(n= n())

# Quiz: income의 결측치를 0으로 평가할 때,
# 성별 income의 평균을 비교하라.
work_pop$income<-ifelse(is.na(work_pop$income ), 0, work_pop$income)
work_pop %>% group_by(sex) %>% summarise(mean = mean(income))

#### 09-4 연령대별 월급 차이 ####

## --------- "어떤 연령대의 월급이 가장 많을까?" ------- ##
welfare <- welfare %>%
  mutate(ageg = ifelse(age < 30, "young",
                       ifelse(age <= 59, "middle", "old")))

table(welfare$ageg)
qplot(welfare$ageg)

## ------- 1. 연령대별 월급 평균표 만들기 --------- ##
ageg_income <- welfare %>%
  filter(!is.na(income)) %>%
  group_by(ageg) %>%
  summarise(mean_income = mean(income))

ageg_income

ggplot(data = ageg_income, aes(x = ageg, y = mean_income)) + geom_col()

## -------- 막대 정렬 : 초년, 중년, 노년 나이 순 ---------- ##
ggplot(data = ageg_income, aes(x = ageg, y = mean_income)) +
  geom_col() +
  scale_x_discrete(limits = c("young", "middle", "old"))

# Quiz : 20대 30대 40대 50대 60대 이상으로 분류해보시오. 10대는 제거.
# 10대는 제거하고 수입 평균을 구하시오
age_income<-welfare %>% mutate(age10 = age %/%10 * 10,
                               age10 = ifelse (age10 > 60, 60,age10)) %>%
  filter(age10 != 10 & !is.na(income)) %>%
  group_by(age10) %>%
  summarise(income_avg = mean(income))

age_income
ggplot(data = age_income, aes(x=age10, y=income_avg)) + geom_col()

#### 09-5 연령대별 성별 평균 월급 표 ####
# ------- "성별 월급 차이는 연령대별로 다를까?" -----
# 먼저 위의 코드를 활용하여 직접 작성해봅시다.
age_income<-welfare %>% mutate(age10 = age %/%10 * 10)
age_sex_income <- age_income %>% filter(!is.na(income)) %>%
  group_by(age10, sex) %>%
  summarise(mean_income = mean(income))

ggplot(age_sex_income, aes(age10, mean_income,
                           fill=sex)) +
  geom_col()

## ----- 연령별 등급으로 다시 작성하면 ----------- ##
sex_income <- welfare %>%
  filter(!is.na(income)) %>%
  group_by(ageg, sex) %>%
  summarise(mean_income = mean(income))

sex_income

ggplot(data = sex_income, aes(x = ageg, y = mean_income, fill = sex)) +
  geom_col() +
  scale_x_discrete(limits = c("young", "middle", "old"))

ggplot(data = sex_income, aes(x = ageg, y = mean_income, fill = sex)) +
  geom_col(position = "dodge") +
  scale_x_discrete(limits = c("young", "middle", "old"))

## Quiz: 나이 및 성별 월급 차이 분석하기 --------------- ##
# 나이 및 성별 월급 평균표를 작성하여 그래프로 표현해보자.
# - income의 비 결측치를 필터링
# - age, sex로 그룹
# - income에 대해 평균을 구하여 sex_age를 생성한다.
# - sex_age로 그래프를 그린다.

sex_age<-welfare %>%
  filter(!is.na(income))%>%
  group_by(age,sex) %>%
  summarise(avg_income= mean(income))

sex_age
ggplot(data = sex_age, aes(x = age, y = avg_income, group=sex,colour=sex)) +
  geom_line()

#### 09-6 직업별 월급 차이 ####

## -------- "어떤 직업이 월급을 가장 많이 받을까?" ---------- ##
class(welfare$code_job)
table(welfare$code_job, useNA="ifany")

### - 직업분류코드 목록 불러오기.
library(readxl)
list_job <- read_excel("Data/Koweps_Codebook.xlsx",
                       col_names = T, sheet = 2)
head(list_job)
dim(list_job)

## 결합
v1 = c(1, 2, 3); v2 = c(5, 4, 3)
cbind(v1, v2)
rbind(v1, v2)

## - welfare에 직업명 결합
welfare <- left_join(welfare, list_job, id = "code_job")
table(welfare$code_job, useNA="ifany")
table(is.na(welfare$code_job), useNA="ifany")
head(welfare)

welfare %>%
  filter(!is.na(code_job)) %>%
  select(code_job, job) %>%
  head(10)

## ---------- job별 평균 임금을 계산하기 ------------- ##
job_income <- welfare %>%
  filter(!is.na(job) & !is.na(income)) %>%
  group_by(job) %>%
  summarise(mean_income = mean(income))

head(job_income)

top10 <- job_income %>%
  arrange(desc(mean_income)) %>%
  head(10)

top10

ggplot(data = top10, aes(x = reorder(job, mean_income), y = mean_income)) +
  geom_col() +
  coord_flip()

# 하위 10위 추출
bottom10 <- job_income %>%
  arrange(mean_income) %>%
  head(10)

bottom10

# 그래프 만들기
ggplot(data = bottom10, aes(x = reorder(job, -mean_income),
                            y = mean_income)) +
  geom_col() +
  coord_flip() +
  ylim(0, 850)

#### 09-7 성별 직업 빈도 ####

## -------- 성별로 어떤 직업이 가장 많을까? ------- ##
# 남성 직업 빈도 상위 10개 추출
job_male <- welfare %>%
  filter(!is.na(job) & sex == "male") %>%
  group_by(job) %>%
  summarise(n = n()) %>%
  arrange(desc(n)) %>%
  head(10)

job_male

# 여성 직업 빈도 상위 10개 추출
job_female <- welfare %>%
  filter(!is.na(job) & sex == "female") %>%
  group_by(job) %>%
  summarise(n = n()) %>%
  arrange(desc(n)) %>%
  head(10)

job_female

str(data)
# 남성 직업 빈도 상위 10개 직업
ggplot(data = job_male, aes(x = reorder(job, n), y = n)) +
  geom_col() +
  coord_flip()

# 여성 직업 빈도 상위 10개 직업
ggplot(data = job_female, aes(x = reorder(job, n), y = n)) +
  geom_col() +
  coord_flip()

#---- Quiz: 연령 등급에서 노년층(ageg = old)을 제외하고 분석하면:
# 1. 노년층 제외 남성 직업 빈도 상위 10개 추출

# 2. 노년층 제외 여성 직업 빈도 상위 10개 추출

# 3. 노년층 제외 남성 직업 빈도 상위 10개 직업 그래프

# 4. 노년층 제외 여성 직업 빈도 상위 10개 직업 그래프

# Quiz: 직업 빈도 상위 10개에 대한 남녀 비율

# Quiz : 월급 상위 30개 직업에 대한 남녀 비율\

#### 09-8 종교 유무에 따른 이혼율 ####

## -------- 종교가 있는 사람들이 이혼을 덜 할까? ------- ##
class(welfare$religion)
table(welfare$religion, useNA = 'ifany')

# 종교 유무 이름 부여
welfare$religion <- ifelse(welfare$religion == 1, "yes", "no")
table(welfare$religion)
qplot(welfare$religion, geom = 'bar')
ggplot(welfare, aes(religion, fill=factor(religion))) +
  geom_bar()

## ----- 혼인 상태 변수 검토 및 전처리 -------- ##
class(welfare$marriage)
table(welfare$marriage, useNA = "ifany")

# 이혼 여부 변수 만들기
welfare$group_marriage <- ifelse(welfare$marriage == 1, "marriage",
                                 ifelse(welfare$marriage == 3, "divorce", NA))

table(welfare$group_marriage)
table(is.na(welfare$group_marriage))
qplot(welfare$group_marriage)

## ------- 종교 유무에 따른 이혼율 분석 -------- ##
religion_marriage <- welfare %>%
  filter(!is.na(group_marriage)) %>%
  group_by(religion, group_marriage) %>%
  summarise(n = n()) %>%
  mutate(tot_group = sum(n)) %>%
  mutate(pct = round(n/tot_group*100, 1))

religion_marriage

religion_marriage <- welfare %>%
  filter(!is.na(group_marriage)) %>%
  count(religion, group_marriage) %>%
  group_by(religion) %>%
  mutate(pct = round(n/sum(n)*100, 1))

religion_marriage

# 이혼율 표 만들기
divorce <- religion_marriage %>%
  filter(group_marriage == "divorce") %>%
  select(religion, pct)

divorce

ggplot(data = divorce, aes(x = religion, y = pct)) + geom_col()

## ---- 연령대 및 종교 유무에 따른 이혼율 분석 ---- ##
ageg_marriage <- welfare %>%
  filter(!is.na(group_marriage)) %>%
  group_by(age10, group_marriage) %>%
  summarise(n = n()) %>%
  mutate(tot_group = sum(n)) %>%
  mutate(pct = round(n/tot_group*100, 1))

ageg_marriage

ageg_marriage <- welfare %>%
  filter(!is.na(group_marriage)) %>%
  count(age10, group_marriage) %>%
  group_by(age10) %>%
  mutate(pct = round(n/sum(n)*100, 1))

# 초년 제외, 이혼 추출
ageg_divorce <- ageg_marriage %>%
  filter(!(age10 %in% c(20, 30)) & group_marriage == "divorce") %>%
  select(age10, pct)

ageg_divorce

# 그래프 만들기
ggplot(data = ageg_divorce, aes(x = age10, y = pct)) + geom_col()

## ------ 연령 대 및 종교 유무에 따른 이혼율 표 --------- ##
# 연령대, 종교유무, 결혼상태별 비율표 만들기
ageg_religion_marriage <- welfare %>%
  filter(!is.na(group_marriage) & ageg != "young") %>%
  group_by(ageg, religion, group_marriage) %>%
  summarise(n = n()) %>%
  mutate(tot_group = sum(n)) %>%
  mutate(pct = round(n/tot_group*100, 1))

ageg_religion_marriage

ageg_religion_marriage <- welfare %>%
  filter(!is.na(group_marriage) & ageg != "young") %>%
  count(ageg, religion, group_marriage) %>%
  group_by(ageg, religion) %>%
  mutate(pct = round(n/sum(n)*100, 1))

# 연령대 및 종교 유무별 이혼율 표 만들기
df_divorce <- ageg_religion_marriage %>%
  filter(group_marriage == "divorce") %>%
  select(ageg, religion, pct)

df_divorce
relig_mark = factor(ifelse(df_divorce$religion==1,
                    "yes", "no"))

ggplot(data = df_divorce, aes(x = ageg, y = pct,
                              fill = relig_mark)) +
  geom_col(position = "dodge")

#### 09-9 지역별 연령 비율 ####

## ------- 노년층이 많은 지역은 어디일까? -------- ##
class(welfare$code_region)
table(welfare$code_region)

# 지역 코드 목록 만들기
list_region <- data.frame(code_region = c(1:7),
                          region = c("서울",
                                     "수도권(인천/경기)",
                                     "부산/경남/울산",
                                     "대구/경북",
                                     "대전/충남",
                                     "강원/충북",
                                     "광주/전남/전북/제주도"))
list_region

# 지역명 변수 추가
welfare <- left_join(welfare, list_region, id = "code_region")

welfare %>%
  select(code_region, region) %>%
  head

## ------ 지역 별 연령대 비율 분석 ---------- ##

region_ageg <- welfare %>%
  group_by(region, ageg) %>%
  summarise(n = n()) %>%
  mutate(tot_group = sum(n)) %>%
  mutate(pct = round(n/tot_group*100, 2))

head(region_ageg)

region_ageg <- welfare %>%
  count(region, ageg) %>%
  group_by(region) %>%
  mutate(pct = round(n/sum(n)*100, 2))

ggplot(data = region_ageg, aes(x = region, y = pct, fill = ageg)) +
  geom_col() +
  coord_flip()

## -------------- 막대 정렬하기 : 노년층 비율 높은 순 ------------------ ##
# 노년층 비율 내림차순 정렬
list_order_old <- region_ageg %>%
  filter(ageg == "old") %>%
  arrange(pct)

list_order_old

# 지역명 순서 변수 만들기
order <- list_order_old$region
order

ggplot(data = region_ageg, aes(x = region,  y = pct, fill = ageg)) +
  geom_col() +
  coord_flip() +
  scale_x_discrete(limits = order)

# 다르게 나타내면:
ggplot(data = list_order_old, aes(x = region,  y = pct, fill = ageg)) +
  geom_col() +
  coord_flip() +
  scale_x_discrete(limits = order)

# ------- 연령대 순으로 막대 색깔 나열하기 -----------#
class(region_ageg$ageg)
levels(region_ageg$ageg)
region_ageg$ageg <- factor(region_ageg$ageg)
region_ageg$ageg <- factor(region_ageg$ageg,
                           level = c("old", "middle", "young"))
str(region_ageg$ageg)
levels(region_ageg$ageg)
table(region_ageg$ageg)

ggplot(data = list_order_old, aes(x = region,  y = pct, fill = ageg)) +
  geom_col() +
  coord_flip() +
  scale_x_discrete(limits = order)

# Quiz: 직업종별 지역분포를 작성해보자.
# - 각 직업코드의 첫 digit을 직업종으로 하자.
# - 1 ~ 10까지의 직업종에 대해 지역별 비율을 구한다.
# - 7대 지역을 x축으로 직업종의 비율을 y축으로 bar 챠트를 작성한다.


library(shiny)
shinyUI(pageWithSidebar(
  headerPanel("Predict son's height"),
  sidebarPanel(
    numericInput('mom', 'Insert the mom\'s height in inches', 62, min = 30, max = 100, step = 0.1),
    numericInput('dad', 'Insert the dad\'s height in inches', 62, min = 30, max = 100, step = 0.1)
  ),
  mainPanel(
    h3('Developing data products: Final project'),
    h4('This example will try to predict a son\'s height based on the mom and dad height\'s, for the linear model regression Galton\'s data was used.'),
    h5('You entered for mom height:'),
    verbatimTextOutput("momo"),
    h5('You entered for dad height:'),
    verbatimTextOutput("dado"),
    h5('The mid height is:'),
    verbatimTextOutput("mido"),
    h5('The predicted son height is:'),
    verbatimTextOutput("sono")
  )
))


library(tidyverse)

c <- rnorm(200)
d <- rnorm(200, c)
dat <- data_frame(c,d) %>%
  mutate(sp = paste0("sp", rep(1:20, each = 10)))

write.csv(dat, "data2.csv", row.names = F)


#' @importFrom topmodel sinkfill topidx
#' @importFrom raster as.matrix setValues xres
#' @export
twi <-
  function(x, sinkfill = 4, degree = .05) {
    y <- as.matrix(x)
    for (i in seq_len(sinkfill)) {
      y <- sinkfill(y, xres(x), degree)
    }
    setValues(x, topidx(y, xres(x))$atb)
  }


# 3. faza: Vizualizacija podatkov

# Uvozimo zemljevid.
#zemljevid <- uvozi.zemljevid("http://baza.fmf.uni-lj.si/OB.zip", "OB",
#                             pot.zemljevida="OB", encoding="Windows-1250")
#levels(zemljevid$OB_UIME) <- levels(zemljevid$OB_UIME) %>%
#  { gsub("Slovenskih", "Slov.", .) } %>% { gsub("-", " - ", .) }
#zemljevid$OB_UIME <- factor(zemljevid$OB_UIME, levels=levels(obcine$obcina))
#zemljevid <- fortify(zemljevid)

# Izračunamo povprečno velikost družine
#povprecja <- druzine %>% group_by(obcina) %>%
#  summarise(povprecje=sum(velikost.druzine * stevilo.druzin) / sum(stevilo.druzin))
library(ggplot2)
library(tmap)

povprecje.dijakovindiplomantov.po.regijah <- tabela1nova %>% group_by(regija,kategorija) %>% summarise(povprecje=sum(stevilo)/10)
seznam <- split(povprecje.dijakovindiplomantov.po.regijah, povprecje.dijakovindiplomantov.po.regijah$kategorija)
povprecje.dijakov.po.regijah <- seznam[[1]]
povprecje.diplomantov.po.regijah <- seznam[[2]]
povprecje.dijakov.po.regijah <- povprecje.dijakov.po.regijah[-12,] %>% select(-"kategorija")
povprecje.diplomantov.po.regijah <- povprecje.diplomantov.po.regijah[-12,] %>% select(-"kategorija")

zemljevid <- uvozi.zemljevid("https://biogeo.ucdavis.edu/data/gadm3.6/shp/gadm36_SVN_shp.zip", "gadm36_SVN_1")
zemljevid1 <- tm_shape(merge(zemljevid, povprecje.diplomantov.po.regijah, by.x="NAME_1", by.y="regija" )) + tm_polygons("povprecje",title="Povprečje") + tm_layout(title="Povprečno število diplomantov po regijah v zadnjih desetih letih")

graf1 <- ggplot(povprecje.dijakov.po.regijah, aes(regija, povprecje, group = 1)) + geom_col() + coord_flip() +
  labs(x = "Regija", y = "Povprecje",
       title = "Povprečno število dijakov po regijah v zadnjih desetih letih")
graf2 <- ggplot(povprecje.diplomantov.po.regijah, aes(regija, povprecje, group = 1)) + geom_col() + coord_flip() +
  labs(x = "Regija", y = "Povprecje",
       title = "Povprečno število diplomantov po regijah v zadnjih desetih letih")

m <- tabela2nova %>% group_by(izobrazevanje, spol) %>% summarise(povprecje=sum(stevilo)/10) %>%filter(spol == "moski") %>% select(-"spol")
z <- tabela2nova %>% group_by(izobrazevanje, spol) %>% summarise(povprecje=sum(stevilo)/10) %>%filter(spol == "zenski")%>% select(-"spol")
graf3 <- ggplot(m, aes(izobrazevanje, povprecje, group = 1)) + geom_col() + coord_flip() + labs(x = "Vrsta izobraževanja", y = "Število moških",
                                                                                title = "Povprečno število moških v \nposameznih vrstah izobraževanj v \nzadnjih desetih letih")
graf4 <- ggplot(z, aes(izobrazevanje, povprecje, group = 1)) + geom_col() + coord_flip()+ labs(x = "Vrsta izobraževanja", y = "Število žensk",
                                                                                title = "Povprečno število žensk v \nposameznih vrstah izobraževanj v \nzadnjih desetih letih")

podatki5 <- tabela2nova %>% group_by(izobrazevanje, spol) %>% summarise(povprecje=sum(stevilo)/10)

#ggplot(podatki5, aes(x=izobrazevanje, y=povprecje, group = 1)) + geom_bar()  + coord_flip() + labs(x = "Vrsta izobraževanja", y = "Povprečno število", title = "test")

graf5 <- ggplot(podatki5, aes(x=izobrazevanje, y=povprecje, fill = spol)) + geom_col()  +
  coord_flip() + labs(x = "Vrsta izobraževanja", y = "Povprečno število", title = "test")


npc_data=read.csv(".\Bayesian_npcGPdata_gene.csv",stringsAsFactors=F)
l1k_genes= read.csv(".\l1k_genes.csv",header=F,stringsAsFactors=F)

npc_genes=intersect(npc_data$gene,l1k_genes$V1)
npc_data=subset(npc_data,gene %in% npc_genes)
rownames(npc_data) <- make.names(npc_data$gene, unique = TRUE)
npc_data=subset(npc_data, select=-c(1))

pathwayList<- unique(AllEdges$Pathway)
NPC_PAS <- data.frame(matrix(ncol = length(pathwayList), nrow = length(l1k_genes$V1)))
rownames(NPC_PAS)<-l1k_genes$V1
colnames(NPC_PAS)<-pathwayList

for (path in pathwayList){
  Edge <- AllEdges[AllEdges$Pathway==path,]
  Score <- CalcPathSig(EdgeFrom=Edge[,"GeneSymbol_a"],EdgeTo=Edge[,"GeneSymbol_b"],interaction=Edge[,"Interaction"],data=npc_data,neigen=1)
  topgenes <-sub("\\..*", "", Score$Gene)
  sig <- rep(NA, times=length(l1k_genes))
  names(sig) = l1k_genes
  for (gene in unique(topgenes)){
    g_sig<-mean(Score[which(topgenes==gene),"Signature"])
    NPC_PAS[gene,path]<-g_sig
  }
}

write.csv(NPC_PAS,".\Bayesian_npc_PAS.csv")


# install.packages("pROC")
library(ggplot2)
library(pROC)

pheno = read.table('EA23k_plink.txt', header=T)

staph = read.table('StaphAureusBloodCulture_GRIDs.txt', header=T)

pheno.1 = pheno[,colnames(pheno) %in% c("FID", "IID", "AGE_in_days", "ARRAY", "GENDER", "PC1", "PC2", "PC3", "PC4", "PC5", "X41.1")]

pheno.1$STAPH = pheno.1$FID %in% staph[,1]
pheno.1 = subset(pheno.1, pheno.1$X41.1 >= 0)

# logistic model
x = lm(STAPH ~ AGE_in_days + GENDER + PC1 + PC2 + PC3 + PC4 + PC5 , data=pheno.1)

# phecode classifier
plot(roc(pheno.1$STAPH, pheno.1$X41.1, direction="<"),  auc.polygon.col="lightblue",
     col="red", lwd=3, main="", cex.lab=1.8)

auc(roc(pheno.1$STAPH, pheno.1$X41.1, direction="<"))
# Setting levels: control = FALSE, case = TRUE
# Area under the curve: 0.9379

# PC1
par(new=T)
plot(roc(pheno.1$STAPH, pheno.1$PC1, direction="<"),
     col="orange", lwd=3, main="", cex.lab=1.8)
auc(roc(pheno.1$STAPH, pheno.1$PC1, direction="<"))
# Setting levels: control = FALSE, case = TRUE
# Area under the curve: 0.514

# Fitted values
par(new=T)
plot(roc(pheno.1$STAPH, x$fitted.values, direction="<"),  auc.polygon.col="lightblue",
     col="blue", lwd=3, main="", cex.lab=1.8)

auc(roc(pheno.1$STAPH, x$fitted.values, direction="<"))
# Setting levels: control = FALSE, case = TRUE
# Area under the curve: 0.5683

legend("bottomright", legend=c("Phecode (041.1)", "PC1", "Age+Sex+5PCs"),
       col=c("red", "orange", "blue"), lwd=2)

# Bootstrap
for (i in 1:100)
{

	pheno.2 = pheno.1[sample(nrow(pheno.1), nrow(pheno.1)),]
	tmp = auc(roc(pheno.2$STAPH, pheno.2$X41.1, direction="<"))
	print(tmp)
}


seq = import('../../seq')
bin_reads = import('./bin_reads')$bin_reads

#' Create a blacklist from WGS read numbers
#'
#' @param ref_reads    GRanges object with reads (or character string of file)
#' @param chr_lengths  Numeric vector of chromosome lengths
#' @param chromosomes  Only include these chromosomes
#' @param lower        Lower quantile to cut off
#' @param upper        Upper quantile to cut off
#' @return             GRanges object of blacklisted regions
blacklist_from_ref = function(ref_reads, chr_lengths, lower=0.05, upper=0.999,
                              chromosomes=names(chr_lengths)) {
    assembly_df = data.frame(chromosome = names(chr_lengths), length=chr_lengths)
    if (is.character(ref_reads))
        ref_reads = seq$read_granges(ref_reads, assembly=assembly_df)

    # select bin size so avg >=100 reads/bin (down to 1kb), blacklist outliers
    bsize = round(100 * sum(as.numeric(chr_lengths)) / length(ref_reads))
    bsize = max(bsize, 1000)

    ref_bins = AneuFinder::fixedWidthBins(binsizes=as.integer(bsize),
        chromosomes=chromosomes, chrom.lengths=chr_lengths)[[1]]
    ref_counts = bin_reads(reads=ref_reads, bins=ref_bins)
    lower = ref_counts$counts < quantile(ref_counts$counts, lower)
    upper = ref_counts$counts > quantile(ref_counts$counts, upper)
    blacklist = ref_bins[lower | upper]
}


bottom.contact.linear = function( sm, O, bcmethods, bcp )  {
  ## Smooth method: smooth data to remove local trends and compute first derivatives

  res = list( bc0=NA, bc1=NA)

  if(0) {
    load("~/aegis/data/nets/Scanmar/bottom.contact/results/bc.NED2014102.8.rdata")
    sm =data.frame( Z=bc$Z)
    sm$timestamp=bc$timestamp
    sm$ts=bc$ts
    good = bc$good
    sm$Z[ !good] = NA
    O = bc
  }

  # use only the subset with data for this step
  names( sm) = c("Z", "timestamp", "ts" ) # Z is used to abstract the variable name such that any variable can be passed

  # must be careful as timestamp is being converted to text and will lose tzone ... need to reset to correct timezone:
  bcm0 = paste(bcmethods, "0", sep="")
  bcm1 = paste(bcmethods, "1", sep="")

  tt0 =   tt1 =  t( as.data.frame(O[ bcm1 ]) )

  tzone = lubridate::tz(sm$timestamp[1])
  # recovert to UTC as time zone is lost with the transpose
  tmp0 = lubridate::ymd_hms( t( as.data.frame(O[ bcm0 ]) ), tz=tzone )
  tmp1 = lubridate::ymd_hms( t( as.data.frame(O[ bcm1 ]) ), tz=tzone )

  bottom0.mean =  mean(tmp0, na.rm=TRUE)
  bottom1.mean =  mean(tmp1, na.rm=TRUE)

  ## at least one solution required to continue  (2 means a valid start and end)
  ## ID best model based upon time .. furthest up a tail is best

  sols = which( sm$timestamp >= bottom0.mean & sm$timestamp <= bottom1.mean )

  left =  min(sols)
  right = max(sols)

  if (0) {
    plot( Z~ts, sm, pch="." )
    abline( v= sm$ts[ c( left, right)], col="red" )  # initial breaks
  }

  if ( any( !is.finite( c(left, right) ) ) ) return(res)

  # remember sm is is the bounds delimited by variance indices so 1=start of variance on left, N is end of variance right
  N = nrow(sm)
  down = 1:left
  up =  right:N
  dl = left
  dr = N-right
  # line segments are approximately same length as the up,down segments
  bot_left = c(left:(left+4*dl))
  bot_right = c( (right-4*dr):right)

  # find the row numbers which corresponds to each part of the curve, decent, bottom and ascent
  if(any(down < 1))  down = down [ -which(down < 1) ]
  if(any(up > N))  up = up [ -which( up > N) ]
  #  compute linear models for each section and their intersection

  #  right tail
  ri2 = right
  if (( length( which( is.finite( sm$Z[bot_right] ))) > 5) & (length( which( is.finite(sm$Z[up]))) > 5 )) {
    uplm2 = lm( Z ~ ts, sm[up, ], na.action = "na.exclude")
    botlm2r = lm( Z ~ ts, sm[bot_right, ], na.action = "na.exclude")
    cm <- rbind(coef(botlm2r),coef(uplm2)) # Coefficient matrix
    i2=c(-solve(cbind(cm[,2],-1)) %*% cm[,1])
    ii = which(sm$ts >i2[1])
    if (length(ii)>0) ri2 = min( ii )
  }

  # left tail
  ri1 =  left
  if (( length( which( is.finite( sm$Z[bot_left] ))) > 5 ) & ( length( which( is.finite( sm$Z[down]))) > 5 )) {
    downlm2 =lm( Z ~ ts, sm[down,], na.action = "na.exclude")
    botlm2l = lm( Z ~ ts, sm[bot_left, ], na.action = "na.exclude")
    # find where the sections intersect
    cm <- rbind(coef(botlm2l),coef(downlm2)) # Coefficient matrix
    i1=c(-solve(cbind(cm[,2],-1)) %*% cm[,1])
    ii = which(sm$ts < i1[1])
    if (length(ii)>0) {
      ri1 = max(ii)
    }
  }

  res =  list( bc0=sm$timestamp[ri1], bc1=sm$timestamp[ri2] )

  return(res)
}


#!/usr/bin/Rscript

library(ggplot2)

sycl_filename <- "sycl-ranges-results.csv"

data <- read.csv(sycl_filename, header=TRUE)
data <- subset(data)

slow_data <- subset(data, path == "slow")
fast_data <- subset(data, path == "fast")

data <- subset(fast_data, select = c("device", "benchmark", "size", "version"))
data$speedup <- slow_data$time / fast_data$time

levels(data$device) <- c("CPU", "GPU")

data$size <- data$size / 2
data$size <- factor(data$size)

plot <- ggplot(data = data) +
        geom_bar(aes(y = speedup, x = size, fill = version),
                 stat = "identity",
                 colour = "black",
                 position = position_dodge(),
                 width = 0.8) +
        facet_grid(device~benchmark) +
        theme_bw() +
        theme(legend.position = "none",
              strip.background = element_rect(fill = "white")) +
        scale_fill_brewer("Version", palette = "YlOrRd") +
        xlab("Size (MB)") +
        ylab("Speedup") +
        ggtitle("Benefit from automatic kernel fusion using views") +
        geom_hline(yintercept = 1)

ggsave("speedup_from_fusion.png", plot, height = 3, width = 10)


context("Facetting")

df <- data.frame(x = 1:3, y = 3:1, z = letters[1:3])

test_that("facets split up the data", {
  l1 <- ggplot(df, aes(x, y)) + geom_point() + facet_wrap(~z)
  l2 <- ggplot(df, aes(x, y)) + geom_point() + facet_grid(. ~ z)
  l3 <- ggplot(df, aes(x, y)) + geom_point() + facet_grid(z ~ .)

  d1 <- layer_data(l1)
  d2 <- layer_data(l2)
  d3 <- layer_data(l3)

  expect_equal(d1, d2)
  expect_equal(d1, d3)
  expect_equal(d1$PANEL, factor(1:3))
})

test_that("facets with free scales scale independently", {
  l1 <- ggplot(df, aes(x, y)) + geom_point() +
    facet_wrap(~z, scales = "free")
  d1 <- cdata(l1)[[1]]
  expect_true(sd(d1$x) < 1e-10)
  expect_true(sd(d1$y) < 1e-10)

  l2 <- ggplot(df, aes(x, y)) + geom_point() +
    facet_grid(. ~ z, scales = "free")
  d2 <- cdata(l2)[[1]]
  expect_true(sd(d2$x) < 1e-10)
  expect_equal(length(unique(d2$y)), 3)

  l3 <- ggplot(df, aes(x, y)) + geom_point() +
    facet_grid(z ~ ., scales = "free")
  d3 <- cdata(l3)[[1]]
  expect_equal(length(unique(d3$x)), 3)
  expect_true(sd(d3$y) < 1e-10)
})

test_that("shrink parameter affects scaling", {
  l1 <- ggplot(df, aes(1, y)) + geom_point()
  r1 <- pranges(l1)

  expect_equal(r1$x[[1]], c(1, 1))
  expect_equal(r1$y[[1]], c(1, 3))

  l2 <- ggplot(df, aes(1, y)) + stat_summary(fun.y = "mean")
  r2 <- pranges(l2)
  expect_equal(r2$y[[1]], c(2, 2))

  l3 <- ggplot(df, aes(1, y)) + stat_summary(fun.y = "mean") +
    facet_null(shrink = FALSE)
  r3 <- pranges(l3)
  expect_equal(r3$y[[1]], c(1, 3))
})


######################
############FRAILTY INDEX CALCULATION

setwd("P:/2019 0970 151 000/User Data/Faraz-Export IDAVE folders")
library(tidyverse)
library(icd)
df <- read.csv("./datasets/New/NACRASCIHI_2_dupRemoved.csv")

tabna <- function(x){table(x, useNA = "ifany")}

ic <- df %>% select(ID, days_to_lefteddate, dx10code1:dx10code10, alc_status)%>%
mutate(IDm = paste(ID, days_to_lefteddate, sep="_"))

codes <- read.csv("./ICD10 codes/frailty_score2.csv")

# codes <- c("F00", "G81","G30", "I69", "R29", "N39", "F05", "W19","S00",
# "R31", "B96", "R41", "R26", "I67", "R56", "R40", "T83", "S06",
# "S42", "E87", "M25", "E86", "R54", "Z50", "F03", "W18", "Z75", "F01",
# "S80", "L03", "H54", "E53", "Z60", "G20", "R55", "S22", "K59", "N17",
# "L89", "Z22", "B95", "L97", "R44", "K26", "I95", "N19", "A41", "Z87",
# "J96", "X59", "", "", "", "", "", "", "", "",
# "", "", "", "", "", "", "", "", "", "")

# points <- c(7.1, 4.4, 4, 3.7, 3.6, 3.2, 3.2, 3.2, 3.2,
# 3.0, 2.9, 2.7, 2.6, 2.6, 2.6, 2.5, 2.4, 2.4,
# 2.3,2.3,2.3,2.3, 2.2, 2.1, 2.1, 2.1, 2.0, 2.0,
# 2.0,2.0,1.9,1.9,1.8,1.8,1.8,1.8,1.8,1.8,
# rep(1.7,3), rep(1.6, 6), 1.5,
# rep(1.5, 4), rep(1.4, 6),

# )

for (i in 1:nrow(codes)){
	id_ls <- ic %>% filter_at(vars(dx10code1:dx10code10),
	 any_vars(substr(.,1,3) == codes$ICD.Code[i])) %>%
	select(IDm , dx10code1:dx10code10) %>% .$IDm

	var_name <- paste0("frail_",as.character(codes$ICD.Code[i])) #dynamic name in mutate

	ic <- ic %>% mutate(!!var_name := ifelse(IDm %in% id_ls, 1, 0))
}

# for (i in 1:nrow(codes)){
	# var_name <- paste0("frail_",as.character(codes$ICD.Code[i])) #dynamic name in mutate

	# ic2 <- ic %>%
	# mutate_at(vars(dx10code1:dx10coSde10), ~substr(.,1,3)) %>%
	# mutate(!!var_name := ifelse(any(vars(dx10code1:dx10code10) %in% codes$ICD.Code[i]), 1, 0))

# }
##Occurences are low usually
ic %>% select(frail_F00:frail_R50) %>% colSums / nrow(ic) * 100 %>% round(digits=2)

mat <- as.matrix(ic %>% select(frail_F00:frail_R50))

scores <- mat %*% codes$coef
####Check Safety
scores[1:5]
ic[1,] %>% select(frail_F00:frail_R50) %>% select_if(.==1)
############
ic$frailty_score <- scores
summary(ic$frailty_score)

ic %>% select(IDm, frailty_score) %>% write.csv("./ICD10 codes/frailty_index.csv", row.names = F)


# Team Rython: Dainius Masiliunas and Tim Weerman
# Date: January 2016
# License: Apache License 2.0

# Geoscripting project: a comparison between official statistics about forest coverage
# and calculated LAI trends since 2002 in Lithuania

library(bfastSpatial)
library(parallel)
library(lattice)
library(htmlwidgets)

source("src/bfastSpatialHelpers.r") # Generate* functions
source("src/ImportStatistics.r")
source("src/SanitiseNames.r")
source("src/ExtractWithinBorders.r")
source("src/GetMunicipalityLeaflet.r")

## MAKE SURE TO SET THE RIGHT WORKING DIRECTORY ##
getwd()

## Data processing ##

# Using LAI data product from the MODIS satellite.
# Get the data (URL script was generated by the MODIS website)
## NOTE: This results in downloading and processing 175 files.
## To speed it up a bit, use "data/reduced.txt" instead.
filelist = read.table("data/data_url_script_2016-01-15_032836.txt", as.is=TRUE)
for(url in unlist(filelist))
    download.file(url, destfile=paste0("data/", basename(url)), method="wget")

# Magic numbers!
# QC_val/filtermask: 0x00 means keep everything, 0xFF means keep only if all are 0
# https://lpdaac.usgs.gov/dataset_discovery/modis/modis_products_table/mcd15a2
# http://www.binaryhexconverter.com/binary-to-hex-converter
filtermask = 0x8C # Filter for dead detectors, clouds, and non-produced pixels
fillnumber = 249:255 # From the manual

# Process all the data: remove unreliable pixels
processMODISbatch("data", pattern=glob2rx("*.hdf"), 2, 3, bit=TRUE, QC_val=0x8C, fill=fillnumber, outdir="data/processed", mc.cores=4)

# Stack resulting layers
Stack = GenerateTimeStack(filename=file.path("data", "processed", "Stack.grd"), x="data/processed", pattern=glob2rx("*.tif"))

# Create annual summary statistics: mean, median, 3rd quartile, max
# These are not in a loop, because it takes a LONG time to calculate each step!
# Long as in HOURS! Even with the reduced dataset, somehow! Pass mc.cores if you have more than 4 cores.
years = 2002:2015
AnnualMed = GenerateAnnualSummary(Stack, "data/yearly/AnnualMedian.grd", median, dates=getMODISinfo(names(Stack))$date)
names(AnnualMed) = years
AnnualAvg = GenerateAnnualSummary(Stack, "data/yearly/AnnualAverage.grd", mean, dates=getMODISinfo(names(Stack))$date)
names(AnnualAvg) = years
quartile3 = function(...) quantile(..., probs=c(0.75))[[1]]
AnnualQrt75 = GenerateAnnualSummary(Stack, "data/yearly/AnnualQuartile75.grd", quartile3, dates=getMODISinfo(names(Stack))$date)
names(AnnualQrt75) = years
quantile90 = function(...) quantile(..., probs=c(0.90))[[1]]
AnnualQnt90 = GenerateAnnualSummary(Stack, "data/yearly/AnnualQuantile90.grd", quantile90, dates=getMODISinfo(names(Stack))$date)
names(AnnualQnt90) = years
AnnualMax = GenerateAnnualSummary(Stack, "data/yearly/AnnualMax.grd", max, dates=getMODISinfo(names(Stack))$date)
names(AnnualMax) = years

# Alternatively, this can be run in parallel, one statistic per core; uncomment this block for that:
#tasklist = list(
#    annualMed <- function() annualSummary(s, fun=median, na.rm=TRUE, filename="data/yearly/AnnualMedian.grd", progress="text"),
#    annualAvg <- function() annualSummary(s, fun=mean, na.rm=TRUE, filename="data/yearly/AnnualAverage.grd", progress="text"),
#    annualQrt75 <- function() annualSummary(s, fun=quartile3, na.rm=TRUE, filename="data/yearly/AnnualQuartile75.grd", progress="text"),
#    annualMax <- function() annualSummary(s, fun=max, na.rm=TRUE, filename="data/yearly/AnnualMax.grd", progress="text")
#)
#system.time(stats <- mclapply(tasklist, function(f) f(), mc.cores = 4))

## Merging of different data sources ##

# Load administrative borders (note: poor quality and outdated!)
LTU0 = getData("GADM", country="LTU", path="data", level=0)
LTU2 = getData("GADM", country="LTU", path="data", level=2)

# Extract data from all our annual summary statistic layers at both levels
StatRasters = c(AnnualAvg, AnnualMed, AnnualQrt75, AnnualQnt90, AnnualMax) # If you just want to load the data from CSVs, replace with StatRasters = 1:5
StatColNames = c("LAI_Avg", "LAI_Med", "LAI_Q75", "LAI_Q90", "LAI_Max")
AdmData = c(LTU0, LTU2)
AdmPostfix = c("LT", "Mun")
AdmNames = list(c("Republic of Lithuania"), SanitiseNames(LTU2@data$VARNAME_2))
rm(LAIData)
for (n in 1:length(AdmData))
{
    for (i in 1:length(StatRasters))
    {
        # Extract the data from our statistic raster
        Extracted = ExtractWithinBorders(StatRasters[[i]], AdmData[[n]], StatColNames[i], years, ids=AdmNames[[n]],
            filename=paste("output/dataframes/", StatColNames[i], "_", AdmPostfix[n], ".csv", sep=""))
        # Merge into one long data frame
        if (!exists("StatData"))
            StatData = Extracted
        else
            StatData = merge(StatData, Extracted)
    }
    # Merge data frames from the two different levels
    if (!exists("LAIData"))
        LAIData = StatData
    else
        LAIData = rbind(LAIData, StatData)
    rm(StatData, Extracted)
}

# Read statistics from the government
statistics = ImportStatistics()

# Merge the two data frames into one
Dataset = merge(LAIData, statistics, by=c("Municipality", "Year"))
write.table(Dataset, file="output/dataframes/Dataset.csv")

## Generate plots ##

# Creates SVG plots of the average, median, maximum, 75qt, 90qt LAI and the Forest Coverage over the years
# from the dataset and places them in outdir
MakePlotSVGs = function(Dataset, outdir)
{
    # Get the common extremes for plot limits
    miniY1= min(Dataset$Forest_Coverage)
    maxiY1= max(Dataset$Forest_Coverage)
    maxiY2= max(Dataset$LAI_Avg, Dataset$LAI_Med, Dataset$LAI_Q75, Dataset$LAI_Q90, Dataset$LAI_Max)
    miniY2= min(Dataset$LAI_Avg, Dataset$LAI_Med, Dataset$LAI_Q75, Dataset$LAI_Q90, Dataset$LAI_Max)

    # Create the graphical output of the statistics and the forest cover/LAI (two Y axes)
    for(i in levels(factor(Dataset$Municipality)))
    {
        svg(paste0(outdir, "/", i, ".svg"))
        par(mar=c(5,4,4,5)+.1)
        plot(Forest_Coverage~ Year, data=Dataset[Dataset$Municipality==i,], type="l",col="black", main=i, ylab= "Forest Coverage %", ylim=c(miniY1, maxiY1), lwd=3)
        par(new=TRUE)
        plot(LAI_Avg~ Year, data=Dataset[Dataset$Municipality==i,], type="l", col="blue", xaxt="n", yaxt="n", xlab="", ylab="", ylim=c(miniY2, maxiY2))
        lines(LAI_Med~ Year, data=Dataset[Dataset$Municipality==i,], col="green")
        lines(LAI_Q75~ Year, data=Dataset[Dataset$Municipality==i,], col="gold")
        lines(LAI_Q90~ Year, data=Dataset[Dataset$Municipality==i,], col="darkorange")
        lines(LAI_Max~ Year, data=Dataset[Dataset$Municipality==i,], col="firebrick1")
        axis(4)
        mtext("LAI",side=4,line=3)
        legend("topleft",col=c("black","blue", "green", "gold", "darkorange", "firebrick1"),lty=1, lwd=c(3,1,1,1,1,1),
            legend=c("Forest Coverage","Mean LAI", "Median LAI", "75th percentile of LAI", "90th percentile of LAI", "Maximum LAI"))
        dev.off()
    }
}

svgdir = file.path("output", "SVG")
MakePlotSVGs(Dataset, svgdir)

## Generate a Leaflet HTML ##

# Create a base raster to render
Summary = summaryBrick(Stack, fun=mean)
# Make it small enough to embed into HTML
SmallSummary = crop(Summary, spTransform(LTU0, Summary@crs))

htmldir = file.path(getwd(), "output", "html")
Leaflet = GetMunicipalityLeaflet(LTU0, LTU2, SmallSummary, svgdir=svgdir)
saveWidget(Leaflet, file=file.path(htmldir, "Municipalities.html"), selfcontained=FALSE)

## Look at some statistics
DatLT = subset(Dataset, Municipality=="Republic of Lithuania")
DatMun = subset(Dataset, Municipality!="Republic of Lithuania")
# LAI mean change per year: +0.04
summary(lm(LAI_Avg~Year, data=DatLT)) # Whole country
summary(lm(LAI_Avg~Year, data=DatMun)) # Individual municipalities
# That's 0.68% per year
lm(LAI_Avg~Year, data=DatLT)$coefficients[2]/max(Dataset[["LAI_Max"]])*100

# LAI maximum change per year: +0.06
summary(lm(LAI_Max~Year, data=DatLT)) # Whole country
summary(lm(LAI_Max~Year, data=DatMun)) # Individual municipalities
# That's 0.93% per year
lm(LAI_Max~Year, data=Dataset[Dataset$Municipality=="Republic of Lithuania",])$coefficients[2]/max(Dataset[["LAI_Max"]])*100

# Forest cover change per year: +0.12%
summary(lm(Forest_Coverage~Year, data=DatLT)) # Whole country
summary(lm(Forest_Coverage~Year, data=DatMun)) # Individual municipalities

## Done. ##
## Note: Leaflet is a bit silly with popup widths; manually fix that by injecting CSS (optional) ##
wd = getwd()
setwd(htmldir)
system("./addcss.sh")
system("firefox Municipalities.html")
setwd(wd)


#' Delineate streams from an elevation model
#' @param dem A [raster::raster]; a digital elevation model.
#' @param threshold The minimum size of a delineated catchment; units are in dem_units^2 (e.g., m^2); default 10 km^2.
#' @param pretty Should flat areas be made prettier? Corresponds to r.watershed -b flag
#' @param file The file name of the raster to be returned, see `details`.
#' @param outlet The location of the outlet of the target stream, see `details`.
#' @param reach_len Optional; if provided, reaches will be resized to meet this target length
#' @param ... If `reach_len` is specified, additional parameters to be passed to [resize_reaches()]
#' @details This is a wrapper for [r.watershed](https://grass.osgeo.org/grass76/manuals/r.watershed.html).
#'
#' The threshold parameter controls the level of detail in the delineated streams. Higher thresholds result in faster
#' computation and fewer streams in the output. For finer control, see [extract_stream()].
#'
#' If `outlet` is `NA` (the default), then the largest stream in the area will be set as the outlet,
#' and only streams in that watershed will be used.
#' If a smaller stream is the focus, then outlet can be a pair of x-y coordinates which will determine the farthest
#' downstream point to use.
#'
#' Streams can be converted to a vector file, see [stream_vector()].
#'
#' It is recommended to specify the `file` parameter (including the extension to specify
#' file format; e.g., .tif, .grd). If not specified, a temp file will be created and will be
#' lost at the end of the R session.
#' @return A [raster::stack()], containing the drainage map, the flow accumulation map, and the delineated streams.
#' @examples
#' \donttest{
#'     data(kamp_dem)
#'     x = delineate(kamp_dem)
#' }
#' @export
delineate = function(dem, threshold = 1e6, pretty = FALSE, file, outlet = NA, reach_len, ...) {
	cell_area = prod(raster::res(dem))
	threshold_cell = floor(threshold/cell_area)

	if(threshold_cell / raster::ncell(dem) < 0.0001)
		warning("Small threshold; excessive computation time and memory usage are possible if threshold not increased")

	flags = c("overwrite", "quiet")
	if(pretty)
		flags = c(flags, "b")

	elevation = "dem"
	accum = "accum"
	drainage = "drainage"
	stream= "stream"

	## launch grass and copy data
	.start_grass(dem, elevation)

	## perform computation
	rgrass7::execGRASS("r.watershed", flags=flags, elevation=elevation, threshold = threshold_cell,
					   accumulation = accum, drainage = drainage, stream = stream)
	# make sure to add the names of created rasters to the list of layers
	ws_env$rasters = c(ws_env$rasters, accum, drainage, stream)

	## gather data
	res = .read_rasters(c(accum, drainage, stream))

	## Clip to a single network
	if(length(outlet) == 1 && is.na(outlet))
		outlet = matrix(raster::coordinates(res)[which.max(abs(raster::values(res$accum))),], ncol=2)
	catch = catchment(res, type = "points", y = outlet, area = FALSE)

	catch = raster::trim(catch)
	res = raster::crop(res, catch)
	stream_clip = raster::mask(res$stream, catch)
	res = raster::dropLayer(res, which(names(res) == stream))
	res = raster::addLayer(res, stream = stream_clip, catchment = catch)

	## renumber reaches to go from 1:nreaches, make sure streams are integers
	res[['stream']] = raster::match(res[['stream']],
					raster::unique(res[['stream']]))
	storage.mode(res[['stream']][]) = 'integer'

	if(!missing(reach_len)) {
		Tp = pixel_topology(res)
		res[['stream']] = resize_reaches(res[['stream']], Tp, len = reach_len, ...)
	}

	## clean up files
	.clean_grass()

	if(!missing(file))
		res = raster::writeRaster(res, filname = file)

	res
}

#' @name vectorise_stream
#' @rdname vectorise_stream
#' @title Vectorize a stream layer
#' Produces a vector layer (in `sf` format) from a raster stream map as created by [delineate()].
#' @param x A [raster] stream map, such as one created by [delineate()].
#' @param Tp A pixel topology
#' @return An `sf` stream layer
#' @examples
#' \donttest{
#'     data(kamp_dem)
#'     x = delineate(kamp_dem)
#'     vect = vectorise_stream(x$stream, pixel_topology(x))
#' }
#' @export
vectorise_stream = function(x, Tp) {

	rids = raster::unique(x)
	vals = cbind(data.frame(reach_id = x[]), raster::coordinates(x))
	sf_pts = sf::st_as_sf(vals, coords = c('x', 'y'), crs=sf::st_crs(x))

	lines = lapply(rids, .pts_to_line, x = x, pts = sf_pts, Tp = Tp)
	do.call(rbind, lines)
}

.pts_to_line = function(i, x, pts, Tp) {
	pids = extract_reach(i, x, Tp, sorted = TRUE)
	pids = c(pids, .downstream(Tp, pids[length(pids)]))
	xy = sf::st_cast(sf::st_geometry(pts[pids,]), "POINT")
	# convert each pair of points into a linestring
	lines = sapply(1:(length(pids)-1), function(j)
		sf::st_cast(sf::st_combine(xy[j:(j+1)]), "LINESTRING"))
	# convert the whole thing to a multilinestring
	mline = sf::st_sf(sf::st_geometry(sf::st_multilinestring(lines)))
	sf::st_crs(mline) = sf::st_crs(pts)
	mline$reach_id = i
	mline
}

#' @name vectorise_stream_old
#' @rdname vectorise_stream_old
#' @title Vectorize a stream layer
#' Deprecated, use vectorise_stream()..
#' @return An `sf` stream layer
#' @keywords internal
vectorise_stream_old = function(x) {
	inpname = "stream"
	outname = "stream_thin"
	vectname = "stream_vect"

	.start_grass(x, inpname)

	flags = c("overwrite", "quiet")

	rgrass7::execGRASS("r.thin", flags=flags, input=inpname, output = outname)
	ws_env$rasters = c(ws_env$rasters, outname)

	rgrass7::execGRASS("r.to.vect", flags=flags, input=outname, output = vectname,
					   type="line", column="reach_id")
	ws_env$vectors = c(ws_env$vectors, vectname)
	vect = .read_vector(vectname)

	.clean_grass()
	vect
}

#' Resize reaches from a delineated stream
#' @param x A [raster] stream map, such as one created by [delineate()].
#' @param len The target length of resized reaches (in map units)
#' @param min_len How small is the smallest acceptable reach?
#' @param trim Logical; remove headwater reaches smaller than min_length?
#' @param Tp A pixel topology
#' @return A raster similar to `x` with reaches resized
#' @examples
#' \donttest{
#'     data(kamp_dem)
#'     x = delineate(kamp_dem)
#'     Tp = pixel_topology(x)
#'     x[['stream']] = resize_reaches(x[['stream']], Tp, 1000, 600)
#' }
#' @export
resize_reaches = function(x, Tp, len, min_len = 0.5 * len, trim = TRUE) {

	if(!is.null(getOption("mc.cores")) && getOption("mc.cores") > 1) {
		lapplfun = parallel::mclapply
	} else {
		lapplfun = lapply
	}

	ids = raster::unique(x)
	if(!is.vector(ids) || !identical(ids, as.integer(ids)))
		stop("x must be a single-layer raster stream delineation with integer reach ids as values")

	pids = lapplfun(ids, extract_reach, stream=x, Tp = Tp, sorted = TRUE)
	new_reaches = unlist(lapplfun(pids, .resize_r, Tp = Tp, trim = trim, len = len, min_len = min_len),
						 recursive = FALSE)
	x = x * NA
	for(i in seq_along(new_reaches))
		x[new_reaches[[i]]] = i

	storage.mode(x[]) = 'integer'
	x
}

#' Split a single reach
#' @param ids A vector of pixel ids in the reach, sorted from upstream to downstream
#' @param Tp A pixel topology
#' @param trim Logical, should we trim small headwater reaches?
#' @param len Target reach length
#' @param min_len Minimum acceptable reach length, only used if `trim` is `TRUE`
#' @return A list of vectors, each vector is a single new reach.
#' @keywords internal
.resize_r = function(ids, Tp, trim, len, min_len) {

	if(length(ids) == 1)
		return(list(ids))

	## only trim headwater reaches
	trim = trim && .is_headwater(Tp)[ids[1]]

	# we will resize from bottom to top, then reverse again at the end
	ids = rev(ids)

	pix_lens = Matrix::rowSums(Tp[ids,])

	## compute target number of reaches
	rlen = sum(pix_lens)
	nr = ceiling(rlen/len)

	## if not trimming, decide on new reach length to get reaches mostly even lengths
	## try the computed number of reaches +/- 1
	## pick the one that gets us closest to the target length
	if(!trim) {
		cand = rlen / (nr + -1:1)
		ldiff = abs(len - cand)
		len = cand[which.min(ldiff)]
		nr = nr + (-1:1)[which.min(ldiff)]
	}

	new_rids = ceiling(cumsum(pix_lens) / len)

	## outlet of the whole river network will end up with an id of 0; fix it
	new_rids[new_rids == 0] = 1

	# any pixels given a new id > nr are short headwater pixels that should be dropped
	new_rids = new_rids[new_rids <= nr]

	new_reaches = lapply(unique(new_rids), function(i) ids[new_rids == i])

	## if we are trimming, drop the headwater if it is too short
	if(trim) {
		r = new_reaches[[length(new_reaches)]]
		hwlen = sum(pix_lens[match(r, ids)])
		if(hwlen < min_len)
			new_reaches[[length(new_reaches)]] = NULL
	}

	# reorder the list so that the reaches are sorted from headwater to outlet
	rev(new_reaches)
}


# 2. faza: Uvoz podatkov

library(readr)
library(dplyr)
library(tidyr)
library(reshape2)

# POTNIŠKI PROMET IN PREVOZ
promet <- read_csv2("podatki/potniski_promet.csv", col_names = c("Potniki(1000)", "Vrsta_prevoza", 2001:2017),
                    skip = 4, n_max = 8, na = "...",
                    locale=locale(encoding="Windows-1250"))
promet <- promet[,-1]

promet <- melt(promet, id.vars = "Vrsta_prevoza", measure.vars = names(promet)[-1],
                    variable.name = "Leto", value.name = "Stevilo",
                    na.rm = TRUE)

# ŠTEVILO AVTOMOBILOV GLEDE NA VRSTO POGONA

pogon <- read_csv2("podatki/vrsta_pogona.csv", col_names = c("Osebni avtomobili","Leto", "Vrsta_pogona", "Stevilo_avtomobilov"),
                     skip = 6, n_max=36,
                     locale = locale(encoding = "Windows-1250"))
pogon <- pogon[c(3,2,4)] %>% fill(2)

pogon <- filter(pogon, Vrsta_pogona !='NA')
pogon <- filter(pogon, Vrsta_pogona !='Vrsta pogona in goriva - SKUPAJ')

indeksi <- dcast(pogon, Vrsta_pogona~Leto, value.var = 'Stevilo_avtomobilov' )
colnames(indeksi) <- c("Vrsta_pogona", "a", "b", "c", "d")
indeksi <- transform(indeksi, Indeks1 = (b-a)*100/a)
indeksi <- transform(indeksi, Indeks2 = (c-b)*100/b)
indeksi <- transform(indeksi, Indeks3 = (d-c)*100/c)
indeksi <- indeksi[c(1,6,7,8)]
colnames(indeksi) <- c("Vrsta_pogona", 2015:2017)

indeksi <- melt(indeksi, id.vars = "Vrsta_pogona", measure.vars = names(indeksi)[-1],
                            variable.name = "Leto", value.name = "Indeks")

# POVPREČNA BRUTO PLAČA PO REGIJAH

placa <- read_delim("podatki/povprecna_bruto_placa_po_regijah.csv", delim = ";", col_names = c("Regija", 2005:2017),
                  skip=5, n_max=12, locale = locale(encoding = "Windows-1250"))
placa$Regija <- gsub("Jugovzhodna Slovenija", "Jugovzhodna", placa$Regija)

placa <- placa[c(1,2,3,4,5,6,7,9,10,8,11,12),]
placa <- melt(placa, id.vars = "Regija", measure.vars = names(placa)[-1],
     variable.name = "Leto", value.name = "Placa")

placa2015 <- filter(placa, Leto == '2015')
placa2015 <- placa2015[,-2]
placa2010 <- filter(placa, Leto == '2010')
placa2010 <- placa2010[,-1]

# ŠTEVILO UMRLIH V CESTNOPROMETNIH NESREČAH NA 10.000 PREBIVALCEV PO REGIJAH

umrli <- read_delim("podatki/Stevilo_umrlih_v_cestnoprometnih_nesrecah_na_10000_prebivalcev.csv", delim=";", col_names = c("nekaj","Regija", 2001:2017),
                   skip=4, n_max=12, locale = locale(encoding = "Windows-1250"))
umrli <- umrli[,-1]
umrli$Regija <- gsub("Jugovzhodna Slovenija", "Jugovzhodna", umrli$Regija)
umrli$Regija <- gsub("Spodnjeposavska", "Posavska", umrli$Regija)
umrli$Regija <- gsub("Notranjsko-kraška", "Primorsko-notranjska", umrli$Regija)

umrli <- melt(umrli, id.vars = "Regija", measure.vars = names(umrli)[-1],
              variable.name = "Leto", value.name = "Umrli")
umrli$Leto <- as.numeric(levels(umrli$Leto))[umrli$Leto]

# ŠTEVILO OSEBNIH AVTOMOBILOV NA 1000 PREBIVALCEV PO REGIJAH

avtomobili <-read_delim("podatki/Stevilo_osebnih_avtomobilov_na_1000_prebivalcev.csv", delim=";", col_names = c("nekaj","Regija", 2001:2017),
                                 skip=4, n_max=12, locale = locale(encoding = "Windows-1250"))
avtomobili <- avtomobili[,-1]
avtomobili$Regija <- gsub("Jugovzhodna Slovenija", "Jugovzhodna", avtomobili$Regija)
avtomobili$Regija <- gsub("Notranjsko-kraška", "Primorsko-notranjska", avtomobili$Regija)
avtomobili$Regija <- gsub("Spodnjeposavska", "Posavska", avtomobili$Regija)

avtomobili <- melt(avtomobili, id.vars = "Regija", measure.vars = names(avtomobili)[-1],
              variable.name = "Leto", value.name = "Avtomobili")

avtomobili$Leto <- as.numeric(levels(avtomobili$Leto))[avtomobili$Leto]

# POVPREČNA STAROST OSEBNEGA AVTOMOBILA PO REGIJAH

starost <- read_delim("podatki/Povprecna_starost_osebnega_avtomobila.csv", delim=";", col_names = c("nekaj","Regija", 2001:2017),
                      skip=4, n_max=12, locale = locale(encoding = "Windows-1250"))
starost <- starost[,-1]
starost$Regija <- gsub("Jugovzhodna Slovenija", "Jugovzhodna", starost$Regija)
starost$Regija <- gsub("Notranjsko-kraška", "Primorsko-notranjska", starost$Regija)
starost$Regija <- gsub("Spodnjeposavska", "Posavska", starost$Regija)

starost <- melt(starost, id.vars = "Regija", measure.vars = names(starost)[-1],
                   variable.name = "Leto", value.name = "Starost_avtomobila")

starost2015 <- filter(starost, Leto == '2015')


employees <- read.csv(file.choose())
str(employees)
employees$gender=as.factor(employees$gender)
orders <- read.csv(file.choose())
str(orders)

sqldf("select * from employees where gender='m'")

#count by first name
sqldf("select firstname,count(firstname) from employees group by firstname")

#count by first name excluding rudi
sqldf("select firstname,count(firstname) from employees where firstname!='rudi' group by firstname ")

emp_cali = sqldf("select *,
                  CASE
                  when firstname='solon' then 1
                  when firstname='hila' then 1
                  when firstname='dima' then 1
                  Else 0
                  End cali_emp
                  from employees
                 ")
emp_cali

# sort employees
emp_cali = sqldf("select *,
                  CASE
                  when firstname='solon' then 1
                  when firstname='hila' then 1
                  when firstname='dima' then 1
                  Else 0
                  End cali_emp
                  from employees
                  order by cali_emp desc,firstname")
emp_cali


source('Bumblebee_interday.R')

maType <- 'SMA'
startDate <- 20160401
endDate <- 20160429
tickSource <- 'C:\\Users\\victor\\Documents\\nautilusdata\\'
productSource <- 'C:\\Users\\victor\\Documents\\nautilusdata\\InstrumentInfo.csv'
#tickSource <- 'D:\\nautilusdata\\'
mainInstrumentID <- 'NI1609'
subInstrumentID <- 'NI1701'

sdMax <- 3
sdMin <- 1.8
sdStep <- 0.2
maMax <- 300
maMin <- 100
maStep <- 50
positionLimit = 10
distortTk = 0.5
orderSize <- 1
hedgeRatio <- 1
subTrigger = T
tradeCoolDown <- 30000
fee <- 4
slippageTick <- 1
isDraw <- T
allData <<- NULL
allBars <<- NULL
paramHeader <- c('sdMax', 'sdMin', 'sdStep', 'maMax', 'maMin', 'maStep',
  'positionLimit', 'distortTk', 'orderSize',
  'hedgeRatio', 'subTrigger', 'tradeCoolDown', 'fee', 'slippageTick', 'startDate', 'endDate')
param <- c(sdMax, sdMin, sdStep, maMax, maMin, maStep, positionLimit, distortTk, orderSize,
     hedgeRatio, subTrigger, tradeCoolDown, fee, slippageTick, startDate, endDate)
names(param) <- paramHeader

#subContract <- c('BU1609', 'SHFE', 2, 10)
#mainContract <- c('RU1609', 'SHFE', 5, 10)
mainContract <- getContractByID(mainInstrumentID, productSource)
subContract <- getContractByID(subInstrumentID)

folder <- paste('C:\\Users\\victor\\Documents\\Backtest\\Bumblebee\\', subContract$Contract, mainContract$Contract, "_", startDate, '_', endDate, '\\', sep = '')
createFolder(folder)

summary <- runBackTest(mainContract, subContract, param, tickSource, folder, maType, isDraw)
summary <- as.data.frame(summary)
colnames(summary) <- c('Date', 'maPeriod', 'sdAmplifier', 'distortTk', 'rtn', 'max', 'min', 'drop')
summary$rtn <- as.numeric(as.character(summary$rtn))
summary$RtnDrop <- as.numeric(as.character(summary$rtn)) / -as.numeric(as.character(summary$drop))
write.csv(summary, file = paste(folder, mainInstrumentID, '_summary.csv', sep = ''))
#NULL
groupColumns = c("sdAmplifier", "maPeriod")
dataColumns = c("RtnDrop", "rtn")
res = ddply(summary, groupColumns, function(x) colMeans(x[dataColumns]))

x <- matrix(res$rtn, nrow = length(unique(res$maPeriod)), ncol = length(unique(res$sdAmplifier)))
rownames(x) <- unique(res$maPeriod)
colnames(x) <- unique(res$sdAmplifier)
write.csv(x, file = paste(folder, mainInstrumentID, '_ma_sd_rtn.csv', sep = ''))

x <- matrix(res$RtnDrop, nrow = length(unique(res$maPeriod)), ncol = length(unique(res$sdAmplifier)))
rownames(x) <- unique(res$maPeriod)
colnames(x) <- unique(res$sdAmplifier)
write.csv(x, file = paste(folder, mainInstrumentID, '_ma_sd_SR.csv', sep = ''))

res = ddply(summary, groupColumns, function(x) colSums(x[dataColumns]))
x <- matrix(res$rtn, nrow = length(unique(res$maPeriod)), ncol = length(unique(res$sdAmplifier)))
rownames(x) <- unique(res$maPeriod)
colnames(x) <- unique(res$sdAmplifier)
write.csv(x, file = paste(folder, mainInstrumentID, '_ma_sd_rtn_acu.csv', sep = ''))