# OSNOVNA ANALIZA

#NAPELJAVE

#pretvorba v obliko tidy data
napeljave <- napeljave %>%
  gather(key="leto.tip", value="stevilo", -Obcina) %>%
  separate(leto.tip, c("leto", "tip"), "(?<=[0-9]) ")

#konstrukcija podtabel vodovoda, kanalizacije, centralnega ogrevanja, električnega toka, kopalnice, stranišča,kuhinje
vodovod <- napeljave %>% filter(tip == "Vodovod")
centralno_ogrevanje <- napeljave %>% filter(tip == "Centralno ogrevanje")
elektricni_tok <- napeljave %>% filter(tip == "Električni tok")
kopalnica <- napeljave %>% filter(tip == "Kopalnica")
stranisce <- napeljave %>% filter(tip == "Stranišče")
kuhinja <- napeljave %>% filter(tip == "Kuhinja")
kanalizacija <- napeljave %>% filter(tip == "Kanalizacija")
vodovod <- vodovod[,-3]
centralno_ogrevanje <- centralno_ogrevanje[,-3]
elektricni_tok <- elektricni_tok[,-3]
kopalnica <- kopalnica[,-3]
stranisce <- stranisce[,-3]
kuhinja <- kuhinja[,-3]
kanalizacija <- kanalizacija[,-3]

#KAZALNIKI

#pretvorba v obliko tidy data
kazalniki <- kazalniki %>% gather(key = "tip", value = "vrednost", -Obcina)

#konstrukcija podtabel gostota, placa_indeks, brezposelni,stanovanja
gostota <- kazalniki %>% filter(tip == "gostota_prebivalstva")
gostota <- gostota[,-2]
placa_indeks <- kazalniki %>% filter(tip == "pov_mes_neto_placa_indeks")
placa_indeks <- placa_indeks[,-2]
brezposelni <- kazalniki %>% filter(tip == "st_reg_brezposelnosti_ods")
brezposelni <- brezposelni[,-2]
stanovanja <- kazalniki %>% filter(tip == "st_stan_na_tisoc_preb")
stanovanja <- stanovanja[,-2]

#sprememba nekaterih imen
gostota$Obcina <- gsub("Koper/Capodistria1)", "Koper/Capodistria", gostota$Obcina)
gostota$Obcina <- gsub("Ankaran/Ancarano1)", "Ankaran/Ancarano", gostota$Obcina)
gostota$Obcina <- gsub("Trebnje2)", "Trebnje", gostota$Obcina)

#gostota_vodovod
gostota_vodovod <- left_join(vodovod,gostota,by="Obcina")
colnames(gostota_vodovod) <- c("obcina", "leto", "stevilo", "gostota")
#sortiranje obcin glede na gostoto
levels <- c(0,261,521, 780, Inf)
labels <- c("zelo_redka", "redka", "gosta", "zelo_gosta")
gostota_vodovod <- gostota_vodovod %>% mutate(skupina = cut(gostota, levels, labels = labels))
skupina <- gostota_vodovod
gostota_vodovod$stevilo <- parse_integer(gostota_vodovod$stevilo)
#izracun povprecij
leta.skupine.vod <- gostota_vodovod %>% group_by(leto, skupina) %>% summarise(povprecje = mean(stevilo))
leta.skupine.vod$leto <- parse_integer(leta.skupine.vod$leto)

#gostota_kanalizacija
gostota_kanalizacija <- left_join(kanalizacija,gostota,by="Obcina")
colnames(gostota_kanalizacija) <- c("obcina", "leto", "stevilo", "gostota")
levels <- c(0,261,521, 780, Inf)
labels <- c("zelo_redka", "redka", "gosta", "zelo_gosta")
gostota_kanalizacija <- gostota_kanalizacija %>% mutate(skupina = cut(gostota, levels, labels = labels))
gostota_kanalizacija$stevilo <- parse_integer(gostota_kanalizacija$stevilo)
leta.skupine.kan <- gostota_kanalizacija %>% group_by(leto, skupina) %>% summarise(povprecje = mean(stevilo))
leta.skupine.kan$leto <- parse_integer(leta.skupine.kan$leto)

#placa_ogrevanje
placa_ogrevanje <- left_join(centralno_ogrevanje,placa_indeks,by="Obcina")
colnames(placa_ogrevanje) <- c("obcina", "leto", "stevilo", "placa_indeks")
levels <- c(0, 90, 110, Inf)
labels <- c("nizka","srednja","visoka")
placa_ogrevanje <- placa_ogrevanje %>% mutate(razred = cut(placa_indeks, levels, labels = labels))
placa_ogrevanje$stevilo <- parse_integer(placa_ogrevanje$stevilo)
leta.razredi <- placa_ogrevanje %>% group_by(leto, razred) %>% summarise(povprecje = mean(stevilo))
leta.razredi <- na.omit(leta.razredi)
leta.razredi$leto <- parse_integer(leta.razredi$leto)

#POMANKLJIVOSTI:

#pretvorba v obliko tidy data
pomankljivosti <- pomankljivosti %>% gather(key = "tip", value = "vrednost", -Obcina)

#delezi stanovanj s pomakljivostmi v posamezni obcini v odstotkih
delezi <- pomankljivosti %>% group_by(Obcina) %>% top_n(2) %>% summarise(delez = min(vrednost)/max(vrednost)*100)
levels <- c(0,25,50,75,Inf)
labels <- c("zelo nizka","nizka","visoka","zelo visoka")
delezi <- delezi %>% mutate(pomankljivost = cut(delez, levels, labels=labels))

stan <- pomankljivosti %>% filter(tip == "st_vseh_stanovanj")
stan <- stan[,-2]

#PREOSTALO ZA VIZUALIZACIJE

#brezposelni
levels <- c(0,12,Inf)
labels <- c("nekritična","kritična")
brezposelni <- brezposelni %>% mutate(kriticnost = cut(vrednost, levels, labels = labels))
#obcini z najmanj in najbolj kriticno brezposelnostjo
y_max <- max(brezposelni[,"vrednost"])
najbolj_kriticna <- brezposelni[brezposelni$'vrednost' == y_max, "Obcina"]
y_min <- min(brezposelni[,"vrednost"])
najmanj_kriticna <- brezposelni[brezposelni$'vrednost' == y_min, "Obcina"]

#place
levels <- c(0, 90, 110, Inf)
labels <- c("nizka","srednja","visoka")
placa_indeks <- placa_indeks %>% mutate(razred = cut(vrednost, levels, labels = labels))
#place, obcini z najvisjim in najnizjim indeksom
y_max <- max(placa_indeks[,"vrednost"])
najvisji_indeks <- placa_indeks[placa_indeks$'vrednost' == y_max, "Obcina"]
y_min <- min(placa_indeks[,"vrednost"])
najnizji_indeks <- placa_indeks[placa_indeks$'vrednost' == y_min, "Obcina"]

#gostota
levels <- c(0,261,521, 780, Inf)
labels <- c("zelo_redka", "redka", "gosta", "zelo_gosta")
gostota <- gostota %>% mutate(skupina = cut(vrednost, levels, labels = labels))
#obcini z najvecjo in najmanjso gostoto
y_max <- max(gostota[,"vrednost"])
najbolj_gosta <- gostota[gostota$'vrednost' == y_max, "Obcina"]
y_min <- min(gostota[,"vrednost"])
najmanj_gosta <- gostota[gostota$'vrednost' == y_min, "Obcina"]

#KAZALNIKI ZA ZEMLJEVIDE

#pretvorba v obliko tidy data
kazalniki_za_zemljevide <- kazalniki_za_zemljevide %>% gather(key = "tip", value = "vrednost", -Obcina)
#preimenovanje nekaterih imen za risanje zemljevida
kazalniki_za_zemljevide$Obcina = gsub("Ankaran/Ancarano1)", "Ankaran", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Koper/Capodistria1)", "Koper", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Trebnje2)", "Trebnje", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Miren - Kostanjevica", "Miren-Kostanjevica", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Mirna2)", "Mirna", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Rače - Fram", "Rače-Fram", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Šempeter - Vrtojba", "Šempeter-Vrtojba", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Piran/Pirano", "Piran", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Mokronog - Trebelno", "Mokronog-Trebelno", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Renče - Vogrsko", "Renče-Vogrsko", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Dobrova - Polhov Gradec", "Dobrova-Polhov Gradec", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Hrpelje - Kozina", "Hrpelje-Kozina", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Sveta Trojica v Slov. goricah", "Sveta Trojica v Slovenskih goricah", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Sveti Jurij v Slov. goricah", "Sveti Jurij v Slovenskih goricah", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Gorenja vas - Poljane", "Gorenja vas-Poljane", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Hoče - Slivnica", "Hoče-Slivnica", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Izola/Isola", "Izola", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Log - Dragomer", "Log-Dragomer", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Lendava/Lendva", "Lendava", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Dobrovnik/Dobronak", "Dobrovnik", kazalniki_za_zemljevide$Obcina)
kazalniki_za_zemljevide$Obcina <- gsub("Hodoš/Hodos", "Hodoš", kazalniki_za_zemljevide$Obcina)
#urejanje
#konstrukcija podtabel gostota, placa_indeks, brezposelni,stanovanja
gostota_z <- kazalniki_za_zemljevide %>% filter(tip == "gostota_prebivalstva")
gostota_z <- gostota_z[,-2]
gostota_z <- gostota_z[-1,]
placa_indeks_z <- kazalniki_za_zemljevide %>% filter(tip == "pov_mes_neto_placa_indeks")
placa_indeks_z <- placa_indeks_z[,-2]
placa_indeks_z <- placa_indeks_z[-1,]
brezposelni_z <- kazalniki_za_zemljevide %>% filter(tip == "st_reg_brezposelnosti_ods")
brezposelni_z <- brezposelni_z[,-2]
brezposelni_z <- brezposelni_z[-1,]
stanovanja_z <- kazalniki_za_zemljevide %>% filter(tip == "st_stan_na_tisoc_preb")
stanovanja_z <- stanovanja_z[,-2]
stanovanja_z <- stanovanja_z[-1,]

# NAPREDNA ANALIZA

#centralno ogrevanje kot pomankljivost
cent_ogr_poman <- pomankljivosti %>% filter(tip == "centralno_ogrevanje")
cent_ogr_poman <- cent_ogr_poman[,-2]

#poenotenje obcin
cent_ogr_poman$Obcina <- gsub("Ankaran/Ancarano", "Ankaran", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Koper/Capodistria", "Koper", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Trebnje)", "Trebnje", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Miren - Kostanjevica", "Miren-Kostanjevica", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Rače - Fram", "Rače-Fram", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Šempeter - Vrtojba", "Šempeter-Vrtojba", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Piran/Pirano", "Piran", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Mokronog - Trebelno", "Mokronog-Trebelno", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Renče - Vogrsko", "Renče-Vogrsko", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Dobrova - Polhov Gradec", "Dobrova-Polhov Gradec", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Hrpelje - Kozina", "Hrpelje-Kozina", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Sveta Trojica v Slov. goricah", "Sveta Trojica v Slovenskih goricah", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Sveti Jurij v Slov. goricah", "Sveti Jurij v Slovenskih goricah", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Gorenja vas - Poljane", "Gorenja vas-Poljane", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Hoče - Slivnica", "Hoče-Slivnica", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Izola/Isola", "Izola", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Log - Dragomer", "Log-Dragomer", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Lendava/Lendva", "Lendava", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Dobrovnik/Dobronak", "Dobrovnik", cent_ogr_poman$Obcina)
cent_ogr_poman$Obcina <- gsub("Hodoš/Hodos", "Hodoš", cent_ogr_poman$Obcina)

stan$Obcina <- gsub("Ankaran/Ancarano", "Ankaran", stan$Obcina)
stan$Obcina <- gsub("Koper/Capodistria", "Koper", stan$Obcina)
stan$Obcina <- gsub("Trebnje)", "Trebnje", stan$Obcina)
stan$Obcina <- gsub("Miren - Kostanjevica", "Miren-Kostanjevica", stan$Obcina)
stan$Obcina <- gsub("Rače - Fram", "Rače-Fram", stan$Obcina)
stan$Obcina <- gsub("Šempeter - Vrtojba", "Šempeter-Vrtojba", stan$Obcina)
stan$Obcina <- gsub("Piran/Pirano", "Piran", stan$Obcina)
stan$Obcina <- gsub("Mokronog - Trebelno", "Mokronog-Trebelno", stan$Obcina)
stan$Obcina <- gsub("Renče - Vogrsko", "Renče-Vogrsko", stan$Obcina)
stan$Obcina <- gsub("Dobrova - Polhov Gradec", "Dobrova-Polhov Gradec", stan$Obcina)
stan$Obcina <- gsub("Hrpelje - Kozina", "Hrpelje-Kozina", stan$Obcina)
stan$Obcina <- gsub("Sveta Trojica v Slov. goricah", "Sveta Trojica v Slovenskih goricah", stan$Obcina)
stan$Obcina <- gsub("Sveti Jurij v Slov. goricah", "Sveti Jurij v Slovenskih goricah", stan$Obcina)
stan$Obcina <- gsub("Gorenja vas - Poljane", "Gorenja vas-Poljane", stan$Obcina)
stan$Obcina <- gsub("Hoče - Slivnica", "Hoče-Slivnica", stan$Obcina)
stan$Obcina <- gsub("Izola/Isola", "Izola", stan$Obcina)
stan$Obcina <- gsub("Log - Dragomer", "Log-Dragomer", stan$Obcina)
stan$Obcina <- gsub("Lendava/Lendva", "Lendava", stan$Obcina)
stan$Obcina <- gsub("Dobrovnik/Dobronak", "Dobrovnik", stan$Obcina)
stan$Obcina <- gsub("Hodoš/Hodos", "Hodoš", stan$Obcina)

#zdruzitev centralnega ogrevanja in plac
a1 <- left_join(cent_ogr_poman,placa_indeks_z,by="Obcina")
names(a1) <- c("Obcina","Brez_ogrevanja","Place")

#zdruzitev centralnega ogrevanja in brezposelosti
a2 <- left_join(cent_ogr_poman,brezposelni_z,by="Obcina")
names(a2) <- c("Obcina","Brez_ogrevanja","Brezposelni_ods")

a <- left_join(a1,a2,by="Obcina")
t <- left_join(a,stan,by="Obcina")
t$'delez' <- (t$'Brez_ogrevanja.x' / t$'vrednost')*100

#javna kanalizacija kot pomankljivost
jav_kan_poman <- pomankljivosti %>% filter(tip == "javna_kanalizacija")
jav_kan_poman <- jav_kan_poman[,-2]

#poenotenje imen obcin
jav_kan_poman$Obcina <- gsub("Ankaran/Ancarano", "Ankaran", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Koper/Capodistria", "Koper", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Trebnje)", "Trebnje", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Miren - Kostanjevica", "Miren-Kostanjevica", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Rače - Fram", "Rače-Fram", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Šempeter - Vrtojba", "Šempeter-Vrtojba", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Piran/Pirano", "Piran", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Mokronog - Trebelno", "Mokronog-Trebelno", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Renče - Vogrsko", "Renče-Vogrsko", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Dobrova - Polhov Gradec", "Dobrova-Polhov Gradec", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Hrpelje - Kozina", "Hrpelje-Kozina", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Sveta Trojica v Slov. goricah", "Sveta Trojica v Slovenskih goricah", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Sveti Jurij v Slov. goricah", "Sveti Jurij v Slovenskih goricah", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Gorenja vas - Poljane", "Gorenja vas-Poljane", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Hoče - Slivnica", "Hoče-Slivnica", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Izola/Isola", "Izola", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Log - Dragomer", "Log-Dragomer", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Lendava/Lendva", "Lendava", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Dobrovnik/Dobronak", "Dobrovnik", jav_kan_poman$Obcina)
jav_kan_poman$Obcina <- gsub("Hodoš/Hodos", "Hodoš", jav_kan_poman$Obcina)


  figure.timeseries.larvae = function( outdir ) {
    larvae = read.table(file=file.path(  project.datadirectory("bio.snowcrab"), "data", "larvae", "ts.brachyura.csv"),  sep = "\t")
    colnames(larvae) = c("yr", "mean.n.m3", "sdev", "n")
    larvae$se = larvae$sdev / sqrt(larvae$n-1)

    ts.plotandsave( x=larvae$yr, y=larvae$mean.n.m3, lb=larvae$mean.n.m3-larvae$se, ub=larvae$mean.n.m3+larvae$se,
      w=larvae$n, outdir=outdir, action="save", title="Brachyura", smooth=0.75 )

    l.monthly = read.table(file=file.path(  project.datadirectory("bio.snowcrab"), "data", "larvae", "ts.brachyura.monthly.csv"),  sep = "\t")
    colnames(l.monthly) = c("month", "mean.n.m3", "n")

    x = l.monthly$month
    y = l.monthly$mean.n.m3
    w = l.monthy$n

    xrange = range(-0.5, 12.5)

  fn = file.path(outdir, "BrachyuraMonthly")
   Cairo( file=fn, type="pdf", bg="white", units="in", width=8, height=4 )

    plot( x, y, type="n", axes=F, xlab="Month", xlim=xrange, ylab=toupper("Brachyura"), cex=2 )
    lines( loess( y ~ x, weights=w, control=loess.control(surface = "direct")), col="orange", lty="solid", lwd=4 )

    points(x, y, pch=10)
    axis( 1 )
    axis( 2 )
   dev.off()
    cmd( "convert   -trim -quality 9  -geometry 200% -frame 2% -mattecolor white -antialias ", paste(fn, "pdf", sep="."),  paste(fn, "png", sep=".") )

  }


#' Swaps
#'
#' Methods for swapping between different memuse formats.
#'
#' These methods allow simple (coherent) swaps between the different
#' \code{memuse} formats.
#'
#' \code{swap.unit()} will switch an object to another, supplied unit.  If the
#' unit is from another prefix, then the prefix too will change.  In this case,
#' the size will change appropriately.
#'
#' \code{swap.prefix()} will change an object from one unit.prefix to the
#' other. In this case, the size will change appropriately.
#'
#' \code{swap.names} will change from short to long, or long to short printing.
#' The size and prefix of the object are unchanged.
#'
#' @param x
#' memuse object
#' @param unit
#' new unit for the \code{memuse} object after the swap occurs
#'
#' @return
#' Returns a \code{memuse} class object.
#'
#' @examples
#' \dontrun{
#' x <- mu(1e6)
#'
#' x
#' swap.prefix(x)
#' swap.names(x)
#' swap.unit(x, "bytes")
#' }
#'
#' @seealso \code{ \link{Constructor} \link{memuse-class} }
#' @keywords Methods
#' @name Swaps
#' @rdname swaps
NULL

#' @rdname swaps
#' @export
setGeneric(name="swap.prefix",
  function(x)
    standardGeneric("swap.prefix"),
  package="memuse"
)

#' @rdname swaps
#' @export
setMethod("swap.prefix", signature(x="memuse"),
  function(x)
  {
    if (x@unit.prefix == "IEC")
      new.prefix <- "SI"
    else if (x@unit.prefix == "SI")
      new.prefix <- "IEC"
    else
      mu_error()

    power <- get_power(x)

    if (new.prefix == "IEC")
      x@size <- x@size * (1e3/1024)^power
    else
      x@size <- x@size * (1024/1e3)^power

    x@unit.prefix <- new.prefix

    check.unit(x)
  }
)

#' @rdname swaps
#' @export
setGeneric(name="swap.names",
  function(x)
    standardGeneric("swap.names"),
  package="memuse"
)

#' @rdname swaps
#' @export
setMethod("swap.names", signature(x="memuse"),
  function(x)
  {
    if (x@unit.names == "short")
      new.names <- "long"
    else if (x@unit.names == "long")
      new.names <- "short"
    else
      mu_error()

    new.unit <- which(.units[[x@unit.names]][[x@unit.prefix]][["print"]] == x@unit)

    x@unit <- .units[[new.names]][[x@unit.prefix]][["print"]][new.unit]

    x@unit.names <- new.names

    x
  }
)

#' @rdname swaps
#' @export
setGeneric(name="swap.unit",
  function(x, unit)
    standardGeneric("swap.unit"),
  package="memuse"
)

#' @rdname swaps
#' @export
setMethod("swap.unit", signature(x="memuse"),
  function(x, unit)
  {
    unit <- tolower(unit)

    if (unit==x@unit)
      return(x)

    if (unit == "best")
      x <- best.unit(x)
    else if (unit == tolower(x@unit))
      return( check.mu(x) )
    else {
      flag <- FALSE

      for (names in c("short", "long")){
        for (prefix in c("IEC", "SI")){
          if ( unit %in% .units[[names]][[prefix]][["check"]] ){
            flag <- TRUE
            unit.names <- names
            unit.prefix <- prefix
            break
          }
          if (flag)
            break
        }
      }

      if (flag){
        x <- convert_to_bytes(x)

        x@unit.names <- unit.names
        x@unit.prefix <- unit.prefix

        if (unit.prefix == "IEC")
          f <- 1024
        else
          f <- 1e3

        units <- .units[[x@unit.names]][[x@unit.prefix]][["check"]]
        i <- which(units == unit)

        x@size <- x@size/(f^(i-1))

        new.unit <- .units[[unit.names]][[unit.prefix]][["print"]][i]

        x@unit <- new.unit
      }
      else
        stop("invalid argument 'unit'.  See help('memuse')")
    }

    x
  }
)


# calculates selection index
# and ranks genotypes accordingly
# Isaak Y Tecle iyt2cornell.edu

options(echo = FALSE)

library(data.table)
library(stats)
library(stringi)
library(dplyr)

allArgs <- commandArgs()

inputFiles <- scan(grep("input_files", allArgs, value = TRUE),
                   what = "character")

relWeightsFile <- grep("rel_weights", inputFiles, value = TRUE)

outputFiles <- scan(grep("output_files", allArgs, value = TRUE),
                    what = "character")

traitsFiles <- grep("gebv_files_of_traits", inputFiles, value = TRUE)

gebvsSelectionIndexFile <- grep("gebvs_selection_index",
                                outputFiles,
                                value = TRUE)

selectionIndexFile <- grep("selection_index_only",
                           outputFiles,
                           value=TRUE)

inTraitFiles   <- scan(traitsFiles, what = "character")

traitFilesList <- strsplit(inTraitFiles, "\t");
traitsTotal    <- length(traitFilesList)

if (traitsTotal == 0)
  stop("There are no traits with GEBV data.")
if (length(relWeightsFile) == 0)
  stop("There is no file with relative weights of traits.")

relWeights           <- data.frame(fread(relWeightsFile, header = TRUE))
rownames(relWeights) <- relWeights[, 1]
relWeights[, 1]      <- NULL

if (is.null(relWeights)) {
    stop('There were no relative weights for all the traits.')
}

combinedRelGebvs <- c()

for (i in 1:traitsTotal) {
  traitFile           <- traitFilesList[[i]]
  traitGEBV           <- data.frame(fread(traitFile, header = TRUE))
  rownames(traitGEBV) <- traitGEBV[, 1]
  traitGEBV[, 1]      <- NULL
  traitGEBV           <- traitGEBV[order(rownames(traitGEBV)),,drop=FALSE]
  trait               <- colnames(traitGEBV)

  relWeight <- relWeights[trait, ]

  if (is.na(relWeight) == FALSE && relWeight != 0 ) {

      weightedTraitGEBV <- apply(traitGEBV, 1,
                                 function(x) x*relWeight)

      weightedTraitGEBV <- data.frame(weightedTraitGEBV)
      colnames(weightedTraitGEBV) <- paste0(trait, '_weighted')

      combinedRelGebvs  <- merge(combinedRelGebvs, weightedTraitGEBV,
                                 by = 0,
                                 all = TRUE)

      rownames(combinedRelGebvs) <- combinedRelGebvs[, 1]
      combinedRelGebvs[, 1]      <- NULL
    }
}

sumRelWeights <- apply(relWeights, 2, sum)
sumRelWeights <- sumRelWeights[[1]]

combinedRelGebvs$Index <- apply(combinedRelGebvs, 1, function (x) sum(x))

combinedRelGebvs <- combinedRelGebvs[ with(combinedRelGebvs,
                                           order(-combinedRelGebvs$Index)
                                           ),
                                     ]

combinedRelGebvs <- round(combinedRelGebvs, 2)

selectionIndex <-c()

if (!is.null(combinedRelGebvs)) {
  selectionIndex <- subset(combinedRelGebvs,
                           select = 'Index'
                           )
}

if (gebvsSelectionIndexFile != 0) {
  if (!is.null(combinedRelGebvs)) {
    fwrite(combinedRelGebvs,
           file      = gebvsSelectionIndexFile,
           sep       = "\t",
           row.names = TRUE,
           quote     = FALSE,
           )
      }
}

if (!is.null(selectionIndexFile)) {
  if (!is.null(selectionIndex)) {
    fwrite(selectionIndex,
           file      = selectionIndexFile,
           row.names = TRUE,
           quote     = FALSE,
           sep       = "\t",
           )
  }
}

q(save = "no", runLast = FALSE)


setwd("P:/2019 0970 151 000/User Data/Faraz-Export IDAVE folders/Models2.5")
library(tidyverse)
library(h2o)
library(inspectdf)
tabna <- function(x){table(x, useNA = "ifany")}
dfx <- readRDS("./dfx_v2.5.rds")

h2o.init()
dfx %>% inspect_na() %>% print(n=10)
dfx <- drop_na(dfx)

####

features <- read.csv("mutualInfo_features.csv")
features$X <- levels(features$X)[features$X]
names(features)[1:2] <- c("predictor", "mutInf")
features[grep("^flag", features$predictor), "is_ed"] <- FALSE
features[grep("^patserv", features$predictor), "is_ed"] <- FALSE
features[
which(features$predictor %in% c("acutelos", "scu", "prior_hosp_90d",
"prior_hosp_365d", "readm_90d")), "is_ed"] <- FALSE
features[is.na(features$is_ed), "is_ed"] <- TRUE

# sum(features$is_ed)
# [1] 37
# sum(features$is_ed[1:40])
# [1] 21

sel_feat_ed_small <- features[1:40,] %>% filter(is_ed) %>% .$predictor
sel_feat_ed_big <- features %>% filter(is_ed) %>% .$predictor
sel_feat <- features[1:40,] %>% .$predictor

####

df.hex  <- as.h2o(dfx)
# Now that we have our tuned model and parameters, we train the models on the train sample and test
# on the hold-out test sample
df.split <- h2o.splitFrame(df.hex, ratios = c(0.8), seed = 1234)
train <- df.split[[1]]
test <- df.split[[2]] #unseen data

df.split_valid <- h2o.splitFrame(train, ratios = c(0.8), seed = 1234)

####
#AUTO ML
####
t <- Sys.time()
aml <- h2o.automl(
x = sel_feat_ed_big,
y = "alc_status",
max_models = 50,
training_frame = train,
leaderboard_frame = test,
# validation_frame = df.split_valid[[2]],
balance_classes = TRUE,
nfolds = 5,
stopping_rounds = 5,
stopping_tolerance = 1e-3,
stopping_metric = "AUCPR",
sort_metric = "AUCPR",
seed = 1234)

cat("time elapsed for AutoML: ", Sys.time() - t, "\n")
print(aml@leaderboard, n = nrow(aml@leaderboard))
aml@leaderboard %>% as.data.frame()%>% write.csv("./autoML_EDonly.csv")

t <- Sys.time()
aml_2 <- h2o.automl(
x = sel_feat,
y = "alc_status",
max_models = 50,
training_frame = train,
leaderboard_frame = test,
# validation_frame = df.split_valid[[2]],
balance_classes = TRUE,
nfolds = 5,
stopping_rounds = 5,
stopping_tolerance = 1e-3,
stopping_metric = "AUCPR",
sort_metric = "AUCPR",
seed = 1234)

cat("time elapsed for AutoML: ",  difftime(Sys.time(), t, unit = "hour"), "hours \n")
#Took 27 hours
print(aml_2@leaderboard, n = nrow(aml_2@leaderboard))
aml_2@leaderboard %>% as.data.frame()%>% write.csv("./autoML_EDCIHI.csv")

modH <- new_resultFrame()
modH <- add_cv_results(h2o.getModel(aml_2@leader@model_id), modH)

                                                # Model Hit_Ratio
# 1 StackedEnsemble_BestOfFamily_AutoML_20210705_150745     0.815
  # Mean_PerC_Error LogLoss   AUC AUCPR Recall Precision Specificity max_F1
# 1            0.29   0.303 0.814 0.371  0.572     0.338       0.936  0.425
  # trshold training_AUC training_AUCPR training_Recall training_Precision
# 1   0.159        0.819          0.415           0.555              0.382
  # training_Spec
# 1         0.935
# >

##DOES NOT get better than this #


#calc TSNE for Seurat object
# This function takes initial data from dr@tsne in initSeurObj and initiate by those the coordinates in newSeurObj;
# the cells that are not found in initSeurObj are put at random positions
# program uses Rtsne package and prepares seuratobjects manually
#
# written by Seva Makeev 2017 - 2021

calcTSNEGeneSpace <- function( newSeurObj, perplexity = 20, TSNErandSeed = 25, Norm = FALSE, initSeurObj = NULL){

require( proxy)

if(!require("Rtsne")){
install.packages("Rtsne")}
library("Rtsne")

if(!require("beepr")){
install.packages("beepr")}
library("beepr")

if( is.null(initSeurObj)){ initNew <- NULL}else{

initCells 	<-  GetDimReduction(object = initSeurObj, reduction.type = "tsne",
            		slot = "cell.embeddings")
tsneMin 	<- apply(initCells, 2, min)
tsneMax		<- apply(initCells, 2, max)

newCells 	<- setdiff( colnames(newSeurObj@data), colnames(initSeurObj@data))

#first we put all cells in newSeurObj at random positions
initNew		<- data.frame(
			initCellsX = runif( ncol( newSeurObj@data), min = tsneMin[1], max = tsneMax[1]),
			initCellsY = runif( ncol( newSeurObj@data), min = tsneMin[2], max = tsneMax[2]),
			row.names = colnames( newSeurObj@data)
			)
#and then update those present in initSeurObj with their positions
initNew[ rownames(initCells) , ] <- initCells
}

#now call tsne
distanceMatrix 	<- dist( t( newSeurObj@data), method = "cosine", pairwise = TRUE)
rtsneRes	<- Rtsne( distanceMatrix, is_distance = TRUE,
				perplexity = perplexity,
				theta = 0,
				eta = 500,
				pca = FALSE,
				max_iter = 50000,
				pca_center = FALSE,
				normalize = Norm,
				Y_init = initNew
			)
#and prepare Seurat Obj
tsneData		<- rtsneRes$Y
rownames( tsneData) 	<- colnames( newSeurObj@data)
colnames( tsneData)	<- c("tSNE_1", "tSNE_2")
newSeurObj		<- SetDimReduction( newSeurObj, reduction.type = "tsne", slot = "cell.embeddings", new.data = tsneData)
newSeurObj		<- SetDimReduction(object = newSeurObj, reduction.type = "tsne", slot = "key", new.data = "tSNE")

#newSeurObj <- RunTSNE( newSeurObj, genes.use = rownames(newSeurObj@data), seed.use = TSNErandSeed,
#	theta = 0, eta = 10, max_iter = 3000, perplexity = 15, verbose = FALSE)

beep(3)

return( newSeurObj)
}


#############################################################################
##
#W  id320.r                GAP library of id's             Hans Ulrich Besche
##

ID_GROUP_TREE.next[320].next[18]:=
rec(
  fp:= [ 1822, 4076, 8937, 9617, 10023, 14478, 17138, 17238, 19339, 21999,
22679, 24200, 26860, 27134, 29061, 30200, 32401, 36856, 38479, 39210, 39616,
40696, 42913, 43971, 44809, 45057, 45130, 46578, 47026, 47347, 48832, 49243,
49512, 49564, 51139, 51460, 52272, 53356, 53677, 53693, 54373, 55573, 55894,
56727, 57033, 57713, 57790, 59234, 59793, 60007, 61894, 64095, 71890, 74244,
74650, 79105, 81612, 81765, 83966, 86626, 87306, 88727, 91761, 93588, 94827,
97028, 99129 ],
  level:= 4,
  next:= [ rec(
    fp:= [ 63396, 64472, 85041, 86784, 90159 ],
    next:= [ rec(
      desc:= [ 111003 ],
      fp:= [ 2, 12 ],
      next:= [ 410, 800 ] ), rec(
      desc:= [ 110003 ],
      fp:= [ 4, 14 ],
      next:= [ 405, 798 ] ), rec(
      desc:= [ 111003 ],
      fp:= [ 2, 12 ],
      next:= [ 411, 406 ] ), rec(
      desc:= [ 302007 ],
      fp:= [ 801, 30501 ],
      next:= [ 797, rec(
        desc:= [ 112003 ],
        fp:= [ 2, 12 ],
        next:= [ 401, 404 ] ) ] ), rec(
      desc:= [ 110003 ],
      fp:= [ 2, 12 ],
      next:= [ 407, 801 ] ) ] ), 819, 831, rec(
    fp:= [ 50405, 81251 ],
    next:= [ 446, 818 ] ), rec(
    fp:= [ 32710, 44439, 52438, 80280 ],
    next:= [ 742, 762, 361, 358 ] ), rec(
    fp:= [ 19599, 34938, 37096 ],
    next:= [ 452, 454, 829 ] ), 381, rec(
    fp:= [ 17768, 63867, 88589 ],
    next:= [ rec(
      desc:= [ 107003 ],
      fp:= [ 4, 14 ],
      next:= [ 330, 329 ] ), rec(
      desc:= [ 108003 ],
      fp:= [ 4, 14, 212 ],
      next:= [ rec(
        desc:= [ 302003, 207002 ],
        fp:= [ 2, 12 ],
        next:= [ 476, 477 ] ), 478, 456 ] ), rec(
      desc:= [ 106003 ],
      fp:= [ 8, 18, 414 ],
      next:= [ rec(
        desc:= [ 302004 ],
        fp:= [ 902, 1801 ],
        next:= [ 308, rec(
          desc:= [ 207002 ],
          fp:= [ 8, 18 ],
          next:= [ 326, 309 ] ) ] ), 307, 310 ] ) ] ), rec(
    fp:= [ 27093, 29022, 53264, 80335, 82123 ],
    next:= [ 792, 391, 414, rec(
      desc:= [ 107003 ],
      fp:= [ 4, 14 ],
      next:= [ 795, rec(
        desc:= [ 110003 ],
        fp:= [ 4, 14 ],
        next:= [ 387, 802 ] ) ] ), rec(
      desc:= [ 106003 ],
      fp:= [ 2, 12 ],
      next:= [ 389, 790 ] ) ] ), 768, rec(
    fp:= [ 28140, 73046 ],
    next:= [ 470, 339 ] ), 828, 375, rec(
    fp:= [ 55126, 61257, 62781 ],
    next:= [ 492, 438, 510 ] ), rec(
    fp:= [ 58363, 79237 ],
    next:= [ 782, 780 ] ), 524, 374, rec(
    fp:= [ 4338, 55758, 59333, 67160, 90007 ],
    next:= [ 402, 409, 799, rec(
      desc:= [ 116011 ],
      fp:= [ 4, 14 ],
      next:= [ 403, 796 ] ), 408 ] ), rec(
    fp:= [ 21551, 53353, 59105, 95082 ],
    next:= [ rec(
      desc:= [ 107003 ],
      fp:= [ 8, 18, 414 ],
      next:= [ rec(
        desc:= [ 107007 ],
        fp:= [ 8, 18 ],
        next:= [ rec(
          desc:= [ 302004, 208002 ],
          fp:= [ 8, 18 ],
          next:= [ 708, 720 ] ), rec(
          desc:= [ 302004, 208002 ],
          fp:= [ 8, 18 ],
          next:= [ 719, 705 ] ) ] ), 706, 691 ] ), rec(
      desc:= [ 107003 ],
      fp:= [ 4, 14, 212 ],
      next:= [ rec(
        desc:= [ 302004, 207003 ],
        fp:= [ 2, 12 ],
        next:= [ 648, 658 ] ), 647, 649 ] ), rec(
      desc:= [ 108003 ],
      fp:= [ 4, 14, 212 ],
      next:= [ rec(
        desc:= [ 302003, 206002 ],
        fp:= [ 2, 12 ],
        next:= [ 717, 718 ] ), 721, 690 ] ), rec(
      desc:= [ 110011 ],
      fp:= [ 22, 814 ],
      next:= [ rec(
        desc:= [ 108003 ],
        fp:= [ 4, 14 ],
        next:= [ 709, 707 ] ), rec(
        desc:= [ 108003 ],
        fp:= [ 4, 14 ],
        next:= [ 696, 692 ] ) ] ) ] ), rec(
    fp:= [ 29083, 34801, 67176 ],
    next:= [ rec(
      desc:= [ 114011 ],
      fp:= [ 8, 18, 414 ],
      next:= [ rec(
        desc:= [ 302014 ],
        fp:= [ 422, 841 ],
        next:= [ rec(
          desc:= [ 107003 ],
          fp:= [ 2, 12 ],
          next:= [ 484, 481 ] ), rec(
          desc:= [ 107003 ],
          fp:= [ 2, 12 ],
          next:= [ 504, 502 ] ) ] ), 809, rec(
        desc:= [ 107003 ],
        fp:= [ 13, 211 ],
        next:= [ 420, rec(
          desc:= [ 106003 ],
          fp:= [ 2, 12 ],
          next:= [ rec(
            desc:= [ 111003 ],
            fp:= [ 2, 12 ],
            next:= [ 423, 426 ] ), rec(
            desc:= [ 111003 ],
            fp:= [ 2, 12 ],
            next:= [ 421, 418 ] ) ] ) ] ) ] ), rec(
      desc:= [ 112011 ],
      fp:= [ 8, 18, 414 ],
      next:= [ rec(
        desc:= [ 302004 ],
        fp:= [ 182, 361 ],
        next:= [ rec(
          desc:= [ 106003 ],
          fp:= [ 4, 14 ],
          next:= [ 485, 482 ] ), rec(
          desc:= [ 106003 ],
          fp:= [ 4, 14 ],
          next:= [ 505, 501 ] ) ] ), 808, 419 ] ), rec(
      desc:= [ 112011 ],
      fp:= [ 8, 414 ],
      next:= [ rec(
        desc:= [ 113011 ],
        fp:= [ 8, 18 ],
        next:= [ 503, 483 ] ), 424 ] ) ] ), rec(
    fp:= [ 9951, 18118, 53697, 73150 ],
    next:= [ rec(
      desc:= [ 106003 ],
      fp:= [ 4, 14 ],
      next:= [ rec(
        desc:= [ 109003 ],
        fp:= [ 4, 14 ],
        next:= [ 349, 348 ] ), 366 ] ), 764, 350, 743 ] ), rec(
    fp:= [ 28799, 38952, 43189, 57218, 68824, 91955 ],
    next:= [ rec(
      desc:= [ 107003 ],
      fp:= [ 4, 14 ],
      next:= [ rec(
        desc:= [ 109003 ],
        fp:= [ 4, 14 ],
        next:= [ 671, 670 ] ), 677 ] ), 679, 672, rec(
      desc:= [ 302005 ],
      fp:= [ 401, 14261 ],
      next:= [ 855, rec(
        desc:= [ 110003 ],
        fp:= [ 4, 14 ],
        next:= [ 597, 598 ] ) ] ), 678, 623 ] ), rec(
    fp:= [ 7428, 17332, 25614, 49754, 86169 ],
    next:= [ 681, rec(
      desc:= [ 109003 ],
      fp:= [ 4, 14 ],
      next:= [ 682, 687 ] ), 683, rec(
      desc:= [ 108003 ],
      fp:= [ 4, 14, 212 ],
      next:= [ 634, rec(
        desc:= [ 302005, 208002 ],
        fp:= [ 2, 12 ],
        next:= [ 635, 646 ] ), 636 ] ), 873 ] ), 830, rec(
    fp:= [ 21637, 39935, 55748, 61001, 71737 ],
    next:= [ rec(
      desc:= [ 109003 ],
      fp:= [ 4, 14, 212 ],
      next:= [ 714, rec(
        desc:= [ 302004, 207002 ],
        fp:= [ 2, 12 ],
        next:= [ 710, 711 ] ), 693 ] ), 695, rec(
      desc:= [ 109003 ],
      fp:= [ 4, 14 ],
      next:= [ 716, 713 ] ), 722, 655 ] ), 359, rec(
    fp:= [ 7553, 38442, 44940, 46636, 82043 ],
    next:= [ 866, 669, rec(
      desc:= [ 108003 ],
      fp:= [ 4, 14 ],
      next:= [ rec(
        desc:= [ 110003 ],
        fp:= [ 4, 14 ],
        next:= [ 660, 661 ] ), 667 ] ), 668, 662 ] ), rec(
    fp:= [ 9017, 44611, 95224 ],
    next:= [ 785, 784, 786 ] ), rec(
    fp:= [ 12702, 26037, 62973, 63622, 87933 ],
    next:= [ 676, 630, 674, 675, rec(
      desc:= [ 302006 ],
      fp:= [ 401, 14261 ],
      next:= [ 854, rec(
        desc:= [ 111003 ],
        fp:= [ 4, 14 ],
        next:= [ 594, 595 ] ) ] ) ] ), rec(
    fp:= [ 11797, 22228, 46486, 86741 ],
    next:= [ 698, 869, rec(
      desc:= [ 107003 ],
      fp:= [ 8, 18 ],
      next:= [ 697, 703 ] ), 702 ] ), 804, rec(
    fp:= [ 5692, 6867, 33516, 83056, 83648, 99094 ],
    next:= [ 684, 643, 689, 872, 686, 688 ] ), 449, 845, rec(
    fp:= [ 41879, 46670, 65339 ],
    next:= [ 654, rec(
      desc:= [ 107003 ],
      fp:= [ 8, 18 ],
      next:= [ 715, 712 ] ), 694 ] ), rec(
    fp:= [ 39105, 43687, 48678, 87358 ],
    next:= [ 665, 666, 664, 865 ] ), rec(
    fp:= [ 17246, 28676, 62270, 69679, 85737 ],
    next:= [ 472, rec(
      desc:= [ 109003 ],
      fp:= [ 4, 14, 212 ],
      next:= [ 473, rec(
        desc:= [ 302004, 208002 ],
        fp:= [ 2, 12 ],
        next:= [ 468, 469 ] ), 474 ] ), rec(
      desc:= [ 108003 ],
      fp:= [ 4, 14 ],
      next:= [ 341, 342 ] ), 324, 379 ] ), 673, rec(
    fp:= [ 41568, 47489, 90804, 94624 ],
    next:= [ 699, 701, 704, 868 ] ), 827, rec(
    fp:= [ 14641, 35685 ],
    next:= [ 803, 413 ] ), rec(
    fp:= [ 20786, 74134 ],
    next:= [ 685, 642 ] ), 844, rec(
    fp:= [ 33120, 39667, 42908, 72812 ],
    next:= [ rec(
      desc:= [ 115011 ],
      fp:= [ 8, 414 ],
      next:= [ rec(
        desc:= [ 111003 ],
        fp:= [ 2, 12 ],
        next:= [ 515, 494 ] ), rec(
        desc:= [ 111003 ],
        fp:= [ 2, 12 ],
        next:= [ 441, 442 ] ) ] ), rec(
      desc:= [ 113011 ],
      fp:= [ 8, 18, 414 ],
      next:= [ 514, 815, 440 ] ), rec(
      desc:= [ 114011 ],
      fp:= [ 8, 18, 414 ],
      next:= [ rec(
        desc:= [ 110003 ],
        fp:= [ 2, 12 ],
        next:= [ 511, 489 ] ), 813, rec(
        desc:= [ 302007 ],
        fp:= [ 801, 30501 ],
        next:= [ 435, rec(
          desc:= [ 112003 ],
          fp:= [ 2, 12 ],
          next:= [ 436, 432 ] ) ] ) ] ), rec(
      desc:= [ 113011 ],
      fp:= [ 8, 18, 414 ],
      next:= [ 495, 816, 443 ] ) ] ), 769, 322, 663, 825, 523, 700, 376, rec(
    fp:= [ 25036, 59718 ],
    next:= [ 781, 777 ] ), 400, rec(
    fp:= [ 30475, 56768, 72349, 89143 ],
    next:= [ rec(
      desc:= [ 115011 ],
      fp:= [ 8, 414 ],
      next:= [ rec(
        desc:= [ 302015 ],
        fp:= [ 422, 841 ],
        next:= [ rec(
          desc:= [ 108003 ],
          fp:= [ 2, 12 ],
          next:= [ 498, 497 ] ), rec(
          desc:= [ 108003 ],
          fp:= [ 2, 12 ],
          next:= [ 518, 517 ] ) ] ), 445 ] ), 427, rec(
      desc:= [ 105003 ],
      fp:= [ 2, 12 ],
      next:= [ 425, 812 ] ), rec(
      desc:= [ 109003 ],
      fp:= [ 2, 12 ],
      next:= [ 422, 817 ] ) ] ), rec(
    fp:= [ 1325, 3944, 28961, 39523, 62213 ],
    next:= [ rec(
      desc:= [ 107003 ],
      fp:= [ 4, 14 ],
      next:= [ rec(
        desc:= [ 110003 ],
        fp:= [ 4, 14 ],
        next:= [ 363, 362 ] ), 365 ] ), 761, 741, 364, 360 ] ), rec(
    fp:= [ 989, 18489 ],
    next:= [ 832, 453 ] ), 783, 382, rec(
    fp:= [ 29614, 46757, 58305, 95105 ],
    next:= [ rec(
      desc:= [ 106003 ],
      fp:= [ 2, 12 ],
      next:= [ rec(
        desc:= [ 110003 ],
        fp:= [ 2, 12 ],
        next:= [ 393, 390 ] ), rec(
        desc:= [ 110003 ],
        fp:= [ 2, 12 ],
        next:= [ 386, rec(
          desc:= [ 115011 ],
          fp:= [ 4, 14 ],
          next:= [ 388, 789 ] ) ] ) ] ), 395, rec(
      desc:= [ 105003 ],
      fp:= [ 2, 12 ],
      next:= [ 394, 793 ] ), rec(
      desc:= [ 109003 ],
      fp:= [ 2, 12 ],
      next:= [ 392, 794 ] ) ] ), 770, rec(
    fp:= [ 31908, 62606, 67658, 73428, 87483 ],
    next:= [ 380, 471, 340, rec(
      desc:= [ 107003 ],
      fp:= [ 8, 18, 414 ],
      next:= [ 321, 320, 323 ] ), 475 ] ), 826, rec(
    fp:= [ 3666, 19081, 64718, 67620, 83909 ],
    next:= [ rec(
      desc:= [ 110003 ],
      fp:= [ 4, 14 ],
      next:= [ 434, 491 ] ), rec(
      desc:= [ 114011 ],
      fp:= [ 8, 414 ],
      next:= [ rec(
        desc:= [ 110003 ],
        fp:= [ 2, 12 ],
        next:= [ 509, 490 ] ), 433 ] ), rec(
      desc:= [ 111003 ],
      fp:= [ 2, 12 ],
      next:= [ 512, 493 ] ), rec(
      desc:= [ 110003 ],
      fp:= [ 2, 12 ],
      next:= [ 814, 437 ] ), rec(
      desc:= [ 110003 ],
      fp:= [ 2, 12 ],
      next:= [ 439, 513 ] ) ] ), 787, 525, 373, 778 ] );


source("R/functions/get_score.r")

# load SLE.sig signature genes
sig.list = readRDS("sig/sig.list.RDS")
gene.sig = sig.list$SLE.sig

# load gene expression data
fn.ge = "../generated_data/CHI/CHI_GE_matrix_gene.txt"
dat = fread(fn.ge, data.table = F) %>%
  tibble::remove_rownames() %>% tibble::column_to_rownames("gene") %>%
  data.matrix()

fn.si = "../generated_data/CHI/CHI_sample_info_2_CD38hi.txt"
info = fread(fn.si, data.table=F)

si = with(info, time == 0) # day 0 only
tdat = dat[,si]
tinfo = info[si,]

gi = toupper(rownames(tdat)) %in% toupper(gene.sig)
sum(gi)

ihl = tinfo$Response %in% c("low","high")
X = get_score(tdat[gi,])[ihl]

df = data.frame(subject=tinfo$subject[ihl], SLE.sig=X)

# output scores
fn.out = "results/sig_scores/scores_SLE.sig_MA.txt"
fwrite(df, fn.out, sep="\t")


import_package('ggplot2', attach=TRUE)

#' Plot genomic frequencies of states
#'
#' We extract from the model because chromstaR::genomicFrequencies is only
#' showing the number of bins, not the fraction of the genome covered (if
#' per.mark=FALSE; otherwise, it includes the width - don't know why)
#'
#' @param model  Chromstar model object
#' @return       ggplot2 object (bar graph)
frequencies = function(model) {
    freqs = chromstaR::genomicFrequencies(model)
    fdf = reshape2::melt(as.array(freqs$frequency))
    p = ggplot(fdf, aes(x=Var1, y=value)) +
        scale_y_log10() +
        labs(x="modification", y="number") +
        geom_bar(stat="identity") +
        theme_minimal() +
        theme(axis.text.x = element_text(angle=45, hjust=1))

    if ("Var2" %in% colnames(fdf))
        p + facet_wrap(~ Var2)
    else
        p
}


# 3. faza: Izdelava zemljevida

# Uvozimo zemljevid.
zemljevid <- uvozi.zemljevid("http://e-prostor.gov.si/fileadmin/BREZPLACNI_POD/RPE/OB.zip",
                             "OB/OB", encoding = "Windows-1250")

# Preuredimo podatke, da jih bomo lahko izrisali na zemljevid.
druzine <- preuredi(druzine, zemljevid, "OB_UIME", c("Ankaran", "Mirna"))

# Izračunamo povprečno velikost družine.
druzine$povprecje <- apply(druzine[1:4], 1, function(x) sum(x*(1:4))/sum(x))
min.povprecje <- min(druzine$povprecje, na.rm=TRUE)
max.povprecje <- max(druzine$povprecje, na.rm=TRUE)


library(reshape)
library(ggplot2)

# load data and produce a freq table for each field

# load this one for other analysis
maps_data <- read.table("maps_dataframe",header=T)

# use _primary if building CDF to compare filtered attributes
maps_data <- read.table("maps_dataframe_primary",header=T)

maps_melt <- melt(maps_data)
attach(maps_melt)
#maps_apply <- tapply(Field,Institution,sum)
maps_table <- table(Field)
maps_table <- rev(sort(maps_table))

# plot histogram of fields
plot(maps_table)

# for CDF
maps_frame <- as.data.frame(table(maps_melt$Field,maps_melt$Type))

# no CDF
maps_frame <- as.data.frame(table(maps_melt$Field))

maps_frame <- maps_frame[order(-maps_frame$Freq),]
attach(maps_frame)
# maps_subs <- subset(maps_frame,Freq >= 5)
# plot(maps_subs)

# which have complete crossover?
#maps_subs <- subset(maps_frame,maps_table )
barplot(maps_subs)

detach(maps_melt)
attach(maps_frame)

tag_factor <- factor(maps_frame$Var1, levels=maps_frame$Var1)

postscript("plot-fieldfreq.eps",horizontal=FALSE,onefile=FALSE,paper="special",width=12,height=6)
p <- ggplot(maps_frame, aes(x=tag_factor, y=Freq)) + geom_bar(stat = "identity",fill="slateblue4",colour="slateblue1") + scale_x_discrete(breaks=NULL,name="Fields") + scale_y_discrete(name="Frequency")
p
dev.off()

# 69 attributes in 1 form
# 29/69 are high-level

# CDFs
# show frequency distribution of all attributes

# show freq dist of just high-level attributes

maps_frame_cdf <- melt(maps_frame)
maps_frame_cdf <- ddply(maps_frame_cdf, .(variable), transform, ecd=ecdf(value)(value))
maps_frame_cdf <- subset(maps_frame_cdf,value!=0)

postscript("plot-cdf.eps",horizontal=FALSE,onefile=FALSE,paper="special",width=12,height=6)

p <- ggplot(maps_frame_cdf, aes(x=value)) + scale_x_continuous(breaks=1:10,name="Forms") + scale_y_continuous(name="Field frequency") + stat_ecdf(aes(colour=Var2)) + theme(panel.background = element_rect(fill = "transparent",colour = "black")) + scale_colour_manual(name="Field type",labels=c("High level","Sub-attribute"),values=c("#13456f", "#e02828"))

dev.off()


################################################################################################
# Dependencies
#source("Code/get_dynamic_data.r")

GetUricData <- function(raw.data.name="train") {

	# For a specified dataset in the original contest format, returns
	# a dataset containing only lab information.
	#
	# Args:
	# 	raw.data.name: name of dataset
	#
	# Returns:
	#	A list.  The first element is a list of datasets that correspond to lab tests. The columns
	#   in each dataset consist of subject.id, test delta and test result.
	#	The second element is a vector of column names corresponding to the test result column of
	#	each dataset.
	#
	# Example usage:
	#	#source("Code/get_lab_data.R")
	#	lab.data<-GetLabData("train")

	# Check if RDA version of lab data has been stored
	rda.filename = paste("Data/uric_",raw.data.name,".rda",sep="")
	if (file.exists(rda.filename)) {
		print(paste("loading saved uric data from",rda.filename,sep=" "))
		load(rda.filename)
		print("finished loading")
		return(uric.data)
	}

	# Get raw data
	 data<-GetRawData(raw.data.name)

	# Keep only lab data
	 data <- data[data$form == "Laboratory Data", ]

	uric.data<-TestToData("Uric Acid",data)

	uric.data$test.result[uric.data$test.unit=="mg/dL"]<-
		uric.data$test.result[uric.data$test.unit=="mg/dL"]*59.48

  	# Drop test name and test units
	uric.data<-uric.data[,!(colnames(uric.data) %in% c("test.name","test.unit"))]

	# Sort by subject id and delta
	uric.data<-uric.data[order(uric.data$subject.id,uric.data$lab.delta),]

	# Remove records with missing lab.delta, test.result, or subject.id
	uric.data <- uric.data[!is.na(uric.data$lab.delta)& !is.na(uric.data$test.result)&
    	!is.na(uric.data$subject.id),]

	# Check for duplicate deltas and delete those rows
	# Create combination of subject.ids and deltas
	id<-paste(as.integer(uric.data$subject.id), as.integer(uric.data$lab.delta),sep=".")

	# Check for duplicates in id
	dup<-duplicated(id)

	# Keep only nonduplicates - throws away second record with same delta
	uric.data<-uric.data[!dup,]

	# Rename test.result column
	colnames(uric.data)[colnames(uric.data)=="test.result"]<-"Uric.Acid"

	# Rename delta column
	colnames(uric.data)[colnames(uric.data)=="lab.delta"]<-"Uric.Acid.delta"

  # Create outlier filter if filter does not exist
  num.sd<-4
  filter.filename<-paste("Data/uric_filter",num.sd,"sd.rda",sep="_")
	if (file.exists(filter.filename)) {
	  print(paste("loading saved uric filter from",filter.filename,sep=" "))
	  load(filter.filename)
	}
  else {
    uric.filter<-LabOutlierFilter(Uric.Acid,num.sd)
    save(uric.filter,file=filter.filename)
  }

  # Discard outliers
  uric.data<-LabDiscardOutlier(uric.data,uric.filter)

	# Save dataset to file
	save(uric.data, file = rda.filename)
	return(uric.data)
}


# install.packages("shiny")
library(shiny)

# Divided into two major code segments: server side code and ui side code

# Server side code - the server side code is where your program actually does stuff, ex: performs operations, uses functions etc.
server <- function(input, output) {
  # to show a simple plot in the ui, you have to create a "reactive expression" and then within that expression, create a plot as you normally would within R
  # within the shiny function renderPlot
  output$distPlot <- renderPlot({
    hist(rnorm(input$obs), col = 'darkgray', border = 'white')
  })
}

# ui - ui side is mostly aesthetic and sets the visual layout for your shiny app

# fluidpage is an argument that can be used to intialize your ui
# fluidpages can be sub-divided into different sections for your ui called panels (side panels and main panels)
# side panels usually are where parameter changes are made in the form of drop-down menus, radio buttons and sliders whearas the main panel is usually where you show
# an output of some kind, be it a plot or map or table of some kind
ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      # Important to note that these min, max and value variables can themselves be reactive variables but more on that later
      sliderInput("obs", "Number of observations:", min = 10, max = 500, value = 100)
    ),
    # Our mainpanel is where we will have the plot output
    mainPanel(plotOutput("distPlot"))
  )
)

shinyApp(ui, server)


library(ggplot2)
library(reshape2)

inputFile=parSampleFile1
nameMapFile=parSampleFile2
outputPrefix=paste0(outFile, ".HTO.summary")

cat("inputFile=", inputFile, "\n")
cat("outputPrefix=", outputPrefix, "\n")
cat("nameMapFile=", nameMapFile, "\n")

files=read.table(inputFile, sep="\t", stringsAsFactor=F)

dat=apply(files, 1, function(x){
  dname=x[[2]]
  dfile=x[[1]]
  dd=read.csv(dfile, check.names=F)
  table(dd$HTO.global)
})
colnames(dat)=files$V2
write.csv(dat, file=paste0(outputPrefix, ".csv"), quote=F)

mdat=reshape2::melt(dat)
colnames(mdat)=c("Class", "Sample", "Cell")

png(paste0(outputPrefix, ".global.png"), width=1600, height=1200, res=300)
g<-ggplot(mdat, aes(x=Sample, y=Cell, fill=Class, label=Cell)) + geom_bar(position="stack", stat="identity") + geom_text(size = 3, position = position_stack(vjust = 0.5)) + theme_bw()
print(g)
dev.off()

hasNameMap = ! is.na(nameMapFile)
if (hasNameMap) {
  df = read.table(nameMapFile, sep="\t", stringsAsFactor=F)
  namemap=df$V1
  names(namemap)=df$V2
}

dat=apply(files, 1, function(x){
  dname=x[[2]]
  dfile=x[[1]]
  dd=read.csv(dfile, stringsAsFactors=F, check.names=F)
  dd$HTO.final=dd$HTO.global
  dd$HTO.final[dd$HTO.global=="Singlet"] = dd$HTO[dd$HTO.global=="Singlet"]
  dt=data.frame(table(dd$HTO.final), stringsAsFactors=F)
  dt$Var1=as.character(dt$Var1)
  dt$Sample=dname
  dt
})
mdat=do.call("rbind", dat)
mdat$Cell=mdat$Var1
if (hasNameMap) {
  mdat$Cell[mdat$Var1 %in% names(namemap)] = namemap[mdat$Var1[mdat$Var1 %in% names(namemap)]]
}
mdat=mdat[,c("Sample", "Cell", "Freq")]
colnames(mdat)=c("Sample", "Class", "Cell")

dat=reshape2::dcast(mdat, formula="Sample~Class")
write.csv(dat, file=paste0(outputPrefix, ".csv"), quote=F, row.names=F)

png(paste0(outputPrefix, ".sample.png"), width=1600, height=1200, res=300)
g<-ggplot(mdat, aes(x=Sample, y=Cell, fill=Class, label=Cell)) + geom_bar(position="stack", stat="identity") + geom_text(size = 3, position = position_stack(vjust = 0.5)) + theme_bw()
print(g)
dev.off()


#' @title Bootstrap dissimilarity
#'
#' @description Bootstrap dissimilarity between two vectors of interactions (or
#'   species names).
#'
#' @param lst_vect A list with two character vectors of interactions.
#'
#' @param index The name of the desired index, e.g.: "whittaker", "jaccard",
#'   "sorensen". Character type.
#'
#' @param by Integer. Number of interactions used to increase gradually the
#'   sampled vectors of interactions until all observations are sampled. If `by`
#'   is too small (e.g. 1) then the computation time is very long depending on
#'   your total number of interactions from which samples are taken. As a rule
#'   of thum set `by` to maybe 5-10\\% of your total interactions.
#'
#' @param replace Should sampling be with replacement? Passed to
#'   \code{\link[base]{sample}}.
#'
#' @param size_short Should the total sample size be set by the length of the
#'   shortest vector from `lst_vect`? Logic type (`TRUE` or `FALSE`).
#'
#' @param n_boot Number of desired bootstraps (100 can be enough).
#'
#' @param n_cpu Number of CPU-s to use for parallel processing.
#'
#' @return A matrix of dissimilarities. The number of columns corresponds to
#'   `n_boot` (number of bootstraps). The names of the rows store the sample
#'   size of each sampled chunk. The final value corresponds to the length of
#'   the shortest vector (when `size_short = TRUE`), or to the length of the
#'   longest vector (when `size_short = FALSE`).
#'
#' @examples
#'
#' library(bootdissim)
#' library(bipartite)
#'
#' net1 <- reshape_net(vazarr, seed = 1)
#' net2 <- reshape_net(vazcer, seed = 1)
#'
#' vect <- get_interactions(net1, net2)
#'
#' tst <- boot_dissim(lst_vect = vect,
#'                    index = "whittaker",
#'                    by = 50,
#'                    replace = TRUE,
#'                    size_short = FALSE,
#'                    n_boot = 10,
#'                    n_cpu = 2)
#'
#' @importFrom foreach foreach %dopar% registerDoSEQ
#' @importFrom parallel splitIndices makeCluster stopCluster
#' @importFrom doParallel registerDoParallel
#' @importFrom iterators iter
#'
#' @export
#'
#' @md
boot_dissim <- function(lst_vect,
                        index,
                        by,
                        replace,
                        size_short,
                        n_boot,
                        n_cpu){

  # Detect which of the two vectors is the short one and which is the long one.
  which_short <- which.min(sapply(X = lst_vect, FUN = length))
  which_long <- which(1:2 != which_short)
  vect_short <- lst_vect[[which_short]]
  vect_long <- lst_vect[[which_long]]

  # If the user chooses to use as total sample size the length of the shortest
  # vector, then set is so.
  size <- ifelse(isTRUE(size_short),
                 yes = length(vect_short),
                 no = length(vect_long))

  # Sample the vectors here to get the sample sizes of each chunk so that can be
  # passed later on easily to the results and will end up on the OX axis of the
  # graphs. Avoid to call this in the loop, because it stays constant anyways
  # and otherwise consumes unnecessary time.
  chunks_lst <- sample_vectors(v1 = vect_short,
                               v2 = vect_long,
                               size = size,
                               by = by,
                               seed = 42,
                               replace = replace)
  n <- length(chunks_lst[[1]])
  # same as length(chunks_lst[[2]])
  spl_size <- sapply(chunks_lst[[1]], FUN = length)
  # same as sapply(chunks_lst[[2]], FUN = length)

  # Start parallel processing
  chunks <- parallel::splitIndices(n_boot, n_cpu)
  cl <- parallel::makeCluster(n_cpu)
  doParallel::registerDoParallel(cl)
  i <- NULL # to avoid 'Undefined global functions or variables: i' in R CMD check
  # Compute dissimilarities in parallel
  boot_lst <-
    foreach::foreach(i = iterators::iter(chunks),
                     .errorhandling = 'pass',
                     .export = c("boot_dissim_once",
                                 "sample_vectors",
                                 "get_abc",
                                 "get_beta")) %dopar% {
                                   lapply(i, FUN = function(x) # note the lapply!
                                     boot_dissim_once(vect_short = vect_short,
                                                      vect_long = vect_long,
                                                      index = index,
                                                      size = size,
                                                      by = by,
                                                      replace = replace,
                                                      seed = x, # iterator is passed as seed (values are 1:n_boot)
                                                      n = n)
                                   )
                                 }
  parallel::stopCluster(cl)
  remove(cl)
  foreach::registerDoSEQ()
  # End of parallel processing

  # Prepare results as a matrix. The row names give the sample size of each
  # chunk. There are as many column as the number of bootstraps (n_boot).
  boot_lst <- unlist(boot_lst, recursive = FALSE)
  results <- do.call(what = "cbind", args = boot_lst)
  rownames(results) <- spl_size

  return(results)
}

#' @title Compute dissimilarity for a sample
#'
#' @description Compute dissimilarity between two vectors of interactions (or
#'   species names) for a single run (sample). You will rarely use this function
#'   alone. It was designed to be executed in parallel by
#'   \code{\link[bootdissim]{boot_dissim}}. See more details there.
#'
#' @param vect_short The shorter vectors of interactions.
#'
#' @param vect_long The longer vectors of interactions.
#'
#' @param index,size,by,replace See \code{\link[bootdissim]{boot_dissim}}.
#'
#' @param seed Passed to \code{\link[base]{set.seed}}. Set seed to get
#'   reproducible random results. Is give by the iterator of the loop during the
#'   parallel processing in \code{\link[bootdissim]{boot_dissim}}.
#'
#' @param n Passed from \code{\link[bootdissim]{boot_dissim}}. Is constant
#'   across all bootstrap iterations.
#'
#' @return A vector of dissimilarities. The length of this vector corresponds to
#'   `n`.
#'
#' @export
#'
#' @md
boot_dissim_once <- function(vect_short,
                             vect_long,
                             index,
                             size,
                             by,
                             replace,
                             seed,
                             n){

  chunks_lst <- sample_vectors(v1 = vect_short,
                               v2 = vect_long,
                               size = size,
                               by = by,
                               seed = seed,
                               replace = replace)

  dissim <- rep(NA, n)

  for (i in 1:n){
    v1 <- chunks_lst[["v1"]][[i]]
    v2 <- chunks_lst[["v2"]][[i]]
    abc <- get_abc(list(v1, v2))
    dissim[[i]] <- get_beta(abc, index)
  }

  return(dissim)
}


#Rienje Veenhof and Frank Fluit
#Project for the course Geoscripting at Wageningen University
#28-1-2021
#This file contains a function that calculates difference rasters

dif_func <- function(lockdown_raster, raster_of_interest){
  difference_raster <- raster_of_interest - lockdown_raster
  return(difference_raster)
}


rm(list = ls())
install.packages("ggplot2")
install.packages("latex2exp")
install.packages("GenSA")
install.packages("maxLik")


# function that corrects "sample" execution in the case of only one element in the population (more info: ?sample and ?sample.int)
sample2 <- function(x, ...) x[sample.int(length(x), ...)]


get.effects.from.model = function( lm.model  ) {

    model.statement = formula( lm.model )
    all.variables = all.vars(model.statement)

    if (length( all.variables ) < 2) {
      print (" No results " )
      return ()
    }

    dependent.var = all.variables[1]
    all.terms = attr( terms( model.statement), "term.labels" )

    # general stats (unadjusted medians/quantiles)
    # for main effects that are significant

    # unadjusted effects
    lm.data = lm.model$model  # internal copy of the data table
    results.unadjusted = list()
    for ( effect.variable in all.terms ) {
      print("---")
      print ( paste( effect.variable, " -- unadjusted: ") )
      results.unadjusted[[effect.variable]] =
extract.summary.data.for.one.variable( lm.data[,1],lm.data[,effect.variable])
}
    lm.data$alldata = 1
    results.unadjusted[["alldata"]] =
extract.summary.data.for.one.variable( lm.data[,1], lm.data[,"alldata"])
results.adjusted = NULL
    for ( effect.variable in all.terms ) {
      print( paste( effect.variable, "..." ) )
      res = try( effect( effect.variable, lm.model ), silent=T )
      if (class(res)=="try-error") {
        print( "There was a problem extracting the effects from:" )
        print( effect.variable  )
        print( "And here is the error message:")
        print( res )
        print( "Here is the data and a summary of the data:")
        print( lm.model$model[[effect.variable]] )
        print( summary(lm.model$model[[effect.variable]]) )
        print( "try combining some levels? ..." )
        plot( lm.model$model[[effect.variable]]  )
      } else {
      med = as.vector(summary(res, typical="median")$effect)
      res.summary = summary(res)
      res.effect = res.summary$effect
      m = expand.grid(dimnames(res.effect))
      if (!is.na(dim(res.effect)[2])) {
        n = paste(as.character(m[,1]), as.character(m[,2]), sep=".")
      } else {
        n = as.character(m[,1])
      }

      results.adjusted = rbind(results.adjusted,
        cbind(dependent.var, effect.variable, n , exp(med)-1,
          exp(as.vector(res.summary$effect))-1,
          exp(as.vector(res.summary$lower))-1,
          exp(as.vector(res.summary$upper))-1  ) )

filename = paste("adjusted.means", dependent.var, effect.variable,"png", sep=".")
filename = gsub(":", "__", filename, fixed=T)
      png( filename=filename )
       plot(effect(effect.variable, lm.model ))
      dev.off()

#      win.metafile(filename = graphfile, width = 7, height = 5)
#      plot(effect(effect.variable, lm.model ))
#      dev.off()
     }
    }
    rownames(results.adjusted) = NULL
    colnames(results.adjusted) = c("interval", "effect", "level", "median", "mean", "95%CI.lower", "95%CI.upper")
    results.adjusted = as.data.frame(results.adjusted)
    for (i in 4:6) results.adjusted[,i] = as.numeric(as.character(results.adjusted[,i]))
    print(" *.PNG Figures have been saved in your work directory" )

    return(list( results.unadjusted=results.unadjusted,
results.adjusted=results.adjusted))

}


requrie(ilo)

init_ilo()

require(Rilostat)

country <- get_ilostat(id = 'UNE_2EAP_SEX_AGE_RT_A', filters = list(time = '2017', sex = 'SEX_T', classif1 = 'AGE_YTHADULT_YGE15')) %>% distinct(ref_area) %>% filter(!str_sub(ref_area, 1,1) %in% 'X')

region <- get_ilostat_toc(segment = 'ref_area', search = 'Annual') %>% select(ref_area, wb_income_group.label,ilo_region.label,  ilo_subregion_broad.label, ilo_subregion_detailed.label)  %>% filter(!str_sub(ref_area, 1,1) %in% 'X')

EAP <- get_ilostat(id = 'EAP_2EAP_SEX_AGE_NB_A', filters = list(time = '2017', sex = 'SEX_T', classif1 = 'AGE_YTHADULT_YGE15')) %>% filter(!str_sub(ref_area, 1,1) %in% 'X') %>% select(ref_area, EAP2017 = obs_value)
EAP_income = EAP %>% left_join(region) %>% group_by(wb_income_group.label) %>% summarise(EAP2017_income = sum(EAP2017)) %>% ungroup

country <- country %>% left_join(region, by = "ref_area")

X <- get_ilostat( id = 'EIP_NEET_SEX_RT_A', detail = 'bestsourceonly') %>% select(ref_area, time)

res <- country %>% left_join(X %>% count(ref_area, time) %>% spread(time, n) , by = "ref_area") %>% left_join(EAP , by = "ref_area") %>% save_ilo()

test <- country %>%  count(wb_income_group.label) %>% rename(new = n)
X %>% left_join(EAP) %>%

			filter(!EAP2017 %in% NA) %>%
			left_join(region) %>%
			left_join(EAP_income) %>%
			distinct() %>%
			group_by(wb_income_group.label, time) %>%
			summarise(ref_EAP = sum(EAP2017) / first(EAP2017_income ) * 100) %>%
			ungroup() %>% left_join(test) %>% spread(time, ref_EAP)%>% select(-new)save_ilo()


#set the working dir to current
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)

heart_attack_mortality_histogram <- function() {
	outcome = read.csv("./rprog-data-ProgAssignment3-data/outcome-of-care-measures.csv", colClasses = "character")
	heart_attacks = as.numeric(outcome[,11])
	hist(heart_attacks)
}

heart_attack_mortality_histogram()


pacman::p_load(tidyverse, rio)
pacman::p_load(ggh4x)
pacman::p_load(gganimate)

vas_per <- import("C:/R/Wonderful-Wednesdays/2021-05-12/vas_per.rds")
vas_vis <- import("C:/R/Wonderful-Wednesdays/2021-05-12/vas_vis.rds") %>%
   filter(ady <= 420)

mysqrt_trans <- function() {
   scales::trans_new("mysqrt",
                     transform = base::sqrt,
                     inverse = function(x) ifelse(x<0, 0, x^2),
                     domain = c(0, Inf))
}

axs_df <- crossing(name = c('sym','dose','cumrem','cumrel'),
                   txt = c('a','b','c','d') ) %>%
   as.data.frame() %>%
   mutate(name  = as.factor(name) %>%
             fct_relevel('sym','dose','cumrem','cumrel')) %>%
   filter(name  == 'sym')

for (s in unique(vas_per$subject)) {

   v <- vas_vis %>%
      filter(subject == s) %>%
      select(subject, trt01pc, ady, sym, dose, rem, rel) %>%
      mutate(cumrem = cumsum(rem),
             cumrel = cumsum(rel)) %>%
      select(-rem, -rel) %>%
      pivot_longer(cols = c(sym, dose, cumrem, cumrel)) %>%
      mutate(name = factor(name) %>%
                fct_relevel('sym','dose','cumrem','cumrel'))

   v2 <- v %>%
      rename(ady_2 = ady)

   g1 <- ggplot(data = v,
                aes(x = ady, y = value, group = subject)) +

      geom_segment(data = axs_df,
                   x  = 1, xend = 365, y = 33, yend = 33,
                   arrow = arrow(length = unit(0.05,  "native"), type = "closed"),
                   inherit.aes = FALSE) +
      geom_label(data = axs_df,
                 x = 168, label = "On Treatment",
                 y = 33,
                 size = 2,
                 inherit.aes = FALSE) +
      geom_segment(data = axs_df,
                   x  = 366, xend = 425, y = 33, yend = 33,
                   arrow = arrow(length = unit(0.05,  "native"), type = "closed"),
                   inherit.aes = FALSE) +
      geom_label(data = axs_df,
                 x = 391, label = "Off Treatment",
                 y = 33,
                 size = 2,
                 inherit.aes = FALSE) +
      coord_cartesian(clip = "off") +

      geom_vline(xintercept = c(168, 365), col = 'gray65') +
      geom_line(data = v2,
                aes(x = ady_2, y = value, group = 1),
                size = 1,
                alpha = 0.5,
                color = ifelse(v2$trt01pc == 'T', '#1b9e77', '#d95f02')) +
      geom_line(size = 1, color = ifelse(v$trt01pc == 'T', '#1b9e77', '#d95f02')) +
      geom_point(         color = ifelse(v$trt01pc == 'T', '#1b9e77', '#d95f02')) +
      facet_wrap(~name,
                 strip.position = 'left',
                 ncol = 1,
                 scales = 'free_y',
                 labeller = as_labeller(c(sym    = "Vasculitis symptom score \n(sqrt)",
                                          dose   = "Oral Corticosteroid dose \n(log+1)",
                                          cumrem = "Remission Event \n(cumulative)",
                                          cumrel = "Relapse Event\n(cumulative sqrt)"))
      ) +
      facetted_pos_scales(y = list(scale_y_continuous(limits = c(0, 28),
                                                      trans = 'mysqrt',
                                                      breaks = c( 0,  1,  4,  10,  20),
                                                      labels = c('0','1','4','10','20'),
                                                      minor_breaks = NULL,
                                                      expand = c(0.03, 0.01)),
                                   scale_y_continuous(limits = c(0, 1280),
                                                      breaks = c( 0,  2,  7.5,  25,  75,  250,  750), # seq(0, 35, by = 5)^2,
                                                      labels = c('0','2','7.5','25','75','250','750'),
                                                      expand = c(0.03, 0.01),
                                                      trans = "log1p",
                                                      minor_breaks = NULL),
                                   scale_y_continuous(limits  = c(0,350),
                                                      breaks = c(0, 100, 200, 300),
                                                      expand = c(0.03, 0.01),
                                                      minor_breaks = NULL),
                                   scale_y_continuous(limits  = c(0,11),
                                                      trans = 'mysqrt',
                                                      breaks = c(0, 1, 4, 9),
                                                      expand = c(0.03, 0.01),
                                                      minor_breaks = NULL))
      )  +
      scale_x_continuous(name = "Study Day",
                         limits = c(0, 420),
                         breaks = c(1, 168, 365, 420),
                         labels = c("1", "168 days\n 24 wks", "365 days\n 52 wks", "420 days\n 60 wks"),
                         expand = c(0.01, 0.01),
                         minor_breaks = NULL) +
      force_panelsizes(rows = c(1,1,0.5,0.5),
                       respect = FALSE) +
      labs(y = NULL) +
      theme_bw(base_size = 10) +
      theme(plot.margin = unit(c(1.5, 0.5, 0.5, 0.5), units="lines"),
            strip.placement = "outside",
            axis.text.x = element_text(hjust = 1)) +
      transition_reveal(ady, range=c(1L, 420L))

   a_g1 <- animate(g1,
                   nframes = 100,
                   width  = 6.0,
                   height = 7.0,
                   units = 'in',
                   res = 96,
                   end_pause = 25)

   anim_save(filename = str_glue("subject_{s}.gif"),
             a_g1,
             path = "C:/R/Wonderful-Wednesdays/2021-05-12/vas-subject-gif/")
}


test_that("Reach trimming works", {
	skip_on_cran()
	ws = readRDS(system.file("testdata/ws_intersect/ws.rds", package="WatershedTools"))
	expect_error(ws_trim <- trim_reaches(ws, 200), regex=NA)
	expect_lt(length(unique(ws_trim$data$reachID)), length(unique(ws$data$reachID)))
	expect_equal(nrow(ws_trim$reach_adjacency), length(unique(ws_trim$data$reachID)))

	# check headwater reach lengths
	rch_len = tapply(ws_trim$data$length, ws_trim$data$reachID, sum)
	hw = headwaters(ws_trim)$reachID
	rch_len = rch_len[names(rch_len) %in% as.character(hw)]
	expect_gte(min(rch_len), 200)
})

ws = readRDS(system.file("testdata/testWS.rds", package="WatershedTools"))
test_that("Reach resizing works", {
	skip_on_cran()
	expect_error(ws_rsz <- resize_reaches(ws, 500, 200), regex=NA)
	## parallel or not shouldn't matter
	expect_identical(ws_rsz, resize_reaches(ws, 500, 200, parallel=FALSE))

	rch_len = tapply(ws_rsz$data$length, ws_rsz$data$reachID, sum)
	expect_gt(length(unique(ws_rsz$data$reachID)), length(unique(ws$data$reachID)))
	expect_equal(nrow(ws_rsz$reach_adjacency), length(unique(ws_rsz$data$reachID)))
	expect_gte(min(rch_len), 200)
	# max size is the size + min_size + 2sqrt(2)res(ws)
	expect_lte(max(rch_len), 500+200+28)
})

test_that("Reach Adjacency", {
	hw = headwaters(ws)$reachID
	expect_error(adj <- sapply(hw, function(i) WatershedTools:::reachAdj(ws, i)), regex=NA)
	expect_true(all(sapply(adj, is.null)))
	rch = unique(ws$data$reachID)
	rch = rch[!rch %in% hw]
	expect_error(adj <- sapply(rch, function(i) WatershedTools:::reachAdj(ws, i)), regex=NA)
	expect_gte(nrow(adj), length(rch))
})


#' howbig
#'
#' Determines the memory usage for a dense, in-core, numeric matrix of
#' specified rows/columns.
#'
#' @details
#' These functions provide the memory usage of an unallocated, dense, in-core,
#' numeric matrix.  As the name suggests, \code{howbig()} simply returns the
#' size (as a \code{memuse} object).
#'
#' @param nrow,ncol
#' Number of (global) rows/columns of the matrix.
#' @param representation
#' The kind of storage the object would be in, i.e. "dense" or "sparse".
#' @param unit
#' string; the unit of storage, such as "MiB" or "MB", depending on
#' prefix.  Case is ignored.
#' @param prefix
#' string; the unit prefix, namely IEC or SI.  Case is ignored.
#' @param names
#' string; control for whether the unit names should be
#' printed out or their abbreviation should be used.  Options are "long" and
#' "short", respectively.  Case is ignored.
#' @param ...
#' Additional arguments.
#' @param sparsity
#' The proportion of sparsity of the matrix if
#' \code{representation="sparse"}
#' @param type
#' "double" or "int"; the storage type of the data matrix.  If you
#' don't know the type, it is probably stored as a double, so the default value
#' will suffice.
#' @param intsize
#' The size (in bytes) of an integer.  Default is 4, but this is
#' platform dependent.
#'
#' @return
#' returns a \code{memuse} class object.
#'
#' @examples
#' \dontrun{
#' # size of a 1000x1000 matrix
#' howbig(1000, 1000)
#' }
#'
#' @seealso \code{\link{howmany}}
#' @export
howbig <- function(nrow=1, ncol=1, representation="dense", unit="best", prefix="IEC", names="short", ..., sparsity=0.05, type="double", intsize=4)
{
  type <- match.arg(tolower(type), c("double", "integer"))

  x <- internal.mu(size=1, unit="b", unit.prefix=prefix, unit.names=names)

  bytes <- check_type(type=type, intsize=intsize)

  x@size <- nrow*ncol*bytes # number of bytes used

  representation <- match.arg(tolower(representation), c("dense", "sparse"))

  if (representation == "sparse")
  {
    if (sparsity < 0 || sparsity > 1)
      stop("argument 'sparsity' should be between 0 and 1")
    else
      x <- sparsity * x
  }

  swap.unit(x, unit)
}


context("check_wkt")

test_that("regular wkt works", {
  aa <- check_wkt('POLYGON((30.1 10.1, 10 20, 20 60, 60 60, 30.1 10.1))')
  bb <- check_wkt('POINT(30.1 10.1)')
  cc <- check_wkt('LINESTRING(3 4,10 50,20 25)')

  expect_is(aa, "character")
  expect_equal(aa, 'POLYGON((30.1 10.1, 10 20, 20 60, 60 60, 30.1 10.1))')

  expect_is(bb, "character")
  expect_equal(bb, 'POINT(30.1 10.1)')

  expect_is(cc, "character")
  expect_equal(cc, 'LINESTRING(3 4,10 50,20 25)')
})

test_that("check many passed in at once", {
  aa <- check_wkt(c('POLYGON((30.1 10.1, 10 20, 20 60, 60 60, 30.1 10.1))',
                    'POINT(30.1 10.1)'))

  expect_is(aa, "character")
  expect_equal(length(aa), 2)
})

test_that("many wkt's, semi-colon separated, for many repeated geometry args", {
  wkt <- "POLYGON((-102.2 46.0,-93.9 46.0,-93.9 43.7,-102.2 43.7,-102.2 46.0));POLYGON((30.1 10.1, 10 20, 20 40, 40 40, 30.1 10.1))"
  aa <- check_wkt(wkt)

  expect_is(wkt, "character")
  expect_is(aa, "character")
  expect_equal(length(wkt), 1)
  expect_equal(length(aa), 2)
  expect_true(grepl(";", wkt))
  expect_false(any(grepl(";", aa)))
})

test_that("bad WKT fails well", {
  expect_error(
    check_wkt('POLYGON((30.1 10.1, 10 20, 20 60, 60 60, 30.1 a))'),
    "bad lexical cast: source type value could not be"
  )

  expect_error(
    check_wkt('POLYGON((30.1 10.1, 10 20, 20 60, 60 60, 30.1 a))'),
    "bad lexical cast: source type value could not be"
  )
})


setwd("P:/2019 0970 151 000/User Data/Faraz-Export IDAVE folders/Models2.5/")
library(tidyverse)
df <- read.csv("../datasets/New/bigCihi.csv")
tabna <- function(x){table(x, useNA = "ifany")}

##df is mostly big Cihi + alc_status

df %>% filter(alclos == 0) %>% select(alc_status) %>% tabna
# x
      # 0       1
# 1300004     279
df %>% filter(alclos > 0) %>% nrow()
# [1] 174002
tabna(df$alc_status)
# x
      # 0       1
# 1300057  174228

 df %>%
group_by(  entry )%>%
summarise(count = n(),
count_perc = count / nrow(df) * 100,
alc_perc = mean(as.numeric(as.character(alc_status))) * 100)

 df %>%
group_by(  admcat )%>%
summarise(count = n(),
count_perc = count / nrow(df) * 100,
alc_perc = mean(as.numeric(as.character(alc_status))) * 100)

########################
#########################New outcome variable
########################

df_alc <- df %>% select(ID, days_to_lefteddate, alclos)

dfx <- left_join(dfx, df_alc, by = c("ID", "days_to_lefteddate"))

dfx <- dfx %>% mutate(alc_30 = ifelse(alclos >= 30, 1, 0) %>% factor)
dfx <- dfx %>% mutate(alc_10 = ifelse(alclos >= 10, 1, 0) %>% factor)
dfx <- dfx %>% mutate(alc_5 = ifelse(alclos >= 5, 1, 0) %>% factor)

#######################
dfx <- drop_na(dfx)
df.hex  <- as.h2o(dfx)

df.split <- h2o.splitFrame(df.hex, ratios = c(0.8), seed = 1234)
train <- df.split[[1]]
test <- df.split
df.split_valid <- h2o.splitFrame(train, ratios = c(0.8), seed = 1234) #validation set to size of 5-fold

df.hex_gbmNew <- h2o.gbm(
training_frame = train,
x = sel_feat,
y = "alc_30",
model_id = "gbm_alc30_noParam",
nfolds = 5,
fold_assignment = "Stratified",
balance_classes = TRUE,
ntrees = 500,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5,
#score_each_iteration = T, #wrong if used with above argument (I guess!)
seed = 1234
)

modH <- new_resultFrame()
modH <- add_cv_results(df.hex_gbmNew, modH)
#very low AUCPR

#############Checking if important predictors are the same
library(infotheo)
X <- dfx %>% select(-c(1:4), - alc_status, -alclos, -alc_30)
res <- X %>% sapply(function(x){
mutinformation(x, dfx$alc_status, method = "emp") / sqrt(entropy(x) * entropy(df$alc_status)) })
#SAME MOSTLY
# write.csv(res[order(-res)], "./mutualInfo_features.csv")
# feat_rank <- res[order(-res)] %>% as.data.frame()

#############Bringing some tuned models

##Loading top 5 GBM models
gbm_models <- c()
path <- "./hypeTune_results/top5_gbm_models_cv"
model_names <- grep("^GBM_model", list.files(path), value=T)
for(model in model_names){
	gbm_models <- c(gbm_models, h2o.loadModel(paste(path, model, sep = "/")))
}

res <- new_resultFrame()
newGBM <- c()
for (i in c(1:5)){

gbm <- gbm_models[[i]]
newGBM <- c(newGBM, do.call(h2o.gbm,
	#update parameters models, original models were cross validated, no need for that now, also change predictors in here
	{
		p <- gbm@parameters
		p$model_id = paste0("GBM_ed_small_", i)
		p$training_frame = train
		p$validation_frame = test
		p$nfolds = NULL
		p$fold_assignment = NULL
		p$ntrees = 1000
		p$x = sel_feat
		p$y = "alc_30"
		p$stopping_rounds = 5
		p$stopping_tolerance = 1e-4
		p$score_tree_interval = 10
		p$sample_rate = NULL
		p
	}))
res <- add_results(newGBM[[i]], res)
}

#even worse results,
#Lets Tune gbm for alc_30 prediction

hyper_params = list(max_depth = c(4,6,8,12,16,20))
t <- Sys.time()
grid <- h2o.grid(
hyper_params = hyper_params,
search_criteria = list(strategy = "Cartesian"),
algorithm = "gbm",
grid_id = "depth_grid_gbm",
balance_classes = TRUE,
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
x = sel_feat,
y = "alc_30",
ntrees = 10000, #just some big number
learn_rate = 0.05,
learn_rate_annealing = .99,
sample_rate = 0.8,
col_sample_rate = 0.8,
#sample_rate_per_class = c(1, 8.3), #For the resampling inside trees ---will igonre sample_rate
seed = 1234,
stopping_rounds = 5,
stopping_tolerance = 1e-4, ##early stop if AUCPR did not improve at least 0.01% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 10
)
print(Sys.time() - t)
#Sort base on validation perf

depth_res <- new_resultFrame()
sortedGrid <- h2o.getGrid("depth_grid_gbm", sort_by = "AUCPR", decreasing = TRUE)

depths <- sortedGrid@summary_table$max_depth[1:3]
max_depth <- max(depths) %>% as.integer
min_depth <- min(depths) %>% as.integer

##############Depth span is found, now going for the next hypTune step

hyper_params <- list(
	max_depth = seq(min_depth, max_depth, 1),
	# sample_rate = seq(0.2, 1, 0.01),
	sample_rate_per_class = lapply(seq(0.4, 1, 0.01), function(x){x * c(0.12, 1)}),
	col_sample_rate = seq(0.4, 1, 0.01),
	col_sample_rate_per_tree = seq(0.4, 1, 0.01),
	col_sample_rate_change_per_level = seq(0.9, 1.1, .01),
	min_rows = 2 ^ seq(0, log2(nrow(df.split_valid[[1]]))-1,1),
	# nbins = 2 ^ seq(1,6, 1),
	# nbins_cats = 2 ^ seq(1,6, 1),
	min_split_improvement = c(0, 1e-8, 1e-6, 1e-4),
	histogram_type = c("UniformAdaptive", "QuantilesGlobal", "RoundRobin")
)

search_criteria = list(
strategy = "RandomDiscrete", #random grid search
max_runtime_secs = 3600 * 1,
max_models = 500,
seed = 1234,
stopping_rounds = 5,
stopping_metric = "AUCPR", #Try with AUC also
stopping_tolerance = 1e-4
)

t <- Sys.time()
grid <- h2o.grid(
hyper_params = hyper_params,
search_criteria = search_criteria,
algorithm = "gbm",
grid_id = "final_grid_gbm_alc_30",
# nfolds = 5,
# fold_assignment = "Stratified",
balance_classes = TRUE,
x = sel_feat,
y = "alc_30",
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
nbins_cats = 16, # instead of 1024 default
ntrees = 10000,
learn_rate = 0.05,
learn_rate_annealing = 0.99,
max_runtime_secs = 3600, #for each model
stopping_rounds = 5,
stopping_metric = "AUCPR", #Try with AUC also
stopping_tolerance = 1e-4,
score_tree_interval = 10,
seed = 1234
)
print(Sys.time() - t)
sortedGrid <- h2o.getGrid("final_grid_gbm_alc_30", sort_by = "AUCPR", decreasing = TRUE)

###Rerrun overnight

################
#What if we used alc_10 or alc_5

df.hex_gbmNew2 <- h2o.gbm(
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
x = sel_feat,
y = "alc_10",
model_id = "gbm_alc10_noParam",
balance_classes = TRUE,
ntrees = 500,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5,
#score_each_iteration = T, #wrong if used with above argument (I guess!)
seed = 1234
)

modH <- add_results(df.hex_gbmNew2, modH)

df.hex_gbmNew3 <- h2o.gbm(
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
x = sel_feat,
y = "alc_5",
model_id = "gbm_alc5_noParam",
balance_classes = TRUE,
ntrees = 500,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5,
#score_each_iteration = T, #wrong if used with above argument (I guess!)
seed = 1234
)

modH <- add_results(df.hex_gbmNew3, modH)

              # Model Hit_Ratio Mean_PerC_Error LogLoss   AUC AUCPR Recall
# 1 gbm_alc30_noParam     0.970           0.381   0.058 0.865 0.116  0.258
# 2 gbm_alc10_noParam     0.908           0.330   0.148 0.836 0.214  0.407
# 3  gbm_alc5_noParam     0.852           0.303   0.219 0.822 0.285  0.513
  # Precision Specificity max_F1 trshold training_AUC training_AUCPR
# 1     0.156       0.989  0.195   0.094        0.879          0.868
# 2     0.220       0.971  0.286   0.136        0.841          0.823
# 3     0.263       0.956  0.348   0.169        0.827          0.804
  # training_Recall training_Precision training_Spec
# 1           0.874              0.749         0.849
# 2           0.877              0.706         0.837
# 3           0.871              0.693         0.827


hoge <- read.csv("synthesized_info.csv")
par(mfrow=c(3,1))
plot(hoge$lifetime, hoge$average.bug, xlab="lifetime [day]", ylab="# of bug per month")
abline(v=869, lty=2)
plot(hoge$commit.interval, hoge$average.bug, xlab="commit interval [day]", ylab="# of bug per month")
abline(v=31, lty=2)
plot(hoge$co.evolution.rate, hoge$average.bug, xlab="co-evolution rate", ylab="# of bug per month")
abline(v=0.100, lty=2)
dev.copy2eps(file="../kousatsu1.eps")


#' shaq
#'
#' Constructor for shaq objects.
#'
#' @details
#' If \code{nrows} and/or \code{ncols} is missing, then it will be imputed.
#' This means one must be especially careful to manually provide \code{ncols}
#' if some of ranks have "placeholder data" (a 0x0 matrix), which is typical
#' when reading from a subset of processors and then broadcasting out to the
#' remainder.
#'
#' @section Communication:
#' If \code{checks=TRUE}, a check on the global number of rows is performed.
#' This amounts to an allgather operation on a logical value (the local
#' dimension check).
#'
#' @param Data
#' The local submatrix.
#' @param nrows,ncols
#' The GLOBAL number of rows and columns.
#' @param checks
#' Logical. Should some basic dimension checks be performed?  Note that these
#' require communication, and with many MPI ranks, could be expensive.
#'
#' @seealso
#' \code{\link{shaq-class}}
#'
#' @name shaq
#' @rdname shaq
#' @export
shaq <- function (Data, nrows, ncols, checks=TRUE)
{
  UseMethod("shaq", Data)
}

intuit.shaq.nrows = function(Data)
{
  rowcheck = allreduce(NROW(Data))
  rowcheck
}

check.shaq.ncols = function(Data, ncols)
{
  colcheck = comm.all(NCOL(Data) == ncols)
  if (!isTRUE(colcheck))
    comm.stop("local column dimensions disagree across ranks")
}

check.shaq = function(Data, nrows, ncols)
{
  check.shaq.ncols(Data, ncols)

  nrows = intuit.shaq.nrows(Data)

  return(nrows)
}

#' @rdname shaq
#' @export
shaq.matrix = function(Data, nrows, ncols, checks=TRUE)
{
  if (!missing(nrows))
    check.is.natnum(nrows)
  if (!missing(ncols))
    check.is.natnum(ncols)
  check.is.flag(checks)

  if (missing(nrows) || missing(ncols))
  {
    if (missing(nrows))
      nrows = intuit.shaq.nrows(Data)

    if (missing(ncols))
      ncols = NCOL(Data)
  }
  else if (checks)
    nrows = check.shaq(Data, nrows, ncols)

  new("shaq", Data=Data, nrows=nrows, ncols=ncols)
}

#' @rdname shaq
#' @export
shaq.numeric = function(Data, nrows, ncols, checks=TRUE)
{
  if (!missing(nrows))
    check.is.natnum(nrows)
  if (!missing(ncols))
    check.is.natnum(ncols)
  check.is.flag(checks)

  if (missing(nrows) || missing(ncols))
  {
    if (missing(nrows) && missing(ncols))
    {
      nrows = length(Data)
      ncols = 1L
    }
    else if (missing(nrows))
      nrows = 1L
    else if (missing(ncols))
      ncols = 1L
  }

  size = comm.size()
  base = nrows %/% size
  rem = nrows - base*size
  nrows.local = base
  if (comm.rank()+1L < rem)
    nrows.local = nrows.local + 1

  Data = matrix(Data, as.integer(nrows.local), ncols)

  new("shaq", Data=Data, nrows=nrows, ncols=ncols)
}


rm(list = ls())
gc()

setwd("~/Desktop/Code/laplace_approximation/Script")
library(stringr)
library(rstan)

# Use function from http://stla.github.io/stlapblog/posts/Numextract.html
# to convert strings to the requisite numbers.
Numextract <- function(string){
  unlist(regmatches(string,gregexpr("[[:digit:]]+\\.*[[:digit:]]*",string)))
}

# Read in data
synth <- read.csv("synth_data/testdata.csv")

nrow = 500  # 250
ncol = 3

if (FALSE) {
  synth_matrix <- matrix(nrow = nrow, ncol = ncol)
  for (i in 1:nrow) {
    dat_str <- toString(synth[i, 1])
    synth_matrix[i, ] <- as.numeric(Numextract(dat_str))
  }
  synth_data <- as.data.frame(synth_matrix)
  names(synth_data) <- c("x1", "x2", "y")

  # augment data to get a 500 dimensional latent variable
  x1 <- c(synth_data$x1, synth_data$x1 * runif(nrow, 1, 1.1))
  x2 <- c(synth_data$x2, synth_data$x2 * runif(nrow, 1, 1.1))
  y <- c(synth_data$y, synth_data$y)
}

if (TRUE) {
  synth_data <- synth
  x1 <- synth_data$x1
  x2 <- synth_data$x2
  y <- synth_data$y
  y[y == -1] <- 0  # express -1 as 0
}

sim_data <- data.frame(x1, x2, y)

# Write data for C++ unit tests.
output_directory <- "aki_synth_data"
write.table(t(x1), file = file.path(output_directory, paste0("x1.csv")),
            row.names = FALSE, col.names = FALSE, quote = FALSE, sep = " ")
write.table(t(x2), file = file.path(output_directory, paste0("x2.csv")),
            row.names = FALSE, col.names = FALSE, quote = FALSE, sep = " ")
write.table(t(y), file = file.path(output_directory, paste0("y.csv")),
            row.names = FALSE, col.names = FALSE, quote = FALSE, sep = " ")

###############################################################################
## Write data for Stan

make_data <- function(n_obs) {
  x1 <- sim_data$x1
  x2 <- sim_data$x2
  y <- sim_data$y

  if (n_obs <= 500) {
    data_stan <- sim_data[sample(1:500, n_obs), ]
  } else {
    for (i in (500 + 1):n_obs) {
      index <- sample(1:500, 1)
      x1 <- c(x1, sim_data$x1[index] * runif(1, 0.9, 1.1))
      x2 <- c(x2, sim_data$x2[index] * runif(1, 0.9, 1.1))
      y <- c(y, sim_data$y[index])
    }
    data_stan <- data.frame(x1, x2, y)
  }
  data_stan_ls <- with(data_stan, list(n_obs = n_obs,
                                       n_covariates = 2,
                                       y = y,
                                       x = cbind(x1, x2)))

  with(data_stan_ls, stan_rdump(ls(data_stan_ls),  # FIX ME
    paste0("data/data_gp/data_gp", n_obs, ".R")))
}

dimension <- c(10, 100, 250, 500, 750, 1000, 5000)
for (i in 1:length(dimension)) make_data(dimension[i])

# Write data for Stan (only use original data set, that is first
# 250 entries)
original_data <- sim_data[1:250, ]
data_org_stan <- with(original_data, list(n_obs = 250,
                                          n_covariates = 2,
                                          y = y,
                                          x = cbind(x1, x2)))
with(data_org_stan, stan_rdump(ls(data_org_stan), "data/data_gp/data_gp.R"))

###############################################################################
## Read data for desease map model in Finland
disease_data <- read.table("aki_disease_data/spatial1.txt")
names(disease_data) <- c("x1", "x2", "ye", "y")

# write data for C++ unit tests.
output_directory <- "aki_disease_data"
write.table(t(disease_data$x1),
            file = file.path(output_directory, paste0("x1.csv")),
            row.names = FALSE, col.names = FALSE, quote = FALSE, sep = " ")
write.table(t(disease_data$x2),
            file = file.path(output_directory, paste0("x2.csv")),
            row.names = FALSE, col.names = FALSE, quote = FALSE, sep = " ")
write.table(t(disease_data$ye),
            file = file.path(output_directory, paste0("ye.csv")),
            row.names = FALSE, col.names = FALSE, quote = FALSE, sep = " ")
write.table(t(disease_data$y),
            file = file.path(output_directory, paste0("y.csv")),
            row.names = FALSE, col.names = FALSE, quote = FALSE, sep = " ")

# output data for Stan file
disease_stan <- with(disease_data, list(n_obs = 911,
                                        n_covariates = 2,
                                        y = y,
                                        ye = ye,
                                        x = cbind(x1, x2)))

with(disease_stan, stan_rdump(ls(disease_stan), "data/disease_data_full.r"))


print("About to read netcdf data.")

library(ncdf4)
nc_data <- nc_open('cfplot_data/ggap.nc')
lon <- ncvar_get(nc_data, "longitude")
lat <- ncvar_get(nc_data, "latitude")
U <- ncvar_get(nc_data, "U")

print("About to plot netcdf data to screen.")

library(raster)

U.slice <- U[,,1]
r <- raster(t(U.slice), xmn=0, xmx=360, ymn=-90, ymx=90, crs=CRS("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs+ towgs84=0,0,0"))

plot(r)

print("Finished plotting. Waiting 5")
Sys.sleep(5)
print("Goodbye.")


N_0 <- 1000
y_0 <- 100

N <- 1000
y <- 200

cc <- 1
dd <- 1

nu <- 1
eta <- 1


sample_and_summarise = function(generated,stan_mod_for_sampling){
	csv_base = paste(as.list(generated$gen_args),collapse='_')
	sampled = stan_mod_for_sampling$sample(
		data = generated$data_for_stan
		, chains = parallel::detectCores()/2
		, parallel_chains = parallel::detectCores()/2
		, show_messages = F
		, refresh = 1
		, output_dir = 'stan_temp'
		, output_basename = csv_base
		, seed = abs(digest::digest2int(digest::digest(generated$data_for_stan,algo='xxhash64')))
	)
	#get ranks & other summaries
	(
		sampled$draws()
		%>% posterior::as_draws_df()
		%>% as_tibble()
		%>% select(-.chain,-.iteration)
		%>% pivot_longer(-.draw)
		%>% left_join(generated$true_pars,by='name')
		%>% filter(
			!is.na(true)
		)
		%>% rename(variable=name)
		%>% group_by(variable)
		%>% summarise(
			rank = mean(true>value)
			, true = true[1]
			, .groups = 'drop'
		)
		%>% left_join(
			(
				sampled$draws()
				%>% posterior::summarise_draws(
					posterior::default_convergence_measures()
				)
			)
			, by = 'variable'
		)
		%>% left_join(
			(
				sampled$draws()
				%>% posterior::summarise_draws(
					~posterior::quantile2(.x,probs=c(.1,.25,.5,.75,.9))
				)
			)
			, by = 'variable'
		)
	) -> posterior_summary
	(
		sampled$sampler_diagnostics()
		%>% posterior::as_draws_df()
		%>% summarise(
			max_treedepth = max(treedepth__)
			, num_divergent = sum(divergent__)
			, var_energy = var(energy__)
		)
		%>% mutate(
			time = sampled$time()$total
			, var_summary = list(posterior_summary)
			, model = str_replace(
				basename(stan_mod_for_sampling$stan_file())
				, fixed('.stan')
				, ''
			)
		)
		%>% bind_cols(generated$gen_args)
	) -> to_return
	#delete the csvs
	system(paste0('rm stan_temp/',csv_base,'*'))
	return(to_return)
}


#
# generate multi-day events from summarized GHCD data
# - expects GHCD format input CSV files, named by station and year in 'tmp' subdirectory
#     (created by fileterData.py)
# - expects seaonsalseaonabl baseline data for all stations in a single CSV file 'season_baseline.csv' in the 'out' subdirectory
#     (this is created by summarize.r)
# - writes output temperature events CSV into 'out' subdirectory

# D. Dorsettt 20-Jul-2019

library(tidyverse)
library(lubridate)
library(here)
setwd("E:/WeatherData/out")

stations <- c("USW00014764","USW00014739","USW00014758","USW00094789","USW00013739","USW00093721","USW00013750","USW00013748","USW00013782","USC00084366","USW00012849","USW00092811")

# pull baseline data
season_baseline <- read.csv("season_baseline.csv")
seasons <- c("spring","summer","fall","winter")

# this is the data frame we're building
tempevents <- data.frame(matrix(ncol=6,nrow=0))
names(tempevents) = c("STATION","YEAR","SEASON","TYPE","EVENT","LABEL")

# go back through daily temperatiure data looking for cold/heat waves based on station highest average max and lowest average min through the whole year
for (i in 1:length(stations)) {
	station = stations[i]
	file_list <- list.files(path="E:/WeatherData/tmp", paste0(station,".*.csv"))
	statavg <- season_baseline %>% filter(STATION==station)
	maxtemp = max(statavg$TMAX_MEAN)
	mintemp = min(statavg$TMIN_MEAN)

	for (y in 1:length(file_list)) {
		if (!file.size(paste0("E:/WeatherData/tmp/",file_list[y])) == 0) {
			print(paste("Processing", file_list[y]))
			raw <- read.csv(paste0("E:/WeatherData/tmp/",file_list[y]), header=FALSE) %>% select(1,2,3,4)
			names(raw) <- c("station","date","tag","value")
			raw <- raw %>% filter(tag == "TMAX")

			# extract year,month,week,season and pivot based on GHCD dataset tag
			hight_data <- raw %>%
				mutate(DATE=ymd(date),YEAR=year(date),MONTH=month(date),SEASON=case_when(MONTH>2 & MONTH<6 ~ "spring",MONTH>5 & MONTH<9 ~ "summer",MONTH>8 & MONTH<12 ~ "fall",TRUE ~ "winter")) %>%
				pivot_wider(names_from=tag, values_from=value)
			# convert temp from tenths degC to degF
			if ("TMAX" %in% colnames(hight_data)) { hight_data$TMAX <- ((hight_data$TMAX / 10.0) * (9.0 / 5.0)) + 32.0 } else { hight_data <- mutate(hight_data, TMAX=NA) }

			# mark the HOT days as more than 9 deg about the average maximum and COLD days as more than 9 deg colder than the average minimum
			hight_data <- hight_data %>% mutate(HOT=TMAX > (maxtemp + 9), COLD=TMAX < (mintemp - 9))

			# summzrize by season
			for (ss in 1:length(seasons)) {
				season = seasons[ss]
				season_avgt <- hight_data %>% filter(SEASON==season)
				# run-length-encode to reduce to vectors of streaks
				streaks <- rle(season_avgt$HOT)
				drow = 1
				if (length(streaks$lengths > 0)) {
					for (r in 1:length(streaks$values)) {
						# write the starting day of streaks where  HOT as TRUE and more than 3 days in length
						if (streaks$values[r] && streaks$lengths[r] > 3) {
							tempevents <- add_row(tempevents, STATION=station, YEAR=season_avgt$YEAR[drow], SEASON=season, TYPE="TMAX", EVENT="Heat Wave",LABEL=sprintf("%d days", streaks$length[r]))
						}
						drow = drow + streaks$lengths[r]
					}
				}
				streaks <- rle(season_avgt$COLD)
				drow = 1
				if (length(streaks$lengths > 0)) {
					for (r in 1:length(streaks$values)) {
						# write the starting day of streaks where COLD as TRUE and more than 3 days in length
						if (streaks$values[r] & streaks$lengths[r] > 3) {
							tempevents <- add_row(tempevents, STATION=station, YEAR=season_avgt$YEAR[drow], SEASON=season, TYPE="TMIN", EVENT="Cold Wave",LABEL=sprintf("%d days", streaks$length[r]))
						}
						drow = drow + streaks$lengths[r]
					}
				}
			}
		}
	}
}
# write CSV summary datafile
write.csv(tempevents, "tempevents.csv", row.names=FALSE)