library(ggplot2)

# Export as pdf with width = 7.5 inch, height = 6.5 inch:

ggplot(boxplot_experimental_data_dataframe, aes(x= kinetics, y=log.nM)) +
  scale_x_discrete(limits=c("IC50","Kd","Ki")) +
  geom_boxplot(outlier.shape = NA, varwidth = TRUE, lwd=1.4, aes(col=genotype)) +
  stat_boxplot(geom = "errorbar", width = 0.3, size=1.5, color="gray40") +
  geom_jitter(size=5, aes(col=genotype)) +
  theme_set(theme_classic())+
  theme(axis.title.x = element_text(size=30, color = "gray35"),
        axis.title.y = element_text(size=30, color = "gray35"),
        axis.line = element_blank(),
        title = element_text(size = 30, color = "gray35"),
        plot.title = element_text(face="bold", hjust = 0.5),
        axis.text = element_text(size=30, color = "black"),
        axis.ticks = element_line(size = 1.5, colour = "gray40"),
        axis.ticks.length = unit(.25, "cm"),
        panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(),
        element_line(size=1.2),
        legend.position = "top",
        legend.direction = "horizontal",
        legend.key.width=unit(0.6,"cm"),
        legend.key.height=unit(2,"cm"),
        legend.title = element_text(size = 30, color = "gray30"),
        legend.text = element_text(size = 30, colour = "black"),
        legend.title.align = 0.5,
        aspect.ratio=1,
        panel.border = element_rect(size = 2.5, color = "gray40", fill = NA)) +
  labs(x = "Experimental binding affinity",  y = bquote(log[10](nM))) +
  coord_cartesian(ylim = c(-1.3, 3.2))


require(ggplot2)
require(ggthemes)
require(GGally)

addTheme =
function(myPlot) {
    return(myPlot +
               theme_economist() # +
#                scale_color_solarized("blue") +
#                scale_fill_solarized("blue")
    )
}

summaryStatsLine =
function(baseHist, summaryStats, statsName) {
    summaryStats$x = summaryStats[,statsName]
    return (
        baseHist +
        geom_rect(data=summaryStats,
                  aes(xmin=x - xMax * 0.002,
                      xmax=x + xMax * 0.002,
                      ymin=0,
                      ymax=Inf,
                      fill=group)) +
        geom_rect(data=summaryStats,
                  aes(xmin=x,
                      xmax=x + xMax * 0.06,
                      ymin=labelPosY + 10 - 0.15,
                      ymax=labelPosY + 10 + 0.15,
                      fill=group)) +
        geom_text(data=summaryStats,
                  aes(x=x + xMax * 0.075,
                      y=labelPosY + 10 + 1,
                      label=label,
                      hjust=0,
                      vjust=1))
    )
}

getDensityPlot =
function(data,
         metric,
         idVarName,
         groupVarName,
         title="",
         xLab="",
         yLab="",
         groupLab="",
         groupNames=NULL) {
    variations = sort(unique(data[,groupVarName]))
    groups = list()
    baseNums = c()
    if (is.null(groupNames)) {
        groupNames = variations
    }
    for (index in 1:length(variations)) {
        var = variations[index]
        groupName = groupNames[index]
        groups[[groupName]] =
            filter_(data, paste(groupVarName, "== '", var, "'", sep="")) %>%
            select_(idVarName, metric) %>%
            arrange_(idVarName)
        groups[[groupName]]$metric = groups[[groupName]][,metric]
        groups[[groupName]]$group = groupName
        baseNums[groupName] = nrow(groups[[groupName]])
    }

    # Calculate summary stats from the entire data first
    stats = groups[[groupNames[1]]][0,]
    for (index in 1:length(variations)) {
        groupName = groupNames[index]
        stats = rbind(stats, groups[[groupName]])
    }

    medians =
        group_by(stats, group) %>%
        summarise(median=median(metric))
    means =
        group_by(stats, group) %>%
        summarise(mean=mean(metric))

    # Truncate
    inc = 10
    qRange = c(0, 0.85)
    xLims = c(0, ceiling(quantile(stats$metric, qRange[2]) / inc) * inc)

    for (index in 1:length(variations)) {
        groupName = groupNames[index]
        groups[[groupName]] =
            filter(groups[[groupName]], metric < xLims[2] + 0.5 * inc)
        groups[[groupName]]$scale = nrow(groups[[groupName]]) / baseNums[groupName]
    }

    stats = groups[[groupNames[1]]][0,]
    for (index in 1:length(variations)) {
        groupName = groupNames[index]
        stats = rbind(stats, groups[[groupName]])
    }

    stats$group =
        factor(stats$group, levels=groupNames)

    xInc = ifelse(xLims[2] <= inc, inc / 10,
                  inc^floor(log(xLims[2] - 1, inc)))
    interval = xInc * ceiling(xLims[2] / 10 / xInc)

    histDatas = list()
    densDatas = list()

    for (index in 1:length(variations)) {
        groupName = groupNames[index]
        histDatas[[groupName]] =
            hist(groups[[groupName]]$metric,
                 breaks=seq(0,
                            xLims[2] + inc,
                            interval),
                 plot=FALSE)

        densDatas[[groupName]] =
            as.data.frame(
                spline(histDatas[[groupName]]$breaks[1:length(histDatas[[groupName]]$counts)],
                       histDatas[[groupName]]$counts / baseNums[groupName],
                       n=1000))
        densDatas[[groupName]]$group = groupName
    }

    if (FALSE) {
        for (index in 1:length(variations)) {
            groupName = groupNames[index]
            if (index == 1) {
                densData =
                    data.frame(breaks=histDatas[[groupName]]$breaks,
                               density=histDatas[[groupName]]$count / baseNums[groupName])
            } else {
                curDensData =
                    data.frame(breaks=histDatas[[groupName]]$breaks,
                               density=histDatas[[groupName]]$count / baseNums[groupName])
                densData = rbind(densData, curDensData)
            }
        }
        densityPlot =
            ggplot(data=densData, aes(x=breaks, y=density * 100)) + geom_bar(position="identity")
    } else {

    densData = densDatas[[groupNames[1]]][0,]
    for (index in 1:length(variations)) {
        groupName = groupNames[index]
        densData =
            rbind(densData, densDatas[[groupName]])
    }

    densData$group =
        factor(densData$group, levels=groupNames)

    densityPlot =
        ggplot() +
        geom_area(data=densData,
                  aes(x=x, y=y * 100, fill=group),
                  alpha=0.5,
                  position="identity") +
        geom_line(data=densData,
                  aes(x=x, y=y * 100, group=group)) +
        labs(title=title,
             x=xLab,
             y=yLab,
             fill=groupLab) +
        scale_x_continuous(limits=c(0, xLims[2]),
                           breaks=seq(0, xLims[2], interval))
    yLims = c(min(densData$y) * 100, max(densData$y) * 100)
    }

    height = yLims[2]
    medians$label = paste("group=", medians$group, "\n",
                          "median=", medians$median, sep="")
    medians$labelPosY = height * (1.0 - 0.2 * seq(1, length(variations), 1))
    medians$xMax = xLims[2]  # Same value for both ends
    medians$yMax = yLims[2]  # Same value for both ends

    means$label = paste("group=", means$group, "\n",
                        "mean=", means$mean, sep="")
    means$labelPosY = height * (0.65 - 0.2 * seq(1, length(variations), 1))
    means$xMax = xLims[2]  # Same value for both ends
    means$yMax = yLims[2]  # Same value for both ends

    densityPlot = summaryStatsLine(densityPlot, medians, "median")
    densityPlot = summaryStatsLine(densityPlot, means, "mean")

    return (densityPlot)
}

densityGeom = function(mean, sd) {
    h <- hist(rnorm(10000, mean, sd), plot=FALSE)
    d <- as.data.frame(
        spline(x=h$breaks[1:length(h$counts)],
               y=h$counts / 10000,
               n=10000))
    return(d)
}

regressionEstimatePlot =
function(model,
         title,
         outcomeCaption,
         predNames,
         predCaptions=NULL,
         logit=FALSE,
         z=1.96 # 95% c.i. 1.28 for 80%
         ) {
    if (is.null(predCaptions)) {
        predCaptions = predNames
    }
    if (is.null(names(predCaptions))){
        names(predCaptions) = predNames
    }
    coeffs = summary(model)$coefficients
    coeffs = coeffs[predNames,]
    predNames = predNames[order(coeffs[,1], decreasing=FALSE)]
    predCaptions = predCaptions[order(coeffs[,1], decreasing=FALSE)]
    estimate = data.frame(estimate=c(), conf.low=c(), conf.high=c(), term=c())
    meanPred = mean(predict(model, type="response"))
    for (predName in predNames) {
        coeff = coeffs[predName, ]
        curEst = coeff[1]
        lower = coeff[1] - z * coeff[2]
        upper = coeff[1] + z * coeff[2]
        if (logit) {
            curEst = 100 * (gtools::inv.logit(gtools::logit(meanPred) + curEst) - meanPred)
            lower = 100 * (gtools::inv.logit(gtools::logit(meanPred) + lower) - meanPred)
            upper = 100 * (gtools::inv.logit(gtools::logit(meanPred) + upper) - meanPred)
        }
        estimate =
            rbind(estimate,
                  data.frame(estimate=curEst,
                             conf.low=lower, conf.high=upper,
                             term=predCaptions[predName]))
    }
    estimate$term <- factor(estimate$term, estimate$term)
    coeffPlot = ggcoef(estimate, exponentiate = FALSE)
    coeffPlot =
        coeffPlot +
            geom_text(data=estimate,
              aes(x=estimate + .02,
                  y=term,
                  label=signif(estimate, 2),
                  hjust=0,
                  vjust=1),
              nudge_y=0.2
              ) +
        scale_alpha_continuous(range=c(0.0, 1.0), trans="identity") +
        guides(alpha=FALSE) +
        labs(title=title,
             x=outcomeCaption,
             y="")
#     if (logit) {
#        coeffPlot = coeffPlot + scale_x_continuous(limits=c(-100, 100))
#    }
}


# https://shiny.rstudio.com/tutorial/written-tutorial/lesson1/

library(shiny)

#### global ####

# library(tidyverse)
library(dplyr)
library(ggplot2)
# library(plotly)
# library(rlang)
library(leaflet) # interactive map (need devtools version of leaflet)
# library(ggmap) # register google api
# library(geosphere) # distm
# library(proj4) # warning masked by rgdal
# library(KernSmooth) # for contouring
# library(sp) # spatial polygons
# library(quantreg) # quantile regression
# # library(ggthemes) # chart theme
# # library(dismo) # geocode
# # library(raster) # required by geocode. Warning - masks dplyr::select
# # library(XML) # needed by geocode
# library(googleway) # for geocoding
# library(cowplot)

# https://stackoverflow.com/questions/36175529/getting-over-query-limit-after-one-request-with-geocode
# https://developers.google.com/maps/documentation/geocoding/get-api-key
# https://lucidmanager.org/geocoding-with-ggmap/
googlekey <- readLines("google.api") # text file with the API key
# ggmap::register_google(key = googlekey)
# ggmap::ggmap_credentials()

# this is good place to put global data or utility functions
# you can change them (for every session) but you have to use the <<- operator

# read multiyear data and tidy up
data_all <- readRDS("joined_small.rds")

# add elevation factor
data_all <- data_all %>%
	mutate(elev_fact=factor(x=case_when(elev<=50 ~ "Low (0-50m)",
										elev<=200 ~ "Middle (50-200m)",
										TRUE ~ "High (200m+)"),
							levels=c("Low (0-50m)", "Middle (50-200m)", "High (200m+)")))

summary(data_all)

# create season and soil list
season_all <- as.list(sort(unique(as.character(data_all$season))))
names(season_all) <- season_all
soil_all <- as.list(sort(unique(data_all$soil)))
names(soil_all) <- soil_all
names(soil_all)[soil_all=="L"] <- "Allophanic"
names(soil_all)[soil_all=="A"] <- "Anthropic"
names(soil_all)[soil_all=="B"] <- "Brown"
names(soil_all)[soil_all=="Z"] <- "Podzol"
names(soil_all)[soil_all=="M"] <- "Pumice"
names(soil_all)[soil_all=="W"] <- "Raw"
names(soil_all)[soil_all=="G"] <- "Gley"
names(soil_all)[soil_all=="N"] <- "Granular"
names(soil_all)[soil_all=="E"] <- "Melanic"
names(soil_all)[soil_all=="R"] <- "Recent"
names(soil_all)[soil_all=="S"] <- "Semiarid"
names(soil_all)[soil_all=="U"] <- "Ultic"
names(soil_all)[soil_all=="O"] <- "Organic"
names(soil_all)[soil_all=="X"] <- "Oxidic"
names(soil_all)[soil_all=="P"] <- "Pallic"
elev_all <- levels(data_all$elev_fact)
names(elev_all) <- elev_all

# define nitrogen steps
nitrogen_range <- seq(0L, 250L, 50L)
nitrogen_here <- as.list(c("Don't Adjust", paste(nitrogen_range, "kgN/ha/y")))
nitrogen_default <- nitrogen_here[[4]]

# calculate nitrogen adjustment
#  could fail if there is insufficient data to do regression
# temp <- data_all %>%
#   group_by(season, elev_fact, soil) %>%
#   do(nitrogen_slope=lm(pasture_eaten ~ nitrogen_applied + 1, data=.)$coefficients["nitrogen_applied"],
#      nitrogen_count=length(.$nitrogen_applied)
#      )
# temp$nitrogen_slope <- unlist(temp$nitrogen_slope)
# ggplot(data=temp) +
#   geom_histogram(mapping=aes(nitrogen_slope*1000)) +
#   scale_x_continuous(limits=c(-30,50))
# temp$nitrogen_count <- unlist(temp$nitrogen_count)
# temp$nitrogen_slope <- median(temp$nitrogen_slope, na.rm=TRUE) # median about 0.010 anyway?
# temp$nitrogen_slope <- 0.010 # after all that, use standard value
data_all <- data_all %>%
	# left_join(temp, by=c("season", "elev_fact", "soil")) %>%
	mutate(
		nitrogen_slope = 0.010,
		pasture_eaten_raw = pasture_eaten,
		pasture_eaten_min = pasture_eaten + (min(nitrogen_range) - nitrogen_applied) * nitrogen_slope,
		pasture_eaten_max = pasture_eaten + (max(nitrogen_range) - nitrogen_applied) * nitrogen_slope
	)

# create data point map/contours for plotting on leaflet
# https://gis.stackexchange.com/questions/168886/r-how-to-build-heatmap-with-the-leaflet-package
data_pts <- unique(data_all[c("long", "lat")])
kde <- KernSmooth::bkde2D(data.matrix(data_pts), bandwidth=c(0.1, 0.1), gridsize=c(100,100))
CL <- contourLines(kde$x1 , kde$x2 , kde$fhat) # contour lines (list)
LEVS <- as.factor(sapply(CL, `[[`, "level")) # contour levels (vector)
NLEV <- length(levels(LEVS)) # number of levels
pgons <- lapply(1:length(CL), function(i) # convert to polygons (ID=i is actually the level)
	sp::Polygons(list(sp::Polygon(cbind(CL[[i]]$x, CL[[i]]$y))), ID=i))
spgons = sp::SpatialPolygons(pgons)
spgon_cols <- topo.colors(NLEV, NULL)[LEVS]

# convert spatialPolygons to data frame for use in ggplot
#spgonsdf <- broom::tidy(spgons, region=ID)

# calculate NZTM2000 coordinates for farm locations
proj4string <- "+proj=tmerc +lat_0=0.0 +lon_0=173.0 +k=0.9996 +x_0=1600000.0 +y_0=10000000.0 +datum=WGS84 +units=m"
nzgd <- data.matrix(data_all[,c("long", "lat")])
nztm <- proj4::project(xy=nzgd, proj=proj4string)
temp <- proj4::project(xy=nzgd, proj=proj4string, inverse=TRUE)
data_all$east <- nztm[,1]
data_all$north <- nztm[,2]

# define some constants
trim <- 0.0 # rqss fails near tails if insufficient data
probs <- seq(trim, 1-trim, 0.02) # probabilities for sampcdf
nprobs <- length(probs)
windows <- c(60,40,20)
nmin <- 4L # minimum number of farms in a window for analysis

# gets a list of default ggplot colours
gg_colour_hue <- function(n) {
	hues = seq(15, 375, length = n + 1)
	hcl(h = hues, l = 65, c = 100)[1:n]
}
window_cols <- gg_colour_hue(length(windows))

# default_loc must be somewhere with data!!!
# default_loc <- list(long=172.833333, lat=-41.5) # Nelson
default_loc <- list(long=175.619105, lat=-40.386396) # Massey
# default_loc <- list(long=174.865530, lat=-41.259256) # Wellington
# default_loc <- list(long=175.352116, lat=-37.781841) # DairyNZ
# default_loc <- list(long=167.893066, lat=-43.036775) # In the ocean!

min_long <- 160
max_long <- 180
min_lat <- -50
max_lat <- -30
# default_location <- "Click map or enter location here"
default_location <- ""

# normal list with same elements, useful for testing
my <- list(name="You Are Here",
		   long=default_loc$long,
		   lat=default_loc$lat,
		   distortion=1,
		   east=NA, north=NA,
		   adjust_here=nitrogen_here,
		   adjust_default=nitrogen_default,
		   adjust=nitrogen_default,
		   season_here=list(NA),
		   season=list(NA),
		   soil_here=list(NA),
		   soil=list(NA),
		   elev_here=list(NA),
		   elev=list(NA),
		   data=list(NA),
		   breaks=list(NA),
		   recalc=0L
)

css <- "
.selectize-input {
  font-family: Arial;
  font-size: 14px;
  line-height: 14px;
}
.selectize-dropdown {
  font-family: Arial;
  font-size: 14px;
  line-height: 14px;
}
/* fix cursor */
.leaflet-container {
  cursor: auto !important;
}
/* font doesnt work */
/* https://stackoverflow.com/questions/29274501/r-markdown-changing-font-size-and-font-type-in-html-output/29298407 */
body{
  font-family: Arial;
  font-size: 16pt;
}
/* headers */
h1,h2,h3,h4,h5,h6{
  font-size: 24pt;
}"

#### ui ####
ui <- fluidPage(

	tags$style(type='text/css', css),

	sidebarLayout(

		sidebarPanel(
			tags$style(".well {background-color:#FFFFFF;border-color:#FFFFFF;}"), # worked!
			cat(file=stderr(), paste("render sidebar"), "\n"),
			width=5, # 12ths of the panel
			uiOutput("season_selector"),
			uiOutput("elev_selector"),
			uiOutput("soil_selector"),
			uiOutput("nitrogen_checkbox")
		), # end sidebarPanel

		mainPanel(
			cat(file=stderr(), paste("render main panel"), "\n"),
			width=7, # 12ths of the panel
			leaflet::leafletOutput("map", width="100%", height=480), # can manipulate size here
			absolutePanel(top=10, left=70, textInput("search_bar", "" , default_location, "75%")) # search bar
		), # end mainPanel

		position="right"

	), # end sidebarLayout

	fluidRow(

		plotOutput("stacked_histogram")

	) # end fluidRow

) # end ui

#### server ####
server <- function(input, output) {

	# collect info about the current location and selections
	# these variables are available in the reactive context
	# "my" is a list of reactive objects
	my <- reactiveValues(name="You Are Here",
						 long=default_loc$long,
						 lat=default_loc$lat,
						 distortion=1,
						 east=NA, north=NA,
						 adjust_here=nitrogen_here,
						 adjust_default=nitrogen_default,
						 adjust=nitrogen_default,
						 season_here=list(NA),
						 season_default=list(NA),
						 season=list(NA),
						 soil_here=list(NA),
						 soil_default=list(NA),
						 soil=list(NA),
						 elev_here=list(NA),
						 elev_default=list(NA),
						 elev=list(NA),
						 data=list(NA),
						 breaks=list(NA),
						 recalc=0L
	)

	# set leaflet info
	v <- reactiveValues(zoom=5, minzoom=5, maxzoom=15, long=NA, lat=NA)

	# initialise map centre
	isolate({
		cat(file=stderr(), paste("initialise location"), "\n")
		v$long <- my$long
		v$lat <- my$lat
	})

	#### define ui elements ####

	# titlePanel("Where are You?")

	output$season_selector <- renderUI({
		cat(file=stderr(), paste("render season selector"), "\n")
		selectInput("season", p("Production season?"), my$season_here, selected=my$season_default)
	})

	output$elev_selector <- renderUI({
		cat(file=stderr(), paste("render elev selector"), "\n")
		selectInput("elev", p("Altitude over sea level?"), my$elev_here, selected=my$elev_default,
					selectize=FALSE, multiple=TRUE)
	})

	output$soil_selector <- renderUI({
		cat(file=stderr(), paste("render soil selector"), "\n")
		selectInput("soil", p("Soil orders?"), my$soil_here, selected=my$soil_default,
					selectize=FALSE, multiple=TRUE)
	})

	output$nitrogen_checkbox <- renderUI({
		cat(file=stderr(), paste("render adjust checkbox"), "\n")
		selectInput("adjust", p("Nitrogen fertiliser applied?"), my$adjust_here, selected=my$adjust_default)
	})

	#### make initial map ####

	# https://stackoverflow.com/questions/34348737/r-leaflet-how-to-click-on-map-and-add-a-circle
	output$map <- leaflet::renderLeaflet({
		cat(file=stderr(), paste("render leaflet"), "\n")

		isolate({ # prevent redraw if arguments change

			leaflet(spgons, options=leafletOptions(minZoom=v$minzoom, maxZoom=v$maxzoom)) %>%
				setView(v$long, v$lat, zoom=v$zoom)  %>%
				addTiles() %>% # default map
				addPolygons(data=spgons, color=spgon_cols, weight=0, options=pathOptions(clickable=FALSE)) %>%
				addMarkers(my$long, my$lat, "layer1", options=pathOptions(clickable=FALSE)) %>%
				addCircles(my$long, my$lat, layerId=as.character(windows), radius=windows*1000,
						   color=window_cols, weight=4, fill=NA, options=pathOptions(clickable=FALSE))

		})

	}) # end renderLeaflet

	#### react to mouse clicks ####

	# see also https://rstudio.github.io/leaflet/shiny.html
	observeEvent(input$map_click, {

		cat(file=stderr(), "\n")
		cat(file=stderr(), paste("observed map_click"), "\n")

		click <- input$map_click
		my$long <- click$lng
		my$lat <- click$lat
		my$season <- list(NA)
		my$elev <- list(NA)
		my$soil <- list(NA)

		# update map
		leafletProxy("map", deferUntilFlush=FALSE) %>%
			addMarkers(my$long, my$lat, "layer1", options=pathOptions(clickable=FALSE)) %>%
			addCircles(my$long, my$lat, layerId=as.character(windows), radius=windows*1000,
					   color=window_cols, weight=4, fill=NA, options=pathOptions(clickable=FALSE))

	}) # end observe mouse click

	#### react to search bar ####

	# https://www.r-bloggers.com/4-tricks-for-working-with-r-leaflet-and-shiny/
	observeEvent(input$search_bar, {

		cat(file=stderr(), "\n")
		cat(file=stderr(), paste("observed search bar =", input$search_bar), "\n")
		req(input$search_bar, nchar(input$search_bar)>=4)
		req(googlekey>"")

		# target_pos <- dismo::geocode(paste(input$search_bar, "New Zealand"),
		#                              extent=raster::extent(min_long, max_long, min_lat, max_lat),
		#                              oneRecord=TRUE)
		target_pos <- googleway::google_geocode(paste(input$search_bar, "New Zealand"),
												bounds=list(c(min_lat,min_long),c(max_lat,max_long)),
												key=googlekey)$results$geometry$location %>%
			rename(lon=lng)
		cat(file=stderr(), paste(input$search_bar, "=", target_pos$lon, target_pos$lat), "\n")
		req(target_pos$lon, target_pos$lat)
		req(target_pos$lon!="NA", target_pos$lat!="NA")
		req(target_pos$lon>=min_long, target_pos$lon<=max_long)
		req(target_pos$lat>=min_lat, target_pos$lat<=max_lat)

		my$long <- target_pos$lon
		my$lat <- target_pos$lat
		my$season <- list(NA)
		my$elev <- list(NA)
		my$soil <- list(NA)

		# update map
		leafletProxy("map", deferUntilFlush=FALSE) %>%
			setView(my$long, my$lat, zoom=input$map_zoom)  %>%
			addMarkers(my$long, my$lat, "layer1", options=pathOptions(clickable=FALSE)) %>%
			addCircles(my$long, my$lat, layerId=as.character(windows), radius=windows*1000,
					   color=window_cols, weight=4, fill=NA, options=pathOptions(clickable=FALSE))

	}) # end observe search bar

	#### react to change of location ####

	observeEvent(c(my$long, my$lat), {

		cat(file=stderr(), "\n")
		cat(file=stderr(), paste("observed location =", my$long, my$lat), "\n")

		# calculate aspect ratio near my farm (not used)
		# nzgd <- data.matrix(tibble(long=c(my$long, my$long, my$long-0.5, my$long+0.5),
		#                            lat=c(my$lat-0.5, my$lat+0.5, my$lat, my$lat)))
		# nztm <- proj4::project(xy=nzgd, proj=proj4string)
		# my$distortion <- (max(nztm[,2])-min(nztm[,2]))/(max(nztm[,1])-min(nztm[,1]))

		# location for map centre
		nzgd <- data.matrix(c(my$long, my$lat))
		nztm <- proj4::project(xy=nzgd, proj=proj4string)
		my$east <- nztm[,1]
		my$north <- nztm[,2]

		# calculate distance
		# this is slow
		# we need to use rowwise()  because distm is not vectorised, I think, although rowwise() is deprecated
		# ungroup() removes the effect of rowwise()
		# http://www.expressivecode.org/2014/12/17/mutating-using-functions-in-dplyr/
		# data <- data_all %>%
		#   rowwise() %>% # slow
		#   mutate(dist=geosphere::distHaversine(c(my$long, my$lat), c(long, lat))/1000) %>%
		#   ungroup()
		data <- data_all %>%
		  group_by(long, lat) %>%
		  mutate(dist=geosphere::distHaversine(c(my$long, my$lat), c(long[1], lat[1]))/1000) %>%
		  ungroup()

		# filter data
		temp <- data %>%
			filter(dist < max(windows)) # km

		# insufficient data?
		if (nrow(temp)>=nmin){
			data <- temp
		} else {
			data <- data[1:max(2,nmin-1),] # grab a few rows (they won't be shown)
		}

		# calculate width of histogram for region
		my$breaks <- seq(  floor(min(data$pasture_eaten_raw, data$pasture_eaten_min, data$pasture_eaten_max)),
						   ceiling(max(data$pasture_eaten_raw, data$pasture_eaten_min, data$pasture_eaten_max)),
						   1)

		# store data for region
		my$data <- data

		# what season are available here
		i <- sort(unique(as.character(data$season)))
		my$season_here <- season_all[match(i, season_all)]
		n <- unlist(purrr::map(my$season_here, function(u) sum(u==data$season)))
		names(my$season_here) <- paste(names(my$season_here), " (", n, " Farms)", sep="")
		cat(file=stderr(), paste("my$season_here =", length(my$season_here)), "\n")
		cat(file=stderr(), paste(names(my$season_here)), "\n")

		# reset selections
		my$season_default <- tail(my$season_here, 1)
		my$season <- my$season_default
		my$elev <- list(NA)
		my$soil <- list(NA)
		# don't change my$adjust

	}) # end reaction to location changing

	#### react to change of season ####

	observeEvent(input$season, {
		cat(file=stderr(), "\n")
		cat(file=stderr(), paste("observed input$season =", input$season), "\n")
		req(input$season, input$season!="NA")
		if (my$season != input$season) {
			my$season <- input$season
			my$elev <- list(NA)
			my$soil <- list(NA)
			# don't change my$adjust
		}
	})

	observeEvent(my$season, {

		cat(file=stderr(), "\n")
		cat(file=stderr(), paste("observed my$season =", my$season), "\n")
		req(my$season, my$season!="NA")

		# make elev list
		data <- my$data %>%
			filter(season == my$season)

		# insufficient data?
		if (nrow(data)<nmin){
			data <- my$data[1:max(2,nmin-1),]
		}

		# data <- data_all[1:10,] # subset for testing
		i <- unique(data$elev_fact)
		my$elev_here <- elev_all[which(elev_all %in% i)] # retains sorting
		n <- unlist(purrr::map(my$elev_here, function(u) sum(u==data$elev_fact)))
		names(my$elev_here) <- paste(my$elev_here, " (", n, " Farms)", sep="")
		cat(file=stderr(), paste("my$elev_here =", length(my$elev_here)), "\n")
		cat(file=stderr(), paste(names(my$elev_here)), "\n")

		# reset selections
		my$elev_default <- my$elev_here
		my$elev <- my$elev_default
		my$soil <- list(NA)
		# don't change my$adjust

	}) # end reaction to season changing

	#### react to change of elevation ####

	observeEvent(input$elev,  {
		cat(file=stderr(), "\n")
		cat(file=stderr(), paste("observed input$elev ="), paste(input$elev), "\n")
		req(input$elev, input$elev!="NA")
		if (any(my$elev != input$elev, na.rm=TRUE)) {
			my$elev <-  input$elev
			my$soil <- list(NA)
			# don't change my$adjust
		}
	})

	observeEvent(my$elev,  {

		cat(file=stderr(), "\n")
		cat(file=stderr(), paste("observed my$elev ="), paste(my$elev), "\n")
		req(my$elev, my$elev!="NA")

		# make soil list
		data <- my$data %>%
			filter(season == my$season) %>%
			filter(elev_fact %in% my$elev)

		# insufficient data?
		if (nrow(data)<nmin){
			data <- my$data[1:max(2,nmin-1),]
		}

		i <- sort(unique(data$soil))
		my$soil_here <- soil_all[match(i, soil_all)]
		n <- unlist(purrr::map(my$soil_here, function(u) sum(u==data$soil)))
		names(my$soil_here) <- paste(names(my$soil_here), " (", n, " Farms)", sep="")
		cat(file=stderr(), paste("my$soil_here =", length(my$soil_here)), "\n")
		cat(file=stderr(), paste(names(my$soil_here)), "\n")

		# reset selections
		my$soil_default <- my$soil_here
		my$soil <- my$soil_default
		# don't change my$adjust

	})

	#### react to change of soil ####

	observeEvent(input$soil, {
		cat(file=stderr(), "\n")
		cat(file=stderr(), paste("observed input$soil ="), paste(input$soil), "\n")
		req(input$soil, input$soil!="NA")
		if (any(my$soil != input$soil, na.rm=TRUE)) {
			my$soil <- input$soil
			# don't change my$adjust
		}
	})

	observeEvent(my$soil, {

		cat(file=stderr(), "\n")
		cat(file=stderr(), paste("observed my$soil = "), paste(my$soil), "\n")
		req(my$soil, my$soil!="NA")

		# trigger recalc
		my$recalc <- my$recalc + 1L

	}) # end reaction to soil changing

	#### react to change of adjust ####

	observeEvent(input$adjust, {
		cat(file=stderr(), "\n")
		cat(file=stderr(), paste("observed input$adjust =", input$adjust), "\n")
		req(my$adjust, input$adjust)
		if (my$adjust != input$adjust) {
			my$adjust <- input$adjust
		}
	})

	observeEvent(my$adjust, {

		cat(file=stderr(), "\n")
		cat(file=stderr(), paste("observed my$adjust =", my$adjust), "\n")
		req(my$adjust)

		# trigger recalc
		my$recalc <- my$recalc + 1L

	})

	#### react to change of inputs ####

	calc <- eventReactive(my$recalc,  {

		cat(file=stderr(), "\n")
		cat(file=stderr(), paste("analyse for location =", my$long, my$lat), "\n")
		cat(file=stderr(), paste("analyse for season =", my$season), "\n")
		cat(file=stderr(), paste("analyse for soil ="), paste(my$soil), "\n")
		cat(file=stderr(), paste("analyse for elev ="), paste(my$elev), "\n")
		cat(file=stderr(), paste("analyse for adjust ="), my$adjust, "\n")
		req(my$season!="NA", my$soil!="NA", my$elev!="NA", my$adjust!="NA")
		req(my$long, my$lat, my$season, my$soil, my$elev, my$adjust)

		dont_adjust <- nitrogen_here[[1]]
		nitrogen_level <- as.numeric(stringr::word(my$adjust,1))
		data <-  my$data %>%
			filter(season == my$season) %>%
			filter(soil %in% my$soil) %>%
			filter(elev_fact %in% my$elev) %>%
			mutate(pasture_eaten =
				   	case_when(
				   		my$adjust==dont_adjust ~ pasture_eaten_raw,
				   		TRUE ~ pasture_eaten_raw + (nitrogen_level - nitrogen_applied) * nitrogen_slope
				   	)
			)

		if (my$adjust==dont_adjust){
			my$name <- paste("Your Location (", season_all[my$season[[1]]], ")", sep="")
		} else {
			my$name <- paste("Your Location (", season_all[my$season[[1]]], ")",
							 # " (Nitrogen response = ", sprintf("%.1f", data$nitrogen_slope[1]*1000), ")",
							 sep="")
		}

		cat(file=stderr(), paste("nrow(data) = ", nrow(data)), "\n")

		# circle function
		circle_fun <- function(centre=c(0,0), r=1, npoints=100){
			tt <- seq(0, 2*pi, length.out=npoints)
			xx <- centre[1] + r * cos(tt)
			yy <- centre[2] + r * sin(tt)
			return(tibble(x=xx, y=yy))
		}

		# prepare empty data frames for loop
		farms <- tibble(x=numeric(), y=numeric(), east=numeric(), north=numeric(), long=numeric(), lat=numeric(),
						pasture=numeric(), dist=numeric(), window=numeric(), radius=factor())
		sampcdf <- tibble(probs=numeric(), quants=numeric(), radius=factor())
		samppdf <- tibble(pasture=numeric(), window=numeric(), radius=factor(),
						  q=numeric(), qr=numeric(), qrlower=numeric(), qrupper=numeric())
		circles <- tibble(east=numeric(), north=numeric(), radius=factor())

		# loop through decreasing window sizes
		for (window in windows) {

			# select data within window
			data_window <- data %>% filter(dist < window)
			n <- nrow(data_window)
			code <- paste(window," km\n(", format(n, width=1), " Farms)", sep="")
			cat(file=stderr(), paste("window = ", window, " km"), "\n")

			# calculate circle
			circle <- circle_fun(centre=c(my$east, my$north), r=window*1000, npoints=100)
			nztm <- data.matrix(circle[,c("x", "y")])
			nzgd <- proj4::project(xy=nztm, proj=proj4string, inverse=TRUE)
			circle$long <- nzgd[,1]
			circle$lat <- nzgd[,2]

			# save selected farms for plot
			if (n >= 1) {
				farms <- rbind(farms, tibble(east=data_window$east, north=data_window$north,
											 long=data_window$long, lat=data_window$lat,
											 pasture=data_window$pasture_eaten,
											 dist=data_window$dist, window=window, radius=as.factor(code)))
			}

			circles <- rbind(circles, tibble(long=circle$long, lat=circle$lat, radius=as.factor(code)))

			# save sample quantiles if enough data to be sensible
			if (n >= nmin) {

				# calculate quantile
				qr1 <- quantreg::rq(formula=pasture_eaten ~ 1, tau=0.9, data=data_window) # linear quantile regression
				se_method <- "boot" # how condience intervals are calculated, some methods more robust
				yqr1<- predict(qr1, tibble(east=my$east, north=my$north), interval="confidence", level=0.95, se=se_method)
				q90 <- quantile(data_window$pasture_eaten, 0.9, type=1) # also calc simple q90

				cat(file=stderr(), paste("yqr1 =", yqr1), "\n")
				# cat(file=stderr(), paste("q90 =", q90), "\n") # should be the same

				quants <- quantile(data_window$pasture_eaten, probs=probs, type=8) # see documentation for type=?
				sampcdf <- rbind(sampcdf, tibble(probs=probs, quants=quants, radius=as.factor(code)))
				samppdf <- rbind(samppdf, tibble(pasture=data_window$pasture_eaten, window=window,
												 radius=as.factor(code),
												 q=q90, qr=yqr1[1], qrlower=yqr1[2], qrupper=yqr1[3]))

			} # if n >= nmin

			# add a blank line (causes warnings but prevents errors)
			samppdf <- rbind(samppdf, tibble(pasture=NA, window=window,
											 radius=as.factor(code),
											 q=NA, qr=NA, qrlower=NA, qrupper=NA))

		} # next window size

		# biggest circle
		circle <- circle_fun(centre=c(my$east, my$north), r=max(windows)*1000, npoints=100)
		nztm <- data.matrix(circle[,c("x", "y")])
		nzgd <- proj4::project(xy=nztm, proj=proj4string, inverse=TRUE)
		circle$long <- nzgd[,1]
		circle$lat <- nzgd[,2]

		# return results as function for testing
		#calc <- function() list(data=data, circles=circles, circle=circle, farms=farms, sampcdf=sampcdf, samppdf=samppdf)

		# return results in a list
		return(list(data=data, circles=circles, circle=circle, farms=farms,
					sampcdf=sampcdf, samppdf=samppdf))

	}) # end reaction to elev chaning, calculation of calc <- list(results)

	#### create histograms ####

	output$stacked_histogram <- renderPlot({

		samppdf <- calc()$samppdf # get data for histogram when calc() changes # makes a slow copy！
	  # temp <- length(calc()) # react to calc()

		isolate({

			cat(file=stderr(), paste("render stacked histograms"), "\n")

			title_string <- paste("Pasture and Crop Eaten Near", my$name)

			# create empty plot
			stacked_histogram <- ggplot() +
				labs(title=title_string, y="Number of Farms\n",
					 x="Pasture and Crop Eaten, tonnes DM per ha", colour="Radius (km)") +
				# theme_cowplot() +
				#theme_stata(base_size=16, scheme="s2color") +
				# ggthemes::theme_economist_white(base_size=12, horizontal=FALSE) +
				theme(axis.text.x=element_text(size=16, colour="grey35"),
					  axis.text.y=element_text(size=16, colour="grey35"),
					  strip.text=element_text(size=16, colour="grey35"),
					  plot.title=element_text(size=18, hjust=0.5, colour="grey35"),
					  axis.title=element_text(size=16, colour="grey35"),
					  axis.title.x=element_text(size=18, colour="grey35"),
					  panel.background=element_rect(fill="white")
				) +
				#scale_y_continuous(breaks=c()) + # remove y-scale when too many facets
				cowplot::panel_border(colour="grey35") +
				theme(legend.position="none")

			# add histograms to empty plot
			if (nrow(tidyr::drop_na(samppdf))>0) {

				breaks <- my$breaks

				# cat(file=stderr(), paste("xlim =", min(breaks), max(breaks)), "\n")

				stacked_histogram <- stacked_histogram +
					geom_rect(data=samppdf, mapping=aes(xmin=qrlower, xmax=qrupper, ymin=0, ymax=Inf), fill="lightcyan") +
					geom_histogram(data=samppdf, mapping=aes(x=pasture, colour=radius), fill=NA, size=1.1, binwidth=1) +
					geom_vline(data=samppdf, mapping=aes(xintercept=qr), size=1.5, colour="lightcyan4", alpha=0.2) +
					geom_vline(data=samppdf, mapping=aes(xintercept=q), size=1.5, colour="blue4") +
					geom_text(data=samppdf, mapping=aes(x=q, y=4, label=sprintf("%.1f t", q)),
							  colour="blue4", size=6, hjust=0, nudge_x=0.2) +
					facet_grid(radius ~ ., as.table=FALSE) + # as.table=FALSE reverses the order
					theme(strip.background=element_blank(), strip.text.y=element_text(angle=0)) +
					scale_x_continuous(breaks=breaks) +
					# scale_y_continuous(breaks=pretty_breaks(n=4)) +
					scale_y_continuous(breaks=NULL) +
					coord_cartesian(xlim=c(min(breaks),max(breaks)))

			} # end add histograms to empty plot

		}) # end isolate

		stacked_histogram
		# plotly::ggplotly(stacked_histogram)
		# plotly::partial_bundle(plotly::toWebGL(plotly::ggplotly(stacked_histogram)))

	}) # end renderPlot

}

# profvis::profvis(shiny::runApp("pasture_shiny19.r"))

# this is how you run it
shinyApp(ui = ui, server = server)


library(gganimate)
library(gapminder)
library(gifski)

ggplot(gapminder, aes(gdpPercap, lifeExp, size = pop, colour = country)) +
  geom_point(alpha = 0.7, show.legend = FALSE) +
  scale_colour_manual(values = country_colors) +
  scale_size(range = c(2, 12)) +
  scale_x_log10() +
  facet_wrap(~continent) +
  # What follows is specific for the gganimate package
  labs(title = 'Year: {frame_time}', x = 'GDP per capita', y = 'life expectancy') +
  transition_time(year) +
  ease_aes('linear')

anim_save("GDP.gif", animation = last_animation(), path = "C:/Users/Stefan/OneDrive - MUNI/Github/R-for-students-of-literature")

RMarkdown/Package of the week - gganimate/gganimate.r


args=commandArgs(trailingOnly=TRUE)
#==============================================
rescale_w<-function(w){
            w[which(w[]==-1)]=-0.01
            w[which(w[]==-2)]=-0.02
            w[which(w[]==-3)]=-0.03
	    w[which(w[]==-4)]=-0.04
            return(w)
}
#==============================================
#$branch_id $file-e_max_llh  $f-masked-un  $file-masked-un+e_short  $file-split-of-values  $file-w_max_llh  $file-w_percent

e_ids=read.table(args[1])
e_max_llh=read.table(args[2])
w_max_llh=read.table(args[6])
w_percent=read.table(args[7])

w_out_un=read.table(args[3])
w_out_un_e=read.table(args[4])
#w_out_un_e=rescale_w(w_out_un_e)

split=read.table(args[5])
tree_id=args[8]
#==============================================
ncol_w=ncol(w_max_llh)

plot_out=args[4]

#print(e_ids)
#print(w_out_un_e)

##PLOTS ==============================================================================================
for(i in 1:nrow(e_ids)){

	pdf(paste(paste(plot_out,"hist-selection-w",e_ids[i,1],e_ids[i,2],sep="-"),".pdf",sep=""),w=6,h=8)
		par(mfrow=c(2,1))
	# plot_1
		#my_breaks=c(seq(-5,10,1),seq(10,1010,100))
		#hist(w_out_un_e[,e_ids[i,1]],breaks=seq(-5,1000,1),main=paste(tree_id," | Distribution of dN/dS for branch | ",e_ids[i,1]," | ",e_ids[i,2],sep=""),xlab="dN/dS")
		#hist(w_out_un_e[which(w_out_un_e[,e_ids[i,1]]<=10),e_ids[i,1]],col="royalblue",breaks=seq(-5,10,1),main=paste(tree_id," | Distribution of dN/dS for branch | ",e_ids[i,1]," | ",e_ids[i,2],sep=""),xlab="dN/dS")
		#abline(v=c(1),col="firebrick")
		plot(w_max_llh[,e_ids[i,1]],w_percent[,e_ids[i,1]],main=paste(tree_id," | dN/dS vs. change in % for branch | ",e_ids[i,1]," | ",e_ids[i,2],sep=""),xlab="dN/dS",ylab="changes in % among 5 runs",col="yellowgreen")
		abline(h=c(10))

		c=which(w_out_un_e[,e_ids[i,1]]==-4)
		points(w_max_llh[c,e_ids[i,1]],w_percent[c,e_ids[i,1]],col="black")
		c=which(w_out_un_e[,e_ids[i,1]]==-3)
                points(w_max_llh[c,e_ids[i,1]],w_percent[c,e_ids[i,1]],col="darkmagenta")
		c=which(w_out_un_e[,e_ids[i,1]]==-1)
                points(w_max_llh[c,e_ids[i,1]],w_percent[c,e_ids[i,1]],col="firebrick")
		c=which(w_out_un_e[,e_ids[i,1]]==-2)
                points(w_max_llh[c,e_ids[i,1]],w_percent[c,e_ids[i,1]],col="royalblue")

		y=which(w_out_un_e[,e_ids[i,1]]<=10 & w_out_un_e[,e_ids[i,1]]>=0)
		hist(w_out_un_e[y,e_ids[i,1]],col="royalblue",breaks=seq(0,10,0.1),main=paste(tree_id," | Distribution of dN/dS for branch | ",e_ids[i,1]," | ",e_ids[i,2],sep=""),xlab="dN/dS")
		abline(v=c(1))
		#hist(w_out_un_e[,e_ids[i,1]],breaks=seq(-5,1000,1),main=paste(tree_id," | Distribution of dN/dS for branch | ",e_ids[i,1]," | ",e_ids[i,2],sep=""),xlab="dN/dS")

		#hist(w_out_un_e[,e_ids[i,1]],breaks=c(seq(-5,10,1),seq(10,1010,100)),main=paste(tree_id," | Distribution of dN/dS for branch | ",e_ids[i,1]," | ",e_ids[i,2],sep=""),xlab="dN/dS")
	# plot_2
		 #hist(w_percent[,e_ids[i,1]],breaks=seq(0,100,1),main=paste(tree_id," | Stability of dN/dS | ",e_ids[i,1]," | ",e_ids[i,2],sep=""),xlab="change of dN/dS in %")
	# plot_3
		#plot(e_max_llh[,e_ids[i,1]],w_percent[,e_ids[i,1]],main=paste(tree_id," | Edge length vs. change (in %) of dN/dS | ",e_ids[i,1]," | ",e_ids[i,2],sep=""))
	dev.off()
}

pdf(paste(paste(plot_out,"Reliability-per-branch",sep="-"),".pdf",sep=""),w=12,h=10)
par(mfrow=c(4,5))
my_col=c("yellowgreen","firebrick","royalblue","darkmagenta","black")
for(i in 1:nrow(e_ids)){
	w_un=length(w_out_un_e[which(w_out_un_e[,e_ids[i,1]]==-1),e_ids[i,1]])
	e_short=length(w_out_un_e[which(w_out_un_e[,e_ids[i,1]]==-2),e_ids[i,1]])
	w_0=length(w_out_un_e[which(w_out_un_e[,e_ids[i,1]]==-3),e_ids[i,1]])
	w_999=length(w_out_un_e[which(w_out_un_e[,e_ids[i,1]]==-4),e_ids[i,1]])
	w_good=nrow(w_out_un_e)-w_un-e_short-w_0-w_999
	barplot(c(w_good,w_un,e_short,w_0,w_999),col=my_col,main=paste(tree_id,e_ids[i,1],e_ids[i,2],sep="|"))
}
dev.off()

#h=c()
#for(i in 1:ncol_w){
#	h=c(h,w_percent[,i])
#}

#pdf()

#plot()

#dev.off()


## Function to get personal secondary table

secondary_ordered <- function(second_tabl, char){
  ### By using the previously generated table we can use this functiont to select
  ### a character and pull their best secondaries, and how the tier list changes
  ### compared to the optimal secondary list

  ## Pull main character, order on decreasing, remove main character
  temp_tab <- second_tabl[,char, drop = FALSE]
  temp_tab <- temp_tab[order(temp_tab,decreasing = T),, drop = FALSE]
  temp_tab <- temp_tab[!is.na(temp_tab),,drop = FALSE]
  ## Get tier list, but remove character again
  tier_filt <- rownames(second_tabl)[!(rownames(second_tabl) %in% char)]
  ## Combine numeric with teir list, and make sorted secondary list a column
  temp_tab <- cbind(temp_tab, tier_filt)
  temp_tab <- rownames_to_column(temp_tab, "Secondary Rank")
  colnames(temp_tab)[2:3] <- c("Secondary Score", "Current Tier List")
  ## Move around columns
  temp_tab <- select(temp_tab, `Secondary Score`, `Secondary Rank`, `Current Tier List`)
  ## Get the secondary rank change when compared to tier list
  `Tier Rank Change` <- match(temp_tab[,2], temp_tab[,3])- seq(nrow(temp_tab))
  ## Bind data together
  temp_tab <- cbind(temp_tab, `Tier Rank Change`) #%>%
  #mutate(`Tier Rank Change` = ifelse(`Current Tier List` == char, NA, `Tier Rank Change`))
  ## Return final output
  return(temp_tab)
}


wbgt <- function(t, rh, wind) {
    .Call('biometeoR_wbgt', PACKAGE = 'biometeoR', t, rh, wind)
}


pdf_file<-"pdf/timeseries_weekly_2x1.pdf"
cairo_pdf(bg="grey98", pdf_file,width=9,height=6)

source("scripts/inc_datadesign_dbconnect.r")
par(omi=c(0.5,0.25,0.25,0.5),mai=c(0.25,0.75,0.75,0.25),mfcol=c(2,1),
	cex=0.7,mgp=c(4,1,0),family="Lato Light",las=1)

# Import data

sql<-"select left(week,10) week, losing_weight, chicken_soup from google_trends"
myData<-dbGetQuery(con,sql)
myData$x<-as.Date(myData$week)
attach(myData)

# Create chart

plot(x,losing_weight,type="l",col="darkblue",ylab="Normalized Search Activity",cex.axis=1.2)
mtext("'losing weight'",3,line=1,adj=0,cex=1,col="darkblue",family="Lato Black")

plot(x,chicken_soup,type="l",col="darkred",ylab="Normalized Search Activity",cex.axis=1.2)
mtext("'chicken soup'",3,line=1,adj=0,cex=1,col="darkred",family="Lato Black")

# Titling

mtext("Google Trends: Number of search queries 2004-2012",3,line=-2,adj=0,cex=1.5,family="Lato Black",outer=T)
mtext("Weekly basis. Source: www.google.com/trends",1,line=1,adj=1.0,cex=0.85,font=3,outer=T)
dev.off()


suppressMessages(library(float))
suppressMessages(library(curand))
suppressMessages(library(dimrgame))

.pbd_env$SPMD.CT$print.quiet = TRUE
comm.cat("----------- crossprod -----------\n")

m = 2000000
n = 250

if (comm.rank() == 0){
  t_gen = comm.timer(x <- matrix(curand::rnorm(m*n), m, n))
  cat("data gen (dbl): ", t_gen[3], "\n")
} else {
  x = NULL
}

dx = expand(x)
ds = dx
ds@Data = fl(DATA(ds))

t_cpu = comm.timer(crossprod(dx))
comm.cat("kazaam (dbl):   ", t_cpu[3], "\n")
t_cpu = comm.timer(crossprod(ds))
comm.cat("kazaam (flt):   ", t_cpu[3], "\n")

t_gpu = comm.timer(crossprod_game(dx))
comm.cat("dimrgame (dbl): ", t_gpu[3], "\n")
t_gpu = comm.timer(crossprod_game(ds))
comm.cat("dimrgame (flt): ", t_gpu[3], "\n")

finalize()


# load required libraries
pacman::p_load(raster, shiny, RColorBrewer, malariaAtlas, shinydashboard, rgdal, googledrive)
##
# load in shapefile
admin0shapefile <- shapefile('data/countries/admin2013_0.shp')

# download admin 0 raster
# https://drive.google.com/open?id=1xY9meFKuR4UqJvc_LwayI11zupvbj5ZQ
temp <- tempfile()
dl <- drive_download(as_id("1xY9meFKuR4UqJvc_LwayI11zupvbj5ZQ"), path = temp, overwrite = TRUE)
admin0raster <- raster(dl$local_path)

# grab a list of available rasters from the MAP API
raster_meta <- as.data.frame(listRaster())

# subset to remove rows where title = "Relative Abundance Africa"
raster_meta <- raster_meta[!raster_meta$title == "Relative Abundance Africa", ]

# turn returned variable as a list to feed into sourcing function
raster_name_list <- as.list(raster_meta$title)

# feed list into getRaster function
raster_list <- lapply(raster_name_list, getRaster)

# stack the surfaces
# error with surfaces due to differing extents
# loop through and get a vector of raster extents
# extents <- t(sapply(raster_list, function (x) as.vector(extent(x))))
#
# get unique extents across all rasters
# u_extents <- unique(extents)

# loop through surfaces and generate info for each country; can't stack as there's 43 unique extents

for(i in 1:length(raster_list)){

  # grab the raster for that iteration
  r_i <- raster_list[[i]]

  # mask it by the extent of the admin 0 raster
  r_i <- crop(r_i, admin0raster)

  # check number of columns match (cell size is equal)
  logic_cell <- r_i@ncols == admin0raster@ncols

  # if the number of cells isn't equal, resample
  if(logic_cell == FALSE){

    message(paste0("Resampling raster ", i, " to align with master grid"))

    r_i <- resample(r_i, admin0raster, method = "bilinear")

  }

  # generate the mean pixel value for all pixels within a country
  poly_mean <- zonal(r_i, admin0raster, fun = 'mean')

  # create a dataframe with the zonal output
  poly_mean <- as.data.frame(poly_mean)

  names(poly_mean) <- c("country_id_raster",
                        names(raster_list[[i]]))

  # convert to a binary surface indicating values for a country
  poly_mean[[2]] <- ifelse(is.na(poly_mean[[2]]), 0, 1)

  # combine results across each raster
  if(i == 1){

    combined <- poly_mean

  } else {

    combined <- merge(combined, poly_mean, by = "country_id_raster")

  }

}

# add back ISO code
iso3 <- as.data.frame(admin0shapefile[, c(1:2, 5)])

names(combined)[1] <- "GAUL_CODE"
combined <- merge(combined, iso3, by = "GAUL_CODE")
# combined$COUNTRY_ID.x <- NULL
# drop countries which are XXX
combined_trim <- combined[!combined$COUNTRY_ID.y == "XXX", ]

# write out combined dataset
write.csv(combined,
          'D:/Dropbox/PhD/collaboration projects/Wellcome Trust data re-use/SHINY-map-prize/data/combined_lookup.csv',
          row.names = FALSE)


library( "rmacrolite" )

# # Setup MACRO directory (if needed)
# rmacroliteSetModelVar( "C:/swash/macro" )

#   Path to an example par-file
par_file_path <- system.file( "par-files",
    "chat_winCer_GW-X_900gHa_d182.par",
    package = "rmacrolite" )

#   Import the example par-file
par_file <- rmacroliteImportParFile(
    file = par_file_path )

#   Fetch the current parametrization
rmacroliteSorption( x = par_file )
    # $`layer`
      # layer_no oc_pc   kf kfoc   nf
    # 1        1  1.39 1.39  100 0.95
    # 2        2  0.93 0.93  100 0.95
    # 3        3  0.70 0.70  100 0.95
    # 4        4  0.30 0.30  100 0.95
    # 5        5  0.30 0.30  100 0.95
    # 6        6  0.27 0.27  100 0.95

    # $site
    # koc
    # 100

#   Modify the parameter
par_file2 <- par_file
rmacroliteSorption( x = par_file2 ) <- c( "kfoc" = 200,
    "nf" = 0.90 )

#   Check the result
ads <- rmacroliteSorption( x = par_file2 )
ads
    # $`layer`
      # layer_no oc_pc   kf kfoc  nf
    # 1        1  1.39 2.78  200 0.9
    # 2        2  0.93 1.86  200 0.9
    # 3        3  0.70 1.40  200 0.9
    # 4        4  0.30 0.60  200 0.9
    # 5        5  0.30 0.60  200 0.9
    # 6        6  0.27 0.54  200 0.9

    # $site
    # koc
    # 200

#   Internal control
if( !all( ads[[ "layer" ]][, "kfoc" ] == 200 ) ){
    stop( "Test of rmacroliteSorption() failed (kfoc, 1)" ) }

if( ads[[ "site" ]][ "koc" ] != 200  ){
    stop( "Test of rmacroliteSorption() failed (kfoc, 2)" ) }

if( !all( ads[[ "layer" ]][, "nf" ] == 0.9 ) ){
    stop( "Test of rmacroliteSorption() failed (nf)" ) }

#   Clean-up
rm( par_file_path, par_file, par_file2, ads  )


# Use the AzureML CRAN package to deploy the tree-based model as a scalable web service.
setwd("/home/remoteuser/Code/MRS")
source("SetComputeContext.r")

# Load our rxDTree Decision Tree model

load("dTreeModelSubset.RData") # loads dTreeModel

# Convert to open source R model

rpartModel <- as.rpart( dTreeModel )

# Define a scoring function to be published as a web service

scoringFn <- function(newdata){
  library(rpart)
  predict(rpartModel, newdata=newdata)
}

trainDS <- RxXdfData( file.path(dataDir, "finalDataTrainSubset") )

exampleDF <- base::subset(head(trainDS), select = -ArrDel15)

testDS <- RxXdfData( file.path(dataDir, "finalDataTestSubset") )

dataToBeScored <- base::subset(head(testDS), select = -ArrDel15)

# Test the scoring function locally

scoringFn(exampleDF)

################################################
# Publish the scoring function as a web service
################################################

library(AzureML)

workspace <- workspace(config = "azureml-settings.json")

endpoint <- publishWebService(workspace, scoringFn,
                              name="Delay Prediction Service",
                              inputSchema = exampleDF)

################################################
# Score new data via the web service
################################################

scores <- consume(endpoint, dataToBeScored)

head(scores)


library(poppr)
library(reshape)
library(ggplot2)
sims <- getfile()
sim <- read.table(sims$files, header = TRUE, sep = " ")
sim$Generation <- as.numeric(vapply(strsplit(as.character(sim$File), "_"), function(x) strsplit(x[10], "\\.")[[1]][1], "butt"))
sim$Sex.Rate <- round(sim$Sex.Rate, 5)
sim$Sex.Rate <- factor(sim$Sex.Rate)
sim$Samp.Size <- factor(paste("n =",sim$Samp.Size))
sim$Samp.Size <- factor(sim$Samp.Size, levels(sim$Samp.Size)[c(1,3:4,2)])
simnarm <- sim[-which(is.na(sim$rbarD)), ]
themes <-  theme_bw() +
  theme(legend.position = "bottom",
        axis.text.x = element_text(angle = 45, hjust=1, vjust=1, family = "Helvetica"),
        axis.text.y = element_text(family = "Helvetica"),
        axis.title = element_text(size = rel(2)),
        panel.grid.major.x = element_blank(),
        strip.background = element_rect(color = "black", fill = "white"),
        strip.text = element_text(face = "bold", family = "Helvetica"),
        plot.title = element_text(face = "bold", size = rel(2), vjust = 1,
                                  family = "Helvetica"))

theme2 <- theme_bw() +
  theme(legend.position = c(1, 0),
        legend.justification = c(1, 0),
        legend.direction = "horizontal",
        legend.title = element_text(size = rel(1), family = "Helvetica"),
        axis.text.x = element_text(angle = 45, hjust=1, vjust=1, family = "Helvetica"),
        axis.text.y = element_text(family = "Helvetica"),
        axis.title.y = element_text(angle = 0, face = "bold", size = rel(2)),
        axis.title.x = element_text(angle = 0, face = "bold", size = rel(2)),
        panel.grid.major.x = element_blank(),
        plot.title = element_text(face = "bold", size = rel(2), vjust = 1,
                                  family = "Helvetica")
  )

theme3 <- theme_bw() +
  theme(#legend.position = c(0, 1),
    #legend.justification = c(0, 1),
    legend.position = "top",
    legend.title = element_text(size = rel(1), family = "Helvetica"),
    axis.text.x = element_text(angle = 45, hjust=1, vjust=1, family = "Helvetica"),
    axis.text.y = element_text(family = "Helvetica"),
    axis.title.y = element_text(angle = 90, face = "bold", size = rel(2)),
    axis.title.x = element_text(angle = 0, face = "bold", size = rel(2)),
    panel.grid.major.x = element_blank(),
    plot.title = element_text(face = "bold", size = rel(2), vjust = 1,
                              family = "Helvetica")
  )
Ialab <- labs(list(y = expression(I[A]), x = "Generation (x1000)", fill = "Sample Size"))
rbarDlab <- labs(list(y = expression(bar(r)[d]), x = "Generation (x1000)", fill = "Sample Size"))
Ia.bar <- ggplot(simnarm) + geom_boxplot(aes(x = factor(Generation), y = Ia, fill = Samp.Size), outlier.shape = 20, outlier.size = 1, notch = TRUE) + facet_wrap(~Sex.Rate) + theme_bw() + scale_fill_grey(start = 0.4, end = 1)
rbarD.bar <- ggplot(simnarm) + geom_boxplot(aes(x = factor(Generation), y = rbarD, fill = Samp.Size), outlier.shape = 20, outlier.size = 1, notch = TRUE) + facet_wrap(~Sex.Rate) + theme_bw() + scale_fill_grey(start = 0.4, end = 1)
All.Iagrey <- Ia.bar + Ialab + theme3
All.rbarDgrey <- rbarD.bar + rbarDlab + theme3

#Ia.point <- ggplot(simnarm, aes(x = factor(Generation), y = Ia, color = Samp.Size, group = Samp.Size, alpha = 0.0001)) + geom_point(position = "jitter") + stat_smooth(alpha = 1) + facet_wrap(~Sex.Rate, scales = "free_y") + theme_bw()
#rbarD.point <- ggplot(simnarm, aes(x = factor(Generation), y = rbarD, color = Samp.Size, group = Samp.Size, alpha = 0.5)) + geom_point(position = "jitter") + stat_smooth() + facet_grid(Sex.Rate ~ Samp.Size) + theme_bw()

# Missing stats:

Samp.Sex <- table(sim[is.na(sim$rbarD) & sim$Generation == 10, c("Sex.Rate", "Samp.Size")])
MLG.Sex <- table(sim[is.na(sim$rbarD) & sim$Generation == 10, c("Sex.Rate", "MLG")])
Samp.Sex.df <- data.frame(t(Samp.Sex[1:2, ]))
names(Samp.Sex.df) <- c(0, 1e-04)
Samp.Sex.df$Samp.Size <- factor(rownames(Samp.Sex.df), levels = rownames(Samp.Sex.df))
Missing1grey <- ggplot(melt(Samp.Sex.df)) +
  geom_bar(aes(x = Samp.Size, y = value, group = variable, fill = variable), stat = "identity", position = "dodge") +
  labs(list(x = "Sample Size", y = "Number of Missing Values", fill = "Sex Rate")) +
  theme3 + scale_fill_grey(start = 0, end = 0.5)

MLG.Sex.df <- data.frame(t(MLG.Sex[1:2, ]))
names(MLG.Sex.df) <- c(0, 1e-04)
MLG.Sex.df$MLG <- factor(rownames(MLG.Sex.df), levels = rownames(MLG.Sex.df))
Missing2grey <- ggplot(melt(MLG.Sex.df)) +
  geom_bar(aes(x = MLG, y = value, group = variable, fill = variable), stat = "identity", position = "dodge") +
  labs(list(x = "Number of MLGs", y = "Number of Missing Values", fill = "Sex Rate")) +
  theme3 + scale_fill_grey(start = 0, end = 0.5)

MLG.Sex.Samp <- table(sim[is.na(sim$rbarD) & sim$Generation == 10, c("MLG", "Samp.Size", "Sex.Rate")])[, , 1:2]
MLG.Sex.Samp.df <- melt(MLG.Sex.Samp)
MLG.Sex.Samp.df$Samp.Size <- factor(MLG.Sex.Samp.df$Samp.Size, levels = unique(MLG.Sex.Samp.df$Samp.Size))
MLG.Sex.Samp.df$Sex.Rate <- paste("Sex Rate:", MLG.Sex.Samp.df$Sex.Rate)

missing_lab <- labs(list(x = "Number of MLGs", y = "Number of missing values", fill = "Sample Size"))
Missing3grey <- ggplot(MLG.Sex.Samp.df) + geom_bar(aes(x = factor(MLG), y = value, fill = Samp.Size), stat = "identity", position = "stack") + theme_bw() + facet_wrap(~Sex.Rate, ncol = 1) + theme3 + theme(legend.position = c(0.5, 0.5), legend.justification = c(0.5, 1), legend.direction = "horizontal", legend.title.align = 0.5) + scale_fill_grey(start = 0.2, end = 0.8) + missing_lab


library(randomForest)
library(caret)
library(doMC)
library(mmadsenr)
library(futile.logger)
library(dplyr)
library(ggthemes)

# Train and tune random forest classifiers for each of the three data sets coming out of the experiment
# "equifinality-4", for binary analysis.
#
# In this analysis, we keep all of the sample sizes and ta duration samples together, to see how accurate we
# can predict with all the data.  BUT, we treat duration as an unknown parameter, while sample size is visible
# to the analysis (and the archaeologis)

log_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "combined-tasampled-classification.log")
flog.appender(appender.file(log_file), name='cl')

clargs <- commandArgs(trailingOnly = TRUE)
if(length(clargs) == 0) {
  ta_sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "equifinality-3-4-tasampled-data.rda")
} else {
  ta_sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "equifinality-3-4-tasampled-data.rda", args = clargs)
}

load(ta_sampled_data_file)
flog.info("Loaded data file: %s", ta_sampled_data_file, name='cl')

flog.info("Beginning classification analysis of equifinality-4 data sets for combined tasampled with hidden duration", name='cl')

# set up parallel processing - use all the cores (unless it's a dev laptop under OS X) - from mmadsenr
num_cores <- get_parallel_cores_given_os(dev=TRUE)
flog.info("Number of cores used in analysis: %s", num_cores, name='cl')
registerDoMC(cores = num_cores)

########### Training and Tuning Variables ##############

#
# Common training and tuning parameters for ctmixtures analysis
#

gbm_grid <- expand.grid(.interaction.depth = (1:6)*2,
                        .n.trees = (2:10)*50,
                        .shrinkage = 0.05)

training_control <- trainControl(method="repeatedcv",
                                 number=10, repeats=5)

# make this repeatable - comment this out or change it to get a fresh analysis result
seed_value <- 58132133
set.seed(seed_value)
flog.info("RNG seed to replicate this analysis: %s", seed_value, name='cl')

# Set up sampling of train and test data sets
training_set_fraction <- 0.8
test_set_fraction <- 1.0 - training_set_fraction

# set up combined_results data frames
experiment_names <- c("All Sample Sizes and TA Durations")
combined_tassize_results <- data.frame()
combined_tassize_results_roc <- NULL
combined_tassize_results_model <- NULL
combined_tassize_results_cm <- NULL

###### Population Data ######

flog.info("Starting analysis of combined tasampled data", name='cl')

# first row of combined_results
i <- 1
exp_name <- experiment_names[i]

# We want to downsample the full 800K points down to 100K, so that we have the same balance of under/overfitting
# with this analysis as all the other analyses which use 100K points.  We do that using a stratified random
# sample by model class, to ensure good proportional representation for the classifier
sample_rows <- createDataPartition(eq4_ta_sampled_df$model_class_label, p = 1/8, list = FALSE)
eq4_downsampled_df <- eq4_ta_sampled_df[sample_rows,]

# prepare data
# create a label combining the biased models into one
# then, split into training and test sets, with balanced samples for each of the binary classes
eq4_downsampled_df$two_class_label <- factor(ifelse(eq4_downsampled_df$model_class_label == 'allneutral', 'neutral', 'biased'))

# remove fields from analysis that aren't predictors, and the detailed label with 4 classes
exclude_columns <- c("simulation_run_id", "model_class_label", "innovation_rate", "ta_duration")

#model <- train_randomforest(eq4_downsampled_df, training_set_fraction, fit_grid, fit_control, exclude_columns)
model <- train_gbm_classifier(eq4_downsampled_df, training_set_fraction, "two_class_label", gbm_grid, training_control, exclude_columns, verbose=FALSE)

combined_tassize_results_model[["combined_tassize"]] <- model$tunedmodel

# use the test data split by the train_randomforest function and calculate tuned model predictions
# and then get the confusion matrix and fitting metrics
predictions <- predict(model$tunedmodel, newdata=model$test_data)
cm <- confusionMatrix(predictions, model$test_data$two_class_label)
results <- get_parsed_binary_confusion_matrix_stats(cm)
results$experiments <- exp_name
results$elapsed <- model$elapsed
combined_tassize_results_cm[["combined_tassize"]] <- cm

# All other analyses record these
results$sample_size <- 0
results$ta_duration <- 0

# calculate a ROC curve
combined_tassize_roc <- calculate_roc_binary_classifier(model$tunedmodel, model$test_data, "two_class_label", "Combined Sample Sizes and Durations")
results$auc <- unlist(combined_tassize_roc$auc@y.values)
combined_tassize_results_roc[["combined_tassize"]] <- combined_tassize_roc

combined_tassize_results <- rbind(combined_tassize_results, results)

############## Complete Processing and Save combined_results ##########3

# save objects from the environment

if(length(clargs) == 0) {

  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                              filename = "classification-combined-tassize-combined_results-gbm.RData")
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                                      filename = "classification-combined-tassize-result-gbm-dfonly.RData")

} else {

  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                              filename = "classification-combined-tassize-combined_results-gbm.RData", args = clargs)
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                                      filename = "classification-combined-tassize-result-gbm-dfonly.RData", args = clargs)
}

flog.info("Saving combined_results of analysis to R environment snapshot: %s", image_file, name='cl')
save(combined_tassize_results, combined_tassize_results_model, combined_tassize_results_cm, combined_tassize_results_roc, file=image_file)

flog.info("Saving just data frame of results of analysis to R environment snapshot: %s", image_file_results, name='cl')
save(combined_tassize_results, file=image_file_results)

# End
flog.info("Analysis complete", name='cl')


#!/usr/bin/env Rscript
#5ma_NbClust.r
#
#Author: Abelardo Aguilar Camara
#
#Task performed:
#    This script reads the mash distance matrix of a family,
#    performs different clustering indices and returns a family
#    membership data frame with consensus clustering
#
#
#INPUT: mash_distmx of anytaxon from  ..results/Distance_Matrices
#
#OUTPUT: Membership vectors        in    ../results/NbClust_membership_vectors/
#        Point plot of distances   in    ../results/Clustering_graphics
#        Clusters PCA              in    ../results/Clustering_graphics
#
#################################################
#
#5ma_NbClust.r
#
#################################################
# Load needed packages
suppressPackageStartupMessages(library("NbClust"))
suppressPackageStartupMessages(library("factoextra"))
suppressPackageStartupMessages(library("ggplot2"))
suppressPackageStartupMessages(library("dplyr"))
suppressPackageStartupMessages(library("tidyr"))
suppressPackageStartupMessages(library("igraph"))
#################################################
# Reading input
setwd("../results/Distance_Matrices") # mashdistmx location
PosArgs <- as.character(commandArgs(trailingOnly = TRUE))
#family = "Circoviridae"
family = PosArgs[1]  #Reads positional arguments to define family (e.g. family = "Geminiviridae")
mincluster = as.numeric(PosArgs[2]) # defines minimum number of clusters
maxcluster = as.numeric(PosArgs[3]) # defines maximum number of clusters
file_suffix <- ("mash_distmx.csv") #Suffix to build input filename
distmx_filename <- paste(family,file_suffix, sep = "_") #Read filename
family_distmx <- as.matrix(read.csv(distmx_filename, header = TRUE, sep = ",", dec = ".")) #Transform to matrix
family_distmx<- as.data.frame(family_distmx)
rownames(family_distmx) <- family_distmx$X
family_distmx$X <- NULL
dist <- as.dist(family_distmx)
#################################################
#indices to estimate
indexes <- c("cindex",
             "silhouette",
             "mcclain",
             "dunn")
#################################################
#Estimating the best number of clusters
res <- c() # Vector to contain results
Best_num_clust <- c() #Vector to contain best number of cluster proposed by each index
#Loop over indices to compute
for (i in indexes){
  res <- NbClust(diss=dist, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "ward.D", index = i)
  Best_num_clust[i] <- res$Best.nc[1]
}
Bestnc <- as.data.frame(Best_num_clust) #to dataframe
nc <- names(sort(summary(as.factor(Bestnc$Best_num_clust)), decreasing = TRUE)[1]) #Saves the most observed number of clusters
ncsubset <- subset(Bestnc, Best_num_clust==nc) #Defines a subset of those indexes indicating matching nc
first_index <- rownames(ncsubset)[1] #Selects index to operate partitions
#################################################
partitions_list <- c("wardD", "wardD2", "single", "complete", "average", "mcquitty", "median", "centroid", "consensus")
#Computing partitions
#Can be changed to for loop but I prefer this way to easily find when a partition method aborts
Partition_wardD <- NbClust(diss=dist, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "ward.D", index = first_index)
Partition_wardD2 <- NbClust(diss=dist, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "ward.D2", index = first_index)
Partition_single <- NbClust(diss=dist, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "single", index = first_index)
Partition_complete <- NbClust(diss=dist, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "complete", index = first_index)
Partition_average <- NbClust(diss=dist, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "average", index = first_index)
Partition_mcquitty <- NbClust(diss=dist, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "mcquitty", index = first_index)
Partition_median <- NbClust(diss=dist, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "median", index = first_index)
Partition_centroid <- NbClust(diss=dist, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "centroid", index = first_index)
#Save partitions to data frame
taxids <- rownames(family_distmx)
Pertenencia.df <- data.frame(Partition_wardD$Best.partition,
                             Partition_wardD2$Best.partition,
                             Partition_single$Best.partition,
                             Partition_complete$Best.partition,
                             Partition_average$Best.partition,
                             Partition_mcquitty$Best.partition,
                             Partition_median$Best.partition,
                             Partition_centroid$Best.partition)
#################################################
#Define a function "moda" to recover the most popular clusters membership proposition for each genome
function.moda<-function(n)
{
  names(sort(summary(as.factor(n)), decreasing = TRUE)[1])
}
#################################################
#Use function.moda to estimate consensus membership vector
Pertenencia.df$Consenso <- apply(Pertenencia.df, 1, function.moda)
#################################################
#################################################
#Save outputs
#Membership vectors
setwd("..")
outdir <- ("mkdir -p NbClust_membership_vectors") #Make membership vectors outdir
system(outdir) #Make outdir
setwd("NbClust_membership_vectors")
outfile <- paste(family,"membership_vectors.csv", sep="_")
write.csv(Pertenencia.df, outfile, row.names = TRUE) #Write membership vectors file
#################################################
#Point plot of ordered distances (pplot)
numericdist <- as.data.frame(lapply(family_distmx,as.numeric))
ene <- nrow(numericdist) #number of genomes
SumDist <- (rowSums(numericdist)) #get sum of distances by genome
SumDist.df <- as.data.frame(SumDist) #transform to data frame
mean_Distance <- (SumDist.df$SumDist)/ene #get average sum of distances per genome
SumDist.df$MeanDif <- mean_Distance #save average sum to data frame
##Este es el bloque de codigo a corregir
colnames(Pertenencia.df) <- partitions_list
SumDist.df <- cbind(SumDist.df,Pertenencia.df)
OrderedDist.df <- SumDist.df[order(SumDist.df$MeanDif),] #sort sum of distances
IndexByDistSum <- seq(from = 1, to = ene)
OrderedDist.df$IndexByDistSum <- IndexByDistSum
outfile3 <- paste(family,"_distances_pplot.tiff", sep = "") #name pplot outfile
setwd("..")
outdir3 <- ("mkdir -p Clustering_graphics") #make clustering graphics outdir
system(outdir3)
legendtitle <- paste(family, "ordered distances by cluster")
setwd("Clustering_graphics")
#################################################
##Linear point plots group by group
outfile_pplot <- ""
legendtitle <- ""

for (i in 1:length(partitions_list)){
  outfile_pplot <- paste(family, "_mash_distpplot_", partitions_list[i],"_method.tiff", sep = "")
  legendtitle <- paste(family, paste("(", partitions_list[i], ")", sep = ""),"ordered distances by cluster")
  tiff(outfile_pplot, units="in", width=7, height=5, res=600)
  print(ggplot(data=OrderedDist.df, aes(IndexByDistSum, MeanDif)) +
    geom_point(aes(colour = as.factor(OrderedDist.df[[2+i]])), size = 2, alpha = 0.2) +
    theme(legend.position="top") +
    labs(color= legendtitle ))
  dev.off()
}

#################################################
#MDS
#Esta ya vimos que funciona
g <- graph.full(nrow(family_distmx))
V(g)$label <- rownames(family_distmx)
layout <- layout_with_mds(g, dist = as.matrix(family_distmx))
plot(g, layout = layout, vertex.size = 4)
# La grafica que se genera me gusta y creo que tiene potencial
# Este libro es para echarle un ojo https://sites.fas.harvard.edu/~airoldi/pub/books/BookDraft-CsardiNepuszAiroldi2016.pdf
# Ahi puedo ayudarme para explotar mejor el potencial de igraph
# Estos dias lo que puedo hacer es intentar embelecer este grafico un poco mas
# Luego automatizar los pasos hasta llegar al producto
#################################################
#Intentar embelecer el gráfico
net.bg <- graph.full(nrow(family_distmx))
V(net.bg)$size <- 3
V(net.bg)$frame.color <- "white"
V(net.bg)$color <- "orange"
V(net.bg)$label <- ""
E(net.bg)$arrow.mode <- 0
#layout randomly
plot(net.bg, layout=layout_randomly)
#layout in circle
l <- layout_in_circle(net.bg)
plot(net.bg, layout=l)
#layout in line
l <- cbind(1:vcount(net.bg), c(1, vcount(net.bg):2))
plot(net.bg, layout=l)
#3D sphere layout
l <- layout_randomly(net.bg)
plot(net.bg, layout=l)
#Force directed layout (Fruchterman-Reingold)
l <- layout_with_fr(net.bg)
x11()
plot(net.bg, layout=l)
#### CREO QUE FALTA UN METODO PARA DIBUJAR UN EDGE ENTRE DOS NODOS,
#### SOLO SI SU DISTANCIA ES MENOR A CIERTO VALOR
g <- graph.full(nrow(family_distmx))
V(g)$label <- rownames(family_distmx)
layout <- layout_with_mds(g, dist = as.matrix(family_distmx))
plot(g, layout = layout, vertex.size = 4)

### CREO QUE DEBO FILTRAR

myAdjacencyMatrix <- as.matrix(family_distmx)
class(myAdjacencyMatrix)
gra  <- graph.adjacency(myAdjacencyMatrix,weighted=TRUE)
df <- get.data.frame(gra)
head(df)

d <- as.matrix(family_distmx)

d_mas_uno <- as.dist(d+1)

#Me quedé buscando una forma de pasar de matriz de distancias a matriz de similitud
s <- ((1*d)-1)

#FROM DISTANCE TO SIMMILARITY MATRIX
length(family_distmx)

family_simmx <- family_distmx
for (i in 1:length(family_simmx)){
  ds <- as.numeric(family_simmx[[i]])
  #family_simmx[[i]] <- (ds * 200)
  family_simmx[[i]] <- ifelse(ds==0,1,((1/ds)-1))
}


if( ! require("bio3d")) {
  install.packages("bio3d", repos="http://cran.rstudio.com/")
}
library(bio3d)

distances <- function(pdb_file) {
  pdb <- read.pdb( pdb_file )
  coordinates <- pdb$atom[c("x","y","z")]
  return(dist(coordinates))
}

head(distances(system.file("examples/1hel.pdb", package="bio3d")))


# user options
nox<-2; noy<-3;
paper<-F   # if paper==T output on file, else screen
cleanup()

#SMS.option<-"-ind run_ms3.dat"
 SMS.option<-' '

first.year.in.mean<-2015    # years where output is independent of initial conditions and used as "equilibrium"
last.year.in.mean<-2015

do.simulation<-F     # do the simulations and create data files for plots
do.plots<-F            # do the plots
do.plots2<-T            # do the plots

 include.probability<-T
######### end user options #########
do.HCR.batch<-function() {

#Read refence points from file reference_points.in
ref<-Read.reference.points()
blim<-ref[,"Blim"]
bpa<-ref[,"Bpa"]
T1<-blim
T2<-bpa

#  files for output
ssb.out<-'HCR_SSB.dat'
yield.out<-'HCR_yield.dat'
F.out<-'HCR_F.dat'
prob.out<-'HCR_prob.dat'

if (do.simulation) {

  # read data and options into FLR objects
  control<-read.FLSMS.control()
  HCR<-read.FLSMS.predict.control(control=control,file='HCR_options.dat.gem')

  sp.name<-control@species.names

  percentiles<-c(0.025,0.05,0.10,0.25,0.50,0.75,0.95,0.975)

  # headers in output files
  cat(paste('codF cluF Species.n '),file=ssb.out)
  cat(paste("SSB",formatC(percentiles*1000,width=3,flag='0'),sep=''),file=ssb.out,append=T); cat('\n',file=ssb.out,append=T)
  cat(paste('codF cluF Species.n '),file=yield.out)
  cat(paste("y",formatC(percentiles*1000,width=3,flag='0'),sep=''),file=yield.out,append=T); cat('\n',file=yield.out,append=T)
  cat(paste('codF cluF Species.n '),file=F.out)
  cat(paste("F",formatC(percentiles*1000,width=3,flag='0'),sep=''),file=F.out,append=T); cat('\n',file=F.out,append=T)
  cat('codF cluF Species.n p.T1 p.T2 \n',file=prob.out)

  iter<-0

  HCR@no.MCMC.iterations<-20   #no of iterations
  HCR@last.prediction.year<-2016
  BaseF<-HCR@constant.F
  print (BaseF)
  codF<-seq(0.3,1.0,0.05)
  ClupoidF<-1

  for (CODF in (codF)) for (CLUF in (ClupoidF)) {
      iter<-iter+1

      HCR@constant.F[1]<-CODF

      #HCR@constant.F[1]<-BaseF[1]*CODF
      #HCR@constant.F[2]<-BaseF[2]*CLUF*0.5
      #HCR@constant.F[3]<-BaseF[3]*CLUF

      write.FLSMS.predict.control(HCR,SMS=control,file='HCR_options.dat')

      #run SMS
      shell(paste( file.path(root,"program","sms.exe"),"-mceval",SMS.option,sep=" "), invisible = TRUE)

      a<-Read.MCMC.SSB.rec.data()
      a<-subset(a,Year>=first.year.in.mean & Year<=last.year.in.mean ,drop=T)

      b<-tapply(a$SSB,list(a$Species.n), function(x) quantile(x,probs = percentiles))
      for (i in (1:length(b))) {
         cat(paste(CODF,' ',CLUF,' ',i,' '),file=ssb.out,append=TRUE)
         cat(b[[i]],file=ssb.out,append=TRUE)
         cat('\n',file=ssb.out,append=TRUE)
      }

      dummy<-by(a,list(a$Species.n),function(x) {
        q<-tapply(x$SSB,list(x$Year,x$Repetion,x$Iteration),sum)
        sp<-x[1,"Species.n"]
        q[q>T2[sp]]<-0
        q[q>0]<-1
        p.T2<-sum(q)/(dim(q)[1]*dim(q)[2]*dim(q)[3])

        q<-tapply(x$SSB,list(x$Year,x$Repetion,x$Iteration),sum)
        q[q>T1[sp]]<-0
        q[q>0]<-1
        p.T1<-sum(q)/(dim(q)[1]*dim(q)[2]*dim(q)[3])
        cat(paste(CODF,' ',CLUF,sp,p.T1,p.T2,'\n'),file=prob.out,append=TRUE)
      })

      a<-Read.MCMC.F.yield.data(dir=data.path)
      a<-subset(a,Year>=first.year.in.mean & Year<=last.year.in.mean ,drop=T)
      b<-tapply(a$Yield,list(a$Species.n), function(x) quantile(x,probs = percentiles))
      for (i in (1:length(b))) {
         cat(paste(CODF,' ',CLUF,' ',i,' '),file=yield.out,append=TRUE)
         cat(b[[i]],file=yield.out,append=TRUE)
         cat('\n',file=yield.out,append=TRUE)
      }

      b<-tapply(a$mean.F,list(a$Species.n), function(x) quantile(x,probs = percentiles))
      for (i in (1:length(b))) {
         cat(paste(CODF,' ',CLUF,' ',i,' '),file=F.out,append=TRUE)
         cat(b[[i]],file=F.out,append=TRUE)
         cat('\n',file=F.out,append=TRUE)
      }

  }
}   # end do.simulations

if (do.plots) {

  # read data and options into FLR objects
  control<-read.FLSMS.control()
  HCR<-read.FLSMS.predict.control(control=control,file='HCR_options.dat')

  sp.name<-control@species.names

  ssb<-read.table(ssb.out,header=TRUE)
  yield<-read.table(yield.out,header=TRUE)
  fi<-read.table(F.out,header=TRUE)

  a<-merge(ssb,yield)
  a<-merge(a,fi)
  b<-subset(a,select=c(Species.n,codF,cluF,SSB500,y500))

  make.plots<-function(variable='SSB') {
  i<<-0
  by(b,list(b$Species.n),function(x) {
    xx<-sort(unique(x$codF))
    y<-sort(unique(x$cluF))
    if (variable=="SSB") z<-tapply(x$SSB500/1000,list(x$codF,x$cluF),mean)
    if (variable=="Yield") z<-tapply(x$y500/1000,list(x$codF,x$cluF),mean)

    sp<-sp.name[x[1,"Species.n"]]
     if ((i %% (nox*noy))==0) {
       if (paper) dev<-"wmf" else dev<-"screen"
       newplot(dev,nox,noy,dir=data.path,filename=paste("Batch_",sep=''),Portrait=T);
       par(mar=c(4,5,3,2))
     }
    i<<-i+1
    contour(xx,y,z,xlab="Cod F",ylab="Clupeid F",nlevels = 10)
    title(main=paste(sp,variable))
  })
  }

  i<<-0
  make.plots(variable="SSB")
  #make.plots(variable="Yield")

  if (paper) cleanup()

} #end do.plots

if (do.plots2) {
 # user options
 nox<-1; noy<-1;
 if (paper) dev<-"wmf" else dev<-"screen"
 newplot(dev,nox,noy,dir=data.path,filename=paste("Batch2_",sep=''),Portrait=T);
  xlab.title<-'Cod F'

  # read data and options into FLR objects
  control<-read.FLSMS.control()
  HCR<-read.FLSMS.predict.control(control=control,file='HCR_options.dat')

  sp.name<-control@species.names

  ssb<-read.table(ssb.out,header=TRUE)
  yield<-read.table(yield.out,header=TRUE)
  prob<-read.table(prob.out,header=TRUE)
  fi<-read.table(F.out,header=TRUE)

  a<-merge(ssb,yield)
  a<-merge(a,prob)
  a<-merge(a,fi)

  by(a,list(a$Species.n), function(a){
    if (paper=="Y") dev<-"wmf" else dev<-"screen"
    sp<-a[1,"Species.n"]
    newplot(dev,nox,noy,dir=outdir,filename=paste("HCR_",sp,sep=''),Portrait=F);

    par(mar=c(5,4,4,5)+.1)
    s<-a$SSB500/1000
    y<-a$y500/1000
    x<-a$codF
    x.lab<-xlab.title

    plot(x,s,ylab='SSB & Yield (1000 t)',xlab=x.lab ,ylim=c(min(s,y,0),max(s,y)),lty=1,type='l',lwd=2,col=1,main=sp.name[sp])
    if (include.probability) {
      legend("topright",
         c('SSB','Yield', paste('p(SSB<',T1[sp],'t)'), paste('p(SSB<',T2[sp],'t)') ),
         pch="  12",lty=c(1,2,3,4),lwd=rep(2,4),col=c(1,2,3,4))
    } else {
      legend(min(x),0.85*max(s,y),
         c('SSB','Yield','F'),
         pch="   ",lty=c(1,2,5),lwd=rep(2,3))
    }
    lines(x,y,lty=2,lwd=2,col=2)

    par(new=T)
    plot(x,a$F500,axes=F,xlab=x.lab, ylab=' ',lty=5,lwd=2,,ylim=c(0,1),type='n')
    if (include.probability) {
      lines(x,a$p.T1,lty=3,lwd=2,type='b',pch="1",col=3)
      lines(x,a$p.T2,lty=4,lwd=2,type='b',pch="2",col=4)
      abline(h=0.05)
    }
    axis(side=4)

    #mtext(side=4,line=3.0,"Probability & F")
    mtext(side=4,line=3.0,"Probability")
    par(xaxs="r")

    if (paper=='Y') cleanup()
  })
} #end do.plots2

}
do.HCR.batch()


#研究f_eject射出次数和频率
#分为single单次射出，即单脉冲内射出的次数
#还有eject，总体射出频率

#设定工作目录
setwd("D:/data")
library(xlsx)

#读取数据
#q2 <- read.xlsx("f_eject.xls", sheetName = "single_q15", header = TRUE)
#q3 <- read.xlsx("f_eject.xls", sheetName = "single_q27", header = TRUE)
#q4 <- read.xlsx("f_eject.xls", sheetName = "single_q54", header = TRUE)
q5 <- read.xlsx("f_eject.xls", sheetName = "single_q180", header = TRUE)

#保存数据
#pdf("f_q180.pdf")

#画图
#设定空间位置
par(fig=c(0,1,0,1), new = F)

##################################画图--占空比k为0.2#######################
plot(q5$fv, q5$X0.2, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "Frequency in cycle (Hz)", main = "Eject frequency in Q = 180nl/min", cex.lab = 1.2, cex.main = 1.5, xlim = c(0, 3550), ylim = c(0, 110))

#model1 = loess(q5$X0.2 ~ q5$fv, span = 0.8 , degree = 2)
lines(q5$fv, q5$X0.2,  col="#458B74", pch=21, lwd=2.5, type="b", lty=2)

#model2 = loess(q5$X0.3 ~ q5$fv, span = 0.8, degree = 2)
lines(q5$fv, q5$X0.3, col="#FF00FF", pch=22, lwd=2.5, type="b", lty=2)

#model3 = loess(q5$X0.4 ~ q5$fv, span = 0.8, degree = 2)
lines(q5$fv, q5$X0.4, col="#EE0000", pch=23, lwd=2.5, type="b", lty=2)

#model4 = loess(q5$X0.5 ~ q5$fv, span = 0.8, degree =2)
lines(q5$fv, q5$X0.5, col="#27408B", pch=24, lwd=2.5, type="b", lty=2)

#区域划线

legend("topleft", c("k = 0.2", "k = 0.3", "k = 0.4", "k = 0.5"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.2, inset = .03, bty = "n")

###############画小图########
par(fig = c(0.22,0.98,0.2,0.98), new  = TRUE)

plot(q5$fv, q5$X0.2, xaxs = "i", col = 0, xlab = "0 ~ 250 Hz", ylab = "f_eject in cycle (Hz)", main = "", cex.lab = 1.2, cex.main = 1.5, xlim = c(0, 250), ylim = c(0, 110))

#model1 = loess(q5$X0.2 ~ q5$fv, span = 0.8 , degree = 2)
lines(q5$fv, q5$X0.2,  col="#458B74", lwd=2.5, type="l", lty=3)

#model2 = loess(q5$X0.3 ~ q5$fv, span = 0.8, degree = 2)
lines(q5$fv, q5$X0.3, col="#FF00FF", lwd=2.5, type="l", lty=3)

#model3 = loess(q5$X0.4 ~ q5$fv, span = 0.8, degree = 2)
lines(q5$fv, q5$X0.4, col="#EE0000", lwd=2.5, type="l", lty=3)

#model4 = loess(q5$X0.5 ~ q5$fv, span = 0.8, degree =2)
lines(q5$fv, q5$X0.5, col="#27408B", lwd=2.5, type="l", lty=3)

#legend("topright", c("1.5nl/min", "27nl/min", "54nl/min", "180nl/min"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.2, bty = "n", inset = .03)

#画小小图
par(fig = c(0.35,0.95,0.4,0.95), new  = TRUE)

plot(q5$fv, q5$X0.2, xaxs = "i", col = 0, xlab = "0 ~ 75 Hz", ylab = "f_eject in cycle (Hz)", main = "", cex.lab = 1.2, cex.main = 1.5, xlim = c(0,  75), ylim = c(0, 110))

#text(260, 0.85, "射出时间在[0.3ms, 0.8ms]内", font = 2, col = "blue", cex = 1.3)

#model1 = loess(q5$X0.2 ~ q5$fv, span = 1.6 , degree = 2)
lines(q5$fv, q5$X0.2, col="#458B74", lwd=2, type="l")

#model2 = loess(q5$X0.3 ~ q5$fv, span = 1.6, degree = 2)
lines(q5$fv,  q5$X0.3, col="#FF00FF", lwd=2, type="l")

#model3 = loess(q5$X0.4 ~ q5$fv, span = 1.6, degree = 2)
lines(q5$fv, q5$X0.4, col="#EE0000", lwd=2, type="l")

#model4 = loess(q5$X0.5 ~ q5$fv, span = 1.6, degree =2)
lines(q5$fv, q5$X0.5, col="#27408B", lwd=2, type="l")

abline(h=50, lty = 3, col = "red", lwd = 2)
abline(h=1, lty = 3, col = "red", lwd = 2)

#legend("topright", c("1.5nl/min", "27nl/min", "54nl/min", "180nl/min"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.2, bty = "n", inset = .03)

#dev.off()


#Rscript

###########################
##     Anonymization     ##
###########################

#####Packages : tangles

#Load arguments

args <- commandArgs(trailingOnly = TRUE)

if (length(args) == 0) {
    stop("This tool needs at least one argument")
}else{
    table <- args[1]
    hr <- args[2]
    latitude <- as.numeric(args[3])
    longitude <- as.numeric(args[4])
}

if (hr == "false") {
  hr <- FALSE
}else{
  hr <- TRUE
}

#####Import data
data <- read.table(table, sep = "\t", dec = ".", header = hr, fill = TRUE, encoding = "UTF-8")

randomized_data <- tangles::tangles(data = as.matrix(data[, c(latitude, longitude)]), depth = 3, rasterdata = FALSE, raster_object = FALSE, saveTangles = FALSE, path = NULL)

data[, c(latitude, longitude)] <- NULL

tab_anon <- data.frame(longitude = randomized_data[[1]]$X, latitude = randomized_data[[1]]$Y)

tab_anon <- cbind(data, tab_anon)

write.table(tab_anon, "anonym_data.tabular", row.names = FALSE, quote = FALSE, sep = "\t", dec = ".", fileEncoding = "UTF-8")


#!/usr/bin/env Rscript
options(warn=-1)

# CLI args
library("optparse")

# Set opts
opt.list = list(
make_option(c("-i", "--input"), type="character", default=NULL,
            help="input dataset file name", metavar="character"),
make_option(c("-o", "--output"), type="character", default="output",
            help="output file set base name [default = %default]", metavar="character"),
make_option(c("-a", "--algorithm"), type="character", default="bf",
            help="search algorithm to be used [fw | bf | spfa]", metavar="character"),
make_option(c("-b", "--benchmark"), type="logical", action="store_true", default=FALSE,
            help="benchmark all algorithms and show metrics (makes -a irrelevant)")
)

# Parse opts
opt.parser = OptionParser(option_list=opt.list)
opt = parse_args(opt.parser)

# Treat errors
if (is.null(opt$input)) {
    print_help(opt.parser)
    stop("Input dataset file must be specified\n", call.=F)
}

# Source scripts
source("fw-arbitrate.r")
source("bf-arbitrate.r")

# Read input data
input.edges = as.matrix(read.table(opt$input))
input.nodes = unique(matrix(input.edges[,1:2], ncol=1))

# Adapt edge weights
weights.new = -log(as.numeric(as.character(input.edges[,3])))
weights.new[which(weights.new==-Inf)] = 0 # cleaning -logs
input.edges.new = cbind(input.edges[,1:2], weights.new)

ret = NULL

# IF BENCHMARKING, measure all algorithms
if (opt$benchmark) {
    cat("\nRunning benchmark for all algorithms...\n")
    lines = c()
    nruns = 15

    # Message
    line = "Benchmarking Floyd-Warshall\n"
    lines = c(lines, line)
    cat("\n ", line)

    # Run FW
    times.fw = c()
    for (i in 1:nruns) {
        start = Sys.time()
        ret = fw.find(input.edges.new, input.edges, debug=F)
        time = Sys.time() - start

        # Record
        times.fw = c(times.fw, time)
        line = paste0("    Execution ", as.character(i), ": ", as.character(time), " seconds\n")
        lines = c(lines, line)
        cat(line)
    }

    ## Include the dummy node every possible
    ## negative cycle is made reachable from
    ## it (For the Bellman-Ford based algorithms)
    voids = cbind(rep("VOIDCURRENCY", NROW(input.nodes)),
                  input.nodes, rep(0, NROW(input.nodes)))
    input.edges = rbind(voids, as.matrix(input.edges))
    input.edges.new = rbind(voids, input.edges.new)

    # Message
    line = "Benchmarking Bellman-Ford\n"
    lines = c(lines, line)
    cat("\n ", line)

    # Run BF
    times.bf = c()
    for (i in 1:nruns) {
        start = Sys.time()
        ret = bf.find(input.edges.new, input.edges, debug=F)
        time = Sys.time() - start

        # Record
        times.bf = c(times.bf, time)
        line = paste0("    Execution ", as.character(i), ": ", as.character(time), " seconds\n")
        lines = c(lines, line)
        cat(line)
    }

    # Message
    line = "Benchmarking SPFA\n"
    lines = c(lines, line)
    cat("\n ", line)

    # Run SPFA
    times.spfa = c()
    for (i in 1:nruns) {
        start = Sys.time()
        ret = bf.spfa(input.edges.new, input.edges, debug=F)
        time = Sys.time() - start

        # Record
        times.spfa = c(times.spfa, time)
        line = paste0("    Execution ", as.character(i), ": ", as.character(time), " seconds\n")
        lines = c(lines, line)
        cat(line)
    }

    times.fw = as.numeric(times.fw)
    times.bf = as.numeric(times.bf)
    times.spfa = as.numeric(times.spfa)
    means = as.numeric(c(mean(times.fw), mean(times.bf), mean(times.spfa)))
    sdevs = as.numeric(c(sd(times.fw), sd(times.bf), sd(times.spfa)))

    # Prepare output
    out.summary = paste0(opt$output, ".summary")
    out.plot = paste0(opt$output, ".plot.png")

    # Output summary
    lines = c(lines, "\nAverage times and standard deviations:\n")
    timedata = as.matrix(cbind(means, sdevs))
    colnames(timedata) = c("Mean", "SD")
    rownames(timedata) = c("Floyd-Warshall", "Bellman-Ford", "SPFA")
    write(lines, out.summary)
    capture.output(print(timedata), file=out.summary, append=T)

    # Prepare plot
    png(out.plot)
    xaxis = 1:NROW(means)
    plot(xaxis, means, xlim=range(c(0, NROW(means) + 1)),
         ylim=range(c(means-sdevs, means+sdevs)), pch=20,
         xlab="Measures for FW, BF and SPFA respectively",
         ylab="Mean of 15 runs +/- SD in seconds",
         main="Algorithm performance measures")

    # Hachy arrows
    arrows(xaxis, means-sdevs, xaxis, means+sdevs, length=0.05, angle=90, code=3)
    text(x=xaxis, y=means, labels=c("Floyd-Warshall", "Bellman-Ford", "SPFA"), pos=4)
    dev.off()

    # OTHERWISE, run method specified via --algorithm
    cat("\n-> Execution summmary written to", out.summary, "\n")
    cat("-> Plot image written to", out.plot, "\n\n")
    browseURL(out.plot)
} else {

    if (opt$algorithm == "fw") {

        # Just run
        ret = fw.find(input.edges.new, input.edges)

    } else if (opt$algorithm == "bf") {

        ## Include the dummy node every possible
        ## negative cycle is made reachable from it
        voids = cbind(rep("VOIDCURRENCY", NROW(input.nodes)),
                      input.nodes, rep(0, NROW(input.nodes)))
        input.edges = rbind(voids, as.matrix(input.edges))
        input.edges.new = rbind(voids, input.edges.new)

        # Run
        ret = bf.find(input.edges.new, input.edges)

    } else if (opt$algorithm == "spfa") {

        ## Include the dummy node every possible
        ## negative cycle is made reachable from it
        voids = cbind(rep("VOIDCURRENCY", NROW(input.nodes)),
                      input.nodes, rep(0, NROW(input.nodes)))
        input.edges = rbind(voids, as.matrix(input.edges))
        input.edges.new = rbind(voids, input.edges.new)

        # Run
        ret = bf.spfa(input.edges.new, input.edges)

    } else {
        stop("No such algorithm implemented\n", call.=F)
    }

    # Ready output file names
    out.nodes = paste0(opt$output, ".nodes")
    out.cycle = paste0(opt$output, ".cycle")
    out.summary = paste0(opt$output, ".summary")

    # Write out everything
    cycle = cbind(ret$cycle[1:(NROW(ret$cycle)-1)], ret$cycle[2:NROW(ret$cycle)])
    write.table(ret$nodes, out.nodes, row.names=F, col.names=F, sep="\t", quote=F)
    write.table(cycle, out.cycle, row.names=F, col.names=F, sep="\t", quote=F)

    # This is ugly, sorry
    write(paste0("Starting from 1 unit of ", cycle[1,1], ", performing these transactions\n(or, in stock terms, SELLING or BIDDING these PAIRS) can\npossibly grant you back", ret$profit, " ", cycle[1,1], ":\n"), out.summary)
    write.table(cycle, out.summary, row.names=F, col.names=F, sep="/", quote=F, append=T)

    # Final messages
    cat("\n-> Graph nodes written to", out.nodes, "\n")
    cat("-> Negative cycle edges written to", out.cycle, "\n")
    cat("-> Execution summmary written to", out.summary, "\n\n")
}

# Reset warnings
options(warn=-1)


#' @title df_qc_spatial
#' @description This function identifies points that aren't in the northern
#' hemisphere (i.e. LAT between 0 and 90) and aren't in the western hemisphere
#' (i.e. LON between 0 and 180).  By default, it returns the "good" points, but
#' the "return.bad" flag allows it to return only the "bad" points.
#' @param df the dataframe to be cleaned
#' @param lat.field default is \code{LATITUDE}.  The field in the dataframe holding the latitudes
#' @param lon.field default is \code{LONGITUDE}.  The field in the dataframe holding the longitudes
#' @param return.bad the default is \code{FALSE}.  Normally, only the plottable points are returned.
#' If TRUE, only the rejected points are returned.
#' @param autoQC the default is \code{TRUE}.  This runs df_qc_spatial()
#' automatically, ensuring that all coordinates are in the Northern hemsisphere
#' (i.e. Latitude between 0 and 90N) and the western hemisphere (i.e. Longitude
#' between -180 and 0W)
#' @return data.frame contents depend of the return.bad parameter
#' @family general_use
#' @author  Mike McMahon, \email{Mike.McMahon@@dfo-mpo.gc.ca}
#' @export
df_qc_spatial <-function(df, lat.field = "LATITUDE", lon.field = "LONGITUDE", return.bad=FALSE, autoQC=T){
  pass = df[!is.na(df[lat.field]) & !is.na(df[lon.field]),]
  if (autoQC){
  pass = pass[pass[lat.field] > 0 & pass[lat.field] < 90,] #northern hemisphere only
  pass = pass[pass[lon.field] > -180 & pass[lon.field] < 0,] #western hemisphere only
  }
  if (return.bad){
    fail = rbind(df, pass)
    fail = fail[!duplicated(fail,fromLast = FALSE)&!duplicated(fail,fromLast = TRUE),]
    return(fail)
  }else{
    return(pass)
  }
}


# 3. faza: Vizualizacija podatkov

#Graf selitve po regijah
izseljeni <- selitve_po_regijah %>% group_by(regija_odselitve, leto) %>%

  summarize(izseljeni_sum = sum(stevilo_preseljencev))

graf_izseljencev <- ggplot(izseljeni, aes(leto, izseljeni_sum)) +
  geom_line(aes(group = regija_odselitve, colour = factor(regija_odselitve)))+
  theme(axis.text.x = element_text(angle = 90))+
  scale_color_discrete("Regija odselitve")+
  labs(title = "Graf notranjih selitev")+
  xlab("Leto")
  ylab("število izseljencev")

izseljeni <- selitve_po_regijah %>% group_by(regija_odselitve, leto) %>%

  summarize(izseljeni_sum = sum(stevilo_preseljencev))

leto2020 <- izseljeni[izseljeni$leto == "2020" , c(1,3)]

graf_iseljencev2020 <- ggplot(leto2020, aes(regija_odselitve, izseljeni_sum)) +
  geom_col()+
  theme(axis.text.x = element_text(angle = 90))+
  labs(title = "Graf notranjih selitev leta 2020")+
  xlab("Regija")+
  ylab("Število izseljencev")

priseljeni <- selitve_po_regijah %>% group_by(regija_priselitve, leto) %>%

  summarize(priseljeni_sum = sum(stevilo_preseljencev))

graf_priseljencev <- ggplot(priseljeni, aes(leto, priseljeni_sum)) +
  geom_line(aes(group=regija_priselitve, colour = factor(regija_priselitve)))+
  theme(axis.text.x = element_text(angle = 90))+
  scale_color_discrete("Regija priselitve")+
  labs(title = "Graf notranjih selitev")+
  xlab("Leto")+
  ylab("Število priseljencev")

#Graf po starostnih skupinah

starost <- selitve_po_starostnih_skupinah %>% group_by(starostna_skupina, leto) %>%

  summarize(starost_sum = sum(stevilo_selitev))

leto2000 <- starost[starost$leto == "2000", c(1:3)]

graf_starost2000 <- ggplot(leto2000, aes(starostna_skupina, starost_sum)) +
  geom_col(fill = "green") +
  theme(axis.text.x = element_text(angle = 90))+
  labs(title = "Selitve po starosti leta 2000")+
  xlab("Starostna skupina")+
  ylab("Število selitev")

leto2007 <- starost[starost$leto == "2007", c(1:3)]

graf_starost2007 <- ggplot(leto2007, aes(starostna_skupina, starost_sum)) +
  geom_col(fill = "red") +
  theme(axis.text.x = element_text(angle = 90))+
  labs(title = "Selitve po starosti leta 2007") +
  xlab("Starostna skupina")+
  ylab("Število selitev")

leto2008 <- starost[starost$leto == "2008", c(1:3)]

graf_starost2008 <- ggplot(leto2008, aes(starostna_skupina, starost_sum)) +
  geom_col(fill = "blue") +
  theme(axis.text.x = element_text(angle = 90))+
  labs(title = "Selitve po starosti leta 2008")+
  xlab("Starostna skupina")+
  ylab("Število selitev")

leto2020 <- starost[starost$leto == "2020", c(1:3)]

graf_starost2020 <- ggplot(leto2020, aes(starostna_skupina, starost_sum)) +
  geom_col(fill = "yellow") +
  theme(axis.text.x = element_text(angle = 90))+
  labs(title = "Selitve po starosti leta 2020")+
  xlab("Starostna skupina")+
  ylab("Število selitev")

graf_starosti <- grid.arrange(graf_starost2000, graf_starost2020,graf_starost2007, graf_starost2008, nrow = 2)

print(graf_starosti)

#Graf stanovanjskih razmer

razmere <- stanovanjske_razmere %>% group_by(regija, kakovost_stanovanja) %>%

  summarize(razmere_sum = sum(stevilo_stanovanj))

graf_stanovanjskih_razmer <- ggplot(razmere, aes(regija, razmere_sum)) +
  geom_line(aes(group = kakovost_stanovanja, colour = factor(kakovost_stanovanja)))+
  theme(axis.text.x = element_text(angle = 90))+
  scale_color_discrete("Kakovost stanovanja") +
  labs(title = "Kakovost stanovanja po regijah") +
  xlab("Regija")+
  ylab("Število stanovanj")

#Graf stanovanjskih stroškov

graf_stroski <- ggplot(stanovanjski_stroski, aes(x=leto,y=stevilo_gospodinjstev, fill=breme_stroskov))+
  geom_bar(stat="identity", position = "dodge") +
  scale_color_discrete("Breme stroškov")+
  labs(title = "Kakšno breme prebivalcem predstavljajo stanovanjski stroški po letih")+
  xlab("Leto")+
  ylab("Število gospodinjstev")

#Zemljevid

zemljevid <- uvozi.zemljevid("http://biogeo.ucdavis.edu/data/gadm2.8/shp/SVN_adm_shp.zip",
                             "SVN_adm1", mapa = "zemljevid", encoding = "UTF-8")

zemljevid$NAME_1 <- c("Gorenjska", "Goriška","Jugovzhodna", "Koroška", "Primorsko-notranjska", "Obalno-kraška",
                      "Osrednjeslovenska", "Podravska", "Pomurska", "Savinjska", "Posavska", "Zasavska")

zemljevid <- fortify(zemljevid)

pdf("slike/zemljevid_regije.pdf", width=6, height=4)