#===
# see error_nonuniformity_filter.py to see how this is used
#
# Note that this is only used to support the error_nonuniformity_filter.py
# option --method=chi-squared. This method has been found to be flawed, and is
# not recommended.
#===

require(pwr)

do_mx_significance_tests <- function(n,mxFlat,testErrorCounts,effectSize=0.3,power=0.8,verbose=F)
	{
	# n
	#	is the number of flattened rows (the number of tests to perform)
	# mxFlat
	#	is a flattened matrix of the test values; each flattened row has 2*m
	#	columns, where m is the vector size of a test; thus each flattened row
	#   has two test vectors, which for our original purposes were "match
	#	counts" and "error counts"
	# testErrorCounts
	#	is TRUE  if we're to test the second test vector in each flattened row
	#	is FALSE if we're to test the first  test vector in each flattened row
	#   in either case, only one of the two vectors is tested

	rowLen = length(mxFlat)/n
	for (row in 1:n)
		{
		if (testErrorCounts)
			{
			# this setting of s,e extracts the second half of each row, the error counts
			e = row*rowLen
			s = e-(rowLen-1) + (rowLen/2)
			}
		else
			{
			# this setting of s,e extracts the first half of each row, the match counts
			s = (row-1)*rowLen + 1
			e = s + (rowLen/2) - 1
			}
		if (verbose)
			write(paste("row",row,"events:",paste(mxFlat[s:e],collapse=",")), stderr())
		result = assess_significance(mxFlat[s:e],effectSize=effectSize,power=power)
		if (verbose) # nb: assess_significance's verbose output fails to get out
			write(paste("alpha:",result$alpha,"pvalue:",result$pvalue,"df:",result$df,"sampleSize:",result$sampleSize), stderr())
		cat(result$outcome)
		cat('\n')
		}
	}

assess_significance <- function(case,effectSize=0.3,power=0.8,verbose=F)
	{
	# returns:
	#   outcome = TRUE  ==> don't reject null hypothesis; the counts are uniform
	#           = FALSE ==> reject null hypothesis;       the counts are biased
	#           = NA    ==> unable to run the test
	#   pvalue          ==> chisq.test's pvalue
	#   alpha           ==> alpha used for the test
	#   df              ==> the test's degrees of freedom
	#   sampleSize      ==> number of items

	if (any(case<5))
		{
	    return (list(outcome    = NA,
	                 pvalue     = NA,
	                 alpha      = NA,
	                 df         = NA,
	                 sampleSize = NA))
		}
	stopifnot(case>=5)
	df <- length(case)-1
	sampleSize <- sum(case)

	alpha <- 0.0000000001 # default alpha value
	tryCatch(
		# ***** need to consider whether this should be treated as "unable to run the test" *****
		# Calculating alpha value for fixed power
		alpha <- pwr.chisq.test(w=effectSize,df=df,N=sampleSize,power=power,sig.level=NULL)$sig.level
		,
		# But if an error occurs, we will stick to the default alpha value.
		# This happens when the alpha value becomes extremely small.
		error=function(error_message)
			{
			message("Uniroot problem: alpha will remain at the minimum value of 0.0000000001.")
			message(error_message)
			message("")  # creates a newline after error_message
		  	}
		)

	pvalue <- chisq.test(case)$p.value
	if (verbose)
		write(paste("alpha:",alpha,"pvalue:",pvalue,"df:",df,"sampleSize:",sampleSize), stderr())
	# (pvalue <= alpha) ==> reject null hypothesis;       the counts are biased
	# (pvalue >  alpha) ==> don't reject null hypothesis; the counts are uniform
    return (list(outcome    = pvalue>alpha,
                 pvalue     = pvalue,
                 alpha      = alpha,
                 df         = df,
                 sampleSize = sampleSize))
	}


# download and summarize annual flow at any gauge
# tutorial here: https://owi.usgs.gov/R/dataRetrieval.html#1

library(dataRetrieval)
library(tidyverse)
library(lubridate)

#get gauge number
siteNo <- readline(prompt="Enter a gauge number: ")

#siteNo <- "08330000"

# get station metadata
gauge_meta <- readNWISsite(siteNo)
startdate <- paste("annual flow\nUSGS gauge",
                   gauge_meta$site_no,
                   "\nData series start date: ",
                   gauge_daily$Date[1])

# reasonable start date
startDate <- "1895-02-01"
endDate <- Sys.Date()

# statistics of interest - this is mean daily discharge
pCode <- "00060"
statCd <- "00003"

# retrieve data
gauge <- as_tibble(gauge <- readNWISdv(siteNo, pCode, startDate, endDate,
                    statCd))
# use pipes to rename flow variable, select ones we need, and
# add the year
gauge_daily <- gauge %>%
  rename(flow = X_00060_00003) %>%
  select(Date, flow) %>%
  mutate(year=year(Date)) %>%
  filter(year < 2019)

# create annual average flows
# the *724 part converts cfs to af per year
gauge_annual <- summarize(group_by(gauge_daily, year), annual_flow=mean(flow)*724)

# plot average annual flows
p <- ggplot(gauge_annual, aes(year, annual_flow)) +
  geom_line(data=gauge_annual, aes(x=year, y=mean(gauge_annual$annual_flow)), colour="brown", size=0.5) +
  geom_line(data=gauge_annual, aes(x=year, y=median(gauge_annual$annual_flow)), colour="red", size=0.5) +
  geom_bar(stat="identity") +
  ylab("acre feet") +
  xlab("Data: USGS; graph by John Fleck, University of New Mexico Water Resources Program") +
  ggtitle(gauge_meta$station_nm, subtitle="annual flow") +
  annotate("text", x=2020, y=mean(gauge_annual$annual_flow), label="mean", size=3) +
  annotate("text", x=2020, y=median(gauge_annual$annual_flow), label="median", size=3) +
  labs(title=gauge_meta$station_nm,
       subtitle=startdate,
       x = "year",
       y = "acre feet",
       caption = "Data: USGS\ngraph: University of New Mexico Water Resources Program
       code: https://github.com/johnrfleck/water-tools") +
  theme(strip.text = element_text(face = "bold", size = 8))
print(p)


# [Konsep Grammar of Graphic](https://academy.dqlab.id/main/livecode/259/469/2337)
library(ggplot2)
# [Mengingat Kembali](https://academy.dqlab.id/main/livecode/259/469/2338)
library(ggplot2)
qplot(x = carat, y = price, colour = clarity, data = diamonds)

# [Pembuatan Grafik dengan ggplot](https://academy.dqlab.id/main/livecode/259/469/2339)
library(ggplot2)
ggplot(data = diamonds,
       mapping = aes(x = carat, y = price, colour = clarity)) +
  geom_point()

# [Kode 3 Rupa](https://academy.dqlab.id/main/livecode/259/469/2340)
library(ggplot2)
# Cara 1
diamonds_c1 <-
  ggplot(data = diamonds,
         mapping = aes(x = carat, y = price, colour = clarity)) +
  geom_point()

summary(diamonds_c1)
# Cara 2
diamonds_c2 <-
  ggplot(data = diamonds) +
  geom_point(mapping = aes(x = carat, y = price, colour = clarity))

summary(diamonds_c2)
# Cara 3
diamonds_c3 <-
  ggplot() +
  geom_point(data = diamonds,
             mapping = aes(x = carat, y = price, colour = clarity))

summary(diamonds_c3)

# [Yin dan Yang](https://academy.dqlab.id/main/livecode/259/469/2344)
library(dplyr)

# [Paket dplyr](https://academy.dqlab.id/main/livecode/259/469/2345)
TRUE

# [Transformasi Data](https://academy.dqlab.id/main/livecode/259/469/2346)
library(dplyr)
glimpse(storms)
# Tanpa menggunakan %>%
storms1 <- select(storms, year, month, wind, pressure)
storms2 <- filter(storms1, between(year, 2000, 2015))
storms3 <- mutate(storms2, month = factor(month.name[storms2$month], levels = month.name))
storms4 <- group_by(storms3, month)
storms_nopipe <- summarise(storms4, avg_wind = mean(wind), avg_pressure = mean(pressure))

glimpse(storms_nopipe)
# Menggunakan %>%
storms_pipe <-
  storms %>%
  select(year, month, wind, pressure) %>%
  filter(between(year, 2000, 2015)) %>%
  mutate(month = factor(month.name[month], levels = month.name)) %>%
  group_by(month) %>%
  summarise(avg_wind = mean(wind),
            avg_pressure = mean(pressure))
glimpse(storms_pipe)
# Komparasi metode tanpa pipe dan dengan pipe
identical(storms_nopipe, storms_pipe)

# [Import Dataset](https://academy.dqlab.id/main/livecode/259/470/2349)
library(readr)

indodapoer <- read_tsv("https://dqlab-dataset.s3-ap-southeast-1.amazonaws.com/indodapoer.tsv.gz")
nrow(indodapoer)
ncol(indodapoer)

# [Wild Names and How to Tame Them](https://academy.dqlab.id/main/livecode/259/470/2350)
install.packages("janitor", repos = "http://cran.us.r-project.org")
library(janitor)

head(colnames(indodapoer), 15)
indodapoer <- clean_names(indodapoer)
head(colnames(indodapoer), 15)

# [Produk Domestik Regional Bruto](https://academy.dqlab.id/main/livecode/259/471/2352)
library(stringr)
library(dplyr)

pdrb_pjawa <-
  indodapoer %>%
  filter(
    area_name %in% c(
      "Banten, Prop.",
      "DKI Jakarta, Prop.",
      "Jawa Barat, Prop.",
      "Jawa Tengah, Prop.",
      "DI Yogyakarta, Prop.",
      "Jawa timur, Prop."
    )
  ) %>%
  transmute(
    provinsi = str_remove(area_name, ", Prop."),
    tahun = year,
    pdrb_nonmigas = total_gdp_excluding_oil_and_gas_in_idr_million_constant_price) %>%
  filter(!is.na(pdrb_nonmigas))

glimpse(pdrb_pjawa)

# [Grafik PDRB Non-Migas](https://academy.dqlab.id/main/livecode/259/471/2353)
library(dplyr)
library(ggplot2)
library(forcats)

pdrb_pjawa %>%
  mutate(
    provinsi = fct_reorder2(provinsi, tahun, pdrb_nonmigas)
  ) %>%
  ggplot(aes(tahun, pdrb_nonmigas, colour = provinsi)) +
  geom_line()

# [Direct Labeling](https://academy.dqlab.id/main/livecode/259/471/2354)
library(ggplot2)
library(dplyr)
library(directlabels)

pdrb_pjawa %>%
  ggplot(aes(tahun, pdrb_nonmigas)) +
  geom_line(aes(colour = provinsi), show.legend = FALSE) +
  geom_dl(
    aes(label = provinsi),
    method = "last.points",
    position = position_nudge(x = 0.3) # agar teks tidak berhimpitan dengan garis
  )

# [Finalisasi Grafik](https://academy.dqlab.id/main/livecode/259/471/2355)
library(ggplot2)
library(dplyr)
library(directlabels)
library(hrbrthemes)

pdrb_pjawa %>%
  ggplot(aes(tahun, pdrb_nonmigas / 1e6)) +
  geom_line(aes(colour = provinsi), show.legend = FALSE) +
  geom_dl(
    aes(label = provinsi),
    method = "last.points",
    position = position_nudge(x = 0.3) # agar teks tidak berhimpitan dengan garis
  ) +
  labs(
    x = NULL,
    y = NULL,
    title = "PDRB Non-Migas di Pulau Jawa Hingga Tahun 2011",
    subtitle = "PDRB atas dasar harga konstan, dalam satuan triliun",
    caption =  "Data: INDO-DAPOER, The World Bank"
  ) +
  coord_cartesian(clip = "off") +
  theme_ipsum(grid = "Y", ticks = TRUE)

# [Seluas Apa?](https://academy.dqlab.id/main/livecode/259/471/2356)
library(dplyr)
library(stringr)

luas_provinsi <-
  indodapoer %>%
  filter(str_detect(area_name, "Prop")) %>%
  filter(year == 2009) %>%
  transmute(
    provinsi = str_remove(area_name, ", Prop."),
    luas_wilayah = total_area_in_km2)

glimpse(luas_provinsi)

# [Komparasi Luas Wilayah](https://academy.dqlab.id/main/livecode/259/471/2357)
library(treemapify)
library(ggplot2)
library(dplyr)

luas_provinsi  %>%
  ggplot(aes(area = luas_wilayah)) +
  geom_treemap() +
  geom_treemap_text(aes(label = provinsi))

# [Modifikasi Grafik](https://academy.dqlab.id/main/livecode/259/471/2358)
library(ggplot2)
library(hrbrthemes)
library(dplyr)
library(treemapify)
library(scales)

luas_provinsi %>%
  ggplot(aes(
    area = luas_wilayah,
    fill = luas_wilayah)
  ) +
  geom_treemap() +
  geom_treemap_text(
    aes(label = provinsi),
    family = "Arial Narrow",
    colour = "white",
    reflow = TRUE,
    grow = TRUE
  ) +
  scale_fill_viridis_c(
    guide = guide_colourbar(
      barwidth = 30,
      barheight = 0.8
    ),
    labels = label_number(
      big.mark = ".",
      decimal.mark = ",",
      suffix = " km2")
  ) +
  labs(
    fill = "Luas\nwilayah",
    title = "Perbandingan Luas 33 Provinsi di Indonesia",
    subtitle = "Berdasarkan data tahun 2009, sehingga Kalimantan Utara tidak tercantum dalam grafik",
    caption = "Data: INDO-DAPOER, The World Bank"
  ) +
  theme_ipsum() +
  theme(legend.position = "bottom")

# [Perjalanan Ini](https://academy.dqlab.id/main/livecode/259/471/2361)
library(dplyr)
library(stringr)

jalan_kabkota  <-
  indodapoer %>%
  filter(str_detect(area_name, ", Prop.", negate = TRUE)) %>%
  filter(year == 2008) %>%
  transmute(
    kabkota = area_name,
    jalan_rusak_parah = length_of_district_road_bad_damage_in_km_bina_marga_data,
    jalan_rusak_ringan = length_of_district_road_light_damage_in_km_bina_marga_data,
    jalan_cukup_baik = length_of_district_road_fair_in_km_bina_marga_data,
    jalan_sangat_baik = length_of_district_road_good_in_km_bina_marga_data)

glimpse(jalan_kabkota )

# [Pivot](https://academy.dqlab.id/main/livecode/259/471/2362)
library(tidyr)
library(dplyr)

glimpse(jalan_kabkota)
jalan_kabkota  <-
  jalan_kabkota %>%
  pivot_longer(
    cols = starts_with("jalan_"),
    names_to = "kondisi",
    names_prefix = "jalan_",
    values_to = "panjang_jalan")

glimpse(jalan_kabkota)

# [The Next Step](https://academy.dqlab.id/main/livecode/259/471/2363)
library(dplyr)
library(stringr)

jalan_kabkota <-
  jalan_kabkota %>%
  mutate(
    status = case_when(
      str_detect(kabkota, ", Kab") ~ "Kabupaten",
      str_detect(kabkota, ", Kota") ~ "Kota",
      str_detect(kabkota, "City") ~ "Kota",
      TRUE ~ NA_character_
    ),
    kondisi = factor(
      kondisi,
      levels = c("rusak_parah", "rusak_ringan", "cukup_baik", "sangat_baik"),
      labels = c("Rusak parah", "Rusak ringan", "Cukup baik", "Sangat baik")
    )
  )

glimpse(jalan_kabkota)

# [Grafik Kondisi Jalan](https://academy.dqlab.id/main/livecode/259/471/2364)
install.packages("ggridges",repos = "http://cran.us.r-project.org")
library(ggplot2)
library(dplyr)
library(ggridges)

jalan_kabkota_plot <-
  jalan_kabkota  %>%
  ggplot(aes(panjang_jalan, kondisi)) +
  facet_wrap(~status) +
  geom_density_ridges_gradient(
    aes(fill = after_stat(x)),
    show.legend = FALSE)

jalan_kabkota_plot

# [Transformasi Logaritmik](https://academy.dqlab.id/main/livecode/259/471/2365)
install.packages("ggridges",repos = "http://cran.us.r-project.org")
library(ggplot2)
library(dplyr)
library(ggridges)

jalan_kabkota_plot <-
  jalan_kabkota %>%
  ggplot(aes(panjang_jalan, kondisi)) +
  facet_wrap(~status) +
  geom_density_ridges_gradient(
    aes(fill = after_stat(x)),
    show.legend = FALSE)

jalan_kabkota_plot +
  geom_vline(xintercept = 100, linetype = "dashed", colour = "darkslategray4") +
  scale_x_continuous(trans = "log10")

# [Finalisasi](https://academy.dqlab.id/main/livecode/259/471/2366)
install.packages("ggridges",repos = "http://cran.us.r-project.org")
library(ggplot2)
library(dplyr)
library(ggridges)
library(hrbrthemes)

jalan_kabkota_plot <-
  jalan_kabkota %>%
  ggplot(aes(panjang_jalan, kondisi)) +
  facet_wrap(~status) +
  geom_density_ridges_gradient(
    aes(fill = after_stat(x)),
    show.legend = FALSE)

jalan_kabkota_plot +
  geom_vline(xintercept = 100, linetype = "dashed", colour = "darkslategray4") +
  scale_x_continuous(trans = "log10") +
  scale_fill_viridis_c(option = "magma") +
  labs(
    x = "Panjang jalan (Km)",
    y = NULL,
    title = "Jalan Kabupaten/Kota Berdasarkan Kondisi",
    subtitle = "Berdasarkan data tahun 2008, garis vertikal menunjukan panjang jalan 100 Km",
    caption = "Data: INDO-DAPOER, The World Bank"
  ) +
  theme_ipsum(grid = FALSE, ticks = TRUE)

# [Fasilitas Kesehatan di Kalimantan](https://academy.dqlab.id/main/livecode/259/471/2367)
library(dplyr)
library(ggplot2)
library(tidyr)
library(stringr)
library(forcats)

faskes_kalimantan <-
  indodapoer %>%
  filter(str_detect(area_name, "Kalimantan")) %>%
  filter(year == 2011) %>%
  transmute(
    provinsi = str_remove(area_name, ", Prop."),
    rumahsakit = number_of_hospitals,
    polindes = number_of_polindes_poliklinik_desa_village_polyclinic,
    puskesmas = number_of_puskesmas_and_its_line_services
  ) %>%
  pivot_longer(
    cols = -provinsi,
    names_to = "faskes",
    values_to = "jumlah"
  ) %>%
  filter(!is.na(jumlah)) %>%
  mutate(
    provinsi = fct_reorder(provinsi, jumlah, sum),
    jumlah = ceiling(jumlah / 10)
  )

glimpse(faskes_kalimantan)

# [Waffle Charts](https://academy.dqlab.id/main/livecode/259/471/2368)
install.packages("waffle", repos = "https://cinc.rud.is")
library(waffle)
library(ggplot2)
library(dplyr)

faskes_kalimantan_plot <-
  faskes_kalimantan %>%
  ggplot(aes(fill = faskes, values = jumlah)) +
  facet_wrap(~provinsi) +
  geom_waffle(colour = "white")

faskes_kalimantan_plot

# [Mengatur Warna dan Label](https://academy.dqlab.id/main/livecode/259/471/2369)
install.packages("waffle", repos = "https://cinc.rud.is")
library(waffle)
library(ggplot2)
library(dplyr)

faskes_kalimantan_plot <-
  faskes_kalimantan %>%
  ggplot(aes(fill = faskes, values = jumlah)) +
  facet_wrap(~provinsi) +
  geom_waffle(colour = "white")

faskes_kalimantan_plot <-
  faskes_kalimantan_plot +
  scale_fill_manual(
    values = c(
      "polindes" = "seagreen3",
      "puskesmas" = "steelblue",
      "rumahsakit" = "cyan4"
    ),
    labels = c(
      "polindes" = "Poliklinik Desa",
      "puskesmas" = "Puskesmas",
      "rumahsakit" = "Rumah Sakit"
    )
  ) +
  labs(
    fill = NULL,
    title = "Fasilitas Kesehatan di Kalimantan",
    subtitle = "Berdasarkan data tahun 2011, satu petak menyatakan ±10 faskes",
    caption = "Data: INDO-DAPOER, The World Bank"
  )

faskes_kalimantan_plot

# [Finalisasi Waffle Charts](https://academy.dqlab.id/main/livecode/259/471/2370)
install.packages("waffle", repos = "https://cinc.rud.is")
library(waffle)
library(ggplot2)
library(dplyr)

faskes_kalimantan_plot <-
  faskes_kalimantan %>%
  ggplot(aes(fill = faskes, values = jumlah)) +
  facet_wrap(~provinsi) +
  geom_waffle(colour = "white")

faskes_kalimantan_plot <-
  faskes_kalimantan_plot +
  scale_fill_manual(
    values = c(
      "polindes" = "seagreen3",
      "puskesmas" = "steelblue",
      "rumahsakit" = "cyan4"
    ),
    labels = c(
      "polindes" = "Poliklinik Desa",
      "puskesmas" = "Puskesmas",
      "rumahsakit" = "Rumah Sakit"
    )
  ) +
  labs(
    fill = NULL,
    title = "Fasilitas Kesehatan di Kalimantan",
    subtitle = "Berdasarkan data tahun 2011, satu petak menyatakan ±10 faskes",
    caption = "Data: INDO-DAPOER, The World Bank"
  )

faskes_kalimantan_plot +
  coord_equal() +
  theme(
    text = element_text(family = "Arial Narrow"),
    plot.title.position = "plot",
    plot.title = element_text(face = "bold", size = 18, hjust = 0.5),
    plot.subtitle = element_text(face = "plain", size = 12, hjust = 0.5),
    plot.caption = element_text(face = "italic", size = 9),
    legend.position = "bottom",
    panel.background = element_blank(),
    panel.grid = element_blank(),
    strip.background = element_blank(),
    strip.text = element_text(face = "italic", size = 9, hjust = 0),
    axis.text.x = element_blank(),
    axis.text.y = element_blank(),
    axis.ticks = element_blank()
  )

# [Jumlah Rata-rata Likes per Hari](https://academy.dqlab.id/main/livecode/259/474/2373)
install.packages("ggtext",repos = "http://cran.us.r-project.org")
library(ggtext)
library(forcats)
library(ggplot2)
library(dplyr)
library(readr)

igstats <- read_csv("https://dqlab-dataset.s3-ap-southeast-1.amazonaws.com/igstats.csv")
glimpse(igstats)

igstats_plot  <-
  igstats %>%
  mutate(day = fct_reorder(day, avglikes)) %>%
  ggplot() +
  geom_segment(aes(
    x = 0,
    xend = avglikes,
    y = day,
    yend = day
  ),
  colour = "white",
  linetype = "longdash"
  ) +
  geom_point(
    aes(avglikes, day, fill = is_weekend),
    shape = "circle filled",
    size = 18,
    colour = "white",
    show.legend = FALSE
  ) +
  geom_text(
    aes(avglikes, day, label = round(avglikes)),
    colour = "white",
    family = "Lacquer",
    size = 7
  ) +
  geom_text(
    aes(x = 0, day, label = day),
    colour = "white",
    nudge_y = 0.15,
    hjust = "left",
    family = "Lacquer"
  ) +
  geom_curve(
    aes(
      x = 185,
      xend = 174,
      y = 6.3,
      yend = 6
    ),
    colour = "white",
    curvature = -0.3,
    arrow = arrow(length = unit(0.1, "inches"), type = "closed")
  ) +
  geom_curve(
    aes(
      x = 185,
      xend = 230,
      y = 6.8,
      yend = 7.2
    ),
    colour = "white",
    curvature = -0.25,
    arrow = arrow(length = unit(0.1, "inches"), type = "closed")
  ) +
  annotate(
    geom = "richtext",
    x = 200,
    y = 6.5,
    label = "Blue is weekday,
green is weekend",
    fill = NA,
    label.colour = NA,
    colour = "white",
    family = "Lacquer",
    size = 4
  ) +
  annotate(
    geom = "text",
    x = 200,
    y = 3,
    label = "How many\nlikes did \nI get?",
    colour = "white",
    hjust = "center",
    family = "Lacquer",
    size = 15
  ) +
  scale_fill_manual(values = c("Blue", "Green")) +
  theme_void() +
  theme(plot.background = element_rect(fill = "Black"))

igstats_plot

# [Jati Diri](https://academy.dqlab.id/main/livecode/259/474/2374)
install.packages("cowplot",repos = "http://cran.us.r-project.org")
library(cowplot)

ggdraw(igstats_plot) +
  draw_image(
    image = "https://academy.dqlab.id/assets/images/logo-dqlab.png",
    x = 0.425,
    y = -0.44,
    scale = 0.1)

R/Kelas Fundamental/5. Advanced Data Visualization for Everyone.r


rm(list=ls())

library(prodlim)
library(dummies)

getPseudoConditional <- function(t, d, qt){
#     Conditional pseudo values for CIF given the risk set.
#     Arguments:
#       t: survival time
#       d: event status
#       qt: Evaluation times

#     Returns:
#       Conditional pseudo values for CIF given the risk set for all subjects for all causes at different intervals.

    s <- c(0, qt)
    n=length(t)
    ns=length(s)-1  # the number of intervals
    D1 <- do.call(cbind, lapply(1:ns, function(j)  (s[j] < t) * (t <= s[j+1]) * (d == 2)))
    D1[D1==1]=2
    D2 <- do.call(cbind, lapply(1:ns, function(j)  (s[j] < t) * (t <= s[j+1]) * (d == 1)))
    D3=D2+D1
    R <- do.call(cbind, lapply(1:ns, function(j) ifelse(s[j] < t, 1, 0)))
    Delta<-do.call(cbind, lapply(1:ns, function(j) pmin(t,s[j+1])-s[j]))

    # format into long formate
    dd.tmp=cbind.data.frame(id=rep(1:n,ns),s=rep(c(0,qt[-length(qt)]), each=n), y=c(R*Delta),d=c(D3))
    dd=dd.tmp[dd.tmp$y>0,]
    pseudost1=rep(NA, nrow(dd))
    pseudost2=rep(NA, nrow(dd))

    for (j in 1:ns){
        index= (dd$s==s[j])
        dds=dd[index,]
        time<-dds$y
        event<-dds$d
        f =prodlim(Hist(time, event)~1) #call function for estimating CIF from right censored data using the Aalen-Johansen estimator
        pseudost1[index]= jackknife(f,times=s[j+1]-s[j],cause=1) #pseudo values for cause 1
        pseudost2[index]= jackknife(f,times=s[j+1]-s[j],cause=2) #pseudo values for cause 2
        }
        dd$pseudost1=pseudost1
        dd$pseudost2=pseudost2
    return(dd[,c(1,2,5, 6)])
}

get_conditional_pseudo_data<-function(data, evalTime){
#   Get data that will be used to train conditional_DeepPseudo model
#   Arguments:
#       - data: A competing risk dataframe containing survival time and event status, which will be used to estimate pseudo values for CIF.
#       - evalTime: Evaluation times at which pseudo values are calculated

#   Returns:
#        - A dataframe with dummy variable of intervals and causes as covariates and pseudo values.

    time<-data[, 'time']
    status<-data[,'status']

    drops <- c("time","status")
    features<-data[ , !(names(data) %in% drops)]
    # get the pseudo conditinal CIF
    pseudoCond <- getPseudoConditional(time, status, evalTime)
    # covaraite
    x <- features[pseudoCond$id,]
    # create dummy variables for the time intervals
    smatrix=model.matrix(~as.factor(pseudoCond$s)+0)

    #create input predictors
    x1 <- cbind(x, smatrix, cause=rep(1,nrow(x)))
    x2 <- cbind(x, smatrix, cause=rep(2,nrow(x)))
    x_feat<-rbind(x1, x2)
    x.all<- dummy.data.frame(x_feat, names = c("cause") , sep = ".")

    y1 <- pseudoCond$pseudost1
    y2 <- pseudoCond$pseudost2
    y  <- c(y1,y2)
    data.all<-cbind(x.all, y)
    return(data.all)
 }

get_conditional_test_data <-function(test_data, evalTime){
#   Get data that will be used to test the conditional_DeepPseudo model
#   Arguments:
#       - data: A test data
#       - evalTime: Evaluation times at which pseudo values are calculated

#   Returns:
#        - A dataframe with dummy variable of intervals and causes as covariates that will be used to test the conditional_DeepPseudo model.

    drops <- c("time","status")
    test_features<-test_data[ , !(names(test_data) %in% drops)]
    # format the test data
    s<-c(0,12)
    x_test=do.call(rbind, replicate(length(evalTime), test_features, simplify=FALSE))
    s_test=rep(s,each=nrow(test_features))
    smatrix.test=model.matrix(~as.factor(s_test)+0)
    x_test1=cbind(x_test,smatrix.test, cause=rep(1,nrow(x_test)))
    x_test2=cbind(x_test,smatrix.test, cause=rep(2,nrow(x_test)))
    x_test.bind<-rbind(x_test1, x_test2)
    x_test.all<- dummy.data.frame(x_test.bind, names = c("cause") , sep = ".")
    return(x_test.all)

 }


/*
 * File: ocomp.r
 *  Contents: lexeq, lexge, lexgt, lexle, lexlt, lexne, numeq, numge,
 *		numgt, numle, numlt, numne, eqv, neqv
 */

/*
 * NumComp is a macro that defines the form of a numeric comparisons.
 */
#begdef NumComp(icon_op, func_name, c_op, descript)
"x " #icon_op " y - test if x is numerically " #descript " y."
   operator{0,1} icon_op func_name(x,y)

   arith_case (x, y) of {
      C_integer: {
         abstract {
            return integer
            }
         inline {
            if c_op(x, y)
               return C_integer y;
            fail;
            }
         }
      integer: { /* large integers only */
         abstract {
            return integer
            }
         inline {
            if (big_ ## c_op (x,y)) {
               return y;
   	    }
            fail;
            }
         }
      C_double: {
         abstract {
            return real
            }
         inline {
            if c_op (x, y)
               return C_double y;
            fail;
            }
         }
      }
end

#enddef

/*
 * x = y
 */
#define NumEq(x,y) (x == y)
#define big_NumEq(x,y) (bigcmp(&x,&y) == 0)
NumComp( = , numeq, NumEq, equal to)

/*
 * x >= y
 */
#define NumGe(x,y) (x >= y)
#define big_NumGe(x,y) (bigcmp(&x,&y) >= 0)
NumComp( >=, numge, NumGe, greater than or equal to)

/*
 * x > y
 */
#define NumGt(x,y) (x > y)
#define big_NumGt(x,y) (bigcmp(&x,&y) > 0)
NumComp( > , numgt, NumGt,  greater than)

/*
 * x <= y
 */
#define NumLe(x,y) (x <= y)
#define big_NumLe(x,y) (bigcmp(&x,&y) <= 0)
NumComp( <=, numle, NumLe, less than or equal to)

/*
 * x < y
 */
#define NumLt(x,y) (x < y)
#define big_NumLt(x,y) (bigcmp(&x,&y) < 0)
NumComp( < , numlt, NumLt,  less than)

/*
 * x ~= y
 */
#define NumNe(x,y) (x != y)
#define big_NumNe(x,y) (bigcmp(&x,&y) != 0)
NumComp( ~=, numne, NumNe, not equal to)

/*
 * StrComp is a macro that defines the form of a string comparisons.
 */
#begdef StrComp(icon_op, func_name, special_test, c_comp, comp_value, descript)
"x " #icon_op " y - test if x is lexically " #descript " y."
operator{0,1} icon_op func_name(x,y)
   declare {
      int temp_str = 0;
      }
   abstract {
      return string
      }
   if !cnv:tmp_string(x) then
      runerr(103,x)
   if !is:string(y) then
      if cnv:tmp_string(y) then
          inline {
             temp_str = 1;
             }
      else
         runerr(103,y)

   body {

      /*
       * lexcmp does the work.
       */
      if (special_test (lexcmp(&x, &y) c_comp comp_value)) {
         /*
          * Return y as the result of the comparison.  If y was converted to
          *  a string, a copy of it is allocated.
          */
         result = y;
         if (temp_str)
            Protect(StrLoc(result) = alcstr(StrLoc(result), StrLen(result)), runerr(0));
         return result;
         }
      else
         fail;
      }
end
#enddef

StrComp(==,  lexeq, (StrLen(x) == StrLen(y)) &&, ==, Equal, equal to)
StrComp(~==, lexne, (StrLen(x) != StrLen(y)) ||, !=, Equal, not equal to)

StrComp(>>=, lexge, , !=, Less,    greater than or equal to)
StrComp(>>,  lexgt, , ==, Greater, greater than)
StrComp(<<=, lexle, , !=, Greater, less than or equal to)
StrComp(<<,  lexlt, , ==, Less,    less than)

"x === y - test equivalence of x and y."

operator{0,1} === eqv(x,y)
   abstract {
      return type(y)
      }
   inline {
      /*
       * Let equiv do all the work, failing if equiv indicates non-equivalence.
       */
      if (equiv(&x, &y))
         return y;
      else
         fail;
   }
end

"x ~=== y - test inequivalence of x and y."

operator{0,1} ~=== neqv(x,y)
   abstract {
      return type(y)
      }
   inline {
      /*
       * equiv does all the work.
       */
      if (!equiv(&x, &y))
         return y;
      else
         fail;
   }
end


#' add
#'
#' Add two matrices: \code{ret = alpha*x + beta*y}.
#'
#' @param transx,transy Should x/y be transposed?
#' @param alpha,beta Scalars.
#' @param x,y Input data.
#' @param ret Either \code{NULL} or an already allocated fml matrix of the same
#' class and type as \code{x}.
#' @return Returns the matrix sum.
#'
#' @rdname linalg-add
#' @name add
#'
#' @useDynLib fmlr R_linalg_add
#'
#' @export
linalg_add = function(transx=FALSE, transy=FALSE, alpha=1, beta=1, x, y, ret=NULL)
{
  check_is_mat(x)
  check_is_mat(y)

  transx = as.logical(transx)
  transy = as.logical(transy)

  alpha = as.double(alpha)
  beta = as.double(beta)

  invisiret = check_inputs(ret, x, y)

  if (is.null(ret))
    ret = setret(x)

  .Call(R_linalg_add, get_backend(x), x$get_type(), transx, transy, alpha, beta, x$data_ptr(), y$data_ptr(), ret$data_ptr())

  if (invisiret)
    invisible(ret)
  else
    ret
}

#' matmult
#'
#' Multiply two matrices: \code{ret = alpha*x*y}.
#'
#' @param transx,transy Should x/y be transposed?
#' @param alpha Scalar.
#' @param x,y Input data.
#' @param ret Either \code{NULL} or an already allocated fml matrix of the same
#' class and type as \code{x}.
#' @return Returns the matrix product.
#'
#' @rdname linalg-matmult
#' @name matmult
#'
#' @useDynLib fmlr R_linalg_matmult
#'
#' @export
linalg_matmult = function(transx=FALSE, transy=FALSE, alpha=1, x, y, ret=NULL)
{
  if (!is_mat(x) && !is_vec(x))
    stop("argument 'x' must be a matrix or vector type")
  if (!is_mat(y) && !is_vec(y))
    stop("argument 'y' must be a matrix or vector type")

  transx = as.logical(transx)
  transy = as.logical(transy)

  alpha = as.double(alpha)

  invisiret = check_inputs(ret, x, y, check_class=FALSE)

  if (is.null(ret))
  {
    vec = is_vec(x) || is_vec(y)
    ret = setret(x, vec=vec)
  }

  .Call(R_linalg_matmult, get_backend(x), x$get_type(), transx, transy, alpha, x$get_class(), x$data_ptr(), y$get_class(), y$data_ptr(), ret$data_ptr())

  if (invisiret)
    invisible(ret)
  else
    ret
}

#' @useDynLib fmlr R_linalg_crossprod
linalg_crossprods = function(x, ret, alpha, xpose)
{
  check_is_mat(x)

  xpose = as.logical(xpose)
  alpha = as.double(alpha)

  invisiret = check_inputs(ret, x)

  if (is.null(ret))
    ret = setret(x)

  .Call(R_linalg_crossprod, get_backend(x), x$get_type(), xpose, alpha, x$data_ptr(), ret$data_ptr())

  if (invisiret)
    invisible(ret)
  else
    ret
}

#' crossprod
#'
#' Compute crossproducts.
#'
#' @param alpha Number to scale the crossproduct by.
#' @param x Input data.
#' @param ret Either \code{NULL} or an already allocated fml matrix of the same
#' class and type as \code{x}.
#' @return Returns the crossproduct.
#'
#' @rdname linalg-crossprod
#' @name crossprod
NULL

#' @rdname linalg-crossprod
#' @export
linalg_crossprod = function(alpha=1, x, ret=NULL)
{
  linalg_crossprods(x, ret, alpha, xpose=FALSE)
}

#' @rdname linalg-crossprod
#' @export
linalg_tcrossprod = function(alpha=1, x, ret=NULL)
{
  linalg_crossprods(x, ret, alpha, xpose=TRUE)
}

#' xpose
#'
#' Matrix transpose.
#'
#' @param x Input data.
#' @param ret Either \code{NULL} or an already allocated fml matrix of the same
#' class and type as \code{x}.
#' @return Returns the xpose.
#'
#' @rdname linalg-xpose
#' @name xpose
#' @useDynLib fmlr R_linalg_xpose
#'
#' @export
linalg_xpose = function(x, ret=NULL)
{
  check_is_mat(x)
  invisiret = check_inputs(ret, x)

  if (is.null(ret))
    ret = setret(x)

  .Call(R_linalg_xpose, get_backend(x), x$get_type(), x$data_ptr(), ret$data_ptr())

  if (invisiret)
    invisible(ret)
  else
    ret
}

#' lu
#'
#' LU factorization. The factorization occurs in-place.
#'
#' @param x Input data, overwritten by its LU factorization.
#' @return Returns \code{NULL}.
#'
#' @rdname linalg-lu
#' @name lu
#' @useDynLib fmlr R_linalg_lu
#'
#' @export
linalg_lu = function(x)
{
  check_is_mat(x)
  .Call(R_linalg_lu, get_backend(x), x$get_type(), x$data_ptr())
  invisible(NULL)
}

#' det
#'
#' Determinant
#'
#' @param x Input data, overwritten by its LU factorization.
#'
#' @return Returns a list containing the modulus and the sign.
#'
#' @rdname linalg-det
#' @name det
#' @useDynLib fmlr R_linalg_det
#'
#' @export
linalg_det = function(x)
{
  check_is_mat(x)
  .Call(R_linalg_det, get_backend(x), x$get_type(), x$data_ptr())
}

#' trace
#'
#' Matrix trace, i.e. theh sum of the diagonal elements.
#'
#' @param x Input data.
#' @return Returns the trace.
#'
#' @rdname linalg-trace
#' @name trace
#' @useDynLib fmlr R_linalg_trace
#'
#' @export
linalg_trace = function(x)
{
  check_is_mat(x)
  .Call(R_linalg_trace, get_backend(x), x$get_type(), x$data_ptr())
}

#' svd
#'
#' Computes the singular value decomposition.
#'
#' @details
#' You will need to initialize the return objects \code{s} and/or \code{u} and
#' \code{vt}.
#' manually. See the example.
#'
#' @param x Input data. The input values are overwritten.
#' @param s Singular values.
#' @param u,vt The left/right singular vectors. Should both be \code{NULL} or
#' matrices of the same backend and fundamental type as \code{x}.
#'
#' @examples
#' suppressMessages(library(fmlr))
#' x = cpumat(3, 2)
#' x$fill_linspace(1, 6)
#'
#' s = cpuvec()
#' linalg_svd(x, s)
#' s$info()
#' s$print()
#'
#' @rdname linalg-svd
#' @name svd
#' @useDynLib fmlr R_linalg_svd
#'
#' @export
linalg_svd = function(x, s, u=NULL, vt=NULL)
{
  check_is_mat(x)
  check_is_vec(s)

  check_type_consistency(x, s)
  if (!is.null(u) && !is.null(vt))
    check_inputs(x, u, vt)
  else if (!is.null(u) || !is.null(vt))
    stop("must pass neither u and vt or both u and vt")

  if (is.null(u))
    .Call(R_linalg_svd, get_backend(x), x$get_type(), x$data_ptr(), s$data_ptr(), NULL, NULL)
  else
    .Call(R_linalg_svd, get_backend(x), x$get_type(), x$data_ptr(), s$data_ptr(), u$data_ptr(), vt$data_ptr())

  invisible(NULL)
}

#' eigen
#'
#' Computes the eigenvalues and/or eigenvectors
#'
#' @details
#' You will need to initialize the return objects \code{values} and/or
#' \code{vectors}.
#' manually. See the example.
#'
#' @param x Input data. The input values are overwritten.
#' @param values The eigenvalues.
#' @param vectors The eigenvectors.
#'
#' @rdname linalg-eigen
#' @name eigen
#' @useDynLib fmlr R_linalg_eigen_sym
#'
#' @export
linalg_eigen_sym = function(x, values, vectors=NULL)
{
  check_is_mat(x)
  check_is_vec(values)
  check_type_consistency(x, values)
  if (!is.null(vectors))
    check_inputs(x, vectors)

  if (is.null(vectors))
    .Call(R_linalg_eigen_sym, get_backend(x), x$get_type(), x$data_ptr(), values$data_ptr(), NULL)
  else
    .Call(R_linalg_eigen_sym, get_backend(x), x$get_type(), x$data_ptr(), values$data_ptr(), vectors$data_ptr())

  invisible(NULL)
}

#' invert
#'
#' Invert a matrix.
#'
#' @param x Input data, overwritten by the inverse.
#' @return Returns \code{NULL}.
#'
#' @rdname linalg-invert
#' @name invert
#' @useDynLib fmlr R_linalg_invert
#'
#' @export
linalg_invert = function(x)
{
  check_is_mat(x)
  .Call(R_linalg_invert, get_backend(x), x$get_type(), x$data_ptr())
  invisible(NULL)
}

#' solve
#'
#' Solve a system of equations.
#'
#' @param x Input data. The input values are overwritten.
#' @param y The RHS, overwritten by the solution.
#'
#' @rdname linalg-solve
#' @name solve
#' @useDynLib fmlr R_linalg_solve
#'
#' @export
linalg_solve = function(x, y)
{
  check_is_mat(x)
  check_type_consistency(x, y)

  if (is_vec(y))
  {
    if (is_mpimat(x))
      stop("can not mix vector with mpimat")

    class = CLASS_VEC
  }
  else
  {
    check_class_consistency(x, y)
    class = CLASS_MAT
  }

  .Call(R_linalg_solve, get_backend(x), x$get_type(), x$data_ptr(), class, y$data_ptr())
  invisible(NULL)
}

#' qr
#'
#' Computes the compact QR factorization.
#'
#' @param x Input data. The input values are overwritten.
#' @param qraux Auxilliary data for the compact QR.
#'
#' @rdname linalg-qr
#' @name qr
#' @useDynLib fmlr R_linalg_qr
#'
#' @export
linalg_qr = function(x, qraux)
{
  check_is_mat(x)
  check_is_vec(qraux)
  check_type_consistency(x, qraux)

  .Call(R_linalg_qr, get_backend(x), x$get_type(), x$data_ptr(), qraux$data_ptr())
  invisible(NULL)
}

#' qr_Q
#'
#' Computes the Q matrix from the compact QR factorization.
#'
#' @param QR The compact QR factorization. The return from \code{qr()}.
#' @param qraux Auxilliary data for the compact QR.
#' @param Q The output Q matrix.
#' @param work A workspace vector.
#'
#' @rdname linalg-qr-Q
#' @name qr_Q
#' @useDynLib fmlr R_linalg_qr_Q
#'
#' @export
linalg_qr_Q = function(QR, qraux, Q, work)
{
  check_inputs(QR, Q)
  check_is_vec(qraux)
  check_is_vec(work)
  check_type_consistency(QR, qraux, work)

  .Call(R_linalg_qr_Q, get_backend(QR), QR$get_type(), QR$data_ptr(), qraux$data_ptr(), Q$data_ptr(), work$data_ptr())
  invisible(NULL)
}

#' qr_R
#'
#' Computes the R matrix from the compact QR factorization.
#'
#' @param QR The compact QR factorization. The return from \code{qr()}.
#' @param R The output R matrix.
#'
#' @rdname linalg-qr-R
#' @name qr_R
#' @useDynLib fmlr R_linalg_qr_R
#'
#' @export
linalg_qr_R = function(QR, R)
{
  check_inputs(QR, R)
  .Call(R_linalg_qr_R, get_backend(QR), QR$get_type(), QR$data_ptr(), R$data_ptr())
  invisible(NULL)
}

#' lq
#'
#' Computes the compact LQ factorization.
#'
#' @param x Input data. The input values are overwritten.
#' @param lqaux Auxilliary data for the compact LQ.
#'
#' @rdname linalg-lq
#' @name lq
#' @useDynLib fmlr R_linalg_lq
#'
#' @export
linalg_lq = function(x, lqaux)
{
  check_is_mat(x)
  check_is_vec(lqaux)
  check_type_consistency(x, lqaux)

  .Call(R_linalg_lq, get_backend(x), x$get_type(), x$data_ptr(), lqaux$data_ptr())
  invisible(NULL)
}

#' lq_L
#'
#' Computes the L matrix from the compact LQ factorization.
#'
#' @param LQ The compact LQ factorization. The return from \code{lq()}.
#' @param L The output L matrix.
#'
#' @rdname linalg-qr-R
#' @name lq_L
#' @useDynLib fmlr R_linalg_lq_L
#'
#' @export
linalg_lq_L = function(LQ, L)
{
  check_inputs(LQ, L)
  .Call(R_linalg_lq_L, get_backend(LQ), LQ$get_type(), LQ$data_ptr(), L$data_ptr())
  invisible(NULL)
}

#' lq_Q
#'
#' Computes the Q matrix from the compact LQ factorization.
#'
#' @param LQ The compact LQ factorization. The return from \code{lq()}.
#' @param lqaux Auxilliary data for the compact LQ.
#' @param Q The output Q matrix.
#' @param work A workspace vector.
#'
#' @rdname linalg-lq-Q
#' @name lq_Q
#' @useDynLib fmlr R_linalg_lq_Q
#'
#' @export
linalg_lq_Q = function(LQ, lqaux, Q, work)
{
  check_inputs(LQ, Q)
  check_is_vec(lqaux)
  check_is_vec(work)
  check_type_consistency(LQ, lqaux, work)

  .Call(R_linalg_lq_Q, get_backend(LQ), LQ$get_type(), LQ$data_ptr(), lqaux$data_ptr(), Q$data_ptr(), work$data_ptr())
  invisible(NULL)
}

#' qrsvd
#'
#' QR/LQ-based SVD. Useful for very tall/skinny or short/wide data.
#'
#' @param x Input data. The input values are overwritten.
#' @param s Singular values.
#' @param u,vt The left/right singular vectors. Should both be \code{NULL} or
#' matrices of the same backend and fundamental type as \code{x}.
#'
#' @rdname linalg-qrsvd
#' @name qrsvd
#' @useDynLib fmlr R_linalg_qrsvd
#'
#' @export
linalg_qrsvd = function(x, s, u=NULL, vt=NULL)
{
  check_is_mat(x)
  check_is_vec(s)

  check_type_consistency(x, s)
  if (!is.null(u) && !is.null(vt))
    check_inputs(x, u, vt)
  else if (!is.null(u) || !is.null(vt))
    stop("must pass neither u and vt or both u and vt")

  if (is.null(u))
    .Call(R_linalg_qrsvd, get_backend(x), x$get_type(), x$data_ptr(), s$data_ptr(), NULL, NULL)
  else
    .Call(R_linalg_qrsvd, get_backend(x), x$get_type(), x$data_ptr(), s$data_ptr(), u$data_ptr(), vt$data_ptr())

  invisible(NULL)
}

#' cpsvd
#'
#' "Crossproducts" SVD.
#'
#' @details
#' Computes the approximate SVD via the eigenvalue decomposition of
#' \code{crossprod(x)} if the input is tall/skinny and \code{tcrossprod(x)}
#' otherwise.
#'
#' @param x Input data. The input values are overwritten.
#' @param s Singular values.
#' @param u,vt The left/right singular vectors. Should both be \code{NULL} or
#' matrices of the same backend and fundamental type as \code{x}.
#'
#' @rdname linalg-cpsvd
#' @name cpsvd
#' @useDynLib fmlr R_linalg_cpsvd
#'
#' @export
linalg_cpsvd = function(x, s, u=NULL, vt=NULL)
{
  check_is_mat(x)
  check_is_vec(s)

  check_type_consistency(x, s)
  if (!is.null(u) && !is.null(vt))
    check_inputs(x, u, vt)
  else if (!is.null(u) || !is.null(vt))
    stop("must pass neither u and vt or both u and vt")

  if (is.null(u))
    .Call(R_linalg_cpsvd, get_backend(x), x$get_type(), x$data_ptr(), s$data_ptr(), NULL, NULL)
  else
    .Call(R_linalg_cpsvd, get_backend(x), x$get_type(), x$data_ptr(), s$data_ptr(), u$data_ptr(), vt$data_ptr())

  invisible(NULL)
}

#' chol
#'
#' Compute the lower-triangular Cholesky factor.
#'
#' @param x Input data, overwritten by the inverse.
#' @return Returns \code{NULL}.
#'
#' @rdname linalg-chol
#' @name chol
#' @useDynLib fmlr R_linalg_chol
#'
#' @export
linalg_chol = function(x)
{
  check_is_mat(x)
  .Call(R_linalg_chol, get_backend(x), x$get_type(), x$data_ptr())
  invisible(NULL)
}

#' norms
#'
#' Norms.
#'
#' @param x Input data. The data is un-modified except for \code{norm_2()}.
#'
#' @return The requested norm.
#'
#' @rdname linalg-norm
#' @name norm
#'
#' @useDynLib fmlr R_linalg_norm
NULL

#' @rdname linalg-norm
#' @export
linalg_norm_1 = function(x)
{
  check_is_mat(x)
  .Call(R_linalg_norm, get_backend(x), x$get_type(), x$data_ptr(), "1")
}

#' @rdname linalg-norm
#' @export
linalg_norm_I = function(x)
{
  check_is_mat(x)
  .Call(R_linalg_norm, get_backend(x), x$get_type(), x$data_ptr(), "I")
}

#' @rdname linalg-norm
#' @export
linalg_norm_F = function(x)
{
  check_is_mat(x)
  .Call(R_linalg_norm, get_backend(x), x$get_type(), x$data_ptr(), "F")
}

#' @rdname linalg-norm
#' @export
linalg_norm_M = function(x)
{
  check_is_mat(x)
  .Call(R_linalg_norm, get_backend(x), x$get_type(), x$data_ptr(), "M")
}

#' @rdname linalg-norm
#' @export
linalg_norm_2 = function(x)
{
  check_is_mat(x)
  .Call(R_linalg_norm, get_backend(x), x$get_type(), x$data_ptr(), "2")
}

#' Condition Number
#'
#' Condition numbers.
#'
#' @param x Input data. The data is modified in each case.
#'
#' @return The requested condition number.
#'
#' @rdname linalg-cond
#' @name cond
#'
#' @useDynLib fmlr R_linalg_cond
NULL

#' @rdname linalg-cond
#' @export
linalg_cond_1 = function(x)
{
  check_is_mat(x)
  .Call(R_linalg_cond, get_backend(x), x$get_type(), x$data_ptr(), "1")
}

#' @rdname linalg-cond
#' @export
linalg_cond_I = function(x)
{
  check_is_mat(x)
  .Call(R_linalg_cond, get_backend(x), x$get_type(), x$data_ptr(), "I")
}

#' @rdname linalg-cond
#' @export
linalg_cond_2 = function(x)
{
  check_is_mat(x)
  .Call(R_linalg_cond, get_backend(x), x$get_type(), x$data_ptr(), "2")
}

#' dot
#'
#' Compute vector dot product i.e. \code{sum(x*y)}.
#'
#' @param x,y Input data.
#' class and type as \code{x}.
#' @return Returns the dot product.
#'
#' @rdname linalg-dot
#' @name dot
#'
#' @useDynLib fmlr R_linalg_dot
#'
#' @export
linalg_dot = function(x, y=NULL)
{
  check_is_vec(x)

  if (!is.null(y))
  {
    check_is_vec(y)
    check_backend_consistency(x, y)
    .Call(R_linalg_dot, get_backend(x), x$get_type(), x$data_ptr(), y$data_ptr())
  }
  else
    .Call(R_linalg_dot, get_backend(x), x$get_type(), x$data_ptr(), NULL)
}

#' trinv
#'
#' Invert a triangular matrix.
#'
#' @param upper Is the matrix upper triangular? Otherwise only the lower
#' triangle will be referenced.
#' @param unit_diag Is the matrix unit diagonal?
#' @param x Input data, overwritten by the inverse.
#' @return Returns \code{NULL}.
#'
#' @rdname linalg-trinv
#' @name trinv
#' @useDynLib fmlr R_linalg_trinv
#'
#' @export
linalg_trinv = function(upper, unit_diag, x)
{
  check_is_mat(x)

  upper = as.logical(upper)
  unit_diag = as.logical(unit_diag)

  .Call(R_linalg_trinv, get_backend(x), x$get_type(), upper, unit_diag, x$data_ptr())
  invisible(NULL)
}

#' rsvd
#'
#' SVD approximation via random projections.
#'
#' @param seed Seed for the random generator.
#' @param k The number of components to estimate. Integer > 0.
#' @param q Exponent (see paper if you really care). Values of 1 or 2 are good.
#' @param x Input data. The input values are overwritten.
#' @param s Singular values.
#' @param u,vt The left/right singular vectors. Should both be \code{NULL} or
#' matrices of the same backend and fundamental type as \code{x}.
#'
#' @references Halko, Nathan, Per-Gunnar Martinsson, and Joel A. Tropp. "Finding
#' structure with randomness: Probabilistic algorithms for constructing
#' approximate matrix decompositions." SIAM review 53, no. 2 (2011): 217-288.
#'
#' @rdname linalg-rsvd
#' @name rsvd
#' @useDynLib fmlr R_linalg_rsvd
#'
#' @export
linalg_rsvd = function(seed, k, q, x, s, u=NULL, vt=NULL)
{
  seed = as.integer(seed)
  k = as.integer(k)
  q = as.integer(q)

  check_is_mat(x)
  check_is_vec(s)

  check_type_consistency(x, s)
  if (!is.null(u) && !is.null(vt))
    check_inputs(x, u, vt)
  else if (!is.null(u) || !is.null(vt))
    stop("must pass neither u and vt or both u and vt")

  if (is.null(u))
    .Call(R_linalg_rsvd, get_backend(x), x$get_type(), seed, k, q, x$data_ptr(), s$data_ptr(), NULL, NULL)
  else
    .Call(R_linalg_rsvd, get_backend(x), x$get_type(), seed, k, q, x$data_ptr(), s$data_ptr(), u$data_ptr(), vt$data_ptr())

  invisible(NULL)
}


library(class)
data <- read.csv("Data_Heart_Disease.CSV")
dim(data)

attributes(data)

data[1:10,]

set.seed(1000)
ind <- sample(2, nrow(data), replace=TRUE, prob - c(0.7, 0.3))
data.train <- data[ind == 1,]
data.test <- data[ind == 2,]
# train a decision tree
library(rpart)
myFoumula <- Chest~Class+Blood + Serun + Sugar + Electrocardiographic + Heartrate + Angina + Oldpeak + Slope + Vessels + Thal
data_rpart <- rpart(myFormula, data=data.train, control=rpart.control(minsplit=10))
attributes(data_rpart)

plot(data_rpart)
text(data_rpart, use.n = T)

opt <- which.min(data_rpart$cptable[, "xerror"])
cp <- data_ra$captable[opt, "CP"]
data_prune <- prune(data_rpart, cp=cp)
print(data_prune)

plot(data_prune)
text(data_prune, use.n = T)

Chest_pred <- predict(data_prune, newdata=data.test)
xlim <- range(data$Chest)
plot(Chest_pred~Chest, data=data.test, xlab="Observed", ylab="Predicted", ylim=xlim, xlim = xlim)
abline(a=0, b=1)


 C02AMJ Example Program Results

  Roots of cubic equation             Error estimates
                                    (machine-dependent)

  z =  -2.0000E+00 +3.0000E+00*i          1.3E-15
  z =   1.0000E+00 -2.0000E+00*i          2.2E-15
  z =   3.0000E+00 -4.0000E+00*i          2.1E-15


# Get command line args with file names for processing
args <- commandArgs(TRUE)

# MBE PG functions
source("/ufrc/barbazuk/lboat/T.lamottei_T.crocifolius/Complete_data_set/align_reads_for_samcompare/scripts/emp_bayesian/Subroutines_model2_experimental.R")
source("/ufrc/barbazuk/lboat/T.lamottei_T.crocifolius/Complete_data_set/align_reads_for_samcompare/scripts/emp_bayesian/AI_poissongamma_functions.R")

# Prepare output file
fileout = args[2]
headers_out = "commonID,q4_mean_theta,q4_q025,q4_q975,q5_mean_theta,q5_q025,q5_q975,q6_mean_theta,q6_q025,q6_q975"
cat(headers_out,file=fileout,append=FALSE,sep="\n")

# Make Connection to input
con = file(args[1],"r")
newline<-readLines(con,n=1) # Go to header line
headers_in=strsplit(newline,split=",")[[1]]

mydata=rep(NA,length(headers_in))
names(mydata)=headers_in
m=1

while(length(newline) != 0 ){
    # Move past fusions that are not flag_analyze
    flaganalyze=0
    while(flaganalyze==0){
        newline<-readLines(con,n=1)
        if(length(newline)==0){break}
        mydata<-as.vector(strsplit(newline,split=",")[[1]])
        names(mydata)=headers_in
        flaganalyze=as.numeric(mydata["flag_analyze"])
    }
    if(length(newline)==0){break}

    print(paste("------------Analyzing",mydata['line'],mydata['mating_status'],mydata['fusion_id'], "--------------"));
    m=m+1
    X_RNA <- as.numeric(mydata[c("LINE_TOTAL_1","LINE_TOTAL_2","LINE_TOTAL_3","LINE_TOTAL_4","LINE_TOTAL_5")])
    X_RNA <- X_RNA[!is.na(X_RNA)]
    Y_RNA <- as.numeric(mydata[c("TESTER_TOTAL_1","TESTER_TOTAL_2","TESTER_TOTAL_3","TESTER_TOTAL_4","TESTER_TOTAL_5")])
    Y_RNA <- Y_RNA[!is.na(Y_RNA)]
    n_i <- X_RNA + Y_RNA

    # Create storage vectors for Quantiles and posterior means for theta (proportion of male reads) under different models
    means=q_025=q_975=rep(NA,3)
    names(means)=names(q_025)=names(q_975)=c("PG_4","PG_5","PG_6")

    #Poisson Gamma models q = .4
    tem_PG=gibbs_poissongamma(nsim=1000,nburnin=1000,lag=10,x=X_RNA,y=Y_RNA,both=c(0,0,0),a_mu=1/2,b_mu=1/2,a_alpha=1/2,b_alpha=1/2,a_beta=1/2,b_beta=1/2,
    q_=.4,#<-------As before but with q=q_sim
    abundance=FALSE)

    thetas=tem_PG$alphas/(1+tem_PG$alphas)
    q_025["PG_4"]= quantile(thetas,c(.025),na.rm=TRUE)
    q_975["PG_4"]= quantile(thetas,c(.975),na.rm=TRUE)
    means["PG_4"]= mean(thetas)

    #Poisson Gamma models q = .5
    tem_PG=gibbs_poissongamma(nsim=1000,nburnin=1000,lag=10,x=X_RNA,y=Y_RNA,both=c(0,0,0),a_mu=1/2,b_mu=1/2,a_alpha=1/2,b_alpha=1/2,a_beta=1/2,b_beta=1/2,
    q_=.5,#<-------As before but with q=q_sim
    abundance=FALSE)

    thetas=tem_PG$alphas/(1+tem_PG$alphas)
    q_025["PG_5"]= quantile(thetas,c(.025),na.rm=TRUE)
    q_975["PG_5"]= quantile(thetas,c(.975),na.rm=TRUE)
    means["PG_5"]= mean(thetas)

    #Poisson Gamma models q = .6
    tem_PG=gibbs_poissongamma(nsim=1000,nburnin=1000,lag=10,x=X_RNA,y=Y_RNA,both=c(0,0,0),a_mu=1/2,b_mu=1/2,a_alpha=1/2,b_alpha=1/2,a_beta=1/2,b_beta=1/2,
    q_=.6,#<-------As before but with q=q_sim
    abundance=FALSE)

    thetas=tem_PG$alphas/(1+tem_PG$alphas)
    q_025["PG_6"]= quantile(thetas,c(.025),na.rm=TRUE)
    q_975["PG_6"]= quantile(thetas,c(.975),na.rm=TRUE)
    means["PG_6"]= mean(thetas)

    # Create output and write to table
    SNPout = paste(mydata["commonID"],paste(round(c(means["PG_4"],q_025["PG_4"],q_975["PG_4"]),3),collapse=","),paste(round(c(means["PG_5"],q_025["PG_5"],q_975["PG_5"]),3),collapse=","),paste(round(c(means["PG_6"],q_025["PG_6"],q_975["PG_6"]),3),collapse=","),sep=",")
    cat(SNPout,file=fileout,append=TRUE,sep="\n")
}


# allocativ
# Healthy Neighborhoods
# ACS DP5Y2018 join Code
# FIPS sum, avg, gini code

## Import Libraries and Data

### Import Hadley Wickham Libraries
library(tidyverse) # All of the libraries above in one line of code

### Import Statistics Libraries
library(ineq) # Gini coefficient and Lorenz curve
library(pROC) # ROC tests with AUC output

### Import Data
setwd("C:/Users/drewc/GitHub/allocativ") # Set wd to project repository
df_ZCTA = read.csv("hnb/ACS/DP5Y2018/ACS_DP5Y2018_ZCTA_full.csv") # Import dataset from _data folder

### CLean Data
df_ZCTA = subset(df_ZCTA, select = -c(ZCTA, X, ST)) # Remove columns in dataframe
df_ZCTA[is.na(df_ZCTA)] <- 0 # Convert all NA to 0

### Convert all to numeric
df_FIPS = df_ZCTA
df_ZCTA = subset(df_ZCTA, select = -c(FIPS)) # Remove columns in dataframe
df_ZCTA = df_ZCTA %>% mutate_if(is.character, as.numeric) ## Change Characters to Numeric
df_ZCTA$FIPS = df_FIPS$FIPS

### Gini, Sum, AVG
tib_FIPS = df_ZCTA %>% group_by(FIPS) %>% summarise_all(.funs = list(gini = ~ ineq(x = ., type = "Gini"), avg = ~ mean(x = .))) # Group By Columns and Average
df_FIPS = as.data.frame(tib_FIPS) # Convert tiblle to Data Frame

### Export to CSV
write.csv(df_FIPS,"hnb/ACS/DP5Y2018/ACS_DP5Y2018_FIPS_gini.csv", row.names = FALSE)


#Objetivo:  mostrar  Repeated Random Sub Sampling Validation

#Modelo con libreria  rpart
#Estimo la ganancia con  Repeated Random Sub Sampling Validation   (Monte Carlo Cross Validation)

#source("M:\\R\\elementary\\MiPrimerModelo_02.r")

#limpio la memoria
rm(list=ls())
gc()

setwd("E:/UBA/2019-II/DM en Finanzas/Dropbox Prof/datasets")

library("rpart")
library("data.table")
library("dplyr")
library("rpart.plot")
library("ROCR")

#Parametros entrada
karchivo_entrada      <-  "201902.txt"
kcampos_separador     <-  "\t"
kcampo_id             <-  "numero_de_cliente"
kclase_nomcampo       <-  "clase_ternaria"
kclase_valor_positivo <-  "BAJA+2"
kcampos_a_borrar      <-  c(kcampo_id)

ktraining_prob        <-  0.70
ksemilla_azar         <-  c(102191, 200177, 410551, 552581, 892237)

#constantes de la funcion ganancia del problema
kprob_corte           <-  0.025
kganancia_acierto     <-  19500
kganancia_noacierto   <-   -500

#------------------------------------------------------
#Esta funcion calcula la ganancia de una prediccion
#Quedarse solo con las predicciones con probabilidad mayor a  kprob_corte
#Si es un acierto  sumar  kganancia_acierto    (+19500)
#Si NO es acierto  sumar  kganancia_noacierto  (  -500)

fmetrica_ganancia_rpart  = function(probs, clases)
{

  return( sum(   (probs > kprob_corte ) *
                   ifelse(clases== kclase_valor_positivo, kganancia_acierto, kganancia_noacierto)
             )
        )

}
#------------------------------------------------------
#Esta funcion calcula AUC  Area Under Curve  de la Curva ROC

fmetrica_auc_rpart  = function(probs, clases)
{
  testing_binaria  <-  as.numeric(clases == kclase_valor_positivo )
  pred             <-  ROCR::prediction( probs, testing_binaria, label.ordering=c(0, 1))
  auc_testing      <-  ROCR::performance(pred,"auc");

  return(unlist(auc_testing@y.values))

}
#------------------------------------------------------

#corre  rpart  usando  las semillas, y promedia el resultado

modelo_rpart_ganancia = function(dataset )
{
  gan      <- c()
  auc      <- c()
  tiempo   <- c()

  cantidad_semillas <- length(ksemilla_azar)

  for(s in  1:cantidad_semillas)
  {

    #Divido el dataset en training 70% y testing 30%  , usando la libreria dplyr
    dataset  <- as.data.table(mutate(dataset, idtempo =  row_number()))

    set.seed(ksemilla_azar[s] )
    dataset_training <- as.data.table(dataset %>%
      group_by(!!as.name(kclase_nomcampo)) %>%
      sample_frac(    ktraining_prob) %>%
      ungroup)
    dataset_testing  <- as.data.table(anti_join(dataset, dataset_training, by = "idtempo"))

    dataset_training[ ,  idtempo := NULL    ]
    dataset_testing[ ,  idtempo := NULL    ]

    # generacion del modelo
    formula  <-  formula(paste(kclase_nomcampo, "~ ."))

    t0       <-  Sys.time()
    modelo   <-  rpart(formula,   data = dataset_training,   cp=0.0,  xval=0)
    t1       <-  Sys.time()

    tiempo[s] <-  as.numeric( t1 - t0, units = "secs")

    #aplico el modelo a datos nuevos
    testing_prediccion  <- predict( modelo, dataset_testing , type = "prob")

    # calculo la ganancia normalizada  en testing
    gan[s] <-  fmetrica_ganancia_rpart(testing_prediccion[, kclase_valor_positivo ],  dataset_testing[ , get(kclase_nomcampo)]) / (1- ktraining_prob)

    # calculo el AUC en testing
    auc[s]     <- fmetrica_auc_rpart(testing_prediccion[ ,kclase_valor_positivo],  dataset_testing[ , get(kclase_nomcampo)])

  }
   return( list("ganancia_promedio"=mean(gan),  "vganancias"=gan ,  "vtiempos"= tiempo,  "AUC_promedio"=mean(auc), "vAUCs"=auc) )
}
#------------------------------------------------------

#cargo los datos
dataset <- fread(karchivo_entrada, header=TRUE, sep=kcampos_separador)

#borro las variables que no me interesan
dataset[ ,  (kcampos_a_borrar) := NULL    ]

t0       <-  Sys.time()
res  <-  modelo_rpart_ganancia(dataset)
t1       <-  Sys.time()

tcorrida <-  as.numeric( t1 - t0, units = "secs")

print(res)


model_snowdensity <- function (ps_t1 = 0.0,
         Sdepth_t1 = 0.0,
         Sdry_t1 = 0.0,
         Swet_t1 = 0.0){
    #'- Name: SnowDensity -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: Density of snow cover calculation
    #'            * Author: STICS
    #'            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    #'            * Institution: INRA
    #'            * Abstract: density of snow cover
    #'- inputs:
    #'            * name: ps_t1
    #'                          ** description : density of snow cover in previous day
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 100.0
    #'                          ** unit : kg/m**3
    #'                          ** uri :
    #'            * name: Sdepth_t1
    #'                          ** description : snow cover depth Calculation in previous day
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : m
    #'                          ** uri :
    #'            * name: Sdry_t1
    #'                          ** description : water in solid state in the snow cover in previous day
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : mmW
    #'                          ** uri :
    #'            * name: Swet_t1
    #'                          ** description : water in liquid state in the snow cover
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 100.0
    #'                          ** unit : mmW
    #'                          ** uri :
    #'- outputs:
    #'            * name: ps
    #'                          ** description : density of snow cover
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : kg/m**3
    #'                          ** uri :
    ps <- 0.0
    if (abs(Sdepth_t1) > 0.0)
    {
        if (abs(Sdry_t1 + Swet_t1) > 0.0)
        {
            ps <- (Sdry_t1 + Swet_t1) / Sdepth_t1
        }
        else
        {
            ps <- ps_t1
        }
    }
    return (list('ps' = ps))
}


dfull <- read_csv("full_set.csv")
df19 <- read_csv("full_set_2019.csv")
df20 <- read_csv("full_set_2020.csv")

dfull_s1 <- dfull[order(dfull$T2Q), ]
dfull_s2 <- dfull[order(dfull$T2Disp), ]
dfull_s3 <- dfull[order(dfull$ProcTime), ]

sum(dfull$T2Q < 0, na.rm=TRUE)
sum(dfull$T2Disp < 0, na.rm = TRUE)
sum(dfull$ProcTime < 0, na.rm=TRUE)
sum(dfull$T2Q < 0 & dfull$T2Disp < 0, na.rm=TRUE)
sum(dfull$T2Q < 0 & dfull$ProcTime < 0, na.rm=TRUE)
sum(dfull$ProcTime < 0 & dfull$T2Disp < 0, na.rm=TRUE)

create_report(dfull)
summary(dfull)
dim(dfull)
str(dfull)
uv_full <- unique(dfull)
dim(uv_full)
dupv_full <- get_dupes(dfull)
dupv_full
introduce(dfull)
describe(dfull)
makeDataReport(dfull)
ls(dfull)

mean(dfull$T2Q)
sd(dfull$T2Q)
median(dfull$T2Q)
scale(dfull$T2Q)
hist(dfull$T2Q)
hist(scale(dfull$T2Q))
nt2q <- dnorm(dfull$T2Q)
plot(nt2q)

t.test(dfull$T2Q, mu = 95)
t.test(dfull$T2Q, dfull$T2Disp)
var.test(dfull$T2Q, dfull$T2Disp)

fligner.test(T2Q ~ DOW, data = dfull)
aggregate(dfull$T2Q ~ dfull$DOW, FUN=var)
f.DOW <- factor(dfull$DOW)
f.Shift <- factor(dfull$Shift)

tapply(dfull$T2Q, f.DOW, mean)
tapply(dfull$T2Q, dfull$WeekNo, mean)
tapply(dfull$T2Q, f.DOW, median)
tapply(dfull$T2Q, dfull$WeekNo, median)
anova.fit1 <- aov(dfull$T2Q ~ f.DOW)
anova.t2q2 <- aov(dfull$T2Q ~ dfull$WeekNo)
anova.t2q3 <- aov(dfull$T2Q ~ dfull$Year)
summary(anova.fit1)
summary(anova.t2q2)
summary(anova.t2q3)
2.279e+05/(2.279e+05 + 1.631e+09)
model.tables(anova.fit1)
plot.design(dfull$T2Q ~ f.DOW)
TukeyHSD(anova.fit1)
plot(TukeyHSD(anova.fit1))
anovalm.fit1 <- lm(dfull$T2Q ~ f.DOW)
summary(anovalm.fit1)

t2q1.factoral <- aov(dfull$T2Q ~ f.DOW + f.Shift + f.DOW:f.Shift)
summary(t2q1.factoral)

t2q2.factorial <- aov(dfull$T2Q ~ dfull$Year + dfull$WeekNo + dfull$Year:dfull$WeekNo)
summary(t2q2.factorial)
testInteractions(t2q2.factorial, fixed="dfull$WeekNo", across="dfull$Year")

cor(dfull$T2Q, dfull$T2Disp)
cor.test(dfull$T2Q, dfull$T2Disp, method="pearson")
cor(dfull$T2Q, dfull$T2Disp, method="spearman")
cor(dfull$T2Q, dfull$ProcTime, method="spearman")
cor(dfull$T2Disp, dfull$ProcTime, method="spearman")
cor.test(dfull$T2Q, dfull$Year)
cor(dfull$T2Q, dfull$ProcTime)
cor(dfull$T2Disp, dfull$ProcTime)
plot(dfull$T2Q, dfull$T2Disp)

# Outlier Detection
hist(dfull$T2Q,
     xlab = "Time to Queue",
     main = "Histogram of Time to Queue",
     breaks = sqrt(nrow(dfull))
) # set number of bins

hist(dfull$T2Disp,
     xlab = "Time to Dispatch",
     main = "Histogram of Time to Dispatch",
     breaks = sqrt(nrow(dfull))
) # set number of bins

hist(dfull$ProcTime,
     xlab = "DECC Processing Time",
     main = "Histogram of Processing Time",
     breaks = sqrt(nrow(dfull))
) # set number of bins

ggplot(dfull) +
  aes(x = "", y = T2Q) +
  geom_boxplot(fill = "#1c5789") +
  theme_minimal()

ggplot(dfull) +
  aes(x = "", y = T2Disp) +
  geom_boxplot(fill = "#1c5789") +
  theme_minimal()

ggplot(dfull) +
  aes(x = "", y = ProcTime) +
  geom_boxplot(fill = "#1c5789") +
  theme_minimal()

T2Q_lb <- quantile(dfull$T2Q, 0.01)
T2Q_ub <- quantile(dfull$T2Q, 0.99)
T2Q_lb
T2Q_ub
T2Q_outTest <- grubbs.test(dfull$T2Q)
T2Q_outTest

T2Q_T2D_lb <- quantile(dfull$T2Disp, 0.01)
T2D_ub <- quantile(dfull$T2Disp, 0.99)
T2D_lb
T2D_ub
grubbs.test(dfull$T2Disp)

PT_lb <- quantile(dfull$ProcTime, 0.01)
PT_ub <- quantile(dfull$ProcTime, 0.99)
PT_lb
PT_ub
grubbs.test(dfull$ProcTime)

dfull <- na.omit(dfull)
df19 <- na.omit(df19)

dfull = dfull[!dfull$T2Q<0, ]
dfull = dfull[!dfull$T2Disp<0, ]

# normality tests
# Kolmogorov-Smirnov normality test P < 0.05 = non-normal distribution
ksnormTest(dfull$T2Q)
ksnormTest(dfull$T2Disp)
ksnormTest(dfull$ProcTime)

# Jarque-Bera normality test P < 0.05 = non-normal distribution
jarqueberaTest(dfull$T2Q)
jarqueberaTest(dfull$T2Disp)
jarqueberaTest(dfull$ProcTime)

# D'Agostino normality test P < 0.05 = non-normal distribution
dagoTest(dfull$T2Q)
dagoTest(dfull$T2Disp)
dagoTest(dfull$ProcTime)

# Anderson-Darling Normality Tests - P < 0.05 = non-normal distribution
ad.test(dfull$T2Q)
ad.test(dfull$T2Disp)
ad.test(dfull$ProcTime)

# Lillefors Test
lillieTest(dfull$T2Q)
lillieTest(dfull$T2Disp)
lillieTest(dfull$ProcTime)

# Pearson Chi-Square Normality Test
pchiTest(dfull$T2Q)
pchiTest(dfull$T2Disp)
pchiTest(dfull$ProcTime)

# plots full
ggdensity(dfull$T2Q, main="Density of Time to Queue", xlab="Time to Queue", fill="lightgrey")
ggdensity(dfull$T2Disp, main="Density of Time to Dispatch", xlab = "Time to Dispatch", fill = "lightgrey")
ggdensity(dfull$ProcTime, main = "Density of Processing Time", xlab = "Processing Time", fill = "lightgrey")
ggqqplot(dfull$T2Q)
ggqqplot(dfull$T2Disp)
ggqqplot(dfull$ProcTime)

tapply(dfull$T2Q,dfull$Shift,mean,na.rm=TRUE)
tapply(dfull$T2Q,dfull$DOW,mean,na.rm=TRUE)

attach(dfull)
kruskal.test(T2Q, g = Year)
kruskal.test(T2Disp, g=Year)
kruskal.test(ProcTime, g=Year)

kruskal.test(dfull$T2Q, g = as.factor(dfull$Problem))
posthoc.kruskal.nemenyi.test(dfull$T2Q, as.factor(dfull$Problem), data=dfull)

kruskal.test(dfull$T2Q, g=dfull$Hour)
posthoc.kruskal.nemenyi.test(dfull$T2Q, dfull$Hour, data=dfull)
kruskal.test(T2Q, g=Problem)
kruskal.test(dfull$T2Q, g=as.factor(dfull$DOW))
posthoc.kruskal.nemenyi.test(dfull$T2Q, as.factor(dfull$DOW), data=dfull)
boxplot(T2Q ~ DOW, data = dfull, ylab="Time 2 Queue in secs", xlab = "Day of the Week")
pairwise.wilcox.test(dfull$T2Q, g=as.factor(dfull$DOW))
pairwise.wilcox.test(dfull$T2Q, g=as.factor(dfull$DOW), p.adjust.method = "bonferroni")
kruskalmc(dfull$T2Q ~ as.factor(dfull$DOW), probs = .05, cont=NULL)
res.dow <- manova(cbind(T2Q, T2Disp) ~ DOW, data = dfull)
summary(res.dow)
summary.aov(res.dow)
detach(dfull)

wilcox.test(T2Q ~ Shift, data = dfull, exact = FALSE)
wilcox.test(T2Disp ~ Shift, data = dfull, exact = FALSE)
wilcox.test(ProcTime ~ Shift, data = dfull, exact = FALSE)

wilcox.test(T2Q ~ Shift, data = dfull, exact = FALSE, alterative = "greater")
wilcox.test(T2Q ~ Shift, data = dfull, exact = FALSE, alternative = "less")

t2q_rank <- rank(dfull$T2Q)

nparml(T2Q|T2Disp|ProcTime~Month*DOW, dfull)
nparml(T2Q|T2Disp|ProcTime~Year*WeekNo, dfull)
nparml(T2Q|T2Disp|ProcTime~Year*Month, dfull)
nparml(T2Q|T2Disp|ProcTime~Year*Agency, dfull)
nparml(T2Q|T2Disp|ProcTime~Year*Priority_Number, dfull)

nonpartest(T2Q|T2Disp|ProcTime~Year, dfull, permreps = 10000, plots = TRUE)


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 16, 2016

### Change spacing to allow for multiline title
par(oma=c(2, 0, 4, 0))
### Some greek letters
mu <- 0
alpha <- 1
beta <- 2
delta <- 3
lambda <- 4
### Some graph or other
plot(1:10,1:10)
mtext(expression(bold("Meaningless Title")),
      line=3.5,cex=1.15)
mtext(bquote(paste(lambda==.(lambda),", ",
                   alpha==.(alpha),", ",
                   beta==.(beta),", ",
                   delta==.(delta),", ",
                   mu==.(mu),sep="")),
      line=2.25,cex=1.15)


#' Compute empirical cumulative distribution
#'
#' The empirical cumulative distribution function (ECDF) provides an alternative
#' visualisation of distribution. Compared to other visualisations that rely on
#' density (like [geom_histogram()]), the ECDF doesn't require any
#' tuning parameters and handles both continuous and categorical variables.
#' The downside is that it requires more training to accurately interpret,
#' and the underlying visual tasks are somewhat more challenging.
#'
#' The statistic relies on the aesthetics assignment to guess which variable to
#' use as the input and which to use as the output. Either x or y must be provided
#' and one of them must be unused. The ECDF will be calculated on the given aesthetic
#' and will be output on the unused one.
#'
#' @inheritParams layer
#' @inheritParams geom_point
#' @param na.rm If `FALSE` (the default), removes missing values with
#'    a warning.  If `TRUE` silently removes missing values.
#' @param n if NULL, do not interpolate. If not NULL, this is the number
#'   of points to interpolate with.
#' @param pad If `TRUE`, pad the ecdf with additional points (-Inf, 0)
#'   and (Inf, 1)
#' @section Computed variables:
#' \describe{
#'   \item{y}{cumulative density corresponding x}
#' }
#' @export
#' @examples
#' df <- data.frame(
#'   x = c(rnorm(100, 0, 3), rnorm(100, 0, 10)),
#'   g = gl(2, 100)
#' )
#' ggplot(df, aes(x)) +
#'   stat_ecdf(geom = "step")
#'
#' # Don't go to positive/negative infinity
#' ggplot(df, aes(x)) +
#'   stat_ecdf(geom = "step", pad = FALSE)
#'
#' # Multiple ECDFs
#' ggplot(df, aes(x, colour = g)) +
#'   stat_ecdf()
stat_ecdf <- function(mapping = NULL, data = NULL,
                      geom = "step", position = "identity",
                      ...,
                      n = NULL,
                      pad = TRUE,
                      na.rm = FALSE,
                      show.legend = NA,
                      inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = StatEcdf,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      n = n,
      pad = pad,
      na.rm = na.rm,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatEcdf <- ggproto("StatEcdf", Stat,
  required_aes = c("x|y"),

  default_aes = aes(y = after_stat(y)),

  setup_params = function(data, params) {
    params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE, main_is_continuous = TRUE)

    has_x <- !(is.null(data$x) && is.null(params$x))
    has_y <- !(is.null(data$y) && is.null(params$y))
    if (!has_x && !has_y) {
      abort("stat_ecdf() requires an x or y aesthetic.")
    }

    params
  },

  compute_group = function(data, scales, n = NULL, pad = TRUE, flipped_aes = FALSE) {
    data <- flip_data(data, flipped_aes)
    # If n is NULL, use raw values; otherwise interpolate
    if (is.null(n)) {
      x <- unique(data$x)
    } else {
      x <- seq(min(data$x), max(data$x), length.out = n)
    }

    if (pad) {
      x <- c(-Inf, x, Inf)
    }
    data_ecdf <- ecdf(data$x)(x)

    df_ecdf <- new_data_frame(list(x = x, y = data_ecdf), n = length(x))
    df_ecdf$flipped_aes <- flipped_aes
    flip_data(df_ecdf, flipped_aes)
  }
)


#INDEX FUNCTIONS

library(dslabs)
library(tidyverse)
data (murders)

murder_rate <- murders$total/murders$population*100000

#let's see murder rate for several states unsing MATCH
index <- match(c("New York", "Florida", "Texas"), murders$state)
murder_rate[index]

index

murder_rate[index]

#Is Boston, Dakota and Washington states?
c("Boston", "Dakota", "Washington") %in% murders$state


MDepths <- read.csv("Depths.csv", header=TRUE)
X06<- MDepths[,06]
X06<-X06[!is.na(X06)]
as.data.frame(X06)
dat06<- data.frame(X06)
p06<-ggplot(dat06, aes(X06)) +
  labs(title = "Profile Nr.06", x = "Depths, m", y = "Density") +
  theme(
    plot.title = element_text(family = "Skia", face = 2, size = 10),
    panel.background=ggplot2::element_rect(fill = "gray91"),
    legend.position = c(.90, .90),
    legend.justification = c("right", "top"),
    legend.box.just = "right",
    legend.margin = margin(6, 6, 6, 6),
    legend.direction = "vertical",
    legend.background = element_blank(),
    legend.key.width = unit(.5,"cm"),
    legend.key.height = unit(.3,"cm"),
    legend.spacing = unit(.3,"cm"),
    legend.box.background = element_rect(colour = "honeydew4",size=0.2),
    legend.text = element_text(family = "Arial", colour="black", size=6, face=1),
    legend.title = element_blank(),
    strip.text.x = element_text(colour = "white"),
    panel.grid.major = element_line("white", size = 0.3),
    panel.grid.minor = element_line("white", size = 0.3, linetype = "dotted"),
    axis.text.x = element_text(family = "Arial", face = 3, color = "gray24",size = 6, angle = 15),
    axis.ticks.length=unit(.2,"cm"),
    axis.text.y = element_text(family = "Arial", face = 3, color = "gray24",size = 6, angle = 15),
    axis.line = element_line(colour = "darkblue", size = .3, linetype = "solid"),
    axis.title.y = element_text(margin = margin(t = 20, r = .3), family = "Times New Roman", face = 1, size = 6),
    axis.title.x = element_text(family = "Times New Roman", face = 1, size = 6,margin = margin(t = .2))) +
  scale_x_continuous(breaks = pretty(dat06$X06, n = 4), minor_breaks = seq(min(dat06$X06), max(dat06$X06), by = 500)) +
  scale_y_continuous(breaks = scales::pretty_breaks(n = 4),labels = scales :: percent) +
  scale_fill_distiller(palette = "PuOr") +
  scale_color_manual(name = "Statistics:", values = c(median = "purple", mean = "green4",density = "blue", norm_dist = "black")) +
  geom_histogram(binwidth = 200,aes(fill = ..density..,x = dat06$X06,y = ..density..),color = "blue",size = .1) +
  stat_function(fun = dnorm, args = list(mean = mean(dat06$X06), sd = sd(dat06$X06)), lwd = 0.2, color = 'black') +
  stat_density(geom = "line", size = .3, aes(color = "density")) +
	     geom_vline(aes(color = "mean", xintercept = mean(X06)), lty = 4, size = .3) +
	     geom_vline(aes(color = "median", xintercept = median(X06)), lty = 2, size = .3)  +
	     geom_vline(aes(color = "norm_dist", xintercept = dnorm(X06)), lty = 2, size = .3)
p06


#Fit MULTINOMIAL dirlichet models to functional groups of fungi from Tedersoo et al. Temperate Latitude Fungi.
#No hierarchy required, as everything is observed at the site level. Each observation is a unique site.
#Missing data are allowed.
#clear environment
rm(list = ls())
library(data.table)
library(doParallel)
source('paths.r')
source('NEFI_functions/dmulti-ddirch_site.level_JAGS.r')
source('NEFI_functions/crib_fun.r')

#detect and register cores.----
n.cores <- detectCores()
registerDoParallel(cores=n.cores)

#set output path.----
output.path <- ted_ITS.prior_dmulti.ddirch_fg_JAGSfit

#load tedersoo data.----
d <- data.table(readRDS(tedersoo_ITS_clean_map.path))
y <- readRDS(tedersoo_ITS_fg_list.path)
seq.depth <- y$seq_total
y <- y$abundances
#d <- d[,.(Ectomycorrhizal,Saprotroph,Pathogen,Arbuscular,pC,cn,pH,moisture,NPP,map,mat,forest,conifer,relEM)]
d <- d[,.(SRR.id,pC,cn,pH,moisture,NPP,map,mat,forest,conifer,relEM)]
d <- d[complete.cases(d),] #optional. This works with missing data.
y <- y[rownames(y) %in% d$SRR.id,]
#y$Arbuscular <- NULL
y <- as.data.frame(y)
testing = F
if(testing == T){
  d <- d[1:35,] #for testing
  y <- y[rownames(y) %in% d$SRR.id,]
}

#organize y data----
#y <- d[,.(Ectomycorrhizal,Saprotroph,Pathogen)]
#y$other <- 1 - rowSums(y)
#y <- data.frame(lapply(y,crib_fun, N = nrow(y) * ncol(y)))
#in the rare case where one column actually needs to be a zero for a row to prevent to summing over 1...
#for(i in 1:nrow(y)){
#  if(rowSums(y[i,]) > 1){
#    y[i,] <- y[i,] / rowSums(y[i,])
#  }
#}

#Drop in intercept, setup predictor matrix.----
#IMPORTANT: LOG TRANSFORM MAP.
d$intercept <- rep(1,nrow(d))
d$map <- log(d$map)
x <- d[,.(intercept,pC,cn,pH,moisture,NPP,mat,map,forest,conifer,relEM)]

#define multiple subsets
x.clim <- d[,.(intercept,NPP,mat,map)]
x.site <- d[,.(intercept,pC,cn,pH,forest,conifer,relEM)]
x.all  <- d[,.(intercept,pC,cn,pH,NPP,mat,map,forest,conifer,relEM)]
x.list <- list(x.clim,x.site,x.all)

#fit model using function.----
#This take a long time to run, probably because there is so much going on.
#fit <- site.level_dirlichet_jags(y=y,x_mu=x,adapt = 50, burnin = 50, sample = 100)
#for running production fit on remote.
output.list<-
  foreach(i = 1:length(x.list)) %dopar% {
    fit <- site.level_multi.dirich_jags(y=y,seq.depth=seq.depth,x_mu=x.list[i],adapt = 200, burnin = 16000, sample = 5000, parallel = T)
    return(fit)
  }

#get intercept only fit.
#output.list[[length(x.list) + 1]] <- site.level_dirlichet_intercept.only_jags(y=y, silent.jags = T)

#name the items in the list, save output.----
#names(output.list) <- c('climate.preds','site.preds','all.preds','int.only')
names(output.list) <- c('climate.preds','site.preds','all.preds')

cat('Saving fit...\n')
saveRDS(output.list, output.path)
cat('Script complete. \n')


#' Score Case Identification Indicators
#'
#' @param df site MSD file
#'
#' @export
#' @importFrom magrittr %>%

score_ci <- function(df){

  #1.&2. HTS_TST_POS Position relative to OU-/PSNU-level median (median last three quarters)

  #pull headers to figure out last three quarters to keep
    headers <- names(df)
    pds <- headers[stringr::str_detect(headers, "q(?=[:digit:])")] %>%
      tail(., n =3)

  #narrow down to data needed for indicator creation
    ci_hts_pos <- df %>%
      dplyr::filter(indicator == "HTS_TST_POS",
             standardizeddisaggregate == "Total Numerator",
             typemilitary == "N") %>%
      dplyr::select(operatingunit, psnu,sitename, orgunituid, pds) %>%
      dplyr::filter_at(dplyr::vars( dplyr::contains("q")),
                        dplyr::any_vars(!is.na(.) & .!=0)) #remove if all quarters are missing
  #site sum over last 3 pds
    ci_hts_pos <- ci_hts_pos %>%
      tidyr::gather(pd, val, dplyr::starts_with("fy")) %>%
      dplyr::select(-pd) %>%
      dplyr::group_by_if(is.character) %>%
      dplyr::summarise_if(is.numeric, ~ sum(., na.rm = TRUE)) %>%
      dplyr::ungroup()

  #Calculate percentile grouping
    ci_hts_pos <- ci_hts_pos %>%
      dplyr::group_by(operatingunit) %>%
      dplyr::mutate(ci.hts_pos_ou.score = dplyr::case_when(val > quantile(val, .75) ~ 2,
                                             val > quantile(val, .50) ~ 1,
                                             TRUE                     ~ 0)) %>%
      dplyr::ungroup() %>%
      dplyr::group_by(operatingunit, psnu) %>%
      dplyr::mutate(ci.hts_pos_psnu.score = dplyr::case_when(val > quantile(val, .75) ~ 2,
                                               val > quantile(val, .50) ~ 1,
                                               TRUE                     ~ 0)) %>%
      dplyr::ungroup() %>%
      dplyr::mutate(ci.hts_pos_ou.value = val) %>%
      dplyr::rename(ci.hts_pos_psnu.value = val)

  #3. Year on Year change in volume

  #figure out quarter to cal cumulative in prior year
    qtr <- ICPIutilities::identifypd(df, "quarter")
    qtr_fltr <- dplyr::case_when(qtr == 1 ~ "1",
                          qtr == 2 ~ "(1|2)",
                          qtr == 3 ~ "(1|2|3)",
                          qtr == 4 ~ "(?=[:digit:])")
    pds <- headers[stringr::str_detect(headers, paste0("q", qtr_fltr))]

  #filter to key cols and variables
    ci_hts_pos_yoy <- df %>%
      dplyr::filter(indicator == "HTS_TST_POS",
                    standardizeddisaggregate == "Total Numerator",
                    typemilitary == "N") %>%
      dplyr::select(operatingunit, psnu,sitename, orgunituid, pds)

  #create year over year percent/raw change
    ci_hts_pos_yoy <- ci_hts_pos_yoy %>%
      tidyr::gather(pd, val, dplyr::starts_with("fy"), na.rm = TRUE) %>%
      dplyr::mutate(pd = stringr::str_remove_all(pd, "q[:digit:]")) %>%
      dplyr::group_by_if(is.character) %>%
      dplyr::summarise_if(is.numeric, ~ sum(., na.rm = TRUE)) %>%
      dplyr::mutate(ci.hts_pos_yoyd =  val - dplyr::lag(val),
                    ci.hts_pos_yoyc = (val - dplyr::lag(val))/dplyr::lag(val)) %>%
      dplyr::ungroup() %>%
      dplyr::filter(pd == "fy2018", is.finite(ci.hts_pos_yoyc))

  #Calculate percentile grouping
  ci_hts_pos_yoy <- ci_hts_pos_yoy %>%
    dplyr::group_by(operatingunit) %>%
    dplyr::mutate(ci.hts_pos_yoyd.score =
                    dplyr::case_when(ci.hts_pos_yoyd > quantile(ci.hts_pos_yoyd, .75) ~ 2,
                                     ci.hts_pos_yoyd > quantile(ci.hts_pos_yoyd, .50) ~ 1,
                                     TRUE                                             ~ 0),
                  ci.hts_pos_yoyc.score =
                    dplyr::case_when(ci.hts_pos_yoyc > quantile(ci.hts_pos_yoyc, .75) ~ 2,
                                     ci.hts_pos_yoyc > quantile(ci.hts_pos_yoyc, .50) ~ 1,
                                     TRUE                                             ~ 0)) %>%
    dplyr::ungroup() %>%
    dplyr::rename(ci.hts_pos_yoyd.value = ci.hts_pos_yoyd,
           ci.hts_pos_yoyc.value = ci.hts_pos_yoyc,
           ci.hts_pos_yoy.value = val) %>%
    dplyr::select(-pd, -ci.hts_pos_yoy.value)

  #4. Share Index testing

  #narrow down to data needed for indicator creation
    ci_index <- df %>%
      dplyr::filter(indicator == "HTS_TST",
                    standardizeddisaggregate %in% c("Modality/Age Aggregated/Sex/Result",
                                                    "Modality/Age/Sex/Result"),
                    typemilitary == "N") %>%
      dplyr::select(operatingunit, psnu,sitename, orgunituid, pds, modality) %>%
      dplyr::filter_at(dplyr::vars(dplyr::contains("q")), dplyr::any_vars(!is.na(.) & .!=0)) #remove if all quarters are missing

  #site sum over last 3 pds
    ci_index <- ci_index %>%
      tidyr::gather(pd, val, dplyr::starts_with("fy"), na.rm = TRUE) %>%
      dplyr::select(-pd) %>%
      dplyr::mutate(modality = ifelse(modality %in% c("Index", "IndexMod"), "ALL Index", modality)) %>%
      dplyr::group_by_if(is.character) %>%
      dplyr::summarise_if(is.numeric, ~ sum(., na.rm = TRUE)) %>%
      dplyr::ungroup()

  #index share
    ci_index <- ci_index %>%
      dplyr::group_by(operatingunit, psnu, sitename, orgunituid) %>%
      dplyr::mutate(indexshare = round(val / sum(val), 2)) %>%
      dplyr::ungroup() %>%
      dplyr::filter(modality == "ALL Index") %>%
      dplyr::select(-modality)

  #Calculate percentile grouping
    ci_index <- ci_index %>%
      dplyr::group_by(operatingunit, psnu) %>%
      dplyr::mutate(ci.hts_index.score =
                      dplyr::case_when(indexshare < quantile(indexshare, .25) ~ 2,
                                       indexshare < quantile(indexshare, .50) ~ 1,
                                       TRUE                                   ~ 0)) %>%
      dplyr::ungroup() %>%
      dplyr::rename(ci.hts_index.value = indexshare) %>%
      dplyr::select(-val)

  #combine all together
    ci <- list(ci_hts_pos, ci_hts_pos_yoy, ci_index) %>%
      purrr::reduce(dplyr::full_join, by = c("operatingunit", "psnu", "sitename", "orgunituid"))
    return(ci)
}


rents.raw <- read.csv("../Downloads/Neighborhood_MedianRentalPricePerSqft_Sfr.csv", header=TRUE)
prices.raw <- read.csv("../Downloads/Neighborhood_MedianListingPricePerSqft_AllHomes.csv", header=TRUE)
pce <- read.csv("../Downloads/PCEPILFE.csv", header=TRUE)
pce$month <- as.Date(pce$DATE)
data.raw <- merge(rents.raw, prices.raw, all=TRUE)

while (nrow(data.raw)>1) {
    current.region = data.raw[1:2,]
    if (current.region$RegionName[1]==current.region$RegionName[2] && current.region$State[1]==current.region$State[2] && current.region$City[1]==current.region$City[2] && current.region$Metro[1]==current.region$Metro[2] && current.region$CountyName[1]==current.region$CountyName[2]) {
        region.data <- t(subset(current.region, select=-c(RegionName, City, State, Metro, CountyName, SizeRank)))
        region.df <- as.data.frame(region.data)
        colnames(region.df) <- c("rent", "price")
        if (sum(!is.na(region.df$rent))>36 && sum(!is.na(region.df$price))>36) {
            region.df$month <- substring(rownames(region.df), 2)
            substring(region.df$month, 5) <- "-"
            region.df$month <- as.Date(paste(region.df$month, "-01", sep=""))
            region.df <- merge(region.df, pce, all.x=TRUE)
            region.df$adj.PCE <- region.df$PCEPILFE/100
            region.df$real.rent <- region.df$rent*region.df$adj.PCE
            region.df$real.price <- region.df$price*region.df$adj.PCE

            library(seasonal)
            deseas.rent <- seas(ts(region.df$real.rent, start=c(2010, 1), end=c(2019, 9), frequency=12), regression.aictest=NULL)
            deseas.rent.df <- subset(as.data.frame(deseas.rent), select=c(date, final))
            colnames(deseas.rent.df)[colnames(deseas.rent.df)=="date"] <- "month"
            colnames(deseas.rent.df)[colnames(deseas.rent.df)=="final"] <- "adj.rent"
            region.df <- merge(region.df, deseas.rent.df, all.x=TRUE)

            deseas.price <- seas(ts(region.df$real.price, start=c(2010, 1), end=c(2019, 9), frequency=12), regression.aictest=NULL)
            deseas.price.df <- subset(as.data.frame(deseas.price), select=c(date, final))
            colnames(deseas.price.df)[colnames(deseas.price.df)=="date"] <- "month"
            colnames(deseas.price.df)[colnames(deseas.price.df)=="final"] <- "adj.price"
            region.df <- merge(region.df, deseas.price.df, all.x=TRUE)

            scatterdata <- subset(region.df, select=c(adj.rent, adj.price, adj.PCE))
            outpath <- file.path("rentvsprice/plots/scatter", paste(current.region$RegionName[1], current.region$State[1], ".png", sep=""))

            png(file=outpath)
            pairs(scatterdata, main=paste(current.region$RegionName[1], current.region$State[1], sep=", "))
            dev.off()

            data.raw <- data.raw[-c(1, 2),]
        } else {
            data.raw <- data.raw[-c(1, 2),]
        }
    } else {
        data.raw <- data.raw[-c(1),]
    }
}


midata <- read.csv("c:/datos_voltaje.csv")
midata$Temperatura <- as.factor(midata$Temperatura)
midata$material <- as.factor(midata$material)
anova <- aov(voltaje~Temperatura+material+Temperatura*material,midata)
summary(anova)

interaction.plot(midata$Temperatura,midata$material,midata$voltaje,
                 xlab="Factor: Temperatura",
                 ylab="Voltaje",
                 leg.legend="Material")

# Medias
tapply(midata$voltaje,midata$Temperatura, mean)
tapply(midata$voltaje,midata$material, mean)

#Estimacion
tapply(midata$voltaje,midata$Temperatura, mean) - mean(midata$voltaje)
tapply(midata$voltaje,midata$material, mean) - mean(midata$voltaje)


#Importa dados
source("http://www.openintro.org/stat/data/present.R")

##Exercicio 1

#anos incluídos
present$year

# dimensoes e nomes das dimensoes
dim(present)
names(present)

##Exercicio 2

#----

##Exercicio 3

present$boys > present$girls

p <- present$boys / (present$boys + present$girls)
p > 0.5

##Exercicio 4

plot(x = present$year, y = present$boys + present$girls, type = "l")

#Exercicio 5

present$year[which.max(present$boys+present$girls)]


# Title: tactFns.r
# Objective: central script containing most tactical acquisition and turn fns
# Created by: NR
# Additional editors:

tactAcq01 <- function(eval.obj){
  eval.obj$threshold <- with(eval.obj,Open-2*med.daily.sd) # maybe replace open w/predictor from a mod
  eval.obj$flag_buy <- with(eval.obj,Last<threshold)
  eval.obj <- eval.obj[with(eval.obj,order(cvhat,decreasing=T)),]
  return(eval.obj)
}

tactTurn01 <- function(eval.obj,sThreshold=1){
  eval.obj$sell_threshold <- with(eval.obj,price+sThreshold*med.daily.sd)
  eval.obj$stop_loss <- with(eval.obj, Open-3*med.daily.sd)
  eval.obj$flag_sell <- with(eval.obj,(Last>sell_threshold | (Last < stop_loss & Last > stop_loss-med.daily.sd)))
  return(eval.obj)
}

# For the stop loss above, be sure to set a window of an acceptable sell so a sell isn't made at the bottom of a huge drop


# input for tests for summarize_col
two_cols_three_rows <- data.frame(x = letters[1:3], y = c(2, 4, 6))
two_cols_four_rows_nas <- data.frame(x = letters[1:4], y = c(2, 4, 6, NA))
one_col_three_rows <- data.frame(y = c(2, 4, 6))
two_cols_three_rows_all_same <- data.frame(x = letters[1:3], y = rep(1, 3))
two_cols_one_row <- data.frame(x = "a", y = 2)
empty_df  <- data.frame(x = character(0), y = numeric(0))
two_cols_three_rows_not_numeric <- data.frame(x = letters[1:3], y = letters[7:9])
list_named_numeric_vector <- list(y = c(2, 4, 6))

# expected output from summarize_col
three_rows_output <- data.frame(median = 4,
                                mean = 4,
                                standard_deviation = 2)

two_cols_three_rows_all_same_output <- data.frame(median = 1,
                                                  mean = 1,
                                                  standard_deviation = 0)

two_cols_one_row_output <- data.frame(median = 2,
                                      mean = 2,
                                      standard_deviation = as.numeric(NA))

two_cols_four_rows_nas_remove_false <- data.frame(median = as.numeric(NA),
                                                  mean = as.numeric(NA),
                                                  standard_deviation = as.numeric(NA))

empty_df_output <- data.frame(median = numeric(0),
                       mean = numeric(0),
                       standard_deviation = numeric(0))


sapply(4:12, function(n) ncol(queens(n)))


#' Cosine Similarity
#'
#' Compute the cosine similarity matrix efficiently.  The function
#' syntax and behavior is largely modeled after that of the
#' \code{cosine()} function from the \code{lsa} package, although
#' with a very different implementation.
#'
#' @details
#' See \code{?coop-package} for implementation details.
#'
#' @param x
#' A numeric dataframe/matrix or vector.
#' @param y
#' A vector (when \code{x} is a vector) or missing (blank) when
#' \code{x} is a matrix.
#' @param use
#' The NA handler, as in R's \code{cov()} and \code{cor()}
#' functions.  Options are "everything", "all.obs", and
#' "complete.obs".
#' @param inverse
#' Logical; should the inverse covariance matrix be returned?
#'
#' @return
#' The \eqn{n\times n} matrix of all pair-wise vector cosine
#' similarities of the columns.
#'
#' @examples
#' x <- matrix(rnorm(10*3), 10, 3)
#'
#' coop::cosine(x)
#' coop::cosine(x[, 1], x[, 2])
#'
#' @author Drew Schmidt
#' @seealso \code{\link{sparsity}}
#' @name cosine
#' @rdname cosine
NULL

#' @rdname cosine
#' @export
cosine <- function(x, y, use="everything", inverse=FALSE) UseMethod("cosine")

#' @export
cosine.matrix <- function(x, y, use="everything", inverse=FALSE)
{
  co_matrix(x, y, CO_SIM, use, inplace=FALSE, inverse=inverse)
}

#' @export
cosine.data.frame <- function(x, y, use="everything", inverse=FALSE)
{
  x_mat = as.matrix(x)
  if (!missing(y) && is.data.frame(y))
    y = as.matrix(y)

  cosine.matrix(x_mat, y, use=use, inverse=inverse)
}

#' @export
cosine.default <- function(x, y, use="everything", inverse=FALSE)
{
  co_vecvec(x, y, CO_SIM, use)
}

#' @export
cosine.simple_triplet_matrix <- function(x, y, use="everything", inverse=FALSE)
{
  if (!missing(y))
    stop("argument 'y' can not be used with a matrix 'x'")

  n <- x$ncol
  a <- x$v
  i <- x$i
  j <- x$j
  index <- 1L
  type <- CO_SIM

  if (length(a) != length(i) || length(i) != length(j))
    stop("Malformed simple_triplet_matrix: lengths of 'v', 'i', and 'j' do not agree")

  ret <- co_sparse(n, a, i, j, index, type, use, inverse)
  if (!is.null(colnames(x)))
  {
    rownames(ret) <- colnames(x)
    colnames(ret) <- colnames(x)
  }

  ret
}

#' @export
cosine.dgCMatrix <- function(x, y, use="everything", inverse=FALSE)
{
  if (!missing(y))
    stop("argument 'y' can not be used with a matrix 'x'")

  n <- ncol(x)
  a <- x@x
  i <- x@i
  j <- csc_to_coo(i, x@p)
  index <- 0L
  type <- CO_SIM

  if (length(a) != length(i) || length(i) != length(j))
    stop("Malformed dgCMatrix: lengths of 'x', 'i', and 'p' do not agree")

  ret <- co_sparse(n, a, i, j, index, type, use, inverse)
  if (!is.null(colnames(x)))
  {
    rownames(ret) <- colnames(x)
    colnames(ret) <- colnames(x)
  }

  ret
}

### tcosine

#' @rdname cosine
#' @export
tcosine <- function(x, y, use="everything", inverse=FALSE) UseMethod("tcosine")

#' @export
tcosine.matrix <- function(x, y, use="everything", inverse=FALSE)
{
  co_matrix(x, y, CO_SIM, use, inplace=FALSE, trans=TRUE, inverse=inverse)
}

#' @export
tcosine.data.frame <- function(x, y, use="everything", inverse=FALSE)
{
  x_mat = as.matrix(x)
  if (!missing(y) && is.data.frame(y))
    y = as.matrix(y)

  tcosine.matrix(x_mat, y, use=use, inverse=inverse)
}


rm(list=ls())
#library(caret) # for dummyVars
#library(RCurl) # download https data
library(Metrics) # calculate errors
library(xgboost) # model

###############################################################################

MultiLogLoss <- function(act, pred)
{
  eps = 1e-15;
  nr <- nrow(pred)
  pred = matrix(sapply( pred, function(x) max(eps,x)), nrow = nr)
  pred = matrix(sapply( pred, function(x) min(1-eps,x)), nrow = nr)
  ll = sum(act*log(pred) + (1-act)*log(1-pred))
  ll = ll * -1/(nrow(act))
  # print (ll)
  return(ll);
}

###############################################################################

TRFile <- "TR_Mul_Feat.csv"

TrainSet <- read.csv(TRFile, header=F)
dim(TrainSet)
names(TrainSet) <- c(1:19,"class")
names(TrainSet)

###############################################################################

outcomeName <- c('class')
predictors <- names(TrainSet)[!names(TrainSet) %in% outcomeName]
adultsTrsf <- TrainSet

# play around with settings of xgboost - eXtreme Gradient Boosting (Tree) library
# https://github.com/tqchen/xgboost/wiki/Parameters
# max.depth - maximum depth of the tree
# nrounds - the max number of iterations

# take first 40% of the data only!
#~ trainPortion <- floor(nrow(adultsTrsf)*0.4)
#~ trainSet <- adultsTrsf[ 1:floor(trainPortion/2),]
#~ testSet <- adultsTrsf[(floor(trainPortion/2)+1):trainPortion,]

# take random 40% of the data only!
 size=nrow(adultsTrsf)*0.6
 selected=sample(nrow(adultsTrsf),size)
 trainPortion <- adultsTrsf[selected,]
 otherPortion <- adultsTrsf[-selected,]

dtrain = xgb.DMatrix(data = as.matrix(trainPortion[,predictors]), label = trainPortion[,outcomeName])
dtest = xgb.DMatrix(data = as.matrix(otherPortion[,predictors]), label = otherPortion[,outcomeName])

watchlist <- list(train=dtrain, test=dtest)

sink("CV_Train_Test.STD", append=T, split=F)

for (tmp.depth in seq(15,20,5)) {					#n=2
#~ for (tmp.depth in seq(5,5,1)) {
	print (paste("tmp.depth",tmp.depth))
for (tmp.eta in seq(0.001,0.6,0.005)) { 			#n=120
#~ for (tmp.eta in seq(0.3,0.3,0.001)) {
	print (paste("tmp.eta",tmp.eta))
for (tmp.delta in seq(0,10,0.2)) { 					#n=51
#~ for (tmp.delta in seq(10,10,0.1)) {
	print (paste("tmp.delta",tmp.delta))
for (tmp.cols in seq(0.1,1,0.1)) { 					#n=10
#~ for (tmp.cols in seq(0.3,0.3,0.1)) {
	print (paste("tmp.cols",tmp.cols))
for (tmp.fold in seq(20,20,10)) { 					#n=1
#~ for (tmp.fold in seq(3,3,20)) {
	print (paste("tmp.fold",tmp.fold))

###############################################################################
# parameters

nrounds=1000
#~ nrounds=10
cv.nfolds=tmp.fold #10
param <- list(
				max.depth=tmp.depth,		#5,
				eta=tmp.eta,				#0.6,
				max_delta_step=tmp.delta,	#1,
				colsample_bytree=tmp.cols,	#0.6,
				objective='multi:softprob',
				eval_metric="mlogloss",
				num_class =3,
				verbose=1,
				nthread = 120
				)

###############################################################################
#CV

    # train

	bstCVres <- xgb.cv(
				param,
				data = dtrain,
				nrounds,
				subsample=0.6,
				early.stop.round=5,
				nfold=cv.nfolds)

mloglossCV=min(bstCVres[,test.mlogloss.mean])
bstRoundCV=which.min(bstCVres[,test.mlogloss.mean])
###############################################################################
#train

	bst <- xgb.train(
				param,
				data = dtrain,
				bstRoundCV,
				watchlist=watchlist
				)
	gc()

###############################################################################
# predict
		predictions <- xgboost::predict(bst, as.matrix(otherPortion[,predictors]))
		predictions <- matrix(predictions, ncol = 3, byrow = TRUE)
		# err <- rmse(as.numeric(testSet[,outcomeName]), as.numeric(predictions))
		actual <- matrix(0, nrow(otherPortion), 3)
		for (z in 1:nrow(otherPortion)){
			actual[z,otherPortion[z,outcomeName]+1] <- 1
		}
		# print (act)
		# print (dim(predictions))
		err <- MultiLogLoss(actual,predictions)
		#print(param)
		#print(paste("External-mlogloss:",err))

###############################################################################
# logging

write(
	c(
		"param$max.depth: ",param$max.depth,
		"param$eta: ",param$eta,
		"param$max_delta_step: ",param$max_delta_step,
		"param$colsample_bytree: ",param$colsample_bytree,
		"nrounds: ",nrounds,
		"cv.nfolds: ",cv.nfolds,
		"mloglossCV: ",mloglossCV,
		"bstRoundCV: ",bstRoundCV,
		"External-mlogloss: ",err
		),ncolumns=100,sep="\t",file="CV_Train_Test.log",append=T)

###############################################################################

}#tmp.fold
}#tmp.cols
}#tmp.delta
}#tmp.eta
}#tmp.depth

sink()