\docType{data}
\name{uçuşlar}
\alias{uçuşlar}
\title{Uçuşlar verisi}
\format{336.776 satır ve 19 sütundan oluşan bir data.frame
\describe{
\item{yıl}{Uçuş kalkış tarihi (yıl)}
\item{ay}{Uçuş kalkış tarihi (ay)}
\item{gün}{Uçuş kalkış tarihi (gün)}
\item{kalkış}{Fiili kalkış saati. Yerel saate göre SSDD veya SDD formatında}
\item{planlanan_kalkış}{Planlanan kalkış saati. Yerel saate göre SSDD veya SDD formatında}
\item{rötar_kalkış}{Rötar süreleri (dakika). Negatif değerler erken kalkışları temsil eder}
\item{varış}{Fiili varış saati. Yerel saate göre SSDD veya SDD formatında}
\item{planlanan_varış}{Planlanan varış saati. Yerel saate göre SSDD veya SDD formatında}
\item{rötar_varış}{Rötar süreleri (dakika). Negatif değerler erken varışları temsil eder}
\item{havayolu_kodu}{Havayolu şirketinin 2 harfli kısaltması. Adlarına ulaşmak için: \code{\link{havayolları}}}
\item{uçuş}{Uçuş numarası}
\item{kuyruk_numarası}{Uçak kuyruk numarası. Uçak kılavuz verileri için: \code{\link{uçaklar}}}
\item{orijin}{Kalkış noktası. Havalimanı kılavuz verileri için: \code{\link{havalimanları}}}
\item{varış_noktası}{Varış noktası. Havalimanı kılavuz verileri için: \code{\link{havalimanları}}}
\item{uçuş_süresi}{Havada geçirilen süre (dakika)}
\item{mesafe}{Havalimanları arasındaki mesafe (mil)}
\item{saat}{Planlanan kalkış saati}
\item{dakika}{Planlanan kalkış dakikası}
\item{tarih_saat}{POSIXct formatında planlanan uçuş tarihi ve saati. Uçuş verilerini, \code{\link{hava_durumu}} verileriyle birleştirmek için, orijin değişkeniyle birlikte kullanılabilir}
}}
\usage{uçuşlar}
\description{2013'te NYC'den (JFK, LGA ve EWR) kalkan tüm uçuşlar için zaman verileri.}
\seealso{\code{\link[nycflights13]{flights}}}
\keyword{datasets}


#### Combine bacterial abundances from the Delgado et al & Ramirez et al.
# get 10 most abundant taxa at every taxonomic rank
source("paths.r")
source("paths_fall2019.r")
source("NEFI_functions/crib_fun.r")
library(dplyr)
library(data.table)

# set output path
output.path <- delgado_ramirez_abun.path

#### Read in relative abundance data ####
ramirez_tax_all <- readRDS(ramirez_tax_fun_abun.path)
delgado_tax_all <- readRDS(delgado_16S_common_phylo_fg_abun.path)

# read in mapping data for subsetting
x <- readRDS(delgado_ramirez_bahram_mapping.path)

# find number for majority of the samples (currently not used)
cutoff <- .93
# number of taxa per rank
n.taxa<- 10

# do we want to subset the taxa by a number per rank, or by presence in a utoff % of samples?
method <- "cutoff"
method <- "n.taxa"

y.lev <- list()
for (k in 1:length(ramirez_tax_all)) {
  d.ram <- ramirez_tax_all[[k]]
  #colnames(d.ram) <- tolower(colnames(d.ram))
  d.ram <- d.ram[d.ram$sampleID %in% x$sampleID,]
  rownames(d.ram) <- d.ram$sampleID

  delgado_tax <- delgado_tax_all[[k]]$rel.abundances
  colnames(delgado_tax) <- tolower(colnames(delgado_tax))
  d.delgado <- as.data.frame(delgado_tax)
  d.delgado <- d.delgado[,colSums(d.delgado) > 0]
  d.delgado <- d.delgado[rownames(d.delgado) %in% x$sampleID,]

  common_col <- Reduce(intersect, list(colnames(d.ram), colnames(d.delgado)))
  y.ram <- d.ram[,colnames(d.ram) %in% common_col]
  y.delgado <- d.delgado[,colnames(d.delgado) %in% common_col]
  y.all.source <- do.call(plyr::rbind.fill, list(y.ram, y.delgado))
  rownames(y.all.source) <- c(rownames(y.ram), rownames(y.delgado))

  # remove samples that are exclusively (99%) one group
  y.all.source <- y.all.source[rowSums(y.all.source > 0)>1,]

  # subset to taxa present in the majority of samples
  n_maj <- nrow(y.all.source) * cutoff
  n.presences <- colSums(y.all.source != 0)
  if (k < 6) n.presences <- n.presences[names(n.presences) != c("other")]

  # get the X most abundant taxa (+ sampleID)
  if (method=="n.taxa") {
    y_maj <- y.all.source[,colnames(y.all.source) %in% names(tail(sort(n.presences),n.taxa)), drop=F]
    } else {   # get the taxa in % of samples (+ sampleID)
  y_maj <- y.all.source[,colSums(y.all.source != 0) > n_maj]
}
  row.name.save <- rownames(y_maj)

  # cribari-neto transformation
  y <- data.frame(lapply(y_maj, crib_fun, N = nrow(y_maj) * ncol(y_maj)))
  rownames(y) <- row.name.save

  #in the case where one column actually needs to be a zero for a row to prevent to summing over 1...
  for(i in 1:nrow(y)){
   if(rowSums(y[i,]) > 1){
     y[i,] <- y[i,] / rowSums(y[i,])
   }
  }
 # prob.rows <- which(rowSums(y)>1)
#  y[prob.rows,] <- apply(y,2, function(y) as.numeric(substr(y, 1, 6)))

 # add "other" column to sum to one.
  y$other <- NULL
  y$other  <- 1 - rowSums(y)

  prob.rows <- which(y$other==0)
  if (length(prob.rows) > 0) {
    print(k)
    print(prob.rows)
    y <- y[-prob.rows,]
  }
 # y[prob.rows,] <- data.frame(lapply(y[prob.rows,],crib_fun, N = nrow(y[prob.rows,]) * ncol(y[prob.rows,])))

  y.lev[[k]] <- y
}
names(y.lev) <- tolower(names(ramirez_tax_all))

saveRDS(y.lev, output.path, version = 2)


args = commandArgs(trailingOnly = TRUE);
if (length(args) >= 1) {
  file = args[1];
} else {
  file = "C:/Users/Marc/framestats.txt";
}

data = read.table(file=file, comment.char=';');
regions = unique(data[,1])

num_regions = length(regions);
num_frames  = length(data[,1]) / num_regions;

# If the number of regions is greater than 1, then what we have is a series
# of samples. Compute total frame time if this is the case.
frame_times <- c();
if (num_frames > 1) {
  for (i in 1:num_frames) {
    frame = data[i:(i+num_regions-1),];
    total = sum(frame[,2]);
    frame_times <- c(frame_times, total);
  }
}

# plot
if (length(args) >= 1) {
  output = paste0(file, ".pdf");
  cat(paste("Saving output to:", output, "\n"));
  pdf(output);
}
plot(x=data, type='l', xlab="Region", ylab="Time (ms)", main="Region Time")
plot(frame_times, type='l', col='blue', xlab="Frame", ylab="Time (ms)", main="Frame Time");
if (length(args) >= 1) {
  dummy <- dev.off(); # supress "null device" output
}

cat(paste("regions:", num_regions, "\n"));
cat(paste("frames:", num_frames, "\n"));

cat("Data:\n");
print(summary(data));

if (num_frames > 1) {
  cat("Frame time:\n");
  print(summary(frame_times));
}

# per-region summaries
for (i in 1:num_regions) {
  region = regions[i];
  values = data[data[,1] == region,2];
  cat(paste0(region, ":\n"));
  print(summary(values));
}

#data = as.matrix(read.table(file="C:/Users/Marc/framestats.txt", comment.char=';'))
#first = T;
#for (name in unique(data[,1])) {
#  entries = data[data[,1] == name,];
#  values  = entries[,2];
#  if (first) {
#    plot(values, type='l', ylim=c(0,80));
#    first = F;
#  }
#  else {
#    lines(values, type='l');
#  }
#}


###---This script will demonstrate the use of Tidycensus in R----#
###---Created by C. Tulley, SPC for PA Geo Dev 2022--------------#

#Set & check the working directory
setwd("C:\\Users\\cathy\\Desktop\\GeoDev\\") #local dir
setwd("L:\\your\\network\\folder\\project\\") #network dir
getwd()

#Install the necessary libraries
install.packages("censusapi")
install.packages("data.table")
install.packages("dplyr")
install.packages("openxlsx")
install.packages("readr")
install.packages("rgdal")
install.packages("sf")
install.packages("tigris")
install.packages("tidycensus")

#Load the necessary libraries
library(censusapi) #explain why we are using this, too :)
library(data.table)
library(dplyr)
library(openxlsx)
library(readr)
library(rgdal)
library(sf)
library(tigris)
library(tidycensus)
options(tigris_use_cache = TRUE)

###Preliminary bits###

# Add API key to .Renviron
Sys.setenv(CENSUS_KEY="YOUR_CENSUS_KEY")

# Reload .Renviron
readRenviron("~/.Renviron")

# Check to see that the expected key is output in your R console
Sys.getenv("CENSUS_KEY")

#set API key for tidycensus
census_api_key("CENSUS_KEY", install = TRUE)

#Provides list of APIs - using 'censusapi'
apis <- listCensusApis()

#check ACS geography names in the API - using 'censusapi'
acs_geo <- listCensusMetadata(name = "acs/acs5", vintage = 2019, type = "geography")
head(acs_geo)

#check ACS vars from API - using 'tidycensus'
api_vars <- load_variables(2019,"acs5",cache=TRUE)

####Data bits####

#Create a list of variables to send to the API
vars <- c('B28002_001E','B28002_002E','B28002_003E', 'B28002_004E', 'B28002_005E', 'B28002_006E', 'B28002_007E','B28002_008E','B28002_009E',
          'B28002_010E','B28002_011E','B28002_012E')

#Download tidy ACS data for tracts
#
#Census tracts "generally have a population size between 1,200 and 8,000 people,
#with an optimum size of 4,000 people." - US Census Bureau
#
data <- get_acs(
  geography = "tract",
  variables = vars,
  year = 2019,
  survey = "acs5",
  summary_var = NULL,
  state = "PA",
  #county = "Allegheny County",
  geometry = FALSE, #we just want the data right now - do not include the spatial version
  output = "wide")

#check output
dim(data)
head(data)

##Write the output to a CSV
write.csv(data, "acsdata_pa_tracts.csv", row.names = FALSE)

#write the files to Excel
write.xlsx(data, file = "acsdata_pa_tracts.xlsx")

####GIS bits####

#load the 2019 Census TIGER tracts shapefile
pa_tracts <- readOGR(dsn=".", layer="tl_2019_42_tract", stringsAsFactors = FALSE)
#Tip: Factors are data structures that store categorical data as levels.

#Join the data frame to the shp
pa_tracts_join <- geo_join(pa_tracts, data, "GEOID", "GEOID", how = "left")
#using the 'geo_join' function from the 'tigris' package
#join data TO tracts, not vice versa

#Write the output to a shapefile
writeOGR(pa_tracts_join, dsn=".",layer="pa_tracts_join", driver="ESRI Shapefile")

####Advanced GIS bits####

datageo <- get_acs(
  geography = "tract",
  variables = "B28002_001",
  year = 2019,
  survey = "acs5",
  summary_var = NULL,
  state = "PA",
  geometry = TRUE)#get the spatial data version

#Plot a quick map to check your data
plot(datageo["estimate"])


#' Train HMM with model specificaiton provided in `model`
#'
#' @param x vector or matrix of data
#' @param model model specification created by hmmspec.gen(..)
#' @param lock.transition boolean, whether to fix the transition matrix
#' @param tol numeric tolerance for convergence evaluation
#' @param maxit maximum number of EM iterations
#' @param verbose boolean, whether to print diagnostics
#' @return list with elements that describe the trained model
#' @details See example
#' @export
hextfit = function(x, model, lock.transition=FALSE, tol=1e-01, maxit=1000, verbose=TRUE) {
  K = model$K
  D = model$D  # size of the alphabet sets, this is a vector!
  M = model$M  # no. of gaussian mixtures
  if ( class(x)=="numeric" | class(x)=="integer") {
     warning('x is a primitive vector. Assuming single sequence.')
     TT = NROW(x)
     Nseq = 1
  } else {
    TT = x$TT
    Nseq = length(TT)
    x = x$x
  }
  mtype = model$mtype
  if ( length(mtype) != NCOL(x) ) stop("length of mtype differs from no of columns in x.")
  if ( K < 2 ) stop("K must be larger than one.")
  if( any(dim(model$ltransition)!=K) )  stop("dimensions of ltransition incorrect!")
  if( length(model$linit)!=K ) stop("dimensions of linit incorrect!")
  if( NROW(x)!=sum(TT) )  stop("no. of rows in x not equal sum(TT) !")

  mstep = model$mstep
  # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  Emit.Prob.Func = model$dens.emission
  # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  loglik1 = numeric(maxit)
  loglik1[] = NA
  loglik1[1] = -1000
  loglik2 = numeric(maxit)
  loglik2[] = NA
  loglik2[1] = -1000

  # initialize gamma ===========
  lgam = rep(-1.0e100, K*sum(TT))
  # ============================
  lAlpha = rep(-1.0e300, (K+1)*sum(TT))
  lBeta = rep(-1.0e300, K*sum(TT))

  ll = c(0.0, 0.0)
  mu.it = rep(list(list()), maxit)

  for(i in 1:maxit) {
    if (verbose == TRUE) cat("\niter:",i," ====")
    # calculate emission prob by state given model >>>>>>>>>>>>>>>>>>>>>>>>>>>>
    emit.p = sapply(1:K, fn <- function(state) Emit.Prob.Func(x, state, model))
    # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    # E-step <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    result = .C("mo_estep_hmm_ln",
        lA=as.double(t(model$ltransition)),
        lPi=as.double(t(model$linit)),
        lP=as.double(t(emit.p)),
        TT=as.integer(TT),
        nsequences=as.integer(Nseq),
        K=as.integer(K),
        forward_p=lAlpha,
        backward_p=lBeta,
        lgam=lgam,
        ll=as.double(ll),
        PACKAGE='Hext')

    loglik1[i] = result$ll[1]
    loglik2[i] = result$ll[2]
    if (verbose == TRUE) {
      cat("loglikelihood(alpha) ", result$ll[1])
      cat(".....(beta)", result$ll[2])
    }
    if ( i > 1 ) {
      if(abs(loglik1[i]-loglik1[i-1]) < tol) {
        if (verbose == TRUE) cat("\nConverged.\n")
        break
      }
    }
    # M-step >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    gam = matrix(exp(result$lgam), ncol=K)
    # simple check on gamma
    gamsum = rowSums(gam)

    model$parms.emission = mstep(x, gam, model)

    # write the optimized parameters back to model
    if(!lock.transition) {
      model$ltransition = matrix(result$lA, nrow=K, byrow=TRUE)
      model$linit = result$lPi
    }
    # save the means vector for output
    mu.it[[i]] = model$parms.emission$M5$mu.ll
  }

  LL = loglik1[i]    # last iteration
  # Calculate no of parameters in the model >>>>>>>>>>>>>>>>>>>>>>>>>
  # 1 = discrete
  ix1 = which(mtype == 1)
  if ( length(ix1) > 0 ) {
    n.par1 = K*length(ix1)*(D - 1)
  } else {
    n.par1 = 0
  }
  # 2 = normal/multivariate
  ix2 = which(mtype == 2)
  if ( length(ix2) > 0 ) {
    # Zucchini & MacDonald (2009), p.186
    # K*p(p+3)/2, where p is the dimension of the observation, and is equal
    # the number of 2s in mtype.
    n.par2 = K*length(ix2)*(length(ix2) + 3)/2
  } else {
    n.par2 = 0
  }
  # 3 = gamma
  ix3 = which(mtype == 3)
  if ( length(ix3) > 0 ) {
    # two free parameters for each component obeying the gamma distribution
    n.par3 = K * length(ix3) * 2
  } else {
    n.par3 = 0
  }
  # 4 = beta
  ix4 = which(mtype == 4)
  if ( length(ix4) > 0 ) {
    # two free parameters for each component obeying the beta distribution
    n.par4 = K * length(ix4) * 2
  } else {
    n.par4 = 0
  }
  # 5 = gaussian mixture
  ix5 = which(mtype == 5)
  if ( length(ix5) > 0 ) {
    # for each multivariate component, there are M mixtures, and each mixture
    # has p(p+3)/2 parameters, thus total :
    n.par5 = K * length(ix5)* M * (length(ix5) + 3) / 2
  } else {
    n.par5 = 0
  }
  np.trans = K * ( K - 1 )
  # Total number of parameters in the HMM
  N.param = np.trans + n.par1 + n.par2 + n.par3 + n.par4 + n.par5
  # Akaike information criterion (Ref : wiki on AIC)
  Aic = - 2*LL + 2*N.param
  # AIC with finite sample correction (see wiki on AIC)
  # Burnham, Anderson (2002) Model selection and multimodel inference: A Practical
  #   Information-Theoretic Approach, 2nd ed, Springer.
  Aicc = Aic + 2*N.param*(N.param + 1)/(sum(TT) - N.param - 1)
  Bic = - 2*LL + N.param*log(sum(TT))

  ret = list(model=model,mstep=mstep, gam=gam, lgam=result$lgam, last.it=i,
         loglik1=loglik1, loglik2=loglik2, TT=TT, yhat=apply(gam,1,which.max),
         Aic=Aic, Aicc=Aicc, Bic=Bic, mu.it=mu.it)
  class(ret) <- "Hext"
  return(ret)
}


testmarkers <- function (data, cl, markers_cutoff_pval_anovatest = 0.05, markers_pval_anovatest_fdr = TRUE)
{
    if (any(is.na(rowMeans(data))))
    stop("Error- missing values in the data")
    resAnova = resanova(data,cl)
    if (markers_pval_anovatest_fdr) {
        colpval = "anova.adjpvalues"
    }
    else {
        colpval = "anova.pvalues"
    }
    if (is.na(sum(resAnova[, colpval]))) {
        resAnova[, colpval][is.na(resAnova[, colpval])] = 1
    }
    if (sum(resAnova[, colpval] < markers_cutoff_pval_anovatest) ==
    0) {
        stop("There is no marker")
    }
    else {
        signifAnova = rownames(resAnova)[resAnova[, colpval] <
        markers_cutoff_pval_anovatest]
        cl = as.factor(as.character(cl))
        names(cl) = colnames(data)
        if (is.null(length(signifAnova)))
        warning("There is no marker")
        else {
            allauc = lapply(levels(cl), function(i) {
                thiscl = (cl == i) * 1
                names(thiscl) = names(cl)
                a = unlist(lapply(signifAnova, function(prob) {
                    PresenceAbsence::auc(data.frame(colnames(data),
                    thiscl[colnames(data)], as.numeric(data[prob,
                    ])), st.dev = FALSE)
                }))
                names(a) = signifAnova
                a
            })
            allauc = do.call(cbind, allauc)
            colnames(allauc) = levels(cl)
            FC = sapply(levels(cl), function(i) {
                classsamples = names(cl)[which(cl == i)]
                othersamples = setdiff(colnames(data), classsamples)
                unlist(lapply(signifAnova, function(p) {
                    mean(as.numeric(data[p, classsamples])) - mean(as.numeric(data[p,
                    othersamples]))
                }))
            })
            colnames(FC) = levels(cl)
            rownames(FC) = signifAnova
        }
        resTest = data.frame(resAnova[signifAnova, ], AUC = allauc,
        logFC = FC)
        return(resTest)
    }
}


library(flume)
library(scales)
library(RColorBrewer)
data("flume_networks")
net = flume_networks$kamp

# headwater nodes for immigration
sp_nodes = c(11, 16, 21:24, 30, 35, 37, 42, 46, 49, 50, 52)
nsp = 5

ex1_template = list(
	nsp = nsp, # gradient from 1 (competitor) to 5 (coloniser)
	nopts = list(location = rep(0.9, nsp), #everyone has the same location,
				 breadth = seq(0.8, 0.05, length.out = nsp), # competitors have broader niches
				 scale_c = seq(0.2, 0.5, length.out = nsp)/6e4, # competitors have lower raw colonisation rates,
				 scale_e = seq(0.05, 0.2, length.out = nsp)/1e6, # competitors have lower extinction rates
				 r_use = seq(0.2, 0.05, length.out = nsp)), # competitors better reduce resources)
	dopts = list(alpha = 0, beta = seq(0.1, 1, length.out = nsp)),
	# competitors are stronger competitors; direct competition disabled for this scenario
	comp = seq(0.4, 0.05, length.out = nsp)*0
)

ex1_template$mcom = with(ex1_template, metacommunity(nsp = nsp, nr = 1,
						niches = niches_custom, niche_args = nopts,
						dispersal = dispersal_custom, dispersal_args = dopts,
						comp_scale = comp))

ex1_template$spcols = brewer.pal(nsp+3, "Purples")[4:(nsp+3)]

## next design the network

## then set up starting and boundary conditions
ex1_template = within(ex1_template,
				start_sp = matrix(0, nrow = length(net), ncol = nsp),
				bound_sp = matrix(0, nrow = length(net), ncol = nsp),
				start_r = matrix(max(locs), nrow = length(net), ncol = 1),
				bound_r = matrix(max(locs), nrow = length(net), ncol = 1))

for(i in sp_nodes)
	ex1_template$bound_sp[i,] = ex1_template$dopts$beta[i]/2

save(list = c("net", "sp_nodes", "ex1_template"),
	 file = "flume_examples/ex1/data/ex1_data.rda")


#!/usr/bin/env Rscript
####################################################################################
### Copyright (C) 2015-2019 by ABLIFE
####################################################################################

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

####################################################################################
# Date           Version       Author            ChangeLog

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

#######################################################################################
#
#This can be used to plot 2 y axis and to show the data with unit
#
#######################################################################################

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

#####################################################################################
suppressPackageStartupMessages(library("optparse"))
suppressPackageStartupMessages(library("stats"))

usage = "The prog is used to display the cumulatived data of RPKM.

example: Rscript /users/ablife/ablife-R/Line/Line_cumu/latest/Line_single_Cumulative_ggplot2.r
	-f /users/ablife/ablife-R/Line/Line_cumu/latest/inflorescence_RPKM_Cumulative.txt
	-t inflorescence_RPKM
	-n inflorescence_RPKM
	"

option_list <- list(
	make_option(c("-f", "--file"),action = "store",type = "character",
		help = "The Input file"),
	make_option("--log",action = "store_true",default = FALSE,
		help = "handel the data using log"),
	make_option(c("-t", "--title"),action = "store",type = "character",
		help = "The title of outimage"),
	make_option(c("-n", "--filename"),action = "store",type = "character",
		help = "The name of outimage"),
	make_option(c("-o", "--outdir"),action = "store",type = "character",default = "./",
		help = "The outdir")
	)
opt <- parse_args(OptionParser(option_list = option_list))

setwd(opt$outdir)						####

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

###################################################################################
library(ggplot2)
library(reshape2)
library(plotrix)
library(methods)
library(gtable)
library(grid)
###################################################################################
colour <- c('#85A2EF','#D285EF','#A2EF85','#4682B4','#A0522D','#87CEEB','#6B8E23','#6A5ACD','#E59B95','#EFD285','#B4B643','#2E9AFE','#A1DDBB','#FF8C00')

#######data format sample########
#key     accumulative_value
# 0.01    139
# 0.02    237
# 0.03    302
# 0.04    382
# 0.05    438
# 0.06    501
# 0.07    549
# 0.08    610
# 0.09    654
# 0.10    709
# 0.11    759
# 0.12    799
# 0.13    848
# 0.14    888
# 0.15    929
#
#
#################################

######Instruction for data#######
#first column is the X axis
#from second to end is the data for ploting
#first row is the head to declare the data
#
#################################

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

data <- read.table(file= opt$file,header = T,sep = "\t")#####	must with header
colname <- colnames(data)
colname[1] <- sub('X.','',colname[1])
dim_data <- dim(data)
sample <-colname[3]
percent_10 <- abs(data[,2]-10)
percent_50 <- abs(data[,2]-50)
num_10 <- min(which(percent_10 == min(percent_10),arr.ind = TRUE))
num_50 <- min(which(percent_50 == min(percent_50),arr.ind = TRUE))
label_10 <- paste("(",data[num_10,1],sep='')
label_10 <- paste(label_10,data[num_10,2],sep = '，')
label_10 <- paste(label_10,"%)",sep = '')

label_50 <- paste("(",data[num_50,1],sep = '')
label_50 <- paste(label_50,data[num_50,2],sep = '，')
label_50 <- paste(label_50,"%)",sep = '')

First_Y = seq(0,1,by=0.2)*data[dim_data[1],3]
First_label = round(First_Y,0)
Sencond_Y=seq(0,100,by=20)
percent = paste(Sencond_Y,'%')

title <- gsub('_',' ',opt$title)
ablife_theme_line <- function(base_size = 12){
	library(grid)		####for using unit function
	theme(
		plot.title = element_text(size=34,lineheight = 10,colour="#000000",face ="bold",family = "sans",vjust = 0.5),

		axis.title.x = element_text(size=28,colour = "#000000",face = "bold",family = "sans",vjust = -0.1
			),
		axis.title.y = element_text(size=28,colour = "#000000",face = "bold",vjust = 1),
		axis.text.x = element_text(size = 22,colour = "#000000"),
		axis.text.y = element_text(size = 22 ,colour = "#000000"),
   		axis.ticks.length = unit(0.25,"cm"),
		axis.ticks = element_line(colour = "#000000"),

		legend.title = element_text(size = 15),
		legend.text = element_text(size = 15),
		legend.key.size = unit(1.2,"cm"),

		panel.background = element_rect(fill = "white",colour = NA),
		# panel.border = element_rect(size = 1,colour = "#8B8B8B",fill =NA),
		# panel.grid.major = element_line(size=0.5,colour = "#BFBFBF"),
		# panel.grid.minor = element_line(size=0.1,colour = "#7F7F7F")
		panel.border = element_rect(size = 1.5,colour = "#000000",fill =NA),
		panel.grid.major.x = element_line(size=0.5,colour = "#909090"),
		panel.grid.major.y = element_line(size=0.5,colour = "#909090",linetype = "dotted"),
		panel.grid.minor = element_line(size=0.1,colour = "#7F7F7F")
		)
}

png(file=paste(opt$filename,'_Cumulative_Line.png',sep=''),pointsize=40,width=1000,height=600)
grid.newpage()
p1 <- ggplot(data)+
		geom_line(aes(x = data[,1],y=data[,3],stat = "identity",group = 1),colour = colour[12],size =1.5,position = "identity")+
		labs(title = title,x=colname[1],y= colname[3])+
		ablife_theme_line()+
		scale_y_continuous(labels = First_label,breaks = First_Y)+
		scale_colour_hue(name=sample)+

		scale_x_continuous(limits=(c(0,100)))
#
p2 <- ggplot(data)+
		geom_line(aes(x = data[,1],y=data[,2],stat = "identity",group = 1),colour = colour[12],size =1.5,position = "identity")+
		labs(title = title,x=colname[1],y= colname[2])+
		ablife_theme_line()+
		scale_y_continuous(labels = percent,breaks=Sencond_Y)+
		scale_colour_hue(name=sample)+

		# # geom_segment(aes(x=c(data[num_10,1],data[num_50,1]),y=c(0,0),xend=c(data[num_10,1],data[num_50,1]),yend = c(yend1,yend2)),colour = '#339900',size = 0.5)+
		# geom_segment(aes(x=data[num_10,1],y=0,xend = data[num_10,1],yend = data[num_10,2]),colour = "#339900",size=0.5)+
		# geom_segment(aes(x=data[num_50,1],y=0,xend = data[num_50,1],yend = data[num_50,2]),colour = "#339900",size=0.5)+
		geom_hline(aes(yintercept = data[num_10,2]),colour = "#909090",size = 0.7)+
		geom_hline(aes(yintercept = data[num_50,2]),colour = "#909090",size = 0.7)+
		geom_point(aes(x=data[num_10,1],y=data[num_10,2]),shape=21,size = 5,colour = "#666666")+
		geom_point(aes(x=data[num_50,1],y=data[num_50,2]),shape=21,size = 5,colour = "#666666")+
		annotate("text",x= c(data[num_10,1],data[num_50,1]),y=c(data[num_10,2],data[num_50,2]),label = c(label_10,label_50),hjust = -0.3,vjust = -1,size=8)+
		scale_x_continuous(limits=(c(0,100)))
g1 <- ggplot_gtable(ggplot_build(p1))
g2 <- ggplot_gtable(ggplot_build(p2))

pp <- c(subset(g1$layout,name == "panel",se = t:r))
g<-gtable_add_grob(g1,g2$grobs[[which(g2$layout$name == "panel")]],pp$t,pp$l,pp$b,pp$l)

ia <- which(g2$layout$name == "axis-l")
ga <- g2$grobs[[ia]]
ax <- ga$children[[2]]
ax$widths <- rev(ax$widths)
ax$grobs <- rev(ax$grobs)
ax$grobs[[1]]$x <- ax$grobs[[1]]$x - unit(1,"npc") + unit(0.15,"cm")
g <- gtable_add_cols(g,g2$widths[g2$layout[ia, ]$l],length(g$widths) -1)
g <- gtable_add_grob(g,ax,pp$t,length(g$widths)-1,pp$b)

grid.draw(g)


plt_proj<-function(dat,Title="Model 1")    {
  #windows(,6.5,9)
  FutBiom(dat)
  #windows(,6.5,9)
  FutCatch(dat)
  # mtext(Title,3,0,outer=T, cex=2, col="blue",family="sans",font=2)
}

FutBiom <- function (dat, new=TRUE,ylab="SSB, both sexes (kt)")
{
  ltmp=c("F35","F=SQ","F=.5SQ","F=.25SQ", "F=0.0")
  attach(dat)
  Data = get("SSB")
  xlim = c(min(Data[,1]+12),max(Data[,1])+10)
  ymax = 1.3*max(Data[13:length(Data[,2]),2])
  ylim = c(0,ymax)
  plot(Data[,1],Data[,2],type="n",lwd=2,
  xlab="Year",ylab=ylab,
  #lab=c(10,10,7),
  xlim=xlim, ylim=ylim, col="red")
  n=length(Data[,1])
  x=c(Data[13:n,1],Data[length(Data[,1]):13,1])
  y=c(Data[13:n,4],Data[length(Data[,1]):13,5])
  polygon(x,y,col="salmon",lty=3,border="grey")
  lines(Data[13:n,1],Data[13:n,2],lwd=2, col="darkred")
  Data = get("SSB_fut_5")
  x=c(Data[,1],Data[length(Data[,1]):1,1])
  y=c(Data[,4],Data[length(Data[,1]):1,5])
  polygon(x, y,col=rainbow(1,alpha=.2,start=.8),
          lty=3,border="grey")
  Data = get("SSB_fut_2")
  x=c(Data[,1],Data[length(Data[,1]):1,1])
  y=c(Data[,4],Data[length(Data[,1]):1,5])
  polygon(x, y,col=rainbow(1,alpha=.5,start=.12),
          lty=3,border="grey")
  for (i in 1:5)
  {
    Data = get(paste("SSB_fut_",i,sep=""))
    lines(Data[,1],Data[,2],lwd=2, col=i)
    points(Data[,1],Data[,2],pch=i, col=i)
  }

  # legend("topright", ltmp, col=1:5,lwd=2, title="          ", inset = .02)
  legend("topright", ltmp, pch=1:5,lwd=2,col=1:5,       title="Future SSB", inset = .02)
  detach(dat)
}

FutCatch <- function (dat, new=TRUE,ylab="Total Catch (kt)",fy=1977,ly=2020)
{
  require(lattice)
  attach(dat)
 nfsh = length( dat$Fshry_names)
 catch_tot = Obs_catch_1
 for (i in 1:nfsh) catch_tot= catch_tot+get(paste("Obs_catch_",i,sep=""))
  xlim = c(fy,ly)
  ylim = c(0,1.5*max(catch_tot))
  plot(fy:(fy+length(catch_tot)-1),catch_tot,
    type="l",lwd=2,
    xlab="Year",ylab=ylab,xlim=xlim, ylim=ylim, col="red")
  x= Catch_fut_1[,1]
  y= Catch_fut_1[,2]
  ltmp=c("F35","F=SQ","F=.5SQ","F=.25SQ")
  print(ltmp)
  for (i in 1:4)
  {
    y = get(paste("Catch_fut_",i,sep=""))
    #lines(x,y[,2],lty=i,lwd=3)
    points(x,y[,2],pch=i      )
  }
  # legend("topright", ltmp, lty=1:4,lwd=3, title="Future catch", inset = .02)
  legend("topright", ltmp, pch=1:4,       title="Future catch", inset = .02)
  detach(dat)
}


N_0 <- 100
y_0 <- 20

N <- 100
y <- 20

cc <- 1
dd <- 1

nu <- 1
eta <- 1


# Function to read multiple CSV files
# Format of input files is 4 columns: the first is a label for each landmark and the rest are the XYZ coordinates
readmulti.csv<-function(filelist){
  n<-length(filelist)
  names<-gsub(".csv","",filelist, ignore.case=T)
  landdata<-nland<-NULL
  for (i in 1:n){
    temp <-read.csv(filelist[i], header=TRUE,row.names = 1)
    p<-nrow(temp);k<-ncol(temp)
    nland<-rbind(nland,p)
    if (min(nland)!=max(nland)) {
      stop("Number of landmarks not the same in all files.") }
    data<-matrix(as.numeric(unlist(temp)),ncol=3,byrow=F)
    landdata<-rbind(landdata,data)
  }
  coords<-arrayspecs(landdata,p,k)
  dimnames(coords)[[3]]<- as.list(names)
  return(coords=coords)
}


library(dplyr)

## requires entities df
get_summary_info <- function(df) {
  observations <- nrow(df)

  biggest_advertiser <- df %>%
    filter(advertiser != "") %>%
    group_by(advertiser) %>%
    summarise(total = n()) %>%
    filter(total == max(total)) %>%
    pull(advertiser)

  biggest_funder <- df %>%
    filter(paid_for_by != "") %>%
    group_by(paid_for_by) %>%
    summarise(total = n()) %>%
    filter(total == max(total)) %>%
    pull(paid_for_by)

  political_count <- df %>%
    filter(!is.na(political)) %>%
    nrow()
  non_political_count <- df %>%
    filter(!is.na(not_political)) %>%
    nrow()
  return(
    list(
      observations = observations,
      advertiser = biggest_advertiser,
      funder = biggest_funder,
      political_percentage = political_count /
        (political_count + non_political_count) * 100
    )
  )
}

## Removed code was problematic, I'll fix later -Michael


dyn.load('/Library/Java/JavaVirtualMachines/jdk1.8.0_131.jdk/Contents/Home/jre/lib/server/libjvm.dylib')

setwd("/Users/mengmengjiang/all datas/voltage")
library(xlsx)

##raeding datas of flow rates
eq<-read.xlsx("voltage.xls",sheetName="ethanol_q",header=TRUE)
aq<-read.xlsx("voltage.xls",sheetName="acetone_q",header=TRUE)
iq<-read.xlsx("voltage.xls",sheetName="iso_q",header=TRUE)

##
yan<-c("red","blue","green3")

## layout

par(mfrow = c(2,2), mar = c(2,2.4,1,1), oma = c(1,1,1,1))
layout(matrix(c(1,2,3),3,1,byrow = TRUE))

## flow rates
plot(eq$f, eq$va,  col=0, xaxs="i", xlim=c(-0.002, 0.032), ylim=c(0.4,1.2),
     xlab=expression(italic(Q)(nl/min)),mgp=c(1.4, 0.2, 0),tck=0.01,cex.lab=1.2,cex.axis=1.2,
     ylab=expression(italic(V)(kv)))

mtext("Flow rate",col="black",3,line=-1.3,font=2,cex=0.9)

lines(eq$f,eq$seva,col=yan[1],pch=0,lwd=2,lty=4,type="b")
lines(aq$f,aq$seva,col=yan[2],pch=1,lwd=2,lty=4,type="b")
lines(iq$f,iq$seva,col=yan[3],pch=2,lwd=2,lty=4,type="b")

leg<-c("ethanol","acetone","iso")

legend("bottomright",legend=leg, col=yan, pch=c(0,1,2),bty="n",lwd=2,lty=2,inset=.01,cex=1.2)

## Distance

eq<-read.xlsx("voltage.xls",sheetName="ethanol_d",header=TRUE)
aq<-read.xlsx("voltage.xls",sheetName="acetone_d",header=TRUE)
iq<-read.xlsx("voltage.xls",sheetName="iso_d",header=TRUE)

plot(eq$d, eq$va,  col=0, xaxs="i", xlim=c(0.5,4.5), ylim=c(0.6,1.4),xlab=expression(italic(Distance)(mm)),mgp=c(1.3, 0.2,0),tck=0.01,cex.lab=1.2,cex.axis=1.2,ylab=expression(italic(V)(kv)))

mtext("Distance",col="black",3,line=-1.3,font=2,cex=0.9)

lines(eq$d,eq$seva,col=yan[1],pch=0,lwd=2,lty=4,type="b")
lines(aq$d,aq$seva,col=yan[2],pch=1,lwd=2,lty=4,type="b")
lines(iq$d,iq$seva,col=yan[3],pch=2,lwd=2,lty=4,type="b")

leg<-c("ethanol","acetone","iso")

legend("bottomleft",legend=leg, col=yan, pch=c(0,1,2),bty="n",lwd=2,lty=2,inset=.01,cex=1.2)

## Nozzle diameter ###

eq<-read.xlsx("voltage.xls",sheetName="ethanol_r",header=TRUE)
aq<-read.xlsx("voltage.xls",sheetName="acetone_r",header=TRUE)
iq<-read.xlsx("voltage.xls",sheetName="iso_r",header=TRUE)

plot(eq$r, eq$va,  col=0, xaxs="i", xlim=c(0.25,0.85), ylim=c(0.6,1.4),xlab=expression(paste(italic(Nozzle)," ",italic(diameter),(mm))),mgp=c(1.3, 0.2,0),tck=0.01,cex.lab=1.2,cex.axis=1.2,ylab=expression(italic(V)(kv)))

mtext("Nozzles",col="black",3,line=-1.3,font=2,cex=0.9)

lines(eq$r,eq$seva,col=yan[1],pch=0,lwd=2,lty=4,type="b")
lines(aq$r,aq$seva,col=yan[2],pch=1,lwd=2,lty=4,type="b")
lines(iq$r,iq$seva,col=yan[3],pch=2,lwd=2,lty=4,type="b")
g
leg<-c("ethanol","acetone","iso")

legend("topleft",legend=leg, col=yan, pch=c(0,1,2),bty="n",lwd=2,lty=2,inset=.01,cex=1.2)


install.packages("keras")
library(keras)
install_keras()
model <- keras_model_sequential()


#
# Licensed to the Apache Software Foundation (ASF) under one
# or more contributor license agreements.  See the NOTICE file
# distributed with this work for additional information
# regarding copyright ownership.  The ASF licenses this file
# to you under the Apache License, Version 2.0 (the
# "License"); you may not use this file except in compliance
# with the License.  You may obtain a copy of the License at
#
#   http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing,
# software distributed under the License is distributed on an
# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
# KIND, either express or implied.  See the License for the
# specific language governing permissions and limitations
# under the License.
#

# Import the tempInCity function exported from the Ruby module
tempInCity <- import('tempInCity')

# The lattice library is needed for the visualization
library(lattice)

createModel <- function(size, length, getName, getLat, getLong, getTemp) {
  idx <- sample(1:length, size)
  data <- as.data.frame(list(
      name = sapply(idx, function(i) getName(i)),
      lat = sapply(idx, function(i) getLat(i)),
      long = sapply(idx, function(i) getLong(i)),
      temp = sapply(idx, function(i) getTemp(i))))
  list(data=data, model=lm(temp~lat, data=data))
}

do_predict <- function(model, lat) {
  predict(model$model, as.data.frame(list(lat = lat)))[[1]]
}

plotModel <- function(model) {
  svg()
  print(xyplot(temp ~ lat, data = model$data,
    panel = function(x, y) {
      panel.xyplot(x, y, cex=2, pch=19)
      panel.abline(model$model)
      labelsIdx <- seq(1, length(x), length.out = 10) # show only 10 labels, to make the graph more readable
      panel.text(x[labelsIdx] + 1, y[labelsIdx], model$data$name[labelsIdx], adj = c(0, 0.5))
  }));
  grDevices:::svg.off()
}

# Export the functions
export('createModel', createModel)
export('do_predict', do_predict)
export('plotModel', plotModel)


# QC4 - What are the severity score measurements of a patient and which measurement method was used?

# person_ has_role person_patient_role;
# person_patient_role is_realized_in severity_score_evaluation_process_;

# severity_score_evaluation_process_ has_output_ severity_score_answer;
# severity_score_evaluation_process_ has_quality severity_score_evaluation_process_date_;

# severity_score_evaluation_process_ has_input severity_score_measurement_method_;
# severity_score_measurement_method_ has_version severity_score_measurement_version_;
# severity_score_measurement_version_ has_value “1.0” ;
# severity_score_measurement_method_ has_scale severity_score_result_scale_ ;

# severity_score_result_scale_ has_minimal_value “0” ;
# severity_score_result_scale_ has_maximal_value “1” ;

# LUMC prefixes
PREFIX rdf:     <http://www.w3.org/1999/02/22-rdf-syntax-ns#>
PREFIX rdfs:    <http://www.w3.org/2000/01/rdf-schema#>
PREFIX xsd:     <http://www.w3.org/2001/XMLSchema#>
PREFIX owl:     <http://www.w3.org/2002/07/owl#>
PREFIX dc:     <http://purl.org/dc/terms/>
PREFIX obo:     <http://purl.obolibrary.org/obo/>
PREFIX ncit:    <http://ncicb.nci.nih.gov/xml/owl/EVS/Thesaurus.owl#>
PREFIX sio:     <http://semanticscience.org/resource/>
PREFIX prov:    <http://http://http://www.w3.org/ns/prov#>
PREFIX bc:      <https://rdf.biosemantics.org/resources/beat-covid/>
PREFIX lco:     <http://purl.org/beat-covid/lco.owl#>
PREFIX om:      <http://www.ontology-of-units-of-measure.org/resource/om-2/>

SELECT ?patient_id ?severity_score_answer ?severity_score_measurement_method ?severity_score_measurement_version ?scale_min ?scale_max WHERE {
    ?person a sio:SIO_000498 ;
              sio:SIO_000228 ?person_patient_role .

    ?person_patient_role a sio:SIO_000715 ;
                         sio:SIO_000356 ?severity_score_evaluation_process  .

    ?patient_id a lco:clinical_id  ;
                  obo:IAO_0000219 ?person_patient_role .

    ?severity_score_evaluation_process a obo:NCIT_C25214 ;
                                         sio:SIO_000229 ?severity_score_answer ;
                                         dc:conformsTo ?severity_score_measurement_method ;
									     sio:SIO_000217 ?severity_score_evaluation_process_date .

    ?severity_score_evaluation_process_date a obo:NCIT_C25164 .

    ?severity_score_measurement_method a obo:NCIT_C81265 ;
                                         dc:hasVersion ?severity_score_measurement_version ;
                                         om:hasScale ?severity_score_result_scale .

    ?severity_score_answer a obo:CMO:0001109 .

    ?severity_score_result_scale a obo:NCIT:C25664 ;
                                   obo:LABO_0000118 ?scale_min ;
							       obo:LABO_0000119 ?scale_max .
}


# API Key:
# QUKSG1N9U1GU2PTG
library(jsonlite)
library(httr)
library(tidyverse)

r <- GET("https://api.iextrading.com/1.0/stock/market/batch",
           query = list(symbols = "GOOG",
                        types = "chart",
                        range = "5y", last = "5"))
  r1 <- content(r)
  rtick <- enframe(unlist(r1[["GOOG"]]$chart))
  rdates <- filter(rtick, name=="date")
  rclose <- filter(rtick, name=="close")
  rhigh <- filter(rtick, name=="high")
  rlow <- filter(rtick, name=="low")
  rvolume <- filter(rtick, name=="volume")
  df <- data.frame(rdates[2], rclose[2], rhigh[2], rlow[2], rvolume[2])
  df <- df %>%
    rename(date="value", close="value.1", high="value.2", low="value.3",
           volume="value.4")


postprocess_beta_age_if_aM_in_names <- function(aM,beta_age,age_band,outfile.base)
{
  cat("\n ----------- make beta_age figure when aM in names ----------- \n")
  tmp2 <- as.matrix(aM)
  tmp2 = reshape2::melt(tmp2) %>%
    rename(region = Var2, aM = value)

  tmp <- as.array(beta_age)
  tmp <-aperm(tmp, c(1, 3, 2))
  colnames(tmp) <- age_band
  tmp = reshape2::melt(tmp) %>%
    rename(age = Var2, region = Var3, beta_age = value) %>%
    merge(tmp2, by = "region") %>%
    mutate(beta_age_wre = beta_age-aM) %>%
    group_by(age) %>%
    summarise(M = mean(beta_age_wre),
              CL = quantile(beta_age_wre, prob = 0.025),
              CU = quantile(beta_age_wre, prob = 0.975))
  g <- ggplot(tmp, aes(x = age)) +
    geom_point(aes(y = M)) +
    geom_errorbar(aes(ymin = CL, ymax = CU)) +
    geom_hline(yintercept=1) +
    labs(x=expression(beta[a])) +
    theme_bw()
  ggsave(paste0(outfile.base,'-beta_age.png'),g,height=5,width=7)
}

make_parPerTimePerLoc_summaries <- function(samples, dates, regions, pop_info)
{
  ps <- c(0.5, 0.025, 0.975)
  p_labs <- c('M','CL','CU')

  stopifnot( dim(samples)[3]==length(regions) )

  p_loc <- unique(subset(pop_info, select=c(loc,pop_total)))
  p_loc <- subset(p_loc, loc %in% regions)
  p_loc <- p_loc[, pop_prop:=pop_total/sum(pop_total)]

  ans <- vector('list',length(regions))
  ans_overall <- vector('list',length(regions))
  #	loop over locations for speed. very hard to take quantiles on such large data
  for(m in seq_along(regions))
  {

    #m <- 1
    cat('\nProcessing state',m,' ',regions[m])

    ds_m <- as.data.table( reshape2::melt( samples[,,m] ) )
    setnames(ds_m, 1:3, c('iteration','time','value'))

    # save time mapping for region m
    tmp1 <- unique(subset(ds_m, select=time))
    tmp1[, date:= dates[[m]][tmp1$time[1]] + tmp1$time - tmp1$time[1]]

    #	to compute national average: add prop_pop, time and save
    tmp <- ds_m[, pop_prop := subset(p_loc, loc==regions[m])$pop_prop]
    # add dates: we need to do here because the time index are different by state
    tmp <- merge(tmp, tmp1, by = 'time')
    tmp[, loc:= regions[m]]
    ans_overall[[m]] = copy(tmp)

    # summarise
    ds_m <- ds_m[, list( 	q= quantile(value, prob=ps),
                          q_label=p_labs),
                 by=c('time')]

    #	add loc
    ds_m[, loc:= regions[m]]

    # add time index and date
    ds_m <- merge(ds_m, tmp1, by='time')

    # build new data object only after summarised
    ans[[m]] <- copy(ds_m)
  }
  ans <- do.call('rbind',ans)
  ans_overall <- do.call('rbind',ans_overall)

  ## National average
  # keep date that are common to every region
  tmp = unique(select(ans_overall, loc, date))
  dates_common = colnames(a<-table(tmp))[colSums(a>0)==nrow(a)]
  ds_m <- subset(ans_overall, date %in% as.Date(dates_common))
  #	summarise
  ds_m <- ds_m[, list(value= sum(value*pop_prop)), by=c('date','iteration')]
  ds_m <- ds_m[, list(q= quantile(value, prob=ps),
                      q_label= p_labs),
               by=c('date')]

  #	make human readable loc labels
  tmp <- unique(subset(pop_info, select=c(loc, loc_label)))
  ans <- merge(ans, tmp, by='loc')
  ans <- select(ans, -time)
  ds_m[,loc:= "US"]
  ds_m[,loc_label := "United-States"]
  ans <- rbind(ans, ds_m)

  ans <- dcast.data.table(ans, loc + loc_label  + date ~ q_label, value.var='q')
  ans
}

make_epidemiologic_scenarios_from_Rta <- function(Rt_byage_less_than_one,cutoff)
{
  Rt_byage_less_than_one[,date.type:=weekdays(date)]
  Rt_byage_less_than_one[,week:=floor_date(date,'week', week_start = 1)]
  Rt_byage_less_than_one_weekday <- Rt_byage_less_than_one[date.type %in% c('Monday','Tuesday','Wednesday','Thursday','Friday')]
  Rt_byage_less_than_one_weekend <- Rt_byage_less_than_one[date.type %in% c('Saturday','Sunday')]
  dt <-   Rt_byage_less_than_one_weekday[,list(greater_than_cutoff=sum(value>cutoff),
                                               total=length(value)),by=c('loc_label','age_band','week')]
  dt[,prop_greater_than_cutoff:=greater_than_cutoff/total]
  dt2 <-   Rt_byage_less_than_one_weekend[,list(greater_than_cutoff=sum(value>cutoff),
                                                total=length(value)),by=c('loc_label','age_band','week')]
  dt2[,prop_greater_than_cutoff:=greater_than_cutoff/total]
  clusters <- vector()

  for (state in unique(dt$loc_label)){
    tmp <- dt[loc_label==state]
    tmp.max.date <- tmp[total==5,max(week)]
    tmp2 <- dt2[loc_label==state]
    tmp2.max.date <- tmp2[total==2,max(week)]
    if(all(tmp[week==tmp.max.date &  age_band =='35-49' & total==5,prop_greater_than_cutoff==0.0])){
      if(any(tmp[ age_band =='35-49', prop_greater_than_cutoff >0.4])){
        clusters <- c(clusters, "recent rise in reproductive numbers > 1  in adults")
      }else{
        if(all(tmp[week==tmp.max.date&  age_band =='20-34' & total==5,prop_greater_than_cutoff==0.0])|
           all(tmp[week==tmp.max.date&  age_band =='10-19' & total==5,prop_greater_than_cutoff==0.0])|
           all(tmp[week==tmp.max.date&  age_band =='50-64' & total==5,prop_greater_than_cutoff==0.0])){
          clusters <- c(clusters, "sustained reproductive numbers > 1 across many age groups")
        }else{
          clusters <- c(clusters, "sustained reproductive numbers > 1 in adults")
        }
      }
    }else if(all(tmp[week==tmp.max.date&  age_band =='35-49' & total==5,prop_greater_than_cutoff==1.0])){
      if(tmp[week==tmp.max.date&  age_band =='35-49' & total==5,prop_greater_than_cutoff] >
         tmp2[week==tmp2.max.date&  age_band =='35-49' & total==2,prop_greater_than_cutoff]){
        clusters <- c(clusters, 'unclear')
      }else{
        clusters <- c(clusters, "all age-specific reproductive numbers consistently < 1")
      }
    }else{
      clusters <- c(clusters, NA_character_)
    }
  }
  return(list(clusters,unique(dt$loc_label)))
}

#' @export
#' @keywords internal
#' @import tidyr forcats grid ggplot2 ggpubr
#' @importFrom scales percent
plot_Rt_less_than_one <- function(Rt_byage_less_than_one, plot_rebound_date=FALSE, rebound_date, outfile.base=NA_character_)
{

  tmp <- data.table(y=runif(1e3 *  length(unique(Rt_byage_less_than_one$loc_label)), 0.5, 0.5 + length(unique(Rt_byage_less_than_one$age_band))),
                    loc_label=rep(unique(Rt_byage_less_than_one$loc_label),each=1e3))
  tmp <- merge(tmp, unique(subset(Rt_byage_less_than_one, select=c(loc_label, epi_scenario_label))), by='loc_label')
  set(tmp, tmp[, which(is.na(epi_scenario_label) | epi_scenario_label=='-')], 'epi_scenario_label', 'unclear')
  set(tmp, NULL, 'epi_scenario_label', tmp[,factor(epi_scenario_label)])
  tmp[,epi_scenario_label:=factor(epi_scenario_label,
                                  levels= c("Rt<1 for all ages in last 4 weeks","Rt>1 after 4 week period of Rt<1 for all ages",
                                            "unclear",
                                            "Rt>1 for 35-49 in last 4 weeks and no prior period with sustained Rt<1",
                                            "Rt>1 for 35-49 and other age groups in last 4 weeks and no prior period with sustained Rt<1"),
                                  labels = c("Rt<1 for all ages in last 4 weeks",
                                             "Rt>1 after 4 week period of Rt<1 \n for all ages",
                                             "unclear",
                                             "Rt>1 for 35-49 in last 4 weeks \n and no prior period with \n sustained Rt<1",
                                             "Rt>1 for 35-49 and other age groups \n in last 4 weeks and no prior period \n with sustained Rt<1"))]
  p <- ggplot( Rt_byage_less_than_one) +
    scale_x_date(expand=c(0,0), date_breaks = "4 weeks", labels = date_format("%e %b")) +
    scale_y_discrete(expand=c(0,0)) +
    geom_tile(aes(x= date, y= age_band, fill=value)) +
    geom_rug(data=tmp,aes(y=y, color=epi_scenario_label),sides='r',outside=TRUE, show.legend=TRUE,size=2)+
    scale_colour_manual(values=c("Rt<1 for all ages in last 4 weeks"="deepskyblue",
                                 "Rt>1 after 4 week period of Rt<1 \n for all ages"="gold",
                                 "Rt>1 for 35-49 in last 4 weeks \n and no prior period with \n sustained Rt<1"="darkorchid1",
                                 "Rt>1 for 35-49 and other age groups \n in last 4 weeks and no prior period \n with sustained Rt<1"="firebrick1",
                                 "unclear"="pink"))+
    scale_fill_gradient(high = "azure1", low = "grey30", labels = scales::percent) +
    #scale_fill_gradient(high = c("lighskyblue2", "yellow", "blue"), labels = scales::percent) +
    #scale_fill_viridis(begin=0.1,end=1, alpha=1, direction=-1, option="inferno", labels = scales::percent) +
    #scale_fill_grey(labels = scales::percent) +
    #scale_fill_gradientn(colours = c("red", "yellow", "blue"), labels = scales::percent) +
    labs(x= 'Date', y='Age bands',color='Epidemiologic classification',
         fill='Posterior probability that age specific \n R[t] is below 1 \n \n \n ') +
    facet_wrap(loc_label~.,ncol=5) +
    theme_bw() +
    theme(#plot.margin = margin(1, 1, 1, 1, "cm"),
      legend.position='bottom',
      legend.box="horizontal",
      legend.direction='horizontal',
      legend.title = element_text(size = 10),
      legend.text = element_text(size = 10),
      legend.text.align = 0,
      legend.justification=c(0,0),
      plot.title = element_text(size = 10, face = "bold"),
      axis.text.x=element_text(angle=60, vjust = 0.9, hjust=1),
      axis.title.x = element_blank(),
      panel.grid.major = element_blank(),
      panel.grid.minor = element_blank(),
      panel.background = element_blank(),
      strip.background = element_blank()) +
    guides(col = guide_legend(ncol=2, byrow = TRUE, direction='vertical', title.position='top',order=1),
           fill = guide_colourbar(barheight = 0.5, barwidth = 10, direction='horizontal',title.position='top',order=2))
  if(plot_rebound_date){
    p = p+   geom_vline(data=rebound_date, aes(xintercept=rebound_date),color = "red")
  }
  h <- ceiling(length(unique(Rt_byage_less_than_one$loc))/5)

  ggsave(paste0(outfile.base,'-plot_Rt_less_than_one.png'),p, width = 5*1.7, height = h * 1.1 + 1, limitsize = FALSE)
}


### Cross-validation plot
## author: Ying-Jung Deweese
## Date: 2017-09-10

### load library
library(purrr)
library(ggplot2)
library(reshape)

## Read data
A=read.csv("CV_plot.csv",header=T)

## plot boxplot

boxplot(MCE~Methods,data=A,xlab=expression(bold("Method")),ylab=expression(bold("MCE")),font.axis=2,las=1,lwd=2,cex.axis = 1.2)
boxplot(Bias~Methods,data=A,xlab=expression(bold("Method")),ylab=expression(bold("Bias")),font.axis=2,las=1,lwd=2,cex.axis = 1.2)
boxplot(MAE~Methods,data=A,xlab=expression(bold("Method")),ylab=expression(bold("MAE")),font.axis=2,las=1,lwd=2,cex.axis = 1.2)
boxplot(RSE~Methods,data=A,xlab=expression(bold("Method")),ylab=expression(bold("RSE")),font.axis=2,las=1,lwd=2,cex.axis = 1.2)
boxplot(RMSE~Methods,data=A,xlab=expression(bold("Method")),ylab=expression(bold("RMSE")),font.axis=2,las=1,lwd=2,cex.axis = 1.2)

# size: 600*500


collapse.unlabelled.singleton <- function(tree){
  if(!is.rooted(tree))
    stop("tree must be rooted")

  if(!is.null(tree$edge.length))
    stop("tree must not have edge length")

  # Solve bug reading newick in phytools 0.6
  if(tree$Nnode > length(tree$node.label))
    tree$node.label <- c(tree$node.label, rep('', tree$Nnode - length(tree$node.label)))

  # number of tips
  not <- length(tree$tip.label)

  edge <- tree$edge

  # unlabelled nodes
  un <- which(tree$node.label %in% '') + not

  # descendants number of unlabelled node
  dnoun <- sapply(un, function(x,y){length(y[y[ ,1] %in% x,1])}, y = edge)

  if(sum(dnoun == 1) > 0){
    # node to drop
    ntd <- un[dnoun == 1]

    # node to tip
    ntt <- edge[edge[ ,2] %in% (1:not),1]
    # common node to tip
    cntt <- edge[edge[ ,2] %in% ntt,1]

    newedge <- edge

    # relink nodes
    for(i in ntd){
      nn <- newedge[newedge[ ,1] %in% i,2]
      newedge <- newedge[!(newedge[ ,1] %in% i), ]
      newedge[newedge[ ,2] %in% i,2] <- nn
    }

    # relink root node
    root <- not + 1
    rd <- newedge[newedge[ ,1] == root,2]
    if(length(rd) == 1){
      if(rd %in% un){
        newedge <- newedge[newedge[ ,1] != root, ]
        newedge[newedge[ ,1] %in% rd,1] <- root
      }
    }

    # New nodes positions
    newn <- matrix(NA, nrow = tree$Nnode, ncol = 2,
                   dimnames = list(1:tree$Nnode, c('nodes', 'new')))
    newn [ ,1] <- 1:tree$Nnode + not
    newn <- newn[!(newn[ ,1] %in% ntd), ]
    newn [ ,2] <- rank(newn[ ,1]) + not

    # Reference table to new nodes positions
    refedge <- rbind(newn, matrix(rep(1:not, each = 2), ncol = 2, byrow = TRUE))
    newedge[ ,1] <- refedge[match(newedge[ ,1], refedge[ ,1]) ,2]
    newedge[ ,2] <- refedge[match(newedge[ ,2], refedge[ ,1]) ,2]

    # update tree
    tree$edge <- newedge
    tree$node.label <- tree$node.label[-(ntd - not)]
    tree$Nnode <- tree$Nnode - length(ntd)
  }

  return(tree)
}


#' mph2knots
#'
#' Conversion speed in  miles per hour to knots per second.
#'
#' @param mph numeric  Speed miles per hour.
#' @return knots per second
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  mph2knots
#'
#' @export
#'
#'
#'
#'

mph2knots=function(mph) {
                         ct$assign("mph", as.array(mph))
                         ct$eval("var res=[]; for(var i=0, len=mph.length; i < len; i++){ res[i]=mph2knots(mph[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


REBOL [
    Title: "CRC-32"
    Date: 6-Apr-2006
    Version: 1.1.0
    File: %crc32.r
    Author: "Vincent Ecuyer"
    Purpose: "CRC32 checksum function"
    Usage: {
        Calculates a 32 bits cyclic redundancy code as used
        in gzip/pkzip/etc.

        Returns a binary:
        >> crc-32 "a string"
        == #{99A255DA}

        >> crc-32 #{112233445566}
        == #{345913D6}

        or an integer:
        >> crc-32/integer "a string"
        == -1717414438

        To compute the checksum part by part:
        >> crc-32 "a str"
        == #{61AD7C35}
        >> crc-32/continue "ing" #{61AD7C35}
        == #{99A255DA}

        >> crc-32/continue data none
        is a synonym of:
        >> crc-32 data

        Usage of /continue in a loop:
        ; initial crc
        crc: none
        until [
            ...
            ; a new crc is computed from the previous one and the new data
            crc: crc-32/continue data-part crc
            ...
        ]
        ; at the end of this loop, 'crc holds the crc-32 of the whole data

        The /direct mode, with a specified buffer size,
        works directly on files (useful for big files):
        ; calculates the checksum of a remote file with a 64 kb buffer
        >> crc-32/direct ftp://192.168.1.33/rebol.exe 64 * 1024
        == #{67AD9CF6}

        Note: In the case of a file access error, connection timeout, or an
        execution halted by the user, the opened file can still be locked.
        Any new invocation of 'crc-32 will release (close) the file and clear
        the internal buffer. Example:
        >> crc-32 ""
    }
    Comment: {
        Contains a precalculated table for speedup.

        REBOL VM isn't really suited for fast bitwise operations, so this
        code is quite slow. If the rebcode VM is available, it's used to
        achieve a more usable speed (between checksum/method 'md5 and
        checksum/method 'sha1).
    }

    Library: [
        level: 'advanced
        platform: 'all
        type: [module function rebcode]
        domain: [math security]
        tested-under: [
            core 2.6.2.3.1 on [Win2K]
            view 1.3.2.3.1 on [Win2K]
            view 1.3.61.3.1 on [Win2K]
            base 2.5.4.3.1 on [Win2K]
            view 1.2.1.1.1 on [AmigaOS30]
            core 2.5.0.1.1 on [AmigaOS30]
        ]
        support: none
        license: 'bsd
        see-also: %rebzip.r
    ]
    History: [
        1.0.0 26-3-2006
            "First published version"
        1.1.0 6-4-2006
            "/direct mode, /continue and /integer added"
    ]
]
ctx-crc-32: context [
    crc-long: [
                 0   1996959894  -301047508 -1727442502   124634137  1886057615
        -379345611  -1637575261   249268274  2044508324  -522852066 -1747789432
         162941995   2125561021  -407360249 -1866523247   498536548  1789927666
        -205950648  -2067906082   450548861  1843258603  -187386543 -2083289657
         325883990   1684777152   -43845254 -1973040660   335633487  1661365465
         -99664541  -1928851979   997073096  1281953886  -715111964 -1570279054
        1006888145   1258607687  -770865667 -1526024853   901097722  1119000684
        -608450090  -1396901568   853044451  1172266101  -589951537 -1412350631
         651767980   1373503546  -925412992 -1076862698   565507253  1454621731
        -809855591  -1195530993   671266974  1594198024  -972236366 -1324619484
         795835527   1483230225 -1050600021 -1234817731  1994146192    31158534
       -1731059524   -271249366  1907459465   112637215 -1614814043  -390540237
        2013776290    251722036 -1777751922  -519137256  2137656763   141376813
       -1855689577   -429695999  1802195444   476864866 -2056965928  -228458418
        1812370925    453092731 -2113342271  -183516073  1706088902   314042704
       -1950435094    -54949764  1658658271   366619977 -1932296973   -69972891
        1303535960    984961486 -1547960204  -725929758  1256170817  1037604311
       -1529756563   -740887301  1131014506   879679996 -1385723834  -631195440
        1141124467    855842277 -1442165665  -586318647  1342533948   654459306
       -1106571248   -921952122  1466479909   544179635 -1184443383  -832445281
        1591671054    702138776 -1328506846  -942167884  1504918807   783551873
       -1212326853  -1061524307  -306674912 -1698712650    62317068  1957810842
        -355121351  -1647151185    81470997  1943803523  -480048366 -1805370492
         225274430   2053790376  -468791541 -1828061283   167816743  2097651377
        -267414716  -2029476910   503444072  1762050814  -144550051 -2140837941
         426522225   1852507879   -19653770 -1982649376   282753626  1742555852
        -105259153  -1900089351   397917763  1622183637  -690576408 -1580100738
         953729732   1340076626  -776247311 -1497606297  1068828381  1219638859
        -670225446  -1358292148   906185462  1090812512  -547295293 -1469587627
         829329135   1181335161  -882789492 -1134132454   628085408  1382605366
        -871598187  -1156888829   570562233  1426400815  -977650754 -1296233688
         733239954   1555261956 -1026031705 -1244606671   752459403  1541320221
       -1687895376   -328994266  1969922972    40735498 -1677130071  -351390145
        1913087877     83908371 -1782625662  -491226604  2075208622   213261112
       -1831694693   -438977011  2094854071   198958881 -2032938284  -237706686
        1759359992    534414190 -2118248755  -155638181  1873836001   414664567
       -2012718362    -15766928  1711684554   285281116 -1889165569  -127750551
        1634467795    376229701 -1609899400  -686959890  1308918612   956543938
       -1486412191   -799009033  1231636301  1047427035 -1362007478  -640263460
        1088359270    936918000 -1447252397  -558129467  1202900863   817233897
       -1111625188   -893730166  1404277552   615818150 -1160759803  -841546093
        1423857449    601450431 -1285129682 -1000256840  1567103746   711928724
       -1274298825  -1022587231  1510334235   755167117
    ]

    right-shift-8: func [
        "Right-shifts the value by 8 bits and returns it."
        value [integer!] "The value to shift"
    ][
        either negative? value [
            -1 xor value and -256 / 256 xor -1 and 16777215
        ][
            -256 and value / 256
        ]
    ]

    update-crc: either value? 'rebcode [
        rebcode [
            "Returns the data crc."
            data [any-string!] "Data to checksum"
            crc [integer!] "Initial value"
            /local char i
        ][
            tail? data
                iff [
                    until [
                        pick char data 1
                        set.i i crc
                        xor i char
                        and i 255
                        lsr crc 8
                        pickz i crc-long i
                        xor crc i
                        next data
                        tail? data
                    ]
                ]
                return crc
        ]
    ][
        func [
            "Returns the data crc."
            data [any-string!] "Data to checksum"
            crc [integer!] "Initial value"
        ][
            foreach char data [
                 crc: (right-shift-8 crc) xor pick crc-long crc and 255 xor char + 1
            ]
            crc
        ]
    ]

    any-file?: func [
        "Returns TRUE for file and url values." value [any-type!]
    ][any [file? value url? value]]

    file: none
    buffer: none

    set 'crc-32 func [
        "Returns a CRC32 checksum."
        source [binary! string! file! url!] "Data or file to checksum"
        /direct "For file! and url! sources, uses /direct mode"
            buffer-size [integer!] "Buffer size (in bytes)"
        /integer "Returns an integer! instead of a binary!"
        /continue "Continues a checksum with more data"
            crc [integer! binary! none!] "Previous CRC32 value."
    ][
        crc: -1 xor to-integer any [crc 0]
        if file   [error? try [close file  ] file:   none]
        if buffer [error? try [clear buffer] buffer: none]
        either all [direct any-file? source] [
            file: source: open/direct/read/binary source
            buffer: make binary! buffer-size
            until [
                clear buffer
                read-io source buffer buffer-size
                crc: update-crc buffer crc
                wait 0.002
                zero? length? buffer
            ]
            clear buffer
            close source
            buffer: file: source: none
        ][
            if any-file? source [source: read/binary source]
            crc: update-crc source crc
            source: none
        ]
        either integer [-1 xor crc][
            load join "#{" [to-hex -1 xor crc "}"]
        ]
    ]
]

; Verification
either #{CBF43926} <> crc-32 "123456789" [
    make error! "Test failed - CRC-32 doesn't work with this VM."
][true]


################################################################################
# The study of Leeds crimes in space and time
# University of Sheffield
# MSc Data Science
# Registration No: 180234862
# Item page: https://github.com/bobleer/Leeds_crime_study
################################################################################

library("tidyverse")
library("dplyr")
library("grid")
library("gridExtra")
library("leaflet")
library("rgdal")
library("tmap")
library("ggcorrplot")
library("ggmap")
library("ggplot2")
library("cowplot")
library("zoo")

options(scipen = 200)

################################################################################
# Show all crime data in the UK (The huge data need a ton of RAM.)
################################################################################

#Set file directory
all_crimes_dir <- "./all-street/"
#Traversal
all_crimes_csv <-
  list.files(
    path = all_crimes_dir,
    pattern = "*.csv",
    recursive = TRUE,
    all.files = TRUE,
    full.names = TRUE
  )
#Set output filename
all_combined_filename <- "[Combined]all-street_crimes.csv"
#First apply read.csv, then rbind
read_all_csv <- lapply(all_crimes_csv,
                       function(x)
                         read.csv(x, stringsAsFactors = F, header = T))
#Output combined csv
all_crimes_path <- paste0(all_crimes_dir, all_combined_filename)
#Save combined csv
do.call(rbind, read_all_csv) %>%
  write.csv(all_crimes_path)
#Read combined csv
all_combined_crimes <- read.csv(all_crimes_path, header = TRUE)
#Sum by month
all_crimes_by_month <-
  all_combined_crimes %>% group_by(Month) %>% summarise(crime_sum = n())

ggplot() +
  geom_point(
    aes(x = as.Date(as.yearmon(Month)),
        y = crime_sum),
    size = all_crimes_by_month$crime_sum / 60000,
    color = "#999999",
    data = all_crimes_by_month
  ) +
  geom_smooth(
    aes(x = as.Date(as.yearmon(Month)),
        y = crime_sum),
    data = all_crimes_by_month,
    method = lm,
    size = 0.7,
    color = "#ffffff",
    fill = "#FF635C",
    se = TRUE
  ) +
  geom_hline(
    yintercept = max(all_crimes_by_month$crime_sum),
    color = "#eeeeee",
    size = 1,
    alpha = 0.5,
    linetype = "dashed"
  ) +
  ggtitle("The trend of crimes in the UK") +
  scale_x_date(
    date_labels = "%Y-%m",
    date_breaks = "3 months",
    date_minor_breaks = "1 months"
  ) +
  xlab("Month (over 36 months)") +
  ylab("The number of crimes") +
  theme(
    plot.title = element_text(
      size = 16,
      color = "#ffffff",
      hjust = 0,
      face = "bold"
    ),
    axis.title = element_text(
      size = 14,
      color = "#888888",
      hjust = 0.5,
      face = "bold"
    ),
    axis.text.x = element_text(
      size = 12,
      color = "#ffffff",
      hjust = 0.5,
      angle = 45,
      face = "bold"
    ),
    axis.text.y = element_text(
      size = 12,
      angle = 45,
      face = "bold",
      color = "#ffffff"
    ),
    plot.background = element_rect(fill = "#2E2E2E",
                                   color = NA),
    plot.margin = unit(c(0.4, 0.4, 0.4, 0.4), "inches"),
    panel.background = element_rect(fill = "#5E5E5E"),
    panel.grid = element_line(color = "#888888"),
    panel.grid.minor = element_line(color = "#727272")
  )

leaflet(all_combined_crimes) %>% addTiles() %>%
  addMarkers(clusterOptions = markerClusterOptions())

################################################################################
# Read West Yorkshire crime data and combine with Leeds LSOA data
################################################################################

leedsShape <-
  readOGR(dsn = "./leeds_lsoa", layer = "england_lsoa_2011")

deprivation2015 <-
  read.csv("./Deprivation2015.csv",
           header = TRUE)

deprivation2015_sl <- deprivation2015 %>%
  select(
    LSOA.name..2011.,
    LSOA.code..2011.,
    Total.population..mid.2012..excluding.prisoners.,
    Income.Score..rate.,
    Employment.Score..rate.,
    Education..Skills.and.Training.Score,
    Living.Environment.Score,
    Crime.Score
  )

names(deprivation2015_sl)[names(deprivation2015_sl) == "LSOA.name..2011."] <-
  "LSOA_name"
names(deprivation2015_sl)[names(deprivation2015_sl) == "LSOA.code..2011."] <-
  "LSOA_code"
names(deprivation2015_sl)[names(deprivation2015_sl) == "Total.population..mid.2012..excluding.prisoners."] <-
  "Total_population"
names(deprivation2015_sl)[names(deprivation2015_sl) == "Income.Score..rate."] <-
  "Income"
names(deprivation2015_sl)[names(deprivation2015_sl) == "Employment.Score..rate."] <-
  "Employment"
names(deprivation2015_sl)[names(deprivation2015_sl) == "Education..Skills.and.Training.Score"] <-
  "Education"
names(deprivation2015_sl)[names(deprivation2015_sl) == "Living.Environment.Score"] <-
  "Living_ENV"
names(deprivation2015_sl)[names(deprivation2015_sl) == "Crime.Score"] <-
  "Crime_Score"

leedsShape@data <- left_join(leedsShape@data,
                             deprivation2015_sl,
                             by = c('code' = 'LSOA_code'))

transformed_leedsShape <- spTransform(leedsShape,
                                      CRS(
                                        "+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0"
                                      ))

tmap_mode("view")

tm_shape(leedsShape) + tm_borders(lwd = 2, alpha = 0.5, col = "#666666") + tm_basemap(leaflet::providers$OpenMapSurfer.Roads)

leeds_pop_map <- tm_shape(leedsShape) +
  tm_fill(
    "Total_population",
    alpha = 0.7,
    style = "kmeans",
    title = "Population@Leeds"
  ) +
  tm_borders(alpha = 0.5, col = "#eeeeee") +
  tm_view(view.legend.position = c("right", "bottom")) +
  tm_basemap(leaflet::providers$OpenMapSurfer.Roads)

leeds_pop_map

leeds_income_map <- tm_shape(leedsShape) +
  tm_fill("Income",
          alpha = 0.7,
          style = "kmeans",
          title = "Income@Leeds") +
  tm_borders(alpha = 0.5, col = "#eeeeee") +
  tm_view(view.legend.position = c("right", "bottom")) +
  tm_basemap(leaflet::providers$OpenMapSurfer.Roads)

leeds_income_map

leeds_employment_map <- tm_shape(leedsShape) +
  tm_fill("Employment",
          alpha = 0.7,
          style = "kmeans",
          title = "Employment@Leeds") +
  tm_borders(alpha = 0.5, col = "#eeeeee") +
  tm_view(view.legend.position = c("right", "bottom")) +
  tm_basemap(leaflet::providers$OpenMapSurfer.Roads)

leeds_employment_map

leeds_education_map <- tm_shape(leedsShape) +
  tm_fill("Education",
          alpha = 0.7,
          style = "kmeans",
          title = "Education@Leeds") +
  tm_borders(alpha = 0.5, col = "#eeeeee") +
  tm_view(view.legend.position = c("right", "bottom")) +
  tm_basemap(leaflet::providers$OpenMapSurfer.Roads)

leeds_education_map

leeds_living_map <- tm_shape(leedsShape) +
  tm_fill("Living_ENV",
          alpha = 0.7,
          style = "kmeans",
          title = "Living Environment
@Leeds") +
  tm_borders(alpha = 0.5, col = "#eeeeee") +
  tm_view(view.legend.position = c("right", "bottom")) +
  tm_basemap(leaflet::providers$OpenMapSurfer.Roads)

leeds_living_map

################################################################################
# Merge all 36 months data from West Yorkshire Police
################################################################################

#Set file directory
crimes_dir = "./west-yorkshire-street_crimes/"
crimes_csv <-
  list.files(path = crimes_dir,
             pattern = "*.csv",
             full.names = TRUE)
#Set output filename
combined_filename = "[Combined]west-yorkshire-street_crimes.csv"
#First apply read.csv, then rbind
read_all_csv <- lapply(crimes_csv,
                       function(x)
                         read.csv(x, stringsAsFactors = F, header = T))
#Save combined csv
do.call(rbind, read_all_csv) %>%
  write.csv(paste0(crimes_dir, combined_filename))

################################################################################
# Visualise Leeds crime data by LSOA
################################################################################

combined_crimes <-
  read.csv(paste0(crimes_dir, combined_filename), header = TRUE)

numCrimesByLSOA <- combined_crimes %>%
  select(LSOA.code, Crime.ID) %>%
  group_by(LSOA.code) %>%
  summarise(Num_crimes = n())

leedsShape@data <- left_join(leedsShape@data,
                             numCrimesByLSOA,
                             by = c('code' = 'LSOA.code'))
leedsShape@data[is.na(leedsShape@data$Num_crimes)] <- 0

tmap_mode("view")
leeds_crime_map <- tm_shape(leedsShape) +
  tm_fill("Num_crimes",
          alpha = 0.7,
          style = "kmeans",
          title = "Crimes@Leeds
Over past 36 months") +
  tm_borders(alpha = 0.5, col = "#eeeeee") +
  tm_view(view.legend.position = c("right", "bottom")) +
  tm_basemap(leaflet::providers$OpenMapSurfer.Roads)

leeds_crime_map

################################################################################
# Correlation among the crime and other social elements
################################################################################

nation_data <- deprivation2015_sl %>%
  select(LSOA_name,
         Total_population,
         Income,
         Employment,
         Education,
         Living_ENV,
         Crime_Score)
rownames(nation_data) <- nation_data[, 1]
nation_data <- nation_data[, -1]
nation_p.mat <- cor_pmat(nation_data)
cor_nation <- cor(nation_data)

leeds_data_by_nation <- leedsShape@data %>%
  select(LSOA_name,
         Total_population,
         Income,
         Employment,
         Education,
         Living_ENV,
         Crime_Score)
rownames(leeds_data_by_nation) <- leeds_data_by_nation[, 1]
leeds_data_by_nation <- leeds_data_by_nation[, -1]
leeds_by_nation_p.mat <- cor_pmat(leeds_data_by_nation)
cor_leeds_by_nation <- cor(leeds_data_by_nation)

leeds_data <- leedsShape@data %>%
  select(LSOA_name,
         Total_population,
         Income,
         Employment,
         Education,
         Living_ENV,
         Num_crimes)
rownames(leeds_data) <- leeds_data[, 1]
leeds_data <- leeds_data[, -1]
leeds_p.mat <- cor_pmat(leeds_data)
cor_leeds <- cor(leeds_data)

ggcorrplot(
  title = "The UK crimes p-value significance",
  cor_nation,
  method = "square",
  outline.color = "white",
  type = "full",
  ggtheme = ggplot2::theme_get,
  lab = TRUE,
  lab_size = 6,
  tl.srt = 45,
  pch.cex = 24,
  p.mat = nation_p.mat,
  colors = c("#6D9EC1", "white", "#E46726")
) + theme(text = element_text(face = "bold"))

ggcorrplot(
  title = "Leeds crimes p-value significance (Data from deprivation2015)",
  cor_leeds_by_nation,
  method = "square",
  outline.color = "white",
  type = "full",
  ggtheme = ggplot2::theme_get,
  lab = TRUE,
  lab_size = 6,
  tl.srt = 45,
  pch.cex = 24,
  p.mat = leeds_by_nation_p.mat,
  colors = c("#6D9EC1", "white", "#E46726")
) + theme(text = element_text(face = "bold"))

ggcorrplot(
  title = "Leeds crimes p-value significance",
  cor_leeds,
  method = "square",
  outline.color = "white",
  type = "full",
  ggtheme = ggplot2::theme_get,
  lab = TRUE,
  lab_size = 6,
  tl.srt = 45,
  pch.cex = 24,
  p.mat = leeds_p.mat,
  colors = c("#6D9EC1", "white", "#E46726")
) + theme(text = element_text(face = "bold"))

numCrimesbyLSOA <- combined_crimes %>%
  select(Month, Crime.type, LSOA.code) %>%
  group_by(Month, Crime.type, LSOA.code) %>%
  na.omit() %>%
  summarise(Num_crimes = n())

leedsShape <-
  readOGR(dsn = "./leeds_lsoa", layer = "england_lsoa_2011")

numCrimesbyType <- left_join(leedsShape@data,
                             numCrimesbyLSOA,
                             by = c('code' = 'LSOA.code')) %>%
  group_by(Month, Crime.type) %>%
  summarise(crime_sum = sum(Num_crimes))

numCrimesbyMonth <- numCrimesbyType %>%
  select(Month, crime_sum) %>%
  group_by(Month) %>%
  summarise(crime_sum = sum(crime_sum))

dataset_path <- "./Leeds_City_Council_Spending/"

leeds_council_dataset <- list.files(path = dataset_path,
                                    pattern = "*.csv",
                                    full.names = TRUE)

read_all_csv <- lapply(leeds_council_dataset,
                       function(x)
                         read.csv(x, stringsAsFactors = F, header = T))
combined = ''
for (leeds_council_month in leeds_council_dataset) {
  single_month_data <- read.csv(leeds_council_month, header = TRUE)
  combining <-
    select(single_month_data, Effective.Date, Amount)[which(single_month_data$Benificiary.Name == "P & Cc For West Yorkshire"),]
  combined <- rbind(combined, combining)
}

leeds_council_spending <- combined %>%
  group_by(Effective.Date) %>%
  summarise(Amount_sum = sum(as.numeric(Amount))) %>%
  na.omit()

leeds_council_spending <-
  leeds_council_spending[order(as.Date(leeds_council_spending$Effective.Date, format = "%d/%m/%Y")),]

crime_and_spending <-
  cbind(numCrimesbyMonth, leeds_council_spending)[-3]
rownames(crime_and_spending) <- crime_and_spending[, 1]
crime_and_spending <- crime_and_spending[, -1]
cor(crime_and_spending)
summary(lm(formula = crime_sum ~ Amount_sum, data = crime_and_spending))

ggplot(data = crime_and_spending,
       aes(x = crime_sum,
           y = as.integer(Amount_sum))) +
  geom_point(size = 4.5,
             color = "#999999") +
  geom_smooth(
    method = lm,
    size = 0.7,
    color = "#ffffff",
    fill = "#2469FF",
    se = TRUE
  ) +
  ggtitle("The correlation between the number of crimes and the amount of police in Leeds") +
  xlab("The number of crimes@Leeds (over past 36 months)") +
  ylab("The amount of spending@West Yorkshire Police") +
  theme(
    plot.title = element_text(
      size = 16,
      color = "#ffffff",
      hjust = 0,
      face = "bold"
    ),
    axis.title = element_text(
      size = 14,
      color = "#888888",
      hjust = 0.5,
      face = "bold"
    ),
    axis.text.x = element_text(
      size = 12,
      color = "#ffffff",
      hjust = 0.5,
      angle = 45,
      face = "bold"
    ),
    axis.text.y = element_text(
      size = 12,
      angle = 45,
      face = "bold",
      color = "#ffffff"
    ),
    plot.background = element_rect(fill = "#2E2E2E",
                                   color = NA),
    plot.margin = unit(c(0.4, 0.4, 0.4, 0.4), "inches"),
    panel.background = element_rect(fill = "#5E5E5E"),
    panel.grid = element_line(color = "#888888"),
    panel.grid.minor = element_line(color = "#727272")
  )

################################################################################
# Visualise Leeds crime data by month
################################################################################

crimes_csv <-
  list.files(path = crimes_dir,
             pattern = "*.csv",
             full.names = TRUE)
# remove combined csv
crimes_csv <-
  crimes_csv[-(grep(pattern = "Combined", x = crimes_csv))]

for (single_month in crimes_csv) {
  crimes <- read.csv(single_month, header = TRUE)
  crimes_month <- substr(single_month, 33, 39)

  numCrimesByLSOA <- crimes %>%
    select(LSOA.code, Longitude, Latitude, Crime.type) %>%
    group_by(Crime.type, LSOA.code) %>%
    summarise(Num_crimes = n())

  leeds_crimes_location <- left_join(leedsShape@data,
                                     numCrimesByLSOA,
                                     by = c('code' = 'LSOA.code')) %>%
    na.omit()

  crimes_location <- crimes %>%
    select(LSOA.code, Longitude, Latitude, Crime.type)

  leeds_crimes_location <- left_join(leedsShape@data,
                                     crimes_location,
                                     by = c('code' = 'LSOA.code')) %>%
    na.omit()

  plot01 <- qmplot(
    Longitude,
    Latitude,
    data = leeds_crimes_location,
    geom = "blank",
    darken = .7,
    zoom = 12,
    maptype = "toner",
    legend = "bottomright"
  ) +
    stat_density_2d(
      aes(fill = ..level..),
      bins = 50,
      geom = "polygon",
      alpha = .2,
      color = NA
    ) +
    scale_fill_gradient2(
      paste0("Leeds Crimes\nPropensity\n", crimes_month),
      low = "white",
      mid = "yellow",
      high = "red",
      midpoint = 100
    ) +
    theme(
      plot.background = element_rect(fill = "#5E5E5E",
                                     color = "#5E5E5E"),
      panel.background = element_rect(fill = "#5E5E5E",
                                      color = "#5E5E5E")
    )

  crime_colors <- c(
    "Anti-social behaviour" = "#A172FF",
    "Bicycle theft" = "#72A1FF",
    "Burglary" = "#0074D9",
    "Criminal damage and arson" = "#39CCCC",
    "Drugs" = "#1B7B00",
    "Other crime" = "#111111",
    "Other theft" = "#EEEEEE",
    "Possession of weapons" = "#85144b",
    "Public order" = "#F012BE",
    "Robbery" = "#3333cc",
    "Shoplifting" = "#01FF70",
    "Theft from the person" = "#E4FF00",
    "Vehicle crime" = "#FFB800",
    "Violence and sexual offences" = "#FF4136"
  )

  plot02 <- qmplot(
    Longitude,
    Latitude,
    data = leeds_crimes_location,
    geom = "blank",
    darken = .7,
    zoom = 12,
    maptype = "toner",
    legend = "bottomright"
  ) +
    stat_bin2d(
      aes(Longitude, Latitude,
          fill = Crime.type),
      size = 0,
      bins = 150,
      alpha = 1,
      drop = TRUE,
      na.rm = TRUE,
      show.legend = FALSE,
      data = leeds_crimes_location
    ) +
    scale_fill_manual(values = crime_colors) +
    theme(
      plot.background = element_rect(fill = "#5E5E5E",
                                     color = "#5E5E5E"),
      panel.background = element_rect(fill = "#5E5E5E",
                                      color = "#5E5E5E")
    )

  crime_type_sum <- leeds_crimes_location %>%
    select(Crime.type) %>%
    group_by(Crime.type) %>%
    summarise(Num_crimes = n()) %>%
    na.omit()

  crime_type_sum$Percent <- round(crime_type_sum$Num_crimes /
                                    sum(crime_type_sum$Num_crimes) * 100,
                                  2)

  plot03 <- ggplot(crime_type_sum,
                   aes(
                     x = reorder(Crime.type, Num_crimes),
                     y = as.numeric(Num_crimes),
                     fill = Crime.type
                   )) +
    geom_bar(stat = "identity", show.legend = FALSE) +
    geom_text(
      label = paste0(crime_type_sum$Percent, '%'),
      hjust = -0.05,
      color = "#ffffff",
      fontface = "bold"
    ) +
    geom_hline(
      yintercept = max(crime_type_sum$Num_crimes),
      color = "#eeeeee",
      size = 1
    ) +
    scale_fill_manual(values = crime_colors) +
    scale_y_continuous(limits = c(0, max(crime_type_sum$Num_crimes) * 1.05),
                       breaks = sort(c(
                         seq(
                           min(crime_type_sum$Num_crimes),
                           max(crime_type_sum$Num_crimes),
                           length.out = 6
                         ),
                         max(crime_type_sum$Num_crimes)
                       ))) +
    geom_text(
      aes(
        x = 0,
        y = max(crime_type_sum$Num_crimes) * 1.05,
        label = paste0("Leeds Crime Types\n", crimes_month),
        hjust = 1,
        vjust = 0
      ),
      fontface = "bold.italic",
      size = 8,
      color = "#2E2E2E",
      show.legend = FALSE,
      nudge_x = 1.2
    ) +
    coord_flip() +
    labs(x = "", y = "the number of crimes") +
    theme(
      plot.title = element_text(
        size = 12,
        color = "#888888",
        hjust = 0,
        face = "bold"
      ),
      axis.title = element_text(
        size = 11,
        color = "#888888",
        hjust = 0.95,
        face = "bold"
      ),
      axis.text.x = element_text(
        size = 11,
        color = "#ffffff",
        hjust = 0
      ),
      axis.text.y = element_text(size = 11,
                                 color = "#ffffff"),
      plot.background = element_rect(fill = "#2E2E2E",
                                     color = NA),
      panel.background = element_rect(fill = "#5E5E5E"),
      panel.grid = element_line(color = "#888888")
    )

  #ggplot2.multiplot(plot01, plot02, plot03, cols = 3)
  jpeg(
    filename = paste0("./images/", crimes_month, "_leeds_crimes.jpeg"),
    width = 1920,
    height = 580,
    units = "px",
    pointsize = 24,
    bg = "#2E2E2E"
  )
  print(
    cowplot::ggdraw(grid.arrange(plot01, plot02, plot03, ncol = 3)) +
      theme(
        plot.background = element_rect(fill = "#5E5E5E",
                                       color = "#5E5E5E"),
        panel.background = element_rect(fill = "#5E5E5E",
                                        color = "#5E5E5E")
      )
  )
  dev.off()

}

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

plot04 <- ggplot() +
  geom_area(aes(
    x = as.Date(as.yearmon(Month)),
    y = crime_sum,
    group = reorder(Crime.type,-crime_sum),
    fill = reorder(Crime.type,-crime_sum)
  ),
  data = numCrimesbyType) +
  geom_point(aes(x = as.Date(as.yearmon(Month)),
                 y = crime_sum),
             color = "#2E2E2E",
             data = numCrimesbyMonth) +
  geom_smooth(
    aes(x = as.Date(as.yearmon(Month)),
        y = crime_sum),
    data = numCrimesbyMonth,
    method = lm,
    size = 0.7,
    color = "white",
    se = TRUE
  ) +
  geom_hline(
    yintercept = max(numCrimesbyMonth$crime_sum),
    color = "#eeeeee",
    size = 1,
    alpha = 0.5,
    linetype = "dashed"
  ) +
  geom_text(
    aes(
      x = as.Date(as.yearmon(Month)),
      y = crime_sum,
      label = crime_sum
    ),
    data = numCrimesbyMonth,
    hjust = 1,
    vjust = 0.5,
    angle = 90,
    color = "#ffffff",
    size = 4
  ) +
  scale_fill_manual(values = crime_colors,
                    name = "Leeds crime types") +
  scale_x_date(
    date_labels = "%Y-%m",
    date_breaks = "3 months",
    date_minor_breaks = "1 months"
  ) +
  xlab("Month (over 36 months)") +
  ylab("The number of crime") +
  theme(
    plot.title = element_text(
      size = 12,
      color = "#888888",
      hjust = 0,
      face = "bold"
    ),
    axis.title = element_text(
      size = 12,
      color = "#888888",
      hjust = 0.5,
      face = "bold"
    ),
    axis.text.x = element_text(
      size = 12,
      color = "#ffffff",
      hjust = 0.5,
      angle = 45,
      face = "bold"
    ),
    axis.text.y = element_text(
      size = 12,
      angle = 45,
      face = "bold",
      color = "#ffffff"
    ),
    legend.title = element_text(size = 12,
                                hjust = 0,
                                face = "bold"),
    legend.text = element_text(#size = 12,
      hjust = 0,
      face = "bold"),
    plot.background = element_rect(fill = "#2E2E2E",
                                   color = NA),
    plot.margin = unit(c(0.4, 0.4, 0.4, 0.4), "inches"),
    panel.background = element_rect(fill = "#5E5E5E"),
    panel.grid = element_line(color = "#888888"),
    panel.grid.minor = element_line(color = "#727272")
  )

plot05 <-
  ggplot(
    numCrimesbyType,
    aes(
      x = as.Date(as.yearmon(Month)),
      y = crime_sum,
      group = reorder(Crime.type,-crime_sum),
      fill = reorder(Crime.type,-crime_sum),
      color = reorder(Crime.type,-crime_sum)
    )
  ) +
  geom_point(show.legend = FALSE) +
  geom_smooth(
    method = lm,
    color = "white",
    size = 0.7,
    show.legend = FALSE
  ) +
  facet_wrap( ~ reorder(Crime.type,-crime_sum),
              scales = "free",
              ncol = 2) +
  scale_discrete_manual(aesthetics = c("colour", "fill"),
                        values = crime_colors) +
  xlab("") +
  ylab("") +
  theme(
    axis.text.x = element_text(
      color = "#ffffff",
      hjust = 0,
      face = "bold"
    ),
    axis.text.y = element_text(face = "bold",
                               color = "#ffffff"),
    plot.background = element_rect(fill = "#2E2E2E",
                                   color = NA),
    plot.margin = unit(c(0.4, 0.4, 0.4, 0.4), "inches"),
    panel.background = element_rect(fill = "#5E5E5E"),
    panel.grid = element_line(color = "#888888"),
    panel.grid.minor = element_line(color = "#727272"),
    strip.background = element_rect(fill = "#242424"),
    strip.text = element_text(color = "#ffffff",
                              face = "bold")
  )

filename = "./images/leeds_crimes_36_months.jpeg"

jpeg(
  filename = filename,
  width = 1919,
  height = 1014,
  units = "px",
  pointsize = 12,
  bg = "#2E2E2E"
)
print(
  cowplot::ggdraw(grid.arrange(
    plot05, plot04, ncol = 2, widths = c(1, 2.5)
  )) +
    theme(
      plot.background = element_rect(fill = "#5E5E5E",
                                     color = "#5E5E5E"),
      panel.background = element_rect(fill = "#5E5E5E",
                                      color = "#5E5E5E")
    )
)
dev.off()


#' Parse input data to fitBM
#'
#' @inheritParams fitBabyMonitor
parseLite = function(minimal_data, num_cat, num_cont,
                            outcome_na = 'remove',
                            cat_na = 'category',
                            cont_na = 'median',
                            unknown_category_code=99){

  minimal_data = as.matrix(minimal_data)

  #Count total records
  N_full = dim(minimal_data)[1]

  #Sort by institution
  minimal_data = minimal_data[order(minimal_data[ ,2]), ]
  if (sum(!complete.cases(minimal_data[ ,2])) > 0){
    stop('Missing values for institution not allowed')}

  #NA outcome variables
  if (outcome_na == 'remove'){ #Remove by default
    minimal_data = minimal_data[complete.cases(minimal_data[ ,1]), ]
  } else if (outcome_na == 'set0'){ #Set to 0
    minimal_data[!complete.cases(minimal_data[ ,1]),1] = 0
  }

  #Categorical risk adjusters
  cat_var_mat = cat_var_locat = NULL
  if (num_cat > 0){
    cat_var_locat = 3:(3 + num_cat - 1)
    #Remove NA categoricals
    if (cat_na == 'remove'){
      minimal_data = minimal_data[
        complete.cases(minimal_data[ ,cat_var_locat]), ]
    }
  }

  #Continuous risk adjusters (set missing values to median)
  imputeFun = function(x){
    if (is.numeric(x)){
      x[!complete.cases(x)] = median(x, na.rm = TRUE)
    }
    return(x)
  }

  cont_var_mat = NULL
  if (num_cont > 0){
    cont_var_locat = (3 + num_cat):(3 + num_cat + num_cont - 1)
    if (cont_na == 'remove'){
      minimal_data = minimal_data[
        complete.cases(minimal_data[ ,cont_var_locat]), ]
    }
    cont_var_mat = as.data.frame(minimal_data[  ,cont_var_locat])
    if (cont_na == 'median'){
      cont_var_mat = cbind(sapply(cont_var_mat, imputeFun))
    }
    colnames(cont_var_mat) = names(minimal_data)[cont_var_locat];
  }
  class(cont_var_mat) <- "numeric"

  #This is done last, after we deal with all NA values
  #Extract categoricals as a matrix and explicitly turn into a factor
  if (num_cat > 0){
    cat_var_mat =as.matrix(minimal_data[  ,cat_var_locat])
    if (cat_na == 'category'){
      cat_var_mat[is.na(cat_var_mat)] = toString(unknown_category_code)
    }
    colnames(cat_var_mat) = names(minimal_data)[cat_var_locat]

    #Explicitly turn each categorical into a factor
    for (i in 1:num_cat){
      cat_var_mat[ ,i] = as.factor(cat_var_mat[ ,i] )
    }
  }

  #Extract variables
  inst_vec = as.factor(minimal_data[ ,2])
  y = as.numeric(minimal_data[ ,1])

  return(list(
    indicator_name = names(minimal_data)[1],
    o_overall = mean(y),
    y = y,
    N_full = N_full,
    N = length(y),
    p = length(unique(inst_vec)),
    inst_vec = inst_vec,
    cat_var_mat = cat_var_mat,
    cont_var_mat = cont_var_mat,
    unique_inst_vec = unique(minimal_data[ ,2])))
}


REBOL []

recycle/torture

f: func [
    a [integer!] "pointer to an integer"
    b [integer!] "pointer to an integer"
][
    i: make struct! compose/deep [
        [raw-memory: (a)]
        int32 i
    ]
    j: make struct! compose/deep [
        [raw-memory: (b)]
        int32 i
    ]
    case [
        i/i = j/i [0]
        i/i < j/i [-1]
        i/i > j/i [1]
     ]
]

cb: make callback! [
    [
		a [pointer]
		b [pointer]
		return: [int32]
    ]
    :f
]

libc: make library! %libc.so.6

x64?: 40 = fifth system/version
size_t: either x64? ['int64]['int32]
qsort: make routine! compose/deep [
    [
        base [pointer]
        nmemb [(size_t)]
		size [(size_t)]
        comp [pointer]
    ]
    (libc) "qsort"
]

array: make vector! [integer! 32 5 [10 8 2 9 5]]
print ["array:" mold array]
qsort array 5 4 (reflect cb 'addr)
print ["array:" mold array] ; [2 5 8 9 10]

close libc


pander_lme_to_latex = function(lme_model_name, save_filename){

  #'  Export an LMER summary table to a LaTex file.
  #'
  #'  Note that this will retain the row index column,
  #'  which will be given a name`neat" in the table.
  #'  This will be need to be manually removed in the
  #'  final `.tex` file.
  #'
  #'  Parameters
  #'  ----------
  #'  lme_model_name : lme4 model
  #'     Model whose output will be cleaned.
  #'
  #'  save_filename : str
  #'     File name for saved LaTex model.
  #'
  #'  Output
  #'  ------
  #'  neat_output : pander table
  #'     Cleaned lme4 model output.

  # load in pander
  require(pander)
  require(Hmisc)
  require(plyr)
  require(dplyr)

  # disable scientific notation
  options(scipen = 999)

  # convert the model summary to a dataframe
  neat_output = data.frame(summary(lme_model_name)$coefficient)

  # round p-values (using Psychological Science's recommendations) for display
  neat_output$p = 2*(1-pnorm(abs(neat_output$t.value)))
  neat_output$p[neat_output$p < .0001] = .0001
  neat_output$p[neat_output$p >= .0001] = round(neat_output$p[neat_output$p >= .0001],4)
  neat_output$p[neat_output$p >= .0005] = round(neat_output$p[neat_output$p >= .0005],3)
  neat_output$p[neat_output$p >= .25] = round(neat_output$p[neat_output$p >= .25],2)

  # round the estimates, standard error, and t-values
  neat_output$"t-value" = round(neat_output$t.value,3)
  neat_output$"Std. Error" = round(neat_output$Std..Error,3)
  neat_output$Estimate = round(neat_output$Estimate,3)

  # create a new column for variable names
  neat_output$Predictor = row.names(neat_output)
  rownames(neat_output) = NULL
  neat_output = neat_output[,c(7,1,6,5,4)]

  # create significance and trending markers
  neat_output$"Sig." = ' '
  neat_output$"Sig."[neat_output$p < .1] = '.'
  neat_output$"Sig."[neat_output$p < .05] = '*'
  neat_output$"Sig."[neat_output$p < .01] = '**'
  neat_output$"Sig."[neat_output$p < .001] = '***'
  neat_output = plyr::rename(neat_output,c("p" = 'p-value'))

  # save to file
  latex(neat_output,file=save_filename,rownamesTexCmd=NULL)

  # return the table
  return(neat_output)
}


#' @export
bib_mmprod = function(x, y)
{
  storage.mode(x) = "double"
  storage.mode(y) = "double"
  .Call("bib_mmprod_", x, y)
}


library(plotly)
data<-read.csv("ElectricCarData_Clean.csv")
fig <- plot_ly(
  data, x = ~Brand, y = ~Range_Km, type='scatter',mode = 'markers',
  # Hover text:
  text = ~paste("RapidCharge: ",RapidCharge, '<br>Price: $',PriceEuro),
  color = ~Brand, size = ~Seats
)
fig


# Imports data from the PWD21 Present Weather Detector at
# Chilbolton Facility for Atmospheric and Radar Research
import_pwd_data <- function(filename, agg=TRUE)
{
  # Open the NetCDF file
  nc = open.ncdf(filename)

  # Get the time
  t = get.var.ncdf(nc, "time")
  # Get the visiblity
  v = get.var.ncdf(nc, "vis_10min")

  close.ncdf(nc)

  # Visibility is provided in metres - we want it in Km.
  v = v/1000

  # Get time as a fraction of the day
  tf = t / max(t)

  # Get date bit from the filename
  date_str = substr(filename, nchar(filename)-10, nchar(filename)-3)

  # Make in to chron object
  tc = chron(date_str, tf, format=c(dates="ymd", times="h:m:s"),out.format=c(dates = "m/d/y", times = "h:m:s"))

  # Convert to zoo object
  z = zoo(v, tc)

  if (agg == TRUE) z = aggregate(z, wholemin, head, 1)

  return(z)
}