## EWAS of schizophrenia
## uses clustered robust regression

library(plm)
library(lmtest)

args<-commandArgs(trailingOnly = TRUE)
source(args[1])

setwd(dataDir)

load(normData)

## remove total samples and cell types with less than 10 samples
pheno<-pheno[which(pheno$Cell.type != "Total"),]
nSample<-table(pheno$Cell.type)
pheno<-pheno[pheno$Cell.type %in% names(nSample[which(nSample > 9)]),]

celltypenormbeta<-celltypenormbeta[,pheno$Basename]

outtab<-matrix(data = NA, ncol = 26, nrow = nrow(celltypenormbeta))
rownames(outtab)<-rownames(celltypenormbeta)
colnames(outtab)<-c("SCZ_coeff", "SCZ_SE", "SCZ_P", "CellType_P", "NeuN_coeff", "NeuN_SE", "NeuN_P", "SOX10_coeff", "SOX10_SE", "SOX10_P", "CellType_SCZ_P", "SCZ_coeff", "SCZ_SE", "SCZ_P", "NeuN_coeff", "NeuN_SE", "NeuN_P", "SOX10_coeff", "SOX10_SE", "SOX10_P", "NeuN_SCZ_coeff", "NeuN_SCZ_SE","NeuN_SCZ_P", "SOX10_SCZ_coeff", "SOX10_SCZ_SE","SOX10_SCZ_P")

for(i in 1:nrow(celltypenormbeta)){

	p.df <- pdata.frame(data.frame("meth" = celltypenormbeta[i,], "phenotype" = pheno$Phenotype, "age" = pheno$CCDNAmAge, "sex" = pheno$Sex, "cell.type" = pheno$Cell.type, "brain.bank" = pheno$Tissue.Centre, "id" = pheno$Indidivual.ID), index = c("id", "cell.type"), drop.index = F)

	pmodel <- plm(meth ~ phenotype + age + sex + cell.type + brain.bank, data = p.df, model = "pooling")
	# compute Stata like df-adjustment
	G <- length(unique(p.df$id))
	N <- length(p.df$id)
	dfa <- (G/(G - 1)) * (N - 1)/pmodel$df.residual

	# display with cluster VCE and df-adjustment
	firm_c_vcov <- dfa * vcovHC(pmodel, type = "HC0", cluster = "group", adjust = T)
	model<-coeftest(pmodel, vcov = firm_c_vcov)

	ctNull<-plm(meth ~ phenotype + age + sex + brain.bank, data = p.df, model = "pooling")
	outtab[i,1:3]<-model["phenotypeControl",c(1,2,4)]
	outtab[i,4]<-waldtest(pmodel, ctNull, vcov = firm_c_vcov, test = "F")[2,4]
	outtab[i,5:7]<-model["cell.typeNeuN +ve",c(1,2,4)]
	outtab[i,8:10]<-model["cell.typeSox10 +ve",c(1,2,4)]

	pmodelInt <- plm(meth ~ phenotype + age + sex + cell.type + brain.bank + phenotype*cell.type, data = p.df, model = "pooling")
	dfa <- (G/(G - 1)) * (N - 1)/pmodelInt$df.residual

	# display with cluster VCE and df-adjustment
	firm_c_vcov <- dfa * vcovHC(pmodelInt, type = "HC0", cluster = "group", adjust = T)
	modelInt<-coeftest(pmodelInt, vcov = firm_c_vcov)

	outtab[i,11]<-waldtest(pmodelInt,pmodel, vcov = firm_c_vcov, test = "F")[2,4]
	outtab[i,12:14]<-modelInt["phenotypeControl",c(1,2,4)]
	outtab[i,15:17]<-modelInt["cell.typeNeuN +ve",c(1,2,4)]
	outtab[i,18:20]<-modelInt["cell.typeSox10 +ve",c(1,2,4)]
	outtab[i,21:23]<-modelInt["phenotypeControl:cell.typeNeuN +ve",c(1,2,4)]
	outtab[i,24:26]<-modelInt["phenotypeControl:cell.typeSox10 +ve",c(1,2,4)]
}

save(outtab, file = "Analysis/Schizophrenia/RobustClusteredErrors.rdata")


# EWAS of left-handedness: adjusted model, NTR children (buccal cells)
# V.Odintsova, J.van Dongen

library(gee)

# Load DNA methylation data
# Load phenotype and covariate data

# Variabels for adjusted model
# familynumber
# sex
# age (age at DNA bloodsampling)
# gestational age
# birth weight
# maternal smoking during pregnancy (0=no, 1=yes)
# Epi (epithelium cells proportion)
# NK (natural killer cells proportion)
# Array_rownum (array rownumber)
# Sample_Plate (sample plate)
# hand01 (left-handedness variable: right-handed = 0, left-handed = 1)

mydata <- data.frame(FamilyNumber, hand01,GA, bweight, matsmok01, age,sex,Sample_Plate,Array_rownum,Epi,NK)  # add your phenotype here

rownames(mydata) <- rownames(covariates)
head(mydata)

mydata <- mydata[which(!is.na(mydata$hand01)),]
mydata <- mydata[which(!is.na(mydata$GA)&!is.na(mydata$bweight)&!is.na(mydata$matsmok01)),]
summary(mydata)
nrow(mydata)

mydata <- mydata[order(mydata$FamilyNumber),]
DNAm  <- DNAm [rownames(mydata),]

# gee model for a continuous outcome (DNA methylation level) correcting for clustering of samples by family

geemodel <- function (data)
{
gee(CpGi~hand01+sex+age+GA+bweight+matsmok01+Epi+NK+Array_rownum+Sample_Plate, data=data, id=FamilyNumber, family=gaussian, corstr="exchangeable", maxiter=100, na.action=na.omit,silent=TRUE)
}

# Testrun for 1 cpg to determine the number of estimates in output
#------------------------------------------------------------------------------------------------------------------------------------------------------
mydata$CpGi <- DNAm [,1]
coeff       <- summary(geemodel(mydata))$coefficients
#------------------------------------------------------------------------------------------------------------------------------------------------------

# Create objects to save the output from gee
#------------------------------------------------------------------------------------------------------------------------------------------------------
Nestimates <-nrow(coeff)
Ncpgs      <-ncol(DNAm )
pval       <-matrix(NA,Ncpgs,Nestimates)
estimate   <-matrix(NA,Ncpgs,Nestimates)
RobustSE   <-matrix(NA,Ncpgs,Nestimates)
RobustZ    <-matrix(NA,Ncpgs,Nestimates)
N          <- matrix(NA,Ncpgs,1)
Ncpgs
Nestimates
#------------------------------------------------------------------------------------------------------------------------------------------------------
# create function to remove outliers from CpGi
iqr.trim<-function(methylation, iqr.limit=3) {
  quantiles <- quantile(methylation, probs = c(0.25, 0.75), na.rm = T)
  iqr <- quantiles[2] - quantiles[1]
  low <- quantiles[1]
  upper <- quantiles[2]
  methylation[which(methylation < low - iqr.limit * iqr)] <- NA
  methylation[which(methylation > upper + iqr.limit * iqr)] <- NA
  methylation
}
# Run geemodel for all CpGs and save output
#------------------------------------------------------------------------------------------------------------------------------------------------------
for (i in 1:Ncpgs)
{
    mydata$CpGi <- iqr.trim(DNAm [,i]) # trimming outliers
N[i,] <- length(which(!is.na(mydata$CpGi)))
coeff <- summary(geemodel(mydata))$coefficients
for (j in 1: Nestimates)
{
estimate[i,j] <- coeff[j,1]
RobustSE[i,j] <- coeff[j,4]
RobustZ[i,j]  <- coeff[j,5]
pval[i,j]     <- 2*pnorm(-abs(coeff[j,5]))
}
}
#------------------------------------------------------------------------------------------------------------------------------------------------------

#------------------------------------------------------------------------------------------------------------------------------------------------------
colnames(estimate)   <- rownames(coeff)
colnames(RobustSE)   <- rownames(coeff)
colnames(RobustZ)    <- rownames(coeff)
colnames(pval)       <- rownames(coeff)
rownames(estimate)   <- colnames(DNAm )
rownames(RobustSE)   <- colnames(DNAm )
rownames(RobustZ)    <- colnames(DNAm )
rownames(pval)       <- colnames(DNAm )
rownames(N)          <- colnames(DNAm )
#------------------------------------------------------------------------------------------------------------------------------------------------------

save(estimate,pval,RobustSE,RobustZ,N, file="EWASresults.RData")


#' @export
#' @rdname stat_summary_2d
#' @inheritParams stat_bin_hex
stat_summary_hex <- function(mapping = NULL, data = NULL,
                             geom = "hex", position = "identity",
                             ...,
                             bins = 30,
                             binwidth = NULL,
                             drop = TRUE,
                             fun = "mean",
                             fun.args = list(),
                             na.rm = FALSE,
                             show.legend = NA,
                             inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = StatSummaryHex,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      bins = bins,
      binwidth = binwidth,
      drop = drop,
      fun = fun,
      fun.args = fun.args,
      na.rm = na.rm,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatSummaryHex <- ggproto("StatSummaryHex", Stat,
  default_aes = aes(fill = after_stat(value)),

  required_aes = c("x", "y", "z"),

  compute_group = function(data, scales, binwidth = NULL, bins = 30, drop = TRUE,
                           fun = "mean", fun.args = list()) {
    try_require("hexbin", "stat_summary_hex")

    binwidth <- binwidth %||% hex_binwidth(bins, scales)
    fun <- as_function(fun)
    hexBinSummarise(data$x, data$y, data$z, binwidth,
      fun = fun, fun.args = fun.args, drop = drop)
  }
)


# Leitura dos arquivos
train <- read.csv("train.csv")
test <- read.csv("test.csv")

# Execução do modelo
m <- lm(Survived ~ SipSp, data = new2_train)
m1<-lm(Survived ~ Pclass+Age, data=new2_train)
m3<-lm(Survived~Pclass + Age + Sex, data=new2_train)
summary(m3)
View(new2_train)
# Previsão dos dados
p<-predict(mod, newdata=test)
test$Sex <- ifelse(test$Sex == "female",as.numeric(1),as.numeric(0))

# Classificação de Survived, através do gatilho 0.5

pr <- ifelse(p<0.5, 0, 1)

# Montagem do dataframe para saída de dados
pr_data <- cbind(test$PassengerId, pr)
pr_data <- as.data.frame(pr_data)

# Nomes das colunas
names(pr_data) <- c("PassengerId", "Survived")

# Gravação em disco do arquivo a ser submetido no site Kaggle
write.csv(pr_data, file="predict.csv", row.names = FALSE)

my_predict <- read.csv("predict.csv")
View(my_predict)
summary(m1)


# GetShockSpan3Server3Seg4Data.r

source("../common/DataUtil.r")
library(ggplot2)
source("../common/PlotUtil.r")

# P A R A M S
nShockspan <- 3
nServerDefaultLife <- 3
nSegments <- 4
nShockImpactMin <- 100
nShockImpactMax <- 100

# S T A N D A R D   P R O C E S S I N G   F O R   S H O C K S
source("../common/shockformat.r")
source("../common/shocktitles.r")

# P L O T   D A T A
gp <- ggplot(data=trows
            , aes(x=shockfreq,y=safe(losspct), color=factor(copies))
            )
gp <- gp + labs(color=sLegendLabel)

gp <- fnPlotLogScales(gp, y="YES"
#                ,xbreaks=c(50,67,75,80,90,100)
                ,xbreaks=c(5000,10000,15000,20000,25000,30000,40000,50000)
                ,ybreaks=c(0.01,0.10,1.00,10,100)
                )
#gp <- gp + scale_x_reverse(breaks=c(50,67,75,80,90,100))
gp <- gp + geom_line(
                  size=3
                , show.legend=TRUE
                )
gp <- gp + geom_point(data=trows
                , size=6
                , show.legend=TRUE
                , color="black"
                )

gp <- gp + theme(legend.position=c(0.15,0.3))
gp <- gp + theme(legend.background=element_rect(fill="lightgray",
                                  size=0.5, linetype="solid"))
gp <- gp + theme(legend.key.size=unit(0.3, "in"))
gp <- gp + theme(legend.key.width=unit(0.6, "in"))
gp <- gp + theme(legend.text=element_text(size=16))
gp <- gp + theme(legend.title=element_text(size=14))
gp <- gp + scale_color_discrete(labels=lLegendItemLabels)

gp <- fnPlotTitles(gp
            , titleline=sTitleLine
            , xlabel=sXLabel
            , ylabel=sYLabel
        )
# Label the percentage lines out on the right side.
xlabelposition <- log10(800)
gp <- fnPlotPercentLine(gp, xloc=xlabelposition)
gp <- fnPlotMilleLine(gp, xloc=xlabelposition)
gp <- fnPlotSubMilleLine(gp, xloc=xlabelposition)

plot(gp)
fnPlotMakeFile(gp, sPlotFile)

# Unwind any remaining sink()s to close output files.
while (sink.number() > 0) {sink()}


################################################################################
# Dependencies
# library("mboost")

MboostGlmboostTrain <- function(train.name="train",target=NULL,args=list(test.name=NULL,R=1,pls=FALSE,
	prune=FALSE,std=FALSE,features=c("static","alsfrs","fvc","svc","vital"),
	slope.features=NULL)) {
	# Trains a MboostGlmboost model given training data.
	# Args:
	#	train.name: base name of training dataset
	#	target: target vector; if NULL, future slopes are used as target
	#	args: list of additional arguments
	#	-test.name: base name of test set, if you want training set to be
	#	 processed using both test and train data
	#	- pls: TRUE means predicting the last score rather than the slope
	#	- prune: TRUE means keeping only features with data for at least 918/2
	#		patients
	#	- std: TRUE means standardize columns by subtracting away column means
	#	- features: a character vector of feature sets to get for the training
	#		data.  Choose from "static","alsfrs","fvc","svc","vital","lab"
	#	- slope.features: a character vector of datasets to get slope features
	#		for.  Choose from NULL if no slopes are desired, or among "static",
	#		"alsfrs","fvc","svc","vital","lab"
	#
	# Returns:
	#	a function that given a test set, returns predictions
	#
	# Side effects:
	#	Saves predictions to file
	#
	# Example usage:
	if(FALSE) {
		features = c("static","alsfrs","fvc","svc","vital")
	   	slope.features = c("alsfrs","fvc","svc","vital")
	   	args=list(test.name="test",R=1,pls=FALSE,prune=TRUE,std=TRUE,
	   		features=features,slope.features=slope.features)
		model <- MboostGlmboostTrain(train.name="train",target=NULL,args=args)
		predictions<-model("test")
	}

	# Preprocess training data according to arguments
	train.preprocess<-PreprocessFeatures(train.name=train.name,test.name=
		args[["test.name"]],args=args)

	# Get training data and target
	train.data<-as.data.frame(train.preprocess$feature.data)
	target<-train.preprocess$target

	# Fit multiple models to training data
	GetModel <- function(i) {
		object<-glmboost(target~.,data.frame(target,train.data[,-1]),
			control = boost_control(mstop = 200))

		# Select optimal number of boosting iterations using CV
		cv.err<-cvrisk(object, folds = cv(model.weights(object),type="kfold"))
		# Set optimal boosting iteration (this looks strange, but it is what it does)
		object[mstop(cv.err)]

		# Report summary results
		print(sprintf("Model: %d, CV error: %g, Best iter: %g",i,sqrt(min(colMeans(cv.err[,]))),mstop(cv.err)))

		# predictions <- predict(object,data.frame(test.data[,-1]))
		# Rmsd(predictions,test.target)

		return(list(object = object))
	}
	models <- lapply(1:args[["R"]], GetModel)

	MboostGlmboostPredict <- function(test.name="test",save.preds=TRUE) {
		# Returns predictions based on the trained model given a test set
		#
		# Args:
		#	test.name: base name of test dataset
		#   save.preds: save predictions to file? TRUE by default
		#
		# Returns:
		#	Two column matrix, ordered by the first column, with first column
		#   "subject.id" containing test set subject ids and the second column
		#   "prediction" containing predicted slopes.
		#
		# Side effects:
		#	Saves predictions to file

		# Preprocess test data according to arguments
		test.preprocess<-PreprocessFeatures(train.name=NULL,test.name=test.name,
			args=args,train.cols=train.preprocess$train.cols,train.data.std=
			train.preprocess$train.data.std,train.data.na=
			train.preprocess$train.data.na)

		test.data<-as.data.frame(test.preprocess$feature.data)

		# Form test predictions
		predictions <- rowMeans(sapply(models, function(model)
			predict(model$object,test.data[,-1])))

		# If predicting last score, transform predictions back to slopes
		if (args[["pls"]]) {
			predictions<-predictions-
				scaling$score.first*scaling$time.scale
		}
		predictions <- cbind(test.data[,1],predictions)

		if(save.preds) {
			# Write predictions to file
			out.file = GetPredictionFilename("MboostGlmboostTrain",train.name,test.name,args)
			WritePredictions(predictions, out.file)
		}
		return(predictions)
	}
	return(MboostGlmboostPredict)
}


#------------------------------
# library
#------------------------------

library(data.table)
library(xgboost)
library(Matrix)
library(magrittr)
library(dtplyr)
library(dplyr, warn.conflicts=FALSE)
library(Rcpp)

#------------------------------
# set seed
#------------------------------

seed <- as.integer(commandArgs(trailingOnly=TRUE)[1])
if(is.na(seed)) seed <- 1000
cat("seed: ", seed, "\n - - - - - - - - - -\n")

set.seed(seed)

#------------------------------
# functions
#------------------------------

sourceCpp("matthews_cc.cpp")

source("load_numeric.r")
source("add_features.r")

#------------------------------
# main
#------------------------------

prj_name <- "submission_pre"
data_dir <- file.path("..", "..", "dataset")
input_dir <- file.path("..", "..", "input")
submission_dir <- file.path("..", "..", "submission", prj_name)

tic <- proc.time()

# train ----------

{} %>%

# load train numeric
load_numeric(dataset="train") %>%

# add features
add_date_features(dataset="train") %>%
add_category_expand(dataset="train") %>%
add_is_duplicated(dataset="train") %>%
add_id_features(dataset="train") %>%

{

	# format data
	cat("==> Format data\n")
	index_valid <- sample(1:nrow(.), as.integer(nrow(.)/10))

	train_label_path <- file.path(data_dir, "train_numeric.csv")
	train_label <- fread(train_label_path, select="Response") %>% use_series(Response)

	valid_label <- train_label[index_valid]
	train_label <- train_label[-index_valid]

	dtrain <- xgb.DMatrix(.[-index_valid,], label=train_label, missing=0)
	dvalid <- xgb.DMatrix(.[index_valid,], label=valid_label, missing=0)

	list(dtrain=dtrain, dvalid=dvalid, train_label=train_label, valid_label=valid_label, colnames=colnames(.))

} %T>% {

	# set parameters
	param <- list(objective = "binary:logistic",
					booster = "gbtree",
					eval_metric = "auc",
					colsample_bytree = 0.752,
					subsample = 0.949,
					eta = 0.013,
					max.depth = 5,
					max_delta_step = 4,
					base_score = 0.332)

	# train model
	cat("==> Train model\n")
	model <<- xgb.train(param=param, data=.$dtrain, nrounds=2875L,
						print.every.n = 20L,
						watchlist=list(train=.$dtrain, valid=.$dvalid))

	importance <- xgb.importance(.$colnames, model=model)
	print(head(importance, 20))

} %>% {

	# predict
	train_pred <- predict(model, .$dtrain)
	valid_pred <- predict(model, .$dvalid)

	thresholds <- quantile(valid_pred, probs=seq(0,1,length=2000))
	global_threshold <<- search_best_threshold(valid_pred, .$valid_label, thresholds)

	# calc scores
	valid_score <<- calc_mcc(valid_pred, .$valid_label, global_threshold)
	train_score <<- calc_mcc(train_pred, .$train_label, global_threshold)
}

gc();gc();

# test ----------

{} %>%

# load test numeric
load_numeric(dataset="test") %>%

# add features
add_date_features(dataset="test") %>%
add_category_expand(dataset="test") %>%
add_is_duplicated(dataset="test") %>%
add_id_features(dataset="test") %>%

# format data
xgb.DMatrix(missing=0) %>%

# predict test label
predict(model, .) %>%
is_greater_than(global_threshold) %>% as.integer %T>%

{
	cat("==> count test_label\n")
	print(table(.))

} %>% {

	# generate submission data
	test_numeric_path <- file.path(data_dir, "test_numeric.csv")
	test_numeric_id <- fread(test_numeric_path, select="Id") %>% use_series(Id)
	submission <- data.frame(Id=test_numeric_id, Response=.)

} %>% {

	# save file
	cat("==> Save submission file\n")
	st <- function(score) return(sprintf("%.3f", score))
	submission_filename <- paste0(prj_name, "_train", st(train_score) ,"_valid", st(valid_score), "_seed", seed, ".csv")

	dir.create(submission_dir, showWarnings=FALSE, recursive=TRUE)
	write.table(., file.path(submission_dir, submission_filename), row.names=FALSE, sep=",")
}

# display computational time
cat("==> Display computational time\n")
proc.time() %>% subtract(tic) %>% print


library(data.table)
library(ggplot2)
library(cowplot)

'%!in%' <- Negate('%in%')

mean_adj <- function(x){
  x <- (x)/mean(x)
  return(x)
}

# load data
load("dataset.RData")

############
## TABLES ##
############

### conflict incidents
summary_combined_dt <- combined_dt[,.(Incidents=sum(z0)),by=.(Crop,Dyad)]
summary_combined_dt <- summary_combined_dt[,.(Dyad,Incidents)]
summary_combined_dt <- unique(summary_combined_dt)

geo_conflict_merge <- merge(distance_dt,summary_combined_dt,by="Dyad")

## Table 1 (note: slight discrepancy due to the omitted 2009 here)
geo_conflict_tab <- geo_conflict_merge[order(-Incidents)]

### prices
summary_dt <- prices_dt[,.(p_mean=round(mean(PRICE_USD_Complete),2),p_sd=round(sd(PRICE_USD_Complete),2),p_min=min(PRICE_USD_Complete),p_max=max(PRICE_USD_Complete)),by=.(Market,Commodity)]

summary_prices_dt <- summary_dt[order(Commodity,Market)]
summary_prices_dt <- summary_prices_dt[Market %in% cities_dt$Market]

## Table 2
average_prices_tab <- dcast(summary_prices_dt,Market~Commodity,value.var="p_mean")

#############
## FIGURES ##
#############

prices_dt$Commodity <- sub(" .+","",prices_dt$Commodity)
prices_dt$Commodity <- factor(prices_dt$Commodity,levels=unique(prices_dt$Commodity)[c(2,1,3)])

gg_prices <- ggplot(prices_dt[Market %!in% c("Hargeisa","Borama","Qorioley")],aes(x=Date,y=PRICE_USD,color=Market,linetype=Market))+
  geom_line(size=.3)+
  facet_grid(. ~ Commodity)+
  labs(x="Year",y="Price (USD/kg)")+
  theme_classic()+
  theme(axis.title = element_text(size=10), axis.text = element_text(size=8),legend.title = element_blank(),legend.text = element_text(size=8),legend.position = "bottom",legend.background = element_rect("transparent"),strip.background = element_rect(fill="transparent",size = NA))

## Figure 2
ggsave("prices.png",gg_prices,width=6.5,height=3.5)

combined_dt$Dyad_long <- paste(combined_dt$Market1,"-",combined_dt$Market2,sep="")

gg_incidents <- ggplot(combined_dt,aes(x=reorder(Dyad_long,-z0),y=z0))+
  geom_boxplot(color="indianred")+
  labs(x="Dyad",y="Monthly Incidents")+
  theme_classic()+
  theme(axis.title=element_text(size=10),axis.text=element_text(size=8),axis.text.x=element_text(angle=45,hjust=1),axis.text.y=element_text(angle=90,hjust=.5))

## Figure A1.a
ggsave("incidents.png",gg_incidents,width=6.5,height=3.5)

combined_dt[,Normalized := mean_adj(z0),by=c("Dyad")]

gg_normalized <- ggplot(combined_dt,aes(x=reorder(Dyad_long,-z0),y=Normalized))+
  geom_boxplot(color="indianred")+
  labs(x="Dyad",y="Monthly Incidents (Normalized)")+
  theme_classic()+
  theme(axis.title=element_text(size=10),axis.text=element_text(size=8),axis.text.x=element_text(angle=45,hjust=1),axis.text.y=element_text(angle=90,hjust=.5))

## Figure A1.b
ggsave("normalized.png",gg_normalized,width=6.5,height=3.5)


# ma_asthma_mcd_data.r
# Author: David Van Riper
# Date: 2020-10-12
#
# This script reads in the Hospitalization data from Massachusetts Department of Health, computes percent diffs between sf and v1/v2, and generates
# box plots and tables.

require(tidyverse)
require(janitor)
require(RColorBrewer)

options(scipen=999)

#### Constants ####
health_data_path <- "data/health_outcomes/"

#### Read in RDS file for MA mcd ####
df <- readRDS("data/df_sa_5year_MA_mcd.rds")

#### Read in Asthma ED visit data ####
ed <- read_csv(paste0(health_data_path, "hospitalization.csv"))

#### Clean field names ####
ed <- clean_names(ed)

#### Keep required fields ####
# only need the MCD data
ed <- ed %>%
  select(geo_description, year, age_group, case_count, census_population, crude_rate, age_adjusted_rate, crude_lower_ci, crude_upper_ci, statistical_difference, stability, supression_flag)

# Modify names of Manchester and Townsend
ed <- ed %>%
  mutate(name = geo_description,
         name = case_when(name == "Manchester" ~ "Manchester-by-the-Sea",
                          name == "Townsend" ~ "send",
                          TRUE ~ name))

#### Assign a gisjoin to each ed record ####
ed  <- ed %>%
  left_join(mcd_name, by = c("name" = "name"))

#### Modify the df_sa_5year df to match age groups in MA ED data ####
# Under 5
# 5 to 14
# 15 to 34
# 35 to 64
# 65+
df <- df %>%
  mutate(ma_age_grp = case_when(age_grp == "0-4" ~ 1,
                                age_grp == "5-9" | age_grp == "10-14" ~ 2,
                                age_grp == "15-19" | age_grp == "20-24" | age_grp == "25-29" | age_grp == "30-34" ~ 3,
                                age_grp == "35-39" | age_grp == "40-44" | age_grp == "45-49" | age_grp == "50-54" | age_grp == "55-59" | age_grp == "60-64" ~ 4,
                                TRUE ~ 5))

df$ma_age_grp <- factor(df$ma_age_grp, labels = c("Under 5 Years", "5 to 14 Years", "15 to 34 Years", "35 to 64 Years", "65 and over"))

#### Collapse df by gisjoin, version, ma_age_grp to get counts ####
df_denom <- df %>%
  group_by(gisjoin, version, ma_age_grp) %>%
  summarise(n = sum(n))

#### Join of ED onto df_denom ####
df_denom_ed <- df_denom %>%
  left_join(ed, by = c("gisjoin" = "gisjoin", "ma_age_grp" = "age_group")) %>%
  filter(!is.na(case_count))

#### Keep required attributes for age adjustment ####
df_denom_ed <- df_denom_ed %>%
  select(gisjoin, name, version, ma_age_grp, n, case_count)

#### Attempt age adjustments ####
# loading standard population from nih for 18 age groups
#https://seer.cancer.gov/stdpopulations/
st.pop2000<-
  read.delim("https://seer.cancer.gov/stdpopulations/stdpop.18ages.txt",
             header=F,colClasses = "character")

st.pop2000<-st.pop2000 %>%
  mutate(st.age.band=as.numeric(str_sub(string=V1, start = 4, end=6)),
         pop=as.numeric(str_sub(string=V1, start = 7, end=14)),
         weight=pop/274633642) %>%
  filter(str_sub(string = V1,start = 1,end = 3)=="204") %>%
  select(st.age.band,pop, weight)

#consolidating age groups to match MA
age_lookup_table<-data.frame(st.age.band=1:18,
                             ma.age.band = c(
                               1,
                               2,2,
                               3,3,3,3,
                               4,4,4,4,4,4,
                               5,5,5,5,5
                             ))

#adding MA age bands to standard pop dataframe
st.pop2000<-left_join(st.pop2000, age_lookup_table,
                      by=c("st.age.band"))

#calculating weights for MA age bands
ma.st.pop2000<-st.pop2000 %>%
  group_by(ma.age.band) %>%
  summarize(weight=sum(weight), pop=sum(pop))

# factor ma.age.band
ma.st.pop2000$ma.age.band <- factor(ma.st.pop2000$ma.age.band, labels = c("Under 5 Years", "5 to 14 Years", "15 to 34 Years", "35 to 64 Years", "65 and over"))

#### Join the ma.st.pop2000 to df_denom_ed ####
df_denom_ed <- df_denom_ed %>%
  left_join(ma.st.pop2000, by = c("ma_age_grp" = "ma.age.band"))

#### compute crude prevalence rates for each age group ####
df_denom_ed <- df_denom_ed %>%
  mutate(crude_rate = case_count / n,
         crute_rate_000s = crude_rate * 1000)

####age adjustment function####
# generate a crude.rate (cases / age group pop for MCD)
# then, multiply that crude.rate by the standard weight for that age group
# do ??????
age.adjust.fun<-function(cases, age.pop, weight, geog.grouping.var, version.grouping.var){

  df<-data.frame(cases, age.pop,
                 crude.rate=cases/age.pop,
                 weight, geog.grouping.var, version.grouping.var)

  df$weight.rate <- df$crude.rate*df$weight

  df<- df %>% group_by(geog.grouping.var, version.grouping.var) %>%
    summarize(age.adjust.rate=sum(weight.rate, na.rm=T),
              crude.rate=sum(cases)/sum(age.pop))

  return(df)
}

####Applying function to MA data####
ma_mcd_adjusted_rate <- age.adjust.fun(cases = df_denom_ed$case_count,
                                age.pop = df_denom_ed$n,
                                weight = df_denom_ed$weight,
                                geog.grouping.var = df_denom_ed$gisjoin,
                                version.grouping.var = df_denom_ed$version)

#### Convert the rates to rate per 10,000 persons ####
ma_mcd_adjusted_rate <- ma_mcd_adjusted_rate %>%
  mutate(age.adjust.rate = age.adjust.rate * 10000,
         crude.rate = crude.rate * 10000)

#### Create a wide df to compute % diffs between sf and v1/v2 ####
ma_mcd_adjusted_rate_wide <- ma_mcd_adjusted_rate %>%
  pivot_wider(id_cols = geog.grouping.var, names_from = version.grouping.var, values_from = age.adjust.rate) %>%
  mutate(sf_denom_abs_perc_diff_sf_v1 = (abs(sf - v1) / (sf)) * 100,
         sf_denom_abs_perc_diff_sf_v2 = (abs(sf - v2) / (sf)) * 100,
         sf_denom_perc_diff_sf_v1 = ((v1 - sf) / (sf)) * 100,
         sf_denom_perc_diff_sf_v2 = ((v2 - sf) / (sf)) * 100,
         abs_perc_diff_sf_v1 = (abs(sf - v1) / ((sf + v1) / 2)) * 100,
         abs_perc_diff_sf_v2 = (abs(sf - v2) / ((sf + v2) / 2)) * 100,
         perc_diff_sf_v1 = ((v1 - sf) / ((sf + v1) / 2)) * 100,
         perc_diff_sf_v2 = ((v2 - sf) / ((sf + v2) / 2)) * 100)

#### Convert the wide df back to a long df ####
ma_mcd_adjusted_perc <- ma_mcd_adjusted_rate_wide %>%
  pivot_longer(cols = sf:perc_diff_sf_v2, names_to = "var", values_to = "value")

#### Join population bins to ma_mcd_adjusted_perc ####
ma_mcd_adjusted_perc <- ma_mcd_adjusted_perc %>%
  left_join(mcd_pop, by = c("geog.grouping.var" = "gisjoin"))

#### Summary stats by pop size bin ####
# absolute percent diffs.
median_ma_mcd_abs_perc <- ma_mcd_adjusted_perc %>%
  filter(var == "abs_perc_diff_sf_v1" | var == "abs_perc_diff_sf_v2") %>%
  group_by(pop_bin, var) %>%
  summarise(Mean = mean(value, na.rm = TRUE),
            SD = sd(value, na.rm = TRUE),
            P25 = quantile(value, 0.25, na.rm = TRUE),
            P50 = median(value, na.rm = TRUE),
            P75 = quantile(value, 0.75, na.rm = TRUE))

# signed percent diffs.
median_ma_mcd_perc <- ma_mcd_adjusted_perc %>%
  filter(var == "perc_diff_sf_v1" | var == "perc_diff_sf_v2") %>%
  group_by(pop_bin, var) %>%
  summarise(Mean = mean(value, na.rm = TRUE),
            SD = sd(value, na.rm = TRUE),
            P25 = quantile(value, 0.25, na.rm = TRUE),
            P50 = median(value, na.rm = TRUE),
            P75 = quantile(value, 0.75, na.rm = TRUE))

# signed percent diffs. using SF as the denominator
median_ma_mcd_perc_sfdenom <- ma_mcd_adjusted_perc %>%
  filter(var == "sf_denom_perc_diff_sf_v1" | var == "sf_denom_perc_diff_sf_v2") %>%
  group_by(pop_bin, var) %>%
  summarise(Mean = mean(value, na.rm = TRUE),
            SD = sd(value, na.rm = TRUE),
            P25 = quantile(value, 0.25, na.rm = TRUE),
            P50 = median(value, na.rm = TRUE),
            P75 = quantile(value, 0.75, na.rm = TRUE))

#### Box plots by pop size bin ####

# colors
# oct_color <- brewer.pal(3, "Set1")[1]
# july_color <- brewer.pal(3, "Set1")[2]
#
# # Absolute percent difference between sf and v1 / sf and v2
# ma_mcd_adjusted_perc %>%
#   filter(var == "abs_perc_diff_sf_v1" | var == "abs_perc_diff_sf_v2") %>%
#   ggplot(aes(x = pop_bin, y = value, color = var)) +
#     geom_boxplot() +
#     scale_x_discrete(name="Total Population Bins (SF1)") +
#     ylab("Absolute Percent Difference (Average denominator)") +
#     scale_color_brewer(palette = "Set1") +
#     labs(caption = "Source: Van Riper et al. 2020; US Census Bureau 2019; Massachusetts Department of Health 2020") +
#     ggtitle(paste("2010 SF1 vs. Diff. Private: Absolute Percent Difference in Age-Adjusted Asthma ED Visits (MA towns)")) +
#     annotate("text", x = 0.85, y = 53, label = "Oct. 2019", color = oct_color, size = 4) +
#     annotate("text", x = 1.15, y = 40.5, label = "July 2020", color = july_color, size = 4) +
#     theme_bw() +
#     theme(axis.title = element_text(size = 16),
#           axis.text = element_text(size = 12),
#           plot.title = element_text(size = 20),
#           legend.position = "none",
#           panel.border = element_blank())
#
# ggsave(paste("figures/ma_towns_asthma_ed_abs_perc_diff", ".png", sep=""), width=10, height=5.625, dpi=150)
#
# # Percent difference (positive and negative) between sf and v1 / sf and v2
# ma_mcd_adjusted_perc %>%
#   filter(var == "perc_diff_sf_v1" | var == "perc_diff_sf_v2") %>%
#   ggplot(aes(x = pop_bin, y = value, color = var)) +
#   geom_boxplot() +
#   scale_x_discrete(name="Total Population Bins (SF1)") +
#   ylab("Percent Difference (Average denominator)") +
#   scale_color_brewer(palette = "Set1") +
#   labs(caption = "Source: Van Riper et al. 2020; US Census Bureau 2019; Massachusetts Department of Health 2020") +
#   ggtitle(paste("2010 SF1 vs. Diff. Private: Percent Difference in Age-Adjusted Asthma ED Visits (MA towns)")) +
#   annotate("text", x = 0.85, y = 55, label = "Oct. 2019", color = oct_color, size = 4) +
#   annotate("text", x = 1.15, y = 37, label = "July 2020", color = july_color, size = 4) +
#   theme_bw() +
#   theme(axis.title = element_text(size = 16),
#         axis.text = element_text(size = 12),
#         plot.title = element_text(size = 20),
#         legend.position = "none",
#         panel.border = element_blank())
#
# ggsave(paste("figures/ma_towns_asthma_ed_perc_diff", ".png", sep=""), width=10, height=5.625, dpi=150)
#
# #### Box plots with SF as denominator for percent difference ####
#
# # Absolute percent difference between sf and v1 / sf and v2
# ma_mcd_adjusted_perc %>%
#   filter(var == "sf_denom_abs_perc_diff_sf_v1" | var == "sf_denom_abs_perc_diff_sf_v2") %>%
#   ggplot(aes(x = pop_bin, y = value, color = var)) +
#   geom_boxplot() +
#   scale_x_discrete(name="Total Population Bins (SF1)") +
#   ylab("Absolute Percent Difference (SF denominator)") +
#   scale_color_brewer(palette = "Set1") +
#   labs(caption = "Source: Van Riper et al. 2020; US Census Bureau 2019; Massachusetts Department of Health 2020") +
#   ggtitle(paste("2010 SF1 vs. Diff. Private: Absolute Percent Difference in Age-Adjusted Asthma ED Visits (MA towns)")) +
#   annotate("text", x = 0.85, y = 53, label = "Oct. 2019", color = oct_color, size = 4) +
#   annotate("text", x = 1.15, y = 40.5, label = "July 2020", color = july_color, size = 4) +
#   theme_bw() +
#   theme(axis.title = element_text(size = 16),
#         axis.text = element_text(size = 12),
#         plot.title = element_text(size = 20),
#         legend.position = "none",
#         panel.border = element_blank())
#
# ggsave(paste("figures/sf_denom_ma_towns_asthma_ed_abs_perc_diff", ".png", sep=""), width=10, height=5.625, dpi=150)
#
# # Percent difference (positive and negative) between sf and v1 / sf and v2
# ma_mcd_adjusted_perc %>%
#   filter(var == "sf_denom_perc_diff_sf_v1" | var == "sf_denom_perc_diff_sf_v2") %>%
#   ggplot(aes(x = pop_bin, y = value, color = var)) +
#   geom_boxplot() +
#   scale_x_discrete(name="Total Population Bins (SF1)") +
#   ylab("Percent Difference (SF denominator)") +
#   scale_color_brewer(palette = "Set1") +
#   labs(caption = "Source: Van Riper et al. 2020; US Census Bureau 2019; Massachusetts Department of Health 2020") +
#   ggtitle(paste("2010 SF1 vs. Diff. Private: Percent Difference in Age-Adjusted Asthma ED Visits (MA towns)")) +
#   annotate("text", x = 0.85, y = 55, label = "Oct. 2019", color = oct_color, size = 4) +
#   annotate("text", x = 1.15, y = 37, label = "July 2020", color = july_color, size = 4) +
#   theme_bw() +
#   theme(axis.title = element_text(size = 16),
#         axis.text = element_text(size = 12),
#         plot.title = element_text(size = 20),
#         legend.position = "none",
#         panel.border = element_blank())
#
# ggsave(paste("figures/sf_denom_ma_towns_asthma_ed_perc_diff", ".png", sep=""), width=10, height=5.625, dpi=150)


#' Book-crossing 3-way contingency table data
#'
#' 3x4x6 contingency table classifying book reviews by age of reviewer (three categories, 0-25, 26-50, 51+), country of reviewer (Australia, Canada, UK, US) and book (labelled A-F).
#' The dataset appears as a list prepared for contingency table resampling conditional on the sufficient statistics for a log-linear model with all 2-way but no 3-way interactions).
#' Components of the list are A (the configuration matrix); y (sufficient statistics); x (true cell counts); lambda (cell means); and MarkovBasis (a matrix with columns corresponding
#' to the vectors in full Markov basis for the resampling problem).
#'
#' @docType data
#'
#' @usage data(BXno3way)
#' @export
#' @examples
#' data(BXno3way)
#' Xsampler(A=BXno3way$A,y=BXno3way$y,lambda=BXno3way$lambda,Model="Poisson",Method="Gibbs",tune.par=0.5,combine=TRUE)
"BXno3way"


 #SNOPSIS

 #runs phenotypic correlation analysis.
 #Correlation coeffiecients are stored in tabular and json formats

 #AUTHOR
 # Isaak Y Tecle (iyt2@cornell.edu)

options(echo = FALSE)

library(ltm)
#library(rjson)
library(jsonlite)
library(data.table)
library(phenoAnalysis)
library(dplyr)
#library(rbenchmark)
library(methods)

allArgs <- commandArgs()

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

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

message('inputFiles: ', inputFiles)

refererQtl <- grep("qtl", inputFiles, value=TRUE)

phenoDataFile      <- grep("\\/phenotype_data", inputFiles, value=TRUE)
formattedPhenoFile <- grep("formatted_phenotype_data", inputFiles, fixed = FALSE, value = TRUE)
metaFile       <-  grep("metadata", inputFiles, value=TRUE)
message('metaFiles: ', metaFile)
correCoefficientsFile     <- grep("corre_coefficients_table", outputFiles, value=TRUE)
correCoefficientsJsonFile <- grep("corre_coefficients_json", outputFiles, value=TRUE)

formattedPhenoData <- c()
phenoData          <- c()

if ( length(refererQtl) != 0 ) {
   phenoDataFile      <- grep("\\/phenodata", inputFiles, value=TRUE)

   phenoData <- data.frame(fread(phenoDataFile,
				header=TRUE,
                                   sep=",",
                                   na.strings=c("NA", "-", " ", ".", "..")
                                   ))
}
# else {
#
#     phenoData <- data.frame(fread(phenoDataFile,
#                                      header = TRUE,
#                                      sep="\t",
#                                      na.strings = c("NA", "", "--", "-", ".", "..")
#                                    ))
# }

metaData <- scan(metaFile, what="character")

allTraitNames <- c()
nonTraitNames <- c()
naTraitNames  <- c()

if (length(refererQtl) != 0) {

  allNames      <- names(phenoData)
  nonTraitNames <- c("ID")
  allTraitNames <- allNames[! allNames %in% nonTraitNames]

}

correPhenoData <- c(0)

if (length(refererQtl) == 0  ) {
    averagedPhenoData <- cleanAveragePhenotypes(inputFiles, metaDataFile = metaFile)

    allNames <- names(averagedPhenoData)
    nonTraitNames <- metaData
    allTraitNames <- allNames[! allNames %in% nonTraitNames]

  rownames(averagedPhenoData) <- NULL
  correPhenoData <- averagedPhenoData
} else {
  message("qtl stuff")
  correPhenoData <- phenoData %>%
                        group_by(ID) %>%
                        summarise_if(is.numeric, mean, na.rm=TRUE) %>%
                        select(-ID) %>%
                        round(., 2) %>%
                        data.frame

}

if (!is.null(correPhenoData) && length(refererQtl) == 0) {

    for (i in allTraitNames) {
      if (class(correPhenoData[, i]) != 'numeric') {
          correPhenoData[, i] <- as.numeric(as.character(correPhenoData[, i]))
      }

      if (all(is.nan(correPhenoData[, i]))) {
          correPhenoData[, i] <- sapply(correPhenoData[, i], function(x) ifelse(is.numeric(x), x, NA))
      }

      if (sum(is.na(correPhenoData[,i])) > (0.5 * nrow(correPhenoData))) {
          correPhenoData$i <- NULL
          naTraitNames <- c(naTraitNames, i)
          message('dropped trait ', i, ' no of missing values: ', sum(is.na(correPhenoData[,i])))
      }
  }
}

filteredTraits <- allTraitNames[!allTraitNames %in% naTraitNames]

coefpvalues <- rcor.test(correPhenoData,
                         method="pearson",
                         use="pairwise"
                         )

coefficients <- coefpvalues$cor.mat
allcordata   <- coefpvalues$cor.mat

allcordata[lower.tri(allcordata)] <- coefpvalues$p.values[, 3]
diag(allcordata) <- 1.00

pvalues <- as.matrix(allcordata)
pvalues <- round(pvalues, 2)

coefficients <- round(coefficients, 3)
allcordata   <- round(allcordata, 3)

#remove rows and columns that are all "NA"
if (apply(coefficients, 1, function(x)any(is.na(x))) ||
    apply(coefficients, 2, function(x)any(is.na(x))))
  {

    coefficients<-coefficients[-which(apply(coefficients, 1, function(x)all(is.na(x)))),
                               -which(apply(coefficients, 2, function(x)all(is.na(x))))]
  }

pvalues[upper.tri(pvalues)]           <- NA
coefficients[upper.tri(coefficients)] <- NA
coefficients <- data.frame(coefficients)

coefficients2json <- coefficients
names(coefficients2json) <- NULL

traits <- colnames(coefficients)

correlationList <- list(
                     labels = traits,
                     values  = coefficients
                   )

correlationJson <- jsonlite::toJSON(correlationList)

write.table(coefficients,
       file = correCoefficientsFile,
       sep  = "\t",
       row.names = TRUE,
       quote = FALSE
       )

write(correlationJson,
       file = correCoefficientsJsonFile)

## if (file.info(formattedPhenoFile)$size == 0 && !is.null(formattedPhenoData) ) {
##   fwrite(formattedPhenoData,
##          file      = formattedPhenoFile,
##          sep       = "\t",
##          row.names = TRUE,
##          quote     = FALSE,
##          )
## }

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


# Check if RStudio is running to set the working directory to the script directory
# https://stackoverflow.com/questions/35986037/detect-if-an-r-session-is-run-in-rstudio-at-startup
is.na(Sys.getenv("RSTUDIO", unset = NA))
if (!is.na(Sys.getenv("RSTUDIO", unset = NA))) {
  # Get current directory
  current_dir <- dirname(rstudioapi::getSourceEditorContext()$path)
  # Set working directory to current directory (script directory)
  setwd(current_dir)
} else {
  # If sourced https://stackoverflow.com/questions/13672720/r-command-for-setting-working-directory-to-source-file-location-in-rstudio
  this.dir <- dirname(parent.frame(2)$ofile)
  setwd(this.dir)
}
# Include the excel helper functions
source("excelhelper.r")

# we will use ggplot2 for our charts
library(ggplot2)

# Read the input files
diamonds<- getTable("color_linechart")

# Define the order of the clarity levels
diamonds$clarity <- factor(diamonds$clarity, levels = c("I1","SI2","SI1","VS2","VS1","VVS2","VVS1","IF"))

# We will create a line for each color and see how the number of diamonds of that color change across clarity categories..
ggplot(diamonds, aes(clarity)) +
  geom_freqpoly(aes(group = color, colour = color), stat="count") +
  labs(x="Clarity", y="Number of Diamonds", title="Clarity by Color")

# save the chart
saveChart("color_linechart")

# Signal the end of the process
done()

# free up all variables
rm(list=ls())


#' ranshaq
#'
#' Generate a random shaq object.
#'
#' @section Communication:
#' The operation is entirely local.
#'
#' @param generator
#' A function, such as \code{runif()} or \code{rnorm()} (passed without parens).
#' See examples for a demonstration of usage.
#' @param nrows,ncols
#' The number of rows
#' @param local
#' Is the problem size \code{nrows*ncols} specifying the local or global problem
#' size?
#' @param ...
#' Additional arguments passed to the generator.
#'
#' @return
#' A shaq.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#'
#' # a 10x3 shaq with random uniform data
#' x = ranshaq(runif, 10, 3)
#' x
#'
#' # a (comm.size() * 10)x3 shaq with random normal data
#' y = ranshaq(rnorm, 10, 3, local=TRUE)
#' y
#'
#' finalize()
#' }
#'
#' @export
ranshaq = function(generator, nrows, ncols, local=FALSE, ...)
{
  if (!missing(nrows))
    check.is.posint(nrows)
  if (!missing(ncols))
    check.is.posint(ncols)
  check.is.flag(local)

  if (missing(nrows) && missing(ncols))
  {
    s = shaq(matrix(nrow=0, ncol=0), 0, 0, checks=FALSE)
    return(s)
  }
  else if (missing(ncols))
    ncols = 1L
  else if (missing(nrows))
    nrows = 1L

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

  Data = generator(nrows.local*ncols, ...)
  dim(Data) <- c(nrows.local, ncols)

  shaq(Data, nrows, ncols, checks=FALSE)
}


valid.GenBandMat <- function(object)
{
  # if (any(dim(object@Data) > object@dim))
  #   return("impossible dimensions: dimension of data larger than @dim slot")
  if (length(object@dim) != 2)
    return("dimension attribute must have exactly 2 numbers (nrows x ncols)")

  return(TRUE)
}

valid.SymMat <- function(object)
{
  if (length(object@dim) != 2)
    return("dimension attribute must have exactly 2 numbers (nrows x ncols)")
  if (object@dim[1L] != object@dim[2L])
    return("invalid dimension specification for SymMat")
  if (!is.char(object@triangle) || !(object@triangle %in% c('l', 'u')))
    return("'triangle' must be 'l' or 'u'")

  TRUE
}

valid.DiagMat <- function(object)
{
  if (length(object@dim) != 2)
    return("dimension attribute must have exactly 2 numbers (nrows x ncols)")
  if (!any(object@dim == length(object@Data)))
    return("invalid dimension specification for DiagMatrix")

  return(TRUE)
}

valid.ZeroMat <- function(object)
{
  if (length(object@dim) != 2)
    return("dimension attribute must have exactly 2 numbers (nrows x ncols)")
  if (!all(object@dim > 0))
    return("invalid dimension specification for ZeroMatrix")

  return(TRUE)
}


#' @export
shingle <- function(x, tokenizer = tokenizers::tokenize_words) {
  # tokenize each document
  s <- tokenizer(x)

  # make sure documents are sets
  s <- lapply(s, unique)

  # find unique shingles
  s_unique <- unique(unlist(s))

  # ensure we can convert to integers
  if (length(s_unique) >= 2^31) {
    stop("there are more than 2^31 unique words, cannot use match() function!", call. = FALSE)
  }

  # convert characters to integers
  lapply(s, function(doc) fastmatch::fmatch(doc, s_unique))
}

#' Jaccard similarity for shingled documents
#'
#' @param x,y shingle documents generated by \code{shingle_} function
#' @export
jaccard_shingles <- function(x, y) {
  # intersection / union
  length(intersect(x, y))/length(union(x,y))
}


##################################################################################
#                                                                                #
#  Copyright (c) 2014 Yao Nien, Yang, paulyang0125@gmail.com                     #
#  Licensed 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.             #
#                                                                                #
##################################################################################

data1 = read.csv(url("http://stat.columbia.edu/~rachel/datasets/nyt1.csv"))
head(data1)
data1$agecat = cut(data1$Age, c(-Inf, 0, 18, 24, 34, 44, 54, 64, Inf)) # 用c()這個command去create一個從負的-Inf aka Not a Number (NaN), 18 一直到64 及正的NaN 其是就是infinite 代表一直延續的數的vector , 然後在用cut()將data1中的Age這個factor以之前產生的interval bin去做分類
summary(data1) # 使用summary function去知道資料基本狀態 你可以看到不同年齡group的各自的總數
install.packages("doBy")
library("doBy") #安裝doBy這個package -
siterange = function(x){c(length(x),min(x),mean(x),max(x))}
summaryBy(Age~agecat, data = data1, FUN=siterange)
summaryBy(Gender+Signed_In+Impressions+Clicks~agecat, data=data1)

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

install.packages("ggplot2") # 安裝ggplot2套件
library("ggplot2")

################### Impression vs. agecat

ggplot(data1, aes(x=Impressions, fill=agecat)) + geom_histogram(binwidth=1)

ggplot(data1, aes(x=agecat, y=Impressions, fill=agecat)) + geom_boxplot()

################## CTR status vs. agecat

data1$hasimp = cut(data1$Impressions,c(-Inf,0,Inf))
summaryBy(Clicks~hasimp, data=data1, FUN=siterange)

ggplot(subset(data1,Impressions>0),aes(x=Clicks/Impressions,colour=agecat)) + geom_density()

ggplot(subset(data1,Clicks>0),aes(x=Clicks/Impressions,colour=agecat)) + geom_density()

ggplot(subset(data1,Clicks>0),aes(x=agecat,y=Clicks,colour=agecat)) + geom_boxplot()

ggplot(subset(data1,Clicks>0),aes(x=Clicks, colour=agecat)) + geom_density()

#####################create一個scode欄位 去分類不同使用族群 (有click,只有impression 或 0)

data1$scode[data1$Impressions == 0] = 'NoImps'
data1$scode[data1$Impressions > 0] = 'Imps'
data1$scode[data1$Clicks > 0] = 'Clicks'

data1$scode = factor(data1$scode)

clen = function(x){c(length(x))}
etable = summaryBy(Impressions~scode+Gender+agecat, data=data1, FUN=clen)

View(etable)

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

data1$teens = cut(data1$Age, c(0,18))
summaryBy(Clicks~teens+Gender, data = data1, FUN = siterange)


\docType{data}
\name{hava_durumu}
\alias{hava_durumu}
\title{Saatlik hava durumu verisi}
\format{26.115 satır ve 15 sütundan oluşan bir data.frame
\describe{
\item{orijin}{Meteoroloji istasyonu. Bu değişken, \\code{\\link{uçuşlar}} verisi ile birleştirme işlemi için kullanılabilir}
\item{yıl}{Kayıt tarihi (yıl)}
\item{ay}{Kayıt tarihi (ay)}
\item{gün}{Kayıt tarihi (gün)}
\item{saat}{Kayıt saati}
\item{sıcaklık}{Fahrenayt (F) cinsinden ortalama sıcaklık}
\item{işba_sıcaklığı}{İşba sıcaklığı: Su buharının yoğulaştığı sıcaklık (F)}
\item{nem}{Bağıl nem}
\item{rüzgar_yönü}{Derece cinsinden rüzgar yönü}
\item{rüzgar_hızı}{Mil bölü saat cinsinden rüzgar hızı}
\item{rüzgar_hamlesi}{Ortalama rüzgar hızından daha hızlı (en az 10 Knot) esen, ani artış gösteren kısa süreli rüzgar}
\item{yağış}{İnç cinsinden yağış}
\item{basınç}{Milibar cinsinden deniz seviyesi basıncı}
\item{görüş}{Görüş mesafesi (mil)}
\item{tarih_saat}{POSIXct formatında kayıt zamanı}
}}
\usage{hava_durumu}
\description{LGA, JFK ve EWR havalimanları için saatlik meteorolojik veriler}
\seealso{\code{\link[nycflights13]{weather}}}
\keyword{datasets}


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

library(RColorBrewer)
par(mfrow=c(2,4),omi=c(0.5,0.5,0.75,0.5),mai=c(0.5,0.5,0.5,0.5),cex=1.1,family="Lato Light",las=1)

# Import data

source("scripts/inc_datadesign_dbconnect.r")
sql<-"select * from v_za4972_laender"
myDataset<-dbGetQuery(con,sql)
attach(myDataset)

# Create chart

myCuts<-c(0,1.5,2,2.5,3)
barplot(table(cut(v84,myCuts)),col=brewer.pal(4,"Reds"), ylim=c(0,20), names.arg=table(cut(v84,myCuts)),axes=F,main="Life Satisfaction")
myCuts<-c(0,1.5,2,2.5,3)
barplot(table(cut(v85,myCuts)),col=brewer.pal(4,"Greens"), ylim=c(0,20),names.arg=table(cut(v85,myCuts)),axes=F,main="Situation:\nArea you live in")
myCuts<-c(-0.1,0,0.1,0.2,0.3)
barplot(table(cut(v100,myCuts)),col=brewer.pal(4,"Blues"), ylim=c(0,20),names.arg=table(cut(v100,myCuts)),axes=F,main="Expectations:\nArea you live in")
myCuts<-c(-0.6,-0.4,0,0.2,0.4)
barplot(table(cut(v114,myCuts)),col=brewer.pal(4,"Purples"), ylim=c(0,20),names.arg=table(cut(v114,myCuts)),axes=F,main="Change 5 years:\nLife in general")
par(family="Lato", cex=0.7)
plot.new()
bez<-c("0.0 to 1.5","1.5 to 2.0","2.0 to 2.5","2.5 to 3.0")
legend("center",bez,cex=2.05,border=F,bty="n",fill= brewer.pal(4,"Reds"),y.intersp=1.3)
plot.new()
bez<-c("0.0 to 1.5","1.5 to 2.0","2.0 to 2.5","2.5 to 3.0")
legend("center",bez,cex=2.05,border=F,bty="n",fill= brewer.pal(4,"Greens"),y.intersp=1.3)
plot.new()
bez<-c("−0.1 to ±0.0","±0.0 to +0.1","+0.1 to +0.2","+0.2 to +0.3")
legend("center",bez,cex=2.05,border=F,bty="n",fill= brewer.pal(4,"Blues"),y.intersp=1.3)
plot.new()
bez<-c("−0.6 to −0.4","−0.4 to ±0.0","±0.0 to +0.2","+0.2 to +0.4")
legend("center",bez,cex=2.05,border=F,bty="n",fill= brewer.pal(4,"Purples"),y.intersp=1.3)

# Titling

mtext("Eurobarometer 71.2: Number of countries",3,line=1,adj=0,cex=2.15,family="Lato Black",outer=T)
mtext("mean values of responsive categories",1,line=1,adj=0,cex=1.25,font=3,outer=T)
mtext("Source: Eurobarometer 71.2",1,line=1,adj=1.0,cex=1.25,font=3,outer=T)
dev.off()


library(broom)
library(cowplot)
library(crayon)
library(data.table)
library(dendextend)
library(DEoptimR)
library(directlabels)
library(dplyr)
library(extrafont)
library(extrafontdb)
library(flexmix)
library(fontcm)
library(fontLiberation)
library(fontquiver)
library(fpc)
library(ggfortify)
library(ggimage)
library(ggplot2)
library(ggplotgui)
library(ggplotify)
library(ggpubr)
library(ggrepel)
library(ggridges)
library(ggsci)
library(git2r)
library(GlobalOptions)
library(graphics)
library(grDevices)
library(grid)
library(gridExtra)
library(gridGraphics)
library(gtable)
library(highr)
library(kernlab)
library(labeling)
library(lattice)
library(latticeExtra)
library(lubridate)
library(magick)
library(magrittr)
library(Matrix)
library(mclust)
library(methods)
library(modelr)
library(permute)
library(pillar)
library(plotfunctions)
#library(plotly)
library(prabclus)
library(psych)
library(pvclust)
library(qqplotr)
library(quadprog)
library(RColorBrewer)
library(readr)
library(reshape2)
library(robustbase)
library(stats)
library(tibble)
library(tidyverse)
library(trimcluster)
#library(violinmplot)
library(utf8)
library(vegan)
library(viridis)
library(viridisLite)
library(wesanderson)


#!/usr/bin/env Rscript

################################### read.mrbayes.FIX.R ###################################

library(tools)
library(ape)		## This is an ips dependency, so load it first.
library(ips)		## ips is the main package we use in this script.

##--Create modified version of ips 'read.mrbayes' function, that fixes a bug in the code:
read.mrbayes.FIX <- function (file, digits = NULL){
    tr <- read.nexus(file)
    nt <- Ntip(tr)
    ni <- Nnode(tr)
    nn <- nt + ni
    X <- scan(file = file, what = "", sep = "\n", quiet = TRUE)
    LEFT <- grep("\\[", X)
    tab <- extractMRBAYESstats(file, nn)
    RIGHT <- grep("\\]", X)
    if (length(LEFT)) {
        w <- LEFT == RIGHT
        if (any(w)) {
            s <- LEFT[w]
            X[s] <- gsub("\\[[^]]*\\]", "", X[s])
        }
        w <- !w
        if (any(w)) {
            s <- LEFT[w]
            X[s] <- gsub("\\[.*", "", X[s])
            sb <- RIGHT[w]
            X[sb] <- gsub(".*\\]", "", X[sb])
            if (any(s < sb - 1))
                X <- X[-unlist(mapply(":", (s + 1), (sb - 1)))]
        }
    }
    endblock <- grep("END;|ENDBLOCK;", X, ignore.case = TRUE)
    semico <- grep(";", X)
    i1 <- grep("BEGIN TREES;", X, ignore.case = TRUE)
    i2 <- grep("TRANSLATE", X, ignore.case = TRUE)
    end <- semico[semico > i2][1]
    x <- X[(i2 + 1):end]
    x <- unlist(strsplit(x, "[,; \t]"))
    x <- x[nzchar(x)]
    TRANS <- matrix(x, ncol = 2, byrow = TRUE)
    TRANS[, 2] <- gsub("['\"]", "", TRANS[, 2])
    n <- dim(TRANS)[1]
    start <- semico[semico > i2][1] + 1
    end <- endblock[endblock > i1][1] - 1
    tree <- X[start:end]
    tree <- gsub("^.*= *", "", tree)
    tree <- read.tree(text = tree)
    nt <- Ntip(tree)
    ni <- Nnode(tree)
    tree$edge.length <- 1:(Ntip(tree) + Nnode(tree) - 1)
    tree <- write.tree(tree, file = "")
    id <- unlist(strsplit(tree, ":"))[-1]
    id <- gsub("(^[[:digit:]]+)([[:punct:]].*$)", "\\1", id)
    id <- as.numeric(id)
    nn <- nt + ni
    tab <- tab[match(1:nn, c(id, nn))]
    tab <- t(tab)
    tr <- read.nexus(file)
    tr <- list(edge = tr$edge, edge.length = tr$edge.length,
        Nnode = tr$Nnode, tip.label = tr$tip.label, mrbayes = tab)
    class(tr) <- ("phylo")
    attr(tr, "origin") <- file
    tr
}


 DGTSV Example Program Results

 Solution
     -4.0000     7.0000     3.0000    -4.0000    -3.0000


setwd("car-insurance-tool")
library(data.table)
library(tidyverse)
library(lubridate)

dt <- fread("metadata_results.csv")
dt <- mutate(dt, edited = as.factor(ifelse(video_file == "Edited video", 1, 0))) %>%
  mutate(FileSize = as.numeric(tstrsplit(`File Size`, split = ' ')[[1]]))
dt <- mutate(dt, TrackDuration = ifelse(tstrsplit(`Track Duration`, split = ' ')[[2]]=='s',
                                        as.numeric(tstrsplit(`Track Duration`, split = ' ')[[1]]),
                                        0))

dt$file_nr <- 1:nrow(dt)
dt <- mutate(dt,TrackDuration = ifelse(edited==1, 30, TrackDuration))
dt$ratio <- dt$FileSize/dt$TrackDuration
ggplot(dt, aes(x=file_nr, y=ratio, color=edited)) + geom_point(size=3) + theme_bw()

dt_selected <- dt[, c(1,4,5,6,7,8,10,13,14,15,21,24,25,26,27,28,30,37,43,
                      45,49,50,51,54,55,56,57,58,61,64,69,73,74,75,76,77,79,87,
                      88,92,93,94,97,100,101,103,104,106,111,112,113,115,116,121,
                      122,123,124,130,140,142,143,146,148,154,157,163,
                      165,170,171,172,173,174)]
#clean(dt_selected)

dt_clean <- mutate(dt_selected, is_GPSLon = ifelse(is.na(`GPS Longitude`)==T, 'none', 'exists'),
                   `GPS Longitude` = NULL, `File Size`=NULL,
                   MediaModifiedDate = parse_date_time(`Media Modify Date`,"%Y:%m:%d %H:%M:%S"),
                   `Media Modify Date` = NULL,
                   `Metering Mode`=NULL, AudioFormat = as.factor(`Audio Format`), `Audio Format`=NULL,
                   `White Balance`=NULL, MediaCreateDate = parse_date_time(`Media Create Date`,"%Y:%m:%d %H:%M:%S"),
                   `Media Create Date` = NULL, `Exposure Compensation`=NULL, `Shutter Speed`=NULL,
                   `X Resolution`=NULL, Software=NULL, `Media Language Code`=NULL)

dt_clean <- mutate(dt_clean, ModifiedDate = parse_date_time(`Modify Date`,"%Y:%m:%d %H:%M:%S"),
                   `Modify Date` = NULL,
                   `Exposure Mode` = NULL,
                   is_PurchaseFileFormat = as.factor(ifelse(is.na(`Purchase File Format`)==T, "none", "exists")),
                   `Purchase File Format` = NULL, `GPS Time Stamp`=NULL,
                   `GPS Date Stamp`=NULL,
                   is_CompressorName = as.factor(ifelse(is.na(`Compressor Name`)==T, "none", "exists")),
                   `Compressor Name` = NULL, `Time To Sample Table`=NULL,
                   is_Encoder = ifelse(is.na(Encoder)==T, 'none','exists'),
                   `Track Duration`= NULL, is_PixelApsectRatio = ifelse(is.na(`Pixel Aspect Ratio`)==T,'none','exists'),
                   `Pixel Aspect Ratio`=NULL, `Max Aperture Value` = NULL)

dt_clean <- mutate(dt_clean, MediaDuration=as.numeric(tstrsplit(`Media Duration`, split = ' ')[[1]]),
                   `Media Duration`=NULL)

dt_clean <- mutate(dt_clean, `Color Space`=NULL, CreateDate=parse_date_time(`Create Date`,"%Y:%m:%d %H:%M:%S"),
                   `Create Date` = NULL, Balance = NULL, `File Type Extension`=NULL,
                   `Date/Time Original` = NULL, `Current Time`=NULL,
                   TrackCreateDate=parse_date_time(`Track Create Date`,"%Y:%m:%d %H:%M:%S"),
                   `Track Create Date` = NULL, `Bits Per Sample`=NULL,
                   `Scene Capture Type` = NULL, `Interoperability Index` = NULL,
                   is_ColorRepresenation = as.factor(ifelse(is.na(`Color Representation`)==T, "none", "exists")),
                   `Color Representation` = NULL)
dt_clean <- mutate(dt_clean, `Graphics Mode` = NULL, `Exposure Time`=NULL, `Color Components`=NULL,
                   `Hyperfocal Distance`=NULL, `Movie Data`=NULL, `Compression`=NULL,
                   is_GPSPos = ifelse(is.na(`GPS Position`)==T, 'none', 'exists'),
                   `GPS Position` = NULL, Duration=ifelse(tstrsplit(Duration, split = ' ')[[2]]=='s',
                                                          as.numeric(tstrsplit(Duration, split = ' ')[[1]]),
                                                          ifelse(edited==1, 30, NA)))

dt_clean <- mutate(dt_clean, AvgBitrate=ifelse(tstrsplit(`Avg Bitrate`, split = ' ')[[2]]=='Mbps',
                                               as.numeric(tstrsplit(`Avg Bitrate`, split = ' ')[[1]]),
                                               NA))

dt_clean <- mutate(dt_clean, `Avg Bitrate`=NULL, Orientation=NULL,
                   `Focal Length`=NULL,
                   is_GPSCoordinates = ifelse(is.na(`GPS Coordinates`)==T, 'none', 'exists'),
                   `GPS Coordinates` = NULL, `Field Of View` = NULL,
                   `GPS Altitude` = NULL, `Brightness Value` = NULL,
                   `GPS Date/Time` = NULL,
                    TrackModifiedDate=parse_date_time(`Track Modify Date`,"%Y:%m:%d %H:%M:%S"),
                   `Track Modify Date` = NULL,
                    is_GPSLat = ifelse(is.na(`GPS Latitude`)==T, 'none', 'exists'),
                   `GPS Latitude` = NULL, `Aperture Value` = NULL, `Audio Channels` = NULL)

dt_clean <- mutate(dt_clean, `Bit Depth`= NULL)
dt_clean$CompatibleBrands = dt_clean$`Compatible Brands`
dt_clean$MovieDataSize = dt_clean$`Movie Data Size`
dt_clean$HandlerType <- dt_clean$`Handler Type`
dt_clean$HandlerDescription <- dt_clean$`Handler Description`
dt_clean <- mutate(dt_clean, creation_modification_diff = MediaModifiedDate-MediaCreateDate)
dt_clean <- mutate(dt_clean, is_MediaModifiedDate = ifelse(is.na(MediaModifiedDate)==T,'none','exists'),
                   is_MediaCreateDate = ifelse(is.na(MediaCreateDate)==T,'none','exists'))
dt_clean$is_Duration <- ifelse(is.na(dt_clean$Duration)==T, 'none','exists')
dt_clean$is_CreateDate <- ifelse(is.na(dt_clean$CreateDate)==T, 'none','exists')
dt_clean$is_ModifiedDate <- ifelse(is.na(dt_clean$ModifiedDate)==T, 'none','exists')
dt_clean$is_MediaDuration <- ifelse(is.na(dt_clean$MediaDuration)==T, 'none','exists')
dt_clean$is_AvgBitRate <- ifelse(is.na(dt_clean$AvgBitrate)==T, 'none','exists')
dt_only_different <- select(dt_clean, video_file, CompatibleBrands, is_Encoder,
                            MovieDataSize, HandlerType, is_Duration, HandlerDescription,
                            FileSize, TrackDuration, is_GPSLon, is_GPSLat, is_MediaModifiedDate,
                            is_MediaCreateDate, is_ModifiedDate, is_PurchaseFileFormat,
                            is_CompressorName, is_PixelApsectRatio, is_MediaDuration, is_CreateDate,
                            is_ColorRepresenation, is_GPSPos,
                            is_AvgBitRate, is_GPSCoordinates, edited)

ggplot(dt_clean, aes(x=`Image Height`, y=`Image Width`, color=edited)) +
  geom_point(alpha=0.3) + theme_bw() + geom_jitter()

ggplot(dt_clean, aes(x=`Compatible Brands`, fill=edited)) +
  geom_bar(position='dodge') + theme_bw()

ggplot(dt_clean, aes(x=Encoder, fill=edited)) +
  geom_bar(position='dodge') + theme_bw()

ggplot(dt_clean, aes(x=`Movie Data Size`, y=`Movie Data Offset`, color=edited)) +
  geom_point(alpha=0.3) + theme_bw() + geom_jitter()

ggplot(dt_clean, aes(x=MediaDuration, y=AvgBitrate, color=edited)) +
  geom_point(alpha=0.3) + theme_bw() + geom_jitter()

table(dt_clean$`Handler Type`, dt_clean$edited)
table(dt_clean$`Image Size`, dt_clean$edited)
table(dt_clean$`Handler Description`, dt_clean$edited)
table(dt_clean$Rotation, dt_clean$edited)
table(dt_clean$GPSLon, dt_clean$edited)
table(dt_clean$is_MediaModifiedDate, dt_clean$edited)
table(dt_clean$AudioFormat, dt_clean$edited)
table(dt_clean$is_PurchaseFileFormat, dt_clean$edited)
table(dt_clean$CompatibleBrands, dt_clean$edited)
ggplot(dt_clean, aes(x=MovieDataSize, y=Duration, color=edited)) +
  geom_point(alpha=0.3, size=3) + theme_bw() + geom_jitter()

ggplot(dt_clean, aes(y=TrackDuration, x=file_nr, color=edited)) +
  geom_point(alpha=0.3, size=3) + theme_bw() + geom_jitter()

dt_clean$HandlerDescription

filter(dt_only_different, video_file=='20170806_125933')


Files = c('DEMO', 'DIQ', 'BPQ', 'FSQ', 'L13', 'L13AM')
Cycles = c('2001-2002', '2003-2004')
df_NH = pull_NHANES(Files, Cycles)

inputs <- as.data.frame(matrix(c(
  # COLUMN    COMMENT     WEIGHTS
   "URXBPH", "URDBPHLC", "WTSB2YR", # Food secuirty
   "URXTRS", "URDTRSLC", "WTSB2YR", #
), ncol = 3, byrow = TRUE), stringsAsFactors = FALSE)
names(inputs) <- c("column", "comments", "weights") # You can compute quantiles for multiple columns at once. The simplest way is to pass vectors for the column, comment, and weight name inputs.
nhanes_quantile(df_NH, inputs, quantiles = c(0.5, 0.95, 0.99)) # You can also pass in a data frame that specifies the columns to compute quantiles for.
nhanes_survey(svymean, df_NH, inputs, na.rm = TRUE) #You can use any function from the survey package to analyze your data through the nhanes_survey function. This provides a generic way to apply a survey function to NHANES data.


# SI with desired gains vs economic values, using Ian Mackay's notation.
# 09-04-2018, G. Slavov

load("out_varcovar_miscanthus_2TT_138_MTM_blues.RData")

# Means (colMeans(d[,6:22],na.rm=T), where d has 553 obs for the 138 genos)
#    DOYFS1.9          AvgeSen.9     BaseDiameter.9        DryMatter.9       LeafLength.7        LeafWidth.7  MaxCanopyHeight.9         Moisture.9
#    221.2133891       7.3358696        398.7249545       1065.4722235         52.4290909          1.4184545        144.6709324         30.6474262
# StatureCategory.7 StatureLeafAngle.7 StatureStemAngle.7     StemDiameter.9      TallestStem.9    TransectCount.9        Cellulose.8    Hemicellulose.8
#         3.5968921          0.6627057          1.9670932          5.3678245        176.8171846         27.6302368         42.1360958         32.8069245
#          Lignin.8
#         8.9534070

# Set var-covar matrices
G<-Gmat
E<-Emat
P<-G+E
H2<-diag(G/P)

# Target traits and desired gains
idx<-c(4,15,17)
G_star<-G[,idx]
Q<-c(213,2.1,-0.45)

# Ian Mackay's calculation of b, correlated responses and relative economic values, as well as sigma_i
s7<-t(G_star)%*%solve(P)%*%G_star
s8<-solve(s7)
s9<-solve(P)%*%G_star
s10<-s9%*%s8
b=s10%*%Q
Q_star= G%*%b
a = solve(G)%*%P%*%b
sigma_i = sqrt(t(b)%*%P%*%b)
print(sigma_i)

# Print/save
print(Q_star)
save.image("out_S2.RData")


# Liste
brojke <- c(23.5, 4.7, 6.3, 12.45, 0.37)
imena <- c("Pera", "Mika", "Laza")
pripada <- c(TRUE, TRUE, FALSE, TRUE)
lista <- list( brojke, 2+3i, imena,
               pripada, 5, "Svasta")
lista

podlista <- lista[3]
podlista
treci.element <- lista[[3]]
treci.element

podlista <- lista[c(4,3,1)]
podlista

brojke <- c(23.5, 4.7, 6.3, 12.45, 0.37)
imena <- c("Pera", "Mika", "Laza")
pripada <- c(TRUE, TRUE, FALSE, TRUE)
lista <- list( brojke, 2+3i, imena,
               pripada, 5, "Svasta")
lista

lista[[2]] <- c(1,2,3)
lista[[3]][3] <- "Luka"
lista

brojke <- c(23.5, 4.7, 6.3, 12.45, 0.37)
imena <- c("Pera", "Mika", "Laza")
pripada <- c(TRUE, TRUE, FALSE, TRUE)
lista <- list( numbers = brojke,
               complex = 2+3i,
               names = imena,
               belongs = pripada)
lista

lista$complex <- 4
lista$names[3] <- "Peter"
lista


papi.flops <- function(expr)
{
  papi.check.ncounters(3L)

  ret <- .Call(papi_flops_on)
  if (ret == -1L)
    stop("PAPI failed to initialize hardware counters.\nYour platform may not support floating point operation event.\n")

  eval(expr)

  ret <- .Call(papi_flops_off)
  if (is.integer(ret) && ret == -1L)
    stop("There was a problem recovering the counter information.")

  return( ret )
}

#' flops
#'
#' Measuring floating point operations.
#'
#' This function measures the evaluation of the provided expression, expr, for
#' real time, process time, number of floating point operations, and floating
#' point operation rate. The additional arguments, gcFirst and burnin, can be
#' toggled to better simulate the target context.
#'
#' @param expr
#' A valid R expression to be profiled.
#' @param gcFirst
#' logical; determines if garbage collection should be called
#' before profiling.
#' @param burnin
#' logical; determines if the function should first be evaluated
#' with an empty expression.
#'
#' @return
#' The return is a list consisting of:
#' \tabular{ll}{
#'    \code{real_time} \tab real time spent evaluating expression \cr
#'    \code{proc_time} \tab total process time spent evaluating expression \cr
#'    \code{flpops} \tab FLoating Point OPerationS (count) \cr
#'    \code{mflops} \tab Mflops (flpops per second) \cr
#' }
#'
#' @keywords programming
#'
#' @examples
#' \dontrun{
#' library(pbdPAPI)
#'
#' system.flops(1+1)
#' }
#'
#' @export
system.flops <- function(expr, gcFirst=TRUE, burnin=TRUE)
{
  if (burnin)
    b <- system.flops(gcFirst=gcFirst, burnin=FALSE)

  if (gcFirst)
    invisible(gc(FALSE))

  if (missing(expr))
    expr <- NULL

  events <- c("PAPI_FP_OPS", "PAPI_TOT_CYC")
  papi.avail.lookup(events=events, shorthand=FALSE)

  ret <- papi.flops(expr=expr)

  if (burnin)
  {
    for (i in 3:length(ret))
      ret[[i]] <- max(ret[[i]] - b[[i]], 0)
  }

  # Store expression call for plotting
  attr(ret, "call") <- as.character(match.call()[2])
  class(ret) <- c("papi_output", "papi_flops")

  return( ret )
}


pdf_file<-"pdf/timeseries_monthly_monthly_labels.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11,height=4.8)

source("scripts/inc_datadesign_dbconnect.r")
par(cex=0.75,bg=rgb(240,240,240,maxColorValue=255))
par(omi=c(0.75,0.25,0.5,0.25),mai=c(0.25,0.55,0.25,0),mgp=c(2,1,0),family="Lato Light",las=1)
myColour1<-rgb(255,0,0,150,maxColorValue=255)
myColour2<-rgb(0,0,0,150,maxColorValue=255)

# Read data

sql<-"select concat_ws('-',jahr,monat,'01') monat, v8, v9 from t_za2391_zeitreihen where jahr >= 2002"
myData<-dbGetQuery(con,sql)
attach(myData)

# Create chart and other elements

plot(type="n",axes=F,xlab="",ylab="Mean",as.Date(monat),v8,col=rgb(255,97,0,150,maxColorValue=255),lwd=2,ylim=c(-1,2))

mbegin<-seq(as.Date("2002-01-01"),as.Date("2008-01-01"),by="1 months")
ybegin<-seq(as.Date("2002-01-01"),as.Date("2008-01-01"),by="1 years")
abline(v=ybegin,col="lightgrey")

points(as.Date(monat),v8,col=myColour1,lwd=5,type="l")
points(as.Date(monat),v9,col=myColour2,lwd=5,type="l")

text(as.Date("2007-10-01"),0.5,"SPD",col=myColour1,cex=1.5)
text(as.Date("2007-10-01"),1.5,"CDU",col=myColour2,cex=1.5)

axis(1,col=rgb(60,60,60,maxColorValue=255),at=mbegin,labels=format(mbegin,"%b\n%Y"),cex.axis=0.85,lwd.ticks=0.1,tck=-0.02)
axis(2,col=rgb(240,240,240,maxColorValue=255),col.ticks=rgb(60,60,60,maxColorValue=255),lwd.ticks=0.5,cex.axis=0.85,tck=-0.025,pos=as.Date("2001-12-15"))

# Titling

mtext("Politbarometer 2002-2007",3,line=0,adj=0,cex=1.5,family="Lato Black",outer=T)
mtext("Monthly values. Source: ZA2391, www.gesis.org",1,line=2,adj=1.0,cex=0.85,font=3,outer=T)
dev.off()


########################################
# Teste 2
# Nome(s): Daniele Monetenegro
#          Rodrigo Dantas da Silva
#          Thiago Bruschi Martins
########################################

## 1 - Agrupamento

groupsum <- function(df, col1, col2){
  if(!is.numeric(df[,col2])){
    cat('A variavel Col2 deve ser numerica.')
  } else {
    tmp <- tapply(df[,col2], chuvas[,col1], sum)
    res <- data.frame(col1 = names(tmp), tmp, row.names = NULL)
    colnames(res) <- c(col1, col2)
    return(res)
  }
}

##### Exemplos no PDF:
dia <- c(01, 01, 02, 02, 03, 03, 04, 04, 05, 05)
cidade <- c('Campinas', 'Vinhedo', 'Campinas', 'Limeira', 'Campinas', 'Vinhedo', 'Campinas', 'Vinhedo', 'Limeira', 'Campinas')
chuva <- c(0.15, 0.02, 0.01, 0.13, 0.12, 2.19, 1.11, 0.76, 2.98, 0.45)
chuvas <- data.frame(cidade, dia, chuva)
groupsum(chuvas, "cidade", "chuva")

## 2 - Binario para Decimal

binToDec <- function(...){
  conjuntoResposta <- c()

  for(numero in list(...)){ # percore a lista de parâmetros
    soma <- 0
    tamanho <- (length(numero))

    for(i in tamanho:1) # percore cada um dos vetores/parâmetros para fazer a conversão
    {
      soma <- soma + numero[i]*2^(tamanho-i)
    }
    conjuntoResposta <- append(conjuntoResposta, soma)
  }
  return(conjuntoResposta)
}

##### Exemplos no PDF:
binToDec(c(1, 0))
binToDec(c(0, 0, 1), c(1, 1))
binToDec(rep(1, 3), rep(0, 2), rep(c(1,0), 2))

## 3 - Ocorrencia de Palavras

wordCount <- function(word, text){
  text <- gsub("[.|,|!]","",text)
  text <- tolower(text)
  tam <- sapply(strsplit(text, " "), length)
  text <- strsplit(text, " ")[[1]]
  result <- 0

  for (i in 1:tam) {
    if (text[i] == word) {
      result <- result + 1
    }
  }
  return(result)

}

##### Exemplos no PDF:
text <- "O rAto roeu a roupa do Rei de Roma! RainhA raivosa rasgou o resto."
wordCount("rato", text)
wordCount("roma", text)
text <- "A vaca malHada foi molhADA por outra VACA, MOLhada e MALhaDa."
wordCount("outra", text)
wordCount("vaca", text)
wordCount("malhada", text)
text <- "Se a liga me ligasse, eu tambem ligava a liga. Mas a liga nao me liga, eu tambem nao ligo a liga."
wordCount("liga", text)
wordCount("ligasse", text)


#!/usr/bin/env Rscript

args <- commandArgs(trailingOnly=TRUE)

if(length(args) == 1) {

    library(DSS)
    require(bsseq)

    li1_fn <- paste(args[1], "phase_0.DSS.sorted.txt", sep='.')
    li2_fn <- paste(args[1], "phase_1.DSS.sorted.txt", sep='.')

    dmr_fn <- paste(args[1], "DMRs.txt", sep='.')
    dml_fn <- paste(args[1], "DMLs.txt", sep='.')

    li1 = read.table(li1_fn, header=TRUE)
    li2 = read.table(li2_fn, header=TRUE)
    BSobj = makeBSseqData(list(li1, li2), c('li1', 'li2'))

    dmlTest = DMLtest(BSobj, group1=c('li1'), group2=c('li2'), smoothing=TRUE)
    dmrs = callDMR(dmlTest, p.threshold=0.05)

    write.table(dmrs, file=dmr_fn, quote=F, sep='\t')

    dmls = callDML(dmlTest, p.threshold=1)
    write.table(dmls, file=dml_fn, quote=F, sep='\t')

}

if(length(args) != 1) {
    cat("usage: dss.r <sample name>\n")
}


 source("R/header.r")

myPalette <- colorRampPalette(rev(brewer.pal(11, "Spectral")), space="Lab")

theme_opts <- list(theme(
			panel.grid.minor = element_blank(),
                        panel.grid.major = element_blank(),
                        #panel.background=element_blank(),
                        panel.background = element_rect(color = "black",fill=NA,  size = 0.4, linetype = "solid"),
                        #panel.border=element_rect(color = "black",fill=NA,  size = 0.4, linetype = "solid"),
                        plot.background = element_blank(),
                        #plot.background=element_blank(),
                        #panel.border = element_blank(),
                        axis.line = element_blank(),
                        axis.text.x = element_blank(),
                        axis.text.y = element_blank(),
                        axis.ticks = element_blank(),
                        #panel.margin = unit(5,"lines"),
                        #axis.title.x = element_blank(),
                        #axis.title.y = element_blank(),
                        plot.title = element_text()))

 plot.title = "General Circulation Models Climate Data Output"
 plot.subtitle = 'created by GCM runs'
 nc<-new("mapncdf", filename="data/Climate_CX_v2_2000.nc",
 		varname="TmaxdegC",start_ind=c(1,1,1),count_ind=c(-1,-1,1))

#  nc<-new("mapncdf", filename="data/tas_A1_2.nc",
# 		varname="tas",start_ind=c(1,1,1),count_ind=c(-1,-1,1))
  kkk<-mapConvert(nc)
  r<-rasterFromXYZ(kkk)
  projection(r)<-CRS("+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0")
  rp<-projectRaster(r,crs=CRS("+proj=laea +lat_0=52   +lon_0=10      +x_0=3 210 000    +y_0=4 321 000"),method="ngb")
  sp<-as.data.frame(rasterToPoints(rp))

  names(sp)<-c("lon","lat","val")
  sp$val[abs(sp$val)>1e32]<-NA

 sp<-SpatialPoints(kkk,proj4string=CRS("+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0"))
# #
 # sp_pj<-spTransform(sp,CRS("+proj=laea +lat_0=52   +lon_0=10      +x_0=3 210 000    +y_0=4 321 000"))
 sp_pj<-spTransform(sp,CRS("+proj=robin"))
# #  sp_pj<-data.frame(sp_pj)
#
  sp_pj<-as.data.frame(sp_pj)
#  s2<-300000#145579.5
#  s1<-300000
 #  sp_pj<-data.frame(round(sp_pj[,1]/s1)*s1,round(sp_pj[,2]/s2)*s2,sp_pj[,3])
#  names(sp_pj)<-c("lon","lat","val")

r<-rasterFromXYZ(sp,digits=1)
projection(r)<-CRS("+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0")
plot(projectRaster(r,crs=CRS("+proj=robin"),method="ngb"))

 g<-ggplot(sp,aes(lon,lat))+geom_raster(aes(fill=val))+
 #geom_path(data=countries_robin_df,aes(long,lat,group=group),color="black",size=0.2)+
     scale_fill_gradientn(colours=myPalette(100), na.value="white",
 		      guide= guide_colorbar(title=expression(degree~C), title.position="top",
 			      #    barwidth = 25, barheight = 1,nbin=100,
 			     draw.ulim = FALSE, draw.llim = FALSE ))+
 		      theme_opts+
 		      ggtitle(bquote(atop(.(plot.title), atop(italic(.(plot.subtitle)), ""))))
#
#
# h<-ggplot(kkk,aes(lon,lat,fill=val))+geom_raster()+
#  geom_path(data=wmap_gg,aes(long+180,lat,group=group),color="black",size=0.2)+
# scale_fill_gradientn(colours=myPalette(100),
#  		      guide= guide_colorbar(title=expression(degree~C), title.position="top",
#  			      #    barwidth = 25, barheight = 1,nbin=100,
#  			     draw.ulim = FALSE, draw.llim = FALSE ))+
#  		      theme_opts+
#  		      ggtitle(bquote(atop(.(plot.title), atop(italic(.(plot.subtitle)), ""))))


=begin
[((<index-ja|URL:index-ja.html>))]
((<Algebra::MPolynomial>))
/
((<Algebra::MPolynomial::Monomial>))
/
((<Algebra::MPolynomialFactorization>))
/
((<Algebra::Groebner>))

= Algebra::MPolynomial
((*(多変数多項式環クラス)*))

多変数の多項式環を表現します。実際のクラスを生成するには環を指定して、
クラスメソッド((<::create>))あるいは関数((<Algebra.MPolynomial>))()を
用います。

== ファイル名:
* ((|m-polynomial.rb|))

== スーパークラス:

* ((|Object|))

== インクルードしているモジュール:

* ((|Enumerable|))
* ((|Comparable|))
* ((<Algebra::Groebner>))

== 関連する関数:

--- Algebra.MPolynomial(ring [, obj0 [, obj1 [, ...]]])
    ((<::create(ring [, obj0[, obj1[, ...]]])>))に同じ。

== クラスメソッド:

--- ::create(ring [, obj0 [, obj1 [, ...]]])
    ((|ring|))で表現されるクラスを係数環とする多変数多項式環
    クラスを生成します。

    オブジェクト(({obj0, obj1, ...}))で変数を登録し、戻り値である
    多変数多項式環クラスは Algebra::MPolynomial クラスのサブクラスです。

    オブジェクト(({obj0, obj1, ...}))は変数の区別と
    名（((|to_s|))の値）に利用されるだけです。

    このサブクラスにはクラスメソッドとして((|ground|))と
    ((|vars|))が定義され、それぞれ、係数環((|ring|))、変数
    の配列を返します。

    登録されたオブジェクト (({obj0, obj1, ...})) で表現される
    される変数は(({var(obj0)})), (({var(obj1)})),...
    で得ることができます。すなわち(({vars == [var(obj0), var(obj1), ...]}))
    です。

    各変数の大小関係は(({obj0 > obj1 > ...}))となります。各単項式
    の順序は((<::set_ord>))で指定します。

    例: 整数を係数とする多項式環の生成
      require "m-polynomial"
      P = Algebra::MPolynomial.create(Integer, "x", "y", "z")
      x, y, z = P.vars
      p((-x + y + z)*(x + y - z)*(x - y + z))
      #=> -x^3 + x^2y + x^2z + xy^2 - 2xyz + xz^2 - y^3 + y^2z + yz^2 - z^3
      p P.ground #=> integer

--- ::vars([obj0 [, obj1 [, ...]]])
    ((*引数が1つもないとき*))、既に登録されている全ての変数を
    配列として返します。

    例:
      P = Algebra.MPolynomial(Integer, "x", "y", "z")
      p P.vars #=> [x, y, z]

    ((*引数がただ1つで文字列であるとき*))、文字列を「英字1字+数字の列」
    に分解し、それで表現される変数を登録します。オブジェクトが既
    に登録されていれば新たな登録はしません。戻り値はそれぞれのオ
    ブジェクトに対応する変数の配列です。

    例:
      P = Algebra.MPolynomial(Integer)
      x, y, z, w = P.vars("a0b10cd")
      p P.vars #=> [a0, b10, c, d]
      p [x, y, z, w] #=> [a0, b10, c, d]

    ((*それ以外のとき*))、引数であるオブジェクト
    (({obj0, obj1, ...})) で表現される変数
    を登録します。オブジェクトが既に登録されていれば新たな登録
    はしません。戻り値は(({obj0, obj1, ...}))に対応する変数
    の配列です。

    例:
      P = Algebra.MPolynomial(Integer)
      p P.vars("x", "y", "z") #=> [x, y, z]

--- ::mvar([obj0 [, obj1 [, ...]]])

    ((*引数が1つもないとき*))、既に登録されている全ての変数を
    配列として返します。

    ((*それ以外のとき*))、引数であるオブジェクト
    (({obj0, obj1, ...})) で表現される変数
    を登録します。オブジェクトが既に登録されていれば新たな登録
    はしません。戻り値は (({obj0, obj1, ...})) に対応する変数
    の配列です。

--- ::to_ary
    (({[self, *vars]})) を返します。

    例: 多項式環と変数を同時に定義する。
      P, x, y, z, w = Algebra.MPolynomial(Integer, "a", "b", "c", "d")

--- ::var(obj)
    ((|obj|)) で登録されたオブジェクトによって表現される変数を返します。

    例:
      P = Algebra.MPolynomial(Integer, "X", "Y", "Z")
      x, y, z = P.vars
      P.var("Y") == y #=> true

--- ::variables
    既に登録されている変数を表現するオブジェクトの配列を返します。

--- ::indeterminate(obj)
    ((<::var>)) と同じです。

--- ::zero?
    零元であるとき真を返します。

--- ::zero
    零元を返します。

--- ::unity
    単位元を返します。

--- ::set_ord(ord [, v_ord])
    ((|ord|)) に単項式順序をシンボルで指定します。順序として可能な指定
    は (({:lex})) (辞書式順序(デフォルト))、(({:grlex})) (次数付き辞書
    式順序)、(({:grevlex})) (次数付き逆辞書式順序)の3つです。

    各変数間の順序は登録された順（先に登録されるほど大きい）に
    なります。((|v_ord|)) に配列を与えてこの順番を変更する事が
    できます。

    例: (({x, y, z = P.var("xyz")})) としたときの順位
      require "m-polynomial"
      P = Algebra.MPolynomial(Integer)
      x, y, z = P.vars("xyz")
      f = -5*x**3 + 7*x**2*z**2 + 4*x*y**2*z + 4*z**2

      P.set_ord(:lex)
      p f #=> -5x^3 + 7x^2z^2 + 4xy^2z + 4z^2

      f.method_cash_clear
      P.set_ord(:grlex)
      p f #=> 7x^2z^2 + 4xy^2z - 5x^3 + 4z^2

      f.method_cash_clear
      P.set_ord(:grevlex)
      p f #=> 4xy^2z + 7x^2z^2 - 5x^3 + 4z^2

      f.method_cash_clear
      P.set_ord(:lex, [2, 1, 0]) # z > y > x
      p f #=> 7x^2z^2 + 4z^2 + 4xy^2z - 5x^3

#    ((<::with_ord>)) も参照してください。

--- ::order=(x)
    ((<::set_ord(x)>)) と同じです。

#--- ::order=(obj)
#    ((<::set_ord(obj)>)) と同じです。

--- ::get_ord
    単項式順序(:lex, :grlex, :grevlex)を返します。

--- ::ord
    ((<::get_ord>)) と同じです。

#--- ::order
#    ((<::get_ord>)) と同じです。

--- ::with_ord(ord [, v_ord[ [, array_of_polys]])
    ((|ord|)) を単項式順序、((|v_ord|)) を変数の順序の変換配列として、
    ブロックを実行します。
    ブロックを抜けると以前の順序に戻ります。
    多項式の配列 ((|array_of_polys|)) が与えられれば、それらに対して
    ((<method_cash_clear>)) が実行されてから、ブロックが実行されます。
    (このブロックはスレッドセーフではありません。)

    例:
      require "m-polynomial"
      P = Algebra.MPolynomial(Integer)
      x, y, z = P.vars("xyz")
      f = -5*x**3 + 7*x**2*z**2 + 4*x*y**2*z + 4*z**2

      P.with_ord(:lex, nil, [f]) do
        p f    #=> -5x^3 + 7x^2z^2 + 4xy^2z + 4z^2
        p f.lt #=> -5x^3
      end

      P.with_ord(:grlex, nil, [f]) do
        p f    #=> 7x^2z^2 + 4xy^2z - 5x^3 + 4z^2
        p f.lt #=> 7x^2z^2
      end

      P.with_ord(:grevlex, nil, [f]) do
        p f    #=> 4xy^2z + 7x^2z^2 - 5x^3 + 4z^2
        p f.lt #=> 4xy^2z
      end

      P.with_ord(:lex, [2, 1, 0], [f]) do # z > y > x
        p f    #=> 7x^2z^2 + 4z^2 + 4xy^2z - 5x^3
        p f.lt #=> 7x^2z^2
      end

    ((<::set_ord>)) も参照してください。

--- ::monomial(ind[, c])
    multi-degree ((|ind|)) で、係数が ((|c|)) の単項式を返します。
    （ただし、((<Algebra::MPolynomial::Monomial>)) は extend
    されていない。）
    ((|c|)) が省略されれば、単位元とみなされます。

#--- ::const(x)
#--- ::regulate(x)
#--- ::[](*x)
#--- ::method_cash_clear(*m)

== メソッド:

--- monomial(ind[, c])
    ((<::monomial>)) と同じ。

#--- each
#--- keys
#--- values
#--- [](ind)
#--- []=(ind, c)
#--- constant_coeff
#--- include?
#--- compact!
#--- rt!

--- constant?
    定数(0次式)であるとき、真を返します。

--- monomial?
    単項式であるとき、真を返します。

--- zero?
    零であるとき、真を返します。

--- zero
    零元を返します。

--- unity
    単位元を返します。

--- method_cash_clear
    このライブラリは、同じ計算を繰り返ししないように結果を保存
    していますが、それをクリアします。この操作は単項式順序の変
    更などを行った後に必要になります。

    結果が保存されているメソッドは、
    ((<lc>)), ((<lm>)), ((<lt>)), ((<rt>)), ((<multideg>))
    です。

    例:
      P = Algebra.MPolynomial(Integer)
      x, y, z = P.vars("xyz")
      f = -5*x**3 + 7*x**2*z**2 + 4*x*y**2*z + 4*z**2
      P.set_ord(:lex)
      p f.lt #=> -5x^3
      P.set_ord(:grlex)
      p f.lt #=> -5x^3
      f.method_cash_clear
      p f.lt #=> 7x^2z^2

--- ==(other)
    等しいとき真を返します。

--- <=>(other)
    大小関係を求めます。

--- +(other)
    和を計算します。

--- -(other)
    差を計算します。

--- *(other)
    積を計算します。

--- **(n)
    ((|n|)) 乗を計算します。

--- /(other)
    ((|other|)) が、定数(0次式)であるとき、商を計算します。

--- divmod(f0 [, f1 [,...]])
    多項式 (({f0, f1,...})) による割り算をし、商の配列と剰余を計算します。

      P = Algebra.MPolynomial(Integer)
      x, y = P.vars("xy")
      f = x**2*y + x*y**2 + y**2
      f0 = x*y - 1
      f1 = y**2 - 1
      p f.divmod(f0, f1) #=> [[x + y, 1], x + y + 1]
      p f % [f0, f1]     #=> x + y + 1

--- %(others)
    ((|others|)) を多項式の配列としたとき、それによる割り算の剰余を返します。
    これは (({divmod(*others)[1]})) と同じです。

--- multideg
    （多重）次数を返します。

    例: (lex オーダーで)
      P = Algebra.MPolynomial(Integer)
      x, y, z = P.vars("xyz")
      f = 4*x*y**2*z + 4*z**2 - 5*x**3*y + 7*x**2*z**2
      p f.multideg #=> [3, 1]

--- totdeg
    次数（多重次数の和）を返します。

    例: (lex オーダーで)
      f = 4*x*y**2*z + 4*z**2 - 5*x**3*y + 7*x**2*z**2
      p f.totdeg   #=> 4

--- deg
    multideg と同じです。

--- lc
    先頭係数(leading coeffcient)を返します。

    例: (lex オーダーで)
      f = 4*x*y**2*z + 4*z**2 - 5*x**3*y + 7*x**2*z**2
      p f.lc       #=> -5

--- lm
    先頭単項式(leading monomial)を返します。
    この戻り値は((<Algebra::MPolynomial::Monomial>))というモジュールが
    extend されます。

    例: (lex オーダーで)
      f = 4*x*y**2*z + 4*z**2 - 5*x**3*y + 7*x**2*z**2
      p f.lm       #=> x^3y

--- lt
    先頭項(leading term)を返します。(({lc * lm}))と等しい値を持ちます。

    例: (lex オーダーで)
      f = 4*x*y**2*z + 4*z**2 - 5*x**3*y + 7*x**2*z**2
      p f.lt       #=> -5x^3y

--- rt
    残余項(rest term)を返します。(({self - lt}))と等しい値を持ちます。

    例: (lex オーダーで)
      f = 4*x*y**2*z + 4*z**2 - 5*x**3*y + 7*x**2*z**2
      p f.rt       #=> 4*z**2 - 5*x**3*y + 7*x**2*z**2

--- to_s
    文字列表現を得ます。表示形式を変えるには((|display_type|))を用います。
    ((|display_type|))に与えられる値は ((|:norm|))(デフォルト), ((|:code|))
    です。

    例:
      P = Algebra.MPolynomial(Integer)
      x, y, z = P.vars("xyz")
      f = -5*x**3 + 7*x**2*z**2 + 4*x*y**2*z + 4*z**2
      p f #=> -5x^3 + 7x^2z^2 + 4xy^2z + 4z^2
      P.display_type = :code
      p f #=> -5*x**3 + 7*x**2*z**2 + 4*x*y**2*z + 4*z**2

--- map_to(ring[, vs]){|c, ind| ... }
    多項式に含まれる各単項式について、
    multi-degree を ((|ind|))、係数を ((|c|)) に代入し、
    ... を評価して、((|ring|)) 上で和を取った値を
    返します。((|vs|)) が省略されると ((<::vars>)) の値が用いら
    れます。
    (({f}))が(({P}))上の多項式なら、
    (({f.map_to(P) {|c, ind| c * P.monomial(ind)}})) は (({f}))と一致します。

--- project(ring[, vs]){|c, ind| ... }
    多項式に含まれる各単項式について、
    multi-degree を ((|ind|))、係数を ((|c|)) に代入し、
    ... を評価して((|ind|))次の単項式に掛けて、
    ((|ring|)) 上で和を取った値を
    返します。((|vs|)) が省略されると ((<::vars>)) の値が用いら
    れます。

    (({f}))が(({P}))上の多項式なら、
    (({f.map_to(P) {|c, ind| c}})) は (({f}))と一致します。

    (({project(ring){|c, ind| f(c, ind)}})) は (({map_to(ring){|c, ind| f(c, ind) * self.class.monomial(ind)}}))に一致します。

    例:
      require "m-polynomial"
      require "rational"
      P = Algebra::MPolynomial(Integer, "x", "y", "z")
      x, y, z = P.vars
      f = x**2 + 2*x*y - z**3
      PQ = Algebra::MPolynomial(Rational, "x", "y", "z")
      p f.project(PQ) {|c, ind| Rational(c) / (ind[0] + 1)}
                        #=> 1/3x^2 + xy - z^3
      p f.convert_to(PQ)      #=> x^2 + 2xy - z^3

--- evaluate(obj0[, [obj1, [obj2,..]]])
    各変数に ((|obj0, obj1, obj2,...|)) を代入した値を返します。
    ((<project>))(({(ground, [obj0, obj1, obj2,..]){|c, ind| c}}))
    の値と一致します。

    例:
      require "m-polynomial"
      P = Algebra::MPolynomial(Integer, "x", "y", "z")
      x, y, z = P.vars
      f = x**2 + 2*x*y - z**3
      p f.evaluate(1, -1, -1) #=> 0 (in Integer)
      p f.evaluate(y, z, x)   #=> -x^3 + y^2 + 2yz (in P)

--- call(obj0[, [obj1, [obj2,..]]])
    ((<evaluate>))と同じです。

--- sub(var, value)
    変数 ((|var|)) に ((|value|)) を代入した値を返します。

    例:
      require "m-polynomial"
      P = Algebra::MPolynomial(Integer)
      x, y, z = P.vars("x", "y", "z")
      f = (x - y)*(y - z - 1)
      p f.sub(y, z+1)    #=> 0

--- convert_to(ring)
    各項を((|ring|))上で評価します。((<project>))(({(ring){|c, ind| c}}))の
    値と一致します。

--- derivate(var)
    ((<var>))での偏微分を返します。

= Algebra::MPolynomial::Monomial
(単項式の性質を集めたモジュール)

((<lt>)), ((<lm>)) の戻り値である多項式にはこのモジュールがextendされます。

== メソッド:

#--- ind
#--- coeff
#--- <=>(other)
--- divide?(other)
    単項式 ((|other|)) で割り切れるとき真を返します。

--- /(other)
    単項式 ((|other|)) で割り切ります。

--- prime_to?(other)
    単項式 ((|other|)) と素なとき真を返します。

--- lcm(other)
    単項式 ((|other|)) との最小公倍数である単項式を返します。

--- divide_or?(other0, other1)
    ((|divide?(other0.lcm(other1))|)) と同じ値を返します。

= Algebra::MPolynomialFactorization
((*(因数分解モジュール)*))

因数分解をするためのモジュールです。

== ファイル名:
((|m-polynomial-factor.rb|))

== メソッド:
--- factorize
    因数分解します。

    因数分解可能な係数環は
    * Integer
    * Rational
    * 素体

    です。

= Algebra::Groebner
(グレブナ基底計算モジュール)

== ファイル名:
* ((|groebner-basis.rb|))
* ((|groebner-basis-coeff.rb|))

== クラスメソッド:

--- Groebner.basis(f)
    基底の配列 ((|f|)) から簡約グレブナ基底を作り、配列として返します。
    ((<Groebner.basis(Groebner.minimal_basis(Groebner.basis_159A(f)))>))
    と同等です。

    例:
      require "m-polynomial"
      require "rational"
      P = Algebra.MPolynomial(Rational)
      P.set_ord :grevlex
      x, y, z = P.vars("xyz")
      f1 = x**2 + y**2 + z**2 -1
      f2 = x**2 + z**2 - y
      f3 = x - z
      b = Groebner.basis([f1, f2, f3])
      p b #=> [y^2 + y - 1, z^2 - 1/2y, x - z]

--- Groebner.basis_159A(f)
    基底の配列 ((|f|)) からグレブナ基底を作り配列として返します。

--- Groebner.minimal_basis(f)
    グレブナ基底の配列 ((|f|)) から極小グレブナ基底の配列を作り返します。

--- Groebner.reduced_basis(f)
    極小グレブナ基底の配列 ((|f|)) から簡約グレブナ基底の配列を作り返します。

--- Groebner.basis_coeff(f)
    基底の配列 ((|f|)) から簡約グレブナ基底の配列と、各基底を生成
    するための係数を返します。

    例:
      require "m-polynomial"
      require "rational"
      P = Algebra.MPolynomial(Rational)
      P.set_ord :grevlex
      x, y, z = P.vars("xyz")
      f1 = x**2 + y**2 + z**2 -1
      f2 = x**2 + z**2 - y
      f3 = x - z
      fs = [f1, f2, f3]
      c, b = Groebner.basis_coeff(fs)
      p b #=> [y^2 + y - 1, z^2 - 1/2y, x - z]
      p c #=> [[1, -1, 0], [0, 1/2, -1/2x - 1/2z], [0, 0, 1]]
      for i in 0..2
        p c[i].inner_product(fs) == b[i] #=> true
      end

--- Groebner.basis?(f)
    ((|f|)) がグレブナ基底の配列か否かを返します。

--- Groebner.minimal_basis?(f)
    ((|f|)) が極小グレブナ基底の配列か否かを返します。

--- Groebner.reduced_basis?(f)
    ((|f|)) が極小グレブナ基底の配列か否かを返します。

== メソッド:
--- S_pair(other)
    ((|other|)) との S-pair を取ります。

    例:
      (x**2*y + y**2 + z**2 -1).S_pair(x**2*z + z**2 - y)
        #=> y^2z + y^2 - yz^2 + z^3 - z

--- divmod_s(f1[, f2[, f3...]])
    基底 (({f1, f2, f3, ...})) で割った商（各基底の係数の配列）
    と余り (({[[q1, q2, q3, ...], r]})) を返します。

    一度 (({f1, f2, f3, ...})) をグレブナ基底に変換してから
    割り算を行うので、(({divmod(f1, f2, ...).last == 0})) と ((|self|)) が
    イデアル (({(f1, f2, ...)})) に属することは同値です。

    例:
      require "m-polynomial"
      require "rational"
      P = Algebra.MPolynomial(Rational)
      P.set_ord :grevlex
      x, y, z = P.vars("xyz")
      f1 = x**2 + y**2 + z**2 -1
      f2 = x**2 + z**2 - y
      f3 = x - z
      fs = [f1, f2, f3]
      f = x**3 + y**3 + z**3
      c, r = f.divmod_s(*fs)
      p r #=> yz + 2y - 1
      p c #=> [y - 1, -y + z + 1, x^2]
      p f == c.inner_product(fs) + r #=> true

--- div_cg(f, cg)
    基底の配列 ((|f|)) から ((<Groebner.basis_coeff>))(f)
    で求めた値 ((|cg|)) を用いて((|self|)) を基底 ((|f|)) で
    割った商（各基底の係数の配列）と余り (({[q, r]})) を返します。
    ((<divmod_s>))(f) は
    (({div_cg(f, Groebner.basis_coeff(f))})) を返しています。

=end


x <- tibble::tribble(
 ~chrom, ~start, ~end,
 'chr1', 100,    250,
 'chr2', 250,    500
)

y <- tibble::tribble(
 ~chrom, ~start, ~end, ~value,
 'chr1', 100,    250,  10,
 'chr1', 150,    250,  20,
 'chr2', 250,    500,  500
)

bed_glyph(bed_map(x, y, value = sum(value)), label = 'value')

# summary examples
bed_map(x, y, .sum = sum(value))

bed_map(x, y, .min = min(value), .max = max(value))

# identify non-intersecting intervals to include in the result
res <- bed_map(x, y, .sum = sum(value))
x_not <- bed_intersect(x, y, invert = TRUE)
dplyr::bind_rows(res, x_not)

# create a list-column
bed_map(x, y, .values = list(value))

# use `nth` family from dplyr
bed_map(x, y, .first = dplyr::first(value))

bed_map(x, y, .absmax = abs(max(value)))

bed_map(x, y, .count = length(value))

bed_map(x, y, .vals = values(value))

# count defaults are NA not 0; differs from bedtools2 ...
bed_map(x, y, .counts = dplyr::n())

# ... but NA counts can be coverted to 0's
dplyr::mutate(bed_map(x, y, .counts = dplyr::n()), .counts = ifelse(is.na(.counts), 0, .counts))


get.top.N.salaries <- function(N)
{
   with(dfr, tapply(Salary, Department,
      function(x)
      {
         sort(x);
         lx <- length(x)
         if(N >= lx) return(x)
         x[-1:(N-lx)]
      }))
}

get.top.N.salaries(3)


#==============================================================================
#	Unit test of cv.group with class stratification
#==============================================================================
library(testthat)
library(cv.models)
library(randomForest)

#------------------------------------------------------------------------------
context("Unit test for cv.group with class stratification.")

#------------------------------------------------------------------------------
#	Create biased iris data.
#------------------------------------------------------------------------------
biased.iris <- function() {
	iris2 <- iris[iris$Species != "setosa", ]
	iris2 <- rbind(iris2, head(iris[iris$Species == "setosa", ], 10))
	return(iris2)
}

#------------------------------------------------------------------------------
#	Create cv.models object for testing.
#------------------------------------------------------------------------------
create.test.cv.models.object <- function(stratify) {
	iris2 <- biased.iris()
	call <- substitute(randomForest(Species ~ ., data = iris2))
	object <- list(
		call = call, folds = 10, stratify = stratify,
		adapter = model.adapter::model.adapter$new(call, environment(), NULL)
	)
	class(object) <- "cv.models"
	return(object)
}

#------------------------------------------------------------------------------
#	Create test data.
#------------------------------------------------------------------------------
create.test.data.for.stratification <- function(stratify) {
	object <- create.test.cv.models.object(stratify)
	group <- cv.models:::cv.group(object)
	y <- object$adapter$y.vars[[1]]
	test.df <- data.frame(y = y, group = group)
	test.df.split <- split(test.df, group)
	return(test.df.split)
}

#------------------------------------------------------------------------------
#	Try grouping and test all groups have "setosa".
#------------------------------------------------------------------------------
try.and.test.having.setosa <- function(stratify, times = 10) {
	results <- rep(NA, times)
	for (i in 1:times) {
		test.df.split <- create.test.data.for.stratification(
			stratify = stratify
		)
		has.setosa <- sapply(test.df.split, function(x) "setosa" %in% x$y)
		results[i] <- all(has.setosa)
	}
	return(results)
}

#------------------------------------------------------------------------------
test_that(
	"Test cv.group assigns same number of observations for each group.", {
		try.test <- function(stratify) {
			object <- create.test.cv.models.object(stratify = stratify)
			group <- cv.models:::cv.group(object)
			n.obs <- tapply(group, group, length)
			expect_true(
				length(unique(n.obs)) <= 2,
				info = sprintf(
					"Test number of group sizes <= 2: stratify = %s",
					stratify
				)
			)
			expect_true(
				(range(n.obs)[2] - range(n.obs)[1]) %in% 0:1,
				info = sprintf(
					"Test all groups have (nearly) equal size: stratify = %s",
					stratify
				)
			)
		}
		# To avoid occasional pass of test, try 10 times.
		for (i in 1:10) {
			try.test(stratify = FALSE)
			try.test(stratify = TRUE)
		}
	}
)

#------------------------------------------------------------------------------
test_that(
	"Test 'stratify = TRUE' makes stratified groups.", {
		# Check all groups have "setosa".
		# Because splitting use stochastic process, try 10 times to avoid
		# passing the test by occasional stratification.
		results <- try.and.test.having.setosa(stratify = TRUE, times = 10)
		expect_true(all(results), info = "Test all groups have setosa.")
	}
)

#------------------------------------------------------------------------------
test_that(
	"Test 'stratify = FALSE' makes non-stratified groups.", {
		# Check some groups don't have "setosa".
		# Because splitting use stochastic process, try 10 times to avoid
		# failing the test by occasional stratification.
		results <- try.and.test.having.setosa(stratify = FALSE, times = 10)
		expect_false(
			all(results), info = "Test some groups don't have setosa."
		)
	}
)

#------------------------------------------------------------------------------
test_that(
	"Test 'stratify = TRUE' for regression model produce error.", {
		call <- substitute(randomForest(Petal.Length ~ ., data = iris))
		object <- list(
			call = call, folds = 10, stratify = TRUE,
			adapter = model.adapter::model.adapter$new(
				call, environment(), NULL
			)
		)
		class(object) <- "cv.models"
		# regexp <- paste0(
		# 	"Currently, class stratification is not supported for \n",
		# 	"regression models\\."
		# )
		# expect_error(cv.models:::cv.group(object), regexp)
		expect_error(cv.models:::cv.group(object))
	}
)

#------------------------------------------------------------------------------
test_that(
	"Test produce warning when 'folds' > minimum number of observations", {
		iris2 <- biased.iris()
		call <- substitute(randomForest(Species ~ ., data = iris2))
		object <- list(
			call = call, folds = 20, stratify = TRUE,
			adapter = model.adapter::model.adapter$new(
				call, environment(), NULL
			)
		)
		class(object) <- "cv.models"
		# regexp <- paste0(
		# 	"Number\\(s\\) of observations in a class of response variable \n",
		# 	"is smaller than the number of 'fold'\\."
		# )
		# expect_warning(cv.models:::cv.group(object), regexp)
		expect_warning(cv.models:::cv.group(object))
	}
)

rm(
	biased.iris,
	create.test.cv.models.object,
	create.test.data.for.stratification,
	try.and.test.having.setosa
)

#==============================================================================
#	Unit test of cv.group with user defined group
#==============================================================================

context("Unit test for cv.group with user defined group.")

test_that(
	"Test user defined group with different variable types", {
		create.test.object <- function(group) {
			call <- substitute(randomForest(Petal.Length ~ ., data = iris))
			object <- list(
				call = call, group = group,
				adapter = model.adapter::model.adapter$new(
					call, environment(), NULL
				)
			)
			class(object) <- "cv.models"
			return(object)
		}
		# Test number of groups.
		obj <- create.test.object(rep(c("a","b"), each = 75))
		expect_equal(length(unique(cv.models:::cv.group(obj))), 2)
		obj <- create.test.object(rep(1:3, each = 50))
		expect_equal(length(unique(cv.models:::cv.group(obj))), 3)
		obj <- create.test.object(rep(c(TRUE, FALSE), each = 75))
		expect_equal(length(unique(cv.models:::cv.group(obj))), 2)
		obj <- create.test.object(iris$Species)
		expect_equal(length(unique(cv.models:::cv.group(obj))), 3)
		# Test invalid group actually produce error.
		obj <- create.test.object(list(1))
		expect_error(cv.models:::cv.group(obj))
	}
)


library("NoiseFiltersR")

MyData <- read.csv(file="c:/../nepal_earthquake_tra.csv", header=TRUE, sep=",")

data(iris)
# We fix a seed since there exists a random partition for the ensemble
set.seed(1)
out <- CVCF(Species~.-Sepal.Width, data = iris)
print(out)
identical(out$cleanData, iris[setdiff(1:nrow(iris),out$remIdx),])